[Git][ghc/ghc][wip/nested-cpr-2019] stuff
Sebastian Graf
gitlab at gitlab.haskell.org
Wed Apr 22 20:18:24 UTC 2020
Sebastian Graf pushed to branch wip/nested-cpr-2019 at Glasgow Haskell Compiler / GHC
Commits:
fdaaeee5 by Sebastian Graf at 2020-04-22T22:18:18+02:00
stuff
- - - - -
4 changed files:
- compiler/GHC/Core/Op/CprAnal.hs
- compiler/GHC/Core/Op/WorkWrap/Lib.hs
- compiler/GHC/Types/Cpr.hs
- compiler/GHC/Types/Id/Make.hs
Changes:
=====================================
compiler/GHC/Core/Op/CprAnal.hs
=====================================
@@ -138,12 +138,12 @@ cprAnal, cprAnal'
-> CoreExpr -- ^ expression to be denoted by a 'CprType'
-> (CprType, CoreExpr) -- ^ the updated expression and its 'CprType'
-cprAnal env args e = -- pprTraceWith "cprAnal" (\res -> ppr (fst (res)) $$ ppr e) $
+cprAnal env args e = pprTraceWith "cprAnal" (\res -> ppr (fst (res)) $$ ppr e) $
cprAnal' env args e
-cprAnal' _ _ (Lit lit) = (topCprType, Lit lit)
-cprAnal' _ _ (Type ty) = (topCprType, Type ty) -- Doesn't happen, in fact
-cprAnal' _ _ (Coercion co) = (topCprType, Coercion co)
+cprAnal' _ _ (Lit lit) = (whnfTermCprType, Lit lit)
+cprAnal' _ _ (Type ty) = (whnfTermCprType, Type ty) -- Doesn't happen, in fact
+cprAnal' _ _ (Coercion co) = (whnfTermCprType, Coercion co)
cprAnal' env args (Var var) = (cprTransform env args var, Var var)
=====================================
compiler/GHC/Core/Op/WorkWrap/Lib.hs
=====================================
@@ -1081,25 +1081,25 @@ mkWWcpr_one_layer fam_envs body_ty cpr = runMaybeT $ do
uniq1:arg_uniqs <- lift getUniquesM
let arg_vars = zipWith mk_ww_local arg_uniqs arg_tys
- maybe_arg_stuff <- lift $ zipWithM (mkWWcpr_one_layer fam_envs)
- (map fst arg_tys)
- arg_cprs
+ maybe_arg_builders <- lift $ zipWithM (mkWWcpr_one_layer fam_envs)
+ (map fst arg_tys)
+ arg_cprs
- let go_arg_stuff var mb_stuff =
- case mb_stuff of
+ let go_arg_stuff var mb_builder =
+ case mb_builder of
Nothing ->
-- this argument does not need to be deconstructed further
([var], varToCoreExpr var, id)
Just (inner_vars, arg_con, arg_decon) ->
(inner_vars, arg_con, arg_decon (varToCoreExpr var))
- let (inner_arg_varss, arg_cons, arg_decons) = unzip3 $ zipWith go_arg_stuff arg_vars maybe_arg_stuff
+ let (inner_arg_varss, arg_cons, arg_decons) = unzip3 $ zipWith go_arg_stuff arg_vars maybe_arg_builders
inner_arg_vars = concat inner_arg_varss
inner_decon = foldl' (.) id arg_decons
-- Don't try to WW an unboxed tuple return type when there's nothing inside
-- to unbox further.
- guard (not (isUnboxedTupleCon data_con && all isNothing maybe_arg_stuff))
+ guard (not (isUnboxedTupleCon data_con && all isNothing maybe_arg_builders))
return ( inner_arg_vars
, mkConApp data_con (map Type inst_tys ++ arg_cons) `mkCast` mkSymCo co
=====================================
compiler/GHC/Types/Cpr.hs
=====================================
@@ -4,13 +4,14 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
+{-# LANGUAGE PatternSynonyms #-}
-- | Types for the Constructed Product Result lattice. "GHC.Core.Op.CprAnal"
-- and "GHC.Core.Op.WorkWrap.Lib" are its primary customers via 'idCprInfo'.
module GHC.Types.Cpr (
TerminationFlag (Terminates),
- Cpr, topCpr, botCpr, conCpr, initRecFunCpr, lubCpr, asConCpr,
- CprType (..), topCprType, botCprType, lubCprType, conCprType,
+ Cpr, topCpr, botCpr, conCpr, whnfTermCpr, initRecFunCpr, lubCpr, asConCpr,
+ CprType (..), topCprType, botCprType, whnfTermCprType, conCprType, lubCprType,
pruneDeepCpr, markConCprType, splitConCprTy, applyCprTy, abstractCprTy,
abstractCprTyNTimes, ensureCprTyArity, trimCprTy,
forceCprTy, forceCpr, bothCprType,
@@ -99,15 +100,11 @@ lubTermFlag _ MightDiverge = MightDiverge
lubTermFlag Terminates Terminates = Terminates
data Termination
- = Term !TerminationFlag !(Levitated (KnownShape Termination))
+ = Term_ !TerminationFlag !(Levitated (KnownShape Termination))
+ -- Don't use 'Term_', use 'Term' instead! Otherwise the derived Eq instance
+ -- is broken.
deriving Eq
-botTerm :: Termination
-botTerm = Term Terminates Bot
-
-topTerm :: Termination
-topTerm = Term MightDiverge Top
-
-- | Normalise the nested termination info according to
-- > Top === Levitate (Con t [topTerm..])
-- > Bot === Levitate (Con t [botTerm..])
@@ -118,14 +115,27 @@ normTermShape (Levitate (Con _ fields))
| all (== botTerm) fields = Bot
normTermShape l_sh = l_sh
+pattern Term :: TerminationFlag -> Levitated (KnownShape Termination) -> Termination
+pattern Term tf l <- (Term_ tf l)
+ where
+ Term tf l = Term_ tf (normTermShape l)
+
+{-# COMPLETE Term #-}
+
+botTerm :: Termination
+botTerm = Term Terminates Bot
+
+topTerm :: Termination
+topTerm = Term MightDiverge Top
+
lubTerm :: Termination -> Termination -> Termination
lubTerm (Term tf1 l_sh1) (Term tf2 l_sh2)
= Term (lubTermFlag tf1 tf2)
- (normTermShape (lubLevitated (lubKnownShape lubTerm) l_sh1 l_sh2))
+ (lubLevitated (lubKnownShape lubTerm) l_sh1 l_sh2)
pruneDeepTerm :: Int -> Termination -> Termination
pruneDeepTerm depth (Term tf (Levitate sh))
- = Term tf (normTermShape (pruneKnownShape pruneDeepTerm depth sh))
+ = Term tf (pruneKnownShape pruneDeepTerm depth sh)
pruneDeepTerm _ term = term
seqTerm :: Termination -> ()
@@ -163,15 +173,27 @@ seqTerm (Term _ l) = seqLevitated (seqKnownShape seqTerm) l
data Cpr
= Cpr !TerminationFlag !(Levitated (KnownShape Cpr))
- | NoMoreCpr !Termination
+ | NoMoreCpr_ !Termination
deriving Eq
+pattern NoMoreCpr :: Termination -> Cpr
+pattern NoMoreCpr t <- (NoMoreCpr_ t)
+ where
+ NoMoreCpr (Term MightDiverge Top) = topCpr
+ NoMoreCpr (Term Terminates Bot) = botCpr
+ NoMoreCpr t = NoMoreCpr_ t
+
+{-# COMPLETE Cpr, NoMoreCpr #-}
+
botCpr :: Cpr
botCpr = Cpr Terminates Bot
topCpr :: Cpr
topCpr = Cpr MightDiverge Top
+whnfTermCpr :: Cpr
+whnfTermCpr = Cpr Terminates Top
+
-- | The initial termination of a recursive function in fixed-point iteration.
-- We assume a recursive call 'MightDiverge', but are optimistic about all
-- CPR and nested termination information. I.e., we assume that evaluating
@@ -245,6 +267,9 @@ topCprType = CprType 0 topCpr
botCprType :: CprType
botCprType = CprType 0 botCpr
+whnfTermCprType :: CprType
+whnfTermCprType = CprType 0 whnfTermCpr
+
lubCprType :: CprType -> CprType -> CprType
lubCprType ty1@(CprType n1 cpr1) ty2@(CprType n2 cpr2)
| ct_cpr ty1 == botCpr && n1 <= n2 = ty2
@@ -506,6 +531,9 @@ type UnboxingStrategy = Type -> Demand -> Maybe (DataCon, [Type], [Demand])
-- - A call demand @C(S)@ would translate to @strTop -> #(#,*)@
argCprTypesFromStrictSig :: UnboxingStrategy -> [Type] -> StrictSig -> [CprType]
argCprTypesFromStrictSig want_to_unbox arg_tys sig
+ -- TODO: Maybe look at unliftedness from the unboxing strategy, just in case
+ -- we e.g. fail to mark an Int# argument as Terminates, which should always be
+ -- the case as per the let/app invariant.
= zipWith go arg_tys (argDmdsFromStrictSig sig)
where
go arg_ty arg_dmd
@@ -539,8 +567,11 @@ instance Outputable Termination where
Levitate shape -> ppr shape
instance Outputable Cpr where
- ppr (NoMoreCpr t) = ppr t
- ppr (Cpr tf l) = ppr tf <> case l of
+ ppr (NoMoreCpr t) = ppr t
+ -- I like it better without the special case
+ -- ppr (Cpr MightDiverge Top) = empty
+ -- ppr (Cpr Terminates Bot) = char 'b'
+ ppr (Cpr tf l) = ppr tf <> case l of
Top -> empty
Bot -> char 'b'
Levitate shape -> char 'c' <> ppr shape
=====================================
compiler/GHC/Types/Id/Make.hs
=====================================
@@ -1178,8 +1178,8 @@ mkPrimOpId prim_op
id = mkGlobalId (PrimOpId prim_op) name ty info
-- PrimOps don't ever construct a product, but we want to preserve bottoms
- cpr | isBotDiv (snd (splitStrictSig strict_sig)) = botCpr
- | otherwise = topCpr
+ cpr | isBotDiv (snd (splitStrictSig strict_sig)) = initRecFunCpr
+ | otherwise = whnfTermCpr
info = noCafIdInfo
`setRuleInfo` mkRuleInfo (maybeToList $ primOpRules name prim_op)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fdaaeee50f83688932aff91997b92d02408ae498
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fdaaeee50f83688932aff91997b92d02408ae498
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/20200422/6547718d/attachment-0001.html>
More information about the ghc-commits
mailing list