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

Parent Directory | Revision Log

---

Revision 626 - (view) (download)

1 :	monnier	16	(* Copyright 1989 by Bell Laboratories *)
2 :			(* cpsopt.sml *)
3 :
4 :			signature CPSOPT = sig
5 :	monnier	100	val reduce : (CPS.function * Unsafe.Object.object option * bool)
6 :			-> CPS.function
7 :	monnier	16	end (* signature CPSOPT *)
8 :
9 :			functor CPSopt(MachSpec: MACH_SPEC) : CPSOPT = struct
10 :
11 :			structure CG = Control.CG
12 :			structure Eta = Eta
13 :			structure Contract = Contract(MachSpec)
14 :			structure Expand = Expand(MachSpec)
15 :			structure EtaSplit = EtaSplit(MachSpec)
16 :			structure Flatten = Flatten(MachSpec)
17 :			structure Uncurry = Uncurry(MachSpec)
18 :	monnier	69	val say = Control.Print.say
19 :	monnier	16
20 :	monnier	100	(** obsolete table: used by cpsopt as a dummy template *)
21 :			exception ZZZ
22 :			val dummyTable : FLINT.lty Intmap.intmap = Intmap.new(32, ZZZ)
23 :
24 :			(** the main function reduce *)
25 :			fun reduce (function, _, afterClosure) =
26 :	monnier	16	(* NOTE: The third argument to reduce is currently ignored.
27 :			It used to be used for reopening closures. *)
28 :			let
29 :
30 :	monnier	100	val table = dummyTable
31 :	monnier	16	val debug = !CG.debugcps (* false *)
32 :	monnier	69	fun debugprint s = if debug then say s else ()
33 :	monnier	16	fun debugflush() = if debug then Control.Print.flush() else ()
34 :			val clicked = ref 0
35 :			fun click (s:string) = (debugprint s; clicked := !clicked+1)
36 :
37 :			val cpssize = ref 0
38 :	monnier	100
39 :	monnier	69	val prC =
40 :			let fun prGen (flag,printE) s e =
41 :			if !flag then (say ("\n\n[After " ^ s ^ " ...]\n\n"); printE e; e)
42 :			else e
43 :			in prGen (Control.CG.printit, PPCps.printcps0)
44 :			end
45 :	monnier	16
46 :			fun contract last f =
47 :			let val f' = (clicked := 0;
48 :			Contract.contract{function=f,table=table,click=click,
49 :			last=last,size=cpssize})
50 :			in app debugprint ["Contract stats: CPS Size = ", Int.toString (!cpssize),
51 :			" , clicks = ", Int.toString (!clicked), "\n"];
52 :			f'
53 :			end
54 :
55 :			(* dropargs are turned off in first_contract to ban unsafe eta reduction *)
56 :			fun first_contract f =
57 :			let val dpargs = !CG.dropargs
58 :			val f' = (clicked := 0; CG.dropargs := false;
59 :			Contract.contract{function=f,table=table,click=click,
60 :			last=false,size=cpssize})
61 :			in app debugprint ["Contract stats: CPS Size = ", Int.toString (!cpssize),
62 :			" , clicks = ", Int.toString (!clicked), "\n"];
63 :			CG.dropargs := dpargs;
64 :			f'
65 :			end
66 :
67 :			(* in the last contract phase, certain contractions are prohibited *)
68 :			fun last_contract f =
69 :			let val f' = (clicked := 0;
70 :			Contract.contract{function=f,table=table,click=click,
71 :			last=true,size=cpssize})
72 :			in app debugprint ["Contract stats: CPS Size = ", Int.toString (!cpssize),
73 :			" , clicks = ", Int.toString (!clicked), "\n"];
74 :			f'
75 :			end
76 :
77 :			fun expand(f,n,unroll) =
78 :			(clicked := 0;
79 :			if not(!CG.betaexpand) then f else
80 :			let val f' = Expand.expand{function=f,click=click,bodysize=n,
81 :			afterClosure=afterClosure,table=table,
82 :			unroll=unroll,do_headers=true}
83 :			in app debugprint["Expand stats: clicks = ", Int.toString (!clicked), "\n"];
84 :			f'
85 :			end)
86 :
87 :	monnier	626	fun zeroexpand f = Expand.expand{function=f, click=click, bodysize=0,
88 :			afterClosure=afterClosure, table=table,
89 :			unroll=false, do_headers=false}
90 :
91 :	monnier	16	fun flatten f =
92 :			(clicked := 0;
93 :			if not(!CG.flattenargs) then f else
94 :			let val f' = Flatten.flatten{function=f,table=table,click=click}
95 :			in app debugprint["Flatten stats: clicks = ", Int.toString (!clicked), "\n"];
96 :			f'
97 :			end)
98 :
99 :			fun unroll_contract(f,n) =
100 :			let val f' = expand(f,n,true)
101 :			val c = !clicked
102 :			in if c>0 then (c,contract true f')
103 :			else (c,f')
104 :			end
105 :
106 :			fun expand_flatten_contract(f,n) =
107 :			let val f1 = expand(f,n,false)
108 :			val c1 = !clicked
109 :			val f2 = flatten f1
110 :			val c2 = !clicked
111 :			val c = c1+c2
112 :			in if c>0 then (c,contract false f2)
113 :			else (c,f2)
114 :			end
115 :
116 :			fun eta f =
117 :			(clicked := 0;
118 :			if not(!CG.eta) then f else
119 :			let val f' = Eta.eta{function=f,click=click}
120 :			in app debugprint["Eta stats: clicks = ", Int.toString (!clicked), "\n"];
121 :			f'
122 :			end)
123 :
124 :			fun uncurry f = if afterClosure then f else
125 :			(clicked := 0;
126 :			if not(!CG.uncurry) then f else
127 :			let val f' = Uncurry.etasplit{function=f,table=table,click=click}
128 :			in app debugprint["Uncurry stats: clicks = ", Int.toString (!clicked), "\n"];
129 :			f'
130 :			end)
131 :
132 :			fun etasplit f =
133 :			(clicked := 0;
134 :			if not(!CG.etasplit) then f else
135 :			let val f' = EtaSplit.etasplit{function=f,table=table,click=click}
136 :			in app debugprint["Etasplit stats: clicks = ",
137 :			Int.toString (!clicked), "\n"];
138 :			f'
139 :			end)
140 :
141 :
142 :			fun lambdaprop x = x
143 :			(* if !CG.lambdaprop then (debugprint "\nLambdaprop:"; CfUse.hoist x)
144 :			else x *)
145 :
146 :			val bodysize = !CG.bodysize
147 :			val rounds = !CG.rounds
148 :			val reducemore = !CG.reducemore
149 :
150 :			(*
151 :			* Note the parameter k starts at rounds..0
152 :			*)
153 :			fun linear_decrease k = (bodysize * k) div rounds
154 :			(*** NOT USED ***
155 :			fun double_linear k = (bodysize*2*k div rounds) - bodysize
156 :			fun cosine_decrease k =
157 :			Real.trunc(real bodysize * (Math.cos(1.5708*(1.0 - real k / real rounds))))
158 :			***)
159 :
160 :
161 :			(* This function is just hacked up and should be tuned someday *)
162 :			fun cycle(0,true,func) = func
163 :			| cycle(0,false,func) = unroll func
164 :			| cycle(k,unrolled,func) =
165 :			let val func = lambdaprop func
166 :			val (c,func) =
167 :			if !CG.betaexpand orelse !CG.flattenargs
168 :			then expand_flatten_contract(func,linear_decrease k)
169 :			else (0,func)
170 :	monnier	100	(* val _ = prC "cycle_contract" func *)
171 :
172 :	monnier	16	in if c * 1000 <= !cpssize * reducemore
173 :			then if unrolled then func
174 :			else unroll func
175 :			else cycle(k-1, unrolled, func)
176 :			end
177 :
178 :			and unroll func =
179 :			let val (c,func') = unroll_contract(func,bodysize)
180 :			in if c>0 then cycle(rounds,true,func')
181 :			else func'
182 :			end
183 :
184 :	monnier	100	in (if rounds < 0 then function
185 :	monnier	162	else let fun apply ("first_contract",f)= first_contract f
186 :			| apply ("eta",f) = eta f
187 :			| apply ("uncurry",f) = uncurry f
188 :			| apply ("etasplit",f) = etasplit f
189 :			| apply ("last_contract",f) = last_contract f
190 :			| apply ("cycle_expand",f) = cycle(rounds, not(!CG.unroll), f)
191 :	monnier	218	| apply ("contract",f) = contract false f
192 :			| apply ("flatten",f) = flatten f
193 :	monnier	626	| apply ("zeroexpand",f) = zeroexpand f
194 :	monnier	218	| apply ("expand",f) = expand(f, bodysize, false)
195 :	monnier	162	| apply ("print",f) = (PPCps.printcps0 f; f)
196 :			| apply (p,f) = (say("\n!! Unknown cps phase '"^p^"' !!\n"); f)
197 :			in foldl apply function (!CG.cpsopt)
198 :	monnier	213	(* val function1 = first_contract function *)
199 :	monnier	162	(* val function2 = eta function1 *)
200 :			(* val function3 = uncurry function2 *)
201 :			(* val function4 = etasplit function3 *)
202 :			(* val function5 = cycle(rounds, not(!CG.unroll), function4) *)
203 :			(* val function6 = eta function5 (* ZSH added this new phase *) *)
204 :			(* val function7 = last_contract function6 *)
205 :			(* in function7 *)
206 :			end)
207 :	monnier	16	before (debugprint "\n"; debugflush())
208 :
209 :			end (* fun reduce *)
210 :
211 :			end (* functor CPSopt *)

---

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