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

Parent Directory | Revision Log

---

Revision 16 - (view) (download)
Original Path: sml/trunk/src/compiler/FLINT/opt/lcontract.sml

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

---

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