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 |