summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-12-15 12:26:00 -0500
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-12-15 12:26:00 -0500
commit3e3d1d1234b6f29a33e7ca480b4b90fe4116f139 (patch)
tree9c9ff6eb180d602ec313b66f991c025c10e1a7a2
parentab13bbf764595fe6c01fcb5fe61bdf464d77f7fe (diff)
Initial generalization of Especialize, with security bug known
-rw-r--r--CHANGELOG1
-rw-r--r--src/especialize.sml64
-rw-r--r--tests/espec.ur56
-rw-r--r--tests/espec.urp3
-rw-r--r--tests/espec.urs1
5 files changed, 98 insertions, 27 deletions
diff --git a/CHANGELOG b/CHANGELOG
index ec2eda90..d62e732a 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -7,6 +7,7 @@ Next
- Typing of SQL queries no longer exposes which tables were used in joins but
had none of their fields projected
- Tasks
+- Optimization improvements
========
20091203
diff --git a/src/especialize.sml b/src/especialize.sml
index e2bbeb9d..2a0ced6d 100644
--- a/src/especialize.sml
+++ b/src/especialize.sml
@@ -79,14 +79,14 @@ fun positionOf (v : int, ls) =
pof (0, ls)
end
-fun squish fvs =
+fun squish (untouched, fvs) =
U.Exp.mapB {kind = fn _ => fn k => k,
con = fn _ => fn c => c,
exp = fn bound => fn e =>
case e of
ERel x =>
if x >= bound then
- ERel (positionOf (x - bound, fvs) + bound)
+ ERel (positionOf (x - bound, fvs) + bound + untouched)
else
e
| _ => e,
@@ -165,31 +165,29 @@ fun specialize' file =
| _ => false}
val loc = ErrorMsg.dummySpan
- fun findSplit (xs, typ, fxs, fvs) =
+ fun findSplit (xs, typ, fxs, fvs, ts) =
case (#1 typ, xs) of
(TFun (dom, ran), e :: xs') =>
if functionInside dom then
findSplit (xs',
ran,
- e :: fxs,
- IS.union (fvs, freeVars e))
+ (true, e) :: fxs,
+ IS.union (fvs, freeVars e),
+ ts)
else
- (rev fxs, xs, fvs)
- | _ => (rev fxs, xs, fvs)
-
- val (fxs, xs, fvs) = findSplit (xs, typ, [], IS.empty)
-
- val fxs' = map (squish (IS.listItems fvs)) fxs
-
- fun firstRel () =
- case fxs' of
- (ERel _, _) :: _ => true
- | _ => false
+ findSplit (xs', ran, (false, e) :: fxs, fvs, dom :: ts)
+ | _ => (List.revAppend (fxs, map (fn e => (false, e)) xs), fvs, rev ts)
+
+ val (xs, fvs, ts) = findSplit (xs, typ, [], IS.empty, [])
+ val fxs = List.mapPartial (fn (true, e) => SOME e | _ => NONE) xs
+ val untouched = length (List.filter (fn (false, _) => true | _ => false) xs)
+ val squish = squish (untouched, IS.listItems fvs)
+ val fxs' = map squish fxs
in
(*Print.preface ("fxs'", Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs');*)
- if firstRel ()
- orelse List.all (fn (ERel _, _) => true
- | _ => false) fxs' then
+ if List.all (fn (false, _) => true
+ | (true, (ERel _, _)) => true
+ | _ => false) xs then
(e, st)
else
case (KM.find (args, fxs'), SS.member (!mayNotSpec, name)) of
@@ -198,7 +196,8 @@ fun specialize' file =
val e = (ENamed f', loc)
val e = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc))
e fvs
- val e = foldl (fn (arg, e) => (EApp (e, arg), loc))
+ val e = foldl (fn ((false, arg), e) => (EApp (e, arg), loc)
+ | (_, e) => e)
e xs
in
(*Print.prefaces "Brand new (reuse)"
@@ -220,20 +219,24 @@ fun specialize' file =
[("fxs'",
Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')]*)
- fun subBody (body, typ, fxs') =
- case (#1 body, #1 typ, fxs') of
+ fun subBody (body, typ, xs) =
+ case (#1 body, #1 typ, xs) of
(_, _, []) => SOME (body, typ)
- | (EAbs (_, _, _, body'), TFun (_, typ'), x :: fxs'') =>
+ | (EAbs (_, _, _, body'), TFun (_, typ'), (b, x) :: xs) =>
let
- val body'' = E.subExpInExp (0, x) body'
+ val body'' =
+ if b then
+ E.subExpInExp (0, squish x) body'
+ else
+ body'
in
subBody (body'',
typ',
- fxs'')
+ xs)
end
| _ => NONE
in
- case subBody (body, typ, fxs') of
+ case subBody (body, typ, xs) of
NONE => (e, st)
| SOME (body', typ') =>
let
@@ -257,6 +260,12 @@ fun specialize' file =
("fxs'", Print.p_list
(CorePrint.p_exp E.empty) fxs'),
("e", CorePrint.p_exp env (e, loc))]*)
+
+ val (body', typ') = foldr (fn (t, (body', typ')) =>
+ ((EAbs ("x", t, typ', body'), loc),
+ (TFun (t, typ'), loc)))
+ (body', typ') ts
+
val (body', typ') = IS.foldl (fn (n, (body', typ')) =>
let
val (x, xt) = List.nth (env, n)
@@ -275,7 +284,8 @@ fun specialize' file =
val e' = (ENamed f', loc)
val e' = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc))
e' fvs
- val e' = foldl (fn (arg, e) => (EApp (e, arg), loc))
+ val e' = foldl (fn ((false, arg), e) => (EApp (e, arg), loc)
+ | (_, e) => e)
e' xs
(*val () = Print.prefaces "Brand new"
[("e'", CorePrint.p_exp CoreEnv.empty e'),
diff --git a/tests/espec.ur b/tests/espec.ur
new file mode 100644
index 00000000..37b22a36
--- /dev/null
+++ b/tests/espec.ur
@@ -0,0 +1,56 @@
+fun foo (wrap : xbody -> transaction page) = wrap <xml>
+ <a link={foo wrap}>Foo</a>
+</xml>
+
+fun bar (wrap : xbody -> transaction page) (n : int) = wrap <xml>
+ <a link={bar wrap n}>Bar</a>; {[n]}
+</xml>
+
+fun baz (n : int) (wrap : xbody -> transaction page) = wrap <xml>
+ <a link={baz n wrap}>Baz</a>; {[n]}
+</xml>
+
+fun middle (n : int) (wrap : xbody -> transaction page) (m : int) = wrap <xml>
+ <a link={middle n wrap m}>Middle</a>; {[n]}; {[m]}
+</xml>
+
+fun crazy (f : int -> int) (b : bool) (wrap : xbody -> transaction page) (m : int) = wrap <xml>
+ <a link={crazy f b wrap m}>Crazy</a>; {[b]}; {[f m]}
+</xml>
+
+fun wild (q : bool) (f : int -> int) (n : float) (wrap : xbody -> transaction page) (m : int) = wrap <xml>
+ <a link={wild q f n wrap m}>Wild</a>; {[n]}; {[f m]}; {[q]}
+</xml>
+
+fun wrap x = return <xml><body>{x}</body></xml>
+
+fun wrapN n x = return <xml><body>{[n]}; {x}</body></xml>
+
+fun foo2 (wrap : xbody -> transaction page) = wrap <xml>
+ <a link={foo2 wrap}>Foo</a>
+</xml>
+
+fun foo3 (n : int) = wrap <xml>
+ <a link={foo2 (wrapN n)}>Foo</a>
+</xml>
+
+fun bar2 (n : int) (wrap : xbody -> transaction page) = wrap <xml>
+ <a link={bar2 n wrap}>Bar</a>; n={[n]}
+</xml>
+
+fun bar3 (n : int) = wrap <xml>
+ <a link={bar2 88 (wrapN n)}>Bar</a>
+</xml>
+
+
+fun main () = return <xml><body>
+ <a link={foo wrap}>Foo</a>
+ <a link={bar wrap 32}>Bar</a>
+ <a link={baz 18 wrap}>Baz</a>
+ <a link={middle 1 wrap 2}>Middle</a>
+ <a link={crazy (fn n => 2 * n) False wrap 2}>Crazy</a>
+ <a link={wild True (fn n => 2 * n) 1.23 wrap 2}>Wild</a>
+ <hr/>
+ <a link={foo3 15}>Foo3</a>
+ <a link={bar3 44}>Bar3</a>
+</body></xml>
diff --git a/tests/espec.urp b/tests/espec.urp
new file mode 100644
index 00000000..045fb1e0
--- /dev/null
+++ b/tests/espec.urp
@@ -0,0 +1,3 @@
+debug
+
+espec
diff --git a/tests/espec.urs b/tests/espec.urs
new file mode 100644
index 00000000..6ac44e0b
--- /dev/null
+++ b/tests/espec.urs
@@ -0,0 +1 @@
+val main : unit -> transaction page