compiler: make sure we reject -O + HscInterpreted

When using GHCi, we explicitly reject optimization, because the
compilers optimization passes can introduce unboxed tuples, which the
interpreter is not able to handle. But this goes the other way too: using
GHCi on optimized code may cause the optimizer to float out breakpoints
that the interpreter introduces. This manifests itself in weird ways,
particularly if you as an API client use custom DynFlags to introduce
optimization in combination with HscInterpreted.

It turns out we weren't checking for consistent DynFlag settings when
doing `setSessionDynFlags`, as #10052 showed. While the main driver
handled it in `DynFlags` via `parseDynamicFlags`, we didn't check this
elsewhere.

This does a little refactoring to split out some of the common code, and
immunizes the various `DynFlags` utilities in the `GHC` module from this
particular bug. We should probably be checking other general invariants
too.

This fixes #10052, and adds some notes about the behavior in `GHC` and
`FloatOut`

As a bonus, expose `warningMsg` from `ErrUtils` as a helper since it
didn't exist (somehow).

Signed-off-by: Austin Seipp <austin@well-typed.com>

Reviewed By: edsko

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

GHC Trac Issues: #10052

12 files changed, 128 insertions, 13 deletions

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 22615c5f14..26f89c3a15 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -52,6 +52,7 @@ module DynFlags (
         dynFlagDependencies,
         tablesNextToCode, mkTablesNextToCode,
         SigOf, getSigOf,
+        checkOptLevel,
 
         Way(..), mkBuildTag, wayRTSOnly, addWay', updateWays,
         wayGeneralFlags, wayUnsetGeneralFlags,
@@ -3837,13 +3838,14 @@ setObjTarget l = updM set
      | otherwise = return dflags
 
 setOptLevel :: Int -> DynFlags -> DynP DynFlags
-setOptLevel n dflags
+setOptLevel n dflags = return (updOptLevel n dflags)
+
+checkOptLevel :: Int -> DynFlags -> Either String DynFlags
+checkOptLevel n dflags
    | hscTarget dflags == HscInterpreted && n > 0
-        = do addWarn "-O conflicts with --interactive; -O ignored."
-             return dflags
+     = Left "-O conflicts with --interactive; -O ignored."
    | otherwise
-        = return (updOptLevel n dflags)
-
+     = Right dflags
 
 -- -Odph is equivalent to
 --
diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs
index d42db57808..1155b4b874 100644
--- a/compiler/main/ErrUtils.hs
+++ b/compiler/main/ErrUtils.hs
@@ -29,7 +29,7 @@ module ErrUtils (
         --  * Messages during compilation
         putMsg, printInfoForUser, printOutputForUser,
         logInfo, logOutput,
-        errorMsg,
+        errorMsg, warningMsg,
         fatalErrorMsg, fatalErrorMsg', fatalErrorMsg'',
         compilationProgressMsg,
         showPass,
@@ -351,6 +351,10 @@ errorMsg :: DynFlags -> MsgDoc -> IO ()
 errorMsg dflags msg
    = log_action dflags dflags SevError noSrcSpan (defaultErrStyle dflags) msg
 
+warningMsg :: DynFlags -> MsgDoc -> IO ()
+warningMsg dflags msg
+   = log_action dflags dflags SevWarning noSrcSpan (defaultErrStyle dflags) msg
+
 fatalErrorMsg :: DynFlags -> MsgDoc -> IO ()
 fatalErrorMsg dflags msg = fatalErrorMsg' (log_action dflags) dflags msg
 
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index d04f092c17..d6aa2273dc 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -570,17 +570,19 @@ checkBrokenTablesNextToCode' dflags
 --
 setSessionDynFlags :: GhcMonad m => DynFlags -> m [PackageKey]
 setSessionDynFlags dflags = do
-  (dflags', preload) <- liftIO $ initPackages dflags
-  modifySession $ \h -> h{ hsc_dflags = dflags'
-                         , hsc_IC = (hsc_IC h){ ic_dflags = dflags' } }
+  dflags' <- checkNewDynFlags dflags
+  (dflags'', preload) <- liftIO $ initPackages dflags'
+  modifySession $ \h -> h{ hsc_dflags = dflags''
+                         , hsc_IC = (hsc_IC h){ ic_dflags = dflags'' } }
   invalidateModSummaryCache
   return preload
 
 -- | Sets the program 'DynFlags'.
 setProgramDynFlags :: GhcMonad m => DynFlags -> m [PackageKey]
 setProgramDynFlags dflags = do
-  (dflags', preload) <- liftIO $ initPackages dflags
-  modifySession $ \h -> h{ hsc_dflags = dflags' }
+  dflags' <- checkNewDynFlags dflags
+  (dflags'', preload) <- liftIO $ initPackages dflags'
+  modifySession $ \h -> h{ hsc_dflags = dflags'' }
   invalidateModSummaryCache
   return preload
 
@@ -619,7 +621,8 @@ getProgramDynFlags = getSessionDynFlags
 -- 'pkgState' into the interactive @DynFlags@.
 setInteractiveDynFlags :: GhcMonad m => DynFlags -> m ()
 setInteractiveDynFlags dflags = do
-  modifySession $ \h -> h{ hsc_IC = (hsc_IC h) { ic_dflags = dflags }}
+  dflags' <- checkNewDynFlags dflags
+  modifySession $ \h -> h{ hsc_IC = (hsc_IC h) { ic_dflags = dflags' }}
 
 -- | Get the 'DynFlags' used to evaluate interactive expressions.
 getInteractiveDynFlags :: GhcMonad m => m DynFlags
@@ -631,6 +634,32 @@ parseDynamicFlags :: MonadIO m =>
                   -> m (DynFlags, [Located String], [Located String])
 parseDynamicFlags = parseDynamicFlagsCmdLine
 
+{- Note [GHCi and -O]
+~~~~~~~~~~~~~~~~~~~~~
+When using optimization, the compiler can introduce several things
+(such as unboxed tuples) into the intermediate code, which GHCi later
+chokes on since the bytecode interpreter can't handle this (and while
+this is arguably a bug these aren't handled, there are no plans to fix
+it.)
+
+While the driver pipeline always checks for this particular erroneous
+combination when parsing flags, we also need to check when we update
+the flags; this is because API clients may parse flags but update the
+DynFlags afterwords, before finally running code inside a session (see
+T10052 and #10052).
+-}
+
+-- | Checks the set of new DynFlags for possibly erroneous option
+-- combinations when invoking 'setSessionDynFlags' and friends, and if
+-- found, returns a fixed copy (if possible).
+checkNewDynFlags :: MonadIO m => DynFlags -> m DynFlags
+checkNewDynFlags dflags
+  -- See Note [GHCi and -O]
+  | Left e <- checkOptLevel (optLevel dflags) dflags
+    = do liftIO $ warningMsg dflags (text e)
+         return (dflags { optLevel = 0 })
+  | otherwise
+    = return dflags
 
 -- %************************************************************************
 -- %*                                                                      *
diff --git a/compiler/simplCore/FloatOut.hs b/compiler/simplCore/FloatOut.hs
index 7f7b921fa8..7f920a230e 100644
--- a/compiler/simplCore/FloatOut.hs
+++ b/compiler/simplCore/FloatOut.hs
@@ -257,6 +257,32 @@ floatBody lvl arg       -- Used rec rhss, and case-alternative rhss
     (fsa, floats', install heres arg') }}
 
 -----------------
+
+{- Note [Floating past breakpoints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Notes from Peter Wortmann (re: #10052)
+
+"This case clearly means we're trying to float past a breakpoint..."
+
+Further:
+
+"Breakpoints as they currently exist are the only Tikish that is not
+scoped, counting, and not splittable.
+
+This means that we can't:
+  - Simply float code out of it, because the payload must still be covered (scoped)
+  - Copy the tick, because it would change entry counts (here: duplicate breakpoints)"
+
+While this seems like an odd case, it can apparently occur in real
+life: through the combination of optimizations + GHCi usage. For an
+example, see #10052 as mentioned above. So not only does the
+interpreter not like some compiler-generated things (like unboxed
+tuples), the compiler doesn't like interpreter-introduced things!
+
+Also see Note [GHCi and -O] in GHC.hs.
+-}
+
 floatExpr :: LevelledExpr
           -> (FloatStats, FloatBinds, CoreExpr)
 floatExpr (Var v)   = (zeroStats, emptyFloats, Var v)
@@ -292,6 +318,7 @@ floatExpr (Tick tickish expr)
     in
     (fs, annotated_defns, Tick tickish expr') }
 
+  -- Note [Floating past breakpoints]
   | otherwise
   = pprPanic "floatExpr tick" (ppr tickish)
 
diff --git a/testsuite/.gitignore b/testsuite/.gitignore
index ecd0e93062..1855727c56 100644
--- a/testsuite/.gitignore
+++ b/testsuite/.gitignore
@@ -717,6 +717,7 @@ mk/ghcconfig*_inplace_bin_ghc-stage2.exe.mk
 /tests/ghc-api/T8628
 /tests/ghc-api/T8639_api
 /tests/ghc-api/T9595
+/tests/ghc-api/T10052/T10052
 /tests/ghc-api/apirecomp001/myghc
 /tests/ghc-api/dynCompileExpr/dynCompileExpr
 /tests/ghc-api/ghcApi
diff --git a/testsuite/tests/ghc-api/T10052/Makefile b/testsuite/tests/ghc-api/T10052/Makefile
new file mode 100644
index 0000000000..a94ec4ed39
--- /dev/null
+++ b/testsuite/tests/ghc-api/T10052/Makefile
@@ -0,0 +1,12 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+clean:
+	rm -f *.o *.hi
+
+T10052: clean
+	'$(TEST_HC)' $(TEST_HC_OPTS) --make -v0 -package ghc T10052
+	./T10052 "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" -XScopedTypeVariables -O
+
+.PHONY: clean T10052
diff --git a/testsuite/tests/ghc-api/T10052/T10052-input.hs b/testsuite/tests/ghc-api/T10052/T10052-input.hs
new file mode 100644
index 0000000000..89879a7195
--- /dev/null
+++ b/testsuite/tests/ghc-api/T10052/T10052-input.hs
@@ -0,0 +1 @@
+main = let (x :: String) = "hello" in putStrLn x
diff --git a/testsuite/tests/ghc-api/T10052/T10052.hs b/testsuite/tests/ghc-api/T10052/T10052.hs
new file mode 100644
index 0000000000..c2df4ae983
--- /dev/null
+++ b/testsuite/tests/ghc-api/T10052/T10052.hs
@@ -0,0 +1,30 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# OPTIONS_GHC -Wall #-}
+module Main where
+
+import System.Environment
+import GHC
+
+main :: IO ()
+main = do
+    flags <- getArgs
+    runGhc' flags $ do
+      setTargets [Target (TargetFile "T10052-input.hs" Nothing) True Nothing]
+      _success <- load LoadAllTargets
+      return ()
+
+runGhc' :: [String] -> Ghc a -> IO a
+runGhc' args act = do
+    let libdir = head args
+        flags  = tail args
+    (dynFlags, _warns) <- parseStaticFlags (map noLoc flags)
+    runGhc (Just libdir) $ do
+      dflags0 <- getSessionDynFlags
+      (dflags1, _leftover, _warns) <- parseDynamicFlags dflags0 dynFlags
+      let dflags2 = dflags1 {
+              hscTarget = HscInterpreted
+            , ghcLink   = LinkInMemory
+            , verbosity = 1
+            }
+      _newPkgs <- setSessionDynFlags dflags2
+      act
diff --git a/testsuite/tests/ghc-api/T10052/T10052.stderr b/testsuite/tests/ghc-api/T10052/T10052.stderr
new file mode 100644
index 0000000000..d298a59365
--- /dev/null
+++ b/testsuite/tests/ghc-api/T10052/T10052.stderr
@@ -0,0 +1,3 @@
+
+<no location info>: Warning:
+    -O conflicts with --interactive; -O ignored.
diff --git a/testsuite/tests/ghc-api/T10052/T10052.stdout b/testsuite/tests/ghc-api/T10052/T10052.stdout
new file mode 100644
index 0000000000..1a909eb36f
--- /dev/null
+++ b/testsuite/tests/ghc-api/T10052/T10052.stdout
@@ -0,0 +1 @@
+[1 of 1] Compiling Main             ( T10052-input.hs, interpreted )
diff --git a/testsuite/tests/ghc-api/T10052/all.T b/testsuite/tests/ghc-api/T10052/all.T
new file mode 100644
index 0000000000..bb73f85fa1
--- /dev/null
+++ b/testsuite/tests/ghc-api/T10052/all.T
@@ -0,0 +1,2 @@
+test('T10052', normal, run_command,
+               ['$MAKE -s --no-print-directory T10052'])
diff --git a/testsuite/tests/ghci.debugger/scripts/print007.stderr b/testsuite/tests/ghci.debugger/scripts/print007.stderr
index d298a59365..0debeb40c9 100644
--- a/testsuite/tests/ghci.debugger/scripts/print007.stderr
+++ b/testsuite/tests/ghci.debugger/scripts/print007.stderr
@@ -1,3 +1,6 @@
 
-<no location info>: Warning:
+<no location info>: warning:
+    -O conflicts with --interactive; -O ignored.
+
+<no location info>: warning:
     -O conflicts with --interactive; -O ignored.