[GHC] #2273: inlining defeats seq

[GHC]

#2273: inlining defeats seq
-------------------------+--------------------------------------------------
    Reporter:  igloo     |       Owner:         
        Type:  bug       |      Status:  new    
    Priority:  normal    |   Milestone:         
   Component:  Compiler  |     Version:  6.9    
    Severity:  normal    |    Keywords:         
  Difficulty:  Unknown   |    Testcase:         
Architecture:  Unknown   |          Os:  Unknown
-------------------------+--------------------------------------------------
 Consider this module:
 {{{
 module Q (tcExtendIdEnv2) where

 -- Interesting code:

 tcExtendIdEnv2 :: M a
 tcExtendIdEnv2 = do env <- getEnv
                     let level :: Int
                         level = thLevel (tcl_th_ctxt env)
                     level `seq` tc_extend_local_id_env level

 {-# NOINLINE tc_extend_local_id_env #-}
 tc_extend_local_id_env :: Int -> M a
 tc_extend_local_id_env th_lvl = if read "foo"
                                 then th_lvl `seq` return undefined
                                 else return undefined

 thLevel :: ThStage -> Int
 thLevel Comp       = 0
 thLevel (Splice l) = l
 thLevel (Brack l)  = l

 -- Dull code:

 type M a = IOEnv TcLclEnv a

 data TcLclEnv = TcLclEnv { tcl_th_ctxt :: !ThStage }

 data ThStage = Comp | Splice Int | Brack  Int

 getEnv :: IOEnv env env
 getEnv = IOEnv (\ env -> return env)

 newtype IOEnv env a = IOEnv { unIOEnv :: env -> IO a }

 instance Monad (IOEnv m) where
     IOEnv m >>= f = IOEnv (\ env -> do r <- m env
                                        unIOEnv (f r) env )
     return a = IOEnv (\ _ -> return a)
     fail = error
 }}}
 Compiling with
 {{{
 ghc -O -ddump-simpl -ddump-stg -c Q.hs
 }}}
 we get, in the STG,
 {{{
 Q.$wa =
     \r srt:(0,*bitmap*) [ww_sDx w_sDO]
         case
             case ww_sDx of wild_sEs {
               Q.Comp -> Q.lvl;
               Q.Splice l_sDA -> l_sDA;
               Q.Brack l_sDC -> l_sDC;
             }
         of
         tpl_sEt
         { GHC.Base.I# ipv_sEu ->
               let { sat_sDN = NO_CCS Q.TcLclEnv! [ww_sDx]; } in
               let {
                 sat_sDL =
                     \u []
                         case ww_sDx of wild_sEv {
                           Q.Comp -> Q.lvl;
                           Q.Splice l_sDH -> l_sDH;
                           Q.Brack l_sDJ -> l_sDJ;
                         };
               } in  Q.tc_extend_local_id_env sat_sDL sat_sDN w_sDO;
         };
 }}}
 GHC seems to have inlined `level`, forced it (due to the seq), but passed
 along a second, inlined, unevaluated copy to `tc_extend_local_id_env`. So
 the whole environment is retained, defeating the purpose of the seq!

 If I mark `level` as `NOINLINE` then the STG looks like this:
 {{{
 Q.a5 =
     \r srt:(0,*bitmap*) [env_sD1 eta_sDh]
         case env_sD1 of tpl_sDg {
           Q.TcLclEnv ipv_sD5 ->
               case
                   case ipv_sD5 of wild_sDN {
                     Q.Comp -> Q.lvl;
                     Q.Splice l_sD8 -> l_sD8;
                     Q.Brack l_sDa -> l_sDa;
                   }
               of
               level_sDc
               { __DEFAULT ->
                     case level_sDc of tpl1_sDf {
                       GHC.Base.I# ipv1_sDO -> Q.tc_extend_local_id_env
 tpl1_sDf tpl_sDg eta_sDh;
                     };
               };
         };
 }}}
 which fixes the env-retained problem, although I don't understand why two
 cases are done.

 It would be nice not to have to resort to this level of trickery, though!

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