From e1399bdcde01f55824973b556f60eecbe4dc2250 Mon Sep 17 00:00:00 2001 From: simonpj Date: Thu, 17 Apr 2003 15:23:37 +0000 Subject: [PATCH] [project @ 2003-04-17 15:23:37 by simonpj] ---------------------------------- Implement Typeable properly ---------------------------------- 1. Add 'deriving' for Typeable class. So you can say data T a b = .... deriving( Typeable ) At the moment you only get this if you ask for it. If you say nothing you get nothing. 2. Implement Typeable better, with proper O(1) comparison of type representations 3. Add the 'cast' operation described in 'Scrap your boilerplate' and use it. 4. Consequence: need to move the definition of IOArray from Data.Array.IO.Internals to GHC.IOBase, where it joins IORef. This is necssary so that HashTable can be low down in the compilation hierarchy, and hence so can Dynamic. WARNING: I'm not certain the imports in HashTable and Dynamic will all be right for Hugs and NHC. I hope you can fix them up. --- Data/Array/IO/Internals.hs | 23 ++---- Data/Dynamic.hs | 183 ++++++++++++++++++++++++++++---------------- Data/HashTable.hs | 45 +++++++---- Data/IORef.hs | 4 +- GHC/IOBase.lhs | 36 +++++++++ 5 files changed, 186 insertions(+), 105 deletions(-) diff --git a/Data/Array/IO/Internals.hs b/Data/Array/IO/Internals.hs index ec930f2..fd98206 100644 --- a/Data/Array/IO/Internals.hs +++ b/Data/Array/IO/Internals.hs @@ -64,30 +64,17 @@ instance (Typeable a, Typeable b) => Typeable (IOArray a b) where -- GHC only to the end of file ----------------------------------------------------------------------------- --- | Mutable, boxed, non-strict arrays in the 'IO' monad. The type --- arguments are as follows: --- --- * @i@: the index type of the array (should be an instance of @Ix@) --- --- * @e@: the element type of the array. --- -newtype IOArray i e = IOArray (STArray RealWorld i e) deriving Eq +-- | Instance declarations for 'IOArray's instance HasBounds IOArray where {-# INLINE bounds #-} bounds (IOArray marr) = bounds marr instance MArray IOArray e IO where - {-# INLINE newArray #-} - newArray lu init = stToIO $ do - marr <- newArray lu init; return (IOArray marr) - {-# INLINE newArray_ #-} - newArray_ lu = stToIO $ do - marr <- newArray_ lu; return (IOArray marr) - {-# INLINE unsafeRead #-} - unsafeRead (IOArray marr) i = stToIO (unsafeRead marr i) - {-# INLINE unsafeWrite #-} - unsafeWrite (IOArray marr) i e = stToIO (unsafeWrite marr i e) + newArray = newIOArray + unsafeRead = unsafeReadIOArray + unsafeWrite = unsafeWriteIOArray + ----------------------------------------------------------------------------- -- Flat unboxed mutable arrays (IO monad) diff --git a/Data/Dynamic.hs b/Data/Dynamic.hs index 1c13873..ea479b6 100644 --- a/Data/Dynamic.hs +++ b/Data/Dynamic.hs @@ -38,6 +38,7 @@ module Data.Dynamic -- instances of 'Typeable'. Typeable( typeOf ), -- :: a -> TypeRep + cast, -- :: (Typeable a, Typeable b) => a -> Maybe b -- ** Building concrete type representations TypeRep, -- abstract, instance of: Eq, Show, Typeable @@ -61,12 +62,12 @@ module Data.Dynamic ) where +import qualified Data.HashTable as HT import Data.Maybe import Data.Either import Data.Int import Data.Word -import Foreign.Ptr -import Foreign.StablePtr +import Data.List( foldl ) #ifdef __GLASGOW_HASKELL__ import GHC.Base @@ -74,8 +75,10 @@ import GHC.Show import GHC.Err import GHC.Num import GHC.Float +import GHC.Real( rem ) import GHC.IOBase -import GHC.List( lookup, foldl ) +import GHC.Ptr -- So we can give Typeable instance for Ptr +import GHC.Stable -- So we can give Typeable instance for StablePtr #endif #ifdef __HUGS__ @@ -213,26 +216,42 @@ instance Eq TyCon where (TyCon t1 _) == (TyCon t2 _) = t1 == t2 #endif -instance Show TypeRep where - showsPrec p (TypeRep _ tycon tys) = - case tys of - [] -> showsPrec p tycon - [x] | tycon == listTc -> showChar '[' . shows x . showChar ']' - [a,r] | tycon == funTc -> showParen (p > 8) $ - showsPrec 9 a . showString " -> " . showsPrec 8 r - xs | isTupleTyCon tycon -> showTuple tycon xs - | otherwise -> - showParen (p > 9) $ - showsPrec p tycon . - showChar ' ' . - showArgs tys +----------------- Type-safe cast ------------------ -instance Show TyCon where - showsPrec _ (TyCon _ s) = showString s +-- | The type-safe cast operation +cast :: (Typeable a, Typeable b) => a -> Maybe b +cast x = r + where + r = if typeOf x == typeOf (fromJust r) then + Just (unsafeCoerce x) + else + Nothing -isTupleTyCon :: TyCon -> Bool -isTupleTyCon (TyCon _ (',':_)) = True -isTupleTyCon _ = False +----------------- Construction -------------------- + +-- | Applies a type constructor to a sequence of types +mkAppTy :: TyCon -> [TypeRep] -> TypeRep +mkAppTy tc@(TyCon tc_k _) args + = TypeRep (appKeys tc_k arg_ks) tc args + where + arg_ks = [k | TypeRep k _ _ <- args] + +funTc :: TyCon +funTc = mkTyCon "->" + +-- | A special case of 'mkAppTy', which applies the function +-- type constructor to a pair of types. +mkFunTy :: TypeRep -> TypeRep -> TypeRep +mkFunTy f a = mkAppTy funTc [f,a] + +-- | Applies a type to a function type. Returns: @'Just' u@ if the +-- first argument represents a function of type @t -> u@ and the +-- second argument represents a function of type @t@. Otherwise, +-- returns 'Nothing'. +applyTy :: TypeRep -> TypeRep -> Maybe TypeRep +applyTy (TypeRep _ tc [t1,t2]) t3 + | tc == funTc && t1 == t3 = Just t2 +applyTy _ _ = Nothing -- If we enforce the restriction that there is only one -- @TyCon@ for a type & it is shared among all its uses, @@ -262,6 +281,30 @@ mkTyCon :: String -- ^ the name of the type constructor (should be unique -> TyCon -- ^ A unique 'TyCon' object mkTyCon str = TyCon (mkTyConKey str) str + +----------------- Showing TypeReps -------------------- + +instance Show TypeRep where + showsPrec p (TypeRep _ tycon tys) = + case tys of + [] -> showsPrec p tycon + [x] | tycon == listTc -> showChar '[' . shows x . showChar ']' + [a,r] | tycon == funTc -> showParen (p > 8) $ + showsPrec 9 a . showString " -> " . showsPrec 8 r + xs | isTupleTyCon tycon -> showTuple tycon xs + | otherwise -> + showParen (p > 9) $ + showsPrec p tycon . + showChar ' ' . + showArgs tys + +instance Show TyCon where + showsPrec _ (TyCon _ s) = showString s + +isTupleTyCon :: TyCon -> Bool +isTupleTyCon (TyCon _ (',':_)) = True +isTupleTyCon _ = False + -- Some (Show.TypeRep) helpers: showArgs :: Show a => [a] -> ShowS @@ -278,32 +321,6 @@ showTuple (TyCon _ str) args = showChar '(' . go str args go _ _ = showChar ')' --- | Applies a type constructor to a sequence of types -mkAppTy :: TyCon -> [TypeRep] -> TypeRep -mkAppTy tc@(TyCon tc_k _) args - = TypeRep (appKeys tc_k arg_ks) tc args - where - arg_ks = [k | TypeRep k _ _ <- args] - -funTc :: TyCon -funTc = mkTyCon "->" - --- | A special case of 'mkAppTy', which applies the function type constructor to --- a pair of types. -mkFunTy :: TypeRep -> TypeRep -> TypeRep -mkFunTy f a = mkAppTy funTc [f,a] - --- Auxillary functions - --- | Applies a type to a function type. Returns: @'Just' u@ if the --- first argument represents a function of type @t -> u@ and the --- second argument represents a function of type @t@. Otherwise, --- returns 'Nothing'. -applyTy :: TypeRep -> TypeRep -> Maybe TypeRep -applyTy (TypeRep _ tc [t1,t2]) t3 - | tc == funTc && t1 == t3 = Just t2 -applyTy _ _ = Nothing - ------------------------------------------------------------- -- @@ -406,7 +423,7 @@ INSTANCE_TYPEABLE0(Word16,word16Tc,"Word16") INSTANCE_TYPEABLE0(Word32,word32Tc,"Word32") INSTANCE_TYPEABLE0(Word64,word64Tc,"Word64") -INSTANCE_TYPEABLE0(TyCon,tyconTc, "TyCon") +INSTANCE_TYPEABLE0(TyCon,tyconTc, "TyCon") INSTANCE_TYPEABLE0(TypeRep,typeRepTc,"TypeRep") INSTANCE_TYPEABLE0(Dynamic,dynamicTc,"Dynamic") @@ -422,28 +439,58 @@ INSTANCE_TYPEABLE1(IORef,ioRefTc,"IORef") newtype Key = Key Int deriving( Eq ) -appKeys :: Key -> [Key] -> Key -appKeys k ks = foldl appKey k ks +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), + tc_tbl :: !(HT.HashTable String Key), + ap_tbl :: !(HT.HashTable KeyPr Key) } + +{-# NOINLINE cache #-} +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 }) + +newKey :: IORef Key -> IO Key +newKey kloc = do { k@(Key i) <- readIORef kloc ; + writeIORef kloc (Key (i+1)) ; + return k } + +mkTyConKey :: String -> Key +mkTyConKey str + = unsafePerformIO $ do + let Cache {next_key = kloc, tc_tbl = tbl} = cache + mb_k <- HT.lookup tbl str + case mb_k of + Just k -> return k + Nothing -> do { k <- newKey kloc ; + HT.insert tbl str k ; + return k } appKey :: Key -> Key -> Key -appKey (Key k1) (Key k2) +appKey k1 k2 = unsafePerformIO $ do - (v, cache) <- readIORef memo - case lookup (k1,k2) cache of - Just k -> return (Key k) - Nothing -> do writeIORef memo (v+1, ((k1,k2),v) : cache) - return (Key v) + let Cache {next_key = kloc, ap_tbl = tbl} = cache + mb_k <- HT.lookup tbl kpr + case mb_k of + Just k -> return k + Nothing -> do { k <- newKey kloc ; + HT.insert tbl kpr k ; + return k } + where + kpr = KeyPr k1 k2 + +appKeys :: Key -> [Key] -> Key +appKeys k ks = foldl appKey k ks + + + -memo :: IORef (Int, [((Int,Int),Int)]) -memo = unsafePerformIO (newIORef (1000, [])) - -- 1000, yuk! -mkTyConKey :: String -> Key -mkTyConKey str = unsafePerformIO $ do - v <- readIORef uni - writeIORef uni (v+1) - return (str `seq` Key v) - -{-# NOINLINE uni #-} -uni :: IORef Int -uni = unsafePerformIO ( newIORef 0 ) diff --git a/Data/HashTable.hs b/Data/HashTable.hs index 917daab..8c88f15 100644 --- a/Data/HashTable.hs +++ b/Data/HashTable.hs @@ -1,3 +1,5 @@ +{-# OPTIONS -fno-implicit-prelude #-} + ----------------------------------------------------------------------------- -- | -- Module : Data.HashTable @@ -23,29 +25,38 @@ module Data.HashTable ( -- * Hash functions -- $hash_functions hashInt, hashString, + prime, -- * Diagnostics longestChain ) where -import Data.Char ( ord ) -import Data.Int ( Int32 ) -import Data.Array.IO -import Data.Array.Base -import Data.List ( maximumBy ) -import Data.IORef +-- This module is imported by Data.Dynamic, which is pretty low down in the +-- module hierarchy, so don't import "high-level" modules + +import GHC.Base +import Data.Tuple ( fst ) import Data.Bits -import Control.Monad ( when ) -import Prelude hiding (lookup) ---import Debug.Trace +import Data.Maybe +import Data.List ( maximumBy, filter, length, concat ) + +import GHC.Num +import GHC.Int ( Int32 ) +import GHC.Real ( Integral(..), fromIntegral ) + +import GHC.IOBase ( IO, IOArray, newIOArray, readIOArray, writeIOArray, unsafeReadIOArray, unsafeWriteIOArray, + IORef, newIORef, readIORef, writeIORef ) +import GHC.Err ( undefined ) +import Control.Monad ( when, mapM, sequence_ ) +----------------------------------------------------------------------- myReadArray :: IOArray Int32 a -> Int32 -> IO a myWriteArray :: IOArray Int32 a -> Int32 -> a -> IO () #ifdef DEBUG -myReadArray = readArray -myWriteArray = writeArray +myReadArray = readIOArray +myWriteArray = writeIOArray #else -myReadArray arr i = unsafeRead arr (fromIntegral i) -myWriteArray arr i x = unsafeWrite arr (fromIntegral i) x +myReadArray arr i = unsafeReadIOArray arr (fromIntegral i) +myWriteArray arr i x = unsafeWriteIOArray arr (fromIntegral i) x #endif -- | A hash table mapping keys of type @key@ to values of type @val@. @@ -128,7 +139,7 @@ hashString :: String -> Int32 hashString = fromIntegral . foldr f 0 where f c m = ord c + (m * 128) `rem` fromIntegral prime --- a prime larger than the maximum hash table size +-- | A prime larger than the maximum hash table size prime = 1500007 :: Int32 -- ----------------------------------------------------------------------------- @@ -154,8 +165,8 @@ new new cmp hash_fn = do -- make a new hash table with a single, empty, segment - dir <- newArray (0,dIR_SIZE) undefined - segment <- newArray (0,sEGMENT_SIZE-1) [] + dir <- newIOArray (0,dIR_SIZE) undefined + segment <- newIOArray (0,sEGMENT_SIZE-1) [] myWriteArray dir 0 segment let @@ -231,7 +242,7 @@ expandHashTable newindex = newbucket .&. sEGMENT_MASK -- when (newindex == 0) $ - do segment <- newArray (0,sEGMENT_SIZE-1) [] + do segment <- newIOArray (0,sEGMENT_SIZE-1) [] myWriteArray dir newsegment segment -- let table' = diff --git a/Data/IORef.hs b/Data/IORef.hs index 9170faf..47499e2 100644 --- a/Data/IORef.hs +++ b/Data/IORef.hs @@ -27,7 +27,7 @@ module Data.IORef #endif ) where -import Prelude +import Prelude -- Explicit dependency helps 'make depend' do the right thing #ifdef __HUGS__ import Hugs.IORef @@ -53,7 +53,7 @@ import NHC.IOExtras #endif #ifndef __NHC__ -import Data.Dynamic +-- import Data.Dynamic #endif #if defined(__GLASGOW_HASKELL__) && !defined(__PARALLEL_HASKELL__) diff --git a/GHC/IOBase.lhs b/GHC/IOBase.lhs index be7c9c2..cf3c5eb 100644 --- a/GHC/IOBase.lhs +++ b/GHC/IOBase.lhs @@ -406,6 +406,42 @@ writeIORef :: IORef a -> a -> IO () writeIORef (IORef var) v = stToIO (writeSTRef var v) -- --------------------------------------------------------------------------- +-- | An 'IOArray' is a mutable, boxed, non-strict array in the 'IO' monad. +-- The type arguments are as follows: +-- +-- * @i@: the index type of the array (should be an instance of @Ix@) +-- +-- * @e@: the element type of the array. +-- +-- + +newtype IOArray i e = IOArray (STArray RealWorld i e) deriving Eq + +-- |Build a new 'IOArray' +newIOArray :: Ix i => (i,i) -> e -> IO (IOArray i e) +{-# INLINE newIOArray #-} +newIOArray lu init = stToIO $ do {marr <- newSTArray lu init; return (IOArray marr)} + +-- | Read a value from an 'IOArray' +unsafeReadIOArray :: Ix i => IOArray i e -> Int -> IO e +{-# INLINE unsafeReadIOArray #-} +unsafeReadIOArray (IOArray marr) i = stToIO (unsafeReadSTArray marr i) + +-- | Write a new value into an 'IOArray' +unsafeWriteIOArray :: Ix i => IOArray i e -> Int -> e -> IO () +{-# INLINE unsafeWriteIOArray #-} +unsafeWriteIOArray (IOArray marr) i e = stToIO (unsafeWriteSTArray marr i e) + +-- | Read a value from an 'IOArray' +readIOArray :: Ix i => IOArray i e -> i -> IO e +readIOArray (IOArray marr) i = stToIO (readSTArray marr i) + +-- | Write a new value into an 'IOArray' +writeIOArray :: Ix i => IOArray i e -> i -> e -> IO () +writeIOArray (IOArray marr) i e = stToIO (writeSTArray marr i e) + + +-- --------------------------------------------------------------------------- -- Show instance for Handles -- handle types are 'show'n when printing error msgs, so -- 1.7.10.4