diff options
Diffstat (limited to 'testsuite/tests/stranal')
42 files changed, 464 insertions, 0 deletions
diff --git a/testsuite/tests/stranal/Makefile b/testsuite/tests/stranal/Makefile new file mode 100644 index 0000000000..9a36a1c5fe --- /dev/null +++ b/testsuite/tests/stranal/Makefile @@ -0,0 +1,3 @@ +TOP=../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/stranal/should_compile/Makefile b/testsuite/tests/stranal/should_compile/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/stranal/should_compile/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/stranal/should_compile/T1988.hs b/testsuite/tests/stranal/should_compile/T1988.hs new file mode 100644 index 0000000000..da99806ce1 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/T1988.hs @@ -0,0 +1,12 @@ +{-# OPTIONS_GHC -O2 #-} + +-- Trac #1988: this one killed GHC 6.8.2 +-- at least with -O2 + +module ShouldCompile where + +newtype CFTree = CFTree (String, [CFTree]) + +prCFTree :: CFTree -> String +prCFTree (CFTree (_,trees)) = concatMap ps trees + where ps t@(CFTree (_,[])) = prCFTree t diff --git a/testsuite/tests/stranal/should_compile/all.T b/testsuite/tests/stranal/should_compile/all.T new file mode 100644 index 0000000000..5814f39f7d --- /dev/null +++ b/testsuite/tests/stranal/should_compile/all.T @@ -0,0 +1,18 @@ +# Only compile with optimisation +setTestOpts( only_ways(['optasm']) ) + +test('default', normal, compile, ['']) +test('fact', normal, compile, ['']) +test('fun', normal, compile, ['']) +test('goo', normal, compile, ['']) +test('ins', normal, compile, ['']) +test('map', normal, compile, ['']) +test('sim', normal, compile, ['']) +test('str001', normal, compile, ['']) +test('str002', normal, compile, ['']) +test('syn', normal, compile, ['']) +test('test', normal, compile, ['']) +test('tst', normal, compile, ['']) +test('unu', normal, compile, ['']) +test('newtype', req_profiling, compile, ['-prof -auto-all']) +test('T1988', normal, compile, ['']) diff --git a/testsuite/tests/stranal/should_compile/default.hs b/testsuite/tests/stranal/should_compile/default.hs new file mode 100644 index 0000000000..43eb9f0633 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/default.hs @@ -0,0 +1,16 @@ +module Test where +data Boolean = FF | TT +data Pair a b = MkPair a b +data LList alpha = Nill | Conss alpha (LList alpha) +data Nat = Zero | Succ Nat +data Tree x = Leaf x | Node (Tree x) (Tree x) +data A a = MkA a (A a) + +append :: LList a -> LList a -> LList a +append xs ys = case xs of + Conss z zs -> Conss z (append zs ys) + v -> ys + + + + diff --git a/testsuite/tests/stranal/should_compile/default.stderr b/testsuite/tests/stranal/should_compile/default.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/default.stderr diff --git a/testsuite/tests/stranal/should_compile/fact.hs b/testsuite/tests/stranal/should_compile/fact.hs new file mode 100644 index 0000000000..9f23f9021e --- /dev/null +++ b/testsuite/tests/stranal/should_compile/fact.hs @@ -0,0 +1,3 @@ +module Test where +fact :: Int -> Int +fact n = if n==0 then 2 else (fact n) * n diff --git a/testsuite/tests/stranal/should_compile/fact.stderr b/testsuite/tests/stranal/should_compile/fact.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/fact.stderr diff --git a/testsuite/tests/stranal/should_compile/fun.hs b/testsuite/tests/stranal/should_compile/fun.hs new file mode 100644 index 0000000000..5bab460f3f --- /dev/null +++ b/testsuite/tests/stranal/should_compile/fun.hs @@ -0,0 +1,6 @@ +module Test where +data Fun = MkFun (Fun -> Fun) +data LList a = Nill | Conss a (LList a) + +g :: Fun -> Fun +g f = f diff --git a/testsuite/tests/stranal/should_compile/fun.stderr b/testsuite/tests/stranal/should_compile/fun.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/fun.stderr diff --git a/testsuite/tests/stranal/should_compile/goo.hs b/testsuite/tests/stranal/should_compile/goo.hs new file mode 100644 index 0000000000..00282bb79e --- /dev/null +++ b/testsuite/tests/stranal/should_compile/goo.hs @@ -0,0 +1,10 @@ +module Test where +data Goo a = Gsimpl | Gcompl ([Goo a]) +data Moo a b = Msimple | Mcompl (Moo b a) + + +idGoo :: Goo a -> Goo a +idGoo x = x + +idMoo :: Moo a b -> Moo a b +idMoo x = x diff --git a/testsuite/tests/stranal/should_compile/goo.stderr b/testsuite/tests/stranal/should_compile/goo.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/goo.stderr diff --git a/testsuite/tests/stranal/should_compile/ins.hs b/testsuite/tests/stranal/should_compile/ins.hs new file mode 100644 index 0000000000..a50320cefa --- /dev/null +++ b/testsuite/tests/stranal/should_compile/ins.hs @@ -0,0 +1,27 @@ +-- !! TEST OF DEFACTORISATION FOR FUNCTIONS THAT DROP +-- !! POLYMORPHIC VARIABLES + +module Test where +data Boolean = FF | TT +data Pair a b = MkPair a b +data LList alpha = Nill | Conss alpha (LList alpha) +data Nat = Zero | Succ Nat +data Tree x = Leaf x | Node (Tree x) (Tree x) +data A a = MkA a (A a) + +append :: LList a -> LList a -> LList a +append xs ys = case xs of + Nill -> ys + Conss z zs -> Conss z (append zs ys) + +-- The following function drops @b@. + +flat :: Tree (Pair a b) -> LList a +flat t = case t of + Leaf (MkPair a b) -> Conss a Nill + Node l r -> append (flat l) (flat r) + +fl :: Boolean -> LList Boolean +fl x = flat (Leaf (MkPair TT Zero)) + + diff --git a/testsuite/tests/stranal/should_compile/ins.stderr b/testsuite/tests/stranal/should_compile/ins.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/ins.stderr diff --git a/testsuite/tests/stranal/should_compile/map.hs b/testsuite/tests/stranal/should_compile/map.hs new file mode 100644 index 0000000000..f4ec1ec769 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/map.hs @@ -0,0 +1,32 @@ +module Test where +data Boolean = FF | TT +data Pair a b = MkPair a b +data LList alpha = Nill | Conss alpha (LList alpha) +data Nat = Zero | Succ Nat +data Tree x = Leaf x | Node (Tree x) (Tree x) +data A a = MkA a (A a) + +{- +map :: (a -> b) -> [a] -> [b] +map f xs = case xs of + [] -> [] + (y:ys) -> (f y):(map f ys) + +map_ide :: [[a]] -> [[a]] +map_ide = map (\x->x) +-} + +my_id :: a -> a +my_id x = x + +idNat :: Nat -> Nat +idNat x = x + +idBool :: Boolean -> Boolean +idBool x = x + +fun :: (a->b) -> a -> b +fun f x = g f + where + g f = f x + diff --git a/testsuite/tests/stranal/should_compile/map.stderr b/testsuite/tests/stranal/should_compile/map.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/map.stderr diff --git a/testsuite/tests/stranal/should_compile/newtype.hs b/testsuite/tests/stranal/should_compile/newtype.hs new file mode 100644 index 0000000000..c68df28111 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/newtype.hs @@ -0,0 +1,14 @@ +-- This one killed GHC 6.4 because it bogusly attributed +-- the CPR property to the construtor T +-- Result: a mkWWcpr crash +-- Needs -prof -auto-all to show it up + +module ShouldCompile where + +newtype T a = T { unT :: a } + +f = unT + +test cs = f $ case cs of + [] -> T [] + (x:xs) -> T $ test cs diff --git a/testsuite/tests/stranal/should_compile/sim.hs b/testsuite/tests/stranal/should_compile/sim.hs new file mode 100644 index 0000000000..d6de6ec09d --- /dev/null +++ b/testsuite/tests/stranal/should_compile/sim.hs @@ -0,0 +1,103 @@ +module Test where +data Boolean = FF | TT +data Pair a b = MkPair a b +data LList alpha = Nill | Conss alpha (LList alpha) +data Nat = Zero | Succ Nat +data Tree x = Leaf x | Node (Tree x) (Tree x) +data A a = MkA a (A a) +{- +id :: a -> a +id x = x + +idb :: Boolean -> Boolean +idb b = b + +swap :: Pair a b -> Pair b a +swap t = case t of + MkPair x y -> MkPair y x + +bang :: A (A a) -> Boolean +bang x = case x of + MkA y ys -> TT + +neg :: Boolean -> Boolean +neg b = case b of + FF -> TT + TT -> FF + +null :: LList x -> Boolean +null l = case l of + Nill -> TT + _ -> FF + +loop :: Boolean -> a +loop b = loop b +-} +idl :: LList a -> LList a +idl xs = case xs of + Conss y ys -> Conss y (idl ys) + _ -> Nill +{- +idn :: Nat -> Nat +idn n = case n of + Zero -> Zero + Succ m -> Succ (idn m) + +add :: Nat -> Nat -> Nat +add a b = case a of + Zero -> b + Succ c -> Succ (add c b) + +length :: LList a -> Nat +length xs = case xs of + Nill -> Zero + Conss y ys -> Succ(length ys) + +before :: LList Nat -> LList Nat +before xs = case xs of + Nill -> Nill + Conss y ys -> case y of + Zero -> Nill + Succ n -> Conss y (before ys) + +reverse :: LList a -> LList a +reverse rs = case rs of + Nill -> Nill + Conss y ys -> append (reverse ys) (Conss y Nill) + +f :: Nat -> Nat +f n = case n of + Zero -> Zero + Succ m -> Succ (g m) + +g :: Nat -> Nat +g n = case n of + Zero -> Zero + Succ m -> Succ (f m) + +append :: LList a -> LList a -> LList a +append xs ys = case xs of + Nill -> ys + Conss z zs -> Conss z (append zs ys) + +flatten :: Tree alpha -> LList alpha +flatten t = case t of + Leaf x -> Conss x Nill + Node l r -> append (flatten l) (flatten r) + +sum :: Tree Nat -> Nat +sum t = case t of + Leaf t -> t + Node l r -> add (sum l) (sum r) + +suml :: LList Nat -> Nat +suml Nill = Zero +suml (Conss n ns) = add n (suml ns) + +map :: (a -> b) -> LList a -> LList b +map f xs = case xs of + Nill -> Nill + Conss y ys -> Conss (f y) (map f ys) +-} + + diff --git a/testsuite/tests/stranal/should_compile/sim.stderr b/testsuite/tests/stranal/should_compile/sim.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/sim.stderr diff --git a/testsuite/tests/stranal/should_compile/str001.hs b/testsuite/tests/stranal/should_compile/str001.hs new file mode 100644 index 0000000000..6d27a923fd --- /dev/null +++ b/testsuite/tests/stranal/should_compile/str001.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE DatatypeContexts #-} +module ShouldSucceed where + +{-# OPTIONS -O #-} + +newtype Num a => Point2 a = Point2 (a,a) + +area2 :: Num a => Point2 a -> Point2 a -> Point2 a -> a +area2 (Point2 (px,py)) (Point2 (qx,qy)) (Point2 (rx,ry)) + = (px-qx) * (py-ry) - (py-qy) * (px-rx) diff --git a/testsuite/tests/stranal/should_compile/str001.stderr b/testsuite/tests/stranal/should_compile/str001.stderr new file mode 100644 index 0000000000..968ccf8885 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/str001.stderr @@ -0,0 +1,4 @@ + +str001.hs:1:14: + Warning: -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language. + diff --git a/testsuite/tests/stranal/should_compile/str002.hs b/testsuite/tests/stranal/should_compile/str002.hs new file mode 100644 index 0000000000..65fb8a7ba2 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/str002.hs @@ -0,0 +1,12 @@ +-- !!! Recursive newtypes +-- Needs -O +-- This one made GHC < 5.00.2 go into an +-- infinite loop in the strictness analysier + +module Foo where + +newtype V = MkV V + +f :: V -> V +f (MkV v) = v + diff --git a/testsuite/tests/stranal/should_compile/str002.stderr b/testsuite/tests/stranal/should_compile/str002.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/str002.stderr diff --git a/testsuite/tests/stranal/should_compile/syn.hs b/testsuite/tests/stranal/should_compile/syn.hs new file mode 100644 index 0000000000..6693db70d9 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/syn.hs @@ -0,0 +1,15 @@ +-- !!! THIS TEST IS FOR TYPE SYNONIMS AND FACTORISATION IN THEIR PRESENCE. + +module Test where +data M a = A | B a (M a) +data L a = N | C a (Syn a) +type Syn b = L b + +idL :: L (Syn c) -> L (Syn c) +idL N = N +idL (C x l) = C x (idL l) + +idM:: M (L (Syn x)) -> M (L (Syn x)) +idM A = A +idM (B x l) = B (idL x) (idM l) + diff --git a/testsuite/tests/stranal/should_compile/syn.stderr b/testsuite/tests/stranal/should_compile/syn.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/syn.stderr diff --git a/testsuite/tests/stranal/should_compile/test.hs b/testsuite/tests/stranal/should_compile/test.hs new file mode 100644 index 0000000000..c984c320d1 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/test.hs @@ -0,0 +1,6 @@ +module Test where +data LList t = Nill | Conss t (LList t) +data BBool = TTrue | FFalse + +f Nill = TTrue +f (Conss a as) = FFalse diff --git a/testsuite/tests/stranal/should_compile/test.stderr b/testsuite/tests/stranal/should_compile/test.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/test.stderr diff --git a/testsuite/tests/stranal/should_compile/tst.hs b/testsuite/tests/stranal/should_compile/tst.hs new file mode 100644 index 0000000000..561292107b --- /dev/null +++ b/testsuite/tests/stranal/should_compile/tst.hs @@ -0,0 +1,3 @@ +module Test where +a :: [a] -> [[a]] +a x = [x] diff --git a/testsuite/tests/stranal/should_compile/tst.stderr b/testsuite/tests/stranal/should_compile/tst.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/tst.stderr diff --git a/testsuite/tests/stranal/should_compile/unu.hs b/testsuite/tests/stranal/should_compile/unu.hs new file mode 100644 index 0000000000..54bb25e9ab --- /dev/null +++ b/testsuite/tests/stranal/should_compile/unu.hs @@ -0,0 +1,76 @@ +module Test where +data Boolean = FF | TT +data Pair a b = Mkpair a b +data LList alpha = Nill | Conss alpha (LList alpha) +data Nat = Zero | Succ Nat +data Tree t = Leaf t | Node (Tree t) (Tree t) +data A a = MkA a (A a) +data Foo baz = MkFoo (Foo (Foo baz)) +{- + append1 :: LList a -> LList a -> LList a + append1 xs ys = append2 xs + where + append2 xs = case xs of + Nill -> ys + Conss x xs -> Conss x (append3 xs) + append3 xs = case xs of + Nill -> ys + Conss x xs -> Conss x (append2 xs) + + loop :: a -> a + loop x = loop x + + hd :: LList b -> b + hd Nill = loop + hd (Conss y ys) = y + + hdb :: LList (LList b) -> LList b + hdb = hd + + append :: [a] -> [a] -> [a] + append [] ys = ys + append (x:xs) ys = x:(append xs ys) + + f :: [a] -> [a] + f y = append x (f y) + where x = append x (f y) +-} +app :: LList a -> LList a -> LList a +app Nill Nill = Nill +app xs ys = case xs of + Nill -> ys + Conss z zs -> Conss z (app zs ys) +{- + app :: LList a -> LList a -> LList a + app xs ys = case xs of + Nill -> case ys of + Nill -> Nill + Conss u us -> ap + Conss a as -> ap + where ap = case xs of + Nill -> ys + Conss z zs -> Conss z (app zs ys) + + app :: LList a -> LList a -> LList a + app xs ys = case xs of + Nill -> case ys of + Nill -> Nill + Conss u us -> ap xs ys + Conss a as -> ap xs ys + + ap xs ys = case xs of + Nill -> ys + Conss z zs -> Conss z (app zs ys) + + ap :: LList a -> LList a -> LList a + ap xs ys = case xs of + Nill -> ys + Conss z zs -> Conss z (ap zs ys) + + app :: LList a -> LList a -> LList a + app xs ys = case xs of + Nill -> case ys of + Nill -> Nill + Conss u us -> ap xs ys + Conss a as -> ap xs ys +-} diff --git a/testsuite/tests/stranal/should_compile/unu.stderr b/testsuite/tests/stranal/should_compile/unu.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/unu.stderr diff --git a/testsuite/tests/stranal/should_run/Makefile b/testsuite/tests/stranal/should_run/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/stranal/should_run/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/stranal/should_run/T2756b.hs b/testsuite/tests/stranal/should_run/T2756b.hs new file mode 100644 index 0000000000..cb59d50c9b --- /dev/null +++ b/testsuite/tests/stranal/should_run/T2756b.hs @@ -0,0 +1,15 @@ +module Main where + +data X = X () + +{-# NOINLINE newX #-} +newX :: () -> IO X +newX n = do + let {-# NOINLINE value #-} + value = n + return (X value) + +main = do + x <- newX (error "Why?") + case x of + X _ -> return () diff --git a/testsuite/tests/stranal/should_run/all.T b/testsuite/tests/stranal/should_run/all.T new file mode 100644 index 0000000000..d94a7c492d --- /dev/null +++ b/testsuite/tests/stranal/should_run/all.T @@ -0,0 +1,9 @@ +# Optimised only, we're testing the strictness analyser here +setTestOpts( only_ways(['optasm']) ) + +test('strun001', normal, compile_and_run, ['']) +test('strun002', exit_code(1), compile_and_run, ['']) +test('strun003', normal, compile_and_run, ['']) +test('strun004', normal, compile_and_run, ['']) +test('T2756b', normal, compile_and_run, ['']) + diff --git a/testsuite/tests/stranal/should_run/strun001.hs b/testsuite/tests/stranal/should_run/strun001.hs new file mode 100644 index 0000000000..43820f3028 --- /dev/null +++ b/testsuite/tests/stranal/should_run/strun001.hs @@ -0,0 +1,15 @@ +-- Made the new demand analyser enter an absent arg +-- Reason: it thought 'a' was unused in g. + +module Main where + +-- Strictness: SS(AL) -> T +f True p@(x,y) = (p,y) +f False p@(x,y) = f y p + +-- Easy to get the wrong strictness, +-- by thinking 'a' is absent +g True a b = f False (a,b) +g False a b = g b a b + +main = print (g True 'a' True) diff --git a/testsuite/tests/stranal/should_run/strun001.stdout b/testsuite/tests/stranal/should_run/strun001.stdout new file mode 100644 index 0000000000..9cba23c739 --- /dev/null +++ b/testsuite/tests/stranal/should_run/strun001.stdout @@ -0,0 +1 @@ +(('a',True),True) diff --git a/testsuite/tests/stranal/should_run/strun002.hs b/testsuite/tests/stranal/should_run/strun002.hs new file mode 100644 index 0000000000..145166964d --- /dev/null +++ b/testsuite/tests/stranal/should_run/strun002.hs @@ -0,0 +1,12 @@ +-- This showed up an "entered-absent-arg" error in 5.02.1 + +module Main where + +is_volatile :: [Int] -> (String,Int) -> Int +is_volatile [] (destVarName, destPtr) + = error ("Variable not found: " ++ "(" ++ (show destPtr) ++ ") " ++ destVarName) +is_volatile (a:allWrites) (destVarName, destPtr) + | a == destPtr = a + | otherwise = is_volatile allWrites (destVarName, destPtr) + +main = print (is_volatile [] ("hello",2)) diff --git a/testsuite/tests/stranal/should_run/strun002.stderr b/testsuite/tests/stranal/should_run/strun002.stderr new file mode 100644 index 0000000000..ac89b7f80b --- /dev/null +++ b/testsuite/tests/stranal/should_run/strun002.stderr @@ -0,0 +1 @@ +strun002: Variable not found: (2) hello diff --git a/testsuite/tests/stranal/should_run/strun003.hs b/testsuite/tests/stranal/should_run/strun003.hs new file mode 100644 index 0000000000..eaedd59e8c --- /dev/null +++ b/testsuite/tests/stranal/should_run/strun003.hs @@ -0,0 +1,23 @@ +-- This module should run fine with an empty argument list +-- But it won't if the strictness analyser thinks that 'len' is use +-- strictly, which was the case in GHC 6.0 + +-- See the io_hack_reqd in DmdAnal.lhs + +module Main where + +import System.Environment +import System.Exit + +main = do + args <- getArgs + let len = read (head args) :: Int + + (if null args && useLazily len + then putStrLn "ok" >> exitWith ExitSuccess + else return () ) + + print len + +useLazily :: Int -> Bool +useLazily len = ([len,3,4] !! 1) == 3 diff --git a/testsuite/tests/stranal/should_run/strun003.stdout b/testsuite/tests/stranal/should_run/strun003.stdout new file mode 100644 index 0000000000..9766475a41 --- /dev/null +++ b/testsuite/tests/stranal/should_run/strun003.stdout @@ -0,0 +1 @@ +ok diff --git a/testsuite/tests/stranal/should_run/strun004.hs b/testsuite/tests/stranal/should_run/strun004.hs new file mode 100644 index 0000000000..ff58f72ce5 --- /dev/null +++ b/testsuite/tests/stranal/should_run/strun004.hs @@ -0,0 +1,10 @@ +module Main where + +f 0 = 0 +f x = x + g (x-1) + +g 0 = 0 +g x = x - f (x-1) + +main = print (f 300) + diff --git a/testsuite/tests/stranal/should_run/strun004.stdout b/testsuite/tests/stranal/should_run/strun004.stdout new file mode 100644 index 0000000000..697cb3a26d --- /dev/null +++ b/testsuite/tests/stranal/should_run/strun004.stdout @@ -0,0 +1 @@ +300 |