module StgInterp (
ClosureEnv, ItblEnv,
-
- linkIModules, -- :: ItblEnv -> ClosureEnv -> [[UnlinkedIBind]] ->
- -- ([LinkedIBind], ItblEnv, ClosureEnv)
-
- runStgI -- tmp, for testing
+ linkIModules,
+ stgToInterpSyn,
) where
{- -----------------------------------------------------------------------------
#include "HsVersions.h"
-#ifdef GHCI
+#if __GLASGOW_HASKELL__ <= 408
+
+import Panic ( panic )
+type ItblEnv = ()
+type ClosureEnv = ()
+linkIModules = panic "StgInterp.linkIModules: this hsc was not built with an interpreter"
+stgToInterpSyn = panic "StgInterp.linkIModules: this hsc was not built with an interpreter"
+
+#else
+
import Linker
import Id ( Id, idPrimRep )
import Outputable
import FastString
import GlaExts ( Int(..) )
import Module ( moduleNameFS )
-#endif
-import TyCon ( TyCon, isDataTyCon, tyConFamilySize, tyConDataCons )
+import TyCon ( TyCon, isDataTyCon, tyConDataCons, tyConFamilySize )
import Class ( Class, classTyCon )
import InterpSyn
import StgSyn
import Addr
import RdrName ( RdrName, rdrNameModule, rdrNameOcc )
-import OccName ( occNameString )
import FiniteMap
import Panic ( panic )
-import PrelAddr
+import OccName ( occNameString )
+
-- ---------------------------------------------------------------------------
-- Environments needed by the linker
-- Run our STG program through the interpreter
-- ---------------------------------------------------------------------------
+#if 0
+-- To be nuked at some point soon.
runStgI :: [TyCon] -> [Class] -> [StgBinding] -> IO Int
-#ifndef GHCI
-runStgI = panic "StgInterp.runStgI: not implemented"
-linkIModules = panic "StgInterp.linkIModules: not implemented"
-#else
-
-- the bindings need to have a binding for stgMain, and the
-- body of it had better represent something of type Int# -> Int#
runStgI tycons classes stgbinds
= do
- let unlinked_binds = concatMap (stg2IBinds emptyUniqSet) stgbinds
+ let unlinked_binds = concatMap (translateBind emptyUniqSet) stgbinds
{-
let dbg_txt
emptyUFM{-initial de-}
)
return result
+#endif
-- ---------------------------------------------------------------------------
-- Convert STG to an unlinked interpretable
-- ---------------------------------------------------------------------------
-stg2IBinds :: UniqSet Id -> StgBinding -> [UnlinkedIBind]
-stg2IBinds ie (StgNonRec v e) = [IBind v (rhs2expr ie e)]
-stg2IBinds ie (StgRec vs_n_es) = [IBind v (rhs2expr ie' e) | (v,e) <- vs_n_es]
+-- visible from outside
+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 <- mkITbls tycs
+ return (ibinds, itblenv)
+
+
+translateBind :: UniqSet Id -> StgBinding -> [UnlinkedIBind]
+translateBind ie (StgNonRec v e) = [IBind v (rhs2expr ie e)]
+translateBind ie (StgRec vs_n_es) = [IBind v (rhs2expr ie' e) | (v,e) <- vs_n_es]
where ie' = addListToUniqSet ie (map fst vs_n_es)
isRec (StgNonRec _ _) = False
StgLet binds@(StgNonRec v e) body
-> mkNonRec (repOfStgExpr stgexpr)
- (head (stg2IBinds ie binds))
+ (head (translateBind ie binds))
(stg2expr (addOneToUniqSet ie v) body)
StgLet binds@(StgRec bs) body
-> mkRec (repOfStgExpr stgexpr)
- (stg2IBinds ie binds)
+ (translateBind ie binds)
(stg2expr (addListToUniqSet ie (map fst bs)) body)
other
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 gce gie 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
+ ---vvvvvvvvv---------------------------------------^^^^^^^^^-- circular
+ new_binds = linkIBinds final_gie new_gce binds
+
+ return (new_binds, final_gie, new_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
-- 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)
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
--- 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
foreign import "strncpy" strncpy :: Addr -> ByteArray# -> CInt -> IO ()
-#endif /* ndef GHCI */
+#endif /* #if __GLASGOW_HASKELL__ <= 408 */
\end{code}
projects / ghc-hetmet.git / blobdiff