X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/f6fb4e449c72e5609105e7d8bd9412b464d4f0fe..5fb413889777319544fb826f2cd3d8e78459b0a8:/util.c diff --git a/util.c b/util.c index cb7a5af..447a19f 100644 --- a/util.c +++ b/util.c @@ -551,20 +551,34 @@ Perl_delimcpy(char *to, const char *toend, const char *from, const char *fromend return (char *)from; } -/* return ptr to little string in big string, NULL if not found */ -/* This routine was donated by Corey Satten. */ +/* +=head1 Miscellaneous Functions -char * -Perl_instr(const char *big, const char *little) -{ +=for apidoc Am|char *|ninstr|char * big|char * bigend|char * little|char * little_end - PERL_ARGS_ASSERT_INSTR; +Find the first (leftmost) occurrence of a sequence of bytes within another +sequence. This is the Perl version of C, extended to handle +arbitrary sequences, potentially containing embedded C characters (C +is what the initial C in the function name stands for; some systems have an +equivalent, C, but with a somewhat different API). - return strstr((char*)big, (char*)little); -} +Another way of thinking about this function is finding a needle in a haystack. +C points to the first byte in the haystack. C points to one byte +beyond the final byte in the haystack. C points to the first byte in +the needle. C points to one byte beyond the final byte in the +needle. All the parameters must be non-C. + +The function returns C if there is no occurrence of C within +C. If C is the empty string, C is returned. -/* same as instr but allow embedded nulls. The end pointers point to 1 beyond - * the final character desired to be checked */ +Because this function operates at the byte level, and because of the inherent +characteristics of UTF-8 (or UTF-EBCDIC), it will work properly if both the +needle and the haystack are strings with the same UTF-8ness, but not if the +UTF-8ness differs. + +=cut + +*/ char * Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend) @@ -590,7 +604,18 @@ Perl_ninstr(const char *big, const char *bigend, const char *little, const char return NULL; } -/* reverse of the above--find last substring */ +/* +=head1 Miscellaneous Functions + +=for apidoc Am|char *|rninstr|char * big|char * bigend|char * little|char * little_end + +Like C>, but instead finds the final (rightmost) occurrence of a +sequence of bytes within another sequence, returning C if there is no +such occurrence. + +=cut + +*/ char * Perl_rninstr(const char *big, const char *bigend, const char *little, const char *lend) @@ -727,21 +752,37 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) s[rarest], (UV)rarest)); } -/* If SvTAIL(littlestr), it has a fake '\n' at end. */ -/* If SvTAIL is actually due to \Z or \z, this gives false positives - if multiline */ /* =for apidoc fbm_instr Returns the location of the SV in the string delimited by C and -C. It returns C if the string can't be found. The C +C (C) is the char following the last char). +It returns C if the string can't be found. The C does not have to be C, but the search will not be as fast then. =cut + +If SvTAIL(littlestr) is true, a fake "\n" was appended to to the string +during FBM compilation due to FBMcf_TAIL in flags. It indicates that +the littlestr must be anchored to the end of bigstr (or to any \n if +FBMrf_MULTILINE). + +E.g. The regex compiler would compile /abc/ to a littlestr of "abc", +while /abc$/ compiles to "abc\n" with SvTAIL() true. + +A littlestr of "abc", !SvTAIL matches as /abc/; +a littlestr of "ab\n", SvTAIL matches as: + without FBMrf_MULTILINE: /ab\n?\z/ + with FBMrf_MULTILINE: /ab\n/ || /ab\z/; + +(According to Ilya from 1999; I don't know if this is still true, DAPM 2015): + "If SvTAIL is actually due to \Z or \z, this gives false positives + if multiline". */ + char * Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U32 flags) { @@ -766,82 +807,103 @@ Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U switch (littlelen) { /* Special cases for 0, 1 and 2 */ case 0: return (char*)big; /* Cannot be SvTAIL! */ + case 1: - if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */ - /* Know that bigend != big. */ - if (bigend[-1] == '\n') - return (char *)(bigend - 1); - return (char *) bigend; - } - s = big; - while (s < bigend) { - if (*s == *little) - return (char *)s; - s++; - } + if (SvTAIL(littlestr) && !multiline) /* Anchor only! */ + /* [-1] is safe because we know that bigend != big. */ + return (char *) (bigend - (bigend[-1] == '\n')); + + s = (unsigned char *)memchr((void*)big, *little, bigend-big); + if (s) + return (char *)s; if (SvTAIL(littlestr)) return (char *) bigend; return NULL; + case 2: if (SvTAIL(littlestr) && !multiline) { - if (bigend[-1] == '\n' && bigend[-2] == *little) + /* a littlestr with SvTAIL must be of the form "X\n" (where X + * is a single char). It is anchored, and can only match + * "....X\n" or "....X" */ + if (bigend[-2] == *little && bigend[-1] == '\n') return (char*)bigend - 2; if (bigend[-1] == *little) return (char*)bigend - 1; return NULL; } + { - /* This should be better than FBM if c1 == c2, and almost - as good otherwise: maybe better since we do less indirection. - And we save a lot of memory by caching no table. */ - const unsigned char c1 = little[0]; - const unsigned char c2 = little[1]; - - s = big + 1; - bigend--; - if (c1 != c2) { - while (s <= bigend) { - if (s[0] == c2) { - if (s[-1] == c1) - return (char*)s - 1; - s += 2; - continue; - } - next_chars: - if (s[0] == c1) { - if (s == bigend) - goto check_1char_anchor; - if (s[1] == c2) - return (char*)s; - else { - s++; - goto next_chars; - } - } - else - s += 2; - } - goto check_1char_anchor; - } - /* Now c1 == c2 */ - while (s <= bigend) { - if (s[0] == c1) { - if (s[-1] == c1) - return (char*)s - 1; - if (s == bigend) - goto check_1char_anchor; - if (s[1] == c1) - return (char*)s; - s += 3; - } - else - s += 2; - } - } - check_1char_anchor: /* One char and anchor! */ - if (SvTAIL(littlestr) && (*bigend == *little)) - return (char *)bigend; /* bigend is already decremented. */ - return NULL; + /* memchr() is likely to be very fast, possibly using whatever + * hardware support is available, such as checking a whole + * cache line in one instruction. + * So for a 2 char pattern, calling memchr() is likely to be + * faster than running FBM, or rolling our own. The previous + * version of this code was roll-your-own which typically + * only needed to read every 2nd char, which was good back in + * the day, but no longer. + */ + unsigned char c1 = little[0]; + unsigned char c2 = little[1]; + + /* *** for all this case, bigend points to the last char, + * not the trailing \0: this makes the conditions slightly + * simpler */ + bigend--; + s = big; + if (c1 != c2) { + while (s < bigend) { + /* do a quick test for c1 before calling memchr(); + * this avoids the expensive fn call overhead when + * there are lots of c1's */ + if (LIKELY(*s != c1)) { + s++; + s = (unsigned char *)memchr((void*)s, c1, bigend - s); + if (!s) + break; + } + if (s[1] == c2) + return (char*)s; + + /* failed; try searching for c2 this time; that way + * we don't go pathologically slow when the string + * consists mostly of c1's or vice versa. + */ + s += 2; + if (s > bigend) + break; + s = (unsigned char *)memchr((void*)s, c2, bigend - s + 1); + if (!s) + break; + if (s[-1] == c1) + return (char*)s - 1; + } + } + else { + /* c1, c2 the same */ + while (s < bigend) { + if (s[0] == c1) { + got_1char: + if (s[1] == c1) + return (char*)s; + s += 2; + } + else { + s++; + s = (unsigned char *)memchr((void*)s, c1, bigend - s); + if (!s || s >= bigend) + break; + goto got_1char; + } + } + } + + /* failed to find 2 chars; try anchored match at end without + * the \n */ + if (SvTAIL(littlestr) && bigend[0] == little[0]) + return (char *)bigend; + return NULL; + } + default: break; /* Only lengths 0 1 and 2 have special-case code. */ } @@ -861,7 +923,9 @@ Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U } return NULL; } + if (!SvVALID(littlestr)) { + /* not compiled; use Perl_ninstr() instead */ char * const b = ninstr((char*)big,(char*)bigend, (char*)little, (char*)little + littlelen); @@ -895,15 +959,30 @@ Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U oldlittle = little; if (s < bigend) { const unsigned char * const table = (const unsigned char *) mg->mg_ptr; + const unsigned char lastc = *little; I32 tmp; top2: if ((tmp = table[*s])) { - if ((s += tmp) < bigend) - goto top2; - goto check_end; + /* *s != lastc; earliest position it could match now is + * tmp slots further on */ + if ((s += tmp) >= bigend) + goto check_end; + if (LIKELY(*s != lastc)) { + s++; + s = (unsigned char *)memchr((void*)s, lastc, bigend - s); + if (!s) { + s = bigend; + goto check_end; + } + goto top2; + } } - else { /* less expensive than calling strncmp() */ + + + /* hand-rolled strncmp(): less expensive than calling the + * real function (maybe???) */ + { unsigned char * const olds = s; tmp = littlelen; @@ -930,6 +1009,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U } } + /* =for apidoc foldEQ @@ -2055,7 +2135,7 @@ void Perl_my_setenv(pTHX_ const char *nam, const char *val) { dVAR; -#if defined(__amigaos4__) +#ifdef __amigaos4__ amigaos4_obtain_environ(__FUNCTION__); #endif #ifdef USE_ITHREADS @@ -2099,7 +2179,7 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val) environ[i] = environ[i+1]; i++; } -#if defined(__amigaos4__) +#ifdef __amigaos4__ goto my_setenv_out; #else return; @@ -2123,7 +2203,7 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val) Configure doesn't test for that yet. For Solaris, setenv() and unsetenv() were introduced in Solaris 9, so testing for HAS UNSETENV is sufficient. */ -# if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__) || (defined(__sun) && defined(HAS_UNSETENV)) +# if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__) || (defined(__sun) && defined(HAS_UNSETENV)) || defined(PERL_DARWIN) # if defined(HAS_UNSETENV) if (val == NULL) { (void)unsetenv(nam); @@ -2164,7 +2244,7 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val) } #endif } -#if defined(__amigaos4__) +#ifdef __amigaos4__ my_setenv_out: amigaos4_release_environ(__FUNCTION__); #endif @@ -2208,17 +2288,20 @@ Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */ } #endif -/* this is a drop-in replacement for bcopy() */ -#if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY)) -char * -Perl_my_bcopy(const char *from, char *to, I32 len) +/* this is a drop-in replacement for bcopy(), except for the return + * value, which we need to be able to emulate memcpy() */ +#if !defined(HAS_MEMCPY) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY)) +void * +Perl_my_bcopy(const void *vfrom, void *vto, size_t len) { - char * const retval = to; +#if defined(HAS_BCOPY) && defined(HAS_SAFE_BCOPY) + bcopy(vfrom, vto, len); +#else + const unsigned char *from = (const unsigned char *)vfrom; + unsigned char *to = (unsigned char *)vto; PERL_ARGS_ASSERT_MY_BCOPY; - assert(len >= 0); - if (from - to >= 0) { while (len--) *to++ = *from++; @@ -2229,57 +2312,53 @@ Perl_my_bcopy(const char *from, char *to, I32 len) while (len--) *(--to) = *(--from); } - return retval; +#endif + + return vto; } #endif /* this is a drop-in replacement for memset() */ #ifndef HAS_MEMSET void * -Perl_my_memset(char *loc, I32 ch, I32 len) +Perl_my_memset(void *vloc, int ch, size_t len) { - char * const retval = loc; + unsigned char *loc = (unsigned char *)vloc; PERL_ARGS_ASSERT_MY_MEMSET; - assert(len >= 0); - while (len--) *loc++ = ch; - return retval; + return vloc; } #endif /* this is a drop-in replacement for bzero() */ #if !defined(HAS_BZERO) && !defined(HAS_MEMSET) -char * -Perl_my_bzero(char *loc, I32 len) +void * +Perl_my_bzero(void *vloc, size_t len) { - char * const retval = loc; + unsigned char *loc = (unsigned char *)vloc; PERL_ARGS_ASSERT_MY_BZERO; - assert(len >= 0); - while (len--) *loc++ = 0; - return retval; + return vloc; } #endif /* this is a drop-in replacement for memcmp() */ #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP) -I32 -Perl_my_memcmp(const char *s1, const char *s2, I32 len) +int +Perl_my_memcmp(const void *vs1, const void *vs2, size_t len) { - const U8 *a = (const U8 *)s1; - const U8 *b = (const U8 *)s2; - I32 tmp; + const U8 *a = (const U8 *)vs1; + const U8 *b = (const U8 *)vs2; + int tmp; PERL_ARGS_ASSERT_MY_MEMCMP; - assert(len >= 0); - while (len--) { if ((tmp = *a++ - *b++)) return tmp; @@ -2484,8 +2563,8 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args) #endif } - /* VMS' my_popen() is in VMS.c, same with OS/2. */ -#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) + /* VMS' my_popen() is in VMS.c, same with OS/2 and AmigaOS 4. */ +#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__) PerlIO * Perl_my_popen(pTHX_ const char *cmd, const char *mode) { @@ -2659,6 +2738,15 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) /* this is called in parent before the fork() */ void Perl_atfork_lock(void) +#if defined(USE_ITHREADS) +# ifdef USE_PERLIO + PERL_TSA_ACQUIRE(PL_perlio_mutex) +# endif +# ifdef MYMALLOC + PERL_TSA_ACQUIRE(PL_malloc_mutex) +# endif + PERL_TSA_ACQUIRE(PL_op_mutex) +#endif { #if defined(USE_ITHREADS) dVAR; @@ -2676,6 +2764,15 @@ Perl_atfork_lock(void) /* this is called in both parent and child after the fork() */ void Perl_atfork_unlock(void) +#if defined(USE_ITHREADS) +# ifdef USE_PERLIO + PERL_TSA_RELEASE(PL_perlio_mutex) +# endif +# ifdef MYMALLOC + PERL_TSA_RELEASE(PL_malloc_mutex) +# endif + PERL_TSA_RELEASE(PL_op_mutex) +#endif { #if defined(USE_ITHREADS) dVAR; @@ -2906,7 +3003,7 @@ Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save) #endif /* !PERL_MICRO */ /* VMS' my_pclose() is in VMS.c; same with OS/2 */ -#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) +#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__) I32 Perl_my_pclose(pTHX_ PerlIO *ptr) { @@ -3252,6 +3349,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, while (deftypes || (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) ) { + Stat_t statbuf; if (deftypes) { deftypes = 0; *tmpbuf = '\0'; @@ -3278,13 +3376,16 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, #endif DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",cur)); - if (PerlLIO_stat(cur,&PL_statbuf) >= 0 - && !S_ISDIR(PL_statbuf.st_mode)) { - dosearch = 0; - scriptname = cur; + { + Stat_t statbuf; + if (PerlLIO_stat(cur,&statbuf) >= 0 + && !S_ISDIR(statbuf.st_mode)) { + dosearch = 0; + scriptname = cur; #ifdef SEARCH_EXTS - break; + break; #endif + } } #ifdef SEARCH_EXTS if (cur == scriptname) { @@ -3310,6 +3411,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, bufend = s + strlen(s); while (s < bufend) { + Stat_t statbuf; # ifdef DOSISH for (len = 0; *s && *s != ';'; len++, s++) { @@ -3346,8 +3448,8 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, do { #endif DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf)); - retval = PerlLIO_stat(tmpbuf,&PL_statbuf); - if (S_ISDIR(PL_statbuf.st_mode)) { + retval = PerlLIO_stat(tmpbuf,&statbuf); + if (S_ISDIR(statbuf.st_mode)) { retval = -1; } #ifdef SEARCH_EXTS @@ -3358,10 +3460,10 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, #endif if (retval < 0) continue; - if (S_ISREG(PL_statbuf.st_mode) - && cando(S_IRUSR,TRUE,&PL_statbuf) + if (S_ISREG(statbuf.st_mode) + && cando(S_IRUSR,TRUE,&statbuf) #if !defined(DOSISH) - && cando(S_IXUSR,TRUE,&PL_statbuf) + && cando(S_IXUSR,TRUE,&statbuf) #endif ) { @@ -3372,11 +3474,16 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, xfailed = savepv(tmpbuf); } #ifndef DOSISH - if (!xfound && !seen_dot && !xfailed && - (PerlLIO_stat(scriptname,&PL_statbuf) < 0 - || S_ISDIR(PL_statbuf.st_mode))) + { + Stat_t statbuf; + if (!xfound && !seen_dot && !xfailed && + (PerlLIO_stat(scriptname,&statbuf) < 0 + || S_ISDIR(statbuf.st_mode))) +#endif + seen_dot = 1; /* Disable message. */ +#ifndef DOSISH + } #endif - seen_dot = 1; /* Disable message. */ if (!xfound) { if (flags & 1) { /* do or die? */ /* diag_listed_as: Can't execute %s */ @@ -4452,6 +4559,9 @@ Perl_parse_unicode_opts(pTHX_ const char **popt) Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p); } } + else { + Perl_croak(aTHX_ "Invalid number '%s' for -C option.\n", p); + } } else { for (; *p; p++) { @@ -4547,7 +4657,11 @@ Perl_seed(pTHX) * if there isn't enough entropy available. You can compile with * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there * is enough real entropy to fill the seed. */ -# define PERL_RANDOM_DEVICE "/dev/urandom" +# ifdef __amigaos4__ +# define PERL_RANDOM_DEVICE "RANDOM:SIZE=4" +# else +# define PERL_RANDOM_DEVICE "/dev/urandom" +# endif #endif fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0); if (fd != -1) { @@ -4813,7 +4927,7 @@ S_mem_log_common(enum mem_log_type mlt, const UV n, (void)time(&when); # endif /* If there are other OS specific ways of hires time than - * gettimeofday() (see ext/Time-HiRes), the easiest way is + * gettimeofday() (see dist/Time-HiRes), the easiest way is * probably that they would be used to fill in the struct * timeval. */ { @@ -4892,6 +5006,8 @@ Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name, const char *filename, const int linenumber, const char *funcname) { + PERL_ARGS_ASSERT_MEM_LOG_ALLOC; + mem_log_common_if(MLT_ALLOC, n, typesize, type_name, NULL, NULL, newalloc, filename, linenumber, funcname); @@ -4904,6 +5020,8 @@ Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name, const char *filename, const int linenumber, const char *funcname) { + PERL_ARGS_ASSERT_MEM_LOG_REALLOC; + mem_log_common_if(MLT_REALLOC, n, typesize, type_name, NULL, oldalloc, newalloc, filename, linenumber, funcname); @@ -4915,6 +5033,8 @@ Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, const char *funcname) { + PERL_ARGS_ASSERT_MEM_LOG_FREE; + mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL, filename, linenumber, funcname); return oldalloc; @@ -5177,13 +5297,11 @@ Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap va_list apc; PERL_ARGS_ASSERT_MY_VSNPRINTF; -#ifndef HAS_VSNPRINTF - PERL_UNUSED_VAR(len); -#endif Perl_va_copy(ap, apc); # ifdef HAS_VSNPRINTF retval = vsnprintf(buffer, len, format, apc); # else + PERL_UNUSED_ARG(len); retval = vsprintf(buffer, format, apc); # endif va_end(apc); @@ -5191,6 +5309,7 @@ Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap # ifdef HAS_VSNPRINTF retval = vsnprintf(buffer, len, format, ap); # else + PERL_UNUSED_ARG(len); retval = vsprintf(buffer, format, ap); # endif #endif /* #ifdef NEED_VA_COPY */ @@ -6060,7 +6179,7 @@ static const char* atos_parse(const char* p, *source_name_size = source_name_end - p; if (grok_atoUV(source_number_start, &uv, &source_line_end) && source_line_end == close_paren - && uv <= MAX_STRLEN + && uv <= PERL_INT_MAX ) { *source_line = (STRLEN)uv; return p; @@ -6127,14 +6246,14 @@ static void atos_symbolize(atos_context* ctx, char out[1024]; UV cnt = fread(out, 1, sizeof(out), fp); if (cnt < sizeof(out)) { - const char* p = atos_parse(out + cnt, out, + const char* p = atos_parse(out + cnt - 1, out, source_name_size, source_line); if (p) { Newx(*source_name, - *source_name_size + 1, char); + *source_name_size, char); Copy(p, *source_name, - *source_name_size + 1, char); + *source_name_size, char); } } pclose(fp); @@ -6259,14 +6378,15 @@ Perl_get_c_backtrace(pTHX_ int depth, int skip) for (i = skip; i < try_depth; i++) { Dl_info* dl_info = &dl_infos[i]; - total_bytes += sizeof(Perl_c_backtrace_frame); - + object_name_sizes[i] = 0; source_names[i] = NULL; source_name_sizes[i] = 0; source_lines[i] = 0; /* Yes, zero from dladdr() is failure. */ if (dladdr(raw_frames[i], dl_info)) { + total_bytes += sizeof(Perl_c_backtrace_frame); + object_name_sizes[i] = dl_info->dli_fname ? strlen(dl_info->dli_fname) : 0; symbol_name_sizes[i] = @@ -6505,6 +6625,106 @@ Perl_dump_c_backtrace(pTHX_ PerlIO* fp, int depth, int skip) #endif /* #ifdef USE_C_BACKTRACE */ +#ifdef PERL_TSA_ACTIVE + +/* pthread_mutex_t and perl_mutex are typedef equivalent + * so casting the pointers is fine. */ + +int perl_tsa_mutex_lock(perl_mutex* mutex) +{ + return pthread_mutex_lock((pthread_mutex_t *) mutex); +} + +int perl_tsa_mutex_unlock(perl_mutex* mutex) +{ + return pthread_mutex_unlock((pthread_mutex_t *) mutex); +} + +int perl_tsa_mutex_destroy(perl_mutex* mutex) +{ + return pthread_mutex_destroy((pthread_mutex_t *) mutex); +} + +#endif + + +#ifdef USE_DTRACE + +/* log a sub call or return */ + +void +Perl_dtrace_probe_call(pTHX_ CV *cv, bool is_call) +{ + const char *func; + const char *file; + const char *stash; + const COP *start; + line_t line; + + PERL_ARGS_ASSERT_DTRACE_PROBE_CALL; + + if (CvNAMED(cv)) { + HEK *hek = CvNAME_HEK(cv); + func = HEK_KEY(hek); + } + else { + GV *gv = CvGV(cv); + func = GvENAME(gv); + } + start = (const COP *)CvSTART(cv); + file = CopFILE(start); + line = CopLINE(start); + stash = CopSTASHPV(start); + + if (is_call) { + PERL_SUB_ENTRY(func, file, line, stash); + } + else { + PERL_SUB_RETURN(func, file, line, stash); + } +} + + +/* log a require file loading/loaded */ + +void +Perl_dtrace_probe_load(pTHX_ const char *name, bool is_loading) +{ + PERL_ARGS_ASSERT_DTRACE_PROBE_LOAD; + + if (is_loading) { + PERL_LOADING_FILE(name); + } + else { + PERL_LOADED_FILE(name); + } +} + + +/* log an op execution */ + +void +Perl_dtrace_probe_op(pTHX_ const OP *op) +{ + PERL_ARGS_ASSERT_DTRACE_PROBE_OP; + + PERL_OP_ENTRY(OP_NAME(op)); +} + + +/* log a compile/run phase change */ + +void +Perl_dtrace_probe_phase(pTHX_ enum perl_phase phase) +{ + const char *ph_old = PL_phase_names[PL_phase]; + const char *ph_new = PL_phase_names[phase]; + + PERL_PHASE_CHANGE(ph_new, ph_old); +} + +#endif + /* * ex: set ts=8 sts=4 sw=4 et: */