Constructor names in info tables

[ghc-hetmet.git] / compiler / codeGen / CgInfoTbls.hs

diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs
index e6d36c0..04a1403 100644 (file)
--- a/compiler/codeGen/CgInfoTbls.hs
+++ b/compiler/codeGen/CgInfoTbls.hs
@@ -50,6 +50,8 @@ import ListSetOps
 import Maybes
 import Constants
 
+import Outputable 
+
 -------------------------------------------------------------------------
 --
 --     Generating the info table and code for a closure
@@ -87,7 +89,13 @@ emitClosureCodeAndInfoTable cl_info args body
                                        cl_type srt_len layout_lit
 
        ; blks <- cgStmtsToBlocks body
-       ; emitInfoTableAndCode info_lbl std_info extra_bits args blks }
+
+        ; conName <-  
+             if is_con
+                then mkStringCLit $ fromJust conIdentity
+                else return (mkIntCLit 0)
+
+       ; emitInfoTableAndCode info_lbl std_info (extra_bits conName) args blks }
   where
     info_lbl  = infoTableLabelFromCI cl_info
 
@@ -100,24 +108,25 @@ emitClosureCodeAndInfoTable cl_info args body
     mb_con = isConstrClosure_maybe  cl_info
     is_con = isJust mb_con
 
-    (srt_label,srt_len)
+    (srt_label,srt_len,conIdentity)
        = case mb_con of
            Just con -> -- Constructors don't have an SRT
                        -- We keep the *zero-indexed* tag in the srt_len
                        -- field of the info table. 
-                       (mkIntCLit 0, fromIntegral (dataConTagZ con)) 
+                       (mkIntCLit 0, fromIntegral (dataConTagZ con), Just $ dataConIdentity con) 
 
            Nothing  -> -- Not a constructor
-                       srtLabelAndLength srt info_lbl
+                        let (label, len) = srtLabelAndLength srt info_lbl
+                        in (label, len, Nothing)
 
     ptrs       = closurePtrsSize cl_info
     nptrs      = size - ptrs
     size       = closureNonHdrSize cl_info
     layout_lit = packHalfWordsCLit ptrs nptrs
 
-    extra_bits
+    extra_bits conName 
        | is_fun    = fun_extra_bits
-       | is_con    = []
+       | is_con    = [conName]
        | needs_srt = [srt_label]
        | otherwise = []
 
@@ -202,18 +211,19 @@ retVec :: CmmExpr -> CmmExpr -> CmmExpr
 -- Get a return vector from the info pointer
 retVec info_amode zero_indexed_tag
   = let slot = vectorSlot info_amode zero_indexed_tag
-#if defined(x86_64_TARGET_ARCH) && defined(TABLES_NEXT_TO_CODE)
-        tableEntry = CmmMachOp (MO_S_Conv I32 I64) [CmmLoad slot I32]
+        table_slot = CmmLoad slot wordRep
+#if defined(x86_64_TARGET_ARCH)
+        offset_slot = CmmMachOp (MO_S_Conv I32 I64) [CmmLoad slot I32]
        -- offsets are 32-bits on x86-64, due to the inability of
        -- the tools to handle 64-bit PC-relative relocations.  See also
        -- PprMach.pprDataItem, and InfoTables.h:OFFSET_FIELD().
 #else
-        tableEntry = CmmLoad slot wordRep
+       offset_slot = table_slot
 #endif
     in if tablesNextToCode
-           then CmmMachOp (MO_Add wordRep) [tableEntry, info_amode]
-           else tableEntry
-           
+           then CmmMachOp (MO_Add wordRep) [offset_slot, info_amode]
+           else table_slot
+
 emitReturnTarget
    :: Name
    -> CgStmts                  -- The direct-return code (if any)