Don't ignore addTopDecls in module finalizers.

Summary:
Module finalizer could call addTopDecls, however, the declarations
added in this fashion were ignored. This patch makes sure to rename,
type check and incorporate this declarations.

Because a declaration may include a splice which calls addModFinalizer,
the list of finalizers is repeteadly checked after adding declarations
until no more finalizers remain.

Test Plan: ./validate

Reviewers: bgamari, goldfire, simonpj, austin

Reviewed By: bgamari, simonpj

Subscribers: simonmar, mboes, thomie

Differential Revision: https://phabricator.haskell.org/D2505

GHC Trac Issues: #12559

7 files changed, 43 insertions, 8 deletions

diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs
index 1b99376a51..4b2e561d29 100644
--- a/compiler/rename/RnSplice.hs
+++ b/compiler/rename/RnSplice.hs
@@ -654,6 +654,7 @@ rnTopSpliceDecls splice
      --
      -- See Note [Delaying modFinalizers in untyped splices].
      add_mod_finalizers_now :: [ForeignRef (TH.Q ())] -> TcRn ()
+     add_mod_finalizers_now []             = return ()
      add_mod_finalizers_now mod_finalizers = do
        th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv
        updTcRef th_modfinalizers_var $ \fins ->
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index bd32d80ae1..da8c2a67a6 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -471,7 +471,8 @@ tcRnSrcDecls :: Bool  -- False => no 'module M(..) where' header at all
 tcRnSrcDecls explicit_mod_hdr decls
  = do { -- Do all the declarations
       ; ((tcg_env, tcl_env), lie) <- captureConstraints $
-              do { (tcg_env, tcl_env) <- tc_rn_src_decls decls ;
+              do { envs <- tc_rn_src_decls decls
+                 ; (tcg_env, tcl_env) <- setEnvs envs run_th_modfinalizers
 
                    -- Check for the 'main' declaration
                    -- Must do this inside the captureConstraints
@@ -539,6 +540,27 @@ tcRnSrcDecls explicit_mod_hdr decls
 
    } }
 
+#ifdef GHCI
+-- | Runs TH finalizers and renames and typechecks the top-level declarations
+-- that they could introduce.
+run_th_modfinalizers :: TcM (TcGblEnv, TcLclEnv)
+run_th_modfinalizers = do
+  th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv
+  th_modfinalizers <- readTcRef th_modfinalizers_var
+  if null th_modfinalizers
+  then getEnvs
+  else do
+    writeTcRef th_modfinalizers_var []
+    sequence_ th_modfinalizers
+    -- Finalizers can add top-level declarations with addTopDecls.
+    envs <- tc_rn_src_decls []
+    -- addTopDecls can add declarations which add new finalizers.
+    setEnvs envs run_th_modfinalizers
+#else
+run_th_modfinalizers :: TcM (TcGblEnv, TcLclEnv)
+run_th_modfinalizers = getEnvs
+#endif /* GHCI */
+
 tc_rn_src_decls :: [LHsDecl RdrName]
                 -> TcM (TcGblEnv, TcLclEnv)
 -- Loops around dealing with each top level inter-splice group
diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs
index d879e56be1..861c3707fd 100644
--- a/compiler/typecheck/TcSplice.hs
+++ b/compiler/typecheck/TcSplice.hs
@@ -962,16 +962,12 @@ addModFinalizerRef finRef = do
         pprPanic "addModFinalizer was called when no finalizers were collected"
                  (ppr th_stage)
 
--- | Run all module finalizers
+-- | Releases the external interpreter state.
 finishTH :: TcM ()
 finishTH = do
-  tcg <- getGblEnv
-  let th_modfinalizers_var = tcg_th_modfinalizers tcg
-  modfinalizers <- readTcRef th_modfinalizers_var
-  writeTcRef th_modfinalizers_var []
-  sequence_ modfinalizers
   dflags <- getDynFlags
-  when (gopt Opt_ExternalInterpreter dflags) $
+  when (gopt Opt_ExternalInterpreter dflags) $ do
+    tcg <- getGblEnv
     writeTcRef (tcg_th_remote_state tcg) Nothing
 
 runTHExp :: ForeignHValue -> TcM TH.Exp
diff --git a/testsuite/tests/th/TH_finalizer2.hs b/testsuite/tests/th/TH_finalizer2.hs
new file mode 100644
index 0000000000..a233fdb9e8
--- /dev/null
+++ b/testsuite/tests/th/TH_finalizer2.hs
@@ -0,0 +1,3 @@
+import TH_finalizer2M
+
+main = print (f 0)
diff --git a/testsuite/tests/th/TH_finalizer2.stdout b/testsuite/tests/th/TH_finalizer2.stdout
new file mode 100644
index 0000000000..0cfbf08886
--- /dev/null
+++ b/testsuite/tests/th/TH_finalizer2.stdout
@@ -0,0 +1 @@
+2
diff --git a/testsuite/tests/th/TH_finalizer2M.hs b/testsuite/tests/th/TH_finalizer2M.hs
new file mode 100644
index 0000000000..7eea2d8f46
--- /dev/null
+++ b/testsuite/tests/th/TH_finalizer2M.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE TemplateHaskell #-}
+module TH_finalizer2M where
+
+import Language.Haskell.TH.Syntax
+
+g :: IO ()
+g = $(do addModFinalizer (do d <- [d| f x = (2 :: Int) |]; addTopDecls d)
+         [| return ()|]
+     )
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 2cfe2a509b..5d2fe3b051 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -405,6 +405,9 @@ test('T10820', normal, compile_and_run, ['-v0'])
 test('T11341', normal, compile, ['-v0 -dsuppress-uniques'])
 test('T11345', normal, compile_and_run, ['-v0 -dsuppress-uniques'])
 test('TH_finalizer', normal, compile, ['-v0'])
+test('TH_finalizer2',
+     normal, multimod_compile_and_run,
+     ['TH_finalizer2', '-v0 ' + config.ghc_th_way_flags])
 test('T10603', normal, compile, ['-ddump-splices -dsuppress-uniques'])
 test('T11452', normal, compile_fail, ['-v0'])
 test('T9022', normal, compile_and_run, ['-v0'])