X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FByteCodeGen.lhs;h=19db7af16b88b2f31f1e98fea98f0974f36e55eb;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=d367bec5122f083ec3956ba4e11faee385c1a81f;hpb=519c3db41ba9017ab2e124b4575ae12667b53881;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs index d367bec..19db7af 100644 --- a/ghc/compiler/ghci/ByteCodeGen.lhs +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -15,69 +15,63 @@ import ByteCodeAsm ( CompiledByteCode(..), UnlinkedBCO, import ByteCodeLink ( lookupStaticPtr ) import Outputable -import Name ( Name, getName, mkSystemName ) +import Name ( Name, getName, mkSystemVarName ) import Id import FiniteMap import ForeignCall ( ForeignCall(..), CCallTarget(..), CCallSpec(..) ) -import HscTypes ( ModGuts(..), ModGuts, typeEnvTyCons, typeEnvClasses ) +import HscTypes ( TypeEnv, typeEnvTyCons, typeEnvClasses ) import CoreUtils ( exprType ) import CoreSyn import PprCore ( pprCoreExpr ) -import Literal ( Literal(..), literalPrimRep ) -import PrimRep +import Literal ( Literal(..), literalType ) import PrimOp ( PrimOp(..) ) import CoreFVs ( freeVars ) -import Type ( typePrimRep, isUnLiftedType, splitTyConApp_maybe, - isTyVarTy ) +import Type ( isUnLiftedType, splitTyConApp_maybe ) import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon, - isUnboxedTupleCon, isNullaryDataCon, - dataConRepArity, dataConWorkId ) -import TyCon ( tyConFamilySize, isDataTyCon, tyConDataCons, - isFunTyCon, isUnboxedTupleTyCon ) + isUnboxedTupleCon, isNullaryRepDataCon, dataConWorkId, + dataConRepArity ) +import TyCon ( TyCon, tyConFamilySize, isDataTyCon, + tyConDataCons, isUnboxedTupleTyCon ) import Class ( Class, classTyCon ) -import Type ( Type, repType, splitFunTys, dropForAlls ) +import Type ( Type, repType, splitFunTys, dropForAlls, pprType ) import Util import DataCon ( dataConRepArity ) import Var ( isTyVar ) import VarSet ( VarSet, varSetElems ) -import TysPrim ( foreignObjPrimTyCon, - arrayPrimTyCon, mutableArrayPrimTyCon, +import TysPrim ( arrayPrimTyCon, mutableArrayPrimTyCon, byteArrayPrimTyCon, mutableByteArrayPrimTyCon ) -import PrimRep ( isFollowableRep ) -import CmdLineOpts ( DynFlags, DynFlag(..) ) +import DynFlags ( DynFlags, DynFlag(..) ) import ErrUtils ( showPass, dumpIfSet_dyn ) -import Unique ( mkPseudoUnique3 ) +import Unique ( mkPseudoUniqueE ) import FastString ( FastString(..), unpackFS ) import Panic ( GhcException(..) ) -import PprType ( pprType ) -import SMRep ( arrWordsHdrSize, arrPtrsHdrSize ) +import SMRep ( typeCgRep, arrWordsHdrSize, arrPtrsHdrSize, StgWord, + CgRep(..), cgRepSizeW, isFollowableArg, idCgRep ) +import Bitmap ( intsToReverseBitmap, mkBitmap ) import OrdList import Constants ( wORD_SIZE ) -import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel ) -import Data.List ( intersperse, sortBy, zip4, zip5, partition ) -import Foreign ( Ptr, castPtr, mallocBytes, pokeByteOff, Word8 ) +import Data.List ( intersperse, sortBy, zip4, zip6, partition ) +import Foreign ( Ptr, castPtr, mallocBytes, pokeByteOff, Word8, + withForeignPtr ) import Foreign.C ( CInt ) import Control.Exception ( throwDyn ) import GHC.Exts ( Int(..), ByteArray# ) -import Control.Monad ( when, mapAndUnzipM ) -import Data.Char ( ord ) -import Data.Bits +import Control.Monad ( when ) +import Data.Char ( ord, chr ) -- ----------------------------------------------------------------------------- -- Generating byte code for a complete module byteCodeGen :: DynFlags - -> ModGuts + -> [CoreBind] + -> [TyCon] -> IO CompiledByteCode -byteCodeGen dflags (ModGuts { mg_binds = binds, mg_types = type_env }) +byteCodeGen dflags binds tycs = do showPass dflags "ByteCodeGen" - let local_tycons = typeEnvTyCons type_env - local_classes = typeEnvClasses type_env - tycs = local_tycons ++ map classTyCon local_classes let flatBinds = [ (bndr, freeVars rhs) | (bndr, rhs) <- flattenBinds binds] @@ -106,7 +100,7 @@ coreExprToBCOs dflags expr -- create a totally bogus name for the top-level BCO; this -- should be harmless, since it's never used for anything - let invented_name = mkSystemName (mkPseudoUnique3 0) FSLIT("ExprTopLevel") + let invented_name = mkSystemVarName (mkPseudoUniqueE 0) FSLIT("ExprTopLevel") invented_id = mkLocalId invented_name (panic "invented_id's type") (BcM_State final_ctr mallocd, proto_bco) @@ -137,7 +131,7 @@ ppBCEnv p $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (fmToList p)))) $$ text "end-env" where - pp_one (var, offset) = int offset <> colon <+> ppr var <+> ppr (idPrimRep var) + pp_one (var, offset) = int offset <> colon <+> ppr var <+> ppr (idCgRep var) cmp_snd x y = compare (snd x) (snd y) -- Create a BCO and do a spot of peephole optimisation on the insns @@ -198,37 +192,11 @@ mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap peep [] = [] -argBits :: [PrimRep] -> [Bool] +argBits :: [CgRep] -> [Bool] argBits [] = [] argBits (rep : args) - | isFollowableRep rep = False : argBits args - | otherwise = take (getPrimRepSize rep) (repeat True) ++ argBits args - -mkBitmap :: [Bool] -> [StgWord] -mkBitmap [] = [] -mkBitmap stuff = chunkToLiveness chunk : mkBitmap rest - where (chunk, rest) = splitAt wORD_SIZE_IN_BITS stuff - -chunkToLiveness :: [Bool] -> StgWord -chunkToLiveness chunk = - foldr (.|.) 0 [ 1 `shiftL` n | (True,n) <- zip chunk [0..] ] - --- make a bitmap where the slots specified are the *zeros* in the bitmap. --- eg. [1,2,4], size 4 ==> 0x8 (we leave any bits outside the size as zero, --- just to make the bitmap easier to read). -intsToBitmap :: Int -> [Int] -> [StgWord] -intsToBitmap size slots{- must be sorted -} - | size <= 0 = [] - | otherwise = - (foldr xor init (map (1 `shiftL`) these)) : - intsToBitmap (size - wORD_SIZE_IN_BITS) - (map (\x -> x - wORD_SIZE_IN_BITS) rest) - where (these,rest) = span (= wORD_SIZE_IN_BITS = complement 0 - | otherwise = (1 `shiftL` size) - 1 - -wORD_SIZE_IN_BITS = wORD_SIZE * 8 :: Int + | isFollowableArg rep = False : argBits args + | otherwise = take (cgRepSizeW rep) (repeat True) ++ argBits args -- ----------------------------------------------------------------------------- -- schemeTopBind @@ -239,12 +207,12 @@ schemeTopBind :: (Id, AnnExpr Id VarSet) -> BcM (ProtoBCO Name) schemeTopBind (id, rhs) - | Just data_con <- isDataConId_maybe id, - isNullaryDataCon data_con + | Just data_con <- isDataConWorkId_maybe id, + isNullaryRepDataCon data_con = -- Special case for the worker of a nullary data con. - -- It'll look like this: $wNil = /\a -> $wNil a + -- It'll look like this: Nil = /\a -> Nil a -- If we feed it into schemeR, we'll get - -- $wNil = $wNil + -- Nil = Nil -- because mkConAppCode treats nullary constructor applications -- by just re-using the single top-level definition. So -- for the worker itself, we must allocate it directly. @@ -301,7 +269,7 @@ schemeR_wrk fvs nm original_body (args, body) p_init = listToFM (zip all_args (mkStackOffsets 0 szsw_args)) -- make the arg bitmap - bits = argBits (reverse (map idPrimRep all_args)) + bits = argBits (reverse (map idCgRep all_args)) bitmap_size = length bits bitmap = mkBitmap bits in @@ -348,11 +316,11 @@ schemeE d s p e@(AnnVar v) `snocOL` RETURN_UBX v_rep) -- go where v_type = idType v - v_rep = typePrimRep v_type + v_rep = typeCgRep v_type schemeE d s p (AnnLit literal) = pushAtom d p (AnnLit literal) `thenBc` \ (push, szw) -> - let l_rep = literalPrimRep literal + let l_rep = typeCgRep (literalType literal) in returnBc (push -- value onto stack `appOL` mkSLIDE szw (d-s) -- clear to sequel `snocOL` RETURN_UBX l_rep) -- go @@ -360,7 +328,7 @@ schemeE d s p (AnnLit literal) schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body)) | (AnnVar v, args_r_to_l) <- splitApp rhs, - Just data_con <- isDataConId_maybe v, + Just data_con <- isDataConWorkId_maybe v, dataConRepArity data_con == length args_r_to_l = -- Special case for a non-recursive let whose RHS is a -- saturatred constructor application. @@ -378,8 +346,8 @@ schemeE d s p (AnnLet binds (_,body)) fvss = map (fvsToEnv p' . fst) rhss - -- Sizes of free vars, + 1 for the fn - sizes = map (\rhs_fvs -> 1 + sum (map idSizeW rhs_fvs)) fvss + -- Sizes of free vars + sizes = map (\rhs_fvs -> sum (map idSizeW rhs_fvs)) fvss -- the arity of each rhs arities = map (length . fst . collect []) rhss @@ -393,26 +361,28 @@ schemeE d s p (AnnLet binds (_,body)) zipE = zipEqual "schemeE" -- ToDo: don't build thunks for things with no free variables - build_thunk dd [] size bco off - = returnBc (PUSH_BCO bco - `consOL` unitOL (MKAP (off+size-1) size)) - build_thunk dd (fv:fvs) size bco off = do + build_thunk dd [] size bco off arity + = returnBc (PUSH_BCO bco `consOL` unitOL (mkap (off+size) size)) + where + mkap | arity == 0 = MKAP + | otherwise = MKPAP + build_thunk dd (fv:fvs) size bco off arity = do (push_code, pushed_szw) <- pushAtom dd p' (AnnVar fv) - more_push_code <- build_thunk (dd+pushed_szw) fvs size bco off + more_push_code <- build_thunk (dd+pushed_szw) fvs size bco off arity returnBc (push_code `appOL` more_push_code) alloc_code = toOL (zipWith mkAlloc sizes arities) where mkAlloc sz 0 = ALLOC_AP sz mkAlloc sz arity = ALLOC_PAP arity sz - compile_bind d' fvs x rhs size off = do + compile_bind d' fvs x rhs size arity off = do bco <- schemeR fvs (x,rhs) - build_thunk d' fvs size bco off + build_thunk d' fvs size bco off arity compile_binds = - [ compile_bind d' fvs x rhs size n - | (fvs, x, rhs, size, n) <- - zip5 fvss xs rhss sizes [n_binds, n_binds-1 .. 1] + [ compile_bind d' fvs x rhs size arity n + | (fvs, x, rhs, size, arity, n) <- + zip6 fvss xs rhss sizes arities [n_binds, n_binds-1 .. 1] ] in do body_code <- schemeE d' s p' body @@ -421,10 +391,10 @@ schemeE d s p (AnnLet binds (_,body)) -schemeE d s p (AnnCase scrut bndr [(DataAlt dc, [bind1, bind2], rhs)]) - | isUnboxedTupleCon dc && VoidRep == typePrimRep (idType bind1) +schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)]) + | isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind1) -- Convert - -- case .... of x { (# VoidRep'd-thing, a #) -> ... } + -- case .... of x { (# VoidArg'd-thing, a #) -> ... } -- to -- case .... of a { DEFAULT -> ... } -- becuse the return convention for both are identical. @@ -432,14 +402,14 @@ schemeE d s p (AnnCase scrut bndr [(DataAlt dc, [bind1, bind2], rhs)]) -- Note that it does not matter losing the void-rep thing from the -- envt (it won't be bound now) because we never look such things up. - = --trace "automagic mashing of case alts (# VoidRep, a #)" $ + = --trace "automagic mashing of case alts (# VoidArg, a #)" $ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] True{-unboxed tuple-} - | isUnboxedTupleCon dc && VoidRep == typePrimRep (idType bind2) - = --trace "automagic mashing of case alts (# a, VoidRep #)" $ + | isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind2) + = --trace "automagic mashing of case alts (# a, VoidArg #)" $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-} -schemeE d s p (AnnCase scrut bndr [(DataAlt dc, [bind1], rhs)]) +schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)]) | isUnboxedTupleCon dc -- Similarly, convert -- case .... of x { (# a #) -> ... } @@ -448,7 +418,7 @@ schemeE d s p (AnnCase scrut bndr [(DataAlt dc, [bind1], rhs)]) = --trace "automagic mashing of case alts (# a #)" $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-} -schemeE d s p (AnnCase scrut bndr alts) +schemeE d s p (AnnCase scrut bndr _ alts) = doCase d s p scrut bndr alts False{-not an unboxed tuple-} schemeE d s p (AnnNote note (_, body)) @@ -470,9 +440,9 @@ schemeE d s p other -- -- 1. The fn denotes a ccall. Defer to generateCCall. -- --- 2. (Another nasty hack). Spot (# a::VoidRep, b #) and treat +-- 2. (Another nasty hack). Spot (# a::VoidArg, b #) and treat -- it simply as b -- since the representations are identical --- (the VoidRep takes up zero stack space). Also, spot +-- (the VoidArg takes up zero stack space). Also, spot -- (# b #) and treat it as b. -- -- 3. Application of a constructor, by defn saturated. @@ -512,9 +482,9 @@ schemeT d s p app | Just con <- maybe_saturated_dcon, isUnboxedTupleCon con = case args_r_to_l of - [arg1,arg2] | isVoidRepAtom arg1 -> + [arg1,arg2] | isVoidArgAtom arg1 -> unboxedTupleReturn d s p arg2 - [arg1,arg2] | isVoidRepAtom arg2 -> + [arg1,arg2] | isVoidArgAtom arg2 -> unboxedTupleReturn d s p arg1 _other -> unboxedTupleException @@ -533,11 +503,14 @@ schemeT d s p app -- Detect and extract relevant info for the tagToEnum kludge. maybe_is_tagToEnum_call = let extract_constr_Names ty - = case splitTyConApp_maybe (repType ty) of - (Just (tyc, [])) | isDataTyCon tyc - -> map getName (tyConDataCons tyc) - other -> panic "maybe_is_tagToEnum_call.extract_constr_Ids" - in + | Just (tyc, []) <- splitTyConApp_maybe (repType ty), + isDataTyCon tyc + = map (getName . dataConWorkId) (tyConDataCons tyc) + -- NOTE: use the worker name, not the source name of + -- the DataCon. See DataCon.lhs for details. + | otherwise + = panic "maybe_is_tagToEnum_call.extract_constr_Ids" + in case app of (AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg) -> case isPrimOpId_maybe v of @@ -554,7 +527,7 @@ schemeT d s p app -- saturated. Otherwise, we'll call the constructor wrapper. n_args = length args_r_to_l maybe_saturated_dcon - = case isDataConId_maybe fn of + = case isDataConWorkId_maybe fn of Just con | dataConRepArity con == n_args -> Just con _ -> Nothing @@ -568,11 +541,10 @@ mkConAppCode :: Int -> Sequel -> BCEnv -> BcM BCInstrList mkConAppCode orig_d s p con [] -- Nullary constructor - = ASSERT( isNullaryDataCon con ) + = ASSERT( isNullaryRepDataCon con ) returnBc (unitOL (PUSH_G (getName (dataConWorkId con)))) -- Instead of doing a PACK, which would allocate a fresh -- copy of this constructor, use the single shared version. - -- The name of the constructor is the name of its wrapper function mkConAppCode orig_d s p con args_r_to_l = ASSERT( dataConRepArity con == length args_r_to_l ) @@ -616,12 +588,12 @@ doTailCall -> Id -> [AnnExpr' Id VarSet] -> BcM BCInstrList doTailCall init_d s p fn args - = do_pushes init_d args (map (primRepToArgRep.atomRep) args) + = do_pushes init_d args (map atomRep args) where do_pushes d [] reps = do - ASSERTM( null reps ) + ASSERT( null reps ) return () (push_fn, sz) <- pushAtom d p (AnnVar fn) - ASSERTM( sz == 1 ) + ASSERT( sz == 1 ) return () returnBc (push_fn `appOL` ( mkSLIDE ((d-init_d) + 1) (init_d - s) `appOL` unitOL ENTER)) @@ -640,29 +612,27 @@ doTailCall init_d s p fn args return (final_d, push_code `appOL` more_push_code) -- v. similar to CgStackery.findMatch, ToDo: merge -findPushSeq (RepP: RepP: RepP: RepP: RepP: RepP: RepP: rest) - = (PUSH_APPLY_PPPPPPP, 7, rest) -findPushSeq (RepP: RepP: RepP: RepP: RepP: RepP: rest) +findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: rest) = (PUSH_APPLY_PPPPPP, 6, rest) -findPushSeq (RepP: RepP: RepP: RepP: RepP: rest) +findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: rest) = (PUSH_APPLY_PPPPP, 5, rest) -findPushSeq (RepP: RepP: RepP: RepP: rest) +findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: rest) = (PUSH_APPLY_PPPP, 4, rest) -findPushSeq (RepP: RepP: RepP: rest) +findPushSeq (PtrArg: PtrArg: PtrArg: rest) = (PUSH_APPLY_PPP, 3, rest) -findPushSeq (RepP: RepP: rest) +findPushSeq (PtrArg: PtrArg: rest) = (PUSH_APPLY_PP, 2, rest) -findPushSeq (RepP: rest) +findPushSeq (PtrArg: rest) = (PUSH_APPLY_P, 1, rest) -findPushSeq (RepV: rest) +findPushSeq (VoidArg: rest) = (PUSH_APPLY_V, 1, rest) -findPushSeq (RepN: rest) +findPushSeq (NonPtrArg: rest) = (PUSH_APPLY_N, 1, rest) -findPushSeq (RepF: rest) +findPushSeq (FloatArg: rest) = (PUSH_APPLY_F, 1, rest) -findPushSeq (RepD: rest) +findPushSeq (DoubleArg: rest) = (PUSH_APPLY_D, 1, rest) -findPushSeq (RepL: rest) +findPushSeq (LongArg: rest) = (PUSH_APPLY_L, 1, rest) findPushSeq _ = panic "ByteCodeGen.findPushSeq" @@ -715,7 +685,7 @@ doCase d s p (_,scrut) -- algebraic alt with some binders | ASSERT(isAlgCase) otherwise = let - (ptrs,nptrs) = partition (isFollowableRep.idPrimRep) real_bndrs + (ptrs,nptrs) = partition (isFollowableArg.idCgRep) real_bndrs ptr_sizes = map idSizeW ptrs nptrs_sizes = map idSizeW nptrs bind_sizes = ptr_sizes ++ nptrs_sizes @@ -741,7 +711,7 @@ doCase d s p (_,scrut) = case l of MachInt i -> DiscrI (fromInteger i) MachFloat r -> DiscrF (fromRational r) MachDouble r -> DiscrD (fromRational r) - MachChar i -> DiscrI i + MachChar i -> DiscrI (ord i) _ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l) maybe_ncons @@ -758,12 +728,12 @@ doCase d s p (_,scrut) -- things that are pointers, whereas in CgBindery the code builds the -- bitmap from the free slots and unboxed bindings. -- (ToDo: merge?) - bitmap = intsToBitmap d{-size-} (sortLt (<) rel_slots) + bitmap = intsToReverseBitmap d{-size-} (sortLe (<=) rel_slots) where binds = fmToList p rel_slots = concat (map spread binds) spread (id, offset) - | isFollowableRep (idPrimRep id) = [ rel_offset ] + | isFollowableArg (idCgRep id) = [ rel_offset ] | otherwise = [] where rel_offset = d - offset - 1 @@ -781,7 +751,7 @@ doCase d s p (_,scrut) alt_bco' <- emitBc alt_bco let push_alts | isAlgCase = PUSH_ALTS alt_bco' - | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typePrimRep bndr_ty) + | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeCgRep bndr_ty) returnBc (push_alts `consOL` scrut_code) @@ -789,8 +759,8 @@ doCase d s p (_,scrut) -- Deal with a CCall. -- Taggedly push the args onto the stack R->L, --- deferencing ForeignObj#s and (ToDo: adjusting addrs to point to --- payloads in Ptr/Byte arrays). Then, generate the marshalling +-- deferencing ForeignObj#s and adjusting addrs to point to +-- payloads in Ptr/Byte arrays. Then, generate the marshalling -- (machine) code for the ccall, and create bytecodes to call that and -- then return in the right way. @@ -804,12 +774,12 @@ generateCCall :: Int -> Sequel -- stack and sequel depths generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l = let -- useful constants - addr_sizeW = getPrimRepSize AddrRep + addr_sizeW = cgRepSizeW NonPtrArg -- Get the args on the stack, with tags and suitably -- dereferenced for the CCall. For each arg, return the -- depth to the first word of the bits for that arg, and the - -- PrimRep of what was actually pushed. + -- CgRep of what was actually pushed. pargs d [] = returnBc [] pargs d (a:az) @@ -823,13 +793,13 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l -> pargs (d + addr_sizeW) az `thenBc` \ rest -> parg_ArrayishRep arrPtrsHdrSize d p a `thenBc` \ code -> - returnBc ((code,AddrRep):rest) + returnBc ((code,NonPtrArg):rest) | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon -> pargs (d + addr_sizeW) az `thenBc` \ rest -> parg_ArrayishRep arrWordsHdrSize d p a `thenBc` \ code -> - returnBc ((code,AddrRep):rest) + returnBc ((code,NonPtrArg):rest) -- Default case: push taggedly, but otherwise intact. other @@ -840,13 +810,11 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) 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 hdrSizeW d p a + parg_ArrayishRep hdrSize d p a = pushAtom d p a `thenBc` \ (push_fo, _) -> -- The ptr points at the header. Advance it over the -- header and then pretend this is an Addr#. - returnBc (push_fo `snocOL` - SWIZZLE 0 (hdrSizeW * getPrimRepSize WordRep - * wORD_SIZE)) + returnBc (push_fo `snocOL` SWIZZLE 0 hdrSize) in pargs d0 args_r_to_l `thenBc` \ code_n_reps -> @@ -854,9 +822,9 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l (pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps push_args = concatOL pushs_arg - d_after_args = d0 + sum (map getPrimRepSize a_reps_pushed_r_to_l) + d_after_args = d0 + sum (map cgRepSizeW a_reps_pushed_r_to_l) a_reps_pushed_RAW - | null a_reps_pushed_r_to_l || head a_reps_pushed_r_to_l /= VoidRep + | null a_reps_pushed_r_to_l || head a_reps_pushed_r_to_l /= VoidArg = panic "ByteCodeGen.generateCCall: missing or invalid World token?" | otherwise = reverse (tail a_reps_pushed_r_to_l) @@ -868,7 +836,7 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l -- Get the result rep. (returns_void, r_rep) = case maybe_getCCallReturnRep (idType fn) of - Nothing -> (True, VoidRep) + Nothing -> (True, VoidArg) Just rr -> (False, rr) {- Because the Haskell stack grows down, the a_reps refer to @@ -913,14 +881,12 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l StaticTarget target -> ioToBc (lookupStaticPtr target) `thenBc` \res -> returnBc (True, res) - CasmTarget _ - -> pprPanic "ByteCodeGen.generateCCall: casm" (ppr ccall_spec) in get_target_info `thenBc` \ (is_static, static_target_addr) -> let -- Get the arg reps, zapping the leading Addr# in the dynamic case - a_reps -- | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???" + a_reps -- | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???" | is_static = a_reps_pushed_RAW | otherwise = if null a_reps_pushed_RAW then panic "ByteCodeGen.generateCCall: dyn with no args" @@ -935,8 +901,8 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l = (nilOL, d_after_args) -- Push the return placeholder. For a call returning nothing, - -- this is a VoidRep (tag). - r_sizeW = getPrimRepSize r_rep + -- this is a VoidArg (tag). + r_sizeW = cgRepSizeW r_rep d_after_r = d_after_Addr + r_sizeW r_lit = mkDummyLiteral r_rep push_r = (if returns_void @@ -948,7 +914,7 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l addr_offW = r_sizeW arg1_offW = r_sizeW + addr_sizeW args_offW = map (arg1_offW +) - (init (scanl (+) 0 (map getPrimRepSize a_reps))) + (init (scanl (+) 0 (map cgRepSizeW a_reps))) in ioToBc (mkMarshalCode cconv (r_offW, r_rep) addr_offW @@ -967,7 +933,7 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l wrapup = mkSLIDE r_sizeW (d_after_r - r_sizeW - s) `snocOL` RETURN_UBX r_rep in - --trace (show (arg1_offW, args_offW , (map getPrimRepSize a_reps) )) $ + --trace (show (arg1_offW, args_offW , (map cgRepSizeW a_reps) )) $ returnBc ( push_args `appOL` push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup @@ -976,15 +942,12 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l -- Make a dummy literal, to be used as a placeholder for FFI return -- values on the stack. -mkDummyLiteral :: PrimRep -> Literal +mkDummyLiteral :: CgRep -> Literal mkDummyLiteral pr = case pr of - CharRep -> MachChar 0 - IntRep -> MachInt 0 - WordRep -> MachWord 0 - DoubleRep -> MachDouble 0 - FloatRep -> MachFloat 0 - AddrRep | getPrimRepSize AddrRep == getPrimRepSize WordRep -> MachWord 0 + NonPtrArg -> MachWord 0 + DoubleArg -> MachDouble 0 + FloatArg -> MachFloat 0 _ -> moan64 "mkDummyLiteral" (ppr pr) @@ -993,7 +956,7 @@ mkDummyLiteral pr -- -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #) -- -- to Just IntRep --- and check that an unboxed pair is returned wherein the first arg is VoidRep'd. +-- and check that an unboxed pair is returned wherein the first arg is VoidArg'd. -- -- Alternatively, for call-targets returning nothing, convert -- @@ -1002,21 +965,21 @@ mkDummyLiteral pr -- -- to Nothing -maybe_getCCallReturnRep :: Type -> Maybe PrimRep +maybe_getCCallReturnRep :: Type -> Maybe CgRep maybe_getCCallReturnRep fn_ty = let (a_tys, r_ty) = splitFunTys (dropForAlls fn_ty) maybe_r_rep_to_go = if isSingleton r_reps then Nothing else Just (r_reps !! 1) (r_tycon, r_reps) = case splitTyConApp_maybe (repType r_ty) of - (Just (tyc, tys)) -> (tyc, map typePrimRep tys) + (Just (tyc, tys)) -> (tyc, map typeCgRep tys) Nothing -> blargh - ok = ( ( r_reps `lengthIs` 2 && VoidRep == head r_reps) - || r_reps == [VoidRep] ) + ok = ( ( r_reps `lengthIs` 2 && VoidArg == head r_reps) + || r_reps == [VoidArg] ) && isUnboxedTupleTyCon r_tycon && case maybe_r_rep_to_go of Nothing -> True - Just r_rep -> r_rep /= PtrRep + Just r_rep -> r_rep /= PtrArg -- if it was, it would be impossible -- to create a valid return value -- placeholder on the stack @@ -1076,7 +1039,7 @@ pushAtom d p (AnnLam x e) pushAtom d p (AnnVar v) - | idPrimRep v == VoidRep + | idCgRep v == VoidArg = returnBc (nilOL, 0) | isFCallId v @@ -1108,34 +1071,34 @@ pushAtom d p (AnnVar v) pushAtom d p (AnnLit lit) = case lit of - MachLabel fs -> code CodePtrRep - MachWord w -> code WordRep - MachInt i -> code IntRep - MachFloat r -> code FloatRep - MachDouble r -> code DoubleRep - MachChar c -> code CharRep - MachStr s -> pushStr s + MachLabel fs _ -> code NonPtrArg + MachWord w -> code NonPtrArg + MachInt i -> code PtrArg + MachFloat r -> code FloatArg + MachDouble r -> code DoubleArg + MachChar c -> code NonPtrArg + MachStr s -> pushStr s where code rep - = let size_host_words = getPrimRepSize rep + = let size_host_words = cgRepSizeW rep in returnBc (unitOL (PUSH_UBX (Left lit) size_host_words), size_host_words) pushStr s = let getMallocvilleAddr = case s of - FastString _ l ba -> - -- sigh, a string in the heap is no good to us. - -- We need a static C pointer, since the type of - -- a string literal is Addr#. So, copy the string - -- into C land and remember the pointer so we can - -- free it later. - let n = I# l - -- CAREFUL! Chars are 32 bits in ghc 4.09+ - in ioToBc (mallocBytes (n+1)) `thenBc` \ ptr -> + FastString _ n _ fp _ -> + -- we could grab the Ptr from the ForeignPtr, + -- but then we have no way to control its lifetime. + -- In reality it'll probably stay alive long enoungh + -- by virtue of the global FastString table, but + -- to be on the safe side we copy the string into + -- a malloc'd area of memory. + ioToBc (mallocBytes (n+1)) `thenBc` \ ptr -> recordMallocBc ptr `thenBc_` ioToBc ( - do memcpy ptr ba (fromIntegral n) + withForeignPtr fp $ \p -> do + memcpy ptr p (fromIntegral n) pokeByteOff ptr n (fromIntegral (ord '\0') :: Word8) return ptr ) @@ -1150,7 +1113,7 @@ pushAtom d p other (pprCoreExpr (deAnnotate (undefined, other))) foreign import ccall unsafe "memcpy" - memcpy :: Ptr a -> ByteArray# -> CInt -> IO () + memcpy :: Ptr a -> Ptr b -> CInt -> IO () -- ----------------------------------------------------------------------------- @@ -1158,14 +1121,14 @@ foreign import ccall unsafe "memcpy" -- of making a multiway branch using a switch tree. -- What a load of hassle! -mkMultiBranch :: Maybe Int -- # datacons in tycon, if alg alt +mkMultiBranch :: Maybe Int -- # datacons in tycon, if alg alt -- a hint; generates better code -- Nothing is always safe -> [(Discr, BCInstrList)] -> BcM BCInstrList mkMultiBranch maybe_ncons raw_ways = let d_way = filter (isNoDiscr.fst) raw_ways - notd_ways = naturalMergeSortLe + notd_ways = sortLe (\w1 w2 -> leAlt (fst w1) (fst w2)) (filter (not.isNoDiscr.fst) raw_ways) @@ -1285,7 +1248,7 @@ lookupBCEnv_maybe :: BCEnv -> Id -> Maybe Int lookupBCEnv_maybe = lookupFM idSizeW :: Id -> Int -idSizeW id = getPrimRepSize (typePrimRep (idType id)) +idSizeW id = cgRepSizeW (typeCgRep (idType id)) unboxedTupleException :: a unboxedTupleException @@ -1313,21 +1276,21 @@ isTypeAtom :: AnnExpr' id ann -> Bool isTypeAtom (AnnType _) = True isTypeAtom _ = False -isVoidRepAtom :: AnnExpr' id ann -> Bool -isVoidRepAtom (AnnVar v) = typePrimRep (idType v) == VoidRep -isVoidRepAtom (AnnNote n (_,e)) = isVoidRepAtom e -isVoidRepAtom _ = False +isVoidArgAtom :: AnnExpr' id ann -> Bool +isVoidArgAtom (AnnVar v) = typeCgRep (idType v) == VoidArg +isVoidArgAtom (AnnNote n (_,e)) = isVoidArgAtom e +isVoidArgAtom _ = False -atomRep :: AnnExpr' Id ann -> PrimRep -atomRep (AnnVar v) = typePrimRep (idType v) -atomRep (AnnLit l) = literalPrimRep l +atomRep :: AnnExpr' Id ann -> CgRep +atomRep (AnnVar v) = typeCgRep (idType v) +atomRep (AnnLit l) = typeCgRep (literalType l) atomRep (AnnNote n b) = atomRep (snd b) atomRep (AnnApp f (_, AnnType _)) = atomRep (snd f) atomRep (AnnLam x e) | isTyVar x = atomRep (snd e) atomRep other = pprPanic "atomRep" (ppr (deAnnotate (undefined,other))) isPtrAtom :: AnnExpr' Id ann -> Bool -isPtrAtom e = isFollowableRep (atomRep e) +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