Oleg Grenrus pushed to branch wip/keepAlive-th-names-found-in-annotations at Glasgow Haskell Compiler / GHC Commits: cf370101 by Oleg Grenrus at 2025-10-09T01:33:01+03:00 keepAlive TH.Names found in annotations - - - - - 4 changed files: - compiler/GHC/Rename/Splice.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Types/Meta.hs - compiler/GHC/Utils/Outputable.hs Changes: ===================================== compiler/GHC/Rename/Splice.hs ===================================== @@ -187,6 +187,7 @@ rn_utbracket (VarBr _ flg rdr_name) ; let res_name = L (l2l (locA rdr_name)) (WithUserRdr (unLoc rdr_name) name) ; if flg then checkThLocalNameNoLift res_name else checkThLocalTyName name ; check_namespace flg name + ; keepAlive name ; return (VarBr noExtField flg (noLocA name), unitFV name) } rn_utbracket (ExpBr _ e) = do { (e', fvs) <- rnLExpr e @@ -1072,6 +1073,32 @@ a bit hacky. For these chaps (which have Internal Names) we don't want to put them in the keep-alive set. +Note [Keeping things alive referenced by TH.Name from annotations] + +Consider + + {-# ANN module 'f #-} + +We stage-check annotations as splices, because we are going to run them, +and thus similar stage restrictions apply. + +That however leads for 'f not being persisted. Consider briefly + + expr = $( [| f |] ) + +Here, `f` isn't kept alive by the same mechanism as in +Note [Keeping things alive for Template Haskell], as there isn't need for that. +Once the splice is evaluated and spliced, compiler will see + + expr = f + +in other words, there will be explicit use of `f`. + +Returning back to the ANN example: once the annotation is run, +we previously had an opaque Serialised blob. There might be a TH Name inside, +but GHC won't know about it. To work around that we not only serialise +the annotation value, but also traverse it to extract all TH Names. + Note [Quoting names] ~~~~~~~~~~~~~~~~~~~~ A quoted name 'n is a bit like a quoted expression [| n |], except that we ===================================== compiler/GHC/Tc/Gen/Splice.hs ===================================== @@ -166,14 +166,16 @@ import qualified Data.ByteString.Lazy as LB import Data.Dynamic ( fromDynamic, toDyn ) import qualified Data.IntMap as IntMap import qualified Data.Map as Map -import Data.Typeable ( typeOf, Typeable, TypeRep, typeRep ) -import Data.Data (Data) +import Data.Typeable ( typeOf, Typeable, TypeRep, typeRep, cast ) +import Data.Data (Data, gmapQ) import Data.Proxy ( Proxy (..) ) import Data.IORef import GHC.Parser.HaddockLex (lexHsDoc) import GHC.Parser (parseIdentifier) import GHC.Rename.Doc (rnHsDoc) +import Debug.Trace + {- Note [Template Haskell state diagram] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -668,14 +670,12 @@ Example: -} -- None of these functions add constraints to the LIE - -tcTypedBracket :: HsExpr GhcRn -> LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) -tcUntypedBracket :: HsExpr GhcRn -> HsQuote GhcRn -> [PendingRnSplice] -> ExpRhoType - -> TcM (HsExpr GhcTc) -tcTypedSplice :: HsTypedSpliceResult -> HsTypedSplice GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) - -getUntypedSpliceBody :: HsUntypedSpliceResult (HsExpr GhcRn) -> TcM (HsExpr GhcRn) -runAnnotation :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation +-- +-- * tcTypedBracket +-- * tcUntypedBracket +-- * tcTypedSplice +-- * getUntypedSpliceBody +-- * runAnnotation {- ************************************************************************ @@ -686,6 +686,7 @@ runAnnotation :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation -} -- See Note [How brackets and nested splices are handled] +tcTypedBracket :: HsExpr GhcRn -> LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) tcTypedBracket rn_expr expr res_ty = addErrCtxt (TypedTHBracketCtxt expr) $ do { cur_lvl <- getThLevel @@ -728,6 +729,7 @@ tcTypedBracket rn_expr expr res_ty meta_ty res_ty } -- See Note [Typechecking Overloaded Quotes] +tcUntypedBracket :: HsExpr GhcRn -> HsQuote GhcRn -> [PendingRnSplice] -> ExpRhoType -> TcM (HsExpr GhcTc) tcUntypedBracket rn_expr brack ps res_ty = do { traceTc "tc_bracket untyped" (ppr brack $$ ppr ps) @@ -929,6 +931,7 @@ tcCodeTy m_ty exp_ty -- getUntypedSpliceBody: the renamer has expanded the splice. -- Just run the finalizers that it produced, and return -- the renamed expression +getUntypedSpliceBody :: HsUntypedSpliceResult (HsExpr GhcRn) -> TcM (HsExpr GhcRn) getUntypedSpliceBody (HsUntypedSpliceTop { utsplice_result_finalizers = mod_finalizers , utsplice_result = rn_expr }) = do { addModFinalizersWithLclEnv mod_finalizers @@ -936,6 +939,7 @@ getUntypedSpliceBody (HsUntypedSpliceTop { utsplice_result_finalizers = mod_fina getUntypedSpliceBody (HsUntypedSpliceNested {}) = panic "tcTopUntypedSplice: invalid nested splice" +tcTypedSplice :: HsTypedSpliceResult -> HsTypedSplice GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) tcTypedSplice HsTypedSpliceTop ctxt@(HsTypedSpliceExpr _ expr) res_ty = addErrCtxt (TypedSpliceCtxt Nothing ctxt) $ setSrcSpan (getLocA expr) $ @@ -1082,6 +1086,7 @@ stubNestedSplice = warnPprTrace True "stubNestedSplice" empty $ ************************************************************************ -} +runAnnotation :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation runAnnotation target expr = do -- Find the classes we want instances for in order to call toAnnotationWrapper loc <- getSrcSpanM @@ -1106,17 +1111,33 @@ runAnnotation target expr = do specialised_to_annotation_wrapper_expr expr')) }) + traceM $ "runAnnotation: " ++ showPprUnsafe zonked_wrapped_expr' + -- Run the appropriately wrapped expression to get the value of -- the annotation and its dictionaries. The return value is of -- type AnnotationWrapper by construction, so this conversion is -- safe - serialized <- runMetaAW zonked_wrapped_expr' + (names, serialized) <- runMetaAW zonked_wrapped_expr' + -- See Note [Keeping things alive referenced by TH.Name from annotations] + traceM $ "runAnnotation names: " ++ showPprUnsafe names +{- + forM_ names $ \th_name -> do + mb_name <- lookupThName_maybe th_name + traceM $ "runAnnotation found: " ++ showPprUnsafe mb_name + forM_ mb_name keepAlive -- TODO: do we need to do checks, like isExternalName here? +-} + return Annotation { ann_target = target, ann_value = serialized } -convertAnnotationWrapper :: ForeignHValue -> TcM Serialized +extractTHNames :: Data a => a -> [TH.Name] +extractTHNames x = case cast x of + Just n -> [n] + Nothing -> concat (gmapQ extractTHNames x) + +convertAnnotationWrapper :: ForeignHValue -> TcM ([TH.Name], Serialized) convertAnnotationWrapper fhv = do interp <- tcGetInterp case interpInstance interp of @@ -1133,8 +1154,7 @@ convertAnnotationWrapper fhv = do -- annotation are exposed at this point. This is also why we are -- doing all this stuff inside the context of runMeta: it has the -- facilities to deal with user error in a meta-level expression - rnf serialized `seq` serialized - + (extractTHNames value, rnf serialized `seq` serialized) #endif {- @@ -1216,7 +1236,7 @@ defaultRunMeta (MetaAW r) ---------------- runMetaAW :: LHsExpr GhcTc -- Of type AnnotationWrapper - -> TcM Serialized + -> TcM ([TH.Name], Serialized) runMetaAW = runMeta metaRequestAW runMetaE :: LHsExpr GhcTc -- Of type (Q Exp) ===================================== compiler/GHC/Types/Meta.hs ===================================== @@ -14,6 +14,7 @@ where import GHC.Prelude import GHC.Serialized ( Serialized ) +import qualified GHC.Boot.TH.Syntax as TH import GHC.Hs import GHC.Utils.Outputable @@ -26,7 +27,7 @@ data MetaRequest | MetaP (LPat GhcPs -> MetaResult) | MetaT (LHsType GhcPs -> MetaResult) | MetaD ([LHsDecl GhcPs] -> MetaResult) - | MetaAW (Serialized -> MetaResult) + | MetaAW (([TH.Name], Serialized) -> MetaResult) -- | data constructors not exported to ensure correct result type data MetaResult @@ -34,7 +35,7 @@ data MetaResult | MetaResP (LPat GhcPs) | MetaResT (LHsType GhcPs) | MetaResD [LHsDecl GhcPs] - | MetaResAW Serialized + | MetaResAW ([TH.Name], Serialized) instance Outputable MetaResult where ppr (MetaResE e) = text "MetaResE" <> braces (ppr e) @@ -63,7 +64,7 @@ unMetaResD :: MetaResult -> [LHsDecl GhcPs] unMetaResD (MetaResD d) = d unMetaResD mr = pprPanic "unMetaResD" (ppr mr) -unMetaResAW :: MetaResult -> Serialized +unMetaResAW :: MetaResult -> ([TH.Name], Serialized) unMetaResAW (MetaResAW aw) = aw unMetaResAW mr = pprPanic "unMetaResAW" (ppr mr) @@ -81,6 +82,6 @@ metaRequestT h = fmap unMetaResT . h (MetaT MetaResT) metaRequestD :: Functor f => MetaHook f -> LHsExpr GhcTc -> f [LHsDecl GhcPs] metaRequestD h = fmap unMetaResD . h (MetaD MetaResD) -metaRequestAW :: Functor f => MetaHook f -> LHsExpr GhcTc -> f Serialized +metaRequestAW :: Functor f => MetaHook f -> LHsExpr GhcTc -> f ([TH.Name], Serialized) metaRequestAW h = fmap unMetaResAW . h (MetaAW MetaResAW) ===================================== compiler/GHC/Utils/Outputable.hs ===================================== @@ -167,6 +167,8 @@ import GHC.Show ( showMultiLineString ) import GHC.Utils.Exception import GHC.Exts (oneShot) +import qualified GHC.Boot.TH.Syntax as TH + {- ************************************************************************ * * @@ -1094,13 +1096,15 @@ instance Outputable a => Outputable (SCC a) where instance Outputable Serialized where ppr (Serialized the_type bytes) = int (length bytes) <+> text "of type" <+> text (show the_type) +instance Outputable TH.Name where + ppr = text . TH.showName + instance Outputable Extension where ppr = text . show instance Outputable ModuleName where ppr = pprModuleName - pprModuleName :: IsLine doc => ModuleName -> doc pprModuleName (ModuleName nm) = docWithStyle (ztext (zEncodeFS nm)) (\_ -> ftext nm) @@ -1250,6 +1254,7 @@ instance (OutputableP env a) => OutputableP env (Set a) where instance OutputableP env Void where pdoc _ = \ case + {- ************************************************************************ * * View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cf37010100b816368bebd31e98e87852... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cf37010100b816368bebd31e98e87852... You're receiving this email because of your account on gitlab.haskell.org.