Add a performance test for #3736

testsuite/tests/ghc-regress/perf/should_run/Makefile

 TOP=../../../..
 include $(TOP)/mk/boilerplate.mk
 include $(TOP)/mk/test.mk
+
+define runT3736
+./T3736 $1 +RTS -t --machine-readable 2>&1 | grep '"bytes allocated"' | sed -e 's/.*, "//' -e 's/".*//'
+endef
+.PHONY: T3736
+T3736:
+	$(RM) -f T3736.hi T3736.o T3736
+	'$(TEST_HC)' -v0 -O --make T3736 -rtsopts
+# Check ALLOC1 is > 100 just to check with have sane results, and if so,
+# the test passes if the two numbers are equal. We could check that the
+# actual numbers are in the range we expect too (on the various
+# platforms), but we don't currently.
+	ALLOC1=`$(call runT3736,1)`; ALLOC2=`$(call runT3736,2)`; if [ "$$ALLOC1" -gt 100 ] && [ "$$ALLOC1" -eq "$$ALLOC2" ]; then echo Match; else echo "Mismatch: $$ALLOC1 $$ALLOC2"; fi
+

testsuite/tests/ghc-regress/perf/should_run/T3736.hs

+{-# OPTIONS_GHC -funbox-strict-fields -O #-}
+{-# LANGUAGE ExistentialQuantification #-}
+
+{- OPTIONS_GHC -ddump-simpl -ddump-asm -}
+
+module Main (main) where
+
+import GHC.Float (float2Int, int2Float)
+
+import System.Environment
+
+import Prelude hiding           (null
+                                ,lines,unlines
+                                ,writeFile
+                                )
+
+import Control.Exception        (assert, bracket, )
+
+import Foreign.Marshal.Array    (advancePtr)
+import Foreign.Ptr              (minusPtr)
+import Foreign.Storable         (Storable(..))
+
+import Control.Monad            (when)
+
+import System.IO                (openBinaryFile, hClose,
+                                 hPutBuf,
+                                 Handle, IOMode(..))
+
+import System.IO.Unsafe         (unsafePerformIO)
+
+import Foreign.Ptr              (Ptr)
+import Foreign.ForeignPtr       (ForeignPtr, withForeignPtr, )
+import Foreign.Marshal.Array    (copyArray)
+
+import qualified Foreign.ForeignPtr as F
+
+main :: IO ()
+main = do args <- getArgs
+          case args of
+              ["1"] -> mainMonolithic1Generator
+              ["2"] -> mainMonolithic1Composed
+              _ -> error "Huh?"
+
+type Phase = (Float, Float, Float)
+
+{-# INLINE saw #-}
+saw :: Num a => a -> a
+saw t = 1-2*t
+
+{-# INLINE fraction #-}
+fraction :: Float -> Float
+fraction x = x - int2Float (float2Int x)
+
+{-# INLINE generator0Freq #-}
+generator0Freq :: Float -> Float -> Maybe (Float, Float)
+generator0Freq freq =
+   \p -> Just (saw p, fraction (p+freq))
+
+infixl 6 `mix`, `mixGen`
+
+{-# INLINE mix #-}
+mix ::
+   (Num y) =>
+   (s -> Maybe (y, s)) ->
+   (t -> Maybe (y, t)) ->
+   ((s,t) -> Maybe (y, (s,t)))
+mix f g (s0,t0) =
+   do (a,s1) <- f s0
+      (b,t1) <- g t0
+      return ((a+b), (s1,t1))
+
+data Generator a =
+   forall s.
+      Generator (s -> Maybe (a, s)) s
+
+{-# INLINE runGeneratorMonolithic #-}
+runGeneratorMonolithic :: Int -> Generator Float -> Vector Float
+runGeneratorMonolithic size' (Generator f s) =
+   fst $ unfoldrN size' f s
+
+{- SPECIALISE INLINE generator0Gen :: Float -> Float -> Generator Float -}
+{-# INLINE generator0Gen #-}
+generator0Gen :: Float -> Float -> Generator Float
+generator0Gen freq phase =
+   Generator (\p -> Just (saw p, fraction (p+freq))) phase
+
+{- SPECIALISE INLINE mixGen :: Generator Float -> Generator Float -> Generator Float -}
+{-# INLINE mixGen #-}
+mixGen ::
+   (Num y) =>
+   Generator y ->
+   Generator y ->
+   Generator y
+mixGen (Generator f s) (Generator g t) =
+   Generator (\(s0,t0) ->
+      do (a,s1) <- f s0
+         (b,t1) <- g t0
+         return ((a+b), (s1,t1))) (s,t)
+
+{-# INLINE dl #-}
+dl :: Phase
+dl = (0.01008, 0.01003, 0.00990)
+
+{-# INLINE initPhase2 #-}
+initPhase2 :: (Phase, Phase)
+initPhase2 =
+   ((0,0.7,0.1), (0.3,0.4,0.6))
+
+
+size :: Int
+size = 10000000
+
+
+mainMonolithic1Composed :: IO ()
+mainMonolithic1Composed =
+   writeFile "speed.f32"
+      (fst $ unfoldrN size
+          (let (f0,f1,f2) = dl
+           in  generator0Freq f0 `mix`
+               generator0Freq f1 `mix`
+               generator0Freq f2)
+          (let (p0,p1,p2) = fst initPhase2
+           in  ((p0,p1),p2)))
+
+mainMonolithic1Generator :: IO ()
+mainMonolithic1Generator =
+   writeFile "speed.f32"
+      (runGeneratorMonolithic size
+          (let (f0,f1,f2) = dl
+               (p0,p1,p2) = fst initPhase2
+           in  generator0Gen f0 p0 `mixGen`
+               generator0Gen f1 p1 `mixGen`
+               generator0Gen f2 p2))
+
+empty :: (Storable a) => Vector a
+empty = unsafeCreate 0 $ const $ return ()
+{-# NOINLINE empty #-}
+
+null :: Vector a -> Bool
+null (SV _ _ l) = assert (l >= 0) $ l <= 0
+{-# INLINE null #-}
+
+unfoldrN :: (Storable b) => Int -> (a -> Maybe (b, a)) -> a -> (Vector b, Maybe a)
+unfoldrN n f x0 =
+   if n <= 0
+     then (empty, Just x0)
+     else unsafePerformIO $ createAndTrim' n $ \p -> go p n x0
+       where
+          go = arguments2 $ \p i -> \x ->
+             if i == 0
+               then return (0, n-i, Just x)
+               else
+                 case f x of
+                   Nothing     -> return (0, n-i, Nothing)
+                   Just (w,x') -> do poke p w
+                                     go (incPtr p) (i-1) x'
+{-# INLINE unfoldrN #-}
+
+hPut :: (Storable a) => Handle -> Vector a -> IO ()
+hPut h v =
+   when (not (null v)) $
+      withStartPtr v $ \ ptrS l ->
+         let ptrE = advancePtr ptrS l
+         in  hPutBuf h ptrS (minusPtr ptrE ptrS)
+
+writeFile :: (Storable a) => FilePath -> Vector a -> IO ()
+writeFile f txt =
+   bracket (openBinaryFile f WriteMode) hClose
+      (\h -> hPut h txt)
+
+data Vector a = SV {-# UNPACK #-} !(ForeignPtr a)
+                   {-# UNPACK #-} !Int                -- offset
+                   {-# UNPACK #-} !Int                -- length
+
+withStartPtr :: Storable a => Vector a -> (Ptr a -> Int -> IO b) -> IO b
+withStartPtr (SV x s l) f =
+   withForeignPtr x $ \p -> f (p `advancePtr` s) l
+{-# INLINE withStartPtr #-}
+
+incPtr :: (Storable a) => Ptr a -> Ptr a
+incPtr v = advancePtr v 1
+{-# INLINE incPtr #-}
+
+unsafeCreate :: (Storable a) => Int -> (Ptr a -> IO ()) -> Vector a
+unsafeCreate l f = unsafePerformIO (create l f)
+{-# INLINE unsafeCreate #-}
+
+create :: (Storable a) => Int -> (Ptr a -> IO ()) -> IO (Vector a)
+create l f = do
+    fp <- mallocForeignPtrArray l
+    withForeignPtr fp $ \p -> f p
+    return $! SV fp 0 l
+
+createAndTrim' :: (Storable a) => Int
+                               -> (Ptr a -> IO (Int, Int, b))
+                               -> IO (Vector a, b)
+createAndTrim' l f = do
+    fp <- mallocForeignPtrArray l
+    withForeignPtr fp $ \p -> do
+        (off, l', res) <- f p
+        if assert (l' <= l) $ l' >= l
+            then return $! (SV fp 0 l, res)
+            else do ps <- create l' $ \p' -> copyArray p' (p `advancePtr` off) l'
+                    return $! (ps, res)
+
+{-# INLINE arguments2 #-}
+arguments2 :: (a -> b -> x) -> a -> b -> x
+arguments2 f = \a b -> (f $! a) $! b
+
+{-# INLINE mallocForeignPtrArray #-}
+mallocForeignPtrArray :: Storable a => Int -> IO (F.ForeignPtr a)
+mallocForeignPtrArray = F.mallocForeignPtrArray

testsuite/tests/ghc-regress/perf/should_run/T3736.stdout

+Match

testsuite/tests/ghc-regress/perf/should_run/all.T

@@ -42,4 +42,5 @@ else:
    sse2_opts = ''
 
 test('T4321', omit_ways(['ghci']), compile_and_run, ['-O ' + sse2_opts])
+test('T3736', normal, run_command, ['$MAKE -s --no-print-directory T3736'])