Have static pointers work with -fno-full-laziness.

Summary:
Before this patch, static pointers wouldn't be floated to
the top-level.

Test Plan: ./validate

Reviewers: simonpj, bgamari, austin

Subscribers: mboes, thomie

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

GHC Trac Issues: #11656

4 files changed, 61 insertions, 9 deletions

diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs
index 0af167ef3e..ca869dc8dd 100644
--- a/compiler/simplCore/SimplCore.hs
+++ b/compiler/simplCore/SimplCore.hs
@@ -204,16 +204,20 @@ getCoreToDo dflags
                            [simpl_phase 0 ["post-worker-wrapper"] max_iter]
                            ))
 
+    -- Static forms are moved to the top level with the FloatOut pass.
+    -- See Note [Grand plan for static forms].
+    static_ptrs_float_outwards =
+      runWhen static_ptrs $ CoreDoFloatOutwards FloatOutSwitches
+        { floatOutLambdas   = Just 0
+        , floatOutConstants = True
+        , floatOutOverSatApps = False
+        , floatToTopLevelOnly = True
+        }
+
     core_todo =
      if opt_level == 0 then
        [ vectorisation,
-         -- Static forms are moved to the top level with the FloatOut pass.
-         -- See Note [Grand plan for static forms].
-         runWhen static_ptrs $ CoreDoFloatOutwards FloatOutSwitches {
-                                 floatOutLambdas   = Just 0,
-                                 floatOutConstants = True,
-                                 floatOutOverSatApps = False,
-                                 floatToTopLevelOnly = True },
+         static_ptrs_float_outwards,
          CoreDoSimplify max_iter
              (base_mode { sm_phase = Phase 0
                         , sm_names = ["Non-opt simplification"] })
@@ -238,12 +242,12 @@ getCoreToDo dflags
         -- so that overloaded functions have all their dictionary lambdas manifest
         runWhen do_specialise CoreDoSpecialising,
 
-        runWhen full_laziness $
+        if full_laziness then
            CoreDoFloatOutwards FloatOutSwitches {
                                  floatOutLambdas   = Just 0,
                                  floatOutConstants = True,
                                  floatOutOverSatApps = False,
-                                 floatToTopLevelOnly = False },
+                                 floatToTopLevelOnly = False }
                 -- Was: gentleFloatOutSwitches
                 --
                 -- I have no idea why, but not floating constants to
@@ -261,6 +265,10 @@ getCoreToDo dflags
                 -- difference at all to performance if we do it here,
                 -- but maybe we save some unnecessary to-and-fro in
                 -- the simplifier.
+        else
+           -- Even with full laziness turned off, we still need to float static
+           -- forms to the top level. See Note [Grand plan for static forms].
+           static_ptrs_float_outwards,
 
         simpl_phases,
 
diff --git a/testsuite/tests/codeGen/should_run/CgStaticPointersNoFullLazyness.hs b/testsuite/tests/codeGen/should_run/CgStaticPointersNoFullLazyness.hs
new file mode 100644
index 0000000000..66363ded6f
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/CgStaticPointersNoFullLazyness.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE LambdaCase         #-}
+{-# LANGUAGE StaticPointers     #-}
+
+-- | A test to use symbols produced by the static form.
+module Main(main) where
+
+import Data.Typeable
+import GHC.StaticPtr
+
+main :: IO ()
+main = do
+  lookupKey (static (id . id)) >>= \f -> print $ f (1 :: Int)
+  lookupKey (static method :: StaticPtr (Char -> Int)) >>= \f -> print $ f 'a'
+  print $ deRefStaticPtr (static g)
+  print $ deRefStaticPtr p0 'a'
+  print $ deRefStaticPtr (static t_field) $ T 'b'
+ where
+  g :: String
+  g = "found"
+
+lookupKey :: StaticPtr a -> IO a
+lookupKey p = unsafeLookupStaticPtr (staticKey p) >>= \case
+  Just p -> return $ deRefStaticPtr p
+  Nothing -> error $ "couldn't find " ++ show (staticPtrInfo p)
+
+p0 :: Typeable a => StaticPtr (a -> a)
+p0 = static (\x -> x)
+
+data T a = T { t_field :: a }
+  deriving Typeable
+
+class C1 a where
+  method :: a -> Int
+
+instance C1 Char where
+  method = const 0
diff --git a/testsuite/tests/codeGen/should_run/CgStaticPointersNoFullLazyness.stdout b/testsuite/tests/codeGen/should_run/CgStaticPointersNoFullLazyness.stdout
new file mode 100644
index 0000000000..7b31e7fa2c
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/CgStaticPointersNoFullLazyness.stdout
@@ -0,0 +1,5 @@
+1
+0
+"found"
+'a'
+'b'
diff --git a/testsuite/tests/codeGen/should_run/all.T b/testsuite/tests/codeGen/should_run/all.T
index 65e3dc06e8..23caa8cc3c 100644
--- a/testsuite/tests/codeGen/should_run/all.T
+++ b/testsuite/tests/codeGen/should_run/all.T
@@ -119,6 +119,8 @@ test('T8256', normal, compile_and_run, ['-dcore-lint -O1'])
 test('T6084',normal, compile_and_run, ['-O2'])
 test('CgStaticPointers', [when(doing_ghci(), extra_hc_opts('-fobject-code'))],
      compile_and_run, [''])
+test('CgStaticPointersNoFullLazyness', [when(doing_ghci(), extra_hc_opts('-fobject-code'))],
+     compile_and_run, ['-O -fno-full-laziness'])
 test('StaticArraySize', [when(doing_ghci(), extra_hc_opts('-fobject-code'))],
      compile_and_run, ['-O2'])
 test('StaticByteArraySize', normal, compile_and_run, ['-O2'])