Refactor handling of global initializers

GHC uses global initializers for a number of things including
cost-center registration, info-table provenance registration, and setup
of foreign exports. Previously, the global initializer arrays which
referenced these initializers would live in the object file of the C
stub, which would then be merged into the main object file of the
module.

Unfortunately, this approach is no longer tenable with the move to
Clang/LLVM on Windows (see #21019). Specifically, lld's PE backend does
not support object merging (that is, the -r flag). Instead we are now
rather packaging a module's object files into a static library. However,
this is problematic in the case of initializers as there are no
references to the C stub object in the archive, meaning that the linker
may drop the object from the final link.

This patch refactors our handling of global initializers to instead
place initializer arrays within the object file of the module to which
they belong. We do this by introducing a Cmm data declaration containing
the initializer array in the module's Cmm stream. While the initializer
functions themselves remain in separate C stub objects, the reference
from the module's object ensures that they are not dropped from the
final link.

In service of #21068.

17 files changed, 372 insertions, 89 deletions

diff --git a/compiler/GHC/Cmm.hs b/compiler/GHC/Cmm.hs
index 893ca556db..4f8bdbd77a 100644
--- a/compiler/GHC/Cmm.hs
+++ b/compiler/GHC/Cmm.hs
@@ -184,6 +184,9 @@ data SectionType
   | RelocatableReadOnlyData
   | UninitialisedData
   | ReadOnlyData16      -- .rodata.cst16 on x86_64, 16-byte aligned
+    -- See Note [Initializers and finalizers in Cmm] in GHC.Cmm.InitFini
+  | InitArray           -- .init_array on ELF, .ctor on Windows
+  | FiniArray           -- .fini_array on ELF, .dtor on Windows
   | CString
   | OtherSection String
   deriving (Show)
@@ -201,6 +204,8 @@ sectionProtection (Section t _) = case t of
     ReadOnlyData            -> ReadOnlySection
     RelocatableReadOnlyData -> WriteProtectedSection
     ReadOnlyData16          -> ReadOnlySection
+    InitArray               -> ReadOnlySection
+    FiniArray               -> ReadOnlySection
     CString                 -> ReadOnlySection
     Data                    -> ReadWriteSection
     UninitialisedData       -> ReadWriteSection
diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs
index c6f29ece0b..6d0870e281 100644
--- a/compiler/GHC/Cmm/CLabel.hs
+++ b/compiler/GHC/Cmm/CLabel.hs
@@ -39,6 +39,11 @@ module GHC.Cmm.CLabel (
         mkBitmapLabel,
         mkStringLitLabel,
 
+        mkInitializerStubLabel,
+        mkInitializerArrayLabel,
+        mkFinalizerStubLabel,
+        mkFinalizerArrayLabel,
+
         mkAsmTempLabel,
         mkAsmTempDerivedLabel,
         mkAsmTempEndLabel,
@@ -255,6 +260,8 @@ data CLabel
   | CCS_Label CostCentreStack
   | IPE_Label InfoProvEnt
 
+    -- | A per-module metadata label.
+  | ModuleLabel !Module ModuleLabelKind
 
   -- | These labels are generated and used inside the NCG only.
   --    They are special variants of a label used for dynamic linking
@@ -271,7 +278,6 @@ data CLabel
   -- | A label before an info table to prevent excessive dead-stripping on darwin
   | DeadStripPreventer CLabel
 
-
   -- | Per-module table of tick locations
   | HpcTicksLabel Module
 
@@ -291,6 +297,19 @@ instance Show CLabel where
 instance Outputable CLabel where
   ppr = text . show
 
+data ModuleLabelKind
+    = MLK_Initializer String
+    | MLK_InitializerArray
+    | MLK_Finalizer String
+    | MLK_FinalizerArray
+    deriving (Eq, Ord)
+
+instance Outputable ModuleLabelKind where
+    ppr MLK_InitializerArray = text "init_arr"
+    ppr (MLK_Initializer s)  = text ("init__" ++ s)
+    ppr MLK_FinalizerArray   = text "fini_arr"
+    ppr (MLK_Finalizer s)    = text ("fini__" ++ s)
+
 isIdLabel :: CLabel -> Bool
 isIdLabel IdLabel{} = True
 isIdLabel _ = False
@@ -355,6 +374,9 @@ instance Ord CLabel where
     compare a1 a2
   compare (IPE_Label a1) (IPE_Label a2) =
     compare a1 a2
+  compare (ModuleLabel m1 k1) (ModuleLabel m2 k2) =
+    compare m1 m2 `thenCmp`
+    compare k1 k2
   compare (DynamicLinkerLabel a1 b1) (DynamicLinkerLabel a2 b2) =
     compare a1 a2 `thenCmp`
     compare b1 b2
@@ -399,6 +421,8 @@ instance Ord CLabel where
   compare _ SRTLabel{} = GT
   compare (IPE_Label {}) _ = LT
   compare  _ (IPE_Label{}) = GT
+  compare (ModuleLabel {}) _ = LT
+  compare  _ (ModuleLabel{}) = GT
 
 -- | Record where a foreign label is stored.
 data ForeignLabelSource
@@ -842,6 +866,19 @@ mkDeadStripPreventer lbl        = DeadStripPreventer lbl
 mkStringLitLabel :: Unique -> CLabel
 mkStringLitLabel                = StringLitLabel
 
+mkInitializerStubLabel :: Module -> String -> CLabel
+mkInitializerStubLabel mod s    = ModuleLabel mod (MLK_Initializer s)
+
+mkInitializerArrayLabel :: Module -> CLabel
+mkInitializerArrayLabel mod     = ModuleLabel mod MLK_InitializerArray
+
+
+mkFinalizerStubLabel :: Module -> String -> CLabel
+mkFinalizerStubLabel mod s      = ModuleLabel mod (MLK_Finalizer s)
+
+mkFinalizerArrayLabel :: Module -> CLabel
+mkFinalizerArrayLabel mod       = ModuleLabel mod MLK_FinalizerArray
+
 mkAsmTempLabel :: Uniquable a => a -> CLabel
 mkAsmTempLabel a                = AsmTempLabel (getUnique a)
 
@@ -964,11 +1001,20 @@ needsCDecl l@(ForeignLabel{})           = not (isMathFun l)
 needsCDecl (CC_Label _)                 = True
 needsCDecl (CCS_Label _)                = True
 needsCDecl (IPE_Label {})               = True
+needsCDecl (ModuleLabel _ kind)         = modLabelNeedsCDecl kind
 needsCDecl (HpcTicksLabel _)            = True
 needsCDecl (DynamicLinkerLabel {})      = panic "needsCDecl DynamicLinkerLabel"
 needsCDecl PicBaseLabel                 = panic "needsCDecl PicBaseLabel"
 needsCDecl (DeadStripPreventer {})      = panic "needsCDecl DeadStripPreventer"
 
+modLabelNeedsCDecl :: ModuleLabelKind -> Bool
+-- Code for finalizers and initializers are emitted in stub objects
+modLabelNeedsCDecl (MLK_Initializer _)  = True
+modLabelNeedsCDecl (MLK_Finalizer   _)  = True
+-- The finalizer and initializer arrays are emitted in the code of the module
+modLabelNeedsCDecl MLK_InitializerArray = False
+modLabelNeedsCDecl MLK_FinalizerArray   = False
+
 -- | If a label is a local block label then return just its 'BlockId', otherwise
 -- 'Nothing'.
 maybeLocalBlockLabel :: CLabel -> Maybe BlockId
@@ -1087,6 +1133,7 @@ externallyVisibleCLabel (IdLabel name _ info)   = isExternalName name && externa
 externallyVisibleCLabel (CC_Label _)            = True
 externallyVisibleCLabel (CCS_Label _)           = True
 externallyVisibleCLabel (IPE_Label {})          = True
+externallyVisibleCLabel (ModuleLabel {})        = True
 externallyVisibleCLabel (DynamicLinkerLabel _ _)  = False
 externallyVisibleCLabel (HpcTicksLabel _)       = True
 externallyVisibleCLabel (LargeBitmapLabel _)    = False
@@ -1147,12 +1194,21 @@ labelType (StringLitLabel _)                    = DataLabel
 labelType (CC_Label _)                          = DataLabel
 labelType (CCS_Label _)                         = DataLabel
 labelType (IPE_Label {})                        = DataLabel
+labelType (ModuleLabel _ kind)                  = moduleLabelKindType kind
 labelType (DynamicLinkerLabel _ _)              = DataLabel -- Is this right?
 labelType PicBaseLabel                          = DataLabel
 labelType (DeadStripPreventer _)                = DataLabel
 labelType (HpcTicksLabel _)                     = DataLabel
 labelType (LargeBitmapLabel _)                  = DataLabel
 
+moduleLabelKindType :: ModuleLabelKind -> CLabelType
+moduleLabelKindType kind =
+  case kind of
+    MLK_Initializer _    -> CodeLabel
+    MLK_InitializerArray -> DataLabel
+    MLK_Finalizer _      -> CodeLabel
+    MLK_FinalizerArray   -> DataLabel
+
 idInfoLabelType :: IdLabelInfo -> CLabelType
 idInfoLabelType info =
   case info of
@@ -1467,7 +1523,7 @@ pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel]
    CC_Label cc   -> maybe_underscore $ ppr cc
    CCS_Label ccs -> maybe_underscore $ ppr ccs
    IPE_Label (InfoProvEnt l _ _ m _) -> maybe_underscore $ (pprCode CStyle (pdoc platform l) <> text "_" <> ppr m <> text "_ipe")
-
+   ModuleLabel mod kind        -> maybe_underscore $ ppr mod <> text "_" <> ppr kind
 
    CmmLabel _ _ fs CmmCode     -> maybe_underscore $ ftext fs
    CmmLabel _ _ fs CmmData     -> maybe_underscore $ ftext fs
diff --git a/compiler/GHC/Cmm/CLabel.hs-boot b/compiler/GHC/Cmm/CLabel.hs-boot
new file mode 100644
index 0000000000..8fb1b74423
--- /dev/null
+++ b/compiler/GHC/Cmm/CLabel.hs-boot
@@ -0,0 +1,9 @@
+module GHC.Cmm.CLabel where
+
+import GHC.Utils.Outputable
+import GHC.Platform
+
+data CLabel
+
+pprCLabel :: Platform -> LabelStyle -> CLabel -> SDoc
+
diff --git a/compiler/GHC/Cmm/InitFini.hs b/compiler/GHC/Cmm/InitFini.hs
new file mode 100644
index 0000000000..2a4a12ed08
--- /dev/null
+++ b/compiler/GHC/Cmm/InitFini.hs
@@ -0,0 +1,78 @@
+-- | Utilities for dealing with constructors/destructors.
+module GHC.Cmm.InitFini
+    ( InitOrFini(..)
+    , isInitOrFiniArray
+    ) where
+
+import GHC.Prelude
+
+import GHC.Cmm.CLabel
+import GHC.Cmm
+import GHC.Utils.Panic
+import GHC.Utils.Outputable
+
+{-
+Note [Initializers and finalizers in Cmm]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Most platforms support some mechanism for marking a procedure to be run when a
+program is loaded (in which case the procedure is known as an "initializer",
+"constructor", or "ctor") or unloaded (a "finalizer", "deconstructor", or
+"dtor").
+
+For instance, on ELF platforms pointers to initializer and finalizer functions
+are listed in .init_array and .fini_array sections, which are traversed by libc
+during program startup and shutdown.
+
+In GHC-generated code, initializers are used for a few things:
+
+ * registration of cost-centres and cost-centre stacks for profiling
+ * registration of info-table provenance entries
+ * registration of ticky tickers
+ * registration of HPC ticks
+
+All of these initializers are implemented as C functions, emitted by the
+compiler as ForeignStubs. Consequently the GHC.Types.ForeignStubs.CStub type
+carries with it lists of functions which should be marked as initializers or
+finalizers.
+
+These initializer and finalizer lists are then turned into CmmData declarations
+which are fed to the backend. These declarations are distinguished by their
+Section (e.g. InitArray or FiniArray) and consist of an array of words, where each
+word is a pointer to an initializer/finalizer function. Since this is the same
+form that most platforms expect initializer or finalizer lists to appear in
+assembler, the NCG backends naturally emit the appropriate assembler.
+
+However, for non-NCG backends (e.g. the C and LLVM backends) these
+initializer/finalizer list declarations need to be detected and dealt with
+appropriately. We provide isInitOrFiniArray to distinguish such declarations
+and turn them back into a list of CLabels.
+
+On Windows initializers/finalizers are a bit tricky due to the inability to
+merge objects (due to the lld linker's lack of `-r` support on Windows; see
+#21068) since we instead must package foreign stubs into static archives.
+However, the linker is free to not include any constituent objects of a static
+library in the final object code if nothing depends upon them. Consequently, we
+must ensure that the initializer list for a module is defined in the module's
+object code, not its foreign stubs. This happens naturally with the plan laid
+out above.
+
+Note that we maintain the invariant that at most one initializer and one
+finalizer CmmDecl will be emitted per module.
+-}
+
+data InitOrFini = IsInitArray | IsFiniArray
+
+isInitOrFiniArray :: RawCmmDecl -> Maybe (InitOrFini, [CLabel])
+isInitOrFiniArray (CmmData sect (CmmStaticsRaw _ lits))
+  | Just initOrFini <- isInitOrFiniSection sect
+  = Just (initOrFini, map get_label lits)
+  where
+    get_label :: CmmStatic -> CLabel
+    get_label (CmmStaticLit (CmmLabel lbl)) = lbl
+    get_label static = pprPanic "isInitOrFiniArray: invalid entry" (ppr static)
+isInitOrFiniArray _ = Nothing
+
+isInitOrFiniSection :: Section -> Maybe InitOrFini
+isInitOrFiniSection (Section InitArray _) = Just IsInitArray
+isInitOrFiniSection (Section FiniArray _) = Just IsFiniArray
+isInitOrFiniSection _                     = Nothing
diff --git a/compiler/GHC/Cmm/Ppr/Decl.hs b/compiler/GHC/Cmm/Ppr/Decl.hs
index b6a2e1992e..3b1eff78ff 100644
--- a/compiler/GHC/Cmm/Ppr/Decl.hs
+++ b/compiler/GHC/Cmm/Ppr/Decl.hs
@@ -166,5 +166,7 @@ pprSectionType s = doubleQuotes $ case s of
   ReadOnlyData16          -> text "readonly16"
   RelocatableReadOnlyData -> text "relreadonly"
   UninitialisedData       -> text "uninitialised"
+  InitArray               -> text "initarray"
+  FiniArray               -> text "finiarray"
   CString                 -> text "cstring"
   OtherSection s'         -> text s'
diff --git a/compiler/GHC/CmmToAsm/PPC/Ppr.hs b/compiler/GHC/CmmToAsm/PPC/Ppr.hs
index 99776cc7f4..a842eef998 100644
--- a/compiler/GHC/CmmToAsm/PPC/Ppr.hs
+++ b/compiler/GHC/CmmToAsm/PPC/Ppr.hs
@@ -299,6 +299,8 @@ pprAlignForSection platform seg =
        ReadOnlyData16    -> text ".align 4"
        -- TODO: This is copied from the ReadOnlyData case, but it can likely be
        -- made more efficient.
+       InitArray         -> text ".align 3"
+       FiniArray         -> text ".align 3"
        CString
         | ppc64          -> text ".align 3"
         | otherwise      -> text ".align 2"
diff --git a/compiler/GHC/CmmToAsm/Ppr.hs b/compiler/GHC/CmmToAsm/Ppr.hs
index 441ee75348..0379ed6464 100644
--- a/compiler/GHC/CmmToAsm/Ppr.hs
+++ b/compiler/GHC/CmmToAsm/Ppr.hs
@@ -227,6 +227,14 @@ pprGNUSectionHeader config t suffix =
       ReadOnlyData16 | OSMinGW32 <- platformOS platform
                                  -> text ".rdata$cst16"
                      | otherwise -> text ".rodata.cst16"
+      InitArray
+        | OSMinGW32 <- platformOS platform
+                    -> text ".ctors"
+        | otherwise -> text ".init_array"
+      FiniArray
+        | OSMinGW32 <- platformOS platform
+                    -> text ".dtors"
+        | otherwise -> text ".fini_array"
       CString
         | OSMinGW32 <- platformOS platform
                     -> text ".rdata"
@@ -251,7 +259,7 @@ pprXcoffSectionHeader t = case t of
   ReadOnlyData16          -> text ".csect .text[PR] # ReadOnlyData16"
   CString                 -> text ".csect .text[PR] # CString"
   UninitialisedData       -> text ".csect .data[BS]"
-  OtherSection _          -> panic "pprXcoffSectionHeader: unknown section type"
+  _                       -> panic "pprXcoffSectionHeader: unknown section type"
 
 pprDarwinSectionHeader :: SectionType -> SDoc
 pprDarwinSectionHeader t = case t of
@@ -261,5 +269,7 @@ pprDarwinSectionHeader t = case t of
   RelocatableReadOnlyData -> text ".const_data"
   UninitialisedData       -> text ".data"
   ReadOnlyData16          -> text ".const"
+  InitArray               -> text ".section\t__DATA,__mod_init_func,mod_init_funcs"
+  FiniArray               -> panic "pprDarwinSectionHeader: fini not supported"
   CString                 -> text ".section\t__TEXT,__cstring,cstring_literals"
   OtherSection _          -> panic "pprDarwinSectionHeader: unknown section type"
diff --git a/compiler/GHC/CmmToC.hs b/compiler/GHC/CmmToC.hs
index da0b54dd9f..c9f86e9afe 100644
--- a/compiler/GHC/CmmToC.hs
+++ b/compiler/GHC/CmmToC.hs
@@ -40,6 +40,7 @@ import GHC.Cmm.Dataflow.Collections
 import GHC.Cmm.Dataflow.Graph
 import GHC.Cmm.Utils
 import GHC.Cmm.Switch
+import GHC.Cmm.InitFini
 
 import GHC.Types.ForeignCall
 import GHC.Types.Unique.Set
@@ -100,6 +101,9 @@ pprTop platform = \case
 
   -- We only handle (a) arrays of word-sized things and (b) strings.
 
+  cmm_data | Just (initOrFini, clbls) <- isInitOrFiniArray cmm_data ->
+    pprCtorArray platform initOrFini clbls
+
   (CmmData section (CmmStaticsRaw lbl [CmmString str])) ->
     pprExternDecl platform lbl $$
     hcat [
@@ -1487,3 +1491,19 @@ pprHexVal platform w rep = parens ctype <> rawlit
              (q,r) = w' `quotRem` 16
              dig | r < 10    = char (chr (fromInteger r + ord '0'))
                  | otherwise = char (chr (fromInteger r - 10 + ord 'a'))
+
+-- | Construct a constructor/finalizer function. Instead of emitting a
+-- initializer/finalizer array we rather just emit a single function, annotated
+-- with the appropriate C attribute, which then calls each of the initializers.
+pprCtorArray :: Platform -> InitOrFini -> [CLabel] -> SDoc
+pprCtorArray platform initOrFini lbls =
+       decls
+    <> text "static __attribute__((" <> attribute <> text "))"
+    <> text "void _hs_" <> attribute <> text "()"
+    <> braces body
+  where
+    body = vcat [ pprCLabel platform CStyle lbl <> text " ();" | lbl <- lbls ]
+    decls = vcat [ text "void" <+> pprCLabel platform CStyle lbl <> text " (void);" | lbl <- lbls ]
+    attribute = case initOrFini of
+                  IsInitArray -> text "constructor"
+                  IsFiniArray -> text "destructor"
diff --git a/compiler/GHC/CmmToLlvm/Data.hs b/compiler/GHC/CmmToLlvm/Data.hs
index 0e5679887d..edab12a6ef 100644
--- a/compiler/GHC/CmmToLlvm/Data.hs
+++ b/compiler/GHC/CmmToLlvm/Data.hs
@@ -15,6 +15,7 @@ import GHC.CmmToLlvm.Config
 
 import GHC.Cmm.BlockId
 import GHC.Cmm.CLabel
+import GHC.Cmm.InitFini
 import GHC.Cmm
 import GHC.Platform
 
@@ -65,6 +66,14 @@ genLlvmData (_, CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit i
 
     pure ([LMGlobal aliasDef $ Just orig], [tyAlias])
 
+-- See Note [Initializers and finalizers in Cmm] in GHC.Cmm.InitFini.
+genLlvmData (sect, statics)
+  | Just (initOrFini, clbls) <- isInitOrFiniArray (CmmData sect statics)
+  = let var = case initOrFini of
+                IsInitArray -> fsLit "llvm.global_ctors"
+                IsFiniArray -> fsLit "llvm.global_dtors"
+    in genGlobalLabelArray var clbls
+
 genLlvmData (sec, CmmStaticsRaw lbl xs) = do
     label <- strCLabel_llvm lbl
     static <- mapM genData xs
@@ -88,6 +97,37 @@ genLlvmData (sec, CmmStaticsRaw lbl xs) = do
 
     return ([globDef], [tyAlias])
 
+-- | Produce an initializer or finalizer array declaration.
+-- See Note [Initializers and finalizers in Cmm] in GHC.Cmm.InitFini for
+-- details.
+genGlobalLabelArray :: FastString -> [CLabel] -> LlvmM LlvmData
+genGlobalLabelArray var_nm clbls = do
+    lbls <- mapM strCLabel_llvm clbls
+    decls <- mapM mkFunDecl lbls
+    let entries = map toArrayEntry lbls
+        static = LMStaticArray entries arr_ty
+        arr = LMGlobal arr_var (Just static)
+    return ([arr], decls)
+  where
+    mkFunDecl :: LMString -> LlvmM LlvmType
+    mkFunDecl fn_lbl = do
+        let fn_ty = mkFunTy fn_lbl
+        funInsert fn_lbl fn_ty
+        return (fn_ty)
+
+    toArrayEntry :: LMString -> LlvmStatic
+    toArrayEntry fn_lbl =
+        let fn_var = LMGlobalVar fn_lbl (LMPointer $ mkFunTy fn_lbl) Internal Nothing Nothing Global
+            fn = LMStaticPointer fn_var
+            null = LMStaticLit (LMNullLit i8Ptr)
+            prio = LMStaticLit $ LMIntLit 0xffff i32
+        in LMStaticStrucU [prio, fn, null] entry_ty
+
+    arr_var = LMGlobalVar var_nm arr_ty Internal Nothing Nothing Global
+    mkFunTy lbl = LMFunction $ LlvmFunctionDecl lbl ExternallyVisible CC_Ccc LMVoid FixedArgs [] Nothing
+    entry_ty = LMStructU [i32, LMPointer $ mkFunTy $ fsLit "placeholder", LMPointer i8]
+    arr_ty = LMArray (length clbls) entry_ty
+
 -- | Format the section type part of a Cmm Section
 llvmSectionType :: Platform -> SectionType -> FastString
 llvmSectionType p t = case t of
@@ -106,7 +146,10 @@ llvmSectionType p t = case t of
     CString                 -> case platformOS p of
                                  OSMinGW32 -> fsLit ".rdata$str"
                                  _         -> fsLit ".rodata.str"
-    (OtherSection _)        -> panic "llvmSectionType: unknown section type"
+
+    InitArray               -> panic "llvmSectionType: InitArray"
+    FiniArray               -> panic "llvmSectionType: FiniArray"
+    OtherSection _          -> panic "llvmSectionType: unknown section type"
 
 -- | Format a Cmm Section into a LLVM section name
 llvmSection :: Section -> LlvmM LMSection
diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs
index 80a8277283..5f5f9882c2 100644
--- a/compiler/GHC/Driver/CodeOutput.hs
+++ b/compiler/GHC/Driver/CodeOutput.hs
@@ -4,7 +4,7 @@
 \section{Code output phase}
 -}
 
-
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module GHC.Driver.CodeOutput
    ( codeOutput
@@ -23,7 +23,7 @@ import GHC.CmmToLlvm    ( llvmCodeGen )
 
 import GHC.CmmToC           ( cmmToC )
 import GHC.Cmm.Lint         ( cmmLint )
-import GHC.Cmm              ( RawCmmGroup )
+import GHC.Cmm
 import GHC.Cmm.CLabel
 
 import GHC.Driver.Session
@@ -70,7 +70,8 @@ import qualified Data.Set as Set
 -}
 
 codeOutput
-    :: Logger
+    :: forall a.
+       Logger
     -> TmpFs
     -> DynFlags
     -> UnitState
@@ -110,18 +111,39 @@ codeOutput logger tmpfs dflags unit_state this_mod filenm location genForeignStu
                 ; return cmm
                 }
 
-        ; a <- case backend dflags of
+        ; let final_stream :: Stream IO RawCmmGroup (ForeignStubs, a)
+              final_stream = do
+                  { a <- linted_cmm_stream
+                  ; let stubs = genForeignStubs a
+                  ; emitInitializerDecls this_mod stubs
+                  ; return (stubs, a) }
+
+        ; (stubs, a) <- case backend dflags of
                  NCG         -> outputAsm logger dflags this_mod location filenm
-                                          linted_cmm_stream
-                 ViaC        -> outputC logger dflags filenm linted_cmm_stream pkg_deps
-                 LLVM        -> outputLlvm logger dflags filenm linted_cmm_stream
+                                          final_stream
+                 ViaC        -> outputC logger dflags filenm final_stream pkg_deps
+                 LLVM        -> outputLlvm logger dflags filenm final_stream
                  Interpreter -> panic "codeOutput: Interpreter"
                  NoBackend   -> panic "codeOutput: NoBackend"
-        ; let stubs = genForeignStubs a
         ; stubs_exist <- outputForeignStubs logger tmpfs dflags unit_state this_mod location stubs
         ; return (filenm, stubs_exist, foreign_fps, a)
         }
 
+-- | See Note [Initializers and finalizers in Cmm] in GHC.Cmm.InitFini for details.
+emitInitializerDecls :: Module -> ForeignStubs -> Stream IO RawCmmGroup ()
+emitInitializerDecls this_mod (ForeignStubs _ cstub)
+  | initializers <- getInitializers cstub
+  , not $ null initializers =
+      let init_array = CmmData sect statics
+          lbl = mkInitializerArrayLabel this_mod
+          sect = Section InitArray lbl
+          statics = CmmStaticsRaw lbl
+            [ CmmStaticLit $ CmmLabel fn_name
+            | fn_name <- initializers
+            ]
+    in Stream.yield [init_array]
+emitInitializerDecls _ _ = return ()
+
 doOutput :: String -> (Handle -> IO a) -> IO a
 doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action
 
@@ -221,7 +243,7 @@ outputForeignStubs logger tmpfs dflags unit_state mod location stubs
      NoStubs ->
         return (False, Nothing)
 
-     ForeignStubs (CHeader h_code) (CStub c_code) -> do
+     ForeignStubs (CHeader h_code) (CStub c_code _ _) -> do
         let
             stub_c_output_d = pprCode CStyle c_code
             stub_c_output_w = showSDoc dflags stub_c_output_d
@@ -298,20 +320,18 @@ outputForeignStubs_help fname doc_str header footer
 -- | Generate code to initialise cost centres
 profilingInitCode :: Platform -> Module -> CollectedCCs -> CStub
 profilingInitCode platform this_mod (local_CCs, singleton_CCSs)
- = CStub $ vcat
-    $  map emit_cc_decl local_CCs
-    ++ map emit_ccs_decl singleton_CCSs
-    ++ [emit_cc_list local_CCs]
-    ++ [emit_ccs_list singleton_CCSs]
-    ++ [ text "static void prof_init_" <> ppr this_mod
-            <> text "(void) __attribute__((constructor));"
-       , text "static void prof_init_" <> ppr this_mod <> text "(void)"
-       , braces (vcat
-                 [ text "registerCcList" <> parens local_cc_list_label <> semi
-                 , text "registerCcsList" <> parens singleton_cc_list_label <> semi
-                 ])
-       ]
+ = initializerCStub platform fn_name decls body
  where
+   fn_name = mkInitializerStubLabel this_mod "prof_init"
+   decls = vcat
+        $  map emit_cc_decl local_CCs
+        ++ map emit_ccs_decl singleton_CCSs
+        ++ [emit_cc_list local_CCs]
+        ++ [emit_ccs_list singleton_CCSs]
+   body = vcat
+        [ text "registerCcList" <> parens local_cc_list_label <> semi
+        , text "registerCcsList" <> parens singleton_cc_list_label <> semi
+        ]
    emit_cc_decl cc =
        text "extern CostCentre" <+> cc_lbl <> text "[];"
      where cc_lbl = pdoc platform (mkCCLabel cc)
@@ -343,19 +363,14 @@ ipInitCode
   -> [InfoProvEnt]
   -> CStub
 ipInitCode do_info_table platform this_mod ents
- = if not do_info_table
-    then mempty
-    else CStub $ vcat
-    $  map emit_ipe_decl ents
-    ++ [emit_ipe_list ents]
-    ++ [ text "static void ip_init_" <> ppr this_mod
-            <> text "(void) __attribute__((constructor));"
-       , text "static void ip_init_" <> ppr this_mod <> text "(void)"
-       , braces (vcat
-                 [ text "registerInfoProvList" <> parens local_ipe_list_label <> semi
-                 ])
-       ]
+  | not do_info_table = mempty
+  | otherwise = initializerCStub platform fn_nm decls body
  where
+   fn_nm = mkInitializerStubLabel this_mod "ip_init"
+   decls = vcat
+        $  map emit_ipe_decl ents
+        ++ [emit_ipe_list ents]
+   body = text "registerInfoProvList" <> parens local_ipe_list_label <> semi
    emit_ipe_decl ipe =
        text "extern InfoProvEnt" <+> ipe_lbl <> text "[];"
      where ipe_lbl = pprCLabel platform CStyle (mkIPELabel ipe)
diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs
index e1e8489fe1..96439a837d 100644
--- a/compiler/GHC/HsToCore/Coverage.hs
+++ b/compiler/GHC/HsToCore/Coverage.hs
@@ -1343,23 +1343,18 @@ static void hpc_init_Main(void)
 hpcInitCode :: Platform -> Module -> HpcInfo -> CStub
 hpcInitCode _ _ (NoHpcInfo {}) = mempty
 hpcInitCode platform this_mod (HpcInfo tickCount hashNo)
- = CStub $ vcat
-    [ text "static void hpc_init_" <> ppr this_mod
-         <> text "(void) __attribute__((constructor));"
-    , text "static void hpc_init_" <> ppr this_mod <> text "(void)"
-    , braces (vcat [
-        text "extern StgWord64 " <> tickboxes <>
-               text "[]" <> semi,
-        text "hs_hpc_module" <>
-          parens (hcat (punctuate comma [
-              doubleQuotes full_name_str,
-              int tickCount, -- really StgWord32
-              int hashNo,    -- really StgWord32
-              tickboxes
-            ])) <> semi
-       ])
-    ]
+ = initializerCStub platform fn_name decls body
   where
+    fn_name = mkInitializerStubLabel this_mod "hpc"
+    decls = text "extern StgWord64 " <> tickboxes <> text "[]" <> semi
+    body = text "hs_hpc_module" <>
+              parens (hcat (punctuate comma [
+                  doubleQuotes full_name_str,
+                  int tickCount, -- really StgWord32
+                  int hashNo,    -- really StgWord32
+                  tickboxes
+                ])) <> semi
+
     tickboxes = pprCLabel platform CStyle (mkHpcTicksLabel $ this_mod)
 
     module_name  = hcat (map (text.charToC) $ BS.unpack $
diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs
index 6f9118604d..68980f5b12 100644
--- a/compiler/GHC/HsToCore/Foreign/Decl.hs
+++ b/compiler/GHC/HsToCore/Foreign/Decl.hs
@@ -43,6 +43,7 @@ import GHC.Tc.Utils.TcType
 
 import GHC.Cmm.Expr
 import GHC.Cmm.Utils
+import GHC.Cmm.CLabel
 import GHC.Driver.Ppr
 import GHC.Types.ForeignCall
 import GHC.Builtin.Types
@@ -95,11 +96,12 @@ dsForeigns' []
   = return (NoStubs, nilOL)
 dsForeigns' fos = do
     mod <- getModule
+    platform <- targetPlatform <$> getDynFlags
     fives <- mapM do_ldecl fos
     let
         (hs, cs, idss, bindss) = unzip4 fives
         fe_ids = concat idss
-        fe_init_code = foreignExportsInitialiser mod fe_ids
+        fe_init_code = foreignExportsInitialiser platform mod fe_ids
     --
     return (ForeignStubs
              (mconcat hs)
@@ -298,7 +300,7 @@ dsFCall fn_id co fcall mDeclHeader = do
                                                 simpl_opts
                                                 wrap_rhs'
 
-    return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], mempty, CStub cDoc)
+    return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], mempty, CStub cDoc [] [])
 
 {-
 ************************************************************************
@@ -526,7 +528,9 @@ mkFExportCBits :: DynFlags
                    Int          -- total size of arguments
                   )
 mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
- = (header_bits, c_bits, type_string,
+ = ( header_bits
+   , CStub body [] []
+   , type_string,
     sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args
          -- NB. the calculation here isn't strictly speaking correct.
          -- We have a primitive Haskell type (eg. Int#, Double#), and
@@ -646,7 +650,7 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
 
 
   -- finally, the whole darn thing
-  c_bits = CStub $
+  body =
     space $$
     extern_decl $$
     fun_proto  $$
@@ -682,10 +686,9 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
      , rbrace
      ]
 
-
-foreignExportsInitialiser :: Module -> [Id] -> CStub
-foreignExportsInitialiser _   []     = mempty
-foreignExportsInitialiser mod hs_fns =
+foreignExportsInitialiser :: Platform -> Module -> [Id] -> CStub
+foreignExportsInitialiser _        _   []     = mempty
+foreignExportsInitialiser platform mod hs_fns =
    -- Initialise foreign exports by registering a stable pointer from an
    -- __attribute__((constructor)) function.
    -- The alternative is to do this from stginit functions generated in
@@ -696,21 +699,18 @@ foreignExportsInitialiser mod hs_fns =
    -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL)
    --
    -- See Note [Tracking foreign exports] in rts/ForeignExports.c
-   CStub $ vcat
-    [ text "static struct ForeignExportsList" <+> list_symbol <+> equals
+   initializerCStub platform fn_nm list_decl fn_body
+  where
+    fn_nm       = mkInitializerStubLabel mod "fexports"
+    mod_str     = pprModuleName (moduleName mod)
+    fn_body     = text "registerForeignExports" <> parens (char '&' <> list_symbol) <> semi
+    list_symbol = text "stg_exports_" <> mod_str
+    list_decl   = text "static struct ForeignExportsList" <+> list_symbol <+> equals
          <+> braces (
            text ".exports = " <+> export_list <> comma <+>
            text ".n_entries = " <+> ppr (length hs_fns))
          <> semi
-    , text "static void " <> ctor_symbol <> text "(void)"
-         <+> text " __attribute__((constructor));"
-    , text "static void " <> ctor_symbol <> text "()"
-    , braces (text "registerForeignExports" <> parens (char '&' <> list_symbol) <> semi)
-    ]
-  where
-    mod_str = pprModuleName (moduleName mod)
-    ctor_symbol = text "stginit_export_" <> mod_str
-    list_symbol = text "stg_exports_" <> mod_str
+
     export_list = braces $ pprWithCommas closure_ptr hs_fns
 
     closure_ptr :: Id -> SDoc
diff --git a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs
index ab29a395da..3107a593b1 100644
--- a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs
+++ b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs
@@ -240,11 +240,12 @@ sptCreateStaticBinds opts this_mod binds = do
 -- its fingerprint.
 sptModuleInitCode :: Platform -> Module -> [SptEntry] -> CStub
 sptModuleInitCode _        _        [] = mempty
-sptModuleInitCode platform this_mod entries = CStub $ vcat
-    [ text "static void hs_spt_init_" <> ppr this_mod
-           <> text "(void) __attribute__((constructor));"
-    , text "static void hs_spt_init_" <> ppr this_mod <> text "(void)"
-    , braces $ vcat $
+sptModuleInitCode platform this_mod entries =
+    initializerCStub platform init_fn_nm empty init_fn_body `mappend`
+    finalizerCStub platform fini_fn_nm empty fini_fn_body
+  where
+    init_fn_nm = mkInitializerStubLabel this_mod "spt"
+    init_fn_body = vcat
         [  text "static StgWord64 k" <> int i <> text "[2] = "
            <> pprFingerprint fp <> semi
         $$ text "extern StgPtr "
@@ -258,17 +259,15 @@ sptModuleInitCode platform this_mod entries = CStub $ vcat
         <> semi
         |  (i, SptEntry n fp) <- zip [0..] entries
         ]
-    , text "static void hs_spt_fini_" <> ppr this_mod
-           <> text "(void) __attribute__((destructor));"
-    , text "static void hs_spt_fini_" <> ppr this_mod <> text "(void)"
-    , braces $ vcat $
+
+    fini_fn_nm = mkFinalizerStubLabel this_mod "spt"
+    fini_fn_body = vcat
         [  text "StgWord64 k" <> int i <> text "[2] = "
            <> pprFingerprint fp <> semi
         $$ text "hs_spt_remove" <> parens (char 'k' <> int i) <> semi
         | (i, (SptEntry _ fp)) <- zip [0..] entries
         ]
-    ]
-  where
+
     pprFingerprint :: Fingerprint -> SDoc
     pprFingerprint (Fingerprint w1 w2) =
       braces $ hcat $ punctuate comma
diff --git a/compiler/GHC/Llvm/Ppr.hs b/compiler/GHC/Llvm/Ppr.hs
index f02d2e1024..f48e7aa034 100644
--- a/compiler/GHC/Llvm/Ppr.hs
+++ b/compiler/GHC/Llvm/Ppr.hs
@@ -569,6 +569,7 @@ ppStatic opts st = case st of
   LMStaticStr   s t -> ppr t <> text " c\"" <> ftext s <> text "\\00\""
   LMStaticArray d t -> ppr t <> text " [" <> ppCommaJoin (map (ppStatic opts) d) <> char ']'
   LMStaticStruc d t -> ppr t <> text "<{" <> ppCommaJoin (map (ppStatic opts) d) <> text "}>"
+  LMStaticStrucU d t -> ppr t <> text "{" <> ppCommaJoin (map (ppStatic opts) d) <> text "}"
   LMStaticPointer v -> ppVar opts v
   LMTrunc v t       -> ppr t <> text " trunc (" <> ppStatic opts v <> text " to " <> ppr t <> char ')'
   LMBitc v t        -> ppr t <> text " bitcast (" <> ppStatic opts v <> text " to " <> ppr t <> char ')'
diff --git a/compiler/GHC/Llvm/Types.hs b/compiler/GHC/Llvm/Types.hs
index f5db5a96aa..79dccfac88 100644
--- a/compiler/GHC/Llvm/Types.hs
+++ b/compiler/GHC/Llvm/Types.hs
@@ -140,6 +140,7 @@ data LlvmStatic
   | LMStaticStr LMString LlvmType       -- ^ Defines a static 'LMString'
   | LMStaticArray [LlvmStatic] LlvmType -- ^ A static array
   | LMStaticStruc [LlvmStatic] LlvmType -- ^ A static structure type
+  | LMStaticStrucU [LlvmStatic] LlvmType -- ^ A static structure type
   | LMStaticPointer LlvmVar             -- ^ A pointer to other data
 
   -- static expressions, could split out but leave
@@ -191,6 +192,7 @@ getStatType (LMUninitType    t) = t
 getStatType (LMStaticStr   _ t) = t
 getStatType (LMStaticArray _ t) = t
 getStatType (LMStaticStruc _ t) = t
+getStatType (LMStaticStrucU _ t) = t
 getStatType (LMStaticPointer v) = getVarType v
 getStatType (LMTrunc       _ t) = t
 getStatType (LMBitc        _ t) = t
diff --git a/compiler/GHC/Types/ForeignStubs.hs b/compiler/GHC/Types/ForeignStubs.hs
index 0a37d230fe..b92bfd9b64 100644
--- a/compiler/GHC/Types/ForeignStubs.hs
+++ b/compiler/GHC/Types/ForeignStubs.hs
@@ -4,29 +4,74 @@ module GHC.Types.ForeignStubs
    ( ForeignStubs (..)
    , CHeader(..)
    , CStub(..)
+   , initializerCStub
+   , finalizerCStub
    , appendStubC
    )
 where
 
+import {-# SOURCE #-} GHC.Cmm.CLabel
+
+import GHC.Platform
 import GHC.Utils.Outputable
+import Data.List ((++))
 import Data.Monoid
 import Data.Semigroup
 import Data.Coerce
 
-newtype CStub = CStub { getCStub :: SDoc }
+data CStub = CStub { getCStub :: SDoc
+                   , getInitializers :: [CLabel]
+                     -- ^ Initializers to be run at startup
+                     -- See Note [Initializers and finalizers in Cmm] in
+                     -- "GHC.Cmm.InitFini".
+                   , getFinalizers :: [CLabel]
+                     -- ^ Finalizers to be run at shutdown
+                   }
 
 emptyCStub :: CStub
-emptyCStub = CStub empty
+emptyCStub = CStub empty [] []
 
 instance Monoid CStub where
   mempty = emptyCStub
-  mconcat = coerce vcat
 
 instance Semigroup CStub where
-  (<>) = coerce ($$)
+  CStub a0 b0 c0 <> CStub a1 b1 c1 =
+      CStub (a0 $$ a1) (b0 ++ b1) (c0 ++ c1)
+
+functionCStub :: Platform -> CLabel -> SDoc -> SDoc -> CStub
+functionCStub platform clbl declarations body =
+    CStub body' [] []
+  where
+    body' = vcat
+        [ declarations
+        , hsep [text "void", pprCLabel platform CStyle clbl, text "(void)"]
+        , braces body
+        ]
+
+-- | @initializerCStub fn_nm decls body@ is a 'CStub' containing C initializer
+-- function (e.g. an entry of the @.init_array@ section) named
+-- @fn_nm@ with the given body and the given set of declarations.
+initializerCStub :: Platform -> CLabel -> SDoc -> SDoc -> CStub
+initializerCStub platform clbl declarations body =
+    functionCStub platform clbl declarations body
+    `mappend` CStub empty [clbl] []
+
+-- | @finalizerCStub fn_nm decls body@ is a 'CStub' containing C finalizer
+-- function (e.g. an entry of the @.fini_array@ section) named
+-- @fn_nm@ with the given body and the given set of declarations.
+finalizerCStub :: Platform -> CLabel -> SDoc -> SDoc -> CStub
+finalizerCStub platform clbl declarations body =
+    functionCStub platform clbl declarations body
+    `mappend` CStub empty [] [clbl]
 
 newtype CHeader = CHeader { getCHeader :: SDoc }
-  deriving (Monoid, Semigroup) via CStub
+
+instance Monoid CHeader where
+  mempty = CHeader empty
+  mconcat = coerce vcat
+
+instance Semigroup CHeader where
+    (<>) = coerce ($$)
 
 -- | Foreign export stubs
 data ForeignStubs
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 9aae391a1b..f4c1a41dd3 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -189,6 +189,7 @@ Library
         GHC.Cmm.Graph
         GHC.Cmm.Info
         GHC.Cmm.Info.Build
+        GHC.Cmm.InitFini
         GHC.Cmm.LayoutStack
         GHC.Cmm.Lexer
         GHC.Cmm.Lint