import Var ( TyVar )
import CallConv ( CallConv, pprCallConv )
import PprType ( pprParendType )
-import OccName ( OccName, pprOccName, varOcc )
-import TyCon ( TyCon )
-import Type ( mkForAllTys, mkForAllTy, mkFunTy, mkFunTys,
- mkTyConApp, typePrimRep,
+import OccName ( OccName, pprOccName, mkSrcVarOcc )
+import TyCon ( TyCon, tyConArity )
+import Type ( mkForAllTys, mkForAllTy, mkFunTy, mkFunTys, mkTyVarTys,
+ mkTyConTy, mkTyConApp, typePrimRep,
splitAlgTyConApp, Type, isUnboxedTupleType,
splitAlgTyConApp_maybe
)
| MkWeakOp
| DeRefWeakOp
+ | FinaliseWeakOp
+
+ | MakeStableNameOp
+ | EqStableNameOp
+ | StableNameToIntOp
| MakeStablePtrOp
| DeRefStablePtrOp
tagOf_PrimOp WriteForeignObjOp = ILIT(202)
tagOf_PrimOp MkWeakOp = ILIT(203)
tagOf_PrimOp DeRefWeakOp = ILIT(204)
-tagOf_PrimOp MakeStablePtrOp = ILIT(205)
-tagOf_PrimOp DeRefStablePtrOp = ILIT(206)
-tagOf_PrimOp EqStablePtrOp = ILIT(207)
-tagOf_PrimOp (CCallOp _ _ _ _) = ILIT(208)
-tagOf_PrimOp ReallyUnsafePtrEqualityOp = ILIT(209)
-tagOf_PrimOp SeqOp = ILIT(210)
-tagOf_PrimOp ParOp = ILIT(211)
-tagOf_PrimOp ForkOp = ILIT(212)
-tagOf_PrimOp KillThreadOp = ILIT(213)
-tagOf_PrimOp DelayOp = ILIT(214)
-tagOf_PrimOp WaitReadOp = ILIT(215)
-tagOf_PrimOp WaitWriteOp = ILIT(216)
-tagOf_PrimOp ParGlobalOp = ILIT(217)
-tagOf_PrimOp ParLocalOp = ILIT(218)
-tagOf_PrimOp ParAtOp = ILIT(219)
-tagOf_PrimOp ParAtAbsOp = ILIT(220)
-tagOf_PrimOp ParAtRelOp = ILIT(221)
-tagOf_PrimOp ParAtForNowOp = ILIT(222)
-tagOf_PrimOp CopyableOp = ILIT(223)
-tagOf_PrimOp NoFollowOp = ILIT(224)
-tagOf_PrimOp NewMutVarOp = ILIT(225)
-tagOf_PrimOp ReadMutVarOp = ILIT(226)
-tagOf_PrimOp WriteMutVarOp = ILIT(227)
-tagOf_PrimOp SameMutVarOp = ILIT(228)
-tagOf_PrimOp CatchOp = ILIT(229)
-tagOf_PrimOp RaiseOp = ILIT(230)
+tagOf_PrimOp FinaliseWeakOp = ILIT(205)
+tagOf_PrimOp MakeStableNameOp = ILIT(206)
+tagOf_PrimOp EqStableNameOp = ILIT(207)
+tagOf_PrimOp StableNameToIntOp = ILIT(208)
+tagOf_PrimOp MakeStablePtrOp = ILIT(209)
+tagOf_PrimOp DeRefStablePtrOp = ILIT(210)
+tagOf_PrimOp EqStablePtrOp = ILIT(211)
+tagOf_PrimOp (CCallOp _ _ _ _) = ILIT(212)
+tagOf_PrimOp ReallyUnsafePtrEqualityOp = ILIT(213)
+tagOf_PrimOp SeqOp = ILIT(214)
+tagOf_PrimOp ParOp = ILIT(215)
+tagOf_PrimOp ForkOp = ILIT(216)
+tagOf_PrimOp KillThreadOp = ILIT(217)
+tagOf_PrimOp DelayOp = ILIT(218)
+tagOf_PrimOp WaitReadOp = ILIT(219)
+tagOf_PrimOp WaitWriteOp = ILIT(220)
+tagOf_PrimOp ParGlobalOp = ILIT(221)
+tagOf_PrimOp ParLocalOp = ILIT(222)
+tagOf_PrimOp ParAtOp = ILIT(223)
+tagOf_PrimOp ParAtAbsOp = ILIT(224)
+tagOf_PrimOp ParAtRelOp = ILIT(225)
+tagOf_PrimOp ParAtForNowOp = ILIT(226)
+tagOf_PrimOp CopyableOp = ILIT(227)
+tagOf_PrimOp NoFollowOp = ILIT(228)
+tagOf_PrimOp NewMutVarOp = ILIT(229)
+tagOf_PrimOp ReadMutVarOp = ILIT(230)
+tagOf_PrimOp WriteMutVarOp = ILIT(231)
+tagOf_PrimOp SameMutVarOp = ILIT(232)
+tagOf_PrimOp CatchOp = ILIT(233)
+tagOf_PrimOp RaiseOp = ILIT(234)
tagOf_PrimOp op = pprPanic# "tagOf_PrimOp: pattern-match" (ppr op)
--panic# "tagOf_PrimOp: pattern-match"
WriteForeignObjOp,
MkWeakOp,
DeRefWeakOp,
+ FinaliseWeakOp,
+ MakeStableNameOp,
+ EqStableNameOp,
+ StableNameToIntOp,
MakeStablePtrOp,
DeRefStablePtrOp,
EqStablePtrOp,
[Type]
Type
-mkDyadic str ty = Dyadic (varOcc str) ty
-mkMonadic str ty = Monadic (varOcc str) ty
-mkCompare str ty = Compare (varOcc str) ty
-mkGenPrimOp str tvs tys ty = GenPrimOp (varOcc str) tvs tys ty
+mkDyadic str ty = Dyadic (mkSrcVarOcc str) ty
+mkMonadic str ty = Monadic (mkSrcVarOcc str) ty
+mkCompare str ty = Compare (mkSrcVarOcc str) ty
+mkGenPrimOp str tvs tys ty = GenPrimOp (mkSrcVarOcc str) tvs tys ty
\end{code}
Utility bits:
primOpStrictness RaiseOp = ([wwLazy], True) -- NB: True => result is bottom
primOpStrictness MkWeakOp = ([wwLazy, wwLazy, wwLazy, wwPrim], False)
+primOpStrictness MakeStableNameOp = ([wwLazy, wwPrim], False)
primOpStrictness MakeStablePtrOp = ([wwLazy, wwPrim], False)
-- The rest all have primitive-typed arguments
s = alphaTy; s_tv = alphaTyVar
op_str = _PK_ ("read" ++ primRepString kind ++ "Array#")
- relevant_type = assoc "primOpInfo{ReadByteArrayOp}" tbl kind
+ (tvs, prim_ty) = mkPrimTyApp betaTyVars kind
state = mkStatePrimTy s
-
- tvs
- | kind == StablePtrRep = [s_tv, betaTyVar]
- | otherwise = [s_tv]
in
- mkGenPrimOp op_str tvs
+ mkGenPrimOp op_str (s_tv:tvs)
[mkMutableByteArrayPrimTy s, intPrimTy, state]
- (unboxedPair [state, relevant_type])
- where
- tbl = [ (CharRep, charPrimTy),
- (IntRep, intPrimTy),
- (WordRep, wordPrimTy),
- (AddrRep, addrPrimTy),
- (FloatRep, floatPrimTy),
- (StablePtrRep, mkStablePtrPrimTy betaTy),
- (DoubleRep, doublePrimTy) ]
-
- -- How come there's no Word byte arrays? ADR
+ (unboxedPair [state, prim_ty])
primOpInfo (WriteByteArrayOp kind)
= let
s = alphaTy; s_tv = alphaTyVar
op_str = _PK_ ("write" ++ primRepString kind ++ "Array#")
- prim_ty = mkTyConApp (primRepTyCon kind) []
-
- (the_prim_ty, tvs)
- | kind == StablePtrRep = (mkStablePtrPrimTy betaTy, [s_tv, betaTyVar])
- | otherwise = (prim_ty, [s_tv])
-
+ (tvs, prim_ty) = mkPrimTyApp betaTyVars kind
in
- mkGenPrimOp op_str tvs
- [mkMutableByteArrayPrimTy s, intPrimTy, the_prim_ty, mkStatePrimTy s]
+ mkGenPrimOp op_str (s_tv:tvs)
+ [mkMutableByteArrayPrimTy s, intPrimTy, prim_ty, mkStatePrimTy s]
(mkStatePrimTy s)
primOpInfo (IndexByteArrayOp kind)
= let
op_str = _PK_ ("index" ++ primRepString kind ++ "Array#")
-
- (prim_tycon_args, tvs)
- | kind == StablePtrRep = ([alphaTy], [alphaTyVar])
- | otherwise = ([],[])
+ (tvs, prim_ty) = mkPrimTyApp alphaTyVars kind
in
- mkGenPrimOp op_str tvs [byteArrayPrimTy, intPrimTy]
- (mkTyConApp (primRepTyCon kind) prim_tycon_args)
+ mkGenPrimOp op_str tvs [byteArrayPrimTy, intPrimTy] prim_ty
primOpInfo (IndexOffForeignObjOp kind)
= let
op_str = _PK_ ("index" ++ primRepString kind ++ "OffForeignObj#")
-
- (prim_tycon_args, tvs)
- | kind == StablePtrRep = ([alphaTy], [alphaTyVar])
- | otherwise = ([], [])
+ (tvs, prim_ty) = mkPrimTyApp alphaTyVars kind
in
- mkGenPrimOp op_str tvs [foreignObjPrimTy, intPrimTy]
- (mkTyConApp (primRepTyCon kind) prim_tycon_args)
+ mkGenPrimOp op_str tvs [foreignObjPrimTy, intPrimTy] prim_ty
primOpInfo (IndexOffAddrOp kind)
= let
op_str = _PK_ ("index" ++ primRepString kind ++ "OffAddr#")
-
- (prim_tycon_args, tvs)
- | kind == StablePtrRep = ([alphaTy], [alphaTyVar])
- | otherwise = ([], [])
+ (tvs, prim_ty) = mkPrimTyApp alphaTyVars kind
in
- mkGenPrimOp op_str tvs [addrPrimTy, intPrimTy]
- (mkTyConApp (primRepTyCon kind) prim_tycon_args)
+ mkGenPrimOp op_str tvs [addrPrimTy, intPrimTy] prim_ty
primOpInfo (WriteOffAddrOp kind)
= let
s = alphaTy; s_tv = alphaTyVar
op_str = _PK_ ("write" ++ primRepString kind ++ "OffAddr#")
- prim_ty = mkTyConApp (primRepTyCon kind) []
+ (tvs, prim_ty) = mkPrimTyApp betaTyVars kind
in
- mkGenPrimOp op_str [s_tv]
+ mkGenPrimOp op_str (s_tv:tvs)
[addrPrimTy, intPrimTy, prim_ty, mkStatePrimTy s]
(mkStatePrimTy s)
\begin{code}
primOpInfo CatchOp
= let
- a = alphaTy; a_tv = alphaTyVar;
+ a = alphaTy; a_tv = alphaTyVar
b = betaTy; b_tv = betaTyVar;
in
mkGenPrimOp SLIT("catch#") [a_tv, b_tv] [a, mkFunTy b a] a
primOpInfo RaiseOp
= let
- a = alphaTy; a_tv = alphaTyVar;
+ a = alphaTy; a_tv = alphaTyVar
b = betaTy; b_tv = betaTyVar;
in
mkGenPrimOp SLIT("raise#") [a_tv, b_tv] [a] b
(unboxedTriple [realWorldStatePrimTy, intPrimTy, alphaTy])
\end{code}
+Weak pointers can be finalised early by using the finalise# operation:
+
+ finalise# :: Weak# v -> State# RealWorld -> State# RealWorld
+
+\begin{code}
+primOpInfo FinaliseWeakOp
+ = mkGenPrimOp SLIT("finaliseWeak#") [alphaTyVar]
+ [mkWeakPrimTy alphaTy, realWorldStatePrimTy]
+ realWorldStatePrimTy
+\end{code}
+
%************************************************************************
%* *
-\subsubsection[PrimOp-stable-pointers]{PrimOpInfo for ``stable pointers''}
+\subsubsection[PrimOp-stable-pointers]{PrimOpInfo for stable pointers and stable names}
%* *
%************************************************************************
-A {\em stable pointer} is an index into a table of pointers into the
-heap. Since the garbage collector is told about stable pointers, it
-is safe to pass a stable pointer to external systems such as C
+A {\em stable name/pointer} is an index into a table of stable name
+entries. Since the garbage collector is told about stable pointers,
+it is safe to pass a stable pointer to external systems such as C
routines.
-Here's what the operations and types are supposed to be (from
-state-interface document).
-
\begin{verbatim}
-makeStablePtr# :: a -> State# _RealWorld -> (# State# _RealWorld, a #)
-freeStablePtr# :: StablePtr# a -> State# _RealWorld -> State# _RealWorld
-deRefStablePtr# :: StablePtr# a -> State# _RealWorld -> (# State# _RealWorld, a #)
+makeStablePtr# :: a -> State# RealWorld -> (# State# RealWorld, a #)
+freeStablePtr :: StablePtr# a -> State# RealWorld -> State# RealWorld
+deRefStablePtr# :: StablePtr# a -> State# RealWorld -> (# State# RealWorld, a #)
eqStablePtr# :: StablePtr# a -> StablePtr# a -> Int#
\end{verbatim}
-It may seem a bit surprising that @makeStablePtr#@ is a @PrimIO@
+It may seem a bit surprising that @makeStablePtr#@ is a @IO@
operation since it doesn't (directly) involve IO operations. The
reason is that if some optimisation pass decided to duplicate calls to
@makeStablePtr#@ and we only pass one of the stable pointers over, a
-massive space leak can result. Putting it into the PrimIO monad
+massive space leak can result. Putting it into the IO monad
prevents this. (Another reason for putting them in a monad is to
-ensure correct sequencing wrt the side-effecting @freeStablePtr#@
+ensure correct sequencing wrt the side-effecting @freeStablePtr@
operation.)
+An important property of stable pointers is that if you call
+makeStablePtr# twice on the same object you get the same stable
+pointer back.
+
Note that we can implement @freeStablePtr#@ using @_ccall_@ (and,
besides, it's not likely to be used from Haskell) so it's not a
primop.
-Question: Why @_RealWorld@ - won't any instance of @_ST@ do the job? [ADR]
+Question: Why @RealWorld@ - won't any instance of @_ST@ do the job? [ADR]
+
+Stable Names
+~~~~~~~~~~~~
+
+A stable name is like a stable pointer, but with three important differences:
+
+ (a) You can't deRef one to get back to the original object.
+ (b) You can convert one to an Int.
+ (c) You don't need to 'freeStableName'
+
+The existence of a stable name doesn't guarantee to keep the object it
+points to alive (unlike a stable pointer), hence (a).
+
+Invariants:
+
+ (a) makeStableName always returns the same value for a given
+ object (same as stable pointers).
+
+ (b) if two stable names are equal, it implies that the objects
+ from which they were created were the same.
+
+ (c) stableNameToInt always returns the same Int for a given
+ stable name.
\begin{code}
primOpInfo MakeStablePtrOp
= mkGenPrimOp SLIT("eqStablePtr#") [alphaTyVar, betaTyVar]
[mkStablePtrPrimTy alphaTy, mkStablePtrPrimTy betaTy]
intPrimTy
+
+primOpInfo MakeStableNameOp
+ = mkGenPrimOp SLIT("makeStableName#") [alphaTyVar]
+ [alphaTy, realWorldStatePrimTy]
+ (unboxedPair [realWorldStatePrimTy,
+ mkTyConApp stableNamePrimTyCon [alphaTy]])
+
+primOpInfo EqStableNameOp
+ = mkGenPrimOp SLIT("eqStableName#") [alphaTyVar, betaTyVar]
+ [mkStableNamePrimTy alphaTy, mkStableNamePrimTy betaTy]
+ intPrimTy
+
+primOpInfo StableNameToIntOp
+ = mkGenPrimOp SLIT("stableNameToInt#") [alphaTyVar]
+ [mkStableNamePrimTy alphaTy]
+ intPrimTy
\end{code}
%************************************************************************
FloatDecodeOp -> True
DoubleDecodeOp -> True
MkWeakOp -> True
- DeRefWeakOp -> True
+ FinaliseWeakOp -> True
+ MakeStableNameOp -> True
MakeForeignObjOp -> True
- MakeStablePtrOp -> True
NewMutVarOp -> True
NewMVarOp -> True
ForkOp -> True
primOpHasSideEffects WriteForeignObjOp = True
primOpHasSideEffects MkWeakOp = True
primOpHasSideEffects DeRefWeakOp = True
+primOpHasSideEffects FinaliseWeakOp = True
primOpHasSideEffects MakeStablePtrOp = True
+primOpHasSideEffects MakeStableNameOp = True
primOpHasSideEffects EqStablePtrOp = True -- SOF
primOpHasSideEffects DeRefStablePtrOp = True -- ??? JSM & ADR
primOpNeedsWrapper DoublePowerOp = True
primOpNeedsWrapper DoubleEncodeOp = True
-primOpNeedsWrapper MakeStablePtrOp = True
+primOpNeedsWrapper MakeStableNameOp = True
primOpNeedsWrapper DeRefStablePtrOp = True
primOpNeedsWrapper DelayOp = True
Utils:
\begin{code}
+mkPrimTyApp :: [TyVar] -> PrimRep -> ([TyVar], Type)
+ -- CharRep --> ([], Char#)
+ -- StablePtrRep --> ([a], StablePtr# a)
+mkPrimTyApp tvs kind
+ = (forall_tvs, mkTyConApp tycon (mkTyVarTys forall_tvs))
+ where
+ tycon = primRepTyCon kind
+ forall_tvs = take (tyConArity tycon) tvs
+
dyadic_fun_ty ty = mkFunTys [ty, ty] ty
monadic_fun_ty ty = mkFunTy ty ty
compare_fun_ty ty = mkFunTys [ty, ty] boolTy
projects / ghc-hetmet.git / blobdiff