[PATCH] POC perl's malloc API takes a my_perl/context/malloc API refactor #14838
Labels
Comments
From @bulk88Created by @bulk88Filing this as a ticket since code on ML posts gets lost. This patch is I wrote this patch to stop a huge number Perl_get_contexts while debugging I've had ideas for a while about replacing win32/vmem.h and perlhost.h's Anyway, this commit would be the begining of incomplete areas: http://perl5.git.perl.org/perl.git/commitdiff/f7abe70be985cb9179c2e728a593cb8a5c8e049d questions to debate Perl Info |
From @bulk880001-WIP-POC-perl-s-malloc-API-takes-a-my_perl-context-ma.patchFrom fac2ab491c422f933137b27e3708c1b655e7a642 Mon Sep 17 00:00:00 2001
From: bulk88 <bulk88@hotmail.com>
Date: Tue, 4 Aug 2015 16:32:25 -0400
Subject: [PATCH] WIP/POC perl's malloc API takes a my_perl/context/malloc API
refactor
I wrote this patch to stop a huge number Perl_get_contexts while debugging
a rogue setting of SetLastError (AKA Win32's errno) in Perl. Putting a
break point in SetLastError produces alot of noise since Perl_get_context
saves and restores the error code each time it is called. Perl's malloc
APIs are the #1 source of Perl_get_context calls on threaded perl.
I've had ideas for a while about replacing win32/vmem.h and perlhost.h's
implementation (but not API) of
PerlMem_malloc/PerlMemShared_malloc/PerlMemParse_malloc with using the
Win32 native malloc API directly. The old Sarathy code is a painful
reimplementation of the Win32 native malloc API on top of the
Win32/standard C malloc API which is on top of the Win32 native malloc API.
This reimplementation is done by putting double linked list headers on
every memory block. The win32 LL alloc code is the doppelganger of
PERL_TRACK_MEMPOOL. Using the Win32 native malloc API allows Perl to free
all the memory associated with a perl thread with 1 C function call, which
frees all the VM pages behind that perl thread in 1 shot, not the linked
list looping stuff which was probably written to deal with sbrk() only, no
mmap() unix machines from the early 80s. Why it was written for Win32 in
the 1990s, which never had sbrk in any form, IDK.
Anyway, this commit would be the begining of
PerlMem_malloc/PerlMemShared_malloc/PerlMemParse_malloc possibly being
macros directly win32 OS API's native malloc, not function calls to perl
API functions. This patch also decreased Perl_get_context calls.
incomplete areas:
S_invlist_trim
add_data
+#define my_perl to and +#undef my_perl stuff, dont create 2 C autos
(CC optimization problems then, VC prefer to make a new C stack auto vs
writing to an incoming arg), but "to" as a var name i think is informative
Perl_clone_params_new
from 5.13.2
http://perl5.git.perl.org/perl.git/commitdiff/f7abe70be985cb9179c2e728a593cb8a5c8e049d
win32_dirp_dup
Newxt for threaded added to handy.h?
Newxzt
make bundled XS modules Newx and my_perl clean
questions to debate
-should win32_* be using win32_malloc instead of interp specific mem?
win32_* funcs are sorta like P5's extensions to libc, so they should be
usable without an interp, right or wrong?
-does embed.fnc need a new letter that says MEMTHX not THX
(think opposite of "n") instead of the #ifdefs
-should it be "MTHX" instead of "MEMTHX"? less clutter less typing?
-is ALWAYS_NEED_THX conceptually nonsense? If no threads, current my_perl
is 1 byte along
struct interpreter {
char broiled;
};, should perl_alloc return null or -1 or just plain 1 or a pointer to 1
char as a C static global? Will there ever be 2 unthreaded libperls in the
same process and somehow they cross pointers through bad embedding or XS
code? Should PERL_TRACK_MEMPOOL not record my_perl on unthreaded perl?
The DEBUGGING debug channel logs in util.c dont need my_perl on unthreaded
perl since its unthreaded perl.
-should Newxt be named Newxt or Newtx or should CPAN be forced to go
through a conversion/deprecate process to be Newx my_perl clean by
"breaking change" Newx to require a my_perl outside of core?
-PERL_NO_GET_CONTEXT exists. Add PERL_CXT_ALLOC to say we want my_perl
version of Newx macro instead of Newxt api?
-Newxt in ppport.h would be defined to Newx on older perls
-is Perl_safesysmalloc_nocontext and friends, have bloated wastefully long
names for purpose of XS/libperl binary size? any better name?
-Why do we have TWO malloc APIs facing XS code/in libperl's export list?
First there is rarely used Perl_malloc/Perl_calloc/Perl_realloc/Perl_mfree
Then there is Perl_safesysmalloc/Perl_safesysrealloc/Perl_safesysfree/Perl_safesyscalloc
On Win32 psuedofork threaded perl, Perl_malloc/Perl_mfree call Perl_get_context
and call the iperlsys.h/perlhost.h layer with
/* Interpreter specific memory macros */
#define PerlMem_malloc(size) \
(*PL_Mem->pMalloc)(PL_Mem, (size))
So any idea of Perl_malloc being the "unsafe" or plain or "system"
version of Perl_safesysmalloc is faulty.
-should Perl_safesysmalloc/Perl_safesysrealloc/Perl_safesysfree/Perl_safesyscalloc
be renamed to Perl_malloc/Perl_calloc/Perl_realloc/Perl_mfree and defines
control which implementation is compiled?
---
embed.fnc | 36 ++++++++++-
embed.h | 33 +++++++---
hv.c | 2 +-
pad.c | 6 +-
perl.h | 27 ++++++++
proto.h | 186 +++++++++++++++++++++++++++++++++++++++++--------------
regcomp.c | 7 ++-
sv.c | 2 +
util.c | 60 ++++++++++++------
win32/perlhost.h | 4 ++
win32/win32.c | 20 ++++++
11 files changed, 302 insertions(+), 81 deletions(-)
diff --git a/embed.fnc b/embed.fnc
index 9171ec6..4f078ca 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1009,9 +1009,16 @@ AmdbR |HV* |newHV
ApaR |HV* |newHVhv |NULLOK HV *hv
Apabm |IO* |newIO
Apda |OP* |newLISTOP |I32 type|I32 flags|NULLOK OP* first|NULLOK OP* last
+
+#ifdef ALWAYS_NEED_THX
+AMpda |PADNAME *|newPADNAMEouter|NN PADNAME *outer
+AMpda |PADNAME *|newPADNAMEpvn|NN const char *s|STRLEN len
+AMpda |PADNAMELIST *|newPADNAMELIST|size_t max
+#else
AMpdan |PADNAME *|newPADNAMEouter|NN PADNAME *outer
AMpdan |PADNAME *|newPADNAMEpvn|NN const char *s|STRLEN len
AMpdan |PADNAMELIST *|newPADNAMELIST|size_t max
+#endif
#ifdef USE_ITHREADS
Apda |OP* |newPADOP |I32 type|I32 flags|NN SV* sv
#endif
@@ -1722,10 +1729,28 @@ s |int |yywarn |NN const char *const s|U32 flags
Ap |void |dump_mstats |NN const char* s
Ap |int |get_mstats |NN perl_mstats_t *buf|int buflen|int level
#endif
+#ifdef ALWAYS_NEED_THX
+:macros use context in core, no context outside
+Amnpa |Malloc_t|safesysmalloc |MEM_SIZE nbytes
+Amnpa |Malloc_t|safesyscalloc |MEM_SIZE elements|MEM_SIZE size
+Amnpa |Malloc_t|safesysrealloc|Malloc_t where|MEM_SIZE nbytes
+Amnp |Free_t |safesysfree |Malloc_t where
+Xnopa |Malloc_t|safesysmalloc |NN PerlInterpreter *my_perl|MEM_SIZE nbytes
+Xnopa |Malloc_t|safesyscalloc |NN PerlInterpreter *my_perl|MEM_SIZE elements|MEM_SIZE size
+Xnopa |Malloc_t|safesysrealloc|NN PerlInterpreter *my_perl|Malloc_t where|MEM_SIZE nbytes
+Xnop |Free_t |safesysfree |NN PerlInterpreter *my_perl|Malloc_t where
+:funcs to implement old public API
+Xnopa |Malloc_t|safesysmalloc_nocontext |MEM_SIZE nbytes
+Xnopa |Malloc_t|safesyscalloc_nocontext |MEM_SIZE elements|MEM_SIZE size
+Xnopa |Malloc_t|safesysrealloc_nocontext|Malloc_t where|MEM_SIZE nbytes
+Xnop |Free_t |safesysfree_nocontext |Malloc_t where
+:ifdef ALWAYS_NEED_THX
+#else
Anpa |Malloc_t|safesysmalloc |MEM_SIZE nbytes
Anpa |Malloc_t|safesyscalloc |MEM_SIZE elements|MEM_SIZE size
Anpa |Malloc_t|safesysrealloc|Malloc_t where|MEM_SIZE nbytes
Anp |Free_t |safesysfree |Malloc_t where
+#endif
Asrnx |void |croak_memory_wrap
#if defined(PERL_GLOBAL_STRUCT)
Ap |struct perl_vars *|GetVars
@@ -1904,7 +1929,11 @@ s |void |hsplit |NN HV *hv|STRLEN const oldsize|STRLEN newsize
s |void |hfreeentries |NN HV *hv
s |SV* |hv_free_ent_ret|NN HV *hv|NN HE *entry
sa |HE* |new_he
+#ifdef ALWAYS_NEED_THX
+saR |HEK* |save_hek_flags |NN const char *str|I32 len|U32 hash|int flags
+#else
sanR |HEK* |save_hek_flags |NN const char *str|I32 len|U32 hash|int flags
+#endif
sn |void |hv_magic_check |NN HV *hv|NN bool *needs_copy|NN bool *needs_store
s |void |unshare_hek_or_pvn|NULLOK const HEK* hek|NULLOK const char* str|I32 len|U32 hash
sR |HEK* |share_hek_flags|NN const char *str|I32 len|U32 hash|int flags
@@ -2212,8 +2241,13 @@ Es |SSize_t|study_chunk |NN RExC_state_t *pRExC_state \
|I32 stopparen|U32 recursed_depth \
|NULLOK regnode_ssc *and_withp \
|U32 flags|U32 depth
-EsRn |U32 |add_data |NN RExC_state_t* const pRExC_state \
+#ifdef ALWAYS_NEED_THX
+EosR |U32 |add_data |NN RExC_state_t* const pRExC_state \
|NN const char* const s|const U32 n
+#else
+EosRn |U32 |add_data |NN RExC_state_t* const pRExC_state \
+ |NN const char* const s|const U32 n
+#endif
rs |void |re_croak2 |bool utf8|NN const char* pat1|NN const char* pat2|...
Ei |I32 |regpposixcc |NN RExC_state_t *pRExC_state \
|I32 value|const bool strict
diff --git a/embed.h b/embed.h
index 6cebb19..6f5a412 100644
--- a/embed.h
+++ b/embed.h
@@ -383,9 +383,6 @@
#define newMYSUB(a,b,c,d,e) Perl_newMYSUB(aTHX_ a,b,c,d,e)
#define newNULLLIST() Perl_newNULLLIST(aTHX)
#define newOP(a,b) Perl_newOP(aTHX_ a,b)
-#define newPADNAMELIST Perl_newPADNAMELIST
-#define newPADNAMEouter Perl_newPADNAMEouter
-#define newPADNAMEpvn Perl_newPADNAMEpvn
#define newPMOP(a,b) Perl_newPMOP(aTHX_ a,b)
#define newPROG(a) Perl_newPROG(aTHX_ a)
#define newPVOP(a,b,c) Perl_newPVOP(aTHX_ a,b,c)
@@ -507,10 +504,6 @@
#define runops_debug() Perl_runops_debug(aTHX)
#define runops_standard() Perl_runops_standard(aTHX)
#define rv2cv_op_cv(a,b) Perl_rv2cv_op_cv(aTHX_ a,b)
-#define safesyscalloc Perl_safesyscalloc
-#define safesysfree Perl_safesysfree
-#define safesysmalloc Perl_safesysmalloc
-#define safesysrealloc Perl_safesysrealloc
#define save_I16(a) Perl_save_I16(aTHX_ a)
#define save_I32(a) Perl_save_I32(aTHX_ a)
#define save_I8(a) Perl_save_I8(aTHX_ a)
@@ -753,6 +746,15 @@
#define whichsig_pvn(a,b) Perl_whichsig_pvn(aTHX_ a,b)
#define whichsig_sv(a) Perl_whichsig_sv(aTHX_ a)
#define wrap_op_checker(a,b,c) Perl_wrap_op_checker(aTHX_ a,b,c)
+#if !(defined(ALWAYS_NEED_THX))
+#define newPADNAMELIST Perl_newPADNAMELIST
+#define newPADNAMEouter Perl_newPADNAMEouter
+#define newPADNAMEpvn Perl_newPADNAMEpvn
+#define safesyscalloc Perl_safesyscalloc
+#define safesysfree Perl_safesysfree
+#define safesysmalloc Perl_safesysmalloc
+#define safesysrealloc Perl_safesysrealloc
+#endif
#if !(defined(HAS_SIGACTION) && defined(SA_SIGINFO))
#define csighandler Perl_csighandler
#endif
@@ -778,6 +780,11 @@
#if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
#define my_bcopy Perl_my_bcopy
#endif
+#if defined(ALWAYS_NEED_THX)
+#define newPADNAMELIST(a) Perl_newPADNAMELIST(aTHX_ a)
+#define newPADNAMEouter(a) Perl_newPADNAMEouter(aTHX_ a)
+#define newPADNAMEpvn(a,b) Perl_newPADNAMEpvn(aTHX_ a,b)
+#endif
#if defined(DEBUGGING)
#define pad_setsv(a,b) Perl_pad_setsv(aTHX_ a,b)
#define pad_sv(a) Perl_pad_sv(aTHX_ a)
@@ -962,7 +969,6 @@
#define _make_exactf_invlist(a,b) S__make_exactf_invlist(aTHX_ a,b)
#define add_above_Latin1_folds(a,b,c) S_add_above_Latin1_folds(aTHX_ a,b,c)
#define add_cp_to_invlist(a,b) S_add_cp_to_invlist(aTHX_ a,b)
-#define add_data S_add_data
#define add_multi_match(a,b,c) S_add_multi_match(aTHX_ a,b,c)
#define alloc_maybe_populate_EXACT(a,b,c,d,e,f) S_alloc_maybe_populate_EXACT(aTHX_ a,b,c,d,e,f)
#define cntrl_to_mnemonic S_cntrl_to_mnemonic
@@ -1337,6 +1343,11 @@
#define yyerror_pvn(a,b,c) Perl_yyerror_pvn(aTHX_ a,b,c)
#define yyparse(a) Perl_yyparse(aTHX_ a)
#define yyunlex() Perl_yyunlex(aTHX)
+# if !(defined(ALWAYS_NEED_THX))
+# if defined(PERL_IN_HV_C)
+#define save_hek_flags S_save_hek_flags
+# endif
+# endif
# if !(defined(DEBUGGING))
# if !defined(NV_PRESERVES_UV)
# if defined(PERL_IN_SV_C)
@@ -1395,6 +1406,11 @@
# if !defined(WIN32)
#define do_exec3(a,b,c) Perl_do_exec3(aTHX_ a,b,c)
# endif
+# if defined(ALWAYS_NEED_THX)
+# if defined(PERL_IN_HV_C)
+#define save_hek_flags(a,b,c,d) S_save_hek_flags(aTHX_ a,b,c,d)
+# endif
+# endif
# if defined(DEBUGGING)
#define get_debug_opts(a,b) Perl_get_debug_opts(aTHX_ a,b)
#define set_padlist Perl_set_padlist
@@ -1502,7 +1518,6 @@
#define new_he() S_new_he(aTHX)
#define ptr_hash S_ptr_hash
#define refcounted_he_value(a) S_refcounted_he_value(aTHX_ a)
-#define save_hek_flags S_save_hek_flags
#define share_hek_flags(a,b,c,d) S_share_hek_flags(aTHX_ a,b,c,d)
#define unshare_hek_or_pvn(a,b,c,d) S_unshare_hek_or_pvn(aTHX_ a,b,c,d)
# endif
diff --git a/hv.c b/hv.c
index 2fd36ee..9e5582d 100644
--- a/hv.c
+++ b/hv.c
@@ -73,7 +73,7 @@ S_new_he(pTHX)
#endif
STATIC HEK *
-S_save_hek_flags(const char *str, I32 len, U32 hash, int flags)
+S_save_hek_flags(pMEMTHX_ const char *str, I32 len, U32 hash, int flags)
{
const int flags_masked = flags & HVhek_MASK;
char *k;
diff --git a/pad.c b/pad.c
index f5ce5f5..3ccac1d 100644
--- a/pad.c
+++ b/pad.c
@@ -2658,7 +2658,7 @@ is allocated.
*/
PADNAMELIST *
-Perl_newPADNAMELIST(size_t max)
+Perl_newPADNAMELIST(pMEMTHX_ size_t max)
{
PADNAMELIST *pnl;
Newx(pnl, 1, PADNAMELIST);
@@ -2790,7 +2790,7 @@ L</newPADNAMEouter>.
*/
PADNAME *
-Perl_newPADNAMEpvn(const char *s, STRLEN len)
+Perl_newPADNAMEpvn(pMEMTHX_ const char *s, STRLEN len)
{
struct padname_with_str *alloc;
char *alloc2; /* for Newxz */
@@ -2821,7 +2821,7 @@ PADNAMEt_OUTER flag already set.
*/
PADNAME *
-Perl_newPADNAMEouter(PADNAME *outer)
+Perl_newPADNAMEouter(pMEMTHX_ PADNAME *outer)
{
PADNAME *pn;
PERL_ARGS_ASSERT_NEWPADNAMEOUTER;
diff --git a/perl.h b/perl.h
index bb4dac4..e723324 100644
--- a/perl.h
+++ b/perl.h
@@ -958,6 +958,33 @@ EXTERN_C int usleep(unsigned int);
# define CHECK_MALLOC_TOO_LATE_FOR(ch) ((void)0)
# define CHECK_MALLOC_TAINT(newval) ((void)0)
# define MALLOC_CHECK_TAINT(argc,argv,env)
+
+# if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL)
+# define ALWAYS_NEED_THX
+# if defined(PERL_CORE)
+# define safesysmalloc(size) Perl_safesysmalloc(aTHX_ size)
+# define safesyscalloc(count, size) Perl_safesyscalloc(aTHX_ count, size)
+# define safesysrealloc(where, size) Perl_safesysrealloc(aTHX_ where, size)
+# define safesysfree(where) Perl_safesysfree(aTHX_ where)
+# else
+# define safesysmalloc(size) Perl_safesysmalloc_nocontext(size)
+# define safesyscalloc(count, size) Perl_safesyscalloc_nocontext(count, size)
+# define safesysrealloc(where, size) Perl_safesysrealloc_nocontext(where, size)
+# define safesysfree(where) Perl_safesysfree_nocontext(where)
+# endif
+# endif
+
+# if defined(PERL_CORE) || defined(PERL_EXT)
+# if defined(ALWAYS_NEED_THX)
+# define pMEMTHX_ pTHX_
+# define aMEMTHX_ aTHX_
+# else
+# define pMEMTHX_
+# define aMEMTHX_
+# endif
+# endif
+
+
#endif /* MYMALLOC */
/* diag_listed_as: "-T" is on the #! line, it must also be used on the command line */
diff --git a/proto.h b/proto.h
index b7acae9..69fc53f 100644
--- a/proto.h
+++ b/proto.h
@@ -3003,24 +3003,6 @@ PERL_CALLCONV OP* Perl_newOP(pTHX_ I32 optype, I32 flags)
__attribute__malloc__
__attribute__warn_unused_result__;
-PERL_CALLCONV PADNAMELIST * Perl_newPADNAMELIST(size_t max)
- __attribute__malloc__
- __attribute__warn_unused_result__;
-
-PERL_CALLCONV PADNAME * Perl_newPADNAMEouter(PADNAME *outer)
- __attribute__malloc__
- __attribute__warn_unused_result__
- __attribute__nonnull__(1);
-#define PERL_ARGS_ASSERT_NEWPADNAMEOUTER \
- assert(outer)
-
-PERL_CALLCONV PADNAME * Perl_newPADNAMEpvn(const char *s, STRLEN len)
- __attribute__malloc__
- __attribute__warn_unused_result__
- __attribute__nonnull__(1);
-#define PERL_ARGS_ASSERT_NEWPADNAMEPVN \
- assert(s)
-
PERL_CALLCONV OP* Perl_newPMOP(pTHX_ I32 type, I32 flags)
__attribute__malloc__
__attribute__warn_unused_result__;
@@ -3761,19 +3743,6 @@ PERL_CALLCONV void Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
#define PERL_ARGS_ASSERT_RXRES_SAVE \
assert(rsp); assert(rx)
-PERL_CALLCONV Malloc_t Perl_safesyscalloc(MEM_SIZE elements, MEM_SIZE size)
- __attribute__malloc__
- __attribute__warn_unused_result__;
-
-PERL_CALLCONV Free_t Perl_safesysfree(Malloc_t where);
-PERL_CALLCONV Malloc_t Perl_safesysmalloc(MEM_SIZE nbytes)
- __attribute__malloc__
- __attribute__warn_unused_result__;
-
-PERL_CALLCONV Malloc_t Perl_safesysrealloc(Malloc_t where, MEM_SIZE nbytes)
- __attribute__malloc__
- __attribute__warn_unused_result__;
-
PERL_CALLCONV void Perl_save_I16(pTHX_ I16* intp)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_SAVE_I16 \
@@ -5277,6 +5246,57 @@ PERL_CALLCONV int Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 fl
PERL_CALLCONV int Perl_yylex(pTHX);
PERL_CALLCONV int Perl_yyparse(pTHX_ int gramtype);
PERL_CALLCONV void Perl_yyunlex(pTHX);
+#if !(defined(ALWAYS_NEED_THX))
+PERL_CALLCONV PADNAMELIST * Perl_newPADNAMELIST(size_t max)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV PADNAME * Perl_newPADNAMEouter(PADNAME *outer)
+ __attribute__malloc__
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_NEWPADNAMEOUTER \
+ assert(outer)
+
+PERL_CALLCONV PADNAME * Perl_newPADNAMEpvn(const char *s, STRLEN len)
+ __attribute__malloc__
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_NEWPADNAMEPVN \
+ assert(s)
+
+PERL_CALLCONV Malloc_t Perl_safesyscalloc(MEM_SIZE elements, MEM_SIZE size)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV Free_t Perl_safesysfree(Malloc_t where);
+PERL_CALLCONV Malloc_t Perl_safesysmalloc(MEM_SIZE nbytes)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV Malloc_t Perl_safesysrealloc(Malloc_t where, MEM_SIZE nbytes)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+# if defined(PERL_IN_HV_C)
+STATIC HEK* S_save_hek_flags(const char *str, I32 len, U32 hash, int flags)
+ __attribute__malloc__
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_SAVE_HEK_FLAGS \
+ assert(str)
+
+# endif
+# if defined(PERL_IN_REGCOMP_C)
+STATIC U32 S_add_data(RExC_state_t* const pRExC_state, const char* const s, const U32 n)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(2);
+#define PERL_ARGS_ASSERT_ADD_DATA \
+ assert(pRExC_state); assert(s)
+
+# endif
+#endif
#if !(defined(DEBUGGING))
# if !defined(NV_PRESERVES_UV)
# if defined(PERL_IN_SV_C)
@@ -5515,6 +5535,96 @@ PERL_CALLCONV char* Perl_my_bcopy(const char* from, char* to, I32 len)
assert(from); assert(to)
#endif
+#if defined(ALWAYS_NEED_THX)
+PERL_CALLCONV PADNAMELIST * Perl_newPADNAMELIST(pTHX_ size_t max)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV PADNAME * Perl_newPADNAMEouter(pTHX_ PADNAME *outer)
+ __attribute__malloc__
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_NEWPADNAMEOUTER \
+ assert(outer)
+
+PERL_CALLCONV PADNAME * Perl_newPADNAMEpvn(pTHX_ const char *s, STRLEN len)
+ __attribute__malloc__
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_NEWPADNAMEPVN \
+ assert(s)
+
+/* PERL_CALLCONV Malloc_t Perl_safesyscalloc(MEM_SIZE elements, MEM_SIZE size)
+ __attribute__malloc__
+ __attribute__warn_unused_result__; */
+
+PERL_CALLCONV Malloc_t Perl_safesyscalloc(PerlInterpreter *my_perl, MEM_SIZE elements, MEM_SIZE size)
+ __attribute__malloc__
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_SAFESYSCALLOC \
+ assert(my_perl)
+
+PERL_CALLCONV Malloc_t Perl_safesyscalloc_nocontext(MEM_SIZE elements, MEM_SIZE size)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+/* PERL_CALLCONV Free_t Perl_safesysfree(Malloc_t where); */
+PERL_CALLCONV Free_t Perl_safesysfree(PerlInterpreter *my_perl, Malloc_t where)
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_SAFESYSFREE \
+ assert(my_perl)
+
+PERL_CALLCONV Free_t Perl_safesysfree_nocontext(Malloc_t where);
+/* PERL_CALLCONV Malloc_t Perl_safesysmalloc(MEM_SIZE nbytes)
+ __attribute__malloc__
+ __attribute__warn_unused_result__; */
+
+PERL_CALLCONV Malloc_t Perl_safesysmalloc(PerlInterpreter *my_perl, MEM_SIZE nbytes)
+ __attribute__malloc__
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_SAFESYSMALLOC \
+ assert(my_perl)
+
+PERL_CALLCONV Malloc_t Perl_safesysmalloc_nocontext(MEM_SIZE nbytes)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+/* PERL_CALLCONV Malloc_t Perl_safesysrealloc(Malloc_t where, MEM_SIZE nbytes)
+ __attribute__malloc__
+ __attribute__warn_unused_result__; */
+
+PERL_CALLCONV Malloc_t Perl_safesysrealloc(PerlInterpreter *my_perl, Malloc_t where, MEM_SIZE nbytes)
+ __attribute__malloc__
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_SAFESYSREALLOC \
+ assert(my_perl)
+
+PERL_CALLCONV Malloc_t Perl_safesysrealloc_nocontext(Malloc_t where, MEM_SIZE nbytes)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+# if defined(PERL_IN_HV_C)
+STATIC HEK* S_save_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags)
+ __attribute__malloc__
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SAVE_HEK_FLAGS \
+ assert(str)
+
+# endif
+# if defined(PERL_IN_REGCOMP_C)
+STATIC U32 S_add_data(pTHX_ RExC_state_t* const pRExC_state, const char* const s, const U32 n)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_ADD_DATA \
+ assert(pRExC_state); assert(s)
+
+# endif
+#endif
#if defined(DEBUGGING)
PERL_CALLCONV int Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
__attribute__warn_unused_result__
@@ -6193,13 +6303,6 @@ STATIC SV * S_refcounted_he_value(pTHX_ const struct refcounted_he *he)
#define PERL_ARGS_ASSERT_REFCOUNTED_HE_VALUE \
assert(he)
-STATIC HEK* S_save_hek_flags(const char *str, I32 len, U32 hash, int flags)
- __attribute__malloc__
- __attribute__warn_unused_result__
- __attribute__nonnull__(1);
-#define PERL_ARGS_ASSERT_SAVE_HEK_FLAGS \
- assert(str)
-
STATIC HEK* S_share_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags)
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
@@ -6895,13 +6998,6 @@ STATIC void S_add_above_Latin1_folds(pTHX_ RExC_state_t *pRExC_state, const U8 c
PERL_STATIC_INLINE SV* S_add_cp_to_invlist(pTHX_ SV* invlist, const UV cp)
__attribute__warn_unused_result__;
-STATIC U32 S_add_data(RExC_state_t* const pRExC_state, const char* const s, const U32 n)
- __attribute__warn_unused_result__
- __attribute__nonnull__(1)
- __attribute__nonnull__(2);
-#define PERL_ARGS_ASSERT_ADD_DATA \
- assert(pRExC_state); assert(s)
-
STATIC AV* S_add_multi_match(pTHX_ AV* multi_char_matches, SV* multi_string, const STRLEN cp_count)
__attribute__nonnull__(pTHX_2);
#define PERL_ARGS_ASSERT_ADD_MULTI_MATCH \
diff --git a/regcomp.c b/regcomp.c
index 901e2c0..3fd1c9f 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -267,6 +267,8 @@ struct RExC_state_t {
#define RExC_frame_count (pRExC_state->frame_count)
#define RExC_strict (pRExC_state->strict)
+#define add_data(pRExC_state, str_and_len) S_add_data(aMEMTHX_ pRExC_state, str_and_len)
+
/* Heuristic check on the complexity of the pattern: if TOO_NAUGHTY, we set
* a flag to disable back-off on the fixed/floating substrings - if it's
* a high complexity pattern we assume the benefit of avoiding a full match
@@ -5646,7 +5648,7 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVuf" RHS=%"UVuf"\n",
}
STATIC U32
-S_add_data(RExC_state_t* const pRExC_state, const char* const s, const U32 n)
+S_add_data(pMEMTHX_ RExC_state_t* const pRExC_state, const char* const s, const U32 n)
{
U32 count = RExC_rxi->data ? RExC_rxi->data->count : 0;
@@ -8069,6 +8071,7 @@ PERL_STATIC_INLINE void
S_invlist_trim(SV* const invlist)
{
PERL_ARGS_ASSERT_INVLIST_TRIM;
+ dTHX;
assert(SvTYPE(invlist) == SVt_INVLIST);
@@ -10230,7 +10233,7 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
RExC_rxi->data->data[n+1] = (void*)o;
}
else {
- n = add_data(pRExC_state,
+ n = S_add_data(aMEMTHX_ pRExC_state,
(RExC_pm_flags & PMf_HAS_CV) ? "L" : "l", 1);
RExC_rxi->data->data[n] = (void*)o;
}
diff --git a/sv.c b/sv.c
index ae5bba3..853817f 100644
--- a/sv.c
+++ b/sv.c
@@ -15081,6 +15081,7 @@ Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to)
PERL_SET_THX(to);
}
+#define my_perl to
/* Given that we've set the context, we can do this unshared. */
Newx(param, 1, CLONE_PARAMS);
@@ -15094,6 +15095,7 @@ Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to)
if (was != to) {
PERL_SET_THX(was);
}
+#undef my_perl
return param;
}
diff --git a/util.c b/util.c
index 607f480..db4bbfe 100644
--- a/util.c
+++ b/util.c
@@ -81,10 +81,6 @@ int putenv(char *);
* XXX This advice seems to be widely ignored :-( --AD August 1996.
*/
-#if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL)
-# define ALWAYS_NEED_THX
-#endif
-
#if defined(PERL_TRACK_MEMPOOL) && defined(PERL_DEBUG_READONLY_COW)
static void
S_maybe_protect_rw(pTHX_ struct perl_memory_debug_header *header)
@@ -122,12 +118,10 @@ S_maybe_protect_ro(pTHX_ struct perl_memory_debug_header *header)
/* paranoid version of system's malloc() */
Malloc_t
-Perl_safesysmalloc(MEM_SIZE size)
+Perl_safesysmalloc(pMEMTHX_ MEM_SIZE size)
{
-#ifdef ALWAYS_NEED_THX
- dTHX;
-#endif
Malloc_t ptr;
+ PERL_ARGS_ASSERT_SAFESYSMALLOC;
#ifdef USE_MDH
if (size + PERL_MEMORY_DEBUG_HEADER_SIZE < size)
@@ -199,17 +193,15 @@ Perl_safesysmalloc(MEM_SIZE size)
/* paranoid version of system's realloc() */
Malloc_t
-Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
+Perl_safesysrealloc(pMEMTHX_ Malloc_t where,MEM_SIZE size)
{
-#ifdef ALWAYS_NEED_THX
- dTHX;
-#endif
Malloc_t ptr;
#ifdef PERL_DEBUG_READONLY_COW
const MEM_SIZE oldsize = where
? ((struct perl_memory_debug_header *)((char *)where - PERL_MEMORY_DEBUG_HEADER_SIZE))->size
: 0;
#endif
+ PERL_ARGS_ASSERT_SAFESYSREALLOC;
#if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
Malloc_t PerlMem_realloc();
#endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
@@ -324,11 +316,9 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
/* safe version of system's free() */
Free_t
-Perl_safesysfree(Malloc_t where)
+Perl_safesysfree(pMEMTHX_ Malloc_t where)
{
-#ifdef ALWAYS_NEED_THX
- dTHX;
-#endif
+ PERL_ARGS_ASSERT_SAFESYSFREE;
DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
if (where) {
#ifdef USE_MDH
@@ -389,15 +379,13 @@ Perl_safesysfree(Malloc_t where)
/* safe version of system's calloc() */
Malloc_t
-Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
+Perl_safesyscalloc(pMEMTHX_ MEM_SIZE count, MEM_SIZE size)
{
-#ifdef ALWAYS_NEED_THX
- dTHX;
-#endif
Malloc_t ptr;
#if defined(USE_MDH) || defined(DEBUGGING)
MEM_SIZE total_size = 0;
#endif
+ PERL_ARGS_ASSERT_SAFESYSCALLOC;
/* Even though calloc() for zero bytes is strange, be robust. */
if (size && (count <= MEM_SIZE_MAX / size)) {
@@ -479,6 +467,38 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
}
}
+
+#ifdef ALWAYS_NEED_THX
+Malloc_t
+Perl_safesysmalloc_nocontext(MEM_SIZE size)
+{
+ dTHX;
+ return Perl_safesysmalloc(aTHX_ size);
+}
+
+Malloc_t
+Perl_safesysrealloc_nocontext(Malloc_t where,MEM_SIZE size)
+{
+ dTHX;
+ return Perl_safesysrealloc(aTHX_ where, size);
+}
+
+Free_t
+Perl_safesysfree_nocontext(Malloc_t where)
+{
+ dTHX;
+ return Perl_safesysfree(aTHX_ where);
+}
+
+Malloc_t
+Perl_safesyscalloc_nocontext(MEM_SIZE count, MEM_SIZE size)
+{
+ dTHX;
+ return Perl_safesyscalloc(aTHX_ count, size);
+}
+
+#endif
+
/* These must be defined when not using Perl's malloc for binary
* compatibility */
diff --git a/win32/perlhost.h b/win32/perlhost.h
index b0b3692..9853b47 100644
--- a/win32/perlhost.h
+++ b/win32/perlhost.h
@@ -2223,6 +2223,7 @@ CPerlHost::CalculateEnvironmentSpace(void)
void
CPerlHost::FreeLocalEnvironmentStrings(LPSTR lpStr)
{
+ dTHXa(host_perl);
Safefree(lpStr);
}
@@ -2231,6 +2232,7 @@ CPerlHost::GetChildDir(void)
{
char* ptr;
size_t length;
+ dTHXa(host_perl);
Newx(ptr, MAX_PATH+1, char);
m_pvDir->GetCurrentDirectoryA(MAX_PATH+1, ptr);
@@ -2245,6 +2247,7 @@ CPerlHost::GetChildDir(void)
void
CPerlHost::FreeChildDir(char* pStr)
{
+ dTHXa(host_perl);
Safefree(pStr);
}
@@ -2275,6 +2278,7 @@ CPerlHost::CreateLocalEnvironmentStrings(VDir &vDir)
// add the additional space used by changes made to the environment
dwSize += CalculateEnvironmentSpace();
+ dTHXa(host_perl);
Newx(lpStr, dwSize, char);
lpPtr = lpStr;
if(lpStr != NULL) {
diff --git a/win32/win32.c b/win32/win32.c
index 48723bf..f17096f 100644
--- a/win32/win32.c
+++ b/win32/win32.c
@@ -533,6 +533,7 @@ tokenize(const char *str, char **dest, char ***destv)
int slen = strlen(str);
char *ret;
char **retv;
+ dTHX;
Newx(ret, slen+2, char);
Newx(retv, (slen+3)/2, char*);
@@ -940,6 +941,7 @@ win32_readdir(DIR *dirp)
}
}
if (res) {
+ dTHX;
long endpos = dirp->end - dirp->start;
long newsize = endpos + strlen(buffer) + 1;
/* bump the string table size by enough for the
@@ -996,6 +998,7 @@ win32_rewinddir(DIR *dirp)
DllExport int
win32_closedir(DIR *dirp)
{
+ dTHX;
if (dirp->handle != INVALID_HANDLE_VALUE)
FindClose(dirp->handle);
Safefree(dirp->start);
@@ -1035,11 +1038,13 @@ win32_dirp_dup(DIR *const dirp, CLONE_PARAMS *const param)
PERL_SET_THX(to);
}
+#define my_perl to
Newx(dup, 1, DIR);
memcpy(dup, dirp, sizeof(DIR));
Newx(dup->start, dirp->size, char);
memcpy(dup->start, dirp->start, dirp->size);
+#undef my_perl
dup->end = dup->start + (dirp->end - dirp->start);
if (dirp->curr)
@@ -3393,7 +3398,11 @@ win32_chmod(const char *path, int mode)
static char *
create_command_line(char *cname, STRLEN clen, const char * const *args)
{
+#ifdef ALWAYS_NEED_THX
+ dTHX;
+#else
PERL_DEB(dTHX;)
+#endif
int index, argc;
char *cmd, *ptr;
const char *arg;
@@ -3557,6 +3566,9 @@ qualified_path(const char *cmd, bool other_exts)
{
char *pathstr;
char *fullcmd, *curfullcmd;
+#ifdef ALWAYS_NEED_THX
+ dTHX;
+#endif
STRLEN cmdlen = 0;
int has_slash = 0;
@@ -3572,7 +3584,9 @@ qualified_path(const char *cmd, bool other_exts)
/* look in PATH */
{
+#ifndef ALWAYS_NEED_THX
dTHX;
+#endif
pathstr = PerlEnv_getenv("PATH");
}
/* worst case: PATH is a single directory; we need additional space
@@ -3688,6 +3702,9 @@ win32_get_childdir(void)
{
char* ptr;
char szfilename[MAX_PATH+1];
+#ifdef ALWAYS_NEED_THX
+ dTHX;
+#endif
GetCurrentDirectoryA(MAX_PATH+1, szfilename);
Newx(ptr, strlen(szfilename)+1, char);
@@ -3698,6 +3715,9 @@ win32_get_childdir(void)
DllExport void
win32_free_childdir(char* d)
{
+#ifdef ALWAYS_NEED_THX
+ dTHX;
+#endif
Safefree(d);
}
--
1.9.5.msysgit.1
|
From @bulk88New patch (do NOT commit this) attached, I forgot to stage/commit a bunch of changes in win32.c in the first patch. -- |
From @bulk880001-WIP-POC-perl-s-malloc-API-takes-a-my_perl-context-ma.patchFrom 452c3358c23c81a8a0062faad1ef81cee6f4c807 Mon Sep 17 00:00:00 2001
From: bulk88 <bulk88@hotmail.com>
Date: Tue, 4 Aug 2015 23:15:51 -0400
Subject: [PATCH] WIP/POC perl's malloc API takes a my_perl/context/malloc API
refactor
I wrote this patch to stop a huge number Perl_get_contexts while debugging
a rogue setting of SetLastError (AKA Win32's errno) in Perl. Putting a
break point in SetLastError produces alot of noise since Perl_get_context
saves and restores the error code each time it is called. Perl's malloc
APIs are the #1 source of Perl_get_context calls on threaded perl.
I've had ideas for a while about replacing win32/vmem.h and perlhost.h's
implementation (but not API) of
PerlMem_malloc/PerlMemShared_malloc/PerlMemParse_malloc with using the
Win32 native malloc API directly. The old Sarathy code is a painful
reimplementation of the Win32 native malloc API on top of the
Win32/standard C malloc API which is on top of the Win32 native malloc API.
This reimplementation is done by putting double linked list headers on
every memory block. The win32 LL alloc code is the doppelganger of
PERL_TRACK_MEMPOOL. Using the Win32 native malloc API allows Perl to free
all the memory associated with a perl thread with 1 C function call, which
frees all the VM pages behind that perl thread in 1 shot, not the linked
list looping stuff which was probably written to deal with sbrk() only, no
mmap() unix machines from the early 80s. Why it was written for Win32 in
the 1990s, which never had sbrk in any form, IDK.
Anyway, this commit would be the begining of
PerlMem_malloc/PerlMemShared_malloc/PerlMemParse_malloc possibly being
macros directly win32 OS API's native malloc, not function calls to perl
API functions. This patch also decreased Perl_get_context calls.
incomplete areas:
S_invlist_trim
add_data
+#define my_perl to and +#undef my_perl stuff, dont create 2 C autos
(CC optimization problems then, VC prefer to make a new C stack auto vs
writing to an incoming arg), but "to" as a var name i think is informative
Perl_clone_params_new
from 5.13.2
http://perl5.git.perl.org/perl.git/commitdiff/f7abe70be985cb9179c2e728a593cb8a5c8e049d
win32_dirp_dup
Newxt for threaded added to handy.h?
Newxzt
make bundled XS modules Newx and my_perl clean
questions to debate
-should win32_* be using win32_malloc instead of interp specific mem?
win32_* funcs are sorta like P5's extensions to libc, so they should be
usable without an interp, right or wrong?
-does embed.fnc need a new letter that says MEMTHX not THX
(think opposite of "n") instead of the #ifdefs
-should it be "MTHX" instead of "MEMTHX"? less clutter less typing?
-is ALWAYS_NEED_THX conceptually nonsense? If no threads, current my_perl
is 1 byte long
struct interpreter {
char broiled;
};, should perl_alloc return null or -1 or just plain 1 or a pointer to 1
char as a C static global? Will there ever be 2 unthreaded libperls in the
same process and somehow they cross pointers through bad embedding or XS
code? Should PERL_TRACK_MEMPOOL not record my_perl on unthreaded perl?
The DEBUGGING debug channel logs in util.c dont need my_perl on unthreaded
perl since its unthreaded perl.
-should Newxt be named Newxt or Newtx or should CPAN be forced to go
through a conversion/deprecate process to be Newx my_perl clean by
"breaking change" Newx to require a my_perl outside of core?
-PERL_NO_GET_CONTEXT exists. Add PERL_CXT_ALLOC to say we want my_perl
version of Newx macro instead of Newxt api?
-Newxt in ppport.h would be defined to Newx on older perls
-is Perl_safesysmalloc_nocontext and friends, have bloated wastefully long
names for purpose of XS/libperl binary size? any better name?
-Why do we have TWO malloc APIs facing XS code/in libperl's export list?
First there is rarely used Perl_malloc/Perl_calloc/Perl_realloc/Perl_mfree
Then there is Perl_safesysmalloc/Perl_safesysrealloc/Perl_safesysfree/Perl_safesyscalloc
On Win32 psuedofork threaded perl, Perl_malloc/Perl_mfree call Perl_get_context
and call the iperlsys.h/perlhost.h layer with
/* Interpreter specific memory macros */
#define PerlMem_malloc(size) \
(*PL_Mem->pMalloc)(PL_Mem, (size))
So any idea of Perl_malloc being the "unsafe" or plain or "system"
version of Perl_safesysmalloc is faulty.
-should Perl_safesysmalloc/Perl_safesysrealloc/Perl_safesysfree/Perl_safesyscalloc
be renamed to Perl_malloc/Perl_calloc/Perl_realloc/Perl_mfree and defines
control which implementation is compiled?
---
embed.fnc | 36 ++++++++++-
embed.h | 33 +++++++---
hv.c | 2 +-
pad.c | 6 +-
perl.h | 27 ++++++++
proto.h | 186 +++++++++++++++++++++++++++++++++++++++++--------------
regcomp.c | 7 ++-
sv.c | 2 +
util.c | 60 ++++++++++++------
win32/perlhost.h | 4 ++
win32/win32.c | 25 +++++++-
11 files changed, 304 insertions(+), 84 deletions(-)
diff --git a/embed.fnc b/embed.fnc
index 9171ec6..4f078ca 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1009,9 +1009,16 @@ AmdbR |HV* |newHV
ApaR |HV* |newHVhv |NULLOK HV *hv
Apabm |IO* |newIO
Apda |OP* |newLISTOP |I32 type|I32 flags|NULLOK OP* first|NULLOK OP* last
+
+#ifdef ALWAYS_NEED_THX
+AMpda |PADNAME *|newPADNAMEouter|NN PADNAME *outer
+AMpda |PADNAME *|newPADNAMEpvn|NN const char *s|STRLEN len
+AMpda |PADNAMELIST *|newPADNAMELIST|size_t max
+#else
AMpdan |PADNAME *|newPADNAMEouter|NN PADNAME *outer
AMpdan |PADNAME *|newPADNAMEpvn|NN const char *s|STRLEN len
AMpdan |PADNAMELIST *|newPADNAMELIST|size_t max
+#endif
#ifdef USE_ITHREADS
Apda |OP* |newPADOP |I32 type|I32 flags|NN SV* sv
#endif
@@ -1722,10 +1729,28 @@ s |int |yywarn |NN const char *const s|U32 flags
Ap |void |dump_mstats |NN const char* s
Ap |int |get_mstats |NN perl_mstats_t *buf|int buflen|int level
#endif
+#ifdef ALWAYS_NEED_THX
+:macros use context in core, no context outside
+Amnpa |Malloc_t|safesysmalloc |MEM_SIZE nbytes
+Amnpa |Malloc_t|safesyscalloc |MEM_SIZE elements|MEM_SIZE size
+Amnpa |Malloc_t|safesysrealloc|Malloc_t where|MEM_SIZE nbytes
+Amnp |Free_t |safesysfree |Malloc_t where
+Xnopa |Malloc_t|safesysmalloc |NN PerlInterpreter *my_perl|MEM_SIZE nbytes
+Xnopa |Malloc_t|safesyscalloc |NN PerlInterpreter *my_perl|MEM_SIZE elements|MEM_SIZE size
+Xnopa |Malloc_t|safesysrealloc|NN PerlInterpreter *my_perl|Malloc_t where|MEM_SIZE nbytes
+Xnop |Free_t |safesysfree |NN PerlInterpreter *my_perl|Malloc_t where
+:funcs to implement old public API
+Xnopa |Malloc_t|safesysmalloc_nocontext |MEM_SIZE nbytes
+Xnopa |Malloc_t|safesyscalloc_nocontext |MEM_SIZE elements|MEM_SIZE size
+Xnopa |Malloc_t|safesysrealloc_nocontext|Malloc_t where|MEM_SIZE nbytes
+Xnop |Free_t |safesysfree_nocontext |Malloc_t where
+:ifdef ALWAYS_NEED_THX
+#else
Anpa |Malloc_t|safesysmalloc |MEM_SIZE nbytes
Anpa |Malloc_t|safesyscalloc |MEM_SIZE elements|MEM_SIZE size
Anpa |Malloc_t|safesysrealloc|Malloc_t where|MEM_SIZE nbytes
Anp |Free_t |safesysfree |Malloc_t where
+#endif
Asrnx |void |croak_memory_wrap
#if defined(PERL_GLOBAL_STRUCT)
Ap |struct perl_vars *|GetVars
@@ -1904,7 +1929,11 @@ s |void |hsplit |NN HV *hv|STRLEN const oldsize|STRLEN newsize
s |void |hfreeentries |NN HV *hv
s |SV* |hv_free_ent_ret|NN HV *hv|NN HE *entry
sa |HE* |new_he
+#ifdef ALWAYS_NEED_THX
+saR |HEK* |save_hek_flags |NN const char *str|I32 len|U32 hash|int flags
+#else
sanR |HEK* |save_hek_flags |NN const char *str|I32 len|U32 hash|int flags
+#endif
sn |void |hv_magic_check |NN HV *hv|NN bool *needs_copy|NN bool *needs_store
s |void |unshare_hek_or_pvn|NULLOK const HEK* hek|NULLOK const char* str|I32 len|U32 hash
sR |HEK* |share_hek_flags|NN const char *str|I32 len|U32 hash|int flags
@@ -2212,8 +2241,13 @@ Es |SSize_t|study_chunk |NN RExC_state_t *pRExC_state \
|I32 stopparen|U32 recursed_depth \
|NULLOK regnode_ssc *and_withp \
|U32 flags|U32 depth
-EsRn |U32 |add_data |NN RExC_state_t* const pRExC_state \
+#ifdef ALWAYS_NEED_THX
+EosR |U32 |add_data |NN RExC_state_t* const pRExC_state \
|NN const char* const s|const U32 n
+#else
+EosRn |U32 |add_data |NN RExC_state_t* const pRExC_state \
+ |NN const char* const s|const U32 n
+#endif
rs |void |re_croak2 |bool utf8|NN const char* pat1|NN const char* pat2|...
Ei |I32 |regpposixcc |NN RExC_state_t *pRExC_state \
|I32 value|const bool strict
diff --git a/embed.h b/embed.h
index 6cebb19..6f5a412 100644
--- a/embed.h
+++ b/embed.h
@@ -383,9 +383,6 @@
#define newMYSUB(a,b,c,d,e) Perl_newMYSUB(aTHX_ a,b,c,d,e)
#define newNULLLIST() Perl_newNULLLIST(aTHX)
#define newOP(a,b) Perl_newOP(aTHX_ a,b)
-#define newPADNAMELIST Perl_newPADNAMELIST
-#define newPADNAMEouter Perl_newPADNAMEouter
-#define newPADNAMEpvn Perl_newPADNAMEpvn
#define newPMOP(a,b) Perl_newPMOP(aTHX_ a,b)
#define newPROG(a) Perl_newPROG(aTHX_ a)
#define newPVOP(a,b,c) Perl_newPVOP(aTHX_ a,b,c)
@@ -507,10 +504,6 @@
#define runops_debug() Perl_runops_debug(aTHX)
#define runops_standard() Perl_runops_standard(aTHX)
#define rv2cv_op_cv(a,b) Perl_rv2cv_op_cv(aTHX_ a,b)
-#define safesyscalloc Perl_safesyscalloc
-#define safesysfree Perl_safesysfree
-#define safesysmalloc Perl_safesysmalloc
-#define safesysrealloc Perl_safesysrealloc
#define save_I16(a) Perl_save_I16(aTHX_ a)
#define save_I32(a) Perl_save_I32(aTHX_ a)
#define save_I8(a) Perl_save_I8(aTHX_ a)
@@ -753,6 +746,15 @@
#define whichsig_pvn(a,b) Perl_whichsig_pvn(aTHX_ a,b)
#define whichsig_sv(a) Perl_whichsig_sv(aTHX_ a)
#define wrap_op_checker(a,b,c) Perl_wrap_op_checker(aTHX_ a,b,c)
+#if !(defined(ALWAYS_NEED_THX))
+#define newPADNAMELIST Perl_newPADNAMELIST
+#define newPADNAMEouter Perl_newPADNAMEouter
+#define newPADNAMEpvn Perl_newPADNAMEpvn
+#define safesyscalloc Perl_safesyscalloc
+#define safesysfree Perl_safesysfree
+#define safesysmalloc Perl_safesysmalloc
+#define safesysrealloc Perl_safesysrealloc
+#endif
#if !(defined(HAS_SIGACTION) && defined(SA_SIGINFO))
#define csighandler Perl_csighandler
#endif
@@ -778,6 +780,11 @@
#if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
#define my_bcopy Perl_my_bcopy
#endif
+#if defined(ALWAYS_NEED_THX)
+#define newPADNAMELIST(a) Perl_newPADNAMELIST(aTHX_ a)
+#define newPADNAMEouter(a) Perl_newPADNAMEouter(aTHX_ a)
+#define newPADNAMEpvn(a,b) Perl_newPADNAMEpvn(aTHX_ a,b)
+#endif
#if defined(DEBUGGING)
#define pad_setsv(a,b) Perl_pad_setsv(aTHX_ a,b)
#define pad_sv(a) Perl_pad_sv(aTHX_ a)
@@ -962,7 +969,6 @@
#define _make_exactf_invlist(a,b) S__make_exactf_invlist(aTHX_ a,b)
#define add_above_Latin1_folds(a,b,c) S_add_above_Latin1_folds(aTHX_ a,b,c)
#define add_cp_to_invlist(a,b) S_add_cp_to_invlist(aTHX_ a,b)
-#define add_data S_add_data
#define add_multi_match(a,b,c) S_add_multi_match(aTHX_ a,b,c)
#define alloc_maybe_populate_EXACT(a,b,c,d,e,f) S_alloc_maybe_populate_EXACT(aTHX_ a,b,c,d,e,f)
#define cntrl_to_mnemonic S_cntrl_to_mnemonic
@@ -1337,6 +1343,11 @@
#define yyerror_pvn(a,b,c) Perl_yyerror_pvn(aTHX_ a,b,c)
#define yyparse(a) Perl_yyparse(aTHX_ a)
#define yyunlex() Perl_yyunlex(aTHX)
+# if !(defined(ALWAYS_NEED_THX))
+# if defined(PERL_IN_HV_C)
+#define save_hek_flags S_save_hek_flags
+# endif
+# endif
# if !(defined(DEBUGGING))
# if !defined(NV_PRESERVES_UV)
# if defined(PERL_IN_SV_C)
@@ -1395,6 +1406,11 @@
# if !defined(WIN32)
#define do_exec3(a,b,c) Perl_do_exec3(aTHX_ a,b,c)
# endif
+# if defined(ALWAYS_NEED_THX)
+# if defined(PERL_IN_HV_C)
+#define save_hek_flags(a,b,c,d) S_save_hek_flags(aTHX_ a,b,c,d)
+# endif
+# endif
# if defined(DEBUGGING)
#define get_debug_opts(a,b) Perl_get_debug_opts(aTHX_ a,b)
#define set_padlist Perl_set_padlist
@@ -1502,7 +1518,6 @@
#define new_he() S_new_he(aTHX)
#define ptr_hash S_ptr_hash
#define refcounted_he_value(a) S_refcounted_he_value(aTHX_ a)
-#define save_hek_flags S_save_hek_flags
#define share_hek_flags(a,b,c,d) S_share_hek_flags(aTHX_ a,b,c,d)
#define unshare_hek_or_pvn(a,b,c,d) S_unshare_hek_or_pvn(aTHX_ a,b,c,d)
# endif
diff --git a/hv.c b/hv.c
index 2fd36ee..9e5582d 100644
--- a/hv.c
+++ b/hv.c
@@ -73,7 +73,7 @@ S_new_he(pTHX)
#endif
STATIC HEK *
-S_save_hek_flags(const char *str, I32 len, U32 hash, int flags)
+S_save_hek_flags(pMEMTHX_ const char *str, I32 len, U32 hash, int flags)
{
const int flags_masked = flags & HVhek_MASK;
char *k;
diff --git a/pad.c b/pad.c
index f5ce5f5..3ccac1d 100644
--- a/pad.c
+++ b/pad.c
@@ -2658,7 +2658,7 @@ is allocated.
*/
PADNAMELIST *
-Perl_newPADNAMELIST(size_t max)
+Perl_newPADNAMELIST(pMEMTHX_ size_t max)
{
PADNAMELIST *pnl;
Newx(pnl, 1, PADNAMELIST);
@@ -2790,7 +2790,7 @@ L</newPADNAMEouter>.
*/
PADNAME *
-Perl_newPADNAMEpvn(const char *s, STRLEN len)
+Perl_newPADNAMEpvn(pMEMTHX_ const char *s, STRLEN len)
{
struct padname_with_str *alloc;
char *alloc2; /* for Newxz */
@@ -2821,7 +2821,7 @@ PADNAMEt_OUTER flag already set.
*/
PADNAME *
-Perl_newPADNAMEouter(PADNAME *outer)
+Perl_newPADNAMEouter(pMEMTHX_ PADNAME *outer)
{
PADNAME *pn;
PERL_ARGS_ASSERT_NEWPADNAMEOUTER;
diff --git a/perl.h b/perl.h
index bb4dac4..e723324 100644
--- a/perl.h
+++ b/perl.h
@@ -958,6 +958,33 @@ EXTERN_C int usleep(unsigned int);
# define CHECK_MALLOC_TOO_LATE_FOR(ch) ((void)0)
# define CHECK_MALLOC_TAINT(newval) ((void)0)
# define MALLOC_CHECK_TAINT(argc,argv,env)
+
+# if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL)
+# define ALWAYS_NEED_THX
+# if defined(PERL_CORE)
+# define safesysmalloc(size) Perl_safesysmalloc(aTHX_ size)
+# define safesyscalloc(count, size) Perl_safesyscalloc(aTHX_ count, size)
+# define safesysrealloc(where, size) Perl_safesysrealloc(aTHX_ where, size)
+# define safesysfree(where) Perl_safesysfree(aTHX_ where)
+# else
+# define safesysmalloc(size) Perl_safesysmalloc_nocontext(size)
+# define safesyscalloc(count, size) Perl_safesyscalloc_nocontext(count, size)
+# define safesysrealloc(where, size) Perl_safesysrealloc_nocontext(where, size)
+# define safesysfree(where) Perl_safesysfree_nocontext(where)
+# endif
+# endif
+
+# if defined(PERL_CORE) || defined(PERL_EXT)
+# if defined(ALWAYS_NEED_THX)
+# define pMEMTHX_ pTHX_
+# define aMEMTHX_ aTHX_
+# else
+# define pMEMTHX_
+# define aMEMTHX_
+# endif
+# endif
+
+
#endif /* MYMALLOC */
/* diag_listed_as: "-T" is on the #! line, it must also be used on the command line */
diff --git a/proto.h b/proto.h
index b7acae9..69fc53f 100644
--- a/proto.h
+++ b/proto.h
@@ -3003,24 +3003,6 @@ PERL_CALLCONV OP* Perl_newOP(pTHX_ I32 optype, I32 flags)
__attribute__malloc__
__attribute__warn_unused_result__;
-PERL_CALLCONV PADNAMELIST * Perl_newPADNAMELIST(size_t max)
- __attribute__malloc__
- __attribute__warn_unused_result__;
-
-PERL_CALLCONV PADNAME * Perl_newPADNAMEouter(PADNAME *outer)
- __attribute__malloc__
- __attribute__warn_unused_result__
- __attribute__nonnull__(1);
-#define PERL_ARGS_ASSERT_NEWPADNAMEOUTER \
- assert(outer)
-
-PERL_CALLCONV PADNAME * Perl_newPADNAMEpvn(const char *s, STRLEN len)
- __attribute__malloc__
- __attribute__warn_unused_result__
- __attribute__nonnull__(1);
-#define PERL_ARGS_ASSERT_NEWPADNAMEPVN \
- assert(s)
-
PERL_CALLCONV OP* Perl_newPMOP(pTHX_ I32 type, I32 flags)
__attribute__malloc__
__attribute__warn_unused_result__;
@@ -3761,19 +3743,6 @@ PERL_CALLCONV void Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
#define PERL_ARGS_ASSERT_RXRES_SAVE \
assert(rsp); assert(rx)
-PERL_CALLCONV Malloc_t Perl_safesyscalloc(MEM_SIZE elements, MEM_SIZE size)
- __attribute__malloc__
- __attribute__warn_unused_result__;
-
-PERL_CALLCONV Free_t Perl_safesysfree(Malloc_t where);
-PERL_CALLCONV Malloc_t Perl_safesysmalloc(MEM_SIZE nbytes)
- __attribute__malloc__
- __attribute__warn_unused_result__;
-
-PERL_CALLCONV Malloc_t Perl_safesysrealloc(Malloc_t where, MEM_SIZE nbytes)
- __attribute__malloc__
- __attribute__warn_unused_result__;
-
PERL_CALLCONV void Perl_save_I16(pTHX_ I16* intp)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_SAVE_I16 \
@@ -5277,6 +5246,57 @@ PERL_CALLCONV int Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 fl
PERL_CALLCONV int Perl_yylex(pTHX);
PERL_CALLCONV int Perl_yyparse(pTHX_ int gramtype);
PERL_CALLCONV void Perl_yyunlex(pTHX);
+#if !(defined(ALWAYS_NEED_THX))
+PERL_CALLCONV PADNAMELIST * Perl_newPADNAMELIST(size_t max)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV PADNAME * Perl_newPADNAMEouter(PADNAME *outer)
+ __attribute__malloc__
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_NEWPADNAMEOUTER \
+ assert(outer)
+
+PERL_CALLCONV PADNAME * Perl_newPADNAMEpvn(const char *s, STRLEN len)
+ __attribute__malloc__
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_NEWPADNAMEPVN \
+ assert(s)
+
+PERL_CALLCONV Malloc_t Perl_safesyscalloc(MEM_SIZE elements, MEM_SIZE size)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV Free_t Perl_safesysfree(Malloc_t where);
+PERL_CALLCONV Malloc_t Perl_safesysmalloc(MEM_SIZE nbytes)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV Malloc_t Perl_safesysrealloc(Malloc_t where, MEM_SIZE nbytes)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+# if defined(PERL_IN_HV_C)
+STATIC HEK* S_save_hek_flags(const char *str, I32 len, U32 hash, int flags)
+ __attribute__malloc__
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_SAVE_HEK_FLAGS \
+ assert(str)
+
+# endif
+# if defined(PERL_IN_REGCOMP_C)
+STATIC U32 S_add_data(RExC_state_t* const pRExC_state, const char* const s, const U32 n)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(2);
+#define PERL_ARGS_ASSERT_ADD_DATA \
+ assert(pRExC_state); assert(s)
+
+# endif
+#endif
#if !(defined(DEBUGGING))
# if !defined(NV_PRESERVES_UV)
# if defined(PERL_IN_SV_C)
@@ -5515,6 +5535,96 @@ PERL_CALLCONV char* Perl_my_bcopy(const char* from, char* to, I32 len)
assert(from); assert(to)
#endif
+#if defined(ALWAYS_NEED_THX)
+PERL_CALLCONV PADNAMELIST * Perl_newPADNAMELIST(pTHX_ size_t max)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+PERL_CALLCONV PADNAME * Perl_newPADNAMEouter(pTHX_ PADNAME *outer)
+ __attribute__malloc__
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_NEWPADNAMEOUTER \
+ assert(outer)
+
+PERL_CALLCONV PADNAME * Perl_newPADNAMEpvn(pTHX_ const char *s, STRLEN len)
+ __attribute__malloc__
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_NEWPADNAMEPVN \
+ assert(s)
+
+/* PERL_CALLCONV Malloc_t Perl_safesyscalloc(MEM_SIZE elements, MEM_SIZE size)
+ __attribute__malloc__
+ __attribute__warn_unused_result__; */
+
+PERL_CALLCONV Malloc_t Perl_safesyscalloc(PerlInterpreter *my_perl, MEM_SIZE elements, MEM_SIZE size)
+ __attribute__malloc__
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_SAFESYSCALLOC \
+ assert(my_perl)
+
+PERL_CALLCONV Malloc_t Perl_safesyscalloc_nocontext(MEM_SIZE elements, MEM_SIZE size)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+/* PERL_CALLCONV Free_t Perl_safesysfree(Malloc_t where); */
+PERL_CALLCONV Free_t Perl_safesysfree(PerlInterpreter *my_perl, Malloc_t where)
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_SAFESYSFREE \
+ assert(my_perl)
+
+PERL_CALLCONV Free_t Perl_safesysfree_nocontext(Malloc_t where);
+/* PERL_CALLCONV Malloc_t Perl_safesysmalloc(MEM_SIZE nbytes)
+ __attribute__malloc__
+ __attribute__warn_unused_result__; */
+
+PERL_CALLCONV Malloc_t Perl_safesysmalloc(PerlInterpreter *my_perl, MEM_SIZE nbytes)
+ __attribute__malloc__
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_SAFESYSMALLOC \
+ assert(my_perl)
+
+PERL_CALLCONV Malloc_t Perl_safesysmalloc_nocontext(MEM_SIZE nbytes)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+/* PERL_CALLCONV Malloc_t Perl_safesysrealloc(Malloc_t where, MEM_SIZE nbytes)
+ __attribute__malloc__
+ __attribute__warn_unused_result__; */
+
+PERL_CALLCONV Malloc_t Perl_safesysrealloc(PerlInterpreter *my_perl, Malloc_t where, MEM_SIZE nbytes)
+ __attribute__malloc__
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_SAFESYSREALLOC \
+ assert(my_perl)
+
+PERL_CALLCONV Malloc_t Perl_safesysrealloc_nocontext(Malloc_t where, MEM_SIZE nbytes)
+ __attribute__malloc__
+ __attribute__warn_unused_result__;
+
+# if defined(PERL_IN_HV_C)
+STATIC HEK* S_save_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags)
+ __attribute__malloc__
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SAVE_HEK_FLAGS \
+ assert(str)
+
+# endif
+# if defined(PERL_IN_REGCOMP_C)
+STATIC U32 S_add_data(pTHX_ RExC_state_t* const pRExC_state, const char* const s, const U32 n)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_ADD_DATA \
+ assert(pRExC_state); assert(s)
+
+# endif
+#endif
#if defined(DEBUGGING)
PERL_CALLCONV int Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
__attribute__warn_unused_result__
@@ -6193,13 +6303,6 @@ STATIC SV * S_refcounted_he_value(pTHX_ const struct refcounted_he *he)
#define PERL_ARGS_ASSERT_REFCOUNTED_HE_VALUE \
assert(he)
-STATIC HEK* S_save_hek_flags(const char *str, I32 len, U32 hash, int flags)
- __attribute__malloc__
- __attribute__warn_unused_result__
- __attribute__nonnull__(1);
-#define PERL_ARGS_ASSERT_SAVE_HEK_FLAGS \
- assert(str)
-
STATIC HEK* S_share_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags)
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
@@ -6895,13 +6998,6 @@ STATIC void S_add_above_Latin1_folds(pTHX_ RExC_state_t *pRExC_state, const U8 c
PERL_STATIC_INLINE SV* S_add_cp_to_invlist(pTHX_ SV* invlist, const UV cp)
__attribute__warn_unused_result__;
-STATIC U32 S_add_data(RExC_state_t* const pRExC_state, const char* const s, const U32 n)
- __attribute__warn_unused_result__
- __attribute__nonnull__(1)
- __attribute__nonnull__(2);
-#define PERL_ARGS_ASSERT_ADD_DATA \
- assert(pRExC_state); assert(s)
-
STATIC AV* S_add_multi_match(pTHX_ AV* multi_char_matches, SV* multi_string, const STRLEN cp_count)
__attribute__nonnull__(pTHX_2);
#define PERL_ARGS_ASSERT_ADD_MULTI_MATCH \
diff --git a/regcomp.c b/regcomp.c
index 901e2c0..3fd1c9f 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -267,6 +267,8 @@ struct RExC_state_t {
#define RExC_frame_count (pRExC_state->frame_count)
#define RExC_strict (pRExC_state->strict)
+#define add_data(pRExC_state, str_and_len) S_add_data(aMEMTHX_ pRExC_state, str_and_len)
+
/* Heuristic check on the complexity of the pattern: if TOO_NAUGHTY, we set
* a flag to disable back-off on the fixed/floating substrings - if it's
* a high complexity pattern we assume the benefit of avoiding a full match
@@ -5646,7 +5648,7 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVuf" RHS=%"UVuf"\n",
}
STATIC U32
-S_add_data(RExC_state_t* const pRExC_state, const char* const s, const U32 n)
+S_add_data(pMEMTHX_ RExC_state_t* const pRExC_state, const char* const s, const U32 n)
{
U32 count = RExC_rxi->data ? RExC_rxi->data->count : 0;
@@ -8069,6 +8071,7 @@ PERL_STATIC_INLINE void
S_invlist_trim(SV* const invlist)
{
PERL_ARGS_ASSERT_INVLIST_TRIM;
+ dTHX;
assert(SvTYPE(invlist) == SVt_INVLIST);
@@ -10230,7 +10233,7 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
RExC_rxi->data->data[n+1] = (void*)o;
}
else {
- n = add_data(pRExC_state,
+ n = S_add_data(aMEMTHX_ pRExC_state,
(RExC_pm_flags & PMf_HAS_CV) ? "L" : "l", 1);
RExC_rxi->data->data[n] = (void*)o;
}
diff --git a/sv.c b/sv.c
index ae5bba3..853817f 100644
--- a/sv.c
+++ b/sv.c
@@ -15081,6 +15081,7 @@ Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to)
PERL_SET_THX(to);
}
+#define my_perl to
/* Given that we've set the context, we can do this unshared. */
Newx(param, 1, CLONE_PARAMS);
@@ -15094,6 +15095,7 @@ Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to)
if (was != to) {
PERL_SET_THX(was);
}
+#undef my_perl
return param;
}
diff --git a/util.c b/util.c
index 607f480..db4bbfe 100644
--- a/util.c
+++ b/util.c
@@ -81,10 +81,6 @@ int putenv(char *);
* XXX This advice seems to be widely ignored :-( --AD August 1996.
*/
-#if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL)
-# define ALWAYS_NEED_THX
-#endif
-
#if defined(PERL_TRACK_MEMPOOL) && defined(PERL_DEBUG_READONLY_COW)
static void
S_maybe_protect_rw(pTHX_ struct perl_memory_debug_header *header)
@@ -122,12 +118,10 @@ S_maybe_protect_ro(pTHX_ struct perl_memory_debug_header *header)
/* paranoid version of system's malloc() */
Malloc_t
-Perl_safesysmalloc(MEM_SIZE size)
+Perl_safesysmalloc(pMEMTHX_ MEM_SIZE size)
{
-#ifdef ALWAYS_NEED_THX
- dTHX;
-#endif
Malloc_t ptr;
+ PERL_ARGS_ASSERT_SAFESYSMALLOC;
#ifdef USE_MDH
if (size + PERL_MEMORY_DEBUG_HEADER_SIZE < size)
@@ -199,17 +193,15 @@ Perl_safesysmalloc(MEM_SIZE size)
/* paranoid version of system's realloc() */
Malloc_t
-Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
+Perl_safesysrealloc(pMEMTHX_ Malloc_t where,MEM_SIZE size)
{
-#ifdef ALWAYS_NEED_THX
- dTHX;
-#endif
Malloc_t ptr;
#ifdef PERL_DEBUG_READONLY_COW
const MEM_SIZE oldsize = where
? ((struct perl_memory_debug_header *)((char *)where - PERL_MEMORY_DEBUG_HEADER_SIZE))->size
: 0;
#endif
+ PERL_ARGS_ASSERT_SAFESYSREALLOC;
#if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
Malloc_t PerlMem_realloc();
#endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
@@ -324,11 +316,9 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
/* safe version of system's free() */
Free_t
-Perl_safesysfree(Malloc_t where)
+Perl_safesysfree(pMEMTHX_ Malloc_t where)
{
-#ifdef ALWAYS_NEED_THX
- dTHX;
-#endif
+ PERL_ARGS_ASSERT_SAFESYSFREE;
DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
if (where) {
#ifdef USE_MDH
@@ -389,15 +379,13 @@ Perl_safesysfree(Malloc_t where)
/* safe version of system's calloc() */
Malloc_t
-Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
+Perl_safesyscalloc(pMEMTHX_ MEM_SIZE count, MEM_SIZE size)
{
-#ifdef ALWAYS_NEED_THX
- dTHX;
-#endif
Malloc_t ptr;
#if defined(USE_MDH) || defined(DEBUGGING)
MEM_SIZE total_size = 0;
#endif
+ PERL_ARGS_ASSERT_SAFESYSCALLOC;
/* Even though calloc() for zero bytes is strange, be robust. */
if (size && (count <= MEM_SIZE_MAX / size)) {
@@ -479,6 +467,38 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
}
}
+
+#ifdef ALWAYS_NEED_THX
+Malloc_t
+Perl_safesysmalloc_nocontext(MEM_SIZE size)
+{
+ dTHX;
+ return Perl_safesysmalloc(aTHX_ size);
+}
+
+Malloc_t
+Perl_safesysrealloc_nocontext(Malloc_t where,MEM_SIZE size)
+{
+ dTHX;
+ return Perl_safesysrealloc(aTHX_ where, size);
+}
+
+Free_t
+Perl_safesysfree_nocontext(Malloc_t where)
+{
+ dTHX;
+ return Perl_safesysfree(aTHX_ where);
+}
+
+Malloc_t
+Perl_safesyscalloc_nocontext(MEM_SIZE count, MEM_SIZE size)
+{
+ dTHX;
+ return Perl_safesyscalloc(aTHX_ count, size);
+}
+
+#endif
+
/* These must be defined when not using Perl's malloc for binary
* compatibility */
diff --git a/win32/perlhost.h b/win32/perlhost.h
index b0b3692..9853b47 100644
--- a/win32/perlhost.h
+++ b/win32/perlhost.h
@@ -2223,6 +2223,7 @@ CPerlHost::CalculateEnvironmentSpace(void)
void
CPerlHost::FreeLocalEnvironmentStrings(LPSTR lpStr)
{
+ dTHXa(host_perl);
Safefree(lpStr);
}
@@ -2231,6 +2232,7 @@ CPerlHost::GetChildDir(void)
{
char* ptr;
size_t length;
+ dTHXa(host_perl);
Newx(ptr, MAX_PATH+1, char);
m_pvDir->GetCurrentDirectoryA(MAX_PATH+1, ptr);
@@ -2245,6 +2247,7 @@ CPerlHost::GetChildDir(void)
void
CPerlHost::FreeChildDir(char* pStr)
{
+ dTHXa(host_perl);
Safefree(pStr);
}
@@ -2275,6 +2278,7 @@ CPerlHost::CreateLocalEnvironmentStrings(VDir &vDir)
// add the additional space used by changes made to the environment
dwSize += CalculateEnvironmentSpace();
+ dTHXa(host_perl);
Newx(lpStr, dwSize, char);
lpPtr = lpStr;
if(lpStr != NULL) {
diff --git a/win32/win32.c b/win32/win32.c
index 48723bf..e224822 100644
--- a/win32/win32.c
+++ b/win32/win32.c
@@ -533,6 +533,7 @@ tokenize(const char *str, char **dest, char ***destv)
int slen = strlen(str);
char *ret;
char **retv;
+ dTHX;
Newx(ret, slen+2, char);
Newx(retv, (slen+3)/2, char*);
@@ -825,6 +826,7 @@ win32_opendir(const char *filename)
return NULL;
}
+ aTHXa(PERL_GET_THX);
/* Get us a DIR structure */
Newxz(dirp, 1, DIR);
@@ -844,7 +846,6 @@ win32_opendir(const char *filename)
/* do the FindFirstFile call */
MultiByteToWideChar(CP_ACP, 0, scanname, -1, wscanname, sizeof(wscanname)/sizeof(WCHAR));
- aTHXa(PERL_GET_THX);
dirp->handle = FindFirstFileW(PerlDir_mapW(wscanname), &wFindData);
if (dirp->handle == INVALID_HANDLE_VALUE) {
@@ -940,6 +941,7 @@ win32_readdir(DIR *dirp)
}
}
if (res) {
+ dTHX;
long endpos = dirp->end - dirp->start;
long newsize = endpos + strlen(buffer) + 1;
/* bump the string table size by enough for the
@@ -996,6 +998,7 @@ win32_rewinddir(DIR *dirp)
DllExport int
win32_closedir(DIR *dirp)
{
+ dTHX;
if (dirp->handle != INVALID_HANDLE_VALUE)
FindClose(dirp->handle);
Safefree(dirp->start);
@@ -1035,11 +1038,13 @@ win32_dirp_dup(DIR *const dirp, CLONE_PARAMS *const param)
PERL_SET_THX(to);
}
+#define my_perl to
Newx(dup, 1, DIR);
memcpy(dup, dirp, sizeof(DIR));
Newx(dup->start, dirp->size, char);
memcpy(dup->start, dirp->start, dirp->size);
+#undef my_perl
dup->end = dup->start + (dirp->end - dirp->start);
if (dirp->curr)
@@ -3393,7 +3398,11 @@ win32_chmod(const char *path, int mode)
static char *
create_command_line(char *cname, STRLEN clen, const char * const *args)
{
+#ifdef ALWAYS_NEED_THX
+ dTHX;
+#else
PERL_DEB(dTHX;)
+#endif
int index, argc;
char *cmd, *ptr;
const char *arg;
@@ -3557,6 +3566,9 @@ qualified_path(const char *cmd, bool other_exts)
{
char *pathstr;
char *fullcmd, *curfullcmd;
+#ifdef ALWAYS_NEED_THX
+ dTHX;
+#endif
STRLEN cmdlen = 0;
int has_slash = 0;
@@ -3572,7 +3584,9 @@ qualified_path(const char *cmd, bool other_exts)
/* look in PATH */
{
+#ifndef ALWAYS_NEED_THX
dTHX;
+#endif
pathstr = PerlEnv_getenv("PATH");
}
/* worst case: PATH is a single directory; we need additional space
@@ -3688,6 +3702,9 @@ win32_get_childdir(void)
{
char* ptr;
char szfilename[MAX_PATH+1];
+#ifdef ALWAYS_NEED_THX
+ dTHX;
+#endif
GetCurrentDirectoryA(MAX_PATH+1, szfilename);
Newx(ptr, strlen(szfilename)+1, char);
@@ -3698,6 +3715,9 @@ win32_get_childdir(void)
DllExport void
win32_free_childdir(char* d)
{
+#ifdef ALWAYS_NEED_THX
+ dTHX;
+#endif
Safefree(d);
}
@@ -3738,7 +3758,7 @@ do_spawnvp_handles(int mode, const char *cmdname, const char *const *argv,
char *fullcmd = NULL;
char *cname = (char *)cmdname;
STRLEN clen = 0;
-
+ aTHXa(PERL_GET_THX);
if (cname) {
clen = strlen(cname);
/* if command name contains dquotes, must remove them */
@@ -3759,7 +3779,6 @@ do_spawnvp_handles(int mode, const char *cmdname, const char *const *argv,
cmd = create_command_line(cname, clen, argv);
- aTHXa(PERL_GET_THX);
env = PerlEnv_get_childenv();
dir = PerlEnv_get_childdir();
--
1.9.5.msysgit.1
|
From @tonycozOn Tue Aug 04 20:16:28 2015, bulk88 wrote:
Did you consider trying to speed up the Win32 PERL_GET_CONTEXT instead (or as well)? I see what appears to be an unused[1] implementation using __declspec(thread), which is presumably cheaper, using the TIB via fs (or gs on 64-bit). If that were inlined instead, you pthread builds call pthread_getspecific() directly, avoiding the extra cost of calling Perl_get_context(). Do your changes result in measurable performance improvement? (or early days yet?) Tony [1] and broken, using different names for the definitions and uses |
|
The RT System itself - Status changed from 'new' to 'open' |
|
@bulk88 now we're on github, could you please submit this as a PR if you want to pursue it further? |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
Migrated from rt.perl.org#125751 (status was 'open')
Searchable as RT125751$
The text was updated successfully, but these errors were encountered: