X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Data%2FTypeable.hs;h=d187296faca25b2f75762d32521ef6844e5beb46;hb=a2a70b9bf60672c72b35654105402cf21238b6f4;hp=8bd01f78e1389a22a591fec4a57b8b5b64a74eee;hpb=48a210e49396b4998174350191759879b442ad75;p=haskell-directory.git diff --git a/Data/Typeable.hs b/Data/Typeable.hs index 8bd01f7..d187296 100644 --- a/Data/Typeable.hs +++ b/Data/Typeable.hs @@ -1,4 +1,11 @@ -{-# OPTIONS -fno-implicit-prelude #-} +{-# OPTIONS_GHC -fno-implicit-prelude -fallow-overlapping-instances #-} + +-- The -fallow-overlapping-instances flag allows the user to over-ride +-- the instances for Typeable given here. In particular, we provide an instance +-- instance ... => Typeable (s a) +-- But a user might want to say +-- instance ... => Typeable (MyType a b) + ----------------------------------------------------------------------------- -- | -- Module : Data.Typeable @@ -9,24 +16,15 @@ -- Stability : experimental -- Portability : portable -- --- The Typeable class reifies types to some extent by associating type +-- The 'Typeable' class reifies types to some extent by associating type -- representations to types. These type representations can be compared, -- and one can in turn define a type-safe cast operation. To this end, -- an unsafe cast is guarded by a test for type (representation) --- equivalence. The module Data.Dynamic uses Typeable for an --- implementation of dynamics. The module Data.Generics uses Typeable +-- equivalence. The module "Data.Dynamic" uses Typeable for an +-- implementation of dynamics. The module "Data.Generics" uses Typeable -- and type-safe cast (but not dynamics) to support the \"Scrap your -- boilerplate\" style of generic programming. -- --- Note, only relevant if you use dynamic linking. If you have a program --- that is statically linked with Data.Typeable, and then dynamically link --- a program that also uses Data.Typeable, you'll get two copies of the module. --- That's fine, but behind the scenes, the module uses a mutable variable to --- allocate unique Ids to type constructors. So in the situation described, --- there'll be two separate Id allocators, which aren't comparable to each other. --- This can lead to chaos. (It's a bug that we will fix.) None of --- this matters if you aren't using dynamic linking. --- ----------------------------------------------------------------------------- module Data.Typeable @@ -55,6 +53,7 @@ module Data.Typeable typeRepTyCon, -- :: TypeRep -> TyCon typeRepArgs, -- :: TypeRep -> [TypeRep] tyConString, -- :: TyCon -> String + typeRepKey, -- :: TypeRep -> IO Int -- * The other Typeable classes -- | /Note:/ The general instances are provided for GHC only. @@ -94,17 +93,36 @@ import GHC.Show import GHC.Err import GHC.Num import GHC.Float -import GHC.Real( rem, Ratio ) -import GHC.IOBase -import GHC.Ptr -- So we can give Typeable instance for Ptr -import GHC.Stable -- So we can give Typeable instance for StablePtr +import GHC.Real ( rem, Ratio ) +import GHC.IOBase (IORef,newIORef,unsafePerformIO) + +-- These imports are so we can define Typeable instances +-- It'd be better to give Typeable instances in the modules themselves +-- but they all have to be compiled before Typeable +import GHC.IOBase ( IO, MVar, Exception, ArithException, IOException, + ArrayException, AsyncException, Handle ) +import GHC.ST ( ST ) +import GHC.STRef ( STRef ) +import GHC.Ptr ( Ptr, FunPtr ) +import GHC.ForeignPtr ( ForeignPtr ) +import GHC.Stable ( StablePtr, newStablePtr, freeStablePtr, + deRefStablePtr, castStablePtrToPtr, + castPtrToStablePtr ) +import GHC.Exception ( block ) +import GHC.Arr ( Array, STArray ) + #endif #ifdef __HUGS__ -import Hugs.Prelude -import Hugs.IO -import Hugs.IORef -import Hugs.IOExts +import Hugs.Prelude ( Key(..), TypeRep(..), TyCon(..), Ratio, + Exception, ArithException, IOException, + ArrayException, AsyncException, Handle, + Ptr, FunPtr, ForeignPtr, StablePtr ) +import Hugs.IORef ( IORef, newIORef, readIORef, writeIORef ) +import Hugs.IOExts ( unsafePerformIO, unsafeCoerce ) + -- For the Typeable instance +import Hugs.Array ( Array ) +import Hugs.ConcBase ( MVar ) #endif #ifdef __GLASGOW_HASKELL__ @@ -117,8 +135,9 @@ import NonStdUnsafeCoerce (unsafeCoerce) import NHC.IOExtras (IORef,newIORef,readIORef,writeIORef,unsafePerformIO) import IO (Handle) import Ratio (Ratio) -import NHC.FFI (Ptr,StablePtr) -#else + -- For the Typeable instance +import NHC.FFI ( Ptr,FunPtr,StablePtr,ForeignPtr ) +import Array ( Array ) #endif #include "Typeable.h" @@ -145,9 +164,21 @@ data TyCon = TyCon !Key String instance Eq TyCon where (TyCon t1 _) == (TyCon t2 _) = t1 == t2 - #endif +-- | Returns a unique integer associated with a 'TypeRep'. This can +-- be used for making a mapping ('Data.IntMap.IntMap') with TypeReps +-- as the keys, for example. It is guaranteed that @t1 == t2@ if and only if +-- @typeRepKey t1 == typeRepKey t2@. +-- +-- It is in the 'IO' monad because the actual value of the key may +-- vary from run to run of the program. You should only rely on +-- the equality property, not any actual key value. The relative ordering +-- of keys has no meaning either. +-- +typeRepKey :: TypeRep -> IO Int +typeRepKey (TypeRep (Key i) _ _) = return i + -- -- let fTy = mkTyCon "Foo" in show (mkTyConApp (mkTyCon ",,") -- [fTy,fTy,fTy]) @@ -457,13 +488,37 @@ gcast2 x = r -- ------------------------------------------------------------- +INSTANCE_TYPEABLE0((),unitTc,"()") INSTANCE_TYPEABLE1([],listTc,"[]") INSTANCE_TYPEABLE1(Maybe,maybeTc,"Maybe") INSTANCE_TYPEABLE1(Ratio,ratioTc,"Ratio") INSTANCE_TYPEABLE2(Either,eitherTc,"Either") INSTANCE_TYPEABLE2((->),funTc,"->") INSTANCE_TYPEABLE1(IO,ioTc,"IO") -INSTANCE_TYPEABLE0((),unitTc,"()") + +#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__) +-- Types defined in GHC.IOBase +INSTANCE_TYPEABLE1(MVar,mvarTc,"MVar" ) +INSTANCE_TYPEABLE0(Exception,exceptionTc,"Exception") +INSTANCE_TYPEABLE0(IOException,ioExceptionTc,"IOException") +INSTANCE_TYPEABLE0(ArithException,arithExceptionTc,"ArithException") +INSTANCE_TYPEABLE0(ArrayException,arrayExceptionTc,"ArrayException") +INSTANCE_TYPEABLE0(AsyncException,asyncExceptionTc,"AsyncException") +#endif + +-- Types defined in GHC.Arr +INSTANCE_TYPEABLE2(Array,arrayTc,"Array") + +#ifdef __GLASGOW_HASKELL__ +-- Hugs has these too, but their Typeable instances are defined +-- elsewhere to keep this module within Haskell 98. +-- This is important because every invocation of runhugs or ffihugs +-- uses this module via Data.Dynamic. +INSTANCE_TYPEABLE2(ST,stTc,"ST") +INSTANCE_TYPEABLE2(STRef,stRefTc,"STRef") +INSTANCE_TYPEABLE3(STArray,sTArrayTc,"STArray") +#endif + #ifndef __NHC__ INSTANCE_TYPEABLE2((,),pairTc,",") INSTANCE_TYPEABLE3((,,),tup3Tc,",,") @@ -491,11 +546,13 @@ tup7Tc = mkTyCon ",,,,,," instance Typeable7 (,,,,,,) where typeOf7 tu = mkTyConApp tup7Tc [] - #endif /* __NHC__ */ + INSTANCE_TYPEABLE1(Ptr,ptrTc,"Ptr") -INSTANCE_TYPEABLE1(StablePtr,stableptrTc,"StablePtr") -INSTANCE_TYPEABLE1(IORef,iorefTc,"IORef") +INSTANCE_TYPEABLE1(FunPtr,funPtrTc,"FunPtr") +INSTANCE_TYPEABLE1(ForeignPtr,foreignPtrTc,"ForeignPtr") +INSTANCE_TYPEABLE1(StablePtr,stablePtrTc,"StablePtr") +INSTANCE_TYPEABLE1(IORef,iORefTc,"IORef") ------------------------------------------------------- -- @@ -508,6 +565,9 @@ INSTANCE_TYPEABLE0(Char,charTc,"Char") INSTANCE_TYPEABLE0(Float,floatTc,"Float") INSTANCE_TYPEABLE0(Double,doubleTc,"Double") INSTANCE_TYPEABLE0(Int,intTc,"Int") +#ifndef __NHC__ +INSTANCE_TYPEABLE0(Word,wordTc,"Word" ) +#endif INSTANCE_TYPEABLE0(Integer,integerTc,"Integer") INSTANCE_TYPEABLE0(Ordering,orderingTc,"Ordering") INSTANCE_TYPEABLE0(Handle,handleTc,"Handle") @@ -526,7 +586,7 @@ INSTANCE_TYPEABLE0(TyCon,tyconTc,"TyCon") INSTANCE_TYPEABLE0(TypeRep,typeRepTc,"TypeRep") #ifdef __GLASGOW_HASKELL__ -INSTANCE_TYPEABLE0(Word,wordTc,"Word" ) +INSTANCE_TYPEABLE0(RealWorld,realWorldTc,"RealWorld") #endif --------------------------------------------- @@ -544,19 +604,38 @@ data KeyPr = KeyPr !Key !Key deriving( Eq ) hashKP :: KeyPr -> Int32 hashKP (KeyPr (Key k1) (Key k2)) = (HT.hashInt k1 + HT.hashInt k2) `rem` HT.prime -data Cache = Cache { next_key :: !(IORef Key), +data Cache = Cache { next_key :: !(IORef Key), -- Not used by GHC (calls genSym instead) tc_tbl :: !(HT.HashTable String Key), ap_tbl :: !(HT.HashTable KeyPr Key) } {-# NOINLINE cache #-} +#ifdef __GLASGOW_HASKELL__ +foreign import ccall unsafe "RtsTypeable.h getOrSetTypeableStore" + getOrSetTypeableStore :: Ptr a -> IO (Ptr a) +#endif + cache :: Cache cache = unsafePerformIO $ do empty_tc_tbl <- HT.new (==) HT.hashString empty_ap_tbl <- HT.new (==) hashKP key_loc <- newIORef (Key 1) - return (Cache { next_key = key_loc, - tc_tbl = empty_tc_tbl, - ap_tbl = empty_ap_tbl }) + let ret = Cache { next_key = key_loc, + tc_tbl = empty_tc_tbl, + ap_tbl = empty_ap_tbl } +#ifdef __GLASGOW_HASKELL__ + block $ do + stable_ref <- newStablePtr ret + let ref = castStablePtrToPtr stable_ref + ref2 <- getOrSetTypeableStore ref + if ref==ref2 + then deRefStablePtr stable_ref + else do + freeStablePtr stable_ref + deRefStablePtr + (castPtrToStablePtr ref2) +#else + return ret +#endif newKey :: IORef Key -> IO Key #ifdef __GLASGOW_HASKELL__ @@ -568,16 +647,6 @@ newKey kloc = do { k@(Key i) <- readIORef kloc ; #endif #ifdef __GLASGOW_HASKELL__ --- In GHC we use the RTS's genSym function to get a new unique, --- because in GHCi we might have two copies of the Data.Typeable --- library running (one in the compiler and one in the running --- program), and we need to make sure they don't share any keys. --- --- This is really a hack. A better solution would be to centralise the --- whole mutable state used by this module, i.e. both hashtables. But --- the current solution solves the immediate problem, which is that --- dynamics generated in one world with one type were erroneously --- being recognised by the other world as having a different type. foreign import ccall unsafe "genSymZh" genSym :: IO Int #endif