Repository : ssh://darcs.haskell.org//srv/darcs/testsuite On branch : master
http://hackage.haskell.org/trac/ghc/changeset/b64a59b4dc8ff179f0107c4f2194100b758ac3ab >--------------------------------------------------------------- commit b64a59b4dc8ff179f0107c4f2194100b758ac3ab Author: Ian Lynagh <[email protected]> Date: Sun Apr 17 15:14:09 2011 +0100 Add a test for #2902 >--------------------------------------------------------------- tests/ghc-regress/perf/should_run/Makefile | 11 ++++ tests/ghc-regress/perf/should_run/T2902_A.hs | 18 +++++++ .../perf/should_run/T2902_A_PairingSum.hs | 49 ++++++++++++++++++++ tests/ghc-regress/perf/should_run/T2902_B.hs | 18 +++++++ .../perf/should_run/T2902_B_PairingSum.hs | 37 +++++++++++++++ tests/ghc-regress/perf/should_run/T2902_Sum.hs | 14 ++++++ tests/ghc-regress/perf/should_run/all.T | 12 +++++ 7 files changed, 159 insertions(+), 0 deletions(-) diff --git a/tests/ghc-regress/perf/should_run/Makefile b/tests/ghc-regress/perf/should_run/Makefile index 53fc382..f40e014 100644 --- a/tests/ghc-regress/perf/should_run/Makefile +++ b/tests/ghc-regress/perf/should_run/Makefile @@ -15,3 +15,14 @@ T3736: # 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 +.PHONY: T2902 +T2902: + $(RM) -f T2902_A T2902_B + $(RM) -f T2902_A.hi T2902_B.hi + $(RM) -f T2902_A.o T2902_B.o + $(RM) -f T2902_A_PairingSum.hi T2902_B_PairingSum.hi T2902_Sum.hi + $(RM) -f T2902_A_PairingSum.o T2902_B_PairingSum.o T2902_Sum.o + '$(TEST_HC)' -v0 -O --make T2902_A -rtsopts + '$(TEST_HC)' -v0 -O --make T2902_B -rtsopts + BAA=`./T2902_A +RTS -t --machine-readable 2>&1 | grep '"bytes allocated"' | sed -e 's/.*, "//' -e 's/")//'`; BAB=`./T2902_B +RTS -t --machine-readable 2>&1 | grep '"bytes allocated"' | sed -e 's/.*, "//' -e 's/")//'`; [ "$$BAA" = "" ] && echo 'T2902_A: No "bytes allocated"'; [ "$$BAA" = "$$BAB" ] || echo 'T2902: Mismatch in "bytes allocated"' + diff --git a/tests/ghc-regress/perf/should_run/T2902_A.hs b/tests/ghc-regress/perf/should_run/T2902_A.hs new file mode 100644 index 0000000..c093910 --- /dev/null +++ b/tests/ghc-regress/perf/should_run/T2902_A.hs @@ -0,0 +1,18 @@ + +{-# LANGUAGE UnicodeSyntax #-} + +module Main (main) where + +import T2902_A_PairingSum + +f :: Int -> PSum Int Int +f n = unions $ fmap g [1..n] + where + g m = unions $ fmap fromList + [ zip [m..n] $ repeat 1 + , zip [m,2+m..n] $ repeat 2 + , zip [m,3+m..n] $ repeat 3 + ] + +main â· IO () +main = print $ take 20 $ toList $ f 20 diff --git a/tests/ghc-regress/perf/should_run/T2902_A_PairingSum.hs b/tests/ghc-regress/perf/should_run/T2902_A_PairingSum.hs new file mode 100644 index 0000000..a5dd0e7 --- /dev/null +++ b/tests/ghc-regress/perf/should_run/T2902_A_PairingSum.hs @@ -0,0 +1,49 @@ + +{-# LANGUAGE UnicodeSyntax, MultiParamTypeClasses, FlexibleInstances #-} + +module T2902_A_PairingSum (Sum(..), PSum) where + +import T2902_Sum + +data PSum a b = Empty | Tree a b [(PSum a b)] + +instance (Ord a, Num b) â Sum PSum a b where + insert = insertX + union = unionX + unions = unionsX + extractMin = extractMinX + fromList = fromListX + toList = toListX + +insertX â· (Ord a, Num b) â a â b â PSum a b â PSum a b +insertX v r = unionX $ Tree v r [] + +unionX â· (Ord a, Num b) â PSum a b â PSum a b â PSum a b +unionX x Empty = x +unionX Empty x = x +unionX x@(Tree v r xs) y@(Tree w s ys) = + case compare v w of + LT â Tree v r (y:xs) + GT â Tree w s (x:ys) + EQ â case r + s of + 0 â z + t â insertX v t z + where z = unionX (unionsX xs) (unionsX ys) + +unionsX â· (Ord a, Num b) â [PSum a b] â PSum a b +unionsX [] = Empty +unionsX [x] = x +unionsX (x : y : zs) = unionX (unionX x y) (unionsX zs) + +extractMinX â· (Ord a, Num b) â PSum a b â ((a,b), PSum a b) +extractMinX Empty = undefined +extractMinX (Tree v r xs) = ((v,r), unionsX xs) + +fromListX â· (Ord a, Num b) â [(a,b)] â PSum a b +fromListX [] = Empty +fromListX ((v,r):xs) = insertX v r $ fromListX xs + +toListX â· (Ord a, Num b) â PSum a b â [(a,b)] +toListX Empty = [] +toListX x = let (y, z) = extractMinX x in y : toListX z + diff --git a/tests/ghc-regress/perf/should_run/T2902_B.hs b/tests/ghc-regress/perf/should_run/T2902_B.hs new file mode 100644 index 0000000..c6558c6 --- /dev/null +++ b/tests/ghc-regress/perf/should_run/T2902_B.hs @@ -0,0 +1,18 @@ + +{-# LANGUAGE UnicodeSyntax #-} + +module Main (main) where + +import T2902_B_PairingSum + +f :: Int -> PSum Int Int +f n = unions $ fmap g [1..n] + where + g m = unions $ fmap fromList + [ zip [m..n] $ repeat 1 + , zip [m,2+m..n] $ repeat 2 + , zip [m,3+m..n] $ repeat 3 + ] + +main â· IO () +main = print $ take 20 $ toList $ f 20 diff --git a/tests/ghc-regress/perf/should_run/T2902_B_PairingSum.hs b/tests/ghc-regress/perf/should_run/T2902_B_PairingSum.hs new file mode 100644 index 0000000..5276da8 --- /dev/null +++ b/tests/ghc-regress/perf/should_run/T2902_B_PairingSum.hs @@ -0,0 +1,37 @@ + +{-# LANGUAGE UnicodeSyntax, MultiParamTypeClasses, FlexibleInstances #-} + +module T2902_B_PairingSum (Sum(..), PSum) where + +import T2902_Sum + +data PSum a b = Empty | Tree a b [PSum a b] + +instance (Ord a, Num b) â Sum PSum a b where + + insert v r = union $ Tree v r [] + + union x Empty = x + union Empty x = x + union x@(Tree v r xs) y@(Tree w s ys) = + case compare v w of + LT â Tree v r (y:xs) + GT â Tree w s (x:ys) + EQ â case r + s of + 0 â z + t â insert v t z + where z = union (unions xs) (unions ys) + + unions [] = Empty + unions [x] = x + unions (x : y : zs) = union (union x y) (unions zs) + + extractMin Empty = undefined + extractMin (Tree v r xs) = ((v,r), unions xs) + + fromList [] = Empty + fromList ((v,r):xs) = insert v r $ fromList xs + + toList Empty = [] + toList x = let (y, z) = extractMin x in y : toList z + diff --git a/tests/ghc-regress/perf/should_run/T2902_Sum.hs b/tests/ghc-regress/perf/should_run/T2902_Sum.hs new file mode 100644 index 0000000..9be6b10 --- /dev/null +++ b/tests/ghc-regress/perf/should_run/T2902_Sum.hs @@ -0,0 +1,14 @@ + +{-# LANGUAGE UnicodeSyntax, MultiParamTypeClasses #-} + +module T2902_Sum (Sum(..)) where + +class Sum c a b where + insert â· a â b â c a b â c a b + union â· c a b â c a b â c a b + unions â· [c a b] â c a b + extractMin â· c a b â ((a,b), c a b) + + fromList â· [(a,b)] â c a b + toList â· c a b â [(a,b)] + diff --git a/tests/ghc-regress/perf/should_run/all.T b/tests/ghc-regress/perf/should_run/all.T index 706b33d..1886d43 100644 --- a/tests/ghc-regress/perf/should_run/all.T +++ b/tests/ghc-regress/perf/should_run/all.T @@ -89,3 +89,15 @@ test('MethSharing', ], compile_and_run, ['-O']) +test('T2902', + [normal, + extra_clean(['T2902_A', 'T2902_B', + 'T2902_A.hi', 'T2902_B.hi', + 'T2902_A.o', 'T2902_B.o', + 'T2902_A_PairingSum.hi', 'T2902_B_PairingSum.hi', + 'T2902_A_PairingSum.o', 'T2902_B_PairingSum.o', + 'T2902_Sum.hi', + 'T2902_Sum.o'])], + run_command, + ['$MAKE -s --no-print-directory T2902']) +
_______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
