[GHC] #12901: Levity polymorphic expressions mustn't be floated out

[GHC]

#12901: Levity polymorphic expressions mustn't be floated out
-------------------------------------+-------------------------------------
           Reporter:  hsyl20         |             Owner:  hsyl20
               Type:  bug            |            Status:  new
           Priority:  normal         |         Milestone:
          Component:  Compiler       |           Version:  8.1
           Keywords:                 |  Operating System:  Unknown/Multiple
  LevityPolymorphism                 |
       Architecture:                 |   Type of failure:  Compile-time
  Unknown/Multiple                   |  crash or panic
          Test Case:                 |        Blocked By:
           Blocking:                 |   Related Tickets:
Differential Rev(s):                 |         Wiki Page:
-------------------------------------+-------------------------------------
 I have been trying to add the following code into GHC:
 {{{#!hs
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ViewPatterns #-}
 pattern AppOp1  :: PrimOp -> Arg CoreBndr -> CoreExpr
 pattern OpVal   :: PrimOp -> Arg CoreBndr

 pattern AppOp1  op x   =  App (OpVal op) x
 pattern OpVal   op     <- Var (isPrimOpId_maybe -> Just op) where
    OpVal op = Var (mkPrimOpId op)
 }}}

 It triggers the following CoreLint error:
 {{{
 <no location info>: warning:
     [RHS of lvl_spfb :: r]
     RuntimeRep-polymorphic binder: lvl_spfb :: (r :: TYPE rep)
 }}}

 Indeed:
 {{{#!hs
 $mAppOp1
   :: forall (r :: TYPE rep).
      CoreExpr -> (PrimOp -> Arg CoreBndr -> r) -> (Void# -> r) -> r
 [LclIdX, Arity=3]
 $mAppOp1 =
   \ (@ (rep_agRe :: RuntimeRep))
     (@ (r_agRf :: TYPE rep))
     (scrut_agRh :: CoreExpr)
     (cont_agRi :: PrimOp -> Arg CoreBndr -> r)
     (fail_agRj :: Void# -> r) ->
     let {
       fail_spbW :: Void# -> r
       [LclId, Arity=1]
       fail_spbW = \ _ [Occ=Dead, OS=OneShot] -> fail_agRj void# } in
     let {
       lvl_spfb :: r
       [LclId]
       lvl_spfb = fail_spbW void# } in
     case scrut_agRh of {
       __DEFAULT -> fail_spbW void#;
       App ds_dj2u x_afoV ->
         $mOpVal
           @ rep
           @ r
           ds_dj2u
           (\ (op_afoU :: PrimOp) -> cont_agRi op_afoU x_afoV)
           (\ _ [Occ=Dead] -> lvl_spfb)
 }}}

 According to the levity polymorphism paper `lvl_spfb` shouldn't have been
 floated out in a let-binding.

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