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