- -- Notice the mutually-recursive "knot" here:
- -- env accumulates down the list of binds,
- -- fvs accumulates upwards
- (env1, fvs2, b' ) = coreTopBindToStg this_pkg env fvs1 b
- (env2, fvs1, bs') = coreTopBindsToStg this_pkg env1 bs
+ -- Notice the mutually-recursive "knot" here:
+ -- env accumulates down the list of binds,
+ -- fvs accumulates upwards
+ (env1, fvs2, b' ) = coreTopBindToStg this_pkg env fvs1 b
+ (env2, fvs1, bs') = coreTopBindsToStg this_pkg env1 bs
- -- It's vital that the arity on a top-level Id matches
- -- the arity of the generated STG binding, else an importing
- -- module will use the wrong calling convention
- -- (Trac #2844 was an example where this happened)
- -- NB1: we can't move the assertion further out without
- -- blocking the "knot" tied in coreTopBindsToStg
- -- NB2: the arity check is only needed for Ids with External
- -- Names, because they are externally visible. The CorePrep
- -- pass introduces "sat" things with Local Names and does
- -- not bother to set their Arity info, so don't fail for those
+ -- It's vital that the arity on a top-level Id matches
+ -- the arity of the generated STG binding, else an importing
+ -- module will use the wrong calling convention
+ -- (Trac #2844 was an example where this happened)
+ -- NB1: we can't move the assertion further out without
+ -- blocking the "knot" tied in coreTopBindsToStg
+ -- NB2: the arity check is only needed for Ids with External
+ -- Names, because they are externally visible. The CorePrep
+ -- pass introduces "sat" things with Local Names and does
+ -- not bother to set their Arity info, so don't fail for those
- :: CoreExpr
- -> LneM (StgExpr, -- Decorated STG expr
- FreeVarsInfo, -- Its free vars (NB free, not live)
- EscVarsSet) -- Its escapees, a subset of its free vars;
- -- also a subset of the domain of the envt
- -- because we are only interested in the escapees
- -- for vars which might be turned into
- -- let-no-escaped ones.
+ :: CoreExpr
+ -> LneM (StgExpr, -- Decorated STG expr
+ FreeVarsInfo, -- Its free vars (NB free, not live)
+ EscVarsSet) -- Its escapees, a subset of its free vars;
+ -- also a subset of the domain of the envt
+ -- because we are only interested in the escapees
+ -- for vars which might be turned into
+ -- let-no-escaped ones.
- -- Determine whether the default binder is dead or not
- -- This helps the code generator to avoid generating an assignment
- -- for the case binder (is extremely rare cases) ToDo: remove.
- bndr' | bndr `elementOfFVInfo` alts_fvs = bndr
- | otherwise = bndr `setIdOccInfo` IAmDead
-
- -- Don't consider the default binder as being 'live in alts',
- -- since this is from the point of view of the case expr, where
- -- the default binder is not free.
- alts_fvs_wo_bndr = bndr `minusFVBinder` alts_fvs
- alts_escs_wo_bndr = alts_escs `delVarSet` bndr
+ -- Determine whether the default binder is dead or not
+ -- This helps the code generator to avoid generating an assignment
+ -- for the case binder (is extremely rare cases) ToDo: remove.
+ bndr' | bndr `elementOfFVInfo` alts_fvs = bndr
+ | otherwise = bndr `setIdOccInfo` IAmDead
+
+ -- Don't consider the default binder as being 'live in alts',
+ -- since this is from the point of view of the case expr, where
+ -- the default binder is not free.
+ alts_fvs_wo_bndr = bndr `minusFVBinder` alts_fvs
+ alts_escs_wo_bndr = alts_escs `delVarSet` bndr
- :: Maybe UpdateFlag -- Just upd <=> this application is
- -- the rhs of a thunk binding
- -- x = [...] \upd [] -> the_app
- -- with specified update flag
- -> Id -- Function
- -> [CoreArg] -- Arguments
- -> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
+ :: Maybe UpdateFlag -- Just upd <=> this application is
+ -- the rhs of a thunk binding
+ -- x = [...] \upd [] -> the_app
+ -- with specified update flag
+ -> Id -- Function
+ -> [CoreArg] -- Arguments
+ -> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
- -- Mostly, the arity info of a function is in the fn's IdInfo
- -- But new bindings introduced by CoreSat may not have no
- -- arity info; it would do us no good anyway. For example:
- -- let f = \ab -> e in f
- -- No point in having correct arity info for f!
- -- Hence the hasArity stuff below.
- -- NB: f_arity is only consulted for LetBound things
- f_arity = stgArity f how_bound
- saturated = f_arity <= n_val_args
-
- fun_occ
- | not_letrec_bound = noBinderInfo -- Uninteresting variable
- | f_arity > 0 && saturated = stgSatOcc -- Saturated or over-saturated function call
- | otherwise = stgUnsatOcc -- Unsaturated function or thunk
-
- fun_escs
- | not_letrec_bound = emptyVarSet -- Only letrec-bound escapees are interesting
- | f_arity == n_val_args = emptyVarSet -- A function *or thunk* with an exactly
- -- saturated call doesn't escape
- -- (let-no-escape applies to 'thunks' too)
-
- | otherwise = unitVarSet f -- Inexact application; it does escape
-
- -- At the moment of the call:
-
- -- either the function is *not* let-no-escaped, in which case
- -- nothing is live except live_in_cont
- -- or the function *is* let-no-escaped in which case the
- -- variables it uses are live, but still the function
- -- itself is not. PS. In this case, the function's
- -- live vars should already include those of the
- -- continuation, but it does no harm to just union the
- -- two regardless.
-
- res_ty = exprType (mkApps (Var f) args)
- app = case idDetails f of
- DataConWorkId dc | saturated -> StgConApp dc args'
-
- -- Some primitive operator that might be implemented as a library call.
- PrimOpId op -> ASSERT( saturated )
- StgOpApp (StgPrimOp op) args' res_ty
-
- -- A call to some primitive Cmm function.
- FCallId (CCall (CCallSpec (StaticTarget lbl (Just pkgId)) PrimCallConv _))
- -> ASSERT( saturated )
- StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) args' res_ty
-
- -- A regular foreign call.
- FCallId call -> ASSERT( saturated )
- StgOpApp (StgFCallOp call (idUnique f)) args' res_ty
+ -- Mostly, the arity info of a function is in the fn's IdInfo
+ -- But new bindings introduced by CoreSat may not have no
+ -- arity info; it would do us no good anyway. For example:
+ -- let f = \ab -> e in f
+ -- No point in having correct arity info for f!
+ -- Hence the hasArity stuff below.
+ -- NB: f_arity is only consulted for LetBound things
+ f_arity = stgArity f how_bound
+ saturated = f_arity <= n_val_args
+
+ fun_occ
+ | not_letrec_bound = noBinderInfo -- Uninteresting variable
+ | f_arity > 0 && saturated = stgSatOcc -- Saturated or over-saturated function call
+ | otherwise = stgUnsatOcc -- Unsaturated function or thunk
+
+ fun_escs
+ | not_letrec_bound = emptyVarSet -- Only letrec-bound escapees are interesting
+ | f_arity == n_val_args = emptyVarSet -- A function *or thunk* with an exactly
+ -- saturated call doesn't escape
+ -- (let-no-escape applies to 'thunks' too)
+
+ | otherwise = unitVarSet f -- Inexact application; it does escape
+
+ -- At the moment of the call:
+
+ -- either the function is *not* let-no-escaped, in which case
+ -- nothing is live except live_in_cont
+ -- or the function *is* let-no-escaped in which case the
+ -- variables it uses are live, but still the function
+ -- itself is not. PS. In this case, the function's
+ -- live vars should already include those of the
+ -- continuation, but it does no harm to just union the
+ -- two regardless.
+
+ res_ty = exprType (mkApps (Var f) args)
+ app = case idDetails f of
+ DataConWorkId dc | saturated -> StgConApp dc args'
+
+ -- Some primitive operator that might be implemented as a library call.
+ PrimOpId op -> ASSERT( saturated )
+ StgOpApp (StgPrimOp op) args' res_ty
+
+ -- A call to some primitive Cmm function.
+ FCallId (CCall (CCallSpec (StaticTarget lbl (Just pkgId)) PrimCallConv _))
+ -> ASSERT( saturated )
+ StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) args' res_ty
+
+ -- A regular foreign call.
+ FCallId call -> ASSERT( saturated )
+ StgOpApp (StgFCallOp call (idUnique f)) args' res_ty
- _other -> StgApp f args'
-
- return (
- app,
- fun_fvs `unionFVInfo` args_fvs,
- fun_escs `unionVarSet` (getFVSet args_fvs)
- -- All the free vars of the args are disqualified
- -- from being let-no-escaped.
+ _other -> StgApp f args'
+ fvs = fun_fvs `unionFVInfo` args_fvs
+ vars = fun_escs `unionVarSet` (getFVSet args_fvs)
+ -- All the free vars of the args are disqualified
+ -- from being let-no-escaped.
+
+ -- Forcing these fixes a leak in the code generator, noticed while
+ -- profiling for trac #4367
+ app `seq` fvs `seq` seqVarSet vars `seq` return (
+ app,
+ fvs,
+ vars
- fvs = args_fvs `unionFVInfo` arg_fvs
- stg_arg = case arg' of
- StgApp v [] -> StgVarArg v
- StgConApp con [] -> StgVarArg (dataConWorkId con)
- StgLit lit -> StgLitArg lit
- _ -> pprPanic "coreToStgArgs" (ppr arg)
-
- -- WARNING: what if we have an argument like (v `cast` co)
- -- where 'co' changes the representation type?
- -- (This really only happens if co is unsafe.)
- -- Then all the getArgAmode stuff in CgBindery will set the
- -- cg_rep of the CgIdInfo based on the type of v, rather
- -- than the type of 'co'.
- -- This matters particularly when the function is a primop
- -- or foreign call.
- -- Wanted: a better solution than this hacky warning
+ fvs = args_fvs `unionFVInfo` arg_fvs
+ stg_arg = case arg' of
+ StgApp v [] -> StgVarArg v
+ StgConApp con [] -> StgVarArg (dataConWorkId con)
+ StgLit lit -> StgLitArg lit
+ _ -> pprPanic "coreToStgArgs" (ppr arg)
+
+ -- WARNING: what if we have an argument like (v `cast` co)
+ -- where 'co' changes the representation type?
+ -- (This really only happens if co is unsafe.)
+ -- Then all the getArgAmode stuff in CgBindery will set the
+ -- cg_rep of the CgIdInfo based on the type of v, rather
+ -- than the type of 'co'.
+ -- This matters particularly when the function is a primop
+ -- or foreign call.
+ -- Wanted: a better solution than this hacky warning
- arg_ty = exprType arg
- stg_arg_ty = stgArgType stg_arg
- bad_args = (isUnLiftedType arg_ty && not (isUnLiftedType stg_arg_ty))
- || (typePrimRep arg_ty /= typePrimRep stg_arg_ty)
- -- In GHCi we coerce an argument of type BCO# (unlifted) to HValue (lifted),
- -- and pass it to a function expecting an HValue (arg_ty). This is ok because
- -- we can treat an unlifted value as lifted. But the other way round
- -- we complain.
- -- We also want to check if a pointer is cast to a non-ptr etc
+ arg_ty = exprType arg
+ stg_arg_ty = stgArgType stg_arg
+ bad_args = (isUnLiftedType arg_ty && not (isUnLiftedType stg_arg_ty))
+ || (typePrimRep arg_ty /= typePrimRep stg_arg_ty)
+ -- In GHCi we coerce an argument of type BCO# (unlifted) to HValue (lifted),
+ -- and pass it to a function expecting an HValue (arg_ty). This is ok because
+ -- we can treat an unlifted value as lifted. But the other way round
+ -- we complain.
+ -- We also want to check if a pointer is cast to a non-ptr etc
- :: Bool -- True <=> yes, we are let-no-escaping this let
- -> CoreBind -- bindings
- -> CoreExpr -- body
- -> LneM (StgExpr, -- new let
- FreeVarsInfo, -- variables free in the whole let
- EscVarsSet, -- variables that escape from the whole let
- Bool) -- True <=> none of the binders in the bindings
- -- is among the escaping vars
+ :: Bool -- True <=> yes, we are let-no-escaping this let
+ -> CoreBind -- bindings
+ -> CoreExpr -- body
+ -> LneM (StgExpr, -- new let
+ FreeVarsInfo, -- variables free in the whole let
+ EscVarsSet, -- variables that escape from the whole let
+ Bool) -- True <=> none of the binders in the bindings
+ -- is among the escaping vars
- = (binder, LetBound (NestedLet live_vars) (manifestArity rhs))
- where
- live_vars | let_no_escape = addLiveVar bind_lv_info binder
- | otherwise = unitLiveVar binder
- -- c.f. the invariant on NestedLet
-
- vars_bind :: FreeVarsInfo -- Free var info for body of binding
- -> CoreBind
- -> LneM (StgBinding,
- FreeVarsInfo,
- EscVarsSet, -- free vars; escapee vars
- LiveInfo, -- Vars and CAFs live in binding
- [(Id, HowBound)]) -- extension to environment
-
+ = (binder, LetBound (NestedLet live_vars) (manifestArity rhs))
+ where
+ live_vars | let_no_escape = addLiveVar bind_lv_info binder
+ | otherwise = unitLiveVar binder
+ -- c.f. the invariant on NestedLet
+
+ vars_bind :: FreeVarsInfo -- Free var info for body of binding
+ -> CoreBind
+ -> LneM (StgBinding,
+ FreeVarsInfo,
+ EscVarsSet, -- free vars; escapee vars
+ LiveInfo, -- Vars and CAFs live in binding
+ [(Id, HowBound)]) -- extension to environment
+
- let
- rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
- binders = map fst pairs
- env_ext = [ mk_binding bind_lv_info b rhs
- | (b,rhs) <- pairs ]
- in
- extendVarEnvLne env_ext $ do
- (rhss2, fvss, lv_infos, escss)
- <- mapAndUnzip4M (coreToStgRhs rec_scope_fvs binders) pairs
- let
- bind_fvs = unionFVInfos fvss
- bind_lv_info = foldr unionLiveInfo emptyLiveInfo lv_infos
- escs = unionVarSets escss
-
- return (StgRec (binders `zip` rhss2),
- bind_fvs, escs, bind_lv_info, env_ext)
+ let
+ rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
+ binders = map fst pairs
+ env_ext = [ mk_binding bind_lv_info b rhs
+ | (b,rhs) <- pairs ]
+ in
+ extendVarEnvLne env_ext $ do
+ (rhss2, fvss, lv_infos, escss)
+ <- mapAndUnzip4M (coreToStgRhs rec_scope_fvs binders) pairs
+ let
+ bind_fvs = unionFVInfos fvss
+ bind_lv_info = foldr unionLiveInfo emptyLiveInfo lv_infos
+ escs = unionVarSets escss
+
+ return (StgRec (binders `zip` rhss2),
+ bind_fvs, escs, bind_lv_info, env_ext)
- -- The Var is so we can gather up the free variables
- -- as a set.
- --
- -- The HowBound info just saves repeated lookups;
- -- we look up just once when we encounter the occurrence.
- -- INVARIANT: Any ImportBound Ids are HaveCafRef Ids
- -- Imported Ids without CAF refs are simply
- -- not put in the FreeVarsInfo for an expression.
- -- See singletonFVInfo and freeVarsToLiveVars
- --
- -- StgBinderInfo records how it occurs; notably, we
- -- are interested in whether it only occurs in saturated
- -- applications, because then we don't need to build a
- -- curried version.
- -- If f is mapped to noBinderInfo, that means
- -- that f *is* mentioned (else it wouldn't be in the
- -- IdEnv at all), but perhaps in an unsaturated applications.
- --
- -- All case/lambda-bound things are also mapped to
- -- noBinderInfo, since we aren't interested in their
- -- occurence info.
- --
- -- For ILX we track free var info for type variables too;
- -- hence VarEnv not IdEnv
+ -- The Var is so we can gather up the free variables
+ -- as a set.
+ --
+ -- The HowBound info just saves repeated lookups;
+ -- we look up just once when we encounter the occurrence.
+ -- INVARIANT: Any ImportBound Ids are HaveCafRef Ids
+ -- Imported Ids without CAF refs are simply
+ -- not put in the FreeVarsInfo for an expression.
+ -- See singletonFVInfo and freeVarsToLiveVars
+ --
+ -- StgBinderInfo records how it occurs; notably, we
+ -- are interested in whether it only occurs in saturated
+ -- applications, because then we don't need to build a
+ -- curried version.
+ -- If f is mapped to noBinderInfo, that means
+ -- that f *is* mentioned (else it wouldn't be in the
+ -- IdEnv at all), but perhaps in an unsaturated applications.
+ --
+ -- All case/lambda-bound things are also mapped to
+ -- noBinderInfo, since we aren't interested in their
+ -- occurence info.
+ --
+ -- For ILX we track free var info for type variables too;
+ -- hence VarEnv not IdEnv