From: simonpj Date: Mon, 19 Nov 2001 14:23:53 +0000 (+0000) Subject: [project @ 2001-11-19 14:23:52 by simonpj] X-Git-Tag: Approximately_9120_patches~562 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=d8af6b8ce9d241a8f8d6878e2400aa8577f552bc;p=ghc-hetmet.git [project @ 2001-11-19 14:23:52 by simonpj] -------------------------------------- Yet another cut at the DmdAnal domains -------------------------------------- This version of the domain for demand analysis was developed in discussion with Peter Sestoft, so I think it might at last be more or less right! Our idea is mentally to separate strictness analysis from absence and boxity analysis Then we combine them back into a single domain. The latter is all you see in the compiler (the Demand type, as before) but we understand it better now. --- diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 9575acd..c4c3570 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -55,7 +55,7 @@ module Id ( idArity, idDemandInfo, idNewDemandInfo, - idStrictness, idNewStrictness, idNewStrictness_maybe, getNewStrictness, + idStrictness, idNewStrictness, idNewStrictness_maybe, idTyGenInfo, idWorkerInfo, idUnfolding, @@ -318,11 +318,7 @@ setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id --------------------------------- -- STRICTNESS idStrictness :: Id -> StrictnessInfo -idStrictness id = case strictnessInfo (idInfo id) of - NoStrictnessInfo -> case idNewStrictness_maybe id of - Just sig -> oldStrictnessFromNew sig - Nothing -> NoStrictnessInfo - strictness -> strictness +idStrictness id = strictnessInfo (idInfo id) setIdStrictness :: Id -> StrictnessInfo -> Id setIdStrictness id strict_info = modifyIdInfo (`setStrictnessInfo` strict_info) id @@ -337,20 +333,6 @@ 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 @@ -431,11 +413,7 @@ idCafInfo id = cgCafInfo (idCgInfo id) --------------------------------- -- CPR INFO idCprInfo :: Id -> CprInfo -idCprInfo id = case cprInfo (idInfo id) of - NoCPRInfo -> case strictSigResInfo (idNewStrictness id) of - RetCPR -> ReturnsCPR - other -> NoCPRInfo - ReturnsCPR -> ReturnsCPR +idCprInfo id = cprInfo (idInfo id) setIdCprInfo :: Id -> CprInfo -> Id setIdCprInfo id cpr_info = modifyIdInfo (`setCprInfo` cpr_info) id diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index 017b3eb..7541f74 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -24,14 +24,15 @@ module IdInfo ( arityInfo, setArityInfo, ppArityInfo, -- New demand and strictness info - newStrictnessInfo, setNewStrictnessInfo, mkNewStrictnessInfo, + newStrictnessInfo, setNewStrictnessInfo, newDemandInfo, setNewDemandInfo, newDemand, oldDemand, -- Strictness; imported from Demand StrictnessInfo(..), mkStrictnessInfo, noStrictnessInfo, ppStrictnessInfo,isBottomingStrictness, - strictnessInfo, setStrictnessInfo, + strictnessInfo, setStrictnessInfo, setAllStrictnessInfo, + oldStrictnessFromNew, newStrictnessFromOld, cprInfoFromNewStrictness, -- Usage generalisation TyGenInfo(..), @@ -96,9 +97,10 @@ import FieldLabel ( FieldLabel ) import Type ( usOnce, usMany ) import Demand hiding( Demand ) import qualified Demand -import NewDemand ( Demand(..), Keepity(..), DmdResult(..), - lazyDmd, topDmd, dmdTypeDepth, isStrictDmd, - StrictSig, mkStrictSig, mkTopDmdType +import NewDemand ( Demand(..), DmdResult(..), Demands(..), + lazyDmd, topDmd, dmdTypeDepth, isStrictDmd, isBotRes, + splitStrictSig, strictSigResInfo, + StrictSig, mkStrictSig, mkTopDmdType, evalDmd, lazyDmd ) import Outputable import Util ( seqList, listLengthCmp ) @@ -118,6 +120,7 @@ infixl 1 `setDemandInfo`, `setCgInfo`, `setCafInfo`, `setNewStrictnessInfo`, + `setAllStrictnessInfo`, `setNewDemandInfo` -- infixl so you can say (id `set` a `set` b) \end{code} @@ -131,22 +134,43 @@ infixl 1 `setDemandInfo`, To be removed later \begin{code} -mkNewStrictnessInfo :: Id -> Arity -> Demand.StrictnessInfo -> CprInfo -> StrictSig -mkNewStrictnessInfo id arity (Demand.StrictnessInfo ds res) cpr +setAllStrictnessInfo :: IdInfo -> Maybe StrictSig -> IdInfo +-- Set old and new strictness info +setAllStrictnessInfo info Nothing + = info { newStrictnessInfo = Nothing, + strictnessInfo = NoStrictnessInfo, + cprInfo = NoCPRInfo } +setAllStrictnessInfo info (Just sig) + = info { newStrictnessInfo = Just sig, + strictnessInfo = oldStrictnessFromNew sig, + cprInfo = cprInfoFromNewStrictness sig } + +oldStrictnessFromNew :: StrictSig -> Demand.StrictnessInfo +oldStrictnessFromNew sig = mkStrictnessInfo (map oldDemand dmds, isBotRes res_info) + where + (dmds, res_info) = splitStrictSig sig + +cprInfoFromNewStrictness :: StrictSig -> CprInfo +cprInfoFromNewStrictness sig = case strictSigResInfo sig of + RetCPR -> ReturnsCPR + other -> NoCPRInfo + +newStrictnessFromOld :: Name -> Arity -> Demand.StrictnessInfo -> CprInfo -> StrictSig +newStrictnessFromOld name arity (Demand.StrictnessInfo ds res) cpr | listLengthCmp ds arity /= GT -- length ds <= arity -- Sometimes the old strictness analyser has more -- demands than the arity justifies - = mk_strict_sig id arity $ + = mk_strict_sig name arity $ mkTopDmdType (map newDemand ds) (newRes res cpr) -mkNewStrictnessInfo id arity other cpr +newStrictnessFromOld name arity other cpr = -- Either no strictness info, or arity is too small -- In either case we can't say anything useful - mk_strict_sig id arity $ + mk_strict_sig name arity $ mkTopDmdType (replicate arity lazyDmd) (newRes False cpr) -mk_strict_sig id arity dmd_ty - = WARN( arity /= dmdTypeDepth dmd_ty, ppr id <+> (ppr arity $$ ppr dmd_ty) ) +mk_strict_sig name arity dmd_ty + = WARN( arity /= dmdTypeDepth dmd_ty, ppr name <+> (ppr arity $$ ppr dmd_ty) ) mkStrictSig dmd_ty newRes True _ = BotRes @@ -155,20 +179,23 @@ 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 (map newDemand ds) -newDemand WwPrim = Lazy -newDemand WwEnum = Eval +newDemand (WwLazy False) = lazyDmd +newDemand WwStrict = evalDmd +newDemand (WwUnpack unpk ds) = Eval (Prod (map newDemand ds)) +newDemand WwPrim = lazyDmd +newDemand WwEnum = evalDmd oldDemand :: NewDemand.Demand -> Demand.Demand -oldDemand Abs = WwLazy True -oldDemand Lazy = WwLazy False -oldDemand Bot = WwStrict -oldDemand Err = WwStrict -oldDemand Eval = WwStrict -oldDemand (Seq _ ds) = WwUnpack True (map oldDemand ds) -oldDemand (Call _) = WwStrict +oldDemand Abs = WwLazy True +oldDemand Top = WwLazy False +oldDemand Bot = WwStrict +oldDemand (Box Bot) = WwStrict +oldDemand (Box Abs) = WwLazy False +oldDemand (Box (Eval _)) = WwStrict -- Pass box only +oldDemand (Defer d) = WwLazy False +oldDemand (Eval (Prod ds)) = WwUnpack True (map oldDemand ds) +oldDemand (Eval (Poly _)) = WwStrict +oldDemand (Call _) = WwStrict \end{code} @@ -300,7 +327,7 @@ setUnfoldingInfo info uf -- let x = (a,b) in h a b x -- and now x is not demanded (I'm assuming h is lazy) -- This really happens. The solution here is a bit ad hoc... - = info { unfoldingInfo = uf, newDemandInfo = Lazy } + = info { unfoldingInfo = uf, newDemandInfo = Top } | otherwise -- We do *not* seq on the unfolding info, For some reason, doing so @@ -717,7 +744,7 @@ zapLamInfo info@(IdInfo {occInfo = occ, newDemandInfo = demand}) = Nothing | otherwise = Just (info {occInfo = safe_occ, - newDemandInfo = Lazy}) + newDemandInfo = Top}) where -- The "unsafe" occ info is the ones that say I'm not in a lambda -- because that might not be true for an unsaturated lambda @@ -734,7 +761,7 @@ zapLamInfo info@(IdInfo {occInfo = occ, newDemandInfo = demand}) zapDemandInfo :: IdInfo -> Maybe IdInfo zapDemandInfo info@(IdInfo {newDemandInfo = demand}) | not (isStrictDmd demand) = Nothing - | otherwise = Just (info {newDemandInfo = Lazy}) + | otherwise = Just (info {newDemandInfo = Top}) \end{code} diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index e15b79a..f5998d2 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -72,12 +72,13 @@ import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal, import IdInfo ( IdInfo, noCafNoTyGenIdInfo, setUnfoldingInfo, setArityInfo, setSpecInfo, setCgInfo, setCafInfo, - mkNewStrictnessInfo, setNewStrictnessInfo, + newStrictnessFromOld, setAllStrictnessInfo, GlobalIdDetails(..), CafInfo(..), CprInfo(..), CgInfo ) import NewDemand ( mkStrictSig, strictSigResInfo, DmdResult(..), - mkTopDmdType, topDmd, evalDmd, Demand(..), Keepity(..) ) + mkTopDmdType, topDmd, evalDmd, lazyDmd, + Demand(..), Demands(..) ) import FieldLabel ( mkFieldLabel, fieldLabelName, firstFieldLabelTag, allFieldLabelTags, fieldLabelType ) @@ -147,7 +148,7 @@ mkDataConId work_name data_con where info = noCafNoTyGenIdInfo `setArityInfo` arity - `setNewStrictnessInfo` Just strict_sig + `setAllStrictnessInfo` Just strict_sig arity = dataConRepArity data_con @@ -238,15 +239,15 @@ mkDataConWrapId data_con `setArityInfo` arity -- It's important to specify the arity, so that partial -- applications are treated as values - `setNewStrictnessInfo` Just wrap_sig + `setAllStrictnessInfo` Just wrap_sig wrap_ty = mkForAllTys all_tyvars (mkFunTys all_arg_tys result_ty) wrap_sig = mkStrictSig (mkTopDmdType arg_dmds res_info) res_info = strictSigResInfo (idNewStrictness work_id) arg_dmds = [Abs | d <- dict_args] ++ map mk_dmd strict_marks - mk_dmd str | isMarkedStrict str = Eval - | otherwise = Lazy + mk_dmd str | isMarkedStrict str = evalDmd + | otherwise = lazyDmd -- The Cpr info can be important inside INLINE rhss, where the -- wrapper constructor isn't inlined. -- And the argument strictness can be important too; we @@ -444,7 +445,7 @@ mkRecordSelId tycon field_label unpack_id unpackUtf8_id `setCafInfo` caf_info `setArityInfo` arity `setUnfoldingInfo` mkTopUnfolding rhs_w_str - `setNewStrictnessInfo` Just strict_sig + `setAllStrictnessInfo` Just strict_sig -- Allocate Ids. We do it a funny way round because field_dict_tys is -- almost always empty. Also note that we use length_tycon_theta @@ -588,7 +589,7 @@ mkDictSelId name clas info = noCafNoTyGenIdInfo `setArityInfo` 1 `setUnfoldingInfo` mkTopUnfolding rhs - `setNewStrictnessInfo` Just strict_sig + `setAllStrictnessInfo` Just strict_sig -- We no longer use 'must-inline' on record selectors. They'll -- inline like crazy if they scrutinise a constructor @@ -598,9 +599,9 @@ mkDictSelId name clas -- It's worth giving one, so that absence info etc is generated -- even if the selector isn't inlined strict_sig = mkStrictSig (mkTopDmdType [arg_dmd] TopRes) - arg_dmd | isNewTyCon tycon = Eval - | otherwise = Seq Drop [ if the_arg_id == id then Eval else Abs - | id <- arg_ids ] + arg_dmd | isNewTyCon tycon = evalDmd + | otherwise = Eval (Prod [ if the_arg_id == id then evalDmd else Abs + | id <- arg_ids ]) tyvars = classTyVars clas @@ -648,7 +649,7 @@ mkPrimOpId prim_op info = noCafNoTyGenIdInfo `setSpecInfo` rules `setArityInfo` arity - `setNewStrictnessInfo` Just (mkNewStrictnessInfo id arity strict_info NoCPRInfo) + `setAllStrictnessInfo` Just (newStrictnessFromOld name arity strict_info NoCPRInfo) -- Until we modify the primop generation code rules = foldl (addRule id) emptyCoreRules (primOpRules prim_op) @@ -678,7 +679,7 @@ mkFCallId uniq fcall ty info = noCafNoTyGenIdInfo `setArityInfo` arity - `setNewStrictnessInfo` Just strict_sig + `setAllStrictnessInfo` Just strict_sig (_, tau) = tcSplitForAllTys ty (arg_tys, _) = tcSplitFunTys tau @@ -939,7 +940,7 @@ pc_bottoming_Id key mod name ty = pcMiscPrelId key mod name ty bottoming_info where strict_sig = mkStrictSig (mkTopDmdType [evalDmd] BotRes) - bottoming_info = noCafNoTyGenIdInfo `setNewStrictnessInfo` Just strict_sig + bottoming_info = noCafNoTyGenIdInfo `setAllStrictnessInfo` Just strict_sig -- these "bottom" out, no matter what their arguments generic_ERROR_ID u n = pc_bottoming_Id u pREL_ERR n errorTy diff --git a/ghc/compiler/basicTypes/NewDemand.lhs b/ghc/compiler/basicTypes/NewDemand.lhs index e401609..dcc47e1 100644 --- a/ghc/compiler/basicTypes/NewDemand.lhs +++ b/ghc/compiler/basicTypes/NewDemand.lhs @@ -5,13 +5,16 @@ \begin{code} module NewDemand( - Demand(..), Keepity(..), - mkSeq, topDmd, lazyDmd, seqDmd, evalDmd, isStrictDmd, + Demand(..), + topDmd, lazyDmd, seqDmd, evalDmd, errDmd, isStrictDmd, + isTop, isAbsent, DmdType(..), topDmdType, botDmdType, mkDmdType, mkTopDmdType, dmdTypeDepth, dmdTypeRes, DmdEnv, emptyDmdEnv, - DmdResult(..), isBotRes, returnsCPR, + DmdResult(..), isBotRes, returnsCPR, resTypeArgDmd, + + Demands(..), mapDmds, zipWithDmds, allTop, StrictSig(..), mkStrictSig, topSig, botSig, isTopSig, splitStrictSig, strictSigResInfo, @@ -23,13 +26,98 @@ module NewDemand( import BasicTypes ( Arity ) import VarEnv ( VarEnv, emptyVarEnv, isEmptyVarEnv ) import UniqFM ( ufmToList ) -import Util ( listLengthCmp ) +import Util ( listLengthCmp, zipWithEqual ) import Outputable \end{code} %************************************************************************ %* * +\subsection{Demands} +%* * +%************************************************************************ + +\begin{code} +data Demand + = Top -- T; used for unlifted types too, so that + -- A `lub` T = T + | Abs -- A + + | Call Demand -- C(d) + + | Eval Demands -- U(ds) + + | Defer Demands -- D(ds) + + | Box Demand -- B(d) + + | Bot -- B + deriving( Eq ) + -- Equality needed for fixpoints in DmdAnal + +data Demands = Poly Demand -- Polymorphic case + | Prod [Demand] -- Product case + deriving( Eq ) + +allTop (Poly d) = isTop d +allTop (Prod ds) = all isTop ds + +isTop Top = True +isTop d = False + +isAbsent Abs = True +isAbsent d = False + +mapDmds :: (Demand -> Demand) -> Demands -> Demands +mapDmds f (Poly d) = Poly (f d) +mapDmds f (Prod ds) = Prod (map f ds) + +zipWithDmds :: (Demand -> Demand -> Demand) + -> Demands -> Demands -> Demands +zipWithDmds f (Poly d1) (Poly d2) = Poly (d1 `f` d2) +zipWithDmds f (Prod ds1) (Poly d2) = Prod [d1 `f` d2 | d1 <- ds1] +zipWithDmds f (Poly d1) (Prod ds2) = Prod [d1 `f` d2 | d2 <- ds2] +zipWithDmds f (Prod ds1) (Prod ds2) = Prod (zipWithEqual "zipWithDmds" f ds1 ds2) + +topDmd, lazyDmd, seqDmd :: Demand +topDmd = Top -- The most uninformative demand +lazyDmd = Box Abs +seqDmd = Eval (Poly Abs) -- Polymorphic seq demand +evalDmd = Box seqDmd -- Evaluate and return +errDmd = Box Bot -- This used to be called X + +isStrictDmd :: Demand -> Bool +isStrictDmd Bot = True +isStrictDmd (Eval _) = True +isStrictDmd (Call _) = True +isStrictDmd (Box d) = isStrictDmd d +isStrictDmd other = False + +instance Outputable Demand where + ppr Top = char 'T' + ppr Abs = char 'A' + ppr Bot = char 'B' + + ppr (Defer ds) = char 'D' <> ppr ds + ppr (Eval ds) = char 'U' <> ppr ds + + ppr (Box (Eval ds)) = char 'S' <> ppr ds + ppr (Box Abs) = char 'L' + ppr (Box Bot) = char 'X' + + ppr (Call d) = char 'C' <> parens (ppr d) + + +instance Outputable Demands where + ppr (Poly Abs) = empty + ppr (Poly d) = parens (ppr d <> char '*') + ppr (Prod ds) | all isAbsent ds = empty + | otherwise = parens (hcat (map ppr ds)) +\end{code} + + +%************************************************************************ +%* * \subsection{Demand types} %* * %************************************************************************ @@ -48,7 +136,7 @@ data DmdType = DmdType -- ANOTHER IMPORTANT INVARIANT -- The Demands in the argument list are never - -- Bot, Err, Seq Defer ds + -- Bot, Defer d -- Handwavey reason: these don't correspond to calling conventions -- See DmdAnal.funArgDemand for details @@ -96,6 +184,15 @@ isBotRes :: DmdResult -> Bool isBotRes BotRes = True isBotRes other = False +resTypeArgDmd :: DmdResult -> Demand +-- TopRes and BotRes are polymorphic, so that +-- BotRes = Bot -> BotRes +-- TopRes = Top -> TopRes +-- This function makes that concrete +resTypeArgDmd TopRes = Top +resTypeArgDmd BotRes = Bot +resTypeArgDmd RetCPR = panic "resTypeArgDmd: RetCPR" + returnsCPR :: DmdResult -> Bool returnsCPR RetCPR = True returnsCPR other = False @@ -183,72 +280,3 @@ pprIfaceStrictSig (StrictSig (DmdType _ dmds res)) \end{code} -%************************************************************************ -%* * -\subsection{Demands} -%* * -%************************************************************************ - -\begin{code} -data Demand - = Lazy -- L; used for unlifted types too, so that - -- A `lub` L = L - | Abs -- A - - | Call Demand -- C(d) - | Eval -- V - | Seq Keepity -- S/U/D(ds) - [Demand] -- S(ds) = L `both` U(ds) - -- D(ds) = A `lub` U(ds) - -- *** Invariant: these demands are never Bot or Abs - -- *** Invariant: if all demands are Abs, get [] - - | Err -- X - | Bot -- B - deriving( Eq ) - -- Equality needed for fixpoints in DmdAnal - -data Keepity = Keep -- Strict and I need the box - | Drop -- Strict, but I don't need the box - | Defer -- Lazy, if you *do* evaluate, I need - -- the components but not the box - deriving( Eq ) - -mkSeq :: Keepity -> [Demand] -> Demand -mkSeq k ds | all is_absent ds = Seq k [] - | otherwise = Seq k ds - where - is_absent Abs = True - is_absent d = False - -topDmd, lazyDmd, seqDmd :: Demand -topDmd = Lazy -- The most uninformative demand -lazyDmd = Lazy -seqDmd = Seq Keep [] -- Polymorphic seq demand -evalDmd = Eval - -isStrictDmd :: Demand -> Bool -isStrictDmd Bot = True -isStrictDmd Err = True -isStrictDmd (Seq Drop _) = True -- But not Defer! -isStrictDmd (Seq Keep _) = True -isStrictDmd Eval = True -isStrictDmd (Call _) = True -isStrictDmd other = False - -instance Outputable Demand where - ppr Lazy = char 'L' - ppr Abs = char 'A' - ppr Eval = char 'V' - ppr Err = char 'X' - ppr Bot = char 'B' - ppr (Call d) = char 'C' <> parens (ppr d) - ppr (Seq k []) = ppr k - ppr (Seq k ds) = ppr k <> parens (hcat (map ppr ds)) - -instance Outputable Keepity where - ppr Keep = char 'S' - ppr Drop = char 'U' - ppr Defer = char 'D' -\end{code} - diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs index b3010f8..344a5db 100644 --- a/ghc/compiler/coreSyn/CoreTidy.lhs +++ b/ghc/compiler/coreSyn/CoreTidy.lhs @@ -500,7 +500,7 @@ tidyTopIdInfo tidy_env is_external idinfo unfold_info arity cg_info basic_info = vanillaIdInfo `setCgInfo` cg_info `setArityInfo` arity - `setNewStrictnessInfo` newStrictnessInfo idinfo + `setAllStrictnessInfo` newStrictnessInfo idinfo -- This is where we set names to local/global based on whether they really are -- externally visible (see comment at the top of this module). If the name @@ -663,7 +663,7 @@ tidyLetBndr env (id,rhs) idinfo = idInfo id new_info = vanillaIdInfo `setArityInfo` exprArity rhs - `setNewStrictnessInfo` newStrictnessInfo idinfo + `setAllStrictnessInfo` newStrictnessInfo idinfo `setNewDemandInfo` newDemandInfo idinfo -- Override the env we get back from tidyId with the new IdInfo diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs index 0d04782..a42fc57 100644 --- a/ghc/compiler/parser/Lex.lhs +++ b/ghc/compiler/parser/Lex.lhs @@ -39,8 +39,8 @@ import List ( isSuffixOf ) import PrelNames ( mkTupNameStr ) import CmdLineOpts ( opt_HiVersion, opt_NoHiCheck ) import ForeignCall ( Safety(..) ) -import NewDemand ( StrictSig(..), Demand(..), Keepity(..), - DmdResult(..), mkTopDmdType ) +import NewDemand ( StrictSig(..), Demand(..), Demands(..), + DmdResult(..), mkTopDmdType, evalDmd, lazyDmd ) import UniqFM ( listToUFM, lookupUFM ) import BasicTypes ( Boxity(..) ) import SrcLoc ( SrcLoc, incSrcLine, srcLocFile, srcLocLine, @@ -838,30 +838,37 @@ lex_demand cont buf = where read_em acc buf = case currentChar# buf of - 'L'# -> read_em (Lazy : acc) (stepOn buf) - 'A'# -> read_em (Abs : acc) (stepOn buf) - 'V'# -> read_em (Eval : acc) (stepOn buf) - 'X'# -> read_em (Err : acc) (stepOn buf) - 'B'# -> read_em (Bot : acc) (stepOn buf) - ')'# -> (reverse acc, stepOn buf) - 'C'# -> do_call acc (stepOnBy# buf 2#) - 'D'# -> do_unpack1 Defer acc (stepOnBy# buf 1#) - 'U'# -> do_unpack1 Drop acc (stepOnBy# buf 1#) - 'S'# -> do_unpack1 Keep acc (stepOnBy# buf 1#) - _ -> (reverse acc, buf) + 'T'# -> read_em (Top : acc) (stepOn buf) + 'L'# -> read_em (lazyDmd : acc) (stepOn buf) + 'A'# -> read_em (Abs : acc) (stepOn buf) + 'V'# -> read_em (evalDmd : acc) (stepOn buf) -- Temporary, until + -- we've recompiled prelude etc + 'C'# -> do_unary Call acc (stepOnBy# buf 2#) -- Skip 'C(' - do_unpack1 keepity acc buf - = case currentChar# buf of - '('# -> do_unpack2 keepity acc (stepOnBy# buf 1#) - _ -> read_em (Seq keepity [] : acc) buf + 'U'# -> do_seq1 Eval acc (stepOnBy# buf 1#) + 'D'# -> do_seq1 Defer acc (stepOnBy# buf 1#) + 'S'# -> do_seq1 (Box . Eval) acc (stepOnBy# buf 1#) - do_unpack2 keepity acc buf - = case read_em [] buf of - (stuff, rest) -> read_em (Seq keepity stuff : acc) rest + _ -> (reverse acc, buf) - do_call acc buf + do_seq1 fn acc buf + = case currentChar# buf of + '('# -> do_seq2 fn acc (stepOnBy# buf 1#) + _ -> read_em (fn (Poly Abs) : acc) buf + + do_seq2 fn acc buf + = case read_em [] buf of { (dmds, buf) -> + case currentChar# buf of + ')'# -> read_em (fn (Prod dmds) : acc) + (stepOn buf) + '*'# -> ASSERT( length dmds == 1 ) + read_em (fn (Poly (head dmds)) : acc) + (stepOnBy# buf 2#) -- Skip '*)' + } + + do_unary fn acc buf = case read_em [] buf of - ([dmd], rest) -> read_em (Call dmd : acc) rest + ([dmd], rest) -> read_em (fn dmd : acc) (stepOn rest) -- Skip ')' ------------------ lex_scc cont buf = diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index b69e2b2..774fa57 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -897,7 +897,8 @@ completeCall env var occ_info cont pprTrace "Rule fired" (vcat [ text "Rule:" <+> ptext rule_name, text "Before:" <+> ppr var <+> sep (map pprParendExpr args), - text "After: " <+> pprCoreExpr rule_rhs]) + text "After: " <+> pprCoreExpr rule_rhs, + text "Cont: " <+> ppr call_cont]) else id) $ simplExprF env rule_rhs call_cont ; diff --git a/ghc/compiler/stranal/DmdAnal.lhs b/ghc/compiler/stranal/DmdAnal.lhs index 8648cb6..e5934e5 100644 --- a/ghc/compiler/stranal/DmdAnal.lhs +++ b/ghc/compiler/stranal/DmdAnal.lhs @@ -22,9 +22,9 @@ import DataCon ( dataConTyCon ) import TyCon ( isProductTyCon, isRecursiveTyCon ) import Id ( Id, idType, idDemandInfo, idInlinePragma, isDataConId, isGlobalId, idArity, - idNewStrictness, idNewStrictness_maybe, getNewStrictness, setIdNewStrictness, - idNewDemandInfo, setIdNewDemandInfo, newStrictnessFromOld ) -import IdInfo ( newDemand ) + idNewStrictness, idNewStrictness_maybe, setIdNewStrictness, + idNewDemandInfo, setIdNewDemandInfo, idName, idStrictness, idCprInfo ) +import IdInfo ( newDemand, newStrictnessFromOld ) import Var ( Var ) import VarEnv import UniqFM ( plusUFM_C, addToUFM_Directly, lookupUFM_Directly, @@ -117,12 +117,13 @@ dmdAnalTopRhs rhs dmdAnal :: SigEnv -> Demand -> CoreExpr -> (DmdType, CoreExpr) dmdAnal sigs Abs e = (topDmdType, e) -dmdAnal sigs Bot e = (botDmdType, e) -dmdAnal sigs Lazy e = let - (res_ty, e') = dmdAnal sigs Eval e - in - (deferType res_ty, e') +dmdAnal sigs dmd e + | not (isStrictDmd dmd) + = let + (res_ty, e') = dmdAnal sigs evalDmd e + in + (deferType res_ty, e') -- It's important not to analyse e with a lazy demand because -- a) When we encounter case s of (a,b) -> -- we demand s with U(d1d2)... but if the overall demand is lazy @@ -149,11 +150,11 @@ dmdAnal sigs dmd (Note n e) where (dmd_ty, e') = dmdAnal sigs dmd' e dmd' = case n of - Coerce _ _ -> Eval -- This coerce usually arises from a recursive - other -> dmd -- newtype, and we don't want to look inside them - -- for exactly the same reason that we don't look - -- inside recursive products -- we might not reach - -- a fixpoint. So revert to a vanilla Eval demand + Coerce _ _ -> evalDmd -- This coerce usually arises from a recursive + other -> dmd -- newtype, and we don't want to look inside them + -- for exactly the same reason that we don't look + -- inside recursive products -- we might not reach + -- a fixpoint. So revert to a vanilla Eval demand dmdAnal sigs dmd (App fun (Type ty)) = (fun_ty, App fun' (Type ty)) @@ -186,7 +187,7 @@ dmdAnal sigs dmd (Lam var body) | otherwise -- Not enough demand on the lambda; but do the body = let -- anyway to annotate it and gather free var info - (body_ty, body') = dmdAnal sigs Eval body + (body_ty, body') = dmdAnal sigs evalDmd body (lam_ty, var') = annotateLamIdBndr body_ty var in (deferType lam_ty, Lam var' body') @@ -231,7 +232,7 @@ dmdAnal sigs dmd (Case scrut case_bndr [alt@(DataAlt dc,bndrs,rhs)]) -- The insight is, of course, that a demand on y is a demand on the -- scrutinee, so we need to `both` it with the scrut demand - scrut_dmd = mkSeq Drop [idNewDemandInfo b | b <- bndrs', isId b] + scrut_dmd = Eval (Prod [idNewDemandInfo b | b <- bndrs', isId b]) `both` idNewDemandInfo case_bndr' @@ -242,7 +243,7 @@ dmdAnal sigs dmd (Case scrut case_bndr [alt@(DataAlt dc,bndrs,rhs)]) dmdAnal sigs dmd (Case scrut case_bndr alts) = let (alt_tys, alts') = mapAndUnzip (dmdAnalAlt sigs dmd) alts - (scrut_ty, scrut') = dmdAnal sigs Eval scrut + (scrut_ty, scrut') = dmdAnal sigs evalDmd scrut (alt_ty, case_bndr') = annotateBndr (foldr1 lubType alt_tys) case_bndr in -- pprTrace "dmdAnal:Case" (ppr alts $$ ppr alt_tys) @@ -255,13 +256,18 @@ dmdAnal sigs dmd (Let (NonRec id rhs) body) (body_ty1, id2) = annotateBndr body_ty id1 body_ty2 = addLazyFVs body_ty1 lazy_fv in +#ifdef DEBUG + -- If the actual demand is better than the vanilla + -- demand, we might do better to re-analyse with the + -- stronger demand. (let vanilla_dmd = vanillaCall (idArity id) actual_dmd = idNewDemandInfo id2 in - if not (vanilla_dmd `betterDemand` actual_dmd) then + if actual_dmd `betterDemand` vanilla_dmd && actual_dmd /= vanilla_dmd then pprTrace "dmdLet: better demand" (ppr id <+> vcat [text "vanilla" <+> ppr vanilla_dmd, text "actual" <+> ppr actual_dmd]) else \x -> x) +#endif (body_ty2, Let (NonRec id2 rhs') body') dmdAnal sigs dmd (Let (Rec pairs) body) @@ -511,15 +517,13 @@ setUnpackStrategy ds -> [Demand] -> (Int, [Demand]) -- Args remaining after subcomponents of [Demand] are unpacked - go n (Seq keep cs : ds) - | n' >= 0 = Seq keep cs' `cons` go n'' ds - | otherwise = Eval `cons` go n ds + go n (Eval (Prod cs) : ds) + | n' >= 0 = Eval (Prod cs') `cons` go n'' ds + | otherwise = Box (Eval (Prod cs)) `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 + n' = n + 1 - non_abs_args + -- Add one to the budget 'cos we drop the top-level arg non_abs_args = nonAbsentArgs cs -- Delete # of non-absent args to which we'll now be committed @@ -547,11 +551,7 @@ splitDmdTy :: DmdType -> (Demand, DmdType) -- We already have a suitable demand on all -- free vars, so no need to add more! splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty) -splitDmdTy ty@(DmdType fv [] TopRes) = (Lazy, ty) -splitDmdTy ty@(DmdType fv [] BotRes) = (Bot, ty) - -- NB: Bot not Abs -splitDmdTy ty@(DmdType fv [] RetCPR) = panic "splitDmdTy" - -- We should not be applying a product as a function! +splitDmdTy ty@(DmdType fv [] res_ty) = (resTypeArgDmd res_ty, ty) \end{code} \begin{code} @@ -598,8 +598,7 @@ annotateBndr :: DmdType -> Var -> (DmdType, Var) -- No effect on the argument demands annotateBndr dmd_ty@(DmdType fv ds res) var | isTyVar var = (dmd_ty, var) - | otherwise = (DmdType fv' ds res, - setIdNewDemandInfo var (argDemand var dmd)) + | otherwise = (DmdType fv' ds res, setIdNewDemandInfo var dmd) where (fv', dmd) = removeFV fv var res @@ -612,7 +611,7 @@ annotateLamIdBndr dmd_ty@(DmdType fv ds res) id (DmdType fv' (hacked_dmd:ds) res, setIdNewDemandInfo id hacked_dmd) where (fv', dmd) = removeFV fv id res - hacked_dmd = argDemand id dmd + hacked_dmd = argDemand dmd -- This call to argDemand is vital, because otherwise we label -- a lambda binder with demand 'B'. But in terms of calling -- conventions that's Abs, because we don't pass it. But @@ -621,12 +620,19 @@ annotateLamIdBndr dmd_ty@(DmdType fv ds res) id -- And then the simplifier things the 'B' is a strict demand -- and evaluates the (error "oops"). Sigh -removeFV fv var res = (fv', dmd) +removeFV fv id res = (fv', zapUnlifted id dmd) where - fv' = fv `delVarEnv` var - dmd = lookupVarEnv fv var `orElse` deflt + fv' = fv `delVarEnv` id + dmd = lookupVarEnv fv id `orElse` deflt deflt | isBotRes res = Bot | otherwise = Abs + +-- For unlifted-type variables, we are only +-- interested in Bot/Abs/Box Abs +zapUnlifted is Bot = Bot +zapUnlifted id Abs = Abs +zapUnlifted id dmd | isUnLiftedType (idType id) = lazyDmd + | otherwise = dmd \end{code} %************************************************************************ @@ -661,8 +667,7 @@ dmdTransform :: SigEnv -- The strictness environment dmdTransform sigs var dmd ------ DATA CONSTRUCTOR - | isDataConId var, -- Data constructor - Seq k ds <- res_dmd -- and the demand looks inside its fields + | isDataConId var -- Data constructor = let StrictSig dmd_ty = idNewStrictness var -- It must have a strictness sig DmdType _ _ con_res = dmd_ty @@ -670,23 +675,23 @@ dmdTransform sigs var dmd in if arity == call_depth then -- Saturated, so unleash the demand let - -- ds can be empty, when we are just seq'ing the thing - -- If so we must make up a suitable bunch of demands - dmd_ds | null ds = replicate arity Abs - | otherwise = ASSERT( ds `lengthIs` arity ) ds - - arg_ds = case k of - Keep -> bothLazy_s dmd_ds - Drop -> dmd_ds - Defer -> pprTrace "dmdTransform: surprising!" (ppr var) - -- I don't think this can happen - dmd_ds -- Important! If we Keep the constructor application, then -- we need the demands the constructor places (always lazy) -- If not, we don't need to. For example: -- f p@(x,y) = (p,y) -- S(AL) -- g a b = f (a,b) -- It's vital that we don't calculate Absent for a! + dmd_ds = case res_dmd of + Box (Eval ds) -> mapDmds box ds + Eval ds -> ds + other -> Poly Top + + -- ds can be empty, when we are just seq'ing the thing + -- If so we must make up a suitable bunch of demands + arg_ds = case dmd_ds of + Poly d -> replicate arity d + Prod ds -> ASSERT( ds `lengthIs` arity ) ds + in mkDmdType emptyDmdEnv arg_ds con_res -- Must remember whether it's a product, hence con_res, not TopRes @@ -695,7 +700,7 @@ dmdTransform sigs var dmd ------ IMPORTED FUNCTION | isGlobalId var, -- Imported function - let StrictSig dmd_ty = getNewStrictness var + let StrictSig dmd_ty = idNewStrictness var = if dmdTypeDepth dmd_ty <= call_depth then -- Saturated, so unleash the demand dmd_ty else @@ -735,7 +740,7 @@ splitCallDmd (Call d) = case splitCallDmd d of splitCallDmd d = (0, d) vanillaCall :: Arity -> Demand -vanillaCall 0 = Eval +vanillaCall 0 = evalDmd vanillaCall n = Call (vanillaCall (n-1)) deferType :: DmdType -> DmdType @@ -748,34 +753,18 @@ deferType (DmdType fv _ _) = DmdType (deferEnv fv) [] TopRes deferEnv :: DmdEnv -> DmdEnv deferEnv fv = mapVarEnv defer fv ---------------- -bothLazy :: Demand -> Demand -bothLazy = both Lazy -bothLazy_s :: [Demand] -> [Demand] -bothLazy_s = map bothLazy - ---------------- -argDemand :: Id -> Demand -> Demand -argDemand id dmd | isUnLiftedType (idType id) = unliftedArgDemand dmd - | otherwise = liftedArgDemand dmd - -liftedArgDemand :: Demand -> Demand +argDemand :: Demand -> Demand -- The 'Defer' demands are just Lazy at function boundaries -- Ugly! Ask John how to improve it. -liftedArgDemand (Seq Defer ds) = Lazy -liftedArgDemand (Seq k ds) = Seq k (map liftedArgDemand ds) - -- Urk! Don't have type info here -liftedArgDemand Err = Eval -- Args passed to a bottoming function -liftedArgDemand Bot = Abs -- Don't pass args that are consumed by bottom/err -liftedArgDemand d = d - -unliftedArgDemand :: Demand -> Demand --- Same idea, but for unlifted types the domain is much simpler: --- Either we use it (Lazy) or we don't (Abs) -unliftedArgDemand Bot = Abs -unliftedArgDemand Abs = Abs -unliftedArgDemand other = Lazy +argDemand Top = lazyDmd +argDemand (Defer d) = lazyDmd +argDemand (Eval ds) = Eval (mapDmds argDemand ds) +argDemand (Box Bot) = evalDmd +argDemand (Box d) = box (argDemand d) +argDemand Bot = Abs -- Don't pass args that are consumed by bottom/err +argDemand d = d \end{code} \begin{code} @@ -787,8 +776,6 @@ 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} @@ -798,13 +785,19 @@ squashDmdEnv (StrictSig (DmdType fv ds res)) = StrictSig (DmdType emptyDmdEnv ds -- *implicitly* has {y->A}. So we must put {y->(V `lub` A)} -- in the result env. lubType (DmdType fv1 ds1 r1) (DmdType fv2 ds2 r2) - = DmdType lub_fv2 (zipWith lub ds1 ds2) (r1 `lubRes` r2) + = DmdType lub_fv2 (lub_ds ds1 ds2) (r1 `lubRes` r2) where lub_fv = plusUFM_C lub fv1 fv2 - lub_fv1 = modifyEnv (not (isBotRes r1)) defer fv2 fv1 lub_fv - lub_fv2 = modifyEnv (not (isBotRes r2)) defer fv1 fv2 lub_fv1 + lub_fv1 = modifyEnv (not (isBotRes r1)) absLub fv2 fv1 lub_fv + lub_fv2 = modifyEnv (not (isBotRes r2)) absLub fv1 fv2 lub_fv1 -- lub is the identity for Bot + -- Extend the shorter argument list to match the longer + lub_ds (d1:ds1) (d2:ds2) = lub d1 d2 : lub_ds ds1 ds2 + lub_ds [] [] = [] + lub_ds ds1 [] = map (`lub` resTypeArgDmd r2) ds1 + lub_ds [] ds2 = map (resTypeArgDmd r1 `lub`) ds2 + ----------------------------------- -- (t1 `bothType` t2) takes the argument/result info from t1, -- using t2 just for its free-var info @@ -834,19 +827,6 @@ bothRes r1 r2 = r1 \end{code} \begin{code} --- A Seq can have an empty list of demands, in the polymorphic case. -lubs [] ds2 = ds2 -lubs ds1 [] = ds1 -lubs ds1 ds2 = ASSERT( equalLength ds1 ds2 ) zipWith lub ds1 ds2 - ------------------------------------ --- A Seq can have an empty list of demands, in the polymorphic case. -boths [] ds2 = ds2 -boths ds1 [] = ds1 -boths ds1 ds2 = ASSERT( equalLength ds1 ds2 ) zipWith both ds1 ds2 -\end{code} - -\begin{code} modifyEnv :: Bool -- No-op if False -> (Demand -> Demand) -- The zapper -> DmdEnv -> DmdEnv -- Env1 and Env2 @@ -870,144 +850,144 @@ modifyEnv need_to_modify zapper env1 env2 env %* * %************************************************************************ - \begin{code} lub :: Demand -> Demand -> Demand -lub Bot d = d - -lub Err Bot = Err -lub Err Abs = Lazy -- E.g. f x = if ... then True else error x -lub Err (Seq k ds) - | null ds = Seq (case k of { Drop -> Keep; other -> k }) [] - -- Yuk - | not (null ds) = Seq k [Err `lub` d | d <- ds] - -- E.g. f x = if ... then fst x else error x - -- We *cannot* use the (lub Err d = d) case, - -- else we'd get U(VA) for x's demand!! -lub Err d = d - -lub Lazy d = Lazy - -lub Abs d = defer d - -lub Eval Abs = Lazy -lub Eval Lazy = Lazy -lub Eval (Seq Defer ds) = Lazy -- Essential! -lub Eval (Seq Drop ds) | not (null ds) = Seq Drop [Lazy | d <- ds] -lub Eval d = Eval - -- For the Seq Drop case, consider - -- f n [] = n - -- f n (x:xs) = f (n+x) xs - -- Here we want to do better than just V for n. It's - -- unboxed in the (x:xs) case, and we might be prepared to - -- rebox it in the [] case. - -- But if we don't use *any* of the components, give up - -- and revert to V - -lub (Call d1) (Call d2) = Call (lub d1 d2) -lub d1@(Call _) d2 = d2 `lub` d1 - -lub (Seq k1 ds1) (Seq k2 ds2) - = Seq (k1 `lub_keep` k2) (lub_ds k1 ds1 k2 ds2) - where - ------------------ - lub_ds Keep ds1 Keep ds2 = ds1 `lubs` ds2 - lub_ds Keep ds1 non_keep ds2 | null ds1 = [Lazy | d <- ds2] - | otherwise = bothLazy_s ds1 `lubs` ds2 - - lub_ds non_keep ds1 Keep ds2 | null ds2 = [Lazy | d <- ds1] - | otherwise = ds1 `lubs` bothLazy_s ds2 - - lub_ds k1 ds1 k2 ds2 = ds1 `lubs` ds2 - - ------------------ - -- Note that (Keep `lub` Drop) is Drop, not Keep - -- Why not? See the example above with (lub Eval d). - lub_keep Keep k = k - - lub_keep Drop Defer = Defer - lub_keep Drop k = Drop - - lub_keep Defer k = Defer - -lub d1@(Seq _ _) d2 = d2 `lub` d1 - +lub Bot d2 = d2 +lub Abs d2 = absLub d2 +lub Top d2 = Top +lub (Defer ds1) d2 = defer (Eval ds1 `lub` d2) + +lub (Call d1) (Call d2) = Call (d1 `lub` d2) +lub d1@(Call _) (Box d2) = d1 `lub` d2 -- Just strip the box +lub d1@(Call _) d2@(Eval _) = d2 -- Presumably seq or vanilla eval +lub d1@(Call _) d2 = d2 `lub` d1 -- Bot, Abs, Top + +-- For the Eval case, we use these approximation rules +-- Box Bot <= Eval (Box Bot ...) +-- Box Top <= Defer (Box Bot ...) +-- Box (Eval ds) <= Eval (map Box ds) +lub (Eval ds1) (Eval ds2) = Eval (ds1 `lubs` ds2) +lub (Eval ds1) (Box Bot) = Eval (mapDmds (`lub` Box Bot) ds1) +lub (Eval ds1) (Box (Eval ds2)) = Eval (ds1 `lubs` mapDmds box ds2) +lub (Eval ds1) (Box Abs) = deferEval (mapDmds (`lub` Box Bot) ds1) +lub d1@(Eval _) d2 = d2 `lub` d1 -- Bot,Abs,Top,Call,Defer + +lub (Box d1) (Box d2) = box (d1 `lub` d2) +lub d1@(Box _) d2 = d2 `lub` d1 + +lubs = zipWithDmds lub + +--------------------- +-- box is the smart constructor for Box +-- It computes & d +-- INVARIANT: (Box d) => d = Bot, Abs, Eval +-- Seems to be no point in allowing (Box (Call d)) +box (Call d) = Call d -- The odd man out. Why? +box (Box d) = Box d +box (Defer _) = lazyDmd +box Top = lazyDmd -- Box Abs and Box Top +box Abs = lazyDmd -- are the same +box d = Box d -- Bot, Eval +--------------- defer :: Demand -> Demand + +-- defer is the smart constructor for Defer +-- The idea is that (Defer ds) = +-- +-- It specifies what happens at a lazy function argument +-- or a lambda; the L* operator +-- Set the strictness part to L, but leave +-- the boxity side unaffected +-- It also ensures that Defer (Eval [LLLL]) = L + +defer Bot = Abs +defer Abs = Abs +defer Top = Top +defer (Call _) = lazyDmd -- Approximation here? +defer (Box _) = lazyDmd +defer (Defer ds) = Defer ds +defer (Eval ds) = deferEval ds + +-- deferEval ds = defer (Eval ds) +deferEval ds | allTop ds = Top + | otherwise = Defer ds + +--------------------- +absLub :: Demand -> Demand -- Computes (Abs `lub` d) -- For the Bot case consider -- f x y = if ... then x else error x -- Then for y we get Abs `lub` Bot, and we really -- want Abs overall -defer Bot = Abs -defer Abs = Abs -defer (Seq Keep ds) = Lazy -defer (Seq _ ds) = Seq Defer ds -defer d = Lazy +absLub Bot = Abs +absLub Abs = Abs +absLub Top = Top +absLub (Call _) = Top +absLub (Box _) = Top +absLub (Eval ds) = Defer (absLubs ds) -- Or (Defer ds)? +absLub (Defer ds) = Defer (absLubs ds) -- Or (Defer ds)? + +absLubs = mapDmds absLub --------------- both :: Demand -> Demand -> Demand -both Bot Bot = Bot -both Bot Abs = Bot -both Bot (Seq k ds) - | not (null ds) = Seq (case k of { Defer -> Drop; other -> k }) - [both Bot d | d <- ds] - -- E.g. f x = if ... then error (fst x) else fst x - -- This equation helps results slightly, - -- but is not necessary for soundness -both Bot d = Err - -both Err d = Err - -both Abs d = d - -both Lazy Bot = Err -both Lazy Err = Err -both Lazy Eval = Eval -both Lazy (Call d) = Call d -both Lazy (Seq Defer ds) = Lazy -both Lazy (Seq k ds) = Seq Keep ds -both Lazy d = Lazy - --- For the (Eval `both` Bot) case, consider --- f x = error x --- From 'error' itself we get demand Bot on x --- From the arg demand on x we get Eval --- So we want Eval `both` Bot to be Err. --- That's what Err is *for* -both Eval Bot = Err -both Eval Err = Err -both Eval (Seq k ds) = Seq Keep ds -both Eval d = Eval - -both (Call d1) (Call d2) = Call (d1 `both` d2) -both d1@(Call _) d2 = d2 `both` d1 - -both (Seq k1 ds1) (Seq k2 ds2) - = Seq (k1 `both_keep` k2) (both_ds k1 ds1 k2 ds2) - where - ---------------- - both_keep Keep k2 = Keep - - both_keep Drop Keep = Keep - both_keep Drop k2 = Drop - - both_keep Defer k2 = k2 - - ---------------- - both_ds Defer ds1 Defer ds2 = ds1 `boths` ds2 - both_ds Defer ds1 non_defer ds2 = map defer ds1 `boths` ds2 - - both_ds non_defer ds1 Defer ds2 = ds1 `boths` map defer ds2 - - both_ds k1 ds1 k2 ds2 = ds1 `boths` ds2 - -both d1@(Seq _ _) d2 = d2 `both` d1 +both Abs d2 = d2 + +both Bot Bot = Bot +both Bot Abs = Bot +both Bot (Eval ds) = Eval (mapDmds (`both` Bot) ds) + -- Consider + -- f x = error x + -- From 'error' itself we get demand Bot on x + -- From the arg demand on x we get + -- x :-> evalDmd = Box (Eval (Poly Abs)) + -- So we get Bot `both` Box (Eval (Poly Abs)) + -- = Seq Keep (Poly Bot) + -- + -- Consider also + -- f x = if ... then error (fst x) else fst x + -- Then we get (Eval (Box Bot, Bot) `lub` Eval (SA)) + -- = Eval (SA) + -- which is what we want. +both Bot d = errDmd + +both Top Bot = errDmd +both Top Abs = Top +both Top Top = Top +both Top (Box d) = Box d +both Top (Call d) = Call d +both Top (Eval ds) = Eval (mapDmds (`both` Top) ds) +both Top (Defer ds) -- = defer (Top `both` Eval ds) + -- = defer (Eval (mapDmds (`both` Top) ds)) + = deferEval (mapDmds (`both` Top) ds) + + +both (Box d1) (Box d2) = box (d1 `both` d2) +both (Box d1) d2@(Call _) = box (d1 `both` d2) +both (Box d1) d2@(Eval _) = box (d1 `both` d2) +both (Box d1) (Defer d2) = Box d1 +both d1@(Box _) d2 = d2 `both` d1 + +both (Call d1) (Call d2) = Call (d1 `both` d2) +both (Call d1) (Eval ds2) = Call d1 -- Could do better for (Poly Bot)? +both (Call d1) (Defer ds2) = Call d1 -- Ditto +both d1@(Call _) d2 = d1 `both` d1 + +both (Eval ds1) (Eval ds2) = Eval (ds1 `boths` ds2) +both (Eval ds1) (Defer ds2) = Eval (ds1 `boths` mapDmds defer ds2) +both d1@(Eval ds1) d2 = d2 `both` d1 + +both (Defer ds1) (Defer ds2) = deferEval (ds1 `boths` ds2) +both d1@(Defer ds1) d2 = d2 `both` d1 + +boths = zipWithDmds both \end{code} + %************************************************************************ %* * \subsection{Miscellaneous @@ -1047,8 +1027,9 @@ get_changes_str id where message word = text word <+> text "strictness for" <+> ppr id <+> info info = (text "Old" <+> ppr old) $$ (text "New" <+> ppr new) - new = squashDmdEnv (idNewStrictness id) -- Don't report diffs in the env - old = newStrictnessFromOld id + new = squashSig (idNewStrictness id) -- Don't report spurious diffs that the old + -- strictness analyser can't track + old = newStrictnessFromOld (idName id) (idArity id) (idStrictness id) (idCprInfo id) old_better = old `betterStrictness` new new_better = new `betterStrictness` old @@ -1061,8 +1042,20 @@ get_changes_dmd id where message word = text word <+> text "demand for" <+> ppr id <+> info info = (text "Old" <+> ppr old) $$ (text "New" <+> ppr new) - new = liftedArgDemand (idNewDemandInfo id) -- To avoid spurious improvements + new = squashDmd (argDemand (idNewDemandInfo id)) -- To avoid spurious improvements + -- A bit of a hack old = newDemand (idDemandInfo id) new_better = new `betterDemand` old old_better = old `betterDemand` new + +squashSig (StrictSig (DmdType fv ds res)) + = StrictSig (DmdType emptyDmdEnv (map squashDmd ds) res) + where + -- squash just gets rid of call demands + -- which the old analyser doesn't track +squashDmd (Call d) = evalDmd +squashDmd (Box d) = Box (squashDmd d) +squashDmd (Eval ds) = Eval (mapDmds squashDmd ds) +squashDmd (Defer ds) = Defer (mapDmds squashDmd ds) +squashDmd d = d \end{code} diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs index 03f4e56..ff17184 100644 --- a/ghc/compiler/stranal/WorkWrap.lhs +++ b/ghc/compiler/stranal/WorkWrap.lhs @@ -20,8 +20,8 @@ import Type ( Type ) import IdInfo ( WorkerInfo(..), arityInfo, newDemandInfo, newStrictnessInfo, unfoldingInfo, inlinePragInfo ) -import NewDemand ( Demand(..), StrictSig(..), DmdType(..), DmdResult(..), Keepity(..), - mkTopDmdType, isBotRes, returnsCPR, topSig +import NewDemand ( Demand(..), StrictSig(..), DmdType(..), DmdResult(..), + Demands(..), mkTopDmdType, isBotRes, returnsCPR, topSig, isAbsent ) import UniqSupply ( UniqSupply, initUs_, returnUs, thenUs, mapUs, getUniqueUs, UniqSM ) import BasicTypes ( RecFlag(..), isNonRec, Activation(..) ) @@ -343,9 +343,9 @@ worthSplittingFun ds res -- [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 + worth_it Abs = True -- Absent arg + worth_it (Eval (Prod ds)) = True -- Product arg to evaluate + worth_it other = False worthSplittingThunk :: Demand -- Demand on the thunk -> DmdResult -- CPR info for the thunk @@ -354,12 +354,8 @@ worthSplittingThunk dmd res = worth_it dmd || returnsCPR res where -- Split if the thing is unpacked - worth_it (Seq Defer ds) = False - worth_it (Seq _ ds) = any not_abs ds - worth_it other = False - - not_abs Abs = False - not_abs other = True + worth_it (Eval (Prod ds)) = not (all isAbsent ds) + worth_it other = False \end{code} diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs index e74de63..2d60dd2 100644 --- a/ghc/compiler/stranal/WwLib.lhs +++ b/ghc/compiler/stranal/WwLib.lhs @@ -16,7 +16,7 @@ import Id ( Id, idType, mkSysLocal, idNewDemandInfo, setIdNewDemandInfo, ) import IdInfo ( vanillaIdInfo ) import DataCon ( splitProductType_maybe, splitProductType ) -import NewDemand ( Demand(..), Keepity(..), DmdResult(..) ) +import NewDemand ( Demand(..), DmdResult(..), Demands(..) ) import DmdAnal ( both ) import MkId ( realWorldPrimId, voidArgId, eRROR_CSTRING_ID ) import TysPrim ( realWorldStatePrimTy ) @@ -315,6 +315,12 @@ mkWWstr (arg : args) ---------------------- +-- mkWWstr_one wrap_arg = (work_args, wrap_fn, work_fn) +-- * wrap_fn assumes wrap_arg is in scope, +-- brings into scope work_args (via cases) +-- * work_fn assumes work_args are in scope, a +-- brings into scope wrap_arg (via lets) + mkWWstr_one arg | isTyVar arg = returnUs ([arg], nop_fn, nop_fn) @@ -328,8 +334,25 @@ mkWWstr_one arg Abs | not (isUnLiftedType (idType arg)) -> returnUs ([], nop_fn, mk_absent_let arg) - -- Seq and keep - Seq _ [] + -- Unpack case + Eval (Prod 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 "mkWWstr" set_worker_arg_info unpk_args cs + unbox_fn = mk_unpk_case arg unpk_args data_con arg_tycon + rebox_fn = Let (NonRec arg con_app) + con_app = mkConApp data_con (map Type tycon_arg_tys ++ map Var unpk_args) + in + mkWWstr unpk_args_w_ds `thenUs` \ (worker_args, wrap_fn, work_fn) -> + returnUs (worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) + -- Don't pass the arg, rebox instead + + -- `seq` demand; evaluate in wrapper in the hope + -- of dropping seqs in the worker + Eval (Poly Abs) -> let arg_w_unf = arg `setIdUnfolding` mkOtherCon [] -- Tell the worker arg that it's sure to be evaluated @@ -346,50 +369,9 @@ mkWWstr_one arg -- fw y = let x{Evald} = error "oops" in (x `seq` y) -- If we don't pin on the "Evald" flag, the seq doesn't disappear, and -- we end up evaluating the absent thunk. - -- But the Evald flag is pretty wierd, and I worry that it might disappear + -- But the Evald flag is pretty weird, and I worry that it might disappear -- during simplification, so for now I've just nuked this whole case - -- Unpack case - 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 "mkWWstr" set_worker_arg_info unpk_args cs' - unbox_fn = mk_unpk_case arg unpk_args data_con arg_tycon - rebox_fn = Let (NonRec arg con_app) - con_app = mkConApp data_con (map Type tycon_arg_tys ++ map Var unpk_args) - - cs' = case keep of - Keep -> map (DmdAnal.both Lazy) cs -- Careful! Now we don't pass - -- the box, we must pass all the - -- components. In effect - -- S(LA) --> U(LL) - Drop -> cs - Defer -> pprTrace "wwlib" (ppr arg) cs - in - mkWWstr unpk_args_w_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 --- I used to be clever here, but consider --- f n [] = n --- f n (x:xs) = f (n+x) xs --- Here n gets (Seq Keep [L]), but it's BAD BAD BAD to pass both n and n# --- Needs more thought, but the simple thing to do is to accept the reboxing --- stuff if there are any non-absent arguments (and that case is dealt with above): - - returnUs (worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) - -- Don't pass the arg, rebox instead - - | otherwise -> - WARN( True, ppr arg ) - returnUs ([arg], nop_fn, nop_fn) - -- Other cases other_demand -> returnUs ([arg], nop_fn, nop_fn) diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index b559686..ebfd83f 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -104,7 +104,7 @@ tcIdInfo unf_env in_scope_vars name ty info_ins returnTc info2 tcPrag info (HsStrictness strict_info) - = returnTc (info `setNewStrictnessInfo` Just strict_info) + = returnTc (info `setAllStrictnessInfo` Just strict_info) tcPrag info (HsWorker nm arity) = tcWorkerInfo unf_env ty info nm arity