minor changes to Cmm left over from September 2007

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

diff --git a/compiler/cmm/CmmProcPointZ.hs b/compiler/cmm/CmmProcPointZ.hs
index 279c730..fc6b726 100644 (file)
--- a/compiler/cmm/CmmProcPointZ.hs
+++ b/compiler/cmm/CmmProcPointZ.hs
@@ -1,4 +1,4 @@
-{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
+
 module CmmProcPointZ
     ( minimalProcPointSet
     , addProcPointProtocols
@@ -22,8 +22,8 @@ import Panic
 import UniqFM
 import UniqSet
 import ZipCfg
-import ZipCfgCmm 
-import ZipDataflow
+import ZipCfgCmmRep
+import ZipDataflow0
 
 -- Compute a minimal set of proc points for a control-flow graph.
 
@@ -116,13 +116,13 @@ forward = FComp "proc-point reachability" first middle last exit
     where first ProcPoint id = ReachedBy $ unitUniqSet id
           first  x _ = x
           middle x _ = x
-          last _ (LastCall _ _ (Just id)) = LastOutFacts [(id, ProcPoint)]
+          last _ (LastCall _ (Just id)) = LastOutFacts [(id, ProcPoint)]
           last x l = LastOutFacts $ map (\id -> (id, x)) (succs l)
-          exit _   = LastOutFacts []
+          exit x   = x
                 
 minimalProcPointSet :: CmmGraph -> ProcPointSet
 minimalProcPointSet g = extendPPSet g (postorder_dfs g) entryPoint
-    where entryPoint = unitUniqSet (gr_entry g)
+    where entryPoint = unitUniqSet (lg_entry g)
 
 extendPPSet :: CmmGraph -> [CmmBlock] -> ProcPointSet -> ProcPointSet
 extendPPSet g blocks procPoints =
@@ -132,7 +132,7 @@ extendPPSet g blocks procPoints =
                      Nothing -> procPoints'
     where env = runDFA lattice $
                 do refine_f_anal forward g set_init_points
-                   allFacts
+                   getAllFacts
           set_init_points = mapM_ (\id -> setFact id ProcPoint)
                             (uniqSetToList procPoints)
           procPoints' = fold_blocks add emptyBlockSet g
@@ -151,7 +151,7 @@ extendPPSet g blocks procPoints =
                   -- more proc points than b and is not already a proc
                   -- point.  If found, it can become a proc point.
                   newId succ_id = not (elemBlockSet succ_id procPoints') &&
-                                  nreached id > my_nreached 
+                                  nreached succ_id > my_nreached
               in  listToMaybe $ filter newId $ succs b
                                     
 
@@ -204,20 +204,20 @@ algorithm would be just as good, so that's what we do.
 
 -}
 
-data Protocol = Protocol Convention CmmHintFormals
+data Protocol = Protocol Convention CmmFormals
   deriving Eq
 
 -- | Function 'optimize_calls' chooses protocols only for those proc
 -- points that are relevant to the optimization explained above.
 -- The others are assigned by 'add_unassigned', which is not yet clever.
 
-addProcPointProtocols :: ProcPointSet -> CmmFormals -> CmmGraph -> CmmGraph
+addProcPointProtocols :: ProcPointSet -> CmmFormalsWithoutKinds -> CmmGraph -> CmmGraph
 addProcPointProtocols procPoints formals g =
        snd $ add_unassigned procPoints $ optimize_calls g
     where optimize_calls g =  -- see Note [Separate Adams optimization]
               let (protos, blocks') =
                       fold_blocks maybe_add_call (init_protocols, emptyBlockEnv) g
-                  g' = LGraph (gr_entry g) (add_CopyIns protos blocks')
+                  g' = LGraph (lg_entry g) (add_CopyIns protos blocks')
               in  (protos, runTx removeUnreachableBlocksZ g')
           maybe_add_call :: CmmBlock -> (BlockEnv Protocol, BlockEnv CmmBlock)
                          -> (BlockEnv Protocol, BlockEnv CmmBlock)
@@ -226,11 +226,11 @@ addProcPointProtocols procPoints formals g =
           -- redirect the call (cf 'newblock') and set the protocol if necessary
           maybe_add_call block (protos, blocks) =
               case goto_end $ unzip block of
-                (h, LastOther (LastCall tgt args (Just k)))
+                (h, LastOther (LastCall tgt (Just k)))
                     | Just proto <- lookupBlockEnv protos k,
                       Just pee <- jumpsToProcPoint k
                     -> let newblock =
-                               zipht h (tailOfLast (LastCall tgt args (Just pee)))
+                               zipht h (tailOfLast (LastCall tgt (Just pee)))
                            changed_blocks   = insertBlock newblock blocks
                            unchanged_blocks = insertBlock block    blocks
                        in case lookupBlockEnv protos pee of
@@ -243,20 +243,21 @@ addProcPointProtocols procPoints formals g =
           jumpsToProcPoint :: BlockId -> Maybe BlockId
           -- ^ Tells whether the named block is just a jump to a proc point
           jumpsToProcPoint id =
-              let (Block _ t) = lookupBlockEnv (gr_blocks g) id `orElse`
+              let (Block _ t) = lookupBlockEnv (lg_blocks g) id `orElse`
                                 panic "jump out of graph"
               in case t of
-                   ZTail (CopyOut {}) (ZLast (LastOther (LastBranch pee [])))
+                   ZTail (CopyIn {}) (ZLast (LastOther (LastBranch pee)))
                        | elemBlockSet pee procPoints -> Just pee
                    _ -> Nothing
           init_protocols = fold_blocks maybe_add_proto emptyBlockEnv g
           maybe_add_proto :: CmmBlock -> BlockEnv Protocol -> BlockEnv Protocol
           maybe_add_proto (Block id (ZTail (CopyIn c fs _srt) _)) env =
               extendBlockEnv env id (Protocol c fs)
-          maybe_add_proto (Block id _) env | id == gr_entry g =
-              extendBlockEnv env id (Protocol (Argument CmmCallConv) hinted_formals)
+          maybe_add_proto (Block id _) env | id == lg_entry g =
+              extendBlockEnv env id (Protocol stdArgConvention hinted_formals)
           maybe_add_proto _ env = env
-          hinted_formals = map (\x -> (x, NoHint)) formals
+          hinted_formals = map (\x -> CmmHinted x NoHint) formals
+          stdArgConvention = ConventionStandard CmmCallConv Arguments
 
 -- | For now, following a suggestion by Ben Lippmeier, we pass all
 -- live variables as arguments, hoping that a clever register
@@ -278,9 +279,9 @@ pass_live_vars_as_args procPoints (protos, g) = (protos', g')
               Nothing -> let live = lookupBlockEnv liveness id `orElse`
                                     emptyRegSet -- XXX there's a bug lurking!
                                     -- panic ("no liveness at block " ++ show id)
-                             formals = map (\x->(x,NoHint)) $ uniqSetToList live
-                         in  extendBlockEnv protos id (Protocol Local formals)
-        g' = g { gr_blocks = add_CopyIns protos' (gr_blocks g) }
+                             formals = map (\x -> CmmHinted x NoHint) $ uniqSetToList live
+                         in  extendBlockEnv protos id (Protocol ConventionPrivate formals)
+        g' = g { lg_blocks = add_CopyIns protos' (lg_blocks g) }
 
 
 -- | Add a CopyIn node to each block that has a protocol but lacks the