Added support for GC block declaration to the Cmm syntax

compiler/cmm/Cmm.hs

@@ -113,7 +113,7 @@ mapBlockStmts f (BasicBlock id bs) = BasicBlock id (map f bs)
 
 data CmmInfo
   = CmmInfo
-      (Maybe BlockId) -- GC target
+      (Maybe BlockId) -- GC target. Nothing <=> CPS won't do stack check
       (Maybe UpdateFrame) -- Update frame
       CmmInfoTable -- Info table
 

compiler/cmm/CmmCPS.hs

@@ -15,7 +15,6 @@ import CmmBrokenBlock
 import CmmProcPoint
 import CmmCallConv
 import CmmCPSGen
-import CmmInfo
 import CmmUtils
 
 import ClosureInfo
@@ -69,37 +68,23 @@ cmmCPS dflags abstractC = do
 
   return continuationC
 
-stg_gc_gen = mkRtsApFastLabel SLIT("gen_cg_TODO") --panic "Need the label for gc"
-make_gc_block block_id fun_label formals safety = BasicBlock block_id stmts
+make_stack_check stack_check_block_id info stack_use next_block_id =
+    BasicBlock stack_check_block_id $
+                   check_stmts ++ [CmmBranch next_block_id]
     where
-      stmts = [CmmCall stg_gc_gen_target [] [] safety,
-               CmmJump fun_expr actuals]
-      stg_gc_gen_target =
-          CmmForeignCall (CmmLit (CmmLabel stg_gc_gen)) CmmCallConv
-      actuals = map (\x -> (CmmReg (CmmLocal x), NoHint)) formals
-      fun_expr = CmmLit (CmmLabel fun_label)
-
-make_gc_check stack_use gc_block =
-    [CmmCondBranch
-     (CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
-                    [CmmReg stack_use, CmmReg spLimReg])
-    gc_block]
-
-force_gc_block old_info stack_use block_id fun_label formals =
-    case old_info of
-      CmmInfo (Just existing) _ _
-          -> (old_info, [], make_gc_check stack_use existing)
-      CmmInfo Nothing update_frame info_table
-          -> (CmmInfo (Just block_id) update_frame info_table,
-              [make_gc_block block_id fun_label formals (CmmSafe $ cmmInfoTableSRT info_table)],
-              make_gc_check stack_use block_id)
-
-cmmInfoTableSRT CmmNonInfoTable = NoC_SRT
-cmmInfoTableSRT (CmmInfoTable _ _ (ConstrInfo _ _ _)) = NoC_SRT
-cmmInfoTableSRT (CmmInfoTable _ _ (FunInfo _ srt _ _ _ _)) = srt
-cmmInfoTableSRT (CmmInfoTable _ _ (ThunkInfo _ srt)) = srt
-cmmInfoTableSRT (CmmInfoTable _ _ (ThunkSelectorInfo _ srt)) = srt
-cmmInfoTableSRT (CmmInfoTable _ _ (ContInfo _ srt)) = srt
+      check_stmts =
+          case info of
+            -- If we are given a stack check handler,
+            -- then great, well check the stack.
+            CmmInfo (Just gc_block) _ _
+                -> [CmmCondBranch
+                    (CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
+                     [CmmReg stack_use, CmmReg spLimReg])
+                    gc_block]
+            -- If we aren't given a stack check handler,
+            -- then humph! we just won't check the stack for them.
+            CmmInfo Nothing _ _
+                -> []
 
 -----------------------------------------------------------------------------
 -- |CPS a single CmmTop (proceedure)
@@ -120,39 +105,35 @@ cpsProc uniqSupply proc@(CmmProc _ _ _ []) = [proc]
 -- CPS transform for those procs that actually need it
 cpsProc uniqSupply (CmmProc info ident params blocks) = cps_procs
     where
+      -- We need to be generating uniques for several things.
+      -- We could make this function monadic to handle that
+      -- but since there is no other reason to make it monadic,
+      -- we instead will just split them all up right here.
       (uniqSupply1, uniqSupply2) = splitUniqSupply uniqSupply
       uniques :: [[Unique]]
       uniques = map uniqsFromSupply $ listSplitUniqSupply uniqSupply1
-      (gc_unique:gc_block_unique:stack_use_unique:info_uniques):adaptor_uniques:block_uniques = uniques
+      (stack_check_block_unique:stack_use_unique:info_uniques) :
+       adaptor_uniques :
+       block_uniques = uniques
       proc_uniques = map (map uniqsFromSupply . listSplitUniqSupply) $ listSplitUniqSupply uniqSupply2
 
       stack_use = CmmLocal (LocalReg stack_use_unique (cmmRegRep spReg) KindPtr)
+      stack_check_block_id = BlockId stack_check_block_unique
+      stack_check_block = make_stack_check stack_check_block_id info stack_use (blockId $ head blocks)
 
-      -- TODO: doc
-      forced_gc :: (CmmInfo, [CmmBasicBlock], [CmmStmt])
-      forced_gc = force_gc_block info stack_use (BlockId gc_unique) ident params
-      (forced_info, gc_blocks, check_stmts) = forced_gc
-      gc_block_id = BlockId gc_block_unique
+      forced_blocks = stack_check_block : blocks
 
-      forced_blocks = 
-          BasicBlock gc_block_id
-                     (check_stmts++[CmmBranch $ blockId $ head blocks]) :
-          blocks ++ gc_blocks
-
-      forced_gc_id = case forced_info of
-                       CmmInfo (Just x) _ _ -> x
-
-      update_frame = case info of CmmInfo _ u _ -> u
+      CmmInfo maybe_gc_block_id update_frame _ = info
 
       -- Break the block at each function call.
       -- The part after the function call will have to become a continuation.
       broken_blocks :: ([(BlockId, ContFormat)], [BrokenBlock])
       broken_blocks =
           (\x -> (concatMap fst x, concatMap snd x)) $
-          zipWith3 (breakBlock [forced_gc_id])
+          zipWith3 (breakBlock (maybeToList maybe_gc_block_id))
                      block_uniques
                      forced_blocks
-                     (FunctionEntry forced_info ident params :
+                     (FunctionEntry info ident params :
                       repeat ControlEntry)
 
       f' = selectContinuations (fst broken_blocks)
@@ -243,9 +224,9 @@ gatherBlocksIntoContinuation live proc_points blocks start =
   Continuation info_table clabel params is_gc_cont body
     where
       children = (collectNonProcPointTargets proc_points blocks (unitUniqSet start) [start]) `minusUniqSet` (unitUniqSet start)
-      start_block = lookupWithDefaultUFM blocks (panic "TODO") start
+      start_block = lookupWithDefaultUFM blocks unknown_block start
+      children_blocks = map (lookupWithDefaultUFM blocks unknown_block) (uniqSetToList children)
       unknown_block = panic "unknown block in gatherBlocksIntoContinuation"
-      children_blocks = map (lookupWithDefaultUFM blocks (panic "TODO")) (uniqSetToList children)
       body = start_block : children_blocks
 
       -- We can't properly annotate the continuation's stack parameters

compiler/cmm/CmmCPSGen.hs

@@ -97,11 +97,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 +120,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 +158,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
@@ -366,7 +355,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)]

compiler/cmm/CmmParse.y

@@ -200,14 +200,15 @@ lits	:: { [ExtFCode CmmExpr] }
 
 cmmproc :: { ExtCode }
 -- TODO: add real SRT/info tables to parsed Cmm
-	: info maybe_formals maybe_frame '{' body '}'
-		{ do ((info_lbl, info, live, formals, frame), stmts) <-
+	: info maybe_formals maybe_frame maybe_gc_block '{' body '}'
+		{ do ((info_lbl, info, live, formals, frame, gc_block), stmts) <-
 		       getCgStmtsEC' $ loopDecls $ do {
 		         (info_lbl, info, live) <- $1;
 		         formals <- sequence $2;
 		         frame <- $3;
-		         $5;
-		         return (info_lbl, info, live, formals, frame) }
+		         gc_block <- $4;
+		         $6;
+		         return (info_lbl, info, live, formals, frame, gc_block) }
 		     blks <- code (cgStmtsToBlocks stmts)
 		     code (emitInfoTableAndCode info_lbl (CmmInfo Nothing frame info) formals blks) }
 
@@ -216,15 +217,16 @@ cmmproc :: { ExtCode }
 		     formals <- sequence $2;
 		     code (emitInfoTableAndCode info_lbl (CmmInfo Nothing Nothing info) formals []) }
 
-	| NAME maybe_formals maybe_frame '{' body '}'
-		{ do ((formals, frame), stmts) <-
+	| NAME maybe_formals maybe_frame maybe_gc_block '{' body '}'
+		{ do ((formals, frame, gc_block), stmts) <-
 			getCgStmtsEC' $ loopDecls $ do {
 		          formals <- sequence $2;
 			  frame <- $3;
-		          $5;
-		          return (formals, frame) }
+		          gc_block <- $4;
+		          $6;
+		          return (formals, frame, gc_block) }
                      blks <- code (cgStmtsToBlocks stmts)
-		     code (emitProc (CmmInfo Nothing frame CmmNonInfoTable) (mkRtsCodeLabelFS $1) formals blks) }
+		     code (emitProc (CmmInfo gc_block frame CmmNonInfoTable) (mkRtsCodeLabelFS $1) formals blks) }
 
 info	:: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
 	: 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
@@ -511,6 +513,11 @@ maybe_frame :: { ExtFCode (Maybe UpdateFrame) }
 					       args <- sequence $4;
 					       return $ Just (UpdateFrame target args) } }
 
+maybe_gc_block :: { ExtFCode (Maybe BlockId) }
+	: {- empty -}			{ return Nothing }
+	| 'goto' NAME
+		{ do l <- lookupLabel $2; return (Just l) }
+
 type	:: { MachRep }
 	: 'bits8'		{ I8 }
 	| typenot8		{ $1 }

compiler/cmm/PprCmm.hs

@@ -156,7 +156,7 @@ pprTypeInfo (FunInfo layout srt fun_type arity args slow_entry) =
           ptext SLIT("srt: ") <> ppr srt,
           ptext SLIT("fun_type: ") <> integer (toInteger fun_type),
           ptext SLIT("arity: ") <> integer (toInteger arity),
-          --ppr args, -- TODO: needs to be printed
+          --ptext SLIT("args: ") <> ppr args, -- TODO: needs to be printed
           ptext SLIT("slow: ") <> pprLit slow_entry
          ]
 pprTypeInfo (ThunkInfo layout srt) =