From 95dd0fc7d63ec253afccc2ce21b15f100b2f52c3 Mon Sep 17 00:00:00 2001 From: Karl Williamson Date: Tue, 29 Jul 2025 12:44:33 -0600 Subject: [PATCH 01/14] embed.fnc: Synchronize formal parameter name with actual A PERL_ARGS_ASSERT macro will be generated for this function in a future commit, and compilation will fail unless the names match. --- embed.fnc | 2 +- proto.h | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/embed.fnc b/embed.fnc index c0b1f18150be..d6d48eb28820 100644 --- a/embed.fnc +++ b/embed.fnc @@ -2232,7 +2232,7 @@ ARdp |OP * |newGVOP |I32 type \ ARdp |OP * |newGVREF |I32 type \ |NULLOK OP *o ARdmp |HV * |newHV -ARdp |HV * |newHVhv |NULLOK HV *hv +ARdp |HV * |newHVhv |NULLOK HV *ohv ARdp |OP * |newHVREF |NN OP *o ARdmp |IO * |newIO ARdp |OP * |newLISTOP |I32 type \ diff --git a/proto.h b/proto.h index f2376e95381f..56662f6a0f81 100644 --- a/proto.h +++ b/proto.h @@ -2914,7 +2914,7 @@ Perl_newHVREF(pTHX_ OP *o) assert(o) PERL_CALLCONV HV * -Perl_newHVhv(pTHX_ HV *hv) +Perl_newHVhv(pTHX_ HV *ohv) __attribute__warn_unused_result__; #define PERL_ARGS_ASSERT_NEWHVHV From b3cdda4acf72be85641411e6c2c5b557b107d772 Mon Sep 17 00:00:00 2001 From: Karl Williamson Date: Wed, 30 Jul 2025 04:47:16 -0600 Subject: [PATCH 02/14] embed.fnc: Add NOCHECK to three entries This has no effect currently, but several commits hence, a bug will be fixed that would otherwise generate a check that actually is inappropriate for these cases. --- embed.fnc | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/embed.fnc b/embed.fnc index d6d48eb28820..d29e3efcd489 100644 --- a/embed.fnc +++ b/embed.fnc @@ -1492,7 +1492,7 @@ ARdpx |SV * |hv_bucket_ratio|NN HV *hv Adp |void |hv_clear |NULLOK HV *hv Adp |void |hv_clear_placeholders \ |NN HV *hv -Cp |void * |hv_common |NULLOK HV *hv \ +Cp |void * |hv_common |NULLOK NOCHECK HV *hv \ |NULLOK SV *keysv \ |NULLOK const char *key \ |STRLEN klen \ @@ -3411,7 +3411,7 @@ Adp |void |sv_reset |NN const char *s \ |NULLOK HV * const stash p |void |sv_resetpvn |NULLOK const char *s \ |STRLEN len \ - |NULLOK HV * const stash + |NULLOK NOCHECK HV * const stash Adp |SV * |sv_rvunweaken |NN SV * const sv Adp |SV * |sv_rvweaken |NN SV * const sv Adp |void |sv_set_bool |NN SV *sv \ @@ -6098,7 +6098,7 @@ S |I32 |utf16_textfilter \ # endif #endif /* defined(PERL_IN_TOKE_C) */ #if defined(PERL_IN_UNIVERSAL_C) -GS |bool |isa_lookup |NULLOK HV *stash \ +GS |bool |isa_lookup |NULLOK NOCHECK HV *stash \ |NULLOK SV *namesv \ |NULLOK const char *name \ |STRLEN len \ From e44ee340aca3e478fb19e12facb2762263a10147 Mon Sep 17 00:00:00 2001 From: Karl Williamson Date: Wed, 30 Jul 2025 04:46:16 -0600 Subject: [PATCH 03/14] Add some ARGS_ASSERT calls An ARGS_ASSERT macro is always generated for every function listed in embed.fnc, unless possibly suppressed with the G flag for that entry. The generated macro is empty if there is nothing to assert. It is mandatory (enforced through a porting test) to call that macro when non-empty. (Hopefully the call occurs in the function the macro is designed for, but the porting test is currently simplistic and doesn't check for that; often compilation would fail anyway if it did get placed in the wrong function, as the parameter names the macro expects and the ones in the function could easily not match). It is optional (but a good idea) to call the macro even when empty. That way this commit would not have been necessary. From time to time, an empty macro becomes non-empty as we figure out more things to check for. When that happens, the porting test fails for the newly-non-empty macros that aren't called. If the function had originally called the empty-one, its source wouldn't have to change at all. Several commits from now will make some ARGS_ASSERT macros non-empty; this commit adds calls to the ones that weren't already called. --- dump.c | 2 ++ gv.c | 2 ++ hv.c | 10 ++++++++++ op.c | 3 +++ pad.c | 2 ++ 5 files changed, 19 insertions(+) diff --git a/dump.c b/dump.c index 780a2df3f879..fd6bdbcb382c 100644 --- a/dump.c +++ b/dump.c @@ -2933,12 +2933,14 @@ Perl_sv_dump_depth(pTHX_ SV *sv, I32 depth) void Perl_av_dump(pTHX_ AV *av) { + PERL_ARGS_ASSERT_AV_DUMP; sv_dump_depth((SV*)av, 3); } void Perl_hv_dump(pTHX_ HV *hv) { + PERL_ARGS_ASSERT_HV_DUMP; sv_dump_depth((SV*)hv, 3); } diff --git a/gv.c b/gv.c index 60cc495f710c..a5960c82f853 100644 --- a/gv.c +++ b/gv.c @@ -3340,6 +3340,8 @@ Implements C, which you should use instead CV* Perl_gv_handler(pTHX_ HV *stash, I32 id) { + PERL_ARGS_ASSERT_GV_HANDLER; + MAGIC *mg; AMT *amtp; U32 newgen; diff --git a/hv.c b/hv.c index a62350ff4e94..8ab44e7e0b09 100644 --- a/hv.c +++ b/hv.c @@ -1836,6 +1836,8 @@ returned. HV * Perl_newHVhv(pTHX_ HV *ohv) { + PERL_ARGS_ASSERT_NEWHVHV; + HV * const hv = newHV(); STRLEN hv_max; @@ -1944,6 +1946,8 @@ added to it. A pointer to the new hash is returned. HV * Perl_hv_copy_hints_hv(pTHX_ HV *const ohv) { + PERL_ARGS_ASSERT_HV_COPY_HINTS_HV; + HV * const hv = newHV(); if (ohv) { @@ -2009,6 +2013,7 @@ S_hv_free_ent_ret(pTHX_ HE *entry) void Perl_hv_free_ent(pTHX_ HV *notused, HE *entry) { + PERL_ARGS_ASSERT_HV_FREE_ENT; PERL_UNUSED_ARG(notused); if (!entry) @@ -2022,6 +2027,7 @@ Perl_hv_free_ent(pTHX_ HV *notused, HE *entry) void Perl_hv_delayfree_ent(pTHX_ HV *notused, HE *entry) { + PERL_ARGS_ASSERT_HV_DELAYFREE_ENT; PERL_UNUSED_ARG(notused); if (!entry) @@ -2049,6 +2055,8 @@ return. void Perl_hv_clear(pTHX_ HV *hv) { + PERL_ARGS_ASSERT_HV_CLEAR; + SSize_t orig_ix; if (!hv) @@ -2279,6 +2287,8 @@ return. void Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags) { + PERL_ARGS_ASSERT_HV_UNDEF_FLAGS; + bool save; SSize_t orig_ix = PL_tmps_ix; /* silence compiler warning about uninitialized vars */ diff --git a/op.c b/op.c index 386c9a9a8ae5..9132754c5b6a 100644 --- a/op.c +++ b/op.c @@ -11781,6 +11781,7 @@ S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, CV * Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv) { + PERL_ARGS_ASSERT_NEWCONSTSUB; return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv); } @@ -11865,6 +11866,8 @@ CV * Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags, SV *sv) { + PERL_ARGS_ASSERT_NEWCONSTSUB_FLAGS; + CV* cv; const char *const file = CopFILE(PL_curcop); diff --git a/pad.c b/pad.c index c33ddc5ea8f9..74ca357d617b 100644 --- a/pad.c +++ b/pad.c @@ -507,6 +507,8 @@ finished its job, so it can forget the slab. void Perl_cv_forget_slab(pTHX_ CV *cv) { + PERL_ARGS_ASSERT_CV_FORGET_SLAB; + bool slabbed; OPSLAB *slab = NULL; From 2d673a728782a394b2a76bc17d8ebeb44f2cc29f Mon Sep 17 00:00:00 2001 From: Karl Williamson Date: Wed, 30 Jul 2025 14:27:02 -0600 Subject: [PATCH 04/14] regen/embed.pl: Rm double negative in conditional As suggested by Bram, this was hard to understand --- regen/embed.pl | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/regen/embed.pl b/regen/embed.pl index 0e0a056454ee..4957402e341f 100755 --- a/regen/embed.pl +++ b/regen/embed.pl @@ -277,7 +277,11 @@ sub generate_proto_h { if (!$nocheck and defined $argtype and exists $type_asserts{$argtype}) { push @typed_args, [ $argtype, $argname ]; } - if (defined $argname && ($nn||$nz) && !($has_mflag && !$binarycompat)) { + + if ( defined $argname + && ($nn||$nz) + && (! $has_mflag || $binarycompat)) + { push @names_of_nn, $argname; } } From 6b651eade71c152bfbcb68a9d8702c3ec9341d3e Mon Sep 17 00:00:00 2001 From: Karl Williamson Date: Wed, 30 Jul 2025 14:32:08 -0600 Subject: [PATCH 05/14] regen/embed.pl: Add a condition to an 'if' $argname is used inside this 'if' as part of a newly created array element. It needs to be defined for the code to work that later looks at that element. No current calls result in an undefined value for this. --- regen/embed.pl | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/regen/embed.pl b/regen/embed.pl index 4957402e341f..5bac3952cd4e 100755 --- a/regen/embed.pl +++ b/regen/embed.pl @@ -274,7 +274,12 @@ sub generate_proto_h { die_at_end "$func: $arg ($n) doesn't have a name\n"; } my $argname = $1; - if (!$nocheck and defined $argtype and exists $type_asserts{$argtype}) { + + if ( defined $argname + and ! $nocheck + and defined $argtype + and exists $type_asserts{$argtype}) + { push @typed_args, [ $argtype, $argname ]; } From cee3a2fbaf1dcd9684655a8242836ac9988c185e Mon Sep 17 00:00:00 2001 From: Karl Williamson Date: Wed, 30 Jul 2025 14:38:23 -0600 Subject: [PATCH 06/14] regen/embed.pl: Add a condition to an 'if' This is in preparation of combining this if clause with the one just below to as many of the conditions in common as possible. In this clause, it applies only to functions, as we don't create ARGS_ASSERT macros for macros. However when something is going into mathoms.c (b flag), it is marked as a macro, but also has a function, so we need to create the ASSERT in this case. --- regen/embed.pl | 1 + 1 file changed, 1 insertion(+) diff --git a/regen/embed.pl b/regen/embed.pl index 5bac3952cd4e..15f37125064a 100755 --- a/regen/embed.pl +++ b/regen/embed.pl @@ -276,6 +276,7 @@ sub generate_proto_h { my $argname = $1; if ( defined $argname + and (! $has_mflag || $binarycompat) and ! $nocheck and defined $argtype and exists $type_asserts{$argtype}) From 71fe2062c3536fa34042369a5d5f5f5c8455cdba Mon Sep 17 00:00:00 2001 From: Karl Williamson Date: Wed, 30 Jul 2025 14:43:08 -0600 Subject: [PATCH 07/14] regen/embed.pl: Swap the order of two blocks This makes no difference in processing now, but will minimize the 'diff' output of a future commit. --- regen/embed.pl | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/regen/embed.pl b/regen/embed.pl index 15f37125064a..80bc5a22590a 100755 --- a/regen/embed.pl +++ b/regen/embed.pl @@ -275,6 +275,13 @@ sub generate_proto_h { } my $argname = $1; + if ( defined $argname + && ($nn||$nz) + && (! $has_mflag || $binarycompat)) + { + push @names_of_nn, $argname; + } + if ( defined $argname and (! $has_mflag || $binarycompat) and ! $nocheck @@ -283,13 +290,6 @@ sub generate_proto_h { { push @typed_args, [ $argtype, $argname ]; } - - if ( defined $argname - && ($nn||$nz) - && (! $has_mflag || $binarycompat)) - { - push @names_of_nn, $argname; - } } $ret .= join ", ", @$args; } From 7fa564181a2efc6151b11e2cb100974e9a382b2d Mon Sep 17 00:00:00 2001 From: Karl Williamson Date: Wed, 30 Jul 2025 14:46:41 -0600 Subject: [PATCH 08/14] regen/embed.pl: Combine the common parts of two 'if's This commit combines two separate 'if' blocks into one big if block with the conditionals in common to the two blocks, and then the two smaller blocks, each with the conditions that apply to it individually. And then everything is reindented to correspond --- regen/embed.pl | 23 ++++++++++------------- 1 file changed, 10 insertions(+), 13 deletions(-) diff --git a/regen/embed.pl b/regen/embed.pl index 80bc5a22590a..77437305ce6e 100755 --- a/regen/embed.pl +++ b/regen/embed.pl @@ -275,20 +275,17 @@ sub generate_proto_h { } my $argname = $1; - if ( defined $argname - && ($nn||$nz) - && (! $has_mflag || $binarycompat)) - { - push @names_of_nn, $argname; - } + if (defined $argname && (! $has_mflag || $binarycompat)) { + if ($nn||$nz) { + push @names_of_nn, $argname; + } - if ( defined $argname - and (! $has_mflag || $binarycompat) - and ! $nocheck - and defined $argtype - and exists $type_asserts{$argtype}) - { - push @typed_args, [ $argtype, $argname ]; + if ( ! $nocheck + && defined $argtype + && exists $type_asserts{$argtype}) + { + push @typed_args, [ $argtype, $argname ]; + } } } $ret .= join ", ", @$args; From 462c9df9823db4a88bcae07b16b896e52c6b87c3 Mon Sep 17 00:00:00 2001 From: Karl Williamson Date: Wed, 30 Jul 2025 04:10:47 -0600 Subject: [PATCH 09/14] regen/embed.pl: Generate ARGS_ASSERT in more cases This macro is actually always generated, but is empty if there are no assertions needed. Before this commit the code incorrectly generated an empty macro when there were no arguments marked NN even when types were defined that would call for asserts to be generated. --- proto.h | 56 ++++++++++++++++++++++++++++++++++---------------- regen/embed.pl | 4 ++-- 2 files changed, 40 insertions(+), 20 deletions(-) diff --git a/proto.h b/proto.h index 56662f6a0f81..bbcc8e30bd30 100644 --- a/proto.h +++ b/proto.h @@ -246,7 +246,8 @@ Perl_av_delete(pTHX_ AV *av, SSize_t key, I32 flags); PERL_CALLCONV void Perl_av_dump(pTHX_ AV *av); -#define PERL_ARGS_ASSERT_AV_DUMP +#define PERL_ARGS_ASSERT_AV_DUMP \ + assert(!av || SvTYPE(av) == SVt_PVAV) PERL_CALLCONV bool Perl_av_exists(pTHX_ AV *av, SSize_t key) @@ -697,7 +698,8 @@ Perl_cv_const_sv_or_av(const CV * const cv) PERL_CALLCONV void Perl_cv_forget_slab(pTHX_ CV *cv) __attribute__visibility__("hidden"); -#define PERL_ARGS_ASSERT_CV_FORGET_SLAB +#define PERL_ARGS_ASSERT_CV_FORGET_SLAB \ + assert(!cv || SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM) PERL_CALLCONV void Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p); @@ -1518,7 +1520,8 @@ Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain) PERL_CALLCONV CV * Perl_gv_handler(pTHX_ HV *stash, I32 id) __attribute__warn_unused_result__; -#define PERL_ARGS_ASSERT_GV_HANDLER +#define PERL_ARGS_ASSERT_GV_HANDLER \ + assert(!stash || SvTYPE(stash) == SVt_PVHV) /* PERL_CALLCONV void gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi); */ @@ -1594,7 +1597,8 @@ Perl_hv_bucket_ratio(pTHX_ HV *hv) PERL_CALLCONV void Perl_hv_clear(pTHX_ HV *hv); -#define PERL_ARGS_ASSERT_HV_CLEAR +#define PERL_ARGS_ASSERT_HV_CLEAR \ + assert(!hv || SvTYPE(hv) == SVt_PVHV) PERL_CALLCONV void Perl_hv_clear_placeholders(pTHX_ HV *hv); @@ -1613,11 +1617,13 @@ Perl_hv_common_key_len(pTHX_ HV *hv, const char *key, I32 klen_i32, const int ac PERL_CALLCONV HV * Perl_hv_copy_hints_hv(pTHX_ HV * const ohv) __attribute__warn_unused_result__; -#define PERL_ARGS_ASSERT_HV_COPY_HINTS_HV +#define PERL_ARGS_ASSERT_HV_COPY_HINTS_HV \ + assert(!ohv || SvTYPE(ohv) == SVt_PVHV) PERL_CALLCONV void Perl_hv_delayfree_ent(pTHX_ HV *notused, HE *entry); -#define PERL_ARGS_ASSERT_HV_DELAYFREE_ENT +#define PERL_ARGS_ASSERT_HV_DELAYFREE_ENT \ + assert(!notused || SvTYPE(notused) == SVt_PVHV) /* PERL_CALLCONV SV * Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags); */ @@ -1627,7 +1633,8 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash); */ PERL_CALLCONV void Perl_hv_dump(pTHX_ HV *hv); -#define PERL_ARGS_ASSERT_HV_DUMP +#define PERL_ARGS_ASSERT_HV_DUMP \ + assert(!hv || SvTYPE(hv) == SVt_PVHV) PERL_CALLCONV HE ** Perl_hv_eiter_p(pTHX_ HV *hv) @@ -1673,7 +1680,8 @@ Perl_hv_fill(pTHX_ HV * const hv); PERL_CALLCONV void Perl_hv_free_ent(pTHX_ HV *notused, HE *entry); -#define PERL_ARGS_ASSERT_HV_FREE_ENT +#define PERL_ARGS_ASSERT_HV_FREE_ENT \ + assert(!notused || SvTYPE(notused) == SVt_PVHV) PERL_CALLCONV I32 Perl_hv_iterinit(pTHX_ HV *hv); @@ -1789,7 +1797,8 @@ hv_undef(pTHX_ HV *hv); */ PERL_CALLCONV void Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags); -#define PERL_ARGS_ASSERT_HV_UNDEF_FLAGS +#define PERL_ARGS_ASSERT_HV_UNDEF_FLAGS \ + assert(!hv || SvTYPE(hv) == SVt_PVHV) /* PERL_CALLCONV I32 ibcmp(pTHX_ const char *a, const char *b, I32 len) @@ -2820,12 +2829,14 @@ newAV_mortal(pTHX) PERL_CALLCONV AV * Perl_newAVav(pTHX_ AV *oav) __attribute__warn_unused_result__; -#define PERL_ARGS_ASSERT_NEWAVAV +#define PERL_ARGS_ASSERT_NEWAVAV \ + assert(!oav || SvTYPE(oav) == SVt_PVAV) PERL_CALLCONV AV * Perl_newAVhv(pTHX_ HV *ohv) __attribute__warn_unused_result__; -#define PERL_ARGS_ASSERT_NEWAVHV +#define PERL_ARGS_ASSERT_NEWAVHV \ + assert(!ohv || SvTYPE(ohv) == SVt_PVHV) PERL_CALLCONV OP * Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) @@ -2840,11 +2851,13 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) PERL_CALLCONV CV * Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv); -#define PERL_ARGS_ASSERT_NEWCONSTSUB +#define PERL_ARGS_ASSERT_NEWCONSTSUB \ + assert(!stash || SvTYPE(stash) == SVt_PVHV) PERL_CALLCONV CV * Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags, SV *sv); -#define PERL_ARGS_ASSERT_NEWCONSTSUB_FLAGS +#define PERL_ARGS_ASSERT_NEWCONSTSUB_FLAGS \ + assert(!stash || SvTYPE(stash) == SVt_PVHV) PERL_CALLCONV OP * Perl_newCVREF(pTHX_ I32 flags, OP *o) @@ -2916,7 +2929,8 @@ Perl_newHVREF(pTHX_ OP *o) PERL_CALLCONV HV * Perl_newHVhv(pTHX_ HV *ohv) __attribute__warn_unused_result__; -#define PERL_ARGS_ASSERT_NEWHVHV +#define PERL_ARGS_ASSERT_NEWHVHV \ + assert(!ohv || SvTYPE(ohv) == SVt_PVHV) /* PERL_CALLCONV IO * Perl_newIO(pTHX) @@ -6891,7 +6905,8 @@ S_require_tie_mod(pTHX_ GV *gv, const char varname, const char *name, STRLEN len # if !defined(PERL_NO_INLINE_FUNCTIONS) PERL_STATIC_INLINE GV * S_gv_fetchmeth_internal(pTHX_ HV *stash, SV *meth, const char *name, STRLEN len, I32 level, U32 flags); -# define PERL_ARGS_ASSERT_GV_FETCHMETH_INTERNAL +# define PERL_ARGS_ASSERT_GV_FETCHMETH_INTERNAL \ + assert(!stash || SvTYPE(stash) == SVt_PVHV) PERL_STATIC_INLINE HV * S_gv_stashpvn_internal(pTHX_ const char *name, U32 namelen, I32 flags); @@ -6933,7 +6948,8 @@ S_hv_auxinit(pTHX_ HV *hv); STATIC SV * S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, int k_flags, I32 d_flags, U32 hash); -# define PERL_ARGS_ASSERT_HV_DELETE_COMMON +# define PERL_ARGS_ASSERT_HV_DELETE_COMMON \ + assert(!hv || SvTYPE(hv) == SVt_PVHV) STATIC SV * S_hv_free_ent_ret(pTHX_ HE *entry); @@ -7796,7 +7812,9 @@ S_destroy_matcher(pTHX_ PMOP *matcher); STATIC OP * S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied); -# define PERL_ARGS_ASSERT_DO_SMARTMATCH +# define PERL_ARGS_ASSERT_DO_SMARTMATCH \ + assert(!seen_this || SvTYPE(seen_this) == SVt_PVHV); \ + assert(!seen_other || SvTYPE(seen_other) == SVt_PVHV) STATIC OP * S_docatch(pTHX_ Perl_ppaddr_t firstpp) @@ -7805,7 +7823,9 @@ S_docatch(pTHX_ Perl_ppaddr_t firstpp) STATIC bool S_doeval_compile(pTHX_ U8 gimme, CV *outside, U32 seq, HV *hh); -# define PERL_ARGS_ASSERT_DOEVAL_COMPILE +# define PERL_ARGS_ASSERT_DOEVAL_COMPILE \ + assert(!outside || SvTYPE(outside) == SVt_PVCV || SvTYPE(outside) == SVt_PVFM); \ + assert(!hh || SvTYPE(hh) == SVt_PVHV) STATIC OP * S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit) diff --git a/regen/embed.pl b/regen/embed.pl index 77437305ce6e..1adfa497fe60 100755 --- a/regen/embed.pl +++ b/regen/embed.pl @@ -362,9 +362,9 @@ sub generate_proto_h { $ret .= ";"; $ret = "/* $ret */" if $has_mflag; - if ($args_assert_line || @names_of_nn) { + if ($args_assert_line || @names_of_nn || @typed_args) { $ret .= "\n#${ind}define PERL_ARGS_ASSERT_\U$plain_func\E"; - if (@names_of_nn) { + if (@names_of_nn || @typed_args) { $ret .= " \\\n"; my @asserts; From 1c833de21f07fa2e1c35a28a9ae1a0060d72037a Mon Sep 17 00:00:00 2001 From: Karl Williamson Date: Fri, 1 Aug 2025 07:32:43 -0600 Subject: [PATCH 10/14] regen/embed.pl: Get rid of ternary This simple change makes the code a bit easier to understand. --- regen/embed.pl | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/regen/embed.pl b/regen/embed.pl index 1adfa497fe60..f12fb7ace012 100755 --- a/regen/embed.pl +++ b/regen/embed.pl @@ -371,14 +371,14 @@ sub generate_proto_h { foreach my $ix (0..$#names_of_nn) { push @asserts, "assert($names_of_nn[$ix])"; } + foreach (@typed_args) { my ($argtype, $argname) = @$_; my $nullok = !grep { $_ eq $argname } @names_of_nn; my $type_assert = $type_asserts{$argtype} =~ s/__arg__/$argname/gr; - push @asserts, - $nullok ? "assert(!$argname || $type_assert)" - : "assert($type_assert)"; + $type_assert = "!$argname || $type_assert" if $nullok; + push @asserts, "assert($type_assert)"; } my $line = ""; From 03805c87f814caa6d806b2d9b28468d628e53212 Mon Sep 17 00:00:00 2001 From: Karl Williamson Date: Fri, 1 Aug 2025 07:40:16 -0600 Subject: [PATCH 11/14] regen/embed.pl Move some code to earlier Prior to this commit, the code created an array describing an input argument, adding it to a list of all the arguments, and later went through that list using a grep to reconstruct some information that had been lost (because the array didn't include all the needed relevant information), and placed the result in its final form. This commit moves the calculation of the final form to earlier, where it first is encountered. This means all the information is available, and no grep is needed. Code review revealed a subtlety here. The moved code has an if $nullok but prior to this commit, there were two different $nullok variables, with slightly different meanings. Prior to this commit, the moved code was using the second $nullok; afterwards, the first one. Hence, even though the name is the same, before and after, it is a different variable, with a (slightly) different meaning. The second $nullok was populated by the grep, and meant that the argument did not have either a NN nor a NZ modifier. The first $nullok meant simply that the arg had a NULLOK modifier. After the commit the single $nullok means that the arg had a NULLOK modifier. This change actually has no effect (as demonstrated by the fact that this commit doesn't change the generated proto.h). The moved code is executed only for an argument where $type_asserts{$argtype} exists. This hash is constant, and has been populated so that only pointer arguments have entries. NZ is not valid for pointer arguments, so we know that both before and after this commit, the arg did not have an NZ modifier. Also it is illegal to specify both NN and NULLOK, so both before and after this commit, the arg did not have a NN modifier. And both before and after this commit the arg does have a NULLOK modifier. --- regen/embed.pl | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/regen/embed.pl b/regen/embed.pl index f12fb7ace012..f1df8ebdf385 100755 --- a/regen/embed.pl +++ b/regen/embed.pl @@ -284,7 +284,10 @@ sub generate_proto_h { && defined $argtype && exists $type_asserts{$argtype}) { - push @typed_args, [ $argtype, $argname ]; + my $type_assert = + $type_asserts{$argtype} =~ s/__arg__/$argname/gr; + $type_assert = "!$argname || $type_assert" if $nullok; + push @typed_args, $type_assert; } } } @@ -372,12 +375,7 @@ sub generate_proto_h { push @asserts, "assert($names_of_nn[$ix])"; } - foreach (@typed_args) { - my ($argtype, $argname) = @$_; - my $nullok = !grep { $_ eq $argname } @names_of_nn; - my $type_assert = - $type_asserts{$argtype} =~ s/__arg__/$argname/gr; - $type_assert = "!$argname || $type_assert" if $nullok; + foreach my $type_assert (@typed_args) { push @asserts, "assert($type_assert)"; } From ac7c2f94d2295f697887f4b229ed938b459c9dc3 Mon Sep 17 00:00:00 2001 From: Karl Williamson Date: Fri, 1 Aug 2025 08:14:16 -0600 Subject: [PATCH 12/14] regen/embed.pl: Combine two arrays These two arrays are combined anyway into a third array later in the code; this just goes with the third array from the start. The order of some assertions in the generated proto.h are changed. But this makes sure that we continue to assert that an argument is present before dereferencing it. --- proto.h | 138 ++++++++++++++++++++++++------------------------- regen/embed.pl | 20 +++---- 2 files changed, 75 insertions(+), 83 deletions(-) diff --git a/proto.h b/proto.h index bbcc8e30bd30..54370079a0b2 100644 --- a/proto.h +++ b/proto.h @@ -203,8 +203,9 @@ Perl_apply(pTHX_ I32 type, SV **mark, SV **sp) PERL_CALLCONV void Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv, const char *attrstr, STRLEN len); #define PERL_ARGS_ASSERT_APPLY_ATTRS_STRING \ - assert(stashpv); assert(cv); assert(attrstr); \ - assert(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM) + assert(stashpv); assert(cv); \ + assert(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM); \ + assert(attrstr) PERL_CALLCONV OP * Perl_apply_builtin_cv_attributes(pTHX_ CV *cv, OP *attrlist); @@ -264,8 +265,8 @@ PERL_CALLCONV void Perl_av_extend_guts(pTHX_ AV *av, SSize_t key, SSize_t *maxp, SV ***allocp, SV ***arrayp) __attribute__visibility__("hidden"); #define PERL_ARGS_ASSERT_AV_EXTEND_GUTS \ - assert(maxp); assert(allocp); assert(arrayp); \ - assert(!av || SvTYPE(av) == SVt_PVAV) + assert(!av || SvTYPE(av) == SVt_PVAV); assert(maxp); assert(allocp); \ + assert(arrayp) PERL_CALLCONV SV ** Perl_av_fetch(pTHX_ AV *av, SSize_t key, I32 lval) @@ -309,7 +310,7 @@ Perl_av_pop(pTHX_ AV *av); PERL_CALLCONV void Perl_av_push(pTHX_ AV *av, SV *val); #define PERL_ARGS_ASSERT_AV_PUSH \ - assert(av); assert(val); assert(SvTYPE(av) == SVt_PVAV) + assert(av); assert(SvTYPE(av) == SVt_PVAV); assert(val) PERL_CALLCONV void Perl_av_reify(pTHX_ AV *av); @@ -680,8 +681,9 @@ PERL_CALLCONV CV * Perl_cv_clone_into(pTHX_ CV *proto, CV *target) __attribute__visibility__("hidden"); #define PERL_ARGS_ASSERT_CV_CLONE_INTO \ - assert(proto); assert(target); \ + assert(proto); \ assert(SvTYPE(proto) == SVt_PVCV || SvTYPE(proto) == SVt_PVFM); \ + assert(target); \ assert(SvTYPE(target) == SVt_PVCV || SvTYPE(target) == SVt_PVFM) PERL_CALLCONV SV * @@ -704,14 +706,14 @@ Perl_cv_forget_slab(pTHX_ CV *cv) PERL_CALLCONV void Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p); #define PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER \ - assert(cv); assert(ckfun_p); assert(ckobj_p); \ - assert(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM) + assert(cv); assert(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM); \ + assert(ckfun_p); assert(ckobj_p) PERL_CALLCONV void Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags, Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p); #define PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS \ - assert(cv); assert(ckfun_p); assert(ckobj_p); assert(ckflags_p); \ - assert(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM) + assert(cv); assert(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM); \ + assert(ckfun_p); assert(ckobj_p); assert(ckflags_p) PERL_CALLCONV SV * Perl_cv_name(pTHX_ CV *cv, SV *sv, U32 flags); @@ -721,14 +723,14 @@ Perl_cv_name(pTHX_ CV *cv, SV *sv, U32 flags); PERL_CALLCONV void Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj); #define PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER \ - assert(cv); assert(ckfun); assert(ckobj); \ - assert(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM) + assert(cv); assert(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM); \ + assert(ckfun); assert(ckobj) PERL_CALLCONV void Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj, U32 ckflags); #define PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS \ - assert(cv); assert(ckfun); assert(ckobj); \ - assert(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM) + assert(cv); assert(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM); \ + assert(ckfun); assert(ckobj) PERL_CALLCONV void Perl_cv_undef(pTHX_ CV *cv); @@ -1529,17 +1531,17 @@ gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi); */ PERL_CALLCONV void Perl_gv_init_pv(pTHX_ GV *gv, HV *stash, const char *name, U32 flags); #define PERL_ARGS_ASSERT_GV_INIT_PV \ - assert(gv); assert(name); assert(!stash || SvTYPE(stash) == SVt_PVHV) + assert(gv); assert(!stash || SvTYPE(stash) == SVt_PVHV); assert(name) PERL_CALLCONV void Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flags); #define PERL_ARGS_ASSERT_GV_INIT_PVN \ - assert(gv); assert(name); assert(!stash || SvTYPE(stash) == SVt_PVHV) + assert(gv); assert(!stash || SvTYPE(stash) == SVt_PVHV); assert(name) PERL_CALLCONV void Perl_gv_init_sv(pTHX_ GV *gv, HV *stash, SV *namesv, U32 flags); #define PERL_ARGS_ASSERT_GV_INIT_SV \ - assert(gv); assert(namesv); assert(!stash || SvTYPE(stash) == SVt_PVHV) + assert(gv); assert(!stash || SvTYPE(stash) == SVt_PVHV); assert(namesv) PERL_CALLCONV void Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags); @@ -1612,7 +1614,7 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, int flags, PERL_CALLCONV void * Perl_hv_common_key_len(pTHX_ HV *hv, const char *key, I32 klen_i32, const int action, SV *val, const U32 hash); #define PERL_ARGS_ASSERT_HV_COMMON_KEY_LEN \ - assert(key); assert(!hv || SvTYPE(hv) == SVt_PVHV) + assert(!hv || SvTYPE(hv) == SVt_PVHV); assert(key) PERL_CALLCONV HV * Perl_hv_copy_hints_hv(pTHX_ HV * const ohv) @@ -1651,13 +1653,13 @@ PERL_CALLCONV void Perl_hv_ename_add(pTHX_ HV *hv, const char *name, U32 len, U32 flags) __attribute__visibility__("hidden"); #define PERL_ARGS_ASSERT_HV_ENAME_ADD \ - assert(hv); assert(name); assert(SvTYPE(hv) == SVt_PVHV) + assert(hv); assert(SvTYPE(hv) == SVt_PVHV); assert(name) PERL_CALLCONV void Perl_hv_ename_delete(pTHX_ HV *hv, const char *name, U32 len, U32 flags) __attribute__visibility__("hidden"); #define PERL_ARGS_ASSERT_HV_ENAME_DELETE \ - assert(hv); assert(name); assert(SvTYPE(hv) == SVt_PVHV) + assert(hv); assert(SvTYPE(hv) == SVt_PVHV); assert(name) /* PERL_CALLCONV bool Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen) @@ -1714,13 +1716,13 @@ PERL_CALLCONV SV * Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen) __attribute__warn_unused_result__; #define PERL_ARGS_ASSERT_HV_ITERNEXTSV \ - assert(hv); assert(key); assert(retlen); assert(SvTYPE(hv) == SVt_PVHV) + assert(hv); assert(SvTYPE(hv) == SVt_PVHV); assert(key); assert(retlen) PERL_CALLCONV SV * Perl_hv_iterval(pTHX_ HV *hv, HE *entry) __attribute__warn_unused_result__; #define PERL_ARGS_ASSERT_HV_ITERVAL \ - assert(hv); assert(entry); assert(SvTYPE(hv) == SVt_PVHV) + assert(hv); assert(SvTYPE(hv) == SVt_PVHV); assert(entry) PERL_CALLCONV void Perl_hv_ksplit(pTHX_ HV *hv, IV newmax); @@ -1846,8 +1848,8 @@ Perl_init_i18nl10n(pTHX_ int printwarn); PERL_CALLCONV void Perl_init_named_cv(pTHX_ CV *cv, OP *nameop); #define PERL_ARGS_ASSERT_INIT_NAMED_CV \ - assert(cv); assert(nameop); \ - assert(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM) + assert(cv); assert(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM); \ + assert(nameop) PERL_CALLCONV void Perl_init_stacks(pTHX); @@ -2295,7 +2297,7 @@ PERL_CALLCONV SV * Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg) __attribute__visibility__("hidden"); #define PERL_ARGS_ASSERT_MAGIC_SCALARPACK \ - assert(hv); assert(mg); assert(SvTYPE(hv) == SVt_PVHV) + assert(hv); assert(SvTYPE(hv) == SVt_PVHV); assert(mg) PERL_CALLCONV int Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) @@ -2617,8 +2619,8 @@ Perl_mro_method_changed_in(pTHX_ HV *stash); PERL_CALLCONV void Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash, const GV * const gv, U32 flags); #define PERL_ARGS_ASSERT_MRO_PACKAGE_MOVED \ - assert(gv); assert(!stash || SvTYPE(stash) == SVt_PVHV); \ - assert(!oldstash || SvTYPE(oldstash) == SVt_PVHV) + assert(!stash || SvTYPE(stash) == SVt_PVHV); \ + assert(!oldstash || SvTYPE(oldstash) == SVt_PVHV); assert(gv) PERL_CALLCONV void Perl_mro_register(pTHX_ const struct mro_alg *mro); @@ -3470,8 +3472,9 @@ PERL_CALLCONV void Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv) __attribute__visibility__("hidden"); #define PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS \ - assert(padlist); assert(old_cv); assert(new_cv); \ + assert(padlist); assert(old_cv); \ assert(SvTYPE(old_cv) == SVt_PVCV || SvTYPE(old_cv) == SVt_PVFM); \ + assert(new_cv); \ assert(SvTYPE(new_cv) == SVt_PVCV || SvTYPE(new_cv) == SVt_PVFM) PERL_CALLCONV void @@ -4056,7 +4059,7 @@ save_aelem(pTHX_ AV *av, SSize_t idx, SV **sptr); */ PERL_CALLCONV void Perl_save_aelem_flags(pTHX_ AV *av, SSize_t idx, SV **sptr, const U32 flags); #define PERL_ARGS_ASSERT_SAVE_AELEM_FLAGS \ - assert(av); assert(sptr); assert(SvTYPE(av) == SVt_PVAV) + assert(av); assert(SvTYPE(av) == SVt_PVAV); assert(sptr) PERL_CALLCONV SSize_t Perl_save_alloc(pTHX_ SSize_t size, I32 pad); @@ -4085,7 +4088,7 @@ Perl_save_clearsv(pTHX_ SV **svp); PERL_CALLCONV void Perl_save_delete(pTHX_ HV *hv, char *key, I32 klen); #define PERL_ARGS_ASSERT_SAVE_DELETE \ - assert(hv); assert(key); assert(SvTYPE(hv) == SVt_PVHV) + assert(hv); assert(SvTYPE(hv) == SVt_PVHV); assert(key) PERL_CALLCONV void Perl_save_destructor(pTHX_ DESTRUCTORFUNC_NOCONTEXT_t f, void *p); @@ -4133,7 +4136,7 @@ Perl_save_hash(pTHX_ GV *gv); PERL_CALLCONV void Perl_save_hdelete(pTHX_ HV *hv, SV *keysv); #define PERL_ARGS_ASSERT_SAVE_HDELETE \ - assert(hv); assert(keysv); assert(SvTYPE(hv) == SVt_PVHV) + assert(hv); assert(SvTYPE(hv) == SVt_PVHV); assert(keysv) /* PERL_CALLCONV void save_helem(pTHX_ HV *hv, SV *key, SV **sptr); */ @@ -4141,7 +4144,7 @@ save_helem(pTHX_ HV *hv, SV *key, SV **sptr); */ PERL_CALLCONV void Perl_save_helem_flags(pTHX_ HV *hv, SV *key, SV **sptr, const U32 flags); #define PERL_ARGS_ASSERT_SAVE_HELEM_FLAGS \ - assert(hv); assert(key); assert(sptr); assert(SvTYPE(hv) == SVt_PVHV) + assert(hv); assert(SvTYPE(hv) == SVt_PVHV); assert(key); assert(sptr) PERL_CALLCONV void Perl_save_hints(pTHX); @@ -6596,13 +6599,13 @@ Perl_ck_trycatch(pTHX_ OP *o) PERL_CALLCONV void Perl_class_add_ADJUST(pTHX_ HV *stash, CV *cv); # define PERL_ARGS_ASSERT_CLASS_ADD_ADJUST \ - assert(stash); assert(cv); assert(SvTYPE(stash) == SVt_PVHV); \ + assert(stash); assert(SvTYPE(stash) == SVt_PVHV); assert(cv); \ assert(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM) PERL_CALLCONV void Perl_class_add_field(pTHX_ HV *stash, PADNAME *pn); # define PERL_ARGS_ASSERT_CLASS_ADD_FIELD \ - assert(stash); assert(pn); assert(SvTYPE(stash) == SVt_PVHV) + assert(stash); assert(SvTYPE(stash) == SVt_PVHV); assert(pn) PERL_CALLCONV void Perl_class_apply_attributes(pTHX_ HV *stash, OP *attrlist); @@ -6879,8 +6882,8 @@ S_gv_is_in_main(pTHX_ const char *name, STRLEN len, const U32 is_utf8); STATIC bool S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, const svtype sv_type); # define PERL_ARGS_ASSERT_GV_MAGICALIZE \ - assert(gv); assert(stash); assert(name); \ - assert(SvTYPE(stash) == SVt_PVHV) + assert(gv); assert(stash); assert(SvTYPE(stash) == SVt_PVHV); \ + assert(name) STATIC void S_gv_magicalize_isa(pTHX_ GV *gv); @@ -6964,8 +6967,8 @@ S_hv_free_entries(pTHX_ HV *hv); STATIC void S_hv_magic_check(HV *hv, bool *needs_copy, bool *needs_store); # define PERL_ARGS_ASSERT_HV_MAGIC_CHECK \ - assert(hv); assert(needs_copy); assert(needs_store); \ - assert(SvTYPE(hv) == SVt_PVHV) + assert(hv); assert(SvTYPE(hv) == SVt_PVHV); assert(needs_copy); \ + assert(needs_store) PERL_STATIC_NO_RET void S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen, const char *msg) @@ -7016,7 +7019,7 @@ PERL_CALLCONV SV * Perl_hfree_next_entry(pTHX_ HV *hv, STRLEN *indexp) __attribute__visibility__("hidden"); # define PERL_ARGS_ASSERT_HFREE_NEXT_ENTRY \ - assert(hv); assert(indexp); assert(SvTYPE(hv) == SVt_PVHV) + assert(hv); assert(SvTYPE(hv) == SVt_PVHV); assert(indexp) #endif #if defined(PERL_IN_LOCALE_C) @@ -7041,8 +7044,8 @@ S_my_localeconv(pTHX_ const int item); STATIC void S_populate_hash_from_C_localeconv(pTHX_ HV *hv, const char *locale, const U32 which_mask, const lconv_offset_t *strings[2], const lconv_offset_t *integers[2]); # define PERL_ARGS_ASSERT_POPULATE_HASH_FROM_C_LOCALECONV \ - assert(hv); assert(locale); assert(strings); assert(integers); \ - assert(SvTYPE(hv) == SVt_PVHV) + assert(hv); assert(SvTYPE(hv) == SVt_PVHV); assert(locale); \ + assert(strings); assert(integers) STATIC bool S_strftime8(pTHX_ const char *fmt, SV *sv, const char *locale, const struct tm *mytm, const utf8ness_t fmt_utf8ness, utf8ness_t *result_utf8ness, const bool called_externally); @@ -7136,8 +7139,8 @@ S_my_setlocale_debug_string_i(pTHX_ const locale_category_index cat_index, const STATIC void S_populate_hash_from_localeconv(pTHX_ HV *hv, const char *locale, const U32 which_mask, const lconv_offset_t *strings[2], const lconv_offset_t *integers[2]); # define PERL_ARGS_ASSERT_POPULATE_HASH_FROM_LOCALECONV \ - assert(hv); assert(locale); assert(strings); assert(integers); \ - assert(SvTYPE(hv) == SVt_PVHV) + assert(hv); assert(SvTYPE(hv) == SVt_PVHV); assert(locale); \ + assert(strings); assert(integers) # endif # if defined(HAS_NL_LANGINFO) @@ -7327,17 +7330,16 @@ Perl_translate_substr_offsets(STRLEN curlen, IV pos1_iv, bool pos1_is_uv, IV len STATIC void S_mro_clean_isarev(pTHX_ HV * const isa, const char * const name, const STRLEN len, HV * const exceptions, U32 hash, U32 flags); # define PERL_ARGS_ASSERT_MRO_CLEAN_ISAREV \ - assert(isa); assert(name); assert(SvTYPE(isa) == SVt_PVHV); \ + assert(isa); assert(SvTYPE(isa) == SVt_PVHV); assert(name); \ assert(!exceptions || SvTYPE(exceptions) == SVt_PVHV) STATIC void S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes, HV *stash, HV *oldstash, SV *namesv); # define PERL_ARGS_ASSERT_MRO_GATHER_AND_RENAME \ - assert(stashes); assert(seen_stashes); assert(namesv); \ - assert(SvTYPE(stashes) == SVt_PVHV); \ - assert(SvTYPE(seen_stashes) == SVt_PVHV); \ + assert(stashes); assert(SvTYPE(stashes) == SVt_PVHV); \ + assert(seen_stashes); assert(SvTYPE(seen_stashes) == SVt_PVHV); \ assert(!stash || SvTYPE(stash) == SVt_PVHV); \ - assert(!oldstash || SvTYPE(oldstash) == SVt_PVHV) + assert(!oldstash || SvTYPE(oldstash) == SVt_PVHV); assert(namesv) STATIC AV * S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level); @@ -7355,13 +7357,13 @@ S_output_non_portable(pTHX_ const U8 shift); STATIC void S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs); # define PERL_ARGS_ASSERT_APPLY_ATTRS \ - assert(stash); assert(target); assert(SvTYPE(stash) == SVt_PVHV) + assert(stash); assert(SvTYPE(stash) == SVt_PVHV); assert(target) STATIC void S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp); # define PERL_ARGS_ASSERT_APPLY_ATTRS_MY \ - assert(stash); assert(target); assert(imopsp); \ - assert(SvTYPE(stash) == SVt_PVHV) + assert(stash); assert(SvTYPE(stash) == SVt_PVHV); assert(target); \ + assert(imopsp) STATIC I32 S_assignment_type(pTHX_ const OP *o) @@ -7738,7 +7740,7 @@ S_usage(pTHX) STATIC SV * S_incpush_if_exists(pTHX_ AV * const av, SV *dir, SV * const stem); # define PERL_ARGS_ASSERT_INCPUSH_IF_EXISTS \ - assert(av); assert(dir); assert(stem); assert(SvTYPE(av) == SVt_PVAV) + assert(av); assert(SvTYPE(av) == SVt_PVAV); assert(dir); assert(stem) # endif # if !defined(SETUID_SCRIPTS_ARE_SECURE_NOW) @@ -7906,7 +7908,7 @@ S_rxres_restore(pTHX_ void **rsp, REGEXP *rx); STATIC void S_save_lines(pTHX_ AV *array, SV *sv); # define PERL_ARGS_ASSERT_SAVE_LINES \ - assert(sv); assert(!array || SvTYPE(array) == SVt_PVAV) + assert(!array || SvTYPE(array) == SVt_PVAV); assert(sv) # if !defined(PERL_DISABLE_PMC) STATIC PerlIO * @@ -8125,8 +8127,8 @@ S_cmp_locale_desc(pTHX_ SV * const str1, SV * const str2); STATIC OP * S_doform(pTHX_ CV *cv, GV *gv, OP *retop); # define PERL_ARGS_ASSERT_DOFORM \ - assert(cv); assert(gv); \ - assert(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM) + assert(cv); assert(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM); \ + assert(gv) STATIC SV * S_space_join_names_mortal(pTHX_ char * const *array); @@ -8229,23 +8231,20 @@ Perl_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, SSize_t *minl STATIC void S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap, AV *revcharmap, U32 depth); # define PERL_ARGS_ASSERT_DUMP_TRIE \ - assert(trie); assert(revcharmap); \ - assert(!widecharmap || SvTYPE(widecharmap) == SVt_PVHV); \ - assert(SvTYPE(revcharmap) == SVt_PVAV) + assert(trie); assert(!widecharmap || SvTYPE(widecharmap) == SVt_PVHV); \ + assert(revcharmap); assert(SvTYPE(revcharmap) == SVt_PVAV) STATIC void S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap, AV *revcharmap, U32 next_alloc, U32 depth); # define PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_LIST \ - assert(trie); assert(revcharmap); \ - assert(!widecharmap || SvTYPE(widecharmap) == SVt_PVHV); \ - assert(SvTYPE(revcharmap) == SVt_PVAV) + assert(trie); assert(!widecharmap || SvTYPE(widecharmap) == SVt_PVHV); \ + assert(revcharmap); assert(SvTYPE(revcharmap) == SVt_PVAV) STATIC void S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap, AV *revcharmap, U32 next_alloc, U32 depth); # define PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_TABLE \ - assert(trie); assert(revcharmap); \ - assert(!widecharmap || SvTYPE(widecharmap) == SVt_PVHV); \ - assert(SvTYPE(revcharmap) == SVt_PVAV) + assert(trie); assert(!widecharmap || SvTYPE(widecharmap) == SVt_PVHV); \ + assert(revcharmap); assert(SvTYPE(revcharmap) == SVt_PVAV) # endif /* defined(PERL_IN_REGCOMP_TRIE_C) && defined(DEBUGGING) */ # if !defined(PERL_NO_INLINE_FUNCTIONS) @@ -8286,8 +8285,8 @@ Perl_invlist_clone(pTHX_ SV * const invlist, SV *newlist); STATIC AV * S_add_multi_match(pTHX_ AV *multi_char_matches, SV *multi_string, const STRLEN cp_count); # define PERL_ARGS_ASSERT_ADD_MULTI_MATCH \ - assert(multi_string); \ - assert(!multi_char_matches || SvTYPE(multi_char_matches) == SVt_PVAV) + assert(!multi_char_matches || SvTYPE(multi_char_matches) == SVt_PVAV); \ + assert(multi_string) STATIC void S_change_engine_size(pTHX_ RExC_state_t *pRExC_state, const ptrdiff_t size); @@ -8503,9 +8502,8 @@ S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode_offset p, const regnode STATIC void S_dump_regex_sets_structures(pTHX_ RExC_state_t *pRExC_state, AV *stack, const IV fence, AV *fence_stack); # define PERL_ARGS_ASSERT_DUMP_REGEX_SETS_STRUCTURES \ - assert(pRExC_state); assert(stack); assert(fence_stack); \ - assert(SvTYPE(stack) == SVt_PVAV); \ - assert(SvTYPE(fence_stack) == SVt_PVAV) + assert(pRExC_state); assert(stack); assert(SvTYPE(stack) == SVt_PVAV); \ + assert(fence_stack); assert(SvTYPE(fence_stack) == SVt_PVAV) # endif # endif /* defined(DEBUGGING) */ @@ -9752,7 +9750,7 @@ Perl_av_new_alloc(pTHX_ SSize_t size, bool zeroflag) PERL_STATIC_INLINE void Perl_av_push_simple(pTHX_ AV *av, SV *val); # define PERL_ARGS_ASSERT_AV_PUSH_SIMPLE \ - assert(av); assert(val); assert(SvTYPE(av) == SVt_PVAV) + assert(av); assert(SvTYPE(av) == SVt_PVAV); assert(val) PERL_STATIC_INLINE void Perl_av_remove_offset(pTHX_ AV *av); diff --git a/regen/embed.pl b/regen/embed.pl index f1df8ebdf385..888fd180b331 100755 --- a/regen/embed.pl +++ b/regen/embed.pl @@ -134,8 +134,7 @@ sub generate_proto_h { my $has_mflag = ( $flags =~ /m/ ); my $is_malloc = ( $flags =~ /a/ ); my $can_ignore = ( $flags !~ /R/ ) && ( $flags !~ /P/ ) && !$is_malloc; - my @names_of_nn; - my @typed_args; + my @asserts; my $func; if (! $can_ignore && $retval eq 'void') { @@ -277,7 +276,7 @@ sub generate_proto_h { if (defined $argname && (! $has_mflag || $binarycompat)) { if ($nn||$nz) { - push @names_of_nn, $argname; + push @asserts, $argname; } if ( ! $nocheck @@ -287,7 +286,7 @@ sub generate_proto_h { my $type_assert = $type_asserts{$argtype} =~ s/__arg__/$argname/gr; $type_assert = "!$argname || $type_assert" if $nullok; - push @typed_args, $type_assert; + push @asserts, $type_assert; } } } @@ -365,18 +364,13 @@ sub generate_proto_h { $ret .= ";"; $ret = "/* $ret */" if $has_mflag; - if ($args_assert_line || @names_of_nn || @typed_args) { + if ($args_assert_line || @asserts) { $ret .= "\n#${ind}define PERL_ARGS_ASSERT_\U$plain_func\E"; - if (@names_of_nn || @typed_args) { + if (@asserts) { $ret .= " \\\n"; - my @asserts; - foreach my $ix (0..$#names_of_nn) { - push @asserts, "assert($names_of_nn[$ix])"; - } - - foreach my $type_assert (@typed_args) { - push @asserts, "assert($type_assert)"; + foreach my $assertion (@asserts) { + $assertion = "assert($assertion)"; } my $line = ""; From a1b80f99bd9250f51f25c4691ef8bb2a6aa8f6a3 Mon Sep 17 00:00:00 2001 From: Karl Williamson Date: Fri, 1 Aug 2025 08:22:41 -0600 Subject: [PATCH 13/14] regen/embed.pl: Remove a loop By creating the @asserts array with each element in its final form, the loop that later did this can be eliminated. --- regen/embed.pl | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/regen/embed.pl b/regen/embed.pl index 888fd180b331..42c4bf3f8ecd 100755 --- a/regen/embed.pl +++ b/regen/embed.pl @@ -276,7 +276,7 @@ sub generate_proto_h { if (defined $argname && (! $has_mflag || $binarycompat)) { if ($nn||$nz) { - push @asserts, $argname; + push @asserts, "assert($argname)"; } if ( ! $nocheck @@ -286,7 +286,7 @@ sub generate_proto_h { my $type_assert = $type_asserts{$argtype} =~ s/__arg__/$argname/gr; $type_assert = "!$argname || $type_assert" if $nullok; - push @asserts, $type_assert; + push @asserts, "assert($type_assert)"; } } } @@ -369,10 +369,6 @@ sub generate_proto_h { if (@asserts) { $ret .= " \\\n"; - foreach my $assertion (@asserts) { - $assertion = "assert($assertion)"; - } - my $line = ""; while(@asserts) { my $assert = shift @asserts; From 86e30f5587f5a3cf1edc1fa455f0be9c93ec9217 Mon Sep 17 00:00:00 2001 From: Karl Williamson Date: Fri, 1 Aug 2025 08:46:42 -0600 Subject: [PATCH 14/14] regen/embed.pl: White-space/comment changes This removes a misleading comment. NULLOK now does have some effect. It changes the actual generated assertion for arguments where a type assertion is generated. (This has actually been true since 2463f19365f941f68e9d5eed2f787341df8ccdef) This also vertically aligns some statements for ease of reading, and reorders things to group them together in a block. --- regen/embed.pl | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/regen/embed.pl b/regen/embed.pl index 42c4bf3f8ecd..44a870a10b42 100755 --- a/regen/embed.pl +++ b/regen/embed.pl @@ -252,14 +252,14 @@ sub generate_proto_h { warn "$func: $arg needs NN or NULLOK\n"; ++$unflagged_pointers; } - my $nn = ( $arg =~ s/\s*\bNN\b\s+// ); - push( @nonnull, $n ) if $nn; - my $nz = ( $arg =~ s/\s*\bNZ\b\s+// ); - - my $nullok = ( $arg =~ s/\s*\bNULLOK\b\s+// ); # strip NULLOK with no effect + my $nn = ( $arg =~ s/\s*\bNN\b\s+// ); + my $nz = ( $arg =~ s/\s*\bNZ\b\s+// ); + my $nullok = ( $arg =~ s/\s*\bNULLOK\b\s+// ); my $nocheck = ( $arg =~ s/\s*\bNOCHECK\b\s+// ); + push( @nonnull, $n ) if $nn; + # Make sure each arg has at least a type and a var name. # An arg of "int" is valid C, but want it to be "int foo". my $argtype = ( $arg =~ m/^(\w+(?:\s*\*+)?)/ )[0];