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

1 files changed, 35 insertions, 6 deletions

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
 
 -- %************************************************************************
 -- %*                                                                      *