Allow a word-sized argument for STKCHECK

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)

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

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

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;