X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FCorePrep.lhs;h=5fa5002bfeb42f47ac55f9829e6924549420d1de;hp=fb31e4536d6997ff38c30f57db082643f225a442;hb=e79c9ce01d0ce4412bd4bcd99c8c728a6a2ec569;hpb=d5934bbb856aa0aa620c9b2e0fa51c90a1a5a048 diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs index fb31e45..5fa5002 100644 --- a/compiler/coreSyn/CorePrep.lhs +++ b/compiler/coreSyn/CorePrep.lhs @@ -23,6 +23,7 @@ import Var import VarSet import VarEnv import Id +import IdInfo import DataCon import PrimOp import BasicTypes @@ -33,7 +34,8 @@ import ErrUtils import DynFlags import Util import Outputable -import TysWiredIn +import MonadUtils +import FastString \end{code} -- --------------------------------------------------------------------------- @@ -96,31 +98,29 @@ any trivial or useless bindings. \begin{code} corePrepPgm :: DynFlags -> [CoreBind] -> [TyCon] -> IO [CoreBind] -corePrepPgm dflags binds data_tycons - = do showPass dflags "CorePrep" - us <- mkSplitUniqSupply 's' - - let implicit_binds = mkDataConWorkers data_tycons - -- NB: we must feed mkImplicitBinds through corePrep too - -- so that they are suitably cloned and eta-expanded - - binds_out = initUs_ us ( - corePrepTopBinds binds `thenUs` \ floats1 -> - corePrepTopBinds implicit_binds `thenUs` \ floats2 -> - returnUs (deFloatTop (floats1 `appendFloats` floats2)) - ) - - endPass dflags "CorePrep" Opt_D_dump_prep binds_out - return binds_out +corePrepPgm dflags binds data_tycons = do + showPass dflags "CorePrep" + us <- mkSplitUniqSupply 's' + + let implicit_binds = mkDataConWorkers data_tycons + -- NB: we must feed mkImplicitBinds through corePrep too + -- so that they are suitably cloned and eta-expanded + + binds_out = initUs_ us $ do + floats1 <- corePrepTopBinds binds + floats2 <- corePrepTopBinds implicit_binds + return (deFloatTop (floats1 `appendFloats` floats2)) + + endPass dflags "CorePrep" Opt_D_dump_prep binds_out + return binds_out corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr -corePrepExpr dflags expr - = do showPass dflags "CorePrep" - us <- mkSplitUniqSupply 's' - let new_expr = initUs_ us (corePrepAnExpr emptyCorePrepEnv expr) - dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" - (ppr new_expr) - return new_expr +corePrepExpr dflags expr = do + showPass dflags "CorePrep" + us <- mkSplitUniqSupply 's' + let new_expr = initUs_ us (corePrepAnExpr emptyCorePrepEnv expr) + dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" (ppr new_expr) + return new_expr \end{code} -- ----------------------------------------------------------------------------- @@ -143,6 +143,7 @@ always fully applied, and the bindings are just there to support partial applications. But it's easier to let them through. \begin{code} +mkDataConWorkers :: [TyCon] -> [CoreBind] mkDataConWorkers data_tycons = [ NonRec id (Var id) -- The ice is thin here, but it works | tycon <- data_tycons, -- CorePrep will eta-expand it @@ -177,7 +178,7 @@ addFloat :: Floats -> FloatingBind -> Floats addFloat (Floats ok_to_spec floats) new_float = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float) where - check (FloatLet _) = OkToSpec + check (FloatLet _) = OkToSpec check (FloatCase _ _ ok_for_spec) | ok_for_spec = IfUnboxedOk | otherwise = NotOkToSpec @@ -196,6 +197,7 @@ appendFloats (Floats spec1 floats1) (Floats spec2 floats2) concatFloats :: [Floats] -> Floats concatFloats = foldr appendFloats emptyFloats +combine :: OkToSpec -> OkToSpec -> OkToSpec combine NotOkToSpec _ = NotOkToSpec combine _ NotOkToSpec = NotOkToSpec combine IfUnboxedOk _ = IfUnboxedOk @@ -212,7 +214,7 @@ deFloatTop (Floats _ floats) = foldrOL get [] floats where get (FloatLet b) bs = b:bs - get b bs = pprPanic "corePrepPgm" (ppr b) + get b _ = pprPanic "corePrepPgm" (ppr b) allLazy :: TopLevelFlag -> RecFlag -> Floats -> Bool allLazy top_lvl is_rec (Floats ok_to_spec _) @@ -229,10 +231,10 @@ corePrepTopBinds :: [CoreBind] -> UniqSM Floats corePrepTopBinds binds = go emptyCorePrepEnv binds where - go env [] = returnUs emptyFloats - go env (bind : binds) = corePrepTopBind env bind `thenUs` \ (env', bind') -> - go env' binds `thenUs` \ binds' -> - returnUs (bind' `appendFloats` binds') + go _ [] = return emptyFloats + go env (bind : binds) = do (env', bind') <- corePrepTopBind env bind + binds' <- go env' binds + return (bind' `appendFloats` binds') -- NB: we do need to float out of top-level bindings -- Consider x = length [True,False] @@ -263,24 +265,24 @@ corePrepTopBinds binds -------------------------------- corePrepTopBind :: CorePrepEnv -> CoreBind -> UniqSM (CorePrepEnv, Floats) -corePrepTopBind env (NonRec bndr rhs) - = cloneBndr env bndr `thenUs` \ (env', bndr') -> - corePrepRhs TopLevel NonRecursive env (bndr, rhs) `thenUs` \ (floats, rhs') -> - returnUs (env', addFloat floats (FloatLet (NonRec bndr' rhs'))) +corePrepTopBind env (NonRec bndr rhs) = do + (env', bndr') <- cloneBndr env bndr + (floats, rhs') <- corePrepRhs TopLevel NonRecursive env (bndr, rhs) + return (env', addFloat floats (FloatLet (NonRec bndr' rhs'))) corePrepTopBind env (Rec pairs) = corePrepRecPairs TopLevel env pairs -------------------------------- corePrepBind :: CorePrepEnv -> CoreBind -> UniqSM (CorePrepEnv, Floats) -- This one is used for *local* bindings -corePrepBind env (NonRec bndr rhs) - = etaExpandRhs bndr rhs `thenUs` \ rhs1 -> - corePrepExprFloat env rhs1 `thenUs` \ (floats, rhs2) -> - cloneBndr env bndr `thenUs` \ (_, bndr') -> - mkLocalNonRec bndr' (bdrDem bndr) floats rhs2 `thenUs` \ (floats', bndr'') -> - -- We want bndr'' in the envt, because it records - -- the evaluated-ness of the binder - returnUs (extendCorePrepEnv env bndr bndr'', floats') +corePrepBind env (NonRec bndr rhs) = do + rhs1 <- etaExpandRhs bndr rhs + (floats, rhs2) <- corePrepExprFloat env rhs1 + (_, bndr') <- cloneBndr env bndr + (floats', bndr'') <- mkLocalNonRec bndr' (bdrDem bndr) floats rhs2 + -- We want bndr'' in the envt, because it records + -- the evaluated-ness of the binder + return (extendCorePrepEnv env bndr bndr'', floats') corePrepBind env (Rec pairs) = corePrepRecPairs NotTopLevel env pairs @@ -289,10 +291,10 @@ corePrepRecPairs :: TopLevelFlag -> CorePrepEnv -> [(Id,CoreExpr)] -- Recursive bindings -> UniqSM (CorePrepEnv, Floats) -- Used for all recursive bindings, top level and otherwise -corePrepRecPairs lvl env pairs - = cloneBndrs env (map fst pairs) `thenUs` \ (env', bndrs') -> - mapAndUnzipUs (corePrepRhs lvl Recursive env') pairs `thenUs` \ (floats_s, rhss') -> - returnUs (env', unitFloat (FloatLet (Rec (flatten (concatFloats floats_s) bndrs' rhss')))) +corePrepRecPairs lvl env pairs = do + (env', bndrs') <- cloneBndrs env (map fst pairs) + (floats_s, rhss') <- mapAndUnzipM (corePrepRhs lvl Recursive env') pairs + return (env', unitFloat (FloatLet (Rec (flatten (concatFloats floats_s) bndrs' rhss')))) where -- Flatten all the floats, and the currrent -- group into a single giant Rec @@ -300,16 +302,16 @@ corePrepRecPairs lvl env pairs get (FloatLet (NonRec b r)) prs2 = (b,r) : prs2 get (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2 - get b prs2 = pprPanic "corePrepRecPairs" (ppr b) + get b _ = pprPanic "corePrepRecPairs" (ppr b) -------------------------------- corePrepRhs :: TopLevelFlag -> RecFlag -> CorePrepEnv -> (Id, CoreExpr) -> UniqSM (Floats, CoreExpr) -- Used for top-level bindings, and local recursive bindings -corePrepRhs top_lvl is_rec env (bndr, rhs) - = etaExpandRhs bndr rhs `thenUs` \ rhs' -> - corePrepExprFloat env rhs' `thenUs` \ floats_w_rhs -> +corePrepRhs top_lvl is_rec env (bndr, rhs) = do + rhs' <- etaExpandRhs bndr rhs + floats_w_rhs <- corePrepExprFloat env rhs' floatRhs top_lvl is_rec bndr floats_w_rhs @@ -320,34 +322,50 @@ corePrepRhs top_lvl is_rec env (bndr, rhs) -- This is where we arrange that a non-trivial argument is let-bound corePrepArg :: CorePrepEnv -> CoreArg -> RhsDemand -> UniqSM (Floats, CoreArg) -corePrepArg env arg dem - = corePrepExprFloat env arg `thenUs` \ (floats, arg') -> - if exprIsTrivial arg' - then returnUs (floats, arg') - else newVar (exprType arg') `thenUs` \ v -> - mkLocalNonRec v dem floats arg' `thenUs` \ (floats', v') -> - returnUs (floats', Var v') +corePrepArg env arg dem = do + (floats, arg') <- corePrepExprFloat env arg + if exprIsTrivial arg' && allLazy NotTopLevel NonRecursive floats + -- Note [Floating unlifted arguments] + then return (floats, arg') + else do v <- newVar (exprType arg') + (floats', v') <- mkLocalNonRec v dem floats arg' + return (floats', Var v') -- version that doesn't consider an scc annotation to be trivial. -exprIsTrivial (Var v) = True -exprIsTrivial (Type _) = True -exprIsTrivial (Lit lit) = True -exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e -exprIsTrivial (Note (SCC _) e) = False -exprIsTrivial (Note (TickBox {}) e) = False -exprIsTrivial (Note (BinaryTickBox {}) e) = False -exprIsTrivial (Note _ e) = exprIsTrivial e -exprIsTrivial (Cast e co) = exprIsTrivial e +exprIsTrivial :: CoreExpr -> Bool +exprIsTrivial (Var _) = True +exprIsTrivial (Type _) = True +exprIsTrivial (Lit _) = True +exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e +exprIsTrivial (Note (SCC _) _) = False +exprIsTrivial (Note _ e) = exprIsTrivial e +exprIsTrivial (Cast e _) = exprIsTrivial e exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body -exprIsTrivial other = False +exprIsTrivial _ = False +\end{code} + +Note [Floating unlifted arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider C (let v* = expensive in v) + +where the "*" indicates "will be demanded". Usually v will have been +inlined by now, but let's suppose it hasn't (see Trac #2756). Then we +do *not* want to get + + let v* = expensive in C v + +because that has different strictness. Hence the use of 'allLazy'. +(NB: the let v* turns into a FloatCase, in mkLocalNonRec.) + +\begin{code} -- --------------------------------------------------------------------------- -- Dealing with expressions -- --------------------------------------------------------------------------- corePrepAnExpr :: CorePrepEnv -> CoreExpr -> UniqSM CoreExpr -corePrepAnExpr env expr - = corePrepExprFloat env expr `thenUs` \ (floats, expr) -> +corePrepAnExpr env expr = do + (floats, expr) <- corePrepExprFloat env expr mkBinds floats expr @@ -360,101 +378,73 @@ corePrepExprFloat :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CoreExpr) -- For example -- f (g x) ===> ([v = g x], f v) -corePrepExprFloat env (Var v) - = fiddleCCall v `thenUs` \ v1 -> - let - v2 = lookupCorePrepEnv env v1 - in +corePrepExprFloat env (Var v) = do + v1 <- fiddleCCall v + let + v2 = lookupCorePrepEnv env v1 maybeSaturate v2 (Var v2) 0 emptyFloats (idType v2) -corePrepExprFloat env expr@(Type _) - = returnUs (emptyFloats, expr) - -corePrepExprFloat env expr@(Lit lit) - = returnUs (emptyFloats, expr) - -corePrepExprFloat env (Let bind body) - = corePrepBind env bind `thenUs` \ (env', new_binds) -> - corePrepExprFloat env' body `thenUs` \ (floats, new_body) -> - returnUs (new_binds `appendFloats` floats, new_body) - -corePrepExprFloat env (Note n@(SCC _) expr) - = corePrepAnExpr env expr `thenUs` \ expr1 -> - deLamFloat expr1 `thenUs` \ (floats, expr2) -> - returnUs (floats, Note n expr2) - -corePrepExprFloat env (Note note@(TickBox {}) expr) - = corePrepAnExpr env expr `thenUs` \ expr1 -> - deLamFloat expr1 `thenUs` \ (floats, expr2) -> - return (floats, Note note expr2) - -corePrepExprFloat env (Note note@(BinaryTickBox m t e) expr) - = corePrepAnExpr env expr `thenUs` \ expr1 -> - deLamFloat expr1 `thenUs` \ (floats, expr2) -> - getUniqueUs `thenUs` \ u -> - let bndr = mkSysLocal FSLIT("t") u boolTy in - return (floats, Case expr2 - bndr - boolTy - [ (DataAlt falseDataCon, [], Note (TickBox m e) (Var falseDataConId)) - , (DataAlt trueDataCon, [], Note (TickBox m t) (Var trueDataConId)) - ]) - -corePrepExprFloat env (Note other_note expr) - = corePrepExprFloat env expr `thenUs` \ (floats, expr') -> - returnUs (floats, Note other_note expr') - -corePrepExprFloat env (Cast expr co) - = corePrepExprFloat env expr `thenUs` \ (floats, expr') -> - returnUs (floats, Cast expr' co) - -corePrepExprFloat env expr@(Lam _ _) - = cloneBndrs env bndrs `thenUs` \ (env', bndrs') -> - corePrepAnExpr env' body `thenUs` \ body' -> - returnUs (emptyFloats, mkLams bndrs' body') +corePrepExprFloat _env expr@(Type _) + = return (emptyFloats, expr) + +corePrepExprFloat _env expr@(Lit _) + = return (emptyFloats, expr) + +corePrepExprFloat env (Let bind body) = do + (env', new_binds) <- corePrepBind env bind + (floats, new_body) <- corePrepExprFloat env' body + return (new_binds `appendFloats` floats, new_body) + +corePrepExprFloat env (Note n@(SCC _) expr) = do + expr1 <- corePrepAnExpr env expr + (floats, expr2) <- deLamFloat expr1 + return (floats, Note n expr2) + +corePrepExprFloat env (Case (Var id) bndr ty [(DEFAULT,[],expr)]) + | Just (TickBox {}) <- isTickBoxOp_maybe id = do + expr1 <- corePrepAnExpr env expr + (floats, expr2) <- deLamFloat expr1 + return (floats, Case (Var id) bndr ty [(DEFAULT,[],expr2)]) + +corePrepExprFloat env (Note other_note expr) = do + (floats, expr') <- corePrepExprFloat env expr + return (floats, Note other_note expr') + +corePrepExprFloat env (Cast expr co) = do + (floats, expr') <- corePrepExprFloat env expr + return (floats, Cast expr' co) + +corePrepExprFloat env expr@(Lam _ _) = do + (env', bndrs') <- cloneBndrs env bndrs + body' <- corePrepAnExpr env' body + return (emptyFloats, mkLams bndrs' body') where (bndrs,body) = collectBinders expr -corePrepExprFloat env (Case (Note note@(TickBox m n) expr) bndr ty alts) - = corePrepExprFloat env (Note note (Case expr bndr ty alts)) - -corePrepExprFloat env (Case (Note note@(BinaryTickBox m t e) expr) bndr ty alts) - = do { ASSERT(exprType expr `coreEqType` boolTy) - corePrepExprFloat env $ - Case expr bndr ty - [ (DataAlt falseDataCon, [], Note (TickBox m e) falseBranch) - , (DataAlt trueDataCon, [], Note (TickBox m t) trueBranch) - ] - } - where - (_,_,trueBranch) = findAlt (DataAlt trueDataCon) alts - (_,_,falseBranch) = findAlt (DataAlt falseDataCon) alts - -corePrepExprFloat env (Case scrut bndr ty alts) - = corePrepExprFloat env scrut `thenUs` \ (floats1, scrut1) -> - deLamFloat scrut1 `thenUs` \ (floats2, scrut2) -> +corePrepExprFloat env (Case scrut bndr ty alts) = do + (floats1, scrut1) <- corePrepExprFloat env scrut + (floats2, scrut2) <- deLamFloat scrut1 let - bndr1 = bndr `setIdUnfolding` evaldUnfolding - -- Record that the case binder is evaluated in the alternatives - in - cloneBndr env bndr1 `thenUs` \ (env', bndr2) -> - mapUs (sat_alt env') alts `thenUs` \ alts' -> - returnUs (floats1 `appendFloats` floats2 , Case scrut2 bndr2 ty alts') + bndr1 = bndr `setIdUnfolding` evaldUnfolding + -- Record that the case binder is evaluated in the alternatives + (env', bndr2) <- cloneBndr env bndr1 + alts' <- mapM (sat_alt env') alts + return (floats1 `appendFloats` floats2 , Case scrut2 bndr2 ty alts') where - sat_alt env (con, bs, rhs) - = cloneBndrs env bs `thenUs` \ (env2, bs') -> - corePrepAnExpr env2 rhs `thenUs` \ rhs1 -> - deLam rhs1 `thenUs` \ rhs2 -> - returnUs (con, bs', rhs2) + sat_alt env (con, bs, rhs) = do + (env2, bs') <- cloneBndrs env bs + rhs1 <- corePrepAnExpr env2 rhs + rhs2 <- deLam rhs1 + return (con, bs', rhs2) -corePrepExprFloat env expr@(App _ _) - = collect_args expr 0 `thenUs` \ (app, (head,depth), ty, floats, ss) -> - ASSERT(null ss) -- make sure we used all the strictness info +corePrepExprFloat env expr@(App _ _) = do + (app, (head,depth), ty, floats, ss) <- collect_args expr 0 + MASSERT(null ss) -- make sure we used all the strictness info -- Now deal with the function case head of Var fn_id -> maybeSaturate fn_id app depth floats ty - _other -> returnUs (floats, app) + _other -> return (floats, app) where @@ -474,28 +464,26 @@ corePrepExprFloat env expr@(App _ _) Floats, -- any floats we pulled out [Demand]) -- remaining argument demands - collect_args (App fun arg@(Type arg_ty)) depth - = collect_args fun depth `thenUs` \ (fun',hd,fun_ty,floats,ss) -> - returnUs (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss) + collect_args (App fun arg@(Type arg_ty)) depth = do + (fun',hd,fun_ty,floats,ss) <- collect_args fun depth + return (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss) - collect_args (App fun arg) depth - = collect_args fun (depth+1) `thenUs` \ (fun',hd,fun_ty,floats,ss) -> - let - (ss1, ss_rest) = case ss of - (ss1:ss_rest) -> (ss1, ss_rest) - [] -> (lazyDmd, []) + collect_args (App fun arg) depth = do + (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1) + let + (ss1, ss_rest) = case ss of + (ss1:ss_rest) -> (ss1, ss_rest) + [] -> (lazyDmd, []) (arg_ty, res_ty) = expectJust "corePrepExprFloat:collect_args" $ splitFunTy_maybe fun_ty - in - corePrepArg env arg (mkDemTy ss1 arg_ty) `thenUs` \ (fs, arg') -> - returnUs (App fun' arg', hd, res_ty, fs `appendFloats` floats, ss_rest) - - collect_args (Var v) depth - = fiddleCCall v `thenUs` \ v1 -> - let - v2 = lookupCorePrepEnv env v1 - in - returnUs (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts) + + (fs, arg') <- corePrepArg env arg (mkDemTy ss1 arg_ty) + return (App fun' arg', hd, res_ty, fs `appendFloats` floats, ss_rest) + + collect_args (Var v) depth = do + v1 <- fiddleCCall v + let v2 = lookupCorePrepEnv env v1 + return (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts) where stricts = case idNewStrictness v of StrictSig (DmdType _ demands _) @@ -508,25 +496,25 @@ corePrepExprFloat env expr@(App _ _) -- Here, we can't evaluate the arg strictly, because this -- partial application might be seq'd - collect_args (Cast fun co) depth - = let (_ty1,ty2) = coercionKind co in - collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) -> - returnUs (Cast fun' co, hd, ty2, floats, ss) + collect_args (Cast fun co) depth = do + let (_ty1,ty2) = coercionKind co + (fun', hd, _, floats, ss) <- collect_args fun depth + return (Cast fun' co, hd, ty2, floats, ss) collect_args (Note note fun) depth - | ignore_note note -- Drop these notes altogether - -- They aren't used by the code generator - = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) -> - returnUs (fun', hd, fun_ty, floats, ss) + | ignore_note note = do -- Drop these notes altogether + -- They aren't used by the code generator + (fun', hd, fun_ty, floats, ss) <- collect_args fun depth + return (fun', hd, fun_ty, floats, ss) -- N-variable fun, better let-bind it -- ToDo: perhaps we can case-bind rather than let-bind this closure, -- since it is sure to be evaluated. - collect_args fun depth - = corePrepExprFloat env fun `thenUs` \ (fun_floats, fun') -> - newVar ty `thenUs` \ fn_id -> - mkLocalNonRec fn_id onceDem fun_floats fun' `thenUs` \ (floats, fn_id') -> - returnUs (Var fn_id', (Var fn_id', depth), ty, floats, []) + collect_args fun depth = do + (fun_floats, fun') <- corePrepExprFloat env fun + fn_id <- newVar ty + (floats, fn_id') <- mkLocalNonRec fn_id onceDem fun_floats fun' + return (Var fn_id', (Var fn_id', depth), ty, floats, []) where ty = exprType fun @@ -543,52 +531,49 @@ corePrepExprFloat env expr@(App _ _) -- The type is the type of the entire application maybeSaturate :: Id -> CoreExpr -> Int -> Floats -> Type -> UniqSM (Floats, CoreExpr) maybeSaturate fn expr n_args floats ty - | Just DataToTagOp <- isPrimOpId_maybe fn -- DataToTag must have an evaluated arg - -- A gruesome special case - = saturate_it `thenUs` \ sat_expr -> - - -- OK, now ensure that the arg is evaluated. - -- But (sigh) take into account the lambdas we've now introduced - let - (eta_bndrs, eta_body) = collectBinders sat_expr - in - eval_data2tag_arg eta_body `thenUs` \ (eta_floats, eta_body') -> - if null eta_bndrs then - returnUs (floats `appendFloats` eta_floats, eta_body') - else - mkBinds eta_floats eta_body' `thenUs` \ eta_body'' -> - returnUs (floats, mkLams eta_bndrs eta_body'') + | Just DataToTagOp <- isPrimOpId_maybe fn -- DataToTag must have an evaluated arg + -- A gruesome special case + = do sat_expr <- saturate_it + + -- OK, now ensure that the arg is evaluated. + -- But (sigh) take into account the lambdas we've now introduced + let (eta_bndrs, eta_body) = collectBinders sat_expr + (eta_floats, eta_body') <- eval_data2tag_arg eta_body + if null eta_bndrs then + return (floats `appendFloats` eta_floats, eta_body') + else do + eta_body'' <- mkBinds eta_floats eta_body' + return (floats, mkLams eta_bndrs eta_body'') - | hasNoBinding fn = saturate_it `thenUs` \ sat_expr -> - returnUs (floats, sat_expr) + | hasNoBinding fn = do sat_expr <- saturate_it + return (floats, sat_expr) - | otherwise = returnUs (floats, expr) + | otherwise = return (floats, expr) where fn_arity = idArity fn excess_arity = fn_arity - n_args saturate_it :: UniqSM CoreExpr - saturate_it | excess_arity == 0 = returnUs expr - | otherwise = getUniquesUs `thenUs` \ us -> - returnUs (etaExpand excess_arity us expr ty) + saturate_it | excess_arity == 0 = return expr + | otherwise = do us <- getUniquesM + return (etaExpand excess_arity us expr ty) -- Ensure that the argument of DataToTagOp is evaluated eval_data2tag_arg :: CoreExpr -> UniqSM (Floats, CoreExpr) eval_data2tag_arg app@(fun `App` arg) - | exprIsHNF arg -- Includes nullary constructors - = returnUs (emptyFloats, app) -- The arg is evaluated - | otherwise -- Arg not evaluated, so evaluate it - = newVar (exprType arg) `thenUs` \ arg_id -> - let - arg_id1 = setIdUnfolding arg_id evaldUnfolding - in - returnUs (unitFloat (FloatCase arg_id1 arg False ), - fun `App` Var arg_id1) + | exprIsHNF arg -- Includes nullary constructors + = return (emptyFloats, app) -- The arg is evaluated + | otherwise -- Arg not evaluated, so evaluate it + = do arg_id <- newVar (exprType arg) + let + arg_id1 = setIdUnfolding arg_id evaldUnfolding + return (unitFloat (FloatCase arg_id1 arg False ), + fun `App` Var arg_id1) eval_data2tag_arg (Note note app) -- Scc notes can appear - = eval_data2tag_arg app `thenUs` \ (floats, app') -> - returnUs (floats, Note note app') + = do (floats, app') <- eval_data2tag_arg app + return (floats, Note note app') eval_data2tag_arg other -- Should not happen = pprPanic "eval_data2tag" (ppr other) @@ -604,19 +589,19 @@ floatRhs :: TopLevelFlag -> RecFlag -> UniqSM (Floats, -- Floats out of this bind CoreExpr) -- Final Rhs -floatRhs top_lvl is_rec bndr (floats, rhs) +floatRhs top_lvl is_rec _bndr (floats, rhs) | isTopLevel top_lvl || exprIsHNF rhs, -- Float to expose value or allLazy top_lvl is_rec floats -- at top level = -- Why the test for allLazy? -- v = f (x `divInt#` y) -- we don't want to float the case, even if f has arity 2, -- because floating the case would make it evaluated too early - returnUs (floats, rhs) + return (floats, rhs) - | otherwise + | otherwise = do -- Don't float; the RHS isn't a value - = mkBinds floats rhs `thenUs` \ rhs' -> - returnUs (emptyFloats, rhs') + rhs' <- mkBinds floats rhs + return (emptyFloats, rhs') -- mkLocalNonRec is used only for *nested*, *non-recursive* bindings mkLocalNonRec :: Id -> RhsDemand -- Lhs: id with demand @@ -631,22 +616,22 @@ mkLocalNonRec bndr dem floats rhs let float = FloatCase bndr rhs (exprOkForSpeculation rhs) in - returnUs (addFloat floats float, evald_bndr) + return (addFloat floats float, evald_bndr) | isStrict dem -- It's a strict let so we definitely float all the bindings - = let -- Don't make a case for a value binding, + = let -- Don't make a case for a value binding, -- even if it's strict. Otherwise we get -- case (\x -> e) of ...! float | exprIsHNF rhs = FloatLet (NonRec bndr rhs) - | otherwise = FloatCase bndr rhs (exprOkForSpeculation rhs) + | otherwise = FloatCase bndr rhs (exprOkForSpeculation rhs) in - returnUs (addFloat floats float, evald_bndr) + return (addFloat floats float, evald_bndr) | otherwise - = floatRhs NotTopLevel NonRecursive bndr (floats, rhs) `thenUs` \ (floats', rhs') -> - returnUs (addFloat floats' (FloatLet (NonRec bndr rhs')), - if exprIsHNF rhs' then evald_bndr else bndr) + = do (floats', rhs') <- floatRhs NotTopLevel NonRecursive bndr (floats, rhs) + return (addFloat floats' (FloatLet (NonRec bndr rhs')), + if exprIsHNF rhs' then evald_bndr else bndr) where evald_bndr = bndr `setIdUnfolding` evaldUnfolding @@ -655,17 +640,18 @@ mkLocalNonRec bndr dem floats rhs mkBinds :: Floats -> CoreExpr -> UniqSM CoreExpr mkBinds (Floats _ binds) body - | isNilOL binds = returnUs body - | otherwise = deLam body `thenUs` \ body' -> - -- Lambdas are not allowed as the body of a 'let' - returnUs (foldrOL mk_bind body' binds) + | isNilOL binds = return body + | otherwise = do body' <- deLam body + -- Lambdas are not allowed as the body of a 'let' + return (foldrOL mk_bind body' binds) where mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)] mk_bind (FloatLet bind) body = Let bind body -etaExpandRhs bndr rhs - = -- Eta expand to match the arity claimed by the binder - -- Remember, after CorePrep we must not change arity +etaExpandRhs :: CoreBndr -> CoreExpr -> UniqSM CoreExpr +etaExpandRhs bndr rhs = do + -- Eta expand to match the arity claimed by the binder + -- Remember, CorePrep must not change arity -- -- Eta expansion might not have happened already, -- because it is done by the simplifier only when @@ -693,8 +679,13 @@ etaExpandRhs bndr rhs -- Eta expanding first gives -- f = /\a -> \y -> let s = h 3 in g s y -- - getUniquesUs `thenUs` \ us -> - returnUs (etaExpand arity us rhs (idType bndr)) + us <- getUniquesM + let eta_rhs = etaExpand arity us rhs (idType bndr) + + ASSERT2( manifestArity eta_rhs == arity, (ppr bndr <+> ppr arity <+> ppr (exprArity rhs)) + $$ ppr rhs $$ ppr eta_rhs ) + -- Assertion checks that eta expansion was successful + return eta_rhs where -- For a GlobalId, take the Arity from the Id. -- It was set in CoreTidy and must not change @@ -711,32 +702,32 @@ deLam :: CoreExpr -> UniqSM CoreExpr -- Takes an expression that may be a lambda, -- and returns one that definitely isn't: -- (\x.e) ==> let f = \x.e in f -deLam expr = - deLamFloat expr `thenUs` \ (floats, expr) -> - mkBinds floats expr +deLam expr = do + (floats, expr) <- deLamFloat expr + mkBinds floats expr deLamFloat :: CoreExpr -> UniqSM (Floats, CoreExpr) -- Remove top level lambdas by let-bindinig -deLamFloat (Note n expr) - = -- You can get things like - -- case e of { p -> coerce t (\s -> ...) } - deLamFloat expr `thenUs` \ (floats, expr') -> - returnUs (floats, Note n expr') +deLamFloat (Note n expr) = do + -- You can get things like + -- case e of { p -> coerce t (\s -> ...) } + (floats, expr') <- deLamFloat expr + return (floats, Note n expr') -deLamFloat (Cast e co) - = deLamFloat e `thenUs` \ (floats, e') -> - returnUs (floats, Cast e' co) +deLamFloat (Cast e co) = do + (floats, e') <- deLamFloat e + return (floats, Cast e' co) deLamFloat expr - | null bndrs = returnUs (emptyFloats, expr) + | null bndrs = return (emptyFloats, expr) | otherwise = case tryEta bndrs body of - Just no_lam_result -> returnUs (emptyFloats, no_lam_result) - Nothing -> newVar (exprType expr) `thenUs` \ fn -> - returnUs (unitFloat (FloatLet (NonRec fn expr)), - Var fn) + Just no_lam_result -> return (emptyFloats, no_lam_result) + Nothing -> do fn <- newVar (exprType expr) + return (unitFloat (FloatLet (NonRec fn expr)), + Var fn) where (bndrs,body) = collectBinders expr @@ -746,6 +737,7 @@ deLamFloat expr -- get to a partial application: -- \xs. map f xs ==> map f +tryEta :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr tryEta bndrs expr@(App _ _) | ok_to_eta_reduce f && n_remaining >= 0 && @@ -760,13 +752,13 @@ tryEta bndrs expr@(App _ _) n_remaining = length args - length bndrs ok bndr (Var arg) = bndr == arg - ok bndr other = False + ok _ _ = False -- we can't eta reduce something which must be saturated. ok_to_eta_reduce (Var f) = not (hasNoBinding f) ok_to_eta_reduce _ = False --safe. ToDo: generalise -tryEta bndrs (Let bind@(NonRec b r) body) +tryEta bndrs (Let bind@(NonRec _ r) body) | not (any (`elemVarSet` fvs) bndrs) = case tryEta bndrs body of Just e -> Just (Let bind e) @@ -774,7 +766,7 @@ tryEta bndrs (Let bind@(NonRec b r) body) where fvs = exprFreeVars r -tryEta bndrs _ = Nothing +tryEta _ _ = Nothing \end{code} @@ -784,16 +776,16 @@ tryEta bndrs _ = Nothing \begin{code} data RhsDemand - = RhsDemand { isStrict :: Bool, -- True => used at least once - isOnceDem :: Bool -- True => used at most once + = RhsDemand { isStrict :: Bool, -- True => used at least once + _isOnceDem :: Bool -- True => used at most once } mkDem :: Demand -> Bool -> RhsDemand mkDem strict once = RhsDemand (isStrictDmd strict) once mkDemTy :: Demand -> Type -> RhsDemand -mkDemTy strict ty = RhsDemand (isStrictDmd strict) - False {- For now -} +mkDemTy strict _ty = RhsDemand (isStrictDmd strict) + False {- For now -} bdrDem :: Id -> RhsDemand bdrDem id = mkDem (idNewDemandInfo id) @@ -839,21 +831,18 @@ lookupCorePrepEnv (CPE env) id -- --------------------------------------------------------------------------- cloneBndrs :: CorePrepEnv -> [Var] -> UniqSM (CorePrepEnv, [Var]) -cloneBndrs env bs = mapAccumLUs cloneBndr env bs +cloneBndrs env bs = mapAccumLM cloneBndr env bs cloneBndr :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var) cloneBndr env bndr | isLocalId bndr - = getUniqueUs `thenUs` \ uniq -> - let - bndr' = setVarUnique bndr uniq - in - returnUs (extendCorePrepEnv env bndr bndr', bndr') + = do bndr' <- setVarUnique bndr <$> getUniqueM + return (extendCorePrepEnv env bndr bndr', bndr') | otherwise -- Top level things, which we don't want -- to clone, have become GlobalIds by now -- And we don't clone tyvars - = returnUs (env, bndr) + = return (env, bndr) ------------------------------------------------------------------------------ @@ -863,9 +852,8 @@ cloneBndr env bndr fiddleCCall :: Id -> UniqSM Id fiddleCCall id - | isFCallId id = getUniqueUs `thenUs` \ uniq -> - returnUs (id `setVarUnique` uniq) - | otherwise = returnUs id + | isFCallId id = (id `setVarUnique`) <$> getUniqueM + | otherwise = return id ------------------------------------------------------------------------------ -- Generating new binders @@ -873,7 +861,7 @@ fiddleCCall id newVar :: Type -> UniqSM Id newVar ty - = seqType ty `seq` - getUniqueUs `thenUs` \ uniq -> - returnUs (mkSysLocal FSLIT("sat") uniq ty) + = seqType ty `seq` do + uniq <- getUniqueM + return (mkSysLocal (fsLit "sat") uniq ty) \end{code}