inlining defeats seq

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!

Trac metadata

Trac field	Value
Version	6.9
Type	Bug
TypeOfFailure	OtherFailure
Priority	normal
Resolution	Unresolved
Component	Compiler
Test case
Differential revisions
BlockedBy
Related
Blocking
CC
Operating system	Unknown
Architecture	Unknown