assembleBCOs, assembleBCO,
CompiledByteCode(..),
- UnlinkedBCO(..), BCOPtr(..), bcoFreeNames,
+ UnlinkedBCO(..), BCOPtr(..), BCONPtr(..), bcoFreeNames,
SizedSeq, sizeSS, ssElts,
iNTERP_STACK_CHECK_THRESH
) where
import Control.Monad ( foldM )
import Control.Monad.ST ( runST )
-import GHC.Word ( Word(..) )
import Data.Array.MArray
import Data.Array.Unboxed ( listArray )
import Data.Array.Base ( UArray(..) )
import Data.Array.ST ( castSTUArray )
-import Foreign ( Word16, free )
+import Foreign
import Data.Bits
import Data.Int ( Int64 )
import Data.Char ( ord )
-import GHC.Base ( ByteArray# )
+import GHC.Base ( ByteArray#, MutableByteArray#, RealWorld )
import GHC.IOBase ( IO(..) )
import GHC.Ptr ( Ptr(..) )
= UnlinkedBCO {
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
- -- be determined at link time
- unlinkedBCOPtrs :: (SizedSeq BCOPtr), -- ptrs
- unlinkedBCOItbls :: (SizedSeq Name) -- itbl refs
+ unlinkedBCOInstrs :: ByteArray#, -- insns
+ unlinkedBCOBitmap :: ByteArray#, -- bitmap
+ unlinkedBCOLits :: (SizedSeq BCONPtr), -- non-ptrs
+ unlinkedBCOPtrs :: (SizedSeq BCOPtr) -- ptrs
}
data BCOPtr
= BCOPtrName Name
| BCOPtrPrimOp PrimOp
| BCOPtrBCO UnlinkedBCO
+ | BCOPtrBreakInfo BreakInfo
+ | BCOPtrArray (MutableByteArray# RealWorld)
+
+data BCONPtr
+ = BCONPtrWord Word
+ | BCONPtrLbl FastString
+ | BCONPtrItbl Name
-- | Finds external references. Remember to remove the names
-- defined by this group of BCOs themselves
bcoFreeNames bco
= bco_refs bco `minusNameSet` mkNameSet [unlinkedBCOName bco]
where
- bco_refs (UnlinkedBCO _ _ _ _ _ ptrs itbls)
+ bco_refs (UnlinkedBCO _ _ _ _ nonptrs ptrs)
= unionManyNameSets (
mkNameSet [ n | BCOPtrName n <- ssElts ptrs ] :
- mkNameSet (ssElts itbls) :
+ mkNameSet [ n | BCONPtrItbl n <- ssElts nonptrs ] :
map bco_refs [ bco | BCOPtrBCO bco <- ssElts ptrs ]
)
instance Outputable UnlinkedBCO where
- ppr (UnlinkedBCO nm arity insns bitmap lits ptrs itbls)
+ ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs)
= sep [text "BCO", ppr nm, text "with",
int (sizeSS lits), text "lits",
- int (sizeSS ptrs), text "ptrs",
- int (sizeSS itbls), text "itbls"]
+ int (sizeSS ptrs), text "ptrs" ]
-- -----------------------------------------------------------------------------
-- The bytecode assembler
return (ByteCode bcos itblenv)
assembleBCO :: ProtoBCO Name -> IO UnlinkedBCO
-assembleBCO (ProtoBCO nm instrs bitmap bsize arity origin malloced)
+assembleBCO (ProtoBCO nm instrs bitmap bsize arity _origin _malloced)
= let
-- pass 1: collect up the offsets of the local labels.
-- Remember that the first insn starts at offset 1 since offset 0
-- (eventually) will hold the total # of insns.
label_env = mkLabelEnv emptyFM 1 instrs
- mkLabelEnv env i_offset [] = env
+ mkLabelEnv env _ [] = env
mkLabelEnv env i_offset (i:is)
= let new_env
= case i of LABEL n -> addToFM env n i_offset ; _ -> env
in
do -- pass 2: generate the instruction, ptr and nonptr bits
insns <- return emptySS :: IO (SizedSeq Word16)
- lits <- return emptySS :: IO (SizedSeq (Either Word FastString))
+ lits <- return emptySS :: IO (SizedSeq BCONPtr)
ptrs <- return emptySS :: IO (SizedSeq BCOPtr)
- itbls <- return emptySS :: IO (SizedSeq Name)
- let init_asm_state = (insns,lits,ptrs,itbls)
- (final_insns, final_lits, final_ptrs, final_itbls)
+ let init_asm_state = (insns,lits,ptrs)
+ (final_insns, final_lits, final_ptrs)
<- mkBits findLabel init_asm_state instrs
let asm_insns = ssElts final_insns
insns_arr
| n_insns > 65535 = panic "linkBCO: >= 64k insns in BCO"
| otherwise = mkInstrArray n_insns asm_insns
- insns_barr = case insns_arr of UArray _lo _hi barr -> barr
+ !insns_barr = case insns_arr of UArray _lo _hi _n barr -> barr
bitmap_arr = mkBitmapArray bsize bitmap
- bitmap_barr = case bitmap_arr of UArray _lo _hi barr -> barr
+ !bitmap_barr = case bitmap_arr of UArray _lo _hi _n barr -> barr
- let ul_bco = UnlinkedBCO nm arity insns_barr bitmap_barr final_lits
- final_ptrs final_itbls
+ let ul_bco = UnlinkedBCO nm arity insns_barr bitmap_barr final_lits final_ptrs
-- 8 Aug 01: Finalisers aren't safe when attached to non-primitive
-- objects, since they might get run too early. Disable this until
-- when (notNull malloced) (addFinalizer ul_bco (mapM_ zonk malloced))
return ul_bco
- where
- zonk ptr = do -- putStrLn ("freeing malloc'd block at " ++ show (A# a#))
- free ptr
+ -- where
+ -- zonk ptr = do -- putStrLn ("freeing malloc'd block at " ++ show (A# a#))
+ -- free ptr
mkBitmapArray :: Int -> [StgWord] -> UArray Int StgWord
mkBitmapArray bsize bitmap
mkInstrArray n_insns asm_insns
= listArray (0, n_insns) (fromIntegral n_insns : asm_insns)
--- instrs nonptrs ptrs itbls
+-- instrs nonptrs ptrs
type AsmState = (SizedSeq Word16,
- SizedSeq (Either Word FastString),
- SizedSeq BCOPtr,
- SizedSeq Name)
+ SizedSeq BCONPtr,
+ SizedSeq BCOPtr)
data SizedSeq a = SizedSeq !Int [a]
+emptySS :: SizedSeq a
emptySS = SizedSeq 0 []
-- Why are these two monadic???
+addToSS :: SizedSeq a -> a -> IO (SizedSeq a)
addToSS (SizedSeq n r_xs) x = return (SizedSeq (n+1) (x:r_xs))
+addListToSS :: SizedSeq a -> [a] -> IO (SizedSeq a)
addListToSS (SizedSeq n r_xs) xs
= return (SizedSeq (n + length xs) (reverse xs ++ r_xs))
ssElts :: SizedSeq a -> [a]
-ssElts (SizedSeq n r_xs) = reverse r_xs
+ssElts (SizedSeq _ r_xs) = reverse r_xs
sizeSS :: SizedSeq a -> Int
-sizeSS (SizedSeq n r_xs) = n
+sizeSS (SizedSeq n _) = n
-- Bring in all the bci_ bytecode constants.
#include "Bytecodes.h"
SLIDE n by -> instr3 st bci_SLIDE n by
ALLOC_AP n -> instr2 st bci_ALLOC_AP n
+ ALLOC_AP_NOUPD n -> instr2 st bci_ALLOC_AP_NOUPD n
ALLOC_PAP arity n -> instr3 st bci_ALLOC_PAP arity n
MKAP off sz -> instr3 st bci_MKAP off sz
MKPAP off sz -> instr3 st bci_MKPAP off sz
UNPACK n -> instr2 st bci_UNPACK n
PACK dcon sz -> do (itbl_no,st2) <- itbl st dcon
instr3 st2 bci_PACK itbl_no sz
- LABEL lab -> return st
+ LABEL _ -> return st
TESTLT_I i l -> do (np, st2) <- int st i
instr3 st2 bci_TESTLT_I np (findLabel l)
TESTEQ_I i l -> do (np, st2) <- int st i
RETURN_UBX rep -> instr1 st (return_ubx rep)
CCALL off m_addr -> do (np, st2) <- addr st m_addr
instr3 st2 bci_CCALL off np
+ BRK_FUN array index info -> do
+ (p1, st2) <- ptr st (BCOPtrArray array)
+ (p2, st3) <- ptr st2 (BCOPtrBreakInfo info)
+ instr4 st3 bci_BRK_FUN p1 index p2
i2s :: Int -> Word16
i2s = fromIntegral
instrn :: AsmState -> [Int] -> IO AsmState
instrn st [] = return st
- instrn (st_i, st_l, st_p, st_I) (i:is)
+ instrn (st_i, st_l, st_p) (i:is)
= do st_i' <- addToSS st_i (i2s i)
- instrn (st_i', st_l, st_p, st_I) is
+ instrn (st_i', st_l, st_p) is
- instr1 (st_i0,st_l0,st_p0,st_I0) i1
+ instr1 (st_i0,st_l0,st_p0) i1
= do st_i1 <- addToSS st_i0 i1
- return (st_i1,st_l0,st_p0,st_I0)
+ return (st_i1,st_l0,st_p0)
- instr2 (st_i0,st_l0,st_p0,st_I0) i1 i2
+ instr2 (st_i0,st_l0,st_p0) i1 i2
= do st_i1 <- addToSS st_i0 (i2s i1)
st_i2 <- addToSS st_i1 (i2s i2)
- return (st_i2,st_l0,st_p0,st_I0)
+ return (st_i2,st_l0,st_p0)
- instr3 (st_i0,st_l0,st_p0,st_I0) i1 i2 i3
+ instr3 (st_i0,st_l0,st_p0) i1 i2 i3
= do st_i1 <- addToSS st_i0 (i2s i1)
st_i2 <- addToSS st_i1 (i2s i2)
st_i3 <- addToSS st_i2 (i2s i3)
- return (st_i3,st_l0,st_p0,st_I0)
+ return (st_i3,st_l0,st_p0)
- instr4 (st_i0,st_l0,st_p0,st_I0) i1 i2 i3 i4
+ instr4 (st_i0,st_l0,st_p0) i1 i2 i3 i4
= do st_i1 <- addToSS st_i0 (i2s i1)
st_i2 <- addToSS st_i1 (i2s i2)
st_i3 <- addToSS st_i2 (i2s i3)
st_i4 <- addToSS st_i3 (i2s i4)
- return (st_i4,st_l0,st_p0,st_I0)
+ return (st_i4,st_l0,st_p0)
- float (st_i0,st_l0,st_p0,st_I0) f
+ float (st_i0,st_l0,st_p0) f
= do let ws = mkLitF f
- st_l1 <- addListToSS st_l0 (map Left ws)
- return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
+ st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
+ return (sizeSS st_l0, (st_i0,st_l1,st_p0))
- double (st_i0,st_l0,st_p0,st_I0) d
+ double (st_i0,st_l0,st_p0) d
= do let ws = mkLitD d
- st_l1 <- addListToSS st_l0 (map Left ws)
- return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
+ st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
+ return (sizeSS st_l0, (st_i0,st_l1,st_p0))
- int (st_i0,st_l0,st_p0,st_I0) i
+ int (st_i0,st_l0,st_p0) i
= do let ws = mkLitI i
- st_l1 <- addListToSS st_l0 (map Left ws)
- return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
+ st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
+ return (sizeSS st_l0, (st_i0,st_l1,st_p0))
- int64 (st_i0,st_l0,st_p0,st_I0) i
+ int64 (st_i0,st_l0,st_p0) i
= do let ws = mkLitI64 i
- st_l1 <- addListToSS st_l0 (map Left ws)
- return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
+ st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
+ return (sizeSS st_l0, (st_i0,st_l1,st_p0))
- addr (st_i0,st_l0,st_p0,st_I0) a
+ addr (st_i0,st_l0,st_p0) a
= do let ws = mkLitPtr a
- st_l1 <- addListToSS st_l0 (map Left ws)
- return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
+ st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
+ return (sizeSS st_l0, (st_i0,st_l1,st_p0))
- litlabel (st_i0,st_l0,st_p0,st_I0) fs
- = do st_l1 <- addListToSS st_l0 [Right fs]
- return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
+ litlabel (st_i0,st_l0,st_p0) fs
+ = do st_l1 <- addListToSS st_l0 [BCONPtrLbl fs]
+ return (sizeSS st_l0, (st_i0,st_l1,st_p0))
- ptr (st_i0,st_l0,st_p0,st_I0) p
+ ptr (st_i0,st_l0,st_p0) p
= do st_p1 <- addToSS st_p0 p
- return (sizeSS st_p0, (st_i0,st_l0,st_p1,st_I0))
-
- itbl (st_i0,st_l0,st_p0,st_I0) dcon
- = 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
+ return (sizeSS st_p0, (st_i0,st_l0,st_p1))
+
+ itbl (st_i0,st_l0,st_p0) dcon
+ = do st_l1 <- addToSS st_l0 (BCONPtrItbl (getName dcon))
+ return (sizeSS st_l0, (st_i0,st_l1,st_p0))
+
+#ifdef mingw32_TARGET_OS
+ literal st (MachLabel fs (Just sz) _)
+ = litlabel st (appendFS fs (mkFastString ('@':show sz)))
+ -- On Windows, stdcall labels have a suffix indicating the no. of
+ -- arg words, e.g. foo@8. testcase: ffi012(ghci)
+#endif
+ 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 MachNullAddr = int st (fromIntegral 0)
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)
+ literal _ other = pprPanic "ByteCodeAsm.literal" (ppr other)
+push_alts :: CgRep -> Int
push_alts NonPtrArg = bci_PUSH_ALTS_N
push_alts FloatArg = bci_PUSH_ALTS_F
push_alts DoubleArg = bci_PUSH_ALTS_D
push_alts LongArg = bci_PUSH_ALTS_L
push_alts PtrArg = bci_PUSH_ALTS_P
+return_ubx :: CgRep -> Word16
return_ubx NonPtrArg = bci_RETURN_N
return_ubx FloatArg = bci_RETURN_F
return_ubx DoubleArg = bci_RETURN_D
PUSH_APPLY_PPPPPP{} -> 1
SLIDE{} -> 3
ALLOC_AP{} -> 2
+ ALLOC_AP_NOUPD{} -> 2
ALLOC_PAP{} -> 3
MKAP{} -> 3
MKPAP{} -> 3
RETURN_UBX{} -> 1
CCALL{} -> 3
SWIZZLE{} -> 3
+ BRK_FUN{} -> 4
-- Make lists of host-sized words for literals, so that when the
-- words are placed in memory at increasing addresses, the
w0 <- readArray d_arr 0
return [w0 :: Word]
)
+ | otherwise
+ = panic "mkLitD: Bad wORD_SIZE"
mkLitI64 ii
| wORD_SIZE == 4
w0 <- readArray d_arr 0
return [w0 :: Word]
)
+ | otherwise
+ = panic "mkLitI64: Bad wORD_SIZE"
mkLitI i
= runST (do
return [w0 :: Word]
)
-iNTERP_STACK_CHECK_THRESH = (INTERP_STACK_CHECK_THRESH :: Int)
+iNTERP_STACK_CHECK_THRESH :: Int
+iNTERP_STACK_CHECK_THRESH = INTERP_STACK_CHECK_THRESH
\end{code}
projects / ghc-hetmet.git / blobdiff