[commit: ghc] master: When -split-objs is on, make one SRT per split, not one per module (3473e21)

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/3473e213941b74a1074ec0cde77c0eeccf885e03

>---------------------------------------------------------------

commit 3473e213941b74a1074ec0cde77c0eeccf885e03
Author: Simon Marlow <[email protected]>
Date:   Tue Sep 25 16:02:45 2012 +0100

    When -split-objs is on, make one SRT per split, not one per module
    
    This is a hopefully temporary measure until the new SRT design is
    implemeented.

>---------------------------------------------------------------

 compiler/cmm/CLabel.hs             |   22 ++++++++------------
 compiler/cmm/CmmBuildInfoTables.hs |   12 ++++++----
 compiler/main/HscMain.hs           |   39 ++++++++++++++++++++++++-----------
 3 files changed, 43 insertions(+), 30 deletions(-)

diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs
index 1ff76c6..a5d559e 100644
--- a/compiler/cmm/CLabel.hs
+++ b/compiler/cmm/CLabel.hs
@@ -13,7 +13,7 @@ module CLabel (
 
         mkClosureLabel,
         mkSRTLabel,
-        mkModSRTLabel,
+        mkTopSRTLabel,
         mkInfoTableLabel,
         mkEntryLabel,
         mkSlowEntryLabel,
@@ -120,8 +120,6 @@ import DynFlags
 import Platform
 import UniqSet
 
-import Data.Maybe (isJust)
-
 -- -----------------------------------------------------------------------------
 -- The CLabel type
 
@@ -218,7 +216,7 @@ data CLabel
   | HpcTicksLabel Module
 
   -- | Static reference table
-  | SRTLabel (Maybe Module) !Unique
+  | SRTLabel !Unique
 
   -- | Label of an StgLargeSRT
   | LargeSRTLabel
@@ -355,8 +353,8 @@ data DynamicLinkerLabelInfo
 mkSlowEntryLabel :: Name -> CafInfo -> CLabel
 mkSlowEntryLabel        name c         = IdLabel name  c Slow
 
-mkModSRTLabel     :: Maybe Module -> Unique -> CLabel
-mkModSRTLabel mb_mod u = SRTLabel mb_mod u
+mkTopSRTLabel     :: Unique -> CLabel
+mkTopSRTLabel u = SRTLabel u
 
 mkSRTLabel        :: Name -> CafInfo -> CLabel
 mkRednCountsLabel :: Name -> CafInfo -> CLabel
@@ -592,7 +590,7 @@ needsCDecl :: CLabel -> Bool
   -- False <=> it's pre-declared; don't bother
   -- don't bother declaring Bitmap labels, we always make sure
   -- they are defined before use.
-needsCDecl (SRTLabel _ _)               = True
+needsCDecl (SRTLabel _)                 = True
 needsCDecl (LargeSRTLabel _)            = False
 needsCDecl (LargeBitmapLabel _)         = False
 needsCDecl (IdLabel _ _ _)              = True
@@ -740,7 +738,7 @@ externallyVisibleCLabel (CCS_Label _)           = True
 externallyVisibleCLabel (DynamicLinkerLabel _ _)  = False
 externallyVisibleCLabel (HpcTicksLabel _)       = True
 externallyVisibleCLabel (LargeBitmapLabel _)    = False
-externallyVisibleCLabel (SRTLabel mb_mod _)     = isJust mb_mod
+externallyVisibleCLabel (SRTLabel _)            = False
 externallyVisibleCLabel (LargeSRTLabel _)       = False
 externallyVisibleCLabel (PicBaseLabel {}) = panic "externallyVisibleCLabel PicBaseLabel"
 externallyVisibleCLabel (DeadStripPreventer {}) = panic "externallyVisibleCLabel DeadStripPreventer"
@@ -788,7 +786,7 @@ labelType (RtsLabel (RtsApFast _))              = CodeLabel
 labelType (CaseLabel _ CaseReturnInfo)          = DataLabel
 labelType (CaseLabel _ _)                       = CodeLabel
 labelType (PlainModuleInitLabel _)              = CodeLabel
-labelType (SRTLabel _ _)                        = DataLabel
+labelType (SRTLabel _)                          = DataLabel
 labelType (LargeSRTLabel _)                     = DataLabel
 labelType (LargeBitmapLabel _)                  = DataLabel
 labelType (ForeignLabel _ _ _ IsFunction)       = CodeLabel
@@ -991,10 +989,8 @@ pprCLbl (CaseLabel u (CaseAlt tag))
 pprCLbl (CaseLabel u CaseDefault)
   = hcat [pprUnique u, ptext (sLit "_dflt")]
 
-pprCLbl (SRTLabel mb_mod u)
-  = pp_mod <> pprUnique u <> pp_cSEP <> ptext (sLit "srt")
-  where pp_mod | Just mod <- mb_mod = ppr mod <> pp_cSEP
-               | otherwise          = empty
+pprCLbl (SRTLabel u)
+  = pprUnique u <> pp_cSEP <> ptext (sLit "srt")
 
 pprCLbl (LargeSRTLabel u)  = pprUnique u <> pp_cSEP <> ptext (sLit "srtd")
 pprCLbl (LargeBitmapLabel u)  = text "b" <> pprUnique u <> pp_cSEP <> ptext (sLit "btm")
diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs
index 54edb73..ecaab57 100644
--- a/compiler/cmm/CmmBuildInfoTables.hs
+++ b/compiler/cmm/CmmBuildInfoTables.hs
@@ -14,7 +14,7 @@
 {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
 module CmmBuildInfoTables
     ( CAFSet, CAFEnv, cafAnal
-    , doSRTs, TopSRT, emptySRT, srtToData )
+    , doSRTs, TopSRT, emptySRT, isEmptySRT, srtToData )
 where
 
 #include "HsVersions.h"
@@ -31,7 +31,6 @@ import CmmInfo
 import Data.List
 import DynFlags
 import Maybes
-import Module
 import Outputable
 import SMRep
 import UniqSupply
@@ -136,11 +135,14 @@ instance Outputable TopSRT where
                    <+> ppr elts
                    <+> ppr eltmap
 
-emptySRT :: MonadUnique m => Maybe Module -> m TopSRT
-emptySRT mb_mod =
-  do top_lbl <- getUniqueM >>= \ u -> return $ mkModSRTLabel mb_mod u
+emptySRT :: MonadUnique m => m TopSRT
+emptySRT =
+  do top_lbl <- getUniqueM >>= \ u -> return $ mkTopSRTLabel u
      return TopSRT { lbl = top_lbl, next_elt = 0, rev_elts = [], elt_map = Map.empty }
 
+isEmptySRT :: TopSRT -> Bool
+isEmptySRT srt = null (rev_elts srt)
+
 cafMember :: TopSRT -> CLabel -> Bool
 cafMember srt lbl = Map.member lbl (elt_map srt)
 
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 6f9745d..5c3fa0d 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -136,7 +136,6 @@ import Fingerprint      ( Fingerprint )
 
 import DynFlags
 import ErrUtils
-import UniqSupply       ( mkSplitUniqSupply )
 
 import Outputable
 import HscStats         ( ppSourceStats )
@@ -144,7 +143,7 @@ import HscTypes
 import MkExternalCore   ( emitExternalCore )
 import FastString
 import UniqFM           ( emptyUFM )
-import UniqSupply       ( initUs_ )
+import UniqSupply
 import Bag
 import Exception
 import qualified Stream
@@ -1399,17 +1398,33 @@ tryNewCodeGen hsc_env this_mod data_tycons
     -- We are building a single SRT for the entire module, so
     -- we must thread it through all the procedures as we cps-convert them.
     us <- mkSplitUniqSupply 'S'
-    let srt_mod | dopt Opt_SplitObjs dflags = Just this_mod
-                | otherwise                 = Nothing
-        initTopSRT = initUs_ us (emptySRT srt_mod)
 
-    let run_pipeline topSRT cmmgroup = do
-           (topSRT, cmmgroup) <- cmmPipeline hsc_env topSRT cmmgroup
-           return (topSRT,cmmOfZgraph cmmgroup)
-
-    let pipeline_stream = {-# SCC "cmmPipeline" #-} do
-          topSRT <- Stream.mapAccumL run_pipeline initTopSRT ppr_stream1
-          Stream.yield (cmmOfZgraph (srtToData topSRT))
+    -- When splitting, we generate one SRT per split chunk, otherwise
+    -- we generate one SRT for the whole module.
+    let
+     pipeline_stream
+      | dopt Opt_SplitObjs dflags
+        = {-# SCC "cmmPipeline" #-}
+          let run_pipeline us cmmgroup = do
+                let (topSRT', us') = initUs us emptySRT
+                (topSRT, cmmgroup) <- cmmPipeline hsc_env topSRT' cmmgroup
+                let srt | isEmptySRT topSRT = []
+                        | otherwise         = srtToData topSRT
+                return (us',cmmOfZgraph (srt ++ cmmgroup))
+
+          in do _ <- Stream.mapAccumL run_pipeline us ppr_stream1
+                return ()
+
+      | otherwise
+        = {-# SCC "cmmPipeline" #-}
+          let initTopSRT = initUs_ us emptySRT in
+  
+          let run_pipeline topSRT cmmgroup = do
+                (topSRT, cmmgroup) <- cmmPipeline hsc_env topSRT cmmgroup
+                return (topSRT,cmmOfZgraph cmmgroup)
+  
+          in do topSRT <- Stream.mapAccumL run_pipeline initTopSRT ppr_stream1
+                Stream.yield (cmmOfZgraph (srtToData topSRT))
 
     let
         dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" $ ppr a