[GHC] #14393: Levity-polymorphic join point crashes 8.2

[GHC]

#14393: Levity-polymorphic join point crashes 8.2
-------------------------------------+-------------------------------------
        Reporter:  simonpj           |                Owner:  (none)
            Type:  bug               |               Status:  new
        Priority:  normal            |            Milestone:  8.2.2
       Component:  Compiler          |              Version:  8.2.1
      Resolution:                    |             Keywords:
Operating System:  Unknown/Multiple  |         Architecture:
                                     |  Unknown/Multiple
 Type of failure:  None/Unknown      |            Test Case:
      Blocked By:                    |             Blocking:
 Related Tickets:                    |  Differential Rev(s):
       Wiki Page:                    |
-------------------------------------+-------------------------------------
Description changed by simonpj:

Old description:

> This program crashes both GHC 8.0 and 8.2
> {{{
> {-# LANGUAGE ViewPatterns, PatternSynonyms #-}
>
> module Foo where
>
> data PrimOp = AddOp | Add2Op | OtherOp | BotherOp
>
> data Expr = Var PrimOp | App Expr Expr | BApp [Expr] | BOp Expr Expr | L
> Integer
>
> pattern BinOpApp  :: Expr -> PrimOp -> Expr -> Expr
> pattern BinOpApp  x op y =  Var op `App` x `App` y
>
> pattern (:+:) :: Expr -> Expr -> Expr
> pattern x :+: y <- BinOpApp x (isAddOp -> True) y
>
> isAddOp :: PrimOp -> Bool
> isAddOp AddOp  = True
> isAddOp Add2Op  = True
> isAddOp _      = False
>
> pattern (:++:) :: Integer -> Expr -> Expr
> pattern l :++: x <- (isAdd -> Just (l,x))
>
> isAdd :: Expr -> Maybe (Integer,Expr)
> {-# INLINE isAdd #-}
> isAdd e = case e of
>    L l :+: x   -> Just (l,x)
>    x   :+: L l -> Just (l,x)
>    _           -> Nothing
> }}}
> Reason: the matching function, generated by the pattern synonym `:++:`,
> has a levity-polymorphic join point.
>
> 8.0 has a Lint Error.  8.2 crashes with
> {{{
>   (GHC version 8.2.1.20171024 for x86_64-unknown-linux):
>         runtimeRepPrimRep
>   typePrimRep (r_a1kX :: TYPE rep_a1kW)
>   rep_a1kW
>   Call stack:
>       CallStack (from HasCallStack):
>         prettyCurrentCallStack, called at
> compiler/utils/Outputable.hs:1133:58 in ghc:Outputable
>         callStackDoc, called at compiler/utils/Outputable.hs:1137:37 in
> ghc:Outputable
>         pprPanic, called at compiler/simplStg/RepType.hs:360:5 in
> ghc:RepType
>         runtimeRepPrimRep, called at compiler/simplStg/RepType.hs:342:5
> in ghc:RepType
>         kindPrimRep, called at compiler/simplStg/RepType.hs:305:18 in
> ghc:RepType
>         typePrimRep, called at compiler/simplStg/RepType.hs:128:19 in
> ghc:RepType
> }}}
> I think this is just #13394, comment:4 again.  It was fixed in comment:5
> of that ticket, but the fix has not yet been transferred to 8.2.

New description:

 This program (derived from Phab:D2858) crashes both GHC 8.0 and 8.2
 {{{
 {-# LANGUAGE ViewPatterns, PatternSynonyms #-}

 module Foo where

 data PrimOp = AddOp | Add2Op | OtherOp | BotherOp

 data Expr = Var PrimOp | App Expr Expr | BApp [Expr] | BOp Expr Expr | L
 Integer

 pattern BinOpApp  :: Expr -> PrimOp -> Expr -> Expr
 pattern BinOpApp  x op y =  Var op `App` x `App` y

 pattern (:+:) :: Expr -> Expr -> Expr
 pattern x :+: y <- BinOpApp x (isAddOp -> True) y

 isAddOp :: PrimOp -> Bool
 isAddOp AddOp  = True
 isAddOp Add2Op  = True
 isAddOp _      = False

 pattern (:++:) :: Integer -> Expr -> Expr
 pattern l :++: x <- (isAdd -> Just (l,x))

 isAdd :: Expr -> Maybe (Integer,Expr)
 {-# INLINE isAdd #-}
 isAdd e = case e of
    L l :+: x   -> Just (l,x)
    x   :+: L l -> Just (l,x)
    _           -> Nothing
 }}}
 Reason: the matching function, generated by the pattern synonym `:++:`,
 has a levity-polymorphic join point.

 8.0 has a Lint Error.  8.2 crashes with
 {{{
   (GHC version 8.2.1.20171024 for x86_64-unknown-linux):
         runtimeRepPrimRep
   typePrimRep (r_a1kX :: TYPE rep_a1kW)
   rep_a1kW
   Call stack:
       CallStack (from HasCallStack):
         prettyCurrentCallStack, called at
 compiler/utils/Outputable.hs:1133:58 in ghc:Outputable
         callStackDoc, called at compiler/utils/Outputable.hs:1137:37 in
 ghc:Outputable
         pprPanic, called at compiler/simplStg/RepType.hs:360:5 in
 ghc:RepType
         runtimeRepPrimRep, called at compiler/simplStg/RepType.hs:342:5 in
 ghc:RepType
         kindPrimRep, called at compiler/simplStg/RepType.hs:305:18 in
 ghc:RepType
         typePrimRep, called at compiler/simplStg/RepType.hs:128:19 in
 ghc:RepType
 }}}
 I think this is just #13394, comment:4 again.  It was fixed in comment:5
 of that ticket, but the fix has not yet been transferred to 8.2.

--

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