pprUnionTag DoubleRep = panic "pprUnionTag:Double?"
pprUnionTag StablePtrRep = char 'i'
+pprUnionTag StableNameRep = char 'p'
pprUnionTag WeakPtrRep = char 'p'
pprUnionTag ForeignObjRep = char 'p'
stablePtrDataConKey,
stablePtrPrimTyConKey,
stablePtrTyConKey,
- stateDataConKey,
- stateTyConKey,
+ stableNameDataConKey,
+ stableNamePrimTyConKey,
+ stableNameTyConKey,
statePrimTyConKey,
typeConKey,
realWorldTyConKey = mkPreludeTyConUnique 32
stablePtrPrimTyConKey = mkPreludeTyConUnique 33
stablePtrTyConKey = mkPreludeTyConUnique 34
-stateTyConKey = mkPreludeTyConUnique 50
-statePrimTyConKey = mkPreludeTyConUnique 51
+statePrimTyConKey = mkPreludeTyConUnique 35
+stableNamePrimTyConKey = mkPreludeTyConUnique 50
+stableNameTyConKey = mkPreludeTyConUnique 51
mutableByteArrayTyConKey = mkPreludeTyConUnique 52
mutVarPrimTyConKey = mkPreludeTyConUnique 53
ioTyConKey = mkPreludeTyConUnique 55
nilDataConKey = mkPreludeDataConUnique 14
ratioDataConKey = mkPreludeDataConUnique 15
stablePtrDataConKey = mkPreludeDataConUnique 16
-stateDataConKey = mkPreludeDataConUnique 33
+stableNameDataConKey = mkPreludeDataConUnique 17
trueDataConKey = mkPreludeDataConUnique 34
wordDataConKey = mkPreludeDataConUnique 35
word8DataConKey = mkPreludeDataConUnique 36
import PrimOp ( commutableOp, PrimOp(..) )
import RegAllocInfo ( mkMRegsState, MRegsState )
import Stix ( StixTree(..), StixReg(..) )
+import PrimRep ( isFloatingRep )
import UniqSupply ( returnUs, thenUs, mapUs, initUs, UniqSM, UniqSupply )
+import UniqFM ( UniqFM, emptyUFM, addToUFM, lookupUFM )
import Outputable
+
+import GlaExts (trace) --tmp
+#include "nativeGen/NCG.h"
\end{code}
The 96/03 native-code generator has machine-independent and
let
stix = map (map genericOpt) treelists
in
+#if i386_TARGET_ARCH
+ let
+ stix' = map floatFix stix
+ in
+ codeGen stix'
+#else
codeGen stix
+#endif
\end{code}
@codeGen@ is the top-level code-generation function:
\begin{code}
primOpt op args = StPrim op args
\end{code}
+
+-----------------------------------------------------------------------------
+Fix up floating point operations for x86.
+
+The problem is that the code generator can't handle the weird register
+naming scheme for floating point registers on the x86, so we have to
+deal with memory-resident floating point values wherever possible.
+
+We therefore can't stand references to floating-point kinded temporary
+variables, and try to translate them into memory addresses wherever
+possible.
+
+\begin{code}
+floatFix :: [StixTree] -> [StixTree]
+floatFix trees = fltFix emptyUFM trees
+
+fltFix :: UniqFM StixTree -- mapping tmp vars to memory locations
+ -> [StixTree]
+ -> [StixTree]
+fltFix locs [] = []
+
+-- The case we're interested in: loading a temporary from a memory
+-- address. Eliminate the instruction and replace all future references
+-- to the temporary with the memory address.
+fltFix locs ((StAssign rep (StReg (StixTemp uq _)) loc) : trees)
+ | isFloatingRep rep = trace "found one" $ fltFix (addToUFM locs uq loc) trees
+
+fltFix locs ((StAssign rep src dst) : trees)
+ = StAssign rep (fltFix1 locs src) (fltFix1 locs dst) : fltFix locs trees
+
+fltFix locs (tree : trees)
+ = fltFix1 locs tree : fltFix locs trees
+
+
+fltFix1 :: UniqFM StixTree -> StixTree -> StixTree
+fltFix1 locs r@(StReg (StixTemp uq rep))
+ | isFloatingRep rep = case lookupUFM locs uq of
+ Nothing -> panic "fltFix1"
+ Just tree -> trace "substed" $ tree
+
+fltFix1 locs (StIndex rep l r) =
+ StIndex rep (fltFix1 locs l) (fltFix1 locs r)
+
+fltFix1 locs (StInd rep tree) =
+ StInd rep (fltFix1 locs tree)
+
+fltFix1 locs (StAssign rep dst src) = panic "fltFix1: StAssign"
+
+fltFix1 locs (StJump tree) = StJump (fltFix1 locs tree)
+
+fltFix1 locs (StCondJump label tree) =
+ StCondJump label (fltFix1 locs tree)
+
+fltFix1 locs (StPrim op trees) =
+ StPrim op (map (fltFix1 locs) trees)
+
+fltFix1 locs (StCall f conv rep trees) =
+ StCall f conv rep (map (fltFix1 locs) trees)
+
+fltFix1 locs tree = tree
+\end{code}
, mutVarPrimTyCon
, realWorldTyCon
, stablePtrPrimTyCon
+ , stableNamePrimTyCon
, statePrimTyCon
, threadIdPrimTyCon
, wordPrimTyCon
mutableByteArrayTyCon_RDR = tcQual (pREL_ARR, SLIT("MutableByteArray"))
foreignObjTyCon_RDR = tcQual (pREL_IO_BASE, SLIT("ForeignObj"))
-stablePtrTyCon_RDR = tcQual (pREL_FOREIGN, SLIT("StablePtr"))
-deRefStablePtr_RDR = varQual (pREL_FOREIGN, SLIT("deRefStablePtr"))
-makeStablePtr_RDR = varQual (pREL_FOREIGN, SLIT("makeStablePtr"))
+stablePtrTyCon_RDR = tcQual (pREL_STABLE, SLIT("StablePtr"))
+deRefStablePtr_RDR = varQual (pREL_STABLE, SLIT("deRefStablePtr"))
+makeStablePtr_RDR = varQual (pREL_STABLE, SLIT("makeStablePtr"))
eqClass_RDR = tcQual (pREL_BASE, SLIT("Eq"))
ordClass_RDR = tcQual (pREL_BASE, SLIT("Ord"))
pREL_GHC, pRELUDE, mONAD, rATIO, iX, mAIN, pREL_MAIN, pREL_ERR,
pREL_BASE, pREL_NUM, pREL_LIST, pREL_TUP, pREL_ADDR, pREL_READ,
pREL_PACK, pREL_CONC, pREL_IO_BASE, pREL_ST, pREL_ARR, pREL_FOREIGN,
+ pREL_STABLE,
iNT, wORD
) where
\begin{code}
pREL_GHC, pRELUDE, mONAD, rATIO, iX, mAIN, pREL_MAIN, pREL_ERR :: Module
pREL_BASE, pREL_NUM, pREL_LIST, pREL_TUP, pREL_ADDR, pREL_READ :: Module
-pREL_PACK, pREL_CONC, pREL_IO_BASE, pREL_ST, pREL_ARR, pREL_FOREIGN :: Module
+pREL_PACK, pREL_CONC, pREL_IO_BASE, pREL_ST, pREL_ARR :: Module
+pREL_FOREIGN, pREL_STABLE :: Module
pRELUDE = mkModule "Prelude"
pREL_ST = mkModule "PrelST"
pREL_ARR = mkModule "PrelArr"
pREL_FOREIGN = mkModule "PrelForeign"
+pREL_STABLE = mkModule "PrelStable"
pREL_ADDR = mkModule "PrelAddr"
pREL_ERR = mkModule "PrelErr"
| MkWeakOp
| DeRefWeakOp
+ | MakeStableNameOp
+ | EqStableNameOp
+ | StableNameToIntOp
+
| MakeStablePtrOp
| DeRefStablePtrOp
| EqStablePtrOp
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 MakeStableNameOp = ILIT(205)
+tagOf_PrimOp EqStableNameOp = ILIT(206)
+tagOf_PrimOp StableNameToIntOp = ILIT(207)
+tagOf_PrimOp MakeStablePtrOp = ILIT(208)
+tagOf_PrimOp DeRefStablePtrOp = ILIT(209)
+tagOf_PrimOp EqStablePtrOp = ILIT(210)
+tagOf_PrimOp (CCallOp _ _ _ _) = ILIT(211)
+tagOf_PrimOp ReallyUnsafePtrEqualityOp = ILIT(212)
+tagOf_PrimOp SeqOp = ILIT(213)
+tagOf_PrimOp ParOp = ILIT(214)
+tagOf_PrimOp ForkOp = ILIT(215)
+tagOf_PrimOp KillThreadOp = ILIT(216)
+tagOf_PrimOp DelayOp = ILIT(217)
+tagOf_PrimOp WaitReadOp = ILIT(218)
+tagOf_PrimOp WaitWriteOp = ILIT(219)
+tagOf_PrimOp ParGlobalOp = ILIT(220)
+tagOf_PrimOp ParLocalOp = ILIT(221)
+tagOf_PrimOp ParAtOp = ILIT(222)
+tagOf_PrimOp ParAtAbsOp = ILIT(223)
+tagOf_PrimOp ParAtRelOp = ILIT(224)
+tagOf_PrimOp ParAtForNowOp = ILIT(225)
+tagOf_PrimOp CopyableOp = ILIT(226)
+tagOf_PrimOp NoFollowOp = ILIT(227)
+tagOf_PrimOp NewMutVarOp = ILIT(228)
+tagOf_PrimOp ReadMutVarOp = ILIT(229)
+tagOf_PrimOp WriteMutVarOp = ILIT(230)
+tagOf_PrimOp SameMutVarOp = ILIT(231)
+tagOf_PrimOp CatchOp = ILIT(232)
+tagOf_PrimOp RaiseOp = ILIT(233)
tagOf_PrimOp op = pprPanic# "tagOf_PrimOp: pattern-match" (ppr op)
--panic# "tagOf_PrimOp: pattern-match"
WriteForeignObjOp,
MkWeakOp,
DeRefWeakOp,
+ MakeStableNameOp,
+ EqStableNameOp,
+ StableNameToIntOp,
MakeStablePtrOp,
DeRefStablePtrOp,
EqStablePtrOp,
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
%************************************************************************
%* *
-\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}
%************************************************************************
DoubleDecodeOp -> True
MkWeakOp -> True
DeRefWeakOp -> True
+ MakeStableNameOp -> True
MakeForeignObjOp -> True
- MakeStablePtrOp -> True
NewMutVarOp -> True
NewMVarOp -> True
ForkOp -> True
primOpHasSideEffects MkWeakOp = True
primOpHasSideEffects DeRefWeakOp = 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
-- there's some documentation gain from having
-- it special? [ADR]
+ | StableNameRep -- A stable name is a real heap object, unpointed,
+ -- with one field containing an index into the
+ -- stable pointer table. It has to be a heap
+ -- object so the garbage collector can track these
+ -- objects and reclaim stable pointer entries.
+
| ThreadIdRep -- Really a pointer to a TSO
| ArrayRep -- Primitive array of Haskell pointers
isFollowableRep ByteArrayRep = True -- ''
isFollowableRep WeakPtrRep = True -- ''
isFollowableRep ForeignObjRep = True -- ''
+isFollowableRep StableNameRep = True -- ''
isFollowableRep ThreadIdRep = True -- pointer to a TSO
isFollowableRep other = False
WeakPtrRep -> 4
ForeignObjRep -> 4
StablePtrRep -> 4
+ StableNameRep -> 4
ArrayRep -> 4
ByteArrayRep -> 4
_ -> panic "getPrimRepSize: ouch - this wasn't supposed to happen!"
showPrimRep ArrayRep = "P_" -- see comment below
showPrimRep ByteArrayRep = "StgByteArray"
showPrimRep StablePtrRep = "StgStablePtr"
+showPrimRep StableNameRep = "P_"
showPrimRep ThreadIdRep = "StgTSO*"
showPrimRep WeakPtrRep = "P_"
showPrimRep ForeignObjRep = "StgAddr"
primRepString WeakPtrRep = "Weak"
primRepString ForeignObjRep = "ForeignObj"
primRepString StablePtrRep = "StablePtr"
+primRepString StableNameRep = "StableName"
primRepString other = pprPanic "primRepString" (ppr other)
showPrimRepToUser pr = primRepString pr
mVarPrimTyCon, mkMVarPrimTy,
stablePtrPrimTyCon, mkStablePtrPrimTy,
+ stableNamePrimTyCon, mkStableNamePrimTy,
weakPrimTyCon, mkWeakPrimTy,
foreignObjPrimTyCon, foreignObjPrimTy,
threadIdPrimTyCon, threadIdPrimTy,
%************************************************************************
%* *
+\subsection[TysPrim-stable-names]{The stable-name type}
+%* *
+%************************************************************************
+
+\begin{code}
+stableNamePrimTyCon = pcPrimTyCon stableNamePrimTyConKey SLIT("StableName#") 1 StableNameRep
+
+mkStableNamePrimTy ty = mkTyConApp stableNamePrimTyCon [ty]
+\end{code}
+
+%************************************************************************
+%* *
\subsection[TysPrim-foreign-objs]{The ``foreign object'' type}
%* *
%************************************************************************
unboxedTupleTyCon, unboxedTupleCon,
unboxedPairTyCon, unboxedPairDataCon,
- stateDataCon,
- stateTyCon,
- realWorldStateTy,
-
stablePtrTyCon,
stringTy,
trueDataCon,
\end{code}
\begin{code}
-mkStateTy ty = mkTyConApp stateTyCon [ty]
-realWorldStateTy = mkStateTy realWorldTy -- a common use
-
-stateTyCon = pcNonRecDataTyCon stateTyConKey pREL_ST SLIT("State") alpha_tyvar [stateDataCon]
-stateDataCon
- = pcDataCon stateDataConKey pREL_ST SLIT("S#")
- alpha_tyvar [] [mkStatePrimTy alphaTy] stateTyCon
-\end{code}
-
-\begin{code}
stablePtrTyCon
- = pcNonRecDataTyCon stablePtrTyConKey pREL_FOREIGN SLIT("StablePtr")
+ = pcNonRecDataTyCon stablePtrTyConKey pREL_STABLE SLIT("StablePtr")
alpha_tyvar [stablePtrDataCon]
where
stablePtrDataCon
- = pcDataCon stablePtrDataConKey pREL_FOREIGN SLIT("StablePtr")
+ = pcDataCon stablePtrDataConKey pREL_STABLE SLIT("StablePtr")
alpha_tyvar [] [mkStablePtrPrimTy alphaTy] stablePtrTyCon
\end{code}
, wordTyConKey, word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey
, floatTyConKey, doubleTyConKey
, addrTyConKey, charTyConKey, foreignObjTyConKey
- , stablePtrTyConKey, byteArrayTyConKey, mutableByteArrayTyConKey
+ , stablePtrTyConKey
+ , byteArrayTyConKey, mutableByteArrayTyConKey
]
-- types that can be passed from the outside world into Haskell.
IWantToBeINLINEd -> True
ICanSafelyBeINLINEd inside_lam one_branch
- -> (small_enough || one_branch) &&
- ((whnf && some_benefit) || not_inside_lam)
+ -> (small_enough || one_branch) && some_benefit &&
+ (whnf || not_inside_lam)
where
not_inside_lam = case inside_lam of {InsideLam -> False; other -> True}
maybeTyConSingleCon (AlgTyCon {}) = Nothing
maybeTyConSingleCon (TupleTyCon {dataCon = con}) = Just con
maybeTyConSingleCon (PrimTyCon {}) = Nothing
+maybeTyConSingleCon other = panic (showSDoc (ppr other))
\end{code}
\begin{code}
- <sect> <idx/Foreign/
+<sect> <idx/Foreign/
<label id="sec:Foreign">
<p>
-This module provides two types to better allow the Haskell world to
-share its data with the outside world (and vice versa), <em/foreign
-objects/ and <em/stable pointers/:
+This module provides the <tt/ForeignObj/ type, which is a Haskell
+reference to an object in the outside world. Foreign objects are
+boxed versions of <tt/Addr#/, the only reason for their existence is
+so that they can be used with finalisers (see Section <ref
+id="foreign-finalisers" name="Finalisation for foreign objects">).
<tscreen><verb>
module Foreign where
data ForeignObj -- abstract, instance of: Eq
-makeForeignObj :: Addr{-object-} -> Addr{-finaliser-} -> IO ForeignObj
+makeForeignObj :: Addr{-object-} -> IO ForeignObj
writeForeignObj :: ForeignObj -> Addr{-new value-} -> IO ()
-
-data StablePtr a -- abstract, instance of: Eq.
-makeStablePtr :: a -> IO (StablePtr a)
-deRefStablePtr :: StablePtr a -> IO a
-freeStablePtr :: StablePtr a -> IO ()
</verb> </tscreen>
-<itemize>
-<item>The <tt/ForeignObj/ type provides foreign objects, encapsulated
-references to values outside the Haskell heap. Foreign objects are
-finalised by the garbage collector when they become dead. The
-finaliser to use is given as second argument to <tt/makeForeignOj/,
-and is currently a function pointer to a C function with
-the following signature
-
-<tscreen><verb>
-void finaliseFO(void* obj);
-</verb></tscreen>
-
-The finaliser is passed the reference to the external object (i.e.,
-the first argument to <tt/makeForeignObj/.)
-
-<item>
-The <tt/writeForeignObj/ lets you overwrite the encapsulated foreign
-reference with another.
-
-<item>
-Stable pointers allow you to hand out references to Haskell heap
-objects to the outside world. <bf/ToDo:/ <em/say more./
-</itemize>
-
In addition to the above, the following operations for indexing via
a <tt/ForeignObj/ are also, mirrored on the same operations provided
over <tt/Addr/s:
<sect1>Finalisation for foreign objects
+<label id="foreign-finalisers">
<p>
A foreign object is some data that lives outside the Haskell heap, for
the program still holds the <tt/Addr#/ and intends to use it.
To avoid this somewhat subtle race condition, we use another type of
-foreign address, called <tt/ForeignObj/. Historical note:
-<tt/ForeignObj/ is identical to the old <tt/ForeignObj/ except that it
-no longer supports finalisation - that's provided by the weak
+foreign address, called <tt/ForeignObj/ (see Section <ref
+id="sec:Foreign" name="Foreign">). Historical note: <tt/ForeignObj/
+is identical to the old <tt/ForeignObj/ except that it no longer
+supports finalisation - that's provided by the weak
pointer/finalisation mechanism above.
A <tt/ForeignObj/ is basically an address, but the <tt/ForeignObj/
itself is a heap-resident object and can therefore be watched by weak
pointers. A <tt/ForeignObj/ can be passed to C functions (in which
case the C function gets a straightforward pointer), but it cannot be
-decomposed into an <tt/Addr#/. Operations on <tt/ForeignObj/ are
-provided by the <tt/Foreign/ module (see Section <ref name="Foreign"
-id="sec:Foreign">).
+decomposed into an <tt/Addr#/.
<!ENTITY numexts SYSTEM "NumExts.sgml">
<!ENTITY pretty SYSTEM "Pretty.sgml">
<!ENTITY st SYSTEM "ST.sgml">
+ <!ENTITY stable SYSTEM "Stable.sgml">
<!ENTITY weak SYSTEM "Weak.sgml">
<!ENTITY word SYSTEM "Word.sgml">
]>
&dynamic
&exception
&foreign
+&getopt
&glaexts
&ioexts
&int
&numexts
&pretty
-&getopt
&st
+&stable
<sect> <idx/LazyST/
<label id="sec:LazyST">
/* ----------------------------------------------------------------------------
- * $Id: ClosureTypes.h,v 1.5 1999/01/15 17:57:03 simonm Exp $
+ * $Id: ClosureTypes.h,v 1.6 1999/01/26 11:12:55 simonm Exp $
*
* Closure Type Constants
*
#define MUT_VAR 49
#define WEAK 40
#define FOREIGN 41
-#define TSO 42
-#define BLOCKED_FETCH 43
-#define FETCH_ME 44
-#define EVACUATED 45
+#define STABLE_NAME 42
+#define TSO 43
+#define BLOCKED_FETCH 44
+#define FETCH_ME 45
+#define EVACUATED 46
#endif CLOSURETYPES_H
/* ----------------------------------------------------------------------------
- * $Id: Closures.h,v 1.4 1999/01/18 15:21:41 simonm Exp $
+ * $Id: Closures.h,v 1.5 1999/01/26 11:12:55 simonm Exp $
*
* Closures
*
StgAddr data; /* pointer to data in non-haskell-land */
} StgForeignObj;
+typedef struct _StgStableName {
+ StgHeader header;
+ StgWord sn;
+} StgStableName;
+
typedef struct _StgWeak { /* Weak v */
StgHeader header;
StgClosure *key;
/* ----------------------------------------------------------------------------
- * $Id: InfoTables.h,v 1.5 1999/01/18 15:21:42 simonm Exp $
+ * $Id: InfoTables.h,v 1.6 1999/01/26 11:12:55 simonm Exp $
*
* Info Tables
*
, WEAK
, FOREIGN
+ , STABLE_NAME
, TSO
#define FLAGS_MUT_ARR_PTRS_FROZEN (_HNF| _NS| _MUT|_UPT )
#define FLAGS_MUT_VAR (_HNF| _NS| _MUT|_UPT )
#define FLAGS_FOREIGN (_HNF| _NS| _UPT )
+#define FLAGS_STABLE_NAME (_HNF| _NS| _UPT )
#define FLAGS_WEAK (_HNF| _NS| _UPT )
#define FLAGS_BLACKHOLE ( _NS| _UPT )
#define FLAGS_BLACKHOLE_BQ ( _NS| _MUT|_UPT )
/* -----------------------------------------------------------------------------
- * $Id: Prelude.h,v 1.2 1998/12/02 13:21:18 simonm Exp $
+ * $Id: Prelude.h,v 1.3 1999/01/26 11:12:56 simonm Exp $
*
* Prelude identifiers that we sometimes need to refer to in the RTS.
*
extern const StgInfoTable PrelAddr_WZh_con_info;
extern const StgInfoTable PrelAddr_I64Zh_con_info;
extern const StgInfoTable PrelAddr_W64Zh_con_info;
-extern const StgInfoTable PrelForeign_StablePtr_static_info;
-extern const StgInfoTable PrelForeign_StablePtr_con_info;
+extern const StgInfoTable PrelStable_StablePtr_static_info;
+extern const StgInfoTable PrelStable_StablePtr_con_info;
/* Define canonical names so we can abstract away from the actual
* module these names are defined in.
#define WZh_con_info PrelAddr_WZh_con_info
#define W64Zh_con_info PrelAddr_W64Zh_con_info
#define I64Zh_con_info PrelAddr_I64Zh_con_info
-#define StablePtr_static_info PrelForeign_StablePtr_static_info
-#define StablePtr_con_info PrelForeign_StablePtr_con_info
+#define StablePtr_static_info PrelStable_StablePtr_static_info
+#define StablePtr_con_info PrelStable_StablePtr_con_info
#define mainIO_closure PrelMain_mainIO_closure
#define unpackCString_closure PrelPack_unpackCString_closure
/* -----------------------------------------------------------------------------
- * $Id: PrimOps.h,v 1.9 1999/01/23 17:48:23 sof Exp $
+ * $Id: PrimOps.h,v 1.10 1999/01/26 11:12:56 simonm Exp $
*
* Macros for primitive operations in STG-ish C code.
*
extern void stg_exit(I_ n) __attribute__ ((noreturn));
/* -----------------------------------------------------------------------------
- Stable Pointer PrimOps.
+ Stable Name / Stable Pointer PrimOps
-------------------------------------------------------------------------- */
#ifndef PAR
-extern StgPtr *stable_ptr_table;
-extern StgPtr *stable_ptr_free;
-#define deRefStablePtrZh(r,sp) (r=stable_ptr_table[(sp)])
-#define eqStablePtrZh(r,sp1,sp2) (r=(sp1==sp2))
-
-#define freeStablePointer(stable_ptr) \
- { \
- stable_ptr_table[stable_ptr] = (P_)stable_ptr_free; \
- stable_ptr_free = &stable_ptr_table[stable_ptr]; \
- }
-
-EF_(makeStablePtrZh_fast);
-
-#else /* PAR */
-#define deRefStablePtrZh(ri,sp) \
-do { \
- fflush(stdout); \
- fprintf(stderr, "deRefStablePtr#: no stable pointer support.\n");\
- stg_exit(EXIT_FAILURE); \
-} while(0)
-
-#define eqStablePtrZh(ri,sp1,sp2) \
-do { \
- fflush(stdout); \
- fprintf(stderr, "eqStablePtr#: no stable pointer support.\n"); \
- stg_exit(EXIT_FAILURE); \
-} while(0)
-
-#define makeStablePtrZh(stablePtr,liveness,unstablePtr) \
-do { \
- fflush(stdout); \
- fprintf(stderr, "makeStablePtr#: no stable pointer support.\n");\
- EXIT(EXIT_FAILURE); \
-} while(0)
-
-#define freeStablePtrZh(stablePtr,liveness,unstablePtr) \
-do { \
- fflush(stdout); \
- fprintf(stderr, "makeStablePtr#: no stable pointer support.\n");\
- EXIT(EXIT_FAILURE); \
-} while(0)
-#endif
+EF_(makeStableNameZh_fast);
+
+#define stableNameToIntZh(r,s) (r = ((StgStableName *)s)->sn)
+
+#define eqStableNameZh(r,sn1,sn2) \
+ (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn))
+
+#define makeStablePtrZh(r,a) \
+ r = RET_STGCALL1(StgStablePtr,getStablePtr,a)
+#define deRefStablePtrZh(r,sp) do { \
+ ASSERT(stable_ptr_table[sp & ~STABLEPTR_WEIGHT_MASK].weight > 0); \
+ r = stable_ptr_table[sp & ~STABLEPTR_WEIGHT_MASK].addr; \
+} while (0);
+
+#define eqStablePtrZh(r,sp1,sp2) \
+ (r = ((sp1 & ~STABLEPTR_WEIGHT_MASK) == (sp2 & ~STABLEPTR_WEIGHT_MASK)))
+
+#endif
/* -----------------------------------------------------------------------------
Parallel PrimOps.
/* -----------------------------------------------------------------------------
- * $Id: Rts.h,v 1.4 1999/01/21 10:31:43 simonm Exp $
+ * $Id: Rts.h,v 1.5 1999/01/26 11:12:57 simonm Exp $
*
* Top-level include file for the RTS itself
*
#define stg_min(a,b) ({typeof(a) _a = (a), _b = (b); _a <= _b ? _a : _b; })
#define stg_max(a,b) ({typeof(a) _a = (a), _b = (b); _a <= _b ? _b : _a; })
-
#define UNUSED __attribute__((unused))
#endif RTS_H
/* -----------------------------------------------------------------------------
- * $Id: Stg.h,v 1.4 1999/01/21 10:31:43 simonm Exp $
+ * $Id: Stg.h,v 1.5 1999/01/26 11:12:57 simonm Exp $
*
* Top-level include file for everything STG-ish.
*
#define COMPILER 1
#endif
+/* bit macros
+ */
+#define BITS_PER_BYTE 8
+#define BITS_IN(x) (BITS_PER_BYTE * sizeof(x))
+
+/* -----------------------------------------------------------------------------
+ Assertions and Debuggery
+ -------------------------------------------------------------------------- */
+
+#ifndef DEBUG
+#define ASSERT(predicate) /* nothing */
+#else
+
+void _stgAssert (char *, unsigned int);
+
+#define ASSERT(predicate) \
+ if (predicate) \
+ /*null*/; \
+ else \
+ _stgAssert(__FILE__, __LINE__)
+#endif /* DEBUG */
+
+/* -----------------------------------------------------------------------------
+ Include everything STG-ish
+ -------------------------------------------------------------------------- */
+
/* Global type definitions*/
#include "StgTypes.h"
#include "Updates.h"
#include "StgTicky.h"
#include "CCall.h"
+#include "Stable.h"
/* Built-in entry points */
#include "StgMiscClosures.h"
extern void* createAdjustor(int cconv, StgStablePtr hptr, StgFunPtr wptr);
extern void freeHaskellFunctionPtr(void* ptr);
-/* -----------------------------------------------------------------------------
- Assertions and Debuggery
- -------------------------------------------------------------------------- */
-
-#ifndef DEBUG
-#define ASSERT(predicate) /* nothing */
-#else
-
-void _stgAssert (char *, unsigned int);
-
-#define ASSERT(predicate) \
- if (predicate) \
- /*null*/; \
- else \
- _stgAssert(__FILE__, __LINE__)
-#endif /* DEBUG */
-
#endif /* STG_H */
/* -----------------------------------------------------------------------------
- * $Id: StgMiscClosures.h,v 1.5 1999/01/15 17:57:04 simonm Exp $
+ * $Id: StgMiscClosures.h,v 1.6 1999/01/26 11:12:58 simonm Exp $
*
* Entry code for various built-in closure types.
*
STGFUN(FOREIGN_entry);
STGFUN(WEAK_entry);
STGFUN(DEAD_WEAK_entry);
+STGFUN(STABLE_NAME_entry);
STGFUN(TSO_entry);
STGFUN(FULL_MVAR_entry);
STGFUN(EMPTY_MVAR_entry);
extern const StgInfoTable FOREIGN_info;
extern const StgInfoTable WEAK_info;
extern const StgInfoTable DEAD_WEAK_info;
+extern const StgInfoTable STABLE_NAME_info;
extern const StgInfoTable FULL_MVAR_info;
extern const StgInfoTable EMPTY_MVAR_info;
extern const StgInfoTable TSO_info;
/* -----------------------------------------------------------------------------
- * $Id: StgTypes.h,v 1.2 1998/12/02 13:21:41 simonm Exp $
+ * $Id: StgTypes.h,v 1.3 1999/01/26 11:12:58 simonm Exp $
*
* Various C datatypes used in the run-time system.
typedef struct StgTSO_* StgTSOPtr;
-typedef StgWord StgStablePtr;
typedef void * StgForeignPtr;
typedef StgInt StgStackOffset; /* offset in words! */
typedef StgInt64 LI_;
typedef StgNat64 LW_;
+/* Stable Pointers: A stable pointer is represented as an index into
+ * the stable pointer table in the low 24 bits with a weight in the
+ * upper 8 bits.
+ */
+typedef StgWord StgStablePtr;
+
+#define STABLEPTR_WEIGHT_MASK (0xff << ((sizeof(StgWord)-1) * BITS_PER_BYTE))
+#define STABLEPTR_WEIGHT_SHIFT (BITS_IN(StgWord) - 8)
+
/*
Types for the generated C functions
take no arguments
/* Free the stable pointer first..*/
if (*(unsigned char*)ptr == 0x68) { /* Aha, a ccall adjustor! */
- freeStablePointer(*((StgStablePtr*)((unsigned char*)ptr + 0x01)));
+ freeStablePtr(*((StgStablePtr*)((unsigned char*)ptr + 0x01)));
} else {
- freeStablePointer(*((StgStablePtr*)((unsigned char*)ptr + 0x02)));
+ freeStablePtr(*((StgStablePtr*)((unsigned char*)ptr + 0x02)));
}
*((unsigned char*)ptr) = '\0';
* Copyright (c) 1994-1998.
*
* $RCSfile: Evaluator.c,v $
- * $Revision: 1.3 $
- * $Date: 1999/01/15 17:57:06 $
+ * $Revision: 1.4 $
+ * $Date: 1999/01/26 11:12:41 $
* ---------------------------------------------------------------------------*/
#include "Rts.h"
#include "Bytecodes.h"
#include "Assembler.h" /* for CFun stuff */
#include "ForeignCall.h"
-#include "StablePtr.h"
+#include "StablePriv.h"
#include "PrimOps.h" /* for __{encode,decode}{Float,Double} */
#include "Evaluator.h"
/* -----------------------------------------------------------------------------
- * $Id: GC.c,v 1.18 1999/01/20 16:24:02 simonm Exp $
+ * $Id: GC.c,v 1.19 1999/01/26 11:12:43 simonm Exp $
*
* Two-space garbage collector
*
#include "DebugProf.h"
#include "SchedAPI.h"
#include "Weak.h"
+#include "StablePriv.h"
StgCAF* enteredCAFs;
weak_ptr_list = NULL;
weak_done = rtsFalse;
+ /* Mark the stable pointer table.
+ */
+ markStablePtrTable(major_gc);
+
#ifdef INTERPRETER
{
/* ToDo: To fix the caf leak, we need to make the commented out
}
}
+ /* Now see which stable names are still alive
+ */
+ gcStablePtrTable(major_gc);
+
/* Set the maximum blocks for the oldest generation, based on twice
* the amount of live data now, adjusted to fit the maximum heap
* size if necessary.
traverse_weak_ptr_list(void)
{
StgWeak *w, **last_w, *next_w;
- StgClosure *target;
- const StgInfoTable *info;
+ StgClosure *new;
rtsBool flag = rtsFalse;
if (weak_done) { return rtsFalse; }
last_w = &old_weak_ptr_list;
for (w = old_weak_ptr_list; w; w = next_w) {
- target = w->key;
- loop:
- /* ignore weak pointers in older generations */
- if (!LOOKS_LIKE_STATIC(target) && Bdescr((P_)target)->gen->no > N) {
- IF_DEBUG(weak, fprintf(stderr,"Weak pointer still alive (in old gen) at %p\n", w));
- /* remove this weak ptr from the old_weak_ptr list */
- *last_w = w->link;
- /* and put it on the new weak ptr list */
- next_w = w->link;
- w->link = weak_ptr_list;
- weak_ptr_list = w;
- flag = rtsTrue;
- continue;
- }
-
- info = get_itbl(target);
- switch (info->type) {
-
- case IND:
- case IND_STATIC:
- case IND_PERM:
- case IND_OLDGEN: /* rely on compatible layout with StgInd */
- case IND_OLDGEN_PERM:
- /* follow indirections */
- target = ((StgInd *)target)->indirectee;
- goto loop;
- case EVACUATED:
- /* If key is alive, evacuate value and finaliser and
- * place weak ptr on new weak ptr list.
- */
- IF_DEBUG(weak, fprintf(stderr,"Weak pointer still alive at %p\n", w));
- w->key = ((StgEvacuated *)target)->evacuee;
+ if ((new = isAlive(w->key))) {
+ w->key = new;
+ /* evacuate the value and finaliser */
w->value = evacuate(w->value);
w->finaliser = evacuate(w->finaliser);
-
/* remove this weak ptr from the old_weak_ptr list */
*last_w = w->link;
-
/* and put it on the new weak ptr list */
next_w = w->link;
w->link = weak_ptr_list;
weak_ptr_list = w;
flag = rtsTrue;
- break;
-
- default: /* key is dead */
+ IF_DEBUG(weak, fprintf(stderr,"Weak pointer still alive at %p -> %p\n", w, w->key));
+ continue;
+ }
+ else {
last_w = &(w->link);
next_w = w->link;
- break;
+ continue;
}
}
return rtsTrue;
}
+/* -----------------------------------------------------------------------------
+ isAlive determines whether the given closure is still alive (after
+ a garbage collection) or not. It returns the new address of the
+ closure if it is alive, or NULL otherwise.
+ -------------------------------------------------------------------------- */
+
+StgClosure *
+isAlive(StgClosure *p)
+{
+ StgInfoTable *info;
+
+ while (1) {
+
+ info = get_itbl(p);
+
+ /* ToDo: for static closures, check the static link field.
+ * Problem here is that we sometimes don't set the link field, eg.
+ * for static closures with an empty SRT or CONSTR_STATIC_NOCAFs.
+ */
+
+ /* ignore closures in generations that we're not collecting. */
+ if (LOOKS_LIKE_STATIC(p) || Bdescr((P_)p)->gen->no > N) {
+ return p;
+ }
+
+ switch (info->type) {
+
+ case IND:
+ case IND_STATIC:
+ case IND_PERM:
+ case IND_OLDGEN: /* rely on compatible layout with StgInd */
+ case IND_OLDGEN_PERM:
+ /* follow indirections */
+ p = ((StgInd *)p)->indirectee;
+ continue;
+
+ case EVACUATED:
+ /* alive! */
+ return ((StgEvacuated *)p)->evacuee;
+
+ default:
+ /* dead. */
+ return NULL;
+ }
+ }
+}
+
StgClosure *
MarkRoot(StgClosure *root)
{
- root = evacuate(root);
- return root;
+ return evacuate(root);
}
static inline void addBlock(step *step)
evacuate_mutable((StgMutClosure *)to);
return to;
+ case STABLE_NAME:
+ stable_ptr_table[((StgStableName *)q)->sn].keep = rtsTrue;
+ to = copy(q,sizeofW(StgStableName),bd);
+ upd_evacuee(q,to);
+ return to;
+
case FUN:
case THUNK:
case CONSTR:
case CONSTR:
case WEAK:
case FOREIGN:
+ case STABLE_NAME:
case IND_PERM:
case IND_OLDGEN_PERM:
case CAF_UNENTERED:
/* -----------------------------------------------------------------------------
- * $Id: GC.h,v 1.2 1998/12/02 13:28:25 simonm Exp $
+ * $Id: GC.h,v 1.3 1999/01/26 11:12:45 simonm Exp $
*
* Prototypes for functions in GC.c
*
* ---------------------------------------------------------------------------*/
void threadPaused(StgTSO *);
+StgClosure *isAlive(StgClosure *p);
#-----------------------------------------------------------------------------
-# $Id: Makefile,v 1.4 1999/01/21 10:30:24 simonm Exp $
+# $Id: Makefile,v 1.5 1999/01/26 11:12:45 simonm Exp $
# This is the Makefile for the runtime-system stuff.
# This stuff is written in C (and cannot be written in Haskell).
#WARNING_OPTS += -optc-Wconversion
SRC_HC_OPTS += -I../includes -I. -Igum $(WARNING_OPTS) $(GhcRtsHcOpts)
+SRC_CC_OPTS += $(GhcRtsCcOpts)
ifeq "$(way)" "mp"
SRC_HC_OPTS += -I$$PVM_ROOT/include
/* -----------------------------------------------------------------------------
- * $Id: PrimOps.hc,v 1.6 1999/01/23 17:53:28 sof Exp $
+ * $Id: PrimOps.hc,v 1.7 1999/01/26 11:12:46 simonm Exp $
*
* Primitive functions / data
*
#include "RtsUtils.h"
#include "Storage.h"
#include "BlockAlloc.h" /* tmp */
-#include "StablePtr.h"
+#include "StablePriv.h"
/* ** temporary **
Stable pointer primitives
------------------------------------------------------------------------- */
-FN_(makeStablePtrZh_fast)
+FN_(makeStableNameZh_fast)
{
- StgInt stable_ptr;
- FB_
+ StgWord index;
+ StgStableName *sn_obj;
+ FB_
- if (stable_ptr_free == NULL) {
- enlargeStablePtrTable();
- }
+ HP_CHK_GEN(sizeofW(StgStableName), R1_PTR, makeStableNameZh_fast,);
+ TICK_ALLOC_PRIM(sizeofW(StgHeader),
+ sizeofW(StgStableName)-sizeofW(StgHeader), 0);
+ CCS_ALLOC(CCCS,sizeofW(StgStableName)); /* ccs prof */
+
+ index = RET_STGCALL1(StgWord,lookupStableName,R1.p);
- stable_ptr = stable_ptr_free - stable_ptr_table;
- (P_)stable_ptr_free = *stable_ptr_free;
- stable_ptr_table[stable_ptr] = R1.p;
+ sn_obj = (StgStableName *) (Hp - sizeofW(StgStableName) + 1);
+ sn_obj->header.info = &STABLE_NAME_info;
+ sn_obj->sn = index;
- R1.i = stable_ptr;
- JMP_(ENTRY_CODE(Sp[0]));
- FE_
+ TICK_RET_UNBOXED_TUP(1);
+ RET_P(sn_obj);
}
#endif /* COMPILER */
/* -----------------------------------------------------------------------------
- * $Id: RtsFlags.h,v 1.5 1999/01/23 17:52:21 sof Exp $
+ * $Id: RtsFlags.h,v 1.6 1999/01/26 11:12:46 simonm Exp $
*
* Datatypes that holds the command-line flag settings.
*
/* flags to control consistency checking (often very expensive!) */
rtsBool sanity : 1; /* 128 */
+
+ rtsBool stable : 1; /* 256 */
};
#if defined(PROFILING) || defined(PAR)
/* -----------------------------------------------------------------------------
- * $Id: RtsStartup.c,v 1.4 1999/01/22 10:58:43 simonm Exp $
+ * $Id: RtsStartup.c,v 1.5 1999/01/26 11:12:47 simonm Exp $
*
* Main function for a standalone Haskell program.
*
#include "RtsUtils.h"
#include "RtsFlags.h"
#include "Storage.h" /* initStorage, exitStorage */
-#include "StablePtr.h" /* initStablePtrTable */
+#include "StablePriv.h" /* initStablePtrTable */
#include "Schedule.h" /* initScheduler */
#include "Stats.h" /* initStats */
#include "Weak.h"
/* -----------------------------------------------------------------------------
- * $Id: Sanity.c,v 1.6 1999/01/19 16:56:50 simonm Exp $
+ * $Id: Sanity.c,v 1.7 1999/01/26 11:12:47 simonm Exp $
*
* Sanity checking code for the heap and stack.
*
case BLACKHOLE:
case BLACKHOLE_BQ:
case FOREIGN:
+ case STABLE_NAME:
case MUT_VAR:
case CONSTR_INTLIKE:
case CONSTR_CHARLIKE:
/* -----------------------------------------------------------------------------
- * $Id: Schedule.c,v 1.5 1999/01/21 10:31:50 simonm Exp $
+ * $Id: Schedule.c,v 1.6 1999/01/26 11:12:48 simonm Exp $
*
* Scheduler
*
#include "Printer.h"
#include "Main.h"
#include "Signals.h"
-#include "StablePtr.h"
#include "Profiling.h"
#include "Sanity.h"
for (i = 0; i < next_main_thread; i++) {
main_threads[i] = (StgTSO *)MarkRoot((StgClosure *)main_threads[i]);
}
-
- markStablePtrTable();
}
/* -----------------------------------------------------------------------------
/* -----------------------------------------------------------------------------
- * $Id: Signals.c,v 1.2 1998/12/02 13:28:46 simonm Exp $
+ * $Id: Signals.c,v 1.3 1999/01/26 11:12:49 simonm Exp $
*
* Signal processing / handling.
*
#include "Signals.h"
#include "RtsUtils.h"
#include "RtsFlags.h"
-#include "StablePtr.h"
+#include "StablePriv.h"
#ifndef PAR
circumstances, depending on the signal.
*/
- *next_pending_handler++ = deRefStablePointer(handlers[sig]);
+ *next_pending_handler++ = deRefStablePtr(handlers[sig]);
/* stack full? */
if (next_pending_handler == &pending_handler_buf[N_PENDING_HANDLERS]) {
* by freeing the previous handler if there was one.
*/
if (previous_spi >= 0) {
- freeStablePointer(handlers[sig]);
+ freeStablePtr(handlers[sig]);
}
return STG_SIG_ERR;
}
+++ /dev/null
-/* -----------------------------------------------------------------------------
- * $Id: StablePtr.c,v 1.2 1998/12/02 13:28:48 simonm Exp $
- *
- * Stable pointers
- *
- * ---------------------------------------------------------------------------*/
-
-#include "Rts.h"
-#include "StablePtr.h"
-#include "GC.h"
-#include "RtsUtils.h"
-#include "Storage.h"
-#include "RtsAPI.h"
-#include "RtsFlags.h"
-
-/* Comment from ADR's implementation in old RTS:
-
- This files (together with @ghc/runtime/storage/PerformIO.lhc@ and a
- small change in @HpOverflow.lc@) consists of the changes in the
- runtime system required to implement "Stable Pointers". But we're
- getting a bit ahead of ourselves --- what is a stable pointer and what
- is it used for?
-
- When Haskell calls C, it normally just passes over primitive integers,
- floats, bools, strings, etc. This doesn't cause any problems at all
- for garbage collection because the act of passing them makes a copy
- from the heap, stack or wherever they are onto the C-world stack.
- However, if we were to pass a heap object such as a (Haskell) @String@
- and a garbage collection occured before we finished using it, we'd run
- into problems since the heap object might have been moved or even
- deleted.
-
- So, if a C call is able to cause a garbage collection or we want to
- store a pointer to a heap object between C calls, we must be careful
- when passing heap objects. Our solution is to keep a table of all
- objects we've given to the C-world and to make sure that the garbage
- collector collects these objects --- updating the table as required to
- make sure we can still find the object.
-
-
- Of course, all this rather begs the question: why would we want to
- pass a boxed value?
-
- One very good reason is to preserve laziness across the language
- interface. Rather than evaluating an integer or a string because it
- {\em might\/} be required by the C function, we can wait until the C
- function actually wants the value and then force an evaluation.
-
- Another very good reason (the motivating reason!) is that the C code
- might want to execute an object of sort $IO ()$ for the side-effects
- it will produce. For example, this is used when interfacing to an X
- widgets library to allow a direct implementation of callbacks.
-
-
- The @makeStablePointer :: a -> IO (StablePtr a)@ function
- converts a value into a stable pointer. It is part of the @PrimIO@
- monad, because we want to be sure we don't allocate one twice by
- accident, and then only free one of the copies.
-
- \begin{verbatim}
- makeStablePtr# :: a -> State# RealWorld -> (# RealWorld, a #)
- freeStablePtr# :: StablePtr# a -> State# RealWorld -> State# RealWorld
- deRefStablePtr# :: StablePtr# a -> State# RealWorld ->
- (# State# RealWorld, a #)
- \end{verbatim}
- There is also a C procedure @FreeStablePtr@ which frees a stable pointer.
-
- There may be additional functions on the C side to allow evaluation,
- application, etc of a stable pointer.
-
- When Haskell calls C, it normally just passes over primitive integers,
- floats, bools, strings, etc. This doesn't cause any problems at all
- for garbage collection because the act of passing them makes a copy
- from the heap, stack or wherever they are onto the C-world stack.
- However, if we were to pass a heap object such as a (Haskell) @String@
- and a garbage collection occured before we finished using it, we'd run
- into problems since the heap object might have been moved or even
- deleted.
-
- So, if a C call is able to cause a garbage collection or we want to
- store a pointer to a heap object between C calls, we must be careful
- when passing heap objects. Our solution is to keep a table of all
- objects we've given to the C-world and to make sure that the garbage
- collector collects these objects --- updating the table as required to
- make sure we can still find the object.
-*/
-
-
-StgPtr *stable_ptr_table;
-StgPtr *stable_ptr_free;
-
-static nat SPT_size;
-
-#define INIT_SPT_SIZE 64
-
-static inline void
-initFreeList(StgPtr *table, nat n, StgPtr *free)
-{
- StgPtr *p;
-
- for (p = table + n - 1; p >= table; p--) {
- *p = (P_)free;
- free = p;
- }
- stable_ptr_free = table;
-}
-
-void
-initStablePtrTable(void)
-{
- SPT_size = INIT_SPT_SIZE;
- stable_ptr_table = stgMallocWords(SPT_size, "initStablePtrTable");
-
- initFreeList(stable_ptr_table,INIT_SPT_SIZE,NULL);
-}
-
-void
-enlargeStablePtrTable(void)
-{
- nat old_SPT_size = SPT_size;
-
- SPT_size *= 2;
- stable_ptr_table = stgReallocWords(stable_ptr_table, SPT_size,
- "enlargeStablePtrTable");
-
- initFreeList(stable_ptr_table + old_SPT_size, old_SPT_size, NULL);
-}
-
-void
-markStablePtrTable(void)
-{
- StgPtr *p, q, *end_stable_ptr_table;
-
- end_stable_ptr_table = &stable_ptr_table[SPT_size];
-
- for (p = stable_ptr_table; p < end_stable_ptr_table; p++) {
- q = *p;
- /* internal pointers or NULL are free slots */
- if (q && (q < (P_)stable_ptr_table || q >= (P_)end_stable_ptr_table)) {
- (StgClosure *)*p = MarkRoot((StgClosure *)q);
- }
- }
-}
-
-/* -----------------------------------------------------------------------------
- performIO
-
- This is a useful function for calling from C land (or Haskell land
- with _ccall_GC) which runs an arbitrary Haskell IO computation in a
- new thread.
-
- The closure to evaluate is passed in as a stable pointer, and
- should have type StablePtr (IO ()). No checking is done on the
- type, so be careful!
-
- The thread will be run in the context of the existing system;
- ie. running threads will continue to run etc.
- -------------------------------------------------------------------------- */
-
-void
-performIO(StgStablePtr io)
-{
- rts_evalIO((StgClosure *)deRefStablePointer(io), NULL);
-}
-
+++ /dev/null
-/* -----------------------------------------------------------------------------
- * $Id: StablePtr.h,v 1.2 1998/12/02 13:28:49 simonm Exp $
- *
- * Stable pointers
- *
- * ---------------------------------------------------------------------------*/
-
-extern StgPtr *stable_ptr_table;
-extern StgPtr *stable_ptr_free;
-
-extern void initStablePtrTable(void);
-extern void markStablePtrTable(void);
-extern void enlargeStablePtrTable(void);
-
-static inline StgPtr
-deRefStablePointer(StgInt stable_ptr)
-{
- return stable_ptr_table[stable_ptr];
-}
-
-extern void performIO(StgStablePtr stableIndex);
/* -----------------------------------------------------------------------------
- * $Id: StgMiscClosures.hc,v 1.7 1999/01/21 10:31:51 simonm Exp $
+ * $Id: StgMiscClosures.hc,v 1.8 1999/01/26 11:12:52 simonm Exp $
*
* Entry code for various built-in closure types.
*
NON_ENTERABLE_ENTRY_CODE(FOREIGN);
/* -----------------------------------------------------------------------------
+ Stable Names are unlifted too.
+ -------------------------------------------------------------------------- */
+
+INFO_TABLE(STABLE_NAME_info,STABLE_NAME_entry,0,1,STABLE_NAME,const,EF_,0,0);
+NON_ENTERABLE_ENTRY_CODE(STABLE_NAME);
+
+/* -----------------------------------------------------------------------------
MVars
There are two kinds of these: full and empty. We need an info table
/* -----------------------------------------------------------------------------
- * $Id: Weak.c,v 1.3 1999/01/13 17:25:49 simonm Exp $
+ * $Id: Weak.c,v 1.4 1999/01/26 11:12:53 simonm Exp $
*
* Weak pointers / finalisers
*
StgWeak *w;
for (w = weak_ptr_list; w; w = w->link) {
- IF_DEBUG(weak,fprintf(stderr,"Finalising weak pointer at %p\n", w));
+ IF_DEBUG(weak,fprintf(stderr,"Finalising weak pointer at %p -> %p\n", w, w->key));
w->header.info = &DEAD_WEAK_info;
rts_evalIO(w->finaliser,NULL);
}
StgWeak *w;
for (w = list; w; w = w->link) {
- IF_DEBUG(weak,fprintf(stderr,"Finalising weak pointer at %p\n", w));
+ IF_DEBUG(weak,fprintf(stderr,"Finalising weak pointer at %p -> %p\n", w, w->key));
#ifdef INTERPRETER
createGenThread(RtsFlags.GcFlags.initialStkSize, w->finaliser);
#else
createIOThread(RtsFlags.GcFlags.initialStkSize, w->finaliser);
#endif
w->header.info = &DEAD_WEAK_info;
-
- /* need to fill the slop with zeros if we're sanity checking */
- IF_DEBUG(sanity, {
- nat dw_size = sizeW_fromITBL(get_itbl(w));
- memset((P_)w + dw_size, 0, (sizeofW(StgWeak) - dw_size) * sizeof(W_));
- });
}
}
module Main where
-import PrelForeign
+import PrelStable
-- Testing callbacks: the initial haskell thread calls out to C with
-- the address of a Haskell callback. The C function runs the callback
--- /dev/null
+module Main where
+
+import PrelStable
+
+main = do
+ stable_list1 <- mapM makeStableName list
+ stable_list2 <- mapM makeStableName list
+ print (stable_list1 == stable_list2)
+
+list = [1..10000] :: [Integer]
projects / ghc-hetmet.git / commitdiff