#include "HsVersions.h"
import CoreSyn
-import CoreUtils ( rhsIsStatic, manifestArity, exprType, findDefault )
+import CoreUtils ( rhsIsStatic, exprType, findDefault )
+import CoreArity ( manifestArity )
import StgSyn
import Type
-import Coercion ( mkUnsafeCoercion )
-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 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 PackageConfig ( PackageId )
+import Module
import Outputable
-
-infixr 9 `thenLne`
+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
how_bound = LetBound TopLet $! manifestArity rhs
(stg_rhs, fvs') =
- initLne env (
- coreToTopStgRhs this_pkg body_fvs (id,rhs) `thenLne` \ (stg_rhs, fvs') ->
- returnLne (stg_rhs, fvs')
- )
+ initLne env $ do
+ (stg_rhs, fvs') <- coreToTopStgRhs this_pkg body_fvs (id,rhs)
+ return (stg_rhs, fvs')
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 ]
env' = extendVarEnvList env extra_env'
(stg_rhss, fvs')
- = initLne env' (
- mapAndUnzipLne (coreToTopStgRhs this_pkg body_fvs) pairs
- `thenLne` \ (stg_rhss, fvss') ->
- let fvs' = unionFVInfos fvss' in
- returnLne (stg_rhss, fvs')
- )
+ = initLne env' $ do
+ (stg_rhss, fvss') <- mapAndUnzipM (coreToTopStgRhs this_pkg body_fvs) pairs
+ let fvs' = unionFVInfos fvss'
+ return (stg_rhss, fvs')
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)
-#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
-- 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
exact = id_marked_caffy == binding_is_caffy
id_marked_caffy = mayHaveCafRefs (idCafInfo id)
binding_is_caffy = stgBindHasCafRefs bind
-#endif
\end{code}
\begin{code}
-> LneM (StgRhs, FreeVarsInfo)
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)
+ = 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
decisions. Hence no black holes.
\begin{code}
-coreToStgExpr (Lit l) = returnLne (StgLit l, emptyFVInfo, emptyVarSet)
+coreToStgExpr (Lit l) = return (StgLit l, emptyFVInfo, emptyVarSet)
coreToStgExpr (Var v) = coreToStgApp Nothing v []
coreToStgExpr expr@(App _ _)
(args, body) = myCollectBinders expr
args' = filterStgBinders args
in
- extendVarEnvLne [ (a, LambdaBound) | a <- args' ] $
- coreToStgExpr body `thenLne` \ (body, body_fvs, body_escs) ->
+ extendVarEnvLne [ (a, LambdaBound) | a <- args' ] $ do
+ (body, body_fvs, body_escs) <- coreToStgExpr body
let
fvs = args' `minusFVBinders` body_fvs
escs = body_escs `delVarSetList` args'
result_expr | null args' = body
| otherwise = StgLam (exprType expr) args' body
- in
- returnLne (result_expr, fvs, escs)
-
-coreToStgExpr (Note (SCC cc) expr)
- = 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 (Cast expr co)
- = let (from_ty, ty_ty) = coercionKind co in
- coreToStgExpr (mkApps (Var unsafeCoerceId)
- [Type from_ty, Type to_ty, expr])
-#endif
-coreToStgExpr (Note other_note expr)
+ return (result_expr, fvs, escs)
+
+coreToStgExpr (Note (SCC cc) expr) = do
+ (expr2, fvs, escs) <- coreToStgExpr expr
+ return (StgSCC cc expr2, fvs, escs)
+
+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 _ expr)
= coreToStgExpr expr
-coreToStgExpr (Cast expr co)
+coreToStgExpr (Cast expr _)
= coreToStgExpr expr
-- Cases require a little more real work.
-coreToStgExpr (Case scrut bndr _ alts)
- = extendVarEnvLne [(bndr, LambdaBound)] (
- mapAndUnzip3Lne vars_alt alts `thenLne` \ (alts2, fvs_s, escs_s) ->
- returnLne ( alts2,
- unionFVInfos fvs_s,
- unionVarSets escs_s )
- ) `thenLne` \ (alts2, alts_fvs, alts_escs) ->
+coreToStgExpr (Case scrut bndr _ alts) = do
+ (alts2, alts_fvs, alts_escs)
+ <- extendVarEnvLne [(bndr, LambdaBound)] $ do
+ (alts2, fvs_s, escs_s) <- mapAndUnzip3M vars_alt alts
+ return ( alts2,
+ unionFVInfos fvs_s,
+ unionVarSets escs_s )
let
-- Determine whether the default binder is dead or not
-- This helps the code generator to avoid generating an assignment
-- the default binder is not free.
alts_fvs_wo_bndr = bndr `minusFVBinder` alts_fvs
alts_escs_wo_bndr = alts_escs `delVarSet` bndr
- in
- freeVarsToLiveVars alts_fvs_wo_bndr `thenLne` \ alts_lv_info ->
+ alts_lv_info <- freeVarsToLiveVars alts_fvs_wo_bndr
-- We tell the scrutinee that everything
-- live in the alts is live in it, too.
- setVarsLiveInCont alts_lv_info (
- coreToStgExpr scrut `thenLne` \ (scrut2, scrut_fvs, scrut_escs) ->
- freeVarsToLiveVars scrut_fvs `thenLne` \ scrut_lv_info ->
- returnLne (scrut2, scrut_fvs, scrut_escs, scrut_lv_info)
- )
- `thenLne` \ (scrut2, scrut_fvs, scrut_escs, scrut_lv_info) ->
-
- returnLne (
+ (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 (scrut2, scrut_fvs, scrut_escs, scrut_lv_info)
+
+ return (
StgCase scrut2 (getLiveVars scrut_lv_info)
(getLiveVars alts_lv_info)
bndr'
(mkSRT alts_lv_info)
- (mkStgAltType (idType bndr) alts)
+ (mkStgAltType bndr alts)
alts2,
scrut_fvs `unionFVInfo` alts_fvs_wo_bndr,
alts_escs_wo_bndr `unionVarSet` getFVSet scrut_fvs
= let -- Remove type variables
binders' = filterStgBinders binders
in
- extendVarEnvLne [(b, LambdaBound) | b <- binders'] $
- coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
+ extendVarEnvLne [(b, LambdaBound) | b <- binders'] $ do
+ (rhs2, rhs_fvs, rhs_escs) <- coreToStgExpr rhs
let
-- Records whether each param is used in the RHS
good_use_mask = [ b `elementOfFVInfo` rhs_fvs | b <- binders' ]
- in
- returnLne ( (con, binders', good_use_mask, rhs2),
- binders' `minusFVBinders` rhs_fvs,
- rhs_escs `delVarSetList` binders' )
+
+ return ( (con, binders', good_use_mask, rhs2),
+ binders' `minusFVBinders` rhs_fvs,
+ rhs_escs `delVarSetList` binders' )
-- ToDo: remove the delVarSet;
-- since escs won't include any of these binders
\end{code}
(Meanwhile, we don't expect to see let-no-escapes...)
\begin{code}
-coreToStgExpr (Let bind body)
- = fixLne (\ ~(_, _, _, no_binder_escapes) ->
- coreToStgLet no_binder_escapes bind body
- ) `thenLne` \ (new_let, fvs, escs, _) ->
+coreToStgExpr (Let bind body) = do
+ (new_let, fvs, escs, _)
+ <- mfix (\ ~(_, _, _, no_binder_escapes) ->
+ coreToStgLet no_binder_escapes bind body
+ )
+
+ return (new_let, fvs, escs)
- returnLne (new_let, fvs, escs)
+coreToStgExpr e = pprPanic "coreToStgExpr" (ppr e)
\end{code}
\begin{code}
-mkStgAltType scrut_ty alts
- = case splitTyConApp_maybe (repType scrut_ty) of
+mkStgAltType :: Id -> [CoreAlt] -> AltType
+mkStgAltType bndr alts
+ = case splitTyConApp_maybe (repType (idType bndr)) 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
- | otherwise -> pprPanic "mkStgAlts" (ppr tc)
+ | otherwise -> ASSERT( _is_poly_alt_tycon tc )
+ PolyAlt
Nothing -> PolyAlt
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
+ _is_poly_alt_tycon tc
+ = isFunTyCon tc
+ || isPrimTyCon tc -- "Any" is lifted but primitive
+ || isOpenTyCon tc -- Type family; e.g. arising from strict
+ -- function application where argument has a
+ -- type-family type
+
+ -- Sometimes, the TyCon is a HiBootTyCon which may not have any
+ -- constructors inside it. 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 =
-> [CoreArg] -- Arguments
-> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
-coreToStgApp maybe_thunk_body f args
- = coreToStgArgs args `thenLne` \ (args', args_fvs) ->
- lookupVarLne f `thenLne` \ how_bound ->
+
+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'
- PrimOpId op -> ASSERT( saturated )
- StgOpApp (StgPrimOp op) args' res_ty
+ PrimOpId op -> ASSERT( saturated )
+ StgOpApp (StgPrimOp op) args' res_ty
+ FCallId (CCall (CCallSpec (StaticTarget lbl) PrimCallConv _))
+ -- prim calls are represented as FCalls in core,
+ -- but in stg we distinguish them
+ -> ASSERT( saturated )
+ StgOpApp (StgPrimCallOp (PrimCall lbl)) 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
- returnLne (
+ return (
app,
fun_fvs `unionFVInfo` args_fvs,
fun_escs `unionVarSet` (getFVSet args_fvs)
-- All the free vars of the args are disqualified
-- from being let-no-escaped.
- )
+ )
coreToStgArgs :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo)
coreToStgArgs []
- = returnLne ([], emptyFVInfo)
-
-coreToStgArgs (Type ty : args) -- Type argument
- = coreToStgArgs args `thenLne` \ (args', fvs) ->
- if opt_RuntimeTypes then
- returnLne (StgTypeArg ty : args', fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType ty))
- else
- returnLne (args', fvs)
-
-coreToStgArgs (arg : args) -- Non-type argument
- = coreToStgArgs args `thenLne` \ (stg_args, args_fvs) ->
- coreToStgExpr arg `thenLne` \ (arg', arg_fvs, escs) ->
+ = return ([], emptyFVInfo)
+
+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
let
fvs = args_fvs `unionFVInfo` arg_fvs
stg_arg = case arg' of
StgConApp con [] -> StgVarArg (dataConWorkId con)
StgLit lit -> StgLitArg lit
_ -> pprPanic "coreToStgArgs" (ppr arg)
- in
- returnLne (stg_arg : stg_args, fvs)
+
+ -- 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
+ bad_args = (isUnLiftedType arg_ty && not (isUnLiftedType stg_arg_ty))
+ || (typePrimRep arg_ty /= typePrimRep stg_arg_ty)
+ -- In GHCi we coerce an argument of type BCO# (unlifted) to HValue (lifted),
+ -- and pass it to a function expecting an HValue (arg_ty). This is ok because
+ -- we can treat an unlifted value as lifted. But the other way round
+ -- 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 )
+ return (stg_arg : stg_args, fvs)
-- ---------------------------------------------------------------------------
Bool) -- True <=> none of the binders in the bindings
-- is among the escaping vars
-coreToStgLet let_no_escape bind body
- = fixLne (\ ~(_, _, _, _, _, rec_body_fvs, _, _) ->
-
- -- Do the bindings, setting live_in_cont to empty if
- -- we ain't in a let-no-escape world
- getVarsLiveInCont `thenLne` \ live_in_cont ->
- setVarsLiveInCont (if let_no_escape
- then live_in_cont
- else emptyLiveInfo)
- (vars_bind rec_body_fvs bind)
- `thenLne` \ ( bind2, bind_fvs, bind_escs, bind_lv_info, env_ext) ->
+coreToStgLet let_no_escape bind body = do
+ (bind2, bind_fvs, bind_escs, bind_lvs,
+ body2, body_fvs, body_escs, body_lvs)
+ <- mfix $ \ ~(_, _, _, _, _, rec_body_fvs, _, _) -> do
- -- Do the body
- extendVarEnvLne env_ext (
- coreToStgExpr body `thenLne` \(body2, body_fvs, body_escs) ->
- freeVarsToLiveVars body_fvs `thenLne` \ body_lv_info ->
+ -- Do the bindings, setting live_in_cont to empty if
+ -- we ain't in a let-no-escape world
+ live_in_cont <- getVarsLiveInCont
+ ( bind2, bind_fvs, bind_escs, bind_lv_info, env_ext)
+ <- setVarsLiveInCont (if let_no_escape
+ then live_in_cont
+ else emptyLiveInfo)
+ (vars_bind rec_body_fvs bind)
- returnLne (bind2, bind_fvs, bind_escs, getLiveVars bind_lv_info,
- body2, body_fvs, body_escs, getLiveVars body_lv_info)
- )
+ -- Do the body
+ extendVarEnvLne env_ext $ do
+ (body2, body_fvs, body_escs) <- coreToStgExpr body
+ body_lv_info <- freeVarsToLiveVars body_fvs
- ) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs,
- body2, body_fvs, body_escs, body_lvs) ->
+ return (bind2, bind_fvs, bind_escs, getLiveVars bind_lv_info,
+ body2, body_fvs, body_escs, getLiveVars body_lv_info)
-- Compute the new let-expression
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!
- in
- returnLne (
+ return (
new_let,
free_in_whole_let,
let_escs,
checked_no_binder_escapes
- ))
+ )
where
set_of_binders = mkVarSet binders
binders = bindersOf bind
[(Id, HowBound)]) -- extension to environment
- vars_bind body_fvs (NonRec binder rhs)
- = coreToStgRhs body_fvs [] (binder,rhs)
- `thenLne` \ (rhs2, bind_fvs, bind_lv_info, escs) ->
+ vars_bind body_fvs (NonRec binder rhs) = do
+ (rhs2, bind_fvs, bind_lv_info, escs) <- coreToStgRhs body_fvs [] (binder,rhs)
let
env_ext_item = mk_binding bind_lv_info binder rhs
- in
- returnLne (StgNonRec binder rhs2,
- bind_fvs, escs, bind_lv_info, [env_ext_item])
+
+ return (StgNonRec binder rhs2,
+ bind_fvs, escs, bind_lv_info, [env_ext_item])
vars_bind body_fvs (Rec pairs)
- = fixLne (\ ~(_, rec_rhs_fvs, _, bind_lv_info, _) ->
+ = mfix $ \ ~(_, rec_rhs_fvs, _, bind_lv_info, _) ->
let
rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
binders = map fst pairs
env_ext = [ mk_binding bind_lv_info b rhs
| (b,rhs) <- pairs ]
in
- extendVarEnvLne env_ext (
- mapAndUnzip4Lne (coreToStgRhs rec_scope_fvs binders) pairs
- `thenLne` \ (rhss2, fvss, lv_infos, escss) ->
+ extendVarEnvLne env_ext $ do
+ (rhss2, fvss, lv_infos, escss)
+ <- mapAndUnzip4M (coreToStgRhs rec_scope_fvs binders) pairs
let
bind_fvs = unionFVInfos fvss
bind_lv_info = foldr unionLiveInfo emptyLiveInfo lv_infos
escs = unionVarSets escss
- in
- returnLne (StgRec (binders `zip` rhss2),
- bind_fvs, escs, bind_lv_info, env_ext)
- )
- )
+
+ return (StgRec (binders `zip` rhss2),
+ bind_fvs, escs, bind_lv_info, env_ext)
+
is_join_var :: Id -> Bool
-- A hack (used only for compiler debuggging) to tell if
-> (Id,CoreExpr)
-> LneM (StgRhs, FreeVarsInfo, LiveInfo, EscVarsSet)
-coreToStgRhs scope_fv_info binders (bndr, rhs)
- = coreToStgExpr rhs `thenLne` \ (new_rhs, rhs_fvs, rhs_escs) ->
- getEnvLne `thenLne` \ env ->
- freeVarsToLiveVars (binders `minusFVBinders` rhs_fvs) `thenLne` \ lv_info ->
- returnLne (mkStgRhs rhs_fvs (mkSRT lv_info) bndr_info new_rhs,
- rhs_fvs, lv_info, rhs_escs)
+coreToStgRhs scope_fv_info binders (bndr, rhs) = do
+ (new_rhs, rhs_fvs, rhs_escs) <- coreToStgExpr rhs
+ lv_info <- freeVarsToLiveVars (binders `minusFVBinders` rhs_fvs)
+ return (mkStgRhs rhs_fvs (mkSRT lv_info) bndr_info new_rhs,
+ rhs_fvs, lv_info, rhs_escs)
where
bndr_info = lookupFVInfo scope_fv_info bndr
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
help. All the stuff here is only passed *down*.
\begin{code}
-type LneM a = IdEnv HowBound
- -> LiveInfo -- Vars and CAFs live in continuation
- -> a
+newtype LneM a = LneM
+ { unLneM :: IdEnv HowBound
+ -> LiveInfo -- Vars and CAFs live in continuation
+ -> a
+ }
type LiveInfo = (StgLiveVars, -- Dynamic live variables;
-- i.e. ones with a nested (non-top-level) binding
-- 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
The std monad functions:
\begin{code}
initLne :: IdEnv HowBound -> LneM a -> a
-initLne env m = m env emptyLiveInfo
+initLne env m = unLneM m env emptyLiveInfo
{-# INLINE returnLne #-}
returnLne :: a -> LneM a
-returnLne e env lvs_cont = e
+returnLne e = LneM $ \_ _ -> e
thenLne :: LneM a -> (a -> LneM b) -> LneM b
-thenLne m k env lvs_cont
- = k (m env lvs_cont) env lvs_cont
-
-mapAndUnzipLne :: (a -> LneM (b,c)) -> [a] -> LneM ([b],[c])
-mapAndUnzipLne f [] = returnLne ([],[])
-mapAndUnzipLne f (x:xs)
- = f x `thenLne` \ (r1, r2) ->
- mapAndUnzipLne f xs `thenLne` \ (rs1, rs2) ->
- 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) ->
- mapAndUnzip3Lne f xs `thenLne` \ (rs1, rs2, rs3) ->
- 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) ->
- mapAndUnzip4Lne f xs `thenLne` \ (rs1, rs2, rs3, rs4) ->
- returnLne (r1:rs1, r2:rs2, r3:rs3, r4:rs4)
-
-fixLne :: (a -> LneM a) -> LneM a
-fixLne expr env lvs_cont
- = result
- where
- result = expr result env lvs_cont
+thenLne m k = LneM $ \env lvs_cont
+ -> unLneM (k (unLneM m env lvs_cont)) env lvs_cont
+
+instance Monad LneM where
+ return = returnLne
+ (>>=) = thenLne
+
+instance MonadFix LneM where
+ mfix expr = LneM $ \env lvs_cont ->
+ let result = unLneM (expr result) env lvs_cont
+ in result
\end{code}
Functions specific to this monad:
\begin{code}
getVarsLiveInCont :: LneM LiveInfo
-getVarsLiveInCont env lvs_cont = lvs_cont
+getVarsLiveInCont = LneM $ \_env lvs_cont -> lvs_cont
setVarsLiveInCont :: LiveInfo -> LneM a -> LneM a
-setVarsLiveInCont new_lvs_cont expr env lvs_cont
- = expr env new_lvs_cont
+setVarsLiveInCont new_lvs_cont expr
+ = LneM $ \env _lvs_cont
+ -> unLneM expr env new_lvs_cont
extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a
-extendVarEnvLne ids_w_howbound expr env lvs_cont
- = expr (extendVarEnvList env ids_w_howbound) lvs_cont
+extendVarEnvLne ids_w_howbound expr
+ = LneM $ \env lvs_cont
+ -> unLneM expr (extendVarEnvList env ids_w_howbound) lvs_cont
lookupVarLne :: Id -> LneM HowBound
-lookupVarLne v env lvs_cont = returnLne (lookupBinding env v) env lvs_cont
-
-getEnvLne :: LneM (IdEnv HowBound)
-getEnvLne env lvs_cont = returnLne env env lvs_cont
+lookupVarLne v = LneM $ \env _lvs_cont -> lookupBinding env v
lookupBinding :: IdEnv HowBound -> Id -> HowBound
lookupBinding env v = case lookupVarEnv env v of
-- the basis of a control decision, which might give a black hole.
freeVarsToLiveVars :: FreeVarsInfo -> LneM LiveInfo
-freeVarsToLiveVars fvs env live_in_cont
- = returnLne live_info env live_in_cont
- where
+freeVarsToLiveVars fvs = LneM freeVarsToLiveVars'
+ where
+ 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)
-#ifdef DEBUG
-- 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
-#endif
+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