X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fghci%2FByteCodeGen.lhs;h=5d1bd27ca8a9054ca3be670d3d63d7e05ae85407;hp=95aae77671a03aa8d946d07daa2b453951882c43;hb=6e9c0431a7cf2bf1a48f01db48c6a1d41fe15a09;hpb=497302c44ad08c6c27d0e15d94a787f332c0cfec diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs index 95aae77..5d1bd27 100644 --- a/compiler/ghci/ByteCodeGen.lhs +++ b/compiler/ghci/ByteCodeGen.lhs @@ -17,6 +17,7 @@ import LibFFI import Outputable import Name +import MkId import Id import FiniteMap import ForeignCall @@ -30,9 +31,9 @@ import CoreFVs import Type import DataCon import TyCon -import Type +-- import Type import Util -import DataCon +-- import DataCon import Var import VarSet import TysPrim @@ -50,7 +51,7 @@ import Data.List import Foreign import Foreign.C -import GHC.Exts ( Int(..), ByteArray# ) +-- import GHC.Exts ( Int(..) ) import Control.Monad ( when ) import Data.Char @@ -122,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 @@ -146,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] @@ -170,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 @@ -274,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 @@ -289,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 @@ -302,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 @@ -345,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 @@ -365,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 @@ -394,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" @@ -454,9 +457,21 @@ schemeE d s p (AnnLet binds (_,body)) -- best way to calculate the free vars but it seemed like the least -- intrusive thing to do schemeE d s p exp@(AnnCase {}) - | Just (_tickInfo, rhs) <- isTickedExp' exp + | Just (_tickInfo, _rhs) <- isTickedExp' exp = if isUnLiftedType ty - then schemeE d s p (snd rhs) + then do + -- If the result type is unlifted, then we must generate + -- let f = \s . case tick# of _ -> e + -- in f realWorld# + -- When we stop at the breakpoint, _result will have an unlifted + -- type and hence won't be bound in the environment, but the + -- breakpoint will otherwise work fine. + id <- newId (mkFunTy realWorldStatePrimTy ty) + st <- newId realWorldStatePrimTy + let letExp = AnnLet (AnnNonRec id (fvs, AnnLam st (emptyVarSet, exp))) + (emptyVarSet, (AnnApp (emptyVarSet, AnnVar id) + (emptyVarSet, AnnVar realWorldPrimId))) + schemeE d s p letExp else do id <- newId ty -- Todo: is emptyVarSet correct on the next line? @@ -571,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 @@ -654,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 @@ -691,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 @@ -703,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 @@ -760,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 @@ -778,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 @@ -806,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... @@ -826,9 +841,10 @@ 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) + MachWord w -> DiscrW (fromInteger w) MachFloat r -> DiscrF (fromRational r) MachDouble r -> DiscrD (fromRational r) MachChar i -> DiscrI (ord i) @@ -856,11 +872,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 = [] @@ -894,7 +912,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 @@ -904,7 +922,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 @@ -921,12 +940,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. @@ -938,6 +957,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 @@ -948,7 +969,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 @@ -1007,14 +1028,15 @@ generateCCall d0 s p (CCallSpec target cconv _) fn args_r_to_l = case target of DynamicTarget -> return (False, panic "ByteCodeGen.generateCCall(dyn)") - StaticTarget target + + StaticTarget target _ -> do res <- ioToBc (lookupStaticPtr stdcall_adj_target) return (True, res) where stdcall_adj_target #ifdef mingw32_TARGET_OS | StdCallConv <- cconv - = let size = a_reps_sizeW * wORD_SIZE in + = let size = fromIntegral a_reps_sizeW * wORD_SIZE in mkFastString (unpackFS target ++ '@':show size) #endif | otherwise @@ -1041,7 +1063,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 @@ -1136,7 +1158,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]) @@ -1166,7 +1188,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 @@ -1183,7 +1205,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 - 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 -- @@ -1200,7 +1223,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) @@ -1216,7 +1240,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) @@ -1312,6 +1336,10 @@ mkMultiBranch maybe_ncons raw_ways \(DiscrI i) fail_label -> TESTEQ_I i fail_label, DiscrI minBound, DiscrI maxBound ); + DiscrW _ -> ( \(DiscrW i) fail_label -> TESTLT_W i fail_label, + \(DiscrW i) fail_label -> TESTEQ_W i fail_label, + DiscrW minBound, + DiscrW maxBound ); DiscrF _ -> ( \(DiscrF f) fail_label -> TESTLT_F f fail_label, \(DiscrF f) fail_label -> TESTEQ_F f fail_label, DiscrF minF, @@ -1329,10 +1357,12 @@ 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 + (DiscrW w1) `eqAlt` (DiscrW w2) = w1 == w2 (DiscrF f1) `eqAlt` (DiscrF f2) = f1 == f2 (DiscrD d1) `eqAlt` (DiscrD d2) = d1 == d2 (DiscrP i1) `eqAlt` (DiscrP i2) = i1 == i2 @@ -1340,6 +1370,7 @@ mkMultiBranch maybe_ncons raw_ways _ `eqAlt` _ = False (DiscrI i1) `leAlt` (DiscrI i2) = i1 <= i2 + (DiscrW w1) `leAlt` (DiscrW w2) = w1 <= w2 (DiscrF f1) `leAlt` (DiscrF f2) = f1 <= f2 (DiscrD d1) `leAlt` (DiscrD d2) = d1 <= d2 (DiscrP i1) `leAlt` (DiscrP i2) = i1 <= i2 @@ -1350,6 +1381,7 @@ mkMultiBranch maybe_ncons raw_ways isNoDiscr _ = False dec (DiscrI i) = DiscrI (i-1) + dec (DiscrW w) = DiscrW (w-1) dec (DiscrP i) = DiscrP (i-1) dec other = other -- not really right, but if you -- do cases on floating values, you'll get what you deserve @@ -1371,20 +1403,22 @@ mkMultiBranch maybe_ncons raw_ways -- Describes case alts data Discr = DiscrI Int + | DiscrW Word | DiscrF Float | DiscrD Double - | DiscrP Int + | DiscrP Word16 | NoDiscr instance Outputable Discr where ppr (DiscrI i) = int i + ppr (DiscrW w) = text (show w) 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 @@ -1400,7 +1434,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]) @@ -1445,7 +1479,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)) @@ -1457,7 +1491,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 @@ -1509,11 +1543,14 @@ 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) + = BcM $ \st -> do let nl = nextlabel st + when (nl == maxBound) $ + panic "getLabelBc: Ran out of labels" + return (st{nextlabel = nl + 1}, nl) -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])