X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FByteCodeGen.lhs;h=72f4d620435f42c8778a2940534d5083317d1cb8;hb=32c62212b35b2b631f3753d432b508de5c79c783;hp=55f0da86febeea2db6edc3c3714b6598604ad1d6;hpb=7bf9669c948c96eddb1b44d8ccef792f84ff7861;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs index 55f0da8..72f4d62 100644 --- a/ghc/compiler/ghci/ByteCodeGen.lhs +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -4,68 +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, isPrimOpId ) + 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, 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 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} %************************************************************************ @@ -77,13 +80,13 @@ import Maybe ( isJust ) \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)] @@ -95,15 +98,13 @@ byteCodeGen dflags binds local_tycons local_classes -- ^^ -- 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, @@ -116,18 +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 - - annexpr = freeVars expr - fvs = filter (not.isTyVar) (varSetElems (fst annexpr)) + 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 fvs (invented_id, annexpr)) - when (not (null mallocd)) + when (notNull mallocd) (panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?") dumpIfSet_dyn dflags Opt_D_dump_BCOs @@ -288,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) -> @@ -314,11 +315,9 @@ schemeE d s p (fvs, AnnLit literal) let x = fn atom1 .. atomn in B and let x = Con atom1 .. atomn in B - (Con must be saturated, and atom1 .. n must be ptr-rep'd) + (Con must be saturated) - In these cases, generate code to allocate in-line. The ptr-rep'd - restriction avoids the problem of having to reorder constructor - args. + 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 @@ -327,13 +326,14 @@ schemeE d s p (fvs, AnnLit literal) This optimisation should be done more cleanly. As-is, it is inapplicable to RHSs in letrecs, and needlessly duplicates code in - schemeR. Some refactoring of the machinery would cure both ills. + 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 order_in_which_to_push `thenBc` \ (d_final, push_code) -> + 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) @@ -348,20 +348,24 @@ schemeE d s p ee@(fvs, AnnLet (AnnNonRec x rhs) b) Nothing -> (False, bomb 1, bomb 2, bomb 3) Just (Left fn) -> (True, False, bomb 5, fn) Just (Right dcon) - | all isPtrRepdVar args_r_to_l - && dataConRepArity dcon <= length args_r_to_l + | 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) - isPtrRepdVar (_, AnnVar v) = isFollowableRep (idPrimRep v) - isPtrRepdVar (_, AnnNote n e) = isPtrRepdVar e - isPtrRepdVar (_, AnnApp f (_, AnnType _)) = isPtrRepdVar f - isPtrRepdVar _ = False - -- Extract the args (R -> L) and fn - order_in_which_to_push = map snd args_r_to_l + 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 @@ -372,29 +376,28 @@ schemeE d s p ee@(fvs, AnnLet (AnnNonRec x rhs) b) -> 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) - args_r_to_l = filter (not.isTypeAtom.snd) args_r_to_l_raw - isTypeAtom (AnnType _) = True - isTypeAtom _ = False -- 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 - mkPushes :: Int{-curr depth-} -> [AnnExpr' Id VarSet] + 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 True dd p' (AnnVar the_fn) `thenBc` \ (fn_push_code, fn_szw) -> + = 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 True dd p' atom `thenBc` \ (push1_code, push1_szw) -> + = 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) @@ -482,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) @@ -520,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) @@ -589,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. -- @@ -640,16 +648,17 @@ schemeT d s p app ) -- Case 2 - | let isVoidRepAtom (_, AnnVar v) = VoidRep == typePrimRep (idType v) + | [arg1,arg2] <- args_r_to_l, + let + isVoidRepAtom (_, AnnVar v) = typePrimRep (idType v) == VoidRep 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) - ) + isVoidRepAtom _ = False + in + isVoidRepAtom arg2 = --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) + schemeT d s p arg1 --) -- Case 3 @@ -769,14 +778,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, @@ -785,13 +796,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 -> @@ -801,7 +812,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 @@ -880,12 +891,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 @@ -933,7 +940,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 @@ -961,22 +968,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) @@ -1006,13 +1013,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 -> @@ -1091,7 +1097,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) @@ -1172,6 +1179,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 @@ -1187,8 +1195,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 @@ -1197,12 +1203,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 @@ -1228,7 +1234,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 @@ -1404,7 +1410,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) @@ -1439,20 +1445,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