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

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