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 17 - (view) (download)
Original Path: sml/branches/SMLNJ/src/compiler/FLINT/cpsopt/contract.sml

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

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