SCM Repository
Annotation of /trunk/src/compiler/IL/ssa-fn.sml
Parent Directory
|
Revision Log
Revision 359 - (view) (download)
1 : | jhr | 137 | (* ssa-fn.sml |
2 : | jhr | 124 | * |
3 : | * COPYRIGHT (c) 2010 The Diderot Project (http://diderot.cs.uchicago.edu) | ||
4 : | * All rights reserved. | ||
5 : | jhr | 137 | * |
6 : | * The IL is a combination of a block-structured tree and an SSA control-flow | ||
7 : | * graph of blocks. | ||
8 : | jhr | 124 | *) |
9 : | |||
10 : | jhr | 198 | signature SSA = |
11 : | sig | ||
12 : | |||
13 : | structure Op : OPERATORS | ||
14 : | |||
15 : | jhr | 256 | (***** CFG *****) |
16 : | jhr | 198 | |
17 : | jhr | 256 | datatype node = ND of { |
18 : | id : Stamp.stamp, | ||
19 : | props : PropList.holder, | ||
20 : | kind : node_kind | ||
21 : | jhr | 198 | } |
22 : | |||
23 : | jhr | 256 | and node_kind |
24 : | = NULL | ||
25 : | | ENTRY of { | ||
26 : | succ : node ref | ||
27 : | } | ||
28 : | | JOIN of { | ||
29 : | preds : node list ref, | ||
30 : | phis : (var * var list) list ref, (* phi statements *) | ||
31 : | succ : node ref | ||
32 : | } | ||
33 : | | COND of { | ||
34 : | pred : node ref, | ||
35 : | cond : var, | ||
36 : | trueBranch : node ref, | ||
37 : | falseBranch : node ref | ||
38 : | } | ||
39 : | | BLOCK of { | ||
40 : | pred : node ref, | ||
41 : | body : assign list ref, | ||
42 : | succ : node ref | ||
43 : | } | ||
44 : | | NEW of { | ||
45 : | pred : node ref, | ||
46 : | actor : Atom.atom, | ||
47 : | args : var list, | ||
48 : | succ : node ref | ||
49 : | } | ||
50 : | | DIE of { | ||
51 : | pred : node ref | ||
52 : | } | ||
53 : | | STABILIZE of { | ||
54 : | pred : node ref | ||
55 : | } | ||
56 : | | EXIT of { | ||
57 : | pred : node ref | ||
58 : | } | ||
59 : | jhr | 198 | |
60 : | jhr | 256 | (***** Statements *****) |
61 : | |||
62 : | jhr | 198 | and stmt = STM of { |
63 : | id : Stamp.stamp, | ||
64 : | props : PropList.holder, | ||
65 : | jhr | 256 | kind : stmt_kind, |
66 : | next : stmt option (* next statement at this structural level *) | ||
67 : | jhr | 198 | } |
68 : | |||
69 : | and stmt_kind | ||
70 : | jhr | 256 | = S_SIMPLE of node (* ENTRY, JOIN, BLOCK, NEW, DIE, STABILIZE, or EXIT node *) |
71 : | | S_IF of { | ||
72 : | cond : node, (* COND node *) | ||
73 : | jhr | 198 | thenBranch : stmt, |
74 : | elseBranch : stmt | ||
75 : | } | ||
76 : | jhr | 256 | | S_LOOP of { |
77 : | jhr | 198 | hdr : stmt, |
78 : | jhr | 256 | cond : node, (* COND node *) |
79 : | body : stmt | ||
80 : | jhr | 198 | } |
81 : | |||
82 : | and rhs | ||
83 : | = VAR of var | ||
84 : | | LIT of Literal.literal | ||
85 : | | OP of Op.rator * var list | ||
86 : | | CONS of var list (* tensor-value construction *) | ||
87 : | |||
88 : | and var = V of { | ||
89 : | name : string, (* name *) | ||
90 : | id : Stamp.stamp, (* unique ID *) | ||
91 : | useCnt : int ref, (* count of uses *) | ||
92 : | props : PropList.holder | ||
93 : | } | ||
94 : | |||
95 : | withtype assign = (var * rhs) | ||
96 : | |||
97 : | jhr | 256 | datatype program = Program of { |
98 : | globals : var list, | ||
99 : | globalInit : stmt, | ||
100 : | actors : actor list | ||
101 : | (* initialization *) | ||
102 : | } | ||
103 : | jhr | 198 | |
104 : | jhr | 256 | and actor = Actor of { |
105 : | name : Atom.atom, | ||
106 : | params : var list, | ||
107 : | state : var list, | ||
108 : | stateInit : stmt, | ||
109 : | methods : method list | ||
110 : | } | ||
111 : | jhr | 198 | |
112 : | jhr | 256 | and method = Method of { |
113 : | name : Atom.atom, | ||
114 : | stateIn : var list, (* names of state variables on method entry *) | ||
115 : | stateOut : var list, (* names of state variables on method exit *) | ||
116 : | body : stmt (* method body *) | ||
117 : | } | ||
118 : | jhr | 198 | |
119 : | jhr | 256 | structure Node : sig |
120 : | val same : node * node -> bool | ||
121 : | val compare : node * node -> order | ||
122 : | val hash : node -> word | ||
123 : | val toString : node -> string | ||
124 : | jhr | 359 | (* CFG edges *) |
125 : | jhr | 256 | val preds : node -> node list |
126 : | val setPred : node * node -> unit | ||
127 : | val hasSucc : node -> bool | ||
128 : | val succs : node -> node list | ||
129 : | val setSucc : node * node -> unit | ||
130 : | val setTrueBranch : node * node -> unit (* set trueBranch successor for COND node *) | ||
131 : | val setFalseBranch : node * node -> unit (* set falseBranch successor for COND node *) | ||
132 : | val addEdge : node * node -> unit | ||
133 : | jhr | 359 | (* constructors *) |
134 : | val mkENTRY : unit -> node | ||
135 : | val mkJOIN : (var * var list) list -> node | ||
136 : | val mkCOND : {cond : var, trueBranch : node, falseBranch : node} -> node | ||
137 : | val mkBLOCK : assign list -> node | ||
138 : | val mkNEW {actor : Atom.atom, args : var list} -> node | ||
139 : | val mkDIE : unit -> node | ||
140 : | val mkSTABILIZE : unit -> node | ||
141 : | val mkEXIT : unit -> node | ||
142 : | jhr | 283 | (* properties *) |
143 : | val newProp : (node -> 'a) -> { | ||
144 : | getFn : node -> 'a, | ||
145 : | peekFn : node -> 'a option, | ||
146 : | setFn : node * 'a -> unit, | ||
147 : | clrFn : node -> unit | ||
148 : | } | ||
149 : | val newFlag : unit -> { | ||
150 : | getFn : node -> bool, | ||
151 : | setFn : node * bool -> unit | ||
152 : | } | ||
153 : | jhr | 256 | end |
154 : | jhr | 198 | |
155 : | jhr | 256 | structure Stmt : sig |
156 : | val same : stmt * stmt -> bool | ||
157 : | val compare : stmt * stmt -> order | ||
158 : | val hash : stmt -> word | ||
159 : | val toString : stmt -> string | ||
160 : | (* return the entry node of the statement *) | ||
161 : | val entry : stmt -> node | ||
162 : | (* return the tail-end node of a statement (not applicable to S_IF or S_LOOP) *) | ||
163 : | val tail : stmt -> node | ||
164 : | (* statement constructor functions *) | ||
165 : | val mkENTRY : stmt option -> stmt | ||
166 : | val mkJOIN : (var * var list) list * stmt option -> stmt | ||
167 : | val mkIF : var * stmt * stmt * stmt option -> stmt | ||
168 : | val mkBLOCK : assign list * stmt option -> stmt | ||
169 : | val mkNEW : Atom.atom * var list * stmt option -> stmt | ||
170 : | val mkDIE : unit -> stmt | ||
171 : | val mkSTABILIZE : unit -> stmt | ||
172 : | val mkEXIT : unit -> stmt | ||
173 : | jhr | 283 | (* properties *) |
174 : | val newProp : (stmt -> 'a) -> { | ||
175 : | getFn : stmt -> 'a, | ||
176 : | peekFn : stmt -> 'a option, | ||
177 : | setFn : stmt * 'a -> unit, | ||
178 : | clrFn : stmt -> unit | ||
179 : | } | ||
180 : | val newFlag : unit -> { | ||
181 : | getFn : stmt -> bool, | ||
182 : | setFn : stmt * bool -> unit | ||
183 : | } | ||
184 : | jhr | 256 | end |
185 : | jhr | 198 | |
186 : | jhr | 199 | structure Var : sig |
187 : | val new : string -> var | ||
188 : | val same : var * var -> bool | ||
189 : | val compare : var * var -> order | ||
190 : | val hash : var -> word | ||
191 : | val toString : var -> string | ||
192 : | jhr | 283 | (* properties *) |
193 : | val newProp : (var -> 'a) -> { | ||
194 : | getFn : var -> 'a, | ||
195 : | peekFn : var -> 'a option, | ||
196 : | setFn : var * 'a -> unit, | ||
197 : | clrFn : var -> unit | ||
198 : | } | ||
199 : | val newFlag : unit -> { | ||
200 : | getFn : var -> bool, | ||
201 : | setFn : var * bool -> unit | ||
202 : | } | ||
203 : | (* collections *) | ||
204 : | jhr | 199 | structure Map : ORD_MAP where type Key.ord_key = var |
205 : | structure Set : ORD_SET where type Key.ord_key = var | ||
206 : | structure Tbl : MONO_HASH_TABLE where type Key.hash_key = var | ||
207 : | end | ||
208 : | jhr | 198 | |
209 : | jhr | 319 | (* DFS sorting of the graph rooted at the entry to a statement; the resulting list will |
210 : | * be in preorder with parents before children. | ||
211 : | *) | ||
212 : | jhr | 257 | val sortNodes : stmt -> node list |
213 : | |||
214 : | jhr | 341 | (* apply a function to all of the nodes in the graph rooted at the entry to the statement *) |
215 : | val applyToNodes : (node -> unit) -> stmt -> unit | ||
216 : | |||
217 : | jhr | 198 | end |
218 : | |||
219 : | functor SSAFn (Op : OPERATORS) : SSA = | ||
220 : | jhr | 192 | struct |
221 : | jhr | 137 | |
222 : | jhr | 192 | structure Op = Op |
223 : | jhr | 137 | |
224 : | jhr | 256 | datatype node = ND of { |
225 : | id : Stamp.stamp, | ||
226 : | props : PropList.holder, | ||
227 : | kind : node_kind | ||
228 : | jhr | 197 | } |
229 : | |||
230 : | jhr | 256 | and node_kind |
231 : | = NULL | ||
232 : | | ENTRY of { | ||
233 : | succ : node ref | ||
234 : | } | ||
235 : | | JOIN of { | ||
236 : | preds : node list ref, | ||
237 : | phis : (var * var list) list ref, (* phi statements *) | ||
238 : | succ : node ref | ||
239 : | } | ||
240 : | | COND of { | ||
241 : | pred : node ref, | ||
242 : | cond : var, | ||
243 : | trueBranch : node ref, | ||
244 : | falseBranch : node ref | ||
245 : | } | ||
246 : | | BLOCK of { | ||
247 : | pred : node ref, | ||
248 : | body : assign list ref, | ||
249 : | succ : node ref | ||
250 : | } | ||
251 : | | NEW of { | ||
252 : | pred : node ref, | ||
253 : | actor : Atom.atom, | ||
254 : | args : var list, | ||
255 : | succ : node ref | ||
256 : | } | ||
257 : | | DIE of { | ||
258 : | pred : node ref | ||
259 : | } | ||
260 : | | STABILIZE of { | ||
261 : | pred : node ref | ||
262 : | } | ||
263 : | | EXIT of { | ||
264 : | pred : node ref | ||
265 : | } | ||
266 : | jhr | 197 | |
267 : | jhr | 256 | (***** Statements *****) |
268 : | jhr | 197 | |
269 : | and stmt = STM of { | ||
270 : | jhr | 188 | id : Stamp.stamp, |
271 : | props : PropList.holder, | ||
272 : | jhr | 256 | kind : stmt_kind, |
273 : | next : stmt option (* next statement at this structural level *) | ||
274 : | jhr | 188 | } |
275 : | |||
276 : | jhr | 192 | and stmt_kind |
277 : | jhr | 256 | = S_SIMPLE of node (* ENTRY, JOIN, BLOCK, NEW, DIE, STABILIZE, or EXIT node *) |
278 : | | S_IF of { | ||
279 : | cond : node, (* COND node *) | ||
280 : | jhr | 192 | thenBranch : stmt, |
281 : | elseBranch : stmt | ||
282 : | } | ||
283 : | jhr | 256 | | S_LOOP of { |
284 : | jhr | 192 | hdr : stmt, |
285 : | jhr | 256 | cond : node, (* COND node *) |
286 : | body : stmt | ||
287 : | jhr | 192 | } |
288 : | |||
289 : | jhr | 188 | and rhs |
290 : | = VAR of var | ||
291 : | | LIT of Literal.literal | ||
292 : | | OP of Op.rator * var list | ||
293 : | | CONS of var list (* tensor-value construction *) | ||
294 : | |||
295 : | jhr | 192 | and var = V of { |
296 : | jhr | 137 | name : string, (* name *) |
297 : | id : Stamp.stamp, (* unique ID *) | ||
298 : | useCnt : int ref, (* count of uses *) | ||
299 : | props : PropList.holder | ||
300 : | jhr | 124 | } |
301 : | |||
302 : | jhr | 192 | withtype assign = (var * rhs) |
303 : | jhr | 188 | |
304 : | jhr | 256 | datatype program = Program of { |
305 : | globals : var list, | ||
306 : | globalInit : stmt, | ||
307 : | actors : actor list | ||
308 : | (* initialization *) | ||
309 : | } | ||
310 : | jhr | 188 | |
311 : | jhr | 256 | and actor = Actor of { |
312 : | name : Atom.atom, | ||
313 : | params : var list, | ||
314 : | state : var list, | ||
315 : | stateInit : stmt, | ||
316 : | methods : method list | ||
317 : | } | ||
318 : | jhr | 188 | |
319 : | jhr | 256 | and method = Method of { |
320 : | name : Atom.atom, | ||
321 : | stateIn : var list, (* names of state variables on method entry *) | ||
322 : | stateOut : var list, (* names of state variables on method exit *) | ||
323 : | body : stmt (* method body *) | ||
324 : | } | ||
325 : | jhr | 188 | |
326 : | jhr | 256 | structure Node = |
327 : | struct | ||
328 : | fun same (ND{id=a, ...}, ND{id=b, ...}) = Stamp.same(a, b) | ||
329 : | fun compare (ND{id=a, ...}, ND{id=b, ...}) = Stamp.compare(a, b) | ||
330 : | fun hash (ND{id, ...}) = Stamp.hash id | ||
331 : | fun toString (ND{id, kind, ...}) = let | ||
332 : | val tag = (case kind | ||
333 : | of NULL => "NULL" | ||
334 : | | ENTRY _ => "ENTRY" | ||
335 : | | JOIN _ => "JOIN" | ||
336 : | | COND _ => "COND" | ||
337 : | | BLOCK _ => "BLOCK" | ||
338 : | | NEW _ => "NEW" | ||
339 : | | DIE _ => "DIE" | ||
340 : | | STABILIZE _ => "STABILIZE" | ||
341 : | | EXIT _ => "EXIT" | ||
342 : | (* end case *)) | ||
343 : | in | ||
344 : | tag ^ Stamp.toString id | ||
345 : | end | ||
346 : | fun new kind = ND{id = Stamp.new(), props = PropList.newHolder(), kind = kind} | ||
347 : | val dummy = new NULL | ||
348 : | fun mkENTRY () = new (ENTRY{succ = ref dummy}) | ||
349 : | fun mkJOIN phis = new (JOIN{preds = ref [], phis = ref phis, succ = ref dummy}) | ||
350 : | fun mkCOND {cond, trueBranch, falseBranch} = new (COND{ | ||
351 : | pred = ref dummy, cond = cond, | ||
352 : | trueBranch = ref trueBranch, falseBranch = ref falseBranch | ||
353 : | }) | ||
354 : | fun mkBLOCK body = new (BLOCK{pred = ref dummy, body = ref body, succ = ref dummy}) | ||
355 : | fun mkNEW {actor, args} = new (NEW{ | ||
356 : | pred = ref dummy, actor = actor, args = args, succ = ref dummy | ||
357 : | }) | ||
358 : | fun mkDIE () = new (DIE{pred = ref dummy}) | ||
359 : | fun mkSTABILIZE () = new (STABILIZE{pred = ref dummy}) | ||
360 : | fun mkEXIT () = new (EXIT{pred = ref dummy}) | ||
361 : | (* editing node edges *) | ||
362 : | fun setPred (ND{kind, ...}, nd) = (case kind | ||
363 : | of NULL => raise Fail "setPred on NULL node" | ||
364 : | | ENTRY _ => raise Fail "setPred on ENTRY node" | ||
365 : | | JOIN{preds, ...} => if List.exists (fn nd' => same(nd, nd')) (!preds) | ||
366 : | then () | ||
367 : | else preds := nd :: !preds | ||
368 : | | COND{pred, ...} => pred := nd | ||
369 : | | BLOCK{pred, ...} => pred := nd | ||
370 : | | NEW{pred, ...} => pred := nd | ||
371 : | | DIE{pred} => pred := nd | ||
372 : | | STABILIZE{pred} => pred := nd | ||
373 : | | EXIT{pred} => pred := nd | ||
374 : | (* end case *)) | ||
375 : | fun preds (ND{kind, ...}) = (case kind | ||
376 : | of NULL => raise Fail "preds on NULL node" | ||
377 : | | ENTRY _ => [] | ||
378 : | | JOIN{preds, ...} => !preds | ||
379 : | | COND{pred, ...} => [!pred] | ||
380 : | | BLOCK{pred, ...} => [!pred] | ||
381 : | | NEW{pred, ...} => [!pred] | ||
382 : | | DIE{pred} => [!pred] | ||
383 : | | STABILIZE{pred} => [!pred] | ||
384 : | | EXIT{pred} => [!pred] | ||
385 : | (* end case *)) | ||
386 : | fun hasSucc (ND{kind, ...}) = (case kind | ||
387 : | of NULL => false | ||
388 : | | ENTRY{succ} => true | ||
389 : | | JOIN{succ, ...} => true | ||
390 : | | COND{trueBranch, falseBranch, ...} => true | ||
391 : | | BLOCK{succ, ...} => true | ||
392 : | | NEW{succ, ...} => true | ||
393 : | | DIE _ => false | ||
394 : | | STABILIZE _ => false | ||
395 : | | EXIT _ => false | ||
396 : | (* end case *)) | ||
397 : | fun setSucc (ND{kind, ...}, nd) = (case kind | ||
398 : | of NULL => raise Fail "setSucc on NULL node" | ||
399 : | | ENTRY{succ} => succ := nd | ||
400 : | | JOIN{succ, ...} => succ := nd | ||
401 : | | COND _ => raise Fail "setSucc on COND node" | ||
402 : | | BLOCK{succ, ...} => succ := nd | ||
403 : | | NEW{succ, ...} => succ := nd | ||
404 : | | DIE _ => raise Fail "setSucc on DIE node" | ||
405 : | | STABILIZE _ => raise Fail "setSucc on STABILIZE node" | ||
406 : | | EXIT _ => raise Fail "setSucc on EXIT node" | ||
407 : | (* end case *)) | ||
408 : | fun succs (ND{kind, ...}) = (case kind | ||
409 : | of NULL => raise Fail "succs on NULL node" | ||
410 : | | ENTRY{succ} => [!succ] | ||
411 : | | JOIN{succ, ...} => [!succ] | ||
412 : | | COND{trueBranch, falseBranch, ...} => [!trueBranch, !falseBranch] | ||
413 : | | BLOCK{succ, ...} => [!succ] | ||
414 : | | NEW{succ, ...} => [!succ] | ||
415 : | | DIE _ => [] | ||
416 : | | STABILIZE _ => [] | ||
417 : | | EXIT _ => [] | ||
418 : | (* end case *)) | ||
419 : | fun setTrueBranch (ND{kind=COND{trueBranch, ...}, ...}, nd) = trueBranch := nd | ||
420 : | | setTrueBranch (nd, _) = raise Fail("setTrueBranch on " ^ toString nd) | ||
421 : | fun setFalseBranch (ND{kind=COND{falseBranch, ...}, ...}, nd) = falseBranch := nd | ||
422 : | | setFalseBranch (nd, _) = raise Fail("setFalseBranch on " ^ toString nd) | ||
423 : | fun addEdge (nd1, nd2) = ( | ||
424 : | if hasSucc nd1 | ||
425 : | then ( | ||
426 : | setSucc (nd1, nd2); | ||
427 : | setPred (nd2, nd1)) | ||
428 : | else ()) | ||
429 : | (*DEBUG*)handle ex => ( | ||
430 : | print(concat["error in addEdge(", toString nd1, ",", toString nd2, ")\n"]); | ||
431 : | raise ex) | ||
432 : | jhr | 283 | (* properties *) |
433 : | fun newProp initFn = | ||
434 : | PropList.newProp (fn (ND{props, ...}) => props, initFn) | ||
435 : | fun newFlag () = | ||
436 : | PropList.newFlag (fn (ND{props, ...}) => props) | ||
437 : | jhr | 256 | end |
438 : | jhr | 124 | |
439 : | jhr | 256 | structure Stmt = |
440 : | struct | ||
441 : | fun same (STM{id=a, ...}, STM{id=b, ...}) = Stamp.same(a, b) | ||
442 : | fun compare (STM{id=a, ...}, STM{id=b, ...}) = Stamp.compare(a, b) | ||
443 : | fun hash (STM{id, ...}) = Stamp.hash id | ||
444 : | fun toString (STM{id, kind, ...}) = let | ||
445 : | val tag = (case kind | ||
446 : | of S_SIMPLE(ND{kind, ...}) => (case kind | ||
447 : | of NULL => "NULL" | ||
448 : | | ENTRY _ => "ENTRY" | ||
449 : | | JOIN _ => "JOIN" | ||
450 : | | COND _ => raise Fail "unexpected S_SIMPLE with COND node" | ||
451 : | | BLOCK _ => "BLOCK" | ||
452 : | | NEW _ => "NEW" | ||
453 : | | DIE _ => "DIE" | ||
454 : | | STABILIZE _ => "STABILIZE" | ||
455 : | | EXIT _ => "EXIT" | ||
456 : | (* end case *)) | ||
457 : | | S_IF _ => "IF" | ||
458 : | | S_LOOP _ => "LOOP" | ||
459 : | (* end case *)) | ||
460 : | in | ||
461 : | tag ^ Stamp.toString id | ||
462 : | end | ||
463 : | (* return the entry node of the statement *) | ||
464 : | fun entry (STM{kind, ...}) = (case kind | ||
465 : | of S_SIMPLE nd => nd | ||
466 : | | S_IF{cond, ...} => cond | ||
467 : | | S_LOOP{hdr, ...} => entry hdr | ||
468 : | (* end case *)) | ||
469 : | (* return the tail-end node of a statement (not applicable to S_IF or S_LOOP) *) | ||
470 : | fun tail (STM{kind, ...}) = (case kind | ||
471 : | of S_SIMPLE nd => nd | ||
472 : | | S_IF{cond, ...} => raise Fail "tail of IF" | ||
473 : | | S_LOOP{hdr, ...} => raise Fail "tail of LOOP" | ||
474 : | (* end case *)) | ||
475 : | (* statement constructor functions *) | ||
476 : | fun new (kind, next) = STM{ | ||
477 : | jhr | 137 | id = Stamp.new(), |
478 : | jhr | 188 | props = PropList.newHolder(), |
479 : | jhr | 256 | kind = kind, |
480 : | next = next | ||
481 : | jhr | 137 | } |
482 : | jhr | 256 | val dummy = new (S_SIMPLE(Node.dummy), NONE) |
483 : | fun mkENTRY next = new (S_SIMPLE(Node.mkENTRY ()), next) | ||
484 : | fun mkJOIN (phis, next) = new (S_SIMPLE(Node.mkJOIN phis), next) | ||
485 : | fun mkIF (cond, thenBranch, elseBranch, next) = let | ||
486 : | val cond = Node.mkCOND { | ||
487 : | cond = cond, | ||
488 : | trueBranch = entry thenBranch, | ||
489 : | falseBranch = entry elseBranch | ||
490 : | } | ||
491 : | in | ||
492 : | Node.setPred (entry thenBranch, cond); | ||
493 : | Node.setPred (entry elseBranch, cond); | ||
494 : | new (S_IF{cond = cond, thenBranch = thenBranch, elseBranch = elseBranch}, next) | ||
495 : | end | ||
496 : | fun mkBLOCK (body, next) = new (S_SIMPLE(Node.mkBLOCK body), next) | ||
497 : | fun mkNEW (actor, args, next) = new (S_SIMPLE(Node.mkNEW{actor=actor, args=args}), next) | ||
498 : | fun mkDIE () = new (S_SIMPLE(Node.mkDIE ()), NONE) | ||
499 : | fun mkSTABILIZE () = new (S_SIMPLE(Node.mkSTABILIZE ()), NONE) | ||
500 : | fun mkEXIT () = new (S_SIMPLE(Node.mkEXIT ()), NONE) | ||
501 : | jhr | 283 | (* properties *) |
502 : | fun newProp initFn = | ||
503 : | PropList.newProp (fn (STM{props, ...}) => props, initFn) | ||
504 : | fun newFlag () = | ||
505 : | PropList.newFlag (fn (STM{props, ...}) => props) | ||
506 : | jhr | 256 | end |
507 : | jhr | 137 | |
508 : | jhr | 199 | structure Var = |
509 : | struct | ||
510 : | fun new name = V{ | ||
511 : | name = name, | ||
512 : | id = Stamp.new(), | ||
513 : | useCnt = ref 0, | ||
514 : | props = PropList.newHolder() | ||
515 : | } | ||
516 : | fun same (V{id=a, ...}, V{id=b, ...}) = Stamp.same(a, b) | ||
517 : | fun compare (V{id=a, ...}, V{id=b, ...}) = Stamp.compare(a, b) | ||
518 : | fun hash (V{id, ...}) = Stamp.hash id | ||
519 : | fun toString (V{name, id, ...}) = name ^ Stamp.toString id | ||
520 : | jhr | 283 | (* properties *) |
521 : | fun newProp initFn = | ||
522 : | PropList.newProp (fn (V{props, ...}) => props, initFn) | ||
523 : | fun newFlag () = | ||
524 : | PropList.newFlag (fn (V{props, ...}) => props) | ||
525 : | jhr | 199 | local |
526 : | structure V = | ||
527 : | struct | ||
528 : | type ord_key = var | ||
529 : | val compare = compare | ||
530 : | end | ||
531 : | in | ||
532 : | structure Map = RedBlackMapFn (V) | ||
533 : | structure Set = RedBlackSetFn (V) | ||
534 : | end | ||
535 : | structure Tbl = HashTableFn ( | ||
536 : | struct | ||
537 : | type hash_key = var | ||
538 : | val hashVal = hash | ||
539 : | val sameKey = same | ||
540 : | end) | ||
541 : | end | ||
542 : | jhr | 197 | |
543 : | jhr | 319 | (* DFS sorting of the graph rooted at the entry to a statement; the resulting list will |
544 : | * be in preorder with parents before children. | ||
545 : | *) | ||
546 : | jhr | 257 | fun sortNodes stmt = let |
547 : | val {getFn, setFn} = PropList.newFlag (fn (ND{props, ...}) => props) | ||
548 : | fun dfs (nd, l) = | ||
549 : | if getFn nd | ||
550 : | then l | ||
551 : | else ( | ||
552 : | setFn (nd, true); | ||
553 : | nd :: List.foldl dfs l (Node.succs nd)) | ||
554 : | jhr | 319 | val nodes = dfs (Stmt.entry stmt, []) |
555 : | jhr | 257 | in |
556 : | jhr | 319 | List.app (fn nd => setFn(nd, false)) nodes; |
557 : | nodes | ||
558 : | jhr | 257 | end |
559 : | |||
560 : | jhr | 341 | (* apply a function to all of the nodes in the graph rooted at the entry to the statement *) |
561 : | fun applyToNodes (f : node -> unit) stmt = let | ||
562 : | val {getFn, setFn} = PropList.newFlag (fn (ND{props, ...}) => props) | ||
563 : | fun dfs (nd, l) = | ||
564 : | if getFn nd | ||
565 : | then l | ||
566 : | else ( | ||
567 : | f nd; (* visit *) | ||
568 : | setFn (nd, true); | ||
569 : | nd :: List.foldl dfs l (Node.succs nd)) | ||
570 : | val nodes = dfs (Stmt.entry stmt, []) | ||
571 : | in | ||
572 : | List.app (fn nd => setFn(nd, false)) nodes | ||
573 : | end | ||
574 : | |||
575 : | jhr | 124 | end |
root@smlnj-gforge.cs.uchicago.edu | ViewVC Help |
Powered by ViewVC 1.0.0 |