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/fcontract.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 58 - (view) (download)

1 : monnier 58 (* copyright 1998 YALE FLINT PROJECT *)
2 :    
3 :     signature FCONTRACT =
4 :     sig
5 :    
6 :     (* needs Collect to be setup properly *)
7 :     val contract : FLINT.fundec -> FLINT.fundec
8 :    
9 :     end
10 :    
11 :     (* All kinds of beta-reductions. In order to do as much work per pass as
12 :     * possible, the usage counts of each variable (maintained by the Collect
13 :     * module) is kept as much uptodate as possible. For instance as soon as a
14 :     * variable becomes dead, all the variables that were referenced have their
15 :     * usage counts decremented correspondingly. This means that we have to
16 :     * be careful to make sure that a dead variable will indeed not appear
17 :     * in the output lexp since it might else reference other dead variables *)
18 :    
19 :     (* things that lcontract did that fcontract doesn't do (yet):
20 :     *
21 :     * - inline across DeBruijn depths
22 :     * - switch(con) concellation
23 :     * - elimination of let [dead-vs] = pure in body *)
24 :    
25 :     structure FContract :> FCONTRACT =
26 :     struct
27 :     local
28 :     structure F = FLINT
29 :     structure M = Intmap
30 :     structure C = Collect
31 :     structure DI = DebIndex
32 :     structure PP = PPFlint
33 :     in
34 :    
35 :     val say = Control.Print.say
36 :     fun bug msg = ErrorMsg.impossible ("FContract: "^msg)
37 :     fun buglexp (msg,le) = (say "\n"; PP.printLexp le; bug msg)
38 :     fun bugval (msg,v) = (say "\n"; PP.printSval v; bug msg)
39 :    
40 :     (* fun sayexn e = app say (map (fn s => s^" <- ") (SMLofNJ.exnHistory e)) *)
41 :    
42 :     fun ASSERT (true,_) = ()
43 :     | ASSERT (FALSE,msg) = bug ("assertion "^msg^" failed")
44 :    
45 :     datatype sval
46 :     = Val of F.value
47 :     | Var of F.lvar
48 :     | Fun of F.lvar * F.lexp * (F.lvar * F.lty) list * F.fkind * DI.depth
49 :     | TFun of F.lvar * F.lexp * (F.tvar * F.tkind) list * DI.depth
50 :     | Record of F.lvar * F.value list
51 :     | Select of F.lvar * F.value * int
52 :     | Con of F.lvar * F.value * F.dcon
53 :    
54 :     exception NotFound
55 :     val m : sval M.intmap = M.new(128, NotFound)
56 :    
57 :     fun cexp (cfg as (d,od)) le = let
58 :    
59 :     val loop = cexp cfg
60 :    
61 :     fun used lv = C.usenb lv > 0
62 :    
63 :     fun impurePO po = true (* if a PrimOP is pure or not *)
64 :    
65 :     fun lookup lv = M.map m lv
66 :     (* handle e as NotFound => *)
67 :     (* (say (concat ["\nlooking up unbound ", *)
68 :     (* !PP.LVarString lv]); *)
69 :     (* raise e) *)
70 :    
71 :     fun sval2val sv =
72 :     case sv
73 :     of (Var lv | Fun{1=lv,...} | TFun{1=lv,...} | Record{1=lv,...}
74 :     | Select{1=lv,...} | Con{1=lv,...} | Val (F.VAR lv)) => F.VAR lv
75 :     | Val v => v
76 :    
77 :     fun val2sval (F.VAR ov) = ((lookup ov) handle x => raise x)
78 :     | val2sval v = Val v
79 :    
80 :     fun bugsv (msg,sv) = bugval(msg, sval2val sv)
81 :    
82 :     fun subst ov = sval2val (lookup ov)
83 :     val substval = sval2val o val2sval
84 :     fun substvar lv =
85 :     case substval (F.VAR lv)
86 :     of F.VAR lv => lv
87 :     | v => bugval ("unexpected val", v)
88 :    
89 :     fun unuseval f (F.VAR lv) = C.unuse f false lv
90 :     | unuseval f _ = ()
91 :    
92 :     (* called when a variable becomes dead.
93 :     * it simply adjusts the use-counts *)
94 :     fun undertake lv =
95 :     (case lookup lv
96 :     of Val v => unuseval undertake v
97 :     | Var nlv => ASSERT(nlv = lv, "nlv = lv")
98 :     | ( Fun {1=lv,2=le,...} | TFun{1=lv,2=le,...} ) =>
99 :     C.inside lv (fn()=> C.unuselexp undertake le)
100 :     | ( Select {2=v,...} | Con {2=v,...} ) =>
101 :     unuseval undertake v
102 :     | Record {2=vs,...} => app (unuseval undertake) vs)
103 :     handle x =>
104 :     (say "while undertaking "; PP.printSval(F.VAR lv); say "\n";
105 :     raise x)
106 :    
107 :     fun addbind (lv,sv) =
108 :     let fun eqsv (sv1,sv2) = (sval2val sv1) = (sval2val sv2)
109 :     fun correct (Val v) = true
110 :     | correct sv =
111 :     let val F.VAR lv = sval2val sv
112 :     in eqsv(sv, M.map m lv)
113 :     end handle NotFound => true
114 :     in ASSERT(correct sv, "addbind");
115 :     M.add m (lv, sv)
116 :     end
117 :    
118 :     (* substitute a value sv for a variable lv and unuse value v *)
119 :     fun substitute (lv1, sv, v) =
120 :     (case sval2val sv of F.VAR lv2 => C.transfer(lv1,lv2) | v2 => ();
121 :     unuseval undertake v;
122 :     addbind (lv1, sv)) handle x => raise x
123 :    
124 :     (* common code for all the lexps "let v = <op>[v1,...] in ..." *)
125 :     fun clet1 (svcon,lecon) (lv,vs,le) =
126 :     if used lv then
127 :     let val nvs = map substval vs
128 :     val _ = addbind (lv, svcon(nvs))
129 :     val nle = loop le
130 :     in if used lv then lecon(nvs, nle) else nle
131 :     end
132 :     else loop le
133 :    
134 :     (* common code for primops *)
135 :     fun cpo (SOME{default,table},po,lty,tycs) =
136 :     (SOME{default=substvar default,
137 :     table=map (fn (tycs,lv) => (tycs, substvar lv)) table},
138 :     po,lty,tycs)
139 :     | cpo po = po
140 :    
141 :     fun cdcon (s,Access.EXN(Access.LVAR lv),lty) =
142 :     (s, Access.EXN(Access.LVAR(substvar lv)), lty)
143 :     | cdcon dc = dc
144 :    
145 :     in
146 :     case le
147 :     of F.RET vs => (F.RET (map substval vs) handle x => raise x)
148 :    
149 :     | F.LET (lvs,le,body) =>
150 :     (let fun clet (F.LET(lvs1,le1,le2)) = F.LET(lvs1, le1, clet le2)
151 :     (* let associativity
152 :     * !!BEWARE!! applying the associativity rule might
153 :     * change the liveness of the bound variables *)
154 :     | clet (F.FIX(fdecs,le)) =
155 :     let val nbody = clet le
156 :     val nfdecs = List.filter (used o #2) fdecs
157 :     in if null nfdecs then nbody else F.FIX(nfdecs, nbody)
158 :     end
159 :     | clet (F.TFN(tfdec,le)) =
160 :     let val nbody = clet le
161 :     in if used (#1 tfdec) then F.TFN(tfdec, nbody) else nbody
162 :     end
163 :     | clet (F.CON(dc,tycs,v,lv,le)) =
164 :     let val nbody = clet le
165 :     in if used lv then F.CON(dc, tycs, v, lv, nbody) else nbody
166 :     end
167 :     | clet (F.RECORD(rk,vs,lv,le)) =
168 :     let val nbody = clet le
169 :     in if used lv then F.RECORD(rk, vs, lv, nbody) else nbody
170 :     end
171 :     | clet (F.SELECT(v,i,lv,le)) =
172 :     let val nbody = clet le
173 :     in if used lv then F.SELECT(v, i, lv, nbody) else nbody
174 :     end
175 :     | clet (F.PRIMOP(po,vs,lv,le)) =
176 :     let val nbody = clet le
177 :     in if impurePO po orelse used lv
178 :     then F.PRIMOP(po, vs, lv, nbody)
179 :     else nbody
180 :     end
181 :     (* F.RAISE never returns so the body of the let could be
182 :     * dropped on the floor, but since I don't propagate
183 :     * types I can't come up with the right return type
184 :     * | F.RAISE(v,ltys) =>
185 :     * (C.unuselexp undertake body;
186 :     * F.RAISE(v, ?????)) *)
187 :     | clet (F.RET vs) =
188 :     (* LET[lvs] = RET[vs] is replaced by substitutions *)
189 :     (app (fn (lv,v) => substitute (lv, val2sval v, v))
190 :     (ListPair.zip(lvs, vs));
191 :     loop body)
192 :     | clet le =
193 :     (app (fn lv => addbind (lv, Var lv)) lvs;
194 :     case loop body
195 :     of F.RET vs => if vs = (map F.VAR lvs) then le
196 :     else F.LET(lvs, le, F.RET vs)
197 :     | nbody => F.LET(lvs, le, nbody))
198 :     in
199 :     clet (loop le)
200 :     end handle x => raise x)
201 :    
202 :     | F.FIX (fs,le) =>
203 :     (let fun cfun [] acc = rev acc
204 :     | cfun (fdec as (fk,f,args,body)::fs) acc =
205 :     if used f then
206 :     let (* make up the bindings for args inside the body *)
207 :     val _ = app (fn lv => addbind (lv, Var lv))
208 :     (map #1 args)
209 :     (* contract the body and create the resulting fundec *)
210 :     val nbody = C.inside f (fn()=> loop body)
211 :     val nsv = Fun(f, nbody, args, fk, od)
212 :    
213 :     val _ = (* update the subst with the new code *)
214 :     case nbody (* look for eta redex *)
215 :     of F.APP(g,vs) =>
216 :     if vs = (map (F.VAR o #1) args)
217 :     then substitute (f, val2sval g, g)
218 :     else addbind (f, nsv)
219 :     | _ => addbind (f, nsv)
220 :     in cfun fs ((fk, f, args, nbody)::acc)
221 :     end
222 :     else cfun fs acc
223 :    
224 :     (* register the new bindings. We register them
225 :     * uncontracted first, for the needs of mutual recursion,
226 :     * and then we replace the contracted versions as they
227 :     * become available *)
228 :     val _ = app (fn fdec as (fk,f,args,body) =>
229 :     addbind (f, Fun(f, body, args, fk, od)))
230 :     fs
231 :    
232 :     (* recurse on the bodies *)
233 :     val fs = cfun fs []
234 :    
235 :     val nle = loop le (* contract the main body *)
236 :     val fs = List.filter (used o #2) fs (* junk newly unused funs *)
237 :     in
238 :     if List.null fs
239 :     then nle
240 :     else F.FIX(fs,nle)
241 :     end handle x => raise x)
242 :    
243 :     | F.APP (f,vs) =>
244 :     (let val nvs = map substval vs
245 :     in case val2sval f
246 :     of Fun(g,body,args,fk,od) =>
247 :     (ASSERT(C.usenb g > 0, "C.usenb g > 0");
248 :     if C.usenb g = 1 andalso od = d andalso not (C.recursive g)
249 :    
250 :     (* simple inlining: we should copy the body and then
251 :     * kill the function, but instead we keep the body
252 :     * and kill only the function name *)
253 :     then (C.unuse (fn lv => ()) true g;
254 :     cexp (d,od) (F.LET(map #1 args, F.RET nvs, body)))
255 :    
256 :     (* no inlining: just substitute the vars and vals *)
257 :     else F.APP(F.VAR g, nvs))
258 :    
259 :     | sv => F.APP(sval2val sv, nvs)
260 :     end handle x => raise x)
261 :    
262 :     | F.TFN ((f,args,body),le) =>
263 :     ((if used f then
264 :     let (* val _ = addbind (f, TFun(f, body, args, od)) *)
265 :     val nbody = cexp (DI.next d, DI.next od) body
266 :     val _ = addbind (f, TFun(f, nbody, args, od))
267 :     val nle = loop le
268 :     in
269 :     if used f
270 :     then F.TFN((f, args, nbody), nle)
271 :     else nle
272 :     end
273 :     else loop le) handle x => raise x)
274 :    
275 :     | F.TAPP(f,tycs) => F.TAPP(substval f, tycs)
276 :    
277 :     | F.SWITCH (v,ac,arms,def) =>
278 :     (let val nv = substval v
279 :     fun carm (F.DATAcon(dc,tycs,lv),le) =
280 :     (addbind(lv, Var lv);
281 :     (F.DATAcon(cdcon dc, tycs, lv), loop le))
282 :     | carm (con,le) = (con, loop le)
283 :     val narms = map carm arms
284 :     val ndef = Option.map loop def
285 :     in
286 :     F.SWITCH(nv,ac,narms,ndef)
287 :     end handle x => raise x)
288 :    
289 :     | F.CON (dc,tycs,v,lv,le) =>
290 :     let val ndc = cdcon dc
291 :     in clet1 (fn [nv] => Con(lv, nv, ndc),
292 :     fn ([nv],nle) => F.CON(ndc, tycs, nv, lv, nle))
293 :     (lv,[v],le)
294 :     end
295 :    
296 :     | F.RECORD (rk,vs,lv,le) =>
297 :     clet1 (fn nvs => Record(lv, nvs),
298 :     fn (nvs,nle) => F.RECORD(rk, nvs, lv, nle))
299 :     (lv,vs,le)
300 :    
301 :     | F.SELECT (v,i,lv,le) =>
302 :     if used lv then
303 :     case val2sval v
304 :     of Record (lvr,vs) =>
305 :     (let val sv = val2sval (List.nth(vs, i))
306 :     in substitute (lv, sv, F.VAR lvr);
307 :     loop le
308 :     end handle x => raise x)
309 :     | sv =>
310 :     (let val nv = sval2val sv
311 :     val _ = addbind (lv, Select(lv, nv, i))
312 :     val nle = loop le
313 :     in if used lv then F.SELECT(nv, i, lv, nle) else nle
314 :     end handle x => raise x)
315 :     else loop le
316 :    
317 :     | F.RAISE (v,ltys) => F.RAISE(substval v, ltys)
318 :    
319 :     | F.HANDLE (le,v) => F.HANDLE(loop le, substval v)
320 :    
321 :     | F.BRANCH (po,vs,le1,le2) =>
322 :     (let val nvs = map substval vs
323 :     val npo = cpo po
324 :     val nle1 = loop le1
325 :     val nle2 = loop le2
326 :     in F.BRANCH(npo, nvs, nle1, le2)
327 :     end handle x => raise x)
328 :    
329 :     | F.PRIMOP (po,vs,lv,le) =>
330 :     (let val nvs = map substval vs
331 :     val npo = cpo po
332 :     val _ = addbind(lv, Var lv)
333 :     val nle = loop le
334 :     in if impurePO po orelse used lv
335 :     then F.PRIMOP(npo, nvs, lv, nle)
336 :     else nle
337 :     end handle x => raise x)
338 :    
339 :     end handle x => raise x
340 :    
341 :     fun contract (fdec as (_,f,_,_)) =
342 :     let val _ = M.clear m
343 :     val F.FIX([fdec], F.RET[F.VAR f]) =
344 :     cexp (DI.top,DI.top) (F.FIX([fdec], F.RET[F.VAR f]))
345 :     val _ = M.clear m
346 :     in fdec
347 :     end
348 :    
349 :     end
350 :     end

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