From b067bdc33ce1a0bb01957b0bcfbb1c516dba53a4 Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Tue, 27 Feb 2007 13:46:09 +0000 Subject: [PATCH] Remove the itbls field of BCO, put itbls in with the literals This is a simplification & minor optimisation for GHCi --- compiler/ghci/ByteCodeAsm.lhs | 110 +++++++++++++++++++-------------------- compiler/ghci/ByteCodeLink.lhs | 37 +++++-------- compiler/prelude/primops.txt.pp | 2 +- includes/Closures.h | 1 - includes/mkDerivedConstants.c | 1 - rts/Disassembler.c | 5 +- rts/Interpreter.c | 7 +-- rts/PrimOps.cmm | 12 ++--- rts/Sanity.c | 1 - rts/sm/Compact.c | 1 - rts/sm/Scav.c | 2 - 11 files changed, 76 insertions(+), 103 deletions(-) diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs index 1491f55..28263f9 100644 --- a/compiler/ghci/ByteCodeAsm.lhs +++ b/compiler/ghci/ByteCodeAsm.lhs @@ -11,7 +11,7 @@ module ByteCodeAsm ( assembleBCOs, assembleBCO, CompiledByteCode(..), - UnlinkedBCO(..), BCOPtr(..), bcoFreeNames, + UnlinkedBCO(..), BCOPtr(..), BCONPtr(..), bcoFreeNames, SizedSeq, sizeSS, ssElts, iNTERP_STACK_CHECK_THRESH ) where @@ -68,14 +68,10 @@ 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 @@ -83,25 +79,29 @@ data BCOPtr | BCOPtrPrimOp PrimOp | BCOPtrBCO UnlinkedBCO +data BCONPtr + = BCONPtrWord Word + | BCONPtrLbl FastString + | BCONPtrItbl Name + -- | Finds external references. Remember to remove the names -- defined by this group of BCOs themselves 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 @@ -141,11 +141,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 @@ -160,7 +159,7 @@ assembleBCO (ProtoBCO nm instrs bitmap bsize arity origin malloced) 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 + 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 @@ -180,11 +179,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 [] @@ -307,68 +305,68 @@ mkBits findLabel st proto_insns 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)) + return (sizeSS st_p0, (st_i0,st_l0,st_p1)) - 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)) + 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)) diff --git a/compiler/ghci/ByteCodeLink.lhs b/compiler/ghci/ByteCodeLink.lhs index c58ae87..9988325 100644 --- a/compiler/ghci/ByteCodeLink.lhs +++ b/compiler/ghci/ByteCodeLink.lhs @@ -43,9 +43,7 @@ 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(..), castPtr ) @@ -107,35 +105,28 @@ linkBCO ie ce ul_bco 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 let ptrs_parr = case ptrs_arr of Array lo hi parr -> parr - itbls_arr = listArray (0, n_itbls-1) linked_itbls - - itbls_barr = case itbls_arr of UArray lo hi barr -> barr - literals_arr = listArray (0, n_literals-1) linked_literals :: UArray Int Word literals_barr = case literals_arr of UArray lo hi barr -> barr (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 @@ -175,20 +166,18 @@ writeArrayBCO (IOArray (STArray _ _ marr#)) (I# i#) bco# = IO $ \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 + -> 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 diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index f5a98c3..3493d05 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -1672,7 +1672,7 @@ primop MkApUpd0_Op "mkApUpd0#" GenPrimOp out_of_line = True primop NewBCOOp "newBCO#" GenPrimOp - ByteArr# -> ByteArr# -> Array# a -> ByteArr# -> Int# -> ByteArr# -> State# s -> (# State# s, BCO# #) + ByteArr# -> ByteArr# -> Array# a -> Int# -> ByteArr# -> State# s -> (# State# s, BCO# #) with has_side_effects = True out_of_line = True diff --git a/includes/Closures.h b/includes/Closures.h index d5458f4..64582ba 100644 --- a/includes/Closures.h +++ b/includes/Closures.h @@ -232,7 +232,6 @@ typedef struct { StgArrWords *instrs; /* a pointer to an ArrWords */ StgArrWords *literals; /* a pointer to an ArrWords */ StgMutArrPtrs *ptrs; /* a pointer to a MutArrPtrs */ - StgArrWords *itbls; /* a pointer to an ArrWords */ StgHalfWord arity; /* arity of this BCO */ StgHalfWord size; /* size of this BCO (in words) */ StgWord bitmap[FLEXIBLE_ARRAY]; /* an StgLargeBitmap */ diff --git a/includes/mkDerivedConstants.c b/includes/mkDerivedConstants.c index 8e3ac2b..c797941 100644 --- a/includes/mkDerivedConstants.c +++ b/includes/mkDerivedConstants.c @@ -369,7 +369,6 @@ main(int argc, char *argv[]) closure_field(StgBCO, instrs); closure_field(StgBCO, literals); closure_field(StgBCO, ptrs); - closure_field(StgBCO, itbls); closure_field(StgBCO, arity); closure_field(StgBCO, size); closure_payload(StgBCO, bitmap); diff --git a/rts/Disassembler.c b/rts/Disassembler.c index f29cce2..4407c77 100644 --- a/rts/Disassembler.c +++ b/rts/Disassembler.c @@ -41,9 +41,6 @@ disInstr ( StgBCO *bco, int pc ) StgMutArrPtrs* ptrs_arr = bco->ptrs; StgPtr* ptrs = (StgPtr*)(&ptrs_arr->payload[0]); - StgArrWords* itbls_arr = bco->itbls; - StgInfoTable** itbls = (StgInfoTable**)(&itbls_arr->payload[0]); - instr = instrs[pc++]; switch (instr) { case bci_SWIZZLE: @@ -163,7 +160,7 @@ disInstr ( StgBCO *bco, int pc ) pc += 1; break; case bci_PACK: debugBelch("PACK %d words with itbl ", instrs[pc+1] ); - printPtr( (StgPtr)itbls[instrs[pc]] ); + printPtr( (StgPtr)literals[instrs[pc]] ); debugBelch("\n"); pc += 2; break; diff --git a/rts/Interpreter.c b/rts/Interpreter.c index 0312d3d..62fd2c2 100644 --- a/rts/Interpreter.c +++ b/rts/Interpreter.c @@ -54,7 +54,6 @@ #define BCO_PTR(n) (W_)ptrs[n] #define BCO_LIT(n) literals[n] -#define BCO_ITBL(n) itbls[n] #define LOAD_STACK_POINTERS \ Sp = cap->r.rCurrentTSO->sp; \ @@ -729,8 +728,6 @@ run_BCO: register StgWord16* instrs = (StgWord16*)(bco->instrs->payload); register StgWord* literals = (StgWord*)(&bco->literals->payload[0]); register StgPtr* ptrs = (StgPtr*)(&bco->ptrs->payload[0]); - register StgInfoTable** itbls = (StgInfoTable**) - (&bco->itbls->payload[0]); #ifdef INTERP_STATS it_lastopc = 0; /* no opcode */ @@ -1018,12 +1015,12 @@ run_BCO: int i; int o_itbl = BCO_NEXT; int n_words = BCO_NEXT; - StgInfoTable* itbl = INFO_PTR_TO_STRUCT(BCO_ITBL(o_itbl)); + StgInfoTable* itbl = INFO_PTR_TO_STRUCT(BCO_LIT(o_itbl)); int request = CONSTR_sizeW( itbl->layout.payload.ptrs, itbl->layout.payload.nptrs ); StgClosure* con = (StgClosure*)allocate_NONUPD(request); ASSERT( itbl->layout.payload.ptrs + itbl->layout.payload.nptrs > 0); - SET_HDR(con, BCO_ITBL(o_itbl), CCS_SYSTEM/*ToDo*/); + SET_HDR(con, (StgInfoTable*)BCO_LIT(o_itbl), CCS_SYSTEM/*ToDo*/); for (i = 0; i < n_words; i++) { con->payload[i] = (StgClosure*)Sp[i]; } diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm index e0823e4..955e50b 100644 --- a/rts/PrimOps.cmm +++ b/rts/PrimOps.cmm @@ -1900,17 +1900,16 @@ newBCOzh_fast /* R1 = instrs R2 = literals R3 = ptrs - R4 = itbls - R5 = arity - R6 = bitmap array + R4 = arity + R5 = bitmap array */ W_ bco, bitmap_arr, bytes, words; - bitmap_arr = R6; + bitmap_arr = R5; words = BYTES_TO_WDS(SIZEOF_StgBCO) + StgArrWords_words(bitmap_arr); bytes = WDS(words); - ALLOC_PRIM( bytes, R1_PTR&R2_PTR&R3_PTR&R4_PTR&R6_PTR, newBCOzh_fast ); + ALLOC_PRIM( bytes, R1_PTR&R2_PTR&R3_PTR&R5_PTR, newBCOzh_fast ); bco = Hp - bytes + WDS(1); SET_HDR(bco, stg_BCO_info, W_[CCCS]); @@ -1918,8 +1917,7 @@ newBCOzh_fast StgBCO_instrs(bco) = R1; StgBCO_literals(bco) = R2; StgBCO_ptrs(bco) = R3; - StgBCO_itbls(bco) = R4; - StgBCO_arity(bco) = HALF_W_(R5); + StgBCO_arity(bco) = HALF_W_(R4); StgBCO_size(bco) = HALF_W_(words); // Copy the arity/bitmap info into the BCO diff --git a/rts/Sanity.c b/rts/Sanity.c index 48d913c..6fdca36 100644 --- a/rts/Sanity.c +++ b/rts/Sanity.c @@ -324,7 +324,6 @@ checkClosure( StgClosure* p ) ASSERT(LOOKS_LIKE_CLOSURE_PTR(bco->instrs)); ASSERT(LOOKS_LIKE_CLOSURE_PTR(bco->literals)); ASSERT(LOOKS_LIKE_CLOSURE_PTR(bco->ptrs)); - ASSERT(LOOKS_LIKE_CLOSURE_PTR(bco->itbls)); return bco_sizeW(bco); } diff --git a/rts/sm/Compact.c b/rts/sm/Compact.c index 5cef816..62d9152 100644 --- a/rts/sm/Compact.c +++ b/rts/sm/Compact.c @@ -530,7 +530,6 @@ thread_obj (StgInfoTable *info, StgPtr p) thread_(&bco->instrs); thread_(&bco->literals); thread_(&bco->ptrs); - thread_(&bco->itbls); return p + bco_sizeW(bco); } diff --git a/rts/sm/Scav.c b/rts/sm/Scav.c index cd200f3..139ecad 100644 --- a/rts/sm/Scav.c +++ b/rts/sm/Scav.c @@ -411,7 +411,6 @@ scavenge(step *stp) bco->instrs = (StgArrWords *)evacuate((StgClosure *)bco->instrs); bco->literals = (StgArrWords *)evacuate((StgClosure *)bco->literals); bco->ptrs = (StgMutArrPtrs *)evacuate((StgClosure *)bco->ptrs); - bco->itbls = (StgArrWords *)evacuate((StgClosure *)bco->itbls); p += bco_sizeW(bco); break; } @@ -792,7 +791,6 @@ linear_scan: bco->instrs = (StgArrWords *)evacuate((StgClosure *)bco->instrs); bco->literals = (StgArrWords *)evacuate((StgClosure *)bco->literals); bco->ptrs = (StgMutArrPtrs *)evacuate((StgClosure *)bco->ptrs); - bco->itbls = (StgArrWords *)evacuate((StgClosure *)bco->itbls); break; } -- 1.7.10.4