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 826 - (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 : blume 773 | (RCC(p,vl,w,_,e),RCC(p',vl',w',_,e')) =>
162 :     (* We don't need to compare protocol info: The protocols are
163 :     * the same iff the functions and arguments are the same. *)
164 :     all2 same (vl,vl') andalso samewith(w,w')(e,e')
165 : monnier 16 | _ => false
166 :     in sameexp
167 :     end
168 :     in equ nil (ce1,ce2)
169 :     end
170 :    
171 :     datatype info = FNinfo of {args: lvar list,
172 :     body : cexp option ref,
173 :     specialuse: int ref option ref,
174 :     liveargs : bool list option ref
175 :     }
176 :     | RECinfo of (value * accesspath) list
177 :     | SELinfo of int * value * cty
178 :     | OFFinfo of int * value
179 :     | WRPinfo of P.pure * value
180 :     | IFIDIOMinfo of {body : (lvar * cexp * cexp) option ref}
181 :     | MISCinfo of cty
182 :    
183 :     fun contract {function=(fkind,fvar,fargs,ctyl,cexp),
184 :     table, click, last, size=cpssize} =
185 :     (* NOTE: the "last" argument is currently ignored. *)
186 :     let
187 :    
188 :     val deadup = !Control.CG.deadup
189 :     val CGbetacontract = !Control.CG.betacontract
190 :     val debug = !Control.CG.debugcps (* false *)
191 :     fun debugprint s = if debug then Control.Print.say(s) else ()
192 :     fun debugflush() = if debug then Control.Print.flush() else ()
193 :    
194 :     val rep_flag = MachSpec.representations
195 :     val type_flag = (!CG.checkcps1) andalso (!CG.checkcps2) andalso rep_flag
196 :    
197 :    
198 :     (* It would be nice to get rid of this type stuff one day. *)
199 :     local
200 :    
201 :     exception NCONTRACT
202 :    
203 :     fun valueName(VAR v) = LV.lvarName v
204 :     | valueName(INT i) = "Int"^Int.toString(i)
205 :     | valueName(REAL r) = "Real"^r
206 :     | valueName(STRING s) = "<"^s^">"
207 :     | valueName _ = "<others>"
208 :    
209 :     fun argLty [] = LT.ltc_int
210 :     | argLty [t] =
211 :     LT.ltw_tuple(t,
212 :     (fn xs as (_::_) => if (length(xs) < MachSpec.maxRepRegs)
213 :     then LT.ltc_tuple [t] else t
214 :     | _ => t),
215 :     fn t =>
216 :     LT.ltw_str(t,
217 :     (fn xs as (_::_) => if (length(xs) < MachSpec.maxRepRegs)
218 :     then LT.ltc_tuple [t] else t
219 :     | _ => t),
220 :     fn t => t))
221 :     | argLty r = LT.ltc_str r (* this is INCORRECT !!!!!!! *)
222 :    
223 : blume 733 val addty = if type_flag then IntHashTable.insert table else (fn _ => ())
224 : monnier 16
225 :     in
226 :    
227 :     (* Only used when dropping args in reduce(FIX) case. *)
228 :     fun getty v =
229 :     if type_flag then
230 : blume 733 (IntHashTable.lookup table v) handle _ =>
231 : monnier 16 (Control.Print.say ("NCONTRACT: Can't find the variable "^
232 :     (Int.toString v)^" in the table ***** \n");
233 :     raise NCONTRACT)
234 :     else LT.ltc_void
235 :     fun grabty u =
236 :     let fun g(VAR v) = getty v
237 :     | g(INT _) = LT.ltc_int
238 :     | g(REAL _) = LT.ltc_real
239 :     | g(STRING _) = LT.ltc_void
240 :     | g(LABEL v) = getty v
241 :     | g _ = LT.ltc_void
242 :     in if type_flag then g u
243 :     else LT.ltc_void
244 :     end
245 : blume 733 fun newty(f,t) = if type_flag then
246 :     (ignore (IntHashTable.remove table f) handle _ => ();
247 :     addty(f,t))
248 :     else ()
249 : monnier 16 fun mkv(t) = let val v = LV.mkLvar()
250 :     val _ = addty(v,t)
251 :     in v
252 :     end
253 : monnier 69
254 :     fun ltc_fun (x, y) =
255 :     if (LT.ltp_tyc x) andalso (LT.ltp_tyc y) then LT.ltc_parrow(x, y)
256 :     else LT.ltc_pfct(x, y)
257 :    
258 : monnier 16 fun mkfnLty(_,_,nil) = bug "mkfnLty in nflatten"
259 :     | mkfnLty(k,CNTt::_,x::r) =
260 : monnier 69 LT.ltw_iscont(x, fn [t2] => (k,ltc_fun(argLty r,t2))
261 : monnier 16 | _ => bug "unexpected mkfnLty",
262 : monnier 69 fn [t2] => (k,ltc_fun(argLty r, LT.ltc_tyc t2))
263 : monnier 16 | _ => bug "unexpected mkfnLty",
264 : monnier 69 fn x => (k, ltc_fun(argLty r,x)))
265 : monnier 16 | mkfnLty(k,_,r) = (k, LT.ltc_cont([argLty r]))
266 :    
267 :     (* Only used in newname *)
268 :     fun sameLty(x,u) =
269 :     let val s = (LV.lvarName(x))^(" *and* "^valueName(u))
270 :     in if type_flag then checklty s (getty x,grabty u)
271 :     else ()
272 :     end
273 :    
274 :     end (* local *)
275 :    
276 :    
277 :    
278 :    
279 :     local exception UsageMap
280 : blume 733 in val m : {info: info, used : int ref, called : int ref}
281 :     IntHashTable.hash_table =
282 :     IntHashTable.mkTable(128, UsageMap)
283 :     val get = fn i => IntHashTable.lookup m i
284 : monnier 16 handle UsageMap => bug ("UsageMap on " ^ Int.toString i)
285 : blume 733 val enter = IntHashTable.insert m
286 :     fun rmv i = ignore (IntHashTable.remove m i) handle _ => ()
287 : monnier 16 end
288 :    
289 :     fun use(VAR v) = inc(#used(get v))
290 :     | use(LABEL v) = inc(#used(get v))
291 :     | use _ = ()
292 :     fun use_less(VAR v) = if deadup then dec(#used(get v)) else ()
293 :     | use_less(LABEL v) = if deadup then dec(#used(get v)) else ()
294 :     | use_less _ = ()
295 :     fun usedOnce v = !(#used(get v)) = 1
296 :     fun used v = !(#used(get v)) > 0
297 :    
298 :     fun call(VAR v) =
299 :     let val {called,used,...} = get v
300 :     in inc called; inc used
301 :     end
302 :     | call(LABEL v) = call(VAR v)
303 :     | call _ = ()
304 :     fun call_less(VAR v) = if deadup then
305 :     let val {called,used,...} = get v
306 :     in dec called; dec used
307 :     end
308 :     else ()
309 :     | call_less(LABEL v) = call_less(VAR v)
310 :     | call_less _ = ()
311 :     fun call_and_clobber(VAR v) =
312 :     let val {called,used,info} = get v
313 :     in inc called; inc used;
314 :     case info
315 :     of FNinfo{body,...} => body := NONE
316 :     | _ => ()
317 :     end
318 :     | call_and_clobber(LABEL v) = call(VAR v)
319 :     | call_and_clobber _ = ()
320 :    
321 :     fun enterREC(w,vl) = enter(w,{info=RECinfo vl, called=ref 0,used=ref 0})
322 :     fun enterMISC (w,ct) = enter(w,{info=MISCinfo ct, called=ref 0, used=ref 0})
323 :     val miscBOG = MISCinfo BOGt
324 :     fun enterMISC0 w = enter(w,{info=miscBOG, called=ref 0, used=ref 0})
325 :     fun enterWRP(w,p,u) =
326 :     enter(w,{info=WRPinfo(p,u), called=ref 0, used=ref 0})
327 :    
328 :     fun enterFN (_,f,vl,cl,cexp) =
329 :     (enter(f,{called=ref 0,used=ref 0,
330 :     info=FNinfo{args=vl,
331 :     body=ref(if CGbetacontract then SOME cexp
332 :     else NONE),
333 :     specialuse=ref NONE,
334 :     liveargs=ref NONE}});
335 :     app2(enterMISC,vl,cl))
336 :    
337 :     (*********************************************************************
338 :     checkFunction: used by pass1(FIX ...) to decide
339 :     (1) whether a function will be inlined for the if idiom;
340 :     (2) whether a function will drop some arguments.
341 :     *********************************************************************)
342 :     fun checkFunction(_,f,vl,_,_) =
343 :     (case get f
344 :     of {called=ref 2,used=ref 2,
345 :     info=FNinfo{specialuse=ref(SOME(ref 1)),
346 :     body as ref(SOME(BRANCH(_,_,c,a,b))),...},...} =>
347 :     if not (!CG.ifidiom) then body:=NONE
348 :     else (* NOTE: remapping f *)
349 :     enter(f,{info=IFIDIOMinfo{body=ref(SOME(c,a,b))},
350 :     called=ref 2, used=ref 2})
351 :     | {called=ref c,used=ref u,info=FNinfo{liveargs,...}} =>
352 :     if u<>c (* escaping function *)
353 :     orelse not(!CG.dropargs) then ()
354 :     else liveargs := SOME(map used vl)
355 :     | _ => ())
356 :    
357 :    
358 :     (**************************************************************************)
359 :     (* pass1: gather usage information on the variables in a cps expression, *)
360 :     (* and make a few decisions about whether to inline functions: *)
361 :     (* (1) If Idiom *)
362 :     (* (2) NO_INLINE_INTO *)
363 :     (**************************************************************************)
364 :     val rec pass1 = fn cexp => p1 false cexp
365 :     and p1 = fn no_inline =>
366 :     let val rec g1 =
367 :     fn RECORD(_,vl,w,e) => (enterREC(w,vl); app (use o #1) vl; g1 e)
368 :     | SELECT (i,v,w,ct,e) =>
369 :     (enter(w,{info=SELinfo(i,v,ct), called=ref 0, used=ref 0});
370 :     use v; g1 e)
371 :     | OFFSET (i,v,w,e) =>
372 :     (enter(w,{info=OFFinfo(i,v), called=ref 0, used=ref 0});
373 :     use v; g1 e)
374 :     | APP(f, vl) => (if no_inline
375 :     then call_and_clobber f
376 :     else call f;
377 :     app use vl)
378 :     | FIX(l, e) => (app enterFN l;
379 :     app (fn (NO_INLINE_INTO,_,_,_,body) => p1 (not last) body
380 :     | (_,_,_,_,body) => g1 body) l;
381 :     g1 e;
382 :     app checkFunction l)
383 :     | SWITCH(v,c,el) => (use v; enterMISC0 c; app g1 el)
384 :     | BRANCH(i,vl,c,e1 as APP(VAR f1, [INT 1]),
385 :     e2 as APP(VAR f2, [INT 0])) =>
386 :     (case get f1
387 :     of {info=FNinfo{body=ref(SOME(BRANCH(P.cmp{oper=P.neq,...},[INT 0, VAR w2],_,_,_))),
388 :     args=[w1],specialuse,...},...} =>
389 :     (* Handle IF IDIOM *)
390 :     if f1=f2 andalso w1=w2
391 :     then let val {used,...}=get w1
392 :     in specialuse := SOME used
393 :     end
394 :     else ()
395 :     | _ => ();
396 :     app use vl; enterMISC(c,BOGt); g1 e1; g1 e2)
397 :     | BRANCH(i,vl,c,e1,e2) => (app use vl; enterMISC0 c; g1 e1; g1 e2)
398 :     | SETTER(i,vl,e) => (app use vl; g1 e)
399 :     | LOOKER(i,vl,w,_,e) => (app use vl; enterMISC0 w; g1 e)
400 :     | ARITH(i,vl,w,_,e) => (app use vl; enterMISC0 w; g1 e)
401 :     | PURE(p as P.iwrap,[u],w,_,e) => (use u; enterWRP(w,p,u); g1 e)
402 :     | PURE(p as P.iunwrap,[u],w,_,e) => (use u; enterWRP(w,p,u); g1 e)
403 :     | PURE(p as P.i32wrap,[u],w,_,e) => (use u; enterWRP(w,p,u); g1 e)
404 :     | PURE(p as P.i32unwrap,[u],w,_,e) => (use u; enterWRP(w,p,u); g1 e)
405 :     | PURE(p as P.fwrap,[u],w,_,e) => (use u; enterWRP(w,p,u); g1 e)
406 :     | PURE(p as P.funwrap,[u],w,_,e) => (use u; enterWRP(w,p,u); g1 e)
407 :     | PURE(i,vl,w,_,e) => (app use vl; enterMISC0 w; g1 e)
408 : blume 773 | RCC(p,vl,w,t,e) => (app use vl; enterMISC0 w; g1 e)
409 : monnier 16 in g1
410 :     end
411 :    
412 :    
413 :     local
414 :     exception Beta
415 : blume 733 val m2 : value IntHashTable.hash_table = IntHashTable.mkTable(32, Beta)
416 :     val mapm2 = IntHashTable.lookup m2
417 : monnier 16 in
418 :    
419 :     fun ren(v0 as VAR v) = (ren(mapm2 v) handle Beta => v0)
420 :     | ren(v0 as LABEL v) = (ren(mapm2 v) handle Beta => v0)
421 :     | ren x = x
422 :    
423 :     fun newname (vw as (v,w)) =
424 :     let val {used=ref u,called=ref c,...} = get v
425 :     fun f(VAR w') = let val {used,called,...} = get w'
426 :     in used := !used + u; called := !called + c
427 :     end
428 :     | f(LABEL w') = f(VAR w')
429 :     | f _ = ()
430 :     in if deadup then f (ren w) else ();
431 :     rmv v;
432 : blume 733 sameLty vw; sameName vw; IntHashTable.insert m2 vw
433 : monnier 16 end
434 :    
435 :     end (* local *)
436 :    
437 :     fun newnames(v::vl, w::wl) = (newname(v,w); newnames(vl,wl))
438 :     | newnames _ = ()
439 :    
440 :    
441 :     (*********************************************************************)
442 :     (* drop_body: used when dropping a function to adjust the usage *)
443 :     (* counts of the free variables of the function. *)
444 :     (* This should match up closely with pass1 above. *)
445 :     (*********************************************************************)
446 :     local val use_less = use_less o ren
447 :     val call_less = call_less o ren
448 :     in
449 :     fun drop_body(APP(f,vl)) = (call_less f; app use_less vl)
450 :     | drop_body(SELECT(_,v,_,_,e)) = (use_less v; drop_body e)
451 :     | drop_body(OFFSET(_,v,_,e)) = (use_less v; drop_body e)
452 :     | drop_body(RECORD(_,vl,_,e)) = (app (use_less o #1) vl; drop_body e)
453 :     | drop_body(FIX(l,e)) = (app (drop_body o #5) l; drop_body e)
454 :     | drop_body(SWITCH(v,_,el)) = (use_less v; app drop_body el)
455 :     | drop_body(BRANCH(_,vl,_,e1,e2)) = (app use_less vl;
456 :     drop_body e1; drop_body e2)
457 :     | drop_body(SETTER(_,vl,e)) = (app use_less vl; drop_body e)
458 :     | drop_body(LOOKER(_,vl,_,_,e)) = (app use_less vl; drop_body e)
459 :     | drop_body(ARITH(_,vl,_,_,e)) = (app use_less vl; drop_body e)
460 :     | drop_body(PURE(_,vl,_,_,e)) = (app use_less vl; drop_body e)
461 : blume 773 | drop_body(RCC(_,vl,_,_,e)) = (app use_less vl; drop_body e)
462 : monnier 16 end (* local *)
463 :    
464 :    
465 :     fun setter (P.update, [_, _, INT _]) = P.unboxedupdate
466 :     | setter (P.update, [_, _, REAL _]) = P.boxedupdate
467 :     | setter (P.update, [_, _, STRING _]) = P.boxedupdate
468 :     | setter (P.update, [_, _, VAR v]) =
469 :     (case #info(get v)
470 :     of (FNinfo _) => P.boxedupdate
471 :     | (RECinfo _) => P.boxedupdate
472 :     | (OFFinfo _) => P.boxedupdate
473 :     | _ => P.update
474 :     (* end case *))
475 : monnier 251 | setter (P.assign, [_, INT _]) = P.unboxedassign
476 : monnier 16 | setter (i, _) = i
477 :    
478 :     fun sameLvar(lvar, VAR lv) = lv = lvar
479 :     | sameLvar _ = false
480 :    
481 :     fun cvtPreCondition(n, n2, x, v2) =
482 :     n=n2 andalso usedOnce(x) andalso sameLvar(x, ren v2)
483 :    
484 :     val rec reduce = fn cexp => g NONE cexp
485 :     and g = fn hdlr =>
486 :     let val rec g' =
487 :     fn RECORD (k,vl,w,e) =>
488 :     let val {used,...} = get w
489 :     val vl' = map (map1 ren) vl
490 :     in if !used=0 andalso !CG.deadvars
491 :     then (click "b"; app (use_less o #1) vl'; g' e)
492 :     else (let fun objlen(VAR z) =
493 :     (case (#info (get z))
494 :     of SELinfo(_,_,PTRt(RPT k)) => k
495 :     | SELinfo(_,_,PTRt(FPT k)) => k
496 :     | MISCinfo(PTRt(RPT k)) => k
497 :     | MISCinfo(PTRt(FPT k)) => k
498 :     | RECinfo l => length l
499 :     | _ => ~1)
500 :     | objlen _ = ~1
501 :    
502 :     fun samevar(VAR x,VAR y) = (x=y)
503 :     | samevar _ = false
504 :    
505 :     fun check1((VAR z)::r,k,a) =
506 :     (case (get z)
507 :     of {info=SELinfo(i,b,_),...} =>
508 :     (if ((i=k) andalso (samevar(ren b,a)))
509 :     then check1(r,k+1,a) else NONE)
510 :     | _ => NONE)
511 :     | check1(_::r,k,_) = NONE
512 :     | check1([],k,a) =
513 :     if ((objlen a)=k) then SOME a else NONE
514 :    
515 :     fun check((VAR z)::r) =
516 :     (case (get z)
517 :     of {info=SELinfo(0,a,_),...} =>
518 :     check1(r,1,ren a)
519 :     | _ => NONE)
520 :     | check _ = NONE
521 :    
522 :     val vl'' = map #1 vl'
523 :    
524 :     in case (check(vl''))
525 :     of NONE =>
526 :     (let val e' = g' e
527 :     in if !used=0 andalso deadup
528 :     then (click "B"; app use_less vl''; e')
529 :     else RECORD(k, vl', w, e')
530 :     end)
531 :     | SOME z =>
532 :     (newname(w,z); click "B"; (*** ? ***)
533 :     app use_less vl''; g' e)
534 :     end)
535 :     end
536 :     | SELECT(i,v,w,t,e) =>
537 :     let val {used,...} = get w
538 :     val v' = ren v
539 :     in if !used=0 andalso !CG.deadvars
540 :     then (click "c"; (* could rmv w here *)
541 :     use_less v';
542 :     g' e)
543 :     else let val z = (case v'
544 :     of VAR v'' =>
545 :     (case get v''
546 :     of {info=RECinfo vl,...} =>
547 :     (let val z = #1(List.nth(vl,i))
548 :     val z' = ren z
549 : monnier 251 in
550 :     case z'
551 :     of REAL _ => NONE
552 :     | _ => SOME z'
553 : monnier 16 end handle Subscript => NONE)
554 :     | _ => NONE)
555 :     | _ => NONE)
556 :     val z = if !CG.selectopt then z else NONE
557 :     in case z
558 :     of NONE => let val e' = g' e
559 :     in if !used=0 andalso deadup
560 :     then (click "s";
561 :     use_less v';
562 :     e')
563 :     else SELECT(i,v',w,t,e')
564 :     end
565 :     | SOME z' => (newname(w,z');
566 :     click "d"; (* could rmv w here *)
567 :     use_less v';
568 :     g' e)
569 :     end
570 :     end
571 :     | OFFSET(i,v,w,e) => OFFSET(i,ren v,w,g' e)
572 :     | APP(f, vl) =>
573 :     let val vl' = map ren vl
574 :     val f' = ren f
575 :     fun newvl NONE = vl'
576 :     | newvl (SOME live) =
577 :     let fun z(a::al,false::bl) = z(al,bl)
578 :     | z(a::al,true::bl) = a::z(al,bl)
579 :     | z _ = nil
580 :     in (* This code may be obsolete. See the comment
581 :     in the FIX case below. *)
582 :     case z(vl',live)
583 :     of nil => [INT 0]
584 :     | [u] =>
585 :     LT.ltw_iscont(grabty u,
586 :     fn _ => [u, INT 0],
587 :     fn _ => [u, INT 0],
588 :     fn _ => [u])
589 :     | vl'' => vl''
590 :     end
591 :     fun trybeta fv =
592 :     let val {used=ref u,called=ref c,info} = get fv
593 :     in case info
594 :     of FNinfo{args,body,liveargs,...} =>
595 :     if c<>1 orelse u<>1 then APP(f',newvl(!liveargs))
596 :     else (case body
597 :     of ref(SOME b) =>
598 :     (newnames(args, vl');
599 :     call_less f';
600 :     app use_less vl';
601 :     body:=NONE;
602 :     g' b)
603 :     | _ => APP(f',newvl(!liveargs)))
604 :     | _ => APP(f',vl')
605 :     end
606 :     in case f'
607 :     of VAR fv => trybeta fv
608 :     | LABEL fv => trybeta fv
609 :     | _ => APP(f',vl')
610 :     end
611 :     | FIX(l,e) =>
612 :     let fun getinfo (x as (fk,f,vl,cl,b)) =
613 :     let val {used,called,info,...} = get f
614 :     in case info
615 :     of FNinfo{liveargs=ref(SOME live),...} =>
616 :     let fun z(a::al,false::bl) = z(al,bl)
617 :     | z(a::al,true::bl) = a::z(al,bl)
618 :     | z _ = nil
619 :     val vl' = z(vl,live)
620 :     val cl' = z(cl,live)
621 :     val drop =
622 :     foldr (fn (a,b) => if a then b else b+1) 0 live
623 :     fun dropclicks(n) =
624 :     if n > 0 then (click "D"; dropclicks(n-1))
625 :     else ()
626 :     (* The code below may be obsolete. I think that
627 :     we used to distinguish between user functions
628 :     and continuations in the closure phase by
629 :     the number of arguments, and also we might
630 :     not have been able to handle functions with
631 :     no arguments. Possibly we can now remove
632 :     these special cases. *)
633 :     val tt' = map getty vl'
634 :     val (vl'', cl'', tt'') =
635 :     case tt'
636 :     of nil =>
637 :     let val x = mkv(LT.ltc_int)
638 :     in dropclicks(drop - 1);
639 :     enterMISC0 x;
640 :     ([x],[INTt],[LT.ltc_int])
641 :     end
642 :     | [x] =>
643 :     if (isCont x)
644 :     then let val x = mkv(LT.ltc_int)
645 :     in dropclicks(drop - 1);
646 :     enterMISC0 x;
647 :     (vl'@[x], cl'@[INTt],
648 :     tt'@[LT.ltc_int])
649 :     end
650 :     else (dropclicks(drop);
651 :     (vl',cl',tt'))
652 :     | _ => (dropclicks(drop);
653 :     (vl',cl',tt'))
654 :    
655 :     val (fk',lt) = mkfnLty(fk,cl'',tt'')
656 :     in newty(f,lt);
657 :     ((fk',f,vl'',cl'',b),used,called,info)
658 :     end
659 :     | _ => (x,used,called,info)
660 :     end
661 :     fun keep (_,used,called,info) =
662 :     (case (!called,!used,info)
663 :     of (_,0,FNinfo{body as ref(SOME b),...}) =>
664 :     (click "g";
665 :     body:=NONE;
666 :     drop_body b;
667 :     false)
668 :     | (_,0,FNinfo{body=ref NONE,...}) =>
669 :     (click "g"; false)
670 :     | (1,1,FNinfo{body=ref(SOME _),...}) =>
671 :     (* NOTE: this is an optimistic click.
672 :     The call could disappear before we
673 :     get there; then the body would
674 :     not be cleared out, dangerous. *)
675 :     (click "e"; false)
676 :     | (_,_,IFIDIOMinfo{body=ref b,...}) =>
677 :     (click "E"; false)
678 :     | _ => true)
679 :     fun keep2 (_,used,_,info) =
680 :     (case (!used,info)
681 :     of (0,FNinfo{body as ref(SOME b),...}) =>
682 :     (* All occurrences were lost *)
683 :     (click "f";
684 :     body:=NONE;
685 :     drop_body b;
686 :     false)
687 :     | (0,FNinfo{body=ref NONE,...}) =>
688 :     (* We performed a cascaded inlining *)
689 :     (click "q"; false)
690 :     | (_,FNinfo{body,...}) => (body:=NONE; true)
691 :     | _ => true)
692 :     fun keep3 ((_,_,_,_,b),used,_,info) =
693 :     (case (!used,info)
694 :     of (0,FNinfo _) =>
695 :     (* All occurrences were lost *)
696 :     (click "f";
697 :     drop_body b;
698 :     false)
699 :     | _ => true)
700 :     fun reduce_body ((fk,f,vl,cl,body),used,called,info) =
701 :     ((fk,f,vl,cl,reduce body),used,called,info)
702 :     val l1 = map getinfo l
703 :     val l2 = sublist keep l1
704 :     val e' = g' e
705 :     val l3 = sublist keep2 l2
706 :     val l4 = map reduce_body l3
707 :     in case (sublist keep3 l4)
708 :     of nil => e'
709 :     | l5 => FIX(map #1 l5, e')
710 :     end
711 :     | SWITCH(v,c,el) =>
712 :     (case ren v
713 :     of v' as INT i =>
714 :     if !CG.switchopt
715 :     then let fun f(e::el,j) = (if i=j then () else drop_body e;
716 :     f(el,j+1))
717 :     | f(nil,_) = ()
718 :     in click "h";
719 :     f(el,0);
720 :     newname(c,INT 0);
721 :     g' (List.nth(el,i))
722 :     end
723 :     else SWITCH(v', c, map g' el)
724 :     | v' => SWITCH(v',c, map g' el))
725 :     | LOOKER(P.gethdlr,_,w,t,e) =>
726 :     (if !CG.handlerfold
727 :     then case hdlr
728 :     of NONE => if used w
729 :     then LOOKER(P.gethdlr,[],w,t,g (SOME(VAR w)) e)
730 :     else (click "i"; g' e)
731 :     | SOME w' => (click "j"; newname(w,w'); g' e)
732 :     else LOOKER(P.gethdlr,[],w,t,g (SOME(VAR w)) e))
733 :     | SETTER(P.sethdlr,[v as VAR vv],e) =>
734 :     let val v' as VAR vv' = ren v
735 :     val e' = g (SOME v') e
736 :     in if !CG.handlerfold
737 :     then case hdlr
738 :     of SOME (v'' as VAR vv'') =>
739 :     if vv'=vv'' then (click "k"; use_less v''; e')
740 :     else SETTER(P.sethdlr,[v'],e')
741 :     | _ => SETTER(P.sethdlr,[v'],e')
742 :     else SETTER(P.sethdlr,[v'],e')
743 :     end
744 :     (* | SETTER(i,vl,e) => SETTER(i, map ren vl, g' e) *)
745 :     | SETTER(i,vl,e) =>
746 :     let val vl' = map ren vl
747 :     in SETTER(setter (i, vl'), vl', g' e)
748 :     end
749 :     | LOOKER(i,vl,w,t,e) =>
750 :     let val vl' = map ren vl
751 :     val {used,...} = get w
752 :     in if !used=0 andalso !CG.deadvars
753 :     then (click "m"; app use_less vl'; g' e)
754 :     else let val e' = g' e
755 :     in if !used=0 andalso deadup
756 :     then (click "*"; app use_less vl'; e')
757 :     else LOOKER(i, vl', w, t, e')
758 :     end
759 :     end
760 :     | ARITH(P.test(p,n),[v],x,t,e as PURE(P.copy(n2,m),[v2],x2,t2,e2)) =>
761 :     if cvtPreCondition(n, n2, x, v2) andalso n=m then
762 :     (click "T(1)"; ARITH(P.test(p,m), [ren v], x2, t2, g' e2))
763 :     else ARITH(P.test(p,n), [ren v], x, t, g' e)
764 :     | ARITH(P.test(p,n),[v],x,t,e as ARITH(P.test(n2,m),[v2],x2,t2,e2)) =>
765 :     if cvtPreCondition(n, n2, x, v2) then
766 :     (click "T(2)"; ARITH(P.test(p,m), [ren v], x2, t2, g' e2))
767 :     else ARITH(P.test(p,n), [ren v], x, t, g' e)
768 :     | ARITH(P.testu(p,n),[v],x,t,e as PURE(P.copy(n2,m),[v2],x2,t2,e2)) =>
769 :     if cvtPreCondition(n, n2, x, v2) andalso n=m then
770 :     (click "U(1)"; ARITH(P.testu(p,m), [ren v], x2, t2, g' e2))
771 :     else ARITH(P.testu(p,n), [ren v], x, t, g' e)
772 :     | ARITH(P.testu(p,n),[v],x,t,e as ARITH(P.testu(n2,m),[v2],x2,t2,e2)) =>
773 :     if cvtPreCondition(n, n2, x, v2) then
774 :     (click "U(2)"; ARITH(P.testu(p,m), [ren v], x2, t2, g' e2))
775 :     else ARITH(P.testu(p,n), [ren v], x, t, g' e)
776 :    
777 :     | ARITH(i,vl,w,t,e) =>
778 :     let val vl' = map ren vl
779 :     in (if !CG.arithopt
780 :     then (newname(w,arith(i, vl')); app use_less vl'; g' e)
781 :     else raise ConstFold)
782 :     handle ConstFold => ARITH(i, vl', w, t, g' e)
783 :     | Overflow => ARITH(i, vl', w, t, g' e)
784 :     end
785 :    
786 :     | PURE(P.trunc(p,n), [v], x, t, e as PURE(pure, [v2], x2, t2, e2)) => let
787 :     fun skip() = PURE(P.trunc(p,n), [ren v], x, t, g' e)
788 :     fun checkClicked(tok, n2, m, pureOp) =
789 :     if cvtPreCondition(n, n2, x, v2) then
790 :     (click tok;
791 :     PURE(pureOp(p,m), [ren v], x2, t2, g' e2))
792 :     else skip()
793 :     in
794 :     case pure
795 :     of P.trunc(n2,m) => checkClicked("R(1)", n2, m, P.trunc)
796 :     | P.copy(n2,m) =>
797 :     if n2=m then checkClicked("R(2)", n2, m, P.trunc) else skip()
798 :     | _ => skip()
799 :     end
800 :     | PURE(P.extend(p,n), [v], x, t, e as PURE(pure, [v2], x2, t2, e2)) => let
801 :     fun skip() = PURE(P.extend(p,n), [ren v], x, t, g' e)
802 :     fun checkClicked(tok, n2, m, pureOp) =
803 :     if cvtPreCondition(n, n2, x, v2) then
804 :     (click tok;
805 :     PURE(pureOp(p,m), [ren v], x2, t2, g' e2))
806 :     else skip()
807 :     in
808 :     case pure
809 :     of P.extend(n2,m) => checkClicked("X(1)", n2, m, P.extend)
810 :     | P.copy(n2,m) =>
811 :     if n2 = m then checkClicked("X(2)", n2, m, P.extend) else skip()
812 :     | P.trunc(n2,m) =>
813 :     if m >= p then checkClicked("X(3)", n2, m, P.extend)
814 :     else checkClicked("X(4)", n2, m, P.trunc)
815 :     | _ => skip()
816 :     end
817 :     | PURE(P.extend(p,n), [v], x, t, e as ARITH(a, [v2], x2, t2, e2)) => let
818 :     val v' = [ren v]
819 :     fun skip() = PURE(P.extend(p,n), v', x, t, g' e)
820 :     fun checkClicked(tok, n2, m, arithOp) =
821 :     if cvtPreCondition(n, n2, x, v2) then
822 :     if m >= p then
823 :     (click tok; PURE(P.extend(p,m), v', x2, t2, g' e2))
824 :     else ARITH(arithOp(p,m), v', x2, t2, g' e2)
825 :     else skip()
826 :     in
827 :     case a
828 :     of P.test(n2, m) => checkClicked("X(5)", n2, m, P.test)
829 :     | P.testu(n2, m) => checkClicked("X(6)", n2, m, P.testu)
830 :     | _ => skip()
831 :     end
832 :     | PURE(P.copy(p,n), [v], x, t, e as PURE(pure, [v2], x2, t2, e2)) => let
833 :     val v' = [ren v]
834 :     fun skip () = PURE(P.copy(p,n), v', x, t, g' e)
835 :     fun checkClicked(tok, n2, m, pureOp) =
836 :     if cvtPreCondition(n, n2, x, v2) then
837 :     (click tok; PURE(pureOp(p,m), v', x2, t2, g' e2))
838 :     else skip()
839 :     in
840 :     case pure
841 :     of P.copy(n2,m) => checkClicked("C(1)", n2, m, P.copy)
842 :     | P.extend(n2,m) =>
843 :     if n > p then checkClicked("C(2)", n2, m, P.copy)
844 :     else if n = p then checkClicked("C(2)", n2, m, P.extend)
845 :     else skip()
846 :     | P.trunc(n2,m) =>
847 :     if m >= p then checkClicked("C(3)", n2, m, P.copy)
848 :     else if m < p then checkClicked("C(4)", n2, m, P.trunc)
849 :     else skip()
850 :     | _ => skip()
851 :     end
852 :     | PURE(P.copy(p,n), [v], x, t, e as ARITH(a, [v2], x2, t2, e2)) => let
853 :     val v' = [ren v]
854 :     fun skip () = PURE(P.copy(p,n), v', x, t, g' e)
855 :     fun checkClicked(tok, n2, m, class, arithOp) =
856 :     if cvtPreCondition(n, n2, x, v2) then
857 :     (click tok; class(arithOp(p,m), v', x2, t2, g' e2))
858 :     else skip()
859 :     in
860 :     case a
861 :     of P.test(n2,m) =>
862 :     if m >= p then checkClicked("C5", n2, m, PURE, P.copy)
863 :     else checkClicked("C6", n2, m, ARITH, P.test)
864 :     | P.testu(n2,m) =>
865 :     if m > p then checkClicked("C7", n2, m, PURE, P.copy)
866 :     else checkClicked("C8", n2, m, ARITH, P.testu)
867 :     | _ => skip()
868 :     end
869 :    
870 :     | PURE(i,vl,w,t,e) =>
871 :     let val vl' = map ren vl
872 :     val {used,...} = get w
873 :     in if !used=0 andalso !CG.deadvars
874 :     then (click "m"; app use_less vl'; g' e)
875 :     else ((if !CG.arithopt
876 :     then (newname(w,pure(i, vl')); g' e)
877 :     else raise ConstFold)
878 :     handle ConstFold =>
879 :     let val e' = g' e
880 :     in if !used=0 andalso deadup
881 :     then (app use_less vl'; click "*"; e')
882 :     else PURE(i, vl', w, t, e')
883 :     end)
884 :     end
885 : blume 773 | RCC(p,vl,w,t,e) =>
886 :     (* leave raw C calls alone *)
887 :     RCC (p, map ren vl, w, t, g' e)
888 : monnier 16 | BRANCH(i,vl,c,e1,e2) =>
889 :     let val vl' = map ren vl
890 :     fun h() = (if !CG.branchfold andalso equalUptoAlpha(e1,e2)
891 :     then (click "z";
892 :     app use_less vl';
893 :     newname(c,INT 0);
894 :     drop_body e2;
895 :     g' e1)
896 :     else if !CG.comparefold
897 :     then if branch(i,vl')
898 :     then (newname(c,INT 0);
899 :     app use_less vl';
900 :     drop_body e2;
901 :     g' e1)
902 :     else (newname(c,INT 0);
903 :     app use_less vl';
904 :     drop_body e1;
905 :     g' e2)
906 :     else raise ConstFold)
907 :     handle ConstFold => BRANCH(i, vl', c, g' e1, g' e2)
908 :     fun getifidiom f =
909 :     let val f' = ren f
910 :     in case f'
911 :     of VAR v =>
912 :     (case get v
913 :     of {info=IFIDIOMinfo{body},...} => SOME body
914 :     | _ => NONE)
915 :     | _ => NONE
916 :     end
917 :     in case (e1,e2)
918 :     of (APP(VAR f, [INT 1]), APP(VAR f', [INT 0])) =>
919 :     (case (f=f', getifidiom(VAR f))
920 :     of (true,
921 :     SOME(body as ref(SOME(c',a,b)))) =>
922 :     (* Handle IF IDIOM *)
923 :     (newname(c', VAR c);
924 :     body:=NONE;
925 :     (* NOTE: could use vl' here instead of vl. *)
926 :     g'(BRANCH(i,vl,c,a,b)))
927 :     | _ => h())
928 :     | _ => h()
929 :     end
930 :     in g'
931 :     end
932 :    
933 :     and branch =
934 :     fn (P.unboxed, vl) => not(branch(P.boxed, vl))
935 :     | (P.boxed, [INT _]) => (click "n"; false)
936 :     | (P.boxed, [STRING s]) => (click "o"; true)
937 :     | (P.boxed, [VAR v]) =>
938 :     (case get v
939 :     of {info=RECinfo _, ...} => (click "p"; true)
940 :     | _ => raise ConstFold)
941 :     | (P.cmp{oper=P.<, kind}, [VAR v, VAR w]) =>
942 :     if v=w then (click "v"; false) else raise ConstFold
943 :     | (P.cmp{oper=P.<, kind=P.INT 31}, [INT i, INT j]) => (click "w"; i<j)
944 :     | (P.cmp{oper=P.>,kind}, [w,v]) =>
945 :     branch(P.cmp{oper=P.<,kind=kind},[v,w])
946 :     | (P.cmp{oper=P.<=,kind}, [w,v]) =>
947 :     branch(P.cmp{oper=P.>=,kind=kind},[v,w])
948 :     | (P.cmp{oper=P.>=,kind}, vl) =>
949 :     not(branch(P.cmp{oper=P.<,kind=kind}, vl))
950 :     | (P.cmp{oper=P.<,kind=P.UINT 31}, [INT i, INT j]) =>
951 :     (click "w"; if j<0 then i>=0 orelse i<j else i>=0 andalso i<j)
952 :     | (P.cmp{oper=P.eql, kind}, [VAR v, VAR w]) =>
953 :     (case kind
954 :     of P.FLOAT _ => raise ConstFold (* incase of NaN's *)
955 : blume 666 | _ => if v=w then (click "v"; true) else raise ConstFold
956 : monnier 16 (*esac*))
957 :     | (P.cmp{oper=P.eql,...}, [INT i, INT j]) => (click "w"; i=j)
958 :     | (P.cmp{oper=P.neq,kind}, vl) =>
959 :     not(branch(P.cmp{oper=P.eql,kind=kind}, vl))
960 :     | (P.peql, [INT i, INT j]) => (click "w"; i=j)
961 :     | (P.pneq, [v,w]) => not(branch(P.peql,[w,v]))
962 :     | _ => raise ConstFold
963 :    
964 :     and arith =
965 :     fn (P.arith{oper=P.*,...}, [INT 1, v]) => (click "F"; v)
966 :     | (P.arith{oper=P.*,...}, [v, INT 1]) => (click "G"; v)
967 :     | (P.arith{oper=P.*,...}, [INT 0, _]) => (click "H"; INT 0)
968 :     | (P.arith{oper=P.*,...}, [_, INT 0]) => (click "I"; INT 0)
969 :     | (P.arith{oper=P.*,kind=P.INT 31}, [INT i, INT j]) =>
970 :     let val x = i*j in x+x+2; click "J"; INT x end
971 :     | (P.arith{oper=P./,...}, [v, INT 1]) => (click "K"; v)
972 :     | (P.arith{oper=P./,...}, [INT i, INT 0]) => raise ConstFold
973 :     | (P.arith{oper=P./,kind=P.INT 31}, [INT i, INT j]) =>
974 :     let val x = Int.quot(i, j) in x+x; click "L"; INT x end
975 :     | (P.arith{oper=P.+,...}, [INT 0, v]) => (click "M"; v)
976 :     | (P.arith{oper=P.+,...}, [v, INT 0]) => (click "N"; v)
977 :     | (P.arith{oper=P.+,kind=P.INT 31}, [INT i, INT j]) =>
978 :     let val x = i+j in x+x+2; click "O"; INT x end
979 :     | (P.arith{oper=P.-,...}, [v, INT 0]) => (click "P"; v)
980 :     | (P.arith{oper=P.-,kind=P.INT 31}, [INT i, INT j]) =>
981 :     let val x = i-j in x+x+2; click "Q"; INT x end
982 :     | (P.arith{oper=P.~,kind=P.INT 31,...}, [INT i]) =>
983 :     let val x = ~i in x+x+2; click "X"; INT x end
984 :     | _ => raise ConstFold
985 :    
986 :     and pure =
987 :     fn (P.pure_arith{oper=P.rshift,kind=P.INT 31}, [INT i, INT j]) =>
988 :     (click "R"; INT(wtoi (Word.~>>(itow i, itow j))))
989 :     | (P.pure_arith{oper=P.rshift,kind=P.INT 31}, [INT 0, _]) =>
990 :     (click "S"; INT 0)
991 :     | (P.pure_arith{oper=P.rshift,kind=P.INT 31}, [v, INT 0]) =>
992 :     (click "T"; v)
993 :     | (P.length, [STRING s]) => (click "V"; INT(size s))
994 :     (* | (P.ordof, [STRING s, INT i]) => (click "W"; INT(ordof(s,i))) *)
995 :     | (P.pure_arith{oper=P.lshift,kind=P.INT 31}, [INT i, INT j]) =>
996 :     (let val x = wtoi (Word.<<(itow i, itow j))
997 :     in x+x; click "Y"; INT x
998 :     end handle Overflow => raise ConstFold)
999 :     | (P.pure_arith{oper=P.lshift,kind=P.INT 31}, [INT 0, _]) =>
1000 :     (click "Z"; INT 0)
1001 :     | (P.pure_arith{oper=P.lshift,kind=P.INT 31}, [v, INT 0]) =>
1002 :     (click "1"; v)
1003 :     | (P.pure_arith{oper=P.orb,kind=P.INT 31}, [INT i, INT j]) =>
1004 :     (click "2"; INT(wtoi (Word.orb(itow i, itow j))))
1005 :     | (P.pure_arith{oper=P.orb,kind=P.INT 31}, [INT 0, v]) => (click "3"; v)
1006 :     | (P.pure_arith{oper=P.orb,kind=P.INT 31}, [v, INT 0]) => (click "4"; v)
1007 :     | (P.pure_arith{oper=P.xorb,kind=P.INT 31}, [INT i, INT j]) =>
1008 :     (click "5"; INT(wtoi (Word.xorb(itow i, itow j))))
1009 :     | (P.pure_arith{oper=P.xorb,kind=P.INT 31}, [INT 0, v]) =>
1010 :     (click "6"; v)
1011 :     | (P.pure_arith{oper=P.xorb,kind=P.INT 31}, [v, INT 0]) => (click "7"; v)
1012 :     | (P.pure_arith{oper=P.notb,kind=P.INT 31}, [INT i]) =>
1013 :     (click "8"; INT(wtoi (Word.notb (itow i))))
1014 :     | (P.pure_arith{oper=P.andb,kind=P.INT 31}, [INT i, INT j]) =>
1015 :     (click "9"; INT(wtoi(Word.andb(itow i, itow j))))
1016 :     | (P.pure_arith{oper=P.andb,kind=P.INT 31}, [INT 0, _]) =>
1017 :     (click "0"; INT 0)
1018 :     | (P.pure_arith{oper=P.andb,kind=P.INT 31}, [_, INT 0]) =>
1019 :     (click "T"; INT 0)
1020 :     | (P.real{fromkind=P.INT 31,tokind=P.FLOAT 64}, [INT i]) =>
1021 :     (REAL(Int.toString i ^ ".0")) (* isn't this cool? *)
1022 : blume 826 | (P.funwrap,[x as VAR v]) =>
1023 :     (case get(v) of {info=WRPinfo(P.fwrap,u),...} =>
1024 :     (click "U"; use_less x; u)
1025 : monnier 16 | _ => raise ConstFold)
1026 : blume 826 | (P.fwrap,[x as VAR v]) =>
1027 :     (case get(v) of {info=WRPinfo(P.funwrap,u),...} =>
1028 :     (click "U"; use_less x; u)
1029 : monnier 16 | _ => raise ConstFold)
1030 : blume 826 | (P.iunwrap,[x as VAR v]) =>
1031 :     (case get(v) of {info=WRPinfo(P.iwrap,u),...} =>
1032 :     (click "U"; use_less x; u)
1033 : monnier 16 | _ => raise ConstFold)
1034 : blume 826 | (P.iwrap,[x as VAR v]) =>
1035 :     (case get(v) of {info=WRPinfo(P.iunwrap,u),...} =>
1036 :     (click "U"; use_less x; u)
1037 : monnier 16 | _ => raise ConstFold)
1038 : blume 826 | (P.i32unwrap,[x as VAR v]) =>
1039 :     (case get(v) of {info=WRPinfo(P.i32wrap,u),...} =>
1040 :     (click "U"; use_less x; u)
1041 : monnier 16 | _ => raise ConstFold)
1042 : blume 826 | (P.i32wrap,[x as VAR v]) =>
1043 :     (case get(v) of {info=WRPinfo(P.i32unwrap,u),...} =>
1044 :     (click "U"; use_less x; u)
1045 : monnier 16 | _ => raise ConstFold)
1046 :     | _ => raise ConstFold
1047 :    
1048 :     in debugprint "Contract: "; debugflush();
1049 :     enterMISC0 fvar; app enterMISC0 fargs;
1050 :     pass1 cexp;
1051 : blume 733 cpssize := IntHashTable.numItems m;
1052 : monnier 16 let val cexp' = reduce cexp
1053 :     in debugprint "\n";
1054 : monnier 149 if debug
1055 : monnier 16 then (debugprint "After contract: \n";
1056 :     PPCps.prcps cexp')
1057 :     else ();
1058 :     (fkind, fvar, fargs, ctyl, cexp')
1059 :     end
1060 :     end
1061 :    
1062 :     end (* toplevel local *)
1063 :     end (* functor Contract *)
1064 :    

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