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 CoreSyn
-import CoreUtils ( rhsIsStatic, manifestArity, exprType, findDefault )
+import CoreUtils ( rhsIsStatic, exprType, findDefault )
+import CoreArity ( manifestArity )
import StgSyn
import Type
import TyCon
import Id
-import Var ( Var, globalIdDetails, idType )
+import Var ( Var )
import IdInfo
import DataCon
import CostCentre ( noCCS )
import Name ( getOccName, isExternalName, nameOccName )
import OccName ( occNameString, occNameFS )
import BasicTypes ( Arity )
-import StaticFlags ( opt_RuntimeTypes )
import Module
import Outputable
import MonadUtils
+import FastString
import Util
+import ForeignCall
+import PrimOp ( PrimCall(..) )
\end{code}
%************************************************************************
-> [CoreBind]
-> (IdEnv HowBound, FreeVarsInfo, [StgBinding])
-coreTopBindsToStg this_pkg env [] = (env, emptyFVInfo, [])
+coreTopBindsToStg _ env [] = (env, emptyFVInfo, [])
coreTopBindsToStg this_pkg env (b:bs)
= (env2, fvs2, b':bs')
where
- -- env accumulates down the list of binds, fvs accumulates upwards
+ -- Notice the mutually-recursive "knot" here:
+ -- env accumulates down the list of binds,
+ -- fvs accumulates upwards
(env1, fvs2, b' ) = coreTopBindToStg this_pkg env fvs1 b
(env2, fvs1, bs') = coreTopBindsToStg this_pkg env1 bs
-
coreTopBindToStg
:: PackageId
-> IdEnv HowBound
bind = StgNonRec id stg_rhs
in
- 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)
+ ASSERT2(consistentCafInfo id bind, ppr id $$ ppr rhs $$ ppr bind )
(env', fvs' `unionFVInfo` body_fvs, bind)
coreTopBindToStg this_pkg env body_fvs (Rec pairs)
- = let
- (binders, rhss) = unzip pairs
+ = ASSERT( not (null pairs) )
+ let
+ binders = map fst pairs
extra_env' = [ (b, LetBound TopLet $! manifestArity rhs)
| (b, rhs) <- pairs ]
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)
(env', fvs' `unionFVInfo` body_fvs, bind)
+
-- 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
-- floated out a binding, in which case it will be approximate.
+consistentCafInfo :: Id -> GenStgBinding Var Id -> Bool
consistentCafInfo id bind
- | occNameFS (nameOccName (idName id)) == FSLIT("sat")
+ | occNameFS (nameOccName (idName id)) == fsLit "sat"
= safe
| otherwise
= WARN (not exact, ppr id) safe
-> (Id,CoreExpr)
-> LneM (StgRhs, FreeVarsInfo)
-coreToTopStgRhs this_pkg scope_fv_info (bndr, rhs) = do
- (new_rhs, rhs_fvs, _) <- coreToStgExpr rhs
- lv_info <- freeVarsToLiveVars rhs_fvs
- return (mkTopStgRhs is_static rhs_fvs (mkSRT lv_info) bndr_info new_rhs, rhs_fvs)
+coreToTopStgRhs this_pkg scope_fv_info (bndr, rhs)
+ = do { (new_rhs, rhs_fvs, _) <- coreToStgExpr rhs
+ ; lv_info <- freeVarsToLiveVars rhs_fvs
+
+ ; let stg_rhs = mkTopStgRhs is_static rhs_fvs (mkSRT lv_info) bndr_info new_rhs
+ stg_arity = stgRhsArity stg_rhs
+ ; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs,
+ rhs_fvs) }
where
bndr_info = lookupFVInfo scope_fv_info bndr
is_static = rhsIsStatic this_pkg rhs
-mkTopStgRhs :: Bool -> FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr
- -> StgRhs
+ -- It's vital that the arity on a top-level Id matches
+ -- the arity of the generated STG binding, else an importing
+ -- module will use the wrong calling convention
+ -- (Trac #2844 was an example where this happened)
+ -- NB1: we can't move the assertion further out without
+ -- blocking the "knot" tied in coreTopBindsToStg
+ -- NB2: the arity check is only needed for Ids with External
+ -- Names, because they are externally visible. The CorePrep
+ -- pass introduces "sat" things with Local Names and does
+ -- not bother to set their Arity info, so don't fail for those
+ arity_ok stg_arity
+ | isExternalName (idName bndr) = id_arity == stg_arity
+ | otherwise = True
+ id_arity = idArity bndr
+ mk_arity_msg stg_arity
+ = vcat [ppr bndr,
+ ptext (sLit "Id arity:") <+> ppr id_arity,
+ ptext (sLit "STG arity:") <+> ppr stg_arity]
+
+mkTopStgRhs :: Bool -> FreeVarsInfo
+ -> SRT -> StgBinderInfo -> StgExpr
+ -> StgRhs
mkTopStgRhs is_static rhs_fvs srt binder_info (StgLam _ bndrs body)
= ASSERT( is_static )
ReEntrant
srt
bndrs body
-
-mkTopStgRhs is_static rhs_fvs srt binder_info (StgConApp con args)
+
+mkTopStgRhs is_static _ _ _ (StgConApp con args)
| is_static -- StgConApps can be updatable (see isCrossDllConApp)
= StgRhsCon noCCS con args
(expr2, fvs, escs) <- coreToStgExpr expr
return (StgSCC cc expr2, fvs, escs)
-coreToStgExpr (Case (Var id) _bndr ty [(DEFAULT,[],expr)])
+coreToStgExpr (Case (Var id) _bndr _ty [(DEFAULT,[],expr)])
| Just (TickBox m n) <- isTickBoxOp_maybe id = do
(expr2, fvs, escs) <- coreToStgExpr expr
return (StgTick m n expr2, fvs, escs)
-coreToStgExpr (Note other_note expr)
+coreToStgExpr (Note _ expr)
= coreToStgExpr expr
-coreToStgExpr (Cast expr co)
+coreToStgExpr (Cast expr _)
= coreToStgExpr expr
-- Cases require a little more real work.
-- We tell the scrutinee that everything
-- live in the alts is live in it, too.
- (scrut2, scrut_fvs, scrut_escs, scrut_lv_info)
+ (scrut2, scrut_fvs, _scrut_escs, scrut_lv_info)
<- setVarsLiveInCont alts_lv_info $ do
(scrut2, scrut_fvs, scrut_escs) <- coreToStgExpr scrut
scrut_lv_info <- freeVarsToLiveVars scrut_fvs
)
return (new_let, fvs, escs)
+
+coreToStgExpr e = pprPanic "coreToStgExpr" (ppr e)
\end{code}
\begin{code}
+mkStgAltType :: Id -> [CoreAlt] -> AltType
mkStgAltType bndr alts
= case splitTyConApp_maybe (repType (idType bndr)) of
Just (tc,_) | isUnboxedTupleTyCon tc -> UbxTupAlt tc
| isUnLiftedTyCon tc -> PrimAlt tc
| isHiBootTyCon tc -> look_for_better_tycon
| isAlgTyCon tc -> AlgAlt tc
- | otherwise -> ASSERT( _is_poly_alt_tycon tc )
+ | otherwise -> ASSERT2( _is_poly_alt_tycon tc, ppr tc )
PolyAlt
Nothing -> PolyAlt
-> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
-coreToStgApp maybe_thunk_body f args = do
+coreToStgApp _ f args = do
(args', args_fvs) <- coreToStgArgs args
how_bound <- lookupVarLne f
let
n_val_args = valArgCount args
not_letrec_bound = not (isLetBound how_bound)
- fun_fvs
- = let fvs = singletonFVInfo f how_bound fun_occ in
+ fun_fvs = singletonFVInfo f how_bound fun_occ
-- e.g. (f :: a -> int) (x :: a)
-- 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 (idType f))
- else fvs
-- Mostly, the arity info of a function is in the fn's IdInfo
-- But new bindings introduced by CoreSat may not have no
-- two regardless.
res_ty = exprType (mkApps (Var f) args)
- app = case globalIdDetails f of
+ app = case idDetails f of
DataConWorkId dc | saturated -> StgConApp dc args'
+
+ -- Some primitive operator that might be implemented as a library call.
PrimOpId op -> ASSERT( saturated )
StgOpApp (StgPrimOp op) args' res_ty
+
+ -- A call to some primitive Cmm function.
+ FCallId (CCall (CCallSpec (StaticTarget lbl (Just pkgId)) PrimCallConv _))
+ -> ASSERT( saturated )
+ StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) args' res_ty
+
+ -- A regular foreign call.
FCallId call -> ASSERT( saturated )
StgOpApp (StgFCallOp call (idUnique f)) args' res_ty
+
TickBoxOpId {} -> pprPanic "coreToStg TickBox" $ ppr (f,args')
_other -> StgApp f args'
coreToStgArgs []
= return ([], emptyFVInfo)
-coreToStgArgs (Type ty : args) = do -- Type argument
+coreToStgArgs (Type _ : args) = do -- Type argument
(args', fvs) <- coreToStgArgs args
- if opt_RuntimeTypes then
- return (StgTypeArg ty : args', fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType ty))
- else
- return (args', fvs)
+ return (args', fvs)
coreToStgArgs (arg : args) = do -- Non-type argument
(stg_args, args_fvs) <- coreToStgArgs args
- (arg', arg_fvs, escs) <- coreToStgExpr arg
+ (arg', arg_fvs, _escs) <- coreToStgExpr arg
let
fvs = args_fvs `unionFVInfo` arg_fvs
stg_arg = case arg' of
-- we complain.
-- We also want to check if a pointer is cast to a non-ptr etc
- WARN( bad_args, ptext SLIT("Dangerous-looking argument. Probable cause: bad unsafeCoerce#") $$ ppr arg )
+ WARN( bad_args, ptext (sLit "Dangerous-looking argument. Probable cause: bad unsafeCoerce#") $$ ppr arg )
return (stg_arg : stg_args, fvs)
coreToStgRhs scope_fv_info binders (bndr, rhs) = do
(new_rhs, rhs_fvs, rhs_escs) <- coreToStgExpr rhs
- env <- getEnvLne
lv_info <- freeVarsToLiveVars (binders `minusFVBinders` rhs_fvs)
return (mkStgRhs rhs_fvs (mkSRT lv_info) bndr_info new_rhs,
rhs_fvs, lv_info, rhs_escs)
mkStgRhs :: FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr -> StgRhs
-mkStgRhs rhs_fvs srt binder_info (StgConApp con args)
- = StgRhsCon noCCS con args
+mkStgRhs _ _ _ (StgConApp con args) = StgRhsCon noCCS con args
mkStgRhs rhs_fvs srt binder_info (StgLam _ bndrs body)
= StgRhsClosure noCCS binder_info
-- itself is always a member of
-- the dynamic set of its own LiveInfo
+isLetBound :: HowBound -> Bool
isLetBound (LetBound _ _) = True
-isLetBound other = False
+isLetBound _ = False
-topLevelBound ImportBound = True
+topLevelBound :: HowBound -> Bool
+topLevelBound ImportBound = True
topLevelBound (LetBound TopLet _) = True
-topLevelBound other = False
+topLevelBound _ = False
\end{code}
For a let(rec)-bound variable, x, we record LiveInfo, the set of
{-# INLINE returnLne #-}
returnLne :: a -> LneM a
-returnLne e = LneM $ \env lvs_cont -> e
+returnLne e = LneM $ \_ _ -> e
thenLne :: LneM a -> (a -> LneM b) -> LneM b
thenLne m k = LneM $ \env lvs_cont
\begin{code}
getVarsLiveInCont :: LneM LiveInfo
-getVarsLiveInCont = LneM $ \env lvs_cont -> lvs_cont
+getVarsLiveInCont = LneM $ \_env lvs_cont -> lvs_cont
setVarsLiveInCont :: LiveInfo -> LneM a -> LneM a
setVarsLiveInCont new_lvs_cont expr
- = LneM $ \env lvs_cont
+ = LneM $ \env _lvs_cont
-> unLneM expr env new_lvs_cont
extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a
-> unLneM expr (extendVarEnvList env ids_w_howbound) lvs_cont
lookupVarLne :: Id -> LneM HowBound
-lookupVarLne v = LneM $ \env lvs_cont -> lookupBinding env v
-
-getEnvLne :: LneM (IdEnv HowBound)
-getEnvLne = LneM $ \env lvs_cont -> env
+lookupVarLne v = LneM $ \env _lvs_cont -> lookupBinding env v
lookupBinding :: IdEnv HowBound -> Id -> HowBound
lookupBinding env v = case lookupVarEnv env v of
freeVarsToLiveVars :: FreeVarsInfo -> LneM LiveInfo
freeVarsToLiveVars fvs = LneM freeVarsToLiveVars'
where
- freeVarsToLiveVars' env live_in_cont = live_info
+ freeVarsToLiveVars' _env live_in_cont = live_info
where
live_info = foldr unionLiveInfo live_in_cont lvs_from_fvs
lvs_from_fvs = map do_one (allFreeIds fvs)
| otherwise = emptyVarEnv
singletonFVInfo id how_bound info = unitVarEnv id (id, how_bound, info)
-tyvarFVInfo :: TyVarSet -> FreeVarsInfo
-tyvarFVInfo tvs = foldVarSet add emptyFVInfo tvs
- where
- add tv fvs = extendVarEnv fvs tv (tv, LambdaBound, noBinderInfo)
- -- Type variables must be lambda-bound
-
unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
minusFVBinders vs fv = foldr minusFVBinder fv vs
minusFVBinder :: Id -> FreeVarsInfo -> FreeVarsInfo
-minusFVBinder v fv | isId v && opt_RuntimeTypes
- = (fv `delVarEnv` v) `unionFVInfo`
- tyvarFVInfo (tyVarsOfType (idType v))
- | otherwise = fv `delVarEnv` v
+minusFVBinder v fv = fv `delVarEnv` v
-- When removing a binder, remember to add its type variables
-- c.f. CoreFVs.delBinderFV
Just (_,_,info) -> info
allFreeIds :: FreeVarsInfo -> [(Id,HowBound)] -- Both top level and non-top-level Ids
-allFreeIds fvs = [(id,how_bound) | (id,how_bound,_) <- varEnvElts fvs, isId id]
+allFreeIds fvs = ASSERT( all (isId . fst) ids ) ids
+ where
+ ids = [(id,how_bound) | (id,how_bound,_) <- varEnvElts fvs]
-- 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, _) <- varEnvElts fvs,
not (topLevelBound how_bound) ]
getFVSet :: FreeVarsInfo -> VarSet
getFVSet fvs = mkVarSet (getFVs fvs)
+plusFVInfo :: (Var, HowBound, StgBinderInfo)
+ -> (Var, HowBound, StgBinderInfo)
+ -> (Var, HowBound, StgBinderInfo)
plusFVInfo (id1,hb1,info1) (id2,hb2,info2)
= ASSERT (id1 == id2 && hb1 `check_eq_how_bound` hb2)
(id1, hb1, combineStgBinderInfo info1 info2)
-- The HowBound info for a variable in the FVInfo should be consistent
+check_eq_how_bound :: HowBound -> HowBound -> Bool
check_eq_how_bound ImportBound ImportBound = True
check_eq_how_bound LambdaBound LambdaBound = True
check_eq_how_bound (LetBound li1 ar1) (LetBound li2 ar2) = ar1 == ar2 && check_eq_li li1 li2
-check_eq_how_bound hb1 hb2 = False
+check_eq_how_bound _ _ = False
+check_eq_li :: LetInfo -> LetInfo -> Bool
check_eq_li (NestedLet _) (NestedLet _) = True
check_eq_li TopLet TopLet = True
-check_eq_li li1 li2 = False
+check_eq_li _ _ = False
\end{code}
Misc.
\begin{code}
filterStgBinders :: [Var] -> [Var]
-filterStgBinders bndrs
- | opt_RuntimeTypes = bndrs
- | otherwise = filter isId bndrs
+filterStgBinders bndrs = filter isId bndrs
\end{code}
\begin{code}
-- Ignore all notes except SCC
+myCollectBinders :: Expr Var -> ([Var], Expr Var)
myCollectBinders expr
= go [] expr
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 (Cast e _) = go bs e
go bs (Note _ e) = go bs e
go bs e = (reverse bs, e)
where
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)
+ go (Note (SCC _) _) _ = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
+ go (Cast e _) as = go e as
+ go (Note _ e) as = go e as
+ go (Lam b e) as
+ | isTyVar b = go e as -- Note [Collect args]
+ go _ _ = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
\end{code}
+Note [Collect args]
+~~~~~~~~~~~~~~~~~~~
+This big-lambda case occurred following a rather obscure eta expansion.
+It all seems a bit yukky to me.
+
\begin{code}
stgArity :: Id -> HowBound -> Arity
-stgArity f (LetBound _ arity) = arity
+stgArity _ (LetBound _ arity) = arity
stgArity f ImportBound = idArity f
-stgArity f LambdaBound = 0
+stgArity _ LambdaBound = 0
\end{code}
projects / ghc-hetmet.git / blobdiff