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

Parent Directory | Revision Log

---

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

---

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