import Data.Array.ST ( castSTUArray )
import Foreign
import Data.Char ( ord )
+import Data.List
import GHC.Base ( ByteArray#, MutableByteArray#, RealWorld )
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
= 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)
-- 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)
SizedSeq BCONPtr,
SizedSeq BCOPtr)
-data SizedSeq a = SizedSeq !Int [a]
+data SizedSeq a = SizedSeq !Word16 [a]
emptySS :: SizedSeq a
emptySS = SizedSeq 0 []
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
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
(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
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
-- The size in 16-bit entities of an instruction.
-instrSize16s :: BCInstr -> Int
+instrSize16s :: BCInstr -> Word16
instrSize16s instr
= case instr of
STKCHECK{} -> 2
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
-> BCInstrList
-> Either [AnnAlt Id VarSet] (AnnExpr Id VarSet)
-> Int
- -> Int
+ -> Word16
-> [StgWord]
-> Bool -- True <=> is a return point, rather than a function
-> [BcPtr]
-- (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
-- \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
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
, 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
-- 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
-- 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
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"
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
-- 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
-- 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
-- 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
-- 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
-- -----------------------------------------------------------------------------
-- 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
| 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
| 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...
| 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)
-- 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 = []
-- (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
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
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.
-- 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
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
-- 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
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])
-- 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
= 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
--
return (unitOL (PUSH_G (getName v)), sz)
where
- sz = idSizeW v
+ sz :: Word16
+ sz = fromIntegral (idSizeW v)
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)
(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
= 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
" 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])
-- 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))
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
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])
import Module (Module)
import GHC.Exts
-
+import Data.Word
-- ----------------------------------------------------------------------------
-- Bytecode instructions
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),
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
| 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
| 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
| 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
| 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
= BreakInfo
{ breakInfo_module :: Module
, breakInfo_number :: {-# UNPACK #-} !Int
- , breakInfo_vars :: [(Id,Int)]
+ , breakInfo_vars :: [(Id,Word16)]
, breakInfo_resty :: Type
}
Right rhs -> pprCoreExpr (deAnnotate rhs)
instance Outputable BCInstr where
- ppr (STKCHECK n) = text "STKCHECK" <+> int n
- ppr (PUSH_L offset) = text "PUSH_L " <+> int offset
- ppr (PUSH_LL o1 o2) = text "PUSH_LL " <+> int o1 <+> int o2
- ppr (PUSH_LLL o1 o2 o3) = text "PUSH_LLL" <+> int o1 <+> int o2 <+> int o3
+ ppr (STKCHECK n) = text "STKCHECK" <+> ppr n
+ ppr (PUSH_L offset) = text "PUSH_L " <+> ppr offset
+ ppr (PUSH_LL o1 o2) = text "PUSH_LL " <+> ppr o1 <+> ppr o2
+ ppr (PUSH_LLL o1 o2 o3) = text "PUSH_LLL" <+> ppr o1 <+> ppr o2 <+> ppr o3
ppr (PUSH_G nm) = text "PUSH_G " <+> ppr nm
ppr (PUSH_PRIMOP op) = text "PUSH_G " <+> text "GHC.PrimopWrappers."
<> ppr op
ppr (PUSH_ALTS bco) = text "PUSH_ALTS " <+> ppr bco
ppr (PUSH_ALTS_UNLIFTED bco pk) = text "PUSH_ALTS_UNLIFTED " <+> ppr pk <+> ppr bco
- ppr (PUSH_UBX (Left lit) nw) = text "PUSH_UBX" <+> parens (int nw) <+> ppr lit
- ppr (PUSH_UBX (Right aa) nw) = text "PUSH_UBX" <+> parens (int nw) <+> text (show aa)
+ ppr (PUSH_UBX (Left lit) nw) = text "PUSH_UBX" <+> parens (ppr nw) <+> ppr lit
+ ppr (PUSH_UBX (Right aa) nw) = text "PUSH_UBX" <+> parens (ppr nw) <+> text (show aa)
ppr PUSH_APPLY_N = text "PUSH_APPLY_N"
ppr PUSH_APPLY_V = text "PUSH_APPLY_V"
ppr PUSH_APPLY_F = text "PUSH_APPLY_F"
ppr PUSH_APPLY_PPPPP = text "PUSH_APPLY_PPPPP"
ppr PUSH_APPLY_PPPPPP = text "PUSH_APPLY_PPPPPP"
- ppr (SLIDE n d) = text "SLIDE " <+> int n <+> int d
- ppr (ALLOC_AP sz) = text "ALLOC_AP " <+> int sz
- ppr (ALLOC_AP_NOUPD sz) = text "ALLOC_AP_NOUPD " <+> int sz
- ppr (ALLOC_PAP arity sz) = text "ALLOC_PAP " <+> int arity <+> int sz
- ppr (MKAP offset sz) = text "MKAP " <+> int sz <+> text "words,"
- <+> int offset <+> text "stkoff"
- ppr (MKPAP offset sz) = text "MKPAP " <+> int sz <+> text "words,"
- <+> int offset <+> text "stkoff"
- ppr (UNPACK sz) = text "UNPACK " <+> int sz
+ ppr (SLIDE n d) = text "SLIDE " <+> ppr n <+> ppr d
+ ppr (ALLOC_AP sz) = text "ALLOC_AP " <+> ppr sz
+ ppr (ALLOC_AP_NOUPD sz) = text "ALLOC_AP_NOUPD " <+> ppr sz
+ ppr (ALLOC_PAP arity sz) = text "ALLOC_PAP " <+> ppr arity <+> ppr sz
+ ppr (MKAP offset sz) = text "MKAP " <+> ppr sz <+> text "words,"
+ <+> ppr offset <+> text "stkoff"
+ ppr (MKPAP offset sz) = text "MKPAP " <+> ppr sz <+> text "words,"
+ <+> ppr offset <+> text "stkoff"
+ ppr (UNPACK sz) = text "UNPACK " <+> ppr sz
ppr (PACK dcon sz) = text "PACK " <+> ppr dcon <+> ppr sz
- ppr (LABEL lab) = text "__" <> int lab <> colon
- ppr (TESTLT_I i lab) = text "TESTLT_I" <+> int i <+> text "__" <> int lab
- ppr (TESTEQ_I i lab) = text "TESTEQ_I" <+> int i <+> text "__" <> int lab
- ppr (TESTLT_F f lab) = text "TESTLT_F" <+> float f <+> text "__" <> int lab
- ppr (TESTEQ_F f lab) = text "TESTEQ_F" <+> float f <+> text "__" <> int lab
- ppr (TESTLT_D d lab) = text "TESTLT_D" <+> double d <+> text "__" <> int lab
- ppr (TESTEQ_D d lab) = text "TESTEQ_D" <+> double d <+> text "__" <> int lab
- ppr (TESTLT_P i lab) = text "TESTLT_P" <+> int i <+> text "__" <> int lab
- ppr (TESTEQ_P i lab) = text "TESTEQ_P" <+> int i <+> text "__" <> int lab
+ ppr (LABEL lab) = text "__" <> ppr lab <> colon
+ ppr (TESTLT_I i lab) = text "TESTLT_I" <+> int i <+> text "__" <> ppr lab
+ ppr (TESTEQ_I i lab) = text "TESTEQ_I" <+> int i <+> text "__" <> ppr lab
+ ppr (TESTLT_F f lab) = text "TESTLT_F" <+> float f <+> text "__" <> ppr lab
+ ppr (TESTEQ_F f lab) = text "TESTEQ_F" <+> float f <+> text "__" <> ppr lab
+ ppr (TESTLT_D d lab) = text "TESTLT_D" <+> double d <+> text "__" <> ppr lab
+ ppr (TESTEQ_D d lab) = text "TESTEQ_D" <+> double d <+> text "__" <> ppr lab
+ ppr (TESTLT_P i lab) = text "TESTLT_P" <+> ppr i <+> text "__" <> ppr lab
+ ppr (TESTEQ_P i lab) = text "TESTEQ_P" <+> ppr i <+> text "__" <> ppr lab
ppr CASEFAIL = text "CASEFAIL"
- ppr (JMP lab) = text "JMP" <+> int lab
- ppr (CCALL off marshall_addr) = text "CCALL " <+> int off
+ ppr (JMP lab) = text "JMP" <+> ppr lab
+ ppr (CCALL off marshall_addr) = text "CCALL " <+> ppr off
<+> text "marshall code at"
<+> text (show marshall_addr)
- ppr (SWIZZLE stkoff n) = text "SWIZZLE " <+> text "stkoff" <+> int stkoff
- <+> text "by" <+> int n
+ ppr (SWIZZLE stkoff n) = text "SWIZZLE " <+> text "stkoff" <+> ppr stkoff
+ <+> text "by" <+> ppr n
ppr ENTER = text "ENTER"
ppr RETURN = text "RETURN"
ppr (RETURN_UBX pk) = text "RETURN_UBX " <+> ppr pk
- ppr (BRK_FUN _breakArray index info) = text "BRK_FUN" <+> text "<array>" <+> int index <+> ppr info
+ ppr (BRK_FUN _breakArray index info) = text "BRK_FUN" <+> text "<array>" <+> ppr index <+> ppr info
-- -----------------------------------------------------------------------------
-- The stack use, in words, of each bytecode insn. These _must_ be
-- This could all be made more accurate by keeping track of a proper
-- stack high water mark, but it doesn't seem worth the hassle.
-protoBCOStackUse :: ProtoBCO a -> Int
+protoBCOStackUse :: ProtoBCO a -> Word
protoBCOStackUse bco = sum (map bciStackUse (protoBCOInstrs bco))
-bciStackUse :: BCInstr -> Int
+bciStackUse :: BCInstr -> Word
bciStackUse STKCHECK{} = 0
bciStackUse PUSH_L{} = 1
bciStackUse PUSH_LL{} = 2
bciStackUse PUSH_BCO{} = 1
bciStackUse (PUSH_ALTS bco) = 2 + protoBCOStackUse bco
bciStackUse (PUSH_ALTS_UNLIFTED bco _) = 2 + protoBCOStackUse bco
-bciStackUse (PUSH_UBX _ nw) = nw
+bciStackUse (PUSH_UBX _ nw) = fromIntegral nw
bciStackUse PUSH_APPLY_N{} = 1
bciStackUse PUSH_APPLY_V{} = 1
bciStackUse PUSH_APPLY_F{} = 1
bciStackUse ALLOC_AP{} = 1
bciStackUse ALLOC_AP_NOUPD{} = 1
bciStackUse ALLOC_PAP{} = 1
-bciStackUse (UNPACK sz) = sz
+bciStackUse (UNPACK sz) = fromIntegral sz
bciStackUse LABEL{} = 0
bciStackUse TESTLT_I{} = 0
bciStackUse TESTEQ_I{} = 0
import GHC.IOBase ( IO(..) )
import GHC.Ptr ( Ptr(..), castPtr )
import GHC.Base ( writeArray#, RealWorld, Int(..), Word# )
+
+import Data.Word
\end{code}
!ptrs_parr = case ptrs_arr of Array _lo _hi _n parr -> parr
literals_arr = listArray (0, n_literals-1) linked_literals
- :: UArray Int Word
+ :: UArray Word16 Word
!literals_barr = case literals_arr of UArray _lo _hi _n barr -> barr
!(I# arity#) = arity
-- we recursively link any sub-BCOs while making the ptrs array
-mkPtrsArray :: ItblEnv -> ClosureEnv -> Int -> [BCOPtr] -> IO (Array Int HValue)
+mkPtrsArray :: ItblEnv -> ClosureEnv -> Word16 -> [BCOPtr] -> IO (Array Word16 HValue)
mkPtrsArray ie ce n_ptrs ptrs = do
marr <- newArray_ (0, n_ptrs-1)
let
unsafeWrite (IOArray marr) i e = stToIO (unsafeWrite marr i e)
-- XXX HACK: we should really have a new writeArray# primop that takes a BCO#.
-writeArrayBCO :: IOArray Int a -> Int -> BCO# -> IO ()
+writeArrayBCO :: IOArray Word16 a -> Int -> BCO# -> IO ()
writeArrayBCO (IOArray (STArray _ _ _ marr#)) (I# i#) bco# = IO $ \s# ->
case (unsafeCoerce# writeArray#) marr# i# bco# s# of { s# ->
(# s#, () #) }
-- has been accidentally evaluated, or something else has gone wrong.
-- So that we don't fall over in a heap when this happens, just don't
-- bind any free variables instead, and we emit a warning.
- mb_hValues <- mapM (getIdValFromApStack apStack) offsets
+ mb_hValues <- mapM (getIdValFromApStack apStack) (map fromIntegral offsets)
let filtered_ids = [ id | (id, Just _hv) <- zip ids mb_hValues ]
when (any isNothing mb_hValues) $
debugTraceMsg (hsc_dflags hsc_env) 1 $
instance Outputable Word32 where
ppr n = integer $ fromIntegral n
+instance Outputable Word where
+ ppr n = integer $ fromIntegral n
+
instance Outputable () where
ppr _ = text "()"
projects / ghc-hetmet.git / commitdiff