This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add inlinable &CORE::functions
authorFather Chrysostomos <sprout@cpan.org>
Sat, 6 Aug 2011 07:20:06 +0000 (00:20 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Sun, 14 Aug 2011 19:23:30 +0000 (12:23 -0700)
This commit allows this to work:

  BEGIN { *entangle = \&CORE::tie };
  entangle $foo, $package;

And the entangle call gets inlined as a tie op, the resulting op tree
being indistinguishable.

These subs are not yet callable via &foo syntax or through a refer-
ence.  That will come later, except for some functions, like sort(),
which will probably never support it.

Almost all overridable functions are supported.  These few are not:

  - infix operators
  - not and getprotobynumber (can’t get the precedence right yet;
    prototype problem)
  - dump

Subsequent commits (hopefully!) will deal with those.

How this works:

gv_fetchpvn_flags is extended with hooks to create subs inside the
CORE package.  Those subs are XSUBs (whose C function dies with an
error, for now at least) with a call checker that blows away the
entersub op and replaces it with whatever op the sub represents.

This is slightly inefficient right now, as gv_fetchpvn_flags calls
keyword(), only to have core_prototype call it again.  That will
be fixed in a future refactoring.

MANIFEST
embed.fnc
gv.c
lib/CORE.pod
op.c
pod/perldiag.pod
pod/perlsub.pod
proto.h
t/op/coreinline.t [new file with mode: 0644]

index a81d4ac..8e999d7 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -4917,6 +4917,7 @@ t/op/concat2.t                    Tests too complex for concat.t
 t/op/concat.t                  See if string concatenation works
 t/op/cond.t                    See if conditional expressions work
 t/op/context.t                 See if context propagation works
+t/op/coreinline.t              Test inlining of \&CORE::subs
 t/op/cproto.t                  Check builtin prototypes
 t/op/crypt.t                   See if crypt works
 t/op/dbm.t                     See if dbmopen/dbmclose work
index 04f8551..0cdaf5a 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -880,6 +880,8 @@ Apd |CV*    |rv2cv_op_cv    |NN OP *cvop|U32 flags
 Apd    |OP*    |ck_entersub_args_list|NN OP *entersubop
 Apd    |OP*    |ck_entersub_args_proto|NN OP *entersubop|NN GV *namegv|NN SV *protosv
 Apd    |OP*    |ck_entersub_args_proto_or_list|NN OP *entersubop|NN GV *namegv|NN SV *protosv
+po     |OP*    |ck_entersub_args_core|NN OP *entersubop|NN GV *namegv \
+                                     |NN SV *protosv
 Apd    |void   |cv_get_call_checker|NN CV *cv|NN Perl_call_checker *ckfun_p|NN SV **ckobj_p
 Apd    |void   |cv_set_call_checker|NN CV *cv|NN Perl_call_checker ckfun|NN SV *ckobj
 Apa    |PERL_SI*|new_stackinfo|I32 stitems|I32 cxitems
@@ -1645,7 +1647,7 @@ s |void   |bad_type       |I32 n|NN const char *t|NN const char *name|NN const OP *kid
 s      |void   |no_bareword_allowed|NN OP *o
 sR     |OP*    |no_fh_allowed|NN OP *o
 sR     |OP*    |too_few_arguments|NN OP *o|NN const char* name
-sR     |OP*    |too_many_arguments|NN OP *o|NN const char* name
+s      |OP*    |too_many_arguments|NN OP *o|NN const char* name
 s      |bool   |looks_like_bool|NN const OP* o
 s      |OP*    |newGIVWHENOP   |NULLOK OP* cond|NN OP *block \
                                |I32 enter_opcode|I32 leave_opcode \
diff --git a/gv.c b/gv.c
index aef0aa4..8c2c1f1 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -36,6 +36,7 @@ Perl stores its global variables.
 #define PERL_IN_GV_C
 #include "perl.h"
 #include "overload.c"
+#include "keywords.h"
 
 static const char S_autoload[] = "AUTOLOAD";
 static const STRLEN S_autolen = sizeof(S_autoload)-1;
@@ -1033,6 +1034,8 @@ S_gv_magicalize_overload(pTHX_ GV *gv)
     hv_magic(hv, NULL, PERL_MAGIC_overload);
 }
 
+static void core_xsub(pTHX_ CV* cv);
+
 GV *
 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                       const svtype sv_type)
@@ -1297,7 +1300,8 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
     /* set up magic where warranted */
     if (stash != PL_defstash) { /* not the main stash */
        /* We only have to check for four names here: EXPORT, ISA, OVERLOAD
-          and VERSION. All the others apply only to the main stash. */
+          and VERSION. All the others apply only to the main stash or to
+          CORE (which is checked right after this). */
        if (len > 2) {
            const char * const name2 = name + 1;
            switch (*name) {
@@ -1317,7 +1321,53 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                if (strEQ(name2, "ERSION"))
                    GvMULTI_on(gv);
                break;
+           default:
+               goto try_core;
+           }
+           return gv;
+       }
+      try_core:
+       if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
+         /* Avoid null warning: */
+         const char * const stashname = HvNAME(stash); assert(stashname);
+         if (strnEQ(stashname, "CORE", 4)) {
+           const int code = keyword(name, len, 1);
+           static const char file[] = __FILE__;
+           CV *cv;
+           int opnum = 0;
+           SV *opnumsv;
+           if (code >= 0) return gv; /* not overridable */
+            /* no support for \&CORE::infix;
+               no support for &CORE::not or &CORE::getprotobynumber
+               either, yet, as we cannot get the precedence right;
+               no support for funcs that take labels, as their parsing is
+               weird  */
+           switch (-code) {
+           case KEY_and: case KEY_cmp: case KEY_CORE: case KEY_dump:
+           case KEY_eq: case KEY_ge:
+           case KEY_getprotobynumber: case KEY_gt: case KEY_le:
+           case KEY_lt: case KEY_ne: case KEY_not:
+           case KEY_or: case KEY_x: case KEY_xor:
+               return gv;
            }
+           /* Avoid calling newXS, as it calls us, and things start to
+              get hairy. */
+           cv = MUTABLE_CV(newSV_type(SVt_PVCV));
+           GvCV_set(gv,cv);
+           GvCVGEN(gv) = 0;
+           mro_method_changed_in(GvSTASH(gv));
+           CvGV_set(cv, gv);
+           (void)gv_fetchfile(file);
+           CvFILE(cv) = (char *)file;
+           CvISXSUB_on(cv);
+           CvXSUB(cv) = core_xsub;
+           (void)core_prototype((SV *)cv, name, len, &opnum, 0);
+           opnumsv = opnum ? newSVuv((UV)opnum) : (SV *)NULL;
+           cv_set_call_checker(
+              cv, Perl_ck_entersub_args_core, opnumsv ? opnumsv : (SV *)cv
+           );
+           SvREFCNT_dec(opnumsv);
+         }
        }
     }
     else if (len > 1) {
@@ -2780,6 +2830,16 @@ Perl_gv_try_downgrade(pTHX_ GV *gv)
     }
 }
 
+#include "XSUB.h"
+
+static void
+core_xsub(pTHX_ CV* cv)
+{
+    Perl_croak(aTHX_
+       "&CORE::%s cannot be called directly", GvNAME(CvGV(cv))
+    );
+}
+
 /*
  * Local variables:
  * c-indentation-style: bsd
index b96c1de..d2175eb 100644 (file)
@@ -1,6 +1,6 @@
 =head1 NAME
 
-CORE - Pseudo-namespace for Perl's core routines
+CORE - Namespace for Perl's core routines
 
 =head1 SYNOPSIS
 
@@ -12,17 +12,31 @@ CORE - Pseudo-namespace for Perl's core routines
     print CORE::hex("0x50"),"\n";              # prints 80
     CORE::say "yes";                           # prints yes
 
+    BEGIN { *shove = \&CORE::push; }
+    shove @array, 1,2,3;                       # pushes on to @array
+
 =head1 DESCRIPTION
 
 The C<CORE> namespace gives access to the original built-in functions of
-Perl.  It also provides access to keywords normally available
-only through the L<feature> pragma.  There is no C<CORE>
-package, and therefore you do not need to use or
+Perl.  The C<CORE> package is built into
+Perl, and therefore you do not need to use or
 require an hypothetical "CORE" module prior to accessing routines in this
 namespace.
 
 A list of the built-in functions in Perl can be found in L<perlfunc>.
 
+For all Perl keywords, a C<CORE::> prefix will force the built-in function
+to be used, even if it has been overridden or would normally require the
+L<feature> pragma.  Despite appearances, this has nothing to do with the
+CORE package, but is part of Perl's syntax.
+
+For many Perl functions, the CORE package contains real subroutines.  This
+feature is new in Perl 5.16.  You can take references to these and make
+aliases.  However, they can only be called as barewords; i.e., you cannot
+use ampersand syntax (C<&foo>) or call them through references.  See the
+C<shove> example above.  This works for all overridable keywords, except
+for C<dump>, C<getprotobynumber>, C<not> and the infix operators.
+
 =head1 OVERRIDING CORE FUNCTIONS
 
 To override a Perl built-in routine with your own version, you need to
diff --git a/op.c b/op.c
index 3f8f7c4..981655d 100644 (file)
--- a/op.c
+++ b/op.c
@@ -9221,6 +9221,95 @@ Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
        return ck_entersub_args_list(entersubop);
 }
 
+OP *
+Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
+{
+    int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
+    OP *aop = cUNOPx(entersubop)->op_first;
+
+    PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
+
+    if (!opnum) {
+       OP *prev, *cvop;
+       if (!aop->op_sibling)
+           aop = cUNOPx(aop)->op_first;
+       prev = aop;
+       aop = aop->op_sibling;
+       for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
+       if (PL_madskills) while (aop != cvop && aop->op_type == OP_STUB) {
+           aop = aop->op_sibling;
+           continue;
+       }
+       if (aop != cvop)
+           (void)too_many_arguments(entersubop, GvNAME(namegv));
+       
+       op_free(entersubop);
+       switch(GvNAME(namegv)[2]) {
+       case 'F': return newSVOP(OP_CONST, 0,
+                                       newSVpv(CopFILE(PL_curcop),0));
+       case 'L': return newSVOP(
+                          OP_CONST, 0,
+                           Perl_newSVpvf(aTHX_
+                            "%"IVdf, (IV)CopLINE(PL_curcop)
+                          )
+                        );
+       case 'P': return newSVOP(OP_CONST, 0,
+                                  (PL_curstash
+                                    ? newSVhek(HvNAME_HEK(PL_curstash))
+                                    : &PL_sv_undef
+                                  )
+                               );
+       }
+       assert(0);
+    }
+    else {
+       OP *prev, *cvop;
+       U32 paren;
+#ifdef PERL_MAD
+       bool seenarg = FALSE;
+#endif
+       if (!aop->op_sibling)
+           aop = cUNOPx(aop)->op_first;
+       
+       prev = aop;
+       aop = aop->op_sibling;
+       prev->op_sibling = NULL;
+       for (cvop = aop;
+            cvop->op_sibling;
+            prev=cvop, cvop = cvop->op_sibling)
+#ifdef PERL_MAD
+           if (PL_madskills && cvop->op_sibling
+            && cvop->op_type != OP_STUB) seenarg = TRUE
+#endif
+           ;
+       prev->op_sibling = NULL;
+       paren = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN);
+       op_free(cvop);
+       if (aop == cvop) aop = NULL;
+       op_free(entersubop);
+
+       switch (PL_opargs[opnum] & OA_CLASS_MASK) {
+       case OA_UNOP:
+       case OA_BASEOP_OR_UNOP:
+       case OA_FILESTATOP:
+           return aop ? newUNOP(opnum,paren,aop) : newOP(opnum,paren);
+       case OA_BASEOP:
+           if (aop) {
+#ifdef PERL_MAD
+               if (!PL_madskills || seenarg)
+#endif
+                   (void)too_many_arguments(aop, GvNAME(namegv));
+               op_free(aop);
+           }
+           return newOP(opnum,0);
+       default:
+           return convert(opnum,0,aop);
+       }
+    }
+    assert(0);
+    return entersubop;
+}
+
 /*
 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
 
index d35e364..4aa76e2 100644 (file)
@@ -1475,6 +1475,16 @@ workarounds.
 (F) The method which overloads "=" is buggy. See
 L<overload/Copy Constructor>.
 
+=item &CORE::%s cannot be called directly
+
+(F) You tried to call a subroutine in the C<CORE::> namespace
+with C<&foo> syntax or through a reference.  The subroutines
+in this package cannot yet be called that way, but must be
+called as barewords.  Something like this will work:
+
+    BEGIN { *shove = \&CORE::push; }
+    shove @array, 1,2,3; # pushes on to @array
+
 =item CORE::%s is not a keyword
 
 (F) The CORE:: namespace is reserved for Perl keywords.
index 4cc0b9c..d344c47 100644 (file)
@@ -1309,8 +1309,10 @@ built-in name with the special package qualifier C<CORE::>.  For example,
 saying C<CORE::open()> always refers to the built-in C<open()>, even
 if the current package has imported some other subroutine called
 C<&open()> from elsewhere.  Even though it looks like a regular
-function call, it isn't: you can't take a reference to it, such as
-the incorrect C<\&CORE::open> might appear to produce.
+function call, it isn't: the CORE:: prefix in that case is part of Perl's
+syntax, and works for any keyword, regardless of what is in the CORE
+package.  Taking a reference to it, that is, C<\&CORE::open>, only works
+for some keywords.  See L<CORE>.
 
 Library modules should not in general export built-in names like C<open>
 or C<chdir> as part of their default C<@EXPORT> list, because these may
diff --git a/proto.h b/proto.h
index 735f0cb..b5c2faa 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -314,6 +314,13 @@ PERL_CALLCONV OP * Perl_ck_each(pTHX_ OP *o)
 #define PERL_ARGS_ASSERT_CK_EACH       \
        assert(o)
 
+PERL_CALLCONV OP*      Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
+                       __attribute__nonnull__(pTHX_1)
+                       __attribute__nonnull__(pTHX_2)
+                       __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE \
+       assert(entersubop); assert(namegv); assert(protosv)
+
 PERL_CALLCONV OP*      Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
                        __attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST \
@@ -5613,7 +5620,6 @@ STATIC OP*        S_too_few_arguments(pTHX_ OP *o, const char* name)
        assert(o); assert(name)
 
 STATIC OP*     S_too_many_arguments(pTHX_ OP *o, const char* name)
-                       __attribute__warn_unused_result__
                        __attribute__nonnull__(pTHX_1)
                        __attribute__nonnull__(pTHX_2);
 #define PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS    \
diff --git a/t/op/coreinline.t b/t/op/coreinline.t
new file mode 100644 (file)
index 0000000..b4f8796
--- /dev/null
@@ -0,0 +1,91 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = qw(. ../lib);
+    require "test.pl";
+    skip_all_without_dynamic_extension('B');
+    $^P |= 0x100;
+}
+
+use B::Deparse;
+my $bd = new B::Deparse;
+
+my %unsupported = map +($_=>1), qw (CORE and cmp dump eq ge gt le
+                                    getprotobynumber lt ne not or x xor);
+my %args_for = (
+  dbmopen  => '%1,$2,$3',
+  dbmclose => '%1',
+);
+
+use File::Spec::Functions;
+my $keywords_file = catfile(updir,'regen','keywords.pl');
+open my $kh, $keywords_file
+   or die "$0 cannot open $keywords_file: $!";
+while(<$kh>) {
+  if (m?__END__?..${\0} and /^[+-]/) {
+    chomp(my $word = $');
+    if($& eq '+' || $unsupported{$word}) {
+      $tests ++;
+      ok !defined &{\&{"CORE::$word"}}, "no CORE::$word";
+    }
+    else {
+      $tests += 3;
+
+      my $proto = prototype "CORE::$word";
+      *{"my$word"} = \&{"CORE::$word"};
+      is prototype \&{"my$word"}, $proto, "prototype of &CORE::$word";
+
+      CORE::state $protochar = qr/\G([^\\]|\\(?:[^[]|\[[^]]+\]))/;
+      my $numargs =
+            () = $proto =~ s/;.*//r =~ /$protochar/g;
+      my $code =
+         "#line 1 This-line-makes-__FILE__-easier-to-test.
+          sub { () = (my$word("
+             . ($args_for{$word} || join ",", map "\$$_", 1..$numargs)
+       . "))}";
+      my $core = $bd->coderef2text(eval $code =~ s/my/CORE::/r or die);
+      my $my   = $bd->coderef2text(eval $code or die);
+      is $my, $core, "inlinability of CORE::$word with parens";
+
+      $code =
+         "#line 1 This-line-makes-__FILE__-easier-to-test.
+          sub { () = (my$word "
+             . ($args_for{$word} || join ",", map "\$$_", 1..$numargs)
+       . ")}";
+      $core = $bd->coderef2text(eval $code =~ s/my/CORE::/r or die);
+      $my   = $bd->coderef2text(eval $code or die);
+      is $my, $core, "inlinability of CORE::$word without parens";
+
+      next if ($proto =~ /\@/);
+      # These ops currently accept any number of args, despite their
+      # prototypes, if they have any:
+      next if $word =~ /^(?:chom?p|exec|keys|each|read(?:lin|pip)e|reset
+                           |system|values|l?stat)/x;
+
+      $tests ++;
+      $code =
+         "sub { () = (my$word("
+             . (
+                $args_for{$word}
+                 ? $args_for{$word}.',$7'
+                 : join ",", map "\$$_", 1..$numargs+5+(
+                      $proto =~ /;/
+                       ? () = $' =~ /$protochar/g
+                       : 0
+                   )
+               )
+       . "))}";
+      eval $code;
+      like $@, qr/^Too many arguments for $word/,
+          "inlined CORE::$word with too many args"
+        or warn $code;
+
+    }
+  }
+}
+
+is curr_test, $tests+1, 'right number of tests';
+done_testing;
+
+CORE::__END__