#ifdef MDH_HAS_SIZE
header->size = size;
#endif
- ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
+ ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
- return ptr;
-}
+
+ }
else {
#ifndef ALWAYS_NEED_THX
dTHX;
#endif
if (PL_nomemok)
- return NULL;
- else {
+ ptr = NULL;
+ else
croak_no_mem();
- }
}
- /*NOTREACHED*/
+ return ptr;
}
/* paranoid version of system's realloc() */
if (!size) {
safesysfree(where);
- return NULL;
+ ptr = NULL;
}
-
- if (!where)
- return safesysmalloc(size);
+ else if (!where) {
+ ptr = safesysmalloc(size);
+ }
+ else {
#ifdef USE_MDH
- where = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
- size += PERL_MEMORY_DEBUG_HEADER_SIZE;
- {
- struct perl_memory_debug_header *const header
- = (struct perl_memory_debug_header *)where;
+ where = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
+ size += PERL_MEMORY_DEBUG_HEADER_SIZE;
+ {
+ struct perl_memory_debug_header *const header
+ = (struct perl_memory_debug_header *)where;
# ifdef PERL_TRACK_MEMPOOL
- if (header->interpreter != aTHX) {
- Perl_croak_nocontext("panic: realloc from wrong pool, %p!=%p",
- header->interpreter, aTHX);
- }
- assert(header->next->prev == header);
- assert(header->prev->next == header);
+ if (header->interpreter != aTHX) {
+ Perl_croak_nocontext("panic: realloc from wrong pool, %p!=%p",
+ header->interpreter, aTHX);
+ }
+ assert(header->next->prev == header);
+ assert(header->prev->next == header);
# ifdef PERL_POISON
- if (header->size > size) {
- const MEM_SIZE freed_up = header->size - size;
- char *start_of_freed = ((char *)where) + size;
- PoisonFree(start_of_freed, freed_up, char);
- }
+ if (header->size > size) {
+ const MEM_SIZE freed_up = header->size - size;
+ char *start_of_freed = ((char *)where) + size;
+ PoisonFree(start_of_freed, freed_up, char);
+ }
# endif
# endif
# ifdef MDH_HAS_SIZE
- header->size = size;
+ header->size = size;
# endif
- }
+ }
#endif
#ifdef DEBUGGING
- if ((SSize_t)size < 0)
- Perl_croak_nocontext("panic: realloc, size=%"UVuf, (UV)size);
+ if ((SSize_t)size < 0)
+ Perl_croak_nocontext("panic: realloc, size=%"UVuf, (UV)size);
#endif
#ifdef PERL_DEBUG_READONLY_COW
- if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE,
- MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
- perror("mmap failed");
- abort();
- }
- Copy(where,ptr,oldsize < size ? oldsize : size,char);
- if (munmap(where, oldsize)) {
- perror("munmap failed");
- abort();
- }
+ if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE,
+ MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
+ perror("mmap failed");
+ abort();
+ }
+ Copy(where,ptr,oldsize < size ? oldsize : size,char);
+ if (munmap(where, oldsize)) {
+ perror("munmap failed");
+ abort();
+ }
#else
- ptr = (Malloc_t)PerlMem_realloc(where,size);
+ ptr = (Malloc_t)PerlMem_realloc(where,size);
#endif
- PERL_ALLOC_CHECK(ptr);
+ PERL_ALLOC_CHECK(ptr);
/* MUST do this fixup first, before doing ANYTHING else, as anything else
might allocate memory/free/move memory, and until we do the fixup, it
may well be chasing (and writing to) free memory. */
- if (ptr != NULL) {
+ if (ptr != NULL) {
#ifdef PERL_TRACK_MEMPOOL
- struct perl_memory_debug_header *const header
- = (struct perl_memory_debug_header *)ptr;
+ struct perl_memory_debug_header *const header
+ = (struct perl_memory_debug_header *)ptr;
# ifdef PERL_POISON
- if (header->size < size) {
- const MEM_SIZE fresh = size - header->size;
- char *start_of_fresh = ((char *)ptr) + size;
- PoisonNew(start_of_fresh, fresh, char);
- }
+ if (header->size < size) {
+ const MEM_SIZE fresh = size - header->size;
+ char *start_of_fresh = ((char *)ptr) + size;
+ PoisonNew(start_of_fresh, fresh, char);
+ }
# endif
- maybe_protect_rw(header->next);
- header->next->prev = header;
- maybe_protect_ro(header->next);
- maybe_protect_rw(header->prev);
- header->prev->next = header;
- maybe_protect_ro(header->prev);
+ maybe_protect_rw(header->next);
+ header->next->prev = header;
+ maybe_protect_ro(header->next);
+ maybe_protect_rw(header->prev);
+ header->prev->next = header;
+ maybe_protect_ro(header->prev);
#endif
- ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
- }
+ ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
+ }
/* In particular, must do that fixup above before logging anything via
*printf(), as it can reallocate memory, which can cause SEGVs. */
- DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
- DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
-
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
- if (ptr != NULL) {
- return ptr;
- }
- else {
+ if (ptr == NULL) {
#ifndef ALWAYS_NEED_THX
- dTHX;
+ dTHX;
#endif
- if (PL_nomemok)
- return NULL;
- else {
- croak_no_mem();
+ if (PL_nomemok)
+ ptr = NULL;
+ else
+ croak_no_mem();
}
}
- /*NOTREACHED*/
+ return ptr;
}
/* safe version of system's free() */
DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
if (where) {
#ifdef USE_MDH
- where = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
+ Malloc_t where_intrn = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
{
struct perl_memory_debug_header *const header
- = (struct perl_memory_debug_header *)where;
+ = (struct perl_memory_debug_header *)where_intrn;
# ifdef MDH_HAS_SIZE
const MEM_SIZE size = header->size;
maybe_protect_ro(header->prev);
maybe_protect_rw(header);
# ifdef PERL_POISON
- PoisonNew(where, size, char);
+ PoisonNew(where_intrn, size, char);
# endif
/* Trigger the duplicate free warning. */
header->next = NULL;
# endif
# ifdef PERL_DEBUG_READONLY_COW
- if (munmap(where, size)) {
+ if (munmap(where_intrn, size)) {
perror("munmap failed");
abort();
}
# endif
}
-#endif
+#else
+ Malloc_t where_intrn = where;
+#endif /* USE_MDH */
#ifndef PERL_DEBUG_READONLY_COW
- PerlMem_free(where);
+ PerlMem_free(where_intrn);
#endif
}
}
}
}
-char *
-Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
-{
- PERL_ARGS_ASSERT_SCREAMINSTR;
- PERL_UNUSED_ARG(bigstr);
- PERL_UNUSED_ARG(littlestr);
- PERL_UNUSED_ARG(start_shift);
- PERL_UNUSED_ARG(end_shift);
- PERL_UNUSED_ARG(old_posp);
- PERL_UNUSED_ARG(last);
-
- /* This function must only ever be called on a scalar with study magic,
- but those do not happen any more. */
- Perl_croak(aTHX_ "panic: screaminstr");
- NORETURN_FUNCTION_END;
-}
-
/*
=for apidoc foldEQ
if (o->op_flags & OPf_KIDS) {
const OP *kid;
- for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) {
+ for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
const COP *new_cop;
/* If the OP_NEXTSTATE has been optimised away we can still use it
*/
const COP *cop =
- closest_cop(PL_curcop, OP_SIBLING(PL_curcop), PL_op, FALSE);
+ closest_cop(PL_curcop, OpSIBLING(PL_curcop), PL_op, FALSE);
if (!cop)
cop = PL_curcop;
=cut
*/
+#ifdef _MSC_VER
+# pragma warning( push )
+# pragma warning( disable : 4646 ) /* warning C4646: function declared with
+ __declspec(noreturn) has non-void return type */
+# pragma warning( disable : 4645 ) /* warning C4645: function declared with
+__declspec(noreturn) has a return statement */
+#endif
OP *
Perl_die_sv(pTHX_ SV *baseex)
{
PERL_ARGS_ASSERT_DIE_SV;
croak_sv(baseex);
- assert(0); /* NOTREACHED */
+ /* NOTREACHED */
NORETURN_FUNCTION_END;
}
+#ifdef _MSC_VER
+# pragma warning( pop )
+#endif
/*
=for apidoc Am|OP *|die|const char *pat|...
*/
#if defined(PERL_IMPLICIT_CONTEXT)
+#ifdef _MSC_VER
+# pragma warning( push )
+# pragma warning( disable : 4646 ) /* warning C4646: function declared with
+ __declspec(noreturn) has non-void return type */
+# pragma warning( disable : 4645 ) /* warning C4645: function declared with
+__declspec(noreturn) has a return statement */
+#endif
OP *
Perl_die_nocontext(const char* pat, ...)
{
va_list args;
va_start(args, pat);
vcroak(pat, &args);
- assert(0); /* NOTREACHED */
+ NOT_REACHED; /* NOTREACHED */
va_end(args);
NORETURN_FUNCTION_END;
}
+#ifdef _MSC_VER
+# pragma warning( pop )
+#endif
#endif /* PERL_IMPLICIT_CONTEXT */
+#ifdef _MSC_VER
+# pragma warning( push )
+# pragma warning( disable : 4646 ) /* warning C4646: function declared with
+ __declspec(noreturn) has non-void return type */
+# pragma warning( disable : 4645 ) /* warning C4645: function declared with
+__declspec(noreturn) has a return statement */
+#endif
OP *
Perl_die(pTHX_ const char* pat, ...)
{
va_list args;
va_start(args, pat);
vcroak(pat, &args);
- assert(0); /* NOTREACHED */
+ NOT_REACHED; /* NOTREACHED */
va_end(args);
NORETURN_FUNCTION_END;
}
+#ifdef _MSC_VER
+# pragma warning( pop )
+#endif
/*
=for apidoc Am|void|croak_sv|SV *baseex
va_list args;
va_start(args, pat);
vcroak(pat, &args);
- assert(0); /* NOTREACHED */
+ NOT_REACHED; /* NOTREACHED */
va_end(args);
}
#endif /* PERL_IMPLICIT_CONTEXT */
va_list args;
va_start(args, pat);
vcroak(pat, &args);
- assert(0); /* NOTREACHED */
+ NOT_REACHED; /* NOTREACHED */
va_end(args);
}
#endif /* PERL_IMPLICIT_CONTEXT */
-/* The meaning of the varargs is determined U32 key arg. This is not a format
- string. The U32 key is assembled with HS_KEY.
-
- v_my_perl arg is "PerlInterpreter * my_perl" if PERL_IMPLICIT_CONTEXT and
- otherwise "CV * cv" (boot xsub's CV *). v_my_perl will catch where a threaded
- future perl526.dll calling IO.dll for example, and IO.dll was linked with
- threaded perl524.dll, and both perl526.dll and perl524.dll are in %PATH and
- the Win32 DLL loader sucessfully can load IO.dll into the process but
- simultaniously it loaded a interp of a different version into the process,
- and XS code will naturally pass SV*s created by perl524.dll for perl526.dll
- to use through perl526.dll's my_perl->Istack_base.
-
- v_my_perl (v=void) can not be the first arg since then key will be out of
- place in a threaded vs non-threaded mixup and analyzing the key number's
- bitfields won't reveal the problem since it will be a valid key
- (unthreaded perl) on interp side, but croak reports the XS mod's key as
- gibberish (it is really my_perl ptr) (threaded XS mod), or if threaded perl
- and unthreaded XS module, threaded perl will look at uninit C stack or uninit
- register to get var key (remember it assumes 1st arg is interp cxt).
+/* Perl_xs_handshake():
+ implement the various XS_*_BOOTCHECK macros, which are added to .c
+ files by ExtUtils::ParseXS, to check that the perl the module was built
+ with is binary compatible with the running perl.
+
+ usage:
+ Perl_xs_handshake(U32 key, void * v_my_perl, const char * file,
+ [U32 items, U32 ax], [char * api_version], [char * xs_version])
+
+ The meaning of the varargs is determined the U32 key arg (which is not
+ a format string). The fields of key are assembled by using HS_KEY().
+
+ Under PERL_IMPLICIT_CONTEX, the v_my_perl arg is of type
+ "PerlInterpreter *" and represents the callers context; otherwise it is
+ of type "CV *", and is the boot xsub's CV.
+
+ v_my_perl will catch where a threaded future perl526.dll calling IO.dll
+ for example, and IO.dll was linked with threaded perl524.dll, and both
+ perl526.dll and perl524.dll are in %PATH and the Win32 DLL loader
+ successfully can load IO.dll into the process but simultaneously it
+ loaded an interpreter of a different version into the process, and XS
+ code will naturally pass SV*s created by perl524.dll for perl526.dll to
+ use through perl526.dll's my_perl->Istack_base.
+
+ v_my_perl cannot be the first arg, since then 'key' will be out of
+ place in a threaded vs non-threaded mixup; and analyzing the key
+ number's bitfields won't reveal the problem, since it will be a valid
+ key (unthreaded perl) on interp side, but croak will report the XS mod's
+ key as gibberish (it is really a my_perl ptr) (threaded XS mod); or if
+ it's a threaded perl and an unthreaded XS module, threaded perl will
+ look at an uninit C stack or an uninit register to get 'key'
+ (remember that it assumes that the 1st arg is the interp cxt).
+
+ 'file' is the source filename of the caller.
+*/
-Perl_xs_handshake(U32 key, void * v_my_perl, [U32 items, U32 ax], [char * api_version], [char * xs_version]) */
I32
-Perl_xs_handshake(const U32 key, void * v_my_perl, ...)
+Perl_xs_handshake(const U32 key, void * v_my_perl, const char * file, ...)
{
va_list args;
U32 items, ax;
+ void * got;
+ void * need;
#ifdef PERL_IMPLICIT_CONTEXT
dTHX;
+ tTHX xs_interp;
+#else
+ CV* cv;
+ SV *** xs_spp;
#endif
PERL_ARGS_ASSERT_XS_HANDSHAKE;
- va_start(args, v_my_perl);
+ va_start(args, file);
- if((key & HSm_KEY_MATCH) != (HS_KEY(FALSE, "", "") & HSm_KEY_MATCH))
- noperl_die("BOOT:: Invalid handshake key got %X needed %X"
- ", binaries are mismatched", (key & HSm_KEY_MATCH)
- , (HS_KEY(FALSE, "", "") & HSm_KEY_MATCH));
+ got = INT2PTR(void*, (UV)(key & HSm_KEY_MATCH));
+ need = (void *)(HS_KEY(FALSE, FALSE, "", "") & HSm_KEY_MATCH);
+ if (UNLIKELY(got != need))
+ goto bad_handshake;
/* try to catch where a 2nd threaded perl interp DLL is loaded into a process
by a XS DLL compiled against the wrong interl DLL b/c of bad @INC, and the
2nd threaded perl interp DLL never initialized its TLS/PERL_SYS_INIT3 so
dTHX call from 2nd interp DLL can't return the my_perl that pp_entersub
passed to the XS DLL */
- {
- void * got;
- void * need;
#ifdef PERL_IMPLICIT_CONTEXT
- tTHX xs_interp = (tTHX)v_my_perl;
- got = xs_interp;
- need = my_perl;
+ xs_interp = (tTHX)v_my_perl;
+ got = xs_interp;
+ need = my_perl;
#else
/* try to catch where an unthreaded perl interp DLL (for ex. perl522.dll) is
loaded into a process by a XS DLL built by an unthreaded perl522.dll perl,
through pp_entersub, use a unique value (which is a pointer to PL_stack_sp's
location in the unthreaded perl binary) stored in CV * to figure out if this
Perl_xs_handshake was called by the same pp_entersub */
- CV* cv = (CV*)v_my_perl;
- SV *** xs_spp = (SV***)CvHSCXT(cv);
- got = xs_spp;
- need = &PL_stack_sp;
+ cv = (CV*)v_my_perl;
+ xs_spp = (SV***)CvHSCXT(cv);
+ got = xs_spp;
+ need = &PL_stack_sp;
#endif
- if(got != need)/* recycle branch and string from above */
- noperl_die("BOOT:: Invalid handshake key got %X needed %X"
- ", binaries are mismatched", got, need);
+ if(UNLIKELY(got != need)) {
+ bad_handshake:/* recycle branch and string from above */
+ if(got != (void *)HSf_NOCHK)
+ noperl_die("%s: loadable library and perl binaries are mismatched"
+ " (got handshake key %p, needed %p)\n",
+ file, got, need);
+ }
+
+ if(key & HSf_SETXSUBFN) { /* this might be called from a module bootstrap */
+ SAVEPPTR(PL_xsubfilename);/* which was require'd from a XSUB BEGIN */
+ PL_xsubfilename = file; /* so the old name must be restored for
+ additional XSUBs to register themselves */
+ (void)gv_fetchfile(file);
}
if(key & HSf_POPMARK) {
{
U32 apiverlen;
assert(HS_GETAPIVERLEN(key) <= UCHAR_MAX);
- if(apiverlen = HS_GETAPIVERLEN(key)) {
+ if((apiverlen = HS_GETAPIVERLEN(key))) {
char * api_p = va_arg(args, char*);
if(apiverlen != sizeof("v" PERL_API_VERSION_STRING)-1
|| memNE(api_p, "v" PERL_API_VERSION_STRING,
{
U32 xsverlen;
assert(HS_GETXSVERLEN(key) <= UCHAR_MAX && HS_GETXSVERLEN(key) <= HS_APIVERLEN_MAX);
- if(xsverlen = HS_GETXSVERLEN(key))
- Perl_xs_version_bootcheck(aTHX_
+ if((xsverlen = HS_GETXSVERLEN(key)))
+ S_xs_version_bootcheck(aTHX_
items, ax, va_arg(args, char*), xsverlen);
}
va_end(args);
return ax;
}
-void
-Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
+
+STATIC void
+S_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
STRLEN xs_len)
{
SV *sv;
return dir->dd_fd;
#else
Perl_croak_nocontext(PL_no_func, "dirfd");
- assert(0); /* NOT REACHED */
+ NOT_REACHED; /* NOT REACHED */
return 0;
#endif
}
/* BFD open and scan only if the filename changed. */
if (ctx->fname_prev == NULL ||
strNE(dl_info->dli_fname, ctx->fname_prev)) {
+ if (ctx->abfd) {
+ bfd_close(ctx->abfd);
+ }
ctx->abfd = bfd_openr(dl_info->dli_fname, 0);
if (ctx->abfd) {
if (bfd_check_format(ctx->abfd, bfd_object)) {
}
#ifdef USE_BFD
Safefree(symbol_names);
+ if (bfd_ctx.abfd) {
+ bfd_close(bfd_ctx.abfd);
+ }
#endif
Safefree(source_lines);
Safefree(source_name_sizes);
https://perl5.git.perl.org / perl5.git / blobdiff