@@ -22,7 +22,7 @@ import Data.Set as Set
2222import Data.String as String
2323import Data.Tuple (Tuple(..), fst, snd)
2424import Partial.Unsafe (unsafeCrashWith)
25−import PureScript.Backend.Optimizer.Analysis (class HasAnalysis, BackendAnalysis(..), Capture(..), Complexity(..), ResultTerm(..), Usage(..), analysisOf, analyze, analyzeEffectBlock, bound, bump, complex, resultOf, updated, withResult, withRewrite)
25+import PureScript.Backend.Optimizer.Analysis (class HasAnalysis, BackendAnalysis(..), Capture(..), Complexity(..), ResultTerm(..), Usage(..), analysisOf, bound, bump, complex, resultOf, updated, withResult, withRewrite)
2626import PureScript.Backend.Optimizer.CoreFn (ConstructorType, Ident(..), Literal(..), ModuleName, Prop(..), ProperName, Qualified(..), findProp, propKey, propValue)
2727import PureScript.Backend.Optimizer.Syntax (class HasSyntax, BackendAccessor(..), BackendEffect, BackendOperator(..), BackendOperator1(..), BackendOperator2(..), BackendOperatorNum(..), BackendOperatorOrd(..), BackendSyntax(..), Level(..), Pair(..), syntaxOf)
2828import PureScript.Backend.Optimizer.Utils (foldl1Array, foldr1Array)
@@ -1150,14 +1150,25 @@ caseNumber = case _ of
11501150 NeutLit (LitNumber a) -> Just a
11511151 _ -> Nothing
11521152
1153−type Ctx =
1153+newtype Ctx = Ctx
11541154 { currentLevel :: Int
1155− , lookupExtern :: Tuple (Qualified Ident) (Maybe BackendAccessor) -> Maybe (Tuple BackendAnalysis NeutralExpr)
1155+ , lookupExtern :: Qualified Ident -> Maybe String -> Maybe BackendAnalysis
1156+ , analyze :: Ctx -> BackendSyntax BackendExpr -> BackendAnalysis
11561157 , effect :: Boolean
11571158 }
11581159
11591160nextLevel :: Ctx -> Tuple Level Ctx
1160−nextLevel ctx = Tuple (Level ctx.currentLevel) $ ctx { currentLevel = ctx.currentLevel + 1 }
1161+nextLevel (Ctx ctx) = Tuple (Level ctx.currentLevel) $ Ctx ctx { currentLevel = ctx.currentLevel + 1 }
1162+
1163+effectfully :: Ctx -> Ctx
1164+effectfully (Ctx ctx)
1165+ | ctx.effect = Ctx ctx
1166+ | otherwise = Ctx ctx { effect = true }
1167+
1168+purely :: Ctx -> Ctx
1169+purely (Ctx ctx)
1170+ | ctx.effect = Ctx ctx { effect = false }
1171+ | otherwise = Ctx ctx
11611172
11621173quote :: Ctx -> BackendSemantics -> BackendExpr
11631174quote = go
@@ -1166,7 +1177,7 @@ quote = go
11661177 -- Block constructors
11671178 SemLet ident binding k -> do
11681179 let Tuple level ctx' = nextLevel ctx
1169− build ctx $ Let ident level (quote (ctx { effect = false }) binding) $ quote ctx' $ k $ SemRef (EvalLocal ident level) [] $ defer \_ -> deref binding
1180+ build ctx $ Let ident level (quote (purely ctx) binding) $ quote ctx' $ k $ SemRef (EvalLocal ident level) [] $ defer \_ -> deref binding
11701181 SemLetRec bindings k -> do
11711182 let Tuple level ctx' = nextLevel ctx
11721183 -- We are not currently propagating references
@@ -1175,18 +1186,18 @@ quote = go
11751186 -- which we don't currently implement.
11761187 let neutBindings = (\(Tuple ident _) -> Tuple ident $ defer \_ -> NeutLocal (Just ident) level) <$> bindings
11771188 build ctx $ LetRec level
1178− (map (\b -> quote (ctx' { effect = false }) $ b neutBindings) <$> bindings)
1189+ (map (\b -> quote (purely ctx') $ b neutBindings) <$> bindings)
11791190 (quote ctx' $ k neutBindings)
11801191 SemEffectBind ident binding k -> do
1181− let ctx' = ctx { effect = true }
1192+ let ctx' = effectfully ctx
11821193 let Tuple level ctx'' = nextLevel ctx'
11831194 build ctx $ EffectBind ident level (quote ctx' binding) $ quote ctx'' $ k $ NeutLocal ident level
11841195 SemEffectPure sem ->
1185− build ctx $ EffectPure (quote (ctx { effect = false }) sem)
1196+ build ctx $ EffectPure (quote (purely ctx) sem)
11861197 SemEffectDefer sem ->
1187− build ctx $ EffectDefer (quote (ctx { effect = true }) sem)
1198+ build ctx $ EffectDefer (quote (effectfully ctx) sem)
11881199 SemBranch branches def -> do
1189− let ctx' = ctx { effect = false }
1200+ let ctx' = purely ctx
11901201 let quoteCond (SemConditional a b) = Pair (quote ctx' $ force a) (quote ctx $ force b)
11911202 let branches' = quoteCond <$> branches
11921203 foldr (buildBranchCond ctx) (quote ctx <<< force $ def) branches'
@@ -1200,7 +1211,7 @@ quote = go
12001211 go ctx $ neutralSpine (NeutLocal ident lvl) sp
12011212 SemLam ident k -> do
12021213 let Tuple level ctx' = nextLevel ctx
1203− build ctx $ Abs (NonEmptyArray.singleton (Tuple ident level)) $ quote (ctx' { effect = false }) $ k $ NeutLocal ident level
1214+ build ctx $ Abs (NonEmptyArray.singleton (Tuple ident level)) $ quote (purely ctx') $ k $ NeutLocal ident level
12041215 SemMkFn pro -> do
12051216 let
12061217 loop ctx' idents = case _ of
@@ -1208,7 +1219,7 @@ quote = go
12081219 let Tuple lvl ctx'' = nextLevel ctx'
12091220 loop ctx'' (Array.snoc idents (Tuple ident lvl)) (k (NeutLocal ident lvl))
12101221 MkFnApplied body ->
1211− build ctx' $ UncurriedAbs idents $ quote (ctx' { effect = false }) body
1222+ build ctx' $ UncurriedAbs idents $ quote (purely ctx') body
12121223 loop ctx [] pro
12131224 SemMkEffectFn pro -> do
12141225 let
@@ -1217,7 +1228,7 @@ quote = go
12171228 let Tuple lvl ctx'' = nextLevel ctx'
12181229 loop ctx'' (Array.snoc idents (Tuple ident lvl)) (k (NeutLocal ident lvl))
12191230 MkFnApplied body ->
1220− build ctx' $ UncurriedEffectAbs idents $ quote (ctx' { effect = false }) body
1231+ build ctx' $ UncurriedEffectAbs idents $ quote (purely ctx') body
12211232 loop ctx [] pro
12221233 SemAssocOp op spine ->
12231234 foldl1Array
@@ -1240,15 +1251,15 @@ quote = go
12401251 NeutCtorDef _ ct ty tag fields ->
12411252 build ctx $ CtorDef ct ty tag fields
12421253 NeutUncurriedApp hd spine -> do
1243− let ctx' = ctx { effect = false }
1254+ let ctx' = purely ctx
12441255 let hd' = quote ctx' hd
12451256 build ctx $ UncurriedApp hd' (quote ctx' <$> spine)
12461257 NeutUncurriedEffectApp hd spine -> do
1247− let ctx' = ctx { effect = false }
1258+ let ctx' = purely ctx
12481259 let hd' = quote ctx' hd
12491260 build ctx $ UncurriedEffectApp hd' (quote ctx' <$> spine)
12501261 NeutApp hd spine -> do
1251− let ctx' = ctx { effect = false }
1262+ let ctx' = purely ctx
12521263 let hd' = quote ctx' hd
12531264 case NonEmptyArray.fromArray (quote ctx' <$> spine) of
12541265 Nothing ->
@@ -1264,7 +1275,7 @@ quote = go
12641275 NeutPrimOp op ->
12651276 build ctx $ PrimOp (quote ctx <$> op)
12661277 NeutPrimEffect eff ->
1267− build ctx $ PrimEffect (quote (ctx { effect = false }) <$> eff)
1278+ build ctx $ PrimEffect (quote (purely ctx) <$> eff)
12681279 NeutPrimUndefined ->
12691280 build ctx PrimUndefined
12701281 NeutFail err ->
@@ -1397,13 +1408,10 @@ simplifyCondLiftAnd ctx pair def1 = case pair of
13971408 Nothing
13981409
13991410buildStop :: Ctx -> Qualified Ident -> BackendExpr
1400−buildStop ctx stop = ExprRewrite (analyzeDefault ctx (Var stop)) (RewriteStop stop)
1411+buildStop ctx@(Ctx { analyze }) stop = ExprRewrite (analyze ctx (Var stop)) (RewriteStop stop)
14011412
14021413buildDefault :: Ctx -> BackendSyntax BackendExpr -> BackendExpr
1403−buildDefault ctx expr = ExprSyntax (analyzeDefault ctx expr) expr
1404−
1405−analyzeDefault :: Ctx -> BackendSyntax BackendExpr -> BackendAnalysis
1406−analyzeDefault ctx = (if ctx.effect then analyzeEffectBlock else analyze) (foldMap fst <<< ctx.lookupExtern)
1414+buildDefault ctx@(Ctx { analyze }) expr = ExprSyntax (analyze ctx expr) expr
14071415
14081416rewriteInline :: Maybe Ident -> Level -> BackendExpr -> BackendExpr -> BackendExpr
14091417rewriteInline ident level binding body = do