{-# OPTIONS -optc-DNON_POSIX_SOURCE -#include "Linker.h" #-}
module Linker ( HValue, getHValue, showLinkerState,
- linkExpr, unload, extendLinkEnv, withExtendedLinkEnv,
- extendLoadedPkgs,
+ linkExpr, unload, withExtendedLinkEnv,
+ extendLinkEnv, deleteFromLinkEnv,
+ extendLoadedPkgs,
linkPackages,initDynLinker,
- recoverDataCon
+ dataConInfoPtrToName
) where
#include "HsVersions.h"
import ByteCodeLink
import ByteCodeItbls
import ByteCodeAsm
-import RtClosureInspect
+import CgInfoTbls
+import SMRep
import IfaceEnv
-import OccName
import TcRnMonad
import Packages
import DriverPhases
import Name
import NameEnv
import NameSet
+import qualified OccName
import UniqFM
import Module
import ListSetOps
import DriverPhases
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:
+deleteFromLinkEnv :: [Name] -> IO ()
+deleteFromLinkEnv to_remove
+ = do pls <- readIORef v_PersistentLinkerState
+ let new_closure_env = delListFromNameEnv (closure_env pls) to_remove
+ new_pls = pls { closure_env = new_closure_env }
+ writeIORef v_PersistentLinkerState new_pls
+
+-- | 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.
-recoverDataCon :: a -> TcM Name
-recoverDataCon x = do
+dataConInfoPtrToName :: Ptr () -> TcM Name
+dataConInfoPtrToName x = do
theString <- ioToTcRn $ do
- let ptr = getInfoTablePtr x
+ let ptr = castPtr x :: Ptr StgInfoTable
conDescAddress <- getConDescAddress ptr
- peekCString conDescAddress
+ peekArray0 0 conDescAddress
let (pkg, mod, occ) = parse theString
- occName = mkOccName OccName.dataName occ
- modName = mkModule (stringToPackageId pkg) (mkModuleName mod)
+ pkgFS = mkFastStringByteList pkg
+ modFS = mkFastStringByteList mod
+ occFS = mkFastStringByteList occ
+ occName = mkOccNameFS OccName.dataName occFS
+ modName = mkModule (fsToPackageId pkgFS) (mkModuleNameFS modFS)
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 $ intPtrToPtr $ (ptrToIntPtr ptr) + offset
- return $ ptr `plusPtr` offsetToString
- where
- -- subtract a word number of bytes
- offset = negate (fromIntegral SIZEOF_VOID_P)
-#endif
-#ifndef GHCI_TABLES_NEXT_TO_CODE
- peek $ intPtrToPtr $ (ptrToIntPtr ptr) + offset
- where
- -- add the standard info table size in bytes
- infoTableSizeBytes = sTD_ITBL_SIZE * wORD_SIZE
- offset = infoTableSizeBytes
+ offsetToString <- peek $ ptr `plusPtr` (- wORD_SIZE)
+ return $ (ptr `plusPtr` stdInfoTableSizeB) `plusPtr` (fromIntegral (offsetToString :: StgWord))
+#else
+ peek $ intPtrToPtr $ (ptrToIntPtr ptr) + 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 :: Name -> IO (Maybe HValue)
-getHValue name = do
- pls <- readIORef v_PersistentLinkerState
- case lookupNameEnv (closure_env pls) name of
- Just (_,x) -> return$ Just x
- _ -> return Nothing
+getHValue :: HscEnv -> Name -> IO HValue
+getHValue hsc_env name = do
+ when (isExternalName name) $ do
+ ok <- linkDependencies hsc_env noSrcSpan [nameModule name]
+ when (failed ok) $ throwDyn (ProgramError "")
+ pls <- readIORef v_PersistentLinkerState
+ lookupName (closure_env pls) name
+
+linkDependencies :: HscEnv -> SrcSpan -> [Module] -> IO SuccessFlag
+linkDependencies hsc_env span needed_mods = do
+ let hpt = hsc_HPT hsc_env
+ dflags = hsc_dflags hsc_env
+ -- The interpreter and dynamic linker can only handle object code built
+ -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky.
+ -- So here we check the build tag: if we're building a non-standard way
+ -- then we need to find & link object files built the "normal" way.
+ maybe_normal_osuf <- checkNonStdWay dflags span
+
+ -- Find what packages and linkables are required
+ eps <- readIORef (hsc_EPS hsc_env)
+ (lnks, pkgs) <- getLinkDeps hsc_env hpt (eps_PIT eps)
+ maybe_normal_osuf span needed_mods
+
+ -- Link the packages and modules required
+ linkPackages dflags pkgs
+ linkModules dflags lnks
+
withExtendedLinkEnv :: [(Name,HValue)] -> IO a -> IO a
withExtendedLinkEnv new_env action
let dflags = hsc_dflags hsc_env
; initDynLinker dflags
- -- The interpreter and dynamic linker can only handle object code built
- -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky.
- -- So here we check the build tag: if we're building a non-standard way
- -- then we need to find & link object files built the "normal" way.
- ; maybe_normal_osuf <- checkNonStdWay dflags span
-
- -- Find what packages and linkables are required
- ; eps <- readIORef (hsc_EPS hsc_env)
- ; (lnks, pkgs) <- getLinkDeps hsc_env hpt (eps_PIT eps)
- maybe_normal_osuf span needed_mods
-
-- Link the packages and modules required
- ; linkPackages dflags pkgs
- ; ok <- linkModules dflags lnks
+ ; ok <- linkDependencies hsc_env span needed_mods
; if failed ok then
throwDyn (ProgramError "")
else do {
; return root_hval
}}
where
- hpt = hsc_HPT hsc_env
free_names = nameSetToList (bcoFreeNames root_ul_bco)
needed_mods :: [Module]
| mi_boot iface
= link_boot_mod_error mod
| otherwise
- = follow_deps (map (mkModule this_pkg) boot_deps ++ mods) acc_mods' acc_pkgs'
+ = follow_deps (map (mkModule this_pkg) boot_deps' ++ mods) acc_mods' acc_pkgs'
where
pkg = modulePackageId mod
iface = get_iface mod
projects / ghc-hetmet.git / blobdiff