Have addModFinalizer expose the local type environment.

Summary:
This annotates the splice point with 'HsSpliced ref e' where 'e' is the
result of the splice. 'ref' is a reference that the typechecker will fill with
the local type environment.

The finalizer then reads the ref and uses the local type environment, which
causes 'reify' to find local variables when run in the finalizer.

Test Plan: ./validate

Reviewers: simonpj, simonmar, bgamari, austin, goldfire

Reviewed By: goldfire

Subscribers: simonmar, thomie, mboes

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

GHC Trac Issues: #11832

19 files changed, 429 insertions, 73 deletions

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 8dd8b48488..01c4903c54 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -1071,6 +1071,7 @@ repSplice :: HsSplice Name -> DsM (Core a)
 repSplice (HsTypedSplice   n _)  = rep_splice n
 repSplice (HsUntypedSplice n _)  = rep_splice n
 repSplice (HsQuasiQuote n _ _ _) = rep_splice n
+repSplice e@(HsSpliced _ _)      = pprPanic "repSplice" (ppr e)
 
 rep_splice :: Name -> DsM (Core a)
 rep_splice splice_name
diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs
index 79cf079882..ffba782dfd 100644
--- a/compiler/hsSyn/HsExpr.hs
+++ b/compiler/hsSyn/HsExpr.hs
@@ -45,8 +45,14 @@ import Type
 
 -- libraries:
 import Data.Data hiding (Fixity(..))
+import qualified Data.Data as Data (Fixity(..))
 import Data.Maybe (isNothing)
 
+#ifdef GHCI
+import GHCi.RemoteTypes ( ForeignRef )
+import qualified Language.Haskell.TH as TH (Q)
+#endif
+
 {-
 ************************************************************************
 *                                                                      *
@@ -1926,12 +1932,55 @@ data HsSplice id
         SrcSpan          -- The span of the enclosed string
         FastString       -- The enclosed string
 
+   | HsSpliced  -- See Note [Delaying modFinalizers in untyped splices] in
+                -- RnSplice.
+                -- This is the result of splicing a splice. It is produced by
+                -- the renamer and consumed by the typechecker. It lives only
+                -- between the two.
+        ThModFinalizers     -- TH finalizers produced by the splice.
+        (HsSplicedThing id) -- The result of splicing
+  deriving Typeable
+
 deriving instance (DataId id) => Data (HsSplice id)
 
 isTypedSplice :: HsSplice id -> Bool
 isTypedSplice (HsTypedSplice {}) = True
 isTypedSplice _                  = False   -- Quasi-quotes are untyped splices
 
+-- | Finalizers produced by a splice with
+-- 'Language.Haskell.TH.Syntax.addModFinalizer'
+--
+-- See Note [Delaying modFinalizers in untyped splices] in RnSplice. For how
+-- this is used.
+--
+#ifdef GHCI
+newtype ThModFinalizers = ThModFinalizers [ForeignRef (TH.Q ())]
+#else
+data ThModFinalizers = ThModFinalizers
+#endif
+
+-- A Data instance which ignores the argument of 'ThModFinalizers'.
+#ifdef GHCI
+instance Data ThModFinalizers where
+  gunfold _ z _ = z $ ThModFinalizers []
+  toConstr  a   = mkConstr (dataTypeOf a) "ThModFinalizers" [] Data.Prefix
+  dataTypeOf a  = mkDataType "HsExpr.ThModFinalizers" [toConstr a]
+#else
+instance Data ThModFinalizers where
+  gunfold _ z _ = z ThModFinalizers
+  toConstr  a   = mkConstr (dataTypeOf a) "ThModFinalizers" [] Data.Prefix
+  dataTypeOf a  = mkDataType "HsExpr.ThModFinalizers" [toConstr a]
+#endif
+
+-- | Values that can result from running a splice.
+data HsSplicedThing id
+    = HsSplicedExpr (HsExpr id)
+    | HsSplicedTy   (HsType id)
+    | HsSplicedPat  (Pat id)
+  deriving Typeable
+
+deriving instance (DataId id) => Data (HsSplicedThing id)
+
 -- See Note [Pending Splices]
 type SplicePointName = Name
 
@@ -2015,6 +2064,11 @@ splices. In contrast, when pretty printing the output of the type checker, we
 sense, although I hate to add another constructor to HsExpr.
 -}
 
+instance OutputableBndrId id => Outputable (HsSplicedThing id) where
+  ppr (HsSplicedExpr e) = ppr_expr e
+  ppr (HsSplicedTy   t) = ppr t
+  ppr (HsSplicedPat  p) = ppr p
+
 instance (OutputableBndrId id) => Outputable (HsSplice id) where
   ppr s = pprSplice s
 
@@ -2026,6 +2080,7 @@ pprSplice :: (OutputableBndrId id) => HsSplice id -> SDoc
 pprSplice (HsTypedSplice   n e)  = ppr_splice (text "$$") n e
 pprSplice (HsUntypedSplice n e)  = ppr_splice (text "$")  n e
 pprSplice (HsQuasiQuote n q _ s) = ppr_quasi n q s
+pprSplice (HsSpliced _ thing)    = ppr thing
 
 ppr_quasi :: OutputableBndr id => id -> id -> FastString -> SDoc
 ppr_quasi n quoter quote = ifPprDebug (brackets (ppr n)) <>
diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs
index f44d492fe0..0ec15a969f 100644
--- a/compiler/rename/RnPat.hs
+++ b/compiler/rename/RnPat.hs
@@ -446,6 +446,10 @@ rnPatAndThen mk (TuplePat pats boxed _)
        ; pats' <- rnLPatsAndThen mk pats
        ; return (TuplePat pats' boxed []) }
 
+-- If a splice has been run already, just rename the result.
+rnPatAndThen mk (SplicePat (HsSpliced mfs (HsSplicedPat pat)))
+  = SplicePat . HsSpliced mfs . HsSplicedPat <$> rnPatAndThen mk pat
+
 rnPatAndThen mk (SplicePat splice)
   = do { eith <- liftCpsFV $ rnSplicePat splice
        ; case eith of   -- See Note [rnSplicePat] in RnSplice
diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs
index b23621d1bd..1b99376a51 100644
--- a/compiler/rename/RnSplice.hs
+++ b/compiler/rename/RnSplice.hs
@@ -46,7 +46,17 @@ import THNames          ( quoteExpName, quotePatName, quoteDecName, quoteTypeNam
                         , decsQTyConName, expQTyConName, patQTyConName, typeQTyConName, )
 
 import {-# SOURCE #-} TcExpr   ( tcPolyExpr )
-import {-# SOURCE #-} TcSplice ( runMetaD, runMetaE, runMetaP, runMetaT, tcTopSpliceExpr )
+import {-# SOURCE #-} TcSplice
+    ( runMetaD
+    , runMetaE
+    , runMetaP
+    , runMetaT
+    , runRemoteModFinalizers
+    , tcTopSpliceExpr
+    )
+
+import GHCi.RemoteTypes ( ForeignRef )
+import qualified Language.Haskell.TH as TH (Q)
 #endif
 
 import qualified GHC.LanguageExtensions as LangExt
@@ -77,6 +87,10 @@ rnBracket e br_body
                                        illegalUntypedBracket
            ; Splice Untyped -> checkTc (not (isTypedBracket br_body))
                                        illegalTypedBracket
+           ; RunSplice _    ->
+               -- See Note [RunSplice ThLevel] in "TcRnTypes".
+               pprPanic "rnBracket: Renaming bracket when running a splice"
+                        (ppr e)
            ; Comp           -> return ()
            ; Brack {}       -> failWithTc illegalBracket
            }
@@ -278,12 +292,17 @@ rnSpliceGen run_splice pend_splice splice
                    else Untyped
 
 ------------------
+
+-- | Returns the result of running a splice and the modFinalizers collected
+-- during the execution.
+--
+-- See Note [Delaying modFinalizers in untyped splices].
 runRnSplice :: UntypedSpliceFlavour
             -> (LHsExpr Id -> TcRn res)
             -> (res -> SDoc)    -- How to pretty-print res
                                 -- Usually just ppr, but not for [Decl]
             -> HsSplice Name    -- Always untyped
-            -> TcRn res
+            -> TcRn (res, [ForeignRef (TH.Q ())])
 runRnSplice flavour run_meta ppr_res splice
   = do { splice' <- getHooked runRnSpliceHook return >>= ($ splice)
 
@@ -291,6 +310,7 @@ runRnSplice flavour run_meta ppr_res splice
                   HsUntypedSplice _ e     ->  e
                   HsQuasiQuote _ q qs str -> mkQuasiQuoteExpr flavour q qs str
                   HsTypedSplice {}        -> pprPanic "runRnSplice" (ppr splice)
+                  HsSpliced {}            -> pprPanic "runRnSplice" (ppr splice)
 
              -- Typecheck the expression
        ; meta_exp_ty   <- tcMetaTy meta_ty_name
@@ -298,13 +318,16 @@ runRnSplice flavour run_meta ppr_res splice
                           tcPolyExpr the_expr meta_exp_ty
 
              -- Run the expression
-       ; result <- run_meta zonked_q_expr
+       ; mod_finalizers_ref <- newTcRef []
+       ; result <- setStage (RunSplice mod_finalizers_ref) $
+                     run_meta zonked_q_expr
+       ; mod_finalizers <- readTcRef mod_finalizers_ref
        ; traceSplice (SpliceInfo { spliceDescription = what
                                  , spliceIsDecl      = is_decl
                                  , spliceSource      = Just the_expr
                                  , spliceGenerated   = ppr_res result })
 
-       ; return result }
+       ; return (result, mod_finalizers) }
 
   where
     meta_ty_name = case flavour of
@@ -331,6 +354,8 @@ makePending flavour (HsQuasiQuote n quoter q_span quote)
   = PendingRnSplice flavour n (mkQuasiQuoteExpr flavour quoter q_span quote)
 makePending _ splice@(HsTypedSplice {})
   = pprPanic "makePending" (ppr splice)
+makePending _ splice@(HsSpliced {})
+  = pprPanic "makePending" (ppr splice)
 
 ------------------
 mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString -> LHsExpr Name
@@ -380,6 +405,8 @@ rnSplice (HsQuasiQuote splice_name quoter q_loc quote)
 
         ; return (HsQuasiQuote splice_name' quoter' q_loc quote, unitFV quoter') }
 
+rnSplice splice@(HsSpliced {}) = pprPanic "rnSplice" (ppr splice)
+
 ---------------------
 rnSpliceExpr :: HsSplice RdrName -> RnM (HsExpr Name, FreeVars)
 rnSpliceExpr splice
@@ -404,9 +431,16 @@ rnSpliceExpr splice
 
       | otherwise  -- Run it here, see Note [Running splices in the Renamer]
       = do { traceRn (text "rnSpliceExpr: untyped expression splice")
-           ; rn_expr <- runRnSplice UntypedExpSplice runMetaE ppr rn_splice
+           ; (rn_expr, mod_finalizers) <-
+                runRnSplice UntypedExpSplice runMetaE ppr rn_splice
            ; (lexpr3, fvs) <- checkNoErrs (rnLExpr rn_expr)
-           ; return (HsPar lexpr3, fvs)  }
+             -- See Note [Delaying modFinalizers in untyped splices].
+           ; return ( HsPar $ HsSpliceE
+                            . HsSpliced (ThModFinalizers mod_finalizers)
+                            . HsSplicedExpr <$>
+                            lexpr3
+                    , fvs)
+           }
 
 {- Note [Running splices in the Renamer]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -450,6 +484,54 @@ to try and
 
 -}
 
+{- Note [Delaying modFinalizers in untyped splices]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+When splices run in the renamer, 'reify' does not have access to the local
+type environment (Trac #11832, [1]).
+
+For instance, in
+
+> let x = e in $(reify (mkName "x") >>= runIO . print >> [| return () |])
+
+'reify' cannot find @x@, because the local type environment is not yet
+populated. To address this, we allow 'reify' execution to be deferred with
+'addModFinalizer'.
+
+> let x = e in $(do addModFinalizer (reify (mkName "x") >>= runIO . print)
+                    [| return () |]
+                )
+
+The finalizer is run with the local type environment when type checking is
+complete.
+
+Since the local type environment is not available in the renamer, we annotate
+the tree at the splice point [2] with @HsSpliceE (HsSpliced finalizers e)@ where
+@e@ is the result of splicing and @finalizers@ are the finalizers that have been
+collected during evaluation of the splice [3]. In our example,
+
+> HsLet
+>   (x = e)
+>   (HsSpliceE $ HsSpliced [reify (mkName "x") >>= runIO . print]
+>                          (HsSplicedExpr $ return ())
+>   )
+
+When the typechecker finds the annotation, it inserts the finalizers in the
+global environment and exposes the current local environment to them [4, 5, 6].
+
+> addModFinalizersWithLclEnv [reify (mkName "x") >>= runIO . print]
+
+References:
+
+[1] https://ghc.haskell.org/trac/ghc/wiki/TemplateHaskell/Reify
+[2] 'rnSpliceExpr'
+[3] 'TcSplice.qAddModFinalizer'
+[4] 'TcExpr.tcExpr' ('HsSpliceE' ('HsSpliced' ...))
+[5] 'TcHsType.tc_hs_type' ('HsSpliceTy' ('HsSpliced' ...))
+[6] 'TcPat.tc_pat' ('SplicePat' ('HsSpliced' ...))
+
+-}
+
 ----------------------
 rnSpliceType :: HsSplice RdrName -> PostTc Name Kind
              -> RnM (HsType Name, FreeVars)
@@ -461,11 +543,18 @@ rnSpliceType splice k
 
     run_type_splice rn_splice
       = do { traceRn (text "rnSpliceType: untyped type splice")
-           ; hs_ty2 <- runRnSplice UntypedTypeSplice runMetaT ppr rn_splice
+           ; (hs_ty2, mod_finalizers) <-
+                runRnSplice UntypedTypeSplice runMetaT ppr rn_splice
            ; (hs_ty3, fvs) <- do { let doc = SpliceTypeCtx hs_ty2
                                  ; checkNoErrs $ rnLHsType doc hs_ty2 }
                                     -- checkNoErrs: see Note [Renamer errors]
-           ; return (HsParTy hs_ty3, fvs) }
+             -- See Note [Delaying modFinalizers in untyped splices].
+           ; return ( HsParTy $ flip HsSpliceTy k
+                              . HsSpliced (ThModFinalizers mod_finalizers)
+                              . HsSplicedTy <$>
+                              hs_ty3
+                    , fvs
+                    ) }
               -- Wrap the result of the splice in parens so that we don't
               -- lose the outermost location set by runQuasiQuote (#7918)
 
@@ -521,8 +610,15 @@ rnSplicePat splice
 
     run_pat_splice rn_splice
       = do { traceRn (text "rnSplicePat: untyped pattern splice")
-           ; pat <- runRnSplice UntypedPatSplice runMetaP ppr rn_splice
-           ; return (Left (ParPat pat), emptyFVs) }
+           ; (pat, mod_finalizers) <-
+                runRnSplice UntypedPatSplice runMetaP ppr rn_splice
+             -- See Note [Delaying modFinalizers in untyped splices].
+           ; return ( Left $ ParPat $ SplicePat
+                                    . HsSpliced (ThModFinalizers mod_finalizers)
+                                    . HsSplicedPat <$>
+                                    pat
+                    , emptyFVs
+                    ) }
               -- Wrap the result of the quasi-quoter in parens so that we don't
               -- lose the outermost location set by runQuasiQuote (#7918)
 
@@ -542,12 +638,28 @@ rnTopSpliceDecls splice
    = do  { (rn_splice, fvs) <- setStage (Splice Untyped) $
                                rnSplice splice
          ; traceRn (text "rnTopSpliceDecls: untyped declaration splice")
-         ; decls <- runRnSplice UntypedDeclSplice runMetaD ppr_decls rn_splice
+         ; (decls, mod_finalizers) <-
+              runRnSplice UntypedDeclSplice runMetaD ppr_decls rn_splice
+         ; add_mod_finalizers_now mod_finalizers
          ; return (decls,fvs) }
    where
      ppr_decls :: [LHsDecl RdrName] -> SDoc
      ppr_decls ds = vcat (map ppr ds)
 
+     -- Adds finalizers to the global environment instead of delaying them
+     -- to the type checker.
+     --
+     -- Declaration splices do not have an interesting local environment so
+     -- there is no point in delaying them.
+     --
+     -- See Note [Delaying modFinalizers in untyped splices].
+     add_mod_finalizers_now :: [ForeignRef (TH.Q ())] -> TcRn ()
+     add_mod_finalizers_now mod_finalizers = do
+       th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv
+       updTcRef th_modfinalizers_var $ \fins ->
+         runRemoteModFinalizers (ThModFinalizers mod_finalizers) : fins
+
+
 {-
 Note [rnSplicePat]
 ~~~~~~~~~~~~~~~~~~
@@ -582,6 +694,7 @@ spliceCtxt splice
              HsUntypedSplice {} -> text "untyped splice:"
              HsTypedSplice   {} -> text "typed splice:"
              HsQuasiQuote    {} -> text "quasi-quotation:"
+             HsSpliced       {} -> text "spliced expression:"
 
 -- | The splice data to be logged
 data SpliceInfo
diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs
index d8a58777f9..36264310f9 100644
--- a/compiler/rename/RnTypes.hs
+++ b/compiler/rename/RnTypes.hs
@@ -1031,6 +1031,7 @@ collectAnonWildCards lty = go lty
                                       `mappend` go ty
       HsQualTy { hst_ctxt = L _ ctxt
                , hst_body = ty }  -> gos ctxt `mappend` go ty
+      HsSpliceTy (HsSpliced _ (HsSplicedTy ty)) _ -> go $ L noSrcSpan ty
       -- HsQuasiQuoteTy, HsSpliceTy, HsCoreTy, HsTyLit
       _ -> mempty
 
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index 643b037cb6..a6918b6cf8 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -981,6 +981,14 @@ tcExpr (PArrSeq _ _) _
 ************************************************************************
 -}
 
+-- HsSpliced is an annotation produced by 'RnSplice.rnSpliceExpr'.
+-- Here we get rid of it and add the finalizers to the global environment.
+--
+-- See Note [Delaying modFinalizers in untyped splices] in RnSplice.
+tcExpr (HsSpliceE (HsSpliced mod_finalizers (HsSplicedExpr expr)))
+       res_ty
+  = do addModFinalizersWithLclEnv mod_finalizers
+       tcExpr expr res_ty
 tcExpr (HsSpliceE splice)        res_ty
   = tcSpliceExpr splice res_ty
 tcExpr (HsBracket brack)         res_ty
diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs
index 2d029b2fdc..ea65a73643 100644
--- a/compiler/typecheck/TcHsType.hs
+++ b/compiler/typecheck/TcHsType.hs
@@ -501,6 +501,18 @@ tc_hs_type _ ty@(HsRecTy _)      _
       -- signatures) should have been removed by now
     = failWithTc (text "Record syntax is illegal here:" <+> ppr ty)
 
+-- HsSpliced is an annotation produced by 'RnSplice.rnSpliceType'.
+-- Here we get rid of it and add the finalizers to the global environment
+-- while capturing the local environment.
+--
+-- See Note [Delaying modFinalizers in untyped splices].
+tc_hs_type mode (HsSpliceTy (HsSpliced mod_finalizers (HsSplicedTy ty))
+                            _
+                )
+           exp_kind
+  = do addModFinalizersWithLclEnv mod_finalizers
+       tc_hs_type mode ty exp_kind
+
 -- This should never happen; type splices are expanded by the renamer
 tc_hs_type _ ty@(HsSpliceTy {}) _exp_kind
   = failWithTc (text "Unexpected type splice:" <+> ppr ty)
diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs
index a46136efca..e62b30030d 100644
--- a/compiler/typecheck/TcPat.hs
+++ b/compiler/typecheck/TcPat.hs
@@ -583,6 +583,15 @@ tc_pat penv (NPlusKPat (L nm_loc name) (L loc lit) _ ge minus _) pat_ty thing_in
                                ge' minus'' pat_ty
         ; return (pat', res) }
 
+-- HsSpliced is an annotation produced by 'RnSplice.rnSplicePat'.
+-- Here we get rid of it and add the finalizers to the global environment.
+--
+-- See Note [Delaying modFinalizers in untyped splices] in RnSplice.
+tc_pat penv (SplicePat (HsSpliced mod_finalizers (HsSplicedPat pat)))
+            pat_ty thing_inside
+  = do addModFinalizersWithLclEnv mod_finalizers
+       tc_pat penv pat pat_ty thing_inside
+
 tc_pat _ _other_pat _ _ = panic "tc_pat"        -- ConPatOut, SigPatOut
 
 ----------------
diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs
index a411e18c62..e8513d39b0 100644
--- a/compiler/typecheck/TcRnMonad.hs
+++ b/compiler/typecheck/TcRnMonad.hs
@@ -106,6 +106,7 @@ module TcRnMonad(
   -- * Template Haskell context
   recordThUse, recordThSpliceUse, recordTopLevelSpliceLoc,
   getTopLevelSpliceLocs, keepAlive, getStage, getStageAndBindLevel, setStage,
+  addModFinalizersWithLclEnv,
 
   -- * Safe Haskell context
   recordUnsafeInfer, finalSafeMode, fixSafeInstances,
@@ -174,6 +175,7 @@ import Data.Set ( Set )
 import qualified Data.Set as Set
 
 #ifdef GHCI
+import {-# SOURCE #-} TcSplice ( runRemoteModFinalizers )
 import qualified Data.Map as Map
 #endif
 
@@ -1529,6 +1531,21 @@ getStageAndBindLevel name
 setStage :: ThStage -> TcM a -> TcRn a
 setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s })
 
+#ifdef GHCI
+-- | Adds the given modFinalizers to the global environment and set them to use
+-- the current local environment.
+addModFinalizersWithLclEnv :: ThModFinalizers -> TcM ()
+addModFinalizersWithLclEnv mod_finalizers
+  = do lcl_env <- getLclEnv
+       th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv
+       updTcRef th_modfinalizers_var $ \fins ->
+         setLclEnv lcl_env (runRemoteModFinalizers mod_finalizers)
+         : fins
+#else
+addModFinalizersWithLclEnv :: ThModFinalizers -> TcM ()
+addModFinalizersWithLclEnv ThModFinalizers = return ()
+#endif
+
 {-
 ************************************************************************
 *                                                                      *
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index 67fd77e81d..d952d2309e 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -502,8 +502,11 @@ data TcGblEnv
         tcg_th_topnames :: TcRef NameSet,
         -- ^ Exact names bound in top-level declarations in tcg_th_topdecls
 
-        tcg_th_modfinalizers :: TcRef [TH.Q ()],
-        -- ^ Template Haskell module finalizers
+        tcg_th_modfinalizers :: TcRef [TcM ()],
+        -- ^ Template Haskell module finalizers.
+        --
+        -- They are computations in the @TcM@ monad rather than @Q@ because we
+        -- set them to use particular local environments.
 
         tcg_th_state :: TcRef (Map TypeRep Dynamic),
         tcg_th_remote_state :: TcRef (Maybe (ForeignRef (IORef QState))),
@@ -788,6 +791,25 @@ data ThStage    -- See Note [Template Haskell state diagram] in TcSplice
                       --   the result replaces the splice
                       -- Binding level = 0
 
+#ifdef GHCI
+  | RunSplice (TcRef [ForeignRef (TH.Q ())])
+      -- Set when running a splice, i.e. NOT when renaming or typechecking the
+      -- Haskell code for the splice. See Note [RunSplice ThLevel].
+      --
+      -- Contains a list of mod finalizers collected while executing the splice.
+      --
+      -- 'addModFinalizer' inserts finalizers here, and from here they are taken
+      -- to construct an @HsSpliced@ annotation for untyped splices. See Note
+      -- [Delaying modFinalizers in untyped splices] in "RnSplice".
+      --
+      -- For typed splices, the typechecker takes finalizers from here and
+      -- inserts them in the list of finalizers in the global environment.
+      --
+      -- See Note [Collecting modFinalizers in typed splices] in "TcSplice".
+#else
+  | RunSplice ()
+#endif
+
   | Comp        -- Ordinary Haskell code
                 -- Binding level = 1
 
@@ -811,9 +833,10 @@ topAnnStage    = Splice Untyped
 topSpliceStage = Splice Untyped
 
 instance Outputable ThStage where
-   ppr (Splice _)  = text "Splice"
-   ppr Comp        = text "Comp"
-   ppr (Brack s _) = text "Brack" <> parens (ppr s)
+   ppr (Splice _)    = text "Splice"
+   ppr (RunSplice _) = text "RunSplice"
+   ppr Comp          = text "Comp"
+   ppr (Brack s _)   = text "Brack" <> parens (ppr s)
 
 type ThLevel = Int
     -- NB: see Note [Template Haskell levels] in TcSplice
@@ -827,9 +850,25 @@ impLevel = 0    -- Imported things; they can be used inside a top level splice
 outerLevel = 1  -- Things defined outside brackets
 
 thLevel :: ThStage -> ThLevel
-thLevel (Splice _)  = 0
-thLevel Comp        = 1
-thLevel (Brack s _) = thLevel s + 1
+thLevel (Splice _)    = 0
+thLevel (RunSplice _) =
+    -- See Note [RunSplice ThLevel].
+    panic "thLevel: called when running a splice"
+thLevel Comp          = 1
+thLevel (Brack s _)   = thLevel s + 1
+
+{- Node [RunSplice ThLevel]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The 'RunSplice' stage is set when executing a splice, and only when running a
+splice. In particular it is not set when the splice is renamed or typechecked.
+
+'RunSplice' is needed to provide a reference where 'addModFinalizer' can insert
+the finalizer (see Note [Delaying modFinalizers in untyped splices]), and
+'addModFinalizer' runs when doing Q things. Therefore, It doesn't make sense to
+set 'RunSplice' when renaming or typechecking the splice, where 'Splice', 'Brak'
+or 'Comp' are used instead.
+
+-}
 
 ---------------------------
 -- Arrow-notation context
diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs
index 44bc299487..fa68d2e98b 100644
--- a/compiler/typecheck/TcSplice.hs
+++ b/compiler/typecheck/TcSplice.hs
@@ -29,7 +29,7 @@ module TcSplice(
      -- called only in stage2 (ie GHCI is on)
      runMetaE, runMetaP, runMetaT, runMetaD, runQuasi,
      tcTopSpliceExpr, lookupThName_maybe,
-     defaultRunMeta, runMeta',
+     defaultRunMeta, runMeta', runRemoteModFinalizers,
      finishTH
 #endif
       ) where
@@ -446,12 +446,28 @@ tcSpliceExpr splice@(HsTypedSplice name expr) res_ty
     setSrcSpan (getLoc expr)    $ do
     { stage <- getStage
     ; case stage of
-        Splice {}            -> tcTopSplice expr res_ty
-        Comp                 -> tcTopSplice expr res_ty
-        Brack pop_stage pend -> tcNestedSplice pop_stage pend name expr res_ty }
+          Splice {}            -> tcTopSplice expr res_ty
+          Brack pop_stage pend -> tcNestedSplice pop_stage pend name expr res_ty
+          RunSplice _          ->
+            -- See Note [RunSplice ThLevel] in "TcRnTypes".
+            pprPanic ("tcSpliceExpr: attempted to typecheck a splice when " ++
+                      "running another splice") (ppr splice)
+          Comp                 -> tcTopSplice expr res_ty
+    }
 tcSpliceExpr splice _
   = pprPanic "tcSpliceExpr" (ppr splice)
 
+{- Note [Collecting modFinalizers in typed splices]
+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+'qAddModFinalizer' of the @Quasi TcM@ instance adds finalizers in the local
+environment (see Note [Delaying modFinalizers in untyped splices] in
+"RnSplice"). Thus after executing the splice, we move the finalizers to the
+finalizer list in the global environment and set them to use the current local
+environment (with 'addModFinalizersWithLclEnv').
+
+-}
+
 tcNestedSplice :: ThStage -> PendingStuff -> Name
                 -> LHsExpr Name -> ExpRhoType -> TcM (HsExpr Id)
     -- See Note [How brackets and nested splices are handled]
@@ -482,8 +498,13 @@ tcTopSplice expr res_ty
        ; zonked_q_expr <- tcTopSpliceExpr Typed $
                           tcMonoExpr expr (mkCheckExpType meta_exp_ty)
 
+         -- See Note [Collecting modFinalizers in typed splices].
+       ; modfinalizers_ref <- newTcRef []
          -- Run the expression
-       ; expr2 <- runMetaE zonked_q_expr
+       ; expr2 <- setStage (RunSplice modfinalizers_ref) $
+                    runMetaE zonked_q_expr
+       ; mod_finalizers <- readTcRef modfinalizers_ref
+       ; addModFinalizersWithLclEnv $ ThModFinalizers mod_finalizers
        ; traceSplice (SpliceInfo { spliceDescription = "expression"
                                  , spliceIsDecl      = False
                                  , spliceSource      = Just expr
@@ -618,6 +639,29 @@ seqSerialized (Serialized the_type bytes) = the_type `seq` bytes `seqList` ()
 runQuasi :: TH.Q a -> TcM a
 runQuasi act = TH.runQ act
 
+runRemoteModFinalizers :: ThModFinalizers -> TcM ()
+runRemoteModFinalizers (ThModFinalizers finRefs) = do
+  dflags <- getDynFlags
+  let withForeignRefs [] f = f []
+      withForeignRefs (x : xs) f = withForeignRef x $ \r ->
+        withForeignRefs xs $ \rs -> f (r : rs)
+  if gopt Opt_ExternalInterpreter dflags then do
+    hsc_env <- env_top <$> getEnv
+    withIServ hsc_env $ \i -> do
+      tcg <- getGblEnv
+      th_state <- readTcRef (tcg_th_remote_state tcg)
+      case th_state of
+        Nothing -> return () -- TH was not started, nothing to do
+        Just fhv -> do
+          liftIO $ withForeignRef fhv $ \st ->
+            withForeignRefs finRefs $ \qrefs ->
+              writeIServ i (putMessage (RunModFinalizers st qrefs))
+          () <- runRemoteTH i []
+          readQResult i
+  else do
+    qs <- liftIO (withForeignRefs finRefs $ mapM localRef)
+    runQuasi $ sequence_ qs
+
 runQResult
   :: (a -> String)
   -> (SrcSpan -> a -> b)
@@ -884,8 +928,9 @@ instance TH.Quasi TcM where
              2 (text "Probable cause: you used mkName instead of newName to generate a binding.")
 
   qAddModFinalizer fin = do
-      th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv
-      updTcRef th_modfinalizers_var (\fins -> fin:fins)
+      r <- liftIO $ mkRemoteRef fin
+      fref <- liftIO $ mkForeignRef r (freeRemoteRef r)
+      addModFinalizerRef fref
 
   qGetQ :: forall a. Typeable a => TcM (Maybe a)
   qGetQ = do
@@ -904,30 +949,30 @@ instance TH.Quasi TcM where
     dflags <- hsc_dflags <$> getTopEnv
     return $ map toEnum $ IntSet.elems $ extensionFlags dflags
 
+-- | Adds a mod finalizer reference to the local environment.
+addModFinalizerRef :: ForeignRef (TH.Q ()) -> TcM ()
+addModFinalizerRef finRef = do
+    th_stage <- getStage
+    case th_stage of
+      RunSplice th_modfinalizers_var -> updTcRef th_modfinalizers_var (finRef :)
+      -- This case happens only if a splice is executed and the caller does
+      -- not set the 'ThStage' to 'RunSplice' to collect finalizers.
+      -- See Note [Delaying modFinalizers in untyped splices] in RnSplice.
+      _ ->
+        pprPanic "addModFinalizer was called when no finalizers were collected"
+                 (ppr th_stage)
 
 -- | Run all module finalizers
 finishTH :: TcM ()
 finishTH = do
-  hsc_env <- env_top <$> getEnv
+  tcg <- getGblEnv
+  let th_modfinalizers_var = tcg_th_modfinalizers tcg
+  modfinalizers <- readTcRef th_modfinalizers_var
+  writeTcRef th_modfinalizers_var []
+  sequence_ modfinalizers
   dflags <- getDynFlags
-  if not (gopt Opt_ExternalInterpreter dflags)
-    then do
-      tcg <- getGblEnv
-      let th_modfinalizers_var = tcg_th_modfinalizers tcg
-      modfinalizers <- readTcRef th_modfinalizers_var
-      writeTcRef th_modfinalizers_var []
-      mapM_ runQuasi modfinalizers
-    else withIServ hsc_env $ \i -> do
-      tcg <- getGblEnv
-      th_state <- readTcRef (tcg_th_remote_state tcg)
-      case th_state of
-        Nothing -> return () -- TH was not started, nothing to do
-        Just fhv -> do
-          liftIO $ withForeignRef fhv $ \rhv ->
-            writeIServ i (putMessage (FinishTH rhv))
-          () <- runRemoteTH i []
-          () <- readQResult i
-          writeTcRef (tcg_th_remote_state tcg) Nothing
+  when (gopt Opt_ExternalInterpreter dflags) $
+    writeTcRef (tcg_th_remote_state tcg) Nothing
 
 runTHExp :: ForeignHValue -> TcM TH.Exp
 runTHExp = runTH THExp
@@ -1073,6 +1118,9 @@ handleTHMessage msg = case msg of
   ReifyModule m -> wrapTHResult $ TH.qReifyModule m
   ReifyConStrictness nm -> wrapTHResult $ TH.qReifyConStrictness nm
   AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f
+  AddModFinalizer r -> do
+    hsc_env <- env_top <$> getEnv
+    wrapTHResult $ liftIO (mkFinalizedHValue hsc_env r) >>= addModFinalizerRef
   AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs
   IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext
   ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled
diff --git a/compiler/typecheck/TcSplice.hs-boot b/compiler/typecheck/TcSplice.hs-boot
index db4884e354..14e479a04e 100644
--- a/compiler/typecheck/TcSplice.hs-boot
+++ b/compiler/typecheck/TcSplice.hs-boot
@@ -9,7 +9,7 @@ import TcType   ( ExpRhoType )
 import Annotations ( Annotation, CoreAnnTarget )
 
 #ifdef GHCI
-import HsSyn      ( LHsType, LPat, LHsDecl )
+import HsSyn      ( LHsType, LPat, LHsDecl, ThModFinalizers )
 import RdrName    ( RdrName )
 import TcRnTypes  ( SpliceType )
 import qualified Language.Haskell.TH as TH
@@ -39,5 +39,6 @@ runMetaD :: LHsExpr TcId -> TcM [LHsDecl RdrName]
 
 lookupThName_maybe :: TH.Name -> TcM (Maybe Name)
 runQuasi :: TH.Q a -> TcM a
+runRemoteModFinalizers :: ThModFinalizers -> TcM ()
 finishTH :: TcM ()
 #endif
diff --git a/iserv/src/Main.hs b/iserv/src/Main.hs
index 3fcd49f5c7..66e15c9785 100644
--- a/iserv/src/Main.hs
+++ b/iserv/src/Main.hs
@@ -53,7 +53,7 @@ serv verbose pipe@Pipe{..} restore = loop
     case msg of
       Shutdown -> return ()
       RunTH st q ty loc -> wrapRunTH $ runTH pipe st q ty loc
-      FinishTH st -> wrapRunTH $ finishTH pipe st
+      RunModFinalizers st qrefs -> wrapRunTH $ runModFinalizerRefs pipe st qrefs
       _other -> run msg >>= reply
 
   reply :: forall a. (Binary a, Show a) => a -> IO ()
diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs
index b14fca4f2d..01fd7f0e3c 100644
--- a/libraries/ghci/GHCi/Message.hs
+++ b/libraries/ghci/GHCi/Message.hs
@@ -172,9 +172,6 @@ data Message a where
   -- | Start a new TH module, return a state token that should be
   StartTH :: Message (RemoteRef (IORef QState))
 
-  -- | Run TH module finalizers, and free the HValueRef
-  FinishTH :: RemoteRef (IORef QState) -> Message (QResult ())
-
   -- | Evaluate a TH computation.
   --
   -- Returns a ByteString, because we have to force the result
@@ -189,6 +186,10 @@ data Message a where
    -> Maybe TH.Loc
    -> Message (QResult ByteString)
 
+  -- | Run the given mod finalizers.
+  RunModFinalizers :: RemoteRef (IORef QState)
+                   -> [RemoteRef (TH.Q ())]
+                   -> Message (QResult ())
 
 deriving instance Show (Message a)
 
@@ -223,6 +224,7 @@ data THMessage a where
   ReifyConStrictness :: TH.Name -> THMessage (THResult [TH.DecidedStrictness])
 
   AddDependentFile :: FilePath -> THMessage (THResult ())
+  AddModFinalizer :: RemoteRef (TH.Q ()) -> THMessage (THResult ())
   AddTopDecls :: [TH.Dec] -> THMessage (THResult ())
   IsExtEnabled :: Extension -> THMessage (THResult Bool)
   ExtsEnabled :: THMessage (THResult [Extension])
@@ -258,7 +260,8 @@ getTHMessage = do
     13 -> THMsg <$> return ExtsEnabled
     14 -> THMsg <$> return StartRecover
     15 -> THMsg <$> EndRecover <$> get
-    _  -> return (THMsg RunTHDone)
+    16 -> return (THMsg RunTHDone)
+    _  -> THMsg <$> AddModFinalizer <$> get
 
 putTHMessage :: THMessage a -> Put
 putTHMessage m = case m of
@@ -279,6 +282,7 @@ putTHMessage m = case m of
   StartRecover                -> putWord8 14
   EndRecover a                -> putWord8 15 >> put a
   RunTHDone                   -> putWord8 16
+  AddModFinalizer a           -> putWord8 17 >> put a
 
 
 data EvalOpts = EvalOpts
@@ -368,8 +372,6 @@ instance Binary THResultType
 data QState = QState
   { qsMap        :: Map TypeRep Dynamic
        -- ^ persistent data between splices in a module
-  , qsFinalizers :: [TH.Q ()]
-       -- ^ registered finalizers (in reverse order)
   , qsLocation   :: Maybe TH.Loc
        -- ^ location for current splice, if any
   , qsPipe :: Pipe
@@ -415,7 +417,7 @@ getMessage = do
       29 -> Msg <$> (BreakpointStatus <$> get <*> get)
       30 -> Msg <$> (GetBreakpointVar <$> get <*> get)
       31 -> Msg <$> return StartTH
-      32 -> Msg <$> FinishTH <$> get
+      32 -> Msg <$> (RunModFinalizers <$> get <*> get)
       _  -> Msg <$> (RunTH <$> get <*> get <*> get <*> get)
 
 putMessage :: Message a -> Put
@@ -452,7 +454,7 @@ putMessage m = case m of
   BreakpointStatus arr ix     -> putWord8 29 >> put arr >> put ix
   GetBreakpointVar a b        -> putWord8 30 >> put a >> put b
   StartTH                     -> putWord8 31
-  FinishTH val                -> putWord8 32 >> put val
+  RunModFinalizers a b        -> putWord8 32 >> put a >> put b
   RunTH st q loc ty           -> putWord8 33 >> put st >> put q >> put loc >> put ty
 
 -- -----------------------------------------------------------------------------
diff --git a/libraries/ghci/GHCi/TH.hs b/libraries/ghci/GHCi/TH.hs
index 3495162a12..def6aee33e 100644
--- a/libraries/ghci/GHCi/TH.hs
+++ b/libraries/ghci/GHCi/TH.hs
@@ -5,7 +5,12 @@
 -- |
 -- Running TH splices
 --
-module GHCi.TH (startTH, finishTH, runTH, GHCiQException(..)) where
+module GHCi.TH
+  ( startTH
+  , runModFinalizerRefs
+  , runTH
+  , GHCiQException(..)
+  ) where
 
 {- Note [Remote Template Haskell]
 
@@ -110,14 +115,7 @@ import Unsafe.Coerce
 
 -- | Create a new instance of 'QState'
 initQState :: Pipe -> QState
-initQState p = QState M.empty [] Nothing p
-
-runModFinalizers :: GHCiQ ()
-runModFinalizers = go =<< getState
-  where
-    go s | (f:ff) <- qsFinalizers s = do
-      putState (s { qsFinalizers = ff}) >> TH.runQ f >> getState >>= go
-    go _ = return ()
+initQState p = QState M.empty Nothing p
 
 -- | The monad in which we run TH computations on the server
 newtype GHCiQ a = GHCiQ { runGHCiQ :: QState -> IO (a, QState) }
@@ -151,9 +149,6 @@ instance Fail.MonadFail GHCiQ where
 getState :: GHCiQ QState
 getState = GHCiQ $ \s -> return (s,s)
 
-putState :: QState -> GHCiQ ()
-putState s = GHCiQ $ \_ -> return ((),s)
-
 noLoc :: TH.Loc
 noLoc = TH.Loc "<no file>" "<no package>" "<no module>" (0,0) (0,0)
 
@@ -198,8 +193,8 @@ instance TH.Quasi GHCiQ where
   qRunIO m = GHCiQ $ \s -> fmap (,s) m
   qAddDependentFile file = ghcCmd (AddDependentFile file)
   qAddTopDecls decls = ghcCmd (AddTopDecls decls)
-  qAddModFinalizer fin = GHCiQ $ \s ->
-    return ((), s { qsFinalizers = fin : qsFinalizers s })
+  qAddModFinalizer fin = GHCiQ (\s -> mkRemoteRef fin >>= return . (, s)) >>=
+                         ghcCmd . AddModFinalizer
   qGetQ = GHCiQ $ \s ->
     let lookup :: forall a. Typeable a => Map TypeRep Dynamic -> Maybe a
         lookup m = fromDynamic =<< M.lookup (typeOf (undefined::a)) m
@@ -216,12 +211,17 @@ startTH = do
   r <- newIORef (initQState (error "startTH: no pipe"))
   mkRemoteRef r
 
--- | The implementation of the 'FinishTH' message.
-finishTH :: Pipe -> RemoteRef (IORef QState) -> IO ()
-finishTH pipe rstate = do
+-- | Runs the mod finalizers.
+--
+-- The references must be created on the caller process.
+runModFinalizerRefs :: Pipe -> RemoteRef (IORef QState)
+                    -> [RemoteRef (TH.Q ())]
+                    -> IO ()
+runModFinalizerRefs pipe rstate qrefs = do
+  qs <- mapM localRef qrefs
   qstateref <- localRef rstate
   qstate <- readIORef qstateref
-  _ <- runGHCiQ runModFinalizers qstate { qsPipe = pipe }
+  _ <- runGHCiQ (TH.runQ $ sequence_ qs) qstate { qsPipe = pipe }
   return ()
 
 -- | The implementation of the 'RunTH' message
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index dfcf471f1d..62bdd10aac 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -458,6 +458,10 @@ addTopDecls ds = Q (qAddTopDecls ds)
 
 -- | Add a finalizer that will run in the Q monad after the current module has
 -- been type checked. This only makes sense when run within a top-level splice.
+--
+-- The finalizer is given the local type environment at the splice point. Thus
+-- 'reify' is able to find the local definitions when executed inside the
+-- finalizer.
 addModFinalizer :: Q () -> Q ()
 addModFinalizer act = Q (qAddModFinalizer (unQ act))
 
diff --git a/testsuite/tests/th/TH_reifyLocalDefs.hs b/testsuite/tests/th/TH_reifyLocalDefs.hs
new file mode 100644
index 0000000000..0bfc90fe1a
--- /dev/null
+++ b/testsuite/tests/th/TH_reifyLocalDefs.hs
@@ -0,0 +1,36 @@
+-- test reification of local definitions
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TemplateHaskell #-}
+import Language.Haskell.TH.Syntax
+import System.IO
+
+-- Sidestep the staging restriction
+-- printTypeOf :: String -> Q ()
+#define printTypeOf(n) (addModFinalizer $ do \
+                       { VarI _ t _ <- reify (mkName (n)) \
+                       ; runIO $ hPutStrLn stderr (n ++ " :: " ++ show t) \
+                       })
+
+main :: IO ()
+main = print (f 1 "", g 'a' 2, h True 3)
+  where
+    f xf yf = ( xf :: Int
+              , let ff $(do printTypeOf("yf")
+                            [p| z |]
+                        ) = z :: $(do printTypeOf("z")
+                                      [t| () |]
+                                  )
+                 in $(do printTypeOf("xf")
+                         [| yf :: String |]
+                     )
+            )
+    g xg y = ( $(do printTypeOf("xg")
+                    [| y :: Int |]
+                )
+             , xg :: Char
+             )
+    h xh y = ( $$(do printTypeOf("xh")
+                     [|| y :: Int ||]
+                 )
+             , xh :: Bool
+             )
diff --git a/testsuite/tests/th/TH_reifyLocalDefs.stderr b/testsuite/tests/th/TH_reifyLocalDefs.stderr
new file mode 100644
index 0000000000..6b654f2986
--- /dev/null
+++ b/testsuite/tests/th/TH_reifyLocalDefs.stderr
@@ -0,0 +1,5 @@
+xh :: ConT GHC.Types.Bool
+xf :: ConT GHC.Types.Int
+z :: TupleT 0
+yf :: ConT GHC.Base.String
+xg :: ConT GHC.Types.Char
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 10da6f0e3c..ff2d6d465f 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -77,6 +77,7 @@ test('TH_spliceD2',
 
 test('TH_reifyDecl1', normal, compile, ['-v0'])
 test('TH_reifyDecl2', normal, compile, ['-v0'])
+test('TH_reifyLocalDefs', normal, compile, ['-v0'])
 
 test('TH_reifyMkName', normal, compile, ['-v0'])