GHC produces Core with an infinite <<loop>> v3

Summary

This feels like deja vu. 😄 Every two years I report a very similar bug. Last one was fixed in ghc-8.10.2 while this one is reproducible with: ghc-8.10.7, ghc-9.0. and ghc-9.2.4 (haven't tried the HEAD). Maybe third time is the charm. Considering that all of them where discovered on totally different projects, I am feeling pretty lucky.

Here are the prior bugs, in case that they are in fact related:

• #17151 (closed)
• #13429 (closed)

A specific relation of type families and type classes causes GHC to generate code that will either:

• crash with <<loop>> or actually never terminate when compiled with optimizations
• die with OOM (Out Of Memory) when compiled with -O0

Steps to reproduce

Compile this snippet and run it:

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Main (main) where

import Data.Kind

newtype Decoder a = Decoder (String -> a)

class Monoid (Share a) => From a where
  type Share a :: Type

  decoderWithShare :: Share a -> Decoder a

decode :: From a => String -> a
decode str =
  case decoderWithShare mempty of
    Decoder f -> f str

class (Ord (Currency e), From (Tx e)) => Ledger e where
--class Ord (Currency e) => Ledger e where
  type Currency e :: Type
  type Tx e :: Type

data MyLedger c

newtype MyTx c = MyTx
  { currency :: c
  } deriving (Show, Read)

instance (Read c, Ord c) => Ledger (MyLedger c) where
  type Currency (MyLedger c) = c
  type Tx (MyLedger c) = MyTx c

instance (Read c, Ledger (MyLedger c)) => From (MyTx c) where
  type Share (MyTx c) = [c]
  decoderWithShare s =
    Decoder $ \str ->
      let c = read str
      in MyTx $ if elem c s then c else c

main :: IO ()
main = print (decode (show (currency (MyTx "USD"))) :: MyTx String)

When compiled with optimizations it results in <<loop>>

$ ghc loop.hs -fforce-recomp -O && ./loop
[1 of 1] Compiling Main             ( loop.hs, loop.o )
Linking loop ...
loop: <<loop>>

while without optimizations will not terminate and crash the process with OOM:

$ ghc loop.hs -fforce-recomp && ./loop
[1 of 1] Compiling Main             ( loop.hs, loop.o )
Linking loop ...
^C

I'd also like to note a few points:

• This is the minimal example I could come up with, the original is way too complex to be included
• Type families do not have to be associated
• In the codebase where the bug was discovered:
  • It actually goes into infinite loop, i.e. no <<loop>> detection.
  • It was necessary for the constraint to be present as well for the bug to trigger: Share (Tx e) ~ [Currency e]:

class (Ord (Currency e), From (Tx e), Share (Tx e) ~ [Currency e]) => Ledger e where

Expected behavior

Regardless of ghc flags the expected output should be:

$ ghc loop.hs -fforce-recomp -O && ./loop
[1 of 1] Compiling Main             ( loop.hs, loop.o )
Linking loop ...
MyTx {currency = "USD"}

Which can be observed when commented out line is used instead of the one that triggers the bug:

-class (Ord (Currency e), From (Tx e)) => Ledger e where
+class Ord (Currency e) => Ledger e where

Above adjustment will cause the bug to disappear. Other minor changes can have the same affect, so this bug is a bit sensitive.

At a quick glance this seems to be the part of Core that is the offender here: https://github.com/lehins/bugs/blob/master/haskell/ghc-infinite-loop/minimal/loop-O1.dump-simpl#L100-L132 Although I am pretty far from being a Core expert, so I might be totally wrong.

Environment

• GHC version used: 8.10.7, 9.0.2 and 9.2.4

Optional:

• Operating System: NixOS and OpenSUSE
• System Architecture: x86_64