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 1116 - (view) (download)
Original Path: trunk/src/compiler/IL/ssa-fn.sml

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

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