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

SCM Repository

[smlnj] Diff of /sml/trunk/src/compiler/FLINT/opt/fcontract.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 80, Wed Apr 29 23:25:33 1998 UTC revision 81, Sat May 2 23:59:45 1998 UTC
# Line 19  Line 19 
19  (* things that lcontract.sml does that fcontract doesn't do (yet):  (* things that lcontract.sml does that fcontract doesn't do (yet):
20   * - inline across DeBruijn depths   * - inline across DeBruijn depths
21   * - elimination of let [dead-vs] = pure in body   * - elimination of let [dead-vs] = pure in body
22   * - contraction of let [v] = branch in switch   * - contraction of `let [v] = branch in switch v'
23   *)   *)
24    
25  (* things that cpsopt/eta.sml did that fcontract doesn't do:  (* things that cpsopt/eta.sml did that fcontract doesn't do:
# Line 35  Line 35 
35   * - dropping of arguments   * - dropping of arguments
36   *)   *)
37    
38    (* 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  structure FContract :> FCONTRACT =  structure FContract :> FCONTRACT =
111  struct  struct
112  local  local
113      structure F  = FLINT      structure F  = FLINT
114      structure M  = Intmap      structure M  = IntmapF
115      structure C  = Collect      structure C  = Collect
116      structure DI = DebIndex      structure DI = DebIndex
117      structure PP = PPFlint      structure PP = PPFlint
118        structure LV = LambdaVar
119  in  in
120    
121  val say = Control.Print.say  val say = Control.Print.say
# Line 55  Line 128 
128  fun ASSERT (true,_) = ()  fun ASSERT (true,_) = ()
129    | ASSERT (FALSE,msg) = bug ("assertion "^msg^" failed")    | ASSERT (FALSE,msg) = bug ("assertion "^msg^" failed")
130    
131    (* 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  datatype sval  datatype sval
208    = Val    of F.value    = Val    of F.value                   (* F.value should never be F.VAR lv *)
209    | Fun    of F.lvar * F.lexp * (F.lvar * F.lty) list * F.fkind * DI.depth    | 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    | TFun   of F.lvar * F.lexp * (F.tvar * F.tkind) list * DI.depth
211    | Record of F.lvar * F.value list    | Record of F.lvar * F.value list
   | Select of F.lvar * F.value * int  
212    | Con    of F.lvar * F.value * F.dcon    | Con    of F.lvar * F.value * F.dcon
213      | Select of F.lvar * F.value * int
214      | Var    of F.lvar * F.lty option     (* cop out case *)
215    
216    fun cexp (cfg as (d,od)) m le = let
 (* this global map should really be replaced by a IntmapF that's passed  
  * around, as it was before, but there are some tricky issues *)  
 exception NotFound  
 val m : sval M.intmap = M.new(128, NotFound)  
   
 fun cexp (cfg as (d,od)) le = let  
217    
218      val loop = cexp cfg      val loop = cexp cfg
219    
# Line 85  Line 229 
229        | eqConV (F.STRINGcon s1, F.STRING s2)    = s1 = s2        | eqConV (F.STRINGcon s1, F.STRING s2)    = s1 = s2
230        | eqConV (con,v) = bugval("unexpected comparison with val", v)        | eqConV (con,v) = bugval("unexpected comparison with val", v)
231    
232      fun lookup lv = M.map m lv      fun lookup m lv = (M.lookup m lv)
233  (*                      handle e as NotFound => *)                            handle e as M.IntmapF =>
234  (*                      (say (concat ["\nlooking up unbound ", *)                            (say "\nlooking up unbound ";
235  (*                                    !PP.LVarString lv]); *)                             say (!PP.LVarString lv);
236  (*                       raise e) *)                             raise e)
237    
238      fun sval2val sv =      fun sval2val sv =
239          case sv          case sv
240           of (Fun{1=lv,...} | TFun{1=lv,...} | Record{1=lv,...}           of (Fun{1=lv,...} | TFun{1=lv,...} | Record{1=lv,...}
241            | Select{1=lv,...} | Con{1=lv,...}) => F.VAR lv            | Con{1=lv,...} | Select{1=lv,...} | Var{1=lv,...}) => F.VAR lv
242            | Val v => v            | Val v => v
243    
244      fun val2sval (F.VAR ov) = lookup ov      fun val2sval m (F.VAR ov) = ((lookup m ov) handle x => raise x)
245        | val2sval v = Val v        | val2sval m v = Val v
246    
247      fun bugsv (msg,sv) = bugval(msg, sval2val sv)      fun bugsv (msg,sv) = bugval(msg, sval2val sv)
248    
249      fun subst ov = sval2val (lookup ov)      fun subst m ov = sval2val ((lookup m ov) handle x => raise x)
250      val substval = sval2val o val2sval      val substval = sval2val o (val2sval m)
251      fun substvar lv =      fun substvar lv =
252          case substval (F.VAR lv)          case ((substval (F.VAR lv)) handle x => raise x)
253           of F.VAR lv => lv           of F.VAR lv => lv
254            | v => bugval ("unexpected val", v)            | v => bugval ("unexpected val", v)
255    
# Line 114  Line 258 
258    
259      (* called when a variable becomes dead.      (* called when a variable becomes dead.
260       * it simply adjusts the use-counts *)       * it simply adjusts the use-counts *)
261      fun undertake lv =      fun undertake m lv =
262          case lookup lv          let val undertake = undertake m
263           of Val (F.VAR nlv)     => ASSERT(nlv = lv, "nlv = lv")          in case lookup m lv
264            | Val v               => unuseval undertake v              of Var {1=nlv,...}   => ASSERT(nlv = lv, "nlv = lv")
265            | ( Fun {1=lv,2=le,...} | TFun{1=lv,2=le,...} ) =>               | Val v             => ()
266              C.inside lv (fn()=> C.unuselexp undertake le)               | Fun (lv,le,args,_,_) =>
267            | ( Select {2=v,...} | Con {2=v,...} ) =>                 C.unusefdec undertake (lv, map #1 args, le)
268              unuseval undertake v               | 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            | Record {2=vs,...}   => app (unuseval undertake) vs
   
     fun addbind (lv,sv) =  
         let fun eqsv (sv1,sv2) = (sval2val sv1) = (sval2val sv2)  
             fun correct (Val v) = true  
               | correct sv =  
                 let val F.VAR lv = sval2val sv  
                 in eqsv(sv, M.map m lv)  
                 end handle NotFound => true  
         in  ASSERT(correct sv, "addbind");  
             M.add m (lv, sv)  
271          end          end
272                    handle M.IntmapF =>
273      (* substitute a value sv for a variable lv and unuse value v *)                  (say "\nUnable to undertake "; PP.printSval(F.VAR lv))
274      fun substitute (lv1, sv, v) =                       | x =>
275                           (say "\nwhile undertaking "; PP.printSval(F.VAR lv); raise x)
276    
277        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          (case sval2val sv of F.VAR lv2 => C.transfer(lv1,lv2) | v2 => ();          (case sval2val sv of F.VAR lv2 => C.transfer(lv1,lv2) | v2 => ();
285           unuseval undertake v;           unuseval (undertake m) v;
286           addbind (lv1, sv))           addbind(m, lv1, sv)) handle x =>
287                 (say "\nwhile substituting ";
288      (* common code for all the lexps "let v = <op>[v1,...] in ..." *)                PP.printSval (F.VAR lv1);
289      fun clet1 (svcon,lecon) (lv,vs,le) =                say " for ";
290          if used lv then                PP.printSval (sval2val sv);
291              let val nvs = map substval vs                raise x)
                 val _ = addbind (lv, svcon(nvs))  
                 val nle = loop le  
             in if used lv then lecon(nvs, nle) else nle  
             end  
         else loop le  
292    
293      (* common code for primops *)      (* common code for primops *)
294      fun cpo (SOME{default,table},po,lty,tycs) =      fun cpo (SOME{default,table},po,lty,tycs) =
# Line 162  Line 301 
301          (s, Access.EXN(Access.LVAR(substvar lv)), lty)          (s, Access.EXN(Access.LVAR(substvar lv)), lty)
302        | cdcon dc = dc        | cdcon dc = dc
303    
304        (* 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  in  in
337      case le      case le
338       of F.RET vs => F.RET(map substval vs)       of F.RET vs => F.RET((map substval vs) handle x => raise x)
339    
340        | F.LET (lvs,le,body) =>        | F.LET (lvs,le,body) =>
341          let fun clet' le = (* default rule for `clet' *)          let fun cassoc le = F.LET(lvs, le, body)
342                  (app (fn lv => addbind (lv, Val(F.VAR lv))) lvs;              fun simplesubst ((lv,v),m) =
343                   case loop body                  let val sv = (val2sval m v) handle x => raise x
344                    of F.RET vs => if vs = (map F.VAR lvs) then le                  in substitute(m, lv, sv, sval2val sv)
345                                   else F.LET(lvs, le, F.RET vs)                  end
346                     | nbody => F.LET(lvs, le, nbody))              (* default behavior *)
347                fun clet () =
348              (* the case for LET should be improved.                  let val nle = loop m le
349               * Proper treatment of BRANCH should be possible once the real                      val nm = foldl (fn (lv,m) => addbind(m, lv, Var(lv, NONE)))
350               * inlining support is added *)                                     m lvs
351              fun clet (F.LET(lvs1,le1,le2)) = F.LET(lvs1, le1, clet le2)                  in case loop nm body
352                (* let associativity                      of F.RET vs => if vs = (map F.VAR lvs) then nle
353                 * !!BEWARE!! applying the associativity rule might                                     else F.LET(lvs, nle, F.RET vs)
354                 * change the liveness of the bound variables *)                       | nbody => F.LET(lvs, nle, nbody)
355                | clet (F.FIX(fdecs,le)) =                  end
356                  let val nbody = clet le              val lopm = loop m
357                      val nfdecs = List.filter (used o #2) fdecs          in case le
358                  in if null nfdecs then nbody else F.FIX(nfdecs, nbody)              (* apply let associativity  *)
359                  end              of F.LET(lvs1,le',le) => lopm(F.LET(lvs1, le', cassoc le))
360                | clet (F.TFN(tfdec,le)) =               | F.FIX(fdecs,le) => lopm(F.FIX(fdecs, cassoc le))
361                  let val nbody = clet le               | F.TFN(tfdec,le) => lopm(F.TFN(tfdec, cassoc le))
362                  in if used (#1 tfdec) then F.TFN(tfdec, nbody) else nbody               | F.CON(dc,tycs,v,lv,le) => lopm(F.CON(dc, tycs, v, lv, cassoc le))
363                  end               | F.RECORD(rk,vs,lv,le) => lopm(F.RECORD(rk, vs, lv, cassoc le))
364                | clet (F.CON(dc,tycs,v,lv,le)) =               | F.SELECT(v,i,lv,le) => lopm(F.SELECT(v, i, lv, cassoc le))
365                  let val nbody = clet le               | F.PRIMOP(po,vs,lv,le) => lopm(F.PRIMOP(po, vs, lv, cassoc le))
366                  in if used lv then F.CON(dc, tycs, v, lv, nbody) else nbody               (* this is a hack originally meant to cleanup the BRANCH mess
367                  end                * introduced in flintnm (where each branch returns just true or
368                | clet (F.RECORD(rk,vs,lv,le)) =                * false which is generally only used as input to a SWITCH.
369                  let val nbody = clet le                * The present code does more than clean up this case (mostly
370                  in if used lv then F.RECORD(rk, vs, lv, nbody) else nbody                * out of lazyness and also because it's very ad-hoc) but the
371                  end                * added generality leads to potential uncontrolled exponential
372                | clet (F.SELECT(v,i,lv,le)) =                * code blowup (and with very little improvement anywhere).
373                  let val nbody = clet le                * In clear, it's probably not a good idea. *)
374                  in if used lv then F.SELECT(v, i, lv, nbody) else nbody               | F.BRANCH (po,vs,le1,le2) => clet()
375                  end  (*             let fun cassoc (lv,v,body) wrap =  *)
376                | clet (F.PRIMOP(po,vs,lv,le)) =  (*                     if lv = v andalso C.usenb lv = 1 then *)
377                  let val nbody = clet le  (*                         let val nle1 = F.LET([lv], le1, body) *)
378                  in if impurePO po orelse used lv  (*                             val nlv = LV.mkLvar() *)
379                     then F.PRIMOP(po, vs, lv, nbody)  (*                             val body2 = copy (M.add(M.empty,lv,nlv)) body *)
380                     else nbody  (*                             val nle2 = F.LET([nlv], le2, body2) *)
381                  end  (*                         in C.new false nlv; C.uselexp body2; *)
382    (*                             lopm(wrap(F.BRANCH(po, vs, nle1, nle2))) *)
383                (* | clet (le as F.BRANCH(po,vs,le1,le2)) =  (*                         end *)
384                 *   (case (lvs,body)  (*                     else *)
385                 *     of ([lv],F.SWITCH(F.VAR v,_,_,_)) =>  (*                         clet() *)
386                 *        if lv = v andalso C.usenb lv = 1 then  (*             in case (lvs,body) *)
387                 *            F.BRANCH(po,vs,clet le1, clet le2)  (*                 of ([lv],le as F.SWITCH(F.VAR v,_,_,_)) => *)
388                 *        else  (*                    cassoc(lv, v, le) (fn x => x) *)
389                 *            clet' le  (*                  | ([lv],F.LET(lvs,le as F.SWITCH(F.VAR v,_,_,_),rest)) => *)
390                 *      | _ => clet' le) *)  (*                    cassoc(lv, v, le) (fn le => F.LET(lvs,le,rest)) *)
391    (*                  | _ => clet() *)
392                (* F.RAISE never returns so the body of the let could be  (*             end *)
393                 * dropped on the floor, but since I don't propagate               | F.RET vs =>
394                 * types I can't come up with the right return type                  ((loop (foldl simplesubst m (ListPair.zip(lvs, vs))) body)
395                 *  | F.RAISE(v,ltys) =>                       handle x => raise x)
396                 *    (C.unuselexp undertake body;               | F.APP(f,vs) =>
397                 *     F.RAISE(v, ?????)) *)                 (case inline(f, vs)
398                | clet (F.RET vs) =                   of SOME(le,od) => cexp (d,od) m (F.LET(lvs, le, body))
399                  (* LET[lvs] = RET[vs] is replaced by substitutions *)                    | NONE => clet())
400                  (app (fn (lv,v) => substitute (lv, val2sval v, v))               | (F.TAPP _ | F.SWITCH _ | F.RAISE _ | F.HANDLE _) =>
401                       (ListPair.zip(lvs, vs));                 clet()
                      loop body)  
               | clet le = clet' le  
         in  
             clet (loop le)  
402          end          end
403    
404        | F.FIX (fs,le) =>        | F.FIX (fs,le) =>
405          let fun cfun [] acc = rev acc          let fun cfun (m,[]:F.fundec list,acc) = acc
406                | cfun (fdec as (fk,f,args,body)::fs) acc =                | cfun (m,fdec as (fk,f,args,body)::fs,acc) =
407                  if used f then                  if used f then
408                      let (* make up the bindings for args inside the body *)                      let (* make up the bindings for args inside the body *)
409                          val _ = app (fn lv => addbind (lv, Val(F.VAR lv)))                          fun addnobind ((lv,lty),m) =
410                                      (map #1 args)                              addbind(m, lv, Var(lv, SOME lty))
411                            val nm = foldl addnobind m args
412                          (* contract the body and create the resulting fundec *)                          (* contract the body and create the resulting fundec *)
413                          val nbody = C.inside f (fn()=> loop body)                          val nbody = C.inside f (fn()=> loop nm body)
414                          val nsv = Fun(f, nbody, args, fk, od)                          (* fixup the fkind info with new data.
415                             * C.recursive only tells us if a fun is self-recursive
416                          (* update the subst with the new code.                           * but doesn't deal with mutual recursion.
417                           * We also do eta-reduction here *)                           * Also the `inline' bit has to be turned off because
418                          val nacc =                           * it applied to the function before contraction
419                              case nbody                           * but might not apply to its new form (inlining might
420                               of F.APP(F.VAR g,vs) =>                           * have increased its size substantially or made it
421                                  (* NOTE: an eta-reduction can potentially                           * recursive in a different way which could make further
422                                   * have the nasty side effect of turning                           * inlining even dangerous) *)
423                                   * a known fun into an escaping one *)                          val nfk =
424                                  if not (C.escaping f andalso                              case fk of F.FK_FCT => fk
425                                          not (C.escaping g)) andalso                                | F.FK_FUN {isrec,fixed,known,inline} =>
426                                      vs = (map (F.VAR o #1) args)                                  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                        end
444                    else cfun(m, fs, acc)
445    
446                (* 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                                  then
453                                      if false andalso null acc then                      let val svg = val2sval m g
454                                          let val g = F.VAR g                          val g = case sval2val svg
455                                          in (substitute (f, val2sval g, g); acc)                                   of F.VAR g => g
456                                          end                                    | v => bugval("not a variable", v)
457                                      else                      (* NOTE: we don't want to turn a known function into an
458                                          (* the function might have already                       * escaping one.  It's dangerous for optimisations based
459                                           * appeared in the previous fundecs                       * on known functions (elimination of dead args, f.ex)
460                                           * so we don't do the eta-reduction just                       * and could generate cases where call>use in collect *)
461                                           * now, but instead we move the function                      in if not (C.escaping f andalso
462                                           * to the head of the list so that it                                 not (C.escaping g))
463                                           * will be eta-reduced next time                         then let
464                                           * we go through fcontract *)                             (* if an earlier function h has been eta-reduced
465                                          (addbind (f, nsv);                              * to f, we have to be careful to update its
466                                           acc @ [(fk, f, args, nbody)])                              * binding to not refer to f any more since f
467                                  else                              * will disappear *)
468                                      (addbind (f, nsv);                             val nm = foldl (fn (h,m) =>
469                                       (fk, f, args, nbody)::acc)                                             if sval2val(lookup m h) = F.VAR f
470                                | _ => (addbind (f, nsv);                                             then addbind(m, h, svg) else m)
471                                        (fk, f, args, nbody)::acc)                                            m hs
472                      in cfun fs nacc                         in
473                      end                             (* if g is one of the members of the FIX, f might
474                  else cfun fs acc                              * appear in its body, so we don't know what parts
475                                * of the counts of f should be counted as inside
476              (* register the new bindings. We register them                              * g and what parts should be counted as outside
477               * uncontracted first, for the needs of mutual recursion,                              * so we take the conservative approach of counting
478               * and then we replace the contracted versions as they                              * them in both *)
479               * become available *)                             if isSome(List.find (fn (_,f,_,_) => f = g) fs)
480              val _ = app (fn fdec as (fk,f,args,body) =>                             then C.inside g (fn()=> C.addto(f,g)) else ();
481                           addbind (f, Fun(f, body, args, fk, od)))                             C.transfer(f,g); C.unuse (undertake nm) true g;
482                          fs                             (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              (* contract the main body *)              (* junk unused funs *)
490              val nle = loop le              val fs = List.filter (used o #2) fs
491    
492              (* contract the functions *)              (* register the new bindings (uncontracted for now) *)
493              val fs = cfun fs []              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                (* contract the main body *)
506                val nle = loop nm le
507                (* contract the functions *)
508                val fs = cfun(nm, fs, [])
509              (* junk newly unused funs *)              (* junk newly unused funs *)
510              val fs = List.filter (used o #2) fs              val fs = List.filter (used o #2) fs
511          in          in
512              if List.null fs              if List.null fs then nle else F.FIX(fs,nle)
             then nle  
             else F.FIX(fs,nle)  
513          end          end
514    
515        | F.APP (f,vs) =>        | F.APP (f,vs) =>
516          let val nvs = map substval vs          let val nvs = ((map substval vs) handle x => raise x)
517          in case val2sval f          in case inline(f, nvs)
518              of Fun(g,body,args,fk,od) =>              of SOME(le,od) => cexp (d,od) m le
519                 (ASSERT(C.usenb g > 0, "C.usenb g > 0");               | NONE => F.APP((substval f) handle x => raise x, nvs)
                 if C.usenb g = 1 andalso od = d andalso not (C.recursive g)  
   
                 (* simple inlining:  we should copy the body and then  
                  * kill the function, but instead we keep the body  
                  * and kill only the function name *)  
                 then (C.unuse (fn lv => ()) true g;  
                       cexp (d,od) (F.LET(map #1 args, F.RET nvs, body)))  
   
                 (* no inlining: just substitute the vars and vals *)  
                 else F.APP(F.VAR g, nvs))  
   
              | sv => F.APP(sval2val sv, nvs)  
520          end          end
521    
522        | F.TFN ((f,args,body),le) =>        | F.TFN ((f,args,body),le) =>
523          if used f then          if used f then
524              let (* val _ = addbind (f, TFun(f, body, args, od)) *)              let val nbody = cexp (DI.next d, DI.next od) m body
525                  val nbody = cexp (DI.next d, DI.next od) body                  val nm = addbind(m, f, TFun(f, nbody, args, od))
526                  val _ = addbind (f, TFun(f, nbody, args, od))                  val nle = loop nm le
                 val nle = loop le  
527              in              in
528                  if used f                  if used f then F.TFN((f, args, nbody), nle) else nle
                 then F.TFN((f, args, nbody), nle)  
                 else nle  
529              end              end
530          else loop le          else loop m le
531    
532        | F.TAPP(f,tycs) => F.TAPP(substval f, tycs)        | F.TAPP(f,tycs) => F.TAPP((substval f) handle x => raise x, tycs)
533    
534        | F.SWITCH (v,ac,arms,def) =>        | F.SWITCH (v,ac,arms,def) =>
535          (case val2sval v          (case ((val2sval m v) handle x => raise x)
536            of sv as (Val(F.VAR lv) | Select(lv,_,_)) =>            of sv as (Var{1=lvc,...} | Select{1=lvc,...} | Record{1=lvc,...}) =>
537               (let fun carm (F.DATAcon(dc,tycs,lv),le) =               let fun carm (F.DATAcon(dc,tycs,lv),le) =
538                        (addbind(lv, Val(F.VAR lv));                        let val ndc = cdcon dc
539                         (* here I should also temporarily bind sv to                            (* here I should try to extract the type of lv *)
540                          * the corresponding Con *)                            val nm = addbind(m, lv, Var(lv, NONE))
541                         (F.DATAcon(cdcon dc, tycs, lv), loop le))                            (* we can rebind lv to a more precise value *)
542                      | carm (con,le) = (con, loop le)                            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                    val narms = map carm arms                    val narms = map carm arms
547                    val ndef = Option.map loop def                    val ndef = Option.map (loop m) def
548               in               in
549                    F.SWITCH(sval2val sv, ac, narms, ndef)                    F.SWITCH(sval2val sv, ac, narms, ndef)
550               end handle x => raise x)               end
551    
552             | Con (lvc,v,(_,conrep,_)) =>             | Con (lvc,v,(_,conrep,_)) =>
553               let fun carm ((F.DATAcon((_,crep,_),tycs,lv),le)::tl) =               let fun carm ((F.DATAcon((_,crep,_),tycs,lv),le)::tl) =
554                       if crep = conrep then                       if crep = conrep then
555                           (substitute(lv, val2sval v, F.VAR lvc);                           loop (substitute(m, lv, (val2sval m v) handle x => raise x, F.VAR lvc)) le
                           loop le)  
556                       else carm tl                       else carm tl
557                     | carm [] = loop (Option.valOf def)                     | carm [] = loop m (Option.valOf def)
558                     | carm _ = buglexp("unexpected arm in switch(con,...)", le)                     | carm _ = buglexp("unexpected arm in switch(con,...)", le)
559               in carm arms               in carm arms
560               end               end
561    
562             | Val v =>             | Val v =>
563               let fun carm ((con,le)::tl) =               let fun carm ((con,le)::tl) =
564                       if eqConV(con, v) then loop le else carm tl                       if eqConV(con, v) then loop m le else carm tl
565                     | carm [] = loop(Option.valOf def)                     | carm [] = loop m (Option.valOf def)
566               in carm arms               in carm arms
567               end               end
568             | sv => bugval("unexpected switch argument", sval2val sv))             | sv as (Fun _ | TFun _) =>
569                 bugval("unexpected switch arg", sval2val sv))
570    
571        | F.CON (dc,tycs,v,lv,le) =>        | F.CON (dc,tycs,v,lv,le) =>
572            if used lv then
573          let val ndc = cdcon dc          let val ndc = cdcon dc
574          in clet1 (fn [nv] => Con(lv, nv, ndc),                  val nv = ((substval v) handle x => raise x)
575                    fn ([nv],nle) => F.CON(ndc, tycs, nv, lv, nle))                  val nm = addbind(m, lv, Con(lv, nv, ndc))
576                   (lv,[v],le)                  val nle = loop nm le
577                in if used lv then F.CON(ndc, tycs, nv, lv, nle) else nle
578          end          end
579            else loop m le
580    
581        | F.RECORD (rk,vs,lv,le) =>        | F.RECORD (rk,vs,lv,le) =>
582          clet1 (fn nvs => Record(lv, nvs),          (* Here I could try to see if I'm reconstructing a preexisting record.
583                 fn (nvs,nle) => F.RECORD(rk, nvs, lv, nle))           * The `lty option' of Var is there just for that purpose *)
584                (lv,vs,le)          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    
592        | F.SELECT (v,i,lv,le) =>        | F.SELECT (v,i,lv,le) =>
593          if used lv then          if used lv then
594              case val2sval v              case ((val2sval m v) handle x => raise x)
595               of Record (lvr,vs) =>               of Record (lvr,vs) =>
596                  (let val sv = val2sval (List.nth(vs, i))                  let val sv = (val2sval m (List.nth(vs, i))) handle x => raise x
597                  in substitute (lv, sv, F.VAR lvr);                  in loop (substitute(m, lv, sv, F.VAR lvr)) le
598                       loop le                  end
                 end handle x => raise x)  
599                | sv =>                | sv =>
600                  (let val nv = sval2val sv                  let val nv = sval2val sv
601                      val _ = addbind (lv, Select(lv, nv, i))                      val nm = addbind (m, lv, Select(lv, nv, i))
602                      val nle = loop le                      val nle = loop nm le
603                  in if used lv then F.SELECT(nv, i, lv, nle) else nle                  in if used lv then F.SELECT(nv, i, lv, nle) else nle
604                  end handle x => raise x)                  end
605          else loop le          else loop m le
606    
607        | F.RAISE (v,ltys) => F.RAISE(substval v, ltys)        | F.RAISE (v,ltys) => F.RAISE((substval v) handle x => raise x, ltys)
608    
609        | F.HANDLE (le,v) => F.HANDLE(loop le, substval v)        | F.HANDLE (le,v) => F.HANDLE(loop m le, (substval v) handle x => raise x)
610    
611        | F.BRANCH (po,vs,le1,le2) =>        | F.BRANCH (po,vs,le1,le2) =>
612          let val nvs = map substval vs          let val nvs = ((map substval vs) handle x => raise x)
613              val npo = cpo po              val npo = cpo po
614              val nle1 = loop le1              val nle1 = loop m le1
615              val nle2 = loop le2              val nle2 = loop m le2
616          in F.BRANCH(npo, nvs, nle1, le2)          in F.BRANCH(npo, nvs, nle1, nle2)
617          end          end
618    
619        | F.PRIMOP (po,vs,lv,le) =>        | F.PRIMOP (po,vs,lv,le) =>
620          let val nvs = map substval vs          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              val npo = cpo po
624              val _ = addbind(lv, Val(F.VAR lv))                  val nm = addbind(m, lv, Var(lv,NONE))
625              val nle = loop le                  val nle = loop nm le
626          in if impurePO po orelse used lv              in
627                    if impure orelse used lv
628             then F.PRIMOP(npo, nvs, lv, nle)             then F.PRIMOP(npo, nvs, lv, nle)
629             else nle             else nle
630          end          end
631               else loop m le
632            end
633  end  end
634    
635  fun contract (fdec as (_,f,_,_)) =  fun contract (fdec as (_,f,_,_)) =
636      let val _ = M.clear m      (C.collect fdec;
637          val F.FIX([fdec], F.RET[F.VAR f]) =       if !Control.FLINT.print then
638              cexp (DI.top,DI.top) (F.FIX([fdec], F.RET[F.VAR f]))           (PPFlint.LVarString := C.LVarString;
639          val _ = M.clear m            say "\n[Before FContract ...]\n\n";
640      in fdec            PPFlint.printFundec fdec;
641      end            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  end  end
648  end  end

Legend:
Removed from v.80  
changed lines
  Added in v.81

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