From 7d6dffe542bdad5707a929ae7ac25813c586766d Mon Sep 17 00:00:00 2001 From: "bjpop@csse.unimelb.edu.au" Date: Tue, 20 Feb 2007 19:07:31 +0000 Subject: [PATCH] Constructor names in info tables This patch adds data constructor names into their info tables. This is useful in the ghci debugger. It replaces the old scheme which was based on tracking data con names in the linker. --- compiler/basicTypes/DataCon.lhs | 15 +++- compiler/codeGen/CgInfoTbls.hs | 21 +++-- compiler/ghci/ByteCodeItbls.lhs | 70 +++++++++++---- compiler/ghci/Linker.lhs | 179 ++++++++++++++++++++++--------------- compiler/ghci/ObjLink.lhs | 16 +--- compiler/ghci/RtClosureInspect.hs | 39 -------- includes/ClosureMacros.h | 5 ++ includes/InfoTables.h | 16 ++++ includes/Linker.h | 3 - rts/Linker.c | 51 ----------- 10 files changed, 212 insertions(+), 203 deletions(-) diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index aef8b65..c75f1b4 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -10,7 +10,7 @@ module DataCon ( ConTag, fIRST_TAG, mkDataCon, dataConRepType, dataConSig, dataConFullSig, - dataConName, dataConTag, dataConTyCon, dataConUserType, + dataConName, dataConIdentity, dataConTag, dataConTyCon, dataConUserType, dataConUnivTyVars, dataConExTyVars, dataConAllTyVars, dataConResTys, dataConEqSpec, eqSpecPreds, dataConTheta, dataConStupidTheta, dataConInstArgTys, dataConOrigArgTys, @@ -501,6 +501,19 @@ mk_dict_strict_mark pred | isStrictPred pred = MarkedStrict dataConName :: DataCon -> Name dataConName = dcName +-- generate a name in the format: package:Module.OccName +-- and the unique identity of the name +dataConIdentity :: DataCon -> String +dataConIdentity dataCon + = prettyName + where + prettyName = pretty packageModule ++ "." ++ pretty occ + nm = getName dataCon + packageModule = nameModule nm + occ = getOccName dataCon + pretty :: Outputable a => a -> String + pretty = showSDoc . ppr + dataConTag :: DataCon -> ConTag dataConTag = dcTag diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs index 1c30d06..04a1403 100644 --- 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 = [] diff --git a/compiler/ghci/ByteCodeItbls.lhs b/compiler/ghci/ByteCodeItbls.lhs index a7c2d4b..12cd47f 100644 --- a/compiler/ghci/ByteCodeItbls.lhs +++ b/compiler/ghci/ByteCodeItbls.lhs @@ -16,7 +16,7 @@ import ByteCodeFFI ( newExec ) import Name ( Name, getName ) import NameEnv import SMRep ( typeCgRep ) -import DataCon ( DataCon, dataConRepArgTys ) +import DataCon ( DataCon, dataConRepArgTys, dataConIdentity ) import TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons ) import Constants ( mIN_PAYLOAD_SIZE, wORD_SIZE ) import CgHeapery ( mkVirtHeapOffsets ) @@ -25,10 +25,14 @@ import Util ( lengthIs, listLengthCmp ) import Foreign import Foreign.C +import Foreign.C.String import Data.Bits ( Bits(..), shiftR ) import GHC.Exts ( Int(I#), addr2Int# ) import GHC.Ptr ( Ptr(..) ) +import GHC.Prim + +import Outputable \end{code} %************************************************************************ @@ -92,17 +96,17 @@ make_constr_itbls cons = mk_itbl dcon conNo stg_interp_constr_entry mk_itbl :: DataCon -> Int -> Ptr () -> IO (Name,ItblPtr) - mk_itbl dcon conNo entry_addr - = let rep_args = [ (typeCgRep arg,arg) - | arg <- dataConRepArgTys dcon ] - (tot_wds, ptr_wds, _) = mkVirtHeapOffsets False{-not a THUNK-} rep_args - - ptrs = ptr_wds - nptrs = tot_wds - ptr_wds - nptrs_really - | ptrs + nptrs >= mIN_PAYLOAD_SIZE = nptrs - | otherwise = mIN_PAYLOAD_SIZE - ptrs - itbl = StgInfoTable { + mk_itbl dcon conNo entry_addr = do + let rep_args = [ (typeCgRep arg,arg) | arg <- dataConRepArgTys dcon ] + (tot_wds, ptr_wds, _) = mkVirtHeapOffsets False{-not a THUNK-} rep_args + + ptrs = ptr_wds + nptrs = tot_wds - ptr_wds + nptrs_really + | ptrs + nptrs >= mIN_PAYLOAD_SIZE = nptrs + | otherwise = mIN_PAYLOAD_SIZE - ptrs + code = mkJumpToAddr entry_addr + itbl = StgInfoTable { #ifndef GHCI_TABLES_NEXT_TO_CODE entry = entry_addr, #endif @@ -114,15 +118,21 @@ make_constr_itbls cons , code = code #endif } - -- Make a piece of code to jump to "entry_label". - -- This is the only arch-dependent bit. - code = mkJumpToAddr entry_addr - in - do addr <- newExec [itbl] + qNameCString <- newCString $ dataConIdentity dcon + let conInfoTbl = StgConInfoTable { + conDesc = qNameCString, + infoTable = itbl + } + -- Make a piece of code to jump to "entry_label". + -- This is the only arch-dependent bit. + -- addr <- newExec [itbl] + addrCon <- newExec [conInfoTbl] + let addr = (castFunPtrToPtr addrCon) `plusPtr` 4 -- ToDo: remove magic number --putStrLn ("SIZE of itbl is " ++ show (sizeOf itbl)) --putStrLn ("# ptrs of itbl is " ++ show ptrs) --putStrLn ("# nptrs of itbl is " ++ show nptrs_really) - return (getName dcon, ItblPtr (castFunPtrToPtr addr)) + -- return (getName dcon, ItblPtr (castFunPtrToPtr addr)) + return (getName dcon, ItblPtr addr) -- Make code which causes a jump to the given address. This is the @@ -284,6 +294,30 @@ type HalfWord = Word32 type HalfWord = Word16 #endif +data StgConInfoTable = StgConInfoTable { + conDesc :: CString, + infoTable :: StgInfoTable +} + +instance Storable StgConInfoTable where + sizeOf conInfoTable + = sum [ sizeOf (conDesc conInfoTable) + , sizeOf (infoTable conInfoTable) ] + alignment conInfoTable = SIZEOF_VOID_P + peek ptr + = runState (castPtr ptr) $ do + desc <- load + itbl <- load + return + StgConInfoTable + { conDesc = desc + , infoTable = itbl + } + poke ptr itbl + = runState (castPtr ptr) $ do + store (conDesc itbl) + store (infoTable itbl) + data StgInfoTable = StgInfoTable { #ifndef GHCI_TABLES_NEXT_TO_CODE entry :: Ptr (), diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index d2c7fe1..37fe289 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -29,11 +29,8 @@ import ByteCodeItbls import ByteCodeAsm import RtClosureInspect import IfaceEnv -import Config import OccName import TcRnMonad -import Constants -import Encoding import Packages import DriverPhases import Finder @@ -58,11 +55,13 @@ import UniqSet -- Standard libraries import Control.Monad -import Control.Arrow ( second ) import Data.IORef import Data.List import Foreign.Ptr +import Foreign.C.Types +import Foreign.C.String +import Foreign.Storable import System.IO import System.Directory @@ -75,6 +74,7 @@ import GHC.IOBase ( IO(..) ) #else import PrelIOBase ( IO(..) ) #endif + \end{code} @@ -118,7 +118,6 @@ data PersistentLinkerState -- Held, as usual, in dependency order; though I am not sure if -- that is really important pkgs_loaded :: [PackageId] - ,dtacons_env :: DataConEnv } emptyPLS :: DynFlags -> PersistentLinkerState @@ -127,9 +126,8 @@ emptyPLS dflags = PersistentLinkerState { itbl_env = emptyNameEnv, pkgs_loaded = init_pkgs, bcos_loaded = [], - objs_loaded = [] - , dtacons_env = emptyAddressEnv - } + objs_loaded = [] } + -- Packages that don't need loading, because the compiler -- shares them with the interpreted program. -- @@ -151,52 +149,105 @@ extendLinkEnv new_bindings new_pls = pls { closure_env = new_closure_env } writeIORef v_PersistentLinkerState new_pls +-- | Given a data constructor, find its internal name. +-- The info tables for data constructors have a field which records the source name +-- of the constructor as a CString. The format is: +-- +-- Package:Module.Name +-- +-- We use this string to lookup the interpreter's internal representation of the name +-- using the lookupOrig. recoverDataCon :: a -> TcM Name -recoverDataCon a = recoverDCInRTS a `recoverM` ioToTcRn (do - mb_name <- recoverDCInDynEnv a - maybe (fail "Linker.recoverDatacon: Name not found in Dyn Env") - return - mb_name) - --- | If a is a Constr closure, lookupDC returns either the Name of the DataCon or the --- symbol if it is a nullary constructor --- For instance, for a closure containing 'Just x' it would return the Name for Data.Maybe.Just --- For a closure containing 'Nothing' it would return the String "DataziMaybe_Nothing_static_info" -recoverDCInDynEnv :: a -> IO (Maybe Name) -recoverDCInDynEnv a = do - pls <- readIORef v_PersistentLinkerState - let de = dtacons_env pls - ctype <- getClosureType a - if not (isConstr ctype) - then putStrLn ("Not a Constr (" ++ show ctype ++ ")") >> - return Nothing - else do let infot = getInfoTablePtr a - name = lookupAddressEnv de (castPtr$ infot `plusPtr` (wORD_SIZE*2)) - return name - - -recoverDCInRTS :: a -> TcM Name -recoverDCInRTS a = do - ctype <- ioToTcRn$ getClosureType a - if (not$ isConstr ctype) - then fail "not Constr" - else do - Just symbol <- ioToTcRn$ lookupDataCon (getInfoTablePtr a) - let (occ,mod) = (parse . lex) symbol - lookupOrig mod occ - where lex x = map zDecodeString . init . init . split '_' . removeLeadingUnderscore $ x - parse [pkg, modName, occ] = (mkOccName OccName.dataName occ, - mkModule (stringToPackageId pkg) (mkModuleName modName)) - parse [modName, occ] = (mkOccName OccName.dataName occ, - mkModule mainPackageId (mkModuleName modName)) - split delim = let - helper [] = Nothing - helper x = Just . second (drop 1) . break (==delim) $ x - in unfoldr helper - removeLeadingUnderscore = if cLeadingUnderscore=="YES" - then tail - else id +recoverDataCon x = do + theString <- ioToTcRn $ do + let ptr = getInfoTablePtr x + conDescAddress <- getConDescAddress ptr + peekCString conDescAddress + let (pkg, mod, occ) = parse theString + occName = mkOccName OccName.dataName occ + modName = mkModule (stringToPackageId pkg) (mkModuleName mod) + lookupOrig modName occName + + where + + {- To find the string in the constructor's info table we need to consider + the layout of info tables relative to the entry code for a closure. + + An info table can be next to the entry code for the closure, or it can + be separate. The former (faster) is used in registerised versions of ghc, + and the latter (portable) is for non-registerised versions. + + The diagrams below show where the string is to be found relative to + the normal info table of the closure. + + 1) Code next to table: + + -------------- + | | <- pointer to the start of the string + -------------- + | | <- the (start of the) info table structure + | | + | | + -------------- + | entry code | + | .... | + + In this case the pointer to the start of the string can be found in + the memory location _one word before_ the first entry in the normal info + table. + + 2) Code NOT next to table: + + -------------- + info table structure -> | *------------------> -------------- + | | | entry code | + | | | .... | + -------------- + ptr to start of str -> | | + -------------- + + In this case the pointer to the start of the string can be found + in the memory location: info_table_ptr + info_table_size + -} + + getConDescAddress :: Ptr StgInfoTable -> IO (Ptr CChar) + getConDescAddress ptr = do + peek $ intPtrToPtr $ (ptrToIntPtr ptr) + offset +#ifdef GHCI_TABLES_NEXT_TO_CODE + where + -- subtract a word number of bytes + offset = negate (fromIntegral SIZEOF_VOID_P) +#endif +#ifndef GHCI_TABLES_NEXT_TO_CODE + where + -- add the standard info table size in bytes + infoTableSizeBytes = sTD_ITBL_SIZE * wORD_SIZE + offset = infoTableSizeBytes +#endif + + -- parsing names is a little bit fiddly because we have a string in the form: + -- pkg:A.B.C.foo, and we want to split it into three parts: ("pkg", "A.B.C", "foo"). + -- Thus we split at the leftmost colon and the rightmost occurrence of the dot. + -- It would be easier if the string was in the form pkg:A.B.C:foo, but alas + -- this is not the conventional way of writing Haskell names. We stick with + -- convention, even though it makes the parsing code more troublesome. + -- Warning: this code assumes that the string is well formed. + parse :: String -> (String, String, String) + parse input + = ASSERT (all (>0) (map length [pkg, mod, occ])) (pkg, mod, occ) + where + (pkg, rest1) = break (==':') input + (mod, occ) + = (concat $ intersperse "." $ reverse modWords, occWord) + where + (modWords, occWord) = ASSERT (length rest1 > 0) (parseModOcc [] (tail rest1)) + parseModOcc :: [String] -> String -> ([String], String) + parseModOcc acc str + = case break (== '.') str of + (top, []) -> (acc, top) + (top, '.':bot) -> parseModOcc (top : acc) bot + getHValue :: Name -> IO (Maybe HValue) getHValue name = do @@ -240,9 +291,7 @@ showLinkerState printDump (vcat [text "----- Linker state -----", text "Pkgs:" <+> ppr (pkgs_loaded pls), text "Objs:" <+> ppr (objs_loaded pls), - text "BCOs:" <+> ppr (bcos_loaded pls), - text "DataCons:" <+> ppr (dtacons_env pls) - ]) + text "BCOs:" <+> ppr (bcos_loaded pls)]) \end{code} @@ -424,11 +473,9 @@ linkExpr hsc_env span root_ul_bco pls <- readIORef v_PersistentLinkerState ; let ie = itbl_env pls ce = closure_env pls - de = dtacons_env pls -- Link the necessary packages and linkables - ; (_,de_out, (root_hval:_)) <- linkSomeBCOs False ie ce de [root_ul_bco] - ; writeIORef v_PersistentLinkerState (pls{dtacons_env=de_out}) + ; (_, (root_hval:_)) <- linkSomeBCOs False ie ce [root_ul_bco] ; return root_hval }} where @@ -715,11 +762,10 @@ dynLinkBCOs bcos gce = closure_env pls final_ie = foldr plusNameEnv (itbl_env pls) ies - (final_gce, final_de, linked_bcos) <- linkSomeBCOs True final_ie gce (dtacons_env pls) ul_bcos + (final_gce, linked_bcos) <- linkSomeBCOs True final_ie gce ul_bcos -- What happens to these linked_bcos? let pls2 = pls1 { closure_env = final_gce, - dtacons_env = final_de, itbl_env = final_ie } writeIORef v_PersistentLinkerState pls2 @@ -730,14 +776,13 @@ linkSomeBCOs :: Bool -- False <=> add _all_ BCOs to returned closure env -- True <=> add only toplevel BCOs to closure env -> ItblEnv -> ClosureEnv - -> DataConEnv -> [UnlinkedBCO] - -> IO (ClosureEnv, DataConEnv, [HValue]) + -> IO (ClosureEnv, [HValue]) -- The returned HValues are associated 1-1 with -- the incoming unlinked BCOs. Each gives the -- value of the corresponding unlinked BCO -linkSomeBCOs toplevs_only ie ce_in de_in ul_bcos +linkSomeBCOs toplevs_only ie ce_in ul_bcos = do let nms = map unlinkedBCOName ul_bcos hvals <- fixIO ( \ hvs -> let ce_out = extendClosureEnv ce_in (zipLazy nms hvs) @@ -750,13 +795,7 @@ linkSomeBCOs toplevs_only ie ce_in de_in ul_bcos -- closure environment, which leads to trouble. ASSERT (all (not . (`elemNameEnv` ce_in)) (map fst ce_additions)) extendClosureEnv ce_in ce_additions - names = concatMap (ssElts . unlinkedBCOItbls) ul_bcos - addresses <- mapM (lookupIE ie) names - let de_additions = [(address, name) | (address, name) <- zip addresses names - , not(address `elemAddressEnv` de_in) - ] - de_out = extendAddressEnvList de_in de_additions - return ( ce_out, de_out, hvals) + return (ce_out, hvals) \end{code} diff --git a/compiler/ghci/ObjLink.lhs b/compiler/ghci/ObjLink.lhs index 135afbb..d032a36 100644 --- a/compiler/ghci/ObjLink.lhs +++ b/compiler/ghci/ObjLink.lhs @@ -18,11 +18,9 @@ module ObjLink ( unloadObj, -- :: String -> IO () insertSymbol, -- :: String -> String -> Ptr a -> IO () lookupSymbol, -- :: String -> IO (Maybe (Ptr a)) - resolveObjs, -- :: IO SuccessFlag - lookupDataCon -- :: Ptr a -> IO (Maybe String) + resolveObjs -- :: IO SuccessFlag ) where -import ByteCodeItbls ( StgInfoTable ) import Panic ( panic ) import BasicTypes ( SuccessFlag, successIf ) import Config ( cLeadingUnderscore ) @@ -33,8 +31,6 @@ import Foreign.C import Foreign ( nullPtr ) import GHC.Exts ( Ptr(..), unsafeCoerce# ) -import Constants ( wORD_SIZE ) -import Foreign ( plusPtr ) -- --------------------------------------------------------------------------- @@ -57,14 +53,6 @@ lookupSymbol str_in = do then return Nothing else return (Just addr) --- | Expects a Ptr to an info table, not to a closure -lookupDataCon :: Ptr StgInfoTable -> IO (Maybe String) -lookupDataCon ptr = do - name <- c_lookupDataCon (ptr `plusPtr` (wORD_SIZE*2)) - if name == nullPtr - then return Nothing - else peekCString name >>= return . Just - prefixUnderscore :: String -> String prefixUnderscore | cLeadingUnderscore == "YES" = ('_':) @@ -108,6 +96,4 @@ foreign import ccall unsafe "lookupSymbol" c_lookupSymbol :: CString -> IO (Ptr foreign import ccall unsafe "loadObj" c_loadObj :: CString -> IO Int foreign import ccall unsafe "unloadObj" c_unloadObj :: CString -> IO Int foreign import ccall unsafe "resolveObjs" c_resolveObjs :: IO Int -foreign import ccall unsafe "lookupDataCon" c_lookupDataCon :: Ptr a -> IO CString - \end{code} diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index 8fd15c0..26816a0 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -10,14 +10,6 @@ module RtClosureInspect( cvObtainTerm, -- :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term - AddressEnv(..), - DataConEnv, - extendAddressEnvList, - elemAddressEnv, - delFromAddressEnv, - emptyAddressEnv, - lookupAddressEnv, - ClosureType(..), getClosureData, -- :: a -> IO Closure Closure ( tipe, infoTable, ptrs, nonPtrs ), @@ -623,34 +615,3 @@ map Just [[1,1],[2,2]] :: [Maybe [Integer]] NOTE: (Num t) contexts have been manually replaced by Integer for clarity -} - --------------------------------------------------------------------- --- The DataConEnv is used to store the addresses of datacons loaded --- via the dynamic linker --------------------------------------------------------------------- - -type DataConEnv = AddressEnv StgInfoTable - --- Note that this AddressEnv and DataConEnv I wrote trying to follow --- conventions in ghc, but probably they make not much sense. - -newtype AddressEnv a = AE {aenv:: FiniteMap (Ptr a) Name} - deriving (Outputable) - -emptyAddressEnv = AE emptyFM - -extendAddressEnvList :: AddressEnv a -> [(Ptr a, Name)] -> AddressEnv a -elemAddressEnv :: Ptr a -> AddressEnv a -> Bool -delFromAddressEnv :: AddressEnv a -> Ptr a -> AddressEnv a -nullAddressEnv :: AddressEnv a -> Bool -lookupAddressEnv :: AddressEnv a -> Ptr a -> Maybe Name - -extendAddressEnvList (AE env) = AE . addListToFM env -elemAddressEnv ptr (AE env) = ptr `elemFM` env -delFromAddressEnv (AE env) = AE . delFromFM env -nullAddressEnv = isEmptyFM . aenv -lookupAddressEnv (AE env) = lookupFM env - - -instance Outputable (Ptr a) where - ppr = text . show diff --git a/includes/ClosureMacros.h b/includes/ClosureMacros.h index f40f6aa..cae5f13 100644 --- a/includes/ClosureMacros.h +++ b/includes/ClosureMacros.h @@ -59,6 +59,7 @@ #define get_ret_itbl(c) (RET_INFO_PTR_TO_STRUCT((c)->header.info)) #define get_fun_itbl(c) (FUN_INFO_PTR_TO_STRUCT((c)->header.info)) #define get_thunk_itbl(c) (THUNK_INFO_PTR_TO_STRUCT((c)->header.info)) +#define get_con_itbl(c) (CON_INFO_PTR_TO_STRUCT((c)->header.info)) #define GET_TAG(con) (get_itbl(con)->srt_bitmap) @@ -67,17 +68,21 @@ #define RET_INFO_PTR_TO_STRUCT(info) ((StgRetInfoTable *)(info) - 1) #define FUN_INFO_PTR_TO_STRUCT(info) ((StgFunInfoTable *)(info) - 1) #define THUNK_INFO_PTR_TO_STRUCT(info) ((StgThunkInfoTable *)(info) - 1) +#define CON_INFO_PTR_TO_STRUCT(info) ((StgConInfoTable *)(info) - 1) #define itbl_to_fun_itbl(i) ((StgFunInfoTable *)(((StgInfoTable *)(i) + 1)) - 1) #define itbl_to_ret_itbl(i) ((StgRetInfoTable *)(((StgInfoTable *)(i) + 1)) - 1) #define itbl_to_thunk_itbl(i) ((StgThunkInfoTable *)(((StgInfoTable *)(i) + 1)) - 1) +#define itbl_to_con_itbl(i) ((StgConInfoTable *)(((StgInfoTable *)(i) + 1)) - 1) #else #define INFO_PTR_TO_STRUCT(info) ((StgInfoTable *)info) #define RET_INFO_PTR_TO_STRUCT(info) ((StgRetInfoTable *)info) #define FUN_INFO_PTR_TO_STRUCT(info) ((StgFunInfoTable *)info) #define THUNK_INFO_PTR_TO_STRUCT(info) ((StgThunkInfoTable *)info) +#define CON_INFO_PTR_TO_STRUCT(info) ((StgConInfoTable *)info) #define itbl_to_fun_itbl(i) ((StgFunInfoTable *)(i)) #define itbl_to_ret_itbl(i) ((StgRetInfoTable *)(i)) #define itbl_to_thunk_itbl(i) ((StgThunkInfoTable *)(i)) +#define itbl_to_con_itbl(i) ((StgConInfoTable *)(i)) #endif /* ----------------------------------------------------------------------------- diff --git a/includes/InfoTables.h b/includes/InfoTables.h index 8fa699a..ea01abf 100644 --- a/includes/InfoTables.h +++ b/includes/InfoTables.h @@ -380,6 +380,22 @@ typedef struct _StgThunkInfoTable { #endif } StgThunkInfoTable; +/* ----------------------------------------------------------------------------- + Constructor info tables + -------------------------------------------------------------------------- */ + +typedef struct _StgConInfoTable { +#if !defined(TABLES_NEXT_TO_CODE) + StgInfoTable i; +#endif + +char *con_desc; /* the name of the data constructor as: Package:Module.Name */ + +#if defined(TABLES_NEXT_TO_CODE) + StgInfoTable i; +#endif +} StgConInfoTable; + /* ----------------------------------------------------------------------------- Accessor macros for fields that might be offsets (C version) diff --git a/includes/Linker.h b/includes/Linker.h index 624d389..681a7f9 100644 --- a/includes/Linker.h +++ b/includes/Linker.h @@ -33,9 +33,6 @@ HsInt resolveObjs( void ); /* load a dynamic library */ char *addDLL( char* dll_name ); -/* lookup an address in the datacon tbl */ -char *lookupDataCon( StgWord addr); - extern void markRootPtrTable(void (*)(StgClosure **)); #endif /* LINKER_H */ diff --git a/rts/Linker.c b/rts/Linker.c index 79febe7..dc31869 100644 --- a/rts/Linker.c +++ b/rts/Linker.c @@ -95,11 +95,6 @@ static /*Str*/HashTable *symhash; /* Hash table mapping symbol names to StgStablePtr */ static /*Str*/HashTable *stablehash; -#if defined(DEBUGGER) -/* Hash table mapping info table ptrs to DataCon names */ -static HashTable *dchash; -#endif - /* List of currently loaded objects */ ObjectCode *objects = NULL; /* initially empty */ @@ -546,7 +541,6 @@ typedef struct _RtsSymbolVal { SymX(insertStableSymbol) \ SymX(insertSymbol) \ SymX(lookupSymbol) \ - SymX(lookupDataCon) \ SymX(makeStablePtrzh_fast) \ SymX(minusIntegerzh_fast) \ SymX(mkApUpd0zh_fast) \ @@ -817,7 +811,6 @@ static RtsSymbolVal rtsSyms[] = { /* ----------------------------------------------------------------------------- * Insert symbols into hash tables, checking for duplicates. */ -int isSuffixOf(char* x, char* suffix); static void ghciInsertStrHashTable ( char* obj_name, HashTable *table, @@ -828,15 +821,6 @@ static void ghciInsertStrHashTable ( char* obj_name, if (lookupHashTable(table, (StgWord)key) == NULL) { insertStrHashTable(table, (StgWord)key, data); -#if defined(DEBUGGER) - // Insert the reverse pair in the datacon hash if it is a closure - { - if(isSuffixOf(key, "static_info") || isSuffixOf(key, "con_info")) { - insertHashTable(dchash, (StgWord)data, key); - // debugBelch("DChash addSymbol: %s (%p)\n", key, data); - } - } -#endif return; } debugBelch( @@ -882,9 +866,6 @@ initLinker( void ) stablehash = allocStrHashTable(); symhash = allocStrHashTable(); -#if defined(DEBUGGER) - dchash = allocHashTable(); -#endif /* populate the symbol table with stuff from the RTS */ for (sym = rtsSyms; sym->lbl != NULL; sym++) { @@ -1103,24 +1084,6 @@ lookupSymbol( char *lbl ) } } -#if defined(DEBUGGER) -char * -lookupDataCon( StgWord addr ) -{ - void *val; - initLinker() ; - ASSERT(dchash != NULL); - val = lookupHashTable(dchash, addr); - - return val; -} -#else -char* lookupDataCon( StgWord addr ) -{ - return NULL; -} -#endif - static __attribute((unused)) void * @@ -4398,17 +4361,3 @@ static int machoGetMisalignment( FILE * f ) #endif -int isSuffixOf(char* x, char* suffix) { - int suffix_len = strlen (suffix); - int x_len = strlen (x); - - if (x_len == 0) - return 0; - if (suffix_len > x_len) - return 0; - if (suffix_len == 0) - return 1; - - char* x_suffix = &x[strlen(x)-strlen(suffix)]; - return strcmp(x_suffix, suffix) == 0; - } -- 1.7.10.4