Move tests from tests/ghc-regress/* to just tests/*

13 files changed, 395 insertions, 0 deletions

diff --git a/testsuite/tests/eyeball/IOList.lhs b/testsuite/tests/eyeball/IOList.lhs
new file mode 100644
index 0000000000..59c282ce9b
--- /dev/null
+++ b/testsuite/tests/eyeball/IOList.lhs
@@ -0,0 +1,64 @@
+> {-# LANGUAGE BangPatterns,CPP #-}
+> module IOList (delete) where
+
+Goal: we want all the IORef boxes to go away in the "delete" operation
+below.  There are two versions of the code: one using the record
+selector "next", the other using a hand-written record selector
+"myNext" (see the use in delete).  Currently (6.10), neither version
+gives good code, but for different reasons.  The record selector
+version is not inlined, and the myNext version gives rise to a join
+point that takes the reboxed IORef as an argument.
+
+#define USE_UNPACK
+-- #define USE_STRICT
+
+#if defined(USE_UNPACK)
+#define UNPACK(p) {-# UNPACK #-} !(p)
+#elif defined(USE_STRICT)
+#define UNPACK(p) !(p)
+#else
+#define UNPACK(p) p
+#endif
+
+> import Data.IORef
+
+> data List a = Node { val :: a, next :: UNPACK(IORef (List a))}   
+>           | Null
+>           | Head {next :: UNPACK(IORef (List a)) }
+
+> {-# INLINE [0] myNext #-}
+> myNext :: List a -> IORef (List a)
+> myNext Node{next=n} = n
+> myNext Head{next=n} = n
+> myNext Null = error "null"
+
+> data ListHandle a = ListHandle { headList :: UNPACK(IORef (IORef (List a))),
+>                            tailList :: UNPACK(IORef (IORef (List a))) }
+  
+> delete :: Eq a => ListHandle a -> a -> IO Bool
+> delete (ListHandle {headList = ptrPtr})  i = 
+>          do startptr <- readIORef ptrPtr
+>             delete2 startptr i
+>   where
+>    delete2 :: Eq a => IORef (List a) -> a -> IO Bool
+>    delete2 prevPtr i =
+>     do
+>    { prevNode <- readIORef prevPtr
+>    ; let curNodePtr = next {- or: myNext -} prevNode --  head/node have both next 
+>    ; curNode <- readIORef curNodePtr
+>    ; case curNode of
+>        Null -> return False  -- we've reached the end of the list
+>                              -- element not found
+>        Node {val = curval, next = nextNode} ->
+>          if (curval /= i) 
+>           then delete2 curNodePtr i         -- keep searching
+>           else 
+>               -- delete element (ie delink node)
+>               do { case prevNode of
+>                      Head {} -> do writeIORef prevPtr (Head {next = nextNode})
+>                                    return True
+>                      Node {} -> do writeIORef prevPtr
+>                                       (Node {val = val prevNode, next = nextNode})
+>                                    return True
+>                  }
+>     }
diff --git a/testsuite/tests/eyeball/Makefile b/testsuite/tests/eyeball/Makefile
new file mode 100644
index 0000000000..9a36a1c5fe
--- /dev/null
+++ b/testsuite/tests/eyeball/Makefile
@@ -0,0 +1,3 @@
+TOP=../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/eyeball/README b/testsuite/tests/eyeball/README
new file mode 100644
index 0000000000..14516604f6
--- /dev/null
+++ b/testsuite/tests/eyeball/README
@@ -0,0 +1,5 @@
+These tests are hard to test automatically, but
+they are intended to let you eyeball the results.
+
+Often they are referred to from comments in the
+source code.
diff --git a/testsuite/tests/eyeball/T3116.hs b/testsuite/tests/eyeball/T3116.hs
new file mode 100644
index 0000000000..ba2439c897
--- /dev/null
+++ b/testsuite/tests/eyeball/T3116.hs
@@ -0,0 +1,34 @@
+{-# OPTIONS -O2 -XBangPatterns #-}
+
+-- The thing to look for here is that the implementation
+-- of 'length' does not allocate in the inner loop
+--
+-- See Trac #3116
+
+module T3116 where
+
+import Foreign
+
+data SByteString
+   = BS  {-# UNPACK #-} !(ForeignPtr Word8)  -- payload
+         {-# UNPACK #-} !Int                 -- offset
+         {-# UNPACK #-} !Int                 -- length
+
+data ByteString
+    =  Empty
+    |  Chunk {-# UNPACK #-} !SByteString ByteString
+
+bnull :: ByteString -> Bool
+bnull Empty = True
+bnull _     = False
+
+btail :: ByteString -> ByteString
+btail Empty = error "empty tail"
+btail (Chunk (BS fp s 1) cs) = cs
+btail (Chunk (BS fp s l) cs) = Chunk (BS fp (s+1) (l-1)) cs
+
+length :: ByteString -> Int
+length = go 0
+  where
+    go !n bs  | bnull bs   = n
+              | otherwise  = go (n+1) (btail bs)
diff --git a/testsuite/tests/eyeball/dead1.hs b/testsuite/tests/eyeball/dead1.hs
new file mode 100644
index 0000000000..108dc8491b
--- /dev/null
+++ b/testsuite/tests/eyeball/dead1.hs
@@ -0,0 +1,42 @@
+{-# OPTIONS -fglasgow-exts -O -ddump-stranal #-}
+
+module Foo(foo) where
+
+foo :: Int -> Int
+foo n = baz (n+1) (bar1 n)
+
+{-# NOINLINE bar1 #-}
+bar1 n = 1 + bar n
+
+bar :: Int -> Int
+{-# NOINLINE bar #-}
+{-# RULES
+"bar/foo" forall n. bar (foo n) = n
+   #-}
+bar n = n-1
+
+baz :: Int -> Int -> Int
+{-# INLINE [0] baz #-}
+baz m n = m
+
+
+{- Ronam writes (Feb08)
+
+    Note that bar becomes dead as soon as baz gets inlined. But strangely,
+    the simplifier only deletes it after full laziness and CSE. That is, it
+    is not deleted in the phase in which baz gets inlined. In fact, it is
+    still there after w/w and the subsequent simplifier run. It gets deleted
+    immediately if I comment out the rule.
+
+    I stumbled over this when I removed one simplifier run after SpecConstr
+    (at the moment, it runs twice at the end but I don't think that should
+    be necessary). With this change, the original version of a specialised
+    loop (the one with the rules) is not longer deleted even if it isn't
+    used any more. I'll reenable the second simplifier run for now but
+    should this really be necessary?
+
+No, it should not be necessary.  A refactoring in OccurAnal makes
+this work right. Look at the simplifier output just before strictness
+analysis; there should be a binding for 'foo', but for nothing else.
+
+-}
diff --git a/testsuite/tests/eyeball/dmd-on-polymorphic-floatouts.hs b/testsuite/tests/eyeball/dmd-on-polymorphic-floatouts.hs
new file mode 100644
index 0000000000..fa411e23f2
--- /dev/null
+++ b/testsuite/tests/eyeball/dmd-on-polymorphic-floatouts.hs
@@ -0,0 +1,23 @@
+{-# OPTIONS_GHC -fglasgow-exts -O -ddump-prep #-}
+module Max(result) where
+
+foo ys = foldr (\x xs -> x : reverse xs) [] ys
+
+result xs = 
+    let stuff = [1, 1, 1, 1, 1, 1]
+    in foo (reverse stuff)
+
+-- What used to happen is that foldr got expanded by main simplification
+-- and the resulting "go" function got floated out but because we manufactured 
+-- a new binder for it in newPolyBndrs we would lose its demand signature! 
+-- This means that the later application of it in result did not use call by value :-(
+
+-- Eyeball test:
+--  Ensure that Max.poly_go has a demand signature
+--  Ensure that we use call by value to call Max.poly_go in result 
+--	i.e. the call to Max.poly_go inside Max.result looks like this:
+--
+-- case GHC.List.poly_rev @ t1_a6x sat_seb (GHC.Base.[] @ t1_a6x)
+--        of sat_sed { __DEFAULT ->
+--        Max.poly_go @ t1_a6x sat_sed
+--        } } in
diff --git a/testsuite/tests/eyeball/inline1.hs b/testsuite/tests/eyeball/inline1.hs
new file mode 100644
index 0000000000..8e58652db6
--- /dev/null
+++ b/testsuite/tests/eyeball/inline1.hs
@@ -0,0 +1,37 @@
+{-# OPTIONS_GHC -fglasgow-exts -O -ddump-simpl -fno-method-sharing #-}
+module Roman where
+
+import Control.Monad.ST
+
+newtype T s a = T { unT :: Int -> ST s a }
+
+instance Monad (T s) where
+   return = T . const . return
+   T p >>= f = T $ \i -> do { x <- p i
+  			    ; unT (f x) i }
+
+myIndex :: T s Int
+{-# INLINE myIndex #-}
+myIndex = T return
+
+foo :: T s Int
+foo = do { x <- myIndex
+         ; return (x + 1) }
+
+
+{-   At one stage we got code looking like this:
+
+    U.a3 =
+       \ (@ s_a8E) (i_shA :: GHC.Base.Int) (eta_shB :: GHC.Prim.State# s_a8E) ->
+         case ((((U.myIndex @ s_a8E)
+                 `cast` ...)
+                  i_shA)
+               `cast` ...)
+                eta_shB
+         of wild_si5 { (# new_s_shF, r_shG #) -> ...
+
+    U.foo :: forall s_a5S. U.T s_a5S GHC.Base.Int
+    U.foo = U.a3 `cast` ...
+
+
+The point is that myIndex should be inlined, else code is bad -}
\ No newline at end of file
diff --git a/testsuite/tests/eyeball/inline2.hs b/testsuite/tests/eyeball/inline2.hs
new file mode 100644
index 0000000000..45bb04bf8b
--- /dev/null
+++ b/testsuite/tests/eyeball/inline2.hs
@@ -0,0 +1,40 @@
+{-# OPTIONS -fglasgow-exts -O -dshow-passes #-}
+
+module Foo where
+import GHC.Base
+
+foo :: Int -> Int
+foo (I# n#) = bar i i
+   where i# = n# +# 1#
+         i  = I# i#
+
+bar :: Int -> Int -> Int
+{-# INLINE [0] bar #-}
+bar _ n = n
+
+{-   The trouble here was 
+
+    *** Simplify:
+         Result size = 25
+         Result size = 25
+         Result size = 25
+         Result size = 25
+         Result size = 25
+    *** Simplify:
+         Result size = 25
+         Result size = 25
+         Result size = 25
+         Result size = 25
+         Result size = 25
+
+
+    etc.  
+
+The reason was this:
+	x = n# +# 1#
+ 	i = I# x
+
+Being an unboxed value, we were treating the argument context of x
+as intersting, and hence inlining x in the arg of I#. But then we just
+float it out again, giving an infinite loop.
+-}
diff --git a/testsuite/tests/eyeball/inline3.hs b/testsuite/tests/eyeball/inline3.hs
new file mode 100644
index 0000000000..1bde5f722a
--- /dev/null
+++ b/testsuite/tests/eyeball/inline3.hs
@@ -0,0 +1,35 @@
+{-# OPTIONS_GHC -fglasgow-exts -O -ddump-simpl #-}
+module Roman where
+
+foo :: Int -> Maybe Int -> Int
+foo 0 (Just n) = n
+foo 0 Nothing  = 1
+foo n p = let f = foo (n-1+n-1+n-1+n-1+n-1+n-1+n-1+n-1)
+           in
+           case p of { Just m -> f (Just m); Nothing -> f Nothing }
+
+
+{-  At one time this oddly produced;
+
+     foo = \n p ->
+          case n of ds {
+            __DEFAULT ->
+              let
+                x = ds -# 1 +# ds -# 1 +# ds -# 1 +# ds -# 1 +# ds -# 1
+              in
+              case p of {
+                Nothing ->
+                  foo (x +# ds -# 1 +# ds -# 1 +# ds -# 1) Nothing
+                ;
+                Just m ->
+                  foo (x +# ds -# 1 +# ds -# 1 +# ds -# 1) (Just m)
+              };
+            0 ->
+              case p of {
+                Nothing -> lvl_sbC; Just n -> n
+              }
+          }
+
+But it shouldn't; and doesn't now.
+
+-}
diff --git a/testsuite/tests/eyeball/inline4.hs b/testsuite/tests/eyeball/inline4.hs
new file mode 100644
index 0000000000..2648c9e039
--- /dev/null
+++ b/testsuite/tests/eyeball/inline4.hs
@@ -0,0 +1,40 @@
+module CmmTx where

+

+data TxRes a = TxRes Bool a

+

+instance Monad TxRes where

+    return = TxRes False

+

+{-  Here you can get a simplifier loop thus:

+NOTE: Simplifier still going after 4 iterations; bailing out.  Size = 52

+NOTE: Simplifier still going after 4 iterations; bailing out.  Size = 52

+NOTE: Simplifier still going after 4 iterations; bailing out.  Size = 52

+NOTE: Simplifier still going after 4 iterations; bailing out.  Size = 52

+

+Reason: 'a' is inline (not pre/post unconditionally; just ordinary inlining)

+Then, since ($dm>>) has arity 3, the rhs of (>>) is a PAP, so the arg is

+floated out, past the big lambdas.

+

+See Note [Unsaturated functions] in SimplUtils 

+

+------------------------------------------------------------

+a_s9f{v} [lid] =

+  base:GHC.Base.:DMonad{v r5} [gid]

+    @ main:CmmTx.TxRes{tc rd}

+    >>={v a6E} [lid]

+    >>{v a6H} [lid]

+    return{v a6J} [lid]

+    fail{v a6M} [lid]

+>>{v a6H} [lid] [ALWAYS LoopBreaker Nothing] :: forall a{tv a6F} [tv]

+                                                       b{tv a6G} [tv].

+                                                main:CmmTx.TxRes{tc rd} a{tv a6F} [tv]

+                                                -> main:CmmTx.TxRes{tc rd} b{tv a6G} [tv]

+                                                -> main:CmmTx.TxRes{tc rd} b{tv a6G} [tv]

+[Arity 2

+ Str: DmdType LL]

+>>{v a6H} [lid] =

+  \ (@ a{tv a78} [sk] :: ghc-prim:GHC.Prim.*{(w) tc 34d})

+    (@ b{tv a79} [sk] :: ghc-prim:GHC.Prim.*{(w) tc 34d}) ->

+    base:GHC.Base.$dm>>{v r5f} [gid]

+      @ main:CmmTx.TxRes{tc rd} a_s9f{v} [lid] @ a{tv a78} [sk] @ b{tv a79} [sk]

+ -}

diff --git a/testsuite/tests/eyeball/record1.hs b/testsuite/tests/eyeball/record1.hs
new file mode 100644
index 0000000000..1f9084b7a6
--- /dev/null
+++ b/testsuite/tests/eyeball/record1.hs
@@ -0,0 +1,17 @@
+-- Check that the record selector for maskMB unfolds in the body of f

+-- At one stage it didn't because the implicit unfolding looked too big

+

+-- Trac #2581

+

+module ShouldCompile where

+import Data.Array.Base

+

+data MBloom s a = MB {

+     shiftMB :: {-# UNPACK #-} !Int

+    , maskMB :: {-# UNPACK #-} !Int

+    , bitArrayMB :: {-# UNPACK #-} !(STUArray s Int Int)

+    }

+

+f a b c = case maskMB (MB a b c) of 

+	    3 -> True

+	    _ -> False

diff --git a/testsuite/tests/eyeball/spec-constr1.hs b/testsuite/tests/eyeball/spec-constr1.hs
new file mode 100644
index 0000000000..a14442035b
--- /dev/null
+++ b/testsuite/tests/eyeball/spec-constr1.hs
@@ -0,0 +1,36 @@
+{-# OPTIONS_GHC -O2 -ddump-simpl  #-}
+module Roman where
+
+{- From: Roman Leshchinskiy [mailto:rl@cse.unsw.edu.au] 
+   Sent: 07 February 2008 03:34
+   Subject: Quadratic SpecConstr 
+
+Here is a program which makes SpecConstr generate a quadratic number of
+iterations:
+-}
+
+
+bar :: Int -> Int -> Int
+bar m n = foo n (n,n) (n,n) (n,n) (n,n)
+   where
+     foo :: Int -> (Int,Int) -> (Int,Int) -> (Int,Int) -> (Int,Int) -> Int
+     foo n p q r s
+       | n == 0    = m
+       | n > 3000  = case p of { (p1,p2) -> foo (n-1) (p2,p1) q r s }
+       | n > 2000  = case q of { (q1,q2) -> foo (n-1) p (q2,q1) r s }
+       | n > 1000  = case r of { (r1,r2) -> foo (n-1) p q (r2,r1) s }
+       | otherwise = case s of { (s1,s2) -> foo (n-1) p q r (s2,s1) }
+
+{- For this particular function, I get 14 specialisations, one for each
+   possible combination of arguments.
+ 
+   However, since we can see all the call sites outside the loop, we could
+   use that to 'seed' the specialisation, and get just one specialisation.
+-}
+
+
+-- Eyeball guidance: 
+-- 	There should be just one specialisation for foo
+-- 	Indeed, the original function should disappear,
+--		since it isn't used
+	
diff --git a/testsuite/tests/eyeball/state-hack.hs b/testsuite/tests/eyeball/state-hack.hs
new file mode 100644
index 0000000000..439bf78202
--- /dev/null
+++ b/testsuite/tests/eyeball/state-hack.hs
@@ -0,0 +1,19 @@
+-- The question here is whether f gets eta-expanded
+-- (assuming the state hack).  It should, but
+-- didn't in GHC 6.10
+
+module Foo where
+
+import GHC.Base
+
+{-# NOINLINE z #-}
+z :: State# a -> Bool
+z s = True
+
+{-# NOINLINE k #-}
+k :: Int -> State# a -> Bool
+k y s = False
+
+
+f []     = z
+f (x:xs) = k (length xs)