summaryrefslogtreecommitdiff
path: root/compiler/GHC/Tc
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Tc')
-rw-r--r--compiler/GHC/Tc/Gen/Bind.hs7
-rw-r--r--compiler/GHC/Tc/Gen/Pat.hs8
-rw-r--r--compiler/GHC/Tc/Gen/Sig.hs24
-rw-r--r--compiler/GHC/Tc/TyCl/Class.hs1
-rw-r--r--compiler/GHC/Tc/TyCl/Instance.hs9
-rw-r--r--compiler/GHC/Tc/TyCl/PatSyn.hs19
6 files changed, 48 insertions, 20 deletions
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
View Lorry Controller Status