X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FLinker.lhs;h=76e9f318c99c8017ab3ed7ed0fceac3b0b9ba26b;hb=26b80e2f7ae773c33067b7f259e2b83bfb08d6b6;hp=2c1b668e6556d965cc9901dafdce22bc609fe63b;hpb=317fc69d18eda68fd65f5ba634feafbe4a3923da;p=ghc-hetmet.git diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index 2c1b668..76e9f31 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -15,10 +15,11 @@ necessary. {-# 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" @@ -27,9 +28,9 @@ import ObjLink import ByteCodeLink import ByteCodeItbls import ByteCodeAsm -import RtClosureInspect +import CgInfoTbls +import SMRep import IfaceEnv -import OccName import TcRnMonad import Packages import DriverPhases @@ -38,6 +39,7 @@ import HscTypes import Name import NameEnv import NameSet +import qualified OccName import UniqFM import Module import ListSetOps @@ -52,16 +54,16 @@ import ErrUtils 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 @@ -142,24 +144,35 @@ 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: +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 @@ -204,21 +217,13 @@ recoverDataCon x = do 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: @@ -228,28 +233,50 @@ recoverDataCon x = do -- 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 @@ -446,20 +473,8 @@ linkExpr hsc_env span root_ul_bco 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 { @@ -474,7 +489,6 @@ linkExpr hsc_env span root_ul_bco ; return root_hval }} where - hpt = hsc_HPT hsc_env free_names = nameSetToList (bcoFreeNames root_ul_bco) needed_mods :: [Module] @@ -556,7 +570,7 @@ getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods | 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