Change 11756 by sky@sky-lab on 2001/08/27 13:18:45
Subject: Custom Ops
From: Simon Cozens <[EMAIL PROTECTED]>
Date: Sat, 25 Aug 2001 17:45:09 +0100
Message-ID: <[EMAIL PROTECTED]>
I also added a fix to Opcode.pm to quite test cases.
Affected files ...
... //depot/perl/dump.c#92 edit
... //depot/perl/embed.pl#265 edit
... //depot/perl/ext/Opcode/Opcode.pm#23 edit
... //depot/perl/intrpvar.h#84 edit
... //depot/perl/op.c#432 edit
... //depot/perl/op.h#92 edit
... //depot/perl/opcode.pl#84 edit
... //depot/perl/pod/perlguts.pod#93 edit
... //depot/perl/pp_ctl.c#278 edit
... //depot/perl/pp_sys.c#253 edit
... //depot/perl/run.c#45 edit
... //depot/perl/sv.c#458 edit
... //depot/perl/utf8.c#105 edit
Differences ...
==== //depot/perl/dump.c#92 (text) ====
Index: perl/dump.c
--- perl/dump.c.~1~ Mon Aug 27 07:30:05 2001
+++ perl/dump.c Mon Aug 27 07:30:05 2001
@@ -381,7 +381,7 @@
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);
==== //depot/perl/embed.pl#265 (xtext) ====
Index: perl/embed.pl
--- perl/embed.pl.~1~ Mon Aug 27 07:30:05 2001
+++ perl/embed.pl Mon Aug 27 07:30:05 2001
@@ -2248,6 +2248,18 @@
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:
==== //depot/perl/ext/Opcode/Opcode.pm#23 (text) ====
Index: perl/ext/Opcode/Opcode.pm
--- perl/ext/Opcode/Opcode.pm.~1~ Mon Aug 27 07:30:05 2001
+++ perl/ext/Opcode/Opcode.pm Mon Aug 27 07:30:05 2001
@@ -415,6 +415,8 @@
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
==== //depot/perl/intrpvar.h#84 (text) ====
Index: perl/intrpvar.h
--- perl/intrpvar.h.~1~ Mon Aug 27 07:30:05 2001
+++ perl/intrpvar.h Mon Aug 27 07:30:05 2001
@@ -487,6 +487,10 @@
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. */
==== //depot/perl/op.c#432 (text) ====
Index: perl/op.c
--- perl/op.c.~1~ Mon Aug 27 07:30:05 2001
+++ perl/op.c Mon Aug 27 07:30:05 2001
@@ -72,7 +72,7 @@
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 @@
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 @@
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 @@
? "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 @@
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 @@
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 @@
(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 @@
}
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 @@
}
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 @@
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 @@
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 @@
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 @@
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. */
==== //depot/perl/op.h#92 (text) ====
Index: perl/op.h
--- perl/op.h.~1~ Mon Aug 27 07:30:05 2001
+++ perl/op.h Mon Aug 27 07:30:05 2001
@@ -461,6 +461,7 @@
#define PERL_LOADMOD_IMPORT_OPS 0x4
#ifdef USE_REENTRANT_API
+er
typedef struct {
struct tm* tmbuff;
} REBUF;
==== //depot/perl/opcode.pl#84 (xtext) ====
Index: perl/opcode.pl
--- perl/opcode.pl.~1~ Mon Aug 27 07:30:05 2001
+++ perl/opcode.pl Mon Aug 27 07:30:05 2001
@@ -65,6 +65,16 @@
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 @@
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 @@
$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 @@
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 @@
# 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
==== //depot/perl/pod/perlguts.pod#93 (text) ====
Index: perl/pod/perlguts.pod
--- perl/pod/perlguts.pod.~1~ Mon Aug 27 07:30:05 2001
+++ perl/pod/perlguts.pod Mon Aug 27 07:30:05 2001
@@ -2357,6 +2357,50 @@
=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
==== //depot/perl/pp_ctl.c#278 (text) ====
Index: perl/pp_ctl.c
--- perl/pp_ctl.c.~1~ Mon Aug 27 07:30:05 2001
+++ perl/pp_ctl.c Mon Aug 27 07:30:05 2001
@@ -1195,27 +1195,27 @@
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 @@
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));
==== //depot/perl/pp_sys.c#253 (text) ====
Index: perl/pp_sys.c
--- perl/pp_sys.c.~1~ Mon Aug 27 07:30:05 2001
+++ perl/pp_sys.c Mon Aug 27 07:30:05 2001
@@ -2150,7 +2150,7 @@
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 */
}
==== //depot/perl/run.c#45 (text) ====
Index: perl/run.c
--- perl/run.c.~1~ Mon Aug 27 07:30:05 2001
+++ perl/run.c Mon Aug 27 07:30:05 2001
@@ -67,7 +67,7 @@
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));
==== //depot/perl/sv.c#458 (text) ====
Index: perl/sv.c
--- perl/sv.c.~1~ Mon Aug 27 07:30:05 2001
+++ perl/sv.c Mon Aug 27 07:30:05 2001
@@ -540,7 +540,7 @@
{
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 @@
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 @@
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 @@
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 @@
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 @@
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 @@
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 @@
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);
==== //depot/perl/utf8.c#105 (text) ====
Index: perl/utf8.c
--- perl/utf8.c.~1~ Mon Aug 27 07:30:05 2001
+++ perl/utf8.c Mon Aug 27 07:30:05 2001
@@ -428,7 +428,7 @@
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);
}
End of Patch.
