From 625ca288ad84f04f191e1aa0109bb9a08b2be473 Mon Sep 17 00:00:00 2001 From: Twan van Laarhoven Date: Thu, 17 Jan 2008 20:26:19 +0000 Subject: [PATCH] Monadify stgSyn/CoreToStg - made LneM a newtype instead of a type synonym - use do, return and standard monad functions - removed custom versions of monad functions --- compiler/stgSyn/CoreToStg.lhs | 298 +++++++++++++++++++---------------------- 1 file changed, 137 insertions(+), 161 deletions(-) diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs index 40023bf..529de77 100644 --- a/compiler/stgSyn/CoreToStg.lhs +++ b/compiler/stgSyn/CoreToStg.lhs @@ -38,8 +38,7 @@ import BasicTypes ( Arity ) import StaticFlags ( opt_RuntimeTypes ) import Module import Outputable - -infixr 9 `thenLne` +import MonadUtils \end{code} %************************************************************************ @@ -181,10 +180,9 @@ 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 @@ -202,12 +200,10 @@ coreTopBindToStg this_pkg env body_fvs (Rec 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 @@ -238,10 +234,10 @@ coreToTopStgRhs -> (Id,CoreExpr) -> 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) +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) where bndr_info = lookupFVInfo scope_fv_info bndr is_static = rhsIsStatic this_pkg rhs @@ -294,7 +290,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 _ _) @@ -307,24 +303,24 @@ 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 (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 - = coreToStgExpr expr `thenLne` ( \ (expr2, fvs, escs) -> - returnLne (StgTick m n expr2, fvs, escs) ) + | 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 expr @@ -334,13 +330,13 @@ coreToStgExpr (Cast expr co) -- 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 @@ -353,20 +349,18 @@ 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' @@ -384,15 +378,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} @@ -402,12 +396,13 @@ 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 + ) - returnLne (new_let, fvs, escs) + return (new_let, fvs, escs) \end{code} \begin{code} @@ -459,9 +454,9 @@ coreToStgApp -> LneM (StgExpr, FreeVarsInfo, EscVarsSet) -coreToStgApp maybe_thunk_body f args - = coreToStgArgs args `thenLne` \ (args', args_fvs) -> - lookupVarLne f `thenLne` \ how_bound -> +coreToStgApp maybe_thunk_body f args = do + (args', args_fvs) <- coreToStgArgs args + how_bound <- lookupVarLne f let n_val_args = valArgCount args @@ -519,14 +514,13 @@ coreToStgApp maybe_thunk_body f args 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. - ) + ) @@ -537,18 +531,18 @@ coreToStgApp maybe_thunk_body f args coreToStgArgs :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo) coreToStgArgs [] - = returnLne ([], emptyFVInfo) + = return ([], emptyFVInfo) -coreToStgArgs (Type ty : args) -- Type argument - = coreToStgArgs args `thenLne` \ (args', fvs) -> +coreToStgArgs (Type ty : args) = do -- Type argument + (args', fvs) <- coreToStgArgs args if opt_RuntimeTypes then - returnLne (StgTypeArg ty : args', fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType ty)) - else - returnLne (args', fvs) + return (StgTypeArg ty : args', fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType ty)) + else + return (args', fvs) -coreToStgArgs (arg : args) -- Non-type argument - = coreToStgArgs args `thenLne` \ (stg_args, args_fvs) -> - coreToStgExpr arg `thenLne` \ (arg', arg_fvs, escs) -> +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 @@ -556,7 +550,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.) @@ -576,9 +570,9 @@ coreToStgArgs (arg : args) -- Non-type argument -- 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 - in + WARN( bad_args, ptext SLIT("Dangerous-looking argument. Probable cause: bad unsafeCoerce#") $$ ppr arg ) - returnLne (stg_arg : stg_args, fvs) + return (stg_arg : stg_args, fvs) -- --------------------------------------------------------------------------- @@ -595,29 +589,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, _, _) -> +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 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) -> + -- 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) - -- Do the body - extendVarEnvLne env_ext ( - coreToStgExpr body `thenLne` \(body2, body_fvs, body_escs) -> - freeVarsToLiveVars body_fvs `thenLne` \ body_lv_info -> + -- Do the body + extendVarEnvLne env_ext $ do + (body2, body_fvs, body_escs) <- coreToStgExpr body + body_lv_info <- freeVarsToLiveVars body_fvs - returnLne (bind2, bind_fvs, bind_escs, getLiveVars bind_lv_info, - body2, body_fvs, body_escs, getLiveVars body_lv_info) - ) - - ) `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 @@ -657,13 +649,12 @@ coreToStgLet let_no_escape bind body -- 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 @@ -684,36 +675,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 @@ -727,12 +716,12 @@ 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 + 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) where bndr_info = lookupFVInfo scope_fv_info bndr @@ -817,9 +806,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 @@ -895,7 +886,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 @@ -903,59 +894,43 @@ initLne env m = m env emptyLiveInfo {-# INLINE returnLne #-} returnLne :: a -> LneM a -returnLne e env lvs_cont = e +returnLne e = LneM $ \env lvs_cont -> 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 +lookupVarLne v = LneM $ \env lvs_cont -> lookupBinding env v getEnvLne :: LneM (IdEnv HowBound) -getEnvLne env lvs_cont = returnLne env env lvs_cont +getEnvLne = LneM $ \env lvs_cont -> env lookupBinding :: IdEnv HowBound -> Id -> HowBound lookupBinding env v = case lookupVarEnv env v of @@ -968,9 +943,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) -- 1.7.10.4