Contents

Recognizing RTLs

[*] This chapter implements the abstract RTL interface such that an attribute is almost a recognizer for instructions. The ``almost'' comes in because the actual recognizer for an instruction depends on the recognizers for its operands, so what we really have is a function that, given recognizers for operands, produces recognizers for instructins.

Introduction

This implementation is currently incomplete, but here are the interesting elements.

Guard expressions

I make patterns into expressions for purposes of computing guards. I go to some effort to make negation fairly sophisticated; see the guard.nw module for the requirements of the interface. 

<urecrtl.sml>= [D->]
structure PatternGuardExp : GUARD_EXP = struct
  structure P = RtlPattern
  type exp = P.exp

  val true'  = P.BOOL true
  val false' = P.BOOL false

  fun negate (P.BOOL b) = P.BOOL (not b)
    | negate (P.APP (("not", []), [e])) = e
    | negate (P.APP (("conjoin", []), l)) = P.APP (("disjoin", []), map negate l) 
    | negate (P.APP (("disjoin", []), l)) = P.APP (("conjoin", []), map negate l) 
    | negate (P.APP (("eq", ws), es)) = P.APP (("ne", ws), es)
    | negate (P.APP (("ne", ws), es)) = P.APP (("eq", ws), es)
    | negate (P.APP (("lt", ws), es)) = P.APP (("ge", ws), es)
    | negate (P.APP (("ge", ws), es)) = P.APP (("lt", ws), es)
    | negate (P.APP (("gt", ws), es)) = P.APP (("le", ws), es)
    | negate (P.APP (("le", ws), es)) = P.APP (("gt", ws), es)
    | negate e = P.APP (("not", []), [e])

  fun isTrue (P.BOOL b) = b
    | isTrue (P.APP (("not", []), [e])) = isFalse e
    | isTrue (P.APP (("conjoin", []), l)) = List.all    isTrue l
    | isTrue (P.APP (("disjoin", []), l)) = List.exists isTrue l
    | isTrue e = false
  and isFalse (P.BOOL b) = not b
    | isFalse (P.APP (("not", []), [e])) = isTrue e
    | isFalse (P.APP (("conjoin", []), l)) = List.exists isFalse l
    | isFalse (P.APP (("disjoin", []), l)) = List.all    isFalse l
    | isFalse e = false
    
(**************
  fun foldConjunction f (e, answer) =
    case e
      of P.APP (("conjoin", []), l) => foldl (foldConjunction f) answer l
       | e => f (e, answer)
  
  fun combine ((atomic, atomic'), conjunction) =
    if existsConjunction (fn e => 
    
**********)
  fun existsConjunction f (P.APP (("conjoin", []), l)) =
        List.exists (existsConjunction f) l
    | existsConjunction f e = f e

  fun filterConjunction conjoin f (P.APP (("conjoin", []), l)) =
        foldl conjoin true' (map (filterConjunction conjoin f) l)
    | filterConjunction conjoin f c = if f c then c else true'

  fun equalityIsContradicted (P.APP (("eq", _), [l , P.INT (n, w)]), q) =
        let fun ne n n' = IntInf.compare (n, n') <> EQUAL
            fun contradicts (P.APP (("eq", _), [l' , P.INT (n', w')])) =
                  w = w' andalso ne n n' andalso l = l'
              | contradicts _ = false
        in  existsConjunction contradicts q
        end
    | equalityIsContradicted _ = false

  fun simpleConjoin (p, q) = P.APP (("conjoin", []), [p, q])

  (* this could probably all be tidied up very simply using relop stuff *)
  fun withConstantEquality p (l, n, w) q =
    let fun ne n n' = IntInf.compare (n, n') <> EQUAL
        fun eq n n' = IntInf.compare (n, n') =  EQUAL
        fun contradicts (P.APP (("eq", _), [l' , P.INT (n', w')])) =
              w = w' andalso ne n n' andalso l = l'
          | contradicts (P.APP (("ne", _), [l' , P.INT (n', w')])) =
              w = w' andalso eq n n' andalso l = l'
          | contradicts _ = false
        fun isImplied (P.APP (("ne", _), [l' , P.INT (n', w')])) =
              w = w' andalso l = l' andalso ne n n'
          | isImplied _ = false (* could do lt, gt, ge, le, etc, but no need yet *)
    in  if existsConjunction contradicts q then false'
        else simpleConjoin (p, filterConjunction conjoin (not o isImplied) q)
    end

  and conjoin (p, q) = 
    if isTrue p then q else if isTrue q then p
    else if isFalse p then p else if isFalse q then q
    else case p
           of P.APP (("eq", _), [l , P.INT (n, w)]) =>
                               withConstantEquality p (l, n, w) q
            | _ => simpleConjoin (p, q)
end
Defines combine, conjoin, equalityIsContradicted, existsConjunction, exp, false', filterConjunction, foldConjunction, isFalse, isTrue, negate, P, PatternGuardExp, simpleConjoin, true', withConstantEquality (links are to index).

I expose more than just the abstract RTL interface: also the guard module and the recognizer type. The debug function works around what would otherwise be a circular dependency with RtlPattern. 

<urecrtl.sig>=
signature PATTERN_RTL = sig
  include ABSTRACT_RTL
  structure G  : GUARD where type Exp.exp = RtlPattern.exp
(*  structure Creation : ABSTRACT_RTL *)
  <recognizer type>
  val debug : (recognizer -> PP.pretty) ref
end
Defines debug, G, PATTERN_RTL (links are to index).

Most of the recognizer is actually RtlPattern; here we just keep track of which kind of recognizer we have at any moment. With expressions and locations, we have guards (grab explanation from previous version---try Nov 1 2000). With effects, we have converted some guards to creation-time conditions. 

<recognizer type>= (<-U U->)
datatype recognizer
  = EFFECT of (RtlPattern.exp * RtlPattern.rtl) list
  | EXP    of RtlPattern.exp G.with_guards
  | LOC    of RtlPattern.loc G.with_guards
  | TUPLE  of recognizer list
  | RECORD of (string * recognizer) list
  | VECTOR of recognizer list
Defines recognizer (links are to index).

The rest of the implementation is straightforward; the only tricky bit is the attribute type, which enables us to inherit the attributes of the operands in order to compute the attributes of an instance. 

<urecrtl.sml>+= [<-D]
(*
structure RtlRecognizer : PATTERN_RTL = struct
*)
signature RECOGNIZER_CREATION_EXP = sig
  structure R : ABSTRACT_RTL
  structure E : GUARD_EXP where type exp = R.exp
end

structure RtlRecognizer (* (Creation : ABSTRACT_RTL) *) : PATTERN_RTL = struct
(*  structure C = Creation *)
  structure P = RtlPattern
  structure G = GuardFun(PatternGuardExp)
  structure R = RtlOperators.Agg
  structure VI = VarInfo

(*  structure Creation = Creation *)
  <recognizer type>

  type 'a recog = (string -> recognizer) -> 'a G.with_guards 

  type attribute = (string -> recognizer) -> recognizer

  type effect   = P.effect recog
  type loc      = P.loc recog
  type exp      = P.exp recog
  type cell     = (char * P.exp) recog
  type operator = P.operator

  type width = int

  type agg = width -> width -> cell -> loc

  exception Failure of string

  <helpers>
  <operators>
  <expressions>
  <locations>
  <cells>
  <effects>
  <attributes>
end
Defines agg, attribute, cell, E, effect, exp, Failure, G, loc, operator, P, R, recog, RECOGNIZER_CREATION_EXP, RtlRecognizer, VI, width (links are to index).

These helper functions are intended to make the monad operations a little more readable. 

<helpers>= (<-U) [D->]
fun gcase     x f = G.map f x
fun gcasepair p f = gcase (G.crossPair p) f
Defines gcase, gcasepair (links are to index).

An operator is just a pair of name and widths. 

<operators>= (<-U)
fun rtlop name ws = (name, ws)
Defines rtlop (links are to index).

The raison d'être of this implementation is to exploit the guard module to handle conditions. 

<expressions>= (<-U) [D->]
fun ifExp (c, t, f) rho = G.ifMap (c rho, t rho, f rho)

(*
fun ifExp (c : exp, t : exp , f : exp) rho =
  let val (c, t, f) = (c rho, t rho, f rho)
      fun onExps (c : P.exp) = 
            let val (early, late) = split c
            in  GC.guard (early, GC.single (G.ifMap (G.single late, t, f))) 
                : P.exp guarded
            end
  in  gmap onExps c
  end

*)
(*
fun ifExp (c : exp, t : exp , f : exp) rho =
  let val (c, t, f) = (c rho, t rho, f rho)
      fun onExps (c : P.exp, t : P.exp, f : P.exp) =
            let val (early, late) = split c
            in  GC.guard (early, GC.single (G.ifMap (G.single late, t, f)))
 :   P.exp guarded
            end
  in  gmap onExps (gmap triple (gcross [c, t, f])) : exp
  end


val lift : 'a G.with_guards -> 'a G.with_guards GC.with_guards =
  let fun lift {guard=g, value=x} =
        let val (early, late) = split g
        in  


fun ifExp (c, t, f) rho =
  let val (c, t, f) = (c rho, t rho, f rho)
      val c = GC.map (G.map split) c (* now condition is split *)
      val (early, late) = (GC.map (G.map #1) c, GC.map (G.map #2) c)
      val lateIf = GC.map (fn 
      (* c is condition with_guards with_guards *)
*)

fun t rho = G.single G.Exp.true'
fun f rho = G.single G.Exp.false'
Defines f, ifExp, lift, t (links are to index).

The other stuff requires suitable unit and map operations on the guards monad. 

<expressions>+= (<-U) [<-D]
fun int w n rho = G.single (P.INT (n, w))
fun fetch w l rho = gcase (l rho) (fn l => P.FETCH(l, w))

fun app (rator, args) rho = 
  gcase (G.crossProduct (applyall rho args)) (fn args => P.APP (rator, args))
Defines app, fetch, int (links are to index).

Helper applyall deals with the attribute inheritance. 

<helpers>+= (<-U) [<-D->]
fun applyall x l = List.map (fn f => f x) l
Defines applyall (links are to index).

There's a problem here with loc; without being able to look up a cell, I don't know what sizes to pass to the identity aggregation. 

<locations>= (<-U)
val ifLoc = ifExp (* polymorphic *)

fun agg a n w cell rho = 
  G.map (fn (space, addr) => P.UNSLICED (a, n, w, space, addr)) (cell rho)
fun bigE x    = agg (R.USER "B") x
fun littleE x = agg (R.USER "L") x
fun loc x     = agg R.ID 99 99 x
fun sliceLoc {width=w, argwidth=aw, lsbwidth=lw} {lsb, arg} rho = 
  gcasepair (lsb rho, arg rho)
    (fn (lsb, arg) =>
           P.SLICED {width=w, argwidth=aw, lsbwidth=lw, lsb=lsb, arg=arg})
Defines agg, bigE, ifLoc, littleE, loc, sliceLoc (links are to index).

Nothing unusual here. 

<cells>= (<-U)
fun cell (c, e) rho = gcase (e rho) (fn e => (c, e))
Defines cell (links are to index).

Again, I exploit the Guard module. I don't implement sequential composition; this module should be wrapped in ``sequential to parallel'' if necessary. 

<effects>= (<-U)
fun guard (g, rtl) rho = G.metaGuard (g rho, rtl rho)

fun seq (ef1, ef2) = Impossible.unimp "sequential composition" 

fun par (ef1, ef2) rho = ef1 rho @ ef2 rho

fun store w (l, e) rho = gcasepair (l rho, e rho) (fn (l, e) => P.STORE (l, e, w))
fun kill l rho = gcase (l rho) P.KILL
fun skip rho = []
Defines guard, kill, par, seq, skip, store (links are to index).

To compute attributes, we need to split guards. The idea is that we split a guard into

Attribute mapping is straightforward. 

<attributes>= (<-U) [D->]
val debug : (recognizer -> PP.pretty) ref =
  ref (fn _ => PP.TEXT "attribute debugger not installed")

fun rtl e : (RtlPattern.exp * RtlPattern.rtl) list = 
  let val conjunctPairs =
        foldl (fn ({guard, value}, pairs) => addpairs (guard, pairs)) [] e
      fun cvt e = P.RTL (map (fn {guard, value} => (guard, value)) e)
      fun onCondition (pairs, results) =
        let val e = G.dropFalse (map (fn ({guard=g, value=eff}) =>
                                   {guard=guardGiven pairs g, value=eff}) e)
            val g = foldl (fn ({true=t, false=f}, c) => G.Exp.conjoin (t, c))
                          G.Exp.true' pairs
        in  if G.Exp.isFalse g then results else (g, cvt e) :: results
        end
  in  allConditions onCondition conjunctPairs
  end
and allConditions f pairs =
  let fun negate {true=t, false=f} = {true=f, false=t}
      fun doWith (decided, [], answer) = f (decided, answer)
        | doWith (decided, cond :: undecided, answer) =
             doWith (cond        :: decided, undecided,
             doWith (negate cond :: decided, undecided, answer))
  in  doWith ([], pairs, [])
  end

structure Attribute = struct
  fun fromEffect e rho =
    let val a = EFFECT (rtl (e rho)) 
        val _ = List.app print ["computed effect = ", PP.flatten (!debug a), "\n"]
    in  a 
    end

  fun unEffect (EFFECT l) = 
        let fun unRtl (g, P.RTL l) =
              let val effects = map (fn (g, v) => {guard=g, value=v}) l
              in  G.dropFalse (G.guard (g, effects))
              end
        in  List.concat (map unRtl l)
        end
    | unEffect _ = Impossible.impossible "non-effect"
  fun toEffect a rho = unEffect (a rho)

  fun fromExp (e : exp) = (fn rho => EXP (e rho)) : attribute
  fun unExp (EXP e) = e
    | unExp a = (*Impossible.impossible "non-exp"*)
       G.single (P.EXPVAR ("this can't happen (non-exp " ^
                           PP.flatten (!debug a) ^ ")"))
  fun toExp a rho = unExp (a rho)

  fun fromLoc (e : loc) = (fn rho => LOC (e rho)) : attribute
  fun unLoc (LOC l) = l
    | unLoc _ = Impossible.impossible "non-loc"
  fun toLoc a rho = unLoc (a rho)
end
Defines allConditions, Attribute, debug, fromEffect, fromExp, fromLoc, rtl, toEffect, toExp, toLoc, unEffect, unExp, unLoc (links are to index).

<attributes>+= (<-U) [<-D->]
fun tuple l rho = TUPLE (map (fn x => x rho) l)
fun tupleSelect k a rho =
  case a rho
    of TUPLE l => 
         (List.nth (l, k-1) handle Subscript =>
             Impossible.impossible ("subscript " ^ Int.toString k ^ " out of bounds " ^
                                    "on tuple of size " ^ Int.toString (length l)))
     | a => a (* bogus *)
Defines tuple, tupleSelect (links are to index).

<attributes>+= (<-U) [<-D->]
fun record l rho = RECORD (map (fn (n, x) => (n, x rho)) l)
fun recordSelect n a rho =
  case a rho
    of RECORD l => 
         (case List.find (fn (n', x) => n = n') l
            of SOME (_, x) => x
             | NONE => Impossible.impossible "Record-type mismatch")
     | a => a (* bogus *)
Defines record, recordSelect (links are to index).

<attributes>+= (<-U) [<-D->]
fun vector l rho = VECTOR (map (fn x => x rho) l)
fun sub (v, i) rho = Impossible.unimp "vector subscript for recognizers"
Defines sub, vector (links are to index).

It's not clear if this is the right lookup for operands, but it will do until something else comes along. 

<attributes>+= (<-U) [<-D]
fun var (VI.INT {early}) v rho = EXP (G.single (P.EXPVAR v))
  | var (VI.LOC)         v rho = LOC (G.single (P.LOCVAR v))
  | var (VI.ATT s)       v rho = rho s (* ???? *)
Defines var (links are to index).

Dealing with the binding-time split is a bear. Here's the general idea:

To deal with all this, we accumulate conjunct pairs.

A basic utility just visits every conjunct in a conjunction. 

<helpers>+= (<-U) [<-D->]
fun foldConjunction f (e, answer) =
  case e
    of P.APP (("conjoin", []), l) => foldl (foldConjunction f) answer l
     | e => f (e, answer)
Defines foldConjunction (links are to index).

A conjunct is interesting only if it can be evaluated early. [Things get worse. If we have an early conjunct we can't express in the source language, we've got big troubles.] 

<helpers>+= (<-U) [<-D->]
fun early (P.INT _) = true
  | early (P.BOOL _) = true
  | early (P.FETCH _) = false
  | early (P.APP (_, args)) = List.all early args
  | early (P.EXPVAR _) = true
Defines early (links are to index).

Here's where we accumulate early conjunct pairs. 

<helpers>+= (<-U) [<-D->]
fun cpair e = {true = e, false = G.Exp.negate e}
fun hasExp   e = List.exists (fn {true=t, false=f} => t = e orelse f = e) 
fun hasTrue  e = List.exists (fn {true=t, false=f} => t = e)
fun hasFalse e = List.exists (fn {true=t, false=f} => f = e)
fun addpairs (e, pairs) =
  foldConjunction
    (fn (e, pairs) =>
     if not (early e) orelse hasExp e pairs then pairs else cpair e :: pairs)
    (e, pairs)
Defines addpairs, cpair, hasExp, hasFalse, hasTrue (links are to index).

If we're given a bunch of pairs, what happens to the guard? It's just as we've said above. 

<helpers>+= (<-U) [<-D]
fun guardGiven pairs g =
  foldConjunction 
    (fn (e, g) => if hasFalse e pairs then P.BOOL false
                  else if hasTrue e pairs then g
                  else G.Exp.conjoin (e, g))
  (g, P.BOOL true)
Defines guardGiven (links are to index).