Added stack checks to the CPS algorithm

This eliminates one of the panics introduced by 
the previous patch:
'First pass at implementing info tables for CPS'
  
The other panic introduced by that patch still remains.
It was due to the need to convert from a
  ContinuationInfo to a CmmInfo.
  (codeGen/CgInfoTbls.hs:emitClosureCodeAndInfoTable)
  (codeGen/CgInfoTbls.hs:emitReturnTarget)

compiler/cmm/Cmm.hs

@@ -115,11 +115,17 @@ data CmmInfo
       ClosureTypeTag -- Int
       ClosureTypeInfo
   | CmmNonInfo   -- Procedure doesn't need an info table
+      (Maybe BlockId) -- But we still need a GC target for it
+
+-- TODO: The GC target shouldn't really be part of CmmInfo
+-- as it doesn't appear in the resulting info table.
+-- It should be factored out.
 
 data ClosureTypeInfo
   = ConstrInfo ClosureLayout ConstrTag ConstrDescription
   | FunInfo ClosureLayout C_SRT FunType FunArity ArgDescr SlowEntry
   | ThunkInfo ClosureLayout C_SRT
+  | ThunkSelectorInfo SelectorOffset C_SRT
   | ContInfo
       [Maybe LocalReg]  -- Forced stack parameters
       C_SRT
@@ -129,10 +135,11 @@ data ProfilingInfo = ProfilingInfo CmmLit CmmLit -- closure_type, closure_desc
 type ClosureTypeTag = StgHalfWord
 type ClosureLayout = (StgHalfWord, StgHalfWord) -- pts, nptrs
 type ConstrTag = StgHalfWord
-type ConstrDescription = CLabel
+type ConstrDescription = CmmLit
 type FunType = StgHalfWord
 type FunArity = StgHalfWord
 type SlowEntry = CLabel
+type SelectorOffset = StgWord
 
 -----------------------------------------------------------------------------
 --		CmmStmt

compiler/cmm/CmmCPS.hs

@@ -69,6 +69,34 @@ 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 srt = BasicBlock block_id stmts
+    where
+      stmts = [CmmCall stg_gc_gen_target [] [] srt,
+               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)
+
+force_gc_block old_info block_id fun_label formals blocks =
+    case old_info of
+      CmmNonInfo (Just _) -> (old_info, [])
+      CmmInfo _ (Just _) _ _ -> (old_info, [])
+      CmmNonInfo Nothing
+          -> (CmmNonInfo (Just block_id),
+              [make_gc_block block_id fun_label formals NoC_SRT])
+      CmmInfo prof Nothing type_tag type_info
+        -> (CmmInfo prof (Just block_id) type_tag type_info,
+            [make_gc_block block_id fun_label formals srt])
+           where
+             srt = case type_info of
+                     ConstrInfo _ _ _ -> NoC_SRT
+                     FunInfo _ srt' _ _ _ _ -> srt'
+                     ThunkInfo _ srt' -> srt'
+                     ThunkSelectorInfo _ srt' -> srt'
+                     ContInfo _ srt' -> srt'    
+
 -----------------------------------------------------------------------------
 -- |CPS a single CmmTop (proceedure)
 -- Only 'CmmProc' are transformed 'CmmData' will be left alone.
@@ -82,14 +110,24 @@ cpsProc uniqSupply (CmmProc info ident params blocks) = info_procs
     where
       uniques :: [[Unique]]
       uniques = map uniqsFromSupply $ listSplitUniqSupply uniqSupply
-      info_uniques:block_uniques = uniques
+      (gc_unique:info_uniques):block_uniques = uniques
+
+      -- Ensure that 
+      forced_gc :: (CmmInfo, [CmmBasicBlock])
+      forced_gc = force_gc_block info (BlockId gc_unique) ident params blocks
+
+      forced_info = fst forced_gc
+      forced_blocks = blocks ++ snd forced_gc
+      forced_gc_id = case forced_info of
+                       CmmNonInfo (Just x) -> x
+                       CmmInfo _ (Just x) _ _ -> x
 
       -- 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 block_uniques blocks
-                     (FunctionEntry info ident params:repeat ControlEntry)
+          concat $ zipWith3 breakBlock block_uniques forced_blocks
+                     (FunctionEntry forced_info ident params:repeat ControlEntry)
 
       -- Calculate live variables for each broken block.
       --
@@ -109,8 +147,10 @@ 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 = map (gatherBlocksIntoContinuation proc_points block_env)
-                          (uniqSetToList proc_points)
+      continuations = zipWith
+                        (gatherBlocksIntoContinuation proc_points block_env)
+                        (uniqSetToList proc_points)
+                        (Just forced_gc_id : repeat Nothing)
 
       -- Select the stack format on entry to each continuation.
       -- Return the max stack offset and an association list
@@ -191,18 +231,22 @@ data StackFormat
 
 collectNonProcPointTargets ::
     UniqSet BlockId -> BlockEnv BrokenBlock
-    -> UniqSet BlockId -> BlockId -> UniqSet BlockId
-collectNonProcPointTargets proc_points blocks current_targets block =
+    -> UniqSet BlockId -> [BlockId] -> UniqSet BlockId
+collectNonProcPointTargets proc_points blocks current_targets new_blocks =
     if sizeUniqSet current_targets == sizeUniqSet new_targets
        then current_targets
-       else foldl (collectNonProcPointTargets proc_points blocks) new_targets targets
+       else foldl
+                (collectNonProcPointTargets proc_points blocks)
+                new_targets
+                (map (:[]) targets)
     where
-      block' = lookupWithDefaultUFM blocks (panic "TODO") block
+      blocks' = map (lookupWithDefaultUFM blocks (panic "TODO")) new_blocks
       targets =
         -- Note the subtlety that since the extra branch after a call
         -- will always be to a block that is a proc-point,
         -- this subtraction will always remove that case
-        uniqSetToList $ (mkUniqSet $ brokenBlockTargets block') `minusUniqSet` proc_points
+        uniqSetToList $ (unionManyUniqSets $ map (mkUniqSet . brokenBlockTargets) blocks')
+                          `minusUniqSet` proc_points
         -- TODO: remove redundant uniqSetToList
       new_targets = current_targets `unionUniqSets` (mkUniqSet targets)
 
@@ -213,14 +257,16 @@ collectNonProcPointTargets proc_points blocks current_targets block =
 
 gatherBlocksIntoContinuation ::
     UniqSet BlockId -> BlockEnv BrokenBlock
-    -> BlockId -> Continuation (Either C_SRT CmmInfo)
-gatherBlocksIntoContinuation proc_points blocks start =
+    -> BlockId -> Maybe BlockId -> Continuation (Either C_SRT CmmInfo)
+gatherBlocksIntoContinuation proc_points blocks start gc =
   Continuation info_table clabel params body
     where
-      children = (collectNonProcPointTargets proc_points blocks (unitUniqSet start) start) `delOneFromUniqSet` start
+      start_and_gc = start : maybeToList gc
+      children = (collectNonProcPointTargets proc_points blocks (mkUniqSet start_and_gc) start_and_gc) `minusUniqSet` (mkUniqSet start_and_gc)
       start_block = lookupWithDefaultUFM blocks (panic "TODO") start
+      gc_block = map (lookupWithDefaultUFM blocks (panic "TODO)")) (maybeToList gc)
       children_blocks = map (lookupWithDefaultUFM blocks (panic "TODO")) (uniqSetToList children)
-      body = start_block : children_blocks
+      body = start_block : gc_block ++ children_blocks
 
       -- We can't properly annotate the continuation's stack parameters
       -- at this point because this is before stack selection
@@ -228,7 +274,7 @@ gatherBlocksIntoContinuation proc_points blocks start =
       info_table = case start_block_entry of
                      FunctionEntry info _ _ -> Right info
                      ContinuationEntry _ srt -> Left srt
-                     ControlEntry -> Right CmmNonInfo
+                     ControlEntry -> Right (CmmNonInfo Nothing)
 
       start_block_entry = brokenBlockEntry start_block
       clabel = case start_block_entry of
@@ -342,11 +388,12 @@ continuationToProc (max_stack, formats)
                            gc_stack_check gc_block max_stack ++
                            function_entry formals curr_format
                        FunctionEntry (CmmInfo _ Nothing _ _) _ formals ->
-                           panic "continuationToProc: TODO generate GC block" ++
-                           function_entry formals curr_format
-                       FunctionEntry CmmNonInfo _ formals ->
-                           panic "TODO: gc_stack_check gc_block max_stack" ++
+                           panic "continuationToProc: missing GC block"
+                       FunctionEntry (CmmNonInfo (Just gc_block)) _ formals ->
+                           gc_stack_check gc_block max_stack ++
                            function_entry formals curr_format
+                       FunctionEntry (CmmNonInfo Nothing) _ formals ->
+                           panic "continuationToProc: missing non-info GC block"
                        ContinuationEntry formals _ ->
                            function_entry formals curr_format
             postfix = case exit of
@@ -395,10 +442,12 @@ gc_stack_check gc_block max_frame_size
     check_stack_limit = [
      CmmCondBranch
      (CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
-                    [CmmRegOff spReg max_frame_size, CmmReg spLimReg])
+                    [CmmRegOff spReg (-max_frame_size*wORD_SIZE),
+                     CmmReg spLimReg])
      gc_block]
 
--- TODO: fix branches to proc point (we have to insert a new block to marshel the continuation)
+-- TODO: fix branches to proc point
+-- (we have to insert a new block to marshel the continuation)
 pack_continuation :: StackFormat -> StackFormat -> [CmmStmt]
 pack_continuation (StackFormat curr_id curr_frame_size _)
                        (StackFormat cont_id cont_frame_size live_regs)

compiler/cmm/CmmInfo.hs

@@ -26,7 +26,7 @@ mkInfoTable :: Unique -> CmmTop -> [RawCmmTop]
 mkInfoTable uniq (CmmData sec dat) = [CmmData sec dat]
 mkInfoTable uniq (CmmProc info entry_label arguments blocks) =
     case info of
-      CmmNonInfo -> [CmmProc [] entry_label arguments blocks]
+      CmmNonInfo _ -> [CmmProc [] entry_label arguments blocks]
       CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag
               (FunInfo (ptrs, nptrs) srt fun_type fun_arity pap_bitmap slow_entry) ->
           mkInfoTableAndCode info_label std_info fun_extra_bits entry_label arguments blocks
@@ -55,7 +55,7 @@ mkInfoTable uniq (CmmProc info entry_label arguments blocks) =
           where
             std_info = mkStdInfoTable ty_prof cl_prof type_tag con_tag layout
             info_label = entryLblToInfoLbl entry_label
-            con_name = makeRelativeRefTo info_label (CmmLabel descr)
+            con_name = makeRelativeRefTo info_label descr
             layout = packHalfWordsCLit ptrs nptrs
 
       CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag
@@ -72,6 +72,19 @@ mkInfoTable uniq (CmmProc info entry_label arguments blocks) =
                        bitmap)
             layout = packHalfWordsCLit ptrs nptrs
 
+      CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag
+              (ThunkSelectorInfo offset srt) ->
+          mkInfoTableAndCode info_label std_info srt_label entry_label arguments blocks
+          where
+            std_info = mkStdInfoTable ty_prof cl_prof type_tag srt_bitmap (mkWordCLit offset)
+            info_label = entryLblToInfoLbl entry_label
+            (srt_label, srt_bitmap) =
+                case srt of
+                  NoC_SRT -> ([], 0)
+                  (C_SRT lbl off bitmap) ->
+                      ([makeRelativeRefTo info_label (cmmLabelOffW lbl off)],
+                       bitmap)
+
       CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag (ContInfo stack_layout srt) ->
           liveness_data ++
           mkInfoTableAndCode info_label std_info srt_label entry_label arguments blocks

compiler/cmm/CmmParse.y

@@ -200,44 +200,70 @@ lits	:: { [ExtFCode CmmExpr] }
 
 cmmproc :: { ExtCode }
 -- TODO: add real SRT/info tables to parsed Cmm
---	: info maybe_formals '{' body '}'
---		{ do (info_lbl, info1, info2) <- $1;
---		     formals <- sequence $2;
---		     stmts <- getCgStmtsEC (loopDecls $4)
---		     blks <- code (cgStmtsToBlocks stmts)
---		     code (emitInfoTableAndCode info_lbl info1 info2 formals blks) }
---
---	| info maybe_formals ';'
---		{ do (info_lbl, info1, info2) <- $1;
---		     formals <- sequence $2;
---		     code (emitInfoTableAndCode info_lbl info1 info2 formals []) }
-
-	: NAME maybe_formals '{' body '}'
+	: info maybe_formals '{' body '}'
+		{ do (info_lbl, info) <- $1;
+		     formals <- sequence $2;
+		     stmts <- getCgStmtsEC (loopDecls $4)
+		     blks <- code (cgStmtsToBlocks stmts)
+		     code (emitInfoTableAndCode info_lbl info formals blks) }
+
+	| info maybe_formals ';'
+		{ do (info_lbl, info) <- $1;
+		     formals <- sequence $2;
+		     code (emitInfoTableAndCode info_lbl info formals []) }
+
+	| NAME maybe_formals '{' body '}'
 		{ do formals <- sequence $2;
 		     stmts <- getCgStmtsEC (loopDecls $4);
 		     blks <- code (cgStmtsToBlocks stmts);
-		     code (emitProc CmmNonInfo (mkRtsCodeLabelFS $1) formals blks) }
+		     code (emitProc (CmmNonInfo Nothing) (mkRtsCodeLabelFS $1) formals blks) }
 
-info	:: { ExtFCode (CLabel, [CmmLit],[CmmLit]) }
+info	:: { ExtFCode (CLabel, CmmInfo) }
 	: 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
 		-- ptrs, nptrs, closure type, description, type
-		{ stdInfo $3 $5 $7 0 $9 $11 $13 }
+		{ do prof <- profilingInfo $11 $13
+		     return (mkRtsInfoLabelFS $3,
+			CmmInfo prof Nothing (fromIntegral $9)
+				(ThunkInfo (fromIntegral $5, fromIntegral $7) NoC_SRT)) }
 	
 	| 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
 		-- ptrs, nptrs, closure type, description, type, fun type
-		{ funInfo $3 $5 $7 $9 $11 $13 $15 }
+		{ do prof <- profilingInfo $11 $13
+		     return (mkRtsInfoLabelFS $3,
+			CmmInfo prof Nothing (fromIntegral $9)
+				(FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $15) 0 (panic "INFO_TABLE_FUN:ArgDesr") (panic "INFO_TABLE_FUN:SlowEntry"))) }
+		-- we leave most of the fields zero here.  This is only used
+		-- to generate the BCO info table in the RTS at the moment.
 	
 	| 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
 		-- ptrs, nptrs, tag, closure type, description, type
-		{ conInfo $3 $5 $7 $9 $11 $13 $15 }
+		{ do prof <- profilingInfo $13 $15
+		     -- If profiling is on, this string gets duplicated,
+		     -- but that's the way the old code did it we can fix it some other time.
+		     desc_lit <- code $ mkStringCLit $13
+		     return (mkRtsInfoLabelFS $3,
+			CmmInfo prof Nothing (fromIntegral $11)
+				(ConstrInfo (fromIntegral $5, fromIntegral $7) (fromIntegral $9) desc_lit)) }
 	
 	| 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
 		-- selector, closure type, description, type
-		{ basicInfo $3 (mkIntCLit (fromIntegral $5)) 0 $7 $9 $11 }
-
-	| 'INFO_TABLE_RET' '(' NAME ',' INT ',' INT ',' INT ')'
-		-- size, live bits, closure type
-		{ retInfo $3 $5 $7 $9 }
+		{ do prof <- profilingInfo $9 $11
+		     return (mkRtsInfoLabelFS $3,
+			CmmInfo prof Nothing (fromIntegral $7)
+				(ThunkSelectorInfo (fromIntegral $5) NoC_SRT)) }
+
+	| 'INFO_TABLE_RET' '(' NAME ',' INT ')'
+		-- closure type (no live regs)
+		{ return (mkRtsInfoLabelFS $3,
+			CmmInfo (ProfilingInfo zeroCLit zeroCLit) Nothing (fromIntegral $5)
+				(ContInfo [] NoC_SRT)) }
+
+	| 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals ')'
+		-- closure type, live regs
+		{ do live <- sequence (map (liftM Just) $7)
+		     return (mkRtsInfoLabelFS $3,
+			CmmInfo (ProfilingInfo zeroCLit zeroCLit) Nothing (fromIntegral $5)
+			(ContInfo live NoC_SRT)) }
 
 body	:: { ExtCode }
 	: {- empty -}			{ return () }
@@ -809,6 +835,15 @@ funInfo name ptrs nptrs cl_type desc_str ty_str fun_type = do
  where
    zero = mkIntCLit 0
 
+profilingInfo desc_str ty_str = do
+  lit1 <- if opt_SccProfilingOn 
+		   then code $ mkStringCLit desc_str
+		   else return (mkIntCLit 0)
+  lit2 <- if opt_SccProfilingOn 
+		   then code $ mkStringCLit ty_str
+		   else return (mkIntCLit 0)
+  return (ProfilingInfo lit1 lit2)
+
 
 staticClosure :: FastString -> FastString -> [CmmLit] -> ExtCode
 staticClosure cl_label info payload

compiler/cmm/CmmProcPoint.hs

@@ -39,7 +39,8 @@ calculateOwnership blocks_ufm proc_points blocks =
       unknown_block = panic "unknown BlockId in selectStackFormat"
 
 calculateProcPoints :: [BrokenBlock] -> UniqSet BlockId
-calculateProcPoints blocks = calculateProcPoints' init_proc_points blocks
+calculateProcPoints blocks =
+    calculateProcPoints' init_proc_points blocks
     where
       init_proc_points = mkUniqSet $
                          map brokenBlockId $

compiler/cmm/PprCmm.hs

@@ -126,7 +126,9 @@ pprTop (CmmData section ds) =
 -- For ideas on how to refine it, they used to be printed in the
 -- style of C--'s 'stackdata' declaration, just inside the proc body,
 -- and were labelled with the procedure name ++ "_info".
-pprInfo CmmNonInfo = empty
+pprInfo (CmmNonInfo gc_target) =
+    ptext SLIT("gc_target: ") <>
+          maybe (ptext SLIT("<none>")) pprBlockId gc_target
 pprInfo (CmmInfo (ProfilingInfo closure_type closure_desc)
                  gc_target tag info) =
     vcat [ptext SLIT("type: ") <> pprLit closure_type,
@@ -140,7 +142,7 @@ pprTypeInfo (ConstrInfo layout constr descr) =
     vcat [ptext SLIT("ptrs: ") <> integer (toInteger (fst layout)),
           ptext SLIT("nptrs: ") <> integer (toInteger (snd layout)),
           ptext SLIT("constructor: ") <> integer (toInteger constr),
-          ppr descr]
+          pprLit descr]
 pprTypeInfo (FunInfo layout srt fun_type arity args slow_entry) =
     vcat [ptext SLIT("ptrs: ") <> integer (toInteger (fst layout)),
           ptext SLIT("nptrs: ") <> integer (toInteger (snd layout)),
@@ -154,6 +156,9 @@ pprTypeInfo (ThunkInfo layout srt) =
     vcat [ptext SLIT("ptrs: ") <> integer (toInteger (fst layout)),
           ptext SLIT("nptrs: ") <> integer (toInteger (snd layout)),
           ptext SLIT("srt: ") <> ppr srt]
+pprTypeInfo (ThunkSelectorInfo offset srt) =
+    vcat [ptext SLIT("ptrs: ") <> integer (toInteger offset),
+          ptext SLIT("srt: ") <> ppr srt]
 pprTypeInfo (ContInfo stack srt) =
     vcat [ptext SLIT("stack: ") <> ppr stack,
           ptext SLIT("srt: ") <> ppr srt]

compiler/codeGen/CgMonad.lhs

@@ -745,7 +745,7 @@ emitSimpleProc :: CLabel -> Code -> Code
 emitSimpleProc lbl code
   = do	{ stmts <- getCgStmts code
 	; blks <- cgStmtsToBlocks stmts
-	; emitProc CmmNonInfo lbl [] blks }
+	; emitProc (CmmNonInfo Nothing) lbl [] blks }
 
 getCmm :: Code -> FCode Cmm
 -- Get all the CmmTops (there should be no stmts)