Fixed CPS to account for info tables not being next to code

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

diff --git a/compiler/cmm/CmmCPSGen.hs b/compiler/cmm/CmmCPSGen.hs
index 49ac9ab..da72b54 100644 (file)
--- a/compiler/cmm/CmmCPSGen.hs
+++ b/compiler/cmm/CmmCPSGen.hs
@@ -17,6 +17,7 @@ import CmmCallConv
 
 import CgProf (curCCS, curCCSAddr)
 import CgUtils (cmmOffsetW)
+import CgInfoTbls (entryCode)
 import SMRep
 import ForeignCall
 
@@ -97,11 +98,7 @@ continuationToProc (max_stack, update_frame_size, formats) stack_use uniques
 
       gc_stmts :: [CmmStmt]
       gc_stmts =
-          case info of
-            CmmInfo (Just gc_block) _ _ ->
-                gc_stack_check' stack_use arg_stack (max_stack - curr_stack)
-            CmmInfo Nothing _ _ ->
-                panic "continuationToProc: missing GC block"
+        assign_gc_stack_use stack_use arg_stack (max_stack - curr_stack)
 
       update_stmts :: [CmmStmt]
       update_stmts =
@@ -124,10 +121,11 @@ continuationToProc (max_stack, update_frame_size, formats) stack_use uniques
           prefix_blocks ++ [main_block]
           where
             prefix_blocks =
-                case gc_prefix ++ param_prefix of
-                  [] -> []
-                  entry_stmts -> [BasicBlock prefix_id
-                                  (entry_stmts ++ [CmmBranch ident])]
+                if is_entry
+                then [BasicBlock
+                      (BlockId prefix_unique)
+                      (param_stmts ++ [CmmBranch ident])]
+                else []
 
             prefix_unique : call_uniques = uniques
             toCLabel = mkReturnPtLabel . getUnique
@@ -161,17 +159,9 @@ continuationToProc (max_stack, update_frame_size, formats) stack_use uniques
                       -- a bit.  This depends on the knowledge that the
                       -- statements in the first block are only the GC check.
                       -- That's fragile but it works for now.
-                      BasicBlock ident (stmts ++ update_stmts ++ postfix_stmts)
+                      BasicBlock ident (gc_stmts ++ stmts ++ update_stmts ++ postfix_stmts)
                   ControlEntry -> BasicBlock ident (stmts ++ postfix_stmts)
                   ContinuationEntry _ _ _ -> BasicBlock ident (stmts ++ postfix_stmts)
-            prefix_id = BlockId prefix_unique
-            gc_prefix = case entry of
-                       FunctionEntry _ _ _ -> gc_stmts
-                       ControlEntry -> []
-                       ContinuationEntry _ _ _ -> []
-            param_prefix = if is_entry
-                           then param_stmts
-                           else []
             postfix_stmts = case exit of
                         FinalBranch next ->
                             if (mkReturnPtLabel $ getUnique next) == label
@@ -179,7 +169,7 @@ continuationToProc (max_stack, update_frame_size, formats) stack_use uniques
                             else case lookup (mkReturnPtLabel $ getUnique next) formats of
                               Nothing -> [CmmBranch next]
                               Just cont_format ->
-                                pack_continuation False curr_format cont_format ++
+                                pack_continuation True curr_format cont_format ++
                                 tail_call (curr_stack - cont_stack)
                                           (CmmLit $ CmmLabel $ mkReturnPtLabel $ getUnique next)
                                           arguments
@@ -189,7 +179,7 @@ continuationToProc (max_stack, update_frame_size, formats) stack_use uniques
                         FinalSwitch expr targets -> [CmmSwitch expr targets]
                         FinalReturn arguments ->
                             tail_call curr_stack
-                                (CmmLoad (CmmReg spReg) wordRep)
+                                (entryCode (CmmLoad (CmmReg spReg) wordRep))
                                 arguments
                         FinalJump target arguments ->
                             tail_call curr_stack target arguments
@@ -366,7 +356,7 @@ adjust_sp_reg spRel =
     then []
     else [CmmAssign spReg (CmmRegOff spReg (spRel*wORD_SIZE))]
 
-gc_stack_check' stack_use arg_stack max_frame_size =
+assign_gc_stack_use stack_use arg_stack max_frame_size =
     if max_frame_size > arg_stack
     then [CmmAssign stack_use (CmmRegOff spReg (-max_frame_size*wORD_SIZE))]
     else [CmmAssign stack_use (CmmReg spLimReg)]
@@ -396,7 +386,6 @@ pack_continuation allow_header_set
                       (ContinuationFormat _ cont_id cont_frame_size live_regs)
   = pack_frame curr_frame_size cont_frame_size maybe_header continuation_args
   where
-    continuation_function = CmmLit $ CmmLabel $ fromJust cont_id
     continuation_args = map (maybe Nothing (Just . CmmReg . CmmLocal))
                             live_regs
     needs_header_set =
@@ -405,7 +394,7 @@ pack_continuation allow_header_set
           _ -> isJust cont_id
 
     maybe_header = if allow_header_set && needs_header_set
-                   then Just continuation_function
+                   then maybe Nothing (Just . CmmLit . CmmLabel . entryLblToInfoLbl) cont_id
                    else Nothing
 
 pack_frame :: WordOff         -- ^ Current frame size