Compile modules with `-fobject-code` enabled to byte-code when loaded with `*` prefix in ghci (#8042)

The documentation states that when using :add and :load, the `*` prefix forces a module
to be loaded as byte-code. However, this seems to be ignored when -fobject-code has been
enabled. In that case, the compiled code is always used, regardless of whether the *-form
is used.

The idea is to consult the Targets in HscEnv and check the 'targetAllowObjCode' flag. If
the flag for given module is set, then patch up DynFlags and select compilation backend
accordingly.

This would require a linear scan of course, but that shouldn't be too costly.

5 files changed, 49 insertions, 6 deletions

diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index 8d0159b800..7ca219bc48 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -316,8 +316,19 @@ compileOne' m_tc_result mHscMessage
        current_dir = takeDirectory basename
        old_paths   = includePaths dflags2
        !prevailing_dflags = hsc_dflags hsc_env0
+       -- Figure out which backend we're using
+       (bcknd, dflags3)
+         -- #8042: When module was loaded with `*` prefix in ghci, but DynFlags
+         -- suggest to generate object code (which may happen in case -fobject-code
+         -- was set), force it to generate byte-code. This is NOT transitive and
+         -- only applies to direct targets.
+         | Just (Target _ obj _) <- findTarget summary (hsc_targets hsc_env0)
+         , not obj
+         = (Interpreter, dflags2 { backend = Interpreter })
+         | otherwise
+         = (backend dflags, dflags2)
        dflags =
-          dflags2 { includePaths = addQuoteInclude old_paths [current_dir]
+          dflags3 { includePaths = addQuoteInclude old_paths [current_dir]
                   , log_action = log_action prevailing_dflags }
                   -- use the prevailing log_action / log_finaliser,
                   -- not the one cached in the summary.  This is so
@@ -325,9 +336,6 @@ compileOne' m_tc_result mHscMessage
                   -- to re-summarize all the source files.
        hsc_env     = hsc_env0 {hsc_dflags = dflags}
 
-       -- Figure out which backend we're using
-       bcknd = backend dflags
-
        -- -fforce-recomp should also work with --make
        force_recomp = gopt Opt_ForceRecomp dflags
        source_modified
diff --git a/compiler/GHC/Driver/Types.hs b/compiler/GHC/Driver/Types.hs
index 6409e6128c..3bc3167031 100644
--- a/compiler/GHC/Driver/Types.hs
+++ b/compiler/GHC/Driver/Types.hs
@@ -19,7 +19,7 @@ module GHC.Driver.Types (
         -- * compilation state
         HscEnv(..), hscEPS,
         FinderCache, FindResult(..), InstalledFindResult(..),
-        Target(..), TargetId(..), InputFileBuffer, pprTarget, pprTargetId,
+        Target(..), TargetId(..), InputFileBuffer, pprTarget, pprTargetId, findTarget,
         HscStatus(..),
 
         -- * ModuleGraph
@@ -605,7 +605,7 @@ type InputFileBuffer = StringBuffer
 
 pprTarget :: Target -> SDoc
 pprTarget (Target id obj _) =
-    (if obj then char '*' else empty) <> pprTargetId id
+    (if obj then empty else char '*') <> pprTargetId id
 
 instance Outputable Target where
     ppr = pprTarget
@@ -617,6 +617,20 @@ pprTargetId (TargetFile f _) = text f
 instance Outputable TargetId where
     ppr = pprTargetId
 
+findTarget :: ModSummary -> [Target] -> Maybe Target
+findTarget ms ts =
+  case filter (matches ms) ts of
+        []    -> Nothing
+        (t:_) -> Just t
+  where
+    summary `matches` Target (TargetModule m) _ _
+        = ms_mod_name summary == m
+    summary `matches` Target (TargetFile f _) _ _
+        | Just f' <- ml_hs_file (ms_location summary)
+        = f == f'
+    _ `matches` _
+        = False
+
 {-
 ************************************************************************
 *                                                                      *
diff --git a/testsuite/tests/ghci/scripts/T8042.script b/testsuite/tests/ghci/scripts/T8042.script
new file mode 100644
index 0000000000..748db8a9d8
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T8042.script
@@ -0,0 +1,11 @@
+:set -v1
+System.IO.writeFile "T8042B.hs" "{-# OPTIONS_GHC -fobject-code #-} module T8042B where { type I = Int; }"
+System.IO.writeFile "T8042C.hs" "module T8042C where { type B = Bool; }"
+System.IO.writeFile "T8042A.hs" "module T8042A where { import T8042B; import T8042C }"
+-- no `*` prefix so should compile object-code for B only
+:load T8042A
+System.IO.writeFile "T8042A.hs" "{-# OPTIONS_GHC -fobject-code #-} module T8042A where { import T8042B; import T8042C }"
+-- should compile object-code for A now
+:reload
+-- with `*` prefix should compile byte-code for A
+:load *T8042A
diff --git a/testsuite/tests/ghci/scripts/T8042.stdout b/testsuite/tests/ghci/scripts/T8042.stdout
new file mode 100644
index 0000000000..fe2720d35d
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T8042.stdout
@@ -0,0 +1,9 @@
+[1 of 3] Compiling T8042B           ( T8042B.hs, T8042B.o )
+[2 of 3] Compiling T8042C           ( T8042C.hs, interpreted )
+[3 of 3] Compiling T8042A           ( T8042A.hs, interpreted )
+Ok, three modules loaded.
+[3 of 3] Compiling T8042A           ( T8042A.hs, T8042A.o )
+Ok, three modules loaded.
+[2 of 3] Compiling T8042C           ( T8042C.hs, interpreted )
+[3 of 3] Compiling T8042A           ( T8042A.hs, interpreted )
+Ok, three modules loaded.
diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T
index e3a84eb764..dde0e90539 100755
--- a/testsuite/tests/ghci/scripts/all.T
+++ b/testsuite/tests/ghci/scripts/all.T
@@ -174,6 +174,7 @@ test('T7872', normal, ghci_script, ['T7872.script'])
 test('T7873', normal, ghci_script, ['T7873.script'])
 test('T7939', normal, ghci_script, ['T7939.script'])
 test('T7894', normal, ghci_script, ['T7894.script'])
+test('T8042', normal, ghci_script, ['T8042.script'])
 test('T8116', normal, ghci_script, ['T8116.script'])
 test('T8113', normal, ghci_script, ['T8113.script'])
 test('T8172', when(opsys('mingw32'), normalise_drive_letter),