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 773 - (view) (download)

1 : monnier 245 (* 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 : blume 733 table: LtyDef.lty IntHashTable.hash_table,
9 : monnier 245 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 : blume 733 then (IntHashTable.lookup typtable v) handle _ =>
75 : monnier 245 (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 : blume 733 fun addty(f,t) = IntHashTable.insert typtable (f,t)
80 : monnier 245 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 : blume 733 val m : info IntHashTable.hash_table = IntHashTable.mkTable(128,Expand)
97 :     val get' = IntHashTable.lookup m
98 :     in val note = IntHashTable.insert m
99 : monnier 245 fun get i = get' i handle Expand => Other
100 : blume 733 fun discard_pass1_info() = IntHashTable.clear m
101 : monnier 245 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 : blume 773 | RCC(p,vl,w,t,e) => (noteother w; prim(level,vl,e)) (* ? *)
260 : monnier 245
261 :    
262 :     (*********************************************************************)
263 :     (* substiture(args,wl,e,alpha) : substitute args for wl in e. *)
264 :     (* If alpha=true, also rename all bindings. *)
265 :     (*********************************************************************)
266 :     fun substitute(args,wl,e,alpha) =
267 :     let
268 :     exception Alpha
269 : blume 733 val vm: value IntHashTable.hash_table = IntHashTable.mkTable(16, Alpha)
270 :     fun look (v,default) = getOpt (IntHashTable.find vm v, default)
271 :     val enter = IntHashTable.insert vm
272 : monnier 245 fun use(v0 as VAR v) = look(v,v0)
273 :     | use(v0 as LABEL v) = look(v,v0)
274 :     | use x = x
275 :     fun def v = if alpha
276 :     then let val w = copyLvar v
277 :     in enter (v, VAR w); w
278 :     end
279 :     else v
280 :     fun defl v = if alpha
281 :     then let val w = copyLvar v
282 :     in enter (v, label w);
283 :     w
284 :     end
285 :     else v
286 :     fun bind(a::args,w::wl) =
287 :     (sameName(w,a); enter (w,a); bind(args,wl))
288 :     | bind _ = ()
289 :    
290 :     val rec g =
291 :     fn RECORD(k,vl,w,ce) => RECORD(k,map (map1 use) vl, def w, g ce)
292 :     | SELECT(i,v,w,t,ce) => SELECT(i, use v, def w, t, g ce)
293 :     | OFFSET(i,v,w,ce) => OFFSET(i, use v, def w, g ce)
294 :     | APP(v,vl) => APP(use v, map use vl)
295 :     | FIX(l,ce) =>
296 :     let (* Careful: order of evaluation is important here. *)
297 :     fun h1(fk,f,vl,cl,e) = (fk,defl f,vl,cl,e)
298 :     fun h2(fk,f',vl,cl,e) =
299 :     let val vl' = map def vl
300 :     val e'= g e
301 :     in (fk,f',vl',cl,e')
302 :     end
303 :     in FIX(map h2(map h1 l), g ce)
304 :     end
305 :     | SWITCH(v,c,l) => SWITCH(use v, def c, map g l)
306 :     | LOOKER(i,vl,w,t,e) => LOOKER(i, map use vl, def w, t, g e)
307 :     | ARITH(i,vl,w,t,e) => ARITH(i, map use vl, def w, t, g e)
308 :     | PURE(i,vl,w,t,e) => PURE(i, map use vl, def w, t, g e)
309 :     | SETTER(i,vl,e) => SETTER(i, map use vl, g e)
310 : blume 773 | RCC(p,vl,w,t,e) => RCC(p, map use vl, def w, t, g e)
311 : monnier 245 | BRANCH(i,vl,c,e1,e2) => BRANCH(i, map use vl, def c, g e1, g e2)
312 :    
313 :     in bind(args,wl); g e
314 :     end
315 :    
316 :     fun whatsave(acc, size, (v:value)::vl, a::al) =
317 :     if acc>=size
318 :     then acc
319 :     else
320 :     (case get a of
321 :     Arg{escape=ref esc,savings=ref save,record=ref rl} =>
322 :     let val (this, nvl: value list, nal) =
323 :     case getval v
324 :     of Fun{escape=ref 1,...} =>
325 :     (if esc>0 then save else 6+save,vl,al)
326 :     | Fun _ => (save,vl,al)
327 :     | Rec{escape=ref ex,vars,size} =>
328 :     let exception Chase
329 :     fun chasepath(v,OFFp 0) = v
330 :     | chasepath(v, SELp(i,p)) =
331 :     (case getval v
332 :     of Rec{vars,...} =>
333 :     chasepath(chasepath(List.nth(vars,i)),p)
334 :     | _ => raise Chase)
335 :     | chasepath _ = raise Chase
336 :     fun loop([],nvl,nal) =
337 :     (if ex>1 orelse esc>0
338 :     then save
339 :     else save+size+2,nvl,nal)
340 :     | loop((i,w)::rl,nvl,nal) =
341 :     loop(rl,
342 :     chasepath(List.nth(vars,i))::nvl,
343 :     w::nal)
344 :     in loop(rl,vl,al)
345 :     handle Chase => (0,vl,al)
346 :     | Subscript => (0,vl,al)
347 :     end
348 :     (* | Real => (save,vl,al)*)
349 :     | Const => (save,vl,al)
350 :     | _ => (0,vl,al)
351 :     in whatsave(acc+this - muldiv(acc,this,size), size, nvl,nal)
352 :     end
353 :     | Sel{savings=ref save} =>
354 :     let val this =
355 :     case v
356 :     of VAR v' => (case get v' of
357 :     Fun _ => save
358 :     | Rec _ => save
359 :     | _ => 0)
360 :     | _ => save
361 :     in whatsave(acc + this - muldiv(acc,this,size),size, vl,al)
362 :     end)
363 :     | whatsave(acc,size,_,_) = acc
364 :    
365 :    
366 :     (*************************************************************
367 :     * should_expand: should a function application be inlined? *
368 :     *************************************************************)
369 :     fun should_expand(d, (* path length from entry to current function *)
370 :     u, (* unroll level *)
371 :     e as APP(v,vl),
372 :     Fun{escape,call,unroll_call,size=ref size,args,body,
373 :     level,within=ref within,...}) =
374 :     if !call + !escape = 1 then false else
375 :     let val stupidloop = (* prevent infinite loops at compile time *)
376 :     case (v,body)
377 :     of (VAR vv, APP(VAR v',_)) => vv=v'
378 :     | (LABEL vv, APP(LABEL v',_)) => vv=v'
379 :     | _ => false
380 :     val calls = case u of UNROLL _ => !unroll_call | _ => !call
381 :     val small_fun_size = case u of UNROLL _ => 0 | _ => 50
382 :     val savings = whatsave(0,size,vl,args)
383 :     val predicted =
384 :     let val real_increase = size-savings-(1+length vl)
385 :     in real_increase * calls -
386 :     (* don't subtract off the original body if
387 :     the original body is huge (because we might
388 :     have guessed wrong and the consequences are
389 :     too nasty for big functions); or if we're
390 :     in unroll mode *)
391 :     (if size < small_fun_size then size else 0)
392 :     end
393 :     val depth = 2 and max = 2
394 :    
395 :     in if false andalso debug
396 :     then (PPCps.prcps e;
397 :     debugprint(Int.toString predicted); debugprint " ";
398 :     debugprint(Int.toString bodysize); debugprint "\n")
399 :     else ();
400 :    
401 :     not stupidloop
402 :     andalso case u
403 :     of UNROLL lev =>
404 :     (* Unroll if: the loop body doesn't make function
405 :     calls orelse "unroll_recur" is turned on; andalso
406 :     we are within the definition of the function;
407 :     andalso it looks like things won't grow too much.
408 :     *)
409 :     (!CG.unroll_recur orelse level >= lev)
410 :     andalso within andalso predicted <= bodysize
411 :     | NO_UNROLL =>
412 :     !unroll_call = 0 andalso
413 :     not within andalso
414 :     (predicted <= bodysize
415 :     orelse (!escape=0 andalso calls = 1))
416 :     | HEADERS => false (* shouldn't get here *)
417 :     | ALL =>
418 :     (predicted <= bodysize
419 :     orelse (!escape=0 andalso calls = 1))
420 :     end
421 :    
422 :     datatype decision = YES of {formals: lvar list, body: cexp}
423 :     | NO of int (* how many no's in a row *)
424 :     (* There is really no point in making decisions a ref. This should
425 :     be changed one day. *)
426 :     val decisions : decision list ref = ref nil
427 :     fun decide_yes x = decisions := YES x :: !decisions
428 :     fun decide_no () = decisions :=
429 :     (case !decisions
430 :     of NO n :: rest => NO(n+1) :: rest
431 :     | d => NO 1 :: d)
432 :    
433 :    
434 :     (*********************************************************************)
435 :     (* pass2: mark function applications to be inlined. *)
436 :     (*********************************************************************)
437 :     fun pass2(d, (* path length from start of current function *)
438 :     u, (* unroll-info *)
439 :     e (* expression to traverse *)
440 :     ) = case e
441 :    
442 :     of RECORD(k,vl,w,ce) => pass2(d+2+length vl,u,ce)
443 :     | SELECT(i,v,w,t,ce) => pass2(d+1,u,ce)
444 :     | OFFSET(i,v,w,ce) => pass2(d+1,u,ce)
445 :     | APP(v,vl) =>
446 :     (case getval v
447 :     of info as Fun{args,body,...} =>
448 :     if should_expand(d,u,e,info)
449 :     then decide_yes{formals=args,body=body}
450 :     else decide_no()
451 :     | _ => decide_no())
452 :     | FIX(l,ce) =>
453 :     let fun fundef (NO_INLINE_INTO,_,_,_,_) = ()
454 :     | fundef (fk,f,vl,cl,e) =
455 :     let val Fun{level,within,escape=ref escape,...} = get f
456 :    
457 :     val u' = case u of UNROLL _ => UNROLL level | _ => u
458 :    
459 :     fun conform((VAR x)::r,z::l) = (x=z) andalso conform(r,l)
460 :     | conform(_::r,_::l) = false
461 :     | conform([],[]) = true
462 :     | conform _ = false
463 :    
464 :     in within := true;
465 :     pass2(0,u',e)
466 :     before within := false
467 :     end
468 :     in app fundef l;
469 :     pass2(d+length l,u,ce)
470 :     end
471 :     | SWITCH(v,c,l) => app (fn e => pass2(d+2,u,e)) l
472 : blume 773 | (LOOKER(_,_,_,_,e) |
473 :     ARITH(_,_,_,_,e) |
474 :     PURE(_,_,_,_,e) |
475 :     SETTER(_,_,e) |
476 :     RCC(_,_,_,_,e)) => pass2(d+2,u,e)
477 : monnier 245 | BRANCH(i,vl,c,e1,e2) => (pass2(d+2,u,e1);
478 :     pass2(d+2,u,e2))
479 :    
480 :    
481 :     val rec gamma =
482 :     fn RECORD(k,vl,w,ce) => RECORD(k,vl, w, gamma ce)
483 :     | SELECT(i,v,w,t,ce) => SELECT(i, v, w, t, gamma ce)
484 :     | OFFSET(i,v,w,ce) => OFFSET(i, v, w, gamma ce)
485 :     | e as APP(v,vl) => e
486 :     | FIX(l,ce) =>
487 :     let fun fundef (z as (NO_INLINE_INTO,_,_,_,_)) = z
488 :     | fundef (fk,f,vl,cl,e) =
489 :     let val Fun{escape=ref escape,call,unroll_call,
490 :     invariant=ref inv,...} = get f
491 :    
492 :     in if escape = 0 andalso !unroll_call > 0
493 :     andalso (!call - !unroll_call > 1
494 :     orelse List.exists (fn t=>t) inv)
495 :     then let val f'::vl' = map copyLvar (f::vl)
496 :     fun drop(false::r,a::s) = a::drop(r,s)
497 :     | drop(true::r,_::s) = drop(r,s)
498 :     | drop _ = nil
499 :     val newformals=label f' :: map VAR (drop(inv,vl'))
500 :     val e' =substitute(newformals,
501 :     f :: drop(inv,vl),
502 :     gamma e,
503 :     false)
504 :     in click "!"; debugprint(Int.toString f);
505 :     enter 0 (fk,f',vl',cl,e');
506 :     (fk,f,vl,cl,FIX([(fk,f',vl',cl,e')],
507 :     APP(label f', map VAR vl)))
508 :     end
509 :     else (fk,f,vl,cl,gamma e)
510 :    
511 :     end
512 :     in FIX(map fundef l, gamma ce)
513 :     end
514 :     | SWITCH(v,c,l) => SWITCH(v, c, map gamma l)
515 :     | LOOKER(i,vl,w,t,e) => LOOKER(i, vl, w, t, gamma e)
516 :     | ARITH(i,vl,w,t,e) => ARITH(i, vl, w, t, gamma e)
517 :     | PURE(i,vl,w,t,e) => PURE(i, vl, w, t, gamma e)
518 :     | SETTER(i,vl,e) => SETTER(i, vl, gamma e)
519 : blume 773 | RCC(p,vl,w,t,e) => RCC(p, vl, w, t, gamma e)
520 : monnier 245 | BRANCH(i,vl,c,e1,e2) => BRANCH(i, vl, c,gamma e1, gamma e2)
521 :    
522 :    
523 :     val rec beta =
524 :     fn RECORD(k,vl,w,ce) => RECORD(k,vl,w,beta ce)
525 :     | SELECT(i,v,w,t,ce) => SELECT(i,v,w,t,beta ce)
526 :     | OFFSET(i,v,w,ce) => OFFSET(i,v,w,beta ce)
527 :     | e as APP(v,vl) =>
528 :     (case !decisions
529 :     of YES{formals,body}::rest =>
530 :     (click "^";
531 :     case v of VAR vv => debugprint(Int.toString vv) | _ => ();
532 :     debugflush();
533 :     decisions := rest;
534 :     substitute(vl,formals,body,true))
535 :     | NO 1::rest => (decisions := rest; e)
536 :     | NO n :: rest => (decisions := NO(n-1)::rest; e))
537 :     | FIX(l,ce) =>
538 :     let fun fundef (z as (NO_INLINE_INTO,_,_,_,_)) = z
539 :     | fundef (fk,f,vl,cl,e) = (fk,f,vl,cl,beta e)
540 :     in FIX(map fundef l, beta ce)
541 :     end
542 :     | SWITCH(v,c,l) => SWITCH(v,c,map beta l)
543 :     | LOOKER(i,vl,w,t,e) => LOOKER(i,vl,w,t,beta e)
544 :     | ARITH(i,vl,w,t,e) => ARITH(i,vl,w,t,beta e)
545 :     | PURE(i,vl,w,t,e) => PURE(i,vl,w,t,beta e)
546 :     | SETTER(i,vl,e) => SETTER(i,vl,beta e)
547 : blume 773 | RCC(p,vl,w,t,e) => RCC(p,vl,w,t,beta e)
548 : monnier 245 | BRANCH(i,vl,c,e1,e2) => BRANCH(i,vl,c,beta e1,beta e2)
549 :    
550 :    
551 :    
552 :     fun pass2_beta(mode,e) =
553 :     (pass2(0,mode,e);
554 :     discard_pass1_info();
555 :     debugprint "Expand: finishing pass2\n"; debugflush();
556 :     case !decisions
557 :     of [NO _] => (debugprint "No expansions to do.\n"; debugflush();
558 :     e)
559 :     | _ => (decisions := rev(!decisions);
560 :     debugprint "Beta: ";
561 :     beta e
562 :     before
563 :     (debugprint "\n"; debugflush())))
564 :    
565 :     val gamma = fn c =>
566 :     (debugprint "Gamma: ";
567 :     gamma c
568 :     before
569 :     (debugprint "\n"; debugflush()))
570 :    
571 :     in (* body of expand *)
572 :     notearg fvar;
573 :     app notearg fargs;
574 :     (***>
575 :     if !CG.printit then PPCps.prcps cexp
576 :     else ();
577 :     <***)
578 :     debugprint("Expand: pass1: ");
579 :     debugprint(Int.toString(pass1 0 cexp));
580 :     debugprint "\n";
581 :     debugflush();
582 :    
583 :     if unroll
584 :     then let val _ = (debugprint(" (unroll)\n"); debugflush());
585 :     val e' = pass2_beta(UNROLL 0,cexp)
586 :     in if !clicked_any
587 :     then expand{function=(fkind,fvar,fargs,ctyl,e'),
588 :     table=typtable,
589 :     bodysize=bodysize,click=click,unroll=unroll,
590 :     afterClosure=afterClosure,
591 :     do_headers=do_headers}
592 :     else ((*debugprint("\nExpand\n");
593 :     debugflush();
594 :     (fkind,fvar,fargs,ctyl,pass2_beta(ALL,cexp)) *)
595 :     (fkind,fvar,fargs,ctyl,e'))
596 :     end
597 :     else if !CG.unroll
598 :     then let val _ = (debugprint(" (headers)\n"); debugflush())
599 :     val e' = if do_headers then gamma cexp else cexp
600 :     in if !clicked_any
601 :     then expand{function=(fkind,fvar,fargs,ctyl,e'),
602 :     table=typtable,bodysize=bodysize,click=click,
603 :     unroll=unroll,afterClosure=afterClosure,
604 :     do_headers=false}
605 :     else (debugprint(" (non-unroll 1)\n"); debugflush();
606 :     (fkind,fvar,fargs,ctyl,pass2_beta(NO_UNROLL,e')))
607 :     end
608 :     else (debugprint(" (non-unroll 2)\n"); debugflush();
609 :     (fkind,fvar,fargs,ctyl,pass2_beta(ALL,cexp)))
610 :     end
611 :    
612 :     end (* toplevel local *)
613 :     end (* functor Expand *)
614 :    

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