summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/Driver/Main.hs24
-rw-r--r--compiler/GHC/Linker/Loader.hs6
-rw-r--r--compiler/GHC/StgToByteCode.hs44
-rw-r--r--testsuite/tests/th/T20060.hs11
-rw-r--r--testsuite/tests/th/all.T1
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, [''])
View Lorry Controller Status