Annotation of /sml/branches/SMLNJ/src/compiler/FLINT/opt/lcontract.sml

Parent Directory | Revision Log

---

Revision 69 - (view) (download)

1 :	monnier	16	(* Copyright 1996 by Bell Laboratories *)
2 :			(* lcontract.sml *)
3 :
4 :			signature LCONTRACT =
5 :			sig
6 :	monnier	45	val lcontract : FLINT.prog -> FLINT.prog
7 :	monnier	16	end
8 :
9 :			structure LContract : LCONTRACT =
10 :			struct
11 :
12 :			local structure DI = DebIndex
13 :	monnier	45	structure DA = Access
14 :			structure LT = LtyExtern
15 :	monnier	69	structure FU = FlintUtil
16 :	monnier	45	open FLINT
17 :	monnier	16	in
18 :
19 :	monnier	45	fun bug s = ErrorMsg.impossible ("LContract: "^s)
20 :			val say = Control.Print.say
21 :			val ident = fn x => x
22 :	monnier	16	fun all p (a::r) = p a andalso all p r | all p nil = true
23 :
24 :	monnier	45	fun isDiffs (vs, us) =
25 :			let fun h (VAR x) = List.all (fn y => (y<>x)) vs
26 :			| h _ = true
27 :			in List.all h us
28 :			end
29 :	monnier	16
30 :	monnier	45	fun isEqs (vs, us) =
31 :			let fun h (v::r, (VAR x)::z) = if v = x then h(r, z) else false
32 :			| h ([], []) = true
33 :			| h _ = false
34 :			in h(vs, us)
35 :			end
36 :
37 :	monnier	16	datatype info
38 :	monnier	45	= SimpVal of value
39 :	monnier	16	| ListExp of value list
40 :	monnier	45	| FunExp of DI.depth * lvar list * lexp
41 :			| ConExp of dcon * tyc list * value
42 :			| StdExp
43 :	monnier	16
44 :			exception LContPass1
45 :	monnier	45	fun pass1 fdec =
46 :	monnier	16	let val zz : (DI.depth option) Intmap.intmap = Intmap.new(32, LContPass1)
47 :			val add = Intmap.add zz
48 :			val get = Intmap.map zz
49 :			val rmv = Intmap.rmv zz
50 :			fun enter(x, d) = add(x, SOME d)
51 :			fun kill x = ((get x; rmv x) handle _ => ())
52 :			fun mark nd x =
53 :			(let val s = get x
54 :			val _ = rmv x
55 :			in case s
56 :			of NONE => ()
57 :	monnier	45	| SOME _ => add(x, NONE) (* depth no longer matters *)
58 :			(*
59 :	monnier	16	| SOME d => if (d=nd) then add(x, NONE)
60 :			else ()
61 :	monnier	45	*)
62 :	monnier	16	end) handle _ => ()
63 :
64 :			fun cand x = (get x; true) handle _ => false
65 :
66 :	monnier	45	fun lpfd d (FK_FUN {isrec=SOME _,...}, v, vts, e) = lple d e
67 :			| lpfd d (_, v, vts, e) = (enter(v, d); lple d e)
68 :
69 :			and lple d e =
70 :	monnier	16	let fun psv (VAR x) = kill x
71 :			| psv _ = ()
72 :	monnier	45
73 :			and pst (v, vks, e) = lple (DI.next d) e
74 :	monnier	16
75 :	monnier	45	and pse (RET vs) = app psv vs
76 :			| pse (LET(vs, e1, e2)) = (pse e1; pse e2)
77 :			| pse (FIX(fdecs, e)) = (app (lpfd d) fdecs; pse e)
78 :			| pse (APP(VAR x, vs)) = (mark d x; app psv vs)
79 :			| pse (APP(v, vs)) = (psv v; app psv vs)
80 :			| pse (TFN(tfdec, e)) = (pst tfdec; pse e)
81 :	monnier	16	| pse (TAPP(v, _)) = psv v
82 :	monnier	45	| pse (RECORD(_,vs,_,e)) = (app psv vs; pse e)
83 :			| pse (SELECT(u,_,_,e)) = (psv u; pse e)
84 :			| pse (CON(_,_,u,_,e)) = (psv u; pse e)
85 :			| pse (SWITCH(u, _, ces, oe)) =
86 :			(psv u; app (fn (_,x) => pse x) ces;
87 :	monnier	16	case oe of NONE => () | SOME x => pse x)
88 :	monnier	45	| pse (RAISE _) = ()
89 :	monnier	24	| pse (HANDLE(e,v)) = (pse e; psv v)
90 :	monnier	45	| pse (BRANCH(_, vs, e1, e2)) = (app psv vs; pse e1; pse e2)
91 :			| pse (PRIMOP(_, vs, _, e)) = (app psv vs; pse e)
92 :	monnier	16
93 :			in pse e
94 :			end
95 :
96 :	monnier	45	in lpfd DI.top fdec; (cand, fn () => Intmap.clear zz)
97 :			end (* pass1 *)
98 :	monnier	16
99 :			(************************************************************************
100 :			* THE MAIN FUNCTION *
101 :			************************************************************************)
102 :	monnier	45	fun lcontract (fdec, init) =
103 :	monnier	16	let
104 :
105 :	monnier	45	(* In pass1, we calculate the list of functions that are the candidates
106 :			* for contraction. To be such a candidate, a function must be called
107 :			* only once, and furthermore, the call site must be at the same
108 :			* depth as the definition site. (ZHONG)
109 :			*
110 :			* Being at the same depth is not strictly necessary, we'll relax this
111 :			* constraint in the future.
112 :			*)
113 :			val (isCand, cleanUp) =
114 :			if init then (fn _ => false, fn () => ()) else pass1 fdec
115 :	monnier	16
116 :			exception LContract
117 :			val m : (int ref * info) Intmap.intmap = Intmap.new(32, LContract)
118 :
119 :			val enter = Intmap.add m
120 :			val get = Intmap.map m
121 :			val kill = Intmap.rmv m
122 :
123 :			fun chkIn (v, info) = enter(v, (ref 0, info))
124 :
125 :	monnier	45	(** check if a variable is dead *)
126 :			fun dead v = (case get v of (ref 0, _) => true
127 :			| _ => false) handle _ => false
128 :	monnier	16
129 :	monnier	69	fun once v = (case get v of (ref 1, _) => true | _ => false) handle _ => false
130 :
131 :	monnier	45	(** check if all variables are dead *)
132 :			fun alldead [] = true
133 :			| alldead (v::r) = if dead v then alldead r else false
134 :	monnier	16
135 :	monnier	45	(** renaming a value *)
136 :			fun rename (u as (VAR v)) =
137 :			((case get v
138 :			of (_, SimpVal sv) => rename sv
139 :			| (x, _) => (x := (!x) + 1; u)) handle _ => u)
140 :			| rename u = u
141 :	monnier	16
142 :	monnier	45	(** selecting a field from a potentially known record *)
143 :			fun selInfo (VAR v, i) =
144 :			((case get v
145 :			of (_, SimpVal u) => selInfo (u, i)
146 :			| (_, ListExp vs) =>
147 :			let val nv = List.nth(vs, i)
148 :			handle _ => bug "unexpected List.Nth in selInfo"
149 :			in SOME nv
150 :			end
151 :			| _ => NONE) handle _ => NONE)
152 :			| selInfo _ = NONE
153 :	monnier	16
154 :	monnier	45	(** applying a switch to a data constructor *)
155 :			fun swiInfo (VAR v, ces, oe) =
156 :			((case get v
157 :			of (_, SimpVal u) => swiInfo(u, ces, oe)
158 :			| (_, ConExp (dc as (_,rep,_), ts, u)) =>
159 :			let fun h ((DATAcon(dc as (_,nrep,_),ts,x),e)::r) =
160 :			if rep=nrep then SOME(LET([x], RET [u], e)) else h r
161 :			| h (_::r) = bug "unexpected case in swiInfo"
162 :			| h [] = oe
163 :			in h ces
164 :			end
165 :			| _ => NONE) handle _ => NONE)
166 :			| swiInfo _ = NONE
167 :
168 :			(** contracting a function application *)
169 :			fun appInfo (VAR v) =
170 :			((case get v
171 :			of (ref 0, FunExp (d, vs, e)) => SOME (d, vs, e)
172 :			| _ => NONE) handle _ => NONE)
173 :			| appInfo _ = NONE
174 :
175 :	monnier	69
176 :			(** A very ad-hoc implementation of branch/switch eliminations *)
177 :			local
178 :
179 :			fun isBoolLty lt =
180 :			(case LT.ltd_arrow lt
181 :			of (_, [at], [rt]) =>
182 :			(LT.lt_eqv(at, LT.ltc_unit)) andalso (LT.lt_eqv(rt, LT.ltc_bool))
183 :			| _ => false)
184 :
185 :			fun isBool true (RECORD(RK_TUPLE _, [], x,
186 :			CON((_,DA.CONSTANT 1,lt), [], VAR x', v, RET [VAR v']))) =
187 :			(x = x') andalso (v = v') andalso (isBoolLty lt)
188 :			| isBool false (RECORD(RK_TUPLE _, [], x,
189 :			CON((_,DA.CONSTANT 0,lt), [], VAR x', v, RET [VAR v']))) =
190 :			(x = x') andalso (v = v') andalso (isBoolLty lt)
191 :			| isBool _ _ = false
192 :
193 :			(* functions that do the branch optimizations *)
194 :			fun boolDcon((DATAcon((_,DA.CONSTANT 1,lt1),[],v1), e1),
195 :			(DATAcon((_,DA.CONSTANT 0,lt2),[],v2), e2)) =
196 :			if (isBoolLty lt1) andalso (isBoolLty lt2) then
197 :			SOME(RECORD(FU.rk_tuple,[],v1,e1), RECORD(FU.rk_tuple,[],v2,e2))
198 :			else NONE
199 :			| boolDcon(ce1 as (DATAcon((_,DA.CONSTANT 0,_),[],_), _),
200 :			ce2 as (DATAcon((_,DA.CONSTANT 1,_),[],_), _)) =
201 :			boolDcon (ce2, ce1)
202 :			| boolDcon _ = NONE
203 :
204 :			fun ssplit (LET(vs,e1,e2)) = (fn x => LET(vs,x,e2), e1)
205 :			| ssplit e = (ident, e)
206 :
207 :			in
208 :
209 :			fun branchopt([v], e1 as (BRANCH(p, us, e11, e12)), e2) =
210 :			let val (hdr, se2) = ssplit e2
211 :			in case se2
212 :			of SWITCH(VAR nv, _, [ce1, ce2], NONE) =>
213 :			if (once v) andalso (nv = v) andalso (isBool true e11)
214 :			andalso (isBool false e12)
215 :			then (case boolDcon (ce1, ce2)
216 :			of SOME (e21, e22) => SOME(hdr(BRANCH(p, us, e21, e22)))
217 :			| NONE => NONE)
218 :			else NONE
219 :			| _ => NONE
220 :			end
221 :			| branchopt _ = NONE
222 :
223 :			end (* branchopt local *)
224 :
225 :
226 :			(** the main transformation function *)
227 :	monnier	45	fun transform [] = bug "unexpected case in transform"
228 :			| transform (cfg as ((d, od, k)::rcfg)) = let
229 :			fun h (f, t, (d, od, k)::r, sk) = h(f, f(t, od, d, k+sk), r, k+sk)
230 :			| h (f, t, [], _) = t
231 :			fun ltf t = h(LT.lt_adj_k, t, cfg, 0)
232 :			fun tcf t = h(LT.tc_adj_k, t, cfg, 0)
233 :
234 :			fun lpacc (DA.LVAR v) =
235 :			(case lpsv (VAR v) of VAR w => DA.LVAR w
236 :			| _ => bug "unexpected in lpacc")
237 :			| lpacc _ = bug "unexpected path in lpacc"
238 :
239 :			and lpdc (s, DA.EXN acc, t) = (s, DA.EXN(lpacc acc), ltf t)
240 :			| lpdc (s, rep, t) = (s, rep, ltf t)
241 :
242 :			and lpcon (DATAcon (dc, ts, v)) = DATAcon(lpdc dc, map tcf ts, v)
243 :			| lpcon c = c
244 :
245 :			and lpdt (SOME {default=v, table=ws}) =
246 :			let fun h x =
247 :			case rename (VAR x) of VAR nv => nv
248 :			| _ => bug "unexpected acse in lpdt"
249 :			in (SOME {default=h v, table=map (fn (ts,w) => (ts,h w)) ws})
250 :			end
251 :			| lpdt NONE = NONE
252 :
253 :			and lpsv x = (case x of VAR v => rename x | _ => x)
254 :
255 :			and lpfd (fk, v, vts, e) =
256 :	monnier	69	let val nfk =
257 :			case fk
258 :			of FK_FUN{isrec=SOME t, known, inline, fixed} =>
259 :			FK_FUN{isrec=SOME(map ltf t), known=known, inline=inline,
260 :			fixed=fixed}
261 :			| _ => fk
262 :			in (nfk, v, map (fn (v,t) => (v,ltf t)) vts, #1(loop e))
263 :			end
264 :	monnier	45
265 :			and lplet (hdr: lexp -> lexp, pure, v: lvar, info: info, e) =
266 :			let val _ = chkIn(v, info)
267 :			val (ne, b) = loop e
268 :			in if pure then (if dead v then (ne, b) else (hdr ne, b))
269 :			else (hdr ne, false)
270 :			end (* function lplet *)
271 :
272 :			and loop le =
273 :			(case le
274 :			of RET vs => (RET (map lpsv vs), true)
275 :			| LET(vs, RET us, e) =>
276 :			(ListPair.app chkIn (vs, map SimpVal us); loop e)
277 :			| LET(vs, LET(us, e1, e2), e3) =>
278 :			loop(LET(us, e1, LET(vs, e2, e3)))
279 :			| LET(vs, FIX(fdecs, e1), e2) =>
280 :			loop(FIX(fdecs, LET(vs, e1, e2)))
281 :			| LET(vs, TFN(tfd, e1), e2) =>
282 :			loop(TFN(tfd, LET(vs, e1, e2)))
283 :			| LET(vs, CON(dc, ts, u, v, e1), e2) =>
284 :			loop(CON(dc, ts, u, v, LET(vs, e1, e2)))
285 :			| LET(vs, RECORD(rk, us, v, e1), e2) =>
286 :			loop(RECORD(rk, us, v, LET(vs, e1, e2)))
287 :			| LET(vs, SELECT(u, i, v, e1), e2) =>
288 :			loop(SELECT(u, i, v, LET(vs, e1, e2)))
289 :			| LET(vs, PRIMOP(p, us, v, e1), e2) =>
290 :			loop(PRIMOP(p, us, v, LET(vs, e1, e2)))
291 :			| LET(vs, e1, e2 as (RET us)) =>
292 :			if isEqs(vs, us) then loop e1
293 :			else let val (ne1, b1) = loop e1
294 :			val nus = map lpsv us
295 :			in if (isDiffs(vs, nus)) andalso b1 then (RET nus, true)
296 :			else (LET(vs, ne1, RET nus), b1)
297 :	monnier	16	end
298 :	monnier	45	| LET(vs, e1, e2) =>
299 :			let val _ = app (fn v => chkIn(v, StdExp)) vs
300 :			val (ne1, b1) = loop e1
301 :			val (ne2, b2) = loop e2
302 :			in if (alldead vs) andalso b1 then (ne2, b2)
303 :	monnier	69	else (case branchopt(vs, ne1, ne2)
304 :			of SOME xx => (xx, b1 andalso b2)
305 :			| NONE =>
306 :			(case ne2
307 :			of (RET us) =>
308 :			if isEqs(vs, us) then (ne1, b1)
309 :			else (LET(vs, ne1, ne2), b1)
310 :			| _ => (LET(vs, ne1, ne2), b1 andalso b2)))
311 :	monnier	45	end
312 :	monnier	16
313 :	monnier	45	| FIX(fdecs, e) =>
314 :			let fun g (FK_FUN {isrec=SOME _, ...} :fkind, v, _, _) =
315 :			chkIn(v, StdExp)
316 :			| g ((_, v, vts, xe) : fundec) =
317 :			chkIn(v, if isCand v then FunExp(od, map #1 vts, xe)
318 :			else StdExp)
319 :			val _ = app g fdecs
320 :			val (ne, b) = loop e
321 :			in if alldead (map #2 fdecs) then (ne, b)
322 :			else (FIX(map lpfd fdecs, ne), b)
323 :			end
324 :			| APP(u, us) =>
325 :			(case appInfo u
326 :			of SOME(od', vs, e) =>
327 :			let val ne = LET(vs, RET us, e)
328 :			in transform ((od, od', 0)::cfg) ne
329 :			end
330 :			| _ => (APP(lpsv u, map lpsv us), false))
331 :	monnier	16
332 :	monnier	45	| TFN(tfdec as (v, tvks, xe), e) =>
333 :			lplet ((fn z => TFN((v, tvks,
334 :			#1(transform ((DI.next d, DI.next od,
335 :			k+1)::rcfg) xe)), z)),
336 :			true, v, StdExp, e)
337 :			| TAPP(u, ts) => (TAPP(lpsv u, map tcf ts), true)
338 :	monnier	16
339 :	monnier	45	| CON(c, ts, u, v, e) => (* this could be made more finegrain *)
340 :			lplet ((fn z => CON(lpdc c, map tcf ts, lpsv u, v, z)),
341 :			true, v, ConExp(c,ts,u), e)
342 :			| SWITCH (v, cs, ces, oe) =>
343 :			(case swiInfo(v, ces, oe)
344 :			of SOME ne => loop ne
345 :			| _ => let val nv = lpsv v
346 :			fun h ((c, e), (es, b)) =
347 :			let val nc = lpcon c
348 :			val (ne, nb) = loop e
349 :			in ((nc, ne)::es, nb andalso b)
350 :			end
351 :			val (nces, ncb) = foldr h ([], true) ces
352 :			val (noe, nb) =
353 :			case oe
354 :			of NONE => (NONE, ncb)
355 :			| SOME e => let val (ne, b) = loop e
356 :			in (SOME ne, b andalso ncb)
357 :			end
358 :			in (SWITCH(nv, cs, nces, noe), nb)
359 :			end)
360 :	monnier	16
361 :	monnier	45	| RECORD (rk, us, v, e) =>
362 :			lplet ((fn z => RECORD(rk, map lpsv us, v, z)),
363 :			true, v, ListExp us, e)
364 :			| SELECT(u, i, v, e) =>
365 :			(case selInfo (u, i)
366 :			of SOME nv => (chkIn(v, SimpVal nv); loop e)
367 :			| NONE => lplet ((fn z => SELECT(lpsv u, i, v, z)),
368 :			true, v, StdExp, e))
369 :	monnier	16
370 :	monnier	45	| RAISE(v, ts) => (RAISE(lpsv v, map ltf ts), false)
371 :			| HANDLE(e, v) =>
372 :			let val (ne, b) = loop e
373 :			in if b then (ne, true)
374 :			else (HANDLE(ne, lpsv v), false)
375 :			end
376 :	monnier	16
377 :	monnier	45	| BRANCH(px as (d, p, lt, ts), vs, e1, e2) =>
378 :			let val (ne1, b1) = loop e1
379 :			val (ne2, b2) = loop e2
380 :			in (BRANCH(case (d,ts) of (NONE, []) => px
381 :			| _ => (lpdt d, p, lt, map tcf ts),
382 :			map lpsv vs, ne1, ne2), false)
383 :			end
384 :			| PRIMOP(px as (dt, p, lt, ts), vs, v, e) =>
385 :			lplet ((fn z => PRIMOP((case (dt, ts)
386 :			of (NONE, []) => px
387 :			| _ => (lpdt dt, p, lt, map tcf ts)),
388 :			map lpsv vs, v, z)),
389 :			false (* isPure p *), v, StdExp, e))
390 :	monnier	16
391 :	monnier	45	in loop
392 :			end (* function transform *)
393 :	monnier	16
394 :	monnier	45	val d = DI.top
395 :			val (fk, f, vts, e) = fdec
396 :			in (fk, f, vts, #1 (transform [(d, d, 0)] e))
397 :			before (Intmap.clear m; cleanUp())
398 :			end (* function lcontract *)
399 :	monnier	16
400 :	monnier	45	(** run the lambda contraction twice *)
401 :			val lcontract = fn fdec => lcontract(lcontract(fdec, true), false)
402 :	monnier	16
403 :			end (* toplevel local *)
404 :			end (* structure LContract *)
405 :

---

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