compiler/basicTypes/BasicTypes.hs

@@ -790,6 +790,13 @@ data TupleSort
   | ConstraintTuple
   deriving( Eq, Data )
 
+instance Outputable TupleSort where
+  ppr ts = text $
+    case ts of
+      BoxedTuple      -> "BoxedTuple"
+      UnboxedTuple    -> "UnboxedTuple"
+      ConstraintTuple -> "ConstraintTuple"
+
 tupleSortBoxity :: TupleSort -> Boxity
 tupleSortBoxity BoxedTuple      = Boxed
 tupleSortBoxity UnboxedTuple    = Unboxed

compiler/basicTypes/MkId.hs

@@ -1719,7 +1719,7 @@ voidArgId :: Id       -- Local lambda-bound :: Void#
 voidArgId = mkSysLocal (fsLit "void") voidArgIdKey voidPrimTy
 
 coercionTokenId :: Id         -- :: () ~ ()
-coercionTokenId -- Used to replace Coercion terms when we go to STG
+coercionTokenId -- See Note [Coercion tokens] in CoreToStg.hs
   = pcMiscPrelId coercionTokenName
                  (mkTyConApp eqPrimTyCon [liftedTypeKind, liftedTypeKind, unitTy, unitTy])
                  noCafIdInfo

compiler/basicTypes/Module.hs

@@ -146,7 +146,7 @@ import UniqDSet
 import FastString
 import Binary
 import Util
-import Data.List
+import Data.List (sortBy, sort)
 import Data.Ord
 import GHC.PackageDb (BinaryStringRep(..), DbUnitIdModuleRep(..), DbModule(..), DbUnitId(..))
 import Fingerprint

compiler/basicTypes/Name.hs

@@ -50,7 +50,7 @@ module Name (
 
         -- ** Manipulating and deconstructing 'Name's
         nameUnique, setNameUnique,
-        nameOccName, nameModule, nameModule_maybe,
+        nameOccName, nameNameSpace, nameModule, nameModule_maybe,
         setNameLoc,
         tidyNameOcc,
         localiseName,
@@ -196,14 +196,16 @@ instance HasOccName Name where
 
 nameUnique              :: Name -> Unique
 nameOccName             :: Name -> OccName
+nameNameSpace           :: Name -> NameSpace
 nameModule              :: HasDebugCallStack => Name -> Module
 nameSrcLoc              :: Name -> SrcLoc
 nameSrcSpan             :: Name -> SrcSpan
 
-nameUnique  name = n_uniq name
-nameOccName name = n_occ  name
-nameSrcLoc  name = srcSpanStart (n_loc name)
-nameSrcSpan name = n_loc  name
+nameUnique    name = n_uniq name
+nameOccName   name = n_occ  name
+nameNameSpace name = occNameSpace (n_occ name)
+nameSrcLoc    name = srcSpanStart (n_loc name)
+nameSrcSpan   name = n_loc  name
 
 type instance SrcSpanLess Name = Name
 instance HasSrcSpan Name where

compiler/basicTypes/PatSyn.hs

@@ -38,7 +38,7 @@ import FieldLabel
 
 import qualified Data.Data as Data
 import Data.Function
-import Data.List
+import Data.List (find)
 
 {-
 ************************************************************************

compiler/basicTypes/RdrName.hs

@@ -57,7 +57,7 @@ module RdrName (
         gresToAvailInfo,
 
         -- ** Global 'RdrName' mapping elements: 'GlobalRdrElt', 'Provenance', 'ImportSpec'
-        GlobalRdrElt(..), isLocalGRE, isRecFldGRE, greLabel,
+        GlobalRdrElt(..), isLocalGRE, isRecFldGRE, isOverloadedRecFldGRE, greLabel,
         unQualOK, qualSpecOK, unQualSpecOK,
         pprNameProvenance,
         Parent(..), greParent_maybe,
@@ -842,6 +842,12 @@ isRecFldGRE :: GlobalRdrElt -> Bool
 isRecFldGRE (GRE {gre_par = FldParent{}}) = True
 isRecFldGRE _                             = False
 
+isOverloadedRecFldGRE :: GlobalRdrElt -> Bool
+-- ^ Is this a record field defined with DuplicateRecordFields?
+-- (See Note [Parents for record fields])
+isOverloadedRecFldGRE (GRE {gre_par = FldParent{par_lbl = Just _}}) = True
+isOverloadedRecFldGRE _                                             = False
+
 -- Returns the field label of this GRE, if it has one
 greLabel :: GlobalRdrElt -> Maybe FieldLabelString
 greLabel (GRE{gre_par = FldParent{par_lbl = Just lbl}}) = Just lbl

compiler/basicTypes/SrcLoc.hs

@@ -100,7 +100,7 @@ import FastString
 import Control.DeepSeq
 import Data.Bits
 import Data.Data
-import Data.List
+import Data.List (sortBy, intercalate)
 import Data.Ord
 
 {-

compiler/cmm/CLabel.hs

@@ -10,6 +10,7 @@
 
 module CLabel (
         CLabel, -- abstract type
+        NeedExternDecl (..),
         ForeignLabelSource(..),
         pprDebugCLabel,
 
@@ -69,6 +70,7 @@ module CLabel (
         mkCmmRetLabel,
         mkCmmCodeLabel,
         mkCmmDataLabel,
+        mkRtsCmmDataLabel,
         mkCmmClosureLabel,
 
         mkRtsApFastLabel,
@@ -179,13 +181,14 @@ data CLabel
     IdLabel
         Name
         CafInfo
-        IdLabelInfo             -- encodes the suffix of the label
+        IdLabelInfo             -- ^ encodes the suffix of the label
 
   -- | A label from a .cmm file that is not associated with a .hs level Id.
   | CmmLabel
-        UnitId               -- what package the label belongs to.
-        FastString              -- identifier giving the prefix of the label
-        CmmLabelInfo            -- encodes the suffix of the label
+        UnitId                  -- ^ what package the label belongs to.
+        NeedExternDecl          -- ^ does the label need an "extern .." declaration
+        FastString              -- ^ identifier giving the prefix of the label
+        CmmLabelInfo            -- ^ encodes the suffix of the label
 
   -- | A label with a baked-in \/ algorithmically generated name that definitely
   --    comes from the RTS. The code for it must compile into libHSrts.a \/ libHSrts.so
@@ -205,13 +208,13 @@ data CLabel
   -- | A 'C' (or otherwise foreign) label.
   --
   | ForeignLabel
-        FastString              -- name of the imported label.
+        FastString              -- ^ name of the imported label.
 
-        (Maybe Int)             -- possible '@n' suffix for stdcall functions
+        (Maybe Int)             -- ^ possible '@n' suffix for stdcall functions
                                 -- When generating C, the '@n' suffix is omitted, but when
                                 -- generating assembler we must add it to the label.
 
-        ForeignLabelSource      -- what package the foreign label is in.
+        ForeignLabelSource      -- ^ what package the foreign label is in.
 
         FunctionOrData
 
@@ -224,7 +227,7 @@ data CLabel
   -- Must not occur outside of the NCG or LLVM code generators.
   | AsmTempDerivedLabel
         CLabel
-        FastString              -- suffix
+        FastString              -- ^ suffix
 
   | StringLitLabel
         {-# UNPACK #-} !Unique
@@ -262,6 +265,24 @@ data CLabel
 
   deriving Eq
 
+-- | Indicate if "GHC.CmmToC" has to generate an extern declaration for the
+-- label (e.g. "extern StgWordArray(foo)").  The type is fixed to StgWordArray.
+--
+-- Symbols from the RTS don't need "extern" declarations because they are
+-- exposed via "includes/Stg.h" with the appropriate type. See 'needsCDecl'.
+--
+-- The fixed StgWordArray type led to "conflicting types" issues with user
+-- provided Cmm files (not in the RTS) that declare data of another type (#15467
+-- and test for #17920).  Hence the Cmm parser considers that labels in data
+-- sections don't need the "extern" declaration (just add one explicitly if you
+-- need it).
+--
+-- See https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/backends/ppr-c#prototypes
+-- for why extern declaration are needed at all.
+newtype NeedExternDecl
+   = NeedExternDecl Bool
+   deriving (Ord,Eq)
+
 -- This is laborious, but necessary. We can't derive Ord because
 -- Unique doesn't have an Ord instance. Note nonDetCmpUnique in the
 -- implementation. See Note [No Ord for Unique]
@@ -272,10 +293,11 @@ instance Ord CLabel where
     compare a1 a2 `thenCmp`
     compare b1 b2 `thenCmp`
     compare c1 c2
-  compare (CmmLabel a1 b1 c1) (CmmLabel a2 b2 c2) =
+  compare (CmmLabel a1 b1 c1 d1) (CmmLabel a2 b2 c2 d2) =
     compare a1 a2 `thenCmp`
     compare b1 b2 `thenCmp`
-    compare c1 c2
+    compare c1 c2 `thenCmp`
+    compare d1 d2
   compare (RtsLabel a1) (RtsLabel a2) = compare a1 a2
   compare (LocalBlockLabel u1) (LocalBlockLabel u2) = nonDetCmpUnique u1 u2
   compare (ForeignLabel a1 b1 c1 d1) (ForeignLabel a2 b2 c2 d2) =
@@ -367,7 +389,7 @@ pprDebugCLabel lbl
  = case lbl of
         IdLabel _ _ info-> ppr lbl <> (parens $ text "IdLabel"
                                        <> whenPprDebug (text ":" <> text (show info)))
-        CmmLabel pkg _name _info
+        CmmLabel pkg _ext _name _info
          -> ppr lbl <> (parens $ text "CmmLabel" <+> ppr pkg)
 
         RtsLabel{}      -> ppr lbl <> (parens $ text "RtsLabel")
@@ -498,24 +520,24 @@ mkDirty_MUT_VAR_Label,
     mkSMAP_DIRTY_infoLabel, mkBadAlignmentLabel :: CLabel
 mkDirty_MUT_VAR_Label           = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction
 mkNonmovingWriteBarrierEnabledLabel
-                                = CmmLabel rtsUnitId (fsLit "nonmoving_write_barrier_enabled") CmmData
-mkUpdInfoLabel                  = CmmLabel rtsUnitId (fsLit "stg_upd_frame")         CmmInfo
-mkBHUpdInfoLabel                = CmmLabel rtsUnitId (fsLit "stg_bh_upd_frame" )     CmmInfo
-mkIndStaticInfoLabel            = CmmLabel rtsUnitId (fsLit "stg_IND_STATIC")        CmmInfo
-mkMainCapabilityLabel           = CmmLabel rtsUnitId (fsLit "MainCapability")        CmmData
-mkMAP_FROZEN_CLEAN_infoLabel    = CmmLabel rtsUnitId (fsLit "stg_MUT_ARR_PTRS_FROZEN_CLEAN") CmmInfo
-mkMAP_FROZEN_DIRTY_infoLabel    = CmmLabel rtsUnitId (fsLit "stg_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo
-mkMAP_DIRTY_infoLabel           = CmmLabel rtsUnitId (fsLit "stg_MUT_ARR_PTRS_DIRTY") CmmInfo
-mkTopTickyCtrLabel              = CmmLabel rtsUnitId (fsLit "top_ct")                CmmData
-mkCAFBlackHoleInfoTableLabel    = CmmLabel rtsUnitId (fsLit "stg_CAF_BLACKHOLE")     CmmInfo
-mkArrWords_infoLabel            = CmmLabel rtsUnitId (fsLit "stg_ARR_WORDS")         CmmInfo
-mkSMAP_FROZEN_CLEAN_infoLabel   = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_CLEAN") CmmInfo
-mkSMAP_FROZEN_DIRTY_infoLabel   = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo
-mkSMAP_DIRTY_infoLabel          = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo
-mkBadAlignmentLabel             = CmmLabel rtsUnitId (fsLit "stg_badAlignment")      CmmEntry
+                                = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "nonmoving_write_barrier_enabled") CmmData
+mkUpdInfoLabel                  = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_upd_frame")         CmmInfo
+mkBHUpdInfoLabel                = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_bh_upd_frame" )     CmmInfo
+mkIndStaticInfoLabel            = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_IND_STATIC")        CmmInfo
+mkMainCapabilityLabel           = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "MainCapability")        CmmData
+mkMAP_FROZEN_CLEAN_infoLabel    = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_MUT_ARR_PTRS_FROZEN_CLEAN") CmmInfo
+mkMAP_FROZEN_DIRTY_infoLabel    = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo
+mkMAP_DIRTY_infoLabel           = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_MUT_ARR_PTRS_DIRTY") CmmInfo
+mkTopTickyCtrLabel              = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "top_ct")                CmmData
+mkCAFBlackHoleInfoTableLabel    = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_CAF_BLACKHOLE")     CmmInfo
+mkArrWords_infoLabel            = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_ARR_WORDS")         CmmInfo
+mkSMAP_FROZEN_CLEAN_infoLabel   = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_CLEAN") CmmInfo
+mkSMAP_FROZEN_DIRTY_infoLabel   = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo
+mkSMAP_DIRTY_infoLabel          = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo
+mkBadAlignmentLabel             = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_badAlignment")      CmmEntry
 
 mkSRTInfoLabel :: Int -> CLabel
-mkSRTInfoLabel n = CmmLabel rtsUnitId lbl CmmInfo
+mkSRTInfoLabel n = CmmLabel rtsUnitId (NeedExternDecl False) lbl CmmInfo
  where
    lbl =
      case n of
@@ -539,16 +561,23 @@ mkSRTInfoLabel n = CmmLabel rtsUnitId lbl CmmInfo
 
 -----
 mkCmmInfoLabel,   mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel,
-  mkCmmCodeLabel, mkCmmDataLabel,  mkCmmClosureLabel
+  mkCmmCodeLabel, mkCmmClosureLabel
         :: UnitId -> FastString -> CLabel
 
-mkCmmInfoLabel      pkg str     = CmmLabel pkg str CmmInfo
-mkCmmEntryLabel     pkg str     = CmmLabel pkg str CmmEntry
-mkCmmRetInfoLabel   pkg str     = CmmLabel pkg str CmmRetInfo
-mkCmmRetLabel       pkg str     = CmmLabel pkg str CmmRet
-mkCmmCodeLabel      pkg str     = CmmLabel pkg str CmmCode
-mkCmmDataLabel      pkg str     = CmmLabel pkg str CmmData
-mkCmmClosureLabel   pkg str     = CmmLabel pkg str CmmClosure
+mkCmmDataLabel    :: UnitId -> NeedExternDecl -> FastString -> CLabel
+mkRtsCmmDataLabel :: FastString -> CLabel
+
+mkCmmInfoLabel       pkg str     = CmmLabel pkg (NeedExternDecl True) str CmmInfo
+mkCmmEntryLabel      pkg str     = CmmLabel pkg (NeedExternDecl True) str CmmEntry
+mkCmmRetInfoLabel    pkg str     = CmmLabel pkg (NeedExternDecl True) str CmmRetInfo
+mkCmmRetLabel        pkg str     = CmmLabel pkg (NeedExternDecl True) str CmmRet
+mkCmmCodeLabel       pkg str     = CmmLabel pkg (NeedExternDecl True) str CmmCode
+mkCmmClosureLabel    pkg str     = CmmLabel pkg (NeedExternDecl True) str CmmClosure
+mkCmmDataLabel       pkg ext str = CmmLabel pkg ext  str CmmData
+mkRtsCmmDataLabel    str         = CmmLabel rtsUnitId (NeedExternDecl False)  str CmmData
+                                    -- RTS symbols don't need "GHC.CmmToC" to
+                                    -- generate \"extern\" declaration (they are
+                                    -- exposed via includes/Stg.h)
 
 mkLocalBlockLabel :: Unique -> CLabel
 mkLocalBlockLabel u = LocalBlockLabel u
@@ -571,7 +600,7 @@ mkApEntryLabel       upd off    = RtsLabel (RtsApEntry           upd off)
 -- A call to some primitive hand written Cmm code
 mkPrimCallLabel :: PrimCall -> CLabel
 mkPrimCallLabel (PrimCall str pkg)
-        = CmmLabel pkg str CmmPrimCall
+        = CmmLabel pkg (NeedExternDecl True) str CmmPrimCall
 
 
 -- Constructing ForeignLabels
@@ -609,7 +638,7 @@ isStaticClosureLabel :: CLabel -> Bool
 -- Closure defined in haskell (.hs)
 isStaticClosureLabel (IdLabel _ _ Closure) = True
 -- Closure defined in cmm
-isStaticClosureLabel (CmmLabel _ _ CmmClosure) = True
+isStaticClosureLabel (CmmLabel _ _ _ CmmClosure) = True
 isStaticClosureLabel _lbl = False
 
 -- | Whether label is a .rodata label
@@ -621,7 +650,7 @@ isSomeRODataLabel (IdLabel _ _ InfoTable) = True
 isSomeRODataLabel (IdLabel _ _ LocalInfoTable) = True
 isSomeRODataLabel (IdLabel _ _ BlockInfoTable) = True
 -- info table defined in cmm (.cmm)
-isSomeRODataLabel (CmmLabel _ _ CmmInfo) = True
+isSomeRODataLabel (CmmLabel _ _ _ CmmInfo) = True
 isSomeRODataLabel _lbl = False
 
 -- | Whether label is points to some kind of info table
@@ -703,7 +732,7 @@ mkAsmTempDieLabel l = mkAsmTempDerivedLabel l (fsLit "_die")
 
 toClosureLbl :: CLabel -> CLabel
 toClosureLbl (IdLabel n c _) = IdLabel n c Closure
-toClosureLbl (CmmLabel m str _) = CmmLabel m str CmmClosure
+toClosureLbl (CmmLabel m ext str _) = CmmLabel m ext str CmmClosure
 toClosureLbl l = pprPanic "toClosureLbl" (ppr l)
 
 toSlowEntryLbl :: CLabel -> CLabel
@@ -718,16 +747,16 @@ toEntryLbl (IdLabel n c ConInfoTable)    = IdLabel n c ConEntry
 toEntryLbl (IdLabel n _ BlockInfoTable)  = mkLocalBlockLabel (nameUnique n)
                               -- See Note [Proc-point local block entry-point].
 toEntryLbl (IdLabel n c _)               = IdLabel n c Entry
-toEntryLbl (CmmLabel m str CmmInfo)      = CmmLabel m str CmmEntry
-toEntryLbl (CmmLabel m str CmmRetInfo)   = CmmLabel m str CmmRet
+toEntryLbl (CmmLabel m ext str CmmInfo)    = CmmLabel m ext str CmmEntry
+toEntryLbl (CmmLabel m ext str CmmRetInfo) = CmmLabel m ext str CmmRet
 toEntryLbl l = pprPanic "toEntryLbl" (ppr l)
 
 toInfoLbl :: CLabel -> CLabel
 toInfoLbl (IdLabel n c LocalEntry)     = IdLabel n c LocalInfoTable
 toInfoLbl (IdLabel n c ConEntry)       = IdLabel n c ConInfoTable
 toInfoLbl (IdLabel n c _)              = IdLabel n c InfoTable
-toInfoLbl (CmmLabel m str CmmEntry)    = CmmLabel m str CmmInfo
-toInfoLbl (CmmLabel m str CmmRet)      = CmmLabel m str CmmRetInfo
+toInfoLbl (CmmLabel m ext str CmmEntry)= CmmLabel m ext str CmmInfo
+toInfoLbl (CmmLabel m ext str CmmRet)  = CmmLabel m ext str CmmRetInfo
 toInfoLbl l = pprPanic "CLabel.toInfoLbl" (ppr l)
 
 hasHaskellName :: CLabel -> Maybe Name
@@ -779,10 +808,13 @@ needsCDecl (AsmTempLabel _)             = False
 needsCDecl (AsmTempDerivedLabel _ _)    = False
 needsCDecl (RtsLabel _)                 = False
 
-needsCDecl (CmmLabel pkgId _ _)
+needsCDecl (CmmLabel pkgId (NeedExternDecl external) _ _)
+        -- local labels mustn't have it
+        | not external                  = False
+
         -- Prototypes for labels defined in the runtime system are imported
         --      into HC files via includes/Stg.h.
-        | pkgId == rtsUnitId         = False
+        | pkgId == rtsUnitId            = False
 
         -- For other labels we inline one into the HC file directly.
         | otherwise                     = True
@@ -907,7 +939,7 @@ externallyVisibleCLabel (AsmTempLabel _)        = False
 externallyVisibleCLabel (AsmTempDerivedLabel _ _)= False
 externallyVisibleCLabel (RtsLabel _)            = True
 externallyVisibleCLabel (LocalBlockLabel _)     = False
-externallyVisibleCLabel (CmmLabel _ _ _)        = True
+externallyVisibleCLabel (CmmLabel _ _ _ _)      = True
 externallyVisibleCLabel (ForeignLabel{})        = True
 externallyVisibleCLabel (IdLabel name _ info)   = isExternalName name && externallyVisibleIdLabel info
 externallyVisibleCLabel (CC_Label _)            = True
@@ -950,14 +982,14 @@ isGcPtrLabel lbl = case labelType lbl of
 --    whether it be code, data, or static GC object.
 labelType :: CLabel -> CLabelType
 labelType (IdLabel _ _ info)                    = idInfoLabelType info
-labelType (CmmLabel _ _ CmmData)                = DataLabel
-labelType (CmmLabel _ _ CmmClosure)             = GcPtrLabel
-labelType (CmmLabel _ _ CmmCode)                = CodeLabel
-labelType (CmmLabel _ _ CmmInfo)                = DataLabel
-labelType (CmmLabel _ _ CmmEntry)               = CodeLabel
-labelType (CmmLabel _ _ CmmPrimCall)            = CodeLabel
-labelType (CmmLabel _ _ CmmRetInfo)             = DataLabel
-labelType (CmmLabel _ _ CmmRet)                 = CodeLabel
+labelType (CmmLabel _ _ _ CmmData)              = DataLabel
+labelType (CmmLabel _ _ _ CmmClosure)           = GcPtrLabel
+labelType (CmmLabel _ _ _ CmmCode)              = CodeLabel
+labelType (CmmLabel _ _ _ CmmInfo)              = DataLabel
+labelType (CmmLabel _ _ _ CmmEntry)             = CodeLabel
+labelType (CmmLabel _ _ _ CmmPrimCall)          = CodeLabel
+labelType (CmmLabel _ _ _ CmmRetInfo)           = DataLabel
+labelType (CmmLabel _ _ _ CmmRet)               = CodeLabel
 labelType (RtsLabel (RtsSelectorInfoTable _ _)) = DataLabel
 labelType (RtsLabel (RtsApInfoTable _ _))       = DataLabel
 labelType (RtsLabel (RtsApFast _))              = CodeLabel
@@ -1027,7 +1059,7 @@ labelDynamic dflags this_mod lbl =
 
    -- When compiling in the "dyn" way, each package is to be linked into
    -- its own shared library.
-   CmmLabel pkg _ _
+   CmmLabel pkg _ _ _
     | os == OSMinGW32 ->
        externalDynamicRefs && (this_pkg /= pkg)
     | otherwise ->
@@ -1233,9 +1265,9 @@ pprCLbl (LargeBitmapLabel u)  =
 -- with a letter so the label will be legal assembly code.
 
 
-pprCLbl (CmmLabel _ str CmmCode)        = ftext str
-pprCLbl (CmmLabel _ str CmmData)        = ftext str
-pprCLbl (CmmLabel _ str CmmPrimCall)    = ftext str
+pprCLbl (CmmLabel _ _ str CmmCode)        = ftext str
+pprCLbl (CmmLabel _ _ str CmmData)        = ftext str
+pprCLbl (CmmLabel _ _ str CmmPrimCall)    = ftext str
 
 pprCLbl (LocalBlockLabel u)             =
     tempLabelPrefixOrUnderscore <> text "blk_" <> pprUniqueAlways u
@@ -1278,19 +1310,19 @@ pprCLbl (RtsLabel (RtsApEntry upd_reqd arity))
                         else (sLit "_noupd_entry"))
         ]
 
-pprCLbl (CmmLabel _ fs CmmInfo)
+pprCLbl (CmmLabel _ _ fs CmmInfo)
   = ftext fs <> text "_info"
 
-pprCLbl (CmmLabel _ fs CmmEntry)
+pprCLbl (CmmLabel _ _ fs CmmEntry)
   = ftext fs <> text "_entry"
 
-pprCLbl (CmmLabel _ fs CmmRetInfo)
+pprCLbl (CmmLabel _ _ fs CmmRetInfo)
   = ftext fs <> text "_info"
 
-pprCLbl (CmmLabel _ fs CmmRet)
+pprCLbl (CmmLabel _ _ fs CmmRet)
   = ftext fs <> text "_ret"
 
-pprCLbl (CmmLabel _ fs CmmClosure)
+pprCLbl (CmmLabel _ _ fs CmmClosure)
   = ftext fs <> text "_closure"
 
 pprCLbl (RtsLabel (RtsPrimOp primop))

compiler/cmm/Cmm.hs

@@ -9,7 +9,7 @@ module Cmm (
      CmmBlock,
      RawCmmDecl, RawCmmGroup,
      Section(..), SectionType(..), CmmStatics(..), CmmStatic(..),
-     isSecConstant,
+     SectionProtection(..), sectionProtection,
 
      -- ** Blocks containing lists
      GenBasicBlock(..), blockId,
@@ -177,17 +177,33 @@ data SectionType
   | OtherSection String
   deriving (Show)
 
--- | Should a data in this section be considered constant
-isSecConstant :: Section -> Bool
-isSecConstant (Section t _) = case t of
-    Text                    -> True
-    ReadOnlyData            -> True
-    RelocatableReadOnlyData -> True
-    ReadOnlyData16          -> True
-    CString                 -> True
-    Data                    -> False
-    UninitialisedData       -> False
-    (OtherSection _)        -> False
+data SectionProtection
+  = ReadWriteSection
+  | ReadOnlySection
+  | WriteProtectedSection -- See Note [Relocatable Read-Only Data]
+  deriving (Eq)
+
+-- | Should a data in this section be considered constant at runtime
+sectionProtection :: Section -> SectionProtection
+sectionProtection (Section t _) = case t of
+    Text                    -> ReadOnlySection
+    ReadOnlyData            -> ReadOnlySection
+    RelocatableReadOnlyData -> WriteProtectedSection
+    ReadOnlyData16          -> ReadOnlySection
+    CString                 -> ReadOnlySection
+    Data                    -> ReadWriteSection
+    UninitialisedData       -> ReadWriteSection
+    (OtherSection _)        -> ReadWriteSection
+
+{-
+Note [Relocatable Read-Only Data]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Relocatable data are only read-only after relocation at the start of the
+program. They should be writable from the source code until then. Failure to
+do so would end up in segfaults at execution when using linkers that do not
+enforce writability of those sections, such as the gold linker.
+-}
 
 data Section = Section SectionType CLabel
 

compiler/cmm/CmmCallConv.hs

@@ -202,11 +202,16 @@ nodeOnly = ([VanillaReg 1], [], [], [], [])
 -- only use this functionality in hand-written C-- code in the RTS.
 realArgRegsCover :: DynFlags -> [GlobalReg]
 realArgRegsCover dflags
-    | passFloatArgsInXmm dflags = map ($VGcPtr) (realVanillaRegs dflags) ++
-                                  realLongRegs dflags ++
-                                  map XmmReg (realXmmRegNos dflags)
-    | otherwise                 = map ($VGcPtr) (realVanillaRegs dflags) ++
-                                  realFloatRegs dflags ++
-                                  realDoubleRegs dflags ++
-                                  realLongRegs dflags ++
-                                  map XmmReg (realXmmRegNos dflags)
+    | passFloatArgsInXmm dflags
+    = map ($VGcPtr) (realVanillaRegs dflags) ++
+      realLongRegs dflags ++
+      realDoubleRegs dflags -- we only need to save the low Double part of XMM registers.
+                            -- Moreover, the NCG can't load/store full XMM
+                            -- registers for now...
+
+    | otherwise
+    = map ($VGcPtr) (realVanillaRegs dflags) ++
+      realFloatRegs dflags ++
+      realDoubleRegs dflags ++
+      realLongRegs dflags
+      -- we don't save XMM registers if they are not used for parameter passing

compiler/cmm/CmmMachOp.hs

@@ -43,6 +43,9 @@ native code generators to handle.
 Most operations are parameterised by the 'Width' that they operate on.
 Some operations have separate signed and unsigned versions, and float
 and integer versions.
+
+Note that there are variety of places in the native code generator where we
+assume that the code produced for a MachOp does not introduce new blocks.
 -}
 
 data MachOp

compiler/cmm/CmmParse.y

@@ -203,6 +203,7 @@ necessary to the stack to accommodate it (e.g. 2).
 module CmmParse ( parseCmmFile ) where
 
 import GhcPrelude
+import qualified Prelude -- for happy-generated code
 
 import GHC.StgToCmm.ExtCode
 import CmmCallConv
@@ -399,7 +400,7 @@ cmmdata :: { CmmParse () }
 data_label :: { CmmParse CLabel }
     : NAME ':'
                 {% liftP . withThisPackage $ \pkg ->
-                   return (mkCmmDataLabel pkg $1) }
+                   return (mkCmmDataLabel pkg (NeedExternDecl False) $1) }
 
 statics :: { [CmmParse [CmmStatic]] }
         : {- empty -}                   { [] }
@@ -1118,6 +1119,9 @@ stmtMacros = listToUFM [
   ( fsLit "LOAD_THREAD_STATE",     \[] -> emitLoadThreadState ),
   ( fsLit "SAVE_THREAD_STATE",     \[] -> emitSaveThreadState ),
 
+  ( fsLit "SAVE_REGS",             \[] -> emitSaveRegs ),
+  ( fsLit "RESTORE_REGS",          \[] -> emitRestoreRegs ),
+
   ( fsLit "LDV_ENTER",             \[e] -> ldvEnter e ),
   ( fsLit "LDV_RECORD_CREATE",     \[e] -> ldvRecordCreate e ),
 
@@ -1175,7 +1179,7 @@ staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse ()
 staticClosure pkg cl_label info payload
   = do dflags <- getDynFlags
        let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []
-       code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits
+       code $ emitDataLits (mkCmmDataLabel pkg (NeedExternDecl True) cl_label) lits
 
 foreignCall
         :: String

compiler/cmm/MkGraph.hs

@@ -151,7 +151,7 @@ flattenCmmAGraph id (stmts_t, tscope) =
 catAGraphs     :: [CmmAGraph] -> CmmAGraph
 catAGraphs      = concatOL
 
--- | created a sequence "goto id; id:" as an AGraph
+-- | creates a sequence "goto id; id:" as an AGraph
 mkLabel        :: BlockId -> CmmTickScope -> CmmAGraph
 mkLabel bid scp = unitOL (CgLabel bid scp)
 
@@ -159,7 +159,7 @@ mkLabel bid scp = unitOL (CgLabel bid scp)
 mkMiddle        :: CmmNode O O -> CmmAGraph
 mkMiddle middle = unitOL (CgStmt middle)
 
--- | created a closed AGraph from a given node
+-- | creates a closed AGraph from a given node
 mkLast         :: CmmNode O C -> CmmAGraph
 mkLast last     = unitOL (CgLast last)
 

compiler/cmm/PprC.hs

@@ -55,7 +55,7 @@ import qualified Data.ByteString as BS
 import Control.Monad.ST
 import Data.Bits
 import Data.Char
-import Data.List
+import Data.List (intersperse)
 import Data.Map (Map)
 import Data.Word
 import System.IO
@@ -128,6 +128,11 @@ pprTop (CmmData section (Statics lbl lits)) =
   pprDataExterns lits $$
   pprWordArray (isSecConstant section) lbl lits
 
+isSecConstant :: Section -> Bool
+isSecConstant section = case sectionProtection section of
+  ReadOnlySection -> True
+  WriteProtectedSection -> True
+  _ -> False
 -- --------------------------------------------------------------------------
 -- BasicBlocks are self-contained entities: they always end in a jump.
 --

compiler/coreSyn/CorePrep.hs

@@ -927,8 +927,10 @@ cpeApp top_env expr
                    (_   : ss_rest, True)  -> (topDmd, ss_rest)
                    (ss1 : ss_rest, False) -> (ss1,    ss_rest)
                    ([],            _)     -> (topDmd, [])
-            (arg_ty, res_ty) = expectJust "cpeBody:collect_args" $
-                               splitFunTy_maybe fun_ty
+            (arg_ty, res_ty) =
+              case splitFunTy_maybe fun_ty of
+                Just as -> as
+                Nothing -> pprPanic "cpeBody" (ppr fun_ty $$ ppr expr)
         (fs, arg') <- cpeArg top_env ss1 arg arg_ty
         rebuild_app as (App fun' arg') res_ty (fs `appendFloats` floats) ss_rest
       CpeCast co ->
@@ -1141,6 +1143,7 @@ and now we do NOT want eta expansion to give
 
 Instead CoreArity.etaExpand gives
                 f = /\a -> \y -> let s = h 3 in g s y
+
 -}
 
 cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs
@@ -1161,6 +1164,8 @@ get to a partial application:
     ==> case x of { p -> map f }
 -}
 
+-- When updating this function, make sure it lines up with
+-- CoreUtils.tryEtaReduce!
 tryEtaReducePrep :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr
 tryEtaReducePrep bndrs expr@(App _ _)
   | ok_to_eta_reduce f
@@ -1180,25 +1185,14 @@ tryEtaReducePrep bndrs expr@(App _ _)
     ok bndr (Var arg) = bndr == arg
     ok _    _         = False
 
-          -- We can't eta reduce something which must be saturated.
+    -- We can't eta reduce something which must be saturated.
     ok_to_eta_reduce (Var f) = not (hasNoBinding f)
     ok_to_eta_reduce _       = False -- Safe. ToDo: generalise
 
-tryEtaReducePrep bndrs (Let bind@(NonRec _ r) body)
-  | not (any (`elemVarSet` fvs) bndrs)
-  = case tryEtaReducePrep bndrs body of
-        Just e -> Just (Let bind e)
-        Nothing -> Nothing
-  where
-    fvs = exprFreeVars r
-
--- NB: do not attempt to eta-reduce across ticks
--- Otherwise we risk reducing
---       \x. (Tick (Breakpoint {x}) f x)
---   ==> Tick (breakpoint {x}) f
--- which is bogus (#17228)
--- tryEtaReducePrep bndrs (Tick tickish e)
---   = fmap (mkTick tickish) $ tryEtaReducePrep bndrs e
+
+tryEtaReducePrep bndrs (Tick tickish e)
+  | tickishFloatable tickish
+  = fmap (mkTick tickish) $ tryEtaReducePrep bndrs e
 
 tryEtaReducePrep _ _ = Nothing
 

compiler/coreSyn/CoreSubst.hs

@@ -16,7 +16,7 @@ module CoreSubst (
         deShadowBinds, substSpec, substRulesForImportedIds,
         substTy, substCo, substExpr, substExprSC, substBind, substBindSC,
         substUnfolding, substUnfoldingSC,
-        lookupIdSubst, lookupTCvSubst, substIdOcc,
+        lookupIdSubst, lookupTCvSubst, substIdType, substIdOcc,
         substTickish, substDVarSet, substIdInfo,
 
         -- ** Operations on substitutions
@@ -754,4 +754,3 @@ analyser, so it's possible that the worker is not even in scope any more.
 In all all these cases we simply drop the special case, returning to
 InlVanilla.  The WARN is just so I can see if it happens a lot.
 -}
-

compiler/coreSyn/CoreUnfold.hs

@@ -169,44 +169,45 @@ mkInlinableUnfolding dflags expr
   where
     expr' = simpleOptExpr dflags expr
 
-specUnfolding :: DynFlags -> [Var] -> (CoreExpr -> CoreExpr) -> Arity
+specUnfolding :: DynFlags
+              -> [Var] -> (CoreExpr -> CoreExpr)
+              -> [CoreArg]   -- LHS arguments in the RULE
               -> Unfolding -> Unfolding
 -- See Note [Specialising unfoldings]
--- specUnfolding spec_bndrs spec_app arity_decrease unf
---   = \spec_bndrs. spec_app( unf )
+-- specUnfolding spec_bndrs spec_args unf
+--   = \spec_bndrs. unf spec_args
 --
-specUnfolding dflags spec_bndrs spec_app arity_decrease
+specUnfolding dflags spec_bndrs spec_app rule_lhs_args
               df@(DFunUnfolding { df_bndrs = old_bndrs, df_con = con, df_args = args })
-  = ASSERT2( arity_decrease == count isId old_bndrs - count isId spec_bndrs, ppr df )
+  = ASSERT2( rule_lhs_args `equalLength` old_bndrs
+           , ppr df $$ ppr rule_lhs_args )
+           -- For this ASSERT see Note [DFunUnfoldings] in GHC.Core.Opt.Specialise
     mkDFunUnfolding spec_bndrs con (map spec_arg args)
-      -- There is a hard-to-check assumption here that the spec_app has
-      -- enough applications to exactly saturate the old_bndrs
       -- For DFunUnfoldings we transform
-      --       \old_bndrs. MkD <op1> ... <opn>
+      --       \obs. MkD <op1> ... <opn>
       -- to
-      --       \new_bndrs. MkD (spec_app(\old_bndrs. <op1>)) ... ditto <opn>
-      -- The ASSERT checks the value part of that
+      --       \sbs. MkD ((\obs. <op1>) spec_args) ... ditto <opn>
   where
-    spec_arg arg = simpleOptExpr dflags (spec_app (mkLams old_bndrs arg))
+    spec_arg arg = simpleOptExpr dflags $
+                   spec_app (mkLams old_bndrs arg)
                    -- The beta-redexes created by spec_app will be
                    -- simplified away by simplOptExpr
 
-specUnfolding dflags spec_bndrs spec_app arity_decrease
+specUnfolding dflags spec_bndrs spec_app rule_lhs_args
               (CoreUnfolding { uf_src = src, uf_tmpl = tmpl
                              , uf_is_top = top_lvl
                              , uf_guidance = old_guidance })
  | isStableSource src  -- See Note [Specialising unfoldings]
- , UnfWhen { ug_arity     = old_arity
-           , ug_unsat_ok  = unsat_ok
-           , ug_boring_ok = boring_ok } <- old_guidance
- = let guidance = UnfWhen { ug_arity     = old_arity - arity_decrease
-                          , ug_unsat_ok  = unsat_ok
-                          , ug_boring_ok = boring_ok }
-       new_tmpl = simpleOptExpr dflags (mkLams spec_bndrs (spec_app tmpl))
-                   -- The beta-redexes created by spec_app will be
-                   -- simplified away by simplOptExpr
+ , UnfWhen { ug_arity     = old_arity } <- old_guidance
+ = mkCoreUnfolding src top_lvl new_tmpl
+                   (old_guidance { ug_arity = old_arity - arity_decrease })
+ where
+   new_tmpl = simpleOptExpr dflags $
+              mkLams spec_bndrs    $
+              spec_app tmpl  -- The beta-redexes created by spec_app
+                             -- will besimplified away by simplOptExpr
+   arity_decrease = count isValArg rule_lhs_args - count isId spec_bndrs
 
-   in mkCoreUnfolding src top_lvl new_tmpl guidance
 
 specUnfolding _ _ _ _ _ = noUnfolding
 
@@ -441,8 +442,9 @@ inlineBoringOk e
     go :: Int -> CoreExpr -> Bool
     go credit (Lam x e) | isId x           = go (credit+1) e
                         | otherwise        = go credit e
-    go credit (App f a) | isTyCoArg a      = go credit f
-                        | credit > 0
+        -- See Note [Count coercion arguments in boring contexts]
+    go credit (App f (Type {}))            = go credit f
+    go credit (App f a) | credit > 0
                         , exprIsTrivial a  = go (credit-1) f
     go credit (Tick _ e)                   = go credit e -- dubious
     go credit (Cast e _)                   = go credit e
@@ -588,6 +590,29 @@ Things to note:
     NB: you might think that PostInlineUnconditionally would do this
     but it doesn't fire for top-level things; see SimplUtils
     Note [Top level and postInlineUnconditionally]
+
+Note [Count coercion arguments in boring contexts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In inlineBoringOK, we ignore type arguments when deciding whether an
+expression is okay to inline into boring contexts. This is good, since
+if we have a definition like
+
+  let y = x @Int in f y y
+
+there’s no reason not to inline y at both use sites — no work is
+actually duplicated. It may seem like the same reasoning applies to
+coercion arguments, and indeed, in #17182 we changed inlineBoringOK to
+treat coercions the same way.
+
+However, this isn’t a good idea: unlike type arguments, which have
+no runtime representation, coercion arguments *do* have a runtime
+representation (albeit the zero-width VoidRep, see Note [Coercion tokens]
+in CoreToStg.hs). This caused trouble in #17787 for DataCon wrappers for
+nullary GADT constructors: the wrappers would be inlined and each use of
+the constructor would lead to a separate allocation instead of just
+sharing the wrapper closure.
+
+The solution: don’t ignore coercion arguments after all.
 -}
 
 uncondInline :: CoreExpr -> Arity -> Int -> Bool
@@ -1287,6 +1312,20 @@ traceInline dflags inline_id str doc result
  | otherwise
  = result
 
+-- | This is an awful but temporary workaround for #17615, where the
+-- case analysis from the 'ufVeryAggressive' selector causes the entire
+-- 'DynFlags' to be unpacked into local bindings (due to binder swap). This
+-- results in a tremendous amount of stack spillage, severely bloating the code
+-- generated for 'callSiteInline'.
+--
+-- The right solution here is likely to fix binder swap to avoid this terrible
+-- behavior (since there are likely other instances of this as well) but this
+-- case was serious enough that it showed up in a CPU profile and consequently
+-- I wanted to fix it for 8.10.
+very_aggressive :: DynFlags -> Bool
+very_aggressive = ufVeryAggressive
+{-# NOINLINE very_aggressive #-}
+
 tryUnfolding :: DynFlags -> Id -> Bool -> [ArgSummary] -> CallCtxt
              -> CoreExpr -> Bool -> Bool -> UnfoldingGuidance
              -> Maybe CoreExpr
@@ -1297,7 +1336,7 @@ tryUnfolding dflags id lone_variable
      UnfNever -> traceInline dflags id str (text "UnfNever") Nothing
 
      UnfWhen { ug_arity = uf_arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }
-        | enough_args && (boring_ok || some_benefit || ufVeryAggressive dflags)
+        | enough_args && (boring_ok || some_benefit || very_aggressive dflags)
                 -- See Note [INLINE for small functions (3)]
         -> traceInline dflags id str (mk_doc some_benefit empty True) (Just unf_template)
         | otherwise
@@ -1307,7 +1346,7 @@ tryUnfolding dflags id lone_variable
           enough_args = (n_val_args >= uf_arity) || (unsat_ok && n_val_args > 0)
 
      UnfIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size }
-        | ufVeryAggressive dflags
+        | very_aggressive dflags
         -> traceInline dflags id str (mk_doc some_benefit extra_doc True) (Just unf_template)
         | is_wf && some_benefit && small_enough
         -> traceInline dflags id str (mk_doc some_benefit extra_doc True) (Just unf_template)

compiler/coreSyn/CoreUtils.hs

@@ -2379,6 +2379,8 @@ But the simplifier pushes those casts outwards, so we don't
 need to address that here.
 -}
 
+-- When updating this function, make sure to update
+-- CorePrep.tryEtaReducePrep as well!
 tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr
 tryEtaReduce bndrs body
   = go (reverse bndrs) body (mkRepReflCo (exprType body))

compiler/deSugar/Coverage.hs

@@ -113,7 +113,7 @@ addTicksToBinds hsc_env mod mod_loc exports tyCons binds
 
      dumpIfSet_dyn dflags Opt_D_dump_ticked "HPC" (pprLHsBinds binds1)
 
-     return (binds1, HpcInfo tickCount hashNo, Just modBreaks)
+     return (binds1, HpcInfo tickCount hashNo, modBreaks)
 
   | otherwise = return (binds, emptyHpcInfo False, Nothing)
 
@@ -130,23 +130,23 @@ guessSourceFile binds orig_file =
         _ -> orig_file
 
 
-mkModBreaks :: HscEnv -> Module -> Int -> [MixEntry_] -> IO ModBreaks
+mkModBreaks :: HscEnv -> Module -> Int -> [MixEntry_] -> IO (Maybe ModBreaks)
 mkModBreaks hsc_env mod count entries
-  | HscInterpreted <- hscTarget (hsc_dflags hsc_env) = do
+  | breakpointsEnabled (hsc_dflags hsc_env) = do
     breakArray <- GHCi.newBreakArray hsc_env (length entries)
     ccs <- mkCCSArray hsc_env mod count entries
     let
            locsTicks  = listArray (0,count-1) [ span  | (span,_,_,_)  <- entries ]
            varsTicks  = listArray (0,count-1) [ vars  | (_,_,vars,_)  <- entries ]
            declsTicks = listArray (0,count-1) [ decls | (_,decls,_,_) <- entries ]
-    return emptyModBreaks
+    return $ Just $ emptyModBreaks
                        { modBreaks_flags = breakArray
                        , modBreaks_locs  = locsTicks
                        , modBreaks_vars  = varsTicks
                        , modBreaks_decls = declsTicks
                        , modBreaks_ccs   = ccs
                        }
-  | otherwise = return emptyModBreaks
+  | otherwise = return Nothing
 
 mkCCSArray
   :: HscEnv -> Module -> Int -> [MixEntry_]
@@ -1041,7 +1041,7 @@ data TickishType = ProfNotes | HpcTicks | Breakpoints | SourceNotes
 
 coveragePasses :: DynFlags -> [TickishType]
 coveragePasses dflags =
-    ifa (hscTarget dflags == HscInterpreted) Breakpoints $
+    ifa (breakpointsEnabled dflags)          Breakpoints $
     ifa (gopt Opt_Hpc dflags)                HpcTicks $
     ifa (gopt Opt_SccProfilingOn dflags &&
          profAuto dflags /= NoProfAuto)      ProfNotes $
@@ -1049,6 +1049,10 @@ coveragePasses dflags =
   where ifa f x xs | f         = x:xs
                    | otherwise = xs
 
+-- | Should we produce 'Breakpoint' ticks?
+breakpointsEnabled :: DynFlags -> Bool
+breakpointsEnabled dflags = hscTarget dflags == HscInterpreted
+
 -- | Tickishs that only make sense when their source code location
 -- refers to the current file. This might not always be true due to
 -- LINE pragmas in the code - which would confuse at least HPC.

compiler/deSugar/DsBinds.hs

@@ -695,20 +695,19 @@ dsSpec mb_poly_rhs (dL->L loc (SpecPrag poly_id spec_co spec_inl))
          dflags <- getDynFlags
        ; case decomposeRuleLhs dflags spec_bndrs ds_lhs of {
            Left msg -> do { warnDs NoReason msg; return Nothing } ;
-           Right (rule_bndrs, _fn, args) -> do
+           Right (rule_bndrs, _fn, rule_lhs_args) -> do
 
        { this_mod <- getModule
        ; let fn_unf    = realIdUnfolding poly_id
-             spec_unf  = specUnfolding dflags spec_bndrs core_app arity_decrease fn_unf
+             spec_unf  = specUnfolding dflags spec_bndrs core_app rule_lhs_args fn_unf
              spec_id   = mkLocalId spec_name spec_ty
                             `setInlinePragma` inl_prag
                             `setIdUnfolding`  spec_unf
-             arity_decrease = count isValArg args - count isId spec_bndrs
 
        ; rule <- dsMkUserRule this_mod is_local_id
                         (mkFastString ("SPEC " ++ showPpr dflags poly_name))
                         rule_act poly_name
-                        rule_bndrs args
+                        rule_bndrs rule_lhs_args
                         (mkVarApps (Var spec_id) spec_bndrs)
 
        ; let spec_rhs = mkLams spec_bndrs (core_app poly_rhs)