import Literal ( Literal(..) )
import TyCon ( TyCon )
import PrimOp ( PrimOp )
-import PrimRep ( PrimRep(..), isFollowableRep, is64BitRep )
import Constants ( wORD_SIZE )
-import FastString ( FastString(..), unpackFS )
+import FastString ( FastString(..) )
+import SMRep ( CgRep(..), StgWord )
import FiniteMap
import Outputable
-import Control.Monad ( foldM, zipWithM )
-import Control.Monad.ST ( ST, runST )
+import Control.Monad ( foldM )
+import Control.Monad.ST ( runST )
import GHC.Word ( Word(..) )
import Data.Array.MArray
-import Data.Array.Base ( STUArray, UArray(..), unsafeWrite )
+import Data.Array.Unboxed ( listArray )
+import Data.Array.Base ( UArray(..) )
import Data.Array.ST ( castSTUArray )
import Foreign ( Word16, free )
import Data.Int ( Int64 )
+import Data.Char ( ord )
import GHC.Base ( ByteArray# )
import GHC.IOBase ( IO(..) )
unlinkedBCOName :: Name,
unlinkedBCOArity :: Int,
unlinkedBCOInstrs :: ByteArray#, -- insns
+ unlinkedBCOBitmap :: ByteArray#, -- bitmap
unlinkedBCOLits :: (SizedSeq (Either Word FastString)), -- literals
-- Either literal words or a pointer to a asciiz
-- string, denoting a label whose *address* should
bcoFreeNames bco
= bco_refs bco `minusNameSet` mkNameSet [unlinkedBCOName bco]
where
- bco_refs (UnlinkedBCO _ _ _ _ ptrs itbls)
+ bco_refs (UnlinkedBCO _ _ _ _ _ ptrs itbls)
= unionManyNameSets (
mkNameSet [ n | BCOPtrName n <- ssElts ptrs ] :
mkNameSet (ssElts itbls) :
)
instance Outputable UnlinkedBCO where
- ppr (UnlinkedBCO nm arity insns lits ptrs itbls)
+ ppr (UnlinkedBCO nm arity insns bitmap lits ptrs itbls)
= sep [text "BCO", ppr nm, text "with",
int (sizeSS lits), text "lits",
int (sizeSS ptrs), text "ptrs",
insns_arr
| n_insns > 65535 = panic "linkBCO: >= 64k insns in BCO"
- | otherwise = runST (mkInstrArray arity bitmap
- bsize n_insns asm_insns)
+ | otherwise = mkInstrArray n_insns asm_insns
insns_barr = case insns_arr of UArray _lo _hi barr -> barr
- let ul_bco = UnlinkedBCO nm arity insns_barr final_lits
+ bitmap_arr = mkBitmapArray bsize bitmap
+ bitmap_barr = case bitmap_arr of UArray _lo _hi barr -> barr
+
+ let ul_bco = UnlinkedBCO nm arity insns_barr bitmap_barr final_lits
final_ptrs final_itbls
-- 8 Aug 01: Finalisers aren't safe when attached to non-primitive
zonk ptr = do -- putStrLn ("freeing malloc'd block at " ++ show (A# a#))
free ptr
+mkBitmapArray :: Int -> [StgWord] -> UArray Int StgWord
+mkBitmapArray bsize bitmap
+ = listArray (0, length bitmap) (fromIntegral bsize : bitmap)
-mkInstrArray :: Int -> [StgWord] -> Int -> Int -> [Word16]
- -> ST s (UArray Int Word16)
-mkInstrArray arity bitmap bsize n_insns asm_insns = do
- (arr :: STUArray s Int Word16) <- newArray_ (0, n_insns + bco_info_w16s)
- zipWithM (unsafeWrite arr) [bco_info_w16s ..]
- (fromIntegral n_insns : asm_insns)
- (arr' :: STUArray s Int StgWord) <- castSTUArray arr
- writeArray arr' 0 (fromIntegral arity)
- writeArray arr' 1 (fromIntegral bsize)
- zipWithM (writeArray arr') [2..] bitmap
- arr <- castSTUArray arr'
- unsafeFreeze arr
- where
- -- The BCO info (arity, bitmap) goes at the beginning of
- -- the instruction stream. See Closures.h for details.
- bco_info_w16s = (1 {- for the arity -} +
- 1 {- for the bitmap size -} +
- length bitmap) * (wORD_SIZE `quot` 2)
+mkInstrArray :: Int -> [Word16] -> UArray Int Word16
+mkInstrArray n_insns asm_insns
+ = listArray (0, n_insns) (fromIntegral n_insns : asm_insns)
-- instrs nonptrs ptrs itbls
type AsmState = (SizedSeq Word16,
= do st_I1 <- addToSS st_I0 (getName dcon)
return (sizeSS st_I0, (st_i0,st_l0,st_p0,st_I1))
- literal st (MachLabel fs) = litlabel st fs
- 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)
- literal st (MachChar c) = int st c
- literal st (MachInt64 ii) = int64 st (fromIntegral ii)
- literal st (MachWord64 ii) = int64 st (fromIntegral ii)
- literal st other = pprPanic "ByteCodeLink.literal" (ppr other)
-
-
-push_alts WordRep = bci_PUSH_ALTS_N
-push_alts IntRep = bci_PUSH_ALTS_N
-push_alts AddrRep = bci_PUSH_ALTS_N
-push_alts CharRep = bci_PUSH_ALTS_N
-push_alts FloatRep = bci_PUSH_ALTS_F
-push_alts DoubleRep = bci_PUSH_ALTS_D
-push_alts VoidRep = bci_PUSH_ALTS_V
-push_alts pk
- | is64BitRep pk = bci_PUSH_ALTS_L
- | isFollowableRep pk = bci_PUSH_ALTS_P
-
-return_ubx WordRep = bci_RETURN_N
-return_ubx IntRep = bci_RETURN_N
-return_ubx AddrRep = bci_RETURN_N
-return_ubx CharRep = bci_RETURN_N
-return_ubx FloatRep = bci_RETURN_F
-return_ubx DoubleRep = bci_RETURN_D
-return_ubx VoidRep = bci_RETURN_V
-return_ubx pk
- | is64BitRep pk = bci_RETURN_L
- | isFollowableRep pk = bci_RETURN_P
+ literal st (MachLabel fs _) = litlabel st fs
+ 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)
+ literal st (MachChar c) = int st (ord c)
+ literal st (MachInt64 ii) = int64 st (fromIntegral ii)
+ literal st (MachWord64 ii) = int64 st (fromIntegral ii)
+ literal st other = pprPanic "ByteCodeLink.literal" (ppr other)
+
+
+push_alts NonPtrArg = bci_PUSH_ALTS_N
+push_alts FloatArg = bci_PUSH_ALTS_F
+push_alts DoubleArg = bci_PUSH_ALTS_D
+push_alts VoidArg = bci_PUSH_ALTS_V
+push_alts LongArg = bci_PUSH_ALTS_L
+push_alts PtrArg = bci_PUSH_ALTS_P
+
+return_ubx NonPtrArg = bci_RETURN_N
+return_ubx FloatArg = bci_RETURN_F
+return_ubx DoubleArg = bci_RETURN_D
+return_ubx VoidArg = bci_RETURN_V
+return_ubx LongArg = bci_RETURN_L
+return_ubx PtrArg = bci_RETURN_P
-- The size in 16-bit entities of an instruction.
projects / ghc-hetmet.git / blobdiff