Support SCC pragmas in declaration context

Not having SCCs at the top level is becoming annoying real quick. For
simplest cases, it's possible to do this transformation:

    f x y = ...
    =>
    f = {-# SCC f #-} \x y -> ...

However, it doesn't work when there's a `where` clause:

    f x y = <t is in scope>
      where t = ...
    =>
    f = {-# SCC f #-} \x y -> <t is out of scope>
      where t = ...

Or when we have a "equation style" definition:

    f (C1 ...) = ...
    f (C2 ...) = ...
    f (C3 ...) = ...
    ...

(usual solution is to rename `f` to `f'` and define a new `f` with a
`SCC`)

This patch implements support for SCC annotations in declaration
contexts. This is now a valid program:

    f x y = ...
      where
        g z = ...
        {-# SCC g #-}
    {-# SCC f #-}

Test Plan: This passes slow validate (no new failures added).

Reviewers: goldfire, mpickering, austin, bgamari, simonmar

Reviewed By: bgamari, simonmar

Subscribers: simonmar, thomie, mpickering

Differential Revision: https://phabricator.haskell.org/D2407

6 files changed, 63 insertions, 1 deletions

diff --git a/testsuite/config/ghc b/testsuite/config/ghc
index 68d4a64979..b0d84535d6 100644
--- a/testsuite/config/ghc
+++ b/testsuite/config/ghc
@@ -76,6 +76,7 @@ config.way_flags = {
     'optllvm'      : ['-O', '-fllvm'],
     'debugllvm'    : ['-fllvm', '-keep-llvm-files'],
     'prof'         : ['-prof', '-static', '-fprof-auto', '-fasm'],
+    'prof_no_auto' : ['-prof', '-static', '-fasm'],
     'profasm'      : ['-O', '-prof', '-static', '-fprof-auto'],
     'profthreaded' : ['-O', '-prof', '-static', '-fprof-auto', '-threaded'],
     'ghci'         : ['--interactive', '-v0', '-ignore-dot-ghci', '-fno-ghci-history', '+RTS', '-I0.1', '-RTS'],
@@ -111,6 +112,7 @@ config.way_rts_flags = {
     'optllvm'      : [],
     'debugllvm'    : [],
     'prof'         : ['-p'],
+    'prof_no_auto' : ['-p'],
     'profasm'      : ['-hc', '-p'], # test heap profiling too
     'profthreaded' : ['-p'],
     'ghci'         : [],
diff --git a/testsuite/tests/profiling/should_run/all.T b/testsuite/tests/profiling/should_run/all.T
index 76956bd220..7aa7977350 100644
--- a/testsuite/tests/profiling/should_run/all.T
+++ b/testsuite/tests/profiling/should_run/all.T
@@ -104,7 +104,7 @@ test('T11627a', [extra_ways(extra_prof_ways)], compile_and_run, [''])
 test('T11627b', [ extra_run_opts('+RTS -i0 -RTS')  # census after each GC
                 , extra_ways(extra_prof_ways)
                 , when(opsys('mingw32'),
-                       expect_broken_for(12236, ['prof_hc_hb'])) 
+                       expect_broken_for(12236, ['prof_hc_hb']))
                 ]
                 , compile_and_run
                 , [''])
@@ -112,3 +112,8 @@ test('T11627b', [ extra_run_opts('+RTS -i0 -RTS')  # census after each GC
 test('T11978a',
      [only_ways(['profthreaded']), extra_run_opts('+RTS -hb -N10')],
      compile_and_run, [''])
+
+test('toplevel_scc_1',
+     [extra_ways(['prof_no_auto']), only_ways(['prof_no_auto'])],
+     compile_and_run,
+     [''])
diff --git a/testsuite/tests/profiling/should_run/toplevel_scc_1.hs b/testsuite/tests/profiling/should_run/toplevel_scc_1.hs
new file mode 100644
index 0000000000..6890511391
--- /dev/null
+++ b/testsuite/tests/profiling/should_run/toplevel_scc_1.hs
@@ -0,0 +1,23 @@
+module Main where
+
+f1 :: Int -> Int
+f1 = (+ 1)
+
+f2 :: Int -> Int
+f2 = f3 . f3 . f3
+  where
+    f3 :: Int -> Int
+    f3 = (* 123)
+    {-# SCC f3 "bar" #-}
+    {-# NOINLINE f3 #-}
+
+
+
+main :: IO ()
+main = readLn >>= print . f2 . f1
+
+{-# NOINLINE f1 #-}
+{-# NOINLINE f2 #-}
+
+{-# SCC f1 #-}
+{-# SCC f2 "foo" #-}
diff --git a/testsuite/tests/profiling/should_run/toplevel_scc_1.prof.sample b/testsuite/tests/profiling/should_run/toplevel_scc_1.prof.sample
new file mode 100644
index 0000000000..4eec28da28
--- /dev/null
+++ b/testsuite/tests/profiling/should_run/toplevel_scc_1.prof.sample
@@ -0,0 +1,30 @@
+	Tue Jul 19 08:36 2016 Time and Allocation Profiling Report  (Final)
+
+	   toplevel_scc_1 +RTS -p -RTS
+
+	total time  =        0.00 secs   (0 ticks @ 1000 us, 1 processor)
+	total alloc =      79,792 bytes  (excludes profiling overheads)
+
+COST CENTRE MODULE           SRC              %time %alloc
+
+CAF         GHC.Read         <entire-module>    0.0    1.2
+CAF         GHC.IO.Handle.FD <entire-module>    0.0   64.9
+CAF         GHC.IO.Encoding  <entire-module>    0.0    3.5
+CAF         Main             <entire-module>    0.0   27.6
+
+
+                                                                              individual      inherited
+COST CENTRE MODULE                SRC                      no.     entries  %time %alloc   %time %alloc
+
+MAIN        MAIN                  <built-in>               105          0    0.0    0.4     0.0  100.0
+ CAF        Main                  <entire-module>          209          0    0.0   27.6     0.0   27.9
+  Main.f1   Main                  toplevel_scc_1.hs:4:1-2  212          1    0.0    0.0     0.0    0.0
+  Main.foo  Main                  toplevel_scc_1.hs:7:1-2  210          1    0.0    0.2     0.0    0.3
+   Main.bar Main                  toplevel_scc_1.hs:10:5-6 211          1    0.0    0.1     0.0    0.1
+ CAF        GHC.Conc.Signal       <entire-module>          203          0    0.0    0.8     0.0    0.8
+ CAF        GHC.IO.Encoding       <entire-module>          193          0    0.0    3.5     0.0    3.5
+ CAF        GHC.IO.Encoding.Iconv <entire-module>          191          0    0.0    0.3     0.0    0.3
+ CAF        GHC.IO.Handle.FD      <entire-module>          183          0    0.0   64.9     0.0   64.9
+ CAF        GHC.IO.Handle.Text    <entire-module>          181          0    0.0    0.1     0.0    0.1
+ CAF        GHC.Read              <entire-module>          171          0    0.0    1.2     0.0    1.2
+ CAF        Text.Read.Lex         <entire-module>          154          0    0.0    0.8     0.0    0.8
diff --git a/testsuite/tests/profiling/should_run/toplevel_scc_1.stdin b/testsuite/tests/profiling/should_run/toplevel_scc_1.stdin
new file mode 100644
index 0000000000..190a18037c
--- /dev/null
+++ b/testsuite/tests/profiling/should_run/toplevel_scc_1.stdin
@@ -0,0 +1 @@
+123
diff --git a/testsuite/tests/profiling/should_run/toplevel_scc_1.stdout b/testsuite/tests/profiling/should_run/toplevel_scc_1.stdout
new file mode 100644
index 0000000000..bfb8a3a41f
--- /dev/null
+++ b/testsuite/tests/profiling/should_run/toplevel_scc_1.stdout
@@ -0,0 +1 @@
+230747508