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)
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) _)
......
......@@ -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
......
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