#include "HsVersions.h"
import CoreSyn
-import CoreUtils
+import CoreUtils ( rhsIsStatic, manifestArity, exprType, findDefault )
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
import VarEnv
import Maybes ( maybeToBool )
import Name ( getOccName, isExternalName, nameOccName )
-import OccName ( occNameUserString, occNameFS )
+import OccName ( occNameString, occNameFS )
import BasicTypes ( Arity )
-import CmdLineOpts ( DynFlags, opt_RuntimeTypes )
+import Packages ( HomeModules )
+import StaticFlags ( opt_RuntimeTypes )
import Outputable
infixr 9 `thenLne`
%************************************************************************
\begin{code}
-coreToStg :: DynFlags -> [CoreBind] -> IO [StgBinding]
-coreToStg dflags pgm
+coreToStg :: HomeModules -> [CoreBind] -> IO [StgBinding]
+coreToStg hmods pgm
= return pgm'
- where (_, _, pgm') = coreTopBindsToStg emptyVarEnv pgm
+ where (_, _, pgm') = coreTopBindsToStg hmods emptyVarEnv pgm
coreExprToStg :: CoreExpr -> StgExpr
coreExprToStg expr
coreTopBindsToStg
- :: IdEnv HowBound -- environment for the bindings
+ :: HomeModules
+ -> IdEnv HowBound -- environment for the bindings
-> [CoreBind]
-> (IdEnv HowBound, FreeVarsInfo, [StgBinding])
-coreTopBindsToStg env [] = (env, emptyFVInfo, [])
-coreTopBindsToStg env (b:bs)
+coreTopBindsToStg hmods env [] = (env, emptyFVInfo, [])
+coreTopBindsToStg hmods 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
+ (env1, fvs2, b' ) = coreTopBindToStg hmods env fvs1 b
+ (env2, fvs1, bs') = coreTopBindsToStg hmods env1 bs
coreTopBindToStg
- :: IdEnv HowBound
+ :: HomeModules
+ -> IdEnv HowBound
-> FreeVarsInfo -- Info about the body
-> CoreBind
-> (IdEnv HowBound, FreeVarsInfo, StgBinding)
-coreTopBindToStg env body_fvs (NonRec id rhs)
+coreTopBindToStg hmods env body_fvs (NonRec id rhs)
= let
env' = extendVarEnv env id how_bound
- how_bound = LetBound TopLet (manifestArity rhs)
+ how_bound = LetBound TopLet $! manifestArity rhs
(stg_rhs, fvs') =
initLne env (
- coreToTopStgRhs body_fvs (id,rhs) `thenLne` \ (stg_rhs, fvs') ->
+ coreToTopStgRhs hmods body_fvs (id,rhs) `thenLne` \ (stg_rhs, fvs') ->
returnLne (stg_rhs, fvs')
)
-- 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)
+coreTopBindToStg hmods env body_fvs (Rec pairs)
= let
(binders, rhss) = unzip pairs
- extra_env' = [ (b, LetBound TopLet (manifestArity rhs))
+ extra_env' = [ (b, LetBound TopLet $! manifestArity rhs)
| (b, rhs) <- pairs ]
env' = extendVarEnvList env extra_env'
(stg_rhss, fvs')
= initLne env' (
- mapAndUnzipLne (coreToTopStgRhs body_fvs) pairs
+ mapAndUnzipLne (coreToTopStgRhs hmods body_fvs) pairs
`thenLne` \ (stg_rhss, fvss') ->
let fvs' = unionFVInfos fvss' in
returnLne (stg_rhss, fvs')
\begin{code}
coreToTopStgRhs
- :: FreeVarsInfo -- Free var info for the scope of the binding
+ :: HomeModules
+ -> FreeVarsInfo -- Free var info for the scope of the binding
-> (Id,CoreExpr)
-> LneM (StgRhs, FreeVarsInfo)
-coreToTopStgRhs scope_fv_info (bndr, rhs)
+coreToTopStgRhs hmods scope_fv_info (bndr, rhs)
= coreToStgExpr rhs `thenLne` \ (new_rhs, rhs_fvs, _) ->
freeVarsToLiveVars rhs_fvs `thenLne` \ lv_info ->
- returnLne (mkTopStgRhs upd rhs_fvs (mkSRT lv_info) bndr_info new_rhs, rhs_fvs)
+ 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 hmods rhs
- upd | rhsIsNonUpd rhs = SingleEntry
- | otherwise = Updatable
-
-mkTopStgRhs :: UpdateFlag -> FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr
+mkTopStgRhs :: Bool -> FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr
-> StgRhs
-mkTopStgRhs upd rhs_fvs srt 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 srt 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 srt 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}
-- Cases require a little more real work.
-coreToStgExpr (Case scrut bndr alts)
+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) alts)
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)
+mkStgAltType scrut_ty alts
+ = case splitTyConApp_maybe (repType scrut_ty) of
+ Just (tc,_) | isUnboxedTupleTyCon tc -> UbxTupAlt tc
+ | isPrimTyCon tc -> PrimAlt tc
+ | isHiBootTyCon tc -> look_for_better_tycon
+ | isAlgTyCon tc -> AlgAlt tc
+ | isFunTyCon tc -> PolyAlt
+ | otherwise -> pprPanic "mkStgAlts" (ppr tc)
+ Nothing -> PolyAlt
- -- Otherwise just do your best
- [] -> case splitTyConApp_maybe (repType scrut_ty) of
- Just (tc,_) | isAlgTyCon tc -> Just tc
- _other -> Nothing
+ where
+ -- Sometimes, the TyCon in the type of the scrutinee is an HiBootTyCon,
+ -- which may not have any constructors inside it. If so, then we
+ -- can get a better TyCon by grabbing the one from a constructor alternative
+ -- if one exists.
+ look_for_better_tycon
+ | ((DataAlt con, _, _) : _) <- data_alts =
+ AlgAlt (dataConTyCon con)
+ | otherwise =
+ ASSERT(null data_alts)
+ PolyAlt
+ where
+ (data_alts, _deflt) = findDefault alts
\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
is_join_var :: Id -> Bool
-- A hack (used only for compiler debuggging) to tell if
-- a variable started life as a join point ($j)
-is_join_var j = occNameUserString (getOccName j) == "$j"
+is_join_var j = occNameString (getOccName j) == "$j"
\end{code}
\begin{code}
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) ->
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) ->
Just (_,_,info) -> info
allFreeIds :: FreeVarsInfo -> [(Id,HowBound)] -- Both top level and non-top-level Ids
-allFreeIds fvs = [(id,how_bound) | (id,how_bound,_) <- rngVarEnv fvs, isId id]
+allFreeIds fvs = [(id,how_bound) | (id,how_bound,_) <- varEnvElts fvs, isId id]
-- Non-top-level things only, both type variables and ids
-- (type variables only if opt_RuntimeTypes)
getFVs :: FreeVarsInfo -> [Var]
-getFVs fvs = [id | (id, how_bound, _) <- rngVarEnv fvs,
+getFVs fvs = [id | (id, how_bound, _) <- varEnvElts fvs,
not (topLevelBound how_bound) ]
getFVSet :: FreeVarsInfo -> VarSet