Commit 6d92f812 authored by Ian Lynagh's avatar Ian Lynagh

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

parent 00d1ec1f
...@@ -150,7 +150,7 @@ assembleBCO (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) ...@@ -150,7 +150,7 @@ assembleBCO (ProtoBCO nm instrs bitmap bsize arity _origin _malloced)
insns_arr insns_arr
| n_insns > 65535 = panic "linkBCO: >= 64k insns in BCO" | 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 !insns_barr = case insns_arr of UArray _lo _hi _n barr -> barr
bitmap_arr = mkBitmapArray bsize bitmap bitmap_arr = mkBitmapArray bsize bitmap
...@@ -181,7 +181,7 @@ type AsmState = (SizedSeq Word16, ...@@ -181,7 +181,7 @@ type AsmState = (SizedSeq Word16,
SizedSeq BCONPtr, SizedSeq BCONPtr,
SizedSeq BCOPtr) SizedSeq BCOPtr)
data SizedSeq a = SizedSeq !Word16 [a] data SizedSeq a = SizedSeq !Word [a]
emptySS :: SizedSeq a emptySS :: SizedSeq a
emptySS = SizedSeq 0 [] emptySS = SizedSeq 0 []
...@@ -195,9 +195,12 @@ addListToSS (SizedSeq n r_xs) xs ...@@ -195,9 +195,12 @@ addListToSS (SizedSeq n r_xs) xs
ssElts :: SizedSeq a -> [a] ssElts :: SizedSeq a -> [a]
ssElts (SizedSeq _ r_xs) = reverse r_xs ssElts (SizedSeq _ r_xs) = reverse r_xs
sizeSS :: SizedSeq a -> Word16 sizeSS :: SizedSeq a -> Word
sizeSS (SizedSeq n _) = n sizeSS (SizedSeq n _) = n
sizeSS16 :: SizedSeq a -> Word16
sizeSS16 (SizedSeq n _) = fromIntegral n
-- Bring in all the bci_ bytecode constants. -- Bring in all the bci_ bytecode constants.
#include "Bytecodes.h" #include "Bytecodes.h"
...@@ -336,39 +339,39 @@ mkBits findLabel st proto_insns ...@@ -336,39 +339,39 @@ mkBits findLabel st proto_insns
float (st_i0,st_l0,st_p0) f float (st_i0,st_l0,st_p0) f
= do let ws = mkLitF f = do let ws = mkLitF f
st_l1 <- addListToSS st_l0 (map BCONPtrWord ws) 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 double (st_i0,st_l0,st_p0) d
= do let ws = mkLitD d = do let ws = mkLitD d
st_l1 <- addListToSS st_l0 (map BCONPtrWord ws) 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 int (st_i0,st_l0,st_p0) i
= do let ws = mkLitI i = do let ws = mkLitI i
st_l1 <- addListToSS st_l0 (map BCONPtrWord ws) 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 int64 (st_i0,st_l0,st_p0) i
= do let ws = mkLitI64 i = do let ws = mkLitI64 i
st_l1 <- addListToSS st_l0 (map BCONPtrWord ws) 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 addr (st_i0,st_l0,st_p0) a
= do let ws = mkLitPtr a = do let ws = mkLitPtr a
st_l1 <- addListToSS st_l0 (map BCONPtrWord ws) 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 litlabel (st_i0,st_l0,st_p0) fs
= do st_l1 <- addListToSS st_l0 [BCONPtrLbl 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 ptr (st_i0,st_l0,st_p0) p
= do st_p1 <- addToSS 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 itbl (st_i0,st_l0,st_p0) dcon
= do st_l1 <- addToSS st_l0 (BCONPtrItbl (getName 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 #ifdef mingw32_TARGET_OS
literal st (MachLabel fs (Just sz) _) literal st (MachLabel fs (Just sz) _)
......
...@@ -119,15 +119,19 @@ linkBCO' ie ce (UnlinkedBCO nm arity insns_barr bitmap literalsSS ptrsSS) ...@@ -119,15 +119,19 @@ linkBCO' ie ce (UnlinkedBCO nm arity insns_barr bitmap literalsSS ptrsSS)
let n_literals = sizeSS literalsSS let n_literals = sizeSS literalsSS
n_ptrs = sizeSS ptrsSS 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 let
!ptrs_parr = case ptrs_arr of Array _lo _hi _n parr -> parr !ptrs_parr = case ptrs_arr of Array _lo _hi _n parr -> parr
litRange = if n_literals > 0 then (0, n_literals-1) litRange
else (1, 0) | 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 literals_arr = listArray litRange linked_literals
:: UArray Word16 Word
!literals_barr = case literals_arr of UArray _lo _hi _n barr -> barr !literals_barr = case literals_arr of UArray _lo _hi _n barr -> barr
!(I# arity#) = arity !(I# arity#) = arity
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment