Use blackholing

Author: effectfully

plutus-core/index-envs/src/Data/RandomAccessList/SkewBinary.hs

@@ -8,6 +8,7 @@
 module Data.RandomAccessList.SkewBinary
     ( RAList(Cons,Nil)
     , contIndexZero
+    , contUpdateZero
     , contIndexOne
     , safeIndexZero
     , unsafeIndexZero
@@ -116,6 +117,30 @@ contIndexZero z f = findTree where
            else indexTree halfSize (offset - 1 - halfSize) t2
 {-# INLINE contIndexZero #-}
 
+-- See Note [Optimizations of contUpdateZero].
+contUpdateZero :: forall a. (a -> a) -> RAList a -> Word64 -> RAList a
+contUpdateZero f = findTree where
+    findTree :: RAList a -> Word64 -> RAList a
+    -- See Note [Optimizations of contUpdateZero].
+    findTree Nil !_ = error "out of bounds"
+    findTree (BHead w t ts) i =
+        if i < w
+        then BHead w (indexTree w i t) ts
+        else BHead w t (findTree ts (i-w))
+
+    indexTree :: Word64 -> Word64 -> Tree a -> Tree a
+    -- See Note [Optimizations of contUpdateZero].
+    indexTree !w 0 t = case t of
+        Node x l r -> Node (f x) l r
+        Leaf x     -> if w == 1 then Leaf (f x) else error "out of bounds"
+    indexTree _ _ (Leaf _) = error "out of bounds"
+    indexTree treeSize offset (Node x t1 t2) =
+        let halfSize = unsafeShiftR treeSize 1 -- probably faster than `div w 2`
+        in if offset <= halfSize
+           then Node x (indexTree halfSize (offset - 1) t1) t2
+           else Node x t1 (indexTree halfSize (offset - 1 - halfSize) t2)
+{-# INLINE contUpdateZero #-}
+
 contIndexOne :: forall a b. b -> (a -> b) -> RAList a -> Word64 -> b
 contIndexOne z _ _ 0 = z
 contIndexOne z f t n = contIndexZero z f t (n - 1)

plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs

@@ -244,6 +244,7 @@ data CekValue uni fun ann =
       -- Check the docs of 'BuiltinRuntime' for details.
     -- | A constructor value, including fully computed arguments and the tag.
   | VConstr {-# UNPACK #-} !Word64 !(ArgStack uni fun ann)
+  | VBlackHole !Text !Word64
 
 deriving stock instance (GShow uni, Everywhere uni Show, Show fun, Show ann, Closed uni)
     => Show (CekValue uni fun ann)
@@ -492,7 +493,10 @@ dischargeCekValEnv valEnv = go 0
                -- var is free, leave it alone
                var
                -- var is in the env, discharge its value
-               dischargeCekValue
+               (\case
+                   VBlackHole recName recLamCnt ->
+                       Var () (NamedDeBruijn recName . coerce $ lamCnt - recLamCnt)
+                   val -> dischargeCekValue val)
                -- index relative to (as seen from the point of view of) the environment
                (Env.indexOne valEnv $ idx - lamCnt)
     Apply ann fun arg    -> Apply ann (go lamCnt fun) $ go lamCnt arg
@@ -521,6 +525,7 @@ dischargeCekValue = \case
         stack2list = go []
         go acc EmptyStack           = acc
         go acc (ConsStack arg rest) = go (arg : acc) rest
+    VBlackHole _ _ -> error "can't happen"
 
 instance (PrettyUni uni, Pretty fun) => PrettyBy PrettyConfigPlc (CekValue uni fun ann) where
     prettyBy cfg = prettyBy cfg . dischargeCekValue
@@ -555,7 +560,7 @@ data Context uni fun ann
     -- ^ @(constr i V0 ... Vj-1 _ Nj ... Nn)@
     | FrameCases !(CekValEnv uni fun ann) !(V.Vector (NTerm uni fun ann)) !(Context uni fun ann)
     -- ^ @(case _ C0 .. Cn)@
-    | FrameFix !(Context uni fun ann)
+    | FrameFix {-# UNPACK #-} !Word64 !(Context uni fun ann)
     | NoFrame
 
 deriving stock instance (GShow uni, Everywhere uni Show, Show fun, Show ann, Closed uni)
@@ -564,11 +569,12 @@ deriving stock instance (GShow uni, Everywhere uni Show, Show fun, Show ann, Clo
 -- See Note [ExMemoryUsage instances for non-constants].
 instance (Closed uni, uni `Everywhere` ExMemoryUsage) => ExMemoryUsage (CekValue uni fun ann) where
     memoryUsage = \case
-        VCon c      -> memoryUsage c
-        VDelay {}   -> singletonRose 1
-        VLamAbs {}  -> singletonRose 1
-        VBuiltin {} -> singletonRose 1
-        VConstr {}  -> singletonRose 1
+        VCon c        -> memoryUsage c
+        VDelay {}     -> singletonRose 1
+        VLamAbs {}    -> singletonRose 1
+        VBuiltin {}   -> singletonRose 1
+        VConstr {}    -> singletonRose 1
+        VBlackHole {} -> singletonRose 1
     {-# INLINE memoryUsage #-}
 
 {- Note [ArgStack vs Spine]
@@ -687,9 +693,10 @@ enterComputeCek = computeCek
     computeCek !ctx !env (Case _ scrut cs) = do
         stepAndMaybeSpend BCase
         computeCek (FrameCases env cs ctx) env scrut
-    computeCek !ctx !env (Fix _ _ body) = do
+    computeCek !ctx !env (Fix _ rec body) = do
         stepAndMaybeSpend BFix
-        computeCek (FrameFix ctx) env body
+        let !len' = Env.length env + 1
+        computeCek (FrameFix len' ctx) (Env.cons (VBlackHole (ndbnString rec) len') env) body
     -- s ; ρ ▻ error  ↦  <> A
     computeCek !_ !_ (Error _) =
         throwing_ _EvaluationFailure
@@ -743,12 +750,12 @@ enterComputeCek = computeCek
             Just t  -> computeCek (transferArgStack args ctx) env t
             Nothing -> throwingDischarged _MachineError (MissingCaseBranch i) e
         _ -> throwingDischarged _MachineError NonConstrScrutinized e
-    returnCek (FrameFix ctx) bodyV =
+    returnCek (FrameFix recIx ctx) bodyV =
         case bodyV of
-            VLamAbs nameArg bodyLam env ->
-                let env' = Env.cons bodyV' env
+            VLamAbs nameArg bodyLam env -> do
+                let env' = Env.contUpdateZero (\_ -> bodyV') env (Env.length env - recIx)
                     bodyV' = VLamAbs nameArg bodyLam env'
-                in returnCek ctx bodyV'
+                returnCek ctx bodyV'
             _ -> throwingDischarged _MachineError NonLambdaFixedMachineError bodyV
 
     -- | Evaluate a 'HeadSpine' by pushing the arguments (if any) onto the stack and proceeding with