Import uvector microbenchmarks for fusion

old-testsuite/microsuite/README

@@ -0,0 +1,8 @@
+Here is a set of small programs useful for visually inspecting
+that fusion has worked. Many of them have decent runtimes that will
+explode if fusion fails.
+
+In addition, there is a script, ./Test, that will check the entire suite
+against expected rule firings.
+
+The Test.hs file will need to be updated if you add new fusion rules.

old-testsuite/microsuite/Test.hs

@@ -0,0 +1,200 @@
+{-# LANGUAGE CPP #-}
+
+#if __GLASGOW_HASKELL__  < 610
+import System.Process
+import qualified Control.Exception as C
+#else
+import System.Process hiding (readProcess)
+import qualified Control.OldException as C
+#endif
+
+import System.Exit
+import System.IO
+import Data.List
+import Data.Maybe
+import System.Directory
+
+import Control.Monad
+import Control.Concurrent
+import Text.Printf
+
+import Text.Regex.PCRE.Light.Char8
+
+------------------------------------------------------------------------
+
+flags= [["-O","-fspec-constr"]
+       ,["-O2"]
+       ]
+
+tests =
+    [(Just 2, "cons",                       flags )     -- expect 2 fusions, with -O2 and -O
+    ,(Just 2, "snoc",                       flags )
+    ,(Just 2, "empty",                      flags )
+--  ,(Just 1, "from-to",                    flags )
+    ,(Just 2, "singleton",                  flags )
+    ,(Just 4, "map",                        flags )
+    ,(Just 5, "filter",                     flags )
+    ,(Just 2, "replicate",                  flags )
+    ,(Just 2, "takeWhile",                  flags )
+    ,(Just 2, "index",                      flags )
+    ,(Just 3, "null",                       flags )
+    ,(Just 1, "length",                     flags )
+    ,(Just 1, "length-bool",                flags )
+    ,(Just 1, "length-unit",                flags )
+    ,(Just 1, "length-char",                flags )
+    ,(Just 1, "length-word",                flags )
+
+    ,(Just 1, "length-word8",                flags )
+    ,(Just 1, "length-word16",                flags )
+    ,(Just 1, "length-word32",                flags )
+    ,(Just 1, "length-word64",                flags )
+
+    ,(Just 1, "length-int8",                flags )
+    ,(Just 1, "length-int16",                flags )
+    ,(Just 1, "length-int32",                flags )
+    ,(Just 1, "length-int64",                flags )
+
+    ,(Just 1, "length-double",                flags )
+    ,(Just 1, "length-float",                flags )
+    ,(Just 1, "head",                       flags )
+    ,(Just 3, "append",                     flags )
+    ,(Just 2, "sum",                        flags )
+    ,(Just 3, "product",                    flags )
+    ,(Just 1, "and",                        flags )
+    ,(Just 1, "or",                         flags )
+    ,(Just 2, "elem",                         flags )
+    ,(Just 2, "tail",                         flags )
+    ,(Just 2, "find",                         flags )
+    ,(Just 2, "findIndex",                         flags )
+    ,(Just 2, "init",                         flags )
+    ,(Just 2, "last",                         flags )
+    ,(Just 3, "foldl1",                         flags )
+    ,(Just 3, "minimum",                         flags )
+    ,(Just 3, "maximum",                         flags )
+    ,(Just 3, "maximumBy",                         flags )
+    ,(Just 3, "minimumBy",                         flags )
+    ,(Just 2, "take",                         flags )
+    ,(Just 2, "drop",                         flags )
+    ,(Just 4, "zipwith",                         flags )
+    ,(Just 4, "zipwith3",                         flags )
+    ,(Just 3, "zip",                         flags ) -- expect zipU fusion
+    ]
+
+------------------------------------------------------------------------
+
+main = do
+    printf "Running %d fusion tests.\n" (length tests)
+    vs <- forM tests $ \x -> do v <- run x
+                                putChar '\n'
+                                return v
+    printf "\nDone.\n"
+    if not (and vs)
+       then exitWith (ExitFailure 1)
+       else return ()
+
+run :: (Maybe Int, String, [[String]]) -> IO Bool
+run (n, name, args) = do
+  printf "%20s: " name >> hFlush stdout
+  v <- forM args $ \opt -> do
+    putChar '.' >> hFlush stdout
+    (cmd,ex,fusion) <- compile_program name opt
+    if ex /= n
+       then do
+               printf "\n%s failed to trigger fusion. Expected %s, Actual %s.\n"
+                            name (show n) (show ex)
+               printf "Command line: %s\n" (show $ intercalate " " cmd)
+               return False
+       else
+         if isJust fusion
+            then do
+                   printf "\n%s failed to remove all vectors.\n" name
+                   printf "Remnants: %s\n" (show fusion)
+                   printf "Command line: %s\n" (show $ intercalate " " cmd)
+                   return False
+            else return True
+  return (and v)
+
+------------------------------------------------------------------------
+
+compile_program s opt = do
+
+    let command = [(s ++ ".hs"), "-ddump-simpl","-ddump-simpl-stats","-no-recomp","--make"] ++ opt
+    x <- readProcess "ghc" command [] 
+    removeFile s
+    case x of
+         Left (err,str) -> do
+            print str
+            printf "GHC failed to compile %s\n" s
+            exitWith (ExitFailure 1) -- fatal
+
+         Right str      -> do
+            return $ case match fusion_regex str [] of
+                          Nothing -> (command,Nothing,Nothing)
+                          Just xs -> {- trace (show xs) $ -}
+                               let fusion_result = (read . last $ xs)
+                               in case match left_over_vector str [] of
+                                     Nothing -> (command, Just fusion_result, Nothing)
+                                     Just n  -> (command, Just fusion_result, Just n)
+
+------------------------------------------------------------------------
+
+-- Fusion happened
+fusion_regex = compile "(\\d+).*(?:stream|length|head)/unstream" []
+
+-- Data.Array.Vector.Strict.Prim.UVec
+-- UVectors were left behind
+left_over_vector = compile "Data\\.Vector\\.Unboxed\\.Base\\.Vector" []
+
+------------------------------------------------------------------------
+
+-- Also, bytestring input/output, since we're strict
+-- Document that this isn't for interactive
+
+--
+-- | readProcess forks an external process, reads its standard output
+-- strictly, blocking until the process terminates, and returns either the output
+-- string, or, in the case of non-zero exit status, an error code, and
+-- any output.
+--
+-- Output is returned strictly, so this is not suitable for
+-- interactive applications.
+--
+-- Users of this library should compile with -threaded if they
+-- want other Haskell threads to keep running while waiting on
+-- the result of readProcess.
+--
+-- >  > readProcess "date" [] []
+-- >  Right "Thu Feb  7 10:03:39 PST 2008\n"
+--
+-- The argumenst are:
+--
+-- * The command to run, which must be in the $PATH, or an absolute path 
+--  
+-- * A list of separate command line arguments to the program
+--
+-- * A string to pass on the standard input to the program.
+--
+readProcess :: FilePath                     -- ^ command to run
+            -> [String]                     -- ^ any arguments
+            -> String                       -- ^ standard input
+            -> IO (Either (ExitCode,String) String)  -- ^ either the stdout, or an exitcode and any output
+
+readProcess cmd args input = C.handle (return . handler) $ do
+    (inh,outh,errh,pid) <- runInteractiveProcess cmd args Nothing Nothing
+    output  <- hGetContents outh
+    outMVar <- newEmptyMVar
+    forkIO $ (C.evaluate (length output) >> putMVar outMVar ())
+    when (not (null input)) $ hPutStr inh input
+    takeMVar outMVar
+    ex     <- C.catch (waitForProcess pid) (\_e -> return ExitSuccess)
+    hClose outh
+    hClose inh          -- done with stdin
+    hClose errh         -- ignore stderr
+
+    return $ case ex of
+        ExitSuccess   -> Right output
+        ExitFailure _ -> Left (ex, output)
+
+  where
+    handler (C.ExitException e) = Left (e,"")
+    handler e                   = Left (ExitFailure 1, show e)

old-testsuite/microsuite/and.hs

@@ -0,0 +1,3 @@
+import qualified Data.Vector as U
+main = print (U.and (U.replicate 100 True))
+

old-testsuite/microsuite/append.hs

@@ -0,0 +1,5 @@
+import qualified Data.Vector as U
+import Data.Bits
+main = print . U.sum . U.map (`shiftL` 2) $
+           (U.++) (U.replicate 10000000 (1::Int))
+                  (U.replicate 10000000 (7::Int))

old-testsuite/microsuite/cons.hs

@@ -0,0 +1,3 @@
+import qualified Data.Vector as U
+main = print . U.sum . U.cons 0xdeadbeef . U.replicate (100000000::Int) $ (8::Int)
+

old-testsuite/microsuite/drop.hs

@@ -0,0 +1,4 @@
+import qualified Data.Vector as U
+import Data.Bits
+main = print . U.length . U.drop 100000 . U.replicate 1000000 $ (7 :: Int)
+

old-testsuite/microsuite/elem.hs

@@ -0,0 +1,4 @@
+import qualified Data.Vector as U
+import Data.Bits
+main = print . U.elem 100 . U.map (`shiftL` 1) . U.enumFromTo 1 $ (10000 :: Int)
+

old-testsuite/microsuite/empty.hs

@@ -0,0 +1,3 @@
+import qualified Data.Vector as U
+main = print . U.sum $ U.cons (0xdeadbeef::Int) U.empty
+

old-testsuite/microsuite/eq.hs

@@ -0,0 +1,6 @@
+
+import qualified Data.Vector.Unboxed as U
+main = print ((==) (U.replicate 100000000 True)
+                   (U.replicate 100000000 True))
+
+

old-testsuite/microsuite/filter.hs

@@ -0,0 +1,4 @@
+import qualified Data.Vector as U
+import Data.Bits
+main = print . U.sum . U.map (`shiftL` 1) . U.filter (<20). U.map (*2) . U.map (+1) . U.replicate (100000000::Int) $ (8::Int)
+

old-testsuite/microsuite/find.hs

@@ -0,0 +1,4 @@
+import qualified Data.Vector as U
+import Data.Bits
+main = print . U.find (==100) . U.map (`shiftL` 1) . U.enumFromTo 1 $ (10000 :: Int)
+

old-testsuite/microsuite/findIndex.hs

@@ -0,0 +1,4 @@
+import qualified Data.Vector as U
+import Data.Bits
+main = print . U.findIndex (==100) . U.map (`shiftL` 1) . U.enumFromTo 1 $ (10000 :: Int)
+

old-testsuite/microsuite/foldl1.hs

@@ -0,0 +1,4 @@
+import qualified Data.Vector as U
+import Data.Bits
+main = print . U.foldl1 (+) . U.map (*2) . U.map (`shiftL` 2) $ U.replicate (100000000 :: Int) (5::Int)
+

old-testsuite/microsuite/from-to.hs

@@ -0,0 +1,2 @@
+import qualified Data.Vector as U
+main = print . head . U.toList . U.fromList $ replicate 1 (7::Int)

old-testsuite/microsuite/head.hs

@@ -0,0 +1,4 @@
+import qualified Data.Vector as U
+import Data.Bits
+main = print . U.head . U.map (`shiftL` 1) . U.replicate 1000000000 $ (7 :: Int)
+

old-testsuite/microsuite/index.hs

@@ -0,0 +1,3 @@
+import qualified Data.Vector as U
+main = print . (\arr -> arr U.! 42) . U.map (subtract 6) . U.replicate 10000000 $ (7 :: Int)
+

old-testsuite/microsuite/init.hs

@@ -0,0 +1,4 @@
+import qualified Data.Vector as U
+import Data.Bits
+main = print . U.length . U.init . U.replicate 1000000 $ (7 :: Int)
+

old-testsuite/microsuite/last.hs

@@ -0,0 +1,4 @@
+import qualified Data.Vector as U
+import Data.Bits
+main = print . U.last . U.map (`shiftL` 1) . U.replicate 1000000000 $ (7 :: Int)
+

old-testsuite/microsuite/length-bool.hs

@@ -0,0 +1,3 @@
+import qualified Data.Vector as U
+main = print (U.length (U.replicate 1 True))
+

old-testsuite/microsuite/length-char.hs

@@ -0,0 +1,3 @@
+import qualified Data.Vector as U
+main = print (U.length (U.replicate 1 'x'))
+

old-testsuite/microsuite/length-double.hs

@@ -0,0 +1,3 @@
+import qualified Data.Vector as U
+main = print (U.length (U.replicate 1 (pi :: Double)))
+

old-testsuite/microsuite/length-float.hs

@@ -0,0 +1,3 @@
+import qualified Data.Vector as U
+main = print (U.length (U.replicate 1 (pi :: Float)))
+

old-testsuite/microsuite/length-int16.hs

@@ -0,0 +1,4 @@
+import qualified Data.Vector as U
+import Data.Int
+main = print (U.length (U.replicate 1 (7 :: Int16)))
+

old-testsuite/microsuite/length-int32.hs

@@ -0,0 +1,4 @@
+import qualified Data.Vector as U
+import Data.Int
+main = print (U.length (U.replicate 1 (7 :: Int32)))
+

old-testsuite/microsuite/length-int64.hs

@@ -0,0 +1,4 @@
+import qualified Data.Vector as U
+import Data.Int
+main = print (U.length (U.replicate 1 (7 :: Int64)))
+

old-testsuite/microsuite/length-int8.hs

@@ -0,0 +1,4 @@
+import qualified Data.Vector as U
+import Data.Int
+main = print (U.length (U.replicate 1 (7 :: Int8)))
+

old-testsuite/microsuite/length-unit.hs

@@ -0,0 +1,3 @@
+import qualified Data.Vector as U
+main = print (U.length (U.replicate 1 ()))
+

old-testsuite/microsuite/length-word.hs

@@ -0,0 +1,4 @@
+import qualified Data.Vector as U
+import Data.Word
+main = print (U.length (U.replicate 1 (7 :: Word)))
+

old-testsuite/microsuite/length-word16.hs

@@ -0,0 +1,4 @@
+import qualified Data.Vector as U
+import Data.Word
+main = print (U.length (U.replicate 1 (7 :: Word16)))
+

old-testsuite/microsuite/length-word32.hs

@@ -0,0 +1,4 @@
+import qualified Data.Vector as U
+import Data.Word
+main = print (U.length (U.replicate 1 (7 :: Word32)))
+

old-testsuite/microsuite/length-word64.hs

@@ -0,0 +1,4 @@
+import qualified Data.Vector as U
+import Data.Word
+main = print (U.length (U.replicate 1 (7 :: Word64)))
+

old-testsuite/microsuite/length-word8.hs

@@ -0,0 +1,4 @@
+import qualified Data.Vector as U
+import Data.Word
+main = print (U.length (U.replicate 1 (7 :: Word8)))
+

old-testsuite/microsuite/length.hs

@@ -0,0 +1,3 @@
+import qualified Data.Vector as U
+main = print . U.length . U.enumFromTo 1 $ (100000000 :: Int)
+

old-testsuite/microsuite/lookup.hs

@@ -0,0 +1,5 @@
+import qualified Data.Vector as U
+import Data.Bits
+main = print . U.lookup 10000
+             . U.zip (U.enumFromTo 1 (10000000 :: Int)) $
+                     (U.replicate (10000000 :: Int) (42::Int))

old-testsuite/microsuite/map.hs

@@ -0,0 +1,4 @@
+import qualified Data.Vector as U
+import Data.Bits
+main = print . U.sum . U.map (`shiftL` 1) . U.map (*2) . U.map (+1) . U.replicate (100000000::Int) $ (8::Int)
+

old-testsuite/microsuite/maximum.hs

@@ -0,0 +1,4 @@
+import qualified Data.Vector as U
+import Data.Bits
+main = print . U.maximum . U.map (*2) . U.map (`shiftL` 2) $ U.replicate (100000000 :: Int) (5::Int)
+

old-testsuite/microsuite/maximumBy.hs

@@ -0,0 +1,4 @@
+import qualified Data.Vector as U
+import Data.Bits
+main = print . U.maximumBy (\x y -> GT) . U.map (*2) . U.map (`shiftL` 2) $ U.replicate (100000000 :: Int) (5::Int)
+

old-testsuite/microsuite/minimum.hs

@@ -0,0 +1,4 @@
+import qualified Data.Vector as U
+import Data.Bits
+main = print . U.minimum . U.map (*2) . U.map (`shiftL` 2) $ U.replicate (100000000 :: Int) (5::Int)
+

old-testsuite/microsuite/minimumBy.hs

@@ -0,0 +1,4 @@
+import qualified Data.Vector as U
+import Data.Bits
+main = print . U.minimumBy (\x y -> GT) . U.map (*2) . U.map (`shiftL` 2) $ U.replicate (100000000 :: Int) (5::Int)
+

old-testsuite/microsuite/null-ndp.hs

@@ -0,0 +1,3 @@
+import qualified Data.Vector as U -- Parallel.Unlifted
+main = print . U.sum . U.map fstS . indexedU . U.enumFromTo 1 $ (100000000 :: Int)
+

old-testsuite/microsuite/null.hs

@@ -0,0 +1,3 @@
+import qualified Data.Vector as U
+main = print . U.null . U.filter (>10) . U.map (subtract 6) . U.enumFromTo 1 $ (100000000 :: Int)
+

old-testsuite/microsuite/or.hs

@@ -0,0 +1,3 @@
+import qualified Data.Vector as U
+main = print (U.or (U.replicate 100 True))
+