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

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

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

revision 201, Sat Nov 28 23:32:48 1998 UTC revision 202, Sun Dec 13 02:29:45 1998 UTC
# Line 51  Line 51 
51  end  end
52  structure SCC = SCCUtilFun (structure Node = SccNode)  structure SCC = SCCUtilFun (structure Node = SccNode)
53    
54  (* fexp: (intset * lexp) -> (int * intset * lexp)  (* fexp: int ref intmapf -> lexp) -> (int * intset * lexp)
55     * The intmap contains refs to counters.  The meaning of the counters
56     * is slightly overloaded:
57     * - if the counter is negative, it means the lvar
58     *   is a locally known function and the counter's absolute value denotes
59     *   the number of calls (off by one to make sure it's always negative).
60     * - else, it indicates that the lvar is a
61     *   function argument and the absolute value is a (fuzzily defined) measure
62     *   of the reduction in code size/speed that would result from knowing
63     *   its value (might be used to decide whether or not duplicating code is
64     *   desirable at a specific call site).
65   * The three subparts returned are:   * The three subparts returned are:
66   * - the size of lexp   * - the size of lexp
67   * - the set of freevariables of lexp (plus the ones passed as arguments   * - the set of freevariables of lexp (plus the ones passed as arguments
68   *   which are assumed to be the freevars of the continuation of lexp)   *   which are assumed to be the freevars of the continuation of lexp)
69   * - a new lexp with FIXes rewritten.   * - a new lexp with FIXes rewritten.
70   *)   *)
71  fun fexp (fv,lexp) = let  fun fexp mf lexp = let
72    
73        val loop = fexp mf
74    
75        fun lookup (F.VAR lv) = M.lookup mf lv
76          | lookup _ = raise M.IntmapF
77    
78      fun addv (s,F.VAR lv) = S.add(lv, s)      fun addv (s,F.VAR lv) = S.add(lv, s)
79        | addv (s,_) = s        | addv (s,_) = s
# Line 162  Line 177 
177        | uncurry (_,body) = bug "uncurrying a non-curried function"        | uncurry (_,body) = bug "uncurrying a non-curried function"
178    
179  in case lexp  in case lexp
180      of F.RET vs => (0, addvs(fv, vs), lexp)      of F.RET vs => (0, addvs(S.empty, vs), lexp)
181       | F.LET (lvs,le1,le2) =>       | F.LET (lvs,body,le) =>
182         let val (s2,fv,le2) = fexp(fv, le2)         let val (s2,fvl,nle) = loop le
183             val (s1,fv,le1) = fexp(rmvs(fv, lvs), le1)             val (s1,fvb,nbody) = loop body
184         in (s1 + s2, fv, F.LET(lvs, le1, le2))         in (s1 + s2, S.union(rmvs(fvl, lvs), fvb), F.LET(lvs, nbody, nle))
185         end         end
186       | F.FIX (fdecs,le) =>       | F.FIX (fdecs,le) =>
187         let val funs = S.make(map #2 fdecs) (* set of funs defined by the FIX *)         let val funs = S.make(map #2 fdecs) (* set of funs defined by the FIX *)
188    
189             (* process the main lexp and make it into a dummy function.             (* create call-counters for each fun and add them to fm *)
190              * The computation of the freevars is a little sloppy since `fv'             val (fs,mf) = foldl (fn ((fk,f,args,body),(fs,mf)) =>
191              * includes freevars of the continuation, but the uniqueness                                  let val c = ref ~1
192              * of varnames ensures that S.inter(fv, funs) gives the correct                                  in ((fk,f,args,body,c)::fs, M.add(mf, f, ref 0))
193              * result nonetheless. *)                                  end)
194             val (s,fv,le) = fexp(fv, le)                                 ([],mf)
195             val lename = LambdaVar.mkLvar()                                 fdecs
            val m = M.singleton(lename, (S.members(S.inter(fv, funs)), 0,  
                                         {inline=F.IH_SAFE, isrec=NONE,  
                                          known=true,cconv=F.CC_FCT},  
                                         [], le))  
196    
197             (* process each fun *)             (* process each fun *)
198             fun ffun (fdec as (fk as {isrec,...},f,args,body):F.fundec,             fun ffun (fdec as (fk as {isrec,...}:F.fkind,f,args,body,cf),
199                       (s,fv,funs,m)) =                       (s,fv,funs,m)) =
200                 case curry (true,false,!maxargs) (F.FIX([fdec], F.RET[F.VAR f]))                 case curry (true,false,!maxargs)
201                              (F.FIX([(fk,f,args,body)], F.RET[F.VAR f]))
202                  of (args as _::_::_,body) => (* curried function *)                  of (args as _::_::_,body) => (* curried function *)
203                     let val ((fk,f,fargs,fbody),(fk',f',fargs',fbody')) =                     let val ((fk,f,fargs,fbody),(fk',f',fargs',fbody')) =
204                             uncurry(args,body)                             uncurry(args,body)
205                         (* add the wrapper function *)                         (* add the wrapper function *)
206                         val nm = M.add(m, f, ([f'], 1, fk, fargs, fbody))                         val cs = map (fn _ => ref 0) fargs
207                           val nm = M.add(m, f, ([f'], 1, fk, fargs, fbody, cf, cs))
208                     (* now, retry ffun with the uncurried function *)                     (* now, retry ffun with the uncurried function *)
209                     in ffun((fk', f', fargs', fbody'),                     in ffun((fk', f', fargs', fbody', ref 1),
210                             (s+1, fv, S.add(f', funs), nm))                             (s+1, fv, S.add(f', funs), nm))
211                     end                     end
212                   | _ => (* non-curried function *)                   | _ => (* non-curried function *)
213                     let val (fs,ffv,body) = fexp(S.empty, body)                     let val (mf,cs) = foldr (fn ((v,t),(m,cs)) =>
214                                                let val c = ref 0
215                                                in (M.add(m, v, c), c::cs) end)
216                                               (mf,[]) args
217                           val (fs,ffv,body) = fexp mf body
218                         val ffv = rmvs(ffv, map #1 args) (* fun's freevars *)                         val ffv = rmvs(ffv, map #1 args) (* fun's freevars *)
219                         val ifv = S.inter(ffv, funs) (* set of rec funs ref'ed *)                         val ifv = S.inter(ffv, funs) (* set of rec funs ref'ed *)
220                         val fs = fs div (case isrec of SOME(_,F.LK_TAIL) => 3                         val fs = fs div (case isrec of SOME(_,F.LK_TAIL) => 3
# Line 205  Line 222 
222                                                      | _ => 1)                                                      | _ => 1)
223                     in                     in
224                         (fs + s, S.union(ffv, fv), funs,                         (fs + s, S.union(ffv, fv), funs,
225                          M.add(m, f, (S.members ifv, fs, fk, args, body)))                          M.add(m, f, (S.members ifv, fs, fk, args, body, cf, cs)))
226                     end                     end
227    
228               (* process the main lexp and make it into a dummy function.
229                * The computation of the freevars is a little sloppy since `fv'
230                * includes freevars of the continuation, but the uniqueness
231                * of varnames ensures that S.inter(fv, funs) gives the correct
232                * result nonetheless. *)
233               val (s,fv,le) = fexp mf le
234               val lename = LambdaVar.mkLvar()
235               val m = M.singleton(lename, (S.members(S.inter(fv, funs)), 0,
236                                            {inline=F.IH_SAFE, isrec=NONE,
237                                             known=true,cconv=F.CC_FCT},
238                                            [], le, ref 0, []))
239    
240             (* process the functions, collecting them in map m *)             (* process the functions, collecting them in map m *)
241             val (s,fv,funs,m) = foldl ffun (s, fv, funs, m) fdecs             val (s,fv,funs,m) = foldl ffun (s, fv, funs, m) fs
242    
243             (* find strongly connected components *)             (* find strongly connected components *)
244             val top = SCC.topOrder{root=lename, follow= #1 o (M.lookup m)}             val top = SCC.topOrder{root=lename, follow= #1 o (M.lookup m)}
245    
246             (* turns them back into flint code *)             (* turns them back into flint code *)
247             fun sccconvert (SCC.SIMPLE f,le) =             fun sccSimple f (_,s,{isrec,cconv,known,inline},args,body,cf,cs) =
248                 (* a simple function.  Fix the fk accordingly *)                 let (* small functions inlining heuristic *)
249                 let val (_,s,{isrec,cconv,known,inline},args,body) = M.lookup m f                     val ilthreshold = !CTRL.inlineThreshold + (length args)
250                     val fk =                     val ilh =
251                         (* small functions inlining heuristic *)                         if inline = F.IH_ALWAYS then inline
252                         let val inline' =                         else if s < ilthreshold then F.IH_ALWAYS
253                                 if inline = F.IH_SAFE andalso                         else let val cs = map (op!) cs
254                                     s < !CTRL.inlineThreshold then                                  val s' = foldl (op+) 0 cs
255                                     F.IH_ALWAYS                         in if s < 2*s' + ilthreshold
256                              then ((* say((Collect.LVarString f)^" = F.IH_MAYBE "^(Int.toString (s-ilthreshold))^(foldl (fn (i,s) => s^" "^(Int.toString i)) "" cs)^"\n"); *)
257                                    F.IH_MAYBE (s-ilthreshold, cs))
258                                 else inline                                 else inline
                        in {isrec=NONE, inline=inline',  
                            known=known, cconv=cconv}  
259                         end                         end
260                 in F.FIX([(fk, f, args, body)], le)                     val fk = {isrec=NONE, inline=ilh, known=known, cconv=cconv}
261                   in (fk, f, args, body)
262                 end                 end
263               | sccconvert (SCC.RECURSIVE fs,le) =             fun sccRec f (_,s,fk as {isrec,cconv,known,inline},args,body,cf,cs) =
264                 let fun scfun f =                 let val fk' =
                        let val (_,s,fk as {isrec,cconv,known,inline},args,le) =  
                                M.lookup m f  
                            val fk' =  
265                                 (* let's check for unroll opportunities.                                 (* let's check for unroll opportunities.
266                                  * This heuristic is pretty bad since it doesn't                                  * This heuristic is pretty bad since it doesn't
267                                  * take the number of rec-calls into account *)                                  * take the number of rec-calls into account *)
# Line 245  Line 272 
272                                          cconv=cconv, known=known}                                          cconv=cconv, known=known}
273                                     else fk                                     else fk
274                                   | _ => fk                                   | _ => fk
275                         in (fk, f, args, le) end                 in (fk, f, args, body)
                in F.FIX(map scfun fs, le)  
276                 end                 end
277               fun sccconvert (SCC.SIMPLE f,le) =
278                   F.FIX([sccSimple f (M.lookup m f)], le)
279                 | sccconvert (SCC.RECURSIVE fs,le) =
280                   F.FIX(map (fn f => sccRec f (M.lookup m f)) fs, le)
281         in         in
282             case top             case top
283              of (SCC.SIMPLE f)::sccs =>              of (SCC.SIMPLE f)::sccs =>
# Line 256  Line 286 
286               | (SCC.RECURSIVE _)::_ => bug "recursive main body in SCC ?!?!?"               | (SCC.RECURSIVE _)::_ => bug "recursive main body in SCC ?!?!?"
287               | [] => bug "SCC going crazy"               | [] => bug "SCC going crazy"
288         end         end
289       | F.APP (f,args) =>       | F.APP (F.VAR f,args) =>
290         (* the cost of a function call depends on the number of args         (* For known functions, increase the counter and
291          * and the size of the continuation (number of free vars).          * make the call a bit cheaper. *)
292          * We could also ask Collect whether f is known *)         let val scall =
293         (3 + (length args) + (S.size fv), addvs(fv, f::args), lexp)                 (let val cf as ref c = M.lookup mf f
294                   in if c < 0
295                      then (cf := c - 1; 1)
296                      else (cf := c + 5; 5)
297                   end) handle M.IntmapF => 5
298           in
299               (scall + (length args), addvs(S.singleton f, args), lexp)
300           end
301       | F.TFN ((f,args,body),le) =>       | F.TFN ((f,args,body),le) =>
302         let val (se,fve,le) = fexp(fv, le)         let val (se,fve,le) = loop le
303             val (sb,fvb,body) = fexp(S.empty, body)             val (sb,fvb,body) = loop body
304         in (sb + se, S.union(S.rmv(f, fve), fvb), F.TFN((f, args, body), le))         in (sb + se, S.union(S.rmv(f, fve), fvb), F.TFN((f, args, body), le))
305         end         end
306       | F.TAPP (f,args) =>       | F.TAPP (F.VAR f,args) =>
307         (* The cost of TAPP is kinda hard to estimate.  It can be very cheap,         (* The cost of TAPP is kinda hard to estimate.  It can be very cheap,
308          * and just return a function, or it might do all kinds of wrapping          * and just return a function, or it might do all kinds of wrapping
309          * but we have almost no information on which to base our choice.          * but we have almost no information on which to base our choice.
310          * We opted for cheap here, to try to inline them more (they might          * We opted for cheap here, to try to inline them more (they might
311          * become cheaper once inlined) *)          * become cheaper once inlined) *)
312         (3, addv(fv, f), lexp)         (3, S.singleton f, lexp)
313       | F.SWITCH (v,ac,arms,def) =>       | F.SWITCH (v,ac,arms,def) =>
314         let fun farm (dcon as F.DATAcon(dc,_,lv),le) =         let fun farm (dcon as F.DATAcon(dc,_,lv),le) =
315                 (* the binding might end up costly, but we count it as 1 *)                 (* the binding might end up costly, but we count it as 1 *)
316                 let val (s,fv,le) = fexp(fv,le)                 let val (s,fv,le) = loop le
317                 in (1+s, fdcon(S.rmv(lv, fv),dc), (dcon, le))                 in (1+s, fdcon(S.rmv(lv, fv),dc), (dcon, le))
318                 end                 end
319               | farm (dc,le) =               | farm (dc,le) =
320                 let val (s,fv,le) = fexp(fv, le) in (s, fv, (dc, le)) end                 let val (s,fv,le) = loop le in (s, fv, (dc, le)) end
321             val (s,fv,arms) =             val (s,smax,fv,arms) =
322                 foldl (fn ((s1,fv1,arm),(s2,fv2,arms)) =>                 foldl (fn ((s1,fv1,arm),(s2,smax,fv2,arms)) =>
323                        (s1+s2, S.union(fv1, fv2), arm::arms))                        (s1+s2, Int.max(s1,smax), S.union(fv1, fv2), arm::arms))
324                       (0, fv, []) (map farm arms)                       (0, 0, S.empty, []) (map farm arms)
325         in case def         in  let val cf = lookup v in cf := !cf+s-smax end handle M.IntmapF=>();
326               case def
327             of NONE => (s, fv, F.SWITCH(v, ac, arms, NONE))             of NONE => (s, fv, F.SWITCH(v, ac, arms, NONE))
328              | SOME le => let val (sd,fvd,le) = fexp(fv,le)              | SOME le => let val (sd,fvd,le) = loop le
329                in (s+sd, S.union(fv, fvd), F.SWITCH(v, ac, arms, SOME le))                in (s+sd, S.union(fv, fvd), F.SWITCH(v, ac, arms, SOME le))
330                end                end
331         end         end
332       | F.CON (dc,tycs,v,lv,le) =>       | F.CON (dc,tycs,v,lv,le) =>
333         let val (s,fv,le) = fexp(fv, le)         let val (s,fv,le) = loop le
334         in (2+s, fdcon(addv(S.rmv(lv, fv), v),dc), F.CON(dc, tycs, v, lv, le))         in (2+s, fdcon(addv(S.rmv(lv, fv), v),dc), F.CON(dc, tycs, v, lv, le))
335         end         end
336       | F.RECORD (rk,vs,lv,le) =>       | F.RECORD (rk,vs,lv,le) =>
337         let val (s,fv,le) = fexp(fv, le)         let val (s,fv,le) = loop le
338         in ((length vs)+s, addvs(S.rmv(lv, fv), vs), F.RECORD(rk, vs, lv, le))         in ((length vs)+s, addvs(S.rmv(lv, fv), vs), F.RECORD(rk, vs, lv, le))
339         end         end
340       | F.SELECT (v,i,lv,le) =>       | F.SELECT (v,i,lv,le) =>
341         let val (s,fv,le) = fexp(fv, le)         let val (s,fv,le) = loop le
342         in (1+s, addv(S.rmv(lv, fv), v), F.SELECT(v,i,lv,le))         in let val cf = lookup v in cf := !cf + 1 end handle M.IntmapF=>();
343               (1+s, addv(S.rmv(lv, fv), v), F.SELECT(v,i,lv,le))
344         end         end
345       | F.RAISE (v,ltys) => (3, addv(fv, v), lexp)       | F.RAISE (F.VAR v,ltys) => (3, S.singleton v, lexp)
346       | F.HANDLE (le,v) =>       | F.HANDLE (le,v) =>
347         let val (s,fv,le) = fexp(fv, le)         let val (s,fv,le) = loop le
348         in (2+s, addv(fv, v), F.HANDLE(le,v))         in (2+s, addv(fv, v), F.HANDLE(le,v))
349         end         end
350       | F.BRANCH (po,vs,le1,le2) =>       | F.BRANCH (po,vs,le1,le2) =>
351         let val (s1,fv1,le1) = fexp(fv,le1)         let val (s1,fv1,le1) = loop le1
352             val (s2,fv2,le2) = fexp(fv,le2)             val (s2,fv2,le2) = loop le2
353         in (1+s1+s2, fpo(addvs(S.union(fv1, fv2), vs), po),         in (1+s1+s2, fpo(addvs(S.union(fv1, fv2), vs), po),
354             F.BRANCH(po, vs, le1, le2))             F.BRANCH(po, vs, le1, le2))
355         end         end
356       | F.PRIMOP (po,vs,lv,le) =>       | F.PRIMOP (po,vs,lv,le) =>
357         let val (s,fv,le) = fexp(fv, le)         let val (s,fv,le) = loop le
358         in (1+s, fpo(addvs(S.rmv(lv, fv), vs),po), F.PRIMOP(po,vs,lv,le))         in (1+s, fpo(addvs(S.rmv(lv, fv), vs),po), F.PRIMOP(po,vs,lv,le))
359         end         end
360    
361         | F.APP _ => bug "bogus F.APP"
362         | F.TAPP _ => bug "bogus F.TAPP"
363         | F.RAISE _ => bug "bogus F.RAISE"
364  end  end
365    
366  fun fixfix ((fk,f,args,body):F.prog) =  fun fixfix ((fk,f,args,body):F.prog) =
367      let val (s,fv,nbody) = fexp(S.empty, body)      let val (s,fv,nbody) = fexp M.empty body
368          val fv = S.diff(fv, S.make(map #1 args))          val fv = S.diff(fv, S.make(map #1 args))
369      in      in
370          (*  PPFlint.printLexp(F.RET(map F.VAR (S.members fv))); *)          (*  PPFlint.printLexp(F.RET(map F.VAR (S.members fv))); *)

Legend:
Removed from v.201  
changed lines
  Added in v.202

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