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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 733 - (view) (download)

1 : monnier 191 (* copyright 1998 YALE FLINT PROJECT *)
2 :     (* monnier@cs.yale.edu *)
3 :    
4 :     signature LOOPIFY =
5 :     sig
6 :     val loopify : FLINT.prog -> FLINT.prog
7 :     end
8 :    
9 :    
10 : monnier 199 structure Loopify :> LOOPIFY =
11 : monnier 191 struct
12 :     local
13 :     structure F = FLINT
14 :     structure O = Option
15 : monnier 504 structure M = IntRedBlackMap
16 :     structure S = IntRedBlackSet
17 : monnier 203 structure OU = OptUtils
18 : monnier 191 structure LK = LtyKernel
19 : monnier 220 structure CTRL = FLINT_Control
20 : monnier 191 in
21 :    
22 : monnier 220 val say = Control_Print.say
23 : monnier 191 fun bug msg = ErrorMsg.impossible ("Loopify: "^msg)
24 :     val cplv = LambdaVar.dupLvar
25 :    
26 : monnier 203 type al = F.value list list
27 :     datatype info = I of {tails : al ref, calls: al ref, icalls: al ref,
28 :     tcp: bool ref, parent: F.lvar}
29 : monnier 199 exception NotFound
30 :    
31 : monnier 191 fun loopify (prog as (progkind,progname,progargs,progbody)) = let
32 :    
33 : blume 733 val m : info IntHashTable.hash_table = IntHashTable.mkTable(128, NotFound)
34 : monnier 199
35 :     (* tails: number of tail-recursive calls
36 :     * calls: number of other calls
37 :     * icalls: non-tail self-recursive subset of `calls'
38 :     * tcp: always called in tail-position
39 :     * parent: enclosing function *)
40 :     fun new (f,known,parent) =
41 : monnier 203 let val i = I{tails=ref [], calls=ref [], icalls=ref [],
42 : monnier 199 tcp=ref known, parent=parent}
43 : blume 733 in IntHashTable.insert m (f,i); i end
44 : monnier 199
45 : blume 733 fun get f = IntHashTable.lookup m f
46 : monnier 199
47 :     (* collect tries to determine what calls are tail recursive.
48 :     * If a function f is always called in tail position in a function g,
49 :     * then all tail calls to g from f are indeed tail recursive. *)
50 :     (* tfs: we are currently in tail position relative to those functions
51 :     * p: englobing function *)
52 :     fun collect p tfs le = let
53 :     val loop = collect p tfs
54 :     in case le
55 :     of F.RET _ => ()
56 :     | F.LET(_,body,le) => (collect p S.empty body; loop le)
57 :     | F.FIX([({isrec=(NONE | SOME(_,F.LK_TAIL)),known,...},f,_,body)],le) =>
58 :     let val I{tcp,calls,icalls,...} = new(f, known, p)
59 :     val _ = loop le
60 : monnier 203 val necalls = length(!calls)
61 : monnier 506 in collect f (if !tcp then S.add(tfs, f) else S.singleton f) body;
62 : monnier 203 icalls := List.take(!calls, length(!calls) - necalls)
63 : monnier 199 end
64 :     | F.FIX(fdecs,le) =>
65 :     let (* create the new entries in the map *)
66 :     val fs = map (fn (fk as {known,...},f,_,body) =>
67 :     (fk, f, body, new(f, false, p)))
68 :     fdecs
69 :     fun cfun ({isrec,...}:F.fkind,f,body,I{calls,icalls,...}) =
70 : monnier 203 let val necalls = length(!calls)
71 : monnier 199 in collect f (S.singleton f) body;
72 : monnier 203 icalls := List.take(!calls, length(!calls) - necalls)
73 : monnier 199 end
74 :     in loop le;
75 :     app cfun fs
76 :     end
77 :     | F.APP(F.VAR f,vs) =>
78 :     (let val I{tails,calls,tcp,parent,...} = get f
79 : monnier 423 in if S.member(tfs, f) then tails := vs::(!tails)
80 : monnier 203 else (calls := vs::(!calls);
81 : monnier 423 if S.member(tfs, parent) then () else tcp := false)
82 : monnier 199 end handle NotFound => ())
83 : monnier 220 | F.TFN((_,_,_,body),le) => (collect p S.empty body; loop le)
84 : monnier 199 | F.TAPP _ => ()
85 :     | F.SWITCH(v,ac,arms,def) =>
86 :     let fun carm (_,body) = loop body
87 :     in app carm arms; case def of SOME le => loop le | _ => ()
88 :     end
89 :     | (F.CON(_,_,_,_,le) | F.RECORD(_,_,_,le) |
90 :     F.SELECT(_,_,_,le) | F.PRIMOP(_,_,_,le)) => loop le
91 :     | F.RAISE _ => ()
92 :     | F.HANDLE(le,v) => collect p S.empty le
93 :     | F.BRANCH(_,_,le1,le2) => (loop le1; loop le2)
94 :    
95 :     | F.APP _ => bug "weird F.APP in collect"
96 :     end
97 :    
98 : monnier 203 (* (intended as a `foldr' argument).
99 :     * `filt' is the bool list indicating if the arg is kept
100 :     * `func' is the list of arguments for the FIX
101 :     * `call' is the list of arguments for the APP
102 :     * `free' is the list of resulting free variables *)
103 :     fun drop_invariant ((v,t),actuals,(filt,func,call,free)) =
104 :     if !CTRL.dropinvariant andalso List.all (fn a => F.VAR v = a) actuals then
105 :     (* drop the argument: the free list is unchanged *)
106 :     (false::filt, func, call, (v,t)::free)
107 :     else
108 :     (* keep the argument: create a new var (used in the call)
109 :     * which will replace the old in the free vars *)
110 :     let val nv = cplv v
111 :     in (true::filt, (v,t)::func, (F.VAR nv)::call, (nv,t)::free)
112 :     end
113 :    
114 : monnier 191 (* m: int intmap renaming for function calls
115 : monnier 199 * tf:(int,int) list the current functions (if any) and their tail version
116 : monnier 191 * le: you get the idea *)
117 : monnier 199 fun lexp m tfs le = let
118 :     val loop = lexp m tfs
119 : monnier 191 in case le
120 :     of F.RET _ => le
121 : monnier 199 | F.LET(lvs,body,le) => F.LET(lvs, lexp m [] body, loop le)
122 : monnier 191 | F.FIX(fdecs,le) =>
123 :     let fun cfun (fk:F.fkind as {isrec=SOME(ltys,F.LK_UNKNOWN),cconv,...},
124 :     f,args,body) =
125 : monnier 199 let val I{tcp=ref tcp,icalls=ref icalls,tails=ref tails,...} =
126 :     get f
127 : monnier 191 (* cpsopt uses the following condition:
128 :     * escape = 0 andalso !unroll_call > 0
129 :     * andalso (!call - !unroll_call > 1
130 :     * orelse List.exists (fn t=>t) inv)
131 :     * `escape = 0': I don't quite see the need for it, though it
132 :     * probably won't change much since etasplit should have
133 :     * made "everything" known already.
134 :     * `!call - !unroll_call > 1 orelse List.exists (fn t=>t) inv)':
135 :     * loopification is only useful if there is more than one
136 :     * external call or if there are loop invariants.
137 :     * Note that we deal with invariants elsewhere, so it's
138 :     * not a good reason to loopify here. *)
139 :     (*** rationale behind the restrictions: ***
140 :     * `icallnb = 0': loopification is pointless and will be
141 :     * undone by fcontract.
142 :     * `C.callnb fi <= icallnb + 1': if there's only one external
143 :     * call, loopification will probably (?) not be of much use
144 :     * and the same benefit would be had by just moving f *)
145 : monnier 203 in if null icalls andalso null tails
146 : monnier 199 then (fk, f, args, lexp m (if tcp then tfs else []) body)
147 : monnier 191 else
148 : monnier 203 let val cconv' =
149 : monnier 191 case cconv
150 :     of (F.CC_FCT | F.CC_FUN(LK.FF_FIXED)) => cconv
151 :     | F.CC_FUN(LK.FF_VAR(f1,f2)) =>
152 :     F.CC_FUN(LK.FF_VAR(true,f2))
153 : monnier 199
154 : monnier 203 (* figure out what arguments of the tail loop
155 :     * are invariants and create the corresponding
156 :     * function args, call args, filter
157 :     * function for the actual calls, ... *)
158 :     val (tfs',atfun,atcall,args,ft) =
159 :     if null tails then (tfs,[],[],args,f) else let
160 :     val ft = cplv f
161 :     val actuals = OU.transpose tails
162 :     val (fcall,afun,acall,afree) =
163 :     ListPair.foldr drop_invariant
164 :     ([],[],[],[])
165 :     (args, actuals)
166 :     in ((f,ft,fcall)::(if tcp then tfs else []),
167 :     afun, acall, afree, ft)
168 :     end
169 :    
170 :     (* Do the same for the non-tail loop *)
171 :     val (nm,alfun,alcall,args,fl) =
172 :     if null icalls then (m,[],[],args,f) else let
173 :     val fl = cplv f
174 :     val actuals = OU.transpose icalls
175 :     val (fcall,afun,acall,afree) =
176 :     ListPair.foldr drop_invariant
177 :     ([],[],[],[])
178 :     (args, actuals)
179 : monnier 422 in (M.insert(m, f, (fl, fcall)),
180 : monnier 203 afun, acall, afree, fl)
181 :     end
182 :    
183 : monnier 199 (* make the new body *)
184 : monnier 203 val nbody = lexp nm tfs' body
185 :    
186 : monnier 199 (* wrap into a tail loop if necessary *)
187 : monnier 203 val nbody =
188 :     if null tails then nbody else
189 : monnier 199 F.FIX([({isrec=SOME(ltys, F.LK_TAIL),
190 :     known=true, inline=F.IH_SAFE,
191 : monnier 203 cconv=cconv'}, ft, atfun,
192 : monnier 199 nbody)],
193 : monnier 203 F.APP(F.VAR ft, atcall))
194 :    
195 : monnier 199 (* wrap into a non-tail loop if necessary *)
196 : monnier 203 val nbody =
197 :     if null icalls then nbody else
198 : monnier 199 F.FIX([({isrec=SOME(ltys, F.LK_LOOP),
199 :     known=true, inline=F.IH_SAFE,
200 : monnier 203 cconv=cconv'}, fl, alfun,
201 : monnier 199 nbody)],
202 : monnier 203 F.APP(F.VAR fl, alcall))
203 :    
204 :     in (fk, f, args, nbody)
205 : monnier 191 end
206 :     end
207 : monnier 199 | cfun (fk as {inline=F.IH_UNROLL,isrec=SOME _,...},f,args,body) =
208 :     let val I{tcp=ref tcp,...} = get f
209 :     in (fk, f, args, lexp m (if tcp then tfs else []) body)
210 :     end
211 :     | cfun (fk,f,args,body) =
212 :     let val I{tcp=ref tcp,...} = get f
213 :     in (fk, f, args, lexp m (if tcp then tfs else []) body)
214 :     end
215 : monnier 191 in F.FIX(map cfun fdecs, loop le)
216 :     end
217 :     | F.APP(F.VAR f,vs) =>
218 : monnier 203 (case List.find (fn (ft,ft',filt) => ft = f) tfs
219 :     of SOME(ft, ft', filt) => F.APP(F.VAR ft', OU.filter filt vs)
220 : monnier 422 | NONE =>
221 :     (case M.find(m,f)
222 :     of SOME(fl, filt) =>
223 :     F.APP(F.VAR fl, OU.filter filt vs)
224 :     | NONE => le
225 : monnier 423 (*esac*)))
226 : monnier 220 | F.TFN((tfk,f,args,body),le) => F.TFN((tfk, f, args, loop body), loop le)
227 : monnier 191 | F.TAPP(f,tycs) => le
228 :     | F.SWITCH(v,ac,arms,def) =>
229 :     let fun carm (con,le) = (con, loop le)
230 :     in F.SWITCH(v, ac, map carm arms, O.map loop def)
231 :     end
232 :     | F.CON(dc,tycs,v,lv,le) => F.CON(dc, tycs, v, lv, loop le)
233 :     | F.RECORD(rk,vs,lv,le) => F.RECORD(rk, vs, lv, loop le)
234 :     | F.SELECT(v,i,lv,le) => F.SELECT(v, i, lv, loop le)
235 :     | F.RAISE(v,ltys) => le
236 : monnier 199 | F.HANDLE(le,v) => F.HANDLE(lexp m [] le, v)
237 : monnier 191 | F.BRANCH(po,vs,le1,le2) => F.BRANCH(po, vs, loop le1, loop le2)
238 :     | F.PRIMOP(po,vs,lv,le) => F.PRIMOP(po, vs, lv, loop le)
239 :    
240 :     | F.APP _ => bug "unexpected APP"
241 :     end
242 :    
243 :     in
244 : monnier 199 collect progname S.empty progbody;
245 :     (progkind, progname, progargs, lexp M.empty [] progbody)
246 : monnier 191 end
247 :    
248 :     end
249 :     end
250 :    
251 : monnier 422

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