\begin{code}
module ByteCodeLink ( UnlinkedBCO, UnlinkedBCOExpr, assembleBCO,
- ClosureEnv, HValue, linkSomeBCOs, filterNameMap
+ ClosureEnv, HValue, filterNameMap,
+ linkIModules, linkIExpr,
+ 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 )
newIntArray, writeIntArray,
newAddrArray, writeAddrArray )
import Foreign ( Word16, Ptr(..) )
-import Addr ( Word, Addr )
+import Addr ( Word, Addr, nullAddr )
+import FiniteMap
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}
+-- Linking stuff
+linkIModules :: ItblEnv -- incoming global itbl env; returned updated
+ -> ClosureEnv -- incoming global closure env; returned updated
+ -> [([UnlinkedBCO], ItblEnv)]
+ -> IO ([HValue], ItblEnv, ClosureEnv)
+linkIModules gie gce mods
+ = do let (bcoss, ies) = unzip mods
+ bcos = concat bcoss
+ final_gie = foldr plusFM gie ies
+ (final_gce, linked_bcos) <- linkSomeBCOs True final_gie gce bcos
+ return (linked_bcos, final_gie, final_gce)
+
+
+linkIExpr :: ItblEnv -> ClosureEnv -> UnlinkedBCOExpr
+ -> IO HValue -- IO BCO# really
+linkIExpr ie ce (root_ul_bco, aux_ul_bcos)
+ = do (aux_ce, _) <- linkSomeBCOs False ie ce aux_ul_bcos
+ (_, [root_bco]) <- linkSomeBCOs False ie aux_ce [root_ul_bco]
+ return root_bco
-- 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 = -- make sure we're not inserting duplicate names into the
+ -- closure environment, which leads to trouble.
+ ASSERT (all (not . (`elemFM` ce_in)) (map fst ce_additions))
+ addListToFM ce_in ce_additions
return (ce_out, hvals)
where
-- A lazier zip, in which no demand is propagated to the second
type ClosureEnv = FiniteMap Name HValue
data HValue = HValue -- dummy type, actually a pointer to some Real Code.
--- remove all entries for a given set of modules from the environment
+-- remove all entries for a given set of modules from the environment;
+-- note that this removes all local names too (ie. temporary bindings from
+-- the command line).
filterNameMap :: [ModuleName] -> FiniteMap Name a -> FiniteMap Name a
filterNameMap mods env
- = filterFM (\n _ -> moduleName (nameModule n) `notElem` mods) env
-
+ = filterFM (\n _ -> isGlobalName n &&
+ moduleName (nameModule n) `elem` mods) env
\end{code}
%************************************************************************
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
TESTLT_P i l -> instr3 st i_TESTLT_P i (findLabel l)
TESTEQ_P i l -> instr3 st i_TESTEQ_P i (findLabel l)
CASEFAIL -> instr1 st i_CASEFAIL
+ JMP l -> instr2 st i_JMP (findLabel l)
ENTER -> instr1 st i_ENTER
RETURN rep -> do (itbl_no,st2) <- itoc_itbl st rep
instr2 st2 i_RETURN itbl_no
CharRep -> stg_ctoi_ret_R1n_info
FloatRep -> stg_ctoi_ret_F1_info
DoubleRep -> stg_ctoi_ret_D1_info
+ VoidRep -> stg_ctoi_ret_V_info
_ -> pprPanic "mkBits.ctoi_itbl" (ppr pk)
itoc_itbl st pk
IntRep -> stg_gc_unbx_r1_info
FloatRep -> stg_gc_f1_info
DoubleRep -> stg_gc_d1_info
+ VoidRep -> nullAddr
+ -- Interpreter.c spots this special case
foreign label "stg_ctoi_ret_R1p_info" stg_ctoi_ret_R1p_info :: Addr
foreign label "stg_ctoi_ret_R1n_info" stg_ctoi_ret_R1n_info :: Addr
foreign label "stg_ctoi_ret_F1_info" stg_ctoi_ret_F1_info :: Addr
foreign label "stg_ctoi_ret_D1_info" stg_ctoi_ret_D1_info :: Addr
+foreign label "stg_ctoi_ret_V_info" stg_ctoi_ret_V_info :: Addr
foreign label "stg_gc_unbx_r1_info" stg_gc_unbx_r1_info :: Addr
foreign label "stg_gc_f1_info" stg_gc_f1_info :: Addr
instrSize16s :: BCInstr -> Int
instrSize16s instr
= case instr of
+ STKCHECK _ -> 2
ARGCHECK _ -> 2
PUSH_L _ -> 2
PUSH_LL _ _ -> 3
TESTEQ_D _ _ -> 3
TESTLT_P _ _ -> 3
TESTEQ_P _ _ -> 3
+ JMP _ -> 2
CASEFAIL -> 1
ENTER -> 1
RETURN _ -> 2
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)
+i_JMP = (bci_JMP :: Int)
+
+iNTERP_STACK_CHECK_THRESH = (INTERP_STACK_CHECK_THRESH :: Int)
\end{code}
projects / ghc-hetmet.git / blobdiff