From 47b1c8a3227816562fcee84921a3176377d38e5e Mon Sep 17 00:00:00 2001 From: Joe Schaefer Date: Thu, 2 Apr 2026 00:54:48 -0400 Subject: [PATCH 01/11] HTTP/2 --- src/modules/perl/modperl_interp.c | 38 ++++++++++++++++++++++++++----- 1 file changed, 32 insertions(+), 6 deletions(-) diff --git a/src/modules/perl/modperl_interp.c b/src/modules/perl/modperl_interp.c index 35f5cea8f..b84ad5951 100644 --- a/src/modules/perl/modperl_interp.c +++ b/src/modules/perl/modperl_interp.c @@ -390,7 +390,8 @@ modperl_interp_t *modperl_interp_select(request_rec *r, conn_rec *c, { MP_dSCFG((r ? s=r->server : c ? s=c->base_server : s)); MP_dDCFG; - modperl_config_con_t *ccfg; + modperl_config_con_t *ccfg = NULL; + modperl_config_req_t *rcfg = NULL; const char *desc = NULL; modperl_interp_t *interp = NULL; apr_pool_t *p = NULL; @@ -418,29 +419,48 @@ modperl_interp_t *modperl_interp_select(request_rec *r, conn_rec *c, return interp; } + + if (!ap_is_initial_req(r)) + r = r->main; if(!c) c = r->connection; ccfg = modperl_config_con_get(c); + rcfg = modperl_config_req_get(r); + if (interp || (interp = modperl_interp_pool_get(r->pool))) { + ap_assert(interp->refcnt > 0); + ap_assert(MpInterpIN_USE(interp)); + interp->refcnt++; + interp->num_requests++; + MP_TRACE_i(MP_FUNC, + "found interp 0x%lx (perl=0x%pp) in r->pool config, refcnt=%d", + (unsigned long)interp, interp->perl, interp->refcnt); + /* set context (THX) for this thread */ + modperl_thx_interp_set(interp->perl, interp); + PERL_SET_CONTEXT(interp->perl); + return interp; + } + +#if 0 if (ccfg && ccfg->interp) { ccfg->interp->refcnt++; - MP_TRACE_i(MP_FUNC, "found interp 0x%lx in con config, refcnt incremented to %d", (unsigned long)ccfg->interp, ccfg->interp->refcnt); /* set context (THX) for this thread */ + //modperl_thx_interp_set(ccfg->interp->perl, interp); PERL_SET_CONTEXT(ccfg->interp->perl); /* modperl_thx_interp_set() is not called here because the interp * already belongs to the perl interpreter */ return ccfg->interp; } - +#endif MP_TRACE_i(MP_FUNC, "fetching interp for %s:%d", s->server_hostname, s->port); interp = modperl_interp_get(s); MP_TRACE_i(MP_FUNC, " --> got %pp (perl=%pp)", interp, interp->perl); ++interp->num_requests; /* should only get here once per request */ - interp->refcnt = 1; + interp->refcnt = 2; /* set context (THX) for this thread */ PERL_SET_CONTEXT(interp->perl); @@ -449,13 +469,19 @@ modperl_interp_t *modperl_interp_select(request_rec *r, conn_rec *c, /* make sure ccfg is initialized */ modperl_config_con_init(c, ccfg); - ccfg->interp = interp; - interp->ccfg = ccfg; + modperl_config_req_init(r, rcfg); + + if (ccfg->interp == NULL) + ccfg->interp = interp; + if (interp->ccfg == NULL) + interp->ccfg = ccfg; MP_TRACE_i(MP_FUNC, "pulled interp %pp (perl=%pp) from mip, num_requests is %d", interp, interp->perl, interp->num_requests); + set_interp(r->pool); + return interp; } From 48a0a1da13248c6c699d24c87e4aa375d9986704 Mon Sep 17 00:00:00 2001 From: Joe Schaefer Date: Thu, 2 Apr 2026 20:32:36 -0400 Subject: [PATCH 02/11] bugfixes-under-h2load-tests --- src/modules/perl/modperl_callback.c | 21 +++++++++----- src/modules/perl/modperl_handler.c | 6 ++-- src/modules/perl/modperl_handler.h | 2 +- src/modules/perl/modperl_interp.c | 45 ++++++++++++----------------- 4 files changed, 37 insertions(+), 37 deletions(-) diff --git a/src/modules/perl/modperl_callback.c b/src/modules/perl/modperl_callback.c index 04f43171f..50ad4d6f3 100644 --- a/src/modules/perl/modperl_callback.c +++ b/src/modules/perl/modperl_callback.c @@ -23,6 +23,7 @@ int modperl_callback(pTHX_ modperl_handler_t *handler, apr_pool_t *p, I32 flags = G_EVAL|G_SCALAR; dSP; int count, status = OK; + PERL_SET_CONTEXT(aTHX); /* handler callbacks shouldn't affect each other's taintedness * state, so start every callback with a clear tainted status @@ -147,10 +148,10 @@ int modperl_callback_run_handlers(int idx, int type, apr_pool_t *ptemp, modperl_hook_run_mode_e run_mode) { - MP_dINTERP; MP_dSCFG(s); MP_dDCFG; MP_dRCFG; + //PERL_SET_CONTEXT(aTHX); modperl_handler_t **handlers; apr_pool_t *p = NULL; MpAV *av, **avp; @@ -171,8 +172,18 @@ int modperl_callback_run_handlers(int idx, int type, p = pconf; } - avp = modperl_handler_lookup_handlers(dcfg, scfg, rcfg, p, + MP_dINTERPa(r,c,s); + avp = modperl_handler_lookup_handlers(aTHX_ dcfg, scfg, rcfg, p, type, idx, FALSE, &desc); +#define MP_INTERP_KEY "MODPERL_INTERP" +#define set_interp(p) \ + (void)apr_pool_userdata_set((void *)interp, MP_INTERP_KEY, \ + modperl_interp_unselect, \ + p) + set_interp(p); + + //MP_INTERP_PUTBACK(interp, aTHX); + if (!(avp && (av = *avp))) { MP_TRACE_h(MP_FUNC, "no %s handlers configured (%s)", @@ -180,8 +191,6 @@ int modperl_callback_run_handlers(int idx, int type, return DECLINED; } - MP_INTERPa(r, c, s); - switch (type) { case MP_HANDLER_TYPE_PER_SRV: modperl_handler_make_args(aTHX_ &av_args, @@ -322,7 +331,7 @@ int modperl_callback_run_handlers(int idx, int type, * * XXX: would be nice to somehow optimize that */ - avp = modperl_handler_lookup_handlers(dcfg, scfg, rcfg, p, + avp = modperl_handler_lookup_handlers(aTHX_ dcfg, scfg, rcfg, p, type, idx, FALSE, NULL); if (avp && (av = *avp)) { handlers = (modperl_handler_t **)av->elts; @@ -331,8 +340,6 @@ int modperl_callback_run_handlers(int idx, int type, SvREFCNT_dec((SV*)av_args); - MP_INTERP_PUTBACK(interp, aTHX); - return status; } diff --git a/src/modules/perl/modperl_handler.c b/src/modules/perl/modperl_handler.c index fe935d785..d169ef2d7 100644 --- a/src/modules/perl/modperl_handler.c +++ b/src/modules/perl/modperl_handler.c @@ -352,7 +352,6 @@ void modperl_handler_make_args(pTHX_ AV **avp, ...) */ #define check_modify(dtype) \ if ((action > MP_HANDLER_ACTION_GET) && rcfg) { \ - dTHXa(PERL_GET_CONTEXT); \ MP_ASSERT(aTHX+0); \ Perl_croak(aTHX_ "too late to modify %s handlers", \ modperl_handler_desc_##dtype(idx)); \ @@ -369,7 +368,7 @@ void modperl_handler_make_args(pTHX_ AV **avp, ...) * r->request_config entries then override those in r->per_dir_config */ -MpAV **modperl_handler_lookup_handlers(modperl_config_dir_t *dcfg, +MpAV **modperl_handler_lookup_handlers(pTHX_ modperl_config_dir_t *dcfg, modperl_config_srv_t *scfg, modperl_config_req_t *rcfg, apr_pool_t *p, @@ -475,6 +474,7 @@ MpAV **modperl_handler_get_handlers(request_rec *r, conn_rec *c, server_rec *s, apr_pool_t *p, const char *name, modperl_handler_action_e action) { + dTHXa(PERL_GET_CONTEXT); MP_dSCFG(s); MP_dDCFG; MP_dRCFG; @@ -490,7 +490,7 @@ MpAV **modperl_handler_get_handlers(request_rec *r, conn_rec *c, server_rec *s, return FALSE; } - return modperl_handler_lookup_handlers(dcfg, scfg, rcfg, p, + return modperl_handler_lookup_handlers(aTHX_ dcfg, scfg, rcfg, p, type, idx, action, NULL); } diff --git a/src/modules/perl/modperl_handler.h b/src/modules/perl/modperl_handler.h index af3a8dda3..8aa382eb1 100644 --- a/src/modules/perl/modperl_handler.h +++ b/src/modules/perl/modperl_handler.h @@ -58,7 +58,7 @@ MpAV *modperl_handler_array_merge(apr_pool_t *p, MpAV *base_a, MpAV *add_a); void modperl_handler_make_args(pTHX_ AV **avp, ...); -MpAV **modperl_handler_lookup_handlers(modperl_config_dir_t *dcfg, +MpAV **modperl_handler_lookup_handlers(pTHX_ modperl_config_dir_t *dcfg, modperl_config_srv_t *scfg, modperl_config_req_t *rcfg, apr_pool_t *p, diff --git a/src/modules/perl/modperl_interp.c b/src/modules/perl/modperl_interp.c index b84ad5951..3435597e3 100644 --- a/src/modules/perl/modperl_interp.c +++ b/src/modules/perl/modperl_interp.c @@ -420,47 +420,38 @@ modperl_interp_t *modperl_interp_select(request_rec *r, conn_rec *c, } - if (!ap_is_initial_req(r)) + if (r && !ap_is_initial_req(r)) r = r->main; - if(!c) c = r->connection; - ccfg = modperl_config_con_get(c); - - rcfg = modperl_config_req_get(r); - if (interp || (interp = modperl_interp_pool_get(r->pool))) { - ap_assert(interp->refcnt > 0); - ap_assert(MpInterpIN_USE(interp)); + if (r && !c) c = r->connection; + if (c) + ccfg = modperl_config_con_get(c); + if (r) + rcfg = modperl_config_req_get(r); + if (r && (interp = modperl_interp_pool_get(r->pool))) { interp->refcnt++; interp->num_requests++; MP_TRACE_i(MP_FUNC, "found interp 0x%lx (perl=0x%pp) in r->pool config, refcnt=%d", (unsigned long)interp, interp->perl, interp->refcnt); - /* set context (THX) for this thread */ - modperl_thx_interp_set(interp->perl, interp); - PERL_SET_CONTEXT(interp->perl); + return interp; } -#if 0 - if (ccfg && ccfg->interp) { + if (!r && ccfg && ccfg->interp) { ccfg->interp->refcnt++; MP_TRACE_i(MP_FUNC, "found interp 0x%lx in con config, refcnt incremented to %d", (unsigned long)ccfg->interp, ccfg->interp->refcnt); - /* set context (THX) for this thread */ - //modperl_thx_interp_set(ccfg->interp->perl, interp); - PERL_SET_CONTEXT(ccfg->interp->perl); - /* modperl_thx_interp_set() is not called here because the interp - * already belongs to the perl interpreter - */ + return ccfg->interp; } -#endif + MP_TRACE_i(MP_FUNC, "fetching interp for %s:%d", s->server_hostname, s->port); interp = modperl_interp_get(s); MP_TRACE_i(MP_FUNC, " --> got %pp (perl=%pp)", interp, interp->perl); ++interp->num_requests; /* should only get here once per request */ - interp->refcnt = 2; + interp->refcnt = 1; /* set context (THX) for this thread */ PERL_SET_CONTEXT(interp->perl); @@ -468,10 +459,12 @@ modperl_interp_t *modperl_interp_select(request_rec *r, conn_rec *c, modperl_thx_interp_set(interp->perl, interp); /* make sure ccfg is initialized */ - modperl_config_con_init(c, ccfg); - modperl_config_req_init(r, rcfg); + if (c) + modperl_config_con_init(c, ccfg); + if (r) + modperl_config_req_init(r, rcfg); - if (ccfg->interp == NULL) + if (ccfg && ccfg->interp == NULL) ccfg->interp = interp; if (interp->ccfg == NULL) interp->ccfg = ccfg; @@ -479,8 +472,8 @@ modperl_interp_t *modperl_interp_select(request_rec *r, conn_rec *c, MP_TRACE_i(MP_FUNC, "pulled interp %pp (perl=%pp) from mip, num_requests is %d", interp, interp->perl, interp->num_requests); - - set_interp(r->pool); + if (r) + modperl_interp_pool_set(r->pool, interp); return interp; } From d81ad0c68a2f42eeb0b95a56dfa26e32661ad9fe Mon Sep 17 00:00:00 2001 From: Joe Schaefer Date: Sun, 5 Apr 2026 03:43:26 -0400 Subject: [PATCH 03/11] massive-reliability-cleanup --- src/modules/perl/mod_perl.c | 15 ++- src/modules/perl/modperl_callback.c | 19 +-- src/modules/perl/modperl_config.c | 14 +-- src/modules/perl/modperl_filter.c | 2 +- src/modules/perl/modperl_handler.c | 8 +- src/modules/perl/modperl_handler.h | 2 +- src/modules/perl/modperl_interp.c | 72 +++++------ src/modules/perl/modperl_interp.h | 3 +- src/modules/perl/modperl_mgv.c | 2 +- src/modules/perl/modperl_module.c | 4 +- src/modules/perl/modperl_tipool.c | 182 +++++++++++++--------------- src/modules/perl/modperl_tipool.h | 18 ++- src/modules/perl/modperl_types.h | 13 +- src/modules/perl/modperl_util.c | 15 ++- 14 files changed, 176 insertions(+), 193 deletions(-) diff --git a/src/modules/perl/mod_perl.c b/src/modules/perl/mod_perl.c index 4edba4a89..00dd30160 100644 --- a/src/modules/perl/mod_perl.c +++ b/src/modules/perl/mod_perl.c @@ -1034,27 +1034,27 @@ int modperl_response_handler(request_rec *r) { MP_dDCFG; apr_status_t retval, rc; - MP_dINTERP; - + if (!strEQ(r->handler, "modperl")) { return DECLINED; } - MP_INTERPa(r, r->connection, r->server); - /* default is -SetupEnv, add if PerlOption +SetupEnv */ + + MP_dINTERPa(r, NULL, NULL); + if (MpDirSETUP_ENV(dcfg)) { modperl_env_request_populate(aTHX_ r); } + retval = modperl_response_handler_run(r); rc = modperl_response_finish(r); if (rc != APR_SUCCESS) { retval = rc; } - + MP_INTERP_PUTBACK(interp, aTHX); - return retval; } @@ -1064,13 +1064,12 @@ int modperl_response_handler_cgi(request_rec *r) GV *h_stdin, *h_stdout; apr_status_t retval, rc; MP_dRCFG; - MP_dINTERP; if (!strEQ(r->handler, "perl-script")) { return DECLINED; } - MP_INTERPa(r, r->connection, r->server); + MP_dINTERPa(r, NULL, NULL); modperl_perl_global_request_save(aTHX_ r); diff --git a/src/modules/perl/modperl_callback.c b/src/modules/perl/modperl_callback.c index 50ad4d6f3..599111d0d 100644 --- a/src/modules/perl/modperl_callback.c +++ b/src/modules/perl/modperl_callback.c @@ -151,7 +151,6 @@ int modperl_callback_run_handlers(int idx, int type, MP_dSCFG(s); MP_dDCFG; MP_dRCFG; - //PERL_SET_CONTEXT(aTHX); modperl_handler_t **handlers; apr_pool_t *p = NULL; MpAV *av, **avp; @@ -172,24 +171,16 @@ int modperl_callback_run_handlers(int idx, int type, p = pconf; } - MP_dINTERPa(r,c,s); - avp = modperl_handler_lookup_handlers(aTHX_ dcfg, scfg, rcfg, p, + avp = modperl_handler_lookup_handlers(dcfg, scfg, rcfg, p, type, idx, FALSE, &desc); -#define MP_INTERP_KEY "MODPERL_INTERP" -#define set_interp(p) \ - (void)apr_pool_userdata_set((void *)interp, MP_INTERP_KEY, \ - modperl_interp_unselect, \ - p) - set_interp(p); - - //MP_INTERP_PUTBACK(interp, aTHX); - if (!(avp && (av = *avp))) { MP_TRACE_h(MP_FUNC, "no %s handlers configured (%s)", desc, r ? r->uri : ""); return DECLINED; } + + MP_dINTERPa(r, c, s); switch (type) { case MP_HANDLER_TYPE_PER_SRV: @@ -331,7 +322,7 @@ int modperl_callback_run_handlers(int idx, int type, * * XXX: would be nice to somehow optimize that */ - avp = modperl_handler_lookup_handlers(aTHX_ dcfg, scfg, rcfg, p, + avp = modperl_handler_lookup_handlers(dcfg, scfg, rcfg, p, type, idx, FALSE, NULL); if (avp && (av = *avp)) { handlers = (modperl_handler_t **)av->elts; @@ -340,6 +331,8 @@ int modperl_callback_run_handlers(int idx, int type, SvREFCNT_dec((SV*)av_args); + MP_INTERP_PUTBACK(interp, aTHX); + return status; } diff --git a/src/modules/perl/modperl_config.c b/src/modules/perl/modperl_config.c index 66030651f..fe9f9a21a 100644 --- a/src/modules/perl/modperl_config.c +++ b/src/modules/perl/modperl_config.c @@ -366,14 +366,12 @@ apr_status_t modperl_config_request_cleanup(pTHX_ request_rec *r) apr_status_t modperl_config_req_cleanup(void *data) { request_rec *r = (request_rec *)data; - apr_status_t rc; - MP_dINTERPa(r, NULL, NULL); - - rc = modperl_config_request_cleanup(aTHX_ r); - - MP_INTERP_PUTBACK(interp, aTHX); - - return rc; + apr_pool_t *p = ap_is_initial_req(r) ? r->pool : r->main->pool; + modperl_interp_t *interp = modperl_interp_pool_get(p); + if (interp && interp->perl) + return modperl_config_request_cleanup(interp->perl, r); + dTHX; + return modperl_config_request_cleanup(aTHX_ r); } void *modperl_get_perl_module_config(ap_conf_vector_t *cv) diff --git a/src/modules/perl/modperl_filter.c b/src/modules/perl/modperl_filter.c index 76be3e07c..5de5dec1d 100644 --- a/src/modules/perl/modperl_filter.c +++ b/src/modules/perl/modperl_filter.c @@ -486,7 +486,7 @@ int modperl_run_filter(modperl_filter_t *filter) server_rec *s = r ? r->server : c->base_server; apr_pool_t *p = r ? r->pool : c->pool; - MP_dINTERPa(r, c, s); + MP_dINTERPa(NULL, NULL, s); /* this needs to NOT be the interpreter in r->pool */ MP_FILTER_SAVE_ERRSV(errsv); diff --git a/src/modules/perl/modperl_handler.c b/src/modules/perl/modperl_handler.c index d169ef2d7..cef9583a9 100644 --- a/src/modules/perl/modperl_handler.c +++ b/src/modules/perl/modperl_handler.c @@ -352,7 +352,8 @@ void modperl_handler_make_args(pTHX_ AV **avp, ...) */ #define check_modify(dtype) \ if ((action > MP_HANDLER_ACTION_GET) && rcfg) { \ - MP_ASSERT(aTHX+0); \ + dTHX; \ + MP_ASSERT(aTHX+0); \ Perl_croak(aTHX_ "too late to modify %s handlers", \ modperl_handler_desc_##dtype(idx)); \ } @@ -368,7 +369,7 @@ void modperl_handler_make_args(pTHX_ AV **avp, ...) * r->request_config entries then override those in r->per_dir_config */ -MpAV **modperl_handler_lookup_handlers(pTHX_ modperl_config_dir_t *dcfg, +MpAV **modperl_handler_lookup_handlers(modperl_config_dir_t *dcfg, modperl_config_srv_t *scfg, modperl_config_req_t *rcfg, apr_pool_t *p, @@ -474,7 +475,6 @@ MpAV **modperl_handler_get_handlers(request_rec *r, conn_rec *c, server_rec *s, apr_pool_t *p, const char *name, modperl_handler_action_e action) { - dTHXa(PERL_GET_CONTEXT); MP_dSCFG(s); MP_dDCFG; MP_dRCFG; @@ -490,7 +490,7 @@ MpAV **modperl_handler_get_handlers(request_rec *r, conn_rec *c, server_rec *s, return FALSE; } - return modperl_handler_lookup_handlers(aTHX_ dcfg, scfg, rcfg, p, + return modperl_handler_lookup_handlers(dcfg, scfg, rcfg, p, type, idx, action, NULL); } diff --git a/src/modules/perl/modperl_handler.h b/src/modules/perl/modperl_handler.h index 8aa382eb1..af3a8dda3 100644 --- a/src/modules/perl/modperl_handler.h +++ b/src/modules/perl/modperl_handler.h @@ -58,7 +58,7 @@ MpAV *modperl_handler_array_merge(apr_pool_t *p, MpAV *base_a, MpAV *add_a); void modperl_handler_make_args(pTHX_ AV **avp, ...); -MpAV **modperl_handler_lookup_handlers(pTHX_ modperl_config_dir_t *dcfg, +MpAV **modperl_handler_lookup_handlers(modperl_config_dir_t *dcfg, modperl_config_srv_t *scfg, modperl_config_req_t *rcfg, apr_pool_t *p, diff --git a/src/modules/perl/modperl_interp.c b/src/modules/perl/modperl_interp.c index 3435597e3..ab69546fb 100644 --- a/src/modules/perl/modperl_interp.c +++ b/src/modules/perl/modperl_interp.c @@ -61,9 +61,9 @@ modperl_interp_t *modperl_interp_new(modperl_interp_pool_t *mip, clone_flags |= CLONEf_CLONE_HOST; #endif - PERL_SET_CONTEXT(perl); interp->perl = perl_clone(perl, clone_flags); + PERL_SET_CONTEXT(interp->perl); MP_ASSERT_CONTEXT(interp->perl); @@ -85,14 +85,13 @@ modperl_interp_t *modperl_interp_new(modperl_interp_pool_t *mip, * are different things, although they use the same type. */ if ((clone_flags & CLONEf_KEEP_PTR_TABLE)) { - dTHXa(interp->perl); + dTHXa(interp->perl); ptr_table_free(PL_ptr_table); PL_ptr_table = NULL; } modperl_interp_clone_init(interp); - PERL_SET_CONTEXT(perl); #ifdef MP_USE_GTOP MP_TRACE_m_do( @@ -120,6 +119,7 @@ void modperl_interp_destroy(modperl_interp_t *interp) if (MpInterpIN_USE(interp)) { MP_TRACE_i(MP_FUNC, "*error - still in use!*"); + abort(); } handles = modperl_xs_dl_handles_get(aTHX); @@ -142,7 +142,7 @@ modperl_interp_t *modperl_interp_get(server_rec *s) MP_dSCFG(s); modperl_interp_t *interp = NULL; modperl_interp_pool_t *mip = scfg->mip; - modperl_list_t *head; + volatile modperl_list_t *head; head = modperl_tipool_pop(mip->tipool); interp = (modperl_interp_t *)head->data; @@ -200,7 +200,7 @@ static void interp_pool_shrink(modperl_tipool_t *tipool, void *data, } static void interp_pool_dump(modperl_tipool_t *tipool, void *data, - modperl_list_t *listp) + volatile modperl_list_t *listp) { while (listp) { modperl_interp_t *interp = (modperl_interp_t *)listp->data; @@ -253,14 +253,13 @@ apr_status_t modperl_interp_unselect(void *data) { modperl_interp_t *interp = (modperl_interp_t *)data; modperl_interp_pool_t *mip = interp->mip; - + modperl_tipool_t *tipool = mip->tipool; + MP_ASSERT(interp && MpInterpIN_USE(interp) && interp->refcnt > 0); MP_TRACE_i(MP_FUNC, "unselect(interp=%pp): refcnt=%d", interp, interp->refcnt); - --interp->refcnt; - - if (interp->refcnt > 0) { + if (--interp->refcnt > 0) { MP_TRACE_i(MP_FUNC, "interp=0x%lx, refcnt=%d -- interp still in use", (unsigned long)interp, interp->refcnt); return APR_SUCCESS; @@ -274,6 +273,9 @@ apr_status_t modperl_interp_unselect(void *data) MpInterpIN_USE_Off(interp); + if (interp->pool) + apr_pool_cleanup_kill(interp->pool, interp, modperl_interp_unselect), interp->pool = NULL; + modperl_thx_interp_set(interp->perl, NULL); #ifdef MP_DEBUG PERL_SET_CONTEXT(NULL); @@ -284,11 +286,10 @@ apr_status_t modperl_interp_unselect(void *data) } else { interp->ccfg->interp = NULL; - modperl_tipool_putback_data(mip->tipool, data, interp->num_requests); + modperl_tipool_putback_data(tipool, data, interp->num_requests); MP_TRACE_i(MP_FUNC, "interp=%pp freed, tipool(size=%ld, in_use=%ld)", - interp, mip->tipool->size, mip->tipool->in_use); + interp, tipool->size, tipool->in_use); } - return APR_SUCCESS; } @@ -385,16 +386,16 @@ modperl_interp_t *modperl_interp_pool_select(apr_pool_t *p, } } -modperl_interp_t *modperl_interp_select(request_rec *r, conn_rec *c, - server_rec *s) +modperl_interp_t *modperl_interp_select(request_rec *r, conn_rec *c, server_rec *s) { - MP_dSCFG((r ? s=r->server : c ? s=c->base_server : s)); + s = r ? r->server : c ? c->base_server : s; + MP_dSCFG(s); MP_dDCFG; modperl_config_con_t *ccfg = NULL; modperl_config_req_t *rcfg = NULL; const char *desc = NULL; modperl_interp_t *interp = NULL; - apr_pool_t *p = NULL; + apr_pool_t *p; /* What does the following condition mean? * (r || c): if true we are at runtime. There is some kind of request @@ -419,33 +420,34 @@ modperl_interp_t *modperl_interp_select(request_rec *r, conn_rec *c, return interp; } - - if (r && !ap_is_initial_req(r)) + if (r && !ap_is_initial_req(r)) r = r->main; + + p = r ? r->pool : c ? c->pool : NULL; + if (r && !c) c = r->connection; if (c) ccfg = modperl_config_con_get(c); - if (r) - rcfg = modperl_config_req_get(r); - if (r && (interp = modperl_interp_pool_get(r->pool))) { + + if (p && (interp = modperl_interp_pool_get(p)) && MpInterpIN_USE(interp)) { interp->refcnt++; interp->num_requests++; MP_TRACE_i(MP_FUNC, "found interp 0x%lx (perl=0x%pp) in r->pool config, refcnt=%d", (unsigned long)interp, interp->perl, interp->refcnt); - + PERL_SET_CONTEXT(interp->perl); return interp; } - - if (!r && ccfg && ccfg->interp) { +#if 0 + if (ccfg && ccfg->interp) { ccfg->interp->refcnt++; MP_TRACE_i(MP_FUNC, "found interp 0x%lx in con config, refcnt incremented to %d", (unsigned long)ccfg->interp, ccfg->interp->refcnt); - + PERL_SET_CONTEXT(interp->perl); return ccfg->interp; } - +#endif MP_TRACE_i(MP_FUNC, "fetching interp for %s:%d", s->server_hostname, s->port); interp = modperl_interp_get(s); @@ -453,14 +455,10 @@ modperl_interp_t *modperl_interp_select(request_rec *r, conn_rec *c, ++interp->num_requests; /* should only get here once per request */ interp->refcnt = 1; - /* set context (THX) for this thread */ - PERL_SET_CONTEXT(interp->perl); - /* let the perl interpreter point back to its interp */ modperl_thx_interp_set(interp->perl, interp); /* make sure ccfg is initialized */ - if (c) - modperl_config_con_init(c, ccfg); + modperl_config_con_init(c, ccfg); if (r) modperl_config_req_init(r, rcfg); @@ -472,8 +470,8 @@ modperl_interp_t *modperl_interp_select(request_rec *r, conn_rec *c, MP_TRACE_i(MP_FUNC, "pulled interp %pp (perl=%pp) from mip, num_requests is %d", interp, interp->perl, interp->num_requests); - if (r) - modperl_interp_pool_set(r->pool, interp); + if (p) + set_interp(p), interp->pool = p; return interp; } @@ -485,7 +483,10 @@ void modperl_interp_mip_walk(PerlInterpreter *current_perl, modperl_interp_mip_walker_t walker, void *data) { - modperl_list_t *head = mip->tipool ? mip->tipool->idle : NULL; + if (mip->tipool) + modperl_tipool_lock(mip->tipool); + + volatile modperl_list_t *head = mip->tipool ? mip->tipool->idle : NULL; if (!current_perl) { current_perl = PERL_GET_CONTEXT; @@ -503,6 +504,9 @@ void modperl_interp_mip_walk(PerlInterpreter *current_perl, head = head->next; } + if (mip->tipool) + modperl_tipool_unlock(mip->tipool); + PERL_SET_CONTEXT(current_perl); } diff --git a/src/modules/perl/modperl_interp.h b/src/modules/perl/modperl_interp.h index f3f40376a..43d0b6eb6 100644 --- a/src/modules/perl/modperl_interp.h +++ b/src/modules/perl/modperl_interp.h @@ -46,8 +46,7 @@ void modperl_interp_pool_set(apr_pool_t *p, modperl_interp_t *modperl_interp_pool_select(apr_pool_t *p, server_rec *s); -modperl_interp_t *modperl_interp_select(request_rec *r, conn_rec *c, - server_rec *s); +modperl_interp_t *modperl_interp_select(request_rec *r, conn_rec *c, server_rec *s); #define MP_dINTERP pTHX; modperl_interp_t *interp = NULL diff --git a/src/modules/perl/modperl_mgv.c b/src/modules/perl/modperl_mgv.c index c6286f018..65e059bee 100644 --- a/src/modules/perl/modperl_mgv.c +++ b/src/modules/perl/modperl_mgv.c @@ -521,7 +521,7 @@ static int modperl_hash_handlers_srv(apr_pool_t *p, server_rec *s, void modperl_mgv_hash_handlers(apr_pool_t *p, server_rec *s) { - MP_dINTERPa(NULL, NULL, s); + MP_dINTERP_POOLa(p, s); ap_pcw_walk_config(p, s, &perl_module, #ifdef USE_ITHREADS aTHX, diff --git a/src/modules/perl/modperl_module.c b/src/modules/perl/modperl_module.c index e804bad62..e77edabe7 100644 --- a/src/modules/perl/modperl_module.c +++ b/src/modules/perl/modperl_module.c @@ -640,7 +640,7 @@ static const char *modperl_module_add_cmds(apr_pool_t *p, server_rec *s, command_rec *cmd; AV *module_cmds; I32 i, fill; - MP_dINTERPa(NULL, NULL, s); + MP_dINTERP_POOLa(p, s); module_cmds = (AV*)SvRV(mod_cmds); fill = AvFILL(module_cmds); @@ -782,7 +782,7 @@ const char *modperl_module_add(apr_pool_t *p, server_rec *s, const char *errmsg; module *modp; modperl_module_info_t *minfo; - MP_dINTERPa(NULL, NULL, s); + MP_dINTERP_POOLa(p, s); modp = (module *)apr_pcalloc(p, sizeof(*modp)); minfo = (modperl_module_info_t *)apr_pcalloc(p, sizeof(*minfo)); diff --git a/src/modules/perl/modperl_tipool.c b/src/modules/perl/modperl_tipool.c index 9cb0ad052..fd52819f9 100644 --- a/src/modules/perl/modperl_tipool.c +++ b/src/modules/perl/modperl_tipool.c @@ -39,7 +39,7 @@ modperl_list_t *modperl_list_new() return listp; } -modperl_list_t *modperl_list_last(modperl_list_t *list) +volatile modperl_list_t *modperl_list_last(volatile modperl_list_t *list) { while (list->next) { list = list->next; @@ -48,7 +48,7 @@ modperl_list_t *modperl_list_last(modperl_list_t *list) return list; } -modperl_list_t *modperl_list_first(modperl_list_t *list) +volatile modperl_list_t *modperl_list_first(volatile modperl_list_t *list) { while (list->prev) { list = list->prev; @@ -57,49 +57,52 @@ modperl_list_t *modperl_list_first(modperl_list_t *list) return list; } -modperl_list_t *modperl_list_append(modperl_list_t *list, +volatile modperl_list_t *modperl_list_append(volatile modperl_list_t *list, modperl_list_t *new_list) { - modperl_list_t *last; + volatile modperl_list_t *last; - new_list->prev = new_list->next = NULL; + if (new_list) + new_list->prev = new_list->next = NULL; - if (!list) { - return new_list; - } + if (!list) + return (volatile modperl_list_t *)new_list; + + if (!new_list) + return list; last = modperl_list_last(list); last->next = new_list; new_list->prev = last; - + new_list->next = NULL; return list; } -modperl_list_t *modperl_list_prepend(modperl_list_t *list, +volatile modperl_list_t *modperl_list_prepend(volatile modperl_list_t *list, modperl_list_t *new_list) { - new_list->prev = new_list->next = NULL; + if (new_list) + new_list->prev = new_list->next = NULL; - if (!list) { - return new_list; - } + if (!list) + return (volatile modperl_list_t *)new_list; if (list->prev) { list->prev->next = new_list; - new_list->prev = list->prev; } - list->prev = new_list; new_list->next = list; + new_list->prev = list->prev; + list->prev = new_list; - return new_list; + return (volatile modperl_list_t *)new_list; } -modperl_list_t *modperl_list_remove(modperl_list_t *list, +volatile modperl_list_t *modperl_list_remove(volatile modperl_list_t *list, modperl_list_t *rlist) { - modperl_list_t *tmp = list; + volatile modperl_list_t *tmp = list; while (tmp) { if (tmp != rlist) { @@ -131,11 +134,11 @@ modperl_list_t *modperl_list_remove(modperl_list_t *list, return list; } -modperl_list_t *modperl_list_remove_data(modperl_list_t *list, - void *data, - modperl_list_t **listp) +volatile modperl_list_t *modperl_list_remove_data(volatile modperl_list_t *list, + void *data, + modperl_list_t **listp) { - modperl_list_t *tmp = list; + volatile modperl_list_t *tmp = list; while (tmp) { if (tmp->data != data) { @@ -145,9 +148,11 @@ modperl_list_t *modperl_list_remove_data(modperl_list_t *list, *listp = tmp; if (tmp->prev) { tmp->prev->next = tmp->next; + tmp->prev = NULL; } if (tmp->next) { tmp->next->prev = tmp->prev; + tmp->next = NULL; } if (list == tmp) { list = list->next; @@ -181,7 +186,6 @@ modperl_tipool_t *modperl_tipool_new(apr_pool_t *p, void modperl_tipool_init(modperl_tipool_t *tipool) { int i; - for (i=0; icfg->start; i++) { void *item = (*tipool->func->tipool_sgrow)(tipool, tipool->data); @@ -198,7 +202,7 @@ void modperl_tipool_init(modperl_tipool_t *tipool) void modperl_tipool_destroy(modperl_tipool_t *tipool) { while (tipool->idle) { - modperl_list_t *listp; + volatile modperl_list_t *listp; if (tipool->func->tipool_destroy) { (*tipool->func->tipool_destroy)(tipool, tipool->data, @@ -216,7 +220,7 @@ void modperl_tipool_destroy(modperl_tipool_t *tipool) } MUTEX_DESTROY(&tipool->tiplock); - COND_DESTROY(&tipool->available); + COND_DESTROY(&tipool->available); } void modperl_tipool_add(modperl_tipool_t *tipool, void *data) @@ -244,47 +248,49 @@ void modperl_tipool_remove(modperl_tipool_t *tipool, modperl_list_t *listp) tipool->size--; MP_TRACE_i(MP_FUNC, "removed 0x%lx (size=%d)", (unsigned long)listp, tipool->size); + } modperl_list_t *modperl_tipool_pop(modperl_tipool_t *tipool) { - modperl_list_t *head; + + START: modperl_tipool_lock(tipool); + volatile modperl_list_t *head = tipool->idle; - if (tipool->size == tipool->in_use) { + if (!head) { if (tipool->size < tipool->cfg->max) { - MP_TRACE_i(MP_FUNC, - "no idle items, size %d < %d max", - tipool->size, tipool->cfg->max); if (tipool->func->tipool_rgrow) { - void * item = - (*tipool->func->tipool_rgrow)(tipool, tipool->data); - + MP_TRACE_i(MP_FUNC, + "growing pool: min_spare=%d, %d of %d in use", + tipool->cfg->min_spare, tipool->in_use, + tipool->size); + void *item = + (*tipool->func->tipool_rgrow)(tipool, + tipool->data); + modperl_tipool_add(tipool, item); } + else + modperl_tipool_wait(tipool); } - /* block until an item becomes available */ - modperl_tipool_wait(tipool); + head = tipool->idle; } - head = tipool->idle; - - tipool->idle = modperl_list_remove(tipool->idle, head); - tipool->busy = modperl_list_append(tipool->busy, head); - - tipool->in_use++; - /* XXX: this should never happen */ if (!head) { MP_TRACE_i(MP_FUNC, "PANIC: no items available, %d of %d in use", tipool->in_use, tipool->size); - abort(); + modperl_tipool_unlock(tipool); + goto START; } + tipool->idle = modperl_list_remove(tipool->idle, head); + tipool->busy = modperl_list_append(tipool->busy, head); + tipool->in_use++; modperl_tipool_unlock(tipool); - - return head; + return (modperl_list_t *)head; } static void modperl_tipool_putback_base(modperl_tipool_t *tipool, @@ -293,7 +299,6 @@ static void modperl_tipool_putback_base(modperl_tipool_t *tipool, int num_requests) { int max_spare, max_requests; - modperl_tipool_lock(tipool); /* remove from busy list, add back to idle */ @@ -307,15 +312,10 @@ static void modperl_tipool_putback_base(modperl_tipool_t *tipool, } if (!listp) { - /* XXX: Attempt to putback something that was never there */ - modperl_tipool_unlock(tipool); - return; + modperl_tipool_unlock(tipool);/* XXX: Attempt to putback something that was never there */ + goto MANAGE_POOL; } - tipool->idle = modperl_list_prepend(tipool->idle, listp); - - tipool->in_use--; - #ifdef MP_TRACE if (!tipool->busy && tipool->func->tipool_dump) { MP_TRACE_i(MP_FUNC, "all items idle:"); @@ -325,67 +325,59 @@ static void modperl_tipool_putback_base(modperl_tipool_t *tipool, } #endif + tipool->in_use--; MP_TRACE_i(MP_FUNC, "0x%lx now available (%d in use, %d running)", (unsigned long)listp->data, tipool->in_use, tipool->size); - modperl_tipool_broadcast(tipool); - if (tipool->in_use == (tipool->cfg->max - 1)) { - /* hurry up, another thread may be blocking */ - modperl_tipool_unlock(tipool); - return; - } + modperl_interp_t *interp = listp->data; + tipool->idle = modperl_list_prepend(tipool->idle, listp); + modperl_tipool_signal(tipool); + modperl_tipool_unlock(tipool); + max_spare = ((tipool->size - tipool->in_use) > tipool->cfg->max_spare); max_requests = ((num_requests > 0) && (num_requests > tipool->cfg->max_requests)); - if (max_spare) { - MP_TRACE_i(MP_FUNC, - "shrinking pool: max_spare=%d, only %d of %d in use", - tipool->cfg->max_spare, tipool->in_use, tipool->size); - } - else if (max_requests) { - MP_TRACE_i(MP_FUNC, "shrinking pool: max requests %d reached", - tipool->cfg->max_requests); - } - /* XXX: this management should probably be happening elsewhere * like in a thread spawned at startup */ - if (max_spare || max_requests) { - modperl_tipool_remove(tipool, listp); - - if (tipool->func->tipool_destroy) { - (*tipool->func->tipool_destroy)(tipool, tipool->data, - listp->data); + MANAGE_POOL: + while (tipool->size < tipool->cfg->max && tipool->size - tipool->in_use < tipool->cfg->min_spare) { + if (tipool->func->tipool_rgrow) { + MP_TRACE_i(MP_FUNC, + "growing pool: min_spare=%d, %d of %d in use", + tipool->cfg->min_spare, tipool->in_use, + tipool->size); + void *item = + (*tipool->func->tipool_rgrow)(tipool, + tipool->data); + modperl_tipool_lock(tipool); + modperl_tipool_add(tipool, item); + modperl_tipool_signal(tipool); + modperl_tipool_unlock(tipool); } - - free(listp); /* gone for good */ - - if (max_requests && ((tipool->size - tipool->in_use) < - tipool->cfg->min_spare)) { - if (tipool->func->tipool_rgrow) { - void *item = - (*tipool->func->tipool_rgrow)(tipool, - tipool->data); - - MP_TRACE_i(MP_FUNC, - "growing pool: min_spare=%d, %d of %d in use", - tipool->cfg->min_spare, tipool->in_use, - tipool->size); - - modperl_tipool_add(tipool, item); + } + while (tipool->size - tipool->in_use > tipool->cfg->max_spare) { + if (tipool->func->tipool_destroy) { + MP_TRACE_i(MP_FUNC, + "shrinking pool: max_spare=%d, %d of %d in use", + tipool->cfg->max_spare, tipool->in_use, + tipool->size); + modperl_tipool_lock(tipool); + if (tipool->idle) { + listp = modperl_list_last(tipool->idle); + modperl_tipool_remove(tipool, listp); + (*tipool->func->tipool_destroy)(tipool, tipool->data, listp->data); } + modperl_tipool_unlock(tipool); } } - - modperl_tipool_unlock(tipool); } /* _data functions are so structures (e.g. modperl_interp_t) don't * need to maintain a pointer back to the modperl_list_t */ - void modperl_tipool_putback_data(modperl_tipool_t *tipool, void *data, int num_requests) diff --git a/src/modules/perl/modperl_tipool.h b/src/modules/perl/modperl_tipool.h index c2d15b885..b4d707e9a 100644 --- a/src/modules/perl/modperl_tipool.h +++ b/src/modules/perl/modperl_tipool.h @@ -21,17 +21,17 @@ modperl_list_t *modperl_list_new(void); -modperl_list_t *modperl_list_last(modperl_list_t *list); +volatile modperl_list_t *modperl_list_last(volatile modperl_list_t *list); -modperl_list_t *modperl_list_first(modperl_list_t *list); +volatile modperl_list_t *modperl_list_first(volatile modperl_list_t *list); -modperl_list_t *modperl_list_append(modperl_list_t *list, +volatile modperl_list_t *modperl_list_append(volatile modperl_list_t *list, modperl_list_t *new_list); -modperl_list_t *modperl_list_prepend(modperl_list_t *list, +volatile modperl_list_t *modperl_list_prepend(volatile modperl_list_t *list, modperl_list_t *new_list); -modperl_list_t *modperl_list_remove(modperl_list_t *list, +volatile modperl_list_t *modperl_list_remove(volatile modperl_list_t *list, modperl_list_t *rlist); modperl_tipool_t *modperl_tipool_new(apr_pool_t *p, @@ -47,7 +47,7 @@ void modperl_tipool_add(modperl_tipool_t *tipool, void *data); void modperl_tipool_remove(modperl_tipool_t *tipool, modperl_list_t *listp); -modperl_list_t *modperl_list_remove_data(modperl_list_t *list, +volatile modperl_list_t *modperl_list_remove_data(volatile modperl_list_t *list, void *data, modperl_list_t **listp); @@ -61,17 +61,15 @@ void modperl_tipool_putback_data(modperl_tipool_t *tipool, void *data, int num_requests); #define modperl_tipool_wait(tipool) \ - while (tipool->size == tipool->in_use) { \ MP_TRACE_i(MP_FUNC, \ "waiting for available tipool item in thread 0x%lx", \ MP_TIDF); \ MP_TRACE_i(MP_FUNC, "(%d items in use, %d alive)", \ tipool->in_use, tipool->size); \ COND_WAIT(&tipool->available, &tipool->tiplock); \ - } -#define modperl_tipool_broadcast(tipool) \ - MP_TRACE_i(MP_FUNC, "broadcast available tipool item"); \ +#define modperl_tipool_signal(tipool) \ + MP_TRACE_i(MP_FUNC, "signal available tipool item"); \ COND_SIGNAL(&tipool->available) #define modperl_tipool_lock(tipool) \ diff --git a/src/modules/perl/modperl_types.h b/src/modules/perl/modperl_types.h index 8438f3504..4b28bf49f 100644 --- a/src/modules/perl/modperl_types.h +++ b/src/modules/perl/modperl_types.h @@ -47,7 +47,7 @@ typedef struct modperl_config_con_t modperl_config_con_t; typedef struct modperl_list_t modperl_list_t; struct modperl_list_t { - modperl_list_t *prev, *next; + volatile modperl_list_t *prev, *next; void *data; }; @@ -63,6 +63,7 @@ struct modperl_interp_t { U8 flags; modperl_config_con_t *ccfg; int refcnt; + apr_pool_t *pool; #ifdef MP_TRACE unsigned long tid; #endif @@ -79,7 +80,7 @@ typedef struct { void (*tipool_destroy)(modperl_tipool_t *tipool, void *data, void *item); void (*tipool_dump)(modperl_tipool_t *tipool, void *data, - modperl_list_t *listp); + volatile modperl_list_t *listp); } modperl_tipool_vtbl_t; struct modperl_tipool_config_t { @@ -93,9 +94,9 @@ struct modperl_tipool_config_t { struct modperl_tipool_t { perl_mutex tiplock; perl_cond available; - modperl_list_t *idle, *busy; - int in_use; /* number of items currrently in use */ - int size; /* current number of items */ + volatile modperl_list_t *idle, *busy; + volatile int in_use; /* number of items currrently in use */ + volatile int size; /* current number of items */ void *data; /* user data */ modperl_tipool_config_t *cfg; modperl_tipool_vtbl_t *func; @@ -240,7 +241,7 @@ typedef struct { HV *pnotes; apr_pool_t *pool; #ifdef USE_ITHREADS - modperl_interp_t *interp; + PerlInterpreter *perl; #endif } modperl_pnotes_t; diff --git a/src/modules/perl/modperl_util.c b/src/modules/perl/modperl_util.c index dc06cde26..0dad0ab03 100644 --- a/src/modules/perl/modperl_util.c +++ b/src/modules/perl/modperl_util.c @@ -833,14 +833,15 @@ static MP_INLINE apr_status_t modperl_cleanup_pnotes(void *data) { modperl_pnotes_t *pnotes = data; - dTHXa(pnotes->interp->perl); + dTHXa(pnotes->perl); MP_ASSERT_CONTEXT(aTHX); + modperl_interp_t *interp = modperl_thx_interp_get(aTHX); + interp->refcnt--; SvREFCNT_dec(pnotes->pnotes); pnotes->pnotes = NULL; pnotes->pool = NULL; - MP_INTERP_PUTBACK(pnotes->interp, aTHX); return APR_SUCCESS; } @@ -859,16 +860,13 @@ SV *modperl_pnotes(pTHX_ modperl_pnotes_t *pnotes, SV *key, SV *val, if (!pnotes->pnotes) { pnotes->pool = pool; -#ifdef USE_ITHREADS - pnotes->interp = modperl_thx_interp_get(aTHX); - pnotes->interp->refcnt++; - MP_TRACE_i(MP_FUNC, "TO: (0x%lx)->refcnt incremented to %ld", - pnotes->interp, pnotes->interp->refcnt); -#endif pnotes->pnotes = newHV(); apr_pool_cleanup_register(pool, pnotes, modperl_cleanup_pnotes, apr_pool_cleanup_null); + pnotes->perl = aTHX; + modperl_interp_t *interp = modperl_thx_interp_get(aTHX); + interp->refcnt++; } if (key) { @@ -1011,6 +1009,7 @@ static const char *perl_parse_require_line(cmd_parms *cmd, */ MP_dINTERP_POOLa(cmd->pool, cmd->server); if (!MP_HAS_INTERP(interp)) { + MP_INTERP_PUTBACK(interp, aTHX); return "Require handler is not currently supported in this context"; } From eff120400574e736a59836dde5d20d9edd9a687d Mon Sep 17 00:00:00 2001 From: Joe Schaefer Date: Mon, 6 Apr 2026 10:51:23 -0400 Subject: [PATCH 04/11] whitespace,etc --- src/modules/perl/mod_perl.c | 8 +-- src/modules/perl/modperl_callback.c | 2 +- src/modules/perl/modperl_config.c | 2 +- src/modules/perl/modperl_filter.c | 2 +- src/modules/perl/modperl_interp.c | 74 +++++++++++++++++--------- src/modules/perl/modperl_interp.h | 1 + src/modules/perl/modperl_tipool.c | 82 +++++++++++++---------------- src/modules/perl/modperl_tipool.h | 4 +- src/modules/perl/modperl_util.c | 10 ++-- 9 files changed, 102 insertions(+), 83 deletions(-) diff --git a/src/modules/perl/mod_perl.c b/src/modules/perl/mod_perl.c index 00dd30160..f10dddbda 100644 --- a/src/modules/perl/mod_perl.c +++ b/src/modules/perl/mod_perl.c @@ -1034,26 +1034,26 @@ int modperl_response_handler(request_rec *r) { MP_dDCFG; apr_status_t retval, rc; - + if (!strEQ(r->handler, "modperl")) { return DECLINED; } /* default is -SetupEnv, add if PerlOption +SetupEnv */ - + MP_dINTERPa(r, NULL, NULL); if (MpDirSETUP_ENV(dcfg)) { modperl_env_request_populate(aTHX_ r); } - + retval = modperl_response_handler_run(r); rc = modperl_response_finish(r); if (rc != APR_SUCCESS) { retval = rc; } - + MP_INTERP_PUTBACK(interp, aTHX); return retval; } diff --git a/src/modules/perl/modperl_callback.c b/src/modules/perl/modperl_callback.c index 599111d0d..c8d197aeb 100644 --- a/src/modules/perl/modperl_callback.c +++ b/src/modules/perl/modperl_callback.c @@ -179,7 +179,7 @@ int modperl_callback_run_handlers(int idx, int type, desc, r ? r->uri : ""); return DECLINED; } - + MP_dINTERPa(r, c, s); switch (type) { diff --git a/src/modules/perl/modperl_config.c b/src/modules/perl/modperl_config.c index fe9f9a21a..9372a9a14 100644 --- a/src/modules/perl/modperl_config.c +++ b/src/modules/perl/modperl_config.c @@ -367,7 +367,7 @@ apr_status_t modperl_config_req_cleanup(void *data) { request_rec *r = (request_rec *)data; apr_pool_t *p = ap_is_initial_req(r) ? r->pool : r->main->pool; - modperl_interp_t *interp = modperl_interp_pool_get(p); + modperl_interp_t *interp = modperl_interp_pool_get(p); if (interp && interp->perl) return modperl_config_request_cleanup(interp->perl, r); dTHX; diff --git a/src/modules/perl/modperl_filter.c b/src/modules/perl/modperl_filter.c index 5de5dec1d..76be3e07c 100644 --- a/src/modules/perl/modperl_filter.c +++ b/src/modules/perl/modperl_filter.c @@ -486,7 +486,7 @@ int modperl_run_filter(modperl_filter_t *filter) server_rec *s = r ? r->server : c->base_server; apr_pool_t *p = r ? r->pool : c->pool; - MP_dINTERPa(NULL, NULL, s); /* this needs to NOT be the interpreter in r->pool */ + MP_dINTERPa(r, c, s); MP_FILTER_SAVE_ERRSV(errsv); diff --git a/src/modules/perl/modperl_interp.c b/src/modules/perl/modperl_interp.c index ab69546fb..78c336567 100644 --- a/src/modules/perl/modperl_interp.c +++ b/src/modules/perl/modperl_interp.c @@ -61,7 +61,7 @@ modperl_interp_t *modperl_interp_new(modperl_interp_pool_t *mip, clone_flags |= CLONEf_CLONE_HOST; #endif - + PERL_SET_CONTEXT(perl); interp->perl = perl_clone(perl, clone_flags); PERL_SET_CONTEXT(interp->perl); @@ -85,7 +85,7 @@ modperl_interp_t *modperl_interp_new(modperl_interp_pool_t *mip, * are different things, although they use the same type. */ if ((clone_flags & CLONEf_KEEP_PTR_TABLE)) { - dTHXa(interp->perl); + dTHXa(interp->perl); ptr_table_free(PL_ptr_table); PL_ptr_table = NULL; } @@ -249,12 +249,23 @@ void modperl_interp_init(server_rec *s, apr_pool_t *p, scfg->mip = mip; } +static apr_status_t modperl_interp_pool_unselect(void *data) +{ + modperl_interp_t *interp = (modperl_interp_t *)data; + if (interp->refcnt > 1) { + MP_TRACE_i(MP_FUNC, "BIZARRE REFCNT: unselect(interp=%pp): refcnt=%d", + interp, interp->refcnt); + interp->refcnt = 1; + } + return modperl_interp_unselect(data); +} + apr_status_t modperl_interp_unselect(void *data) { modperl_interp_t *interp = (modperl_interp_t *)data; modperl_interp_pool_t *mip = interp->mip; modperl_tipool_t *tipool = mip->tipool; - + MP_ASSERT(interp && MpInterpIN_USE(interp) && interp->refcnt > 0); MP_TRACE_i(MP_FUNC, "unselect(interp=%pp): refcnt=%d", interp, interp->refcnt); @@ -274,8 +285,8 @@ apr_status_t modperl_interp_unselect(void *data) MpInterpIN_USE_Off(interp); if (interp->pool) - apr_pool_cleanup_kill(interp->pool, interp, modperl_interp_unselect), interp->pool = NULL; - + apr_pool_cleanup_kill(interp->pool, interp, modperl_interp_pool_unselect), interp->pool = NULL; + modperl_thx_interp_set(interp->perl, NULL); #ifdef MP_DEBUG PERL_SET_CONTEXT(NULL); @@ -305,7 +316,7 @@ apr_status_t modperl_interp_unselect(void *data) #define set_interp(p) \ (void)apr_pool_userdata_set((void *)interp, MP_INTERP_KEY, \ - modperl_interp_unselect, \ + modperl_interp_pool_unselect, \ p) modperl_interp_t *modperl_interp_pool_get(apr_pool_t *p) @@ -321,6 +332,15 @@ void modperl_interp_pool_set(apr_pool_t *p, (void)apr_pool_userdata_set((void *)interp, MP_INTERP_KEY, NULL, p); } +modperl_interp_t *modperl_interp_pool_unset(apr_pool_t *p) +{ + modperl_interp_t *interp = NULL; + get_interp(p); + (void)apr_pool_userdata_set(NULL, MP_INTERP_KEY, NULL, p); + return interp; +} + + /* * used in the case where we don't have a request_rec or conn_rec, * such as for directive handlers per-{dir,srv} create and merge. @@ -344,7 +364,7 @@ modperl_interp_t *modperl_interp_pool_select(apr_pool_t *p, modperl_init_vhost(s, p, NULL); if (!scfg->mip) { /* FIXME: We get here if global "server_rec" == s, scfg->mip - * is not created then. I'm not sure if that's bug or + * is not created then. I'm not sure if that's bug or * bad/good design decicision. For now just return NULL. */ return NULL; @@ -420,12 +440,13 @@ modperl_interp_t *modperl_interp_select(request_rec *r, conn_rec *c, server_rec return interp; } - if (r && !ap_is_initial_req(r)) + if (r && !ap_is_initial_req(r)) r = r->main; - + p = r ? r->pool : c ? c->pool : NULL; if (r && !c) c = r->connection; + if (c) ccfg = modperl_config_con_get(c); @@ -438,16 +459,7 @@ modperl_interp_t *modperl_interp_select(request_rec *r, conn_rec *c, server_rec PERL_SET_CONTEXT(interp->perl); return interp; } -#if 0 - if (ccfg && ccfg->interp) { - ccfg->interp->refcnt++; - MP_TRACE_i(MP_FUNC, - "found interp 0x%lx in con config, refcnt incremented to %d", - (unsigned long)ccfg->interp, ccfg->interp->refcnt); - PERL_SET_CONTEXT(interp->perl); - return ccfg->interp; - } -#endif + MP_TRACE_i(MP_FUNC, "fetching interp for %s:%d", s->server_hostname, s->port); interp = modperl_interp_get(s); @@ -455,12 +467,11 @@ modperl_interp_t *modperl_interp_select(request_rec *r, conn_rec *c, server_rec ++interp->num_requests; /* should only get here once per request */ interp->refcnt = 1; + PERL_SET_CONTEXT(interp->perl); modperl_thx_interp_set(interp->perl, interp); - /* make sure ccfg is initialized */ + /* make sure ccfg/rcfg is initialized */ modperl_config_con_init(c, ccfg); - if (r) - modperl_config_req_init(r, rcfg); if (ccfg && ccfg->interp == NULL) ccfg->interp = interp; @@ -470,8 +481,23 @@ modperl_interp_t *modperl_interp_select(request_rec *r, conn_rec *c, server_rec MP_TRACE_i(MP_FUNC, "pulled interp %pp (perl=%pp) from mip, num_requests is %d", interp, interp->perl, interp->num_requests); - if (p) - set_interp(p), interp->pool = p; + if (r) + /* it is correct to bump the refcnt below, assuming mod_http2's h2_stream.c is patched: + + +@@ -659,16 +659,16 @@ apr_status_t h2_stream_set_request_rec(h2_stream *stream, + if (stream->rst_error) { + return APR_ECONNRESET; + } +- status = h2_request_rcreate(&req, stream->pool, r, ++ status = h2_request_rcreate(&req, r->pool, r, + &stream->session->hd_scratch); + if (status == APR_SUCCESS) { + + + + */ + interp->refcnt++, set_interp(p), interp->pool = p; return interp; } diff --git a/src/modules/perl/modperl_interp.h b/src/modules/perl/modperl_interp.h index 43d0b6eb6..14cf1a4e9 100644 --- a/src/modules/perl/modperl_interp.h +++ b/src/modules/perl/modperl_interp.h @@ -42,6 +42,7 @@ modperl_interp_t *modperl_interp_pool_get(apr_pool_t *p); void modperl_interp_pool_set(apr_pool_t *p, modperl_interp_t *interp); +modperl_interp_t *modperl_interp_pool_unset(apr_pool_t *p); modperl_interp_t *modperl_interp_pool_select(apr_pool_t *p, server_rec *s); diff --git a/src/modules/perl/modperl_tipool.c b/src/modules/perl/modperl_tipool.c index fd52819f9..210b1566c 100644 --- a/src/modules/perl/modperl_tipool.c +++ b/src/modules/perl/modperl_tipool.c @@ -84,13 +84,14 @@ volatile modperl_list_t *modperl_list_prepend(volatile modperl_list_t *list, { if (new_list) new_list->prev = new_list->next = NULL; + else + return list; if (!list) return (volatile modperl_list_t *)new_list; - if (list->prev) { + if (list->prev) list->prev->next = new_list; - } new_list->next = list; new_list->prev = list->prev; @@ -118,7 +119,7 @@ volatile modperl_list_t *modperl_list_remove(volatile modperl_list_t *list, if (list == tmp) { list = list->next; } - + tmp->prev = tmp->next = NULL; break; } } @@ -148,16 +149,14 @@ volatile modperl_list_t *modperl_list_remove_data(volatile modperl_list_t *list, *listp = tmp; if (tmp->prev) { tmp->prev->next = tmp->next; - tmp->prev = NULL; } if (tmp->next) { tmp->next->prev = tmp->prev; - tmp->next = NULL; } if (list == tmp) { list = list->next; } - + tmp->prev = tmp->next = NULL; break; } } @@ -220,7 +219,7 @@ void modperl_tipool_destroy(modperl_tipool_t *tipool) } MUTEX_DESTROY(&tipool->tiplock); - COND_DESTROY(&tipool->available); + COND_DESTROY(&tipool->available); } void modperl_tipool_add(modperl_tipool_t *tipool, void *data) @@ -254,12 +253,12 @@ void modperl_tipool_remove(modperl_tipool_t *tipool, modperl_list_t *listp) modperl_list_t *modperl_tipool_pop(modperl_tipool_t *tipool) { - - START: + modperl_tipool_lock(tipool); volatile modperl_list_t *head = tipool->idle; if (!head) { + START: if (tipool->size < tipool->cfg->max) { if (tipool->func->tipool_rgrow) { MP_TRACE_i(MP_FUNC, @@ -269,12 +268,12 @@ modperl_list_t *modperl_tipool_pop(modperl_tipool_t *tipool) void *item = (*tipool->func->tipool_rgrow)(tipool, tipool->data); - modperl_tipool_add(tipool, item); } + } else modperl_tipool_wait(tipool); - } + head = tipool->idle; } @@ -282,7 +281,6 @@ modperl_list_t *modperl_tipool_pop(modperl_tipool_t *tipool) if (!head) { MP_TRACE_i(MP_FUNC, "PANIC: no items available, %d of %d in use", tipool->in_use, tipool->size); - modperl_tipool_unlock(tipool); goto START; } tipool->idle = modperl_list_remove(tipool->idle, head); @@ -298,7 +296,6 @@ static void modperl_tipool_putback_base(modperl_tipool_t *tipool, void *data, int num_requests) { - int max_spare, max_requests; modperl_tipool_lock(tipool); /* remove from busy list, add back to idle */ @@ -311,10 +308,8 @@ static void modperl_tipool_putback_base(modperl_tipool_t *tipool, tipool->busy = modperl_list_remove_data(tipool->busy, data, &listp); } - if (!listp) { - modperl_tipool_unlock(tipool);/* XXX: Attempt to putback something that was never there */ - goto MANAGE_POOL; - } + tipool->in_use--; + #ifdef MP_TRACE if (!tipool->busy && tipool->func->tipool_dump) { @@ -325,26 +320,37 @@ static void modperl_tipool_putback_base(modperl_tipool_t *tipool, } #endif - tipool->in_use--; + if (!listp) { + MP_TRACE_i(MP_FUNC, "what happened to listp?"); + goto MANAGE_TIPOOL; + } + MP_TRACE_i(MP_FUNC, "0x%lx now available (%d in use, %d running)", (unsigned long)listp->data, tipool->in_use, tipool->size); - modperl_interp_t *interp = listp->data; - tipool->idle = modperl_list_prepend(tipool->idle, listp); modperl_tipool_signal(tipool); - modperl_tipool_unlock(tipool); - - max_spare = ((tipool->size - tipool->in_use) > tipool->cfg->max_spare); - max_requests = ((num_requests > 0) && - (num_requests > tipool->cfg->max_requests)); - /* XXX: this management should probably be happening elsewhere * like in a thread spawned at startup */ - MANAGE_POOL: - while (tipool->size < tipool->cfg->max && tipool->size - tipool->in_use < tipool->cfg->min_spare) { - if (tipool->func->tipool_rgrow) { + MANAGE_TIPOOL: + if (tipool->func->tipool_destroy) { + if (tipool->size - tipool->in_use > tipool->cfg->max_spare) { + if (tipool->idle && tipool->idle->next) { + MP_TRACE_i(MP_FUNC, + "shrinking pool: max_spare=%d, %d of %d in use", + tipool->cfg->max_spare, tipool->in_use, + tipool->size); + listp = modperl_list_last(tipool->idle->next); + if (listp) { + modperl_tipool_remove(tipool, listp); + (*tipool->func->tipool_destroy)(tipool, tipool->data, listp->data); + } + } + } + } + if (tipool->func->tipool_rgrow) { + if (tipool->size < tipool->cfg->max && tipool->size - tipool->in_use < tipool->cfg->min_spare) { MP_TRACE_i(MP_FUNC, "growing pool: min_spare=%d, %d of %d in use", tipool->cfg->min_spare, tipool->in_use, @@ -352,27 +358,11 @@ static void modperl_tipool_putback_base(modperl_tipool_t *tipool, void *item = (*tipool->func->tipool_rgrow)(tipool, tipool->data); - modperl_tipool_lock(tipool); modperl_tipool_add(tipool, item); modperl_tipool_signal(tipool); - modperl_tipool_unlock(tipool); - } - } - while (tipool->size - tipool->in_use > tipool->cfg->max_spare) { - if (tipool->func->tipool_destroy) { - MP_TRACE_i(MP_FUNC, - "shrinking pool: max_spare=%d, %d of %d in use", - tipool->cfg->max_spare, tipool->in_use, - tipool->size); - modperl_tipool_lock(tipool); - if (tipool->idle) { - listp = modperl_list_last(tipool->idle); - modperl_tipool_remove(tipool, listp); - (*tipool->func->tipool_destroy)(tipool, tipool->data, listp->data); - } - modperl_tipool_unlock(tipool); } } + modperl_tipool_unlock(tipool); } /* _data functions are so structures (e.g. modperl_interp_t) don't diff --git a/src/modules/perl/modperl_tipool.h b/src/modules/perl/modperl_tipool.h index b4d707e9a..433734b1f 100644 --- a/src/modules/perl/modperl_tipool.h +++ b/src/modules/perl/modperl_tipool.h @@ -60,14 +60,14 @@ void modperl_tipool_putback(modperl_tipool_t *tipool, void modperl_tipool_putback_data(modperl_tipool_t *tipool, void *data, int num_requests); -#define modperl_tipool_wait(tipool) \ +#define modperl_tipool_wait(tipool) do { \ MP_TRACE_i(MP_FUNC, \ "waiting for available tipool item in thread 0x%lx", \ MP_TIDF); \ MP_TRACE_i(MP_FUNC, "(%d items in use, %d alive)", \ tipool->in_use, tipool->size); \ COND_WAIT(&tipool->available, &tipool->tiplock); \ - + } while (0) #define modperl_tipool_signal(tipool) \ MP_TRACE_i(MP_FUNC, "signal available tipool item"); \ COND_SIGNAL(&tipool->available) diff --git a/src/modules/perl/modperl_util.c b/src/modules/perl/modperl_util.c index 0dad0ab03..bce8825e2 100644 --- a/src/modules/perl/modperl_util.c +++ b/src/modules/perl/modperl_util.c @@ -835,9 +835,10 @@ apr_status_t modperl_cleanup_pnotes(void *data) { dTHXa(pnotes->perl); MP_ASSERT_CONTEXT(aTHX); - +#ifdef USE_ITHREADS modperl_interp_t *interp = modperl_thx_interp_get(aTHX); interp->refcnt--; +#endif SvREFCNT_dec(pnotes->pnotes); pnotes->pnotes = NULL; pnotes->pool = NULL; @@ -864,9 +865,11 @@ SV *modperl_pnotes(pTHX_ modperl_pnotes_t *pnotes, SV *key, SV *val, apr_pool_cleanup_register(pool, pnotes, modperl_cleanup_pnotes, apr_pool_cleanup_null); +#ifdef USE_ITHREADS pnotes->perl = aTHX; modperl_interp_t *interp = modperl_thx_interp_get(aTHX); interp->refcnt++; +#endif } if (key) { @@ -886,10 +889,10 @@ SV *modperl_pnotes(pTHX_ modperl_pnotes_t *pnotes, SV *key, SV *val, } U16 *modperl_code_attrs(pTHX_ CV *cv) { - MAGIC *mg; + MAGIC *mg; if (!(SvMAGICAL(cv) && (mg = mg_find((SV*)cv, PERL_MAGIC_ext)))) { - sv_magic((SV*)cv, (SV *)NULL, PERL_MAGIC_ext, NULL, -1); + sv_magic((SV*)cv, (SV *)NULL, PERL_MAGIC_ext, NULL, -1); } mg = mg_find((SV*)cv, PERL_MAGIC_ext); @@ -1009,7 +1012,6 @@ static const char *perl_parse_require_line(cmd_parms *cmd, */ MP_dINTERP_POOLa(cmd->pool, cmd->server); if (!MP_HAS_INTERP(interp)) { - MP_INTERP_PUTBACK(interp, aTHX); return "Require handler is not currently supported in this context"; } From 01ee00d8d87cefdd41214f3c7eb717eb54c5fc70 Mon Sep 17 00:00:00 2001 From: Joe Schaefer Date: Wed, 8 Apr 2026 22:30:52 -0400 Subject: [PATCH 05/11] interpreter-locks --- src/modules/perl/modperl_interp.c | 21 ++++++++++++++++++--- src/modules/perl/modperl_tipool.c | 19 ++++++++++++------- src/modules/perl/modperl_types.h | 3 ++- src/modules/perl/modperl_util.c | 9 +-------- 4 files changed, 33 insertions(+), 19 deletions(-) diff --git a/src/modules/perl/modperl_interp.c b/src/modules/perl/modperl_interp.c index 78c336567..a813d1c4c 100644 --- a/src/modules/perl/modperl_interp.c +++ b/src/modules/perl/modperl_interp.c @@ -48,6 +48,7 @@ modperl_interp_t *modperl_interp_new(modperl_interp_pool_t *mip, interp->mip = mip; interp->refcnt = 0; + MUTEX_INIT(&interp->lock); if (perl) { #ifdef MP_USE_GTOP @@ -112,7 +113,7 @@ void modperl_interp_destroy(modperl_interp_t *interp) void **handles; dTHXa(interp->perl); - PERL_SET_CONTEXT(interp->perl); + PERL_SET_CONTEXT(aTHX); MP_TRACE_i(MP_FUNC, "interp == 0x%lx / perl: 0x%lx", (unsigned long)interp, (unsigned long)interp->perl); @@ -124,11 +125,13 @@ void modperl_interp_destroy(modperl_interp_t *interp) handles = modperl_xs_dl_handles_get(aTHX); - modperl_perl_destruct(interp->perl); + modperl_perl_destruct(aTHX); modperl_xs_dl_handles_close(handles); + MUTEX_DESTROY(&interp->lock); free(interp); + } apr_status_t modperl_interp_cleanup(void *data) @@ -257,6 +260,7 @@ static apr_status_t modperl_interp_pool_unselect(void *data) interp, interp->refcnt); interp->refcnt = 1; } + interp->pool = NULL; return modperl_interp_unselect(data); } @@ -265,7 +269,7 @@ apr_status_t modperl_interp_unselect(void *data) modperl_interp_t *interp = (modperl_interp_t *)data; modperl_interp_pool_t *mip = interp->mip; modperl_tipool_t *tipool = mip->tipool; - + MUTEX_LOCK(&interp->lock); MP_ASSERT(interp && MpInterpIN_USE(interp) && interp->refcnt > 0); MP_TRACE_i(MP_FUNC, "unselect(interp=%pp): refcnt=%d", interp, interp->refcnt); @@ -273,12 +277,14 @@ apr_status_t modperl_interp_unselect(void *data) if (--interp->refcnt > 0) { MP_TRACE_i(MP_FUNC, "interp=0x%lx, refcnt=%d -- interp still in use", (unsigned long)interp, interp->refcnt); + MUTEX_UNLOCK(&interp->lock); return APR_SUCCESS; } if (!MpInterpIN_USE(interp)){ MP_TRACE_i(MP_FUNC, "interp=0x%pp, refcnt=%d -- interp already not in use", interp, interp->refcnt); + MUTEX_UNLOCK(&interp->lock); return APR_SUCCESS; } @@ -301,6 +307,7 @@ apr_status_t modperl_interp_unselect(void *data) MP_TRACE_i(MP_FUNC, "interp=%pp freed, tipool(size=%ld, in_use=%ld)", interp, tipool->size, tipool->in_use); } + MUTEX_UNLOCK(&interp->lock); return APR_SUCCESS; } @@ -450,9 +457,14 @@ modperl_interp_t *modperl_interp_select(request_rec *r, conn_rec *c, server_rec if (c) ccfg = modperl_config_con_get(c); + static perl_mutex lock = PTHREAD_MUTEX_INITIALIZER; + MUTEX_LOCK(&lock); if (p && (interp = modperl_interp_pool_get(p)) && MpInterpIN_USE(interp)) { + MUTEX_LOCK(&interp->lock); + MUTEX_UNLOCK(&lock); interp->refcnt++; interp->num_requests++; + MUTEX_UNLOCK(&interp->lock); MP_TRACE_i(MP_FUNC, "found interp 0x%lx (perl=0x%pp) in r->pool config, refcnt=%d", (unsigned long)interp, interp->perl, interp->refcnt); @@ -463,6 +475,7 @@ modperl_interp_t *modperl_interp_select(request_rec *r, conn_rec *c, server_rec MP_TRACE_i(MP_FUNC, "fetching interp for %s:%d", s->server_hostname, s->port); interp = modperl_interp_get(s); + MUTEX_LOCK(&interp->lock); MP_TRACE_i(MP_FUNC, " --> got %pp (perl=%pp)", interp, interp->perl); ++interp->num_requests; /* should only get here once per request */ interp->refcnt = 1; @@ -499,6 +512,8 @@ modperl_interp_t *modperl_interp_select(request_rec *r, conn_rec *c, server_rec */ interp->refcnt++, set_interp(p), interp->pool = p; + MUTEX_UNLOCK(&interp->lock); + MUTEX_UNLOCK(&lock); return interp; } diff --git a/src/modules/perl/modperl_tipool.c b/src/modules/perl/modperl_tipool.c index 210b1566c..b2644116d 100644 --- a/src/modules/perl/modperl_tipool.c +++ b/src/modules/perl/modperl_tipool.c @@ -248,6 +248,7 @@ void modperl_tipool_remove(modperl_tipool_t *tipool, modperl_list_t *listp) MP_TRACE_i(MP_FUNC, "removed 0x%lx (size=%d)", (unsigned long)listp, tipool->size); + free(listp); } modperl_list_t *modperl_tipool_pop(modperl_tipool_t *tipool) @@ -297,7 +298,6 @@ static void modperl_tipool_putback_base(modperl_tipool_t *tipool, int num_requests) { modperl_tipool_lock(tipool); - /* remove from busy list, add back to idle */ /* XXX: option to sort list, e.g. on num_requests */ @@ -335,18 +335,23 @@ static void modperl_tipool_putback_base(modperl_tipool_t *tipool, */ MANAGE_TIPOOL: if (tipool->func->tipool_destroy) { - if (tipool->size - tipool->in_use > tipool->cfg->max_spare) { + while (tipool->size - tipool->in_use > tipool->cfg->max_spare) { if (tipool->idle && tipool->idle->next) { - MP_TRACE_i(MP_FUNC, - "shrinking pool: max_spare=%d, %d of %d in use", - tipool->cfg->max_spare, tipool->in_use, - tipool->size); listp = modperl_list_last(tipool->idle->next); if (listp) { + MP_TRACE_i(MP_FUNC, + "shrinking pool: destroying 0x%lx, max_spare=%d, %d of %d in use", + (unsigned long)listp->data, tipool->cfg->max_spare, tipool->in_use, + tipool->size); + void *data = listp->data; modperl_tipool_remove(tipool, listp); - (*tipool->func->tipool_destroy)(tipool, tipool->data, listp->data); + (*tipool->func->tipool_destroy)(tipool, tipool->data, data); } + else + break; } + else + break; } } if (tipool->func->tipool_rgrow) { diff --git a/src/modules/perl/modperl_types.h b/src/modules/perl/modperl_types.h index 4b28bf49f..24bbfdfa5 100644 --- a/src/modules/perl/modperl_types.h +++ b/src/modules/perl/modperl_types.h @@ -62,11 +62,12 @@ struct modperl_interp_t { int num_requests; U8 flags; modperl_config_con_t *ccfg; - int refcnt; + volatile int refcnt; apr_pool_t *pool; #ifdef MP_TRACE unsigned long tid; #endif + perl_mutex lock; }; typedef struct { diff --git a/src/modules/perl/modperl_util.c b/src/modules/perl/modperl_util.c index bce8825e2..a35bf2624 100644 --- a/src/modules/perl/modperl_util.c +++ b/src/modules/perl/modperl_util.c @@ -19,7 +19,7 @@ int modperl_require_module(pTHX_ const char *pv, int logfailure) { SV *sv; - + PERL_SET_CONTEXT(aTHX); dSP; PUSHSTACKi(PERLSI_REQUIRE); ENTER;SAVETMPS; @@ -835,14 +835,9 @@ apr_status_t modperl_cleanup_pnotes(void *data) { dTHXa(pnotes->perl); MP_ASSERT_CONTEXT(aTHX); -#ifdef USE_ITHREADS - modperl_interp_t *interp = modperl_thx_interp_get(aTHX); - interp->refcnt--; -#endif SvREFCNT_dec(pnotes->pnotes); pnotes->pnotes = NULL; pnotes->pool = NULL; - return APR_SUCCESS; } @@ -867,8 +862,6 @@ SV *modperl_pnotes(pTHX_ modperl_pnotes_t *pnotes, SV *key, SV *val, apr_pool_cleanup_null); #ifdef USE_ITHREADS pnotes->perl = aTHX; - modperl_interp_t *interp = modperl_thx_interp_get(aTHX); - interp->refcnt++; #endif } From 918a43296b3a9a99356b50fdcbacd9aeb2e5c637 Mon Sep 17 00:00:00 2001 From: Joe Schaefer Date: Thu, 9 Apr 2026 11:22:14 -0400 Subject: [PATCH 06/11] mostly-fix-BIZARRE-refcnt-issues --- src/modules/perl/modperl_module.c | 4 ++-- xs/APR/Pool/APR__Pool.h | 17 +++++++++-------- xs/Apache2/Filter/Apache2__Filter.h | 2 +- 3 files changed, 12 insertions(+), 11 deletions(-) diff --git a/src/modules/perl/modperl_module.c b/src/modules/perl/modperl_module.c index e77edabe7..4386b1c9c 100644 --- a/src/modules/perl/modperl_module.c +++ b/src/modules/perl/modperl_module.c @@ -128,7 +128,7 @@ static apr_status_t modperl_module_config_obj_cleanup(void *data) MP_TRACE_c(MP_FUNC, "deleting ptr %pp from table %pp", cleanup->ptr, cleanup->table); - MP_INTERP_PUTBACK(cleanup->interp, aTHX); +// MP_INTERP_PUTBACK(cleanup->interp, aTHX); return APR_SUCCESS; } @@ -145,7 +145,7 @@ static void modperl_module_config_obj_cleanup_register(pTHX_ cleanup->ptr = ptr; #ifdef USE_ITHREADS cleanup->interp = modperl_thx_interp_get(aTHX); - MP_INTERP_REFCNT_inc(cleanup->interp); +// MP_INTERP_REFCNT_inc(cleanup->interp); #endif apr_pool_cleanup_register(p, cleanup, diff --git a/xs/APR/Pool/APR__Pool.h b/xs/APR/Pool/APR__Pool.h index 4a168b345..be52c33ee 100644 --- a/xs/APR/Pool/APR__Pool.h +++ b/xs/APR/Pool/APR__Pool.h @@ -101,10 +101,10 @@ APR_OPTIONAL_FN_TYPE(modperl_thx_interp_get) *modperl_opt_thx_interp_get; */ \ if (modperl_opt_thx_interp_get) { \ if ((acct->interp = modperl_opt_thx_interp_get(aTHX))) { \ - acct->interp->refcnt++; \ - MP_TRACE_i(MP_FUNC, "TO: (0x%lx)->refcnt incremented to %ld", \ - acct->interp, acct->interp->refcnt); \ - } \ + /* acct->interp->refcnt++;*/ \ + /* MP_TRACE_i(MP_FUNC, "TO: (0x%lx)->refcnt incremented to %ld", */ \ + /* acct->interp, acct->interp->refcnt); */ \ + ;} \ } \ } STMT_END @@ -299,7 +299,7 @@ static apr_status_t mpxs_cleanup_run(void *data) } if (SvTRUE(ERRSV)) { - Perl_warn(aTHX_ "APR::Pool: cleanup died: %s", + Perl_warn(aTHX_ "APR::Pool: cleanup died: %s", SvPV_nolen(ERRSV)); } @@ -348,9 +348,10 @@ static MP_INLINE void mpxs_apr_pool_cleanup_register(pTHX_ apr_pool_t *p, */ if (modperl_opt_thx_interp_get) { if ((data->interp = modperl_opt_thx_interp_get(data->perl))) { - data->interp->refcnt++; - MP_TRACE_i(MP_FUNC, "(0x%lx)->refcnt incremented to %ld", - data->interp, data->interp->refcnt); + /* data->interp->refcnt++; */ + /* MP_TRACE_i(MP_FUNC, "(0x%lx)->refcnt incremented to %ld", + data->interp, data->interp->refcnt); */ + ; } } #endif diff --git a/xs/Apache2/Filter/Apache2__Filter.h b/xs/Apache2/Filter/Apache2__Filter.h index bc551370d..51dd28335 100644 --- a/xs/Apache2/Filter/Apache2__Filter.h +++ b/xs/Apache2/Filter/Apache2__Filter.h @@ -198,7 +198,7 @@ static MP_INLINE SV *mpxs_Apache2__Filter_ctx(pTHX_ #ifdef USE_ITHREADS if (!ctx->interp) { ctx->interp = modperl_thx_interp_get(aTHX); - MP_INTERP_REFCNT_inc(ctx->interp); +// MP_INTERP_REFCNT_inc(ctx->interp); } #endif ctx->data = SvREFCNT_inc(data); From 43af9e026d95159db241b6236807f647f829d233 Mon Sep 17 00:00:00 2001 From: Joe Schaefer Date: Thu, 9 Apr 2026 13:06:36 -0400 Subject: [PATCH 07/11] nuke-redundant-interpreter-locks-experiment --- src/modules/perl/modperl_interp.c | 17 ++--------------- src/modules/perl/modperl_types.h | 1 - 2 files changed, 2 insertions(+), 16 deletions(-) diff --git a/src/modules/perl/modperl_interp.c b/src/modules/perl/modperl_interp.c index a813d1c4c..c9ba10edb 100644 --- a/src/modules/perl/modperl_interp.c +++ b/src/modules/perl/modperl_interp.c @@ -48,7 +48,6 @@ modperl_interp_t *modperl_interp_new(modperl_interp_pool_t *mip, interp->mip = mip; interp->refcnt = 0; - MUTEX_INIT(&interp->lock); if (perl) { #ifdef MP_USE_GTOP @@ -129,7 +128,6 @@ void modperl_interp_destroy(modperl_interp_t *interp) modperl_xs_dl_handles_close(handles); - MUTEX_DESTROY(&interp->lock); free(interp); } @@ -269,7 +267,6 @@ apr_status_t modperl_interp_unselect(void *data) modperl_interp_t *interp = (modperl_interp_t *)data; modperl_interp_pool_t *mip = interp->mip; modperl_tipool_t *tipool = mip->tipool; - MUTEX_LOCK(&interp->lock); MP_ASSERT(interp && MpInterpIN_USE(interp) && interp->refcnt > 0); MP_TRACE_i(MP_FUNC, "unselect(interp=%pp): refcnt=%d", interp, interp->refcnt); @@ -277,14 +274,12 @@ apr_status_t modperl_interp_unselect(void *data) if (--interp->refcnt > 0) { MP_TRACE_i(MP_FUNC, "interp=0x%lx, refcnt=%d -- interp still in use", (unsigned long)interp, interp->refcnt); - MUTEX_UNLOCK(&interp->lock); return APR_SUCCESS; } if (!MpInterpIN_USE(interp)){ MP_TRACE_i(MP_FUNC, "interp=0x%pp, refcnt=%d -- interp already not in use", interp, interp->refcnt); - MUTEX_UNLOCK(&interp->lock); return APR_SUCCESS; } @@ -307,7 +302,7 @@ apr_status_t modperl_interp_unselect(void *data) MP_TRACE_i(MP_FUNC, "interp=%pp freed, tipool(size=%ld, in_use=%ld)", interp, tipool->size, tipool->in_use); } - MUTEX_UNLOCK(&interp->lock); + return APR_SUCCESS; } @@ -434,7 +429,7 @@ modperl_interp_t *modperl_interp_select(request_rec *r, conn_rec *c, server_rec if (!((r || c) && modperl_threaded_mpm())) { interp = scfg->mip->parent; MpInterpIN_USE_On(interp); - interp->refcnt++; + interp->refcnt = 1; /* XXX: if no VirtualHosts w/ PerlOptions +Parent we can skip this */ PERL_SET_CONTEXT(interp->perl); /* let the perl interpreter point back to its interp */ @@ -457,14 +452,9 @@ modperl_interp_t *modperl_interp_select(request_rec *r, conn_rec *c, server_rec if (c) ccfg = modperl_config_con_get(c); - static perl_mutex lock = PTHREAD_MUTEX_INITIALIZER; - MUTEX_LOCK(&lock); if (p && (interp = modperl_interp_pool_get(p)) && MpInterpIN_USE(interp)) { - MUTEX_LOCK(&interp->lock); - MUTEX_UNLOCK(&lock); interp->refcnt++; interp->num_requests++; - MUTEX_UNLOCK(&interp->lock); MP_TRACE_i(MP_FUNC, "found interp 0x%lx (perl=0x%pp) in r->pool config, refcnt=%d", (unsigned long)interp, interp->perl, interp->refcnt); @@ -475,7 +465,6 @@ modperl_interp_t *modperl_interp_select(request_rec *r, conn_rec *c, server_rec MP_TRACE_i(MP_FUNC, "fetching interp for %s:%d", s->server_hostname, s->port); interp = modperl_interp_get(s); - MUTEX_LOCK(&interp->lock); MP_TRACE_i(MP_FUNC, " --> got %pp (perl=%pp)", interp, interp->perl); ++interp->num_requests; /* should only get here once per request */ interp->refcnt = 1; @@ -512,8 +501,6 @@ modperl_interp_t *modperl_interp_select(request_rec *r, conn_rec *c, server_rec */ interp->refcnt++, set_interp(p), interp->pool = p; - MUTEX_UNLOCK(&interp->lock); - MUTEX_UNLOCK(&lock); return interp; } diff --git a/src/modules/perl/modperl_types.h b/src/modules/perl/modperl_types.h index 24bbfdfa5..42090c1fd 100644 --- a/src/modules/perl/modperl_types.h +++ b/src/modules/perl/modperl_types.h @@ -67,7 +67,6 @@ struct modperl_interp_t { #ifdef MP_TRACE unsigned long tid; #endif - perl_mutex lock; }; typedef struct { From 8f744af81f3af36e4144fd2030e32cbef82b3c36 Mon Sep 17 00:00:00 2001 From: Joe Schaefer Date: Mon, 13 Apr 2026 18:44:38 -0400 Subject: [PATCH 08/11] bugs:must-walk-r-main --- src/modules/perl/modperl_config.c | 2 +- src/modules/perl/modperl_interp.c | 6 ++++-- xs/APR/Pool/APR__Pool.h | 36 +++---------------------------- 3 files changed, 8 insertions(+), 36 deletions(-) diff --git a/src/modules/perl/modperl_config.c b/src/modules/perl/modperl_config.c index 9372a9a14..bd7b02635 100644 --- a/src/modules/perl/modperl_config.c +++ b/src/modules/perl/modperl_config.c @@ -366,7 +366,7 @@ apr_status_t modperl_config_request_cleanup(pTHX_ request_rec *r) apr_status_t modperl_config_req_cleanup(void *data) { request_rec *r = (request_rec *)data; - apr_pool_t *p = ap_is_initial_req(r) ? r->pool : r->main->pool; + apr_pool_t *p = r->main ? r->main->pool : r->pool; modperl_interp_t *interp = modperl_interp_pool_get(p); if (interp && interp->perl) return modperl_config_request_cleanup(interp->perl, r); diff --git a/src/modules/perl/modperl_interp.c b/src/modules/perl/modperl_interp.c index c9ba10edb..551ef5a15 100644 --- a/src/modules/perl/modperl_interp.c +++ b/src/modules/perl/modperl_interp.c @@ -442,8 +442,10 @@ modperl_interp_t *modperl_interp_select(request_rec *r, conn_rec *c, server_rec return interp; } - if (r && !ap_is_initial_req(r)) + while (r && r->main) { + MP_TRACE_i(MP_FUNC, "subrequest: r=%pp (r->main=%pp):%s", r, r->main, r->uri); r = r->main; + } p = r ? r->pool : c ? c->pool : NULL; @@ -461,7 +463,7 @@ modperl_interp_t *modperl_interp_select(request_rec *r, conn_rec *c, server_rec PERL_SET_CONTEXT(interp->perl); return interp; } - + assert(interp == NULL); MP_TRACE_i(MP_FUNC, "fetching interp for %s:%d", s->server_hostname, s->port); interp = modperl_interp_get(s); diff --git a/xs/APR/Pool/APR__Pool.h b/xs/APR/Pool/APR__Pool.h index be52c33ee..cce5ded01 100644 --- a/xs/APR/Pool/APR__Pool.h +++ b/xs/APR/Pool/APR__Pool.h @@ -72,15 +72,6 @@ APR_OPTIONAL_FN_TYPE(modperl_thx_interp_get) *modperl_opt_thx_interp_get; #define MP_APR_POOL_SV_DROPS_OWNERSHIP(acct) STMT_START { \ dTHXa(acct->perl); \ MP_APR_POOL_SV_DROPS_OWNERSHIP_RUN(acct); \ - if (modperl_opt_interp_unselect && acct->interp) { \ - /* this will decrement the interp refcnt until \ - * there are no more references, in which case \ - * the interpreter will be putback into the mip \ - */ \ - MP_TRACE_i(MP_FUNC, "DO: calling interp_unselect(0x%lx)", \ - acct->interp); \ - (void)modperl_opt_interp_unselect(acct->interp); \ - } \ } STMT_END #define MP_APR_POOL_SV_TAKES_OWNERSHIP(acct_sv, pool) STMT_START { \ @@ -89,23 +80,13 @@ APR_OPTIONAL_FN_TYPE(modperl_thx_interp_get) *modperl_opt_thx_interp_get; acct->perl = aTHX; \ SvIVX(acct_sv) = PTR2IV(pool); \ \ - sv_magic(acct_sv, (SV *)NULL, PERL_MAGIC_ext, \ + sv_magic(acct_sv, (SV *)NULL, PERL_MAGIC_ext, \ MP_APR_POOL_NEW, sizeof(MP_APR_POOL_NEW)); \ \ apr_pool_cleanup_register(pool, (void *)acct, \ mpxs_apr_pool_cleanup, \ apr_pool_cleanup_null); \ \ - /* make sure interpreter is not putback into the mip \ - * until this cleanup has run. \ - */ \ - if (modperl_opt_thx_interp_get) { \ - if ((acct->interp = modperl_opt_thx_interp_get(aTHX))) { \ - /* acct->interp->refcnt++;*/ \ - /* MP_TRACE_i(MP_FUNC, "TO: (0x%lx)->refcnt incremented to %ld", */ \ - /* acct->interp, acct->interp->refcnt); */ \ - ;} \ - } \ } STMT_END #else /* !USE_ITHREADS */ @@ -317,8 +298,8 @@ static apr_status_t mpxs_cleanup_run(void *data) * there are no more references, in which case * the interpreter will be putback into the mip */ - MP_TRACE_i(MP_FUNC, "calling interp_unselect(0x%lx)", cdata->interp); - (void)modperl_opt_interp_unselect(cdata->interp); +// MP_TRACE_i(MP_FUNC, "calling interp_unselect(0x%lx)", cdata->interp); +// (void)modperl_opt_interp_unselect(cdata->interp); } #endif @@ -343,17 +324,6 @@ static MP_INLINE void mpxs_apr_pool_cleanup_register(pTHX_ apr_pool_t *p, data->p = p; #ifdef USE_ITHREADS data->perl = aTHX; - /* make sure interpreter is not putback into the mip - * until this cleanup has run. - */ - if (modperl_opt_thx_interp_get) { - if ((data->interp = modperl_opt_thx_interp_get(data->perl))) { - /* data->interp->refcnt++; */ - /* MP_TRACE_i(MP_FUNC, "(0x%lx)->refcnt incremented to %ld", - data->interp, data->interp->refcnt); */ - ; - } - } #endif apr_pool_cleanup_register(p, data, From 408404040e1d9d398017eb286f68cf998fd9f6f4 Mon Sep 17 00:00:00 2001 From: Joe Schaefer Date: Fri, 17 Apr 2026 16:10:04 -0400 Subject: [PATCH 09/11] not-a-bug-in-http2-after-all --- src/modules/perl/modperl_interp.c | 15 --------------- 1 file changed, 15 deletions(-) diff --git a/src/modules/perl/modperl_interp.c b/src/modules/perl/modperl_interp.c index 551ef5a15..cd67f1289 100644 --- a/src/modules/perl/modperl_interp.c +++ b/src/modules/perl/modperl_interp.c @@ -486,21 +486,6 @@ modperl_interp_t *modperl_interp_select(request_rec *r, conn_rec *c, server_rec "pulled interp %pp (perl=%pp) from mip, num_requests is %d", interp, interp->perl, interp->num_requests); if (r) - /* it is correct to bump the refcnt below, assuming mod_http2's h2_stream.c is patched: - - -@@ -659,16 +659,16 @@ apr_status_t h2_stream_set_request_rec(h2_stream *stream, - if (stream->rst_error) { - return APR_ECONNRESET; - } -- status = h2_request_rcreate(&req, stream->pool, r, -+ status = h2_request_rcreate(&req, r->pool, r, - &stream->session->hd_scratch); - if (status == APR_SUCCESS) { - - - - */ interp->refcnt++, set_interp(p), interp->pool = p; return interp; From 32fcf0bb518dbd279cb93f10c7a85bca59d99d80 Mon Sep 17 00:00:00 2001 From: Joe Schaefer Date: Wed, 22 Apr 2026 09:39:03 -0400 Subject: [PATCH 10/11] nuke --- src/modules/perl/modperl_module.c | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/modules/perl/modperl_module.c b/src/modules/perl/modperl_module.c index 4386b1c9c..1996a0a34 100644 --- a/src/modules/perl/modperl_module.c +++ b/src/modules/perl/modperl_module.c @@ -128,8 +128,6 @@ static apr_status_t modperl_module_config_obj_cleanup(void *data) MP_TRACE_c(MP_FUNC, "deleting ptr %pp from table %pp", cleanup->ptr, cleanup->table); -// MP_INTERP_PUTBACK(cleanup->interp, aTHX); - return APR_SUCCESS; } @@ -145,7 +143,6 @@ static void modperl_module_config_obj_cleanup_register(pTHX_ cleanup->ptr = ptr; #ifdef USE_ITHREADS cleanup->interp = modperl_thx_interp_get(aTHX); -// MP_INTERP_REFCNT_inc(cleanup->interp); #endif apr_pool_cleanup_register(p, cleanup, From a3f5733522d85dc5e8b43778903a8fa6a6467bb9 Mon Sep 17 00:00:00 2001 From: Joe Schaefer Date: Thu, 23 Apr 2026 16:00:48 -0400 Subject: [PATCH 11/11] polish --- src/modules/perl/modperl_filter.c | 2 +- src/modules/perl/modperl_interp.c | 2 +- xs/APR/Pool/APR__Pool.h | 11 ----------- xs/Apache2/Filter/Apache2__Filter.h | 1 - 4 files changed, 2 insertions(+), 14 deletions(-) diff --git a/src/modules/perl/modperl_filter.c b/src/modules/perl/modperl_filter.c index 76be3e07c..72070a8b2 100644 --- a/src/modules/perl/modperl_filter.c +++ b/src/modules/perl/modperl_filter.c @@ -283,7 +283,7 @@ static apr_status_t modperl_filter_f_cleanup(void *data) if (ctx->data){ #ifdef USE_ITHREADS dTHXa(ctx->interp->perl); -// MP_ASSERT_CONTEXT(aTHX); + MP_ASSERT_CONTEXT(aTHX); #endif if (SvOK(ctx->data) && SvREFCNT(ctx->data)) { SvREFCNT_dec(ctx->data); diff --git a/src/modules/perl/modperl_interp.c b/src/modules/perl/modperl_interp.c index cd67f1289..50daac148 100644 --- a/src/modules/perl/modperl_interp.c +++ b/src/modules/perl/modperl_interp.c @@ -463,7 +463,7 @@ modperl_interp_t *modperl_interp_select(request_rec *r, conn_rec *c, server_rec PERL_SET_CONTEXT(interp->perl); return interp; } - assert(interp == NULL); + MP_TRACE_i(MP_FUNC, "fetching interp for %s:%d", s->server_hostname, s->port); interp = modperl_interp_get(s); diff --git a/xs/APR/Pool/APR__Pool.h b/xs/APR/Pool/APR__Pool.h index cce5ded01..fbab14bf6 100644 --- a/xs/APR/Pool/APR__Pool.h +++ b/xs/APR/Pool/APR__Pool.h @@ -292,17 +292,6 @@ static apr_status_t mpxs_cleanup_run(void *data) SvREFCNT_dec(cdata->arg); } -#ifdef USE_ITHREADS - if (cdata->interp && modperl_opt_interp_unselect) { - /* this will decrement the interp refcnt until - * there are no more references, in which case - * the interpreter will be putback into the mip - */ -// MP_TRACE_i(MP_FUNC, "calling interp_unselect(0x%lx)", cdata->interp); -// (void)modperl_opt_interp_unselect(cdata->interp); - } -#endif - /* the return value is ignored by apr_pool_destroy anyway */ return APR_SUCCESS; } diff --git a/xs/Apache2/Filter/Apache2__Filter.h b/xs/Apache2/Filter/Apache2__Filter.h index 51dd28335..1fcaf8ab8 100644 --- a/xs/Apache2/Filter/Apache2__Filter.h +++ b/xs/Apache2/Filter/Apache2__Filter.h @@ -198,7 +198,6 @@ static MP_INLINE SV *mpxs_Apache2__Filter_ctx(pTHX_ #ifdef USE_ITHREADS if (!ctx->interp) { ctx->interp = modperl_thx_interp_get(aTHX); -// MP_INTERP_REFCNT_inc(ctx->interp); } #endif ctx->data = SvREFCNT_inc(data);