import TyCon ( isAlgTyCon )
import Id
import Var ( Var, globalIdDetails, idType )
import TyCon ( isAlgTyCon )
import Id
import Var ( Var, globalIdDetails, idType )
import Name ( getOccName, isExternalName, nameOccName )
import OccName ( occNameString, occNameFS )
import BasicTypes ( Arity )
import Name ( getOccName, isExternalName, nameOccName )
import OccName ( occNameString, occNameFS )
import BasicTypes ( Arity )
-> IdEnv HowBound -- environment for the bindings
-> [CoreBind]
-> (IdEnv HowBound, FreeVarsInfo, [StgBinding])
-> IdEnv HowBound -- environment for the bindings
-> [CoreBind]
-> (IdEnv HowBound, FreeVarsInfo, [StgBinding])
-coreTopBindsToStg hmods env [] = (env, emptyFVInfo, [])
-coreTopBindsToStg hmods env (b:bs)
+coreTopBindsToStg this_pkg env [] = (env, emptyFVInfo, [])
+coreTopBindsToStg this_pkg env (b:bs)
- (env1, fvs2, b' ) = coreTopBindToStg hmods env fvs1 b
- (env2, fvs1, bs') = coreTopBindsToStg hmods env1 bs
+ (env1, fvs2, b' ) = coreTopBindToStg this_pkg env fvs1 b
+ (env2, fvs1, bs') = coreTopBindsToStg this_pkg env1 bs
-> IdEnv HowBound
-> FreeVarsInfo -- Info about the body
-> CoreBind
-> (IdEnv HowBound, FreeVarsInfo, StgBinding)
-> IdEnv HowBound
-> FreeVarsInfo -- Info about the body
-> CoreBind
-> (IdEnv HowBound, FreeVarsInfo, StgBinding)
returnLne (stg_rhs, fvs')
)
bind = StgNonRec id stg_rhs
in
returnLne (stg_rhs, fvs')
)
bind = StgNonRec id stg_rhs
in
ASSERT2(consistentCafInfo id bind, ppr id)
-- WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info)
(env', fvs' `unionFVInfo` body_fvs, bind)
ASSERT2(consistentCafInfo id bind, ppr id)
-- WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info)
(env', fvs' `unionFVInfo` body_fvs, bind)
`thenLne` \ (stg_rhss, fvss') ->
let fvs' = unionFVInfos fvss' in
returnLne (stg_rhss, fvs')
`thenLne` \ (stg_rhss, fvss') ->
let fvs' = unionFVInfos fvss' in
returnLne (stg_rhss, fvs')
-> FreeVarsInfo -- Free var info for the scope of the binding
-> (Id,CoreExpr)
-> LneM (StgRhs, FreeVarsInfo)
-> FreeVarsInfo -- Free var info for the scope of the binding
-> (Id,CoreExpr)
-> LneM (StgRhs, FreeVarsInfo)
= coreToStgExpr rhs `thenLne` \ (new_rhs, rhs_fvs, _) ->
freeVarsToLiveVars rhs_fvs `thenLne` \ lv_info ->
returnLne (mkTopStgRhs is_static rhs_fvs (mkSRT lv_info) bndr_info new_rhs, rhs_fvs)
where
bndr_info = lookupFVInfo scope_fv_info bndr
= coreToStgExpr rhs `thenLne` \ (new_rhs, rhs_fvs, _) ->
freeVarsToLiveVars rhs_fvs `thenLne` \ lv_info ->
returnLne (mkTopStgRhs is_static rhs_fvs (mkSRT lv_info) bndr_info new_rhs, rhs_fvs)
where
bndr_info = lookupFVInfo scope_fv_info bndr
--- For ILX, convert (__coerce__ to_ty from_ty e)
--- into (coerce to_ty from_ty e)
+-- For ILX, convert (__coerce__ to_ty from_ty e)
+-- into (coerce to_ty from_ty e)
-coreToStgExpr (Note (Coerce to_ty from_ty) expr)
- = coreToStgExpr (mkApps (Var unsafeCoerceId)
- [Type from_ty, Type to_ty, expr])
+coreToStgExpr (Cast expr co)
+ = let (from_ty, ty_ty) = coercionKind co in
+ coreToStgExpr (mkApps (Var unsafeCoerceId)
+ [Type from_ty, Type to_ty, expr])
where
go bs (Lam b e) = go (b:bs) e
go bs e@(Note (SCC _) _) = (reverse bs, e)
where
go bs (Lam b e) = go (b:bs) e
go bs e@(Note (SCC _) _) = (reverse bs, e)
go bs (Note _ e) = go bs e
go bs e = (reverse bs, e)
go bs (Note _ e) = go bs e
go bs e = (reverse bs, e)