Commit 9c54ee0c authored by Simon Marlow's avatar Simon Marlow

Store the constructor name in the info table in UTF-8

parent ab13303c
...@@ -43,6 +43,11 @@ import ListSetOps ...@@ -43,6 +43,11 @@ import ListSetOps
import Util import Util
import Maybes import Maybes
import FastString import FastString
import PackageConfig
import Module
import Data.Char
import Data.Word
\end{code} \end{code}
...@@ -518,19 +523,6 @@ mk_dict_strict_mark pred | isStrictPred pred = MarkedStrict ...@@ -518,19 +523,6 @@ mk_dict_strict_mark pred | isStrictPred pred = MarkedStrict
dataConName :: DataCon -> Name dataConName :: DataCon -> Name
dataConName = dcName 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 :: DataCon -> ConTag
dataConTag = dcTag dataConTag = dcTag
...@@ -694,6 +686,19 @@ dataConRepArgTys :: DataCon -> [Type] ...@@ -694,6 +686,19 @@ dataConRepArgTys :: DataCon -> [Type]
dataConRepArgTys dc = dcRepArgTys dc dataConRepArgTys dc = dcRepArgTys dc
\end{code} \end{code}
The string <package>:<module>.<name> identifying a constructor, which is attached
to its info table and used by the GHCi debugger and the heap profiler. We want
this string to be UTF-8, so we get the bytes directly from the FastStrings.
\begin{code}
dataConIdentity :: DataCon -> [Word8]
dataConIdentity dc = bytesFS (packageIdFS (modulePackageId mod)) ++
fromIntegral (ord ':') : bytesFS (moduleNameFS (moduleName mod)) ++
fromIntegral (ord '.') : bytesFS (occNameFS (nameOccName name))
where name = dataConName dc
mod = nameModule name
\end{code}
\begin{code} \begin{code}
isTupleCon :: DataCon -> Bool isTupleCon :: DataCon -> Bool
......
...@@ -43,12 +43,18 @@ import Name ...@@ -43,12 +43,18 @@ import Name
import DataCon import DataCon
import Unique import Unique
import StaticFlags import StaticFlags
import FastString
import Packages
import Module
import Maybes import Maybes
import Constants import Constants
import Outputable import Outputable
import Data.Char
import Data.Word
------------------------------------------------------------------------- -------------------------------------------------------------------------
-- --
-- Generating the info table and code for a closure -- Generating the info table and code for a closure
...@@ -89,7 +95,7 @@ emitClosureCodeAndInfoTable cl_info args body ...@@ -89,7 +95,7 @@ emitClosureCodeAndInfoTable cl_info args body
; conName <- ; conName <-
if is_con if is_con
then do cstr <- mkStringCLit $ fromJust conIdentity then do cstr <- mkByteStringCLit $ fromJust conIdentity
return (makeRelativeRefTo info_lbl cstr) return (makeRelativeRefTo info_lbl cstr)
else return (mkIntCLit 0) else return (mkIntCLit 0)
...@@ -111,7 +117,8 @@ emitClosureCodeAndInfoTable cl_info args body ...@@ -111,7 +117,8 @@ emitClosureCodeAndInfoTable cl_info args body
Just con -> -- Constructors don't have an SRT Just con -> -- Constructors don't have an SRT
-- We keep the *zero-indexed* tag in the srt_len -- We keep the *zero-indexed* tag in the srt_len
-- field of the info table. -- field of the info table.
(mkIntCLit 0, fromIntegral (dataConTagZ con), Just $ dataConIdentity con) (mkIntCLit 0, fromIntegral (dataConTagZ con),
Just $ dataConIdentity con)
Nothing -> -- Not a constructor Nothing -> -- Not a constructor
let (label, len) = srtLabelAndLength srt info_lbl let (label, len) = srtLabelAndLength srt info_lbl
......
...@@ -26,7 +26,7 @@ module CgUtils ( ...@@ -26,7 +26,7 @@ module CgUtils (
addToMem, addToMemE, addToMem, addToMemE,
mkWordCLit, mkWordCLit,
mkStringCLit, mkStringCLit, mkByteStringCLit,
packHalfWordsCLit, packHalfWordsCLit,
blankWord blankWord
) where ) where
......
...@@ -117,7 +117,7 @@ make_constr_itbls cons ...@@ -117,7 +117,7 @@ make_constr_itbls cons
, code = code , code = code
#endif #endif
} }
qNameCString <- newCString $ dataConIdentity dcon qNameCString <- newArray0 0 $ dataConIdentity dcon
let conInfoTbl = StgConInfoTable { let conInfoTbl = StgConInfoTable {
conDesc = qNameCString, conDesc = qNameCString,
infoTable = itbl infoTable = itbl
...@@ -273,7 +273,7 @@ type HalfWord = Word16 ...@@ -273,7 +273,7 @@ type HalfWord = Word16
#endif #endif
data StgConInfoTable = StgConInfoTable { data StgConInfoTable = StgConInfoTable {
conDesc :: CString, conDesc :: Ptr Word8,
infoTable :: StgInfoTable infoTable :: StgInfoTable
} }
......
...@@ -55,16 +55,15 @@ import DriverPhases ...@@ -55,16 +55,15 @@ import DriverPhases
import SrcLoc import SrcLoc
import UniqSet import UniqSet
import Constants import Constants
import FastString
-- Standard libraries -- Standard libraries
import Control.Monad import Control.Monad
import Data.Char
import Data.IORef import Data.IORef
import Data.List import Data.List
import Foreign.Ptr import Foreign
import Foreign.C.Types
import Foreign.C.String
import Foreign.Storable
import System.IO import System.IO
import System.Directory import System.Directory
...@@ -152,9 +151,10 @@ deleteFromLinkEnv to_remove ...@@ -152,9 +151,10 @@ deleteFromLinkEnv to_remove
new_pls = pls { closure_env = new_closure_env } new_pls = pls { closure_env = new_closure_env }
writeIORef v_PersistentLinkerState new_pls writeIORef v_PersistentLinkerState new_pls
-- | Given a data constructor, find its internal name. -- | Given a data constructor in the heap, find its Name.
-- The info tables for data constructors have a field which records the source name -- The info tables for data constructors have a field which records
-- of the constructor as a CString. The format is: -- the source name of the constructor as a Ptr Word8 (UTF-8 encoded
-- string). The format is:
-- --
-- Package:Module.Name -- Package:Module.Name
-- --
...@@ -166,11 +166,13 @@ dataConInfoPtrToName x = do ...@@ -166,11 +166,13 @@ dataConInfoPtrToName x = do
theString <- ioToTcRn $ do theString <- ioToTcRn $ do
let ptr = castPtr x :: Ptr StgInfoTable let ptr = castPtr x :: Ptr StgInfoTable
conDescAddress <- getConDescAddress ptr conDescAddress <- getConDescAddress ptr
str <- peekCString conDescAddress peekArray0 0 conDescAddress
return str
let (pkg, mod, occ) = parse theString let (pkg, mod, occ) = parse theString
occName = mkOccName OccName.dataName occ pkgFS = mkFastStringByteList pkg
modName = mkModule (stringToPackageId pkg) (mkModuleName mod) modFS = mkFastStringByteList mod
occFS = mkFastStringByteList occ
occName = mkOccNameFS OccName.dataName occFS
modName = mkModule (fsToPackageId pkgFS) (mkModuleNameFS modFS)
lookupOrig modName occName lookupOrig modName occName
where where
...@@ -215,7 +217,7 @@ dataConInfoPtrToName x = do ...@@ -215,7 +217,7 @@ dataConInfoPtrToName x = do
in the memory location: info_table_ptr + info_table_size in the memory location: info_table_ptr + info_table_size
-} -}
getConDescAddress :: Ptr StgInfoTable -> IO (Ptr CChar) getConDescAddress :: Ptr StgInfoTable -> IO (Ptr Word8)
getConDescAddress ptr = do getConDescAddress ptr = do
#ifdef GHCI_TABLES_NEXT_TO_CODE #ifdef GHCI_TABLES_NEXT_TO_CODE
offsetToString <- peek $ ptr `plusPtr` (- wORD_SIZE) offsetToString <- peek $ ptr `plusPtr` (- wORD_SIZE)
...@@ -231,20 +233,21 @@ dataConInfoPtrToName x = do ...@@ -231,20 +233,21 @@ dataConInfoPtrToName x = do
-- this is not the conventional way of writing Haskell names. We stick with -- this is not the conventional way of writing Haskell names. We stick with
-- convention, even though it makes the parsing code more troublesome. -- convention, even though it makes the parsing code more troublesome.
-- Warning: this code assumes that the string is well formed. -- Warning: this code assumes that the string is well formed.
parse :: String -> (String, String, String) parse :: [Word8] -> ([Word8], [Word8], [Word8])
parse input parse input
= ASSERT (all (>0) (map length [pkg, mod, occ])) (pkg, mod, occ) = ASSERT (all (>0) (map length [pkg, mod, occ])) (pkg, mod, occ)
where where
(pkg, rest1) = break (==':') input dot = fromIntegral (ord '.')
(pkg, rest1) = break (== fromIntegral (ord ':')) input
(mod, occ) (mod, occ)
= (concat $ intersperse "." $ reverse modWords, occWord) = (concat $ intersperse [dot] $ reverse modWords, occWord)
where where
(modWords, occWord) = ASSERT (length rest1 > 0) (parseModOcc [] (tail rest1)) (modWords, occWord) = ASSERT (length rest1 > 0) (parseModOcc [] (tail rest1))
parseModOcc :: [String] -> String -> ([String], String) parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8])
parseModOcc acc str parseModOcc acc str
= case break (== '.') str of = case break (== dot) str of
(top, []) -> (acc, top) (top, []) -> (acc, top)
(top, '.':bot) -> parseModOcc (top : acc) bot (top, _:bot) -> parseModOcc (top : acc) bot
getHValue :: HscEnv -> Name -> IO HValue getHValue :: HscEnv -> Name -> IO HValue
......
...@@ -24,6 +24,7 @@ module FastString ...@@ -24,6 +24,7 @@ module FastString
-- ** Construction -- ** Construction
mkFastString, mkFastString,
mkFastStringBytes, mkFastStringBytes,
mkFastStringByteList,
mkFastStringForeignPtr, mkFastStringForeignPtr,
mkFastString#, mkFastString#,
mkZFastString, mkZFastString,
...@@ -275,6 +276,15 @@ mkFastString str = ...@@ -275,6 +276,15 @@ mkFastString str =
utf8EncodeString ptr str utf8EncodeString ptr str
mkFastStringForeignPtr ptr buf l mkFastStringForeignPtr ptr buf l
-- | Creates a 'FastString' from a UTF-8 encoded @[Word8]@
mkFastStringByteList :: [Word8] -> FastString
mkFastStringByteList str =
inlinePerformIO $ do
let l = Prelude.length str
buf <- mallocForeignPtrBytes l
withForeignPtr buf $ \ptr -> do
pokeArray (castPtr ptr) str
mkFastStringForeignPtr ptr buf l
-- | Creates a Z-encoded 'FastString' from a 'String' -- | Creates a Z-encoded 'FastString' from a 'String'
mkZFastString :: String -> FastString mkZFastString :: String -> FastString
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment