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 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
\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
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)
+ 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 $$ ppr rhs $$ ppr bind)
-- WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info)
(env', fvs' `unionFVInfo` body_fvs, bind)
-- 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
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
-> 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
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)
no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs)
-#ifdef DEBUG
-- Debugging code as requested by Andrew Kennedy
checked_no_binder_escapes
- | not no_binder_escapes && any is_join_var binders
+ | debugIsOn && not no_binder_escapes && any is_join_var binders
= pprTrace "Interesting! A join var that isn't let-no-escaped" (ppr binders)
False
| otherwise = no_binder_escapes
-#else
- checked_no_binder_escapes = no_binder_escapes
-#endif
-- Mustn't depend on the passed-in let_no_escape flag, since
-- no_binder_escapes is used by the caller to derive the flag!
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 _ _ = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
\end{code}
\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