From 5615397b9348e68ea2bfe0813c4b4c2beac96ef8 Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Sat, 1 Aug 2009 15:32:03 +0000 Subject: [PATCH] Allow more than 64k instructions in a BCO; fixes #789 --- compiler/ghci/ByteCodeAsm.lhs | 63 ++++++++++++++++++++++++----------------- rts/Interpreter.c | 25 +++++++++------- 2 files changed, 51 insertions(+), 37 deletions(-) diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs index f690aa6..e842bf7 100644 --- a/compiler/ghci/ByteCodeAsm.lhs +++ b/compiler/ghci/ByteCodeAsm.lhs @@ -121,17 +121,24 @@ assembleBCO :: ProtoBCO Name -> IO UnlinkedBCO 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 - + -- Remember that the first insn starts at offset + -- sizeOf Word / sizeOf Word16 + -- since offset 0 (eventually) will hold the total # of insns. + lableInitialOffset + | wORD_SIZE_IN_BITS == 64 = 4 + | wORD_SIZE_IN_BITS == 32 = 2 + | otherwise = error "wORD_SIZE_IN_BITS not 32 or 64?" + label_env = mkLabelEnv emptyFM lableInitialOffset instrs + + mkLabelEnv :: FiniteMap Word16 Word -> Word -> [BCInstr] + -> FiniteMap Word16 Word mkLabelEnv env _ [] = env mkLabelEnv env i_offset (i:is) = let new_env = case i of LABEL n -> addToFM env n i_offset ; _ -> env in mkLabelEnv new_env (i_offset + instrSize16s i) is - findLabel :: Word16 -> Word16 + findLabel :: Word16 -> Word findLabel lab = case lookupFM label_env lab of Just bco_offset -> bco_offset @@ -148,9 +155,7 @@ assembleBCO (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) let asm_insns = ssElts final_insns n_insns = sizeSS final_insns - insns_arr - | n_insns > 65535 = panic "linkBCO: >= 64k insns in BCO" - | otherwise = mkInstrArray (fromIntegral n_insns) asm_insns + insns_arr = mkInstrArray lableInitialOffset n_insns asm_insns !insns_barr = case insns_arr of UArray _lo _hi _n barr -> barr bitmap_arr = mkBitmapArray bsize bitmap @@ -172,9 +177,10 @@ mkBitmapArray :: Word16 -> [StgWord] -> UArray Int StgWord mkBitmapArray bsize bitmap = listArray (0, length bitmap) (fromIntegral bsize : bitmap) -mkInstrArray :: Word16 -> [Word16] -> UArray Word16 Word16 -mkInstrArray n_insns asm_insns - = listArray (0, n_insns) (n_insns : asm_insns) +mkInstrArray :: Word -> Word -> [Word16] -> UArray Word Word16 +mkInstrArray lableInitialOffset n_insns asm_insns + = let size = lableInitialOffset + n_insns + in listArray (0, size - 1) (largeArg size ++ asm_insns) -- instrs nonptrs ptrs type AsmState = (SizedSeq Word16, @@ -220,7 +226,7 @@ largeArg w | otherwise = error "wORD_SIZE_IN_BITS not 32 or 64?" -- This is where all the action is (pass 2 of the assembler) -mkBits :: (Word16 -> Word16) -- label finder +mkBits :: (Word16 -> Word) -- label finder -> AsmState -> [BCInstr] -- instructions (in) -> IO AsmState @@ -231,10 +237,7 @@ mkBits findLabel st proto_insns doInstr :: AsmState -> BCInstr -> IO AsmState doInstr st i = case i of - STKCHECK n - | n > 65535 -> - instrn st (largeArgInstr bci_STKCHECK : largeArg n) - | otherwise -> instr2 st bci_STKCHECK (fromIntegral n) + STKCHECK n -> instr1Large 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 @@ -282,22 +285,22 @@ mkBits findLabel st proto_insns instr3 st2 bci_PACK itbl_no sz LABEL _ -> return st TESTLT_I i l -> do (np, st2) <- int st i - instr3 st2 bci_TESTLT_I np (findLabel l) + instr2Large st2 bci_TESTLT_I np (findLabel l) TESTEQ_I i l -> do (np, st2) <- int st i - instr3 st2 bci_TESTEQ_I np (findLabel l) + instr2Large st2 bci_TESTEQ_I np (findLabel l) TESTLT_F f l -> do (np, st2) <- float st f - instr3 st2 bci_TESTLT_F np (findLabel l) + instr2Large st2 bci_TESTLT_F np (findLabel l) TESTEQ_F f l -> do (np, st2) <- float st f - instr3 st2 bci_TESTEQ_F np (findLabel l) + instr2Large st2 bci_TESTEQ_F np (findLabel l) TESTLT_D d l -> do (np, st2) <- double st d - instr3 st2 bci_TESTLT_D np (findLabel l) + instr2Large st2 bci_TESTLT_D np (findLabel l) TESTEQ_D d l -> do (np, st2) <- double st d - instr3 st2 bci_TESTEQ_D np (findLabel l) - TESTLT_P i l -> instr3 st bci_TESTLT_P i (findLabel l) - TESTEQ_P i l -> instr3 st bci_TESTEQ_P i (findLabel l) + instr2Large st2 bci_TESTEQ_D np (findLabel l) + TESTLT_P i l -> instr2Large st bci_TESTLT_P i (findLabel l) + TESTEQ_P i l -> instr2Large st bci_TESTEQ_P i (findLabel l) CASEFAIL -> instr1 st bci_CASEFAIL SWIZZLE stkoff n -> instr3 st bci_SWIZZLE stkoff n - JMP l -> instr2 st bci_JMP (findLabel l) + JMP l -> instr1Large st bci_JMP (findLabel l) ENTER -> instr1 st bci_ENTER RETURN -> instr1 st bci_RETURN RETURN_UBX rep -> instr1 st (return_ubx rep) @@ -314,6 +317,14 @@ mkBits findLabel st proto_insns = do st_i' <- addToSS st_i i instrn (st_i', st_l, st_p) is + instr1Large st i1 large + | large > 65535 = instrn st (largeArgInstr i1 : largeArg large) + | otherwise = instr2 st i1 (fromIntegral large) + + instr2Large st i1 i2 large + | large > 65535 = instrn st (largeArgInstr i1 : i2 : largeArg large) + | otherwise = instr3 st i1 i2 (fromIntegral large) + instr1 (st_i0,st_l0,st_p0) i1 = do st_i1 <- addToSS st_i0 i1 return (st_i1,st_l0,st_p0) @@ -409,7 +420,7 @@ return_ubx PtrArg = bci_RETURN_P -- The size in 16-bit entities of an instruction. -instrSize16s :: BCInstr -> Word16 +instrSize16s :: BCInstr -> Word instrSize16s instr = case instr of STKCHECK{} -> 2 diff --git a/rts/Interpreter.c b/rts/Interpreter.c index 3a99d42..91e500b 100644 --- a/rts/Interpreter.c +++ b/rts/Interpreter.c @@ -763,19 +763,22 @@ run_BCO_fun: run_BCO: INTERP_TICK(it_BCO_entries); { - register int bciPtr = 1; /* instruction pointer */ + register int bciPtr = 0; /* instruction pointer */ register StgWord16 bci; register StgBCO* bco = (StgBCO*)obj; register StgWord16* instrs = (StgWord16*)(bco->instrs->payload); register StgWord* literals = (StgWord*)(&bco->literals->payload[0]); register StgPtr* ptrs = (StgPtr*)(&bco->ptrs->payload[0]); + int bcoSize; + bcoSize = BCO_NEXT_WORD; + IF_DEBUG(interpreter,debugBelch("bcoSize = %d\n", bcoSize)); #ifdef INTERP_STATS it_lastopc = 0; /* no opcode */ #endif nextInsn: - ASSERT(bciPtr <= instrs[0]); + ASSERT(bciPtr < bcoSize); IF_DEBUG(interpreter, //if (do_print_stack) { //debugBelch("\n-- BEGIN stack\n"); @@ -1186,7 +1189,7 @@ run_BCO: case bci_TESTLT_P: { unsigned int discr = BCO_NEXT; - int failto = BCO_NEXT; + int failto = BCO_GET_LARGE_ARG; StgClosure* con = (StgClosure*)Sp[0]; if (GET_TAG(con) >= discr) { bciPtr = failto; @@ -1196,7 +1199,7 @@ run_BCO: case bci_TESTEQ_P: { unsigned int discr = BCO_NEXT; - int failto = BCO_NEXT; + int failto = BCO_GET_LARGE_ARG; StgClosure* con = (StgClosure*)Sp[0]; if (GET_TAG(con) != discr) { bciPtr = failto; @@ -1207,7 +1210,7 @@ run_BCO: case bci_TESTLT_I: { // There should be an Int at Sp[1], and an info table at Sp[0]. int discr = BCO_NEXT; - int failto = BCO_NEXT; + int failto = BCO_GET_LARGE_ARG; I_ stackInt = (I_)Sp[1]; if (stackInt >= (I_)BCO_LIT(discr)) bciPtr = failto; @@ -1217,7 +1220,7 @@ run_BCO: case bci_TESTEQ_I: { // There should be an Int at Sp[1], and an info table at Sp[0]. int discr = BCO_NEXT; - int failto = BCO_NEXT; + int failto = BCO_GET_LARGE_ARG; I_ stackInt = (I_)Sp[1]; if (stackInt != (I_)BCO_LIT(discr)) { bciPtr = failto; @@ -1228,7 +1231,7 @@ run_BCO: case bci_TESTLT_D: { // There should be a Double at Sp[1], and an info table at Sp[0]. int discr = BCO_NEXT; - int failto = BCO_NEXT; + int failto = BCO_GET_LARGE_ARG; StgDouble stackDbl, discrDbl; stackDbl = PK_DBL( & Sp[1] ); discrDbl = PK_DBL( & BCO_LIT(discr) ); @@ -1241,7 +1244,7 @@ run_BCO: case bci_TESTEQ_D: { // There should be a Double at Sp[1], and an info table at Sp[0]. int discr = BCO_NEXT; - int failto = BCO_NEXT; + int failto = BCO_GET_LARGE_ARG; StgDouble stackDbl, discrDbl; stackDbl = PK_DBL( & Sp[1] ); discrDbl = PK_DBL( & BCO_LIT(discr) ); @@ -1254,7 +1257,7 @@ run_BCO: case bci_TESTLT_F: { // There should be a Float at Sp[1], and an info table at Sp[0]. int discr = BCO_NEXT; - int failto = BCO_NEXT; + int failto = BCO_GET_LARGE_ARG; StgFloat stackFlt, discrFlt; stackFlt = PK_FLT( & Sp[1] ); discrFlt = PK_FLT( & BCO_LIT(discr) ); @@ -1267,7 +1270,7 @@ run_BCO: case bci_TESTEQ_F: { // There should be a Float at Sp[1], and an info table at Sp[0]. int discr = BCO_NEXT; - int failto = BCO_NEXT; + int failto = BCO_GET_LARGE_ARG; StgFloat stackFlt, discrFlt; stackFlt = PK_FLT( & Sp[1] ); discrFlt = PK_FLT( & BCO_LIT(discr) ); @@ -1451,7 +1454,7 @@ run_BCO: case bci_JMP: { /* BCO_NEXT modifies bciPtr, so be conservative. */ - int nextpc = BCO_NEXT; + int nextpc = BCO_GET_LARGE_ARG; bciPtr = nextpc; goto nextInsn; } -- 1.7.10.4