From ed4cd6d403d932026f38608f81c3a8872e38b2ce Mon Sep 17 00:00:00 2001 From: simonm Date: Tue, 26 Jan 1999 11:13:15 +0000 Subject: [PATCH] [project @ 1999-01-26 11:12:41 by simonm] - Add Stable Names - Stable pointers and stable names are now both provided by the "Stable" module in ghc/lib/exts. Documentation is updated, and Foriegn still exports the stable pointer operations for backwards compatibility. --- ghc/compiler/absCSyn/PprAbsC.lhs | 1 + ghc/compiler/basicTypes/Unique.lhs | 12 ++- ghc/compiler/nativeGen/AsmCodeGen.lhs | 73 +++++++++++++ ghc/compiler/prelude/PrelInfo.lhs | 7 +- ghc/compiler/prelude/PrelMods.lhs | 5 +- ghc/compiler/prelude/PrimOp.lhs | 136 ++++++++++++++++-------- ghc/compiler/prelude/PrimRep.lhs | 10 ++ ghc/compiler/prelude/TysPrim.lhs | 13 +++ ghc/compiler/prelude/TysWiredIn.lhs | 21 +--- ghc/compiler/simplCore/Simplify.lhs | 4 +- ghc/compiler/types/TyCon.lhs | 1 + ghc/docs/libraries/Foreign.sgml | 41 ++------ ghc/docs/libraries/Weak.sgml | 12 +-- ghc/docs/libraries/libs.sgml | 4 +- ghc/includes/ClosureTypes.h | 11 +- ghc/includes/Closures.h | 7 +- ghc/includes/InfoTables.h | 4 +- ghc/includes/Prelude.h | 10 +- ghc/includes/PrimOps.h | 64 ++++-------- ghc/includes/Rts.h | 3 +- ghc/includes/Stg.h | 46 +++++---- ghc/includes/StgMiscClosures.h | 4 +- ghc/includes/StgTypes.h | 12 ++- ghc/rts/Adjustor.c | 4 +- ghc/rts/Evaluator.c | 6 +- ghc/rts/GC.c | 117 +++++++++++++-------- ghc/rts/GC.h | 3 +- ghc/rts/Makefile | 3 +- ghc/rts/PrimOps.hc | 31 +++--- ghc/rts/RtsFlags.h | 4 +- ghc/rts/RtsStartup.c | 4 +- ghc/rts/Sanity.c | 3 +- ghc/rts/Schedule.c | 5 +- ghc/rts/Signals.c | 8 +- ghc/rts/StablePtr.c | 165 ------------------------------ ghc/rts/StablePtr.h | 21 ---- ghc/rts/StgMiscClosures.hc | 9 +- ghc/rts/Weak.c | 12 +-- ghc/tests/lib/should_run/stableptr002.hs | 2 +- ghc/tests/lib/should_run/stableptr003.hs | 10 ++ 40 files changed, 445 insertions(+), 463 deletions(-) delete mode 100644 ghc/rts/StablePtr.c delete mode 100644 ghc/rts/StablePtr.h create mode 100644 ghc/tests/lib/should_run/stableptr003.hs diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index 9531325..d0b396e 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -1244,6 +1244,7 @@ pprUnionTag FloatRep = char 'f' pprUnionTag DoubleRep = panic "pprUnionTag:Double?" pprUnionTag StablePtrRep = char 'i' +pprUnionTag StableNameRep = char 'p' pprUnionTag WeakPtrRep = char 'p' pprUnionTag ForeignObjRep = char 'p' diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs index f518899..bdd8513 100644 --- a/ghc/compiler/basicTypes/Unique.lhs +++ b/ghc/compiler/basicTypes/Unique.lhs @@ -160,8 +160,9 @@ module Unique ( stablePtrDataConKey, stablePtrPrimTyConKey, stablePtrTyConKey, - stateDataConKey, - stateTyConKey, + stableNameDataConKey, + stableNamePrimTyConKey, + stableNameTyConKey, statePrimTyConKey, typeConKey, @@ -517,8 +518,9 @@ rationalTyConKey = mkPreludeTyConUnique 31 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 @@ -562,7 +564,7 @@ foreignObjDataConKey = mkPreludeDataConUnique 13 nilDataConKey = mkPreludeDataConUnique 14 ratioDataConKey = mkPreludeDataConUnique 15 stablePtrDataConKey = mkPreludeDataConUnique 16 -stateDataConKey = mkPreludeDataConUnique 33 +stableNameDataConKey = mkPreludeDataConUnique 17 trueDataConKey = mkPreludeDataConUnique 34 wordDataConKey = mkPreludeDataConUnique 35 word8DataConKey = mkPreludeDataConUnique 36 diff --git a/ghc/compiler/nativeGen/AsmCodeGen.lhs b/ghc/compiler/nativeGen/AsmCodeGen.lhs index 1e297ad..ce8587b 100644 --- a/ghc/compiler/nativeGen/AsmCodeGen.lhs +++ b/ghc/compiler/nativeGen/AsmCodeGen.lhs @@ -21,8 +21,13 @@ import OrdList ( OrdList ) 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 @@ -85,7 +90,14 @@ runNCG absC 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: @@ -282,3 +294,64 @@ Anything else is just too hard. \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} diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs index 830247a..788ad25 100644 --- a/ghc/compiler/prelude/PrelInfo.lhs +++ b/ghc/compiler/prelude/PrelInfo.lhs @@ -171,6 +171,7 @@ prim_tycons , mutVarPrimTyCon , realWorldTyCon , stablePtrPrimTyCon + , stableNamePrimTyCon , statePrimTyCon , threadIdPrimTyCon , wordPrimTyCon @@ -459,9 +460,9 @@ byteArrayTyCon_RDR = tcQual (pREL_ARR, SLIT("ByteArray")) 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")) diff --git a/ghc/compiler/prelude/PrelMods.lhs b/ghc/compiler/prelude/PrelMods.lhs index bbdee40..3090ef7 100644 --- a/ghc/compiler/prelude/PrelMods.lhs +++ b/ghc/compiler/prelude/PrelMods.lhs @@ -17,6 +17,7 @@ module PrelMods 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 @@ -31,7 +32,8 @@ import Panic ( panic ) \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" @@ -47,6 +49,7 @@ pREL_IO_BASE = mkModule "PrelIOBase" pREL_ST = mkModule "PrelST" pREL_ARR = mkModule "PrelArr" pREL_FOREIGN = mkModule "PrelForeign" +pREL_STABLE = mkModule "PrelStable" pREL_ADDR = mkModule "PrelAddr" pREL_ERR = mkModule "PrelErr" diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index f65aa02..8829735 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -173,6 +173,10 @@ data PrimOp | MkWeakOp | DeRefWeakOp + | MakeStableNameOp + | EqStableNameOp + | StableNameToIntOp + | MakeStablePtrOp | DeRefStablePtrOp | EqStablePtrOp @@ -496,32 +500,35 @@ tagOf_PrimOp MakeForeignObjOp = ILIT(201) 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" @@ -758,6 +765,9 @@ allThePrimOps WriteForeignObjOp, MkWeakOp, DeRefWeakOp, + MakeStableNameOp, + EqStableNameOp, + StableNameToIntOp, MakeStablePtrOp, DeRefStablePtrOp, EqStablePtrOp, @@ -874,6 +884,7 @@ primOpStrictness CatchOp = ([wwLazy, wwLazy], False) 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 @@ -1580,39 +1591,63 @@ primOpInfo DeRefWeakOp %************************************************************************ %* * -\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 @@ -1630,6 +1665,22 @@ primOpInfo EqStablePtrOp = 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} %************************************************************************ @@ -1772,8 +1823,8 @@ primOpOutOfLine op DoubleDecodeOp -> True MkWeakOp -> True DeRefWeakOp -> True + MakeStableNameOp -> True MakeForeignObjOp -> True - MakeStablePtrOp -> True NewMutVarOp -> True NewMVarOp -> True ForkOp -> True @@ -1854,6 +1905,7 @@ primOpHasSideEffects WriteForeignObjOp = True primOpHasSideEffects MkWeakOp = True primOpHasSideEffects DeRefWeakOp = True primOpHasSideEffects MakeStablePtrOp = True +primOpHasSideEffects MakeStableNameOp = True primOpHasSideEffects EqStablePtrOp = True -- SOF primOpHasSideEffects DeRefStablePtrOp = True -- ??? JSM & ADR @@ -1914,7 +1966,7 @@ primOpNeedsWrapper DoubleTanhOp = True primOpNeedsWrapper DoublePowerOp = True primOpNeedsWrapper DoubleEncodeOp = True -primOpNeedsWrapper MakeStablePtrOp = True +primOpNeedsWrapper MakeStableNameOp = True primOpNeedsWrapper DeRefStablePtrOp = True primOpNeedsWrapper DelayOp = True diff --git a/ghc/compiler/prelude/PrimRep.lhs b/ghc/compiler/prelude/PrimRep.lhs index 9dfd5b4..2b934c3 100644 --- a/ghc/compiler/prelude/PrimRep.lhs +++ b/ghc/compiler/prelude/PrimRep.lhs @@ -62,6 +62,12 @@ data PrimRep -- 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 @@ -105,6 +111,7 @@ isFollowableRep ArrayRep = True -- all heap objects: isFollowableRep ByteArrayRep = True -- '' isFollowableRep WeakPtrRep = True -- '' isFollowableRep ForeignObjRep = True -- '' +isFollowableRep StableNameRep = True -- '' isFollowableRep ThreadIdRep = True -- pointer to a TSO isFollowableRep other = False @@ -179,6 +186,7 @@ getPrimRepSizeInBytes pr = WeakPtrRep -> 4 ForeignObjRep -> 4 StablePtrRep -> 4 + StableNameRep -> 4 ArrayRep -> 4 ByteArrayRep -> 4 _ -> panic "getPrimRepSize: ouch - this wasn't supposed to happen!" @@ -217,6 +225,7 @@ showPrimRep DoubleRep = "StgDouble" showPrimRep ArrayRep = "P_" -- see comment below showPrimRep ByteArrayRep = "StgByteArray" showPrimRep StablePtrRep = "StgStablePtr" +showPrimRep StableNameRep = "P_" showPrimRep ThreadIdRep = "StgTSO*" showPrimRep WeakPtrRep = "P_" showPrimRep ForeignObjRep = "StgAddr" @@ -233,6 +242,7 @@ primRepString DoubleRep = "Double" primRepString WeakPtrRep = "Weak" primRepString ForeignObjRep = "ForeignObj" primRepString StablePtrRep = "StablePtr" +primRepString StableNameRep = "StableName" primRepString other = pprPanic "primRepString" (ppr other) showPrimRepToUser pr = primRepString pr diff --git a/ghc/compiler/prelude/TysPrim.lhs b/ghc/compiler/prelude/TysPrim.lhs index 406dfb7..1bb342c 100644 --- a/ghc/compiler/prelude/TysPrim.lhs +++ b/ghc/compiler/prelude/TysPrim.lhs @@ -30,6 +30,7 @@ module TysPrim( mVarPrimTyCon, mkMVarPrimTy, stablePtrPrimTyCon, mkStablePtrPrimTy, + stableNamePrimTyCon, mkStableNamePrimTy, weakPrimTyCon, mkWeakPrimTy, foreignObjPrimTyCon, foreignObjPrimTy, threadIdPrimTyCon, threadIdPrimTy, @@ -217,6 +218,18 @@ mkStablePtrPrimTy ty = mkTyConApp stablePtrPrimTyCon [ty] %************************************************************************ %* * +\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} %* * %************************************************************************ diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index 3a2a16f..a03554c 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -61,10 +61,6 @@ module TysWiredIn ( unboxedTupleTyCon, unboxedTupleCon, unboxedPairTyCon, unboxedPairDataCon, - stateDataCon, - stateTyCon, - realWorldStateTy, - stablePtrTyCon, stringTy, trueDataCon, @@ -383,22 +379,12 @@ doubleDataCon = pcDataCon doubleDataConKey pREL_BASE SLIT("D#") [] [] [doublePri \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} @@ -460,7 +446,8 @@ primArgTyConKeys , 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. diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index cac1d68..a3a5caf 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -941,8 +941,8 @@ okToInline sw_chkr in_scope id form guidance cont 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} diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index 189b0da..fb969bc 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -322,6 +322,7 @@ maybeTyConSingleCon (AlgTyCon {dataCons = [c]}) = Just c maybeTyConSingleCon (AlgTyCon {}) = Nothing maybeTyConSingleCon (TupleTyCon {dataCon = con}) = Just con maybeTyConSingleCon (PrimTyCon {}) = Nothing +maybeTyConSingleCon other = panic (showSDoc (ppr other)) \end{code} \begin{code} diff --git a/ghc/docs/libraries/Foreign.sgml b/ghc/docs/libraries/Foreign.sgml index 4f59f39..8ca16ee 100644 --- a/ghc/docs/libraries/Foreign.sgml +++ b/ghc/docs/libraries/Foreign.sgml @@ -1,48 +1,21 @@ -

-This module provides two types to better allow the Haskell world to -share its data with the outside world (and vice versa), ). 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 () - -The -void finaliseFO(void* obj); - - -The finaliser is passed the reference to the external object (i.e., -the first argument to -The -Stable pointers allow you to hand out references to Haskell heap -objects to the outside world. - In addition to the above, the following operations for indexing via a Finalisation for foreign objects +

A foreign object is some data that lives outside the Haskell heap, for @@ -250,15 +251,14 @@ references to its key and trigger the finaliser despite the fact that the program still holds the ). Historical note: ). +decomposed into an + ]> @@ -83,14 +84,15 @@ the form diff --git a/ghc/includes/ClosureTypes.h b/ghc/includes/ClosureTypes.h index d392b92..9ae6332 100644 --- a/ghc/includes/ClosureTypes.h +++ b/ghc/includes/ClosureTypes.h @@ -1,5 +1,5 @@ /* ---------------------------------------------------------------------------- - * $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 * @@ -55,9 +55,10 @@ #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 diff --git a/ghc/includes/Closures.h b/ghc/includes/Closures.h index 13ba416..e2e2932 100644 --- a/ghc/includes/Closures.h +++ b/ghc/includes/Closures.h @@ -1,5 +1,5 @@ /* ---------------------------------------------------------------------------- - * $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 * @@ -243,6 +243,11 @@ typedef struct _StgForeignObj { 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; diff --git a/ghc/includes/InfoTables.h b/ghc/includes/InfoTables.h index 78e754d..fb1640d 100644 --- a/ghc/includes/InfoTables.h +++ b/ghc/includes/InfoTables.h @@ -1,5 +1,5 @@ /* ---------------------------------------------------------------------------- - * $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 * @@ -141,6 +141,7 @@ typedef enum { , WEAK , FOREIGN + , STABLE_NAME , TSO @@ -200,6 +201,7 @@ typedef enum { #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 ) diff --git a/ghc/includes/Prelude.h b/ghc/includes/Prelude.h index 3b5ce6e..deab0b8 100644 --- a/ghc/includes/Prelude.h +++ b/ghc/includes/Prelude.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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. * @@ -30,8 +30,8 @@ extern const StgInfoTable PrelAddr_AZh_con_info; 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. @@ -55,8 +55,8 @@ extern const StgInfoTable PrelForeign_StablePtr_con_info; #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 diff --git a/ghc/includes/PrimOps.h b/ghc/includes/PrimOps.h index e68a09d..67dd76e 100644 --- a/ghc/includes/PrimOps.h +++ b/ghc/includes/PrimOps.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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. * @@ -633,54 +633,30 @@ EF_(raiseZh_fast); 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. diff --git a/ghc/includes/Rts.h b/ghc/includes/Rts.h index 45f66cf..b649e0b 100644 --- a/ghc/includes/Rts.h +++ b/ghc/includes/Rts.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -83,7 +83,6 @@ typedef enum { #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 diff --git a/ghc/includes/Stg.h b/ghc/includes/Stg.h index 555c7b1..3c9a1b4 100644 --- a/ghc/includes/Stg.h +++ b/ghc/includes/Stg.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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. * @@ -25,6 +25,32 @@ #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" @@ -92,6 +118,7 @@ #include "Updates.h" #include "StgTicky.h" #include "CCall.h" +#include "Stable.h" /* Built-in entry points */ #include "StgMiscClosures.h" @@ -112,21 +139,4 @@ extern char **environ; 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 */ diff --git a/ghc/includes/StgMiscClosures.h b/ghc/includes/StgMiscClosures.h index 0598ccd..990385c 100644 --- a/ghc/includes/StgMiscClosures.h +++ b/ghc/includes/StgMiscClosures.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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. * @@ -27,6 +27,7 @@ STGFUN(EVACUATED_entry); 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); @@ -57,6 +58,7 @@ extern const StgInfoTable EVACUATED_info; 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; diff --git a/ghc/includes/StgTypes.h b/ghc/includes/StgTypes.h index ee15623..c067521 100644 --- a/ghc/includes/StgTypes.h +++ b/ghc/includes/StgTypes.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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. @@ -109,7 +109,6 @@ typedef StgWord StgOffset; /* byte offset within closure */ typedef struct StgTSO_* StgTSOPtr; -typedef StgWord StgStablePtr; typedef void * StgForeignPtr; typedef StgInt StgStackOffset; /* offset in words! */ @@ -125,6 +124,15 @@ typedef char* StgByteArray; /* the goods of a ByteArray# */ 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 diff --git a/ghc/rts/Adjustor.c b/ghc/rts/Adjustor.c index b976f38..e88262d 100644 --- a/ghc/rts/Adjustor.c +++ b/ghc/rts/Adjustor.c @@ -147,9 +147,9 @@ freeHaskellFunctionPtr(void* ptr) /* 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'; diff --git a/ghc/rts/Evaluator.c b/ghc/rts/Evaluator.c index b951f3c..e99a149 100644 --- a/ghc/rts/Evaluator.c +++ b/ghc/rts/Evaluator.c @@ -5,8 +5,8 @@ * 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" @@ -23,7 +23,7 @@ #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" diff --git a/ghc/rts/GC.c b/ghc/rts/GC.c index fa0977f..619aa5c 100644 --- a/ghc/rts/GC.c +++ b/ghc/rts/GC.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -20,6 +20,7 @@ #include "DebugProf.h" #include "SchedAPI.h" #include "Weak.h" +#include "StablePriv.h" StgCAF* enteredCAFs; @@ -317,6 +318,10 @@ void GarbageCollect(void (*get_roots)(void)) 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 @@ -392,6 +397,10 @@ void GarbageCollect(void (*get_roots)(void)) } } + /* 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. @@ -695,8 +704,7 @@ static rtsBool 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; } @@ -708,56 +716,26 @@ traverse_weak_ptr_list(void) 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; } } @@ -776,11 +754,57 @@ traverse_weak_ptr_list(void) 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) @@ -1052,6 +1076,12 @@ loop: 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: @@ -1460,6 +1490,7 @@ scavenge(step *step) case CONSTR: case WEAK: case FOREIGN: + case STABLE_NAME: case IND_PERM: case IND_OLDGEN_PERM: case CAF_UNENTERED: diff --git a/ghc/rts/GC.h b/ghc/rts/GC.h index 8b2c30b..7b42b4e 100644 --- a/ghc/rts/GC.h +++ b/ghc/rts/GC.h @@ -1,8 +1,9 @@ /* ----------------------------------------------------------------------------- - * $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); diff --git a/ghc/rts/Makefile b/ghc/rts/Makefile index a66d115..26280eb 100644 --- a/ghc/rts/Makefile +++ b/ghc/rts/Makefile @@ -1,5 +1,5 @@ #----------------------------------------------------------------------------- -# $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). @@ -54,6 +54,7 @@ WARNING_OPTS += -optc-Wbad-function-cast #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 diff --git a/ghc/rts/PrimOps.hc b/ghc/rts/PrimOps.hc index d99a430..ae40080 100644 --- a/ghc/rts/PrimOps.hc +++ b/ghc/rts/PrimOps.hc @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -16,7 +16,7 @@ #include "RtsUtils.h" #include "Storage.h" #include "BlockAlloc.h" /* tmp */ -#include "StablePtr.h" +#include "StablePriv.h" /* ** temporary ** @@ -849,22 +849,25 @@ FN_(putMVarZh_fast) 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 */ diff --git a/ghc/rts/RtsFlags.h b/ghc/rts/RtsFlags.h index a82ec51..da65c5b 100644 --- a/ghc/rts/RtsFlags.h +++ b/ghc/rts/RtsFlags.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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. * @@ -49,6 +49,8 @@ struct DEBUG_FLAGS { /* flags to control consistency checking (often very expensive!) */ rtsBool sanity : 1; /* 128 */ + + rtsBool stable : 1; /* 256 */ }; #if defined(PROFILING) || defined(PAR) diff --git a/ghc/rts/RtsStartup.c b/ghc/rts/RtsStartup.c index 5ad4a17..d079f6e 100644 --- a/ghc/rts/RtsStartup.c +++ b/ghc/rts/RtsStartup.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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. * @@ -10,7 +10,7 @@ #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" diff --git a/ghc/rts/Sanity.c b/ghc/rts/Sanity.c index 00ebb3c..311930e 100644 --- a/ghc/rts/Sanity.c +++ b/ghc/rts/Sanity.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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. * @@ -215,6 +215,7 @@ checkClosure( StgClosure* p ) case BLACKHOLE: case BLACKHOLE_BQ: case FOREIGN: + case STABLE_NAME: case MUT_VAR: case CONSTR_INTLIKE: case CONSTR_CHARLIKE: diff --git a/ghc/rts/Schedule.c b/ghc/rts/Schedule.c index 4ee0892..1cdaa0c 100644 --- a/ghc/rts/Schedule.c +++ b/ghc/rts/Schedule.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -21,7 +21,6 @@ #include "Printer.h" #include "Main.h" #include "Signals.h" -#include "StablePtr.h" #include "Profiling.h" #include "Sanity.h" @@ -607,8 +606,6 @@ static void GetRoots(void) for (i = 0; i < next_main_thread; i++) { main_threads[i] = (StgTSO *)MarkRoot((StgClosure *)main_threads[i]); } - - markStablePtrTable(); } /* ----------------------------------------------------------------------------- diff --git a/ghc/rts/Signals.c b/ghc/rts/Signals.c index 5c47e12..7062102 100644 --- a/ghc/rts/Signals.c +++ b/ghc/rts/Signals.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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. * @@ -10,7 +10,7 @@ #include "Signals.h" #include "RtsUtils.h" #include "RtsFlags.h" -#include "StablePtr.h" +#include "StablePriv.h" #ifndef PAR @@ -93,7 +93,7 @@ generic_handler(int sig) 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]) { @@ -188,7 +188,7 @@ sig_install(StgInt sig, StgInt spi, StgStablePtr handler, sigset_t *mask) * by freeing the previous handler if there was one. */ if (previous_spi >= 0) { - freeStablePointer(handlers[sig]); + freeStablePtr(handlers[sig]); } return STG_SIG_ERR; } diff --git a/ghc/rts/StablePtr.c b/ghc/rts/StablePtr.c deleted file mode 100644 index 6db9d3c..0000000 --- a/ghc/rts/StablePtr.c +++ /dev/null @@ -1,165 +0,0 @@ -/* ----------------------------------------------------------------------------- - * $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); -} - diff --git a/ghc/rts/StablePtr.h b/ghc/rts/StablePtr.h deleted file mode 100644 index 546e701..0000000 --- a/ghc/rts/StablePtr.h +++ /dev/null @@ -1,21 +0,0 @@ -/* ----------------------------------------------------------------------------- - * $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); diff --git a/ghc/rts/StgMiscClosures.hc b/ghc/rts/StgMiscClosures.hc index 94dc96c..9bc0930 100644 --- a/ghc/rts/StgMiscClosures.hc +++ b/ghc/rts/StgMiscClosures.hc @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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. * @@ -247,6 +247,13 @@ INFO_TABLE(FOREIGN_info,FOREIGN_entry,0,1,FOREIGN,const,EF_,0,0); 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 diff --git a/ghc/rts/Weak.c b/ghc/rts/Weak.c index 9cd70eb..48e7310 100644 --- a/ghc/rts/Weak.c +++ b/ghc/rts/Weak.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -25,7 +25,7 @@ finaliseWeakPointersNow(void) 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); } @@ -43,19 +43,13 @@ scheduleFinalisers(StgWeak *list) 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_)); - }); } } diff --git a/ghc/tests/lib/should_run/stableptr002.hs b/ghc/tests/lib/should_run/stableptr002.hs index 5d436ad..3edcc6c 100644 --- a/ghc/tests/lib/should_run/stableptr002.hs +++ b/ghc/tests/lib/should_run/stableptr002.hs @@ -1,6 +1,6 @@ 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 diff --git a/ghc/tests/lib/should_run/stableptr003.hs b/ghc/tests/lib/should_run/stableptr003.hs new file mode 100644 index 0000000..81f12a5 --- /dev/null +++ b/ghc/tests/lib/should_run/stableptr003.hs @@ -0,0 +1,10 @@ +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] -- 1.7.10.4