[commit: ghc] ghc-8.0: Don't ignore addTopDecls in module finalizers. (a77bbb8)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : ghc-8.0
Link       : http://ghc.haskell.org/trac/ghc/changeset/a77bbb8b8c15ef21eab4357248d5d6964c542150/ghc

>---------------------------------------------------------------

commit a77bbb8b8c15ef21eab4357248d5d6964c542150
Author: Facundo Domínguez <facundo.dominguez at tweag.io>
Date:   Thu Sep 1 11:00:08 2016 -0300

    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
    
    (cherry picked from commit 71dd6e4429833238bcdaf96da8e2e41a62dacbf4)


>---------------------------------------------------------------

a77bbb8b8c15ef21eab4357248d5d6964c542150
 compiler/rename/RnSplice.hs                        |  1 +
 compiler/typecheck/TcRnDriver.hs                   | 25 +++++++++++++++++++++-
 compiler/typecheck/TcSplice.hs                     | 10 +++------
 testsuite/tests/th/TH_finalizer2.hs                |  3 +++
 .../T3279.stdout => th/TH_finalizer2.stdout}       |  0
 testsuite/tests/th/TH_finalizer2M.hs               |  9 ++++++++
 testsuite/tests/th/all.T                           |  3 +++
 7 files changed, 43 insertions(+), 8 deletions(-)

diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs
index 828ee8e..0dc4487 100644
--- a/compiler/rename/RnSplice.hs
+++ b/compiler/rename/RnSplice.hs
@@ -612,6 +612,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 b05e4b4..7dd7774 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -477,7 +477,9 @@ 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
+
                  ; tcg_env <- setEnvs (tcg_env, tcl_env) $
                               checkMain explicit_mod_hdr
                  ; return (tcg_env, tcl_env) }
@@ -548,6 +550,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 002306b..1bc2497 100644
--- a/compiler/typecheck/TcSplice.hs
+++ b/compiler/typecheck/TcSplice.hs
@@ -961,16 +961,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 0000000..a233fdb
--- /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/concurrent/should_run/T3279.stdout b/testsuite/tests/th/TH_finalizer2.stdout
similarity index 100%
copy from testsuite/tests/concurrent/should_run/T3279.stdout
copy to testsuite/tests/th/TH_finalizer2.stdout
diff --git a/testsuite/tests/th/TH_finalizer2M.hs b/testsuite/tests/th/TH_finalizer2M.hs
new file mode 100644
index 0000000..7eea2d8
--- /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 e5e07d7..74a1d4b 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -401,6 +401,9 @@ 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('T11145', normal, compile_fail, ['-v0 -dsuppress-uniques'])