Add NOINLINE for hs-boot functions
authorSimon Peyton Jones <simonpj@microsoft.com>
Mon, 20 Jul 2015 15:18:05 +0000 (16:18 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Tue, 21 Jul 2015 13:21:40 +0000 (14:21 +0100)
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.

compiler/typecheck/TcBinds.hs
compiler/typecheck/TcClassDcl.hs
compiler/typecheck/TcInstDcls.hs
compiler/typecheck/TcPat.hs
compiler/typecheck/TcPatSyn.hs
testsuite/tests/simplCore/should_compile/Makefile
testsuite/tests/simplCore/should_compile/T10083.hs [new file with mode: 0644]
testsuite/tests/simplCore/should_compile/T10083.hs-boot [new file with mode: 0644]
testsuite/tests/simplCore/should_compile/T10083a.hs [new file with mode: 0644]
testsuite/tests/simplCore/should_compile/all.T

index de49c91..eab6c5c 100644 (file)
@@ -9,9 +9,10 @@
 
 module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds,
                  tcHsBootSigs, tcPolyCheck,
 
 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
 
                  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.
 
 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
 -}
 
 tcValBinds :: TopLevelFlag
@@ -305,7 +353,19 @@ tcValBinds top_lvl binds sigs thing_inside
                                          -- See Note [Placeholder PatSyn kinds]
                                 tcTySigs sigs
 
                                          -- 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
 
                 -- 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"
 
 ------------------------
       = 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,
              -> [(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.
 
 ------------------------
 tc_group :: forall thing.
-            TopLevelFlag -> TcSigFun -> PragFun
+            TopLevelFlag -> TcSigFun -> TcPragEnv
          -> (RecFlag, LHsBinds Name) -> TcM thing
          -> TcM ([(RecFlag, LHsBinds TcId)], thing)
 
          -> (RecFlag, LHsBinds Name) -> TcM thing
          -> TcM ([(RecFlag, LHsBinds TcId)], thing)
 
@@ -408,7 +468,7 @@ recursivePatSynErr binds
                             pprLoc loc
 
 tc_single :: forall thing.
                             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
           -> 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 ]
 
 ------------------------
                                      , 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
             -> 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
 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])
 
   -> [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'
       = 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
            ; 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
 ------------------
 tcPolyCheck :: RecFlag       -- Whether it's recursive after breaking
                              -- dependencies based on type signatures
-            -> PragFun
+            -> TcPragEnv
             -> TcSigInfo
             -> LHsBind Name
             -> TcM (LHsBinds TcId, [TcId])
             -> 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)
     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 $
              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
 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])
   -> 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
 
 --------------
          -- poly_ids are guaranteed zonked by mkExport
 
 --------------
-mkExport :: PragFun
+mkExport :: TcPragEnv
          -> [TyVar] -> TcThetaType      -- Both already zonked
          -> MonoBindInfo
          -> TcM (ABExport Id)
          -> [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
                       , 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
     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 #-}
 
    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
    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
           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
 
 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
 -}
 
    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
 
   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
         -- 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
 
 
     -- 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)
 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)
 
     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]
 
 --------------
 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
 -- 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 :: 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
   = 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
          -- 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]
 
          -- perform type inference (including generalisation)
        ; (binds, [id'], _) <- tcPolyInfer False True sigFun pragFun NonRecursive [bind]
index bc1bac2..e868da2 100644 (file)
@@ -19,7 +19,7 @@ module TcClassDcl ( tcClassSigs, tcClassDecl2,
 
 import HsSyn
 import TcEnv
 
 import HsSyn
 import TcEnv
-import TcPat( addInlinePrags, completeSigPolyId )
+import TcPat( addInlinePrags, completeSigPolyId, lookupPragEnv, emptyPragEnv )
 import TcEvidence( idHsWrapper )
 import TcBinds
 import TcUnify
 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
         -- 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)
               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))
                        -- 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
                                              ; 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
 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.)
           -> 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
   | 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
 
 ---------------
                                 -- they are all for meth_id
 
 ---------------
index 2c9a980..f1aa3c5 100644 (file)
@@ -18,7 +18,7 @@ import TcTyClsDecls
 import TcClassDcl( tcClassDecl2,
                    HsSigFun, lookupHsSig, mkHsSigFun,
                    findMethodBind, instantiateMethod )
 import TcClassDcl( tcClassDecl2,
                    HsSigFun, lookupHsSig, mkHsSigFun,
                    findMethodBind, instantiateMethod )
-import TcPat      ( addInlinePrags, completeSigPolyId )
+import TcPat      ( addInlinePrags, completeSigPolyId, lookupPragEnv, emptyPragEnv )
 import TcRnMonad
 import TcValidity
 import TcMType
 import TcRnMonad
 import TcValidity
 import TcMType
@@ -1243,7 +1243,7 @@ tcMethods :: DFunId -> Class
           -> [TcTyVar] -> [EvVar]
           -> [TcType]
           -> TcEvBinds
           -> [TcTyVar] -> [EvVar]
           -> [TcType]
           -> TcEvBinds
-          -> ([Located TcSpecPrag], PragFun)
+          -> ([Located TcSpecPrag], TcPragEnv)
           -> [(Id, DefMeth)]
           -> InstBindings Name
           -> TcM ([Id], LHsBinds Id, Bag Implication)
           -> [(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
 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
              -> 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
 
                  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
              -- 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
 
       | 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
 
 
                                 -- they are all for meth_id
 
 
@@ -1738,12 +1738,12 @@ Note that
 -}
 
 tcSpecInstPrags :: DFunId -> InstBindings Name
 -}
 
 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
 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
 
 ------------------------------
 tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag
index f04ab9e..bec80ca 100644 (file)
@@ -8,11 +8,12 @@ TcPat: Typechecking patterns
 
 {-# LANGUAGE CPP, RankNTypes #-}
 
 
 {-# LANGUAGE CPP, RankNTypes #-}
 
-module TcPat ( tcLetPat, TcSigFun, TcPragFun
+module TcPat ( tcLetPat, TcSigFun
+             , TcPragEnv, lookupPragEnv, emptyPragEnv
              , TcSigInfo(..), TcPatSynInfo(..)
              , findScopedTyVars, isPartialSig
              , completeSigPolyId, completeSigPolyId_maybe
              , TcSigInfo(..), TcPatSynInfo(..)
              , findScopedTyVars, isPartialSig
              , completeSigPolyId, completeSigPolyId_maybe
-             , LetBndrSpec(..), addInlinePrags, warnPrags
+             , LetBndrSpec(..), addInlinePrags
              , tcPat, tcPats, newNoSigLetBndr
              , addDataConStupidTheta, badFieldCon, polyPatSig ) where
 
              , tcPat, tcPats, newNoSigLetBndr
              , addDataConStupidTheta, badFieldCon, polyPatSig ) where
 
@@ -28,6 +29,7 @@ import Id
 import Var
 import Name
 import NameSet
 import Var
 import Name
 import NameSet
+import NameEnv
 import TcEnv
 import TcMType
 import TcValidity( arityErr )
 import TcEnv
 import TcMType
 import TcValidity( arityErr )
@@ -47,7 +49,9 @@ import SrcLoc
 import Util
 import Outputable
 import FastString
 import Util
 import Outputable
 import FastString
+import Maybes( orElse )
 import Control.Monad
 import Control.Monad
+
 {-
 ************************************************************************
 *                                                                      *
 {-
 ************************************************************************
 *                                                                      *
@@ -119,7 +123,7 @@ data LetBndrSpec
   = LetLclBndr            -- The binder is just a local one;
                           -- an AbsBinds will provide the global version
 
   = 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
                           -- 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
 
 ---------------
 inPatBind (PE { pe_ctxt = LamPat {} }) = False
 
 ---------------
-type TcPragFun = Name -> [LSig Name]
+type TcPragEnv = NameEnv [LSig Name]
 type TcSigFun  = Name -> Maybe TcSigInfo
 
 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
 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
   | 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) }
        ; 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
   =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
 
 ----------
 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
   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]
 
 {-
 Note [Typing patterns in pattern bindings]
index dc470b4..eb2872b 100644 (file)
@@ -372,7 +372,7 @@ tcPatSynBuilderBind PSB{ psb_id = L loc name, psb_def = lpat
        ; sig <- instTcTySigFromId builder_id
                 -- See Note [Redundant constraints for builder]
 
        ; 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
        ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds
        ; return builder_binds }
   where
index a7460b0..7f43daf 100644 (file)
@@ -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
 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
diff --git a/testsuite/tests/simplCore/should_compile/T10083.hs b/testsuite/tests/simplCore/should_compile/T10083.hs
new file mode 100644 (file)
index 0000000..df896e6
--- /dev/null
@@ -0,0 +1,5 @@
+module T10083 where
+  import T10083a
+  data RSR = MkRSR SR
+  eqRSR (MkRSR s1) (MkRSR s2) = (eqSR s1 s2)
+  foo x y = not (eqRSR x y)
diff --git a/testsuite/tests/simplCore/should_compile/T10083.hs-boot b/testsuite/tests/simplCore/should_compile/T10083.hs-boot
new file mode 100644 (file)
index 0000000..3d3e4a1
--- /dev/null
@@ -0,0 +1,3 @@
+module T10083 where
+  data RSR
+  eqRSR :: RSR -> RSR -> Bool
diff --git a/testsuite/tests/simplCore/should_compile/T10083a.hs b/testsuite/tests/simplCore/should_compile/T10083a.hs
new file mode 100644 (file)
index 0000000..f4fd782
--- /dev/null
@@ -0,0 +1,4 @@
+module T10083a where
+  import {-# SOURCE #-} T10083
+  data SR = MkSR RSR
+  eqSR (MkSR r1) (MkSR r2) = eqRSR r1 r2
index 9029710..ba2244e 100644 (file)
@@ -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('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'])