Mercurial > urweb
comparison src/especialize.sml @ 1180:ac3dbbc85c6e
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'), |