Simon Peyton Jones pushed to branch wip/T24464 at Glasgow Haskell Compiler / GHC Commits: 02fa9d82 by Simon Peyton Jones at 2026-01-17T23:37:42+00:00 Print pat not pat' in pattern match errors in ds_val_bind - - - - - 726ae4c7 by Simon Peyton Jones at 2026-01-17T23:38:31+00:00 Zap unfolding in addImplicitBinds to avoid inlining makeStatic into callers - - - - - 7050a884 by Simon Peyton Jones at 2026-01-17T23:39:10+00:00 Accept err changes - - - - - 495e99fa by Simon Peyton Jones at 2026-01-18T00:13:10+00:00 Get closed types right - - - - - 11 changed files: - compiler/GHC/CoreToStg/AddImplicitBinds.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/Iface/Tidy.hs - compiler/GHC/Iface/Tidy/StaticPtrTable.hs - compiler/GHC/Tc/Gen/Bind.hs - compiler/GHC/Tc/Utils/Env.hs - compiler/GHC/Types/Id/Make.hs - testsuite/tests/codeGen/should_run/CgStaticPointers.hs - testsuite/tests/rename/should_fail/RnStaticPointersFail01.stderr - testsuite/tests/rename/should_fail/RnStaticPointersFail03.stderr - testsuite/tests/warnings/should_fail/CaretDiagnostics1.stderr Changes: ===================================== compiler/GHC/CoreToStg/AddImplicitBinds.hs ===================================== @@ -98,7 +98,6 @@ addImplicitBinds pgm_cfg mod_loc tycons binds mkImplicitBinds :: Bool -> ModLocation -> TyCon -> [CoreBind] -- See Note [Data constructor workers] --- c.f. Note [Injecting implicit bindings] in GHC.Iface.Tidy mkImplicitBinds gen_debug_info mod_loc tycon = classop_binds ++ datacon_binds where ===================================== compiler/GHC/HsToCore/Expr.hs ===================================== @@ -180,7 +180,8 @@ ds_val_bind dflags (NonRecursive, hsbinds) body ; let rhs' = mkOptTickBox rhs_tick rhs_expr ; let body_ty = exprType body ; let mult = getTcMultAnn mult_ann - ; error_expr <- mkErrorAppDs pAT_ERROR_ID body_ty (ppr pat') + ; error_expr <- mkErrorAppDs pAT_ERROR_ID body_ty (ppr pat) + -- Show the original user-written `pat` in error msg ; matchSimply rhs' PatBindRhs mult pat' body error_expr } -- This is the one place where matchSimply is given a non-ManyTy -- multiplicity argument. ===================================== compiler/GHC/Iface/Tidy.hs ===================================== @@ -432,7 +432,7 @@ tidyProgram opts (ModGuts { mg_module = mod -- -- See Note [Don't attempt to trim data types] final_ids = [ trimId (opt_trim_ids opts) id - | id <- bindersOfBinds tidy_binds + | id <- bindersOfBinds tidy_binds' , isExternalName (idName id) , not (isWiredIn id) ] -- See Note [Drop wired-in things] @@ -443,9 +443,6 @@ tidyProgram opts (ModGuts { mg_module = mod tidy_cls_insts = mkFinalClsInsts tidy_type_env $ mkInstEnv cls_insts tidy_rules = tidyRules tidy_env trimmed_rules - -- See Note [Injecting implicit bindings] - all_tidy_binds = tidy_binds' - -- Get the TyCons to generate code for. Careful! We must use -- the untidied TyCons here, because we need -- (a) implicit TyCons arising from types and classes defined @@ -458,13 +455,13 @@ tidyProgram opts (ModGuts { mg_module = mod local_ccs | opt_collect_ccs opts - = collectCostCentres mod all_tidy_binds tidy_rules + = collectCostCentres mod tidy_binds' tidy_rules | otherwise = S.empty return (CgGuts { cg_module = mod , cg_tycons = alg_tycons - , cg_binds = all_tidy_binds + , cg_binds = tidy_binds' , cg_ccs = S.toList local_ccs , cg_foreign = all_foreign_stubs , cg_foreign_files = foreign_files ===================================== compiler/GHC/Iface/Tidy/StaticPtrTable.hs ===================================== @@ -80,20 +80,30 @@ Here is a running example: static form wouldn't be closed because the Show dictionary would come from g's context instead of coming from the top level. -(SF4) The desugarer replaces the static form with a top-level binding for - an application of the function 'makeStatic' (defined in module +(SF4) The desugarer replaces a nested expression (static e) with a top-level + binding for an application of the function 'makeStatic' (defined in module GHC.StaticPtr.Internal of base). So we get - s = fromStaticPtr (makeStatic location k) - f x = ...s... + s = /\abc. makeStatic location e + f x = ...(fromStaticPtr s)... + + The new Id `s` is marked Exported so that it won't be inlined, even though + it is only mentioned once. (SF6) The CoreTidy pass, specifically `sptCreateStaticBinds`, replaces all bindings of the form - b = /\ ... -> makeStatic location value + s = /\ ... -> makeStatic location value with - b = /\ ... -> StaticPtr key (StaticPtrInfo "pkg key" "module" location) value + s = /\ ... -> StaticPtr key + (StaticPtrInfo "pkg key" "module" location) + value where a distinct key is generated for each binding. + We also zap s's unfolding (if any) because we are changing the RHS; and + we don't particularly want client modules to see s's implementation. + (That would be possibly, with a little bit more footwork; e.g. maybe + it'd be better to do this key-generation step in the desugarer.) + (SF7) If we are compiling to object code we insert a C stub (generated by `sptModuleInitCode`) into the final object which runs when the module is loaded, inserting the static forms defined by the module into the RTS's static pointer @@ -154,7 +164,8 @@ data StaticPtrOpts = StaticPtrOpts -- pointer table. -- -- See (SF6) in Note [Grand plan for static forms] -sptCreateStaticBinds :: StaticPtrOpts -> Module -> CoreProgram -> IO ([SptEntry], Maybe CStub, CoreProgram) +sptCreateStaticBinds :: StaticPtrOpts -> Module -> CoreProgram + -> IO ([SptEntry], Maybe CStub, CoreProgram) sptCreateStaticBinds opts this_mod binds = do (fps, binds') <- evalStateT (go [] [] binds) 0 let cstub @@ -186,7 +197,11 @@ sptCreateStaticBinds opts this_mod binds = do Nothing -> return (Nothing, (b, e)) Just (_, t, info, arg) -> do (fp, e') <- mkStaticBind t info arg - return (Just (SptEntry (idName b) fp), (b, foldr Lam e' tvs)) + let b' = zapIdUnfolding b + -- zapIdUnfolding: we are changing the RHS! + -- And we don't particularly want importing clients + -- to see the unfolding anyway + return (Just (SptEntry (idName b) fp), (b', foldr Lam e' tvs)) mkStaticBind :: Type -> CoreExpr -> CoreExpr -> StateT Int IO (Fingerprint, CoreExpr) ===================================== compiler/GHC/Tc/Gen/Bind.hs ===================================== @@ -1798,7 +1798,9 @@ instance Outputable GeneralisationPlan where ppr (CheckGen _ s) = text "CheckGen" <+> ppr s decideGeneralisationPlan - :: DynFlags -> TopLevelFlag -> ClosedTypeId -> TcSigFun + :: DynFlags -> TopLevelFlag + -> ClosedTypeId -- True <=> all the free vars have closed types + -> TcSigFun -> [LHsBind GhcRn] -> GeneralisationPlan decideGeneralisationPlan dflags top_lvl closed_type sig_fn lbinds | Just (bind, sig) <- one_funbind_with_sig = CheckGen bind sig @@ -1812,7 +1814,7 @@ decideGeneralisationPlan dflags top_lvl closed_type sig_fn lbinds -- types (see #25428). So we don't force it. -- See (NVP5) in Note [Non-variable pattern bindings aren't linear] in GHC.Tc.Gen.Bind. - | isTopLevel top_lvl = True + | isTopLevel top_lvl = True -- See Note [Always generalise top-level bindings] | has_mult_anns_and_pats = False ===================================== compiler/GHC/Tc/Utils/Env.hs ===================================== @@ -117,7 +117,7 @@ import GHC.Utils.Misc ( HasDebugCallStack ) import GHC.Data.FastString import GHC.Data.List.SetOps -import GHC.Data.Maybe( MaybeErr(..), maybeToList, fromMaybe ) +import GHC.Data.Maybe( MaybeErr(..), maybeToList, fromMaybe, isNothing ) import GHC.Types.SrcLoc import GHC.Types.Basic hiding( SuccessFlag(..) ) @@ -677,7 +677,8 @@ tcExtendNameTyVarEnv binds thing_inside isTypeClosedLetBndr :: Id -> Bool -- See Note [Bindings with closed types: ClosedTypeId] in GHC.Tc.Types -isTypeClosedLetBndr = noFreeVarsOfType . idType +isTypeClosedLetBndr id + = noFreeVarsOfType (idType id) tcExtendRecIds :: [(Name, TcId)] -> TcM a -> TcM a -- Used for binding the recursive uses of Ids in a binding @@ -712,11 +713,18 @@ tcExtendLetEnv :: TopLevelFlag -> TcSigFun -> ClosedTypeId -- Used for both top-level value bindings and nested let/where-bindings -- Used for a single NonRec or a single Rec -- Adds to the TcBinderStack too -tcExtendLetEnv top_lvl _sig_fn closed ids thing_inside +-- Note (ELE) For Ids that are in `sig_fn` we have /already/ extended the env, +-- using `tcExtendSigIds`, so no point in doing so again. Moreover, for +-- those Ids, we want closed-ness to be driven entirely by the signature, +-- and not by the free vars (which are embodied in `closed`. +tcExtendLetEnv top_lvl sig_fn closed ids thing_inside = tcExtendBinderStack [TcIdBndr id top_lvl | Scaled _ id <- ids] $ tc_extend_local_env top_lvl - [ (idName id, ATcId { tct_id = id, tct_info = LetBound closed }) - | Scaled _ id <- ids ] $ + [ (id_nm, ATcId { tct_id = id, tct_info = LetBound closed }) + | Scaled _ id <- ids + , let id_nm = idName id + , isNothing (sig_fn id_nm) -- See (ELE) above + ] $ foldr check_one_usg thing_inside ids where check_one_usg (Scaled mult id) thing_inside ===================================== compiler/GHC/Types/Id/Make.hs ===================================== @@ -916,8 +916,8 @@ mkDataConRep dc_bang_opts fam_envs wrap_name data_con (rep_tys, rep_strs) = unzip (concat rep_tys_w_strs) -- This is True if the data constructor or class dictionary constructor - -- needs a wrapper. This wrapper is injected into the program later in the - -- CoreTidy pass. See Note [Injecting implicit bindings] in GHC.Iface.Tidy, + -- needs a wrapper. This wrapper is injected into the program later in the CoreTidy + -- pass. See Note [Injecting implicit bindings] in GHC.CoreToStg.AddImplicitBinds -- along with the accompanying implementation in getTyConImplicitBinds. wrapper_reqd | isTypeDataTyCon tycon ===================================== testsuite/tests/codeGen/should_run/CgStaticPointers.hs ===================================== @@ -15,9 +15,9 @@ main = do print $ deRefStaticPtr (static g) print $ deRefStaticPtr p0 'a' print $ deRefStaticPtr (static t_field) $ T 'b' - where - g :: String - g = "found" + +g :: String +g = "found" lookupKey :: StaticPtr a -> IO a lookupKey p = unsafeLookupStaticPtr (staticKey p) >>= \case ===================================== testsuite/tests/rename/should_fail/RnStaticPointersFail01.stderr ===================================== @@ -1,6 +1,3 @@ - RnStaticPointersFail01.hs:5:7: error: [GHC-88431] - • ‘x’ is used in a static form but it is not closed because it - is not let-bound. - • In the expression: static x - In an equation for ‘f’: f x = static x + ‘x’ is used in a static form but it is not defined at top level + ===================================== testsuite/tests/rename/should_fail/RnStaticPointersFail03.stderr ===================================== @@ -1,29 +1,12 @@ - RnStaticPointersFail03.hs:8:7: error: [GHC-88431] - • ‘x’ is used in a static form but it is not closed because it - is not let-bound. - • In the expression: static (x . id) - In an equation for ‘f’: f x = static (x . id) + ‘x’ is used in a static form but it is not defined at top level RnStaticPointersFail03.hs:10:8: error: [GHC-88431] - • ‘k’ is used in a static form but it is not closed because it - uses ‘x’ which is not let-bound. - • In the expression: static (k . id) - In an equation for ‘f0’: - f0 x - = static (k . id) - where - k = const (const () x) + ‘k’ is used in a static form but it is not defined at top level + +RnStaticPointersFail03.hs:14:8: error: [GHC-88431] + ‘k’ is used in a static form but it is not defined at top level RnStaticPointersFail03.hs:19:15: error: [GHC-88431] - • ‘g’ is used in a static form but it is not closed because it - uses ‘h’ which has a non-closed type because it contains the - type variables: ‘a’ - • In the first argument of ‘const’, namely ‘(static (g undefined))’ - In the expression: const (static (g undefined)) (h x) - In an equation for ‘f2’: - f2 x - = const (static (g undefined)) (h x) - where - g = h - h = typeOf + ‘g’ is used in a static form but it is not defined at top level + ===================================== testsuite/tests/warnings/should_fail/CaretDiagnostics1.stderr ===================================== @@ -1,5 +1,5 @@ CaretDiagnostics1.hs:7:8-15: error: [GHC-83865] - • Couldn't match expected type ‘IO a0’ with actual type ‘Int’ + • Couldn't match expected type ‘IO a1’ with actual type ‘Int’ • In the second argument of ‘(+)’, namely ‘(3 :: Int)’ In a stmt of a 'do' block: 10000000000000000000000000000000000000 + 2 + (3 :: Int) @@ -23,9 +23,9 @@ CaretDiagnostics1.hs:8:9-27: error: [GHC-83865] | ^^^^^^^^^^^^^^^^^^^ CaretDiagnostics1.hs:13:7-11: error: [GHC-83865] - • Couldn't match type: a1 -> a1 + • Couldn't match type: a0 -> a0 with: [Char] - Expected: a1 -> a1 + Expected: a0 -> a0 Actual: String • In the pattern: "γηξ" In a case alternative: "γηξ" -> () '0' View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5034e877fbae2f522c20dff41c2f481... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5034e877fbae2f522c20dff41c2f481... You're receiving this email because of your account on gitlab.haskell.org.