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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 489 - (view) (download)

1 : monnier 122 (* copyright 1998 YALE FLINT PROJECT *)
2 : monnier 160 (* monnier@cs.yale.edu *)
3 : monnier 122
4 :     (* This module does various FIX-related transformations:
5 :     * - FIXes are split into their strongly-connected components
6 :     * - small non-recursive functions are marked inlinable
7 : monnier 160 * - curried functions are uncurried
8 : monnier 122 *)
9 :    
10 :     signature FIXFIX =
11 :     sig
12 :     val fixfix : FLINT.prog -> FLINT.prog
13 :     end
14 :    
15 : monnier 160 (* Maybe later:
16 : monnier 122 * - hoisting of inner functions out of their englobing function
17 :     * so that the outer function becomes smaller, giving more opportunity
18 :     * for inlining.
19 : monnier 160 * - eta expand escaping functions
20 :     * - loop-preheader introduction
21 : monnier 122 *)
22 :    
23 :     structure FixFix :> FIXFIX =
24 :     struct
25 :    
26 :     local
27 :     structure F = FLINT
28 : monnier 423 structure S = IntBinarySet
29 : monnier 422 structure M = IntBinaryMap
30 : monnier 122 structure PP = PPFlint
31 :     structure LT = LtyExtern
32 : monnier 220 structure LK = LtyKernel
33 : monnier 163 structure OU = OptUtils
34 : monnier 220 structure CTRL = FLINT_Control
35 : monnier 122 in
36 :    
37 : monnier 220 val say = Control_Print.say
38 : monnier 122 fun bug msg = ErrorMsg.impossible ("FixFix: "^msg)
39 :     fun buglexp (msg,le) = (say "\n"; PP.printLexp le; say " "; bug msg)
40 :     fun bugval (msg,v) = (say "\n"; PP.printSval v; say " "; bug msg)
41 :     fun assert p = if p then () else bug ("assertion failed")
42 : monnier 257 fun bugsay s = say ("!*!*! Fixfix: "^s^" !*!*!\n")
43 : monnier 122
44 : monnier 160 val cplv = LambdaVar.dupLvar
45 :    
46 : monnier 162 (* to limit the amount of uncurrying *)
47 : monnier 184 val maxargs = CTRL.maxargs
48 : monnier 162
49 : monnier 122 structure SccNode = struct
50 :     type node = LambdaVar.lvar
51 :     val eq = (op =)
52 :     val lt = (op <)
53 :     end
54 :     structure SCC = SCCUtilFun (structure Node = SccNode)
55 :    
56 : monnier 213 datatype info = Fun of int ref
57 :     | Arg of int * (int * int) ref
58 :    
59 : monnier 202 (* fexp: int ref intmapf -> lexp) -> (int * intset * lexp)
60 :     * The intmap contains refs to counters. The meaning of the counters
61 :     * is slightly overloaded:
62 :     * - if the counter is negative, it means the lvar
63 :     * is a locally known function and the counter's absolute value denotes
64 :     * the number of calls (off by one to make sure it's always negative).
65 :     * - else, it indicates that the lvar is a
66 :     * function argument and the absolute value is a (fuzzily defined) measure
67 :     * of the reduction in code size/speed that would result from knowing
68 :     * its value (might be used to decide whether or not duplicating code is
69 :     * desirable at a specific call site).
70 : monnier 122 * The three subparts returned are:
71 :     * - the size of lexp
72 :     * - the set of freevariables of lexp (plus the ones passed as arguments
73 :     * which are assumed to be the freevars of the continuation of lexp)
74 :     * - a new lexp with FIXes rewritten.
75 :     *)
76 : monnier 213 fun fexp mf depth lexp = let
77 : monnier 122
78 : monnier 213 val loop = fexp mf depth
79 : monnier 202
80 : monnier 423 fun lookup (F.VAR lv) = M.find(mf, lv)
81 : monnier 422 | lookup _ = NONE
82 : monnier 202
83 : monnier 489 fun S_rmv(x, s) = S.delete(s, x) handle NotFound => s
84 :    
85 : monnier 423 fun addv (s,F.VAR lv) = S.add(s, lv)
86 : monnier 122 | addv (s,_) = s
87 :     fun addvs (s,vs) = foldl (fn (v,s) => addv(s, v)) s vs
88 : monnier 489 fun rmvs (s,lvs) = foldl (fn (l,s) => S_rmv(l, s)) s lvs
89 : monnier 122
90 :     (* Looks for free vars in the primop descriptor.
91 :     * This is normally unnecessary since these are special vars anyway *)
92 :     fun fpo (fv,(NONE:F.dict option,po,lty,tycs)) = fv
93 :     | fpo (fv,(SOME{default,table},po,lty,tycs)) =
94 :     addvs(addv(fv, F.VAR default), map (F.VAR o #2) table)
95 :    
96 :     (* Looks for free vars in the primop descriptor.
97 :     * This is normally unnecessary since these are exception vars anyway *)
98 :     fun fdcon (fv,(s,Access.EXN(Access.LVAR lv),lty)) = addv(fv, F.VAR lv)
99 :     | fdcon (fv,_) = fv
100 :    
101 : monnier 162 (* recognize the curried essence of a function.
102 : monnier 220 * - hd:fkind option identifies the head of the curried function
103 : monnier 162 * - na:int gives the number of args still allowed *)
104 : monnier 220 fun curry (hd,na)
105 :     (le as (F.FIX([(fk as {inline=F.IH_SAFE,...},f,args,body)],
106 :     F.RET[F.VAR lv]))) =
107 :     if lv = f andalso na >= length args then
108 :     case (hd,fk)
109 :     of ((* (SOME{isrec=NONE,...},{isrec=SOME _,...}) | *)
110 :     (SOME{cconv=F.CC_FCT,...},{cconv=F.CC_FUN _,...}) |
111 :     (SOME{cconv=F.CC_FUN _,...},{cconv=F.CC_FCT,...})) =>
112 :     ([], le)
113 :     (* | ((NONE,_) |
114 :     (SOME{isrec=SOME _,...},_) |
115 :     (SOME{isrec=NONE,...},{isrec=NONE,...})) => *)
116 :     (* recursive functions are only accepted for uncurrying
117 :     * if they are the head of the function or if the head
118 :     * is already recursive *)
119 :     | _ =>
120 :     let val (funs,body) = curry (SOME fk, na - (length args)) body
121 : monnier 184 in ((fk,f,args)::funs,body)
122 : monnier 122 end
123 :     else
124 :     (* this "never" occurs, but dead-code removal is not bullet-proof *)
125 : monnier 164 ([], le)
126 : monnier 220 | curry _ le = ([], le)
127 : monnier 122
128 : monnier 220 exception Uncurryable
129 :    
130 : monnier 122 (* do the actual uncurrying *)
131 :     fun uncurry (args as (fk,f,fargs)::_::_,body) =
132 : monnier 160 let val f' = cplv f (* the new fun name *)
133 : monnier 122
134 : monnier 184 (* find the rtys of the uncurried function *)
135 :     fun getrtypes (({isrec=SOME(rtys,_),...}:F.fkind,_,_),_) = SOME rtys
136 :     | getrtypes ((_,_,_),rtys) =
137 :     Option.map (fn [lty] => #2(LT.ltd_fkfun lty)
138 :     | _ => bug "strange isrec") rtys
139 : monnier 122
140 :     (* create the new fkinds *)
141 : monnier 220 val ncconv = case #cconv(#1(List.last args)) of
142 :     F.CC_FUN(LK.FF_VAR(_,raw)) => F.CC_FUN(LK.FF_VAR(true, raw))
143 :     | cconv => cconv
144 : monnier 184 val (nfk,nfk') = OU.fk_wrap(fk, foldl getrtypes NONE args)
145 : monnier 220 val nfk' = {inline= #inline nfk', isrec= #isrec nfk',
146 :     known= #known nfk', cconv= ncconv}
147 : monnier 122
148 :     (* funarg renaming *)
149 : monnier 160 fun newargs fargs = map (fn (a,t) => (cplv a,t)) fargs
150 : monnier 122
151 :     (* create (curried) wrappers to be inlined *)
152 :     fun recurry ([],args) = F.APP(F.VAR f', map (F.VAR o #1) args)
153 : monnier 184 | recurry (({inline,isrec,known,cconv},f,fargs)::rest,args) =
154 :     let val fk = {inline=F.IH_ALWAYS, isrec=NONE,
155 :     known=known, cconv=cconv}
156 : monnier 122 val nfargs = newargs fargs
157 : monnier 160 val g = cplv f'
158 : monnier 122 in F.FIX([(fk, g, nfargs, recurry(rest, args @ nfargs))],
159 :     F.RET[F.VAR g])
160 :     end
161 :    
162 :     (* build the new f fundec *)
163 :     val nfargs = newargs fargs
164 :     val nf = (nfk, f, nfargs, recurry(tl args, nfargs))
165 :    
166 :     (* make up the body of the uncurried function (creating
167 :     * dummy wrappers for the intermediate functions that are now
168 :     * useless).
169 :     * Intermediate functions that were not marked as recursive
170 :     * cannot appear in the body, so we don't need to build them.
171 :     * Note that we can't just rely on dead-code elimination to remove
172 :     * them because we may not be able to create them correctly with
173 :     * the limited type information gleaned in this phase. *)
174 :     fun uncurry' ([],args) = body
175 :     | uncurry' ((fk,f,fargs)::rest,args) =
176 :     let val le = uncurry'(rest, args @ fargs)
177 :     in case fk
178 : monnier 184 of {isrec=SOME _,cconv,known,inline} =>
179 : monnier 122 let val nfargs = newargs fargs
180 : monnier 184 val fk = {isrec=NONE, inline=F.IH_ALWAYS,
181 :     known=known, cconv=cconv}
182 : monnier 122 in F.FIX([(fk, f, nfargs,
183 :     recurry(rest, args @ nfargs))],
184 :     le)
185 :     end
186 :     | _ => le
187 :     end
188 :    
189 :     (* the new f' fundec *)
190 :     val nfbody' = uncurry'(tl args, fargs)
191 :     val nf' = (nfk', f', foldr (op @) [] (map #3 args), nfbody')
192 :    
193 :     in (nf, nf')
194 :     end
195 :     | uncurry (_,body) = bug "uncurrying a non-curried function"
196 :    
197 :     in case lexp
198 : monnier 202 of F.RET vs => (0, addvs(S.empty, vs), lexp)
199 :     | F.LET (lvs,body,le) =>
200 :     let val (s2,fvl,nle) = loop le
201 :     val (s1,fvb,nbody) = loop body
202 :     in (s1 + s2, S.union(rmvs(fvl, lvs), fvb), F.LET(lvs, nbody, nle))
203 : monnier 122 end
204 :     | F.FIX (fdecs,le) =>
205 : monnier 423 let val funs = S.addList(S.empty, map #2 fdecs) (* set of funs defined by the FIX *)
206 : monnier 122
207 : monnier 202 (* create call-counters for each fun and add them to fm *)
208 :     val (fs,mf) = foldl (fn ((fk,f,args,body),(fs,mf)) =>
209 : monnier 213 let val c = ref 0
210 :     in ((fk, f, args, body, c)::fs,
211 : monnier 422 M.insert(mf, f, Fun c))
212 : monnier 202 end)
213 :     ([],mf)
214 :     fdecs
215 : monnier 122
216 :     (* process each fun *)
217 : monnier 202 fun ffun (fdec as (fk as {isrec,...}:F.fkind,f,args,body,cf),
218 : monnier 199 (s,fv,funs,m)) =
219 : monnier 220 case curry (NONE,!maxargs)
220 : monnier 202 (F.FIX([(fk,f,args,body)], F.RET[F.VAR f]))
221 : monnier 122 of (args as _::_::_,body) => (* curried function *)
222 :     let val ((fk,f,fargs,fbody),(fk',f',fargs',fbody')) =
223 :     uncurry(args,body)
224 :     (* add the wrapper function *)
225 : monnier 213 val cs = map (fn _ => ref(0,0)) fargs
226 : monnier 422 val nm = M.insert(m, f, ([f'], 1, fk, fargs, fbody, cf, cs))
227 : monnier 122 (* now, retry ffun with the uncurried function *)
228 : monnier 202 in ffun((fk', f', fargs', fbody', ref 1),
229 : monnier 423 (s+1, fv, S.add(funs, f'), nm))
230 : monnier 122 end
231 :     | _ => (* non-curried function *)
232 : monnier 213 let val newdepth =
233 :     case isrec
234 :     of SOME(_,(F.LK_TAIL | F.LK_LOOP)) => depth + 1
235 :     | _ => depth
236 :     val (mf,cs) = foldr (fn ((v,t),(m,cs)) =>
237 :     let val c = ref(0, 0)
238 : monnier 422 in (M.insert(m, v, Arg(newdepth, c)),
239 : monnier 213 c::cs) end)
240 : monnier 202 (mf,[]) args
241 : monnier 213 val (fs,ffv,body) = fexp mf newdepth body
242 : monnier 122 val ffv = rmvs(ffv, map #1 args) (* fun's freevars *)
243 : monnier 423 val ifv = S.intersection(ffv, funs) (* set of rec funs ref'ed *)
244 : monnier 122 in
245 :     (fs + s, S.union(ffv, fv), funs,
246 : monnier 423 M.insert(m,f,(S.listItems ifv, fs, fk, args, body, cf, cs)))
247 : monnier 122 end
248 :    
249 : monnier 202 (* process the main lexp and make it into a dummy function.
250 :     * The computation of the freevars is a little sloppy since `fv'
251 :     * includes freevars of the continuation, but the uniqueness
252 :     * of varnames ensures that S.inter(fv, funs) gives the correct
253 :     * result nonetheless. *)
254 : monnier 213 val (s,fv,le) = fexp mf depth le
255 : monnier 202 val lename = LambdaVar.mkLvar()
256 : monnier 422 val m = M.insert(M.empty,
257 :     lename,
258 : monnier 423 (S.listItems(S.intersection(fv, funs)), 0,
259 : monnier 422 {inline=F.IH_SAFE, isrec=NONE,
260 :     known=true,cconv=F.CC_FCT},
261 :     [], le, ref 0, []))
262 : monnier 202
263 : monnier 122 (* process the functions, collecting them in map m *)
264 : monnier 202 val (s,fv,funs,m) = foldl ffun (s, fv, funs, m) fs
265 : monnier 122
266 :     (* find strongly connected components *)
267 : monnier 422 val top =
268 :     SCC.topOrder{root=lename,
269 :     follow=(fn n => #1(Option.valOf(M.find(m,n))))}
270 :     handle x => (bug "top:follow"; raise x)
271 : monnier 122
272 :     (* turns them back into flint code *)
273 : monnier 202 fun sccSimple f (_,s,{isrec,cconv,known,inline},args,body,cf,cs) =
274 :     let (* small functions inlining heuristic *)
275 :     val ilthreshold = !CTRL.inlineThreshold + (length args)
276 :     val ilh =
277 :     if inline = F.IH_ALWAYS then inline
278 : monnier 213 (* else if s < ilthreshold then F.IH_ALWAYS *)
279 :     else let val cs = map (fn ref(sp,ti) => sp + ti div 2) cs
280 : monnier 202 val s' = foldl (op+) 0 cs
281 :     in if s < 2*s' + ilthreshold
282 : monnier 257 then ((* say((Collect.LVarString f)^
283 : monnier 216 " {"^(Int.toString(!cf))^
284 :     "} = F.IH_MAYBE "^
285 :     (Int.toString (s-ilthreshold))^
286 :     (foldl (fn (i,s) => s^" "^
287 :     (Int.toString i))
288 :     "" cs)^"\n"); *)
289 : monnier 202 F.IH_MAYBE (s-ilthreshold, cs))
290 :     else inline
291 : monnier 184 end
292 : monnier 202 val fk = {isrec=NONE, inline=ilh, known=known, cconv=cconv}
293 :     in (fk, f, args, body)
294 : monnier 122 end
295 : monnier 202 fun sccRec f (_,s,fk as {isrec,cconv,known,inline},args,body,cf,cs) =
296 :     let val fk' =
297 :     (* let's check for unroll opportunities.
298 :     * This heuristic is pretty bad since it doesn't
299 :     * take the number of rec-calls into account *)
300 :     case (isrec,inline)
301 :     of (SOME(_,(F.LK_LOOP|F.LK_TAIL)),F.IH_SAFE) =>
302 :     if s < !CTRL.unrollThreshold then
303 :     {inline=F.IH_UNROLL, isrec=isrec,
304 :     cconv=cconv, known=known}
305 :     else fk
306 :     | _ => fk
307 :     in (fk, f, args, body)
308 :     end
309 :     fun sccconvert (SCC.SIMPLE f,le) =
310 : monnier 422 F.FIX([sccSimple f (Option.valOf(M.find(m, f)))], le)
311 : monnier 122 | sccconvert (SCC.RECURSIVE fs,le) =
312 : monnier 423 F.FIX(map (fn f => sccRec f (Option.valOf(M.find(m, f)))) fs, le)
313 : monnier 122 in
314 :     case top
315 :     of (SCC.SIMPLE f)::sccs =>
316 : monnier 257 ((if (f = lename) then () else bugsay "f != lename");
317 : monnier 423 (s, S.difference(fv, funs), foldl sccconvert le sccs))
318 : monnier 122 | (SCC.RECURSIVE _)::_ => bug "recursive main body in SCC ?!?!?"
319 :     | [] => bug "SCC going crazy"
320 :     end
321 : monnier 202 | F.APP (F.VAR f,args) =>
322 :     (* For known functions, increase the counter and
323 :     * make the call a bit cheaper. *)
324 :     let val scall =
325 : monnier 422 (case M.find(mf, f)
326 :     of SOME(Fun(fc as ref c)) => (fc := c + 1; 1)
327 :     | SOME(Arg(d, ac as ref (sp,ti))) =>
328 :     (ac := (4 + sp, OU.pow2(depth - d) * 30 + ti); 5)
329 :     | NONE => 5)
330 : monnier 213 in
331 : monnier 202 (scall + (length args), addvs(S.singleton f, args), lexp)
332 :     end
333 : monnier 220 | F.TFN ((tfk,f,args,body),le) =>
334 : monnier 202 let val (se,fve,le) = loop le
335 :     val (sb,fvb,body) = loop body
336 : monnier 489 in (sb + se, S.union(S_rmv(f, fve), fvb),
337 : monnier 220 F.TFN((tfk, f, args, body), le))
338 : monnier 122 end
339 : monnier 202 | F.TAPP (F.VAR f,args) =>
340 : monnier 122 (* The cost of TAPP is kinda hard to estimate. It can be very cheap,
341 :     * and just return a function, or it might do all kinds of wrapping
342 :     * but we have almost no information on which to base our choice.
343 :     * We opted for cheap here, to try to inline them more (they might
344 :     * become cheaper once inlined) *)
345 : monnier 202 (3, S.singleton f, lexp)
346 : monnier 122 | F.SWITCH (v,ac,arms,def) =>
347 :     let fun farm (dcon as F.DATAcon(dc,_,lv),le) =
348 :     (* the binding might end up costly, but we count it as 1 *)
349 : monnier 202 let val (s,fv,le) = loop le
350 : monnier 489 in (1+s, fdcon(S_rmv(lv, fv),dc), (dcon, le))
351 : monnier 122 end
352 :     | farm (dc,le) =
353 : monnier 202 let val (s,fv,le) = loop le in (s, fv, (dc, le)) end
354 : monnier 213 val narms = length arms
355 : monnier 202 val (s,smax,fv,arms) =
356 :     foldl (fn ((s1,fv1,arm),(s2,smax,fv2,arms)) =>
357 :     (s1+s2, Int.max(s1,smax), S.union(fv1, fv2), arm::arms))
358 : monnier 213 (narms, 0, S.empty, []) (map farm arms)
359 :     in (case lookup v
360 : monnier 422 of SOME(Arg(d,ac as ref(sp,ti))) =>
361 : monnier 213 ac := (sp + s - smax + narms, OU.pow2(depth - d) * 2 + ti)
362 : monnier 422 | _ => ());
363 : monnier 202 case def
364 : monnier 213 of NONE => (s, fv, F.SWITCH(v, ac, arms, NONE))
365 :     | SOME le => let val (sd,fvd,le) = loop le
366 :     in (s+sd, S.union(fv, fvd), F.SWITCH(v, ac, arms, SOME le))
367 :     end
368 : monnier 122 end
369 :     | F.CON (dc,tycs,v,lv,le) =>
370 : monnier 202 let val (s,fv,le) = loop le
371 : monnier 489 in (2+s, fdcon(addv(S_rmv(lv, fv), v),dc), F.CON(dc, tycs, v, lv, le))
372 : monnier 122 end
373 :     | F.RECORD (rk,vs,lv,le) =>
374 : monnier 202 let val (s,fv,le) = loop le
375 : monnier 489 in ((length vs)+s, addvs(S_rmv(lv, fv), vs), F.RECORD(rk, vs, lv, le))
376 : monnier 122 end
377 :     | F.SELECT (v,i,lv,le) =>
378 : monnier 202 let val (s,fv,le) = loop le
379 : monnier 213 in (case lookup v
380 : monnier 422 of SOME(Arg(d,ac as ref(sp,ti))) =>
381 : monnier 213 ac := (sp + 1, OU.pow2(depth - d) + ti)
382 : monnier 422 | _ => ());
383 : monnier 489 (1+s, addv(S_rmv(lv, fv), v), F.SELECT(v,i,lv,le))
384 : monnier 122 end
385 : monnier 255 | F.RAISE (F.VAR v,ltys) =>
386 :     (* artificially high size estimate to discourage inlining *)
387 :     (15, S.singleton v, lexp)
388 : monnier 122 | F.HANDLE (le,v) =>
389 : monnier 202 let val (s,fv,le) = loop le
390 : monnier 122 in (2+s, addv(fv, v), F.HANDLE(le,v))
391 :     end
392 :     | F.BRANCH (po,vs,le1,le2) =>
393 : monnier 202 let val (s1,fv1,le1) = loop le1
394 :     val (s2,fv2,le2) = loop le2
395 : monnier 122 in (1+s1+s2, fpo(addvs(S.union(fv1, fv2), vs), po),
396 :     F.BRANCH(po, vs, le1, le2))
397 :     end
398 :     | F.PRIMOP (po,vs,lv,le) =>
399 : monnier 202 let val (s,fv,le) = loop le
400 : monnier 489 in (1+s, fpo(addvs(S_rmv(lv, fv), vs),po), F.PRIMOP(po,vs,lv,le))
401 : monnier 122 end
402 : monnier 202
403 :     | F.APP _ => bug "bogus F.APP"
404 :     | F.TAPP _ => bug "bogus F.TAPP"
405 :     | F.RAISE _ => bug "bogus F.RAISE"
406 : monnier 122 end
407 :    
408 :     fun fixfix ((fk,f,args,body):F.prog) =
409 : monnier 213 let val (s,fv,nbody) = fexp M.empty 0 body
410 : monnier 423 val fv = S.difference(fv, S.addList(S.empty, map #1 args))
411 : monnier 122 in
412 :     (* PPFlint.printLexp(F.RET(map F.VAR (S.members fv))); *)
413 :     assert(S.isEmpty(fv));
414 :     (fk, f, args, nbody)
415 :     end
416 :    
417 :     end
418 :     end
419 : monnier 422

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