%
-% (c) The University of Glasgow 2000
+% (c) The University of Glasgow 2000-2006
%
-\section[ByteCodeLink]{Bytecode assembler and linker}
+ByteCodeLink: Bytecode assembler and linker
\begin{code}
-
+{-# LANGUAGE BangPatterns #-}
{-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
module ByteCodeLink (
HValue,
ClosureEnv, emptyClosureEnv, extendClosureEnv,
- linkBCO, lookupStaticPtr
+ linkBCO, lookupStaticPtr, lookupName
+ ,lookupIE
) where
#include "HsVersions.h"
-import ByteCodeItbls ( ItblEnv, ItblPtr )
-import ByteCodeAsm ( UnlinkedBCO(..), BCOPtr(..), sizeSS, ssElts )
-import ObjLink ( lookupSymbol )
+import ByteCodeItbls
+import ByteCodeAsm
+import ObjLink
-import Name ( Name, nameModule, nameOccName, isExternalName )
+import Name
import NameEnv
-import OccName ( occNameFS )
-import PrimOp ( PrimOp, primOpOcc )
-import Module ( moduleFS )
-import FastString ( FastString(..), unpackFS, zEncodeFS )
+import OccName
+import PrimOp
+import Module
+import PackageConfig
+import FastString
+import Panic
import Outputable
-import Panic ( GhcException(..) )
-- Standard libraries
import GHC.Word ( Word(..) )
-import Data.Array.IArray ( listArray )
import Data.Array.Base
import GHC.Arr ( STArray(..) )
-import Control.Exception ( throwDyn )
import Control.Monad ( zipWithM )
import Control.Monad.ST ( stToIO )
-import GHC.Exts ( BCO#, newBCO#, unsafeCoerce#, Int#,
- ByteArray#, Array#, addrToHValue#, mkApUpd0# )
-
+import GHC.Exts
import GHC.Arr ( Array(..) )
import GHC.IOBase ( IO(..) )
-import GHC.Ptr ( Ptr(..) )
-import GHC.Base ( writeArray#, RealWorld, Int(..) )
+import GHC.Ptr ( Ptr(..), castPtr )
+import GHC.Base ( writeArray#, RealWorld, Int(..), Word# )
+
+import Data.Word
\end{code}
\begin{code}
type ClosureEnv = NameEnv (Name, HValue)
-newtype HValue = HValue (forall a . a)
+newtype HValue = HValue Any
emptyClosureEnv = emptyNameEnv
linkBCO' :: ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO BCO
-linkBCO' ie ce (UnlinkedBCO nm arity insns_barr bitmap literalsSS ptrsSS itblsSS)
+linkBCO' ie ce (UnlinkedBCO nm arity insns_barr bitmap literalsSS ptrsSS)
-- Raises an IO exception on failure
= do let literals = ssElts literalsSS
ptrs = ssElts ptrsSS
- itbls = ssElts itblsSS
- linked_itbls <- mapM (lookupIE ie) itbls
- linked_literals <- mapM lookupLiteral literals
+ linked_literals <- mapM (lookupLiteral ie) literals
let n_literals = sizeSS literalsSS
n_ptrs = sizeSS ptrsSS
- n_itbls = sizeSS itblsSS
- ptrs_arr <- mkPtrsArray ie ce n_ptrs ptrs
+ ptrs_arr <- if n_ptrs > 65535
+ then panic "linkBCO: >= 64k ptrs"
+ else mkPtrsArray ie ce (fromIntegral n_ptrs) ptrs
let
- ptrs_parr = case ptrs_arr of Array lo hi parr -> parr
-
- itbls_arr = listArray (0, n_itbls-1) linked_itbls
- :: UArray Int ItblPtr
- itbls_barr = case itbls_arr of UArray lo hi barr -> barr
+ !ptrs_parr = case ptrs_arr of Array _lo _hi _n parr -> parr
- literals_arr = listArray (0, n_literals-1) linked_literals
- :: UArray Int Word
- literals_barr = case literals_arr of UArray lo hi barr -> barr
+ litRange
+ | n_literals > 65535 = panic "linkBCO: >= 64k literals"
+ | n_literals > 0 = (0, fromIntegral n_literals - 1)
+ | otherwise = (1, 0)
+ literals_arr :: UArray Word16 Word
+ literals_arr = listArray litRange linked_literals
+ !literals_barr = case literals_arr of UArray _lo _hi _n barr -> barr
- (I# arity#) = arity
+ !(I# arity#) = arity
- newBCO insns_barr literals_barr ptrs_parr itbls_barr arity# bitmap
+ newBCO insns_barr literals_barr ptrs_parr arity# bitmap
-- we recursively link any sub-BCOs while making the ptrs array
-mkPtrsArray :: ItblEnv -> ClosureEnv -> Int -> [BCOPtr] -> IO (Array Int HValue)
+mkPtrsArray :: ItblEnv -> ClosureEnv -> Word16 -> [BCOPtr] -> IO (Array Word16 HValue)
mkPtrsArray ie ce n_ptrs ptrs = do
- marr <- newArray_ (0, n_ptrs-1)
+ let ptrRange = if n_ptrs > 0 then (0, n_ptrs-1) else (1, 0)
+ marr <- newArray_ ptrRange
let
fill (BCOPtrName n) i = do
ptr <- lookupName ce n
fill (BCOPtrBCO ul_bco) i = do
BCO bco# <- linkBCO' ie ce ul_bco
writeArrayBCO marr i bco#
+ fill (BCOPtrBreakInfo brkInfo) i =
+ unsafeWrite marr i (unsafeCoerce# brkInfo)
+ fill (BCOPtrArray brkArray) i =
+ unsafeWrite marr i (unsafeCoerce# brkArray)
zipWithM fill ptrs [0..]
unsafeFreeze marr
newtype IOArray i e = IOArray (STArray RealWorld i e)
-instance HasBounds IOArray where
- bounds (IOArray marr) = bounds marr
-
instance MArray IOArray e IO where
+ getBounds (IOArray marr) = stToIO $ getBounds marr
+ getNumElements (IOArray marr) = stToIO $ getNumElements marr
newArray lu init = stToIO $ do
marr <- newArray lu init; return (IOArray marr)
newArray_ lu = stToIO $ do
unsafeWrite (IOArray marr) i e = stToIO (unsafeWrite marr i e)
-- XXX HACK: we should really have a new writeArray# primop that takes a BCO#.
-writeArrayBCO :: IOArray Int a -> Int -> BCO# -> IO ()
-writeArrayBCO (IOArray (STArray _ _ marr#)) (I# i#) bco# = IO $ \s# ->
+writeArrayBCO :: IOArray Word16 a -> Int -> BCO# -> IO ()
+writeArrayBCO (IOArray (STArray _ _ _ marr#)) (I# i#) bco# = IO $ \s# ->
case (unsafeCoerce# writeArray#) marr# i# bco# s# of { s# ->
(# s#, () #) }
+{-
+writeArrayMBA :: IOArray Int a -> Int -> MutableByteArray# a -> IO ()
+writeArrayMBA (IOArray (STArray _ _ marr#)) (I# i#) mba# = IO $ \s# ->
+ case (unsafeCoerce# writeArray#) marr# i# bco# s# of { s# ->
+ (# s#, () #) }
+-}
+
data BCO = BCO BCO#
-newBCO :: ByteArray# -> ByteArray# -> Array# a
- -> ByteArray# -> Int# -> ByteArray# -> IO BCO
-newBCO instrs lits ptrs itbls arity bitmap
- = IO $ \s -> case newBCO# instrs lits ptrs itbls arity bitmap s of
+newBCO :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> IO BCO
+newBCO instrs lits ptrs arity bitmap
+ = IO $ \s -> case newBCO# instrs lits ptrs arity bitmap s of
(# s1, bco #) -> (# s1, BCO bco #)
-lookupLiteral :: Either Word FastString -> IO Word
-lookupLiteral (Left lit) = return lit
-lookupLiteral (Right sym) = do Ptr addr <- lookupStaticPtr sym
- return (W# (unsafeCoerce# addr))
- -- Can't be bothered to find the official way to convert Addr# to Word#;
- -- the FFI/Foreign designers make it too damn difficult
- -- Hence we apply the Blunt Instrument, which works correctly
- -- on all reasonable architectures anyway
+lookupLiteral :: ItblEnv -> BCONPtr -> IO Word
+lookupLiteral ie (BCONPtrWord lit) = return lit
+lookupLiteral ie (BCONPtrLbl sym) = do Ptr a# <- lookupStaticPtr sym
+ return (W# (int2Word# (addr2Int# a#)))
+lookupLiteral ie (BCONPtrItbl nm) = do Ptr a# <- lookupIE ie nm
+ return (W# (int2Word# (addr2Int# a#)))
lookupStaticPtr :: FastString -> IO (Ptr ())
lookupStaticPtr addr_of_label_string
lookupIE :: ItblEnv -> Name -> IO (Ptr a)
lookupIE ie con_nm
= case lookupNameEnv ie con_nm of
- Just (_, Ptr a) -> return (Ptr a)
+ Just (_, a) -> return (castPtr (itblCode a))
Nothing
-> do -- try looking up in the object files.
let sym_to_find1 = nameToCLabel con_nm "con_info"
linkFail :: String -> String -> IO a
linkFail who what
- = throwDyn (ProgramError $
+ = ghcError (ProgramError $
unlines [ ""
, "During interactive linking, GHCi couldn't find the following symbol:"
, ' ' : ' ' : what
-- HACKS!!! ToDo: cleaner
nameToCLabel :: Name -> String{-suffix-} -> String
nameToCLabel n suffix
- = unpackFS (zEncodeFS (moduleFS (nameModule n)))
- ++ '_': unpackFS (zEncodeFS (occNameFS (nameOccName n))) ++ '_':suffix
+ = if pkgid /= mainPackageId
+ then package_part ++ '_': qual_name
+ else qual_name
+ where
+ pkgid = modulePackageId mod
+ mod = ASSERT( isExternalName n ) nameModule n
+ package_part = unpackFS (zEncodeFS (packageIdFS (modulePackageId mod)))
+ module_part = unpackFS (zEncodeFS (moduleNameFS (moduleName mod)))
+ occ_part = unpackFS (zEncodeFS (occNameFS (nameOccName n)))
+ qual_name = module_part ++ '_':occ_part ++ '_':suffix
+
primopToCLabel :: PrimOp -> String{-suffix-} -> String
primopToCLabel primop suffix
- = let str = "GHCziPrimopWrappers_" ++ unpackFS (zEncodeFS (occNameFS (primOpOcc primop))) ++ '_':suffix
+ = let str = "ghczmprim_GHCziPrimopWrappers_" ++ unpackFS (zEncodeFS (occNameFS (primOpOcc primop))) ++ '_':suffix
in --trace ("primopToCLabel: " ++ str)
str
\end{code}
projects / ghc-hetmet.git / blobdiff