5f1fd24 · rowtype-yoga/purescript-backend-optimizer

git.iko.soy/rowtype-yoga/purescript-backend-optimizer

Remove Maybe from fallback in Branch (#49)

* Remove Maybe from fallback in Branch * Simplify codegenBlockBranches * Remove unneeded parentheses * Refactor evalBranches * Remove ExprBacktrack and NeutBacktrack * Further remove Maybe in SemConditional * Remote continuation from SemConditional * Separate laziness for condition and body * Tiny refactor * Totality is the default * Format files

commit5f1fd244859ed9306f360753cc316be27e4f0155 authorJustin Garcia <functor@duck.com> dateSat 6 May 2023, 01:29 (3 years ago) parent85a70a4

6 files changed+80−143

compare with main

unifiedsplit

backend-es/src/PureScript/Backend/Optimizer/Codegen/EcmaScript/Convert.purs+12−14 src/PureScript/Backend/Optimizer/Analysis.purs+1−1 src/PureScript/Backend/Optimizer/Codegen/Tco.purs+17−39 src/PureScript/Backend/Optimizer/Convert.purs+3−3 src/PureScript/Backend/Optimizer/Semantics.purs+44−83 src/PureScript/Backend/Optimizer/Syntax.purs+3−3

backend-es/src/PureScript/Backend/Optimizer/Codegen/EcmaScript/Convert.purs+12−14

@@ -26,7 +26,7 @@ import Data.Tuple (Tuple(..), fst, snd, uncurry)

2626import Partial.Unsafe (unsafeCrashWith)

2727import PureScript.Backend.Optimizer.Codegen.EcmaScript.Common (esEscapeIdent)

2828import PureScript.Backend.Optimizer.Codegen.EcmaScript.Syntax (class ToEsIdent, EsArrayElement(..), EsBinaryOp(..), EsBindingPattern(..), EsExpr(..), EsIdent(..), EsObjectElement(..), EsRuntimeOp(..), EsSyntax(..), EsUnaryOp(..), build, esArrowFunction, esAssignIdent, esBinding, esCurriedFunction, esLazyBinding, printIdentString, toEsIdent, toEsIdentWith)

29−import PureScript.Backend.Optimizer.Codegen.Tco (LocalRef, TcoAnalysis(..), TcoExpr(..), TcoPop, TcoRef(..), TcoRole, TcoScope, TcoScopeItem, TcoUsage(..), Total(..), tcoAnalysisOf)

29+import PureScript.Backend.Optimizer.Codegen.Tco (LocalRef, TcoAnalysis(..), TcoExpr(..), TcoPop, TcoRef(..), TcoRole, TcoScope, TcoScopeItem, TcoUsage(..), tcoAnalysisOf)

3030import PureScript.Backend.Optimizer.Codegen.Tco as Tco

3131import PureScript.Backend.Optimizer.Convert (BackendBindingGroup, BackendImplementations)

3232import PureScript.Backend.Optimizer.CoreFn (ConstructorType(..), Ident(..), Literal(..), ModuleName, Prop(..), ProperName(..), Qualified(..), propValue, qualifiedModuleName, unQualified)

@@ -375,7 +375,7 @@ codegenBlockStatements = go []

375375 let line = esBinding (toEsIdent ident') (codegenExpr env binding)

376376 go (Array.snoc acc line) mode env' body

377377 Branch bs def ->

378− acc <> codegenBlockBranches mode env analysis.total bs def

378+ acc <> codegenBlockBranches mode env bs def

379379 EffectBind ident lvl (TcoExpr _ (PrimEffect (EffectRefNew val))) body

380380 | mode.effect && canUnboxRef (TcoLocal ident lvl) (tcoAnalysisOf body) -> do

381381 let Tuple ident' env' = freshName RefUnboxed ident lvl env

@@ -384,8 +384,8 @@ codegenBlockStatements = go []

384384 EffectBind ident lvl eff body

385385 | mode.effect && totalUsagesOf (TcoLocal ident lvl) (tcoAnalysisOf body) == 0 ->

386386 case eff of

387− TcoExpr (TcoAnalysis { total: Root Total }) (Branch bs def) -> do

388− let lines = codegenBlockBranches (mode { return = Discard }) env (Root Total) bs def -- TODO

387+ TcoExpr _ (Branch bs def) -> do

388+ let lines = codegenBlockBranches (mode { return = Discard }) env bs def -- TODO

389389 go (acc <> lines) mode env body

390390 _ -> do

391391 let line = codegenBindEffect env eff

@@ -450,19 +450,17 @@ codegenBlockReturn mode env tcoExpr

450450 Return ->

451451 pure $ build $ EsReturn $ Just $ codegenExpr env tcoExpr

452452

453−codegenBlockBranches :: BlockMode -> CodegenEnv -> Total -> NonEmptyArray (Pair TcoExpr) -> Maybe TcoExpr -> Array EsExpr

454−codegenBlockBranches mode env total bs def = case total, def of

455− Root Total, Just def'

456− | mode.return == Discard ->

457− foldr (\p -> pure <<< build <<< uncurry EsIfElse (go p)) (codegenBlockStatements mode env def') bs

458− _, _ ->

459− NonEmptyArray.toArray (build <<< flip (uncurry EsIfElse) [] <<< go <$> bs)

460− <> maybe [] (codegenBlockStatements mode env) def

453+codegenBlockBranches :: BlockMode -> CodegenEnv -> NonEmptyArray (Pair TcoExpr) -> TcoExpr -> Array EsExpr

454+codegenBlockBranches mode env bs def = case mode.return of

455+ Discard ->

456+ foldr (\p -> pure <<< build <<< uncurry EsIfElse (go p)) (codegenBlockStatements mode env def) bs

457+ _ ->

458+ NonEmptyArray.toArray (build <<< flip (uncurry EsIfElse) [] <<< go <$> bs) <> codegenBlockStatements mode env def

461459 where

462460 go :: Pair TcoExpr -> Tuple EsExpr (Array EsExpr)

463− go (Pair a b@(TcoExpr (TcoAnalysis s) b')) = case b' of

461+ go (Pair a b@(TcoExpr _ b')) = case b' of

464462 Branch next nextDef ->

465− Tuple (codegenExpr env a) $ codegenBlockBranches mode env s.total next nextDef

463+ Tuple (codegenExpr env a) $ codegenBlockBranches mode env next nextDef

466464 _ ->

467465 Tuple (codegenExpr env a) $ codegenBlockStatements mode env b

468466

src/PureScript/Backend/Optimizer/Analysis.purs+1−1

@@ -314,7 +314,7 @@ analyze externAnalysis expr = case expr of

314314 analysisOf a

315315 <> capture CaptureBranch (analysisOf b)

316316 <> capture CaptureBranch (foldMap (foldMap analysisOf) (NonEmptyArray.tail bs))

317− <> capture CaptureBranch (foldMap analysisOf def)

317+ <> capture CaptureBranch (analysisOf def)

318318 Fail _ ->

319319 complex NonTrivial

320320 $ analyzeDefault expr

src/PureScript/Backend/Optimizer/Codegen/Tco.purs+17−39

@@ -11,7 +11,7 @@ import Data.List (List)

1111import Data.List as List

1212import Data.Map (Map)

1313import Data.Map as Map

14−import Data.Maybe (Maybe(..), isJust, maybe)

14+import Data.Maybe (Maybe(..), maybe)

1515import Data.Newtype (class Newtype)

1616import Data.Set (Set)

1717import Data.Set as Set

@@ -100,22 +100,10 @@ instance Monoid TcoUsage where

100100 , readWrite: 0

101101 }

102102

103−data Total = Total | Partial | Root Total

104−

105−instance Semigroup Total where

106− append = case _, _ of

107− Partial, _ -> Partial

108− _, Partial -> Partial

109− _, _ -> Total

110−

111−instance Monoid Total where

112− mempty = Total

113−

114103newtype TcoAnalysis = TcoAnalysis

115104 { usages :: Map TcoRef TcoUsage

116105 , tailCalls :: Map TcoRef Int

117106 , role :: TcoRole

118− , total :: Total

119107 }

120108

121109derive instance Newtype TcoAnalysis _

@@ -125,7 +113,6 @@ instance Semigroup TcoAnalysis where

125113 { usages: Map.unionWith append a.usages b.usages

126114 , tailCalls: Map.unionWith add a.tailCalls b.tailCalls

127115 , role: noTcoRole

128− , total: a.total <> b.total

129116 }

130117

131118instance Monoid TcoAnalysis where

@@ -133,7 +120,6 @@ instance Monoid TcoAnalysis where

133120 { usages: Map.empty

134121 , tailCalls: Map.empty

135122 , role: noTcoRole

136− , total: mempty

137123 }

138124

139125type TcoRole =

@@ -182,11 +168,6 @@ tcoNoTailCalls (TcoAnalysis s) = TcoAnalysis s

182168 , role = s.role { joins = [] }

183169 }

184170

185−tcoTotal :: Total -> TcoAnalysis -> TcoAnalysis

186−tcoTotal total (TcoAnalysis s) = TcoAnalysis s

187− { total = total

188− }

189−

190171withTcoRole :: TcoRole -> TcoAnalysis -> TcoAnalysis

191172withTcoRole role (TcoAnalysis s) = TcoAnalysis s { role = role }

192173

@@ -261,46 +242,43 @@ syntacticArity = case _ of

261242analyze :: TcoEnv -> NeutralExpr -> TcoExpr

262243analyze env (NeutralExpr expr) = case expr of

263244 Var ident ->

264− TcoExpr (tcoTotal Total $ tcoCall (TcoTopLevel ident) 0 mempty) $ Var ident

245+ TcoExpr (tcoCall (TcoTopLevel ident) 0 mempty) $ Var ident

265246 Local ident level ->

266− TcoExpr (tcoTotal Total $ tcoCall (TcoLocal ident level) 0 mempty) $ Local ident level

247+ TcoExpr (tcoCall (TcoLocal ident level) 0 mempty) $ Local ident level

267248 App hd@(NeutralExpr (Local ident level)) tl -> do

268249 let hd' = analyze env hd

269250 let tl' = overTcoAnalysis tcoNoTailCalls <<< analyze env <$> tl

270− let analysis2 = tcoTotal Total $ tcoCall (TcoLocal ident level) (NonEmptyArray.length tl') (foldMap tcoAnalysisOf tl')

251+ let analysis2 = tcoCall (TcoLocal ident level) (NonEmptyArray.length tl') (foldMap tcoAnalysisOf tl')

271252 TcoExpr analysis2 $ App hd' tl'

272253 App hd@(NeutralExpr (Var ident)) tl -> do

273254 let hd' = analyze env hd

274255 let tl' = overTcoAnalysis tcoNoTailCalls <<< analyze env <$> tl

275− let analysis2 = tcoTotal Total $ tcoCall (TcoTopLevel ident) (NonEmptyArray.length tl') (foldMap tcoAnalysisOf tl')

256+ let analysis2 = tcoCall (TcoTopLevel ident) (NonEmptyArray.length tl') (foldMap tcoAnalysisOf tl')

276257 TcoExpr analysis2 $ App hd' tl'

277258 UncurriedApp hd@(NeutralExpr (Local ident level)) tl -> do

278259 let hd' = analyze env hd

279260 let tl' = overTcoAnalysis tcoNoTailCalls <<< analyze env <$> tl

280− let analysis2 = tcoTotal Total $ tcoCall (TcoLocal ident level) (Array.length tl') (foldMap tcoAnalysisOf tl')

261+ let analysis2 = tcoCall (TcoLocal ident level) (Array.length tl') (foldMap tcoAnalysisOf tl')

281262 TcoExpr analysis2 $ UncurriedApp hd' tl'

282263 UncurriedApp hd@(NeutralExpr (Var ident)) tl -> do

283264 let hd' = analyze env hd

284265 let tl' = overTcoAnalysis tcoNoTailCalls <<< analyze env <$> tl

285− let analysis2 = tcoTotal Total $ tcoCall (TcoTopLevel ident) (Array.length tl') (foldMap tcoAnalysisOf tl')

266+ let analysis2 = tcoCall (TcoTopLevel ident) (Array.length tl') (foldMap tcoAnalysisOf tl')

286267 TcoExpr analysis2 $ UncurriedApp hd' tl'

287268 PrimEffect (EffectRefRead ref@(NeutralExpr (Local ident level))) -> do

288269 let ref' = analyze env ref

289− let analysis = tcoTotal Total $ tcoRefEffect (TcoLocal ident level) mempty

270+ let analysis = tcoRefEffect (TcoLocal ident level) mempty

290271 TcoExpr analysis $ PrimEffect (EffectRefRead ref')

291272 PrimEffect (EffectRefWrite ref@(NeutralExpr (Local ident level)) val) -> do

292273 let ref' = analyze env ref

293274 let val' = analyze env val

294− let analysis = tcoTotal Total $ tcoRefEffect (TcoLocal ident level) $ tcoAnalysisOf val'

275+ let analysis = tcoRefEffect (TcoLocal ident level) $ tcoAnalysisOf val'

295276 TcoExpr analysis $ PrimEffect (EffectRefWrite ref' val')

296277 Branch branches def -> do

297278 let branches' = map (\(Pair a b) -> Pair (overTcoAnalysis tcoNoTailCalls (analyze env a)) (analyze env b)) branches

298− let def' = analyze env <$> def

299− let analysis@(TcoAnalysis { total }) = foldMap (foldMap tcoAnalysisOf) branches' <> foldMap tcoAnalysisOf def'

300− if isJust def then

301− TcoExpr (tcoTotal (Root total) analysis) $ Branch branches' def'

302− else

303− TcoExpr (tcoTotal Partial analysis) $ Branch branches' def'

279+ let def' = analyze env def

280+ let analysis = foldMap (foldMap tcoAnalysisOf) branches' <> tcoAnalysisOf def'

281+ TcoExpr analysis $ Branch branches' def'

304282 Let ident level binding body -> do

305283 let binding' = analyze env binding

306284 let body' = analyze env body

@@ -309,10 +287,10 @@ analyze env (NeutralExpr expr) = case expr of

309287 let role = { isLoop: false, joins: foldMap (tcoRoleJoins env (tcoAnalysisOf body') <<< pure) refBinding }

310288 case refBinding of

311289 Just rb | hasTcoRole role -> do

312− let analysis = tcoTotal Total $ rb.analysis <> tcoAnalysisOf body'

290+ let analysis = rb.analysis <> tcoAnalysisOf body'

313291 TcoExpr (withTcoRole role analysis) expr'

314292 _ -> do

315− let analysis = tcoTotal Total $ tcoNoTailCalls (tcoAnalysisOf binding') <> tcoAnalysisOf body'

293+ let analysis = tcoNoTailCalls (tcoAnalysisOf binding') <> tcoAnalysisOf body'

316294 TcoExpr analysis expr'

317295 LetRec level bindings body -> do

318296 let group = localTcoEnvGroup level bindings

@@ -324,11 +302,11 @@ analyze env (NeutralExpr expr) = case expr of

324302 let isLoop = maybe false tcoRoleIsLoop refBindings

325303 let role = { isLoop, joins: foldMap (tcoRoleJoins env (tcoAnalysisOf body')) refBindings }

326304 if hasTcoRole role then do

327− let analysis = tcoTotal Total $ foldMap (foldMap _.analysis) refBindings <> tcoAnalysisOf body'

305+ let analysis = foldMap (foldMap _.analysis) refBindings <> tcoAnalysisOf body'

328306 TcoExpr (withTcoRole role analysis) expr'

329307 else do

330− let analysis = tcoTotal Total $ tcoNoTailCalls (foldMap (foldMap tcoAnalysisOf) bindings') <> tcoAnalysisOf body'

308+ let analysis = tcoNoTailCalls (foldMap (foldMap tcoAnalysisOf) bindings') <> tcoAnalysisOf body'

331309 TcoExpr analysis expr'

332310 _ -> do

333311 let expr' = analyze env <$> expr

334− TcoExpr (tcoTotal Total $ tcoNoTailCalls (foldMap tcoAnalysisOf expr')) expr'

312+ TcoExpr (tcoNoTailCalls (foldMap tcoAnalysisOf expr')) expr'

src/PureScript/Backend/Optimizer/Convert.purs+3−3

@@ -233,7 +233,7 @@ toBackendTopLevelBindingGroup env = case _ of

233233

234234toTopLevelBackendBinding :: Array (Qualified Ident) -> ConvertEnv -> Binding Ann -> Accum ConvertEnv (Tuple Ident (WithDeps NeutralExpr))

235235toTopLevelBackendBinding group env (Binding _ ident cfn) = do

236− let evalEnv = Env { currentModule: env.currentModule, evalExtern: makeExternEval env, locals: [], directives: env.directives, branchTry: Nothing }

236+ let evalEnv = Env { currentModule: env.currentModule, evalExtern: makeExternEval env, locals: [], directives: env.directives }

237237 let backendExpr = toBackendExpr cfn env

238238 let Tuple impl expr' = toExternImpl env group (optimize (getCtx env) evalEnv (Qualified (Just env.currentModule) ident) env.rewriteLimit backendExpr)

239239 { accum: env

@@ -706,7 +706,7 @@ buildCaseLeaf row0 tailRows = do

706706 pairs <- for gs \(Tuple pred bodyFn) ->

707707 Pair <$> toBackendExpr pred <*> callFn bodyFn args

708708 fallback <- buildCaseTreeFromRows tailRows

709− buildM $ Branch pairs (Just fallback)

709+ buildM $ Branch pairs fallback

710710 )

711711 orderedArgs

712712 []

@@ -940,7 +940,7 @@ makeGuard

940940 -> ConvertM BackendExpr

941941 -> ConvertM BackendExpr

942942makeGuard lvl g inner def =

943− make $ Branch (NonEmptyArray.singleton (Pair (make (g (make (Local Nothing lvl)))) inner)) (Just def)

943+ make $ Branch (NonEmptyArray.singleton (Pair (make (g (make (Local Nothing lvl)))) inner)) def

944944

945945makeUncurriedAbs

946946 :: Array Ident

src/PureScript/Backend/Optimizer/Semantics.purs+44−83

@@ -14,7 +14,7 @@ import Data.Lazy (Lazy, defer, force)

1414import Data.List as List

1515import Data.Map (Map)

1616import Data.Map as Map

17−import Data.Maybe (Maybe(..), fromMaybe)

17+import Data.Maybe (Maybe(..))

1818import Data.Monoid (power)

1919import Data.Newtype (class Newtype, unwrap)

2020import Data.Set as Set

@@ -44,7 +44,7 @@ data BackendSemantics

4444 | SemEffectBind (Maybe Ident) BackendSemantics (BackendSemantics -> BackendSemantics)

4545 | SemEffectPure BackendSemantics

4646 | SemEffectDefer BackendSemantics

47− | SemBranch (NonEmptyArray (Lazy (SemConditional BackendSemantics))) (Maybe (Lazy BackendSemantics))

47+ | SemBranch (NonEmptyArray (SemConditional BackendSemantics)) (Lazy BackendSemantics)

4848 | NeutLocal (Maybe Ident) Level

4949 | NeutVar (Qualified Ident)

5050 | NeutStop (Qualified Ident)

@@ -55,21 +55,17 @@ data BackendSemantics

5555 | NeutUpdate BackendSemantics (Array (Prop BackendSemantics))

5656 | NeutLit (Literal BackendSemantics)

5757 | NeutFail String

58− | NeutBacktrack

5958 | NeutUncurriedApp BackendSemantics (Array BackendSemantics)

6059 | NeutUncurriedEffectApp BackendSemantics (Array BackendSemantics)

6160 | NeutPrimOp (BackendOperator BackendSemantics)

6261 | NeutPrimEffect (BackendEffect BackendSemantics)

6362 | NeutPrimUndefined

6463

65−data SemConditional a = SemConditional a (Maybe (SemTry a) -> a)

66−

67−type SemTry a = Tuple (Array (Lazy (SemConditional a))) (Maybe (Lazy a))

64+data SemConditional a = SemConditional (Lazy a) (Lazy a)

6865

6966data BackendExpr

7067 = ExprSyntax BackendAnalysis (BackendSyntax BackendExpr)

7168 | ExprRewrite BackendAnalysis BackendRewrite

72− | ExprBacktrack

7369

7470type LetBindingAssoc a =

7571 { ident :: Maybe Ident

@@ -126,7 +122,6 @@ instance HasAnalysis BackendExpr where

126122 analysisOf = case _ of

127123 ExprSyntax s _ -> s

128124 ExprRewrite s _ -> s

129− ExprBacktrack -> mempty

130125

131126instance HasSyntax BackendExpr where

132127 syntaxOf = case _ of

@@ -169,7 +164,6 @@ newtype Env = Env

169164 , evalExtern :: Env -> Qualified Ident -> Array ExternSpine -> Maybe BackendSemantics

170165 , locals :: Array (LocalBinding BackendSemantics)

171166 , directives :: InlineDirectiveMap

172− , branchTry :: Maybe (SemTry BackendSemantics)

173167 }

174168

175169derive instance Newtype Env _

@@ -201,9 +195,6 @@ addStop (Env env) ref acc = Env env

201195 env.directives

202196 }

203197

204−withBranchTry :: Env -> Maybe (SemTry BackendSemantics) -> Env

205−withBranchTry (Env env) branchTry = Env env { branchTry = branchTry }

206−

207198class Eval f where

208199 eval :: Env -> f -> BackendSemantics

209200

@@ -265,17 +256,8 @@ instance Eval f => Eval (BackendSyntax f) where

265256 evalAccessor env (eval env lhs) accessor

266257 Update lhs updates ->

267258 evalUpdate env (eval env lhs) (map (eval env) <$> updates)

268− Branch branches def -> do

269− let conds1 = evalPair env <$> branches

270− case def of

271− Just def' ->

272− evalBranches env conds1 (Just (defer \_ -> eval env def'))

273− Nothing ->

274− case (unwrap env).branchTry of

275− Nothing ->

276− evalBranches env conds1 Nothing

277− Just (Tuple conds2 def') ->

278− evalBranches env (NonEmptyArray.appendArray conds1 conds2) def'

259+ Branch branches def ->

260+ evalBranches env (evalPair env <$> branches) (defer \_ -> eval env def)

279261 PrimOp op ->

280262 evalPrimOp env (eval env <$> op)

281263 PrimEffect eff ->

@@ -358,9 +340,9 @@ instance Eval BackendExpr where

358340 []

359341 RewriteDistBranchesLet _ _ branches def body ->

360342 rewriteBranches (flip eval body <<< bindLocal env <<< One)

361− $ evalBranches env (evalPair env <$> branches) (Just (defer \_ -> eval env def))

343+ $ evalBranches env (evalPair env <$> branches) (defer \_ -> eval env def)

362344 RewriteDistBranchesOp branches def op ->

363− rewriteBranches dist $ evalBranches env (evalPair env <$> branches) (Just (defer \_ -> eval env def))

345+ rewriteBranches dist $ evalBranches env (evalPair env <$> branches) (defer \_ -> eval env def)

364346 where

365347 dist = case op of

366348 DistApp spine ->

@@ -377,8 +359,6 @@ instance Eval BackendExpr where

377359 evalPrimOp env <<< Op2 op2 (eval env lhs)

378360 ExprSyntax _ expr ->

379361 eval env expr

380− ExprBacktrack ->

381− NeutBacktrack

382362

383363instance Eval NeutralExpr where

384364 eval env (NeutralExpr a) = eval env a

@@ -536,31 +516,26 @@ evalUpdate initEnv initLhs props =

536516 _ ->

537517 NeutUpdate lhs props

538518

539−evalBranches :: Env -> NonEmptyArray (Lazy (SemConditional BackendSemantics)) -> Maybe (Lazy BackendSemantics) -> BackendSemantics

519+evalBranches :: Env -> NonEmptyArray (SemConditional BackendSemantics) -> Lazy BackendSemantics -> BackendSemantics

540520evalBranches _ initConds initDef = go [] (NonEmptyArray.toArray initConds) initDef

541521 where

542522 go acc conds def = case Array.uncons conds of

543523 Just { head, tail } ->

544− case force head of

545− SemConditional (NeutLit (LitBoolean didMatch)) k ->

546− if didMatch then

547− go acc [] (Just (defer \_ -> k (Just (Tuple tail def))))

548− else

549− go acc tail def

550− SemConditional (NeutFail err) _ ->

551− go acc [] (Just (defer \_ -> NeutFail err))

552− _ ->

553− go (Array.snoc acc head) tail def

524+ case head of

525+ SemConditional c t -> case force c of

526+ NeutLit (LitBoolean didMatch)

527+ | didMatch -> go acc [] t

528+ | otherwise -> go acc tail def

529+ NeutFail err ->

530+ go acc [] (defer \_ -> NeutFail err)

531+ _ ->

532+ go (Array.snoc acc head) tail def

554533 Nothing ->

555534 case NonEmptyArray.fromArray acc of

556535 Just bs ->

557536 SemBranch bs def

558537 Nothing ->

559− case def of

560− Just sem ->

561− force sem

562− Nothing ->

563− NeutBacktrack

538+ force def

564539

565540rewriteBranches :: (BackendSemantics -> BackendSemantics) -> BackendSemantics -> BackendSemantics

566541rewriteBranches k = go

@@ -571,12 +546,12 @@ rewriteBranches k = go

571546 SemLetRec a b ->

572547 SemLetRec a (go <$> b)

573548 SemBranch bs def ->

574− SemBranch (map (\(SemConditional a b) -> SemConditional a (go <$> b)) <$> bs) (map go <$> def)

549+ SemBranch ((\(SemConditional a b) -> SemConditional a (go <$> b)) <$> bs) (go <$> def)

575550 sem ->

576551 k sem

577552

578−evalPair :: forall f. Eval f => Env -> Pair f -> Lazy (SemConditional BackendSemantics)

579−evalPair env (Pair a b) = defer \_ -> SemConditional (eval env a) (flip eval b <<< withBranchTry env)

553+evalPair :: forall f. Eval f => Env -> Pair f -> SemConditional BackendSemantics

554+evalPair env (Pair a b) = SemConditional (defer \_ -> eval env a) (defer \_ -> eval env b)

580555

581556evalAssocLet :: Env -> BackendSemantics -> (Env -> BackendSemantics -> BackendSemantics) -> BackendSemantics

582557evalAssocLet env sem go = case sem of

@@ -1076,9 +1051,9 @@ quote = go

10761051 build ctx $ EffectDefer (quote (ctx { effect = true }) sem)

10771052 SemBranch branches def -> do

10781053 let ctx' = ctx { effect = false }

1079− let quoteCond (SemConditional a k) = buildPair ctx' (quote ctx' a) (quote ctx (k Nothing))

1080− let branches' = quoteCond <<< force <$> branches

1081− fromMaybe ExprBacktrack $ foldr (buildBranchCond ctx) (quote ctx <<< force <$> def) branches'

1054+ let quoteCond (SemConditional a b) = Pair (quote ctx' $ force a) (quote ctx $ force b)

1055+ let branches' = quoteCond <$> branches

1056+ foldr (buildBranchCond ctx) (quote ctx <<< force $ def) branches'

10821057

10831058 -- Non-block constructors

10841059 SemExtern _ _ sem ->

@@ -1146,8 +1121,6 @@ quote = go

11461121 build ctx PrimUndefined

11471122 NeutFail err ->

11481123 build ctx $ Fail err

1149− NeutBacktrack ->

1150− ExprBacktrack

11511124

11521125build :: Ctx -> BackendSyntax BackendExpr -> BackendExpr

11531126build ctx = case _ of

@@ -1186,22 +1159,22 @@ build ctx = case _ of

11861159 Let _ level binding body

11871160 | Just expr' <- shouldEtaReduce level binding body ->

11881161 expr'

1189− App (ExprSyntax analysis (Branch bs (Just def))) tl

1162+ App (ExprSyntax analysis (Branch bs def)) tl

11901163 | Just expr' <- shouldDistributeBranchApps analysis bs def tl ->

11911164 expr'

1192− UncurriedApp (ExprSyntax analysis (Branch bs (Just def))) tl

1165+ UncurriedApp (ExprSyntax analysis (Branch bs def)) tl

11931166 | Just expr' <- shouldDistributeBranchUncurriedApps analysis bs def tl ->

11941167 expr'

1195− Accessor (ExprSyntax analysis (Branch bs (Just def))) acc

1168+ Accessor (ExprSyntax analysis (Branch bs def)) acc

11961169 | Just expr' <- shouldDistributeBranchAccessor analysis bs def acc ->

11971170 expr'

1198− PrimOp (Op1 op1 (ExprSyntax analysis (Branch bs (Just def))))

1171+ PrimOp (Op1 op1 (ExprSyntax analysis (Branch bs def)))

11991172 | Just expr' <- shouldDistributeBranchPrimOp1 analysis bs def op1 ->

12001173 expr'

1201− PrimOp (Op2 op2 (ExprSyntax analysis (Branch bs (Just def))) rhs)

1174+ PrimOp (Op2 op2 (ExprSyntax analysis (Branch bs def)) rhs)

12021175 | Just expr' <- shouldDistributeBranchPrimOp2L analysis bs def op2 rhs ->

12031176 expr'

1204− PrimOp (Op2 op2 lhs (ExprSyntax analysis (Branch bs (Just def))))

1177+ PrimOp (Op2 op2 lhs (ExprSyntax analysis (Branch bs def)))

12051178 | Just expr' <- shouldDistributeBranchPrimOp2R analysis bs def lhs op2 ->

12061179 expr'

12071180 expr@(EffectBind ident1 level1 (ExprSyntax _ (EffectBind ident2 level2 binding2 body2)) body1) ->

@@ -1237,41 +1210,31 @@ build ctx = case _ of

12371210 binding

12381211 EffectDefer expr@(ExprSyntax _ (EffectDefer _)) ->

12391212 expr

1240− Branch pairs (Just def) | Just expr <- simplifyBranches ctx pairs def ->

1213+ Branch pairs def | Just expr <- simplifyBranches ctx pairs def ->

12411214 expr

12421215 PrimOp (Op1 OpBooleanNot (ExprSyntax _ (PrimOp (Op1 OpBooleanNot expr)))) ->

12431216 expr

12441217 expr ->

12451218 buildDefault ctx expr

12461219

1247−buildPair :: Ctx -> BackendExpr -> BackendExpr -> Pair BackendExpr

1248−buildPair ctx p1 = case _ of

1249− ExprSyntax _ (Branch bs Nothing)

1250− | [ Pair p2 b ] <- NonEmptyArray.toArray bs ->

1251− Pair (build ctx $ PrimOp (Op2 OpBooleanAnd p1 p2)) b

1252− p2 ->

1253− Pair p1 p2

1254−

1255−buildBranchCond :: Ctx -> Pair BackendExpr -> Maybe BackendExpr -> Maybe BackendExpr

1220+buildBranchCond :: Ctx -> Pair BackendExpr -> BackendExpr -> BackendExpr

12561221buildBranchCond ctx (Pair a b) c = case b of

12571222 ExprSyntax _ (Lit (LitBoolean true))

1258− | Just (ExprSyntax _ (Lit (LitBoolean true))) <- c ->

1223+ | ExprSyntax _ (Lit (LitBoolean true)) <- c ->

12591224 c

1260− | Just (ExprSyntax _ (Lit (LitBoolean false))) <- c ->

1261− Just a

1262− | Just x@(ExprSyntax _ x') <- c, isBooleanTail x' ->

1263− Just $ build ctx (PrimOp (Op2 OpBooleanOr a x))

1225+ | ExprSyntax _ (Lit (LitBoolean false)) <- c ->

1226+ a

1227+ | ExprSyntax _ x <- c, isBooleanTail x ->

1228+ build ctx (PrimOp (Op2 OpBooleanOr a c))

12641229 ExprSyntax _ (Lit (LitBoolean false))

1265− | Just (ExprSyntax _ (Lit (LitBoolean false))) <- c ->

1230+ | ExprSyntax _ (Lit (LitBoolean false)) <- c ->

12661231 c

12671232 | ExprSyntax _ (PrimOp (Op1 (OpIsTag _) (ExprSyntax _ x1))) <- a

1268− , Just (ExprSyntax _ (PrimOp (Op1 (OpIsTag _) (ExprSyntax _ x2)))) <- c

1233+ , ExprSyntax _ (PrimOp (Op1 (OpIsTag _) (ExprSyntax _ x2))) <- c

12691234 , isSameVariable x1 x2 ->

12701235 c

1271− ExprBacktrack ->

1272− c

12731236 _ ->

1274− Just $ build ctx (Branch (NonEmptyArray.singleton (Pair a b)) c)

1237+ build ctx (Branch (NonEmptyArray.singleton (Pair a b)) c)

12751238 where

12761239 isSameVariable = case _, _ of

12771240 Local _ l, Local _ r -> l == r

@@ -1300,7 +1263,7 @@ simplifyBranches ctx pairs def = case NonEmptyArray.toArray pairs of

13001263 , Pair (ExprSyntax _ (PrimOp (Op1 OpBooleanNot (ExprSyntax _ (Local _ lvl2))))) body2 <- b

13011264 , ExprSyntax _ (Fail _) <- def

13021265 , lvl1 == lvl2 ->

1303− Just $ build ctx $ Branch (NonEmptyArray.singleton (Pair expr1 body1)) (Just body2)

1266+ Just $ build ctx $ Branch (NonEmptyArray.singleton (Pair expr1 body1)) body2

13041267 _

13051268 | ExprSyntax _ (Branch pairs2 def2) <- def ->

13061269 Just $ build ctx (Branch (pairs <> pairs2) def2)

@@ -1391,7 +1354,7 @@ shouldDistributeBranches :: Maybe Ident -> Level -> BackendExpr -> BackendExpr -

13911354shouldDistributeBranches ident level a body = do

13921355 let BackendAnalysis s2 = analysisOf body

13931356 case a of

1394− ExprSyntax (BackendAnalysis s1) (Branch branches (Just def))

1357+ ExprSyntax (BackendAnalysis s1) (Branch branches def)

13951358 | s2.size <= 128

13961359 , s1.result == KnownNeutral

13971360 , Just (Usage us) <- Map.lookup level s2.usages

@@ -1608,9 +1571,9 @@ freeze init = Tuple (analysisOf init) (go init)

16081571 UnpackData qual ct ty tag values ->

16091572 NeutralExpr $ Let ident level (NeutralExpr (CtorSaturated qual ct ty tag (map go <$> values))) (go body)

16101573 RewriteDistBranchesLet ident level branches def body ->

1611− NeutralExpr $ Let ident level (NeutralExpr (Branch (map go <$> branches) (Just (go def)))) (go body)

1574+ NeutralExpr $ Let ident level (NeutralExpr (Branch (map go <$> branches) (go def))) (go body)

16121575 RewriteDistBranchesOp branches def op -> do

1613− let branches' = NeutralExpr $ Branch (map go <$> branches) (Just (go def))

1576+ let branches' = NeutralExpr $ Branch (map go <$> branches) (go def)

16141577 case op of

16151578 DistApp spine ->

16161579 NeutralExpr $ App branches' (go <$> spine)

@@ -1624,8 +1587,6 @@ freeze init = Tuple (analysisOf init) (go init)

16241587 NeutralExpr $ PrimOp $ Op2 op2 branches' (go rhs)

16251588 DistPrimOp2R lhs op2 ->

16261589 NeutralExpr $ PrimOp $ Op2 op2 (go lhs) branches'

1627− ExprBacktrack ->

1628− NeutralExpr $ Fail "Failed pattern match"

16291590

16301591evalMkFn :: Env -> Int -> BackendSemantics -> MkFn BackendSemantics

16311592evalMkFn env n sem

src/PureScript/Backend/Optimizer/Syntax.purs+3−3

@@ -28,7 +28,7 @@ data BackendSyntax a

2828 | EffectBind (Maybe Ident) Level a a

2929 | EffectPure a

3030 | EffectDefer a

31− | Branch (NonEmptyArray (Pair a)) (Maybe a)

31+ | Branch (NonEmptyArray (Pair a)) a

3232 | PrimOp (BackendOperator a)

3333 | PrimEffect (BackendEffect a)

3434 | PrimUndefined

@@ -144,7 +144,7 @@ instance Foldable BackendSyntax where

144144 EffectBind _ _ b c -> f b <> f c

145145 EffectPure a -> f a

146146 EffectDefer a -> f a

147− Branch as b -> foldMap (foldMap f) as <> foldMap f b

147+ Branch as b -> foldMap (foldMap f) as <> f b

148148 PrimOp a -> foldMap f a

149149 PrimEffect a -> foldMap f a

150150 PrimUndefined -> mempty

@@ -199,7 +199,7 @@ instance Traversable BackendSyntax where

199199 EffectDefer a ->

200200 EffectDefer <$> f a

201201 Branch as b ->

202− Branch <$> traverse (traverse f) as <*> traverse f b

202+ Branch <$> traverse (traverse f) as <*> f b

203203 PrimOp a ->

204204 PrimOp <$> traverse f a

205205 PrimEffect a ->