diff options
Diffstat (limited to 'testsuite/tests/simplCore/should_run')
48 files changed, 1866 insertions, 0 deletions
diff --git a/testsuite/tests/simplCore/should_run/Makefile b/testsuite/tests/simplCore/should_run/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/simplCore/should_run/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/simplCore/should_run/SeqRule.hs b/testsuite/tests/simplCore/should_run/SeqRule.hs new file mode 100644 index 0000000000..b1569efd7b --- /dev/null +++ b/testsuite/tests/simplCore/should_run/SeqRule.hs @@ -0,0 +1,16 @@ + +-- This test checks that the magic treatment of RULES +-- for 'seq' works right. +-- +-- See Note [RULES for seq] in MkId for more details + +module Main where + +{-# NOINLINE f #-} +f x = not x + +{-# RULES + "f/seq" forall n e. seq (f n) e = True + #-} + +main = print (seq (f True) False) diff --git a/testsuite/tests/simplCore/should_run/SeqRule.stdout b/testsuite/tests/simplCore/should_run/SeqRule.stdout new file mode 100644 index 0000000000..0ca95142bb --- /dev/null +++ b/testsuite/tests/simplCore/should_run/SeqRule.stdout @@ -0,0 +1 @@ +True diff --git a/testsuite/tests/simplCore/should_run/T2486.hs b/testsuite/tests/simplCore/should_run/T2486.hs new file mode 100644 index 0000000000..2f5df48532 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/T2486.hs @@ -0,0 +1,37 @@ +{-# OPTIONS_GHC -O -ddump-rules #-} + +-- Trac #2486 +-- +-- The thing to look for here is that specialisations for fib and tak +-- at both Int and Double are indeed generated; hence -ddump-rules + +module Main where + +import System.Environment +import Numeric + +main = do + n <- getArgs >>= readIO . head + let m = n-1 + a = 27 + fromIntegral n + putStr $ + line "Ack" [3,n] (ack 3 n) show ++ + line "Fib" [a] (fib a :: Double) (\n -> showFFloat (Just 1) n []) ++ + line "Tak" [3*m,2*m,m] (tak (3*m) (2*m) m :: Int) show ++ + line "Fib" [3] (fib 3 :: Int) show ++ + line "Tak" [3,2,1] (tak 3 2 1 :: Double) show + where + line pre a r f = pre ++ "(" ++ csv f a "" ++ "): " ++ f r ++ "\n" + csv f [a] s = s ++ f a + csv f (a:b) s = s ++ f a ++ "," ++ csv f b s + +ack :: Int -> Int -> Int +ack 0 n = n+1 +ack m 0 = ack (m-1) 1 +ack m n = ack (m-1) (ack m (n-1)) + +fib :: (Num a, Ord a) => a -> a +fib n = if n >= 2 then fib (n-1) + fib (n-2) else 1 + +tak :: (Num a, Ord a) => a -> a -> a -> a +tak x y z = if y < x then tak (tak (x-1) y z) (tak (y-1) z x) (tak (z-1) x y) else z diff --git a/testsuite/tests/simplCore/should_run/T2486.stderr b/testsuite/tests/simplCore/should_run/T2486.stderr new file mode 100644 index 0000000000..968e8dbdb4 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/T2486.stderr @@ -0,0 +1,24 @@ + +==================== Tidy Core rules ==================== +"SPEC Main.fib [GHC.Types.Double]" [ALWAYS] + forall ($dNum :: GHC.Num.Num GHC.Types.Double) + ($dOrd :: GHC.Classes.Ord GHC.Types.Double). + Main.fib @ GHC.Types.Double $dNum $dOrd + = Main.fib_$sfib1 +"SPEC Main.fib [GHC.Types.Int]" [ALWAYS] + forall ($dNum :: GHC.Num.Num GHC.Types.Int) + ($dOrd :: GHC.Classes.Ord GHC.Types.Int). + Main.fib @ GHC.Types.Int $dNum $dOrd + = Main.fib_$sfib +"SPEC Main.tak [GHC.Types.Double]" [ALWAYS] + forall ($dNum :: GHC.Num.Num GHC.Types.Double) + ($dOrd :: GHC.Classes.Ord GHC.Types.Double). + Main.tak @ GHC.Types.Double $dNum $dOrd + = Main.tak_$stak1 +"SPEC Main.tak [GHC.Types.Int]" [ALWAYS] + forall ($dNum :: GHC.Num.Num GHC.Types.Int) + ($dOrd :: GHC.Classes.Ord GHC.Types.Int). + Main.tak @ GHC.Types.Int $dNum $dOrd + = Main.tak_$stak + + diff --git a/testsuite/tests/simplCore/should_run/T2756.hs b/testsuite/tests/simplCore/should_run/T2756.hs new file mode 100644 index 0000000000..cb59d50c9b --- /dev/null +++ b/testsuite/tests/simplCore/should_run/T2756.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/simplCore/should_run/T2756.stdout b/testsuite/tests/simplCore/should_run/T2756.stdout new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/T2756.stdout diff --git a/testsuite/tests/simplCore/should_run/T3403.hs b/testsuite/tests/simplCore/should_run/T3403.hs new file mode 100644 index 0000000000..276aae88b2 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/T3403.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE BangPatterns #-} + + +-- See Trac #3403: interaction of pattern match failure and CPR +-- The point is that this should run in constant space, with no +-- stack growth. In GHC 6.10 the tail call optimisation didn't work. + +module Main (main) where + +import qualified Data.Set as Set +import Data.Set (Set) + +data Result = Result !S1 !S2 + +type S1 = Set () +type S2 = Set () + +input :: [[(Int, ())]] +input = replicate 1000 (replicate 400 (100, ())) + +main :: IO () +main = do let Result s1 s2 = doAll Set.empty Set.empty () input + print $ Set.size s1 + print $ Set.size s2 + +doAll :: S1 -> S2 -> () -> [[(Int, ())]] -> Result +doAll !s1 !s2 !_ [] = Result s1 s2 +doAll !s1 !s2 !unit ([] : xs) = doAll s1 s2 unit xs +doAll !s1 !s2 !unit (((t, _) : x1) : x2 : xs) + | t >= 99999 = doAll s1 s2 unit (x1 : x2 : xs) +doAll !s1 !s2 !unit (((_, ()) : x) : xs) + = doAll s1 s2 unit (x : xs) diff --git a/testsuite/tests/simplCore/should_run/T3403.stdout b/testsuite/tests/simplCore/should_run/T3403.stdout new file mode 100644 index 0000000000..aa47d0d46d --- /dev/null +++ b/testsuite/tests/simplCore/should_run/T3403.stdout @@ -0,0 +1,2 @@ +0 +0 diff --git a/testsuite/tests/simplCore/should_run/T3437.hs b/testsuite/tests/simplCore/should_run/T3437.hs new file mode 100644 index 0000000000..9ef6ee8b82 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/T3437.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -O2 #-} + +-- Trac #3437 +-- When we do SpecConstr on 'go', we want the specialised +-- function to *still* be strict in k. Otherwise we get +-- a bad space leak! + +-- The test is run with +RTS -M10m to limit the amount of heap +-- It should run in constant space, but if the function isn't +-- strict enough it'll run out of heap + +module Main where + +go :: [Int] -> [Int] -> [Int] +go (0:xs) !k = k +go (n:xs) !k = go (n-1 : xs) (k ++ k) + +main = print (go [100000000] []) diff --git a/testsuite/tests/simplCore/should_run/T3437.stdout b/testsuite/tests/simplCore/should_run/T3437.stdout new file mode 100644 index 0000000000..fe51488c70 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/T3437.stdout @@ -0,0 +1 @@ +[] diff --git a/testsuite/tests/simplCore/should_run/T3591.hs b/testsuite/tests/simplCore/should_run/T3591.hs new file mode 100644 index 0000000000..491ba5fa17 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/T3591.hs @@ -0,0 +1,206 @@ +{- + Copyright 2009 Mario Blazevic + + This file is part of the Streaming Component Combinators (SCC) project. + + The SCC project is free software: you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation, either version 3 of the + License, or (at your option) any later version. + + SCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with SCC. If not, see <http://www.gnu.org/licenses/>. +-} + +-- | Module "Trampoline" defines the pipe computations and their basic building blocks. + +{-# LANGUAGE ScopedTypeVariables, Rank2Types, MultiParamTypeClasses, + TypeFamilies, KindSignatures, FlexibleContexts, + FlexibleInstances, OverlappingInstances, UndecidableInstances + #-} + +{- Somewhere we get: + + Wanted: AncestorFunctor (EitherFunctor a (TryYield a)) d + This should not reduce because of overlapping instances + + If it (erroneously) does reduce, via dfun2 we get + Wanted: Functor (EitherFunctor a (TryYield a) + Functor d' + Functor d + d ~ EitherFunctor d' s + AncestorFunctor (EitherFunctor a (TryYield a) d' + + + And that gives an infinite loop in the type checker! +-} + + +module Main where + +import Control.Monad (liftM, liftM2, when) +-- import Control.Monad.Identity + +import Debug.Trace (trace) + + +------------- +class (Functor a, Functor d) => AncestorFunctor a d where + liftFunctor :: a x -> d x + +-- dfun 1 +instance Functor a => AncestorFunctor a a where + liftFunctor = trace "liftFunctor id" . id + +-- dfun 2 +instance ( Functor a + , Functor d' + , Functor d + , d ~ EitherFunctor d' s + , AncestorFunctor a d') + => AncestorFunctor a d where + liftFunctor = LeftF . (trace "liftFunctor other" . liftFunctor :: a x -> d' x) + + + + +------------- +newtype Identity a = Identity { runIdentity :: a } +instance Monad Identity where + return a = Identity a + m >>= k = k (runIdentity m) + +newtype Trampoline m s r = Trampoline {bounce :: m (TrampolineState m s r)} +data TrampolineState m s r = Done r | Suspend! (s (Trampoline m s r)) + +instance (Monad m, Functor s) => Monad (Trampoline m s) where + return x = Trampoline (return (Done x)) + t >>= f = Trampoline (bounce t >>= apply f) + where apply f (Done x) = bounce (f x) + apply f (Suspend s) = return (Suspend (fmap (>>= f) s)) + +data Yield x y = Yield! x y +instance Functor (Yield x) where + fmap f (Yield x y) = trace "fmap yield" $ Yield x (f y) + +data Await x y = Await! (x -> y) +instance Functor (Await x) where + fmap f (Await g) = trace "fmap await" $ Await (f . g) + +data EitherFunctor l r x = LeftF (l x) | RightF (r x) +instance (Functor l, Functor r) => Functor (EitherFunctor l r) where + fmap f v = trace "fmap Either" $ + case v of + LeftF l -> trace "fmap LeftF" $ LeftF (fmap f l) + RightF r -> trace "fmap RightF" $ RightF (fmap f r) + +type TryYield x = EitherFunctor (Yield x) (Await Bool) + +suspend :: (Monad m, Functor s) => s (Trampoline m s x) -> Trampoline m s x +suspend s = Trampoline (return (Suspend s)) + +yield :: forall m x. Monad m => x -> Trampoline m (Yield x) () +yield x = suspend (Yield x (return ())) + +await :: forall m x. Monad m => Trampoline m (Await x) x +await = suspend (Await return) + +tryYield :: forall m x. Monad m => x -> Trampoline m (TryYield x) Bool +tryYield x = suspend (LeftF (Yield x (suspend (RightF (Await return))))) + +canYield :: forall m x. Monad m => Trampoline m (TryYield x) Bool +canYield = suspend (RightF (Await return)) + +liftBounce :: Monad m => m x -> Trampoline m s x +liftBounce = Trampoline . liftM Done + +fromTrampoline :: Monad m => Trampoline m s x -> m x +fromTrampoline t = bounce t >>= \(Done x)-> return x + +runTrampoline :: Monad m => Trampoline m Maybe x -> m x +runTrampoline = fromTrampoline + +coupleNestedFinite :: (Functor s, Monad m) => + Trampoline m (EitherFunctor s (TryYield a)) x + -> Trampoline m (EitherFunctor s (Await (Maybe a))) y -> Trampoline m s (x, y) +coupleNestedFinite t1 t2 = + trace "bounce start" $ + liftBounce (liftM2 (,) (bounce t1) (bounce t2)) + >>= \(s1, s2)-> trace "bounce end" $ + case (s1, s2) + of (Done x, Done y) -> return (x, y) + (Done x, Suspend (RightF (Await c2))) -> coupleNestedFinite (return x) (c2 Nothing) + (Suspend (RightF (LeftF (Yield _ c1))), Done y) -> coupleNestedFinite c1 (return y) + (Suspend (RightF (LeftF (Yield x c1))), Suspend (RightF (Await c2))) -> coupleNestedFinite c1 (c2 $ Just x) + (Suspend (RightF (RightF (Await c1))), Suspend s2@(RightF Await{})) -> coupleNestedFinite (c1 True) (suspend s2) + (Suspend (RightF (RightF (Await c1))), Done y) -> coupleNestedFinite (c1 False) (return y) + (Suspend (LeftF s), Done y) -> suspend (fmap (flip coupleNestedFinite (return y)) s) + (Done x, Suspend (LeftF s)) -> suspend (fmap (coupleNestedFinite (return x)) s) + (Suspend (LeftF s1), Suspend (LeftF s2)) -> suspend (fmap (coupleNestedFinite $ suspend $ LeftF s1) s2) + (Suspend (LeftF s1), Suspend (RightF s2)) -> suspend (fmap (flip coupleNestedFinite (suspend $ RightF s2)) s1) + (Suspend (RightF s1), Suspend (LeftF s2)) -> suspend (fmap (coupleNestedFinite (suspend $ RightF s1)) s2) + +local :: forall m l r x. (Monad m, Functor r) => Trampoline m r x -> Trampoline m (EitherFunctor l r) x +local (Trampoline mr) = Trampoline (liftM inject mr) + where inject :: TrampolineState m r x -> TrampolineState m (EitherFunctor l r) x + inject (Done x) = Done x + inject (Suspend r) = Suspend (RightF $ fmap local r) + +out :: forall m l r x. (Monad m, Functor l) => Trampoline m l x -> Trampoline m (EitherFunctor l r) x +out (Trampoline ml) = Trampoline (liftM inject ml) + where inject :: TrampolineState m l x -> TrampolineState m (EitherFunctor l r) x + inject (Done x) = Done x + inject (Suspend l) = Suspend (LeftF $ fmap out l) + +liftOut :: forall m a d x. (Monad m, Functor a, AncestorFunctor a d) => Trampoline m a x -> Trampoline m d x +liftOut (Trampoline ma) = trace "liftOut" $ Trampoline (liftM inject ma) + where inject :: TrampolineState m a x -> TrampolineState m d x + inject (Done x) = Done x + inject (Suspend a) = trace "inject suspend" $ Suspend (liftFunctor $ trace "calling fmap" $ + fmap liftOut (trace "poking a" a)) + +data Sink (m :: * -> *) a x = + Sink {put :: forall d. (AncestorFunctor (EitherFunctor a (TryYield x)) d) => x -> Trampoline m d Bool, + canPut :: forall d. (AncestorFunctor (EitherFunctor a (TryYield x)) d) => Trampoline m d Bool} +newtype Source (m :: * -> *) a x = + Source {get :: forall d. (AncestorFunctor (EitherFunctor a (Await (Maybe x))) d) => Trampoline m d (Maybe x)} + +pipe :: forall m a x r1 r2. (Monad m, Functor a) => + (Sink m a x -> Trampoline m (EitherFunctor a (TryYield x)) r1) + -> (Source m a x -> Trampoline m (EitherFunctor a (Await (Maybe x))) r2) -> Trampoline m a (r1, r2) +pipe producer consumer = coupleNestedFinite (producer sink) (consumer source) where + sink = Sink {put= liftOut . (local . tryYield :: x -> Trampoline m (EitherFunctor a (TryYield x)) Bool), + canPut= liftOut (local canYield :: Trampoline m (EitherFunctor a (TryYield x)) Bool)} :: Sink m a x + source = Source (liftOut (local await :: Trampoline m (EitherFunctor a (Await (Maybe x))) (Maybe x))) :: Source m a x + +pipeProducer sink = do put sink 1 + (c, d) <- pipe + (\sink'-> do put sink' 2 + put sink 3 + put sink' 4 + return 5) + (\source'-> do Just n <- get source' + put sink n + put sink 6 + return n) + put sink c + put sink d + return (c, d) + +testPipe = print $ + runIdentity $ + runTrampoline $ + do (a, b) <- pipe + pipeProducer + (\source-> do Just n1 <- get source + Just n2 <- get source + Just n3 <- get source + return (n1, n2, n3)) + return (a, b) + +main = testPipe diff --git a/testsuite/tests/simplCore/should_run/T3591.stderr b/testsuite/tests/simplCore/should_run/T3591.stderr new file mode 100644 index 0000000000..3fcef522a9 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/T3591.stderr @@ -0,0 +1,456 @@ +bounce start +bounce end +liftOut +inject suspend +liftFunctor id +calling fmap +fmap Either +poking a +fmap RightF +fmap Either +fmap RightF +fmap Either +fmap Either +fmap Either +fmap LeftF +fmap LeftF +fmap LeftF +fmap yield +fmap yield +fmap yield +liftOut +inject suspend +liftFunctor id +calling fmap +fmap Either +poking a +fmap RightF +fmap Either +fmap RightF +fmap await +fmap await +fmap await +bounce start +bounce end +liftOut +inject suspend +liftFunctor id +calling fmap +fmap Either +poking a +fmap RightF +fmap Either +fmap RightF +fmap Either +fmap Either +fmap Either +fmap RightF +fmap RightF +fmap RightF +fmap await +fmap await +fmap await +liftOut +fmap Either +fmap RightF +fmap await +bounce start +bounce end +liftOut +bounce start +bounce end +liftOut +inject suspend +liftFunctor id +calling fmap +fmap Either +poking a +fmap RightF +fmap Either +fmap RightF +fmap Either +fmap Either +fmap Either +fmap LeftF +fmap LeftF +fmap LeftF +fmap yield +fmap yield +fmap yield +liftOut +inject suspend +liftFunctor id +calling fmap +fmap Either +poking a +fmap RightF +fmap Either +fmap RightF +fmap await +fmap await +fmap await +bounce start +bounce end +liftOut +inject suspend +liftFunctor id +calling fmap +fmap Either +poking a +fmap RightF +fmap Either +fmap RightF +fmap Either +fmap Either +fmap Either +fmap RightF +fmap RightF +fmap RightF +fmap await +fmap await +fmap await +liftOut +liftOut +inject suspend +fmap Either +fmap LeftF +fmap Either +fmap Either +liftFunctor other +liftFunctor id +calling fmap +fmap Either +poking a +fmap RightF +fmap RightF +fmap RightF +fmap Either +fmap RightF +fmap Either +fmap Either +fmap Either +fmap Either +fmap Either +fmap LeftF +fmap LeftF +fmap LeftF +fmap LeftF +fmap LeftF +fmap yield +fmap yield +fmap yield +fmap yield +fmap yield +bounce start +bounce end +bounce start +bounce end +liftOut +inject suspend +fmap Either +fmap LeftF +fmap Either +fmap Either +liftFunctor other +liftFunctor id +calling fmap +fmap Either +poking a +fmap RightF +fmap RightF +fmap RightF +fmap Either +fmap RightF +fmap Either +fmap Either +fmap Either +fmap Either +fmap Either +fmap RightF +fmap RightF +fmap RightF +fmap RightF +fmap RightF +fmap await +fmap await +fmap await +fmap await +fmap await +liftOut +fmap Either +fmap RightF +fmap await +bounce start +bounce end +bounce start +bounce end +liftOut +liftOut +inject suspend +fmap Either +fmap LeftF +fmap Either +fmap Either +liftFunctor other +liftFunctor id +calling fmap +fmap Either +poking a +fmap RightF +fmap RightF +fmap RightF +fmap Either +fmap RightF +fmap Either +fmap Either +fmap Either +fmap Either +fmap Either +fmap LeftF +fmap LeftF +fmap LeftF +fmap LeftF +fmap LeftF +fmap yield +fmap yield +fmap yield +fmap yield +fmap yield +bounce start +bounce end +bounce start +bounce end +liftOut +inject suspend +fmap Either +fmap LeftF +fmap Either +fmap Either +liftFunctor other +liftFunctor id +calling fmap +fmap Either +poking a +fmap RightF +fmap RightF +fmap RightF +fmap Either +fmap RightF +fmap Either +fmap Either +fmap Either +fmap Either +fmap Either +fmap RightF +fmap RightF +fmap RightF +fmap RightF +fmap RightF +fmap await +fmap await +fmap await +fmap await +fmap await +liftOut +bounce start +bounce end +bounce start +bounce end +liftOut +bounce start +bounce end +liftOut +liftOut +inject suspend +fmap Either +fmap LeftF +fmap Either +fmap Either +liftFunctor other +liftFunctor id +calling fmap +fmap Either +poking a +fmap RightF +fmap RightF +fmap RightF +fmap Either +fmap RightF +fmap Either +fmap Either +fmap Either +fmap Either +fmap Either +fmap LeftF +fmap LeftF +fmap LeftF +fmap LeftF +fmap LeftF +fmap yield +fmap yield +fmap yield +fmap yield +fmap yield +bounce start +bounce end +bounce start +bounce end +liftOut +inject suspend +fmap Either +fmap LeftF +fmap Either +fmap Either +liftFunctor other +liftFunctor id +calling fmap +fmap Either +poking a +fmap RightF +fmap RightF +fmap RightF +fmap Either +fmap RightF +fmap Either +fmap Either +fmap Either +fmap Either +fmap Either +fmap RightF +fmap RightF +fmap RightF +fmap RightF +fmap RightF +fmap await +fmap await +fmap await +fmap await +fmap await +bounce start +bounce end +bounce start +bounce end +liftOut +liftOut +inject suspend +liftFunctor id +calling fmap +fmap Either +poking a +fmap RightF +fmap Either +fmap RightF +fmap Either +fmap Either +fmap Either +fmap LeftF +fmap LeftF +fmap LeftF +fmap yield +fmap yield +fmap yield +bounce start +bounce end +liftOut +inject suspend +liftFunctor id +calling fmap +fmap Either +poking a +fmap RightF +fmap Either +fmap RightF +fmap Either +fmap Either +fmap Either +fmap RightF +fmap RightF +fmap RightF +fmap await +fmap await +fmap await +bounce start +bounce end +liftOut +liftOut +inject suspend +liftFunctor id +calling fmap +fmap Either +poking a +fmap RightF +fmap Either +fmap RightF +fmap Either +fmap Either +fmap Either +fmap LeftF +fmap LeftF +fmap LeftF +fmap yield +fmap yield +fmap yield +bounce start +bounce end +liftOut +inject suspend +liftFunctor id +calling fmap +fmap Either +poking a +fmap RightF +fmap Either +fmap RightF +fmap Either +fmap Either +fmap Either +fmap RightF +fmap RightF +fmap RightF +fmap await +fmap await +fmap await +bounce start +bounce end +liftOut +liftOut +inject suspend +liftFunctor id +calling fmap +fmap Either +poking a +fmap RightF +fmap Either +fmap RightF +fmap Either +fmap Either +fmap Either +fmap LeftF +fmap LeftF +fmap LeftF +fmap yield +fmap yield +fmap yield +bounce start +bounce end +liftOut +inject suspend +liftFunctor id +calling fmap +fmap Either +poking a +fmap RightF +fmap Either +fmap RightF +fmap Either +fmap Either +fmap Either +fmap RightF +fmap RightF +fmap RightF +fmap await +fmap await +fmap await +bounce start +bounce end +liftOut diff --git a/testsuite/tests/simplCore/should_run/T3591.stdout b/testsuite/tests/simplCore/should_run/T3591.stdout new file mode 100644 index 0000000000..0c69a05357 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/T3591.stdout @@ -0,0 +1 @@ +((5,2),(1,2,6)) diff --git a/testsuite/tests/simplCore/should_run/T3959.hs b/testsuite/tests/simplCore/should_run/T3959.hs new file mode 100644 index 0000000000..725f315da8 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/T3959.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-} +module Main(main,f) where + +import Data.List (isPrefixOf) +import Data.Dynamic +import Control.Exception as E + +data Failure = Failure + deriving (Show, Typeable) + +instance Exception Failure + +test = (E.throw Failure >> return ()) + `E.catch` + (\(x::Failure) -> return ()) + +main :: IO () +main = print =<< test + +f :: Bool -> Bool -> Bool +f True = error "urk" +-- f False = \y -> y + +{- +Uderlying cause: we call + catch# thing handler +and expect that (thing state-token) will + - either diverge/throw an exception + - or return (# x,y #) +But it does neither: it returns a PAP, because + thing = \p q. blah + +In particular, 'thing = lvl_sxo' is + lvl_sxc :: IO Any + lvl_sxc = error "urk" + + lvl_sxo :: IO () + = lvl_sxc >> return () + + -- inline (>>) -- + + = (\(eta::S#). case lvl_sxc |> g1 eta of ...) |> g2 + where + g1 :: IO Any ~ S# -> (# S#, Any #) + g2 :: S# -> (# S#, () #) -> IO () + + -- case-of-bottomming function -- + + = (\ (eta::S#). lvl_sxc |> g1 |> ug3) |> g2 + where + ug3(unsafe) :: S# -> (S#, Any) ~ (# S#, () #) + +This is all fine. But it's crucial that lvl_sxc actually diverges. +Do not eta-expand it to + + lvl_sxc :: IO Any + lvl_sxc = \eta. error "urk" |> ug4 + where + ug4(unsafe) :: S# -> (# S#, Any #) ~ IO Any + +In contrast, if we had + case x of + True -> \a -> 3 + False -> error "urk" +we can, and must, eta-expand the error + +-}
\ No newline at end of file diff --git a/testsuite/tests/simplCore/should_run/T3959.stdout b/testsuite/tests/simplCore/should_run/T3959.stdout new file mode 100644 index 0000000000..6a452c185a --- /dev/null +++ b/testsuite/tests/simplCore/should_run/T3959.stdout @@ -0,0 +1 @@ +() diff --git a/testsuite/tests/simplCore/should_run/T3972.hs b/testsuite/tests/simplCore/should_run/T3972.hs new file mode 100644 index 0000000000..324ddd4f9a --- /dev/null +++ b/testsuite/tests/simplCore/should_run/T3972.hs @@ -0,0 +1,25 @@ + +module Main (main) where + +import T3972A (Expr(E10), Token, spanning, getSpan) + +import Control.Monad +import System.Exit +import System.IO + +main :: IO () +main = do h <- openFile "T3972.o" ReadMode + s <- hFileSize h + hClose h + -- size is just under 8k on amd64/Linux in 6.13, but was + -- around 3.5M in 6.12. Let's try >20k as the test for + -- having regressed. + when (s > 20000) $ do + hPutStrLn stderr ("T3972.o is too big! " ++ show s) + exitFailure + +makeTupleOrExpr :: [Expr] -> Maybe Token -> Expr +makeTupleOrExpr [e] Nothing = e +makeTupleOrExpr es@(_:_) (Just t) = E10 (spanning es t) +makeTupleOrExpr es@(_:_) Nothing = E10 (getSpan es) + diff --git a/testsuite/tests/simplCore/should_run/T3972A.hs b/testsuite/tests/simplCore/should_run/T3972A.hs new file mode 100644 index 0000000000..b8202f7448 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/T3972A.hs @@ -0,0 +1,86 @@ + +module T3972A (Expr(..), Token(..), spanning, getSpan) where + +class Span a where + getSpan :: a -> SrcSpan + +spanning :: (Span a, Span b) => a -> b -> SrcSpan +spanning x y = combineSrcSpans (getSpan x) (getSpan y) + +instance Span a => Span [a] where + getSpan [] = error "[]" + getSpan [x] = getSpan x + getSpan list@(x:_) = combineSrcSpans (getSpan x) (getSpan (last list)) + +data SrcSpan + + = SpanMultiLine + { span_start_row :: !Int + , span_start_column :: !Int + , span_end_row :: !Int + , span_end_column :: !Int + } + +combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan +combineSrcSpans start end + = case row1 `compare` row2 of + LT -> SpanMultiLine row1 col1 row2 col2 + _ -> SpanMultiLine row2 col2 row1 col1 + where + row1 = startRow start + col1 = startCol start + row2 = endRow end + col2 = endCol end + + +startRow :: SrcSpan -> Int +startRow (SpanMultiLine { span_start_row = row }) = row + +endRow :: SrcSpan -> Int +endRow (SpanMultiLine { span_end_row = row }) = row + +startCol :: SrcSpan -> Int +startCol (SpanMultiLine { span_start_column = col }) = col + +endCol :: SrcSpan -> Int +endCol (SpanMultiLine { span_end_column = col }) = col + +data Token + = T10 { token_SrcSpan :: SrcSpan } + | T11 { token_SrcSpan :: SrcSpan } + | T12 { token_SrcSpan :: SrcSpan } + | T13 { token_SrcSpan :: SrcSpan } + | T14 { token_SrcSpan :: SrcSpan } + | T15 { token_SrcSpan :: SrcSpan } + | T16 { token_SrcSpan :: SrcSpan } + | T17 { token_SrcSpan :: SrcSpan } + | T18 { token_SrcSpan :: SrcSpan } + | T19 { token_SrcSpan :: SrcSpan } + | T20 { token_SrcSpan :: SrcSpan } + | T21 { token_SrcSpan :: SrcSpan } + | T22 { token_SrcSpan :: SrcSpan } + | T23 { token_SrcSpan :: SrcSpan } + | T24 { token_SrcSpan :: SrcSpan } + +instance Span Token where + getSpan = token_SrcSpan + +data Expr + = E10 { expr_SrcSpan :: SrcSpan } + | E11 { expr_SrcSpan :: SrcSpan } + | E12 { expr_SrcSpan :: SrcSpan } + | E13 { expr_SrcSpan :: SrcSpan } + | E14 { expr_SrcSpan :: SrcSpan } + | E15 { expr_SrcSpan :: SrcSpan } + | E16 { expr_SrcSpan :: SrcSpan } + | E17 { expr_SrcSpan :: SrcSpan } + | E18 { expr_SrcSpan :: SrcSpan } + | E19 { expr_SrcSpan :: SrcSpan } + | E20 { expr_SrcSpan :: SrcSpan } + | E21 { expr_SrcSpan :: SrcSpan } + | E22 { expr_SrcSpan :: SrcSpan } + | E23 { expr_SrcSpan :: SrcSpan } + | E24 { expr_SrcSpan :: SrcSpan } + +instance Span Expr where + getSpan = expr_SrcSpan diff --git a/testsuite/tests/simplCore/should_run/T3983.hs b/testsuite/tests/simplCore/should_run/T3983.hs new file mode 100644 index 0000000000..7a665256b1 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/T3983.hs @@ -0,0 +1,5 @@ +module Main where +import T3983_Foo +import T3983_Bar + +main = catchX (foo False True) >>= print
\ No newline at end of file diff --git a/testsuite/tests/simplCore/should_run/T3983.stdout b/testsuite/tests/simplCore/should_run/T3983.stdout new file mode 100644 index 0000000000..bc59c12aa1 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/T3983.stdout @@ -0,0 +1 @@ +False diff --git a/testsuite/tests/simplCore/should_run/T3983_Bar.hs b/testsuite/tests/simplCore/should_run/T3983_Bar.hs new file mode 100644 index 0000000000..ee6fe36e86 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/T3983_Bar.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE DeriveDataTypeable #-} +module T3983_Bar where +import Data.Dynamic +import Control.Exception +import Control.Monad (unless) + +type Assertion = IO () + +data X = X String deriving (Show, Typeable) + +instance Exception X + +throwX = throw.X + +catchX action = do { action; return True; } `catches` [Handler (\(X _) -> return False)]
\ No newline at end of file diff --git a/testsuite/tests/simplCore/should_run/T3983_Foo.hs b/testsuite/tests/simplCore/should_run/T3983_Foo.hs new file mode 100644 index 0000000000..b2519632a9 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/T3983_Foo.hs @@ -0,0 +1,8 @@ +module T3983_Foo where + +import Control.Monad (unless) +import Control.Exception +import T3983_Bar + +foo :: Bool -> Bool -> IO () +foo a b = unless a $ throwX (if b then "" else "") diff --git a/testsuite/tests/simplCore/should_run/T4814.hs b/testsuite/tests/simplCore/should_run/T4814.hs new file mode 100644 index 0000000000..45551ffd23 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/T4814.hs @@ -0,0 +1,39 @@ +-- This test exposes the bug in GHC 7.0.1 (and earlier) +-- which did the following rule rewrite: +-- +-- f (let v = 2 in g v) (let v = 3 in g v) +-- ---> let v = 2 in let v = 3 in g v + g v +-- +-- which is wrong because of the shadowing of v + +module Main where +foo :: Int -> Int +{-# INLINE foo #-} +foo x = g (bar (x,x)) + +bar :: (Int,Int) -> Int +{-# NOINLINE bar #-} +bar (x,y) = x + +baz :: Int -> Int +{-# NOINLINE baz #-} +baz x = x + +f :: Int -> Int -> Int +{-# NOINLINE f #-} +f x y = x+y + +g :: Int -> Int +{-# NOINLINE g #-} +g x = x + +{-# RULES + + "f/g" [1] forall x y. f (g x) (g y) = x + y + + #-} + +main = print $ f (foo (baz 1)) (foo (baz 2)) +-- Should print 3 +-- Bug means that it prints 4 + diff --git a/testsuite/tests/simplCore/should_run/T4814.stdout b/testsuite/tests/simplCore/should_run/T4814.stdout new file mode 100644 index 0000000000..00750edc07 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/T4814.stdout @@ -0,0 +1 @@ +3 diff --git a/testsuite/tests/simplCore/should_run/T5315.hs b/testsuite/tests/simplCore/should_run/T5315.hs new file mode 100644 index 0000000000..5b2ff39346 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/T5315.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +infixr 7 :*, .* +infix 8 :*:, .*. + +data HNil +data α :* β +type HSingle α = α :* HNil +type α :*: β = α :* β :* HNil + +data HList l where + HNil ∷ HList HNil + (:*) ∷ α → HList t → HList (α :* t) + +(.*) ∷ α → HList t → HList (α :* t) +(.*) = (:*) + +(.*.) ∷ α → β → HList (α :*: β) +a .*. b = a .* b .* HNil + +data First +data Next p + +data HIndex i where + First ∷ HIndex First + Next ∷ HIndex p → HIndex (Next p) + +class (l ~ (HHead l :* HTail l)) ⇒ HNonEmpty l where + type HHead l + type HTail l + +instance HNonEmpty (h :* t) where + type HHead (h :* t) = h + type HTail (h :* t) = t + +hHead ∷ HNonEmpty l ⇒ HList l → HHead l +hHead (h :* _) = h +hHead _ = undefined + +hTail ∷ HNonEmpty l ⇒ HList l → HList (HTail l) +hTail (_ :* t) = t +hTail _ = undefined + +data HFromWitness n l where + HFromFirst ∷ HFromWitness First l + HFromNext ∷ (HNonEmpty l, HFromClass p (HTail l), + HTail (HFrom (Next p) l) ~ HFrom (Next p) (HTail l)) + ⇒ HFromWitness (Next p) l + +class HFromClass n l where + type HFrom n l + hFromWitness ∷ HFromWitness n l + +instance HFromClass First l where + type HFrom First l = l + hFromWitness = HFromFirst + +instance (HNonEmpty l, HFromClass p (HTail l)) ⇒ HFromClass (Next p) l where + type HFrom (Next p) l = HFrom p (HTail l) + hFromWitness = case hFromWitness ∷ HFromWitness p (HTail l) of + HFromFirst → HFromNext + HFromNext → HFromNext + +hFrom ∷ ∀ n l . HFromClass n l ⇒ HIndex n → HList l → HList (HFrom n l) +hFrom First l = l +hFrom (Next p) l = case hFromWitness ∷ HFromWitness n l of + HFromNext → hFrom p (hTail l) + _ → undefined + +type HNth n l = HHead (HFrom n l) + +hNth ∷ ∀ n l . (HFromClass n l, HNonEmpty (HFrom n l)) + ⇒ HIndex n → HList l → HNth n l +hNth First l = hHead l +hNth (Next p) l = case hFromWitness ∷ HFromWitness n l of + HFromNext → hNth p (hTail l) + _ → undefined + +main = putStrLn $ hNth (Next First) (0 .*. "Test") + diff --git a/testsuite/tests/simplCore/should_run/T5315.stdout b/testsuite/tests/simplCore/should_run/T5315.stdout new file mode 100644 index 0000000000..345e6aef71 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/T5315.stdout @@ -0,0 +1 @@ +Test diff --git a/testsuite/tests/simplCore/should_run/all.T b/testsuite/tests/simplCore/should_run/all.T new file mode 100644 index 0000000000..174fa180c8 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/all.T @@ -0,0 +1,47 @@ +# Args to compile_and_run are: +# extra compile flags +# extra run flags +# expected process return value, if not zero + +# Only compile with optimisation +def f( opts ): + opts.only_ways = ['optasm'] + +setTestOpts(f) + +test('simplrun001', normal, compile_and_run, ['']) +test('simplrun002', normal, compile_and_run, ['']) +test('simplrun003', normal, compile_and_run, ['']) +test('simplrun004', normal, compile_and_run, ['']) +test('simplrun005', normal, compile_and_run, ['']) + +test('simplrun007', normal, compile_and_run, ['']) +test('simplrun008', normal, compile_and_run, ['']) +test('simplrun009', normal, compile_and_run, ['']) +test('simplrun010', composes([extra_run_opts('24 16 8'), + exit_code(1)]) + , compile_and_run, ['']) + +# Really we'd like to run T2486 too, to check that its +# runtime has not gone up, but here I just compile it so that +# the output of -ddump-rules can be compared +test('T2486', normal, compile, ['']) +test('T2756', normal, compile_and_run, ['']) +test('T3437', extra_run_opts('+RTS -M10m'), compile_and_run, ['']) + +test('SeqRule', only_ways(['optasm']), compile_and_run, ['']) + +test('T3403', normal, compile_and_run, ['-package containers']) +test('T3591', normal, compile_and_run, ['']) +test('T4814', normal, compile_and_run, ['']) + +# Run this test *without* optimisation too +test('T3959', only_ways(['normal','optasm']), compile_and_run, ['']) +test('T3983', [only_ways(['normal','optasm']), + extra_clean(['T3983_Foo.hi','T3983_Foo.o','T3983_Bar.hi','T3983_Bar.o',])], + multimod_compile_and_run, + ['T3983','']) +test('T3972', extra_clean(['T3972A.hi', 'T3972A.o']), + compile_and_run, + ['']) +test('T5315', normal, compile_and_run, ['']) diff --git a/testsuite/tests/simplCore/should_run/simplrun001.hs b/testsuite/tests/simplCore/should_run/simplrun001.hs new file mode 100644 index 0000000000..6cbbf76a91 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/simplrun001.hs @@ -0,0 +1,14 @@ +-- !!! Test filter fusion + +-- In GHC 4.06, the filterFB rule was back to front, which +-- made this program hit the "error foo" case instead of +-- working fine. + + +module Main where + +main :: IO () +main = print (length (filter (not . foo) + (filter (const False) [Nothing]))) + where foo (Just x) = x + foo _ = error "foo" diff --git a/testsuite/tests/simplCore/should_run/simplrun001.stderr b/testsuite/tests/simplCore/should_run/simplrun001.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/simplrun001.stderr diff --git a/testsuite/tests/simplCore/should_run/simplrun001.stdout b/testsuite/tests/simplCore/should_run/simplrun001.stdout new file mode 100644 index 0000000000..573541ac97 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/simplrun001.stdout @@ -0,0 +1 @@ +0 diff --git a/testsuite/tests/simplCore/should_run/simplrun002.hs b/testsuite/tests/simplCore/should_run/simplrun002.hs new file mode 100644 index 0000000000..c6d9267d40 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/simplrun002.hs @@ -0,0 +1,23 @@ + +-- !!! A rules test +-- At one time the rule got too specialised a type: +-- +-- _R "ffoo" forall {@ a1 v :: (a1, ((), ()))} +-- fst @ a1 @ () (sndSnd @ a1 @ () @ () v) = fst @ a1 @ ((), ()) v + + +module Main where + +import System.IO +import System.IO.Unsafe ( unsafePerformIO ) + +{-# NOINLINE [0] sndSnd #-} +-- Dont inline till last, to give the rule a chance +sndSnd (a,(b,c)) = (a,c) + +trace x y = unsafePerformIO (hPutStr stderr x >> hPutStr stderr "\n" >> return y) + +{-# RULES "foo" forall v . fst (sndSnd v) = trace "Yes" (fst v) #-} + +main :: IO () +main = print (fst (sndSnd (True, (False,True)))) diff --git a/testsuite/tests/simplCore/should_run/simplrun002.stderr b/testsuite/tests/simplCore/should_run/simplrun002.stderr new file mode 100644 index 0000000000..dcd7a5d6d5 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/simplrun002.stderr @@ -0,0 +1 @@ +Yes diff --git a/testsuite/tests/simplCore/should_run/simplrun002.stdout b/testsuite/tests/simplCore/should_run/simplrun002.stdout new file mode 100644 index 0000000000..0ca95142bb --- /dev/null +++ b/testsuite/tests/simplCore/should_run/simplrun002.stdout @@ -0,0 +1 @@ +True diff --git a/testsuite/tests/simplCore/should_run/simplrun003.hs b/testsuite/tests/simplCore/should_run/simplrun003.hs new file mode 100644 index 0000000000..45aa73578e --- /dev/null +++ b/testsuite/tests/simplCore/should_run/simplrun003.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE UnboxedTuples #-} + +-- O2 to get CSE + +module Main where + +f :: Int -> (# Int, Int #) +f 0 = (# 1,2 #) +f n = f (n-1) + +{-# NOINLINE g #-} +g x = case f x of + (# a,b #) -> if a>0 + then f x -- CSE opportunity + else (# b,a #) + +-- GHC 6.2 wrongly optimised g to: +-- case f x of t +-- (# a,b #) -> if a>0 then +-- t -- WRONG +-- else (# b,a #) + +main = case g 2 of (# a,b #) -> print a diff --git a/testsuite/tests/simplCore/should_run/simplrun003.stdout b/testsuite/tests/simplCore/should_run/simplrun003.stdout new file mode 100644 index 0000000000..d00491fd7e --- /dev/null +++ b/testsuite/tests/simplCore/should_run/simplrun003.stdout @@ -0,0 +1 @@ +1 diff --git a/testsuite/tests/simplCore/should_run/simplrun004.hs b/testsuite/tests/simplCore/should_run/simplrun004.hs new file mode 100644 index 0000000000..16e7566ee2 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/simplrun004.hs @@ -0,0 +1,34 @@ +module Main where + +-- A test for loss of sharing. GHC 6.4.1 did a bogus preInlineUnconditionally + +import Control.Monad ( guard ) + +expensive 0 = True +expensive 1 = False +expensive n = expensive (n-2) + +f g = if expensive (1000000*(fst g)) then odd else even + +--------------------------------------------------------- +-- The key point is that the (c g) call should not get pushed inside the \x, +-- as happened in 6.4.1. Doing so loses laziness, and this test shows up +-- the difference in performance +gen_sucW grow c g + = \ x -> grow g x >>= \ y -> do guard $ check y; return y + where + check = c g + +sucW = gen_sucW (\ g x -> map (+x) [fst g..snd g]) f (11,500000) + +main = print (sum $ sucW 11,sum $ sucW 12) + +-- Becuase this version uses a case expression, the bug +-- doesn't happen and execution is much faster +gen_sucC grow c g = case c g of + check -> \ x -> grow g x >>= \ y -> do guard $ check y; return y + +sucC = gen_sucC (\ g x -> map (+x) [fst g..snd g]) f (11,500000) + +mainC = print (sum $ sucC 11,sum $ sucC 12) + diff --git a/testsuite/tests/simplCore/should_run/simplrun004.stdout b/testsuite/tests/simplCore/should_run/simplrun004.stdout new file mode 100644 index 0000000000..7cdf0c5bab --- /dev/null +++ b/testsuite/tests/simplCore/should_run/simplrun004.stdout @@ -0,0 +1 @@ +(62502999915,62502999915) diff --git a/testsuite/tests/simplCore/should_run/simplrun005.hs b/testsuite/tests/simplCore/should_run/simplrun005.hs new file mode 100644 index 0000000000..d177568e4b --- /dev/null +++ b/testsuite/tests/simplCore/should_run/simplrun005.hs @@ -0,0 +1,47 @@ +module Main where + +main = print (fib' 100) + -- This will time out unless memoing works properly + +data Nat = Z | S Nat + deriving (Show, Eq) + +memo f = g + where + fz = f Z + fs = memo (f . S) + g Z = fz + g (S n) = fs n + -- It is a BAD BUG to inline 'fs' inside g + -- and that happened in 6.4.1, resulting in exponential behaviour + +-- memo f = g (f Z) (memo (f . S)) +-- = g (f Z) (g (f (S Z)) (memo (f . S . S))) +-- = g (f Z) (g (f (S Z)) (g (f (S (S Z))) (memo (f . S . S . S)))) + +fib' :: Nat -> Integer +fib' = memo fib + where + fib Z = 0 + fib (S Z) = 1 + fib (S (S n)) = fib' (S n) + fib' n + +instance Num Nat where + fromInteger 0 = Z + fromInteger n = S (fromInteger (n - 1)) + Z + n = n + S m + n = S (m + n) + Z * n = Z + S m * n = (m * n) + n + Z - n = Z + S m - Z = S m + S m - S n = m - n + +instance Enum Nat where + succ = S + pred Z = Z + pred (S n) = n + toEnum = fromInteger . toInteger + fromEnum Z = 0 + fromEnum (S n) = fromEnum n + 1 + diff --git a/testsuite/tests/simplCore/should_run/simplrun005.stdout b/testsuite/tests/simplCore/should_run/simplrun005.stdout new file mode 100644 index 0000000000..c21fc4a1b9 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/simplrun005.stdout @@ -0,0 +1 @@ +354224848179261915075 diff --git a/testsuite/tests/simplCore/should_run/simplrun007.hs b/testsuite/tests/simplCore/should_run/simplrun007.hs new file mode 100644 index 0000000000..12bfb2d335 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/simplrun007.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE MagicHash #-} + +-- Actually, this exercises prelude/PrelRules, but this is the closest +-- place I could find to put it... + +import GHC.Exts +import Numeric +import Data.Bits + +main = do phex (I# (uncheckedIShiftL# (negateInt# 5#) 2#)) + phex (I# (uncheckedIShiftRA# (negateInt# 5#) 1#)) + phex (I# (uncheckedIShiftRL# (negateInt# 5#) 1#)) + phex (W# (uncheckedShiftL# (int2Word# (negateInt# 5#)) 2#)) + phex (W# (uncheckedShiftRL# (int2Word# (negateInt# 5#)) 1#)) + +phex x = putStrLn (showSigned (\x -> ("0x"++) . showHex x) 0 x "") + +{- Too wordsize-dependant +phex x = putStrLn (hex x) +hex x = "0x" ++ [onedigit (fromIntegral ((x `shiftR` (i*4)) .&. 0xF)) + | i <- [digits-1,digits-2..0]] + where + digits = bitSize x `div` 4 + onedigit n = "0123456789abcdef" !! n +-} + + diff --git a/testsuite/tests/simplCore/should_run/simplrun007.stdout b/testsuite/tests/simplCore/should_run/simplrun007.stdout new file mode 100644 index 0000000000..3283b5c891 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/simplrun007.stdout @@ -0,0 +1,5 @@ +-0x14 +-0x3 +0x7ffffffd +0xffffffec +0x7ffffffd diff --git a/testsuite/tests/simplCore/should_run/simplrun007.stdout-ws-64 b/testsuite/tests/simplCore/should_run/simplrun007.stdout-ws-64 new file mode 100644 index 0000000000..47e0adb0d3 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/simplrun007.stdout-ws-64 @@ -0,0 +1,5 @@ +-0x14 +-0x3 +0x7ffffffffffffffd +0xffffffffffffffec +0x7ffffffffffffffd diff --git a/testsuite/tests/simplCore/should_run/simplrun008.hs b/testsuite/tests/simplCore/should_run/simplrun008.hs new file mode 100644 index 0000000000..782f0e40ac --- /dev/null +++ b/testsuite/tests/simplCore/should_run/simplrun008.hs @@ -0,0 +1,18 @@ + +module Main where +import Data.Char + +{-# NOINLINE f #-} +f :: Int -> String +f x = "NOT FIRED" + +{-# NOINLINE neg #-} +neg :: Int -> Int +neg = negate + +{-# RULES + "f" forall (c::Char->Int) (x::Char). f (c x) = "RULE FIRED" + #-} + +main = do { print (f (ord 'a')) -- Rule should fire + ; print (f (neg 1)) } -- Rule should not fire diff --git a/testsuite/tests/simplCore/should_run/simplrun008.stdout b/testsuite/tests/simplCore/should_run/simplrun008.stdout new file mode 100644 index 0000000000..e04622af3d --- /dev/null +++ b/testsuite/tests/simplCore/should_run/simplrun008.stdout @@ -0,0 +1,2 @@ +"RULE FIRED" +"NOT FIRED" diff --git a/testsuite/tests/simplCore/should_run/simplrun009.hs b/testsuite/tests/simplCore/should_run/simplrun009.hs new file mode 100644 index 0000000000..826cdeef77 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/simplrun009.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE ExistentialQuantification #-} + +-- This test is really meant for human looking; do a -ddump-simpl. + +-- The definition that you want to look at is for foo. +-- It produces a nested unfold that should look something +-- like the code below. Note the 'lvl1_shW'. It is BAD +-- if this is a lambda instead; you get a lot more allocation +-- See Note [Escaping a value lambda] in SetLevels + + +{- + $wunfold_shU = + \ (ww_she :: [[a_abm]]) (ww1_shf :: Data.Maybe.Maybe (Stream.Stream a_abm)) -> + case ww1_shf of wild2_afo { + Data.Maybe.Nothing -> + case ww_she of wild_ad6 { + [] -> GHC.Base.[] @ a_abm; + : x_ado xs1_adp -> + $wunfold_shU + xs1_adp + (Data.Maybe.Just + @ (Stream.Stream a_abm) (Stream.Stream @ a_abm @ [a_abm] + *** lvl1_shW *** + x_ado)) + }; + Data.Maybe.Just ds3_afJ -> + case ds3_afJ of wild3_afL { Stream.Stream @ s1_afN stepb_afO sb_afP -> + case stepb_afO sb_afP of wild4_afR { + Stream.Done -> $wunfold_shU ww_she (Data.Maybe.Nothing @ (Stream.Stream a_abm)); + Stream.Yield x_afV sb'_afW -> + GHC.Base.: + @ a_abm + x_afV + ($wunfold_shU + ww_she + (Data.Maybe.Just + @ (Stream.Stream a_abm) (Stream.Stream @ a_abm @ s1_afN stepb_afO sb'_afW))); + Stream.Skip sb'_afZ -> + $wunfold_shU + ww_she + (Data.Maybe.Just + @ (Stream.Stream a_abm) (Stream.Stream @ a_abm @ s1_afN stepb_afO sb'_afZ)) + } + } +-} + + + +module Main( main, foo ) where +-- Must export foo to make the issue show up + +import Prelude hiding ( concatMap, map) + +main = print (sum (foo [[1,2], [3,4,5]])) + +foo :: Num a => [[a]] -> [a] +foo xss = Main.concatMap (\xs -> Main.map (+1) xs) xss + + +instance StreamableSequence [] where + stream = listToStream + unstream = streamToList + -- These inline pragmas are useless (see #5084) +{- + {-# INLINE stream #-} + {-# INLINE unstream #-} +-} + +listToStream :: [a] -> Stream a +listToStream xs = Stream next xs + where next [] = Done + next (x:xs) = Yield x xs +{-# INLINE [0] listToStream #-} + +streamToList :: Stream a -> [a] +streamToList (Stream next s) = unfold s + where unfold s = + case next s of + Done -> [] + Skip s' -> unfold s' + Yield x s' -> x : unfold s' +{-# INLINE [0] streamToList #-} + +{-# RULES +"stream/unstream" + forall s. listToStream (streamToList s) = s + #-} + +map :: (a -> b) -> [a] -> [b] +map f = unstream . mapS f . stream +{-# INLINE map #-} + +concatMap :: (a -> [b]) -> [a] -> [b] +concatMap f = unstream . concatMapS (stream . f) . stream +{-# INLINE concatMap #-} + + +data Stream a = forall s. Stream (s -> Step a s) s + +data Step a s = Done + | Yield a s + | Skip s + +class StreamableSequence seq where + stream :: seq a -> Stream a + unstream :: Stream a -> seq a + + -- axiom: stream . unstream = id + -- These inline pragmas are useless (see #5084) +{- + {-# INLINE stream #-} + {-# INLINE unstream #-} +-} + +{- +--version that does not require the sequence type +--to be polymorphic in its elements: + +class StreamableSequence seq a | seq -> a where + stream :: seq -> Stream a + unstream :: Stream a -> seq +-} + + +mapS :: (a -> b) -> Stream a -> Stream b +mapS f (Stream next s0) = Stream next' s0 + where next' s = case next s of + Done -> Done + Skip s' -> Skip s' + Yield x s' -> Yield (f x) s' +{-# INLINE [0] mapS #-} + + +concatMapS :: (a -> Stream b) -> Stream a -> Stream b +concatMapS f (Stream step s) = Stream step' (s, Nothing) + where step' (s, Nothing) = + case step s of + Yield x s' -> Skip (s', Just (f x)) + Skip s' -> Skip (s', Nothing) + Done -> Done + + step' (s, Just (Stream stepb sb)) = + case stepb sb of + Yield x sb' -> Yield x (s, Just (Stream stepb sb')) + Skip sb' -> Skip (s, Just (Stream stepb sb')) + Done -> Skip (s, Nothing) +{-# INLINE [0] concatMapS #-} + diff --git a/testsuite/tests/simplCore/should_run/simplrun009.stdout b/testsuite/tests/simplCore/should_run/simplrun009.stdout new file mode 100644 index 0000000000..209e3ef4b6 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/simplrun009.stdout @@ -0,0 +1 @@ +20 diff --git a/testsuite/tests/simplCore/should_run/simplrun010.hs b/testsuite/tests/simplCore/should_run/simplrun010.hs new file mode 100644 index 0000000000..0fbc33ac81 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/simplrun010.hs @@ -0,0 +1,313 @@ +{-# LANGUAGE ForeignFunctionInterface, MagicHash, UnboxedTuples #-} + +-- From trac #1947 + +module Main(main) where + +import System.IO.Unsafe +import System.IO +import System.Environment +import System.Exit +import Foreign.C.Types +import Data.Char(ord,chr) + + +-- low level imports +import GHC.Base (realWorld#) +import GHC.IOBase (IO(IO), unIO, unsafePerformIO) +import GHC.Prim (State#,RealWorld) + + +-- FFI replacements for Haskell stuff +foreign import ccall unsafe "stdio.h getchar" getchar :: IO CInt +foreign import ccall unsafe "ctype.h iswspace" isspace :: CInt -> CInt + + +skipCAF :: State# RealWorld -> a -> a +skipCAF _ x = x + + +-- IO Subsystem +-- Unboxed IO is more efficient, but requires a certain level of +-- optimisation, so provide a BOXED_IO fallback + +data RW_Box = RW_Box (State# RealWorld) +type RW_Pair a = (RW_Box, a) + +fromIO :: IO a -> (RW_Box -> RW_Pair a) +fromIO a (RW_Box r) = case unIO a r of (# r, x #) -> (RW_Box r, x) + +toIO :: (RW_Box -> RW_Pair a) -> IO a +toIO f = IO $ \r -> case f (RW_Box r) of (RW_Box r, x) -> (# r, x #) + +-- IO functions not dependent on the IO primitives +main :: IO () +main = toIO main_generated + +typeRealWorld :: RW_Box -> RW_Box +typeRealWorld x = x + +overlay_get_char :: RW_Box -> RW_Pair Int +overlay_get_char = fromIO $ do + c <- getchar + return $ fromIntegral c + +system_IO_hPutChar :: Handle -> Int -> RW_Box -> RW_Pair () +system_IO_hPutChar h c = fromIO $ hPutChar h (chr c) + +overlay_errorIO :: [Int] -> RW_Box -> RW_Pair a +overlay_errorIO x r = case fromIO (putStrLn ("ERROR: " ++ map chr x)) r of + (r, _) -> fromIO exitFailure r + +system_Environment_getArgs :: RW_Box -> RW_Pair [[Int]] +system_Environment_getArgs r = case (fromIO getArgs) r of + (r, s) -> (r, map str_ s) + +overlay_supero_wrap x = x + + +-- Primitives +prelude_seq = seq + +prelude_error x = error (map chr x) + +aDD_W = (+) :: Int -> Int -> Int +mUL_W = (*) :: Int -> Int -> Int +sUB_W = (-) :: Int -> Int -> Int +eQ_W = (==) :: Int -> Int -> Bool +nE_W = (/=) :: Int -> Int -> Bool +gT_W = (>) :: Int -> Int -> Bool +gE_W = (>=) :: Int -> Int -> Bool +lT_W = (<) :: Int -> Int -> Bool +lE_W = (<=) :: Int -> Int -> Bool +qUOT = quot :: Int -> Int -> Int +rEM = rem :: Int -> Int -> Int +nEG_W = negate :: Int -> Int +yHC_Primitive_primIntAbs = abs :: Int -> Int +yHC_Primitive_primIntSignum = signum :: Int -> Int +yHC_Primitive_primIntegerAdd = (+) :: Integer -> Integer -> Integer +yHC_Primitive_primIntegerEq = (==) :: Integer -> Integer -> Bool +yHC_Primitive_primIntegerFromInt = toInteger :: Int -> Integer +yHC_Primitive_primIntegerGe = (>=) :: Integer -> Integer -> Bool +yHC_Primitive_primIntegerGt = (>) :: Integer -> Integer -> Bool +yHC_Primitive_primIntegerLe = (<=) :: Integer -> Integer -> Bool +yHC_Primitive_primIntegerMul = (*) :: Integer -> Integer -> Integer +yHC_Primitive_primIntegerNe = (/=) :: Integer -> Integer -> Bool +yHC_Primitive_primIntegerNeg = negate :: Integer -> Integer +yHC_Primitive_primIntegerQuot = quot :: Integer -> Integer -> Integer +yHC_Primitive_primIntegerQuotRem = quotRem :: Integer -> Integer -> (Integer, Integer) +yHC_Primitive_primIntegerRem = rem :: Integer -> Integer -> Integer +yHC_Primitive_primIntFromInteger = fromInteger :: Integer -> Int +yHC_Primitive_primIntegerLt = (<) :: Integer -> Integer -> Bool +yHC_Primitive_primIntegerSub = (-) :: Integer -> Integer -> Integer + +aDD_D = (+) :: Double -> Double -> Double +sUB_D = (-) :: Double -> Double -> Double +lT_D = (<) :: Double -> Double -> Bool +lE_D = (<=) :: Double -> Double -> Bool +gT_D = (>) :: Double -> Double -> Bool +gE_D = (>=) :: Double -> Double -> Bool +eQ_D = (==) :: Double -> Double -> Bool +mUL_D = (*) :: Double -> Double -> Double +nEG_D = (negate) :: Double -> Double +nE_D = (/=) :: Double -> Double -> Bool +sLASH_D = (/) :: Double -> Double -> Double +yHC_Primitive_primDecodeDouble = decodeFloat :: Double -> (Integer,Int) +yHC_Primitive_primDoubleACos = acos :: Double -> Double +yHC_Primitive_primDoubleASin = asin :: Double -> Double +yHC_Primitive_primDoubleATan = atan :: Double -> Double +yHC_Primitive_primDoubleAbs = abs :: Double -> Double +yHC_Primitive_primDoubleCos = cos :: Double -> Double +yHC_Primitive_primDoubleExp = exp :: Double -> Double +yHC_Primitive_primDoubleFromInteger = fromInteger :: Integer -> Double +yHC_Primitive_primDoubleLog = log :: Double -> Double +yHC_Primitive_primDoublePow = (**) :: Double -> Double -> Double +yHC_Primitive_primDoubleSignum = signum :: Double -> Double +yHC_Primitive_primDoubleSin = sin :: Double -> Double +yHC_Primitive_primDoubleSqrt = sqrt :: Double -> Double +yHC_Primitive_primDoubleTan = tan :: Double -> Double +yHC_Primitive_primEncodeDouble = encodeFloat :: Integer -> Int -> Double + + + + +-- things which Yhc decides should be hopelessly slow +prelude_Int_Integral_mod = mod :: Int -> Int -> Int +prelude_Integer_Integral_div = div :: Integer -> Integer -> Integer +prelude_Integer_Integral_mod = mod :: Integer -> Integer -> Integer +prelude_Integer_Num_signum = signum :: Integer -> Integer +prelude_Integer_Num_abs = abs :: Integer -> Integer + + +int_ x = x :: Int +chr_ x = ord x +str_ x = map chr_ x + + +system_IO_stdin = stdin +system_IO_stdout = stdout + +data_Char_isSpace :: Int -> Bool +data_Char_isSpace c = isspace (toEnum c) /= 0 + + + +type ReadsPrec a = Int -> [Int] -> [(a,[Int])] + + +prelude_Int_Read_readsPrec :: ReadsPrec Int +prelude_Int_Read_readsPrec p s = [(a, str_ b) | (a,b) <- readsPrec p (map chr s)] +prelude_Int_Read_readList = undefined + +prelude_Integer_Read_readsPrec :: ReadsPrec Integer +prelude_Integer_Read_readsPrec p s = [(a, str_ b) | (a,b) <- readsPrec p (map chr s)] +prelude_Integer_Read_readList = undefined + +prelude_Double_Read_readsPrec :: ReadsPrec Double +prelude_Double_Read_readsPrec p s = [(a, str_ b) | (a,b) <- readsPrec p (map chr s)] +prelude_Double_Read_readList = undefined + +prelude_Char_Read_readsPrec :: ReadsPrec Int +prelude_Char_Read_readsPrec p s = [(chr_ (a :: Char), str_ b) | (a,b) <- readsPrec p (map chr s)] + +prelude_Char_Show_showList :: [Int] -> [Int] -> [Int] +prelude_Char_Show_showList value rest = str_ (show (map chr value)) ++ rest + +prelude_Char_Show_showsPrec :: Int -> Int -> [Int] -> [Int] +prelude_Char_Show_showsPrec prec i rest = str_ (showsPrec prec (chr i) []) ++ rest + +prelude_Int_Show_showsPrec :: Int -> Int -> [Int] -> [Int] +prelude_Int_Show_showsPrec prec i rest = str_ (showsPrec prec i []) ++ rest + +prelude_Integer_Show_showsPrec :: Int -> Integer -> [Int] -> [Int] +prelude_Integer_Show_showsPrec prec i rest = str_ (showsPrec prec i []) ++ rest + +prelude_Double_Show_showsPrec :: Int -> Double -> [Int] -> [Int] +prelude_Double_Show_showsPrec prec i rest = str_ (showsPrec prec i []) ++ rest + + +prelude_'amp'amp27 v1 v2 = + case (data_Char_isSpace v1) of + True -> + case v2 of + [] -> True + (:) v4 v5 -> prelude_'amp'amp27 v4 v5 + False -> False + +prelude_LAMBDA22 v1 v2 = + case v1 of + (,) v267 v268 -> + case v268 of + [] -> prelude_LAMBDA24 v267 v2 + (:) v7 v8 -> + let v11 = prelude_'amp'amp27 v7 v8 + in case v11 of + True -> prelude_LAMBDA24 v267 v2 + False -> prelude__foldr25 v2 + +prelude_LAMBDA24 v1 v2 = (:) v1 (prelude__foldr25 v2) + +prelude_IO_Monad_fail41 v1 = + overlay_errorIO + (skipCAF realWorld# (str_ "pattern-match failure in do expression")) + v1 + +prelude__foldr25 v1 = + case v1 of + [] -> [] + (:) v296 v297 -> prelude_LAMBDA22 v296 v297 + +f17 uncaf = skipCAF uncaf (str_ "Prelude.read: no parse") + +f18 v1 v2 = + case v1 of + (,) v176 v177 -> + case v177 of + [] -> f20 v176 v2 + (:) v7 v8 -> + let v11 = prelude_'amp'amp27 v7 v8 + in case v11 of + True -> f20 v176 v2 + False -> + case v2 of + [] -> prelude_error (f17 realWorld#) + (:) v4 v5 -> f18 v4 v5 + +f20 v1 v2 = + case v2 of + [] -> v1 + (:) v257 v258 -> + let v9 = prelude_LAMBDA22 v257 v258 + in case v9 of + [] -> v1 + (:) v10 v11 -> + prelude_error + (skipCAF realWorld# (str_ "Prelude.read: ambiguous parse")) + +f34 v1 v2 v3 = + let v336 = f34 v1 v2 v3 + in v336 + +f38 v1 v2 = + case v1 of + [] -> system_IO_hPutChar system_IO_stdout (chr_ '\n') v2 + (:) v350 v351 -> + case (system_IO_hPutChar + system_IO_stdout + v350 + (typeRealWorld v2)) of + ( v7 , v8 ) -> f38 v351 v7 + +main_generated v1 = + case (system_Environment_getArgs (typeRealWorld v1)) of + ( v3 , v4 ) -> + case v4 of + (:) v7 v8 -> + case v8 of + (:) v9 v12 -> + case v12 of + (:) v13 v14 -> + case v14 of + [] -> + case (prelude_Int_Show_showsPrec + (int_ 0) + (let v8 = + case (prelude_Int_Read_readsPrec + (int_ 0) + v7) of + [] -> prelude_error (f17 realWorld#) + (:) v12 v14 -> f18 v12 v14 + v10 = + case (prelude_Int_Read_readsPrec + (int_ 0) + v9) of + [] -> prelude_error (f17 realWorld#) + (:) v15 v16 -> f18 v15 v16 + v11 = + case (prelude_Int_Read_readsPrec + (int_ 0) + v13) of + [] -> prelude_error (f17 realWorld#) + (:) v17 v18 -> f18 v17 v18 + in case (lT_W v10 v8) of + True -> + let v7 = f34 v8 v10 v11 + in v7 + False -> v11) + (skipCAF realWorld# (str_ ""))) of + [] -> + system_IO_hPutChar + system_IO_stdout + (chr_ '\n') + (typeRealWorld v3) + (:) v11 v12 -> + case (system_IO_hPutChar + system_IO_stdout + v11 + (typeRealWorld (typeRealWorld v3))) of + ( v7 , v8 ) -> f38 v12 v7 + (:) v15 v16 -> prelude_IO_Monad_fail41 v3 + [] -> prelude_IO_Monad_fail41 v3 + [] -> prelude_IO_Monad_fail41 v3 + [] -> prelude_IO_Monad_fail41 v3 + diff --git a/testsuite/tests/simplCore/should_run/simplrun010.stderr b/testsuite/tests/simplCore/should_run/simplrun010.stderr new file mode 100644 index 0000000000..57647f1f92 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/simplrun010.stderr @@ -0,0 +1 @@ +simplrun010: <<loop>> |