From b125ffe2eff1a31ab7b53e1dc2355fe6115838d9 Mon Sep 17 00:00:00 2001 From: sewardj Date: Wed, 25 Oct 2000 12:47:43 +0000 Subject: [PATCH] [project @ 2000-10-25 12:47:43 by sewardj] Sort out linking of interpreted code a bit. --- ghc/compiler/ghci/CmLink.lhs | 11 +++- ghc/compiler/main/HscMain.lhs | 5 +- ghc/compiler/stgSyn/StgInterp.lhs | 100 +++++++++++++++++++------------------ 3 files changed, 64 insertions(+), 52 deletions(-) diff --git a/ghc/compiler/ghci/CmLink.lhs b/ghc/compiler/ghci/CmLink.lhs index df308e5..953f3be 100644 --- a/ghc/compiler/ghci/CmLink.lhs +++ b/ghc/compiler/ghci/CmLink.lhs @@ -30,8 +30,16 @@ import Panic ( panic ) \begin{code} data PersistentLinkerState = PersistentLinkerState { + -- Current global mapping from RdrNames to closure addresses closure_env :: ClosureEnv, + + -- the current global mapping from RdrNames of DataCons to + -- info table addresses. + -- When a new Unlinked is linked into the running image, or an existing + -- module in the image is replaced, the itbl_env must be updated + -- appropriately. itbl_env :: ItblEnv + -- notionally here, but really lives in the C part of the linker: -- object_symtab :: FiniteMap String Addr } @@ -44,7 +52,8 @@ data Unlinked = DotO FilePath | DotA FilePath | DotDLL FilePath - | Trees [UnlinkedIBind] -- bunch of interpretable bindings + | Trees [UnlinkedIBind] ItblEnv -- bunch of interpretable bindings, + + -- a mapping from DataCons to their itbls instance Outputable Unlinked where ppr (DotO path) = text "DotO" <+> text path diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 0be91c5..eebf4bd 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -59,7 +59,7 @@ data HscResult (Maybe ModIface) -- new iface (if any compilation was done) (Maybe String) -- generated stub_h filename (in /tmp) (Maybe String) -- generated stub_c filename (in /tmp) - (Maybe [UnlinkedIBind]) -- interpreted code, if any + (Maybe ([UnlinkedIBind],ItblEnv)) -- interpreted code, if any PersistentCompilerState -- updated PCS | HscFail PersistentCompilerState -- updated PCS @@ -151,6 +151,7 @@ hscRecomp dflags core_cmds stg_cmds summary hit hst pcs maybe_old_iface maybe_ibinds pcs_tc) }}}}}}} + myParseModule dflags summary = do -------------------------- Reader ---------------- show_pass "Parser" @@ -185,7 +186,7 @@ myParseModule dflags summary restOfCodeGeneration toInterp this_mod imported_modules cost_centre_info fe_binders local_tycons local_classes stg_binds | toInterp - = return (Nothing, Nothing, stgToIBinds stg_binds local_tycons local_classes) + = return (Nothing, Nothing, stgToInterpSyn stg_binds local_tycons local_classes) | otherwise = do -------------------------- Code generation ------------------------------- diff --git a/ghc/compiler/stgSyn/StgInterp.lhs b/ghc/compiler/stgSyn/StgInterp.lhs index fecb54b..8ab3c3a 100644 --- a/ghc/compiler/stgSyn/StgInterp.lhs +++ b/ghc/compiler/stgSyn/StgInterp.lhs @@ -7,12 +7,8 @@ module StgInterp ( ClosureEnv, ItblEnv, - - linkIModules, -- :: ItblEnv -> ClosureEnv -> [[UnlinkedIBind]] -> - -- ([LinkedIBind], ItblEnv, ClosureEnv) - - stgToIBinds, -- :: [StgBinding] -> [UnlinkedIBind] - + linkIModules, + stgToInterpSyn, runStgI -- tmp, for testing ) where @@ -138,8 +134,15 @@ runStgI tycons classes stgbinds -- --------------------------------------------------------------------------- -- visible from outside -stgToIBinds :: [StgBinding] -> [UnlinkedIBind] -stgToIBinds = concatMap (translateBind emptyUniqSet) +stgToInterpSyn :: [StgBinding] + -> [TyCon] -> [Class] + -> IO ([UnlinkedIBind], ItblEnv) +stgToInterpSyn binds local_tycons local_classes + = do let ibinds = concatMap (translateBind emptyUniqSet) binds + let tycs = local_tycons ++ map classTyCon local_classes + itblenv <- makeItbls tycs + return (ibinds, itblenv) + translateBind :: UniqSet Id -> StgBinding -> [UnlinkedIBind] translateBind ie (StgNonRec v e) = [IBind v (rhs2expr ie e)] @@ -409,25 +412,29 @@ repOfArg (StgTypeArg ty) = pprPanic "repOfArg" (ppr ty) id2VaaRep var = (var, repOfId var) + -- --------------------------------------------------------------------------- --- Link an interpretable into something we can run +-- Link interpretables into something we can run -- --------------------------------------------------------------------------- -linkIModules :: ItblEnv -> ClosureEnv -> [([TyCon],[UnlinkedIBind])] -> - IO ([LinkedIBind], ItblEnv, ClosureEnv) -linkIModules ie ce mods = do - let (tyconss, bindss) = unzip mods - tycons = concat tyconss +linkIModules :: ClosureEnv -- incoming global closure env; returned updated + -> ItblEnv -- incoming global itbl env; returned updated + -> [([UnlinkedIBind], ItblEnv)] + -> IO ([LinkedIBind], ItblEnv, ClosureEnv) +linkIModules gie gce mods = do + let (bindss, ies) = unzip mods binds = concat bindss top_level_binders = map (toRdrName.binder) binds - - new_ie <- mkITbls (concat tyconss) - let new_ce = addListToFM ce (zip top_level_binders new_rhss) + final_gie = foldr plusFM gie ies + + let {-rec-} + new_gce = addListToFM gce (zip top_level_binders new_rhss) new_rhss = map (\b -> evalP (bindee b) emptyUFM) new_binds ---vvvvvvvvv---------------------------------------^^^^^^^^^-- circular - (new_binds, final_ie, final_ce) = linkIBinds new_ie new_ce binds + (new_binds, final_gce) = linkIBinds final_gie new_gce binds + + return (new_binds, final_gie, final_gce) - return (new_binds, final_ie, final_ce) -- We're supposed to augment the environments with the values of any -- external functions/info tables we need as we go along, but that's a @@ -435,35 +442,11 @@ linkIModules ie ce mods = do -- up and not cache them in the source symbol tables. The interpreted -- code will still be referenced in the source symbol tables. +-- JRS 001025: above comment is probably out of date ... interpret +-- with care. --- Make info tables for the data decls in this module -mkITbls :: [TyCon] -> IO ItblEnv -mkITbls [] = return emptyFM -mkITbls (tc:tcs) = do itbls <- mkITbl tc - itbls2 <- mkITbls tcs - return (itbls `plusFM` itbls2) - -mkITbl :: TyCon -> IO ItblEnv -mkITbl tc --- | trace ("TYCON: " ++ showSDoc (ppr tc)) False --- = error "?!?!" - | not (isDataTyCon tc) - = return emptyFM - | n == length dcs -- paranoia; this is an assertion. - = make_constr_itbls dcs - where - dcs = tyConDataCons tc - n = tyConFamilySize tc - - -linkIBinds :: ItblEnv -> ClosureEnv -> [UnlinkedIBind] -> - ([LinkedIBind], ItblEnv, ClosureEnv) -linkIBinds ie ce binds - = (new_binds, ie, ce) - where new_binds = map (linkIBind ie ce) binds - -linkIBinds' ie ce binds - = new_binds where (new_binds, ie, ce) = linkIBinds ie ce binds +linkIBinds :: ItblEnv -> ClosureEnv -> [UnlinkedIBind] -> [LinkedIBind] +linkIBinds ie ce binds = map (linkIBind ie ce) binds linkIBind ie ce (IBind bndr expr) = IBind bndr (linkIExpr ie ce expr) @@ -505,10 +488,10 @@ linkIExpr ie ce expr = case expr of PrimOpP op args -> PrimOpP op (map (linkIExpr ie ce) args) NonRecP bind expr -> NonRecP (linkIBind ie ce bind) (linkIExpr ie ce expr) - RecP binds expr -> RecP (linkIBinds' ie ce binds) (linkIExpr ie ce expr) + RecP binds expr -> RecP (linkIBinds ie ce binds) (linkIExpr ie ce expr) NonRecI bind expr -> NonRecI (linkIBind ie ce bind) (linkIExpr ie ce expr) - RecI binds expr -> RecI (linkIBinds' ie ce binds) (linkIExpr ie ce expr) + RecI binds expr -> RecI (linkIBinds ie ce binds) (linkIExpr ie ce expr) LitI i -> LitI i LitF i -> LitF i @@ -1064,6 +1047,25 @@ indexIntOffClosure con (I# offset) --- Manufacturing of info tables for DataCons defined in this module --- ------------------------------------------------------------------------ +-- Make info tables for the data decls in this module +mkITbls :: [TyCon] -> IO ItblEnv +mkITbls [] = return emptyFM +mkITbls (tc:tcs) = do itbls <- mkITbl tc + itbls2 <- mkITbls tcs + return (itbls `plusFM` itbls2) + +mkITbl :: TyCon -> IO ItblEnv +mkITbl tc +-- | trace ("TYCON: " ++ showSDoc (ppr tc)) False +-- = error "?!?!" + | not (isDataTyCon tc) + = return emptyFM + | n == length dcs -- paranoia; this is an assertion. + = make_constr_itbls dcs + where + dcs = tyConDataCons tc + n = tyConFamilySize tc + cONSTR :: Int cONSTR = 1 -- as defined in ghc/includes/ClosureTypes.h -- 1.7.10.4