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

3 files changed, 49 insertions, 17 deletions

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index d8f5169122..f8f72b1a16 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,
@@ -2563,11 +2564,11 @@ dynamic_flags = [
   , defGhcFlag "fplugin"     (hasArg addPluginModuleName)
 
         ------ Optimisation flags ------------------------------------------
-  , defGhcFlag "O"      (noArgM (setOptLevel 1))
+  , defGhcFlag "O"      (noArgM (updOptLevel 1))
   , defGhcFlag "Onot"   (noArgM (\dflags -> do deprecate "Use -O0 instead"
-                                               setOptLevel 0 dflags))
+                                               updOptLevel 0 dflags))
   , defGhcFlag "Odph"   (noArgM setDPHOpt)
-  , defGhcFlag "O"      (optIntSuffixM (\mb_n -> setOptLevel (mb_n `orElse` 1)))
+  , defGhcFlag "O"      (optIntSuffixM (\mb_n -> updOptLevel (mb_n `orElse` 1)))
                 -- If the number is missing, use 1
 
 
@@ -3862,14 +3863,12 @@ setObjTarget l = updM set
        = return $ dflags { hscTarget = l }
      | otherwise = return dflags
 
-setOptLevel :: Int -> DynFlags -> DynP DynFlags
-setOptLevel 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
 --
@@ -3878,7 +3877,7 @@ setOptLevel n dflags
 --    -fsimplifier-phases=3             we use an additional simplifier phase for fusion
 --
 setDPHOpt :: DynFlags -> DynP DynFlags
-setDPHOpt dflags = setOptLevel 2 (dflags { maxSimplIterations  = 20
+setDPHOpt dflags = updOptLevel 2 (dflags { maxSimplIterations  = 20
                                          , simplPhases         = 3
                                          })
 
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 a0a0262bcc..79c6dca5ef 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
 
 -- %************************************************************************
 -- %*                                                                      *