Simon Peyton Jones pushed to branch wip/T24464 at Glasgow Haskell Compiler / GHC Commits: 5034e877 by Simon Peyton Jones at 2026-01-17T18:26:40+00:00 Wibbles tidying up - - - - - 9 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Syn/Type.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/Utils/Env.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Tc/Zonk/Type.hs Changes: ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -361,8 +361,9 @@ type instance XProc (GhcPass _) = (EpToken "proc", TokRarrow) type instance XStatic GhcPs = EpToken "static" type instance XStatic GhcRn = NoExtField -type instance XStatic GhcTc = Type - -- Type of expression, this is stored for convenience as wiring in +type instance XStatic GhcTc = (Type, HsExpr GhcTc) + -- Type of expression, and the (fromStaticPtr function) + -- These are stored for convenience as the wiring in -- StaticPtr is a bit tricky (see #20150) type instance XEmbTy GhcPs = EpToken "type" ===================================== compiler/GHC/Hs/Syn/Type.hs ===================================== @@ -142,7 +142,7 @@ hsExprType e@(HsTypedSplice{}) = pprPanic "hsExprType: Unexpected HsTypedSplice" -- than in the typechecked AST. hsExprType (HsUntypedSplice ext _) = dataConCantHappen ext hsExprType (HsProc _ _ lcmd_top) = lhsCmdTopType lcmd_top -hsExprType (HsStatic ty _s) = ty +hsExprType (HsStatic (ty,_) _s) = ty hsExprType (HsPragE _ _ e) = lhsExprType e hsExprType (HsEmbTy x _) = dataConCantHappen x hsExprType (HsHole (_, (HER _ ty _))) = ty ===================================== compiler/GHC/HsToCore/Expr.hs ===================================== @@ -465,22 +465,26 @@ dsExpr (ArithSeq expr witness seq) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable for an overview. - g = ... static e ... -==> - s = /\abc. e - g = ... (s @a @b @c) ... + ... static{from_static_ptr} e ... + ==> + s = /\abc. makeStatic e + ... (from_static_ptr (s @a @b @c)) ... + +Here `from_static_ptr` is a suitably-instantiated instantiated version of +the overloaded function `fromStaticPtr`. -} -dsExpr (HsStatic whole_ty expr@(L loc _)) +dsExpr (HsStatic (static_ptr_ty, from_static_fun) expr@(L loc _)) = do { dflags <- getDynFlags ; make_static_id <- dsLookupGlobalId makeStaticName ; expr_ds <- dsLExpr expr + ; from_static_ds <- dsExpr from_static_fun -- The static expression can have free type variables, -- which we should quantify. We can also have free Ids, -- but they will be bound at top level - ; let (_, [ty]) = splitTyConApp whole_ty + ; let (_, [ty]) = splitTyConApp static_ptr_ty static_fvs :: [Var] static_fvs = scopedSort $ @@ -498,11 +502,11 @@ dsExpr (HsStatic whole_ty expr@(L loc _)) static_rhs = mkLams static_fvs $ mkCoreApps (Var make_static_id) [ Type ty, srcLoc, expr_ds ] - ; static_id <- newStaticId (mkSpecForAllTys static_fvs whole_ty) + ; static_id <- newStaticId (mkSpecForAllTys static_fvs static_ptr_ty) ; emitStaticBinds [(static_id, static_rhs)] - ; return (mkVarApps (Var static_id) static_fvs) } + ; return (App from_static_ds (mkVarApps (Var static_id) static_fvs)) } {- Note [Desugaring record construction] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Rename/Expr.hs ===================================== @@ -44,7 +44,7 @@ import GHC.Rename.Pat import GHC.Driver.DynFlags import GHC.Builtin.Names import GHC.Builtin.Types ( nilDataConName ) -import GHC.Unit.Module ( getModule, isInteractiveModule ) +import GHC.Unit.Module ( isInteractiveModule ) import GHC.Types.Basic (TypeOrKind (TypeLevel)) import GHC.Types.FieldLabel ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -589,16 +589,16 @@ tcExpr (HsStatic _ expr) res_ty [liftedTypeKind, expr_ty] -- Wrap the static form with the 'fromStaticPtr' call. - ; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName - [p_ty] + -- fromStaticPtr :: forall p. (IsStatic p) => + -- forall a. (Typeable a) => + -- StaticPtr a -> p a + ; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName [p_ty] ; static_ptr_ty_con <- tcLookupTyCon staticPtrTyConName - ; loc <- getSrcSpanM ; let wrap = mkWpEvVarApps [typeable_ev] <.> mkWpTyApps [expr_ty] - expr_ty = mkTyConApp static_ptr_ty_con [expr_ty] + static_expr_ty = mkTyConApp static_ptr_ty_con [expr_ty] ; return $ mkHsWrapCo co $ - HsApp noExtField - (L (noAnnSrcSpan loc) $ mkHsWrap wrap fromStaticPtr) - (L (noAnnSrcSpan loc) (HsStatic expr_ty expr'')) + HsStatic (static_expr_ty, mkHsWrap wrap fromStaticPtr) + expr'' } tcExpr (HsEmbTy _ _) _ = failWith (TcRnIllegalTypeExpr TypeKeywordSyntax) ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -561,10 +561,11 @@ tcRnSrcDecls explicit_mod_hdr export_ies decls -- and affects how names are rendered in error messages -- * the local env exposes the local Ids to simplifyTop, -- so that we get better error messages (monomorphism restriction) - ; new_ev_binds <- {-# SCC "simplifyTop" #-} - restoreEnvs (tcg_env, tcl_env) $ - do { lie_main <- checkMainType tcg_env - ; simplifyTop (lie `andWC` lie_main) } + ; tcg_env <- {-# SCC "simplifyTop" #-} + restoreEnvs (tcg_env, tcl_env) $ + do { lie_main <- checkMainType tcg_env + ; ev_binds <- simplifyTop (lie `andWC` lie_main) + ; return (tcg_env `addEvBinds` ev_binds) } -- Emit Typeable bindings ; tcg_env <- setGblEnv tcg_env $ @@ -579,7 +580,8 @@ tcRnSrcDecls explicit_mod_hdr export_ies decls -- Even simplifyTop may do some unification. -- This pass also warns about missing type signatures ; (id_env, ev_binds', binds', fords', imp_specs', rules', pat_syns') - <- zonkTcGblEnv new_ev_binds tcg_env + <- zonkTcGblEnv tcg_env + ; traceTc "Tc10" empty --------- Run finalizers -------------- -- Finalizers must run after constraints are simplified, lest types @@ -613,12 +615,12 @@ tcRnSrcDecls explicit_mod_hdr export_ies decls --------- Emit the ':Main.main = runMainIO main' declaration ---------- -- Do this /after/ rnExports, so that it can consult -- the tcg_exports created by rnExports - ; (tcg_env, main_ev_binds) + ; tcg_env <- restoreEnvs (tcg_env, tcl_env) $ do { (tcg_env, lie) <- captureTopConstraints $ checkMain explicit_mod_hdr export_ies ; ev_binds <- simplifyTop lie - ; return (tcg_env, ev_binds) } + ; return (tcg_env `addEvBinds` ev_binds) } ; failIfErrsM -- Stop now if if there have been errors -- Continuing is a waste of time; and we may get debug @@ -629,7 +631,7 @@ tcRnSrcDecls explicit_mod_hdr export_ies decls -- and main. This won't give rise to any more finalisers as you -- can't nest finalisers inside finalisers. ; (id_env_mf, ev_binds_mf, binds_mf, fords_mf, imp_specs_mf, rules_mf, patsyns_mf) - <- zonkTcGblEnv main_ev_binds tcg_env + <- zonkTcGblEnv tcg_env ; let { !final_type_env = tcg_type_env tcg_env `plusTypeEnv` id_env_mf @@ -648,20 +650,19 @@ tcRnSrcDecls explicit_mod_hdr export_ies decls ; setGlobalTypeEnv tcg_env' final_type_env } -zonkTcGblEnv :: Bag EvBind -> TcGblEnv +zonkTcGblEnv :: TcGblEnv -> TcM (TypeEnv, Bag EvBind, LHsBinds GhcTc, [LForeignDecl GhcTc], [LTcSpecPrag], [LRuleDecl GhcTc], [PatSyn]) -zonkTcGblEnv ev_binds tcg_env@(TcGblEnv { tcg_binds = binds - , tcg_ev_binds = cur_ev_binds - , tcg_imp_specs = imp_specs - , tcg_rules = rules - , tcg_fords = fords - , tcg_patsyns = pat_syns }) +zonkTcGblEnv tcg_env@(TcGblEnv { tcg_binds = binds + , tcg_ev_binds = ev_binds + , tcg_imp_specs = imp_specs + , tcg_rules = rules + , tcg_fords = fords + , tcg_patsyns = pat_syns }) = {-# SCC "zonkTopDecls" #-} setGblEnv tcg_env $ -- This sets the GlobalRdrEnv which is used when rendering -- error messages during zonking (notably levity errors) - do { let all_ev_binds = cur_ev_binds `unionBags` ev_binds - ; zonkTopDecls all_ev_binds binds rules imp_specs fords pat_syns } + zonkTopDecls ev_binds binds rules imp_specs fords pat_syns -- | Runs TH finalizers and renames and typechecks the top-level declarations -- that they could introduce. ===================================== compiler/GHC/Tc/Utils/Env.hs ===================================== @@ -25,7 +25,7 @@ module GHC.Tc.Utils.Env( tcLookupLocatedGlobalId, tcLookupLocatedTyCon, tcLookupLocatedClass, tcLookupAxiom, lookupGlobal, lookupGlobal_maybe, - addTypecheckedBinds, + addTypecheckedBinds, addEvBinds, addTopEvBinds, failIllegalTyCon, failIllegalTyVar, -- Local environment @@ -90,6 +90,7 @@ import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType import GHC.Tc.Utils.TcMType ( tcCheckUsage ) import GHC.Tc.Types.LclEnv +import GHC.Tc.Types.Evidence import GHC.Core.InstEnv import GHC.Core.DataCon ( DataCon, dataConTyCon, flSelector ) @@ -139,6 +140,8 @@ import GHC.Rename.Unbound ( unknownNameSuggestions ) import GHC.Tc.Errors.Types.PromotionErr import {-# SOURCE #-} GHC.Tc.Errors.Hole (getHoleFitDispConfig) +import GHC.Data.Bag + import Control.Monad import Data.IORef import Data.List ( intercalate ) @@ -212,6 +215,17 @@ addTypecheckedBinds tcg_env binds | otherwise = tcg_env { tcg_binds = foldr (++) (tcg_binds tcg_env) binds } + +addEvBinds :: TcGblEnv -> Bag EvBind -> TcGblEnv +addEvBinds tcg_env ev_binds + = tcg_env { tcg_ev_binds = tcg_ev_binds tcg_env `unionBags` ev_binds } + +addTopEvBinds :: Bag EvBind -> TcM a -> TcM a +-- Defined here (rather than in GHC.Tc.Utils.Monad) +-- because it depends on addEvBinds +addTopEvBinds new_ev_binds thing_inside + = updGblEnv (\env -> env `addEvBinds` new_ev_binds) thing_inside + {- ************************************************************************ * * ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -104,7 +104,7 @@ module GHC.Tc.Utils.Monad( -- * Type constraints newTcEvBinds, newNoTcEvBinds, cloneEvBindsVar, - addTcEvBind, addTcEvBinds, addTopEvBinds, + addTcEvBind, addTcEvBinds, getTcEvBindsMap, setTcEvBindsMap, updTcEvBinds, getTcEvTyCoVars, chooseUniqueOccTc, getConstraintVar, setConstraintVar, @@ -1852,13 +1852,6 @@ debugTc thing ************************************************************************ -} -addTopEvBinds :: Bag EvBind -> TcM a -> TcM a -addTopEvBinds new_ev_binds thing_inside - =updGblEnv upd_env thing_inside - where - upd_env tcg_env = tcg_env { tcg_ev_binds = tcg_ev_binds tcg_env - `unionBags` new_ev_binds } - newTcEvBinds :: TcM EvBindsVar newTcEvBinds = do { binds_ref <- newTcRef emptyEvBindMap ; tcvs_ref <- newTcRef [] ===================================== compiler/GHC/Tc/Zonk/Type.hs ===================================== @@ -1078,9 +1078,10 @@ zonkExpr (HsProc x pat body) ; return (HsProc x new_pat new_body) } -- StaticPointers extension -zonkExpr (HsStatic ty expr) +zonkExpr (HsStatic (ty, fs) expr) = do new_ty <- zonkTcTypeToTypeX ty - HsStatic new_ty <$> zonkLExpr expr + new_fs <- zonkExpr fs + HsStatic (new_ty, new_fs) <$> zonkLExpr expr zonkExpr (HsEmbTy x _) = dataConCantHappen x zonkExpr (HsQual x _ _) = dataConCantHappen x View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5034e877fbae2f522c20dff41c2f481b... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5034e877fbae2f522c20dff41c2f481b... You're receiving this email because of your account on gitlab.haskell.org.