Annotation of /trunk/src/compiler/IL/ssa-fn.sml

Parent Directory | Revision Log

---

Revision 3349 - (view) (download)

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

---

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