X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FstgSyn%2FCoreToStg.lhs;h=b2d725796d1250eeec37179d62e72b849f91c966;hp=614feba45db739afb87af582745d1ccd0a7e793d;hb=cbbee4e8727c583daf32d9bf17f00afaa839ef10;hpb=fd8f8c6a4d1d5a91c0095804a9ada86c42d64141 diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs index 614feba..b2d7257 100644 --- a/compiler/stgSyn/CoreToStg.lhs +++ b/compiler/stgSyn/CoreToStg.lhs @@ -12,14 +12,14 @@ 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 TyCon ( isUnboxedTupleTyCon, isPrimTyCon, isFunTyCon, isHiBootTyCon ) +import Var ( Var ) import IdInfo import DataCon import CostCentre ( noCCS ) @@ -29,11 +29,13 @@ import Maybes ( maybeToBool ) 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} %************************************************************************ @@ -153,15 +155,16 @@ coreTopBindsToStg -> [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 @@ -175,47 +178,43 @@ coreTopBindToStg this_pkg env body_fvs (NonRec id rhs) 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 @@ -224,7 +223,6 @@ consistentCafInfo id bind exact = id_marked_caffy == binding_is_caffy id_marked_caffy = mayHaveCafRefs (idCafInfo id) binding_is_caffy = stgBindHasCafRefs bind -#endif \end{code} \begin{code} @@ -235,15 +233,39 @@ coreToTopStgRhs -> 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 ) @@ -252,8 +274,8 @@ mkTopStgRhs is_static rhs_fvs srt binder_info (StgLam _ bndrs body) 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 @@ -290,7 +312,7 @@ on these components, but it in turn is not scrutinised as the basis for any 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 _ _) @@ -303,40 +325,40 @@ coreToStgExpr expr@(Lam _ _) (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) ) + return (result_expr, fvs, escs) -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 (SCC cc) expr) = do + (expr2, fvs, escs) <- coreToStgExpr expr + return (StgSCC cc expr2, fvs, escs) -coreToStgExpr (Note other_note 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 _ 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 @@ -349,25 +371,23 @@ coreToStgExpr (Case scrut bndr _ alts) -- 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 @@ -380,15 +400,15 @@ coreToStgExpr (Case scrut bndr _ alts) = 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} @@ -398,30 +418,40 @@ then to let-no-escapes, if we wish. (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 | 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) + | 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 = @@ -449,21 +479,17 @@ coreToStgApp -> 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 @@ -500,23 +526,27 @@ coreToStgApp maybe_thunk_body f args -- 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 + 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. - ) + ) @@ -527,18 +557,15 @@ coreToStgApp maybe_thunk_body f args 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 @@ -546,7 +573,7 @@ coreToStgArgs (arg : args) -- Non-type argument StgConApp con [] -> StgVarArg (dataConWorkId con) 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.) @@ -559,10 +586,16 @@ coreToStgArgs (arg : args) -- Non-type argument 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) + 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) -- --------------------------------------------------------------------------- @@ -579,29 +612,27 @@ coreToStgLet 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 @@ -628,26 +659,21 @@ coreToStgLet let_no_escape bind body 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 @@ -668,36 +694,34 @@ coreToStgLet let_no_escape bind body [(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 @@ -711,19 +735,17 @@ coreToStgRhs :: FreeVarsInfo -- Free var info for the scope of the binding -> (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 @@ -801,9 +823,11 @@ There's a lot of stuff to pass around, so we use this @LneM@ monad to 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 @@ -830,12 +854,14 @@ data LetInfo -- 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 @@ -879,7 +905,7 @@ getLiveVars (lvs, _) = lvs 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 @@ -887,59 +913,40 @@ initLne env m = 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 @@ -952,9 +959,10 @@ 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) @@ -1017,12 +1025,6 @@ singletonFVInfo id ImportBound info | 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 @@ -1033,10 +1035,7 @@ minusFVBinders :: [Id] -> FreeVarsInfo -> FreeVarsInfo 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 @@ -1053,10 +1052,11 @@ lookupFVInfo fvs id 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) ] @@ -1064,40 +1064,42 @@ getFVs fvs = [id | (id, how_bound, _) <- varEnvElts fvs, 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) @@ -1109,15 +1111,22 @@ myCollectArgs expr 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}