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

SCM Repository

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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 501 - (view) (download)

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

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