Commit b125ffe2 authored by sewardj's avatar sewardj
Browse files

[project @ 2000-10-25 12:47:43 by sewardj]

Sort out linking of interpreted code a bit.
parent 49db9fd3
......@@ -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
......
......@@ -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 -------------------------------
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment