Annotation of /sml/trunk/src/compiler/FLINT/opt/switchoff.sml

Parent Directory | Revision Log

---

Revision 540 - (view) (download)

1 :	dtelle	532	(* is there a copyright of some kind ? Well, anyway : 2000 YALE FLINT PROJECT*)
2 :			(* dtelle@ens-lyon.fr / teller-david@cs.yale.edu *)
3 :
4 :			signature SWITCHOFF =
5 :			sig
6 :			val switchoff : FLINT.prog -> FLINT.prog
7 :			end
8 :
9 :			structure Switchoff :> SWITCHOFF =
10 :			struct
11 :			local
12 :			structure F = FLINT
13 :			structure O = Option
14 :			structure S = IntRedBlackSet
15 :			structure I = Intmap
16 :			structure X = TextIO
17 :			in
18 :
19 :			fun bug msg = ErrorMsg.impossible ("Switchoff: "^msg)
20 :			exception NotFound
21 :			(*this function is supposed to remove as many embedded witches
22 :			*as possible, by rewriting the program into a continuation-style
23 :			*and letting the inliner do the tough job*)
24 :
25 :			fun switchoff (prog as (progkind, progname, progargs, progbody)) = let
26 :			val mklv = LambdaVar.mkLvar
27 :			val {getLty,...} = Recover.recover (prog, false)
28 :
29 :			(*does the set contain this variable ?
30 :			*contains : 'a intmap -> int -> bool*)
31 :			fun contains set var =
32 :			(I.map set var;
33 :			true) handle NotFound => false
34 :
35 :			(*put source into destination
36 :			*setUnion : 'a intmap -> 'a intmap -> 'a intmap*)
37 :			and setUnion destination source =
38 :			I.app (I.add destination) source
39 :
40 :			(*remove all members of elements from from
41 :			setRemove : 'a intmap -> int list -> 'a intmap*)
42 :			and setRemove from elements =
43 :			app (I.rmv from) elements
44 :
45 :			(**)
46 :			and inCase set (pat, body) =
47 :			let val (result, variables) = inside body
48 :			in
49 :			I.app (I.add set) variables;
50 :			case pat of
51 :			F.DATAcon(_,_,var) => I.rmv variables var
52 :			|_ => ();
53 :			(pat, result)
54 :			end
55 :
56 :			and inDefault set default =
57 :			case default of
58 :			SOME expression =>
59 :			let val (result, variables) = inside expression
60 :			in
61 :			I.app (I.add set) variables;
62 :			SOME result
63 :			end
64 :			| _ => NONE
65 :
66 :			and putFunInExpr funLVar (expr : F.lexp) =
67 :			let val newVar = mklv()
68 :			in
69 :			F.LET([newVar], expr, F.APP(funLVar, [F.VAR newVar]))
70 :			end
71 :
72 :			and putFunInCase funLVar (pat, body : F.lexp) =
73 :			(pat, putFunInExpr funLVar body)
74 :
75 :			and putFunInDefault funLVar expr =
76 :			case expr of
77 :			SOME expression => SOME (putFunInExpr funLVar expression)
78 :			| _ => NONE
79 :
80 :			and valueAdder set value = case value of
81 :			F.VAR v => I.add set (v, true)
82 :			| _ => ()
83 :
84 :			and fst (a,_) = a
85 :
86 :			(*
87 :			* inside : tree -> (tree, bool intmap)
88 :			* (rewritten expression, set of free variables)
89 :			*)
90 :			and inside tree =
91 :			case tree of
92 :			F.LET (assign as [x],
93 :			F.SWITCH(name as F.VAR(y), conds, handles, default), cont) =>
94 :			let val (newCont, nextVariables) = inside cont
95 :	monnier	540	val optHandles = map (inCase nextVariables) handles
96 :			val optDefault = inDefault nextVariables default
97 :	dtelle	532	in
98 :	monnier	540	if contains nextVariables x
99 :			then (
100 :			(*cannot optimize*)
101 :			I.rmv nextVariables x;
102 :			(F.LET(assign,
103 :			F.SWITCH
104 :			(
105 :			name,
106 :			conds,
107 :			optHandles,
108 :			optDefault
109 :			),
110 :			newCont),
111 :			nextVariables))
112 :			else (
113 :			(*optimize*)
114 :			I.add nextVariables (y, true);
115 :			let val newFunID = (mklv())
116 :			val newFunction = (F.VAR newFunID)
117 :			val optimized =
118 :			F.FIX
119 :			(
120 :			[({
121 :			inline = F.IH_MAYBE(1, [2]),
122 :			known = true, (*?*)
123 :			cconv = F.CC_FUN LtyKernel.FF_FIXED,
124 :			isrec = NONE
125 :			},
126 :			newFunID, [(x, getLty (F.VAR x))], newCont)],
127 :			F.SWITCH(name,
128 :			conds,
129 :			map (putFunInCase newFunction) handles,
130 :			putFunInDefault newFunction default))
131 :			in
132 :			(optimized, nextVariables)
133 :			end)
134 :	dtelle	532	end
135 :			| F.LET (vars, exp, block) =>
136 :			let val (optExpr, varExpr) = inside exp
137 :			val (optBlock, varBlock) = inside block
138 :			in
139 :			setUnion varExpr varBlock;
140 :			setRemove varExpr vars;
141 :			(F.LET(vars, optExpr, optBlock), varExpr)
142 :			end
143 :			| F.RET values =>
144 :			let val vars = I.new(8, NotFound)
145 :			in
146 :			map (valueAdder vars) values;
147 :			(tree, vars)
148 :			end
149 :			| F.FIX (funs, block) =>
150 :			let val (optBlock, varBlock) = inside block
151 :			in
152 :			let fun aux (kind, name, args, body) =
153 :			let val (optBody, varBody) = inside body
154 :			in
155 :			(*first remove local "variables"*)
156 :			setRemove varBody (map fst args);
157 :			(*then join the sets*)
158 :			setUnion varBlock varBody;
159 :			(kind, name, args, optBody)
160 :			end
161 :			fun removeFuns (_, name, _, _) =
162 :			(*now, remove function names*)
163 :			I.rmv varBlock name;
164 :			in
165 :			let val l = map aux funs
166 :			in
167 :			app removeFuns l;
168 :			(F.FIX(l, optBlock), varBlock)
169 :			end
170 :			end
171 :			end
172 :			| F.APP (applied, appliedOn) =>
173 :			let val vars = I.new (8, NotFound)
174 :			in
175 :			let val adder = valueAdder vars
176 :			in
177 :			adder applied;
178 :			app adder appliedOn;
179 :			(tree, vars)
180 :			end
181 :			end
182 :			| F.TFN (dec, block) =>
183 :			let val (kind, var, cons, exp) = dec
184 :			in
185 :			let val (optExp, varExp) = inside exp
186 :			val (optBlock, varBlock) = inside block
187 :			in
188 :			setUnion varExp varBlock;
189 :			I.rmv varBlock var;
190 :			(F.TFN((kind, var, cons, optExp), optBlock), varBlock)
191 :			end
192 :			end
193 :			| F.TAPP (value, _) =>
194 :			let val vars = I.new(8, NotFound)
195 :			in
196 :			valueAdder vars value;
197 :			(tree, vars)
198 :			end
199 :			| F.SWITCH (value, conds, handles, default) =>
200 :			let val vars = I.new(8, NotFound)
201 :			val optDefault = inDefault vars default
202 :			val optHandles = map (inCase vars) handles
203 :			in
204 :			(F.SWITCH (value, conds, optHandles, optDefault), vars)
205 :			end
206 :			| F.CON (dbg, cons, value, var, block) =>
207 :			let val (optBlock, varBlock) = inside block in
208 :			valueAdder varBlock value;
209 :			I.rmv varBlock var;
210 :			(F.CON(dbg, cons, value, var, optBlock), varBlock)
211 :			end
212 :			| F.RECORD (kind, values, var, block) =>
213 :			let val (optBlock, varBlock) = inside block
214 :			in
215 :			let val adder = valueAdder varBlock
216 :			in
217 :			app adder values;
218 :			I.rmv varBlock var;
219 :			(F.RECORD(kind, values, var, optBlock), varBlock)
220 :			end
221 :			end
222 :			| F.SELECT (value, index, var, block) =>
223 :			let val (optBlock, varBlock) = inside block
224 :			in
225 :			valueAdder varBlock value;
226 :			I.rmv varBlock var;
227 :			(F.SELECT (value, index, var, optBlock), varBlock)
228 :			end
229 :			| F.RAISE (value, _) =>
230 :			let val vars = I.new(8, NotFound)
231 :			in
232 :			valueAdder vars value;
233 :			(tree, vars)
234 :			end
235 :			| F.HANDLE (exp, value) =>
236 :			let val (optExp, varExp) = inside exp
237 :			in
238 :			valueAdder varExp value;
239 :			(F.HANDLE (optExp, value), varExp)
240 :			end
241 :			| F.BRANCH (operation, values, expr, block) =>
242 :			let val (optBlock, varBlock) = inside block
243 :			val (optExp, varExp) = inside expr
244 :			in
245 :			let val adder = valueAdder varBlock
246 :			in
247 :			app adder values
248 :			end;
249 :			setUnion varBlock varExp;
250 :			(F.BRANCH (operation, values, optExp, optBlock), varBlock)
251 :			end
252 :			| F.PRIMOP (operation, values, variable, block) =>
253 :			let val (optBlock, varBlock) = inside block
254 :			val adder = valueAdder varBlock
255 :			in
256 :			app adder values;
257 :			I.add varBlock (variable, true);
258 :			(F.PRIMOP (operation, values, variable, optBlock), varBlock)
259 :			end
260 :
261 :			in
262 :			let val (result, _) = inside progbody in
263 :			(progkind, progname, progargs, result)
264 :			end
265 :			end
266 :			end
267 :			end

---

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