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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 532 - (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 :     in
96 :     let
97 :     val optHandles = map (inCase nextVariables) handles
98 :     val optDefault = inDefault nextVariables default
99 :     in
100 :     if contains nextVariables x
101 :     then (
102 :     (*cannot optimize*)
103 :     I.rmv nextVariables x;
104 :     (F.LET(assign,
105 :     F.SWITCH
106 :     (
107 :     name,
108 :     conds,
109 :     optHandles,
110 :     optDefault
111 :     ),
112 :     newCont),
113 :     nextVariables)
114 :     ) else (
115 :     (*optimize*)
116 :     I.add nextVariables (y, true);
117 :     let val newFunID = (mklv())
118 :     val newFunction = (F.VAR newFunID)
119 :     val optimized =
120 :     F.FIX
121 :     (
122 :     ({
123 :     inline = F.IH_ALWAYS,
124 :     known = true, (*?*)
125 :     cconv = F.CC_FUN LtyKernel.FF_FIXED,
126 :     isrec = NONE
127 :     },
128 :     newFunID, (x, getLty (F.VAR x))::nil, newCont)::nil,
129 :     F.SWITCH(name,
130 :     conds,
131 :     map (putFunInCase newFunction) handles,
132 :     putFunInDefault newFunction default
133 :     )
134 :     )
135 :     in
136 :     (optimized, nextVariables)
137 :     end
138 :     )
139 :     end
140 :     end
141 :     | F.LET (vars, exp, block) =>
142 :     let val (optExpr, varExpr) = inside exp
143 :     val (optBlock, varBlock) = inside block
144 :     in
145 :     setUnion varExpr varBlock;
146 :     setRemove varExpr vars;
147 :     (F.LET(vars, optExpr, optBlock), varExpr)
148 :     end
149 :     | F.RET values =>
150 :     let val vars = I.new(8, NotFound)
151 :     in
152 :     map (valueAdder vars) values;
153 :     (tree, vars)
154 :     end
155 :     | F.FIX (funs, block) =>
156 :     let val (optBlock, varBlock) = inside block
157 :     in
158 :     let fun aux (kind, name, args, body) =
159 :     let val (optBody, varBody) = inside body
160 :     in
161 :     (*first remove local "variables"*)
162 :     setRemove varBody (map fst args);
163 :     (*then join the sets*)
164 :     setUnion varBlock varBody;
165 :     (kind, name, args, optBody)
166 :     end
167 :     fun removeFuns (_, name, _, _) =
168 :     (*now, remove function names*)
169 :     I.rmv varBlock name;
170 :     in
171 :     let val l = map aux funs
172 :     in
173 :     app removeFuns l;
174 :     (F.FIX(l, optBlock), varBlock)
175 :     end
176 :     end
177 :     end
178 :     | F.APP (applied, appliedOn) =>
179 :     let val vars = I.new (8, NotFound)
180 :     in
181 :     let val adder = valueAdder vars
182 :     in
183 :     adder applied;
184 :     app adder appliedOn;
185 :     (tree, vars)
186 :     end
187 :     end
188 :     | F.TFN (dec, block) =>
189 :     let val (kind, var, cons, exp) = dec
190 :     in
191 :     let val (optExp, varExp) = inside exp
192 :     val (optBlock, varBlock) = inside block
193 :     in
194 :     setUnion varExp varBlock;
195 :     I.rmv varBlock var;
196 :     (F.TFN((kind, var, cons, optExp), optBlock), varBlock)
197 :     end
198 :     end
199 :     | F.TAPP (value, _) =>
200 :     let val vars = I.new(8, NotFound)
201 :     in
202 :     valueAdder vars value;
203 :     (tree, vars)
204 :     end
205 :     | F.SWITCH (value, conds, handles, default) =>
206 :     let val vars = I.new(8, NotFound)
207 :     val optDefault = inDefault vars default
208 :     val optHandles = map (inCase vars) handles
209 :     in
210 :     (F.SWITCH (value, conds, optHandles, optDefault), vars)
211 :     end
212 :     | F.CON (dbg, cons, value, var, block) =>
213 :     let val (optBlock, varBlock) = inside block in
214 :     valueAdder varBlock value;
215 :     I.rmv varBlock var;
216 :     (F.CON(dbg, cons, value, var, optBlock), varBlock)
217 :     end
218 :     | F.RECORD (kind, values, var, block) =>
219 :     let val (optBlock, varBlock) = inside block
220 :     in
221 :     let val adder = valueAdder varBlock
222 :     in
223 :     app adder values;
224 :     I.rmv varBlock var;
225 :     (F.RECORD(kind, values, var, optBlock), varBlock)
226 :     end
227 :     end
228 :     | F.SELECT (value, index, var, block) =>
229 :     let val (optBlock, varBlock) = inside block
230 :     in
231 :     valueAdder varBlock value;
232 :     I.rmv varBlock var;
233 :     (F.SELECT (value, index, var, optBlock), varBlock)
234 :     end
235 :     | F.RAISE (value, _) =>
236 :     let val vars = I.new(8, NotFound)
237 :     in
238 :     valueAdder vars value;
239 :     (tree, vars)
240 :     end
241 :     | F.HANDLE (exp, value) =>
242 :     let val (optExp, varExp) = inside exp
243 :     in
244 :     valueAdder varExp value;
245 :     (F.HANDLE (optExp, value), varExp)
246 :     end
247 :     | F.BRANCH (operation, values, expr, block) =>
248 :     let val (optBlock, varBlock) = inside block
249 :     val (optExp, varExp) = inside expr
250 :     in
251 :     let val adder = valueAdder varBlock
252 :     in
253 :     app adder values
254 :     end;
255 :     setUnion varBlock varExp;
256 :     (F.BRANCH (operation, values, optExp, optBlock), varBlock)
257 :     end
258 :     | F.PRIMOP (operation, values, variable, block) =>
259 :     let val (optBlock, varBlock) = inside block
260 :     val adder = valueAdder varBlock
261 :     in
262 :     app adder values;
263 :     I.add varBlock (variable, true);
264 :     (F.PRIMOP (operation, values, variable, optBlock), varBlock)
265 :     end
266 :    
267 :     in
268 :     let val (result, _) = inside progbody in
269 :     (progkind, progname, progargs, result)
270 :     end
271 :     end
272 :     end
273 :     end

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