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

Sort out linking of interpreted code a bit.

3 files changed, 64 insertions, 52 deletions

diff --git a/ghc/compiler/ghci/CmLink.lhs b/ghc/compiler/ghci/CmLink.lhs
index df308e5370..953f3bea60 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 0be91c5607..eebf4bd3a8 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 fecb54bc4c..8ab3c3a524 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