testsuite: Add testcase for #13615

Reviewers: austin

Subscribers: dfeuer, rwbarton, thomie

GHC Trac Issues: #13615

Differential Revision: https://phabricator.haskell.org/D3696

(cherry picked from commit 0836bfbd)

testsuite/tests/concurrent/T13615/Memo.hs

+{-# 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)

testsuite/tests/concurrent/T13615/Parallel.hs

+{-# 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

testsuite/tests/concurrent/T13615/T13615.hs

+{-# 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)

testsuite/tests/concurrent/T13615/all.T

+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'])