X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FCmmProcPoint.hs;h=de8cfa378b3e5d6379e3317a485cd69b28dec3b9;hb=2bb3a439c106935d97fae7f7a0b60c21493d1bef;hp=15a723af527f42e3b134fd2f4f71933d2cd44f8b;hpb=1f46671fe24c7155ee64091b71b77dd66909e7a0;p=ghc-hetmet.git

diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs
index 15a723a..de8cfa3 100644
--- a/compiler/cmm/CmmProcPoint.hs
+++ b/compiler/cmm/CmmProcPoint.hs
@@ -4,39 +4,36 @@ module CmmProcPoint (
 
 #include "HsVersions.h"
 
-import Cmm
+import BlockId
 import CmmBrokenBlock
 import Dataflow
 
 import UniqSet
-import UniqFM
 import Panic
 
-calculateOwnership :: BlockEnv BrokenBlock -> UniqSet BlockId -> [BrokenBlock] -> BlockEnv (UniqSet BlockId)
-calculateOwnership blocks_ufm proc_points blocks =
-    fixedpoint dependants update (map brokenBlockId blocks) emptyUFM
-    where
-      dependants :: BlockId -> [BlockId]
-      dependants ident =
-          brokenBlockTargets $ lookupWithDefaultUFM
-                                 blocks_ufm unknown_block ident
-
-      update :: BlockId -> Maybe BlockId
-             -> BlockEnv (UniqSet BlockId) -> Maybe (BlockEnv (UniqSet BlockId))
-      update ident cause owners =
-          case (cause, ident `elementOfUniqSet` proc_points) of
-            (Nothing, True) -> Just $ addToUFM owners ident (unitUniqSet ident)
-            (Nothing, False) -> Nothing
-            (Just cause', True) -> Nothing
-            (Just cause', False) ->
-                if (sizeUniqSet old) == (sizeUniqSet new)
-                   then Nothing
-                   else Just $ addToUFM owners ident new
-                where
-                  old = lookupWithDefaultUFM owners emptyUniqSet ident
-                  new = old `unionUniqSets` lookupWithDefaultUFM owners emptyUniqSet cause'
-
-      unknown_block = panic "unknown BlockId in selectStackFormat"
+-- Determine the proc points for a set of basic blocks.
+--
+-- A proc point is any basic block that must start a new function.
+-- The entry block of the original function is a proc point.
+-- The continuation of a function call is also a proc point.
+-- The third kind of proc point arises when there is a joint point
+-- in the control flow.  Suppose we have code like the following:
+--
+--   if (...) { ...; call foo(); ...}
+--   else { ...; call bar(); ...}
+--   x = y;
+--
+-- That last statement "x = y" must be a proc point because
+-- it can be reached by blocks owned by different proc points
+-- (the two branches of the conditional).
+--
+-- We calculate these proc points by starting with the minimal set
+-- and finding blocks that are reachable from more proc points than
+-- one of their parents.  (This ensures we don't choose a block
+-- simply beause it is reachable from another block that is reachable
+-- from multiple proc points.)  These new blocks are added to the
+-- set of proc points and the process is repeated until there
+-- are no more proc points to be found.
 
 calculateProcPoints :: [BrokenBlock] -> UniqSet BlockId
 calculateProcPoints blocks =
@@ -48,7 +45,7 @@ calculateProcPoints blocks =
       always_proc_point BrokenBlock {
                               brokenBlockEntry = FunctionEntry _ _ _ } = True
       always_proc_point BrokenBlock {
-                              brokenBlockEntry = ContinuationEntry _ _ } = True
+                              brokenBlockEntry = ContinuationEntry _ _ _ } = True
       always_proc_point _ = False
 
 calculateProcPoints' :: UniqSet BlockId -> [BrokenBlock] -> UniqSet BlockId
@@ -61,20 +58,62 @@ calculateProcPoints' old_proc_points blocks =
       blocks_ufm = blocksToBlockEnv blocks
 
       owners = calculateOwnership blocks_ufm old_proc_points blocks
-      new_proc_points = unionManyUniqSets (old_proc_points:(map (calculateProcPoints'' owners) blocks))
+      new_proc_points =
+          unionManyUniqSets
+            (old_proc_points:
+             map (calculateNewProcPoints owners) blocks)
 
-calculateProcPoints'' :: BlockEnv (UniqSet BlockId) -> BrokenBlock -> UniqSet BlockId
-calculateProcPoints''  owners block =
-    unionManyUniqSets (map (f parent_id) child_ids)
+calculateNewProcPoints :: BlockEnv (UniqSet BlockId)
+                       -> BrokenBlock
+                       -> UniqSet BlockId
+calculateNewProcPoints  owners block =
+    unionManyUniqSets (map (maybe_proc_point parent_id) child_ids)
     where
       parent_id = brokenBlockId block
       child_ids = brokenBlockTargets block
-      -- TODO: name for f
-      f parent_id child_id = 
+      maybe_proc_point parent_id child_id =
           if needs_proc_point
             then unitUniqSet child_id
             else emptyUniqSet
           where
-            parent_owners = lookupWithDefaultUFM owners emptyUniqSet parent_id
-            child_owners = lookupWithDefaultUFM owners emptyUniqSet child_id
-            needs_proc_point = not $ isEmptyUniqSet $ child_owners `minusUniqSet` parent_owners
+            parent_owners = lookupWithDefaultBEnv owners emptyUniqSet parent_id
+            child_owners = lookupWithDefaultBEnv owners emptyUniqSet child_id
+            needs_proc_point =
+                -- only if parent isn't dead
+                (not $ isEmptyUniqSet parent_owners) &&
+                -- and only if child has more owners than parent
+                (not $ isEmptyUniqSet $
+                     child_owners `minusUniqSet` parent_owners)
+
+calculateOwnership :: BlockEnv BrokenBlock
+                   -> UniqSet BlockId
+                   -> [BrokenBlock]
+                   -> BlockEnv (UniqSet BlockId)
+calculateOwnership blocks_ufm proc_points blocks =
+    fixedpoint dependants update (map brokenBlockId blocks) emptyBlockEnv
+    where
+      dependants :: BlockId -> [BlockId]
+      dependants ident =
+          brokenBlockTargets $ lookupWithDefaultBEnv
+                                 blocks_ufm unknown_block ident
+
+      update :: BlockId
+             -> Maybe BlockId
+             -> BlockEnv (UniqSet BlockId)
+             -> Maybe (BlockEnv (UniqSet BlockId))
+      update ident cause owners =
+          case (cause, ident `elementOfUniqSet` proc_points) of
+            (Nothing, True) ->
+                Just $ extendBlockEnv owners ident (unitUniqSet ident)
+            (Nothing, False) -> Nothing
+            (Just _,      True) -> Nothing
+            (Just cause', False) ->
+                if (sizeUniqSet old) == (sizeUniqSet new)
+                   then Nothing
+                   else Just $ extendBlockEnv owners ident new
+                where
+                  old = lookupWithDefaultBEnv owners emptyUniqSet ident
+                  new = old `unionUniqSets`
+                        lookupWithDefaultBEnv owners emptyUniqSet cause'
+
+      unknown_block = panic "unknown BlockId in calculateOwnership"