From 76a84dd3fb97b56605292c4f0eab2febe3c6a7ed Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 31 Dec 2009 18:07:53 -0500 Subject: Eta-expand bodies of transaction functions in Monoization, to enable later optimization --- lib/ur/list.ur | 33 +++++++++++++++++++++++++++++++++ lib/ur/list.urs | 14 ++++++++++++++ src/mono_print.sml | 32 ++++++++++++++++++++------------ src/mono_reduce.sml | 33 ++++++++++++++++----------------- src/monoize.sml | 23 +++++++++++++++++++++++ 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 -- cgit v1.2.3