Allow a word-sized argument for STKCHECK

diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs
index e1346a9..f1f5c8a 100644 (file)
--- a/compiler/ghci/ByteCodeAsm.lhs
+++ b/compiler/ghci/ByteCodeAsm.lhs
@@ -42,6 +42,7 @@ 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 )
 
@@ -202,6 +203,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
@@ -214,7 +230,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
@@ -286,6 +305,12 @@ mkBits findLabel st proto_insns
        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)
+          = do st_i' <- addToSS st_i (i2s i)
+               instrn (st_i', st_l, st_p, st_I) is
+
        instr1 (st_i0,st_l0,st_p0,st_I0) i1
           = do st_i1 <- addToSS st_i0 i1
                return (st_i1,st_l0,st_p0,st_I0)

diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs
index 72ad7df..bfc7d75 100644 (file)
--- a/compiler/ghci/ByteCodeGen.lhs
+++ b/compiler/ghci/ByteCodeGen.lhs
@@ -165,14 +165,12 @@ mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap
                -- don't do stack checks at return points;
                -- everything is aggregated up to the top BCO
                -- (which must be a function)
-           | stack_overest >= 65535
-           = pprPanic "mkProtoBCO: stack use won't fit in 16 bits" 
-                      (int stack_overest)
            | stack_overest >= iNTERP_STACK_CHECK_THRESH
            = STKCHECK stack_overest : peep_d
            | otherwise
            = peep_d    -- the supposedly common case
              
+        -- We assume that this sum doesn't wrap
         stack_overest = sum (map bciStackUse peep_d)
 
         -- Merge local pushes

diff --git a/includes/Bytecodes.h b/includes/Bytecodes.h
index 73003a3..4a75b00 100644 (file)
--- a/includes/Bytecodes.h
+++ b/includes/Bytecodes.h
@@ -75,6 +75,10 @@
 #define bci_RETURN_D                   50
 #define bci_RETURN_L                   51
 #define bci_RETURN_V                   52
+/* If you need to go past 255 then you will run into the flags */
+
+/* If you need to go below 0x0100 then you will run into the instructions */
+#define bci_FLAG_LARGE_ARGS     0x8000
 
 /* If a BCO definitely requires less than this many words of stack,
    don't include an explicit STKCHECK insn in it.  The interpreter

diff --git a/rts/Interpreter.c b/rts/Interpreter.c
index fba9e3f..b4ef171 100644 (file)
--- a/rts/Interpreter.c
+++ b/rts/Interpreter.c
@@ -41,6 +41,17 @@
 /* Sp points to the lowest live word on the stack. */
 
 #define BCO_NEXT      instrs[bciPtr++]
+#define BCO_NEXT_32   (bciPtr += 2, (((StgWord) instrs[bciPtr-2]) << 16) + ((StgWord) instrs[bciPtr-1]))
+#define BCO_NEXT_64   (bciPtr += 4, (((StgWord) instrs[bciPtr-4]) << 48) + (((StgWord) instrs[bciPtr-3]) << 32) + (((StgWord) instrs[bciPtr-2]) << 16) + ((StgWord) instrs[bciPtr-1]))
+#if WORD_SIZE_IN_BITS == 32
+#define BCO_NEXT_WORD BCO_NEXT_32
+#elif WORD_SIZE_IN_BITS == 64
+#define BCO_NEXT_WORD BCO_NEXT_64
+#else
+#error Can't cope with WORD_SIZE_IN_BITS being nether 32 nor 64
+#endif
+#define BCO_GET_LARGE_ARG ((bci & bci_FLAG_LARGE_ARGS) ? BCO_NEXT_WORD : BCO_NEXT)
+
 #define BCO_PTR(n)    (W_)ptrs[n]
 #define BCO_LIT(n)    literals[n]
 #define BCO_ITBL(n)   itbls[n]
@@ -713,6 +724,7 @@ run_BCO:
     INTERP_TICK(it_BCO_entries);
     {
        register int       bciPtr     = 1; /* 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]);
@@ -753,13 +765,18 @@ run_BCO:
        it_lastopc = (int)instrs[bciPtr];
 #endif
 
-       switch (BCO_NEXT) {
+       bci = BCO_NEXT;
+    /* We use the high 8 bits for flags, only the highest of which is
+     * currently allocated */
+    ASSERT((bci & 0xFF00) == (bci & 0x8000));
+
+    switch (bci & 0xFF) {
 
        case bci_STKCHECK: {
            // Explicit stack check at the beginning of a function
            // *only* (stack checks in case alternatives are
            // propagated to the enclosing function).
-           int stk_words_reqd = BCO_NEXT + 1;
+           StgWord stk_words_reqd = BCO_GET_LARGE_ARG + 1;
            if (Sp - stk_words_reqd < SpLim) {
                Sp -= 2; 
                Sp[1] = (W_)obj;