-- 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
) 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
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__
(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,
-> 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
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
-
-------------------------------------------------------------
--
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")
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 )
+{-# OPTIONS -fno-implicit-prelude #-}
+
-----------------------------------------------------------------------------
-- |
-- 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@.
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
-- -----------------------------------------------------------------------------
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
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' =
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
projects / ghc-base.git / commitdiff