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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 113 - (view) (download)
Original Path: sml/branches/SMLNJ/src/compiler/FLINT/cpsopt/expand.sml

1 : monnier 16 (* Copyright 1996 by Bell Laboratories *)
2 :     (* expand.sml *)
3 :    
4 :     signature EXPAND = sig
5 :     val expand : {function: CPS.function,
6 :     bodysize: int,
7 :     unroll: bool,
8 :     table: LtyDef.lty Intmap.intmap,
9 :     afterClosure: bool, do_headers: bool,
10 :     click: string -> unit} -> CPS.function
11 :     end (* signature EXPAND *)
12 :    
13 :     functor Expand (MachSpec : MACH_SPEC) : EXPAND =
14 :     struct
15 :    
16 :     local open CPS
17 :     structure CG = Control.CG
18 :     structure LV = LambdaVar
19 :     in
20 :    
21 :     fun inc (ri as ref i) = (ri := i+1)
22 :     fun dec (ri as ref i) = (ri := i-1)
23 :    
24 :     fun map1 f (a,b) = (f a, b)
25 :    
26 :     fun sum f = let fun h [] = 0
27 :     | h (a::r) = f a + h r
28 :     in h
29 :     end
30 :    
31 :     fun muldiv(a,b,c) = (* a*b/c, approximately, but guaranteed no overflow *)
32 :     (a*b) div c
33 :     handle Overflow => if a>b then muldiv(a div 2,b,c div 2)
34 :     else muldiv(a,b div 2,c div 2)
35 :    
36 :     fun sameName(x,VAR y) = LV.sameName(x,y)
37 :     | sameName(x,LABEL y) = LV.sameName(x,y)
38 :     | sameName _ = ()
39 :    
40 :     datatype mode = ALL | NO_UNROLL | UNROLL of int | HEADERS
41 :    
42 :     fun expand{function=(fkind,fvar,fargs,ctyl,cexp),unroll,bodysize,click,
43 :     afterClosure,table=typtable,do_headers} =
44 :     let
45 :     val clicked_any = ref false
46 :     val click = fn z => (click z; clicked_any := true)
47 :     val debug = !CG.debugcps (* false *)
48 :     val debugprint = if debug then Control.Print.say else fn _ => ()
49 :     val debugflush = if debug then Control.Print.flush else fn _ => ()
50 :     val CGinvariant = !CG.invariant
51 :     fun label v = if afterClosure then LABEL v else VAR v
52 :     datatype info = Fun of {escape: int ref, call: int ref, size: int ref,
53 :     args: lvar list, body: cexp,
54 :     invariant: bool list ref, (* one for each arg *)
55 :     unroll_call: int ref, level: int,
56 :     within: bool ref}
57 :     | Arg of {escape: int ref, savings: int ref,
58 :     record: (int * lvar) list ref}
59 :     | Sel of {savings: int ref}
60 :     | Rec of {escape: int ref, size: int,
61 :     vars: (value * accesspath) list}
62 :     | Real
63 :     | Const
64 :     | Other
65 :    
66 :     val rep_flag = MachSpec.representations
67 :     val type_flag = (!Control.CG.checkcps1) andalso
68 :     (!Control.CG.checkcps1) andalso rep_flag
69 :    
70 :     local
71 :     exception NEXPAND
72 :     fun getty v =
73 :     if type_flag
74 :     then (Intmap.map typtable v) handle _ =>
75 :     (Control.Print.say ("NEXPAND: Can't find the variable "^
76 :     (Int.toString v)^" in the typtable ***** \n");
77 :     raise NEXPAND)
78 :     else LtyExtern.ltc_void
79 :     fun addty(f,t) = Intmap.add typtable (f,t)
80 :     in
81 :    
82 :     fun mkv(t) = let val v = LV.mkLvar()
83 :     val _ = if type_flag then addty(v,t) else ()
84 :     in v
85 :     end
86 :    
87 :     fun copyLvar v = let val x = LV.dupLvar(v)
88 :     val _ = if type_flag then addty(x,getty v) else ()
89 :     in x
90 :     end
91 :    
92 :     end (* local *)
93 :    
94 :    
95 :     local exception Expand
96 :     val m : info Intmap.intmap = Intmap.new(128,Expand)
97 :     val get' = Intmap.map m
98 :     in val note = Intmap.add m
99 :     fun get i = get' i handle Expand => Other
100 :     fun discard_pass1_info() = Intmap.clear m
101 :     end
102 :     fun getval(VAR v) = get v
103 :     | getval(LABEL v) = get v
104 :     | getval(INT _) = Const
105 :     (* | getval(REAL _) = Real*)
106 :     | getval _ = Other
107 :     fun call(v, args) = case getval v
108 :     of Fun{call,within=ref false,...} => inc call
109 :     | Fun{call,within=ref true,unroll_call,
110 :     args=vl,invariant,...} =>
111 :     let fun g(VAR x :: args, x' :: vl, i::inv) =
112 :     (i andalso x=x') :: g(args,vl,inv)
113 :     | g( _ :: args, _ :: vl, i::inv) =
114 :     false :: g(args,vl,inv)
115 :     | g _ = nil
116 :     in inc call; inc unroll_call;
117 :     invariant := g(args,vl,!invariant)
118 :     end
119 :     | Arg{savings,...} => inc savings
120 :     | Sel{savings} => inc savings
121 :     | _ => ()
122 :     fun escape v = case getval v
123 :     of Fun{escape,...} => inc escape
124 :     | Arg{escape,...} => inc escape
125 :     | Rec{escape,...} => inc escape
126 :     | _ => ()
127 :     fun escapeargs v = case getval v
128 :     of Fun{escape,...} => inc escape
129 :     | Arg{escape,savings, ...} =>
130 :     (inc escape; inc savings)
131 :     | Sel{savings} => inc savings
132 :     | Rec{escape,...} => inc escape
133 :     | _ => ()
134 :     fun unescapeargs v = case getval v
135 :     of Fun{escape,...} => dec escape
136 :     | Arg{escape,savings, ...} =>
137 :     (dec escape; dec savings)
138 :     | Sel{savings} => dec savings
139 :     | Rec{escape,...} => dec escape
140 :     | _ => ()
141 :     fun notearg v = (note (v,Arg{escape=ref 0,savings=ref 0, record=ref []}))
142 :     fun noteother v = () (* note (v,Other) *)
143 :     fun notereal v = noteother v (* note (v,Real) *)
144 :     fun enter level (_,f,vl,_,e) =
145 :     (note(f,Fun{escape=ref 0, call=ref 0, size=ref 0,
146 :     args=vl, body=e, within=ref false,
147 :     unroll_call = ref 0,
148 :     invariant = ref(map (fn _ => CGinvariant) vl),
149 :     level=level});
150 :     app notearg vl)
151 :     fun noterec(w, vl, size) = note (w,Rec{size=size,escape=ref 0,vars=vl})
152 :     fun notesel(i,v,w) = (note (w, Sel{savings=ref 0});
153 :     case getval v
154 :     of Arg{savings,record,...} => (inc savings;
155 :     record := (i,w)::(!record))
156 :     | _ => ())
157 :    
158 :     fun setsize(f,n) = case get f of Fun{size,...} => (size := n; n)
159 :    
160 :     fun incsave(v,k) = case getval v
161 :     of Arg{savings,...} => savings := !savings + k
162 :     | Sel{savings} => savings := !savings + k
163 :     | _ => ()
164 :     fun setsave(v,k) = case getval v
165 :     of Arg{savings,...} => savings := k
166 :     | Sel{savings} => savings := k
167 :     | _ => ()
168 :     fun savesofar v = case getval v
169 :     of Arg{savings,...} => !savings
170 :     | Sel{savings} => !savings
171 :     | _ => 0
172 :    
173 :     fun within f func arg =
174 :     case get f of Fun{within=w,...} =>
175 :     (w := true; func arg before (w := false))
176 :    
177 :     val rec prim = fn (level,vl,e) =>
178 :     let fun vbl(VAR v) = (case get v of Rec _ => 0 | _ => 1)
179 :     | vbl _ = 0
180 :     val nonconst = sum vbl vl
181 :     val sl = map savesofar vl
182 :     val afterwards = pass1 level e
183 :     val zl = map savesofar vl
184 :     val overhead = length vl + 1
185 :     val potential = overhead
186 :     val savings = case nonconst of
187 :     1 => potential
188 :     | 2 => potential div 4
189 :     | _ => 0
190 :     fun app3 f = let fun loop (a::b,c::d,e::r) = (f(a,c,e); loop(b,d,r))
191 :     | loop _ = ()
192 :     in loop
193 :     end
194 :     in app3(fn (v,s,z)=> setsave(v,s + savings + (z-s))) (vl,sl,zl);
195 :     overhead+afterwards
196 :     end
197 :    
198 :     and primreal = fn (level,(_,vl,w,_,e)) =>
199 :     (notereal w;
200 :     app (fn v => incsave(v,1)) vl;
201 :     2*(length vl + 1) + pass1 level e)
202 :    
203 :     (*******************************************************************)
204 :     (* pass1: gather info on code. *)
205 :     (*******************************************************************)
206 :     and pass1 : int -> cexp -> int= fn level =>
207 :     fn RECORD(_,vl,w,e) =>
208 :     let val len = length vl
209 :     in app (escape o #1) vl;
210 :     noterec(w,vl,len);
211 :     2 + len + pass1 level e
212 :     end
213 :     | SELECT (i,v,w,_,e) => (notesel(i,v,w); 1 + pass1 level e)
214 :     | OFFSET (i,v,w,e) => (noteother w; 1 + pass1 level e)
215 :     | APP(f,vl) => (call(f,vl);
216 :     app escapeargs vl;
217 :     1 + ((length vl + 1) div 2))
218 :     | FIX(l, e) =>
219 :     (app (enter level) l;
220 :     sum (fn (_,f,_,_,e) => setsize(f, within f (pass1 (level+1)) e)) l
221 :     + length l + pass1 level e)
222 :     | SWITCH(v,_,el) => let val len = length el
223 :     val jumps = 4 + len
224 :     val branches = sum (pass1 level) el
225 :     in incsave(v, muldiv(branches,len-1,len) + jumps);
226 :     jumps+branches
227 :     end
228 :     | BRANCH(_,vl,c,e1,e2) =>
229 :     let fun vbl(VAR v) = (case get v of Rec _ => 0 | _ => 1)
230 :     | vbl _ = 0
231 :     val nonconst = sum vbl vl
232 :     val sl = map savesofar vl
233 :     val branches = pass1 level e1 + pass1 level e2
234 :     val zl = map savesofar vl
235 :     val overhead = length vl
236 :     val potential = overhead + branches div 2
237 :     val savings = case nonconst of
238 :     1 => potential
239 :     | 2 => potential div 4
240 :     | _ => 0
241 :     fun app3 f = let fun loop (a::b,c::d,e::r) = (f(a,c,e); loop(b,d,r))
242 :     | loop _ = ()
243 :     in loop
244 :     end
245 :     in app3(fn (v,s,z)=> setsave(v,s + savings + (z-s) div 2)) (vl,sl,zl);
246 :     overhead+branches
247 :     end
248 :     | LOOKER(_,vl,w,_,e) => (noteother w; prim(level,vl,e))
249 :     | SETTER(_,vl,e) => prim(level,vl,e)
250 :     | ARITH(args as (P.arith{kind=P.FLOAT 64,...},_,_,_,_)) =>
251 :     primreal (level,args)
252 :     | ARITH(args as (P.round _, _,_,_,_)) => primreal (level,args)
253 :     | ARITH(_,vl,w,_,e) => (noteother w; prim(level,vl,e))
254 :     | PURE(P.pure_arith{kind=P.FLOAT 64,...},[v],w,_,e) =>
255 :     (notereal w; incsave(v,1); 4+(pass1 level e))
256 :     | PURE(P.real{tokind=P.FLOAT 64,...},vl,w,_,e) =>
257 :     (notereal w; prim(level,vl,e))
258 :     | PURE(_,vl,w,_,e) => (noteother w; prim(level,vl,e))
259 :    
260 :    
261 :     (*********************************************************************)
262 :     (* substiture(args,wl,e,alpha) : substitute args for wl in e. *)
263 :     (* If alpha=true, also rename all bindings. *)
264 :     (*********************************************************************)
265 :     fun substitute(args,wl,e,alpha) =
266 :     let
267 :     exception Alpha
268 :     val vm : value Intmap.intmap = Intmap.new(16, Alpha)
269 :     fun look (v,default) = Intmap.map vm v handle Alpha => default
270 :     val enter = Intmap.add vm
271 :     fun use(v0 as VAR v) = look(v,v0)
272 :     | use(v0 as LABEL v) = look(v,v0)
273 :     | use x = x
274 :     fun def v = if alpha
275 :     then let val w = copyLvar v
276 :     in enter (v, VAR w); w
277 :     end
278 :     else v
279 :     fun defl v = if alpha
280 :     then let val w = copyLvar v
281 :     in enter (v, label w);
282 :     w
283 :     end
284 :     else v
285 :     fun bind(a::args,w::wl) =
286 :     (sameName(w,a); enter (w,a); bind(args,wl))
287 :     | bind _ = ()
288 :    
289 :     val rec g =
290 :     fn RECORD(k,vl,w,ce) => RECORD(k,map (map1 use) vl, def w, g ce)
291 :     | SELECT(i,v,w,t,ce) => SELECT(i, use v, def w, t, g ce)
292 :     | OFFSET(i,v,w,ce) => OFFSET(i, use v, def w, g ce)
293 :     | APP(v,vl) => APP(use v, map use vl)
294 :     | FIX(l,ce) =>
295 :     let (* Careful: order of evaluation is important here. *)
296 :     fun h1(fk,f,vl,cl,e) = (fk,defl f,vl,cl,e)
297 :     fun h2(fk,f',vl,cl,e) =
298 :     let val vl' = map def vl
299 :     val e'= g e
300 :     in (fk,f',vl',cl,e')
301 :     end
302 :     in FIX(map h2(map h1 l), g ce)
303 :     end
304 :     | SWITCH(v,c,l) => SWITCH(use v, def c, map g l)
305 :     | LOOKER(i,vl,w,t,e) => LOOKER(i, map use vl, def w, t, g e)
306 :     | ARITH(i,vl,w,t,e) => ARITH(i, map use vl, def w, t, g e)
307 :     | PURE(i,vl,w,t,e) => PURE(i, map use vl, def w, t, g e)
308 :     | SETTER(i,vl,e) => SETTER(i, map use vl, g e)
309 :     | BRANCH(i,vl,c,e1,e2) => BRANCH(i, map use vl, def c, g e1, g e2)
310 :    
311 :     in bind(args,wl); g e
312 :     end
313 :    
314 :     fun whatsave(acc, size, (v:value)::vl, a::al) =
315 :     if acc>=size
316 :     then acc
317 :     else
318 :     (case get a of
319 :     Arg{escape=ref esc,savings=ref save,record=ref rl} =>
320 :     let val (this, nvl: value list, nal) =
321 :     case getval v
322 :     of Fun{escape=ref 1,...} =>
323 :     (if esc>0 then save else 6+save,vl,al)
324 :     | Fun _ => (save,vl,al)
325 :     | Rec{escape=ref ex,vars,size} =>
326 :     let exception Chase
327 :     fun chasepath(v,OFFp 0) = v
328 :     | chasepath(v, SELp(i,p)) =
329 :     (case getval v
330 :     of Rec{vars,...} =>
331 :     chasepath(chasepath(List.nth(vars,i)),p)
332 :     | _ => raise Chase)
333 :     | chasepath _ = raise Chase
334 :     fun loop([],nvl,nal) =
335 :     (if ex>1 orelse esc>0
336 :     then save
337 :     else save+size+2,nvl,nal)
338 :     | loop((i,w)::rl,nvl,nal) =
339 :     loop(rl,
340 :     chasepath(List.nth(vars,i))::nvl,
341 :     w::nal)
342 :     in loop(rl,vl,al)
343 :     handle Chase => (0,vl,al)
344 :     | Subscript => (0,vl,al)
345 :     end
346 :     (* | Real => (save,vl,al)*)
347 :     | Const => (save,vl,al)
348 :     | _ => (0,vl,al)
349 :     in whatsave(acc+this - muldiv(acc,this,size), size, nvl,nal)
350 :     end
351 :     | Sel{savings=ref save} =>
352 :     let val this =
353 :     case v
354 :     of VAR v' => (case get v' of
355 :     Fun _ => save
356 :     | Rec _ => save
357 :     | _ => 0)
358 :     | _ => save
359 :     in whatsave(acc + this - muldiv(acc,this,size),size, vl,al)
360 :     end)
361 :     | whatsave(acc,size,_,_) = acc
362 :    
363 :    
364 :     (*************************************************************
365 :     * should_expand: should a function application be inlined? *
366 :     *************************************************************)
367 :     fun should_expand(d, (* path length from entry to current function *)
368 :     u, (* unroll level *)
369 :     e as APP(v,vl),
370 :     Fun{escape,call,unroll_call,size=ref size,args,body,
371 :     level,within=ref within,...}) =
372 :     if !call + !escape = 1 then false else
373 :     let val stupidloop = (* prevent infinite loops at compile time *)
374 :     case (v,body)
375 :     of (VAR vv, APP(VAR v',_)) => vv=v'
376 :     | (LABEL vv, APP(LABEL v',_)) => vv=v'
377 :     | _ => false
378 :     val calls = case u of UNROLL _ => !unroll_call | _ => !call
379 :     val small_fun_size = case u of UNROLL _ => 0 | _ => 50
380 :     val savings = whatsave(0,size,vl,args)
381 :     val predicted =
382 :     let val real_increase = size-savings-(1+length vl)
383 :     in real_increase * calls -
384 :     (* don't subtract off the original body if
385 :     the original body is huge (because we might
386 :     have guessed wrong and the consequences are
387 :     too nasty for big functions); or if we're
388 :     in unroll mode *)
389 :     (if size < small_fun_size then size else 0)
390 :     end
391 :     val depth = 2 and max = 2
392 :    
393 :     in if false andalso debug
394 :     then (PPCps.prcps e;
395 :     debugprint(Int.toString predicted); debugprint " ";
396 :     debugprint(Int.toString bodysize); debugprint "\n")
397 :     else ();
398 :    
399 :     not stupidloop
400 :     andalso case u
401 :     of UNROLL lev =>
402 :     (* Unroll if: the loop body doesn't make function
403 :     calls orelse "unroll_recur" is turned on; andalso
404 :     we are within the definition of the function;
405 :     andalso it looks like things won't grow too much.
406 :     *)
407 :     (!CG.unroll_recur orelse level >= lev)
408 :     andalso within andalso predicted <= bodysize
409 :     | NO_UNROLL =>
410 :     !unroll_call = 0 andalso
411 :     not within andalso
412 :     (predicted <= bodysize
413 :     orelse (!escape=0 andalso calls = 1))
414 :     | HEADERS => false (* shouldn't get here *)
415 :     | ALL =>
416 :     (predicted <= bodysize
417 :     orelse (!escape=0 andalso calls = 1))
418 :     end
419 :    
420 :     datatype decision = YES of {formals: lvar list, body: cexp}
421 :     | NO of int (* how many no's in a row *)
422 :     (* There is really no point in making decisions a ref. This should
423 :     be changed one day. *)
424 :     val decisions : decision list ref = ref nil
425 :     fun decide_yes x = decisions := YES x :: !decisions
426 :     fun decide_no () = decisions :=
427 :     (case !decisions
428 :     of NO n :: rest => NO(n+1) :: rest
429 :     | d => NO 1 :: d)
430 :    
431 :    
432 :     (*********************************************************************)
433 :     (* pass2: mark function applications to be inlined. *)
434 :     (*********************************************************************)
435 :     fun pass2(d, (* path length from start of current function *)
436 :     u, (* unroll-info *)
437 :     e (* expression to traverse *)
438 :     ) = case e
439 :    
440 :     of RECORD(k,vl,w,ce) => pass2(d+2+length vl,u,ce)
441 :     | SELECT(i,v,w,t,ce) => pass2(d+1,u,ce)
442 :     | OFFSET(i,v,w,ce) => pass2(d+1,u,ce)
443 :     | APP(v,vl) =>
444 :     (case getval v
445 :     of info as Fun{args,body,...} =>
446 :     if should_expand(d,u,e,info)
447 :     then decide_yes{formals=args,body=body}
448 :     else decide_no()
449 :     | _ => decide_no())
450 :     | FIX(l,ce) =>
451 :     let fun fundef (NO_INLINE_INTO,_,_,_,_) = ()
452 :     | fundef (fk,f,vl,cl,e) =
453 :     let val Fun{level,within,escape=ref escape,...} = get f
454 :    
455 :     val u' = case u of UNROLL _ => UNROLL level | _ => u
456 :    
457 :     fun conform((VAR x)::r,z::l) = (x=z) andalso conform(r,l)
458 :     | conform(_::r,_::l) = false
459 :     | conform([],[]) = true
460 :     | conform _ = false
461 :    
462 :     in within := true;
463 :     pass2(0,u',e)
464 :     before within := false
465 :     end
466 :     in app fundef l;
467 :     pass2(d+length l,u,ce)
468 :     end
469 :     | SWITCH(v,c,l) => app (fn e => pass2(d+2,u,e)) l
470 :     | LOOKER(i,vl,w,t,e) => pass2(d+2,u,e)
471 :     | ARITH(i,vl,w,t,e) => pass2(d+2,u,e)
472 :     | PURE(i,vl,w,t,e) => pass2(d+2,u,e)
473 :     | SETTER(i,vl,e) => pass2(d+2,u,e)
474 :     | BRANCH(i,vl,c,e1,e2) => (pass2(d+2,u,e1);
475 :     pass2(d+2,u,e2))
476 :    
477 :    
478 :     val rec gamma =
479 :     fn RECORD(k,vl,w,ce) => RECORD(k,vl, w, gamma ce)
480 :     | SELECT(i,v,w,t,ce) => SELECT(i, v, w, t, gamma ce)
481 :     | OFFSET(i,v,w,ce) => OFFSET(i, v, w, gamma ce)
482 :     | e as APP(v,vl) => e
483 :     | FIX(l,ce) =>
484 :     let fun fundef (z as (NO_INLINE_INTO,_,_,_,_)) = z
485 :     | fundef (fk,f,vl,cl,e) =
486 :     let val Fun{escape=ref escape,call,unroll_call,
487 :     invariant=ref inv,...} = get f
488 :    
489 :     in if escape = 0 andalso !unroll_call > 0
490 :     andalso (!call - !unroll_call > 1
491 :     orelse List.exists (fn t=>t) inv)
492 :     then let val f'::vl' = map copyLvar (f::vl)
493 :     fun drop(false::r,a::s) = a::drop(r,s)
494 :     | drop(true::r,_::s) = drop(r,s)
495 :     | drop _ = nil
496 :     val newformals=label f' :: map VAR (drop(inv,vl'))
497 :     val e' =substitute(newformals,
498 :     f :: drop(inv,vl),
499 :     gamma e,
500 :     false)
501 :     in click "!"; debugprint(Int.toString f);
502 :     enter 0 (fk,f',vl',cl,e');
503 :     (fk,f,vl,cl,FIX([(fk,f',vl',cl,e')],
504 :     APP(label f', map VAR vl)))
505 :     end
506 :     else (fk,f,vl,cl,gamma e)
507 :    
508 :     end
509 :     in FIX(map fundef l, gamma ce)
510 :     end
511 :     | SWITCH(v,c,l) => SWITCH(v, c, map gamma l)
512 :     | LOOKER(i,vl,w,t,e) => LOOKER(i, vl, w, t, gamma e)
513 :     | ARITH(i,vl,w,t,e) => ARITH(i, vl, w, t, gamma e)
514 :     | PURE(i,vl,w,t,e) => PURE(i, vl, w, t, gamma e)
515 :     | SETTER(i,vl,e) => SETTER(i, vl, gamma e)
516 :     | BRANCH(i,vl,c,e1,e2) => BRANCH(i, vl, c,gamma e1, gamma e2)
517 :    
518 :    
519 :     val rec beta =
520 :     fn RECORD(k,vl,w,ce) => RECORD(k,vl,w,beta ce)
521 :     | SELECT(i,v,w,t,ce) => SELECT(i,v,w,t,beta ce)
522 :     | OFFSET(i,v,w,ce) => OFFSET(i,v,w,beta ce)
523 :     | e as APP(v,vl) =>
524 :     (case !decisions
525 :     of YES{formals,body}::rest =>
526 :     (click "^";
527 :     case v of VAR vv => debugprint(Int.toString vv) | _ => ();
528 :     debugflush();
529 :     decisions := rest;
530 :     substitute(vl,formals,body,true))
531 :     | NO 1::rest => (decisions := rest; e)
532 :     | NO n :: rest => (decisions := NO(n-1)::rest; e))
533 :     | FIX(l,ce) =>
534 :     let fun fundef (z as (NO_INLINE_INTO,_,_,_,_)) = z
535 :     | fundef (fk,f,vl,cl,e) = (fk,f,vl,cl,beta e)
536 :     in FIX(map fundef l, beta ce)
537 :     end
538 :     | SWITCH(v,c,l) => SWITCH(v,c,map beta l)
539 :     | LOOKER(i,vl,w,t,e) => LOOKER(i,vl,w,t,beta e)
540 :     | ARITH(i,vl,w,t,e) => ARITH(i,vl,w,t,beta e)
541 :     | PURE(i,vl,w,t,e) => PURE(i,vl,w,t,beta e)
542 :     | SETTER(i,vl,e) => SETTER(i,vl,beta e)
543 :     | BRANCH(i,vl,c,e1,e2) => BRANCH(i,vl,c,beta e1,beta e2)
544 :    
545 :    
546 :    
547 :     fun pass2_beta(mode,e) =
548 :     (pass2(0,mode,e);
549 :     discard_pass1_info();
550 :     debugprint "Expand: finishing pass2\n"; debugflush();
551 :     case !decisions
552 :     of [NO _] => (debugprint "No expansions to do.\n"; debugflush();
553 :     e)
554 :     | _ => (decisions := rev(!decisions);
555 :     debugprint "Beta: ";
556 :     beta e
557 :     before
558 :     (debugprint "\n"; debugflush())))
559 :    
560 :     val gamma = fn c =>
561 :     (debugprint "Gamma: ";
562 :     gamma c
563 :     before
564 :     (debugprint "\n"; debugflush()))
565 :    
566 :     in (* body of expand *)
567 :     notearg fvar;
568 :     app notearg fargs;
569 :     (***>
570 :     if !CG.printit then PPCps.prcps cexp
571 :     else ();
572 :     <***)
573 :     debugprint("Expand: pass1: ");
574 :     debugprint(Int.toString(pass1 0 cexp));
575 :     debugprint "\n";
576 :     debugflush();
577 :    
578 :     if unroll
579 :     then let val _ = (debugprint(" (unroll)\n"); debugflush());
580 :     val e' = pass2_beta(UNROLL 0,cexp)
581 :     in if !clicked_any
582 :     then expand{function=(fkind,fvar,fargs,ctyl,e'),
583 :     table=typtable,
584 :     bodysize=bodysize,click=click,unroll=unroll,
585 :     afterClosure=afterClosure,
586 :     do_headers=do_headers}
587 :     else ((*debugprint("\nExpand\n");
588 :     debugflush();
589 :     (fkind,fvar,fargs,ctyl,pass2_beta(ALL,cexp)) *)
590 :     (fkind,fvar,fargs,ctyl,e'))
591 :     end
592 :     else if !CG.unroll
593 :     then let val _ = (debugprint(" (headers)\n"); debugflush())
594 :     val e' = if do_headers then gamma cexp else cexp
595 :     in if !clicked_any
596 :     then expand{function=(fkind,fvar,fargs,ctyl,e'),
597 :     table=typtable,bodysize=bodysize,click=click,
598 :     unroll=unroll,afterClosure=afterClosure,
599 :     do_headers=false}
600 :     else (debugprint(" (non-unroll 1)\n"); debugflush();
601 :     (fkind,fvar,fargs,ctyl,pass2_beta(NO_UNROLL,e')))
602 :     end
603 :     else (debugprint(" (non-unroll 2)\n"); debugflush();
604 :     (fkind,fvar,fargs,ctyl,pass2_beta(ALL,cexp)))
605 :     end
606 :    
607 :     end (* toplevel local *)
608 :     end (* functor Expand *)
609 :    
610 :     (*
611 : monnier 113 * $Log$
612 : monnier 16 *)

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