+\begin{code}
+coreToStg :: DynFlags -> [CoreBind] -> IO [StgBinding]
+coreToStg dflags pgm
+ = return pgm'
+ where (_, _, pgm') = coreTopBindsToStg emptyVarEnv pgm
+
+coreExprToStg :: CoreExpr -> StgExpr
+coreExprToStg expr
+ = new_expr where (new_expr,_,_) = initLne emptyVarEnv (coreToStgExpr expr)
+
+
+coreTopBindsToStg
+ :: IdEnv HowBound -- environment for the bindings
+ -> [CoreBind]
+ -> (IdEnv HowBound, FreeVarsInfo, [StgBinding])
+
+coreTopBindsToStg env [] = (env, emptyFVInfo, [])
+coreTopBindsToStg env (b:bs)
+ = (env2, fvs2, b':bs')
+ where
+ -- 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) (predictArity 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(predictArity 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) (predictArity 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 [predictArity 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
+\end{code}
+
+\begin{code}
+coreToStgRhs
+ :: FreeVarsInfo -- Free var info for the scope of the binding
+ -> TopLevelFlag
+ -> (Id,CoreExpr)
+ -> LneM (StgRhs, FreeVarsInfo, EscVarsSet)
+
+coreToStgRhs scope_fv_info top (binder, rhs)
+ = coreToStgExpr rhs `thenLne` \ (new_rhs, rhs_fvs, rhs_escs) ->
+ returnLne (mkStgRhs top rhs_fvs binder_info new_rhs,
+ rhs_fvs, rhs_escs)
+ where
+ binder_info = lookupFVInfo scope_fv_info binder
+
+mkStgRhs :: TopLevelFlag -> FreeVarsInfo -> StgBinderInfo
+ -> StgExpr -> StgRhs
+
+mkStgRhs top rhs_fvs binder_info (StgLam _ bndrs body)
+ = StgRhsClosure noCCS binder_info
+ (getFVs rhs_fvs)
+ ReEntrant
+ bndrs body
+
+mkStgRhs top rhs_fvs binder_info (StgConApp con args)
+ | isNotTopLevel top || not (isDllConApp con args)
+ = StgRhsCon noCCS con args
+
+mkStgRhs top rhs_fvs binder_info rhs
+ = StgRhsClosure noCCS binder_info
+ (getFVs rhs_fvs)
+ (updatable [] rhs)
+ [] rhs
+ where
+ updatable args body | null args && isPAP body = ReEntrant
+ | otherwise = Updatable
+{- ToDo:
+ upd = if isOnceDem dem
+ then (if isNotTop toplev
+ then SingleEntry -- HA! Paydirt for "dem"
+ else
+#ifdef DEBUG
+ trace "WARNING: SE CAFs unsupported, forcing UPD instead" $
+#endif
+ Updatable)
+ else Updatable
+ -- For now we forbid SingleEntry CAFs; they tickle the
+ -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
+ -- and I don't understand why. There's only one SE_CAF (well,
+ -- only one that tickled a great gaping bug in an earlier attempt
+ -- at ClosureInfo.getEntryConvention) in the whole of nofib,
+ -- specifically Main.lvl6 in spectral/cryptarithm2.
+ -- So no great loss. KSW 2000-07.
+-}
+\end{code}
+
+Detect thunks which will reduce immediately to PAPs, and make them
+non-updatable. This has several advantages:
+
+ - the non-updatable thunk behaves exactly like the PAP,
+
+ - the thunk is more efficient to enter, because it is
+ specialised to the task.
+
+ - we save one update frame, one stg_update_PAP, one update
+ and lots of PAP_enters.
+
+ - in the case where the thunk is top-level, we save building
+ a black hole and futhermore the thunk isn't considered to
+ be a CAF any more, so it doesn't appear in any SRTs.
+
+We do it here, because the arity information is accurate, and we need
+to do it before the SRT pass to save the SRT entries associated with
+any top-level PAPs.
+
+\begin{code}
+isPAP (StgApp f args) = idArity f > length args
+isPAP _ = False
+\end{code}
+
+
+-- ---------------------------------------------------------------------------
+-- Expressions
+-- ---------------------------------------------------------------------------