summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adam@chlipala.net>2013-08-10 10:13:40 -0400
committerGravatar Adam Chlipala <adam@chlipala.net>2013-08-10 10:13:40 -0400
commit9734b34421533a3a70a09629b11d7e2105ef4a1a (patch)
tree28bfd11f2f5b4745ddfdaf6c3e42e7f70fc72b59 /src
parent93fea8aa22abe42292b2d4f8fed07900280b64be (diff)
Expand coverage of 'functionInside' for Especialize
Diffstat (limited to 'src')
-rw-r--r--src/especialize.sig2
-rw-r--r--src/especialize.sml48
-rw-r--r--src/reduce.sml4
3 files changed, 38 insertions, 16 deletions
diff --git a/src/especialize.sig b/src/especialize.sig
index ad2d15da..135e3a00 100644
--- a/src/especialize.sig
+++ b/src/especialize.sig
@@ -29,6 +29,6 @@ signature ESPECIALIZE = sig
val specialize : Core.file -> Core.file
- val functionInside : Core.con -> bool
+ val functionInside : IntBinarySet.set -> Core.con -> bool
end
diff --git a/src/especialize.sml b/src/especialize.sml
index dac91535..7cf145cd 100644
--- a/src/especialize.sml
+++ b/src/especialize.sml
@@ -122,18 +122,20 @@ type state = {
fun default (_, x, st) = (x, st)
-val functionInside = U.Con.exists {kind = fn _ => false,
- con = fn TFun _ => true
- | TCFun _ => true
- | CFfi ("Basis", "transaction") => true
- | CFfi ("Basis", "eq") => true
- | CFfi ("Basis", "num") => true
- | CFfi ("Basis", "ord") => true
- | CFfi ("Basis", "show") => true
- | CFfi ("Basis", "read") => true
- | CFfi ("Basis", "sql_injectable_prim") => true
- | CFfi ("Basis", "sql_injectable") => true
- | _ => false}
+fun functionInside known =
+ U.Con.exists {kind = fn _ => false,
+ con = fn TFun _ => true
+ | TCFun _ => true
+ | CFfi ("Basis", "transaction") => true
+ | CFfi ("Basis", "eq") => true
+ | CFfi ("Basis", "num") => true
+ | CFfi ("Basis", "ord") => true
+ | CFfi ("Basis", "show") => true
+ | CFfi ("Basis", "read") => true
+ | CFfi ("Basis", "sql_injectable_prim") => true
+ | CFfi ("Basis", "sql_injectable") => true
+ | CNamed n => IS.member (known, n)
+ | _ => false}
fun getApp (e, _) =
case e of
@@ -216,8 +218,28 @@ fun calcConstArgs enclosingFunctions e =
end
+fun optionExists p opt =
+ case opt of
+ NONE => false
+ | SOME v => p v
+
fun specialize' (funcs, specialized) file =
let
+ val known = foldl (fn (d, known) =>
+ case #1 d of
+ DCon (_, n, _, c) =>
+ if functionInside known c then
+ IS.add (known, n)
+ else
+ known
+ | DDatatype dts =>
+ if List.exists (List.exists (optionExists (functionInside known) o #3) o #4) dts then
+ foldl (fn (dt, known) => IS.add (known, #2 dt)) known dts
+ else
+ known
+ | _ => known)
+ IS.empty file
+
fun bind (env, b) =
case b of
U.Decl.RelE xt => xt :: env
@@ -382,7 +404,7 @@ fun specialize' (funcs, specialized) file =
(TFun (dom, ran), e :: xs') =>
if constArgs > 0 then
let
- val fi = functionInside dom
+ val fi = functionInside known dom
in
if initialPart orelse fi then
findSplit av (not fi andalso initialPart,
diff --git a/src/reduce.sml b/src/reduce.sml
index aa5408b0..933a4d94 100644
--- a/src/reduce.sml
+++ b/src/reduce.sml
@@ -558,7 +558,7 @@ fun kindConAndExp (namedC, namedE) =
(ELet (x, t, e1', exp (UnknownE :: env') (EApp (e2', E.liftExpInExp 0 e2), loc)), loc)
| EAbs (x, dom, _, b) =>
- if count b <= 1 orelse passive e2 orelse ESpecialize.functionInside dom then
+ if count b <= 1 orelse passive e2 orelse ESpecialize.functionInside IS.empty dom then
let
val r = exp (KnownE e2 :: env') b
in
@@ -798,7 +798,7 @@ fun kindConAndExp (namedC, namedE) =
val t = con env t
in
- if notFfi t andalso (passive e1' orelse count e2 <= 1 orelse ESpecialize.functionInside t) then
+ if notFfi t andalso (passive e1' orelse count e2 <= 1 orelse ESpecialize.functionInside IS.empty t) then
exp (KnownE e1 :: env) e2
else
(ELet (x, t, e1', exp (UnknownE :: env) e2), loc)