Advanced
Mailing List Archive

Mailing List Archive

  1. Home >
  2. Perl>
  3. porters
G_KEEPERR efficiency update
gsar at engin
Oct 28, 1995, 10:11 AM
Post #1 of 6 (809 views)
Permalink
Here's a more efficient, updated G_KEEPERR patch. This one was coerced
out of Mr. Laziness Me by Tim Bunce. :-)

The only change is in the pp_ctl.c hunk.
(and don't forget to run 'make regen_headers' before make)

- Sarathy.
gsar@engin.umich.edu
----------------------------------8<----------------------------------
*** toke.c.old Tue Oct 10 12:13:24 1995
--- toke.c Wed Oct 18 19:35:58 1995
***************
*** 4851,4857 ****
if (in_eval & 2)
warn("%s",buf);
else if (in_eval)
! sv_catpv(GvSV(gv_fetchpv("@",TRUE, SVt_PV)),buf);
else
fputs(buf,stderr);
if (++error_count >= 10)
--- 4851,4857 ----
if (in_eval & 2)
warn("%s",buf);
else if (in_eval)
! sv_catpv(GvSV(errgv),buf);
else
fputs(buf,stderr);
if (++error_count >= 10)
*** perl.c.old Thu Jun 22 18:38:28 1995
--- perl.c Wed Oct 18 19:44:37 1995
***************
*** 671,677 ****

cLOGOP->op_other = op;
markstack_ptr--;
! pp_entertry();
markstack_ptr++;

restart:
--- 671,695 ----

cLOGOP->op_other = op;
markstack_ptr--;
! /* we're trying to emulate pp_entertry() here */
! {
! register CONTEXT *cx;
! I32 gimme = GIMME;
!
! ENTER;
! SAVETMPS;
!
! push_return(op->op_next);
! PUSHBLOCK(cx, CXt_EVAL, stack_sp);
! PUSHEVAL(cx, 0, 0);
! eval_root = op; /* Only needed so that goto works right. */
!
! in_eval = 1;
! if (flags & G_KEEPERR)
! in_eval |= 4;
! else
! sv_setpv(GvSV(errgv),"");
! }
markstack_ptr++;

restart:
***************
*** 716,723 ****
if (op)
run();
retval = stack_sp - (stack_base + oldmark);
! if (flags & G_EVAL)
! sv_setpv(GvSV(gv_fetchpv("@",TRUE, SVt_PV)),"");

cleanup:
if (flags & G_EVAL) {
--- 734,741 ----
if (op)
run();
retval = stack_sp - (stack_base + oldmark);
! if ((flags & G_EVAL) && !(flags & G_KEEPERR))
! sv_setpv(GvSV(errgv),"");

cleanup:
if (flags & G_EVAL) {
***************
*** 1077,1082 ****
--- 1095,1102 ----
incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
SvMULTI_on(incgv);
defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
+ errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
+ SvMULTI_on(errgv);
curstash = defstash;
compiling.cop_stash = defstash;
debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
***************
*** 1721,1727 ****

switch (setjmp(top_env)) {
case 0: {
! SV* atsv = GvSV(gv_fetchpv("@",TRUE, SVt_PV));
PUSHMARK(stack_sp);
perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
(void)SvPV(atsv, len);
--- 1741,1747 ----

switch (setjmp(top_env)) {
case 0: {
! SV* atsv = GvSV(errgv);
PUSHMARK(stack_sp);
perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
(void)SvPV(atsv, len);
*** pp_ctl.c.old Tue Sep 5 21:52:09 1995
--- pp_ctl.c Wed Oct 28 11:27:55 1995
***************
*** 942,953 ****
register CONTEXT *cx;
I32 gimme;
SV **newsp;
- SV *errsv;

! errsv = GvSV(gv_fetchpv("@",TRUE, SVt_PV));
! /* As destructors may produce errors we set $@ at the last moment */
! sv_setpv(errsv, ""); /* clear $@ before destroying */
!
cxix = dopoptoeval(cxstack_ix);
if (cxix >= 0) {
I32 optype;
--- 942,968 ----
register CONTEXT *cx;
I32 gimme;
SV **newsp;

! if (in_eval & 4) {
! SV **svp;
! STRLEN klen = strlen(message);
!
! svp = hv_fetch(GvHV(errgv), message, klen, TRUE);
! if (svp) {
! if (!SvIOK(*svp)) {
! static char prefix[] = "\t(in cleanup) ";
! sv_upgrade(*svp, SVt_IV);
! SvIOK_only(*svp);
! SvGROW(GvSV(errgv), SvCUR(GvSV(errgv))+sizeof(prefix)+klen);
! sv_catpvn(GvSV(errgv), prefix, sizeof(prefix)-1);
! sv_catpvn(GvSV(errgv), message, klen);
! }
! sv_inc(*svp);
! }
! }
! else
! sv_catpv(GvSV(errgv), message);
!
cxix = dopoptoeval(cxstack_ix);
if (cxix >= 0) {
I32 optype;
***************
*** 968,976 ****

LEAVE;

- sv_insert(errsv, 0, 0, message, strlen(message));
if (optype == OP_REQUIRE)
! DIE("%s", SvPVx(GvSV(gv_fetchpv("@",TRUE, SVt_PV)), na));
return pop_return();
}
}
--- 983,990 ----

LEAVE;

if (optype == OP_REQUIRE)
! DIE("%s", SvPVx(GvSV(errgv), na));
return pop_return();
}
}
***************
*** 1925,1931 ****
rslen = 1;
rschar = '\n';
rspara = 0;
! sv_setpv(GvSV(gv_fetchpv("@",TRUE, SVt_PV)),"");
if (yyparse() || error_count || !eval_root) {
SV **newsp;
I32 gimme;
--- 1940,1946 ----
rslen = 1;
rschar = '\n';
rspara = 0;
! sv_setpv(GvSV(errgv),"");
if (yyparse() || error_count || !eval_root) {
SV **newsp;
I32 gimme;
***************
*** 1943,1949 ****
lex_end();
LEAVE;
if (optype == OP_REQUIRE)
! DIE("%s", SvPVx(GvSV(gv_fetchpv("@",TRUE, SVt_PV)), na));
rs = nrs;
rslen = nrslen;
rschar = nrschar;
--- 1958,1964 ----
lex_end();
LEAVE;
if (optype == OP_REQUIRE)
! DIE("%s", SvPVx(GvSV(errgv), na));
rs = nrs;
rslen = nrslen;
rschar = nrschar;
***************
*** 2182,2188 ****

lex_end();
LEAVE;
! sv_setpv(GvSV(gv_fetchpv("@",TRUE, SVt_PV)),"");

RETURNOP(retop);
}
--- 2196,2202 ----

lex_end();
LEAVE;
! sv_setpv(GvSV(errgv),"");

RETURNOP(retop);
}
***************
*** 2202,2208 ****
eval_root = op; /* Only needed so that goto works right. */

in_eval = 1;
! sv_setpv(GvSV(gv_fetchpv("@",TRUE, SVt_PV)),"");
RETURN;
}

--- 2216,2222 ----
eval_root = op; /* Only needed so that goto works right. */

in_eval = 1;
! sv_setpv(GvSV(errgv),"");
RETURN;
}

***************
*** 2247,2253 ****
curpm = newpm; /* Don't pop $1 et al till now */

LEAVE;
! sv_setpv(GvSV(gv_fetchpv("@",TRUE, SVt_PV)),"");
RETURN;
}

--- 2261,2267 ----
curpm = newpm; /* Don't pop $1 et al till now */

LEAVE;
! sv_setpv(GvSV(errgv),"");
RETURN;
}

*** pp_sys.c.dist Thu Jun 1 18:06:10 1995
--- pp_sys.c Wed Oct 18 19:33:58 1995
***************
*** 192,198 ****
tmps = SvPV(TOPs, na);
}
if (!tmps || !*tmps) {
! SV *error = GvSV(gv_fetchpv("@", TRUE, SVt_PV));
(void)SvUPGRADE(error, SVt_PV);
if (SvPOK(error) && SvCUR(error))
sv_catpv(error, "\t...caught");
--- 192,198 ----
tmps = SvPV(TOPs, na);
}
if (!tmps || !*tmps) {
! SV *error = GvSV(errgv);
(void)SvUPGRADE(error, SVt_PV);
if (SvPOK(error) && SvCUR(error))
sv_catpv(error, "\t...caught");
***************
*** 218,224 ****
tmps = SvPV(TOPs, na);
}
if (!tmps || !*tmps) {
! SV *error = GvSV(gv_fetchpv("@", TRUE, SVt_PV));
(void)SvUPGRADE(error, SVt_PV);
if (SvPOK(error) && SvCUR(error))
sv_catpv(error, "\t...propagated");
--- 218,224 ----
tmps = SvPV(TOPs, na);
}
if (!tmps || !*tmps) {
! SV *error = GvSV(errgv);
(void)SvUPGRADE(error, SVt_PV);
if (SvPOK(error) && SvCUR(error))
sv_catpv(error, "\t...propagated");
*** perl.h.old Thu Jun 22 18:38:30 1995
--- perl.h Wed Oct 18 18:48:45 1995
***************
*** 1247,1252 ****
--- 1247,1255 ----
IEXT I32 Imaxscream IINIT(-1);
IEXT SV * Ilastscream;

+ /* shortcuts to misc objects */
+ IEXT GV * Ierrgv;
+
/* shortcuts to debugging objects */
IEXT GV * IDBgv;
IEXT GV * IDBline;
*** interp.sym.old Thu Jun 22 18:38:19 1995
--- interp.sym Wed Oct 18 18:42:50 1995
***************
*** 47,52 ****
--- 47,53 ----
e_tmpname
endav
envgv
+ errgv
eval_root
eval_start
fdpid
*** sv.c.old Fri Aug 18 18:33:54 1995
--- sv.c Wed Sep 13 21:04:55 1995
***************
*** 2129,2135 ****
PUSHMARK(SP);
PUSHs(&ref);
PUTBACK;
! perl_call_sv((SV*)destructor, G_DISCARD|G_EVAL);
del_XRV(SvANY(&ref));
}
LEAVE;
--- 2129,2135 ----
PUSHMARK(SP);
PUSHs(&ref);
PUTBACK;
! perl_call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
del_XRV(SvANY(&ref));
}
LEAVE;
*** cop.h.dist Sun Mar 12 22:25:47 1995
--- cop.h Tue Sep 5 18:14:17 1995
***************
*** 231,233 ****
--- 231,234 ----
#define G_DISCARD 2 /* Call FREETMPS. */
#define G_EVAL 4 /* Assume eval {} around subroutine call. */
#define G_NOARGS 8 /* Don't construct a @_ array. */
+ #define G_KEEPERR 16 /* Append errors to $@ rather than overwriting it */
Re: G_KEEPERR efficiency update [ In reply to ]
Tim.Bunce at ig
Oct 30, 1995, 3:41 PM
Post #2 of 6 (797 views)
Permalink
> From: Gurusamy Sarathy <gsar@engin.umich.edu>

> ! if (in_eval & 4) {
> ! SV **svp;
> ! STRLEN klen = strlen(message);
> !
> ! svp = hv_fetch(GvHV(errgv), message, klen, TRUE);
> ! if (svp) {
> ! if (!SvIOK(*svp)) {
> ! static char prefix[] = "\t(in cleanup) ";
> ! sv_upgrade(*svp, SVt_IV);
> ! SvIOK_only(*svp);
> ! SvGROW(GvSV(errgv), SvCUR(GvSV(errgv))+sizeof(prefix)+klen);
> ! sv_catpvn(GvSV(errgv), prefix, sizeof(prefix)-1);
> ! sv_catpvn(GvSV(errgv), message, klen);
> ! }
> ! sv_inc(*svp);
> ! }
> ! }
> ! else
> ! sv_catpv(GvSV(errgv), message);
> !

I think the SvGROW needs a +1 to avoid the second sv_catpvn from triggering a
second grow since sv_grow does not take into account the extra space needed
for the trailing '\0' that perl always adds.

My earlier message to Gurusamy probably got lost.

Tim.
Re: G_KEEPERR efficiency update [ In reply to ]
lwall at scalpel
Oct 30, 1995, 4:02 PM
Post #3 of 6 (797 views)
Permalink
: > ! static char prefix[] = "\t(in cleanup) ";
: > ! SvGROW(GvSV(errgv), SvCUR(GvSV(errgv))+sizeof(prefix)+klen);
:
: I think the SvGROW needs a +1 to avoid the second sv_catpvn from triggering a
: second grow since sv_grow does not take into account the extra space needed
: for the trailing '\0' that perl always adds.

There's already a +1 implied by sizeof(prefix), which has an unused \0
on the end.

Larry
Re: G_KEEPERR efficiency update [ In reply to ]
gsar at engin
Oct 30, 1995, 5:15 PM
Post #4 of 6 (796 views)
Permalink
On Mon, 30 Oct 1995 22:41:31 GMT, Tim Bunce wrote:
>> From: Gurusamy Sarathy <gsar@engin.umich.edu>
>> ! SvGROW(GvSV(errgv), SvCUR(GvSV(errgv))+sizeof(prefix)+klen)
>
>I think the SvGROW needs a +1 to avoid the second sv_catpvn from triggering a
>second grow since sv_grow does not take into account the extra space needed
>for the trailing '\0' that perl always adds.

No, I thought I already replied to your earlier message (two days ago) that

sizeof(sv) == strlen(sv) + 1

so the above is just right.

- Sarathy.
gsar@engin.umich.edu
Re: G_KEEPERR efficiency update [ In reply to ]
Tim.Bunce at ig
Oct 30, 1995, 5:23 PM
Post #5 of 6 (797 views)
Permalink
> From: Larry Wall <lwall@scalpel.netlabs.com>
>
> : > ! static char prefix[] = "\t(in cleanup) ";
> : > ! SvGROW(GvSV(errgv), SvCUR(GvSV(errgv))+sizeof(prefix)+klen);
> :
> : I think the SvGROW needs a +1 to avoid the second sv_catpvn from triggering a
> : second grow since sv_grow does not take into account the extra space needed
> : for the trailing '\0' that perl always adds.
>
> There's already a +1 implied by sizeof(prefix), which has an unused \0
> on the end.
>
> Larry

:-)

Okay, time to go home.

Tim.
Re: G_KEEPERR efficiency update [ In reply to ]
Tim.Bunce at ig
Oct 30, 1995, 5:27 PM
Post #6 of 6 (797 views)
Permalink
> From: Gurusamy Sarathy <gsar@engin.umich.edu>
>
> On Mon, 30 Oct 1995 22:41:31 GMT, Tim Bunce wrote:
> >> From: Gurusamy Sarathy <gsar@engin.umich.edu>
> >> ! SvGROW(GvSV(errgv), SvCUR(GvSV(errgv))+sizeof(prefix)+klen)
> >
> >I think the SvGROW needs a +1 to avoid the second sv_catpvn from triggering a
> >second grow since sv_grow does not take into account the extra space needed
> >for the trailing '\0' that perl always adds.
>
> No, I thought I already replied to your earlier message (two days ago) that
>
> sizeof(sv) == strlen(sv) + 1
>
> so the above is just right.

Sorry. It almost certainly got lost. Either externally, or internally
when my mail system was trying to deal with backlog of ~250 messages
which arrived in the last couple of hours! It's been syslog'ing all
sorts of wierd messages :(

Tim.

©2024 GT.net. A Gossamer Threads company.
5th Floor, 455 Granville St., Vancouver, BC V6C 1T1, Canada | Legal