Commit b067bdc3 authored by Simon Marlow's avatar Simon Marlow
Browse files

Remove the itbls field of BCO, put itbls in with the literals

This is a simplification & minor optimisation for GHCi
parent f38310c9
......@@ -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))
......
......@@ -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
......
......@@ -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
......
......@@ -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 */
......
......@@ -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);
......
......@@ -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;
......
......@@ -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];
}
......
......@@ -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
......
......@@ -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);
}
......
......@@ -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);
}
......
......@@ -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;
}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment