summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adam@chlipala.net>2010-12-21 13:57:12 -0500
committerGravatar Adam Chlipala <adam@chlipala.net>2010-12-21 13:57:12 -0500
commitbc42b77787363bf9f1592f7696223cccb4b9381d (patch)
tree726849a873ace28524bff624b3ab08e6dda1286e
parent0ecaa53f8c3951d695a4379dd1b353863749963a (diff)
Hopeful fix to stop Especialize infinite looping
-rw-r--r--src/especialize.sml21
-rw-r--r--tests/each.ur16
-rw-r--r--tests/each.urp3
-rw-r--r--tests/each.urs1
4 files changed, 40 insertions, 1 deletions
diff --git a/src/especialize.sml b/src/especialize.sml
index d7a5014b..d089230b 100644
--- a/src/especialize.sml
+++ b/src/especialize.sml
@@ -324,13 +324,32 @@ fun specialize' (funcs, specialized) file =
val (fxs, xs, fvs, fin) = findSplit true (xs, typ, [], IS.empty, false)
+ fun valueish (e, _) =
+ case e of
+ EPrim _ => true
+ | ERel _ => true
+ | ENamed _ => true
+ | ECon (_, _, _, NONE) => true
+ | ECon (_, _, _, SOME e) => valueish e
+ | EFfi (_, _) => true
+ | EAbs _ => true
+ | ECAbs _ => true
+ | EKAbs _ => true
+ | ECApp (e, _) => valueish e
+ | EKApp (e, _) => valueish e
+ | ERecord xes => List.all (valueish o #2) xes
+ | _ => false
+
val vts = map (fn n => #2 (List.nth (env, n))) (IS.listItems fvs)
val fxs' = map (squish (IS.listItems fvs)) fxs
in
- (*Print.preface ("fxs'", Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs');*)
+ (*Print.prefaces "Func" [("name", Print.PD.string name),
+ ("e", CorePrint.p_exp CoreEnv.empty e),
+ ("fxs'", Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')];*)
if not fin
orelse List.all (fn (ERel _, _) => true
| _ => false) fxs'
+ orelse List.exists (not o valueish) fxs'
orelse (IS.numItems fvs >= length fxs
andalso IS.exists (fn n => functionInside (#2 (List.nth (env, n)))) fvs) then
((*Print.prefaces "No" [("name", Print.PD.string name),
diff --git a/tests/each.ur b/tests/each.ur
new file mode 100644
index 00000000..b3b0b1a2
--- /dev/null
+++ b/tests/each.ur
@@ -0,0 +1,16 @@
+sequence s
+table t : { Id : int, S1 : string, S2:string, S3:string, S4:string }
+
+fun each (n : int, (f : unit -> transaction unit)) = if n > 0 then f (); each ((n-1),f) else return ()
+
+fun fill () =
+ dml (DELETE FROM t WHERE 1=1);
+ each (1,( fn () =>
+ (nv <- nextval s;
+ (dml (INSERT INTO t (Id, S1, S2, S3, S4) VALUES ({[nv]}, {["S1"]}, {["S2"]}, {["S3"]}, {["S4"]}))))
+ ));
+ return <xml>done</xml>
+
+fun main () = return <xml><body>
+ <form><submit action={fill} value="fill"/></form>
+</body></xml>
diff --git a/tests/each.urp b/tests/each.urp
new file mode 100644
index 00000000..c25b7175
--- /dev/null
+++ b/tests/each.urp
@@ -0,0 +1,3 @@
+database dbname=each
+
+each
diff --git a/tests/each.urs b/tests/each.urs
new file mode 100644
index 00000000..6ac44e0b
--- /dev/null
+++ b/tests/each.urs
@@ -0,0 +1 @@
+val main : unit -> transaction page