\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 )
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(..) )
\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
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
instrSize16s :: BCInstr -> Int
instrSize16s instr
= case instr of
+ STKCHECK _ -> 2
ARGCHECK _ -> 2
PUSH_L _ -> 2
PUSH_LL _ _ -> 3
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
= 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
-> 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)
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}