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

SCM Repository

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

Annotation of /trunk/src/compiler/IL/ssa-fn.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2356 - (view) (download)

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

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