Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/compiler/FLINT/opt/lcontract.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/FLINT/opt/lcontract.sml

Parent Directory Parent Directory | Revision Log Revision Log


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

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