[commit: testsuite] master: Test the strictness analyzer using annotations (b0358f4)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/testsuite

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/b0358f45fab57e9e2f8afc10a396e1356e340d89/testsuite

>---------------------------------------------------------------

commit b0358f45fab57e9e2f8afc10a396e1356e340d89
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Fri Nov 29 18:58:55 2013 +0000

    Test the strictness analyzer using annotations
    
    This adds a new directory, tests/stranal/sigs. Tests therein are
    expected to use the StrAnalAnnotation GHC plugin (also therein) to
    annotate (some of) their top level functions like this:
    
        foo x = x
        {-# ANN foo (StrAnal "<S,1*U>") #-}
    
    Then the test will fail if the strictness analyzer finds a different
    strictness signature.


>---------------------------------------------------------------

b0358f45fab57e9e2f8afc10a396e1356e340d89
 .../should_compile => stranal/sigs}/Makefile       |    0
 tests/stranal/sigs/StrAnalAnnotation.hs            |   59 ++++++++++++++++++++
 tests/stranal/sigs/StrAnalExample.hs               |   10 ++++
 tests/stranal/sigs/all.T                           |   18 ++++++
 4 files changed, 87 insertions(+)

diff --git a/tests/annotations/should_compile/Makefile b/tests/stranal/sigs/Makefile
similarity index 100%
copy from tests/annotations/should_compile/Makefile
copy to tests/stranal/sigs/Makefile
diff --git a/tests/stranal/sigs/StrAnalAnnotation.hs b/tests/stranal/sigs/StrAnalAnnotation.hs
new file mode 100644
index 0000000..b5bfa75
--- /dev/null
+++ b/tests/stranal/sigs/StrAnalAnnotation.hs
@@ -0,0 +1,59 @@
+{-# 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
new file mode 100644
index 0000000..af9180b
--- /dev/null
+++ b/tests/stranal/sigs/StrAnalExample.hs
@@ -0,0 +1,10 @@
+{-# 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/all.T b/tests/stranal/sigs/all.T
new file mode 100644
index 0000000..89df993
--- /dev/null
+++ b/tests/stranal/sigs/all.T
@@ -0,0 +1,18 @@
+# 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']))
+
+# 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])
+