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 3349 - (view) (download)

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

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