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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 4540 - (view) (download)

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

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