Annotation of /sml/trunk/src/compiler/FLINT/clos/cps-split.sml

Parent Directory | Revision Log

---

Revision 224 - (view) (download)

1 :	monnier	66	(* cps-split.sml
2 :			*
3 :			* COPYRIGHT (c) 1996 Bell Laboratories.
4 :			*
5 :			*)
6 :
7 :			signature CPSSPLIT =
8 :			sig
9 :			val cpsSplit: CPS.function -> CPS.function list
10 :			end;
11 :
12 :			(** A dummy implementation for now **)
13 :			functor CpsSplitFun (MachSpec: MACH_SPEC): CPSSPLIT =
14 :			struct
15 :
16 :			fun cpsSplit f = [f]
17 :
18 :			end
19 :
20 :
21 :			(*
22 :			functor CpsSplitFun (MachSpec: MACH_SPEC): CPSSPLIT = struct
23 :
24 :			exception Impossible
25 :
26 :			(* currently we don't deal with floating point stuff,
27 :			* it is probably not worth the trouble here anyway *)
28 :			val numRegs = MachSpec.numRegs
29 :			val numCalleeSaves = MachSpec.numCalleeSaves
30 :
31 :			val maxEscapeArgs = numRegs - 1 - numCalleeSaves - 2
32 :			val maxContArgs = numRegs - 1 - 2
33 :
34 :			structure C = CPS
35 :			structure SL = SortedList
36 :			structure A = LambdaVar
37 :			structure M = IntmapF
38 :
39 :			val add = SL.enter
40 :			val del = SL.rmv
41 :			val join = SL.merge
42 :			val xcl = SL.remove
43 :			val mkset = SL.uniq
44 :			val inset = SL.member
45 :			val intersect = SL.intersect
46 :
47 :			fun lv_x (C.VAR v, l) = add (v, l)
48 :			| lv_x (C.LABEL v, l) = add (v, l)
49 :			| lv_x (_, l) = l
50 :
51 :			infix $
52 :			fun (f $ g) (x, y) = f (g x, y)
53 :			fun fst (x, _) = x
54 :
55 :			fun lv_record (l, v, elv) = foldl (lv_x $ fst) (del (v, elv)) l
56 :
57 :			fun lv_xv (x, v, elv) = lv_x (x, del (v, elv))
58 :
59 :			fun lv_app (x, l) = foldl lv_x (lv_x (x, [])) l
60 :
61 :			fun lv_setter (l, elv) = foldl lv_x elv l
62 :
63 :			fun lv_calc (l, v, elv) = foldl lv_x (del (v, elv)) l
64 :
65 :			fun lv_branch (l, v, elv1, elv2) =
66 :			foldl lv_x (del (v, join (elv1, elv2))) l
67 :
68 :			fun lv'switch (x, v, el) =
69 :			lv_x (x, del (v, foldl (join $ live) [] el))
70 :
71 :			and lv'branch (l, v, e1, e2) = lv_branch (l, v, live e1, live e2)
72 :
73 :			and lv'_fix (l, elv) = let
74 :			fun f ((_, v, vl, _, e), (lv, bv)) =
75 :			(join (xcl (mkset vl, live e), lv), add (v, bv))
76 :			val (lv, bv) = foldl f (elv, []) l
77 :			in
78 :			xcl (bv, lv)
79 :			end
80 :
81 :			and live (C.RECORD (_, l, v, e)) = lv_record (l, v, live e)
82 :			| live (C.SELECT (_, x, v, _, e)) = lv_xv (x, v, live e)
83 :			| live (C.OFFSET (_, x, v, e)) = lv_xv (x, v, live e)
84 :			| live (C.APP (x, l)) = lv_app (x, l)
85 :			| live (C.FIX (l, e)) = lv'_fix (l, live e)
86 :			| live (C.SWITCH (x, v, el)) = lv'switch (x, v, el)
87 :			| live (C.BRANCH (_, l, v, e1, e2)) = lv'branch (l, v, e1, e2)
88 :			| live (C.SETTER (_, l, e)) = lv_setter (l, live e)
89 :			| live (C.LOOKER (_, l, v, _, e)) = lv_calc (l, v, live e)
90 :			| live (C.ARITH (_, l, v, _, e)) = lv_calc (l, v, live e)
91 :			| live (C.PURE (_, l, v, _, e)) = lv_calc (l, v, live e)
92 :
93 :			structure M = IntmapF
94 :
95 :			(* scc stuff *)
96 :
97 :			datatype node = N of { id: int,
98 :			function: C.function option,
99 :			edges: node list ref,
100 :			fv: A.lvar list }
101 :
102 :			fun lt (N n1, N n2) = (#id n1) < (#id n2)
103 :			fun eq (N n1, N n2) = (#id n1) = (#id n2)
104 :
105 :			structure SCC = SCCUtilFun (type node = node val lt = lt val eq = eq)
106 :
107 :			fun scc (l, fv, e) = let
108 :			val root = N { id = ~1, function = NONE, edges = ref [], fv = fv }
109 :			fun mkn (f as (_, v, vl, _, b)) =
110 :			N { id = v, function = SOME f, edges = ref [],
111 :			fv = xcl (mkset vl, live b) }
112 :			val nodes = root :: map mkn l
113 :			fun addif n n' = let
114 :			val N { edges, fv, ... } = n'
115 :			val N { edges = bedges, ... } = n
116 :			in
117 :			case n of
118 :			N { function = SOME (k, f, _, _, _), ... } =>
119 :			if inset fv f then
120 :			(edges := n :: (!edges);
121 :			(* Add back edge for known functions. This forces
122 :			* the two nodes to be in the same scc, which is
123 :			* necessary because calls to known functions
124 :			* cannot go accross code segments *)
125 :			case k of
126 :			C.ESCAPE => ()
127 :			| C.CONT => ()
128 :			| _ => bedges := n' :: (!bedges))
129 :			else ()
130 :			| _ => ()
131 :			end
132 :			(* enter all edges *)
133 :			val _ = app (fn n => (app (addif n) nodes)) nodes
134 :			(* outgoing edges *)
135 :			fun out (N { edges = ref e, ... }) = e
136 :			(* calculate sccs of this graph;
137 :			* the top scc must contain the original root node (f = NONE)! *)
138 :			val top :: sccs =
139 :			SCC.sccTop { root = root, outgoingEdgesOf = out }
140 :
141 :			fun component l = let
142 :			fun xtr (N { function = SOME f, fv, ... }, (fl, lv, bv)) =
143 :			(f :: fl, join (fv, lv), add (#2 f, bv))
144 :			| xtr (N { function = NONE, ... }, x) = x
145 :			in
146 :			foldl xtr ([], [], []) l
147 :			end
148 :
149 :			val top' =
150 :			case top of
151 :			[N { function = NONE, ... }] => NONE
152 :			| _ => SOME (component top)
153 :			in
154 :			{ components = map component sccs, top = top' }
155 :			end
156 :
157 :			(* don't keep type info about known functions, because they cannot
158 :			* be passed to other codeunits anyway *)
159 :			datatype tyinfo =
160 :			NORMALTY of C.cty (* ordinary C.cty *)
161 :			| KNOWNTY (* known function *)
162 :			| CONTTY of C.cty list (* argument types of cont. function *)
163 :
164 :			type tymap = tyinfo M.intmap
165 :
166 :			fun rectyn 0 = C.INTt
167 :			| rectyn n = C.PTRt (C.RPT n)
168 :
169 :			fun recty lv = rectyn (length lv)
170 :
171 :			fun madd (v, t, m) = M.add (m, v, NORMALTY t)
172 :
173 :			fun maddf ((C.ESCAPE, v, _, _, _), m) = M.add (m, v, NORMALTY C.FUNt)
174 :			| maddf ((C.CONT, v, _, tl, _), m) = M.add (m, v, CONTTY tl)
175 :			| maddf ((_, v, _, _, _), m) = M.add (m, v, KNOWNTY)
176 :
177 :			fun maddal ([], [], m) = m
178 :			| maddal (v :: vl, t :: tl, m) = maddal (vl, tl, madd (v, t, m))
179 :			| maddal _ = raise Impossible
180 :
181 :			fun reconst (exp, tymap, units) =
182 :			case exp of
183 :			C.RECORD (k, l, v, e) => let
184 :			val tymap' = madd (v, recty l, tymap)
185 :			val (e', units', lv) = reconst (e, tymap', units)
186 :			val lv' = lv_record (l, v, lv)
187 :			in
188 :			(C.RECORD (k, l, v, e'), units', lv')
189 :			end
190 :			| C.SELECT (i, x, v, t, e) => let
191 :			val tymap' = madd (v, t, tymap)
192 :			val (e', units', lv) = reconst (e, tymap', units)
193 :			val lv' = lv_xv (x, v, lv)
194 :			in
195 :			(C.SELECT (i, x, v, t, e'), units', lv')
196 :			end
197 :			| C.OFFSET (i, x, v, e) => let
198 :			val tymap' = madd (v, C.BOGt, tymap)
199 :			val (e', units', lv) = reconst (e, tymap', units)
200 :			val lv' = lv_xv (x, v, lv)
201 :			in
202 :			(C.OFFSET (i, x, v, e'), units', lv')
203 :			end
204 :			| C.APP (x, l) => (exp, units, lv_app (x, l))
205 :			| C.FIX (fl, e) => reconst_fix (fl, e, tymap, units)
206 :			| C.SWITCH (x, v, el) => let
207 :			fun r (e, (u, lv, el)) = let
208 :			val (e', u', lv') = reconst (e, tymap, u)
209 :			in
210 :			(u', join (lv, lv'), e' :: el)
211 :			end
212 :			val (units', lv, el') = foldr r (units, [], []) el
213 :			in
214 :			(C.SWITCH (x, v, el'), units', lv)
215 :			end
216 :			| C.BRANCH (b, l, v, e1, e2) => let
217 :			val tymap' = madd (v, C.INTt, tymap)
218 :			val (e1', units', lv1) = reconst (e1, tymap', units)
219 :			val (e2', units'', lv2) = reconst (e2, tymap', units')
220 :			val lv = lv_branch (l, v, lv1, lv2)
221 :			in
222 :			(C.BRANCH (b, l, v, e1', e2'), units'', lv)
223 :			end
224 :			| C.SETTER (s, l, e) => let
225 :			val (e', units', lv) = reconst (e, tymap, units)
226 :			val lv' = lv_setter (l, lv)
227 :			in
228 :			(C.SETTER (s, l, e), units', lv')
229 :			end
230 :			| C.LOOKER (p, l, v, t, e) => let
231 :			val tymap' = madd (v, t, tymap)
232 :			val (e', units', lv) = reconst (e, tymap', units)
233 :			val lv' = lv_calc (l, v, lv)
234 :			in
235 :			(C.LOOKER (p, l, v, t, e'), units', lv')
236 :			end
237 :			| C.ARITH (p, l, v, t, e) => let
238 :			val tymap' = madd (v, t, tymap)
239 :			val (e', units', lv) = reconst (e, tymap', units)
240 :			val lv' = lv_calc (l, v, lv)
241 :			in
242 :			(C.ARITH (p, l, v, t, e'), units', lv')
243 :			end
244 :			| C.PURE (p, l, v, t, e) => let
245 :			val tymap' = madd (v, t, tymap)
246 :			val (e', units', lv) = reconst (e, tymap', units)
247 :			val lv' = lv_calc (l, v, lv)
248 :			in
249 :			(C.PURE (p, l, v, t, e'), units', lv')
250 :			end
251 :
252 :			and reconst_fix (fl, e, tymap, units) = let
253 :			val tymap = foldl maddf tymap fl
254 :			val (e, units, lv) = reconst (e, tymap, units)
255 :			val { components, top } = scc (fl, lv, e)
256 :
257 :			(* recursively apply reconstruction to continuations *)
258 :			fun reconst_cont ((C.CONT, v, vl, tl, e), (u, fl)) = let
259 :			val tymap = maddal (vl, tl, tymap)
260 :			val (e, u, _) = reconst (e, tymap, u)
261 :			in
262 :			(u, (C.CONT, v, vl, tl, e) :: fl)
263 :			end
264 :			| reconst_cont (f, (u, fl)) = (u, f :: fl)
265 :			fun reconst_comp (c, u) = foldl reconst_cont (u, []) c
266 :
267 :			(* incorporate top component *)
268 :			val (e, lv, units) =
269 :			case top of
270 :			NONE => (e, lv, units)
271 :			| SOME (bfl, blv, bbv) => let
272 :			val (u, c) = reconst_comp (bfl, units)
273 :			in
274 :			(C.FIX (c, e), xcl (bbv, join (blv, lv)), u)
275 :			end
276 :
277 :			(* a component is eligible to be put into its own unit if
278 :			* - it doesn't contain C.CONT members
279 :			* - none of its free variables refers to a known function *)
280 :			fun stays (fl, fv) = let
281 :			fun isCont (C.CONT, _, _, _, _) = true | isCont _ = false
282 :			fun impossibleArg v =
283 :			case M.lookup tymap v of
284 :			KNOWNTY => true
285 :			| NORMALTY C.CNTt => true
286 :			| _ => false
287 :			in
288 :			List.exists isCont fl orelse List.exists impossibleArg fv
289 :			end
290 :
291 :			(* move a component into its own code unit *)
292 :			fun movecomponent (fl, lv, xl, yl, e, units) = let
293 :
294 :			(* code for the new unit:
295 :			* (C.ESCAPE, unitvar,
296 :			* [contvar, argvar], [C.CNTt, C.BOGt],
297 :			* FIX ((ESCAPE, funvar,
298 :			* [contvar2, exl...], [C.CNTt, extl...],
299 :			* DECODESEND (exl..., xl...,
300 :			* FIX (fl,
301 :			* ENCODERCV (yl, eyl,
302 :			* APP (contvar2, eyl)))))
303 :			* RECORD ([argvar, funvar], resvar,
304 :			* APP (contvar, [resvar]))))
305 :			*
306 :			* code that replaces the original occurence of the component:
307 :			* FIX ((CONT, contvar2, eyl, [FUNt...],
308 :			* DECODERCV (eyl, yl, e)),
309 :			* ENCODESEND (xl, exl,
310 :			* APP (funvar, [contvar2, exl...])))
311 :			*)
312 :
313 :			val unitvar = A.mkLvar ()
314 :			val contvar = A.mkLvar ()
315 :			val argvar = A.mkLvar ()
316 :			val funvar = A.mkLvar ()
317 :			val contvar2 = A.mkLvar ()
318 :			val resvar = A.mkLvar ()
319 :
320 :			fun firstN (0, l) = ([], l)
321 :			| firstN (n, h :: t) = let
322 :			val (f, r) = firstN (n - 1, t)
323 :			in
324 :			(h :: f, r)
325 :			end
326 :			| firstN _ = raise Impossible
327 :
328 :			fun selectall (base, vl, tl, e) = let
329 :			val base = C.VAR base
330 :			fun s ([], [], _, e) = e
331 :			| s (h :: t, th :: tt, i, e) =
332 :			s (t, tt, i + 1, C.SELECT (i, base, h, th, e))
333 :			in
334 :			s (vl, tl, 0, e)
335 :			end
336 :
337 :			fun funty _ = C.FUNt
338 :			fun recvar v = (C.VAR v, C.OFFp 0)
339 :
340 :			(* deal with received values (all of them are functions) *)
341 :			val ny = length yl
342 :			val (ysend, mk_yrcv) =
343 :			if ny <= maxContArgs then
344 :			(C.APP (C.VAR contvar2, map C.VAR yl),
345 :			fn body =>
346 :			C.FIX ([(C.CONT, contvar2, yl, map funty yl, e)], body))
347 :			else let
348 :			val npy = ny + 1 - maxContArgs
349 :			val (pyl, ryl) = firstN (npy, yl)
350 :			val v = A.mkLvar ()
351 :			in
352 :			(C.RECORD (A.RK_RECORD, map recvar pyl, v,
353 :			C.APP (C.VAR contvar2,
354 :			(C.VAR v) :: map C.VAR ryl)),
355 :			fn body =>
356 :			C.FIX ([(C.CONT, contvar2, v :: ryl,
357 :			(recty pyl) :: map funty ryl,
358 :			selectall (v, pyl, map funty pyl, e))],
359 :			body))
360 :			end
361 :
362 :			(* put the component in *)
363 :			val fix'n'ysend = C.FIX (fl, ysend)
364 :
365 :			(* Wrap a CNTt so it can be passed as a FUNt.
366 :			* tl lists argument types *)
367 :			fun wrapcnt (xvar, x'var, tl, e) = let
368 :			val vl = map (fn _ => A.mkLvar ()) tl
369 :			val ikvar = A.mkLvar ()
370 :			in
371 :			C.FIX ([(C.ESCAPE, x'var, ikvar :: vl, C.CNTt :: tl,
372 :			C.APP (C.VAR xvar, map C.VAR vl))],
373 :			e)
374 :			end
375 :
376 :			(* unwrap FUNt so it can be used as a CNTt.
377 :			* Even though it ignores it our escaping version of the
378 :			* continuation expects a continuation of its own. We have
379 :			* to pull one out of the air... contvar2 *)
380 :			fun unwrapcnt (x'var, xvar, tl, e) = let
381 :			val vl = map (fn _ => A.mkLvar ()) tl
382 :			in
383 :			C.FIX ([(C.CONT, xvar, vl, tl,
384 :			C.APP (C.VAR x'var, map C.VAR (contvar2 :: vl)))],
385 :			e)
386 :			end
387 :
388 :			fun wrap'gen other (v, (evl, etl, mkwE, mkuwE)) =
389 :			case M.lookup tymap v of
390 :			KNOWNTY => raise Impossible
391 :			| CONTTY tl => let
392 :			val ev = A.mkLvar ()
393 :			in
394 :			(ev :: evl,
395 :			C.FUNt :: etl,
396 :			fn e => wrapcnt (v, ev, tl, mkwE e),
397 :			fn e => unwrapcnt (ev, v, tl, mkuwE e))
398 :			end
399 :			| NORMALTY C.CNTt => raise Impossible
400 :			| NORMALTY ct => other (v, ct, evl, etl, mkwE, mkuwE)
401 :
402 :			(* wrap a variable, so I can stick it into a record *)
403 :			val wrap'rec = let
404 :			fun other (v, ct, evl, etl, mkwE, mkuwE) = let
405 :			fun w (wrap, unwrap) = let
406 :			val ev = A.mkLvar ()
407 :			in
408 :			(ev :: evl,
409 :			C.BOGt :: etl,
410 :			fn e => C.PURE (wrap, [C.VAR v], ev, C.BOGt, mkwE e),
411 :			fn e => C.PURE (unwrap, [C.VAR ev], v, ct, mkuwE e))
412 :			end
413 :			in
414 :			case ct of
415 :			C.INT32t => w (C.P.i32wrap, C.P.i32unwrap)
416 :			| C.FLTt => w (C.P.fwrap, C.P.funwrap)
417 :			| _ => (v :: evl, ct :: etl, mkwE, mkuwE)
418 :			end
419 :			in
420 :			wrap'gen other
421 :			end
422 :
423 :			(* wrap continuations only (for argument passing) *)
424 :			val wrap'cnt = let
425 :			fun other (v, ct, evl, etl, mkwE, mkuwE) =
426 :			(v :: evl, ct :: etl, mkwE, mkuwE)
427 :			in
428 :			wrap'gen other
429 :			end
430 :
431 :			val nx = length xl
432 :			val unitresult =
433 :			C.RECORD (A.RK_RECORD,
434 :			[recvar argvar, recvar funvar],
435 :			resvar,
436 :			C.APP (C.VAR contvar, [C.VAR resvar]))
437 :			val (xsend, xrcv) =
438 :			if nx = 0 then
439 :			(C.APP (C.VAR funvar, [C.VAR contvar2, C.INT 0]),
440 :			C.FIX ([(C.ESCAPE, funvar,
441 :			[contvar2, A.mkLvar ()],
442 :			[C.CNTt, C.INTt],
443 :			fix'n'ysend)],
444 :			unitresult))
445 :			else if nx <= maxEscapeArgs then let
446 :			val (exl, etl, wrapper, unwrapper) =
447 :			foldr wrap'cnt ([], [], fn e => e, fn e => e) xl
448 :			in
449 :			(wrapper
450 :			(C.APP (C.VAR funvar,
451 :			(C.VAR contvar2) :: map C.VAR exl)),
452 :			C.FIX ([(C.ESCAPE, funvar,
453 :			contvar2 :: exl, C.CNTt :: etl,
454 :			unwrapper fix'n'ysend)],
455 :			unitresult))
456 :			end
457 :			else let
458 :			(* we need two rregisters for:
459 :			* 1. the continuation, 2. the record holding extra args *)
460 :			val npx = nx + 1 - maxEscapeArgs
461 :			val (pxl, rxl) = firstN (npx, xl)
462 :			val v = A.mkLvar ()
463 :			val (epxl, eptl, pwrapper, punwrapper) =
464 :			foldr wrap'rec ([], [], fn e => e, fn e => e) pxl
465 :			val (erxl, ertl, rwrapper, runwrapper) =
466 :			foldr wrap'cnt ([], [], fn e => e, fn e => e) rxl
467 :			in
468 :			(pwrapper
469 :			(rwrapper
470 :			(C.RECORD (A.RK_RECORD, map recvar epxl, v,
471 :			C.APP (C.VAR funvar,
472 :			(C.VAR contvar2) :: (C.VAR v) ::
473 :			map C.VAR erxl)))),
474 :			C.FIX ([(C.ESCAPE, funvar,
475 :			contvar2 :: v :: erxl,
476 :			C.CNTt :: (recty epxl) :: ertl,
477 :			selectall (v, epxl, eptl,
478 :			runwrapper
479 :			(punwrapper fix'n'ysend)))],
480 :			unitresult))
481 :			end
482 :
483 :			val newunit =
484 :			(C.ESCAPE, unitvar, [contvar, argvar], [C.CNTt, C.BOGt],
485 :			xrcv)
486 :			val replacedcode = mk_yrcv xsend
487 :
488 :			val { uheader, curargvar, ul } = units
489 :			val newargvar = A.mkLvar ()
490 :			fun uheader' e =
491 :			C.SELECT (0, C.VAR newargvar, curargvar, C.BOGt,
492 :			C.SELECT (1, C.VAR newargvar, funvar, C.FUNt,
493 :			uheader e))
494 :			val units' = { uheader = uheader', curargvar = newargvar,
495 :			ul = newunit :: ul }
496 :			in
497 :			(units', replacedcode)
498 :			end
499 :
500 :			(* deal with one component at a time *)
501 :			fun docomponent ((fl, lv, bv), (e, units, lv_rest)) = let
502 :			val fv = xcl (bv, lv)
503 :			val lv' = join (fv, xcl (bv, lv_rest))
504 :			val xl = fv
505 :			val yl = intersect (bv, lv_rest)
506 :			in
507 :			case yl of
508 :			[] => (e, units, lv_rest)
509 :			| _ =>
510 :			if stays (fl, fv) then let
511 :			val (units, fl) = reconst_comp (fl, units)
512 :			in
513 :			(C.FIX (fl, e), units, lv')
514 :			end
515 :			else let
516 :			val (u, e) = movecomponent (fl, lv, xl, yl, e, units)
517 :			in
518 :			(e, u, lv')
519 :			end
520 :			end
521 :
522 :			in
523 :			(* now do them all *)
524 :			foldl docomponent (e, units, lv) components
525 :			end
526 :
527 :			fun split (C.ESCAPE, name,
528 :			[contvar, argvar], [C.CNTt, argty], body) = let
529 :			val units = { uheader = fn e => e,
530 :			curargvar = argvar,
531 :			ul = [] }
532 :			val tymap = M.add (madd (argvar, C.BOGt, M.empty),
533 :			contvar, CONTTY [C.BOGt])
534 :			val (e, u, _) = reconst (body, tymap, units)
535 :			val { uheader, curargvar, ul } = u
536 :			val lastunit = (C.ESCAPE, name, [contvar, curargvar], [C.CNTt, C.BOGt],
537 :			uheader e)
538 :			in
539 :			foldl (op ::) [lastunit] ul
540 :			end
541 :
542 :			fun cpsSplit f =
543 :			case split f of
544 :			[_, _] => [f] (* found only one extra piece... don't bother *)
545 :			| l => l
546 :
547 :			end
548 :			*)
549 :
550 :	monnier	93
551 :			(*
552 :	monnier	223	* $Log: cps-split.sml,v $
553 :			* Revision 1.1.1.1 1998/04/08 18:39:46 george
554 :			* Version 110.5
555 :			*
556 :	monnier	93	*)

---

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