Comment and formatting updates for the CPS pass

compiler/cmm/CmmBrokenBlock.hs

@@ -19,6 +19,11 @@ import Panic
 import Unique
 import UniqFM
 
+-- This module takes a 'CmmBasicBlock' which might have 'CmmCall'
+-- statements in it with 'CmmSafe' set and breaks it up at each such call.
+-- It also collects information about the block for later use
+-- by the CPS algorithm.
+
 -----------------------------------------------------------------------------
 -- Data structures
 -----------------------------------------------------------------------------
@@ -110,6 +115,8 @@ breakBlock uniques (BasicBlock ident stmts) entry =
       breakBlock' uniques current_id entry exits accum_stmts stmts =
           case stmts of
             [] -> panic "block doesn't end in jump, goto, return or switch"
+
+            -- Last statement.  Make the 'BrokenBlock'
             [CmmJump target arguments] ->
                 [BrokenBlock current_id entry accum_stmts
                              exits
@@ -126,6 +133,9 @@ breakBlock uniques (BasicBlock ident stmts) entry =
                 [BrokenBlock current_id entry accum_stmts
                              (mapMaybe id targets ++ exits)
                              (FinalSwitch expr targets)]
+
+            -- These shouldn't happen in the middle of a block.
+            -- They would cause dead code.
             (CmmJump _ _:_) -> panic "jump in middle of block"
             (CmmReturn _:_) -> panic "return in middle of block"
             (CmmBranch _:_) -> panic "branch in middle of block"
@@ -140,6 +150,8 @@ breakBlock uniques (BasicBlock ident stmts) entry =
                 block = do_call current_id entry accum_stmts exits next_id
                                 target results arguments
              -}
+
+            -- Break the block on safe calls (the main job of this function)
             (CmmCall target results arguments (CmmSafe srt):stmts) ->
                 block : rest
                 where
@@ -149,6 +161,9 @@ breakBlock uniques (BasicBlock ident stmts) entry =
                   rest = breakBlock' (tail uniques) next_id
                                      (ContinuationEntry (map fst results) srt)
                                      [] [] stmts
+
+            -- Default case.  Just keep accumulating statements
+            -- and branch targets.
             (s:stmts) ->
                 breakBlock' uniques current_id entry
                             (cond_branch_target s++exits)

compiler/cmm/CmmCPS.hs

@@ -157,7 +157,9 @@ cpsProc uniqSupply (CmmProc info ident params blocks) = info_procs
       --
       -- This is an association list instead of a UniqFM because
       -- CLabel's don't have a 'Uniqueable' instance.
-      formats :: [(CLabel, (Maybe CLabel, [Maybe LocalReg]))]
+      formats :: [(CLabel,              -- key
+                   (Maybe CLabel,       -- label in top slot
+                    [Maybe LocalReg]))] -- slots
       formats = selectStackFormat live continuations
 
       -- Do a little meta-processing on the stack formats such as
@@ -203,7 +205,7 @@ cpsProc uniqSupply (CmmProc info ident params blocks) = info_procs
 continuationLabel (Continuation _ l _ _) = l
 data Continuation info =
   Continuation
-     info --(Either C_SRT CmmInfo)   -- Left <=> Continuation created by the CPS
+     info              -- Left <=> Continuation created by the CPS
                        -- Right <=> Function or Proc point
      CLabel            -- Used to generate both info & entry labels
      CmmFormals        -- Argument locals live on entry (C-- procedure params)
@@ -361,7 +363,7 @@ applyStackFormat formats (Continuation (Left srt) label formals blocks) =
       -- TODO prof: this is the same as the current implementation
       -- but I think it could be improved
       prof = ProfilingInfo zeroCLit zeroCLit
-      tag = rET_SMALL -- cmmToRawCmm will convert this to rET_BIG if needed
+      tag = rET_SMALL -- cmmToRawCmm may convert it to rET_BIG
       format = maybe unknown_block id $ lookup label formats
       unknown_block = panic "unknown BlockId in applyStackFormat"
 

compiler/cmm/CmmCallConv.hs

 module CmmCallConv (
   ParamLocation(..),
   ArgumentFormat,
-  assignRegs,
   assignArguments,
 ) where
 
@@ -15,26 +14,35 @@ import Constants
 import StaticFlags (opt_Unregisterised)
 import Panic
 
+-- Calculate the 'GlobalReg' or stack locations for function call
+-- parameters as used by the Cmm calling convention.
+
 data ParamLocation
   = RegisterParam GlobalReg
   | StackParam WordOff
 
-assignRegs :: [LocalReg] -> ArgumentFormat LocalReg
-assignRegs regs = assignRegs' regs 0 availRegs
-    where
-      assignRegs' (r:rs) offset availRegs = (r,assignment):assignRegs' rs new_offset remaining
-          where 
-            (assignment, new_offset, remaining) = assign_reg (localRegRep r) offset availRegs
+type ArgumentFormat a = [(a, ParamLocation)]
 
 assignArguments :: (a -> MachRep) -> [a] -> ArgumentFormat a
 assignArguments f reps = assignArguments' reps 0 availRegs
     where
       assignArguments' [] offset availRegs = []
-      assignArguments' (r:rs) offset availRegs = (r,assignment):assignArguments' rs new_offset remaining
+      assignArguments' (r:rs) offset availRegs =
+          (r,assignment):assignArguments' rs new_offset remaining
           where 
-            (assignment, new_offset, remaining) = assign_reg (f r) offset availRegs
+            (assignment, new_offset, remaining) =
+                assign_reg (f r) offset availRegs
 
-type ArgumentFormat a = [(a, ParamLocation)]
+argumentsSize :: (a -> MachRep) -> [a] -> WordOff
+argumentsSize f reps = maximum (0 : map arg_top args)
+    where
+      args = assignArguments f reps
+
+      arg_top (a, StackParam offset) = -offset
+      arg_top (_, RegisterParam _) = 0
+
+-----------------------------------------------------------------------------
+-- Local information about the registers available
 
 type AvailRegs = ( [GlobalReg]   -- available vanilla regs.
 		 , [GlobalReg]   -- floats
@@ -65,7 +73,8 @@ availRegs = (regList VanillaReg useVanillaRegs,
       regList f max = map f [1 .. max]
 
 slot_size :: LocalReg -> Int
-slot_size reg = ((machRepByteWidth (localRegRep reg) - 1) `div` wORD_SIZE) + 1
+slot_size reg =
+    ((machRepByteWidth (localRegRep reg) - 1) `div` wORD_SIZE) + 1
 
 slot_size' :: MachRep -> Int
 slot_size' reg = ((machRepByteWidth reg - 1) `div` wORD_SIZE) + 1

compiler/cmm/CmmProcPoint.hs

@@ -12,31 +12,29 @@ 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 =
@@ -61,20 +59,58 @@ 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
+            needs_proc_point = 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) 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"