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

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