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 81 - (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 : monnier 73 (* things that lcontract.sml does that fcontract doesn't do (yet):
20 : monnier 58 * - inline across DeBruijn depths
21 : monnier 63 * - elimination of let [dead-vs] = pure in body
22 : monnier 81 * - contraction of `let [v] = branch in switch v'
23 : monnier 63 *)
24 : monnier 58
25 : monnier 72 (* things that cpsopt/eta.sml did that fcontract doesn't do:
26 :     * - let f vs = select(v,i,g,g vs)
27 :     *)
28 :    
29 :     (* things that cpsopt/contract.sml did that fcontract doesn't do:
30 :     * - IF-idiom
31 :     * - unifying branches
32 :     * - Handler operations
33 :     * - primops expressions
34 :     * - branch expressions
35 :     * - dropping of arguments
36 :     *)
37 :    
38 : monnier 81 (* things that could also be added:
39 :     * - elimination of dead vars in let (subsumes what lcontract does)
40 :     *)
41 :    
42 :     (* things that would require some type info:
43 :     * - dropping foo in LET vs = RAISE v IN foo
44 :     * - contracting RECORD(R.1,R.2) => R
45 :     *)
46 :    
47 :     (* eta-reduction is tricky:
48 :     * - recognition of eta-redexes and introduction of the corresponding
49 :     * substitution in the table has to be done at the very beginning of
50 :     * the processing of the FIX
51 :     * - eta-reduction can turn a known function into an escaping function
52 :     * - fun f (g,v2,v3) = g(g,v2,v3) looks tremendously like an eta-redex
53 :     *)
54 :    
55 :     (* order of contraction is important:
56 :     * - the body of a FIX is contracted before the functions because the
57 :     * functions might end up being inlined in the body in which case they
58 :     * could be contracted twice. This makes introduction of eta-reduction
59 :     * less seamless.
60 :     *)
61 :    
62 :     (* When creating substitution f->g (as happens with eta redexes or with
63 :     * code like `LET [f] = RET[g]'), we need to make sure that the usage cout
64 :     * of f gets properly transfered to g. One way to do that is to make the
65 :     * transfer incremental: each time we apply the substitution, we decrement
66 :     * f's count and increment g's count. But this can be tricky since the
67 :     * elimination of the eta-redex (or the trivial binding) eliminates one of the
68 :     * references to g and if thyis is the only one, we might trigger the killing
69 :     * of g even though its count would be later incremented. Similarly, inlining
70 :     * of g would be dangerous as long as some references to f exist.
71 :     * So instead we do the transfer once and for all when we see the eta-redex,
72 :     * which frees us from those two problems but forces us to make sure that
73 :     * every existing reference to f will be substituted with g.
74 :     * Also, the transfer of counts from f to g is not quite straightforward
75 :     * since some of the references to f might be from inside g and without doing
76 :     * the transfer incrementally, we can't easily know which of the usage counts
77 :     * of f should be transfered to the internal counts of g and which to the
78 :     * external counts.
79 :     *)
80 :    
81 :     (* Simple inlining (inlining called-once functions, which doesn't require
82 :     * alpha-renaming) seems inoffensive enough but is not always desirable.
83 :     * The typical example is wrapper functions introduced by fexpand: they
84 :     * usually (until inlined) contain the only call the the main function,
85 :     * but inlining the main function in the wrapper defeats the purpose of the
86 :     * wrapper.
87 :     * cpsopt dealt with this problem by adding a `NO_INLINE_INTO' hint to the
88 :     * wrapper function. In this file, the idea is to be careful instead:
89 :     * - all functions (even the ones that would have a `NO_INLINE_INTO') are
90 :     * contracted, because the "aggressive usage count maintenance" makes any
91 :     * alternative painful (the collect phase has already assumed that dead code
92 :     * will be eliminated, which means that fcontract should at the very least
93 :     * do the dead-code elimination, so you can only avoid fcontracting if you
94 :     * can be sure that the body doesn't contain any dead-code, which is generally
95 :     * not known).
96 :     * - once a function is fcontracted it is marked as non-inlinable since
97 :     * fcontractiong might have changed its form considerably (via inlining).
98 :     * - to ensure that this de-inlining doesn't prevent too much inlining, the
99 :     * inlineable functions should be contracted late.
100 :     * - at the very end of the optimization phase, cpsopt had a special pass
101 :     * that ignored the `NO_INLINE_INTO' hint (since at this stage, inlining
102 :     * into it doesn't have any undesirable side effects any more). The present
103 :     * code doesn't need such a thing. On another hand, the cpsopt approach
104 :     * had the advantage of keeping the `inline' bit from one contract phase to
105 :     * the next. If this ends up being important, I could add a global
106 :     * "noinline" flag that could be set to true whenever fcontracting an
107 :     * inlinable function.
108 :     *)
109 :    
110 : monnier 58 structure FContract :> FCONTRACT =
111 :     struct
112 :     local
113 :     structure F = FLINT
114 : monnier 81 structure M = IntmapF
115 : monnier 58 structure C = Collect
116 :     structure DI = DebIndex
117 :     structure PP = PPFlint
118 : monnier 81 structure LV = LambdaVar
119 : monnier 58 in
120 :    
121 :     val say = Control.Print.say
122 :     fun bug msg = ErrorMsg.impossible ("FContract: "^msg)
123 :     fun buglexp (msg,le) = (say "\n"; PP.printLexp le; bug msg)
124 :     fun bugval (msg,v) = (say "\n"; PP.printSval v; bug msg)
125 :    
126 :     (* fun sayexn e = app say (map (fn s => s^" <- ") (SMLofNJ.exnHistory e)) *)
127 :    
128 :     fun ASSERT (true,_) = ()
129 :     | ASSERT (FALSE,msg) = bug ("assertion "^msg^" failed")
130 :    
131 : monnier 81 (* copy an lexp, with alpha renaming. Could be moved to flint.sml
132 :     * since it's very generic (though probably not useful at many other places) *)
133 :     fun copy alpha le = let
134 :     fun substvar lv = ((M.lookup alpha lv) handle M.IntmapF => lv)
135 :     fun substval (F.VAR lv) = F.VAR(substvar lv)
136 :     | substval v = v
137 :     fun newv (lv,alpha) =
138 :     let val nlv = LV.mkLvar() in (nlv, M.add(alpha,lv,nlv)) end
139 :     fun newvs (lvs,alpha) =
140 :     foldr (fn (lv,(lvs,alpha)) =>
141 :     let val (nlv,nalpha) = newv(lv,alpha) in (nlv::lvs,nalpha) end)
142 :     ([],alpha) lvs
143 :     fun cdcon (s,Access.EXN(Access.LVAR lv),lty) =
144 :     (s, Access.EXN(Access.LVAR(substvar lv)), lty)
145 :     | cdcon dc = dc
146 :     fun cpo (SOME{default,table},po,lty,tycs) =
147 :     (SOME{default=substvar default,
148 :     table=map (fn (tycs,lv) => (tycs, substvar lv)) table},
149 :     po,lty,tycs)
150 :     | cpo po = po
151 :     in case le
152 :     of F.RET vs => F.RET(map substval vs)
153 :     | F.LET (lvs,le,body) =>
154 :     let val nle = copy alpha le
155 :     val (nlvs,nalpha) = newvs(lvs,alpha)
156 :     in F.LET(nlvs, nle, copy nalpha body)
157 :     end
158 :     | F.FIX (fdecs,le) =>
159 :     let fun cfun alpha ((fk,f,args,body):F.fundec,nf) =
160 :     let val (nargs,nalpha) = newvs(map #1 args, alpha)
161 :     in (fk, nf, ListPair.zip(nargs, (map #2 args)), copy nalpha body)
162 :     end
163 :     val (nfs, nalpha) = newvs(map #2 fdecs, alpha)
164 :     val nfdecs = ListPair.map (cfun nalpha) (fdecs, nfs)
165 :     in
166 :     F.FIX(nfdecs, copy nalpha le)
167 :     end
168 :     | F.APP (f,args) => F.APP(substval f, map substval args)
169 :     | F.TFN ((lv,args,body),le) =>
170 :     (* don't forget to rename the tvar also *)
171 :     let val (nlv,nalpha) = newv(lv,alpha)
172 :     val (nargs,ialpha) = newvs(map #1 args, nalpha)
173 :     in F.TFN((nlv, ListPair.zip(nargs, map #2 args), copy ialpha body),
174 :     copy nalpha le)
175 :     end
176 :     | F.TAPP (f,tycs) => F.TAPP(substval f, tycs)
177 :     | F.SWITCH (v,ac,arms,def) =>
178 :     let fun carm (F.DATAcon(dc,tycs,lv),le) =
179 :     let val (nlv,nalpha) = newv(lv, alpha)
180 :     in (F.DATAcon(cdcon dc, tycs, nlv), copy nalpha le)
181 :     end
182 :     | carm (con,le) = (con, copy alpha le)
183 :     in F.SWITCH(substval v, ac, map carm arms, Option.map (copy alpha) def)
184 :     end
185 :     | F.CON (dc,tycs,v,lv,le) =>
186 :     let val (nlv,nalpha) = newv(lv, alpha)
187 :     in F.CON(cdcon dc, tycs, substval v, nlv, copy nalpha le)
188 :     end
189 :     | F.RECORD (rk,vs,lv,le) =>
190 :     let val (nlv,nalpha) = newv(lv, alpha)
191 :     in F.RECORD(rk, map substval vs, nlv, copy nalpha le)
192 :     end
193 :     | F.SELECT (v,i,lv,le) =>
194 :     let val (nlv,nalpha) = newv(lv, alpha)
195 :     in F.SELECT(substval v, i, nlv, copy nalpha le)
196 :     end
197 :     | F.RAISE (v,ltys) => F.RAISE(substval v, ltys)
198 :     | F.HANDLE (le,v) => F.HANDLE(copy alpha le, substval v)
199 :     | F.BRANCH (po,vs,le1,le2) =>
200 :     F.BRANCH(cpo po, map substval vs, copy alpha le1, copy alpha le2)
201 :     | F.PRIMOP (po,vs,lv,le) =>
202 :     let val (nlv,nalpha) = newv(lv, alpha)
203 :     in F.PRIMOP(cpo po, map substval vs, nlv, copy nalpha le)
204 :     end
205 :     end
206 :    
207 : monnier 58 datatype sval
208 : monnier 81 = Val of F.value (* F.value should never be F.VAR lv *)
209 : monnier 58 | Fun of F.lvar * F.lexp * (F.lvar * F.lty) list * F.fkind * DI.depth
210 :     | TFun of F.lvar * F.lexp * (F.tvar * F.tkind) list * DI.depth
211 :     | Record of F.lvar * F.value list
212 : monnier 81 | Con of F.lvar * F.value * F.dcon
213 : monnier 58 | Select of F.lvar * F.value * int
214 : monnier 81 | Var of F.lvar * F.lty option (* cop out case *)
215 : monnier 58
216 : monnier 81 fun cexp (cfg as (d,od)) m le = let
217 : monnier 73
218 : monnier 58 val loop = cexp cfg
219 :    
220 :     fun used lv = C.usenb lv > 0
221 :    
222 :     fun impurePO po = true (* if a PrimOP is pure or not *)
223 :    
224 : monnier 63 fun eqConV (F.INTcon i1, F.INT i2) = i1 = i2
225 :     | eqConV (F.INT32con i1, F.INT32 i2) = i1 = i2
226 :     | eqConV (F.WORDcon i1, F.WORD i2) = i1 = i2
227 :     | eqConV (F.WORD32con i1, F.WORD32 i2) = i1 = i2
228 :     | eqConV (F.REALcon r1, F.REAL r2) = r1 = r2
229 :     | eqConV (F.STRINGcon s1, F.STRING s2) = s1 = s2
230 :     | eqConV (con,v) = bugval("unexpected comparison with val", v)
231 :    
232 : monnier 81 fun lookup m lv = (M.lookup m lv)
233 :     handle e as M.IntmapF =>
234 :     (say "\nlooking up unbound ";
235 :     say (!PP.LVarString lv);
236 :     raise e)
237 : monnier 58
238 :     fun sval2val sv =
239 :     case sv
240 : monnier 63 of (Fun{1=lv,...} | TFun{1=lv,...} | Record{1=lv,...}
241 : monnier 81 | Con{1=lv,...} | Select{1=lv,...} | Var{1=lv,...}) => F.VAR lv
242 : monnier 58 | Val v => v
243 :    
244 : monnier 81 fun val2sval m (F.VAR ov) = ((lookup m ov) handle x => raise x)
245 :     | val2sval m v = Val v
246 : monnier 58
247 :     fun bugsv (msg,sv) = bugval(msg, sval2val sv)
248 :    
249 : monnier 81 fun subst m ov = sval2val ((lookup m ov) handle x => raise x)
250 :     val substval = sval2val o (val2sval m)
251 : monnier 58 fun substvar lv =
252 : monnier 81 case ((substval (F.VAR lv)) handle x => raise x)
253 : monnier 58 of F.VAR lv => lv
254 :     | v => bugval ("unexpected val", v)
255 :    
256 :     fun unuseval f (F.VAR lv) = C.unuse f false lv
257 :     | unuseval f _ = ()
258 :    
259 :     (* called when a variable becomes dead.
260 :     * it simply adjusts the use-counts *)
261 : monnier 81 fun undertake m lv =
262 :     let val undertake = undertake m
263 :     in case lookup m lv
264 :     of Var {1=nlv,...} => ASSERT(nlv = lv, "nlv = lv")
265 :     | Val v => ()
266 :     | Fun (lv,le,args,_,_) =>
267 :     C.unusefdec undertake (lv, map #1 args, le)
268 :     | TFun{1=lv,2=le,...} => C.unusefdec undertake (lv, [], le)
269 :     | (Select {2=v,...} | Con {2=v,...}) => unuseval undertake v
270 :     | Record {2=vs,...} => app (unuseval undertake) vs
271 : monnier 58 end
272 : monnier 81 handle M.IntmapF =>
273 :     (say "\nUnable to undertake "; PP.printSval(F.VAR lv))
274 :     | x =>
275 :     (say "\nwhile undertaking "; PP.printSval(F.VAR lv); raise x)
276 : monnier 58
277 : monnier 81 fun addbind (m,lv,sv) = M.add(m, lv, sv)
278 :    
279 :     (* substitute a value sv for a variable lv and unuse value v.
280 :     * This doesn't quite work for eta-redex since the `use' we have
281 :     * to remove in that case is a non-escaping use, whereas this code
282 :     * assumes that we're getting rid of an escaping use *)
283 :     fun substitute (m, lv1, sv, v) =
284 : monnier 58 (case sval2val sv of F.VAR lv2 => C.transfer(lv1,lv2) | v2 => ();
285 : monnier 81 unuseval (undertake m) v;
286 :     addbind(m, lv1, sv)) handle x =>
287 :     (say "\nwhile substituting ";
288 :     PP.printSval (F.VAR lv1);
289 :     say " for ";
290 :     PP.printSval (sval2val sv);
291 :     raise x)
292 : monnier 58
293 :     (* common code for primops *)
294 :     fun cpo (SOME{default,table},po,lty,tycs) =
295 :     (SOME{default=substvar default,
296 :     table=map (fn (tycs,lv) => (tycs, substvar lv)) table},
297 :     po,lty,tycs)
298 :     | cpo po = po
299 :    
300 :     fun cdcon (s,Access.EXN(Access.LVAR lv),lty) =
301 :     (s, Access.EXN(Access.LVAR(substvar lv)), lty)
302 :     | cdcon dc = dc
303 :    
304 : monnier 81 (* F.APP inlining (if any) *)
305 :     fun inline (f,vs) =
306 :     case ((val2sval m f) handle x => raise x)
307 :     of Fun(g,body,args,F.FK_FUN{isrec,inline,...},od) =>
308 :     (ASSERT(C.usenb g > 0, "C.usenb g > 0");
309 :     if C.usenb g = 1 andalso od = d andalso not (C.recursive g)
310 :    
311 :     (* simple inlining: we should copy the body and then
312 :     * kill the function, but instead we just move the body
313 :     * and kill only the function name. This inlining strategy
314 :     * looks inoffensive enough, but still requires some care:
315 :     * see comments at the begining of this file and in cfun *)
316 :     then (C.unuse (fn _ => ()) true g; ASSERT(not (used g), "killed");
317 :     SOME(F.LET(map #1 args, F.RET vs, body), od))
318 :    
319 :     (* aggressive inlining (but hopefully safe). We allow
320 :     * inlining for mutually recursive functions (isrec)
321 :     * despite the potential risk. The reason is that it can
322 :     * happen that a wrapper (that should be inlined) has to be made
323 :     * mutually recursive with its main function. On another hand,
324 :     * self recursion (C.recursive) is too dangerous to be inlined
325 :     * except for loop unrolling which we don't support yet *)
326 :     else if inline andalso od = d andalso not(C.recursive g) then
327 :     let val nle = copy M.empty (F.LET(map #1 args, F.RET vs, body))
328 :     in C.uselexp nle;
329 :     app (unuseval (undertake m)) vs;
330 :     C.unuse (undertake m) true g;
331 :     SOME(nle, od)
332 :     end
333 :    
334 :     else NONE)
335 :     | sv => NONE
336 : monnier 58 in
337 :     case le
338 : monnier 81 of F.RET vs => F.RET((map substval vs) handle x => raise x)
339 : monnier 58
340 :     | F.LET (lvs,le,body) =>
341 : monnier 81 let fun cassoc le = F.LET(lvs, le, body)
342 :     fun simplesubst ((lv,v),m) =
343 :     let val sv = (val2sval m v) handle x => raise x
344 :     in substitute(m, lv, sv, sval2val sv)
345 : monnier 63 end
346 : monnier 81 (* default behavior *)
347 :     fun clet () =
348 :     let val nle = loop m le
349 :     val nm = foldl (fn (lv,m) => addbind(m, lv, Var(lv, NONE)))
350 :     m lvs
351 :     in case loop nm body
352 :     of F.RET vs => if vs = (map F.VAR lvs) then nle
353 :     else F.LET(lvs, nle, F.RET vs)
354 :     | nbody => F.LET(lvs, nle, nbody)
355 : monnier 63 end
356 : monnier 81 val lopm = loop m
357 :     in case le
358 :     (* apply let associativity *)
359 :     of F.LET(lvs1,le',le) => lopm(F.LET(lvs1, le', cassoc le))
360 :     | F.FIX(fdecs,le) => lopm(F.FIX(fdecs, cassoc le))
361 :     | F.TFN(tfdec,le) => lopm(F.TFN(tfdec, cassoc le))
362 :     | F.CON(dc,tycs,v,lv,le) => lopm(F.CON(dc, tycs, v, lv, cassoc le))
363 :     | F.RECORD(rk,vs,lv,le) => lopm(F.RECORD(rk, vs, lv, cassoc le))
364 :     | F.SELECT(v,i,lv,le) => lopm(F.SELECT(v, i, lv, cassoc le))
365 :     | F.PRIMOP(po,vs,lv,le) => lopm(F.PRIMOP(po, vs, lv, cassoc le))
366 :     (* this is a hack originally meant to cleanup the BRANCH mess
367 :     * introduced in flintnm (where each branch returns just true or
368 :     * false which is generally only used as input to a SWITCH.
369 :     * The present code does more than clean up this case (mostly
370 :     * out of lazyness and also because it's very ad-hoc) but the
371 :     * added generality leads to potential uncontrolled exponential
372 :     * code blowup (and with very little improvement anywhere).
373 :     * In clear, it's probably not a good idea. *)
374 :     | F.BRANCH (po,vs,le1,le2) => clet()
375 :     (* let fun cassoc (lv,v,body) wrap = *)
376 :     (* if lv = v andalso C.usenb lv = 1 then *)
377 :     (* let val nle1 = F.LET([lv], le1, body) *)
378 :     (* val nlv = LV.mkLvar() *)
379 :     (* val body2 = copy (M.add(M.empty,lv,nlv)) body *)
380 :     (* val nle2 = F.LET([nlv], le2, body2) *)
381 :     (* in C.new false nlv; C.uselexp body2; *)
382 :     (* lopm(wrap(F.BRANCH(po, vs, nle1, nle2))) *)
383 :     (* end *)
384 :     (* else *)
385 :     (* clet() *)
386 :     (* in case (lvs,body) *)
387 :     (* of ([lv],le as F.SWITCH(F.VAR v,_,_,_)) => *)
388 :     (* cassoc(lv, v, le) (fn x => x) *)
389 :     (* | ([lv],F.LET(lvs,le as F.SWITCH(F.VAR v,_,_,_),rest)) => *)
390 :     (* cassoc(lv, v, le) (fn le => F.LET(lvs,le,rest)) *)
391 :     (* | _ => clet() *)
392 :     (* end *)
393 :     | F.RET vs =>
394 :     ((loop (foldl simplesubst m (ListPair.zip(lvs, vs))) body)
395 :     handle x => raise x)
396 :     | F.APP(f,vs) =>
397 :     (case inline(f, vs)
398 :     of SOME(le,od) => cexp (d,od) m (F.LET(lvs, le, body))
399 :     | NONE => clet())
400 :     | (F.TAPP _ | F.SWITCH _ | F.RAISE _ | F.HANDLE _) =>
401 :     clet()
402 : monnier 63 end
403 : monnier 58
404 :     | F.FIX (fs,le) =>
405 : monnier 81 let fun cfun (m,[]:F.fundec list,acc) = acc
406 :     | cfun (m,fdec as (fk,f,args,body)::fs,acc) =
407 : monnier 63 if used f then
408 :     let (* make up the bindings for args inside the body *)
409 : monnier 81 fun addnobind ((lv,lty),m) =
410 :     addbind(m, lv, Var(lv, SOME lty))
411 :     val nm = foldl addnobind m args
412 : monnier 63 (* contract the body and create the resulting fundec *)
413 : monnier 81 val nbody = C.inside f (fn()=> loop nm body)
414 :     (* fixup the fkind info with new data.
415 :     * C.recursive only tells us if a fun is self-recursive
416 :     * but doesn't deal with mutual recursion.
417 :     * Also the `inline' bit has to be turned off because
418 :     * it applied to the function before contraction
419 :     * but might not apply to its new form (inlining might
420 :     * have increased its size substantially or made it
421 :     * recursive in a different way which could make further
422 :     * inlining even dangerous) *)
423 :     val nfk =
424 :     case fk of F.FK_FCT => fk
425 :     | F.FK_FUN {isrec,fixed,known,inline} =>
426 :     let val nisrec = if isSome isrec andalso
427 :     null fs andalso
428 :     null acc andalso
429 :     not(C.recursive f)
430 :     then NONE else isrec
431 :     val nknown = known orelse not(C.escaping f)
432 :     in F.FK_FUN{isrec=nisrec, fixed=fixed,
433 :     inline=false, known=nknown}
434 :     end
435 :     (* update the binding in the map. This step is not
436 :     * not just a mere optimization but is necessary
437 :     * because if we don't do it and the function
438 :     * gets inlined afterwards, the counts will reflect the
439 :     * new contracted code while we'll be working on the
440 :     * the old uncontracted code *)
441 :     val nm = addbind(m, f, Fun(f, nbody, args, nfk, od))
442 :     in cfun(nm, fs, (nfk, f, args, nbody)::acc)
443 : monnier 63 end
444 : monnier 81 else cfun(m, fs, acc)
445 : monnier 73
446 : monnier 81 (* check for eta redex *)
447 :     fun ceta ((fk,f,args,F.APP(g,vs)):F.fundec,(m,hs)) =
448 :     if vs = (map (F.VAR o #1) args) andalso
449 :     (* don't forget to check that g is not one of the args
450 :     * and not f itself either *)
451 :     (List.find (fn v => v = g) (F.VAR f::vs)) = NONE
452 :     then
453 :     let val svg = val2sval m g
454 :     val g = case sval2val svg
455 :     of F.VAR g => g
456 :     | v => bugval("not a variable", v)
457 :     (* NOTE: we don't want to turn a known function into an
458 :     * escaping one. It's dangerous for optimisations based
459 :     * on known functions (elimination of dead args, f.ex)
460 :     * and could generate cases where call>use in collect *)
461 :     in if not (C.escaping f andalso
462 :     not (C.escaping g))
463 :     then let
464 :     (* if an earlier function h has been eta-reduced
465 :     * to f, we have to be careful to update its
466 :     * binding to not refer to f any more since f
467 :     * will disappear *)
468 :     val nm = foldl (fn (h,m) =>
469 :     if sval2val(lookup m h) = F.VAR f
470 :     then addbind(m, h, svg) else m)
471 :     m hs
472 :     in
473 :     (* if g is one of the members of the FIX, f might
474 :     * appear in its body, so we don't know what parts
475 :     * of the counts of f should be counted as inside
476 :     * g and what parts should be counted as outside
477 :     * so we take the conservative approach of counting
478 :     * them in both *)
479 :     if isSome(List.find (fn (_,f,_,_) => f = g) fs)
480 :     then C.inside g (fn()=> C.addto(f,g)) else ();
481 :     C.transfer(f,g); C.unuse (undertake nm) true g;
482 :     (addbind(nm, f, svg),f::hs)
483 :     end
484 :     else (m, hs)
485 :     end
486 :     else (m, hs)
487 :     | ceta (_,(m,hs)) = (m, hs)
488 :    
489 :     (* junk unused funs *)
490 :     val fs = List.filter (used o #2) fs
491 :    
492 :     (* register the new bindings (uncontracted for now) *)
493 :     val nm = foldl (fn (fdec as (fk,f,args,body),m) =>
494 :     addbind(m, f, Fun(f, body, args, fk, od)))
495 :     m fs
496 :     (* check for eta redexes *)
497 :     val (nm,_) = foldl ceta (nm,[]) fs
498 :    
499 :     (* move the inlinable functions to the end of the list *)
500 :     val (f1s,f2s) =
501 :     List.partition (fn (F.FK_FUN{inline,...},_,_,_) => inline
502 :     | _ => false) fs
503 :     val fs = f2s @ f1s
504 :    
505 : monnier 73 (* contract the main body *)
506 : monnier 81 val nle = loop nm le
507 : monnier 73 (* contract the functions *)
508 : monnier 81 val fs = cfun(nm, fs, [])
509 : monnier 73 (* junk newly unused funs *)
510 :     val fs = List.filter (used o #2) fs
511 : monnier 58 in
512 : monnier 81 if List.null fs then nle else F.FIX(fs,nle)
513 : monnier 63 end
514 : monnier 58
515 :     | F.APP (f,vs) =>
516 : monnier 81 let val nvs = ((map substval vs) handle x => raise x)
517 :     in case inline(f, nvs)
518 :     of SOME(le,od) => cexp (d,od) m le
519 :     | NONE => F.APP((substval f) handle x => raise x, nvs)
520 : monnier 63 end
521 : monnier 58
522 :     | F.TFN ((f,args,body),le) =>
523 : monnier 63 if used f then
524 : monnier 81 let val nbody = cexp (DI.next d, DI.next od) m body
525 :     val nm = addbind(m, f, TFun(f, nbody, args, od))
526 :     val nle = loop nm le
527 : monnier 63 in
528 : monnier 81 if used f then F.TFN((f, args, nbody), nle) else nle
529 : monnier 63 end
530 : monnier 81 else loop m le
531 : monnier 58
532 : monnier 81 | F.TAPP(f,tycs) => F.TAPP((substval f) handle x => raise x, tycs)
533 : monnier 58
534 :     | F.SWITCH (v,ac,arms,def) =>
535 : monnier 81 (case ((val2sval m v) handle x => raise x)
536 :     of sv as (Var{1=lvc,...} | Select{1=lvc,...} | Record{1=lvc,...}) =>
537 :     let fun carm (F.DATAcon(dc,tycs,lv),le) =
538 :     let val ndc = cdcon dc
539 :     (* here I should try to extract the type of lv *)
540 :     val nm = addbind(m, lv, Var(lv, NONE))
541 :     (* we can rebind lv to a more precise value *)
542 :     val nm = addbind(nm, lvc, Con(lvc, F.VAR lv, ndc))
543 :     in (F.DATAcon(ndc, tycs, lv), loop nm le)
544 :     end
545 :     | carm (con,le) = (con, loop m le)
546 : monnier 63 val narms = map carm arms
547 : monnier 81 val ndef = Option.map (loop m) def
548 : monnier 63 in
549 :     F.SWITCH(sval2val sv, ac, narms, ndef)
550 : monnier 81 end
551 : monnier 63
552 :     | Con (lvc,v,(_,conrep,_)) =>
553 :     let fun carm ((F.DATAcon((_,crep,_),tycs,lv),le)::tl) =
554 :     if crep = conrep then
555 : monnier 81 loop (substitute(m, lv, (val2sval m v) handle x => raise x, F.VAR lvc)) le
556 : monnier 63 else carm tl
557 : monnier 81 | carm [] = loop m (Option.valOf def)
558 : monnier 63 | carm _ = buglexp("unexpected arm in switch(con,...)", le)
559 :     in carm arms
560 :     end
561 : monnier 81
562 : monnier 63 | Val v =>
563 :     let fun carm ((con,le)::tl) =
564 : monnier 81 if eqConV(con, v) then loop m le else carm tl
565 :     | carm [] = loop m (Option.valOf def)
566 : monnier 63 in carm arms
567 :     end
568 : monnier 81 | sv as (Fun _ | TFun _) =>
569 :     bugval("unexpected switch arg", sval2val sv))
570 : monnier 58
571 :     | F.CON (dc,tycs,v,lv,le) =>
572 : monnier 81 if used lv then
573 :     let val ndc = cdcon dc
574 :     val nv = ((substval v) handle x => raise x)
575 :     val nm = addbind(m, lv, Con(lv, nv, ndc))
576 :     val nle = loop nm le
577 :     in if used lv then F.CON(ndc, tycs, nv, lv, nle) else nle
578 :     end
579 :     else loop m le
580 : monnier 58
581 :     | F.RECORD (rk,vs,lv,le) =>
582 : monnier 81 (* Here I could try to see if I'm reconstructing a preexisting record.
583 :     * The `lty option' of Var is there just for that purpose *)
584 :     if used lv then
585 :     let val nvs = ((map substval vs) handle x => raise x)
586 :     val nm = addbind(m, lv, Record(lv, nvs))
587 :     val nle = loop nm le
588 :     in if used lv then F.RECORD(rk, nvs, lv, nle) else nle
589 :     end
590 :     else loop m le
591 : monnier 58
592 :     | F.SELECT (v,i,lv,le) =>
593 :     if used lv then
594 : monnier 81 case ((val2sval m v) handle x => raise x)
595 : monnier 58 of Record (lvr,vs) =>
596 : monnier 81 let val sv = (val2sval m (List.nth(vs, i))) handle x => raise x
597 :     in loop (substitute(m, lv, sv, F.VAR lvr)) le
598 :     end
599 : monnier 58 | sv =>
600 : monnier 81 let val nv = sval2val sv
601 :     val nm = addbind (m, lv, Select(lv, nv, i))
602 :     val nle = loop nm le
603 : monnier 58 in if used lv then F.SELECT(nv, i, lv, nle) else nle
604 : monnier 81 end
605 :     else loop m le
606 : monnier 58
607 : monnier 81 | F.RAISE (v,ltys) => F.RAISE((substval v) handle x => raise x, ltys)
608 : monnier 58
609 : monnier 81 | F.HANDLE (le,v) => F.HANDLE(loop m le, (substval v) handle x => raise x)
610 : monnier 58
611 :     | F.BRANCH (po,vs,le1,le2) =>
612 : monnier 81 let val nvs = ((map substval vs) handle x => raise x)
613 : monnier 63 val npo = cpo po
614 : monnier 81 val nle1 = loop m le1
615 :     val nle2 = loop m le2
616 :     in F.BRANCH(npo, nvs, nle1, nle2)
617 : monnier 63 end
618 : monnier 58
619 :     | F.PRIMOP (po,vs,lv,le) =>
620 : monnier 81 let val impure = impurePO po
621 :     in if impure orelse used lv then
622 :     let val nvs = ((map substval vs) handle x => raise x)
623 :     val npo = cpo po
624 :     val nm = addbind(m, lv, Var(lv,NONE))
625 :     val nle = loop nm le
626 :     in
627 :     if impure orelse used lv
628 :     then F.PRIMOP(npo, nvs, lv, nle)
629 :     else nle
630 :     end
631 :     else loop m le
632 : monnier 63 end
633 :     end
634 : monnier 58
635 :     fun contract (fdec as (_,f,_,_)) =
636 : monnier 81 (C.collect fdec;
637 :     if !Control.FLINT.print then
638 :     (PPFlint.LVarString := C.LVarString;
639 :     say "\n[Before FContract ...]\n\n";
640 :     PPFlint.printFundec fdec;
641 :     PPFlint.LVarString := LV.lvarName)
642 :     else ();
643 :     case cexp (DI.top,DI.top) M.empty (F.FIX([fdec], F.RET[F.VAR f]))
644 :     of F.FIX([fdec], F.RET[F.VAR f]) => fdec
645 :     | fdec => bug "invalid return fundec")
646 :    
647 : monnier 58 end
648 :     end

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