Skip to content

Commit

Permalink
Avoid creating GVs when subs are declared
Browse files Browse the repository at this point in the history
This patch changes ‘sub foo {...}’ declarations to store subroutine
references in the stash, to save memory.

Typeglobs still notionally exist.  Accessing CvGV(cv) will reify them.
Hence, currently the savings are lost when a sub call is compiled.

$ ./miniperl -e 'sub foo{} BEGIN { warn $::{foo} } foo(); BEGIN { warn $::{foo} }'
CODE(0x7f8ef082ad98) at -e line 1.
*main::foo at -e line 1.

This optimisation is skipped if the subroutine declaration contains a
package separator.

Concerning the changes in caller.t, this code:

    sub foo { print +(caller(0))[3],"\n" }
    my $fooref = delete $::{foo};
    $fooref -> ();

used to crash in 5.7.3 or thereabouts.  It was fixed by 16658 (aka
07b8c80) to produce ‘(unknown)’ instead.  Then in 5.13.3 it was
changed (by 803f274) to produce ‘main::__ANON__’ instead.  So the
tests are really checking that we don’t get a crash.  I think it is
acceptable that it has now changed to ‘main::foo’.
  • Loading branch information
Father Chrysostomos committed Sep 15, 2014
1 parent c831c5e commit 2eaf799
Show file tree
Hide file tree
Showing 11 changed files with 225 additions and 53 deletions.
2 changes: 1 addition & 1 deletion embed.fnc
Expand Up @@ -1941,7 +1941,7 @@ s |OP* |newGIVWHENOP |NULLOK OP* cond|NN OP *block \
|I32 enter_opcode|I32 leave_opcode \
|PADOFFSET entertarg
s |OP* |ref_array_or_hash|NULLOK OP* cond
s |void |process_special_blocks |I32 floor \
s |bool |process_special_blocks |I32 floor \
|NN const char *const fullname\
|NN GV *const gv|NN CV *const cv
s |void |clear_special_blocks |NN const char *const fullname\
Expand Down
31 changes: 26 additions & 5 deletions gv.c
Expand Up @@ -260,17 +260,25 @@ GV *
Perl_cvgv_from_hek(pTHX_ CV *cv)
{
GV *gv;
SV **svp;
PERL_ARGS_ASSERT_CVGV_FROM_HEK;
assert(SvTYPE(cv) == SVt_PVCV);
if (!CvSTASH(cv)) return NULL;
ASSUME(CvNAME_HEK(cv));
gv = (GV *)newSV(0);
gv_init_pvn(gv, CvSTASH(cv), HEK_KEY(CvNAME_HEK(cv)),
svp = hv_fetchhek(CvSTASH(cv), CvNAME_HEK(cv), 0);
gv = MUTABLE_GV(svp && *svp ? *svp : newSV(0));
if (!isGV(gv))
gv_init_pvn(gv, CvSTASH(cv), HEK_KEY(CvNAME_HEK(cv)),
HEK_LEN(CvNAME_HEK(cv)),
SVf_UTF8 * !!HEK_UTF8(CvNAME_HEK(cv)));
if (!CvNAMED(cv)) { /* gv_init took care of it */
assert (SvANY(cv)->xcv_gv_u.xcv_gv == gv);
return gv;
}
unshare_hek(CvNAME_HEK(cv));
CvNAMED_off(cv);
SvANY(cv)->xcv_gv_u.xcv_gv = gv;
if (svp && *svp) SvREFCNT_inc_simple_void_NN(gv);
CvCVGV_RC_on(cv);
return gv;
}
Expand Down Expand Up @@ -370,10 +378,9 @@ Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flag
assert (!(proto && has_constant));

if (has_constant) {
/* The constant has to be a simple scalar type. */
/* The constant has to be a scalar, array or subroutine. */
switch (SvTYPE(has_constant)) {
case SVt_PVHV:
case SVt_PVCV:
case SVt_PVFM:
case SVt_PVIO:
Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
Expand Down Expand Up @@ -409,7 +416,21 @@ Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flag
gv_name_set(gv, name, len, GV_ADD | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ));
if (flags & GV_ADDMULTI || doproto) /* doproto means it */
GvMULTI_on(gv); /* _was_ mentioned */
if (doproto) {
if (has_constant && SvTYPE(has_constant) == SVt_PVCV) {
/* Not actually a constant. Just a regular sub. */
CV * const cv = (CV *)has_constant;
GvCV_set(gv,cv);
if (CvSTASH(cv) == stash && (
CvNAME_HEK(cv) == GvNAME_HEK(gv)
|| ( HEK_LEN(CvNAME_HEK(cv)) == HEK_LEN(GvNAME_HEK(gv))
&& HEK_FLAGS(CvNAME_HEK(cv)) != HEK_FLAGS(GvNAME_HEK(gv))
&& HEK_UTF8(CvNAME_HEK(cv)) == HEK_UTF8(GvNAME_HEK(gv))
&& memEQ(HEK_KEY(CvNAME_HEK(cv)), GvNAME(gv), GvNAMELEN(gv))
)
))
CvGV_set(cv,gv);
}
else if (doproto) {
CV *cv;
if (has_constant) {
/* newCONSTSUB takes ownership of the reference from us. */
Expand Down

0 comments on commit 2eaf799

Please sign in to comment.