Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: b85a0293 by Simon Jakobi at 2026-03-11T15:06:41-04:00 Add perf test for #1216 Closes #1216. - - - - - 3 changed files: - + testsuite/tests/perf/should_run/T1216.hs - + testsuite/tests/perf/should_run/T1216.stdout - testsuite/tests/perf/should_run/all.T Changes: ===================================== testsuite/tests/perf/should_run/T1216.hs ===================================== @@ -0,0 +1,68 @@ +{-# LANGUAGE BangPatterns #-} + +import Data.Array.Base +import GHC.Arr(unsafeIndex,index) +import Data.Array.IArray +import Control.Monad.ST +import Data.Array.ST +import System.Environment(getArgs) + +type Elem = Double +type Vector = [Elem] +type Matrix = [Vector] + +n :: Num a => a +n = 40 + +a :: Matrix +a = [[if i==j then 1 else 0|i<-[1..n]]|j<-[1..n]] + +p :: Vector +p = [1..n] + +------------------------ array-based, update-in-place code + +type VectorA s = STUArray s Int Elem +type MatrixA s = STUArray s (Int,Int) Elem + +{-# INLINE myreadArray #-} +-- | Read an element from a mutable array +myreadArray :: (MArray a e m, Ix i) => a i e -> i -> m e +myreadArray marr i = do + (l,u) <- getBounds marr + unsafeRead marr (myindex (l,u) i) + +{-# INLINE mywriteArray #-} +-- | Write an element in a mutable array +mywriteArray :: (MArray a e m, Ix i) => a i e -> i -> e -> m () +mywriteArray marr i e = do + (l,u) <- getBounds marr + unsafeWrite marr (myindex (l,u) i) e + +myindex b i = index b i +-- the following is supposed to be the default implementation of index, +-- from GHC.Arr +-- myindex b i | inRange b i = unsafeIndex b i +-- | otherwise = error "Error in array index" + +matA :: MatrixA s -> VectorA s -> VectorA s -> ST s (VectorA s) +(m `matA` v) tmp = m `seq` v `seq` tmp `seq` l 1 1 0 + where l !i !j !s | i>n = return tmp + l i j s | j>n = mywriteArray tmp i s >> l (i+1) 1 0 + l i j s = do a<-myreadArray m (i,j) + b<-myreadArray v j + l i (j+1) (s+a*b) + +loopA a p q n | n==0 = return q +loopA a p q n = do + (a `matA` p) q + loopA a p q (n-1) + +testA c = runSTUArray (do + aA <- newListArray ((1,1),(n,n)) (concat a) + pA <- newListArray (1,n) p + qA <- newArray (1,n) 0 + loopA aA pA qA c + ) + +main = print $ testA 100_000 ===================================== testsuite/tests/perf/should_run/T1216.stdout ===================================== @@ -0,0 +1 @@ +array (1,40) [(1,1.0),(2,2.0),(3,3.0),(4,4.0),(5,5.0),(6,6.0),(7,7.0),(8,8.0),(9,9.0),(10,10.0),(11,11.0),(12,12.0),(13,13.0),(14,14.0),(15,15.0),(16,16.0),(17,17.0),(18,18.0),(19,19.0),(20,20.0),(21,21.0),(22,22.0),(23,23.0),(24,24.0),(25,25.0),(26,26.0),(27,27.0),(28,28.0),(29,29.0),(30,30.0),(31,31.0),(32,32.0),(33,33.0),(34,34.0),(35,35.0),(36,36.0),(37,37.0),(38,38.0),(39,39.0),(40,40.0)] ===================================== testsuite/tests/perf/should_run/all.T ===================================== @@ -112,6 +112,13 @@ test('T149', ], makefile_test, ['T149']) +test ('T1216', + [collect_stats('bytes allocated',5), + only_ways(['normal']) + ], + compile_and_run, + ['-O']) + test('T5113', [collect_stats('bytes allocated',5), only_ways(['normal']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b85a02933a1e7c884b19de1b7af95095... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b85a02933a1e7c884b19de1b7af95095... You're receiving this email because of your account on gitlab.haskell.org.