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"
-> [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
-- 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"
= 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
coreToStgArgs []
= return ([], emptyFVInfo)
-coreToStgArgs (Type ty : args) = do -- Type argument
+coreToStgArgs (Type _ : args) = do -- Type argument
(args', fvs) <- coreToStgArgs args
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
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 = emptyFVInfo -- Type variables are not recorded
--- Old code recorded free tyvars for when we supported runtime types:
--- 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
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}
-- 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