[Git][ghc/ghc][wip/refactor-demand] It bootstraps
Sebastian Graf
gitlab at gitlab.haskell.org
Thu Oct 29 13:40:17 UTC 2020
Sebastian Graf pushed to branch wip/refactor-demand at Glasgow Haskell Compiler / GHC
Commits:
7f20604e by Sebastian Graf at 2020-10-29T14:40:09+01:00
It bootstraps
- - - - -
4 changed files:
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs
- compiler/GHC/Types/Demand.hs
- compiler/GHC/Types/Id/Make.hs
Changes:
=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -44,6 +44,8 @@ import GHC.Builtin.PrimOps
import GHC.Builtin.Types.Prim ( realWorldStatePrimTy )
import GHC.Types.Unique.Set
+-- import GHC.Driver.Ppr
+
{-
************************************************************************
* *
@@ -435,7 +437,7 @@ worker, so the worker will rebuild
x = (a, absent-error)
and that'll crash.
-Note [Aggregated demand for cardinality]
+Note [Aggregated demand for cardinality] -- TODO: This Note should be named [LetUp vs. LetDown] and probably predates said separation
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We use different strategies for strictness and usage/cardinality to
"unleash" demands captured on free variables by bindings. Let us
@@ -498,7 +500,8 @@ dmdTransform env var dmd
-- Used to be controlled by a flag.
-- See #18429 for some perf measurements.
| Just _ <- isClassOpId_maybe var
- = dmdTransformDictSelSig (idStrictness var) dmd
+ = -- pprTrace "dmdTransform:DictSel" (ppr var $$ ppr dmd) $
+ dmdTransformDictSelSig (idStrictness var) dmd
-- Imported functions
| isGlobalId var
, let res = dmdTransformSig (idStrictness var) dmd
@@ -511,14 +514,14 @@ dmdTransform env var dmd
= -- pprTrace "dmdTransform:LetDown" (vcat [ppr var, ppr sig, ppr dmd, ppr fn_ty]) $
if isTopLevel top_lvl
then fn_ty -- Don't record demand on top-level things
- else addVarDmd fn_ty var (mkOnceUsedDmd dmd)
+ else addVarDmd fn_ty var (C_11 :* dmd)
-- Everything else:
-- * Local let binders for which we use LetUp (cf. 'useLetUp')
-- * Lambda binders
-- * Case and constructor field binders
| otherwise
= -- pprTrace "dmdTransform:other" (vcat [ppr var, ppr sig, ppr dmd, ppr res]) $
- unitDmdType (unitVarEnv var (mkOnceUsedDmd dmd))
+ unitDmdType (unitVarEnv var (C_11 :* dmd))
{- *********************************************************************
* *
@@ -566,6 +569,16 @@ dmdAnalRhsLetDown rec_flag env let_dmd id rhs
sig = mkStrictSigForArity rhs_arity (DmdType sig_fv rhs_dmds rhs_div)
-- See Note [Aggregated demand for cardinality]
+ -- TODO: That Note doesn't explain the following lines at all. The reason
+ -- is really much different: When we have a recursive function, we'd
+ -- have to also consider the free vars of the strictness signature
+ -- when checking whether we found a fixed-point. That is expensive; we
+ -- only want to check whether argument demands of the sig changed.
+ -- reuseEnv makes it so that the FV results are stable as long as the
+ -- last argument demands were. Strictness won't change. But used-once
+ -- might turn into used-many even if the signature was stable and we'd
+ -- have to do an additional iteration. reuseEnv makes sure that we
+ -- never get used-once info for FVs of recursive fucntions.
rhs_fv1 = case rec_flag of
Just bs -> reuseEnv (delVarEnvList rhs_fv bs)
Nothing -> rhs_fv
=====================================
compiler/GHC/Core/Opt/WorkWrap/Utils.hs
=====================================
@@ -607,18 +607,25 @@ mkWWstr_one dflags fam_envs has_inlineable_prag arg
dmd = idDemandInfo arg
wantToUnbox :: FamInstEnvs -> Bool -> Type -> Demand -> Maybe ([Demand], DataConAppContext)
-wantToUnbox fam_envs has_inlineable_prag ty dmd@(_ :* cd) =
+wantToUnbox fam_envs has_inlineable_prag ty dmd =
case deepSplitProductType_maybe fam_envs ty of
Just dcac at DataConAppContext{ dcac_arg_tys = con_arg_tys }
| isStrictDmd dmd
-- See Note [Unpacking arguments with product and polymorphic demands]
- , Just cs <- viewProd (length con_arg_tys) cd
+ , Just cs <- split_prod_dmd_arity dmd (length con_arg_tys)
-- See Note [Do not unpack class dictionaries]
, not (has_inlineable_prag && isClassPred ty)
-- See Note [mkWWstr and unsafeCoerce]
, cs `equalLength` con_arg_tys
-> Just (cs, dcac)
_ -> Nothing
+ where
+ split_prod_dmd_arity dmd arty
+ -- For seqDmd, it should behave like <S(AAAA)>, for some
+ -- suitable arity
+ | isSeqDmd dmd = Just (replicate arty absDmd)
+ | _ :* Prod ds <- dmd = Just ds
+ | otherwise = Nothing
unbox_one :: DynFlags -> FamInstEnvs -> Var
-> [Demand]
=====================================
compiler/GHC/Types/Demand.hs
=====================================
@@ -12,8 +12,8 @@
-}
module GHC.Types.Demand (
- Card, Demand(..), CleanDemand(Prod), viewProd,
- mkOnceUsedDmd, mkManyUsedDmd, oneifyDmd, oneifyCard,
+ Card(..), Demand(..), CleanDemand(Prod), viewProd,
+ oneifyDmd, oneifyCard,
absDmd, topDmd, botDmd, seqDmd,
lubCard, lubDmd, lubCleanDmd,
plusCard, plusDmd, plusCleanDmd,
@@ -319,13 +319,9 @@ f g = (snd (g 3), True)
should be: <L,C(U(AU))>m
-}
-mkOnceUsedDmd, mkManyUsedDmd :: CleanDemand -> Demand
-mkOnceUsedDmd cd = C_11 :* cd
-mkManyUsedDmd cd = C_1N :* cd
-
+-- | Evaluated strictly, and used arbitrarily deeply
evalDmd :: Demand
--- Evaluated strictly, and used arbitrarily deeply
-evalDmd = C_1N :* topCleanDmd
+evalDmd = C_1N :* cleanEvalDmd
-- | Wraps the 'CleanDemand' with a one-shot call demand: @d@ -> @C1(d)@.
mkCallDmd :: CleanDemand -> CleanDemand
@@ -360,17 +356,21 @@ data Card
| C_01 -- ^ {0,1}
| C_0N -- ^ {0,1,n} Every possible cardinality; the top element.
| C_11 -- ^ {1,1}
- | C_1N -- ^ {1,n}
+ | C_1N -- ^ {1,n} TODO: Think about whether this cardinality is of any
+ -- practical relevance. If we are strict, we can
+ -- assume that it is used at most once because of
+ -- call-by-value. Ah yes, it's relevant for call
+ -- demands.
| C_10 -- ^ {} The empty interval; the bottom element of the powerset lattice.
deriving ( Eq )
instance Show Card where
- show C_00 = "0"
- show C_01 = "01"
- show C_0N = "_"
- show C_11 = "1"
- show C_1N = "1_"
- show C_10 = "⊥"
+ show C_00 = "A"
+ show C_01 = "1"
+ show C_0N = "U"
+ show C_11 = "S"
+ show C_1N = "S"
+ show C_10 = "B"
_botCard, topCard :: Card
_botCard = C_10
@@ -464,17 +464,6 @@ multCard _ _ = C_0N
data Demand = !Card :* !CleanDemand
deriving ( Eq, Show )
-instance Outputable Card where
- ppr = text . show
-
-instance Outputable Demand where
- ppr (n :* cd) = ppr n <> char '*' <> ppr cd
-
-instance Outputable CleanDemand where
- ppr (Poly cd) = ppr cd
- ppr (Call n cd) = char 'C' <> ppr n <> parens (ppr cd)
- ppr (Prod ds) = parens (interpp'SP (map ppr ds))
-
data CleanDemand
= Poly !Card -- ^ Polymorphic head demand with nested evaluation
-- cardinalities.
@@ -1041,7 +1030,7 @@ plusDmdType (DmdType fv1 ds1 r1) (fv2, t2)
instance Outputable DmdType where
ppr (DmdType fv ds res)
- = hsep [hcat (map ppr ds) <> ppr res,
+ = hsep [hcat (map (angleBrackets . ppr) ds) <> ppr res,
if null fv_elts then empty
else braces (fsep (map pp_elt fv_elts))]
where
@@ -1157,7 +1146,7 @@ multDmdEnv n env
-- | See Note [Scaling demands]
reuseEnv :: DmdEnv -> DmdEnv
-reuseEnv = mapVarEnv (multDmd C_1N)
+reuseEnv = multDmdEnv C_1N
-- | The trivial cases of the @mult*@ functions.
-- If @multTrivial n abs a = ma@, we have the following outcomes
@@ -1527,17 +1516,20 @@ dmdTransformDictSelSig :: StrictSig -> CleanDemand -> DmdType
-- for dictionary selectors. If the selector is saturated (ie has one
-- argument: the dictionary), we feed the demand on the result into
-- the indicated dictionary component.
-dmdTransformDictSelSig (StrictSig (DmdType _ [_ :* Prod ds] _)) cd
- | (n, cd') <- peelCallDmd cd
+-- NB: This currently doesn't handle newtype dictionaries and it's unclear how
+-- it could without additional parameters.
+dmdTransformDictSelSig (StrictSig (DmdType _ [(_ :* sig_cd)] _)) call_cd
+ | (n, cd') <- peelCallDmd call_cd
+ , Prod sig_ds <- sig_cd
= multUnsat n $
- DmdType emptyDmdEnv [mkOnceUsedDmd $ Prod $ map (enhance cd') ds] topDiv
+ DmdType emptyDmdEnv [C_11 :* Prod (map (enhance cd') sig_ds)] topDiv
| otherwise
= nopDmdType -- See Note [Demand transformer for a dictionary selector]
where
enhance cd old | isAbsDmd old = old
- | otherwise = mkOnceUsedDmd cd -- This is the one!
+ | otherwise = C_11 :* cd -- This is the one!
-dmdTransformDictSelSig _ _ = panic "dmdTransformDictSelSig: no args"
+dmdTransformDictSelSig sig cd = pprPanic "dmdTransformDictSelSig: no args" (ppr sig $$ ppr cd)
{-
Note [Demand transformer for a dictionary selector]
@@ -1718,8 +1710,27 @@ the demand signature, because we still want to know about the demand on things.
The signature of f should be <S(SL),1*U(1*U(U),A)><S,1*U>m. If we were not
distinguishing the uses on x and y in the True case, we could either not figure
out how deeply we can unpack x, or that we do not have to pass y.
+-}
+instance Outputable Card where
+ ppr = text . show
+instance Outputable Demand where
+ ppr dmd@(n :* cd)
+ | isAbs n = ppr n
+ | dmd == polyDmd n = ppr n
+ | otherwise = ppr n <> ppr cd
+
+instance Outputable CleanDemand where
+ ppr (Poly cd) = ppr cd
+ ppr (Call n cd) = char 'C' <> ppr n <> parens (ppr cd)
+ ppr (Prod ds) = parens (fields ds)
+ where
+ fields [] = empty
+ fields [x] = ppr x
+ fields (x:xs) = ppr x <> char ',' <> fields xs
+
+{-
************************************************************************
* *
Serialisation
@@ -1762,29 +1773,22 @@ instance Binary CleanDemand where
_ -> pprPanic "Binary:CleanDemand" (ppr (fromIntegral h :: Int))
instance Binary StrictSig where
- put_ bh (StrictSig aa) = do
- put_ bh aa
- get bh = do
- aa <- get bh
- return (StrictSig aa)
+ put_ bh (StrictSig aa) = put_ bh aa
+ get bh = StrictSig <$> get bh
instance Binary DmdType where
-- Ignore DmdEnv when spitting out the DmdType
- put_ bh (DmdType _ ds dr)
- = do put_ bh ds
- put_ bh dr
- get bh
- = do ds <- get bh
- dr <- get bh
- return (DmdType emptyDmdEnv ds dr)
+ put_ bh (DmdType _ ds dr) = put_ bh ds *> put_ bh dr
+ get bh = DmdType emptyDmdEnv <$> get bh <*> get bh
instance Binary Divergence where
put_ bh Dunno = putByte bh 0
put_ bh ExnOrDiv = putByte bh 1
put_ bh Diverges = putByte bh 2
-
- get bh = do { h <- getByte bh
- ; case h of
- 0 -> return Dunno
- 1 -> return ExnOrDiv
- _ -> return Diverges }
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> return Dunno
+ 1 -> return ExnOrDiv
+ 2 -> return Diverges
+ _ -> pprPanic "Binary:Divergence" (ppr (fromIntegral h :: Int))
=====================================
compiler/GHC/Types/Id/Make.hs
=====================================
@@ -513,7 +513,7 @@ mkDictSelId name clas
strict_sig = mkClosedStrictSig [arg_dmd] topDiv
arg_dmd | new_tycon = evalDmd
- | otherwise = mkManyUsedDmd $
+ | otherwise = C_1N :*
Prod [ if name == sel_name then evalDmd else absDmd
| sel_name <- sel_names ]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7f20604ea6ea134eb6298529ff61cd539865877e
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7f20604ea6ea134eb6298529ff61cd539865877e
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20201029/fb9ba9b5/attachment-0001.html>
More information about the ghc-commits
mailing list