import DynFlags
import Util
import Outputable
+import MonadUtils
\end{code}
-- ---------------------------------------------------------------------------
\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}
-- -----------------------------------------------------------------------------
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 env [] = 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]
--------------------------------
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
-> [(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
-> 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
-- 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') ->
+corePrepArg env arg dem = do
+ (floats, arg') <- corePrepExprFloat env 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')
+ 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 _ e) = exprIsTrivial e
+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 _ e) = exprIsTrivial e
exprIsTrivial (Cast e co) = exprIsTrivial e
exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
-exprIsTrivial other = False
+exprIsTrivial other = False
-- ---------------------------------------------------------------------------
-- 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
-- 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)
+ = return (emptyFloats, expr)
corePrepExprFloat env expr@(Lit lit)
- = returnUs (emptyFloats, expr)
+ = return (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 (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)
- = corePrepAnExpr env expr `thenUs` \ expr1 ->
- deLamFloat expr1 `thenUs` \ (floats, expr2) ->
- returnUs (floats, Note n expr2)
+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
- = corePrepAnExpr env expr `thenUs` \ expr1 ->
- deLamFloat expr1 `thenUs` \ (floats, expr2) ->
+ | 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)
- = corePrepExprFloat env expr `thenUs` \ (floats, expr') ->
- returnUs (floats, Note other_note expr')
+corePrepExprFloat env (Note other_note expr) = do
+ (floats, expr') <- corePrepExprFloat env expr
+ return (floats, Note other_note expr')
-corePrepExprFloat env (Cast expr co)
- = corePrepExprFloat env expr `thenUs` \ (floats, expr') ->
- returnUs (floats, Cast expr' co)
+corePrepExprFloat env (Cast expr co) = do
+ (floats, expr') <- corePrepExprFloat env expr
+ return (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@(Lam _ _) = do
+ (env', bndrs') <- cloneBndrs env bndrs
+ body' <- corePrepAnExpr env' body
+ return (emptyFloats, mkLams bndrs' body')
where
(bndrs,body) = collectBinders expr
-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
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 _)
-- 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, fun_ty, 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
-- 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
- | hasNoBinding fn = saturate_it `thenUs` \ sat_expr ->
- returnUs (floats, 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
+ (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'')
- | otherwise = returnUs (floats, expr)
+ | hasNoBinding fn = do sat_expr <- saturate_it
+ return (floats, sat_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)
-- 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
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
float | exprIsHNF rhs = FloatLet (NonRec bndr 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
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
+etaExpandRhs bndr rhs = do
+ -- Eta expand to match the arity claimed by the binder
-- Remember, after CorePrep we must not change arity
--
-- Eta expansion might not have happened already,
-- 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
+ return (etaExpand arity us rhs (idType bndr))
where
-- For a GlobalId, take the Arity from the Id.
-- It was set in CoreTidy and must not change
-- 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
-- ---------------------------------------------------------------------------
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)
------------------------------------------------------------------------------
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
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}
projects / ghc-hetmet.git / commitdiff