X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FCmmProcPointZ.hs;h=c34f041bedd3125b20a4d821e1cb76d6291412cd;hb=8a9eb3cd35117c62ac9758d118c6f4109b7330cb;hp=5ec65c5d0b1a1b7dbc2113fe1a863f082fc17a85;hpb=31a9d04804d9cacda35695c5397590516b964964;p=ghc-hetmet.git

diff --git a/compiler/cmm/CmmProcPointZ.hs b/compiler/cmm/CmmProcPointZ.hs
index 5ec65c5..c34f041 100644
--- a/compiler/cmm/CmmProcPointZ.hs
+++ b/compiler/cmm/CmmProcPointZ.hs
@@ -5,26 +5,23 @@ module CmmProcPointZ
     )
 where
 
-import qualified Prelude as P
 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 List (sortBy)
+import Data.List (sortBy)
 import Maybes
 import MkZipCfg
 import MkZipCfgCmm hiding (CmmBlock, CmmGraph, CmmTopZ)
-import Monad
+import Control.Monad
 import Outputable
-import Panic
 import UniqSet
 import UniqSupply
 import ZipCfg
@@ -329,7 +326,7 @@ add_CopyIns callPPs protos blocks =
            = case lookupBlockEnv protos id of
                Just (Protocol c fs _area) ->
                  do LGraph _ blocks <-
-                      lgraphOfAGraph (mkLabel id <*> copyInSlot c False fs <*> mkZTail t)
+                      lgraphOfAGraph (mkLabel id <*> copyInSlot c fs <*> mkZTail t)
                     return (map snd $ blockEnvToList blocks)
                Nothing -> return [b]
            | otherwise = return [b]
@@ -356,8 +353,7 @@ add_CopyOuts protos procPoints g = fold_blocks mb_copy_out (return emptyBlockEnv
                     if elemBlockSet succId procPoints then
                       case lookupBlockEnv protos succId of
                         Nothing -> z
-                        Just (Protocol c fs _area) ->
-                          insert z succId $ copyOutSlot c Jump fs
+                        Just (Protocol c fs _area) -> insert z succId $ copyOutSlot c fs
                     else z
                   insert z succId m =
                     do (b, bmap) <- z
@@ -454,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 
-             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
-             CmmProc emptyContInfoTable lbl [] g
+             CmmProc emptyContInfoTable lbl [] (replacePPIds 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
+         -- 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)