diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/codeGen/StgCmmPrim.hs | 5 | ||||
| -rw-r--r-- | compiler/prelude/PrelNames.hs | 4 | ||||
| -rw-r--r-- | compiler/prelude/TysPrim.hs | 19 | ||||
| -rw-r--r-- | compiler/prelude/primops.txt.pp | 101 |
4 files changed, 126 insertions, 3 deletions
diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index 84f263cc3c..d3c09c584e 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -351,7 +351,6 @@ emitPrimOp dflags [res] EqStableNameOp [arg1,arg2] cmmLoadIndexW dflags arg2 (fixedHdrSizeW dflags) (bWord dflags) ]) - emitPrimOp dflags [res] ReallyUnsafePtrEqualityOp [arg1,arg2] = emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [arg1,arg2]) @@ -359,6 +358,10 @@ emitPrimOp dflags [res] ReallyUnsafePtrEqualityOp [arg1,arg2] emitPrimOp _ [res] AddrToAnyOp [arg] = emitAssign (CmmLocal res) arg +-- #define hvalueToAddrzh(r, a) r=(W_)a +emitPrimOp _ [res] AnyToAddrOp [arg] + = emitAssign (CmmLocal res) arg + -- #define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info)) -- Note: argument may be tagged! emitPrimOp dflags [res] DataToTagOp [arg] diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs index 483006f638..4d5e378f57 100644 --- a/compiler/prelude/PrelNames.hs +++ b/compiler/prelude/PrelNames.hs @@ -1579,7 +1579,8 @@ statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey, liftedConKey, unliftedConKey, anyBoxConKey, kindConKey, boxityConKey, typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey, funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey, - eqReprPrimTyConKey, eqPhantPrimTyConKey, voidPrimTyConKey :: Unique + eqReprPrimTyConKey, eqPhantPrimTyConKey, voidPrimTyConKey, + compactPrimTyConKey :: Unique statePrimTyConKey = mkPreludeTyConUnique 50 stableNamePrimTyConKey = mkPreludeTyConUnique 51 stableNameTyConKey = mkPreludeTyConUnique 52 @@ -1608,6 +1609,7 @@ bcoPrimTyConKey = mkPreludeTyConUnique 74 ptrTyConKey = mkPreludeTyConUnique 75 funPtrTyConKey = mkPreludeTyConUnique 76 tVarPrimTyConKey = mkPreludeTyConUnique 77 +compactPrimTyConKey = mkPreludeTyConUnique 78 -- Parallel array type constructor parrTyConKey :: Unique diff --git a/compiler/prelude/TysPrim.hs b/compiler/prelude/TysPrim.hs index 376a0bbe43..19728ee430 100644 --- a/compiler/prelude/TysPrim.hs +++ b/compiler/prelude/TysPrim.hs @@ -59,6 +59,7 @@ module TysPrim( tVarPrimTyCon, mkTVarPrimTy, stablePtrPrimTyCon, mkStablePtrPrimTy, stableNamePrimTyCon, mkStableNamePrimTy, + compactPrimTyCon, compactPrimTy, bcoPrimTyCon, bcoPrimTy, weakPrimTyCon, mkWeakPrimTy, threadIdPrimTyCon, threadIdPrimTy, @@ -138,6 +139,7 @@ primTyCons , realWorldTyCon , stablePtrPrimTyCon , stableNamePrimTyCon + , compactPrimTyCon , statePrimTyCon , voidPrimTyCon , proxyPrimTyCon @@ -170,7 +172,7 @@ mkBuiltInPrimTc fs unique tycon BuiltInSyntax -charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, proxyPrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName, voidPrimTyConName :: Name +charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, proxyPrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName, voidPrimTyConName :: Name charPrimTyConName = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon intPrimTyConName = mkPrimTc (fsLit "Int#") intPrimTyConKey intPrimTyCon int32PrimTyConName = mkPrimTc (fsLit "Int32#") int32PrimTyConKey int32PrimTyCon @@ -201,6 +203,7 @@ mVarPrimTyConName = mkPrimTc (fsLit "MVar#") mVarPrimTyConKey mVarPr tVarPrimTyConName = mkPrimTc (fsLit "TVar#") tVarPrimTyConKey tVarPrimTyCon stablePtrPrimTyConName = mkPrimTc (fsLit "StablePtr#") stablePtrPrimTyConKey stablePtrPrimTyCon stableNamePrimTyConName = mkPrimTc (fsLit "StableName#") stableNamePrimTyConKey stableNamePrimTyCon +compactPrimTyConName = mkPrimTc (fsLit "Compact#") compactPrimTyConKey compactPrimTyCon bcoPrimTyConName = mkPrimTc (fsLit "BCO#") bcoPrimTyConKey bcoPrimTyCon weakPrimTyConName = mkPrimTc (fsLit "Weak#") weakPrimTyConKey weakPrimTyCon threadIdPrimTyConName = mkPrimTc (fsLit "ThreadId#") threadIdPrimTyConKey threadIdPrimTyCon @@ -893,6 +896,20 @@ mkStableNamePrimTy ty = TyConApp stableNamePrimTyCon [ty] {- ************************************************************************ * * +\subsection[TysPrim-compact-nfdata]{The Compact NFData (CNF) type} +* * +************************************************************************ +-} + +compactPrimTyCon :: TyCon +compactPrimTyCon = pcPrimTyCon0 compactPrimTyConName PtrRep + +compactPrimTy :: Type +compactPrimTy = mkTyConTy compactPrimTyCon + +{- +************************************************************************ +* * \subsection[TysPrim-BCOs]{The ``bytecode object'' type} * * ************************************************************************ diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index bfeb7852c6..9fd5d17f14 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -2426,6 +2426,92 @@ primop StableNameToIntOp "stableNameToInt#" GenPrimOp StableName# a -> Int# ------------------------------------------------------------------------ +section "Compact normal form" +------------------------------------------------------------------------ + +primtype Compact# + +primop CompactNewOp "compactNew#" GenPrimOp + Word# -> State# RealWorld -> (# State# RealWorld, Compact# #) + { Create a new Compact with the given size (in bytes, not words). + The size is rounded up to a multiple of the allocator block size, + and capped to one mega block. } + with + has_side_effects = True + out_of_line = True + +primop CompactAppendOp "compactAppend#" GenPrimOp + Compact# -> a -> Int# -> State# RealWorld -> (# State# RealWorld, a #) + { Append an object to a compact, return the new address in the Compact. + The third argument is 1 if sharing should be preserved, 0 otherwise. } + with + has_side_effects = True + out_of_line = True + +primop CompactResizeOp "compactResize#" GenPrimOp + Compact# -> Word# -> State# RealWorld -> + State# RealWorld + { Set the new allocation size of the compact. This value (in bytes) + determines the size of each block in the compact chain. } + with + has_side_effects = True + out_of_line = True + +primop CompactContainsOp "compactContains#" GenPrimOp + Compact# -> a -> State# RealWorld -> (# State# RealWorld, Int# #) + { Returns 1# if the object is contained in the compact, 0# otherwise. } + with + out_of_line = True + +primop CompactContainsAnyOp "compactContainsAny#" GenPrimOp + a -> State# RealWorld -> (# State# RealWorld, Int# #) + { Returns 1# if the object is in any compact at all, 0# otherwise. } + with + out_of_line = True + +primop CompactGetFirstBlockOp "compactGetFirstBlock#" GenPrimOp + Compact# -> State# RealWorld -> (# State# RealWorld, Addr#, Word# #) + { Returns the address and the size (in bytes) of the first block of + a compact. } + with + out_of_line = True + +primop CompactGetNextBlockOp "compactGetNextBlock#" GenPrimOp + Compact# -> Addr# -> State# RealWorld -> (# State# RealWorld, Addr#, Word# #) + { Given a compact and the address of one its blocks, returns the + next block and its size, or #nullAddr if the argument was the + last block in the compact. } + with + out_of_line = True + +primop CompactAllocateBlockOp "compactAllocateBlock#" GenPrimOp + Word# -> Addr# -> State# RealWorld -> (# State# RealWorld, Addr# #) + { Attempt to allocate a compact block with the given size (in + bytes) at the given address. The first argument is a hint to + the allocator, allocation might be satisfied at a different + address (which is returned). + The resulting block is not known to the GC until + compactFixupPointers# is called on it, and care must be taken + so that the address does not escape or memory will be leaked. + } + with + has_side_effects = True + out_of_line = True + +primop CompactFixupPointersOp "compactFixupPointers#" GenPrimOp + Addr# -> Addr# -> State# RealWorld -> (# State# RealWorld, Compact#, Addr# #) + { Given the pointer to the first block of a compact, and the + address of the root object in the old address space, fix up + the internal pointers inside the compact to account for + a different position in memory than when it was serialized. + This method must be called exactly once after importing + a serialized compact, and returns the new compact and + the new adjusted root address. } + with + has_side_effects = True + out_of_line = True + +------------------------------------------------------------------------ section "Unsafe pointer equality" -- (#1 Bad Guy: Alistair Reid :) ------------------------------------------------------------------------ @@ -2507,6 +2593,21 @@ primop AddrToAnyOp "addrToAny#" GenPrimOp with code_size = 0 +primop AnyToAddrOp "anyToAddr#" GenPrimOp + a -> State# RealWorld -> (# State# RealWorld, Addr# #) + { Retrive the address of any Haskell value. This is + essentially an {\texttt unsafeCoerce\#}, but if implemented as such + the core lint pass complains and fails to compile. + As a primop, it is opaque to core/stg, and only appears + in cmm (where the copy propagation pass will get rid of it). + Note that "a" must be a value, not a thunk! It's too late + for strictness analysis to enforce this, so you're on your + own to guarantee this. Also note that {\texttt Addr\#} is not a GC + pointer - up to you to guarantee that it does not become + a dangling pointer immediately after you get it.} + with + code_size = 0 + primop MkApUpd0_Op "mkApUpd0#" GenPrimOp BCO# -> (# a #) { Wrap a BCO in a {\tt AP_UPD} thunk which will be updated with the value of |