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]
-- 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)
$$ 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
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) slots
- init
- | size >= 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
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.
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
`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
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.
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
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
-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.
-- 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 #) -> ... }
= --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))
--
-- 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.
| 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
-- 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
-- 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
-> 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 )
-> 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))
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"
-- 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
= 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
-- 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
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)
-- 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.
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)
-> 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
-- 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 ->
(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)
-- 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
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"
= (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
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
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
-- 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)
-- -> (# 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
--
--
-- 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
pushAtom d p (AnnVar v)
- | idPrimRep v == VoidRep
+ | idCgRep v == VoidArg
= returnBc (nilOL, 0)
| isFCallId 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
)
(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)]
-> 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)
lookupBCEnv_maybe = lookupFM
idSizeW :: Id -> Int
-idSizeW id = getPrimRepSize (typePrimRep (idType id))
+idSizeW id = cgRepSizeW (typeCgRep (idType id))
unboxedTupleException :: a
unboxedTupleException
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
projects / ghc-hetmet.git / blobdiff