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

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