th: Weaken return type of myCoreToStgExpr

The previous code assumed properties of the CoreToStg translation,
namely that a core let expression which be translated to a single
non-recursive top-level STG binding. This assumption was false, as
evidenced by #20060.

The consequence of this was the need to modify the call sites of
`myCoreToStgExpr`, the main one being in hscCompileCoreExpr', which
the meant we had to use byteCodeGen instead of stgExprToBCOs to convert
the returned value to bytecode.

I removed the `stgExprToBCOs` function as it is no longer
used in the compiler.

There is still some partiallity with this patch (the lookup in
hscCompileCoreExpr') but this should be more robust that before.

Fixes #20060

5 files changed, 30 insertions, 56 deletions

diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index 0ee84f7ca8..cb3c82ebd1 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -121,7 +121,7 @@ import GHC.Hs.Stats         ( ppSourceStats )
 
 import GHC.HsToCore
 
-import GHC.StgToByteCode    ( byteCodeGen, stgExprToBCOs )
+import GHC.StgToByteCode    ( byteCodeGen )
 
 import GHC.IfaceToCore  ( typecheckIface )
 
@@ -223,7 +223,6 @@ import GHC.Data.Stream (Stream)
 import qualified GHC.SysTools
 
 import Data.Data hiding (Fixity, TyCon)
-import Data.Maybe       ( fromJust )
 import Data.List        ( nub, isPrefixOf, partition )
 import Control.Monad
 import Data.IORef
@@ -235,6 +234,7 @@ import Data.Set (Set)
 import Data.Functor
 import Control.DeepSeq (force)
 import Data.Bifunctor (first)
+import GHC.Data.Maybe
 
 {- **********************************************************************
 %*                                                                      *
@@ -1814,7 +1814,8 @@ doCodeGen hsc_env this_mod denv data_tycons
 
 myCoreToStgExpr :: Logger -> DynFlags -> InteractiveContext
                 -> Module -> ModLocation -> CoreExpr
-                -> IO ( StgRhs
+                -> IO ( Id
+                      , [StgTopBinding]
                       , InfoTableProvMap
                       , CollectedCCs )
 myCoreToStgExpr logger dflags ictxt this_mod ml prepd_expr = do
@@ -1824,14 +1825,14 @@ myCoreToStgExpr logger dflags ictxt this_mod ml prepd_expr = do
                                 (mkPseudoUniqueE 0)
                                 Many
                                 (exprType prepd_expr)
-    ([StgTopLifted (StgNonRec _ stg_expr)], prov_map, collected_ccs) <-
+    (stg_binds, prov_map, collected_ccs) <-
        myCoreToStg logger
                    dflags
                    ictxt
                    this_mod
                    ml
                    [NonRec bco_tmp_id prepd_expr]
-    return (stg_expr, prov_map, collected_ccs)
+    return (bco_tmp_id, stg_binds, prov_map, collected_ccs)
 
 myCoreToStg :: Logger -> DynFlags -> InteractiveContext
             -> Module -> ModLocation -> CoreProgram
@@ -2000,7 +2001,7 @@ hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do
                                 stg_binds data_tycons mod_breaks
 
     let src_span = srcLocSpan interactiveSrcLoc
-    liftIO $ loadDecls interp hsc_env (src_span, Nothing) cbc
+    _ <- liftIO $ loadDecls interp hsc_env (src_span, Nothing) cbc
 
     {- Load static pointer table entries -}
     liftIO $ hscAddSptEntries hsc_env Nothing (cg_spt_entries tidy_cg)
@@ -2171,7 +2172,7 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr
                                       ml_hie_file  = panic "hscCompileCoreExpr':ml_hie_file" }
 
          ; let ictxt = hsc_IC hsc_env
-         ; (stg_expr, _, _) <-
+         ; (binding_id, stg_expr, _, _) <-
              myCoreToStgExpr (hsc_logger hsc_env)
                              (hsc_dflags hsc_env)
                              ictxt
@@ -2180,13 +2181,16 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr
                              prepd_expr
 
            {- Convert to BCOs -}
-         ; bcos <- stgExprToBCOs hsc_env
+         ; bcos <- byteCodeGen hsc_env
                      (icInteractiveModule ictxt)
-                     (exprType prepd_expr)
                      stg_expr
+                     [] Nothing
 
            {- load it -}
-         ; loadExpr (hscInterp hsc_env) hsc_env srcspan bcos }
+         ; fv_hvs <- loadDecls (hscInterp hsc_env) hsc_env srcspan bcos
+           {- Get the HValue for the root -}
+         ; return (expectJust "hscCompileCoreExpr'"
+              $ lookup (idName binding_id) fv_hvs) }
 
 
 {- **********************************************************************
diff --git a/compiler/GHC/Linker/Loader.hs b/compiler/GHC/Linker/Loader.hs
index 1b1fca8b17..832d2b0cfd 100644
--- a/compiler/GHC/Linker/Loader.hs
+++ b/compiler/GHC/Linker/Loader.hs
@@ -797,13 +797,13 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods
 
   ********************************************************************* -}
 
-loadDecls :: Interp -> HscEnv -> (SrcSpan, Maybe ModuleNameWithIsBoot) -> CompiledByteCode -> IO ()
+loadDecls :: Interp -> HscEnv -> (SrcSpan, Maybe ModuleNameWithIsBoot) -> CompiledByteCode -> IO [(Name, ForeignHValue)]
 loadDecls interp hsc_env span cbc@CompiledByteCode{..} = do
     -- Initialise the linker (if it's not been done already)
     initLoaderState interp hsc_env
 
     -- Take lock for the actual work.
-    modifyLoaderState_ interp $ \pls0 -> do
+    modifyLoaderState interp $ \pls0 -> do
       -- Link the packages and modules required
       (pls, ok) <- loadDependencies interp hsc_env pls0 span needed_mods
       if failed ok
@@ -819,7 +819,7 @@ loadDecls interp hsc_env span cbc@CompiledByteCode{..} = do
           nms_fhvs <- makeForeignNamedHValueRefs interp new_bindings
           let pls2 = pls { closure_env = extendClosureEnv ce nms_fhvs
                          , itbl_env    = ie }
-          return pls2
+          return (pls2, nms_fhvs)
   where
     free_names = uniqDSetToList $
       foldr (unionUniqDSets . bcoFreeNames) emptyUniqDSet bc_bcos
diff --git a/compiler/GHC/StgToByteCode.hs b/compiler/GHC/StgToByteCode.hs
index 64de0ff05e..78b24c97cd 100644
--- a/compiler/GHC/StgToByteCode.hs
+++ b/compiler/GHC/StgToByteCode.hs
@@ -11,7 +11,7 @@
 --
 
 -- | GHC.StgToByteCode: Generate bytecode from STG
-module GHC.StgToByteCode ( UnlinkedBCO, byteCodeGen, stgExprToBCOs ) where
+module GHC.StgToByteCode ( UnlinkedBCO, byteCodeGen) where
 
 import GHC.Prelude
 
@@ -176,48 +176,6 @@ literals:
    BcM and used when generating code for variable references.
 -}
 
--- -----------------------------------------------------------------------------
--- Generating byte code for an expression
-
--- Returns: the root BCO for this expression
-stgExprToBCOs :: HscEnv
-              -> Module
-              -> Type
-              -> StgRhs
-              -> IO UnlinkedBCO
-stgExprToBCOs hsc_env this_mod expr_ty expr
- = withTiming logger
-              (text "GHC.StgToByteCode"<+>brackets (ppr this_mod))
-              (const ()) $ do
-
-      -- the uniques are needed to generate fresh variables when we introduce new
-      -- let bindings for ticked expressions
-      us <- mkSplitUniqSupply 'y'
-      (BcM_State _dflags _us _this_mod _final_ctr mallocd _ _ _, proto_bco)
-         <- runBc hsc_env us this_mod Nothing emptyVarEnv $ do
-              prepd_expr <- annBindingFreeVars <$>
-                                       bcPrepBind (StgNonRec dummy_id expr)
-              case prepd_expr of
-                (StgNonRec _ cg_expr) -> schemeR [] (idName dummy_id, cg_expr)
-                _                     ->
-                  panic "GHC.StgByteCode.stgExprToBCOs"
-
-      when (notNull mallocd)
-           (panic "GHC.StgToByteCode.stgExprToBCOs: missing final emitBc?")
-
-      putDumpFileMaybe logger Opt_D_dump_BCOs "Proto-BCOs" FormatByteCode
-         (ppr proto_bco)
-
-      assembleOneBCO interp profile proto_bco
-  where dflags  = hsc_dflags hsc_env
-        logger   = hsc_logger hsc_env
-        profile = targetProfile dflags
-        interp  = hscInterp hsc_env
-        -- we need an otherwise unused Id for bytecode generation
-        dummy_id = mkSysLocal (fsLit "BCO_toplevel")
-                              (mkPseudoUniqueE 0)
-                              Many
-                              expr_ty
 {-
   Prepare the STG for bytecode generation:
 
diff --git a/testsuite/tests/th/T20060.hs b/testsuite/tests/th/T20060.hs
new file mode 100644
index 0000000000..cbf78c3215
--- /dev/null
+++ b/testsuite/tests/th/T20060.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -O2 #-}
+module THBug where
+
+data A
+data B
+
+concat <$> mapM (\_ -> (pure []))
+  [ ''A
+  , ''B
+  ]
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 029353cfc3..90ca816cd8 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -529,3 +529,4 @@ test('T17804', normal, compile, [''])
 test('T19470', only_ways(['ghci']), ghci_script, ['T19470.script'])
 test('T19737', normal, compile, [''])
 test('T19759', normal, compile, [''])
+test('T20060', normal, compile, [''])