From b0046dd679244886fdc62e5cc2a73128d2e018bb Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Wed, 29 Jul 2009 13:09:11 +0000 Subject: [PATCH] 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. --- compiler/ghci/ByteCodeAsm.lhs | 75 ++++++++++++------------ compiler/ghci/ByteCodeGen.lhs | 112 ++++++++++++++++++++---------------- compiler/ghci/ByteCodeInstr.lhs | 118 +++++++++++++++++++------------------- compiler/ghci/ByteCodeLink.lhs | 8 ++- compiler/main/InteractiveEval.hs | 2 +- compiler/utils/Outputable.lhs | 3 + 6 files changed, 166 insertions(+), 152 deletions(-) diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs index 968dbaa..1a99096 100644 --- a/compiler/ghci/ByteCodeAsm.lhs +++ b/compiler/ghci/ByteCodeAsm.lhs @@ -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 diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs index 0df09d6..8a4b5e2 100644 --- a/compiler/ghci/ByteCodeGen.lhs +++ b/compiler/ghci/ByteCodeGen.lhs @@ -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]) diff --git a/compiler/ghci/ByteCodeInstr.lhs b/compiler/ghci/ByteCodeInstr.lhs index 84472f2..2082826 100644 --- a/compiler/ghci/ByteCodeInstr.lhs +++ b/compiler/ghci/ByteCodeInstr.lhs @@ -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 = BreakInfo { breakInfo_module :: Module , breakInfo_number :: {-# UNPACK #-} !Int - , breakInfo_vars :: [(Id,Int)] + , breakInfo_vars :: [(Id,Word16)] , breakInfo_resty :: Type } @@ -167,10 +167,10 @@ instance Outputable a => Outputable (ProtoBCO a) where 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 @@ -178,8 +178,8 @@ instance Outputable BCInstr where 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" @@ -192,36 +192,36 @@ instance Outputable BCInstr where 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 "" <+> int index <+> ppr info + ppr (BRK_FUN _breakArray index info) = text "BRK_FUN" <+> text "" <+> ppr index <+> ppr info -- ----------------------------------------------------------------------------- -- The stack use, in words, of each bytecode insn. These _must_ be @@ -233,10 +233,10 @@ instance Outputable BCInstr where -- 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 @@ -246,7 +246,7 @@ bciStackUse PUSH_PRIMOP{} = 1 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 @@ -261,7 +261,7 @@ bciStackUse PUSH_APPLY_PPPPPP{} = 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 diff --git a/compiler/ghci/ByteCodeLink.lhs b/compiler/ghci/ByteCodeLink.lhs index 5e39fde..11d4022 100644 --- a/compiler/ghci/ByteCodeLink.lhs +++ b/compiler/ghci/ByteCodeLink.lhs @@ -50,6 +50,8 @@ import GHC.Arr ( Array(..) ) import GHC.IOBase ( IO(..) ) import GHC.Ptr ( Ptr(..), castPtr ) import GHC.Base ( writeArray#, RealWorld, Int(..), Word# ) + +import Data.Word \end{code} @@ -123,7 +125,7 @@ linkBCO' ie ce (UnlinkedBCO nm arity insns_barr bitmap literalsSS ptrsSS) !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 @@ -132,7 +134,7 @@ linkBCO' ie ce (UnlinkedBCO nm arity insns_barr bitmap literalsSS ptrsSS) -- 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 @@ -165,7 +167,7 @@ instance MArray IOArray e IO where 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#, () #) } diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 33227a8..352fbf0 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -586,7 +586,7 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do -- 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 $ diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index fc5a87e..34ee673 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -501,6 +501,9 @@ instance Outputable Word16 where instance Outputable Word32 where ppr n = integer $ fromIntegral n +instance Outputable Word where + ppr n = integer $ fromIntegral n + instance Outputable () where ppr _ = text "()" -- 1.7.10.4