Change the way module initialisation is done (#3252, #4417)

Previously the code generator generated small code fragments labelled
with __stginit_M for each module M, and these performed whatever
initialisation was necessary for that module and recursively invoked
the initialisation functions for imported modules.  This appraoch had
drawbacks:

 - FFI users had to call hs_add_root() to ensure the correct
   initialisation routines were called.  This is a non-standard,
   and ugly, API.

 - unless we were using -split-objs, the __stginit dependencies would
   entail linking the whole transitive closure of modules imported,
   whether they were actually used or not.  In an extreme case (#4387,
   #4417), a module from GHC might be imported for use in Template
   Haskell or an annotation, and that would force the whole of GHC to
   be needlessly linked into the final executable.

So now instead we do our initialisation with C functions marked with
__attribute__((constructor)), which are automatically invoked at
program startup time (or DSO load-time).  The C initialisers are
emitted into the stub.c file.  This means that every time we compile
with -prof or -hpc, we now get a stub file, but thanks to #3687 that
is now invisible to the user.

There are some refactorings in the RTS (particularly for HPC) to
handle the fact that initialisers now get run earlier than they did
before.

The __stginit symbols are still generated, and the hs_add_root()
function still exists (but does nothing), for backwards compatibility.

diff --git a/aclocal.m4 b/aclocal.m4
index 23e6bc0..e09bda8 100644 (file)
--- a/aclocal.m4
+++ b/aclocal.m4
@@ -484,6 +484,31 @@ AC_SUBST([LdXFlag])
 ])# FP_PROG_LD_X
 
 
 ])# FP_PROG_LD_X
 
 

+# FP_PROG_LD_BUILD_ID
+# ------------
+
+# Sets the output variable LdHasBuildId to YES if ld supports
+# --build-id, or NO otherwise.
+AC_DEFUN([FP_PROG_LD_BUILD_ID],
+[
+AC_CACHE_CHECK([whether ld understands --build-id], [fp_cv_ld_build_id],
+[echo 'foo() {}' > conftest.c
+${CC-cc} -c conftest.c
+if ${LdCmd} -r --build-id=none -o conftest2.o conftest.o > /dev/null 2>&1; then
+   fp_cv_ld_build_id=yes
+else
+   fp_cv_ld_build_id=no
+fi
+rm -rf conftest*])
+if test "$fp_cv_ld_build_id" = yes; then
+  LdHasBuildId=YES
+else
+  LdHasBuildId=NO
+fi
+AC_SUBST([LdHasBuildId])
+])# FP_PROG_LD_BUILD_ID
+
+

 # FP_PROG_LD_IS_GNU
 # -----------------
 # Sets the output variable LdIsGNULd to YES or NO, depending on whether it is
 # FP_PROG_LD_IS_GNU
 # -----------------
 # Sets the output variable LdIsGNULd to YES or NO, depending on whether it is

diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs
index 4d95961..c151a26 100644 (file)
--- a/compiler/cmm/CLabel.hs
+++ b/compiler/cmm/CLabel.hs
@@ -51,9 +51,7 @@ module CLabel (
 
        mkAsmTempLabel,
 
 
        mkAsmTempLabel,
 

-       mkModuleInitLabel,
-       mkPlainModuleInitLabel,
-       mkModuleInitTableLabel,
+        mkPlainModuleInitLabel,

 
        mkSplitMarkerLabel,
        mkDirty_MUT_VAR_Label,
 
        mkSplitMarkerLabel,
        mkDirty_MUT_VAR_Label,

@@ -70,10 +68,7 @@ module CLabel (
        mkRtsPrimOpLabel,
        mkRtsSlowTickyCtrLabel,
 
        mkRtsPrimOpLabel,
        mkRtsSlowTickyCtrLabel,
 

-       moduleRegdLabel,
-       moduleRegTableLabel,
-
-       mkSelectorInfoLabel,
+        mkSelectorInfoLabel,

        mkSelectorEntryLabel,
 
        mkCmmInfoLabel,
        mkSelectorEntryLabel,
 
        mkCmmInfoLabel,

@@ -102,7 +97,6 @@ module CLabel (
         mkDeadStripPreventer,
 
         mkHpcTicksLabel,
         mkDeadStripPreventer,
 
         mkHpcTicksLabel,

-        mkHpcModuleNameLabel,

 
         hasCAF,
        infoLblToEntryLbl, entryLblToInfoLbl, cvtToClosureLbl, cvtToSRTLbl,
 
         hasCAF,
        infoLblToEntryLbl, entryLblToInfoLbl, cvtToClosureLbl, cvtToSRTLbl,

@@ -202,23 +196,9 @@ data CLabel
   | StringLitLabel
        {-# UNPACK #-} !Unique
 
   | StringLitLabel
        {-# UNPACK #-} !Unique
 

-  | ModuleInitLabel 
-       Module                  -- the module name
-       String                  -- its "way"
-       -- at some point we might want some kind of version number in
-       -- the module init label, to guard against compiling modules in
-       -- the wrong order.  We can't use the interface file version however,
-       -- because we don't always recompile modules which depend on a module
-       -- whose version has changed.
-
-  | PlainModuleInitLabel       -- without the version & way info
+  | PlainModuleInitLabel        -- without the version & way info

        Module
 
        Module
 

-  | ModuleInitTableLabel       -- table of imported modules to init
-       Module
-
-  | ModuleRegdLabel
-

   | CC_Label  CostCentre
   | CCS_Label CostCentreStack
 
   | CC_Label  CostCentre
   | CCS_Label CostCentreStack
 

@@ -242,9 +222,6 @@ data CLabel
   -- | Per-module table of tick locations
   | HpcTicksLabel Module
 
   -- | Per-module table of tick locations
   | HpcTicksLabel Module
 

-  -- | Per-module name of the module for Hpc
-  | HpcModuleNameLabel
-

   -- | Label of an StgLargeSRT
   | LargeSRTLabel
         {-# UNPACK #-} !Unique
   -- | Label of an StgLargeSRT
   | LargeSRTLabel
         {-# UNPACK #-} !Unique

@@ -490,7 +467,6 @@ mkRtsSlowTickyCtrLabel pat = RtsLabel (RtsSlowTickyCtr pat)
 
 -- Constructing Code Coverage Labels
 mkHpcTicksLabel                = HpcTicksLabel
 
 -- Constructing Code Coverage Labels
 mkHpcTicksLabel                = HpcTicksLabel

-mkHpcModuleNameLabel           = HpcModuleNameLabel

 
 
 -- Constructing labels used for dynamic linking
 
 
 -- Constructing labels used for dynamic linking

@@ -515,19 +491,9 @@ mkStringLitLabel           = StringLitLabel
 mkAsmTempLabel :: Uniquable a => a -> CLabel
 mkAsmTempLabel a               = AsmTempLabel (getUnique a)
 
 mkAsmTempLabel :: Uniquable a => a -> CLabel
 mkAsmTempLabel a               = AsmTempLabel (getUnique a)
 

-mkModuleInitLabel :: Module -> String -> CLabel
-mkModuleInitLabel mod way      = ModuleInitLabel mod way
-

 mkPlainModuleInitLabel :: Module -> CLabel
 mkPlainModuleInitLabel mod     = PlainModuleInitLabel mod
 
 mkPlainModuleInitLabel :: Module -> CLabel
 mkPlainModuleInitLabel mod     = PlainModuleInitLabel mod
 

-mkModuleInitTableLabel :: Module -> CLabel
-mkModuleInitTableLabel mod     = ModuleInitTableLabel mod
-
-moduleRegdLabel                        = ModuleRegdLabel
-moduleRegTableLabel            = ModuleInitTableLabel  
-
-

 -- -----------------------------------------------------------------------------
 -- Converting between info labels and entry/ret labels.
 
 -- -----------------------------------------------------------------------------
 -- Converting between info labels and entry/ret labels.
 

@@ -591,10 +557,7 @@ needsCDecl (LargeSRTLabel _)               = False
 needsCDecl (LargeBitmapLabel _)                = False
 needsCDecl (IdLabel _ _ _)             = True
 needsCDecl (CaseLabel _ _)             = True
 needsCDecl (LargeBitmapLabel _)                = False
 needsCDecl (IdLabel _ _ _)             = True
 needsCDecl (CaseLabel _ _)             = True

-needsCDecl (ModuleInitLabel _ _)       = True
-needsCDecl (PlainModuleInitLabel _)    = True
-needsCDecl (ModuleInitTableLabel _)    = True
-needsCDecl ModuleRegdLabel             = False
+needsCDecl (PlainModuleInitLabel _)     = True

 
 needsCDecl (StringLitLabel _)          = False
 needsCDecl (AsmTempLabel _)            = False
 
 needsCDecl (StringLitLabel _)          = False
 needsCDecl (AsmTempLabel _)            = False

@@ -612,7 +575,6 @@ needsCDecl l@(ForeignLabel{})               = not (isMathFun l)
 needsCDecl (CC_Label _)                        = True
 needsCDecl (CCS_Label _)               = True
 needsCDecl (HpcTicksLabel _)            = True
 needsCDecl (CC_Label _)                        = True
 needsCDecl (CCS_Label _)               = True
 needsCDecl (HpcTicksLabel _)            = True

-needsCDecl HpcModuleNameLabel           = False

 
 
 -- | Check whether a label is a local temporary for native code generation
 
 
 -- | Check whether a label is a local temporary for native code generation

@@ -725,11 +687,8 @@ externallyVisibleCLabel :: CLabel -> Bool -- not C "static"
 externallyVisibleCLabel (CaseLabel _ _)                = False
 externallyVisibleCLabel (StringLitLabel _)     = False
 externallyVisibleCLabel (AsmTempLabel _)       = False
 externallyVisibleCLabel (CaseLabel _ _)                = False
 externallyVisibleCLabel (StringLitLabel _)     = False
 externallyVisibleCLabel (AsmTempLabel _)       = False

-externallyVisibleCLabel (ModuleInitLabel _ _)  = True

 externallyVisibleCLabel (PlainModuleInitLabel _)= True
 externallyVisibleCLabel (PlainModuleInitLabel _)= True

-externallyVisibleCLabel (ModuleInitTableLabel _)= False
-externallyVisibleCLabel ModuleRegdLabel                = False
-externallyVisibleCLabel (RtsLabel _)           = True
+externallyVisibleCLabel (RtsLabel _)            = True

 externallyVisibleCLabel (CmmLabel _ _ _)       = True
 externallyVisibleCLabel (ForeignLabel{})       = True
 externallyVisibleCLabel (IdLabel name _ _)     = isExternalName name
 externallyVisibleCLabel (CmmLabel _ _ _)       = True
 externallyVisibleCLabel (ForeignLabel{})       = True
 externallyVisibleCLabel (IdLabel name _ _)     = isExternalName name

@@ -737,8 +696,7 @@ externallyVisibleCLabel (CC_Label _)                = True
 externallyVisibleCLabel (CCS_Label _)          = True
 externallyVisibleCLabel (DynamicLinkerLabel _ _)  = False
 externallyVisibleCLabel (HpcTicksLabel _)      = True
 externallyVisibleCLabel (CCS_Label _)          = True
 externallyVisibleCLabel (DynamicLinkerLabel _ _)  = False
 externallyVisibleCLabel (HpcTicksLabel _)      = True

-externallyVisibleCLabel HpcModuleNameLabel     = False
-externallyVisibleCLabel (LargeBitmapLabel _)   = False
+externallyVisibleCLabel (LargeBitmapLabel _)    = False

 externallyVisibleCLabel (LargeSRTLabel _)      = False
 
 -- -----------------------------------------------------------------------------
 externallyVisibleCLabel (LargeSRTLabel _)      = False
 
 -- -----------------------------------------------------------------------------

@@ -777,9 +735,7 @@ labelType (RtsLabel (RtsApInfoTable _ _))       = DataLabel
 labelType (RtsLabel (RtsApFast _))              = CodeLabel
 labelType (CaseLabel _ CaseReturnInfo)          = DataLabel
 labelType (CaseLabel _ _)                      = CodeLabel
 labelType (RtsLabel (RtsApFast _))              = CodeLabel
 labelType (CaseLabel _ CaseReturnInfo)          = DataLabel
 labelType (CaseLabel _ _)                      = CodeLabel

-labelType (ModuleInitLabel _ _)                 = CodeLabel

 labelType (PlainModuleInitLabel _)              = CodeLabel
 labelType (PlainModuleInitLabel _)              = CodeLabel

-labelType (ModuleInitTableLabel _)              = DataLabel

 labelType (LargeSRTLabel _)                     = DataLabel
 labelType (LargeBitmapLabel _)                  = DataLabel
 labelType (ForeignLabel _ _ _ IsFunction)      = CodeLabel
 labelType (LargeSRTLabel _)                     = DataLabel
 labelType (LargeBitmapLabel _)                  = DataLabel
 labelType (ForeignLabel _ _ _ IsFunction)      = CodeLabel

@@ -837,10 +793,8 @@ labelDynamic this_pkg lbl =
    CmmLabel pkg _ _     -> True 
 
 #endif
    CmmLabel pkg _ _     -> True 
 
 #endif

-   ModuleInitLabel m _    -> not opt_Static && this_pkg /= (modulePackageId m)

    PlainModuleInitLabel m -> not opt_Static && this_pkg /= (modulePackageId m)
    PlainModuleInitLabel m -> not opt_Static && this_pkg /= (modulePackageId m)

-   ModuleInitTableLabel m -> not opt_Static && this_pkg /= (modulePackageId m)
-   
+

    -- Note that DynamicLinkerLabels do NOT require dynamic linking themselves.
    _                -> False
 
    -- Note that DynamicLinkerLabels do NOT require dynamic linking themselves.
    _                -> False
 

@@ -1008,9 +962,6 @@ pprCLbl (RtsLabel (RtsPrimOp primop))
 pprCLbl (RtsLabel (RtsSlowTickyCtr pat)) 
   = ptext (sLit "SLOW_CALL_") <> text pat <> ptext (sLit "_ctr")
 
 pprCLbl (RtsLabel (RtsSlowTickyCtr pat)) 
   = ptext (sLit "SLOW_CALL_") <> text pat <> ptext (sLit "_ctr")
 

-pprCLbl ModuleRegdLabel
-  = ptext (sLit "_module_registered")
-

 pprCLbl (ForeignLabel str _ _ _)
   = ftext str
 
 pprCLbl (ForeignLabel str _ _ _)
   = ftext str
 

@@ -1019,22 +970,12 @@ pprCLbl (IdLabel name cafs flavor) = ppr name <> ppIdFlavor flavor
 pprCLbl (CC_Label cc)          = ppr cc
 pprCLbl (CCS_Label ccs)        = ppr ccs
 
 pprCLbl (CC_Label cc)          = ppr cc
 pprCLbl (CCS_Label ccs)        = ppr ccs
 

-pprCLbl (ModuleInitLabel mod way)
-   = ptext (sLit "__stginit_") <> ppr mod
-       <> char '_' <> text way
-

 pprCLbl (PlainModuleInitLabel mod)
    = ptext (sLit "__stginit_") <> ppr mod
 
 pprCLbl (PlainModuleInitLabel mod)
    = ptext (sLit "__stginit_") <> ppr mod
 

-pprCLbl (ModuleInitTableLabel mod)
-   = ptext (sLit "__stginittable_") <> ppr mod
-

 pprCLbl (HpcTicksLabel mod)
   = ptext (sLit "_hpc_tickboxes_")  <> ppr mod <> ptext (sLit "_hpc")
 
 pprCLbl (HpcTicksLabel mod)
   = ptext (sLit "_hpc_tickboxes_")  <> ppr mod <> ptext (sLit "_hpc")
 

-pprCLbl HpcModuleNameLabel
-  = ptext (sLit "_hpc_module_name_str")
-

 ppIdFlavor :: IdLabelInfo -> SDoc
 ppIdFlavor x = pp_cSEP <>
               (case x of
 ppIdFlavor :: IdLabelInfo -> SDoc
 ppIdFlavor x = pp_cSEP <>
               (case x of

diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index ca6fa74..10f4e8b 100644 (file)
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -105,18 +105,19 @@ pprTop (CmmProc info clbl (ListGraph blocks)) =
         then pprDataExterns info $$
              pprWordArray (entryLblToInfoLbl clbl) info
         else empty) $$
         then pprDataExterns info $$
              pprWordArray (entryLblToInfoLbl clbl) info
         else empty) $$

-    (case blocks of
-        [] -> empty
-         -- the first block doesn't get a label:
-        (BasicBlock _ stmts : rest) -> vcat [
+    (vcat [

           blankLine,
           extern_decls,
            (if (externallyVisibleCLabel clbl)
                     then mkFN_ else mkIF_) (pprCLabel clbl) <+> lbrace,
            nest 8 temp_decls,
            nest 8 mkFB_,
           blankLine,
           extern_decls,
            (if (externallyVisibleCLabel clbl)
                     then mkFN_ else mkIF_) (pprCLabel clbl) <+> lbrace,
            nest 8 temp_decls,
            nest 8 mkFB_,

-           nest 8 (vcat (map pprStmt stmts)) $$
-              vcat (map pprBBlock rest),
+           case blocks of
+               [] -> empty
+               -- the first block doesn't get a label:
+               (BasicBlock _ stmts : rest) ->
+                    nest 8 (vcat (map pprStmt stmts)) $$
+                       vcat (map pprBBlock rest),

            nest 8 mkFE_,
            rbrace ]
     )
            nest 8 mkFE_,
            rbrace ]
     )

diff --git a/compiler/codeGen/CgHpc.hs b/compiler/codeGen/CgHpc.hs
index 8da2715..4875650 100644 (file)
--- a/compiler/codeGen/CgHpc.hs
+++ b/compiler/codeGen/CgHpc.hs
@@ -6,24 +6,14 @@
 --
 -----------------------------------------------------------------------------
 
 --
 -----------------------------------------------------------------------------
 

-module CgHpc (cgTickBox, initHpc, hpcTable) where
+module CgHpc (cgTickBox, hpcTable) where

 
 import OldCmm
 import CLabel
 import Module
 import OldCmmUtils
 
 import OldCmm
 import CLabel
 import Module
 import OldCmmUtils

-import CgUtils

 import CgMonad
 import CgMonad

-import CgForeignCall
-import ForeignCall
-import ClosureInfo
-import FastString

 import HscTypes
 import HscTypes

-import Panic
-import BasicTypes
-
-import Data.Char
-import Data.Word

 
 cgTickBox :: Module -> Int -> Code
 cgTickBox mod n = do
 
 cgTickBox :: Module -> Int -> Code
 cgTickBox mod n = do

@@ -40,47 +30,10 @@ cgTickBox mod n = do
 
 hpcTable :: Module -> HpcInfo -> Code
 hpcTable this_mod (HpcInfo hpc_tickCount _) = do
 
 hpcTable :: Module -> HpcInfo -> Code
 hpcTable this_mod (HpcInfo hpc_tickCount _) = do

-                        emitData ReadOnlyData
-                                        [ CmmDataLabel mkHpcModuleNameLabel
-                                        , CmmString $ map (fromIntegral . ord)
-                                                         (full_name_str)
-                                                      ++ [0]
-                                        ]

                         emitData Data $ [ CmmDataLabel (mkHpcTicksLabel this_mod)
                                         ] ++
                                         [ CmmStaticLit (CmmInt 0 W64)
                                         | _ <- take hpc_tickCount [0::Int ..]
                                         ]
                         emitData Data $ [ CmmDataLabel (mkHpcTicksLabel this_mod)
                                         ] ++
                                         [ CmmStaticLit (CmmInt 0 W64)
                                         | _ <- take hpc_tickCount [0::Int ..]
                                         ]

-  where
-    module_name_str = moduleNameString (Module.moduleName this_mod)
-    full_name_str   = if modulePackageId this_mod == mainPackageId 
-                     then module_name_str
-                     else packageIdString (modulePackageId this_mod) ++ "/" ++
-                          module_name_str

 
 hpcTable _ (NoHpcInfo {}) = error "TODO: impossible"
 
 hpcTable _ (NoHpcInfo {}) = error "TODO: impossible"

-
-initHpc :: Module -> HpcInfo -> Code
-initHpc this_mod (HpcInfo tickCount hashNo)
-  = do { id <- newTemp bWord
-       ; emitForeignCall'
-               PlayRisky
-               [CmmHinted id NoHint]
-               (CmmCallee
-                 (CmmLit $ CmmLabel $ mkForeignLabel mod_alloc Nothing ForeignLabelInThisPackage IsFunction)
-                  CCallConv
-               )
-               [ CmmHinted (mkLblExpr mkHpcModuleNameLabel) AddrHint
-               , CmmHinted (word32 tickCount) NoHint
-               , CmmHinted (word32 hashNo)    NoHint
-               , CmmHinted (CmmLit $ CmmLabel $ mkHpcTicksLabel $ this_mod) AddrHint
-               ]
-               (Just [])
-               NoC_SRT -- No SRT b/c we PlayRisky
-               CmmMayReturn
-       }
-  where
-       word32 i = CmmLit (CmmInt (fromIntegral (fromIntegral i :: Word32)) W32)
-       mod_alloc = mkFastString "hs_hpc_module"
-initHpc _ (NoHpcInfo {}) = panic "initHpc: NoHpcInfo"
-

diff --git a/compiler/codeGen/CgProf.hs b/compiler/codeGen/CgProf.hs
index 0cf209e..243aa1d 100644 (file)
--- a/compiler/codeGen/CgProf.hs
+++ b/compiler/codeGen/CgProf.hs
@@ -16,8 +16,7 @@ module CgProf (
        costCentreFrom, 
        curCCS, curCCSAddr,
        emitCostCentreDecl, emitCostCentreStackDecl, 
        costCentreFrom, 
        curCCS, curCCSAddr,
        emitCostCentreDecl, emitCostCentreStackDecl, 

-       emitRegisterCC, emitRegisterCCS,
-       emitSetCCC, emitCCS,
+        emitSetCCC, emitCCS,

 
        -- Lag/drag/void stuff
        ldvEnter, ldvEnterClosure, ldvRecordCreate
 
        -- Lag/drag/void stuff
        ldvEnter, ldvEnterClosure, ldvRecordCreate

@@ -348,56 +347,6 @@ sizeof_ccs_words
    (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE
 
 -- ---------------------------------------------------------------------------
    (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE
 
 -- ---------------------------------------------------------------------------

--- Registering CCs and CCSs
-
---   (cc)->link = CC_LIST;
---   CC_LIST = (cc);
---   (cc)->ccID = CC_ID++;
-
-emitRegisterCC :: CostCentre -> Code
-emitRegisterCC cc = do
-  { tmp <- newTemp cInt
-  ; stmtsC [
-     CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_link)
-                (CmmLoad cC_LIST bWord),
-     CmmStore cC_LIST cc_lit,
-     CmmAssign (CmmLocal tmp) (CmmLoad cC_ID cInt),
-     CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_ccID) (CmmReg (CmmLocal tmp)),
-     CmmStore cC_ID (cmmRegOffB (CmmLocal tmp) 1)
-   ]
-  }
-  where
-    cc_lit = CmmLit (CmmLabel (mkCCLabel cc))
-
---  (ccs)->prevStack = CCS_LIST;
---  CCS_LIST = (ccs);
---  (ccs)->ccsID = CCS_ID++;
-
-emitRegisterCCS :: CostCentreStack -> Code
-emitRegisterCCS ccs = do
-  { tmp <- newTemp cInt
-  ; stmtsC [
-     CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_prevStack) 
-                       (CmmLoad cCS_LIST bWord),
-     CmmStore cCS_LIST ccs_lit,
-     CmmAssign (CmmLocal tmp) (CmmLoad cCS_ID cInt),
-     CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_ccsID) (CmmReg (CmmLocal tmp)),
-     CmmStore cCS_ID (cmmRegOffB (CmmLocal tmp) 1)
-   ]
-  }
-  where
-    ccs_lit = CmmLit (CmmLabel (mkCCSLabel ccs))
-
-
-cC_LIST, cC_ID :: CmmExpr
-cC_LIST = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CC_LIST")))
-cC_ID   = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CC_ID")))
-
-cCS_LIST, cCS_ID :: CmmExpr
-cCS_LIST = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCS_LIST")))
-cCS_ID   = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCS_ID")))
-
--- ---------------------------------------------------------------------------

 -- Set the current cost centre stack
 
 emitSetCCC :: CostCentre -> Code
 -- Set the current cost centre stack
 
 emitSetCCC :: CostCentre -> Code

diff --git a/compiler/codeGen/CodeGen.lhs b/compiler/codeGen/CodeGen.lhs
index 6ce8fca..81a65f7 100644 (file)
--- a/compiler/codeGen/CodeGen.lhs
+++ b/compiler/codeGen/CodeGen.lhs
@@ -29,7 +29,6 @@ import CgHpc
 
 import CLabel
 import OldCmm
 
 import CLabel
 import OldCmm

-import OldCmmUtils

 import OldPprCmm
 
 import StgSyn
 import OldPprCmm
 
 import StgSyn

@@ -51,8 +50,7 @@ import Panic
 codeGen :: DynFlags
        -> Module
        -> [TyCon]
 codeGen :: DynFlags
        -> Module
        -> [TyCon]

-       -> [Module]             -- directly-imported modules
-       -> CollectedCCs         -- (Local/global) cost-centres needing declaring/registering.
+        -> CollectedCCs         -- (Local/global) cost-centres needing declaring/registering.

        -> [(StgBinding,[(Id,[Id])])]   -- Bindings to convert, with SRTs
        -> HpcInfo
        -> IO [Cmm]             -- Output
        -> [(StgBinding,[(Id,[Id])])]   -- Bindings to convert, with SRTs
        -> HpcInfo
        -> IO [Cmm]             -- Output

@@ -61,8 +59,7 @@ codeGen :: DynFlags
                 -- possible for object splitting to split up the
                 -- pieces later.
 
                 -- possible for object splitting to split up the
                 -- pieces later.
 

-codeGen dflags this_mod data_tycons imported_mods 
-       cost_centre_info stg_binds hpc_info
+codeGen dflags this_mod data_tycons cost_centre_info stg_binds hpc_info

   = do 
   { showPass dflags "CodeGen"
 
   = do 
   { showPass dflags "CodeGen"
 

@@ -73,167 +70,46 @@ codeGen dflags this_mod data_tycons imported_mods
                { cmm_binds  <- mapM (getCmm . cgTopBinding dflags) stg_binds
                ; cmm_tycons <- mapM cgTyCon data_tycons
                ; cmm_init   <- getCmm (mkModuleInit dflags cost_centre_info 
                { cmm_binds  <- mapM (getCmm . cgTopBinding dflags) stg_binds
                ; cmm_tycons <- mapM cgTyCon data_tycons
                ; cmm_init   <- getCmm (mkModuleInit dflags cost_centre_info 

-                                            this_mod imported_mods hpc_info)
-               ; return (cmm_binds ++ concat cmm_tycons ++ [cmm_init])
+                                             this_mod hpc_info)
+                ; return (cmm_init : cmm_binds ++ concat cmm_tycons)

                }
                -- Put datatype_stuff after code_stuff, because the
                -- datatype closure table (for enumeration types) to
                -- (say) PrelBase_True_closure, which is defined in
                -- code_stuff
 
                }
                -- Put datatype_stuff after code_stuff, because the
                -- datatype closure table (for enumeration types) to
                -- (say) PrelBase_True_closure, which is defined in
                -- code_stuff
 

+                -- Note [codegen-split-init] the cmm_init block must
+                -- come FIRST.  This is because when -split-objs is on
+                -- we need to combine this block with its
+                -- initialisation routines; see Note
+                -- [pipeline-split-init].
+

   ; dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms code_stuff)
 
   ; return code_stuff }
   ; dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms code_stuff)
 
   ; return code_stuff }

-\end{code}
-
-%************************************************************************
-%*                                                                     *
-\subsection[codegen-init]{Module initialisation code}
-%*                                                                     *
-%************************************************************************
-
-/* -----------------------------------------------------------------------------
-   Module initialisation
-
-   The module initialisation code looks like this, roughly:
-
-       FN(__stginit_Foo) {
-         JMP_(__stginit_Foo_1_p)
-       }
-
-       FN(__stginit_Foo_1_p) {
-       ...
-       }
-
-   We have one version of the init code with a module version and the
-   'way' attached to it.  The version number helps to catch cases
-   where modules are not compiled in dependency order before being
-   linked: if a module has been compiled since any modules which depend on
-   it, then the latter modules will refer to a different version in their
-   init blocks and a link error will ensue.
-
-   The 'way' suffix helps to catch cases where modules compiled in different
-   ways are linked together (eg. profiled and non-profiled).
-
-   We provide a plain, unadorned, version of the module init code
-   which just jumps to the version with the label and way attached.  The
-   reason for this is that when using foreign exports, the caller of
-   startupHaskell() must supply the name of the init function for the "top"
-   module in the program, and we don't want to require that this name
-   has the version and way info appended to it.
-   --------------------------------------------------------------------------  */
-
-We initialise the module tree by keeping a work-stack, 
-       * pointed to by Sp
-       * that grows downward
-       * Sp points to the last occupied slot
-

 
 

-\begin{code}
-mkModuleInit 
+mkModuleInit

         :: DynFlags
        -> CollectedCCs         -- cost centre info
        -> Module
         :: DynFlags
        -> CollectedCCs         -- cost centre info
        -> Module

-       -> [Module]
-       -> HpcInfo
+        -> HpcInfo

        -> Code
        -> Code

-mkModuleInit dflags cost_centre_info this_mod imported_mods hpc_info
-  = do { -- Allocate the static boolean that records if this
-          -- module has been registered already
-         emitData Data [CmmDataLabel moduleRegdLabel, 
-                        CmmStaticLit zeroCLit]

 
 

+mkModuleInit dflags cost_centre_info this_mod hpc_info
+  = do { -- Allocate the static boolean that records if this

         ; whenC (opt_Hpc) $
               hpcTable this_mod hpc_info
 
         ; whenC (opt_Hpc) $
               hpcTable this_mod hpc_info
 

-          -- we emit a recursive descent module search for all modules
-         -- and *choose* to chase it in :Main, below.
-          -- In this way, Hpc enabled modules can interact seamlessly with
-         -- not Hpc enabled moduled, provided Main is compiled with Hpc.
-
-        ; emitSimpleProc real_init_lbl $ do
-                       { ret_blk <- forkLabelledCode ret_code
-
-                        ; init_blk <- forkLabelledCode $ do
-                                        { mod_init_code; stmtC (CmmBranch ret_blk) }
-                                    
-                        ; stmtC (CmmCondBranch (cmmNeWord (CmmLit zeroCLit) mod_reg_val)
-                                    ret_blk)
-                        ; stmtC (CmmBranch init_blk)       
-                        }
-
-           -- Make the "plain" procedure jump to the "real" init procedure
-       ; emitSimpleProc plain_init_lbl jump_to_init
-
-       -- When compiling the module in which the 'main' function lives,
-       -- (that is, this_mod == main_mod)
-       -- we inject an extra stg_init procedure for stg_init_ZCMain, for the 
-       -- RTS to invoke.  We must consult the -main-is flag in case the
-       -- user specified a different function to Main.main
- 
-        -- Notice that the recursive descent is optional, depending on what options
-       -- are enabled.
-
-       ; whenC (this_mod == main_mod)
-               (emitSimpleProc plain_main_init_lbl rec_descent_init)
-    }
-  where
-    -- The way string we attach to the __stginit label to catch
-    -- accidental linking of modules compiled in different ways.  We
-    -- omit "dyn" from this way, because we want to be able to load
-    -- both dynamic and non-dynamic modules into a dynamic GHC.
-    way = mkBuildTag (filter want_way (ways dflags))
-    want_way w = not (wayRTSOnly w) && wayName w /= WayDyn
-
-    main_mod = mainModIs dflags
-
-    plain_init_lbl = mkPlainModuleInitLabel this_mod
-    real_init_lbl  = mkModuleInitLabel this_mod way
-    plain_main_init_lbl = mkPlainModuleInitLabel rOOT_MAIN
-
-    jump_to_init = stmtC (CmmJump (mkLblExpr real_init_lbl) [])
-
-    mod_reg_val = CmmLoad (mkLblExpr moduleRegdLabel) bWord
-
-    -- Main refers to GHC.TopHandler.runIO, so make sure we call the
-    -- init function for GHC.TopHandler.
-    extra_imported_mods
-       | this_mod == main_mod = [gHC_TOP_HANDLER]
-       | otherwise            = []
-
-    mod_init_code = do
-       {       -- Set mod_reg to 1 to record that we've been here
-         stmtC (CmmStore (mkLblExpr moduleRegdLabel) (CmmLit (mkIntCLit 1)))
-

         ; whenC (opt_SccProfilingOn) $ do 
            initCostCentres cost_centre_info
 
         ; whenC (opt_SccProfilingOn) $ do 
            initCostCentres cost_centre_info
 

-        ; whenC (opt_Hpc) $
-            initHpc this_mod hpc_info
-         
-       ; mapCs (registerModuleImport way)
-               (imported_mods++extra_imported_mods)
-
-       } 
-
-                    -- The return-code pops the work stack by 
-                    -- incrementing Sp, and then jumpd to the popped item
-    ret_code = stmtsC [ CmmAssign spReg (cmmRegOffW spReg 1)
-                      , CmmJump (CmmLoad (cmmRegOffW spReg (-1)) bWord) [] ]
-
-
-    rec_descent_init = if opt_SccProfilingOn || isHpcUsed hpc_info
-                      then jump_to_init
-                      else ret_code
-
------------------------
-registerModuleImport :: String -> Module -> Code
-registerModuleImport way mod
-  | mod == gHC_PRIM
-  = nopC 
-  | otherwise  -- Push the init procedure onto the work stack
-  = stmtsC [ CmmAssign spReg (cmmRegOffW spReg (-1))
-          , CmmStore (CmmReg spReg) (mkLblExpr (mkModuleInitLabel mod way)) ]
+            -- For backwards compatibility: user code may refer to this
+            -- label for calling hs_add_root().
+        ; emitSimpleProc (mkPlainModuleInitLabel this_mod) $ return ()
+
+        ; whenC (this_mod == mainModIs dflags) $
+             emitSimpleProc (mkPlainModuleInitLabel rOOT_MAIN) $ return ()
+    }

 \end{code}
 
 
 \end{code}
 
 

@@ -252,9 +128,7 @@ initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs)
   | otherwise
   = do { mapM_ emitCostCentreDecl       local_CCs
        ; mapM_ emitCostCentreStackDecl  singleton_CCSs
   | otherwise
   = do { mapM_ emitCostCentreDecl       local_CCs
        ; mapM_ emitCostCentreStackDecl  singleton_CCSs

-       ; mapM_ emitRegisterCC           local_CCs
-       ; mapM_ emitRegisterCCS          singleton_CCSs
-       }
+        }

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs
index 26ace07..fa3dcfe 100644 (file)
--- a/compiler/codeGen/StgCmm.hs
+++ b/compiler/codeGen/StgCmm.hs
@@ -24,16 +24,12 @@ import StgCmmHpc
 import StgCmmTicky
 
 import MkGraph
 import StgCmmTicky
 
 import MkGraph

-import CmmDecl

 import CmmExpr
 import CmmExpr

-import CmmUtils

 import CLabel
 import PprCmm
 
 import StgSyn
 import CLabel
 import PprCmm
 
 import StgSyn

-import PrelNames

 import DynFlags
 import DynFlags

-import StaticFlags

 
 import HscTypes
 import CostCentre
 
 import HscTypes
 import CostCentre

@@ -50,17 +46,14 @@ import Outputable
 codeGen :: DynFlags
         -> Module
         -> [TyCon]
 codeGen :: DynFlags
         -> Module
         -> [TyCon]

-        -> [Module]                    -- Directly-imported modules
-        -> CollectedCCs                -- (Local/global) cost-centres needing declaring/registering.
+         -> CollectedCCs                -- (Local/global) cost-centres needing declaring/registering.

         -> [(StgBinding,[(Id,[Id])])]  -- Bindings to convert, with SRTs
         -> HpcInfo
         -> IO [Cmm]            -- Output
 
         -> [(StgBinding,[(Id,[Id])])]  -- Bindings to convert, with SRTs
         -> HpcInfo
         -> IO [Cmm]            -- Output
 

-codeGen dflags this_mod data_tycons imported_mods 
+codeGen dflags this_mod data_tycons

         cost_centre_info stg_binds hpc_info
   = do  { showPass dflags "New CodeGen"
         cost_centre_info stg_binds hpc_info
   = do  { showPass dflags "New CodeGen"

-        ; let way = buildTag dflags
-              main_mod = mainModIs dflags

 
 -- Why?
 --   ; mapM_ (\x -> seq x (return ())) data_tycons
 
 -- Why?
 --   ; mapM_ (\x -> seq x (return ())) data_tycons

@@ -68,10 +61,9 @@ codeGen dflags this_mod data_tycons imported_mods
         ; code_stuff <- initC dflags this_mod $ do 
                 { cmm_binds  <- mapM (getCmm . cgTopBinding dflags) stg_binds
                 ; cmm_tycons <- mapM cgTyCon data_tycons
         ; code_stuff <- initC dflags this_mod $ do 
                 { cmm_binds  <- mapM (getCmm . cgTopBinding dflags) stg_binds
                 ; cmm_tycons <- mapM cgTyCon data_tycons

-                ; cmm_init   <- getCmm (mkModuleInit way cost_centre_info 
-                                             this_mod main_mod
-                                             imported_mods hpc_info)
-                ; return (cmm_binds ++ concat cmm_tycons ++ [cmm_init])
+                ; cmm_init   <- getCmm (mkModuleInit cost_centre_info
+                                             this_mod hpc_info)
+                ; return (cmm_init : cmm_binds ++ concat cmm_tycons)

                 }
                 -- Put datatype_stuff after code_stuff, because the
                 -- datatype closure table (for enumeration types) to
                 }
                 -- Put datatype_stuff after code_stuff, because the
                 -- datatype closure table (for enumeration types) to

@@ -82,6 +74,12 @@ codeGen dflags this_mod data_tycons imported_mods
                 -- possible for object splitting to split up the
                 -- pieces later.
 
                 -- possible for object splitting to split up the
                 -- pieces later.
 

+                -- Note [codegen-split-init] the cmm_init block must
+                -- come FIRST.  This is because when -split-objs is on
+                -- we need to combine this block with its
+                -- initialisation routines; see Note
+                -- [pipeline-split-init].
+

         ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "New Cmm" (pprCmms code_stuff)
 
         ; return code_stuff }
         ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "New Cmm" (pprCmms code_stuff)
 
         ; return code_stuff }

@@ -173,89 +171,18 @@ We initialise the module tree by keeping a work-stack,
 -}
 
 mkModuleInit 
 -}
 
 mkModuleInit 

-       :: String               -- the "way"
-       -> CollectedCCs         -- cost centre info
+        :: CollectedCCs         -- cost centre info

        -> Module
        -> Module

-       -> Module               -- name of the Main module
-       -> [Module]
-       -> HpcInfo
+        -> HpcInfo

        -> FCode ()
        -> FCode ()

-mkModuleInit way cost_centre_info this_mod main_mod imported_mods hpc_info
-  = do { -- Allocate the static boolean that records if this
-          -- module has been registered already
-         emitData Data [CmmDataLabel moduleRegdLabel, 
-                        CmmStaticLit zeroCLit]
-
-        ; init_hpc  <- initHpc this_mod hpc_info
-       ; init_prof <- initCostCentres cost_centre_info
-
-          -- We emit a recursive descent module search for all modules
-         -- and *choose* to chase it in :Main, below.
-          -- In this way, Hpc enabled modules can interact seamlessly with
-         -- not Hpc enabled moduled, provided Main is compiled with Hpc.
-
-        ; updfr_sz <- getUpdFrameOff
-        ; tail <- getCode (pushUpdateFrame imports
-                       (do updfr_sz' <- getUpdFrameOff
-                           emit $ mkReturn (ret_e updfr_sz') [] (pop_ret_loc updfr_sz')))
-        ; emitSimpleProc real_init_lbl $ (withFreshLabel "ret_block" $ \retId -> catAGraphs
-               [ check_already_done retId updfr_sz
-               , init_prof
-               , init_hpc
-                , tail])
-           -- Make the "plain" procedure jump to the "real" init procedure
-       ; emitSimpleProc plain_init_lbl (jump_to_init updfr_sz)
-
-       -- When compiling the module in which the 'main' function lives,
-       -- (that is, this_mod == main_mod)
-       -- we inject an extra stg_init procedure for stg_init_ZCMain, for the 
-       -- RTS to invoke.  We must consult the -main-is flag in case the
-       -- user specified a different function to Main.main
- 
-        -- Notice that the recursive descent is optional, depending on what options
-       -- are enabled.
-
-
-       ; whenC (this_mod == main_mod)
-               (emitSimpleProc plain_main_init_lbl (rec_descent_init updfr_sz))
-    }
-  where
-    plain_init_lbl = mkPlainModuleInitLabel this_mod
-    real_init_lbl  = mkModuleInitLabel this_mod way
-    plain_main_init_lbl = mkPlainModuleInitLabel rOOT_MAIN
-
-    jump_to_init updfr_sz = mkJump (mkLblExpr real_init_lbl) [] updfr_sz
-
-
-    -- Main refers to GHC.TopHandler.runIO, so make sure we call the
-    -- init function for GHC.TopHandler.
-    extra_imported_mods
-       | this_mod == main_mod = [gHC_TOP_HANDLER]
-       | otherwise            = []
-    all_imported_mods = imported_mods ++ extra_imported_mods
-    imports = map (\mod -> mkLblExpr (mkModuleInitLabel mod way))
-                  (filter (gHC_PRIM /=) all_imported_mods)
-
-    mod_reg_val = CmmLoad (mkLblExpr moduleRegdLabel) bWord
-    check_already_done retId updfr_sz
-     = mkCmmIfThenElse (cmmNeWord (CmmLit zeroCLit) mod_reg_val)
-                      (mkLabel retId <*> mkReturn (ret_e updfr_sz) [] (pop_ret_loc updfr_sz)) mkNop
-       <*>     -- Set mod_reg to 1 to record that we've been here
-           mkStore (mkLblExpr moduleRegdLabel) (CmmLit (mkIntCLit 1))
-
-                    -- The return-code pops the work stack by 
-                    -- incrementing Sp, and then jumps to the popped item
-    ret_e updfr_sz = CmmLoad (CmmStackSlot (CallArea Old) updfr_sz) gcWord
-    ret_code updfr_sz = mkJump (ret_e updfr_sz) [] (pop_ret_loc updfr_sz)
-      -- mkAssign spReg (cmmRegOffW spReg 1) <*>
-      -- mkJump (CmmLoad (cmmRegOffW spReg (-1)) bWord) [] updfr_sz
-
-    pop_ret_loc updfr_sz = updfr_sz - widthInBytes (typeWidth bWord)
-
-    rec_descent_init updfr_sz =
-      if opt_SccProfilingOn || isHpcUsed hpc_info
-      then jump_to_init updfr_sz
-      else ret_code updfr_sz
+
+mkModuleInit cost_centre_info this_mod hpc_info
+  = do  { initHpc this_mod hpc_info
+        ; initCostCentres cost_centre_info
+            -- For backwards compatibility: user code may refer to this
+            -- label for calling hs_add_root().
+        ; emitSimpleProc (mkPlainModuleInitLabel this_mod) $ emptyAGraph
+        }

 
 ---------------------------------------------------------------
 --     Generating static stuff for algebraic data types
 
 ---------------------------------------------------------------
 --     Generating static stuff for algebraic data types

diff --git a/compiler/codeGen/StgCmmHpc.hs b/compiler/codeGen/StgCmmHpc.hs
index a93af34..fae3bef 100644 (file)
--- a/compiler/codeGen/StgCmmHpc.hs
+++ b/compiler/codeGen/StgCmmHpc.hs
@@ -8,9 +8,7 @@
 
 module StgCmmHpc ( initHpc, mkTickBox ) where
 
 
 module StgCmmHpc ( initHpc, mkTickBox ) where
 

-import StgCmmUtils

 import StgCmmMonad
 import StgCmmMonad

-import StgCmmForeign

 
 import MkGraph
 import CmmDecl
 
 import MkGraph
 import CmmDecl

@@ -18,11 +16,8 @@ import CmmExpr
 import CLabel
 import Module
 import CmmUtils
 import CLabel
 import Module
 import CmmUtils

-import FastString

 import HscTypes
 import HscTypes

-import Data.Char

 import StaticFlags
 import StaticFlags

-import BasicTypes

 
 mkTickBox :: Module -> Int -> CmmAGraph
 mkTickBox mod n 
 
 mkTickBox :: Module -> Int -> CmmAGraph
 mkTickBox mod n 

@@ -35,41 +30,15 @@ mkTickBox mod n
                         (CmmLit $ CmmLabel $ mkHpcTicksLabel $ mod)
                         n
 
                         (CmmLit $ CmmLabel $ mkHpcTicksLabel $ mod)
                         n
 

-initHpc :: Module -> HpcInfo -> FCode CmmAGraph
+initHpc :: Module -> HpcInfo -> FCode ()

 -- Emit top-level tables for HPC and return code to initialise
 initHpc _ (NoHpcInfo {})
 -- Emit top-level tables for HPC and return code to initialise
 initHpc _ (NoHpcInfo {})

-  = return mkNop
-initHpc this_mod (HpcInfo tickCount hashNo)
-  = getCode $ whenC opt_Hpc $
-    do { emitData ReadOnlyData
-              [ CmmDataLabel mkHpcModuleNameLabel
-              , CmmString $ map (fromIntegral . ord)
-                               (full_name_str)
-                            ++ [0]
-              ]
-        ; emitData Data $ [ CmmDataLabel (mkHpcTicksLabel this_mod)
+  = return ()
+initHpc this_mod (HpcInfo tickCount _hashNo)
+  = whenC opt_Hpc $
+    do  { emitData Data $ [ CmmDataLabel (mkHpcTicksLabel this_mod)

               ] ++
               [ CmmStaticLit (CmmInt 0 W64)
               | _ <- take tickCount [0::Int ..]
               ]
               ] ++
               [ CmmStaticLit (CmmInt 0 W64)
               | _ <- take tickCount [0::Int ..]
               ]

-
-       ; id <- newTemp bWord -- TODO FIXME NOW
-        ; emitCCall
-               [(id,NoHint)]
-               (CmmLit $ CmmLabel $ mkForeignLabel mod_alloc Nothing ForeignLabelInThisPackage IsFunction)
-               [ (mkLblExpr mkHpcModuleNameLabel,AddrHint)
-               , (CmmLit $ mkIntCLit tickCount,NoHint)
-               , (CmmLit $ mkIntCLit hashNo,NoHint)
-               , (CmmLit $ CmmLabel $ mkHpcTicksLabel $ this_mod,AddrHint)
-               ]

        }
        }

-  where
-    mod_alloc = mkFastString "hs_hpc_module"
-    module_name_str = moduleNameString (Module.moduleName this_mod)
-    full_name_str   = if modulePackageId this_mod == mainPackageId 
-                     then module_name_str
-                     else packageIdString (modulePackageId this_mod) ++ "/" ++
-                          module_name_str
-
-
-         

diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs
index 36d05ac..08bf529 100644 (file)
--- a/compiler/codeGen/StgCmmProf.hs
+++ b/compiler/codeGen/StgCmmProf.hs
@@ -348,14 +348,12 @@ ifProfilingL xs
 --     Initialising Cost Centres & CCSs
 ---------------------------------------------------------------
 
 --     Initialising Cost Centres & CCSs
 ---------------------------------------------------------------
 

-initCostCentres :: CollectedCCs -> FCode CmmAGraph
--- Emit the declarations, and return code to register them
+initCostCentres :: CollectedCCs -> FCode ()
+-- Emit the declarations

 initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs)
 initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs)

-  = getCode $ whenC opt_SccProfilingOn $
+  = whenC opt_SccProfilingOn $

     do { mapM_ emitCostCentreDecl local_CCs
     do { mapM_ emitCostCentreDecl local_CCs

-       ; mapM_ emitCostCentreStackDecl  singleton_CCSs 
-       ; emit $ catAGraphs $ map mkRegisterCC local_CCs
-       ; emit $ catAGraphs $ map mkRegisterCCS singleton_CCSs }
+        ; mapM_ emitCostCentreStackDecl  singleton_CCSs  }

 
 
 emitCostCentreDecl :: CostCentre -> FCode ()
 
 
 emitCostCentreDecl :: CostCentre -> FCode ()

@@ -409,54 +407,6 @@ sizeof_ccs_words
    (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE
 
 -- ---------------------------------------------------------------------------
    (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE
 
 -- ---------------------------------------------------------------------------

--- Registering CCs and CCSs
-
---   (cc)->link = CC_LIST;
---   CC_LIST = (cc);
---   (cc)->ccID = CC_ID++;
-
-mkRegisterCC :: CostCentre -> CmmAGraph
-mkRegisterCC cc
-  = withTemp cInt $ \tmp -> 
-    catAGraphs [
-     mkStore (cmmOffsetB cc_lit oFFSET_CostCentre_link)
-                (CmmLoad cC_LIST bWord),
-     mkStore cC_LIST cc_lit,
-     mkAssign (CmmLocal tmp) (CmmLoad cC_ID cInt),
-     mkStore (cmmOffsetB cc_lit oFFSET_CostCentre_ccID) (CmmReg (CmmLocal tmp)),
-     mkStore cC_ID (cmmRegOffB (CmmLocal tmp) 1)
-   ]
-  where
-       cc_lit = CmmLit (CmmLabel (mkCCLabel cc))
-
---  (ccs)->prevStack = CCS_LIST;
---  CCS_LIST = (ccs);
---  (ccs)->ccsID = CCS_ID++;
-
-mkRegisterCCS :: CostCentreStack -> CmmAGraph
-mkRegisterCCS ccs
-  = withTemp cInt $ \ tmp ->
-    catAGraphs [
-     mkStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_prevStack) 
-                       (CmmLoad cCS_LIST bWord),
-     mkStore cCS_LIST ccs_lit,
-     mkAssign (CmmLocal tmp) (CmmLoad cCS_ID cInt),
-     mkStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_ccsID) (CmmReg (CmmLocal tmp)),
-     mkStore cCS_ID (cmmRegOffB (CmmLocal tmp) 1)
-   ]
-  where
-    ccs_lit = CmmLit (CmmLabel (mkCCSLabel ccs))
-
-
-cC_LIST, cC_ID :: CmmExpr
-cC_LIST = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CC_LIST")))
-cC_ID   = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CC_ID")))
-
-cCS_LIST, cCS_ID :: CmmExpr
-cCS_LIST = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCS_LIST")))
-cCS_ID   = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCS_ID")))
-
--- ---------------------------------------------------------------------------

 -- Set the current cost centre stack
 
 emitSetCCC :: CostCentre -> FCode ()
 -- Set the current cost centre stack
 
 emitSetCCC :: CostCentre -> FCode ()

diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index 95b70f0..b28f3eb 100644 (file)
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -5,7 +5,7 @@
 \section[Coverage]{@coverage@: the main function}
 
 \begin{code}
 \section[Coverage]{@coverage@: the main function}
 
 \begin{code}

-module Coverage (addCoverageTicksToBinds) where
+module Coverage (addCoverageTicksToBinds, hpcInitCode) where

 
 import HsSyn
 import Module
 
 import HsSyn
 import Module

@@ -25,6 +25,8 @@ import StaticFlags
 import TyCon
 import MonadUtils
 import Maybes
 import TyCon
 import MonadUtils
 import Maybes

+import CLabel
+import Util

 
 import Data.Array
 import System.Directory ( createDirectoryIfMissing )
 
 import Data.Array
 import System.Directory ( createDirectoryIfMissing )

@@ -871,3 +873,56 @@ mixHash :: FilePath -> Integer -> Int -> [MixEntry] -> Int
 mixHash file tm tabstop entries = fromIntegral $ hashString
        (show $ Mix file tm 0 tabstop entries)
 \end{code}
 mixHash file tm tabstop entries = fromIntegral $ hashString
        (show $ Mix file tm 0 tabstop entries)
 \end{code}

+
+%************************************************************************
+%*                                                                     *
+%*              initialisation
+%*                                                                     *
+%************************************************************************
+
+Each module compiled with -fhpc declares an initialisation function of
+the form `hpc_init_<module>()`, which is emitted into the _stub.c file
+and annotated with __attribute__((constructor)) so that it gets
+executed at startup time.
+
+The function's purpose is to call hs_hpc_module to register this
+module with the RTS, and it looks something like this:
+
+static void hpc_init_Main(void) __attribute__((constructor));
+static void hpc_init_Main(void)
+{extern StgWord64 _hpc_tickboxes_Main_hpc[];
+ hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc);}
+
+\begin{code}
+hpcInitCode :: Module -> HpcInfo -> SDoc
+hpcInitCode _ (NoHpcInfo {}) = empty
+hpcInitCode this_mod (HpcInfo tickCount hashNo)
+ = 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 [
+        ptext (sLit "extern StgWord64 ") <> tickboxes <>
+               ptext (sLit "[]") <> semi,
+        ptext (sLit "hs_hpc_module") <>
+          parens (hcat (punctuate comma [
+              doubleQuotes full_name_str,
+              int tickCount, -- really StgWord32
+              int hashNo,    -- really StgWord32
+              tickboxes
+            ])) <> semi
+       ])
+    ]
+  where
+    tickboxes = pprCLabel (mkHpcTicksLabel $ this_mod)
+
+    module_name  = hcat (map (text.charToC) $
+                         bytesFS (moduleNameFS (Module.moduleName this_mod)))
+    package_name = hcat (map (text.charToC) $
+                         bytesFS (packageIdFS  (modulePackageId this_mod)))
+    full_name_str
+       | modulePackageId this_mod == mainPackageId
+       = module_name
+       | otherwise
+       = package_name <> char '/' <> module_name
+\end{code}

diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index 142f695..37a3cf9 100644 (file)
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -105,10 +105,14 @@ deSugar hsc_env
                           ; (ds_fords, foreign_prs) <- dsForeigns fords
                           ; ds_rules <- mapMaybeM dsRule rules
                           ; ds_vects <- mapM dsVect vects
                           ; (ds_fords, foreign_prs) <- dsForeigns fords
                           ; ds_rules <- mapMaybeM dsRule rules
                           ; ds_vects <- mapM dsVect vects

+                          ; let hpc_init
+                                  | opt_Hpc   = hpcInitCode mod ds_hpc_info
+                                  | otherwise = empty

                           ; return ( ds_ev_binds
                                    , foreign_prs `appOL` core_prs `appOL` spec_prs
                                    , spec_rules ++ ds_rules, ds_vects
                           ; return ( ds_ev_binds
                                    , foreign_prs `appOL` core_prs `appOL` spec_prs
                                    , spec_rules ++ ds_rules, ds_vects

-                                   , ds_fords, ds_hpc_info, modBreaks) }
+                                   , ds_fords `appendStubC` hpc_init
+                                   , ds_hpc_info, modBreaks) }

 
         ; case mb_res of {
            Nothing -> return (msgs, Nothing) ;
 
         ; case mb_res of {
            Nothing -> return (msgs, Nothing) ;

diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 32d13f8..c509eb6 100644 (file)
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -350,6 +350,7 @@ Library
         TysPrim
         TysWiredIn
         CostCentre
         TysPrim
         TysWiredIn
         CostCentre

+        ProfInit

         SCCfinal
         RnBinds
         RnEnv
         SCCfinal
         RnBinds
         RnEnv

diff --git a/compiler/ghc.mk b/compiler/ghc.mk
index 48a802a..a7a353d 100644 (file)
--- a/compiler/ghc.mk
+++ b/compiler/ghc.mk
@@ -140,6 +140,8 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/.
        @echo 'cMKDLL                = "$(BLD_DLL)"'                        >> $@
        @echo 'cLdIsGNULd            :: String'                             >> $@
        @echo 'cLdIsGNULd            = "$(LdIsGNULd)"'                      >> $@
        @echo 'cMKDLL                = "$(BLD_DLL)"'                        >> $@
        @echo 'cLdIsGNULd            :: String'                             >> $@
        @echo 'cLdIsGNULd            = "$(LdIsGNULd)"'                      >> $@

+       @echo 'cLdHasBuildId         :: String'                             >> $@
+       @echo 'cLdHasBuildId         = "$(LdHasBuildId)"'                   >> $@

        @echo 'cLD_X                 :: String'                             >> $@
        @echo 'cLD_X                 = "$(LD_X)"'                           >> $@
        @echo 'cGHC_DRIVER_DIR       :: String'                             >> $@
        @echo 'cLD_X                 :: String'                             >> $@
        @echo 'cLD_X                 = "$(LD_X)"'                           >> $@
        @echo 'cGHC_DRIVER_DIR       :: String'                             >> $@

diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index d7d6ae3..61486fc 100644 (file)
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -1227,6 +1227,8 @@ runPhase SplitAs _input_fn dflags
                                   Just x -> x
 
         let split_s   n = split_s_prefix ++ "__" ++ show n <.> "s"
                                   Just x -> x
 
         let split_s   n = split_s_prefix ++ "__" ++ show n <.> "s"

+
+            split_obj :: Int -> FilePath

             split_obj n = split_odir </>
                           takeFileName base_o ++ "__" ++ show n <.> osuf
 
             split_obj n = split_odir </>
                           takeFileName base_o ++ "__" ++ show n <.> osuf
 

@@ -1253,15 +1255,31 @@ runPhase SplitAs _input_fn dflags
 
         io $ mapM_ assemble_file [1..n]
 
 
         io $ mapM_ assemble_file [1..n]
 

-        -- If there's a stub_o file, then we make it the n+1th split object.
+        -- Note [pipeline-split-init]
+        -- If we have a stub file, it may contain constructor
+        -- functions for initialisation of this module.  We can't
+        -- simply leave the stub as a separate object file, because it
+        -- will never be linked in: nothing refers to it.  We need to
+        -- ensure that if we ever refer to the data in this module
+        -- that needs initialisation, then we also pull in the
+        -- initialisation routine.
+        --
+        -- To that end, we make a DANGEROUS ASSUMPTION here: the data
+        -- that needs to be initialised is all in the FIRST split
+        -- object.  See Note [codegen-split-init].
+

         PipeState{maybe_stub_o} <- getPipeState
         PipeState{maybe_stub_o} <- getPipeState

-        n' <- case maybe_stub_o of
-                  Nothing     -> return n
-                  Just stub_o -> do io $ copyFile stub_o (split_obj (n+1))
-                                    return (n+1)
+        case maybe_stub_o of
+            Nothing     -> return ()
+            Just stub_o -> io $ do
+                     tmp_split_1 <- newTempName dflags osuf
+                     let split_1 = split_obj 1
+                     copyFile split_1 tmp_split_1
+                     removeFile split_1
+                     joinObjectFiles dflags [tmp_split_1, stub_o] split_1

 
         -- join them into a single .o file
 
         -- join them into a single .o file

-        io $ joinObjectFiles dflags (map split_obj [1..n']) output_fn
+        io $ joinObjectFiles dflags (map split_obj [1..n]) output_fn

 
         return (next_phase, output_fn)
 
 
         return (next_phase, output_fn)
 

@@ -1979,14 +1997,22 @@ joinObjectFiles dflags o_files output_fn = do
                             SysTools.Option "-nostdlib",
                             SysTools.Option "-nodefaultlibs",
                             SysTools.Option "-Wl,-r",
                             SysTools.Option "-nostdlib",
                             SysTools.Option "-nodefaultlibs",
                             SysTools.Option "-Wl,-r",

+                            SysTools.Option ld_build_id,

                             SysTools.Option ld_x_flag,
                             SysTools.Option "-o",
                             SysTools.FileOption "" output_fn ]
                          ++ map SysTools.Option md_c_flags
                          ++ args)
                             SysTools.Option ld_x_flag,
                             SysTools.Option "-o",
                             SysTools.FileOption "" output_fn ]
                          ++ map SysTools.Option md_c_flags
                          ++ args)

+

       ld_x_flag | null cLD_X = ""
                 | otherwise  = "-Wl,-x"
 
       ld_x_flag | null cLD_X = ""
                 | otherwise  = "-Wl,-x"
 

+      -- suppress the generation of the .note.gnu.build-id section,
+      -- which we don't need and sometimes causes ld to emit a
+      -- warning:
+      ld_build_id | cLdHasBuildId == "YES"  = "-Wl,--build-id=none"
+                  | otherwise               = ""
+

       md_c_flags = machdepCCOpts dflags
   
   if cLdIsGNULd == "YES"
       md_c_flags = machdepCCOpts dflags
   
   if cLdIsGNULd == "YES"

diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 0d94ade..ca2e14c 100644 (file)
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -756,9 +756,7 @@ data CoreModule
       -- | Type environment for types declared in this module
       cm_types    :: !TypeEnv,
       -- | Declarations
       -- | Type environment for types declared in this module
       cm_types    :: !TypeEnv,
       -- | Declarations

-      cm_binds    :: [CoreBind],
-      -- | Imports
-      cm_imports  :: ![Module]
+      cm_binds    :: [CoreBind]

     }
 
 instance Outputable CoreModule where
     }
 
 instance Outputable CoreModule where

@@ -857,11 +855,11 @@ compileCore simplify fn = do
         gutsToCoreModule :: Either (CgGuts, ModDetails) ModGuts -> CoreModule
         gutsToCoreModule (Left (cg, md))  = CoreModule {
           cm_module = cg_module cg,    cm_types = md_types md,
         gutsToCoreModule :: Either (CgGuts, ModDetails) ModGuts -> CoreModule
         gutsToCoreModule (Left (cg, md))  = CoreModule {
           cm_module = cg_module cg,    cm_types = md_types md,

-          cm_imports = cg_dir_imps cg, cm_binds = cg_binds cg
+          cm_binds = cg_binds cg

         }
         gutsToCoreModule (Right mg) = CoreModule {
           cm_module  = mg_module mg,                   cm_types   = mg_types mg,
         }
         gutsToCoreModule (Right mg) = CoreModule {
           cm_module  = mg_module mg,                   cm_types   = mg_types mg,

-          cm_imports = moduleEnvKeys (mg_dir_imps mg), cm_binds   = mg_binds mg
+          cm_binds   = mg_binds mg

          }
 
 -- %************************************************************************
          }
 
 -- %************************************************************************

diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs
index 841125a..70ddd6a 100644 (file)
--- a/compiler/main/HscMain.lhs
+++ b/compiler/main/HscMain.lhs
@@ -109,7 +109,8 @@ import CoreToStg    ( coreToStg )
 import qualified StgCmm        ( codeGen )
 import StgSyn
 import CostCentre
 import qualified StgCmm        ( codeGen )
 import StgSyn
 import CostCentre

-import TyCon           ( TyCon, isDataTyCon )
+import ProfInit
+import TyCon            ( TyCon, isDataTyCon )

 import Name            ( Name, NamedThing(..) )
 import SimplStg                ( stg2stg )
 import CodeGen         ( codeGen )
 import Name            ( Name, NamedThing(..) )
 import SimplStg                ( stg2stg )
 import CodeGen         ( codeGen )

@@ -863,8 +864,7 @@ hscGenHardCode cgguts mod_summary
                      cg_module   = this_mod,
                      cg_binds    = core_binds,
                      cg_tycons   = tycons,
                      cg_module   = this_mod,
                      cg_binds    = core_binds,
                      cg_tycons   = tycons,

-                     cg_dir_imps = dir_imps,
-                     cg_foreign  = foreign_stubs,
+                     cg_foreign  = foreign_stubs0,

                      cg_dep_pkgs = dependencies,
                      cg_hpc_info = hpc_info } = cgguts
              dflags = hsc_dflags hsc_env
                      cg_dep_pkgs = dependencies,
                      cg_hpc_info = hpc_info } = cgguts
              dflags = hsc_dflags hsc_env

@@ -883,16 +883,19 @@ hscGenHardCode cgguts mod_summary
              <- {-# SCC "CoreToStg" #-}
                 myCoreToStg dflags this_mod prepd_binds        
 
              <- {-# SCC "CoreToStg" #-}
                 myCoreToStg dflags this_mod prepd_binds        
 

+         let prof_init = profilingInitCode this_mod cost_centre_info
+             foreign_stubs = foreign_stubs0 `appendStubC` prof_init
+

          ------------------  Code generation ------------------
          
          cmms <- if dopt Opt_TryNewCodeGen dflags
                  then do cmms <- tryNewCodeGen hsc_env this_mod data_tycons
          ------------------  Code generation ------------------
          
          cmms <- if dopt Opt_TryNewCodeGen dflags
                  then do cmms <- tryNewCodeGen hsc_env this_mod data_tycons

-                                 dir_imps cost_centre_info
+                                 cost_centre_info

                                  stg_binds hpc_info
                          return cmms
                  else {-# SCC "CodeGen" #-}
                        codeGen dflags this_mod data_tycons
                                  stg_binds hpc_info
                          return cmms
                  else {-# SCC "CodeGen" #-}
                        codeGen dflags this_mod data_tycons

-                               dir_imps cost_centre_info
+                               cost_centre_info

                                stg_binds hpc_info
 
          --- Optionally run experimental Cmm transformations ---
                                stg_binds hpc_info
 
          --- Optionally run experimental Cmm transformations ---

@@ -963,15 +966,15 @@ hscCompileCmmFile hsc_env filename
 
 -------------------- Stuff for new code gen ---------------------
 
 
 -------------------- Stuff for new code gen ---------------------
 

-tryNewCodeGen  :: HscEnv -> Module -> [TyCon] -> [Module]
+tryNewCodeGen   :: HscEnv -> Module -> [TyCon]

                -> CollectedCCs
                -> [(StgBinding,[(Id,[Id])])]
                -> HpcInfo
                -> IO [Cmm]
                -> CollectedCCs
                -> [(StgBinding,[(Id,[Id])])]
                -> HpcInfo
                -> IO [Cmm]

-tryNewCodeGen hsc_env this_mod data_tycons imported_mods 
+tryNewCodeGen hsc_env this_mod data_tycons

              cost_centre_info stg_binds hpc_info =
   do   { let dflags = hsc_dflags hsc_env
              cost_centre_info stg_binds hpc_info =
   do   { let dflags = hsc_dflags hsc_env

-        ; prog <- StgCmm.codeGen dflags this_mod data_tycons imported_mods 
+        ; prog <- StgCmm.codeGen dflags this_mod data_tycons

                         cost_centre_info stg_binds hpc_info
        ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Cmm produced by new codegen" 
                (pprCmms prog)
                         cost_centre_info stg_binds hpc_info
        ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Cmm produced by new codegen" 
                (pprCmms prog)

diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index 3d441cc..e59c223 100644 (file)
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -14,7 +14,7 @@ module HscTypes (
 
         -- * Information about modules
        ModDetails(..), emptyModDetails,
 
         -- * Information about modules
        ModDetails(..), emptyModDetails,

-       ModGuts(..), CgGuts(..), ForeignStubs(..),
+        ModGuts(..), CgGuts(..), ForeignStubs(..), appendStubC,

         ImportedMods,
 
        ModSummary(..), ms_mod_name, showModMsg, isBootSummary,
         ImportedMods,
 
        ModSummary(..), ms_mod_name, showModMsg, isBootSummary,

@@ -799,11 +799,7 @@ data CgGuts
                -- data constructor workers; reason: we we regard them
                -- as part of the code-gen of tycons
 
                -- data constructor workers; reason: we we regard them
                -- as part of the code-gen of tycons
 

-       cg_dir_imps :: ![Module],
-               -- ^ Directly-imported modules; used to generate
-               -- initialisation code
-
-       cg_foreign  :: !ForeignStubs,   -- ^ Foreign export stubs
+        cg_foreign  :: !ForeignStubs,   -- ^ Foreign export stubs

        cg_dep_pkgs :: ![PackageId],    -- ^ Dependent packages, used to 
                                        -- generate #includes for C code gen
         cg_hpc_info :: !HpcInfo,        -- ^ Program coverage tick box information
        cg_dep_pkgs :: ![PackageId],    -- ^ Dependent packages, used to 
                                        -- generate #includes for C code gen
         cg_hpc_info :: !HpcInfo,        -- ^ Program coverage tick box information

@@ -823,6 +819,10 @@ data ForeignStubs = NoStubs             -- ^ We don't have any stubs
                    --
                    --  2) C stubs to use when calling
                    --     "foreign exported" functions
                    --
                    --  2) C stubs to use when calling
                    --     "foreign exported" functions

+
+appendStubC :: ForeignStubs -> SDoc -> ForeignStubs
+appendStubC NoStubs            c_code = ForeignStubs empty c_code
+appendStubC (ForeignStubs h c) c_code = ForeignStubs h (c $$ c_code)

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index b78c0db..f23280b 100644 (file)
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -292,8 +292,7 @@ tidyProgram hsc_env  (ModGuts { mg_module = mod, mg_exports = exports,
                                mg_binds = binds, 
                                mg_rules = imp_rules,
                                 mg_vect_info = vect_info,
                                mg_binds = binds, 
                                mg_rules = imp_rules,
                                 mg_vect_info = vect_info,

-                               mg_dir_imps = dir_imps, 
-                               mg_anns = anns,
+                                mg_anns = anns,

                                 mg_deps = deps, 
                                mg_foreign = foreign_stubs,
                                mg_hpc_info = hpc_info,
                                 mg_deps = deps, 
                                mg_foreign = foreign_stubs,
                                mg_hpc_info = hpc_info,

@@ -363,13 +362,10 @@ tidyProgram hsc_env  (ModGuts { mg_module = mod, mg_exports = exports,
                            <+> int (cs_ty cs) 
                            <+> int (cs_co cs) ))
 
                            <+> int (cs_ty cs) 
                            <+> int (cs_co cs) ))
 

-        ; let dir_imp_mods = moduleEnvKeys dir_imps
-
-       ; return (CgGuts { cg_module   = mod, 
-                          cg_tycons   = alg_tycons,
-                          cg_binds    = all_tidy_binds,
-                          cg_dir_imps = dir_imp_mods,
-                          cg_foreign  = foreign_stubs,
+        ; return (CgGuts { cg_module   = mod,
+                           cg_tycons   = alg_tycons,
+                           cg_binds    = all_tidy_binds,
+                           cg_foreign  = foreign_stubs,

                           cg_dep_pkgs = dep_pkgs deps,
                           cg_hpc_info = hpc_info,
                            cg_modBreaks = modBreaks }, 
                           cg_dep_pkgs = dep_pkgs deps,
                           cg_hpc_info = hpc_info,
                            cg_modBreaks = modBreaks }, 

diff --git a/compiler/profiling/ProfInit.hs b/compiler/profiling/ProfInit.hs
new file mode 100644 (file)
index 0000000..7e223f8
--- /dev/null
+++ b/compiler/profiling/ProfInit.hs
@@ -0,0 +1,45 @@
+-- -----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow, 2011
+--
+-- Generate code to initialise cost centres
+--
+-- -----------------------------------------------------------------------------
+
+module ProfInit (profilingInitCode) where
+
+import CLabel
+import CostCentre
+import Outputable
+import StaticFlags
+import FastString
+import Module
+
+-- -----------------------------------------------------------------------------
+-- Initialising cost centres
+
+-- We must produce declarations for the cost-centres defined in this
+-- module;
+
+profilingInitCode :: Module -> CollectedCCs -> SDoc
+profilingInitCode this_mod (local_CCs, ___extern_CCs, singleton_CCSs)
+ | not opt_SccProfilingOn = empty
+ | otherwise
+ = vcat
+    [ text "static void prof_init_" <> ppr this_mod
+         <> text "(void) __attribute__((constructor));"
+    , text "static void prof_init_" <> ppr this_mod <> text "(void)"
+    , braces (vcat (
+         map emitRegisterCC           local_CCs ++
+         map emitRegisterCCS          singleton_CCSs
+       ))
+    ]
+ where
+   emitRegisterCC cc   =
+      ptext (sLit "extern CostCentre ") <> cc_lbl <> ptext (sLit "[];") $$
+      ptext (sLit "REGISTER_CC(") <> cc_lbl <> char ')' <> semi
+     where cc_lbl = ppr (mkCCLabel cc)
+   emitRegisterCCS ccs =
+      ptext (sLit "extern CostCentreStack ") <> ccs_lbl <> ptext (sLit "[];") $$
+      ptext (sLit "REGISTER_CCS(") <> ccs_lbl <> char ')' <> semi
+     where ccs_lbl = ppr (mkCCSLabel ccs)

diff --git a/configure.ac b/configure.ac
index 21e965b..7baa3dd 100644 (file)
--- a/configure.ac
+++ b/configure.ac
@@ -816,6 +816,7 @@ FP_LEADING_UNDERSCORE
 dnl ** check for ld, whether it has an -x option, and if it is GNU ld
 FP_PROG_LD_X
 FP_PROG_LD_IS_GNU
 dnl ** check for ld, whether it has an -x option, and if it is GNU ld
 FP_PROG_LD_X
 FP_PROG_LD_IS_GNU

+FP_PROG_LD_BUILD_ID

 
 dnl ** check for Apple-style dead-stripping support
 dnl    (.subsections-via-symbols assembler directive)
 
 dnl ** check for Apple-style dead-stripping support
 dnl    (.subsections-via-symbols assembler directive)

diff --git a/docs/users_guide/ffi-chap.xml b/docs/users_guide/ffi-chap.xml
index 47c0f01..97a2378 100644 (file)
--- a/docs/users_guide/ffi-chap.xml
+++ b/docs/users_guide/ffi-chap.xml
@@ -245,18 +245,11 @@ extern HsInt foo(HsInt a0);</programlisting>
 #include "foo_stub.h"
 #endif
 
 #include "foo_stub.h"
 #endif
 

-#ifdef __GLASGOW_HASKELL__
-extern void __stginit_Foo ( void );
-#endif
-

 int main(int argc, char *argv[])
 {
   int i;
 
   hs_init(&amp;argc, &amp;argv);
 int main(int argc, char *argv[])
 {
   int i;
 
   hs_init(&amp;argc, &amp;argv);

-#ifdef __GLASGOW_HASKELL__
-  hs_add_root(__stginit_Foo);
-#endif

 
   for (i = 0; i &lt; 5; i++) {
     printf("%d\n", foo(2500));
 
   for (i = 0; i &lt; 5; i++) {
     printf("%d\n", foo(2500));

@@ -283,26 +276,6 @@ int main(int argc, char *argv[])
        (i.e. those arguments between
        <literal>+RTS...-RTS</literal>).</para>
 
        (i.e. those arguments between
        <literal>+RTS...-RTS</literal>).</para>
 

-       <para>Next, we call
-       <function>hs_add_root</function><indexterm><primary><function>hs_add_root</function></primary>
-       </indexterm>, a GHC-specific interface which is required to
-       initialise the Haskell modules in the program.  The argument
-       to <function>hs_add_root</function> should be the name of the
-       initialization function for the "root" module in your program
-       - in other words, the module which directly or indirectly
-       imports all the other Haskell modules in the program.  In a
-       standalone Haskell program the root module is normally
-       <literal>Main</literal>, but when you are using Haskell code
-       from a library it may not be.  If your program has multiple
-       root modules, then you can call
-       <function>hs_add_root</function> multiple times, one for each
-       root.  The name of the initialization function for module
-       <replaceable>M</replaceable> is
-       <literal>__stginit_<replaceable>M</replaceable></literal>, and
-       it may be declared as an external function symbol as in the
-       code above.  Note that the symbol name should be transformed
-       according to the Z-encoding:</para>
-

       <informaltable>
        <tgroup cols="2" align="left" colsep="1" rowsep="1">
          <thead>
       <informaltable>
        <tgroup cols="2" align="left" colsep="1" rowsep="1">
          <thead>

@@ -380,9 +353,6 @@ int main(int argc, char *argv[])
    // Initialize Haskell runtime
    hs_init(&amp;argc, &amp;argv);
 
    // Initialize Haskell runtime
    hs_init(&amp;argc, &amp;argv);
 

-   // Tell Haskell about all root modules
-   hs_add_root(__stginit_Foo);
-

    // do any other initialization here and
    // return false if there was a problem
    return HS_BOOL_TRUE;
    // do any other initialization here and
    // return false if there was a problem
    return HS_BOOL_TRUE;

@@ -394,7 +364,7 @@ int main(int argc, char *argv[])
 </programlisting>
 
         <para>The initialisation routine, <literal>mylib_init</literal>, calls
 </programlisting>
 
         <para>The initialisation routine, <literal>mylib_init</literal>, calls

-          <literal>hs_init()</literal> and <literal>hs_add_root()</literal> as
+          <literal>hs_init()</literal> as

           normal to initialise the Haskell runtime, and the corresponding
           deinitialisation function <literal>mylib_end()</literal> calls
           <literal>hs_exit()</literal> to shut down the runtime.</para>
           normal to initialise the Haskell runtime, and the corresponding
           deinitialisation function <literal>mylib_end()</literal> calls
           <literal>hs_exit()</literal> to shut down the runtime.</para>

@@ -599,8 +569,7 @@ int main(int argc, char *argv[])
           invoke <literal>foreign export</literal>ed functions from
           multiple OS threads concurrently.  The runtime system must
           be initialised as usual by
           invoke <literal>foreign export</literal>ed functions from
           multiple OS threads concurrently.  The runtime system must
           be initialised as usual by

-          calling <literal>hs_init()</literal>
-          and <literal>hs_add_root</literal>, and these calls must
+          calling <literal>hs_init()</literal>, and this call must

           complete before invoking any <literal>foreign
           export</literal>ed functions.</para>
       </sect3>
           complete before invoking any <literal>foreign
           export</literal>ed functions.</para>
       </sect3>

diff --git a/docs/users_guide/packages.xml b/docs/users_guide/packages.xml
index 5915046..86df594 100644 (file)
--- a/docs/users_guide/packages.xml
+++ b/docs/users_guide/packages.xml
@@ -279,7 +279,6 @@ exposed-modules: Network.BSD,
 <programlisting>
 /usr/bin/ld: Undefined symbols:
 _ZCMain_main_closure
 <programlisting>
 /usr/bin/ld: Undefined symbols:
 _ZCMain_main_closure

-___stginit_ZCMain

 </programlisting>
 </para>
 
 </programlisting>
 </para>
 

diff --git a/docs/users_guide/win32-dlls.xml b/docs/users_guide/win32-dlls.xml
index bf243a2..f00e1e2 100644 (file)
--- a/docs/users_guide/win32-dlls.xml
+++ b/docs/users_guide/win32-dlls.xml
@@ -429,8 +429,6 @@ foreign export stdcall adder :: Int -> Int -> IO Int
 // StartEnd.c
 #include <Rts.h>
 
 // StartEnd.c
 #include <Rts.h>
 

-extern void __stginit_Adder(void);
-

 void HsStart()
 {
    int argc = 1;
 void HsStart()
 {
    int argc = 1;

@@ -439,9 +437,6 @@ void HsStart()
    // Initialize Haskell runtime
    char** args = argv;
    hs_init(&argc, &args);
    // Initialize Haskell runtime
    char** args = argv;
    hs_init(&argc, &args);

-
-   // Tell Haskell about all root modules
-   hs_add_root(__stginit_Adder);

 }
 
 void HsEnd()
 }
 
 void HsEnd()

diff --git a/includes/rts/Hpc.h b/includes/rts/Hpc.h
index 26da35d..bceb81c 100644 (file)
--- a/includes/rts/Hpc.h
+++ b/includes/rts/Hpc.h
@@ -18,16 +18,16 @@
 typedef struct _HpcModuleInfo {
   char *modName;               // name of module
   StgWord32 tickCount;         // number of ticks
 typedef struct _HpcModuleInfo {
   char *modName;               // name of module
   StgWord32 tickCount;         // number of ticks

-  StgWord32 tickOffset;                // offset into a single large .tix Array
-  StgWord32 hashNo;            // Hash number for this module's mix info
+  StgWord32 hashNo;             // Hash number for this module's mix info

   StgWord64 *tixArr;           // tix Array; local for this module
   StgWord64 *tixArr;           // tix Array; local for this module

+  rtsBool from_file;            // data was read from the .tix file

   struct _HpcModuleInfo *next;
 } HpcModuleInfo;
 
   struct _HpcModuleInfo *next;
 } HpcModuleInfo;
 

-int hs_hpc_module (char *modName, 
-                   StgWord32 modCount, 
-                   StgWord32 modHashNo,
-                   StgWord64 *tixArr);
+void hs_hpc_module (char *modName,
+                    StgWord32 modCount,
+                    StgWord32 modHashNo,
+                    StgWord64 *tixArr);

 
 HpcModuleInfo * hs_hpc_rootModule (void);
 
 
 HpcModuleInfo * hs_hpc_rootModule (void);
 

diff --git a/mk/config.mk.in b/mk/config.mk.in
index 10911e6..be8b57b 100644 (file)
--- a/mk/config.mk.in
+++ b/mk/config.mk.in
@@ -659,6 +659,10 @@ LD_X                       = @LdXFlag@
 # overflowing command-line length limits.
 LdIsGNULd              = @LdIsGNULd@
 
 # overflowing command-line length limits.
 LdIsGNULd              = @LdIsGNULd@
 

+# Set to YES if ld has the --build-id flag.  Sometimes we need to
+# disable it with --build-id=none.
+LdHasBuildId           = @LdHasBuildId@
+

 # On MSYS, building with SplitObjs=YES fails with 
 #   ar: Bad file number
 # see #3201.  We need to specify a smaller max command-line size
 # On MSYS, building with SplitObjs=YES fails with 
 #   ar: Bad file number
 # see #3201.  We need to specify a smaller max command-line size

diff --git a/rts/Hpc.c b/rts/Hpc.c
index 81c802c..c4ff8d3 100644 (file)
--- a/rts/Hpc.c
+++ b/rts/Hpc.c
@@ -6,6 +6,8 @@
 #include "Rts.h"
 
 #include "Trace.h"
 #include "Rts.h"
 
 #include "Trace.h"

+#include "Hash.h"
+#include "RtsUtils.h"

 
 #include <stdio.h>
 #include <ctype.h>
 
 #include <stdio.h>
 #include <ctype.h>

@@ -36,11 +38,11 @@ static pid_t hpc_pid = 0;           // pid of this process at hpc-boot time.
 static FILE *tixFile;                  // file being read/written
 static int tix_ch;                     // current char
 
 static FILE *tixFile;                  // file being read/written
 static int tix_ch;                     // current char
 

+static HashTable * moduleHash = NULL;   // module name -> HpcModuleInfo
+

 HpcModuleInfo *modules = 0;
 HpcModuleInfo *modules = 0;

-HpcModuleInfo *nextModule = 0;
-int totalTixes = 0;            // total number of tix boxes.

 
 

-static char *tixFilename;
+static char *tixFilename = NULL;

 
 static void GNU_ATTRIBUTE(__noreturn__)
 failure(char *msg) {
 
 static void GNU_ATTRIBUTE(__noreturn__)
 failure(char *msg) {

@@ -78,7 +80,7 @@ static void ws(void) {
 }
 
 static char *expectString(void) {
 }
 
 static char *expectString(void) {

-  char tmp[256], *res;
+  char tmp[256], *res; // XXX

   int tmp_ix = 0;
   expect('"');
   while (tix_ch != '"') {
   int tmp_ix = 0;
   expect('"');
   while (tix_ch != '"') {

@@ -87,7 +89,7 @@ static char *expectString(void) {
   }
   tmp[tmp_ix++] = 0;
   expect('"');
   }
   tmp[tmp_ix++] = 0;
   expect('"');

-  res = malloc(tmp_ix);
+  res = stgMallocBytes(tmp_ix,"Hpc.expectString");

   strcpy(res,tmp);
   return res;
 }
   strcpy(res,tmp);
   return res;
 }

@@ -104,10 +106,8 @@ static StgWord64 expectWord64(void) {
 static void
 readTix(void) {
   unsigned int i;
 static void
 readTix(void) {
   unsigned int i;

-  HpcModuleInfo *tmpModule;
+  HpcModuleInfo *tmpModule, *lookup;

 
 

-  totalTixes = 0;
-    

   ws();
   expect('T');
   expect('i');
   ws();
   expect('T');
   expect('i');

@@ -117,7 +117,9 @@ readTix(void) {
   ws();
   
   while(tix_ch != ']') {
   ws();
   
   while(tix_ch != ']') {

-    tmpModule = (HpcModuleInfo *)calloc(1,sizeof(HpcModuleInfo));
+    tmpModule = (HpcModuleInfo *)stgMallocBytes(sizeof(HpcModuleInfo),
+                                                "Hpc.readTix");
+    tmpModule->from_file = rtsTrue;

     expect('T');
     expect('i');
     expect('x');
     expect('T');
     expect('i');
     expect('x');

@@ -134,8 +136,6 @@ readTix(void) {
     ws();
     tmpModule -> tickCount = (int)expectWord64();
     tmpModule -> tixArr = (StgWord64 *)calloc(tmpModule->tickCount,sizeof(StgWord64));
     ws();
     tmpModule -> tickCount = (int)expectWord64();
     tmpModule -> tixArr = (StgWord64 *)calloc(tmpModule->tickCount,sizeof(StgWord64));

-    tmpModule -> tickOffset = totalTixes;
-    totalTixes += tmpModule -> tickCount;

     ws();
     expect('[');
     ws();
     ws();
     expect('[');
     ws();

@@ -150,13 +150,32 @@ readTix(void) {
     expect(']');
     ws();
     
     expect(']');
     ws();
     

-    if (!modules) {
-      modules = tmpModule;
+    lookup = lookupHashTable(moduleHash, (StgWord)tmpModule->modName);
+    if (tmpModule == NULL) {
+        debugTrace(DEBUG_hpc,"readTix: new HpcModuleInfo for %s",
+                   tmpModule->modName);
+        insertHashTable(moduleHash, (StgWord)tmpModule->modName, tmpModule);

     } else {
     } else {

-      nextModule->next=tmpModule;
+        ASSERT(lookup->tixArr != 0);
+        ASSERT(!strcmp(tmpModule->modName, lookup->modName));
+        debugTrace(DEBUG_hpc,"readTix: existing HpcModuleInfo for %s",
+                   tmpModule->modName);
+        if (tmpModule->hashNo != lookup->hashNo) {
+            fprintf(stderr,"in module '%s'\n",tmpModule->modName);
+            failure("module mismatch with .tix/.mix file hash number");
+            if (tixFilename != NULL) {
+                fprintf(stderr,"(perhaps remove %s ?)\n",tixFilename);
+            }
+            stg_exit(EXIT_FAILURE);
+        }
+        for (i=0; i < tmpModule->tickCount; i++) {
+            lookup->tixArr[i] = tmpModule->tixArr[i];
+        }
+        stgFree(tmpModule->tixArr);
+        stgFree(tmpModule->modName);
+        stgFree(tmpModule);

     }
     }

-    nextModule=tmpModule;
-    
+

     if (tix_ch == ',') {
       expect(',');
       ws();
     if (tix_ch == ',') {
       expect(',');
       ws();

@@ -166,9 +185,18 @@ readTix(void) {
   fclose(tixFile);
 }
 
   fclose(tixFile);
 }
 

-static void hpc_init(void) {
+void
+startupHpc(void)
+{

   char *hpc_tixdir;
   char *hpc_tixfile;
   char *hpc_tixdir;
   char *hpc_tixfile;

+
+  if (moduleHash == NULL) {
+      // no modules were registered with hs_hpc_module, so don't bother
+      // creating the .tix file.
+      return;
+  }
+

   if (hpc_inited != 0) {
     return;
   }
   if (hpc_inited != 0) {
     return;
   }

@@ -177,6 +205,8 @@ static void hpc_init(void) {
   hpc_tixdir = getenv("HPCTIXDIR");
   hpc_tixfile = getenv("HPCTIXFILE");
 
   hpc_tixdir = getenv("HPCTIXDIR");
   hpc_tixfile = getenv("HPCTIXFILE");
 

+  debugTrace(DEBUG_hpc,"startupHpc");
+

   /* XXX Check results of mallocs/strdups, and check we are requesting
          enough bytes */
   if (hpc_tixfile != NULL) {
   /* XXX Check results of mallocs/strdups, and check we are requesting
          enough bytes */
   if (hpc_tixfile != NULL) {

@@ -192,10 +222,13 @@ static void hpc_init(void) {
 #endif
     /* Then, try open the file
      */
 #endif
     /* Then, try open the file
      */

-    tixFilename = (char *) malloc(strlen(hpc_tixdir) + strlen(prog_name) + 12);
+    tixFilename = (char *) stgMallocBytes(strlen(hpc_tixdir) +
+                                          strlen(prog_name) + 12,
+                                          "Hpc.startupHpc");

     sprintf(tixFilename,"%s/%s-%d.tix",hpc_tixdir,prog_name,(int)hpc_pid);
   } else {
     sprintf(tixFilename,"%s/%s-%d.tix",hpc_tixdir,prog_name,(int)hpc_pid);
   } else {

-    tixFilename = (char *) malloc(strlen(prog_name) + 6);
+    tixFilename = (char *) stgMallocBytes(strlen(prog_name) + 6,
+                                          "Hpc.startupHpc");

     sprintf(tixFilename, "%s.tix", prog_name);
   }
 
     sprintf(tixFilename, "%s.tix", prog_name);
   }
 

@@ -204,90 +237,80 @@ static void hpc_init(void) {
   }
 }
 
   }
 }
 

-/* Called on a per-module basis, at startup time, declaring where the tix boxes are stored in memory.
- * This memory can be uninitized, because we will initialize it with either the contents
- * of the tix file, or all zeros.
+/*
+ * Called on a per-module basis, by a constructor function compiled
+ * with each module (see Coverage.hpcInitCode), declaring where the
+ * tix boxes are stored in memory.  This memory can be uninitized,
+ * because we will initialize it with either the contents of the tix
+ * file, or all zeros.
+ *
+ * Note that we might call this before reading the .tix file, or after
+ * in the case where we loaded some Haskell code from a .so with
+ * dlopen().  So we must handle the case where we already have an
+ * HpcModuleInfo for the module which was read from the .tix file.

  */
 
  */
 

-int
+void

 hs_hpc_module(char *modName,
              StgWord32 modCount,
              StgWord32 modHashNo,
 hs_hpc_module(char *modName,
              StgWord32 modCount,
              StgWord32 modHashNo,

-             StgWord64 *tixArr) {
-  HpcModuleInfo *tmpModule, *lastModule;
-  unsigned int i;
-  int offset = 0;
-  
-  debugTrace(DEBUG_hpc,"hs_hpc_module(%s,%d)",modName,(nat)modCount);
+              StgWord64 *tixArr)
+{
+  HpcModuleInfo *tmpModule;
+  nat i;

 
 

-  hpc_init();
+  if (moduleHash == NULL) {
+      moduleHash = allocStrHashTable();
+  }

 
 

-  tmpModule = modules;
-  lastModule = 0;
-  
-  for(;tmpModule != 0;tmpModule = tmpModule->next) {
-    if (!strcmp(tmpModule->modName,modName)) {
+  tmpModule = lookupHashTable(moduleHash, (StgWord)modName);
+  if (tmpModule == NULL)
+  {
+      // Did not find entry so add one on.
+      tmpModule = (HpcModuleInfo *)stgMallocBytes(sizeof(HpcModuleInfo),
+                                                  "Hpc.hs_hpc_module");
+      tmpModule->modName = modName;
+      tmpModule->tickCount = modCount;
+      tmpModule->hashNo = modHashNo;
+
+      tmpModule->tixArr = tixArr;
+      for(i=0;i < modCount;i++) {
+          tixArr[i] = 0;
+      }
+      tmpModule->next = modules;
+      tmpModule->from_file = rtsFalse;
+      modules = tmpModule;
+      insertHashTable(moduleHash, (StgWord)modName, tmpModule);
+  }
+  else
+  {

       if (tmpModule->tickCount != modCount) {
       if (tmpModule->tickCount != modCount) {

-       failure("inconsistent number of tick boxes");
+          failure("inconsistent number of tick boxes");

       }
       }

-      assert(tmpModule->tixArr != 0);  
+      ASSERT(tmpModule->tixArr != 0);

       if (tmpModule->hashNo != modHashNo) {
       if (tmpModule->hashNo != modHashNo) {

-       fprintf(stderr,"in module '%s'\n",tmpModule->modName);
-       failure("module mismatch with .tix/.mix file hash number");
-       fprintf(stderr,"(perhaps remove %s ?)\n",tixFilename);
-       stg_exit(1);
-
+          fprintf(stderr,"in module '%s'\n",tmpModule->modName);
+          failure("module mismatch with .tix/.mix file hash number");
+          if (tixFilename != NULL) {
+              fprintf(stderr,"(perhaps remove %s ?)\n",tixFilename);
+          }
+          stg_exit(EXIT_FAILURE);

       }
       }

+      // The existing tixArr was made up when we read the .tix file,
+      // whereas this is the real tixArr, so copy the data from the
+      // .tix into the real tixArr.

       for(i=0;i < modCount;i++) {
       for(i=0;i < modCount;i++) {

-       tixArr[i] = tmpModule->tixArr[i];
+          tixArr[i] = tmpModule->tixArr[i];

       }
       }

-      tmpModule->tixArr = tixArr;
-      return tmpModule->tickOffset;
-    }
-    lastModule = tmpModule;
-  }
-  // Did not find entry so add one on.
-  tmpModule = (HpcModuleInfo *)calloc(1,sizeof(HpcModuleInfo));
-  tmpModule->modName = modName;
-  tmpModule->tickCount = modCount;
-  tmpModule->hashNo = modHashNo;
-  if (lastModule) {
-    tmpModule->tickOffset = lastModule->tickOffset + lastModule->tickCount;
-  } else {
-    tmpModule->tickOffset = 0;
-  }
-  tmpModule->tixArr = tixArr;
-  for(i=0;i < modCount;i++) {
-    tixArr[i] = 0;
-  }
-  tmpModule->next = 0;
-
-  if (!modules) {
-    modules = tmpModule;
-  } else {
-    lastModule->next=tmpModule;
-  }
-
-  debugTrace(DEBUG_hpc,"end: hs_hpc_module");
-
-  return offset;
-}
-

 
 

-/* This is called after all the modules have registered their local tixboxes,
- * and does a sanity check: are we good to go?
- */
-
-void
-startupHpc(void) {
-  debugTrace(DEBUG_hpc,"startupHpc");
- 
- if (hpc_inited == 0) {
-    return;
+      if (tmpModule->from_file) {
+          stgFree(tmpModule->modName);
+          stgFree(tmpModule->tixArr);
+      }
+      tmpModule->from_file = rtsFalse;

   }
 }
 
   }
 }
 

-

 static void
 writeTix(FILE *f) {
   HpcModuleInfo *tmpModule;  
 static void
 writeTix(FILE *f) {
   HpcModuleInfo *tmpModule;  

@@ -311,11 +334,10 @@ writeTix(FILE *f) {
           tmpModule->modName,
            (nat)tmpModule->hashNo,
            (nat)tmpModule->tickCount);
           tmpModule->modName,
            (nat)tmpModule->hashNo,
            (nat)tmpModule->tickCount);

-    debugTrace(DEBUG_hpc,"%s: %u (offset=%u) (hash=%u)\n",
+    debugTrace(DEBUG_hpc,"%s: %u (hash=%u)\n",

               tmpModule->modName,
               (nat)tmpModule->tickCount,
               tmpModule->modName,
               (nat)tmpModule->tickCount,

-              (nat)tmpModule->hashNo,
-              (nat)tmpModule->tickOffset);
+               (nat)tmpModule->hashNo);

 
     inner_comma = 0;
     for(i = 0;i < tmpModule->tickCount;i++) {
 
     inner_comma = 0;
     for(i = 0;i < tmpModule->tickCount;i++) {

@@ -338,7 +360,17 @@ writeTix(FILE *f) {
   fclose(f);
 }
 
   fclose(f);
 }
 

-/* Called at the end of execution, to write out the Hpc *.tix file  
+static void
+freeHpcModuleInfo (HpcModuleInfo *mod)
+{
+    if (mod->from_file) {
+        stgFree(mod->modName);
+        stgFree(mod->tixArr);
+    }
+    stgFree(mod);
+}
+
+/* Called at the end of execution, to write out the Hpc *.tix file

  * for this exection. Safe to call, even if coverage is not used.
  */
 void
  * for this exection. Safe to call, even if coverage is not used.
  */
 void

@@ -357,6 +389,12 @@ exitHpc(void) {
     FILE *f = fopen(tixFilename,"w");
     writeTix(f);
   }
     FILE *f = fopen(tixFilename,"w");
     writeTix(f);
   }

+
+  freeHashTable(moduleHash, (void (*)(void *))freeHpcModuleInfo);
+  moduleHash = NULL;
+
+  stgFree(tixFilename);
+  tixFilename = NULL;

 }
 
 //////////////////////////////////////////////////////////////////////////////
 }
 
 //////////////////////////////////////////////////////////////////////////////

diff --git a/rts/Main.c b/rts/Main.c
index c1b028f..c7a559f 100644 (file)
--- a/rts/Main.c
+++ b/rts/Main.c
@@ -15,16 +15,10 @@
 #include "Rts.h"
 #include "RtsMain.h"
 
 #include "Rts.h"
 #include "RtsMain.h"
 

-/* The symbol for the Haskell Main module's init function. It is safe to refer
- * to it here because this Main.o object file will only be linked in if we are
- * linking a Haskell program that uses a Haskell Main.main function.
- */
-extern void __stginit_ZCMain(void);
-

 /* Similarly, we can refer to the ZCMain_main_closure here */
 extern StgClosure ZCMain_main_closure;
 
 int main(int argc, char *argv[])
 {
 /* Similarly, we can refer to the ZCMain_main_closure here */
 extern StgClosure ZCMain_main_closure;
 
 int main(int argc, char *argv[])
 {

-    return hs_main(argc, argv, &__stginit_ZCMain, &ZCMain_main_closure);
+    return hs_main(argc, argv, &ZCMain_main_closure);

 }
 }

diff --git a/rts/ProfHeap.c b/rts/ProfHeap.c
index 39b64d4..f7fbd32 100644 (file)
--- a/rts/ProfHeap.c
+++ b/rts/ProfHeap.c
@@ -309,7 +309,7 @@ void initProfiling1 (void)
 {
 }
 
 {
 }
 

-void freeProfiling1 (void)
+void freeProfiling (void)

 {
 }
 
 {
 }
 

diff --git a/rts/Profiling.c b/rts/Profiling.c
index 1d8627c..5648f31 100644 (file)
--- a/rts/Profiling.c
+++ b/rts/Profiling.c
@@ -34,9 +34,9 @@ Arena *prof_arena;
  * closure_cats
  */
 
  * closure_cats
  */
 

-unsigned int CC_ID;
-unsigned int CCS_ID;
-unsigned int HP_ID;
+unsigned int CC_ID  = 1;
+unsigned int CCS_ID = 1;
+unsigned int HP_ID  = 1;

 
 /* figures for the profiling report.
  */
 
 /* figures for the profiling report.
  */

@@ -58,8 +58,8 @@ CostCentreStack *CCCS;
 /* Linked lists to keep track of cc's and ccs's that haven't
  * been declared in the log file yet
  */
 /* Linked lists to keep track of cc's and ccs's that haven't
  * been declared in the log file yet
  */

-CostCentre *CC_LIST;
-CostCentreStack *CCS_LIST;
+CostCentre      *CC_LIST  = NULL;
+CostCentreStack *CCS_LIST = NULL;

 
 /*
  * Built-in cost centres and cost-centre stacks:
 
 /*
  * Built-in cost centres and cost-centre stacks:

@@ -152,41 +152,10 @@ initProfiling1 (void)
 
   /* for the benefit of allocate()... */
   CCCS = CCS_SYSTEM;
 
   /* for the benefit of allocate()... */
   CCCS = CCS_SYSTEM;

-  
-  /* Initialize counters for IDs */
-  CC_ID  = 1;
-  CCS_ID = 1;
-  HP_ID  = 1;
-  
-  /* Initialize Declaration lists to NULL */
-  CC_LIST  = NULL;
-  CCS_LIST = NULL;
-
-  /* Register all the cost centres / stacks in the program 
-   * CC_MAIN gets link = 0, all others have non-zero link.
-   */
-  REGISTER_CC(CC_MAIN);
-  REGISTER_CC(CC_SYSTEM);
-  REGISTER_CC(CC_GC);
-  REGISTER_CC(CC_OVERHEAD);
-  REGISTER_CC(CC_SUBSUMED);
-  REGISTER_CC(CC_DONT_CARE);
-  REGISTER_CCS(CCS_MAIN);
-  REGISTER_CCS(CCS_SYSTEM);
-  REGISTER_CCS(CCS_GC);
-  REGISTER_CCS(CCS_OVERHEAD);
-  REGISTER_CCS(CCS_SUBSUMED);
-  REGISTER_CCS(CCS_DONT_CARE);
-
-  CCCS = CCS_OVERHEAD;
-
-  /* cost centres are registered by the per-module 
-   * initialisation code now... 
-   */

 }
 
 void
 }
 
 void

-freeProfiling1 (void)
+freeProfiling (void)

 {
     arenaFree(prof_arena);
 }
 {
     arenaFree(prof_arena);
 }

@@ -202,17 +171,36 @@ initProfiling2 (void)
    * information into it.  */
   initProfilingLogFile();
 
    * information into it.  */
   initProfilingLogFile();
 

+  /* Register all the cost centres / stacks in the program
+   * CC_MAIN gets link = 0, all others have non-zero link.
+   */
+  REGISTER_CC(CC_MAIN);
+  REGISTER_CC(CC_SYSTEM);
+  REGISTER_CC(CC_GC);
+  REGISTER_CC(CC_OVERHEAD);
+  REGISTER_CC(CC_SUBSUMED);
+  REGISTER_CC(CC_DONT_CARE);
+
+  REGISTER_CCS(CCS_SYSTEM);
+  REGISTER_CCS(CCS_GC);
+  REGISTER_CCS(CCS_OVERHEAD);
+  REGISTER_CCS(CCS_SUBSUMED);
+  REGISTER_CCS(CCS_DONT_CARE);
+  REGISTER_CCS(CCS_MAIN);
+

   /* find all the "special" cost centre stacks, and make them children
    * of CCS_MAIN.
    */
   /* find all the "special" cost centre stacks, and make them children
    * of CCS_MAIN.
    */

-  ASSERT(CCS_MAIN->prevStack == 0);
+  ASSERT(CCS_LIST == CCS_MAIN);
+  CCS_LIST = CCS_LIST->prevStack;
+  CCS_MAIN->prevStack = NULL;

   CCS_MAIN->root = CC_MAIN;
   ccsSetSelected(CCS_MAIN);
   DecCCS(CCS_MAIN);
 
   CCS_MAIN->root = CC_MAIN;
   ccsSetSelected(CCS_MAIN);
   DecCCS(CCS_MAIN);
 

-  for (ccs = CCS_LIST; ccs != CCS_MAIN; ) {
+  for (ccs = CCS_LIST; ccs != NULL; ) {

     next = ccs->prevStack;
     next = ccs->prevStack;

-    ccs->prevStack = 0;
+    ccs->prevStack = NULL;

     ActualPush_(CCS_MAIN,ccs->cc,ccs);
     ccs->root = ccs->cc;
     ccs = next;
     ActualPush_(CCS_MAIN,ccs->cc,ccs);
     ccs->root = ccs->cc;
     ccs = next;

diff --git a/rts/Profiling.h b/rts/Profiling.h
index 3a4184f..e27ad4c 100644 (file)
--- a/rts/Profiling.h
+++ b/rts/Profiling.h
@@ -14,9 +14,9 @@
 #include "BeginPrivate.h"
 
 void initProfiling1 (void);
 #include "BeginPrivate.h"
 
 void initProfiling1 (void);

-void freeProfiling1 (void);

 void initProfiling2 (void);
 void endProfiling   (void);
 void initProfiling2 (void);
 void endProfiling   (void);

+void freeProfiling  (void);

 
 extern FILE *prof_file;
 extern FILE *hp_file;
 
 extern FILE *prof_file;
 extern FILE *hp_file;

diff --git a/rts/RtsMain.c b/rts/RtsMain.c
index b6cf546..0ed6df4 100644 (file)
--- a/rts/RtsMain.c
+++ b/rts/RtsMain.c
@@ -28,13 +28,10 @@
 # include <windows.h>
 #endif
 
 # include <windows.h>
 #endif
 

-extern void __stginit_ZCMain(void);
-

 /* Annoying global vars for passing parameters to real_main() below
  * This is to get around problem with Windows SEH, see hs_main(). */
 static int progargc;
 static char **progargv;
 /* Annoying global vars for passing parameters to real_main() below
  * This is to get around problem with Windows SEH, see hs_main(). */
 static int progargc;
 static char **progargv;

-static void (*progmain_init)(void);   /* This will be __stginit_ZCMain */

 static StgClosure *progmain_closure;  /* This will be ZCMain_main_closure */
 
 /* Hack: we assume that we're building a batch-mode system unless 
 static StgClosure *progmain_closure;  /* This will be ZCMain_main_closure */
 
 /* Hack: we assume that we're building a batch-mode system unless 

@@ -47,7 +44,7 @@ static void real_main(void)
     SchedulerStatus status;
     /* all GranSim/GUM init is done in startupHaskell; sets IAmMainThread! */
 
     SchedulerStatus status;
     /* all GranSim/GUM init is done in startupHaskell; sets IAmMainThread! */
 

-    startupHaskell(progargc,progargv,progmain_init);
+    startupHaskell(progargc,progargv,NULL);

 
     /* kick off the computation by creating the main thread with a pointer
        to mainIO_closure representing the computation of the overall program;
 
     /* kick off the computation by creating the main thread with a pointer
        to mainIO_closure representing the computation of the overall program;

@@ -95,18 +92,17 @@ static void real_main(void)
  * This gets called from a tiny main function which gets linked into each
  * compiled Haskell program that uses a Haskell main function.
  *
  * This gets called from a tiny main function which gets linked into each
  * compiled Haskell program that uses a Haskell main function.
  *

- * We expect the caller to pass __stginit_ZCMain for main_init and
- * ZCMain_main_closure for main_closure. The reason we cannot refer to
- * these symbols directly is because we're inside the rts and we do not know
- * for sure that we'll be using a Haskell main function.
+ * We expect the caller to pass ZCMain_main_closure for
+ * main_closure. The reason we cannot refer to this symbol directly
+ * is because we're inside the rts and we do not know for sure that
+ * we'll be using a Haskell main function.

  */
  */

-int hs_main(int argc, char *argv[], void (*main_init)(void), StgClosure *main_closure)
+int hs_main(int argc, char *argv[], StgClosure *main_closure)

 {
     /* We do this dance with argc and argv as otherwise the SEH exception
        stuff (the BEGIN/END CATCH below) on Windows gets confused */
     progargc = argc;
     progargv = argv;
 {
     /* We do this dance with argc and argv as otherwise the SEH exception
        stuff (the BEGIN/END CATCH below) on Windows gets confused */
     progargc = argc;
     progargv = argv;

-    progmain_init    = main_init;

     progmain_closure = main_closure;
 
 #if defined(mingw32_HOST_OS)
     progmain_closure = main_closure;
 
 #if defined(mingw32_HOST_OS)

diff --git a/rts/RtsMain.h b/rts/RtsMain.h
index 4aabc56..24e5819 100644 (file)
--- a/rts/RtsMain.h
+++ b/rts/RtsMain.h
@@ -13,6 +13,6 @@
  * The entry point for Haskell programs that use a Haskell main function
  * -------------------------------------------------------------------------- */
 
  * The entry point for Haskell programs that use a Haskell main function
  * -------------------------------------------------------------------------- */
 

-int hs_main(int argc, char *argv[], void (*main_init)(void), StgClosure *main_closure);
+int hs_main(int argc, char *argv[], StgClosure *main_closure);

 
 #endif /* RTSMAIN_H */
 
 #endif /* RTSMAIN_H */

diff --git a/rts/RtsStartup.c b/rts/RtsStartup.c
index b860667..236d07a 100644 (file)
--- a/rts/RtsStartup.c
+++ b/rts/RtsStartup.c
@@ -224,90 +224,37 @@ hs_init(int *argc, char **argv[])
     x86_init_fpu();
 #endif
 
     x86_init_fpu();
 #endif
 

+    startupHpc();
+
+    // This must be done after module initialisation.
+    // ToDo: make this work in the presence of multiple hs_add_root()s.
+    initProfiling2();
+
+    // ditto.
+#if defined(THREADED_RTS)
+    ioManagerStart();
+#endif
+

     /* Record initialization times */
     stat_endInit();
 }
 
 // Compatibility interface
 void
     /* Record initialization times */
     stat_endInit();
 }
 
 // Compatibility interface
 void

-startupHaskell(int argc, char *argv[], void (*init_root)(void))
+startupHaskell(int argc, char *argv[], void (*init_root)(void) STG_UNUSED)

 {
     hs_init(&argc, &argv);
 {
     hs_init(&argc, &argv);

-    if(init_root)
-        hs_add_root(init_root);

 }
 
 
 /* -----------------------------------------------------------------------------
 }
 
 
 /* -----------------------------------------------------------------------------

-   Per-module initialisation
-
-   This process traverses all the compiled modules in the program
-   starting with "Main", and performing per-module initialisation for
-   each one.
-
-   So far, two things happen at initialisation time:
-
-      - we register stable names for each foreign-exported function
-        in that module.  This prevents foreign-exported entities, and
-       things they depend on, from being garbage collected.
-
-      - we supply a unique integer to each statically declared cost
-        centre and cost centre stack in the program.
-
-   The code generator inserts a small function "__stginit_<module>" in each
-   module and calls the registration functions in each of the modules it
-   imports.
-
-   The init* functions are compiled in the same way as STG code,
-   i.e. without normal C call/return conventions.  Hence we must use
-   StgRun to call this stuff.
+   hs_add_root: backwards compatibility.  (see #3252)

    -------------------------------------------------------------------------- */
 
    -------------------------------------------------------------------------- */
 

-/* The init functions use an explicit stack... 
- */
-#define INIT_STACK_BLOCKS  4
-static StgFunPtr *init_stack = NULL;
-

 void
 void

-hs_add_root(void (*init_root)(void))
+hs_add_root(void (*init_root)(void) STG_UNUSED)

 {
 {

-    bdescr *bd;
-    nat init_sp;
-    Capability *cap;
-
-    cap = rts_lock();
-
-    if (hs_init_count <= 0) {
-       barf("hs_add_root() must be called after hs_init()");
-    }
-
-    /* The initialisation stack grows downward, with sp pointing 
-       to the last occupied word */
-    init_sp = INIT_STACK_BLOCKS*BLOCK_SIZE_W;
-    bd = allocGroup_lock(INIT_STACK_BLOCKS);
-    init_stack = (StgFunPtr *)bd->start;
-    init_stack[--init_sp] = (StgFunPtr)stg_init_finish;
-    if (init_root != NULL) {
-       init_stack[--init_sp] = (StgFunPtr)init_root;
-    }
-    
-    cap->r.rSp = (P_)(init_stack + init_sp);
-    StgRun((StgFunPtr)stg_init, &cap->r);
-
-    freeGroup_lock(bd);
-
-    startupHpc();
-
-    // This must be done after module initialisation.
-    // ToDo: make this work in the presence of multiple hs_add_root()s.
-    initProfiling2();
-
-    rts_unlock(cap);
-
-    // ditto.
-#if defined(THREADED_RTS)
-    ioManagerStart();
-#endif
+    /* nothing */

 }
 
 /* ----------------------------------------------------------------------------
 }
 
 /* ----------------------------------------------------------------------------

@@ -424,7 +371,7 @@ hs_exit_(rtsBool wait_foreign)
 #endif
 
     endProfiling();
 #endif
 
     endProfiling();

-    freeProfiling1();
+    freeProfiling();

 
 #ifdef PROFILING
     // Originally, this was in report_ccs_profiling().  Now, retainer
 
 #ifdef PROFILING
     // Originally, this was in report_ccs_profiling().  Now, retainer