Tweaking treatment of function application: substitute or introduce a 'let'?

4 files changed, 87 insertions, 39 deletions

diff --git a/src/especialize.sml b/src/especialize.sml
index d6bf7eba..a3d59ef9 100644
--- a/src/especialize.sml
+++ b/src/especialize.sml
@@ -124,6 +124,7 @@ fun default (_, x, st) = (x, st)
 
 val functionInside = U.Con.exists {kind = fn _ => false,
                                    con = fn TFun _ => true
+                                          | TCFun _ => true
                                           | CFfi ("Basis", "transaction") => true
                                           | CFfi ("Basis", "eq") => true
                                           | CFfi ("Basis", "num") => true
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 88628ac2..af61489c 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -179,12 +179,12 @@ val swapExpVarsPat =
                 bind = fn ((lower, len), U.Exp.RelE _) => (lower+1, len)
                         | (st, _) => st}
 
-datatype result = Yes of exp list | No | Maybe
+datatype result = Yes of (string * typ * exp) list | No | Maybe
 
 fun match (env, p : pat, e : exp) =
     case (#1 p, #1 e) of
         (PWild, _) => Yes env
-      | (PVar (x, t), _) => Yes (e :: env)
+      | (PVar (x, t), _) => Yes ((x, t, e) :: env)
 
       | (PPrim (Prim.String s), EStrcat ((EPrim (Prim.String s'), _), _)) =>
         if String.isPrefix s' s then
@@ -519,6 +519,17 @@ fun reduce file =
 
                 fun doLet (x, t, e', b) =
                     let
+                        val notValue = U.Exp.exists {typ = fn _ => false,
+                                                     exp = fn e =>
+                                                              case e of
+                                                                  EPrim _ => false
+                                                                | ECon _ => false
+                                                                | ENone _ => false
+                                                                | ESome _ => false
+                                                                | ERecord _ => false
+                                                                | _ => true}
+
+
                         fun doSub () =
                             let
                                 val r = subExpInExp (0, e') b
@@ -597,6 +608,8 @@ fun reduce file =
                                 else
                                     e
                             end
+                        else if countFree 0 0 b > 1 andalso notValue e' then
+                            e
                         else
                             trySub ()
                     end
@@ -659,8 +672,11 @@ fun reduce file =
                                       | Yes subs =>
                                         let
                                             val (body, remaining) =
-                                                foldl (fn (e, (body, remaining)) =>
-                                                          (subExpInExp (0, multiLift remaining e) body, remaining - 1))
+                                                foldl (fn ((x, t, e), (body, remaining)) =>
+                                                          (if countFree 0 0 body > 1 then
+                                                               (ELet (x, t, multiLift remaining e, body), #2 e')
+                                                           else
+                                                               subExpInExp (0, multiLift remaining e) body, remaining - 1))
                                                       (body, length subs - 1) subs
                                             val r = reduceExp (E.patBinds env p) body
                                         in
diff --git a/src/monoize.sml b/src/monoize.sml
index 1b9c97ed..edc13c3f 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -3257,29 +3257,29 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                         val t = (L'.TFfi ("Basis", "string"), loc)
                         val s = (L'.EPrim (Prim.String (String.concat ["<", tag'])), loc)
 
-                        val s = (L'.ECase (class,
-                                           [((L'.PPrim (Prim.String ""), loc),
-                                             s),
-                                            ((L'.PVar ("x", t), loc),
-                                             (L'.EStrcat (s,
-                                                         (L'.EStrcat ((L'.EPrim (Prim.String " class=\""), loc),
-                                                                      (L'.EStrcat ((L'.ERel 0, loc),
-                                                                                   (L'.EPrim (Prim.String "\""), loc)),
-                                                                       loc)), loc)), loc))],
-                                           {disc = t,
-                                            result = t}), loc)
-
-                        val s = (L'.ECase (style,
-                                           [((L'.PPrim (Prim.String ""), loc),
-                                             s),
-                                            ((L'.PVar ("x", t), loc),
-                                             (L'.EStrcat (s,
-                                                         (L'.EStrcat ((L'.EPrim (Prim.String " style=\""), loc),
-                                                                      (L'.EStrcat ((L'.ERel 0, loc),
-                                                                                   (L'.EPrim (Prim.String "\""), loc)),
-                                                                       loc)), loc)), loc))],
-                                           {disc = t,
-                                            result = t}), loc)
+                        val s = (L'.EStrcat (s,
+                                             (L'.ECase (class,
+                                                        [((L'.PPrim (Prim.String ""), loc),
+                                                          (L'.EPrim (Prim.String ""), loc)),
+                                                         ((L'.PVar ("x", t), loc),
+                                                          (L'.EStrcat ((L'.EPrim (Prim.String " class=\""), loc),
+                                                                       (L'.EStrcat ((L'.ERel 0, loc),
+                                                                                    (L'.EPrim (Prim.String "\""), loc)),
+                                                                        loc)), loc))],
+                                                        {disc = t,
+                                                         result = t}), loc)), loc)
+
+                        val s = (L'.EStrcat (s,
+                                             (L'.ECase (style,
+                                                        [((L'.PPrim (Prim.String ""), loc),
+                                                          (L'.EPrim (Prim.String ""), loc)),
+                                                         ((L'.PVar ("x", t), loc),
+                                                          (L'.EStrcat ((L'.EPrim (Prim.String " style=\""), loc),
+                                                                       (L'.EStrcat ((L'.ERel 0, loc),
+                                                                                    (L'.EPrim (Prim.String "\""), loc)),
+                                                                        loc)), loc))],
+                                                        {disc = t,
+                                                         result = t}), loc)), loc)
 
                         val (s, fm) = foldl (fn (("Action", _, _), acc) => acc
                                               | (("Source", _, _), acc) => acc
diff --git a/src/reduce.sml b/src/reduce.sml
index 1fbf526d..c5733b97 100644
--- a/src/reduce.sml
+++ b/src/reduce.sml
@@ -232,6 +232,21 @@ fun monadRecord m loc =
                         ((CName "Bind", loc),
                          bindType m loc)]), loc), loc)
 
+fun passive (e : exp) =
+    case #1 e of
+        EPrim _ => true
+      | ERel _ => true
+      | ENamed _ => true
+      | ECon (_, _, _, NONE) => true
+      | ECon (_, _, _, SOME e) => passive e
+      | EFfi _ => true
+      | EAbs _ => true
+      | ECAbs _ => true
+      | EKAbs _ => true
+      | ERecord xes => List.all (passive o #2) xes
+      | EField (e, _, _) => passive e
+      | _ => false
+
 fun kindConAndExp (namedC, namedE) =
     let
         fun kind env (all as (k, loc)) =
@@ -534,16 +549,30 @@ fun kindConAndExp (namedC, namedE) =
                                 val e2 = exp env e2
                             in
                                 case #1 e1 of
-                                    EAbs (_, _, _, b) =>
-                                    let
-                                        val r = exp (KnownE e2 :: env') b
-                                    in
-                                        (*Print.prefaces "eapp" [("b", CorePrint.p_exp CoreEnv.empty b),
-                                                               ("env", Print.PD.string (e2s env')),
-                                                               ("e2", CorePrint.p_exp CoreEnv.empty e2),
-                                                               ("r", CorePrint.p_exp CoreEnv.empty r)];*)
-                                        r
-                                    end
+                                    ELet (x, t, e1', e2') =>
+                                    (ELet (x, t, e1', exp (UnknownE :: env') (EApp (e2', E.liftExpInExp 0 e2), loc)), loc)
+
+                                  | EAbs (x, dom, _, b) =>
+                                    if count b <= 1 orelse passive e2 orelse ESpecialize.functionInside dom then
+                                        let
+                                            val r = exp (KnownE e2 :: env') b
+                                        in
+                                            (*Print.prefaces "eapp" [("b", CorePrint.p_exp CoreEnv.empty b),
+                                                                     ("env", Print.PD.string (e2s env')),
+                                                                     ("e2", CorePrint.p_exp CoreEnv.empty e2),
+                                                                     ("r", CorePrint.p_exp CoreEnv.empty r)];*)
+                                            r
+                                        end
+                                    else
+                                        let
+                                            val dom = con env' dom
+                                            val r = exp (UnknownE :: env') b
+                                        in
+                                            (*Print.prefaces "El skippo" [("x", Print.PD.string x),
+                                                                        ("e2", CorePrint.p_exp CoreEnv.empty e2)];*)
+                                            (ELet (x, dom, e2, r), loc)
+                                        end
+
                                   | ECase (e, pes, cc as {disc, result = res as (TFun (_, c2), _)}) =>
                                     let
                                         val pes' = map (fn (p, body) =>
@@ -760,12 +789,14 @@ fun kindConAndExp (namedC, namedE) =
 
                           | ELet (x, t, e1, e2) =>
                             let
+                                val e1' = exp env e1
+
                                 val t = con env t
                             in
-                                if ESpecialize.functionInside t then
+                                if passive e1' orelse count e2 <= 1 orelse ESpecialize.functionInside t then
                                     exp (KnownE e1 :: env) e2
                                 else
-                                    (ELet (x, t, exp env e1, exp (UnknownE :: env) e2), loc)
+                                    (ELet (x, t, e1', exp (UnknownE :: env) e2), loc)
                             end
 
                           | EServerCall (n, es, t) => (EServerCall (n, map (exp env) es, con env t), loc)