import SrcLoc
import UniqSet
import Constants
+import FastString
-- Standard libraries
import Control.Monad
+import Data.Char
import Data.IORef
import Data.List
-import Foreign.Ptr
-import Foreign.C.Types
-import Foreign.C.String
-import Foreign.Storable
+import Foreign
import System.IO
import System.Directory
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:
+-- | Given a data constructor in the heap, find its Name.
+-- The info tables for data constructors have a field which records
+-- the source name of the constructor as a Ptr Word8 (UTF-8 encoded
+-- string). The format is:
--
-- Package:Module.Name
--
-- We use this string to lookup the interpreter's internal representation of the name
-- using the lookupOrig.
-dataConInfoPtrToName :: Ptr () -> TcM Name
+dataConInfoPtrToName :: Ptr () -> TcM (Either String Name)
dataConInfoPtrToName x = do
theString <- ioToTcRn $ do
let ptr = castPtr x :: Ptr StgInfoTable
conDescAddress <- getConDescAddress ptr
- str <- peekCString conDescAddress
- return str
+ peekArray0 0 conDescAddress
let (pkg, mod, occ) = parse theString
- occName = mkOccName OccName.dataName occ
- modName = mkModule (stringToPackageId pkg) (mkModuleName mod)
- lookupOrig modName occName
+ pkgFS = mkFastStringByteList pkg
+ modFS = mkFastStringByteList mod
+ occFS = mkFastStringByteList occ
+ occName = mkOccNameFS OccName.dataName occFS
+ modName = mkModule (fsToPackageId pkgFS) (mkModuleNameFS modFS)
+ return (Left$ showSDoc$ ppr modName <> dot <> ppr occName )
+ `recoverM` (Right `fmap` lookupOrig modName occName)
where
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
#ifdef GHCI_TABLES_NEXT_TO_CODE
offsetToString <- peek $ ptr `plusPtr` (- wORD_SIZE)
return $ (ptr `plusPtr` stdInfoTableSizeB) `plusPtr` (fromIntegral (offsetToString :: StgWord))
#else
- peek $ intPtrToPtr $ (ptrToIntPtr ptr) + stdInfoTableSizeB
+ peek $ intPtrToPtr $ (ptrToIntPtr ptr) + fromIntegral stdInfoTableSizeB
#endif
-- parsing names is a little bit fiddly because we have a string in the form:
-- 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 :: [Word8] -> ([Word8], [Word8], [Word8])
parse input
= ASSERT (all (>0) (map length [pkg, mod, occ])) (pkg, mod, occ)
where
- (pkg, rest1) = break (==':') input
+ dot = fromIntegral (ord '.')
+ (pkg, rest1) = break (== fromIntegral (ord ':')) input
(mod, occ)
- = (concat $ intersperse "." $ reverse modWords, occWord)
+ = (concat $ intersperse [dot] $ reverse modWords, occWord)
where
(modWords, occWord) = ASSERT (length rest1 > 0) (parseModOcc [] (tail rest1))
- parseModOcc :: [String] -> String -> ([String], String)
+ parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8])
parseModOcc acc str
- = case break (== '.') str of
+ = case break (== dot) str of
(top, []) -> (acc, top)
- (top, '.':bot) -> parseModOcc (top : acc) bot
+ (top, _:bot) -> parseModOcc (top : acc) bot
getHValue :: HscEnv -> Name -> IO HValue
linkModules dflags lnks
+-- | Temporarily extend the linker state.
+
withExtendedLinkEnv :: [(Name,HValue)] -> IO a -> IO a
withExtendedLinkEnv new_env action
= bracket set_new_env
reset_old_env
(const action)
- where set_new_env = do pls <- readIORef v_PersistentLinkerState
- let new_closure_env = extendClosureEnv (closure_env pls) new_env
- new_pls = pls { closure_env = new_closure_env }
- writeIORef v_PersistentLinkerState new_pls
- return (closure_env pls)
- reset_old_env env = modifyIORef v_PersistentLinkerState (\pls -> pls{ closure_env = env })
+ where set_new_env = do
+ pls <- readIORef v_PersistentLinkerState
+ let new_closure_env = extendClosureEnv (closure_env pls) new_env
+ new_pls = pls { closure_env = new_closure_env }
+ writeIORef v_PersistentLinkerState new_pls
+ return (closure_env pls)
+
+ -- Remember that the linker state might be side-effected
+ -- during the execution of the IO action, and we don't want to
+ -- lose those changes (we might have linked a new module or
+ -- package), so the reset action only removes the names we
+ -- added earlier.
+ reset_old_env env = do
+ modifyIORef v_PersistentLinkerState $ \pls ->
+ let cur = closure_env pls
+ new = delListFromNameEnv cur (map fst new_env)
+ in
+ pls{ closure_env = new }
-- filterNameMap removes from the environment all entries except
-- those for a given set of modules;