Skip to content

Commit

Permalink
Avoid ghc bug that causes an infinite loop
Browse files Browse the repository at this point in the history
A more restricitve constraint with a redundant associated type family
constraint causes GHC to generate code that goes into an infinite loop.
This depicts iteslf in an OOM when compiled with `-O0` and non
terminating computaton when compiled with optimizations.

Here is the bug report on the GHC issue tracker:
https://gitlab.haskell.org/ghc/ghc/-/issues/21973
  • Loading branch information
lehins committed Aug 6, 2022
1 parent b8a3ea8 commit 01a43be
Show file tree
Hide file tree
Showing 2 changed files with 15 additions and 9 deletions.
17 changes: 10 additions & 7 deletions eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody.hs
Original file line number Diff line number Diff line change
Expand Up @@ -123,9 +123,9 @@ import Cardano.Ledger.ShelleyMA.Timelocks (ValidityInterval (..))
import Cardano.Ledger.ShelleyMA.TxBody (ShelleyMAEraTxBody (..))
import Cardano.Ledger.TxIn (TxIn (..))
import Cardano.Ledger.Val
( Val (..),
( DecodeNonNegative (decodeNonNegative),
Val (..),
decodeMint,
decodeNonNegative,
encodeMint,
isZero,
)
Expand Down Expand Up @@ -277,7 +277,7 @@ encodeDataHash32 dataHash = do
_ -> Nothing

viewCompactTxOut ::
EraTxOut era =>
(Era era, Val (Value era)) =>
AlonzoTxOut era ->
(CompactAddr (Crypto era), CompactForm (Value era), StrictMaybe (DataHash (Crypto era)))
viewCompactTxOut txOut = case txOut of
Expand All @@ -294,7 +294,7 @@ viewCompactTxOut txOut = case txOut of
| otherwise -> error addressErrorMsg

viewTxOut ::
EraTxOut era =>
(Era era, Val (Value era)) =>
AlonzoTxOut era ->
(Addr (Crypto era), Value era, StrictMaybe (DataHash (Crypto era)))
viewTxOut (TxOutCompact' bs c) = (addr, val, SNothing)
Expand Down Expand Up @@ -322,7 +322,7 @@ deriving via InspectHeapNamed "AlonzoTxOut" (AlonzoTxOut era) instance NoThunks

pattern AlonzoTxOut ::
forall era.
(EraTxOut era, HasCallStack) =>
(Era era, Val (Value era), HasCallStack) =>
Addr (Crypto era) ->
Value era ->
StrictMaybe (DataHash (Crypto era)) ->
Expand Down Expand Up @@ -683,7 +683,10 @@ instance EraTxOut era => FromCBOR (AlonzoTxOut era) where
fromCBOR = fromNotSharedCBOR
{-# INLINE fromCBOR #-}

instance EraTxOut era => FromSharedCBOR (AlonzoTxOut era) where
instance
(Era era, Val (Value era), DecodeNonNegative (Value era), Show (Value era)) =>
FromSharedCBOR (AlonzoTxOut era)
where
type Share (AlonzoTxOut era) = Interns (Credential 'Staking (Crypto era))
fromSharedCBOR credsInterns = do
lenOrIndef <- decodeListLenOrIndef
Expand Down Expand Up @@ -739,7 +742,7 @@ pattern TxOutCompactDH addr vl dh <-
{-# COMPLETE TxOutCompact, TxOutCompactDH #-}

mkTxOutCompact ::
(EraTxOut era, HasCallStack) =>
(Era era, HasCallStack, Val (Value era)) =>
Addr (Crypto era) ->
CompactAddr (Crypto era) ->
CompactForm (Value era) ->
Expand Down
7 changes: 5 additions & 2 deletions eras/shelley/impl/src/Cardano/Ledger/Shelley/TxBody.hs
Original file line number Diff line number Diff line change
Expand Up @@ -458,7 +458,7 @@ instance EraTxBody era => ToCBOR (TxBody era) where

-- ===============================================================

instance EraTxOut era => ToCBOR (TxOut era) where
instance (Era era, ToCBOR (CompactForm (Value era))) => ToCBOR (TxOut era) where
toCBOR (TxOutCompact addr coin) =
encodeListLen 2
<> toCBOR addr
Expand All @@ -469,7 +469,10 @@ instance EraTxOut era => FromCBOR (TxOut era) where

-- This instance does not do any sharing and is isomorphic to FromCBOR
-- use the weakest constraint necessary
instance (EraTxOut era, DecodeNonNegative (Value era)) => FromSharedCBOR (TxOut era) where
instance
(Era era, Show (Value era), DecodeNonNegative (Value era), Compactible (Value era)) =>
FromSharedCBOR (TxOut era)
where
type Share (TxOut era) = Interns (Credential 'Staking (Crypto era))
fromSharedCBOR _ =
decodeRecordNamed "TxOut" (const 2) $ do
Expand Down

0 comments on commit 01a43be

Please sign in to comment.