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
This diff is collapsed.
......@@ -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