X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2FcodeGen%2FCgInfoTbls.hs;h=04a1403c3471bbb26f93cf2d45fd4016013e2bf5;hb=7d6dffe542bdad5707a929ae7ac25813c586766d;hp=5a40a3d5c193bdf1ee3d527ea13b64019d67354c;hpb=1bda00ba7f7d3ae4f332d7fac4add8ee2407b476;p=ghc-hetmet.git

diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs
index 5a40a3d..04a1403 100644
--- a/compiler/codeGen/CgInfoTbls.hs
+++ b/compiler/codeGen/CgInfoTbls.hs
@@ -2,7 +2,7 @@
 --
 -- Building info tables.
 --
--- (c) The University of Glasgow 2004
+-- (c) The University of Glasgow 2004-2006
 --
 -----------------------------------------------------------------------------
 
@@ -28,42 +28,29 @@ module CgInfoTbls (
 
 #include "HsVersions.h"
 
-import ClosureInfo	( ClosureInfo, closureTypeDescr, closureName,
-			  infoTableLabelFromCI, Liveness,
-			  closureValDescr, closureSRT, closureSMRep,
-			  closurePtrsSize, closureNonHdrSize, closureFunInfo,
-			  C_SRT(..), needsSRT, isConstrClosure_maybe,
-			  ArgDescr(..) )
-import SMRep		( StgHalfWord, hALF_WORD_SIZE_IN_BITS, hALF_WORD_SIZE,
-			  WordOff, ByteOff,
-			  smRepClosureTypeInt, tablesNextToCode,
-			  rET_BIG, rET_SMALL, rET_VEC_BIG, rET_VEC_SMALL )
-import CgBindery	( getLiveStackSlots )
-import CgCallConv	( isBigLiveness, mkLivenessCLit, buildContLiveness,
-			  argDescrType, getSequelAmode,
-			  CtrlReturnConvention(..) )
-import CgUtils		( mkStringCLit, packHalfWordsCLit, mkWordCLit, 
-			  cmmOffsetB, cmmOffsetExprW, cmmLabelOffW, cmmOffsetW,
-			  emitDataLits, emitRODataLits, emitSwitch, cmmNegate,
-			  newTemp )
+import ClosureInfo
+import SMRep
+import CgBindery
+import CgCallConv
+import CgUtils
 import CgMonad
 
-import CmmUtils		( mkIntCLit, zeroCLit )
-import Cmm		( CmmStmt(..), CmmExpr(..), CmmLit(..), LocalReg,
-			  CmmBasicBlock, nodeReg )
+import CmmUtils
+import Cmm
 import MachOp
 import CLabel
-import StgSyn		( SRT(..) )
-import Name		( Name )
-import DataCon		( DataCon, dataConTag, fIRST_TAG )
-import Unique		( Uniquable(..) )
-import DynFlags		( DynFlags(..), HscTarget(..) )
-import StaticFlags	( opt_SccProfilingOn )
-import ListSetOps	( assocDefault )
-import Maybes		( isJust )
-import Constants	( wORD_SIZE, sIZEOF_StgFunInfoExtraRev )
-import Outputable
+import StgSyn
+import Name
+import DataCon
+import Unique
+import DynFlags
+import StaticFlags
 
+import ListSetOps
+import Maybes
+import Constants
+
+import Outputable 
 
 -------------------------------------------------------------------------
 --
@@ -102,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
 
@@ -115,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 = []
 
@@ -217,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
-#ifdef x86_64_TARGET_ARCH
-        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)