[project @ 2001-02-09 13:09:16 by simonmar]

[ghc-hetmet.git] / ghc / compiler / ghci / ByteCodeLink.lhs

diff --git a/ghc/compiler/ghci/ByteCodeLink.lhs b/ghc/compiler/ghci/ByteCodeLink.lhs
index 8942a4c..dce5253 100644 (file)
--- a/ghc/compiler/ghci/ByteCodeLink.lhs
+++ b/ghc/compiler/ghci/ByteCodeLink.lhs
@@ -5,13 +5,14 @@
 
 \begin{code}
 module ByteCodeLink ( UnlinkedBCO, UnlinkedBCOExpr, assembleBCO,
-                     ClosureEnv, HValue, linkSomeBCOs, filterNameMap
+                     ClosureEnv, HValue, linkSomeBCOs, filterNameMap,
+                     iNTERP_STACK_CHECK_THRESH
                   ) where
 
 #include "HsVersions.h"
 
 import Outputable
-import Name            ( Name, getName, nameModule, toRdrName )
+import Name            ( Name, getName, nameModule, toRdrName, isGlobalName )
 import RdrName         ( rdrNameOcc, rdrNameModule )
 import OccName         ( occNameString )
 import FiniteMap       ( FiniteMap, addListToFM, filterFM,
@@ -57,14 +58,23 @@ import PrelIOBase   ( IO(..) )
 \begin{code}
 
 -- Link a bunch of BCOs and return them + updated closure env.
-linkSomeBCOs :: ItblEnv -> ClosureEnv -> [UnlinkedBCO]
-                -> IO (ClosureEnv, [HValue])
-linkSomeBCOs ie ce_in ul_bcos
+linkSomeBCOs :: Bool   -- False <=> add _all_ BCOs to returned closure env
+                        -- True  <=> add only toplevel BCOs to closure env
+             -> ItblEnv 
+             -> ClosureEnv 
+             -> [UnlinkedBCO]
+             -> IO (ClosureEnv, [HValue])
+linkSomeBCOs toplevs_only ie ce_in ul_bcos
    = do let nms = map nameOfUnlinkedBCO ul_bcos
         hvals <- fixIO 
                     ( \ hvs -> let ce_out = addListToFM ce_in (zipLazily nms hvs)
                                in  mapM (linkBCO ie ce_out) ul_bcos )
-        let ce_out = addListToFM ce_in (zip nms hvals)
+
+        let ce_all_additions = zip nms hvals
+            ce_top_additions = filter (isGlobalName.fst) ce_all_additions
+            ce_additions     = if toplevs_only then ce_top_additions 
+                                               else ce_all_additions
+            ce_out = addListToFM ce_in ce_additions
         return (ce_out, hvals)
      where
         -- A lazier zip, in which no demand is propagated to the second
@@ -103,8 +113,7 @@ data HValue     = HValue  -- dummy type, actually a pointer to some Real Code.
 -- remove all entries for a given set of modules from the environment
 filterNameMap :: [ModuleName] -> FiniteMap Name a -> FiniteMap Name a
 filterNameMap mods env 
-   = filterFM (\n _ -> moduleName (nameModule n) `notElem` mods) env
-
+   = filterFM (\n _ -> moduleName (nameModule n) `elem` mods) env
 \end{code}
 
 %************************************************************************
@@ -179,6 +188,7 @@ mkBits findLabel st proto_insns
        doInstr st i
           = case i of
                ARGCHECK  n        -> instr2 st i_ARGCHECK n
+               STKCHECK  n        -> instr2 st i_STKCHECK n
                PUSH_L    o1       -> instr2 st i_PUSH_L o1
                PUSH_LL   o1 o2    -> instr3 st i_PUSH_LL o1 o2
                PUSH_LLL  o1 o2 o3 -> instr4 st i_PUSH_LLL o1 o2 o3
@@ -311,6 +321,7 @@ foreign label "stg_gc_d1_info"      stg_gc_d1_info :: Addr
 instrSize16s :: BCInstr -> Int
 instrSize16s instr
    = case instr of
+        STKCHECK _     -> 2
         ARGCHECK _     -> 2
         PUSH_L   _     -> 2
         PUSH_LL  _ _   -> 3
@@ -544,5 +555,8 @@ i_TESTEQ_P = (bci_TESTEQ_P :: Int)
 i_CASEFAIL = (bci_CASEFAIL :: Int)
 i_ENTER    = (bci_ENTER :: Int)
 i_RETURN   = (bci_RETURN :: Int)
+i_STKCHECK = (bci_STKCHECK :: Int)
+
+iNTERP_STACK_CHECK_THRESH = (INTERP_STACK_CHECK_THRESH :: Int)
 
 \end{code}