{-# LANGUAGE FlexibleInstances , BangPatterns , MagicHash , ScopedTypeVariables , TypeFamilies , UndecidableInstances , OverlappingInstances , MultiParamTypeClasses #-} {-# OPTIONS_HADDOCK hide #-} {- - Intel Concurrent Collections for Haskell - Copyright (c) 2010, Intel Corporation. - - This program is free software; you can redistribute it and/or modify it - under the terms and conditions of the GNU Lesser General Public License, - version 2.1, as published by the Free Software Foundation. - - This program is distributed in the hope it will be useful, but WITHOUT - ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or - FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for - more details. - - You should have received a copy of the GNU Lesser General Public License along with - this program; if not, write to the Free Software Foundation, Inc., - 51 Franklin St - Fifth Floor, Boston, MA 02110-1301 USA. - -} -- |An internal utility module that supports the CnC implementations. #ifndef INCLUDEMETHOD module Intel.CncUtil ( foldRange, for_, splitN, forkJoin, doTrials, FitInWord (..), GMapKey (..), Hashable (..), (!), testCase, tests, MutableMap, newMutableMap, assureMvar, mmToList, HotVar, newHotVar, modifyHotVar, modifyHotVar_, ) where #endif import GHC.Conc import Control.Concurrent import Data.Time.Clock -- Not in 6.10 import qualified Data.Map as DM import qualified Data.IntMap as DI import qualified Data.List as L import Prelude hiding (lookup) import Data.Char (ord,chr) import Data.Word import Data.Int import Data.Bits import Data.IORef import qualified Data.HashTable as HT import Debug.Trace import Test.HUnit import Test.QuickCheck (quickCheck, (==>)) -------------------------------------------------------------------------------- -- Miscellaneous Utilities -------------------------------------------------------------------------------- -- |A simple loop construct to use if you don't trust rewrite based deforestation. -- Usage foldRange start end acc, where start is inclusive, end uninclusive. foldRange start end acc fn = loop start acc where loop !i !acc | i == end = acc | otherwise = loop (i+1) (fn acc i) -- |My own forM, again, less trusting of optimizations. -- Inclusive start, exclusive end. for_ start end fn | start > end = error "for_: start is greater than end" for_ start end fn = loop start where loop !i | i == end = return () | otherwise = do fn i; loop (i+1) -- |Split a list into N pieces (not evenly sized if N does not divide -- the length of the list). splitN :: Int -> [a] -> [[a]] splitN n ls | n <= 0 = error "Cannot split list by a factor of 0" splitN n ls = loop n ls where sz = length ls `quot` n loop 1 ls = [ls] loop n ls = hd : loop (n-1) tl where (hd,tl) = splitAt sz ls -- |Run IO threads in parallel and wait till they're done. forkJoin actions = -- I'm amazed this is not built-in. do joiner <- newChan mapM (\a -> forkIO (do a; writeChan joiner ())) actions mapM_ (\_ -> readChan joiner) actions return () t = forkJoin [putStrLn "foo", putStrLn "bar", putStrLn "baz"] -- |Run a test and time it. doTrials trials mnd = sequence_ $ take trials $ repeat $ do putStrLn "------------------------------------------------------------" strt <- getCurrentTime --start <- getCPUTime mnd --end <- getCPUTime end <- getCurrentTime let diff = (diffUTCTime end strt) --let diff = fromIntegral (end-start) / (10.0 ^ 12) putStrLn$ show diff ++ " real time consumed" -------------------------------------------------------------------------------- -- Mutable Maps. -------------------------------------------------------------------------------- -- Abstract over the shared mutable data structure used -- for item collections (in the IO-based Cnc.hs) #ifdef HASHTABLE_TEST type MutableMap a b = HashTable a (MVar b) newMutableMap :: (Eq tag, Hashable tag) => IO (MutableMap tag b) newMutableMap = HT.new (==) hash assureMvar col tag = do mayb <- HT.lookup col tag case mayb of Nothing -> do mvar <- newEmptyMVar HT.insert col tag mvar return mvar Just mvar -> return mvar mmToList = HT.toList #warning "Enabling HashTable item collections. These are not truly thread safe (yet)." #elif USE_GMAP #warning "Using experimental indexed type family GMap implementation..." -- Trying to use GMaps: type MutableMap a b = IORef (GMap a (MVar b)) newMutableMap :: (GMapKey tag) => IO (MutableMap tag b) newMutableMap = newIORef empty assureMvar col tag = do map <- readIORef col case lookup tag map of Nothing -> do mvar <- newEmptyMVar atomicModifyIORef col (\mp -> let altered = alter (\mv -> case mv of Nothing -> Just mvar Just mv -> Just mv) tag mp -- Might be able to optimize this somehow... in (altered, (!) altered tag)) Just mvar -> return mvar mmToList col = do map <- readIORef col return (toList map) #else -- A Data.Map based version: -- Can probably get rid of this once we build a little confidence with GMap: type MutableMap a b = IORef (DM.Map a (MVar b)) newMutableMap :: (Ord tag) => IO (MutableMap tag b) newMutableMap = newIORef DM.empty assureMvar col tag = do map <- readIORef col case DM.lookup tag map of Nothing -> do mvar <- newEmptyMVar atomicModifyIORef col (\mp -> let altered = DM.alter (\mv -> case mv of Nothing -> Just mvar Just mv -> Just mv) tag mp -- Might be able to optimize this somehow... in (altered, (DM.!) altered tag)) Just mvar -> return mvar mmToList col = do map <- readIORef col return (DM.toList map) #endif ------------------------------------------------------------ -- Hot Atomic Words operations ------------------------------------------------------------ -- In this library we abuse individual words of memory with many -- concurrent, atomic operations. In Haskell, there are three choices -- for these: IORef, MVars, and STVars. -- We want to experiment with all three of these. #define HOTVAR 1 newHotVar :: a -> IO (HotVar a) modifyHotVar :: HotVar a -> (a -> (a,b)) -> IO b modifyHotVar_ :: HotVar a -> (a -> a) -> IO () #if HOTVAR == 1 type HotVar a = IORef a newHotVar = newIORef modifyHotVar = atomicModifyIORef modifyHotVar_ v fn = atomicModifyIORef v (\a -> (fn a, ())) #elif HOTVAR == 2 #warning "Using MVars for hot atomic variables." type HotVar a = MVar a newHotVar = newMVar modifyHotVar v fn = modifyMVar v (return . fn) modifyHotVar_ v fn = modifyMVar_ v (return . fn) #elif HOTVAR == 3 #warning "Using TVars for hot atomic variables." -- Simon Marlow said he saw better scaling with TVars (surprise to me): type HotVar a = TVar a newHotVar = newTVarIO modifyHotVar tv fn = atomically (do x <- readTVar tv let (x2,b) = fn x writeTVar tv x2 return b) modifyHotVar_ tv fn = atomically (do x <- readTVar tv; writeTVar tv (fn x)) #endif -------------------------------------------------------------------------------- -- Class of types which are hashable. -------------------------------------------------------------------------------- -- TODO: Might as well replace this by the Data.Hash module on cabal. class Hashable a where hash :: a -> Int32 instance Hashable Bool where hash True = 1 hash False = 0 instance Hashable Int where hash = HT.hashInt instance Hashable Char where hash = HT.hashInt . fromEnum instance Hashable Word16 where hash = HT.hashInt . fromIntegral --instance Hashable String where -- Needs -XTypeSynonymInstances instance Hashable [Char] where hash = HT.hashString instance (Hashable a, Hashable b) => Hashable (a,b) where hash (a,b) = hash a + hash b instance Hashable a => Hashable [a] where hash [] = 0 hash (h:t) = hash h + hash t -- Needs -fallow-undecidable-instances: -- instance Integral t => Hashable t where -- hash n = hashInt (fromInteger (toInteger n)) -- instance Enum a => Hashable a where -- hash = hashInt . fromEnum -------------------------------------------------------------------------------- -- Class of types that fit in a machine word. -------------------------------------------------------------------------------- -- |All datatypes that can be packed into a single word, including -- scalars and some tuple types. class FitInWord v where toWord :: v -> Word fromWord :: Word -> v intToWord :: Int -> Word intToWord = fromIntegral wordToInt :: Word -> Int wordToInt = fromIntegral instance FitInWord Char where toWord = intToWord . ord fromWord = chr . wordToInt instance FitInWord Int where toWord = fromIntegral fromWord = fromIntegral instance FitInWord Int16 where toWord = fromIntegral fromWord = fromIntegral instance FitInWord Int8 where toWord = fromIntegral fromWord = fromIntegral instance FitInWord Word8 where toWord = fromIntegral fromWord = fromIntegral instance FitInWord Word16 where toWord = fromIntegral fromWord = fromIntegral #ifdef x86_64_HOST_ARCH instance FitInWord Int64 where toWord = fromIntegral fromWord = fromIntegral instance FitInWord Word64 where toWord = fromIntegral fromWord = fromIntegral #endif -- Pairs can fit in words too! -- TODO: Use some code generation method to generate instances for all -- combinations of small words/ints that fit in a machine word (a lot). instance FitInWord (Word16,Word16) where toWord (a,b) = shiftL (fromIntegral a) 16 + (fromIntegral b) fromWord n = (fromIntegral$ shiftR n 16, fromIntegral$ n .&. 0xFFFF) -------------------------------------------------------------------------------- -- ADT definition for generic Maps: -------------------------------------------------------------------------------- -- |Class for generic map key types. By using indexed type families, -- |each key type may correspond to a different data structure that -- |implements it. class (Ord k, Eq k, Show k) => GMapKey k where data GMap k :: * -> * empty :: GMap k v lookup :: k -> GMap k v -> Maybe v insert :: k -> v -> GMap k v -> GMap k v alter :: (Maybe a -> Maybe a) -> k -> GMap k a -> GMap k a toList :: GMap k a -> [(k,a)] -------------------------------------------------------------------------------- #if 0 instance FitInWord t => GMapKey t where -- data GMap t v = GMapWord (GMap t v) deriving Show -- empty = GMapWord empty -- lookup k (GMapWord m) = lookup (ord k) m -- insert k v (GMapWord m) = GMapWord (insert (ord k) v m) -- alter fn k (GMapWord m) = GMapWord (alter fn (ord k) m) -- toList (GMapWord m) = map (\ (i,v) -> (chr i,v)) (toList m) data GMap t v = GMapInt (DI.IntMap v) deriving Show --empty = trace "\n <<<<< Empty FitInWord Gmap... >>>>\n"$ GMapInt DI.empty empty = GMapInt DI.empty lookup k (GMapInt m) = DI.lookup (wordToInt$ toWord k) m insert k v (GMapInt m) = GMapInt (DI.insert (wordToInt$ toWord k) v m) alter fn k (GMapInt m) = GMapInt (DI.alter fn (wordToInt$ toWord k) m) toList (GMapInt m) = map (\ (i,v) -> (fromWord$ intToWord i, v)) $ DI.toList m #else -- CODE DUPLICATION instance GMapKey Char where data GMap Char v = GMapChar (GMap Int v) deriving Show empty = GMapChar empty lookup k (GMapChar m) = lookup (ord k) m insert k v (GMapChar m) = GMapChar (insert (ord k) v m) alter fn k (GMapChar m) = GMapChar (alter fn (ord k) m) toList (GMapChar m) = map (\ (i,v) -> (chr i,v)) (toList m) instance GMapKey Word8 where data GMap Word8 v = GMapWord8 (GMap Int v) deriving Show empty = GMapWord8 empty lookup k (GMapWord8 m) = lookup (fromIntegral k) m insert k v (GMapWord8 m) = GMapWord8 (insert (fromIntegral k) v m) alter fn k (GMapWord8 m) = GMapWord8 (alter fn (fromIntegral k) m) toList (GMapWord8 m) = map (\ (i,v) -> (fromIntegral i,v)) (toList m) instance GMapKey Word16 where data GMap Word16 v = GMapWord16 (GMap Int v) deriving Show empty = GMapWord16 empty lookup k (GMapWord16 m) = lookup (fromIntegral k) m insert k v (GMapWord16 m) = GMapWord16 (insert (fromIntegral k) v m) alter fn k (GMapWord16 m) = GMapWord16 (alter fn (fromIntegral k) m) toList (GMapWord16 m) = map (\ (i,v) -> (fromIntegral i,v)) (toList m) instance GMapKey Word where data GMap Word v = GMapWord (GMap Int v) deriving Show empty = GMapWord empty lookup k (GMapWord m) = lookup (fromIntegral k) m insert k v (GMapWord m) = GMapWord (insert (fromIntegral k) v m) alter fn k (GMapWord m) = GMapWord (alter fn (fromIntegral k) m) toList (GMapWord m) = map (\ (i,v) -> (fromIntegral i,v)) (toList m) instance GMapKey Int where data GMap Int v = GMapInt (DI.IntMap v) deriving Show empty = GMapInt DI.empty lookup k (GMapInt m) = DI.lookup k m insert k v (GMapInt m) = GMapInt (DI.insert k v m) alter fn k (GMapInt m) = GMapInt (DI.alter fn k m) toList (GMapInt m) = DI.toList m instance GMapKey Int8 where data GMap Int8 v = GMapInt8 (GMap Int v) deriving Show empty = GMapInt8 empty lookup k (GMapInt8 m) = lookup (fromIntegral k) m insert k v (GMapInt8 m) = GMapInt8 (insert (fromIntegral k) v m) alter fn k (GMapInt8 m) = GMapInt8 (alter fn (fromIntegral k) m) toList (GMapInt8 m) = map (\ (i,v) -> (fromIntegral i,v)) (toList m) instance GMapKey Int16 where data GMap Int16 v = GMapInt16 (GMap Int v) deriving Show empty = GMapInt16 empty lookup k (GMapInt16 m) = lookup (fromIntegral k) m insert k v (GMapInt16 m) = GMapInt16 (insert (fromIntegral k) v m) alter fn k (GMapInt16 m) = GMapInt16 (alter fn (fromIntegral k) m) toList (GMapInt16 m) = map (\ (i,v) -> (fromIntegral i,v)) (toList m) -- TODO IFDEF 64 BIT THEN WE CAN FIT AN INT64 AND WORD64 TOO!! #endif -------------------------------------------------------------------------------- instance GMapKey () where data GMap () v = GMapUnit (Maybe v) empty = GMapUnit Nothing lookup () (GMapUnit v) = v insert () v (GMapUnit _) = GMapUnit $ Just v alter fn () (GMapUnit v) = GMapUnit $ fn v toList (GMapUnit Nothing) = [] toList (GMapUnit (Just v)) = [((),v)] instance GMapKey Bool where data GMap Bool v = GMapBool (Maybe v) (Maybe v) empty = GMapBool Nothing Nothing lookup True (GMapBool v _) = v lookup False (GMapBool _ v) = v insert True v (GMapBool a b) = GMapBool (Just v) b insert False v (GMapBool a b) = GMapBool a (Just v) alter fn True (GMapBool a b) = GMapBool (fn a) b alter fn False (GMapBool a b) = GMapBool a (fn b) toList (GMapBool Nothing Nothing) = [] toList (GMapBool (Just a) Nothing) = [(True,a)] toList (GMapBool Nothing (Just b)) = [(False,b)] toList (GMapBool (Just a) (Just b)) = [(True,a),(False,b)] -- |GMaps over pairs are implemented by nested GMaps. instance (GMapKey a, GMapKey b) => GMapKey (a, b) where data GMap (a, b) v = GMapPair (GMap a (GMap b v)) empty = GMapPair empty lookup (a, b) (GMapPair gm) = lookup a gm >>= lookup b insert (a, b) v (GMapPair gm) = GMapPair $ case lookup a gm of Nothing -> insert a (insert b v empty) gm Just gm2 -> insert a (insert b v gm2 ) gm alter fn (a, b) (GMapPair gm) = GMapPair $ alter newfun a gm where newfun entry = case entry of Nothing -> case fn Nothing of Nothing -> Nothing Just v -> Just $ insert b v empty Just m -> Just$ alter fn b m toList (GMapPair gm) = L.foldl' (\ acc (a,m) -> map (\ (b,v) -> ((a,b),v)) (toList m) ++ acc) [] $ toList gm {- -- Here's a traditional Data.Map implementation: instance (Ord a, Ord b) => GMapKey (a, b) where newtype GMap (a, b) v = GMapPair (DM.Map (a,b) v) empty = GMapPair DM.empty lookup pr (GMapPair gm) = DM.lookup pr gm insert pr v (GMapPair gm) = GMapPair $ DM.insert pr v gm -} -- -- Here's a traditional Data.Map implementation: -- instance (Ord a, Ord b) => GMapKey (a, b) where -- empty = DM.empty -- lookup = DM.lookup -- insert = DM.insert -- |Sum types are represented by separate GMaps for the separate variants. instance (GMapKey a, GMapKey b) => GMapKey (Either a b) where data GMap (Either a b) v = GMapEither (GMap a v) (GMap b v) empty = GMapEither empty empty lookup (Left a) (GMapEither gm1 _gm2) = lookup a gm1 lookup (Right b) (GMapEither _gm1 gm2 ) = lookup b gm2 insert (Left a) v (GMapEither gm1 gm2) = GMapEither (insert a v gm1) gm2 insert (Right b) v (GMapEither gm1 gm2) = GMapEither gm1 (insert b v gm2) alter fn (Left a) (GMapEither gm1 gm2) = GMapEither (alter fn a gm1) gm2 alter fn (Right b) (GMapEither gm1 gm2) = GMapEither gm1 (alter fn b gm2) toList (GMapEither gm1 gm2) = map (\ (a,v) -> (Left a, v)) (toList gm1) ++ map (\ (b,v) -> (Right b, v)) (toList gm2) -- |GMaps with list indices could be treated like tuples (nested -- |maps). Instead, we put them in a regular Data.Map. instance (GMapKey a) => GMapKey [a] where data GMap [a] v = GMapList (DM.Map [a] v) deriving Show empty = GMapList DM.empty lookup k (GMapList m) = DM.lookup k m insert k v (GMapList m) = GMapList (DM.insert k v m) alter fn k (GMapList m) = GMapList (DM.alter fn k m) toList (GMapList m) = DM.toList m (!) :: (GMapKey k) => GMap k v -> k -> v (!) m k = case lookup k m of Nothing -> error "GMap (!) operator failed, element was not present." Just x -> x myGMap :: GMap (Int, Either Char ()) String myGMap = insert (5, Left 'c') "(5, Left 'c')" $ insert (4, Right ()) "(4, Right ())" $ insert (5, Right ()) "This is the one!" $ insert (5, Right ()) "This is the two!" $ insert (6, Right ()) "(6, Right ())" $ insert (5, Left 'a') "(5, Left 'a')" $ empty intMap :: GMap Int String intMap = insert 3 "Entry 3" $ insert 4 "(4, Right ())" $ empty -------------------------------------------------------------------------------- -- Experimental: trying to parameterize by both key and value type and -- thereby use things like Judy arrays. -- We also switch to a mutable data structure here: -------------------------------------------------------------------------------- -- A key/value pair that works inside a GMap2. class GMapKeyVal k v where data GMap2 k v :: * empty2 :: IO (GMap2 k v) lookup2 :: k -> GMap2 k v -> IO (Maybe v) insert2 :: k -> v -> GMap2 k v -> IO () -- instance GMapKeyVal Int Int where -- data GMap2 Int Int = GMapInt2 (DI.IntMap Int) deriving Show -- empty2 = GMapInt2 DI.empty -- lookup2 k (GMapInt2 m) = DI.lookup k m -- insert2 k v (GMapInt2 m) = GMapInt2 (DI.insert k v m) -- instance (FitInWord k, FitInWord v) => GMapKeyVal k v where -- data GMap2 k v = GMapInt2 (DI.IntMap v) deriving Show -- empty2 = GMapInt2 DI.empty -- lookup2 k (GMapInt2 m) = DI.lookup (wordToInt $ toWord k) m -- insert2 k v (GMapInt2 m) = GMapInt2 (DI.insert (wordToInt $ toWord k) v m) -- [2010.05.19] TEMPTOGGLE uncommenting to compile on laptop: {- instance FitInWord t => J.JE t where toWord = undefined fromWord = undefined -- If we know a little more, use the Judy version: instance (FitInWord k, J.JE v) => GMapKeyVal k v where data GMap2 k v = GMapInt2 (J.JudyL v) empty2 = do x <- J.new return $ GMapInt2 x lookup2 = undefined insert2 = undefined -- empty2 = do x <- J.new -- return $ GMapInt2 x -- lookup2 k (GMapInt2 r) = do m <- readIORef r -- return$ DI.lookup (wordToInt $ toWord k) m -- insert2 k v (GMapInt2 r) = modifyIORef r (DI.insert (wordToInt $ toWord k) v) -} -- Otherwise this is the Data.IntMap version -- instance (FitInWord k) => GMapKeyVal k v where -- data GMap2 k v = GMapInt2 (IORef (DI.IntMap v)) -- empty2 = do x <- newIORef DI.empty -- return $ GMapInt2 x -- lookup2 k (GMapInt2 r) = do m <- readIORef r -- return$ DI.lookup (wordToInt $ toWord k) m -- insert2 k v (GMapInt2 r) = modifyIORef r (DI.insert (wordToInt $ toWord k) v) test1gmap = putStrLn $ maybe "Couldn't find key!" id $ lookup (5, Right ()) myGMap test2gmap = putStrLn $ maybe "Couldn't find key!" id $ lookup 3 intMap -- There's a problem with quickcheck where it doesn't -- newline-terminate the "Cases: N" report message. testCase str io = TestLabel str $ TestCase$ do putStrLn$ "\n *** Running unit test: "++str; io; putStrLn "" test1 = testCase "Spot check list lengths"$ assertEqual "splitN" [[1,2], [3,4,5]] (splitN 2 [1..5]) test2 = testCase "Quickcheck splitN - varying split size"$ quickCheck$ (\ (n::Int) -> n>0 ==> (\ (l::[Int]) -> concat (splitN n l) == l)) tests = TestList [test1, test2]