X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fghci%2FLinker.lhs;h=38d584a633f7cb46a94161c67654573a0f5b8998;hp=f59eecc0b048276224c7973c67f9ec16ebc7dcb7;hb=cdce647711c0f46f5799b24de087622cb77e647f;hpb=0f6f2b865a650cf5f2acb4989d01c1128e22e746 diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index f59eecc..38d584a 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -18,7 +18,7 @@ module Linker ( HValue, getHValue, showLinkerState, linkExpr, unload, extendLinkEnv, withExtendedLinkEnv, extendLoadedPkgs, linkPackages,initDynLinker, - recoverDataCon + dataConInfoPtrToName ) where #include "HsVersions.h" @@ -28,12 +28,10 @@ import ByteCodeLink import ByteCodeItbls import ByteCodeAsm import RtClosureInspect +import CgInfoTbls +import SMRep import IfaceEnv -import Config -import OccName import TcRnMonad -import Constants -import Encoding import Packages import DriverPhases import Finder @@ -41,6 +39,7 @@ import HscTypes import Name import NameEnv import NameSet +import qualified OccName import UniqFM import Module import ListSetOps @@ -55,26 +54,23 @@ import ErrUtils import DriverPhases import SrcLoc import UniqSet +import Constants -- Standard libraries import Control.Monad -import Control.Arrow ( second ) import Data.IORef import Data.List import Foreign.Ptr +import Foreign.C.Types +import Foreign.C.String +import Foreign.Storable import System.IO import System.Directory import Control.Exception import Data.Maybe - -#if __GLASGOW_HASKELL__ >= 503 -import GHC.IOBase ( IO(..) ) -#else -import PrelIOBase ( IO(..) ) -#endif \end{code} @@ -118,7 +114,6 @@ 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 @@ -127,9 +122,8 @@ emptyPLS dflags = PersistentLinkerState { itbl_env = emptyNameEnv, pkgs_loaded = init_pkgs, bcos_loaded = [], - objs_loaded = [] - , dtacons_env = emptyAddressEnv - } + objs_loaded = [] } + -- Packages that don't need loading, because the compiler -- shares them with the interpreted program. -- @@ -151,52 +145,100 @@ 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 -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 + {- 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 @@ -240,9 +282,7 @@ 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 "DataCons:" <+> ppr (dtacons_env pls) - ]) + text "BCOs:" <+> ppr (bcos_loaded pls)]) \end{code} @@ -424,11 +464,9 @@ 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 - ; (_,de_out, (root_hval:_)) <- linkSomeBCOs False ie ce de [root_ul_bco] - ; writeIORef v_PersistentLinkerState (pls{dtacons_env=de_out}) + ; (_, (root_hval:_)) <- linkSomeBCOs False ie ce [root_ul_bco] ; return root_hval }} where @@ -715,11 +753,10 @@ dynLinkBCOs bcos gce = closure_env pls final_ie = foldr plusNameEnv (itbl_env pls) ies - (final_gce, final_de, linked_bcos) <- linkSomeBCOs True final_ie gce (dtacons_env pls) ul_bcos + (final_gce, linked_bcos) <- linkSomeBCOs True final_ie gce 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 @@ -730,14 +767,13 @@ linkSomeBCOs :: Bool -- False <=> add _all_ BCOs to returned closure env -- True <=> add only toplevel BCOs to closure env -> ItblEnv -> ClosureEnv - -> DataConEnv -> [UnlinkedBCO] - -> IO (ClosureEnv, DataConEnv, [HValue]) + -> IO (ClosureEnv, [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 de_in ul_bcos +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) @@ -750,22 +786,8 @@ linkSomeBCOs toplevs_only ie ce_in de_in ul_bcos -- closure environment, which leads to trouble. ASSERT (all (not . (`elemNameEnv` ce_in)) (map fst ce_additions)) extendClosureEnv ce_in ce_additions - refs = goForRefs ul_bcos - names = nub$ concatMap (ssElts . unlinkedBCOItbls) (ul_bcos ++ refs) - 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) - where - goForRefs = getRefs [] - getRefs acc [] = acc - getRefs acc new = getRefs (new++acc) - [bco | BCOPtrBCO bco <- concatMap (ssElts . unlinkedBCOPtrs) new - , notElemBy bco (new ++ acc) nameEq] - ul1 `nameEq` ul2 = unlinkedBCOName ul1 == unlinkedBCOName ul2 - (x1 `notElemBy` x2) eq = null$ intersectBy eq [x1] x2 + return (ce_out, hvals) + \end{code}