diff --git a/primer/src/Primer/Eval/Redex.hs b/primer/src/Primer/Eval/Redex.hs index 33f84275d..8a32a6efb 100644 --- a/primer/src/Primer/Eval/Redex.hs +++ b/primer/src/Primer/Eval/Redex.hs @@ -176,6 +176,10 @@ import Primer.Zipper.Type ( letTypeBindingName, ) +pushMultiLet = False +pushAndElide = False +agressiveElision = False + data EvalLog = -- | Found something that may have been a case redex, -- but the scrutinee's head is an out-of-scope constructor. @@ -654,12 +658,13 @@ viewRedex tydefs globals dir = \case pure $ InlineGlobal{gvar, def, orig} orig@(viewLets -> Just (bindings, expr)) - | letBinders <- foldMap' (S.singleton . letBindingName . snd) bindings + | if pushMultiLet then True else null (NonEmpty.tail bindings) + , letBinders <- foldMap' (S.singleton . letBindingName . snd) bindings , S.disjoint (getBoundHereDn expr) (letBinders <> setOf (folded % _2 % _freeVarsLetBinding) bindings) , -- prefer to elide if possible - allLetsUsed (fmap snd bindings) expr -> + not agressiveElision || allLetsUsed (fmap snd bindings) expr -> pure $ PushLet{bindings, expr, orig} where -- Fold right-to-left calculating free var set and whether each @@ -798,10 +803,11 @@ viewRedexType :: Type -> Reader Cxt (Maybe RedexType) viewRedexType = \case origTy | Just (bindingsWithID, intoTy) <- viewLetsTy origTy + , if pushMultiLet then True else null (NonEmpty.tail bindingsWithID) , (bindings, bindingIDs) <- NonEmpty.unzip bindingsWithID , letBinders <- foldMap' (S.singleton . letTypeBindingName) bindings , -- prefer to elide if possible - allLetsUsed bindings intoTy + not agressiveElision || allLetsUsed bindings intoTy , S.disjoint (S.map unLocalName $ getBoundHereDnTy intoTy) (letBinders <> setOf (folded % _freeVarsLetTypeBinding) bindings) -> @@ -1125,7 +1131,7 @@ runRedex = \case pure (expr', Primer.Eval.Detail.ApplyPrimFun details) addLets :: MonadFresh ID m => NonEmpty LetBinding -> Expr -> m Expr -addLets ls expr = foldrM addLet expr $ filterLets ls expr +addLets ls expr = foldrM addLet expr $ if pushAndElide then filterLets ls expr else toList ls where addLet :: MonadFresh ID m => LetBinding -> Expr -> m Expr addLet (LetBind v e) b = let_ v (regenerateExprIDs e) (pure b) @@ -1133,7 +1139,7 @@ addLets ls expr = foldrM addLet expr $ filterLets ls expr addLet (LetTyBind (LetTypeBind v ty)) b = letType v (regenerateTypeIDs ty) (pure b) addTLets :: MonadFresh ID m => NonEmpty LetBinding -> Type -> m Type -addTLets ls t = foldrM addTLet t $ filterLetsTy ls t +addTLets ls t = foldrM addTLet t $ if pushAndElide then filterLetsTy ls t else toList ls where addTLet :: MonadFresh ID m => LetBinding -> Type -> m Type -- drop let bindings of term variables diff --git a/primer/test/Tests/EvalFull.hs b/primer/test/Tests/EvalFull.hs index 74423f970..23eda1db6 100644 --- a/primer/test/Tests/EvalFull.hs +++ b/primer/test/Tests/EvalFull.hs @@ -212,7 +212,7 @@ unit_8 = evalFullTest (maxID e) builtinTypes (defMap e) 500 Syn (expr e) >>= \case Left (TimedOut _) -> pure () x -> assertFailure $ show x - s <- evalFullTest (maxID e) builtinTypes (defMap e) 1000 Syn (expr e) + s <- evalFullTest (maxID e) builtinTypes (defMap e) 2000 Syn (expr e) s <~==> Right (expectedResult e) -- A worker/wrapper'd map @@ -233,7 +233,7 @@ unit_9 = evalFullTest maxID builtinTypes (M.fromList globals) 500 Syn e >>= \case Left (TimedOut _) -> pure () x -> assertFailure $ show x - s <- evalFullTest maxID builtinTypes (M.fromList globals) 1000 Syn e + s <- evalFullTest maxID builtinTypes (M.fromList globals) 2000 Syn e s <~==> Right expected -- A case redex must have an scrutinee which is an annotated constructor.