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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 66 - (view) (download)

1 : monnier 66 (* Copyright 1996 by Bell Laboratories *)
2 :     (* expand.sml *)
3 :    
4 :     functor ExpandNEW (MachSpec : MACH_SPEC) : EXPAND =
5 :     struct
6 :    
7 :     local open CPS
8 :     structure CG = Control.CG
9 :     structure LV = LambdaVar
10 :     in
11 :    
12 :     fun inc r = (r := !r + 1)
13 :     fun dec r = (r := !r - 1)
14 :    
15 :     fun map1 f (a,b) = (f a, b)
16 :    
17 :     fun sum f = let fun h [] = 0
18 :     | h (a::r) = f a + h r
19 :     in h
20 :     end
21 :    
22 :     fun split pred (a::rest) = let val (t,f) = split pred rest
23 :     in if pred a then (a::t,f) else (t,a::f)
24 :     end
25 :     | split pred nil = (nil,nil)
26 :    
27 :     fun muldiv(a,b,c) = (* a*b/c, approximately, but guaranteed no overflow *)
28 :     (a*b) div c
29 :     handle Overflow => if a>b then muldiv(a div 2,b,c div 2)
30 :     else muldiv(a,b div 2,c div 2)
31 :    
32 :     fun sameName(x,VAR y) = LV.sameName(x,y)
33 :     | sameName(x,LABEL y) = LV.sameName(x,y)
34 :     | sameName _ = ()
35 :    
36 :     datatype mode = ALL | NO_UNROLL | UNROLL of int | HEADERS
37 :    
38 :     fun expand{function=(fkind,fvar,fargs,ctyl,cexp),unroll,bodysize,click,
39 :     afterClosure,table=typtable,do_headers} =
40 :     let
41 :     val clicked_any = ref false
42 :     val debug = !CG.debugcps (* false *)
43 :     val debugprint = if debug then Control.Print.say else fn _ => ()
44 :     val debugflush = if debug then Control.Print.flush else fn _ => ()
45 :     val click = fn z => (debugprint z; (* temporary *)
46 :     click z; clicked_any := true)
47 :     val CGinvariant = !CG.invariant
48 :     fun label v = if afterClosure then LABEL v else VAR v
49 :     datatype info =
50 :     Fun of {escape: int ref, (* how many non-call uses *)
51 :     call: int ref, (* how many calls to this func *)
52 :     size: int ref, (* size of function body *)
53 :     args: lvar list, (* formal parameters *)
54 :     body: cexp, (* function body *)
55 :     invariant: bool list ref, (* one for each arg *)
56 :     sibling_call: int ref, (* how many of calls are from
57 :     other functions defined in same FIX *)
58 :     unroll_call: int ref, (* how many calls are from within
59 :     this func's body *)
60 :     level: int, (* loop-nesting level of this function *)
61 :     within: bool ref,(* are we currently doing pass1 within this
62 :     function's body? *)
63 :     within_sibling: bool ref
64 :     (* are we currently doing passw within the
65 :     body of this function or any of the other
66 :     functions defined in the same FIX? *)
67 :     }
68 :     | Arg of {escape: int ref, savings: int ref,
69 :     record: (int * lvar) list ref}
70 :     | Sel of {savings: int ref}
71 :     | Rec of {escape: int ref, size: int,
72 :     vars: (value * accesspath) list}
73 :     | Real
74 :     | Const
75 :     | Other
76 :    
77 :     val rep_flag = MachSpec.representations
78 :     val type_flag = (!Control.CG.checkcps1) andalso
79 :     (!Control.CG.checkcps1) andalso rep_flag
80 :    
81 :     local
82 :     exception NEXPAND
83 :     fun getty v =
84 :     if type_flag
85 :     then (Intmap.map typtable v) handle _ =>
86 :     (Control.Print.say ("NEXPAND: Can't find the variable "^
87 :     (Int.toString v)^" in the typtable ***** \n");
88 :     raise NEXPAND)
89 :     else LtyExtern.ltc_void
90 :     fun addty(f,t) = Intmap.add typtable (f,t)
91 :     in
92 :    
93 :     fun mkv(t) = let val v = LV.mkLvar()
94 :     val _ = if type_flag then addty(v,t) else ()
95 :     in v
96 :     end
97 :    
98 :     fun copyLvar v = let val x = LV.dupLvar(v)
99 :     val _ = if type_flag then addty(x,getty v) else ()
100 :     in x
101 :     end
102 :    
103 :     end (* local *)
104 :    
105 :    
106 :     local exception Expand
107 :     val m : info Intmap.intmap = Intmap.new(128,Expand)
108 :     val get' = Intmap.map m
109 :     in val note = Intmap.add m
110 :     fun get i = get' i handle Expand => Other
111 :     fun discard_pass1_info() = Intmap.clear m
112 :     end
113 :     fun getval(VAR v) = get v
114 :     | getval(LABEL v) = get v
115 :     | getval(INT _) = Const
116 :     (* | getval(REAL _) = Real*)
117 :     | getval _ = Other
118 :     fun call(v, args) = case getval v
119 :     of Fun{call,within=ref false,
120 :     within_sibling=ref false,...} => inc call
121 :     | Fun{call,within=ref false,within_sibling=ref true,
122 :     sibling_call,...} => (inc call;
123 :     inc sibling_call)
124 :     | Fun{call,within=ref true,unroll_call,
125 :     args=vl,invariant,...} =>
126 :     let fun g(VAR x :: args, x' :: vl, i::inv) =
127 :     (i andalso x=x') :: g(args,vl,inv)
128 :     | g( _ :: args, _ :: vl, i::inv) =
129 :     false :: g(args,vl,inv)
130 :     | g _ = nil
131 :     in inc call; inc unroll_call;
132 :     invariant := g(args,vl,!invariant)
133 :     end
134 :     | Arg{savings,...} => inc savings
135 :     | Sel{savings} => inc savings
136 :     | _ => ()
137 :     fun escape v = case getval v
138 :     of Fun{escape,...} => inc escape
139 :     | Arg{escape,...} => inc escape
140 :     | Rec{escape,...} => inc escape
141 :     | _ => ()
142 :     fun escapeargs v = case getval v
143 :     of Fun{escape,...} => inc escape
144 :     | Arg{escape,savings, ...} =>
145 :     (inc escape; inc savings)
146 :     | Sel{savings} => inc savings
147 :     | Rec{escape,...} => inc escape
148 :     | _ => ()
149 :     fun unescapeargs v = case getval v
150 :     of Fun{escape,...} => dec escape
151 :     | Arg{escape,savings, ...} =>
152 :     (dec escape; dec savings)
153 :     | Sel{savings} => dec savings
154 :     | Rec{escape,...} => dec escape
155 :     | _ => ()
156 :     fun notearg v = (note (v,Arg{escape=ref 0,savings=ref 0, record=ref []}))
157 :     fun noteother v = () (* note (v,Other) *)
158 :     fun notereal v = noteother v (* note (v,Real) *)
159 :     fun enter level (_,f,vl,_,e) =
160 :     (note(f,Fun{escape=ref 0, call=ref 0, size=ref 0,
161 :     args=vl, body=e, within=ref false,
162 :     within_sibling=ref false,
163 :     unroll_call = ref 0, sibling_call=ref 0,
164 :     invariant = ref(map (fn _ => CGinvariant) vl),
165 :     level=level});
166 :     app notearg vl)
167 :     fun noterec(w, vl, size) = note (w,Rec{size=size,escape=ref 0,vars=vl})
168 :     fun notesel(i,v,w) = (note (w, Sel{savings=ref 0});
169 :     case getval v
170 :     of Arg{savings,record,...} => (inc savings;
171 :     record := (i,w)::(!record))
172 :     | _ => ())
173 :    
174 :     fun setsize(f,n) = case get f of Fun{size,...} => (size := n; n)
175 :    
176 :     fun incsave(v,k) = case getval v
177 :     of Arg{savings,...} => savings := !savings + k
178 :     | Sel{savings} => savings := !savings + k
179 :     | _ => ()
180 :     fun setsave(v,k) = case getval v
181 :     of Arg{savings,...} => savings := k
182 :     | Sel{savings} => savings := k
183 :     | _ => ()
184 :     fun savesofar v = case getval v
185 :     of Arg{savings,...} => !savings
186 :     | Sel{savings} => !savings
187 :     | _ => 0
188 :    
189 :     fun within_sibling fundefs func arg =
190 :     (app (fn (_,f,_,_,_) =>
191 :     case get f of Fun{within_sibling=w,...} => w := true) fundefs;
192 :     func arg before
193 :     (app (fn (_,f,_,_,_) =>
194 :     case get f of Fun{within_sibling=w,...} => w := false) fundefs))
195 :    
196 :     fun within f func arg =
197 :     case get f of Fun{within=w,...} =>
198 :     (w := true; func arg before (w := false))
199 :    
200 :     val rec prim = fn (level,vl,e) =>
201 :     let fun vbl(VAR v) = (case get v of Rec _ => 0 | _ => 1)
202 :     | vbl _ = 0
203 :     val nonconst = sum vbl vl
204 :     val sl = map savesofar vl
205 :     val afterwards = pass1 level e
206 :     val zl = map savesofar vl
207 :     val overhead = length vl + 1
208 :     val potential = overhead
209 :     val savings = case nonconst of
210 :     1 => potential
211 :     | 2 => potential div 4
212 :     | _ => 0
213 :     fun app3 f = let fun loop (a::b,c::d,e::r) = (f(a,c,e); loop(b,d,r))
214 :     | loop _ = ()
215 :     in loop
216 :     end
217 :     in app3(fn (v,s,z)=> setsave(v,s + savings + (z-s))) (vl,sl,zl);
218 :     overhead+afterwards
219 :     end
220 :    
221 :     and primreal = fn (level,(_,vl,w,_,e)) =>
222 :     (notereal w;
223 :     app (fn v => incsave(v,1)) vl;
224 :     2*(length vl + 1) + pass1 level e)
225 :    
226 :     (*******************************************************************)
227 :     (* pass1: gather info on code. *)
228 :     (*******************************************************************)
229 :     and pass1 : int -> cexp -> int= fn level =>
230 :     fn RECORD(_,vl,w,e) =>
231 :     let val len = length vl
232 :     in app (escape o #1) vl;
233 :     noterec(w,vl,len);
234 :     2 + len + pass1 level e
235 :     end
236 :     | SELECT (i,v,w,_,e) => (notesel(i,v,w); 1 + pass1 level e)
237 :     | OFFSET (i,v,w,e) => (noteother w; 1 + pass1 level e)
238 :     | APP(f,vl) => (call(f,vl);
239 :     app escapeargs vl;
240 :     1 + ((length vl + 1) div 2))
241 :     | FIX(l, e) =>
242 :     (app (enter level) l;
243 :     within_sibling l
244 :     (fn () =>
245 :     (sum (fn (_,f,_,_,e) => setsize(f, within f (pass1 (level+1)) e)) l
246 :     + length l + pass1 level e))
247 :     ())
248 :     | SWITCH(v,_,el) => let val len = length el
249 :     val jumps = 4 + len
250 :     val branches = sum (pass1 level) el
251 :     in incsave(v, muldiv(branches,len-1,len) + jumps);
252 :     jumps+branches
253 :     end
254 :     | BRANCH(_,vl,c,e1,e2) =>
255 :     let fun vbl(VAR v) = (case get v of Rec _ => 0 | _ => 1)
256 :     | vbl _ = 0
257 :     val nonconst = sum vbl vl
258 :     val sl = map savesofar vl
259 :     val branches = pass1 level e1 + pass1 level e2
260 :     val zl = map savesofar vl
261 :     val overhead = length vl
262 :     val potential = overhead + branches div 2
263 :     val savings = case nonconst of
264 :     1 => potential
265 :     | 2 => potential div 4
266 :     | _ => 0
267 :     fun app3 f = let fun loop (a::b,c::d,e::r) = (f(a,c,e); loop(b,d,r))
268 :     | loop _ = ()
269 :     in loop
270 :     end
271 :     in app3(fn (v,s,z)=> setsave(v,s + savings + (z-s) div 2)) (vl,sl,zl);
272 :     overhead+branches
273 :     end
274 :     | LOOKER(_,vl,w,_,e) => (noteother w; prim(level,vl,e))
275 :     | SETTER(_,vl,e) => prim(level,vl,e)
276 :     | ARITH(args as (P.arith{kind=P.FLOAT 64,...},_,_,_,_)) =>
277 :     primreal (level,args)
278 :     | ARITH(args as (P.round _, _,_,_,_)) => primreal (level,args)
279 :     | ARITH(_,vl,w,_,e) => (noteother w; prim(level,vl,e))
280 :     | PURE(P.pure_arith{kind=P.FLOAT 64,...},[v],w,_,e) =>
281 :     (notereal w; incsave(v,1); 4+(pass1 level e))
282 :     | PURE(P.real{tokind=P.FLOAT 64,...},vl,w,_,e) =>
283 :     (notereal w; prim(level,vl,e))
284 :     | PURE(_,vl,w,_,e) => (noteother w; prim(level,vl,e))
285 :    
286 :    
287 :     (*********************************************************************)
288 :     (* substitute(args,wl,e,alpha) : substitute args for wl in e. *)
289 :     (* If alpha=true, also rename all bindings. *)
290 :     (*********************************************************************)
291 :     fun substitute(args,wl,e,alpha) =
292 :     let
293 :     exception Alpha
294 :     val vm : value Intmap.intmap = Intmap.new(16, Alpha)
295 :     fun look (v,default) = Intmap.map vm v handle Alpha => default
296 :     val enter = Intmap.add vm
297 :     fun use(v0 as VAR v) = look(v,v0)
298 :     | use(v0 as LABEL v) = look(v,v0)
299 :     | use x = x
300 :     fun def v = if alpha
301 :     then let val w = copyLvar v
302 :     in enter (v, VAR w); w
303 :     end
304 :     else v
305 :     fun defl v = if alpha
306 :     then let val w = copyLvar v
307 :     in enter (v, label w);
308 :     w
309 :     end
310 :     else v
311 :     fun bind(a::args,w::wl) =
312 :     (sameName(w,a); enter (w,a); bind(args,wl))
313 :     | bind _ = ()
314 :    
315 :     val rec g =
316 :     fn RECORD(k,vl,w,ce) => RECORD(k,map (map1 use) vl, def w, g ce)
317 :     | SELECT(i,v,w,t,ce) => SELECT(i, use v, def w, t, g ce)
318 :     | OFFSET(i,v,w,ce) => OFFSET(i, use v, def w, g ce)
319 :     | APP(v,vl) => APP(use v, map use vl)
320 :     | FIX(l,ce) =>
321 :     let (* Careful: order of evaluation is important here. *)
322 :     fun h1(fk,f,vl,cl,e) = (fk,defl f,vl,cl,e)
323 :     fun h2(fk,f',vl,cl,e) =
324 :     let val vl' = map def vl
325 :     val e'= g e
326 :     in (fk,f',vl',cl,e')
327 :     end
328 :     in FIX(map h2(map h1 l), g ce)
329 :     end
330 :     | SWITCH(v,c,l) => SWITCH(use v, def c, map g l)
331 :     | LOOKER(i,vl,w,t,e) => LOOKER(i, map use vl, def w, t, g e)
332 :     | ARITH(i,vl,w,t,e) => ARITH(i, map use vl, def w, t, g e)
333 :     | PURE(i,vl,w,t,e) => PURE(i, map use vl, def w, t, g e)
334 :     | SETTER(i,vl,e) => SETTER(i, map use vl, g e)
335 :     | BRANCH(i,vl,c,e1,e2) => BRANCH(i, map use vl, def c, g e1, g e2)
336 :    
337 :     in bind(args,wl); g e
338 :     end
339 :    
340 :     fun whatsave(acc, size, (v:value)::vl, a::al) =
341 :     if acc>=size
342 :     then acc
343 :     else
344 :     (case get a of
345 :     Arg{escape=ref esc,savings=ref save,record=ref rl} =>
346 :     let val (this, nvl: value list, nal) =
347 :     case getval v
348 :     of Fun{escape=ref 1,...} =>
349 :     (if esc>0 then save else 6+save,vl,al)
350 :     | Fun _ => (save,vl,al)
351 :     | Rec{escape=ref ex,vars,size} =>
352 :     let exception Chase
353 :     fun chasepath(v,OFFp 0) = v
354 :     | chasepath(v, SELp(i,p)) =
355 :     (case getval v
356 :     of Rec{vars,...} =>
357 :     chasepath(chasepath(List.nth(vars,i)),p)
358 :     | _ => raise Chase)
359 :     | chasepath _ = raise Chase
360 :     fun loop([],nvl,nal) =
361 :     (if ex>1 orelse esc>0
362 :     then save
363 :     else save+size+2,nvl,nal)
364 :     | loop((i,w)::rl,nvl,nal) =
365 :     loop(rl,
366 :     chasepath(List.nth(vars,i))::nvl,
367 :     w::nal)
368 :     in loop(rl,vl,al)
369 :     handle Chase => (0,vl,al)
370 :     | Subscript => (0,vl,al)
371 :     end
372 :     (* | Real => (save,vl,al)*)
373 :     | Const => (save,vl,al)
374 :     | _ => (0,vl,al)
375 :     in whatsave(acc+this - muldiv(acc,this,size), size, nvl,nal)
376 :     end
377 :     | Sel{savings=ref save} =>
378 :     let val this =
379 :     case v
380 :     of VAR v' => (case get v' of
381 :     Fun _ => save
382 :     | Rec _ => save
383 :     | _ => 0)
384 :     | _ => save
385 :     in whatsave(acc + this - muldiv(acc,this,size),size, vl,al)
386 :     end)
387 :     | whatsave(acc,size,_,_) = acc
388 :    
389 :    
390 :     (*************************************************************
391 :     * should_expand: should a function application be inlined? *
392 :     *************************************************************)
393 :     fun should_expand(d, (* path length from entry to current function *)
394 :     u, (* unroll level *)
395 :     e as APP(v,vl),
396 :     Fun{escape,call,unroll_call,size=ref size,args,body,
397 :     level,within=ref within,...}) =
398 :     if !call + !escape = 1 then false else
399 :     let val stupidloop = (* prevent infinite loops at compile time *)
400 :     case (v,body)
401 :     of (VAR vv, APP(VAR v',_)) => vv=v'
402 :     | (LABEL vv, APP(LABEL v',_)) => vv=v'
403 :     | _ => false
404 :     val calls = case u of UNROLL _ => !unroll_call | _ => !call
405 :     val small_fun_size = case u of UNROLL _ => 0 | _ => 50
406 :     val savings = whatsave(0,size,vl,args)
407 :     val predicted =
408 :     let val real_increase = size-savings-(1+length vl)
409 :     in real_increase * calls -
410 :     (* don't subtract off the original body if
411 :     the original body is huge (because we might
412 :     have guessed wrong and the consequences are
413 :     too nasty for big functions); or if we're
414 :     in unroll mode *)
415 :     (if size < small_fun_size then size else 0)
416 :     end
417 :     val depth = 2 and max = 2
418 :    
419 :     in if false andalso debug
420 :     then (PPCps.prcps e;
421 :     debugprint(Int.toString predicted); debugprint " ";
422 :     debugprint(Int.toString bodysize); debugprint "\n")
423 :     else ();
424 :    
425 :     not stupidloop
426 :     andalso case u
427 :     of UNROLL lev =>
428 :     (* Unroll if: the loop body doesn't make function
429 :     calls orelse "unroll_recur" is turned on; andalso
430 :     we are within the definition of the function;
431 :     andalso it looks like things won't grow too much.
432 :     *)
433 :     (!CG.unroll_recur orelse level >= lev)
434 :     andalso within andalso predicted <= bodysize
435 :     | NO_UNROLL =>
436 :     !unroll_call = 0 andalso
437 :     not within andalso
438 :     (predicted <= bodysize
439 :     orelse (!escape=0 andalso calls = 1))
440 :     | HEADERS => false (* shouldn't get here *)
441 :     | ALL =>
442 :     (predicted <= bodysize
443 :     orelse (!escape=0 andalso calls = 1))
444 :     end
445 :    
446 :     datatype decision = YES of {formals: lvar list, body: cexp}
447 :     | NO of int (* how many no's in a row *)
448 :     (* There is really no point in making decisions a ref. This should
449 :     be changed one day. *)
450 :     val decisions : decision list ref = ref nil
451 :     fun decide_yes x = decisions := YES x :: !decisions
452 :     fun decide_no () = decisions :=
453 :     (case !decisions
454 :     of NO n :: rest => NO(n+1) :: rest
455 :     | d => NO 1 :: d)
456 :    
457 :    
458 :     (*********************************************************************)
459 :     (* pass2: mark function applications to be inlined. *)
460 :     (*********************************************************************)
461 :     fun pass2(d, (* path length from start of current function *)
462 :     u, (* unroll-info *)
463 :     e (* expression to traverse *)
464 :     ) = case e
465 :    
466 :     of RECORD(k,vl,w,ce) => pass2(d+2+length vl,u,ce)
467 :     | SELECT(i,v,w,t,ce) => pass2(d+1,u,ce)
468 :     | OFFSET(i,v,w,ce) => pass2(d+1,u,ce)
469 :     | APP(v,vl) =>
470 :     (case getval v
471 :     of info as Fun{args,body,...} =>
472 :     if should_expand(d,u,e,info)
473 :     then decide_yes{formals=args,body=body}
474 :     else decide_no()
475 :     | _ => decide_no())
476 :     | FIX(l,ce) =>
477 :     let fun fundef (NO_INLINE_INTO,_,_,_,_) = ()
478 :     | fundef (fk,f,vl,cl,e) =
479 :     let val Fun{level,within,escape=ref escape,...} = get f
480 :    
481 :     val u' = case u of UNROLL _ => UNROLL level | _ => u
482 :    
483 :     fun conform((VAR x)::r,z::l) = (x=z) andalso conform(r,l)
484 :     | conform(_::r,_::l) = false
485 :     | conform([],[]) = true
486 :     | conform _ = false
487 :    
488 :     in within := true;
489 :     pass2(0,u',e)
490 :     before within := false
491 :     end
492 :     in app fundef l;
493 :     pass2(d+length l,u,ce)
494 :     end
495 :     | SWITCH(v,c,l) => app (fn e => pass2(d+2,u,e)) l
496 :     | LOOKER(i,vl,w,t,e) => pass2(d+2,u,e)
497 :     | ARITH(i,vl,w,t,e) => pass2(d+2,u,e)
498 :     | PURE(i,vl,w,t,e) => pass2(d+2,u,e)
499 :     | SETTER(i,vl,e) => pass2(d+2,u,e)
500 :     | BRANCH(i,vl,c,e1,e2) => (pass2(d+2,u,e1);
501 :     pass2(d+2,u,e2))
502 :    
503 :    
504 :     (* Do loop-header optimizations, elimination of invariant loop arguments,
505 :     hoisting of invariant computations. *)
506 :    
507 :    
508 :     fun from_outside (_,f,_,_,_) =
509 :     case get f of Fun{escape,call,unroll_call,sibling_call,...} =>
510 :     !escape > 0 orelse
511 :     !call > !unroll_call + !sibling_call
512 :    
513 :     fun loop_opt(bigexp) =
514 :     let exception Gamma_Levmap
515 :     (* For each variable, tell what level of loop nesting at its definition*)
516 :     val levmap : int Intmap.intmap = Intmap.new(16,Gamma_Levmap)
517 :     val level_of' = Intmap.map levmap
518 :     fun level_of(VAR v) = (level_of' v handle Gamma_Levmap => 0 )
519 :     (* ^^^ clean this up *)
520 :     | level_of(LABEL v) = level_of (VAR v)
521 :     | level_of _ = 0
522 :     val note_level = Intmap.add levmap
523 :    
524 :     val _ = app (fn v => note_level(v,0)) fargs
525 :    
526 :     exception Gamma_Hoistmap
527 :     (* For each level, tell what expressions are hoisted there *)
528 :     val hoistmap : (cexp->cexp) Intmap.intmap = Intmap.new(16,Gamma_Hoistmap)
529 :     fun hoisted_here (lev) = Intmap.map hoistmap lev
530 :     handle Gamma_Hoistmap => (fn e=>e)
531 :     fun any_hoisted_here (lev) = (Intmap.map hoistmap lev; true)
532 :     handle Gamma_Hoistmap => false
533 :     fun reset_hoist(lev) = Intmap.rmv hoistmap lev
534 :     fun add_hoist(lev,f) =
535 :     let val h = hoisted_here lev
536 :     in Intmap.add hoistmap (lev, h o f)
537 :     end
538 :    
539 :     fun gamma_lev(level,e) =
540 :     let fun def w = note_level(w,level)
541 :     fun formaldef wl = app (fn w => note_level(w,level+1)) wl
542 :     fun gamma e = gamma_lev(level,e)
543 :     fun tryhoist(vl,w,e,f) =
544 :     let val minlev = foldr Int.min 1000000000 (map level_of vl)
545 :     in if minlev < level
546 :     then (add_hoist(minlev, f);
547 :     note_level(w, minlev);
548 :     click "#";
549 :     gamma e)
550 :     else (def w; f(gamma e))
551 :     end
552 :    
553 :     in case e
554 :     of RECORD(k,vl,w,ce) => tryhoist(map #1 vl, w, ce,
555 :     fn e => RECORD(k,vl, w, e))
556 :     | SELECT(i,v,w,t,ce) => tryhoist([v],w,ce, fn e=>SELECT(i, v, w, t,e))
557 :     | OFFSET(i,v,w,ce) => tryhoist([v],w,ce, fn e=>OFFSET(i, v, w, e))
558 :     | e as APP(v,vl) => e
559 :     | SWITCH(v,c,l) => (def c; SWITCH(v, c, map gamma l))
560 :     | LOOKER(i,vl,w,t,e) => (def w; LOOKER(i, vl, w, t, gamma e))
561 :     | ARITH(i,vl,w,t,e) => (def w; ARITH(i, vl, w, t, gamma e))
562 :     | PURE(i,vl,w,t,e) => tryhoist(vl,w,e, fn e=>PURE(i,vl,w,t,e))
563 :     | SETTER(i,vl,e) => SETTER(i, vl, gamma e)
564 :     | BRANCH(i,vl,c,e1,e2) => (def c; BRANCH(i, vl, c,gamma e1, gamma e2))
565 :     | FIX(l,ce) =>
566 :     let fun fundef (z as (NO_INLINE_INTO,_,_,_,_)) = z
567 :     | fundef (fk,f,vl,cl,e) =
568 :     let val Fun{escape=ref escape,call,unroll_call,
569 :     invariant=ref inv,...} = get f
570 :    
571 :     val _ = app def vl
572 :    
573 :     (* A "loop" is a function called from inside itself.
574 :     Here we will ensure that any loop has a unique entry
575 :     point; that is, any loop has only one call from
576 :     outside itself. We do this by making a "header"
577 :     and "pre-header". Also, any argument passed around
578 :     the loop but never used is hoisted out. See also:
579 :    
580 :     Loop Headers in Lambda-calculus or CPS. Andrew W. Appel.
581 :     CS-TR-460-94, Princeton University, June 15, 1994. To appear
582 :     in _Lisp and Symbolic Computation_ 7, 337-343 (1994).
583 :     ftp://ftp.cs.princeton.edu/reports/1994/460.ps.Z
584 :     *)
585 :    
586 :     in if escape = 0 andalso !unroll_call > 0
587 :     then let val e' = gamma_lev(level+1,e)
588 :     in if (!call - !unroll_call > 1
589 :     orelse List.exists (fn t=>t) inv
590 :     orelse any_hoisted_here(level))
591 :     then let val f'::vl' = map copyLvar (f::vl)
592 :     fun drop(false::r,a::s) = a::drop(r,s)
593 :     | drop(true::r,_::s) = drop(r,s)
594 :     | drop _ = nil
595 :     val newformals=label f' :: map VAR (drop(inv,vl'))
596 :     val e'' =substitute(newformals,
597 :     f :: drop(inv,vl),
598 :     e',
599 :     false)
600 :     val hoisted = hoisted_here level
601 :     in click "!"; debugprint(Int.toString f);
602 :     reset_hoist level;
603 :     (* app def (f'::vl'); Unnecessary *)
604 :     enter 0 (fk,f',vl',cl,e'');
605 :     (fk,f,vl,cl,
606 :     hoisted(FIX([(fk,f',vl',cl,e'')],
607 :     APP(label f', map VAR vl))))
608 :     end
609 :     else (fk,f,vl,cl,e')
610 :     end
611 :     else (fk,f,vl,cl,gamma e)
612 :    
613 :     end
614 :     in
615 :     case split from_outside l
616 :     of ([(fk,f,vl,cl,e)], others as _::_) =>
617 :     (* for any FIX containing more than one function,
618 :     but only one of them called from the body of the FIX
619 :     itself, split into two levels to hide the
620 :     "auxiliary" functions inside the externally called
621 :     function. *)
622 :     let val Fun{sibling_call as ref sib,
623 :     unroll_call as ref unr,...} = get f
624 :     in sibling_call := 0;
625 :     unroll_call := unr + sib;
626 :     def f;
627 :     click "`"; (* temporary: *) print "`";
628 :     app (fn (_,ff,_,_,_) =>
629 :     let val Fun{sibling_call,...} = get ff
630 :     in sibling_call := 0 (* this is a conservative
631 :     estimate, I hope. *)
632 :     end)
633 :     others;
634 :     gamma(FIX([(fk,f,vl,cl, FIX(others,e))], ce))
635 :     end
636 :     (* for any other kind of FIX, proceed with
637 :     loop detection on each function individually*)
638 :     | _ => (app (def o #2) l;
639 :     FIX(map fundef l, gamma ce))
640 :     end
641 :     end
642 :    
643 :     val bigexp' = gamma_lev(1,bigexp)
644 :     in hoisted_here 0 bigexp'
645 :     end
646 :    
647 :     val rec beta =
648 :     fn RECORD(k,vl,w,ce) => RECORD(k,vl,w,beta ce)
649 :     | SELECT(i,v,w,t,ce) => SELECT(i,v,w,t,beta ce)
650 :     | OFFSET(i,v,w,ce) => OFFSET(i,v,w,beta ce)
651 :     | e as APP(v,vl) =>
652 :     (case !decisions
653 :     of YES{formals,body}::rest =>
654 :     (click "^";
655 :     case v of VAR vv => debugprint(Int.toString vv) | _ => ();
656 :     debugflush();
657 :     decisions := rest;
658 :     substitute(vl,formals,body,true))
659 :     | NO 1::rest => (decisions := rest; e)
660 :     | NO n :: rest => (decisions := NO(n-1)::rest; e))
661 :     | FIX(l,ce) =>
662 :     let fun fundef (z as (NO_INLINE_INTO,_,_,_,_)) = z
663 :     | fundef (fk,f,vl,cl,e) = (fk,f,vl,cl,beta e)
664 :     in FIX(map fundef l, beta ce)
665 :     end
666 :     | SWITCH(v,c,l) => SWITCH(v,c,map beta l)
667 :     | LOOKER(i,vl,w,t,e) => LOOKER(i,vl,w,t,beta e)
668 :     | ARITH(i,vl,w,t,e) => ARITH(i,vl,w,t,beta e)
669 :     | PURE(i,vl,w,t,e) => PURE(i,vl,w,t,beta e)
670 :     | SETTER(i,vl,e) => SETTER(i,vl,beta e)
671 :     | BRANCH(i,vl,c,e1,e2) => BRANCH(i,vl,c,beta e1,beta e2)
672 :    
673 :    
674 :    
675 :     fun pass2_beta(mode,e) =
676 :     (pass2(0,mode,e);
677 :     discard_pass1_info();
678 :     debugprint "Expand: finishing pass2\n"; debugflush();
679 :     case !decisions
680 :     of [NO _] => (debugprint "No expansions to do.\n"; debugflush();
681 :     e)
682 :     | _ => (decisions := rev(!decisions);
683 :     debugprint "Beta: ";
684 :     beta e
685 :     before
686 :     (debugprint "\n"; debugflush())))
687 :    
688 :     fun prCexp cexp =
689 :     PPCps.printcps0(fkind,fvar,fargs,ctyl,cexp)
690 :    
691 :    
692 :     val gamma = fn c =>
693 :     (print "Before Gamma:\n";
694 :     prCexp c;
695 :     debugprint "Gamma: ";
696 :     let val c' = loop_opt c
697 :     in print "After Gamma:\n";
698 :     prCexp c';
699 :     c'
700 :     end
701 :     before
702 :     (debugprint "\n"; debugflush()))
703 :    
704 :     in (* body of expand *)
705 :     notearg fvar;
706 :     app notearg fargs;
707 :     (***>
708 :     if !CG.printit then CPSprint.show Control.Print.say cexp
709 :     else ();
710 :     <***)
711 :     debugprint("Expand: pass1: ");
712 :     debugprint(Int.toString(pass1 0 cexp));
713 :     debugprint "\n";
714 :     debugflush();
715 :    
716 :     if unroll
717 :     then let val _ = (debugprint(" (unroll)\n"); debugflush());
718 :     val e' = pass2_beta(UNROLL 0,cexp)
719 :     in if !clicked_any
720 :     then expand{function=(fkind,fvar,fargs,ctyl,e'),
721 :     table=typtable,
722 :     bodysize=bodysize,click=click,unroll=unroll,
723 :     afterClosure=afterClosure,
724 :     do_headers=do_headers}
725 :     else ((*debugprint("\nExpand\n");
726 :     debugflush();
727 :     (fkind,fvar,fargs,ctyl,pass2_beta(ALL,cexp)) *)
728 :     (fkind,fvar,fargs,ctyl,e'))
729 :     end
730 :     else if !CG.unroll
731 :     then let val _ = (debugprint(" (headers)\n"); debugflush())
732 :     val e' = if do_headers then gamma cexp else cexp
733 :     in if !clicked_any
734 :     then expand{function=(fkind,fvar,fargs,ctyl,e'),
735 :     table=typtable,bodysize=bodysize,click=click,
736 :     unroll=unroll,afterClosure=afterClosure,
737 :     do_headers=false}
738 :     else (debugprint(" (non-unroll 1)\n"); debugflush();
739 :     (fkind,fvar,fargs,ctyl,pass2_beta(NO_UNROLL,e')))
740 :     end
741 :     else (debugprint(" (non-unroll 2)\n"); debugflush();
742 :     (fkind,fvar,fargs,ctyl,pass2_beta(ALL,cexp)))
743 :     end
744 :    
745 :     end (* local *)
746 :     end (* functor Expand *)
747 :    
748 :     (*
749 :     * $Log: expandNEW.sml,v $
750 :     * Revision 1.1.1.1 1997/01/14 01:38:31 george
751 :     * Version 109.24
752 :     *
753 :     *)

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