tests/ghc-tests/tests/T2317/T2317.stdout

+100000
+100000

tests/ghc-tests/tests/T2317/all.T

+test('T2317',
+     [when(fast(), skip),
+      reqlib('parallel'), reqlib('random')],
+     multimod_compile_and_run,
+     ['T2317',''])

tests/ghc-tests/tests/T3087.hs

+{-# LANGUAGE RankNTypes, DeriveDataTypeable #-}
+
+module T3087 where
+
+import Data.Generics hiding (ext2Q)
+import System.IO
+
+data MyMaybe a = MyNothing | MyJust a deriving (Data, Typeable)
+
+test1 :: ()
+test1 = undefined `ext1Q` (\ (Just _) -> ()) $ Just ()
+
+test1' :: ()
+test1' = undefined `ext1Q` (\ (MyJust _) -> ()) $ MyJust ()
+
+newtype Q r a = Q { unQ :: a -> r }
+
+ext2Q :: (Data d, Typeable t)
+      => (d -> q) -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q)
+      -> d -> q
+ext2Q def ext arg =
+  case dataCast2 (Q ext) of
+    Just (Q ext') -> ext' arg
+    Nothing       -> def arg
+
+data MyPair a b = MyPair a b deriving (Data, Typeable)
+
+test2 :: ()
+test2 = undefined `ext2Q` (\(_,_) -> ()) $ ((),())
+
+test2' :: ()
+test2' = undefined `ext2Q` (\(MyPair _ _) -> ()) $ MyPair () ()
+
+main stdout _ = do { print test1; print test1'; print test2; print test2' }
+  where
+    print = hPrint stdout

tests/ghc-tests/tests/T367.hs

+{-# LANGUAGE MagicHash #-}
+{-# OPTIONS_GHC  -O2 #-}
+module T367 where
+import Control.Concurrent
+import qualified Data.Vector as U
+import System.IO
+
+main stdout _ = do
+    -- Non allocating loop, needs -fno-omit-yields in order for the kill to
+    -- work
+    t <- forkIO (U.sum (U.enumFromTo 1 (1000000000 :: Int)) `seq` return ())
+    threadDelay 10
+    killThread t
+    hPutStrLn stdout "Done"

tests/ghc-tests/tests/T367A.hs

+{-# OPTIONS_GHC -O2 -fno-omit-yields #-}
+-- Without -fno-omit-yields this test doesn't terminate
+module T367A where
+
+import Data.IORef
+import Control.Concurrent
+import System.IO
+
+main :: Handle -> Handle -> IO ()
+main stdout _ = do
+    r <- newIORef False
+    done_var <- newEmptyMVar
+    hPutStrLn stdout "About to fork"
+
+    forkIO $ f stdout done_var r
+    threadDelay 1000000 -- 1 second
+
+    hPutStrLn stdout "Why is this never printed?!"
+    writeIORef r True
+    readMVar done_var
+    -- and why do we never exit?
+
+f :: Handle -> MVar () -> IORef Bool -> IO ()
+f stdout done_var r = readIORef r >>= \b-> if b then hPutStrLn stdout "Done" >> putMVar done_var ()  else f stdout done_var r

tests/ghc-tests/tests/T7953.hs

+module T7953 (main) where
+
+import Control.Monad
+import System.IO
+import System.Random
+
+main :: Handle -> Handle -> IO ()
+main stdout _ = do
+    hSetBuffering stdout NoBuffering
+    let q = fold $ zip [1..] (take 200 [500.0,400.0..])
+    hPrint stdout q
+    hPutStrLn stdout "Before atMost"
+    let (xs,q') = atMost 0.5 q -- this causes seqfault with -O2
+    hPrint stdout xs
+    hPrint stdout q'
+    hPutStrLn stdout "After atMost"
+
+fold :: [(Key, Prio)] -> PSQ
+fold []         = Void
+fold ((u,r):xs) = insert u r $ fold xs
+
+data Elem = E
+    { _key   :: Key
+    , prio   :: Prio
+    } deriving (Eq, Show)
+
+type Prio = Double
+type Key = Int
+
+data PSQ = Void
+           | Winner Elem Tree
+           deriving (Eq, Show)
+
+singleton :: Key -> Prio -> PSQ
+singleton k p = Winner (E k p) Start
+
+insert :: Key -> Prio -> PSQ -> PSQ
+insert k p q = case q of
+    Void -> singleton k p
+    Winner e t -> Winner (E k p) (Fork e Start t)
+
+atMost :: Prio -> PSQ -> ([Elem], PSQ)
+atMost pt q = case q of
+    (Winner e _)
+        | prio e > pt -> ([], q)
+    Void              -> ([], Void)
+    Winner e Start    -> ([e], Void)
+    Winner e (Fork e' tl tr) ->
+        let (sequ, q')   = atMost pt (Winner e' tl)
+            (sequ', q'') = atMost pt (Winner e tr)
+        in (sequ ++ sequ', q' `play` q'')
+
+data Tree = Start
+          | Fork Elem Tree Tree
+    deriving (Eq, Show)
+
+lloser :: Key -> Prio -> Tree -> Tree -> Tree
+lloser k p tl tr = Fork (E k p) tl tr
+
+play :: PSQ -> PSQ -> PSQ
+Void `play` t' = t'
+t `play` Void  = t
+Winner e@(E k p) t `play` Winner e'@(E k' p') t'
+    | p <= p'   = Winner e  (lloser k' p' t t')
+    | otherwise = Winner e' (lloser k  p  t t')
+

tests/ghc-tests/tests/T8138.hs

+{-# LANGUAGE ScopedTypeVariables #-}
+
+module T8138 where
+
+import Control.Monad.ST
+import Data.Primitive
+import System.IO
+
+main :: Handle -> Handle -> IO ()
+main stdout _ = do
+    let xs :: [Float] = runST $ do
+          barr <- mutableByteArrayFromList [1..fromIntegral n::Float]
+          peekByteArray n barr
+    hPrint stdout xs
+  where
+    n = 13
+
+mutableByteArrayFromList :: forall s a . (Prim a)
+                         => [a]
+                         -> ST s (MutableByteArray s)
+mutableByteArrayFromList xs = do
+    arr <- newByteArray (length xs*sizeOf (undefined :: a))
+    loop arr 0 xs
+    return arr
+  where
+    loop :: MutableByteArray s -> Int -> [a] -> ST s ()
+    loop _ _ [] = return ()
+
+    loop arr i (x : xs) = do
+        writeByteArray arr i x
+        loop arr (i+1) xs
+
+peekByteArray :: (Prim a)
+              => Int
+              -> MutableByteArray s
+              -> ST s [a]
+peekByteArray n arr =
+    loop 0 arr
+  where
+    loop :: (Prim a)
+         => Int
+         -> MutableByteArray s
+         -> ST s [a]
+    loop i _ | i >= n = return []
+
+    loop i arr = do
+        x  <- readByteArray arr i
+        xs <- loop (i+1) arr
+        return (x : xs)

tests/ghc-tests/tests/TC191.hs

+{-# LANGUAGE RankNTypes #-}
+
+-- This only typechecks if forall-hoisting works ok when
+-- importing from an interface file.  The type of Twins.gzipWithQ
+-- is this:
+--   type GenericQ r = forall a. Data a => a -> r
+--   gzipWithQ :: GenericQ (GenericQ r) -> GenericQ (GenericQ [r])
+-- It's kept this way in the interface file for brevity and documentation,
+-- but when the type synonym is expanded, the foralls need expanding
+
+module TC191 where
+
+import Data.Generics.Basics
+import Data.Generics.Aliases
+import Data.Generics.Twins(gzipWithQ)
+
+-- | Generic equality: an alternative to \deriving Eq\
+geq :: Data a => a -> a -> Bool
+geq x y = geq' x y
+  where
+--    This type signature no longer works, because it is
+--    insufficiently polymorphic.
+--    geq' :: forall a b. (Data a, Data b) => a -> b -> Bool
+    geq' :: GenericQ (GenericQ Bool)
+    geq' x y =     (toConstr x == toConstr y)
+                && and (gzipWithQ geq' x y)
+
+
+

tests/ghc-tests/tests/TC220.hs

+{-# LANGUAGE DeriveDataTypeable #-}
+
+-- See #1033
+
+module TC220 where
+
+import Data.Generics
+import Control.Monad.State
+
+data HsExp = HsWildCard deriving( Typeable, Data )
+data HsName = HsName deriving( Typeable, Data )
+
+-- rename :: () -> HsExp -> State (HsName, [HsName]) HsExp
+-- Type sig commented out
+rename1 = \_ -> everywhereM (mkM (\e -> case e of HsWildCard -> return e))
+
+rename2 _ = everywhereM (mkM (\e -> case e of  HsWildCard -> return e))
+
+uncomb1 :: State (HsName, [HsName]) HsExp
+uncomb1 = rename1 () undefined
+
+uncomb2 :: State (HsName, [HsName]) HsExp
+uncomb2 = rename2 () undefined
+
+
+

tests/ghc-tests/tests/Tasty/Bronze.hs

+{-# LANGUAGE ScopedTypeVariables, BangPatterns #-}
+module Tasty.Bronze where
+
+import System.Exit
+import Test.Tasty
+import Test.Tasty.Silver
+import qualified System.Process as PT
+import Control.Exception
+import System.IO
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.Encoding as T
+import System.Posix.Process.Internals
+import System.IO.Temp
+
+
+-- | Compares a given file with the output (exit code, stdout, stderr) of a program. Assumes
+-- that the program output is utf8 encoded.
+goldenVsOut
+  :: TestName   -- ^ test name
+  -> FilePath   -- ^ path to the golden file
+  -> (Handle -> Handle -> IO ())
+  -> TestTree
+goldenVsOut name ref cmd =
+  goldenVsAction name ref runProg printProcResult
+  where runProg = wrapAction cmd
+
+wrapAction :: (Handle -> Handle -> IO ()) -> IO (ExitCode, T.Text, T.Text)
+wrapAction io =
+  withSystemTempFile "stdout" $ \stdout_fp stdout_h -> do
+    withSystemTempFile "stderr" $ \stderr_fp stderr_h -> do
+      e_code <- catchExit (io stdout_h stderr_h)
+      hClose stdout_h
+      hClose stderr_h
+      !std_o <- readFile stdout_fp
+      !std_e <- readFile stderr_fp
+      return (e_code, T.pack std_o, T.pack std_e)
+
+catchExit :: IO () -> IO ExitCode
+catchExit io = catch (ExitSuccess <$ io) (\(e :: ExitCode) -> return e)

tests/ghc-tests/tests/Throwto001.hs

+module Throwto001 where
+import Control.Concurrent
+import Control.Exception
+import Data.Array
+import System.Random
+import System.Environment
+import Control.Monad
+import GHC.Conc
+
+-- A fiendish throwTo test.  A bunch of threads take random MVars from
+-- a shared array; if the MVar has Nothing in it, replace it with Just
+-- of the current thread's ThreadId.  If the MVar has another ThreadId
+-- in it, then killThread that thread, and replace it with the current
+-- thread's ThreadId.  We keep going until only one thread is left
+-- standing.
+--
+-- On multiple CPUs this should give throwTo a good workout.
+--
+main m t = do
+  ms <- replicateM m $ newMVar Nothing
+  let arr = listArray (1,m) ms
+  dead <- newTVarIO 0
+  ts <- replicateM t $ forkIO (thread m arr `onException`
+                                      (atomically $ do d <- readTVar dead
+                                                       writeTVar dead $! d+1))
+  atomically $ do
+    d <- readTVar dead
+    when (d < t-1) $ retry
+
+thread m arr = do
+  x <- randomIO
+  id <- myThreadId
+  modifyMVar_ (arr ! ((x `mod` m) + 1)) $ \b ->
+    case b of
+      Nothing    -> return (Just id)
+      Just other -> do when (other /= id) $ killThread other
+                       return (Just id)
+  thread m arr

text @ e5644b66

+Subproject commit e5644b663c32c01a1de7299a5e711216755e01bc