Commit efa7b3a4 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Add NOINLINE for hs-boot functions

This fixes Trac #10083.

The key change is in TcBinds.tcValBinds, where we construct
the prag_fn.  With this patch we add a NOINLINE pragma for
any functions that were exported by the hs-boot file for this
module.

See Note [Inlining and hs-boot files], and #10083, for details.

The commit touches several other files becuase I also changed the
representation of the "pragma function" from a function TcPragFun
to an environment, TcPragEnv. This makes it easer to extend
during construction.
parent 3c44a46b
......@@ -9,9 +9,10 @@
module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds,
tcHsBootSigs, tcPolyCheck,
PragFun, tcSpecPrags, tcSpecWrapper,
tcVectDecls,
TcSigInfo(..), TcSigFun, mkPragFun,
tcSpecPrags, tcSpecWrapper,
tcVectDecls,
TcSigInfo(..), TcSigFun,
TcPragEnv, mkPragEnv,
instTcTySig, instTcTySigFromId, findScopedTyVars,
badBootDeclErr, mkExport ) where
......@@ -292,6 +293,53 @@ and will give a 'wrongThingErr' as a result. But the lookup of A won't fail.
The _|_ (= panic "fakePatSynCon") works because the wrongThingErr call, in
tcTyVar, doesn't look inside the TcTyThing.
Note [Inlining and hs-boot files]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this example (Trac #10083):
---------- RSR.hs-boot ------------
module RSR where
data RSR
eqRSR :: RSR -> RSR -> Bool
---------- SR.hs ------------
module SR where
import {-# SOURCE #-} RSR
data SR = MkSR RSR
eqSR (MkSR r1) (MkSR r2) = eqRSR r1 r2
---------- RSR.hs ------------
module RSR where
import SR
data RSR = MkRSR SR -- deriving( Eq )
eqRSR (MkRSR s1) (MkRSR s2) = (eqSR s1 s2)
foo x y = not (eqRSR x y)
When compiling RSR we get this code
RSR.eqRSR :: RSR -> RSR -> Bool
RSR.eqRSR = \ (ds1 :: RSR.RSR) (ds2 :: RSR.RSR) ->
case ds1 of _ { RSR.MkRSR s1 ->
case ds2 of _ { RSR.MkRSR s2 ->
SR.eqSR s1 s2 }}
RSR.foo :: RSR -> RSR -> Bool
RSR.foo = \ (x :: RSR) (y :: RSR) -> not (RSR.eqRSR x y)
Now, when optimising foo:
Inline eqRSR (small, non-rec)
Inline eqSR (small, non-rec)
but the result of inlining eqSR from SR is another call to eqRSR, so
everything repeats. Neither eqSR nor eqRSR are (apparently) loop
breakers.
Solution: when compiling RSR, add a NOINLINE pragma to every function
exported by the boot-file for RSR (if it exists).
ALAS: doing so makes the boostrappted GHC itself slower by 8% overall
(on Trac #9872a-d, and T1969. So I un-did this change, and
parked it for now. Sigh.
-}
tcValBinds :: TopLevelFlag
......@@ -305,7 +353,19 @@ tcValBinds top_lvl binds sigs thing_inside
-- See Note [Placeholder PatSyn kinds]
tcTySigs sigs
; let prag_fn = mkPragFun sigs (foldr (unionBags . snd) emptyBag binds)
; _self_boot <- tcSelfBootInfo
; let prag_fn = mkPragEnv sigs (foldr (unionBags . snd) emptyBag binds)
-- ------- See Note [Inlining and hs-boot files] (change parked) --------
-- prag_fn | isTopLevel top_lvl -- See Note [Inlining and hs-boot files]
-- , SelfBoot { sb_ids = boot_id_names } <- self_boot
-- = foldNameSet add_no_inl prag_fn1 boot_id_names
-- | otherwise
-- = prag_fn1
-- add_no_inl boot_id_name prag_fn
-- = extendPragEnv prag_fn (boot_id_name, no_inl_sig boot_id_name)
-- no_inl_sig name = L boot_loc (InlineSig (L boot_loc name) neverInlinePragma)
-- boot_loc = mkGeneralSrcSpan (fsLit "The hs-boot file for this module")
-- Extend the envt right away with all the Ids
-- declared with complete type signatures
......@@ -327,7 +387,7 @@ tcValBinds top_lvl binds sigs thing_inside
= AGlobal $ AConLike $ PatSynCon $ panic "fakePatSynCon"
------------------------
tcBindGroups :: TopLevelFlag -> TcSigFun -> PragFun
tcBindGroups :: TopLevelFlag -> TcSigFun -> TcPragEnv
-> [(RecFlag, LHsBinds Name)] -> TcM thing
-> TcM ([(RecFlag, LHsBinds TcId)], thing)
-- Typecheck a whole lot of value bindings,
......@@ -348,7 +408,7 @@ tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside
------------------------
tc_group :: forall thing.
TopLevelFlag -> TcSigFun -> PragFun
TopLevelFlag -> TcSigFun -> TcPragEnv
-> (RecFlag, LHsBinds Name) -> TcM thing
-> TcM ([(RecFlag, LHsBinds TcId)], thing)
......@@ -408,7 +468,7 @@ recursivePatSynErr binds
pprLoc loc
tc_single :: forall thing.
TopLevelFlag -> TcSigFun -> PragFun
TopLevelFlag -> TcSigFun -> TcPragEnv
-> LHsBind Name -> TcM thing
-> TcM (LHsBinds TcId, thing)
tc_single _top_lvl sig_fn _prag_fn (L _ (PatSynBind psb@PSB{ psb_id = L _ name })) thing_inside
......@@ -456,7 +516,7 @@ mkEdges sig_fn binds
, bndr <- collectHsBindBinders bind ]
------------------------
tcPolyBinds :: TopLevelFlag -> TcSigFun -> PragFun
tcPolyBinds :: TopLevelFlag -> TcSigFun -> TcPragEnv
-> RecFlag -- Whether the group is really recursive
-> RecFlag -- Whether it's recursive after breaking
-- dependencies based on type signatures
......@@ -511,7 +571,7 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list
tcPolyNoGen -- No generalisation whatsoever
:: RecFlag -- Whether it's recursive after breaking
-- dependencies based on type signatures
-> PragFun -> TcSigFun
-> TcPragEnv -> TcSigFun
-> [LHsBind Name]
-> TcM (LHsBinds TcId, [TcId])
......@@ -526,7 +586,7 @@ tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list
= do { mono_ty' <- zonkTcType (idType mono_id)
-- Zonk, mainly to expose unboxed types to checkStrictBinds
; let mono_id' = setIdType mono_id mono_ty'
; _specs <- tcSpecPrags mono_id' (prag_fn name)
; _specs <- tcSpecPrags mono_id' (lookupPragEnv prag_fn name)
; return mono_id' }
-- NB: tcPrags generates error messages for
-- specialisation pragmas for non-overloaded sigs
......@@ -536,7 +596,7 @@ tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list
------------------
tcPolyCheck :: RecFlag -- Whether it's recursive after breaking
-- dependencies based on type signatures
-> PragFun
-> TcPragEnv
-> TcSigInfo
-> LHsBind Name
-> TcM (LHsBinds TcId, [TcId])
......@@ -554,7 +614,7 @@ tcPolyCheck rec_tc prag_fn
do { ev_vars <- newEvVars theta
; let ctxt = FunSigCtxt name warn_redundant
skol_info = SigSkol ctxt (mkPhiTy theta tau)
prag_sigs = prag_fn name
prag_sigs = lookupPragEnv prag_fn name
tvs = map snd tvs_w_scoped
; (ev_binds, (binds', [mono_info]))
<- setSrcSpan loc $
......@@ -582,7 +642,7 @@ tcPolyCheck _rec_tc _prag_fn sig _bind
tcPolyInfer
:: RecFlag -- Whether it's recursive after breaking
-- dependencies based on type signatures
-> PragFun -> TcSigFun
-> TcPragEnv -> TcSigFun
-> Bool -- True <=> apply the monomorphism restriction
-> [LHsBind Name]
-> TcM (LHsBinds TcId, [TcId])
......@@ -612,7 +672,7 @@ tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list
-- poly_ids are guaranteed zonked by mkExport
--------------
mkExport :: PragFun
mkExport :: TcPragEnv
-> [TyVar] -> TcThetaType -- Both already zonked
-> MonoBindInfo
-> TcM (ABExport Id)
......@@ -668,7 +728,7 @@ mkExport prag_fn qtvs inferred_theta (poly_name, mb_sig, mono_id)
, abe_mono = mono_id
, abe_prags = SpecPrags spec_prags}) }
where
prag_sigs = prag_fn poly_name
prag_sigs = lookupPragEnv prag_fn poly_name
sig_ctxt = InfSigCtxt poly_name
mkInferredPolyId :: Name -> [TyVar] -> TcThetaType -> TcType -> TcM Id
......@@ -864,9 +924,9 @@ The basic idea is this:
f:: Num a => a -> b -> a
{-# SPECIALISE foo :: Int -> b -> Int #-}
We check that
(forall a. Num a => a -> a)
is more polymorphic than
We check that
(forall a. Num a => a -> a)
is more polymorphic than
Int -> Int
(for which we could use tcSubType, but see below), generating a HsWrapper
to connect the two, something like
......@@ -949,7 +1009,7 @@ Some wrinkles
f_spec = <f rhs> Int dNumInt
RULE: forall d. f Int d = f_spec
You can see this discarding happening in
You can see this discarding happening in
3. Note that the HsWrapper can transform *any* function with the right
type prefix
......@@ -959,32 +1019,32 @@ Some wrinkles
well as the dict. That's what goes on in TcInstDcls.mk_meth_spec_prags
-}
type PragFun = Name -> [LSig Name]
mkPragFun :: [LSig Name] -> LHsBinds Name -> PragFun
mkPragFun sigs binds = \n -> lookupNameEnv prag_env n `orElse` []
mkPragEnv :: [LSig Name] -> LHsBinds Name -> TcPragEnv
mkPragEnv sigs binds
= foldl extendPragEnv emptyNameEnv prs
where
prs = mapMaybe get_sig sigs
get_sig :: LSig Name -> Maybe (Located Name, LSig Name)
get_sig (L l (SpecSig nm ty inl)) = Just (nm, L l $ SpecSig nm ty (add_arity nm inl))
get_sig (L l (InlineSig nm inl)) = Just (nm, L l $ InlineSig nm (add_arity nm inl))
get_sig _ = Nothing
get_sig :: LSig Name -> Maybe (Name, LSig Name)
get_sig (L l (SpecSig lnm@(L _ nm) ty inl)) = Just (nm, L l $ SpecSig lnm ty (add_arity nm inl))
get_sig (L l (InlineSig lnm@(L _ nm) inl)) = Just (nm, L l $ InlineSig lnm (add_arity nm inl))
get_sig _ = Nothing
add_arity (L _ n) inl_prag -- Adjust inl_sat field to match visible arity of function
| Just ar <- lookupNameEnv ar_env n,
Inline <- inl_inline inl_prag = inl_prag { inl_sat = Just ar }
add_arity n inl_prag -- Adjust inl_sat field to match visible arity of function
| Inline <- inl_inline inl_prag
-- add arity only for real INLINE pragmas, not INLINABLE
| otherwise = inl_prag
prag_env :: NameEnv [LSig Name]
prag_env = foldl add emptyNameEnv prs
add env (L _ n,p) = extendNameEnv_Acc (:) singleton env n p
, Just ar <- lookupNameEnv ar_env n
= inl_prag { inl_sat = Just ar }
| otherwise
= inl_prag
-- ar_env maps a local to the arity of its definition
ar_env :: NameEnv Arity
ar_env = foldrBag lhsBindArity emptyNameEnv binds
extendPragEnv :: TcPragEnv -> (Name, LSig Name) -> TcPragEnv
extendPragEnv prag_fn (n, sig) = extendNameEnv_Acc (:) singleton prag_fn n sig
lhsBindArity :: LHsBind Name -> NameEnv Arity -> NameEnv Arity
lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env
= extendNameEnv env (unLoc id) (matchGroupArity ms)
......@@ -1008,15 +1068,15 @@ tcSpecPrags poly_id prag_sigs
bad_sigs = filter is_bad_sig prag_sigs
is_bad_sig s = not (isSpecLSig s || isInlineLSig s)
warn_discarded_sigs = warnPrags poly_id bad_sigs $
ptext (sLit "Discarding unexpected pragmas for")
warn_discarded_sigs
= addWarnTc (hang (ptext (sLit "Discarding unexpected pragmas for") <+> ppr poly_id)
2 (vcat (map (ppr . getLoc) bad_sigs)))
--------------
tcSpecPrag :: TcId -> Sig Name -> TcM [TcSpecPrag]
tcSpecPrag poly_id prag@(SpecSig fun_name hs_tys inl)
-- See Note [Handling SPECIALISE pragmas]
--
--
-- The Name fun_name in the SpecSig may not be the same as that of the poly_id
-- Example: SPECIALISE for a class method: the Name in the SpecSig is
-- for the selector Id, but the poly_id is something like $cop
......@@ -1044,7 +1104,7 @@ tcSpecPrag _ prag = pprPanic "tcSpecPrag" (ppr prag)
tcSpecWrapper :: UserTypeCtxt -> TcType -> TcType -> TcM HsWrapper
-- A simpler variant of tcSubType, used for SPECIALISE pragmas
-- See Note [Handling SPECIALISE pragmas], wrinkle 1
tcSpecWrapper ctxt poly_ty spec_ty
tcSpecWrapper ctxt poly_ty spec_ty
= do { (sk_wrap, inst_wrap)
<- tcGen ctxt spec_ty $ \ _ spec_tau ->
do { (inst_wrap, tau) <- deeplyInstantiate orig poly_ty
......@@ -1141,7 +1201,7 @@ tcVect (HsVect s name rhs)
-- turn the vectorisation declaration into a single non-recursive binding
; let bind = L loc $ mkTopFunBind name [mkSimpleMatch [] rhs]
sigFun = const Nothing
pragFun = mkPragFun [] (unitBag bind)
pragFun = emptyPragEnv
-- perform type inference (including generalisation)
; (binds, [id'], _) <- tcPolyInfer False True sigFun pragFun NonRecursive [bind]
......
......@@ -19,7 +19,7 @@ module TcClassDcl ( tcClassSigs, tcClassDecl2,
import HsSyn
import TcEnv
import TcPat( addInlinePrags, completeSigPolyId )
import TcPat( addInlinePrags, completeSigPolyId, lookupPragEnv, emptyPragEnv )
import TcEvidence( idHsWrapper )
import TcBinds
import TcUnify
......@@ -157,7 +157,7 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
-- And since ds is big, it doesn't get inlined, so we don't get good
-- default methods. Better to make separate AbsBinds for each
; let (tyvars, _, _, op_items) = classBigSig clas
prag_fn = mkPragFun sigs default_binds
prag_fn = mkPragEnv sigs default_binds
sig_fn = mkHsSigFun sigs
clas_tyvars = snd (tcSuperSkolTyVars tyvars)
pred = mkClassPred clas (mkTyVarTys clas_tyvars)
......@@ -171,7 +171,7 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
-- with redundant constraints; but not for DefMeth, where
-- the default method may well be 'error' or something
NoDefMeth -> do { mapM_ (addLocM (badDmPrag sel_id))
(prag_fn (idName sel_id))
(lookupPragEnv prag_fn (idName sel_id))
; return emptyBag }
tc_dm = tcDefMeth clas clas_tyvars this_dict
default_binds sig_fn prag_fn
......@@ -184,7 +184,7 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)
tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name
-> HsSigFun -> PragFun -> Id -> Name -> Bool
-> HsSigFun -> TcPragEnv -> Id -> Name -> Bool
-> TcM (LHsBinds TcId)
-- Generate code for polymorphic default methods only (hence DefMeth)
-- (Generic default methods have turned into instance decls by now.)
......@@ -250,8 +250,8 @@ tcDefMeth clas tyvars this_dict binds_in
| otherwise = pprPanic "tcDefMeth" (ppr sel_id)
where
sel_name = idName sel_id
prags = prag_fn sel_name
no_prag_fn _ = [] -- No pragmas for local_meth_id;
prags = lookupPragEnv prag_fn sel_name
no_prag_fn = emptyPragEnv -- No pragmas for local_meth_id;
-- they are all for meth_id
---------------
......
......@@ -18,7 +18,7 @@ import TcTyClsDecls
import TcClassDcl( tcClassDecl2,
HsSigFun, lookupHsSig, mkHsSigFun,
findMethodBind, instantiateMethod )
import TcPat ( addInlinePrags, completeSigPolyId )
import TcPat ( addInlinePrags, completeSigPolyId, lookupPragEnv, emptyPragEnv )
import TcRnMonad
import TcValidity
import TcMType
......@@ -1243,7 +1243,7 @@ tcMethods :: DFunId -> Class
-> [TcTyVar] -> [EvVar]
-> [TcType]
-> TcEvBinds
-> ([Located TcSpecPrag], PragFun)
-> ([Located TcSpecPrag], TcPragEnv)
-> [(Id, DefMeth)]
-> InstBindings Name
-> TcM ([Id], LHsBinds Id, Bag Implication)
......@@ -1362,7 +1362,7 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys
tcMethodBody :: Class -> [TcTyVar] -> [EvVar] -> [TcType]
-> TcEvBinds -> Bool
-> HsSigFun
-> ([LTcSpecPrag], PragFun)
-> ([LTcSpecPrag], TcPragEnv)
-> Id -> LHsBind Name -> SrcSpan
-> TcM (TcId, LHsBind Id, Maybe Implication)
tcMethodBody clas tyvars dfun_ev_vars inst_tys
......@@ -1376,7 +1376,7 @@ tcMethodBody clas tyvars dfun_ev_vars inst_tys
mkMethIds sig_fn clas tyvars dfun_ev_vars
inst_tys sel_id
; let prags = prag_fn (idName sel_id)
; let prags = lookupPragEnv prag_fn (idName sel_id)
-- A method always has a complete type signature, hence
-- it is safe to call completeSigPolyId
local_meth_id = completeSigPolyId local_meth_sig
......@@ -1413,7 +1413,7 @@ tcMethodBody clas tyvars dfun_ev_vars inst_tys
| is_derived = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys) thing
| otherwise = thing
no_prag_fn _ = [] -- No pragmas for local_meth_id;
no_prag_fn = emptyPragEnv -- No pragmas for local_meth_id;
-- they are all for meth_id
......@@ -1738,12 +1738,12 @@ Note that
-}
tcSpecInstPrags :: DFunId -> InstBindings Name
-> TcM ([Located TcSpecPrag], PragFun)
-> TcM ([Located TcSpecPrag], TcPragEnv)
tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags })
= do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $
filter isSpecInstLSig uprags
-- The filter removes the pragmas for methods
; return (spec_inst_prags, mkPragFun uprags binds) }
; return (spec_inst_prags, mkPragEnv uprags binds) }
------------------------------
tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag
......
......@@ -8,11 +8,12 @@ TcPat: Typechecking patterns
{-# LANGUAGE CPP, RankNTypes #-}
module TcPat ( tcLetPat, TcSigFun, TcPragFun
module TcPat ( tcLetPat, TcSigFun
, TcPragEnv, lookupPragEnv, emptyPragEnv
, TcSigInfo(..), TcPatSynInfo(..)
, findScopedTyVars, isPartialSig
, completeSigPolyId, completeSigPolyId_maybe
, LetBndrSpec(..), addInlinePrags, warnPrags
, LetBndrSpec(..), addInlinePrags
, tcPat, tcPats, newNoSigLetBndr
, addDataConStupidTheta, badFieldCon, polyPatSig ) where
......@@ -28,6 +29,7 @@ import Id
import Var
import Name
import NameSet
import NameEnv
import TcEnv
import TcMType
import TcValidity( arityErr )
......@@ -47,7 +49,9 @@ import SrcLoc
import Util
import Outputable
import FastString
import Maybes( orElse )
import Control.Monad
{-
************************************************************************
* *
......@@ -119,7 +123,7 @@ data LetBndrSpec
= LetLclBndr -- The binder is just a local one;
-- an AbsBinds will provide the global version
| LetGblBndr TcPragFun -- Generalisation plan is NoGen, so there isn't going
| LetGblBndr TcPragEnv -- Generalisation plan is NoGen, so there isn't going
-- to be an AbsBinds; So we must bind the global version
-- of the binder right away.
-- Oh, and here is the inline-pragma information
......@@ -132,9 +136,15 @@ inPatBind (PE { pe_ctxt = LetPat {} }) = True
inPatBind (PE { pe_ctxt = LamPat {} }) = False
---------------
type TcPragFun = Name -> [LSig Name]
type TcPragEnv = NameEnv [LSig Name]
type TcSigFun = Name -> Maybe TcSigInfo
emptyPragEnv :: TcPragEnv
emptyPragEnv = emptyNameEnv
lookupPragEnv :: TcPragEnv -> Name -> [LSig Name]
lookupPragEnv prag_fn n = lookupNameEnv prag_fn n `orElse` []
data TcSigInfo
= TcSigInfo {
sig_name :: Name, -- The binder name of the type signature. When
......@@ -327,7 +337,7 @@ tcPatBndr (PE { pe_ctxt = LetPat lookup_sig no_gen}) bndr_name pat_ty
| LetGblBndr prags <- no_gen
, Just sig <- lookup_sig bndr_name
, Just poly_id <- sig_poly_id sig
= do { bndr_id <- addInlinePrags poly_id (prags bndr_name)
= do { bndr_id <- addInlinePrags poly_id (lookupPragEnv prags bndr_name)
; traceTc "tcPatBndr(gbl,sig)" (ppr bndr_id $$ ppr (idType bndr_id))
; co <- unifyPatType (idType bndr_id) pat_ty
; return (co, bndr_id) }
......@@ -351,31 +361,35 @@ newNoSigLetBndr LetLclBndr name ty
=do { mono_name <- newLocalName name
; return (mkLocalId mono_name ty) }
newNoSigLetBndr (LetGblBndr prags) name ty
= addInlinePrags (mkLocalId name ty) (prags name)
= addInlinePrags (mkLocalId name ty) (lookupPragEnv prags name)
----------
addInlinePrags :: TcId -> [LSig Name] -> TcM TcId
addInlinePrags poly_id prags
= do { traceTc "addInlinePrags" (ppr poly_id $$ ppr prags)
; tc_inl inl_sigs }
where
inl_sigs = filter isInlineLSig prags
tc_inl [] = return poly_id
tc_inl (L loc (InlineSig _ prag) : other_inls)
= do { unless (null other_inls) (setSrcSpan loc warn_dup_inline)
; traceTc "addInlinePrag" (ppr poly_id $$ ppr prag)
; return (poly_id `setInlinePragma` prag) }
tc_inl _ = panic "tc_inl"
warn_dup_inline = warnPrags poly_id inl_sigs $
ptext (sLit "Duplicate INLINE pragmas for")
warnPrags :: Id -> [LSig Name] -> SDoc -> TcM ()
warnPrags id bad_sigs herald
= addWarnTc (hang (herald <+> quotes (ppr id))
2 (ppr_sigs bad_sigs))
| inl@(L _ prag) : inls <- inl_prags
= do { traceTc "addInlinePrag" (ppr poly_id $$ ppr prag)
; unless (null inls) (warn_multiple_inlines inl inls)
; return (poly_id `setInlinePragma` prag) }
| otherwise
= return poly_id
where
ppr_sigs sigs = vcat (map (ppr . getLoc) sigs)
inl_prags = [L loc prag | L loc (InlineSig _ prag) <- prags]
warn_multiple_inlines _ [] = return ()
warn_multiple_inlines inl1@(L loc prag1) (inl2@(L _ prag2) : inls)
| inlinePragmaActivation prag1 == inlinePragmaActivation prag2
, isEmptyInlineSpec (inlinePragmaSpec prag1)
= -- Tiresome: inl1 is put there by virtue of being in a hs-boot loop
-- and inl2 is a user NOINLINE pragma; we don't want to complain
warn_multiple_inlines inl2 inls
| otherwise
= setSrcSpan loc $
addWarnTc (hang (ptext (sLit "Multiple INLINE pragmas for") <+> ppr poly_id)
2 (vcat (ptext (sLit "Ignoring all but the first")
: map pp_inl (inl1:inl2:inls))))
pp_inl (L loc prag) = ppr prag <+> parens (ppr loc)
{-
Note [Typing patterns in pattern bindings]
......
......@@ -372,7 +372,7 @@ tcPatSynBuilderBind PSB{ psb_id = L loc name, psb_def = lpat
; sig <- instTcTySigFromId builder_id
-- See Note [Redundant constraints for builder]
; (builder_binds, _) <- tcPolyCheck NonRecursive (const []) sig (noLoc bind)
; (builder_binds, _) <- tcPolyCheck NonRecursive emptyPragEnv sig (noLoc bind)
; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds
; return builder_binds }
where
......
......@@ -126,3 +126,9 @@ T8221:
T5996:
$(RM) -f T5996.o T5996.hi
'$(TEST_HC)' $(TEST_HC_OPTS) -O -c T5996.hs -ddump-simpl -dsuppress-uniques -dsuppress-all | grep y2
T10083:
$(RM) -f T10083.o T10083.hi T10083.hi-boot T10083a.o T10083a.hi
'$(TEST_HC)' $(TEST_HC_OPTS) -c -O T10083.hs-boot
'$(TEST_HC)' $(TEST_HC_OPTS) -c -O T10083a.hs
'$(TEST_HC)' $(TEST_HC_OPTS) -c -O T10083.hs
module T10083 where
import T10083a
data RSR = MkRSR SR
eqRSR (MkRSR s1) (MkRSR s2) = (eqSR s1 s2)
foo x y = not (eqRSR x y)
module T10083 where
data RSR
eqRSR :: RSR -> RSR -> Bool
module T10083a where
import {-# SOURCE #-} T10083
data SR = MkSR RSR
eqSR (MkSR r1) (MkSR r2) = eqRSR r1 r2
......@@ -215,3 +215,7 @@ test('T10180', only_ways(['optasm']), compile, [''])
test('T10602', only_ways(['optasm']), multimod_compile, ['T10602','-v0'])
test('T10627', only_ways(['optasm']), compile, [''])
test('T10181', [expect_broken(10181), only_ways(['optasm'])], compile, [''])
test('T10083',
expect_broken(10083),
run_command,
['$MAKE -s --no-print-directory T10083'])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment