From 20a73588a20c6d6699014817852ee9615a39103b Mon Sep 17 00:00:00 2001
From: Kosyrev Serge <serge.kosyrev@iohk.io>
Date: Thu, 6 May 2021 13:05:37 +0300
Subject: [PATCH] CAD-2907 ouroboros-consensus-shelley:  prevent GHC floating
 the stub closure

---
 .../ouroboros-consensus-shelley.cabal         |  1 +
 .../Consensus/Shelley/Ledger/Ledger.hs        | 34 +++++++++++++------
 2 files changed, 25 insertions(+), 10 deletions(-)

diff --git a/ouroboros-consensus-shelley/ouroboros-consensus-shelley.cabal b/ouroboros-consensus-shelley/ouroboros-consensus-shelley.cabal
index 5fec9a63ba3..d444015daaf 100644
--- 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
index 6ac0fa5c443..dfb23e3336f 100644
--- 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)