diff options
| author |  Adam Chlipala <adam@chlipala.net> | 2010-12-21 13:57:12 -0500 |
|---|---|---|
| committer | Adam Chlipala <adam@chlipala.net> | 2010-12-21 13:57:12 -0500 |
| commit | bc42b77787363bf9f1592f7696223cccb4b9381d (patch) | |
| tree | 726849a873ace28524bff624b3ab08e6dda1286e | |
| parent | 0ecaa53f8c3951d695a4379dd1b353863749963a (diff) | |
Hopeful fix to stop Especialize infinite looping
| -rw-r--r-- | src/especialize.sml | 21 | ||||
| -rw-r--r-- | tests/each.ur | 16 | ||||
| -rw-r--r-- | tests/each.urp | 3 | ||||
| -rw-r--r-- | tests/each.urs | 1 |
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 |