Mercurial > urweb

comparison src/especialize.sml @ 1180:ac3dbbc85c6e

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Standard library moduls Incl and Mem; tweaks to Especialize and Unpoly
author Adam Chlipala <adamc@hcoop.net>
date Sat, 06 Mar 2010 16:15:26 -0500
parents 74f2eb3b0606
children 618f9f458da9
comparison
equal deleted inserted replaced
1179:c58453683bbb 1180:ac3dbbc85c6e
1 (* Copyright (c) 2008-2009, Adam Chlipala 1 (* Copyright (c) 2008-2010, 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 *
127 127
128 val mayNotSpec = ref SS.empty 128 val mayNotSpec = ref SS.empty
129 129
130 fun specialize' (funcs, specialized) file = 130 fun specialize' (funcs, specialized) file =
131 let 131 let
132 fun functionInside functiony = U.Con.exists {kind = fn _ => false,
133 con = fn TFun _ => true
134 | CFfi ("Basis", "transaction") => true
135 | CFfi ("Basis", "eq") => true
136 | CFfi ("Basis", "num") => true
137 | CFfi ("Basis", "ord") => true
138 | CFfi ("Basis", "show") => true
139 | CFfi ("Basis", "read") => true
140 | CFfi ("Basis", "sql_injectable_prim") => true
141 | CFfi ("Basis", "sql_injectable") => true
142 | CNamed n => IS.member (functiony, n)
143 | _ => false}
144
145 val functiony = foldl (fn ((d, _), functiony) =>
146 case d of
147 DCon (_, n, _, c) =>
148 if functionInside functiony c then
149 IS.add (functiony, n)
150 else
151 functiony
152 | DDatatype dts =>
153 if List.exists (fn (_, _, _, cs) =>
154 List.exists (fn (_, _, SOME c) => functionInside functiony c
155 | _ => false) cs) dts then
156 IS.addList (functiony, map #2 dts)
157 else
158 functiony
159 | _ => functiony) IS.empty file
160
161 val functionInside = functionInside functiony
162
132 fun bind (env, b) = 163 fun bind (env, b) =
133 case b of 164 case b of
134 U.Decl.RelE xt => xt :: env 165 U.Decl.RelE xt => xt :: env
135 | _ => env 166 | _ => env
136 167
284 val (xs, st) = ListUtil.foldlMap (fn (e, st) => exp (env, e, st)) st xs 315 val (xs, st) = ListUtil.foldlMap (fn (e, st) => exp (env, e, st)) st xs
285 316
286 (*val () = Print.prefaces "Consider" [("e", CorePrint.p_exp CoreEnv.empty 317 (*val () = Print.prefaces "Consider" [("e", CorePrint.p_exp CoreEnv.empty
287 (e, ErrorMsg.dummySpan))]*) 318 (e, ErrorMsg.dummySpan))]*)
288 319
289 val functionInside = U.Con.exists {kind = fn _ => false, 320
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}
300 val loc = ErrorMsg.dummySpan 321 val loc = ErrorMsg.dummySpan
301 322
302 fun findSplit av (xs, typ, fxs, fvs, fin) = 323 fun findSplit av (xs, typ, fxs, fvs, fin) =
303 case (#1 typ, xs) of 324 case (#1 typ, xs) of
304 (TFun (dom, ran), e :: xs') => 325 (TFun (dom, ran), e :: xs') =>
330 | _ => false) fxs' 351 | _ => false) fxs'
331 orelse (IS.numItems fvs >= length fxs 352 orelse (IS.numItems fvs >= length fxs
332 andalso IS.exists (fn n => functionInside (#2 (List.nth (env, n)))) fvs) then 353 andalso IS.exists (fn n => functionInside (#2 (List.nth (env, n)))) fvs) then
333 ((*Print.prefaces "No" [("name", Print.PD.string name), 354 ((*Print.prefaces "No" [("name", Print.PD.string name),
334 ("f", Print.PD.string (Int.toString f)), 355 ("f", Print.PD.string (Int.toString f)),
356 ("xs",
357 Print.p_list (CorePrint.p_exp CoreEnv.empty) xs),
335 ("fxs'", 358 ("fxs'",
336 Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')];*) 359 Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')];*)
337 default ()) 360 default ())
338 else 361 else
339 case (KM.find (args, fxs'), 362 case (KM.find (args, fxs'),