summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/especialize.sml1
-rw-r--r--src/mono_reduce.sml24
-rw-r--r--src/monoize.sml46
-rw-r--r--src/reduce.sml55
-rw-r--r--tests/badInline.ur12
5 files changed, 99 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)
diff --git a/tests/badInline.ur b/tests/badInline.ur
new file mode 100644
index 00000000..bfbdba79
--- /dev/null
+++ b/tests/badInline.ur
@@ -0,0 +1,12 @@
+style s1
+style s2
+style s3
+
+fun ifClass r cls c = if r then classes cls c else c
+
+fun main (n : int) : transaction page = return <xml><body>
+ <p class={ifClass (n = 0) s1
+ (ifClass (n = 1) s2
+ (ifClass (n = 2) s3
+ null))}>Hi</p>
+</body></xml>
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-01 01:55:34 +0000