Skip to content
GitLab
Projects Groups Topics Snippets
  • /
  • Help
    • Help
    • Support
    • Community forum
    • Submit feedback
  • Register
  • Sign in
  • GHC GHC
  • Project information
    • Project information
    • Activity
    • Labels
    • Members
  • Repository
    • Repository
    • Files
    • Commits
    • Branches
    • Tags
    • Contributor statistics
    • Graph
    • Compare revisions
    • Locked files
  • Issues 5.5k
    • Issues 5.5k
    • List
    • Boards
    • Service Desk
    • Milestones
    • Iterations
  • Merge requests 623
    • Merge requests 623
  • CI/CD
    • CI/CD
    • Pipelines
    • Jobs
    • Artifacts
    • Schedules
    • Test cases
  • Deployments
    • Deployments
    • Releases
  • Analytics
    • Analytics
    • CI/CD
    • Code review
    • Insights
    • Issue
    • Repository
  • Wiki
    • Wiki
  • Snippets
    • Snippets
  • Activity
  • Graph
  • Create a new issue
  • Jobs
  • Commits
  • Issue Boards
Collapse sidebar
  • Glasgow Haskell CompilerGlasgow Haskell Compiler
  • GHCGHC
  • Issues
  • #21689
Closed
Open
Issue created Jun 02, 2022 by Ryan Scott@RyanGlScottMaintainer

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" [] Prefix

To 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
To upload designs, you'll need to enable LFS and have an admin enable hashed storage. More information
Assignee
Assign to
Time tracking