[Git][ghc/ghc][wip/andreask/spec-transitive] First PoC partially done
Andreas Klebinger (@AndreasK)
gitlab at gitlab.haskell.org
Fri Jan 6 10:26:30 UTC 2023
Andreas Klebinger pushed to branch wip/andreask/spec-transitive at Glasgow Haskell Compiler / GHC
Commits:
1c93cdb6 by Andreas Klebinger at 2023-01-06T11:25:00+01:00
First PoC partially done
- - - - -
29 changed files:
- compiler/GHC/Core.hs
- compiler/GHC/Core/FVs.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- + compiler/GHC/Core/Opt/SpecRec.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/Opt/WorkWrap.hs
- compiler/GHC/Core/Ppr.hs
- compiler/GHC/CoreToIface.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/HsToCore.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Tidy.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Rename/Bind.hs
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/Gen/Sig.hs
- compiler/GHC/Tc/TyCl/Class.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- compiler/GHC/Tc/TyCl/PatSyn.hs
- compiler/GHC/Types/Basic.hs
- compiler/GHC/Types/Id.hs
- compiler/GHC/Types/Id/Info.hs
- compiler/GHC/Types/SourceText.hs
- compiler/Language/Haskell/Syntax/Binds.hs
- compiler/ghc.cabal.in
Changes:
=====================================
compiler/GHC/Core.hs
=====================================
@@ -60,7 +60,7 @@ module GHC.Core (
-- ** Predicates and deconstruction on 'Unfolding'
unfoldingTemplate, expandUnfolding_maybe,
- maybeUnfoldingTemplate, otherCons,
+ maybeUnfoldingTemplate, maybeUnfoldingSource, otherCons,
isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,
isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding,
isStableUnfolding, isStableUserUnfolding, isStableSystemUnfolding,
@@ -1454,6 +1454,11 @@ maybeUnfoldingTemplate (DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args
maybeUnfoldingTemplate _
= Nothing
+maybeUnfoldingSource :: Unfolding -> Maybe UnfoldingSource
+maybeUnfoldingSource (CoreUnfolding { uf_src = src })
+ = Just src
+maybeUnfoldingSource _ = Nothing
+
-- | The constructors that the unfolding could never be:
-- returns @[]@ if no information is available
otherCons :: Unfolding -> [AltCon]
=====================================
compiler/GHC/Core/FVs.hs
=====================================
@@ -31,10 +31,11 @@ module GHC.Core.FVs (
bndrRuleAndUnfoldingIds,
idFVs,
idRuleVars, stableUnfoldingVars,
- ruleFreeVars, rulesFreeVars,
+ ruleFreeVars, rulesFreeVars, rulesSomeFreeVars, rulesSomeFreeVarsList,
rulesFreeVarsDSet, mkRuleInfo,
ruleLhsFreeIds, ruleLhsFreeIdsList,
ruleRhsFreeVars, rulesRhsFreeIds,
+ rulesRhsSomeFVs, ruleRhsSomeFreeVars,
exprFVs,
@@ -466,34 +467,47 @@ data RuleFVsFrom
-- | Those locally-defined variables free in the left and/or right hand sides
-- of the rule, depending on the first argument. Returns an 'FV' computation.
ruleFVs :: RuleFVsFrom -> CoreRule -> FV
-ruleFVs !_ (BuiltinRule {}) = emptyFV
-ruleFVs from (Rule { ru_fn = _do_not_include
+ruleFVs = ruleSomeFVs isLocalVar
+
+ruleSomeFVs :: InterestingVarFun -> RuleFVsFrom -> CoreRule -> FV
+ruleSomeFVs _fv_cand !_ (BuiltinRule {}) = emptyFV
+ruleSomeFVs fv_cand from (Rule { ru_fn = _do_not_include
-- See Note [Rule free var hack]
, ru_bndrs = bndrs
, ru_rhs = rhs, ru_args = args })
- = filterFV isLocalVar $ addBndrs bndrs (exprs_fvs exprs)
+ = filterFV fv_cand $ addBndrs bndrs (exprs_fvs exprs)
where
exprs = case from of
LhsOnly -> args
RhsOnly -> [rhs]
BothSides -> rhs:args
-
-- | Those locally-defined variables free in the left and/or right hand sides
-- from several rules, depending on the first argument.
-- Returns an 'FV' computation.
rulesFVs :: RuleFVsFrom -> [CoreRule] -> FV
rulesFVs from = mapUnionFV (ruleFVs from)
+rulesSomeFVs :: InterestingVarFun -> RuleFVsFrom -> [CoreRule] -> FV
+rulesSomeFVs fv_cand from = mapUnionFV (ruleSomeFVs fv_cand from)
+
-- | Those variables free in the right hand side of a rule returned as a
-- non-deterministic set
ruleRhsFreeVars :: CoreRule -> VarSet
ruleRhsFreeVars = fvVarSet . ruleFVs RhsOnly
+-- | Those variables free in the right hand side of a rule returned as a
+-- non-deterministic set
+ruleRhsSomeFreeVars :: InterestingVarFun -> CoreRule -> VarSet
+ruleRhsSomeFreeVars fv_cand = fvVarSet . ruleSomeFVs fv_cand RhsOnly
+
-- | Those locally-defined free 'Id's in the right hand side of several rules
-- returned as a non-deterministic set
rulesRhsFreeIds :: [CoreRule] -> VarSet
rulesRhsFreeIds = fvVarSet . filterFV isLocalId . rulesFVs RhsOnly
+rulesRhsSomeFVs :: InterestingVarFun -> [CoreRule] -> VarSet
+rulesRhsSomeFVs fv_cand = fvVarSet . rulesSomeFVs fv_cand RhsOnly
+
ruleLhsFreeIds :: CoreRule -> VarSet
-- ^ This finds all locally-defined free Ids on the left hand side of a rule
-- and returns them as a non-deterministic set
@@ -518,6 +532,12 @@ rulesFreeVarsDSet rules = fvDVarSet $ rulesFVs BothSides rules
rulesFreeVars :: [CoreRule] -> VarSet
rulesFreeVars rules = fvVarSet $ rulesFVs BothSides rules
+rulesSomeFreeVars :: InterestingVarFun -> [CoreRule] -> VarSet
+rulesSomeFreeVars fv_cand rules = fvVarSet $ rulesSomeFVs fv_cand BothSides rules
+
+rulesSomeFreeVarsList :: InterestingVarFun -> [CoreRule] -> [Var]
+rulesSomeFreeVarsList fv_cand rules = fvVarList $ rulesSomeFVs fv_cand BothSides rules
+
-- | Make a 'RuleInfo' containing a number of 'CoreRule's, suitable
-- for putting into an 'IdInfo'
mkRuleInfo :: [CoreRule] -> RuleInfo
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -677,6 +677,7 @@ mkCastWrapperPragInfo prag_info
, inl_rule = rule_info } -- in GHC.Core.Opt.WorkWrap
-- RuleMatchInfo is (and must be) unaffected
(pragHasInlineable prag_info)
+ (pragSpecRec prag_info)
where
-- See Note [Wrapper activation] in GHC.Core.Opt.WorkWrap
-- But simpler, because we don't need to disable during InitialPhase
=====================================
compiler/GHC/Core/Opt/SpecRec.hs
=====================================
@@ -0,0 +1,211 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE TupleSections #-}
+
+-- | Transfer specrec pragmas from functions having such a pragma
+-- to functions calling such functions.
+module GHC.Core.Opt.SpecRec
+ ( transferSpecRecs
+ ) where
+
+import GHC.Prelude
+
+
+import GHC.Types.Basic
+import GHC.Driver.Session
+import GHC.Types.Name hiding (varName)
+import GHC.Types.Id
+import GHC.Unit.Module.ModGuts
+import GHC.Types.Var.Set
+import GHC.Types.Name.Env
+import GHC.Unit.Types
+import GHC.Core
+import GHC.Core.Rules
+import GHC.Core.FVs
+import GHC.Utils.Outputable
+
+import Data.Graph
+import GHC.Utils.Monad.State.Strict
+import Control.Monad
+import Data.Maybe
+{-
+-- We need to transfer the pragma in these cases:
+
+{-# SPECREC foo #-}
+foo = ...
+
+We transfer the pragma if foo is mentioned in:
+* The RHS of a function
+* The unfolding. -- TODO: Not needed after desugar?
+-- TODO: Rules
+
+-}
+
+transferSpecRecs :: ModGuts -> ModGuts
+-- transferSpecRecs _dflags guts = guts
+transferSpecRecs guts =
+ let env :: Env
+ env = Env
+ { thisModule = mg_module guts
+ , orphanRules = mkRuleBase (mg_rules guts)
+ }
+ in guts { mg_binds = doCoreProgram env (mg_binds guts)
+ }
+
+-- bind_fvs (NonRec _ rhs) =
+doCoreProgram :: Env -> CoreProgram -> CoreProgram
+doCoreProgram env binds = flip evalState (SS mempty mempty) $ do
+ -- pprTraceM "binds_in" $ vcat $ map ppr binds
+ let sorted_binds = depAnal (map getName . bindersOf) bind_deps binds
+ -- pprTraceM "binds_sorted" $ vcat $ map (ppr . bindersOf) sorted_binds
+ done_binds <- doSccs env sorted_binds
+ -- pprTraceM "binds_out" $ vcat $ map (ppr . bindersOf) done_binds
+ return done_binds
+ where
+ bind_deps bind =
+ let bs = bindersOf bind
+ rhss = rhssOfBind bind
+ rhss_fvs = exprsSomeFreeVarsList (const True) rhss
+ unfs = map realIdUnfolding bs
+ unf_rhs = catMaybes . map maybeUnfoldingTemplate $ unfs
+ unf_fvs = exprsSomeFreeVarsList (const True) unf_rhs
+ id_rules = concatMap idCoreRules bs
+ id_rules_fvs = rulesSomeFreeVarsList (const True) id_rules
+ in map getName $ unf_fvs ++ id_rules_fvs ++ unf_fvs ++ rhss_fvs
+
+mcons :: Monad m => a -> m [a] -> m [a]
+mcons x xs = liftM (x:) xs
+
+doSccs :: Env -> [SCC CoreBind] -> M [CoreBind]
+doSccs env binds = do
+ bindss <- mapM (doScc env) binds
+ pure $ concat bindss
+
+doScc :: Env -> SCC CoreBind -> M [CoreBind]
+doScc env (AcyclicSCC bind) = do
+ (b,is_spec) <- doBind env bind
+ when is_spec $ addSpecBinders $ bindersOf b
+ pure [b]
+doScc env (CyclicSCC binds) = do
+ -- A bunch of binders which might refer to each other in a cyclic fashion via
+ -- something like rules. So we must put specrec on all of them.
+ (bs,is_specs) <- unzip <$> mapM (doBind env) binds
+ when (or is_specs) $ addSpecBinders $ bindersOfBinds bs
+ pure $ map setSpec bs
+
+addSpecBinders :: [Id] -> M ()
+addSpecBinders ids = do
+ mapM_ addSpec ids
+ mapM_ addDone ids
+ return ()
+
+doBind :: Env -> CoreBind -> M (CoreBind, Bool)
+doBind env bind = do
+ to_spec <- spec_set <$> get
+ let bs = bindersOf bind
+ rhss = rhssOfBind bind
+ spec_id = any idHasSpecRec bs
+ spec_rhs = any (is_spec_expr to_spec) rhss
+ spec_unf = any (is_spec_unf to_spec . realIdUnfolding) bs
+ spec_rules = any (is_spec_rules to_spec . idCoreRules) bs
+
+ if spec_id || spec_rhs || spec_unf || spec_rules
+ -- If the rhs, unfolding or a rule rhs mentions a spec-rec function
+ -- we must make the function itself spec-rec
+ then pure (setSpec bind, True)
+ -- Otherwise another binding might still become spec-rec in the future
+ else pure (bind, False)
+
+ where
+ is_spec_rules spec_set rules =
+ let fvs = rulesRhsSomeFVs (\v -> isId v && idHasSpecRec v || elemVarSet v spec_set) rules
+ in not (isEmptyVarSet fvs)
+
+ is_spec_expr :: VarSet -> CoreExpr -> Bool
+ is_spec_expr spec_set expr =
+ let fvs = exprSomeFreeVars (\v -> isId v && idHasSpecRec v || elemVarSet v spec_set) expr
+ in not (isEmptyVarSet fvs)
+
+ is_spec_unf :: VarSet -> Unfolding -> Bool
+ is_spec_unf spec_set unf = do
+ case maybeUnfoldingSource unf of
+ -- We already look at the rhs and the unf is the same
+ Just VanillaSrc -> False
+ _ -> case maybeUnfoldingTemplate unf of
+ Just unf_tmpl -> do
+ is_spec_expr spec_set unf_tmpl
+ Nothing -> False
+
+ -- TODO: Properly set activation
+
+setSpec :: Bind Id -> Bind Id
+setSpec (NonRec b rhs) = NonRec (setHasSpecRec b (Just AlwaysActive)) rhs
+setSpec (Rec pairs) = Rec $ map (\(b,rhs) -> (setHasSpecRec b (Just AlwaysActive), rhs)) pairs
+
+
+-- doBind :: Env -> CoreBind -> M CoreBind
+-- doBind env (NonRec b rhs) = NonRec b <$> doExpr (addParent b env) rhs
+-- doBind env (Rec bs) = Rec <$> mapM doPair bs
+-- where
+-- doPair (b,rhs) = (b,) <$> doExpr (addParent b env) rhs
+
+-- doExpr :: Env -> CoreExpr -> M CoreExpr
+-- doExpr env e@(Var v)
+-- | needsCallSiteCostCentre env v = do
+-- let nameDoc :: SDoc
+-- nameDoc = withUserStyle alwaysQualify DefaultDepth $
+-- hcat (punctuate dot (map ppr (parents env))) <> parens (text "calling:" <> ppr v)
+
+-- ccName :: CcName
+-- ccName = mkFastString $ renderWithContext defaultSDocContext nameDoc
+-- ccIdx <- getCCIndex' ccName
+-- let count = countEntries env
+-- span = case revParents env of
+-- top:_ -> nameSrcSpan $ varName top
+-- _ -> noSrcSpan
+-- cc = NormalCC (ExprCC ccIdx) ccName (thisModule env) span
+-- tick :: CoreTickish
+-- tick = ProfNote cc count True
+-- pure $ Tick tick e
+-- | otherwise = pure e
+-- doExpr _env e@(Lit _) = pure e
+-- doExpr env (f `App` x) = App <$> doExpr env f <*> doExpr env x
+-- doExpr env (Lam b x) = Lam b <$> doExpr env x
+-- doExpr env (Let b rhs) = Let <$> doBind env b <*> doExpr env rhs
+-- doExpr env (Case scrut b ty alts) =
+-- Case <$> doExpr env scrut <*> pure b <*> pure ty <*> mapM doAlt alts
+-- where
+-- doAlt (Alt con bs rhs) = Alt con bs <$> doExpr env rhs
+-- doExpr env (Cast expr co) = Cast <$> doExpr env expr <*> pure co
+-- doExpr env (Tick t e) = Tick t <$> doExpr env e
+-- doExpr _env e@(Type _) = pure e
+-- doExpr _env e@(Coercion _) = pure e
+
+data SpecState = SS
+ { spec_set :: !VarSet
+ , spec_done :: !VarSet
+ }
+
+type M = State SpecState
+
+addSpec :: Var -> M ()
+addSpec v = do
+ s <- get
+ put $! s { spec_set = extendVarSet (spec_set s) v }
+
+addDone :: Var -> M ()
+addDone v = do
+ s <- get
+ put $! s { spec_done = extendVarSet (spec_done s) v }
+
+
+
+data Env = Env
+ { thisModule :: Module
+ , orphanRules :: RuleBase
+ }
+
=====================================
compiler/GHC/Core/Opt/Specialise.hs
=====================================
@@ -52,6 +52,7 @@ import GHC.Types.Var ( PiTyBinder(..), isLocalVar, isInvisibleFunArg )
import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Types.Id
+import GHC.Types.Id.Info
import GHC.Types.Error
import GHC.Utils.Error ( mkMCDiagnostic )
@@ -1613,6 +1614,7 @@ specCalls spec_imp env dict_binds existing_rules calls_for_me fn rhs
| notNull calls_for_me -- And there are some calls to specialise
, not (isNeverActive inl_act)
|| idHasInlineable fn -- Explicit INLINEABLE pragma
+ || idHasSpecRec fn -- SpecRec
|| gopt Opt_SpecialiseAggressively dflags -- -fspecialise-aggressively
, not (isOpaquePragma inl_prag)
-- Don't specialise NOINLINE things by default.
@@ -1766,6 +1768,11 @@ specCalls spec_imp env dict_binds existing_rules calls_for_me fn rhs
| otherwise
= inl_prag
+ spec_inlineable = idHasInlineable fn
+ spec_rec = idSpecRec fn
+
+ spec_prag_info = mkPragInfo spec_inl_prag spec_inlineable spec_rec
+
--------------------------------------
-- Adding arity information just propagates it a bit faster
-- See Note [Arity decrease] in GHC.Core.Opt.Simplify
@@ -1773,7 +1780,7 @@ specCalls spec_imp env dict_binds existing_rules calls_for_me fn rhs
-- So if f has INLINE[1] so does spec_fn
arity_decr = count isValArg rule_lhs_args - count isId spec_bndrs
spec_f_w_arity = spec_fn `setIdArity` max 0 (fn_arity - arity_decr)
- `setInlinePragma` spec_inl_prag
+ `setIdPragmaInfo` spec_prag_info
`setIdUnfolding` spec_unf
`asJoinId_maybe` spec_join_arity
=====================================
compiler/GHC/Core/Opt/WorkWrap.hs
=====================================
@@ -830,6 +830,7 @@ mkWWBindPair ww_opts fn_id fn_info fn_args fn_body work_uniq div
-- inl_inline: copy from fn_id; see Note [Worker/wrapper for INLINABLE functions]
-- inl_act: see Note [Worker activation]
-- inl_rule: it does not make sense for workers to be constructorlike.
+ work_prag_info = mkPragInfo work_prag fn_has_inlineable fn_spec_rec
work_join_arity | isJoinId fn_id = Just join_arity
| otherwise = Nothing
@@ -844,8 +845,7 @@ mkWWBindPair ww_opts fn_id fn_info fn_args fn_body work_uniq div
-- Doesn't matter much, since we will simplify next, but
-- seems right-er to do so
- `setInlinePragma` work_prag
- `setHasInlineable` fn_has_inlineable
+ `setIdPragmaInfo` work_prag_info
`setIdUnfolding` mkWorkerUnfolding simpl_opts work_fn fn_unfolding
-- See Note [Worker/wrapper for INLINABLE functions]
@@ -874,6 +874,7 @@ mkWWBindPair ww_opts fn_id fn_info fn_args fn_body work_uniq div
wrap_rhs = wrap_fn work_id
wrap_prag = mkStrWrapperInlinePrag fn_inl_prag fn_rules
+ wrap_prag_info = mkPragInfo wrap_prag fn_has_inlineable fn_spec_rec
wrap_unf = mkWrapperUnfolding (simpleOptExpr simpl_opts wrap_rhs) arity
wrap_id = fn_id `setIdUnfolding` wrap_unf
@@ -881,7 +882,7 @@ mkWWBindPair ww_opts fn_id fn_info fn_args fn_body work_uniq div
`setIdOccInfo` noOccInfo
-- We must keep hasInlineable to ensure wrappers can specialise
-- if they are NOINLINE[final]
- `setHasInlineable`fn_has_inlineable
+ `setIdPragmaInfo` wrap_prag_info
-- Zap any loop-breaker-ness, to avoid bleating from Lint
-- about a loop breaker with an INLINE rule
@@ -890,6 +891,7 @@ mkWWBindPair ww_opts fn_id fn_info fn_args fn_body work_uniq div
fn_unfolding = realUnfoldingInfo fn_info
fn_has_inlineable = inlineableInfo fn_info
fn_rules = ruleInfoRules (ruleInfo fn_info)
+ fn_spec_rec = specRecInfo fn_info
mkStrWrapperInlinePrag :: InlinePragma -> [CoreRule] -> InlinePragma
mkStrWrapperInlinePrag (InlinePragma { inl_inline = fn_inl
=====================================
compiler/GHC/Core/Ppr.hs
=====================================
@@ -489,6 +489,9 @@ pprIdBndrInfo info
has_inlineable = inlineableInfo info &&
isNoInlinePragma prag_info -- The flag is redundant
-- unless we have NOINLINE.
+ spec_rec = specRecInfo info
+ has_spec_rec = isJust spec_rec || True
+
occ_info = occInfo info
dmd_info = demandInfo info
@@ -502,6 +505,7 @@ pprIdBndrInfo info
doc = showAttributes
[ (has_prag, text "InlPrag=" <> pprInlineDebug prag_info)
, (has_inlineable, text "Inlineable")
+ , (has_spec_rec, text "SpecRec:" <> ppr spec_rec)
, (has_occ, text "Occ=" <> ppr occ_info)
, (has_dmd, text "Dmd=" <> ppr dmd_info)
, (has_lbv , text "OS=" <> ppr lbv_info)
@@ -512,6 +516,7 @@ instance Outputable IdInfo where
[ (has_prag, text "InlPrag=" <> pprInlineDebug prag_info)
-- Todo: This is only interesting for NoInline pragmas
, (has_inlineable, text "Inlineable")
+ , (has_spec_rec, text "SpecRec:" <> ppr spec_rec)
, (has_occ, text "Occ=" <> ppr occ_info)
, (has_dmd, text "Dmd=" <> ppr dmd_info)
, (has_lbv , text "OS=" <> ppr lbv_info)
@@ -525,6 +530,9 @@ instance Outputable IdInfo where
where
prag_info = inlinePragInfo info
has_prag = not (isDefaultInlinePragma prag_info)
+ spec_rec = specRecInfo info
+ has_spec_rec = isJust spec_rec || True
+
occ_info = occInfo info
has_occ = not (isManyOccs occ_info)
=====================================
compiler/GHC/CoreToIface.hs
=====================================
@@ -84,7 +84,7 @@ import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Misc
-import Data.Maybe ( isNothing, catMaybes )
+import Data.Maybe
{- Note [Avoiding space leaks in toIface*]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -463,7 +463,7 @@ toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other)
toIfaceIdInfo :: IdInfo -> IfaceIdInfo
toIfaceIdInfo id_info
= catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, cpr_hsinfo,
- inline_hsinfo, has_inlineable_hsinfo, unfold_hsinfo]
+ inline_hsinfo, has_inlineable_hsinfo, unfold_hsinfo, spec_rec_hsinfo]
-- NB: strictness and arity must appear in the list before unfolding
-- See GHC.IfaceToCore.tcUnfolding
where
@@ -503,6 +503,10 @@ toIfaceIdInfo id_info
| has_inlineable = Just HsInlineable
| otherwise = Nothing
+ ------------ SpecRec flag ------------
+ spec_rec_hsinfo = maybe Nothing (Just . HsSpecRec) (specRecInfo id_info)
+
+
toIfaceJoinInfo :: Maybe JoinArity -> IfaceJoinInfo
toIfaceJoinInfo (Just ar) = IfaceJoinPoint ar
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -175,6 +175,7 @@ import GHC.Core.Multiplicity
import GHC.Core.Utils ( exprType )
import GHC.Core.ConLike
import GHC.Core.Opt.Pipeline
+import GHC.Core.Opt.SpecRec
import GHC.Core.Opt.Pipeline.Types ( CoreToDo (..))
import GHC.Core.TyCon
import GHC.Core.InstEnv
@@ -2488,11 +2489,16 @@ hscTidy hsc_env guts = do
let logger = hsc_logger hsc_env
let this_mod = mg_module guts
+ (specrec_guts) <- withTiming logger
+ (text "CoreTidy"<+>brackets (ppr this_mod))
+ (const ())
+ $! {-# SCC "CoreTidy" #-} (return $ transferSpecRecs guts)
+
opts <- initTidyOpts hsc_env
(cgguts, details) <- withTiming logger
(text "CoreTidy"<+>brackets (ppr this_mod))
(const ())
- $! {-# SCC "CoreTidy" #-} tidyProgram opts guts
+ $! {-# SCC "CoreTidy" #-} tidyProgram opts specrec_guts
-- post tidy pretty-printing and linting...
let tidy_rules = md_rules details
=====================================
compiler/GHC/HsToCore.hs
=====================================
@@ -57,6 +57,7 @@ import GHC.Core.DataCon ( dataConWrapId )
import GHC.Core.Make
import GHC.Core.Rules
import GHC.Core.Opt.Pipeline.Types ( CoreToDo(..) )
+import GHC.Core.Opt.SpecRec
import GHC.Core.Ppr
import GHC.Builtin.Names
@@ -254,7 +255,7 @@ deSugar hsc_env
; docs <- extractDocs dflags tcg_env
- ; let mod_guts = ModGuts {
+ ; let mod_guts = transferSpecRecs ModGuts {
mg_module = mod,
mg_hsc_src = hsc_src,
mg_loc = mkFileSrcSpan mod_loc,
@@ -284,6 +285,7 @@ deSugar hsc_env
mg_complete_matches = complete_matches,
mg_docs = docs
}
+
; return (msgs, Just mod_guts)
}}}}
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -993,6 +993,8 @@ rep_sig (L loc (ClassOpSig _ is_deflt nms ty))
| otherwise = mapM (rep_ty_sig sigDName (locA loc) ty) nms
rep_sig (L loc (FixSig _ fix_sig)) = rep_fix_d (locA loc) fix_sig
rep_sig (L loc (InlineSig _ nm ispec))= rep_inline nm ispec (locA loc)
+rep_sig (L loc (SpecRecSig _ nm act))
+ = rep_specrec nm act (locA loc)
rep_sig (L loc (SpecSig _ nm tys ispec))
= concatMapM (\t -> rep_specialise nm t ispec (locA loc)) tys
rep_sig (L loc (SpecInstSig _ ty)) = rep_specialiseInst ty (locA loc)
@@ -1097,6 +1099,8 @@ rep_inline nm ispec loc
; return [(loc, pragma)]
}
+rep_specrec = error "TODO"
+
rep_specialise :: LocatedN Name -> LHsSigType GhcRn -> InlinePragma
-> SrcSpan
-> MetaM [(SrcSpan, Core (M TH.Dec))]
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -1718,6 +1718,11 @@ instance HiePass p => ToHie (SigContext (LocatedA (Sig (GhcPass p)))) where
InlineSig _ name _ ->
[ toHie $ (C Use) name
]
+ SpecRecSig _ name act ->
+ [ toHie $ (C Use) name
+ -- TODO: activation
+ -- , toHie $ act
+ ]
SpecSig _ name typs _ ->
[ toHie $ (C Use) name
, toHie $ map (TS (ResolvedScopes [])) typs
=====================================
compiler/GHC/Iface/Recomp.hs
=====================================
@@ -1035,9 +1035,14 @@ addFingerprints hsc_env iface0
-- See Note [Identity versus semantic module]
| semantic_mod /= this_mod
, not (isHoleModule semantic_mod) = global_hash_fn name
- | otherwise = return (snd (lookupOccEnv local_env (getOccName name)
- `orElse` pprPanic "urk! lookup local fingerprint"
- (ppr name $$ ppr local_env)))
+ | otherwise = do
+ let fp = lookupOccEnv local_env (getOccName name) `orElse`
+ (pprTrace "urk! lookup local fingerprint"
+ (ppr (nameModule name) $$ ppr name $$ ppr local_env)
+ -- TODO: ???
+ (undefined, fingerprint0)
+ )
+ return $ snd fp
-- This panic indicates that we got the dependency
-- analysis wrong, because we needed a fingerprint for
-- an entity that wasn't in the environment. To debug
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -358,6 +358,7 @@ data IfaceInfoItem
| HsUnfold Bool -- True <=> isStrongLoopBreaker is true
IfaceUnfolding -- See Note [Expose recursive functions]
| HsInlineable
+ | HsSpecRec Activation
| HsNoCafRefs
| HsLFInfo IfaceLFInfo
| HsTagSig TagSig
@@ -1517,6 +1518,7 @@ instance Outputable IfaceInfoItem where
<> colon <+> ppr unf
ppr (HsInline prag) = text "Inline:" <+> ppr prag
ppr (HsInlineable) = text "HasInlineable:True"
+ ppr (HsSpecRec act) = text "SpecRec:" <> ppr act
ppr (HsArity arity) = text "Arity:" <+> int arity
ppr (HsDmdSig str) = text "Strictness:" <+> ppr str
ppr (HsCprSig cpr) = text "CPR:" <+> ppr cpr
@@ -2287,7 +2289,8 @@ instance Binary IfaceInfoItem where
put_ bh (HsCprSig cpr) = putByte bh 6 >> put_ bh cpr
put_ bh (HsLFInfo lf_info) = putByte bh 7 >> put_ bh lf_info
put_ bh (HsTagSig sig) = putByte bh 8 >> put_ bh sig
- put_ bh (HsInlineable) = putByte bh 9
+ put_ bh (HsInlineable) = putByte bh 9
+ put_ bh (HsSpecRec act) = putByte bh 10 >> put_ bh act
get bh = do
h <- getByte bh
@@ -2303,6 +2306,7 @@ instance Binary IfaceInfoItem where
7 -> HsLFInfo <$> get bh
8 -> HsTagSig <$> get bh
9 -> pure HsInlineable
+ 10 -> HsSpecRec <$> get bh
_ -> error "Binary:IfaceInfoItem - Invalid byte"
instance Binary IfaceUnfolding where
@@ -2713,6 +2717,7 @@ instance NFData IfaceInfoItem where
HsLFInfo lf_info -> lf_info `seq` () -- TODO: seq further?
HsTagSig sig -> sig `seq` ()
HsInlineable -> ()
+ HsSpecRec act -> rnf act
instance NFData IfGuidance where
rnf = \case
=====================================
compiler/GHC/Iface/Tidy.hs
=====================================
@@ -384,6 +384,8 @@ tidyProgram opts (ModGuts { mg_module = mod
(unfold_env, tidy_occ_env) <- chooseExternalIds opts mod all_binds imp_rules
let (trimmed_binds, trimmed_rules) = findExternalRules opts all_binds imp_rules unfold_env
+ -- pprTraceM "trimmed_binds" (ppr $ bindersOfBinds trimmed_binds)
+
(tidy_env, tidy_binds) <- tidyTopBinds unfold_env boot_exports tidy_occ_env trimmed_binds
-- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.
@@ -652,7 +654,9 @@ chooseExternalIds :: TidyOpts
chooseExternalIds opts mod binds imp_id_rules
= do { (unfold_env1,occ_env1) <- search init_work_list emptyVarEnv init_occ_env
+ -- ; pprTraceM "unfoldEnv" (ppr unfold_env1)
; let internal_ids = filter (not . (`elemVarEnv` unfold_env1)) binders
+ -- ; pprTraceM "internals" (ppr internal_ids)
; tidy_internal internal_ids unfold_env1 occ_env1 }
where
name_cache = opt_name_cache opts
@@ -717,7 +721,9 @@ chooseExternalIds opts mod binds imp_id_rules
search [] unfold_env occ_env = return (unfold_env, occ_env)
search ((idocc,referrer) : rest) unfold_env occ_env
- | idocc `elemVarEnv` unfold_env = search rest unfold_env occ_env
+ | idocc `elemVarEnv` unfold_env =
+ -- pprTrace "search.1" (ppr idocc <+> ppr referrer) $
+ search rest unfold_env occ_env
| otherwise = do
(occ_env', name') <- tidyTopName mod name_cache (Just referrer) occ_env idocc
let
@@ -733,6 +739,11 @@ chooseExternalIds opts mod binds imp_id_rules
referrer' | isExportedId refined_id = refined_id
| otherwise = referrer
--
+ -- pprTraceM "search.2"
+ -- (ppr idocc <+> ppr referrer $$
+ -- text "show:" <> ppr show_unfold $$
+ -- text "name',external:" <> ppr (name', isExternalName name')
+ -- )
search (zip new_ids (repeat referrer') ++ rest) unfold_env' occ_env'
tidy_internal :: [Id] -> UnfoldEnv -> TidyOccEnv
@@ -762,6 +773,7 @@ addExternal opts id
loop_breaker = isStrongLoopBreaker (occInfo idinfo)
bottoming_fn = isDeadEndSig (dmdSigInfo idinfo)
inlineable = inlineableInfo idinfo
+ spec_rec = specRecInfo idinfo
-- Stuff to do with the Id's unfolding
-- We leave the unfolding there even if there is a worker
@@ -776,6 +788,7 @@ addExternal opts id
-- source is an inline rule
|| inlineable
+ || isJust spec_rec
|| not dont_inline
where
@@ -1033,7 +1046,11 @@ findExternalRules opts binds imp_id_rules unfold_env
where
stuff@(binds', bndr_set, needed_fvs, rules)
= trim_binds binds
- needed bndr = isExportedId bndr || bndr `elemVarSet` needed_fvs
+ shows_unf bndr = case lookupVarEnv unfold_env bndr of
+ Just (name, show_unf)
+ | isExternalName name || show_unf -> True
+ _ -> False
+ needed bndr = isExportedId bndr || bndr `elemVarSet` needed_fvs || shows_unf bndr
bndrs = bindersOf bind
rhss = rhssOfBind bind
@@ -1281,7 +1298,7 @@ tidyTopIdInfo rhs_tidy_env name rhs_ty orig_rhs tidy_rhs idinfo show_unfold
Nothing -> False
Just (arity, _, _) -> not (isDeadEndAppSig id_sig arity)
- prag_info = mkPragInfo (inlinePragInfo idinfo) (inlineableInfo idinfo)
+ prag_info = mkPragInfo (inlinePragInfo idinfo) (inlineableInfo idinfo) (specRecInfo idinfo)
--------- Unfolding ------------
-- Force unfold_info (hence bangs), otherwise the old unfolding
-- is retained during code generation. See #22071
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -1725,6 +1725,7 @@ tcIdInfo ignore_prags toplvl name ty info = do
tcPrag info (HsCprSig cpr) = return (info `setCprSigInfo` cpr)
tcPrag info (HsInline prag) = return (info `setInlinePragInfo` prag)
tcPrag info (HsInlineable) = return (info `setHasInlineableInfo` True)
+ tcPrag info (HsSpecRec act) = return (info `setHasSpecRecInfo` (Just act))
tcPrag info (HsLFInfo lf_info) = do
lf_info <- tcLFInfo lf_info
return (info `setLFInfo` lf_info)
=====================================
compiler/GHC/Rename/Bind.hs
=====================================
@@ -1054,6 +1054,10 @@ renameSig ctxt sig@(InlineSig _ v s)
= do { new_v <- lookupSigOccRnN ctxt sig v
; return (InlineSig noAnn new_v s, emptyFVs) }
+renameSig ctxt sig@(SpecRecSig _ v s)
+ = do { new_v <- lookupSigOccRnN ctxt sig v
+ ; return (SpecRecSig noAnn new_v s, emptyFVs) }
+
renameSig ctxt (FixSig _ fsig)
= do { new_fsig <- rnSrcFixityDecl ctxt fsig
; return (FixSig noAnn new_fsig, emptyFVs) }
@@ -1138,6 +1142,10 @@ okHsSig ctxt (L _ sig)
(InlineSig {}, HsBootCtxt {}) -> False
(InlineSig {}, _) -> True
+ (SpecRecSig {}, HsBootCtxt {}) -> False
+ (SpecRecSig {}, LocalBindCtxt {}) -> False
+ (SpecRecSig {}, _) -> True
+
(SpecSig {}, TopSigCtxt {}) -> True
(SpecSig {}, LocalBindCtxt {}) -> True
(SpecSig {}, InstDeclCtxt {}) -> True
@@ -1176,10 +1184,11 @@ findDupSigs sigs
expand_sig :: Sig GhcPs -> [(LocatedN RdrName, Sig GhcPs)] -- AZ
expand_sig sig@(FixSig _ (FixitySig _ ns _)) = zip ns (repeat sig)
expand_sig sig@(InlineSig _ n _) = [(n,sig)]
+ expand_sig sig@(SpecRecSig _ n _) = [(n,sig)]
expand_sig sig@(TypeSig _ ns _) = [(n,sig) | n <- ns]
expand_sig sig@(ClassOpSig _ _ ns _) = [(n,sig) | n <- ns]
expand_sig sig@(PatSynSig _ ns _ ) = [(n,sig) | n <- ns]
- expand_sig sig@(SCCFunSig (_, _) n _) = [(n,sig)]
+ expand_sig sig@(SCCFunSig (_, _) n _) = [(n,sig)]
expand_sig _ = []
matching_sig :: (LocatedN RdrName, Sig GhcPs) -> (LocatedN RdrName, Sig GhcPs) -> Bool --AZ
@@ -1194,6 +1203,7 @@ findDupSigs sigs
mtch (ClassOpSig _ d1 _ _) (ClassOpSig _ d2 _ _) = d1 == d2
mtch (PatSynSig _ _ _) (PatSynSig _ _ _) = True
mtch (SCCFunSig{}) (SCCFunSig{}) = True
+ mtch (SpecRecSig{}) (SpecRecSig{}) = True
mtch _ _ = False
-- Warn about multiple MINIMAL signatures
=====================================
compiler/GHC/Tc/Gen/Bind.hs
=====================================
@@ -637,6 +637,7 @@ tcPolyCheck prag_fn
poly_id2 = mkLocalId mono_name (idMult poly_id) (idType poly_id)
; spec_prags <- tcSpecPrags poly_id prag_sigs
; poly_id <- addInlinePrags poly_id prag_sigs
+ ; poly_id <- addSpecRecPrags poly_id prag_sigs
; mod <- getModule
; tick <- funBindTicks (locA nm_loc) poly_id mod prag_sigs
@@ -832,6 +833,7 @@ mkExport prag_fn residual insoluble qtvs theta
-- NB: poly_id has a zonked type
; poly_id <- addInlinePrags poly_id prag_sigs
+ ; poly_id <- addSpecRecPrags poly_id prag_sigs
; spec_prags <- tcSpecPrags poly_id prag_sigs
-- tcPrags requires a zonked poly_id
@@ -1514,7 +1516,10 @@ tcLhsSigId no_gen (name, sig)
newSigLetBndr :: LetBndrSpec -> Name -> TcIdSigInst -> TcM TcId
newSigLetBndr (LetGblBndr prags) name (TISI { sig_inst_sig = id_sig })
| CompleteSig { sig_bndr = poly_id } <- id_sig
- = addInlinePrags poly_id (lookupPragEnv prags name)
+ = do
+ poly_id <- addInlinePrags poly_id (lookupPragEnv prags name)
+ poly_id <- addSpecRecPrags poly_id (lookupPragEnv prags name)
+ return poly_id
newSigLetBndr no_gen name (TISI { sig_inst_tau = tau })
= newLetBndr no_gen name ManyTy tau
-- Binders with a signature are currently always of multiplicity
=====================================
compiler/GHC/Tc/Gen/Pat.hs
=====================================
@@ -32,7 +32,7 @@ import GHC.Hs.Syn.Type
import GHC.Rename.Utils
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Zonk
-import GHC.Tc.Gen.Sig( TcPragEnv, lookupPragEnv, addInlinePrags )
+import GHC.Tc.Gen.Sig
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Instantiate
import GHC.Types.FieldLabel
@@ -265,7 +265,11 @@ newLetBndr LetLclBndr name w ty
= do { mono_name <- cloneLocalName name
; return (mkLocalId mono_name w ty) }
newLetBndr (LetGblBndr prags) name w ty
- = addInlinePrags (mkLocalId name w ty) (lookupPragEnv prags name)
+ = do { let prags' = (lookupPragEnv prags name)
+ ; bndr <- addInlinePrags (mkLocalId name w ty) prags'
+ ; bndr <- addSpecRecPrags bndr prags'
+ ; return bndr
+ }
tc_sub_type :: PatEnv -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper
-- tcSubTypeET with the UserTypeCtxt specialised to GenSigCtxt
=====================================
compiler/GHC/Tc/Gen/Sig.hs
=====================================
@@ -22,7 +22,7 @@ module GHC.Tc.Gen.Sig(
TcPragEnv, emptyPragEnv, lookupPragEnv, extendPragEnv,
mkPragEnv, tcSpecPrags, tcSpecWrapper, tcImpPrags,
- addInlinePrags, addInlinePragArity
+ addInlinePrags, addInlinePragArity, addSpecRecPrags
) where
import GHC.Prelude
@@ -56,8 +56,7 @@ import GHC.Core.TyCo.Rep( mkNakedFunTy )
import GHC.Types.Error
import GHC.Types.Var ( TyVar, Specificity(..), tyVarKind, binderVars, invisArgTypeLike )
-import GHC.Types.Id ( Id, idName, idType, setIdPragmaInfo
- , mkLocalId, realIdUnfolding )
+import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Basic
import GHC.Types.Name
@@ -592,6 +591,7 @@ mkPragEnv sigs binds
get_sig sig@(L _ (SpecSig _ (L _ nm) _ _)) = Just (nm, add_arity nm sig)
get_sig sig@(L _ (InlineSig _ (L _ nm) _)) = Just (nm, add_arity nm sig)
get_sig sig@(L _ (SCCFunSig _ (L _ nm) _)) = Just (nm, sig)
+ get_sig sig@(L _ (SpecRecSig _ (L _ nm) _)) = Just (nm, sig)
get_sig _ = Nothing
add_arity n sig -- Adjust inl_sat field to match visible arity of function
@@ -633,7 +633,7 @@ computePragmaInfo info (prag:prags)
-- INLINEABLE + NOINLINE
| NoInline{} <- new_spec
, isDefaultActivationPragma old_prag
- -> computePragmaInfo (mkPragInfo prag True) prags
+ -> computePragmaInfo (mkPragInfo prag True spec_rec) prags
| otherwise -> Nothing
NoInline{}
-- NOINLINE + INLINEABLE
@@ -645,12 +645,13 @@ computePragmaInfo info (prag:prags)
Opaque{} -> Nothing
NoUserInlinePrag ->
computePragmaInfo
- (mkPragInfo prag (isInlinablePragma prag))
+ (mkPragInfo prag (isInlinablePragma prag) spec_rec)
prags
where
old_prag = pragInfoInline $ info
old_spec = inl_inline old_prag
new_spec = inl_inline prag
+ spec_rec = pragSpecRec info
@@ -659,7 +660,7 @@ addInlinePrags :: TcId -> [LSig GhcRn] -> TcM TcId
addInlinePrags poly_id prags_for_me
| inl@(L _ inl_prag) : inls <- inl_prags
= do { traceTc "addInlinePrag" (ppr poly_id $$ ppr inl_prag)
- ; let init_info = (mkPragInfo inl_prag $ isInlinablePragma inl_prag)
+ ; let init_info = mkPragInfo inl_prag (isInlinablePragma inl_prag) (idSpecRec poly_id)
m_prag_info = computePragmaInfo
init_info
(map unLoc inls)
@@ -687,6 +688,15 @@ addInlinePrags poly_id prags_for_me
let dia = TcRnMultipleInlinePragmas poly_id inl1 (inl2 NE.:| inls)
in addDiagnosticTc dia
+-----------------
+addSpecRecPrags :: TcId -> [LSig GhcRn] -> TcM TcId
+addSpecRecPrags poly_id prags_for_me
+ = case spec_rec of
+ [] -> return poly_id
+ [L _ act] -> return $ setHasSpecRec poly_id (Just act)
+ (_:_) -> error "TODO: Duplicate SpecRec"
+ where
+ spec_rec = [L loc act | L loc (SpecRecSig _ _ act) <- prags_for_me]
{- Note [Pattern synonym inline arity]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -829,7 +839,7 @@ tcSpecPrags poly_id prag_sigs
where
spec_sigs = filter isSpecLSig prag_sigs
bad_sigs = filter is_bad_sig prag_sigs
- is_bad_sig s = not (isSpecLSig s || isInlineLSig s || isSCCFunSig s)
+ is_bad_sig s = not (isSpecLSig s || isSpecRecLSig s || isInlineLSig s || isSCCFunSig s)
warn_discarded_sigs bad_sigs_ne
= let dia = TcRnUnexpectedPragmas poly_id bad_sigs_ne
=====================================
compiler/GHC/Tc/TyCl/Class.hs
=====================================
@@ -253,6 +253,7 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn
global_dm_id <- tcLookupId dm_name
; global_dm_id <- addInlinePrags global_dm_id prags
+ ; global_dm_id <- addSpecRecPrags global_dm_id prags
; local_dm_name <- newNameAt (getOccName sel_name) bndr_loc
-- Base the local_dm_name on the selector name, because
-- type errors from tcInstanceMethodBody come from here
=====================================
compiler/GHC/Tc/TyCl/Instance.hs
=====================================
@@ -1900,6 +1900,7 @@ tcMethodBody clas tyvars dfun_ev_vars inst_tys
tcMethodBodyHelp sig_fn sel_id local_meth_id (L bind_loc lm_bind)
; global_meth_id <- addInlinePrags global_meth_id prags
+ ; global_meth_id <- addSpecRecPrags global_meth_id prags
; spec_prags <- tcSpecPrags global_meth_id prags
; let specs = mk_meth_spec_prags global_meth_id spec_inst_prags spec_prags
@@ -2113,7 +2114,11 @@ mkDefMethBind loc dfun_id clas sel_id dm_name
= []
-- Copy the inline pragma (if any) from the default method
-- to this version. Note [INLINE and default methods]
-
+ spec_rec = idSpecRec dm_id
+ spec_rec_prag | Just act <- spec_rec
+ = [noLocA (SpecRecSig noAnn fn act)]
+ | otherwise
+ = []
fn = noLocA (idName sel_id)
visible_inst_tys = [ ty | (tcb, ty) <- tyConBinders (classTyCon clas) `zip` inst_tys
, tyConBinderForAllTyFlag tcb /= Inferred ]
@@ -2127,7 +2132,7 @@ mkDefMethBind loc dfun_id clas sel_id dm_name
(vcat [ppr clas <+> ppr inst_tys,
nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
- ; return (bind, inline_prags) }
+ ; return (bind, spec_rec_prag ++ inline_prags) }
where
(_, _, _, inst_tys) = tcSplitDFunTy (idType dfun_id)
=====================================
compiler/GHC/Tc/TyCl/PatSyn.hs
=====================================
@@ -26,8 +26,7 @@ import GHC.Tc.Utils.TcMType
import GHC.Tc.Utils.Zonk
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
-import GHC.Tc.Gen.Sig ( TcPragEnv, emptyPragEnv, completeSigFromId, lookupPragEnv
- , addInlinePrags, addInlinePragArity )
+import GHC.Tc.Gen.Sig
import GHC.Tc.Solver
import GHC.Tc.Utils.Unify
import GHC.Tc.Utils.TcType
@@ -851,9 +850,11 @@ tcPatSynMatcher (L loc ps_name) lpat prag_fn
-- Add INLINE pragmas; see Note [Pragmas for pattern synonyms]
-- NB: prag_fn is keyed by the PatSyn Name, not the (internal) matcher name
- ; matcher_prag_id <- addInlinePrags matcher_id $
- map (addInlinePragArity matcher_arity) $
- lookupPragEnv prag_fn ps_name
+ ; let prags = map (addInlinePragArity matcher_arity) $
+ lookupPragEnv prag_fn ps_name
+
+ ; matcher_prag_id <- addInlinePrags matcher_id prags
+ ; matcher_prag_id <- addSpecRecPrags matcher_prag_id prags
; let bind = FunBind{ fun_id = L loc matcher_prag_id
, fun_matches = mg
@@ -949,9 +950,11 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name)
-- Add INLINE pragmas; see Note [Pragmas for pattern synonyms]
-- NB: prag_fn is keyed by the PatSyn Name, not the (internal) builder name
- ; builder_id <- addInlinePrags builder_id $
- map (addInlinePragArity builder_arity) $
- lookupPragEnv prag_fn ps_name
+ ; let prags = map (addInlinePragArity builder_arity) $
+ lookupPragEnv prag_fn ps_name
+ ; builder_id <- addInlinePrags builder_id prags
+ ; builder_id <- addSpecRecPrags builder_id prags
+
; let match_group' | need_dummy_arg = add_dummy_arg match_group
| otherwise = match_group
=====================================
compiler/GHC/Types/Basic.hs
=====================================
@@ -1711,6 +1711,15 @@ instance Binary Activation where
ab <- get bh
return (ActiveAfter src ab)
+instance NFData Activation where
+ rnf act = case act of
+ AlwaysActive -> ()
+ NeverActive -> ()
+ ActiveBefore src phase -> src `deepseq` phase `deepseq` ()
+ ActiveAfter src phase -> src `deepseq` phase `deepseq` ()
+ FinalActive -> ()
+
+
instance Outputable RuleMatchInfo where
ppr ConLike = text "CONLIKE"
ppr FunLike = text "FUNLIKE"
=====================================
compiler/GHC/Types/Id.hs
=====================================
@@ -83,7 +83,8 @@ module GHC.Types.Id (
-- ** Inline pragma stuff
idPragmaInfo, idInlinePragma, idHasInlineable, setInlinePragma,
- setIdPragmaInfo, modifyInlinePragma, setHasInlineable,
+ idHasSpecRec, idSpecRec,
+ setIdPragmaInfo, modifyInlinePragma, setHasInlineable, setHasSpecRec,
idInlineActivation, setInlineActivation, idRuleMatchInfo,
-- ** One-shot lambdas
@@ -176,6 +177,7 @@ infixl 1 `setIdUnfolding`,
`setIdSpecialisation`,
`setInlinePragma`,
`setHasInlineable`,
+ `setHasSpecRec`,
`setIdPragmaInfo`,
`setInlineActivation`,
`idCafInfo`,
@@ -899,6 +901,12 @@ idInlinePragma id = inlinePragInfo (idInfo id)
idHasInlineable :: Id -> Bool
idHasInlineable id = inlineableInfo (idInfo id)
+idHasSpecRec :: Id -> Bool
+idHasSpecRec id = isJust $ specRecInfo (idInfo id)
+
+idSpecRec :: Id -> Maybe Activation
+idSpecRec id = specRecInfo (idInfo id)
+
idPragmaInfo :: Id -> PragInfo
idPragmaInfo id = pragInfo (idInfo id)
@@ -908,6 +916,9 @@ setInlinePragma id prag = modifyIdInfo (`setInlinePragInfo` prag) id
setHasInlineable :: Id -> Bool -> Id
setHasInlineable id inlineable = modifyIdInfo (`setHasInlineableInfo` inlineable) id
+setHasSpecRec :: Id -> (Maybe Activation) -> Id
+setHasSpecRec id spec_rec = modifyIdInfo (`setHasSpecRecInfo` spec_rec) id
+
setIdPragmaInfo :: Id -> PragInfo -> Id
setIdPragmaInfo id pragInfo = modifyIdInfo (`setPragInfo` pragInfo) id
@@ -1053,6 +1064,7 @@ transferPolyIdInfo old_id abstract_wrt new_id
old_arity = arityInfo old_info
old_inline_prag = inlinePragInfo old_info
old_unf_info = inlineableInfo old_info
+ old_spec_rec = specRecInfo old_info
old_occ_info = occInfo old_info
new_arity = old_arity + arity_increase
new_occ_info = zapOccTailCallInfo old_occ_info
@@ -1077,6 +1089,7 @@ transferPolyIdInfo old_id abstract_wrt new_id
transfer new_info = new_info `setArityInfo` new_arity
`setInlinePragInfo` old_inline_prag
`setHasInlineableInfo` old_unf_info
+ `setHasSpecRecInfo` old_spec_rec
`setOccInfo` new_occ_info
`setDmdSigInfo` new_strictness
`setCprSigInfo` new_cpr
=====================================
compiler/GHC/Types/Id/Info.hs
=====================================
@@ -49,10 +49,11 @@ module GHC.Types.Id.Info (
-- ** Unfolding Info
realUnfoldingInfo, unfoldingInfo, setUnfoldingInfo, hasInlineUnfolding,
inlinePragInfo, setInlinePragInfo, inlineableInfo, setHasInlineableInfo,
+ specRecInfo, setHasSpecRecInfo,
-- ** The PragInfo type
setPragInfo, pragInfo, PragInfo, mkPragInfo,
- pragInfoInline, pragHasInlineable,
+ pragInfoInline, pragHasInlineable, pragSpecRec,
setPragInfoInline,
-- ** The OccInfo type
@@ -117,6 +118,7 @@ infixl 1 `setRuleInfo`,
`setArityInfo`,
`setInlinePragInfo`,
`setHasInlineableInfo`,
+ `setHasSpecRecInfo`,
`setUnfoldingInfo`,
`setOneShotInfo`,
`setOccInfo`,
@@ -439,6 +441,9 @@ inlinePragInfo = pragInfoInline . pragInfo
inlineableInfo :: IdInfo -> Bool
inlineableInfo = pragHasInlineable . pragInfo
+specRecInfo :: IdInfo -> (Maybe Activation)
+specRecInfo = pragSpecRec . pragInfo
+
-- | Info about a lambda-bound variable, if the 'Id' is one
oneShotInfo :: IdInfo -> OneShotInfo
oneShotInfo = bitfieldGetOneShotInfo . bitfield
@@ -474,6 +479,9 @@ setInlinePragInfo :: IdInfo -> InlinePragma -> IdInfo
setInlinePragInfo info pr = pr `seq` info { pragInfo = setPragInfoInline pr (pragInfo info) }
setHasInlineableInfo :: IdInfo -> Bool -> IdInfo
setHasInlineableInfo info pr = pr `seq` info { pragInfo = setPragInfoUnf pr (pragInfo info) }
+setHasSpecRecInfo :: IdInfo -> (Maybe Activation) -> IdInfo
+setHasSpecRecInfo info pr = pr `seq` info { pragInfo = setPragInfoSpecRec pr (pragInfo info) }
+
-- Try to avoid space leaks by seq'ing
-- | Essentially returns the 'realUnfoldingInfo' field, but does not expose the
@@ -641,18 +649,21 @@ ppArityInfo n = hsep [text "Arity", int n]
-- entirely as a way to inhibit inlining until we want it
data PragInfo = PragInfo
{ -- | INLINE etc info
- pragInfoInline :: !InlinePragma
+ pragInfoInline :: InlinePragma
, -- | Should we keep the unfolding?
- pragHasInlineable :: !Bool
+ pragHasInlineable :: Bool
+ , -- | Allow specialisation transitively?
+ pragSpecRec :: (Maybe Activation)
} deriving Eq
instance Outputable PragInfo where
ppr prag = text "PragInfo=" <> braces
(ppr (pragInfoInline prag) <> comma <>
- text "HasInlineable:" <> ppr (pragHasInlineable prag))
+ text "HasInlineable:" <> ppr (pragHasInlineable prag) <> comma <>
+ text "SpecRec:" <> ppr (pragSpecRec prag))
--- | mkPragInfo inl_prag has_inlineable
-mkPragInfo :: InlinePragma -> Bool -> PragInfo
+-- | mkPragInfo inl_prag has_inlineable spec_rec
+mkPragInfo :: InlinePragma -> Bool -> (Maybe Activation) -> PragInfo
mkPragInfo = PragInfo
setPragInfoInline :: InlinePragma -> PragInfo -> PragInfo
@@ -661,14 +672,21 @@ setPragInfoInline inl prag_info = prag_info { pragInfoInline = inl }
setPragInfoUnf :: Bool -> PragInfo -> PragInfo
setPragInfoUnf keep prag_info = prag_info { pragHasInlineable = keep }
+setPragInfoSpecRec :: (Maybe Activation) -> PragInfo -> PragInfo
+setPragInfoSpecRec spec_rec prag_info = prag_info { pragSpecRec = spec_rec }
+
defaultPragInfo :: PragInfo
defaultPragInfo = PragInfo
{ pragInfoInline = defaultInlinePragma
- , pragHasInlineable = defaultHasInlineableInfo }
+ , pragHasInlineable = defaultHasInlineableInfo
+ , pragSpecRec = defaultSpecRecInfo }
defaultHasInlineableInfo :: Bool
defaultHasInlineableInfo = False
+defaultSpecRecInfo :: Maybe Activation
+defaultSpecRecInfo = Nothing
+
{-
************************************************************************
* *
=====================================
compiler/GHC/Types/SourceText.hs
=====================================
@@ -39,6 +39,8 @@ import Data.Data
import GHC.Real ( Ratio(..) )
import GHC.Types.SrcLoc
+import Control.DeepSeq
+
{-
Note [Pragma source text]
~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -121,6 +123,10 @@ instance Binary SourceText where
return (SourceText s)
_ -> panic $ "Binary SourceText:" ++ show h
+instance NFData SourceText where
+ rnf NoSourceText = ()
+ rnf (SourceText s) = rnf s
+
-- | Special combinator for showing string literals.
pprWithSourceText :: SourceText -> SDoc -> SDoc
pprWithSourceText NoSourceText d = d
=====================================
compiler/Language/Haskell/Syntax/Binds.hs
=====================================
@@ -36,7 +36,7 @@ import GHC.Data.Bag (Bag)
import GHC.Types.Basic (InlinePragma, Activation)
import GHC.Data.BooleanFormula (LBooleanFormula)
-import GHC.Types.SourceText (StringLiteral, SourceText)
+import GHC.Types.SourceText (StringLiteral)
import Data.Void
import Data.Bool
@@ -482,6 +482,10 @@ isSpecLSig :: forall p. UnXRec p => LSig p -> Bool
isSpecLSig (unXRec @p -> SpecSig {}) = True
isSpecLSig _ = False
+isSpecRecLSig :: forall p. UnXRec p => LSig p -> Bool
+isSpecRecLSig (unXRec @p -> SpecRecSig {}) = True
+isSpecRecLSig _ = False
+
isSpecInstLSig :: forall p. UnXRec p => LSig p -> Bool
isSpecInstLSig (unXRec @p -> SpecInstSig {}) = True
isSpecInstLSig _ = False
@@ -491,6 +495,7 @@ isPragLSig :: forall p. UnXRec p => LSig p -> Bool
isPragLSig (unXRec @p -> SpecSig {}) = True
isPragLSig (unXRec @p -> InlineSig {}) = True
isPragLSig (unXRec @p -> SCCFunSig {}) = True
+isPragLSig (unXRec @p -> SpecRecSig {}) = True
isPragLSig (unXRec @p -> CompleteMatchSig {}) = True
isPragLSig _ = False
=====================================
compiler/ghc.cabal.in
=====================================
@@ -330,6 +330,7 @@ Library
GHC.Core.Opt.Simplify.Utils
GHC.Core.Opt.SpecConstr
GHC.Core.Opt.Specialise
+ GHC.Core.Opt.SpecRec
GHC.Core.Opt.StaticArgs
GHC.Core.Opt.Stats
GHC.Core.Opt.WorkWrap
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1c93cdb6a09ac0c0fd711754da0b7780dda4f65b
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1c93cdb6a09ac0c0fd711754da0b7780dda4f65b
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/20230106/d8e739e9/attachment-0001.html>
More information about the ghc-commits
mailing list