X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/6edcbed6404ee551719c9a49397baea538aae7cc..a3be5ee7857e3bd21db692b2200f237c8d791830:/util.c diff --git a/util.c b/util.c index 4ee17c2..67136fe 100644 --- a/util.c +++ b/util.c @@ -170,24 +170,20 @@ Perl_safesysmalloc(MEM_SIZE size) #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)); - ret: - return ptr; -} + + } else { #ifndef ALWAYS_NEED_THX dTHX; #endif - if (PL_nomemok){ - ptr = NULL; - goto ret; - } - else { + if (PL_nomemok) + ptr = NULL; + else croak_no_mem(); - } } - /*NOTREACHED*/ + return ptr; } /* paranoid version of system's realloc() */ @@ -211,110 +207,101 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) if (!size) { safesysfree(where); ptr = NULL; - goto ret; } - - if (!where) { + else if (!where) { ptr = safesysmalloc(size); - goto ret; } + 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) { - ret: - return ptr; - } - else { + if (ptr == NULL) { #ifndef ALWAYS_NEED_THX - dTHX; + dTHX; #endif - if (PL_nomemok){ - ptr = NULL; - goto ret; - } - else { - croak_no_mem(); + if (PL_nomemok) + ptr = NULL; + else + croak_no_mem(); } } - /*NOTREACHED*/ + return ptr; } /* safe version of system's free() */ @@ -926,23 +913,6 @@ Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U } } -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 @@ -1334,7 +1304,7 @@ Perl_closest_cop(pTHX_ const COP *cop, const OP *o, const OP *curop, 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 @@ -1427,7 +1397,7 @@ Perl_mess_sv(pTHX_ SV *basemsg, bool consume) */ 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; @@ -1574,14 +1544,24 @@ The function never actually returns. =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|... @@ -1594,6 +1574,13 @@ The function never actually returns. */ #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, ...) { @@ -1601,22 +1588,35 @@ 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 @@ -1713,7 +1713,7 @@ Perl_croak_nocontext(const char *pat, ...) va_list args; va_start(args, pat); vcroak(pat, &args); - assert(0); /* NOTREACHED */ + NOT_REACHED; /* NOTREACHED */ va_end(args); } #endif /* PERL_IMPLICIT_CONTEXT */ @@ -1724,7 +1724,7 @@ Perl_croak(pTHX_ const char *pat, ...) va_list args; va_start(args, pat); vcroak(pat, &args); - assert(0); /* NOTREACHED */ + NOT_REACHED; /* NOTREACHED */ va_end(args); } @@ -1944,8 +1944,13 @@ bool Perl_ckwarn(pTHX_ U32 w) { /* If lexical warnings have not been set, use $^W. */ - if (isLEXWARN_off) - return PL_dowarn & G_WARN_ON; + if (isLEXWARN_off) { + /* TODO: Hardcoding this here sucks, see the commit that added this */ + if (w == WARN_VOID_UNUSUAL) + return FALSE; + else + return PL_dowarn & G_WARN_ON; + } return ckwarn_common(w); } @@ -1956,8 +1961,13 @@ bool Perl_ckwarn_d(pTHX_ U32 w) { /* If lexical warnings have not been set then default classes warn. */ - if (isLEXWARN_off) - return TRUE; + if (isLEXWARN_off) { + /* TODO: Hardcoding this here sucks, see the commit that added this */ + if (w == WARN_VOID_UNUSUAL) + return FALSE; + else + return TRUE; + } return ckwarn_common(w); } @@ -1965,8 +1975,13 @@ Perl_ckwarn_d(pTHX_ U32 w) static bool S_ckwarn_common(pTHX_ U32 w) { - if (PL_curcop->cop_warnings == pWARN_ALL) - return TRUE; + if (PL_curcop->cop_warnings == pWARN_ALL) { + /* TODO: Hardcoding this here sucks, see the commit that added this */ + if (w == WARN_VOID_UNUSUAL) + return FALSE; + else + return TRUE; + } if (PL_curcop->cop_warnings == pWARN_NONE) return FALSE; @@ -5343,28 +5358,42 @@ Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size) #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(U32 key, void * v_my_perl, const char * file, -[U32 items, U32 ax], [char * api_version], [char * xs_version]) */ +/* 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. +*/ + I32 Perl_xs_handshake(const U32 key, void * v_my_perl, const char * file, ...) { @@ -5382,9 +5411,9 @@ Perl_xs_handshake(const U32 key, void * v_my_perl, const char * file, ...) PERL_ARGS_ASSERT_XS_HANDSHAKE; va_start(args, file); - got = (void *)(key & HSm_KEY_MATCH); + got = INT2PTR(void*, (UV)(key & HSm_KEY_MATCH)); need = (void *)(HS_KEY(FALSE, FALSE, "", "") & HSm_KEY_MATCH); - if(UNLIKELY(got != need)) + 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 @@ -5411,8 +5440,8 @@ Perl_xs_handshake(const U32 key, void * v_my_perl, const char * file, ...) if(UNLIKELY(got != need)) { bad_handshake:/* recycle branch and string from above */ if(got != (void *)HSf_NOCHK) - noperl_die("%s: Invalid handshake key got %p" - " needed %p, binaries are mismatched", + noperl_die("%s: loadable library and perl binaries are mismatched" + " (got handshake key %p, needed %p)\n", file, got, need); } @@ -5451,15 +5480,16 @@ Perl_xs_handshake(const U32 key, void * v_my_perl, const char * file, ...) U32 xsverlen; assert(HS_GETXSVERLEN(key) <= UCHAR_MAX && HS_GETXSVERLEN(key) <= HS_APIVERLEN_MAX); if((xsverlen = HS_GETXSVERLEN(key))) - Perl_xs_version_bootcheck(aTHX_ + 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; @@ -5661,7 +5691,7 @@ Perl_my_dirfd(DIR * dir) { return dir->dd_fd; #else Perl_croak_nocontext(PL_no_func, "dirfd"); - assert(0); /* NOT REACHED */ + NOT_REACHED; /* NOT REACHED */ return 0; #endif } @@ -5805,6 +5835,9 @@ static void bfd_update(bfd_context* ctx, Dl_info* dl_info) /* 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)) { @@ -6301,6 +6334,9 @@ Perl_get_c_backtrace(pTHX_ int depth, int skip) } #ifdef USE_BFD Safefree(symbol_names); + if (bfd_ctx.abfd) { + bfd_close(bfd_ctx.abfd); + } #endif Safefree(source_lines); Safefree(source_name_sizes);