Mercurial > urweb

comparison src/especialize.sml @ 1863:32784d27b5bc

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Expand coverage of 'functionInside' for Especialize
author Adam Chlipala <adam@chlipala.net>
date Sat, 10 Aug 2013 10:13:40 -0400
parents 52043ad66ce7
children
comparison
equal deleted inserted replaced
1862:a3d795fbecb9 1863:32784d27b5bc
120 specialized : IS.set 120 specialized : IS.set
121 } 121 }
122 122
123 fun default (_, x, st) = (x, st) 123 fun default (_, x, st) = (x, st)
124 124
125 val functionInside = U.Con.exists {kind = fn _ => false, 125 fun functionInside known =
126 con = fn TFun _ => true 126 U.Con.exists {kind = fn _ => false,
127 | TCFun _ => true 127 con = fn TFun _ => true
128 | CFfi ("Basis", "transaction") => true 128 | TCFun _ => true
129 | CFfi ("Basis", "eq") => true 129 | CFfi ("Basis", "transaction") => true
130 | CFfi ("Basis", "num") => true 130 | CFfi ("Basis", "eq") => true
131 | CFfi ("Basis", "ord") => true 131 | CFfi ("Basis", "num") => true
132 | CFfi ("Basis", "show") => true 132 | CFfi ("Basis", "ord") => true
133 | CFfi ("Basis", "read") => true 133 | CFfi ("Basis", "show") => true
134 | CFfi ("Basis", "sql_injectable_prim") => true 134 | CFfi ("Basis", "read") => true
135 | CFfi ("Basis", "sql_injectable") => true 135 | CFfi ("Basis", "sql_injectable_prim") => true
136 | _ => false} 136 | CFfi ("Basis", "sql_injectable") => true
137 | CNamed n => IS.member (known, n)
138 | _ => false}
137 139
138 fun getApp (e, _) = 140 fun getApp (e, _) =
139 case e of 141 case e of
140 ENamed f => SOME (f, []) 142 ENamed f => SOME (f, [])
141 | EApp (e1, e2) => 143 | EApp (e1, e2) =>
214 in 216 in
215 enterAbs 0 e 217 enterAbs 0 e
216 end 218 end
217 219
218 220
221 fun optionExists p opt =
222 case opt of
223 NONE => false
224 | SOME v => p v
225
219 fun specialize' (funcs, specialized) file = 226 fun specialize' (funcs, specialized) file =
220 let 227 let
228 val known = foldl (fn (d, known) =>
229 case #1 d of
230 DCon (_, n, _, c) =>
231 if functionInside known c then
232 IS.add (known, n)
233 else
234 known
235 | DDatatype dts =>
236 if List.exists (List.exists (optionExists (functionInside known) o #3) o #4) dts then
237 foldl (fn (dt, known) => IS.add (known, #2 dt)) known dts
238 else
239 known
240 | _ => known)
241 IS.empty file
242
221 fun bind (env, b) = 243 fun bind (env, b) =
222 case b of 244 case b of
223 U.Decl.RelE xt => xt :: env 245 U.Decl.RelE xt => xt :: env
224 | _ => env 246 | _ => env
225 247
380 in 402 in
381 case (#1 typ, xs) of 403 case (#1 typ, xs) of
382 (TFun (dom, ran), e :: xs') => 404 (TFun (dom, ran), e :: xs') =>
383 if constArgs > 0 then 405 if constArgs > 0 then
384 let 406 let
385 val fi = functionInside dom 407 val fi = functionInside known dom
386 in 408 in
387 if initialPart orelse fi then 409 if initialPart orelse fi then
388 findSplit av (not fi andalso initialPart, 410 findSplit av (not fi andalso initialPart,
389 constArgs - 1, 411 constArgs - 1,
390 xs', 412 xs',