Custom Ops

Message-ID: <20010825174509.A5752@netthink.co.uk>
I also added a fix to Opcode.pm to quite test cases.

p4raw-id: //depot/perl@11756

diff --git a/dump.c b/dump.c
index 6729db8..5fef711 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -381,7 +381,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o)
        PerlIO_printf(file, "    ");
     PerlIO_printf(file,
                  "%*sTYPE = %s  ===> ",
-                 (int)(PL_dumpindent*level-4), "", PL_op_name[o->op_type]);
+                 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
     if (o->op_next) {
        if (o->op_seq)
            PerlIO_printf(file, "%d\n", o->op_next->op_seq);

diff --git a/embed.pl b/embed.pl
index 84ff77b..54550b4 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -2248,6 +2248,18 @@ Ap       |void   |ptr_table_free|PTR_TBL_t *tbl
 Ap     |void   |sys_intern_clear
 Ap     |void   |sys_intern_init
 #endif
+#if defined(PERL_CUSTOM_OPS)
+Ap |char * |custom_op_name|OP* op
+Ap |char * |custom_op_desc|OP* op
+#endif
+#if defined(PERL_CUSTOM_OPS)
+Ap |char * |custom_op_name|OP* op
+Ap |char * |custom_op_desc|OP* op
+#endif
+#if defined(PERL_CUSTOM_OPS)
+Ap |char * |custom_op_name|OP* op
+Ap |char * |custom_op_desc|OP* op
+#endif
 
 #if defined(PERL_OBJECT)
 protected:

diff --git a/ext/Opcode/Opcode.pm b/ext/Opcode/Opcode.pm
index e979851..8c7d254 100644 (file)
--- a/ext/Opcode/Opcode.pm
+++ b/ext/Opcode/Opcode.pm
@@ -415,6 +415,8 @@ These are a hotchpotch of opcodes still waiting to be considered
 
     entertry leavetry -- can be used to 'hide' fatal errors
 
+    custom -- where should this go
+
 =item :base_math
 
 These ops are not included in :base_core because of the risk of them being

diff --git a/intrpvar.h b/intrpvar.h
index 4fa7374..8a92d7d 100644 (file)
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -487,6 +487,10 @@ PERLVAR(Ireentrant_buffer, REBUF*) /* here we store the _r buffers */
 
 PERLVAR(Isavebegin,     bool)  /* save BEGINs for compiler     */
 
+#ifdef PERL_CUSTOM_OPS
+PERLVAR(Icustom_op_names, HV*)  /* Names of user defined ops */
+PERLVAR(Icustom_op_descs, HV*)  /* Descriptions of user defined ops */
+#endif
 /* New variables must be added to the very end for binary compatibility.
  * XSUB.h provides wrapper functions via perlapi.h that make this
  * irrelevant, but not all code may be expected to #include XSUB.h. */

diff --git a/op.c b/op.c
index 030fabe..c5af7b2 100644 (file)
--- a/op.c
+++ b/op.c
@@ -72,7 +72,7 @@ STATIC OP *
 S_no_fh_allowed(pTHX_ OP *o)
 {
     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
-                PL_op_desc[o->op_type]));
+                OP_DESC(o)));
     return o;
 }
 
@@ -94,7 +94,7 @@ STATIC void
 S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
 {
     yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
-                (int)n, name, t, PL_op_desc[kid->op_type]));
+                (int)n, name, t, OP_DESC(kid)));
 }
 
 STATIC void
@@ -1141,7 +1141,7 @@ Perl_scalarvoid(pTHX_ OP *o)
     case OP_GETLOGIN:
       func_ops:
        if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
-           useless = PL_op_desc[o->op_type];
+           useless = OP_DESC(o);
        break;
 
     case OP_RV2GV:
@@ -1510,7 +1510,7 @@ Perl_mod(pTHX_ OP *o, I32 type)
                      ? "do block"
                      : (o->op_type == OP_ENTERSUB
                        ? "non-lvalue subroutine call"
-                       : PL_op_desc[o->op_type])),
+                       : OP_DESC(o))),
                     type ? PL_op_desc[type] : "local"));
        return o;
 
@@ -1972,7 +1972,7 @@ S_my_kid(pTHX_ OP *o, OP *attrs)
             type != OP_PUSHMARK)
     {
        yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
-                         PL_op_desc[o->op_type],
+                         OP_DESC(o),
                          PL_in_my == KEY_our ? "our" : "my"));
        return o;
     }
@@ -5431,7 +5431,7 @@ Perl_ck_delete(pTHX_ OP *o)
            break;
        default:
            Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
-                 PL_op_desc[o->op_type]);
+                 OP_DESC(o));
        }
        op_null(kid);
     }
@@ -5536,14 +5536,14 @@ Perl_ck_exists(pTHX_ OP *o)
            (void) ref(kid, o->op_type);
            if (kid->op_type != OP_RV2CV && !PL_error_count)
                Perl_croak(aTHX_ "%s argument is not a subroutine name",
-                          PL_op_desc[o->op_type]);
+                           OP_DESC(o));
            o->op_private |= OPpEXISTS_SUB;
        }
        else if (kid->op_type == OP_AELEM)
            o->op_flags |= OPf_SPECIAL;
        else if (kid->op_type != OP_HELEM)
            Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
-                      PL_op_desc[o->op_type]);
+                       OP_DESC(o));
        op_null(kid);
     }
     return o;
@@ -5821,7 +5821,7 @@ Perl_ck_fun(pTHX_ OP *o)
                    }
                    else if (kid->op_type == OP_READLINE) {
                        /* neophyte patrol: open(<FH>), close(<FH>) etc. */
-                       bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
+                       bad_type(numargs, "HANDLE", OP_DESC(o), kid);
                    }
                    else {
                        I32 flags = OPf_SPECIAL;
@@ -5889,7 +5889,7 @@ Perl_ck_fun(pTHX_ OP *o)
        }
        o->op_private |= numargs;
        if (kid)
-           return too_many_arguments(o,PL_op_desc[o->op_type]);
+           return too_many_arguments(o,OP_DESC(o));
        listkids(o);
     }
     else if (PL_opargs[type] & OA_DEFGV) {
@@ -5901,7 +5901,7 @@ Perl_ck_fun(pTHX_ OP *o)
        while (oa & OA_OPTIONAL)
            oa >>= 4;
        if (oa && oa != OA_LIST)
-           return too_few_arguments(o,PL_op_desc[o->op_type]);
+           return too_few_arguments(o,OP_DESC(o));
     }
     return o;
 }
@@ -6000,7 +6000,7 @@ Perl_ck_grep(pTHX_ OP *o)
 
     kid = cLISTOPo->op_first->op_sibling;
     if (!kid || !kid->op_sibling)
-       return too_few_arguments(o,PL_op_desc[o->op_type]);
+       return too_few_arguments(o,OP_DESC(o));
     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
        mod(kid, OP_GREPSTART);
 
@@ -6505,7 +6505,7 @@ Perl_ck_split(pTHX_ OP *o)
     scalar(kid);
 
     if (kid->op_sibling)
-       return too_many_arguments(o,PL_op_desc[o->op_type]);
+       return too_many_arguments(o,OP_DESC(o));
 
     return o;
 }
@@ -7098,6 +7098,44 @@ Perl_peep(pTHX_ register OP *o)
     LEAVE;
 }
 
+#ifdef PERL_CUSTOM_OPS
+char* custom_op_name(pTHX_ OP* o)
+{
+    IV  index = PTR2IV(o->op_ppaddr);
+    SV* keysv;
+    HE* he;
+
+    if (!PL_custom_op_names) /* This probably shouldn't happen */
+        return PL_op_name[OP_CUSTOM];
+
+    keysv = sv_2mortal(newSViv(index));
+
+    he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
+    if (!he)
+        return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
+
+    return SvPV_nolen(HeVAL(he));
+}
+
+char* custom_op_desc(pTHX_ OP* o)
+{
+    IV  index = PTR2IV(o->op_ppaddr);
+    SV* keysv;
+    HE* he;
+
+    if (!PL_custom_op_descs)
+        return PL_op_desc[OP_CUSTOM];
+
+    keysv = sv_2mortal(newSViv(index));
+
+    he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
+    if (!he)
+        return PL_op_desc[OP_CUSTOM];
+
+    return SvPV_nolen(HeVAL(he));
+}
+#endif
+
 #include "XSUB.h"
 
 /* Efficient sub that returns a constant scalar value. */

diff --git a/op.h b/op.h
index dbfaced..75a3294 100644 (file)
--- a/op.h
+++ b/op.h
@@ -461,6 +461,7 @@ struct loop {
 #define PERL_LOADMOD_IMPORT_OPS                0x4
 
 #ifdef USE_REENTRANT_API
+er
 typedef struct {
   struct tm* tmbuff;
 } REBUF;

diff --git a/opcode.pl b/opcode.pl
index 4053671..2e08641 100755 (executable)
--- a/opcode.pl
+++ b/opcode.pl
@@ -65,6 +65,16 @@ print <<END;
 
 START_EXTERN_C
 
+#ifdef PERL_CUSTOM_OPS
+#define OP_NAME(o) (o->op_type == OP_CUSTOM ? custom_op_name(o) : \\
+                    PL_op_name[o->op_type])
+#define OP_DESC(o) (o->op_type == OP_CUSTOM ? custom_op_desc(o) : \\
+                    PL_op_desc[o->op_type])
+#else
+#define OP_NAME(o) PL_op_name[o->op_type]
+#define OP_DESC(o) PL_op_desc[o->op_type]
+#endif
+
 #ifndef DOINIT
 EXT char *PL_op_name[];
 #else
@@ -130,7 +140,7 @@ EXT OP * (CPERLscope(*PL_ppaddr)[])(pTHX) = {
 END
 
 for (@ops) {
-    print "\tMEMBER_TO_FPTR(Perl_pp_$_),\n";
+    print "\tMEMBER_TO_FPTR(Perl_pp_$_),\n" unless $_ eq "custom";
 }
 
 print <<END;
@@ -209,7 +219,6 @@ for (@ops) {
     $argsum |= 32 if $flags =~ /I/;            # has corresponding int op
     $argsum |= 64 if $flags =~ /d/;            # danger, unknown side effects
     $argsum |= 128 if $flags =~ /u/;           # defaults to $_
-
     $flags =~ /([\W\d_])/ or die qq[Opcode "$_" has no class indicator];
     $argsum |= $opclass{$1} << 9;
     $mul = 0x2000;                             # 2 ^ OASHIFT
@@ -291,6 +300,7 @@ print PP "\n\n";
 
 for (@ops) {
     next if /^i_(pre|post)(inc|dec)$/;
+    next if /^custom$/;
     print PP "PERL_PPDEF(Perl_pp_$_)\n";
     print PPSYM "Perl_pp_$_\n";
 }
@@ -887,3 +897,5 @@ threadsv    per-thread value        ck_null         ds0
 # Control (contd.)
 setstate       set statement info      ck_null         s;
 method_named   method with known name  ck_null         d$
+
+custom         unknown custom operator         ck_null         0

diff --git a/pod/perlguts.pod b/pod/perlguts.pod
index 6478efd..f89d0a4 100644 (file)
--- a/pod/perlguts.pod
+++ b/pod/perlguts.pod
@@ -2357,6 +2357,50 @@ high character - C<HALF_UPGRADE> is one of those.
 
 =back
 
+=head1 Custom Operators
+
+Custom operator support is a new experimental feature that allows you do
+define your own ops. This is primarily to allow the building of
+interpreters for other languages in the Perl core, but it also allows
+optimizations through the creation of "macro-ops" (ops which perform the
+functions of multiple ops which are usually executed together, such as
+C<gvsv, gvsv, add>.) Currently, this feature must be enabled with the C
+flag C<-DPERL_CUSTOM_OPS>.
+
+Enabling the feature will create a new op type, C<OP_CUSTOM>. The Perl
+core does not "know" anything special about this op type, and so it will
+not be involved in any optimizations. This also means that you can
+define your custom ops to be any op structure - unary, binary, list and
+so on - you like.
+
+It's important to know what custom operators won't do for you. They
+won't let you add new syntax to Perl, directly. They won't even let you
+add new keywords, directly. In fact, they won't change the way Perl
+compiles a program at all. You have to do those changes yourself, after
+Perl has compiled the program. You do this either by manipulating the op
+tree using a C<CHECK> block and the C<B::Generate> module, or by adding
+a custom peephole optimizer with the C<optimize> module.
+
+When you do this, you replace ordinary Perl ops with custom ops by
+creating ops with the type C<OP_CUSTOM> and the C<pp_addr> of your own
+PP function. This should be defined in XS code, and should look like
+the PP ops in C<pp_*.c>. You are responsible for ensuring that your op
+takes the appropriate number of values from the stack, and you are
+responsible for adding stack marks if necessary.
+
+You should also "register" your op with the Perl interpreter so that it
+can produce sensible error and warning messages. Since it is possible to
+have multiple custom ops within the one "logical" op type C<OP_CUSTOM>,
+Perl uses the value of C<< o->op_ppaddr >> as a key into the
+C<PL_custom_op_descs> and C<PL_custom_op_names> hashes. This means you
+need to enter a name and description for your op at the appropriate
+place in the C<PL_custom_op_names> and C<PL_custom_op_descs> hashes.
+
+Forthcoming versions of C<B::Generate> (version 1.0 and above) should
+directly support the creation of custom ops by name; C<Opcodes::Custom> 
+will provide functions which make it trivial to "register" custom ops to
+the Perl interpreter.
+
 =head1 AUTHORS
 
 Until May 1997, this document was maintained by Jeff Okamoto

diff --git a/pp_ctl.c b/pp_ctl.c
index e79d45d..d9decd7 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1195,27 +1195,27 @@ S_dopoptolabel(pTHX_ char *label)
        case CXt_SUBST:
            if (ckWARN(WARN_EXITING))
                Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
-                       PL_op_name[PL_op->op_type]);
+                       OP_NAME(PL_op));
            break;
        case CXt_SUB:
            if (ckWARN(WARN_EXITING))
                Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
-                       PL_op_name[PL_op->op_type]);
+                       OP_NAME(PL_op));
            break;
        case CXt_FORMAT:
            if (ckWARN(WARN_EXITING))
                Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
-                       PL_op_name[PL_op->op_type]);
+                       OP_NAME(PL_op));
            break;
        case CXt_EVAL:
            if (ckWARN(WARN_EXITING))
                Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
-                       PL_op_name[PL_op->op_type]);
+                       OP_NAME(PL_op));
            break;
        case CXt_NULL:
            if (ckWARN(WARN_EXITING))
                Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
-                       PL_op_name[PL_op->op_type]);
+                       OP_NAME(PL_op));
            return -1;
        case CXt_LOOP:
            if (!cx->blk_loop.label ||
@@ -1330,27 +1330,27 @@ S_dopoptoloop(pTHX_ I32 startingblock)
        case CXt_SUBST:
            if (ckWARN(WARN_EXITING))
                Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
-                       PL_op_name[PL_op->op_type]);
+                       OP_NAME(PL_op));
            break;
        case CXt_SUB:
            if (ckWARN(WARN_EXITING))
                Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
-                       PL_op_name[PL_op->op_type]);
+                       OP_NAME(PL_op));
            break;
        case CXt_FORMAT:
            if (ckWARN(WARN_EXITING))
                Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
-                       PL_op_name[PL_op->op_type]);
+                       OP_NAME(PL_op));
            break;
        case CXt_EVAL:
            if (ckWARN(WARN_EXITING))
                Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
-                       PL_op_name[PL_op->op_type]);
+                       OP_NAME(PL_op));
            break;
        case CXt_NULL:
            if (ckWARN(WARN_EXITING))
                Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
-                       PL_op_name[PL_op->op_type]);
+                       OP_NAME(PL_op));
            return -1;
        case CXt_LOOP:
            DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));

diff --git a/pp_sys.c b/pp_sys.c
index cdcbc93..bf32b3c 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -2150,7 +2150,7 @@ PP(pp_ioctl)
     if (SvPOK(argsv)) {
        if (s[SvCUR(argsv)] != 17)
            DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
-               PL_op_name[optype]);
+               OP_NAME(PL_op));
        s[SvCUR(argsv)] = 0;            /* put our null back */
        SvSETMAGIC(argsv);              /* Assume it has changed */
     }

diff --git a/run.c b/run.c
index 533beac..34dfc9b 100644 (file)
--- a/run.c
+++ b/run.c
@@ -67,7 +67,7 @@ Perl_debop(pTHX_ OP *o)
     CV *cv;
     SV *sv;
     STRLEN n_a;
-    Perl_deb(aTHX_ "%s", PL_op_name[o->op_type]);
+    Perl_deb(aTHX_ "%s", OP_NAME(o));
     switch (o->op_type) {
     case OP_CONST:
        PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));

diff --git a/sv.c b/sv.c
index e0a242e..3655151 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -540,7 +540,7 @@ Perl_report_uninit(pTHX)
 {
     if (PL_op)
        Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit,
-                   " in ", PL_op_desc[PL_op->op_type]);
+                   " in ", OP_DESC(PL_op));
     else
        Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, "", "");
 }
@@ -1616,7 +1616,7 @@ Perl_sv_setiv(pTHX_ register SV *sv, IV i)
     case SVt_PVFM:
     case SVt_PVIO:
        Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
-                  PL_op_desc[PL_op->op_type]);
+                  OP_DESC(PL_op));
     }
     (void)SvIOK_only(sv);                      /* validate number */
     SvIVX(sv) = i;
@@ -1727,7 +1727,7 @@ Perl_sv_setnv(pTHX_ register SV *sv, NV num)
     case SVt_PVFM:
     case SVt_PVIO:
        Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
-                  PL_op_name[PL_op->op_type]);
+                  OP_NAME(PL_op));
     }
     SvNVX(sv) = num;
     (void)SvNOK_only(sv);                      /* validate number */
@@ -1807,7 +1807,7 @@ S_not_a_number(pTHX_ SV *sv)
     if (PL_op)
        Perl_warner(aTHX_ WARN_NUMERIC,
                    "Argument \"%s\" isn't numeric in %s", tmpbuf,
-               PL_op_desc[PL_op->op_type]);
+                       OP_DESC(PL_op));
     else
        Perl_warner(aTHX_ WARN_NUMERIC,
                    "Argument \"%s\" isn't numeric", tmpbuf);
@@ -3355,7 +3355,7 @@ Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
                        if (first && ch > 255) {
                            if (PL_op)
                                Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte %s",
-                                          PL_op_desc[PL_op->op_type]);
+                                          OP_DESC(PL_op);
                            else
                                Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte");
                            first = 0;
@@ -3370,7 +3370,7 @@ Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
                else {
                    if (PL_op)
                        Perl_croak(aTHX_ "Wide character in %s",
-                                  PL_op_desc[PL_op->op_type]);
+                                  OP_DESC(PL_op));
                    else
                        Perl_croak(aTHX_ "Wide character");
                }
@@ -3597,7 +3597,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
     case SVt_PVIO:
        if (PL_op)
            Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
-               PL_op_name[PL_op->op_type]);
+               OP_NAME(PL_op));
        else
            Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
        break;
@@ -6760,7 +6760,7 @@ Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
     else {
        if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
            Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
-               PL_op_name[PL_op->op_type]);
+               OP_NAME(PL_op));
        }
        else
            s = sv_2pv_flags(sv, lp, flags);

diff --git a/utf8.c b/utf8.c
index 1c1a5d4..5a5f56c 100644 (file)
--- a/utf8.c
+++ b/utf8.c
@@ -428,7 +428,7 @@ malformed:
 
            if (PL_op)
                Perl_warner(aTHX_ WARN_UTF8,
-                           "%s in %s", s,  PL_op_desc[PL_op->op_type]);
+                           "%s in %s", s,  OP_DESC(PL_op));
            else
                Perl_warner(aTHX_ WARN_UTF8, "%s", s);
        }