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

SCM Repository

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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1640 - (view) (download)
Original Path: trunk/src/compiler/IL/ssa-fn.sml

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

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