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
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
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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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
import VarEnv
import VarSet
import Name
-import Module
#if mingw32_TARGET_OS
import Packages
#endif
-- | 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
--
-- 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
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)
-- | 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
import DataCon
import TyCon
import Module
+import Packages( isDllName )
import HscTypes
import Maybes
import UniqSupply
\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
#include "HsVersions.h"
import CoreSyn
-import CoreUtils ( rhsIsStatic, exprType, findDefault )
+import CoreUtils ( exprType, findDefault )
import CoreArity ( manifestArity )
import StgSyn
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)
-- 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}
= 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
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
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 )
import StaticFlags ( opt_SccProfilingOn )
import Module
import FastString
+
+#if mingw32_TARGET_OS
+import Packages ( isDllName )
+
+#endif
\end{code}
%************************************************************************
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
projects / ghc-hetmet.git / commitdiff