(* ssa-fn.sml * * This code is part of the Diderot Project (http://diderot-language.cs.uchicago.edu) * * COPYRIGHT (c) 2015 The University of Chicago * All rights reserved. * * The SSAFn functor is used to generate the High, Med, and Low ILs in the Diderot * compiler. These ILs have the same program and control-flow structure, but differ * in their types and operators. *) functor SSAFn ( val ilName : string structure Ty : SSA_TYPES structure Op : OPERATORS where type ty = Ty.ty ) : SSA = struct structure Ty = Ty structure Op = Op val ilName = ilName (***** strand state variables *****) datatype state_var = SV of { id : Stamp.stamp, (* variable's unique ID *) name : string, (* variable's name *) ty : Ty.ty, (* variable's type *) output : bool, (* true for output variables *) props : PropList.holder } (***** CFG *****) datatype cfg = CFG of { entry : node, (* the entry node of a graph; not necessarily an ENTRY node *) exit : node (* the exit node of a graph; not necessarily an EXIT node. *) } and node = ND of { id : Stamp.stamp, props : PropList.holder, kind : node_kind } and node_kind = NULL | ENTRY of { succ : node ref } | JOIN of { preds : node list ref, phis : phi list ref, succ : node ref } | COND of { pred : node ref, cond : var, trueBranch : node ref, falseBranch : node ref } | COM of { (* comment *) pred : node ref, text : string list, succ : node ref } | ASSIGN of { (* assignment *) pred : node ref, stm : assign, succ : node ref } | MASSIGN of { (* multi-assignment *) pred : node ref, stm : massign, succ : node ref } | NEW of { (* create new strand instance *) pred : node ref, strand : Atom.atom, args : var list, succ : node ref } | SAVE of { (* save state variable *) pred: node ref, lhs : state_var, rhs : var, succ : node ref } | EXIT of { (* includes die and stabilize *) pred : node ref, kind : ExitKind.kind, (* kind of exit node *) live : var list (* live variables *) } and rhs = STATE of state_var (* read strand state variable *) | VAR of var | LIT of Literal.literal | OP of Op.rator * var list | APPLY of MathFuns.name * var list (* basis function application *) | CONS of Ty.ty * var list (* tensor/sequence-value construction *) and var = V of { name : string, (* name *) id : Stamp.stamp, (* unique ID *) ty : Ty.ty, (* type *) bind : var_bind ref, (* binding *) useCnt : int ref, (* count of uses *) props : PropList.holder } and var_bind = VB_NONE | VB_RHS of rhs (* defined by an assignment (includes globals and state variables) *) | VB_MULTIOP of int * Op.rator * var list (* n'th result of operator in multi-assignment *) | VB_PHI of var list (* defined by a phi node *) | VB_PARAM (* parameter to a strand *) withtype assign = (var * rhs) and massign = (var list * Op.rator * var list) and phi = (var * var list) datatype assignment = ASSGN of assign | MASSGN of massign (***** Program representation *****) datatype program = Program of { props : StrandUtil.program_prop list, globalInit : cfg, initially : initially, strands : strand list } and initially = Initially of { isArray : bool, (* true for initially array, false for collection *) rangeInit : cfg, (* code to compute bounds of iteration *) iters : (var * var * var) list, create : (cfg * Atom.atom * var list) } and strand = Strand of { name : Atom.atom, params : var list, state : state_var list, stateInit : cfg, methods : method list } and method = Method of { name : StrandUtil.method_name, body : cfg (* method body *) } structure StateVar = struct fun new (isOut, name, ty) = SV{ id = Stamp.new(), name = name, ty = ty, output = isOut, props = PropList.newHolder() } fun name (SV{name, ...}) = name fun ty (SV{ty, ...}) = ty fun isOutput (SV{output, ...}) = output fun same (SV{id=a, ...}, SV{id=b, ...}) = Stamp.same(a, b) fun compare (SV{id=a, ...}, SV{id=b, ...}) = Stamp.compare(a, b) fun hash (SV{id, ...}) = Stamp.hash id fun toString (SV{name, ...}) = "self." ^ name (* properties *) fun newProp initFn = PropList.newProp (fn (SV{props, ...}) => props, initFn) fun newFlag () = PropList.newFlag (fn (SV{props, ...}) => props) (* collections *) local structure V = struct type ord_key = state_var val compare = compare end in structure Map = RedBlackMapFn (V) structure Set = RedBlackSetFn (V) end structure Tbl = HashTableFn ( struct type hash_key = state_var val hashVal = hash val sameKey = same end) end structure Var = struct fun new (name, ty) = V{ name = name, id = Stamp.new(), ty = ty, bind = ref VB_NONE, useCnt = ref 0, props = PropList.newHolder() } fun copy (V{name, ty, ...}) = new (name, ty) fun name (V{name, ...}) = name fun ty (V{ty, ...}) = ty fun binding (V{bind, ...}) = !bind fun setBinding (V{bind, ...}, vb) = bind := vb fun useCount (V{useCnt, ...}) = !useCnt fun same (V{id=a, ...}, V{id=b, ...}) = Stamp.same(a, b) fun compare (V{id=a, ...}, V{id=b, ...}) = Stamp.compare(a, b) fun hash (V{id, ...}) = Stamp.hash id fun toString (V{name, id, ...}) = name ^ Stamp.toString id (* properties *) fun newProp initFn = PropList.newProp (fn (V{props, ...}) => props, initFn) fun newFlag () = PropList.newFlag (fn (V{props, ...}) => props) (* collections *) local structure V = struct type ord_key = var val compare = compare end in structure Map = RedBlackMapFn (V) structure Set = RedBlackSetFn (V) end structure Tbl = HashTableFn ( struct type hash_key = var val hashVal = hash val sameKey = same end) end structure Node = struct fun id (ND{id, ...}) = id fun kind (ND{kind, ...}) = kind fun same (ND{id=a, ...}, ND{id=b, ...}) = Stamp.same(a, b) fun compare (ND{id=a, ...}, ND{id=b, ...}) = Stamp.compare(a, b) fun hash (ND{id, ...}) = Stamp.hash id fun toString (ND{id, kind, ...}) = let val tag = (case kind of NULL => "NULL" | ENTRY _ => "ENTRY" | JOIN _ => "JOIN" | COND _ => "COND" | COM _ => "COM" | ASSIGN _ => "ASSIGN" | MASSIGN _ => "MASSIGN" | NEW _ => "NEW" | SAVE _ => "SAVE" | EXIT{kind, ...} => ExitKind.toString kind (* end case *)) in tag ^ Stamp.toString id end fun new kind = ND{id = Stamp.new(), props = PropList.newHolder(), kind = kind} (* variable defs and uses *) fun uses (ND{kind, ...}) = (case kind of JOIN{phis, ...} => List.foldr (fn ((_, xs), ys) => xs@ys) [] (!phis) | COND{cond, ...} => [cond] | ASSIGN{stm=(y, rhs), ...} => (case rhs of STATE _ => [] | VAR x => [x] | LIT _ => [] | OP(_, args) => args | APPLY(_, args) => args | CONS(_, args) => args (* end case *)) | MASSIGN{stm=(_, _, args), ...} => args | NEW{args, ...} => args | SAVE{rhs, ...} => [rhs] | EXIT{live, ...} => live | _ => [] (* end case *)) fun defs (ND{kind, ...}) = (case kind of JOIN{phis, ...} => List.map #1 (!phis) | ASSIGN{stm=(y, _), ...} => [y] | MASSIGN{stm=(ys, _, _), ...} => ys | _ => [] (* end case *)) val dummy = new NULL fun mkENTRY () = new (ENTRY{succ = ref dummy}) fun mkJOIN phis = new (JOIN{preds = ref [], phis = ref phis, succ = ref dummy}) fun mkCOND {cond, trueBranch, falseBranch} = new (COND{ pred = ref dummy, cond = cond, trueBranch = ref trueBranch, falseBranch = ref falseBranch }) fun mkCOM text = new (COM{pred = ref dummy, text = text, succ = ref dummy}) fun mkASSIGN (lhs, rhs) = ( Var.setBinding (lhs, VB_RHS rhs); new (ASSIGN{pred = ref dummy, stm = (lhs, rhs), succ = ref dummy})) fun mkMASSIGN (lhs, rator, args) = let fun setB (_, []) = () | setB (i, x::xs) = ( Var.setBinding (x, VB_MULTIOP(i, rator, args)); setB (i+1, xs)) in setB (0, lhs); new (MASSIGN{pred = ref dummy, stm = (lhs, rator, args), succ = ref dummy}) end fun mkNEW {strand, args} = new (NEW{ pred = ref dummy, strand = strand, args = args, succ = ref dummy }) fun mkSAVE (lhs, rhs) = new (SAVE{ pred = ref dummy, lhs = lhs, rhs = rhs, succ = ref dummy }) fun mkEXIT (kind, xs) = new (EXIT{kind = kind, live = xs, pred = ref dummy}) fun mkFRAGMENT xs = mkEXIT (ExitKind.FRAGMENT, xs) fun mkSINIT () = mkEXIT (ExitKind.SINIT, []) fun mkRETURN xs = mkEXIT (ExitKind.RETURN, xs) fun mkACTIVE () = mkEXIT (ExitKind.ACTIVE, []) fun mkSTABILIZE () = mkEXIT (ExitKind.STABILIZE, []) fun mkDIE () = mkEXIT (ExitKind.DIE, []) fun isNULL (ND{kind=NULL, ...}) = true | isNULL _ = false (* editing node edges *) fun hasPred (ND{kind, ...}) = (case kind of NULL => false | ENTRY _ => false | _ => true (* end case *)) fun setPred (nd0 as ND{kind, ...}, nd) = (case kind of NULL => raise Fail("setPred on NULL node " ^ toString nd0) | ENTRY _ => raise Fail("setPred on ENTRY node " ^ toString nd0) | JOIN{preds, ...} => if List.exists (fn nd' => same(nd, nd')) (!preds) then () else preds := !preds @ [nd] (* assume preds are added in order *) | COND{pred, ...} => pred := nd | COM{pred, ...} => pred := nd | ASSIGN{pred, ...} => pred := nd | MASSIGN{pred, ...} => pred := nd | NEW{pred, ...} => pred := nd | SAVE{pred, ...} => pred := nd | EXIT{pred, ...} => pred := nd (* end case *)) fun preds (nd as ND{kind, ...}) = (case kind of NULL => [] (*raise Fail("preds on NULL node "^toString nd)*) | ENTRY _ => [] | JOIN{preds, ...} => !preds | COND{pred, ...} => [!pred] | COM{pred, ...} => [!pred] | ASSIGN{pred, ...} => [!pred] | MASSIGN{pred, ...} => [!pred] | NEW{pred, ...} => [!pred] | SAVE{pred, ...} => [!pred] | EXIT{pred, ...} => [!pred] (* end case *)) fun hasSucc (ND{kind, ...}) = (case kind of NULL => false | ENTRY _ => true | JOIN _ => true | COND _ => true | COM _ => true | ASSIGN _ => true | MASSIGN _ => true | NEW _ => true | SAVE _ => true | EXIT _ => false (* end case *)) fun setSucc (nd0 as ND{kind, ...}, nd) = (case kind of NULL => raise Fail("setSucc on NULL node "^toString nd0) | ENTRY{succ} => succ := nd | JOIN{succ, ...} => succ := nd | COND _ => raise Fail("setSucc on COND node "^toString nd0) | COM{succ, ...} => succ := nd | ASSIGN{succ, ...} => succ := nd | MASSIGN{succ, ...} => succ := nd | NEW{succ, ...} => succ := nd | SAVE{succ, ...} => succ := nd | EXIT _ => raise Fail("setSucc on EXIT node "^toString nd0) (* end case *)) fun succs (nd as ND{kind, ...}) = (case kind of NULL => [] (*raise Fail("succs on NULL node "^toString nd)*) | ENTRY{succ} => [!succ] | JOIN{succ, ...} => [!succ] | COND{trueBranch, falseBranch, ...} => [!trueBranch, !falseBranch] | COM{succ, ...} => [!succ] | ASSIGN{succ, ...} => [!succ] | MASSIGN{succ, ...} => [!succ] | NEW{succ, ...} => [!succ] | SAVE{succ, ...} => [!succ] | EXIT _ => [] (* end case *)) fun setTrueBranch (ND{kind=COND{trueBranch, ...}, ...}, nd) = trueBranch := nd | setTrueBranch (nd, _) = raise Fail("setTrueBranch on " ^ toString nd) fun setFalseBranch (ND{kind=COND{falseBranch, ...}, ...}, nd) = falseBranch := nd | setFalseBranch (nd, _) = raise Fail("setFalseBranch on " ^ toString nd) fun addEdge (nd1, nd2) = ( if hasSucc nd1 then ( setSucc (nd1, nd2); setPred (nd2, nd1)) else ()) (*DEBUG*)handle ex => ( print(concat["error in addEdge(", toString nd1, ",", toString nd2, ")\n"]); raise ex) fun replaceInEdge {src, oldDst, dst} = ( (* first set the successor of src *) case kind src of COND{trueBranch, falseBranch, ...} => if same(!trueBranch, oldDst) then trueBranch := dst else falseBranch := dst | _ => setSucc (src, dst) (* end case *); (* then set the predecessor of dst *) setPred (dst, src)) (*DEBUG*)handle ex => ( print(concat["error in replaceInEdge(", toString src, ",", toString oldDst, ",", toString dst, ")\n"]); raise ex) fun replaceOutEdge {oldSrc, src, dst} = ( (* first set the successor of src *) case kind oldSrc of COND{trueBranch, falseBranch, ...} => if same(!trueBranch, dst) then setTrueBranch (src, dst) else setFalseBranch (src, dst) | _ => setSucc (src, dst) (* end case *); (* then set the predecessor of dst *) case kind dst of JOIN{preds, ...} => let fun edit [] = raise Fail "replaceOutEdge: cannot find predecessor" | edit (nd::nds) = if same(nd, oldSrc) then src::nds else nd::edit nds in preds := edit (!preds) end | _ => setPred (dst, src) (* end case *)) (*DEBUG*)handle ex => ( print(concat["error in replaceOutEdge(", toString oldSrc, ",", toString src, ",", toString dst, ")\n"]); raise ex) (* properties *) fun newProp initFn = PropList.newProp (fn (ND{props, ...}) => props, initFn) fun newFlag () = PropList.newFlag (fn (ND{props, ...}) => props) end structure CFG = struct val empty = CFG{entry = Node.dummy, exit = Node.dummy} fun isEmpty (CFG{entry, exit}) = Node.same(entry, exit) andalso Node.isNULL entry (* create a basic block from a list of assignments *) fun mkBlock [] = empty | mkBlock (stm::stms) = let fun mkNode (ASSGN stm) = Node.mkASSIGN stm | mkNode (MASSGN stm) = Node.mkMASSIGN stm val entry = mkNode stm fun f (stm, prev) = let val nd = mkNode stm in Node.addEdge (prev, nd); nd end val exit = List.foldl f entry stms in CFG{entry = entry, exit = exit} end (* entry/exit nodes of a CFG *) fun entry (CFG{entry = nd, ...}) = nd fun exit (CFG{exit = nd, ...}) = nd (* return the list of variables that are live at exit from a CFG *) fun liveAtExit cfg = (case Node.kind(exit cfg) of EXIT{live, ...} => live | _ => raise Fail "bogus exit node" (* end case *)) (* DFS sorting of the graph rooted at the entry to a statement; the resulting list will * be in preorder with parents before children. *) fun sort (CFG{entry, ...}) = let val {getFn, setFn} = PropList.newFlag (fn (ND{props, ...}) => props) fun dfs (nd, l) = if getFn nd then l else ( setFn (nd, true); nd :: List.foldl dfs l (Node.succs nd)) val nodes = dfs (entry, []) in List.app (fn nd => setFn(nd, false)) nodes; nodes end (* apply a function to all of the nodes in the graph rooted at the entry to the statement *) fun apply (f : node -> unit) (CFG{entry, ...}) = let val {getFn, setFn} = Node.newFlag() fun dfs (nd, l) = if getFn nd then l else ( f nd; (* visit *) setFn (nd, true); nd :: List.foldl dfs l (Node.succs nd)) val nodes = dfs (entry, []) in List.app (fn nd => setFn(nd, false)) nodes end (* delete a simple node from a CFG *) fun deleteNode (nd as ND{kind, ...}) = let val (pred, succ) = (case kind of COM{pred = ref pred, succ = ref succ, ...} => (pred, succ) | ASSIGN{pred = ref pred, succ = ref succ, ...} => (pred, succ) | MASSIGN{pred = ref pred, succ = ref succ, ...} => (pred, succ) | NEW{pred = ref pred, succ = ref succ, ...} => (pred, succ) | SAVE{pred = ref pred, succ = ref succ, ...} => (pred, succ) | _ => raise Fail(concat["unsupported deleteNode(", Node.toString nd, ")\n"]) (* end case *)) in Node.setPred (succ, pred); case Node.kind pred of COND{trueBranch, falseBranch, ...} => ( (* note that we treat each branch independently, so that we handle the * situation where both branches are the same node. *) if Node.same(!trueBranch, nd) then Node.setTrueBranch(pred, succ) else (); if Node.same(!falseBranch, nd) then Node.setFalseBranch(pred, succ) else ()) | _ => Node.setSucc (pred, succ) (* end case *) end (*DEBUG*)handle ex => ( print(concat["error in deleteNode(", Node.toString nd, ")\n"]); raise ex) (* replace a simple node in a cfg with a subgraph *) fun replaceNode (oldNd as ND{kind, ...}, node) = (case kind of ASSIGN{pred, succ, ...} => ( Node.replaceInEdge {src = !pred, oldDst = oldNd, dst = node}; Node.replaceOutEdge {oldSrc = oldNd, src = node, dst = !succ}) | MASSIGN{pred, succ, ...} => ( Node.replaceInEdge {src = !pred, oldDst = oldNd, dst = node}; Node.replaceOutEdge {oldSrc = oldNd, src = node, dst = !succ}) | NEW{pred, succ, ...} => ( Node.replaceInEdge {src = !pred, oldDst = oldNd, dst = node}; Node.replaceOutEdge {oldSrc = oldNd, src = node, dst = !succ}) | SAVE{pred, succ, ...} => ( Node.replaceInEdge {src = !pred, oldDst = oldNd, dst = node}; Node.replaceOutEdge {oldSrc = oldNd, src = node, dst = !succ}) | EXIT{pred, ...} => Node.replaceInEdge {src = !pred, oldDst = oldNd, dst = node} | _ => raise Fail "unsupported replaceNode" (* end case *)) (* replace a simple node in a cfg with a subgraph *) fun replaceNodeWithCFG (nd as ND{kind, ...}, cfg as CFG{entry, exit}) = if isEmpty cfg then deleteNode nd else (case kind of ASSIGN{pred, succ, ...} => ( Node.replaceInEdge {src = !pred, oldDst = nd, dst = entry}; Node.replaceOutEdge {oldSrc = nd, src = exit, dst = !succ}) | MASSIGN{pred, succ, ...} => ( Node.replaceInEdge {src = !pred, oldDst = nd, dst = entry}; Node.replaceOutEdge {oldSrc = nd, src = exit, dst = !succ}) | _ => raise Fail "unsupported replaceNodeWithCFG" (* end case *)) (* concatenate two CFGs *) fun concat (cfg1 as CFG{entry=e1, exit=x1}, cfg2 as CFG{entry=e2, exit=x2}) = if isEmpty cfg1 then cfg2 else if isEmpty cfg2 then cfg1 else ( Node.setSucc (x1, e2); Node.setPred (e2, x1); CFG{entry = e1, exit = x2}) (*DEBUG*)handle ex => ( print(String.concat["error in concat({", Node.toString e1, ",", Node.toString x1, "},{", Node.toString e2, ",", Node.toString x2, "})\n"]); raise ex) (* prepend a node to a CFG *) fun prependNode (nd, cfg as CFG{entry, exit}) = if isEmpty cfg then CFG{entry=nd, exit=nd} else ( Node.setSucc (nd, entry); Node.setPred (entry, nd); CFG{entry=nd, exit=exit}) (* append a node to a CFG *) fun appendNode (cfg as CFG{entry, exit}, nd) = if isEmpty cfg then CFG{entry=nd, exit=nd} else ( Node.setPred (nd, exit); Node.setSucc (exit, nd); CFG{entry=entry, exit=nd}) (* update the exit of a CFG by modifying the live variable list *) fun updateExit (CFG{entry, exit as ND{kind, ...}}, f) = let val newExit = (case kind of EXIT{pred, kind, live} => let val newNd = Node.mkEXIT(kind, f live) in Node.replaceInEdge {src = !pred, oldDst = exit, dst = newNd}; newNd end | _ => raise Fail "bogus exit node for updateExit" (* end case *)) in CFG{entry=entry, exit=newExit} end end structure RHS = struct fun vars rhs = (case rhs of STATE x => [] | VAR x => [x] | LIT _ => [] | OP(rator, xs) => xs | APPLY(g, xs) => xs | CONS(ty, xs) => xs (* end case *)) fun map f = let fun mapf rhs = (case rhs of STATE _ => rhs | VAR x => VAR(f x) | LIT _ => rhs | OP(rator, xs) => OP(rator, List.map f xs) | APPLY(g, xs) => APPLY(g, List.map f xs) | CONS(ty, xs) => CONS(ty, List.map f xs) (* end case *)) in mapf end fun app f = let fun appf rhs = (case rhs of STATE _ => () | VAR x => f x | LIT _ => () | OP(rator, xs) => List.app f xs | APPLY(_, xs) => List.app f xs | CONS(ty, xs) => List.app f xs (* end case *)) in appf end (* return a string representation of a rhs *) fun toString rhs = (case rhs of STATE x => StateVar.toString x | VAR x => Var.toString x | LIT lit => Literal.toString lit | OP(rator, xs) => String.concat [ Op.toString rator, "(", String.concatWith "," (List.map Var.toString xs), ")" ] | APPLY(f, xs) => String.concat [ MathFuns.toString f, "(", String.concatWith "," (List.map Var.toString xs), ")" ] | CONS(ty, xs) => String.concat [ "<", Ty.toString ty, ">[", String.concatWith "," (List.map Var.toString xs), "]" ] (* end case *)) end (* return a string representation of a variable binding *) fun vbToString VB_NONE = "NONE" | vbToString (VB_RHS rhs) = concat["RHS(", RHS.toString rhs, ")"] | vbToString (VB_MULTIOP(i, rator, xs)) = concat[ "MULTIOP(", Op.toString rator, "[", String.concatWith "," (List.map Var.toString xs), "])" ] | vbToString (VB_PHI xs) = concat[ "PHI(", String.concatWith "," (List.map Var.toString xs), ")" ] | vbToString VB_PARAM = "PARAM" (* return a string representation of a PHI node *) fun phiToString (y, xs) = String.concat [ Ty.toString(Var.ty y), " ", Var.toString y, " = PHI(", String.concatWith "," (List.map Var.toString xs), ")" ] (* return a string representation of an assignment *) fun assignToString (y, rhs) = String.concat [Ty.toString(Var.ty y), " ", Var.toString y, " = ", RHS.toString rhs] fun massignToString (ys, rator, xs) = String.concat [ "(", String.concatWith "," (List.map (fn y => concat[Ty.toString(Var.ty y), " ", Var.toString y]) ys), " = ", Op.toString rator, "(", String.concatWith "," (List.map Var.toString xs), ")" ] fun assignmentToString (ASSGN asgn) = assignToString asgn | assignmentToString (MASSGN masgn) = massignToString masgn end (* SSAFn *)
Click to toggle
does not end with </html> tag
does not end with </body> tag
The output has ended thus: gnToString asgn | assignmentToString (MASSGN masgn) = massignToString masgn end (* SSAFn *)