[commit: testsuite] master: Test Trac #8425 (7fb29c6)
git at git.haskell.org
git at git.haskell.org
Thu Oct 24 14:45:04 UTC 2013
Repository : ssh://git@git.haskell.org/testsuite
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/7fb29c6b82d15365a38a11745afee958e2beace6/testsuite
>---------------------------------------------------------------
commit 7fb29c6b82d15365a38a11745afee958e2beace6
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date: Thu Oct 24 15:44:50 2013 +0100
Test Trac #8425
>---------------------------------------------------------------
7fb29c6b82d15365a38a11745afee958e2beace6
tests/stranal/should_run/T8425/Arr.hs | 67 ++++++++++++++++++++
tests/stranal/should_run/T8425/Base.hs | 43 +++++++++++++
tests/stranal/should_run/T8425/BuggyOpt.hs | 13 ++++
tests/stranal/should_run/T8425/Good.hs | 4 ++
tests/stranal/should_run/T8425/M.hs | 9 +++
tests/stranal/should_run/T8425/Main.hs | 14 ++++
.../break022 => stranal/should_run/T8425}/Makefile | 0
.../should_run/T8425/T8425.stdout} | 0
tests/stranal/should_run/T8425/all.T | 5 ++
9 files changed, 155 insertions(+)
diff --git a/tests/stranal/should_run/T8425/Arr.hs b/tests/stranal/should_run/T8425/Arr.hs
new file mode 100644
index 0000000..e9627ec
--- /dev/null
+++ b/tests/stranal/should_run/T8425/Arr.hs
@@ -0,0 +1,67 @@
+{-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples, FlexibleInstances #-}
+{-# OPTIONS_GHC -funbox-strict-fields #-}
+
+module Arr (
+ Array(..), (!!!), array
+ ) where
+
+import GHC.Num
+import GHC.ST
+import GHC.Base
+import Good
+
+data Array e = Array !Int !Int Int (Array# e)
+
+array :: (Int,Int) -> [(Int, e)] -> Array e
+array (l,u) ies
+ = unsafeArray (l,u) [(index (l,u) i, e) | (i, e) <- ies]
+
+unsafeArray :: (Int,Int) -> [(Int, e)] -> Array e
+unsafeArray b ies = unsafeArray' b (rangeSize b) ies
+
+unsafeArray' :: (Int,Int) -> Int -> [(Int, e)] -> Array e
+unsafeArray' (l,u) n@(I# n#) ies =
+ if n == 0 then error "aa" else runST (ST $ \s1# ->
+ case newArray# n# arrEleBottom s1# of
+ (# s2#, marr# #) ->
+ foldr (fill marr#) (done l u n marr#) ies s2#)
+
+{-# NOINLINE arrEleBottom #-}
+arrEleBottom :: a
+arrEleBottom = error "(Array.!): undefined array element"
+
+unsafeAt :: Array e -> Int -> e
+unsafeAt (Array _ _ _ arr#) (I# i#) =
+ case indexArray# arr# i# of (# e #) -> e
+
+fill :: MutableArray# s e -> (Int, e) -> STRep s a -> STRep s a
+fill marr# (I# i#, e) next
+ = \s1# -> case writeArray# marr# i# e s1# of
+ s2# -> next s2#
+
+done :: Int -> Int -> Int -> MutableArray# s e -> STRep s (Array e)
+done l u n marr#
+ = \s1# -> case unsafeFreezeArray# marr# s1# of
+ (# s2#, arr# #) -> (# s2#, Array l u n arr# #)
+
+instance Eq (Array e) where
+ (Array l1 _ _ _) == (Array l2 _ _ _) = l1 == l2
+
+instance Ord (Array e) where
+ compare (Array l1 _ _ _) (Array l2 _ _ _) = compare l1 l2
+
+{-# INLINE index #-}
+index :: (Int,Int) -> Int -> Int
+index (m,n) i | m <= i && i <= n = i - m
+ | otherwise = error "index out of range"
+
+rangeSize :: (Int,Int) -> Int
+rangeSize (l,h) = h - l + 1
+
+
+{-# INLINE (!!!) #-}
+(!!!) :: Array e -> Int -> e
+arr@(Array l u _ _) !!! i = unsafeAt arr $ index (l,u) i
+
+instance Good (Array Int) where
+ isGood (Array _ _ n _) = 0 < n
diff --git a/tests/stranal/should_run/T8425/Base.hs b/tests/stranal/should_run/T8425/Base.hs
new file mode 100644
index 0000000..0c96bd4
--- /dev/null
+++ b/tests/stranal/should_run/T8425/Base.hs
@@ -0,0 +1,43 @@
+module Base (
+ Map(..)
+ , lookup
+ , empty
+ , insert
+ ) where
+
+import Prelude hiding (lookup)
+import Good
+
+empty :: Map k a
+empty = Tip
+
+data Map k a = Bin !k a !(Map k a) | Tip
+
+insert :: Ord k => k -> a -> Map k a -> Map k a
+insert = go
+ where
+ go :: Ord k => k -> a -> Map k a -> Map k a
+ go kx x Tip = singleton kx x
+ go kx x (Bin ky y r) =
+ case compare kx ky of
+ EQ -> Bin kx x r
+ LT -> Bin ky y (go kx x r)
+ GT -> Bin ky y (go kx x r)
+{-# INLINABLE insert #-}
+
+singleton :: k -> a -> Map k a
+singleton k x = Bin k x Tip
+
+lookup :: Eq k => k -> Map k a -> Maybe a
+lookup = go
+ where
+ go x _ | x `seq` False = undefined
+ go _ Tip = Nothing
+ go k (Bin kx x r) = case k == kx of
+ False -> go k r
+ True -> Just x
+{-# INLINABLE lookup #-}
+
+instance Good k => Good (Map k a) where
+ isGood Tip = True
+ isGood (Bin k _ r) = isGood k && isGood r
diff --git a/tests/stranal/should_run/T8425/BuggyOpt.hs b/tests/stranal/should_run/T8425/BuggyOpt.hs
new file mode 100644
index 0000000..b76e723
--- /dev/null
+++ b/tests/stranal/should_run/T8425/BuggyOpt.hs
@@ -0,0 +1,13 @@
+module BuggyOpt
+ (
+ addSequence, -- induces inliner bug, but not used anywhere
+ ) where
+
+import M
+import Prelude hiding (lookup)
+
+addSequence :: Map (Array Int) Int -> Map (Array Int) Int
+addSequence seqs =
+ seq (isJust (lookup seq_ seqs)) (insert seq_ 5 seqs)
+
+seq_ = array (2,2) [ (2,3)]
diff --git a/tests/stranal/should_run/T8425/Good.hs b/tests/stranal/should_run/T8425/Good.hs
new file mode 100644
index 0000000..ebfbf31
--- /dev/null
+++ b/tests/stranal/should_run/T8425/Good.hs
@@ -0,0 +1,4 @@
+module Good (Good(..)) where
+
+class Good a where
+ isGood :: a -> Bool
diff --git a/tests/stranal/should_run/T8425/M.hs b/tests/stranal/should_run/T8425/M.hs
new file mode 100644
index 0000000..894e227
--- /dev/null
+++ b/tests/stranal/should_run/T8425/M.hs
@@ -0,0 +1,9 @@
+module M (Array, (!!!), array, isJust, Map, lookup, insert, empty) where
+
+import Arr (Array, (!!!), array)
+import Base (Map, lookup, insert, empty)
+import Prelude hiding (lookup)
+
+isJust :: Maybe a -> Bool
+isJust Nothing = False
+isJust (Just _) = True
diff --git a/tests/stranal/should_run/T8425/Main.hs b/tests/stranal/should_run/T8425/Main.hs
new file mode 100644
index 0000000..cc2935b
--- /dev/null
+++ b/tests/stranal/should_run/T8425/Main.hs
@@ -0,0 +1,14 @@
+module Main where
+
+import BuggyOpt() -- bug inducer!
+
+import Prelude hiding (lookup)
+import Good
+import M
+
+mkLin :: Array Int -> Map (Array Int) Int
+mkLin mseqs =
+ (isJust (lookup mseqs empty)) `seq` (insert mseqs 1 empty)
+
+main :: IO ()
+main = print $ isGood $ mkLin (array (1,1) [ (1,array (3,3) [(3, 42)]) ]!!!1)
diff --git a/tests/ghci.debugger/scripts/break022/Makefile b/tests/stranal/should_run/T8425/Makefile
similarity index 100%
copy from tests/ghci.debugger/scripts/break022/Makefile
copy to tests/stranal/should_run/T8425/Makefile
diff --git a/tests/codeGen/should_run/cgrun033.stdout b/tests/stranal/should_run/T8425/T8425.stdout
similarity index 100%
copy from tests/codeGen/should_run/cgrun033.stdout
copy to tests/stranal/should_run/T8425/T8425.stdout
diff --git a/tests/stranal/should_run/T8425/all.T b/tests/stranal/should_run/T8425/all.T
new file mode 100644
index 0000000..03f2c44
--- /dev/null
+++ b/tests/stranal/should_run/T8425/all.T
@@ -0,0 +1,5 @@
+# Optimised only, we're testing the strictness analyser here
+setTestOpts( only_ways(['optasm']) )
+
+test('T8425', normal, multimod_compile_and_run, ['Main','-O2'])
+
More information about the ghc-commits
mailing list