Commit 9e6ca39b authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Fix an ASSERT failure with profiling

The problem arose with this kind of thing

   x = (,) (scc "blah" Nothing)

Then 'x' is marked NoCafRefs by CoreTidy, becuase it has 
arity 1, and doesn't mention any caffy things.

That in turns means that CorePrep must not float out the
sat binding to give

  sat = scc "blah" Nothing
  x = (,) sat

Rather we must generate

  x = \eta. let sat = scc "blah" Nothing 
            in (,) sat eta

URGH! This Caf stuff is such a mess.
parent 2d874edc
......@@ -197,7 +197,7 @@ And then x will actually end up case-bound
Note [CafInfo and floating]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
What happense when we try to float bindings to the top level. At this
What happens when we try to float bindings to the top level? At this
point all the CafInfo is supposed to be correct, and we must make certain
that is true of the new top-level bindings. There are two cases
to consider
......@@ -297,16 +297,18 @@ cpePair :: TopLevelFlag -> RecFlag -> RhsDemand
cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs
= do { (floats1, rhs1) <- cpeRhsE env rhs
; (floats2, rhs2)
-- See if we are allowed to float this stuff out of the RHS
; (floats2, rhs2) <- float_from_rhs floats1 rhs1
-- Make the arity match up
; (floats3, rhs')
<- if manifestArity rhs1 <= arity
then return (floats1, cpeEtaExpand arity rhs1)
then return (floats2, cpeEtaExpand arity rhs2)
else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr)
-- Note [Silly extra arguments]
(do { v <- newVar (idType bndr)
; let float = mkFloat False False v rhs1
; return (addFloat floats1 float, cpeEtaExpand arity (Var v)) })
; (floats3, rhs') <- float_from_rhs floats2 rhs2
; let float = mkFloat False False v rhs2
; return (addFloat floats2 float, cpeEtaExpand arity (Var v)) })
-- Record if the binder is evaluated
; let bndr' | exprIsHNF rhs' = bndr `setIdUnfolding` evaldUnfolding
......@@ -317,37 +319,38 @@ cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs
arity = idArity bndr -- We must match this arity
---------------------
float_from_rhs floats2 rhs2
| isEmptyFloats floats2 = return (emptyFloats, rhs2)
| isTopLevel top_lvl = float_top floats2 rhs2
| otherwise = float_nested floats2 rhs2
float_from_rhs floats rhs
| isEmptyFloats floats = return (emptyFloats, rhs)
| isTopLevel top_lvl = float_top floats rhs
| otherwise = float_nested floats rhs
---------------------
float_nested floats2 rhs2
| wantFloatNested is_rec is_strict_or_unlifted floats2 rhs2
= return (floats2, rhs2)
| otherwise = dont_float floats2 rhs2
float_nested floats rhs
| wantFloatNested is_rec is_strict_or_unlifted floats rhs
= return (floats, rhs)
| otherwise = dont_float floats rhs
---------------------
float_top floats2 rhs2 -- Urhgh! See Note [CafInfo and floating]
float_top floats rhs -- Urhgh! See Note [CafInfo and floating]
| mayHaveCafRefs (idCafInfo bndr)
= if allLazyTop floats2
then return (floats2, rhs2)
else dont_float floats2 rhs2
, allLazyTop floats
= return (floats, rhs)
-- So the top-level binding is marked NoCafRefs
| Just (floats', rhs') <- canFloatFromNoCaf floats rhs
= return (floats', rhs')
| otherwise
= case canFloatFromNoCaf floats2 rhs2 of
Just (floats2', rhs2') -> return (floats2', rhs2')
Nothing -> pprPanic "cpePair" (ppr bndr $$ ppr rhs2 $$ ppr floats2)
= dont_float floats rhs
---------------------
dont_float floats2 rhs2
dont_float floats rhs
-- Non-empty floats, but do not want to float from rhs
-- So wrap the rhs in the floats
-- But: rhs1 might have lambdas, and we can't
-- put them inside a wrapBinds
= do { body2 <- rhsToBodyNF rhs2
; return (emptyFloats, wrapBinds floats2 body2) }
= do { body <- rhsToBodyNF rhs
; return (emptyFloats, wrapBinds floats body) }
{- Note [Silly extra arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -897,35 +900,50 @@ deFloatTop (Floats _ floats)
canFloatFromNoCaf :: Floats -> CpeRhs -> Maybe (Floats, CpeRhs)
-- Note [CafInfo and floating]
canFloatFromNoCaf (Floats ok_to_spec fs) rhs
| OkToSpec <- ok_to_spec
= Just (Floats OkToSpec (toOL fs'), subst_expr subst rhs)
| OkToSpec <- ok_to_spec -- Worth trying
, Just (subst, fs') <- go (emptySubst, nilOL) (fromOL fs)
= Just (Floats OkToSpec fs', subst_expr subst rhs)
| otherwise
= Nothing
where
(subst, fs') = mapAccumL set_nocaf emptySubst (fromOL fs)
subst_expr = substExpr (text "CorePrep")
set_nocaf _ (FloatCase {})
= panic "canFloatFromNoCaf"
go :: (Subst, OrdList FloatingBind) -> [FloatingBind]
-> Maybe (Subst, OrdList FloatingBind)
set_nocaf subst (FloatLet (NonRec b r))
= (subst', FloatLet (NonRec b' (subst_expr subst r)))
go (subst, fbs_out) [] = Just (subst, fbs_out)
go (subst, fbs_out) (FloatLet (NonRec b r) : fbs_in)
| rhs_ok r
= go (subst', fbs_out `snocOL` new_fb) fbs_in
where
(subst', b') = set_nocaf_bndr subst b
new_fb = FloatLet (NonRec b' (subst_expr subst r))
set_nocaf subst (FloatLet (Rec prs))
= (subst', FloatLet (Rec (bs' `zip` rs')))
go (subst, fbs_out) (FloatLet (Rec prs) : fbs_in)
| all rhs_ok rs
= go (subst', fbs_out `snocOL` new_fb) fbs_in
where
(bs,rs) = unzip prs
(subst', bs') = mapAccumL set_nocaf_bndr subst bs
rs' = map (subst_expr subst') rs
new_fb = FloatLet (Rec (bs' `zip` rs'))
go _ _ = Nothing -- Encountered a caffy binding
------------
set_nocaf_bndr subst bndr
= (extendIdSubst subst bndr (Var bndr'), bndr')
where
bndr' = bndr `setIdCafInfo` NoCafRefs
------------
rhs_ok :: CoreExpr -> Bool
-- We can only float to top level from a NoCaf thing if
-- the new binding is static. However it can't mention
-- any non-static things or it would *already* be Caffy
rhs_ok = rhsIsStatic (\_ -> False)
wantFloatNested :: RecFlag -> Bool -> Floats -> CpeRhs -> Bool
wantFloatNested is_rec strict_or_unlifted floats rhs
= isEmptyFloats floats
......
......@@ -55,7 +55,6 @@ import SrcLoc
import VarEnv
import VarSet
import Name
import Module
#if mingw32_TARGET_OS
import Packages
#endif
......@@ -1337,7 +1336,7 @@ and 'execute' it rather than allocating it statically.
-- | This function is called only on *top-level* right-hand sides.
-- Returns @True@ if the RHS can be allocated statically in the output,
-- with no thunks involved at all.
rhsIsStatic :: PackageId -> CoreExpr -> Bool
rhsIsStatic :: (Name -> Bool) -> CoreExpr -> Bool
-- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or
-- refers to, CAFs; (ii) in CoreToStg to decide whether to put an
-- update flag on it and (iii) in DsExpr to decide how to expand
......@@ -1392,7 +1391,7 @@ rhsIsStatic :: PackageId -> CoreExpr -> Bool
--
-- c) don't look through unfolding of f in (f x).
rhsIsStatic _this_pkg rhs = is_static False rhs
rhsIsStatic _is_dynamic_name rhs = is_static False rhs
where
is_static :: Bool -- True <=> in a constructor argument; must be atomic
-> CoreExpr -> Bool
......@@ -1420,7 +1419,7 @@ rhsIsStatic _this_pkg rhs = is_static False rhs
where
go (Var f) n_val_args
#if mingw32_TARGET_OS
| not (isDllName _this_pkg (idName f))
| not (_is_dynamic_name (idName f))
#endif
= saturated_data_con f n_val_args
|| (in_arg && n_val_args == 0)
......
......@@ -947,6 +947,9 @@ missingDependencyMsg (Just parent)
-- | Will the 'Name' come from a dynamically linked library?
isDllName :: PackageId -> Name -> Bool
-- Despite the "dll", I think this function just means that
-- the synbol comes from another dynamically-linked package,
-- and applies on all platforms, not just Windows
isDllName this_pkg name
| opt_Static = False
| Just mod <- nameModule_maybe name = modulePackageId mod /= this_pkg
......
......@@ -37,6 +37,7 @@ import TcType
import DataCon
import TyCon
import Module
import Packages( isDllName )
import HscTypes
import Maybes
import UniqSupply
......@@ -1139,12 +1140,12 @@ CAF list to keep track of non-collectable CAFs.
\begin{code}
hasCafRefs :: PackageId -> VarEnv Var -> Arity -> CoreExpr -> CafInfo
hasCafRefs this_pkg p arity expr
| is_caf || mentions_cafs
= MayHaveCafRefs
| is_caf || mentions_cafs = MayHaveCafRefs
| otherwise = NoCafRefs
where
mentions_cafs = isFastTrue (cafRefs p expr)
is_caf = not (arity > 0 || rhsIsStatic this_pkg expr)
is_dynamic_name = isDllName this_pkg
is_caf = not (arity > 0 || rhsIsStatic is_dynamic_name expr)
-- NB. we pass in the arity of the expression, which is expected
-- to be calculated by exprArity. This is because exprArity
......
......@@ -12,7 +12,7 @@ module CoreToStg ( coreToStg, coreExprToStg ) where
#include "HsVersions.h"
import CoreSyn
import CoreUtils ( rhsIsStatic, exprType, findDefault )
import CoreUtils ( exprType, findDefault )
import CoreArity ( manifestArity )
import StgSyn
......@@ -184,7 +184,7 @@ coreTopBindToStg this_pkg env body_fvs (NonRec id rhs)
bind = StgNonRec id stg_rhs
in
ASSERT2(consistentCafInfo id bind, ppr id $$ ppr rhs $$ ppr bind )
ASSERT2(consistentCafInfo id bind, ppr id {- $$ ppr rhs $$ ppr bind -} )
(env', fvs' `unionFVInfo` body_fvs, bind)
coreTopBindToStg this_pkg env body_fvs (Rec pairs)
......@@ -214,15 +214,14 @@ coreTopBindToStg this_pkg env body_fvs (Rec pairs)
-- floated out a binding, in which case it will be approximate.
consistentCafInfo :: Id -> GenStgBinding Var Id -> Bool
consistentCafInfo id bind
| occNameFS (nameOccName (idName id)) == fsLit "sat"
= safe
| otherwise
= WARN (not exact, ppr id) safe
= WARN( not (exact || is_sat_thing) , ppr id )
safe
where
safe = id_marked_caffy || not binding_is_caffy
exact = id_marked_caffy == binding_is_caffy
id_marked_caffy = mayHaveCafRefs (idCafInfo id)
binding_is_caffy = stgBindHasCafRefs bind
safe = id_marked_caffy || not binding_is_caffy
exact = id_marked_caffy == binding_is_caffy
id_marked_caffy = mayHaveCafRefs (idCafInfo id)
binding_is_caffy = stgBindHasCafRefs bind
is_sat_thing = occNameFS (nameOccName (idName id)) == fsLit "sat"
\end{code}
\begin{code}
......@@ -236,13 +235,12 @@ coreToTopStgRhs this_pkg scope_fv_info (bndr, rhs)
= do { (new_rhs, rhs_fvs, _) <- coreToStgExpr rhs
; lv_info <- freeVarsToLiveVars rhs_fvs
; let stg_rhs = mkTopStgRhs is_static rhs_fvs (mkSRT lv_info) bndr_info new_rhs
; let stg_rhs = mkTopStgRhs this_pkg rhs_fvs (mkSRT lv_info) bndr_info new_rhs
stg_arity = stgRhsArity stg_rhs
; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs,
rhs_fvs) }
where
bndr_info = lookupFVInfo scope_fv_info bndr
is_static = rhsIsStatic this_pkg rhs
-- It's vital that the arity on a top-level Id matches
-- the arity of the generated STG binding, else an importing
......@@ -263,25 +261,23 @@ coreToTopStgRhs this_pkg scope_fv_info (bndr, rhs)
ptext (sLit "Id arity:") <+> ppr id_arity,
ptext (sLit "STG arity:") <+> ppr stg_arity]
mkTopStgRhs :: Bool -> FreeVarsInfo
mkTopStgRhs :: PackageId -> FreeVarsInfo
-> SRT -> StgBinderInfo -> StgExpr
-> StgRhs
mkTopStgRhs is_static rhs_fvs srt binder_info (StgLam _ bndrs body)
= ASSERT( is_static )
StgRhsClosure noCCS binder_info
mkTopStgRhs _ rhs_fvs srt binder_info (StgLam _ bndrs body)
= StgRhsClosure noCCS binder_info
(getFVs rhs_fvs)
ReEntrant
srt
bndrs body
mkTopStgRhs is_static _ _ _ (StgConApp con args)
| is_static -- StgConApps can be updatable (see isCrossDllConApp)
mkTopStgRhs this_pkg _ _ _ (StgConApp con args)
| not (isDllConApp this_pkg con args) -- Dynamic StgConApps are updatable
= StgRhsCon noCCS con args
mkTopStgRhs is_static rhs_fvs srt binder_info rhs
= ASSERT2( not is_static, ppr rhs )
StgRhsClosure noCCS binder_info
mkTopStgRhs _ rhs_fvs srt binder_info rhs
= StgRhsClosure noCCS binder_info
(getFVs rhs_fvs)
Updatable
srt
......
......@@ -48,12 +48,11 @@ module StgSyn (
import CostCentre ( CostCentreStack, CostCentre )
import VarSet ( IdSet, isEmptyVarSet )
import Id ( Id, idName, idType, idCafInfo, isId )
import Id
import DataCon
import IdInfo ( mayHaveCafRefs )
import Packages ( isDllName )
import Literal ( Literal, literalType )
import ForeignCall ( ForeignCall )
import DataCon ( DataCon, dataConName )
import CoreSyn ( AltCon )
import PprCore ( {- instances -} )
import PrimOp ( PrimOp, PrimCall )
......@@ -66,6 +65,11 @@ import Bitmap
import StaticFlags ( opt_SccProfilingOn )
import Module
import FastString
#if mingw32_TARGET_OS
import Packages ( isDllName )
#endif
\end{code}
%************************************************************************
......@@ -105,17 +109,20 @@ isStgTypeArg :: StgArg -> Bool
isStgTypeArg (StgTypeArg _) = True
isStgTypeArg _ = False
isDllArg :: PackageId -> StgArg -> Bool
-- Does this argument refer to something in a different DLL?
isDllArg this_pkg (StgVarArg v) = isDllName this_pkg (idName v)
isDllArg _ _ = False
isDllConApp :: PackageId -> DataCon -> [StgArg] -> Bool
-- Does this constructor application refer to
-- anything in a different DLL?
-- If so, we can't allocate it statically
-- Does this constructor application refer to
-- anything in a different *Windows* DLL?
-- If so, we can't allocate it statically
#if mingw32_TARGET_OS
isDllConApp this_pkg con args
= isDllName this_pkg (dataConName con) || any (isDllArg this_pkg) args
= isDllName this_pkg (dataConName con) || any is_dll_arg args
where
is_dll_arg ::StgArg -> Bool
is_dll_arg (StgVarArg v) = isDllName this_pkg (idName v)
is_dll_arg _ = False
#else
isDllConApp _ _ _ = False
#endif
stgArgType :: StgArg -> Type
-- Very half baked becase we have lost the type arguments
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment