[Git][ghc/ghc][wip/sand-witch/make-set-field] Small fixes after intensive testing

2 Jul 2025


      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.

    

Andrei Borzenkov (＠sand-witch)

tags

participants (1)