X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FLinker.lhs;h=d2c7fe10810dd1510d673826352a3fe34931b315;hb=1a1164f580d910ad41cb52a17c989cef02010dae;hp=26f40ebbe4e13bea04ed7d03cef4a999fc7d6fa3;hpb=61d2625ae2e6a4cdae2ffc92df828905e81c24cc;p=ghc-hetmet.git diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index 26f40eb..d2c7fe1 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,59 +12,63 @@ 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, + recoverDataCon ) 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 IfaceEnv +import Config +import OccName +import TcRnMonad +import Constants +import Encoding 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 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, 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 -- Standard libraries -import Control.Monad ( when, filterM, foldM ) +import Control.Monad +import Control.Arrow ( second ) -import Data.IORef ( IORef, readIORef, writeIORef, modifyIORef ) -import Data.List ( partition, nub ) +import Data.IORef +import Data.List +import Foreign.Ptr -import System.IO ( putStr, putStrLn, hPutStrLn, stderr, fixIO ) -import System.Directory ( doesFileExist ) +import System.IO +import System.Directory -import Control.Exception ( block, throwDyn, bracket ) -import Maybe ( fromJust ) -#ifdef DEBUG -import Maybe ( isJust ) -#endif +import Control.Exception +import Data.Maybe #if __GLASGOW_HASKELL__ >= 503 import GHC.IOBase ( IO(..) ) @@ -114,6 +118,7 @@ data PersistentLinkerState -- Held, as usual, in dependency order; though I am not sure if -- that is really important pkgs_loaded :: [PackageId] + ,dtacons_env :: DataConEnv } emptyPLS :: DynFlags -> PersistentLinkerState @@ -122,7 +127,9 @@ emptyPLS dflags = PersistentLinkerState { itbl_env = emptyNameEnv, pkgs_loaded = init_pkgs, bcos_loaded = [], - objs_loaded = [] } + objs_loaded = [] + , dtacons_env = emptyAddressEnv + } -- Packages that don't need loading, because the compiler -- shares them with the interpreted program. -- @@ -144,6 +151,60 @@ extendLinkEnv new_bindings new_pls = pls { closure_env = new_closure_env } writeIORef v_PersistentLinkerState new_pls + +recoverDataCon :: a -> TcM Name +recoverDataCon a = recoverDCInRTS a `recoverM` ioToTcRn (do + mb_name <- recoverDCInDynEnv a + maybe (fail "Linker.recoverDatacon: Name not found in Dyn Env") + return + mb_name) + +-- | If a is a Constr closure, lookupDC returns either the Name of the DataCon or the +-- symbol if it is a nullary constructor +-- For instance, for a closure containing 'Just x' it would return the Name for Data.Maybe.Just +-- For a closure containing 'Nothing' it would return the String "DataziMaybe_Nothing_static_info" +recoverDCInDynEnv :: a -> IO (Maybe Name) +recoverDCInDynEnv a = do + pls <- readIORef v_PersistentLinkerState + let de = dtacons_env pls + ctype <- getClosureType a + if not (isConstr ctype) + then putStrLn ("Not a Constr (" ++ show ctype ++ ")") >> + return Nothing + else do let infot = getInfoTablePtr a + name = lookupAddressEnv de (castPtr$ infot `plusPtr` (wORD_SIZE*2)) + return name + + +recoverDCInRTS :: a -> TcM Name +recoverDCInRTS a = do + ctype <- ioToTcRn$ getClosureType a + if (not$ isConstr ctype) + then fail "not Constr" + else do + Just symbol <- ioToTcRn$ lookupDataCon (getInfoTablePtr a) + let (occ,mod) = (parse . lex) symbol + lookupOrig mod occ + where lex x = map zDecodeString . init . init . split '_' . removeLeadingUnderscore $ x + parse [pkg, modName, occ] = (mkOccName OccName.dataName occ, + mkModule (stringToPackageId pkg) (mkModuleName modName)) + parse [modName, occ] = (mkOccName OccName.dataName occ, + mkModule mainPackageId (mkModuleName modName)) + split delim = let + helper [] = Nothing + helper x = Just . second (drop 1) . break (==delim) $ x + in unfoldr helper + removeLeadingUnderscore = if cLeadingUnderscore=="YES" + then tail + else id + +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 @@ -179,7 +240,9 @@ showLinkerState printDump (vcat [text "----- Linker state -----", text "Pkgs:" <+> ppr (pkgs_loaded pls), text "Objs:" <+> ppr (objs_loaded pls), - text "BCOs:" <+> ppr (bcos_loaded pls)]) + text "BCOs:" <+> ppr (bcos_loaded pls), + text "DataCons:" <+> ppr (dtacons_env pls) + ]) \end{code} @@ -196,7 +259,6 @@ We initialise the dynamic linker by 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 @@ -225,7 +287,7 @@ reallyInitDynLinker dflags ; 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 @@ -331,6 +393,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 { @@ -360,9 +424,11 @@ linkExpr hsc_env span root_ul_bco pls <- readIORef v_PersistentLinkerState ; let ie = itbl_env pls ce = closure_env pls + de = dtacons_env pls -- Link the necessary packages and linkables - ; (_, (root_hval:_)) <- linkSomeBCOs False ie ce [root_ul_bco] + ; (_,de_out, (root_hval:_)) <- linkSomeBCOs False ie ce de [root_ul_bco] + ; writeIORef v_PersistentLinkerState (pls{dtacons_env=de_out}) ; return root_hval }} where @@ -409,17 +475,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 @@ -430,17 +497,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 @@ -468,8 +561,8 @@ getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods case mb_stuff of Found loc mod -> found loc mod _ -> no_obj mod_name - - found loc mod = do { + where + found loc mod = do { -- ...and then find the linkable for it mb_lnk <- findObjectLinkableMaybe mod loc ; case mb_lnk of { @@ -622,10 +715,11 @@ dynLinkBCOs bcos gce = closure_env pls final_ie = foldr plusNameEnv (itbl_env pls) ies - (final_gce, linked_bcos) <- linkSomeBCOs True final_ie gce ul_bcos + (final_gce, final_de, linked_bcos) <- linkSomeBCOs True final_ie gce (dtacons_env pls) ul_bcos -- What happens to these linked_bcos? let pls2 = pls1 { closure_env = final_gce, + dtacons_env = final_de, itbl_env = final_ie } writeIORef v_PersistentLinkerState pls2 @@ -636,19 +730,18 @@ linkSomeBCOs :: Bool -- False <=> add _all_ BCOs to returned closure env -- True <=> add only toplevel BCOs to closure env -> ItblEnv -> ClosureEnv + -> DataConEnv -> [UnlinkedBCO] - -> IO (ClosureEnv, [HValue]) + -> IO (ClosureEnv, DataConEnv, [HValue]) -- The returned HValues are associated 1-1 with -- the incoming unlinked BCOs. Each gives the -- value of the corresponding unlinked BCO - -linkSomeBCOs toplevs_only ie ce_in ul_bcos +linkSomeBCOs toplevs_only ie ce_in de_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 @@ -657,7 +750,13 @@ linkSomeBCOs toplevs_only ie ce_in ul_bcos -- closure environment, which leads to trouble. ASSERT (all (not . (`elemNameEnv` ce_in)) (map fst ce_additions)) extendClosureEnv ce_in ce_additions - return (ce_out, hvals) + names = concatMap (ssElts . unlinkedBCOItbls) ul_bcos + addresses <- mapM (lookupIE ie) names + let de_additions = [(address, name) | (address, name) <- zip addresses names + , not(address `elemAddressEnv` de_in) + ] + de_out = extendAddressEnvList de_in de_additions + return ( ce_out, de_out, hvals) \end{code}