tmp. I don't believe the stats I am getting...

hackworthltd · Jul 25, 2023 · 025ceb9 · 025ceb9
1 parent 842abef
commit 025ceb9
Show file tree

Hide file tree

Showing 2 changed files with 13 additions and 7 deletions.
diff --git 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,15 +1131,15 @@ 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)
     addLet (LetrecBind v t ty) b = letrec v (regenerateExprIDs t) (regenerateTypeIDs ty) (pure b)
     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
@@ -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.