summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-09-13 13:25:09 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-09-13 13:25:09 -0400
commit3e58952b52b3a731a8e78b11b47f0e8d6e647d14 (patch)
treedf54e06c4519ae222dd00aeb0e1cbbf26007e4a9
parent3120f9ddb17494dc36d7a329c28dc587be55de77 (diff)
Full Grid1 compiles, thanks to avoiding code size blow-up in mono_reduce
-rw-r--r--demo/more/grid1.ur10
-rw-r--r--src/mono_reduce.sml16
2 files changed, 18 insertions, 8 deletions
diff --git a/demo/more/grid1.ur b/demo/more/grid1.ur
index ea0dcbd5..b5cc4511 100644
--- a/demo/more/grid1.ur
+++ b/demo/more/grid1.ur
@@ -8,7 +8,7 @@ table t : {Id : int, A : int, B : string, C : bool, D : int, E : option int, F :
PRIMARY KEY Id,
CONSTRAINT Foreign FOREIGN KEY (D) REFERENCES t1(Id) ON DELETE CASCADE
-(*fun page (n, s) = return <xml>A = {[n]}, B = {[s]}</xml>*)
+fun page (n, s) = return <xml>A = {[n]}, B = {[s]}</xml>
open Make(struct
val tab = t
@@ -36,14 +36,14 @@ open Make(struct
end)
val cols = {Id = Direct.readOnly [#Id] ! "Id" Direct.int,
- (*A = Direct.editable [#A] ! "A" Direct.int,
+ A = Direct.editable [#A] ! "A" Direct.int,
B = Direct.editable [#B] ! "B" Direct.string,
C = Direct.editable [#C] ! "C" Direct.bool,
- D = Direct.editable [#D] ! "D" F.meta,*)
+ D = Direct.editable [#D] ! "D" F.meta,
E = Direct.editable [#E] ! "E" (Direct.nullable Direct.int),
- F = Direct.editable [#F] ! "F" (Direct.nullable F.meta)(*,
+ F = Direct.editable [#F] ! "F" (Direct.nullable F.meta),
DA = computed "2A" (fn r => 2 * r.A),
- Link = computedHtml "Link" (fn r => <xml><a link={page (r.A, r.B)}>Go</a></xml>)*)}
+ Link = computedHtml "Link" (fn r => <xml><a link={page (r.A, r.B)}>Go</a></xml>)}
end)
fun main () =
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index c552db17..171bcef0 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -275,6 +275,16 @@ fun patBinds (p, _) =
| PNone _ => 0
| PSome (_, p) => patBinds p
+val countFree = U.Exp.foldB {typ = fn (_, n) => n,
+ exp = fn (x, e, n) =>
+ case e of
+ ERel x' => if x = x' then n + 1 else n
+ | _ => n,
+ bind = fn (n, b) =>
+ case b of
+ U.Exp.RelE _ => n + 1
+ | _ => n} 0 0
+
fun reduce file =
let
val (impures, absCounts) =
@@ -434,7 +444,7 @@ fun reduce file =
((*Print.prefaces "Considering" [("e1", MonoPrint.p_exp (E.pushERel env x t NONE) e1),
("e2", MonoPrint.p_exp env e2),
("sub", MonoPrint.p_exp env (reduceExp env (subExpInExp (0, e2) e1)))];*)
- if impure env e2 then
+ if impure env e2 orelse countFree e1 > 1 then
#1 (reduceExp env (ELet (x, t, e2, e1), loc))
else
#1 (reduceExp env (subExpInExp (0, e2) e1)))
@@ -522,8 +532,8 @@ fun reduce file =
val r = subExpInExp (0, e') b
in
(*Print.prefaces "doSub" [("e'", MonoPrint.p_exp env e'),
- ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
- ("r", MonoPrint.p_exp env r)];*)
+ ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
+ ("r", MonoPrint.p_exp env r)];*)
#1 (reduceExp env r)
end