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, 39 insertions, 99 deletions
diff --git a/src/especialize.sml b/src/especialize.sml
index a3d59ef9..d6bf7eba 100644
--- a/src/especialize.sml
+++ b/src/especialize.sml
@@ -124,7 +124,6 @@ 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 af61489c..88628ac2 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 (string * typ * exp) list | No | Maybe
+datatype result = Yes of exp list | No | Maybe
fun match (env, p : pat, e : exp) =
case (#1 p, #1 e) of
(PWild, _) => Yes env
- | (PVar (x, t), _) => Yes ((x, t, e) :: env)
+ | (PVar (x, t), _) => Yes (e :: env)
| (PPrim (Prim.String s), EStrcat ((EPrim (Prim.String s'), _), _)) =>
if String.isPrefix s' s then
@@ -519,17 +519,6 @@ 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
@@ -608,8 +597,6 @@ fun reduce file =
else
e
end
- else if countFree 0 0 b > 1 andalso notValue e' then
- e
else
trySub ()
end
@@ -672,11 +659,8 @@ fun reduce file =
| Yes subs =>
let
val (body, remaining) =
- 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))
+ foldl (fn (e, (body, remaining)) =>
+ (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 edc13c3f..1b9c97ed 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'.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 = (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, fm) = foldl (fn (("Action", _, _), acc) => acc
| (("Source", _, _), acc) => acc
diff --git a/src/reduce.sml b/src/reduce.sml
index c5733b97..1fbf526d 100644
--- a/src/reduce.sml
+++ b/src/reduce.sml
@@ -232,21 +232,6 @@ 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)) =
@@ -549,30 +534,16 @@ fun kindConAndExp (namedC, namedE) =
val e2 = exp env e2
in
case #1 e1 of
- 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
-
+ 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
| ECase (e, pes, cc as {disc, result = res as (TFun (_, c2), _)}) =>
let
val pes' = map (fn (p, body) =>
@@ -789,14 +760,12 @@ fun kindConAndExp (namedC, namedE) =
| ELet (x, t, e1, e2) =>
let
- val e1' = exp env e1
-
val t = con env t
in
- if passive e1' orelse count e2 <= 1 orelse ESpecialize.functionInside t then
+ if ESpecialize.functionInside t then
exp (KnownE e1 :: env) e2
else
- (ELet (x, t, e1', exp (UnknownE :: env) e2), loc)
+ (ELet (x, t, exp env 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
deleted file mode 100644
index bfbdba79..00000000
--- a/tests/badInline.ur
+++ /dev/null
@@ -1,12 +0,0 @@
-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-11-25 22:58:10 +0000