Formatting changes for CPS code.

2 files changed, 138 insertions, 194 deletions

diff --git a/compiler/cmm/CmmCPS.hs b/compiler/cmm/CmmCPS.hs
index b00a50fb06..0fe63a740e 100644
--- a/compiler/cmm/CmmCPS.hs
+++ b/compiler/cmm/CmmCPS.hs
@@ -34,6 +34,90 @@ import Monad
 import IO
 import Data.List
 
+-----------------------------------------------------------------------------
+-- |Top level driver for the CPS pass
+-----------------------------------------------------------------------------
+cmmCPS :: DynFlags -- ^ Dynamic flags: -dcmm-lint -ddump-cps-cmm
+       -> [Cmm]    -- ^ Input C-- with Proceedures
+       -> IO [Cmm] -- ^ Output CPS transformed C--
+cmmCPS dflags abstractC = do
+  when (dopt Opt_DoCmmLinting dflags) $
+       do showPass dflags "CmmLint"
+	  case firstJust $ map cmmLint abstractC of
+	    Just err -> do printDump err
+			   ghcExit dflags 1
+	    Nothing  -> return ()
+  showPass dflags "CPS"
+
+  -- TODO: more lint checking
+  --        check for use of branches to non-existant blocks
+  --        check for use of Sp, SpLim, R1, R2, etc.
+
+  uniqSupply <- mkSplitUniqSupply 'p'
+  let supplies = listSplitUniqSupply uniqSupply
+  let doCpsProc s (Cmm c) =
+          Cmm $ concat $ zipWith cpsProc (listSplitUniqSupply s) c
+  let continuationC = zipWith doCpsProc supplies abstractC
+
+  dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (pprCmms continuationC)
+
+  -- TODO: add option to dump Cmm to file
+
+  return continuationC
+
+-----------------------------------------------------------------------------
+-- |CPS a single CmmTop (proceedure)
+-- Only 'CmmProc' are transformed 'CmmData' will be left alone.
+-----------------------------------------------------------------------------
+
+cpsProc :: UniqSupply 
+        -> CmmTop     -- ^Input proceedure
+        -> [CmmTop]   -- ^Output proceedure and continuations
+cpsProc uniqSupply x@(CmmData _ _) = [x]
+cpsProc uniqSupply x@(CmmProc info_table ident params blocks) = cps_procs
+    where
+      uniqes :: [[Unique]]
+      uniqes = map uniqsFromSupply $ listSplitUniqSupply uniqSupply
+
+      -- Break the block at each function call.
+      -- The part after the function call will have to become a continuation.
+      broken_blocks :: [BrokenBlock]
+      broken_blocks =
+          concat $ zipWith3 breakBlock uniqes blocks
+                     (FunctionEntry ident params:repeat ControlEntry)
+
+      -- Calculate live variables for each broken block.
+      --
+      -- Nothing can be live on entry to the first block
+      -- so we could take the tail, but for now we wont
+      -- to help future proof the code.
+      live :: BlockEntryLiveness
+      live = cmmLiveness $ map cmmBlockFromBrokenBlock broken_blocks
+
+      -- Calculate which blocks must be made into full fledged procedures.
+      proc_points :: UniqSet BlockId
+      proc_points = calculateProcPoints broken_blocks
+
+      -- Construct a map so we can lookup a broken block by its 'BlockId'.
+      block_env :: BlockEnv BrokenBlock
+      block_env = blocksToBlockEnv broken_blocks
+
+      -- Group the blocks into continuations based on the set of proc-points.
+      continuations :: [Continuation]
+      continuations = map (gatherBlocksIntoContinuation proc_points block_env)
+                          (uniqSetToList proc_points)
+
+      -- Select the stack format on entry to each continuation.
+      --
+      -- This is an association list instead of a UniqFM because
+      -- CLabel's don't have a 'Uniqueable' instance.
+      formats :: [(CLabel, StackFormat)]
+      formats = selectStackFormat live continuations
+
+      -- Do the actual CPS transform.
+      cps_procs :: [CmmTop]
+      cps_procs = map (continuationToProc formats) continuations
+
 --------------------------------------------------------------------------------
 
 -- The format for the call to a continuation
@@ -97,10 +181,15 @@ collectNonProcPointTargets proc_points blocks current_targets block =
         -- TODO: remove redundant uniqSetToList
       new_targets = current_targets `unionUniqSets` (mkUniqSet targets)
 
-procPointToContinuation ::
+-- TODO: insert proc point code here
+--  * Branches and switches to proc points may cause new blocks to be created
+--    (or proc points could leave behind phantom blocks that just jump to them)
+--  * Proc points might get some live variables passed as arguments
+
+gatherBlocksIntoContinuation ::
     UniqSet BlockId -> BlockEnv BrokenBlock
     -> BlockId -> Continuation
-procPointToContinuation proc_points blocks start =
+gatherBlocksIntoContinuation proc_points blocks start =
   Continuation is_entry info_table clabel params body
     where
       children = (collectNonProcPointTargets proc_points blocks (unitUniqSet start) start) `delOneFromUniqSet` start
@@ -251,144 +340,3 @@ unpack_continuation (StackFormat curr_id curr_frame_size curr_offsets)
          (CmmLoad (CmmRegOff spReg (wORD_SIZE*offset)) (cmmRegRep reg))
          | (reg, offset) <- curr_offsets]
 
------------------------------------------------------------------------------
--- Breaking basic blocks on function calls
------------------------------------------------------------------------------
-
------------------------------------------------------------------------------
--- Takes a basic block and breaks it up into a list of broken blocks
---
--- Takes a basic block and returns a list of basic blocks that
--- each have at most 1 CmmCall in them which must occur at the end.
--- Also returns with each basic block, the variables that will
--- be arguments to the continuation of the block once the call (if any)
--- returns.
-
-breakBlock :: [Unique] -> CmmBasicBlock -> BlockEntryInfo -> [BrokenBlock]
-breakBlock uniques (BasicBlock ident stmts) entry =
-    breakBlock' uniques ident entry [] [] stmts where
-        breakBlock' uniques current_id entry exits accum_stmts stmts =
-            case stmts of
-              [] -> panic "block doesn't end in jump, goto or return"
-              [CmmJump target arguments] ->
-                  [BrokenBlock current_id entry accum_stmts
-                               exits
-                               (FinalJump target arguments)]
-              [CmmReturn arguments] ->
-                  [BrokenBlock current_id entry accum_stmts
-                               exits
-                               (FinalReturn arguments)]
-              [CmmBranch target] ->
-                  [BrokenBlock current_id entry accum_stmts
-                               (target:exits)
-                               (FinalBranch target)]
-              [CmmSwitch expr targets] ->
-                  [BrokenBlock current_id entry accum_stmts
-                               (mapMaybe id targets ++ exits)
-                               (FinalSwitch expr targets)]
-              (CmmJump _ _:_) ->
-                  panic "jump in middle of block"
-              (CmmReturn _:_) ->
-                  panic "return in middle of block"
-              (CmmBranch _:_) ->
-                  panic "branch in middle of block"
-              (CmmSwitch _ _:_) ->
-                  panic ("switch in middle of block" ++ (showSDoc $ ppr stmts))
-              (CmmCall target results arguments saves:stmts) -> block : rest
-                  where
-                    new_id = BlockId $ head uniques
-                    block = BrokenBlock current_id entry accum_stmts
-                            (new_id:exits)
-                            (FinalCall new_id target results arguments saves)
-                    rest = breakBlock' (tail uniques) new_id
-                           (ContinuationEntry results) [] [] stmts
-              (s@(CmmCondBranch test target):stmts) ->
-                  breakBlock' uniques current_id entry
-                              (target:exits) (accum_stmts++[s]) stmts
-              (s:stmts) ->
-                  breakBlock' uniques current_id entry
-                              exits (accum_stmts++[s]) stmts
-
---------------------------------
--- Convert from a BrokenBlock
--- to a CmmBasicBlock so the
--- liveness analysis can run
--- on it.
---------------------------------
-cmmBlockFromBrokenBlock :: BrokenBlock -> CmmBasicBlock
-cmmBlockFromBrokenBlock (BrokenBlock ident _ stmts _ exit) =
-    BasicBlock ident (stmts++exit_stmt)
-    where
-      exit_stmt =
-          case exit of
-            FinalBranch target -> [CmmBranch target]
-            FinalReturn arguments -> [CmmReturn arguments]
-            FinalJump target arguments -> [CmmJump target arguments]
-            FinalSwitch expr targets -> [CmmSwitch expr targets]
-            FinalCall branch_target call_target results arguments saves ->
-                [CmmCall call_target results arguments saves,
-                 CmmBranch branch_target]
-
------------------------------------------------------------------------------
--- CPS a single CmmTop (proceedure)
------------------------------------------------------------------------------
-
-cpsProc :: UniqSupply -> CmmTop -> [CmmTop]
-cpsProc uniqSupply x@(CmmData _ _) = [x]
-cpsProc uniqSupply x@(CmmProc info_table ident params blocks) = cps_procs
-    where
-      uniqes :: [[Unique]]
-      uniqes = map uniqsFromSupply $ listSplitUniqSupply uniqSupply
-
-      -- Break the block at each function call
-      broken_blocks :: [BrokenBlock]
-      broken_blocks = concat $ zipWith3 breakBlock uniqes blocks
-                                        (FunctionEntry ident params:repeat ControlEntry)
-
-      -- Calculate live variables for each broken block
-      live :: BlockEntryLiveness
-      live = cmmLiveness $ map cmmBlockFromBrokenBlock broken_blocks
-             -- nothing can be live on entry to the first block so we could take the tail
-
-      proc_points :: UniqSet BlockId
-      proc_points = calculateProcPoints broken_blocks
-
-      -- TODO: insert proc point code here
-      --  * Branches and switches to proc points may cause new blocks to be created
-      --    (or proc points could leave behind phantom blocks that just jump to them)
-      --  * Proc points might get some live variables passed as arguments
-
-      continuations :: [Continuation]
-      continuations = map (procPointToContinuation proc_points (blocksToBlockEnv broken_blocks)) (uniqSetToList proc_points)
-
-      -- Select the stack format on entry to each block
-      formats :: [(CLabel, StackFormat)]
-      formats = selectStackFormat live continuations
-
-      -- Do the actual CPS transform
-      cps_procs :: [CmmTop]
-      cps_procs = map (continuationToProc formats) continuations
-
---------------------------------------------------------------------------------
-cmmCPS :: DynFlags
-       -> [Cmm]                 -- C-- with Proceedures
-       -> IO [Cmm]		-- Output: CPS transformed C--
-
-cmmCPS dflags abstractC = do
-  when (dopt Opt_DoCmmLinting dflags) $
-       do showPass dflags "CmmLint"
-	  case firstJust $ map cmmLint abstractC of
-	    Just err -> do printDump err
-			   ghcExit dflags 1
-	    Nothing  -> return ()
-  showPass dflags "CPS"
-  -- TODO: check for use of branches to non-existant blocks
-  -- TODO: check for use of Sp, SpLim, R1, R2, etc.
-  -- TODO: find out if it is valid to create a new unique source like this
-  uniqSupply <- mkSplitUniqSupply 'p'
-  let supplies = listSplitUniqSupply uniqSupply
-  let continuationC = zipWith (\s (Cmm c) -> Cmm $ concat $ zipWith (cpsProc) (listSplitUniqSupply s) c) supplies abstractC
-
-  dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (pprCmms continuationC)
-  -- TODO: add option to dump Cmm to file
-  return continuationC
diff --git a/compiler/cmm/CmmLive.hs b/compiler/cmm/CmmLive.hs
index 8d13505d36..8591aae117 100644
--- a/compiler/cmm/CmmLive.hs
+++ b/compiler/cmm/CmmLive.hs
@@ -1,7 +1,8 @@
 module CmmLive (
-        CmmLive, BlockEntryLiveness,
+        CmmLive,
+        BlockEntryLiveness,
         cmmLiveness,
-        cmmFormalsToLiveLocals
+        cmmFormalsToLiveLocals,
   ) where
 
 #include "HsVersions.h"
@@ -14,20 +15,24 @@ import Panic
 import UniqFM
 import UniqSet
 
-import Data.List
-
 -----------------------------------------------------------------------------
 -- Calculating what variables are live on entry to a basic block
 -----------------------------------------------------------------------------
 
--- The variables live on entry to a block
+-- | The variables live on entry to a block
 type CmmLive = UniqSet LocalReg
 
--- A mapping from block labels to the variables live on entry
+-- | A mapping from block labels to the variables live on entry
 type BlockEntryLiveness = BlockEnv CmmLive
 
+-- | A mapping from block labels to the blocks that target it
+type BlockSources = BlockEnv (UniqSet BlockId)
+
+-- | A mapping from block labels to the statements in the block
+type BlockStmts = BlockEnv [CmmStmt]
+
 -----------------------------------------------------------------------------
--- cmmLiveness and helpers
+-- | Calculated liveness info for a list of 'CmmBasicBlock'
 -----------------------------------------------------------------------------
 cmmLiveness :: [CmmBasicBlock] -> BlockEntryLiveness
 cmmLiveness blocks =
@@ -36,8 +41,14 @@ cmmLiveness blocks =
                (map blockId blocks)
                (listToUFM [(blockId b, emptyUniqSet) | b <- blocks])
     where
+      sources :: BlockSources
       sources = cmmBlockSources blocks
-      blocks' = cmmBlockNames blocks
+
+      blocks' :: BlockStmts
+      blocks' = listToUFM $ map block_name blocks
+
+      block_name :: CmmBasicBlock -> (BlockId, [CmmStmt])
+      block_name b = (blockId b, blockStmts b)
 
 {-
 -- For debugging, annotate each block with a comment indicating
@@ -51,27 +62,24 @@ cmmLivenessComment live (BasicBlock ident stmts) =
 -}
 
 
---------------------------------
--- cmmBlockSources
---
--- Calculates a table of blocks
--- that might need updating after
--- a given block is updated
---------------------------------
-cmmBlockSources :: [CmmBasicBlock] -> BlockEnv (UniqSet BlockId)
+-----------------------------------------------------------------------------
+-- | Calculates a table of where one can lookup the blocks that might
+-- need updating after a given block is updated in the liveness analysis
+-----------------------------------------------------------------------------
+cmmBlockSources :: [CmmBasicBlock] -> BlockSources
 cmmBlockSources blocks = foldr aux emptyUFM blocks
     where
       aux :: CmmBasicBlock
-          -> BlockEnv (UniqSet BlockId)
-          -> BlockEnv (UniqSet BlockId)
+          -> BlockSources
+          -> BlockSources
       aux block sourcesUFM =
           foldUniqSet (add_source_edges $ blockId block)
                       sourcesUFM
                       (branch_targets $ blockStmts block)
 
       add_source_edges :: BlockId -> BlockId
-                       -> BlockEnv (UniqSet BlockId)
-                       -> BlockEnv (UniqSet BlockId)
+                       -> BlockSources
+                       -> BlockSources
       add_source_edges source target ufm =
           addToUFM_Acc (flip addOneToUniqSet) unitUniqSet ufm target source
 
@@ -83,40 +91,22 @@ cmmBlockSources blocks = foldr aux emptyUFM blocks
               target (CmmSwitch _ blocks) = mapMaybe id blocks
               target _ = []
 
---------------------------------
--- cmmBlockNames
---
--- Calculates a table that maps
--- block names to the list
--- of statements inside them
---------------------------------
-cmmBlockNames :: [CmmBasicBlock] -> BlockEnv [CmmStmt]
-cmmBlockNames blocks = listToUFM $ map block_name blocks where
-    block_name b = (blockId b, blockStmts b)
-
---------------------------------
--- cmmBlockDependants
+-----------------------------------------------------------------------------
+-- | Given the table calculated by 'cmmBlockSources', list all blocks
+-- that depend on the result of a particular block.
 --
--- Given the table calculated
--- by cmmBlockSources created,
--- list all blocks that depend
--- on the result of a particular
--- block.
---------------------------------
-cmmBlockDependants :: BlockEnv (UniqSet BlockId) -> BlockId -> [BlockId]
+-- Used by the call to 'fixedpoint'.
+-----------------------------------------------------------------------------
+cmmBlockDependants :: BlockSources -> BlockId -> [BlockId]
 cmmBlockDependants sources ident =
     uniqSetToList $ lookupWithDefaultUFM sources emptyUniqSet ident
 
---------------------------------
--- cmmBlockUpdate
---
--- Given the table from
--- cmmBlockNames and a block
--- that was updated, calculate
--- an updated BlockEntryLiveness
---------------------------------
+-----------------------------------------------------------------------------
+-- | Given the table of type 'BlockStmts' and a block that was updated,
+-- calculate an updated BlockEntryLiveness
+-----------------------------------------------------------------------------
 cmmBlockUpdate ::
-    BlockEnv [CmmStmt]
+    BlockStmts
     -> BlockId
     -> Maybe BlockId
     -> BlockEntryLiveness
@@ -126,13 +116,19 @@ cmmBlockUpdate blocks node _ state =
       then Nothing
       else Just $ addToUFM state node new_live
     where
-      new_live = cmmStmtListLive state block
+      new_live, old_live :: CmmLive
+      new_live = cmmStmtListLive state block_stmts
       old_live = lookupWithDefaultUFM state missing_live node
-      block = lookupWithDefaultUFM blocks missing_block node
+
+      block_stmts :: [CmmStmt]
+      block_stmts = lookupWithDefaultUFM blocks missing_block node
+
       missing_live = panic "unknown block id during liveness analysis"
       missing_block = panic "unknown block id during liveness analysis"
 
 -----------------------------------------------------------------------------
+-- Section: 
+-----------------------------------------------------------------------------
 -- CmmBlockLive, cmmStmtListLive and helpers
 -----------------------------------------------------------------------------