Added support for update frames to the CPS pass

(This required a bit of refactoring of CmmInfo.)

diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs
index 1f7161b..8fef400 100644 (file)
--- a/compiler/cmm/Cmm.hs
+++ b/compiler/cmm/Cmm.hs
@@ -9,7 +9,8 @@
 module Cmm ( 
        GenCmm(..), Cmm, RawCmm,
        GenCmmTop(..), CmmTop, RawCmmTop,
 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(..),
        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 Tables
 -----------------------------------------------------------------------------
 

--- Info table as a haskell data type

 data CmmInfo
   = CmmInfo
 data CmmInfo
   = CmmInfo

-      ProfilingInfo

       (Maybe BlockId) -- GC target
       (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
       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.
 
 -- 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
 
   -- 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
 -----------------------------------------------------------------------------
 --             CmmStmt
 -- A "statement".  Note that all branches are explicit: there are no

diff --git a/compiler/cmm/CmmCPS.hs b/compiler/cmm/CmmCPS.hs
index cb36de4..feabb7f 100644 (file)
--- a/compiler/cmm/CmmCPS.hs
+++ b/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
 
 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)
               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)
 
 -----------------------------------------------------------------------------
 -- |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
       (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)
       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
       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
 
       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.
 
       -- 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
 
       -- 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]
 
       -- 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]
 
       -- 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
       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
 
       is_gc_cont = case start_block_entry of
                      FunctionEntry _ _ _ -> False

@@ -287,7 +284,7 @@ selectContinuationFormat live continuations =
     where
       -- User written continuations
       selectContinuationFormat' (Continuation
     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
                           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]))]
       unknown_block = panic "unknown BlockId in selectContinuationFormat"
 
 processFormats :: [(CLabel, (CmmFormals, Maybe CLabel, [Maybe LocalReg]))]

+               -> Maybe UpdateFrame

                -> [Continuation (Either C_SRT CmmInfo)]
                -> [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
     where
       max_size = maximum $
                  0 : map (continuationMaxStack formats') continuations

@@ -324,6 +323,17 @@ processFormats formats continuations = (max_size, formats')
                                 else 0,
              continuation_stack = stack })
 
                                 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
 
       -- TODO: get rid of "+ 1" etc.
       label_size = 1 :: WordOff
 

@@ -381,9 +391,9 @@ applyContinuationFormat :: [(CLabel, ContinuationFormat)]
 
 -- User written continuations
 applyContinuationFormat formats (Continuation
 
 -- 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) =
                           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
                  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) =
 -- 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
                  label formals is_gc blocks
     where
       gc = Nothing -- Generated continuations never need a stack check

diff --git a/compiler/cmm/CmmCPSGen.hs b/compiler/cmm/CmmCPSGen.hs
index b2c4305..49ac9ab 100644 (file)
--- a/compiler/cmm/CmmCPSGen.hs
+++ b/compiler/cmm/CmmCPSGen.hs
@@ -78,12 +78,12 @@ data ContinuationFormat
 -- A block can be an entry to a function
 
 -----------------------------------------------------------------------------
 -- A block can be an entry to a function
 
 -----------------------------------------------------------------------------

-continuationToProc :: (WordOff, [(CLabel, ContinuationFormat)])
+continuationToProc :: (WordOff, WordOff, [(CLabel, ContinuationFormat)])

                    -> CmmReg
                    -> [[Unique]]
                    -> Continuation CmmInfo
                    -> CmmTop
                    -> 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
                    (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
       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)
                 gc_stack_check' stack_use arg_stack (max_stack - curr_stack)

-            CmmInfo _ Nothing _ _ ->
+            CmmInfo Nothing _ _ ->

                 panic "continuationToProc: missing GC block"
                 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
 
 -- 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
 
             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
             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
 
 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]
     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
 
     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))]
 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]
 
 
      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
 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)
 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 =
     -- 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 =
     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(?)
 
     -- 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 [] = []
 
     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
         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
 
           -- 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)
 
 -- Lazy adjustment of stack headers assumes all blocks
 -- that could branch to eachother (i.e. control blocks)

diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs
index 3f458b5..78ff5af 100644 (file)
--- a/compiler/cmm/CmmInfo.hs
+++ b/compiler/cmm/CmmInfo.hs
@@ -71,15 +71,15 @@ cmmToRawCmm cmm = do
 
 mkInfoTable :: Unique -> CmmTop -> [RawCmmTop]
 mkInfoTable uniq (CmmData sec dat) = [CmmData sec dat]
 
 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.
     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.
 
       -- | 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
           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.
             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
           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.
             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
           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.
             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
           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.
             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
           liveness_data ++
           mkInfoTableAndCode info_label std_info srt_label entry_label
                              arguments blocks

diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 27fce3b..32512fe 100644 (file)
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -200,47 +200,49 @@ lits      :: { [ExtFCode CmmExpr] }
 
 cmmproc :: { ExtCode }
 -- TODO: add real SRT/info tables to parsed Cmm
 
 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;
                       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)
                     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;
 
        | 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;
                        getCgStmtsEC' $ loopDecls $ do {
                          formals <- sequence $2;

-                         $4;
-                         return formals }
+                         frame <- $3;
+                         $5;
+                         return (formals, frame) }

                      blks <- code (cgStmtsToBlocks stmts)
                      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,
        : '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,
                        []) }
        
        | '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.
                        []) }
                -- 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,
                     -- 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,
                        []) }
        
        | '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,
                        []) }
 
        | '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,
                        []) }
 
        | '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 }
                        live) }
 
 body   :: { ExtCode }

@@ -503,6 +505,12 @@ formal :: { ExtFCode LocalReg }
        | STRING type NAME      {% do k <- parseKind $1;
                                     return $ newLocal k $2 $3 }
 
        | 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 }
 type   :: { MachRep }
        : 'bits8'               { I8 }
        | typenot8              { $1 }

diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs
index 866a1c9..602f51c 100644 (file)
--- a/compiler/cmm/PprCmm.hs
+++ b/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".
 -- 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("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]
 
           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]
 
     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 ; .. 
 -- --------------------------------------------------------------------------
 -- Basic blocks look like assembly blocks.
 --      lbl: stmt ; stmt ; .. 

diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs
index 6d270ae..f6277f1 100644 (file)
--- a/compiler/codeGen/CgInfoTbls.hs
+++ b/compiler/codeGen/CgInfoTbls.hs
@@ -89,12 +89,12 @@ mkCmmInfo cl_info = do
            info = ConstrInfo (ptrs, nptrs)
                              (fromIntegral (dataConTagZ con))
                              conName
            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 } ->
 
     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
        where
          info =
              case lf_info of

@@ -145,10 +145,12 @@ emitReturnTarget name stmts
        ; blks <- cgStmtsToBlocks stmts
         ; frame <- mkStackLayout
         ; let info = CmmInfo
        ; blks <- cgStmtsToBlocks stmts
         ; frame <- mkStackLayout
         ; let info = CmmInfo

-                       (ProfilingInfo zeroCLit zeroCLit)

                        gc_target
                        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
         ; emitInfoTableAndCode info_lbl info args blks
        ; return info_lbl }
   where

diff --git a/compiler/codeGen/CgMonad.lhs b/compiler/codeGen/CgMonad.lhs
index d40c511..6885912 100644 (file)
--- a/compiler/codeGen/CgMonad.lhs
+++ b/compiler/codeGen/CgMonad.lhs
@@ -745,7 +745,7 @@ emitSimpleProc :: CLabel -> Code -> Code
 emitSimpleProc lbl code
   = do { stmts <- getCgStmts code
        ; blks <- cgStmtsToBlocks stmts
 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)
 
 getCmm :: Code -> FCode Cmm
 -- Get all the CmmTops (there should be no stmts)