[project @ 2001-06-20 15:11:17 by sewardj]

All your codeGen tests are belong to me.  Well, the should_run ones,
at least.

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

+
+include ($confdir ++ "/../vanilla-test.T")
+
+-- Args to vt are: extra compile flags
+--                 extra run flags
+--                 expected process return value, if not zero
+
+test "cg001" { vt("", "", "") }
+test "cg002" { vt("", "", "") }
+test "cg003" { vt("", "", "") }
+test "cg004" { vt("", "", "") }
+test "cg005" { vt("", "", "") }
+test "cg006" { vt("", "", "") }
+test "cg007" { vt("", "", "") }
+test "cg008" { vt("", "", "") }
+test "cg009" { vt("", "", "") }
+test "cg010" { vt("", "", "") }
+test "cg011" { vt("", "", "") }
+test "cg012" { vt("-fglasgow-exts", "", "") }
+test "cg013" { vt("", "", "") }
+test "cg014" { vt("", "", "") }
+test "cg015" { vt("-fglasgow-exts", "", "") }
+test "cg016" { vt("", "", "1") }
+test "cg017" { vt("", "", "") }
+test "cg018" { vt("-fglasgow-exts", "", "") }
+test "cg019" { vt("", "", "") }
+test "cg020" { vt("", "", "") }
+test "cg021" { vt("", "", "") }
+test "cg022" { vt("", "", "") }
+test "cg023" { vt("", "", "") }
+test "cg024" { vt("", "", "") }
+test "cg025" { vt("-package lang -package text", "", "1") }
+test "cg026" { vt("-package lang -fglasgow-exts -fvia-C", "", "") }
+test "cg027" { vt("", "", "") }
+test "cg028" { vt("", "", "") }
+test "cg029" { vt("-package lang -fglasgow-exts", "", "") }
+test "cg030" { vt("-package lang -fglasgow-exts", "", "") }
+test "cg031" { vt("-fglasgow-exts", "", "") }
+test "cg032" { vt("-fglasgow-exts", "", "") }
+test "cg033" { vt("-fglasgow-exts", "", "") }
+test "cg034" { vt("", "", "") }
+test "cg035" { vt("-package lang -fglasgow-exts", "", "") }
+test "cg036" { vt("", "", "") }
+test "cg037" { vt("", "", "") }
+test "cg038" { vt("", "", "") }
+test "cg039" { vt("", "", "") }
+test "cg040" { vt("", "", "") }
+test "cg041" { vt("", "", "") }
+test "cg042" { vt("-package lang -fglasgow-exts", "", "") }
+test "cg043" { vt("", "", "") }
+test "cg044" { vt("-package lang", "", "" ) }
+
+-- tmp, until we fix the problems with seq#...
+test "cg045" { vt( "-O", "", "1") }
+test "cg046" { vt("", "", "") }
+test "cg047" { vt("", "", "") }
+test "cg048" { vt("", "", "") }
+test "cg049" { vt( "-funbox-strict-fields", "", "") }

testsuite/tests/ghc-regress/codeGen/should_run/cg001.hs

+-- !! cg001: main = -42 -- take 1
+
+main = print ( f () )
+     where
+	f :: a -> Int
+	f x = -42

testsuite/tests/ghc-regress/codeGen/should_run/cg001.stdout

+-42

testsuite/tests/ghc-regress/codeGen/should_run/cg002.hs

+main = print ((f id2) (10 + thirty_two))
+  where
+    f x = g x
+      where
+        g x = h x
+	  where
+	    h x = x
+
+    thirty_two :: Int
+    thirty_two = 32
+
+id2 x = x

testsuite/tests/ghc-regress/codeGen/should_run/cg002.stdout

+42

testsuite/tests/ghc-regress/codeGen/should_run/cg003.hs

+main = print (id2 (id2 id2) (42::Int))
+--	where
+--	id2 = s k k
+
+-- id2 x = s k k x
+
+id2 = s k k
+
+s x y z = x z (y z)
+
+k x y = x

testsuite/tests/ghc-regress/codeGen/should_run/cg003.stdout

+42

testsuite/tests/ghc-regress/codeGen/should_run/cg004.hs

+main = print (length ([9,8,7,6,5,4,3,2,1] :: [Int]))

testsuite/tests/ghc-regress/codeGen/should_run/cg004.stdout

+9

testsuite/tests/ghc-regress/codeGen/should_run/cg005.hs

+-- !! answer: 65532
+
+main = print foo
+
+foo :: Int
+foo = ((1 + 2 + 32767 - 4) * 6) --later? `div` 3

testsuite/tests/ghc-regress/codeGen/should_run/cg005.stdout

+196596

testsuite/tests/ghc-regress/codeGen/should_run/cg006.hs

+main = print (length thirteen_ones)
+     where
+	thirteen_ones	= take (13::Int) ones
+
+	ones :: [Int]
+	ones		= 1 : ones

testsuite/tests/ghc-regress/codeGen/should_run/cg006.stdout

+13

testsuite/tests/ghc-regress/codeGen/should_run/cg007.hs

+data Tree a = Leaf a | Branch (Tree a) (Tree a)
+
+main = print (height our_tree)
+    where
+      our_tree :: Tree Int
+      our_tree =
+	Branch (Branch (Leaf 1) (Branch (Branch (Leaf 1) (Leaf 1)) (Leaf 1)))
+	       (Branch (Leaf 1) (Leaf 1))
+
+
+height :: Tree a -> Int
+
+height (Leaf _)		= 1
+height (Branch t1 t2)	= 1 + max (height t1) (height t2)

testsuite/tests/ghc-regress/codeGen/should_run/cg007.stdout

+5

testsuite/tests/ghc-regress/codeGen/should_run/cg008.hs

+main = print (length comp_list)
+ where
+    comp_list :: [(Int,Int)]
+    comp_list = [ (elem1,elem2)
+		| elem1 <- given_list,
+		  elem2 <- given_list,
+		  elem1 >= (4::Int),
+		  elem2 <  (3::Int)
+		]
+
+    given_list :: [Int]
+    given_list = [1,2,3,4,5,6,7,8,9]

testsuite/tests/ghc-regress/codeGen/should_run/cg008.stdout

+12

testsuite/tests/ghc-regress/codeGen/should_run/cg009.hs

+main = print (length take_list)
+ where
+    take_list :: [Int]
+    take_list = takeWhile (\ x -> x < 6) given_list
+
+    given_list :: [Int]
+    given_list = [1,2,3,4,5,6,7,8,9]

testsuite/tests/ghc-regress/codeGen/should_run/cg009.stdout

+5

testsuite/tests/ghc-regress/codeGen/should_run/cg010.hs

+main = print a
+  where
+    a :: Int
+    b :: Int
+    (a, b) = (3 + 4, 5 + 6)

testsuite/tests/ghc-regress/codeGen/should_run/cg010.stdout

+7

testsuite/tests/ghc-regress/codeGen/should_run/cg011.hs

+-- !!! simple overloading example
+
+class Foo a where
+    foo :: a -> a -> Bool
+
+class (Foo a) => Bar a where
+    bar :: a -> a -> Bool
+
+instance Foo Int where
+    foo a b = a /= b
+
+instance Foo Bool where
+    foo a b = a /= b
+
+instance Bar Int where
+    bar a b = a < b
+
+instance Bar Bool where
+    bar a b = a < b
+
+foO = if bar (2::Int) (3::Int) then
+	    if bar False True then
+	    	(42::Int)
+	    else
+		(888::Int)
+       else
+	  (999::Int)
+
+main = print foO

testsuite/tests/ghc-regress/codeGen/should_run/cg011.stdout

+42

testsuite/tests/ghc-regress/codeGen/should_run/cg012.hs

+-- !!! move arguments around on the stacks, mainly the B stack
+
+import PrelBase	( Float#, Double#, Int#, Int(..) )
+
+
+main = print foo
+
+foo = I#
+	( f 1.1##
+	    2.1#
+	    True
+	    3.1##
+	    4.1#
+	    5.1##
+	    6.1##
+	    42#	-- the answer!
+	    7.1#
+	    8.1# )
+    where
+      f :: Double# -> Float# -> Bool -> Double# -> Float#
+	-> Double# -> Double# -> Int# -> Float# -> Float#
+	-> Int#
+      f b1 s2 t b3 s4 b5 b6 i42 s7 s8
+	-- evens, then odds
+	= g s2 b3 b5 i42 s8 b1 t s4 b6 s7
+
+      g :: Float# -> Double# -> Double# -> Int# -> Float#
+        -> Double# -> Bool -> Float# -> Double# -> Float#
+	-> Int#
+      g s2 b3 b5 i42 s8 b1 t s4 b6 s7
+	-- powers of 2 backwards, then others forwards
+	= h s7 b6 t b5 s2 b3 i42 s8 b1 s4
+
+      h :: Float# -> Double# -> Bool -> Double# -> Float#
+        -> Double# -> Int# -> Float# -> Double# -> Float#
+	-> Int#
+      h s7 b6 t b5 s2 b3 i42 s8 b1 s4
+	= i42

testsuite/tests/ghc-regress/codeGen/should_run/cg012.stdout

+42

testsuite/tests/ghc-regress/codeGen/should_run/cg013.hs

+{-
+From: Kevin Hammond <kh>
+To: partain
+Subject: Nasty Overloading
+Date: Wed, 23 Oct 91 16:19:46 BST
+-}
+module Main where
+
+class Foo a where
+	o1 :: a -> a -> Bool
+	o2 :: a -> Int
+
+--	o2 :: Int
+    -- Lennart: The type of method o2 does not contain the variable a
+    -- (and it must according to line 1 page 29 of the manual).
+
+class Foo tyvar => Bar tyvar where
+	o3 :: a -> tyvar -> tyvar
+
+-- class (Eq a, Foo a) => Baz a where
+class (Ord a, Foo a) => Baz a where
+	o4 :: a -> a -> (String,String,String,a)
+
+instance (Ord a, Foo a) =>  Foo [a] where
+	o2 x = 100
+	o1 a b = a < b || o1 (head a) (head b)
+
+-- instance Bar [a] where
+instance (Ord a, Foo a) => Bar [a] where
+	o3 x l = []
+    --
+    -- Lennart: I guess the instance declaration 
+    -- 	instance Bar [w] where
+    -- 		o3 x l = []
+    -- is wrong because to be a Bar you have to be a Foo.  For [w] to
+    -- be a Foo, w has to be Ord and Foo.  But w is not Ord or Foo in
+    -- this instance declaration so it must be wrong.  (Page 31, line
+    -- 7: The context c' must imply ...)
+
+instance Baz a => Baz [a] where
+ 	o4 [] [] = ("Nil", "Nil", "Nil", [])
+	o4 l1 l2 = 
+		(if o1 l1 l2 then "Y" else "N",
+		 if l1 == l2 then "Y" else "N",
+--		 if o4 (head l1) (head l2) then "Y" else "N",
+		 case o4 (head l1) (head l2) of
+			(_,_,_,l3) -> if (o1 (head l1) l3) then "Y" else "N",
+		 l1 ++ l2 )
+
+instance Foo Int where
+	o2 x = x
+	o1 i j = i == j
+
+instance Bar Int where
+	o3 _ j = j + 1
+
+instance Baz Int where
+--	o4 i j = i > j
+	o4 i j = (if i>j then "Y" else "Z", "p", "q", i+j)
+--simpl:o4 i j = ("Z", "p", "q", i+j)
+
+{- also works w/ glhc! -}
+
+main =  if o4 [1,2,3] [1,3,2::Int] /= ("Y","N","Y",[1,2,3,1,3,2]) then
+		(print "43\n") 
+	else	(print "144\n")
+
+{- works: glhc
+main =  case o4 [1,2,3] [1,3,2::Int] of
+		(s1,s2,s3,x) -> print s1
+
+main =  case o4 ([]::[Int]) ([]::[Int]) of
+		(s1,s2,s3,x) -> print s1
+-}
+
+{- simple main: breaks nhc, works w/ glhc 
+main = case o4 (3::Int) (4::Int) of (s1,s2,s3,x) -> print s1
+-}

testsuite/tests/ghc-regress/codeGen/should_run/cg013.stdout

+"43\n"

testsuite/tests/ghc-regress/codeGen/should_run/cg014.hs

+-- !! cg014: main = -42 -- twice: in Float and Double
+
+main = print ((show ( (-42) :: Float )) ++ " " ++ (show ( (-42) :: Double )) ++ "\n")

testsuite/tests/ghc-regress/codeGen/should_run/cg014.stdout

+"-42.0 -42.0\n"

testsuite/tests/ghc-regress/codeGen/should_run/cg015.hs

+module Main ( main ) where
+
+import PrelBase
+
+data CList = CNil | CCons Int# CList
+
+mk :: Int# -> CList
+mk n  = if (n ==# 0#)
+	then CNil
+	else CCons 1# (mk (n -# 1#))
+
+clen :: CList -> Int#
+clen CNil = 0#
+clen (CCons _ cl) = 1# +# (clen cl)
+
+main = case (clen list4) of
+		len4 ->
+		  case (len4 +# len4) of
+		    8# -> finish 65#	-- 'A'
+		    _  -> finish 66#	-- 'B'
+      where
+      list4	= mk 4#
+
+finish :: Int# -> IO ()
+finish n = _ccall_ putchar (C# (chr# n)) >> return ()

testsuite/tests/ghc-regress/codeGen/should_run/cg015.stdout

+A
\ No newline at end of file

testsuite/tests/ghc-regress/codeGen/should_run/cg016.hs

+-- !!! tests calls of `error' (that make calls of `error'...)
+--
+main = error ("1st call to error\n"++(
+       error ("2nd call to error\n"++(
+       error ("3rd call to error\n"++(
+       error ("4th call to error\n"++(
+       error ("5th call to error\n"++(
+       error ("6th call to error"
+       )))))))))))

testsuite/tests/ghc-regress/codeGen/should_run/cg016.stderr

+
+Fail: 6th call to error

testsuite/tests/ghc-regress/codeGen/should_run/cg017.hs

+-- !!! test of cyclic default methods
+--
+class Foo a where
+    op1 :: Fractional b => a -> b -> Bool
+    op2 :: Fractional b => a -> b -> Bool
+    op3 :: Fractional b => a -> b -> Bool
+    op4 :: Fractional b => a -> b -> Bool
+    op5 :: Fractional b => a -> b -> Bool
+    op6 :: Fractional b => a -> b -> Bool
+
+    -- each depends on the next:
+    op1 a b = not (op2 a b)
+    op2 a b = not (op3 a b)
+    op3 a b = not (op4 a b)
+    op4 a b = not (op5 a b)
+    op5 a b = not (op6 a b)
+    op6 a b = not (op1 a b)
+
+-- now some instance decls to break the cycle:
+instance Foo Int where
+    op1 a b = a == 42
+
+instance Foo Char where
+    op1 a b = a == 'c'
+
+instance Foo a => Foo [a] where
+    op1 a b = null a
+
+-- try it:
+main = do
+    putStr (show (op2 (3::Int)    3.14159))
+    putStr (show (op2 'X' 	  3.14159))
+    putStr (show (op2 ([]::[Char])3.14159))

testsuite/tests/ghc-regress/codeGen/should_run/cg017.stdout

+TrueTrueFalse
\ No newline at end of file

testsuite/tests/ghc-regress/codeGen/should_run/cg018.hs

+-- !!! test of datatype with many unboxed fields
+--
+import PrelGHC( Float# )
+import PrelFloat
+
+main = print (selectee1 + selectee2)
+
+data Tfo = Tfo Float# Float# Float# Float# Float# Float# Float# Float# Float# Float# Float# Float#
+
+yyy = (Tfo (-0.0018#)  (-0.8207#)   (0.5714#)
+            (0.2679#)  (-0.5509#)  (-0.7904#)
+            (0.9634#)   (0.1517#)   (0.2209#)
+            (0.0073#)   (8.4030#)   (0.6232#))
+
+xxx = (Tfo (-0.8143#)  (-0.5091#)  (-0.2788#)
+           (-0.0433#)  (-0.4257#)   (0.9038#)
+           (-0.5788#)   (0.7480#)   (0.3246#)
+            (1.5227#)   (6.9114#)  (-7.0765#))
+
+selectee1 = F# (case xxx of
+		  Tfo _ _ _ _ _ _ _ x _ _ _ _ -> x)
+
+selectee2 = F# (case xxx of
+		  Tfo _ _ y _ _ _ _ _ _ _ _ _ -> y)

testsuite/tests/ghc-regress/codeGen/should_run/cg018.stdout

+0.46920002

testsuite/tests/ghc-regress/codeGen/should_run/cg019.hs

+-- !!! printing of floating-pt numbers
+--
+main = print (1.234e5 :: Float)

testsuite/tests/ghc-regress/codeGen/should_run/cg019.stdout

+123400.0

testsuite/tests/ghc-regress/codeGen/should_run/cg020.hs

+-- !!! reading/showing of Ints/Integers
+--
+main = print ((read "-1") :: Integer)

testsuite/tests/ghc-regress/codeGen/should_run/cg020.stdout

+-1

testsuite/tests/ghc-regress/codeGen/should_run/cg021.hs

+-- !!! Tests garbage collection in the branch of a case
+-- !!!	alternative where the constructor is returned in the heap.
+
+{- This is also a rather stressful test for another reason.
+   The mutual recursion between munch and f causes lots of
+   closures to be built, of the form (munch n s), for some n and s.
+   Now, all of these closures are entered and each has as its value
+   the result delivere by the next; so the result is that there is
+   a massive chain of identical updates.
+
+   As it turns out, they are mostly garbage, so the GC could eliminate
+   them (though this isn't implemented at present), but that isn't
+   necessarily the case.  
+
+   The only correct solution is to spot that the updates are all
+   updating with the same value (update frames stacked on top of each
+   other), and update all but one with indirections to the last
+   remaining one.  This could be done by GC, or at the moment the
+   frame is pushed.
+
+   Incidentally, hbc won't have this particular problem, because it
+   updates immediately.
+
+   NOTE: [March 97]  Now that stack squeezing happens when GC happens,
+   the stack is squished at GC.  So this program uses a small stack
+   in a small heap (eg 4m heap 2m stack), but in a big heap (no GC)
+   it needs a much bigger stack (10m)!  It would be better to try GC/stack
+   squeezing on stack oflo.
+-}
+
+module Main where
+
+main = munch 100000 (inf 3)
+
+data Stream a
+  = MkStream a a a a a a a a a (Stream a)
+  | Empty
+
+inf :: Int -> Stream Int
+inf n = MkStream n n n n n n n n n (inf n)
+
+munch :: Int -> Stream a -> IO ()
+
+munch n Empty = return () -- error "this never happens!\n"
+    -- this first equation mks it non-strict in "n"
+    -- (NB: call the "error" makes it strict)
+
+munch 0 _ = putStr "I succeeded!\n"
+munch n s = case (f n s) of
+	      (True, rest) -> rest
+	      (False, _)   -> error "this never happens either\n"
+
+--f :: Int -> Stream a -> (Bool, [Request])
+
+f n (MkStream _ _ _ _ _ _ _ _ _ rest)
+  = -- garbage collection *HERE*, please!
+    -- (forced by the closure for n-1)
+    (True, munch (n - 1) rest)
+
+-- munch and f are mutually recursive, just to be nasty

testsuite/tests/ghc-regress/codeGen/should_run/cg021.stdout

+I succeeded!

testsuite/tests/ghc-regress/codeGen/should_run/cg022.hs

+-- !!! tests stack stubbing: if "f" doesn't stub "ns",
+-- !!! the program has a space leak.
+
+module Main where
+
+main = f (putStr "a")
+	 (take 1000000 (repeat True))
+	 (putStr "b")
+
+f a ns b = if last ns then a else b

testsuite/tests/ghc-regress/codeGen/should_run/cg022.stdout

+a
\ No newline at end of file

testsuite/tests/ghc-regress/codeGen/should_run/cg023.stdout

+False
\ No newline at end of file

testsuite/tests/ghc-regress/codeGen/should_run/cg024.hs

+-- !!! test super-dictionary grabification
+--
+
+main = putStr (show (is_one (1.2::Double)))
+
+is_one :: RealFloat a => a -> Bool
+
+is_one x = x == 1.0

testsuite/tests/ghc-regress/codeGen/should_run/cg024.stdout

+False
\ No newline at end of file

testsuite/tests/ghc-regress/codeGen/should_run/cg025.hs

+-- !!! test various I/O Requests
+--
+--
+import IO
+import System
+import IOExts (trace)
+import RegexString
+import Maybe
+
+main = do
+    prog <- getProgName
+    let Just (name:_) = matchRegex (mkRegex ".*(cg025.bin)") prog
+    hPutStr stderr (shows name "\n")