summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-12-31 18:07:53 -0500
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-12-31 18:07:53 -0500
commit76a84dd3fb97b56605292c4f0eab2febe3c6a7ed (patch)
tree0bde2b80fc3e8df14cd6e16f05bdd88e062aca9a
parentd57cc15e6b5c1f77ebfbfa222283809a4f594e36 (diff)
Eta-expand bodies of transaction functions in Monoization, to enable later optimization
-rw-r--r--lib/ur/list.ur33
-rw-r--r--lib/ur/list.urs14
-rw-r--r--src/mono_print.sml32
-rw-r--r--src/mono_reduce.sml33
-rw-r--r--src/monoize.sml23
5 files changed, 106 insertions, 29 deletions
diff --git a/lib/ur/list.ur b/lib/ur/list.ur
index 3abd8b97..bca5f4ba 100644
--- a/lib/ur/list.ur
+++ b/lib/ur/list.ur
@@ -133,6 +133,20 @@ fun mapM [m ::: (Type -> Type)] (_ : monad m) [a] [b] f =
mapM' []
end
+fun mapPartialM [m ::: (Type -> Type)] (_ : monad m) [a] [b] f =
+ let
+ fun mapPartialM' acc ls =
+ case ls of
+ [] => return (rev acc)
+ | x :: ls =>
+ v <- f x;
+ mapPartialM' (case v of
+ None => acc
+ | Some x' => x' :: acc) ls
+ in
+ mapPartialM' []
+ end
+
fun mapXM [m ::: (Type -> Type)] (_ : monad m) [a] [ctx ::: {Unit}] f =
let
fun mapXM' ls =
@@ -237,6 +251,25 @@ fun mapQuery [tables ::: {{Type}}] [exps ::: {Type}] [t ::: Type]
[];
return (rev ls)
+fun mapQueryM [tables ::: {{Type}}] [exps ::: {Type}] [t ::: Type]
+ [tables ~ exps] (q : sql_query tables exps)
+ (f : $(exps ++ map (fn fields :: {Type} => $fields) tables) -> transaction t) =
+ ls <- query q
+ (fn fs acc => v <- f fs; return (v :: acc))
+ [];
+ return (rev ls)
+
+fun mapQueryPartialM [tables ::: {{Type}}] [exps ::: {Type}] [t ::: Type]
+ [tables ~ exps] (q : sql_query tables exps)
+ (f : $(exps ++ map (fn fields :: {Type} => $fields) tables) -> transaction (option t)) =
+ ls <- query q
+ (fn fs acc => v <- f fs;
+ return (case v of
+ None => acc
+ | Some v => v :: acc))
+ [];
+ return (rev ls)
+
fun assoc [a] [b] (_ : eq a) (x : a) =
let
fun assoc' (ls : list (a * b)) =
diff --git a/lib/ur/list.urs b/lib/ur/list.urs
index 5f3fad9c..c5e41816 100644
--- a/lib/ur/list.urs
+++ b/lib/ur/list.urs
@@ -27,6 +27,8 @@ val mapX : a ::: Type -> ctx ::: {Unit} -> (a -> xml ctx [] []) -> t a -> xml ct
val mapM : m ::: (Type -> Type) -> monad m -> a ::: Type -> b ::: Type
-> (a -> m b) -> t a -> m (t b)
+val mapPartialM : m ::: (Type -> Type) -> monad m -> a ::: Type -> b ::: Type -> (a -> m (option b)) -> t a -> m (t b)
+
val mapXM : m ::: (Type -> Type) -> monad m -> a ::: Type -> ctx ::: {Unit}
-> (a -> m (xml ctx [] [])) -> t a -> m (xml ctx [] [])
@@ -53,6 +55,18 @@ val mapQuery : tables ::: {{Type}} -> exps ::: {Type} -> t ::: Type
-> ($(exps ++ map (fn fields :: {Type} => $fields) tables) -> t)
-> transaction (list t)
+val mapQueryM : tables ::: {{Type}} -> exps ::: {Type} -> t ::: Type
+ -> [tables ~ exps] =>
+ sql_query tables exps
+ -> ($(exps ++ map (fn fields :: {Type} => $fields) tables) -> transaction t)
+ -> transaction (list t)
+
+val mapQueryPartialM : tables ::: {{Type}} -> exps ::: {Type} -> t ::: Type
+ -> [tables ~ exps] =>
+ sql_query tables exps
+ -> ($(exps ++ map (fn fields :: {Type} => $fields) tables) -> transaction (option t))
+ -> transaction (list t)
+
(** Association lists *)
val assoc : a ::: Type -> b ::: Type -> eq a -> a -> t (a * b) -> option b
diff --git a/src/mono_print.sml b/src/mono_print.sml
index d190640e..a5e795b2 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -206,18 +206,26 @@ fun p_exp' par env (e, _) =
string ".",
string x]
- | ECase (e, pes, _) => parenIf true (box [string "case",
- space,
- p_exp env e,
- space,
- string "of",
- space,
- p_list_sep (box [space, string "|", space])
- (fn (p, e) => box [p_pat env p,
- space,
- string "=>",
- space,
- p_exp (E.patBinds env p) e]) pes])
+ | ECase (e, pes, {result, ...}) => parenIf true (box [string "case",
+ space,
+ p_exp env e,
+ space,
+ if !debug then
+ box [string "return",
+ space,
+ p_typ env result,
+ space]
+ else
+ box [],
+ string "of",
+ space,
+ p_list_sep (box [space, string "|", space])
+ (fn (p, e) => box [p_pat env p,
+ space,
+ string "=>",
+ space,
+ p_exp (E.patBinds env p) e])
+ pes])
| EError (e, t) => box [string "(error",
space,
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index aa6b7051..16cfd9f9 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -582,23 +582,22 @@ fun reduce file =
fun push () =
case result of
(TFun (dom, result), loc) =>
- if List.all (fn (_, (EAbs _, _)) => true | _ => false) pes then
- let
- val r =
- EAbs ("y", dom, result,
- (ECase (liftExpInExp 0 e',
- map (fn (p, (EAbs (_, _, _, e), _)) =>
- (p, swapExpVarsPat (0, patBinds p) e)
- | _ => raise Fail "MonoReduce ECase") pes,
- {disc = disc, result = result}), loc))
- in
- (*Print.prefaces "Swapped"
- [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan)),
- ("r", MonoPrint.p_exp env (r, ErrorMsg.dummySpan))];*)
- r
- end
- else
- e
+ let
+ fun safe (e, _) =
+ case e of
+ EAbs _ => true
+ | _ => false
+ in
+ if List.all (safe o #2) pes then
+ EAbs ("y", dom, result,
+ (ECase (liftExpInExp 0 e',
+ map (fn (p, (EAbs (_, _, _, e), _)) =>
+ (p, swapExpVarsPat (0, patBinds p) e)
+ | _ => raise Fail "MonoReduce ECase") pes,
+ {disc = disc, result = result}), loc))
+ else
+ e
+ end
| _ => e
fun search pes =
diff --git a/src/monoize.sml b/src/monoize.sml
index afe2012f..4d3bfda2 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -3440,6 +3440,29 @@ fun monoDecl (env, fm) (all as (d, loc)) =
end
| L.DValRec vis =>
let
+ val vis = map (fn (x, n, t, e, s) =>
+ let
+ fun maybeTransaction (t, e) =
+ case (#1 t, #1 e) of
+ (L.CApp ((L.CFfi ("Basis", "transaction"), _), _), _) =>
+ SOME (L.EAbs ("_",
+ (L.TRecord (L.CRecord ((L.KType, loc), []), loc), loc),
+ t,
+ (L.EApp (CoreEnv.liftExpInExp 0 e,
+ (L.ERecord [], loc)), loc)), loc)
+ | (L.TFun (dom, ran), L.EAbs (x, _, _, e)) =>
+ (case maybeTransaction (ran, e) of
+ NONE => NONE
+ | SOME e => SOME (L.EAbs (x, dom, ran, e), loc))
+ | _ => NONE
+ in
+ (x, n, t,
+ case maybeTransaction (t, e) of
+ NONE => e
+ | SOME e => e,
+ s)
+ end) vis
+
val env = foldl (fn ((x, n, t, e, s), env) => Env.pushENamed env x n t NONE s) env vis
val (vis, fm) = ListUtil.foldlMap