diff options
| -rw-r--r-- | CHANGELOG | 1 | ||||
| -rw-r--r-- | src/especialize.sml | 64 | ||||
| -rw-r--r-- | tests/espec.ur | 56 | ||||
| -rw-r--r-- | tests/espec.urp | 3 | ||||
| -rw-r--r-- | tests/espec.urs | 1 |
5 files changed, 98 insertions, 27 deletions
@@ -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 |