[Git][ghc/ghc][wip/T22404] Define JoinPointHood and use it
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Fri Jul 28 16:52:33 UTC 2023
Simon Peyton Jones pushed to branch wip/T22404 at Glasgow Haskell Compiler / GHC
Commits:
68e92a9a by Simon Peyton Jones at 2023-07-28T17:51:50+01:00
Define JoinPointHood and use it
- - - - -
26 changed files:
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Opt/CSE.hs
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Opt/Exitify.hs
- compiler/GHC/Core/Opt/FloatIn.hs
- compiler/GHC/Core/Opt/FloatOut.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/SetLevels.hs
- compiler/GHC/Core/Opt/Simplify/Env.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/SpecConstr.hs
- compiler/GHC/Core/Opt/WorkWrap.hs
- compiler/GHC/Core/Ppr.hs
- compiler/GHC/Core/Rules.hs
- compiler/GHC/Core/SimpleOpt.hs
- compiler/GHC/Core/Tidy.hs
- compiler/GHC/Core/Unfold.hs
- compiler/GHC/CoreToIface.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Stg/Lint.hs
- compiler/GHC/Types/Basic.hs
- compiler/GHC/Types/Id.hs
- compiler/GHC/Utils/Binary.hs
- compiler/GHC/Utils/Outputable.hs
Changes:
=====================================
compiler/GHC/Core/Lint.hs
=====================================
@@ -604,10 +604,10 @@ lintLetBind top_lvl rec_flag binder rhs rhs_ty
-- Check that a join-point binder has a valid type
-- NB: lintIdBinder has checked that it is not top-level bound
- ; case isJoinId_maybe binder of
- Nothing -> return ()
- Just arity -> checkL (isValidJoinPointType arity binder_ty)
- (mkInvalidJoinPointMsg binder binder_ty)
+ ; case idJoinPointHood binder of
+ NotJoinPoint -> return ()
+ JoinPoint arity -> checkL (isValidJoinPointType arity binder_ty)
+ (mkInvalidJoinPointMsg binder binder_ty)
; when (lf_check_inline_loop_breakers flags
&& isStableUnfolding (realIdUnfolding binder)
@@ -662,7 +662,7 @@ lintRhs :: Id -> CoreExpr -> LintM (LintedType, UsageEnv)
-- NB: the Id can be Linted or not -- it's only used for
-- its OccInfo and join-pointer-hood
lintRhs bndr rhs
- | Just arity <- isJoinId_maybe bndr
+ | JoinPoint arity <- idJoinPointHood bndr
= lintJoinLams arity (Just bndr) rhs
| AlwaysTailCalled arity <- tailCallInfo (idOccInfo bndr)
= lintJoinLams arity Nothing rhs
@@ -1085,7 +1085,7 @@ lintJoinBndrType :: LintedType -- Type of the body
-- E.g. join j x = rhs in body
-- The type of 'rhs' must be the same as the type of 'body'
lintJoinBndrType body_ty bndr
- | Just arity <- isJoinId_maybe bndr
+ | JoinPoint arity <- idJoinPointHood bndr
, let bndr_ty = idType bndr
, (bndrs, res) <- splitPiTys bndr_ty
= checkL (length bndrs >= arity
@@ -1101,15 +1101,14 @@ checkJoinOcc :: Id -> JoinArity -> LintM ()
-- Check that if the occurrence is a JoinId, then so is the
-- binding site, and it's a valid join Id
checkJoinOcc var n_args
- | Just join_arity_occ <- isJoinId_maybe var
+ | JoinPoint join_arity_occ <- idJoinPointHood var
= do { mb_join_arity_bndr <- lookupJoinId var
; case mb_join_arity_bndr of {
- Nothing -> -- Binder is not a join point
- do { join_set <- getValidJoins
- ; addErrL (text "join set " <+> ppr join_set $$
- invalidJoinOcc var) } ;
+ NotJoinPoint -> do { join_set <- getValidJoins
+ ; addErrL (text "join set " <+> ppr join_set $$
+ invalidJoinOcc var) } ;
- Just join_arity_bndr ->
+ JoinPoint join_arity_bndr ->
do { checkL (join_arity_bndr == join_arity_occ) $
-- Arity differs at binding site and occurrence
@@ -2109,8 +2108,8 @@ lintCoreRule fun fun_ty rule@(Rule { ru_name = name, ru_bndrs = bndrs
, ru_args = args, ru_rhs = rhs })
= lintBinders LambdaBind bndrs $ \ _ ->
do { (lhs_ty, _) <- lintCoreArgs (fun_ty, zeroUE) args
- ; (rhs_ty, _) <- case isJoinId_maybe fun of
- Just join_arity
+ ; (rhs_ty, _) <- case idJoinPointHood fun of
+ JoinPoint join_arity
-> do { checkL (args `lengthIs` join_arity) $
mkBadJoinPointRuleMsg fun join_arity rule
-- See Note [Rules for join points]
@@ -3373,14 +3372,14 @@ lookupIdInScope id_occ
-- wired-in Ids after worker/wrapper
-- So we simply disable the test in this case
-lookupJoinId :: Id -> LintM (Maybe JoinArity)
+lookupJoinId :: Id -> LintM JoinPointHood
-- Look up an Id which should be a join point, valid here
-- If so, return its arity, if not return Nothing
lookupJoinId id
= do { join_set <- getValidJoins
; case lookupVarSet join_set id of
- Just id' -> return (isJoinId_maybe id')
- Nothing -> return Nothing }
+ Just id' -> return (idJoinPointHood id')
+ Nothing -> return NotJoinPoint }
addAliasUE :: Id -> UsageEnv -> LintM a -> LintM a
addAliasUE id ue thing_inside = LintM $ \ env errs ->
=====================================
compiler/GHC/Core/Opt/CSE.hs
=====================================
@@ -14,7 +14,7 @@ import GHC.Types.Var.Env ( mkInScopeSet )
import GHC.Types.Id ( Id, idType, idHasRules, zapStableUnfolding
, idInlineActivation, setInlineActivation
, zapIdOccInfo, zapIdUsageInfo, idInlinePragma
- , isJoinId, isJoinId_maybe, idUnfolding )
+ , isJoinId, idJoinPointHood, idUnfolding )
import GHC.Core.Utils ( mkAltExpr
, exprIsTickedString
, stripTicksE, stripTicksT, mkTicks )
@@ -436,7 +436,7 @@ cse_bind toplevel env_rhs env_body (in_id, in_rhs) out_id
-- See Note [Take care with literal strings]
= (env_body', (out_id', in_rhs))
- | Just arity <- isJoinId_maybe out_id
+ | JoinPoint arity <- idJoinPointHood out_id
-- See Note [Look inside join-point binders]
= let (params, in_body) = collectNBinders arity in_rhs
(env', params') = addBinders env_rhs params
=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -1130,9 +1130,9 @@ splitWeakDmds (DE fvs div) = (DE sig_fvs div, weak_fvs)
thresholdArity :: Id -> CoreExpr -> Arity
-- See Note [Demand signatures are computed for a threshold arity based on idArity]
thresholdArity fn rhs
- = case isJoinId_maybe fn of
- Just join_arity -> count isId $ fst $ collectNBinders join_arity rhs
- Nothing -> idArity fn
+ = case idJoinPointHood fn of
+ JoinPoint join_arity -> count isId $ fst $ collectNBinders join_arity rhs
+ NotJoinPoint -> idArity fn
-- | The result type after applying 'idArity' many arguments. Returns 'Nothing'
-- when the type doesn't have exactly 'idArity' many arrows.
=====================================
compiler/GHC/Core/Opt/Exitify.hs
=====================================
@@ -36,20 +36,24 @@ Now `t` is no longer in a recursive function, and good things happen!
-}
import GHC.Prelude
+import GHC.Builtin.Uniques
+import GHC.Core
+import GHC.Core.Utils
+import GHC.Core.FVs
+import GHC.Core.Type
+
import GHC.Types.Var
import GHC.Types.Id
import GHC.Types.Id.Info
-import GHC.Core
-import GHC.Core.Utils
-import GHC.Utils.Monad.State.Strict
-import GHC.Builtin.Uniques
import GHC.Types.Var.Set
import GHC.Types.Var.Env
-import GHC.Core.FVs
-import GHC.Data.FastString
-import GHC.Core.Type
+import GHC.Types.Basic( JoinPointHood(..) )
+
+import GHC.Utils.Monad.State.Strict
import GHC.Utils.Misc( mapSnd )
+import GHC.Data.FastString
+
import Data.Bifunctor
import Control.Monad
@@ -160,7 +164,7 @@ exitifyRec in_scope pairs
go captured (_, AnnLet ann_bind body)
-- join point, RHS and body are in tail-call position
| AnnNonRec j rhs <- ann_bind
- , Just join_arity <- isJoinId_maybe j
+ , JoinPoint join_arity <- idJoinPointHood j
= do let (params, join_body) = collectNAnnBndrs join_arity rhs
join_body' <- go (captured ++ params) join_body
let rhs' = mkLams params join_body'
=====================================
compiler/GHC/Core/Opt/FloatIn.hs
=====================================
@@ -29,7 +29,7 @@ import GHC.Core.FVs
import GHC.Core.Type
import GHC.Types.Basic ( RecFlag(..), isRec )
-import GHC.Types.Id ( idType, isJoinId, isJoinId_maybe )
+import GHC.Types.Id ( idType, isJoinId, idJoinPointHood )
import GHC.Types.Tickish
import GHC.Types.Var
import GHC.Types.Var.Set
@@ -599,7 +599,7 @@ fiBind platform to_drop (AnnRec bindings) body_fvs
------------------
fiRhs :: Platform -> RevFloatInBinds -> CoreBndr -> CoreExprWithFVs -> CoreExpr
fiRhs platform to_drop bndr rhs
- | Just join_arity <- isJoinId_maybe bndr
+ | JoinPoint join_arity <- idJoinPointHood bndr
, let (bndrs, body) = collectNAnnBndrs join_arity rhs
= mkLams bndrs (fiExpr platform to_drop body)
| otherwise
=====================================
compiler/GHC/Core/Opt/FloatOut.hs
=====================================
@@ -22,7 +22,7 @@ import GHC.Driver.Flags ( DumpFlag (..) )
import GHC.Utils.Logger
import GHC.Types.Id ( Id, idType,
-- idArity, isDeadEndId,
- isJoinId, isJoinId_maybe )
+ isJoinId, idJoinPointHood )
import GHC.Types.Tickish
import GHC.Core.Opt.SetLevels
import GHC.Types.Unique.Supply ( UniqSupply )
@@ -487,7 +487,7 @@ floatRhs :: CoreBndr
-> LevelledExpr
-> (FloatStats, FloatBinds, CoreExpr)
floatRhs bndr rhs
- | Just join_arity <- isJoinId_maybe bndr
+ | JoinPoint join_arity <- idJoinPointHood bndr
, Just (bndrs, body) <- try_collect join_arity rhs []
= case bndrs of
[] -> floatExpr rhs
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -42,7 +42,7 @@ import GHC.Core.Predicate ( isDictId )
import GHC.Core.Type
import GHC.Core.TyCo.FVs ( tyCoVarsOfMCo )
-import GHC.Data.Maybe( isJust, orElse )
+import GHC.Data.Maybe( orElse )
import GHC.Data.Graph.Directed ( SCC(..), Node(..)
, stronglyConnCompFromEdgedVerticesUniq
, stronglyConnCompFromEdgedVerticesUniqR )
@@ -982,7 +982,7 @@ occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine
-- /Existing/ non-recursive join points
-- See Note [Occurrence analysis for join points]
- | mb_join@(Just {}) <- isJoinId_maybe bndr
+ | mb_join@(JoinPoint {}) <- idJoinPointHood bndr
= -- Analyse the RHS and /then/ the body
let -- Analyse the rhs first, generating rhs_uds
!(rhs_uds_s, bndr', rhs') = occAnalNonRecRhs env ire mb_join bndr rhs
@@ -997,7 +997,7 @@ occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine
if isDeadOcc occ -- Drop dead code; see Note [Dead code]
then WUD body_uds body
else WUD (rhs_uds `orUDs` body_uds) -- Note `orUDs`
- (combine [NonRec (tagNonRecBinder lvl occ bndr') rhs']
+ (combine [NonRec (fst (tagNonRecBinder lvl occ bndr')) rhs']
body)
-- The normal case, including newly-discovered join points
@@ -1009,10 +1009,7 @@ occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine
-- Get the join info from the *new* decision; NB: bndr is not already a JoinId
-- See Note [Join points and unfoldings/rules]
-- => join arity O of Note [Join arity prediction based on joinRhsArity]
- tagged_bndr = tagNonRecBinder lvl occ bndr
- mb_join = case tailCallInfo occ of
- AlwaysTailCalled arity -> Just arity
- _ -> Nothing
+ (tagged_bndr, mb_join) = tagNonRecBinder lvl occ bndr
!(rhs_uds_s, final_bndr, rhs') = occAnalNonRecRhs env ire mb_join tagged_bndr rhs
in WUD (foldr andUDs body_uds rhs_uds_s) -- Note `andUDs`
@@ -1029,7 +1026,7 @@ occAnalNonRecBody env bndr thing_inside
in WUD inner_uds (occ, res)
-----------------
-occAnalNonRecRhs :: OccEnv -> ImpRuleEdges -> Maybe JoinArity
+occAnalNonRecRhs :: OccEnv -> ImpRuleEdges -> JoinPointHood
-> Id -> CoreExpr
-> ([UsageDetails], Id, CoreExpr)
occAnalNonRecRhs !env imp_rule_edges mb_join bndr rhs
@@ -1040,7 +1037,7 @@ occAnalNonRecRhs !env imp_rule_edges mb_join bndr rhs
| otherwise
= (adj_rhs_uds : adj_unf_uds : adj_rule_uds, final_bndr_with_rules, final_rhs )
where
- is_join_point = isJust mb_join
+ is_join_point = isJoinPoint mb_join
--------- Right hand side ---------
-- For join points, set occ_encl to OccVanilla, via setTailCtxt. If we have
@@ -1147,10 +1144,9 @@ occAnalRec !_ lvl
| isDeadOcc occ -- Check for dead code: see Note [Dead code]
= WUD body_uds binds
| otherwise
- = let tagged_bndr = tagNonRecBinder lvl occ bndr
- mb_join_arity = willBeJoinId_maybe tagged_bndr
- !(WUD rhs_uds' rhs') = adjustNonRecRhs mb_join_arity wtuds
- !unf' = markNonRecUnfoldingOneShots mb_join_arity (idUnfolding tagged_bndr)
+ = let (tagged_bndr, mb_join) = tagNonRecBinder lvl occ bndr
+ !(WUD rhs_uds' rhs') = adjustNonRecRhs mb_join wtuds
+ !unf' = markNonRecUnfoldingOneShots mb_join (idUnfolding tagged_bndr)
!bndr' = tagged_bndr `setIdUnfolding` unf'
in WUD (body_uds `andUDs` rhs_uds')
(NonRec bndr' rhs' : binds)
@@ -1768,7 +1764,7 @@ makeNode !env imp_rule_edges bndr_set (bndr, rhs)
unf = realIdUnfolding bndr -- realIdUnfolding: Ignore loop-breaker-ness
-- here because that is what we are setting!
WTUD unf_tuds unf' = occAnalUnfolding rhs_env unf
- adj_unf_uds = adjustTailArity (Just rhs_ja) unf_tuds
+ adj_unf_uds = adjustTailArity (JoinPoint rhs_ja) unf_tuds
-- `rhs_ja` is `joinRhsArity rhs` and is the prediction for source M
-- of Note [Join arity prediction based on joinRhsArity]
@@ -1783,7 +1779,7 @@ makeNode !env imp_rule_edges bndr_set (bndr, rhs)
-- `rhs_ja` is `joinRhsArity rhs'` and is the prediction for source M
-- of Note [Join arity prediction based on joinRhsArity]
rules_w_uds :: [(CoreRule, UsageDetails, UsageDetails)]
- rules_w_uds = [ (r,l,adjustTailArity (Just rhs_ja) rhs_wuds)
+ rules_w_uds = [ (r,l,adjustTailArity (JoinPoint rhs_ja) rhs_wuds)
| rule <- idCoreRules bndr
, let (r,l,rhs_wuds) = occAnalRule rhs_env rule ]
rules' = map fstOf3 rules_w_uds
@@ -2537,7 +2533,7 @@ occAnal env app@(App _ _)
= occAnalApp env (collectArgsTicks tickishFloatable app)
occAnal env expr@(Lam {})
- = adjustNonRecRhs Nothing $ -- Nothing <=> markAllManyNonTail
+ = adjustNonRecRhs NotJoinPoint $ -- NotJoinPoint <=> markAllManyNonTail
occAnalLamTail env expr
occAnal env (Case scrut bndr ty alts)
@@ -2630,7 +2626,7 @@ occAnalApp !env (Var fun, args, ticks)
-- This caused #18296
| fun `hasKey` runRWKey
, [t1, t2, arg] <- args
- , WUD usage arg' <- adjustNonRecRhs (Just 1) $ occAnalLamTail env arg
+ , WUD usage arg' <- adjustNonRecRhs (JoinPoint 1) $ occAnalLamTail env arg
= WUD usage (mkTicks ticks $ mkApps (Var fun) [t1, t2, arg'])
occAnalApp env (Var fun_id, args, ticks)
@@ -3704,7 +3700,7 @@ lookupOccInfoByUnique (UD { ud_env = env
-------------------
-- See Note [Adjusting right-hand sides]
-adjustNonRecRhs :: Maybe JoinArity
+adjustNonRecRhs :: JoinPointHood
-> WithTailUsageDetails CoreExpr
-> WithUsageDetails CoreExpr
-- ^ This function concentrates shared logic between occAnalNonRecBind and the
@@ -3715,13 +3711,13 @@ adjustNonRecRhs mb_join_arity rhs_wuds@(WTUD _ rhs)
= WUD rhs_uds' rhs'
where
--------- Marking (non-rec) join binders one-shot ---------
- !rhs' | Just ja <- mb_join_arity = markNonRecJoinOneShots ja rhs
- | otherwise = rhs
+ !rhs' | JoinPoint ja <- mb_join_arity = markNonRecJoinOneShots ja rhs
+ | otherwise = rhs
--------- Adjusting right-hand side usage ---------
rhs_uds' = adjustTailUsage mb_join_arity rhs_wuds
-adjustTailUsage :: Maybe JoinArity
+adjustTailUsage :: JoinPointHood
-> WithTailUsageDetails CoreExpr -- Rhs usage, AFTER occAnalLamTail
-> UsageDetails
adjustTailUsage mb_join_arity (WTUD (TUD rhs_ja uds) rhs)
@@ -3731,11 +3727,11 @@ adjustTailUsage mb_join_arity (WTUD (TUD rhs_ja uds) rhs)
uds
where
one_shot = isOneShotFun rhs
- exact_join = mb_join_arity == Just rhs_ja
+ exact_join = mb_join_arity == JoinPoint rhs_ja
-adjustTailArity :: Maybe JoinArity -> TailUsageDetails -> UsageDetails
+adjustTailArity :: JoinPointHood -> TailUsageDetails -> UsageDetails
adjustTailArity mb_rhs_ja (TUD ja usage)
- = markAllNonTailIf (mb_rhs_ja /= Just ja) usage
+ = markAllNonTailIf (mb_rhs_ja /= JoinPoint ja) usage
markNonRecJoinOneShots :: JoinArity -> CoreExpr -> CoreExpr
-- For a /non-recursive/ join point we can mark all
@@ -3753,10 +3749,10 @@ markNonRecJoinOneShots join_arity rhs
-- enough lambdas /yet/. (Lint checks that JoinIds do
-- have enough lambdas.)
-markNonRecUnfoldingOneShots :: Maybe JoinArity -> Unfolding -> Unfolding
+markNonRecUnfoldingOneShots :: JoinPointHood -> Unfolding -> Unfolding
-- ^ Apply 'markNonRecJoinOneShots' to a stable unfolding
markNonRecUnfoldingOneShots mb_join_arity unf
- | Just ja <- mb_join_arity
+ | JoinPoint ja <- mb_join_arity
, CoreUnfolding{uf_src=src,uf_tmpl=tmpl} <- unf
, isStableSource src
, let !tmpl' = markNonRecJoinOneShots ja tmpl
@@ -3787,17 +3783,18 @@ tagLamBinder usage bndr
tagNonRecBinder :: TopLevelFlag -- At top level?
-> OccInfo -- Of scope
-> CoreBndr -- Binder
- -> IdWithOccInfo -- Tagged binder
+ -> (IdWithOccInfo, JoinPointHood) -- Tagged binder
-- No-op on TyVars
-- Precondition: OccInfo is not IAmDead
tagNonRecBinder lvl occ bndr
- = setBinderOcc occ' bndr
+ | okForJoinPoint lvl bndr tail_call_info
+ , AlwaysTailCalled ar <- tail_call_info
+ = (setBinderOcc occ bndr, JoinPoint ar)
+ | otherwise
+ = (setBinderOcc zapped_occ bndr, NotJoinPoint)
where
- will_be_join = okForJoinPoint lvl bndr (tailCallInfo occ)
- occ' | will_be_join = -- Must already be marked AlwaysTailCalled, unless
- -- it was a join point before but is now dead
- warnPprTrace (not (isAlwaysTailCalled occ)) "tagNonRecBinder" (ppr bndr <+> ppr occ) occ
- | otherwise = markNonTail occ
+ tail_call_info = tailCallInfo occ
+ zapped_occ = markNonTail occ
tagRecBinders :: TopLevelFlag -- At top level?
-> UsageDetails -- Of body of let ONLY
@@ -3817,11 +3814,11 @@ tagRecBinders lvl body_uds details_s
-- This (re-)asserts that makeNode had made tuds for that same arity M!
unadj_uds = foldr (andUDs . test_manifest_arity) body_uds details_s
test_manifest_arity ND{nd_rhs = WTUD tuds rhs}
- = adjustTailArity (Just (joinRhsArity rhs)) tuds
+ = adjustTailArity (JoinPoint (joinRhsArity rhs)) tuds
will_be_joins = decideRecJoinPointHood lvl unadj_uds bndrs
- mb_join_arity :: Id -> Maybe JoinArity
+ mb_join_arity :: Id -> JoinPointHood
-- mb_join_arity: See Note [Join arity prediction based on joinRhsArity]
-- This is the source O
mb_join_arity bndr
@@ -3829,10 +3826,10 @@ tagRecBinders lvl body_uds details_s
-- the binder yet (the tag depends on these adjustments!)
| will_be_joins
, AlwaysTailCalled arity <- lookupTailCallInfo unadj_uds bndr
- = Just arity
+ = JoinPoint arity
| otherwise
= assert (not will_be_joins) -- Should be AlwaysTailCalled if
- Nothing -- we are making join points!
+ NotJoinPoint -- we are making join points!
-- 2. Adjust usage details of each RHS, taking into account the
-- join-point-hood decision
@@ -3903,7 +3900,7 @@ okForJoinPoint lvl bndr tail_call_info
| otherwise
= False
- lost_join | Just ja <- isJoinId_maybe bndr
+ lost_join | JoinPoint ja <- idJoinPointHood bndr
= not valid_join ||
(case tail_call_info of -- Valid join but arity differs
AlwaysTailCalled ja' -> ja /= ja'
@@ -3934,15 +3931,6 @@ okForJoinPoint lvl bndr tail_call_info
, text "ok_type:" <+> ppr (isValidJoinPointType arity (idType bndr)) ]
_ -> empty ]
-willBeJoinId_maybe :: CoreBndr -> Maybe JoinArity
-willBeJoinId_maybe bndr
- | isId bndr
- , AlwaysTailCalled arity <- tailCallInfo (idOccInfo bndr)
- = Just arity
- | otherwise
- = isJoinId_maybe bndr
-
-
{- Note [Join points and INLINE pragmas]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
=====================================
compiler/GHC/Core/Opt/SetLevels.hs
=====================================
@@ -322,7 +322,7 @@ lvl_top :: LevelEnv -> RecFlag -> Id -> CoreExpr
-- there is no need call substAndLvlBndrs here
lvl_top env is_rec bndr rhs
= do { rhs' <- lvlRhs env is_rec (isDeadEndId bndr)
- Nothing -- Not a join point
+ NotJoinPoint
(freeVars rhs)
; return (stayPut tOP_LEVEL bndr, rhs') }
@@ -666,9 +666,9 @@ lvlMFE env strict_ctxt ann_expr
-- No wrapping needed if the type is lifted, or is a literal string
-- or if we are wrapping it in one or more value lambdas
= do { expr1 <- lvlFloatRhs abs_vars dest_lvl rhs_env NonRecursive
- is_bot_lam join_arity_maybe ann_expr
+ is_bot_lam NotJoinPoint ann_expr
-- Treat the expr just like a right-hand side
- ; var <- newLvlVar expr1 join_arity_maybe is_mk_static
+ ; var <- newLvlVar expr1 NotJoinPoint is_mk_static
; let var2 = annotateBotStr var float_n_lams mb_bot_str
; return (Let (NonRec (TB var2 (FloatMe dest_lvl)) expr1)
(mkVarApps (Var var2) abs_vars)) }
@@ -689,7 +689,7 @@ lvlMFE env strict_ctxt ann_expr
Case expr1 (stayPut l1r ubx_bndr) box_ty
[Alt DEFAULT [] (App boxing_expr (Var ubx_bndr))]
- ; var <- newLvlVar float_rhs Nothing is_mk_static
+ ; var <- newLvlVar float_rhs NotJoinPoint is_mk_static
; let l1u = incMinorLvlFrom env
use_expr = Case (mkVarApps (Var var) abs_vars)
(stayPut l1u bx_bndr) expr_ty
@@ -726,8 +726,6 @@ lvlMFE env strict_ctxt ann_expr
(rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars
- join_arity_maybe = Nothing
-
is_mk_static = isJust (collectMakeStaticArgs expr)
-- Yuk: See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable
@@ -1177,8 +1175,8 @@ lvlBind env (AnnNonRec bndr rhs)
-- NB: not isBottomThunk! See Note [Bottoming floats] point (3)
n_extra = count isId abs_vars
- mb_join_arity = isJoinId_maybe bndr
- is_join = isJust mb_join_arity
+ mb_join_arity = idJoinPointHood bndr
+ is_join = isJoinPoint mb_join_arity
lvlBind env (AnnRec pairs)
| floatTopLvlOnly env && not (isTopLvl dest_lvl)
@@ -1193,7 +1191,7 @@ lvlBind env (AnnRec pairs)
= -- No float
do { let bind_lvl = incMinorLvl (le_ctxt_lvl env)
(env', bndrs') = substAndLvlBndrs Recursive env bind_lvl bndrs
- lvl_rhs (b,r) = lvlRhs env' Recursive is_bot (isJoinId_maybe b) r
+ lvl_rhs (b,r) = lvlRhs env' Recursive is_bot (idJoinPointHood b) r
; rhss' <- mapM lvl_rhs pairs
; return (Rec (bndrs' `zip` rhss'), env') }
@@ -1256,8 +1254,8 @@ lvlBind env (AnnRec pairs)
is_bot (get_join bndr)
rhs
- get_join bndr | need_zap = Nothing
- | otherwise = isJoinId_maybe bndr
+ get_join bndr | need_zap = NotJoinPoint
+ | otherwise = idJoinPointHood bndr
need_zap = dest_lvl `ltLvl` joinCeilingLevel env
-- Finding the free vars of the binding group is annoying
@@ -1284,7 +1282,7 @@ profitableFloat env dest_lvl
lvlRhs :: LevelEnv
-> RecFlag
-> Bool -- Is this a bottoming function
- -> Maybe JoinArity
+ -> JoinPointHood
-> CoreExprWithFVs
-> LvlM LevelledExpr
lvlRhs env rec_flag is_bot mb_join_arity expr
@@ -1293,7 +1291,7 @@ lvlRhs env rec_flag is_bot mb_join_arity expr
lvlFloatRhs :: [OutVar] -> Level -> LevelEnv -> RecFlag
-> Bool -- Binding is for a bottoming function
- -> Maybe JoinArity
+ -> JoinPointHood
-> CoreExprWithFVs
-> LvlM (Expr LevelledBndr)
-- Ignores the le_ctxt_lvl in env; treats dest_lvl as the baseline
@@ -1304,13 +1302,13 @@ lvlFloatRhs abs_vars dest_lvl env rec is_bot mb_join_arity rhs
else lvlExpr body_env body
; return (mkLams bndrs' body') }
where
- (bndrs, body) | Just join_arity <- mb_join_arity
+ (bndrs, body) | JoinPoint join_arity <- mb_join_arity
= collectNAnnBndrs join_arity rhs
| otherwise
= collectAnnBndrs rhs
(env1, bndrs1) = substBndrsSL NonRecursive env bndrs
all_bndrs = abs_vars ++ bndrs1
- (body_env, bndrs') | Just _ <- mb_join_arity
+ (body_env, bndrs') | JoinPoint {} <- mb_join_arity
= lvlJoinBndrs env1 dest_lvl rec all_bndrs
| otherwise
= case lvlLamBndrs env1 dest_lvl all_bndrs of
@@ -1741,14 +1739,14 @@ newPolyBndrs dest_lvl
-- but we may need to adjust its arity
dest_is_top = isTopLvl dest_lvl
transfer_join_info bndr new_bndr
- | Just join_arity <- isJoinId_maybe bndr
+ | JoinPoint join_arity <- idJoinPointHood bndr
, not dest_is_top
= new_bndr `asJoinId` join_arity + length abs_vars
| otherwise
= new_bndr
newLvlVar :: LevelledExpr -- The RHS of the new binding
- -> Maybe JoinArity -- Its join arity, if it is a join point
+ -> JoinPointHood -- Its join arity, if it is a join point
-> Bool -- True <=> the RHS looks like (makeStatic ...)
-> LvlM Id
newLvlVar lvld_rhs join_arity_maybe is_mk_static
=====================================
compiler/GHC/Core/Opt/Simplify/Env.hs
=====================================
@@ -373,7 +373,7 @@ type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr
-- | A substitution result.
data SimplSR
- = DoneEx OutExpr (Maybe JoinArity)
+ = DoneEx OutExpr JoinPointHood
-- If x :-> DoneEx e ja is in the SimplIdSubst
-- then replace occurrences of x by e
-- and ja = Just a <=> x is a join-point of arity a
@@ -398,8 +398,8 @@ instance Outputable SimplSR where
ppr (DoneEx e mj) = text "DoneEx" <> pp_mj <+> ppr e
where
pp_mj = case mj of
- Nothing -> empty
- Just n -> parens (int n)
+ NotJoinPoint -> empty
+ JoinPoint n -> parens (int n)
ppr (ContEx _tv _cv _id e) = vcat [text "ContEx" <+> ppr e {-,
ppr (filter_env tv), ppr (filter_env id) -}]
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -425,7 +425,7 @@ simplAuxBind env bndr new_rhs
= return ( emptyFloats env
, case new_rhs of
Coercion co -> extendCvSubst env bndr co
- _ -> extendIdSubst env bndr (DoneEx new_rhs Nothing) )
+ _ -> extendIdSubst env bndr (DoneEx new_rhs NotJoinPoint) )
| otherwise
= do { -- ANF-ise the RHS
@@ -625,7 +625,7 @@ tryCastWorkerWrapper env bind_cxt old_bndr occ_info bndr (Cast rhs co)
then do { tick (PostInlineUnconditionally bndr)
; return ( floats
, extendIdSubst (setInScopeFromF env floats) old_bndr $
- DoneEx triv_rhs Nothing ) }
+ DoneEx triv_rhs NotJoinPoint ) }
else do { wrap_unf <- mkLetUnfolding uf_opts top_lvl VanillaSrc bndr triv_rhs
; let bndr' = bndr `setInlinePragma` mkCastWrapperInlinePrag (idInlinePragma bndr)
@@ -961,7 +961,7 @@ completeBind env bind_cxt old_bndr new_bndr new_rhs
; simplTrace "PostInlineUnconditionally" (ppr new_bndr <+> ppr unf_rhs) $
return ( emptyFloats env
, extendIdSubst env old_bndr $
- DoneEx unf_rhs (isJoinId_maybe new_bndr)) }
+ DoneEx unf_rhs (idJoinPointHood new_bndr)) }
-- Use the substitution to make quite, quite sure that the
-- substitution will happen, since we are going to discard the binding
@@ -1303,7 +1303,7 @@ work. T5631 is a good example of this.
simplJoinRhs :: SimplEnv -> InId -> InExpr -> SimplCont
-> SimplM OutExpr
simplJoinRhs env bndr expr cont
- | Just arity <- isJoinId_maybe bndr
+ | JoinPoint arity <- idJoinPointHood bndr
= do { let (join_bndrs, join_body) = collectNBinders arity expr
mult = contHoleScaling cont
; (env', join_bndrs') <- simplLamBndrs env (map (scaleVarBy mult) join_bndrs)
@@ -1985,14 +1985,14 @@ wrapJoinCont env cont thing_inside
--------------------
trimJoinCont :: Id -- Used only in error message
- -> Maybe JoinArity
+ -> JoinPointHood
-> SimplCont -> SimplCont
-- Drop outer context from join point invocation (jump)
-- See Note [Join points and case-of-case]
-trimJoinCont _ Nothing cont
+trimJoinCont _ NotJoinPoint cont
= cont -- Not a jump
-trimJoinCont var (Just arity) cont
+trimJoinCont var (JoinPoint arity) cont
= trim arity cont
where
trim 0 cont@(Stop {})
@@ -2139,7 +2139,7 @@ simplIdF env var cont
DoneId var1 ->
do { rule_base <- getSimplRules
- ; let cont' = trimJoinCont var1 (isJoinId_maybe var1) cont
+ ; let cont' = trimJoinCont var1 (idJoinPointHood var1) cont
info = mkArgInfo env rule_base var1 cont'
; rebuildCall env info cont' }
@@ -3260,7 +3260,7 @@ improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv
improveSeq fam_envs env scrut case_bndr case_bndr1 [Alt DEFAULT _ _]
| Just (Reduction co ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1)
= do { case_bndr2 <- newId (fsLit "nt") ManyTy ty2
- ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCo co) Nothing
+ ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCo co) NotJoinPoint
env2 = extendIdSubst env case_bndr rhs
; return (env2, scrut `Cast` co, case_bndr2) }
@@ -3549,7 +3549,7 @@ knownCon env scrut dc_floats dc dc_ty_args dc_args bndr bs rhs cont
bind_case_bndr env
| isDeadBinder bndr = return (emptyFloats env, env)
| exprIsTrivial scrut = return (emptyFloats env
- , extendIdSubst env bndr (DoneEx scrut Nothing))
+ , extendIdSubst env bndr (DoneEx scrut NotJoinPoint))
-- See Note [Do not duplicate constructor applications]
| otherwise = do { dc_args <- mapM (simplVar env) bs
-- dc_ty_args are already OutTypes,
@@ -4463,11 +4463,11 @@ simplRules env mb_new_id rules bind_cxt
-- binder matches that of the rule, so that pushing the
-- continuation into the RHS makes sense
join_ok = case mb_new_id of
- Just id | Just join_arity <- isJoinId_maybe id
+ Just id | JoinPoint join_arity <- idJoinPointHood id
-> length args == join_arity
_ -> False
bad_join_msg = vcat [ ppr mb_new_id, ppr rule
- , ppr (fmap isJoinId_maybe mb_new_id) ]
+ , ppr (fmap idJoinPointHood mb_new_id) ]
; args' <- mapM (simplExpr lhs_env) args
; rhs' <- simplExprC rhs_env rhs rhs_cont
=====================================
compiler/GHC/Core/Opt/SpecConstr.hs
=====================================
@@ -1941,8 +1941,8 @@ spec_one env fn arg_bndrs body (call_pat, rule_number)
= calcSpecInfo fn arg_bndrs call_pat extra_bndrs
spec_arity = count isId spec_lam_args
- spec_join_arity | isJoinId fn = Just (length spec_call_args)
- | otherwise = Nothing
+ spec_join_arity | isJoinId fn = JoinPoint (length spec_call_args)
+ | otherwise = NotJoinPoint
spec_id = asWorkerLikeId $
mkLocalId spec_name ManyTy
(mkLamTypes spec_lam_args spec_body_ty)
=====================================
compiler/GHC/Core/Opt/WorkWrap.hs
=====================================
@@ -830,8 +830,8 @@ mkWWBindPair ww_opts fn_id fn_info fn_args fn_body work_uniq div
-- inl_act: see Note [Worker activation]
-- inl_rule: it does not make sense for workers to be constructorlike.
- work_join_arity | isJoinId fn_id = Just join_arity
- | otherwise = Nothing
+ work_join_arity | isJoinId fn_id = JoinPoint join_arity
+ | otherwise = NotJoinPoint
-- worker is join point iff wrapper is join point
-- (see Note [Don't w/w join points for CPR])
=====================================
compiler/GHC/Core/Ppr.hs
=====================================
@@ -44,7 +44,6 @@ import GHC.Core.TyCon
import GHC.Core.TyCo.Ppr
import GHC.Core.Coercion
import GHC.Types.Basic
-import GHC.Data.Maybe
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Types.SrcLoc ( pprUserRealSpan )
@@ -140,8 +139,8 @@ ppr_binding ann (val_bdr, expr)
pp_val_bdr = pprPrefixOcc val_bdr
pp_bind = case bndrIsJoin_maybe val_bdr of
- Nothing -> pp_normal_bind
- Just ar -> pp_join_bind ar
+ NotJoinPoint -> pp_normal_bind
+ JoinPoint ar -> pp_join_bind ar
pp_normal_bind = hang pp_val_bdr 2 (equals <+> pprCoreExpr expr)
@@ -306,12 +305,12 @@ ppr_expr add_par (Let bind expr)
pprCoreExpr expr]
where
keyword (NonRec b _)
- | isJust (bndrIsJoin_maybe b) = text "join"
- | otherwise = text "let"
+ | isJoinPoint (bndrIsJoin_maybe b) = text "join"
+ | otherwise = text "let"
keyword (Rec pairs)
| ((b,_):_) <- pairs
- , isJust (bndrIsJoin_maybe b) = text "joinrec"
- | otherwise = text "letrec"
+ , isJoinPoint (bndrIsJoin_maybe b) = text "joinrec"
+ | otherwise = text "letrec"
ppr_expr add_par (Tick tickish expr)
= sdocOption sdocSuppressTicks $ \case
@@ -382,13 +381,13 @@ instance OutputableBndr Var where
pprBndr = pprCoreBinder
pprInfixOcc = pprInfixName . varName
pprPrefixOcc = pprPrefixName . varName
- bndrIsJoin_maybe = isJoinId_maybe
+ bndrIsJoin_maybe = idJoinPointHood
instance Outputable b => OutputableBndr (TaggedBndr b) where
pprBndr _ b = ppr b -- Simple
pprInfixOcc b = ppr b
pprPrefixOcc b = ppr b
- bndrIsJoin_maybe (TB b _) = isJoinId_maybe b
+ bndrIsJoin_maybe (TB b _) = idJoinPointHood b
pprOcc :: OutputableBndr a => LexicalFixity -> a -> SDoc
pprOcc Infix = pprInfixOcc
@@ -429,7 +428,7 @@ pprTypedLamBinder bind_site debug_on var
_
| not debug_on -- Show case-bound wild binders only if debug is on
, CaseBind <- bind_site
- , isDeadBinder var -> empty
+ , isDeadBinder var -> ppr var -- empty
| not debug_on -- Even dead binders can be one-shot
, isDeadBinder var -> char '_' <+> ppWhen (isId var)
=====================================
compiler/GHC/Core/Rules.hs
=====================================
@@ -220,9 +220,9 @@ mkSpecRule :: DynFlags -> Module -> Bool -> Activation -> SDoc
-> Id -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule
-- Make a specialisation rule, for Specialise or SpecConstr
mkSpecRule dflags this_mod is_auto inl_act herald fn bndrs args rhs
- = case isJoinId_maybe fn of
- Just join_arity -> etaExpandToJoinPointRule join_arity rule
- Nothing -> rule
+ = case idJoinPointHood fn of
+ JoinPoint join_arity -> etaExpandToJoinPointRule join_arity rule
+ NotJoinPoint -> rule
where
rule = mkRule this_mod is_auto is_local
rule_name
=====================================
compiler/GHC/Core/SimpleOpt.hs
=====================================
@@ -475,7 +475,7 @@ simple_bind_pair env@(SOE { soe_inl = inl_env, soe_subst = subst })
occ = idOccInfo in_bndr
in_scope = getSubstInScope subst
- out_rhs | Just join_arity <- isJoinId_maybe in_bndr
+ out_rhs | JoinPoint join_arity <- idJoinPointHood in_bndr
= simple_join_rhs join_arity
| otherwise
= simple_opt_clo in_scope clo
=====================================
compiler/GHC/Core/Tidy.hs
=====================================
@@ -132,7 +132,7 @@ computeCbvInfo :: HasCallStack
-> Id
-- computeCbvInfo fun_id rhs = fun_id
computeCbvInfo fun_id rhs
- | is_wkr_like || isJust mb_join_id
+ | is_wkr_like || isJoinPoint mb_join_id
, valid_unlifted_worker val_args
= -- pprTrace "computeCbvInfo"
-- (text "fun" <+> ppr fun_id $$
@@ -147,14 +147,14 @@ computeCbvInfo fun_id rhs
| otherwise = fun_id
where
- mb_join_id = isJoinId_maybe fun_id
+ mb_join_id = idJoinPointHood fun_id
is_wkr_like = isWorkerLikeId fun_id
val_args = filter isId lam_bndrs
-- When computing CbvMarks, we limit the arity of join points to
-- the JoinArity, because that's the arity we are going to use
-- when calling it. There may be more lambdas than that on the RHS.
- lam_bndrs | Just join_arity <- mb_join_id
+ lam_bndrs | JoinPoint join_arity <- mb_join_id
= fst $ collectNBinders join_arity rhs
| otherwise
= fst $ collectBinders rhs
=====================================
compiler/GHC/Core/Unfold.hs
=====================================
@@ -545,7 +545,7 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr
= False
size_up_rhs (bndr, rhs)
- | Just join_arity <- isJoinId_maybe bndr
+ | JoinPoint join_arity <- idJoinPointHood bndr
-- Skip arguments to join point
, (_bndrs, body) <- collectNBinders join_arity rhs
= size_up body
=====================================
compiler/GHC/CoreToIface.hs
=====================================
@@ -438,7 +438,7 @@ toIfaceLetBndr :: Id -> IfaceLetBndr
toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id))
(toIfaceType (idType id))
(toIfaceIdInfo (idInfo id))
- (toIfaceJoinInfo (isJoinId_maybe id))
+ (idJoinPointHood id)
-- Put into the interface file any IdInfo that GHC.Core.Tidy.tidyLetBndr
-- has left on the Id. See Note [IdInfo on nested let-bindings] in GHC.Iface.Syntax
@@ -505,10 +505,6 @@ toIfaceIdInfo id_info
inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing
| otherwise = Just (HsInline inline_prag)
-toIfaceJoinInfo :: Maybe JoinArity -> IfaceJoinInfo
-toIfaceJoinInfo (Just ar) = IfaceJoinPoint ar
-toIfaceJoinInfo Nothing = IfaceNotJoinPoint
-
--------------------------
toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem
toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs
=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -740,8 +740,8 @@ cpeJoinPair :: CorePrepEnv -> JoinId -> CoreExpr
-- No eta-expansion: see Note [Do not eta-expand join points] in GHC.Core.Opt.Simplify.Utils
cpeJoinPair env bndr rhs
= assert (isJoinId bndr) $
- do { let Just join_arity = isJoinId_maybe bndr
- (bndrs, body) = collectNBinders join_arity rhs
+ do { let JoinPoint join_arity = idJoinPointHood bndr
+ (bndrs, body) = collectNBinders join_arity rhs
; (env', bndrs') <- cpCloneBndrs env bndrs
@@ -1541,7 +1541,7 @@ maybeSaturate fn expr n_args unsat_ticks
( not (isJoinId fn)) -- See Note [Do not eta-expand join points]
( ppr fn $$ text "expr:" <+> ppr expr $$ text "n_args:" <+> ppr n_args $$
text "marks:" <+> ppr (idCbvMarks_maybe fn) $$
- text "join_arity" <+> ppr (isJoinId_maybe fn) $$
+ text "join_arity" <+> ppr (idJoinPointHood fn) $$
text "fn_arity" <+> ppr fn_arity
) $
-- pprTrace "maybeSat"
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -12,7 +12,7 @@ module GHC.Iface.Syntax (
IfaceDecl(..), IfaceFamTyConFlav(..), IfaceClassOp(..), IfaceAT(..),
IfaceConDecl(..), IfaceConDecls(..), IfaceEqSpec,
- IfaceExpr(..), IfaceAlt(..), IfaceLetBndr(..), IfaceJoinInfo(..), IfaceBinding,
+ IfaceExpr(..), IfaceAlt(..), IfaceLetBndr(..), IfaceBinding,
IfaceBindingX(..), IfaceMaybeRhs(..), IfaceConAlt(..),
IfaceIdInfo, IfaceIdDetails(..), IfaceUnfolding(..), IfGuidance(..),
IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
@@ -651,7 +651,7 @@ data IfaceBindingX r b
-- IfaceLetBndr is like IfaceIdBndr, but has IdInfo too
-- It's used for *non-top-level* let/rec binders
-- See Note [IdInfo on nested let-bindings]
-data IfaceLetBndr = IfLetBndr IfLclName IfaceType IfaceIdInfo IfaceJoinInfo
+data IfaceLetBndr = IfLetBndr IfLclName IfaceType IfaceIdInfo JoinPointHood
data IfaceTopBndrInfo = IfLclTopBndr IfLclName IfaceType IfaceIdInfo IfaceIdDetails
| IfGblTopBndr IfaceTopBndr
@@ -659,9 +659,6 @@ data IfaceTopBndrInfo = IfLclTopBndr IfLclName IfaceType IfaceIdInfo IfaceIdDeta
-- See Note [Interface File with Core: Sharing RHSs]
data IfaceMaybeRhs = IfUseUnfoldingRhs | IfRhs IfaceExpr
-data IfaceJoinInfo = IfaceNotJoinPoint
- | IfaceJoinPoint JoinArity
-
{-
Note [Empty case alternatives]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1574,10 +1571,6 @@ instance Outputable IfaceInfoItem where
ppr (HsLFInfo lf_info) = text "LambdaFormInfo:" <+> ppr lf_info
ppr (HsTagSig tag_sig) = text "TagSig:" <+> ppr tag_sig
-instance Outputable IfaceJoinInfo where
- ppr IfaceNotJoinPoint = empty
- ppr (IfaceJoinPoint ar) = angleBrackets (text "join" <+> ppr ar)
-
instance Outputable IfaceUnfolding where
ppr (IfCoreUnfold src _ guide e)
= sep [ text "Core:" <+> ppr src <+> ppr guide, ppr e ]
@@ -2689,19 +2682,6 @@ instance Binary IfaceMaybeRhs where
1 -> IfRhs <$> get bh
_ -> pprPanic "IfaceMaybeRhs" (intWithCommas b)
-
-
-instance Binary IfaceJoinInfo where
- put_ bh IfaceNotJoinPoint = putByte bh 0
- put_ bh (IfaceJoinPoint ar) = do
- putByte bh 1
- put_ bh ar
- get bh = do
- h <- getByte bh
- case h of
- 0 -> return IfaceNotJoinPoint
- _ -> liftM IfaceJoinPoint $ get bh
-
instance Binary IfaceTyConParent where
put_ bh IfNoParent = putByte bh 0
put_ bh (IfDataInstance ax pr ty) = do
@@ -2881,9 +2861,6 @@ instance NFData IfaceFamTyConFlav where
IfaceAbstractClosedSynFamilyTyCon -> ()
IfaceBuiltInSynFamTyCon -> ()
-instance NFData IfaceJoinInfo where
- rnf x = x `seq` ()
-
instance NFData IfaceTickish where
rnf = \case
IfaceHpcTick m i -> rnf m `seq` rnf i
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -1586,7 +1586,7 @@ tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info ji) rhs) body)
; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
NotTopLevel name ty' info
; let id = mkLocalIdWithInfo name ManyTy ty' id_info
- `asJoinId_maybe` tcJoinInfo ji
+ `asJoinId_maybe` ji
; rhs' <- tcIfaceExpr rhs
; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body)
; return (Let (NonRec id rhs') body') }
@@ -1601,7 +1601,7 @@ tcIfaceExpr (IfaceLet (IfaceRec pairs) body)
tc_rec_bndr (IfLetBndr fs ty _ ji)
= do { name <- newIfaceName (mkVarOccFS fs)
; ty' <- tcIfaceType ty
- ; return (mkLocalId name ManyTy ty' `asJoinId_maybe` tcJoinInfo ji) }
+ ; return (mkLocalId name ManyTy ty' `asJoinId_maybe` ji) }
tc_pair (IfLetBndr _ _ info _, rhs) id
= do { rhs' <- tcIfaceExpr rhs
; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
@@ -1744,10 +1744,6 @@ tcIdInfo ignore_prags toplvl name ty info = do
| otherwise = info
; return (info1 `setUnfoldingInfo` unf) }
-tcJoinInfo :: IfaceJoinInfo -> Maybe JoinArity
-tcJoinInfo (IfaceJoinPoint ar) = Just ar
-tcJoinInfo IfaceNotJoinPoint = Nothing
-
tcLFInfo :: IfaceLFInfo -> IfL LambdaFormInfo
tcLFInfo lfi = case lfi of
IfLFReEntrant rep_arity ->
=====================================
compiler/GHC/Stg/Lint.hs
=====================================
@@ -415,7 +415,7 @@ lintAppCbvMarks e@(StgApp fun args) = do
(text "marks" <> ppr marks $$
text "args" <> ppr args $$
text "arity" <> ppr (idArity fun) $$
- text "join_arity" <> ppr (isJoinId_maybe fun))
+ text "join_arity" <> ppr (idJoinPointHood fun))
lintAppCbvMarks _ = panic "impossible - lintAppCbvMarks"
{-
=====================================
compiler/GHC/Types/Basic.hs
=====================================
@@ -29,6 +29,7 @@ module GHC.Types.Basic (
ConTag, ConTagZ, fIRST_TAG,
Arity, RepArity, JoinArity, FullArgCount,
+ JoinPointHood(..), isJoinPoint,
Alignment, mkAlignment, alignmentOf, alignmentBytes,
@@ -1205,7 +1206,7 @@ The AlwaysTailCalled marker actually means slightly more than simply that the
function is always tail-called. See Note [Invariants on join points].
This info is quite fragile and should not be relied upon unless the occurrence
-analyser has *just* run. Use 'Id.isJoinId_maybe' for the permanent state of
+analyser has *just* run. Use 'Id.idJoinPointHood' for the permanent state of
the join-point-hood of a binder; a join id itself will not be marked
AlwaysTailCalled.
=====================================
compiler/GHC/Types/Id.hs
=====================================
@@ -78,7 +78,8 @@ module GHC.Types.Id (
hasNoBinding,
-- ** Join variables
- JoinId, isJoinId, isJoinId_maybe, idJoinArity,
+ JoinId, JoinPointHood,
+ isJoinId, idJoinPointHood, idJoinArity,
asJoinId, asJoinId_maybe, zapJoinId,
-- ** Inline pragma stuff
@@ -560,13 +561,13 @@ isJoinId id
| otherwise = False
-- | Doesn't return strictness marks
-isJoinId_maybe :: Var -> Maybe JoinArity
-isJoinId_maybe id
+idJoinPointHood :: Var -> JoinPointHood
+idJoinPointHood id
| isId id = assertPpr (isId id) (ppr id) $
case Var.idDetails id of
- JoinId arity _marks -> Just arity
- _ -> Nothing
- | otherwise = Nothing
+ JoinId arity _marks -> JoinPoint arity
+ _ -> NotJoinPoint
+ | otherwise = NotJoinPoint
idDataCon :: Id -> DataCon
-- ^ Get from either the worker or the wrapper 'Id' to the 'DataCon'. Currently used only in the desugarer.
@@ -639,7 +640,9 @@ isDeadBinder bndr | isId bndr = isDeadOcc (idOccInfo bndr)
-}
idJoinArity :: JoinId -> JoinArity
-idJoinArity id = isJoinId_maybe id `orElse` pprPanic "idJoinArity" (ppr id)
+idJoinArity id = case idJoinPointHood id of
+ JoinPoint ar -> ar
+ NotJoinPoint -> pprPanic "idJoinArity" (ppr id)
asJoinId :: Id -> JoinArity -> JoinId
asJoinId id arity = warnPprTrace (not (isLocalId id))
@@ -671,9 +674,9 @@ zapJoinId jid | isJoinId jid = zapIdTailCallInfo (newIdDetails `seq` jid `setIdD
_ -> panic "zapJoinId: newIdDetails can only be used if Id was a join Id."
-asJoinId_maybe :: Id -> Maybe JoinArity -> Id
-asJoinId_maybe id (Just arity) = asJoinId id arity
-asJoinId_maybe id Nothing = zapJoinId id
+asJoinId_maybe :: Id -> JoinPointHood -> Id
+asJoinId_maybe id (JoinPoint arity) = asJoinId id arity
+asJoinId_maybe id NotJoinPoint = zapJoinId id
{-
************************************************************************
=====================================
compiler/GHC/Utils/Binary.hs
=====================================
@@ -97,6 +97,7 @@ import GHC.Utils.Fingerprint
import GHC.Types.SrcLoc
import GHC.Types.Unique
import qualified GHC.Data.Strict as Strict
+import GHC.Utils.Outputable( JoinPointHood(..) )
import Control.DeepSeq
import Foreign hiding (shiftL, shiftR, void)
@@ -809,6 +810,17 @@ instance Binary DiffTime where
get bh = do r <- get bh
return $ fromRational r
+instance Binary JoinPointHood where
+ put_ bh NotJoinPoint = putByte bh 0
+ put_ bh (JoinPoint ar) = do
+ putByte bh 1
+ put_ bh ar
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> return NotJoinPoint
+ _ -> do { ar <- get bh; return (JoinPoint ar) }
+
{-
Finally - a reasonable portable Integer instance.
=====================================
compiler/GHC/Utils/Outputable.hs
=====================================
@@ -23,6 +23,7 @@
module GHC.Utils.Outputable (
-- * Type classes
Outputable(..), OutputableBndr(..), OutputableP(..),
+ BindingSite(..), JoinPointHood(..), isJoinPoint,
IsOutput(..), IsLine(..), IsDoc(..),
HLine, HDoc,
@@ -86,8 +87,6 @@ module GHC.Utils.Outputable (
pprModuleName,
-- * Controlling the style in which output is printed
- BindingSite(..),
-
PprStyle(..), NamePprCtx(..),
QueryQualifyName, QueryQualifyModule, QueryQualifyPackage, QueryPromotionTick,
PromotedItem(..), IsEmptyOrSingleton(..), isListEmptyOrSingleton,
@@ -156,6 +155,7 @@ import qualified Data.List.NonEmpty as NEL
import Data.Time ( UTCTime )
import Data.Time.Format.ISO8601
import Data.Void
+import Control.DeepSeq (NFData(rnf))
import GHC.Fingerprint
import GHC.Show ( showMultiLineString )
@@ -1220,16 +1220,6 @@ instance OutputableP env Void where
************************************************************************
-}
--- | 'BindingSite' is used to tell the thing that prints binder what
--- language construct is binding the identifier. This can be used
--- to decide how much info to print.
--- Also see Note [Binding-site specific printing] in "GHC.Core.Ppr"
-data BindingSite
- = LambdaBind -- ^ The x in (\x. e)
- | CaseBind -- ^ The x in case scrut of x { (y,z) -> ... }
- | CasePatBind -- ^ The y,z in case scrut of x { (y,z) -> ... }
- | LetBind -- ^ The x in (let x = rhs in e)
- deriving Eq
-- | When we print a binder, we often want to print its type too.
-- The @OutputableBndr@ class encapsulates this idea.
class Outputable a => OutputableBndr a where
@@ -1241,13 +1231,40 @@ class Outputable a => OutputableBndr a where
-- prefix position of an application, thus (f a b) or ((+) x)
-- or infix position, thus (a `f` b) or (x + y)
- bndrIsJoin_maybe :: a -> Maybe Int
- bndrIsJoin_maybe _ = Nothing
+ bndrIsJoin_maybe :: a -> JoinPointHood
+ bndrIsJoin_maybe _ = NotJoinPoint
-- When pretty-printing we sometimes want to find
-- whether the binder is a join point. You might think
-- we could have a function of type (a->Var), but Var
-- isn't available yet, alas
+-- | 'BindingSite' is used to tell the thing that prints binder what
+-- language construct is binding the identifier. This can be used
+-- to decide how much info to print.
+-- Also see Note [Binding-site specific printing] in "GHC.Core.Ppr"
+data BindingSite
+ = LambdaBind -- ^ The x in (\x. e)
+ | CaseBind -- ^ The x in case scrut of x { (y,z) -> ... }
+ | CasePatBind -- ^ The y,z in case scrut of x { (y,z) -> ... }
+ | LetBind -- ^ The x in (let x = rhs in e)
+ deriving Eq
+
+data JoinPointHood
+ = JoinPoint {-# UNPACK #-} !Int -- The JoinArity (but an Int here because
+ | NotJoinPoint -- synonym JoinArity is defined in Types.Basic
+ deriving( Eq )
+
+isJoinPoint :: JoinPointHood -> Bool
+isJoinPoint (JoinPoint {}) = True
+isJoinPoint NotJoinPoint = False
+
+instance Outputable JoinPointHood where
+ ppr NotJoinPoint = text "NotJoinPoint"
+ ppr (JoinPoint arity) = text "JoinPoint" <> parens (ppr arity)
+
+instance NFData JoinPointHood where
+ rnf x = x `seq` ()
+
{-
************************************************************************
* *
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/68e92a9acb53114cb4498134ac2728a507bc96df
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/68e92a9acb53114cb4498134ac2728a507bc96df
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/20230728/39d244a6/attachment-0001.html>
More information about the ghc-commits
mailing list