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 162 - (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 :     structure S = IntSetF
29 :     structure M = IntmapF
30 :     structure PP = PPFlint
31 :     structure LK = LtyKernel
32 :     structure LT = LtyExtern
33 :     in
34 :    
35 :     val say = Control.Print.say
36 :     fun bug msg = ErrorMsg.impossible ("FixFix: "^msg)
37 :     fun buglexp (msg,le) = (say "\n"; PP.printLexp le; say " "; bug msg)
38 :     fun bugval (msg,v) = (say "\n"; PP.printSval v; say " "; bug msg)
39 :     fun assert p = if p then () else bug ("assertion failed")
40 :    
41 : monnier 160 val cplv = LambdaVar.dupLvar
42 :    
43 : monnier 162 (* to limit the amount of uncurrying *)
44 :     val maxargs = Control.FLINT.maxargs
45 :    
46 : monnier 122 structure SccNode = struct
47 :     type node = LambdaVar.lvar
48 :     val eq = (op =)
49 :     val lt = (op <)
50 :     end
51 :     structure SCC = SCCUtilFun (structure Node = SccNode)
52 :    
53 :     (* fexp: (intset * lexp) -> (int * intset * lexp)
54 :     * The three subparts returned are:
55 :     * - the size of lexp
56 :     * - the set of freevariables of lexp (plus the ones passed as arguments
57 :     * which are assumed to be the freevars of the continuation of lexp)
58 :     * - a new lexp with FIXes rewritten.
59 :     *)
60 :     fun fexp (fv,lexp) = let
61 :    
62 :     fun addv (s,F.VAR lv) = S.add(lv, s)
63 :     | addv (s,_) = s
64 :     fun addvs (s,vs) = foldl (fn (v,s) => addv(s, v)) s vs
65 :     fun rmvs (s,lvs) = foldl S.rmv s lvs
66 :    
67 :     (* Looks for free vars in the primop descriptor.
68 :     * This is normally unnecessary since these are special vars anyway *)
69 :     fun fpo (fv,(NONE:F.dict option,po,lty,tycs)) = fv
70 :     | fpo (fv,(SOME{default,table},po,lty,tycs)) =
71 :     addvs(addv(fv, F.VAR default), map (F.VAR o #2) table)
72 :    
73 :     (* Looks for free vars in the primop descriptor.
74 :     * This is normally unnecessary since these are exception vars anyway *)
75 :     fun fdcon (fv,(s,Access.EXN(Access.LVAR lv),lty)) = addv(fv, F.VAR lv)
76 :     | fdcon (fv,_) = fv
77 :    
78 : monnier 162 (* recognize the curried essence of a function.
79 :     * - hd:bool identifies the head of the (potentially) curried function
80 :     * - r:bool indicates whether the head was recursive
81 :     * - na:int gives the number of args still allowed *)
82 :     fun curry (hd,r,na) (le as (F.FIX([(fk,f,args,body)], F.RET[F.VAR lv]))) =
83 : monnier 122 if lv = f then
84 :     case fk
85 :     of F.FK_FCT => ([], le) (* don't bother *)
86 :     | F.FK_FUN {inline=true,...} => ([], le) (* don't bother *)
87 :     | F.FK_FUN fk' =>
88 :     let val fisrec = isSome(#isrec fk')
89 : monnier 162 val na = na - length args
90 :     in if na >= 0 andalso (hd orelse r orelse not fisrec) then
91 : monnier 122 (* recursive functions are only accepted for uncurrying
92 :     * if they are the head of the function or if the head
93 :     * is already recursive *)
94 : monnier 162 let val (funs,body) =
95 :     curry (false, r orelse fisrec, na) body
96 : monnier 122 in ((fk,f,args)::funs,body)
97 :     end
98 :     else ([], le)
99 :     end
100 :     else
101 :     (* this "never" occurs, but dead-code removal is not bullet-proof *)
102 :     ([(fk,f,args)], body)
103 :     | curry first le = ([], le)
104 :    
105 :     (* do the actual uncurrying *)
106 :     fun uncurry (args as (fk,f,fargs)::_::_,body) =
107 : monnier 160 let val f' = cplv f (* the new fun name *)
108 : monnier 122
109 :     fun getrtypes ([],rtys) = (NONE, rtys)
110 :     | getrtypes ((fk,f,fargs:(F.lvar * F.lty) list)::rest,rtys) =
111 :     case fk
112 :     of F.FK_FUN{isrec=SOME rtys,...} =>
113 :     let val fty = LT.ltc_fkfun(fk, map #2 fargs, rtys)
114 :     val (_,rtys) = getrtypes(rest, SOME rtys)
115 :     in (SOME fty, rtys)
116 :     end
117 :     | _ =>
118 :     let val rtys = Option.map (fn [lty] => #2(LT.ltd_fkfun lty)
119 :     | _ => bug "strange isrec") rtys
120 :     val (fty,rtys) = getrtypes(rest,rtys)
121 :     val fty = Option.map
122 :     (fn lty =>
123 :     LT.ltc_fkfun(fk, map #2 fargs, [lty]))
124 :     fty
125 :     in (fty,rtys)
126 :     end
127 :    
128 :     (* create the new fkinds *)
129 :     val (fty,rtys') = getrtypes(args, NONE)
130 :     val (nfk,nfk') =
131 :     case fk
132 :     of F.FK_FCT => (F.FK_FCT, F.FK_FCT)
133 :     | F.FK_FUN {isrec,known,fixed,inline} =>
134 :     let val fixed' =
135 :     case fixed
136 :     of LK.FF_VAR(f1,f2) => LK.FF_VAR(true, f2)
137 :     | LK.FF_FIXED => LK.FF_FIXED
138 :     (* val rtys = Option.map (fn lty => #2(LT.ltd_fkfun lty)) *)
139 :     (* fty *)
140 :     in (F.FK_FUN{isrec=isrec, known=known,
141 :     fixed=fixed, inline=true},
142 :     F.FK_FUN{isrec=rtys', known=true,
143 :     fixed=fixed', inline=inline})
144 :     end
145 :    
146 :     (* funarg renaming *)
147 : monnier 160 fun newargs fargs = map (fn (a,t) => (cplv a,t)) fargs
148 : monnier 122
149 :     (* create (curried) wrappers to be inlined *)
150 :     fun recurry ([],args) = F.APP(F.VAR f', map (F.VAR o #1) args)
151 :     | recurry ((fk,f,fargs)::rest,args) =
152 :     let val fk = case fk
153 :     of F.FK_FCT => fk
154 :     | F.FK_FUN{isrec,fixed,known,inline} =>
155 :     F.FK_FUN{isrec=NONE, fixed=fixed,
156 :     known=known, inline=true}
157 :     val nfargs = newargs fargs
158 : monnier 160 val g = cplv f'
159 : monnier 122 in F.FIX([(fk, g, nfargs, recurry(rest, args @ nfargs))],
160 :     F.RET[F.VAR g])
161 :     end
162 :    
163 :     (* build the new f fundec *)
164 :     val nfargs = newargs fargs
165 :     val nf = (nfk, f, nfargs, recurry(tl args, nfargs))
166 :    
167 :     (* make up the body of the uncurried function (creating
168 :     * dummy wrappers for the intermediate functions that are now
169 :     * useless).
170 :     * Intermediate functions that were not marked as recursive
171 :     * cannot appear in the body, so we don't need to build them.
172 :     * Note that we can't just rely on dead-code elimination to remove
173 :     * them because we may not be able to create them correctly with
174 :     * the limited type information gleaned in this phase. *)
175 :     fun uncurry' ([],args) = body
176 :     | uncurry' ((fk,f,fargs)::rest,args) =
177 :     let val le = uncurry'(rest, args @ fargs)
178 :     in case fk
179 :     of F.FK_FUN{isrec=SOME _, ...} =>
180 :     let val nfargs = newargs fargs
181 :     val fk = case fk
182 :     of F.FK_FCT => fk
183 :     | F.FK_FUN{isrec,fixed,known,inline} =>
184 :     F.FK_FUN{isrec=NONE, fixed=fixed,
185 :     known=known, inline=true}
186 :     in F.FIX([(fk, f, nfargs,
187 :     recurry(rest, args @ nfargs))],
188 :     le)
189 :     end
190 :     | _ => le
191 :     end
192 :    
193 :     (* the new f' fundec *)
194 :     val nfbody' = uncurry'(tl args, fargs)
195 :     val nf' = (nfk', f', foldr (op @) [] (map #3 args), nfbody')
196 :    
197 :     in (nf, nf')
198 :     end
199 :     | uncurry (_,body) = bug "uncurrying a non-curried function"
200 :    
201 :     in case lexp
202 :     of F.RET vs => (0, addvs(fv, vs), lexp)
203 :     | F.LET (lvs,le1,le2) =>
204 :     let val (s2,fv,le2) = fexp(fv, le2)
205 :     val (s1,fv,le1) = fexp(rmvs(fv, lvs), le1)
206 :     in (s1 + s2, fv, F.LET(lvs, le1, le2))
207 :     end
208 :     | F.FIX (fdecs,le) =>
209 :     let val funs = S.make(map #2 fdecs) (* set of funs defined by the FIX *)
210 :    
211 :     (* process the main lexp and make it into a dummy function.
212 :     * The computation of the freevars is a little sloppy since `fv'
213 : monnier 160 * includes freevars of the continuation, but the uniqueness
214 : monnier 122 * of varnames ensures that S.inter(fv, funs) gives the correct
215 :     * result nonetheless. *)
216 :     val (s,fv,le) = fexp(fv, le)
217 :     val lename = LambdaVar.mkLvar()
218 :     val m = M.singleton(lename, (S.members(S.inter(fv, funs)), 0,
219 :     F.FK_FCT, [], le))
220 :    
221 :     (* process each fun *)
222 :     fun ffun (fdec as (fk,f,args,body):F.fundec,(s,fv,funs,m)) =
223 : monnier 162 case curry (true,false,!maxargs) (F.FIX([fdec], F.RET[F.VAR f]))
224 : monnier 122 of (args as _::_::_,body) => (* curried function *)
225 :     let val ((fk,f,fargs,fbody),(fk',f',fargs',fbody')) =
226 :     uncurry(args,body)
227 :     (* add the wrapper function *)
228 :     val nm = M.add(m, f, ([f'], 1, fk, fargs, fbody))
229 :     (* now, retry ffun with the uncurried function *)
230 :     in ffun((fk', f', fargs', fbody'),
231 :     (s+1, fv, S.add(f', funs), nm))
232 :     end
233 :     | _ => (* non-curried function *)
234 :     let val (fs,ffv,body) = fexp(S.empty, body)
235 :     val ffv = rmvs(ffv, map #1 args) (* fun's freevars *)
236 :     val ifv = S.inter(ffv, funs) (* set of rec funs ref'ed *)
237 :     in
238 :     (fs + s, S.union(ffv, fv), funs,
239 :     M.add(m, f, (S.members ifv, fs, fk, args, body)))
240 :     end
241 :    
242 :     (* process the functions, collecting them in map m *)
243 :     val (s,fv,funs,m) = foldl ffun (s, fv, funs, m) fdecs
244 :    
245 :     (* find strongly connected components *)
246 :     val top = SCC.topOrder{root=lename, follow= #1 o (M.lookup m)}
247 :    
248 :     (* turns them back into flint code *)
249 :     fun sccconvert (SCC.SIMPLE f,le) =
250 :     (* a simple function. Fix the fk accordingly *)
251 :     let val (_,s,fk,args,body) = M.lookup m f
252 :     val fk =
253 :     case fk
254 :     of F.FK_FCT => F.FK_FCT
255 :     | F.FK_FUN {isrec,fixed,known,inline} =>
256 :     (* small functions inlining heuristic *)
257 :     let val small = s < !Control.FLINT.inlineThreshold
258 :     in F.FK_FUN{isrec=NONE, fixed=fixed,
259 :     known=known, inline=inline orelse small}
260 :     end
261 :     in F.FIX([(fk, f, args, body)], le)
262 :     end
263 :     | sccconvert (SCC.RECURSIVE fs,le) =
264 :     let fun scfun f =
265 :     let val (_,_,fk,args,body) = M.lookup m f
266 :     in (fk, f, args, body) end
267 :     in F.FIX(map scfun fs, le)
268 :     end
269 :     in
270 :     case top
271 :     of (SCC.SIMPLE f)::sccs =>
272 :     (assert(f = lename);
273 :     (s, S.diff(fv, funs), foldl sccconvert le sccs))
274 :     | (SCC.RECURSIVE _)::_ => bug "recursive main body in SCC ?!?!?"
275 :     | [] => bug "SCC going crazy"
276 :     end
277 :     | F.APP (f,args) =>
278 :     (* the cost of a function call depends on the number of args
279 :     * and the size of the continuation (number of free vars).
280 :     * We could also ask Collect whether f is known *)
281 :     (3 + (length args) + (S.size fv), addvs(fv, f::args), lexp)
282 :     | F.TFN ((f,args,body),le) =>
283 :     let val (se,fve,le) = fexp(fv, le)
284 :     val (sb,fvb,body) = fexp(S.empty, body)
285 :     in (sb + se, S.union(S.rmv(f, fve), fvb), F.TFN((f, args, body), le))
286 :     end
287 :     | F.TAPP (f,args) =>
288 :     (* The cost of TAPP is kinda hard to estimate. It can be very cheap,
289 :     * and just return a function, or it might do all kinds of wrapping
290 :     * but we have almost no information on which to base our choice.
291 :     * We opted for cheap here, to try to inline them more (they might
292 :     * become cheaper once inlined) *)
293 :     (3, addv(fv, f), lexp)
294 :     | F.SWITCH (v,ac,arms,def) =>
295 :     let fun farm (dcon as F.DATAcon(dc,_,lv),le) =
296 :     (* the binding might end up costly, but we count it as 1 *)
297 :     let val (s,fv,le) = fexp(fv,le)
298 :     in (1+s, fdcon(S.rmv(lv, fv),dc), (dcon, le))
299 :     end
300 :     | farm (dc,le) =
301 :     let val (s,fv,le) = fexp(fv, le) in (s, fv, (dc, le)) end
302 :     val (s,fv,arms) =
303 :     foldl (fn ((s1,fv1,arm),(s2,fv2,arms)) =>
304 :     (s1+s2, S.union(fv1, fv2), arm::arms))
305 :     (0, fv, []) (map farm arms)
306 :     in case def
307 :     of NONE => (s, fv, F.SWITCH(v, ac, arms, NONE))
308 :     | SOME le => let val (sd,fvd,le) = fexp(fv,le)
309 :     in (s+sd, S.union(fv, fvd), F.SWITCH(v, ac, arms, SOME le))
310 :     end
311 :     end
312 :     | F.CON (dc,tycs,v,lv,le) =>
313 :     let val (s,fv,le) = fexp(fv, le)
314 :     in (2+s, fdcon(addv(S.rmv(lv, fv), v),dc), F.CON(dc, tycs, v, lv, le))
315 :     end
316 :     | F.RECORD (rk,vs,lv,le) =>
317 :     let val (s,fv,le) = fexp(fv, le)
318 :     in ((length vs)+s, addvs(S.rmv(lv, fv), vs), F.RECORD(rk, vs, lv, le))
319 :     end
320 :     | F.SELECT (v,i,lv,le) =>
321 :     let val (s,fv,le) = fexp(fv, le)
322 :     in (1+s, addv(S.rmv(lv, fv), v), F.SELECT(v,i,lv,le))
323 :     end
324 :     | F.RAISE (v,ltys) => (3, addv(fv, v), lexp)
325 :     | F.HANDLE (le,v) =>
326 :     let val (s,fv,le) = fexp(fv, le)
327 :     in (2+s, addv(fv, v), F.HANDLE(le,v))
328 :     end
329 :     | F.BRANCH (po,vs,le1,le2) =>
330 :     let val (s1,fv1,le1) = fexp(fv,le1)
331 :     val (s2,fv2,le2) = fexp(fv,le2)
332 :     in (1+s1+s2, fpo(addvs(S.union(fv1, fv2), vs), po),
333 :     F.BRANCH(po, vs, le1, le2))
334 :     end
335 :     | F.PRIMOP (po,vs,lv,le) =>
336 :     let val (s,fv,le) = fexp(fv, le)
337 :     in (1+s, fpo(addvs(S.rmv(lv, fv), vs),po), F.PRIMOP(po,vs,lv,le))
338 :     end
339 :     end
340 :    
341 :     fun fixfix ((fk,f,args,body):F.prog) =
342 :     let val (s,fv,nbody) = fexp(S.empty, body)
343 :     val fv = S.diff(fv, S.make(map #1 args))
344 :     in
345 :     (* PPFlint.printLexp(F.RET(map F.VAR (S.members fv))); *)
346 :     assert(S.isEmpty(fv));
347 :     (fk, f, args, nbody)
348 :     end
349 :    
350 :     end
351 :     end

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