%
-% (c) The University of Glasgow 2005
+% (c) The University of Glasgow 2005-2006
%
-- --------------------------------------
\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 ( findModule, findObjectLinkableMaybe, FindResult(..) )
+import DriverPhases
+import Finder
import HscTypes
-import Name ( Name, nameModule, isExternalName, isWiredInName )
+import Name
import NameEnv
-import NameSet ( nameSetToList )
+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 Panic ( GhcException(..) )
-import Util ( zipLazy, global, joinFileExt, joinFileName, suffixOf,
- 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 ( isJust, fromJust )
+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}
pkgs_loaded = init_pkgs,
bcos_loaded = [],
objs_loaded = [] }
+
-- Packages that don't need loading, because the compiler
-- shares them with the interpreted program.
--
-- The linker's symbol table is populated with RTS symbols using an
-- explicit list. See rts/Linker.c for details.
- where init_pkgs
- | ExtPackage rts_id <- rtsPackageId (pkgState dflags) = [rts_id]
- | otherwise = []
+ where init_pkgs = [rtsPackageId]
\end{code}
\begin{code}
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
a) calling the C initialisation procedure
b) Loading any packages specified on the command line,
- now held in v_ExplicitPackages
c) Loading any packages specified on the command line,
now held in the -l options in v_Opt_l
; initObjLinker
-- (b) Load packages from the command-line
- ; linkPackages dflags (explicitPackages (pkgState dflags))
+ ; linkPackages dflags (preloadPackages (pkgState dflags))
-- (c) Link libraries from the command-line
; let optl = getOpts dflags opt_l
--
-- 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 {
}}
where
hpt = hsc_HPT hsc_env
- dflags = hsc_dflags hsc_env
free_names = nameSetToList (bcoFreeNames root_ul_bco)
needed_mods :: [Module]
= 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 linkableModule (objs_loaded pls ++ bcos_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
return (lnks_needed, pkgs_needed) }
where
- get_deps :: Module -> ([Module],[PackageId])
- -- Get the things needed for the specified module
- -- This is rather similar to the code in RnNames.importsFromImportDecl
- get_deps mod
- | ExtPackage p <- mi_package iface
- = ([], p : dep_pkgs deps)
+ dflags = hsc_dflags hsc_env
+ this_pkg = thisPackage dflags
+
+ -- 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
+ = follow_deps mods acc_mods (addOneToUniqSet acc_pkgs' pkg)
+ | mi_boot iface
+ = link_boot_mod_error mod
| otherwise
- = (mod : [m | (m,_) <- dep_mods deps], dep_pkgs deps)
- where
- iface = get_iface mod
- deps = mi_deps iface
+ = 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
- get_iface mod = case lookupIface hpt pit mod of
+ 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
Nothing -> pprPanic "getLinkDeps" (no_iface mod)
no_iface mod = ptext SLIT("No iface for") <+> ppr mod
-- This one is a build-system bug
get_linkable maybe_normal_osuf mod_name -- A home-package module
- | Just mod_info <- lookupModuleEnv hpt mod_name
+ | Just mod_info <- lookupUFM hpt mod_name
= ASSERT(isJust (hm_linkable mod_info))
adjust_linkable (fromJust (hm_linkable mod_info))
| otherwise
- = -- It's not in the HPT because we are in one shot mode,
+ = do -- It's not in the HPT because we are in one shot mode,
-- so use the Finder to get a ModLocation...
- do { mb_stuff <- findModule hsc_env mod_name False ;
- case mb_stuff of {
- Found loc _ -> found loc mod_name ;
+ mb_stuff <- findHomeModule hsc_env mod_name
+ case mb_stuff of
+ Found loc mod -> found loc mod
_ -> no_obj mod_name
- }}
- where
- found loc mod_name = do {
+ where
+ found loc mod = do {
-- ...and then find the linkable for it
- mb_lnk <- findObjectLinkableMaybe mod_name loc ;
+ mb_lnk <- findObjectLinkableMaybe mod loc ;
case mb_lnk of {
- Nothing -> no_obj mod_name ;
+ Nothing -> no_obj mod ;
Just lnk -> adjust_linkable lnk
}}
-- 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
projects / ghc-hetmet.git / blobdiff