Skip to content

GitLab

GHC
GHC
Commit b0046dd6 authored by Ian Lynagh's avatar Ian Lynagh
Browse files
Options

Make the types we use when creating GHCi bytecode better match reality 

We were keeping things as Int, and then converting them to Word16 at
the last minute, when really they ought to have been Word16 all along.
parent f6648348
Hide whitespace changes
Inline Side-by-side
Showing with 166 additions and 152 deletions
compiler/ghci/ByteCodeAsm.lhs
View file @ b0046dd6
......@@ -41,6 +41,7 @@ import Data.Array.Base ( UArray(..) )
import Data.Array.ST ( castSTUArray )
import Foreign
import Data.Char ( ord )
import Data.List
import GHC.Base ( ByteArray#, MutableByteArray#, RealWorld )
......@@ -96,8 +97,8 @@ bcoFreeNames bco
instance Outputable UnlinkedBCO where
ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs)
= sep [text "BCO", ppr nm, text "with",
int (sizeSS lits), text "lits",
int (sizeSS ptrs), text "ptrs" ]
ppr (sizeSS lits), text "lits",
ppr (sizeSS ptrs), text "ptrs" ]
-- -----------------------------------------------------------------------------
-- The bytecode assembler
......@@ -130,10 +131,11 @@ assembleBCO (ProtoBCO nm instrs bitmap bsize arity _origin _malloced)
= case i of LABEL n -> addToFM env n i_offset ; _ -> env
in mkLabelEnv new_env (i_offset + instrSize16s i) is
findLabel :: Word16 -> Word16
findLabel lab
= case lookupFM label_env lab of
Just bco_offset -> bco_offset
Nothing -> pprPanic "assembleBCO.findLabel" (int lab)
Nothing -> pprPanic "assembleBCO.findLabel" (ppr lab)
in
do -- pass 2: generate the instruction, ptr and nonptr bits
insns <- return emptySS :: IO (SizedSeq Word16)
......@@ -166,11 +168,11 @@ assembleBCO (ProtoBCO nm instrs bitmap bsize arity _origin _malloced)
-- zonk ptr = do -- putStrLn ("freeing malloc'd block at " ++ show (A# a#))
-- free ptr
mkBitmapArray :: Int -> [StgWord] -> UArray Int StgWord
mkBitmapArray :: Word16 -> [StgWord] -> UArray Int StgWord
mkBitmapArray bsize bitmap
= listArray (0, length bitmap) (fromIntegral bsize : bitmap)
mkInstrArray :: Int -> [Word16] -> UArray Int Word16
mkInstrArray :: Word16 -> [Word16] -> UArray Word16 Word16
mkInstrArray n_insns asm_insns
= listArray (0, n_insns) (fromIntegral n_insns : asm_insns)
......@@ -179,7 +181,7 @@ type AsmState = (SizedSeq Word16,
SizedSeq BCONPtr,
SizedSeq BCOPtr)
data SizedSeq a = SizedSeq !Int [a]
data SizedSeq a = SizedSeq !Word16 [a]
emptySS :: SizedSeq a
emptySS = SizedSeq 0 []
......@@ -188,34 +190,34 @@ addToSS :: SizedSeq a -> a -> IO (SizedSeq a)
addToSS (SizedSeq n r_xs) x = return (SizedSeq (n+1) (x:r_xs))
addListToSS :: SizedSeq a -> [a] -> IO (SizedSeq a)
addListToSS (SizedSeq n r_xs) xs
= return (SizedSeq (n + length xs) (reverse xs ++ r_xs))
= return (SizedSeq (n + genericLength xs) (reverse xs ++ r_xs))
ssElts :: SizedSeq a -> [a]
ssElts (SizedSeq _ r_xs) = reverse r_xs
sizeSS :: SizedSeq a -> Int
sizeSS :: SizedSeq a -> Word16
sizeSS (SizedSeq n _) = n
-- Bring in all the bci_ bytecode constants.
#include "Bytecodes.h"
largeArgInstr :: Int -> Int
largeArgInstr :: Word16 -> Word16
largeArgInstr bci = bci_FLAG_LARGE_ARGS .|. bci
largeArg :: Int -> [Int]
largeArg i
largeArg :: Word -> [Word16]
largeArg w
| wORD_SIZE_IN_BITS == 64
= [(i .&. 0xFFFF000000000000) `shiftR` 48,
(i .&. 0x0000FFFF00000000) `shiftR` 32,
(i .&. 0x00000000FFFF0000) `shiftR` 16,
(i .&. 0x000000000000FFFF)]
= [fromIntegral (w `shiftR` 48),
fromIntegral (w `shiftR` 32),
fromIntegral (w `shiftR` 16),
fromIntegral w]
| wORD_SIZE_IN_BITS == 32
= [(i .&. 0xFFFF0000) `shiftR` 16,
(i .&. 0x0000FFFF)]
= [fromIntegral (w `shiftR` 16),
fromIntegral w]
| 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
mkBits :: (Word16 -> Word16) -- label finder
-> AsmState
-> [BCInstr] -- instructions (in)
-> IO AsmState
......@@ -229,7 +231,7 @@ mkBits findLabel st proto_insns
STKCHECK n
| n > 65535 ->
instrn st (largeArgInstr bci_STKCHECK : largeArg n)
| otherwise -> instr2 st bci_STKCHECK n
| otherwise -> instr2 st bci_STKCHECK (fromIntegral 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
......@@ -303,35 +305,32 @@ mkBits findLabel st proto_insns
(p2, st3) <- ptr st2 (BCOPtrBreakInfo info)
instr4 st3 bci_BRK_FUN p1 index p2
i2s :: Int -> Word16
i2s = fromIntegral
instrn :: AsmState -> [Int] -> IO AsmState
instrn :: AsmState -> [Word16] -> IO AsmState
instrn st [] = return st
instrn (st_i, st_l, st_p) (i:is)
= do st_i' <- addToSS st_i (i2s i)
= do st_i' <- addToSS st_i i
instrn (st_i', st_l, st_p) is
instr1 (st_i0,st_l0,st_p0) i1
= do st_i1 <- addToSS st_i0 i1
return (st_i1,st_l0,st_p0)
instr2 (st_i0,st_l0,st_p0) i1 i2
= do st_i1 <- addToSS st_i0 (i2s i1)
st_i2 <- addToSS st_i1 (i2s i2)
instr2 (st_i0,st_l0,st_p0) w1 w2
= do st_i1 <- addToSS st_i0 w1
st_i2 <- addToSS st_i1 w2
return (st_i2,st_l0,st_p0)
instr3 (st_i0,st_l0,st_p0) i1 i2 i3
= do st_i1 <- addToSS st_i0 (i2s i1)
st_i2 <- addToSS st_i1 (i2s i2)
st_i3 <- addToSS st_i2 (i2s i3)
instr3 (st_i0,st_l0,st_p0) w1 w2 w3
= do st_i1 <- addToSS st_i0 w1
st_i2 <- addToSS st_i1 w2
st_i3 <- addToSS st_i2 w3
return (st_i3,st_l0,st_p0)
instr4 (st_i0,st_l0,st_p0) i1 i2 i3 i4
= do st_i1 <- addToSS st_i0 (i2s i1)
st_i2 <- addToSS st_i1 (i2s i2)
st_i3 <- addToSS st_i2 (i2s i3)
st_i4 <- addToSS st_i3 (i2s i4)
instr4 (st_i0,st_l0,st_p0) w1 w2 w3 w4
= do st_i1 <- addToSS st_i0 w1
st_i2 <- addToSS st_i1 w2
st_i3 <- addToSS st_i2 w3
st_i4 <- addToSS st_i3 w4
return (st_i4,st_l0,st_p0)
float (st_i0,st_l0,st_p0) f
......@@ -389,7 +388,7 @@ mkBits findLabel st proto_insns
literal _ other = pprPanic "ByteCodeAsm.literal" (ppr other)
push_alts :: CgRep -> Int
push_alts :: CgRep -> Word16
push_alts NonPtrArg = bci_PUSH_ALTS_N
push_alts FloatArg = bci_PUSH_ALTS_F
push_alts DoubleArg = bci_PUSH_ALTS_D
......@@ -407,7 +406,7 @@ return_ubx PtrArg = bci_RETURN_P
-- The size in 16-bit entities of an instruction.
instrSize16s :: BCInstr -> Int
instrSize16s :: BCInstr -> Word16
instrSize16s instr
= case instr of
STKCHECK{} -> 2
......
compiler/ghci/ByteCodeGen.lhs
View file @ b0046dd6
......@@ -123,11 +123,11 @@ coreExprToBCOs dflags expr
type BCInstrList = OrdList BCInstr
type Sequel = Int -- back off to this depth before ENTER
type Sequel = Word16 -- back off to this depth before ENTER
-- Maps Ids to the offset from the stack _base_ so we don't have
-- to mess with it after each push/pop.
type BCEnv = FiniteMap Id Int -- To find vars on the stack
type BCEnv = FiniteMap Id Word16 -- To find vars on the stack
{-
ppBCEnv :: BCEnv -> SDoc
......@@ -147,7 +147,7 @@ mkProtoBCO
-> BCInstrList
-> Either [AnnAlt Id VarSet] (AnnExpr Id VarSet)
-> Int
-> Int
-> Word16
-> [StgWord]
-> Bool -- True <=> is a return point, rather than a function
-> [BcPtr]
......@@ -171,13 +171,13 @@ mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_bloc
-- (hopefully rare) cases when the (overestimated) stack use
-- exceeds iNTERP_STACK_CHECK_THRESH.
maybe_with_stack_check
| is_ret && stack_usage < aP_STACK_SPLIM = peep_d
| is_ret && stack_usage < fromIntegral aP_STACK_SPLIM = peep_d
-- don't do stack checks at return points,
-- everything is aggregated up to the top BCO
-- (which must be a function).
-- That is, unless the stack usage is >= AP_STACK_SPLIM,
-- see bug #1466.
| stack_usage >= iNTERP_STACK_CHECK_THRESH
| stack_usage >= fromIntegral iNTERP_STACK_CHECK_THRESH
= STKCHECK stack_usage : peep_d
| otherwise
= peep_d -- the supposedly common case
......@@ -275,13 +275,13 @@ schemeR_wrk fvs nm original_body (args, body)
-- \fv1..fvn x1..xn -> e
-- i.e. the fvs come first
szsw_args = map idSizeW all_args
szsw_args = map (fromIntegral . idSizeW) all_args
szw_args = sum szsw_args
p_init = listToFM (zip all_args (mkStackOffsets 0 szsw_args))
-- make the arg bitmap
bits = argBits (reverse (map idCgRep all_args))
bitmap_size = length bits
bitmap_size = genericLength bits
bitmap = mkBitmap bits
in do
body_code <- schemeER_wrk szw_args p_init body
......@@ -290,12 +290,12 @@ schemeR_wrk fvs nm original_body (args, body)
arity bitmap_size bitmap False{-not alts-})
-- introduce break instructions for ticked expressions
schemeER_wrk :: Int -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList
schemeER_wrk :: Word16 -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList
schemeER_wrk d p rhs
| Just (tickInfo, (_annot, newRhs)) <- isTickedExp' rhs = do
code <- schemeE d 0 p newRhs
arr <- getBreakArray
let idOffSets = getVarOffSets d p tickInfo
let idOffSets = getVarOffSets (fromIntegral d) p tickInfo
let tickNumber = tickInfo_number tickInfo
let breakInfo = BreakInfo
{ breakInfo_module = tickInfo_module tickInfo
......@@ -303,14 +303,16 @@ schemeER_wrk d p rhs
, breakInfo_vars = idOffSets
, breakInfo_resty = exprType (deAnnotate' newRhs)
}
let breakInstr = case arr of (BA arr#) -> BRK_FUN arr# tickNumber breakInfo
let breakInstr = case arr of
BA arr# ->
BRK_FUN arr# (fromIntegral tickNumber) breakInfo
return $ breakInstr `consOL` code
| otherwise = schemeE d 0 p rhs
getVarOffSets :: Int -> BCEnv -> TickInfo -> [(Id, Int)]
getVarOffSets :: Word16 -> BCEnv -> TickInfo -> [(Id, Word16)]
getVarOffSets d p = catMaybes . map (getOffSet d p) . tickInfo_locals
getOffSet :: Int -> BCEnv -> Id -> Maybe (Id, Int)
getOffSet :: Word16 -> BCEnv -> Id -> Maybe (Id, Word16)
getOffSet d env id
= case lookupBCEnv_maybe env id of
Nothing -> Nothing
......@@ -346,7 +348,7 @@ instance Outputable TickInfo where
-- Compile code to apply the given expression to the remaining args
-- on the stack, returning a HNF.
schemeE :: Int -> Sequel -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList
schemeE :: Word16 -> Sequel -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList
schemeE d s p e
| Just e' <- bcView e
......@@ -366,7 +368,7 @@ schemeE d s p e@(AnnVar v)
-- Heave it on the stack, SLIDE, and RETURN.
(push, szw) <- pushAtom d p (AnnVar v)
return (push -- value onto stack
`appOL` mkSLIDE szw (d-s) -- clear to sequel
`appOL` mkSLIDE szw (d-s) -- clear to sequel
`snocOL` RETURN_UBX v_rep) -- go
where
v_type = idType v
......@@ -395,21 +397,21 @@ schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))
schemeE d s p (AnnLet binds (_,body))
= let (xs,rhss) = case binds of AnnNonRec x rhs -> ([x],[rhs])
AnnRec xs_n_rhss -> unzip xs_n_rhss
n_binds = length xs
n_binds = genericLength xs
fvss = map (fvsToEnv p' . fst) rhss
-- Sizes of free vars
sizes = map (\rhs_fvs -> sum (map idSizeW rhs_fvs)) fvss
sizes = map (\rhs_fvs -> sum (map (fromIntegral . idSizeW) rhs_fvs)) fvss
-- the arity of each rhs
arities = map (length . fst . collect) rhss
arities = map (genericLength . fst . collect) rhss
-- This p', d' defn is safe because all the items being pushed
-- are ptrs, so all have size 1. d' and p' reflect the stack
-- after the closures have been allocated in the heap (but not
-- filled in), and pointers to them parked on the stack.
p' = addListToFM p (zipE xs (mkStackOffsets d (nOfThem n_binds 1)))
p' = addListToFM p (zipE xs (mkStackOffsets d (genericReplicate n_binds 1)))
d' = d + n_binds
zipE = zipEqual "schemeE"
......@@ -436,7 +438,7 @@ schemeE d s p (AnnLet binds (_,body))
compile_bind d' fvs x rhs size arity off = do
bco <- schemeR fvs (x,rhs)
build_thunk d' fvs size bco off arity
build_thunk (fromIntegral d') fvs size bco off arity
compile_binds =
[ compile_bind d' fvs x rhs size arity n
......@@ -584,7 +586,7 @@ isTickedExp' _ = Nothing
-- 4. Otherwise, it must be a function call. Push the args
-- right to left, SLIDE and ENTER.
schemeT :: Int -- Stack depth
schemeT :: Word16 -- Stack depth
-> Sequel -- Sequel depth
-> BCEnv -- stack env
-> AnnExpr' Id VarSet
......@@ -667,7 +669,7 @@ schemeT d s p app
-- Generate code to build a constructor application,
-- leaving it on top of the stack
mkConAppCode :: Int -> Sequel -> BCEnv
mkConAppCode :: Word16 -> Sequel -> BCEnv
-> DataCon -- The data constructor
-> [AnnExpr' Id VarSet] -- Args, in *reverse* order
-> BcM BCInstrList
......@@ -704,7 +706,7 @@ mkConAppCode orig_d _ p con args_r_to_l
-- returned, even if it is a pointed type. We always just return.
unboxedTupleReturn
:: Int -> Sequel -> BCEnv
:: Word16 -> Sequel -> BCEnv
-> AnnExpr' Id VarSet -> BcM BCInstrList
unboxedTupleReturn d s p arg = do
(push, sz) <- pushAtom d p arg
......@@ -716,7 +718,7 @@ unboxedTupleReturn d s p arg = do
-- Generate code for a tail-call
doTailCall
:: Int -> Sequel -> BCEnv
:: Word16 -> Sequel -> BCEnv
-> Id -> [AnnExpr' Id VarSet]
-> BcM BCInstrList
doTailCall init_d s p fn args
......@@ -773,7 +775,7 @@ findPushSeq _
-- -----------------------------------------------------------------------------
-- Case expressions
doCase :: Int -> Sequel -> BCEnv
doCase :: Word16 -> Sequel -> BCEnv
-> AnnExpr Id VarSet -> Id -> [AnnAlt Id VarSet]
-> Bool -- True <=> is an unboxed tuple case, don't enter the result
-> BcM BCInstrList
......@@ -791,7 +793,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
| otherwise = 1
-- depth of stack after the return value has been pushed
d_bndr = d + ret_frame_sizeW + idSizeW bndr
d_bndr = d + ret_frame_sizeW + fromIntegral (idSizeW bndr)
-- depth of stack after the extra info table for an unboxed return
-- has been pushed, if any. This is the stack depth at the
......@@ -819,8 +821,8 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
| otherwise =
let
(ptrs,nptrs) = partition (isFollowableArg.idCgRep) real_bndrs
ptr_sizes = map idSizeW ptrs
nptrs_sizes = map idSizeW nptrs
ptr_sizes = map (fromIntegral . idSizeW) ptrs
nptrs_sizes = map (fromIntegral . idSizeW) nptrs
bind_sizes = ptr_sizes ++ nptrs_sizes
size = sum ptr_sizes + sum nptrs_sizes
-- the UNPACK instruction unpacks in reverse order...
......@@ -839,7 +841,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
| isUnboxedTupleCon dc
= unboxedTupleException
| otherwise
= DiscrP (dataConTag dc - fIRST_TAG)
= DiscrP (fromIntegral (dataConTag dc - fIRST_TAG))
my_discr (LitAlt l, _, _)
= case l of MachInt i -> DiscrI (fromInteger i)
MachFloat r -> DiscrF (fromRational r)
......@@ -869,11 +871,13 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
-- case-of-case expressions, which is the only time we can be compiling a
-- case expression with s /= 0.
bitmap_size = d-s
bitmap = intsToReverseBitmap bitmap_size{-size-}
(sortLe (<=) (filter (< bitmap_size) rel_slots))
bitmap_size' :: Int
bitmap_size' = fromIntegral bitmap_size
bitmap = intsToReverseBitmap bitmap_size'{-size-}
(sortLe (<=) (filter (< bitmap_size') rel_slots))
where
binds = fmToList p
rel_slots = concat (map spread binds)
rel_slots = map fromIntegral $ concat (map spread binds)
spread (id, offset)
| isFollowableArg (idCgRep id) = [ rel_offset ]
| otherwise = []
......@@ -907,7 +911,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
-- (machine) code for the ccall, and create bytecodes to call that and
-- then return in the right way.
generateCCall :: Int -> Sequel -- stack and sequel depths
generateCCall :: Word16 -> Sequel -- stack and sequel depths
-> BCEnv
-> CCallSpec -- where to call
-> Id -- of target, for type info
......@@ -917,7 +921,8 @@ generateCCall :: Int -> Sequel -- stack and sequel depths
generateCCall d0 s p (CCallSpec target cconv _) fn args_r_to_l
= let
-- useful constants
addr_sizeW = cgRepSizeW NonPtrArg
addr_sizeW :: Word16
addr_sizeW = fromIntegral (cgRepSizeW NonPtrArg)
-- Get the args on the stack, with tags and suitably
-- dereferenced for the CCall. For each arg, return the
......@@ -934,12 +939,12 @@ generateCCall d0 s p (CCallSpec target cconv _) fn args_r_to_l
Just (t, _)
| t == arrayPrimTyCon || t == mutableArrayPrimTyCon
-> do rest <- pargs (d + addr_sizeW) az
code <- parg_ArrayishRep arrPtrsHdrSize d p a
code <- parg_ArrayishRep (fromIntegral arrPtrsHdrSize) d p a
return ((code,AddrRep):rest)
| t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon
-> do rest <- pargs (d + addr_sizeW) az
code <- parg_ArrayishRep arrWordsHdrSize d p a
code <- parg_ArrayishRep (fromIntegral arrWordsHdrSize) d p a
return ((code,AddrRep):rest)
-- Default case: push taggedly, but otherwise intact.
......@@ -951,6 +956,8 @@ generateCCall d0 s p (CCallSpec target cconv _) fn args_r_to_l
-- Do magic for Ptr/Byte arrays. Push a ptr to the array on
-- the stack but then advance it over the headers, so as to
-- point to the payload.
parg_ArrayishRep :: Word16 -> Word16 -> BCEnv -> AnnExpr' Id VarSet
-> BcM BCInstrList
parg_ArrayishRep hdrSize d p a
= do (push_fo, _) <- pushAtom d p a
-- The ptr points at the header. Advance it over the
......@@ -961,7 +968,7 @@ generateCCall d0 s p (CCallSpec target cconv _) fn args_r_to_l
code_n_reps <- pargs d0 args_r_to_l
let
(pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps
a_reps_sizeW = sum (map primRepSizeW a_reps_pushed_r_to_l)
a_reps_sizeW = fromIntegral (sum (map primRepSizeW a_reps_pushed_r_to_l))
push_args = concatOL pushs_arg
d_after_args = d0 + a_reps_sizeW
......@@ -1054,7 +1061,7 @@ generateCCall d0 s p (CCallSpec target cconv _) fn args_r_to_l
-- Push the return placeholder. For a call returning nothing,
-- this is a VoidArg (tag).
r_sizeW = primRepSizeW r_rep
r_sizeW = fromIntegral (primRepSizeW r_rep)
d_after_r = d_after_Addr + r_sizeW
r_lit = mkDummyLiteral r_rep
push_r = (if returns_void
......@@ -1149,7 +1156,7 @@ maybe_getCCallReturnRep fn_ty
implement_tagToId :: [Name] -> BcM BCInstrList
implement_tagToId names
= ASSERT( notNull names )
do labels <- getLabelsBc (length names)
do labels <- getLabelsBc (genericLength names)
label_fail <- getLabelBc
label_exit <- getLabelBc
let infos = zip4 labels (tail labels ++ [label_fail])
......@@ -1179,7 +1186,7 @@ implement_tagToId names
-- to 5 and not to 4. Stack locations are numbered from zero, so a
-- depth 6 stack has valid words 0 .. 5.
pushAtom :: Int -> BCEnv -> AnnExpr' Id VarSet -> BcM (BCInstrList, Int)
pushAtom :: Word16 -> BCEnv -> AnnExpr' Id VarSet -> BcM (BCInstrList, Word16)
pushAtom d p e
| Just e' <- bcView e
......@@ -1196,7 +1203,8 @@ pushAtom d p (AnnVar v)
= return (unitOL (PUSH_PRIMOP primop), 1)
| Just d_v <- lookupBCEnv_maybe p v -- v is a local variable
= return (toOL (nOfThem sz (PUSH_L (d-d_v+sz-2))), sz)
= let l = d - fromIntegral d_v + sz - 2
in return (toOL (genericReplicate sz (PUSH_L l)), sz)
-- d - d_v the number of words between the TOS
-- and the 1st slot of the object
--
......@@ -1213,7 +1221,8 @@ pushAtom d p (AnnVar v)
return (unitOL (PUSH_G (getName v)), sz)
where
sz = idSizeW v
sz :: Word16
sz = fromIntegral (idSizeW v)
pushAtom _ _ (AnnLit lit)
......@@ -1229,7 +1238,7 @@ pushAtom _ _ (AnnLit lit)
l -> pprPanic "pushAtom" (ppr l)
where
code rep
= let size_host_words = cgRepSizeW rep
= let size_host_words = fromIntegral (cgRepSizeW rep)
in return (unitOL (PUSH_UBX (Left lit) size_host_words),
size_host_words)
......@@ -1342,7 +1351,8 @@ mkMultiBranch maybe_ncons raw_ways
(algMinBound, algMaxBound)
= case maybe_ncons of
Just n -> (0, n - 1)
-- XXX What happens when n == 0?
Just n -> (0, fromIntegral n - 1)
Nothing -> (minBound, maxBound)
(DiscrI i1) `eqAlt` (DiscrI i2) = i1 == i2
......@@ -1386,18 +1396,18 @@ data Discr
= DiscrI Int
| DiscrF Float
| DiscrD Double
| DiscrP Int
| DiscrP Word16
| NoDiscr
instance Outputable Discr where
ppr (DiscrI i) = int i
ppr (DiscrF f) = text (show f)
ppr (DiscrD d) = text (show d)
ppr (DiscrP i) = int i
ppr (DiscrP i) = ppr i
ppr NoDiscr = text "DEF"
lookupBCEnv_maybe :: BCEnv -> Id -> Maybe Int
lookupBCEnv_maybe :: BCEnv -> Id -> Maybe Word16
lookupBCEnv_maybe = lookupFM
idSizeW :: Id -> Int
......@@ -1413,7 +1423,7 @@ unboxedTupleException
" Workaround: use -fobject-code, or compile this module to .o separately."))
mkSLIDE :: Int -> Int -> OrdList BCInstr
mkSLIDE :: Word16 -> Word16 -> OrdList BCInstr
mkSLIDE n d = if d == 0 then nilOL else unitOL (SLIDE n d)
splitApp :: AnnExpr' Var ann -> (AnnExpr' Var ann, [AnnExpr' Var ann])
......@@ -1458,7 +1468,7 @@ isPtrAtom e = atomRep e == PtrArg
-- Let szsw be the sizes in words of some items pushed onto the stack,
-- which has initial depth d'. Return the values which the stack environment
-- should map these items to.
mkStackOffsets :: Int -> [Int] -> [Int]
mkStackOffsets :: Word16 -> [Word16] -> [Word16]
mkStackOffsets original_depth szsw
= map (subtract 1) (tail (scanl (+) original_depth szsw))
......@@ -1470,7 +1480,7 @@ type BcPtr = Either ItblPtr (Ptr ())
data BcM_State
= BcM_State {
uniqSupply :: UniqSupply, -- for generating fresh variable names
nextlabel :: Int, -- for generating local labels
nextlabel :: Word16, -- for generating local labels
malloced :: [BcPtr], -- thunks malloced for current BCO
-- Should be free()d when it is GCd
breakArray :: BreakArray -- array of breakpoint flags
......@@ -1522,11 +1532,11 @@ recordItblMallocBc :: ItblPtr -> BcM ()
recordItblMallocBc a
= BcM $ \st -> return (st{malloced = Left a : malloced st}, ())
getLabelBc :: BcM Int
getLabelBc :: BcM Word16
getLabelBc
= BcM $ \st -> return (st{nextlabel = 1 + nextlabel st}, nextlabel st)
getLabelsBc :: Int -> BcM [Int]
getLabelsBc :: Word16 -> BcM [Word16]
getLabelsBc n
= BcM $ \st -> let ctr = nextlabel st
in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1])
......
compiler/ghci/ByteCodeInstr.lhs
View file @ b0046dd6
......@@ -29,7 +29,7 @@ import SMRep
import Module (Module)
import GHC.Exts
import Data.Word
-- ----------------------------------------------------------------------------
-- Bytecode instructions
......@@ -40,7 +40,7 @@ data ProtoBCO a
protoBCOInstrs :: [BCInstr], -- instrs
-- arity and GC info
protoBCOBitmap :: [StgWord],
protoBCOBitmapSize :: Int,
protoBCOBitmapSize :: Word16,
protoBCOArity :: Int,
-- what the BCO came from
protoBCOExpr :: Either [AnnAlt Id VarSet] (AnnExpr Id VarSet),
......@@ -48,16 +48,16 @@ data ProtoBCO a
protoBCOPtrs :: [Either ItblPtr (Ptr ())]
}
type LocalLabel = Int
type LocalLabel = Word16
data BCInstr
-- Messing with the stack
= STKCHECK Int
= STKCHECK Word
-- Push locals (existing bits of the stack)
| PUSH_L !Int{-offset-}
| PUSH_LL !Int !Int{-2 offsets-}
| PUSH_LLL !Int !Int !Int{-3 offsets-}
| PUSH_L !Word16{-offset-}
| PUSH_LL !Word16 !Word16{-2 offsets-}
| PUSH_LLL !Word16 !Word16 !Word16{-3 offsets-}
-- Push a ptr (these all map to PUSH_G really)
| PUSH_G Name
......@@ -69,8 +69,8 @@ data BCInstr
| PUSH_ALTS_UNLIFTED (ProtoBCO Name) CgRep
-- Pushing literals
| PUSH_UBX (Either Literal (Ptr ())) Int
-- push this int/float/double/addr, on the stack. Int
| PUSH_UBX (Either Literal (Ptr ())) Word16
-- push this int/float/double/addr, on the stack. Word16
-- is # of words to copy from literal pool. Eitherness reflects
-- the difficulty of dealing with MachAddr here, mostly due to
-- the excessive (and unnecessary) restrictions imposed by the
......@@ -92,16 +92,16 @@ data BCInstr
| PUSH_APPLY_PPPPP
| PUSH_APPLY_PPPPPP
| SLIDE Int{-this many-} Int{-down by this much-}
| SLIDE Word16{-this many-} Word16{-down by this much-}
-- To do with the heap
| ALLOC_AP !Int -- make an AP with this many payload words
| ALLOC_AP_NOUPD !Int -- make an AP_NOUPD with this many payload words
| ALLOC_PAP !Int !Int -- make a PAP with this arity / payload words
| MKAP !Int{-ptr to AP is this far down stack-} !Int{-number of words-}
| MKPAP !Int{-ptr to PAP is this far down stack-} !Int{-number of words-}
| UNPACK !Int -- unpack N words from t.o.s Constr
| PACK DataCon !Int
| ALLOC_AP !Word16 -- make an AP with this many payload words
| ALLOC_AP_NOUPD !Word16 -- make an AP_NOUPD with this many payload words
| ALLOC_PAP !Word16 !Word16 -- make a PAP with this arity / payload words
| MKAP !Word16{-ptr to AP is this far down stack-} !Word16{-number of words-}
| MKPAP !Word16{-ptr to PAP is this far down stack-} !Word16{-number of words-}
| UNPACK !Word16 -- unpack N words from t.o.s Constr
| PACK DataCon !Word16
-- after assembly, the DataCon is an index into the
-- itbl array
-- For doing case trees
......@@ -113,22 +113,22 @@ data BCInstr
| TESTLT_D Double LocalLabel
| TESTEQ_D Double LocalLabel
-- The Int value is a constructor number and therefore
-- The Word16 value is a constructor number and therefore
-- stored in the insn stream rather than as an offset into
-- the literal pool.
| TESTLT_P Int LocalLabel
| TESTEQ_P Int LocalLabel
| TESTLT_P Word16 LocalLabel
| TESTEQ_P Word16 LocalLabel
| CASEFAIL
| JMP LocalLabel
-- For doing calls to C (via glue code generated by ByteCodeFFI, or libffi)
| CCALL Int -- stack frame size
(Ptr ()) -- addr of the glue code
| CCALL Word16 -- stack frame size
(Ptr ()) -- addr of the glue code
-- For doing magic ByteArray passing to foreign calls
| SWIZZLE Int -- to the ptr N words down the stack,
Int -- add M (interpreted as a signed 16-bit entity)
| SWIZZLE Word16 -- to the ptr N words down the stack,
Word16 -- add M (interpreted as a signed 16-bit entity)
-- To Infinity And Beyond
| ENTER
......@@ -136,13 +136,13 @@ data BCInstr
| RETURN_UBX CgRep -- return an unlifted value, here's its rep
-- Breakpoints
| BRK_FUN (MutableByteArray# RealWorld) Int BreakInfo
| BRK_FUN (MutableByteArray# RealWorld) Word16 BreakInfo
data BreakInfo