let-no-escapes.
\begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
module CoreToStg ( coreToStg, coreExprToStg ) where
#include "HsVersions.h"
import StgSyn
import Type
-import TyCon ( isAlgTyCon )
+import TyCon
import Id
import Var ( Var, globalIdDetails, idType )
-import TyCon ( isUnboxedTupleTyCon, isPrimTyCon, isFunTyCon, isHiBootTyCon )
-#ifdef ILX
-import MkId ( unsafeCoerceId )
-#endif
import IdInfo
import DataCon
import CostCentre ( noCCS )
import Name ( getOccName, isExternalName, nameOccName )
import OccName ( occNameString, occNameFS )
import BasicTypes ( Arity )
-import Packages ( HomeModules )
import StaticFlags ( opt_RuntimeTypes )
+import PackageConfig ( PackageId )
import Outputable
infixr 9 `thenLne`
%************************************************************************
\begin{code}
-coreToStg :: HomeModules -> [CoreBind] -> IO [StgBinding]
-coreToStg hmods pgm
+coreToStg :: PackageId -> [CoreBind] -> IO [StgBinding]
+coreToStg this_pkg pgm
= return pgm'
- where (_, _, pgm') = coreTopBindsToStg hmods emptyVarEnv pgm
+ where (_, _, pgm') = coreTopBindsToStg this_pkg emptyVarEnv pgm
coreExprToStg :: CoreExpr -> StgExpr
coreExprToStg expr
coreTopBindsToStg
- :: HomeModules
+ :: PackageId
-> 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)
= (env2, fvs2, b':bs')
where
-- env accumulates down the list of binds, fvs accumulates upwards
- (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
coreTopBindToStg
- :: HomeModules
+ :: PackageId
-> IdEnv HowBound
-> FreeVarsInfo -- Info about the body
-> CoreBind
-> (IdEnv HowBound, FreeVarsInfo, StgBinding)
-coreTopBindToStg hmods env body_fvs (NonRec id rhs)
+coreTopBindToStg this_pkg env body_fvs (NonRec id rhs)
= let
env' = extendVarEnv env id how_bound
how_bound = LetBound TopLet $! manifestArity rhs
(stg_rhs, fvs') =
initLne env (
- coreToTopStgRhs hmods body_fvs (id,rhs) `thenLne` \ (stg_rhs, fvs') ->
+ coreToTopStgRhs this_pkg body_fvs (id,rhs) `thenLne` \ (stg_rhs, fvs') ->
returnLne (stg_rhs, fvs')
)
bind = StgNonRec id stg_rhs
in
- ASSERT2(manifestArity rhs == stgRhsArity stg_rhs, ppr id)
+ ASSERT2(manifestArity rhs == stgRhsArity stg_rhs, ppr id $$ (ptext SLIT("rhs:")) <+> ppr rhs $$ (ptext SLIT("stg_rhs:"))<+> ppr stg_rhs $$ (ptext SLIT("Manifest:")) <+> (ppr $ manifestArity rhs) $$ (ptext SLIT("STG:")) <+>(ppr $ stgRhsArity stg_rhs) )
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)
-coreTopBindToStg hmods env body_fvs (Rec pairs)
+coreTopBindToStg this_pkg env body_fvs (Rec pairs)
= let
(binders, rhss) = unzip pairs
(stg_rhss, fvs')
= initLne env' (
- mapAndUnzipLne (coreToTopStgRhs hmods body_fvs) pairs
+ mapAndUnzipLne (coreToTopStgRhs this_pkg body_fvs) pairs
`thenLne` \ (stg_rhss, fvss') ->
let fvs' = unionFVInfos fvss' in
returnLne (stg_rhss, fvs')
ASSERT2(consistentCafInfo (head binders) bind, ppr binders)
(env', fvs' `unionFVInfo` body_fvs, bind)
-#ifdef DEBUG
-- Assertion helper: this checks that the CafInfo on the Id matches
-- what CoreToStg has figured out about the binding's SRT. The
-- CafInfo will be exact in all cases except when CorePrep has
exact = id_marked_caffy == binding_is_caffy
id_marked_caffy = mayHaveCafRefs (idCafInfo id)
binding_is_caffy = stgBindHasCafRefs bind
-#endif
\end{code}
\begin{code}
coreToTopStgRhs
- :: HomeModules
+ :: PackageId
-> FreeVarsInfo -- Free var info for the scope of the binding
-> (Id,CoreExpr)
-> LneM (StgRhs, FreeVarsInfo)
-coreToTopStgRhs hmods scope_fv_info (bndr, rhs)
+coreToTopStgRhs this_pkg scope_fv_info (bndr, rhs)
= 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
- is_static = rhsIsStatic hmods rhs
+ is_static = rhsIsStatic this_pkg rhs
mkTopStgRhs :: Bool -> FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr
-> StgRhs
= coreToStgExpr expr `thenLne` ( \ (expr2, fvs, escs) ->
returnLne (StgSCC cc expr2, fvs, escs) )
-#ifdef ILX
--- For ILX, convert (__coerce__ to_ty from_ty e)
--- into (coerce to_ty from_ty e)
--- where coerce is real function
-coreToStgExpr (Note (Coerce to_ty from_ty) expr)
- = coreToStgExpr (mkApps (Var unsafeCoerceId)
- [Type from_ty, Type to_ty, expr])
-#endif
+coreToStgExpr (Case (Var id) _bndr ty [(DEFAULT,[],expr)])
+ | Just (TickBox m n) <- isTickBoxOp_maybe id
+ = coreToStgExpr expr `thenLne` ( \ (expr2, fvs, escs) ->
+ returnLne (StgTick m n expr2, fvs, escs) )
coreToStgExpr (Note other_note expr)
= coreToStgExpr expr
+coreToStgExpr (Cast expr co)
+ = coreToStgExpr expr
+
-- Cases require a little more real work.
coreToStgExpr (Case scrut bndr _ alts)
mkStgAltType scrut_ty alts
= case splitTyConApp_maybe (repType scrut_ty) of
Just (tc,_) | isUnboxedTupleTyCon tc -> UbxTupAlt tc
- | isPrimTyCon tc -> PrimAlt tc
+ | isUnLiftedTyCon tc -> PrimAlt tc
| isHiBootTyCon tc -> look_for_better_tycon
| isAlgTyCon tc -> AlgAlt tc
| isFunTyCon tc -> PolyAlt
+ | isPrimTyCon tc -> PolyAlt -- for "Any"
| otherwise -> pprPanic "mkStgAlts" (ppr tc)
Nothing -> PolyAlt
-> [CoreArg] -- Arguments
-> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
+
coreToStgApp maybe_thunk_body f args
= coreToStgArgs args `thenLne` \ (args', args_fvs) ->
lookupVarLne f `thenLne` \ how_bound ->
res_ty = exprType (mkApps (Var f) args)
app = case globalIdDetails f of
DataConWorkId dc | saturated -> StgConApp dc args'
- PrimOpId op -> ASSERT( saturated )
- StgOpApp (StgPrimOp op) args' res_ty
+ PrimOpId op -> ASSERT( saturated )
+ StgOpApp (StgPrimOp op) args' res_ty
FCallId call -> ASSERT( saturated )
StgOpApp (StgFCallOp call (idUnique f)) args' res_ty
+ TickBoxOpId {} -> pprPanic "coreToStg TickBox" $ ppr (f,args')
_other -> StgApp f args'
in
StgLit lit -> StgLitArg lit
_ -> pprPanic "coreToStgArgs" (ppr arg)
in
+ -- WARNING: what if we have an argument like (v `cast` co)
+ -- where 'co' changes the representation type?
+ -- (This really only happens if co is unsafe.)
+ -- Then all the getArgAmode stuff in CgBindery will set the
+ -- cg_rep of the CgIdInfo based on the type of v, rather
+ -- than the type of 'co'.
+ -- This matters particularly when the function is a primop
+ -- or foreign call.
+ -- Wanted: a better solution than this hacky warning
+ let
+ arg_ty = exprType arg
+ stg_arg_ty = stgArgType stg_arg
+ in
+ WARN( isUnLiftedType arg_ty /= isUnLiftedType stg_arg_ty,
+ ptext SLIT("Dangerous-looking argument. Probable cause: bad unsafeCoerce#") $$ ppr arg)
returnLne (stg_arg : stg_args, fvs)
= ASSERT (id1 == id2 && hb1 `check_eq_how_bound` hb2)
(id1, hb1, combineStgBinderInfo info1 info2)
-#ifdef DEBUG
-- The HowBound info for a variable in the FVInfo should be consistent
check_eq_how_bound ImportBound ImportBound = True
check_eq_how_bound LambdaBound LambdaBound = True
check_eq_li (NestedLet _) (NestedLet _) = True
check_eq_li TopLet TopLet = True
check_eq_li li1 li2 = False
-#endif
\end{code}
Misc.
where
go bs (Lam b e) = go (b:bs) e
go bs e@(Note (SCC _) _) = (reverse bs, e)
+ go bs (Cast e co) = go bs e
go bs (Note _ e) = go bs e
go bs e = (reverse bs, e)
go (Var v) as = (v, as)
go (App f a) as = go f (a:as)
go (Note (SCC _) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
+ go (Cast e co) as = go e as
go (Note n e) as = go e as
go _ as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
\end{code}