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 16 - (view) (download)

1 : monnier 16 (* 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 mkfnLty(_,_,nil) = bug "mkfnLty in nflatten"
95 :     | mkfnLty(k,CNTt::_,x::r) =
96 :     LT.ltw_iscont(x, fn [t2] => (k,LT.ltc_fun(argLty r,t2))
97 :     | _ => bug "unexpected mkfnLty",
98 :     fn [t2] => (k,LT.ltc_fun(argLty r, LT.ltc_tyc t2))
99 :     | _ => bug "unexpected mkfnLty",
100 :     fn x => (k, LT.ltc_fun(argLty r,x)))
101 :     | mkfnLty(k,_,r) = (k, LT.ltc_cont([argLty r]))
102 :    
103 :     (* Note that maxfree has already been reduced by 1 (in CPScomp)
104 :     on most machines to allow for an arithtemp *)
105 :     val maxregs = maxfree - MachSpec.numCalleeSaves
106 :    
107 :     local exception UsageMap
108 :     val m : info Intmap.intmap = Intmap.new(128, UsageMap)
109 :     val umap = Intmap.map m
110 :     in
111 :     fun get i = umap i handle UsageMap => MISCinfo
112 :     val enter = Intmap.add m
113 :     end
114 :    
115 :     fun select(VAR v,i) =
116 :     (case get v
117 :     of ARGinfo(biggestSEL as ref j) => biggestSEL := Int.max(i,j)
118 :     | _ => ())
119 :     | select(LABEL v, i) = select(VAR v, i)
120 :     | select _ = ()
121 :    
122 :     fun escape(VAR v) = (case get v
123 :     of FNinfo{escape=r,...} => r := true
124 :     | _ => ())
125 :     | escape(LABEL v) = escape(VAR v)
126 :     | escape _ = ()
127 :    
128 :     fun field(v, SELp(i,_)) = select(v,i)
129 :     | field(v, _) = escape v
130 :    
131 :     val botlist = if !CG.flattenargs then map (fn _ => BOT)
132 :     else map (fn _ => TOP)
133 :    
134 :     fun enterFN (_,f,vl,_,cexp) =
135 :     (enter(f,FNinfo{arity=ref(botlist vl),alias=ref NONE,escape=ref false});
136 :     app (fn v => enter(v,ARGinfo(ref ~1))) vl)
137 :    
138 :     local exception Found
139 :     in
140 :     fun findFetch(v,k) body =
141 :     (* find whether field k of variable v is guaranteed to exist *)
142 :     let fun f(RECORD(_, fields,_,e)) = (app g fields; f e)
143 :     | f(SELECT(i,VAR v',w,_,e)) =
144 :     if v=v' andalso i=k then raise Found else f e
145 :     | f(SELECT(_,_,_,_,e)) = f e
146 :     | f(OFFSET(_,_,_,e)) = f e
147 :     | f(FIX(_,e)) = f e
148 :     | f(BRANCH(_,_,_,e1,e2)) = findFetch(v,k) e1 andalso findFetch(v,k) e2
149 :     | f(LOOKER(_,_,_,_,e)) = f e
150 :     | f(SETTER(_,_,e)) = f e
151 :     | f(ARITH(_,_,_,_,e)) = f e
152 :     | f(PURE(_,_,_,_,e)) = f e
153 :     | f(SWITCH(_,_,el)) = not(List.exists (not o findFetch(v,k)) el)
154 :     | f _ = false
155 :     and g(VAR v',SELp(i,_)) = if v=v' andalso i=k then raise Found else ()
156 :     | g _ = ()
157 :     in f body handle Found => true
158 :     end
159 :     end (* local *)
160 :    
161 :     fun checkFlatten(_,f,vl,_,body) =
162 :     case get f
163 :     of FNinfo{arity as ref al, alias, escape} =>
164 :     let fun loop(v::vl,a::al,headroom) =
165 :     (case (a,get v)
166 :     of (COUNT(c,some_non_record_actual),ARGinfo(ref j)) =>
167 :     if j > ~1 (* exists a select of the formal parameter *)
168 :     andalso headroom-(c-1) >= 0
169 :     andalso
170 :     (not (some_non_record_actual orelse !escape)
171 :     orelse !CG.extraflatten
172 :     andalso j=c-1 andalso findFetch(v,j) body)
173 :     then a::loop(vl,al,headroom-(c-1))
174 :     else TOP::loop(vl,al,headroom)
175 :     | _ =>
176 :     TOP::loop(vl,al,headroom))
177 :     | loop _ = nil
178 :    
179 :     val a' = loop(vl,al,maxregs-1-length(al))
180 :     in arity := a';
181 :     if List.exists (fn COUNT _ => true | _ => false) a'
182 :     then (alias := SOME(LV.dupLvar f); click "F"; clicks := !clicks+1)
183 :     else ()
184 :     end
185 :     | _ => () (* impossible *)
186 :    
187 :    
188 :     (**************************************************************************)
189 :     (* pass1: gather usage information on the variables in a cps expression. *)
190 :     (**************************************************************************)
191 :     val rec pass1 =
192 :     fn RECORD(_,vl,w,e) => (enter(w,RECinfo (length vl)); app field vl; pass1 e)
193 :     | SELECT (i,v,w,_,e) => (select(v,i); pass1 e)
194 :     | OFFSET (i,v,w,e) => (escape v; pass1 e)
195 :     | SWITCH(v,c,el) => (escape v; app pass1 el)
196 :     | BRANCH(i,vl,c,e1,e2) => (app escape vl; pass1 e1; pass1 e2)
197 :     | SETTER(i,vl,e) => (app escape vl; pass1 e)
198 :     | LOOKER(i,vl,w,_,e) => (app escape vl; pass1 e)
199 :     | ARITH(i,vl,w,_,e) => (app escape vl; pass1 e)
200 :     | PURE(i,vl,w,_,e) => (app escape vl; pass1 e)
201 :     | APP(VAR f, vl) =>
202 :     let fun loop (t::r,vl0 as (VAR v)::vl,n) =
203 :     (case (t,get v)
204 :     of (BOT,RECinfo sz) =>
205 :     loop(COUNT(sz,false)::r,vl0,n)
206 :     | (BOT,_) => UNK::loop(r,vl,n+1)
207 :     | (UNK,RECinfo sz) =>
208 :     loop(COUNT(sz,true)::r,vl0,n)
209 :     | (UNK,_) => UNK::loop(r,vl,n+1)
210 :     | (COUNT(a,_),RECinfo sz) =>
211 :     if a = sz then t::loop(r,vl,n+1)
212 :     else TOP::loop(r,vl,n+1)
213 :     | (COUNT(a,_),_) =>
214 :     COUNT(a,true)::loop(r,vl,n+1)
215 :     | _ => TOP::loop(r,vl,n+1))
216 :     | loop (_::r, _::vl,n) = TOP::loop(r,vl,n+1)
217 :     | loop _ = nil
218 :     in app escape vl;
219 :     case get f
220 :     of FNinfo{arity as ref al,...} => arity := loop(al,vl,0)
221 :     | _ => ()
222 :     end
223 :     | APP(f, vl) => app escape vl
224 :     | FIX(l, e) => (app enterFN l;
225 :     app (fn (_,_,_,_,body) => pass1 body) l;
226 :     pass1 e;
227 :     app checkFlatten l)
228 :    
229 :     val rec reduce =
230 :     fn RECORD (k,vl,w,e) => RECORD(k,vl, w, reduce e)
231 :     | SELECT(i,v,w,t,e) => SELECT(i,v,w,t,reduce e)
232 :     | OFFSET(i,v,w,e) => OFFSET(i,v,w,reduce e)
233 :     | SWITCH(v,c,el) => SWITCH(v,c,map reduce el)
234 :     | LOOKER(i,vl,w,t,e) => LOOKER(i,vl,w,t,reduce e)
235 :     | SETTER(i,vl,e) => SETTER(i,vl,reduce e)
236 :     | ARITH(i,vl,w,t,e) => ARITH(i,vl,w,t,reduce e)
237 :     | PURE(i,vl,w,t,e) => PURE(i,vl,w,t,reduce e)
238 :     | BRANCH(i,vl,c,e1,e2) => BRANCH(i,vl,c,reduce e1,reduce e2)
239 :     | APP(f as VAR fv, vl) =>
240 :     (case get fv
241 :     of FNinfo{arity=ref al,alias=ref(SOME f'),...} =>
242 :     let fun loop(COUNT(cnt,_)::r,v::vl,args) =
243 :     let val lt = grabty v
244 :     fun g(i,args) =
245 :     if i=cnt then loop(r,vl,args)
246 :     else let val tt = selectLty(lt,i)
247 :     val z = mkv(tt)
248 :     in SELECT(i,v,z,ctype(tt), g(i+1,(VAR z)::args))
249 :     end
250 :     in g(0,args)
251 :     end
252 :     | loop(_::r,v::vl,args) = loop(r,vl,v::args)
253 :     | loop(_,_,args) = APP(VAR f', rev args)
254 :     in loop(al,vl,nil)
255 :     end
256 :     | _ => APP(f,vl))
257 :     | APP(f,vl) => APP(f,vl)
258 :     | FIX(l,e) =>
259 :     let fun vars(0,_,l,l') = (l,l')
260 :     | vars(i,lt,l,l') =
261 :     let val tt = selectLty(lt,i-1)
262 :     in vars(i-1,lt,(mkv(tt))::l,(ctype(tt))::l')
263 :     end
264 :     fun newargs(COUNT(j,_) :: r,v::vl,_::cl) =
265 :     let val lt = getty v
266 :     val (new,ncl) = vars(j,lt,nil,nil)
267 :     val (vl',cl',bt') = newargs(r,vl,cl)
268 :     fun bodytransform body =
269 :     RECORD(RK_RECORD,
270 :     map (fn x =>(VAR x, OFFp 0)) new,
271 :     v,body)
272 :     in (new @ vl', ncl @ cl',bodytransform o bt')
273 :     end
274 :     | newargs(_::r,v::vl,ct::cl) =
275 :     let val (vl',cl',bt') = newargs(r,vl,cl)
276 :     in (v::vl',ct::cl',bt')
277 :     end
278 :     | newargs _ = ([],[],fn b=>b)
279 :     fun process_args((fdef as (fk,f,vl,cl,body))::rest) =
280 :     (case get f
281 :     of FNinfo{arity=ref al,alias=ref(SOME f'),...} =>
282 :     let val (nargs,ncl,bt) = newargs(al,vl,cl)
283 :     val (fk',lt) = mkfnLty(fk,ncl, map getty nargs)
284 :     val _ = newty(f',lt)
285 :     val wl = map LV.dupLvar vl
286 :     in
287 :     (fk,f,wl,cl,APP(VAR f,map VAR wl))::
288 :     (fk',f',nargs,ncl,bt body) :: process_args rest
289 :     end
290 :     | _ => fdef :: process_args rest)
291 :     | process_args nil = nil
292 :     fun reduce_body (fk,f,vl,cl,body) = (fk,f,vl,cl,reduce body)
293 :     in FIX(map reduce_body (process_args l), reduce e)
294 :     end
295 :    
296 :     fun fprint (function, s : string) =
297 :     (say "\n"; say s; say "\n \n"; PPCps.printcps0 function)
298 :    
299 :     val _ = (debugprint "Flatten: "; debugflush())
300 :     val _ = if debug then fprint ((fkind, fvar, fargs, ctyl, cexp), "Before flatten:") else ()
301 :     val _ = pass1 cexp;
302 :     val cexp' = if !clicks>0 then reduce cexp else cexp
303 :     val _ = if (debug) then
304 :     if (!clicks>0) then fprint ((fkind, fvar, fargs, ctyl, cexp'), "After flatten:")
305 :     else say "No flattening this time.\n"
306 :     else ()
307 :     val _ = debugprint "\n"
308 :     in (fkind, fvar, fargs, ctyl, cexp')
309 :     end
310 :    
311 :     end (* toplevel local *)
312 :     end (* functor Flatten *)
313 :    
314 :     (*
315 :     * $Log: flatten.sml,v $
316 :     * Revision 1.1.1.1 1997/01/14 01:38:31 george
317 :     * Version 109.24
318 :     *
319 :     *)

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