Refactor handling of global initializers

12 files changed, 245 insertions, 88 deletions

diff --git a/compiler/GHC/Cmm.hs b/compiler/GHC/Cmm.hs
index 893ca556db..79685b048b 100644
--- a/compiler/GHC/Cmm.hs
+++ b/compiler/GHC/Cmm.hs
@@ -184,6 +184,8 @@ data SectionType
   | RelocatableReadOnlyData
   | UninitialisedData
   | ReadOnlyData16      -- .rodata.cst16 on x86_64, 16-byte aligned
+  | InitArray           -- .init_array on ELF, .ctor on Windows
+  | FiniArray           -- .fini_array on ELF, .dtor on Windows
   | CString
   | OtherSection String
   deriving (Show)
@@ -201,6 +203,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 3acace8be2..02b9e86f0b 100644
--- a/compiler/GHC/Cmm/CLabel.hs
+++ b/compiler/GHC/Cmm/CLabel.hs
@@ -41,6 +41,11 @@ module GHC.Cmm.CLabel (
         mkBitmapLabel,
         mkStringLitLabel,
 
+        mkInitializerStubLabel,
+        mkInitializerArrayLabel,
+        mkFinalizerStubLabel,
+        mkFinalizerArrayLabel,
+
         mkAsmTempLabel,
         mkAsmTempDerivedLabel,
         mkAsmTempEndLabel,
@@ -258,6 +263,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
@@ -274,7 +281,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
 
@@ -294,6 +300,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
@@ -358,6 +377,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
@@ -402,6 +424,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
@@ -826,6 +850,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)
 
@@ -948,6 +985,7 @@ needsCDecl l@(ForeignLabel{})           = not (isMathFun l)
 needsCDecl (CC_Label _)                 = True
 needsCDecl (CCS_Label _)                = True
 needsCDecl (IPE_Label {})               = True
+needsCDecl (ModuleLabel {})             = True
 needsCDecl (HpcTicksLabel _)            = True
 needsCDecl (DynamicLinkerLabel {})      = panic "needsCDecl DynamicLinkerLabel"
 needsCDecl PicBaseLabel                 = panic "needsCDecl PicBaseLabel"
@@ -1071,6 +1109,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
@@ -1131,12 +1170,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
@@ -1451,7 +1499,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/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 df113b45b6..89cdec8f12 100644
--- a/compiler/GHC/CmmToAsm/Ppr.hs
+++ b/compiler/GHC/CmmToAsm/Ppr.hs
@@ -222,6 +222,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"
@@ -246,7 +254,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
@@ -256,5 +264,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/CmmToLlvm/Data.hs b/compiler/GHC/CmmToLlvm/Data.hs
index 0e5679887d..51cd9ab851 100644
--- a/compiler/GHC/CmmToLlvm/Data.hs
+++ b/compiler/GHC/CmmToLlvm/Data.hs
@@ -65,6 +65,20 @@ genLlvmData (_, CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit i
 
     pure ([LMGlobal aliasDef $ Just orig], [tyAlias])
 
+genLlvmData (Section InitArray _, CmmStaticsRaw _ lits) = do
+    let labels = [ lbl
+                 | CmmStaticLit (CmmLabel lbl) <- lits
+                 ]
+    decl <- genGlobalLabelArray "llvm.global_ctors" labels
+    pure ([decl], [])
+
+genLlvmData (Section FiniArray _, CmmStaticsRaw _ lits) = do
+    let labels = [ lbl
+                 | CmmStaticLit (CmmLabel lbl) <- lits
+                 ]
+    decl <- genGlobalLabelArray "llvm.globaldtors" labels
+    pure ([decl], [])
+
 genLlvmData (sec, CmmStaticsRaw lbl xs) = do
     label <- strCLabel_llvm lbl
     static <- mapM genData xs
@@ -88,6 +102,20 @@ genLlvmData (sec, CmmStaticsRaw lbl xs) = do
 
     return ([globDef], [tyAlias])
 
+-- | Produce a initializer or finalizer array declaration.
+genGlobalLabelArray :: String -> [CLabel] -> LlvmM LMGlobal
+genGlobalLabelArray _var_nm _lbls = do
+    error "TODO"
+    {-
+    return $ LMGlobal var (Just static)
+  where
+    var = LMVar var_nm
+    static = LMStaticArray vars ty
+    vars =
+    ty = LMArray (length lbls) LMLabel
+    ctor_ty = LMStruct [LMInt 32, LMPointer LMLabel
+    -}
+
 -- | Format the section type part of a Cmm Section
 llvmSectionType :: Platform -> SectionType -> FastString
 llvmSectionType p t = case t of
@@ -106,7 +134,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..bc5289e75e 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,38 @@ 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)
         }
 
+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 +242,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 +319,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 +362,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 77c6ba651c..ec6f06a62f 100644
--- a/compiler/GHC/HsToCore/Coverage.hs
+++ b/compiler/GHC/HsToCore/Coverage.hs
@@ -1348,23 +1348,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 0c04929984..3114732beb 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,9 +686,8 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
      , rbrace
      ]
 
-
-foreignExportsInitialiser :: Module -> [Id] -> CStub
-foreignExportsInitialiser mod hs_fns =
+foreignExportsInitialiser :: Platform -> Module -> [Id] -> CStub
+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
@@ -695,21 +698,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 4751ae9ea6..5b136006a3 100644
--- a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs
+++ b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs
@@ -259,11 +259,12 @@ sptCreateStaticBinds hsc_env this_mod binds
 -- 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`
+    initializerCStub 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 "
@@ -277,17 +278,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/Types/ForeignStubs.hs b/compiler/GHC/Types/ForeignStubs.hs
index 0a37d230fe..b858257dcc 100644
--- a/compiler/GHC/Types/ForeignStubs.hs
+++ b/compiler/GHC/Types/ForeignStubs.hs
@@ -4,29 +4,72 @@ 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
+                   , 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