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.

4 files changed, 90 insertions, 0 deletions

diff --git a/testsuite/tests/stranal/sigs/Makefile b/testsuite/tests/stranal/sigs/Makefile
new file mode 100644
index 0000000000..9101fbd40a
--- /dev/null
+++ b/testsuite/tests/stranal/sigs/Makefile
@@ -0,0 +1,3 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/stranal/sigs/StrAnalAnnotation.hs b/testsuite/tests/stranal/sigs/StrAnalAnnotation.hs
new file mode 100644
index 0000000000..b5bfa75a69
--- /dev/null
+++ b/testsuite/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/testsuite/tests/stranal/sigs/StrAnalExample.hs b/testsuite/tests/stranal/sigs/StrAnalExample.hs
new file mode 100644
index 0000000000..af9180ba43
--- /dev/null
+++ b/testsuite/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/testsuite/tests/stranal/sigs/all.T b/testsuite/tests/stranal/sigs/all.T
new file mode 100644
index 0000000000..89df99386b
--- /dev/null
+++ b/testsuite/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])
+