diff options
| -rw-r--r-- | compiler/ghci/ByteCodeAsm.lhs | 75 | ||||
| -rw-r--r-- | compiler/ghci/ByteCodeGen.lhs | 112 | ||||
| -rw-r--r-- | compiler/ghci/ByteCodeInstr.lhs | 118 | ||||
| -rw-r--r-- | compiler/ghci/ByteCodeLink.lhs | 8 | ||||
| -rw-r--r-- | compiler/main/InteractiveEval.hs | 2 | ||||
| -rw-r--r-- | 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 968dbaaabd..1a99096a9b 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 0df09d63d3..8a4b5e29a9 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 84472f24ac..20828266fb 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 "<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 @@ -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 5e39fdef10..11d4022196 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 33227a8cd8..352fbf055f 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 fc5a87ee29..34ee673ad1 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 "()" |