Added support for update frames to the CPS pass

(This required a bit of refactoring of CmmInfo.)

compiler/cmm/Cmm.hs

@@ -9,7 +9,8 @@
 module Cmm ( 
 	GenCmm(..), Cmm, RawCmm,
 	GenCmmTop(..), CmmTop, RawCmmTop,
-	CmmInfo(..), ClosureTypeInfo(..), ProfilingInfo(..), ClosureTypeTag,
+	CmmInfo(..), UpdateFrame(..),
+        CmmInfoTable(..), ClosureTypeInfo(..), ProfilingInfo(..), ClosureTypeTag,
 	GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts, mapBlockStmts,
 	CmmStmt(..), CmmActuals, CmmFormal, CmmFormals, CmmHintFormals,
         CmmSafety(..),
@@ -110,15 +111,19 @@ mapBlockStmts f (BasicBlock id bs) = BasicBlock id (map f bs)
 --     Info Tables
 -----------------------------------------------------------------------------
 
--- Info table as a haskell data type
 data CmmInfo
   = CmmInfo
-      ProfilingInfo
       (Maybe BlockId) -- GC target
+      (Maybe UpdateFrame) -- Update frame
+      CmmInfoTable -- Info table
+
+-- Info table as a haskell data type
+data CmmInfoTable
+  = CmmInfoTable
+      ProfilingInfo
       ClosureTypeTag -- Int
       ClosureTypeInfo
-  | CmmNonInfo   -- Procedure doesn't need an info table
-      (Maybe BlockId) -- But we still need a GC target for it
+  | CmmNonInfoTable   -- Procedure doesn't need an info table
 
 -- TODO: The GC target shouldn't really be part of CmmInfo
 -- as it doesn't appear in the resulting info table.
@@ -146,6 +151,13 @@ type SlowEntry = CmmLit
   -- for now the parser sets this to zero on an INFO_TABLE_FUN.
 type SelectorOffset = StgWord
 
+-- | A frame that is to be pushed before entry to the function.
+-- Used to handle 'update' frames.
+data UpdateFrame =
+    UpdateFrame
+      CmmExpr    -- Frame header.  Behaves like the target of a 'jump'.
+      [CmmExpr]  -- Frame remainder.  Behaves like the arguments of a 'jump'.
+
 -----------------------------------------------------------------------------
 --		CmmStmt
 -- A "statement".  Note that all branches are explicit: there are no

compiler/cmm/CmmCPS.hs

@@ -87,23 +87,19 @@ make_gc_check stack_use gc_block =
 
 force_gc_block old_info stack_use block_id fun_label formals =
     case old_info of
-      CmmNonInfo (Just existing) -> (old_info, [], make_gc_check stack_use existing)
-      CmmInfo _ (Just existing) _ _ -> (old_info, [], make_gc_check stack_use existing)
-      CmmNonInfo Nothing
-          -> (CmmNonInfo (Just block_id),
-              [make_gc_block block_id fun_label formals (CmmSafe NoC_SRT)],
+      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)
-      CmmInfo prof Nothing type_tag type_info
-          -> (CmmInfo prof (Just block_id) type_tag type_info,
-              [make_gc_block block_id fun_label formals (CmmSafe srt)],
-              make_gc_check stack_use block_id)
-             where
-               srt = case type_info of
-                       ConstrInfo _ _ _ -> NoC_SRT
-                       FunInfo _ srt' _ _ _ _ -> srt'
-                       ThunkInfo _ srt' -> srt'
-                       ThunkSelectorInfo _ srt' -> srt'
-                       ContInfo _ srt' -> srt'
+
+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
 
 -----------------------------------------------------------------------------
 -- |CPS a single CmmTop (proceedure)
@@ -127,7 +123,7 @@ cpsProc uniqSupply (CmmProc info ident params blocks) = cps_procs
       (uniqSupply1, uniqSupply2) = splitUniqSupply uniqSupply
       uniques :: [[Unique]]
       uniques = map uniqsFromSupply $ listSplitUniqSupply uniqSupply1
-      (gc_unique:stack_use_unique:info_uniques):adaptor_uniques:block_uniques = uniques
+      (gc_unique:gc_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)
@@ -136,16 +132,17 @@ cpsProc uniqSupply (CmmProc info ident params blocks) = cps_procs
       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 =
-          case blocks of
-            (BasicBlock id stmts) : bs ->
-                (BasicBlock id (check_stmts ++ stmts)) : (bs ++ gc_blocks)
-            [] -> [] -- If there is no code then we don't need a stack check
+      forced_blocks = 
+          BasicBlock gc_block_id
+                     (check_stmts++[CmmBranch $ blockId $ head blocks]) :
+          blocks ++ gc_blocks
 
       forced_gc_id = case forced_info of
-                       CmmNonInfo (Just x) -> x
-                       CmmInfo _ (Just x) _ _ -> x
+                       CmmInfo (Just x) _ _ -> x
+
+      update_frame = case info of CmmInfo _ u _ -> u
 
       -- Break the block at each function call.
       -- The part after the function call will have to become a continuation.
@@ -199,13 +196,13 @@ cpsProc uniqSupply (CmmProc info ident params blocks) = cps_procs
 
       -- Do a little meta-processing on the stack formats such as
       -- getting the individual frame sizes and the maximum frame size
-      formats' :: (WordOff, [(CLabel, ContinuationFormat)])
-      formats' = processFormats formats continuations
+      formats' :: (WordOff, WordOff, [(CLabel, ContinuationFormat)])
+      formats'@(_, _, format_list) = processFormats formats update_frame continuations
 
       -- Update the info table data on the continuations with
       -- the selected stack formats.
       continuations' :: [Continuation CmmInfo]
-      continuations' = map (applyContinuationFormat (snd formats')) continuations
+      continuations' = map (applyContinuationFormat format_list) continuations
 
       -- Do the actual CPS transform.
       cps_procs :: [CmmTop]
@@ -257,7 +254,7 @@ gatherBlocksIntoContinuation live proc_points blocks start =
       info_table = case start_block_entry of
                      FunctionEntry info _ _ -> Right info
                      ContinuationEntry _ srt _ -> Left srt
-                     ControlEntry -> Right (CmmNonInfo Nothing)
+                     ControlEntry -> Right (CmmInfo Nothing Nothing CmmNonInfoTable)
 
       is_gc_cont = case start_block_entry of
                      FunctionEntry _ _ _ -> False
@@ -287,7 +284,7 @@ selectContinuationFormat live continuations =
     where
       -- User written continuations
       selectContinuationFormat' (Continuation
-                          (Right (CmmInfo _ _ _ (ContInfo format srt)))
+                          (Right (CmmInfo _ _ (CmmInfoTable _ _ (ContInfo format srt))))
                           label formals _ _) =
           (formals, Just label, format)
       -- Either user written non-continuation code
@@ -306,9 +303,11 @@ selectContinuationFormat live continuations =
       unknown_block = panic "unknown BlockId in selectContinuationFormat"
 
 processFormats :: [(CLabel, (CmmFormals, Maybe CLabel, [Maybe LocalReg]))]
+               -> Maybe UpdateFrame
                -> [Continuation (Either C_SRT CmmInfo)]
-               -> (WordOff, [(CLabel, ContinuationFormat)])
-processFormats formats continuations = (max_size, formats')
+               -> (WordOff, WordOff, [(CLabel, ContinuationFormat)])
+processFormats formats update_frame continuations =
+    (max_size + update_frame_size, update_frame_size, formats')
     where
       max_size = maximum $
                  0 : map (continuationMaxStack formats') continuations
@@ -324,6 +323,17 @@ processFormats formats continuations = (max_size, formats')
                                 else 0,
              continuation_stack = stack })
 
+      update_frame_size = case update_frame of
+                            Nothing -> 0
+                            (Just (UpdateFrame _ args))
+                                -> label_size + update_size args
+
+      update_size [] = 0
+      update_size (expr:exprs) = width + update_size exprs
+          where
+            width = machRepByteWidth (cmmExprRep expr) `quot` wORD_SIZE
+            -- TODO: it would be better if we had a machRepWordWidth
+
       -- TODO: get rid of "+ 1" etc.
       label_size = 1 :: WordOff
 
@@ -381,9 +391,9 @@ applyContinuationFormat :: [(CLabel, ContinuationFormat)]
 
 -- User written continuations
 applyContinuationFormat formats (Continuation
-                          (Right (CmmInfo prof gc tag (ContInfo _ srt)))
+                          (Right (CmmInfo gc update_frame (CmmInfoTable prof tag (ContInfo _ srt))))
                           label formals is_gc blocks) =
-    Continuation (CmmInfo prof gc tag (ContInfo format srt))
+    Continuation (CmmInfo gc update_frame (CmmInfoTable prof tag (ContInfo format srt)))
                  label formals is_gc blocks
     where
       format = continuation_stack $ maybe unknown_block id $ lookup label formats
@@ -397,7 +407,7 @@ applyContinuationFormat formats (Continuation
 -- CPS generated continuations
 applyContinuationFormat formats (Continuation
                           (Left srt) label formals is_gc blocks) =
-    Continuation (CmmInfo prof gc tag (ContInfo (continuation_stack $ format) srt))
+    Continuation (CmmInfo gc Nothing (CmmInfoTable prof tag (ContInfo (continuation_stack $ format) srt)))
                  label formals is_gc blocks
     where
       gc = Nothing -- Generated continuations never need a stack check

compiler/cmm/CmmCPSGen.hs

@@ -78,12 +78,12 @@ data ContinuationFormat
 -- A block can be an entry to a function
 
 -----------------------------------------------------------------------------
-continuationToProc :: (WordOff, [(CLabel, ContinuationFormat)])
+continuationToProc :: (WordOff, WordOff, [(CLabel, ContinuationFormat)])
                    -> CmmReg
                    -> [[Unique]]
                    -> Continuation CmmInfo
                    -> CmmTop
-continuationToProc (max_stack, formats) stack_use uniques
+continuationToProc (max_stack, update_frame_size, formats) stack_use uniques
                    (Continuation info label formals _ blocks) =
     CmmProc info label formals (concat $ zipWith3 continuationToProc' uniques blocks (True : repeat False))
     where
@@ -98,14 +98,18 @@ continuationToProc (max_stack, formats) stack_use uniques
       gc_stmts :: [CmmStmt]
       gc_stmts =
           case info of
-            CmmInfo _ (Just gc_block) _ _ ->
+            CmmInfo (Just gc_block) _ _ ->
                 gc_stack_check' stack_use arg_stack (max_stack - curr_stack)
-            CmmInfo _ Nothing _ _ ->
+            CmmInfo Nothing _ _ ->
                 panic "continuationToProc: missing GC block"
-            CmmNonInfo (Just gc_block) ->
-                gc_stack_check' stack_use arg_stack (max_stack - curr_stack)
-            CmmNonInfo Nothing ->
-                panic "continuationToProc: missing non-info GC block"
+
+      update_stmts :: [CmmStmt]
+      update_stmts =
+          case info of
+            CmmInfo _ (Just (UpdateFrame target args)) _ ->
+                pack_frame curr_stack update_frame_size (Just target) (map Just args) ++
+                adjust_sp_reg (curr_stack - update_frame_size)
+            CmmInfo _ Nothing _ -> []
 
 -- At present neither the Cmm parser nor the code generator
 -- produce code that will allow the target of a CmmCondBranch
@@ -148,7 +152,18 @@ continuationToProc (max_stack, formats) stack_use uniques
             block_for_branch' unique (Just next) = (Just new_next, new_blocks)
               where (new_next, new_blocks) = block_for_branch unique next
 
-            main_block = BasicBlock ident (stmts ++ postfix_stmts)
+            main_block =
+                case entry of
+                  FunctionEntry _ _ _ ->
+                      -- Ugh, the statements for an update frame must come
+                      -- *after* the GC check that was added at the beginning
+                      -- of the CPS pass.  So we have do edit the statements
+                      -- 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)
+                  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
@@ -336,20 +351,21 @@ currentNursery 	  = CmmGlobal CurrentNursery
 
 tail_call :: WordOff -> CmmExpr -> CmmActuals -> [CmmStmt]
 tail_call spRel target arguments
-  = store_arguments ++ adjust_spReg ++ jump where
+  = store_arguments ++ adjust_sp_reg spRel ++ jump where
     store_arguments =
         [stack_put spRel expr offset
          | ((expr, _), StackParam offset) <- argument_formats] ++
         [global_put expr global
          | ((expr, _), RegisterParam global) <- argument_formats]
-    adjust_spReg =
-        if spRel == 0
-        then []
-        else [CmmAssign spReg (CmmRegOff spReg (spRel*wORD_SIZE))]
     jump = [CmmJump target arguments]
 
     argument_formats = assignArguments (cmmExprRep . fst) arguments
 
+adjust_sp_reg spRel =
+    if spRel == 0
+    then []
+    else [CmmAssign spReg (CmmRegOff spReg (spRel*wORD_SIZE))]
+
 gc_stack_check' stack_use arg_stack max_frame_size =
     if max_frame_size > arg_stack
     then [CmmAssign stack_use (CmmRegOff spReg (-max_frame_size*wORD_SIZE))]
@@ -367,10 +383,6 @@ gc_stack_check gc_block max_frame_size
      gc_block]
 
 
--- TODO: fix branches to proc point
--- (we have to insert a new block to marshel the continuation)
-
-
 pack_continuation :: Bool               -- ^ Whether to set the top/header
                                         -- of the stack.  We only need to
                                         -- set it if we are calling down
@@ -382,35 +394,52 @@ pack_continuation :: Bool               -- ^ Whether to set the top/header
 pack_continuation allow_header_set
                       (ContinuationFormat _ curr_id curr_frame_size _)
                       (ContinuationFormat _ cont_id cont_frame_size live_regs)
-  = store_live_values ++ set_stack_header where
+  = 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 =
+        case (curr_id, cont_id) of
+          (Just x, Just y) -> x /= y
+          _ -> isJust cont_id
+
+    maybe_header = if allow_header_set && needs_header_set
+                   then Just continuation_function
+                   else Nothing
+
+pack_frame :: WordOff         -- ^ Current frame size
+           -> WordOff         -- ^ Next frame size
+           -> Maybe CmmExpr   -- ^ Next frame header if any
+           -> [Maybe CmmExpr] -- ^ Next frame data
+           -> [CmmStmt]
+pack_frame curr_frame_size next_frame_size next_frame_header frame_args =
+    store_live_values ++ set_stack_header
+    where
     -- TODO: only save variables when actually needed
     -- (may be handled by latter pass)
     store_live_values =
-        [stack_put spRel (CmmReg (CmmLocal reg)) offset
-         | (reg, offset) <- cont_offsets]
+        [stack_put spRel expr offset
+         | (expr, offset) <- cont_offsets]
     set_stack_header =
-        if needs_header_set && allow_header_set
-        then [stack_put spRel continuation_function 0]
-        else []
+        case next_frame_header of
+          Nothing -> []
+          Just expr -> [stack_put spRel expr 0]
 
     -- TODO: factor with function_entry and CmmInfo.hs(?)
-    cont_offsets = mkOffsets label_size live_regs
+    cont_offsets = mkOffsets label_size frame_args
 
     label_size = 1 :: WordOff
 
     mkOffsets size [] = []
-    mkOffsets size (Nothing:regs) = mkOffsets (size+1) regs
-    mkOffsets size (Just reg:regs) = (reg, size):mkOffsets (size + width) regs
+    mkOffsets size (Nothing:exprs) = mkOffsets (size+1) exprs
+    mkOffsets size (Just expr:exprs) = (expr, size):mkOffsets (size + width) exprs
         where
-          width = machRepByteWidth (localRegRep reg) `quot` wORD_SIZE
+          width = machRepByteWidth (cmmExprRep expr) `quot` wORD_SIZE
           -- TODO: it would be better if we had a machRepWordWidth
 
-    spRel = curr_frame_size - cont_frame_size
-    continuation_function = CmmLit $ CmmLabel $ fromJust cont_id
-    needs_header_set =
-        case (curr_id, cont_id) of
-          (Just x, Just y) -> x /= y
-          _ -> isJust cont_id
+    spRel = curr_frame_size - next_frame_size
+
 
 -- Lazy adjustment of stack headers assumes all blocks
 -- that could branch to eachother (i.e. control blocks)

compiler/cmm/CmmInfo.hs

@@ -71,15 +71,15 @@ cmmToRawCmm cmm = do
 
 mkInfoTable :: Unique -> CmmTop -> [RawCmmTop]
 mkInfoTable uniq (CmmData sec dat) = [CmmData sec dat]
-mkInfoTable uniq (CmmProc info entry_label arguments blocks) =
+mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label arguments blocks) =
     case info of
       -- | Code without an info table.  Easy.
-      CmmNonInfo _ -> [CmmProc [] entry_label arguments blocks]
+      CmmNonInfoTable -> [CmmProc [] entry_label arguments blocks]
 
       -- | A function entry point.
-      CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag
-              (FunInfo (ptrs, nptrs) srt fun_type fun_arity
-                       pap_bitmap slow_entry) ->
+      CmmInfoTable (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
           where
@@ -97,8 +97,8 @@ mkInfoTable uniq (CmmProc info entry_label arguments blocks) =
             layout = packHalfWordsCLit ptrs nptrs
 
       -- | A constructor.
-      CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag
-              (ConstrInfo (ptrs, nptrs) con_tag descr) ->
+      CmmInfoTable (ProfilingInfo ty_prof cl_prof) type_tag
+                   (ConstrInfo (ptrs, nptrs) con_tag descr) ->
           mkInfoTableAndCode info_label std_info [con_name] entry_label
                              arguments blocks
           where
@@ -108,8 +108,8 @@ mkInfoTable uniq (CmmProc info entry_label arguments blocks) =
             layout = packHalfWordsCLit ptrs nptrs
 
       -- | A thunk.
-      CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag
-              (ThunkInfo (ptrs, nptrs) srt) ->
+      CmmInfoTable (ProfilingInfo ty_prof cl_prof) type_tag
+                   (ThunkInfo (ptrs, nptrs) srt) ->
           mkInfoTableAndCode info_label std_info srt_label entry_label
                              arguments blocks
           where
@@ -119,8 +119,8 @@ mkInfoTable uniq (CmmProc info entry_label arguments blocks) =
             layout = packHalfWordsCLit ptrs nptrs
 
       -- | A selector thunk.
-      CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag
-              (ThunkSelectorInfo offset srt) ->
+      CmmInfoTable (ProfilingInfo ty_prof cl_prof) type_tag
+                   (ThunkSelectorInfo offset srt) ->
           mkInfoTableAndCode info_label std_info [{- no SRT -}] entry_label
                              arguments blocks
           where
@@ -128,7 +128,8 @@ mkInfoTable uniq (CmmProc info entry_label arguments blocks) =
             info_label = entryLblToInfoLbl entry_label
 
       -- A continuation/return-point.
-      CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag (ContInfo stack_layout srt) ->
+      CmmInfoTable (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,47 +200,49 @@ lits	:: { [ExtFCode CmmExpr] }
 
 cmmproc :: { ExtCode }
 -- TODO: add real SRT/info tables to parsed Cmm
-	: info maybe_formals '{' body '}'
-		{ do ((info_lbl, info, live, formals), stmts) <-
+	: info maybe_formals maybe_frame '{' body '}'
+		{ do ((info_lbl, info, live, formals, frame), stmts) <-
 		       getCgStmtsEC' $ loopDecls $ do {
 		         (info_lbl, info, live) <- $1;
 		         formals <- sequence $2;
-		         $4;
-		         return (info_lbl, info, live, formals) }
+		         frame <- $3;
+		         $5;
+		         return (info_lbl, info, live, formals, frame) }
 		     blks <- code (cgStmtsToBlocks stmts)
-		     code (emitInfoTableAndCode info_lbl info formals blks) }
+		     code (emitInfoTableAndCode info_lbl (CmmInfo Nothing frame info) formals blks) }
 
 	| info maybe_formals ';'
 		{ do (info_lbl, info, live) <- $1;
 		     formals <- sequence $2;
-		     code (emitInfoTableAndCode info_lbl info formals []) }
+		     code (emitInfoTableAndCode info_lbl (CmmInfo Nothing Nothing info) formals []) }
 
-	| NAME maybe_formals '{' body '}'
-		{ do (formals, stmts) <-
+	| NAME maybe_formals maybe_frame '{' body '}'
+		{ do ((formals, frame), stmts) <-
 			getCgStmtsEC' $ loopDecls $ do {
 		          formals <- sequence $2;
-		          $4;
-		          return formals }
+			  frame <- $3;
+		          $5;
+		          return (formals, frame) }
                      blks <- code (cgStmtsToBlocks stmts)
-		     code (emitProc (CmmNonInfo Nothing) (mkRtsCodeLabelFS $1) formals blks) }
+		     code (emitProc (CmmInfo Nothing frame CmmNonInfoTable) (mkRtsCodeLabelFS $1) formals blks) }
 
-info	:: { ExtFCode (CLabel, CmmInfo, [Maybe LocalReg]) }
+info	:: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
 	: 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
 		-- ptrs, nptrs, closure type, description, type
 		{ do prof <- profilingInfo $11 $13
 		     return (mkRtsInfoLabelFS $3,
-			CmmInfo prof Nothing (fromIntegral $9)
-				(ThunkInfo (fromIntegral $5, fromIntegral $7) NoC_SRT),
+			CmmInfoTable prof (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
 		{ do prof <- profilingInfo $11 $13
 		     return (mkRtsInfoLabelFS $3,
-			CmmInfo prof Nothing (fromIntegral $9)
-				(FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $15) 0
-				 (ArgSpec 0)
-				 zeroCLit),
+			CmmInfoTable prof (fromIntegral $9)
+				     (FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $15) 0
+				      (ArgSpec 0)
+				      zeroCLit),
 			[]) }
 		-- we leave most of the fields zero here.  This is only used
 		-- to generate the BCO info table in the RTS at the moment.
@@ -252,31 +254,31 @@ info	:: { ExtFCode (CLabel, CmmInfo, [Maybe LocalReg]) }
 		     -- 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),
+			CmmInfoTable prof (fromIntegral $11)
+				     (ConstrInfo (fromIntegral $5, fromIntegral $7) (fromIntegral $9) desc_lit),
 			[]) }
 	
 	| 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
 		-- selector, closure type, description, type
 		{ do prof <- profilingInfo $9 $11
 		     return (mkRtsInfoLabelFS $3,
-			CmmInfo prof Nothing (fromIntegral $7)
-				(ThunkSelectorInfo (fromIntegral $5) NoC_SRT),
+			CmmInfoTable prof (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),
+			CmmInfoTable (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5)
+				     (ContInfo [] NoC_SRT),
 			[]) }
 
 	| 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')'
 		-- 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),
+			CmmInfoTable (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5)
+			             (ContInfo live NoC_SRT),
 			live) }
 
 body	:: { ExtCode }
@@ -503,6 +505,12 @@ formal :: { ExtFCode LocalReg }
 	| STRING type NAME	{% do k <- parseKind $1;
 				     return $ newLocal k $2 $3 }
 
+maybe_frame :: { ExtFCode (Maybe UpdateFrame) }
+	: {- empty -}			{ return Nothing }
+	| 'jump' expr '(' exprs0 ')'	{ do { target <- $2;
+					       args <- sequence $4;
+					       return $ Just (UpdateFrame target args) } }
+
 type	:: { MachRep }
 	: 'bits8'		{ I8 }
 	| typenot8		{ $1 }

compiler/cmm/PprCmm.hs

@@ -129,17 +129,19 @@ instance Outputable CmmSafety where
 -- 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 gc_target) =
-    ptext SLIT("gc_target: ") <>
-          ptext SLIT("TODO") --maybe (ptext SLIT("<none>")) pprBlockId gc_target
-          -- ^ gc_target is currently unused and wired to a panic
-pprInfo (CmmInfo (ProfilingInfo closure_type closure_desc)
-                 gc_target tag info) =
-    vcat [ptext SLIT("type: ") <> pprLit closure_type,
+pprInfo (CmmInfo gc_target update_frame CmmNonInfoTable) =
+    vcat [ptext SLIT("gc_target: ") <>
+                maybe (ptext SLIT("<none>")) pprBlockId gc_target,
+          ptext SLIT("update_frame: ") <>
+                maybe (ptext SLIT("<none>")) pprUpdateFrame update_frame]
+pprInfo (CmmInfo gc_target update_frame
+         (CmmInfoTable (ProfilingInfo closure_type closure_desc) tag info)) =
+    vcat [ptext SLIT("gc_target: ") <>
+                maybe (ptext SLIT("<none>")) pprBlockId gc_target,
+          ptext SLIT("update_frame: ") <>
+                maybe (ptext SLIT("<none>")) pprUpdateFrame update_frame,
+          ptext SLIT("type: ") <> pprLit closure_type,
           ptext SLIT("desc: ") <> pprLit closure_desc,
-          ptext SLIT("gc_target: ") <>
-                ptext SLIT("TODO"), --maybe (ptext SLIT("<none>")) pprBlockId gc_target,
-                -- ^ gc_target is currently unused and wired to a panic
           ptext SLIT("tag: ") <> integer (toInteger tag),
           pprTypeInfo info]
 
@@ -168,6 +170,19 @@ pprTypeInfo (ContInfo stack srt) =
     vcat [ptext SLIT("stack: ") <> ppr stack,
           ptext SLIT("srt: ") <> ppr srt]
 
+pprUpdateFrame :: UpdateFrame -> SDoc
+pprUpdateFrame (UpdateFrame expr args) = 
+    hcat [ ptext SLIT("jump")
+         , space
+         , if isTrivialCmmExpr expr
+                then pprExpr expr
+                else case expr of
+                    CmmLoad (CmmReg _) _ -> pprExpr expr 
+                    _ -> parens (pprExpr expr)
+         , space
+         , parens  ( commafy $ map ppr args ) ]
+
+
 -- --------------------------------------------------------------------------
 -- Basic blocks look like assembly blocks.
 --      lbl: stmt ; stmt ; .. 

compiler/codeGen/CgInfoTbls.hs

@@ -89,12 +89,12 @@ mkCmmInfo cl_info = do
            info = ConstrInfo (ptrs, nptrs)
                              (fromIntegral (dataConTagZ con))
                              conName
-       return $ CmmInfo prof gc_target cl_type info
+       return $ CmmInfo gc_target Nothing (CmmInfoTable prof cl_type info)
 
     ClosureInfo { closureName   = name,
                   closureLFInfo = lf_info,
                   closureSRT    = srt } ->
-       return $ CmmInfo prof gc_target cl_type info
+       return $ CmmInfo gc_target Nothing (CmmInfoTable prof cl_type info)
        where
          info =
              case lf_info of
@@ -145,10 +145,12 @@ emitReturnTarget name stmts
 	; blks <- cgStmtsToBlocks stmts
         ; frame <- mkStackLayout
         ; let info = CmmInfo
-                       (ProfilingInfo zeroCLit zeroCLit)
                        gc_target
-                       rET_SMALL -- cmmToRawCmm may convert it to rET_BIG
-                       (ContInfo frame srt_info)
+                       Nothing
+                       (CmmInfoTable
+                        (ProfilingInfo zeroCLit zeroCLit)
+                        rET_SMALL -- cmmToRawCmm may convert it to rET_BIG
+                        (ContInfo frame srt_info))
         ; emitInfoTableAndCode info_lbl info args blks
 	; return info_lbl }
   where

compiler/codeGen/CgMonad.lhs

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