summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2008-11-06 17:09:53 -0500
committerGravatar Adam Chlipala <adamc@hcoop.net>2008-11-06 17:09:53 -0500
commit36952b2e49afdb4ba8024eb6372992e4b5d8df7a (patch)
tree16401277a8c24a1bcfcc410700526f64ba27a5b8 /src
parent49f721d39e46ab0635cc2e9a5ed2a66944586640 (diff)
About to begin optimization of recursive transaction functions
Diffstat (limited to 'src')
-rw-r--r--src/elaborate.sml198
-rw-r--r--src/especialize.sml6
2 files changed, 127 insertions, 77 deletions
diff --git a/src/elaborate.sml b/src/elaborate.sml
index a6edc0ed..f0beecdd 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -1777,6 +1777,38 @@ fun tableOf () = (L'.CModProj (!basis_r, [], "sql_table"), ErrorMsg.dummySpan)
fun sequenceOf () = (L'.CModProj (!basis_r, [], "sql_sequence"), ErrorMsg.dummySpan)
fun cookieOf () = (L'.CModProj (!basis_r, [], "http_cookie"), ErrorMsg.dummySpan)
+fun dopenConstraints (loc, env, denv) {str, strs} =
+ case E.lookupStr env str of
+ NONE => (strError env (UnboundStr (loc, str));
+ denv)
+ | SOME (n, sgn) =>
+ let
+ val (st, sgn) = foldl (fn (m, (str, sgn)) =>
+ case E.projectStr env {str = str, sgn = sgn, field = m} of
+ NONE => (strError env (UnboundStr (loc, m));
+ (strerror, sgnerror))
+ | SOME sgn => ((L'.StrProj (str, m), loc), sgn))
+ ((L'.StrVar n, loc), sgn) strs
+
+ val cso = E.projectConstraints env {sgn = sgn, str = st}
+
+ val denv = case cso of
+ NONE => (strError env (UnboundStr (loc, str));
+ denv)
+ | SOME cs => foldl (fn ((c1, c2), denv) =>
+ let
+ val (denv, gs) = D.assert env denv (c1, c2)
+ in
+ case gs of
+ [] => ()
+ | _ => raise Fail "dopenConstraints: Sub-constraints remain";
+
+ denv
+ end) denv cs
+ in
+ denv
+ end
+
fun elabSgn_item ((sgi, loc), (env, denv, gs)) =
case sgi of
L.SgiConAbs (x, k) =>
@@ -2054,7 +2086,8 @@ and elabSgn (env, denv) (sgn, loc) =
let
val (dom', gs1) = elabSgn (env, denv) dom
val (env', n) = E.pushStrNamed env m dom'
- val (ran', gs2) = elabSgn (env', denv) ran
+ val denv' = dopenConstraints (loc, env', denv) {str = m, strs = []}
+ val (ran', gs2) = elabSgn (env', denv') ran
in
((L'.SgnFun (m, n, dom', ran'), loc), gs1 @ gs2)
end
@@ -2193,38 +2226,6 @@ fun dopen (env, denv) {str, strs, sgn} =
([], (env, denv)))
end
-fun dopenConstraints (loc, env, denv) {str, strs} =
- case E.lookupStr env str of
- NONE => (strError env (UnboundStr (loc, str));
- denv)
- | SOME (n, sgn) =>
- let
- val (st, sgn) = foldl (fn (m, (str, sgn)) =>
- case E.projectStr env {str = str, sgn = sgn, field = m} of
- NONE => (strError env (UnboundStr (loc, m));
- (strerror, sgnerror))
- | SOME sgn => ((L'.StrProj (str, m), loc), sgn))
- ((L'.StrVar n, loc), sgn) strs
-
- val cso = E.projectConstraints env {sgn = sgn, str = st}
-
- val denv = case cso of
- NONE => (strError env (UnboundStr (loc, str));
- denv)
- | SOME cs => foldl (fn ((c1, c2), denv) =>
- let
- val (denv, gs) = D.assert env denv (c1, c2)
- in
- case gs of
- [] => ()
- | _ => raise Fail "dopenConstraints: Sub-constraints remain";
-
- denv
- end) denv cs
- in
- denv
- end
-
fun sgiOfDecl (d, loc) =
case d of
L'.DCon (x, n, k, c) => [(L'.SgiCon (x, n, k, c), loc)]
@@ -2252,6 +2253,8 @@ fun sgiBindsD (env, denv) (sgi, _) =
| _ => denv
fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) =
+ ((*prefaces "subSgn" [("sgn1", p_sgn env sgn1),
+ ("sgn2", p_sgn env sgn2)];*)
case (#1 (hnormSgn env sgn1), #1 (hnormSgn env sgn2)) of
(L'.SgnError, _) => ()
| (_, L'.SgnError) => ()
@@ -2274,8 +2277,18 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) =
[] => (sgnError env (UnmatchedSgi sgi2All);
(env, denv))
| h :: t =>
- case p h of
- NONE => seek (E.sgiBinds env h, sgiBindsD (env, denv) h) t
+ case p (env, h) of
+ NONE =>
+ let
+ val env = case #1 h of
+ L'.SgiCon (x, n, k, c) =>
+ E.pushCNamedAs env x n k (SOME c)
+ | L'.SgiConAbs (x, n, k) =>
+ E.pushCNamedAs env x n k NONE
+ | _ => env
+ in
+ seek (E.sgiBinds env h, sgiBindsD (env, denv) h) t
+ end
| SOME envs => envs
in
seek (env, denv) sgis1
@@ -2283,7 +2296,7 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) =
in
case sgi of
L'.SgiConAbs (x, n2, k2) =>
- seek (fn sgi1All as (sgi1, _) =>
+ seek (fn (env, sgi1All as (sgi1, _)) =>
let
fun found (x', n1, k1, co1) =
if x = x' then
@@ -2331,7 +2344,7 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) =
end)
| L'.SgiCon (x, n2, k2, c2) =>
- seek (fn sgi1All as (sgi1, _) =>
+ seek (fn (env, sgi1All as (sgi1, _)) =>
let
fun found (x', n1, k1, c1) =
if x = x' then
@@ -2365,7 +2378,7 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) =
end)
| L'.SgiDatatype (x, n2, xs2, xncs2) =>
- seek (fn sgi1All as (sgi1, _) =>
+ seek (fn (env, sgi1All as (sgi1, _)) =>
let
fun found (n1, xs1, xncs1) =
let
@@ -2426,7 +2439,7 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) =
end)
| L'.SgiDatatypeImp (x, n2, m12, ms2, s2, xs, _) =>
- seek (fn sgi1All as (sgi1, _) =>
+ seek (fn (env, sgi1All as (sgi1, _)) =>
case sgi1 of
L'.SgiDatatypeImp (x', n1, m11, ms1, s1, _, _) =>
if x = x' then
@@ -2457,7 +2470,7 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) =
| _ => NONE)
| L'.SgiVal (x, n2, c2) =>
- seek (fn sgi1All as (sgi1, _) =>
+ seek (fn (env, sgi1All as (sgi1, _)) =>
case sgi1 of
L'.SgiVal (x', n1, c1) =>
if x = x' then
@@ -2474,7 +2487,7 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) =
| _ => NONE)
| L'.SgiStr (x, n2, sgn2) =>
- seek (fn sgi1All as (sgi1, _) =>
+ seek (fn (env, sgi1All as (sgi1, _)) =>
case sgi1 of
L'.SgiStr (x', n1, sgn1) =>
if x = x' then
@@ -2495,7 +2508,7 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) =
| _ => NONE)
| L'.SgiSgn (x, n2, sgn2) =>
- seek (fn sgi1All as (sgi1, _) =>
+ seek (fn (env, sgi1All as (sgi1, _)) =>
case sgi1 of
L'.SgiSgn (x', n1, sgn1) =>
if x = x' then
@@ -2516,7 +2529,7 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) =
| _ => NONE)
| L'.SgiConstraint (c2, d2) =>
- seek (fn sgi1All as (sgi1, _) =>
+ seek (fn (env, sgi1All as (sgi1, _)) =>
case sgi1 of
L'.SgiConstraint (c1, d1) =>
if consEq (env, denv) (c1, c2) andalso consEq (env, denv) (d1, d2) then
@@ -2534,7 +2547,7 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) =
| _ => NONE)
| L'.SgiClassAbs (x, n2) =>
- seek (fn sgi1All as (sgi1, _) =>
+ seek (fn (env, sgi1All as (sgi1, _)) =>
let
fun found (x', n1, co) =
if x = x' then
@@ -2557,7 +2570,7 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) =
| _ => NONE
end)
| L'.SgiClass (x, n2, c2) =>
- seek (fn sgi1All as (sgi1, _) =>
+ seek (fn (env, sgi1All as (sgi1, _)) =>
let
val k = (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc)
@@ -2606,7 +2619,7 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) =
subSgn (E.pushStrNamedAs env m2 n2 dom2, denv) ran1 ran2
end
- | _ => sgnError env (SgnWrongForm (sgn1, sgn2))
+ | _ => sgnError env (SgnWrongForm (sgn1, sgn2)))
fun positive self =
@@ -2717,46 +2730,79 @@ fun wildifyStr env (str, sgn) =
| _ => NONE
- val (needed, constraints, _) =
- foldl (fn ((sgi, loc), (needed, constraints, env')) =>
+ val (neededC, constraints, neededV, _) =
+ foldl (fn ((sgi, loc), (neededC, constraints, neededV, env')) =>
let
- val (needed, constraints) =
+ val (needed, constraints, neededV) =
case sgi of
- L'.SgiConAbs (x, _, _) => (SS.add (needed, x), constraints)
- | L'.SgiConstraint cs => (needed, (env', cs, loc) :: constraints)
- | _ => (needed, constraints)
+ L'.SgiConAbs (x, _, _) => (SS.add (neededC, x), constraints, neededV)
+ | L'.SgiConstraint cs => (neededC, (env', cs, loc) :: constraints, neededV)
+
+ | L'.SgiVal (x, _, t) =>
+ let
+ fun default () = (neededC, constraints, neededV)
+
+ val t = normClassConstraint env' t
+ in
+ case #1 t of
+ L'.CApp (f, _) =>
+ if E.isClass env' f then
+ (neededC, constraints, SS.add (neededV, x))
+ else
+ default ()
+
+ | _ => default ()
+ end
+
+ | _ => (neededC, constraints, neededV)
in
- (needed, constraints, E.sgiBinds env' (sgi, loc))
+ (needed, constraints, neededV, E.sgiBinds env' (sgi, loc))
end)
- (SS.empty, [], env) sgis
+ (SS.empty, [], SS.empty, env) sgis
- val needed = foldl (fn ((d, _), needed) =>
- case d of
- L.DCon (x, _, _) => (SS.delete (needed, x)
- handle NotFound =>
- needed)
- | L.DClass (x, _) => (SS.delete (needed, x)
- handle NotFound => needed)
- | L.DOpen _ => SS.empty
- | _ => needed)
- needed ds
-
- val cds = List.mapPartial (fn (env', (c1, c2), loc) =>
+ val (neededC, neededV) = foldl (fn ((d, _), needed as (neededC, neededV)) =>
+ case d of
+ L.DCon (x, _, _) => ((SS.delete (neededC, x), neededV)
+ handle NotFound =>
+ needed)
+ | L.DClass (x, _) => ((SS.delete (neededC, x), neededV)
+ handle NotFound => needed)
+ | L.DVal (x, _, _) => ((neededC, SS.delete (neededV, x))
+ handle NotFound => needed)
+ | L.DOpen _ => (SS.empty, SS.empty)
+ | _ => needed)
+ (neededC, neededV) ds
+
+ val ds' = List.mapPartial (fn (env', (c1, c2), loc) =>
case (decompileCon env' c1, decompileCon env' c2) of
(SOME c1, SOME c2) =>
SOME (L.DConstraint (c1, c2), loc)
| _ => NONE) constraints
+
+ val ds' =
+ case SS.listItems neededV of
+ [] => ds'
+ | xs =>
+ let
+ val ewild = (L.EWild, #2 str)
+ val ds'' = map (fn x => (L.DVal (x, NONE, ewild), #2 str)) xs
+ in
+ ds'' @ ds'
+ end
+
+ val ds' =
+ case SS.listItems neededC of
+ [] => ds'
+ | xs =>
+ let
+ val kwild = (L.KWild, #2 str)
+ val cwild = (L.CWild kwild, #2 str)
+ val ds'' = map (fn x => (L.DCon (x, NONE, cwild), #2 str)) xs
+ in
+ ds'' @ ds'
+ end
in
- case SS.listItems needed of
- [] => (L.StrConst (ds @ cds), #2 str)
- | xs =>
- let
- val kwild = (L.KWild, #2 str)
- val cwild = (L.CWild kwild, #2 str)
- val ds' = map (fn x => (L.DCon (x, NONE, cwild), #2 str)) xs
- in
- (L.StrConst (ds @ ds' @ cds), #2 str)
- end
+ (L.StrConst (ds @ ds'), #2 str)
end
| _ => str)
| _ => str
diff --git a/src/especialize.sml b/src/especialize.sml
index d5e93680..2c6799dd 100644
--- a/src/especialize.sml
+++ b/src/especialize.sml
@@ -110,7 +110,7 @@ fun exp (e, st : state) =
| SOME (_, [], _) => (e, st)
| SOME (f, xs, xs') =>
case IM.find (#funcs st, f) of
- NONE => ((*print "SHOT DOWN!\n";*) (e, st))
+ NONE => ((*print ("SHOT DOWN! " ^ Int.toString f ^ "\n");*) (e, st))
| SOME {name, args, body, typ, tag} =>
case KM.find (args, xs) of
SOME f' => ((*Print.prefaces "Pre-existing" [("e", CorePrint.p_exp CoreEnv.empty (e, ErrorMsg.dummySpan))];*)
@@ -203,6 +203,10 @@ fun specialize' file =
body = e,
typ = c,
tag = tag})
+ | DVal (_, n, _, (ENamed n', _), _) =>
+ (case IM.find (funcs, n') of
+ NONE => funcs
+ | SOME v => IM.insert (funcs, n, v))
| _ => funcs
val (changed, ds) =