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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1183 - (view) (download)

1 : monnier 16 (* Copyright 1996 by Bell Laboratories *)
2 :     (* contract.sml *)
3 :    
4 :     (*
5 :     Transformations performed by the contracter:
6 :    
7 :     TRANSFORMATION: Click: Compiler.Control.CG flag:
8 :     ------------------------------------------------------------------------
9 :     Inlining functions that are used once e betacontract
10 :     Cascaded inlining of functions q
11 :     The IF-idiom E ifidiom
12 :     Unify BRANCHs z branchfold
13 :     Constant folding:
14 :     SELECTs from known RECORDs d
15 :     Handler operations ijk handlerfold
16 :     SWITCH expressions h switchopt
17 :     ARITH expressions FGHIJKLMNOPQX arithopt
18 :     PURE expressions RSTUVWYZ0123456789 arithopt
19 :     BRANCH expressions nopvw comparefold
20 :    
21 :     Dead variable elimination: [down,up] [down,up]
22 :     RECORDs [b,B] [deadvars,deadup]
23 :     SELECTs [c,s] [deadvars,deadup]
24 :     Functions [g,f]
25 :     LOOKERs [m,*] [deadvars,deadup]
26 :     PUREs [m,*] [deadvars,deadup]
27 :     Arguments [D, ] [dropargs, ]
28 :    
29 :     Conversion Primops:
30 :     testu U(n)
31 :     test T(n)
32 :     copy C(n)
33 :     extend X(n)
34 :     trunc R(n)
35 :     *)
36 :    
37 :     signature CONTRACT = sig
38 :     val contract : {function: CPS.function,
39 : blume 733 table: LtyDef.lty IntHashTable.hash_table,
40 : monnier 16 click: string -> unit,
41 :     last: bool,
42 :     size: int ref}
43 :     -> CPS.function
44 :     end (* signature CONTRACT *)
45 :    
46 :     functor Contract(MachSpec : MACH_SPEC) : CONTRACT =
47 :     struct
48 :    
49 :     local
50 :    
51 :     open CPS
52 :     structure LT = LtyExtern
53 :     structure LV = LambdaVar
54 :    
55 :     fun inc (ri as ref i) = (ri := i+1)
56 :     fun dec (ri as ref i) = (ri := i-1)
57 :    
58 :     val wtoi = Word.toIntX
59 :     val itow = Word.fromInt
60 :    
61 :     structure CG = Control.CG
62 :    
63 :     in
64 :    
65 :     val say = Control.Print.say
66 :     fun bug s = ErrorMsg.impossible ("Contract: " ^ s)
67 :    
68 :     exception ConstFold
69 :    
70 :     fun sublist pred nil = nil
71 :     | sublist pred (hd::tl) = if (pred hd) then hd::(sublist pred tl)
72 :     else sublist pred tl
73 :    
74 :     fun map1 f (a,b) = (f a, b)
75 :     fun app2(f,nil,nil) = ()
76 :     | app2(f,a::al,b::bl) = (f(a,b);app2(f,al,bl))
77 :     | app2(f,_,_) = bug "NContract app2 783"
78 :    
79 :     fun sameName(x,VAR y) = LV.sameName(x,y)
80 :     | sameName(x,LABEL y) = LV.sameName(x,y)
81 :     | sameName _ = ()
82 :    
83 :     fun complain(t1,t2,s) =
84 :     (say (s^" ____ Type conflicting while contractions =====> \n ");
85 :     say (LT.lt_print t1); say "\n and \n "; say (LT.lt_print t2);
86 :     say "\n \n";
87 :     say "_____________________________________________________ \n")
88 :    
89 :     fun checklty s (t1,t2) = ()
90 :     (*
91 :     let fun g (LT.INT, LT.INT) = ()
92 :     | g (LT.INT32, LT.INT32) = ()
93 :     | g (LT.BOOL, LT.BOOL) = ()
94 :     | g (LT.INT, LT.BOOL) = ()
95 :     | g (LT.BOOL, LT.INT) = ()
96 :     | g (LT.REAL, LT.REAL) = ()
97 :     | g (LT.SRCONT, LT.SRCONT) = ()
98 :     | g (LT.BOXED, LT.BOXED) = ()
99 :     | g (LT.RBOXED, LT.RBOXED) = ()
100 :     | g (LT.INT, LT.RECORD nil) = ()
101 :     | g (LT.RECORD nil, LT.INT) = ()
102 :     | g (LT.BOXED, LT.RBOXED) = () (* this is temporary *)
103 :     | g (LT.RBOXED, LT.BOXED) = () (* this is temporary *)
104 :     | g (LT.ARROW(t1,t2),LT.ARROW(t1',t2')) =
105 :     (g(LT.out t1,LT.out t1'); g(LT.out t2, LT.out t2'))
106 :     | g (LT.RECORD l1,LT.RECORD l2) =
107 :     app2(g,map LT.out l1, map LT.out l2)
108 :     | g (LT.CONT t1,LT.CONT t2) = g(LT.out t1,LT.out t2)
109 :     | g (t1,t2) = complain(LT.inj t1, LT.inj t2,"CTR *** "^s)
110 :     in g(LT.out t1, LT.out t2)
111 :     end
112 :     *)
113 :    
114 :     val isCont = LT.lt_iscont
115 :    
116 :     fun equalUptoAlpha(ce1,ce2) =
117 :     let fun equ pairs =
118 :     let fun same(VAR a, VAR b) =
119 :     let fun look((x,y)::rest) = a=x andalso b=y orelse look rest
120 :     | look nil = false
121 :     in a=b orelse look pairs
122 :     end
123 :     | same(LABEL a, LABEL b) = same(VAR a, VAR b)
124 :     | same(INT i, INT j) = i=j
125 :     | same(REAL a, REAL b) = a=b
126 :     | same(STRING a, STRING b) = a=b
127 :     | same(a,b) = false
128 : blume 666 fun samefields((a,ap)::ar,(b,bp)::br) =
129 :     ap=bp andalso same(a,b) andalso samefields(ar,br)
130 : monnier 16 | samefields(nil,nil) = true
131 :     | samefields _ = false
132 :     fun samewith p = equ (p::pairs)
133 :     fun all2 f (e::r,e'::r') = f(e,e') andalso all2 f (r,r')
134 :     | all2 f (nil,nil) = true
135 :     | all2 f _ = false
136 :     val rec sameexp =
137 :     fn (SELECT(i,v,w,_,e),SELECT(i',v',w',_,e')) =>
138 :     i=i' andalso same(v,v') andalso samewith(w,w') (e,e')
139 :     | (RECORD(k,vl,w,e),RECORD(k',vl',w',e')) =>
140 :     (k = k') andalso samefields(vl,vl')
141 :     andalso samewith (w,w') (e,e')
142 :     | (OFFSET(i,v,w,e),OFFSET(i',v',w',e')) =>
143 :     i=i' andalso same(v,v') andalso samewith(w,w') (e,e')
144 :     | (SWITCH(v,c,el),SWITCH(v',c',el')) =>
145 :     same(v,v') andalso all2 (samewith(c,c')) (el,el')
146 :     | (APP(f,vl),APP(f',vl')) =>
147 :     same(f,f') andalso all2 same (vl,vl')
148 :     | (FIX(l,e),FIX(l',e')) => (* punt! *) false
149 :     | (BRANCH(i,vl,c,e1,e2),BRANCH(i',vl',c',e1',e2')) =>
150 :     i=i' andalso all2 same (vl,vl')
151 :     andalso samewith(c,c') (e1,e1')
152 :     andalso samewith(c,c') (e2,e2')
153 :     | (LOOKER(i,vl,w,_,e),LOOKER(i',vl',w',_,e')) =>
154 :     i=i' andalso all2 same (vl,vl') andalso samewith(w,w')(e,e')
155 :     | (SETTER(i,vl,e),SETTER(i',vl',e')) =>
156 :     i=i' andalso all2 same (vl,vl') andalso sameexp(e,e')
157 :     | (ARITH(i,vl,w,_,e),ARITH(i',vl',w',_,e')) =>
158 :     i=i' andalso all2 same (vl,vl') andalso samewith(w,w')(e,e')
159 :     | (PURE(i,vl,w,_,e),PURE(i',vl',w',_,e')) =>
160 :     i=i' andalso all2 same (vl,vl') andalso samewith(w,w')(e,e')
161 : leunga 1174 | (RCC(k,l,p,vl,w,_,e),RCC(k',l',p',vl',w',_,e')) =>
162 : blume 773 (* We don't need to compare protocol info: The protocols are
163 :     * the same iff the functions and arguments are the same. *)
164 : leunga 1174 k = k' andalso l = l' andalso
165 :     all2 same (vl,vl') andalso samewith(w,w')(e,e')
166 : monnier 16 | _ => false
167 :     in sameexp
168 :     end
169 :     in equ nil (ce1,ce2)
170 :     end
171 :    
172 :     datatype info = FNinfo of {args: lvar list,
173 :     body : cexp option ref,
174 :     specialuse: int ref option ref,
175 :     liveargs : bool list option ref
176 :     }
177 :     | RECinfo of (value * accesspath) list
178 :     | SELinfo of int * value * cty
179 :     | OFFinfo of int * value
180 :     | WRPinfo of P.pure * value
181 :     | IFIDIOMinfo of {body : (lvar * cexp * cexp) option ref}
182 :     | MISCinfo of cty
183 :    
184 :     fun contract {function=(fkind,fvar,fargs,ctyl,cexp),
185 :     table, click, last, size=cpssize} =
186 :     (* NOTE: the "last" argument is currently ignored. *)
187 :     let
188 :    
189 :     val deadup = !Control.CG.deadup
190 :     val CGbetacontract = !Control.CG.betacontract
191 :     val debug = !Control.CG.debugcps (* false *)
192 :     fun debugprint s = if debug then Control.Print.say(s) else ()
193 :     fun debugflush() = if debug then Control.Print.flush() else ()
194 :    
195 :     val rep_flag = MachSpec.representations
196 :     val type_flag = (!CG.checkcps1) andalso (!CG.checkcps2) andalso rep_flag
197 :    
198 :    
199 :     (* It would be nice to get rid of this type stuff one day. *)
200 :     local
201 :    
202 :     exception NCONTRACT
203 :    
204 :     fun valueName(VAR v) = LV.lvarName v
205 :     | valueName(INT i) = "Int"^Int.toString(i)
206 :     | valueName(REAL r) = "Real"^r
207 :     | valueName(STRING s) = "<"^s^">"
208 :     | valueName _ = "<others>"
209 :    
210 :     fun argLty [] = LT.ltc_int
211 :     | argLty [t] =
212 :     LT.ltw_tuple(t,
213 :     (fn xs as (_::_) => if (length(xs) < MachSpec.maxRepRegs)
214 :     then LT.ltc_tuple [t] else t
215 :     | _ => t),
216 :     fn t =>
217 :     LT.ltw_str(t,
218 :     (fn xs as (_::_) => if (length(xs) < MachSpec.maxRepRegs)
219 :     then LT.ltc_tuple [t] else t
220 :     | _ => t),
221 :     fn t => t))
222 :     | argLty r = LT.ltc_str r (* this is INCORRECT !!!!!!! *)
223 :    
224 : blume 733 val addty = if type_flag then IntHashTable.insert table else (fn _ => ())
225 : monnier 16
226 :     in
227 :    
228 :     (* Only used when dropping args in reduce(FIX) case. *)
229 :     fun getty v =
230 :     if type_flag then
231 : blume 733 (IntHashTable.lookup table v) handle _ =>
232 : monnier 16 (Control.Print.say ("NCONTRACT: Can't find the variable "^
233 :     (Int.toString v)^" in the table ***** \n");
234 :     raise NCONTRACT)
235 :     else LT.ltc_void
236 :     fun grabty u =
237 :     let fun g(VAR v) = getty v
238 :     | g(INT _) = LT.ltc_int
239 :     | g(REAL _) = LT.ltc_real
240 :     | g(STRING _) = LT.ltc_void
241 :     | g(LABEL v) = getty v
242 :     | g _ = LT.ltc_void
243 :     in if type_flag then g u
244 :     else LT.ltc_void
245 :     end
246 : blume 733 fun newty(f,t) = if type_flag then
247 :     (ignore (IntHashTable.remove table f) handle _ => ();
248 :     addty(f,t))
249 :     else ()
250 : monnier 16 fun mkv(t) = let val v = LV.mkLvar()
251 :     val _ = addty(v,t)
252 :     in v
253 :     end
254 : monnier 69
255 :     fun ltc_fun (x, y) =
256 :     if (LT.ltp_tyc x) andalso (LT.ltp_tyc y) then LT.ltc_parrow(x, y)
257 :     else LT.ltc_pfct(x, y)
258 :    
259 : monnier 16 fun mkfnLty(_,_,nil) = bug "mkfnLty in nflatten"
260 :     | mkfnLty(k,CNTt::_,x::r) =
261 : monnier 69 LT.ltw_iscont(x, fn [t2] => (k,ltc_fun(argLty r,t2))
262 : monnier 16 | _ => bug "unexpected mkfnLty",
263 : monnier 69 fn [t2] => (k,ltc_fun(argLty r, LT.ltc_tyc t2))
264 : monnier 16 | _ => bug "unexpected mkfnLty",
265 : monnier 69 fn x => (k, ltc_fun(argLty r,x)))
266 : monnier 16 | mkfnLty(k,_,r) = (k, LT.ltc_cont([argLty r]))
267 :    
268 :     (* Only used in newname *)
269 :     fun sameLty(x,u) =
270 :     let val s = (LV.lvarName(x))^(" *and* "^valueName(u))
271 :     in if type_flag then checklty s (getty x,grabty u)
272 :     else ()
273 :     end
274 :    
275 :     end (* local *)
276 :    
277 :    
278 :    
279 :    
280 :     local exception UsageMap
281 : blume 733 in val m : {info: info, used : int ref, called : int ref}
282 :     IntHashTable.hash_table =
283 :     IntHashTable.mkTable(128, UsageMap)
284 :     val get = fn i => IntHashTable.lookup m i
285 : monnier 16 handle UsageMap => bug ("UsageMap on " ^ Int.toString i)
286 : blume 733 val enter = IntHashTable.insert m
287 :     fun rmv i = ignore (IntHashTable.remove m i) handle _ => ()
288 : monnier 16 end
289 :    
290 :     fun use(VAR v) = inc(#used(get v))
291 :     | use(LABEL v) = inc(#used(get v))
292 :     | use _ = ()
293 :     fun use_less(VAR v) = if deadup then dec(#used(get v)) else ()
294 :     | use_less(LABEL v) = if deadup then dec(#used(get v)) else ()
295 :     | use_less _ = ()
296 :     fun usedOnce v = !(#used(get v)) = 1
297 :     fun used v = !(#used(get v)) > 0
298 :    
299 :     fun call(VAR v) =
300 :     let val {called,used,...} = get v
301 :     in inc called; inc used
302 :     end
303 :     | call(LABEL v) = call(VAR v)
304 :     | call _ = ()
305 :     fun call_less(VAR v) = if deadup then
306 :     let val {called,used,...} = get v
307 :     in dec called; dec used
308 :     end
309 :     else ()
310 :     | call_less(LABEL v) = call_less(VAR v)
311 :     | call_less _ = ()
312 :     fun call_and_clobber(VAR v) =
313 :     let val {called,used,info} = get v
314 :     in inc called; inc used;
315 :     case info
316 :     of FNinfo{body,...} => body := NONE
317 :     | _ => ()
318 :     end
319 :     | call_and_clobber(LABEL v) = call(VAR v)
320 :     | call_and_clobber _ = ()
321 :    
322 :     fun enterREC(w,vl) = enter(w,{info=RECinfo vl, called=ref 0,used=ref 0})
323 :     fun enterMISC (w,ct) = enter(w,{info=MISCinfo ct, called=ref 0, used=ref 0})
324 :     val miscBOG = MISCinfo BOGt
325 :     fun enterMISC0 w = enter(w,{info=miscBOG, called=ref 0, used=ref 0})
326 :     fun enterWRP(w,p,u) =
327 :     enter(w,{info=WRPinfo(p,u), called=ref 0, used=ref 0})
328 :    
329 :     fun enterFN (_,f,vl,cl,cexp) =
330 :     (enter(f,{called=ref 0,used=ref 0,
331 :     info=FNinfo{args=vl,
332 :     body=ref(if CGbetacontract then SOME cexp
333 :     else NONE),
334 :     specialuse=ref NONE,
335 :     liveargs=ref NONE}});
336 :     app2(enterMISC,vl,cl))
337 :    
338 :     (*********************************************************************
339 :     checkFunction: used by pass1(FIX ...) to decide
340 :     (1) whether a function will be inlined for the if idiom;
341 :     (2) whether a function will drop some arguments.
342 :     *********************************************************************)
343 :     fun checkFunction(_,f,vl,_,_) =
344 :     (case get f
345 :     of {called=ref 2,used=ref 2,
346 :     info=FNinfo{specialuse=ref(SOME(ref 1)),
347 :     body as ref(SOME(BRANCH(_,_,c,a,b))),...},...} =>
348 :     if not (!CG.ifidiom) then body:=NONE
349 :     else (* NOTE: remapping f *)
350 :     enter(f,{info=IFIDIOMinfo{body=ref(SOME(c,a,b))},
351 :     called=ref 2, used=ref 2})
352 :     | {called=ref c,used=ref u,info=FNinfo{liveargs,...}} =>
353 :     if u<>c (* escaping function *)
354 :     orelse not(!CG.dropargs) then ()
355 :     else liveargs := SOME(map used vl)
356 :     | _ => ())
357 :    
358 :    
359 :     (**************************************************************************)
360 :     (* pass1: gather usage information on the variables in a cps expression, *)
361 :     (* and make a few decisions about whether to inline functions: *)
362 :     (* (1) If Idiom *)
363 :     (* (2) NO_INLINE_INTO *)
364 :     (**************************************************************************)
365 :     val rec pass1 = fn cexp => p1 false cexp
366 :     and p1 = fn no_inline =>
367 :     let val rec g1 =
368 :     fn RECORD(_,vl,w,e) => (enterREC(w,vl); app (use o #1) vl; g1 e)
369 :     | SELECT (i,v,w,ct,e) =>
370 :     (enter(w,{info=SELinfo(i,v,ct), called=ref 0, used=ref 0});
371 :     use v; g1 e)
372 :     | OFFSET (i,v,w,e) =>
373 :     (enter(w,{info=OFFinfo(i,v), called=ref 0, used=ref 0});
374 :     use v; g1 e)
375 :     | APP(f, vl) => (if no_inline
376 :     then call_and_clobber f
377 :     else call f;
378 :     app use vl)
379 :     | FIX(l, e) => (app enterFN l;
380 :     app (fn (NO_INLINE_INTO,_,_,_,body) => p1 (not last) body
381 :     | (_,_,_,_,body) => g1 body) l;
382 :     g1 e;
383 :     app checkFunction l)
384 :     | SWITCH(v,c,el) => (use v; enterMISC0 c; app g1 el)
385 :     | BRANCH(i,vl,c,e1 as APP(VAR f1, [INT 1]),
386 :     e2 as APP(VAR f2, [INT 0])) =>
387 :     (case get f1
388 :     of {info=FNinfo{body=ref(SOME(BRANCH(P.cmp{oper=P.neq,...},[INT 0, VAR w2],_,_,_))),
389 :     args=[w1],specialuse,...},...} =>
390 :     (* Handle IF IDIOM *)
391 :     if f1=f2 andalso w1=w2
392 :     then let val {used,...}=get w1
393 :     in specialuse := SOME used
394 :     end
395 :     else ()
396 :     | _ => ();
397 :     app use vl; enterMISC(c,BOGt); g1 e1; g1 e2)
398 :     | BRANCH(i,vl,c,e1,e2) => (app use vl; enterMISC0 c; g1 e1; g1 e2)
399 :     | SETTER(i,vl,e) => (app use vl; g1 e)
400 :     | LOOKER(i,vl,w,_,e) => (app use vl; enterMISC0 w; g1 e)
401 :     | ARITH(i,vl,w,_,e) => (app use vl; enterMISC0 w; g1 e)
402 :     | PURE(p as P.iwrap,[u],w,_,e) => (use u; enterWRP(w,p,u); g1 e)
403 :     | PURE(p as P.iunwrap,[u],w,_,e) => (use u; enterWRP(w,p,u); g1 e)
404 :     | PURE(p as P.i32wrap,[u],w,_,e) => (use u; enterWRP(w,p,u); g1 e)
405 :     | PURE(p as P.i32unwrap,[u],w,_,e) => (use u; enterWRP(w,p,u); g1 e)
406 :     | PURE(p as P.fwrap,[u],w,_,e) => (use u; enterWRP(w,p,u); g1 e)
407 :     | PURE(p as P.funwrap,[u],w,_,e) => (use u; enterWRP(w,p,u); g1 e)
408 :     | PURE(i,vl,w,_,e) => (app use vl; enterMISC0 w; g1 e)
409 : leunga 1174 | RCC(k,l,p,vl,w,t,e) => (app use vl; enterMISC0 w; g1 e)
410 : monnier 16 in g1
411 :     end
412 :    
413 :    
414 :     local
415 :     exception Beta
416 : blume 733 val m2 : value IntHashTable.hash_table = IntHashTable.mkTable(32, Beta)
417 :     val mapm2 = IntHashTable.lookup m2
418 : monnier 16 in
419 :    
420 :     fun ren(v0 as VAR v) = (ren(mapm2 v) handle Beta => v0)
421 :     | ren(v0 as LABEL v) = (ren(mapm2 v) handle Beta => v0)
422 :     | ren x = x
423 :    
424 :     fun newname (vw as (v,w)) =
425 :     let val {used=ref u,called=ref c,...} = get v
426 :     fun f(VAR w') = let val {used,called,...} = get w'
427 :     in used := !used + u; called := !called + c
428 :     end
429 :     | f(LABEL w') = f(VAR w')
430 :     | f _ = ()
431 :     in if deadup then f (ren w) else ();
432 :     rmv v;
433 : blume 733 sameLty vw; sameName vw; IntHashTable.insert m2 vw
434 : monnier 16 end
435 :    
436 :     end (* local *)
437 :    
438 :     fun newnames(v::vl, w::wl) = (newname(v,w); newnames(vl,wl))
439 :     | newnames _ = ()
440 :    
441 :    
442 :     (*********************************************************************)
443 :     (* drop_body: used when dropping a function to adjust the usage *)
444 :     (* counts of the free variables of the function. *)
445 :     (* This should match up closely with pass1 above. *)
446 :     (*********************************************************************)
447 :     local val use_less = use_less o ren
448 :     val call_less = call_less o ren
449 :     in
450 :     fun drop_body(APP(f,vl)) = (call_less f; app use_less vl)
451 :     | drop_body(SELECT(_,v,_,_,e)) = (use_less v; drop_body e)
452 :     | drop_body(OFFSET(_,v,_,e)) = (use_less v; drop_body e)
453 :     | drop_body(RECORD(_,vl,_,e)) = (app (use_less o #1) vl; drop_body e)
454 :     | drop_body(FIX(l,e)) = (app (drop_body o #5) l; drop_body e)
455 :     | drop_body(SWITCH(v,_,el)) = (use_less v; app drop_body el)
456 :     | drop_body(BRANCH(_,vl,_,e1,e2)) = (app use_less vl;
457 :     drop_body e1; drop_body e2)
458 :     | drop_body(SETTER(_,vl,e)) = (app use_less vl; drop_body e)
459 :     | drop_body(LOOKER(_,vl,_,_,e)) = (app use_less vl; drop_body e)
460 :     | drop_body(ARITH(_,vl,_,_,e)) = (app use_less vl; drop_body e)
461 :     | drop_body(PURE(_,vl,_,_,e)) = (app use_less vl; drop_body e)
462 : leunga 1174 | drop_body(RCC(_,_,_,vl,_,_,e)) = (app use_less vl; drop_body e)
463 : monnier 16 end (* local *)
464 :    
465 :    
466 :     fun setter (P.update, [_, _, INT _]) = P.unboxedupdate
467 :     | setter (P.update, [_, _, REAL _]) = P.boxedupdate
468 :     | setter (P.update, [_, _, STRING _]) = P.boxedupdate
469 :     | setter (P.update, [_, _, VAR v]) =
470 :     (case #info(get v)
471 :     of (FNinfo _) => P.boxedupdate
472 :     | (RECinfo _) => P.boxedupdate
473 :     | (OFFinfo _) => P.boxedupdate
474 :     | _ => P.update
475 :     (* end case *))
476 : monnier 251 | setter (P.assign, [_, INT _]) = P.unboxedassign
477 : monnier 16 | setter (i, _) = i
478 :    
479 :     fun sameLvar(lvar, VAR lv) = lv = lvar
480 :     | sameLvar _ = false
481 :    
482 :     fun cvtPreCondition(n, n2, x, v2) =
483 :     n=n2 andalso usedOnce(x) andalso sameLvar(x, ren v2)
484 :    
485 :     val rec reduce = fn cexp => g NONE cexp
486 :     and g = fn hdlr =>
487 :     let val rec g' =
488 :     fn RECORD (k,vl,w,e) =>
489 :     let val {used,...} = get w
490 :     val vl' = map (map1 ren) vl
491 :     in if !used=0 andalso !CG.deadvars
492 :     then (click "b"; app (use_less o #1) vl'; g' e)
493 :     else (let fun objlen(VAR z) =
494 :     (case (#info (get z))
495 :     of SELinfo(_,_,PTRt(RPT k)) => k
496 :     | SELinfo(_,_,PTRt(FPT k)) => k
497 :     | MISCinfo(PTRt(RPT k)) => k
498 :     | MISCinfo(PTRt(FPT k)) => k
499 :     | RECinfo l => length l
500 :     | _ => ~1)
501 :     | objlen _ = ~1
502 :    
503 :     fun samevar(VAR x,VAR y) = (x=y)
504 :     | samevar _ = false
505 :    
506 :     fun check1((VAR z)::r,k,a) =
507 :     (case (get z)
508 :     of {info=SELinfo(i,b,_),...} =>
509 :     (if ((i=k) andalso (samevar(ren b,a)))
510 :     then check1(r,k+1,a) else NONE)
511 :     | _ => NONE)
512 :     | check1(_::r,k,_) = NONE
513 :     | check1([],k,a) =
514 :     if ((objlen a)=k) then SOME a else NONE
515 :    
516 :     fun check((VAR z)::r) =
517 :     (case (get z)
518 :     of {info=SELinfo(0,a,_),...} =>
519 :     check1(r,1,ren a)
520 :     | _ => NONE)
521 :     | check _ = NONE
522 :    
523 :     val vl'' = map #1 vl'
524 :    
525 :     in case (check(vl''))
526 :     of NONE =>
527 :     (let val e' = g' e
528 :     in if !used=0 andalso deadup
529 :     then (click "B"; app use_less vl''; e')
530 :     else RECORD(k, vl', w, e')
531 :     end)
532 :     | SOME z =>
533 :     (newname(w,z); click "B"; (*** ? ***)
534 :     app use_less vl''; g' e)
535 :     end)
536 :     end
537 :     | SELECT(i,v,w,t,e) =>
538 :     let val {used,...} = get w
539 :     val v' = ren v
540 :     in if !used=0 andalso !CG.deadvars
541 :     then (click "c"; (* could rmv w here *)
542 :     use_less v';
543 :     g' e)
544 :     else let val z = (case v'
545 :     of VAR v'' =>
546 :     (case get v''
547 :     of {info=RECinfo vl,...} =>
548 :     (let val z = #1(List.nth(vl,i))
549 :     val z' = ren z
550 : monnier 251 in
551 :     case z'
552 :     of REAL _ => NONE
553 :     | _ => SOME z'
554 : monnier 16 end handle Subscript => NONE)
555 :     | _ => NONE)
556 :     | _ => NONE)
557 :     val z = if !CG.selectopt then z else NONE
558 :     in case z
559 :     of NONE => let val e' = g' e
560 :     in if !used=0 andalso deadup
561 :     then (click "s";
562 :     use_less v';
563 :     e')
564 :     else SELECT(i,v',w,t,e')
565 :     end
566 :     | SOME z' => (newname(w,z');
567 :     click "d"; (* could rmv w here *)
568 :     use_less v';
569 :     g' e)
570 :     end
571 :     end
572 :     | OFFSET(i,v,w,e) => OFFSET(i,ren v,w,g' e)
573 :     | APP(f, vl) =>
574 :     let val vl' = map ren vl
575 :     val f' = ren f
576 :     fun newvl NONE = vl'
577 :     | newvl (SOME live) =
578 :     let fun z(a::al,false::bl) = z(al,bl)
579 :     | z(a::al,true::bl) = a::z(al,bl)
580 :     | z _ = nil
581 :     in (* This code may be obsolete. See the comment
582 :     in the FIX case below. *)
583 :     case z(vl',live)
584 :     of nil => [INT 0]
585 :     | [u] =>
586 :     LT.ltw_iscont(grabty u,
587 :     fn _ => [u, INT 0],
588 :     fn _ => [u, INT 0],
589 :     fn _ => [u])
590 :     | vl'' => vl''
591 :     end
592 :     fun trybeta fv =
593 :     let val {used=ref u,called=ref c,info} = get fv
594 :     in case info
595 :     of FNinfo{args,body,liveargs,...} =>
596 :     if c<>1 orelse u<>1 then APP(f',newvl(!liveargs))
597 :     else (case body
598 :     of ref(SOME b) =>
599 :     (newnames(args, vl');
600 :     call_less f';
601 :     app use_less vl';
602 :     body:=NONE;
603 :     g' b)
604 :     | _ => APP(f',newvl(!liveargs)))
605 :     | _ => APP(f',vl')
606 :     end
607 :     in case f'
608 :     of VAR fv => trybeta fv
609 :     | LABEL fv => trybeta fv
610 :     | _ => APP(f',vl')
611 :     end
612 :     | FIX(l,e) =>
613 :     let fun getinfo (x as (fk,f,vl,cl,b)) =
614 :     let val {used,called,info,...} = get f
615 :     in case info
616 :     of FNinfo{liveargs=ref(SOME live),...} =>
617 :     let fun z(a::al,false::bl) = z(al,bl)
618 :     | z(a::al,true::bl) = a::z(al,bl)
619 :     | z _ = nil
620 :     val vl' = z(vl,live)
621 :     val cl' = z(cl,live)
622 :     val drop =
623 :     foldr (fn (a,b) => if a then b else b+1) 0 live
624 :     fun dropclicks(n) =
625 :     if n > 0 then (click "D"; dropclicks(n-1))
626 :     else ()
627 :     (* The code below may be obsolete. I think that
628 :     we used to distinguish between user functions
629 :     and continuations in the closure phase by
630 :     the number of arguments, and also we might
631 :     not have been able to handle functions with
632 :     no arguments. Possibly we can now remove
633 :     these special cases. *)
634 :     val tt' = map getty vl'
635 :     val (vl'', cl'', tt'') =
636 :     case tt'
637 :     of nil =>
638 :     let val x = mkv(LT.ltc_int)
639 :     in dropclicks(drop - 1);
640 :     enterMISC0 x;
641 :     ([x],[INTt],[LT.ltc_int])
642 :     end
643 :     | [x] =>
644 :     if (isCont x)
645 :     then let val x = mkv(LT.ltc_int)
646 :     in dropclicks(drop - 1);
647 :     enterMISC0 x;
648 :     (vl'@[x], cl'@[INTt],
649 :     tt'@[LT.ltc_int])
650 :     end
651 :     else (dropclicks(drop);
652 :     (vl',cl',tt'))
653 :     | _ => (dropclicks(drop);
654 :     (vl',cl',tt'))
655 :    
656 :     val (fk',lt) = mkfnLty(fk,cl'',tt'')
657 :     in newty(f,lt);
658 :     ((fk',f,vl'',cl'',b),used,called,info)
659 :     end
660 :     | _ => (x,used,called,info)
661 :     end
662 :     fun keep (_,used,called,info) =
663 :     (case (!called,!used,info)
664 :     of (_,0,FNinfo{body as ref(SOME b),...}) =>
665 :     (click "g";
666 :     body:=NONE;
667 :     drop_body b;
668 :     false)
669 :     | (_,0,FNinfo{body=ref NONE,...}) =>
670 :     (click "g"; false)
671 :     | (1,1,FNinfo{body=ref(SOME _),...}) =>
672 :     (* NOTE: this is an optimistic click.
673 :     The call could disappear before we
674 :     get there; then the body would
675 :     not be cleared out, dangerous. *)
676 :     (click "e"; false)
677 :     | (_,_,IFIDIOMinfo{body=ref b,...}) =>
678 :     (click "E"; false)
679 :     | _ => true)
680 :     fun keep2 (_,used,_,info) =
681 :     (case (!used,info)
682 :     of (0,FNinfo{body as ref(SOME b),...}) =>
683 :     (* All occurrences were lost *)
684 :     (click "f";
685 :     body:=NONE;
686 :     drop_body b;
687 :     false)
688 :     | (0,FNinfo{body=ref NONE,...}) =>
689 :     (* We performed a cascaded inlining *)
690 :     (click "q"; false)
691 :     | (_,FNinfo{body,...}) => (body:=NONE; true)
692 :     | _ => true)
693 :     fun keep3 ((_,_,_,_,b),used,_,info) =
694 :     (case (!used,info)
695 :     of (0,FNinfo _) =>
696 :     (* All occurrences were lost *)
697 :     (click "f";
698 :     drop_body b;
699 :     false)
700 :     | _ => true)
701 :     fun reduce_body ((fk,f,vl,cl,body),used,called,info) =
702 :     ((fk,f,vl,cl,reduce body),used,called,info)
703 :     val l1 = map getinfo l
704 :     val l2 = sublist keep l1
705 :     val e' = g' e
706 :     val l3 = sublist keep2 l2
707 :     val l4 = map reduce_body l3
708 :     in case (sublist keep3 l4)
709 :     of nil => e'
710 :     | l5 => FIX(map #1 l5, e')
711 :     end
712 :     | SWITCH(v,c,el) =>
713 :     (case ren v
714 :     of v' as INT i =>
715 :     if !CG.switchopt
716 :     then let fun f(e::el,j) = (if i=j then () else drop_body e;
717 :     f(el,j+1))
718 :     | f(nil,_) = ()
719 :     in click "h";
720 :     f(el,0);
721 :     newname(c,INT 0);
722 :     g' (List.nth(el,i))
723 :     end
724 :     else SWITCH(v', c, map g' el)
725 :     | v' => SWITCH(v',c, map g' el))
726 :     | LOOKER(P.gethdlr,_,w,t,e) =>
727 :     (if !CG.handlerfold
728 :     then case hdlr
729 :     of NONE => if used w
730 :     then LOOKER(P.gethdlr,[],w,t,g (SOME(VAR w)) e)
731 :     else (click "i"; g' e)
732 :     | SOME w' => (click "j"; newname(w,w'); g' e)
733 :     else LOOKER(P.gethdlr,[],w,t,g (SOME(VAR w)) e))
734 :     | SETTER(P.sethdlr,[v as VAR vv],e) =>
735 :     let val v' as VAR vv' = ren v
736 :     val e' = g (SOME v') e
737 :     in if !CG.handlerfold
738 :     then case hdlr
739 :     of SOME (v'' as VAR vv'') =>
740 :     if vv'=vv'' then (click "k"; use_less v''; e')
741 :     else SETTER(P.sethdlr,[v'],e')
742 :     | _ => SETTER(P.sethdlr,[v'],e')
743 :     else SETTER(P.sethdlr,[v'],e')
744 :     end
745 :     (* | SETTER(i,vl,e) => SETTER(i, map ren vl, g' e) *)
746 :     | SETTER(i,vl,e) =>
747 :     let val vl' = map ren vl
748 :     in SETTER(setter (i, vl'), vl', g' e)
749 :     end
750 :     | LOOKER(i,vl,w,t,e) =>
751 :     let val vl' = map ren vl
752 :     val {used,...} = get w
753 :     in if !used=0 andalso !CG.deadvars
754 :     then (click "m"; app use_less vl'; g' e)
755 :     else let val e' = g' e
756 :     in if !used=0 andalso deadup
757 :     then (click "*"; app use_less vl'; e')
758 :     else LOOKER(i, vl', w, t, e')
759 :     end
760 :     end
761 :     | ARITH(P.test(p,n),[v],x,t,e as PURE(P.copy(n2,m),[v2],x2,t2,e2)) =>
762 :     if cvtPreCondition(n, n2, x, v2) andalso n=m then
763 :     (click "T(1)"; ARITH(P.test(p,m), [ren v], x2, t2, g' e2))
764 :     else ARITH(P.test(p,n), [ren v], x, t, g' e)
765 :     | ARITH(P.test(p,n),[v],x,t,e as ARITH(P.test(n2,m),[v2],x2,t2,e2)) =>
766 :     if cvtPreCondition(n, n2, x, v2) then
767 :     (click "T(2)"; ARITH(P.test(p,m), [ren v], x2, t2, g' e2))
768 :     else ARITH(P.test(p,n), [ren v], x, t, g' e)
769 :     | ARITH(P.testu(p,n),[v],x,t,e as PURE(P.copy(n2,m),[v2],x2,t2,e2)) =>
770 :     if cvtPreCondition(n, n2, x, v2) andalso n=m then
771 :     (click "U(1)"; ARITH(P.testu(p,m), [ren v], x2, t2, g' e2))
772 :     else ARITH(P.testu(p,n), [ren v], x, t, g' e)
773 :     | ARITH(P.testu(p,n),[v],x,t,e as ARITH(P.testu(n2,m),[v2],x2,t2,e2)) =>
774 :     if cvtPreCondition(n, n2, x, v2) then
775 :     (click "U(2)"; ARITH(P.testu(p,m), [ren v], x2, t2, g' e2))
776 :     else ARITH(P.testu(p,n), [ren v], x, t, g' e)
777 :    
778 :     | ARITH(i,vl,w,t,e) =>
779 :     let val vl' = map ren vl
780 :     in (if !CG.arithopt
781 :     then (newname(w,arith(i, vl')); app use_less vl'; g' e)
782 :     else raise ConstFold)
783 :     handle ConstFold => ARITH(i, vl', w, t, g' e)
784 :     | Overflow => ARITH(i, vl', w, t, g' e)
785 :     end
786 :    
787 :     | PURE(P.trunc(p,n), [v], x, t, e as PURE(pure, [v2], x2, t2, e2)) => let
788 :     fun skip() = PURE(P.trunc(p,n), [ren v], x, t, g' e)
789 :     fun checkClicked(tok, n2, m, pureOp) =
790 :     if cvtPreCondition(n, n2, x, v2) then
791 :     (click tok;
792 :     PURE(pureOp(p,m), [ren v], x2, t2, g' e2))
793 :     else skip()
794 :     in
795 :     case pure
796 :     of P.trunc(n2,m) => checkClicked("R(1)", n2, m, P.trunc)
797 :     | P.copy(n2,m) =>
798 :     if n2=m then checkClicked("R(2)", n2, m, P.trunc) else skip()
799 :     | _ => skip()
800 :     end
801 :     | PURE(P.extend(p,n), [v], x, t, e as PURE(pure, [v2], x2, t2, e2)) => let
802 :     fun skip() = PURE(P.extend(p,n), [ren v], x, t, g' e)
803 :     fun checkClicked(tok, n2, m, pureOp) =
804 :     if cvtPreCondition(n, n2, x, v2) then
805 :     (click tok;
806 :     PURE(pureOp(p,m), [ren v], x2, t2, g' e2))
807 :     else skip()
808 :     in
809 :     case pure
810 :     of P.extend(n2,m) => checkClicked("X(1)", n2, m, P.extend)
811 :     | P.copy(n2,m) =>
812 :     if n2 = m then checkClicked("X(2)", n2, m, P.extend) else skip()
813 :     | P.trunc(n2,m) =>
814 :     if m >= p then checkClicked("X(3)", n2, m, P.extend)
815 :     else checkClicked("X(4)", n2, m, P.trunc)
816 :     | _ => skip()
817 :     end
818 :     | PURE(P.extend(p,n), [v], x, t, e as ARITH(a, [v2], x2, t2, e2)) => let
819 :     val v' = [ren v]
820 :     fun skip() = PURE(P.extend(p,n), v', x, t, g' e)
821 :     fun checkClicked(tok, n2, m, arithOp) =
822 :     if cvtPreCondition(n, n2, x, v2) then
823 :     if m >= p then
824 :     (click tok; PURE(P.extend(p,m), v', x2, t2, g' e2))
825 :     else ARITH(arithOp(p,m), v', x2, t2, g' e2)
826 :     else skip()
827 :     in
828 :     case a
829 :     of P.test(n2, m) => checkClicked("X(5)", n2, m, P.test)
830 :     | P.testu(n2, m) => checkClicked("X(6)", n2, m, P.testu)
831 :     | _ => skip()
832 :     end
833 :     | PURE(P.copy(p,n), [v], x, t, e as PURE(pure, [v2], x2, t2, e2)) => let
834 :     val v' = [ren v]
835 :     fun skip () = PURE(P.copy(p,n), v', x, t, g' e)
836 :     fun checkClicked(tok, n2, m, pureOp) =
837 :     if cvtPreCondition(n, n2, x, v2) then
838 :     (click tok; PURE(pureOp(p,m), v', x2, t2, g' e2))
839 :     else skip()
840 :     in
841 :     case pure
842 :     of P.copy(n2,m) => checkClicked("C(1)", n2, m, P.copy)
843 :     | P.extend(n2,m) =>
844 :     if n > p then checkClicked("C(2)", n2, m, P.copy)
845 :     else if n = p then checkClicked("C(2)", n2, m, P.extend)
846 :     else skip()
847 :     | P.trunc(n2,m) =>
848 :     if m >= p then checkClicked("C(3)", n2, m, P.copy)
849 :     else if m < p then checkClicked("C(4)", n2, m, P.trunc)
850 :     else skip()
851 :     | _ => skip()
852 :     end
853 :     | PURE(P.copy(p,n), [v], x, t, e as ARITH(a, [v2], x2, t2, e2)) => let
854 :     val v' = [ren v]
855 :     fun skip () = PURE(P.copy(p,n), v', x, t, g' e)
856 :     fun checkClicked(tok, n2, m, class, arithOp) =
857 :     if cvtPreCondition(n, n2, x, v2) then
858 :     (click tok; class(arithOp(p,m), v', x2, t2, g' e2))
859 :     else skip()
860 :     in
861 :     case a
862 :     of P.test(n2,m) =>
863 :     if m >= p then checkClicked("C5", n2, m, PURE, P.copy)
864 :     else checkClicked("C6", n2, m, ARITH, P.test)
865 :     | P.testu(n2,m) =>
866 :     if m > p then checkClicked("C7", n2, m, PURE, P.copy)
867 :     else checkClicked("C8", n2, m, ARITH, P.testu)
868 :     | _ => skip()
869 :     end
870 :    
871 :     | PURE(i,vl,w,t,e) =>
872 :     let val vl' = map ren vl
873 :     val {used,...} = get w
874 :     in if !used=0 andalso !CG.deadvars
875 :     then (click "m"; app use_less vl'; g' e)
876 :     else ((if !CG.arithopt
877 :     then (newname(w,pure(i, vl')); g' e)
878 :     else raise ConstFold)
879 :     handle ConstFold =>
880 :     let val e' = g' e
881 :     in if !used=0 andalso deadup
882 :     then (app use_less vl'; click "*"; e')
883 :     else PURE(i, vl', w, t, e')
884 :     end)
885 :     end
886 : leunga 1174 | RCC(k,l,p,vl,w,t,e) =>
887 : blume 773 (* leave raw C calls alone *)
888 : leunga 1174 RCC (k, l, p, map ren vl, w, t, g' e)
889 : monnier 16 | BRANCH(i,vl,c,e1,e2) =>
890 :     let val vl' = map ren vl
891 : leunga 1174
892 :     (* Maximum number of speculatively executed conditional moves *)
893 :     val MAX_CONDMOVE_HOIST = 3
894 :    
895 :     (* This function creates conditional move from
896 :     * branches of the form:
897 :     * BRANCH(i,vl,c,APP(f,[x1]),APP(f,[x2]))
898 :     *)
899 :     fun conditionalMove() =
900 :     let (* Hoist conditional moves up from branches
901 :     * This will make them speculatively.
902 :     * We limit this number to MAX_CONDMOVE_HOIST, so
903 :     * that we don't speculatively execute everything.
904 :     *)
905 :     fun hoist(e, 0) = (fn k => k, e)
906 :     | hoist(PURE(p as P.condmove _,vl,x,t,e), n) =
907 :     let val (k, e) = hoist(e, n-1)
908 :     fun newK e = PURE(p,vl,x,t,k e)
909 :     in (newK, e)
910 :     end
911 :     | hoist(e, _) = (fn k => k, e)
912 :     val (k1, e1) = hoist(g' e1, MAX_CONDMOVE_HOIST)
913 :     val (k2, e2) = hoist(g' e2, MAX_CONDMOVE_HOIST)
914 :    
915 :     (* The default does nothing *)
916 :     fun default() = BRANCH(i, vl', c, k1 e1, k2 e2)
917 :    
918 :     (* detemine the type of conditional move *)
919 :     fun findType(f,x,y) =
920 :     let fun getTy(x,again) =
921 :     case x of
922 :     STRING _ => SOME BOGt
923 :     | LABEL _ => SOME BOGt
924 :     | REAL _ => SOME FLTt
925 :     | INT32 _ => SOME INT32t
926 :     | INT _ => SOME BOGt
927 :     | _ => again()
928 :     fun findTy() =
929 :     getTy(x, fn _ => getTy(y, fn _ => NONE))
930 :     in case #info(get f) of
931 :     FNinfo{args=[f_arg], ...} =>
932 :     (case #info(get f_arg) of
933 :     MISCinfo t => SOME t (* found type *)
934 :     | _ => findTy()
935 :     )
936 :     | _ => findTy()
937 :     end
938 :    
939 :     in case (i, e1, e2) of
940 :     (* String compares are complex, so we punt on them *)
941 :     ((P.streq | P.strneq), _, _) => default()
942 :     | (_, APP(VAR f, [x]), APP(VAR f', [y])) =>
943 :     if f = f' then
944 :     (case findType(f,x,y) of
945 :     SOME t =>
946 :     let val r = LV.mkLvar()
947 :     in say "COND MOVE\n";
948 :     k1(k2(
949 :     PURE(P.condmove i,vl' @ [x,y],
950 :     r,t,APP(VAR f,[VAR r]))))
951 :     end
952 :     | _ => (say "COND MOVE failed\n"; default())
953 :     )
954 :     else default()
955 :     | _ => default()
956 :     end
957 :    
958 :     fun noConditionalMove() = BRANCH(i, vl', c, g' e1, g' e2)
959 :    
960 : monnier 16 fun h() = (if !CG.branchfold andalso equalUptoAlpha(e1,e2)
961 :     then (click "z";
962 :     app use_less vl';
963 :     newname(c,INT 0);
964 :     drop_body e2;
965 :     g' e1)
966 :     else if !CG.comparefold
967 :     then if branch(i,vl')
968 :     then (newname(c,INT 0);
969 :     app use_less vl';
970 :     drop_body e2;
971 :     g' e1)
972 :     else (newname(c,INT 0);
973 :     app use_less vl';
974 :     drop_body e1;
975 :     g' e2)
976 :     else raise ConstFold)
977 : leunga 1174 handle ConstFold => noConditionalMove()
978 : monnier 16 fun getifidiom f =
979 :     let val f' = ren f
980 :     in case f'
981 :     of VAR v =>
982 :     (case get v
983 :     of {info=IFIDIOMinfo{body},...} => SOME body
984 :     | _ => NONE)
985 :     | _ => NONE
986 :     end
987 :     in case (e1,e2)
988 :     of (APP(VAR f, [INT 1]), APP(VAR f', [INT 0])) =>
989 :     (case (f=f', getifidiom(VAR f))
990 :     of (true,
991 :     SOME(body as ref(SOME(c',a,b)))) =>
992 :     (* Handle IF IDIOM *)
993 :     (newname(c', VAR c);
994 :     body:=NONE;
995 :     (* NOTE: could use vl' here instead of vl. *)
996 :     g'(BRANCH(i,vl,c,a,b)))
997 :     | _ => h())
998 :     | _ => h()
999 :     end
1000 :     in g'
1001 :     end
1002 :    
1003 :     and branch =
1004 :     fn (P.unboxed, vl) => not(branch(P.boxed, vl))
1005 :     | (P.boxed, [INT _]) => (click "n"; false)
1006 :     | (P.boxed, [STRING s]) => (click "o"; true)
1007 :     | (P.boxed, [VAR v]) =>
1008 :     (case get v
1009 :     of {info=RECinfo _, ...} => (click "p"; true)
1010 :     | _ => raise ConstFold)
1011 :     | (P.cmp{oper=P.<, kind}, [VAR v, VAR w]) =>
1012 :     if v=w then (click "v"; false) else raise ConstFold
1013 :     | (P.cmp{oper=P.<, kind=P.INT 31}, [INT i, INT j]) => (click "w"; i<j)
1014 :     | (P.cmp{oper=P.>,kind}, [w,v]) =>
1015 :     branch(P.cmp{oper=P.<,kind=kind},[v,w])
1016 :     | (P.cmp{oper=P.<=,kind}, [w,v]) =>
1017 :     branch(P.cmp{oper=P.>=,kind=kind},[v,w])
1018 :     | (P.cmp{oper=P.>=,kind}, vl) =>
1019 :     not(branch(P.cmp{oper=P.<,kind=kind}, vl))
1020 :     | (P.cmp{oper=P.<,kind=P.UINT 31}, [INT i, INT j]) =>
1021 :     (click "w"; if j<0 then i>=0 orelse i<j else i>=0 andalso i<j)
1022 :     | (P.cmp{oper=P.eql, kind}, [VAR v, VAR w]) =>
1023 :     (case kind
1024 :     of P.FLOAT _ => raise ConstFold (* incase of NaN's *)
1025 : blume 666 | _ => if v=w then (click "v"; true) else raise ConstFold
1026 : monnier 16 (*esac*))
1027 :     | (P.cmp{oper=P.eql,...}, [INT i, INT j]) => (click "w"; i=j)
1028 :     | (P.cmp{oper=P.neq,kind}, vl) =>
1029 :     not(branch(P.cmp{oper=P.eql,kind=kind}, vl))
1030 :     | (P.peql, [INT i, INT j]) => (click "w"; i=j)
1031 :     | (P.pneq, [v,w]) => not(branch(P.peql,[w,v]))
1032 :     | _ => raise ConstFold
1033 :    
1034 :     and arith =
1035 :     fn (P.arith{oper=P.*,...}, [INT 1, v]) => (click "F"; v)
1036 :     | (P.arith{oper=P.*,...}, [v, INT 1]) => (click "G"; v)
1037 :     | (P.arith{oper=P.*,...}, [INT 0, _]) => (click "H"; INT 0)
1038 :     | (P.arith{oper=P.*,...}, [_, INT 0]) => (click "I"; INT 0)
1039 :     | (P.arith{oper=P.*,kind=P.INT 31}, [INT i, INT j]) =>
1040 :     let val x = i*j in x+x+2; click "J"; INT x end
1041 :     | (P.arith{oper=P./,...}, [v, INT 1]) => (click "K"; v)
1042 :     | (P.arith{oper=P./,...}, [INT i, INT 0]) => raise ConstFold
1043 :     | (P.arith{oper=P./,kind=P.INT 31}, [INT i, INT j]) =>
1044 :     let val x = Int.quot(i, j) in x+x; click "L"; INT x end
1045 : blume 1183 | (P.arith{oper=P.div,...}, [v, INT 1]) => (click "K"; v)
1046 :     | (P.arith{oper=P.div,...}, [INT i, INT 0]) => raise ConstFold
1047 :     | (P.arith{oper=P.div,kind=P.INT 31}, [INT i, INT j]) =>
1048 :     let val x = Int.div(i, j) in x+x; click "L"; INT x end
1049 :     (* FIXME: should we do anything for mod or rem here? *)
1050 : monnier 16 | (P.arith{oper=P.+,...}, [INT 0, v]) => (click "M"; v)
1051 :     | (P.arith{oper=P.+,...}, [v, INT 0]) => (click "N"; v)
1052 :     | (P.arith{oper=P.+,kind=P.INT 31}, [INT i, INT j]) =>
1053 :     let val x = i+j in x+x+2; click "O"; INT x end
1054 :     | (P.arith{oper=P.-,...}, [v, INT 0]) => (click "P"; v)
1055 :     | (P.arith{oper=P.-,kind=P.INT 31}, [INT i, INT j]) =>
1056 :     let val x = i-j in x+x+2; click "Q"; INT x end
1057 :     | (P.arith{oper=P.~,kind=P.INT 31,...}, [INT i]) =>
1058 :     let val x = ~i in x+x+2; click "X"; INT x end
1059 :     | _ => raise ConstFold
1060 :    
1061 :     and pure =
1062 :     fn (P.pure_arith{oper=P.rshift,kind=P.INT 31}, [INT i, INT j]) =>
1063 :     (click "R"; INT(wtoi (Word.~>>(itow i, itow j))))
1064 :     | (P.pure_arith{oper=P.rshift,kind=P.INT 31}, [INT 0, _]) =>
1065 :     (click "S"; INT 0)
1066 :     | (P.pure_arith{oper=P.rshift,kind=P.INT 31}, [v, INT 0]) =>
1067 :     (click "T"; v)
1068 :     | (P.length, [STRING s]) => (click "V"; INT(size s))
1069 :     (* | (P.ordof, [STRING s, INT i]) => (click "W"; INT(ordof(s,i))) *)
1070 :     | (P.pure_arith{oper=P.lshift,kind=P.INT 31}, [INT i, INT j]) =>
1071 :     (let val x = wtoi (Word.<<(itow i, itow j))
1072 :     in x+x; click "Y"; INT x
1073 :     end handle Overflow => raise ConstFold)
1074 :     | (P.pure_arith{oper=P.lshift,kind=P.INT 31}, [INT 0, _]) =>
1075 :     (click "Z"; INT 0)
1076 :     | (P.pure_arith{oper=P.lshift,kind=P.INT 31}, [v, INT 0]) =>
1077 :     (click "1"; v)
1078 :     | (P.pure_arith{oper=P.orb,kind=P.INT 31}, [INT i, INT j]) =>
1079 :     (click "2"; INT(wtoi (Word.orb(itow i, itow j))))
1080 :     | (P.pure_arith{oper=P.orb,kind=P.INT 31}, [INT 0, v]) => (click "3"; v)
1081 :     | (P.pure_arith{oper=P.orb,kind=P.INT 31}, [v, INT 0]) => (click "4"; v)
1082 :     | (P.pure_arith{oper=P.xorb,kind=P.INT 31}, [INT i, INT j]) =>
1083 :     (click "5"; INT(wtoi (Word.xorb(itow i, itow j))))
1084 :     | (P.pure_arith{oper=P.xorb,kind=P.INT 31}, [INT 0, v]) =>
1085 :     (click "6"; v)
1086 :     | (P.pure_arith{oper=P.xorb,kind=P.INT 31}, [v, INT 0]) => (click "7"; v)
1087 :     | (P.pure_arith{oper=P.notb,kind=P.INT 31}, [INT i]) =>
1088 :     (click "8"; INT(wtoi (Word.notb (itow i))))
1089 :     | (P.pure_arith{oper=P.andb,kind=P.INT 31}, [INT i, INT j]) =>
1090 :     (click "9"; INT(wtoi(Word.andb(itow i, itow j))))
1091 :     | (P.pure_arith{oper=P.andb,kind=P.INT 31}, [INT 0, _]) =>
1092 :     (click "0"; INT 0)
1093 :     | (P.pure_arith{oper=P.andb,kind=P.INT 31}, [_, INT 0]) =>
1094 :     (click "T"; INT 0)
1095 :     | (P.real{fromkind=P.INT 31,tokind=P.FLOAT 64}, [INT i]) =>
1096 :     (REAL(Int.toString i ^ ".0")) (* isn't this cool? *)
1097 : blume 826 | (P.funwrap,[x as VAR v]) =>
1098 :     (case get(v) of {info=WRPinfo(P.fwrap,u),...} =>
1099 :     (click "U"; use_less x; u)
1100 : monnier 16 | _ => raise ConstFold)
1101 : blume 826 | (P.fwrap,[x as VAR v]) =>
1102 :     (case get(v) of {info=WRPinfo(P.funwrap,u),...} =>
1103 :     (click "U"; use_less x; u)
1104 : monnier 16 | _ => raise ConstFold)
1105 : blume 826 | (P.iunwrap,[x as VAR v]) =>
1106 :     (case get(v) of {info=WRPinfo(P.iwrap,u),...} =>
1107 :     (click "U"; use_less x; u)
1108 : monnier 16 | _ => raise ConstFold)
1109 : blume 826 | (P.iwrap,[x as VAR v]) =>
1110 :     (case get(v) of {info=WRPinfo(P.iunwrap,u),...} =>
1111 :     (click "U"; use_less x; u)
1112 : monnier 16 | _ => raise ConstFold)
1113 : blume 826 | (P.i32unwrap,[x as VAR v]) =>
1114 :     (case get(v) of {info=WRPinfo(P.i32wrap,u),...} =>
1115 :     (click "U"; use_less x; u)
1116 : monnier 16 | _ => raise ConstFold)
1117 : blume 826 | (P.i32wrap,[x as VAR v]) =>
1118 :     (case get(v) of {info=WRPinfo(P.i32unwrap,u),...} =>
1119 :     (click "U"; use_less x; u)
1120 : monnier 16 | _ => raise ConstFold)
1121 :     | _ => raise ConstFold
1122 :    
1123 :     in debugprint "Contract: "; debugflush();
1124 :     enterMISC0 fvar; app enterMISC0 fargs;
1125 :     pass1 cexp;
1126 : blume 733 cpssize := IntHashTable.numItems m;
1127 : monnier 16 let val cexp' = reduce cexp
1128 :     in debugprint "\n";
1129 : monnier 149 if debug
1130 : monnier 16 then (debugprint "After contract: \n";
1131 :     PPCps.prcps cexp')
1132 :     else ();
1133 :     (fkind, fvar, fargs, ctyl, cexp')
1134 :     end
1135 :     end
1136 :    
1137 :     end (* toplevel local *)
1138 :     end (* functor Contract *)
1139 :    

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