[commit: testsuite] master: Use -ddump-strsigs in tests/stranal/sigs (323cab2)
git at git.haskell.org
git at git.haskell.org
Mon Dec 9 15:40:49 UTC 2013
Repository : ssh://git@git.haskell.org/testsuite
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/323cab22d65ea88410a607ef22db23198c03e305/testsuite
>---------------------------------------------------------------
commit 323cab22d65ea88410a607ef22db23198c03e305
Author: Joachim Breitner <mail at joachim-breitner.de>
Date: Mon Dec 9 15:40:20 2013 +0000
Use -ddump-strsigs in tests/stranal/sigs
because it is more reliable than the previous GHC plugin (no need to
support annotations etc.), plus it works nicely with "make accept".
>---------------------------------------------------------------
323cab22d65ea88410a607ef22db23198c03e305
tests/stranal/sigs/HyperStrUse.hs | 4 --
tests/stranal/sigs/HyperStrUse.stderr | 5 +++
tests/stranal/sigs/StrAnalAnnotation.hs | 59 ------------------------------
tests/stranal/sigs/StrAnalExample.hs | 5 ---
tests/stranal/sigs/StrAnalExample.stderr | 5 +++
tests/stranal/sigs/T8569.hs | 4 --
tests/stranal/sigs/T8569.stderr | 5 +++
tests/stranal/sigs/T8598.hs | 3 --
tests/stranal/sigs/T8598.stderr | 5 +++
tests/stranal/sigs/all.T | 18 +++------
10 files changed, 25 insertions(+), 88 deletions(-)
diff --git a/tests/stranal/sigs/HyperStrUse.hs b/tests/stranal/sigs/HyperStrUse.hs
index 88ba3e3..14bdea4 100644
--- a/tests/stranal/sigs/HyperStrUse.hs
+++ b/tests/stranal/sigs/HyperStrUse.hs
@@ -1,9 +1,5 @@
-{-# OPTIONS_GHC -fplugin StrAnalAnnotation #-}
module HyperStrUse where
-import StrAnalAnnotation (StrAnal(StrAnal))
-
f :: (Int, Int) -> Bool -> Int
f (x,y) True = error (show x)
f (x,y) False = x +1
-{-# ANN f (StrAnal "<S(SL),1*U(1*U(U),A)><S,1*U>m") #-}
diff --git a/tests/stranal/sigs/HyperStrUse.stderr b/tests/stranal/sigs/HyperStrUse.stderr
new file mode 100644
index 0000000..1a0ff33
--- /dev/null
+++ b/tests/stranal/sigs/HyperStrUse.stderr
@@ -0,0 +1,5 @@
+
+==================== Strictness signatures ====================
+HyperStrUse.f: <S(SL),1*U(1*U(U),A)><S,1*U>m
+
+
diff --git a/tests/stranal/sigs/StrAnalAnnotation.hs b/tests/stranal/sigs/StrAnalAnnotation.hs
deleted file mode 100644
index b5bfa75..0000000
--- a/tests/stranal/sigs/StrAnalAnnotation.hs
+++ /dev/null
@@ -1,59 +0,0 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-
-
--- | This module is not used in GHC. Rather, it is a module that
--- can be used to annotate functions with expected result of the demand
--- analyzer, and it will print warnings if they do not match.
--- This is primarily used for the GHC testsuite, but you can use it in your own
--- test suites as well.
-module StrAnalAnnotation (plugin, StrAnal(..)) where
-
-import GhcPlugins
-import Demand (StrictSig, pprIfaceStrictSig)
-
-import Data.Data
-import Control.Monad
-
--- | Use this to annotate your functions
-data StrAnal= StrAnal String deriving (Data, Typeable)
-
-plugin :: Plugin
-plugin = defaultPlugin {
- installCoreToDos = install
- }
-
-install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
-install _ todo = do
- reinitializeGlobals
- return (todo ++ [CoreDoPluginPass "Strictness Analzier result test" pass])
-
-pass :: ModGuts -> CoreM ModGuts
-pass g = mapM_ (printAnn g) (allIds (mg_binds g)) >> return g
-
-printAnn :: ModGuts -> Id -> CoreM ()
-printAnn guts b = do
- anns <- annotationsOn guts b :: CoreM [StrAnal]
- flags <- getDynFlags
- mapM_ (report flags b) anns
-
-report :: DynFlags -> Id -> StrAnal -> CoreM ()
-report flags id (StrAnal ann)
- | sigStr == ann = return ()
- | otherwise = putMsg $
- hang (text "Mismatch in expected strictness signature:") 4 $
- vcat [ text "name: " <+> ppr id
- , text "expected:" <+> text ann
- , text "found: " <+> text sigStr
- ]
- where sig = idStrictness id
- sigStr = showSDoc flags (pprIfaceStrictSig (idStrictness id))
-
-allIds :: CoreProgram -> [Id]
-allIds = concatMap go
- where go (NonRec i _) = [i]
- go (Rec bs) = map fst bs
-
-annotationsOn :: Data a => ModGuts -> CoreBndr -> CoreM [a]
-annotationsOn guts bndr = do
- anns <- getAnnotations deserializeWithData guts
- return $ lookupWithDefaultUFM anns [] (varUnique bndr)
diff --git a/tests/stranal/sigs/StrAnalExample.hs b/tests/stranal/sigs/StrAnalExample.hs
index af9180b..0ac61b9 100644
--- a/tests/stranal/sigs/StrAnalExample.hs
+++ b/tests/stranal/sigs/StrAnalExample.hs
@@ -1,10 +1,5 @@
-{-# OPTIONS_GHC -fplugin StrAnalAnnotation #-}
-
-- Just an example on how to create tests that test the strictness analizer
module StrAnalExample where
-import StrAnalAnnotation (StrAnal(StrAnal))
-
foo x = x
-{-# ANN foo (StrAnal "<S,1*U>") #-}
diff --git a/tests/stranal/sigs/StrAnalExample.stderr b/tests/stranal/sigs/StrAnalExample.stderr
new file mode 100644
index 0000000..dbe4770
--- /dev/null
+++ b/tests/stranal/sigs/StrAnalExample.stderr
@@ -0,0 +1,5 @@
+
+==================== Strictness signatures ====================
+StrAnalExample.foo: <S,1*U>
+
+
diff --git a/tests/stranal/sigs/T8569.hs b/tests/stranal/sigs/T8569.hs
index ee6c413..17f7595 100644
--- a/tests/stranal/sigs/T8569.hs
+++ b/tests/stranal/sigs/T8569.hs
@@ -1,10 +1,7 @@
-{-# OPTIONS_GHC -fplugin StrAnalAnnotation #-}
{-# LANGUAGE GADTs #-}
module T8569 where
-import StrAnalAnnotation (StrAnal(StrAnal))
-
data Rep t where
Rint :: Rep Int
Rdata :: Rep i -> (t -> i) -> Rep t
@@ -12,4 +9,3 @@ data Rep t where
addUp :: Rep a -> a -> Int
addUp Rint n = n
addUp (Rdata i f) x = addUp i (f x)
-{-# ANN addUp (StrAnal "<S,1*U><L,U>") #-}
diff --git a/tests/stranal/sigs/T8569.stderr b/tests/stranal/sigs/T8569.stderr
new file mode 100644
index 0000000..d33935e
--- /dev/null
+++ b/tests/stranal/sigs/T8569.stderr
@@ -0,0 +1,5 @@
+
+==================== Strictness signatures ====================
+T8569.addUp: <S,1*U><L,U>
+
+
diff --git a/tests/stranal/sigs/T8598.hs b/tests/stranal/sigs/T8598.hs
index 55c1a35..1e0ca6f 100644
--- a/tests/stranal/sigs/T8598.hs
+++ b/tests/stranal/sigs/T8598.hs
@@ -1,11 +1,9 @@
-{-# OPTIONS_GHC -fplugin StrAnalAnnotation #-}
{-# LANGUAGE MagicHash , UnboxedTuples #-}
module T8598(fun) where
import GHC.Float (Double(..))
import GHC.Integer (decodeDoubleInteger, encodeDoubleInteger)
-import StrAnalAnnotation (StrAnal(StrAnal))
-- Float.scaleFloat for Doubles, slightly simplified
fun :: Double -> Double
@@ -15,6 +13,5 @@ fun x | isFix = x
(# i, j #) -> D# (encodeDoubleInteger i j)
where
isFix = isDoubleFinite x == 0
-{-# ANN fun (StrAnal "<S(S),1*U(U)>m") #-}
foreign import ccall unsafe "isDoubleFinite" isDoubleFinite :: Double -> Int
diff --git a/tests/stranal/sigs/T8598.stderr b/tests/stranal/sigs/T8598.stderr
new file mode 100644
index 0000000..8de5d31
--- /dev/null
+++ b/tests/stranal/sigs/T8598.stderr
@@ -0,0 +1,5 @@
+
+==================== Strictness signatures ====================
+T8598.fun: <S(S),1*U(U)>m
+
+
diff --git a/tests/stranal/sigs/all.T b/tests/stranal/sigs/all.T
index aee2ab3..247a077 100644
--- a/tests/stranal/sigs/all.T
+++ b/tests/stranal/sigs/all.T
@@ -1,22 +1,14 @@
# This directory contains tests where we annotate functions with expected
# type signatures, and verify that these actually those found by the compiler
-def f(name, opts):
- if (ghc_with_interpreter == 0):
- opts.skip = 1
-
-setTestOpts(f)
-setTestOpts(when(compiler_lt('ghc', '7.1'), skip))
-setTestOpts(extra_clean(['StrAnalAnnotation.hi','StrAnalAnnotation.o']))
+setTestOpts(extra_hc_opts('-ddump-strsigs'))
# We are testing the result of an optimization, so no use
# running them in various runtimes
setTestOpts(only_ways(['optasm']))
-# Use this as a template
-test('StrAnalExample', normal, compile, ['--make -package ghc -v0 ' + config.ghc_th_way_flags])
-
-test('T8569', expect_broken(8569), compile, ['--make -package ghc -v0 ' + config.ghc_th_way_flags])
-test('HyperStrUse', normal, compile, ['--make -package ghc -v0 ' + config.ghc_th_way_flags])
-test('T8598', expect_broken(8598), compile, ['--make -package ghc -v0 ' + config.ghc_th_way_flags])
+test('StrAnalExample', normal, compile, [''])
+test('T8569', expect_broken(8569), compile, [''])
+test('HyperStrUse', normal, compile, [''])
+test('T8598', expect_broken(8598), compile, [''])
More information about the ghc-commits
mailing list