CAD-2907 ouroboros-consensus-shelley: prevent GHC floating the stub c…

…losure
IntersectMBO · May 28, 2021 · 2b6721c · 2b6721c
1 parent 41666f4
commit 2b6721c
Show file tree

Hide file tree

Showing 2 changed files with 25 additions and 10 deletions.
diff --git a/ouroboros-consensus-shelley/ouroboros-consensus-shelley.cabal b/ouroboros-consensus-shelley/ouroboros-consensus-shelley.cabal
@@ -60,6 +60,7 @@ library
                      , containers        >=0.5   && <0.7
                      , deepseq
                      , data-default-class
+                     , ghc-prim
                      , mtl               >=2.2   && <2.3
                      , nothunks
                      , serialise         >=0.2   && <0.3

diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs
@@ -5,6 +5,7 @@
 {-# LANGUAGE DisambiguateRecordFields   #-}
 {-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MagicHash                  #-}
 {-# LANGUAGE MultiParamTypeClasses      #-}
 {-# LANGUAGE MultiWayIf                 #-}
 {-# LANGUAGE NamedFieldPuns             #-}
@@ -41,6 +42,9 @@ module Ouroboros.Consensus.Shelley.Ledger.Ledger (
   , encodeShelleyLedgerState
   ) where
 
+import           GHC.Prim
+import           GHC.Types (Int(I#))
+
 import           Codec.CBOR.Decoding (Decoder)
 import qualified Codec.CBOR.Decoding as CBOR
 import           Codec.CBOR.Encoding (Encoding)
@@ -290,17 +294,27 @@ instance ShelleyBasedEra era
   --    - 'updateChainDepState': executes the @PRTCL@ transition
   -- + 'applyLedgerBlock': executes the @BBODY@ transition
   --
-  applyLedgerBlock =
-      seq (stubComputation stubComputationArg) $
-      applyHelper $
+  applyLedgerBlock x y z =
+      seq (stubComputation (stubComputationArg
+                             + I# (reallyUnsafePtrEquality# x x)
+                             + I# (reallyUnsafePtrEquality# y y)
+                             + I# (reallyUnsafePtrEquality# z z))) $
+      applyHelper
         -- Apply the BBODY transition using the ticked state
-        withExcept BBodyError ..: SL.applyBlock
-
-  reapplyLedgerBlock = runIdentity ...:
-      seq (stubComputation stubComputationArg) $
-      applyHelper $
-        -- Reapply the BBODY transition using the ticked state
-        Identity ..: SL.reapplyBlock
+        (withExcept BBodyError ..: SL.applyBlock)
+        x y z
+
+  reapplyLedgerBlock x y z =
+    ((seq (stubComputation (stubComputationArg
+                             + I# (reallyUnsafePtrEquality# x x)
+                             + I# (reallyUnsafePtrEquality# y y)
+                             + I# (reallyUnsafePtrEquality# z z)))
+      .
+      runIdentity) ...:
+      applyHelper)
+         -- Reapply the BBODY transition using the ticked state
+         (Identity ..: SL.reapplyBlock)
+         x y z
 
 applyHelper ::
      (ShelleyBasedEra era, Monad m)