X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/96e280ae86d56001827a53c737ce2fee631ea5cc..b38b066d1cf1b115dd83bdf7e4355e8870134fb9:/util.c diff --git a/util.c b/util.c index ed70ea0..0026909 100644 --- a/util.c +++ b/util.c @@ -26,17 +26,6 @@ #endif #endif -#ifdef I_VFORK -# include -#endif - -/* Put this after #includes because fork and vfork prototypes may - conflict. -*/ -#ifndef HAS_VFORK -# define vfork fork -#endif - #ifdef I_SYS_WAIT # include #endif @@ -336,6 +325,37 @@ S_xstat(pTHX_ int flag) #endif /* LEAKTEST */ +/* These must be defined when not using Perl's malloc for binary + * compatibility */ + +#ifndef MYMALLOC + +Malloc_t Perl_malloc (MEM_SIZE nbytes) +{ + dTHXs; + return PerlMem_malloc(nbytes); +} + +Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size) +{ + dTHXs; + return PerlMem_calloc(elements, size); +} + +Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes) +{ + dTHXs; + return PerlMem_realloc(where, nbytes); +} + +Free_t Perl_mfree (Malloc_t where) +{ + dTHXs; + PerlMem_free(where); +} + +#endif + /* copy a string up to some (non-backslashed) delimiter, if any */ char * @@ -972,17 +992,60 @@ Perl_mess(pTHX_ const char *pat, ...) return retval; } +STATIC COP* +S_closest_cop(pTHX_ COP *cop, OP *o) +{ + /* Look for PL_op starting from o. cop is the last COP we've seen. */ + + if (!o || o == PL_op) return cop; + + if (o->op_flags & OPf_KIDS) { + OP *kid; + for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) + { + COP *new_cop; + + /* If the OP_NEXTSTATE has been optimised away we can still use it + * the get the file and line number. */ + + if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE) + cop = (COP *)kid; + + /* Keep searching, and return when we've found something. */ + + new_cop = closest_cop(cop, kid); + if (new_cop) return new_cop; + } + } + + /* Nothing found. */ + + return 0; +} + SV * Perl_vmess(pTHX_ const char *pat, va_list *args) { SV *sv = mess_alloc(); static char dgd[] = " during global destruction.\n"; + COP *cop; sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') { - if (CopLINE(PL_curcop)) + + /* + * Try and find the file and line for PL_op. This will usually be + * PL_curcop, but it might be a cop that has been optimised away. We + * can try to find such a cop by searching through the optree starting + * from the sibling of PL_curcop. + */ + + cop = closest_cop(PL_curcop, PL_curcop->op_sibling); + if (!cop) cop = PL_curcop; + + if (CopLINE(cop)) Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf, - CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); + CopFILE(cop), (IV)CopLINE(cop)); if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) { bool line_mode = (RsSIMPLE(PL_rs) && SvCUR(PL_rs) == 1 && *SvPVX(PL_rs) == '\n'); @@ -991,7 +1054,7 @@ Perl_vmess(pTHX_ const char *pat, va_list *args) line_mode ? "line" : "chunk", (IV)IoLINES(GvIOp(PL_last_in_gv))); } -#ifdef USE_THREADS +#ifdef USE_5005THREADS if (thr->tid) Perl_sv_catpvf(aTHX_ sv, " thread %ld", thr->tid); #endif @@ -1343,9 +1406,9 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) message = SvPV(msv, msglen); if (ckDEAD(err)) { -#ifdef USE_THREADS +#ifdef USE_5005THREADS DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s", PTR2UV(thr), message)); -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ if (PL_diehook) { /* sv_2cv might call Perl_croak() */ SV *olddiehook = PL_diehook; @@ -1784,7 +1847,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) /* Try for another pipe pair for error return */ if (PerlProc_pipe(pp) >= 0) did_pipes = 1; - while ((pid = vfork()) < 0) { + while ((pid = PerlProc_fork()) < 0) { if (errno != EAGAIN) { PerlLIO_close(p[This]); if (did_pipes) { @@ -1836,7 +1899,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) #undef THAT } /* Parent */ - do_execfree(); /* free any memory malloced by child on vfork */ + do_execfree(); /* free any memory malloced by child on fork */ /* Close child's end of pipe */ PerlLIO_close(p[that]); if (did_pipes) @@ -1917,7 +1980,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) return Nullfp; if (doexec && PerlProc_pipe(pp) >= 0) did_pipes = 1; - while ((pid = (doexec?vfork():fork())) < 0) { + while ((pid = PerlProc_fork()) < 0) { if (errno != EAGAIN) { PerlLIO_close(p[This]); if (did_pipes) { @@ -1978,7 +2041,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) #undef THIS #undef THAT } - do_execfree(); /* free any memory malloced by child on vfork */ + do_execfree(); /* free any memory malloced by child on fork */ PerlLIO_close(p[that]); if (did_pipes) PerlLIO_close(pp[1]); @@ -2053,6 +2116,54 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) #endif /* !DOSISH */ +/* this is called in parent before the fork() */ +void +Perl_atfork_lock(void) +{ +#if defined(USE_5005THREADS) || defined(USE_ITHREADS) + /* locks must be held in locking order (if any) */ +# ifdef MYMALLOC + MUTEX_LOCK(&PL_malloc_mutex); +# endif + OP_REFCNT_LOCK; +#endif +} + +/* this is called in both parent and child after the fork() */ +void +Perl_atfork_unlock(void) +{ +#if defined(USE_5005THREADS) || defined(USE_ITHREADS) + /* locks must be released in same order as in atfork_lock() */ +# ifdef MYMALLOC + MUTEX_UNLOCK(&PL_malloc_mutex); +# endif + OP_REFCNT_UNLOCK; +#endif +} + +Pid_t +Perl_my_fork(void) +{ +#if defined(HAS_FORK) + Pid_t pid; +#if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(HAS_PTHREAD_ATFORK) + atfork_lock(); + pid = fork(); + atfork_unlock(); +#else + /* atfork_lock() and atfork_unlock() are installed as pthread_atfork() + * handlers elsewhere in the code */ + pid = fork(); +#endif + return pid; +#else + /* this "canna happen" since nothing should be calling here if !HAS_FORK */ + Perl_croak_nocontext("fork() not available"); + return 0; +#endif /* HAS_FORK */ +} + #ifdef DUMP_FDS void Perl_dump_fds(pTHX_ char *s) @@ -2679,7 +2790,7 @@ Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 f void * Perl_get_context(void) { -#if defined(USE_THREADS) || defined(USE_ITHREADS) +#if defined(USE_5005THREADS) || defined(USE_ITHREADS) # ifdef OLD_PTHREADS_API pthread_addr_t t; if (pthread_getspecific(PL_thr_key, &t)) @@ -2700,7 +2811,7 @@ Perl_get_context(void) void Perl_set_context(void *t) { -#if defined(USE_THREADS) || defined(USE_ITHREADS) +#if defined(USE_5005THREADS) || defined(USE_ITHREADS) # ifdef I_MACH_CTHREADS cthread_set_data(cthread_self(), t); # else @@ -2712,7 +2823,7 @@ Perl_set_context(void *t) #endif /* !PERL_GET_CONTEXT_DEFINED */ -#ifdef USE_THREADS +#ifdef USE_5005THREADS #ifdef FAKE_THREADS /* Very simplistic scheduler for now */ @@ -2926,6 +3037,8 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) PL_reg_start_tmpl = 0; PL_reg_poscache = Nullch; + PL_peepp = MEMBER_TO_FPTR(Perl_peep); + /* parent thread's data needs to be locked while we make copy */ MUTEX_LOCK(&t->mutex); @@ -2983,7 +3096,7 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) #endif /* HAVE_THREAD_INTERN */ return thr; } -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ #ifdef PERL_GLOBAL_STRUCT struct perl_vars * @@ -3104,7 +3217,7 @@ Perl_get_vtbl(pTHX_ int vtbl_id) case want_vtbl_uvar: result = &PL_vtbl_uvar; break; -#ifdef USE_THREADS +#ifdef USE_5005THREADS case want_vtbl_mutex: result = &PL_vtbl_mutex; break; @@ -3606,6 +3719,10 @@ Perl_getcwd_sv(pTHX_ register SV *sv) { #ifndef PERL_MICRO +#ifndef INCOMPLETE_TAINTS + SvTAINTED_on(sv); +#endif + #ifdef HAS_GETCWD { char buf[MAXPATHLEN];