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)

diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs
index f5525a7..9038534 100644 (file)
--- a/compiler/cmm/Cmm.hs
+++ b/compiler/cmm/Cmm.hs
@@ -115,11 +115,17 @@ data CmmInfo
       ClosureTypeTag -- Int
       ClosureTypeInfo
   | CmmNonInfo   -- Procedure doesn't need an info table
       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
 
 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
   | 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 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 FunType = StgHalfWord
 type FunArity = StgHalfWord
 type SlowEntry = CLabel

+type SelectorOffset = StgWord

 
 -----------------------------------------------------------------------------
 --             CmmStmt
 
 -----------------------------------------------------------------------------
 --             CmmStmt

diff --git a/compiler/cmm/CmmCPS.hs b/compiler/cmm/CmmCPS.hs
index f26e55f..be9f474 100644 (file)
--- a/compiler/cmm/CmmCPS.hs
+++ b/compiler/cmm/CmmCPS.hs
@@ -69,6 +69,34 @@ cmmCPS dflags abstractC = do
 
   return continuationC
 
 
   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.
 -----------------------------------------------------------------------------
 -- |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
     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 =
 
       -- 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.
       --
 
       -- 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)]
 
       -- 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
 
       -- 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
 
 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
     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
     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
       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)
 
         -- 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
 
 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
   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
       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)
       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
 
       -- 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
       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
 
       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 ->
                            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
                            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
                        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)
     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]
 
      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)
 pack_continuation :: StackFormat -> StackFormat -> [CmmStmt]
 pack_continuation (StackFormat curr_id curr_frame_size _)
                        (StackFormat cont_id cont_frame_size live_regs)

diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs
index 80c892f..ab46f1e 100644 (file)
--- a/compiler/cmm/CmmInfo.hs
+++ b/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
 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
       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
           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
             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
 
                        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
       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

diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index ab50799..7fc4c43 100644 (file)
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -200,44 +200,70 @@ 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, 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);
                { 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
        : '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
        
        | '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
        
        | '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
        
        | '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 () }
 
 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
 
  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
 
 staticClosure :: FastString -> FastString -> [CmmLit] -> ExtCode
 staticClosure cl_label info payload

diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs
index 2d48f76..15a723a 100644 (file)
--- a/compiler/cmm/CmmProcPoint.hs
+++ b/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
       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 $
     where
       init_proc_points = mkUniqSet $
                          map brokenBlockId $

diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs
index 55a8014..97170a1 100644 (file)
--- a/compiler/cmm/PprCmm.hs
+++ b/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".
 -- 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,
 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),
     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)),
 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]
     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]
 pprTypeInfo (ContInfo stack srt) =
     vcat [ptext SLIT("stack: ") <> ppr stack,
           ptext SLIT("srt: ") <> ppr srt]

diff --git a/compiler/codeGen/CgMonad.lhs b/compiler/codeGen/CgMonad.lhs
index e3c8a77..d40c511 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 lbl [] blks }
+       ; emitProc (CmmNonInfo Nothing) 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)