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

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