[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 7 commits: Switch from HscSource to IsBootInterface for module lookup in GhcMake

Marge Bot gitlab at gitlab.haskell.org
Sat Jun 20 23:04:35 UTC 2020



 Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC


Commits:
be988a2d by John Ericson at 2020-06-20T19:03:50-04:00
Switch from HscSource to IsBootInterface for module lookup in GhcMake

We look up modules by their name, and not their contents. There is no
way to separately reference a signature vs regular module; you get what
you get. Only boot files can be referenced indepenently with `import {-#
SOURCE #-}`.

- - - - -
6bdab65b by Sylvain Henry at 2020-06-20T19:04:20-04:00
Cmm: introduce SAVE_REGS/RESTORE_REGS

We don't want to save both Fn and Dn register sets on x86-64 as they are
aliased to the same arch register (XMMn).

Moreover, when SAVE_STGREGS was used in conjunction with `jump foo [*]`
which makes a set of Cmm registers alive so that they cover all arch
registers used to pass parameter, we could have Fn, Dn and XMMn alive at
the same time. It made the LLVM code generator choke (see #17920).

Now `SAVE_REGS/RESTORE_REGS` and `jump foo [*]` use the same set of
registers.

- - - - -
75819b0d by Sylvain Henry at 2020-06-20T19:04:20-04:00
CmmToC: don't add extern decl to parsed Cmm data

Previously, if a .cmm file *not in the RTS* contained something like:

```cmm
section "rodata" { msg : bits8[] "Test\n"; }
```

It would get compiled by CmmToC into:

```c
ERW_(msg);
const char msg[] = "Test\012";
```

and fail with:

```
/tmp/ghc32129_0/ghc_4.hc:5:12: error:
     error: conflicting types for \u2018msg\u2019
     const char msg[] = "Test\012";
                ^~~

In file included from /tmp/ghc32129_0/ghc_4.hc:3:0: error:

/tmp/ghc32129_0/ghc_4.hc:4:6: error:
     note: previous declaration of \u2018msg\u2019 was here
     ERW_(msg);
          ^

/builds/hsyl20/ghc/_build/install/lib/ghc-8.11.0.20200605/lib/../lib/x86_64-linux-ghc-8.11.0.20200605/rts-1.0/include/Stg.h:253:46: error:
     note: in definition of macro \u2018ERW_\u2019
     #define ERW_(X)   extern       StgWordArray (X)
                                                  ^
```

See the rationale for this on https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/backends/ppr-c#prototypes

Now we don't generate these extern declarations (ERW_, etc.) for
top-level data. It shouldn't change anything for the RTS (the only place
we use .cmm files) as it is already special cased in
`GHC.Cmm.CLabel.needsCDecl`. And hand-written Cmm can use explicit
extern declarations when needed.

Note that it allows `cgrun069` test to pass with CmmToC (cf #15467).

- - - - -
17dadbf2 by Sylvain Henry at 2020-06-20T19:04:20-04:00
LLVM: refactor and comment register padding code (#17920)

- - - - -
1463aaee by Sylvain Henry at 2020-06-20T19:04:20-04:00
Add tests for #17920

Metric Decrease:
    T12150
    T12234

- - - - -
ffd954c0 by Simon Peyton Jones at 2020-06-20T19:04:20-04:00
Fix a buglet in Simplify.simplCast

This bug, revealed by #18347, is just a missing update to
sc_hole_ty in simplCast.  I'd missed a code path when I
made the recentchanges in

    commit 6d49d5be904c0c01788fa7aae1b112d5b4dfaf1c
    Author: Simon Peyton Jones <simonpj at microsoft.com>
    Date:   Thu May 21 12:53:35 2020 +0100

    Implement cast worker/wrapper properly

The fix is very easy.

Two other minor changes

* Tidy up in SimpleOpt.simple_opt_expr. In fact I think this is an
  outright bug, introduced in the fix to #18112: we were simplifying
  the same coercion twice *with the same substitution*, which is just
  wrong.  It'd be a hard bug to trigger, so I just fixed it; less code
  too.

* Better debug printing of ApplyToVal

- - - - -
faa12bc6 by Simon Peyton Jones at 2020-06-20T19:04:20-04:00
Two small tweaks to Coercion.simplifyArgsWorker

These tweaks affect the inner loop of simplifyArgsWorker, which
in turn is called from the flattener in Flatten.hs.  This is
a key perf bottleneck to T9872{a,b,c,d}.

These two small changes have a modest but useful benefit.
No change in functionality whatsoever.

Relates to #18354

- - - - -


28 changed files:

- compiler/GHC/Cmm/CLabel.hs
- compiler/GHC/Cmm/CallConv.hs
- compiler/GHC/Cmm/Parser.y
- compiler/GHC/CmmToLlvm/Base.hs
- compiler/GHC/CmmToLlvm/CodeGen.hs
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/Opt/Simplify.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/SimpleOpt.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/StgToCmm/Foreign.hs
- compiler/GHC/StgToCmm/Prof.hs
- compiler/GHC/StgToCmm/Ticky.hs
- compiler/GHC/StgToCmm/Utils.hs
- includes/Cmm.h
- rts/StgMiscClosures.cmm
- testsuite/driver/testlib.py
- testsuite/tests/cmm/should_compile/all.T
- testsuite/tests/codeGen/should_compile/all.T
- testsuite/tests/codeGen/should_fail/all.T
- + testsuite/tests/codeGen/should_run/T17920.cmm
- + testsuite/tests/codeGen/should_run/T17920.stdout
- testsuite/tests/codeGen/should_run/all.T
- testsuite/tests/driver/all.T
- + testsuite/tests/llvm/should_compile/T17920fail.cmm
- testsuite/tests/llvm/should_compile/all.T
- + testsuite/tests/simplCore/should_compile/T18347.hs
- testsuite/tests/simplCore/should_compile/all.T


Changes:

=====================================
compiler/GHC/Cmm/CLabel.hs
=====================================
@@ -12,6 +12,7 @@
 
 module GHC.Cmm.CLabel (
         CLabel, -- abstract type
+        NeedExternDecl (..),
         ForeignLabelSource(..),
         pprDebugCLabel,
 
@@ -71,6 +72,7 @@ module GHC.Cmm.CLabel (
         mkCmmRetLabel,
         mkCmmCodeLabel,
         mkCmmDataLabel,
+        mkRtsCmmDataLabel,
         mkCmmClosureLabel,
 
         mkRtsApFastLabel,
@@ -182,13 +184,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
@@ -208,13 +211,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
 
@@ -227,7 +230,7 @@ data CLabel
   -- Must not occur outside of the NCG or LLVM code generators.
   | AsmTempDerivedLabel
         CLabel
-        FastString              -- suffix
+        FastString              -- ^ suffix
 
   | StringLitLabel
         {-# UNPACK #-} !Unique
@@ -275,6 +278,24 @@ isTickyLabel :: CLabel -> Bool
 isTickyLabel (IdLabel _ _ RednCounts) = True
 isTickyLabel _ = False
 
+-- | 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]
@@ -285,10 +306,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) =
@@ -380,7 +402,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")
@@ -510,24 +532,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
@@ -551,16 +573,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
@@ -593,7 +622,7 @@ mkApEntryLabel dflags upd arity =
 -- A call to some primitive hand written Cmm code
 mkPrimCallLabel :: PrimCall -> CLabel
 mkPrimCallLabel (PrimCall str pkg)
-        = CmmLabel (toUnitId pkg) str CmmPrimCall
+        = CmmLabel (toUnitId pkg) (NeedExternDecl True) str CmmPrimCall
 
 
 -- Constructing ForeignLabels
@@ -631,7 +660,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
@@ -643,7 +672,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
@@ -725,7 +754,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
@@ -740,16 +769,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
@@ -801,10 +830,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
@@ -929,7 +961,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
@@ -972,14 +1004,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
@@ -1049,7 +1081,7 @@ labelDynamic config 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 && (toUnitId this_pkg /= pkg)
     | otherwise       -> externalDynamicRefs
 
@@ -1248,9 +1280,9 @@ pprCLbl platform = \case
                            -- until that gets resolved we'll just force them to start
                            -- with a letter so the label will be legal assembly code.
 
-   (CmmLabel _ str CmmCode)     -> ftext str
-   (CmmLabel _ str CmmData)     -> ftext str
-   (CmmLabel _ str CmmPrimCall) -> ftext str
+   (CmmLabel _ _ str CmmCode)     -> ftext str
+   (CmmLabel _ _ str CmmData)     -> ftext str
+   (CmmLabel _ _ str CmmPrimCall) -> ftext str
 
    (LocalBlockLabel u) -> tempLabelPrefixOrUnderscore platform <> text "blk_" <> pprUniqueAlways u
 
@@ -1284,11 +1316,11 @@ pprCLbl platform = \case
                         else (sLit "_noupd_entry"))
         ]
 
-   (CmmLabel _ fs CmmInfo)    -> ftext fs <> text "_info"
-   (CmmLabel _ fs CmmEntry)   -> ftext fs <> text "_entry"
-   (CmmLabel _ fs CmmRetInfo) -> ftext fs <> text "_info"
-   (CmmLabel _ fs CmmRet)     -> ftext fs <> text "_ret"
-   (CmmLabel _ fs CmmClosure) -> ftext fs <> text "_closure"
+   (CmmLabel _ _ fs CmmInfo)    -> ftext fs <> text "_info"
+   (CmmLabel _ _ fs CmmEntry)   -> ftext fs <> text "_entry"
+   (CmmLabel _ _ fs CmmRetInfo) -> ftext fs <> text "_info"
+   (CmmLabel _ _ fs CmmRet)     -> ftext fs <> text "_ret"
+   (CmmLabel _ _ fs CmmClosure) -> ftext fs <> text "_closure"
 
    (RtsLabel (RtsPrimOp primop)) -> text "stg_" <> ppr primop
    (RtsLabel (RtsSlowFastTickyCtr pat)) ->


=====================================
compiler/GHC/Cmm/CallConv.hs
=====================================
@@ -206,9 +206,13 @@ realArgRegsCover dflags
     | passFloatArgsInXmm (targetPlatform 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)
+      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/GHC/Cmm/Parser.y
=====================================
@@ -399,7 +399,7 @@ cmmdata :: { CmmParse () }
 data_label :: { CmmParse CLabel }
     : NAME ':'
                 {% liftP . withHomeUnitId $ \pkg ->
-                   return (mkCmmDataLabel pkg $1) }
+                   return (mkCmmDataLabel pkg (NeedExternDecl False) $1) }
 
 statics :: { [CmmParse [CmmStatic]] }
         : {- empty -}                   { [] }
@@ -1115,6 +1115,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 ),
 
@@ -1173,7 +1176,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/GHC/CmmToLlvm/Base.hs
=====================================
@@ -42,12 +42,14 @@ module GHC.CmmToLlvm.Base (
 #include "ghcautoconf.h"
 
 import GHC.Prelude
+import GHC.Utils.Panic
 
 import GHC.Llvm
 import GHC.CmmToLlvm.Regs
 
 import GHC.Cmm.CLabel
-import GHC.Platform.Regs ( activeStgRegs )
+import GHC.Cmm.Ppr.Expr ()
+import GHC.Platform.Regs ( activeStgRegs, globalRegMaybe )
 import GHC.Driver.Session
 import GHC.Data.FastString
 import GHC.Cmm              hiding ( succ )
@@ -65,7 +67,8 @@ import qualified GHC.Data.Stream as Stream
 import Data.Maybe (fromJust)
 import Control.Monad (ap)
 import Data.Char (isDigit)
-import Data.List (sort, groupBy, intercalate)
+import Data.List (sortBy, groupBy, intercalate)
+import Data.Ord (comparing)
 import qualified Data.List.NonEmpty as NE
 
 -- ----------------------------------------------------------------------------
@@ -157,8 +160,10 @@ llvmFunArgs :: Platform -> LiveGlobalRegs -> [LlvmVar]
 llvmFunArgs platform live =
     map (lmGlobalRegArg platform) (filter isPassed allRegs)
     where allRegs = activeStgRegs platform
-          paddedLive = map (\(_,r) -> r) $ padLiveArgs platform live
-          isLive r = r `elem` alwaysLive || r `elem` paddedLive
+          paddingRegs = padLiveArgs platform live
+          isLive r = r `elem` alwaysLive
+                     || r `elem` live
+                     || r `elem` paddingRegs
           isPassed r = not (isFPR r) || isLive r
 
 
@@ -170,91 +175,76 @@ isFPR (YmmReg _)    = True
 isFPR (ZmmReg _)    = True
 isFPR _             = False
 
-sameFPRClass :: GlobalReg -> GlobalReg -> Bool
-sameFPRClass (FloatReg _)  (FloatReg _) = True
-sameFPRClass (DoubleReg _) (DoubleReg _) = True
-sameFPRClass (XmmReg _)    (XmmReg _) = True
-sameFPRClass (YmmReg _)    (YmmReg _) = True
-sameFPRClass (ZmmReg _)    (ZmmReg _) = True
-sameFPRClass _             _          = False
-
-normalizeFPRNum :: GlobalReg -> GlobalReg
-normalizeFPRNum (FloatReg _)  = FloatReg 1
-normalizeFPRNum (DoubleReg _) = DoubleReg 1
-normalizeFPRNum (XmmReg _)    = XmmReg 1
-normalizeFPRNum (YmmReg _)    = YmmReg 1
-normalizeFPRNum (ZmmReg _)    = ZmmReg 1
-normalizeFPRNum _ = error "normalizeFPRNum expected only FPR regs"
-
-getFPRCtor :: GlobalReg -> Int -> GlobalReg
-getFPRCtor (FloatReg _)  = FloatReg
-getFPRCtor (DoubleReg _) = DoubleReg
-getFPRCtor (XmmReg _)    = XmmReg
-getFPRCtor (YmmReg _)    = YmmReg
-getFPRCtor (ZmmReg _)    = ZmmReg
-getFPRCtor _ = error "getFPRCtor expected only FPR regs"
-
-fprRegNum :: GlobalReg -> Int
-fprRegNum (FloatReg i)  = i
-fprRegNum (DoubleReg i) = i
-fprRegNum (XmmReg i)    = i
-fprRegNum (YmmReg i)    = i
-fprRegNum (ZmmReg i)    = i
-fprRegNum _ = error "fprRegNum expected only FPR regs"
-
--- | Input: dynflags, and the list of live registers
+-- | Return a list of "padding" registers for LLVM function calls.
 --
--- Output: An augmented list of live registers, where padding was
--- added to the list of registers to ensure the calling convention is
--- correctly used by LLVM.
+-- When we generate LLVM function signatures, we can't just make any register
+-- alive on function entry. Instead, we need to insert fake arguments of the
+-- same register class until we are sure that one of them is mapped to the
+-- register we want alive. E.g. to ensure that F5 is alive, we may need to
+-- insert fake arguments mapped to F1, F2, F3 and F4.
 --
--- Each global reg in the returned list is tagged with a bool, which
--- indicates whether the global reg was added as padding, or was an original
--- live register.
---
--- That is, True => padding, False => a real, live global register.
---
--- Also, the returned list is not sorted in any particular order.
---
-padLiveArgs :: Platform -> LiveGlobalRegs -> [(Bool, GlobalReg)]
-padLiveArgs plat live =
-      if platformUnregisterised plat
-        then taggedLive -- not using GHC's register convention for platform.
-        else padding ++ taggedLive
+-- Invariant: Cmm FPR regs with number "n" maps to real registers with number
+-- "n" If the calling convention uses registers in a different order or if the
+-- invariant doesn't hold, this code probably won't be correct.
+padLiveArgs :: Platform -> LiveGlobalRegs -> LiveGlobalRegs
+padLiveArgs platform live =
+      if platformUnregisterised platform
+        then [] -- not using GHC's register convention for platform.
+        else padded
   where
-    taggedLive = map (\x -> (False, x)) live
-
-    fprLive = filter isFPR live
-    padding = concatMap calcPad $ groupBy sharesClass fprLive
-
-    sharesClass :: GlobalReg -> GlobalReg -> Bool
-    sharesClass a b = sameFPRClass a b || overlappingClass
+    ----------------------------------
+    -- handle floating-point registers (FPR)
+
+    fprLive = filter isFPR live  -- real live FPR registers
+
+    -- we group live registers sharing the same classes, i.e. that use the same
+    -- set of real registers to be passed. E.g. FloatReg, DoubleReg and XmmReg
+    -- all use the same real regs on X86-64 (XMM registers).
+    --
+    classes         = groupBy sharesClass fprLive
+    sharesClass a b = regsOverlap platform (norm a) (norm b) -- check if mapped to overlapping registers
+    norm x          = CmmGlobal ((fpr_ctor x) 1)             -- get the first register of the family
+
+    -- For each class, we just have to fill missing registers numbers. We use
+    -- the constructor of the greatest register to build padding registers.
+    --
+    -- E.g. sortedRs = [   F2,   XMM4, D5]
+    --      output   = [D1,   D3]
+    padded      = concatMap padClass classes
+    padClass rs = go sortedRs [1..]
       where
-        overlappingClass = regsOverlap plat (norm a) (norm b)
-        norm = CmmGlobal . normalizeFPRNum
-
-    calcPad :: [GlobalReg] -> [(Bool, GlobalReg)]
-    calcPad rs = getFPRPadding (getFPRCtor $ head rs) rs
-
-getFPRPadding :: (Int -> GlobalReg) -> LiveGlobalRegs -> [(Bool, GlobalReg)]
-getFPRPadding paddingCtor live = padding
-    where
-        fprRegNums = sort $ map fprRegNum live
-        (_, padding) = foldl assignSlots (1, []) $ fprRegNums
-
-        assignSlots (i, acc) regNum
-            | i == regNum = -- don't need padding here
-                  (i+1, acc)
-            | i < regNum = let -- add padding for slots i .. regNum-1
-                  numNeeded = regNum-i
-                  acc' = genPad i numNeeded ++ acc
-                in
-                  (regNum+1, acc')
-            | otherwise = error "padLiveArgs -- i > regNum ??"
-
-        genPad start n =
-            take n $ flip map (iterate (+1) start) (\i ->
-                (True, paddingCtor i))
+         sortedRs = sortBy (comparing fpr_num) rs
+         maxr     = last sortedRs
+         ctor     = fpr_ctor maxr
+
+         go [] _ = []
+         go (c1:c2:_) _   -- detect bogus case (see #17920)
+            | fpr_num c1 == fpr_num c2
+            , Just real <- globalRegMaybe platform c1
+            = sorryDoc "LLVM code generator" $
+               text "Found two different Cmm registers (" <> ppr c1 <> text "," <> ppr c2 <>
+               text ") both alive AND mapped to the same real register: " <> ppr real <>
+               text ". This isn't currently supported by the LLVM backend."
+         go (c:cs) (f:fs)
+            | fpr_num c == f = go cs fs              -- already covered by a real register
+            | otherwise      = ctor f : go (c:cs) fs -- add padding register
+         go _ _ = undefined -- unreachable
+
+    fpr_ctor :: GlobalReg -> Int -> GlobalReg
+    fpr_ctor (FloatReg _)  = FloatReg
+    fpr_ctor (DoubleReg _) = DoubleReg
+    fpr_ctor (XmmReg _)    = XmmReg
+    fpr_ctor (YmmReg _)    = YmmReg
+    fpr_ctor (ZmmReg _)    = ZmmReg
+    fpr_ctor _ = error "fpr_ctor expected only FPR regs"
+
+    fpr_num :: GlobalReg -> Int
+    fpr_num (FloatReg i)  = i
+    fpr_num (DoubleReg i) = i
+    fpr_num (XmmReg i)    = i
+    fpr_num (YmmReg i)    = i
+    fpr_num (ZmmReg i)    = i
+    fpr_num _ = error "fpr_num expected only FPR regs"
 
 
 -- | Llvm standard fun attributes


=====================================
compiler/GHC/CmmToLlvm/CodeGen.hs
=====================================
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, GADTs #-}
+{-# LANGUAGE CPP, GADTs, MultiWayIf #-}
 {-# OPTIONS_GHC -fno-warn-type-defaults #-}
 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
 -- ----------------------------------------------------------------------------
@@ -38,6 +38,7 @@ import GHC.Utils.Misc
 
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.Writer
+import Control.Monad
 
 import qualified Data.Semigroup as Semigroup
 import Data.List ( nub )
@@ -1848,7 +1849,7 @@ funPrologue live cmmBlocks = do
       isLive r     = r `elem` alwaysLive || r `elem` live
 
   platform <- getPlatform
-  stmtss <- flip mapM assignedRegs $ \reg ->
+  stmtss <- forM assignedRegs $ \reg ->
     case reg of
       CmmLocal (LocalReg un _) -> do
         let (newv, stmts) = allocReg reg
@@ -1875,9 +1876,7 @@ funEpilogue :: LiveGlobalRegs -> LlvmM ([LlvmVar], LlvmStatements)
 funEpilogue live = do
     platform <- getPlatform
 
-    -- the bool indicates whether the register is padding.
-    let alwaysNeeded = map (\r -> (False, r)) alwaysLive
-        livePadded = alwaysNeeded ++ padLiveArgs platform live
+    let paddingRegs = padLiveArgs platform live
 
     -- Set to value or "undef" depending on whether the register is
     -- actually live
@@ -1887,14 +1886,25 @@ funEpilogue live = do
         loadUndef r = do
           let ty = (pLower . getVarType $ lmGlobalRegVar platform r)
           return (Just $ LMLitVar $ LMUndefLit ty, nilOL)
-    platform <- getPlatform
+
+    -- Note that floating-point registers in `activeStgRegs` must be sorted
+    -- according to the calling convention.
+    --  E.g. for X86:
+    --     GOOD: F1,D1,XMM1,F2,D2,XMM2,...
+    --     BAD : F1,F2,F3,D1,D2,D3,XMM1,XMM2,XMM3,...
+    --  As Fn, Dn and XMMn use the same register (XMMn) to be passed, we don't
+    --  want to pass F2 before D1 for example, otherwise we could get F2 -> XMM1
+    --  and D1 -> XMM2.
     let allRegs = activeStgRegs platform
-    loads <- flip mapM allRegs $ \r -> case () of
-      _ | (False, r) `elem` livePadded
-                             -> loadExpr r   -- if r is not padding, load it
-        | not (isFPR r) || (True, r) `elem` livePadded
-                             -> loadUndef r
-        | otherwise          -> return (Nothing, nilOL)
+    loads <- forM allRegs $ \r -> if
+      -- load live registers
+      | r `elem` alwaysLive  -> loadExpr r
+      | r `elem` live        -> loadExpr r
+      -- load all non Floating-Point Registers
+      | not (isFPR r)        -> loadUndef r
+      -- load padding Floating-Point Registers
+      | r `elem` paddingRegs -> loadUndef r
+      | otherwise            -> return (Nothing, nilOL)
 
     let (vars, stmts) = unzip loads
     return (catMaybes vars, concatOL stmts)


=====================================
compiler/GHC/Core/Coercion.hs
=====================================
@@ -1794,6 +1794,8 @@ liftCoSubstWith r tvs cos ty
 -- @lc_left@ is a substitution mapping type variables to the left-hand
 -- types of the mapped coercions in @lc@, and similar for @lc_right at .
 liftCoSubst :: HasDebugCallStack => Role -> LiftingContext -> Type -> Coercion
+{-# INLINE liftCoSubst #-}
+-- Inlining this function is worth 2% of allocation in T9872d,
 liftCoSubst r lc@(LC subst env) ty
   | isEmptyVarEnv env = mkReflCo r (substTy subst ty)
   | otherwise         = ty_co_subst lc r ty
@@ -2846,7 +2848,9 @@ simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs
        -> [Role]      -- Roles at which to flatten these ...
        -> [(Type, Coercion)]  -- flattened arguments, with their flattening coercions
        -> ([Type], [Coercion], CoercionN)
-    go acc_xis acc_cos lc binders inner_ki _ []
+    go acc_xis acc_cos !lc binders inner_ki _ []
+        -- The !lc makes the function strict in the lifting context
+        -- which means GHC can unbox that pair.  A modest win.
       = (reverse acc_xis, reverse acc_cos, kind_co)
       where
         final_kind = mkPiTys binders inner_ki


=====================================
compiler/GHC/Core/Opt/Simplify.hs
=====================================
@@ -1456,7 +1456,8 @@ simplCast env body co0 cont0
           = {-#SCC "addCoerce-pushCoValArg" #-}
             do { tail' <- addCoerceM m_co2 tail
                ; if isReflCo co1
-                 then return (cont { sc_cont = tail' })
+                 then return (cont { sc_cont = tail'
+                                   , sc_hole_ty = coercionLKind co })
                       -- Avoid simplifying if possible;
                       -- See Note [Avoiding exponential behaviour]
                  else do


=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -221,9 +221,10 @@ instance Outputable SimplCont where
   ppr (TickIt t cont)       = (text "TickIt" <+> ppr t) $$ ppr cont
   ppr (ApplyToTy  { sc_arg_ty = ty, sc_cont = cont })
     = (text "ApplyToTy" <+> pprParendType ty) $$ ppr cont
-  ppr (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_cont = cont })
-    = (text "ApplyToVal" <+> ppr dup <+> pprParendExpr arg)
-                                        $$ ppr cont
+  ppr (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_cont = cont, sc_hole_ty = hole_ty })
+    = (hang (text "ApplyToVal" <+> ppr dup <+> text "hole" <+> ppr hole_ty)
+          2 (pprParendExpr arg))
+      $$ ppr cont
   ppr (StrictBind { sc_bndr = b, sc_cont = cont })
     = (text "StrictBind" <+> ppr b) $$ ppr cont
   ppr (StrictArg { sc_fun = ai, sc_cont = cont })


=====================================
compiler/GHC/Core/SimpleOpt.hs
=====================================
@@ -213,6 +213,7 @@ simple_opt_expr env expr
     in_scope     = substInScope subst
     in_scope_env = (in_scope, simpleUnfoldingFun)
 
+    ---------------
     go (Var v)
        | Just clo <- lookupVarEnv (soe_inl env) v
        = simple_opt_clo env clo
@@ -221,17 +222,10 @@ simple_opt_expr env expr
 
     go (App e1 e2)      = simple_app env e1 [(env,e2)]
     go (Type ty)        = Type     (substTy subst ty)
-    go (Coercion co)    = Coercion (optCoercion (soe_dflags env) (getTCvSubst subst) co)
+    go (Coercion co)    = Coercion (go_co co)
     go (Lit lit)        = Lit lit
     go (Tick tickish e) = mkTick (substTickish subst tickish) (go e)
-    go (Cast e co)      = case go e of
-                            -- flatten nested casts before calling the coercion optimizer;
-                            -- see #18112 (note that mkCast handles dropping Refl coercions)
-                            Cast e' co' -> mkCast e' (opt_co (mkTransCo co' co))
-                            e'          -> mkCast e' (opt_co co)
-                          where
-                            opt_co = optCoercion (soe_dflags env) (getTCvSubst subst)
-
+    go (Cast e co)      = mk_cast (go e) (go_co co)
     go (Let bind body)  = case simple_opt_bind env bind NotTopLevel of
                              (env', Nothing)   -> simple_opt_expr env' body
                              (env', Just bind) -> Let bind (simple_opt_expr env' body)
@@ -266,6 +260,9 @@ simple_opt_expr env expr
         e' = go e
         (env', b') = subst_opt_bndr env b
 
+    ----------------------
+    go_co co = optCoercion (soe_dflags env) (getTCvSubst subst) co
+
     ----------------------
     go_alt env (con, bndrs, rhs)
       = (con, bndrs', simple_opt_expr env' rhs)
@@ -285,6 +282,15 @@ simple_opt_expr env expr
          bs = reverse bs'
          e' = simple_opt_expr env e
 
+mk_cast :: CoreExpr -> CoercionR -> CoreExpr
+-- Like GHC.Core.Utils.mkCast, but does a full reflexivity check.
+-- mkCast doesn't do that because the Simplifier does (in simplCast)
+-- But in SimpleOpt it's nice to kill those nested casts (#18112)
+mk_cast (Cast e co1) co2        = mk_cast e (co1 `mkTransCo` co2)
+mk_cast (Tick t e)   co         = Tick t (mk_cast e co)
+mk_cast e co | isReflexiveCo co = e
+             | otherwise        = Cast e co
+
 ----------------------
 -- simple_app collects arguments for beta reduction
 simple_app :: SimpleOptEnv -> InExpr -> [SimpleClo] -> CoreExpr


=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -1917,7 +1917,7 @@ reachableBackwards mod summaries
   = [ node_payload node | node <- reachableG (transposeG graph) root ]
   where -- the rest just sets up the graph:
         (graph, lookup_node) = moduleGraphNodes False summaries
-        root  = expectJust "reachableBackwards" (lookup_node HsBootFile mod)
+        root  = expectJust "reachableBackwards" (lookup_node IsBoot mod)
 
 -- ---------------------------------------------------------------------------
 --
@@ -1960,7 +1960,7 @@ topSortModuleGraph drop_hs_boot_nodes module_graph mb_root_mod
             -- the specified module.  We do this by building a graph with
             -- the full set of nodes, and determining the reachable set from
             -- the specified node.
-            let root | Just node <- lookup_node HsSrcFile root_mod
+            let root | Just node <- lookup_node NotBoot root_mod
                      , graph `hasVertexG` node
                      = node
                      | otherwise
@@ -1976,21 +1976,18 @@ summaryNodeSummary :: SummaryNode -> ModSummary
 summaryNodeSummary = node_payload
 
 moduleGraphNodes :: Bool -> [ModSummary]
-  -> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode)
+  -> (Graph SummaryNode, IsBootInterface -> ModuleName -> Maybe SummaryNode)
 moduleGraphNodes drop_hs_boot_nodes summaries =
   (graphFromEdgedVerticesUniq nodes, lookup_node)
   where
     numbered_summaries = zip summaries [1..]
 
-    lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode
+    lookup_node :: IsBootInterface -> ModuleName -> Maybe SummaryNode
     lookup_node hs_src mod = Map.lookup
-      GWIB
-        { gwib_mod = mod
-        , gwib_isBoot = hscSourceToIsBoot hs_src
-        }
+      (GWIB { gwib_mod = mod, gwib_isBoot = hs_src })
       node_map
 
-    lookup_key :: HscSource -> ModuleName -> Maybe Int
+    lookup_key :: IsBootInterface -> ModuleName -> Maybe Int
     lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod)
 
     node_map :: NodeMap SummaryNode
@@ -2010,11 +2007,11 @@ moduleGraphNodes drop_hs_boot_nodes summaries =
              -- Drop the hi-boot ones if told to do so
             , not (isBootSummary s == IsBoot && drop_hs_boot_nodes)
             , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_home_srcimps s)) ++
-                             out_edge_keys HsSrcFile   (map unLoc (ms_home_imps s)) ++
+                             out_edge_keys NotBoot     (map unLoc (ms_home_imps s)) ++
                              (-- see [boot-edges] below
                               if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile
                               then []
-                              else case lookup_key HsBootFile (ms_mod_name s) of
+                              else case lookup_key IsBoot (ms_mod_name s) of
                                     Nothing -> []
                                     Just k  -> [k]) ]
 
@@ -2027,10 +2024,10 @@ moduleGraphNodes drop_hs_boot_nodes summaries =
     -- most up to date information.
 
     -- Drop hs-boot nodes by using HsSrcFile as the key
-    hs_boot_key | drop_hs_boot_nodes = HsSrcFile
-                | otherwise          = HsBootFile
+    hs_boot_key | drop_hs_boot_nodes = NotBoot -- is regular mod or signature
+                | otherwise          = IsBoot
 
-    out_edge_keys :: HscSource -> [ModuleName] -> [Int]
+    out_edge_keys :: IsBootInterface -> [ModuleName] -> [Int]
     out_edge_keys hi_boot ms = mapMaybe (lookup_key hi_boot) ms
         -- If we want keep_hi_boot_nodes, then we do lookup_key with
         -- IsBoot; else False


=====================================
compiler/GHC/StgToCmm/Foreign.hs
=====================================
@@ -13,6 +13,8 @@ module GHC.StgToCmm.Foreign (
   emitSaveThreadState,
   saveThreadState,
   emitLoadThreadState,
+  emitSaveRegs,
+  emitRestoreRegs,
   loadThreadState,
   emitOpenNursery,
   emitCloseNursery,
@@ -32,6 +34,7 @@ import GHC.Cmm.BlockId (newBlockId)
 import GHC.Cmm
 import GHC.Cmm.Utils
 import GHC.Cmm.Graph
+import GHC.Cmm.CallConv
 import GHC.Core.Type
 import GHC.Types.RepType
 import GHC.Cmm.CLabel
@@ -308,6 +311,32 @@ saveThreadState dflags = do
       else mkNop
     ]
 
+
+
+-- | Save STG registers
+--
+-- STG registers must be saved around a C call, just in case the STG
+-- register is mapped to a caller-saves machine register.  Normally we
+-- don't need to worry about this the code generator has already
+-- loaded any live STG registers into variables for us, but in
+-- hand-written low-level Cmm code where we don't know which registers
+-- are live, we might have to save them all.
+emitSaveRegs :: FCode ()
+emitSaveRegs = do
+   dflags <- getDynFlags
+   let regs = realArgRegsCover dflags
+       save = catAGraphs (map (callerSaveGlobalReg dflags) regs)
+   emit save
+
+-- | Restore STG registers (see 'emitSaveRegs')
+emitRestoreRegs :: FCode ()
+emitRestoreRegs = do
+   dflags <- getDynFlags
+   let regs = realArgRegsCover dflags
+       save = catAGraphs (map (callerRestoreGlobalReg dflags) regs)
+   emit save
+
+
 emitCloseNursery :: FCode ()
 emitCloseNursery = do
   dflags <- getDynFlags


=====================================
compiler/GHC/StgToCmm/Prof.hs
=====================================
@@ -364,7 +364,7 @@ ldvEnter cl_ptr = do
 
 loadEra :: DynFlags -> CmmExpr
 loadEra dflags = CmmMachOp (MO_UU_Conv (cIntWidth dflags) (wordWidth platform))
-    [CmmLoad (mkLblExpr (mkCmmDataLabel rtsUnitId (fsLit "era")))
+    [CmmLoad (mkLblExpr (mkRtsCmmDataLabel (fsLit "era")))
              (cInt dflags)]
     where platform = targetPlatform dflags
 


=====================================
compiler/GHC/StgToCmm/Ticky.hs
=====================================
@@ -115,7 +115,6 @@ import GHC.Cmm.Utils
 import GHC.Cmm.CLabel
 import GHC.Runtime.Heap.Layout
 
-import GHC.Unit
 import GHC.Types.Name
 import GHC.Types.Id
 import GHC.Types.Basic
@@ -356,7 +355,7 @@ registerTickyCtr ctr_lbl = do
         , mkStore (CmmLit (cmmLabelOffB ctr_lbl
                                 (oFFSET_StgEntCounter_registeredp dflags)))
                    (mkIntExpr platform 1) ]
-    ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsUnitId (fsLit "ticky_entry_ctrs"))
+    ticky_entry_ctrs = mkLblExpr (mkRtsCmmDataLabel (fsLit "ticky_entry_ctrs"))
   emit =<< mkCmmIfThen test (catAGraphs register_stmts)
 
 tickyReturnOldCon, tickyReturnNewCon :: RepArity -> FCode ()
@@ -498,12 +497,12 @@ tickyAllocHeap genuine hp
                      bytes,
             -- Bump the global allocation total ALLOC_HEAP_tot
             addToMemLbl (bWord platform)
-                        (mkCmmDataLabel rtsUnitId (fsLit "ALLOC_HEAP_tot"))
+                        (mkRtsCmmDataLabel (fsLit "ALLOC_HEAP_tot"))
                         bytes,
             -- Bump the global allocation counter ALLOC_HEAP_ctr
             if not genuine then mkNop
             else addToMemLbl (bWord platform)
-                             (mkCmmDataLabel rtsUnitId (fsLit "ALLOC_HEAP_ctr"))
+                             (mkRtsCmmDataLabel (fsLit "ALLOC_HEAP_ctr"))
                              1
             ]}
 
@@ -567,13 +566,13 @@ ifTickyDynThunk :: FCode () -> FCode ()
 ifTickyDynThunk code = tickyDynThunkIsOn >>= \b -> when b code
 
 bumpTickyCounter :: FastString -> FCode ()
-bumpTickyCounter lbl = bumpTickyLbl (mkCmmDataLabel rtsUnitId lbl)
+bumpTickyCounter lbl = bumpTickyLbl (mkRtsCmmDataLabel lbl)
 
 bumpTickyCounterBy :: FastString -> Int -> FCode ()
-bumpTickyCounterBy lbl = bumpTickyLblBy (mkCmmDataLabel rtsUnitId lbl)
+bumpTickyCounterBy lbl = bumpTickyLblBy (mkRtsCmmDataLabel lbl)
 
 bumpTickyCounterByE :: FastString -> CmmExpr -> FCode ()
-bumpTickyCounterByE lbl = bumpTickyLblByE (mkCmmDataLabel rtsUnitId lbl)
+bumpTickyCounterByE lbl = bumpTickyLblByE (mkRtsCmmDataLabel lbl)
 
 bumpTickyEntryCount :: CLabel -> FCode ()
 bumpTickyEntryCount lbl = do
@@ -615,7 +614,7 @@ bumpHistogram lbl n = do
     emit (addToMem (bWord platform)
            (cmmIndexExpr platform
                 (wordWidth platform)
-                (CmmLit (CmmLabel (mkCmmDataLabel rtsUnitId lbl)))
+                (CmmLit (CmmLabel (mkRtsCmmDataLabel lbl)))
                 (CmmLit (CmmInt (fromIntegral offset) (wordWidth platform))))
            1)
 


=====================================
compiler/GHC/StgToCmm/Utils.hs
=====================================
@@ -23,6 +23,7 @@ module GHC.StgToCmm.Utils (
         tagToClosure, mkTaggedObjectLoad,
 
         callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr,
+        callerSaveGlobalReg, callerRestoreGlobalReg,
 
         cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
         cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord,
@@ -249,8 +250,8 @@ callerSaveVolatileRegs dflags = (caller_save, caller_load)
   where
     platform = targetPlatform dflags
 
-    caller_save = catAGraphs (map callerSaveGlobalReg    regs_to_save)
-    caller_load = catAGraphs (map callerRestoreGlobalReg regs_to_save)
+    caller_save = catAGraphs (map (callerSaveGlobalReg    dflags) regs_to_save)
+    caller_load = catAGraphs (map (callerRestoreGlobalReg dflags) regs_to_save)
 
     system_regs = [ Sp,SpLim,Hp,HpLim,CCCS,CurrentTSO,CurrentNursery
                     {- ,SparkHd,SparkTl,SparkBase,SparkLim -}
@@ -258,12 +259,14 @@ callerSaveVolatileRegs dflags = (caller_save, caller_load)
 
     regs_to_save = filter (callerSaves platform) system_regs
 
-    callerSaveGlobalReg reg
-        = mkStore (get_GlobalReg_addr dflags reg) (CmmReg (CmmGlobal reg))
+callerSaveGlobalReg :: DynFlags -> GlobalReg -> CmmAGraph
+callerSaveGlobalReg dflags reg
+    = mkStore (get_GlobalReg_addr dflags reg) (CmmReg (CmmGlobal reg))
 
-    callerRestoreGlobalReg reg
-        = mkAssign (CmmGlobal reg)
-                   (CmmLoad (get_GlobalReg_addr dflags reg) (globalRegType platform reg))
+callerRestoreGlobalReg :: DynFlags -> GlobalReg -> CmmAGraph
+callerRestoreGlobalReg dflags reg
+    = mkAssign (CmmGlobal reg)
+               (CmmLoad (get_GlobalReg_addr dflags reg) (globalRegType (targetPlatform dflags) reg))
 
 
 -------------------------------------------------------------------------


=====================================
includes/Cmm.h
=====================================
@@ -739,75 +739,6 @@
     TICK_BUMP(ALLOC_RTS_ctr);                   \
     TICK_BUMP_BY(ALLOC_RTS_tot,bytes)
 
-/* -----------------------------------------------------------------------------
-   Saving and restoring STG registers
-
-   STG registers must be saved around a C call, just in case the STG
-   register is mapped to a caller-saves machine register.  Normally we
-   don't need to worry about this the code generator has already
-   loaded any live STG registers into variables for us, but in
-   hand-written low-level Cmm code where we don't know which registers
-   are live, we might have to save them all.
-   -------------------------------------------------------------------------- */
-
-#define SAVE_STGREGS                            \
-    W_ r1, r2, r3,  r4,  r5,  r6,  r7,  r8;     \
-    F_ f1, f2, f3, f4, f5, f6;                  \
-    D_ d1, d2, d3, d4, d5, d6;                  \
-    L_ l1;                                      \
-                                                \
-    r1 = R1;                                    \
-    r2 = R2;                                    \
-    r3 = R3;                                    \
-    r4 = R4;                                    \
-    r5 = R5;                                    \
-    r6 = R6;                                    \
-    r7 = R7;                                    \
-    r8 = R8;                                    \
-                                                \
-    f1 = F1;                                    \
-    f2 = F2;                                    \
-    f3 = F3;                                    \
-    f4 = F4;                                    \
-    f5 = F5;                                    \
-    f6 = F6;                                    \
-                                                \
-    d1 = D1;                                    \
-    d2 = D2;                                    \
-    d3 = D3;                                    \
-    d4 = D4;                                    \
-    d5 = D5;                                    \
-    d6 = D6;                                    \
-                                                \
-    l1 = L1;
-
-
-#define RESTORE_STGREGS                         \
-    R1 = r1;                                    \
-    R2 = r2;                                    \
-    R3 = r3;                                    \
-    R4 = r4;                                    \
-    R5 = r5;                                    \
-    R6 = r6;                                    \
-    R7 = r7;                                    \
-    R8 = r8;                                    \
-                                                \
-    F1 = f1;                                    \
-    F2 = f2;                                    \
-    F3 = f3;                                    \
-    F4 = f4;                                    \
-    F5 = f5;                                    \
-    F6 = f6;                                    \
-                                                \
-    D1 = d1;                                    \
-    D2 = d2;                                    \
-    D3 = d3;                                    \
-    D4 = d4;                                    \
-    D5 = d5;                                    \
-    D6 = d6;                                    \
-                                                \
-    L1 = l1;
-
 /* -----------------------------------------------------------------------------
    Misc junk
    -------------------------------------------------------------------------- */


=====================================
rts/StgMiscClosures.cmm
=====================================
@@ -31,14 +31,14 @@ INFO_TABLE_RET (stg_stack_underflow_frame, UNDERFLOW_FRAME,
     W_ new_tso;
     W_ ret_off;
 
-    SAVE_STGREGS
+    SAVE_REGS();
 
     SAVE_THREAD_STATE();
     (ret_off) = foreign "C" threadStackUnderflow(MyCapability() "ptr",
                                                  CurrentTSO);
     LOAD_THREAD_STATE();
 
-    RESTORE_STGREGS
+    RESTORE_REGS();
 
     jump %ENTRY_CODE(Sp(ret_off)) [*]; // NB. all registers live!
 }


=====================================
testsuite/driver/testlib.py
=====================================
@@ -1547,8 +1547,7 @@ def simple_build(name: Union[TestName, str],
     # Required by GHC 7.3+, harmless for earlier versions:
     if (getTestOpts().c_src or
         getTestOpts().objc_src or
-        getTestOpts().objcpp_src or
-        getTestOpts().cmm_src):
+        getTestOpts().objcpp_src):
         extra_hc_opts += ' -no-hs-main '
 
     if getTestOpts().compile_cmd_prefix == '':


=====================================
testsuite/tests/cmm/should_compile/all.T
=====================================
@@ -1,4 +1,4 @@
 #
-test('selfloop', [cmm_src], compile, [''])
+test('selfloop', [cmm_src], compile, ['-no-hs-main'])
 test('T16930', normal, makefile_test, ['T16930'])
 test('T17442', normal, compile, [''])


=====================================
testsuite/tests/codeGen/should_compile/all.T
=====================================
@@ -21,15 +21,15 @@ test('massive_array',
      [ when(arch('i386'), omit_ways(llvm_ways)) ],
      compile, ['-fPIC'])
 test('T7237', normal, compile, [''])
-test('T7574', [cmm_src, omit_ways(llvm_ways)], compile, [''])
+test('T7574', [cmm_src, omit_ways(llvm_ways)], compile, ['-no-hs-main'])
 test('T8205', normal, compile, ['-O0'])
 test('T9155', normal, compile, ['-O2'])
 test('T9303', normal, compile, ['-O2'])
-test('T9329', [when(unregisterised(), expect_broken(15467)), cmm_src], compile, [''])
+test('T9329', [when(unregisterised(), expect_broken(15467)), cmm_src], compile, ['-no-hs-main'])
 
 test('debug', normal, makefile_test, [])
 test('T9964', normal, compile, ['-O'])
-test('T10518', [cmm_src], compile, [''])
+test('T10518', [cmm_src], compile, ['-no-hs-main'])
 test('T10667', normal, compile, ['-g'])
 test('T12115', normal, compile, [''])
 test('T12355', normal, compile, [''])


=====================================
testsuite/tests/codeGen/should_fail/all.T
=====================================
@@ -2,6 +2,6 @@
 
 # Only the LLVM code generator consistently forces the alignment of
 # memcpy operations
-test('T8131', [cmm_src, only_ways(llvm_ways)], compile_fail, [''])
+test('T8131', [cmm_src, only_ways(llvm_ways)], compile_fail, ['-no-hs-main'])
 test('T13233', normal, compile_fail, [''])
 test('T13233_elab', normal, compile_fail, ['-fprint-typechecker-elaboration'])


=====================================
testsuite/tests/codeGen/should_run/T17920.cmm
=====================================
@@ -0,0 +1,28 @@
+#include "Cmm.h"
+
+section "rodata" { msg : bits8[] "Test\n"; }
+section "data" { faketso : bits8[1000]; }
+
+stg_myExit {
+   foreign "C" stg_exit(0);
+}
+
+stg_foo {
+  
+   BaseReg = faketso;
+
+   SAVE_REGS();
+
+   foreign "C" printf(msg "ptr");
+
+   RESTORE_REGS();
+
+   jump stg_myExit [*]; // all registers live
+}
+
+INFO_TABLE_CONSTR(ZCMain_main,0,0,0,CONSTR_NOCAF,"MAIN","MAIN")
+{
+   jump stg_foo [];
+}
+
+CLOSURE(ZCMain_main_closure,ZCMain_main);


=====================================
testsuite/tests/codeGen/should_run/T17920.stdout
=====================================
@@ -0,0 +1 @@
+Test


=====================================
testsuite/tests/codeGen/should_run/all.T
=====================================
@@ -75,8 +75,7 @@ test('cgrun066', normal, compile_and_run, [''])
 test('cgrun067', [extra_files(['Cgrun067A.hs'])], compile_and_run, [''])
 test('cgrun068', reqlib('random'), compile_and_run, [''])
 test('cgrun069',
-     [when(unregisterised(), expect_broken(15467)),
-      omit_ways(['ghci'])],
+     [ omit_ways(['ghci'])],
      multi_compile_and_run,
      ['cgrun069', [('cgrun069_cmm.cmm', '')], ''])
 test('cgrun070', normal, compile_and_run, [''])
@@ -206,3 +205,5 @@ test('T15892',
 test('T16617', normal, compile_and_run, [''])
 test('T16449_2', exit_code(0), compile_and_run, [''])
 test('T16846', [only_ways(['optasm']), exit_code(1)], compile_and_run, [''])
+
+test('T17920', cmm_src, compile_and_run, [''])


=====================================
testsuite/tests/driver/all.T
=====================================
@@ -195,7 +195,7 @@ test('T8101b', normal, multimod_compile,
 test('T10600', normal, compile_fail, ['-fno-code'])
 
 # Should not panic when compiling cmm file together with -outputdir.
-test('T9050', cmm_src, compile, ['-outputdir=.'])
+test('T9050', cmm_src, compile, ['-outputdir=. -no-hs-main'])
 
 test('write_interface_oneshot', [extra_files(['A011.hs'])], makefile_test, [])
 


=====================================
testsuite/tests/llvm/should_compile/T17920fail.cmm
=====================================
@@ -0,0 +1,35 @@
+#include "Cmm.h"
+
+section "rodata" { msg : bits8[] "Test\n"; }
+section "data" { faketso : bits8[1000]; }
+
+stg_myExit {
+   foreign "C" exit(0);
+}
+
+stg_foo {
+  
+   BaseReg = faketso;
+
+   SAVE_REGS();
+
+   D_ d1;
+   F_ f1;
+
+   d1 = D1;
+   f1 = F1;
+
+   foreign "C" printf(msg "ptr");
+
+   D1 = d1;
+   F1 = f1;
+
+   RESTORE_REGS();
+
+   jump stg_myExit [*]; // all registers live
+}
+
+main {
+   jump stg_foo [];
+}
+


=====================================
testsuite/tests/llvm/should_compile/all.T
=====================================
@@ -8,7 +8,8 @@ setTestOpts(f)
 # test('T5486', normal, compile, [''])
 test('T5681', normal, compile, [''])
 test('T6158', [reqlib('vector'), reqlib('primitive')], compile, ['-package vector -package primitive'])
-test('T7571', cmm_src, compile, [''])
+test('T7571', cmm_src, compile, ['-no-hs-main'])
 test('T7575', unless(wordsize(32), skip), compile, [''])
 test('T8131b', normal, compile, [''])
 test('T11649', normal, compile, [''])
+test('T17920fail', cmm_src, compile_fail, ['-no-hs-main'])


=====================================
testsuite/tests/simplCore/should_compile/T18347.hs
=====================================
@@ -0,0 +1,10 @@
+module T18347 (function) where
+
+import Data.Coerce
+
+newtype All = All Bool
+
+data Encoding = Encoding (Char -> Bool)
+
+function :: Encoding -> Char -> All
+function enc v = coerce (case enc of Encoding x -> x) v


=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -328,3 +328,4 @@ test('T18231', [ only_ways(['optasm']), grep_errmsg(r'^[\w\.]+ ::.*->.*') ], com
 # Cast WW
 test('T17673', [ only_ways(['optasm']), grep_errmsg(r'^\w+\.\$wf') ], compile, ['-ddump-simpl -dsuppress-uniques -dppr-cols=9999'])
 test('T18078', [ only_ways(['optasm']), grep_errmsg(r'^\w+\.\$wf') ], compile, ['-ddump-simpl -dsuppress-uniques -dppr-cols=9999'])
+test('T18347', normal, compile, ['-dcore-lint -O'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3894ec35475f7cc1e49d72b0eee97a68240105a9...faa12bc64c277fada86c5342a5147a7045339483

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3894ec35475f7cc1e49d72b0eee97a68240105a9...faa12bc64c277fada86c5342a5147a7045339483
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200620/0c86a886/attachment-0001.html>


More information about the ghc-commits mailing list