Implemented and fixed bugs in CmmInfo handling

1 files changed, 186 insertions, 50 deletions

diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs
index ab46f1e58d..5937dd4fb9 100644
--- a/compiler/cmm/CmmInfo.hs
+++ b/compiler/cmm/CmmInfo.hs
@@ -1,4 +1,5 @@
 module CmmInfo (
+  cmmToRawCmm,
   mkInfoTable
 ) where
 
@@ -6,30 +7,81 @@ module CmmInfo (
 
 import Cmm
 import CmmUtils
+import PprCmm
 
 import CLabel
+import MachOp
 
 import Bitmap
 import ClosureInfo
 import CgInfoTbls
 import CgCallConv
 import CgUtils
+import SMRep
 
 import Constants
 import StaticFlags
+import DynFlags
 import Unique
+import UniqSupply
 import Panic
 
 import Data.Bits
 
+cmmToRawCmm :: [Cmm] -> IO [RawCmm]
+cmmToRawCmm cmm = do
+  info_tbl_uniques <- mkSplitUniqSupply 'i'
+  return $ zipWith raw_cmm (listSplitUniqSupply info_tbl_uniques) cmm
+    where
+      raw_cmm uniq_supply (Cmm procs) =
+          Cmm $ concat $ zipWith mkInfoTable (uniqsFromSupply uniq_supply) procs
+
+-- Make a concrete info table, represented as a list of CmmStatic
+-- (it can't be simply a list of Word, because the SRT field is
+-- represented by a label+offset expression).
+--
+-- With tablesNextToCode, the layout is
+--	<reversed variable part>
+--	<normal forward StgInfoTable, but without 
+--		an entry point at the front>
+--	<code>
+--
+-- Without tablesNextToCode, the layout of an info table is
+--	<entry label>
+--	<normal forward rest of StgInfoTable>
+--	<forward variable part>
+--
+--	See includes/InfoTables.h
+--
+-- For return-points these are as follows
+--
+-- Tables next to code:
+--
+--			<srt slot>
+--			<standard info table>
+--  	ret-addr -->	<entry code (if any)>
+--
+-- Not tables-next-to-code:
+--
+--	ret-addr -->	<ptr to entry code>
+--			<standard info table>
+--			<srt slot>
+--
+--  * The SRT slot is only there if there is SRT info to record
+
 mkInfoTable :: Unique -> CmmTop -> [RawCmmTop]
 mkInfoTable uniq (CmmData sec dat) = [CmmData sec dat]
 mkInfoTable uniq (CmmProc info entry_label arguments blocks) =
     case info of
+      -- | Code without an info table.  Easy.
       CmmNonInfo _ -> [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) ->
-          mkInfoTableAndCode info_label std_info fun_extra_bits entry_label arguments blocks
+              (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
             fun_extra_bits =
                [packHalfWordsCLit fun_type fun_arity] ++
@@ -37,71 +89,74 @@ mkInfoTable uniq (CmmProc info entry_label arguments blocks) =
                case pap_bitmap of
                  ArgGen liveness ->
                      [makeRelativeRefTo info_label $ mkLivenessCLit liveness,
-                      makeRelativeRefTo info_label (CmmLabel slow_entry)]
+                      makeRelativeRefTo info_label slow_entry]
                  _ -> []
             std_info = mkStdInfoTable ty_prof cl_prof type_tag srt_bitmap layout
             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)
+            (srt_label, srt_bitmap) = mkSRTLit info_label srt
             layout = packHalfWordsCLit ptrs nptrs
 
+      -- | A constructor.
       CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag
               (ConstrInfo (ptrs, nptrs) con_tag descr) ->
-          mkInfoTableAndCode info_label std_info [con_name] entry_label arguments blocks
+          mkInfoTableAndCode info_label std_info [con_name] entry_label
+                             arguments blocks
           where
             std_info = mkStdInfoTable ty_prof cl_prof type_tag con_tag layout
             info_label = entryLblToInfoLbl entry_label
             con_name = makeRelativeRefTo info_label descr
             layout = packHalfWordsCLit ptrs nptrs
 
+      -- | A thunk.
       CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag
               (ThunkInfo (ptrs, nptrs) srt) ->
-          mkInfoTableAndCode info_label std_info srt_label entry_label arguments blocks
+          mkInfoTableAndCode info_label std_info srt_label entry_label
+                             arguments blocks
           where
             std_info = mkStdInfoTable ty_prof cl_prof type_tag srt_bitmap layout
             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)
+            (srt_label, srt_bitmap) = mkSRTLit info_label srt
             layout = packHalfWordsCLit ptrs nptrs
 
+      -- | A selector thunk.
       CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag
               (ThunkSelectorInfo offset srt) ->
-          mkInfoTableAndCode info_label std_info srt_label entry_label arguments blocks
+          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)
+            (srt_label, srt_bitmap) = mkSRTLit info_label srt
 
+      -- A continuation/return-point.
       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
+          mkInfoTableAndCode info_label std_info srt_label entry_label
+                             arguments blocks
           where
-            std_info = mkStdInfoTable ty_prof cl_prof type_tag srt_bitmap liveness_lit
+            std_info = mkStdInfoTable ty_prof cl_prof maybe_big_type_tag srt_bitmap
+                                      (makeRelativeRefTo info_label liveness_lit)
             info_label = entryLblToInfoLbl entry_label
-            (liveness_lit, liveness_data) = mkLiveness uniq stack_layout
-            (srt_label, srt_bitmap) =
-                case srt of
-                  NoC_SRT -> ([], 0)
-                  (C_SRT lbl off bitmap) ->
-                      ([makeRelativeRefTo info_label (cmmLabelOffW lbl off)],
-                       bitmap)
+            (liveness_lit, liveness_data, liveness_tag) =
+                mkLiveness uniq stack_layout
+            maybe_big_type_tag = if type_tag == rET_SMALL
+                                 then liveness_tag
+                                 else type_tag
+            (srt_label, srt_bitmap) = mkSRTLit info_label srt
 
+-- Handle the differences between tables-next-to-code
+-- and not tables-next-to-code
+mkInfoTableAndCode :: CLabel
+                   -> [CmmLit]
+                   -> [CmmLit]
+                   -> CLabel
+                   -> CmmFormals
+                   -> [CmmBasicBlock]
+                   -> [RawCmmTop]
 mkInfoTableAndCode info_lbl std_info extra_bits entry_lbl args blocks
   | tablesNextToCode 	-- Reverse the extra_bits; and emit the top-level proc
-  = [CmmProc (map CmmStaticLit (reverse extra_bits ++ std_info)) entry_lbl args blocks]
+  = [CmmProc (map CmmStaticLit (reverse extra_bits ++ std_info))
+             entry_lbl args blocks]
 
   | null blocks -- No actual code; only the info table is significant
   =		-- Use a zero place-holder in place of the 
@@ -113,27 +168,108 @@ mkInfoTableAndCode info_lbl std_info extra_bits entry_lbl args blocks
     [mkDataLits info_lbl (CmmLabel entry_lbl : std_info ++ extra_bits),
      CmmProc [] entry_lbl args blocks]
 
+mkSRTLit :: CLabel
+         -> C_SRT
+         -> ([CmmLit],    -- srt_label
+             StgHalfWord) -- srt_bitmap
+mkSRTLit info_label NoC_SRT = ([], 0)
+mkSRTLit info_label (C_SRT lbl off bitmap) =
+    ([makeRelativeRefTo info_label (cmmLabelOffW lbl off)], bitmap)
+
+-------------------------------------------------------------------------
+--
+--		Build a liveness mask for the stack layout
+--
+-------------------------------------------------------------------------
+
+-- There are four kinds of things on the stack:
+--
+--	- pointer variables (bound in the environment)
+-- 	- non-pointer variables (bound in the environment)
+-- 	- free slots (recorded in the stack free list)
+-- 	- non-pointer data slots (recorded in the stack free list)
+--
+-- The first two are represented with a 'Just' of a 'LocalReg'.
+-- The last two with one or more 'Nothing' constructors.
+-- Each 'Nothing' represents one used word.
+--
+-- The head of the stack layout is the top of the stack and
+-- the least-significant bit.
+
 -- TODO: refactor to use utility functions
-mkLiveness :: Unique -> [Maybe LocalReg] -> (CmmLit, [GenCmmTop CmmStatic [CmmStatic] CmmStmt])
-mkLiveness uniq live
-  = if length live > mAX_SMALL_BITMAP_SIZE
-    then (CmmLabel big_liveness, [data_lits]) -- does not fit in one word
-    else (mkWordCLit small_liveness, []) -- fits in one word
+-- TODO: combine with CgCallConv.mkLiveness (see comment there)
+mkLiveness :: Unique
+           -> [Maybe LocalReg]
+           -> (CmmLit,           -- ^ The bitmap (literal value or label)
+               [RawCmmTop],      -- ^ Large bitmap CmmData if needed
+               ClosureTypeTag)   -- ^ rET_SMALL or rET_BIG
+mkLiveness uniq live =
+  if length bits > mAX_SMALL_BITMAP_SIZE
+    -- does not fit in one word
+    then (CmmLabel big_liveness, [data_lits], rET_BIG)
+    -- fits in one word
+    else (mkWordCLit small_liveness, [], rET_SMALL)
   where
-    size = length live
+    mkBits [] = []
+    mkBits (reg:regs) = take sizeW bits ++ mkBits regs where
+        sizeW = case reg of
+                  Nothing -> 1
+                  Just r -> machRepByteWidth (localRegRep r) `quot` wORD_SIZE
+        bits = repeat $ is_non_ptr reg -- True <=> Non Ptr
 
-    bits = mkBitmap (map is_non_ptr live)
     is_non_ptr Nothing = True
-    is_non_ptr (Just reg) | localRegGCFollow reg == KindNonPtr = True
-    is_non_ptr (Just reg) | localRegGCFollow reg == KindPtr = False
+    is_non_ptr (Just reg) =
+        case localRegGCFollow reg of
+          KindNonPtr -> True
+          KindPtr -> False
 
-    big_liveness = mkBitmapLabel uniq
-    data_lits = mkRODataLits big_liveness lits
-    lits = mkWordCLit (fromIntegral size) : map mkWordCLit bits
-  
-    small_liveness =
-        fromIntegral size .|. (small_bits `shiftL` bITMAP_BITS_SHIFT)
-    small_bits = case bits of 
+    bits :: [Bool]
+    bits = mkBits live
+
+    bitmap :: Bitmap
+    bitmap = mkBitmap bits
+
+    small_bitmap = case bitmap of 
 		   []  -> 0
 		   [b] -> fromIntegral b
 		   _   -> panic "mkLiveness"
+    small_liveness =
+        fromIntegral (length bits) .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT)
+
+    big_liveness = mkBitmapLabel uniq
+    lits = mkWordCLit (fromIntegral (length bits)) : map mkWordCLit bitmap
+    data_lits = mkRODataLits big_liveness lits
+
+-------------------------------------------------------------------------
+--
+--	Generating a standard info table
+--
+-------------------------------------------------------------------------
+
+-- The standard bits of an info table.  This part of the info table
+-- corresponds to the StgInfoTable type defined in InfoTables.h.
+--
+-- Its shape varies with ticky/profiling/tables next to code etc
+-- so we can't use constant offsets from Constants
+
+mkStdInfoTable
+   :: CmmLit		-- closure type descr (profiling)
+   -> CmmLit		-- closure descr (profiling)
+   -> StgHalfWord	-- closure type
+   -> StgHalfWord	-- SRT length
+   -> CmmLit		-- layout field
+   -> [CmmLit]
+
+mkStdInfoTable type_descr closure_descr cl_type srt_len layout_lit
+ = 	-- Parallel revertible-black hole field
+    prof_info
+	-- Ticky info (none at present)
+	-- Debug info (none at present)
+ ++ [layout_lit, type_lit]
+
+ where  
+    prof_info 
+	| opt_SccProfilingOn = [type_descr, closure_descr]
+	| otherwise	     = []
+
+    type_lit = packHalfWordsCLit cl_type srt_len