Mercurial > urweb

comparison src/especialize.sml @ 1185:338be96f8533

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Undo an Especialize change that turned out to be unecessary
author Adam Chlipala <adamc@hcoop.net>
date Tue, 16 Mar 2010 10:09:01 -0400
parents 618f9f458da9
children 56bd4a4f6e66
comparison
equal deleted inserted replaced
1184:d6f0e972b706 1185:338be96f8533
1 (* Copyright (c) 2008-2010, Adam Chlipala 1 (* Copyright (c) 2008-2009, Adam Chlipala
2 * All rights reserved. 2 * All rights reserved.
3 * 3 *
4 * Redistribution and use in source and binary forms, with or without 4 * Redistribution and use in source and binary forms, with or without
5 * modification, are permitted provided that the following conditions are met: 5 * modification, are permitted provided that the following conditions are met:
6 * 6 *
41 41
42 structure KM = BinaryMapFn(K) 42 structure KM = BinaryMapFn(K)
43 structure IM = IntBinaryMap 43 structure IM = IntBinaryMap
44 structure IS = IntBinarySet 44 structure IS = IntBinarySet
45 45
46 val isOpen = U.Exp.exists {kind = fn _ => false,
47 con = fn c =>
48 case c of
49 CRel _ => true
50 | _ => false,
51 exp = fn _ => false}
52
53 val freeVars = U.Exp.foldB {kind = fn (_, _, xs) => xs, 46 val freeVars = U.Exp.foldB {kind = fn (_, _, xs) => xs,
54 con = fn (_, _, xs) => xs, 47 con = fn (_, _, xs) => xs,
55 exp = fn (bound, e, xs) => 48 exp = fn (bound, e, xs) =>
56 case e of 49 case e of
57 ERel x => 50 ERel x =>
134 127
135 val mayNotSpec = ref SS.empty 128 val mayNotSpec = ref SS.empty
136 129
137 fun specialize' (funcs, specialized) file = 130 fun specialize' (funcs, specialized) file =
138 let 131 let
139 fun functionInside functiony = U.Con.exists {kind = fn _ => false,
140 con = fn TFun _ => true
141 | CFfi ("Basis", "transaction") => true
142 | CFfi ("Basis", "eq") => true
143 | CFfi ("Basis", "num") => true
144 | CFfi ("Basis", "ord") => true
145 | CFfi ("Basis", "show") => true
146 | CFfi ("Basis", "read") => true
147 | CFfi ("Basis", "sql_injectable_prim") => true
148 | CFfi ("Basis", "sql_injectable") => true
149 | CNamed n => IS.member (functiony, n)
150 | _ => false}
151
152 val functiony = foldl (fn ((d, _), functiony) =>
153 case d of
154 DCon (_, n, _, c) =>
155 if functionInside functiony c then
156 IS.add (functiony, n)
157 else
158 functiony
159 | DDatatype dts =>
160 if List.exists (fn (_, _, _, cs) =>
161 List.exists (fn (_, _, SOME c) => functionInside functiony c
162 | _ => false) cs) dts then
163 IS.addList (functiony, map #2 dts)
164 else
165 functiony
166 | _ => functiony) IS.empty file
167
168 val functionInside = functionInside functiony
169
170 fun bind (env, b) = 132 fun bind (env, b) =
171 case b of 133 case b of
172 U.Decl.RelE xt => xt :: env 134 U.Decl.RelE xt => xt :: env
173 | _ => env 135 | _ => env
174 136
226 let 188 let
227 val (e, st) = exp (env, e, st) 189 val (e, st) = exp (env, e, st)
228 in 190 in
229 ((ECApp (e, c), loc), st) 191 ((ECApp (e, c), loc), st)
230 end 192 end
231 | ECAbs (x, k, e) => 193 | ECAbs _ => (e, st)
232 let
233 val (e, st) = exp (env, e, st)
234 in
235 ((ECAbs (x, k, e), loc), st)
236 end
237 | EKAbs _ => (e, st) 194 | EKAbs _ => (e, st)
238 | EKApp (e, k) => 195 | EKApp (e, k) =>
239 let 196 let
240 val (e, st) = exp (env, e, st) 197 val (e, st) = exp (env, e, st)
241 in 198 in
327 val (xs, st) = ListUtil.foldlMap (fn (e, st) => exp (env, e, st)) st xs 284 val (xs, st) = ListUtil.foldlMap (fn (e, st) => exp (env, e, st)) st xs
328 285
329 (*val () = Print.prefaces "Consider" [("e", CorePrint.p_exp CoreEnv.empty 286 (*val () = Print.prefaces "Consider" [("e", CorePrint.p_exp CoreEnv.empty
330 (e, ErrorMsg.dummySpan))]*) 287 (e, ErrorMsg.dummySpan))]*)
331 288
332 289 val functionInside = U.Con.exists {kind = fn _ => false,
290 con = fn TFun _ => true
291 | CFfi ("Basis", "transaction") => true
292 | CFfi ("Basis", "eq") => true
293 | CFfi ("Basis", "num") => true
294 | CFfi ("Basis", "ord") => true
295 | CFfi ("Basis", "show") => true
296 | CFfi ("Basis", "read") => true
297 | CFfi ("Basis", "sql_injectable_prim") => true
298 | CFfi ("Basis", "sql_injectable") => true
299 | _ => false}
333 val loc = ErrorMsg.dummySpan 300 val loc = ErrorMsg.dummySpan
334 301
335 fun findSplit av (xs, typ, fxs, fvs, fin) = 302 fun findSplit av (xs, typ, fxs, fvs, fin) =
336 case (#1 typ, xs) of 303 case (#1 typ, xs) of
337 (TFun (dom, ran), e :: xs') => 304 (TFun (dom, ran), e :: xs') =>
359 in 326 in
360 (*Print.preface ("fxs'", Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs');*) 327 (*Print.preface ("fxs'", Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs');*)
361 if not fin 328 if not fin
362 orelse List.all (fn (ERel _, _) => true 329 orelse List.all (fn (ERel _, _) => true
363 | _ => false) fxs' 330 | _ => false) fxs'
364 orelse List.exists isOpen fxs'
365 orelse (IS.numItems fvs >= length fxs 331 orelse (IS.numItems fvs >= length fxs
366 andalso IS.exists (fn n => functionInside (#2 (List.nth (env, n)))) fvs) then 332 andalso IS.exists (fn n => functionInside (#2 (List.nth (env, n)))) fvs) then
367 ((*Print.prefaces "No" [("name", Print.PD.string name), 333 ((*Print.prefaces "No" [("name", Print.PD.string name),
368 ("f", Print.PD.string (Int.toString f)), 334 ("f", Print.PD.string (Int.toString f)),
369 ("xs",
370 Print.p_list (CorePrint.p_exp CoreEnv.empty) xs),
371 ("fxs'", 335 ("fxs'",
372 Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')];*) 336 Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')];*)
373 default ()) 337 default ())
374 else 338 else
375 case (KM.find (args, fxs'), 339 case (KM.find (args, fxs'),