diff options
Diffstat (limited to 'testsuite/tests')
-rw-r--r-- | testsuite/tests/concurrent/T13615/Memo.hs | 57 | ||||
-rw-r--r-- | testsuite/tests/concurrent/T13615/Parallel.hs | 61 | ||||
-rw-r--r-- | testsuite/tests/concurrent/T13615/T13615.hs | 63 | ||||
-rw-r--r-- | testsuite/tests/concurrent/T13615/all.T | 11 |
4 files changed, 192 insertions, 0 deletions
diff --git a/testsuite/tests/concurrent/T13615/Memo.hs b/testsuite/tests/concurrent/T13615/Memo.hs new file mode 100644 index 0000000000..825377d1a0 --- /dev/null +++ b/testsuite/tests/concurrent/T13615/Memo.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE RankNTypes #-} + +module Memo where +import Data.Bits + +type Memo a = forall r. (a -> r) -> (a -> r) + + +memo2 :: Memo a -> Memo b -> (a -> b -> r) -> (a -> b -> r) +memo2 a b = a . (b .) + +wrap :: (a -> b) -> (b -> a) -> Memo a -> Memo b +wrap i j m f = m (f . i) . j + + +pair :: Memo a -> Memo b -> Memo (a,b) +pair m m' f = uncurry (m (\x -> m' (\y -> f (x,y)))) + + +bits :: (Num a, Ord a, Bits a) => Memo a +bits f = apply (fmap f identity) + +data IntTrie a = IntTrie (BitTrie a) a (BitTrie a) -- negative, 0, positive +data BitTrie a = BitTrie a (BitTrie a) (BitTrie a) + + +instance Functor BitTrie where + fmap f ~(BitTrie x l r) = BitTrie (f x) (fmap f l) (fmap f r) + + + +instance Functor IntTrie where + fmap f ~(IntTrie neg z pos) = IntTrie (fmap f neg) (f z) (fmap f pos) + +-- | Apply the trie to an argument. This is the semantic map. +apply :: (Ord b, Num b, Bits b) => IntTrie a -> b -> a +apply (IntTrie neg z pos) x = + case compare x 0 of + LT -> applyPositive neg (-x) + EQ -> z + GT -> applyPositive pos x + +applyPositive :: (Num b, Bits b) => BitTrie a -> b -> a +applyPositive (BitTrie one eve od) x + | x == 1 = one + | testBit x 0 = applyPositive od (x `shiftR` 1) + | otherwise = applyPositive eve (x `shiftR` 1) + +identity :: (Num a, Bits a) => IntTrie a +identity = IntTrie (fmap negate identityPositive) 0 identityPositive + + + +identityPositive :: (Num a, Bits a) => BitTrie a +identityPositive = go + where + go = BitTrie 1 (fmap (`shiftL` 1) go) (fmap (\n -> (n `shiftL` 1) .|. 1) go) diff --git a/testsuite/tests/concurrent/T13615/Parallel.hs b/testsuite/tests/concurrent/T13615/Parallel.hs new file mode 100644 index 0000000000..ba711b64d6 --- /dev/null +++ b/testsuite/tests/concurrent/T13615/Parallel.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, DefaultSignatures, TypeOperators, FlexibleContexts #-} + +module Parallel + (NFData, parMap, rdeepseq) where + +import Control.Monad +import GHC.Exts +import Control.DeepSeq + +infixl 0 `using` + + +type Strategy a = a -> Eval a + +newtype Eval a = Eval (State# RealWorld -> (# State# RealWorld, a #)) + + + +instance Functor Eval where + fmap = liftM + +instance Applicative Eval where + pure x = Eval $ \s -> (# s, x #) + (<*>) = ap + +instance Monad Eval where + return = pure + Eval x >>= k = Eval $ \s -> case x s of + (# s', a #) -> case k a of + Eval f -> f s' + +rpar :: Strategy a +rpar x = Eval $ \s -> spark# x s + +rparWith :: Strategy a -> Strategy a +rparWith s a = do l <- rpar r; return (case l of Lift x -> x) + where r = case s a of + Eval f -> case f realWorld# of + (# _, a' #) -> Lift a' + +data Lift a = Lift a + +using :: a -> Strategy a -> a +x `using` strat = runEval (strat x) + + +rdeepseq :: NFData a => Strategy a +rdeepseq x = do rseq (rnf x); return x + +parList :: Strategy a -> Strategy [a] +parList strat = traverse (rparWith strat) + +parMap :: Strategy b -> (a -> b) -> [a] -> [b] +parMap strat f = (`using` parList strat) . map f + + +runEval :: Eval a -> a +runEval (Eval x) = case x realWorld# of (# _, a #) -> a + +rseq :: Strategy a +rseq x = Eval $ \s -> seq# x s diff --git a/testsuite/tests/concurrent/T13615/T13615.hs b/testsuite/tests/concurrent/T13615/T13615.hs new file mode 100644 index 0000000000..9295db3a7c --- /dev/null +++ b/testsuite/tests/concurrent/T13615/T13615.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE RankNTypes #-} + +module Main where + +import Parallel +import qualified Memo +import qualified Data.Map.Lazy as M +import Control.DeepSeq +import Control.Monad.ST +import Data.STRef + +fight :: Int -> Int -> [Int] +fight i a = map fst $ fightVanillaM i a + +fightVanillaM :: Int -> Int -> [(Int, Int)] +fightVanillaM = Memo.memo2 Memo.bits Memo.bits fightVanilla + +fightVanilla :: Int -> Int -> [(Int, Int)] +fightVanilla php ohp + | php <= 0 || ohp <= 0 = [(max 0 php, max 0 ohp)] + | otherwise = regroup $ do + (odmg, pdmg) <- [(9,3),(10,2),(11,2),(12,2),(14,1),(16,1),(18,0),(100,0),(100,0),(100,0)] + fightVanillaM (php - pdmg) (ohp - odmg) + +update :: Int -> Int -> [(Int, Int)] +update i outcome = (,) outcome <$> fight i outcome + +memoState :: Memo.Memo (Int, Int) +memoState = Memo.pair Memo.bits Memo.bits + +fibFight :: Int -> [Int] +fibFight 0 = [] +fibFight 1 = [] +fibFight x = [(x - 1), (x - 2)] + + +----------------------------------------------------------------------------------- +regroup :: (NFData a, Show a, Eq a, Ord a) => [(a, Int)] -> [(a, Int)] +regroup xs = + let xs' = M.toList $ M.fromListWith (+) xs + s' = addTheNumbers (map (\(_,x) -> x) xs) -- sum (map snd xs') + s = sum (map snd xs) + in if s' /= s + then if show s' == show s + then error "WAT????" + else error $ "Those are expected to be equal" ++ show (s', s) + else xs' +---------------------------------------------------------------------------------- + +addTheNumbers :: [Int] -> Int +addTheNumbers xs0 = runST $ do + y <- newSTRef 0 + let go [] = readSTRef y + go (x : xs) = do + modifySTRef y (+x) + go xs + go xs0 + +main :: IO () +main = rnf (go (80, 250)) `seq` return () + where + go = memoState (rnf . parMap rdeepseq (map go) . step) +step (cid, hp) = map (update hp) (fibFight cid) diff --git a/testsuite/tests/concurrent/T13615/all.T b/testsuite/tests/concurrent/T13615/all.T new file mode 100644 index 0000000000..bac4d0167a --- /dev/null +++ b/testsuite/tests/concurrent/T13615/all.T @@ -0,0 +1,11 @@ +test('T13615', + [when(fast(), skip), + only_ways(threaded_ways), + extra_files(['Parallel.hs', 'Memo.hs']), + # Decrease stack chunk size and lots of capabilities to increase failure + # probability due to more frequent duplicate-computation checks. The + # reproduction probability is around 75% on my dual-core hyperthreaded + # laptop. + extra_run_opts('+RTS -N15 -ki4k')], + multimod_compile_and_run, + ['T13615','-rtsopts']) |