[GHC] #15186: ghc 8.4.2 panic in profiling build

[GHC]

#15186: ghc 8.4.2 panic in profiling build
-------------------------------------+-------------------------------------
        Reporter:  kquick            |                Owner:  (none)
            Type:  bug               |               Status:  new
        Priority:  normal            |            Milestone:
       Component:  Profiling         |              Version:  8.4.2
      Resolution:                    |             Keywords:
Operating System:  Linux             |         Architecture:  x86_64
 Type of failure:  Compile-time      |  (amd64)
  crash or panic                     |            Test Case:
      Blocked By:                    |             Blocking:
 Related Tickets:                    |  Differential Rev(s):
       Wiki Page:                    |
-------------------------------------+-------------------------------------
Changes (by RyanGlScott):

 * component:  Compiler => Profiling


Comment:

 I can trim this down to two modules, at least:

 {{{#!hs
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE ViewPatterns #-}
 module Foo (Ctx, Assignment, pattern EmptyAssn, pattern (:>)) where

 import Data.Kind (Type)
 import Unsafe.Coerce (unsafeCoerce)

 data Ctx k
   = EmptyCtx
   | Ctx k ::> k

 type SingleCtx x = 'EmptyCtx '::> x

 type family (<+>) (x :: Ctx k) (y :: Ctx k) :: Ctx k where
   x <+> 'EmptyCtx = x
   x <+> (y '::> e) = (x <+> y) '::> e

 data Height = Zero | Succ Height

 data BinomialTree (h::Height) (f :: k -> Type) :: Ctx k -> Type where
   Empty :: BinomialTree h f 'EmptyCtx
   PlusOne  :: !Int
            -> !(BinomialTree ('Succ h) f x)
            -> !(BalancedTree h f y)
            -> BinomialTree h f (x <+> y)
   PlusZero  :: !Int
             -> !(BinomialTree ('Succ h) f x)
             -> BinomialTree h f x

 newtype Assignment (f :: k -> *) (ctx :: Ctx k)
   = Assignment (BinomialTree 'Zero f ctx)

 data AssignView f ctx where
   AssignEmpty :: AssignView f 'EmptyCtx
   AssignExtend :: Assignment f ctx
                -> f tp
                -> AssignView f (ctx '::> tp)

 data DropResult f (ctx :: Ctx k) where
   DropEmpty :: DropResult f 'EmptyCtx
   DropExt   :: BinomialTree 'Zero f x
             -> f y
             -> DropResult f (x '::> y)

 data BalancedTree h (f :: k -> Type) (p :: Ctx k) where
   BalLeaf :: !(f x) -> BalancedTree 'Zero f (SingleCtx x)
   BalPair :: !(BalancedTree h f x)
           -> !(BalancedTree h f y)
           -> BalancedTree ('Succ h) f (x <+> y)

 tsize :: BinomialTree h f a -> Int
 tsize Empty = 0
 tsize (PlusOne s _ _) = 2*s+1
 tsize (PlusZero  s _) = 2*s

 bal_drop :: forall h f x y
           . BinomialTree h f x
          -> BalancedTree h f y
          -> DropResult f (x <+> y)
 bal_drop t (BalLeaf e) = DropExt t e
 bal_drop t (BalPair x y) =
   unsafeCoerce (bal_drop (PlusOne (tsize t) (unsafeCoerce t) x) y)

 bin_drop :: forall h f ctx
           . BinomialTree h f ctx
          -> DropResult f ctx
 bin_drop Empty = DropEmpty
 bin_drop (PlusZero _ u) = bin_drop u
 bin_drop (PlusOne s t u) =
   let m = case t of
             Empty -> Empty
             _ -> PlusZero s t
    in bal_drop m u

 viewAssign :: forall f ctx . Assignment f ctx -> AssignView f ctx
 viewAssign (Assignment x) =
   case bin_drop x of
     DropEmpty -> AssignEmpty
     DropExt t v -> AssignExtend (Assignment t) v

 pattern EmptyAssn :: () => ctx ~ 'EmptyCtx => Assignment f ctx
 pattern EmptyAssn <- (viewAssign -> AssignEmpty)

 pattern (:>) :: () => ctx' ~ (ctx '::> tp) => Assignment f ctx -> f tp ->
 Assignment f ctx'
 pattern (:>) a v <- (viewAssign -> AssignExtend a v)

 }}}
 {{{#!hs
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE PatternSynonyms #-}
 module Bar (pattern PointerExpr) where

 import Foo

 -------------------------------------------------------------------------------

 pattern PointerExpr :: Expr tp
 pattern PointerExpr <-
    App (RollRecursive (EmptyAssn :> BVRepr) (App _))

 -------------------------------------------------------------------------------

 data CrucibleType where
   RecursiveType :: Ctx CrucibleType -> CrucibleType

 data TypeRepr (tp :: CrucibleType) where
   BVRepr :: TypeRepr tp
   TypeReprDummy :: TypeRepr tp

 data App (f :: CrucibleType -> *) (tp :: CrucibleType) where
   RollRecursive :: !(Assignment TypeRepr ctx)
                 -> !(Expr tp)
                 -> App f ('RecursiveType ctx)

 data Expr (tp :: CrucibleType)
   = App !(App Expr tp)
   | ExprDummy
 }}}
 {{{
 $ /opt/ghc/8.4.2/bin/ghc -fforce-recomp -prof -fprof-auto -O Bar.hs
 [1 of 2] Compiling Foo              ( Foo.hs, Foo.o )
 [2 of 2] Compiling Bar              ( Bar.hs, Bar.o )
 ghc: panic! (the 'impossible' happened)
   (GHC version 8.4.2 for x86_64-unknown-linux):
         isUnliftedType
   r_a22f :: TYPE rep_a22e
   Call stack:
       CallStack (from HasCallStack):
         callStackDoc, called at compiler/utils/Outputable.hs:1150:37 in
 ghc:Outputable
         pprPanic, called at compiler/types/Type.hs:1939:10 in ghc:Type

 Please report this as a GHC bug:  http://www.haskell.org/ghc/reportabug

 $ /opt/ghc/head/bin/ghc -fforce-recomp -prof -fprof-auto -O Bar.hs
 [1 of 2] Compiling Foo              ( Foo.hs, Foo.o )
 [2 of 2] Compiling Bar              ( Bar.hs, Bar.o )
 ghc: panic! (the 'impossible' happened)
   (GHC version 8.5.20180501 for x86_64-unknown-linux):
         isUnliftedType
   r_a256 :: TYPE rep_a255
   Call stack:
       CallStack (from HasCallStack):
         callStackDoc, called at compiler/utils/Outputable.hs:1162:37 in
 ghc:Outputable
         pprPanic, called at compiler/types/Type.hs:1922:10 in ghc:Type

 Please report this as a GHC bug:  http://www.haskell.org/ghc/reportabug

 }}}

-- 
Ticket URL: <http://ghc.haskell.org/trac/ghc/ticket/15186#comment:1>
GHC <http://www.haskell.org/ghc/>
The Glasgow Haskell Compiler