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

Parent Directory | 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