diff options
| -rw-r--r-- | compiler/GHC/Cmm.hs | 5 | ||||
| -rw-r--r-- | compiler/GHC/Cmm/CLabel.hs | 60 | ||||
| -rw-r--r-- | compiler/GHC/Cmm/CLabel.hs-boot | 9 | ||||
| -rw-r--r-- | compiler/GHC/Cmm/InitFini.hs | 78 | ||||
| -rw-r--r-- | compiler/GHC/Cmm/Ppr/Decl.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/CmmToAsm/PPC/Ppr.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/CmmToAsm/Ppr.hs | 12 | ||||
| -rw-r--r-- | compiler/GHC/CmmToC.hs | 20 | ||||
| -rw-r--r-- | compiler/GHC/CmmToLlvm/Data.hs | 45 | ||||
| -rw-r--r-- | compiler/GHC/Driver/CodeOutput.hs | 83 | ||||
| -rw-r--r-- | compiler/GHC/HsToCore/Coverage.hs | 27 | ||||
| -rw-r--r-- | compiler/GHC/HsToCore/Foreign/Decl.hs | 38 | ||||
| -rw-r--r-- | compiler/GHC/Iface/Tidy/StaticPtrTable.hs | 21 | ||||
| -rw-r--r-- | compiler/GHC/Llvm/Ppr.hs | 1 | ||||
| -rw-r--r-- | compiler/GHC/Llvm/Types.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Types/ForeignStubs.hs | 55 | ||||
| -rw-r--r-- | compiler/ghc.cabal.in | 1 |
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 |