From 6d92f8127b85a52a472b692c6fa40320432dd5a5 Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Sat, 1 Aug 2009 13:00:14 +0000 Subject: [PATCH] Fix the 64k insns overflow check in ghci, and add more checks --- compiler/ghci/ByteCodeAsm.lhs | 25 ++++++++++++++----------- compiler/ghci/ByteCodeLink.lhs | 12 ++++++++---- 2 files changed, 22 insertions(+), 15 deletions(-) diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs index 5980810..f690aa6 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 f0ab8cf..7d94d2c 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 -- 1.7.10.4