Commit 567dbd9b authored by Facundo Domínguez's avatar Facundo Domínguez

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
parent f560a03c
......@@ -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
......
......@@ -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)) <>
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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
----------------
......
......@@ -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
{-
************************************************************************
* *
......
......@@ -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
......
......@@ -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.