remove -XNoMonomorphismRestriction

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

diff --git a/compiler/cmm/CmmProcPointZ.hs b/compiler/cmm/CmmProcPointZ.hs
index 60d6ce1..c972ad5 100644 (file)
--- a/compiler/cmm/CmmProcPointZ.hs
+++ b/compiler/cmm/CmmProcPointZ.hs
@@ -5,32 +5,30 @@ 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 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 ZipCfgCmmRep
 import ZipDataflow
 
 import UniqSet
 import UniqSupply
 import ZipCfg
 import ZipCfgCmmRep
 import ZipDataflow
 

+import qualified Data.Map as Map
+

 -- Compute a minimal set of proc points for a control-flow graph.
 
 -- Determine a protocol for each proc point (which live variables will
 -- Compute a minimal set of proc points for a control-flow graph.
 
 -- Determine a protocol for each proc point (which live variables will

@@ -130,18 +128,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)

@@ -399,9 +400,9 @@ splitAtProcPoints entry_label callPPs procPoints procMap
      graphEnv <- return $ fold_blocks addBlock emptyBlockEnv g
      -- Build a map from proc point BlockId to labels for their new procedures
      -- Due to common blockification, we may overestimate the set of procpoints.
      graphEnv <- return $ fold_blocks addBlock emptyBlockEnv g
      -- Build a map from proc point BlockId to labels for their new procedures
      -- Due to common blockification, we may overestimate the set of procpoints.

-     let add_label map pp = return $ addToFM map pp lbl
+     let add_label map pp = return $ Map.insert pp lbl map

            where lbl = if pp == entry then entry_label else blockLbl pp
            where lbl = if pp == entry then entry_label else blockLbl pp

-     procLabels <- foldM add_label emptyFM
+     procLabels <- foldM add_label Map.empty

                          (filter (elemBlockEnv blocks) (blockSetToList procPoints))
      -- For each procpoint, we need to know the SP offset on entry.
      -- If the procpoint is:
                          (filter (elemBlockEnv blocks) (blockSetToList procPoints))
      -- For each procpoint, we need to know the SP offset on entry.
      -- If the procpoint is:

@@ -434,7 +435,7 @@ splitAtProcPoints entry_label callPPs procPoints procMap
                         add_if_pp ti (add_if_pp fi rst)
                       LastOther (LastSwitch _ tbl) -> foldr add_if_pp rst (catMaybes tbl)
                       _ -> rst
                         add_if_pp ti (add_if_pp fi rst)
                       LastOther (LastSwitch _ tbl) -> foldr add_if_pp rst (catMaybes tbl)
                       _ -> rst

-                  add_if_pp id rst = case lookupFM procLabels id of
+                  add_if_pp id rst = case Map.lookup id procLabels of

                                        Just x -> (id, x) : rst
                                        Nothing -> rst
               (jumpEnv, jumpBlocks) <-
                                        Just x -> (id, x) : rst
                                        Nothing -> rst
               (jumpEnv, jumpBlocks) <-

@@ -453,13 +454,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
-           where lbl = expectJust "pp label" $ lookupFM procLabels bid
+             CmmProc emptyContInfoTable lbl [] (replacePPIds g)
+           where lbl = expectJust "pp label" $ Map.lookup bid procLabels

          to_proc (bid, g) =
          to_proc (bid, g) =

-           CmmProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] g
-             where lbl = expectJust "pp label" $ lookupFM procLabels bid
+           CmmProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] (replacePPIds g)
+             where lbl = expectJust "pp label" $ Map.lookup bid procLabels
+         -- 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 Map.lookup bid procLabels 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)