[commit: ghc] master: Avoid calling toInfoLbl on the entry label (#7313) (dc7a936)

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

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/dc7a9364e9bae25f6d70bad24bb0aa5708cbeaad

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

commit dc7a9364e9bae25f6d70bad24bb0aa5708cbeaad
Author: Simon Marlow <[email protected]>
Date:   Tue Oct 23 09:50:33 2012 +0100

    Avoid calling toInfoLbl on the entry label (#7313)

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

 compiler/cmm/CmmProcPoint.hs |   43 ++++++++++++++++++++++-------------------
 1 files changed, 23 insertions(+), 20 deletions(-)

diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs
index 19f0155..ddccf7b 100644
--- a/compiler/cmm/CmmProcPoint.hs
+++ b/compiler/cmm/CmmProcPoint.hs
@@ -234,9 +234,10 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
      --    the proc point is a callPP)
      -- Due to common blockification, we may overestimate the set of procpoints.
      let add_label map pp = mapInsert pp lbls map
-           where lbls | pp == entry = (entry_label, Just (toInfoLbl entry_label))
-                      | otherwise   = (blockLbl pp, guard (setMember pp callPPs) >> 
-                                                    Just (infoTblLbl pp))
+           where lbls | pp == entry = (entry_label, fmap cit_lbl (mapLookup entry info_tbls))
+                      | otherwise   = (block_lbl, guard (setMember pp callPPs) >>
+                                                    Just (toInfoLbl block_lbl))
+                      where block_lbl = blockLbl pp
 
          procLabels :: LabelMap (CLabel, Maybe CLabel)
          procLabels = foldl add_label mapEmpty
@@ -288,23 +289,25 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
 
      graphEnv <- foldM add_jumps emptyBlockMap $ mapToList graphEnv
 
-     let to_proc (bid, g) = case expectJust "pp label" $ mapLookup bid procLabels of
-             (lbl, Just info_lbl)
-               | bid == entry
-               -> CmmProc (TopInfo {info_tbls  = info_tbls,
-                                    stack_info = stack_info})
-                          top_l (replacePPIds g)
-               | otherwise
-               -> CmmProc (TopInfo {info_tbls = mapSingleton (g_entry g) (mkEmptyContInfoTable info_lbl), stack_info=stack_info})
-                          lbl (replacePPIds g)
-             (lbl, Nothing)
-               -> CmmProc (TopInfo {info_tbls = mapEmpty, stack_info=stack_info})
-                          lbl (replacePPIds g)
-            where
-             stack_info = StackInfo { arg_space = 0
-                                    , updfr_space =  Nothing
-                                    , do_layout = True }
-                          -- cannot use panic, this is printed by -ddump-cmmz
+     let to_proc (bid, g)
+             | bid == entry
+             =  CmmProc (TopInfo {info_tbls  = info_tbls,
+                                  stack_info = stack_info})
+                        top_l (replacePPIds g)
+             | otherwise
+             = case expectJust "pp label" $ mapLookup bid procLabels of
+                 (lbl, Just info_lbl)
+                    -> CmmProc (TopInfo { info_tbls = mapSingleton (g_entry g) (mkEmptyContInfoTable info_lbl)
+                                        , stack_info=stack_info})
+                               lbl (replacePPIds g)
+                 (lbl, Nothing)
+                    -> CmmProc (TopInfo {info_tbls = mapEmpty, stack_info=stack_info})
+                               lbl (replacePPIds g)
+                where
+                 stack_info = StackInfo { arg_space = 0
+                                        , updfr_space =  Nothing
+                                        , do_layout = True }
+                               -- cannot use panic, this is printed by -ddump-cmmz
 
          -- References to procpoint IDs can now be replaced with the
          -- infotable's label