[project @ 2001-02-06 12:00:17 by sewardj]

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

diff --git a/ghc/compiler/ghci/ByteCodeLink.lhs b/ghc/compiler/ghci/ByteCodeLink.lhs
index 0bb6906..39e36fb 100644 (file)
--- a/ghc/compiler/ghci/ByteCodeLink.lhs
+++ b/ghc/compiler/ghci/ByteCodeLink.lhs
@@ -5,22 +5,22 @@
 
 \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, occNameUserString )
+import OccName         ( occNameString )
 import FiniteMap       ( FiniteMap, addListToFM, filterFM,
                          addToFM, lookupFM, emptyFM )
 import CoreSyn
 import Literal         ( Literal(..) )
 import PrimOp          ( PrimOp, primOpOcc )
 import PrimRep         ( PrimRep(..) )
-import Util            ( global )
 import Constants       ( wORD_SIZE )
 import Module          ( ModuleName, moduleName, moduleNameFS )
 import Linker          ( lookupSymbol )
@@ -42,7 +42,7 @@ import Addr           ( Word, Addr )
 import PrelBase                ( Int(..) )
 import PrelGHC         ( BCO#, newBCO#, unsafeCoerce#, 
                          ByteArray#, Array#, addrToHValue#, mkApUpd0# )
-import IOExts          ( IORef, fixIO, readIORef, writeIORef )
+import IOExts          ( fixIO )
 import ArrayBase       
 import PrelArr         ( Array(..) )
 import PrelIOBase      ( IO(..) )
@@ -58,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
@@ -180,6 +189,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
@@ -271,6 +281,7 @@ mkBits findLabel st proto_insns
           = do st_I1 <- addToSS st_I0 (getName dcon)
                return (sizeSS st_I0, (st_i0,st_l0,st_p0,st_I1))
 
+       literal st (MachWord w)   = int st (fromIntegral w)
        literal st (MachInt j)    = int st (fromIntegral j)
        literal st (MachFloat r)  = float st (fromRational r)
        literal st (MachDouble r) = double st (fromRational r)
@@ -281,6 +292,7 @@ mkBits findLabel st proto_insns
             where
                ret_itbl_addr = case pk of
                                   PtrRep    -> stg_ctoi_ret_R1p_info
+                                  WordRep   -> stg_ctoi_ret_R1n_info
                                   IntRep    -> stg_ctoi_ret_R1n_info
                                   AddrRep   -> stg_ctoi_ret_R1n_info
                                   CharRep   -> stg_ctoi_ret_R1n_info
@@ -310,6 +322,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
@@ -409,14 +422,6 @@ data BCO# = BCO# ByteArray#                -- instrs   :: array Word16#
                  ByteArray#            -- itbls    :: Array Addr#
 -}
 
-GLOBAL_VAR(v_cafTable, [], [HValue])
-
-addCAF :: HValue -> IO ()
-addCAF x = do xs <- readIORef v_cafTable
-              --putStrLn ("addCAF " ++ show (1 + length xs))
-              writeIORef v_cafTable (x:xs)
-
-
 linkBCO ie ce (UnlinkedBCO nm insnsSS literalsSS ptrsSS itblsSS)
    = do insns    <- listFromSS insnsSS
         literals <- listFromSS literalsSS
@@ -473,8 +478,7 @@ lookupCE ce (Right primop)
    = do m <- lookupSymbol (primopToCLabel primop "closure")
         case m of
            Just (Ptr addr) -> case addrToHValue# addr of
-                                 (# hval #) -> do addCAF hval
-                                                  return hval
+                                 (# hval #) -> return hval
            Nothing -> pprPanic "ByteCodeGen.lookupCE(primop)" (ppr primop)
 lookupCE ce (Left nm)
    = case lookupFM ce nm of
@@ -483,8 +487,7 @@ lookupCE ce (Left nm)
            -> do m <- lookupSymbol (nameToCLabel nm "closure")
                  case m of
                     Just (Ptr addr) -> case addrToHValue# addr of
-                                          (# hval #) -> do addCAF hval
-                                                           return hval
+                                          (# hval #) -> return hval
                     Nothing        -> pprPanic "ByteCodeGen.lookupCE" (ppr nm)
 
 lookupIE :: ItblEnv -> Name -> IO (Ptr a)
@@ -553,5 +556,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}