X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fghci%2FLinker.lhs;h=38d584a633f7cb46a94161c67654573a0f5b8998;hp=976fe92a888231a19a9d2aadbadd2343048a5211;hb=cdce647711c0f46f5799b24de087622cb77e647f;hpb=05e066c439c22f05de5fbcc0d11c515444ca0f16 diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index 976fe92..38d584a 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -1,5 +1,5 @@ % -% (c) The University of Glasgow 2005 +% (c) The University of Glasgow 2005-2006 % -- -------------------------------------- @@ -12,65 +12,65 @@ necessary. \begin{code} - {-# OPTIONS -optc-DNON_POSIX_SOURCE -#include "Linker.h" #-} -module Linker ( HValue, showLinkerState, +module Linker ( HValue, getHValue, showLinkerState, linkExpr, unload, extendLinkEnv, withExtendedLinkEnv, extendLoadedPkgs, - linkPackages,initDynLinker + linkPackages,initDynLinker, + dataConInfoPtrToName ) where #include "HsVersions.h" -import ObjLink ( loadDLL, loadObj, unloadObj, resolveObjs, initObjLinker ) -import ByteCodeLink ( HValue, ClosureEnv, extendClosureEnv, linkBCO ) -import ByteCodeItbls ( ItblEnv ) -import ByteCodeAsm ( CompiledByteCode(..), bcoFreeNames, UnlinkedBCO(..)) - +import ObjLink +import ByteCodeLink +import ByteCodeItbls +import ByteCodeAsm +import RtClosureInspect +import CgInfoTbls +import SMRep +import IfaceEnv +import TcRnMonad import Packages -import DriverPhases ( isObjectFilename, isDynLibFilename ) -import Finder ( findHomeModule, findObjectLinkableMaybe, - FindResult(..) ) +import DriverPhases +import Finder import HscTypes -import Name ( Name, nameModule, isExternalName, isWiredInName ) +import Name import NameEnv -import NameSet ( nameSetToList ) -import UniqFM ( lookupUFM ) +import NameSet +import qualified OccName +import UniqFM import Module -import ListSetOps ( minusList ) -import DynFlags ( DynFlags(..), getOpts ) -import BasicTypes ( SuccessFlag(..), succeeded, failed ) +import ListSetOps +import DynFlags +import BasicTypes import Outputable -import PackageConfig ( rtsPackageId ) -import Panic ( GhcException(..) ) -import Util ( zipLazy, global, joinFileExt, joinFileName, - replaceFilenameSuffix ) -import StaticFlags ( v_Ld_inputs, v_Build_tag ) -import ErrUtils ( debugTraceMsg, mkLocMessage ) -import DriverPhases ( phaseInputExt, Phase(..) ) -import SrcLoc ( SrcSpan ) +import PackageConfig +import Panic +import Util +import StaticFlags +import ErrUtils +import DriverPhases +import SrcLoc +import UniqSet +import Constants -- Standard libraries -import Control.Monad ( when, filterM, foldM ) - -import Data.IORef ( IORef, readIORef, writeIORef, modifyIORef ) -import Data.List ( partition, nub ) +import Control.Monad -import System.IO ( putStr, putStrLn, hPutStrLn, stderr, fixIO ) -import System.Directory ( doesFileExist ) +import Data.IORef +import Data.List +import Foreign.Ptr +import Foreign.C.Types +import Foreign.C.String +import Foreign.Storable -import Control.Exception ( block, throwDyn, bracket ) -import Maybe ( fromJust ) -#ifdef DEBUG -import Maybe ( isJust ) -#endif +import System.IO +import System.Directory -#if __GLASGOW_HASKELL__ >= 503 -import GHC.IOBase ( IO(..) ) -#else -import PrelIOBase ( IO(..) ) -#endif +import Control.Exception +import Data.Maybe \end{code} @@ -123,6 +123,7 @@ emptyPLS dflags = PersistentLinkerState { pkgs_loaded = init_pkgs, bcos_loaded = [], objs_loaded = [] } + -- Packages that don't need loading, because the compiler -- shares them with the interpreted program. -- @@ -144,6 +145,108 @@ 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. + +dataConInfoPtrToName :: Ptr () -> TcM Name +dataConInfoPtrToName x = do + theString <- ioToTcRn $ do + let ptr = castPtr x :: Ptr StgInfoTable + conDescAddress <- getConDescAddress ptr + str <- peekCString conDescAddress + return str + 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 +#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 +#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 + pls <- readIORef v_PersistentLinkerState + case lookupNameEnv (closure_env pls) name of + Just (_,x) -> return$ Just x + _ -> return Nothing + withExtendedLinkEnv :: [(Name,HValue)] -> IO a -> IO a withExtendedLinkEnv new_env action = bracket set_new_env @@ -330,6 +433,8 @@ linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO HValue -- -- Raises an IO exception if it can't find a compiled version of the -- dependents to link. +-- +-- Note: This function side-effects the linker state (Pepe) linkExpr hsc_env span root_ul_bco = do { @@ -408,17 +513,18 @@ getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods = do { pls <- readIORef v_PersistentLinkerState ; let { -- 1. Find the dependent home-pkg-modules/packages from each iface - (mods_s, pkgs_s) = unzip (map get_deps mods) ; + (mods_s, pkgs_s) = follow_deps mods emptyUniqSet emptyUniqSet; -- 2. Exclude ones already linked -- Main reason: avoid findModule calls in get_linkable - mods_needed = nub (concat mods_s) `minusList` linked_mods ; - pkgs_needed = nub (concat pkgs_s) `minusList` pkgs_loaded pls ; + mods_needed = mods_s `minusList` linked_mods ; + pkgs_needed = pkgs_s `minusList` pkgs_loaded pls ; linked_mods = map (moduleName.linkableModule) (objs_loaded pls ++ bcos_loaded pls) } ; +-- putStrLn (showSDoc (ppr mods_s)) ; -- 3. For each dependent module, find its linkable -- This will either be in the HPT or (in the case of one-shot -- compilation) we may need to use maybe_getFileLinkable @@ -429,17 +535,43 @@ getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods dflags = hsc_dflags hsc_env this_pkg = thisPackage dflags - get_deps :: Module -> ([ModuleName],[PackageId]) - -- Get the things needed for the specified module - -- This is rather similar to the code in RnNames.importsFromImportDecl - get_deps mod + -- The ModIface contains the transitive closure of the module dependencies + -- within the current package, *except* for boot modules: if we encounter + -- a boot module, we have to find its real interface and discover the + -- dependencies of that. Hence we need to traverse the dependency + -- tree recursively. See bug #936, testcase ghci/prog007. + follow_deps :: [Module] -- modules to follow + -> UniqSet ModuleName -- accum. module dependencies + -> UniqSet PackageId -- accum. package dependencies + -> ([ModuleName], [PackageId]) -- result + follow_deps [] acc_mods acc_pkgs + = (uniqSetToList acc_mods, uniqSetToList acc_pkgs) + follow_deps (mod:mods) acc_mods acc_pkgs | pkg /= this_pkg - = ([], pkg : dep_pkgs deps) + = follow_deps mods acc_mods (addOneToUniqSet acc_pkgs' pkg) + | mi_boot iface + = link_boot_mod_error mod | otherwise - = (moduleName mod : [m | (m,_) <- dep_mods deps], dep_pkgs deps) - where - pkg = modulePackageId mod - deps = mi_deps (get_iface mod) + = follow_deps (map (mkModule this_pkg) boot_deps ++ mods) acc_mods' acc_pkgs' + where + pkg = modulePackageId mod + iface = get_iface mod + deps = mi_deps iface + + pkg_deps = dep_pkgs deps + (boot_deps, mod_deps) = partitionWith is_boot (dep_mods deps) + where is_boot (m,True) = Left m + is_boot (m,False) = Right m + + boot_deps' = filter (not . (`elementOfUniqSet` acc_mods)) boot_deps + acc_mods' = addListToUniqSet acc_mods (moduleName mod : mod_deps) + acc_pkgs' = addListToUniqSet acc_pkgs pkg_deps + + + link_boot_mod_error mod = + throwDyn (ProgramError (showSDoc ( + text "module" <+> ppr mod <+> + text "cannot be linked; it is only available as a boot module"))) get_iface mod = case lookupIfaceByModule dflags hpt pit mod of Just iface -> iface @@ -641,13 +773,11 @@ linkSomeBCOs :: Bool -- False <=> add _all_ BCOs to returned closure env -- the incoming unlinked BCOs. Each gives the -- value of the corresponding unlinked BCO - 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) in mapM (linkBCO ie ce_out) ul_bcos ) - let ce_all_additions = zip nms hvals ce_top_additions = filter (isExternalName.fst) ce_all_additions ce_additions = if toplevs_only then ce_top_additions