X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fghci%2FByteCodeAsm.lhs;h=6502ac4182629d59f1e8ef2b06a7fd6d2b591efa;hp=e332413daed8eba05623eedd78119ba3cedd33fc;hb=17b297d97d327620ed6bfab942f8992b2446f1bf;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1 diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs index e332413..6502ac4 100644 --- a/compiler/ghci/ByteCodeAsm.lhs +++ b/compiler/ghci/ByteCodeAsm.lhs @@ -1,16 +1,24 @@ % -% (c) The University of Glasgow 2002 +% (c) The University of Glasgow 2002-2006 % -\section[ByteCodeLink]{Bytecode assembler and linker} + +ByteCodeLink: Bytecode assembler and linker \begin{code} {-# OPTIONS -optc-DNON_POSIX_SOURCE #-} +{-# OPTIONS_GHC -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/WorkingConventions#Warnings +-- for details + module ByteCodeAsm ( assembleBCOs, assembleBCO, CompiledByteCode(..), - UnlinkedBCO(..), BCOPtr(..), bcoFreeNames, + UnlinkedBCO(..), BCOPtr(..), BCONPtr(..), bcoFreeNames, SizedSeq, sizeSS, ssElts, iNTERP_STACK_CHECK_THRESH ) where @@ -18,17 +26,17 @@ module ByteCodeAsm ( #include "HsVersions.h" import ByteCodeInstr -import ByteCodeItbls ( ItblEnv, mkITbls ) +import ByteCodeItbls -import Name ( Name, getName ) +import Name import NameSet -import FiniteMap ( addToFM, lookupFM, emptyFM ) -import Literal ( Literal(..) ) -import TyCon ( TyCon ) -import PrimOp ( PrimOp ) -import Constants ( wORD_SIZE ) -import FastString ( FastString(..) ) -import SMRep ( CgRep(..), StgWord ) +import FiniteMap +import Literal +import TyCon +import PrimOp +import Constants +import FastString +import SMRep import FiniteMap import Outputable @@ -41,10 +49,11 @@ import Data.Array.Unboxed ( listArray ) import Data.Array.Base ( UArray(..) ) import Data.Array.ST ( castSTUArray ) import Foreign ( Word16, free ) +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(..) ) @@ -66,20 +75,23 @@ data UnlinkedBCO = 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 @@ -87,19 +99,18 @@ bcoFreeNames :: UnlinkedBCO -> NameSet 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 @@ -139,11 +150,10 @@ assembleBCO (ProtoBCO nm instrs bitmap bsize arity origin malloced) 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 @@ -152,13 +162,12 @@ assembleBCO (ProtoBCO nm instrs bitmap bsize arity origin malloced) 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 @@ -166,9 +175,9 @@ assembleBCO (ProtoBCO nm instrs bitmap bsize arity origin malloced) -- 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 @@ -178,11 +187,10 @@ mkInstrArray :: Int -> [Word16] -> UArray Int Word16 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 0 [] @@ -201,6 +209,21 @@ sizeSS (SizedSeq n r_xs) = n -- Bring in all the bci_ bytecode constants. #include "Bytecodes.h" +largeArgInstr :: Int -> Int +largeArgInstr bci = bci_FLAG_LARGE_ARGS .|. bci + +largeArg :: Int -> [Int] +largeArg i + | wORD_SIZE_IN_BITS == 64 + = [(i .&. 0xFFFF000000000000) `shiftR` 48, + (i .&. 0x0000FFFF00000000) `shiftR` 32, + (i .&. 0x00000000FFFF0000) `shiftR` 16, + (i .&. 0x000000000000FFFF)] + | wORD_SIZE_IN_BITS == 32 + = [(i .&. 0xFFFF0000) `shiftR` 16, + (i .&. 0x0000FFFF)] + | otherwise = error "wORD_SIZE_IN_BITS not 32 or 64?" + -- This is where all the action is (pass 2 of the assembler) mkBits :: (Int -> Int) -- label finder -> AsmState @@ -213,7 +236,10 @@ mkBits findLabel st proto_insns doInstr :: AsmState -> BCInstr -> IO AsmState doInstr st i = case i of - STKCHECK n -> instr2 st bci_STKCHECK n + STKCHECK n + | n > 65535 -> + instrn st (largeArgInstr bci_STKCHECK : largeArg n) + | otherwise -> instr2 st bci_STKCHECK n PUSH_L o1 -> instr2 st bci_PUSH_L o1 PUSH_LL o1 o2 -> instr3 st bci_PUSH_LL o1 o2 PUSH_LLL o1 o2 o3 -> instr4 st bci_PUSH_LLL o1 o2 o3 @@ -281,69 +307,85 @@ mkBits findLabel st proto_insns 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 - instr1 (st_i0,st_l0,st_p0,st_I0) i1 + instrn :: AsmState -> [Int] -> IO AsmState + instrn st [] = return st + instrn (st_i, st_l, st_p) (i:is) + = do st_i' <- addToSS st_i (i2s i) + instrn (st_i', st_l, st_p) is + + 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)) - + 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) @@ -418,6 +460,7 @@ instrSize16s instr 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