Minor documentation fixes.

[ghc-hetmet.git] / compiler / cmm / CmmProcPointZ.hs

diff --git a/compiler/cmm/CmmProcPointZ.hs b/compiler/cmm/CmmProcPointZ.hs
index 60d6ce1..c34f041 100644 (file)
--- a/compiler/cmm/CmmProcPointZ.hs
+++ b/compiler/cmm/CmmProcPointZ.hs
@@ -5,26 +5,23 @@ module CmmProcPointZ
     )
 where
 
     )
 where
 

-import qualified Prelude as P

 import Prelude hiding (zip, unzip, last)
 
 import BlockId
 import CLabel
 import Cmm hiding (blockId)
 import CmmContFlowOpt
 import Prelude hiding (zip, unzip, last)
 
 import BlockId
 import CLabel
 import Cmm hiding (blockId)
 import CmmContFlowOpt

-import CmmExpr

 import CmmInfo
 import CmmLiveZ
 import CmmTx
 import DFMonad
 import FiniteMap
 import CmmInfo
 import CmmLiveZ
 import CmmTx
 import DFMonad
 import FiniteMap

-import List (sortBy)
+import Data.List (sortBy)

 import Maybes
 import MkZipCfg
 import MkZipCfgCmm hiding (CmmBlock, CmmGraph, CmmTopZ)
 import Maybes
 import MkZipCfg
 import MkZipCfgCmm hiding (CmmBlock, CmmGraph, CmmTopZ)

-import Monad
+import Control.Monad

 import Outputable
 import Outputable

-import Panic

 import UniqSet
 import UniqSupply
 import ZipCfg
 import UniqSet
 import UniqSupply
 import ZipCfg

@@ -453,13 +450,20 @@ splitAtProcPoints entry_label callPPs procPoints procMap
      graphEnv <- foldM add_jumps emptyBlockEnv $ blockEnvToList graphEnv
      let to_proc (bid, g) | elemBlockSet bid callPPs =
            if bid == entry then 
      graphEnv <- foldM add_jumps emptyBlockEnv $ blockEnvToList graphEnv
      let to_proc (bid, g) | elemBlockSet bid callPPs =
            if bid == entry then 

-             CmmProc (CmmInfo gc upd_fr info_tbl) top_l top_args g
+             CmmProc (CmmInfo gc upd_fr info_tbl) top_l top_args (replacePPIds g)

            else
            else

-             CmmProc emptyContInfoTable lbl [] g
+             CmmProc emptyContInfoTable lbl [] (replacePPIds g)

            where lbl = expectJust "pp label" $ lookupFM procLabels bid
          to_proc (bid, g) =
            where lbl = expectJust "pp label" $ lookupFM procLabels bid
          to_proc (bid, g) =

-           CmmProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] g
+           CmmProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] (replacePPIds g)

              where lbl = expectJust "pp label" $ lookupFM procLabels bid
              where lbl = expectJust "pp label" $ lookupFM procLabels bid

+         -- References to procpoint IDs can now be replaced with the infotable's label
+         replacePPIds (x, g) = (x, map_nodes id (mapExpMiddle repl) (mapExpLast repl) g)
+           where repl e@(CmmLit (CmmBlock bid)) =
+                   case lookupFM procLabels bid of
+                     Just l  -> CmmLit (CmmLabel (entryLblToInfoLbl l))
+                     Nothing -> e
+                 repl e = e

      -- The C back end expects to see return continuations before the call sites.
      -- Here, we sort them in reverse order -- it gets reversed later.
      let (_, block_order) = foldl add_block_num (0::Int, emptyBlockEnv) (postorder_dfs g)
      -- The C back end expects to see return continuations before the call sites.
      -- Here, we sort them in reverse order -- it gets reversed later.
      let (_, block_order) = foldl add_block_num (0::Int, emptyBlockEnv) (postorder_dfs g)