GHC HEAD panics (lookupIdSubst) when building fixed-vector-1.2.1.0
(Originally noticed in a head.hackage build here.)
The fixed-vector-1.2.1.0 Hackage library fails to compile with GHC HEAD, but does compile with GHC 9.4, 9.2, and earlier. I have made an attempt to minimize it as much as I could. The panic goes away (AFAICT) if you try to combine all of the relevant code into a single module, but it suffices to split things up into the following two modules:
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module UnboxedAux
( Arity
, Dim
, DimM
, IVector
, Mutable
, MVector
, Vector(..)
, constructVec
, inspectVec
, gfoldl'
, gunfold'
) where
import Control.Monad.ST (ST, runST)
import Data.Coerce (coerce)
import Data.Data (Data)
import Data.Functor.Const (Const(..))
import Data.Kind (Type)
import GHC.TypeLits (KnownNat, Nat, type (+), type (-))
-----
-- Data.Vector.Fixed.Cont
-----
data PeanoNum = Z
| S PeanoNum
type family Peano (n :: Nat) :: PeanoNum where
Peano 0 = 'Z
Peano n = 'S (Peano (n - 1))
type family Fn (n :: PeanoNum) (a :: Type) (b :: Type) where
Fn 'Z a b = b
Fn ('S n) a b = a -> Fn n a b
newtype Fun n a b = Fun { unFun :: Fn n a b }
type family Dim (v :: Type -> Type) :: Nat
class Arity (Dim v) => Vector v a where
construct :: Fun (Peano (Dim v)) a (v a)
inspect :: v a -> Fun (Peano (Dim v)) a b -> b
type Arity n = ( ArityPeano (Peano n)
, KnownNat n
, Peano (n+1) ~ 'S (Peano n)
)
class ArityPeano n where
accum :: (forall k. t ('S k) -> a -> t k)
-> (t 'Z -> b)
-> t n
-> Fun n a b
applyFun :: (forall k. t ('S k) -> (a, t k))
-> t n
-> (CVecPeano n a, t 'Z)
gunfoldF :: (Data a)
=> (forall b x. Data b => c (b -> x) -> c x)
-> T_gunfold c r a n -> c r
newtype T_gunfold c r a n = T_gunfold (c (Fn n a r))
gfoldl' :: forall c v a. (Vector v a, Data a)
=> (forall x y. Data x => c (x -> y) -> x -> c y)
-> (forall x . x -> c x)
-> v a -> c (v a)
gfoldl' f inj v
= inspect v
$ gfoldlF f (inj $ unFun (construct :: Fun (Peano (Dim v)) a (v a)))
gunfold' :: forall con c v a. (Vector v a, Data a)
=> (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r)
-> con -> c (v a)
gunfold' f inj _
= gunfoldF f gun
where
con = construct :: Fun (Peano (Dim v)) a (v a)
gun = T_gunfold (inj $ unFun con) :: T_gunfold c (v a) a (Peano (Dim v))
gfoldlF :: (ArityPeano n, Data a)
=> (forall x y. Data x => c (x -> y) -> x -> c y)
-> c (Fn n a r) -> Fun n a (c r)
gfoldlF f c0 = accum
(\(T_gfoldl c) x -> T_gfoldl (f c x))
(\(T_gfoldl c) -> c)
(T_gfoldl c0)
newtype T_gfoldl c r a n = T_gfoldl (c (Fn n a r))
newtype ContVec n a = ContVec (forall r. Fun (Peano n) a r -> r)
type instance Dim (ContVec n) = n
instance Arity n => Vector (ContVec n) a where
construct = accum
(\(T_mkN f) a -> T_mkN (f . consPeano a))
(\(T_mkN f) -> toContVec $ f (CVecPeano unFun))
(T_mkN id)
inspect (ContVec c) f = c f
{-# INLINE construct #-}
{-# INLINE inspect #-}
newtype T_mkN n_tot a n = T_mkN (CVecPeano n a -> CVecPeano n_tot a)
toContVec :: CVecPeano (Peano n) a -> ContVec n a
toContVec = coerce
newtype CVecPeano n a = CVecPeano (forall r. Fun n a r -> r)
consPeano :: a -> CVecPeano n a -> CVecPeano ('S n) a
consPeano a (CVecPeano cont) = CVecPeano $ \f -> cont $ curryFirst f a
{-# INLINE consPeano #-}
curryFirst :: Fun ('S n) a b -> a -> Fun n a b
curryFirst = coerce
{-# INLINE curryFirst #-}
apply :: Arity n
=> (forall k. t ('S k) -> (a, t k))
-> t (Peano n)
-> ContVec n a
{-# INLINE apply #-}
apply step' z = toContVec $ fst (applyFun step' z)
-----
-- Data.Vector.Fixed.Mutable
-----
type family Mutable (v :: Type -> Type) :: Type -> Type -> Type
type family DimM (v :: Type -> Type -> Type) :: Nat
class (Arity (DimM v)) => MVector v a where
new :: PrimMonad m => m (v (PrimState m) a)
unsafeWrite :: PrimMonad m => v (PrimState m) a -> Int -> a -> m ()
class (Dim v ~ DimM (Mutable v), MVector (Mutable v) a) => IVector v a where
unsafeFreeze :: PrimMonad m => Mutable v (PrimState m) a -> m (v a)
unsafeIndex :: v a -> Int -> a
inspectVec :: forall v a b. (Arity (Dim v), IVector v a) => v a -> Fun (Peano (Dim v)) a b -> b
{-# INLINE inspectVec #-}
inspectVec v
= inspect cv
where
cv :: ContVec (Dim v) a
cv = apply (\(Const i) -> (unsafeIndex v i, Const (i+1)))
(Const 0 :: Const Int (Peano (Dim v)))
constructVec :: forall v a. (Arity (Dim v), IVector v a) => Fun (Peano (Dim v)) a (v a)
{-# INLINE constructVec #-}
constructVec =
accum step
(\(T_new _ st) -> runST $ unsafeFreeze =<< st :: v a)
(T_new 0 new :: T_new v a (Peano (Dim v)))
data T_new v a n = T_new Int (forall s. ST s (Mutable v s a))
step :: (IVector v a) => T_new v a ('S n) -> a -> T_new v a n
step (T_new i st) x = T_new (i+1) $ do
mv <- st
unsafeWrite mv i x
return mv
-----
-- Control.Monad.Primitive
-----
class Monad m => PrimMonad m where
type PrimState m
instance PrimMonad (ST s) where
type PrimState (ST s) = s{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
module Unboxed (Vec, MVec, Unbox) where
import Data.Data (Data(..), Constr, DataType, Fixity(..), mkConstr, mkDataType)
import Data.Typeable (Typeable)
import GHC.TypeLits (Nat)
import UnboxedAux
data family Vec (n :: Nat) a
data family MVec (n :: Nat) s a
class (Arity n, IVector (Vec n) a, MVector (MVec n) a) => Unbox n a
type instance Mutable (Vec n) = MVec n
type instance Dim (Vec n) = n
type instance DimM (MVec n) = n
instance (Unbox n a) => Vector (Vec n) a where
construct = constructVec
inspect = inspectVec
{-# INLINE construct #-}
{-# INLINE inspect #-}
instance (Typeable n, Unbox n a, Data a) => Data (Vec n a) where
gfoldl = gfoldl'
gunfold = gunfold'
toConstr _ = con_Vec
dataTypeOf _ = ty_Vec
ty_Vec :: DataType
ty_Vec = mkDataType "Data.Vector.Fixed.Unboxed.Vec" [con_Vec]
con_Vec :: Constr
con_Vec = mkConstr ty_Vec "Vec" [] PrefixTo reproduce the error, compile Unboxed.hs with optimizations using HEAD:
$ ~/Software/ghc-9.5.20220602/bin/ghc -fforce-recomp -O Unboxed.hs
[1 of 2] Compiling UnboxedAux ( UnboxedAux.hs, UnboxedAux.o )
[2 of 2] Compiling Unboxed ( Unboxed.hs, Unboxed.o )
<no location info>: error:
panic! (the 'impossible' happened)
GHC version 9.5.20220602:
lookupIdSubst
$d(%,,%)_s4JG
InScope {n_a2Be a_a2Bf $dTypeable_a2Bg $dUnbox_a2Bh $dData_a2Bi
$cgfoldl_a2Bo $cgunfold_a2BM c_a2BT $cgmapQl_a2DJ $cgmapQr_a2E3
$cgmapQ_a2Em $cgmapQi_a2EC $cgmapM_a2ES $cgmapMp_a2Fa $cgmapMo_a2Fv
$cp1Vector_a2FS $cconstruct_a2FU $cinspect_a2G9 co_a4bo $krep_a4bW
$krep_a4bX $krep_a4bY $krep_a4bZ $krep_a4c0 $krep_a4c1 eta_i4G9
eta1_i4Gc eta2_i4Ge $fDataVec $fVectorVeca $tcMVec $tcUnbox $tcVec
$trModule ty_Vec con_Vec ty_Vec_s4Jb ty_Vec_s4Jc ty_Vec_s4Jd
$trModule_s4Je $trModule_s4Jf $trModule_s4Jg $trModule_s4Jh
$tcVec_s4Ji $tcVec_s4Jj $cp1Data_s4Jk $tcMVec_s4Jq $tcMVec_s4Jr
$tcUnbox_s4Js $tcUnbox_s4Jt $cgmapT_s4Ju}
Call stack:
CallStack (from HasCallStack):
callStackDoc, called at compiler/GHC/Utils/Panic.hs:182:37 in ghc:GHC.Utils.Panic
pprPanic, called at compiler/GHC/Core/Subst.hs:260:17 in ghc:GHC.Core.Subst
Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug