First PoC partially donewip/andreask/spec-transitive

29 files changed, 451 insertions, 54 deletions

diff --git a/compiler/GHC/Core.hs b/compiler/GHC/Core.hs
index 23306a29d0..f613b4c4db 100644
--- a/compiler/GHC/Core.hs
+++ b/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]
diff --git a/compiler/GHC/Core/FVs.hs b/compiler/GHC/Core/FVs.hs
index 65b654356e..74bed60e38 100644
--- a/compiler/GHC/Core/FVs.hs
+++ b/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
diff --git a/compiler/GHC/Core/Opt/Simplify/Iteration.hs b/compiler/GHC/Core/Opt/Simplify/Iteration.hs
index 82d84d0012..8dabac1888 100644
--- a/compiler/GHC/Core/Opt/Simplify/Iteration.hs
+++ b/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
diff --git a/compiler/GHC/Core/Opt/SpecRec.hs b/compiler/GHC/Core/Opt/SpecRec.hs
new file mode 100644
index 0000000000..aa40e54e9e
--- /dev/null
+++ b/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
+  }
+
diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs
index 73024ed79b..10ab7f0717 100644
--- a/compiler/GHC/Core/Opt/Specialise.hs
+++ b/compiler/GHC/Core/Opt/Specialise.hs
@@ -34,6 +34,7 @@ import GHC.Core.Utils     ( exprIsTrivial
 import GHC.Core.FVs
 import GHC.Core.TyCo.FVs ( tyCoVarsOfTypeList )
 import GHC.Core.Opt.Arity( collectBindersPushingCo )
+import GHC.Core.Opt.SpecRec (transferSpecRecs)
 
 import GHC.Builtin.Types  ( unboxedUnitTy )
 
@@ -52,6 +53,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 )
@@ -636,10 +638,13 @@ Hence, the invariant is this:
 
 -- | Specialise calls to type-class overloaded functions occurring in a program.
 specProgram :: ModGuts -> CoreM ModGuts
-specProgram guts@(ModGuts { mg_module = this_mod
-                          , mg_rules  = local_rules
-                          , mg_binds  = binds })
+specProgram guts_in
   = do { dflags   <- getDynFlags
+
+       ; let guts@(ModGuts  { mg_module = this_mod
+                            , mg_rules  = local_rules
+                            , mg_binds  = binds }) = transferSpecRecs guts_in
+
        ; rule_env <- initRuleEnv guts
                      -- See Note [Fire rules in the specialiser]
 
@@ -1613,6 +1618,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 +1772,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 +1784,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
 
diff --git a/compiler/GHC/Core/Opt/WorkWrap.hs b/compiler/GHC/Core/Opt/WorkWrap.hs
index 69ed8331f3..874e44e338 100644
--- a/compiler/GHC/Core/Opt/WorkWrap.hs
+++ b/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
diff --git a/compiler/GHC/Core/Ppr.hs b/compiler/GHC/Core/Ppr.hs
index 9f7bb747b3..85ae07fc6c 100644
--- a/compiler/GHC/Core/Ppr.hs
+++ b/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)
diff --git a/compiler/GHC/CoreToIface.hs b/compiler/GHC/CoreToIface.hs
index d2ad8f161d..5aff06bc47 100644
--- a/compiler/GHC/CoreToIface.hs
+++ b/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
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index 976cf12b55..4a48e60f25 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/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
diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs
index 523fa542c7..acc74d3727 100644
--- a/compiler/GHC/HsToCore.hs
+++ b/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)
         }}}}
 
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index 13595a8f00..82d65dc6f0 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/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))]
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index 8f97f51833..685bc31bbe 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/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
diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs
index 0d001e94d9..73ba71240f 100644
--- a/compiler/GHC/Iface/Recomp.hs
+++ b/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
diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs
index f57fefd4e7..d48d547dc7 100644
--- a/compiler/GHC/Iface/Syntax.hs
+++ b/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
diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs
index cb5458899a..b19e3c531c 100644
--- a/compiler/GHC/Iface/Tidy.hs
+++ b/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
diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs
index b065b24383..695362d07a 100644
--- a/compiler/GHC/IfaceToCore.hs
+++ b/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)
diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs
index aa3f33b8da..72bdbdcd24 100644
--- a/compiler/GHC/Rename/Bind.hs
+++ b/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
diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs
index cf2cac142b..3d78ac9e02 100644
--- a/compiler/GHC/Tc/Gen/Bind.hs
+++ b/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
diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs
index 35c2463cb6..e41845a395 100644
--- a/compiler/GHC/Tc/Gen/Pat.hs
+++ b/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
diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs
index 4163d06f6f..161a0cbb1b 100644
--- a/compiler/GHC/Tc/Gen/Sig.hs
+++ b/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
diff --git a/compiler/GHC/Tc/TyCl/Class.hs b/compiler/GHC/Tc/TyCl/Class.hs
index 9da7b05192..03ac19e3f6 100644
--- a/compiler/GHC/Tc/TyCl/Class.hs
+++ b/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
diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs
index f3980ed481..08d8f349e5 100644
--- a/compiler/GHC/Tc/TyCl/Instance.hs
+++ b/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)
 
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs
index 4c691185aa..3b6e6bceda 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs
+++ b/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
diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs
index 253431ca6a..f35ca891d3 100644
--- a/compiler/GHC/Types/Basic.hs
+++ b/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"
diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs
index f186fc3c5b..2b1609773b 100644
--- a/compiler/GHC/Types/Id.hs
+++ b/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
diff --git a/compiler/GHC/Types/Id/Info.hs b/compiler/GHC/Types/Id/Info.hs
index 7fb83d8c20..f0a3cabb46 100644
--- a/compiler/GHC/Types/Id/Info.hs
+++ b/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
+
 {-
 ************************************************************************
 *                                                                      *
diff --git a/compiler/GHC/Types/SourceText.hs b/compiler/GHC/Types/SourceText.hs
index 72c77dec95..4fec99d7d6 100644
--- a/compiler/GHC/Types/SourceText.hs
+++ b/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
diff --git a/compiler/Language/Haskell/Syntax/Binds.hs b/compiler/Language/Haskell/Syntax/Binds.hs
index c8d3e33fb6..2cd06c536a 100644
--- a/compiler/Language/Haskell/Syntax/Binds.hs
+++ b/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
 
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index ab320bfcac..a8f5ae88e1 100644
--- a/compiler/ghc.cabal.in
+++ b/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