------------------------------------------------
Make code generation ignore isLocalId/isGlobalId
------------------------------------------------
MERGE WITH STABLE BRANCH
CorePrep may introduce some new, top-level LocalIds. This
breaks an invariant that the core2stg/code generator passes
occasionally used, namely that LocalIds are not top-level bound.
This commit fixes that problem.
It also removes an assert from CodeGen.cgTopRhs that asks
for the CgInfo of such new LocalIds -- but they may (legitimately)
not have any, so it was a bad ASSERT. [Showed up in George
Russel's system.]
cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag args body) srt
= -- There should be no free variables
ASSERT(null fvs)
cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag args body) srt
= -- There should be no free variables
ASSERT(null fvs)
- -- If the closure is a thunk, then the binder must be recorded as such.
- ASSERT2(not (isUpdatable upd_flag) || mayHaveCafRefs (idCafInfo bndr), ppr bndr)
getSRTLabel `thenFC` \srt_label ->
let lf_info =
getSRTLabel `thenFC` \srt_label ->
let lf_info =
+ = ImportBound -- Used only as a response to lookupBinding; never
+ -- exists in the range of the (IdEnv HowBound)
| CaseBound
| LambdaBound
| LetBound
| CaseBound
| LambdaBound
| LetBound
= expr (extendVarEnvList env ids_w_howbound) lvs_cont
lookupVarLne :: Id -> LneM HowBound
= expr (extendVarEnvList env ids_w_howbound) lvs_cont
lookupVarLne :: Id -> LneM HowBound
-lookupVarLne v env lvs_cont
- = returnLne (
- case (lookupVarEnv env v) of
- Just xx -> xx
- Nothing -> ImportBound
- ) env lvs_cont
+lookupVarLne v env lvs_cont = returnLne (lookupBinding env v) env lvs_cont
+
+lookupBinding :: IdEnv HowBound -> Id -> HowBound
+lookupBinding env v = case lookupVarEnv env v of
+ Just xx -> xx
+ Nothing -> ASSERT( isGlobalId v ) ImportBound
+
-- The result of lookupLiveVarsForSet, a set of live variables, is
-- only ever tacked onto a decorated expression. It is never used as
-- The result of lookupLiveVarsForSet, a set of live variables, is
-- only ever tacked onto a decorated expression. It is never used as
= returnLne (lvs, cafs) env live_in_cont
where
(lvs_cont, cafs_cont) = live_in_cont -- not a strict pattern match!
= returnLne (lvs, cafs) env live_in_cont
where
(lvs_cont, cafs_cont) = live_in_cont -- not a strict pattern match!
- (local, global) = partition isLocalId (allFreeIds fvs)
-
- (lvs_from_fvs, caf_extras) = unzip (map do_one local)
- lvs = unionVarSets lvs_from_fvs
- `unionVarSet` lvs_cont
+ (lvs_from_fvs, caf_from_fvs) = unzip (map do_one (allFreeIds fvs))
- cafs = mkVarSet (filter is_caf_one global)
- `unionVarSet` (unionVarSets caf_extras)
- `unionVarSet` cafs_cont
+ lvs = unionVarSets lvs_from_fvs `unionVarSet` lvs_cont
+ cafs = unionVarSets caf_from_fvs `unionVarSet` cafs_cont
- = case (lookupVarEnv env v) of
- Just (LetBound _ (lvs,cafs) _) -> (extendVarSet lvs v, cafs)
- Just _ -> (unitVarSet v, emptyVarSet)
- Nothing -> pprPanic "lookupLiveVarsForSet/do_one:" (ppr v)
-
- is_caf_one v
- = case lookupVarEnv env v of
- Just (LetBound TopLevelHasCafs (lvs,_) _) ->
- ASSERT( isEmptyVarSet lvs ) True
- Just (LetBound _ _ _) -> False
- _otherwise -> mayHaveCafRefs (idCafInfo v)
+ = case lookupBinding env v of
+ LetBound caf_ness (lvs,cafs) _ ->
+ case caf_ness of
+ TopLevelHasCafs -> ASSERT( isEmptyVarSet lvs ) (emptyVarSet, unitVarSet v)
+ TopLevelNoCafs -> ASSERT( isEmptyVarSet lvs ) (emptyVarSet, emptyVarSet)
+ NotTopLevelBound -> (extendVarSet lvs v, cafs)
+
+ ImportBound | mayHaveCafRefs (idCafInfo v) -> (emptyVarSet, unitVarSet v)
+ | otherwise -> (emptyVarSet, emptyVarSet)
+
+ _nested_binding -> (unitVarSet v, emptyVarSet) -- Bound by lambda or case
\end{code}
%************************************************************************
\end{code}
%************************************************************************
-- cafRefs compiles to beautiful code :)
cafRefs p (Var id)
-- cafRefs compiles to beautiful code :)
cafRefs p (Var id)
- | isLocalId id = fastBool False
- | otherwise =
- case lookupVarEnv p id of
- Just (LetBound TopLevelHasCafs _ _) -> fastBool True
- Just (LetBound _ _ _) -> fastBool False
- Nothing -> fastBool (cgMayHaveCafRefs (idCgInfo id)) -- imported Ids
+ = case lookupBinding p id of
+ ImportBound -> fastBool (mayHaveCafRefs (idCafInfo id))
+ LetBound TopLevelHasCafs _ _ -> fastBool True
+ other -> fastBool False
cafRefs p (Lit l) = fastBool False
cafRefs p (App f a) = fastOr (cafRefs p f) (cafRefs p) a
cafRefs p (Lit l) = fastBool False
cafRefs p (App f a) = fastOr (cafRefs p f) (cafRefs p) a