Minor documentation fixes.

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

diff --git a/compiler/cmm/CmmProcPointZ.hs b/compiler/cmm/CmmProcPointZ.hs
index 5ec65c5..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

@@ -329,7 +326,7 @@ add_CopyIns callPPs protos blocks =
            = case lookupBlockEnv protos id of
                Just (Protocol c fs _area) ->
                  do LGraph _ 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]
                     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
                     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
                     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 
      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)