Andrei Borzenkov pushed to branch wip/sand-witch/make-set-field at Glasgow Haskell Compiler / GHC Commits: 88d6c414 by Andrei Borzenkov at 2025-07-02T22:10:04+04:00 Small fixes after intensive testing - - - - - 7 changed files: - compiler/GHC/Builtin/Names.hs - compiler/GHC/Core/Make.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/TyCl/Utils.hs - compiler/GHC/Tc/Types.hs - libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs Changes: ===================================== compiler/GHC/Builtin/Names.hs ===================================== @@ -2308,7 +2308,7 @@ wildCardKey, absentErrorIdKey, absentConstraintErrorIdKey, augmentIdKey, appendI noMethodBindingErrorIdKey, nonExhaustiveGuardsErrorIdKey, impossibleErrorIdKey, impossibleConstraintErrorIdKey, patErrorIdKey, voidPrimIdKey, - realWorldPrimIdKey, recConErrorIdKey, + realWorldPrimIdKey, recConErrorIdKey, recUpdErrorIdKey, unpackCStringUtf8IdKey, unpackCStringAppendUtf8IdKey, unpackCStringFoldrUtf8IdKey, unpackCStringIdKey, unpackCStringAppendIdKey, unpackCStringFoldrIdKey, typeErrorIdKey, divIntIdKey, modIntIdKey, @@ -2409,6 +2409,7 @@ rationalToFloatIdKey = mkPreludeMiscIdUnique 132 rationalToDoubleIdKey = mkPreludeMiscIdUnique 133 seqHashKey = mkPreludeMiscIdUnique 134 +recUpdErrorIdKey = mkPreludeMiscIdUnique 135 coerceKey :: Unique coerceKey = mkPreludeMiscIdUnique 157 ===================================== compiler/GHC/Core/Make.hs ===================================== @@ -42,7 +42,7 @@ module GHC.Core.Make ( -- * Error Ids mkRuntimeErrorApp, mkImpossibleExpr, mkAbsentErrorApp, errorIds, - rEC_CON_ERROR_ID, + rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, pAT_ERROR_ID, rEC_SEL_ERROR_ID, tYPE_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID @@ -897,6 +897,7 @@ errorIds nO_METHOD_BINDING_ERROR_ID, pAT_ERROR_ID, rEC_CON_ERROR_ID, + rEC_UPD_ERROR_ID, rEC_SEL_ERROR_ID, iMPOSSIBLE_ERROR_ID, iMPOSSIBLE_CONSTRAINT_ERROR_ID, aBSENT_ERROR_ID, aBSENT_CONSTRAINT_ERROR_ID, @@ -904,13 +905,14 @@ errorIds tYPE_ERROR_ID -- Used with Opt_DeferTypeErrors, see #10284 ] -recSelErrorName, recConErrorName, patErrorName :: Name +recSelErrorName, recConErrorName, patErrorName, recUpdErrorName :: Name nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name typeErrorName :: Name absentSumFieldErrorName :: Name recSelErrorName = err_nm "recSelError" recSelErrorIdKey rEC_SEL_ERROR_ID recConErrorName = err_nm "recConError" recConErrorIdKey rEC_CON_ERROR_ID +recUpdErrorName = err_nm "recUpdError" recUpdErrorIdKey rEC_UPD_ERROR_ID patErrorName = err_nm "patError" patErrorIdKey pAT_ERROR_ID typeErrorName = err_nm "typeError" typeErrorIdKey tYPE_ERROR_ID @@ -922,11 +924,12 @@ nonExhaustiveGuardsErrorName = err_nm "nonExhaustiveGuardsError" err_nm :: String -> Unique -> Id -> Name err_nm str uniq id = mkWiredInIdName gHC_INTERNAL_CONTROL_EXCEPTION_BASE (fsLit str) uniq id -rEC_SEL_ERROR_ID, rEC_CON_ERROR_ID :: Id +rEC_SEL_ERROR_ID, rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID :: Id pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id tYPE_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID :: Id rEC_SEL_ERROR_ID = mkRuntimeErrorId TypeLike recSelErrorName rEC_CON_ERROR_ID = mkRuntimeErrorId TypeLike recConErrorName +rEC_UPD_ERROR_ID = mkRuntimeErrorId TypeLike recUpdErrorName pAT_ERROR_ID = mkRuntimeErrorId TypeLike patErrorName nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId TypeLike noMethodBindingErrorName nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId TypeLike nonExhaustiveGuardsErrorName ===================================== compiler/GHC/Tc/Instance/Class.hs ===================================== @@ -1340,7 +1340,7 @@ matchSetField dflags short_cut clas tys mb_ct_loc -- Use the equality proof to cast the selector Id to -- type (r -> a), then use the newtype coercion to cast -- it to a HasField dictionary. - mk_ev (ev1:ev2:evs) = evDFunApp (dataConWrapId dCon) (tys ++ tvs) + mk_ev (ev1:ev2:evs) = evDFunApp (dataConWrapId dCon) tys [ evSelector modifier_id tvs evs `Cast` co ev2 , evSelector setter_id tvs evs `Cast` co ev1 ] @@ -1395,7 +1395,7 @@ matchSetField dflags short_cut clas tys mb_ct_loc pure (setter, modifier) Nothing -> do binds@((setter, _), (modifier,_)) <- mkSetFieldBinds tycon fl - writeTcRef req_flds ((fl, binds) : reqs) + updTcRef req_flds ((fl, binds) : ) pure (setter, modifier) tc_inst_setfield_binds setter_id modifier_id ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -579,12 +579,13 @@ tcRnSrcDecls explicit_mod_hdr export_ies decls -- Emit Typeable bindings ; tcg_env <- setGblEnv tcg_env $ mkTypeableBinds + ; (tcg_env, recs_lie) <- setGblEnv tcg_env $ captureTopConstraints $ tcRecSetterBinds ; rec_ev_binds <- restoreEnvs (tcg_env, tcl_env) $ - simplifyTop recs_lie -- Is that required? + simplifyTop recs_lie -- TODO sand-witch: Is that required? ; let new_ev_binds = main_ev_binds `mappend` rec_ev_binds ===================================== compiler/GHC/Tc/TyCl/Utils.hs ===================================== @@ -42,7 +42,7 @@ import GHC.Hs import GHC.Core.TyCo.Rep( Type(..), Coercion(..), MCoercion(..) ) import GHC.Core.Multiplicity import GHC.Core.Predicate -import GHC.Core.Make( rEC_SEL_ERROR_ID ) +import GHC.Core.Make( rEC_SEL_ERROR_ID, rEC_UPD_ERROR_ID ) import GHC.Core.Class import GHC.Core.Type import GHC.Core.TyCon @@ -868,19 +868,22 @@ mkRecSelBind (tycon, fl) mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel -> FieldSelectors -> (Id, LHsBind GhcRn) mkOneRecordSelector all_cons idDetails fl has_sel - = collectFieldLabelInfo all_cons idDetails fl has_sel mkRecordSelectorBind + = collectFieldLabelInfo all_cons idDetails fl has_sel mkRecordSelectorBind mkRecordSelectorBind :: RecordBindBuilder (Id, LHsBind GhcRn) -mkRecordSelectorBind = mk_record_bind mk_sel_ty mk_match where +mkRecordSelectorBind fl = mk_record_bind 1 err_expr mk_sel_ty mk_match fl where + + err_expr = make_rec_error_expr fl rEC_SEL_ERROR_ID + mk_sel_ty :: Type -> Type -> Type - mk_sel_ty data_ty field_ty = + mk_sel_ty data_ty field_ty = mkVisFunTyMany data_ty $ -- Record selectors are always typed with Many. We -- could improve on it in the case where all the -- fields in all the constructor have multiplicity Many. field_ty - mk_match sel_name match_ctxt con = + mk_match sel_name match_ctxt con = mkSimpleMatch match_ctxt (L loc [L loc (mk_sel_pat con)]) (L loc (mkHsVar (L loc field_var))) @@ -915,7 +918,7 @@ tcRecSetterBinds = do where remove_binds (n, ((setter, _), (modifier, _))) = (flSelector n, (setter, modifier)) get_ids_to_check [] = [] - get_ids_to_check ( (_, (setter, modifier)) : flds) = + get_ids_to_check ( (_, (setter, modifier)) : flds) = setter : modifier : get_ids_to_check flds @@ -928,41 +931,44 @@ mkSetFieldBinds tycon fl = idDetails = RecSelData tycon mk_field_lbl prefix uniq = - let + let lbl = flLabel fl newOcc = mkOccNameFS varName (mkFastString prefix `mappend` field_label lbl) - in fl {flSelector = flSelector fl `setNameUnique` uniq `tidyNameOcc` newOcc} + in fl { flSelector = flSelector fl `setNameUnique` uniq `tidyNameOcc` newOcc } mk_binds cons_w_field rec_details ty_builder = do setter_fl <- mk_field_lbl "setter_" <$> newUnique - modifier_fd <- mk_field_lbl "modifier_" <$> newUnique + modifier_fl <- mk_field_lbl "modifier_" <$> newUnique let setter_bind = mkRecordSetterBind fl setter_fl all_cons cons_w_field rec_details ty_builder - modifier_bind = mkRecordModifierBind fl modifier_fd all_cons cons_w_field rec_details ty_builder + modifier_bind = mkRecordModifierBind fl modifier_fl all_cons cons_w_field rec_details ty_builder pure (setter_bind, modifier_bind) - mkRecordSetterBind :: FieldLabel -> RecordBindBuilder (Id, LHsBind GhcRn) -mkRecordSetterBind origFl fl = mk_record_bind mkRecordSetterType mk_match fl where +mkRecordSetterBind origFl fl = mk_record_bind 2 err_expr mkRecordSetterType mk_match fl where - mk_match = - mk_set_fld_match (getOccName $ flSelector fl) origFl $ + err_expr = make_rec_error_expr origFl rEC_UPD_ERROR_ID + + mk_match = + mk_set_fld_match (getOccName $ flSelector origFl) origFl $ \_ field_var -> (genWildPat, genLHsVar field_var) mkRecordSetterType :: Type -> Type -> Type -mkRecordSetterType data_ty field_ty = +mkRecordSetterType data_ty field_ty = mkVisFunTyMany field_ty $ mkVisFunTyMany data_ty data_ty mkRecordModifierBind :: FieldLabel -> RecordBindBuilder (Id, LHsBind GhcRn) -mkRecordModifierBind origFl fl = mk_record_bind mkRecordModifierType mk_match fl where +mkRecordModifierBind origFl fl = mk_record_bind 2 err_expr mkRecordModifierType mk_match fl where + + err_expr = make_rec_error_expr origFl rEC_UPD_ERROR_ID - mk_match = mk_set_fld_match (mkOccName varName "f") origFl $ \i fun_var -> + mk_match = mk_set_fld_match (mkOccName varName "f") origFl $ \i fun_var -> let fld_nm = mk_set_fld_bind i fl expr = wrapGenSpan $ HsPar noExtField $ genLHsApp (genHsVar fun_var) (genLHsVar fld_nm) in (genVarPat fld_nm, expr) mkRecordModifierType :: Type -> Type -> Type -mkRecordModifierType data_ty field_ty = +mkRecordModifierType data_ty field_ty = mkVisFunTyMany (mkVisFunTyMany field_ty field_ty) $ mkVisFunTyMany data_ty data_ty @@ -981,11 +987,11 @@ mk_set_fld_match occ_name fl on_fld setter_name match_ctxt con = loc = noAnnSrcSpan (getSrcSpan setter_name) - mk_con_arg i fld_lbl + mk_con_arg i fld_lbl | fl == fld_lbl = on_fld i arg_var | otherwise = let fld_nm = mk_set_fld_bind i fld_lbl - in (genVarPat fld_nm, genLHsVar fld_nm) + in (genVarPat fld_nm, genLHsVar fld_nm) arg_var = mkInternalName (mkBuiltinUnique 1) occ_name loc @@ -993,14 +999,14 @@ mk_set_fld_bind :: Int -> FieldLabel -> Name mk_set_fld_bind i fld_lbl = mkInternalName (mkBuiltinUnique i) (nameOccName $ flSelector $ fld_lbl) - generatedSrcSpan + generatedSrcSpan type ConLikeWithField = ConLike -type RecordBindBuilder r = +type RecordBindBuilder r = FieldLabel -> [ConLike] -> [ConLikeWithField] -> IdDetails -> ((Type -> Type -> Type) -> Type) -> r -type FldBindMatchBuilder = +type FldBindMatchBuilder = Name -> HsMatchContext (LocatedN Name) -> ConLikeWithField -> LMatch GhcRn (LHsExpr GhcRn) collectFieldLabelInfo :: [ConLike] -> @@ -1052,7 +1058,7 @@ collectFieldLabelInfo all_cons idDetails fl has_sel k -- A slight hack! sel_ty | is_naughty = \_ -> unitTy -- See Note [Naughty record selectors] - | otherwise = \mk_ty -> + | otherwise = \mk_ty -> mkForAllTys (tyVarSpecToBinders sel_tvbs) $ -- Urgh! See Note [The stupid context] in GHC.Core.DataCon mkPhiTy (conLikeStupidTheta con1) $ @@ -1060,11 +1066,21 @@ collectFieldLabelInfo all_cons idDetails fl has_sel k mkPhiTy req_theta $ mk_ty data_ty field_ty -mk_record_bind :: +make_rec_error_expr :: FieldLabel -> Id -> LHsExpr GhcRn +make_rec_error_expr fl err_id = + genLHsApp + (genHsVar (getName err_id)) + (genLHsLit msg_lit) + where + msg_lit = HsStringPrim NoSourceText (bytesFS (field_label (flLabel fl))) + +mk_record_bind :: + Int -> + LHsExpr GhcRn -> (Type -> Type -> Type) -> FldBindMatchBuilder -> RecordBindBuilder (Id, LHsBind GhcRn) -mk_record_bind mk_ty mk_match fl all_cons cons_w_field rec_details ty_builder +mk_record_bind num_args err_expr mk_ty mk_match fl all_cons cons_w_field rec_details ty_builder = (sel_id, L loc sel_bind) where sel_ty = ty_builder mk_ty @@ -1092,10 +1108,8 @@ mk_record_bind mk_ty mk_match fl all_cons cons_w_field rec_details ty_builder -- We do this explicitly so that we get a nice error message that -- mentions this particular record selector deflt | all dealt_with all_cons = [] - | otherwise = [mkSimpleMatch match_ctxt (wrapGenSpan [genWildPat]) - (genLHsApp - (genHsVar (getName rEC_SEL_ERROR_ID)) - (genLHsLit msg_lit))] + | otherwise = [mkSimpleMatch match_ctxt (wrapGenSpan (replicate num_args genWildPat)) + err_expr] -- Do not add a default case unless there are unmatched -- constructors. We must take account of GADTs, else we @@ -1114,7 +1128,6 @@ mk_record_bind mk_ty mk_match fl all_cons cons_w_field rec_details ty_builder inst_tys = dataConResRepTyArgs dc unit_rhs = mkLHsTupleExpr [] noExtField - msg_lit = HsStringPrim NoSourceText (bytesFS (field_label (flLabel fl))) {- Note [Polymorphic selectors] ===================================== compiler/GHC/Tc/Types.hs ===================================== @@ -561,7 +561,7 @@ data TcGblEnv -- they all have a non-empty gre_imp field. tcg_keep :: TcRef NameSet, - tcg_requested_fields :: TcRef [(FieldLabel, ((Id, LHsBind GhcRn), (Id, LHsBind GhcRn)))], + tcg_requested_fields :: TcRef [(FieldLabel, (FieldBind, FieldBind))], tcg_th_used :: TcRef Bool, -- ^ @True@ \<=> Template Haskell syntax used. @@ -706,7 +706,8 @@ data TcGblEnv -- ^ See Note [Generating fresh names for FFI wrappers] } -type FieldInstEnv = NameEnv (Id, Id) +type FieldInstEnv = NameEnv (Id, Id) +type FieldBind = (Id, LHsBind GhcRn) -- NB: topModIdentity, not topModSemantic! -- Definition sites of orphan identities will be identity modules, not semantic ===================================== libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs ===================================== @@ -104,7 +104,7 @@ module GHC.Internal.Control.Exception.Base ( finally, -- * Calls for GHC runtime - recSelError, recConError, + recSelError, recConError, recUpdError, impossibleError, impossibleConstraintError, nonExhaustiveGuardsError, patError, noMethodBindingError, typeError, @@ -422,12 +422,14 @@ instance Exception NoMatchingContinuationPrompt ----- -- See Note [Compiler error functions] in ghc-internal:GHC.Internal.Prim.Panic -recSelError, recConError, typeError, +recSelError, recUpdError, recConError, typeError, nonExhaustiveGuardsError, patError, noMethodBindingError :: Addr# -> a -- All take a UTF8-encoded C string recSelError s = throw (RecSelError ("No match in record selector " ++ unpackCStringUtf8# s)) -- No location info unfortunately +recUpdError s = throw (RecUpdError ("No match in record update " + ++ unpackCStringUtf8# s)) -- No location info unfortunately nonExhaustiveGuardsError s = throw (PatternMatchFail (untangle s "Non-exhaustive guards in")) recConError s = throw (RecConError (untangle s "Missing field in record construction")) noMethodBindingError s = throw (NoMethodError (untangle s "No instance nor default method for class operation")) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/88d6c41456df78c3c9529cc7e6b49f6a... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/88d6c41456df78c3c9529cc7e6b49f6a... You're receiving this email because of your account on gitlab.haskell.org.