InsideLam, insideLam, notInsideLam,
OneBranch, oneBranch, notOneBranch,
- EP(..)
+ EP(..),
+
+ StrictnessMark(..), isMarkedUnboxed, isMarkedStrict
) where
#include "HsVersions.h"
showsPrec p occ = showsPrecSDoc p (ppr occ)
\end{code}
+%************************************************************************
+%* *
+\subsection{Strictness indication}
+%* *
+%************************************************************************
+
+The strictness annotations on types in data type declarations
+e.g. data T = MkT !Int !(Bool,Bool)
+
+\begin{code}
+data StrictnessMark
+ = MarkedUserStrict -- "!" in a source decl
+ | MarkedStrict -- "!" in an interface decl: strict but not unboxed
+ | MarkedUnboxed -- "!!" in an interface decl: unboxed
+ | NotMarkedStrict -- No annotation at all
+ deriving( Eq )
+
+isMarkedUnboxed MarkedUnboxed = True
+isMarkedUnboxed other = False
+
+isMarkedStrict NotMarkedStrict = False
+isMarkedStrict other = True -- All others are strict
+
+instance Outputable StrictnessMark where
+ ppr MarkedUserStrict = ptext SLIT("!u")
+ ppr MarkedStrict = ptext SLIT("!")
+ ppr MarkedUnboxed = ptext SLIT("! !")
+ ppr NotMarkedStrict = empty
+\end{code}
import Name ( Name, NamedThing(..), nameUnique )
import Var ( TyVar, Id )
import FieldLabel ( FieldLabel )
-import BasicTypes ( Arity )
-import Demand ( Demand, StrictnessMark(..), wwStrict, wwLazy )
+import BasicTypes ( Arity, StrictnessMark(..) )
+import NewDemand ( Demand, lazyDmd, seqDmd )
import Outputable
import Unique ( Unique, Uniquable(..) )
import CmdLineOpts ( opt_UnboxStrictFields )
Just (arg_tycon, _) -> isProductTyCon arg_tycon
unbox_strict_arg_ty
- :: StrictnessMark -- After strategy choice; can't be MkaredUserStrict
+ :: StrictnessMark -- After strategy choice; can't be MarkedUserStrict
-> Type -- Source argument type
-> [(Demand,Type)] -- Representation argument types and demamds
-unbox_strict_arg_ty NotMarkedStrict ty = [(wwLazy, ty)]
-unbox_strict_arg_ty MarkedStrict ty = [(wwStrict, ty)]
+unbox_strict_arg_ty NotMarkedStrict ty = [(lazyDmd, ty)]
+unbox_strict_arg_ty MarkedStrict ty = [(seqDmd, ty)]
unbox_strict_arg_ty MarkedUnboxed ty
= zipEqual "unbox_strict_arg_ty" (dataConRepStrictness arg_data_con) arg_tys
where
- (_, _, arg_data_con, arg_tys)
- = splitProductType "unbox_strict_arg_ty" (repType ty)
+ (_, _, arg_data_con, arg_tys) = splitProductType "unbox_strict_arg_ty" (repType ty)
\end{code}
ppStrictnessInfo, seqStrictnessInfo,
isBottomingStrictness, appIsBottom,
- StrictnessMark(..), isMarkedUnboxed, isMarkedStrict
) where
#include "HsVersions.h"
\end{code}
-%************************************************************************
-%* *
-\subsection{Strictness indication}
-%* *
-%************************************************************************
-
-The strictness annotations on types in data type declarations
-e.g. data T = MkT !Int !(Bool,Bool)
-
-\begin{code}
-data StrictnessMark
- = MarkedUserStrict -- "!" in a source decl
- | MarkedStrict -- "!" in an interface decl: strict but not unboxed
- | MarkedUnboxed -- "!!" in an interface decl: unboxed
- | NotMarkedStrict -- No annotation at all
- deriving( Eq )
-
-isMarkedUnboxed MarkedUnboxed = True
-isMarkedUnboxed other = False
-
-isMarkedStrict NotMarkedStrict = False
-isMarkedStrict other = True -- All others are strict
-
-instance Outputable StrictnessMark where
- ppr MarkedUserStrict = ptext SLIT("!u")
- ppr MarkedStrict = ptext SLIT("!")
- ppr MarkedUnboxed = ptext SLIT("! !")
- ppr NotMarkedStrict = empty
-\end{code}
-- IdInfo stuff
setIdUnfolding,
setIdArityInfo,
- setIdDemandInfo,
- setIdStrictness,
+ setIdDemandInfo, setIdNewDemandInfo,
+ setIdStrictness, setIdNewStrictness,
setIdTyGenInfo,
setIdWorkerInfo,
setIdSpecialisation,
setIdOccInfo,
idArity, idArityInfo,
- idDemandInfo,
- idStrictness,
+ idDemandInfo, idNewDemandInfo,
+ idStrictness, idNewStrictness, idNewStrictness_maybe, getNewStrictness,
idTyGenInfo,
idWorkerInfo,
idUnfolding,
idLBVarInfo,
idOccInfo,
+ newStrictnessFromOld -- Temporary
+
) where
#include "HsVersions.h"
import IdInfo
-import Demand ( Demand )
+import qualified Demand ( Demand )
+import NewDemand ( Demand, DmdResult(..), StrictSig, topSig, isBotRes,
+ isBottomingSig, splitStrictSig, strictSigResInfo
+ )
import Name ( Name, OccName,
mkSysLocalName, mkLocalName,
getOccName, getSrcLoc
import PrimRep ( PrimRep )
import TysPrim ( statePrimTyCon )
import FieldLabel ( FieldLabel )
+import Maybes ( orElse )
import SrcLoc ( SrcLoc )
import Outputable
import Unique ( Unique, mkBuiltinUnique )
`setIdArityInfo`,
`setIdDemandInfo`,
`setIdStrictness`,
+ `setIdNewDemandInfo`,
+ `setIdNewStrictness`,
`setIdTyGenInfo`,
`setIdWorkerInfo`,
`setIdSpecialisation`,
setIdArityInfo id arity = modifyIdInfo (`setArityInfo` arity) id
---------------------------------
- -- STRICTNESS
+ -- STRICTNESS
idStrictness :: Id -> StrictnessInfo
-idStrictness id = strictnessInfo (idInfo id)
+idStrictness id = case strictnessInfo (idInfo id) of
+ NoStrictnessInfo -> case idNewStrictness_maybe id of
+ Just sig -> oldStrictnessFromNew sig
+ Nothing -> NoStrictnessInfo
+ strictness -> strictness
setIdStrictness :: Id -> StrictnessInfo -> Id
setIdStrictness id strict_info = modifyIdInfo (`setStrictnessInfo` strict_info) id
-- isBottomingId returns true if an application to n args would diverge
isBottomingId :: Id -> Bool
-isBottomingId id = isBottomingStrictness (idStrictness id)
+isBottomingId id = isBottomingSig (idNewStrictness id)
+
+idNewStrictness_maybe :: Id -> Maybe StrictSig
+idNewStrictness :: Id -> StrictSig
+
+idNewStrictness_maybe id = newStrictnessInfo (idInfo id)
+idNewStrictness id = idNewStrictness_maybe id `orElse` topSig
+
+getNewStrictness :: Id -> StrictSig
+-- First tries the "new-strictness" field, and then
+-- reverts to the old one. This is just until we have
+-- cross-module info for new strictness
+getNewStrictness id = idNewStrictness_maybe id `orElse` newStrictnessFromOld id
+
+newStrictnessFromOld :: Id -> StrictSig
+newStrictnessFromOld id = mkNewStrictnessInfo id (idArity id) (idStrictness id) (idCprInfo id)
+
+oldStrictnessFromNew :: StrictSig -> StrictnessInfo
+oldStrictnessFromNew sig = mkStrictnessInfo (map oldDemand dmds, isBotRes res_info)
+ where
+ (dmds, res_info) = splitStrictSig sig
+
+setIdNewStrictness :: Id -> StrictSig -> Id
+setIdNewStrictness id sig = modifyIdInfo (`setNewStrictnessInfo` Just sig) id
---------------------------------
-- TYPE GENERALISATION
---------------------------------
-- DEMAND
-idDemandInfo :: Id -> Demand
+idDemandInfo :: Id -> Demand.Demand
idDemandInfo id = demandInfo (idInfo id)
-setIdDemandInfo :: Id -> Demand -> Id
+setIdDemandInfo :: Id -> Demand.Demand -> Id
setIdDemandInfo id demand_info = modifyIdInfo (`setDemandInfo` demand_info) id
+idNewDemandInfo :: Id -> NewDemand.Demand
+idNewDemandInfo id = newDemandInfo (idInfo id)
+
+setIdNewDemandInfo :: Id -> NewDemand.Demand -> Id
+setIdNewDemandInfo id dmd = modifyIdInfo (`setNewDemandInfo` dmd) id
+
---------------------------------
-- SPECIALISATION
idSpecialisation :: Id -> CoreRules
---------------------------------
-- CG ARITY
-
idCgArity :: Id -> Arity
idCgArity id = cgArity (idCgInfo id)
---------------------------------
-- CPR INFO
idCprInfo :: Id -> CprInfo
-idCprInfo id = cprInfo (idInfo id)
+idCprInfo id = case cprInfo (idInfo id) of
+ NoCPRInfo -> case strictSigResInfo (idNewStrictness id) of
+ RetCPR -> ReturnsCPR
+ other -> NoCPRInfo
+ ReturnsCPR -> ReturnsCPR
setIdCprInfo :: Id -> CprInfo -> Id
setIdCprInfo id cpr_info = modifyIdInfo (`setCprInfo` cpr_info) id
shortableIdInfo, copyIdInfo,
-- Arity
- ArityInfo(..),
+ ArityInfo,
exactArity, unknownArity, hasArity,
arityInfo, setArityInfo, ppArityInfo, arityLowerBound,
-- New demand and strictness info
newStrictnessInfo, setNewStrictnessInfo, mkNewStrictnessInfo,
- newDemandInfo, setNewDemandInfo, newDemand,
+ newDemandInfo, setNewDemandInfo, newDemand, oldDemand,
-- Strictness; imported from Demand
StrictnessInfo(..),
import ForeignCall ( ForeignCall )
import FieldLabel ( FieldLabel )
import Type ( usOnce, usMany )
-import Demand -- Lots of stuff
-import qualified NewDemand
+import Demand hiding( Demand )
+import NewDemand ( Demand(..), Keepity(..), Deferredness(..), DmdResult(..),
+ lazyDmd, topDmd,
+ StrictSig, mkStrictSig,
+ DmdType, mkTopDmdType
+ )
import Outputable
import Util ( seqList )
import List ( replicate )
To be removed later
\begin{code}
-mkNewStrictnessInfo :: Id -> Arity -> StrictnessInfo -> CprInfo -> NewDemand.StrictSig
-mkNewStrictnessInfo id arity NoStrictnessInfo cpr
- = NewDemand.mkStrictSig id
- arity
- (NewDemand.mkTopDmdType (replicate arity NewDemand.Lazy) (newRes False cpr))
-
-mkNewStrictnessInfo id arity (StrictnessInfo ds res) cpr
- = NewDemand.mkStrictSig id
- arity
- (NewDemand.mkTopDmdType (take arity (map newDemand ds)) (newRes res cpr))
+mkNewStrictnessInfo :: Id -> Arity -> Demand.StrictnessInfo -> CprInfo -> StrictSig
+mkNewStrictnessInfo id arity Demand.NoStrictnessInfo cpr
+ = mkStrictSig id arity $
+ mkTopDmdType (replicate arity lazyDmd) (newRes False cpr)
+
+mkNewStrictnessInfo id arity (Demand.StrictnessInfo ds res) cpr
+ = mkStrictSig id arity $
+ mkTopDmdType (take arity (map newDemand ds)) (newRes res cpr)
-- Sometimes the old strictness analyser has more
-- demands than the arity justifies
-newRes True _ = NewDemand.BotRes
-newRes False ReturnsCPR = NewDemand.RetCPR
-newRes False NoCPRInfo = NewDemand.TopRes
-
-newDemand :: Demand -> NewDemand.Demand
-newDemand (WwLazy True) = NewDemand.Abs
-newDemand (WwLazy False) = NewDemand.Lazy
-newDemand WwStrict = NewDemand.Eval
-newDemand (WwUnpack unpk ds) = NewDemand.Seq NewDemand.Drop NewDemand.Now (map newDemand ds)
-newDemand WwPrim = NewDemand.Lazy
-newDemand WwEnum = NewDemand.Eval
+newRes True _ = BotRes
+newRes False ReturnsCPR = RetCPR
+newRes False NoCPRInfo = TopRes
+
+newDemand :: Demand.Demand -> NewDemand.Demand
+newDemand (WwLazy True) = Abs
+newDemand (WwLazy False) = Lazy
+newDemand WwStrict = Eval
+newDemand (WwUnpack unpk ds) = Seq Drop Now (map newDemand ds)
+newDemand WwPrim = Lazy
+newDemand WwEnum = Eval
+
+oldDemand :: NewDemand.Demand -> Demand.Demand
+oldDemand Abs = WwLazy True
+oldDemand Lazy = WwLazy False
+oldDemand Eval = WwStrict
+oldDemand (Seq _ _ ds) = WwUnpack True (map oldDemand ds)
+oldDemand (Call _) = WwStrict
\end{code}
data IdInfo
= IdInfo {
arityInfo :: ArityInfo, -- Its arity
- demandInfo :: Demand, -- Whether or not it is definitely demanded
+ demandInfo :: Demand.Demand, -- Whether or not it is definitely demanded
specInfo :: CoreRules, -- Specialisations of this function which exist
tyGenInfo :: TyGenInfo, -- Restrictions on usage-generalisation of this Id
strictnessInfo :: StrictnessInfo, -- Strictness properties
inlinePragInfo :: InlinePragInfo, -- Inline pragma
occInfo :: OccInfo, -- How it occurs
- newStrictnessInfo :: Maybe NewDemand.StrictSig,
- newDemandInfo :: NewDemand.Demand
+ newStrictnessInfo :: Maybe StrictSig,
+ newDemandInfo :: Demand
}
seqIdInfo :: IdInfo -> ()
setLBVarInfo info lb = info { lbvarInfo = lb }
setNewDemandInfo info dd = info { newDemandInfo = dd }
-setNewStrictnessInfo info dd = info { newStrictnessInfo = Just dd }
+setNewStrictnessInfo info dd = info { newStrictnessInfo = dd }
\end{code}
lbvarInfo = NoLBVarInfo,
inlinePragInfo = NoInlinePragInfo,
occInfo = NoOccInfo,
- newDemandInfo = NewDemand.topDmd,
+ newDemandInfo = topDmd,
newStrictnessInfo = Nothing
}
#include "HsVersions.h"
-import BasicTypes ( Arity )
+import BasicTypes ( Arity, StrictnessMark(..), isMarkedUnboxed, isMarkedStrict )
import TysPrim ( openAlphaTyVars, alphaTyVar, alphaTy,
intPrimTy, realWorldStatePrimTy
)
import OccName ( mkVarOcc )
import PrimOp ( PrimOp(DataToTagOp), primOpSig, mkPrimOpIdName )
import ForeignCall ( ForeignCall )
-import Demand ( wwStrict, wwPrim, mkStrictnessInfo, noStrictnessInfo,
- StrictnessMark(..), isMarkedUnboxed, isMarkedStrict )
import DataCon ( DataCon,
dataConFieldLabels, dataConRepArity, dataConTyCon,
dataConArgTys, dataConRepType, dataConRepStrictness,
)
import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal,
mkTemplateLocals, mkTemplateLocalsNum,
- mkTemplateLocal, idCprInfo, idName
+ mkTemplateLocal, idNewStrictness, idName
)
import IdInfo ( IdInfo, noCafNoTyGenIdInfo,
exactArity, setUnfoldingInfo, setCprInfo,
setArityInfo, setSpecInfo, setCgInfo,
- setStrictnessInfo,
mkNewStrictnessInfo, setNewStrictnessInfo,
GlobalIdDetails(..), CafInfo(..), CprInfo(..),
CgInfo(..), setCgArity
)
+import NewDemand ( mkStrictSig, strictSigResInfo, DmdResult(..),
+ mkTopDmdType, topDmd, evalDmd )
import FieldLabel ( mkFieldLabel, fieldLabelName,
firstFieldLabelTag, allFieldLabelTags, fieldLabelType
)
where
id = mkGlobalId (DataConId data_con) work_name (dataConRepType data_con) info
info = noCafNoTyGenIdInfo
- `setCgArity` arity
- `setArityInfo` arity
- `setCprInfo` cpr_info
- `setStrictnessInfo` strict_info
- `setNewStrictnessInfo` mkNewStrictnessInfo id arity strict_info cpr_info
+ `setCgArity` arity
+ `setArityInfo` arity
+ `setNewStrictnessInfo` Just strict_sig
arity = dataConRepArity data_con
- strict_info = mkStrictnessInfo (dataConRepStrictness data_con, False)
+ strict_sig = mkStrictSig id arity (mkTopDmdType (dataConRepStrictness data_con) cpr_info)
tycon = dataConTyCon data_con
cpr_info | isProductTyCon tycon &&
isDataTyCon tycon &&
arity > 0 &&
- arity <= mAX_CPR_SIZE = ReturnsCPR
- | otherwise = NoCPRInfo
- -- ReturnsCPR is only true for products that are real data types;
+ arity <= mAX_CPR_SIZE = RetCPR
+ | otherwise = TopRes
+ -- RetCPR is only true for products that are real data types;
-- that is, not unboxed tuples or [non-recursive] newtypes
mAX_CPR_SIZE :: Arity
info = noCafNoTyGenIdInfo
`setUnfoldingInfo` mkTopUnfolding (mkInlineMe wrap_rhs)
- `setCprInfo` cpr_info
- -- The Cpr info can be important inside INLINE rhss, where the
- -- wrapper constructor isn't inlined
`setCgArity` arity
-- The NoCaf-ness is set by noCafNoTyGenIdInfo
`setArityInfo` arity
-- It's important to specify the arity, so that partial
-- applications are treated as values
- `setNewStrictnessInfo` mkNewStrictnessInfo wrap_id arity noStrictnessInfo cpr_info
+ `setNewStrictnessInfo` Just wrap_sig
wrap_ty = mkForAllTys all_tyvars $
mkFunTys all_arg_tys
result_ty
- cpr_info = idCprInfo work_id
+ res_info = strictSigResInfo (idNewStrictness work_id)
+ wrap_sig = mkStrictSig wrap_id arity (mkTopDmdType (replicate arity topDmd) res_info)
+ -- The Cpr info can be important inside INLINE rhss, where the
+ -- wrapper constructor isn't inlined
+ -- But we are sloppy about the argument demands, because we expect
+ -- to inline the constructor very vigorously.
wrap_rhs | isNewTyCon tycon
= ASSERT( null ex_tyvars && null ex_dict_args && length orig_arg_tys == 1 )
`setSpecInfo` rules
`setCgArity` arity
`setArityInfo` arity
- `setStrictnessInfo` strict_info
- `setNewStrictnessInfo` mkNewStrictnessInfo id arity strict_info NoCPRInfo
+ `setNewStrictnessInfo` Just (mkNewStrictnessInfo id arity strict_info NoCPRInfo)
+ -- Until we modify the primop generation code
rules = maybe emptyCoreRules (addRule emptyCoreRules id)
(primOpRule prim_op)
name = mkFCallName uniq occ_str
info = noCafNoTyGenIdInfo
- `setCgArity` arity
- `setArityInfo` arity
- `setStrictnessInfo` strict_info
- `setNewStrictnessInfo` mkNewStrictnessInfo id arity strict_info NoCPRInfo
+ `setCgArity` arity
+ `setArityInfo` arity
+ `setNewStrictnessInfo` Just strict_sig
(_, tau) = tcSplitForAllTys ty
(arg_tys, _) = tcSplitFunTys tau
arity = length arg_tys
- strict_info = mkStrictnessInfo (take arity (repeat wwPrim), False)
+ strict_sig = mkStrictSig id arity (mkTopDmdType (replicate arity evalDmd) TopRes)
\end{code}
= id
where
id = pcMiscPrelId key mod name ty bottoming_info
- strict_info = mkStrictnessInfo ([wwStrict], True)
- bottoming_info = noCafNoTyGenIdInfo
- `setStrictnessInfo` strict_info
- `setNewStrictnessInfo` mkNewStrictnessInfo id 1 strict_info NoCPRInfo
-
-
+ arity = 1
+ strict_sig = mkStrictSig id arity (mkTopDmdType [evalDmd] BotRes)
+ bottoming_info = noCafNoTyGenIdInfo `setNewStrictnessInfo` Just strict_sig
-- these "bottom" out, no matter what their arguments
generic_ERROR_ID u n = pc_bottoming_Id u pREL_ERR n errorTy
\begin{code}
module NewDemand(
- Demand(..), Keepity(..), Deferredness(..), topDmd,
- StrictSig(..), topSig, botSig, mkStrictSig,
- DmdType(..), topDmdType, mkDmdType, mkTopDmdType,
+ Demand(..), Keepity(..), Deferredness(..),
+ topDmd, lazyDmd, seqDmd, evalDmd, isStrictDmd,
+
+ DmdType(..), topDmdType, mkDmdType, mkTopDmdType,
+ dmdTypeDepth, dmdTypeRes,
DmdEnv, emptyDmdEnv,
- DmdResult(..), isBotRes
+ DmdResult(..), isBotRes, returnsCPR,
+
+ StrictSig(..), mkStrictSig, topSig, botSig,
+ splitStrictSig, strictSigResInfo,
+ pprIfaceStrictSig, appIsBottom, isBottomingSig
) where
#include "HsVersions.h"
%************************************************************************
%* *
-\subsection{Strictness signatures
-%* *
-%************************************************************************
-
-\begin{code}
-data StrictSig = StrictSig Arity DmdType
- deriving( Eq )
- -- Equality needed when comparing strictness
- -- signatures for fixpoint finding
-
-topSig = StrictSig 0 topDmdType
-botSig = StrictSig 0 botDmdType
-
-mkStrictSig :: Id -> Arity -> DmdType -> StrictSig
-mkStrictSig id arity ty
- = WARN( arity /= dmdTypeDepth ty, ppr id <+> (ppr arity $$ ppr ty) )
- StrictSig arity ty
-
-instance Outputable StrictSig where
- ppr (StrictSig arity ty) = ppr ty
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection{Demand types}
%* *
%************************************************************************
data DmdResult = TopRes -- Nothing known
| RetCPR -- Returns a constructed product
| BotRes -- Diverges or errors
- deriving( Eq )
+ deriving( Eq, Show )
+ -- Equality for fixpoints
+ -- Show needed for Show in Lex.Token (sigh)
-- Equality needed for fixpoints in DmdAnal
instance Eq DmdType where
pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd
instance Outputable DmdResult where
- ppr TopRes = char 'T'
+ ppr TopRes = empty
ppr RetCPR = char 'M'
ppr BotRes = char 'X'
isBotRes BotRes = True
isBotRes other = False
+returnsCPR :: DmdResult -> Bool
+returnsCPR RetCPR = True
+returnsCPR other = False
+
mkDmdType :: DmdEnv -> [Demand] -> DmdResult -> DmdType
mkDmdType fv ds res = DmdType fv ds res
dmdTypeDepth :: DmdType -> Arity
dmdTypeDepth (DmdType _ ds _) = length ds
+
+dmdTypeRes :: DmdType -> DmdResult
+dmdTypeRes (DmdType _ _ res_ty) = res_ty
\end{code}
%************************************************************************
%* *
+\subsection{Strictness signature
+%* *
+%************************************************************************
+
+In a let-bound Id we record its strictness info.
+In principle, this strictness info is a demand transformer, mapping
+a demand on the Id into a DmdType, which gives
+ a) the free vars of the Id's value
+ b) the Id's arguments
+ c) an indication of the result of applying
+ the Id to its arguments
+
+However, in fact we store in the Id an extremely emascuated demand transfomer,
+namely
+ a single DmdType
+(Nevertheless we dignify StrictSig as a distinct type.)
+
+This DmdType gives the demands unleashed by the Id when it is applied
+to as many arguments as are given in by the arg demands in the DmdType.
+
+For example, the demand transformer described by the DmdType
+ DmdType {x -> U(LL)} [V,A] Top
+says that when the function is applied to two arguments, it
+unleashes demand U(LL) on the free var x, V on the first arg,
+and A on the second.
+
+If this same function is applied to one arg, all we can say is
+that it uses x with U*(LL), and its arg with demand L.
+
+\begin{code}
+newtype StrictSig = StrictSig DmdType
+ deriving( Eq )
+
+instance Outputable StrictSig where
+ ppr (StrictSig ty) = ppr ty
+
+instance Show StrictSig where
+ show (StrictSig ty) = showSDoc (ppr ty)
+
+mkStrictSig :: Id -> Arity -> DmdType -> StrictSig
+mkStrictSig id arity dmd_ty
+ = WARN( arity /= dmdTypeDepth dmd_ty, ppr id <+> (ppr arity $$ ppr dmd_ty) )
+ StrictSig dmd_ty
+
+splitStrictSig :: StrictSig -> ([Demand], DmdResult)
+splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res)
+
+strictSigResInfo :: StrictSig -> DmdResult
+strictSigResInfo (StrictSig (DmdType _ _ res)) = res
+
+topSig = StrictSig topDmdType
+botSig = StrictSig botDmdType
+
+-- appIsBottom returns true if an application to n args would diverge
+appIsBottom (StrictSig (DmdType _ ds BotRes)) n = n >= length ds
+appIsBottom _ _ = False
+
+isBottomingSig (StrictSig (DmdType _ _ BotRes)) = True
+isBottomingSig _ = False
+
+pprIfaceStrictSig :: StrictSig -> SDoc
+-- Used for printing top-level strictness pragmas in interface files
+pprIfaceStrictSig (StrictSig (DmdType _ dmds res))
+ = hcat (map ppr dmds) <> ppr res
+\end{code}
+
+
+%************************************************************************
+%* *
\subsection{Demands}
%* *
%************************************************************************
data Keepity = Keep | Drop
deriving( Eq )
-topDmd :: Demand -- The most uninformative demand
-topDmd = Lazy
+topDmd, lazyDmd, seqDmd :: Demand
+topDmd = Lazy -- The most uninformative demand
+lazyDmd = Lazy
+seqDmd = Seq Keep Now [] -- Polymorphic seq demand
+evalDmd = Eval
+
+isStrictDmd :: Demand -> Bool
+isStrictDmd Bot = True
+isStrictDmd Err = True
+isStrictDmd (Seq _ Now _) = True
+isStrictDmd Eval = True
+isStrictDmd (Call _) = True
+isStrictDmd other = False
instance Outputable Demand where
ppr Lazy = char 'L'
ppr Err = char 'X'
ppr Bot = char 'B'
ppr (Call d) = char 'C' <> parens (ppr d)
+ ppr (Seq k l []) = ppr k <> ppr l
ppr (Seq k l ds) = ppr k <> ppr l <> parens (hcat (map ppr ds))
instance Outputable Deferredness where
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
= 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")
-- because floating the case would make it evaluated too early
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) )
\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
setIdUnfolding, hasNoBinding, mkUserLocal
)
import IdInfo {- loads of stuff -}
+import NewDemand ( isBottomingSig, topSig )
import Name ( getOccName, nameOccName, globaliseName, setNameOcc,
localiseName, isGlobalName, setNameUnique
)
idinfo = idInfo id
dont_inline = isNeverInlinePrag (inlinePragInfo idinfo)
loop_breaker = isLoopBreaker (occInfo idinfo)
- bottoming_fn = isBottomingStrictness (strictnessInfo idinfo)
+ bottoming_fn = isBottomingSig (newStrictnessInfo idinfo `orElse` topSig)
spec_ids = rulesRhsFreeVars (specInfo idinfo)
worker_info = workerInfo idinfo
| opt_OmitInterfacePragmas || not is_external
-- No IdInfo if the Id isn't external, or if we don't have -O
= vanillaIdInfo
- `setCgInfo` cg_info
- `setStrictnessInfo` strictnessInfo core_idinfo
+ `setCgInfo` cg_info
+ `setNewStrictnessInfo` newStrictnessInfo core_idinfo
-- Keep strictness; it's used by CorePrep
| otherwise
= vanillaIdInfo
- `setCgInfo` cg_info
- `setCprInfo` cprInfo core_idinfo
- `setStrictnessInfo` strictnessInfo core_idinfo
- `setInlinePragInfo` inlinePragInfo core_idinfo
- `setUnfoldingInfo` unfold_info
- `setWorkerInfo` tidyWorker tidy_env (workerInfo core_idinfo)
+ `setCgInfo` cg_info
+ `setNewStrictnessInfo` newStrictnessInfo core_idinfo
+ `setInlinePragInfo` inlinePragInfo core_idinfo
+ `setUnfoldingInfo` unfold_info
+ `setWorkerInfo` tidyWorker tidy_env (workerInfo core_idinfo)
-- NB: we throw away the Rules
-- They have already been extracted by findExternalRules
where
import Literal ( hashLiteral, literalType, litIsDupable )
import DataCon ( DataCon, dataConRepArity )
import PrimOp ( primOpOkForSpeculation, primOpIsCheap )
-import Id ( Id, idType, globalIdDetails, idStrictness, idLBVarInfo,
+import Id ( Id, idType, globalIdDetails, idNewStrictness, idLBVarInfo,
mkWildId, idArity, idName, idUnfolding, idInfo, isOneShotLambda,
isDataConId_maybe, mkSysLocal, hasNoBinding
)
import IdInfo ( LBVarInfo(..),
GlobalIdDetails(..),
megaSeqIdInfo )
-import Demand ( appIsBottom )
+import NewDemand ( appIsBottom )
import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe,
applyTys, isUnLiftedType, seqType, mkUTy, mkTyVarTy,
splitForAllTy_maybe, isForAllTy, splitNewType_maybe, eqType
go n (Lam _ _) = False
idAppIsBottom :: Id -> Int -> Bool
-idAppIsBottom id n_val_args = appIsBottom (idStrictness id) n_val_args
+idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
\end{code}
@exprIsValue@ returns true for expressions that are certainly *already*
\begin{code}
cprAnalyse :: DynFlags -> [CoreBind] -> IO [CoreBind]
+#ifndef DEBUG
+-- Omit unless DEBUG is on
+cprAnalyse dflags binds = return binds
+
+#else
cprAnalyse dflags binds
= do {
showPass dflags "Constructed Product analysis" ;
arity = idArity v
-- Imported (non-nullary) constructors will have the CPR property
-- in their IdInfo, so no need to look at their unfolding
+#endif /* DEBUG */
\end{code}
-- others:
import Id ( idArity, idType, isDataConId_maybe, isFCallId_maybe )
import Var ( varType, isId )
-import IdInfo ( InlinePragInfo, pprInlinePragInfo, ppStrictnessInfo )
+import IdInfo ( InlinePragInfo, pprInlinePragInfo )
import Name ( Name, NamedThing(..), getName, toRdrName )
import RdrName ( RdrName, rdrNameOcc )
import OccName ( isTvOcc )
import CoreSyn
import CostCentre ( pprCostCentreCore )
-import Demand ( StrictnessInfo )
+import NewDemand ( StrictSig, pprIfaceStrictSig )
import Literal ( Literal, maybeLitLit )
import ForeignCall ( ForeignCall )
import DataCon ( dataConTyCon, dataConSourceArity )
data HsIdInfo name
= HsArity Arity
- | HsStrictness StrictnessInfo
+ | HsStrictness StrictSig
| HsUnfold InlinePragInfo (UfExpr name)
| HsNoCafRefs
- | HsCprInfo
| HsWorker name Arity -- Worker, if any see IdInfo.WorkerInfo
-- for why we want arity here.
deriving( Eq )
ppr_hs_info (HsUnfold prag unf) = ptext SLIT("__U") <> pprInlinePragInfo prag <+> parens (pprUfExpr noParens unf)
ppr_hs_info (HsArity arity) = ptext SLIT("__A") <+> int arity
-ppr_hs_info (HsStrictness str) = ptext SLIT("__S") <+> ppStrictnessInfo str
+ppr_hs_info (HsStrictness str) = ptext SLIT("__S") <+> pprIfaceStrictSig str
ppr_hs_info HsNoCafRefs = ptext SLIT("__C")
-ppr_hs_info HsCprInfo = ptext SLIT("__M")
ppr_hs_info (HsWorker w a) = ptext SLIT("__P") <+> ppr w <+> int a
\end{code}
eq_ufBinders, eq_ufExpr, pprUfExpr
)
import CoreSyn ( CoreRule(..) )
-import BasicTypes ( NewOrData(..) )
-import Demand ( StrictnessMark(..) )
+import BasicTypes ( NewOrData(..), StrictnessMark(..) )
import ForeignCall ( CExportSpec, CCallSpec, DNCallSpec, CCallConv )
-- others:
opt_SimplDoLambdaEtaExpansion,
opt_SimplCaseMerge,
opt_SimplExcessPrecision,
+ opt_MaxWorkerArgs,
-- Unfolding control
opt_UF_CreationThreshold,
opt_UnfoldCasms = lookUp SLIT("-funfold-casms-in-hi-file")
opt_UsageSPOn = lookUp SLIT("-fusagesp-on")
opt_UnboxStrictFields = lookUp SLIT("-funbox-strict-fields")
+opt_MaxWorkerArgs = lookup_def_int "-fmax-worker-args" (10::Int)
{-
The optional '-inpackage=P' flag tells what package
|| any (flip prefixMatch f) [
"fcontext-stack",
"fliberate-case-threshold",
+ "fmax-worker-args",
"fhistory-size",
"funfolding-creation-threshold",
"funfolding-use-threshold",
caf_info = cgCafInfo cg_info
hs_idinfo | opt_OmitInterfacePragmas = []
- | otherwise = arity_hsinfo ++ caf_hsinfo ++ cpr_hsinfo ++
+ | otherwise = arity_hsinfo ++ caf_hsinfo ++
strict_hsinfo ++ wrkr_hsinfo ++ unfold_hsinfo
------------ Arity --------------
NoCafRefs -> [HsNoCafRefs]
otherwise -> []
- ------------ CPR Info --------------
- cpr_hsinfo = case cprInfo id_info of
- ReturnsCPR -> [HsCprInfo]
- NoCPRInfo -> []
-
------------ Strictness --------------
- strict_hsinfo = case strictnessInfo id_info of
- NoStrictnessInfo -> []
- info -> [HsStrictness info]
+ strict_hsinfo = case newStrictnessInfo id_info of
+ Nothing -> []
+ Just sig -> [HsStrictness sig]
------------ Worker --------------
work_info = workerInfo id_info
import PrelNames ( mkTupNameStr )
import CmdLineOpts ( opt_HiVersion, opt_NoHiCheck )
import ForeignCall ( Safety(..) )
-import Demand ( Demand(..) {- instance Read -} )
+import NewDemand ( StrictSig(..), Demand(..), Keepity(..),
+ DmdResult(..), Deferredness(..), mkTopDmdType )
import UniqFM ( listToUFM, lookupUFM )
import BasicTypes ( Boxity(..) )
import SrcLoc ( SrcLoc, incSrcLine, srcLocFile, srcLocLine,
| ITspecialise
| ITnocaf
| ITunfold InlinePragInfo
- | ITstrict ([Demand], Bool)
+ | ITstrict StrictSig
| ITrules
| ITcprinfo
| ITdeprecated
lex_demand cont buf =
case read_em [] buf of { (ls,buf') ->
case currentChar# buf' of
- 'B'# -> cont (ITstrict (ls, True )) (incLexeme buf')
- _ -> cont (ITstrict (ls, False)) buf'
+ 'X'# -> cont (ITstrict (StrictSig (mkTopDmdType ls BotRes))) (incLexeme buf')
+ 'M'# -> cont (ITstrict (StrictSig (mkTopDmdType ls RetCPR))) (incLexeme buf')
+ _ -> cont (ITstrict (StrictSig (mkTopDmdType ls TopRes))) buf'
}
where
-- code snatched from Demand.lhs
read_em acc buf =
case currentChar# buf of
- 'L'# -> read_em (WwLazy False : acc) (stepOn buf)
- 'A'# -> read_em (WwLazy True : acc) (stepOn buf)
- 'S'# -> read_em (WwStrict : acc) (stepOn buf)
- 'P'# -> read_em (WwPrim : acc) (stepOn buf)
- 'E'# -> read_em (WwEnum : acc) (stepOn buf)
+ 'L'# -> read_em (Lazy : acc) (stepOn buf)
+ 'A'# -> read_em (Abs : acc) (stepOn buf)
+ 'V'# -> read_em (Eval : acc) (stepOn buf)
')'# -> (reverse acc, stepOn buf)
- 'U'# -> do_unpack True acc (stepOnBy# buf 2#)
- 'u'# -> do_unpack False acc (stepOnBy# buf 2#)
+ 'C'# -> do_call acc (stepOnBy# buf 2#)
+ 'U'# -> do_unpack1 Drop Now acc (stepOnBy# buf 1#)
+ 'S'# -> do_unpack1 Keep Now acc (stepOnBy# buf 1#)
_ -> (reverse acc, buf)
- do_unpack wrapper_unpacks acc buf
- = case read_em [] buf of
- (stuff, rest) -> read_em (WwUnpack wrapper_unpacks stuff : acc) rest
+ do_unpack1 keepity defer acc buf
+ = case currentChar# buf of
+ '*'# -> do_unpack1 keepity Defer acc (stepOnBy# buf 1#)
+ '('# -> do_unpack2 keepity defer acc (stepOnBy# buf 1#)
+ _ -> read_em (Seq keepity defer [] : acc) buf
+ do_unpack2 keepity defer acc buf
+ = case read_em [] buf of
+ (stuff, rest) -> read_em (Seq keepity defer stuff : acc) rest
+
+ do_call acc buf
+ = case read_em [] buf of
+ ([dmd], rest) -> read_em (Call dmd : acc) rest
------------------
lex_scc cont buf =
{-
-----------------------------------------------------------------------------
-$Id: Parser.y,v 1.71 2001/07/13 13:29:57 simonpj Exp $
+$Id: Parser.y,v 1.72 2001/07/23 10:54:48 simonpj Exp $
Haskell grammar.
import OccName ( UserFS, varName, tcName, dataName, tcClsName, tvName )
import SrcLoc ( SrcLoc )
import Module
-import Demand ( StrictnessMark(..) )
import CmdLineOpts ( opt_SccProfilingOn )
-import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), NewOrData(..) )
+import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), NewOrData(..), StrictnessMark(..) )
import Panic
import GlaExts
import OccName ( mkOccFS, tcName, dataName, mkWorkerOcc, mkGenOcc1, mkGenOcc2 )
import RdrName ( rdrNameOcc )
import DataCon ( DataCon, mkDataCon, dataConId )
-import Demand ( StrictnessMark(..) )
import Var ( TyVar, tyVarKind )
import TyCon ( TyCon, AlgTyConFlavour(..), tyConDataCons,
mkTupleTyCon, isUnLiftedTyCon, mkAlgTyCon
)
-import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed )
+import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed, StrictnessMark(..) )
import Type ( Type, mkTyConTy, mkTyConApp, mkTyVarTys,
mkArrowKinds, liftedTypeKind, unliftedTypeKind,
import RdrHsSyn -- oodles of synonyms
import HsTypes ( mkHsForAllTy, mkHsTupCon )
import HsCore
-import Demand ( mkStrictnessInfo )
import Literal ( Literal(..), mkMachInt, mkMachInt64, mkMachWord, mkMachWord64 )
-import BasicTypes ( Fixity(..), FixityDirection(..),
+import BasicTypes ( Fixity(..), FixityDirection(..), StrictnessMark(..),
NewOrData(..), Version, initialVersion, Boxity(..)
)
import CostCentre ( CostCentre(..), IsCafCC(..), IsDupdCC(..) )
-import Demand ( StrictnessMark(..) )
import Type ( Kind, mkArrowKind, liftedTypeKind, openTypeKind, usageTypeKind )
import IdInfo ( InlinePragInfo(..) )
import ForeignCall ( ForeignCall(..), CCallConv(..), CCallSpec(..), CCallTarget(..) )
id_info_item :: { HsIdInfo RdrName }
: '__A' INTEGER { HsArity (fromInteger $2) }
| '__U' inline_prag core_expr { HsUnfold $2 $3 }
- | '__M' { HsCprInfo }
- | '__S' { HsStrictness (mkStrictnessInfo $1) }
+ | '__S' { HsStrictness $1 }
| '__C' { HsNoCafRefs }
| '__P' qvar_name INTEGER { HsWorker $2 (fromInteger $3) }
where
doc_str = text "In the interface signature for" <+> quotes (ppr name)
-rnTyClDecl (ForeignType {tcdName = name, tcdFoType = spec, tcdLoc = loc})
+rnTyClDecl (ForeignType {tcdName = name, tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc})
= pushSrcLocRn loc $
lookupTopBndrRn name `thenRn` \ name' ->
- returnRn (ForeignType {tcdName = name', tcdFoType = spec, tcdLoc = loc})
+ returnRn (ForeignType {tcdName = name', tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc})
rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon,
tcdTyVars = tyvars, tcdCons = condecls, tcdNCons = nconstrs,
rnIdInfo (HsStrictness str) = returnRn (HsStrictness str)
rnIdInfo (HsArity arity) = returnRn (HsArity arity)
rnIdInfo HsNoCafRefs = returnRn HsNoCafRefs
-rnIdInfo HsCprInfo = returnRn HsCprInfo
\end{code}
@UfCore@ expressions.
import Subst ( InScopeSet, mkSubst, substExpr )
import qualified Subst ( simplBndrs, simplBndr, simplLetId )
import Id ( idType, idName,
- idUnfolding, idStrictness,
+ idUnfolding, idNewStrictness,
mkLocalId, idInfo
)
import IdInfo ( StrictnessInfo(..) )
import Maybes ( maybeToBool, catMaybes )
import Name ( setNameUnique )
-import Demand ( isStrict )
+import NewDemand ( isStrictDmd, isBotRes, splitStrictSig )
import SimplMonad
import Type ( Type, mkForAllTys, seqType,
splitTyConApp_maybe, tyConAppArgs, mkTyVarTys,
-- after that number of value args have been consumed
-- Otherwise it's infinite, extended with False
fun_stricts
- = case idStrictness fun of
- StrictnessInfo demands result_bot
+ = case splitStrictSig (idNewStrictness fun) of
+ (demands, result_info)
| not (demands `lengthExceeds` countValArgs orig_cont)
-> -- Enough args, use the strictness given.
-- For bottoming functions we used to pretend that the arg
-- top-level bindings for (say) strings into
-- calls to error. But now we are more careful about
-- inlining lone variables, so its ok (see SimplUtils.analyseCont)
- if result_bot then
- map isStrict demands -- Finite => result is bottom
+ if isBotRes result_info then
+ map isStrictDmd demands -- Finite => result is bottom
else
- map isStrict demands ++ vanilla_stricts
+ map isStrictDmd demands ++ vanilla_stricts
other -> vanilla_stricts -- Not enough args, or no strictness
import Literal ( Literal )
import Id ( Id, idType, idInfo, isDataConId, hasNoBinding,
idUnfolding, setIdUnfolding, isExportedId, isDeadBinder,
- idDemandInfo, setIdInfo,
+ idNewDemandInfo, setIdInfo,
idOccInfo, setIdOccInfo,
zapLamIdInfo, setOneShotLambda,
)
setUnfoldingInfo,
occInfo
)
-import Demand ( isStrict )
+import NewDemand ( isStrictDmd )
import DataCon ( dataConNumInstArgs, dataConRepStrictness,
dataConSig, dataConArgTys
)
-- has arisen from an application (\x. E) RHS, perhaps they aren't
bndr'' = simplIdInfo bndr_subst (idInfo bndr) bndr'
bndr_ty' = idType bndr'
- is_strict = isStrict (idDemandInfo bndr) || isStrictType bndr_ty'
+ is_strict = isStrictDmd (idNewDemandInfo bndr) || isStrictType bndr_ty'
in
modifyInScope bndr'' bndr'' $
-- we only float if arg' is a WHNF,
-- and so there can't be any 'will be demanded' bindings in the floats.
-- Hence the assert
- WARN( any demanded_float (fromOL floats2), ppr (fromOL floats2) )
+ WARN( any demanded_float (fromOL floats2), ppr (filter demanded_float (fromOL floats2)) )
-- Transform the RHS
-- It's important that we do eta expansion on function *arguments* (which are
-- Don't do the float
thing_inside (wrapFloats floats1 rhs1)
-demanded_float (NonRec b r) = isStrict (idDemandInfo b) && not (isUnLiftedType (idType b))
+demanded_float (NonRec b r) = isStrictDmd (idNewDemandInfo b) && not (isUnLiftedType (idType b))
-- Unlifted-type (cheap-eagerness) lets may well have a demanded flag on them
demanded_float (Rec _) = False
(rhs1:other_rhss) = rhssOfAlts alts
binders_unused (_, bndrs, _) = all isDeadBinder bndrs
- var_demanded_later (Var v) = isStrict (idDemandInfo bndr) -- It's going to be evaluated later
+ var_demanded_later (Var v) = isStrictDmd (idNewDemandInfo bndr) -- It's going to be evaluated later
var_demanded_later other = False
cat_evals [] [] = []
cat_evals (v:vs) (str:strs)
- | isTyVar v = v : cat_evals vs (str:strs)
- | isStrict str = (v' `setIdUnfolding` mkOtherCon []) : cat_evals vs strs
- | otherwise = v' : cat_evals vs strs
+ | isTyVar v = v : cat_evals vs (str:strs)
+ | isStrictDmd str = (v' `setIdUnfolding` mkOtherCon []) : cat_evals vs strs
+ | otherwise = v' : cat_evals vs strs
where
v' = zap_occ_info v
\end{code}
#include "HsVersions.h"
-import CmdLineOpts ( DynFlags, DynFlag(..) )
+import CmdLineOpts ( DynFlags, DynFlag(..), opt_MaxWorkerArgs )
import NewDemand -- All of it
import CoreSyn
import CoreUtils ( exprIsValue, exprArity )
import DataCon ( dataConTyCon )
import TyCon ( isProductTyCon, isRecursiveTyCon )
-import Id ( Id, idType, idInfo, idArity, idStrictness, idCprInfo, idDemandInfo,
- modifyIdInfo, isDataConId, isImplicitId, isGlobalId )
-import IdInfo ( newStrictnessInfo, setNewStrictnessInfo, mkNewStrictnessInfo,
- newDemandInfo, setNewDemandInfo, newDemand
- )
+import Id ( Id, idType, idInfo, idArity, idCprInfo, idDemandInfo,
+ modifyIdInfo, isDataConId, isImplicitId, isGlobalId,
+ idNewStrictness, idNewStrictness_maybe, getNewStrictness, setIdNewStrictness,
+ idNewDemandInfo, setIdNewDemandInfo, newStrictnessFromOld )
+import IdInfo ( newDemand )
import Var ( Var )
import VarEnv
import UniqFM ( plusUFM_C, addToUFM_Directly, lookupUFM_Directly,
import FastTypes
\end{code}
-ToDo: set a noinline pragma on bottoming Ids
+To think about
+
+* set a noinline pragma on bottoming Ids
+
+* Consider f x = x+1 `fatbar` error (show x)
+ We'd like to unbox x, even if that means reboxing it in the error case.
+
\begin{code}
instance Outputable TopLevelFlag where
ppr flag = empty
\begin{code}
dmdAnalPgm :: DynFlags -> [CoreBind] -> IO [CoreBind]
-#ifndef DEBUG
-
-dmdAnalPgm dflags binds = return binds
-
-#else
-
dmdAnalPgm dflags binds
= do {
showPass dflags "Demand analysis" ;
where
arity = exprArity rhs -- The idArity may not be up to date
(rhs_ty, rhs') = dmdAnal sigs (vanillaCall arity) rhs
- (lazy_fv, sig_ty) = mkSigTy rhs rhs_ty
- sig = mkStrictSig id arity sig_ty
- id' = id `setIdNewStrictness` sig
- sigs' = extendSigEnv top_lvl sigs id sig
+ (lazy_fv, sig_ty) = mkSigTy id arity rhs rhs_ty
+ id' = id `setIdNewStrictness` sig_ty
+ sigs' = extendSigEnv top_lvl sigs id sig_ty
+\end{code}
-mkSigTy rhs (DmdType fv dmds res)
- = (lazy_fv, DmdType strict_fv lazified_dmds res')
+%************************************************************************
+%* *
+\subsection{Strictness signatures and types}
+%* *
+%************************************************************************
+
+\begin{code}
+mkSigTy :: Id -> Arity -> CoreExpr -> DmdType -> (DmdEnv, StrictSig)
+-- Take a DmdType and turn it into a StrictSig
+mkSigTy id arity rhs (DmdType fv dmds res)
+ = (lazy_fv, mkStrictSig id arity dmd_ty)
where
+ dmd_ty = DmdType strict_fv lazified_dmds res'
+
lazy_fv = filterUFM (not . isStrictDmd) fv
strict_fv = filterUFM isStrictDmd fv
-- We put the strict FVs in the DmdType of the Id, so
lazified_dmds = map lazify dmds
-- Get rid of defers in the arguments
-
+ final_dmds = setUnpackStrategy lazified_dmds
+ -- Set the unpacking strategy
+
res' = case (dmds, res) of
([], RetCPR) | not (exprIsValue rhs) -> TopRes
other -> res
-- if r doesn't have the CPR property then neither does modInt
\end{code}
+The unpack strategy determines whether we'll *really* unpack the argument,
+or whether we'll just remember its strictness. If unpacking would give
+rise to a *lot* of worker args, we may decide not to unpack after all.
+
+\begin{code}
+setUnpackStrategy :: [Demand] -> [Demand]
+setUnpackStrategy ds
+ = snd (go (opt_MaxWorkerArgs - nonAbsentArgs ds) ds)
+ where
+ go :: Int -- Max number of args available for sub-components of [Demand]
+ -> [Demand]
+ -> (Int, [Demand]) -- Args remaining after subcomponents of [Demand] are unpacked
+
+ go n (Seq keep _ cs : ds)
+ | n' >= 0 = Seq keep Now cs' `cons` go n'' ds
+ | otherwise = Eval `cons` go n ds
+ where
+ (n'',cs') = go n' cs
+ n' = n + box - non_abs_args
+ box = case keep of
+ Keep -> 0
+ Drop -> 1 -- Add one to the budget if we drop the top-level arg
+ non_abs_args = nonAbsentArgs cs
+ -- Delete # of non-absent args to which we'll now be committed
+
+ go n (d:ds) = d `cons` go n ds
+ go n [] = (n,[])
+
+ cons d (n,ds) = (n, d:ds)
+
+nonAbsentArgs :: [Demand] -> Int
+nonAbsentArgs [] = 0
+nonAbsentArgs (Abs : ds) = nonAbsentArgs ds
+nonAbsentArgs (d : ds) = 1 + nonAbsentArgs ds
+\end{code}
+
%************************************************************************
%* *
%************************************************************************
\begin{code}
+splitDmdTy :: DmdType -> (Demand, DmdType)
+-- Split off one function argument
+splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty)
+splitDmdTy ty@(DmdType fv [] TopRes) = (topDmd, ty)
+splitDmdTy ty@(DmdType fv [] BotRes) = (Abs, ty)
+ -- We already have a suitable demand on all
+ -- free vars, so no need to add more!
+splitDmdTy (DmdType fv [] RetCPR) = panic "splitDmdTy"
+\end{code}
+
+\begin{code}
unitVarDmd var dmd = DmdType (unitVarEnv var dmd) [] TopRes
addVarDmd top_lvl dmd_ty@(DmdType fv ds res) var dmd
%************************************************************************
%* *
-\subsection{Demand types}
-%* *
-%************************************************************************
-
-\begin{code}
-splitDmdTy :: DmdType -> (Demand, DmdType)
--- Split off one function argument
-splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty)
-splitDmdTy ty@(DmdType fv [] TopRes) = (topDmd, ty)
-splitDmdTy ty@(DmdType fv [] BotRes) = (Abs, ty)
- -- We already have a suitable demand on all
- -- free vars, so no need to add more!
-splitDmdTy (DmdType fv [] RetCPR) = panic "splitDmdTy"
-
--------------------------
-dmdTypeRes :: DmdType -> DmdResult
-dmdTypeRes (DmdType _ _ res_ty) = res_ty
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection{Strictness signatures}
%* *
%************************************************************************
------ DATA CONSTRUCTOR
| isDataConId var, -- Data constructor
Seq k Now ds <- res_dmd, -- and the demand looks inside its fields
- let StrictSig arity dmd_ty = idNewStrictness var -- It must have a strictness sig
- = if arity == length ds then -- Saturated, so unleash the demand
+ let StrictSig dmd_ty = idNewStrictness var -- It must have a strictness sig
+ = if dmdTypeDepth dmd_ty == length ds then -- Saturated, so unleash the demand
-- ds can be empty, when we are just seq'ing the thing
mkDmdType emptyDmdEnv ds (dmdTypeRes dmd_ty)
- -- Need to extract whether it's a product
+ -- Need to extract whether it's a product, hence dmdTypeRes
else
topDmdType
------ IMPORTED FUNCTION
| isGlobalId var, -- Imported function
- let StrictSig arity dmd_ty = getNewStrictness var
- = if arity <= depth then -- Saturated, so unleash the demand
+ let StrictSig dmd_ty = getNewStrictness var
+ = if dmdTypeDepth dmd_ty <= call_depth then -- Saturated, so unleash the demand
dmd_ty
else
topDmdType
------ LOCAL LET/REC BOUND THING
- | Just (StrictSig arity dmd_ty, top_lvl) <- lookupVarEnv sigs var
+ | Just (StrictSig dmd_ty, top_lvl) <- lookupVarEnv sigs var
= let
- fn_ty | arity <= depth = dmd_ty
- | otherwise = deferType dmd_ty
+ fn_ty | dmdTypeDepth dmd_ty <= call_depth = dmd_ty
+ | otherwise = deferType dmd_ty
-- NB: it's important to use deferType, and not just return topDmdType
-- Consider let { f x y = p + x } in f 1
-- The application isn't saturated, but we must nevertheless propagate
= unitVarDmd var dmd
where
- (depth, res_dmd) = splitCallDmd dmd
-\end{code}
-
-\begin{code}
-squashDmdEnv (StrictSig a (DmdType fv ds res)) = StrictSig a (DmdType emptyDmdEnv ds res)
-
-betterStrict :: StrictSig -> StrictSig -> Bool
-betterStrict (StrictSig ar1 t1) (StrictSig ar2 t2)
- = (ar1 >= ar2) && (t1 `betterDmdType` t2)
-
-betterDmdType t1 t2 = (t1 `lubType` t2) == t2
+ (call_depth, res_dmd) = splitCallDmd dmd
\end{code}
defer (Seq k _ ds) = Seq k Defer ds
defer other = Lazy
-isStrictDmd :: Demand -> Bool
-isStrictDmd Bot = True
-isStrictDmd Err = True
-isStrictDmd (Seq _ Now _) = True
-isStrictDmd Eval = True
-isStrictDmd (Call _) = True
-isStrictDmd other = False
-
lazify :: Demand -> Demand
-- The 'Defer' demands are just Lazy at function boundaries
lazify (Seq k Defer ds) = Lazy
lazify (Seq k Now ds) = Seq k Now (map lazify ds)
lazify Bot = Abs -- Don't pass args that are consumed by bottom
lazify d = d
+\end{code}
+
+\begin{code}
+betterStrictness :: StrictSig -> StrictSig -> Bool
+betterStrictness (StrictSig t1) (StrictSig t2) = betterDmdType t1 t2
+
+betterDmdType t1 t2 = (t1 `lubType` t2) == t2
betterDemand :: Demand -> Demand -> Bool
-- If d1 `better` d2, and d2 `better` d2, then d1==d2
betterDemand d1 d2 = (d1 `lub` d2) == d2
+
+squashDmdEnv (StrictSig (DmdType fv ds res)) = StrictSig (DmdType emptyDmdEnv ds res)
\end{code}
\begin{code}
--- Move these to Id.lhs
-idNewStrictness_maybe :: Id -> Maybe StrictSig
-idNewStrictness :: Id -> StrictSig
-
-idNewStrictness_maybe id = newStrictnessInfo (idInfo id)
-idNewStrictness id = idNewStrictness_maybe id `orElse` topSig
-
-getNewStrictness :: Id -> StrictSig
--- First tries the "new-strictness" field, and then
--- reverts to the old one. This is just until we have
--- cross-module info for new strictness
-getNewStrictness id = idNewStrictness_maybe id `orElse` newStrictnessFromOld id
-
-newStrictnessFromOld :: Id -> StrictSig
-newStrictnessFromOld id = mkNewStrictnessInfo id (idArity id) (idStrictness id) (idCprInfo id)
-
-setIdNewStrictness :: Id -> StrictSig -> Id
-setIdNewStrictness id sig = modifyIdInfo (`setNewStrictnessInfo` sig) id
-
-idNewDemandInfo :: Id -> Demand
-idNewDemandInfo id = newDemandInfo (idInfo id)
-
-setIdNewDemandInfo :: Id -> Demand -> Id
-setIdNewDemandInfo id dmd = modifyIdInfo (`setNewDemandInfo` dmd) id
-\end{code}
-
-\begin{code}
get_changes binds = vcat (map get_changes_bind binds)
get_changes_bind (Rec pairs) = vcat (map get_changes_pr pairs)
info = (text "Old" <+> ppr old) $$ (text "New" <+> ppr new)
new = squashDmdEnv (idNewStrictness id) -- Don't report diffs in the env
old = newStrictnessFromOld id
- old_better = old `betterStrict` new
- new_better = new `betterStrict` old
+ old_better = old `betterStrictness` new
+ new_better = new `betterStrictness` old
get_changes_dmd id
| isUnLiftedType (idType id) = empty -- Not useful
old = newDemand (idDemandInfo id)
new_better = new `betterDemand` old
old_better = old `betterDemand` new
-#endif /* DEBUG */
\end{code}
\section[SaAbsInt]{Abstract interpreter for strictness analysis}
\begin{code}
+#ifndef DEBUG
+-- If DEBUG is off, omit all exports
+module SaAbsInt () where
+
+#else
module SaAbsInt (
findStrictness,
findDemand, findDemandAlts,
fixpoint,
isBot
) where
-
+#endif /* DEBUG */
#include "HsVersions.h"
import CmdLineOpts ( opt_AllStrict, opt_NumbersStrict )
See also: the ``library'' for the ``back end'' (@SaBackLib@).
\begin{code}
+#ifndef DEBUG
+-- If DEBUG is off, omit all exports
+module SaAbsInt () where
+
+#else
module SaLib (
AbsVal(..),
AnalysisKind(..),
lookupAbsValEnv,
absValFromStrictness
) where
+#endif /* DEBUG */
#include "HsVersions.h"
\begin{code}
saBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
+#ifndef DEBUG
+-- Omit strictness analyser if DEBUG is off
+saBinds dflags binds = return binds
+
+#else
saBinds dflags binds
= do {
showPass dflags "Strictness analysis";
sequenceSa (m:ms) = m `thenSa` \ r ->
sequenceSa ms `thenSa` \ rs ->
returnSa (r:rs)
+#endif /* DEBUG */
\end{code}
import CoreUnfold ( certainlyWillInline )
import CoreLint ( showPass, endPass )
import CoreUtils ( exprType )
-import Id ( Id, idType, idStrictness, idArity, isOneShotLambda,
- setIdStrictness, idInlinePragma, mkWorkerId,
+import Id ( Id, idType, idNewStrictness, idArity, isOneShotLambda,
+ setIdNewStrictness, idInlinePragma, mkWorkerId,
setIdWorkerInfo, idCprInfo, setInlinePragma )
import Type ( Type )
import IdInfo ( mkStrictnessInfo, noStrictnessInfo, StrictnessInfo(..),
CprInfo(..), InlinePragInfo(..), isNeverInlinePrag,
WorkerInfo(..)
)
-import Demand ( Demand )
+import NewDemand ( Demand(..), StrictSig(..), DmdType(..), DmdResult(..),
+ mkTopDmdType, isBotRes, returnsCPR
+ )
import UniqSupply ( UniqSupply, initUs_, returnUs, thenUs, mapUs, getUniqueUs, UniqSM )
+import BasicTypes ( RecFlag(..), isNonRec )
import CmdLineOpts
import WwLib
import Outputable
-- as appropriate.
wwBind (NonRec binder rhs)
- = wwExpr rhs `thenUs` \ new_rhs ->
- tryWW True {- non-recursive -} binder new_rhs `thenUs` \ new_pairs ->
+ = wwExpr rhs `thenUs` \ new_rhs ->
+ tryWW NonRecursive binder new_rhs `thenUs` \ new_pairs ->
returnUs [NonRec b e | (b,e) <- new_pairs]
-- Generated bindings must be non-recursive
-- because the original binding was.
-------------------------------
-
wwBind (Rec pairs)
= mapUs do_one pairs `thenUs` \ new_pairs ->
returnUs [Rec (concat new_pairs)]
where
do_one (binder, rhs) = wwExpr rhs `thenUs` \ new_rhs ->
- tryWW False {- recursive -} binder new_rhs
+ tryWW Recursive binder new_rhs
\end{code}
@wwExpr@ basically just walks the tree, looking for appropriate
The only reason this is monadised is for the unique supply.
\begin{code}
-tryWW :: Bool -- True <=> a non-recursive binding
+tryWW :: RecFlag
-> Id -- The fn binder
-> CoreExpr -- The bound rhs; its innards
-- are already ww'd
-- the orig "wrapper" lives on);
-- if two, then a worker and a
-- wrapper.
-tryWW non_rec fn_id rhs
- | isNeverInlinePrag inline_prag || arity == 0
- = -- Don't split things that will never be inlined
- returnUs [ (fn_id, rhs) ]
-
- | non_rec && certainlyWillInline fn_id
+tryWW is_rec fn_id rhs
+ | arity == 0
+ -- Don't worker-wrapper thunks
+ || isNeverInlinePrag inline_prag
+ -- Don't split things that will never be inlined
+ || isNonRec is_rec && certainlyWillInline fn_id
-- No point in worker/wrappering a function that is going to be
-- INLINEd wholesale anyway. If the strictness analyser is run
-- twice, this test also prevents wrappers (which are INLINEd)
-- fw = \ab -> (__inline (\x -> E)) (a,b)
-- and the original __inline now vanishes, so E is no longer
-- inside its __inline wrapper. Death! Disaster!
- --
- -- OUT OF DATE NOTE:
- -- [Out of date because the size calculation in CoreUnfold now
- -- makes wrappers look very cheap even when they are inlined.]
- -- In this case we add an INLINE pragma to the RHS. Why?
- -- Because consider
- -- f = \x -> g x x
- -- g = \yz -> ... -- And g is strict
- -- Then f is small, so we don't w/w it. But g is big, and we do, so
- -- g's wrapper will get inlined in f's RHS, which makes f look big now.
- -- So f doesn't get inlined, but it is strict and we have failed to w/w it.
+ || not (worthSplitting strict_sig)
+ -- Strictness info suggests not to w/w
= returnUs [ (fn_id, rhs) ]
- | not (do_strict_ww || do_cpr_ww)
- = returnUs [ (fn_id, rhs) ]
-
- | otherwise -- Do w/w split
- = mkWwBodies fun_ty arity wrap_dmds result_bot one_shots cpr_info `thenUs` \ (work_demands, wrap_fn, work_fn) ->
- getUniqueUs `thenUs` \ work_uniq ->
+ | otherwise -- Do w/w split!
+ = WARN( arity /= length wrap_dmds, ppr fn_id <+> (ppr arity $$ ppr strict_sig) )
+ -- The arity should match the signature
+ mkWwBodies fun_ty wrap_dmds res_info one_shots `thenUs` \ (work_demands, wrap_fn, work_fn) ->
+ getUniqueUs `thenUs` \ work_uniq ->
let
- work_rhs = work_fn rhs
- proto_work_id = mkWorkerId work_uniq fn_id (exprType work_rhs)
+ work_rhs = work_fn rhs
+ work_id = mkWorkerId work_uniq fn_id (exprType work_rhs)
`setInlinePragma` inline_prag
-
- work_id | has_strictness = proto_work_id `setIdStrictness` mkStrictnessInfo (work_demands, result_bot)
- | otherwise = proto_work_id
+ `setIdNewStrictness` StrictSig (mkTopDmdType work_demands work_res_info)
+ -- Even though we may not be at top level,
+ -- it's ok to give it an empty DmdEnv
wrap_rhs = wrap_fn work_id
- wrap_id = fn_id `setIdStrictness` wrapper_strictness
- `setIdWorkerInfo` HasWorker work_id arity
- `setInlinePragma` NoInlinePragInfo -- Put it on the worker instead
- -- Add info to the wrapper:
- -- (a) we want to set its arity
- -- (b) we want to pin on its revised strictness info
- -- (c) we pin on its worker id
+ wrap_id = fn_id `setIdWorkerInfo` HasWorker work_id arity
+ `setInlinePragma` NoInlinePragInfo -- Zap any inline pragma;
+ -- Put it on the worker instead
in
returnUs ([(work_id, work_rhs), (wrap_id, wrap_rhs)])
-- Worker first, because wrapper mentions it
arity = idArity fn_id -- The arity is set by the simplifier using exprEtaExpandArity
-- So it may be more than the number of top-level-visible lambdas
- inline_prag = idInlinePragma fn_id
-
- strictness_info = idStrictness fn_id
- has_strictness = case strictness_info of
- StrictnessInfo _ _ -> True
- NoStrictnessInfo -> False
- (arg_demands, result_bot) = case strictness_info of
- StrictnessInfo d r -> (d, r)
- NoStrictnessInfo -> ([], False)
-
- wrap_dmds = setUnpackStrategy arg_demands
- do_strict_ww = WARN( has_strictness && not result_bot && arity < length arg_demands && worthSplitting wrap_dmds result_bot,
- text "Insufficient arity" <+> ppr fn_id <+> ppr arity <+> ppr arg_demands )
- (result_bot || arity >= length arg_demands) -- Only if there's enough visible arity
- && -- (else strictness info isn't valid)
- --
- worthSplitting wrap_dmds result_bot -- And it's useful
- -- worthSplitting returns False for an empty list of demands,
- -- and hence do_strict_ww is False if arity is zero
- -- Also it's false if there is no strictness (arg_demands is [])
-
- wrapper_strictness | has_strictness = mkStrictnessInfo (wrap_dmds, result_bot)
- | otherwise = noStrictnessInfo
+ inline_prag = idInlinePragma fn_id
+ strict_sig = idNewStrictness fn_id
- -------------------------------------------------------------
- cpr_info = idCprInfo fn_id
- do_cpr_ww = arity > 0 &&
- case cpr_info of
- ReturnsCPR -> True
- other -> False
+ StrictSig (DmdType _ wrap_dmds res_info) = strict_sig
+ work_res_info | isBotRes res_info = BotRes -- Cpr stuff done by wrapper
+ | otherwise = TopRes
- -------------------------------------------------------------
one_shots = get_one_shots rhs
-- If the original function has one-shot arguments, it is important to
\end{code}
+%************************************************************************
+%* *
+\subsection{Functions over Demands}
+%* *
+%************************************************************************
+
+\begin{code}
+worthSplitting :: StrictSig -> Bool
+ -- True <=> the wrapper would not be an identity function
+worthSplitting (StrictSig (DmdType _ ds res))
+ = any worth_it ds || returnsCPR res
+ -- worthSplitting returns False for an empty list of demands,
+ -- and hence do_strict_ww is False if arity is zero
+
+ -- We used not to split if the result is bottom.
+ -- [Justification: there's no efficiency to be gained.]
+ -- But it's sometimes bad not to make a wrapper. Consider
+ -- fw = \x# -> let x = I# x# in case e of
+ -- p1 -> error_fn x
+ -- p2 -> error_fn x
+ -- p3 -> the real stuff
+ -- The re-boxing code won't go away unless error_fn gets a wrapper too.
+ -- [We don't do reboxing now, but in general it's better to pass
+ -- an unboxed thing to f, and have it reboxed in the error cases....]
+ where
+ worth_it Abs = True -- Absent arg
+ worth_it (Seq _ _ ds) = True -- Arg to evaluate
+ worth_it other = False
+\end{code}
+
+
%************************************************************************
%* *
\begin{code}
mkWrapper :: Type -- Wrapper type
- -> Int -- Arity
- -> [Demand] -- Wrapper strictness info
- -> Bool -- Function returns bottom
- -> CprInfo -- Wrapper cpr info
+ -> StrictSig -- Wrapper strictness info
-> UniqSM (Id -> CoreExpr) -- Wrapper body, missing worker Id
-mkWrapper fun_ty arity demands res_bot cpr_info
- = mkWwBodies fun_ty arity demands res_bot noOneShotInfo cpr_info `thenUs` \ (_, wrap_fn, _) ->
+mkWrapper fun_ty (StrictSig (DmdType _ demands res_info))
+ = mkWwBodies fun_ty demands res_info noOneShotInfo `thenUs` \ (_, wrap_fn, _) ->
returnUs wrap_fn
noOneShotInfo = repeat False
\section[WwLib]{A library for the ``worker/wrapper'' back-end to the strictness analyser}
\begin{code}
-module WwLib (
- mkWwBodies,
- worthSplitting, setUnpackStrategy
- ) where
+module WwLib ( mkWwBodies ) where
#include "HsVersions.h"
import CoreSyn
import CoreUtils ( exprType )
-import Id ( Id, idType, mkSysLocal, idDemandInfo, setIdDemandInfo,
+import Id ( Id, idType, mkSysLocal, idNewDemandInfo, setIdNewDemandInfo,
isOneShotLambda, setOneShotLambda,
setIdInfo
)
-import IdInfo ( CprInfo(..), vanillaIdInfo )
-import DataCon ( splitProductType )
-import Demand ( Demand(..), wwLazy, wwPrim )
+import IdInfo ( vanillaIdInfo )
+import DataCon ( splitProductType_maybe, splitProductType )
+import NewDemand ( Demand(..), Keepity(..), DmdResult(..) )
import PrelInfo ( realWorldPrimId, aBSENT_ERROR_ID )
import TysPrim ( realWorldStatePrimTy )
import TysWiredIn ( tupleCon )
%* *
%************************************************************************
- ************ WARNING ******************
- these comments are rather out of date
- *****************************************
-
-@mkWrapperAndWorker@ is given:
-\begin{enumerate}
-\item
-The {\em original function} \tr{f}, of the form:
-\begin{verbatim}
-f = /\ tyvars -> \ args -> body
-\end{verbatim}
-The original-binder \tr{f}, the \tr{tyvars}, \tr{args}, and \tr{body}
-are given separately.
-
-We use the Id \tr{f} mostly to get its type.
-
-\item
-Strictness information about \tr{f}, in the form of a list of
-@Demands@.
-
-\item
-A @UniqueSupply@.
-\end{enumerate}
-
-@mkWrapperAndWorker@ produces (A BIT OUT-OF-DATE...):
-\begin{enumerate}
-\item
-Maybe @Nothing@: no worker/wrappering going on in this case. This can
-happen (a)~if the strictness info says that there is nothing
-interesting to do or (b)~if *any* of the argument types corresponding
-to ``active'' arg postitions is abstract or will be to the outside
-world (i.e., {\em this} module can see the constructors, but nobody
-else will be able to). An ``active'' arg position is one which the
-wrapper has to unpack. An importing module can't do this unpacking,
-so it simply has to give up and call the wrapper only.
-
-\item
-Maybe \tr{Just (wrapper_Id, wrapper_body, worker_Id, worker_body)}.
-
-The @wrapper_Id@ is just the one that was passed in, with its
-strictness IdInfo updated.
-\end{enumerate}
-
-The \tr{body} of the original function may not be given (i.e., it's
-BOTTOM), in which case you'd jolly well better not tug on the
-worker-body output!
-
Here's an example. The original function is:
+
\begin{verbatim}
g :: forall a . Int -> [a] -> a
g = /\ a -> \ x ys ->
case x of
- I# x# -> g.wrk a x# ys
+ I# x# -> $wg a x# ys
-- call the worker; don't forget the type args!
-- worker
-g.wrk :: forall a . Int# -> [a] -> a
+$wg :: forall a . Int# -> [a] -> a
-g.wrk = /\ a -> \ x# ys ->
+$wg = /\ a -> \ x# ys ->
let
x = I# x#
in
\end{verbatim}
Something we have to be careful about: Here's an example:
+
\begin{verbatim}
-- "f" strictness: U(P)U(P)
f (I# a) (I# b) = a +# b
g = f -- "g" strictness same as "f"
\end{verbatim}
+
\tr{f} will get a worker all nice and friendly-like; that's good.
{\em But we don't want a worker for \tr{g}}, even though it has the
same strictness as \tr{f}. Doing so could break laziness, at best.
%************************************************************************
%* *
-\subsection{Functions over Demands}
-%* *
-%************************************************************************
-
-\begin{code}
-mAX_WORKER_ARGS :: Int -- ToDo: set via flag
-mAX_WORKER_ARGS = 6
-
-setUnpackStrategy :: [Demand] -> [Demand]
-setUnpackStrategy ds
- = snd (go (mAX_WORKER_ARGS - nonAbsentArgs ds) ds)
- where
- go :: Int -- Max number of args available for sub-components of [Demand]
- -> [Demand]
- -> (Int, [Demand]) -- Args remaining after subcomponents of [Demand] are unpacked
-
- go n (WwUnpack _ cs : ds) | n' >= 0
- = WwUnpack True cs' `cons` go n'' ds
- | otherwise
- = WwUnpack False cs `cons` go n ds
- where
- n' = n + 1 - nonAbsentArgs cs
- -- Add one because we don't pass the top-level arg any more
- -- Delete # of non-absent args to which we'll now be committed
- (n'',cs') = go n' cs
-
- go n (d:ds) = d `cons` go n ds
- go n [] = (n,[])
-
- cons d (n,ds) = (n, d:ds)
-
-nonAbsentArgs :: [Demand] -> Int
-nonAbsentArgs [] = 0
-nonAbsentArgs (WwLazy True : ds) = nonAbsentArgs ds
-nonAbsentArgs (d : ds) = 1 + nonAbsentArgs ds
-
-worthSplitting :: [Demand]
- -> Bool -- Result is bottom
- -> Bool -- True <=> the wrapper would not be an identity function
-worthSplitting ds result_bot = any worth_it ds
- -- We used not to split if the result is bottom.
- -- [Justification: there's no efficiency to be gained.]
- -- But it's sometimes bad not to make a wrapper. Consider
- -- fw = \x# -> let x = I# x# in case e of
- -- p1 -> error_fn x
- -- p2 -> error_fn x
- -- p3 -> the real stuff
- -- The re-boxing code won't go away unless error_fn gets a wrapper too.
-
- where
- worth_it (WwLazy True) = True -- Absent arg
- worth_it (WwUnpack True _) = True -- Arg to unpack
- worth_it WwStrict = False -- Don't w/w just because of strictness
- worth_it other = False
-
-allAbsent :: [Demand] -> Bool
-allAbsent ds = all absent ds
- where
- absent (WwLazy is_absent) = is_absent
- absent (WwUnpack True cs) = allAbsent cs
- absent other = False
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection{The worker wrapper core}
%* *
%************************************************************************
\begin{code}
mkWwBodies :: Type -- Type of original function
- -> Arity -- Arity of original function
-> [Demand] -- Strictness of original function
- -> Bool -- True <=> function returns bottom
+ -> DmdResult -- Info about function result
-> [Bool] -- One-shot-ness of the function
- -> CprInfo -- Result of CPR analysis
-> UniqSM ([Demand], -- Demands for worker (value) args
Id -> CoreExpr, -- Wrapper body, lacking only the worker Id
CoreExpr -> CoreExpr) -- Worker body, lacking the original function rhs
-- let x = (a,b) in
-- E
-mkWwBodies fun_ty arity demands res_bot one_shots cpr_info
- = mkWWargs fun_ty arity demands' res_bot one_shots' `thenUs` \ (wrap_args, wrap_fn_args, work_fn_args, res_ty) ->
- mkWWcpr res_ty cpr_info `thenUs` \ (wrap_fn_cpr, work_fn_cpr, cpr_res_ty) ->
- mkWWstr cpr_res_ty wrap_args `thenUs` \ (work_dmds, wrap_fn_str, work_fn_str) ->
+mkWwBodies fun_ty demands res_info one_shots
+ = mkWWargs fun_ty demands one_shots' `thenUs` \ (wrap_args, wrap_fn_args, work_fn_args, res_ty) ->
+ mkWWcpr res_ty res_info `thenUs` \ (wrap_fn_cpr, work_fn_cpr, cpr_res_ty) ->
+ mkWWstr cpr_res_ty wrap_args `thenUs` \ (work_dmds, wrap_fn_str, work_fn_str) ->
returnUs (work_dmds,
Note InlineMe . wrap_fn_args . wrap_fn_cpr . wrap_fn_str . Var,
-- f's RHS is now trivial (size 1) we still want the __inline__ to prevent
-- fw from being inlined into f's RHS
where
- demands' = demands ++ repeat wwLazy
one_shots' = one_shots ++ repeat False
\end{code}
-- It chomps bites off foralls, arrows, newtypes
-- and keeps repeating that until it's satisfied the supplied arity
-mkWWargs :: Type -> Arity
- -> [Demand] -> Bool -> [Bool] -- Both these will in due course be derived
- -- from the type. The [Bool] is True for a one-shot arg.
- -- ** Both are infinite, extended with neutral values if necy **
+mkWWargs :: Type
+ -> [Demand]
+ -> [Bool] -- True for a one-shot arg; ** may be infinite **
-> UniqSM ([Var], -- Wrapper args
CoreExpr -> CoreExpr, -- Wrapper fn
CoreExpr -> CoreExpr, -- Worker fn
Type) -- Type of wrapper body
-mkWWargs fun_ty arity demands res_bot one_shots
- | (res_bot || arity > 0) && (not (null tyvars) || n_arg_tys > 0)
- -- If the function returns bottom, we feel free to
- -- build lots of wrapper args:
- -- \x. let v=E in \y. bottom
- -- = \xy. let v=E in bottom
- = getUniquesUs `thenUs` \ wrap_uniqs ->
- let
- val_args = zipWith4 mk_wrap_arg wrap_uniqs arg_tys demands one_shots
- wrap_args = tyvars ++ val_args
- n_args | res_bot = n_arg_tys
- | otherwise = arity `min` n_arg_tys
- new_fun_ty | n_args == n_arg_tys = body_ty
- | otherwise = mkFunTys (drop n_args arg_tys) body_ty
- in
- mkWWargs new_fun_ty
- (arity - n_args)
- (drop n_args demands)
- res_bot
- (drop n_args one_shots) `thenUs` \ (more_wrap_args, wrap_fn_args, work_fn_args, res_ty) ->
-
- returnUs (wrap_args ++ more_wrap_args,
- mkLams wrap_args . wrap_fn_args,
- work_fn_args . applyToVars wrap_args,
- res_ty)
-
- | Just rep_ty <- splitNewType_maybe fun_ty,
- arity >= 0
+mkWWargs fun_ty demands one_shots
+ | Just rep_ty <- splitNewType_maybe fun_ty
-- The newtype case is for when the function has
-- a recursive newtype after the arrow (rare)
-- We check for arity >= 0 to avoid looping in the case
-- wrapped in a recursive newtype, at least if CPR analysis can look
-- through such newtypes, which it probably can since they are
-- simply coerces.
- = mkWWargs rep_ty arity demands res_bot one_shots `thenUs` \ (wrap_args, wrap_fn_args, work_fn_args, res_ty) ->
+ = mkWWargs rep_ty demands one_shots `thenUs` \ (wrap_args, wrap_fn_args, work_fn_args, res_ty) ->
returnUs (wrap_args,
Note (Coerce fun_ty rep_ty) . wrap_fn_args,
work_fn_args . Note (Coerce rep_ty fun_ty),
res_ty)
+ | not (null demands)
+ = getUniquesUs `thenUs` \ wrap_uniqs ->
+ let
+ (tyvars, tau) = splitForAllTys fun_ty
+ (arg_tys, body_ty) = splitFunTys tau
+
+ n_demands = length demands
+ n_arg_tys = length arg_tys
+ n_args = n_demands `min` n_arg_tys
+
+ new_fun_ty = mkFunTys (drop n_demands arg_tys) body_ty
+ new_demands = drop n_arg_tys demands
+ new_one_shots = drop n_args one_shots
+
+ val_args = zipWith4 mk_wrap_arg wrap_uniqs arg_tys demands one_shots
+ wrap_args = tyvars ++ val_args
+ in
+ ASSERT( not (null tyvars) || not (null arg_tys) )
+ mkWWargs new_fun_ty
+ new_demands
+ new_one_shots `thenUs` \ (more_wrap_args, wrap_fn_args, work_fn_args, res_ty) ->
+
+ returnUs (wrap_args ++ more_wrap_args,
+ mkLams wrap_args . wrap_fn_args,
+ work_fn_args . applyToVars wrap_args,
+ res_ty)
+
| otherwise
= returnUs ([], id, id, fun_ty)
- where
- (tyvars, tau) = splitForAllTys fun_ty
- (arg_tys, body_ty) = splitFunTys tau
- n_arg_tys = length arg_tys
-
applyToVars :: [Var] -> CoreExpr -> CoreExpr
applyToVars vars fn = mkVarApps fn vars
mk_wrap_arg uniq ty dmd one_shot
- = set_one_shot one_shot (setIdDemandInfo (mkSysLocal SLIT("w") uniq ty) dmd)
+ = set_one_shot one_shot (setIdNewDemandInfo (mkSysLocal SLIT("w") uniq ty) dmd)
where
set_one_shot True id = setOneShotLambda id
set_one_shot False id = id
mkWWstr res_ty wrap_args
= mk_ww_str wrap_args `thenUs` \ (work_args, take_apart, put_together) ->
let
- work_dmds = [idDemandInfo v | v <- work_args, isId v]
+ work_dmds = [idNewDemandInfo v | v <- work_args, isId v]
apply_to args fn = mkVarApps fn args
in
if not (null work_dmds && isUnLiftedType res_ty) then
returnUs ( work_dmds,
- take_apart . apply_to work_args,
+ take_apart . applyToVars work_args,
mkLams work_args . put_together)
else
-- Horrid special case. If the worker would have no arguments, and the
let
void_arg = mk_ww_local void_arg_uniq realWorldStatePrimTy
in
- returnUs ([wwPrim],
- take_apart . apply_to [realWorldPrimId] . apply_to work_args,
+ returnUs ([Lazy],
+ take_apart . applyToVars [realWorldPrimId] . apply_to work_args,
mkLams work_args . Lam void_arg . put_together)
-- Empty case
returnUs (arg : worker_args, wrap_fn, work_fn)
| otherwise
- = case idDemandInfo arg of
+ = case idNewDemandInfo arg of
- -- Absent case
- WwLazy True ->
+ -- Absent case. We don't deal with absence for unlifted types,
+ -- though, because it's not so easy to manufacture a placeholder
+ -- We'll see if this turns out to be a problem
+ Abs | not (isUnLiftedType (idType arg)) ->
mk_ww_str ds `thenUs` \ (worker_args, wrap_fn, work_fn) ->
returnUs (worker_args, wrap_fn, mk_absent_let arg . work_fn)
+ -- Seq and keep
+ Seq Keep _ [] -> mk_ww_str ds `thenUs` \ (worker_args, wrap_fn, work_fn) ->
+ returnUs (arg : worker_args, mk_seq_case arg . wrap_fn, work_fn)
+ -- Pass the arg, no need to rebox
+
+ -- Seq and discard
+ Seq Drop _ [] -> mk_ww_str ds `thenUs` \ (worker_args, wrap_fn, work_fn) ->
+ returnUs (worker_args, mk_seq_case arg . wrap_fn, mk_absent_let arg . work_fn)
+ -- Don't pass the arg, build absent arg
+
-- Unpack case
- WwUnpack True cs ->
- getUniquesUs `thenUs` \ uniqs ->
- let
- unpk_args = zipWith mk_ww_local uniqs inst_con_arg_tys
- unpk_args_w_ds = zipWithEqual "mk_ww_str" set_worker_arg_info unpk_args cs
- in
- mk_ww_str (unpk_args_w_ds ++ ds) `thenUs` \ (worker_args, wrap_fn, work_fn) ->
- returnUs (worker_args,
- mk_unpk_case arg unpk_args data_con arg_tycon . wrap_fn,
- work_fn . mk_pk_let arg data_con tycon_arg_tys unpk_args)
- where
- (arg_tycon, tycon_arg_tys, data_con, inst_con_arg_tys) = splitProductType "mk_ww_str" (idType arg)
+ Seq keep _ cs
+ | Just (arg_tycon, tycon_arg_tys, data_con, inst_con_arg_tys)
+ <- splitProductType_maybe (idType arg)
+ -> getUniquesUs `thenUs` \ uniqs ->
+ let
+ unpk_args = zipWith mk_ww_local uniqs inst_con_arg_tys
+ unpk_args_w_ds = zipWithEqual "mk_ww_str" set_worker_arg_info unpk_args cs
+ unbox_fn = mk_unpk_case arg unpk_args data_con arg_tycon
+ rebox_fn = mk_pk_let arg data_con tycon_arg_tys unpk_args
+ in
+ mk_ww_str (unpk_args_w_ds ++ ds) `thenUs` \ (worker_args, wrap_fn, work_fn) ->
+ case keep of
+ Keep -> returnUs (arg : worker_args, unbox_fn . wrap_fn, work_fn)
+ -- Pass the arg, no need to rebox
+ Drop -> returnUs (worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn)
+ -- Don't pass the arg, rebox instead
+
+ | otherwise ->
+ WARN( True, ppr arg )
+ mk_ww_str ds `thenUs` \ (worker_args, wrap_fn, work_fn) ->
+ returnUs (arg : worker_args, wrap_fn, work_fn)
-- Other cases
other_demand ->
-- If the wrapper argument is a one-shot lambda, then
-- so should (all) the corresponding worker arguments be
-- This bites when we do w/w on a case join point
- set_worker_arg_info worker_arg demand = set_one_shot (setIdDemandInfo worker_arg demand)
+ set_worker_arg_info worker_arg demand = set_one_shot (setIdNewDemandInfo worker_arg demand)
set_one_shot | isOneShotLambda arg = setOneShotLambda
| otherwise = \x -> x
\begin{code}
mkWWcpr :: Type -- function body type
- -> CprInfo -- CPR analysis results
+ -> DmdResult -- CPR analysis results
-> UniqSM (CoreExpr -> CoreExpr, -- New wrapper
CoreExpr -> CoreExpr, -- New worker
Type) -- Type of worker's body
-mkWWcpr body_ty NoCPRInfo
- = returnUs (id, id, body_ty) -- Must be just the strictness transf.
-
-mkWWcpr body_ty ReturnsCPR
+mkWWcpr body_ty RetCPR
| not (isAlgType body_ty)
= WARN( True, text "mkWWcpr: non-algebraic body type" <+> ppr body_ty )
returnUs (id, id, body_ty)
n_con_args = length con_arg_tys
con_arg_ty1 = head con_arg_tys
+mkWWcpr body_ty other -- No CPR info
+ = returnUs (id, id, body_ty)
+
-- If the original function looked like
-- f = \ x -> _scc_ "foo" E
--
(sanitiseCaseBndr arg)
[(DataAlt boxing_con, unpk_args, body)]
+mk_seq_case arg body = Case (Var arg) (sanitiseCaseBndr arg) [(DEFAULT, [], body)]
+
sanitiseCaseBndr :: Id -> Id
-- The argument we are scrutinising has the right type to be
-- a case binder, so it's convenient to re-use it for that purpose.
where
con_args = map Type con_tys ++ map Var unpk_args
-
mk_ww_local uniq ty = mkSysLocal SLIT("ww") uniq ty
-
\end{code}
isClassOpSig, isPragSig,
getClassDeclSysNames, placeHolderType
)
-import BasicTypes ( TopLevelFlag(..), RecFlag(..) )
+import BasicTypes ( TopLevelFlag(..), RecFlag(..), StrictnessMark(..) )
import RnHsSyn ( RenamedTyClDecl,
RenamedClassOpSig, RenamedMonoBinds,
RenamedContext, RenamedSig,
Class, ClassOpItem, DefMeth (..) )
import MkId ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId )
import DataCon ( mkDataCon )
-import Demand ( StrictnessMark(..) )
import Id ( Id, idType, idName )
import Module ( Module )
import Name ( Name, NamedThing(..) )
import TcHsSyn ( TcExpr, TcRecordBinds, mkHsLet )
import TcMonad
-import BasicTypes ( RecFlag(..) )
-
+import BasicTypes ( RecFlag(..), isMarkedStrict )
import Inst ( InstOrigin(..),
LIE, mkLIE, emptyLIE, unitLIE, plusLIE, plusLIEs,
newOverloadedLit, newMethod, newIPDict,
import DataCon ( dataConFieldLabels, dataConSig,
dataConStrictMarks
)
-import Demand ( isMarkedStrict )
import Name ( Name )
import TyCon ( TyCon, tyConTyVars, isAlgTyCon, tyConDataCons )
import Subst ( mkTopTyVarSubst, substTheta, substTy )
import TysWiredIn ( tupleCon )
import Var ( mkTyVar, tyVarKind )
import Name ( Name, nameIsLocalOrFrom )
-import Demand ( wwLazy )
import ErrUtils ( pprBagOfErrors )
import Outputable
import Util ( zipWithEqual )
init_info = vanillaIdInfo `setCgInfo` vanillaCgInfo
tcPrag info (HsNoCafRefs) = returnTc (info `setCafInfo` NoCafRefs)
- tcPrag info HsCprInfo = returnTc (info `setCprInfo` ReturnsCPR)
tcPrag info (HsArity arity) =
returnTc (info `setArityInfo` arity
returnTc info2
tcPrag info (HsStrictness strict_info)
- = returnTc (info `setStrictnessInfo` strict_info)
+ = returnTc (info `setNewStrictnessInfo` Just strict_info)
tcPrag info (HsWorker nm arity)
= tcWorkerInfo unf_env ty info nm arity
\begin{code}
tcWorkerInfo unf_env ty info worker_name arity
- = uniqSMToTcM (mkWrapper ty arity demands res_bot cpr_info) `thenNF_Tc` \ wrap_fn ->
+ = uniqSMToTcM (mkWrapper ty strict_sig) `thenNF_Tc` \ wrap_fn ->
let
-- Watch out! We can't pull on unf_env too eagerly!
info' = case tcLookupRecId_maybe unf_env worker_name of
in
returnTc info'
where
- -- We are relying here on cpr and strictness info always appearing
+ -- We are relying here on strictness info always appearing
-- before worker info, fingers crossed ....
- cpr_info = cprInfo info
-
- (demands, res_bot)
- = case strictnessInfo info of
- StrictnessInfo d r -> (d,r)
- _ -> (take arity (repeat wwLazy),False)
- -- Noncommittal
+ strict_sig = case newStrictnessInfo info of
+ Just sig -> sig
+ Nothing -> pprPanic "Worker info but no strictness for" (ppr worker_name)
\end{code}
For unfoldings we try to do the job lazily, so that we never type check
projects / ghc-hetmet.git / commitdiff