Home My Page Projects Code Snippets Project Openings diderot
Summary Activity Tracker Tasks SCM

SCM Repository

[diderot] Annotation of /branches/lamont/src/compiler/IL/ssa-fn.sml
ViewVC logotype

Annotation of /branches/lamont/src/compiler/IL/ssa-fn.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2246 - (view) (download)

1 : jhr 137 (* ssa-fn.sml
2 : jhr 124 *
3 : jhr 1232 * COPYRIGHT (c) 2011 The Diderot Project (http://diderot-language.cs.uchicago.edu)
4 : jhr 124 * All rights reserved.
5 : jhr 137 *
6 : jhr 1116 * The SSAFn functor is used to generate the High, Med, and Low ILs in the Diderot
7 :     * compiler. These ILs have the same program and control-flow structure, but differ
8 :     * in their types and operators.
9 : jhr 124 *)
10 :    
11 : jhr 392 functor SSAFn (
12 : jhr 137
13 : jhr 1232 val ilName : string
14 : jhr 392 structure Ty : SSA_TYPES
15 :     structure Op : OPERATORS where type ty = Ty.ty
16 :    
17 :     ) : SSA = struct
18 :    
19 :     structure Ty = Ty
20 : jhr 192 structure Op = Op
21 : jhr 137
22 : jhr 1232 val ilName = ilName
23 :    
24 : jhr 1640 (***** strand state variables *****)
25 :    
26 :     datatype state_var = SV of {
27 :     id : Stamp.stamp, (* variable's unique ID *)
28 :     name : string , (* variable's name *)
29 :     ty : Ty.ty, (* variable's type *)
30 :     output : bool, (* true for output variables *)
31 :     props : PropList.holder
32 :     }
33 :    
34 : jhr 1116 (***** CFG *****)
35 :    
36 :     datatype cfg = CFG of {
37 :     entry : node, (* the entry node of a graph; not necessarily an ENTRY node *)
38 :     exit : node (* the exit node of a graph; not necessarily an EXIT node. *)
39 :     }
40 :    
41 :     and node = ND of {
42 : jhr 256 id : Stamp.stamp,
43 :     props : PropList.holder,
44 :     kind : node_kind
45 : jhr 197 }
46 :    
47 : jhr 256 and node_kind
48 :     = NULL
49 :     | ENTRY of {
50 :     succ : node ref
51 :     }
52 :     | JOIN of {
53 :     preds : node list ref,
54 : jhr 1116 phis : phi list ref,
55 : jhr 256 succ : node ref
56 :     }
57 :     | COND of {
58 :     pred : node ref,
59 :     cond : var,
60 :     trueBranch : node ref,
61 :     falseBranch : node ref
62 :     }
63 : lamonts 2083 | FOREACH of {
64 :     pred : node ref,
65 :     cond : var,
66 :     phis: phi list ref,
67 :     stmBranch: node ref,
68 :     varStrandName: string ref,
69 :     shouldReplace: bool ref,
70 :     stmBranchDone: bool ref,
71 :     succ : node ref
72 :     }
73 : jhr 1116 | COM of { (* comment *)
74 : jhr 256 pred : node ref,
75 : jhr 1116 text : string list,
76 : jhr 256 succ : node ref
77 :     }
78 : jhr 1116 | ASSIGN of { (* assignment *)
79 :     pred : node ref,
80 :     stm : assign,
81 :     succ : node ref
82 :     }
83 : jhr 1640 | MASSIGN of { (* multi-assignment *)
84 :     pred : node ref,
85 :     stm : massign,
86 :     succ : node ref
87 :     }
88 : jhr 511 | NEW of { (* create new strand instance *)
89 : jhr 256 pred : node ref,
90 : jhr 511 strand : Atom.atom,
91 : jhr 256 args : var list,
92 :     succ : node ref
93 :     }
94 : jhr 1640 | SAVE of { (* save state variable *)
95 :     pred: node ref,
96 :     lhs : state_var,
97 :     rhs : var,
98 :     succ : node ref
99 :     }
100 : jhr 1116 | EXIT of { (* includes die and stabilize *)
101 :     pred : node ref,
102 :     kind : ExitKind.kind, (* kind of exit node *)
103 :     live : var list (* live variables *)
104 : jhr 256 }
105 : jhr 197
106 : lamonts 2098 and strand_set
107 : lamonts 2203 = SS_All
108 : lamonts 2098 | SS_Stable
109 : lamonts 2203 | SS_Active
110 : lamonts 2098
111 : jhr 188 and rhs
112 : jhr 1640 = STATE of state_var (* read strand state variable *)
113 :     | VAR of var
114 : jhr 188 | LIT of Literal.literal
115 : lamonts 2083 | SELECTOR of var * Atom.atom
116 : lamonts 2101 | STRAND_SET of strand_set list
117 : jhr 188 | OP of Op.rator * var list
118 : jhr 1922 | APPLY of MathFuns.name * var list (* basis function application *)
119 : jhr 1116 | CONS of Ty.ty * var list (* tensor/sequence-value construction *)
120 : jhr 192 and var = V of {
121 : jhr 137 name : string, (* name *)
122 : jhr 1116 id : Stamp.stamp, (* unique ID *)
123 : jhr 394 ty : Ty.ty, (* type *)
124 : jhr 367 bind : var_bind ref, (* binding *)
125 : jhr 137 useCnt : int ref, (* count of uses *)
126 :     props : PropList.holder
127 : jhr 124 }
128 :    
129 : jhr 367 and var_bind
130 :     = VB_NONE
131 : jhr 1116 | VB_RHS of rhs (* defined by an assignment (includes globals and state variables) *)
132 : jhr 1640 | VB_MULTIOP of int * Op.rator * var list
133 :     (* n'th result of operator in multi-assignment *)
134 : jhr 1116 | VB_PHI of var list (* defined by a phi node *)
135 :     | VB_PARAM (* parameter to a strand *)
136 : jhr 367
137 : jhr 192 withtype assign = (var * rhs)
138 : jhr 1640 and massign = (var list * Op.rator * var list)
139 : jhr 1116 and phi = (var * var list)
140 : jhr 188
141 : jhr 1640 datatype assignment = ASSGN of assign | MASSGN of massign
142 : jhr 1116
143 :     (***** Program representation *****)
144 :    
145 : jhr 256 datatype program = Program of {
146 : jhr 1640 props : StrandUtil.program_prop list,
147 : jhr 1116 globalInit : cfg,
148 : lamonts 2203 globalBlock : cfg,
149 : lamonts 2246 globalReduce: cfg,
150 : jhr 1116 initially : initially,
151 : jhr 511 strands : strand list
152 : jhr 256 }
153 : jhr 188
154 : jhr 1116 and initially = Initially of {
155 :     isArray : bool, (* true for initially array, false for collection *)
156 :     rangeInit : cfg, (* code to compute bounds of iteration *)
157 :     iters : (var * var * var) list,
158 :     create : (cfg * Atom.atom * var list)
159 :     }
160 :    
161 : jhr 511 and strand = Strand of {
162 : jhr 256 name : Atom.atom,
163 :     params : var list,
164 : jhr 1640 state : state_var list,
165 : jhr 1116 stateInit : cfg,
166 : jhr 256 methods : method list
167 :     }
168 : jhr 188
169 : jhr 256 and method = Method of {
170 : jhr 1640 name : StrandUtil.method_name,
171 : jhr 1116 body : cfg (* method body *)
172 : jhr 256 }
173 : jhr 188
174 : jhr 1640 structure StateVar =
175 :     struct
176 :     fun new (isOut, name, ty) = SV{
177 :     id = Stamp.new(),
178 :     name = name,
179 :     ty = ty,
180 :     output = isOut,
181 :     props = PropList.newHolder()
182 :     }
183 :     fun name (SV{name, ...}) = name
184 :     fun ty (SV{ty, ...}) = ty
185 :     fun isOutput (SV{output, ...}) = output
186 :     fun same (SV{id=a, ...}, SV{id=b, ...}) = Stamp.same(a, b)
187 :     fun compare (SV{id=a, ...}, SV{id=b, ...}) = Stamp.compare(a, b)
188 :     fun hash (SV{id, ...}) = Stamp.hash id
189 :     fun toString (SV{name, ...}) = "self." ^ name
190 :     (* properties *)
191 :     fun newProp initFn = PropList.newProp (fn (SV{props, ...}) => props, initFn)
192 :     fun newFlag () = PropList.newFlag (fn (SV{props, ...}) => props)
193 : jhr 1813 (* collections *)
194 : jhr 1640 local
195 :     structure V =
196 :     struct
197 :     type ord_key = state_var
198 :     val compare = compare
199 :     end
200 :     in
201 :     structure Map = RedBlackMapFn (V)
202 :     structure Set = RedBlackSetFn (V)
203 :     end
204 :     structure Tbl = HashTableFn (
205 :     struct
206 :     type hash_key = state_var
207 :     val hashVal = hash
208 :     val sameKey = same
209 :     end)
210 :     end
211 :    
212 : jhr 1116 structure Var =
213 :     struct
214 :     fun new (name, ty) = V{
215 :     name = name,
216 :     id = Stamp.new(),
217 :     ty = ty,
218 :     bind = ref VB_NONE,
219 :     useCnt = ref 0,
220 :     props = PropList.newHolder()
221 :     }
222 :     fun copy (V{name, ty, ...}) = new (name, ty)
223 :     fun name (V{name, ...}) = name
224 :     fun ty (V{ty, ...}) = ty
225 :     fun binding (V{bind, ...}) = !bind
226 :     fun setBinding (V{bind, ...}, vb) = bind := vb
227 :     fun useCount (V{useCnt, ...}) = !useCnt
228 :     fun same (V{id=a, ...}, V{id=b, ...}) = Stamp.same(a, b)
229 :     fun compare (V{id=a, ...}, V{id=b, ...}) = Stamp.compare(a, b)
230 :     fun hash (V{id, ...}) = Stamp.hash id
231 :     fun toString (V{name, id, ...}) = name ^ Stamp.toString id
232 :     (* properties *)
233 : jhr 1640 fun newProp initFn = PropList.newProp (fn (V{props, ...}) => props, initFn)
234 :     fun newFlag () = PropList.newFlag (fn (V{props, ...}) => props)
235 : jhr 1813 (* collections *)
236 : jhr 1116 local
237 :     structure V =
238 :     struct
239 :     type ord_key = var
240 :     val compare = compare
241 :     end
242 :     in
243 :     structure Map = RedBlackMapFn (V)
244 :     structure Set = RedBlackSetFn (V)
245 :     end
246 :     structure Tbl = HashTableFn (
247 :     struct
248 :     type hash_key = var
249 :     val hashVal = hash
250 :     val sameKey = same
251 :     end)
252 :     end
253 :    
254 : jhr 256 structure Node =
255 :     struct
256 : jhr 511 fun id (ND{id, ...}) = id
257 :     fun kind (ND{kind, ...}) = kind
258 : jhr 256 fun same (ND{id=a, ...}, ND{id=b, ...}) = Stamp.same(a, b)
259 :     fun compare (ND{id=a, ...}, ND{id=b, ...}) = Stamp.compare(a, b)
260 :     fun hash (ND{id, ...}) = Stamp.hash id
261 :     fun toString (ND{id, kind, ...}) = let
262 :     val tag = (case kind
263 :     of NULL => "NULL"
264 :     | ENTRY _ => "ENTRY"
265 :     | JOIN _ => "JOIN"
266 :     | COND _ => "COND"
267 : lamonts 2083 | FOREACH _ => "FOREACH"
268 : jhr 1116 | COM _ => "COM"
269 :     | ASSIGN _ => "ASSIGN"
270 : jhr 1640 | MASSIGN _ => "MASSIGN"
271 : jhr 256 | NEW _ => "NEW"
272 : jhr 1640 | SAVE _ => "SAVE"
273 : jhr 1116 | EXIT{kind, ...} => ExitKind.toString kind
274 : jhr 256 (* end case *))
275 :     in
276 :     tag ^ Stamp.toString id
277 :     end
278 :     fun new kind = ND{id = Stamp.new(), props = PropList.newHolder(), kind = kind}
279 : jhr 1116 (* variable defs and uses *)
280 :     fun uses (ND{kind, ...}) = (case kind
281 :     of JOIN{phis, ...} => List.foldr (fn ((_, xs), ys) => xs@ys) [] (!phis)
282 :     | COND{cond, ...} => [cond]
283 : lamonts 2083 | FOREACH {phis,cond,...} => [cond]@(List.foldr (fn ((_, xs), ys) => xs@ys) [] (!phis))
284 : jhr 1116 | ASSIGN{stm=(y, rhs), ...} => (case rhs
285 : jhr 1640 of STATE _ => []
286 :     | VAR x => [x]
287 : jhr 1116 | LIT _ => []
288 : lamonts 2101 | STRAND_SET _ => []
289 : lamonts 2083 | SELECTOR(x,_) => [x]
290 : jhr 1116 | OP(_, args) => args
291 :     | APPLY(_, args) => args
292 :     | CONS(_, args) => args
293 :     (* end case *))
294 : jhr 1640 | MASSIGN{stm=(_, _, args), ...} => args
295 : jhr 1116 | NEW{args, ...} => args
296 : jhr 1640 | SAVE{rhs, ...} => [rhs]
297 : jhr 1116 | EXIT{live, ...} => live
298 :     | _ => []
299 :     (* end case *))
300 :     fun defs (ND{kind, ...}) = (case kind
301 :     of JOIN{phis, ...} => List.map #1 (!phis)
302 :     | ASSIGN{stm=(y, _), ...} => [y]
303 : lamonts 2083 | FOREACH{phis,...} => List.map #1 (!phis)
304 : jhr 1640 | MASSIGN{stm=(ys, _, _), ...} => ys
305 : jhr 1116 | _ => []
306 :     (* end case *))
307 : jhr 256 val dummy = new NULL
308 :     fun mkENTRY () = new (ENTRY{succ = ref dummy})
309 :     fun mkJOIN phis = new (JOIN{preds = ref [], phis = ref phis, succ = ref dummy})
310 :     fun mkCOND {cond, trueBranch, falseBranch} = new (COND{
311 :     pred = ref dummy, cond = cond,
312 :     trueBranch = ref trueBranch, falseBranch = ref falseBranch
313 :     })
314 : lamonts 2083 fun mkFOREACH {cond,stmBranch,sName,phis} = (
315 :     new (FOREACH{pred = ref dummy, cond = cond, stmBranch = ref stmBranch,
316 :     phis = ref phis, shouldReplace = ref false, varStrandName = ref sName,
317 :     stmBranchDone = ref false, succ = ref dummy}))
318 : jhr 1116 fun mkCOM text = new (COM{pred = ref dummy, text = text, succ = ref dummy})
319 :     fun mkASSIGN (lhs, rhs) = (
320 :     Var.setBinding (lhs, VB_RHS rhs);
321 :     new (ASSIGN{pred = ref dummy, stm = (lhs, rhs), succ = ref dummy}))
322 : jhr 1640 fun mkMASSIGN (lhs, rator, args) = let
323 :     fun setB (_, []) = ()
324 :     | setB (i, x::xs) = (
325 :     Var.setBinding (x, VB_MULTIOP(i, rator, args));
326 :     setB (i+1, xs))
327 :     in
328 :     setB (0, lhs);
329 :     new (MASSIGN{pred = ref dummy, stm = (lhs, rator, args), succ = ref dummy})
330 :     end
331 : jhr 511 fun mkNEW {strand, args} = new (NEW{
332 :     pred = ref dummy, strand = strand, args = args, succ = ref dummy
333 : jhr 256 })
334 : jhr 1640 fun mkSAVE (lhs, rhs) = new (SAVE{
335 :     pred = ref dummy, lhs = lhs, rhs = rhs, succ = ref dummy
336 :     })
337 : jhr 1116 fun mkEXIT (kind, xs) = new (EXIT{kind = kind, live = xs, pred = ref dummy})
338 :     fun mkFRAGMENT xs = mkEXIT (ExitKind.FRAGMENT, xs)
339 : jhr 1640 fun mkSINIT () = mkEXIT (ExitKind.SINIT, [])
340 : jhr 1116 fun mkRETURN xs = mkEXIT (ExitKind.RETURN, xs)
341 : jhr 1640 fun mkACTIVE () = mkEXIT (ExitKind.ACTIVE, [])
342 :     fun mkSTABILIZE () = mkEXIT (ExitKind.STABILIZE, [])
343 : jhr 1116 fun mkDIE () = mkEXIT (ExitKind.DIE, [])
344 :     fun isNULL (ND{kind=NULL, ...}) = true
345 :     | isNULL _ = false
346 : jhr 256 (* editing node edges *)
347 : jhr 511 fun hasPred (ND{kind, ...}) = (case kind
348 :     of NULL => false
349 :     | ENTRY _ => false
350 :     | _ => true
351 :     (* end case *))
352 : jhr 419 fun setPred (nd0 as ND{kind, ...}, nd) = (case kind
353 : jhr 1116 of NULL => raise Fail("setPred on NULL node " ^ toString nd0)
354 :     | ENTRY _ => raise Fail("setPred on ENTRY node " ^ toString nd0)
355 : jhr 256 | JOIN{preds, ...} => if List.exists (fn nd' => same(nd, nd')) (!preds)
356 :     then ()
357 : jhr 1116 else preds := !preds @ [nd] (* assume preds are added in order *)
358 : jhr 256 | COND{pred, ...} => pred := nd
359 : jhr 1116 | COM{pred, ...} => pred := nd
360 :     | ASSIGN{pred, ...} => pred := nd
361 : jhr 1640 | MASSIGN{pred, ...} => pred := nd
362 : lamonts 2083 | FOREACH{pred, ...} => pred := nd
363 : jhr 256 | NEW{pred, ...} => pred := nd
364 : jhr 1640 | SAVE{pred, ...} => pred := nd
365 : jhr 1116 | EXIT{pred, ...} => pred := nd
366 : jhr 256 (* end case *))
367 : jhr 419 fun preds (nd as ND{kind, ...}) = (case kind
368 : jhr 1116 of NULL => [] (*raise Fail("preds on NULL node "^toString nd)*)
369 : jhr 256 | ENTRY _ => []
370 :     | JOIN{preds, ...} => !preds
371 :     | COND{pred, ...} => [!pred]
372 : jhr 1116 | COM{pred, ...} => [!pred]
373 : lamonts 2083 | FOREACH{pred, ...} => [!pred]
374 : jhr 1116 | ASSIGN{pred, ...} => [!pred]
375 : jhr 1640 | MASSIGN{pred, ...} => [!pred]
376 : jhr 256 | NEW{pred, ...} => [!pred]
377 : jhr 1640 | SAVE{pred, ...} => [!pred]
378 : jhr 1116 | EXIT{pred, ...} => [!pred]
379 : jhr 256 (* end case *))
380 :     fun hasSucc (ND{kind, ...}) = (case kind
381 :     of NULL => false
382 : jhr 1116 | ENTRY _ => true
383 :     | JOIN _ => true
384 :     | COND _ => true
385 : lamonts 2083 | FOREACH _ => true
386 : jhr 1116 | COM _ => true
387 :     | ASSIGN _ => true
388 : jhr 1640 | MASSIGN _ => true
389 : jhr 1116 | NEW _ => true
390 : jhr 1640 | SAVE _ => true
391 : jhr 256 | EXIT _ => false
392 :     (* end case *))
393 : jhr 419 fun setSucc (nd0 as ND{kind, ...}, nd) = (case kind
394 :     of NULL => raise Fail("setSucc on NULL node "^toString nd0)
395 : jhr 256 | ENTRY{succ} => succ := nd
396 :     | JOIN{succ, ...} => succ := nd
397 : jhr 419 | COND _ => raise Fail("setSucc on COND node "^toString nd0)
398 : lamonts 2083 | FOREACH{succ, ...} => succ := nd
399 : jhr 1116 | COM{succ, ...} => succ := nd
400 :     | ASSIGN{succ, ...} => succ := nd
401 : jhr 1640 | MASSIGN{succ, ...} => succ := nd
402 : jhr 256 | NEW{succ, ...} => succ := nd
403 : jhr 1640 | SAVE{succ, ...} => succ := nd
404 : jhr 419 | EXIT _ => raise Fail("setSucc on EXIT node "^toString nd0)
405 : jhr 256 (* end case *))
406 : jhr 419 fun succs (nd as ND{kind, ...}) = (case kind
407 : jhr 1116 of NULL => [] (*raise Fail("succs on NULL node "^toString nd)*)
408 : jhr 256 | ENTRY{succ} => [!succ]
409 :     | JOIN{succ, ...} => [!succ]
410 :     | COND{trueBranch, falseBranch, ...} => [!trueBranch, !falseBranch]
411 : lamonts 2083 | FOREACH{succ,stmBranch, ...} => [!stmBranch, !succ]
412 : jhr 1116 | COM{succ, ...} => [!succ]
413 :     | ASSIGN{succ, ...} => [!succ]
414 : jhr 1640 | MASSIGN{succ, ...} => [!succ]
415 : jhr 256 | NEW{succ, ...} => [!succ]
416 : jhr 1640 | SAVE{succ, ...} => [!succ]
417 : jhr 256 | EXIT _ => []
418 :     (* end case *))
419 :     fun setTrueBranch (ND{kind=COND{trueBranch, ...}, ...}, nd) = trueBranch := nd
420 :     | setTrueBranch (nd, _) = raise Fail("setTrueBranch on " ^ toString nd)
421 :     fun setFalseBranch (ND{kind=COND{falseBranch, ...}, ...}, nd) = falseBranch := nd
422 :     | setFalseBranch (nd, _) = raise Fail("setFalseBranch on " ^ toString nd)
423 : lamonts 2083 fun setStmBranch (ND{kind=FOREACH{stmBranch, ...}, ...}, nd) = stmBranch := nd
424 :     | setStmBranch (nd, _) = raise Fail("setStmBranch on " ^ toString nd)
425 : jhr 256 fun addEdge (nd1, nd2) = (
426 :     if hasSucc nd1
427 :     then (
428 :     setSucc (nd1, nd2);
429 :     setPred (nd2, nd1))
430 :     else ())
431 :     (*DEBUG*)handle ex => (
432 :     print(concat["error in addEdge(", toString nd1, ",", toString nd2, ")\n"]);
433 :     raise ex)
434 : jhr 1116 fun replaceInEdge {src, oldDst, dst} = (
435 :     (* first set the successor of src *)
436 :     case kind src
437 :     of COND{trueBranch, falseBranch, ...} =>
438 :     if same(!trueBranch, oldDst)
439 :     then trueBranch := dst
440 :     else falseBranch := dst
441 :     | _ => setSucc (src, dst)
442 :     (* end case *);
443 :     (* then set the predecessor of dst *)
444 :     setPred (dst, src))
445 :     (*DEBUG*)handle ex => (
446 :     print(concat["error in replaceInEdge(", toString src, ",", toString oldDst, ",", toString dst, ")\n"]);
447 :     raise ex)
448 :     fun replaceOutEdge {oldSrc, src, dst} = (
449 :     (* first set the successor of src *)
450 : jhr 1232 case kind oldSrc
451 :     of COND{trueBranch, falseBranch, ...} =>
452 :     if same(!trueBranch, dst)
453 :     then setTrueBranch (src, dst)
454 :     else setFalseBranch (src, dst)
455 :     | _ => setSucc (src, dst)
456 :     (* end case *);
457 : jhr 1116 (* then set the predecessor of dst *)
458 :     case kind dst
459 :     of JOIN{preds, ...} => let
460 :     fun edit [] = raise Fail "replaceOutEdge: cannot find predecessor"
461 :     | edit (nd::nds) = if same(nd, oldSrc) then src::nds else nd::edit nds
462 :     in
463 :     preds := edit (!preds)
464 :     end
465 :     | _ => setPred (dst, src)
466 :     (* end case *))
467 :     (*DEBUG*)handle ex => (
468 :     print(concat["error in replaceOutEdge(", toString oldSrc, ",", toString src, ",", toString dst, ")\n"]);
469 :     raise ex)
470 : jhr 283 (* properties *)
471 :     fun newProp initFn =
472 :     PropList.newProp (fn (ND{props, ...}) => props, initFn)
473 :     fun newFlag () =
474 :     PropList.newFlag (fn (ND{props, ...}) => props)
475 : jhr 256 end
476 : jhr 124
477 : jhr 1116 structure CFG =
478 : jhr 256 struct
479 : jhr 1116 val empty = CFG{entry = Node.dummy, exit = Node.dummy}
480 :    
481 :     fun isEmpty (CFG{entry, exit}) =
482 :     Node.same(entry, exit) andalso Node.isNULL entry
483 :    
484 :     (* create a basic block from a list of assignments *)
485 :     fun mkBlock [] = empty
486 :     | mkBlock (stm::stms) = let
487 : jhr 1640 fun mkNode (ASSGN stm) = Node.mkASSIGN stm
488 :     | mkNode (MASSGN stm) = Node.mkMASSIGN stm
489 :     val entry = mkNode stm
490 : jhr 1116 fun f (stm, prev) = let
491 : jhr 1640 val nd = mkNode stm
492 : jhr 1116 in
493 :     Node.addEdge (prev, nd);
494 :     nd
495 :     end
496 :     val exit = List.foldl f entry stms
497 : jhr 256 in
498 : jhr 1116 CFG{entry = entry, exit = exit}
499 : jhr 256 end
500 : jhr 1116
501 :     (* entry/exit nodes of a CFG *)
502 :     fun entry (CFG{entry = nd, ...}) = nd
503 :     fun exit (CFG{exit = nd, ...}) = nd
504 :    
505 :     (* return the list of variables that are live at exit from a CFG *)
506 :     fun liveAtExit cfg = (case Node.kind(exit cfg)
507 :     of EXIT{live, ...} => live
508 :     | _ => raise Fail "bogus exit node"
509 : jhr 256 (* end case *))
510 : jhr 1116
511 :     (* DFS sorting of the graph rooted at the entry to a statement; the resulting list will
512 :     * be in preorder with parents before children.
513 :     *)
514 :     fun sort (CFG{entry, ...}) = let
515 :     val {getFn, setFn} = PropList.newFlag (fn (ND{props, ...}) => props)
516 :     fun dfs (nd, l) =
517 :     if getFn nd
518 :     then l
519 :     else (
520 :     setFn (nd, true);
521 :     nd :: List.foldl dfs l (Node.succs nd))
522 :     val nodes = dfs (entry, [])
523 : jhr 256 in
524 : jhr 1116 List.app (fn nd => setFn(nd, false)) nodes;
525 :     nodes
526 : jhr 256 end
527 : jhr 137
528 : jhr 1116 (* apply a function to all of the nodes in the graph rooted at the entry to the statement *)
529 :     fun apply (f : node -> unit) (CFG{entry, ...}) = let
530 : jhr 1822 val {getFn, setFn} = Node.newFlag()
531 : jhr 1116 fun dfs (nd, l) =
532 :     if getFn nd
533 :     then l
534 :     else (
535 :     f nd; (* visit *)
536 :     setFn (nd, true);
537 :     nd :: List.foldl dfs l (Node.succs nd))
538 :     val nodes = dfs (entry, [])
539 :     in
540 :     List.app (fn nd => setFn(nd, false)) nodes
541 :     end
542 :    
543 :     (* delete a simple node from a CFG *)
544 : jhr 1640 fun deleteNode (nd as ND{kind, ...}) = let
545 :     val (pred, succ) = (case kind
546 :     of COM{pred = ref pred, succ = ref succ, ...} => (pred, succ)
547 :     | ASSIGN{pred = ref pred, succ = ref succ, ...} => (pred, succ)
548 :     | MASSIGN{pred = ref pred, succ = ref succ, ...} => (pred, succ)
549 : lamonts 2083 | FOREACH{pred = ref pred, succ = ref succ, ...} => (pred, succ)
550 : jhr 1640 | NEW{pred = ref pred, succ = ref succ, ...} => (pred, succ)
551 :     | SAVE{pred = ref pred, succ = ref succ, ...} => (pred, succ)
552 :     | _ => raise Fail(concat["unsupported deleteNode(", Node.toString nd, ")\n"])
553 :     (* end case *))
554 :     in
555 :     Node.setPred (succ, pred);
556 :     case Node.kind pred
557 :     of COND{trueBranch, falseBranch, ...} => (
558 :     (* note that we treat each branch independently, so that we handle the
559 :     * situation where both branches are the same node.
560 :     *)
561 :     if Node.same(!trueBranch, nd)
562 :     then Node.setTrueBranch(pred, succ)
563 :     else ();
564 :     if Node.same(!falseBranch, nd)
565 :     then Node.setFalseBranch(pred, succ)
566 :     else ())
567 :     | _ => Node.setSucc (pred, succ)
568 :     (* end case *)
569 :     end
570 : jhr 1348 (*DEBUG*)handle ex => (
571 :     print(concat["error in deleteNode(", Node.toString nd, ")\n"]);
572 :     raise ex)
573 : jhr 1116
574 :     (* replace a simple node in a cfg with a subgraph *)
575 :     fun replaceNode (oldNd as ND{kind, ...}, node) = (case kind
576 :     of ASSIGN{pred, succ, ...} => (
577 :     Node.replaceInEdge {src = !pred, oldDst = oldNd, dst = node};
578 :     Node.replaceOutEdge {oldSrc = oldNd, src = node, dst = !succ})
579 : jhr 1640 | MASSIGN{pred, succ, ...} => (
580 :     Node.replaceInEdge {src = !pred, oldDst = oldNd, dst = node};
581 :     Node.replaceOutEdge {oldSrc = oldNd, src = node, dst = !succ})
582 : jhr 1116 | NEW{pred, succ, ...} => (
583 :     Node.replaceInEdge {src = !pred, oldDst = oldNd, dst = node};
584 :     Node.replaceOutEdge {oldSrc = oldNd, src = node, dst = !succ})
585 : lamonts 2083 | FOREACH{pred, succ, ...} => (
586 :     Node.replaceInEdge {src = !pred, oldDst = oldNd, dst = node};
587 :     Node.replaceOutEdge {oldSrc = oldNd, src = node, dst = !succ})
588 : jhr 1640 | SAVE{pred, succ, ...} => (
589 :     Node.replaceInEdge {src = !pred, oldDst = oldNd, dst = node};
590 :     Node.replaceOutEdge {oldSrc = oldNd, src = node, dst = !succ})
591 : jhr 1116 | EXIT{pred, ...} =>
592 :     Node.replaceInEdge {src = !pred, oldDst = oldNd, dst = node}
593 :     | _ => raise Fail "unsupported replaceNode"
594 :     (* end case *))
595 :    
596 :     (* replace a simple node in a cfg with a subgraph *)
597 :     fun replaceNodeWithCFG (nd as ND{kind, ...}, cfg as CFG{entry, exit}) =
598 :     if isEmpty cfg
599 :     then deleteNode nd
600 :     else (case kind
601 :     of ASSIGN{pred, succ, ...} => (
602 :     Node.replaceInEdge {src = !pred, oldDst = nd, dst = entry};
603 :     Node.replaceOutEdge {oldSrc = nd, src = exit, dst = !succ})
604 : jhr 1640 | MASSIGN{pred, succ, ...} => (
605 :     Node.replaceInEdge {src = !pred, oldDst = nd, dst = entry};
606 :     Node.replaceOutEdge {oldSrc = nd, src = exit, dst = !succ})
607 : jhr 1116 | _ => raise Fail "unsupported replaceNodeWithCFG"
608 :     (* end case *))
609 :    
610 :     (* concatenate two CFGs *)
611 :     fun concat (cfg1 as CFG{entry=e1, exit=x1}, cfg2 as CFG{entry=e2, exit=x2}) =
612 :     if isEmpty cfg1 then cfg2
613 :     else if isEmpty cfg2 then cfg1
614 :     else (
615 :     Node.setSucc (x1, e2);
616 :     Node.setPred (e2, x1);
617 :     CFG{entry = e1, exit = x2})
618 : jhr 1348 (*DEBUG*)handle ex => (
619 :     print(String.concat["error in concat({", Node.toString e1, ",", Node.toString x1,
620 :     "},{", Node.toString e2, ",", Node.toString x2, "})\n"]);
621 :     raise ex)
622 : jhr 1116
623 : jhr 1640 (* prepend a node to a CFG *)
624 :     fun prependNode (nd, cfg as CFG{entry, exit}) =
625 :     if isEmpty cfg
626 :     then CFG{entry=nd, exit=nd}
627 :     else (
628 :     Node.setSucc (nd, entry);
629 :     Node.setPred (entry, nd);
630 :     CFG{entry=nd, exit=exit})
631 :    
632 : jhr 1116 (* append a node to a CFG *)
633 :     fun appendNode (cfg as CFG{entry, exit}, nd) =
634 :     if isEmpty cfg
635 :     then CFG{entry=nd, exit=nd}
636 :     else (
637 :     Node.setPred (nd, exit);
638 :     Node.setSucc (exit, nd);
639 :     CFG{entry=entry, exit=nd})
640 :    
641 : jhr 1232 (* update the exit of a CFG by modifying the live variable list *)
642 :     fun updateExit (CFG{entry, exit as ND{kind, ...}}, f) = let
643 :     val newExit = (case kind
644 :     of EXIT{pred, kind, live} => let
645 :     val newNd = Node.mkEXIT(kind, f live)
646 :     in
647 :     Node.replaceInEdge {src = !pred, oldDst = exit, dst = newNd};
648 :     newNd
649 :     end
650 :     | _ => raise Fail "bogus exit node for updateExit"
651 :     (* end case *))
652 :     in
653 :     CFG{entry=entry, exit=newExit}
654 :     end
655 : jhr 199 end
656 : jhr 197
657 : jhr 1232 structure RHS =
658 :     struct
659 :     fun vars rhs = (case rhs
660 : jhr 1640 of STATE x => []
661 :     | VAR x => [x]
662 : jhr 1232 | LIT _ => []
663 : lamonts 2083 | SELECTOR(x,field) => [x]
664 : lamonts 2101 | STRAND_SET _ => []
665 :     (* | REDUCTION(r, s,x,xExp) => [x,xExp] *)
666 : jhr 1232 | OP(rator, xs) => xs
667 :     | APPLY(g, xs) => xs
668 :     | CONS(ty, xs) => xs
669 :     (* end case *))
670 : jhr 1116
671 : jhr 1232 fun map f = let
672 :     fun mapf rhs = (case rhs
673 : jhr 1640 of STATE _ => rhs
674 :     | VAR x => VAR(f x)
675 : jhr 1232 | LIT _ => rhs
676 : lamonts 2083 | SELECTOR(x,field) => SELECTOR(f x, field)
677 : lamonts 2101 | STRAND_SET _ => rhs
678 :     (* | REDUCTION(r,s,x,xExp) => REDUCTION(r,s, f x, f xExp) *)
679 : jhr 1232 | OP(rator, xs) => OP(rator, List.map f xs)
680 :     | APPLY(g, xs) => APPLY(g, List.map f xs)
681 :     | CONS(ty, xs) => CONS(ty, List.map f xs)
682 :     (* end case *))
683 :     in
684 :     mapf
685 :     end
686 :    
687 :     fun app f = let
688 : jhr 1813 fun appf rhs = (case rhs
689 : jhr 1640 of STATE _ => ()
690 :     | VAR x => f x
691 : jhr 1232 | LIT _ => ()
692 : lamonts 2083 | SELECTOR(x,field) => f x
693 : lamonts 2101 | STRAND_SET _ => ()
694 : jhr 1232 | OP(rator, xs) => List.app f xs
695 :     | APPLY(_, xs) => List.app f xs
696 :     | CONS(ty, xs) => List.app f xs
697 :     (* end case *))
698 :     in
699 : jhr 1813 appf
700 : jhr 1232 end
701 :    
702 : lamonts 2101 (* fun reductionSame(r,r') = (case (r,r')
703 : lamonts 2098 of (R_Max,R_Max) => true
704 :     | (R_Min,R_Min) => true
705 :     | (R_Or,R_Or) => true
706 :     | (R_And,R_And) => true
707 :     | (R_Xor,R_Xor) => true
708 :     | (R_Product,R_Product) => true
709 :     | (R_Sum,R_Sum) => true
710 :     | (_,_) => false)
711 :    
712 :    
713 :     fun reductionToString(r) = (case r
714 :     of R_Max => "max"
715 :     | R_Min => "min"
716 :     | R_Or => "or"
717 :     | R_And => "and"
718 :     | R_Xor => "xor"
719 :     | R_Product => "product"
720 : lamonts 2101 | R_Sum => "sum") *)
721 : lamonts 2098
722 :     fun toStringSets(sets) = let
723 :     fun ppSetsList([]) = []
724 :     | ppSetsList(x::[]) = (case x
725 : lamonts 2203 of SS_All => ["all"]
726 :     | SS_Active => ["active"]
727 : lamonts 2098 | SS_Stable => ["stable"])
728 :     | ppSetsList(x::xs) = (case x
729 : lamonts 2203 of SS_All => "all,"::ppSetsList(xs)
730 :     | SS_Active => "active,"::ppSetsList(xs)
731 : lamonts 2098 | SS_Stable => "stable,"::ppSetsList(xs))
732 :     in
733 :     ppSetsList(sets)
734 :     end
735 :    
736 : lamonts 2101 fun strandSetSame(s,s') = let
737 : lamonts 2098 fun same ([],[]) = true
738 :     | same(t,[]) = false
739 :     | same([],t) = false
740 :     | same((x::xs),(x'::xs')) =
741 :     if (x = x')
742 :     then same(xs,xs')
743 :     else false
744 :     in
745 :     same(toStringSets(s),toStringSets(s'))
746 : lamonts 2101 end
747 : lamonts 2098
748 : jhr 1232 (* return a string representation of a rhs *)
749 :     fun toString rhs = (case rhs
750 : jhr 1640 of STATE x => StateVar.toString x
751 :     | VAR x => Var.toString x
752 : jhr 1232 | LIT lit => Literal.toString lit
753 : lamonts 2083 | SELECTOR(x,field) => String.concat[Var.toString x, ".", Atom.toString field]
754 : lamonts 2101 | STRAND_SET(sets) => String.concat (["{"] @ toStringSets(sets) @ ["}"])
755 :     (*| REDUCTION(r,s,x,xExp) => String.concat ([reductionToString(r), "{ ",Var.toString xExp, " | ", Var.toString x,
756 : lamonts 2098 " in { "] @ toStringSets(s) @ ["}}"])
757 : lamonts 2101 *)
758 : jhr 1232 | OP(rator, xs) => String.concat [
759 :     Op.toString rator,
760 :     "(", String.concatWith "," (List.map Var.toString xs), ")"
761 :     ]
762 :     | APPLY(f, xs) => String.concat [
763 : jhr 1922 MathFuns.toString f,
764 : jhr 1232 "(", String.concatWith "," (List.map Var.toString xs), ")"
765 :     ]
766 :     | CONS(ty, xs) => String.concat [
767 :     "<", Ty.toString ty, ">[",
768 :     String.concatWith "," (List.map Var.toString xs), "]"
769 :     ]
770 :     (* end case *))
771 :     end
772 :    
773 : jhr 1116 (* return a string representation of a variable binding *)
774 :     fun vbToString VB_NONE = "NONE"
775 : jhr 1232 | vbToString (VB_RHS rhs) = concat["RHS(", RHS.toString rhs, ")"]
776 : jhr 1640 | vbToString (VB_MULTIOP(i, rator, xs)) = concat[
777 :     "MULTIOP(", Op.toString rator,
778 :     "[", String.concatWith "," (List.map Var.toString xs), "])"
779 :     ]
780 : jhr 1116 | vbToString (VB_PHI xs) = concat[
781 :     "PHI(", String.concatWith "," (List.map Var.toString xs), ")"
782 :     ]
783 :     | vbToString VB_PARAM = "PARAM"
784 :    
785 : jhr 412 (* return a string representation of a PHI node *)
786 :     fun phiToString (y, xs) = String.concat [
787 :     Ty.toString(Var.ty y), " ", Var.toString y, " = PHI(",
788 :     String.concatWith "," (List.map Var.toString xs), ")"
789 :     ]
790 :    
791 :     (* return a string representation of an assignment *)
792 : jhr 1116 fun assignToString (y, rhs) =
793 : jhr 1232 String.concat [Ty.toString(Var.ty y), " ", Var.toString y, " = ", RHS.toString rhs]
794 : jhr 1640 fun massignToString (ys, rator, xs) = String.concat [
795 :     "(", String.concatWith ","
796 :     (List.map (fn y => concat[Ty.toString(Var.ty y), " ", Var.toString y]) ys),
797 :     " = ", Op.toString rator,
798 :     "(", String.concatWith "," (List.map Var.toString xs), ")"
799 :     ]
800 : jhr 412
801 : jhr 1116 end (* SSAFn *)

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0