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

SCM Repository

[diderot] Annotation of /branches/vis15/src/compiler/cfg-ir/ssa-fn.sml
ViewVC logotype

Annotation of /branches/vis15/src/compiler/cfg-ir/ssa-fn.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 5286 - (view) (download)

1 : jhr 3470 (* ssa-fn.sml
2 :     *
3 :     * This code is part of the Diderot Project (http://diderot-language.cs.uchicago.edu)
4 :     *
5 :     * COPYRIGHT (c) 2015 The University of Chicago
6 :     * All rights reserved.
7 :     *
8 : jhr 3475 * The SSAFn functor is used to generate the High, Med, and Low IRs in the Diderot
9 :     * compiler. These IRs have the same program and control-flow structure, but differ
10 : jhr 3470 * in their types and operators.
11 :     *)
12 :    
13 :     functor SSAFn (
14 :    
15 : jhr 3508 val irName : string
16 : jhr 3470
17 :     structure Ty : SSA_TYPES
18 :     structure Op : OPERATORS where type ty = Ty.ty
19 :    
20 :     ) : SSA = struct
21 :    
22 :     structure Ty = Ty
23 :     structure Op = Op
24 :    
25 : jhr 3508 val irName = irName
26 : jhr 3470
27 :     (***** CFG *****)
28 :    
29 : jhr 3527 datatype global_kind = datatype GlobalVarKind.t
30 :    
31 : jhr 3470 datatype cfg = CFG of {
32 :     entry : node, (* the entry node of a graph; not necessarily an ENTRY node *)
33 :     exit : node (* the exit node of a graph; not necessarily an EXIT node. *)
34 :     }
35 :    
36 :     and node = ND of {
37 : jhr 5273 id : Stamp.t,
38 : jhr 3470 props : PropList.holder,
39 :     kind : node_kind
40 :     }
41 :    
42 :     and node_kind
43 :     = NULL
44 :     | ENTRY of {
45 :     succ : node ref
46 :     }
47 :     | JOIN of {
48 :     preds : node list ref, (* includes fake control-flow edges *)
49 :     mask : bool list ref, (* true for incoming fake edges *)
50 :     phis : phi list ref, (* data-flow joins corresponding to the edges in preds *)
51 :     succ : node ref
52 :     }
53 :     | COND of {
54 :     pred : node ref,
55 : jhr 3536 cond : var ref, (* the variable being tested (we use a ref to allow rewriting) *)
56 : jhr 3470 trueBranch : node ref,
57 :     falseBranch : node ref
58 :     }
59 : jhr 3837 | FOREACH of { (* foreach-loop; this node combines aspects of the COND
60 :     * and JOIN nodes. *)
61 :     pred : node ref, (* the predecessor *)
62 :     phis : phi list ref, (* phi nodes (as in JOIN) *)
63 : jhr 3473 mask : bool list ref, (* true for incoming fake edges *)
64 : jhr 3837 var : var, (* the loop variable *)
65 :     src : var ref, (* the source of values being iterated over *)
66 :     bodyEntry : node ref, (* the loop body entry node *)
67 :     bodyExit : node ref, (* the loop body exit node *)
68 :     succ : node ref (* the loop-exit edge *)
69 :     }
70 :     | NEXT of { (* a loop-body exit node *)
71 :     pred : node ref, (* the predecessor *)
72 :     succ : node ref (* the FOREACH node *)
73 :     }
74 : jhr 3470 | COM of { (* comment *)
75 :     pred : node ref,
76 :     text : string list,
77 :     succ : node ref
78 :     }
79 :     | ASSIGN of { (* local-variable assignment *)
80 :     pred : node ref,
81 :     stm : assign,
82 :     succ : node ref
83 :     }
84 :     | MASSIGN of { (* multi-assignment *)
85 :     pred : node ref,
86 :     stm : massign,
87 :     succ : node ref
88 :     }
89 :     | GASSIGN of { (* global variable assignment *)
90 :     pred: node ref,
91 :     lhs : global_var,
92 :     rhs : var,
93 :     succ : node ref
94 :     }
95 :     | NEW of { (* create new strand instance *)
96 :     pred : node ref,
97 :     strand : Atom.atom,
98 :     args : var list,
99 :     succ : node ref
100 :     }
101 :     | SAVE of { (* save state variable *)
102 :     pred: node ref,
103 :     lhs : state_var,
104 :     rhs : var,
105 :     succ : node ref
106 :     }
107 :     | EXIT of { (* includes die and stabilize *)
108 :     pred : node ref,
109 : jhr 4164 kind : var ExitKind.kind, (* kind of exit node *)
110 : jhr 3470 succ : node option ref (* optional fake control-flow edge for when the EXIT is *)
111 : jhr 3837 (* not the CFG exit node *)
112 : jhr 3470 }
113 :    
114 :     and rhs
115 :     = GLOBAL of global_var (* read global variable *)
116 : jhr 3846 | STATE of var option * state_var (* read strand state variable; NONE means "self" *)
117 : jhr 3470 | VAR of var
118 :     | LIT of Literal.t
119 :     | OP of Op.rator * var list
120 :     | CONS of var list * Ty.ty (* tensor-value construction *)
121 :     | SEQ of var list * Ty.ty (* sequence-value construction *)
122 :     | EINAPP of Ein.ein * var list
123 : jhr 4317 | APPLY of func * var list (* function application *)
124 : jhr 4378 | MAPREDUCE of (Reductions.t * func * var list) list
125 :     (* parallel map-reduce *)
126 : jhr 3470
127 :     and var = V of {
128 :     name : string, (* name *)
129 : jhr 5273 id : Stamp.t, (* unique ID *)
130 : jhr 3470 ty : Ty.ty, (* type *)
131 :     bind : var_bind ref, (* binding *)
132 :     useCnt : int ref, (* count of uses *)
133 :     props : PropList.holder
134 :     }
135 :    
136 :     and var_bind
137 :     = VB_NONE
138 :     | VB_RHS of rhs (* defined by an assignment (includes globals and state variables) *)
139 : jhr 4362 | VB_MULTIOP of int * rhs (* n'th result of operator in multi-assignment *)
140 : jhr 3470 | VB_PHI of var option list (* defined by a phi node *)
141 :     | VB_PARAM (* parameter to a strand *)
142 : jhr 3837 | VB_ITER (* bound in a foreach loop *)
143 : jhr 3470
144 :     (***** global variables *****)
145 :     and global_var = GV of {
146 : jhr 5273 id : Stamp.t, (* variable's unique ID *)
147 : jhr 3470 name : string, (* variable's name *)
148 :     ty : Ty.ty, (* variable's type *)
149 : jhr 3506 kind : global_kind, (* the variable kind *)
150 : jhr 3837 updated : bool, (* true if the global variable is modified in the *)
151 :     (* global-update code *)
152 :     binding : var option ref, (* the local variable used to define this global variable
153 :     * (i.e., in a GASSIGN node). This field will be NONE
154 : jhr 4014 * for inputs and for mutable variables.
155 : jhr 3837 *)
156 : jhr 3517 useCnt : int ref, (* count of uses *)
157 : jhr 3470 props : PropList.holder
158 :     }
159 :    
160 :     (***** strand state variables *****)
161 :     and state_var = SV of {
162 : jhr 5273 id : Stamp.t, (* variable's unique ID *)
163 : jhr 3470 name : string, (* variable's name *)
164 :     ty : Ty.ty, (* variable's type *)
165 : jhr 3838 output : bool, (* true for output variables *)
166 : jhr 3840 varying : bool, (* true for variables that are modified during super steps *)
167 :     shared : bool, (* true for variables that are read by other strands *)
168 : jhr 3470 props : PropList.holder
169 :     }
170 :    
171 : jhr 4163 (***** function identifiers *****)
172 :     and func = FV of {
173 : jhr 5273 id : Stamp.t, (* function's unique ID *)
174 : jhr 4163 name : string, (* function's name *)
175 :     ty : Ty.ty, (* function's result type *)
176 : jhr 4317 paramTys : Ty.ty list, (* function's parameter types *)
177 : jhr 4163 useCnt : int ref, (* count of uses *)
178 :     props : PropList.holder
179 :     }
180 :    
181 : jhr 3470 withtype assign = (var * rhs)
182 : jhr 4362 and massign = (var list * rhs)
183 : jhr 3470 and phi = (var * var option list) (* NONE for fake edges *)
184 :    
185 :     datatype assignment
186 :     = ASSGN of assign
187 :     | MASSGN of massign
188 :     | GASSGN of (global_var * var)
189 :     | SAV of (state_var * var)
190 :    
191 :     (***** Program representation *****)
192 :    
193 : jhr 3505 type input = global_var Inputs.input
194 :    
195 : jhr 3470 datatype program = Program of {
196 :     props : Properties.t list,
197 : jhr 3837 consts : global_var list, (* large constant variables *)
198 :     inputs : input list, (* global input variables *)
199 : jhr 3505 constInit : cfg, (* code that initializes constants and inputs *)
200 : jhr 3485 globals : global_var list, (* other global variables *)
201 : jhr 4317 funcs : func_def list, (* user-defined functions *)
202 : jhr 3995 globInit : cfg, (* CFG to initialize globals *)
203 : jhr 3837 strand : strand, (* the strand definition *)
204 :     create : create, (* initial strand creation *)
205 : jhr 4491 start : cfg option, (* optional global start code *)
206 : jhr 3837 update : cfg option (* optional update code. *)
207 : jhr 3470 }
208 :    
209 : jhr 4163 and func_def = Func of {
210 : jhr 4317 name : func,
211 :     params : var list,
212 :     body : cfg
213 : jhr 4163 }
214 :    
215 : jhr 3470 and strand = Strand of {
216 :     name : Atom.atom,
217 :     params : var list,
218 : jhr 4369 spatialDim : int option,
219 : jhr 3470 state : state_var list,
220 :     stateInit : cfg,
221 : jhr 4491 startM : cfg option,
222 : jhr 3837 updateM : cfg,
223 :     stabilizeM : cfg option
224 : jhr 3470 }
225 :    
226 : jhr 4045 withtype create = cfg Create.t
227 : jhr 3470
228 :     structure GlobalVar =
229 :     struct
230 : jhr 3843 fun new (kind, isVarying, name, ty) = GV{
231 : jhr 3470 id = Stamp.new(),
232 :     name = name,
233 :     ty = ty,
234 : jhr 3506 kind = kind,
235 : jhr 3843 updated = isVarying,
236 : jhr 3837 binding = ref NONE,
237 :     useCnt = ref 0,
238 : jhr 3470 props = PropList.newHolder()
239 :     }
240 :     fun name (GV{name, ...}) = name
241 :     fun uniqueName (GV{id, name, ...}) = name ^ Stamp.toString id
242 : jhr 3506 fun kind (GV{kind, ...}) = kind
243 : jhr 3843 fun isVarying (GV{updated, ...}) = updated
244 : jhr 3837 fun bindingOf (GV{binding, ...}) = !binding
245 :     fun setBinding (GV{binding, ...}, x) = (binding := SOME x)
246 : jhr 3470 fun ty (GV{ty, ...}) = ty
247 : jhr 3506 fun isInput (GV{kind=InputVar, ...}) = true
248 : jhr 3837 | isInput _ = false
249 :     fun useCount (GV{useCnt, ...}) = !useCnt
250 : jhr 3470 fun same (GV{id=a, ...}, GV{id=b, ...}) = Stamp.same(a, b)
251 :     fun compare (GV{id=a, ...}, GV{id=b, ...}) = Stamp.compare(a, b)
252 :     fun hash (GV{id, ...}) = Stamp.hash id
253 :     fun toString (GV{id, name, ...}) = concat["globals.", name, Stamp.toString id]
254 :     (* properties *)
255 : jhr 3837 fun newProp initFn = PropList.newProp (fn (GV{props, ...}) => props, initFn)
256 :     fun newFlag () = PropList.newFlag (fn (GV{props, ...}) => props)
257 : jhr 3470 (* collections *)
258 :     local
259 :     structure V =
260 :     struct
261 :     type ord_key = global_var
262 :     val compare = compare
263 :     end
264 :     in
265 :     structure Map = RedBlackMapFn (V)
266 :     structure Set = RedBlackSetFn (V)
267 :     end
268 :     structure Tbl = HashTableFn (
269 :     struct
270 :     type hash_key = global_var
271 :     val hashVal = hash
272 :     val sameKey = same
273 :     end)
274 :     end
275 :    
276 :     structure StateVar =
277 :     struct
278 : jhr 3840 fun new (isOut, name, ty, varying, shared) = SV{
279 : jhr 3470 id = Stamp.new(),
280 :     name = name,
281 :     ty = ty,
282 : jhr 3838 output = isOut,
283 : jhr 3840 varying = varying,
284 :     shared = shared,
285 : jhr 3470 props = PropList.newHolder()
286 :     }
287 :     fun name (SV{name, ...}) = name
288 :     fun ty (SV{ty, ...}) = ty
289 : jhr 3838 fun isOutput (SV{output, ...}) = output
290 : jhr 3840 fun isVarying (SV{varying, ...}) = varying
291 :     fun isShared (SV{shared, ...}) = shared
292 : jhr 3470 fun same (SV{id=a, ...}, SV{id=b, ...}) = Stamp.same(a, b)
293 :     fun compare (SV{id=a, ...}, SV{id=b, ...}) = Stamp.compare(a, b)
294 :     fun hash (SV{id, ...}) = Stamp.hash id
295 : jhr 3846 fun toString (SV{name, ...}) = name
296 : jhr 3470 (* properties *)
297 : jhr 3837 fun newProp initFn = PropList.newProp (fn (SV{props, ...}) => props, initFn)
298 :     fun newFlag () = PropList.newFlag (fn (SV{props, ...}) => props)
299 : jhr 3470 (* collections *)
300 :     local
301 :     structure V =
302 :     struct
303 :     type ord_key = state_var
304 :     val compare = compare
305 :     end
306 :     in
307 :     structure Map = RedBlackMapFn (V)
308 :     structure Set = RedBlackSetFn (V)
309 :     end
310 :     structure Tbl = HashTableFn (
311 :     struct
312 :     type hash_key = state_var
313 :     val hashVal = hash
314 :     val sameKey = same
315 :     end)
316 :     end
317 :    
318 :     structure Var =
319 :     struct
320 :     fun new (name, ty) = V{
321 :     name = name,
322 :     id = Stamp.new(),
323 :     ty = ty,
324 :     bind = ref VB_NONE,
325 :     useCnt = ref 0,
326 :     props = PropList.newHolder()
327 :     }
328 :     fun copy (V{name, ty, ...}) = new (name, ty)
329 :     fun name (V{name, ...}) = name
330 :     fun ty (V{ty, ...}) = ty
331 :     fun binding (V{bind, ...}) = !bind
332 :     fun setBinding (V{bind, ...}, vb) = bind := vb
333 :     fun useCount (V{useCnt, ...}) = !useCnt
334 :     fun same (V{id=a, ...}, V{id=b, ...}) = Stamp.same(a, b)
335 :     fun compare (V{id=a, ...}, V{id=b, ...}) = Stamp.compare(a, b)
336 :     fun hash (V{id, ...}) = Stamp.hash id
337 :     fun toString (V{name, id, ...}) = name ^ Stamp.toString id
338 : jhr 4317 fun getLocalDef x = (case binding x
339 :     of VB_RHS(VAR x) => getLocalDef x
340 :     | VB_RHS rhs => rhs
341 :     | _ => VAR x
342 :     (* end case *))
343 : jhr 3837 fun getDef x = (case binding x
344 :     of VB_RHS rhs => (case rhs
345 :     of GLOBAL gv => if GlobalVar.isInput gv
346 :     then rhs (* inputs could be different at runtime! *)
347 :     else (case GlobalVar.bindingOf gv
348 :     of SOME x => getDef x
349 :     | NONE => rhs
350 :     (* end case *))
351 :     | VAR x => getDef x
352 :     | _ => rhs
353 :     (* end case *))
354 :     | _ => VAR x
355 :     (* end case *))
356 : jhr 3470 (* properties *)
357 : jhr 3837 fun newProp initFn = PropList.newProp (fn (V{props, ...}) => props, initFn)
358 :     fun newFlag () = PropList.newFlag (fn (V{props, ...}) => props)
359 : jhr 3470 (* collections *)
360 :     local
361 :     structure V =
362 :     struct
363 :     type ord_key = var
364 :     val compare = compare
365 :     end
366 :     in
367 :     structure Map = RedBlackMapFn (V)
368 :     structure Set = RedBlackSetFn (V)
369 :     end
370 :     structure Tbl = HashTableFn (
371 :     struct
372 :     type hash_key = var
373 :     val hashVal = hash
374 :     val sameKey = same
375 :     end)
376 :     end
377 :    
378 : jhr 4163 structure Func = struct
379 :     fun new (name, resTy, paramTys) = FV{
380 :     name = name,
381 :     id = Stamp.new(),
382 :     ty = resTy,
383 : jhr 4317 paramTys = paramTys,
384 :     useCnt = ref 0,
385 : jhr 4163 props = PropList.newHolder()
386 :     }
387 :     fun name (FV{name, ...}) = name
388 :     fun ty (FV{ty, paramTys, ...}) = (ty, paramTys)
389 :     fun same (FV{id=a, ...}, FV{id=b, ...}) = Stamp.same(a, b)
390 :     fun compare (FV{id=a, ...}, FV{id=b, ...}) = Stamp.compare(a, b)
391 :     fun hash (FV{id, ...}) = Stamp.hash id
392 :     fun toString (FV{name, id, ...}) = name ^ Stamp.toString id
393 :     fun use (f as FV{useCnt, ...}) = (useCnt := !useCnt + 1; f)
394 :     fun decCnt (FV{useCnt, ...}) = (useCnt := !useCnt - 1)
395 :     fun useCount (FV{useCnt, ...}) = !useCnt
396 :     (* properties *)
397 :     fun newProp initFn = PropList.newProp (fn (FV{props, ...}) => props, initFn)
398 :     fun newFlag () = PropList.newFlag (fn (FV{props, ...}) => props)
399 :     (* collections *)
400 :     local
401 :     structure FV =
402 :     struct
403 :     type ord_key = func
404 :     val compare = compare
405 :     end
406 :     in
407 :     structure Map = RedBlackMapFn (FV)
408 :     structure Set = RedBlackSetFn (FV)
409 :     end
410 :     structure Tbl = HashTableFn (
411 :     struct
412 :     type hash_key = func
413 :     val hashVal = hash
414 :     val sameKey = same
415 :     end)
416 :     end
417 :    
418 : jhr 4362 structure RHS =
419 :     struct
420 :     fun vars rhs = (case rhs
421 :     of GLOBAL _ => []
422 :     | STATE(SOME x, _) => [x]
423 :     | STATE _ => []
424 :     | VAR x => [x]
425 :     | LIT _ => []
426 :     | OP(rator, xs) => xs
427 :     | CONS(xs, _) => xs
428 :     | SEQ(xs, _) => xs
429 :     | EINAPP(_, xs) => xs
430 :     | APPLY(_, xs) => xs
431 : jhr 4378 | MAPREDUCE mrs => List.foldr (fn ((_, _, args), xs) => args@xs) [] mrs
432 : jhr 4362 (* end case *))
433 :    
434 :     fun map f = let
435 :     fun mapf rhs = (case rhs
436 :     of GLOBAL _ => rhs
437 :     | STATE(SOME x, sv) => STATE(SOME(f x), sv)
438 :     | STATE _ => rhs
439 :     | VAR x => VAR(f x)
440 :     | LIT _ => rhs
441 :     | OP(rator, xs) => OP(rator, List.map f xs)
442 :     | CONS(xs, ty) => CONS(List.map f xs, ty)
443 :     | SEQ(xs, ty) => SEQ(List.map f xs, ty)
444 :     | EINAPP(ein, xs) => EINAPP(ein, List.map f xs)
445 :     | APPLY(g, xs) => APPLY(g, List.map f xs)
446 : jhr 4378 | MAPREDUCE mrs =>
447 :     MAPREDUCE(List.map (fn (r, g, xs) => (r, g, List.map f xs)) mrs)
448 : jhr 4362 (* end case *))
449 :     in
450 :     mapf
451 :     end
452 :    
453 :     fun app f = let
454 :     fun appf rhs = (case rhs
455 :     of GLOBAL _ => ()
456 :     | STATE(SOME x, _) => f x
457 :     | STATE _ => ()
458 :     | VAR x => f x
459 :     | LIT _ => ()
460 :     | OP(rator, xs) => List.app f xs
461 :     | CONS(xs, _) => List.app f xs
462 :     | SEQ(xs, _) => List.app f xs
463 :     | EINAPP(_, xs) => List.app f xs
464 :     | APPLY(_, xs) => List.app f xs
465 : jhr 4378 | MAPREDUCE mrs => List.app (fn (_, _, xs) => List.app f xs) mrs
466 : jhr 4362 (* end case *))
467 :     in
468 :     appf
469 :     end
470 :    
471 :     (* return a string representation of a rhs *)
472 :     fun toString rhs = (case rhs
473 :     of GLOBAL x => GlobalVar.toString x
474 :     | STATE(NONE, x) => "self." ^ StateVar.toString x
475 :     | STATE(SOME x, y) => String.concat[Var.toString x, ".", StateVar.toString y]
476 :     | VAR x => Var.toString x
477 :     | LIT lit => Literal.toString lit
478 :     | OP(rator, xs) => String.concat [
479 :     Op.toString rator,
480 :     "(", String.concatWithMap "," Var.toString xs, ")"
481 :     ]
482 :     | CONS(xs, ty) => String.concat [
483 :     "<", Ty.toString ty, ">[",
484 :     String.concatWithMap "," Var.toString xs, "]"
485 :     ]
486 :     | SEQ(xs, ty) => String.concat [
487 :     "<", Ty.toString ty, ">{",
488 :     String.concatWithMap "," Var.toString xs, "}"
489 :     ]
490 :     | EINAPP(ein, xs) => String.concat [
491 :     EinPP.toString ein, " (",
492 :     String.concatWithMap "," Var.toString xs, ")"
493 :     ]
494 :     | APPLY(f, xs) => String.concat [
495 :     Func.toString f, " (",
496 :     String.concatWithMap "," Var.toString xs, ")"
497 :     ]
498 : jhr 4378 | MAPREDUCE[(r, f, args)] => String.concat [
499 :     Reductions.toString r, "(MAP ", Func.toString f, " (",
500 :     String.concatWithMap "," Var.toString args, "))"
501 : jhr 4362 ]
502 : jhr 4378 | MAPREDUCE mrs => let
503 :     fun toS (r, f, args) = String.concat [
504 :     Reductions.toString r, "(MAP ", Func.toString f, " (",
505 :     String.concatWithMap "," Var.toString args, "))"
506 :     ]
507 :     in
508 :     String.concat ["{ ", String.concatWithMap " | " toS mrs, " }"]
509 :     end
510 : jhr 4362 (* end case *))
511 :     end
512 :    
513 : jhr 3470 structure Node =
514 :     struct
515 :     fun id (ND{id, ...}) = id
516 :     fun kind (ND{kind, ...}) = kind
517 :     fun same (ND{id=a, ...}, ND{id=b, ...}) = Stamp.same(a, b)
518 :     fun compare (ND{id=a, ...}, ND{id=b, ...}) = Stamp.compare(a, b)
519 :     fun hash (ND{id, ...}) = Stamp.hash id
520 :     fun toString (ND{id, kind, ...}) = let
521 :     val tag = (case kind
522 :     of NULL => "NULL"
523 :     | ENTRY _ => "ENTRY"
524 :     | JOIN _ => "JOIN"
525 :     | COND _ => "COND"
526 : jhr 3837 | FOREACH _ => "FOREACH"
527 :     | NEXT _ => "NEXT"
528 : jhr 3470 | COM _ => "COM"
529 :     | ASSIGN _ => "ASSIGN"
530 :     | MASSIGN _ => "MASSIGN"
531 :     | GASSIGN _ => "GASSIGN"
532 :     | NEW _ => "NEW"
533 :     | SAVE _ => "SAVE"
534 : jhr 4164 | EXIT{kind, ...} => ExitKind.toString Var.toString kind
535 : jhr 3470 (* end case *))
536 :     in
537 :     tag ^ Stamp.toString id
538 :     end
539 :     fun new kind = ND{id = Stamp.new(), props = PropList.newHolder(), kind = kind}
540 :     (* variable defs and uses *)
541 :     fun uses (ND{kind, ...}) = (case kind
542 :     of JOIN{phis, ...} => let
543 :     fun add ([], ys) = ys
544 :     | add (SOME x :: xs, ys) = add(xs, x::ys)
545 :     | add (NONE :: xs, ys) = add(xs, ys)
546 :     in
547 :     List.foldr (fn ((_, xs), ys) => add(xs, ys)) [] (!phis)
548 :     end
549 : jhr 3536 | COND{cond, ...} => [!cond]
550 : jhr 3837 | FOREACH{src, phis, ...} => let
551 :     fun add ([], ys) = ys
552 : jhr 3473 | add (SOME x :: xs, ys) = add(xs, x::ys)
553 :     | add (NONE :: xs, ys) = add(xs, ys)
554 :     in
555 : jhr 3536 List.foldr (fn ((_, xs), ys) => add(xs, ys)) [!src] (!phis)
556 : jhr 3473 end
557 : jhr 3837 | NEXT _ => []
558 : jhr 4362 | ASSIGN{stm=(y, rhs), ...} => RHS.vars rhs
559 :     | MASSIGN{stm=(_, rhs), ...} => RHS.vars rhs
560 : jhr 3470 | GASSIGN{rhs, ...} => [rhs]
561 :     | NEW{args, ...} => args
562 :     | SAVE{rhs, ...} => [rhs]
563 :     | _ => []
564 :     (* end case *))
565 :     fun defs (ND{kind, ...}) = (case kind
566 :     of JOIN{phis, ...} => List.map #1 (!phis)
567 : jhr 3837 | FOREACH{var, phis, ...} => var :: List.map #1 (!phis)
568 : jhr 3470 | ASSIGN{stm=(y, _), ...} => [y]
569 : jhr 4362 | MASSIGN{stm=(ys, _), ...} => ys
570 : jhr 3470 | _ => []
571 :     (* end case *))
572 :     val dummy = new NULL
573 :     fun mkENTRY () = new (ENTRY{succ = ref dummy})
574 :     fun mkJOIN phis = new (JOIN{preds = ref [], mask = ref [], phis = ref phis, succ = ref dummy})
575 :     fun mkCOND cond = new (COND{
576 : jhr 3536 pred = ref dummy, cond = ref cond,
577 : jhr 3470 trueBranch = ref dummy, falseBranch = ref dummy
578 :     })
579 : jhr 3837 fun mkFOREACH (var, src) = (
580 :     Var.setBinding (var, VB_ITER);
581 :     new (FOREACH{
582 :     pred = ref dummy,
583 :     phis = ref [], mask = ref [],
584 :     var = var, src = ref src,
585 :     bodyEntry = ref dummy,
586 :     bodyExit = ref dummy,
587 :     succ = ref dummy
588 :     }))
589 :     fun mkNEXT () = new(NEXT{pred = ref dummy, succ = ref dummy})
590 : jhr 3470 fun mkCOM text = new (COM{pred = ref dummy, text = text, succ = ref dummy})
591 :     fun mkASSIGN (lhs, rhs) = (
592 :     Var.setBinding (lhs, VB_RHS rhs);
593 :     new (ASSIGN{pred = ref dummy, stm = (lhs, rhs), succ = ref dummy}))
594 : jhr 4362 fun mkMASSIGN (lhs, rhs) = let
595 : jhr 3470 fun setB (_, []) = ()
596 :     | setB (i, x::xs) = (
597 : jhr 4362 Var.setBinding (x, VB_MULTIOP(i, rhs));
598 : jhr 3470 setB (i+1, xs))
599 :     in
600 :     setB (0, lhs);
601 : jhr 4362 new (MASSIGN{pred = ref dummy, stm = (lhs, rhs), succ = ref dummy})
602 : jhr 3470 end
603 : jhr 3586 fun mkGASSIGN (lhs, rhs) = (
604 : jhr 3843 if not(GlobalVar.isVarying lhs) then GlobalVar.setBinding(lhs, rhs) else ();
605 : jhr 3837 new (GASSIGN{pred = ref dummy, lhs = lhs, rhs = rhs, succ = ref dummy}))
606 : jhr 4339 fun mkNEW (strand, args) = new (NEW{
607 : jhr 3470 pred = ref dummy, strand = strand, args = args, succ = ref dummy
608 :     })
609 :     fun mkSAVE (lhs, rhs) = new (SAVE{
610 :     pred = ref dummy, lhs = lhs, rhs = rhs, succ = ref dummy
611 :     })
612 : jhr 3505 fun mkEXIT kind = new (EXIT{kind = kind, pred = ref dummy, succ = ref NONE})
613 : jhr 4164 fun mkRETURN optX = mkEXIT (ExitKind.RETURN optX)
614 : jhr 3505 fun mkACTIVE () = mkEXIT ExitKind.ACTIVE
615 :     fun mkSTABILIZE () = mkEXIT ExitKind.STABILIZE
616 :     fun mkDIE () = mkEXIT ExitKind.DIE
617 : jhr 5286 fun mkNEXTSTEP () = mkEXIT ExitKind.NEXTSTEP
618 : jhr 3505 fun mkUNREACHABLE () = mkEXIT ExitKind.UNREACHABLE
619 : jhr 3470 fun isNULL (ND{kind=NULL, ...}) = true
620 :     | isNULL _ = false
621 :     (* is a node reachable from the CFG entry; UNREACHABLE exit nodes and JOINs with no real
622 :     * predecessors are unreachable.
623 :     *)
624 :     fun isReachable (ND{kind=EXIT{kind=ExitKind.UNREACHABLE, ...}, ...}) = false
625 :     | isReachable (ND{kind=JOIN{mask, ...}, ...}) = List.exists not (!mask)
626 :     | isReachable _ = true
627 :     (* editing node edges *)
628 :     fun hasPred (ND{kind, ...}) = (case kind
629 :     of NULL => false
630 :     | ENTRY _ => false
631 :     | _ => true
632 :     (* end case *))
633 :     fun setPred (nd0 as ND{kind, ...}, nd) = (case kind
634 :     of NULL => raise Fail("setPred on NULL node " ^ toString nd0)
635 :     | ENTRY _ => raise Fail("setPred on ENTRY node " ^ toString nd0)
636 :     | JOIN{preds, ...} => preds := !preds @ [nd] (* assume preds are added in order *)
637 : jhr 3837 | FOREACH{pred, ...} => pred := nd
638 :     | NEXT{pred, ...} => pred := nd
639 : jhr 3470 | COND{pred, ...} => pred := nd
640 :     | COM{pred, ...} => pred := nd
641 :     | ASSIGN{pred, ...} => pred := nd
642 :     | MASSIGN{pred, ...} => pred := nd
643 :     | GASSIGN{pred, ...} => pred := nd
644 :     | NEW{pred, ...} => pred := nd
645 :     | SAVE{pred, ...} => pred := nd
646 :     | EXIT{pred, ...} => pred := nd
647 :     (* end case *))
648 :     fun preds (nd as ND{kind, ...}) = (case kind
649 :     of NULL => [] (*raise Fail("preds on NULL node "^toString nd)*)
650 :     | ENTRY _ => []
651 :     | JOIN{preds, ...} => !preds
652 :     | COND{pred, ...} => [!pred]
653 : jhr 3837 | FOREACH{pred, bodyExit, ...} => [!pred, !bodyExit]
654 : jhr 3754 | NEXT{pred, ...} => [!pred]
655 : jhr 3470 | COM{pred, ...} => [!pred]
656 :     | ASSIGN{pred, ...} => [!pred]
657 :     | MASSIGN{pred, ...} => [!pred]
658 :     | GASSIGN{pred, ...} => [!pred]
659 :     | NEW{pred, ...} => [!pred]
660 :     | SAVE{pred, ...} => [!pred]
661 :     | EXIT{pred, ...} => [!pred]
662 :     (* end case *))
663 :     fun hasSucc (ND{kind, ...}) = (case kind
664 :     of NULL => false
665 :     | ENTRY _ => true
666 :     | JOIN _ => true
667 :     | COND _ => true
668 :     | COM _ => true
669 : jhr 3473 | FOREACH _ => true
670 : jhr 3754 | NEXT _ => true
671 : jhr 3470 | ASSIGN _ => true
672 :     | MASSIGN _ => true
673 :     | GASSIGN _ => true
674 :     | NEW _ => true
675 :     | SAVE _ => true
676 :     | EXIT{succ=ref(SOME _), ...} => true
677 :     | EXIT _ => false
678 :     (* end case *))
679 :     fun setSucc (nd0 as ND{kind, ...}, nd) = (case kind
680 :     of NULL => raise Fail("setSucc on NULL node "^toString nd0)
681 :     | ENTRY{succ} => succ := nd
682 :     | JOIN{succ, ...} => succ := nd
683 :     | COND _ => raise Fail("setSucc on COND node "^toString nd0)
684 : jhr 3501 | FOREACH{succ, ...} => succ := nd
685 : jhr 3754 | NEXT{succ, ...} => succ := nd
686 : jhr 3470 | COM{succ, ...} => succ := nd
687 :     | ASSIGN{succ, ...} => succ := nd
688 :     | MASSIGN{succ, ...} => succ := nd
689 :     | GASSIGN{succ, ...} => succ := nd
690 :     | NEW{succ, ...} => succ := nd
691 :     | SAVE{succ, ...} => succ := nd
692 :     | EXIT{succ, ...} => succ := SOME nd
693 :     (* end case *))
694 :     fun succs (ND{kind, ...}) = (case kind
695 :     of NULL => [] (*raise Fail("succs on NULL node "^toString nd)*)
696 :     | ENTRY{succ} => [!succ]
697 :     | JOIN{succ, ...} => [!succ]
698 :     | COND{trueBranch, falseBranch, ...} => [!trueBranch, !falseBranch]
699 : jhr 3837 | FOREACH{bodyEntry, succ, ...} => [!bodyEntry, !succ]
700 : jhr 3754 | NEXT{succ, ...} => [!succ]
701 : jhr 3470 | COM{succ, ...} => [!succ]
702 :     | ASSIGN{succ, ...} => [!succ]
703 :     | MASSIGN{succ, ...} => [!succ]
704 :     | GASSIGN{succ, ...} => [!succ]
705 :     | NEW{succ, ...} => [!succ]
706 :     | SAVE{succ, ...} => [!succ]
707 :     | EXIT{succ=ref(SOME nd), ...} => [nd]
708 :     | EXIT _ => []
709 :     (* end case *))
710 :     (* QUESTION: should these functions also do the setPred operation? *)
711 :     fun setTrueBranch (ND{kind=COND{trueBranch, ...}, ...}, nd) = trueBranch := nd
712 :     | setTrueBranch (nd, _) = raise Fail("setTrueBranch on " ^ toString nd)
713 :     fun setFalseBranch (ND{kind=COND{falseBranch, ...}, ...}, nd) = falseBranch := nd
714 :     | setFalseBranch (nd, _) = raise Fail("setFalseBranch on " ^ toString nd)
715 : jhr 3837 fun setBodyEntry (ND{kind=FOREACH{bodyEntry, ...}, ...}, nd) = bodyEntry := nd
716 :     | setBodyEntry (nd, _) = raise Fail("setBodyEntry on " ^ toString nd)
717 :     fun setBodyExit (ND{kind=FOREACH{bodyExit, ...}, ...}, nd) = bodyExit := nd
718 :     | setBodyExit (nd, _) = raise Fail("setBodyExit on " ^ toString nd)
719 : jhr 4342 fun setPhis (ND{kind=JOIN{phis, ...}, ...}, phis') = phis := phis'
720 : jhr 4369 | setPhis (ND{kind=FOREACH{phis, ...}, ...}, phis') = phis := phis'
721 : jhr 4342 | setPhis (nd, _) = raise Fail("setPhis on " ^ toString nd)
722 : jhr 3470 fun setEdgeMask (ND{kind=JOIN{mask, ...}, ...}, mask') = mask := mask'
723 : jhr 4369 | setEdgeMask (ND{kind=FOREACH{mask, ...}, ...}, mask') = mask := mask'
724 : jhr 3470 | setEdgeMask (nd, _) = raise Fail("setEdgeMask on " ^ toString nd)
725 :     fun addEdge (nd1, nd2) = (
726 :     if hasSucc nd1
727 :     then (
728 :     setSucc (nd1, nd2);
729 :     setPred (nd2, nd1))
730 :     else ())
731 :     (*DEBUG*)handle ex => (
732 :     print(concat["error in addEdge(", toString nd1, ",", toString nd2, ")\n"]);
733 :     raise ex)
734 : jhr 3502 (* replace the edge src-->oldDst by the edge src-->dst *)
735 : jhr 3937 fun replaceOutEdge {src, oldDst, dst} = (
736 : jhr 3470 (* first set the successor of src *)
737 :     case kind src
738 :     of COND{trueBranch, falseBranch, ...} =>
739 :     if same(!trueBranch, oldDst)
740 :     then trueBranch := dst
741 :     else falseBranch := dst
742 : jhr 3837 | FOREACH{bodyEntry, succ, ...} =>
743 :     if same(!bodyEntry, oldDst)
744 :     then bodyEntry := dst
745 :     else succ := dst
746 : jhr 3470 | _ => setSucc (src, dst)
747 :     (* end case *);
748 :     (* then set the predecessor of dst *)
749 : jhr 3837 case kind oldDst
750 :     of FOREACH{bodyExit, pred, ...} =>
751 :     if same(!bodyExit, src)
752 :     then setBodyExit (dst, src)
753 :     else setPred (dst, src)
754 :     | _ => setPred (dst, src)
755 :     (* end case *))
756 : jhr 3470 (*DEBUG*)handle ex => (
757 : jhr 3937 print(concat["error in replaceOutEdge(", toString src, ",", toString oldDst, ",", toString dst, ")\n"]);
758 : jhr 3470 raise ex)
759 : jhr 3502 (* replace the edge oldSrc-->dst by the edge src-->dst *)
760 : jhr 3937 fun replaceInEdge {oldSrc, src, dst} = (
761 : jhr 4204 (* first set the successor of src; check to see if we are replacing a conditional
762 : jhr 4317 * node with a conditional node.
763 :     *)
764 : jhr 4204 case (kind oldSrc, kind src)
765 :     of (COND{trueBranch, falseBranch, ...}, COND _) =>
766 : jhr 3470 if same(!trueBranch, dst)
767 :     then setTrueBranch (src, dst)
768 :     else setFalseBranch (src, dst)
769 : jhr 4204 | (FOREACH{bodyEntry, succ, ...}, FOREACH _) =>
770 : jhr 3837 if same(!bodyEntry, dst)
771 :     then setBodyEntry (src, dst)
772 :     else setSucc (src, dst)
773 : jhr 3470 | _ => setSucc (src, dst)
774 :     (* end case *);
775 :     (* then set the predecessor of dst *)
776 :     case kind dst
777 :     of JOIN{preds, ...} => let
778 : jhr 3937 fun edit [] = raise Fail "replaceInEdge: cannot find predecessor"
779 : jhr 3470 | edit (nd::nds) = if same(nd, oldSrc) then src::nds else nd::edit nds
780 :     in
781 :     preds := edit (!preds)
782 :     end
783 : jhr 3837 | FOREACH{bodyExit, pred, ...} =>
784 :     if same(!bodyExit, oldSrc)
785 :     then bodyExit := src
786 :     else pred := src
787 : jhr 3470 | _ => setPred (dst, src)
788 :     (* end case *))
789 :     (*DEBUG*)handle ex => (
790 : jhr 3937 print(concat["error in replaceInEdge(", toString oldSrc, ",", toString src, ",", toString dst, ")\n"]);
791 : jhr 3470 raise ex)
792 :     (* properties *)
793 :     fun newProp initFn =
794 : jhr 3837 PropList.newProp (fn (ND{props, ...}) => props, initFn)
795 : jhr 3470 fun newFlag () =
796 : jhr 3837 PropList.newFlag (fn (ND{props, ...}) => props)
797 : jhr 3470 end
798 :    
799 :     structure CFG =
800 :     struct
801 :     val empty = CFG{entry = Node.dummy, exit = Node.dummy}
802 :    
803 :     fun isEmpty (CFG{entry, exit}) =
804 :     Node.same(entry, exit) andalso Node.isNULL entry
805 :    
806 :     (* create a basic block from a list of assignments *)
807 :     fun mkBlock [] = empty
808 :     | mkBlock (stm::stms) = let
809 :     fun mkNode (ASSGN stm) = Node.mkASSIGN stm
810 :     | mkNode (MASSGN stm) = Node.mkMASSIGN stm
811 :     | mkNode (GASSGN stm) = Node.mkGASSIGN stm
812 :     | mkNode (SAV stm) = Node.mkSAVE stm
813 :     val entry = mkNode stm
814 :     fun f (stm, prev) = let
815 :     val nd = mkNode stm
816 :     in
817 :     Node.addEdge (prev, nd);
818 :     nd
819 :     end
820 :     val exit = List.foldl f entry stms
821 :     in
822 :     CFG{entry = entry, exit = exit}
823 :     end
824 :    
825 :     (* entry/exit nodes of a CFG *)
826 :     fun entry (CFG{entry = nd, ...}) = nd
827 :     fun exit (CFG{exit = nd, ...}) = nd
828 :    
829 : jhr 3879 (* DFS sorting of the graph rooted at the entry node; the resulting list will
830 : jhr 3470 * be in preorder with parents before children.
831 :     *)
832 :     fun sort (CFG{entry, ...}) = let
833 :     val {getFn, setFn} = PropList.newFlag (fn (ND{props, ...}) => props)
834 :     fun dfs (nd, l) =
835 :     if getFn nd
836 :     then l
837 :     else (
838 :     setFn (nd, true);
839 :     nd :: List.foldl dfs l (Node.succs nd))
840 :     val nodes = dfs (entry, [])
841 :     in
842 :     List.app (fn nd => setFn(nd, false)) nodes;
843 :     nodes
844 :     end
845 :    
846 :     (* apply a function to all of the nodes in the graph rooted at the entry to the statement *)
847 :     fun apply (f : node -> unit) (CFG{entry, ...}) = let
848 :     val {getFn, setFn} = Node.newFlag()
849 :     fun dfs (nd, l) =
850 :     if getFn nd
851 :     then l
852 :     else (
853 :     f nd; (* visit *)
854 :     setFn (nd, true);
855 :     nd :: List.foldl dfs l (Node.succs nd))
856 :     val nodes = dfs (entry, [])
857 :     in
858 :     List.app (fn nd => setFn(nd, false)) nodes
859 :     end
860 :    
861 :     (* delete a simple node from a CFG *)
862 :     fun deleteNode (nd as ND{kind, ...}) = let
863 :     val (pred, succ) = (case kind
864 :     of COM{pred = ref pred, succ = ref succ, ...} => (pred, succ)
865 :     | ASSIGN{pred = ref pred, succ = ref succ, ...} => (pred, succ)
866 :     | MASSIGN{pred = ref pred, succ = ref succ, ...} => (pred, succ)
867 :     | GASSIGN{pred = ref pred, succ = ref succ, ...} => (pred, succ)
868 :     | NEW{pred = ref pred, succ = ref succ, ...} => (pred, succ)
869 :     | SAVE{pred = ref pred, succ = ref succ, ...} => (pred, succ)
870 :     | _ => raise Fail(concat["unsupported deleteNode(", Node.toString nd, ")\n"])
871 :     (* end case *))
872 :     in
873 :     (* replace the predecessor edge from succ to nd with an edge from succ to pred *)
874 :     case Node.kind succ
875 :     of JOIN{preds, ...} => let
876 :     fun edit [] = raise Fail "deleteNode: cannot find predecessor"
877 :     | edit (nd'::nds) = if Node.same(nd', nd) then pred::nds else nd'::edit nds
878 :     in
879 :     preds := edit (!preds)
880 :     end
881 : jhr 3837 | FOREACH{pred=pred', bodyExit, ...} =>
882 :     if Node.same(!pred', nd)
883 :     then pred' := pred
884 :     else bodyExit := pred
885 : jhr 3470 | _ => Node.setPred (succ, pred)
886 :     (* end case *);
887 :     (* replace the successor edge from pred to nd with an edge from pred to succ *)
888 :     case Node.kind pred
889 :     of COND{trueBranch, falseBranch, ...} => (
890 :     (* note that we treat each branch independently, so that we handle the
891 :     * situation where both branches are the same node.
892 :     *)
893 :     if Node.same(!trueBranch, nd)
894 : jhr 3536 then trueBranch := succ
895 : jhr 3470 else ();
896 :     if Node.same(!falseBranch, nd)
897 : jhr 3536 then falseBranch := succ
898 : jhr 3470 else ())
899 : jhr 3837 | FOREACH{bodyEntry, succ=succ', ...} =>
900 :     if Node.same(!bodyEntry, nd)
901 :     then bodyEntry := succ
902 :     else succ' := succ
903 : jhr 4672 | NEXT _ => raise Fail "deleteNode: pred is NEXT"
904 : jhr 3470 | _ => Node.setSucc (pred, succ)
905 :     (* end case *)
906 :     end
907 :     (*DEBUG*)handle ex => (
908 :     print(concat["error in deleteNode(", Node.toString nd, ")\n"]);
909 :     raise ex)
910 :    
911 :     (* replace a simple node in a cfg with a subgraph *)
912 :     fun replaceNode (oldNd as ND{kind, ...}, node) = (case kind
913 :     of ASSIGN{pred, succ, ...} => (
914 : jhr 3937 Node.replaceOutEdge {src = !pred, oldDst = oldNd, dst = node};
915 :     Node.replaceInEdge {oldSrc = oldNd, src = node, dst = !succ})
916 : jhr 3470 | MASSIGN{pred, succ, ...} => (
917 : jhr 3937 Node.replaceOutEdge {src = !pred, oldDst = oldNd, dst = node};
918 :     Node.replaceInEdge {oldSrc = oldNd, src = node, dst = !succ})
919 : jhr 3470 | GASSIGN{pred, succ, ...} => (
920 : jhr 3937 Node.replaceOutEdge {src = !pred, oldDst = oldNd, dst = node};
921 :     Node.replaceInEdge {oldSrc = oldNd, src = node, dst = !succ})
922 : jhr 3470 | NEW{pred, succ, ...} => (
923 : jhr 3937 Node.replaceOutEdge {src = !pred, oldDst = oldNd, dst = node};
924 :     Node.replaceInEdge {oldSrc = oldNd, src = node, dst = !succ})
925 : jhr 3470 | SAVE{pred, succ, ...} => (
926 : jhr 3937 Node.replaceOutEdge {src = !pred, oldDst = oldNd, dst = node};
927 :     Node.replaceInEdge {oldSrc = oldNd, src = node, dst = !succ})
928 : jhr 3470 | EXIT{pred, succ=ref NONE, ...} =>
929 : jhr 3937 Node.replaceOutEdge {src = !pred, oldDst = oldNd, dst = node}
930 : jhr 4807 | EXIT{pred, succ=ref(SOME succ), ...} => (
931 :     Node.replaceOutEdge {src = !pred, oldDst = oldNd, dst = node};
932 :     Node.replaceInEdge {oldSrc = oldNd, src = node, dst = succ})
933 : jhr 3470 | _ => raise Fail(concat[
934 :     "unsupported replaceNode(", Node.toString oldNd, ", ", Node.toString node, ")"
935 :     ])
936 :     (* end case *))
937 :    
938 :     (* replace a simple node in a cfg with a subgraph *)
939 :     fun replaceNodeWithCFG (nd as ND{kind, ...}, cfg as CFG{entry, exit}) =
940 :     if isEmpty cfg
941 :     then deleteNode nd
942 :     else (case kind
943 :     of ASSIGN{pred, succ, ...} => (
944 : jhr 3937 Node.replaceOutEdge {src = !pred, oldDst = nd, dst = entry};
945 :     Node.replaceInEdge {oldSrc = nd, src = exit, dst = !succ})
946 : jhr 3470 | MASSIGN{pred, succ, ...} => (
947 : jhr 3937 Node.replaceOutEdge {src = !pred, oldDst = nd, dst = entry};
948 :     Node.replaceInEdge {oldSrc = nd, src = exit, dst = !succ})
949 : jhr 3470 | _ => raise Fail "unsupported replaceNodeWithCFG"
950 :     (* end case *))
951 :    
952 :     (* concatenate two CFGs *)
953 :     fun concat (cfg1 as CFG{entry=e1, exit=x1}, cfg2 as CFG{entry=e2, exit=x2}) =
954 :     if isEmpty cfg1 then cfg2
955 :     else if isEmpty cfg2 then cfg1
956 :     else (
957 :     Node.setSucc (x1, e2);
958 :     Node.setPred (e2, x1);
959 :     CFG{entry = e1, exit = x2})
960 :     (*DEBUG*)handle ex => (
961 :     print(String.concat["error in concat({", Node.toString e1, ",", Node.toString x1,
962 :     "},{", Node.toString e2, ",", Node.toString x2, "})\n"]);
963 :     raise ex)
964 :    
965 :     (* prepend a node to a CFG *)
966 :     fun prependNode (nd, cfg as CFG{entry, exit}) =
967 :     if isEmpty cfg
968 :     then CFG{entry=nd, exit=nd}
969 :     else (
970 :     Node.setSucc (nd, entry);
971 :     Node.setPred (entry, nd);
972 :     CFG{entry=nd, exit=exit})
973 :    
974 :     (* append a node to a CFG *)
975 :     fun appendNode (cfg as CFG{entry, exit}, nd) =
976 :     if isEmpty cfg
977 :     then CFG{entry=nd, exit=nd}
978 :     else (
979 :     Node.setPred (nd, exit);
980 :     Node.setSucc (exit, nd);
981 :     CFG{entry=entry, exit=nd})
982 :    
983 :     (* insert a block of assignments at the beginning of the CFG. If the CFG has an ENTRY
984 :     * node, then the block is inserted immediatly following the entry.
985 :     *)
986 :     fun prependBlock ([], cfg) = cfg
987 :     | prependBlock (stms, cfg as CFG{entry, exit}) = (case entry
988 :     of ND{kind=ENTRY{succ}, ...} => let
989 :     fun mkNode (ASSGN stm) = Node.mkASSIGN stm
990 :     | mkNode (MASSGN stm) = Node.mkMASSIGN stm
991 :     | mkNode (GASSGN stm) = Node.mkGASSIGN stm
992 :     | mkNode (SAV stm) = Node.mkSAVE stm
993 :     fun f (stm, succ) = let
994 :     val nd = mkNode stm
995 :     in
996 :     Node.addEdge (nd, succ);
997 :     nd
998 :     end
999 :     val first = List.foldr f (!succ) stms
1000 :     in
1001 :     succ := first;
1002 :     Node.setPred (first, entry);
1003 :     cfg
1004 :     end
1005 :     | _ => concat(mkBlock stms, cfg)
1006 :     (* end case *))
1007 :    
1008 :     (* insert a block of assignments at the end of the CFG argument If the CFG has an EXIT
1009 :     * node, then the block is inserted immediatly before the exit.
1010 :     *)
1011 :     fun appendBlock (cfg, []) = cfg
1012 : jhr 3754 | appendBlock (cfg as CFG{entry, exit}, stms) = let
1013 : jhr 3837 fun mkNode (ASSGN stm) = Node.mkASSIGN stm
1014 :     | mkNode (MASSGN stm) = Node.mkMASSIGN stm
1015 :     | mkNode (GASSGN stm) = Node.mkGASSIGN stm
1016 :     | mkNode (SAV stm) = Node.mkSAVE stm
1017 :     fun f (stm, prev) = let
1018 :     val nd = mkNode stm
1019 :     in
1020 :     Node.addEdge (prev, nd);
1021 :     nd
1022 :     end
1023 :     in
1024 :     case exit
1025 :     of ND{kind=EXIT{pred, ...}, ...} => let
1026 :     val last = List.foldl f (!pred) stms
1027 :     in
1028 :     pred := last;
1029 :     Node.setSucc(last, exit);
1030 :     cfg
1031 :     end
1032 :     | ND{kind=NEXT{pred, ...}, ...} => let
1033 :     val last = List.foldl f (!pred) stms
1034 :     in
1035 :     pred := last;
1036 :     Node.setSucc(last, exit);
1037 :     cfg
1038 :     end
1039 :     | _ => concat(cfg, mkBlock stms)
1040 :     (* end case *)
1041 :     end
1042 : jhr 3470 end
1043 :    
1044 :     (* return a string representation of a variable binding *)
1045 :     fun vbToString VB_NONE = "NONE"
1046 :     | vbToString (VB_RHS rhs) = concat["RHS(", RHS.toString rhs, ")"]
1047 : jhr 4362 | vbToString (VB_MULTIOP(i, rhs)) = concat["MULTIOP(", RHS.toString rhs, ")"]
1048 : jhr 3470 | vbToString (VB_PHI xs) = concat[
1049 :     "PHI(",
1050 :     String.concatWithMap "," (fn NONE => "_" | SOME x => Var.toString x) xs, ")"
1051 :     ]
1052 :     | vbToString VB_PARAM = "PARAM"
1053 : jhr 3522 | vbToString VB_ITER = "ITER"
1054 : jhr 3470
1055 :     (* return a string representation of a PHI node *)
1056 :     fun phiToString (y, xs) = String.concat [
1057 :     Ty.toString(Var.ty y), " ", Var.toString y, " = PHI(",
1058 :     String.concatWithMap "," (fn NONE => "_" | SOME x => Var.toString x) xs, ")"
1059 :     ]
1060 :    
1061 :     (* return a string representation of an assignment *)
1062 :     fun assignToString (y, rhs) =
1063 :     String.concat [Ty.toString(Var.ty y), " ", Var.toString y, " = ", RHS.toString rhs]
1064 : jhr 4362 fun massignToString (ys, rhs) = String.concat [
1065 : jhr 3470 "(", String.concatWithMap ","
1066 :     (fn y => concat[Ty.toString(Var.ty y), " ", Var.toString y]) ys,
1067 : jhr 4362 " = ", RHS.toString rhs
1068 : jhr 3470 ]
1069 :     fun assignmentToString (ASSGN asgn) = assignToString asgn
1070 :     | assignmentToString (MASSGN masgn) = massignToString masgn
1071 :     | assignmentToString (GASSGN(lhs, rhs)) = String.concat[
1072 :     GlobalVar.toString lhs, " = ", Var.toString rhs
1073 :     ]
1074 :     | assignmentToString (SAV(lhs, rhs)) = String.concat[
1075 :     StateVar.toString lhs, " = ", Var.toString rhs
1076 :     ]
1077 :    
1078 :     end (* SSAFn *)

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