#include "HsVersions.h"
import CoreSyn
-import CoreUtils
+import CoreUtils ( rhsIsStatic, manifestArity, exprType )
import StgSyn
import Type
import TyCon ( isAlgTyCon )
-import Literal
import Id
-import Var ( Var, globalIdDetails, varType )
+import Var ( Var, globalIdDetails, idType )
+import TyCon ( isUnboxedTupleTyCon, isPrimTyCon, isFunTyCon, isHiBootTyCon )
#ifdef ILX
import MkId ( unsafeCoerceId )
#endif
env' = extendVarEnv env id how_bound
how_bound = LetBound TopLet (manifestArity rhs)
- (stg_rhs, fvs', lv_info) =
+ (stg_rhs, fvs') =
initLne env (
coreToTopStgRhs body_fvs (id,rhs) `thenLne` \ (stg_rhs, fvs') ->
- freeVarsToLiveVars fvs' `thenLne` \ lv_info ->
- returnLne (stg_rhs, fvs', lv_info)
+ returnLne (stg_rhs, fvs')
)
- bind = StgNonRec (mkSRT lv_info) id stg_rhs
+ bind = StgNonRec id stg_rhs
in
ASSERT2(manifestArity rhs == stgRhsArity stg_rhs, ppr id)
ASSERT2(consistentCafInfo id bind, ppr id)
| (b, rhs) <- pairs ]
env' = extendVarEnvList env extra_env'
- (stg_rhss, fvs', lv_info)
+ (stg_rhss, fvs')
= initLne env' (
mapAndUnzipLne (coreToTopStgRhs body_fvs) pairs
`thenLne` \ (stg_rhss, fvss') ->
let fvs' = unionFVInfos fvss' in
- freeVarsToLiveVars fvs' `thenLne` \ lv_info ->
- returnLne (stg_rhss, fvs', lv_info)
+ returnLne (stg_rhss, fvs')
)
- bind = StgRec (mkSRT lv_info) (zip binders stg_rhss)
+ bind = StgRec (zip binders stg_rhss)
in
ASSERT2(and [manifestArity rhs == stgRhsArity stg_rhs | (rhs,stg_rhs) <- rhss `zip` stg_rhss], ppr binders)
ASSERT2(consistentCafInfo (head binders) bind, ppr binders)
--- WARN(not (consistent caf_info bind), ppr binders <+> ppr cafs <+> ppCafInfo caf_info)
(env', fvs' `unionFVInfo` body_fvs, bind)
#ifdef DEBUG
-- floated out a binding, in which case it will be approximate.
consistentCafInfo id bind
| occNameFS (nameOccName (idName id)) == FSLIT("sat")
- = id_marked_caffy || not binding_is_caffy
+ = safe
| otherwise
- = id_marked_caffy == binding_is_caffy
+ = WARN (not exact, ppr id) safe
where
+ safe = id_marked_caffy || not binding_is_caffy
+ exact = id_marked_caffy == binding_is_caffy
id_marked_caffy = mayHaveCafRefs (idCafInfo id)
binding_is_caffy = stgBindHasCafRefs bind
#endif
coreToTopStgRhs scope_fv_info (bndr, rhs)
= coreToStgExpr rhs `thenLne` \ (new_rhs, rhs_fvs, _) ->
- returnLne (mkTopStgRhs upd rhs_fvs bndr_info 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
+ is_static = rhsIsStatic rhs
- upd | rhsIsNonUpd rhs = SingleEntry
- | otherwise = Updatable
+mkTopStgRhs :: Bool -> FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr
+ -> StgRhs
-mkTopStgRhs :: UpdateFlag -> FreeVarsInfo -> StgBinderInfo -> StgExpr -> StgRhs
-
-mkTopStgRhs upd rhs_fvs binder_info (StgLam _ bndrs body)
- = StgRhsClosure noCCS binder_info
+mkTopStgRhs is_static rhs_fvs srt binder_info (StgLam _ bndrs body)
+ = ASSERT( is_static )
+ StgRhsClosure noCCS binder_info
(getFVs rhs_fvs)
ReEntrant
+ srt
bndrs body
-mkTopStgRhs upd rhs_fvs binder_info (StgConApp con args)
- | not (isUpdatable upd) -- StgConApps can be updatable (see isCrossDllConApp)
+mkTopStgRhs is_static rhs_fvs srt binder_info (StgConApp con args)
+ | is_static -- StgConApps can be updatable (see isCrossDllConApp)
= StgRhsCon noCCS con args
-mkTopStgRhs upd rhs_fvs binder_info rhs
- = StgRhsClosure noCCS binder_info
+mkTopStgRhs is_static rhs_fvs srt binder_info rhs
+ = ASSERT2( not is_static, ppr rhs )
+ StgRhsClosure noCCS binder_info
(getFVs rhs_fvs)
- upd
+ Updatable
+ srt
[] rhs
\end{code}
coreToStgExpr (Case scrut bndr alts)
= extendVarEnvLne [(bndr, LambdaBound)] (
mapAndUnzip3Lne vars_alt alts `thenLne` \ (alts2, fvs_s, escs_s) ->
- returnLne ( mkStgAlts (idType bndr) alts2,
+ returnLne ( alts2,
unionFVInfos fvs_s,
unionVarSets escs_s )
) `thenLne` \ (alts2, alts_fvs, alts_escs) ->
(getLiveVars alts_lv_info)
bndr'
(mkSRT alts_lv_info)
+ (mkStgAltType (idType bndr))
alts2,
scrut_fvs `unionFVInfo` alts_fvs_wo_bndr,
alts_escs_wo_bndr `unionVarSet` getFVSet scrut_fvs
\end{code}
\begin{code}
-mkStgAlts scrut_ty orig_alts
- | is_prim_case = StgPrimAlts (tyConAppTyCon scrut_ty) prim_alts deflt
- | otherwise = StgAlgAlts maybe_tycon alg_alts deflt
- where
- is_prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty)
-
- prim_alts = [(lit, rhs) | (LitAlt lit, _, _, rhs) <- other_alts]
- alg_alts = [(con, bndrs, use, rhs) | (DataAlt con, bndrs, use, rhs) <- other_alts]
-
- (other_alts, deflt)
- = case orig_alts of -- DEFAULT is always first if it's there at all
- (DEFAULT, _, _, rhs) : other_alts -> (other_alts, StgBindDefault rhs)
- other -> (orig_alts, StgNoDefault)
-
- maybe_tycon = case alg_alts of
- -- Get the tycon from the data con
- (dc, _, _, _) : _rest -> Just (dataConTyCon dc)
-
- -- Otherwise just do your best
- [] -> case splitTyConApp_maybe (repType scrut_ty) of
- Just (tc,_) | isAlgTyCon tc -> Just tc
- _other -> Nothing
+mkStgAltType scrut_ty
+ = case splitTyConApp_maybe (repType scrut_ty) of
+ Just (tc,_) | isUnboxedTupleTyCon tc -> UbxTupAlt tc
+ | isPrimTyCon tc -> PrimAlt tc
+ | isHiBootTyCon tc -> PolyAlt -- Algebraic, but no constructors visible
+ | isAlgTyCon tc -> AlgAlt tc
+ | isFunTyCon tc -> PolyAlt
+ | otherwise -> pprPanic "mkStgAlts" (ppr tc)
+ Nothing -> PolyAlt
\end{code}
-- Here the free variables are "f", "x" AND the type variable "a"
-- coreToStgArgs will deal with the arguments recursively
if opt_RuntimeTypes then
- fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType (varType f))
+ fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType (idType f))
else fvs
-- Mostly, the arity info of a function is in the fn's IdInfo
vars_bind body_fvs (NonRec binder rhs)
- = coreToStgRhs body_fvs (binder,rhs)
- `thenLne` \ (rhs2, bind_fvs, escs) ->
-
- freeVarsToLiveVars bind_fvs `thenLne` \ bind_lv_info ->
+ = coreToStgRhs body_fvs [] (binder,rhs)
+ `thenLne` \ (rhs2, bind_fvs, bind_lv_info, escs) ->
let
env_ext_item = mk_binding bind_lv_info binder rhs
in
- returnLne (StgNonRec (mkSRT bind_lv_info) binder rhs2,
+ returnLne (StgNonRec binder rhs2,
bind_fvs, escs, bind_lv_info, [env_ext_item])
| (b,rhs) <- pairs ]
in
extendVarEnvLne env_ext (
- mapAndUnzip3Lne (coreToStgRhs rec_scope_fvs) pairs
- `thenLne` \ (rhss2, fvss, escss) ->
+ mapAndUnzip4Lne (coreToStgRhs rec_scope_fvs binders) pairs
+ `thenLne` \ (rhss2, fvss, lv_infos, escss) ->
let
bind_fvs = unionFVInfos fvss
+ bind_lv_info = foldr unionLiveInfo emptyLiveInfo lv_infos
escs = unionVarSets escss
in
- freeVarsToLiveVars (binders `minusFVBinders` bind_fvs)
- `thenLne` \ bind_lv_info ->
-
- returnLne (StgRec (mkSRT bind_lv_info) (binders `zip` rhss2),
+ returnLne (StgRec (binders `zip` rhss2),
bind_fvs, escs, bind_lv_info, env_ext)
)
)
\begin{code}
coreToStgRhs :: FreeVarsInfo -- Free var info for the scope of the binding
+ -> [Id]
-> (Id,CoreExpr)
- -> LneM (StgRhs, FreeVarsInfo, EscVarsSet)
+ -> LneM (StgRhs, FreeVarsInfo, LiveInfo, EscVarsSet)
-coreToStgRhs scope_fv_info (bndr, rhs)
+coreToStgRhs scope_fv_info binders (bndr, rhs)
= coreToStgExpr rhs `thenLne` \ (new_rhs, rhs_fvs, rhs_escs) ->
getEnvLne `thenLne` \ env ->
- returnLne (mkStgRhs env rhs_fvs bndr_info new_rhs,
- rhs_fvs, rhs_escs)
+ freeVarsToLiveVars (binders `minusFVBinders` rhs_fvs) `thenLne` \ lv_info ->
+ returnLne (mkStgRhs rhs_fvs (mkSRT lv_info) bndr_info new_rhs,
+ rhs_fvs, lv_info, rhs_escs)
where
bndr_info = lookupFVInfo scope_fv_info bndr
-mkStgRhs :: IdEnv HowBound -> FreeVarsInfo -> StgBinderInfo -> StgExpr -> StgRhs
+mkStgRhs :: FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr -> StgRhs
-mkStgRhs env rhs_fvs binder_info (StgConApp con args)
+mkStgRhs rhs_fvs srt binder_info (StgConApp con args)
= StgRhsCon noCCS con args
-mkStgRhs env rhs_fvs binder_info (StgLam _ bndrs body)
+mkStgRhs rhs_fvs srt binder_info (StgLam _ bndrs body)
= StgRhsClosure noCCS binder_info
(getFVs rhs_fvs)
ReEntrant
- bndrs body
+ srt bndrs body
-mkStgRhs env rhs_fvs binder_info rhs
+mkStgRhs rhs_fvs srt binder_info rhs
= StgRhsClosure noCCS binder_info
(getFVs rhs_fvs)
- upd_flag [] rhs
+ upd_flag srt [] rhs
where
upd_flag = Updatable
{-
thenLne m k env lvs_cont
= k (m env lvs_cont) env lvs_cont
-mapLne :: (a -> LneM b) -> [a] -> LneM [b]
-mapLne f [] = returnLne []
-mapLne f (x:xs)
- = f x `thenLne` \ r ->
- mapLne f xs `thenLne` \ rs ->
- returnLne (r:rs)
-
mapAndUnzipLne :: (a -> LneM (b,c)) -> [a] -> LneM ([b],[c])
-
mapAndUnzipLne f [] = returnLne ([],[])
mapAndUnzipLne f (x:xs)
= f x `thenLne` \ (r1, r2) ->
returnLne (r1:rs1, r2:rs2)
mapAndUnzip3Lne :: (a -> LneM (b,c,d)) -> [a] -> LneM ([b],[c],[d])
-
mapAndUnzip3Lne f [] = returnLne ([],[],[])
mapAndUnzip3Lne f (x:xs)
= f x `thenLne` \ (r1, r2, r3) ->
mapAndUnzip3Lne f xs `thenLne` \ (rs1, rs2, rs3) ->
returnLne (r1:rs1, r2:rs2, r3:rs3)
+mapAndUnzip4Lne :: (a -> LneM (b,c,d,e)) -> [a] -> LneM ([b],[c],[d],[e])
+mapAndUnzip4Lne f [] = returnLne ([],[],[],[])
+mapAndUnzip4Lne f (x:xs)
+ = f x `thenLne` \ (r1, r2, r3, r4) ->
+ mapAndUnzip4Lne f xs `thenLne` \ (rs1, rs2, rs3, rs4) ->
+ returnLne (r1:rs1, r2:rs2, r3:rs3, r4:rs4)
+
fixLne :: (a -> LneM a) -> LneM a
fixLne expr env lvs_cont
= result
projects / ghc-hetmet.git / blobdiff