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

SCM Repository

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

Annotation of /branches/vis15/src/compiler/cfg-ir/ssa-fn.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3517 - (view) (download)

1 : jhr 3470 (* ssa-fn.sml
2 :     *
3 :     * This code is part of the Diderot Project (http://diderot-language.cs.uchicago.edu)
4 :     *
5 :     * COPYRIGHT (c) 2015 The University of Chicago
6 :     * All rights reserved.
7 :     *
8 : jhr 3475 * The SSAFn functor is used to generate the High, Med, and Low IRs in the Diderot
9 :     * compiler. These IRs have the same program and control-flow structure, but differ
10 : jhr 3470 * in their types and operators.
11 :     *)
12 :    
13 :     functor SSAFn (
14 :    
15 : jhr 3508 val irName : string
16 : jhr 3470
17 :     structure Ty : SSA_TYPES
18 :     structure Op : OPERATORS where type ty = Ty.ty
19 :    
20 :     ) : SSA = struct
21 :    
22 :     structure Ty = Ty
23 :     structure Op = Op
24 :    
25 : jhr 3508 val irName = irName
26 : jhr 3470
27 :     (***** CFG *****)
28 :    
29 :     datatype cfg = CFG of {
30 :     entry : node, (* the entry node of a graph; not necessarily an ENTRY node *)
31 :     exit : node (* the exit node of a graph; not necessarily an EXIT node. *)
32 :     }
33 :    
34 :     and node = ND of {
35 :     id : Stamp.stamp,
36 :     props : PropList.holder,
37 :     kind : node_kind
38 :     }
39 :    
40 :     and node_kind
41 :     = NULL
42 :     | ENTRY of {
43 :     succ : node ref
44 :     }
45 :     | JOIN of {
46 :     preds : node list ref, (* includes fake control-flow edges *)
47 :     mask : bool list ref, (* true for incoming fake edges *)
48 :     phis : phi list ref, (* data-flow joins corresponding to the edges in preds *)
49 :     succ : node ref
50 :     }
51 :     | COND of {
52 :     pred : node ref,
53 :     cond : var,
54 :     trueBranch : node ref,
55 :     falseBranch : node ref
56 :     }
57 : jhr 3473 | FOREACH of { (* foreach-loop; this node combines aspects of the COND
58 :     * and JOIN nodes. *)
59 : jhr 3502 pred : node ref, (* the predecessor *)
60 : jhr 3473 phis : phi list ref, (* phi nodes (as in JOIN) *)
61 :     mask : bool list ref, (* true for incoming fake edges *)
62 :     var : var, (* the loop variable *)
63 :     src : var, (* the source of values being iterated over *)
64 : jhr 3502 bodyEntry : node ref, (* the loop body entry node *)
65 :     bodyExit : node ref, (* the loop body exit node *)
66 : jhr 3473 succ : node ref (* the loop-exit edge *)
67 :     }
68 : jhr 3470 | COM of { (* comment *)
69 :     pred : node ref,
70 :     text : string list,
71 :     succ : node ref
72 :     }
73 :     | ASSIGN of { (* local-variable assignment *)
74 :     pred : node ref,
75 :     stm : assign,
76 :     succ : node ref
77 :     }
78 :     | MASSIGN of { (* multi-assignment *)
79 :     pred : node ref,
80 :     stm : massign,
81 :     succ : node ref
82 :     }
83 :     | GASSIGN of { (* global variable assignment *)
84 :     pred: node ref,
85 :     lhs : global_var,
86 :     rhs : var,
87 :     succ : node ref
88 :     }
89 :     | NEW of { (* create new strand instance *)
90 :     pred : node ref,
91 :     strand : Atom.atom,
92 :     args : var list,
93 :     succ : node ref
94 :     }
95 :     | SAVE of { (* save state variable *)
96 :     pred: node ref,
97 :     lhs : state_var,
98 :     rhs : var,
99 :     succ : node ref
100 :     }
101 :     | EXIT of { (* includes die and stabilize *)
102 :     pred : node ref,
103 :     kind : ExitKind.kind, (* kind of exit node *)
104 :     succ : node option ref (* optional fake control-flow edge for when the EXIT is *)
105 :     (* not the CFG exit node *)
106 :     }
107 :    
108 :     and rhs
109 :     = GLOBAL of global_var (* read global variable *)
110 :     | STATE of state_var (* read strand state variable *)
111 :     | VAR of var
112 :     | LIT of Literal.t
113 :     | OP of Op.rator * var list
114 :     | CONS of var list * Ty.ty (* tensor-value construction *)
115 :     | SEQ of var list * Ty.ty (* sequence-value construction *)
116 :     | EINAPP of Ein.ein * var list
117 :    
118 :     and var = V of {
119 :     name : string, (* name *)
120 :     id : Stamp.stamp, (* unique ID *)
121 :     ty : Ty.ty, (* type *)
122 :     bind : var_bind ref, (* binding *)
123 :     useCnt : int ref, (* count of uses *)
124 :     props : PropList.holder
125 :     }
126 :    
127 :     and var_bind
128 :     = VB_NONE
129 :     | VB_RHS of rhs (* defined by an assignment (includes globals and state variables) *)
130 :     | VB_MULTIOP of int * Op.rator * var list
131 :     (* n'th result of operator in multi-assignment *)
132 :     | VB_PHI of var option list (* defined by a phi node *)
133 :     | VB_PARAM (* parameter to a strand *)
134 :    
135 :     (***** global variables *****)
136 :     and global_var = GV of {
137 :     id : Stamp.stamp, (* variable's unique ID *)
138 :     name : string, (* variable's name *)
139 :     ty : Ty.ty, (* variable's type *)
140 : jhr 3506 kind : global_kind, (* the variable kind *)
141 : jhr 3517 useCnt : int ref, (* count of uses *)
142 : jhr 3470 props : PropList.holder
143 :     }
144 :    
145 : jhr 3506 and global_kind = ConstVar | InputVar | GlobalVar
146 :    
147 : jhr 3470 (***** strand state variables *****)
148 :     and state_var = SV of {
149 :     id : Stamp.stamp, (* variable's unique ID *)
150 :     name : string, (* variable's name *)
151 :     ty : Ty.ty, (* variable's type *)
152 :     output : bool, (* true for output variables *)
153 :     props : PropList.holder
154 :     }
155 :    
156 :     withtype assign = (var * rhs)
157 :     and massign = (var list * Op.rator * var list)
158 :     and phi = (var * var option list) (* NONE for fake edges *)
159 :    
160 :     datatype assignment
161 :     = ASSGN of assign
162 :     | MASSGN of massign
163 :     | GASSGN of (global_var * var)
164 :     | SAV of (state_var * var)
165 :    
166 :     (***** Program representation *****)
167 :    
168 : jhr 3505 type input = global_var Inputs.input
169 :    
170 : jhr 3470 datatype program = Program of {
171 :     props : Properties.t list,
172 : jhr 3485 consts : global_var list, (* large constant variables *)
173 : jhr 3505 inputs : input list, (* global input variables *)
174 :     constInit : cfg, (* code that initializes constants and inputs *)
175 : jhr 3485 globals : global_var list, (* other global variables *)
176 : jhr 3470 globalInit : cfg, (* CFG to initialize other globals (if any) *)
177 : jhr 3485 strand : strand, (* the strand definition *)
178 :     create : create, (* initial strand creation *)
179 :     update : cfg option (* optional update code. *)
180 : jhr 3470 }
181 :    
182 :     and strand = Strand of {
183 :     name : Atom.atom,
184 :     params : var list,
185 :     state : state_var list,
186 :     stateInit : cfg,
187 : jhr 3485 initM : cfg option,
188 :     updateM : cfg,
189 :     stabilizeM : cfg option
190 : jhr 3470 }
191 :    
192 : jhr 3485 and create = Create of {
193 :     dim : int option, (* grid dimension; NONE for collections *)
194 :     code : cfg (* the loop nest for creating the strands *)
195 : jhr 3470 }
196 :    
197 :     structure GlobalVar =
198 :     struct
199 : jhr 3506 fun new (kind, name, ty) = GV{
200 : jhr 3470 id = Stamp.new(),
201 :     name = name,
202 :     ty = ty,
203 : jhr 3506 kind = kind,
204 : jhr 3517 useCnt = ref 0,
205 : jhr 3470 props = PropList.newHolder()
206 :     }
207 :     fun name (GV{name, ...}) = name
208 :     fun uniqueName (GV{id, name, ...}) = name ^ Stamp.toString id
209 : jhr 3506 fun kind (GV{kind, ...}) = kind
210 : jhr 3470 fun ty (GV{ty, ...}) = ty
211 : jhr 3506 fun isInput (GV{kind=InputVar, ...}) = true
212 :     | isInput _ = false
213 : jhr 3517 fun useCount (GV{useCnt, ...}) = !useCnt
214 : jhr 3470 fun same (GV{id=a, ...}, GV{id=b, ...}) = Stamp.same(a, b)
215 :     fun compare (GV{id=a, ...}, GV{id=b, ...}) = Stamp.compare(a, b)
216 :     fun hash (GV{id, ...}) = Stamp.hash id
217 :     fun toString (GV{id, name, ...}) = concat["globals.", name, Stamp.toString id]
218 :     (* properties *)
219 :     fun newProp initFn = PropList.newProp (fn (GV{props, ...}) => props, initFn)
220 :     fun newFlag () = PropList.newFlag (fn (GV{props, ...}) => props)
221 :     (* collections *)
222 :     local
223 :     structure V =
224 :     struct
225 :     type ord_key = global_var
226 :     val compare = compare
227 :     end
228 :     in
229 :     structure Map = RedBlackMapFn (V)
230 :     structure Set = RedBlackSetFn (V)
231 :     end
232 :     structure Tbl = HashTableFn (
233 :     struct
234 :     type hash_key = global_var
235 :     val hashVal = hash
236 :     val sameKey = same
237 :     end)
238 :     end
239 :    
240 :     structure StateVar =
241 :     struct
242 :     fun new (isOut, name, ty) = SV{
243 :     id = Stamp.new(),
244 :     name = name,
245 :     ty = ty,
246 :     output = isOut,
247 :     props = PropList.newHolder()
248 :     }
249 :     fun name (SV{name, ...}) = name
250 :     fun ty (SV{ty, ...}) = ty
251 :     fun isOutput (SV{output, ...}) = output
252 :     fun same (SV{id=a, ...}, SV{id=b, ...}) = Stamp.same(a, b)
253 :     fun compare (SV{id=a, ...}, SV{id=b, ...}) = Stamp.compare(a, b)
254 :     fun hash (SV{id, ...}) = Stamp.hash id
255 :     fun toString (SV{name, ...}) = "self." ^ name
256 :     (* properties *)
257 :     fun newProp initFn = PropList.newProp (fn (SV{props, ...}) => props, initFn)
258 :     fun newFlag () = PropList.newFlag (fn (SV{props, ...}) => props)
259 :     (* collections *)
260 :     local
261 :     structure V =
262 :     struct
263 :     type ord_key = state_var
264 :     val compare = compare
265 :     end
266 :     in
267 :     structure Map = RedBlackMapFn (V)
268 :     structure Set = RedBlackSetFn (V)
269 :     end
270 :     structure Tbl = HashTableFn (
271 :     struct
272 :     type hash_key = state_var
273 :     val hashVal = hash
274 :     val sameKey = same
275 :     end)
276 :     end
277 :    
278 :     structure Var =
279 :     struct
280 :     fun new (name, ty) = V{
281 :     name = name,
282 :     id = Stamp.new(),
283 :     ty = ty,
284 :     bind = ref VB_NONE,
285 :     useCnt = ref 0,
286 :     props = PropList.newHolder()
287 :     }
288 :     fun copy (V{name, ty, ...}) = new (name, ty)
289 :     fun name (V{name, ...}) = name
290 :     fun ty (V{ty, ...}) = ty
291 :     fun binding (V{bind, ...}) = !bind
292 :     fun setBinding (V{bind, ...}, vb) = bind := vb
293 :     fun useCount (V{useCnt, ...}) = !useCnt
294 :     fun same (V{id=a, ...}, V{id=b, ...}) = Stamp.same(a, b)
295 :     fun compare (V{id=a, ...}, V{id=b, ...}) = Stamp.compare(a, b)
296 :     fun hash (V{id, ...}) = Stamp.hash id
297 :     fun toString (V{name, id, ...}) = name ^ Stamp.toString id
298 :     (* properties *)
299 :     fun newProp initFn = PropList.newProp (fn (V{props, ...}) => props, initFn)
300 :     fun newFlag () = PropList.newFlag (fn (V{props, ...}) => props)
301 :     (* collections *)
302 :     local
303 :     structure V =
304 :     struct
305 :     type ord_key = var
306 :     val compare = compare
307 :     end
308 :     in
309 :     structure Map = RedBlackMapFn (V)
310 :     structure Set = RedBlackSetFn (V)
311 :     end
312 :     structure Tbl = HashTableFn (
313 :     struct
314 :     type hash_key = var
315 :     val hashVal = hash
316 :     val sameKey = same
317 :     end)
318 :     end
319 :    
320 :     structure Node =
321 :     struct
322 :     fun id (ND{id, ...}) = id
323 :     fun kind (ND{kind, ...}) = kind
324 :     fun same (ND{id=a, ...}, ND{id=b, ...}) = Stamp.same(a, b)
325 :     fun compare (ND{id=a, ...}, ND{id=b, ...}) = Stamp.compare(a, b)
326 :     fun hash (ND{id, ...}) = Stamp.hash id
327 :     fun toString (ND{id, kind, ...}) = let
328 :     val tag = (case kind
329 :     of NULL => "NULL"
330 :     | ENTRY _ => "ENTRY"
331 :     | JOIN _ => "JOIN"
332 :     | COND _ => "COND"
333 : jhr 3473 | FOREACH _ => "FOREACH"
334 : jhr 3470 | COM _ => "COM"
335 :     | ASSIGN _ => "ASSIGN"
336 :     | MASSIGN _ => "MASSIGN"
337 :     | GASSIGN _ => "GASSIGN"
338 :     | NEW _ => "NEW"
339 :     | SAVE _ => "SAVE"
340 :     | EXIT{kind, ...} => ExitKind.toString kind
341 :     (* end case *))
342 :     in
343 :     tag ^ Stamp.toString id
344 :     end
345 :     fun new kind = ND{id = Stamp.new(), props = PropList.newHolder(), kind = kind}
346 :     (* variable defs and uses *)
347 :     fun uses (ND{kind, ...}) = (case kind
348 :     of JOIN{phis, ...} => let
349 :     fun add ([], ys) = ys
350 :     | add (SOME x :: xs, ys) = add(xs, x::ys)
351 :     | add (NONE :: xs, ys) = add(xs, ys)
352 :     in
353 :     List.foldr (fn ((_, xs), ys) => add(xs, ys)) [] (!phis)
354 :     end
355 :     | COND{cond, ...} => [cond]
356 : jhr 3473 | FOREACH{src, phis, ...} => let
357 :     fun add ([], ys) = ys
358 :     | add (SOME x :: xs, ys) = add(xs, x::ys)
359 :     | add (NONE :: xs, ys) = add(xs, ys)
360 :     in
361 :     List.foldr (fn ((_, xs), ys) => add(xs, ys)) [src] (!phis)
362 :     end
363 : jhr 3470 | ASSIGN{stm=(y, rhs), ...} => (case rhs
364 :     of GLOBAL _ => []
365 :     | STATE _ => []
366 :     | VAR x => [x]
367 :     | LIT _ => []
368 :     | OP(_, args) => args
369 :     | CONS(args, _) => args
370 :     | SEQ(args, _) => args
371 :     | EINAPP(_, args) => args
372 :     (* end case *))
373 :     | MASSIGN{stm=(_, _, args), ...} => args
374 :     | GASSIGN{rhs, ...} => [rhs]
375 :     | NEW{args, ...} => args
376 :     | SAVE{rhs, ...} => [rhs]
377 :     | _ => []
378 :     (* end case *))
379 :     fun defs (ND{kind, ...}) = (case kind
380 :     of JOIN{phis, ...} => List.map #1 (!phis)
381 : jhr 3473 | FOREACH{var, phis, ...} => var :: List.map #1 (!phis)
382 : jhr 3470 | ASSIGN{stm=(y, _), ...} => [y]
383 :     | MASSIGN{stm=(ys, _, _), ...} => ys
384 :     | _ => []
385 :     (* end case *))
386 :     val dummy = new NULL
387 :     fun mkENTRY () = new (ENTRY{succ = ref dummy})
388 :     fun mkJOIN phis = new (JOIN{preds = ref [], mask = ref [], phis = ref phis, succ = ref dummy})
389 :     fun mkCOND cond = new (COND{
390 :     pred = ref dummy, cond = cond,
391 :     trueBranch = ref dummy, falseBranch = ref dummy
392 :     })
393 : jhr 3473 fun mkFOREACH (var, src) = new (FOREACH{
394 : jhr 3502 pred = ref dummy,
395 : jhr 3473 phis = ref [], mask = ref [],
396 :     var = var, src = src,
397 : jhr 3502 bodyEntry = ref dummy,
398 :     bodyExit = ref dummy,
399 :     succ = ref dummy
400 : jhr 3473 })
401 : jhr 3470 fun mkCOM text = new (COM{pred = ref dummy, text = text, succ = ref dummy})
402 :     fun mkASSIGN (lhs, rhs) = (
403 :     Var.setBinding (lhs, VB_RHS rhs);
404 :     new (ASSIGN{pred = ref dummy, stm = (lhs, rhs), succ = ref dummy}))
405 :     fun mkMASSIGN (lhs, rator, args) = let
406 :     fun setB (_, []) = ()
407 :     | setB (i, x::xs) = (
408 :     Var.setBinding (x, VB_MULTIOP(i, rator, args));
409 :     setB (i+1, xs))
410 :     in
411 :     setB (0, lhs);
412 :     new (MASSIGN{pred = ref dummy, stm = (lhs, rator, args), succ = ref dummy})
413 :     end
414 :     fun mkGASSIGN (lhs, rhs) = new (GASSIGN{
415 :     pred = ref dummy, lhs = lhs, rhs = rhs, succ = ref dummy
416 :     })
417 :     fun mkNEW {strand, args} = new (NEW{
418 :     pred = ref dummy, strand = strand, args = args, succ = ref dummy
419 :     })
420 :     fun mkSAVE (lhs, rhs) = new (SAVE{
421 :     pred = ref dummy, lhs = lhs, rhs = rhs, succ = ref dummy
422 :     })
423 : jhr 3505 fun mkEXIT kind = new (EXIT{kind = kind, pred = ref dummy, succ = ref NONE})
424 :     fun mkRETURN () = mkEXIT ExitKind.RETURN
425 :     fun mkACTIVE () = mkEXIT ExitKind.ACTIVE
426 :     fun mkSTABILIZE () = mkEXIT ExitKind.STABILIZE
427 :     fun mkDIE () = mkEXIT ExitKind.DIE
428 :     fun mkUNREACHABLE () = mkEXIT ExitKind.UNREACHABLE
429 : jhr 3470 fun isNULL (ND{kind=NULL, ...}) = true
430 :     | isNULL _ = false
431 :     (* is a node reachable from the CFG entry; UNREACHABLE exit nodes and JOINs with no real
432 :     * predecessors are unreachable.
433 :     *)
434 :     fun isReachable (ND{kind=EXIT{kind=ExitKind.UNREACHABLE, ...}, ...}) = false
435 :     | isReachable (ND{kind=JOIN{mask, ...}, ...}) = List.exists not (!mask)
436 :     | isReachable _ = true
437 :     (* editing node edges *)
438 :     fun hasPred (ND{kind, ...}) = (case kind
439 :     of NULL => false
440 :     | ENTRY _ => false
441 :     | _ => true
442 :     (* end case *))
443 :     fun setPred (nd0 as ND{kind, ...}, nd) = (case kind
444 :     of NULL => raise Fail("setPred on NULL node " ^ toString nd0)
445 :     | ENTRY _ => raise Fail("setPred on ENTRY node " ^ toString nd0)
446 :     | JOIN{preds, ...} => preds := !preds @ [nd] (* assume preds are added in order *)
447 : jhr 3502 | FOREACH{pred, ...} => pred := nd
448 : jhr 3470 | COND{pred, ...} => pred := nd
449 :     | COM{pred, ...} => pred := nd
450 :     | ASSIGN{pred, ...} => pred := nd
451 :     | MASSIGN{pred, ...} => pred := nd
452 :     | GASSIGN{pred, ...} => pred := nd
453 :     | NEW{pred, ...} => pred := nd
454 :     | SAVE{pred, ...} => pred := nd
455 :     | EXIT{pred, ...} => pred := nd
456 :     (* end case *))
457 :     fun preds (nd as ND{kind, ...}) = (case kind
458 :     of NULL => [] (*raise Fail("preds on NULL node "^toString nd)*)
459 :     | ENTRY _ => []
460 :     | JOIN{preds, ...} => !preds
461 :     | COND{pred, ...} => [!pred]
462 : jhr 3502 | FOREACH{pred, bodyExit, ...} => [!pred, !bodyExit]
463 : jhr 3470 | COM{pred, ...} => [!pred]
464 :     | ASSIGN{pred, ...} => [!pred]
465 :     | MASSIGN{pred, ...} => [!pred]
466 :     | GASSIGN{pred, ...} => [!pred]
467 :     | NEW{pred, ...} => [!pred]
468 :     | SAVE{pred, ...} => [!pred]
469 :     | EXIT{pred, ...} => [!pred]
470 :     (* end case *))
471 :     fun hasSucc (ND{kind, ...}) = (case kind
472 :     of NULL => false
473 :     | ENTRY _ => true
474 :     | JOIN _ => true
475 :     | COND _ => true
476 :     | COM _ => true
477 : jhr 3473 | FOREACH _ => true
478 : jhr 3470 | ASSIGN _ => true
479 :     | MASSIGN _ => true
480 :     | GASSIGN _ => true
481 :     | NEW _ => true
482 :     | SAVE _ => true
483 :     | EXIT{succ=ref(SOME _), ...} => true
484 :     | EXIT _ => false
485 :     (* end case *))
486 :     fun setSucc (nd0 as ND{kind, ...}, nd) = (case kind
487 :     of NULL => raise Fail("setSucc on NULL node "^toString nd0)
488 :     | ENTRY{succ} => succ := nd
489 :     | JOIN{succ, ...} => succ := nd
490 :     | COND _ => raise Fail("setSucc on COND node "^toString nd0)
491 : jhr 3501 | FOREACH{succ, ...} => succ := nd
492 : jhr 3470 | COM{succ, ...} => succ := nd
493 :     | ASSIGN{succ, ...} => succ := nd
494 :     | MASSIGN{succ, ...} => succ := nd
495 :     | GASSIGN{succ, ...} => succ := nd
496 :     | NEW{succ, ...} => succ := nd
497 :     | SAVE{succ, ...} => succ := nd
498 :     | EXIT{succ, ...} => succ := SOME nd
499 :     (* end case *))
500 :     fun succs (ND{kind, ...}) = (case kind
501 :     of NULL => [] (*raise Fail("succs on NULL node "^toString nd)*)
502 :     | ENTRY{succ} => [!succ]
503 :     | JOIN{succ, ...} => [!succ]
504 :     | COND{trueBranch, falseBranch, ...} => [!trueBranch, !falseBranch]
505 : jhr 3502 | FOREACH{bodyEntry, succ, ...} => [!bodyEntry, !succ]
506 : jhr 3470 | COM{succ, ...} => [!succ]
507 :     | ASSIGN{succ, ...} => [!succ]
508 :     | MASSIGN{succ, ...} => [!succ]
509 :     | GASSIGN{succ, ...} => [!succ]
510 :     | NEW{succ, ...} => [!succ]
511 :     | SAVE{succ, ...} => [!succ]
512 :     | EXIT{succ=ref(SOME nd), ...} => [nd]
513 :     | EXIT _ => []
514 :     (* end case *))
515 :     (* QUESTION: should these functions also do the setPred operation? *)
516 :     fun setTrueBranch (ND{kind=COND{trueBranch, ...}, ...}, nd) = trueBranch := nd
517 :     | setTrueBranch (nd, _) = raise Fail("setTrueBranch on " ^ toString nd)
518 :     fun setFalseBranch (ND{kind=COND{falseBranch, ...}, ...}, nd) = falseBranch := nd
519 :     | setFalseBranch (nd, _) = raise Fail("setFalseBranch on " ^ toString nd)
520 : jhr 3502 fun setBodyEntry (ND{kind=FOREACH{bodyEntry, ...}, ...}, nd) = bodyEntry := nd
521 :     | setBodyEntry (nd, _) = raise Fail("setBodyEntry on " ^ toString nd)
522 :     fun setBodyExit (ND{kind=FOREACH{bodyExit, ...}, ...}, nd) = bodyExit := nd
523 :     | setBodyExit (nd, _) = raise Fail("setBodyExit on " ^ toString nd)
524 : jhr 3470 fun setEdgeMask (ND{kind=JOIN{mask, ...}, ...}, mask') = mask := mask'
525 :     | setEdgeMask (nd, _) = raise Fail("setEdgeMask on " ^ toString nd)
526 :     fun addEdge (nd1, nd2) = (
527 :     if hasSucc nd1
528 :     then (
529 :     setSucc (nd1, nd2);
530 :     setPred (nd2, nd1))
531 :     else ())
532 :     (*DEBUG*)handle ex => (
533 :     print(concat["error in addEdge(", toString nd1, ",", toString nd2, ")\n"]);
534 :     raise ex)
535 : jhr 3502 (* replace the edge src-->oldDst by the edge src-->dst *)
536 : jhr 3470 fun replaceInEdge {src, oldDst, dst} = (
537 :     (* first set the successor of src *)
538 :     case kind src
539 :     of COND{trueBranch, falseBranch, ...} =>
540 :     if same(!trueBranch, oldDst)
541 :     then trueBranch := dst
542 :     else falseBranch := dst
543 : jhr 3502 | FOREACH{bodyEntry, succ, ...} =>
544 :     if same(!bodyEntry, oldDst)
545 :     then bodyEntry := dst
546 :     else succ := dst
547 : jhr 3470 | _ => setSucc (src, dst)
548 :     (* end case *);
549 :     (* then set the predecessor of dst *)
550 :     setPred (dst, src))
551 :     (*DEBUG*)handle ex => (
552 :     print(concat["error in replaceInEdge(", toString src, ",", toString oldDst, ",", toString dst, ")\n"]);
553 :     raise ex)
554 : jhr 3502 (* replace the edge oldSrc-->dst by the edge src-->dst *)
555 : jhr 3470 fun replaceOutEdge {oldSrc, src, dst} = (
556 :     (* first set the successor of src *)
557 :     case kind oldSrc
558 :     of COND{trueBranch, falseBranch, ...} =>
559 :     if same(!trueBranch, dst)
560 :     then setTrueBranch (src, dst)
561 :     else setFalseBranch (src, dst)
562 : jhr 3502 | FOREACH{bodyEntry, succ, ...} =>
563 :     if same(!bodyEntry, dst)
564 :     then setBodyEntry (src, dst)
565 :     else setSucc (src, dst)
566 : jhr 3470 | _ => setSucc (src, dst)
567 :     (* end case *);
568 :     (* then set the predecessor of dst *)
569 :     case kind dst
570 :     of JOIN{preds, ...} => let
571 :     fun edit [] = raise Fail "replaceOutEdge: cannot find predecessor"
572 :     | edit (nd::nds) = if same(nd, oldSrc) then src::nds else nd::edit nds
573 :     in
574 :     preds := edit (!preds)
575 :     end
576 : jhr 3502 | FOREACH{bodyExit, pred, ...} =>
577 :     if same(!bodyExit, oldSrc)
578 :     then bodyExit := src
579 :     else pred := src
580 : jhr 3470 | _ => setPred (dst, src)
581 :     (* end case *))
582 :     (*DEBUG*)handle ex => (
583 :     print(concat["error in replaceOutEdge(", toString oldSrc, ",", toString src, ",", toString dst, ")\n"]);
584 :     raise ex)
585 :     (* properties *)
586 :     fun newProp initFn =
587 :     PropList.newProp (fn (ND{props, ...}) => props, initFn)
588 :     fun newFlag () =
589 :     PropList.newFlag (fn (ND{props, ...}) => props)
590 :     end
591 :    
592 :     structure CFG =
593 :     struct
594 :     val empty = CFG{entry = Node.dummy, exit = Node.dummy}
595 :    
596 :     fun isEmpty (CFG{entry, exit}) =
597 :     Node.same(entry, exit) andalso Node.isNULL entry
598 :    
599 :     (* create a basic block from a list of assignments *)
600 :     fun mkBlock [] = empty
601 :     | mkBlock (stm::stms) = let
602 :     fun mkNode (ASSGN stm) = Node.mkASSIGN stm
603 :     | mkNode (MASSGN stm) = Node.mkMASSIGN stm
604 :     | mkNode (GASSGN stm) = Node.mkGASSIGN stm
605 :     | mkNode (SAV stm) = Node.mkSAVE stm
606 :     val entry = mkNode stm
607 :     fun f (stm, prev) = let
608 :     val nd = mkNode stm
609 :     in
610 :     Node.addEdge (prev, nd);
611 :     nd
612 :     end
613 :     val exit = List.foldl f entry stms
614 :     in
615 :     CFG{entry = entry, exit = exit}
616 :     end
617 :    
618 :     (* entry/exit nodes of a CFG *)
619 :     fun entry (CFG{entry = nd, ...}) = nd
620 :     fun exit (CFG{exit = nd, ...}) = nd
621 :    
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 :     in
635 :     List.app (fn nd => setFn(nd, false)) nodes;
636 :     nodes
637 :     end
638 :    
639 :     (* 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} = Node.newFlag()
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, ...}) = let
656 :     val (pred, succ) = (case kind
657 :     of COM{pred = ref pred, succ = ref succ, ...} => (pred, succ)
658 :     | ASSIGN{pred = ref pred, succ = ref succ, ...} => (pred, succ)
659 :     | MASSIGN{pred = ref pred, succ = ref succ, ...} => (pred, succ)
660 :     | GASSIGN{pred = ref pred, succ = ref succ, ...} => (pred, succ)
661 :     | NEW{pred = ref pred, succ = ref succ, ...} => (pred, succ)
662 :     | SAVE{pred = ref pred, succ = ref succ, ...} => (pred, succ)
663 :     | _ => raise Fail(concat["unsupported deleteNode(", Node.toString nd, ")\n"])
664 :     (* end case *))
665 :     in
666 :     (* replace the predecessor edge from succ to nd with an edge from succ to pred *)
667 :     case Node.kind succ
668 :     of JOIN{preds, ...} => let
669 :     fun edit [] = raise Fail "deleteNode: cannot find predecessor"
670 :     | edit (nd'::nds) = if Node.same(nd', nd) then pred::nds else nd'::edit nds
671 :     in
672 :     preds := edit (!preds)
673 :     end
674 :     | _ => Node.setPred (succ, pred)
675 :     (* end case *);
676 :     (* replace the successor edge from pred to nd with an edge from pred to succ *)
677 :     case Node.kind pred
678 :     of COND{trueBranch, falseBranch, ...} => (
679 :     (* note that we treat each branch independently, so that we handle the
680 :     * situation where both branches are the same node.
681 :     *)
682 :     if Node.same(!trueBranch, nd)
683 :     then Node.setTrueBranch(pred, succ)
684 :     else ();
685 :     if Node.same(!falseBranch, nd)
686 :     then Node.setFalseBranch(pred, succ)
687 :     else ())
688 :     | _ => Node.setSucc (pred, succ)
689 :     (* end case *)
690 :     end
691 :     (*DEBUG*)handle ex => (
692 :     print(concat["error in deleteNode(", Node.toString nd, ")\n"]);
693 :     raise ex)
694 :    
695 :     (* replace a simple node in a cfg with a subgraph *)
696 :     fun replaceNode (oldNd as ND{kind, ...}, node) = (case kind
697 :     of ASSIGN{pred, succ, ...} => (
698 :     Node.replaceInEdge {src = !pred, oldDst = oldNd, dst = node};
699 :     Node.replaceOutEdge {oldSrc = oldNd, src = node, dst = !succ})
700 :     | MASSIGN{pred, succ, ...} => (
701 :     Node.replaceInEdge {src = !pred, oldDst = oldNd, dst = node};
702 :     Node.replaceOutEdge {oldSrc = oldNd, src = node, dst = !succ})
703 :     | GASSIGN{pred, succ, ...} => (
704 :     Node.replaceInEdge {src = !pred, oldDst = oldNd, dst = node};
705 :     Node.replaceOutEdge {oldSrc = oldNd, src = node, dst = !succ})
706 :     | NEW{pred, succ, ...} => (
707 :     Node.replaceInEdge {src = !pred, oldDst = oldNd, dst = node};
708 :     Node.replaceOutEdge {oldSrc = oldNd, src = node, dst = !succ})
709 :     | SAVE{pred, succ, ...} => (
710 :     Node.replaceInEdge {src = !pred, oldDst = oldNd, dst = node};
711 :     Node.replaceOutEdge {oldSrc = oldNd, src = node, dst = !succ})
712 :     | EXIT{pred, succ=ref NONE, ...} =>
713 :     Node.replaceInEdge {src = !pred, oldDst = oldNd, dst = node}
714 :     | _ => raise Fail(concat[
715 :     "unsupported replaceNode(", Node.toString oldNd, ", ", Node.toString node, ")"
716 :     ])
717 :     (* end case *))
718 :    
719 :     (* replace a simple node in a cfg with a subgraph *)
720 :     fun replaceNodeWithCFG (nd as ND{kind, ...}, cfg as CFG{entry, exit}) =
721 :     if isEmpty cfg
722 :     then deleteNode nd
723 :     else (case kind
724 :     of ASSIGN{pred, succ, ...} => (
725 :     Node.replaceInEdge {src = !pred, oldDst = nd, dst = entry};
726 :     Node.replaceOutEdge {oldSrc = nd, src = exit, dst = !succ})
727 :     | MASSIGN{pred, succ, ...} => (
728 :     Node.replaceInEdge {src = !pred, oldDst = nd, dst = entry};
729 :     Node.replaceOutEdge {oldSrc = nd, src = exit, dst = !succ})
730 :     | _ => raise Fail "unsupported replaceNodeWithCFG"
731 :     (* end case *))
732 :    
733 :     (* concatenate two CFGs *)
734 :     fun concat (cfg1 as CFG{entry=e1, exit=x1}, cfg2 as CFG{entry=e2, exit=x2}) =
735 :     if isEmpty cfg1 then cfg2
736 :     else if isEmpty cfg2 then cfg1
737 :     else (
738 :     Node.setSucc (x1, e2);
739 :     Node.setPred (e2, x1);
740 :     CFG{entry = e1, exit = x2})
741 :     (*DEBUG*)handle ex => (
742 :     print(String.concat["error in concat({", Node.toString e1, ",", Node.toString x1,
743 :     "},{", Node.toString e2, ",", Node.toString x2, "})\n"]);
744 :     raise ex)
745 :    
746 :     (* prepend a node to a CFG *)
747 :     fun prependNode (nd, cfg as CFG{entry, exit}) =
748 :     if isEmpty cfg
749 :     then CFG{entry=nd, exit=nd}
750 :     else (
751 :     Node.setSucc (nd, entry);
752 :     Node.setPred (entry, nd);
753 :     CFG{entry=nd, exit=exit})
754 :    
755 :     (* append a node to a CFG *)
756 :     fun appendNode (cfg as CFG{entry, exit}, nd) =
757 :     if isEmpty cfg
758 :     then CFG{entry=nd, exit=nd}
759 :     else (
760 :     Node.setPred (nd, exit);
761 :     Node.setSucc (exit, nd);
762 :     CFG{entry=entry, exit=nd})
763 :    
764 :     (* insert a block of assignments at the beginning of the CFG. If the CFG has an ENTRY
765 :     * node, then the block is inserted immediatly following the entry.
766 :     *)
767 :     fun prependBlock ([], cfg) = cfg
768 :     | prependBlock (stms, cfg as CFG{entry, exit}) = (case entry
769 :     of ND{kind=ENTRY{succ}, ...} => let
770 :     fun mkNode (ASSGN stm) = Node.mkASSIGN stm
771 :     | mkNode (MASSGN stm) = Node.mkMASSIGN stm
772 :     | mkNode (GASSGN stm) = Node.mkGASSIGN stm
773 :     | mkNode (SAV stm) = Node.mkSAVE stm
774 :     fun f (stm, succ) = let
775 :     val nd = mkNode stm
776 :     in
777 :     Node.addEdge (nd, succ);
778 :     nd
779 :     end
780 :     val first = List.foldr f (!succ) stms
781 :     in
782 :     succ := first;
783 :     Node.setPred (first, entry);
784 :     cfg
785 :     end
786 :     | _ => concat(mkBlock stms, cfg)
787 :     (* end case *))
788 :    
789 :     (* insert a block of assignments at the end of the CFG argument If the CFG has an EXIT
790 :     * node, then the block is inserted immediatly before the exit.
791 :     *)
792 :     fun appendBlock (cfg, []) = cfg
793 :     | appendBlock (cfg as CFG{entry, exit}, stms) = (case exit
794 :     of ND{kind=EXIT{pred, ...}, ...} => let
795 :     fun mkNode (ASSGN stm) = Node.mkASSIGN stm
796 :     | mkNode (MASSGN stm) = Node.mkMASSIGN stm
797 :     | mkNode (GASSGN stm) = Node.mkGASSIGN stm
798 :     | mkNode (SAV stm) = Node.mkSAVE stm
799 :     fun f (stm, prev) = let
800 :     val nd = mkNode stm
801 :     in
802 :     Node.addEdge (prev, nd);
803 :     nd
804 :     end
805 :     val last = List.foldl f (!pred) stms
806 :     in
807 :     pred := last;
808 :     Node.setSucc(last, exit);
809 :     cfg
810 :     end
811 :     | _ => concat(cfg, mkBlock stms)
812 :     (* end case *))
813 :     end
814 :    
815 :     structure RHS =
816 :     struct
817 :     fun vars rhs = (case rhs
818 :     of GLOBAL _ => []
819 :     | STATE _ => []
820 :     | VAR x => [x]
821 :     | LIT _ => []
822 :     | OP(rator, xs) => xs
823 :     | CONS(xs, _) => xs
824 :     | SEQ(xs, _) => xs
825 :     | EINAPP(_, xs) => xs
826 :     (* end case *))
827 :    
828 :     fun map f = let
829 :     fun mapf rhs = (case rhs
830 :     of GLOBAL _ => rhs
831 :     | STATE _ => rhs
832 :     | VAR x => VAR(f x)
833 :     | LIT _ => rhs
834 :     | OP(rator, xs) => OP(rator, List.map f xs)
835 :     | CONS(xs, ty) => CONS(List.map f xs, ty)
836 :     | SEQ(xs, ty) => SEQ(List.map f xs, ty)
837 :     | EINAPP(ein, xs) => EINAPP(ein, List.map f xs)
838 :     (* end case *))
839 :     in
840 :     mapf
841 :     end
842 :    
843 :     fun app f = let
844 :     fun appf rhs = (case rhs
845 :     of GLOBAL _ => ()
846 :     | STATE _ => ()
847 :     | VAR x => f x
848 :     | LIT _ => ()
849 :     | OP(rator, xs) => List.app f xs
850 :     | CONS(xs, _) => List.app f xs
851 :     | SEQ(xs, _) => List.app f xs
852 :     | EINAPP(_, xs) => List.app f xs
853 :     (* end case *))
854 :     in
855 :     appf
856 :     end
857 :    
858 :     (* return a string representation of a rhs *)
859 :     fun toString rhs = (case rhs
860 :     of GLOBAL x => GlobalVar.toString x
861 :     | STATE x => StateVar.toString x
862 :     | VAR x => Var.toString x
863 :     | LIT lit => Literal.toString lit
864 :     | OP(rator, xs) => String.concat [
865 :     Op.toString rator,
866 :     "(", String.concatWithMap "," Var.toString xs, ")"
867 :     ]
868 :     | CONS(xs, ty) => String.concat [
869 :     "<", Ty.toString ty, ">[",
870 :     String.concatWithMap "," Var.toString xs, "]"
871 :     ]
872 :     | SEQ(xs, ty) => String.concat [
873 :     "<", Ty.toString ty, ">{",
874 :     String.concatWithMap "," Var.toString xs, "}"
875 :     ]
876 :     (* FIXME: proper printing of Ein applications *)
877 :     | EINAPP(ein, xs) => String.concat [
878 :     "EIN(", String.concatWithMap "," Var.toString xs, ")"
879 :     ]
880 :     (* end case *))
881 :     end
882 :    
883 :     (* return a string representation of a variable binding *)
884 :     fun vbToString VB_NONE = "NONE"
885 :     | vbToString (VB_RHS rhs) = concat["RHS(", RHS.toString rhs, ")"]
886 :     | vbToString (VB_MULTIOP(i, rator, xs)) = concat[
887 :     "MULTIOP(", Op.toString rator,
888 :     "[", String.concatWithMap "," Var.toString xs, "])"
889 :     ]
890 :     | vbToString (VB_PHI xs) = concat[
891 :     "PHI(",
892 :     String.concatWithMap "," (fn NONE => "_" | SOME x => Var.toString x) xs, ")"
893 :     ]
894 :     | vbToString VB_PARAM = "PARAM"
895 :    
896 :     (* return a string representation of a PHI node *)
897 :     fun phiToString (y, xs) = String.concat [
898 :     Ty.toString(Var.ty y), " ", Var.toString y, " = PHI(",
899 :     String.concatWithMap "," (fn NONE => "_" | SOME x => Var.toString x) xs, ")"
900 :     ]
901 :    
902 :     (* return a string representation of an assignment *)
903 :     fun assignToString (y, rhs) =
904 :     String.concat [Ty.toString(Var.ty y), " ", Var.toString y, " = ", RHS.toString rhs]
905 :     fun massignToString (ys, rator, xs) = String.concat [
906 :     "(", String.concatWithMap ","
907 :     (fn y => concat[Ty.toString(Var.ty y), " ", Var.toString y]) ys,
908 :     " = ", Op.toString rator,
909 :     "(", String.concatWithMap "," Var.toString xs, ")"
910 :     ]
911 :     fun assignmentToString (ASSGN asgn) = assignToString asgn
912 :     | assignmentToString (MASSGN masgn) = massignToString masgn
913 :     | assignmentToString (GASSGN(lhs, rhs)) = String.concat[
914 :     GlobalVar.toString lhs, " = ", Var.toString rhs
915 :     ]
916 :     | assignmentToString (SAV(lhs, rhs)) = String.concat[
917 :     StateVar.toString lhs, " = ", Var.toString rhs
918 :     ]
919 :    
920 :     end (* SSAFn *)

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