#include "HsVersions.h"
-import CoreUtils( exprIsTrivial, exprIsAtom, exprType, exprIsValue, etaExpand )
+import CoreUtils( exprIsTrivial, exprIsAtom, exprType, exprIsValue, etaExpand, exprArity )
import CoreFVs ( exprFreeVars )
import CoreLint ( endPass )
import CoreSyn
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 ( IdFlavour(..) )
-import Id ( mkSysLocal, idType, idStrictness, idFlavour, idDemandInfo, idArity )
+import Id ( mkSysLocal, idType, idStrictness, idFlavour, idDemandInfo, idArity,
+ isDeadBinder, setIdType, isPrimOpId_maybe
+ )
import UniqSupply
import Maybes
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,
4. Ensure that lambdas only occur as the RHS of a binding
(The code generator can't deal with anything else.)
+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.
-- Dealing with bindings
-- ---------------------------------------------------------------------------
-data FloatingBind = FloatBind CoreBind
+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 bs
- = mapUs do_bind bs
+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_bind (NonRec b r) = coreSatAnExpr r `thenUs` \ r' ->
- returnUs (NonRec b r')
- do_bind (Rec prs) = mapUs do_pair prs `thenUs` \ prs' ->
- returnUs (Rec prs')
- do_pair (b,r) = coreSatAnExpr r `thenUs` \ r' ->
- returnUs (b, r')
+ 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)
coreSatBind (NonRec binder rhs)
= coreSatExprFloat rhs `thenUs` \ (floats, new_rhs) ->
- mkNonRec binder new_rhs (bdrDem binder) floats
+ 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)
+ -- 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 (FloatBind (Rec new_pairs)))
+ returnUs (unitOL (FloatLet (Rec new_pairs)))
where
do_rhs (bndr,rhs) = coreSatAnExpr rhs `thenUs` \ new_rhs' ->
returnUs (bndr,new_rhs')
if needs_binding arg'
then returnUs (floats, arg')
else newVar (exprType arg') `thenUs` \ v ->
- mkNonRec v arg' dem floats `thenUs` \ floats' ->
+ mkNonRec v dem floats arg' `thenUs` \ floats' ->
returnUs (floats', Var v)
needs_binding | opt_KeepStgTypes = exprIsAtom
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 ->
collect_args fun depth
= coreSatExprFloat fun `thenUs` \ (fun_floats, fun) ->
newVar ty `thenUs` \ fn_id ->
- mkNonRec fn_id fun onceDem fun_floats `thenUs` \ floats ->
+ mkNonRec fn_id onceDem fun_floats fun `thenUs` \ floats ->
returnUs (Var fn_id, (Var fn_id, depth), ty, floats, [])
where
ty = exprType fun
-- Precipitating the floating bindings
-- ---------------------------------------------------------------------------
--- mkNonrec is used for local bindings only, not top level
-mkNonRec bndr rhs dem floats
- | isUnLiftedType bndr_rep_ty
- || isStrictDem dem && not (exprIsValue rhs)
+-- 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)
- where
- bndr_rep_ty = repType (idType bndr)
-mkNonRec bndr rhs dem floats
+ | otherwise
= mkBinds floats rhs `thenUs` \ rhs' ->
- returnUs (unitOL (FloatBind (NonRec bndr rhs')))
+ returnUs (unitOL (FloatLet (NonRec bndr rhs')))
+
+ where
+ bndr_rep_ty = repType (idType bndr)
mkBinds :: OrdList FloatingBind -> CoreExpr -> UniqSM CoreExpr
mkBinds binds body
| otherwise = deLam body `thenUs` \ body' ->
returnUs (foldOL mk_bind body' binds)
where
- mk_bind (FloatCase bndr rhs) body = Case rhs bndr [(DEFAULT, [], body)]
- mk_bind (FloatBind bind) body = Let bind body
+ 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)
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
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 &&
fvs = exprFreeVars r
tryEta bndrs _ = Nothing
+\end{code}
+
+
+-- -----------------------------------------------------------------------------
+-- Do the seq and par transformation
+-- -----------------------------------------------------------------------------
+
+Here we do two pre-codegen transformations:
+
+1. case seq# a of {
+ 0 -> seqError ...
+ DEFAULT -> rhs }
+ ==>
+ case a of { DEFAULT -> rhs }
+
+
+2. case par# a of {
+ 0 -> parError ...
+ DEFAULT -> rhs }
+ ==>
+ case par# a of {
+ DEFAULT -> rhs }
+
+NB: seq# :: a -> Int# -- Evaluate value and return anything
+ par# :: a -> Int# -- Spark value and return anything
+
+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.
+
+
+\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
+ (deflt_alt : _) = [alt | alt@(DEFAULT,_,_) <- alts]
+
+ 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.
+
+mkCase scrut bndr alts = Case scrut bndr alts
+\end{code}
+
-- -----------------------------------------------------------------------------
-- 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