#include "HsVersions.h"
-import CoreUtils
-import CoreFVs
-import CoreLint
+import CoreUtils( exprIsTrivial, exprIsAtom, exprType, exprIsValue, etaExpand, exprArity )
+import CoreFVs ( exprFreeVars )
+import CoreLint ( endPass )
import CoreSyn
-import Type
-import Demand
-import Var ( TyVar, setTyVarUnique )
+import Type ( Type, applyTy, splitFunTy_maybe, isTyVarTy,
+ isUnLiftedType, isUnboxedTupleType, repType,
+ uaUTy, usOnce, usMany, seqType )
+import Demand ( Demand, isStrict, wwLazy, StrictnessInfo(..) )
+import PrimOp ( PrimOp(..) )
+import Var ( Id, TyVar, setTyVarUnique )
import VarSet
-import IdInfo
-import Id
-import PrimOp
+import IdInfo ( IdFlavour(..) )
+import Id ( mkSysLocal, idType, idStrictness, idFlavour, idDemandInfo, idArity,
+ isDeadBinder, setIdType, isPrimOpId_maybe
+ )
+
import UniqSupply
import Maybes
+import OrdList
import ErrUtils
import CmdLineOpts
import Outputable
-- Overview
-- ---------------------------------------------------------------------------
+MAJOR CONSTRAINT:
+ By the time this pass happens, we have spat out tidied Core into
+ the interface file, including all IdInfo.
+
+ So we must not change the arity of any top-level function,
+ because we've already fixed it and put it out into the interface file.
+ Nor must we change a value (e.g. constructor) into a thunk.
+
+ It's ok to introduce extra bindings, which don't appear in the
+ interface file. We don't put arity info on these extra bindings,
+ because they are never fully applied, so there's no chance of
+ compiling just-a-fast-entry point for them.
+
Most of the contents of this pass used to be in CoreToStg. The
primary goals here are:
-1. Get the program into "A-normal form". In particular:
+1. Saturate constructor and primop applications.
- f E ==> let x = E in f x
- OR ==> case E of x -> f x
+2. Convert to A-normal form:
+ * Use case for strict arguments:
+ f E ==> case E of x -> f x
+ (where f is strict)
- if E is a non-trivial expression.
- Which transformation is used depends on whether f is strict or not.
- [Previously the transformation to case used to be done by the
- simplifier, but it's better done here. It does mean that f needs
- to have its strictness info correct!.]
+ * Use let for non-trivial lazy arguments
+ f E ==> let x = E in f x
+ (were f is lazy and x is non-trivial)
-2. Similarly, convert any unboxed lets into cases.
- [I'm experimenting with leaving 'ok-for-speculation' rhss in let-form
- right up to this point.]
+3. Similarly, convert any unboxed lets into cases.
+ [I'm experimenting with leaving 'ok-for-speculation'
+ rhss in let-form right up to this point.]
- This is all done modulo type applications and abstractions, so that
- when type erasure is done for conversion to STG, we don't end up with
- any trivial or useless bindings.
-
-3. Ensure that lambdas only occur as the RHS of a binding
+4. Ensure that lambdas only occur as the RHS of a binding
(The code generator can't deal with anything else.)
-4. Saturate constructor and primop applications.
+5. Do the seq/par munging. See notes with mkCase below.
+This is all done modulo type applications and abstractions, so that
+when type erasure is done for conversion to STG, we don't end up with
+any trivial or useless bindings.
+
-- -----------------------------------------------------------------------------
coreSatPgm dflags binds
= do showPass dflags "CoreSat"
us <- mkSplitUniqSupply 's'
- let new_binds = initUs_ us (coreSatBinds binds)
+ let new_binds = initUs_ us (coreSatTopBinds binds)
endPass dflags "CoreSat" Opt_D_dump_sat new_binds
coreSatExpr :: DynFlags -> CoreExpr -> IO CoreExpr
us <- mkSplitUniqSupply 's'
let new_expr = initUs_ us (coreSatAnExpr expr)
dumpIfSet_dyn dflags Opt_D_dump_sat "Saturated/Normal form syntax:"
- (ppr new_expr)
+ (ppr new_expr)
return new_expr
-- ---------------------------------------------------------------------------
-- Dealing with bindings
-- ---------------------------------------------------------------------------
-data FloatingBind
- = RecF [(Id, CoreExpr)]
- | NonRecF Id
- CoreExpr -- *Can* be a Lam
- RhsDemand
- [FloatingBind]
-
-coreSatBinds :: [CoreBind] -> UniqSM [CoreBind]
-coreSatBinds [] = returnUs []
-coreSatBinds (b:bs)
- = coreSatBind b `thenUs` \ float ->
- coreSatBinds bs `thenUs` \ new_bs ->
- case float of
- NonRecF bndr rhs dem floats
- -> ASSERT2( not (isStrictDem dem) &&
- not (isUnLiftedType (idType bndr)),
- ppr b ) -- No top-level cases!
-
- mkBinds floats rhs `thenUs` \ new_rhs ->
- returnUs (NonRec bndr new_rhs : new_bs)
- -- Keep all the floats inside...
- -- Some might be cases etc
- -- We might want to revisit this decision
-
- RecF prs -> returnUs (Rec prs : new_bs)
-
-coreSatBind :: CoreBind -> UniqSM FloatingBind
+data FloatingBind = FloatLet CoreBind
+ | FloatCase Id CoreExpr
+
+allLazy :: OrdList FloatingBind -> Bool
+allLazy floats = foldOL check True floats
+ where
+ check (FloatLet _) y = y
+ check (FloatCase _ _) y = False
+
+coreSatTopBinds :: [CoreBind] -> UniqSM [CoreBind]
+-- Very careful to preserve the arity of top-level functions
+coreSatTopBinds [] = returnUs []
+
+coreSatTopBinds (NonRec b r : binds)
+ = coreSatTopRhs b r `thenUs` \ (floats, r') ->
+ coreSatTopBinds binds `thenUs` \ binds' ->
+ returnUs (floats ++ NonRec b r' : binds')
+
+coreSatTopBinds (Rec prs : binds)
+ = mapAndUnzipUs do_pair prs `thenUs` \ (floats_s, prs') ->
+ coreSatTopBinds binds `thenUs` \ binds' ->
+ returnUs (Rec (flattenBinds (concat floats_s) ++ prs') : binds')
+ where
+ do_pair (b,r) = coreSatTopRhs b r `thenUs` \ (floats, r') ->
+ returnUs (floats, (b, r'))
+
+coreSatTopRhs :: Id -> CoreExpr -> UniqSM ([CoreBind], CoreExpr)
+-- The trick here is that if we see
+-- x = $wC p $wJust q
+-- we want to transform to
+-- sat = \a -> $wJust a
+-- x = $wC p sat q
+-- and NOT to
+-- x = let sat = \a -> $wJust a in $wC p sat q
+--
+-- The latter is bad because the thing was a value before, but
+-- is a thunk now, and that's wrong because now x may need to
+-- be in other bindings' SRTs.
+-- This has to be right for recursive as well as non-recursive bindings
+--
+-- Notice that it's right to give sat vanilla IdInfo; in particular NoCafRefs
+--
+-- You might worry that arity might increase, thus
+-- x = $wC a ==> x = \ b c -> $wC a b c
+-- but the simpifier does eta expansion vigorously, so I don't think this
+-- can occur. If it did, it would be a problem, because x's arity changes,
+-- so we have an ASSERT to check. (I use WARN so we can see the output.)
+
+coreSatTopRhs b rhs
+ = coreSatExprFloat rhs `thenUs` \ (floats, rhs1) ->
+ if exprIsValue rhs then
+ ASSERT( allLazy floats )
+ WARN( idArity b /= exprArity rhs1, ptext SLIT("Disaster!") <+> ppr b )
+ returnUs ([bind | FloatLet bind <- fromOL floats], rhs1)
+ else
+ mkBinds floats rhs1 `thenUs` \ rhs2 ->
+ WARN( idArity b /= exprArity rhs2, ptext SLIT("Disaster!") <+> ppr b )
+ returnUs ([], rhs2)
+
+
+coreSatBind :: CoreBind -> UniqSM (OrdList FloatingBind)
+-- Used for non-top-level bindings
+-- We return a *list* of bindings because we may start with
+-- x* = f (g y)
+-- where x is demanded, in which case we want to finish with
+-- a = g y
+-- x* = f a
+-- And then x will actually end up case-bound
+
coreSatBind (NonRec binder rhs)
- = coreSatExprFloat rhs `thenUs` \ (floats, new_rhs) ->
- returnUs (NonRecF binder new_rhs (bdrDem binder) floats)
+ = coreSatExprFloat rhs `thenUs` \ (floats, new_rhs) ->
+ mkNonRec binder (bdrDem binder) floats new_rhs
+ -- NB: if there are any lambdas at the top of the RHS,
+ -- the floats will be empty, so the arity won't be affected
+
coreSatBind (Rec pairs)
- = mapUs do_rhs pairs `thenUs` \ new_rhss ->
- returnUs (RecF (binders `zip` new_rhss))
+ -- Don't bother to try to float bindings out of RHSs
+ -- (compare mkNonRec, which does try)
+ = mapUs do_rhs pairs `thenUs` \ new_pairs ->
+ returnUs (unitOL (FloatLet (Rec new_pairs)))
where
- binders = map fst pairs
- do_rhs (bndr,rhs) =
- coreSatExprFloat rhs `thenUs` \ (floats, new_rhs) ->
- mkBinds floats new_rhs `thenUs` \ new_rhs' ->
- -- NB: new_rhs' might still be a Lam (and we want that)
- returnUs new_rhs'
+ do_rhs (bndr,rhs) = coreSatAnExpr rhs `thenUs` \ new_rhs' ->
+ returnUs (bndr,new_rhs')
+
-- ---------------------------------------------------------------------------
-- Making arguments atomic (function args & constructor args)
-- ---------------------------------------------------------------------------
-- This is where we arrange that a non-trivial argument is let-bound
-coreSatArg :: CoreArg -> RhsDemand -> UniqSM ([FloatingBind], CoreArg)
+coreSatArg :: CoreArg -> RhsDemand -> UniqSM (OrdList FloatingBind, CoreArg)
coreSatArg arg dem
= coreSatExprFloat arg `thenUs` \ (floats, arg') ->
- if exprIsTrivial arg'
+ if needs_binding arg'
then returnUs (floats, arg')
else newVar (exprType arg') `thenUs` \ v ->
- returnUs ([NonRecF v arg' dem floats], Var v)
+ mkNonRec v dem floats arg' `thenUs` \ floats' ->
+ returnUs (floats', Var v)
+
+needs_binding | opt_KeepStgTypes = exprIsAtom
+ | otherwise = exprIsTrivial
-- ---------------------------------------------------------------------------
-- Dealing with expressions
mkBinds floats expr
-coreSatExprFloat :: CoreExpr -> UniqSM ([FloatingBind], CoreExpr)
+coreSatExprFloat :: CoreExpr -> UniqSM (OrdList FloatingBind, CoreExpr)
-- If
-- e ===> (bs, e')
-- then
-- f (g x) ===> ([v = g x], f v)
coreSatExprFloat (Var v)
- = fiddleCCall v `thenUs` \ v ->
- maybeSaturate v (Var v) 0 (idType v) `thenUs` \ app ->
- returnUs ([], app)
+ = maybeSaturate v (Var v) 0 (idType v) `thenUs` \ app ->
+ returnUs (nilOL, app)
coreSatExprFloat (Lit lit)
- = returnUs ([], Lit lit)
+ = returnUs (nilOL, Lit lit)
coreSatExprFloat (Let bind body)
- = coreSatBind bind `thenUs` \ new_bind ->
+ = coreSatBind bind `thenUs` \ new_binds ->
coreSatExprFloat body `thenUs` \ (floats, new_body) ->
- returnUs (new_bind:floats, new_body)
+ returnUs (new_binds `appOL` floats, new_body)
+
+coreSatExprFloat (Note n@(SCC _) expr)
+ = coreSatAnExpr expr `thenUs` \ expr ->
+ deLam expr `thenUs` \ expr ->
+ returnUs (nilOL, Note n expr)
coreSatExprFloat (Note other_note expr)
= coreSatExprFloat expr `thenUs` \ (floats, expr) ->
returnUs (floats, Note other_note expr)
coreSatExprFloat expr@(Type _)
- = returnUs ([], expr)
+ = returnUs (nilOL, expr)
-coreSatExprFloat (Lam v e)
- = coreSatAnExpr e `thenUs` \ e' ->
- returnUs ([], Lam v e')
+coreSatExprFloat expr@(Lam _ _)
+ = coreSatAnExpr body `thenUs` \ body' ->
+ returnUs (nilOL, mkLams bndrs body')
+ where
+ (bndrs,body) = collectBinders expr
coreSatExprFloat (Case scrut bndr alts)
= coreSatExprFloat scrut `thenUs` \ (floats, scrut) ->
mapUs sat_alt alts `thenUs` \ alts ->
- returnUs (floats, Case scrut bndr alts)
+ returnUs (floats, mkCase scrut bndr alts)
where
sat_alt (con, bs, rhs)
- = coreSatAnExpr rhs `thenUs` \ rhs ->
- deLam rhs `thenUs` \ rhs ->
+ = coreSatAnExpr rhs `thenUs` \ rhs ->
+ deLam rhs `thenUs` \ rhs ->
returnUs (con, bs, rhs)
coreSatExprFloat expr@(App _ _)
-- Deconstruct and rebuild the application, floating any non-atomic
-- arguments to the outside. We collect the type of the expression,
- -- the head of the applicaiton, and the number of actual value arguments,
+ -- the head of the application, and the number of actual value arguments,
-- all of which are used to possibly saturate this application if it
-- has a constructor or primop at the head.
collect_args
:: CoreExpr
- -> Int -- current app depth
- -> UniqSM (CoreExpr, -- the rebuilt expression
- (CoreExpr,Int), -- the head of the application,
+ -> Int -- current app depth
+ -> UniqSM (CoreExpr, -- the rebuilt expression
+ (CoreExpr,Int), -- the head of the application,
-- and no. of args it was applied to
- Type, -- type of the whole expr
- [FloatingBind], -- any floats we pulled out
- [Demand]) -- remaining argument demands
+ Type, -- type of the whole expr
+ OrdList FloatingBind, -- 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) ->
splitFunTy_maybe fun_ty
in
coreSatArg arg (mkDemTy ss1 arg_ty) `thenUs` \ (fs, arg') ->
- returnUs (App fun' arg', hd, res_ty, fs ++ floats, ss_rest)
+ returnUs (App fun' arg', hd, res_ty, fs `appOL` floats, ss_rest)
collect_args (Var v) depth
- = fiddleCCall v `thenUs` \ v ->
- returnUs (Var v, (Var v, depth), idType v, [], stricts)
+ = returnUs (Var v, (Var v, depth), idType v, nilOL, stricts)
where
stricts = case idStrictness v of
StrictnessInfo demands _
-- non-variable fun, better let-bind it
collect_args fun depth
- = newVar ty `thenUs` \ fn_id ->
- coreSatExprFloat fun `thenUs` \ (fun_floats, fun) ->
- returnUs (Var fn_id, (Var fn_id, depth), ty,
- [NonRecF fn_id fun onceDem fun_floats], [])
- where ty = exprType fun
+ = coreSatExprFloat fun `thenUs` \ (fun_floats, fun) ->
+ newVar ty `thenUs` \ fn_id ->
+ mkNonRec fn_id onceDem fun_floats fun `thenUs` \ floats ->
+ returnUs (Var fn_id, (Var fn_id, depth), ty, floats, [])
+ where
+ ty = exprType fun
ignore_note InlineCall = True
ignore_note InlineMe = True
maybeSaturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
maybeSaturate fn expr n_args ty
= case idFlavour fn of
- PrimOpId op -> saturate fn expr n_args ty
- DataConId dc -> saturate fn expr n_args ty
+ PrimOpId op -> saturate_it
+ DataConId dc -> saturate_it
other -> returnUs expr
-
-saturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
- -- The type should be the type of expr.
- -- The returned expression should also have this type
-saturate fn expr n_args ty
- = go excess_arity expr ty
where
fn_arity = idArity fn
excess_arity = fn_arity - n_args
+ saturate_it = getUs `thenUs` \ us ->
+ returnUs (etaExpand excess_arity us expr ty)
- go n expr ty
- | n == 0 -- Saturated, so nothing to do
- = returnUs expr
+-- ---------------------------------------------------------------------------
+-- Precipitating the floating bindings
+-- ---------------------------------------------------------------------------
- | otherwise -- An unsaturated constructor or primop; eta expand it
- = case splitForAllTy_maybe ty of {
- Just (tv,ty') -> go n (App expr (Type (mkTyVarTy tv))) ty' `thenUs` \ expr' ->
- returnUs (Lam tv expr') ;
- Nothing ->
-
- case splitFunTy_maybe ty of {
- Just (arg_ty, res_ty)
- -> newVar arg_ty `thenUs` \ arg' ->
- go (n-1) (App expr (Var arg')) res_ty `thenUs` \ expr' ->
- returnUs (Lam arg' expr') ;
- Nothing ->
-
- case splitNewType_maybe ty of {
- Just ty' -> go n (mkCoerce ty' ty expr) ty' `thenUs` \ expr' ->
- returnUs (mkCoerce ty ty' expr') ;
-
- Nothing -> pprTrace "Bad saturate" ((ppr fn <+> ppr expr) $$ ppr ty)
- returnUs expr
- }}}
+-- mkNonRec is used for local bindings only, not top level
+mkNonRec :: Id -> RhsDemand -- Lhs: id with demand
+ -> OrdList FloatingBind -> CoreExpr -- Rhs: let binds in body
+ -> UniqSM (OrdList FloatingBind)
+mkNonRec bndr dem floats rhs
+ | exprIsValue rhs && allLazy floats -- Notably constructor applications
+ = -- Why the test for allLazy? You might think that the only
+ -- floats we can get out of a value are eta expansions
+ -- e.g. C $wJust ==> let s = \x -> $wJust x in C s
+ -- Here we want to float the s binding.
+ --
+ -- But if the programmer writes this:
+ -- f x = case x of { (a,b) -> \y -> a }
+ -- then the strictness analyser may say that f has strictness "S"
+ -- Later the eta expander will transform to
+ -- f x y = case x of { (a,b) -> a }
+ -- So now f has arity 2. Now CoreSat may see
+ -- v = f E
+ -- so the E argument will turn into a FloatCase.
+ -- Indeed we should end up with
+ -- v = case E of { r -> f r }
+ -- That is, we should not float, even though (f r) is a value
+ returnUs (floats `snocOL` FloatLet (NonRec bndr rhs))
+
+ | isUnLiftedType bndr_rep_ty || isStrictDem dem
+ = ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
+ returnUs (floats `snocOL` FloatCase bndr rhs)
+
+ | otherwise
+ = mkBinds floats rhs `thenUs` \ rhs' ->
+ returnUs (unitOL (FloatLet (NonRec bndr rhs')))
+ where
+ bndr_rep_ty = repType (idType bndr)
-fiddleCCall id
- = case idFlavour id of
- PrimOpId (CCallOp ccall) ->
- -- Make a guaranteed unique name for a dynamic ccall.
- getUniqueUs `thenUs` \ uniq ->
- returnUs (modifyIdInfo (`setFlavourInfo`
- PrimOpId (CCallOp (setCCallUnique ccall uniq))) id)
- other_flavour ->
- returnUs id
+mkBinds :: OrdList FloatingBind -> CoreExpr -> UniqSM CoreExpr
+mkBinds binds body
+ | isNilOL binds = returnUs body
+ | otherwise = deLam body `thenUs` \ body' ->
+ returnUs (foldOL mk_bind body' binds)
+ where
+ mk_bind (FloatCase bndr rhs) body = mkCase rhs bndr [(DEFAULT, [], body)]
+ mk_bind (FloatLet bind) body = Let bind body
-- ---------------------------------------------------------------------------
-- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
+-- We arrange that they only show up as the RHS of a let(rec)
-- ---------------------------------------------------------------------------
-deLam (Note n e)
- = deLam e `thenUs` \ e ->
- returnUs (Note n e)
+deLam :: CoreExpr -> UniqSM CoreExpr
+-- Remove top level lambdas by let-bindinig
+
+deLam (Note n expr)
+ = -- You can get things like
+ -- case e of { p -> coerce t (\s -> ...) }
+ deLam expr `thenUs` \ expr' ->
+ returnUs (Note n expr')
+
+deLam expr
+ | null bndrs = returnUs expr
+ | otherwise = case tryEta bndrs body of
+ Just no_lam_result -> returnUs no_lam_result
+ Nothing -> newVar (exprType expr) `thenUs` \ fn ->
+ returnUs (Let (NonRec fn expr) (Var fn))
+ where
+ (bndrs,body) = collectBinders expr
+
+-- Why try eta reduction? Hasn't the simplifier already done eta?
+-- But the simplifier only eta reduces if that leaves something
+-- trivial (like f, or f Int). But for deLam it would be enough to
+-- get to a partial application, like (map f).
+
+tryEta bndrs expr@(App _ _)
+ | ok_to_eta_reduce f &&
+ n_remaining >= 0 &&
+ and (zipWith ok bndrs last_args) &&
+ not (any (`elemVarSet` fvs_remaining) bndrs)
+ = Just remaining_expr
+ where
+ (f, args) = collectArgs expr
+ remaining_expr = mkApps f remaining_args
+ fvs_remaining = exprFreeVars remaining_expr
+ (remaining_args, last_args) = splitAt n_remaining args
+ n_remaining = length args - length bndrs
+
+ ok bndr (Var arg) = bndr == arg
+ ok bndr other = False
+
+ -- we can't eta reduce something which must be saturated.
+ ok_to_eta_reduce (Var f)
+ = case idFlavour f of
+ PrimOpId op -> False
+ DataConId dc -> False
+ other -> True
+ ok_to_eta_reduce _ = False --safe. ToDo: generalise
+
+tryEta bndrs (Let bind@(NonRec b r) body)
+ | not (any (`elemVarSet` fvs) bndrs)
+ = case tryEta bndrs body of
+ Just e -> Just (Let bind e)
+ Nothing -> Nothing
+ where
+ fvs = exprFreeVars r
- -- types will all disappear, so that's ok
-deLam (Lam x e) | isTyVar x
- = deLam e `thenUs` \ e ->
- returnUs (Lam x e)
+tryEta bndrs _ = Nothing
+\end{code}
-deLam expr@(Lam _ _)
- -- Try for eta reduction
- | Just e <- eta body
- = returnUs e
- -- Eta failed, so let-bind the lambda
- | otherwise
- = newVar (exprType expr) `thenUs` \ fn ->
- returnUs (Let (NonRec fn expr) (Var fn))
+-- -----------------------------------------------------------------------------
+-- Do the seq and par transformation
+-- -----------------------------------------------------------------------------
- where
- (bndrs, body) = collectBinders expr
+Here we do two pre-codegen transformations:
- eta expr@(App _ _)
- | n_remaining >= 0 &&
- and (zipWith ok bndrs last_args) &&
- not (any (`elemVarSet` fvs_remaining) bndrs)
- = Just remaining_expr
- where
- (f, args) = collectArgs expr
- remaining_expr = mkApps f remaining_args
- fvs_remaining = exprFreeVars remaining_expr
- (remaining_args, last_args) = splitAt n_remaining args
- n_remaining = length args - length bndrs
+1. case seq# a of {
+ 0 -> seqError ...
+ DEFAULT -> rhs }
+ ==>
+ case a of { DEFAULT -> rhs }
- ok bndr (Var arg) = bndr == arg
- ok bndr other = False
- eta (Let bind@(NonRec b r) body)
- | not (any (`elemVarSet` fvs) bndrs)
- = case eta body of
- Just e -> Just (Let bind e)
- Nothing -> Nothing
- where fvs = exprFreeVars r
+2. case par# a of {
+ 0 -> parError ...
+ DEFAULT -> rhs }
+ ==>
+ case par# a of {
+ DEFAULT -> rhs }
- eta _ = Nothing
+NB: seq# :: a -> Int# -- Evaluate value and return anything
+ par# :: a -> Int# -- Spark value and return anything
-deLam expr = returnUs expr
+These transformations can't be done earlier, or else we might
+think that the expression was strict in the variables in which
+rhs is strict --- but that would defeat the purpose of seq and par.
--- ---------------------------------------------------------------------------
--- Precipitating the floating bindings
--- ---------------------------------------------------------------------------
-
-mkBinds :: [FloatingBind] -> CoreExpr -> UniqSM CoreExpr
-mkBinds [] body = returnUs body
-mkBinds (b:bs) body
- = deLam body `thenUs` \ body' ->
- go (b:bs) body'
- where
- go [] body = returnUs body
- go (b:bs) body = go bs body `thenUs` \ body' ->
- mkBind b body'
-
--- body can't be Lam
-mkBind (RecF prs) body = returnUs (Let (Rec prs) body)
-
-mkBind (NonRecF bndr rhs dem floats) body
-#ifdef DEBUG
- -- We shouldn't get let or case of the form v=w
- = if exprIsTrivial rhs
- then pprTrace "mkBind" (ppr bndr <+> ppr rhs)
- (mk_let bndr rhs dem floats body)
- else mk_let bndr rhs dem floats body
-
-mk_let bndr rhs dem floats body
-#endif
- | isUnLiftedType bndr_rep_ty
- = ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
- mkBinds floats (Case rhs bndr [(DEFAULT, [], body)])
- | is_whnf
- = if is_strict then
- -- Strict let with WHNF rhs
- mkBinds floats $
- Let (NonRec bndr rhs) body
- else
- -- Lazy let with WHNF rhs; float until we find a strict binding
- let
- (floats_out, floats_in) = splitFloats floats
- in
- mkBinds floats_in rhs `thenUs` \ new_rhs ->
- mkBinds floats_out $
- Let (NonRec bndr new_rhs) body
-
- | otherwise -- Not WHNF
- = if is_strict then
- -- Strict let with non-WHNF rhs
- mkBinds floats (Case rhs bndr [(DEFAULT, [], body)])
- else
- -- Lazy let with non-WHNF rhs, so keep the floats in the RHS
- mkBinds floats rhs `thenUs` \ new_rhs ->
- returnUs (Let (NonRec bndr new_rhs) body)
-
+\begin{code}
+mkCase scrut@(Var fn `App` Type ty `App` arg) bndr alts
+ = case isPrimOpId_maybe fn of
+ Just ParOp -> Case scrut bndr [deflt_alt]
+ Just SeqOp ->
+ Case arg new_bndr [deflt_alt]
+ other -> Case scrut bndr alts
where
- bndr_rep_ty = repType (idType bndr)
- is_strict = isStrictDem dem
- is_whnf = exprIsValue rhs
+ (deflt_alt : _) = [alt | alt@(DEFAULT,_,_) <- alts]
-splitFloats fs@(NonRecF _ _ dem _ : _)
- | isStrictDem dem = ([], fs)
+ new_bndr = ASSERT( isDeadBinder bndr ) -- The binder shouldn't be used in the expression!
+ setIdType bndr (exprType arg)
+ -- NB: SeqOp :: forall a. a -> Int#
+ -- So bndr has type Int#
+ -- But now we are going to scrutinise the SeqOp's argument directly,
+ -- so we must change the type of the case binder to match that
+ -- of the argument expression e.
-splitFloats (f : fs) = case splitFloats fs of
- (fs_out, fs_in) -> (f : fs_out, fs_in)
+mkCase scrut bndr alts = Case scrut bndr alts
+\end{code}
-splitFloats [] = ([], [])
-- -----------------------------------------------------------------------------
-- Demands
-- -----------------------------------------------------------------------------
+\begin{code}
data RhsDemand
= RhsDemand { isStrictDem :: Bool, -- True => used at least once
isOnceDem :: Bool -- True => used at most once
safeDem = RhsDemand False False -- always safe to use this
onceDem = RhsDemand False True -- used at most once
\end{code}
+
+
projects / ghc-hetmet.git / blobdiff