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 199 - (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 :     structure M = IntmapF
16 : monnier 199 structure S = IntSetF
17 : monnier 191 structure LK = LtyKernel
18 :     in
19 :    
20 :     fun bug msg = ErrorMsg.impossible ("Loopify: "^msg)
21 :     val cplv = LambdaVar.dupLvar
22 :    
23 : monnier 199 datatype info = I of {tails : int ref, calls: int ref, icalls: int ref, tcp: bool ref, parent: F.lvar}
24 :     exception NotFound
25 :    
26 : monnier 191 fun loopify (prog as (progkind,progname,progargs,progbody)) = let
27 :    
28 : monnier 199 val m : info Intmap.intmap = Intmap.new(128, NotFound)
29 :    
30 :     (* tails: number of tail-recursive calls
31 :     * calls: number of other calls
32 :     * icalls: non-tail self-recursive subset of `calls'
33 :     * tcp: always called in tail-position
34 :     * parent: enclosing function *)
35 :     fun new (f,known,parent) =
36 :     let val i = I{tails=ref 0, calls=ref 0, icalls=ref 0,
37 :     tcp=ref known, parent=parent}
38 :     in Intmap.add m (f,i); i end
39 :    
40 :     fun get f = Intmap.map m f
41 :    
42 :     (* collect tries to determine what calls are tail recursive.
43 :     * If a function f is always called in tail position in a function g,
44 :     * then all tail calls to g from f are indeed tail recursive. *)
45 :     (* tfs: we are currently in tail position relative to those functions
46 :     * p: englobing function *)
47 :     fun collect p tfs le = let
48 :     val loop = collect p tfs
49 :     in case le
50 :     of F.RET _ => ()
51 :     | F.LET(_,body,le) => (collect p S.empty body; loop le)
52 :     | F.FIX([({isrec=(NONE | SOME(_,F.LK_TAIL)),known,...},f,_,body)],le) =>
53 :     let val I{tcp,calls,icalls,...} = new(f, known, p)
54 :     val _ = loop le
55 :     val ecalls = !calls
56 :     in collect f (if !tcp then S.add(f,tfs) else S.singleton f) body;
57 :     icalls := !calls - ecalls
58 :     end
59 :     | F.FIX(fdecs,le) =>
60 :     let (* create the new entries in the map *)
61 :     val fs = map (fn (fk as {known,...},f,_,body) =>
62 :     (fk, f, body, new(f, false, p)))
63 :     fdecs
64 :     fun cfun ({isrec,...}:F.fkind,f,body,I{calls,icalls,...}) =
65 :     let val ecalls = !calls
66 :     in collect f (S.singleton f) body;
67 :     icalls := !calls - ecalls
68 :     end
69 :     in loop le;
70 :     app cfun fs
71 :     end
72 :     | F.APP(F.VAR f,vs) =>
73 :     (let val I{tails,calls,tcp,parent,...} = get f
74 :     in if S.member tfs f then tails := !tails + 1
75 :     else (calls := !calls + 1;
76 :     if S.member tfs parent then () else tcp := false)
77 :     end handle NotFound => ())
78 :     | F.TFN((_,_,body),le) => (collect p S.empty body; loop le)
79 :     | F.TAPP _ => ()
80 :     | F.SWITCH(v,ac,arms,def) =>
81 :     let fun carm (_,body) = loop body
82 :     in app carm arms; case def of SOME le => loop le | _ => ()
83 :     end
84 :     | (F.CON(_,_,_,_,le) | F.RECORD(_,_,_,le) |
85 :     F.SELECT(_,_,_,le) | F.PRIMOP(_,_,_,le)) => loop le
86 :     | F.RAISE _ => ()
87 :     | F.HANDLE(le,v) => collect p S.empty le
88 :     | F.BRANCH(_,_,le1,le2) => (loop le1; loop le2)
89 :    
90 :     | F.APP _ => bug "weird F.APP in collect"
91 :     end
92 :    
93 : monnier 191 (* m: int intmap renaming for function calls
94 : monnier 199 * tf:(int,int) list the current functions (if any) and their tail version
95 : monnier 191 * le: you get the idea *)
96 : monnier 199 fun lexp m tfs le = let
97 :     val loop = lexp m tfs
98 : monnier 191 in case le
99 :     of F.RET _ => le
100 : monnier 199 | F.LET(lvs,body,le) => F.LET(lvs, lexp m [] body, loop le)
101 : monnier 191 | F.FIX(fdecs,le) =>
102 :     let fun cfun (fk:F.fkind as {isrec=SOME(ltys,F.LK_UNKNOWN),cconv,...},
103 :     f,args,body) =
104 : monnier 199 let val I{tcp=ref tcp,icalls=ref icalls,tails=ref tails,...} =
105 :     get f
106 : monnier 191 (* cpsopt uses the following condition:
107 :     * escape = 0 andalso !unroll_call > 0
108 :     * andalso (!call - !unroll_call > 1
109 :     * orelse List.exists (fn t=>t) inv)
110 :     * `escape = 0': I don't quite see the need for it, though it
111 :     * probably won't change much since etasplit should have
112 :     * made "everything" known already.
113 :     * `!call - !unroll_call > 1 orelse List.exists (fn t=>t) inv)':
114 :     * loopification is only useful if there is more than one
115 :     * external call or if there are loop invariants.
116 :     * Note that we deal with invariants elsewhere, so it's
117 :     * not a good reason to loopify here. *)
118 :     (*** rationale behind the restrictions: ***
119 :     * `icallnb = 0': loopification is pointless and will be
120 :     * undone by fcontract.
121 :     * `C.callnb fi <= icallnb + 1': if there's only one external
122 :     * call, loopification will probably (?) not be of much use
123 :     * and the same benefit would be had by just moving f *)
124 : monnier 199 in if icalls = 0 andalso tails = 0
125 :     then (fk, f, args, lexp m (if tcp then tfs else []) body)
126 : monnier 191 else
127 :     let val fl = cplv f
128 :     val ft = cplv f
129 :     val largs = map (fn(v,t) => (cplv v, t)) args
130 :     val args' = map (fn(v,t) => (cplv v, t)) args
131 :     val cconv' =
132 :     case cconv
133 :     of (F.CC_FCT | F.CC_FUN(LK.FF_FIXED)) => cconv
134 :     | F.CC_FUN(LK.FF_VAR(f1,f2)) =>
135 :     F.CC_FUN(LK.FF_VAR(true,f2))
136 :     val nm = M.add(m, f, fl)
137 : monnier 199 val tfs' = ((f,ft)::(if tcp then tfs else []))
138 :    
139 :     (* make the new body *)
140 :     val (nargs,nbody) = (args, lexp nm tfs' body)
141 :     (* wrap into a tail loop if necessary *)
142 :     val (nargs,nbody) =
143 :     if tails = 0 then (nargs,nbody) else let
144 :     val args' = map (fn(v,t) => (cplv v, t)) args
145 :     in (args',
146 :     F.FIX([({isrec=SOME(ltys, F.LK_TAIL),
147 :     known=true, inline=F.IH_SAFE,
148 :     cconv=cconv'}, ft, nargs,
149 :     nbody)],
150 :     F.APP(F.VAR ft, map (F.VAR o #1) args')))
151 :     end
152 :     (* wrap into a non-tail loop if necessary *)
153 :     val (nargs,nbody) =
154 :     if icalls = 0 then (nargs,nbody) else let
155 :     val args' = map (fn(v,t) => (cplv v, t)) args
156 :     in (args',
157 :     F.FIX([({isrec=SOME(ltys, F.LK_LOOP),
158 :     known=true, inline=F.IH_SAFE,
159 :     cconv=cconv'}, fl, nargs,
160 :     nbody)],
161 :     F.APP(F.VAR fl, map (F.VAR o #1) args')))
162 :     end
163 :     in (fk, f, nargs, nbody)
164 : monnier 191 end
165 :     end
166 : monnier 199 | cfun (fk as {inline=F.IH_UNROLL,isrec=SOME _,...},f,args,body) =
167 :     let val I{tcp=ref tcp,...} = get f
168 :     in (fk, f, args, lexp m (if tcp then tfs else []) body)
169 :     end
170 :     | cfun (fk,f,args,body) =
171 :     let val I{tcp=ref tcp,...} = get f
172 :     in (fk, f, args, lexp m (if tcp then tfs else []) body)
173 :     end
174 : monnier 191 in F.FIX(map cfun fdecs, loop le)
175 :     end
176 :     | F.APP(F.VAR f,vs) =>
177 :     (let val fl = M.lookup m f
178 : monnier 199 in case List.find (fn (ft,ft') => ft = f) tfs
179 :     of SOME(ft, ft') => F.APP(F.VAR ft', vs)
180 : monnier 191 | NONE => F.APP(F.VAR fl, vs)
181 :     end handle M.IntmapF => le)
182 :     | F.TFN((f,args,body),le) => F.TFN((f, args, loop body), loop le)
183 :     | F.TAPP(f,tycs) => le
184 :     | F.SWITCH(v,ac,arms,def) =>
185 :     let fun carm (con,le) = (con, loop le)
186 :     in F.SWITCH(v, ac, map carm arms, O.map loop def)
187 :     end
188 :     | F.CON(dc,tycs,v,lv,le) => F.CON(dc, tycs, v, lv, loop le)
189 :     | F.RECORD(rk,vs,lv,le) => F.RECORD(rk, vs, lv, loop le)
190 :     | F.SELECT(v,i,lv,le) => F.SELECT(v, i, lv, loop le)
191 :     | F.RAISE(v,ltys) => le
192 : monnier 199 | F.HANDLE(le,v) => F.HANDLE(lexp m [] le, v)
193 : monnier 191 | F.BRANCH(po,vs,le1,le2) => F.BRANCH(po, vs, loop le1, loop le2)
194 :     | F.PRIMOP(po,vs,lv,le) => F.PRIMOP(po, vs, lv, loop le)
195 :    
196 :     | F.APP _ => bug "unexpected APP"
197 :     end
198 :    
199 :     in
200 : monnier 199 collect progname S.empty progbody;
201 :     (progkind, progname, progargs, lexp M.empty [] progbody)
202 : monnier 191 end
203 :    
204 :     end
205 :     end
206 :    

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