Fix the 64k insns overflow check in ghci, and add more checks

2 files changed, 22 insertions, 15 deletions

diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs
index 5980810f88..f690aa6990 100644
--- a/compiler/ghci/ByteCodeAsm.lhs
+++ b/compiler/ghci/ByteCodeAsm.lhs
@@ -150,7 +150,7 @@ assembleBCO (ProtoBCO nm instrs bitmap bsize arity _origin _malloced)
 
              insns_arr
                  | n_insns > 65535 = panic "linkBCO: >= 64k insns in BCO"
-                 | otherwise = mkInstrArray n_insns asm_insns
+                 | otherwise = mkInstrArray (fromIntegral n_insns) asm_insns
              !insns_barr = case insns_arr of UArray _lo _hi _n barr -> barr
 
              bitmap_arr = mkBitmapArray bsize bitmap
@@ -181,7 +181,7 @@ type AsmState = (SizedSeq Word16,
                  SizedSeq BCONPtr,
                  SizedSeq BCOPtr)
 
-data SizedSeq a = SizedSeq !Word16 [a]
+data SizedSeq a = SizedSeq !Word [a]
 emptySS :: SizedSeq a
 emptySS = SizedSeq 0 []
 
@@ -195,9 +195,12 @@ addListToSS (SizedSeq n r_xs) xs
 ssElts :: SizedSeq a -> [a]
 ssElts (SizedSeq _ r_xs) = reverse r_xs
 
-sizeSS :: SizedSeq a -> Word16
+sizeSS :: SizedSeq a -> Word
 sizeSS (SizedSeq n _) = n
 
+sizeSS16 :: SizedSeq a -> Word16
+sizeSS16 (SizedSeq n _) = fromIntegral n
+
 -- Bring in all the bci_ bytecode constants.
 #include "Bytecodes.h"
 
@@ -336,39 +339,39 @@ mkBits findLabel st proto_insns
        float (st_i0,st_l0,st_p0) f
           = do let ws = mkLitF f
                st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
-               return (sizeSS st_l0, (st_i0,st_l1,st_p0))
+               return (sizeSS16 st_l0, (st_i0,st_l1,st_p0))
 
        double (st_i0,st_l0,st_p0) d
           = do let ws = mkLitD d
                st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
-               return (sizeSS st_l0, (st_i0,st_l1,st_p0))
+               return (sizeSS16 st_l0, (st_i0,st_l1,st_p0))
 
        int (st_i0,st_l0,st_p0) i
           = do let ws = mkLitI i
                st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
-               return (sizeSS st_l0, (st_i0,st_l1,st_p0))
+               return (sizeSS16 st_l0, (st_i0,st_l1,st_p0))
 
        int64 (st_i0,st_l0,st_p0) i
           = do let ws = mkLitI64 i
                st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
-               return (sizeSS st_l0, (st_i0,st_l1,st_p0))
+               return (sizeSS16 st_l0, (st_i0,st_l1,st_p0))
 
        addr (st_i0,st_l0,st_p0) a
           = do let ws = mkLitPtr a
                st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
-               return (sizeSS st_l0, (st_i0,st_l1,st_p0))
+               return (sizeSS16 st_l0, (st_i0,st_l1,st_p0))
 
        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))
+               return (sizeSS16 st_l0, (st_i0,st_l1,st_p0))
 
        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))
+               return (sizeSS16 st_p0, (st_i0,st_l0,st_p1))
 
        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))
+               return (sizeSS16 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 f0ab8cf2e5..7d94d2c72f 100644
--- a/compiler/ghci/ByteCodeLink.lhs
+++ b/compiler/ghci/ByteCodeLink.lhs
@@ -119,15 +119,19 @@ linkBCO' ie ce (UnlinkedBCO nm arity insns_barr bitmap literalsSS ptrsSS)
         let n_literals = sizeSS literalsSS
             n_ptrs     = sizeSS ptrsSS
 
-	ptrs_arr <- mkPtrsArray ie ce n_ptrs ptrs
+        ptrs_arr <- if n_ptrs > 65535
+                    then panic "linkBCO: >= 64k ptrs"
+                    else mkPtrsArray ie ce (fromIntegral n_ptrs) ptrs
 
         let 
             !ptrs_parr = case ptrs_arr of Array _lo _hi _n parr -> parr
 
-            litRange = if n_literals > 0 then (0, n_literals-1)
-                                         else (1, 0)
+            litRange
+             | n_literals > 65535 = panic "linkBCO: >= 64k literals"
+             | n_literals > 0     = (0, fromIntegral n_literals - 1)
+             | otherwise          = (1, 0)
+            literals_arr :: UArray Word16 Word
             literals_arr = listArray litRange linked_literals
-                           :: UArray Word16 Word
             !literals_barr = case literals_arr of UArray _lo _hi _n barr -> barr
 
 	    !(I# arity#)  = arity