- u = uaUTy ty
- once | u == usOnce = True
- | u == usMany = False
- | isTyVarTy u = False -- if unknown at compile-time, is Top ie usMany
-
-bdrDem :: Id -> RhsDemand
-bdrDem id = mkDem (idDemandInfo id) (isOnceTy (idType id))
-
-safeDem, onceDem :: RhsDemand
-safeDem = RhsDemand False False -- always safe to use this
-onceDem = RhsDemand False True -- used at most once
-\end{code}
-
-No free/live variable information is pinned on in this pass; it's added
-later. For this pass
-we use @bOGUS_LVs@ and @bOGUS_FVs@ as placeholders.
-
-When printing out the Stg we need non-bottom values in these
-locations.
-
-\begin{code}
-bOGUS_LVs :: StgLiveVars
-bOGUS_LVs = emptyUniqSet
-
-bOGUS_FVs :: [Id]
-bOGUS_FVs = []
-\end{code}
-
-\begin{code}
-topCoreBindsToStg :: UniqSupply -- name supply
- -> [CoreBind] -- input
- -> [StgBinding] -- output
-
-topCoreBindsToStg us core_binds
- = initUs_ us (coreBindsToStg emptyVarEnv core_binds)
- where
- coreBindsToStg :: StgEnv -> [CoreBind] -> UniqSM [StgBinding]
-
- coreBindsToStg env [] = returnUs []
- coreBindsToStg env (b:bs)
- = coreBindToStg TopLevel env b `thenUs` \ (bind_spec, new_env) ->
- coreBindsToStg new_env bs `thenUs` \ new_bs ->
- case bind_spec of
- NonRecF bndr rhs dem floats
- -> ASSERT2( not (isStrictDem dem) &&
- not (isUnLiftedType (idType bndr)),
- ppr b ) -- No top-level cases!
-
- mkStgBinds floats rhs `thenUs` \ new_rhs ->
- returnUs (StgNonRec bndr (exprToRhs dem TopLevel new_rhs)
- : new_bs)
- -- Keep all the floats inside...
- -- Some might be cases etc
- -- We might want to revisit this decision
-
- RecF prs -> returnUs (StgRec prs : new_bs)
- NoBindF -> pprTrace "topCoreBindsToStg" (ppr b) $
- returnUs new_bs
+ -- env accumulates down the list of binds, fvs accumulates upwards
+ (env1, fvs2, b' ) = coreTopBindToStg env fvs1 b
+ (env2, fvs1, bs') = coreTopBindsToStg env1 bs
+
+
+coreTopBindToStg
+ :: IdEnv HowBound
+ -> FreeVarsInfo -- Info about the body
+ -> CoreBind
+ -> (IdEnv HowBound, FreeVarsInfo, StgBinding)
+
+coreTopBindToStg env body_fvs (NonRec id rhs)
+ = let
+ caf_info = hasCafRefs env rhs
+ env' = extendVarEnv env id how_bound
+ how_bound = LetBound (TopLet caf_info) (manifestArity rhs)
+
+ (stg_rhs, fvs', lv_info) =
+ initLne env (
+ coreToStgRhs body_fvs TopLevel (id,rhs) `thenLne` \ (stg_rhs, fvs', _) ->
+ freeVarsToLiveVars fvs' `thenLne` \ lv_info ->
+ returnLne (stg_rhs, fvs', lv_info)
+ )
+
+ bind = StgNonRec (mkSRT lv_info) id stg_rhs
+ in
+ ASSERT2(isLocalId id || idArity id == manifestArity rhs, ppr id)
+ ASSERT2(manifestArity rhs == stgRhsArity stg_rhs, ppr id)
+ ASSERT2(consistent caf_info bind, ppr id)
+-- WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info)
+ (env', fvs' `unionFVInfo` body_fvs, bind)
+
+coreTopBindToStg env body_fvs (Rec pairs)
+ = let
+ (binders, rhss) = unzip pairs
+
+ -- To calculate caf_info, we initially map
+ -- all the binders to NoCafRefs
+ env1 = extendVarEnvList env
+ [ (b, LetBound (TopLet NoCafRefs) (error "no arity"))
+ | b <- binders ]
+
+ caf_info = hasCafRefss env1{-NB: not env'-} rhss
+
+ env' = extendVarEnvList env
+ [ (b, LetBound (TopLet caf_info) (manifestArity rhs))
+ | (b,rhs) <- pairs ]
+
+ (stg_rhss, fvs', lv_info)
+ = initLne env' (
+ mapAndUnzip3Lne (coreToStgRhs body_fvs TopLevel) pairs
+ `thenLne` \ (stg_rhss, fvss', _) ->
+ let fvs' = unionFVInfos fvss' in
+ freeVarsToLiveVars fvs' `thenLne` \ lv_info ->
+ returnLne (stg_rhss, fvs', lv_info)
+ )
+
+ bind = StgRec (mkSRT lv_info) (zip binders stg_rhss)
+ in
+ ASSERT2(and [isLocalId bndr || manifestArity rhs == idArity bndr | (bndr,rhs) <- pairs], ppr binders)
+ ASSERT2(and [manifestArity rhs == stgRhsArity stg_rhs | (rhs,stg_rhs) <- rhss `zip` stg_rhss], ppr binders)
+ ASSERT2(consistent caf_info bind, ppr binders)
+-- WARN(not (consistent caf_info bind), ppr binders <+> ppr cafs <+> ppCafInfo caf_info)
+ (env', fvs' `unionFVInfo` body_fvs, bind)
+
+-- assertion helper
+consistent caf_info bind = mayHaveCafRefs caf_info == stgBindHasCafRefs bind