X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Fghci%2FByteCodeGen.lhs;h=0d21f2d7886b47363e079d875c0960992a732e4b;hb=6942766ac64f71b57c85a4069900b383495e2bdb;hp=5a375c47aa8728bbb274282cfd9bdfe331d971d9;hpb=13386b66f4fcc1fbf2f7df13e8687510e857c848;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs index 5a375c4..0d21f2d 100644 --- a/ghc/compiler/ghci/ByteCodeGen.lhs +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -4,67 +4,71 @@ \section[ByteCodeGen]{Generate bytecode from Core} \begin{code} -module ByteCodeGen ( UnlinkedBCO, UnlinkedBCOExpr, ItblEnv, ClosureEnv, HValue, - filterNameMap, - byteCodeGen, coreExprToBCOs +module ByteCodeGen ( UnlinkedBCO, UnlinkedBCOExpr, + byteCodeGen, coreExprToBCOs ) where #include "HsVersions.h" +import ByteCodeInstr ( BCInstr(..), ProtoBCO(..), nameOfProtoBCO, bciStackUse ) +import ByteCodeFFI ( taggedSizeW, untaggedSizeW, mkMarshalCode, moan64 ) +import ByteCodeAsm ( CompiledByteCode(..), UnlinkedBCO, UnlinkedBCOExpr, + assembleBCO, assembleBCOs, iNTERP_STACK_CHECK_THRESH ) +import ByteCodeLink ( lookupStaticPtr ) + import Outputable -import Name ( Name, getName ) +import Name ( Name, getName, mkSystemName ) import Id ( Id, idType, isDataConId_maybe, isPrimOpId_maybe, isFCallId, - idPrimRep, mkSysLocal, idName, isFCallId_maybe ) + idPrimRep, mkLocalId, isFCallId_maybe, isPrimOpId ) import ForeignCall ( ForeignCall(..), CCallTarget(..), CCallSpec(..) ) import OrdList ( OrdList, consOL, snocOL, appOL, unitOL, nilOL, toOL, concatOL, fromOL ) -import FiniteMap ( FiniteMap, addListToFM, listToFM, +import FiniteMap ( FiniteMap, addListToFM, listToFM, elemFM, addToFM, lookupFM, fmToList ) +import HscTypes ( ModGuts(..), ModGuts, typeEnvTyCons, typeEnvClasses ) +import CoreUtils ( exprType ) import CoreSyn import PprCore ( pprCoreExpr ) import Literal ( Literal(..), literalPrimRep ) import PrimRep ( PrimRep(..) ) import PrimOp ( PrimOp(..) ) import CoreFVs ( freeVars ) -import Type ( typePrimRep, splitTyConApp_maybe, isTyVarTy ) +import Type ( typePrimRep, isUnLiftedType, splitTyConApp_maybe, isTyVarTy ) import DataCon ( dataConTag, fIRST_TAG, dataConTyCon, dataConWrapId, isUnboxedTupleCon ) -import TyCon ( TyCon(..), tyConFamilySize, isDataTyCon, tyConDataCons, +import TyCon ( tyConFamilySize, isDataTyCon, tyConDataCons, isFunTyCon, isUnboxedTupleTyCon ) import Class ( Class, classTyCon ) -import Type ( Type, repType, splitRepFunTys ) +import Type ( Type, repType, splitFunTys, dropForAlls ) import Util ( zipEqual, zipWith4Equal, naturalMergeSortLe, nOfThem, - isSingleton, lengthIs ) + isSingleton, lengthIs, notNull ) +import DataCon ( dataConRepArity ) import Var ( isTyVar ) import VarSet ( VarSet, varSetElems ) +import TysPrim ( foreignObjPrimTyCon, + arrayPrimTyCon, mutableArrayPrimTyCon, + byteArrayPrimTyCon, mutableByteArrayPrimTyCon + ) import PrimRep ( isFollowableRep ) import CmdLineOpts ( DynFlags, DynFlag(..) ) import ErrUtils ( showPass, dumpIfSet_dyn ) import Unique ( mkPseudoUnique3 ) -import FastString ( FastString(..) ) +import FastString ( FastString(..), unpackFS ) import Panic ( GhcException(..) ) import PprType ( pprType ) import SMRep ( arrWordsHdrSize, arrPtrsHdrSize ) import Constants ( wORD_SIZE ) -import ByteCodeInstr ( BCInstr(..), ProtoBCO(..), nameOfProtoBCO, bciStackUse ) -import ByteCodeItbls ( ItblEnv, mkITbls ) -import ByteCodeLink ( UnlinkedBCO, UnlinkedBCOExpr, assembleBCO, - ClosureEnv, HValue, filterNameMap, linkFail, - iNTERP_STACK_CHECK_THRESH ) -import ByteCodeFFI ( taggedSizeW, untaggedSizeW, mkMarshalCode, moan64 ) -import Linker ( lookupSymbol ) import List ( intersperse, sortBy, zip4 ) -import Foreign ( Ptr(..), mallocBytes ) -import Addr ( Addr(..), writeCharOffAddr ) -import CTypes ( CInt ) -import Exception ( throwDyn ) - -import PrelBase ( Int(..) ) -import PrelGHC ( ByteArray# ) -import PrelIOBase ( IO(..) ) -import Monad ( when ) +import Foreign ( Ptr, castPtr, mallocBytes, pokeByteOff, Word8 ) +import Foreign.C ( CInt ) +import Control.Exception ( throwDyn ) + +import GHC.Exts ( Int(..), ByteArray# ) +import Monad ( when ) +import Maybe ( isJust ) +import Char ( ord ) \end{code} %************************************************************************ @@ -76,13 +80,13 @@ import Monad ( when ) \begin{code} byteCodeGen :: DynFlags - -> [CoreBind] - -> [TyCon] -> [Class] - -> IO ([UnlinkedBCO], ItblEnv) -byteCodeGen dflags binds local_tycons local_classes + -> ModGuts + -> IO CompiledByteCode +byteCodeGen dflags (ModGuts { mg_binds = binds, mg_types = type_env }) = do showPass dflags "ByteCodeGen" - let tycs = local_tycons ++ map classTyCon local_classes - itblenv <- mkITbls tycs + let local_tycons = typeEnvTyCons type_env + local_classes = typeEnvClasses type_env + tycs = local_tycons ++ map classTyCon local_classes let flatBinds = concatMap getBind binds getBind (NonRec bndr rhs) = [(bndr, freeVars rhs)] @@ -90,17 +94,17 @@ byteCodeGen dflags binds local_tycons local_classes (BcM_State proto_bcos final_ctr mallocd, ()) <- runBc (BcM_State [] 0 []) - (mapBc (schemeR True) flatBinds `thenBc_` returnBc ()) + (mapBc (schemeR True []) flatBinds `thenBc_` returnBc ()) + -- ^^ + -- better be no free vars in these top-level bindings - when (not (null mallocd)) + when (notNull mallocd) (panic "ByteCodeGen.byteCodeGen: missing final emitBc?") dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-bcos" (vcat (intersperse (char ' ') (map ppr proto_bcos))) - bcos <- mapM assembleBCO proto_bcos - - return (bcos, itblenv) + assembleBCOs proto_bcos tycs -- Returns: (the root BCO for this expression, @@ -113,15 +117,16 @@ 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_id = mkSysLocal SLIT("Expr-Top-Level") (mkPseudoUnique3 0) - (panic "invented_id's type") - let invented_name = idName invented_id + let invented_name = mkSystemName (mkPseudoUnique3 0) FSLIT("ExprTopLevel") + invented_id = mkLocalId invented_name (panic "invented_id's type") + annexpr = freeVars expr + fvs = filter (not.isTyVar) (varSetElems (fst annexpr)) (BcM_State all_proto_bcos final_ctr mallocd, ()) <- runBc (BcM_State [] 0 []) - (schemeR True (invented_id, freeVars expr)) + (schemeR True fvs (invented_id, annexpr)) - when (not (null mallocd)) + when (notNull mallocd) (panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?") dumpIfSet_dyn dflags Opt_D_dump_BCOs @@ -207,8 +212,8 @@ mkProtoBCO nm instrs_ordlist origin mallocd_blocks -- variable to which this value was bound, so as to give the -- resulting BCO a name. Bool indicates top-levelness. -schemeR :: Bool -> (Id, AnnExpr Id VarSet) -> BcM () -schemeR is_top (nm, rhs) +schemeR :: Bool -> [Id] -> (Id, AnnExpr Id VarSet) -> BcM () +schemeR is_top fvs (nm, rhs) {- | trace (showSDoc ( (char ' ' @@ -219,7 +224,7 @@ schemeR is_top (nm, rhs) = undefined -} | otherwise - = schemeR_wrk is_top rhs nm (collect [] rhs) + = schemeR_wrk is_top fvs rhs nm (collect [] rhs) collect xs (_, AnnNote note e) @@ -229,7 +234,7 @@ collect xs (_, AnnLam x e) collect xs not_lambda = (reverse xs, not_lambda) -schemeR_wrk is_top original_body nm (args, body) +schemeR_wrk is_top fvs original_body nm (args, body) | Just dcon <- maybe_toplevel_null_con_rhs = --trace ("nullary constructor! " ++ showSDocDebug (ppr nm)) ( emitBc (mkProtoBCO (getName nm) (toOL [PACK dcon 0, ENTER]) @@ -237,8 +242,7 @@ schemeR_wrk is_top original_body nm (args, body) --) | otherwise - = let fvs = filter (not.isTyVar) (varSetElems (fst original_body)) - all_args = reverse args ++ fvs + = let all_args = reverse args ++ fvs szsw_args = map taggedIdSizeW all_args szw_args = sum szsw_args p_init = listToFM (zip all_args (mkStackOffsets 0 szsw_args)) @@ -283,18 +287,20 @@ schemeE d s p e@(fvs, AnnApp f a) = schemeT d s p (fvs, AnnApp f a) schemeE d s p e@(fvs, AnnVar v) - | isFollowableRep v_rep - = -- Ptr-ish thing; push it in the normal way + | not (isUnLiftedType v_type) + = -- Lifted-type thing; push it in the normal way schemeT d s p (fvs, AnnVar v) | otherwise - = -- returning an unboxed value. Heave it on the stack, SLIDE, and RETURN. + = -- Returning an unlifted value. + -- Heave it on the stack, SLIDE, and RETURN. pushAtom True d p (AnnVar v) `thenBc` \ (push, szw) -> returnBc (push -- value onto stack `appOL` mkSLIDE szw (d-s) -- clear to sequel `snocOL` RETURN v_rep) -- go where - v_rep = typePrimRep (idType v) + v_type = idType v + v_rep = typePrimRep v_type schemeE d s p (fvs, AnnLit literal) = pushAtom True d p (AnnLit literal) `thenBc` \ (push, szw) -> @@ -303,11 +309,108 @@ schemeE d s p (fvs, AnnLit literal) `appOL` mkSLIDE szw (d-s) -- clear to sequel `snocOL` RETURN l_rep) -- go + +{- + Deal specially with the cases + let x = fn atom1 .. atomn in B + and + let x = Con atom1 .. atomn in B + (Con must be saturated) + + In these cases, generate code to allocate in-line. + + This is optimisation of the general case for let, which follows + this one; this case can safely be omitted. The reduction in + interpreter execution time seems to be around 5% for some programs, + with a similar drop in allocations. + + This optimisation should be done more cleanly. As-is, it is + inapplicable to RHSs in letrecs, and needlessly duplicates code in + schemeR and schemeT. Some refactoring of the machinery would cure + both ills. +-} +schemeE d s p ee@(fvs, AnnLet (AnnNonRec x rhs) b) + | ok_to_go + = let d_init = if is_con then d else d' + in + mkPushes d_init args_r_to_l_reordered `thenBc` \ (d_final, push_code) -> + schemeE d' s p' b `thenBc` \ body_code -> + let size = d_final - d_init + alloc = if is_con then nilOL else unitOL (ALLOC size) + pack = unitOL (if is_con then PACK the_dcon size else MKAP size size) + in + returnBc (alloc `appOL` push_code `appOL` pack + `appOL` body_code) + where + -- Decide whether we can do this or not + (ok_to_go, is_con, the_dcon, the_fn) + = case maybe_fn of + Nothing -> (False, bomb 1, bomb 2, bomb 3) + Just (Left fn) -> (True, False, bomb 5, fn) + Just (Right dcon) + | dataConRepArity dcon <= length args_r_to_l + -> (True, True, dcon, bomb 6) + | otherwise + -> (False, bomb 7, bomb 8, bomb 9) + bomb n = panic ("schemeE.is_con(hacky hack hack) " ++ show n) + + -- Extract the args (R -> L) and fn + args_r_to_l_reordered + | not is_con + = args_r_to_l + | otherwise + = filter (not.isPtr.snd) args_r_to_l ++ filter (isPtr.snd) args_r_to_l + where isPtr = isFollowableRep . atomRep + + args_r_to_l = filter (not.isTypeAtom.snd) args_r_to_l_raw + isTypeAtom (AnnType _) = True + isTypeAtom _ = False + + (args_r_to_l_raw, maybe_fn) = chomp rhs + chomp expr + = case snd expr of + AnnVar v + | isFCallId v || isPrimOpId v + -> ([], Nothing) + | otherwise + -> case isDataConId_maybe v of + Just dcon -> ([], Just (Right dcon)) + Nothing -> ([], Just (Left v)) + AnnApp f a -> case chomp f of (az, f) -> (a:az, f) + AnnNote n e -> chomp e + other -> ([], Nothing) + + -- This is the env in which to translate the body + p' = addToFM p x d + d' = d + 1 + + -- Shove the args on the stack, including the fn in the non-dcon case + tag_when_push = not is_con + + mkPushes :: Int{-curr depth-} -> [AnnExpr Id VarSet] + -> BcM (Int{-final depth-}, BCInstrList) + mkPushes dd [] + | is_con + = returnBc (dd, nilOL) + | otherwise + = pushAtom False dd p' (AnnVar the_fn) `thenBc` \ (fn_push_code, fn_szw) -> + returnBc (dd+fn_szw, fn_push_code) + mkPushes dd (atom:atoms) + = pushAtom tag_when_push dd p' (snd atom) + `thenBc` \ (push1_code, push1_szw) -> + mkPushes (dd+push1_szw) atoms `thenBc` \ (dd_final, push_rest) -> + returnBc (dd_final, push1_code `appOL` push_rest) + + +-- General case for let. Generates correct, if inefficient, code in +-- all situations. schemeE d s p (fvs, AnnLet binds b) = let (xs,rhss) = case binds of AnnNonRec x rhs -> ([x],[rhs]) AnnRec xs_n_rhss -> unzip xs_n_rhss n = length xs - fvss = map (filter (not.isTyVar).varSetElems.fst) rhss + + is_local id = not (isTyVar id) && elemFM id p' + fvss = map (filter is_local . varSetElems . fst) rhss -- Sizes of tagged free vars, + 1 for the fn sizes = map (\rhs_fvs -> 1 + sum (map taggedIdSizeW rhs_fvs)) fvss @@ -338,9 +441,13 @@ schemeE d s p (fvs, AnnLet binds b) returnBc (concatOL tcodes) allocCode = toOL (map ALLOC sizes) + + schemeRs [] _ _ = returnBc () + schemeRs (fvs:fvss) (x:xs) (rhs:rhss) = + schemeR False fvs (x,rhs) `thenBc_` schemeRs fvss xs rhss in schemeE d' s p' b `thenBc` \ bodyCode -> - mapBc (schemeR False) (zip xs rhss) `thenBc_` + schemeRs fvss xs rhss `thenBc_` genThunkCode `thenBc` \ thunkCode -> returnBc (allocCode `appOL` thunkCode `appOL` bodyCode) @@ -378,25 +485,30 @@ schemeE d s p (fvs_case, AnnCase (fvs_scrut, scrut) bndr -{- Convert case .... of (# VoidRep'd-thing, a #) -> ... - as - case .... of a -> ... - Use a as the name of the binder too. - - Also case .... of (# a #) -> ... - to - case .... of a -> ... --} schemeE d s p (fvs, AnnCase scrut bndr [(DataAlt dc, [bind1, bind2], rhs)]) | isUnboxedTupleCon dc && VoidRep == typePrimRep (idType bind1) + -- Convert + -- case .... of x { (# VoidRep'd-thing, a #) -> ... } + -- to + -- case .... of a { DEFAULT -> ... } + -- becuse the return convention for both are identical. + -- + -- 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 #)" ( - schemeE d s p (fvs, AnnCase scrut bind2 [(DEFAULT, [bind2], rhs)]) + schemeE d s p (fvs, AnnCase scrut bind2 [(DEFAULT, [], rhs)]) + -- Note: --) schemeE d s p (fvs, AnnCase scrut bndr [(DataAlt dc, [bind1], rhs)]) | isUnboxedTupleCon dc + -- Similarly, convert + -- case .... of x { (# a #) -> ... } + -- to + -- case .... of a { DEFAULT -> ... } = --trace "automagic mashing of case alts (# a #)" ( - schemeE d s p (fvs, AnnCase scrut bind1 [(DEFAULT, [bind1], rhs)]) + schemeE d s p (fvs, AnnCase scrut bind1 [(DEFAULT, [], rhs)]) --) schemeE d s p (fvs, AnnCase scrut bndr alts) @@ -416,13 +528,13 @@ schemeE d s p (fvs, AnnCase scrut bndr alts) isAlgCase | scrut_primrep == PtrRep = True - | scrut_primrep `elem` - [CharRep, AddrRep, WordRep, IntRep, FloatRep, DoubleRep, - VoidRep, Int8Rep, Int16Rep, Int32Rep, Int64Rep, - Word8Rep, Word16Rep, Word32Rep, Word64Rep] - = False - | otherwise - = pprPanic "ByteCodeGen.schemeE" (ppr scrut_primrep) + | otherwise + = WARN( scrut_primrep `elem` bad_reps, + text "Dire warning: strange rep in primitive case:" <+> ppr bndr ) + -- We don't expect to see any of these + False + where + bad_reps = [CodePtrRep, DataPtrRep, RetRep, CostCentreRep] -- given an alt, return a discr and code for it. codeAlt alt@(discr, binds_f, rhs) @@ -485,7 +597,7 @@ schemeE d s p other -- and enter. Four cases: -- -- 0. (Nasty hack). --- An application "PrelGHC.tagToEnum# unboxed-int". +-- An application "GHC.Prim.tagToEnum# unboxed-int". -- The int will be on the stack. Generate a code sequence -- to convert it to the relevant constructor, SLIDE and ENTER. -- @@ -536,17 +648,25 @@ schemeT d s p app ) -- Case 2 - | let isVoidRepAtom (_, AnnVar v) = VoidRep == typePrimRep (idType v) - isVoidRepAtom (_, AnnNote n e) = isVoidRepAtom e - in is_con_call && isUnboxedTupleCon con - && ( (args_r_to_l `lengthIs` 2 && isVoidRepAtom (last (args_r_to_l))) - || (isSingleton args_r_to_l) - ) + | is_con_call, + isUnboxedTupleCon con, -- (# ... #) + [(_,arg1),(_,arg2)] <- args_r_to_l, -- Exactly two args + let + isVoidRepAtom (AnnVar v) = typePrimRep (idType v) == VoidRep + isVoidRepAtom (AnnNote n (_,e)) = isVoidRepAtom e + isVoidRepAtom _ = False + in + isVoidRepAtom arg2 -- The first arg is void = --trace (if isSingleton args_r_to_l -- then "schemeT: unboxed singleton" -- else "schemeT: unboxed pair with Void first component") ( - schemeT d s p (head args_r_to_l) - --) + pushAtom True d p arg1 `thenBc` \ (push, szw) -> + returnBc (push -- value onto stack + `appOL` mkSLIDE szw (d-s) -- clear to sequel + `snocOL` RETURN (atomRep arg1)) -- go + -- We used to use "schemeT d s p arg1", but that is wrong. + -- We must use RETURN (because it's an unboxed tuple) + -- I think that this still does not work: SLPJ Oct 02 -- Case 3 | Just (CCall ccall_spec) <- isFCallId_maybe fn @@ -575,23 +695,34 @@ schemeT d s p app other -> Nothing -- Extract the args (R->L) and fn - (args_r_to_l_raw, fn) = chomp app + (args_r_to_l, fn) = chomp app chomp expr = case snd expr of AnnVar v -> ([], v) - AnnApp f a -> case chomp f of (az, f) -> (a:az, f) + AnnApp f a + | isTypeAtom (snd a) -> chomp f + | otherwise -> case chomp f of (az, f) -> (a:az, f) AnnNote n e -> chomp e other -> pprPanic "schemeT" - (ppr (deAnnotate (panic "schemeT.chomp", other))) - - args_r_to_l = filter (not.isTypeAtom.snd) args_r_to_l_raw + (ppr (deAnnotate (panic "schemeT.chomp", other))) + + n_args = length args_r_to_l + isTypeAtom (AnnType _) = True isTypeAtom _ = False - -- decide if this is a constructor call, and rearrange - -- args appropriately. - maybe_dcon = isDataConId_maybe fn - is_con_call = case maybe_dcon of Nothing -> False; Just _ -> True + -- decide if this is a constructor application, because we need + -- to rearrange the arguments on the stack if so. For building + -- a constructor, we put pointers before non-pointers and omit + -- the tags. + -- + -- Also if the constructor is not saturated, we just arrange to + -- call the curried worker instead. + + maybe_dcon = case isDataConId_maybe fn of + Just con | dataConRepArity con == n_args -> Just con + _ -> Nothing + is_con_call = isJust maybe_dcon (Just con) = maybe_dcon args_final_r_to_l @@ -628,7 +759,6 @@ schemeT d s p app `snocOL` ENTER) - {- 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 @@ -655,14 +785,16 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l pargs d [] = returnBc [] pargs d ((_,a):az) - = let rep_arg = atomRep a - in case rep_arg of + = let arg_ty = repType (exprType (deAnnotate' a)) + + in case splitTyConApp_maybe arg_ty of -- Don't push the FO; instead push the Addr# it -- contains. - ForeignObjRep + Just (t, _) + | t == foreignObjPrimTyCon -> pushAtom False{-irrelevant-} d p a `thenBc` \ (push_fo, _) -> - let foro_szW = taggedSizeW ForeignObjRep + let foro_szW = taggedSizeW PtrRep d_now = d + addr_tsizeW code = push_fo `appOL` toOL [ UPK_TAG addr_usizeW 0 0, @@ -671,13 +803,13 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l in pargs d_now az `thenBc` \ rest -> returnBc ((code, AddrRep) : rest) - ArrayRep + | t == arrayPrimTyCon || t == mutableArrayPrimTyCon -> pargs (d + addr_tsizeW) az `thenBc` \ rest -> parg_ArrayishRep arrPtrsHdrSize d p a `thenBc` \ code -> returnBc ((code,AddrRep):rest) - ByteArrayRep + | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon -> pargs (d + addr_tsizeW) az `thenBc` \ rest -> parg_ArrayishRep arrWordsHdrSize d p a `thenBc` \ code -> @@ -687,7 +819,7 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l other -> pushAtom True d p a `thenBc` \ (code_a, sz_a) -> pargs (d+sz_a) az `thenBc` \ rest -> - returnBc ((code_a, rep_arg) : rest) + returnBc ((code_a, atomRep a) : rest) -- 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 @@ -766,12 +898,8 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l DynamicTarget -> returnBc (False, panic "ByteCodeGen.generateCCall(dyn)") StaticTarget target - -> let sym_to_find = _UNPK_ target in - ioToBc (lookupSymbol sym_to_find) `thenBc` \res -> - case res of - Just aa -> case aa of Ptr a# -> returnBc (True, A# a#) - Nothing -> ioToBc (linkFail "ByteCodeGen.generateCCall" - sym_to_find) + -> ioToBc (lookupStaticPtr target) `thenBc` \res -> + returnBc (True, res) CasmTarget _ -> pprPanic "ByteCodeGen.generateCCall: casm" (ppr ccall_spec) in @@ -819,7 +947,7 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l recordMallocBc addr_of_marshaller `thenBc_` let -- do the call - do_call = unitOL (CCALL addr_of_marshaller) + do_call = unitOL (CCALL (castPtr addr_of_marshaller)) -- slide and return wrapup = mkSLIDE r_tsizeW (d_after_r - r_tsizeW - s) `snocOL` RETURN r_rep @@ -847,22 +975,22 @@ mkDummyLiteral pr -- Convert (eg) --- PrelGHC.Char# -> PrelGHC.State# PrelGHC.RealWorld --- -> (# PrelGHC.State# PrelGHC.RealWorld, PrelGHC.Int# #) +-- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld +-- -> (# 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. -- -- Alternatively, for call-targets returning nothing, convert -- --- PrelGHC.Char# -> PrelGHC.State# PrelGHC.RealWorld --- -> (# PrelGHC.State# PrelGHC.RealWorld #) +-- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld +-- -> (# GHC.Prim.State# GHC.Prim.RealWorld #) -- -- to Nothing maybe_getCCallReturnRep :: Type -> Maybe PrimRep maybe_getCCallReturnRep fn_ty - = let (a_tys, r_ty) = splitRepFunTys 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) @@ -892,13 +1020,12 @@ atomRep (AnnApp f (_, AnnType _)) = atomRep (snd f) atomRep (AnnLam x e) | isTyVar x = atomRep (snd e) atomRep other = pprPanic "atomRep" (ppr (deAnnotate (undefined,other))) - -- Compile code which expects an unboxed Int on the top of stack, -- (call it i), and pushes the i'th closure in the supplied list -- as a consequence. implement_tagToId :: [Name] -> BcM BCInstrList implement_tagToId names - = ASSERT(not (null names)) + = ASSERT( notNull names ) getLabelsBc (length names) `thenBc` \ labels -> getLabelBc `thenBc` \ label_fail -> getLabelBc `thenBc` \ label_exit -> @@ -977,7 +1104,8 @@ mkUnpackCode vars d p code_np = do_nptrs vreps_env_uszw ptrs_szw (reverse (map snd vreps_np)) do_nptrs off_h off_s [] = nilOL do_nptrs off_h off_s (npr:nprs) - | npr `elem` [IntRep, WordRep, FloatRep, DoubleRep, CharRep, AddrRep] + | npr `elem` [IntRep, WordRep, FloatRep, DoubleRep, + CharRep, AddrRep, StablePtrRep] = approved | otherwise = moan64 "ByteCodeGen.mkUnpackCode" (ppr npr) @@ -1058,6 +1186,7 @@ pushAtom True d p (AnnLit lit) pushAtom False d p (AnnLit lit) = case lit of + MachLabel fs -> code CodePtrRep MachWord w -> code WordRep MachInt i -> code IntRep MachFloat r -> code FloatRep @@ -1073,8 +1202,6 @@ pushAtom False d p (AnnLit lit) pushStr s = let getMallocvilleAddr = case s of - CharStr s i -> returnBc (A# s) - FastString _ l ba -> -- sigh, a string in the heap is no good to us. -- We need a static C pointer, since the type of @@ -1083,12 +1210,12 @@ pushAtom False d p (AnnLit lit) -- at the same time. let n = I# l -- CAREFUL! Chars are 32 bits in ghc 4.09+ - in ioToBc (mallocBytes (n+1)) `thenBc` \ (Ptr a#) -> - recordMallocBc (A# a#) `thenBc_` + in ioToBc (mallocBytes (n+1)) `thenBc` \ ptr -> + recordMallocBc ptr `thenBc_` ioToBc ( - do strncpy (Ptr a#) ba (fromIntegral n) - writeCharOffAddr (A# a#) n '\0' - return (A# a#) + do memcpy ptr ba (fromIntegral n) + pokeByteOff ptr n (fromIntegral (ord '\0') :: Word8) + return ptr ) other -> panic "ByteCodeGen.pushAtom.pushStr" in @@ -1114,7 +1241,7 @@ pushAtom tagged d p other = pprPanic "ByteCodeGen.pushAtom" (pprCoreExpr (deAnnotate (undefined, other))) -foreign import "strncpy" strncpy :: Ptr a -> ByteArray# -> CInt -> IO () +foreign import "memcpy" memcpy :: Ptr a -> ByteArray# -> CInt -> IO () -- Given a bunch of alts code and their discrs, do the donkey work @@ -1290,7 +1417,7 @@ bind x f = f x data BcM_State = BcM_State { bcos :: [ProtoBCO Name], -- accumulates completed BCOs nextlabel :: Int, -- for generating local labels - malloced :: [Addr] } -- ptrs malloced for current BCO + malloced :: [Ptr ()] } -- ptrs malloced for current BCO -- Should be free()d when it is GCd type BcM r = BcM_State -> IO (BcM_State, r) @@ -1325,20 +1452,20 @@ mapBc f (x:xs) mapBc f xs `thenBc` \ rs -> returnBc (r:rs) -emitBc :: ([Addr] -> ProtoBCO Name) -> BcM () +emitBc :: ([Ptr ()] -> ProtoBCO Name) -> BcM () emitBc bco st = return (st{bcos = bco (malloced st) : bcos st, malloced=[]}, ()) newbcoBc :: BcM () newbcoBc st - | not (null (malloced st)) + | notNull (malloced st) = panic "ByteCodeGen.newbcoBc: missed prior emitBc?" | otherwise = return (st, ()) -recordMallocBc :: Addr -> BcM () +recordMallocBc :: Ptr a -> BcM () recordMallocBc a st - = return (st{malloced = a : malloced st}, ()) + = return (st{malloced = castPtr a : malloced st}, ()) getLabelBc :: BcM Int getLabelBc st