summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adam@chlipala.net>2010-08-22 13:43:46 -0400
committerGravatar Adam Chlipala <adam@chlipala.net>2010-08-22 13:43:46 -0400
commit7765b90d25f98bd9eb0cf2998121e51d4551f733 (patch)
treed081f569cf52ee803d96962b25ab35f828c696df /src
parent1bd7feb39add77e14df852d2087902049f2b5df3 (diff)
Reduce: Inline let-bound variables whose types involve functions
Diffstat (limited to 'src')
-rw-r--r--src/especialize.sig2
-rw-r--r--src/especialize.sml23
-rw-r--r--src/reduce.sml9
-rw-r--r--src/reduce_local.sml2
-rw-r--r--src/sources20
5 files changed, 33 insertions, 23 deletions
diff --git a/src/especialize.sig b/src/especialize.sig
index df83e81b..ad2d15da 100644
--- a/src/especialize.sig
+++ b/src/especialize.sig
@@ -29,4 +29,6 @@ signature ESPECIALIZE = sig
val specialize : Core.file -> Core.file
+ val functionInside : Core.con -> bool
+
end
diff --git a/src/especialize.sml b/src/especialize.sml
index 3fa3ea1d..a43652d0 100644
--- a/src/especialize.sml
+++ b/src/especialize.sml
@@ -127,6 +127,18 @@ structure SS = BinarySetFn(struct
val mayNotSpec = ref SS.empty
+val functionInside = U.Con.exists {kind = fn _ => false,
+ con = fn TFun _ => 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 specialize' (funcs, specialized) file =
let
fun bind (env, b) =
@@ -286,17 +298,6 @@ fun specialize' (funcs, specialized) file =
(*val () = Print.prefaces "Consider" [("e", CorePrint.p_exp CoreEnv.empty
(e, ErrorMsg.dummySpan))]*)
- val functionInside = U.Con.exists {kind = fn _ => false,
- con = fn TFun _ => 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}
val loc = ErrorMsg.dummySpan
fun findSplit av (xs, typ, fxs, fvs, fin) =
diff --git a/src/reduce.sml b/src/reduce.sml
index 963863e8..36c9f44e 100644
--- a/src/reduce.sml
+++ b/src/reduce.sml
@@ -652,7 +652,14 @@ fun kindConAndExp (namedC, namedE) =
| EClosure (n, es) => (EClosure (n, map (exp env) es), loc)
| ELet (x, t, e1, e2) =>
- (ELet (x, con env t, exp env e1, exp (UnknownE :: env) e2), loc)
+ let
+ val t = con env t
+ in
+ if ESpecialize.functionInside t then
+ exp (KnownE e1 :: env) e2
+ else
+ (ELet (x, con env t, exp env e1, exp (UnknownE :: env) e2), loc)
+ end
| EServerCall (n, es, t) => (EServerCall (n, map (exp env) es, con env t), loc)
in
diff --git a/src/reduce_local.sml b/src/reduce_local.sml
index 9370c95b..cfa6bfd8 100644
--- a/src/reduce_local.sml
+++ b/src/reduce_local.sml
@@ -136,7 +136,7 @@ fun con env (all as (c, loc)) =
let
fun find (n', env, nudge, liftC) =
case env of
- [] => raise Fail "Reduce.con: CRel"
+ [] => raise Fail "ReduceLocal.con: CRel"
| Unknown :: rest => find (n', rest, nudge, liftC)
| Known _ :: rest => find (n', rest, nudge, liftC)
| Lift (liftC', _) :: rest => find (n', rest, nudge + liftC',
diff --git a/src/sources b/src/sources
index 7ccb39db..3efdecb4 100644
--- a/src/sources
+++ b/src/sources
@@ -107,14 +107,20 @@ core_print.sml
corify.sig
corify.sml
-reduce.sig
-reduce.sml
+reduce_local.sig
+reduce_local.sml
shake.sig
shake.sml
-reduce_local.sig
-reduce_local.sml
+core_untangle.sig
+core_untangle.sml
+
+especialize.sig
+especialize.sml
+
+reduce.sig
+reduce.sml
unpoly.sig
unpoly.sml
@@ -122,12 +128,6 @@ unpoly.sml
specialize.sig
specialize.sml
-core_untangle.sig
-core_untangle.sml
-
-especialize.sig
-especialize.sml
-
rpcify.sig
rpcify.sml