#include "HsVersions.h"
-import CoreUtils( exprIsAtom, exprType, exprIsValue, etaExpand )
+import CoreUtils( exprIsAtom, exprType, exprIsValue, etaExpand, exprArity, exprOkForSpeculation )
import CoreFVs ( exprFreeVars )
import CoreLint ( endPass )
import CoreSyn
import Type ( Type, applyTy, splitFunTy_maybe, isTyVarTy,
isUnLiftedType, isUnboxedTupleType, repType,
uaUTy, usOnce, usMany, eqUsage, seqType )
-import Demand ( Demand, isStrict, wwLazy, StrictnessInfo(..) )
+import NewDemand ( Demand, isStrictDmd, lazyDmd, StrictSig(..), DmdType(..) )
import PrimOp ( PrimOp(..) )
import Var ( Var, Id, setVarUnique )
import VarSet
import VarEnv
-import Id ( mkSysLocal, idType, idStrictness, idDemandInfo, idArity,
+import Id ( mkSysLocal, idType, idNewDemandInfo, idArity,
setIdType, isPrimOpId_maybe, isFCallId, isLocalId,
- hasNoBinding
+ hasNoBinding, idNewStrictness
)
import HscTypes ( ModDetails(..) )
import UniqSupply
-- ---------------------------------------------------------------------------
data FloatingBind = FloatLet CoreBind
- | FloatCase Id CoreExpr
+ | FloatCase Id CoreExpr Bool
+ -- The bool indicates "ok-for-speculation"
+
+instance Outputable FloatingBind where
+ ppr (FloatLet bind) = text "FloatLet" <+> ppr bind
+ ppr (FloatCase b rhs spec) = text "FloatCase" <+> ppr b <+> ppr spec <+> equals <+> ppr rhs
type CloneEnv = IdEnv Id -- Clone local Ids
allLazy :: OrdList FloatingBind -> Bool
-allLazy floats = foldOL check True floats
- where
- check (FloatLet _) y = y
- check (FloatCase _ _) y = False
+allLazy floats
+ = foldrOL check True floats
+ where
+ check (FloatLet _) y = y
+ check (FloatCase _ _ ok_for_spec) y = ok_for_spec && y
+ -- The ok-for-speculation flag says that it's safe to
+ -- float this Case out of a let, and thereby do it more eagerly
+ -- We need the top-level flag because it's never ok to float
+ -- an unboxed binding to the top level
+
+-- ---------------------------------------------------------------------------
+-- Bindings
+-- ---------------------------------------------------------------------------
corePrepTopBinds :: CloneEnv -> [CoreBind] -> UniqSM [CoreBind]
corePrepTopBinds env [] = returnUs []
corePrepTopBinds env (bind : binds)
- = corePrepBind env bind `thenUs` \ (env', floats) ->
- ASSERT( allLazy floats )
- corePrepTopBinds env' binds `thenUs` \ binds' ->
- returnUs (foldOL add binds' floats)
+ = corePrepTopBind env bind `thenUs` \ (env', bind') ->
+ corePrepTopBinds env' binds `thenUs` \ binds' ->
+ returnUs (bind' : binds')
+
+-- From top level bindings we don't get any floats
+-- (a) it isn't necessary because the mkAtomicArgs in Simplify
+-- has already done all the floating necessary
+-- (b) floating would give rise to top-level LocaIds, generated
+-- by CorePrep.newVar. That breaks the invariant that
+-- after CorePrep all top-level vars are GlobalIds
+
+corePrepTopBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, CoreBind)
+corePrepTopBind env (NonRec bndr rhs)
+ = corePrepRhs env (bndr, rhs) `thenUs` \ rhs' ->
+ cloneBndr env bndr `thenUs` \ (env', bndr') ->
+ returnUs (env', NonRec bndr' rhs')
+
+corePrepTopBind env (Rec pairs)
+ = corePrepRecPairs env pairs `thenUs` \ (env', pairs') ->
+ returnUs (env, Rec pairs')
+
+corePrepRecPairs env pairs
+ = cloneBndrs env bndrs `thenUs` \ (env', bndrs') ->
+ mapUs (corePrepRhs env') pairs `thenUs` \ rhss' ->
+ returnUs (env', bndrs' `zip` rhss')
where
- add (FloatLet bind) binds = bind : binds
+ bndrs = map fst pairs
+corePrepRhs :: CloneEnv -> (Id, CoreExpr) -> UniqSM CoreExpr
+ -- Used for top-level bindings, and local recursive bindings
+ -- c.f. mkLocalNonRec, which does the other case
+ -- No nonsense about floating.
+ -- Prepare the RHS and eta expand it.
+corePrepRhs env (bndr, rhs)
+ = corePrepAnExpr env rhs `thenUs` \ rhs' ->
+ getUniquesUs `thenUs` \ us ->
+ returnUs (etaExpand (exprArity rhs') us rhs' (idType bndr))
--- ---------------------------------------------------------------------------
--- Bindings
--- ---------------------------------------------------------------------------
-corePrepBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
--- Used for non-top-level bindings
+corePrepBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
+-- This one is used for *local* 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
-- And then x will actually end up case-bound
corePrepBind env (NonRec bndr rhs)
- = corePrepExprFloat env rhs `thenUs` \ (floats, rhs') ->
- cloneBndr env bndr `thenUs` \ (env', bndr') ->
- mkNonRec bndr' (bdrDem bndr') floats rhs' `thenUs` \ floats' ->
+ = corePrepExprFloat env rhs `thenUs` \ (floats, rhs') ->
+ cloneBndr env bndr `thenUs` \ (env', bndr') ->
+ mkLocalNonRec bndr' (bdrDem bndr') floats rhs' `thenUs` \ floats' ->
returnUs (env', floats')
corePrepBind env (Rec pairs)
-- Don't bother to try to float bindings out of RHSs
-- (compare mkNonRec, which does try)
- = cloneBndrs env bndrs `thenUs` \ (env', bndrs') ->
- mapUs (corePrepAnExpr env') rhss `thenUs` \ rhss' ->
- returnUs (env', unitOL (FloatLet (Rec (bndrs' `zip` rhss'))))
- where
- (bndrs, rhss) = unzip pairs
-
+ = corePrepRecPairs env pairs `thenUs` \ (env', pairs') ->
+ returnUs (env', unitOL (FloatLet (Rec pairs')))
-- ---------------------------------------------------------------------------
-- Making arguments atomic (function args & constructor args)
= corePrepExprFloat env arg `thenUs` \ (floats, arg') ->
if needs_binding arg'
then returnUs (floats, arg')
- else newVar (exprType arg') `thenUs` \ v ->
- mkNonRec v dem floats arg' `thenUs` \ floats' ->
+ else newVar (exprType arg') `thenUs` \ v ->
+ mkLocalNonRec v dem floats arg' `thenUs` \ floats' ->
returnUs (floats', Var v)
needs_binding | opt_RuntimeTypes = exprIsAtom
= 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)
- [] -> (wwLazy, [])
+ (ss1:ss_rest) -> (ss1, ss_rest)
+ [] -> (lazyDmd, [])
(arg_ty, res_ty) = expectJust "corePrepExprFloat:collect_args" $
splitFunTy_maybe fun_ty
in
let v2 = lookupVarEnv env v1 `orElse` v1 in
returnUs (Var v2, (Var v2, depth), idType v2, nilOL, stricts)
where
- stricts = case idStrictness v of
- StrictnessInfo demands _
+ stricts = case idNewStrictness v of
+ StrictSig (DmdType _ demands _)
| depth >= length demands -> demands
| otherwise -> []
- other -> []
-- If depth < length demands, then we have too few args to
-- satisfy strictness info so we have to ignore all the
-- strictness info, e.g. + (error "urk")
-- non-variable fun, better let-bind it
collect_args fun depth
- = corePrepExprFloat env fun `thenUs` \ (fun_floats, fun) ->
- newVar ty `thenUs` \ fn_id ->
- mkNonRec fn_id onceDem fun_floats fun `thenUs` \ floats ->
+ = corePrepExprFloat env fun `thenUs` \ (fun_floats, fun) ->
+ newVar ty `thenUs` \ fn_id ->
+ mkLocalNonRec fn_id onceDem fun_floats fun `thenUs` \ floats ->
returnUs (Var fn_id, (Var fn_id, depth), ty, floats, [])
where
ty = exprType fun
maybeSaturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
maybeSaturate fn expr n_args ty
| hasNoBinding fn = saturate_it
- | otherwise = returnUs expr
+ | otherwise = returnUs expr
where
fn_arity = idArity fn
excess_arity = fn_arity - n_args
- saturate_it = getUs `thenUs` \ us ->
+ saturate_it = getUniquesUs `thenUs` \ us ->
returnUs (etaExpand excess_arity us expr ty)
-- ---------------------------------------------------------------------------
-- Precipitating the floating bindings
-- ---------------------------------------------------------------------------
--- mkNonRec is used for both top level and local bindings
-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
+-- mkLocalNonRec is used only for local bindings
+mkLocalNonRec :: Id -> RhsDemand -- Lhs: id with demand
+ -> OrdList FloatingBind -> CoreExpr -- Rhs: let binds in body
+ -> UniqSM (OrdList FloatingBind)
+
+mkLocalNonRec 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
-- 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 `snocOL` FloatLet (NonRec bndr rhs))
+ --
+ -- Finally, eta-expand the RHS, for the benefit of the code gen
+ -- This might not have happened already, because eta expansion
+ -- is done by the simplifier only when there at least one lambda already.
+ --
+ -- NB: we could refrain when the RHS is trivial (which can happen
+ -- for exported things. This would reduce the amount of code
+ -- generated (a little) and make things a little words for
+ -- code compiled without -O. The case in point is data constructor
+ -- wrappers.
+ --
+ getUniquesUs `thenUs` \ us ->
+ let
+ rhs' = etaExpand (exprArity rhs) us rhs bndr_ty
+ in
+ returnUs (floats `snocOL` FloatLet (NonRec bndr rhs'))
- | isUnLiftedType bndr_rep_ty || isStrictDem dem
+ | isUnLiftedType bndr_rep_ty || isStrict dem
-- It's a strict let, or the binder is unlifted,
-- so we definitely float all the bindings
= ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
- returnUs (floats `snocOL` FloatCase bndr rhs)
+ returnUs (floats `snocOL` FloatCase bndr rhs (exprOkForSpeculation rhs))
| otherwise
- -- Don't float
+ -- Don't float; the RHS isn't a value
= mkBinds floats rhs `thenUs` \ rhs' ->
returnUs (unitOL (FloatLet (NonRec bndr rhs')))
where
- bndr_rep_ty = repType (idType bndr)
+ bndr_ty = idType bndr
+ bndr_rep_ty = repType bndr_ty
mkBinds :: OrdList FloatingBind -> CoreExpr -> UniqSM CoreExpr
mkBinds binds body
| isNilOL binds = returnUs body
| otherwise = deLam body `thenUs` \ body' ->
- returnUs (foldOL mk_bind body' binds)
+ returnUs (foldrOL mk_bind body' binds)
where
- mk_bind (FloatCase bndr rhs) body = mkCase rhs bndr [(DEFAULT, [], body)]
- mk_bind (FloatLet 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)
\begin{code}
data RhsDemand
- = RhsDemand { isStrictDem :: Bool, -- True => used at least once
+ = RhsDemand { isStrict :: Bool, -- True => used at least once
isOnceDem :: Bool -- True => used at most once
}
mkDem :: Demand -> Bool -> RhsDemand
-mkDem strict once = RhsDemand (isStrict strict) once
+mkDem strict once = RhsDemand (isStrictDmd strict) once
mkDemTy :: Demand -> Type -> RhsDemand
-mkDemTy strict ty = RhsDemand (isStrict strict) (isOnceTy ty)
+mkDemTy strict ty = RhsDemand (isStrictDmd strict) (isOnceTy ty)
isOnceTy :: Type -> Bool
isOnceTy ty
| isTyVarTy u = False -- if unknown at compile-time, is Top ie usMany
bdrDem :: Id -> RhsDemand
-bdrDem id = mkDem (idDemandInfo id) (isOnceTy (idType id))
+bdrDem id = mkDem (idNewDemandInfo id) (isOnceTy (idType id))
safeDem, onceDem :: RhsDemand
safeDem = RhsDemand False False -- always safe to use this
cloneBndr :: CloneEnv -> Var -> UniqSM (CloneEnv, Var)
cloneBndr env bndr
| isId bndr && isLocalId bndr -- Top level things, which we don't want
- -- to clone, have become ConstantIds by now
+ -- to clone, have become GlobalIds by now
= getUniqueUs `thenUs` \ uniq ->
let
bndr' = setVarUnique bndr uniq
projects / ghc-hetmet.git / blobdiff