Factor cmmToRawCmm completely out of CPS

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

diff --git a/compiler/cmm/CmmCPS.hs b/compiler/cmm/CmmCPS.hs
index 1a00110..cb36de4 100644 (file)
--- a/compiler/cmm/CmmCPS.hs
+++ b/compiler/cmm/CmmCPS.hs
@@ -43,7 +43,7 @@ import Data.List
 -----------------------------------------------------------------------------
 cmmCPS :: DynFlags -- ^ Dynamic flags: -dcmm-lint -ddump-cps-cmm
        -> [GenCmm CmmStatic CmmInfo CmmStmt]    -- ^ Input C-- with Proceedures
-       -> IO [GenCmm CmmStatic [CmmStatic] CmmStmt] -- ^ Output CPS transformed C--
+       -> IO [GenCmm CmmStatic CmmInfo CmmStmt] -- ^ Output CPS transformed C--
 cmmCPS dflags abstractC = do
   when (dopt Opt_DoCmmLinting dflags) $
        do showPass dflags "CmmLint"
@@ -112,9 +112,17 @@ force_gc_block old_info stack_use block_id fun_label formals =
 
 cpsProc :: UniqSupply 
         -> GenCmmTop CmmStatic CmmInfo CmmStmt     -- ^Input proceedure
-        -> [GenCmmTop CmmStatic [CmmStatic] CmmStmt]   -- ^Output proceedure and continuations
-cpsProc uniqSupply (CmmData sec dat) = [CmmData sec dat]
-cpsProc uniqSupply (CmmProc info ident params blocks) = info_procs
+        -> [GenCmmTop CmmStatic CmmInfo CmmStmt]   -- ^Output proceedure and continuations
+
+-- Data blocks don't need to be CPS transformed
+cpsProc uniqSupply proc@(CmmData _ _) = [proc]
+
+-- Empty functions just don't work with the CPS algorithm, but
+-- they don't need the transformation anyway so just output them directly
+cpsProc uniqSupply proc@(CmmProc _ _ _ []) = [proc]
+
+-- CPS transform for those procs that actually need it
+cpsProc uniqSupply (CmmProc info ident params blocks) = cps_procs
     where
       (uniqSupply1, uniqSupply2) = splitUniqSupply uniqSupply
       uniques :: [[Unique]]
@@ -175,10 +183,8 @@ cpsProc uniqSupply (CmmProc info ident params blocks) = info_procs
 
       -- Group the blocks into continuations based on the set of proc-points.
       continuations :: [Continuation (Either C_SRT CmmInfo)]
-      continuations = zipWith
-                        (gatherBlocksIntoContinuation live proc_points block_env)
-                        (uniqSetToList proc_points)
-                        (Just forced_gc_id : repeat Nothing) {-dead-}
+      continuations = map (gatherBlocksIntoContinuation live proc_points block_env)
+                          (uniqSetToList proc_points)
 
       -- Select the stack format on entry to each continuation.
       -- Return the max stack offset and an association list
@@ -205,11 +211,6 @@ cpsProc uniqSupply (CmmProc info ident params blocks) = info_procs
       cps_procs :: [CmmTop]
       cps_procs = zipWith (continuationToProc formats' stack_use) proc_uniques continuations'
 
-      -- Convert the info tables from CmmInfo to [CmmStatic]
-      -- We might want to put this in another pass eventually
-      info_procs :: [RawCmmTop]
-      info_procs = concat (zipWith mkInfoTable info_uniques cps_procs)
-
 -----------------------------------------------------------------------------
 
 collectNonProcPointTargets ::
@@ -240,19 +241,15 @@ collectNonProcPointTargets proc_points blocks current_targets new_blocks =
 
 gatherBlocksIntoContinuation ::
     BlockEntryLiveness -> UniqSet BlockId -> BlockEnv BrokenBlock
-    -> BlockId -> Maybe BlockId -> Continuation (Either C_SRT CmmInfo)
-gatherBlocksIntoContinuation live proc_points blocks start gc =
+    -> BlockId -> Continuation (Either C_SRT CmmInfo)
+gatherBlocksIntoContinuation live proc_points blocks start =
   Continuation info_table clabel params is_gc_cont body
     where
-      --start_and_gc = [start] -- : maybeToList gc
-      --children = (collectNonProcPointTargets proc_points blocks (mkUniqSet start_and_gc) start_and_gc) `minusUniqSet` (mkUniqSet start_and_gc)
       children = (collectNonProcPointTargets proc_points blocks (unitUniqSet start) [start]) `minusUniqSet` (unitUniqSet start)
       start_block = lookupWithDefaultUFM blocks (panic "TODO") start
       unknown_block = panic "unknown block in gatherBlocksIntoContinuation"
-      --gc_block = map (lookupWithDefaultUFM blocks (panic "TODO)"))
-      --               (maybeToList gc)
       children_blocks = map (lookupWithDefaultUFM blocks (panic "TODO")) (uniqSetToList children)
-      body = start_block : {-gc_block ++ -} children_blocks
+      body = start_block : children_blocks
 
       -- We can't properly annotate the continuation's stack parameters
       -- at this point because this is before stack selection