fix type tags for RTS-defined info tables

3 files changed, 65 insertions, 59 deletions

diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs
index 4e2d976826..bea613e507 100644
--- a/compiler/cmm/CmmInfo.hs
+++ b/compiler/cmm/CmmInfo.hs
@@ -77,7 +77,7 @@ mkInfoTable (CmmProc (CmmInfo _ _ info) entry_label blocks)
   = return [CmmProc Nothing entry_label blocks]
                                
   | CmmInfoTable { cit_lbl = info_lbl } <- info
-  = do { (top_decls, info_cts) <- mkInfoTableContents info
+  = do { (top_decls, info_cts) <- mkInfoTableContents info Nothing
        ; return (top_decls  ++
                  mkInfoTableAndCode info_lbl info_cts
                                     entry_label blocks) }
@@ -89,30 +89,37 @@ type InfoTableContents = ( [CmmLit]	     -- The standard part
 -- These Lits have *not* had mkRelativeTo applied to them
 
 mkInfoTableContents :: CmmInfoTable
-                    -> UniqSM ([RawCmmTop],		-- Auxiliary top decls
+                    -> Maybe StgHalfWord    -- override default RTS type tag?
+                    -> UniqSM ([RawCmmTop],             -- Auxiliary top decls
                                InfoTableContents)	-- Info tbl + extra bits
+
+mkInfoTableContents info@(CmmInfoTable { cit_rep = RTSRep ty rep }) _
+ = mkInfoTableContents info{cit_rep = rep} (Just ty)
+
 mkInfoTableContents (CmmInfoTable { cit_lbl  = info_lbl
                                   , cit_rep  = smrep
-                                  , cit_prof = prof, cit_srt = srt }) 
+                                  , cit_prof = prof
+                                  , cit_srt = srt }) mb_rts_tag
   | StackRep frame <- smrep
-  = do { (prof_lits,    prof_data)     <- mkProfLits prof
+  = do { (prof_lits, prof_data) <- mkProfLits prof
+       ; let (srt_label, srt_bitmap) = mkSRTLit srt
        ; (liveness_lit, liveness_data) <- mkLivenessBits frame
-       ; let (extra_bits, srt_bitmap) = mkSRTLit srt
+       ; let
              std_info = mkStdInfoTable prof_lits rts_tag srt_bitmap liveness_lit
-             rts_tag | null liveness_data = rET_SMALL  -- Fits in extra_bits
-                     | otherwise          = rET_BIG    -- Does not; extra_bits is
-                                                       -- a label
-       ; return (prof_data ++ liveness_data, (std_info, extra_bits)) }
+             rts_tag | Just tag <- mb_rts_tag = tag
+                     | null liveness_data     = rET_SMALL -- Fits in extra_bits
+                     | otherwise              = rET_BIG   -- Does not; extra_bits is
+                                                          -- a label
+       ; return (prof_data ++ liveness_data, (std_info, srt_label)) }
 
   | HeapRep _ ptrs nonptrs closure_type <- smrep
-  = do { let rts_tag = rtsClosureType smrep
-             layout  = packHalfWordsCLit ptrs nonptrs
-  	     (srt_label, srt_bitmap) = mkSRTLit srt
-
+  = do { let layout  = packHalfWordsCLit ptrs nonptrs
        ; (prof_lits, prof_data) <- mkProfLits prof
-       ; (mb_srt_field, mb_layout, extra_bits, ct_data) 
+       ; let (srt_label, srt_bitmap) = mkSRTLit srt
+       ; (mb_srt_field, mb_layout, extra_bits, ct_data)
                                 <- mk_pieces closure_type srt_label
-       ; let std_info = mkStdInfoTable prof_lits rts_tag 
+       ; let std_info = mkStdInfoTable prof_lits
+                                       (mb_rts_tag   `orElse` rtsClosureType smrep)
                                        (mb_srt_field `orElse` srt_bitmap)
                                        (mb_layout    `orElse` layout)
        ; return (prof_data ++ ct_data, (std_info, extra_bits)) }
@@ -152,7 +159,8 @@ mkInfoTableContents (CmmInfoTable { cit_lbl  = info_lbl
 
     mk_pieces BlackHole _ = panic "mk_pieces: BlackHole"
 
-mkInfoTableContents _ = panic "mkInfoTableContents"   -- NonInfoTable dealt with earlier
+
+mkInfoTableContents _ _ = panic "mkInfoTableContents"   -- NonInfoTable dealt with earlier
 
 mkSRTLit :: C_SRT
          -> ([CmmLit],    -- srt_label, if any
diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index cd0c021db6..6f72388cd5 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -265,9 +265,12 @@ info	:: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
 		-- ptrs, nptrs, closure type, description, type
 		{% withThisPackage $ \pkg ->
 		   do let prof = profilingInfo $11 $13
-			  rep = mkHeapRep False (fromIntegral $5) (fromIntegral $7) Thunk
-			-- ToDo: Type tag $9 redundant
-		      return (mkCmmEntryLabel pkg $3,
+                          rep  = mkRTSRep (fromIntegral $9) $
+                                   mkHeapRep False (fromIntegral $5)
+                                                   (fromIntegral $7) Thunk
+                              -- not really Thunk, but that makes the info table
+                              -- we want.
+                      return (mkCmmEntryLabel pkg $3,
 			      CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
 				           , cit_rep = rep
                				   , cit_prof = prof, cit_srt = NoC_SRT },
@@ -277,11 +280,12 @@ info	:: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
 		-- ptrs, nptrs, closure type, description, type, fun type
 		{% withThisPackage $ \pkg -> 
 		   do let prof = profilingInfo $11 $13
-			  rep = mkHeapRep False (fromIntegral $5) (fromIntegral $7) ty
-                          ty  = Fun 0  -- Arity zero
-				     (ArgSpec (fromIntegral $15))
-			-- ToDo: Type tag $9 redundant
-		      return (mkCmmEntryLabel pkg $3,
+                          ty   = Fun 0 (ArgSpec (fromIntegral $15))
+                                -- Arity zero, arg_type $15
+                          rep = mkRTSRep (fromIntegral $9) $
+                                    mkHeapRep False (fromIntegral $5)
+                                                    (fromIntegral $7) ty
+                      return (mkCmmEntryLabel pkg $3,
 			      CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
 				           , cit_rep = rep
                				   , cit_prof = prof, cit_srt = NoC_SRT },
@@ -289,32 +293,16 @@ info	:: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
 		-- we leave most of the fields zero here.  This is only used
 		-- to generate the BCO info table in the RTS at the moment.
 
-	-- A variant with a non-zero arity (needed to write Main_main in Cmm)
-	| 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ',' INT ')'
-		-- ptrs, nptrs, closure type, description, type, fun type, arity
-		{% withThisPackage $ \pkg ->
-		   do let prof = profilingInfo $11 $13
-			  rep = mkHeapRep False (fromIntegral $5) (fromIntegral $7) ty
-			  ty  = Fun (fromIntegral $17)  -- Arity 
-				     (ArgSpec (fromIntegral $15))
-			-- ToDo: Type tag $9 redundant
-		      return (mkCmmEntryLabel pkg $3,
-			      CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
-				           , cit_rep = rep
-               				   , cit_prof = prof, cit_srt = NoC_SRT },
-			      []) }
-		-- 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 ')'
+        | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
 		-- ptrs, nptrs, tag, closure type, description, type
 		{% withThisPackage $ \pkg ->
 		   do let prof = profilingInfo $13 $15
-			  rep = mkHeapRep False (fromIntegral $5) (fromIntegral $7) ty
-			  ty  = Constr (fromIntegral $9)  -- Tag
+                          ty  = Constr (fromIntegral $9)  -- Tag
 	                           	(stringToWord8s $13)
-			-- ToDo: Type tag $11 redundant
-		      return (mkCmmEntryLabel pkg $3,
+                          rep = mkRTSRep (fromIntegral $11) $
+                                  mkHeapRep False (fromIntegral $5)
+                                                  (fromIntegral $7) ty
+                      return (mkCmmEntryLabel pkg $3,
 			      CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
 				           , cit_rep = rep
                				   , cit_prof = prof, cit_srt = NoC_SRT },
@@ -327,10 +315,10 @@ info	:: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
 		-- selector, closure type, description, type
 		{% withThisPackage $ \pkg ->
 		   do let prof = profilingInfo $9 $11
-			  rep = mkHeapRep False (fromIntegral $5) (fromIntegral $7) ty
                           ty  = ThunkSelector (fromIntegral $5)
-			-- ToDo: Type tag $7 redundant
-		      return (mkCmmEntryLabel pkg $3,
+                          rep = mkRTSRep (fromIntegral $7) $
+                                   mkHeapRep False 0 0 ty
+                      return (mkCmmEntryLabel pkg $3,
 			      CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
 				           , cit_rep = rep
                				   , cit_prof = prof, cit_srt = NoC_SRT },
@@ -340,9 +328,8 @@ info	:: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
 		-- closure type (no live regs)
 		{% withThisPackage $ \pkg ->
 		   do let prof = NoProfilingInfo
-			  rep  = mkStackRep []
-			-- ToDo: Type tag $5 redundant
-		      return (mkCmmRetLabel pkg $3,
+                          rep  = mkRTSRep (fromIntegral $5) $ mkStackRep []
+                      return (mkCmmRetLabel pkg $3,
 			      CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
 				           , cit_rep = rep
                				   , cit_prof = prof, cit_srt = NoC_SRT },
@@ -353,9 +340,9 @@ info	:: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
 		{% withThisPackage $ \pkg ->
 		   do live <- sequence (map (liftM Just) $7)
 		      let prof = NoProfilingInfo
-			  rep  = mkStackRep []
-			-- ToDo: Type tag $5 redundant
-		      return (mkCmmRetLabel pkg $3,
+                          bitmap = mkLiveness live
+                          rep  = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap
+                      return (mkCmmRetLabel pkg $3,
 			      CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
 				           , cit_rep = rep
                				   , cit_prof = prof, cit_srt = NoC_SRT },
diff --git a/compiler/cmm/SMRep.lhs b/compiler/cmm/SMRep.lhs
index 8ed35ec605..fd60544869 100644
--- a/compiler/cmm/SMRep.lhs
+++ b/compiler/cmm/SMRep.lhs
@@ -20,7 +20,7 @@ module SMRep (
         IsStatic, 
         ClosureTypeInfo(..), ArgDescr(..), Liveness,
         ConstrDescription, 
-	mkHeapRep, blackHoleRep, mkStackRep,
+        mkHeapRep, blackHoleRep, mkStackRep, mkRTSRep,
 
 	isStaticRep, isStaticNoCafCon,
         heapClosureSize,
@@ -99,6 +99,10 @@ data SMRep
   | StackRep            -- Stack frame (RET_SMALL or RET_BIG)
         Liveness
 
+  | RTSRep              -- The RTS needs to declare info tables with specific
+        StgHalfWord     -- type tags, so this form lets us override the default
+        SMRep           -- tag for an SMRep.
+
 -- | True <=> This is a static closure.  Affects how we garbage-collect it.
 -- Static closure have an extra static link field at the end.
 type IsStatic = Bool
@@ -159,9 +163,11 @@ mkHeapRep is_static ptr_wds nonptr_wds cl_type_info
      hdr_size     = closureTypeHdrSize cl_type_info
      payload_size = ptr_wds + nonptr_wds
 
+mkRTSRep :: StgHalfWord -> SMRep -> SMRep
+mkRTSRep = RTSRep
 
 mkStackRep :: [Bool] -> SMRep
-mkStackRep = StackRep
+mkStackRep liveness = StackRep liveness
 
 blackHoleRep :: SMRep
 blackHoleRep = HeapRep False 0 0 BlackHole
@@ -198,11 +204,13 @@ thunkHdrSize = fixedHdrSize + smp_hdr
 
 isStaticRep :: SMRep -> IsStatic
 isStaticRep (HeapRep is_static _ _ _) = is_static
-isStaticRep (StackRep {})	         = False
+isStaticRep (StackRep {})             = False
+isStaticRep (RTSRep _ rep)            = isStaticRep rep
 
 nonHdrSize :: SMRep -> WordOff
 nonHdrSize (HeapRep _ p np _) = p + np
 nonHdrSize (StackRep bs)      = length bs
+nonHdrSize (RTSRep _ rep)     = nonHdrSize rep
 
 heapClosureSize :: SMRep -> WordOff
 heapClosureSize (HeapRep _ p np ty) = closureTypeHdrSize ty + p + np
@@ -229,6 +237,8 @@ closureTypeHdrSize ty = case ty of
 
 -- | Derives the RTS closure type from an 'SMRep'
 rtsClosureType :: SMRep -> StgHalfWord
+rtsClosureType (RTSRep ty _)  = ty
+
 rtsClosureType (HeapRep False 1 0 Constr{}) = CONSTR_1_0
 rtsClosureType (HeapRep False 0 1 Constr{}) = CONSTR_0_1
 rtsClosureType (HeapRep False 2 0 Constr{}) = CONSTR_2_0
@@ -312,6 +322,8 @@ instance Outputable SMRep where
 
    ppr (StackRep bs) = ptext (sLit "StackRep") <+> ppr bs
 
+   ppr (RTSRep ty rep) = ptext (sLit "tag:") <> ppr ty <+> ppr rep
+
 instance Outputable ArgDescr where
   ppr (ArgSpec n) = ptext (sLit "ArgSpec") <+> integer (toInteger n)
   ppr (ArgGen ls) = ptext (sLit "ArgGen") <+> ppr ls
@@ -333,7 +345,6 @@ pprTypeInfo (ThunkSelector offset)
 pprTypeInfo Thunk     = ptext (sLit "Thunk")
 pprTypeInfo BlackHole = ptext (sLit "BlackHole")
 
-
 stringToWord8s :: String -> [Word8]
 stringToWord8s s = map (fromIntegral . ord) s