import TyCon ( 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 Linker ( lookupSymbol )
import List ( intersperse, sortBy, zip4 )
-import Foreign ( Ptr(..), mallocBytes )
-import Addr ( Addr(..), writeCharOffAddr )
+import Foreign ( Ptr(..), castPtr, mallocBytes, pokeByteOff, Word8 )
import CTypes ( CInt )
import Exception ( throwDyn )
-import PrelBase ( Int(..) )
-import PrelGHC ( ByteArray# )
-import PrelIOBase ( IO(..) )
+import GlaExts ( Int(..), ByteArray# )
+
import Monad ( when )
import Maybe ( isJust )
+import Char ( ord )
\end{code}
%************************************************************************
-- ^^
-- 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
-- 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_id = mkSysLocal FSLIT("Expr-Top-Level")
+ (mkPseudoUnique3 0)
+ (panic "invented_id's type")
let invented_name = idName invented_id
annexpr = freeVars expr
<- 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
-- and enter. Four cases:
--
-- 0. (Nasty hack).
--- An application "PrelGHC.tagToEnum# <type> unboxed-int".
+-- An application "GHC.Prim.tagToEnum# <type> unboxed-int".
-- The int will be on the stack. Generate a code sequence
-- to convert it to the relevant constructor, SLIDE and ENTER.
--
)
-- 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
DynamicTarget
-> returnBc (False, panic "ByteCodeGen.generateCCall(dyn)")
StaticTarget target
- -> let sym_to_find = _UNPK_ target in
+ -> let sym_to_find = unpackFS target in
ioToBc (lookupSymbol sym_to_find) `thenBc` \res ->
case res of
- Just aa -> case aa of Ptr a# -> returnBc (True, A# a#)
+ Just aa -> returnBc (True, aa)
Nothing -> ioToBc (linkFail "ByteCodeGen.generateCCall"
sym_to_find)
CasmTarget _
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
-- 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)
-- 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 ->
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)
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
pushStr s
= let getMallocvilleAddr
= case s of
- CharStr s i -> returnBc (A# s)
+ CharStr s i -> returnBc (Ptr s)
FastString _ l ba ->
-- sigh, a string in the heap is no good to us.
-- 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 memcpy (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
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)
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
projects / ghc-hetmet.git / blobdiff