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 CoreFVs ( freeVars )
import Type ( isUnLiftedType, splitTyConApp_maybe )
import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon,
- isUnboxedTupleCon, isNullaryDataCon, dataConWorkId,
+ isUnboxedTupleCon, isNullaryRepDataCon, dataConWorkId,
dataConRepArity )
-import TyCon ( tyConFamilySize, isDataTyCon, tyConDataCons,
- isUnboxedTupleTyCon )
+import TyCon ( TyCon, tyConFamilySize, isDataTyCon,
+ tyConDataCons, isUnboxedTupleTyCon )
import Class ( Class, classTyCon )
import Type ( Type, repType, splitFunTys, dropForAlls, pprType )
import Util
import TysPrim ( arrayPrimTyCon, mutableArrayPrimTyCon,
byteArrayPrimTyCon, mutableByteArrayPrimTyCon
)
-import CmdLineOpts ( DynFlags, DynFlag(..) )
+import DynFlags ( DynFlags, DynFlag(..) )
import ErrUtils ( showPass, dumpIfSet_dyn )
import Unique ( mkPseudoUniqueE )
import FastString ( FastString(..), unpackFS )
import Constants ( wORD_SIZE )
import Data.List ( intersperse, sortBy, zip4, zip5, partition )
-import Foreign ( Ptr, castPtr, mallocBytes, pokeByteOff, Word8 )
+import Foreign ( Ptr, castPtr, mallocBytes, pokeByteOff, Word8,
+ withForeignPtr )
import Foreign.C ( CInt )
import Control.Exception ( throwDyn )
byteCodeGen :: DynFlags
-> [CoreBind]
- -> TypeEnv
+ -> [TyCon]
-> IO CompiledByteCode
-byteCodeGen dflags binds 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]
-- 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 (mkPseudoUniqueE 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)
schemeTopBind (id, rhs)
| Just data_con <- isDataConWorkId_maybe id,
- isNullaryDataCon data_con
+ isNullaryRepDataCon data_con
= -- Special case for the worker of a nullary data con.
-- It'll look like this: Nil = /\a -> Nil a
-- If we feed it into schemeR, we'll get
-schemeE d s p (AnnCase scrut bndr [(DataAlt dc, [bind1, bind2], rhs)])
+schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)])
| isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind1)
-- Convert
-- case .... of x { (# VoidArg'd-thing, a #) -> ... }
= --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 #) -> ... }
= --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))
-> 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.
= 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))
return (final_d, push_code `appOL` more_push_code)
-- v. similar to CgStackery.findMatch, ToDo: merge
-findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: rest)
- = (PUSH_APPLY_PPPPPPP, 7, rest)
findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: rest)
= (PUSH_APPLY_PPPPPP, 6, rest)
findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: rest)
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"
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
)
(pprCoreExpr (deAnnotate (undefined, other)))
foreign import ccall unsafe "memcpy"
- memcpy :: Ptr a -> ByteArray# -> CInt -> IO ()
+ memcpy :: Ptr a -> Ptr b -> CInt -> IO ()
-- -----------------------------------------------------------------------------
-- 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)]
projects / ghc-hetmet.git / blobdiff