Mercurial > urweb

comparison src/especialize.sml @ 800:e92cfac1608f

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Proper lifting of MonoEnv stored expressions; avoidance of onchange clobbering
author Adam Chlipala <adamc@hcoop.net>
date Thu, 14 May 2009 13:18:31 -0400
parents dc3fc3f3b834
children ef6de4075dc1
comparison
equal deleted inserted replaced
799:9330ba3a2799 800:e92cfac1608f
110 decls : (string * int * con * exp * string) list 110 decls : (string * int * con * exp * string) list
111 } 111 }
112 112
113 fun default (_, x, st) = (x, st) 113 fun default (_, x, st) = (x, st)
114 114
115 structure SS = BinarySetFn(struct
116 type ord_key = string
117 val compare = String.compare
118 end)
119
120 val mayNotSpec = ref SS.empty
121
115 fun specialize' file = 122 fun specialize' file =
116 let 123 let
117 fun bind (env, b) = 124 fun bind (env, b) =
118 case b of 125 case b of
119 U.Decl.RelE xt => xt :: env 126 U.Decl.RelE xt => xt :: env
177 fun firstRel () = 184 fun firstRel () =
178 case fxs' of 185 case fxs' of
179 (ERel _, _) :: _ => true 186 (ERel _, _) :: _ => true
180 | _ => false 187 | _ => false
181 in 188 in
189 (*Print.preface ("fxs'", Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs');*)
182 if firstRel () 190 if firstRel ()
183 orelse List.all (fn (ERel _, _) => true 191 orelse List.all (fn (ERel _, _) => true
184 | _ => false) fxs' then 192 | _ => false) fxs' then
185 (e, st) 193 (e, st)
186 else 194 else
187 case KM.find (args, fxs') of 195 case (KM.find (args, fxs'), SS.member (!mayNotSpec, name)) of
188 SOME f' => 196 (SOME f', _) =>
189 let 197 let
190 val e = (ENamed f', loc) 198 val e = (ENamed f', loc)
191 val e = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc)) 199 val e = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc))
192 e fvs 200 e fvs
193 val e = foldl (fn (arg, e) => (EApp (e, arg), loc)) 201 val e = foldl (fn (arg, e) => (EApp (e, arg), loc))
195 in 203 in
196 (*Print.prefaces "Brand new (reuse)" 204 (*Print.prefaces "Brand new (reuse)"
197 [("e'", CorePrint.p_exp CoreEnv.empty e)];*) 205 [("e'", CorePrint.p_exp CoreEnv.empty e)];*)
198 (#1 e, st) 206 (#1 e, st)
199 end 207 end
200 | NONE => 208 | (_, true) => (e, st)
209 | (NONE, false) =>
201 let 210 let
211 (*val () = Print.prefaces "New one"
212 [("f", Print.PD.string (Int.toString f)),
213 ("mns", Print.p_list Print.PD.string
214 (SS.listItems (!mayNotSpec)))]*)
215
202 fun subBody (body, typ, fxs') = 216 fun subBody (body, typ, fxs') =
203 case (#1 body, #1 typ, fxs') of 217 case (#1 body, #1 typ, fxs') of
204 (_, _, []) => SOME (body, typ) 218 (_, _, []) => SOME (body, typ)
205 | (EAbs (_, _, _, body'), TFun (_, typ'), x :: fxs'') => 219 | (EAbs (_, _, _, body'), TFun (_, typ'), x :: fxs'') =>
206 let 220 let
243 ((EAbs (x, xt, typ', body'), 257 ((EAbs (x, xt, typ', body'),
244 loc), 258 loc),
245 (TFun (xt, typ'), loc)) 259 (TFun (xt, typ'), loc))
246 end) 260 end)
247 (body', typ') fvs 261 (body', typ') fvs
262 val mns = !mayNotSpec
263 val () = mayNotSpec := SS.add (mns, name)
264 (*val () = Print.preface ("body'", CorePrint.p_exp CoreEnv.empty body')*)
248 val (body', st) = specExp env st body' 265 val (body', st) = specExp env st body'
266 val () = mayNotSpec := mns
249 267
250 val e' = (ENamed f', loc) 268 val e' = (ENamed f', loc)
251 val e' = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc)) 269 val e' = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc))
252 e' fvs 270 e' fvs
253 val e' = foldl (fn (arg, e) => (EApp (e, arg), loc)) 271 val e' = foldl (fn (arg, e) => (EApp (e, arg), loc))
295 313
296 val (d', st) = 314 val (d', st) =
297 if isPoly d then 315 if isPoly d then
298 (d, st) 316 (d, st)
299 else 317 else
300 specDecl [] st d 318 (mayNotSpec := (case #1 d of
319 DValRec vis => foldl (fn ((x, _, _, _, _), mns) =>
320 SS.add (mns, x)) SS.empty vis
321 | DVal (x, _, _, _, _) => SS.singleton x
322 | _ => SS.empty);
323 specDecl [] st d
324 before mayNotSpec := SS.empty)
301 325
302 (*val () = print "/decl\n"*) 326 (*val () = print "/decl\n"*)
303 327
304 val funcs = #funcs st 328 val funcs = #funcs st
305 val funcs = 329 val funcs =
322 | vis => 346 | vis =>
323 (true, case d' of 347 (true, case d' of
324 (DValRec vis', _) => [(DValRec (vis @ vis'), ErrorMsg.dummySpan)] 348 (DValRec vis', _) => [(DValRec (vis @ vis'), ErrorMsg.dummySpan)]
325 | _ => [(DValRec vis, ErrorMsg.dummySpan), d']) 349 | _ => [(DValRec vis, ErrorMsg.dummySpan), d'])
326 in 350 in
327 (*Print.prefaces "doDecl" [("d", CorePrint.p_decl E.empty d), 351 (*Print.prefaces "doDecl" [("d", CorePrint.p_decl E.empty d)];*)
328 ("t", Print.PD.string (Real.toString (Time.toReal
329 (Time.- (Time.now (), befor)))))];*)
330 (ds, ({maxName = #maxName st, 352 (ds, ({maxName = #maxName st,
331 funcs = funcs, 353 funcs = funcs,
332 decls = []}, changed)) 354 decls = []}, changed))
333 end 355 end
334 356