Add cmm-notes, describing Simon and John's work on Cmm pipeline

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

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

@@ -130,18 +127,21 @@ forward = ForwardTransfers first middle last exit
 -- those that are induced by calls in the original graph
 -- and those that are introduced because they're reachable from multiple proc points.
 callProcPoints      :: CmmGraph -> ProcPointSet
 -- those that are induced by calls in the original graph
 -- and those that are introduced because they're reachable from multiple proc points.
 callProcPoints      :: CmmGraph -> ProcPointSet

-minimalProcPointSet :: ProcPointSet -> CmmGraph -> FuelMonad ProcPointSet
-

 callProcPoints g = fold_blocks add (unitBlockSet (lg_entry g)) g
   where add b set = case last $ unzip b of
                       LastOther (LastCall _ (Just k) _ _ _) -> extendBlockSet set k
                       _ -> set
 
 callProcPoints g = fold_blocks add (unitBlockSet (lg_entry g)) g
   where add b set = case last $ unzip b of
                       LastOther (LastCall _ (Just k) _ _ _) -> extendBlockSet set k
                       _ -> set
 

+minimalProcPointSet :: ProcPointSet -> CmmGraph -> FuelMonad ProcPointSet
+-- Given the set of successors of calls (which must be proc-points)
+-- figure ou the minimal set of necessary proc-points

 minimalProcPointSet callProcPoints g = extendPPSet g (postorder_dfs g) callProcPoints
 
 type PPFix = FuelMonad (ForwardFixedPoint Middle Last Status ())
 
 procPointAnalysis :: ProcPointSet -> CmmGraph -> FuelMonad (BlockEnv Status)
 minimalProcPointSet callProcPoints g = extendPPSet g (postorder_dfs g) callProcPoints
 
 type PPFix = FuelMonad (ForwardFixedPoint Middle Last Status ())
 
 procPointAnalysis :: ProcPointSet -> CmmGraph -> FuelMonad (BlockEnv Status)

+-- Once you know what the proc-points are, figure out
+-- what proc-points each block is reachable from

 procPointAnalysis procPoints g =
   let addPP env id = extendBlockEnv env id ProcPoint
       initProcPoints = foldl addPP emptyBlockEnv (blockSetToList procPoints)
 procPointAnalysis procPoints g =
   let addPP env id = extendBlockEnv env id ProcPoint
       initProcPoints = foldl addPP emptyBlockEnv (blockSetToList procPoints)

@@ -329,7 +329,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 +356,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 +453,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)