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

Annotation of /sml/trunk/src/compiler/FLINT/cpsopt/flatten.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 419 - (view) (download)

1 : monnier 245 (* Copyright 1996 by Bell Laboratories *)
2 :     (* flatten.sml *)
3 :    
4 :     signature FLATTEN = sig
5 :     val flatten : {function: CPS.function,
6 :     table: LtyDef.lty Intmap.intmap,
7 :     click: string -> unit} -> CPS.function
8 :     end (* signature FLATTEN *)
9 :    
10 :     functor Flatten(MachSpec : MACH_SPEC) : FLATTEN =
11 :     struct
12 :    
13 :     local open CPS
14 :     structure LT = LtyExtern
15 :     structure LV = LambdaVar
16 :     structure CG = Control.CG
17 :    
18 :     in
19 :    
20 :     val say = Control.Print.say
21 :     fun bug s = ErrorMsg.impossible ("Flatten: " ^ s)
22 :    
23 :     datatype arity = BOT
24 :     | UNK (* an arg seen that isn't a known record *)
25 :     | COUNT of int * bool (* int is # of record fields;
26 :     bool is whether any arguments
27 :     were unknown records *)
28 :     | TOP
29 :    
30 :     datatype info = FNinfo of {arity: arity list ref,
31 :     alias: lvar option ref,
32 :     escape: bool ref}
33 :     | ARGinfo of int ref (* the highest-numbered field selected *)
34 :     | RECinfo of int (* number of fields *)
35 :     | MISCinfo
36 :    
37 :     fun flatten {function=(fkind,fvar,fargs,ctyl,cexp), table, click} =
38 :     let
39 :    
40 :     val clicks = ref 0
41 :    
42 :     val maxfree = MachSpec.numRegs
43 :     val debug = !Control.CG.debugcps (* false *)
44 :     fun debugprint s = if debug then Control.Print.say(s) else ()
45 :     fun debugflush() = if debug then Control.Print.flush() else ()
46 :    
47 :     val rep_flag = MachSpec.representations
48 :     val type_flag = (!CG.checkcps1) andalso (!CG.checkcps2) andalso rep_flag
49 :    
50 :     val selectLty =
51 :     (fn (lt,i) => if type_flag then LT.lt_select(lt,i) else LT.ltc_void)
52 :    
53 :     exception NFLATTEN
54 :     fun getty v =
55 :     if type_flag then
56 :     (Intmap.map table v) handle _ =>
57 :     (Control.Print.say ("NFLATTEN: Can't find the variable "^
58 :     (Int.toString v)^" in the table ***** \n");
59 :     raise NFLATTEN)
60 :     else LT.ltc_void
61 :    
62 :     val addty = if type_flag then Intmap.add table else (fn _ => ())
63 :     fun newty(f,t) = if type_flag then (Intmap.rmv table f; addty(f,t))
64 :     else ()
65 :     fun mkv(t) = let val v = LV.mkLvar()
66 :     val _ = addty(v,t)
67 :     in v
68 :     end
69 :     fun grabty u =
70 :     let fun g(VAR v) = getty v
71 :     | g(INT _) = LT.ltc_int
72 :     | g(REAL _) = LT.ltc_real
73 :     | g(STRING _) = LT.ltc_void
74 :     | g(LABEL v) = getty v
75 :     | g _ = LT.ltc_void
76 :     in if type_flag then g u
77 :     else LT.ltc_void
78 :     end
79 :    
80 :     fun argLty [] = LT.ltc_int
81 :     | argLty [t] =
82 :     LT.ltw_tuple(t,
83 :     (fn xs as (_::_) => if (length(xs) < MachSpec.maxRepRegs)
84 :     then LT.ltc_tuple [t] else t
85 :     | _ => t),
86 :     fn t =>
87 :     LT.ltw_str(t,
88 :     (fn xs as (_::_) => if (length(xs) < MachSpec.maxRepRegs)
89 :     then LT.ltc_tuple [t] else t
90 :     | _ => t),
91 :     fn t => t))
92 :     | argLty r = LT.ltc_str r (* this is INCORRECT !!!!!!! *)
93 :    
94 :     fun ltc_fun (x, y) =
95 :     if (LT.ltp_tyc x) andalso (LT.ltp_tyc y) then LT.ltc_parrow(x, y)
96 :     else LT.ltc_pfct(x, y)
97 :    
98 :     fun mkfnLty(_,_,nil) = bug "mkfnLty in nflatten"
99 :     | mkfnLty(k,CNTt::_,x::r) =
100 :     LT.ltw_iscont(x, fn [t2] => (k,ltc_fun(argLty r,t2))
101 :     | _ => bug "unexpected mkfnLty",
102 :     fn [t2] => (k,ltc_fun(argLty r, LT.ltc_tyc t2))
103 :     | _ => bug "unexpected mkfnLty",
104 :     fn x => (k, ltc_fun(argLty r,x)))
105 :     | mkfnLty(k,_,r) = (k, LT.ltc_cont([argLty r]))
106 :    
107 :     (* Note that maxfree has already been reduced by 1 (in CPScomp)
108 :     on most machines to allow for an arithtemp *)
109 :     val maxregs = maxfree - MachSpec.numCalleeSaves
110 :    
111 :     local exception UsageMap
112 :     val m : info Intmap.intmap = Intmap.new(128, UsageMap)
113 :     val umap = Intmap.map m
114 :     in
115 :     fun get i = umap i handle UsageMap => MISCinfo
116 :     val enter = Intmap.add m
117 :     end
118 :    
119 :     fun select(VAR v,i) =
120 :     (case get v
121 :     of ARGinfo(biggestSEL as ref j) => biggestSEL := Int.max(i,j)
122 :     | _ => ())
123 :     | select(LABEL v, i) = select(VAR v, i)
124 :     | select _ = ()
125 :    
126 :     fun escape(VAR v) = (case get v
127 :     of FNinfo{escape=r,...} => r := true
128 :     | _ => ())
129 :     | escape(LABEL v) = escape(VAR v)
130 :     | escape _ = ()
131 :    
132 :     fun field(v, SELp(i,_)) = select(v,i)
133 :     | field(v, _) = escape v
134 :    
135 :     val botlist = if !CG.flattenargs then map (fn _ => BOT)
136 :     else map (fn _ => TOP)
137 :    
138 :     fun enterFN (_,f,vl,_,cexp) =
139 :     (enter(f,FNinfo{arity=ref(botlist vl),alias=ref NONE,escape=ref false});
140 :     app (fn v => enter(v,ARGinfo(ref ~1))) vl)
141 :    
142 :     local exception Found
143 :     in
144 :     fun findFetch(v,k) body =
145 :     (* find whether field k of variable v is guaranteed to exist *)
146 :     let fun f(RECORD(_, fields,_,e)) = (app g fields; f e)
147 :     | f(SELECT(i,VAR v',w,_,e)) =
148 :     if v=v' andalso i=k then raise Found else f e
149 :     | f(SELECT(_,_,_,_,e)) = f e
150 :     | f(OFFSET(_,_,_,e)) = f e
151 :     | f(FIX(_,e)) = f e
152 :     | f(BRANCH(_,_,_,e1,e2)) = findFetch(v,k) e1 andalso findFetch(v,k) e2
153 :     | f(LOOKER(_,_,_,_,e)) = f e
154 :     | f(SETTER(_,_,e)) = f e
155 :     | f(ARITH(_,_,_,_,e)) = f e
156 :     | f(PURE(_,_,_,_,e)) = f e
157 :     | f(SWITCH(_,_,el)) = not(List.exists (not o findFetch(v,k)) el)
158 :     | f _ = false
159 :     and g(VAR v',SELp(i,_)) = if v=v' andalso i=k then raise Found else ()
160 :     | g _ = ()
161 :     in f body handle Found => true
162 :     end
163 :     end (* local *)
164 :    
165 :     fun checkFlatten(_,f,vl,_,body) =
166 :     case get f
167 :     of FNinfo{arity as ref al, alias, escape} =>
168 :     let fun loop(v::vl,a::al,headroom) =
169 :     (case (a,get v)
170 :     of (COUNT(c,some_non_record_actual),ARGinfo(ref j)) =>
171 :     if j > ~1 (* exists a select of the formal parameter *)
172 :     andalso headroom-(c-1) >= 0
173 :     andalso
174 :     (not (some_non_record_actual orelse !escape)
175 :     orelse !CG.extraflatten
176 :     andalso j=c-1 andalso findFetch(v,j) body)
177 :     then a::loop(vl,al,headroom-(c-1))
178 :     else TOP::loop(vl,al,headroom)
179 :     | _ =>
180 :     TOP::loop(vl,al,headroom))
181 :     | loop _ = nil
182 :    
183 :     val a' = loop(vl,al,maxregs-1-length(al))
184 :     in arity := a';
185 :     if List.exists (fn COUNT _ => true | _ => false) a'
186 :     then (alias := SOME(LV.dupLvar f); click "F"; clicks := !clicks+1)
187 :     else ()
188 :     end
189 :     | _ => () (* impossible *)
190 :    
191 :    
192 :     (**************************************************************************)
193 :     (* pass1: gather usage information on the variables in a cps expression. *)
194 :     (**************************************************************************)
195 :     val rec pass1 =
196 :     fn RECORD(_,vl,w,e) => (enter(w,RECinfo (length vl)); app field vl; pass1 e)
197 :     | SELECT (i,v,w,_,e) => (select(v,i); pass1 e)
198 :     | OFFSET (i,v,w,e) => (escape v; pass1 e)
199 :     | SWITCH(v,c,el) => (escape v; app pass1 el)
200 :     | BRANCH(i,vl,c,e1,e2) => (app escape vl; pass1 e1; pass1 e2)
201 :     | SETTER(i,vl,e) => (app escape vl; pass1 e)
202 :     | LOOKER(i,vl,w,_,e) => (app escape vl; pass1 e)
203 :     | ARITH(i,vl,w,_,e) => (app escape vl; pass1 e)
204 :     | PURE(i,vl,w,_,e) => (app escape vl; pass1 e)
205 :     | APP(VAR f, vl) =>
206 :     let fun loop (t::r,vl0 as (VAR v)::vl,n) =
207 :     (case (t,get v)
208 :     of (BOT,RECinfo sz) =>
209 :     loop(COUNT(sz,false)::r,vl0,n)
210 :     | (BOT,_) => UNK::loop(r,vl,n+1)
211 :     | (UNK,RECinfo sz) =>
212 :     loop(COUNT(sz,true)::r,vl0,n)
213 :     | (UNK,_) => UNK::loop(r,vl,n+1)
214 :     | (COUNT(a,_),RECinfo sz) =>
215 :     if a = sz then t::loop(r,vl,n+1)
216 :     else TOP::loop(r,vl,n+1)
217 :     | (COUNT(a,_),_) =>
218 :     COUNT(a,true)::loop(r,vl,n+1)
219 :     | _ => TOP::loop(r,vl,n+1))
220 :     | loop (_::r, _::vl,n) = TOP::loop(r,vl,n+1)
221 :     | loop _ = nil
222 :     in app escape vl;
223 :     case get f
224 :     of FNinfo{arity as ref al,...} => arity := loop(al,vl,0)
225 :     | _ => ()
226 :     end
227 :     | APP(f, vl) => app escape vl
228 :     | FIX(l, e) => (app enterFN l;
229 :     app (fn (_,_,_,_,body) => pass1 body) l;
230 :     pass1 e;
231 :     app checkFlatten l)
232 :    
233 :     val rec reduce =
234 :     fn RECORD (k,vl,w,e) => RECORD(k,vl, w, reduce e)
235 :     | SELECT(i,v,w,t,e) => SELECT(i,v,w,t,reduce e)
236 :     | OFFSET(i,v,w,e) => OFFSET(i,v,w,reduce e)
237 :     | SWITCH(v,c,el) => SWITCH(v,c,map reduce el)
238 :     | LOOKER(i,vl,w,t,e) => LOOKER(i,vl,w,t,reduce e)
239 :     | SETTER(i,vl,e) => SETTER(i,vl,reduce e)
240 :     | ARITH(i,vl,w,t,e) => ARITH(i,vl,w,t,reduce e)
241 :     | PURE(i,vl,w,t,e) => PURE(i,vl,w,t,reduce e)
242 :     | BRANCH(i,vl,c,e1,e2) => BRANCH(i,vl,c,reduce e1,reduce e2)
243 :     | APP(f as VAR fv, vl) =>
244 :     (case get fv
245 :     of FNinfo{arity=ref al,alias=ref(SOME f'),...} =>
246 :     let fun loop(COUNT(cnt,_)::r,v::vl,args) =
247 :     let val lt = grabty v
248 :     fun g(i,args) =
249 :     if i=cnt then loop(r,vl,args)
250 :     else let val tt = selectLty(lt,i)
251 :     val z = mkv(tt)
252 :     in SELECT(i,v,z,ctype(tt), g(i+1,(VAR z)::args))
253 :     end
254 :     in g(0,args)
255 :     end
256 :     | loop(_::r,v::vl,args) = loop(r,vl,v::args)
257 :     | loop(_,_,args) = APP(VAR f', rev args)
258 :     in loop(al,vl,nil)
259 :     end
260 :     | _ => APP(f,vl))
261 :     | APP(f,vl) => APP(f,vl)
262 :     | FIX(l,e) =>
263 :     let fun vars(0,_,l,l') = (l,l')
264 :     | vars(i,lt,l,l') =
265 :     let val tt = selectLty(lt,i-1)
266 :     in vars(i-1,lt,(mkv(tt))::l,(ctype(tt))::l')
267 :     end
268 :     fun newargs(COUNT(j,_) :: r,v::vl,_::cl) =
269 :     let val lt = getty v
270 :     val (new,ncl) = vars(j,lt,nil,nil)
271 :     val (vl',cl',bt') = newargs(r,vl,cl)
272 :     fun bodytransform body =
273 :     RECORD(RK_RECORD,
274 :     map (fn x =>(VAR x, OFFp 0)) new,
275 :     v,body)
276 :     in (new @ vl', ncl @ cl',bodytransform o bt')
277 :     end
278 :     | newargs(_::r,v::vl,ct::cl) =
279 :     let val (vl',cl',bt') = newargs(r,vl,cl)
280 :     in (v::vl',ct::cl',bt')
281 :     end
282 :     | newargs _ = ([],[],fn b=>b)
283 :     fun process_args((fdef as (fk,f,vl,cl,body))::rest) =
284 :     (case get f
285 :     of FNinfo{arity=ref al,alias=ref(SOME f'),...} =>
286 :     let val (nargs,ncl,bt) = newargs(al,vl,cl)
287 :     val (fk',lt) = mkfnLty(fk,ncl, map getty nargs)
288 :     val _ = newty(f',lt)
289 :     val wl = map LV.dupLvar vl
290 :     in
291 :     (fk,f,wl,cl,APP(VAR f,map VAR wl))::
292 :     (fk',f',nargs,ncl,bt body) :: process_args rest
293 :     end
294 :     | _ => fdef :: process_args rest)
295 :     | process_args nil = nil
296 :     fun reduce_body (fk,f,vl,cl,body) = (fk,f,vl,cl,reduce body)
297 :     in FIX(map reduce_body (process_args l), reduce e)
298 :     end
299 :    
300 :     fun fprint (function, s : string) =
301 :     (say "\n"; say s; say "\n \n"; PPCps.printcps0 function)
302 :    
303 :     val _ = (debugprint "Flatten: "; debugflush())
304 :     val _ = if debug then fprint ((fkind, fvar, fargs, ctyl, cexp), "Before flatten:") else ()
305 :     val _ = pass1 cexp;
306 :     val cexp' = if !clicks>0 then reduce cexp else cexp
307 :     val _ = if (debug) then
308 :     if (!clicks>0) then fprint ((fkind, fvar, fargs, ctyl, cexp'), "After flatten:")
309 :     else say "No flattening this time.\n"
310 :     else ()
311 :     val _ = debugprint "\n"
312 :     in (fkind, fvar, fargs, ctyl, cexp')
313 :     end
314 :    
315 :     end (* toplevel local *)
316 :     end (* functor Flatten *)
317 :    

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