--- /dev/null
+
+
+
+
+ The "Artistic License"
+
+ Preamble
+
+The intent of this document is to state the conditions under which a
+Package may be copied, such that the Copyright Holder maintains some
+semblance of artistic control over the development of the package,
+while giving the users of the package the right to use and distribute
+the Package in a more-or-less customary fashion, plus the right to make
+reasonable modifications.
+
+Definitions:
+
+ "Package" refers to the collection of files distributed by the
+ Copyright Holder, and derivatives of that collection of files
+ created through textual modification.
+
+ "Standard Version" refers to such a Package if it has not been
+ modified, or has been modified in accordance with the wishes
+ of the Copyright Holder as specified below.
+
+ "Copyright Holder" is whoever is named in the copyright or
+ copyrights for the package.
+
+ "You" is you, if you're thinking about copying or distributing
+ this Package.
+
+ "Reasonable copying fee" is whatever you can justify on the
+ basis of media cost, duplication charges, time of people involved,
+ and so on. (You will not be required to justify it to the
+ Copyright Holder, but only to the computing community at large
+ as a market that must bear the fee.)
+
+ "Freely Available" means that no fee is charged for the item
+ itself, though there may be fees involved in handling the item.
+ It also means that recipients of the item may redistribute it
+ under the same conditions they received it.
+
+1. You may make and give away verbatim copies of the source form of the
+Standard Version of this Package without restriction, provided that you
+duplicate all of the original copyright notices and associated disclaimers.
+
+2. You may apply bug fixes, portability fixes and other modifications
+derived from the Public Domain or from the Copyright Holder. A Package
+modified in such a way shall still be considered the Standard Version.
+
+3. You may otherwise modify your copy of this Package in any way, provided
+that you insert a prominent notice in each changed file stating how and
+when you changed that file, and provided that you do at least ONE of the
+following:
+
+ a) place your modifications in the Public Domain or otherwise make them
+ Freely Available, such as by posting said modifications to Usenet or
+ an equivalent medium, or placing the modifications on a major archive
+ site such as uunet.uu.net, or by allowing the Copyright Holder to include
+ your modifications in the Standard Version of the Package.
+
+ b) use the modified Package only within your corporation or organization.
+
+ c) rename any non-standard executables so the names do not conflict
+ with standard executables, which must also be provided, and provide
+ a separate manual page for each non-standard executable that clearly
+ documents how it differs from the Standard Version.
+
+ d) make other distribution arrangements with the Copyright Holder.
+
+4. You may distribute the programs of this Package in object code or
+executable form, provided that you do at least ONE of the following:
+
+ a) distribute a Standard Version of the executables and library files,
+ together with instructions (in the manual page or equivalent) on where
+ to get the Standard Version.
+
+ b) accompany the distribution with the machine-readable source of
+ the Package with your modifications.
+
+ c) give non-standard executables non-standard names, and clearly
+ document the differences in manual pages (or equivalent), together
+ with instructions on where to get the Standard Version.
+
+ d) make other distribution arrangements with the Copyright Holder.
+
+5. You may charge a reasonable copying fee for any distribution of this
+Package. You may charge any fee you choose for support of this
+Package. You may not charge a fee for this Package itself. However,
+you may distribute this Package in aggregate with other (possibly
+commercial) programs as part of a larger (possibly commercial) software
+distribution provided that you do not advertise this Package as a
+product of your own. You may embed this Package's interpreter within
+an executable of yours (by linking); this shall be construed as a mere
+form of aggregation, provided that the complete Standard Version of the
+interpreter is so embedded.
+
+6. The scripts and library files supplied as input to or produced as
+output from the programs of this Package do not automatically fall
+under the copyright of this Package, but belong to whomever generated
+them, and may be sold commercially, and may be aggregated with this
+Package. If such scripts or library files are aggregated with this
+Package via the so-called "undump" or "unexec" methods of producing a
+binary executable image, then distribution of such an image shall
+neither be construed as a distribution of this Package nor shall it
+fall under the restrictions of Paragraphs 3 and 4, provided that you do
+not represent such an executable image as a Standard Version of this
+Package.
+
+7. C subroutines (or comparably compiled subroutines in other
+languages) supplied by you and linked into this Package in order to
+emulate subroutines and variables of the language defined by this
+Package shall not be considered part of this Package, but are the
+equivalent of input as in Paragraph 6, provided these subroutines do
+not change the language in any way that would cause it to fail the
+regression tests for the language.
+
+8. Aggregation of this Package with a commercial distribution is always
+permitted provided that the use of this Package is embedded; that is,
+when no overt attempt is made to make this Package's interfaces visible
+to the end user of the commercial distribution. Such use shall not be
+construed as a distribution of this Package.
+
+9. The name of the Copyright Holder may not be used to endorse or promote
+products derived from this software without specific prior written permission.
+
+10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
+IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
+WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+
+ The End
--- /dev/null
+# B.pm
+#
+# Copyright (c) 1996 Malcolm Beattie
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the README file.
+#
+package B;
+require DynaLoader;
+require Exporter;
+@ISA = qw(Exporter DynaLoader);
+@EXPORT_OK = qw(byteload_fh byteload_string minus_c ppname
+ class peekop cast_I32 ad cstring cchar hash
+ main_root main_start main_cv svref_2object
+ walkoptree walkoptree_exec walksymtable
+ comppadlist sv_undef compile_stats timing_info);
+
+use strict;
+@B::SV::ISA = 'B::OBJECT';
+@B::NULL::ISA = 'B::SV';
+@B::PV::ISA = 'B::SV';
+@B::IV::ISA = 'B::SV';
+@B::NV::ISA = 'B::IV';
+@B::RV::ISA = 'B::SV';
+@B::PVIV::ISA = qw(B::PV B::IV);
+@B::PVNV::ISA = qw(B::PV B::NV);
+@B::PVMG::ISA = 'B::PVNV';
+@B::PVLV::ISA = 'B::PVMG';
+@B::BM::ISA = 'B::PVMG';
+@B::AV::ISA = 'B::PVMG';
+@B::GV::ISA = 'B::PVMG';
+@B::HV::ISA = 'B::PVMG';
+@B::CV::ISA = 'B::PVMG';
+@B::IO::ISA = 'B::CV';
+
+@B::OP::ISA = 'B::OBJECT';
+@B::UNOP::ISA = 'B::OP';
+@B::BINOP::ISA = 'B::UNOP';
+@B::LOGOP::ISA = 'B::UNOP';
+@B::CONDOP::ISA = 'B::UNOP';
+@B::LISTOP::ISA = 'B::BINOP';
+@B::SVOP::ISA = 'B::OP';
+@B::GVOP::ISA = 'B::OP';
+@B::PVOP::ISA = 'B::OP';
+@B::CVOP::ISA = 'B::OP';
+@B::LOOP::ISA = 'B::LISTOP';
+@B::PMOP::ISA = 'B::LISTOP';
+@B::COP::ISA = 'B::OP';
+
+@B::SPECIAL::ISA = 'B::OBJECT';
+
+{
+ # Stop "-w" from complaining about the lack of a real B::OBJECT class
+ package B::OBJECT;
+}
+
+my $debug;
+my $op_count = 0;
+
+sub debug {
+ my ($class, $value) = @_;
+ $debug = $value;
+}
+
+# sub OPf_KIDS;
+# add to .xs for perl5.002
+sub OPf_KIDS () { 4 }
+
+sub ad {
+ my $obj = shift;
+ return $$obj;
+}
+
+sub class {
+ my $obj = shift;
+ my $name = ref $obj;
+ $name =~ s/^.*:://;
+ return $name;
+}
+
+# For debugging
+sub peekop {
+ my $op = shift;
+ return sprintf("%s (0x%x) %s", class($op), $$op, $op->ppaddr);
+}
+
+sub walkoptree {
+ my($op, $method, $level) = @_;
+ $op_count++; # just for statistics
+ $level ||= 0;
+ warn(sprintf("walkoptree: %d. %s\n", $level, peekop($op))) if $debug;
+ $op->$method($level);
+ if (ad($op) && ($op->flags & OPf_KIDS)) {
+ my $kid;
+ for ($kid = $op->first; $$kid; $kid = $kid->sibling) {
+ walkoptree($kid, $method, $level + 1);
+ }
+ }
+}
+
+sub compile_stats {
+ return "Total number of OPs processed: $op_count\n";
+}
+
+sub timing_info {
+ my ($sec, $min, $hr) = localtime;
+ my ($user, $sys) = times;
+ sprintf("%02d:%02d:%02d user=$user sys=$sys",
+ $hr, $min, $sec, $user, $sys);
+}
+
+my %symtable;
+sub savesym {
+ my ($obj, $value) = @_;
+# warn(sprintf("savesym: sym_%x => %s\n", ad($obj), $value)); # debug
+ $symtable{sprintf("sym_%x", ad($obj))} = $value;
+}
+
+sub objsym {
+ my $obj = shift;
+ return $symtable{sprintf("sym_%x", ad($obj))};
+}
+
+sub walkoptree_exec {
+ my ($op, $method, $level) = @_;
+ my ($sym, $ppname);
+ my $prefix = " " x $level;
+ for (; $$op; $op = $op->next) {
+ $sym = objsym($op);
+ if (defined($sym)) {
+ print $prefix, "goto $sym\n";
+ return;
+ }
+ savesym($op, sprintf("%s (0x%lx)", class($op), ad($op)));
+ $op->$method($level);
+ $ppname = $op->ppaddr;
+ if ($ppname =~ /^pp_(or|and|mapwhile|grepwhile|entertry)$/) {
+ print $prefix, uc($1), " => {\n";
+ walkoptree_exec($op->other, $method, $level + 1);
+ print $prefix, "}\n";
+ } elsif ($ppname eq "pp_match" || $ppname eq "pp_subst") {
+ my $pmreplstart = $op->pmreplstart;
+ if (ad($pmreplstart)) {
+ print $prefix, "PMREPLSTART => {\n";
+ walkoptree_exec($pmreplstart, $method, $level + 1);
+ print $prefix, "}\n";
+ }
+ } elsif ($ppname eq "pp_substcont") {
+ print $prefix, "SUBSTCONT => {\n";
+ walkoptree_exec($op->other->pmreplstart, $method, $level + 1);
+ print $prefix, "}\n";
+ $op = $op->other;
+ } elsif ($ppname eq "pp_cond_expr") {
+ # pp_cond_expr never returns op_next
+ print $prefix, "TRUE => {\n";
+ walkoptree_exec($op->true, $method, $level + 1);
+ print $prefix, "}\n";
+ $op = $op->false;
+ redo;
+ } elsif ($ppname eq "pp_range") {
+ print $prefix, "TRUE => {\n";
+ walkoptree_exec($op->true, $method, $level + 1);
+ print $prefix, "}\n", $prefix, "FALSE => {\n";
+ walkoptree_exec($op->false, $method, $level + 1);
+ print $prefix, "}\n";
+ } elsif ($ppname eq "pp_enterloop") {
+ print $prefix, "REDO => {\n";
+ walkoptree_exec($op->redoop, $method, $level + 1);
+ print $prefix, "}\n", $prefix, "NEXT => {\n";
+ walkoptree_exec($op->nextop, $method, $level + 1);
+ print $prefix, "}\n", $prefix, "LAST => {\n";
+ walkoptree_exec($op->lastop, $method, $level + 1);
+ print $prefix, "}\n";
+ } elsif ($ppname eq "pp_subst") {
+ my $replstart = $op->pmreplstart;
+ if (ad($replstart)) {
+ print $prefix, "SUBST => {\n";
+ walkoptree_exec($replstart, $method, $level + 1);
+ print $prefix, "}\n";
+ }
+ }
+ }
+}
+
+sub walksymtable {
+ my ($symref, $method, $recurse) = @_;
+ my $sym;
+ no strict 'vars';
+ local(*glob);
+ while (($sym, *glob) = each %$symref) {
+ if ($sym =~ /::$/) {
+ if ($sym ne "main::" && &$recurse($sym)) {
+ walksymtable(\%glob, $method, $recurse);
+ }
+ } else {
+ svref_2object(\*glob)->EGV->$method();
+ }
+ }
+}
+
+bootstrap B;
+
+1;
--- /dev/null
+/* B.xs
+ *
+ * Copyright (c) 1996 Malcolm Beattie
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+#include "INTERN.h"
+#include "bytecode.h"
+#include "byterun.h"
+#include "ccop.h"
+
+static char *svclassnames[] = {
+ "B::NULL",
+ "B::IV",
+ "B::NV",
+ "B::RV",
+ "B::PV",
+ "B::PVIV",
+ "B::PVNV",
+ "B::PVMG",
+ "B::BM",
+ "B::PVLV",
+ "B::AV",
+ "B::HV",
+ "B::CV",
+ "B::GV",
+ "B::FM",
+ "B::IO",
+};
+
+static SV *
+make_sv_object(arg, sv)
+SV *arg;
+SV *sv;
+{
+ char *type = 0;
+ IV iv;
+
+ for (iv = 0; iv < sizeof(specialsv_list)/sizeof(SV*); iv++) {
+ if (sv == specialsv_list[iv]) {
+ type = "B::SPECIAL";
+ break;
+ }
+ }
+ if (!type) {
+ type = svclassnames[SvTYPE(sv)];
+ iv = (IV)sv;
+ }
+ sv_setiv(newSVrv(arg, type), iv);
+ return arg;
+}
+
+static SV *
+make_mg_object(arg, mg)
+SV *arg;
+MAGIC *mg;
+{
+ sv_setiv(newSVrv(arg, "B::MAGIC"), (IV)mg);
+ return arg;
+}
+
+static SV *
+cstring(sv)
+SV *sv;
+{
+ SV *sstr = newSVpv("", 0);
+ STRLEN len;
+ char *s;
+
+ if (!SvOK(sv))
+ sv_setpvn(sstr, "0", 1);
+ else
+ {
+ /* XXX Optimise? */
+ s = SvPV(sv, len);
+ sv_catpv(sstr, "\"");
+ for (; len; len--, s++)
+ {
+ /* At least try a little for readability */
+ if (*s == '"')
+ sv_catpv(sstr, "\\\"");
+ else if (*s == '\\')
+ sv_catpv(sstr, "\\\\");
+ else if (*s >= ' ' && *s < 127) /* XXX not portable */
+ sv_catpvn(sstr, s, 1);
+ else if (*s == '\n')
+ sv_catpv(sstr, "\\n");
+ else if (*s == '\r')
+ sv_catpv(sstr, "\\r");
+ else if (*s == '\t')
+ sv_catpv(sstr, "\\t");
+ else if (*s == '\a')
+ sv_catpv(sstr, "\\a");
+ else if (*s == '\b')
+ sv_catpv(sstr, "\\b");
+ else if (*s == '\f')
+ sv_catpv(sstr, "\\f");
+ else if (*s == '\v')
+ sv_catpv(sstr, "\\v");
+ else
+ {
+ /* no trigraph support */
+ char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */
+ /* Don't want promotion of a signed -1 char in sprintf args */
+ unsigned char c = (unsigned char) *s;
+ sprintf(escbuff, "\\%03o", c);
+ sv_catpv(sstr, escbuff);
+ }
+ /* XXX Add line breaks if string is long */
+ }
+ sv_catpv(sstr, "\"");
+ }
+ return sstr;
+}
+
+static SV *
+cchar(sv)
+SV *sv;
+{
+ SV *sstr = newSVpv("'", 0);
+ char *s = SvPV(sv, na);
+
+ if (*s == '\'')
+ sv_catpv(sstr, "\\'");
+ else if (*s == '\\')
+ sv_catpv(sstr, "\\\\");
+ else if (*s >= ' ' && *s < 127) /* XXX not portable */
+ sv_catpvn(sstr, s, 1);
+ else if (*s == '\n')
+ sv_catpv(sstr, "\\n");
+ else if (*s == '\r')
+ sv_catpv(sstr, "\\r");
+ else if (*s == '\t')
+ sv_catpv(sstr, "\\t");
+ else if (*s == '\a')
+ sv_catpv(sstr, "\\a");
+ else if (*s == '\b')
+ sv_catpv(sstr, "\\b");
+ else if (*s == '\f')
+ sv_catpv(sstr, "\\f");
+ else if (*s == '\v')
+ sv_catpv(sstr, "\\v");
+ else
+ {
+ /* no trigraph support */
+ char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */
+ /* Don't want promotion of a signed -1 char in sprintf args */
+ unsigned char c = (unsigned char) *s;
+ sprintf(escbuff, "\\%03o", c);
+ sv_catpv(sstr, escbuff);
+ }
+ sv_catpv(sstr, "'");
+ return sstr;
+}
+
+void *
+bset_obj_store(obj, ix)
+void *obj;
+I32 ix;
+{
+ if (ix > obj_list_fill) {
+ if (obj_list_fill == -1)
+ New(666, obj_list, ix + 1, void*);
+ else
+ Renew(obj_list, ix + 1, void*);
+ obj_list_fill = ix;
+ }
+ obj_list[ix] = obj;
+ return obj;
+}
+
+#ifdef INDIRECT_BGET_MACROS
+void freadpv(len, data)
+U32 len;
+void *data;
+{
+ New(666, pv.xpv_pv, len, char);
+ fread(pv.xpv_pv, 1, len, (FILE*)data);
+ pv.xpv_len = len;
+ pv.xpv_cur = len - 1;
+}
+
+void byteload_fh(fp)
+FILE *fp;
+{
+ struct bytestream bs;
+ bs.data = fp;
+ bs.fgetc = (int(*) _((void*)))fgetc;
+ bs.fread = (int(*) _((char*,size_t,size_t,void*)))fread;
+ bs.freadpv = freadpv;
+ byterun(bs);
+}
+
+static int fgetc_fromstring(data)
+void *data;
+{
+ char **strp = (char **)data;
+ return *(*strp)++;
+}
+
+static int fread_fromstring(argp, elemsize, nelem, data)
+char *argp;
+size_t elemsize;
+size_t nelem;
+void *data;
+{
+ char **strp = (char **)data;
+ size_t len = elemsize * nelem;
+
+ memcpy(argp, *strp, len);
+ *strp += len;
+ return (int)len;
+}
+
+static void freadpv_fromstring(len, data)
+U32 len;
+void *data;
+{
+ char **strp = (char **)data;
+
+ New(666, pv.xpv_pv, len, char);
+ memcpy(pv.xpv_pv, *strp, len);
+ pv.xpv_len = len;
+ pv.xpv_cur = len - 1;
+ *strp += len;
+}
+
+void byteload_string(str)
+char *str;
+{
+ struct bytestream bs;
+ bs.data = &str;
+ bs.fgetc = fgetc_fromstring;
+ bs.fread = fread_fromstring;
+ bs.freadpv = freadpv_fromstring;
+ byterun(bs);
+}
+#else
+void byteload_fh(fp)
+FILE *fp;
+{
+ byterun(fp);
+}
+
+void byteload_string(str)
+char *str;
+{
+ croak("Must compile with -DINDIRECT_BGET_MACROS for byteload_string");
+}
+#endif /* INDIRECT_BGET_MACROS */
+
+
+typedef OP *B__OP;
+typedef UNOP *B__UNOP;
+typedef BINOP *B__BINOP;
+typedef LOGOP *B__LOGOP;
+typedef CONDOP *B__CONDOP;
+typedef LISTOP *B__LISTOP;
+typedef PMOP *B__PMOP;
+typedef SVOP *B__SVOP;
+typedef GVOP *B__GVOP;
+typedef PVOP *B__PVOP;
+typedef LOOP *B__LOOP;
+typedef COP *B__COP;
+
+typedef SV *B__SV;
+typedef SV *B__IV;
+typedef SV *B__PV;
+typedef SV *B__NV;
+typedef SV *B__PVMG;
+typedef SV *B__PVLV;
+typedef SV *B__BM;
+typedef SV *B__RV;
+typedef AV *B__AV;
+typedef HV *B__HV;
+typedef CV *B__CV;
+typedef GV *B__GV;
+typedef IO *B__IO;
+
+typedef MAGIC *B__MAGIC;
+
+MODULE = B PACKAGE = B PREFIX = B_
+
+PROTOTYPES: DISABLE
+
+#define B_main_cv() main_cv
+#define B_main_root() main_root
+#define B_main_start() main_start
+#define B_comppadlist() (main_cv ? CvPADLIST(main_cv) : CvPADLIST(compcv))
+#define B_sv_undef() &sv_undef
+#define B_sv_yes() &sv_yes
+#define B_sv_no() &sv_no
+
+B::CV
+B_main_cv()
+
+B::OP
+B_main_root()
+
+B::OP
+B_main_start()
+
+B::AV
+B_comppadlist()
+
+B::SV
+B_sv_undef()
+
+B::SV
+B_sv_yes()
+
+B::SV
+B_sv_no()
+
+MODULE = B PACKAGE = B
+
+
+void
+byteload_fh(fp)
+ FILE * fp
+
+void
+byteload_string(str)
+ char * str
+
+#define address(sv) (IV)sv
+
+IV
+address(sv)
+ SV * sv
+
+B::SV
+svref_2object(sv)
+ SV * sv
+ CODE:
+ if (!SvROK(sv))
+ croak("argument is not a reference");
+ RETVAL = (SV*)SvRV(sv);
+ OUTPUT:
+ RETVAL
+
+void
+ppname(opnum)
+ int opnum
+ CODE:
+ ST(0) = sv_newmortal();
+ if (opnum >= 0 && opnum < sizeof(ppnames)/sizeof(char*))
+ sv_setpv(ST(0), ppnames[opnum]);
+
+void
+hash(sv)
+ SV * sv
+ CODE:
+ char *s;
+ STRLEN len;
+ U32 hash = 0;
+ char hexhash[11]; /* must fit "0xffffffff" plus trailing \0 */
+ s = SvPV(sv, len);
+ while (len--)
+ hash = hash * 33 + *s++;
+ sprintf(hexhash, "0x%x", hash);
+ ST(0) = sv_2mortal(newSVpv(hexhash, 0));
+
+#define cast_I32(foo) (I32)foo
+IV
+cast_I32(i)
+ IV i
+
+void
+minus_c()
+ CODE:
+ minus_c = TRUE;
+
+SV *
+cstring(sv)
+ SV * sv
+
+SV *
+cchar(sv)
+ SV * sv
+
+#define OP_next(o) o->op_next
+#define OP_sibling(o) o->op_sibling
+#define OP_ppaddr(o) ppnames[o->op_type]
+#define OP_targ(o) o->op_targ
+#define OP_type(o) o->op_type
+#define OP_seq(o) o->op_seq
+#define OP_flags(o) o->op_flags
+#define OP_private(o) o->op_private
+
+MODULE = B PACKAGE = B::OP PREFIX = OP_
+
+B::OP
+OP_next(o)
+ B::OP o
+
+B::OP
+OP_sibling(o)
+ B::OP o
+
+char *
+OP_ppaddr(o)
+ B::OP o
+
+U16
+OP_targ(o)
+ B::OP o
+
+U16
+OP_type(o)
+ B::OP o
+
+U16
+OP_seq(o)
+ B::OP o
+
+U8
+OP_flags(o)
+ B::OP o
+
+U8
+OP_private(o)
+ B::OP o
+
+#define UNOP_first(o) o->op_first
+
+MODULE = B PACKAGE = B::UNOP PREFIX = UNOP_
+
+B::OP
+UNOP_first(o)
+ B::UNOP o
+
+#define BINOP_last(o) o->op_last
+
+MODULE = B PACKAGE = B::BINOP PREFIX = BINOP_
+
+B::OP
+BINOP_last(o)
+ B::BINOP o
+
+#define LOGOP_other(o) o->op_other
+
+MODULE = B PACKAGE = B::LOGOP PREFIX = LOGOP_
+
+B::OP
+LOGOP_other(o)
+ B::LOGOP o
+
+#define CONDOP_true(o) o->op_true
+#define CONDOP_false(o) o->op_false
+
+MODULE = B PACKAGE = B::CONDOP PREFIX = CONDOP_
+
+B::OP
+CONDOP_true(o)
+ B::CONDOP o
+
+B::OP
+CONDOP_false(o)
+ B::CONDOP o
+
+#define LISTOP_children(o) o->op_children
+
+MODULE = B PACKAGE = B::LISTOP PREFIX = LISTOP_
+
+U32
+LISTOP_children(o)
+ B::LISTOP o
+
+#define PMOP_pmreplroot(o) o->op_pmreplroot
+#define PMOP_pmreplstart(o) o->op_pmreplstart
+#define PMOP_pmnext(o) o->op_pmnext
+#define PMOP_pmregexp(o) o->op_pmregexp
+#define PMOP_pmshort(o) o->op_pmshort
+#define PMOP_pmflags(o) o->op_pmflags
+#define PMOP_pmpermflags(o) o->op_pmpermflags
+#define PMOP_pmslen(o) o->op_pmslen
+
+MODULE = B PACKAGE = B::PMOP PREFIX = PMOP_
+
+void
+PMOP_pmreplroot(o)
+ B::PMOP o
+ OP * root = NO_INIT
+ CODE:
+ ST(0) = sv_newmortal();
+ root = o->op_pmreplroot;
+ /* OP_PUSHRE stores an SV* instead of an OP* in op_pmreplroot */
+ if (o->op_type == OP_PUSHRE) {
+ sv_setiv(newSVrv(ST(0), root ?
+ svclassnames[SvTYPE((SV*)root)] : "B::SV"),
+ (IV)root);
+ }
+ else {
+ sv_setiv(newSVrv(ST(0), cc_opclassname(root)), (IV)root);
+ }
+
+B::OP
+PMOP_pmreplstart(o)
+ B::PMOP o
+
+B::PMOP
+PMOP_pmnext(o)
+ B::PMOP o
+
+B::SV
+PMOP_pmshort(o)
+ B::PMOP o
+
+U16
+PMOP_pmflags(o)
+ B::PMOP o
+
+U16
+PMOP_pmpermflags(o)
+ B::PMOP o
+
+U8
+PMOP_pmslen(o)
+ B::PMOP o
+
+void
+PMOP_precomp(o)
+ B::PMOP o
+ REGEXP * rx = NO_INIT
+ CODE:
+ ST(0) = sv_newmortal();
+ rx = o->op_pmregexp;
+ if (rx)
+ sv_setpvn(ST(0), rx->precomp, rx->prelen);
+
+#define SVOP_sv(o) o->op_sv
+
+MODULE = B PACKAGE = B::SVOP PREFIX = SVOP_
+
+
+B::SV
+SVOP_sv(o)
+ B::SVOP o
+
+#define GVOP_gv(o) o->op_gv
+
+MODULE = B PACKAGE = B::GVOP PREFIX = GVOP_
+
+
+B::GV
+GVOP_gv(o)
+ B::GVOP o
+
+MODULE = B PACKAGE = B::PVOP PREFIX = PVOP_
+
+void
+PVOP_pv(o)
+ B::PVOP o
+ CODE:
+ /*
+ * OP_TRANS uses op_pv to point to a table of 256 shorts
+ * whereas other PVOPs point to a null terminated string.
+ */
+ ST(0) = sv_2mortal(newSVpv(o->op_pv, (o->op_type == OP_TRANS) ?
+ 256 * sizeof(short) : 0));
+
+#define LOOP_redoop(o) o->op_redoop
+#define LOOP_nextop(o) o->op_nextop
+#define LOOP_lastop(o) o->op_lastop
+
+MODULE = B PACKAGE = B::LOOP PREFIX = LOOP_
+
+
+B::OP
+LOOP_redoop(o)
+ B::LOOP o
+
+B::OP
+LOOP_nextop(o)
+ B::LOOP o
+
+B::OP
+LOOP_lastop(o)
+ B::LOOP o
+
+#define COP_label(o) o->cop_label
+#define COP_stash(o) o->cop_stash
+#define COP_filegv(o) o->cop_filegv
+#define COP_cop_seq(o) o->cop_seq
+#define COP_arybase(o) o->cop_arybase
+#define COP_line(o) o->cop_line
+
+MODULE = B PACKAGE = B::COP PREFIX = COP_
+
+char *
+COP_label(o)
+ B::COP o
+
+B::HV
+COP_stash(o)
+ B::COP o
+
+B::GV
+COP_filegv(o)
+ B::COP o
+
+U32
+COP_cop_seq(o)
+ B::COP o
+
+I32
+COP_arybase(o)
+ B::COP o
+
+U16
+COP_line(o)
+ B::COP o
+
+MODULE = B PACKAGE = B::SV PREFIX = Sv
+
+U32
+SvREFCNT(sv)
+ B::SV sv
+
+U32
+SvFLAGS(sv)
+ B::SV sv
+
+MODULE = B PACKAGE = B::IV PREFIX = Sv
+
+IV
+SvIV(sv)
+ B::IV sv
+
+IV
+SvIVX(sv)
+ B::IV sv
+
+MODULE = B PACKAGE = B::IV
+
+#define needs64bits(sv) ((I32)SvIVX(sv) != SvIVX(sv))
+
+int
+needs64bits(sv)
+ B::IV sv
+
+void
+packiv(sv)
+ B::IV sv
+ CODE:
+ if (sizeof(IV) == 8) {
+ U32 wp[2];
+ IV iv = SvIVX(sv);
+ /*
+ * The following way of spelling 32 is to stop compilers on
+ * 32-bit architectures from moaning about the shift count
+ * being >= the width of the type. Such architectures don't
+ * reach this code anyway (unless sizeof(IV) > 8 but then
+ * everything else breaks too so I'm not fussed at the moment).
+ */
+ wp[0] = htonl(((U32)iv) >> (sizeof(IV)*4));
+ wp[1] = htonl(iv & 0xffffffff);
+ ST(0) = sv_2mortal(newSVpv((char *)wp, 8));
+ } else {
+ U32 w = htonl((U32)SvIVX(sv));
+ ST(0) = sv_2mortal(newSVpv((char *)&w, 4));
+ }
+
+MODULE = B PACKAGE = B::NV PREFIX = Sv
+
+double
+SvNV(sv)
+ B::NV sv
+
+double
+SvNVX(sv)
+ B::NV sv
+
+MODULE = B PACKAGE = B::RV PREFIX = Sv
+
+B::SV
+SvRV(sv)
+ B::RV sv
+
+MODULE = B PACKAGE = B::PV PREFIX = Sv
+
+void
+SvPV(sv)
+ B::PV sv
+ CODE:
+ ST(0) = sv_newmortal();
+ sv_setpvn(ST(0), SvPVX(sv), SvCUR(sv));
+
+MODULE = B PACKAGE = B::PVMG PREFIX = Sv
+
+void
+SvMAGIC(sv)
+ B::PVMG sv
+ MAGIC * mg = NO_INIT
+ PPCODE:
+ for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
+ XPUSHs(make_mg_object(sv_newmortal(), mg));
+
+MODULE = B PACKAGE = B::PVMG
+
+B::HV
+SvSTASH(sv)
+ B::PVMG sv
+
+#define MgMOREMAGIC(mg) mg->mg_moremagic
+#define MgPRIVATE(mg) mg->mg_private
+#define MgTYPE(mg) mg->mg_type
+#define MgFLAGS(mg) mg->mg_flags
+#define MgOBJ(mg) mg->mg_obj
+
+MODULE = B PACKAGE = B::MAGIC PREFIX = Mg
+
+B::MAGIC
+MgMOREMAGIC(mg)
+ B::MAGIC mg
+
+U16
+MgPRIVATE(mg)
+ B::MAGIC mg
+
+char
+MgTYPE(mg)
+ B::MAGIC mg
+
+U8
+MgFLAGS(mg)
+ B::MAGIC mg
+
+B::SV
+MgOBJ(mg)
+ B::MAGIC mg
+
+void
+MgPTR(mg)
+ B::MAGIC mg
+ CODE:
+ ST(0) = sv_newmortal();
+ if (mg->mg_ptr)
+ sv_setpvn(ST(0), mg->mg_ptr, mg->mg_len);
+
+MODULE = B PACKAGE = B::PVLV PREFIX = Lv
+
+U32
+LvTARGOFF(sv)
+ B::PVLV sv
+
+U32
+LvTARGLEN(sv)
+ B::PVLV sv
+
+char
+LvTYPE(sv)
+ B::PVLV sv
+
+B::SV
+LvTARG(sv)
+ B::PVLV sv
+
+MODULE = B PACKAGE = B::BM PREFIX = Bm
+
+I32
+BmUSEFUL(sv)
+ B::BM sv
+
+U16
+BmPREVIOUS(sv)
+ B::BM sv
+
+U8
+BmRARE(sv)
+ B::BM sv
+
+void
+BmTABLE(sv)
+ B::BM sv
+ STRLEN len = NO_INIT
+ char * str = NO_INIT
+ CODE:
+ str = SvPV(sv, len);
+ /* Boyer-Moore table is just after string and its safety-margin \0 */
+ ST(0) = sv_2mortal(newSVpv(str + len + 1, 256));
+
+MODULE = B PACKAGE = B::GV PREFIX = Gv
+
+void
+GvNAME(gv)
+ B::GV gv
+ CODE:
+ ST(0) = sv_2mortal(newSVpv(GvNAME(gv), GvNAMELEN(gv)));
+
+B::HV
+GvSTASH(gv)
+ B::GV gv
+
+B::SV
+GvSV(gv)
+ B::GV gv
+
+B::IO
+GvIO(gv)
+ B::GV gv
+
+B::CV
+GvFORM(gv)
+ B::GV gv
+
+B::AV
+GvAV(gv)
+ B::GV gv
+
+B::HV
+GvHV(gv)
+ B::GV gv
+
+B::GV
+GvEGV(gv)
+ B::GV gv
+
+B::CV
+GvCV(gv)
+ B::GV gv
+
+U32
+GvCVGEN(gv)
+ B::GV gv
+
+U16
+GvLINE(gv)
+ B::GV gv
+
+B::GV
+GvFILEGV(gv)
+ B::GV gv
+
+MODULE = B PACKAGE = B::GV
+
+U32
+GvREFCNT(gv)
+ B::GV gv
+
+U8
+GvFLAGS(gv)
+ B::GV gv
+
+MODULE = B PACKAGE = B::IO PREFIX = Io
+
+long
+IoLINES(io)
+ B::IO io
+
+long
+IoPAGE(io)
+ B::IO io
+
+long
+IoPAGE_LEN(io)
+ B::IO io
+
+long
+IoLINES_LEFT(io)
+ B::IO io
+
+char *
+IoTOP_NAME(io)
+ B::IO io
+
+B::GV
+IoTOP_GV(io)
+ B::IO io
+
+char *
+IoFMT_NAME(io)
+ B::IO io
+
+B::GV
+IoFMT_GV(io)
+ B::IO io
+
+char *
+IoBOTTOM_NAME(io)
+ B::IO io
+
+B::GV
+IoBOTTOM_GV(io)
+ B::IO io
+
+short
+IoSUBPROCESS(io)
+ B::IO io
+
+MODULE = B PACKAGE = B::IO
+
+char
+IoTYPE(io)
+ B::IO io
+
+U8
+IoFLAGS(io)
+ B::IO io
+
+MODULE = B PACKAGE = B::AV PREFIX = Av
+
+SSize_t
+AvFILL(av)
+ B::AV av
+
+SSize_t
+AvMAX(av)
+ B::AV av
+
+#define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off
+
+IV
+AvOFF(av)
+ B::AV av
+
+void
+AvARRAY(av)
+ B::AV av
+ PPCODE:
+ if (AvFILL(av) >= 0) {
+ SV **svp = AvARRAY(av);
+ I32 i;
+ for (i = 0; i <= AvFILL(av); i++)
+ XPUSHs(make_sv_object(sv_newmortal(), svp[i]));
+ }
+
+MODULE = B PACKAGE = B::AV
+
+U8
+AvFLAGS(av)
+ B::AV av
+
+MODULE = B PACKAGE = B::CV PREFIX = Cv
+
+B::HV
+CvSTASH(cv)
+ B::CV cv
+
+B::OP
+CvSTART(cv)
+ B::CV cv
+
+B::OP
+CvROOT(cv)
+ B::CV cv
+
+B::GV
+CvGV(cv)
+ B::CV cv
+
+B::GV
+CvFILEGV(cv)
+ B::CV cv
+
+long
+CvDEPTH(cv)
+ B::CV cv
+
+B::AV
+CvPADLIST(cv)
+ B::CV cv
+
+B::CV
+CvOUTSIDE(cv)
+ B::CV cv
+
+void
+CvXSUB(cv)
+ B::CV cv
+ CODE:
+ ST(0) = sv_2mortal(newSViv((IV)CvXSUB(cv)));
+
+
+void
+CvXSUBANY(cv)
+ B::CV cv
+ CODE:
+ ST(0) = sv_2mortal(newSViv(CvXSUBANY(cv).any_iv));
+
+MODULE = B PACKAGE = B::HV PREFIX = Hv
+
+STRLEN
+HvFILL(hv)
+ B::HV hv
+
+STRLEN
+HvMAX(hv)
+ B::HV hv
+
+I32
+HvKEYS(hv)
+ B::HV hv
+
+I32
+HvRITER(hv)
+ B::HV hv
+
+char *
+HvNAME(hv)
+ B::HV hv
+
+B::PMOP
+HvPMROOT(hv)
+ B::HV hv
+
+void
+HvARRAY(hv)
+ B::HV hv
+ PPCODE:
+ if (HvKEYS(hv) > 0) {
+ SV *sv;
+ char *key;
+ I32 len;
+ (void)hv_iterinit(hv);
+ EXTEND(sp, HvKEYS(hv) * 2);
+ while (sv = hv_iternextsv(hv, &key, &len)) {
+ PUSHs(newSVpv(key, len));
+ PUSHs(make_sv_object(sv_newmortal(), sv));
+ }
+ }
--- /dev/null
+#
+# Copyright (c) 1996 Malcolm Beattie
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the README file.
+#
+#
+#
+# This file is autogenerated from bytecode.pl. Changes made here will be lost.
+#
+package B::Asmdata;
+use Exporter;
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(%insn_data @insn_name @optype @specialsv_name);
+use vars qw(%insn_data @insn_name @optype @specialsv_name);
+
+@optype = qw(OP UNOP BINOP LOGOP CONDOP LISTOP PMOP SVOP GVOP PVOP LOOP COP);
+@specialsv_name = qw(Nullsv &sv_undef &sv_yes &sv_no);
+
+# XXX insn_data is initialised this way because with a large
+# %insn_data = (foo => [...], bar => [...], ...) initialiser
+# I get a hard-to-track-down stack underflow and segfault.
+$insn_data{comment} = [35, \&PUT_comment, "GET_comment"];
+$insn_data{nop} = [10, \&PUT_none, "GET_none"];
+$insn_data{ret} = [0, \&PUT_none, "GET_none"];
+$insn_data{ldsv} = [1, \&PUT_objindex, "GET_objindex"];
+$insn_data{ldop} = [2, \&PUT_objindex, "GET_objindex"];
+$insn_data{stsv} = [3, \&PUT_U32, "GET_U32"];
+$insn_data{stop} = [4, \&PUT_U32, "GET_U32"];
+$insn_data{ldspecsv} = [5, \&PUT_U8, "GET_U8"];
+$insn_data{newsv} = [6, \&PUT_U8, "GET_U8"];
+$insn_data{newop} = [7, \&PUT_U8, "GET_U8"];
+$insn_data{newopn} = [8, \&PUT_U8, "GET_U8"];
+$insn_data{newpv} = [9, \&PUT_PV, "GET_PV"];
+$insn_data{pv_cur} = [11, \&PUT_U32, "GET_U32"];
+$insn_data{pv_free} = [12, \&PUT_none, "GET_none"];
+$insn_data{sv_upgrade} = [13, \&PUT_U8, "GET_U8"];
+$insn_data{sv_refcnt} = [14, \&PUT_U32, "GET_U32"];
+$insn_data{sv_refcnt_add} = [15, \&PUT_I32, "GET_I32"];
+$insn_data{sv_flags} = [16, \&PUT_U32, "GET_U32"];
+$insn_data{xrv} = [17, \&PUT_objindex, "GET_objindex"];
+$insn_data{xpv} = [18, \&PUT_none, "GET_none"];
+$insn_data{xiv32} = [19, \&PUT_I32, "GET_I32"];
+$insn_data{xiv64} = [20, \&PUT_IV64, "GET_IV64"];
+$insn_data{xnv} = [21, \&PUT_double, "GET_double"];
+$insn_data{xlv_targoff} = [22, \&PUT_U32, "GET_U32"];
+$insn_data{xlv_targlen} = [23, \&PUT_U32, "GET_U32"];
+$insn_data{xlv_targ} = [24, \&PUT_objindex, "GET_objindex"];
+$insn_data{xlv_type} = [25, \&PUT_U8, "GET_U8"];
+$insn_data{xbm_useful} = [26, \&PUT_I32, "GET_I32"];
+$insn_data{xbm_previous} = [27, \&PUT_U16, "GET_U16"];
+$insn_data{xbm_rare} = [28, \&PUT_U8, "GET_U8"];
+$insn_data{xfm_lines} = [29, \&PUT_I32, "GET_I32"];
+$insn_data{xio_lines} = [30, \&PUT_I32, "GET_I32"];
+$insn_data{xio_page} = [31, \&PUT_I32, "GET_I32"];
+$insn_data{xio_page_len} = [32, \&PUT_I32, "GET_I32"];
+$insn_data{xio_lines_left} = [33, \&PUT_I32, "GET_I32"];
+$insn_data{xio_top_name} = [34, \&PUT_pvcontents, "GET_pvcontents"];
+$insn_data{xio_top_gv} = [36, \&PUT_objindex, "GET_objindex"];
+$insn_data{xio_fmt_name} = [37, \&PUT_pvcontents, "GET_pvcontents"];
+$insn_data{xio_fmt_gv} = [38, \&PUT_objindex, "GET_objindex"];
+$insn_data{xio_bottom_name} = [39, \&PUT_pvcontents, "GET_pvcontents"];
+$insn_data{xio_bottom_gv} = [40, \&PUT_objindex, "GET_objindex"];
+$insn_data{xio_subprocess} = [41, \&PUT_U16, "GET_U16"];
+$insn_data{xio_type} = [42, \&PUT_U8, "GET_U8"];
+$insn_data{xio_flags} = [43, \&PUT_U8, "GET_U8"];
+$insn_data{xcv_stash} = [44, \&PUT_objindex, "GET_objindex"];
+$insn_data{xcv_start} = [45, \&PUT_objindex, "GET_objindex"];
+$insn_data{xcv_root} = [46, \&PUT_objindex, "GET_objindex"];
+$insn_data{xcv_gv} = [47, \&PUT_objindex, "GET_objindex"];
+$insn_data{xcv_filegv} = [48, \&PUT_objindex, "GET_objindex"];
+$insn_data{xcv_depth} = [49, \&PUT_I32, "GET_I32"];
+$insn_data{xcv_padlist} = [50, \&PUT_objindex, "GET_objindex"];
+$insn_data{xcv_outside} = [51, \&PUT_objindex, "GET_objindex"];
+$insn_data{xcv_flags} = [52, \&PUT_U8, "GET_U8"];
+$insn_data{av_extend} = [53, \&PUT_I32, "GET_I32"];
+$insn_data{av_push} = [54, \&PUT_objindex, "GET_objindex"];
+$insn_data{xav_fill} = [55, \&PUT_I32, "GET_I32"];
+$insn_data{xav_max} = [56, \&PUT_I32, "GET_I32"];
+$insn_data{xav_flags} = [57, \&PUT_U8, "GET_U8"];
+$insn_data{xhv_riter} = [58, \&PUT_I32, "GET_I32"];
+$insn_data{xhv_name} = [59, \&PUT_pvcontents, "GET_pvcontents"];
+$insn_data{hv_store} = [60, \&PUT_objindex, "GET_objindex"];
+$insn_data{sv_magic} = [61, \&PUT_U8, "GET_U8"];
+$insn_data{mg_obj} = [62, \&PUT_objindex, "GET_objindex"];
+$insn_data{mg_private} = [63, \&PUT_U16, "GET_U16"];
+$insn_data{mg_flags} = [64, \&PUT_U8, "GET_U8"];
+$insn_data{mg_pv} = [65, \&PUT_pvcontents, "GET_pvcontents"];
+$insn_data{xmg_stash} = [66, \&PUT_objindex, "GET_objindex"];
+$insn_data{gv_fetchpv} = [67, \&PUT_strconst, "GET_strconst"];
+$insn_data{gv_stashpv} = [68, \&PUT_strconst, "GET_strconst"];
+$insn_data{gp_sv} = [69, \&PUT_objindex, "GET_objindex"];
+$insn_data{gp_refcnt} = [70, \&PUT_U32, "GET_U32"];
+$insn_data{gp_refcnt_add} = [71, \&PUT_I32, "GET_I32"];
+$insn_data{gp_av} = [72, \&PUT_objindex, "GET_objindex"];
+$insn_data{gp_hv} = [73, \&PUT_objindex, "GET_objindex"];
+$insn_data{gp_cv} = [74, \&PUT_objindex, "GET_objindex"];
+$insn_data{gp_filegv} = [75, \&PUT_objindex, "GET_objindex"];
+$insn_data{gp_io} = [76, \&PUT_objindex, "GET_objindex"];
+$insn_data{gp_form} = [77, \&PUT_objindex, "GET_objindex"];
+$insn_data{gp_cvgen} = [78, \&PUT_U32, "GET_U32"];
+$insn_data{gp_line} = [79, \&PUT_U16, "GET_U16"];
+$insn_data{gp_share} = [80, \&PUT_objindex, "GET_objindex"];
+$insn_data{xgv_flags} = [81, \&PUT_U8, "GET_U8"];
+$insn_data{op_next} = [82, \&PUT_objindex, "GET_objindex"];
+$insn_data{op_sibling} = [83, \&PUT_objindex, "GET_objindex"];
+$insn_data{op_ppaddr} = [84, \&PUT_strconst, "GET_strconst"];
+$insn_data{op_targ} = [85, \&PUT_U32, "GET_U32"];
+$insn_data{op_type} = [86, \&PUT_U16, "GET_U16"];
+$insn_data{op_seq} = [87, \&PUT_U16, "GET_U16"];
+$insn_data{op_flags} = [88, \&PUT_U8, "GET_U8"];
+$insn_data{op_private} = [89, \&PUT_U8, "GET_U8"];
+$insn_data{op_first} = [90, \&PUT_objindex, "GET_objindex"];
+$insn_data{op_last} = [91, \&PUT_objindex, "GET_objindex"];
+$insn_data{op_other} = [92, \&PUT_objindex, "GET_objindex"];
+$insn_data{op_true} = [93, \&PUT_objindex, "GET_objindex"];
+$insn_data{op_false} = [94, \&PUT_objindex, "GET_objindex"];
+$insn_data{op_children} = [95, \&PUT_U32, "GET_U32"];
+$insn_data{op_pmreplroot} = [96, \&PUT_objindex, "GET_objindex"];
+$insn_data{op_pmreplrootgv} = [97, \&PUT_objindex, "GET_objindex"];
+$insn_data{op_pmreplstart} = [98, \&PUT_objindex, "GET_objindex"];
+$insn_data{op_pmnext} = [99, \&PUT_objindex, "GET_objindex"];
+$insn_data{pregcomp} = [100, \&PUT_pvcontents, "GET_pvcontents"];
+$insn_data{op_pmshort} = [101, \&PUT_objindex, "GET_objindex"];
+$insn_data{op_pmflags} = [102, \&PUT_U16, "GET_U16"];
+$insn_data{op_pmpermflags} = [103, \&PUT_U16, "GET_U16"];
+$insn_data{op_pmslen} = [104, \&PUT_U8, "GET_U8"];
+$insn_data{op_sv} = [105, \&PUT_objindex, "GET_objindex"];
+$insn_data{op_gv} = [106, \&PUT_objindex, "GET_objindex"];
+$insn_data{op_pv} = [107, \&PUT_pvcontents, "GET_pvcontents"];
+$insn_data{op_pv_tr} = [108, \&PUT_op_tr_array, "GET_op_tr_array"];
+$insn_data{op_redoop} = [109, \&PUT_objindex, "GET_objindex"];
+$insn_data{op_nextop} = [110, \&PUT_objindex, "GET_objindex"];
+$insn_data{op_lastop} = [111, \&PUT_objindex, "GET_objindex"];
+$insn_data{cop_label} = [112, \&PUT_pvcontents, "GET_pvcontents"];
+$insn_data{cop_stash} = [113, \&PUT_objindex, "GET_objindex"];
+$insn_data{cop_filegv} = [114, \&PUT_objindex, "GET_objindex"];
+$insn_data{cop_seq} = [115, \&PUT_U32, "GET_U32"];
+$insn_data{cop_arybase} = [116, \&PUT_I32, "GET_I32"];
+$insn_data{cop_line} = [117, \&PUT_U16, "GET_U16"];
+$insn_data{main_start} = [118, \&PUT_objindex, "GET_objindex"];
+$insn_data{main_root} = [119, \&PUT_objindex, "GET_objindex"];
+$insn_data{curpad} = [120, \&PUT_objindex, "GET_objindex"];
+
+my ($insn_name, $insn_data);
+while (($insn_name, $insn_data) = each %insn_data) {
+ $insn_name[$insn_data->[0]] = $insn_name;
+}
+# Fill in any gaps
+@insn_name = map($_ || "unused", @insn_name);
+
+1;
--- /dev/null
+# Assembler.pm
+#
+# Copyright (c) 1996 Malcolm Beattie
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the README file.
+package B::Assembler;
+use Exporter;
+use B qw(ppname);
+use B::Asmdata qw(%insn_data @insn_name);
+
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(assemble_fh assemble_insn strip_comments
+ parse_statement uncstring);
+
+use strict;
+my %opnumber;
+my ($i, $opname);
+for ($i = 0; defined($opname = ppname($i)); $i++) {
+ $opnumber{$opname} = $i;
+}
+
+my ($linenum, $errors);
+
+sub error {
+ my $str = shift;
+ warn "$linenum: $str\n";
+ $errors++;
+}
+
+my $debug = 0;
+sub debug { $debug = shift }
+
+#
+# First define all the data conversion subs to which Asmdata will refer
+#
+
+sub B::Asmdata::PUT_U8 {
+ my $arg = shift;
+ my $c = uncstring($arg);
+ if (defined($c)) {
+ if (length($c) != 1) {
+ error "argument for U8 is too long: $c";
+ $c = substr($c, 0, 1);
+ }
+ } else {
+ $c = chr($arg);
+ }
+ return $c;
+}
+
+sub B::Asmdata::PUT_U16 { pack("n", $_[0]) }
+sub B::Asmdata::PUT_U32 { pack("N", $_[0]) }
+sub B::Asmdata::PUT_I32 { pack("N", $_[0]) }
+sub B::Asmdata::PUT_objindex { pack("N", $_[0]) } # could allow names here
+
+sub B::Asmdata::PUT_strconst {
+ my $arg = shift;
+ $arg = uncstring($arg);
+ if (!defined($arg)) {
+ error "bad string constant: $arg";
+ return "";
+ }
+ if ($arg =~ s/\0//g) {
+ error "string constant argument contains NUL: $arg";
+ }
+ return $arg . "\0";
+}
+
+sub B::Asmdata::PUT_pvcontents {
+ my $arg = shift;
+ error "extraneous argument: $arg" if defined $arg;
+ return "";
+}
+sub B::Asmdata::PUT_PV {
+ my $arg = shift;
+ $arg = uncstring($arg);
+ error "bad string argument: $arg" unless defined($arg);
+ return pack("N", length($arg)) . $arg;
+}
+sub B::Asmdata::PUT_comment {
+ my $arg = shift;
+ $arg = uncstring($arg);
+ error "bad string argument: $arg" unless defined($arg);
+ if ($arg =~ s/\n//g) {
+ error "comment argument contains linefeed: $arg";
+ }
+ return $arg . "\n";
+}
+sub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) }
+sub B::Asmdata::PUT_none {
+ my $arg = shift;
+ error "extraneous argument: $arg" if defined $arg;
+ return "";
+}
+sub B::Asmdata::PUT_op_tr_array {
+ my $arg = shift;
+ my @ary = split(/\s*,\s*/, $arg);
+ if (@ary != 256) {
+ error "wrong number of arguments to op_tr_array";
+ @ary = (0) x 256;
+ }
+ return pack("n256", @ary);
+}
+# XXX Check this works
+sub B::Asmdata::PUT_IV64 {
+ my $arg = shift;
+ return pack("NN", $arg >> 32, $arg & 0xffffffff);
+}
+
+my %unesc = (n => "\n", r => "\r", t => "\t", a => "\a",
+ b => "\b", f => "\f", v => "\013");
+
+sub uncstring {
+ my $s = shift;
+ $s =~ s/^"// and $s =~ s/"$// or return undef;
+ $s =~ s/\\(\d\d\d|.)/length($1) == 3 ? chr(oct($1)) : ($unesc{$1}||$1)/eg;
+ return $s;
+}
+
+sub strip_comments {
+ my $stmt = shift;
+ # Comments only allowed in instructions which don't take string arguments
+ $stmt =~ s{
+ (?sx) # Snazzy extended regexp coming up. Also, treat
+ # string as a single line so .* eats \n characters.
+ ^\s* # Ignore leading whitespace
+ (
+ [^"]* # A double quote '"' indicates a string argument. If we
+ # find a double quote, the match fails and we strip nothing.
+ )
+ \s*\# # Any amount of whitespace plus the comment marker...
+ .*$ # ...which carries on to end-of-string.
+ }{$1}; # Keep only the instruction and optional argument.
+ return $stmt;
+}
+
+sub parse_statement {
+ my $stmt = shift;
+ my ($insn, $arg) = $stmt =~ m{
+ (?sx)
+ ^\s* # allow (but ignore) leading whitespace
+ (.*?) # Instruction continues up until...
+ (?: # ...an optional whitespace+argument group
+ \s+ # first whitespace.
+ (.*) # The argument is all the rest (newlines included).
+ )?$ # anchor at end-of-line
+ };
+ if (defined($arg)) {
+ if ($arg =~ s/^0x(?=[0-9a-fA-F]+$)//) {
+ $arg = hex($arg);
+ } elsif ($arg =~ s/^0(?=[0-7]+$)//) {
+ $arg = oct($arg);
+ } elsif ($arg =~ /^pp_/) {
+ $arg =~ s/\s*$//; # strip trailing whitespace
+ my $opnum = $opnumber{$arg};
+ if (defined($opnum)) {
+ $arg = $opnum;
+ } else {
+ error qq(No such op type "$arg");
+ $arg = 0;
+ }
+ }
+ }
+ return ($insn, $arg);
+}
+
+sub assemble_insn {
+ my ($insn, $arg) = @_;
+ my $data = $insn_data{$insn};
+ if (defined($data)) {
+ my ($bytecode, $putsub) = @{$data}[0, 1];
+ my $argcode = &$putsub($arg);
+ return chr($bytecode).$argcode;
+ } else {
+ error qq(no such instruction "$insn");
+ return "";
+ }
+}
+
+sub assemble_fh {
+ my ($fh, $out) = @_;
+ my ($line, $insn, $arg);
+ $linenum = 0;
+ $errors = 0;
+ while ($line = <$fh>) {
+ $linenum++;
+ chomp $line;
+ if ($debug) {
+ my $quotedline = $line;
+ $quotedline =~ s/\\/\\\\/g;
+ $quotedline =~ s/"/\\"/g;
+ &$out(assemble_insn("comment", qq("$quotedline")));
+ }
+ $line = strip_comments($line) or next;
+ ($insn, $arg) = parse_statement($line);
+ &$out(assemble_insn($insn, $arg));
+ if ($debug) {
+ &$out(assemble_insn("nop", undef));
+ }
+ }
+ if ($errors) {
+ die "Assembly failed with $errors error(s)\n";
+ }
+}
+
+1;
--- /dev/null
+package B::Bblock;
+use Exporter ();
+@ISA = "Exporter";
+@EXPORT_OK = qw(find_leaders);
+
+use B qw(ad peekop walkoptree walkoptree_exec
+ main_root main_start svref_2object);
+use B::Terse;
+use strict;
+
+my $bblock;
+my @bblock_ends;
+
+sub mark_leader {
+ my $op = shift;
+ if (ad($op)) {
+ $bblock->{ad($op)} = $op;
+ }
+}
+
+sub find_leaders {
+ my ($root, $start) = @_;
+ $bblock = {};
+ mark_leader($start);
+ walkoptree($root, "mark_if_leader");
+ return $bblock;
+}
+
+# Debugging
+sub walk_bblocks {
+ my ($root, $start) = @_;
+ my ($op, $lastop, $leader, $bb);
+ $bblock = {};
+ mark_leader($start);
+ walkoptree($root, "mark_if_leader");
+ my @leaders = values %$bblock;
+ while ($leader = shift @leaders) {
+ $lastop = $leader;
+ $op = $leader->next;
+ while (ad($op) && !exists($bblock->{ad($op)})) {
+ $bblock->{ad($op)} = $leader;
+ $lastop = $op;
+ $op = $op->next;
+ }
+ push(@bblock_ends, [$leader, $lastop]);
+ }
+ foreach $bb (@bblock_ends) {
+ ($leader, $lastop) = @$bb;
+ printf "%s .. %s\n", peekop($leader), peekop($lastop);
+ for ($op = $leader; ad($op) != ad($lastop); $op = $op->next) {
+ printf " %s\n", peekop($op);
+ }
+ printf " %s\n", peekop($lastop);
+ }
+ print "-------\n";
+ walkoptree_exec($start, "terse");
+}
+
+sub walk_bblocks_obj {
+ my $cvref = shift;
+ my $cv = svref_2object($cvref);
+ walk_bblocks($cv->ROOT, $cv->START);
+}
+
+sub B::OP::mark_if_leader {
+ my $op = shift;
+ my $ppaddr = $op->ppaddr;
+# if ($ppaddr eq "pp_enter" || $ppaddr eq "pp_entersub" || $ppaddr eq "pp_return") {
+ if ($ppaddr eq "pp_enter" || $ppaddr eq "pp_return") {
+ mark_leader($op->next);
+ }
+}
+
+sub B::COP::mark_if_leader {
+ my $op = shift;
+ if ($op->label) {
+ mark_leader($op);
+ }
+}
+
+sub B::LOOP::mark_if_leader {
+ my $op = shift;
+ mark_leader($op->next);
+ mark_leader($op->nextop);
+ mark_leader($op->redoop);
+ mark_leader($op->lastop->next);
+}
+
+sub B::LOGOP::mark_if_leader {
+ my $op = shift;
+ my $ppaddr = $op->ppaddr;
+ mark_leader($op->next);
+ if ($ppaddr eq "pp_entertry") {
+ mark_leader($op->other->next);
+ } else {
+ mark_leader($op->other);
+ }
+}
+
+sub B::CONDOP::mark_if_leader {
+ my $op = shift;
+ mark_leader($op->next);
+ mark_leader($op->true);
+ mark_leader($op->false);
+}
+
+sub B::PMOP::mark_if_leader {
+ my $op = shift;
+ if ($op->ppaddr ne "pp_pushre") {
+ my $replroot = $op->pmreplroot;
+ if (ad($replroot)) {
+ mark_leader($replroot);
+ mark_leader($op->next);
+ mark_leader($op->pmreplstart);
+ }
+ }
+}
+
+# PMOP stuff omitted
+
+sub compile {
+ my @options = @_;
+ if (@options) {
+ return sub {
+ my $objname;
+ foreach $objname (@options) {
+ $objname = "main::$objname" unless $objname =~ /::/;
+ eval "walk_bblocks_obj(\\&$objname)";
+ die "walk_bblocks_obj(\\&$objname) failed: $@" if $@;
+ }
+ }
+ } else {
+ return sub { walk_bblocks(main_root, main_start) };
+ }
+}
+
+# Basic block leaders:
+# Any COP (pp_nextstate) with a non-NULL label
+# The op after a pp_enter
+# [The op after a pp_entersub. Don't count this one.]
+# The ops pointed at by nextop, redoop and lastop->op_next of a LOOP
+# The ops pointed at by op_next and op_other of a LOGOP, except
+# for pp_entertry which has op_next and op_other->op_next
+# The ops pointed at by op_true and op_false of a CONDOP
+# The op pointed at by op_pmreplstart of a PMOP
+# The op pointed at by op_other->op_pmreplstart of pp_substcont?
+# The op after a pp_return
+
+1;
--- /dev/null
+# Bytecode.pm
+#
+# Copyright (c) 1996 Malcolm Beattie
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the README file.
+#
+package B::Bytecode;
+use strict;
+use Carp;
+
+use B qw(ad minus_c main_cv main_root main_start comppadlist
+ class peekop walkoptree svref_2object cstring walksymtable);
+use B::Asmdata qw(@optype @specialsv_name);
+use B::Assembler qw(assemble_fh);
+
+my %optype_enum;
+my $i;
+for ($i = 0; $i < @optype; $i++) {
+ $optype_enum{$optype[$i]} = $i;
+}
+
+# Following is SVf_POK|SVp_POK
+# XXX Shouldn't be hardwired
+sub POK () { 0x04040000 }
+
+# Following is SVf_IOK|SVp_OK
+# XXX Shouldn't be hardwired
+sub IOK () { 0x01010000 }
+
+my ($verbose, $module_only, $no_assemble, $debug_cv);
+my $assembler_pid;
+
+# Optimisation options. On the command line, use hyphens instead of
+# underscores for compatibility with gcc-style options. We use
+# underscores here because they are OK in (strict) barewords.
+my ($strip_syntree, $compress_nullops, $omit_seq, $bypass_nullops);
+my %optimise = (strip_syntax_tree => \$strip_syntree,
+ compress_nullops => \$compress_nullops,
+ omit_sequence_numbers => \$omit_seq,
+ bypass_nullops => \$bypass_nullops);
+
+my $nextix = 0;
+my %symtable; # maps object addresses to object indices.
+ # Filled in at allocation (newsv/newop) time.
+my %saved; # maps object addresses (for SVish classes) to "saved yet?"
+ # flag. Set at FOO::bytecode time usually by SV::bytecode.
+ # Manipulated via saved(), mark_saved(), unmark_saved().
+
+my $svix = -1; # we keep track of when the sv register contains an element
+ # of the object table to avoid unnecessary repeated
+ # consecutive ldsv instructions.
+my $opix = -1; # Ditto for the op register.
+
+sub ldsv {
+ my $ix = shift;
+ if ($ix != $svix) {
+ print "ldsv $ix\n";
+ $svix = $ix;
+ }
+}
+
+sub stsv {
+ my $ix = shift;
+ print "stsv $ix\n";
+ $svix = $ix;
+}
+
+sub set_svix {
+ $svix = shift;
+}
+
+sub ldop {
+ my $ix = shift;
+ if ($ix != $opix) {
+ print "ldop $ix\n";
+ $opix = $ix;
+ }
+}
+
+sub stop {
+ my $ix = shift;
+ print "stop $ix\n";
+ $opix = $ix;
+}
+
+sub set_opix {
+ $opix = shift;
+}
+
+sub pvstring {
+ my $str = shift;
+ if (defined($str)) {
+ return cstring($str . "\0");
+ } else {
+ return '""';
+ }
+}
+
+sub saved { $saved{ad($_[0])} }
+sub mark_saved { $saved{ad($_[0])} = 1 }
+sub unmark_saved { $saved{ad($_[0])} = 0 }
+
+my $debug = 0;
+sub debug { $debug = shift }
+
+sub B::OBJECT::nyi {
+ my $obj = shift;
+ warn sprintf("bytecode save method for %s (0x%x) not yet implemented\n",
+ class($obj), ad($obj));
+}
+
+#
+# objix may stomp on the op register (for op objects)
+# or the sv register (for SV objects)
+#
+sub B::OBJECT::objix {
+ my $obj = shift;
+ my $ix = $symtable{$$obj};
+ if (defined($ix)) {
+ return $ix;
+ } else {
+ $obj->newix($nextix);
+ return $symtable{$$obj} = $nextix++;
+ }
+}
+
+sub B::SV::newix {
+ my ($sv, $ix) = @_;
+ printf "newsv %d\t# %s\n", $sv->FLAGS & 0xf, class($sv);
+ stsv($ix);
+}
+
+sub B::GV::newix {
+ my ($gv, $ix) = @_;
+ my $gvname = $gv->NAME;
+ my $name = cstring($gv->STASH->NAME . "::" . $gvname);
+ print "gv_fetchpv $name\n";
+ stsv($ix);
+}
+
+sub B::HV::newix {
+ my ($hv, $ix) = @_;
+ my $name = $hv->NAME;
+ if ($name) {
+ # It's a stash
+ printf "gv_stashpv %s\n", cstring($name);
+ stsv($ix);
+ } else {
+ # It's an ordinary HV. Fall back to ordinary newix method
+ $hv->B::SV::newix($ix);
+ }
+}
+
+sub B::SPECIAL::newix {
+ my ($sv, $ix) = @_;
+ # Special case. $$sv is not the address of the SV but an
+ # index into svspecialsv_list.
+ printf "ldspecsv $$sv\t# %s\n", $specialsv_name[$$sv];
+ stsv($ix);
+}
+
+sub B::OP::newix {
+ my ($op, $ix) = @_;
+ my $class = class($op);
+ my $typenum = $optype_enum{$class};
+ croak "OP::newix: can't understand class $class" unless defined($typenum);
+ print "newop $typenum\t# $class\n";
+ stop($ix);
+}
+
+sub B::OP::bytecode {
+ my $op = shift;
+ my $next = $op->next;
+ my $nextix;
+ my $sibix = $op->sibling->objix;
+ my $ix = $op->objix;
+ my $type = $op->type;
+
+ if ($bypass_nullops) {
+ $next = $next->next while ad($next) && $next->type == 0;
+ }
+ $nextix = $next->objix;
+
+ printf "# %s\n", peekop($op) if $debug;
+ ldop($ix);
+ print "op_next $nextix\n";
+ print "op_sibling $sibix\n" unless $strip_syntree;
+ printf "op_type %s\t# %d\n", $op->ppaddr, $type;
+ printf("op_seq %d\n", $op->seq) unless $omit_seq;
+ if ($type || !$compress_nullops) {
+ printf "op_targ %d\nop_flags 0x%x\nop_private 0x%x\n",
+ $op->targ, $op->flags, $op->private;
+ }
+}
+
+sub B::UNOP::bytecode {
+ my $op = shift;
+ my $firstix = $op->first->objix;
+ $op->B::OP::bytecode;
+ if (($op->type || !$compress_nullops) && !$strip_syntree) {
+ print "op_first $firstix\n";
+ }
+}
+
+sub B::LOGOP::bytecode {
+ my $op = shift;
+ my $otherix = $op->other->objix;
+ $op->B::UNOP::bytecode;
+ print "op_other $otherix\n";
+}
+
+sub B::SVOP::bytecode {
+ my $op = shift;
+ my $sv = $op->sv;
+ my $svix = $sv->objix;
+ $op->B::OP::bytecode;
+ print "op_sv $svix\n";
+ $sv->bytecode;
+}
+
+sub B::GVOP::bytecode {
+ my $op = shift;
+ my $gv = $op->gv;
+ my $gvix = $gv->objix;
+ $op->B::OP::bytecode;
+ print "op_gv $gvix\n";
+ $gv->bytecode;
+}
+
+sub B::PVOP::bytecode {
+ my $op = shift;
+ my $pv = $op->pv;
+ $op->B::OP::bytecode;
+ #
+ # This would be easy except that OP_TRANS uses a PVOP to store an
+ # endian-dependent array of 256 shorts instead of a plain string.
+ #
+ if ($op->ppaddr eq "pp_trans") {
+ my @shorts = unpack("s256", $pv); # assembler handles endianness
+ print "op_pv_tr ", join(",", @shorts), "\n";
+ } else {
+ printf "newpv %s\nop_pv\n", pvstring($pv);
+ }
+}
+
+sub B::BINOP::bytecode {
+ my $op = shift;
+ my $lastix = $op->last->objix;
+ $op->B::UNOP::bytecode;
+ if (($op->type || !$compress_nullops) && !$strip_syntree) {
+ print "op_last $lastix\n";
+ }
+}
+
+sub B::CONDOP::bytecode {
+ my $op = shift;
+ my $trueix = $op->true->objix;
+ my $falseix = $op->false->objix;
+ $op->B::UNOP::bytecode;
+ print "op_true $trueix\nop_false $falseix\n";
+}
+
+sub B::LISTOP::bytecode {
+ my $op = shift;
+ my $children = $op->children;
+ $op->B::BINOP::bytecode;
+ if (($op->type || !$compress_nullops) && !$strip_syntree) {
+ print "op_children $children\n";
+ }
+}
+
+sub B::LOOP::bytecode {
+ my $op = shift;
+ my $redoopix = $op->redoop->objix;
+ my $nextopix = $op->nextop->objix;
+ my $lastopix = $op->lastop->objix;
+ $op->B::LISTOP::bytecode;
+ print "op_redoop $redoopix\nop_nextop $nextopix\nop_lastop $lastopix\n";
+}
+
+sub B::COP::bytecode {
+ my $op = shift;
+ my $stash = $op->stash;
+ my $stashix = $stash->objix;
+ my $filegv = $op->filegv;
+ my $filegvix = $filegv->objix;
+ my $line = $op->line;
+ if ($debug) {
+ printf "# line %s:%d\n", $filegv->SV->PV, $line;
+ }
+ $op->B::OP::bytecode;
+ printf <<"EOT", pvstring($op->label), $op->cop_seq, $op->arybase;
+newpv %s
+cop_label
+cop_stash $stashix
+cop_seq %d
+cop_filegv $filegvix
+cop_arybase %d
+cop_line $line
+EOT
+ $filegv->bytecode;
+ $stash->bytecode;
+}
+
+sub B::PMOP::bytecode {
+ my $op = shift;
+ my $short = $op->pmshort;
+ my $shortix = $short->objix;
+ my $replroot = $op->pmreplroot;
+ my $replrootix = $replroot->objix;
+ my $replstartix = $op->pmreplstart->objix;
+ my $ppaddr = $op->ppaddr;
+ # pmnext is corrupt in some PMOPs (see misc.t for example)
+ #my $pmnextix = $op->pmnext->objix;
+
+ $short->bytecode;
+ if (ad($replroot)) {
+ # OP_PUSHRE (a mutated version of OP_MATCH for the regexp
+ # argument to a split) stores a GV in op_pmreplroot instead
+ # of a substitution syntax tree. We don't want to walk that...
+ if ($ppaddr eq "pp_pushre") {
+ $replroot->bytecode;
+ } else {
+ walkoptree($replroot, "bytecode");
+ }
+ }
+ $op->B::LISTOP::bytecode;
+ if ($ppaddr eq "pp_pushre") {
+ printf "op_pmreplrootgv $replrootix\n";
+ } else {
+ print "op_pmreplroot $replrootix\nop_pmreplstart $replstartix\n";
+ }
+ my $re = pvstring($op->precomp);
+ # op_pmnext omitted since a perl bug means it's sometime corrupt
+ printf <<"EOT", $op->pmflags, $op->pmpermflags, $op->pmslen;
+op_pmshort $shortix
+op_pmflags 0x%x
+op_pmpermflags 0x%x
+op_pmslen %d
+newpv $re
+pregcomp
+EOT
+}
+
+sub B::SV::bytecode {
+ my $sv = shift;
+ return if saved($sv);
+ my $ix = $sv->objix;
+ my $refcnt = $sv->REFCNT;
+ my $flags = sprintf("0x%x", $sv->FLAGS);
+ ldsv($ix);
+ print "sv_refcnt $refcnt\nsv_flags $flags\n";
+ mark_saved($sv);
+}
+
+sub B::PV::bytecode {
+ my $sv = shift;
+ return if saved($sv);
+ $sv->B::SV::bytecode;
+ printf("newpv %s\nxpv\n", pvstring($sv->PV)) if $sv->FLAGS & POK;
+}
+
+sub B::IV::bytecode {
+ my $sv = shift;
+ return if saved($sv);
+ my $iv = $sv->IVX;
+ $sv->B::SV::bytecode;
+ printf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32";
+}
+
+sub B::NV::bytecode {
+ my $sv = shift;
+ return if saved($sv);
+ $sv->B::SV::bytecode;
+ printf "xnv %s\n", $sv->NVX;
+}
+
+sub B::RV::bytecode {
+ my $sv = shift;
+ return if saved($sv);
+ my $rvix = $sv->RV->objix;
+ $sv->B::SV::bytecode;
+ print "xrv $rvix\n";
+}
+
+sub B::PVIV::bytecode {
+ my $sv = shift;
+ return if saved($sv);
+ my $iv = $sv->IVX;
+ $sv->B::PV::bytecode;
+ printf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32";
+}
+
+sub B::PVNV::bytecode {
+ my ($sv, $flag) = @_;
+ # The $flag argument is passed through PVMG::bytecode by BM::bytecode
+ # and AV::bytecode and indicates special handling. $flag = 1 is used by
+ # BM::bytecode and means that we should ensure we save the whole B-M
+ # table. It consists of 257 bytes (256 char array plus a final \0)
+ # which follow the ordinary PV+\0 and the 257 bytes are *not* reflected
+ # in SvCUR. $flag = 2 is used by AV::bytecode and means that we only
+ # call SV::bytecode instead of saving PV and calling NV::bytecode since
+ # PV/NV/IV stuff is different for AVs.
+ return if saved($sv);
+ if ($flag == 2) {
+ $sv->B::SV::bytecode;
+ } else {
+ my $pv = $sv->PV;
+ $sv->B::IV::bytecode;
+ printf "xnv %s\n", $sv->NVX;
+ if ($flag == 1) {
+ $pv .= "\0" . $sv->TABLE;
+ printf "newpv %s\npv_cur %d\nxpv\n", pvstring($pv),length($pv)-257;
+ } else {
+ printf("newpv %s\nxpv\n", pvstring($pv)) if $sv->FLAGS & POK;
+ }
+ }
+}
+
+sub B::PVMG::bytecode {
+ my ($sv, $flag) = @_;
+ # See B::PVNV::bytecode for an explanation of $flag.
+ return if saved($sv);
+ # XXX We assume SvSTASH is already saved and don't save it later ourselves
+ my $stashix = $sv->SvSTASH->objix;
+ my @mgchain = $sv->MAGIC;
+ my (@mgobjix, $mg);
+ #
+ # We need to traverse the magic chain and get objix for each OBJ
+ # field *before* we do B::PVNV::bytecode since objix overwrites
+ # the sv register. However, we need to write the magic-saving
+ # bytecode *after* B::PVNV::bytecode since sv isn't initialised
+ # to refer to $sv until then.
+ #
+ @mgobjix = map($_->OBJ->objix, @mgchain);
+ $sv->B::PVNV::bytecode($flag);
+ print "xmg_stash $stashix\n";
+ foreach $mg (@mgchain) {
+ printf "sv_magic %s\nmg_obj %d\nnewpv %s\nmg_pv\n",
+ cstring($mg->TYPE), shift(@mgobjix), pvstring($mg->PTR);
+ }
+}
+
+sub B::PVLV::bytecode {
+ my $sv = shift;
+ return if saved($sv);
+ $sv->B::PVMG::bytecode;
+ printf <<'EOT', $sv->TARGOFF, $sv->TARGLEN, cstring($sv->TYPE);
+xlv_targoff %d
+xlv_targlen %d
+xlv_type %s
+EOT
+}
+
+sub B::BM::bytecode {
+ my $sv = shift;
+ return if saved($sv);
+ # See PVNV::bytecode for an explanation of what the argument does
+ $sv->B::PVMG::bytecode(1);
+ printf "xbm_useful %d\nxbm_previous %d\nxbm_rare %d\n",
+ $sv->USEFUL, $sv->PREVIOUS, $sv->RARE;
+}
+
+sub B::GV::bytecode {
+ my $gv = shift;
+ return if saved($gv);
+ my $ix = $gv->objix;
+ mark_saved($gv);
+ my $gvname = $gv->NAME;
+ my $name = cstring($gv->STASH->NAME . "::" . $gvname);
+ my $egv = $gv->EGV;
+ my $egvix = $egv->objix;
+ ldsv($ix);
+ printf <<"EOT", $gv->FLAGS, $gv->GvFLAGS, $gv->LINE;
+sv_flags 0x%x
+xgv_flags 0x%x
+gp_line %d
+EOT
+ my $refcnt = $gv->REFCNT;
+ printf("sv_refcnt_add %d\n", $refcnt - 1) if $refcnt > 1;
+ my $gvrefcnt = $gv->GvREFCNT;
+ printf("gp_refcnt_add %d\n", $gvrefcnt - 1) if $gvrefcnt > 1;
+ if ($gvrefcnt > 1 && $ix != $egvix) {
+ print "gp_share $egvix\n";
+ } else {
+ if ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) {
+ my $i;
+ my @subfield_names = qw(SV AV HV CV FILEGV FORM IO);
+ my @subfields = map($gv->$_(), @subfield_names);
+ my @ixes = map($_->objix, @subfields);
+ # Reset sv register for $gv
+ ldsv($ix);
+ for ($i = 0; $i < @ixes; $i++) {
+ printf "gp_%s %d\n", lc($subfield_names[$i]), $ixes[$i];
+ }
+ # Now save all the subfields
+ my $sv;
+ foreach $sv (@subfields) {
+ $sv->bytecode;
+ }
+ }
+ }
+}
+
+sub B::HV::bytecode {
+ my $hv = shift;
+ return if saved($hv);
+ mark_saved($hv);
+ my $name = $hv->NAME;
+ my $ix = $hv->objix;
+ if (!$name) {
+ # It's an ordinary HV. Stashes have NAME set and need no further
+ # saving beyond the gv_stashpv that $hv->objix already ensures.
+ #
+ # XXX We don't yet save the contents of non-empty HVs
+ ldsv($ix);
+ printf "sv_refcnt %d\nsv_flags 0x%x\n", $hv->REFCNT, $hv->FLAGS;
+ }
+}
+
+sub B::AV::bytecode {
+ my $av = shift;
+ return if saved($av);
+ my $ix = $av->objix;
+ my $fill = $av->FILL;
+ my $max = $av->MAX;
+ my (@array, @ixes);
+ if ($fill > -1) {
+ @array = $av->ARRAY;
+ @ixes = map($_->objix, @array);
+ my $sv;
+ foreach $sv (@array) {
+ $sv->bytecode;
+ }
+ }
+ # See PVNV::bytecode for the meaning of the flag argument of 2.
+ $av->B::PVMG::bytecode(2);
+ # Recover sv register and set AvMAX and AvFILL to -1 (since we
+ # create an AV with NEWSV and SvUPGRADE rather than doing newAV
+ # which is what sets AvMAX and AvFILL.
+ ldsv($ix);
+ printf "xav_flags 0x%x\nxav_max -1\nxav_fill -1\n", $av->AvFLAGS;
+ if ($fill > -1) {
+ my $elix;
+ foreach $elix (@ixes) {
+ print "av_push $elix\n";
+ }
+ } else {
+ if ($max > -1) {
+ print "av_extend $max\n";
+ }
+ }
+}
+
+sub B::CV::bytecode {
+ my $cv = shift;
+ return if saved($cv);
+ my $ix = $cv->objix;
+ $cv->B::PVMG::bytecode;
+ my $i;
+ my @subfield_names = qw(ROOT START STASH GV FILEGV PADLIST OUTSIDE);
+ my @subfields = map($cv->$_(), @subfield_names);
+ my @ixes = map($_->objix, @subfields);
+ # Save OP tree from CvROOT (first element of @subfields)
+ my $root = shift @subfields;
+ if (ad($root)) {
+ walkoptree($root, "bytecode");
+ }
+ # Reset sv register for $cv (since above ->objix calls stomped on it)
+ ldsv($ix);
+ for ($i = 0; $i < @ixes; $i++) {
+ printf "xcv_%s %d\n", lc($subfield_names[$i]), $ixes[$i];
+ }
+ printf "xcv_depth %d\nxcv_flags 0x%x\n", $cv->DEPTH, $cv->FLAGS;
+ # Now save all the subfields (except for CvROOT which was handled
+ # above) and CvSTART (now the initial element of @subfields).
+ shift @subfields; # bye-bye CvSTART
+ my $sv;
+ foreach $sv (@subfields) {
+ $sv->bytecode;
+ }
+}
+
+sub B::IO::bytecode {
+ my $io = shift;
+ return if saved($io);
+ my $ix = $io->objix;
+ my $top_gv = $io->TOP_GV;
+ my $top_gvix = $top_gv->objix;
+ my $fmt_gv = $io->FMT_GV;
+ my $fmt_gvix = $fmt_gv->objix;
+ my $bottom_gv = $io->BOTTOM_GV;
+ my $bottom_gvix = $bottom_gv->objix;
+
+ $io->B::PVMG::bytecode;
+ ldsv($ix);
+ print "xio_top_gv $top_gvix\n";
+ print "xio_fmt_gv $fmt_gvix\n";
+ print "xio_bottom_gv $bottom_gvix\n";
+ my $field;
+ foreach $field (qw(TOP_NAME FMT_NAME BOTTOM_NAME)) {
+ printf "newpv %s\nxio_%s\n", pvstring($io->$field()), lc($field);
+ }
+ foreach $field (qw(LINES PAGE PAGE_LEN LINES_LEFT SUBPROCESS)) {
+ printf "xio_%s %d\n", lc($field), $io->$field();
+ }
+ printf "xio_type %s\nxio_flags 0x%x\n", cstring($io->IoTYPE), $io->IoFLAGS;
+ $top_gv->bytecode;
+ $fmt_gv->bytecode;
+ $bottom_gv->bytecode;
+}
+
+sub B::SPECIAL::bytecode {
+ # nothing extra needs doing
+}
+
+sub bytecompile_object {
+ my $sv;
+ foreach $sv (@_) {
+ svref_2object($sv)->bytecode;
+ }
+}
+
+sub B::GV::bytecodecv {
+ my $gv = shift;
+ my $cv = $gv->CV;
+ if (ad($cv) && !saved($cv)) {
+ if ($debug_cv) {
+ warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n",
+ $gv->STASH->NAME, $gv->NAME, ad($cv), ad($gv));
+ }
+ $gv->bytecode;
+ }
+}
+
+sub bytecompile_main {
+ my $curpad = (comppadlist->ARRAY)[1];
+ my $curpadix = $curpad->objix;
+ $curpad->bytecode;
+ walkoptree(main_root, "bytecode");
+ my ($pack, %exclude);
+ foreach $pack (qw(B O AutoLoader DynaLoader Config DB VMS
+ strict vars FileHandle Exporter Carp)) {
+ $exclude{$pack."::"} = 1;
+ }
+ no strict qw(vars refs);
+ walksymtable(\%{"main::"}, "bytecodecv",sub { !defined($exclude{$_[0]}) });
+ if (!$module_only) {
+ printf "main_root %d\n", main_root->objix;
+ printf "main_start %d\n", main_start->objix;
+ printf "curpad $curpadix\n";
+ # XXX Do min_intro_pending and max_intro_pending matter?
+ }
+}
+
+sub prepare_output {
+ # Plumbing for output
+ if (!$no_assemble) {
+ pipe(READER, WRITER) or die "pipe: $!\n";
+ $assembler_pid = fork();
+ die "fork: $!\n" unless defined($assembler_pid);
+ if ($assembler_pid) {
+ # parent
+ close WRITER;
+ assemble_fh(\*READER, sub { print @_ });
+ exit(0);
+ } else {
+ # child
+ close READER;
+ open(STDOUT, ">&WRITER") or die "dup: $!\n";
+ }
+ }
+}
+
+sub compile {
+ my @options = @_;
+ my ($option, $opt, $arg);
+ OPTION:
+ while ($option = shift @options) {
+ if ($option =~ /^-(.)(.*)/) {
+ $opt = $1;
+ $arg = $2;
+ } else {
+ unshift @options, $option;
+ last OPTION;
+ }
+ if ($opt eq "-" && $arg eq "-") {
+ shift @options;
+ last OPTION;
+ } elsif ($opt eq "o") {
+ $arg ||= shift @options;
+ open(STDOUT, ">$arg") or return "$arg: $!\n";
+ } elsif ($opt eq "D") {
+ $arg ||= shift @options;
+ foreach $arg (split(//, $arg)) {
+ if ($arg eq "o") {
+ B->debug(1);
+ } elsif ($arg eq "a") {
+ B::Assembler::debug(1);
+ } elsif ($arg eq "D") {
+ $debug_cv = 1;
+ }
+ }
+ } elsif ($opt eq "v") {
+ $verbose = 1;
+ } elsif ($opt eq "m") {
+ $module_only = 1;
+ } elsif ($opt eq "S") {
+ $no_assemble = 1;
+ } elsif ($opt eq "f") {
+ $arg ||= shift @options;
+ my $value = $arg !~ s/^no-//;
+ $arg =~ s/-/_/g;
+ my $ref = $optimise{$arg};
+ if (defined($ref)) {
+ $$ref = $value;
+ } else {
+ warn qq(ignoring unknown optimisation option "$arg"\n);
+ }
+ } elsif ($opt eq "O") {
+ $arg = 1 if $arg eq "";
+ my $ref;
+ foreach $ref (values %optimise) {
+ $$ref = 0;
+ }
+ if ($arg >= 6) {
+ $strip_syntree = 1;
+ }
+ if ($arg >= 2) {
+ $bypass_nullops = 1;
+ }
+ if ($arg >= 1) {
+ $compress_nullops = 1;
+ $omit_seq = 1;
+ }
+ }
+ }
+ if (@options) {
+ return sub {
+ my $objname;
+ prepare_output();
+ foreach $objname (@options) {
+ eval "bytecompile_object(\\$objname)";
+ }
+ waitpid($assembler_pid, 0) if defined($assembler_pid);
+ }
+ } else {
+ return sub {
+ prepare_output();
+ bytecompile_main();
+ waitpid($assembler_pid, 0) if defined($assembler_pid);
+ }
+ }
+}
+
+1;
--- /dev/null
+# C.pm
+#
+# Copyright (c) 1996 Malcolm Beattie
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the README file.
+#
+package B::C;
+use Exporter ();
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(push_decl init_init push_init output_all output_boilerplate
+ output_main set_callback save_unused_subs objsym);
+
+use B qw(minus_c sv_undef walkoptree walksymtable main_root main_start
+ ad peekop class cstring cchar svref_2object compile_stats
+ comppadlist hash);
+use B::Asmdata qw(@specialsv_name);
+
+use FileHandle;
+use Carp;
+use strict;
+
+my $hv_index = 0;
+my $gv_index = 0;
+my $re_index = 0;
+my $pv_index = 0;
+my $anonsub_index = 0;
+my (@binop_list, @condop_list, @cop_list, @cvop_list, @decl_list,
+ @gvop_list, @listop_list, @logop_list, @loop_list, @op_list, @pmop_list,
+ @pvop_list, @sv_list, @svop_list, @unop_list, @xpv_list,
+ @xpvav_list, @xpvhv_list, @xpvcv_list, @xpviv_list, @xpvnv_list,
+ @xpvmg_list, @xpvlv_list, @xrv_list, @xpvbm_list, @xpvio_list);
+
+my $init_list_fh;
+my %symtable;
+my $warn_undefined_syms;
+my $verbose;
+my @unused_sub_packages;
+my $nullop_count;
+my $pv_copy_on_grow;
+my ($debug_cops, $debug_av, $debug_cv, $debug_mg);
+
+sub walk_and_save_optree;
+my $saveoptree_callback = \&walk_and_save_optree;
+sub set_callback { $saveoptree_callback = shift }
+sub saveoptree { &$saveoptree_callback(@_) }
+
+sub walk_and_save_optree {
+ my ($name, $root, $start) = @_;
+ walkoptree($root, "save");
+ return objsym($start);
+}
+
+sub push_decl {
+ push(@decl_list, @_);
+}
+
+sub init_init {
+ $init_list_fh->close if defined $init_list_fh;
+ $init_list_fh = FileHandle->new_tmpfile;
+ return $init_list_fh ? 1 : 0;
+}
+
+sub push_init {
+ map { print $init_list_fh $_, "\n" } @_;
+}
+
+# Current workaround/fix for op_free() trying to free statically
+# defined OPs is to set op_seq = -1 and check for that in op_free().
+# Instead of hardwiring -1 in place of $op->seq, we use $op_seq
+# so that it can be changed back easily if necessary. In fact, to
+# stop compilers from moaning about a U16 being initialised with an
+# uncast -1 (the printf format is %d so we can't tweak it), we have
+# to "know" that op_seq is a U16 and use 65535. Ugh.
+my $op_seq = 65535;
+
+sub AVf_REAL () { 1 }
+
+sub savesym {
+ my ($obj, $value) = @_;
+# warn(sprintf("savesym: sym_%x => %s\n", ad($obj), $value)); # debug
+ $symtable{sprintf("sym_%x", ad($obj))} = $value;
+}
+
+sub objsym {
+ my $obj = shift;
+ return $symtable{sprintf("sym_%x", ad($obj))};
+}
+
+sub getsym {
+ my $sym = shift;
+ my $value;
+
+ return 0 if $sym eq "sym_0"; # special case
+ $value = $symtable{$sym};
+ if (defined($value)) {
+ return $value;
+ } else {
+ warn "warning: undefined symbol $sym\n" if $warn_undefined_syms;
+ return "UNUSED";
+ }
+}
+
+sub fixsyms {
+ $_[0] =~ s/(sym_[0-9a-f]+)/getsym($1)/ge;
+}
+
+sub savepv {
+ my $pv = shift;
+ my $pvsym = 0;
+ my $pvmax = 0;
+ if ($pv_copy_on_grow) {
+ my $cstring = cstring($pv);
+ if ($cstring ne "0") { # sic
+ $pvsym = sprintf("pv%d", $pv_index++);
+ push(@decl_list,sprintf("static char %s[] = %s;",$pvsym,$cstring));
+ }
+ } else {
+ $pvmax = length($pv) + 1;
+ }
+ return ($pvsym, $pvmax);
+}
+
+sub B::OP::save {
+ my ($op, $level) = @_;
+ my $type = $op->type;
+ $nullop_count++ unless $type;
+ push(@op_list,
+ sprintf("sym_%x, sym_%x, %s, %u, %u, %u, 0x%x, 0x%x",
+ ad($op->next), ad($op->sibling), $op->ppaddr, $op->targ,
+ $type, $op_seq, $op->flags, $op->private));
+ savesym($op, "&op_list[$#op_list]");
+}
+
+sub B::FAKEOP::new {
+ my ($class, %objdata) = @_;
+ bless \%objdata, $class;
+}
+
+sub B::FAKEOP::save {
+ my ($op, $level) = @_;
+ push(@op_list,
+ sprintf("%s, %s, %s, %u, %u, %u, 0x%x, 0x%x",
+ $op->next, $op->sibling, $op->ppaddr, $op->targ,
+ $op->type, $op_seq, $op->flags, $op->private));
+ return "&op_list[$#op_list]";
+}
+
+sub B::FAKEOP::next { $_[0]->{"next"} || 0 }
+sub B::FAKEOP::type { $_[0]->{type} || 0}
+sub B::FAKEOP::sibling { $_[0]->{sibling} || 0 }
+sub B::FAKEOP::ppaddr { $_[0]->{ppaddr} || 0 }
+sub B::FAKEOP::targ { $_[0]->{targ} || 0 }
+sub B::FAKEOP::flags { $_[0]->{flags} || 0 }
+sub B::FAKEOP::private { $_[0]->{private} || 0 }
+
+sub B::UNOP::save {
+ my ($op, $level) = @_;
+ push(@unop_list,
+ sprintf("sym_%x, sym_%x, %s, %u, %u, %u, 0x%x, 0x%x, sym_%x",
+ ad($op->next), ad($op->sibling), $op->ppaddr, $op->targ,
+ $op->type, $op_seq, $op->flags,$op->private,ad($op->first)));
+ savesym($op, "(OP*)&unop_list[$#unop_list]");
+}
+
+sub B::BINOP::save {
+ my ($op, $level) = @_;
+ push(@binop_list,
+ sprintf("sym_%x, sym_%x, %s, %u, %u, %u, 0x%x, 0x%x, sym_%x, sym_%x",
+ ad($op->next), ad($op->sibling), $op->ppaddr, $op->targ,
+ $op->type, $op_seq, $op->flags, $op->private,
+ ad($op->first), ad($op->last)));
+ savesym($op, "(OP*)&binop_list[$#binop_list]");
+}
+
+sub B::LISTOP::save {
+ my ($op, $level) = @_;
+ push(@listop_list, sprintf(
+ "sym_%x, sym_%x, %s, %u, %u, %u, 0x%x, 0x%x, sym_%x, sym_%x, %u",
+ ad($op->next), ad($op->sibling), $op->ppaddr, $op->targ,
+ $op->type, $op_seq, $op->flags, $op->private, ad($op->first),
+ ad($op->last), $op->children));
+ savesym($op, "(OP*)&listop_list[$#listop_list]");
+}
+
+sub B::LOGOP::save {
+ my ($op, $level) = @_;
+ push(@logop_list,
+ sprintf("sym_%x, sym_%x, %s, %u, %u, %u, 0x%x, 0x%x, sym_%x, sym_%x",
+ ad($op->next), ad($op->sibling), $op->ppaddr, $op->targ,
+ $op->type, $op_seq, $op->flags, $op->private,
+ ad($op->first), ad($op->other)));
+ savesym($op, "(OP*)&logop_list[$#logop_list]");
+}
+
+sub B::CONDOP::save {
+ my ($op, $level) = @_;
+ push(@condop_list, sprintf(
+ "sym_%x, sym_%x, %s, %u, %u, %u, 0x%x, 0x%x, sym_%x, sym_%x, sym_%x",
+ ad($op->next), ad($op->sibling), $op->ppaddr, $op->targ,
+ $op->type, $op_seq, $op->flags, $op->private, ad($op->first),
+ ad($op->true), ad($op->false)));
+ savesym($op, "(OP*)&condop_list[$#condop_list]");
+}
+
+sub B::LOOP::save {
+ my ($op, $level) = @_;
+ #warn sprintf("LOOP: redoop %s, nextop %s, lastop %s\n",
+ # peekop($op->redoop), peekop($op->nextop),
+ # peekop($op->lastop)); # debug
+ push(@loop_list, sprintf(
+ "sym_%x, sym_%x, %s, %u, %u, %u, 0x%x, 0x%x, "
+ ."sym_%x, sym_%x, %u, sym_%x, sym_%x, sym_%x",
+ ad($op->next), ad($op->sibling), $op->ppaddr, $op->targ, $op->type,
+ $op_seq, $op->flags, $op->private, ad($op->first), ad($op->last),
+ $op->children, ad($op->redoop), ad($op->nextop), ad($op->lastop)));
+ savesym($op, "(OP*)&loop_list[$#loop_list]");
+}
+
+sub B::PVOP::save {
+ my ($op, $level) = @_;
+ push(@pvop_list,
+ sprintf("sym_%x, sym_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s",
+ ad($op->next), ad($op->sibling), $op->ppaddr, $op->targ,
+ $op->type, $op_seq, $op->flags, $op->private,
+ cstring($op->pv)));
+ savesym($op, "(OP*)&pvop_list[$#pvop_list]");
+}
+
+sub B::SVOP::save {
+ my ($op, $level) = @_;
+ push(@svop_list,
+ sprintf("sym_%x, sym_%x, %s, %u, %u, %u, 0x%x, 0x%x, (SV*)sym_%x",
+ ad($op->next), ad($op->sibling), $op->ppaddr, $op->targ,
+ $op->type, $op_seq, $op->flags, $op->private, ad($op->sv)));
+ savesym($op, "(OP*)&svop_list[$#svop_list]");
+# warn sprintf("svop saving sv %s 0x%x\n", ref($op->sv), ad($op->sv));#debug
+ $op->sv->save;
+}
+
+sub B::GVOP::save {
+ my ($op, $level) = @_;
+ my $gvsym = $op->gv->save;
+ push(@gvop_list,
+ sprintf("sym_%x, sym_%x, %s, %u, %u, %u, 0x%x, 0x%x, Nullgv",
+ ad($op->next), ad($op->sibling), $op->ppaddr, $op->targ,
+ $op->type, $op_seq, $op->flags, $op->private));
+ push_init(sprintf("gvop_list[$#gvop_list].op_gv = %s;", $gvsym));
+ savesym($op, "(OP*)&gvop_list[$#gvop_list]");
+}
+
+sub B::COP::save {
+ my ($op, $level) = @_;
+ my $gvsym = $op->filegv->save;
+ my $stashsym = $op->stash->save;
+ warn sprintf("COP: line %d file %s\n", $op->line, $op->filegv->SV->PV)
+ if $debug_cops;
+ push(@cop_list,
+ sprintf("sym_%x, sym_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s, "
+ ."Nullhv, Nullgv, %u, %d, %u",
+ ad($op->next), ad($op->sibling), $op->ppaddr, $op->targ,
+ $op->type, $op_seq, $op->flags, $op->private,
+ cstring($op->label), $op->cop_seq, $op->arybase, $op->line));
+ push_init(sprintf("cop_list[$#cop_list].cop_filegv = %s;", $gvsym),
+ sprintf("cop_list[$#cop_list].cop_stash = %s;", $stashsym));
+ savesym($op, "(OP*)&cop_list[$#cop_list]");
+}
+
+sub B::PMOP::save {
+ my ($op, $level) = @_;
+ my $shortsym = $op->pmshort->save;
+ my $replroot = $op->pmreplroot;
+ my $replstart = $op->pmreplstart;
+ my $replrootfield = sprintf("sym_%x", ad($replroot));
+ my $replstartfield = sprintf("sym_%x", ad($replstart));
+ my $gvsym;
+ my $ppaddr = $op->ppaddr;
+ if (ad($replroot)) {
+ # OP_PUSHRE (a mutated version of OP_MATCH for the regexp
+ # argument to a split) stores a GV in op_pmreplroot instead
+ # of a substitution syntax tree. We don't want to walk that...
+ if ($ppaddr eq "pp_pushre") {
+ $gvsym = $replroot->save;
+# warn "PMOP::save saving a pp_pushre with GV $gvsym\n"; # debug
+ $replrootfield = 0;
+ } else {
+ $replstartfield = saveoptree("*ignore*", $replroot, $replstart);
+ }
+ }
+ # pmnext handling is broken in perl itself, I think. Bad op_pmnext
+ # fields aren't noticed in perl's runtime (unless you try reset) but we
+ # segfault when trying to dereference it to find op->op_pmnext->op_type
+ push(@pmop_list,
+ sprintf("sym_%x, sym_%x, %s, %u, %u, %u, 0x%x, 0x%x, sym_%x, sym_%x,"
+ ." %u, %s, %s, 0, 0, %s, 0x%x, 0x%x, %u",
+ ad($op->next), ad($op->sibling), $ppaddr, $op->targ,
+ $op->type, $op_seq, $op->flags, $op->private,
+ ad($op->first), ad($op->last), $op->children,
+ $replrootfield, $replstartfield,
+ $shortsym, $op->pmflags, $op->pmpermflags, $op->pmslen));
+ my $pm = "pmop_list[$#pmop_list]";
+ my $re = $op->precomp;
+ if (defined($re)) {
+ my $resym = sprintf("re%d", $re_index++);
+ push(@decl_list, sprintf("static char *$resym = %s;", cstring($re)));
+ push_init(sprintf(
+ "$pm.op_pmregexp = pregcomp($resym, $resym + %u, &$pm);",
+ length($re)));
+ }
+ if ($gvsym) {
+ push_init("$pm.op_pmreplroot = (OP*)$gvsym;");
+ }
+ savesym($op, "(OP*)&pmop_list[$#pmop_list]");
+}
+
+sub B::SPECIAL::save {
+ my ($sv) = @_;
+ # special case: $$sv is not the address but an index into specialsv_list
+# warn "SPECIAL::save specialsv $$sv\n"; # debug
+ my $sym = $specialsv_name[$$sv];
+ if (!defined($sym)) {
+ confess "unknown specialsv index $$sv passed to B::SPECIAL::save";
+ }
+ return $sym;
+}
+
+sub B::OBJECT::save {}
+
+sub B::NULL::save {
+ my ($sv) = @_;
+ my $sym = objsym($sv);
+ return $sym if defined $sym;
+# warn "Saving SVt_NULL SV\n"; # debug
+ # debug
+ #if ($$sv == 0) {
+ # warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n";
+ #}
+ push(@sv_list, sprintf("0, %u, 0x%x", $sv->REFCNT + 1, $sv->FLAGS));
+ return savesym($sv, "&sv_list[$#sv_list]");
+}
+
+sub B::IV::save {
+ my ($sv) = @_;
+ my $sym = objsym($sv);
+ return $sym if defined $sym;
+ push(@xpviv_list, sprintf("0, 0, 0, %d", $sv->IVX));
+ push(@sv_list, sprintf("&xpviv_list[$#xpviv_list], %lu, 0x%x",
+ $sv->REFCNT + 1, $sv->FLAGS));
+ return savesym($sv, "&sv_list[$#sv_list]");
+}
+
+sub B::NV::save {
+ my ($sv) = @_;
+ my $sym = objsym($sv);
+ return $sym if defined $sym;
+ push(@xpvnv_list, sprintf("0, 0, 0, %d, %s", $sv->IVX, $sv->NVX));
+ push(@sv_list, sprintf("&xpvnv_list[$#xpvnv_list], %lu, 0x%x",
+ $sv->REFCNT + 1, $sv->FLAGS));
+ return savesym($sv, "&sv_list[$#sv_list]");
+}
+
+sub B::PVLV::save {
+ my ($sv) = @_;
+ my $sym = objsym($sv);
+ return $sym if defined $sym;
+ my $pv = $sv->PV;
+ my $len = length($pv);
+ my ($pvsym, $pvmax) = savepv($pv);
+ my ($lvtarg, $lvtarg_sym);
+ push(@xpvlv_list, sprintf("%s, %u, %u, %d, %g, 0, 0, %u, %u, 0, %s",
+ $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX,
+ $sv->TARGOFF, $sv->TARGLEN, cchar($sv->TYPE)));
+
+ push(@sv_list, sprintf("&xpvlv_list[$#xpvlv_list], %lu, 0x%x",
+ $sv->REFCNT + 1, $sv->FLAGS));
+ if (!$pv_copy_on_grow) {
+ push_init(sprintf("xpvlv_list[$#xpvlv_list].xpv_pv = savepvn(%s, %u);",
+ cstring($pv), $len));
+ }
+ $sv->save_magic;
+ return savesym($sv, "&sv_list[$#sv_list]");
+}
+
+sub B::PVIV::save {
+ my ($sv) = @_;
+ my $sym = objsym($sv);
+ return $sym if defined $sym;
+ my $pv = $sv->PV;
+ my $len = length($pv);
+ my ($pvsym, $pvmax) = savepv($pv);
+ push(@xpviv_list, sprintf("%s, %u, %u, %d", $pvsym, $len,$pvmax,$sv->IVX));
+ push(@sv_list, sprintf("&xpviv_list[$#xpviv_list], %u, 0x%x",
+ $sv->REFCNT + 1, $sv->FLAGS));
+ if (!$pv_copy_on_grow) {
+ push_init(sprintf("xpviv_list[$#xpviv_list].xpv_pv = savepvn(%s, %u);",
+ cstring($pv), $len));
+ }
+ return savesym($sv, "&sv_list[$#sv_list]");
+}
+
+sub B::PVNV::save {
+ my ($sv) = @_;
+ my $sym = objsym($sv);
+ return $sym if defined $sym;
+ my $pv = $sv->PV;
+ my $len = length($pv);
+ my ($pvsym, $pvmax) = savepv($pv);
+ push(@xpvnv_list, sprintf("%s, %u, %u, %d, %s",
+ $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX));
+ push(@sv_list, sprintf("&xpvnv_list[$#xpvnv_list], %lu, 0x%x",
+ $sv->REFCNT + 1, $sv->FLAGS));
+ if (!$pv_copy_on_grow) {
+ push_init(sprintf("xpvnv_list[$#xpvnv_list].xpv_pv = savepvn(%s, %u);",
+ cstring($pv), $len));
+ }
+ return savesym($sv, "&sv_list[$#sv_list]");
+}
+
+sub B::BM::save {
+ my ($sv) = @_;
+ my $sym = objsym($sv);
+ return $sym if defined $sym;
+ my $pv = $sv->PV . "\0" . $sv->TABLE;
+ my $len = length($pv);
+ push(@xpvbm_list, sprintf("0, %u, %u, %d, %s, 0, 0, %d, %u, 0x%x",
+ $len, $len + 258, $sv->IVX, $sv->NVX,
+ $sv->USEFUL, $sv->PREVIOUS, $sv->RARE));
+ push(@sv_list, sprintf("&xpvbm_list[$#xpvbm_list], %lu, 0x%x",
+ $sv->REFCNT + 1, $sv->FLAGS));
+ $sv->save_magic;
+ push_init(sprintf("xpvbm_list[$#xpvbm_list].xpv_pv = savepvn(%s, %u);",
+ cstring($pv), $len),
+ sprintf("xpvbm_list[$#xpvbm_list].xpv_cur = %u;", $len - 257));
+# "sv_magic(&sv_list[$#sv_list], Nullsv, 'B', Nullch, 0);");
+ return savesym($sv, "&sv_list[$#sv_list]");
+}
+
+sub B::PV::save {
+ my ($sv) = @_;
+ my $sym = objsym($sv);
+ return $sym if defined $sym;
+ my $pv = $sv->PV;
+ my $len = length($pv);
+ my ($pvsym, $pvmax) = savepv($pv);
+ push(@xpv_list, sprintf("%s, %u, %u", $pvsym, $len, $pvmax));
+ push(@sv_list, sprintf("&xpv_list[$#xpv_list], %lu, 0x%x",
+ $sv->REFCNT + 1, $sv->FLAGS));
+ if (!$pv_copy_on_grow) {
+ push_init(sprintf("xpv_list[$#xpv_list].xpv_pv = savepvn(%s, %u);",
+ cstring($pv), $len));
+ }
+ return savesym($sv, "&sv_list[$#sv_list]");
+}
+
+sub B::PVMG::save {
+ my ($sv) = @_;
+ my $sym = objsym($sv);
+ return $sym if defined $sym;
+ my $pv = $sv->PV;
+ my $len = length($pv);
+ my ($pvsym, $pvmax) = savepv($pv);
+ push(@xpvmg_list, sprintf("%s, %u, %u, %d, %s, 0, 0",
+ $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX));
+ push(@sv_list, sprintf("&xpvmg_list[$#xpvmg_list], %lu, 0x%x",
+ $sv->REFCNT + 1, $sv->FLAGS));
+ if (!$pv_copy_on_grow) {
+ push_init(sprintf("xpvmg_list[$#xpvmg_list].xpv_pv = savepvn(%s, %u);",
+ cstring($pv), $len));
+ }
+ $sym = savesym($sv, "&sv_list[$#sv_list]");
+ $sv->save_magic;
+ return $sym;
+}
+
+sub B::PVMG::save_magic {
+ my ($sv) = @_;
+ #warn sprintf("saving magic for %s (0x%x)\n", class($sv), ad($sv)); # debug
+ my $stash = $sv->SvSTASH;
+ if (ad($stash)) {
+ warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, ad($stash))
+ if $debug_mg;
+ # XXX Hope stash is already going to be saved.
+ push_init(sprintf("SvSTASH(sym_%x) = sym_%x;", ad($sv), ad($stash)));
+ }
+ my @mgchain = $sv->MAGIC;
+ my ($mg, $type, $obj, $ptr);
+ foreach $mg (@mgchain) {
+ $type = $mg->TYPE;
+ $obj = $mg->OBJ;
+ $ptr = $mg->PTR;
+ my $len = defined($ptr) ? length($ptr) : 0;
+ if ($debug_mg) {
+ warn sprintf("magic %s (0x%x), obj %s (0x%x), type %s, ptr %s\n",
+ class($sv), ad($sv), class($obj), ad($obj),
+ cchar($type), cstring($ptr));
+ }
+ push_init(sprintf("sv_magic((SV*)sym_%x, (SV*)sym_%x, %s, %s, %d);",
+ ad($sv), ad($obj), cchar($type),cstring($ptr),$len));
+ }
+}
+
+sub B::RV::save {
+ my ($sv) = @_;
+ my $sym = objsym($sv);
+ return $sym if defined $sym;
+ push(@xrv_list, $sv->RV->save);
+ push(@sv_list, sprintf("&xrv_list[$#xrv_list], %lu, 0x%x",
+ $sv->REFCNT + 1, $sv->FLAGS));
+ return savesym($sv, "&sv_list[$#sv_list]");
+}
+
+sub B::CV::save {
+ my ($cv) = @_;
+ my $sym = objsym($cv);
+ if (defined($sym)) {
+# warn sprintf("CV 0x%x already saved as $sym\n", ad($cv)); # debug
+ return $sym;
+ }
+ # Reserve a place on sv_list and xpvcv_list and record indices
+ push(@sv_list, undef);
+ my $sv_ix = $#sv_list;
+ push(@xpvcv_list, undef);
+ my $xpvcv_ix = $#xpvcv_list;
+ # Save symbol now so that GvCV() doesn't recurse back to us via CvGV()
+ $sym = savesym($cv, "&sv_list[$sv_ix]");
+ warn sprintf("saving CV 0x%x as $sym\n", ad($cv)) if $debug_cv;
+ my $gv = $cv->GV;
+ my $root = $cv->ROOT;
+ my $startfield = 0;
+ my $padlist = $cv->PADLIST;
+ if (ad($root)) {
+ warn sprintf("saving op tree for CV 0x%x, root = 0x%x\n",
+ ad($cv), ad($root)) if $debug_cv;
+ my $ppname;
+ if (ad($gv)) {
+ my $stashname = $gv->STASH->NAME;
+ my $gvname = $gv->NAME;
+ $ppname = "pp_sub_";
+ $ppname .= $stashname eq "main" ? $gvname : "$stashname\::$gvname";
+ $ppname =~ s/::/__/g;
+ } else {
+ $ppname = "pp_anonsub_$anonsub_index";
+ $anonsub_index++;
+ }
+ $startfield = saveoptree($ppname, $root, $cv->START, $padlist->ARRAY);
+ warn sprintf("done saving op tree for CV 0x%x, name %s, root 0x%x\n",
+ ad($cv), $ppname, ad($root)) if $debug_cv;
+ }
+ if (ad($padlist)) {
+ warn sprintf("saving PADLIST 0x%x for CV 0x%x\n",
+ ad($padlist), ad($cv)) if $debug_cv;
+ $padlist->save;
+ warn sprintf("done saving PADLIST 0x%x for CV 0x%x\n",
+ ad($padlist), ad($cv)) if $debug_cv;
+ }
+ my $pv = $cv->PV;
+ my $xsub = 0;
+ my $xsubany = "Nullany";
+ if ($cv->XSUB) {
+ $xsubany = sprintf("ANYINIT((void*)0x%x)", $cv->XSUBANY);
+ # Find out canonical name of XSUB function from EGV (I hope)
+ my $egv = $gv->EGV;
+ my $stashname = $egv->STASH->NAME;
+ $stashname =~ s/::/__/g;
+ $xsub = sprintf("XS_%s_%s", $stashname, $egv->NAME);
+ push(@decl_list, "void $xsub _((CV*));");
+ }
+ $xpvcv_list[$xpvcv_ix] = sprintf(
+ "%s, %u, 0, %d, %s, 0, Nullhv, Nullhv, %s, sym_%lx, $xsub, $xsubany,".
+ " Nullgv, Nullgv, %d, sym_%lx, (CV*)sym_%lx, 0",
+ cstring($pv), length($pv), $cv->IVX, $cv->NVX, $startfield,
+ ad($cv->ROOT), $cv->DEPTH, ad($padlist), ad($cv->OUTSIDE));
+ if (ad($gv)) {
+ $gv->save;
+ push_init(sprintf("CvGV(sym_%lx) = sym_%lx;",ad($cv),ad($gv)));
+ warn sprintf("done saving GV 0x%x for CV 0x%x\n",
+ ad($gv), ad($cv)) if $debug_cv;
+ }
+ my $filegv = $cv->FILEGV;
+ if (ad($filegv)) {
+ $filegv->save;
+ push_init(sprintf("CvFILEGV(sym_%lx) = sym_%lx;",ad($cv),ad($filegv)));
+ warn sprintf("done saving FILEGV 0x%x for CV 0x%x\n",
+ ad($filegv), ad($cv)) if $debug_cv;
+ }
+ my $stash = $cv->STASH;
+ if (ad($stash)) {
+ $stash->save;
+ push_init(sprintf("CvSTASH(sym_%lx) = sym_%lx;", ad($cv), ad($stash)));
+ warn sprintf("done saving STASH 0x%x for CV 0x%x\n",
+ ad($stash), ad($cv)) if $debug_cv;
+ }
+ $sv_list[$sv_ix] = sprintf("(XPVCV*)&xpvcv_list[%u], %lu, 0x%x",
+ $xpvcv_ix, $cv->REFCNT + 1, $cv->FLAGS);
+ return $sym;
+}
+
+sub B::GV::save {
+ my ($gv) = @_;
+ my $sym = objsym($gv);
+ if (defined($sym)) {
+ #warn sprintf("GV 0x%x already saved as $sym\n", ad($gv)); # debug
+ return $sym;
+ } else {
+ my $ix = $gv_index++;
+ $sym = savesym($gv, "gv_list[$ix]");
+ #warn sprintf("Saving GV 0x%x as $sym\n", ad($gv)); # debug
+ }
+ my $gvname = $gv->NAME;
+ my $name = cstring($gv->STASH->NAME . "::" . $gvname);
+ #warn "GV name is $name\n"; # debug
+ my $egv = $gv->EGV;
+ my $egvsym;
+ if (ad($gv) != ad($egv)) {
+ #warn(sprintf("EGV name is %s, saving it now\n",
+ # $egv->STASH->NAME . "::" . $egv->NAME)); # debug
+ $egvsym = $egv->save;
+ }
+ push_init(qq[$sym = gv_fetchpv($name, TRUE, SVt_PV);],
+ sprintf("SvFLAGS($sym) = 0x%x;", $gv->FLAGS),
+ sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS),
+ sprintf("GvLINE($sym) = %u;", $gv->LINE));
+ # Shouldn't need to do save_magic since gv_fetchpv handles that
+ #$gv->save_magic;
+ my $refcnt = $gv->REFCNT + 1;
+ push_init(sprintf("SvREFCNT($sym) += %u;", $refcnt - 1)) if $refcnt > 1;
+ my $gvrefcnt = $gv->GvREFCNT;
+ if ($gvrefcnt > 1) {
+ push_init(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1));
+ }
+ if (defined($egvsym)) {
+ # Shared glob *foo = *bar
+ push_init("gp_free($sym);",
+ "GvGP($sym) = GvGP($egvsym);");
+ } elsif ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) {
+ # Don't save subfields of special GVs (*_, *1, *# and so on)
+# warn "GV::save saving subfields\n"; # debug
+ my $gvsv = $gv->SV;
+ if (ad($gvsv)) {
+ push_init(sprintf("GvSV($sym) = sym_%x;", ad($gvsv)));
+# warn "GV::save \$$name\n"; # debug
+ $gvsv->save;
+ }
+ my $gvav = $gv->AV;
+ if (ad($gvav)) {
+ push_init(sprintf("GvAV($sym) = sym_%x;", ad($gvav)));
+# warn "GV::save \@$name\n"; # debug
+ $gvav->save;
+ }
+ my $gvhv = $gv->HV;
+ if (ad($gvhv)) {
+ push_init(sprintf("GvHV($sym) = sym_%x;", ad($gvhv)));
+# warn "GV::save \%$name\n"; # debug
+ $gvhv->save;
+ }
+ my $gvcv = $gv->CV;
+ if (ad($gvcv)) {
+ push_init(sprintf("GvCV($sym) = (CV*)sym_%x;", ad($gvcv)));
+# warn "GV::save &$name\n"; # debug
+ $gvcv->save;
+ }
+ my $gvfilegv = $gv->FILEGV;
+ if (ad($gvfilegv)) {
+ push_init(sprintf("GvFILEGV($sym) = sym_%x;",ad($gvfilegv)));
+# warn "GV::save GvFILEGV(*$name)\n"; # debug
+ $gvfilegv->save;
+ }
+ my $gvform = $gv->FORM;
+ if (ad($gvform)) {
+ push_init(sprintf("GvFORM($sym) = (CV*)sym_%x;", ad($gvform)));
+# warn "GV::save GvFORM(*$name)\n"; # debug
+ $gvform->save;
+ }
+ my $gvio = $gv->IO;
+ if (ad($gvio)) {
+ push_init(sprintf("GvIOp($sym) = sym_%x;", ad($gvio)));
+# warn "GV::save GvIO(*$name)\n"; # debug
+ $gvio->save;
+ }
+ }
+ return $sym;
+}
+sub B::AV::save {
+ my ($av) = @_;
+ my $sym = objsym($av);
+ return $sym if defined $sym;
+ my $avflags = $av->AvFLAGS;
+ push(@xpvav_list,
+ sprintf("0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0, 0x%x", $avflags));
+ push(@sv_list, sprintf("&xpvav_list[$#xpvav_list], %lu, 0x%x",
+ $av->REFCNT + 1, $av->FLAGS));
+ my $sv_list_index = $#sv_list;
+ my $fill = $av->FILL;
+ $av->save_magic;
+ warn sprintf("saving AV 0x%x FILL=$fill AvFLAGS=0x%x", ad($av), $avflags)
+ if $debug_av;
+ # XXX AVf_REAL is wrong test: need to save comppadlist but not stack
+ #if ($fill > -1 && ($avflags & AVf_REAL)) {
+ if ($fill > -1) {
+ my @array = $av->ARRAY;
+ if ($debug_av) {
+ my $el;
+ my $i = 0;
+ foreach $el (@array) {
+ warn sprintf("AV 0x%x[%d] = %s 0x%x\n",
+ ad($av), $i++, class($el), ad($el));
+ }
+ }
+ my @names = map($_->save, @array);
+ # XXX Better ways to write loop?
+ # Perhaps svp[0] = ...; svp[1] = ...; svp[2] = ...;
+ # Perhaps I32 i = 0; svp[i++] = ...; svp[i++] = ...; svp[i++] = ...;
+ push_init("{",
+ "\tSV **svp;",
+ "\tAV *av = (AV*)&sv_list[$sv_list_index];",
+ "\tav_extend(av, $fill);",
+ "\tsvp = AvARRAY(av);",
+ map("\t*svp++ = (SV*)$_;", @names),
+ "\tAvFILL(av) = $fill;",
+ "}");
+ } else {
+ my $max = $av->MAX;
+ push_init("av_extend((AV*)&sv_list[$sv_list_index], $max);")
+ if $max > -1;
+ }
+ return savesym($av, "(AV*)&sv_list[$sv_list_index]");
+}
+
+sub B::HV::save {
+ my ($hv) = @_;
+ my $sym = objsym($hv);
+ return $sym if defined $sym;
+ my $name = $hv->NAME;
+ if ($name) {
+ # It's a stash
+
+ # A perl bug means HvPMROOT isn't altered when a PMOP is freed. Usually
+ # the only symptom is that sv_reset tries to reset the PMf_USED flag of
+ # a trashed op but we look at the trashed op_type and segfault.
+ #my $adpmroot = ad($hv->PMROOT);
+ my $adpmroot = 0;
+ push(@decl_list, "static HV *hv$hv_index;");
+ # XXX Beware of weird package names containing double-quotes, \n, ...?
+ push_init(qq[hv$hv_index = gv_stashpv("$name", TRUE);]);
+ if ($adpmroot) {
+ push_init(sprintf("HvPMROOT(hv$hv_index) = (PMOP*)sym_%x;",
+ $adpmroot));
+ }
+ $sym = savesym($hv, "hv$hv_index");
+ $hv_index++;
+ return $sym;
+ }
+ # It's just an ordinary HV
+ push(@xpvhv_list,
+ sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0",
+ $hv->MAX, $hv->RITER));
+ push(@sv_list, sprintf("&xpvhv_list[$#xpvhv_list], %lu, 0x%x",
+ $hv->REFCNT + 1, $hv->FLAGS));
+ my $sv_list_index = $#sv_list;
+ my @contents = $hv->ARRAY;
+ if (@contents) {
+ my $i;
+ for ($i = 1; $i < @contents; $i += 2) {
+ $contents[$i] = $contents[$i]->save;
+ }
+ push_init("{", "\tHV *hv = (HV*)&sv_list[$sv_list_index];");
+ while (@contents) {
+ my ($key, $value) = splice(@contents, 0, 2);
+ push_init(sprintf("\thv_store(hv, %s, %u, %s, %s);",
+ cstring($key),length($key), $value, hash($key)));
+ }
+ push_init("}");
+ }
+ return savesym($hv, "(HV*)&sv_list[$sv_list_index]");
+}
+
+sub B::IO::save {
+ my ($io) = @_;
+ my $sym = objsym($io);
+ return $sym if defined $sym;
+ my $pv = $io->PV;
+ my $len = length($pv);
+ push(@xpvio_list,
+ sprintf("0, %u, %u, %d, %s, 0, 0, 0, 0, 0, %d, %d, %d, %d, %s, "
+ ."Nullgv, %s, Nullgv, %s, Nullgv, %d, %s, 0x%x",
+ $len, $len+1, $io->IVX, $io->NVX,
+ $io->LINES, $io->PAGE, $io->PAGE_LEN, $io->LINES_LEFT,
+ cstring($io->TOP_NAME), cstring($io->FMT_NAME),
+ cstring($io->BOTTOM_NAME), $io->SUBPROCESS,
+ cchar($io->IoTYPE), $io->IoFLAGS));
+ push(@sv_list, sprintf("&xpvio_list[$#xpvio_list], %lu, 0x%x",
+ $io->REFCNT + 1, $io->FLAGS));
+ $sym = savesym($io, "(IO*)&sv_list[$#sv_list]");
+ my ($field, $fsym);
+ foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) {
+ $fsym = $io->$field();
+ if (ad($fsym)) {
+ push_init(sprintf("Io$field($sym) = (GV*)sym_%x;", ad($fsym)));
+ $fsym->save;
+ }
+ }
+ $io->save_magic;
+ return $sym;
+}
+
+sub B::SV::save {
+ my $sv = shift;
+ # This is where we catch an honest-to-goodness Nullsv (which gets
+ # blessed into B::SV explicitly) and any stray erroneous SVs.
+ return 0 unless ad($sv);
+ confess sprintf("cannot save that type of SV: %s (0x%x)\n",
+ class($sv), ad($sv));
+}
+
+sub output_all {
+ my $init_name = shift;
+
+ output_declarations();
+ print "$_\n" while $_ = shift @decl_list;
+ print "\n";
+ output_list("op", \@op_list) if @op_list;
+ output_list("unop", \@unop_list) if @unop_list;
+ output_list("binop", \@binop_list) if @binop_list;
+ output_list("logop", \@logop_list) if @logop_list;
+ output_list("condop", \@condop_list) if @condop_list;
+ output_list("listop", \@listop_list) if @listop_list;
+ output_list("pmop", \@pmop_list) if @pmop_list;
+ output_list("svop", \@svop_list) if @svop_list;
+ output_list("gvop", \@gvop_list) if @gvop_list;
+ output_list("pvop", \@pvop_list) if @pvop_list;
+ output_list("cvop", \@cvop_list) if @cvop_list;
+ output_list("loop", \@loop_list) if @loop_list;
+ output_list("cop", \@cop_list) if @cop_list;
+
+ output_list("sv", \@sv_list) if @sv_list;
+ output_list("xrv", \@xrv_list) if @xrv_list;
+ output_list("xpv", \@xpv_list) if @xpv_list;
+ output_list("xpviv", \@xpviv_list) if @xpviv_list;
+ output_list("xpvnv", \@xpvnv_list) if @xpvnv_list;
+ output_list("xpvmg", \@xpvmg_list) if @xpvmg_list;
+ output_list("xpvlv", \@xpvlv_list) if @xpvlv_list;
+ output_list("xpvbm", \@xpvbm_list) if @xpvbm_list;
+ output_list("xpvav", \@xpvav_list) if @xpvav_list;
+ output_list("xpvhv", \@xpvhv_list) if @xpvhv_list;
+ output_list("xpvio", \@xpvio_list) if @xpvio_list;
+ output_list("xpvcv", \@xpvcv_list) if @xpvcv_list;
+
+ output_init($init_name);
+ if ($verbose) {
+ warn compile_stats();
+ warn "NULLOP count: $nullop_count\n";
+ }
+}
+
+sub output_init {
+ my $name = shift;
+ print "static int $name()\n{\n";
+ seek($init_list_fh, 0, 0);
+ while (<$init_list_fh>) {
+ fixsyms($_);
+ print "\t", $_;
+ }
+ print "\treturn 0;\n}\n";
+}
+
+sub output_list {
+ my ($name, $listref) = @_;
+ # Support pre-Standard C compilers which can't cope with static
+ # initialisation of union members. Sheesh.
+ my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
+ printf "static %s %s_list[%u] = {\n", $typename, $name, scalar(@$listref);
+ while ($_ = shift @$listref) {
+ fixsyms($_);
+ print "\t{ $_ },\n";
+ }
+ print "};\n\n";
+}
+
+sub output_declarations {
+ print <<'EOT';
+#ifdef BROKEN_STATIC_REDECL
+#define Static extern
+#else
+#define Static static
+#endif /* BROKEN_STATIC_REDECL */
+
+#ifdef BROKEN_UNION_INIT
+/*
+ * Cribbed from cv.h with ANY (a union) replaced by void*.
+ * Some pre-Standard compilers can't cope with initialising unions. Ho hum.
+ */
+typedef struct {
+ char * xpv_pv; /* pointer to malloced string */
+ STRLEN xpv_cur; /* length of xp_pv as a C string */
+ STRLEN xpv_len; /* allocated size */
+ IV xof_off; /* integer value */
+ double xnv_nv; /* numeric value, if any */
+ MAGIC* xmg_magic; /* magic for scalar array */
+ HV* xmg_stash; /* class package */
+
+ HV * xcv_stash;
+ OP * xcv_start;
+ OP * xcv_root;
+ void (*xcv_xsub) _((CV*));
+ void * xcv_xsubany;
+ GV * xcv_gv;
+ GV * xcv_filegv;
+ long xcv_depth; /* >= 2 indicates recursive call */
+ AV * xcv_padlist;
+ CV * xcv_outside;
+ U8 xcv_flags;
+} XPVCV_or_similar;
+#define ANYINIT(i) i
+#else
+#define XPVCV_or_similar XPVCV
+#define ANYINIT(i) {i}
+#endif /* BROKEN_UNION_INIT */
+#define Nullany ANYINIT(0)
+
+#define UNUSED 0
+
+EOT
+ printf("Static OP op_list[%d];\n", scalar(@op_list)) if @op_list;
+ printf("Static UNOP unop_list[%d];\n", scalar(@unop_list)) if @unop_list;
+ printf("Static BINOP binop_list[%d];\n", scalar(@binop_list))
+ if @binop_list;
+ printf("Static LOGOP logop_list[%d];\n", scalar(@logop_list))
+ if @logop_list;
+ printf("Static CONDOP condop_list[%d];\n", scalar(@condop_list))
+ if @condop_list;
+ printf("Static LISTOP listop_list[%d];\n", scalar(@listop_list))
+ if @listop_list;
+ printf("Static PMOP pmop_list[%d];\n", scalar(@pmop_list)) if @pmop_list;
+ printf("Static SVOP svop_list[%d];\n", scalar(@svop_list)) if @svop_list;
+ printf("Static GVOP gvop_list[%d];\n", scalar(@gvop_list)) if @gvop_list;
+ printf("Static PVOP pvop_list[%d];\n", scalar(@pvop_list)) if @pvop_list;
+ printf("Static CVOP cvop_list[%d];\n", scalar(@cvop_list)) if @cvop_list;
+ printf("Static LOOP loop_list[%d];\n", scalar(@loop_list)) if @loop_list;
+ printf("Static COP cop_list[%d];\n", scalar(@cop_list)) if @cop_list;
+
+ printf("Static SV sv_list[%d];\n", scalar(@sv_list)) if @sv_list;
+ printf("Static XPV xpv_list[%d];\n", scalar(@xpv_list)) if @xpv_list;
+ printf("Static XRV xrv_list[%d];\n", scalar(@xrv_list)) if @xrv_list;
+ printf("Static XPVIV xpviv_list[%d];\n", scalar(@xpviv_list))
+ if @xpviv_list;
+ printf("Static XPVNV xpvnv_list[%d];\n", scalar(@xpvnv_list))
+ if @xpvnv_list;
+ printf("Static XPVMG xpvmg_list[%d];\n", scalar(@xpvmg_list))
+ if @xpvmg_list;
+ printf("Static XPVLV xpvlv_list[%d];\n", scalar(@xpvlv_list))
+ if @xpvlv_list;
+ printf("Static XPVBM xpvbm_list[%d];\n", scalar(@xpvbm_list))
+ if @xpvbm_list;
+ printf("Static XPVAV xpvav_list[%d];\n", scalar(@xpvav_list))
+ if @xpvav_list;
+ printf("Static XPVHV xpvhv_list[%d];\n", scalar(@xpvhv_list))
+ if @xpvhv_list;
+ printf("Static XPVCV_or_similar xpvcv_list[%d];\n", scalar(@xpvcv_list))
+ if @xpvcv_list;
+ printf("Static XPVIO xpvio_list[%d];\n", scalar(@xpvio_list))
+ if @xpvio_list;
+ print "static GV *gv_list[$gv_index];\n" if $gv_index;
+ print "\n";
+}
+
+
+sub output_boilerplate {
+ print <<'EOT';
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#include "EXTERN.h"
+#include "perl.h"
+
+#ifdef __cplusplus
+}
+# define EXTERN_C extern "C"
+#else
+# define EXTERN_C extern
+#endif
+
+/* Workaround for mapstart: the only op which needs a different ppaddr */
+#undef pp_mapstart
+#define pp_mapstart pp_grepstart
+
+static void xs_init _((void));
+static PerlInterpreter *my_perl;
+EOT
+}
+
+sub output_main {
+ print <<'EOT';
+int
+#ifndef CAN_PROTOTYPE
+main(argc, argv, env)
+int argc;
+char **argv;
+char **env;
+#else /* def(CAN_PROTOTYPE) */
+main(int argc, char **argv, char **env)
+#endif /* def(CAN_PROTOTYPE) */
+{
+ int exitstatus;
+ int i;
+ char **fakeargv;
+
+ PERL_SYS_INIT(&argc,&argv);
+
+#if PATCHLEVEL > 3 || (PATCHLEVEL == 3 && SUBVERSION >= 1)
+ perl_init_i18nl10n(1);
+#else
+ perl_init_i18nl14n(1);
+#endif
+
+ if (!do_undump) {
+ my_perl = perl_alloc();
+ if (!my_perl)
+ exit(1);
+ perl_construct( my_perl );
+ }
+
+ if (!cshlen)
+ cshlen = strlen(cshname);
+
+#ifdef ALLOW_PERL_OPTIONS
+#define EXTRA_OPTIONS 2
+#else
+#define EXTRA_OPTIONS 3
+#endif /* ALLOW_PERL_OPTIONS */
+ New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *);
+ fakeargv[0] = argv[0];
+ fakeargv[1] = "-e";
+ fakeargv[2] = "";
+#ifndef ALLOW_PERL_OPTIONS
+ fakeargv[3] = "--";
+#endif /* ALLOW_PERL_OPTIONS */
+ for (i = 1; i < argc; i++)
+ fakeargv[i + EXTRA_OPTIONS] = argv[i];
+ fakeargv[argc + EXTRA_OPTIONS] = 0;
+
+ exitstatus = perl_parse(my_perl, xs_init, argc + EXTRA_OPTIONS,
+ fakeargv, NULL);
+ if (exitstatus)
+ exit( exitstatus );
+
+ sv_setpv(GvSV(gv_fetchpv("0", TRUE, SVt_PV)), argv[0]);
+ main_cv = compcv;
+ compcv = 0;
+
+ exitstatus = perl_init();
+ if (exitstatus)
+ exit( exitstatus );
+
+ exitstatus = perl_run( my_perl );
+
+ perl_destruct( my_perl );
+ perl_free( my_perl );
+
+ exit( exitstatus );
+}
+
+static void
+xs_init()
+{
+}
+EOT
+}
+
+sub dump_symtable {
+ # For debugging
+ my ($sym, $val);
+ warn "----Symbol table:\n";
+ while (($sym, $val) = each %symtable) {
+ warn "$sym => $val\n";
+ }
+ warn "---End of symbol table\n";
+}
+
+sub save_object {
+ my $sv;
+ foreach $sv (@_) {
+ svref_2object($sv)->save;
+ }
+}
+
+sub B::GV::savecv {
+ my $gv = shift;
+ my $cv = $gv->CV;
+ my $name = $gv->NAME;
+ if (ad($cv) && !objsym($cv) && !($name eq "bootstrap" && $cv->XSUB)) {
+ if ($debug_cv) {
+ warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n",
+ $gv->STASH->NAME, $name, ad($cv), ad($gv));
+ }
+ $gv->save;
+ }
+}
+
+sub save_unused_subs {
+ my %search_pack;
+ map { $search_pack{"$_\::"} = 1 } @_;
+ no strict qw(vars refs);
+ walksymtable(\%{"main::"}, "savecv", sub { exists($search_pack{$_[0]}) });
+}
+
+sub save_main {
+ my $curpad_sym = (comppadlist->ARRAY)[1]->save;
+ walkoptree(main_root, "save");
+ if (@unused_sub_packages) {
+ warn "done main optree, walking symtable for extras\n" if $debug_cv;
+ save_unused_subs(@unused_sub_packages);
+ }
+ push_init(sprintf("main_root = sym_%x;", ad(main_root)),
+ sprintf("main_start = sym_%x;", ad(main_start)),
+ "curpad = AvARRAY($curpad_sym);");
+ output_boilerplate();
+ print "\n";
+ output_all("perl_init");
+ print "\n";
+ output_main();
+}
+
+sub compile {
+ my @options = @_;
+ my ($option, $opt, $arg);
+ OPTION:
+ while ($option = shift @options) {
+ if ($option =~ /^-(.)(.*)/) {
+ $opt = $1;
+ $arg = $2;
+ } else {
+ unshift @options, $option;
+ last OPTION;
+ }
+ if ($opt eq "-" && $arg eq "-") {
+ shift @options;
+ last OPTION;
+ }
+ if ($opt eq "w") {
+ $warn_undefined_syms = 1;
+ } elsif ($opt eq "D") {
+ $arg ||= shift @options;
+ foreach $arg (split(//, $arg)) {
+ if ($arg eq "o") {
+ B->debug(1);
+ } elsif ($arg eq "c") {
+ $debug_cops = 1;
+ } elsif ($arg eq "A") {
+ $debug_av = 1;
+ } elsif ($arg eq "C") {
+ $debug_cv = 1;
+ } elsif ($arg eq "M") {
+ $debug_mg = 1;
+ } else {
+ warn "ignoring unknown debug option: $arg\n";
+ }
+ }
+ } elsif ($opt eq "o") {
+ $arg ||= shift @options;
+ open(STDOUT, ">$arg") or return "$arg: $!\n";
+ } elsif ($opt eq "v") {
+ $verbose = 1;
+ } elsif ($opt eq "u") {
+ $arg ||= shift @options;
+ push(@unused_sub_packages, $arg);
+ } elsif ($opt eq "f") {
+ $arg ||= shift @options;
+ if ($arg eq "cog") {
+ $pv_copy_on_grow = 1;
+ } elsif ($arg eq "no-cog") {
+ $pv_copy_on_grow = 0;
+ }
+ } elsif ($opt eq "O") {
+ $arg = 1 if $arg eq "";
+ $pv_copy_on_grow = 0;
+ if ($arg >= 1) {
+ # Optimisations for -O1
+ $pv_copy_on_grow = 1;
+ }
+ }
+ }
+ init_init();
+ if (@options) {
+ return sub {
+ my $objname;
+ foreach $objname (@options) {
+ eval "save_object(\\$objname)";
+ }
+ output_all();
+ }
+ } else {
+ return sub { save_main() };
+ }
+}
+
+1;
--- /dev/null
+# CC.pm
+#
+# Copyright (c) 1996 Malcolm Beattie
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the README file.
+#
+package B::CC;
+use strict;
+use B qw(main_start main_root class comppadlist peekop svref_2object ad
+ timing_info);
+use B::C qw(push_decl init_init push_init save_unused_subs objsym
+ output_all output_boilerplate output_main);
+use B::Bblock qw(find_leaders);
+use B::Stackobj qw(:types :flags);
+
+# These should probably be elsewhere
+# Flags for $op->flags
+sub OPf_LIST () { 1 }
+sub OPf_KNOW () { 2 }
+sub OPf_MOD () { 32 }
+sub OPf_STACKED () { 64 }
+sub OPf_SPECIAL () { 128 }
+# op-specific flags for $op->private
+sub OPpASSIGN_BACKWARDS () { 64 }
+sub OPpLVAL_INTRO () { 128 }
+sub OPpDEREF_AV () { 32 }
+sub OPpDEREF_HV () { 64 }
+sub OPpFLIP_LINENUM () { 64 }
+sub G_ARRAY () { 1 }
+# cop.h
+sub CXt_NULL () { 0 }
+sub CXt_SUB () { 1 }
+sub CXt_EVAL () { 2 }
+sub CXt_LOOP () { 3 }
+sub CXt_SUBST () { 4 }
+sub CXt_BLOCK () { 5 }
+
+my %done; # hash keyed by $$op of leaders of basic blocks
+ # which have already been done.
+my $leaders; # ref to hash of basic block leaders. Keys are $$op
+ # addresses, values are the $op objects themselves.
+my @bblock_todo; # list of leaders of basic blocks that need visiting
+ # sometime.
+my @cc_todo; # list of tuples defining what PP code needs to be
+ # saved (e.g. CV, main or PMOP repl code). Each tuple
+ # is [$name, $root, $start, @padlist]. PMOP repl code
+ # tuples inherit padlist.
+my @stack; # shadows perl's stack when contents are known.
+ # Values are objects derived from class B::Stackobj
+my @pad; # Lexicals in current pad as Stackobj-derived objects
+my @padlist; # Copy of current padlist so PMOP repl code can find it
+my @cxstack; # Shadows the (compile-time) cxstack for next,last,redo
+my $jmpbuf_ix = 0; # Next free index for dynamically allocated jmpbufs
+my %constobj; # OP_CONST constants as Stackobj-derived objects
+ # keyed by ad($sv).
+my $need_freetmps = 0; # We may postpone FREETMPS to the end of each basic
+ # block or even to the end of each loop of blocks,
+ # depending on optimisation options.
+my $know_op = 0; # Set when C variable op already holds the right op
+ # (from an immediately preceding DOOP(ppname)).
+my $errors = 0; # Number of errors encountered
+my %skip_stack; # Hash of PP names which don't need write_back_stack
+my %skip_lexicals; # Hash of PP names which don't need write_back_lexicals
+my %skip_invalidate; # Hash of PP names which don't need invalidate_lexicals
+my %ignore_op; # Hash of ops which do nothing except returning op_next
+
+BEGIN {
+ foreach (qw(pp_scalar pp_regcmaybe pp_lineseq pp_scope pp_null)) {
+ $ignore_op{$_} = 1;
+ }
+}
+
+my @unused_sub_packages; # list of packages (given by -u options) to search
+ # explicitly and save every sub we find there, even
+ # if apparently unused (could be only referenced from
+ # an eval "" or from a $SIG{FOO} = "bar").
+
+my ($module_name);
+my ($debug_op, $debug_stack, $debug_cxstack, $debug_pad, $debug_runtime,
+ $debug_shadow, $debug_queue, $debug_lineno, $debug_timings);
+
+# Optimisation options. On the command line, use hyphens instead of
+# underscores for compatibility with gcc-style options. We use
+# underscores here because they are OK in (strict) barewords.
+my ($freetmps_each_bblock, $freetmps_each_loop, $omit_taint);
+my %optimise = (freetmps_each_bblock => \$freetmps_each_bblock,
+ freetmps_each_loop => \$freetmps_each_loop,
+ omit_taint => \$omit_taint);
+
+# Could rewrite push_runtime() and output_runtime() to use a
+# temporary file if memory is at a premium.
+my $ppname; # name of current fake PP function
+my $runtime_list_ref;
+my $declare_ref; # Hash ref keyed by C variable type of declarations.
+
+my @pp_list; # list of [$ppname, $runtime_list_ref, $declare_ref]
+ # tuples to be written out.
+
+sub init_hash { map { $_ => 1 } @_ }
+
+#
+# Initialise the hashes for the default PP functions where we can avoid
+# either write_back_stack, write_back_lexicals or invalidate_lexicals.
+#
+%skip_lexicals = init_hash qw(pp_enter pp_enterloop);
+%skip_invalidate = init_hash qw(pp_enter pp_enterloop);
+
+sub debug {
+ if ($debug_runtime) {
+ warn(@_);
+ } else {
+ runtime(map { chomp; "/* $_ */"} @_);
+ }
+}
+
+sub declare {
+ my ($type, $var) = @_;
+ push(@{$declare_ref->{$type}}, $var);
+}
+
+sub push_runtime {
+ push(@$runtime_list_ref, @_);
+ warn join("\n", @_) . "\n" if $debug_runtime;
+}
+
+sub save_runtime {
+ push(@pp_list, [$ppname, $runtime_list_ref, $declare_ref]);
+}
+
+sub output_runtime {
+ my $ppdata;
+ print qq(#include "cc_runtime.h"\n);
+ foreach $ppdata (@pp_list) {
+ my ($name, $runtime, $declare) = @$ppdata;
+ print "\nstatic\nPP($name)\n{\n";
+ my ($type, $varlist, $line);
+ while (($type, $varlist) = each %$declare) {
+ print "\t$type ", join(", ", @$varlist), ";\n";
+ }
+ foreach $line (@$runtime) {
+ print $line, "\n";
+ }
+ print "}\n";
+ }
+}
+
+sub runtime {
+ my $line;
+ foreach $line (@_) {
+ push_runtime("\t$line");
+ }
+}
+
+sub init_pp {
+ $ppname = shift;
+ $runtime_list_ref = [];
+ $declare_ref = {};
+ runtime("dSP;");
+ declare("I32", "oldsave");
+ declare("SV", "**svp");
+ map { declare("SV", "*$_") } qw(sv src dst left right);
+ declare("MAGIC", "*mg");
+ push_decl("static OP * $ppname _((ARGSproto));");
+ debug "init_pp: $ppname\n" if $debug_queue;
+}
+
+# Initialise runtime_callback function for Stackobj class
+BEGIN { B::Stackobj::set_callback(\&runtime) }
+
+# Initialise saveoptree_callback for B::C class
+sub cc_queue {
+ my ($name, $root, $start, @pl) = @_;
+ debug "cc_queue: name $name, root $root, start $start, padlist (@pl)\n"
+ if $debug_queue;
+ if ($name eq "*ignore*") {
+ $name = 0;
+ } else {
+ push(@cc_todo, [$name, $root, $start, (@pl ? @pl : @padlist)]);
+ }
+ my $fakeop = new B::FAKEOP ("next" => 0, sibling => 0, ppaddr => $name);
+ $start = $fakeop->save;
+ debug "cc_queue: name $name returns $start\n" if $debug_queue;
+ return $start;
+}
+BEGIN { B::C::set_callback(\&cc_queue) }
+
+sub valid_int { $_[0]->{flags} & VALID_INT }
+sub valid_double { $_[0]->{flags} & VALID_DOUBLE }
+sub valid_numeric { $_[0]->{flags} & (VALID_INT | VALID_DOUBLE) }
+sub valid_sv { $_[0]->{flags} & VALID_SV }
+
+sub top_int { @stack ? $stack[-1]->as_int : "TOPi" }
+sub top_double { @stack ? $stack[-1]->as_double : "TOPn" }
+sub top_numeric { @stack ? $stack[-1]->as_numeric : "TOPn" }
+sub top_sv { @stack ? $stack[-1]->as_sv : "TOPs" }
+sub top_bool { @stack ? $stack[-1]->as_numeric : "SvTRUE(TOPs)" }
+
+sub pop_int { @stack ? (pop @stack)->as_int : "POPi" }
+sub pop_double { @stack ? (pop @stack)->as_double : "POPn" }
+sub pop_numeric { @stack ? (pop @stack)->as_numeric : "POPn" }
+sub pop_sv { @stack ? (pop @stack)->as_sv : "POPs" }
+sub pop_bool {
+ if (@stack) {
+ return ((pop @stack)->as_numeric);
+ } else {
+ # Careful: POPs has an auto-decrement and SvTRUE evaluates
+ # its argument more than once.
+ runtime("sv = POPs;");
+ return "SvTRUE(sv)";
+ }
+}
+
+sub write_back_lexicals {
+ my $avoid = shift || 0;
+ debug "write_back_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
+ if $debug_shadow;
+ my $lex;
+ foreach $lex (@pad) {
+ next unless ref($lex);
+ $lex->write_back unless $lex->{flags} & $avoid;
+ }
+}
+
+sub write_back_stack {
+ my $obj;
+ return unless @stack;
+ runtime(sprintf("EXTEND(sp, %d);", scalar(@stack)));
+ foreach $obj (@stack) {
+ runtime(sprintf("PUSHs((SV*)%s);", $obj->as_sv));
+ }
+ @stack = ();
+}
+
+sub invalidate_lexicals {
+ my $avoid = shift || 0;
+ debug "invalidate_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
+ if $debug_shadow;
+ my $lex;
+ foreach $lex (@pad) {
+ next unless ref($lex);
+ $lex->invalidate unless $lex->{flags} & $avoid;
+ }
+}
+
+sub reload_lexicals {
+ my $lex;
+ foreach $lex (@pad) {
+ next unless ref($lex);
+ my $type = $lex->{type};
+ if ($type == T_INT) {
+ $lex->as_int;
+ } elsif ($type == T_DOUBLE) {
+ $lex->as_double;
+ } else {
+ $lex->as_sv;
+ }
+ }
+}
+
+{
+ package B::Pseudoreg;
+ #
+ # This class allocates pseudo-registers (OK, so they're C variables).
+ #
+ my %alloc; # Keyed by variable name. A value of 1 means the
+ # variable has been declared. A value of 2 means
+ # it's in use.
+
+ sub new_scope { %alloc = () }
+
+ sub new ($$$) {
+ my ($class, $type, $prefix) = @_;
+ my ($ptr, $i, $varname, $status, $obj);
+ $prefix =~ s/^(\**)//;
+ $ptr = $1;
+ $i = 0;
+ do {
+ $varname = "$prefix$i";
+ $status = $alloc{$varname};
+ } while $status == 2;
+ if ($status != 1) {
+ # Not declared yet
+ B::CC::declare($type, "$ptr$varname");
+ $alloc{$varname} = 2; # declared and in use
+ }
+ $obj = bless \$varname, $class;
+ return $obj;
+ }
+ sub DESTROY {
+ my $obj = shift;
+ $alloc{$$obj} = 1; # no longer in use but still declared
+ }
+}
+{
+ package B::Shadow;
+ #
+ # This class gives a standard API for a perl object to shadow a
+ # C variable and only generate reloads/write-backs when necessary.
+ #
+ # Use $obj->load($foo) instead of runtime("shadowed_c_var = foo").
+ # Use $obj->write_back whenever shadowed_c_var needs to be up to date.
+ # Use $obj->invalidate whenever an unknown function may have
+ # set shadow itself.
+
+ sub new {
+ my ($class, $write_back) = @_;
+ # Object fields are perl shadow variable, validity flag
+ # (for *C* variable) and callback sub for write_back
+ # (passed perl shadow variable as argument).
+ bless [undef, 1, $write_back], $class;
+ }
+ sub load {
+ my ($obj, $newval) = @_;
+ $obj->[1] = 0; # C variable no longer valid
+ $obj->[0] = $newval;
+ }
+ sub write_back {
+ my $obj = shift;
+ if (!($obj->[1])) {
+ $obj->[1] = 1; # C variable will now be valid
+ &{$obj->[2]}($obj->[0]);
+ }
+ }
+ sub invalidate { $_[0]->[1] = 0 } # force C variable to be invalid
+}
+my $curcop = new B::Shadow (sub {
+ my $opsym = shift->save;
+ runtime("curcop = (COP*)$opsym;");
+});
+
+#
+# Context stack shadowing. Mimics stuff in pp_ctl.c, cop.h and so on.
+#
+sub dopoptoloop {
+ my $cxix = $#cxstack;
+ while ($cxix >= 0 && $cxstack[$cxix]->{type} != CXt_LOOP) {
+ $cxix--;
+ }
+ debug "dopoptoloop: returning $cxix" if $debug_cxstack;
+ return $cxix;
+}
+
+sub dopoptolabel {
+ my $label = shift;
+ my $cxix = $#cxstack;
+ while ($cxix >= 0 && $cxstack[$cxix]->{type} != CXt_LOOP
+ && $cxstack[$cxix]->{label} ne $label) {
+ $cxix--;
+ }
+ debug "dopoptolabel: returning $cxix" if $debug_cxstack;
+ return $cxix;
+}
+
+sub error {
+ my $format = shift;
+ my $file = $curcop->[0]->filegv->SV->PV;
+ my $line = $curcop->[0]->line;
+ $errors++;
+ if (@_) {
+ warn sprintf("%s:%d: $format\n", $file, $line, @_);
+ } else {
+ warn sprintf("%s:%d: %s\n", $file, $line, $format);
+ }
+}
+
+#
+# Load pad takes (the elements of) a PADLIST as arguments and loads
+# up @pad with Stackobj-derived objects which represent those lexicals.
+# If/when perl itself can generate type information (my int $foo) then
+# we'll take advantage of that here. Until then, we'll use various hacks
+# to tell the compiler when we want a lexical to be a particular type
+# or to be a register.
+#
+sub load_pad {
+ my ($namelistav, $valuelistav) = @_;
+ @padlist = @_;
+ my @namelist = $namelistav->ARRAY;
+ my @valuelist = $valuelistav->ARRAY;
+ my $ix;
+ @pad = ();
+ debug "load_pad: $#namelist names, $#valuelist values\n" if $debug_pad;
+ # Temporary lexicals don't get named so it's possible for @valuelist
+ # to be strictly longer than @namelist. We count $ix up to the end of
+ # @valuelist but index into @namelist for the name. Any temporaries which
+ # run off the end of @namelist will make $namesv undefined and we treat
+ # that the same as having an explicit SPECIAL sv_undef object in @namelist.
+ # [XXX If/when @_ becomes a lexical, we must start at 0 here.]
+ for ($ix = 1; $ix < @valuelist; $ix++) {
+ my $namesv = $namelist[$ix];
+ my $type = T_UNKNOWN;
+ my $flags = 0;
+ my $name = "tmp$ix";
+ my $class = class($namesv);
+ if (!defined($namesv) || $class eq "SPECIAL") {
+ # temporaries have &sv_undef instead of a PVNV for a name
+ $flags = VALID_SV|TEMPORARY|REGISTER;
+ } else {
+ if ($namesv->PV =~ /^\$(.*)_([di])(r?)$/) {
+ $name = $1;
+ if ($2 eq "i") {
+ $type = T_INT;
+ $flags = VALID_SV|VALID_INT;
+ } elsif ($2 eq "d") {
+ $type = T_DOUBLE;
+ $flags = VALID_SV|VALID_DOUBLE;
+ }
+ $flags |= REGISTER if $3;
+ }
+ }
+ $pad[$ix] = new B::Stackobj::Padsv ($type, $flags, $ix,
+ "i_$name", "d_$name");
+ declare("IV", $type == T_INT ? "i_$name = 0" : "i_$name");
+ declare("double", $type == T_DOUBLE ? "d_$name = 0" : "d_$name");
+ debug sprintf("curpad[$ix] = %s\n", $pad[$ix]->peek) if $debug_pad;
+ }
+}
+
+#
+# Debugging stuff
+#
+sub peek_stack { sprintf "stack = %s\n", join(" ", map($_->minipeek, @stack)) }
+
+#
+# OP stuff
+#
+
+sub label {
+ my $op = shift;
+ # XXX Preserve original label name for "real" labels?
+ return sprintf("lab_%x", $$op);
+}
+
+sub write_label {
+ my $op = shift;
+ push_runtime(sprintf(" %s:", label($op)));
+}
+
+sub loadop {
+ my $op = shift;
+ my $opsym = $op->save;
+ runtime("op = $opsym;") unless $know_op;
+ return $opsym;
+}
+
+sub doop {
+ my $op = shift;
+ my $ppname = $op->ppaddr;
+ my $sym = loadop($op);
+ runtime("DOOP($ppname);");
+ $know_op = 1;
+ return $sym;
+}
+
+sub gimme {
+ my $op = shift;
+ my $flags = $op->flags;
+ return (($flags & OPf_KNOW) ? ($flags & OPf_LIST) : "dowantarray()");
+}
+
+#
+# Code generation for PP code
+#
+
+sub pp_null {
+ my $op = shift;
+ return $op->next;
+}
+
+sub pp_stub {
+ my $op = shift;
+ my $gimme = gimme($op);
+ if ($gimme != 1) {
+ # XXX Change to push a constant sv_undef Stackobj onto @stack
+ write_back_stack();
+ runtime("if ($gimme != G_ARRAY) XPUSHs(&sv_undef);");
+ }
+ return $op->next;
+}
+
+sub pp_unstack {
+ my $op = shift;
+ @stack = ();
+ runtime("PP_UNSTACK;");
+ return $op->next;
+}
+
+sub pp_and {
+ my $op = shift;
+ my $next = $op->next;
+ reload_lexicals();
+ unshift(@bblock_todo, $next);
+ if (@stack >= 1) {
+ my $bool = pop_bool();
+ write_back_stack();
+ runtime(sprintf("if (!$bool) goto %s;", label($next)));
+ } else {
+ runtime(sprintf("if (!%s) goto %s;", top_bool(), label($next)),
+ "*sp--;");
+ }
+ return $op->other;
+}
+
+sub pp_or {
+ my $op = shift;
+ my $next = $op->next;
+ reload_lexicals();
+ unshift(@bblock_todo, $next);
+ if (@stack >= 1) {
+ my $obj = pop @stack;
+ write_back_stack();
+ runtime(sprintf("if (%s) { XPUSHs(%s); goto %s; }",
+ $obj->as_numeric, $obj->as_sv, label($next)));
+ } else {
+ runtime(sprintf("if (%s) goto %s;", top_bool(), label($next)),
+ "*sp--;");
+ }
+ return $op->other;
+}
+
+sub pp_cond_expr {
+ my $op = shift;
+ my $false = $op->false;
+ unshift(@bblock_todo, $false);
+ reload_lexicals();
+ my $bool = pop_bool();
+ write_back_stack();
+ runtime(sprintf("if (!$bool) goto %s;", label($false)));
+ return $op->true;
+}
+
+
+sub pp_padsv {
+ my $op = shift;
+ my $ix = $op->targ;
+ push(@stack, $pad[$ix]);
+ if ($op->flags & OPf_MOD) {
+ my $private = $op->private;
+ if ($private & OPpLVAL_INTRO) {
+ runtime("SAVECLEARSV(curpad[$ix]);");
+ } elsif ($private & (OPpDEREF_HV|OPpDEREF_AV)) {
+ loadop($op);
+ runtime("provide_ref(op, curpad[$ix]);");
+ $pad[$ix]->invalidate;
+ }
+ }
+ return $op->next;
+}
+
+sub pp_const {
+ my $op = shift;
+ my $sv = $op->sv;
+ my $obj = $constobj{ad($sv)};
+ if (!defined($obj)) {
+ $obj = $constobj{ad($sv)} = new B::Stackobj::Const ($sv);
+ }
+ push(@stack, $obj);
+ return $op->next;
+}
+
+sub pp_nextstate {
+ my $op = shift;
+ $curcop->load($op);
+ @stack = ();
+ debug(sprintf("%s:%d\n", $op->filegv->SV->PV, $op->line)) if $debug_lineno;
+ runtime("TAINT_NOT;") unless $omit_taint;
+ runtime("sp = stack_base + cxstack[cxstack_ix].blk_oldsp;");
+ if ($freetmps_each_bblock || $freetmps_each_loop) {
+ $need_freetmps = 1;
+ } else {
+ runtime("FREETMPS;");
+ }
+ return $op->next;
+}
+
+sub pp_dbstate {
+ my $op = shift;
+ $curcop->invalidate; # XXX?
+ return default_pp($op);
+}
+
+sub pp_rv2gv { $curcop->write_back; default_pp(@_) }
+sub pp_bless { $curcop->write_back; default_pp(@_) }
+sub pp_repeat { $curcop->write_back; default_pp(@_) }
+# The following subs need $curcop->write_back if we decide to support arybase:
+# pp_pos, pp_substr, pp_index, pp_rindex, pp_aslice, pp_lslice, pp_splice
+sub pp_sort { $curcop->write_back; default_pp(@_) }
+sub pp_caller { $curcop->write_back; default_pp(@_) }
+sub pp_reset { $curcop->write_back; default_pp(@_) }
+
+sub pp_gv {
+ my $op = shift;
+ my $gvsym = $op->gv->save;
+ write_back_stack();
+ runtime("XPUSHs((SV*)$gvsym);");
+ return $op->next;
+}
+
+sub pp_gvsv {
+ my $op = shift;
+ my $gvsym = $op->gv->save;
+ write_back_stack();
+ if ($op->private & OPpLVAL_INTRO) {
+ runtime("XPUSHs(save_scalar($gvsym));");
+ } else {
+ runtime("XPUSHs(GvSV($gvsym));");
+ }
+ return $op->next;
+}
+
+sub pp_aelemfast {
+ my $op = shift;
+ my $gvsym = $op->gv->save;
+ my $ix = $op->private;
+ my $flag = $op->flags & OPf_MOD;
+ write_back_stack();
+ runtime("svp = av_fetch(GvAV($gvsym), $ix, $flag);",
+ "PUSHs(svp ? *svp : &sv_undef);");
+ return $op->next;
+}
+
+sub int_binop {
+ my ($op, $operator) = @_;
+ if ($op->flags & OPf_STACKED) {
+ my $right = pop_int();
+ if (@stack >= 1) {
+ my $left = top_int();
+ $stack[-1]->set_int(&$operator($left, $right));
+ } else {
+ runtime(sprintf("sv_setiv(TOPs, %s);",&$operator("TOPi", $right)));
+ }
+ } else {
+ my $targ = $pad[$op->targ];
+ my $right = new B::Pseudoreg ("IV", "riv");
+ my $left = new B::Pseudoreg ("IV", "liv");
+ runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int));
+ $targ->set_int(&$operator($$left, $$right));
+ push(@stack, $targ);
+ }
+ return $op->next;
+}
+
+sub INTS_CLOSED () { 0x1 }
+sub INT_RESULT () { 0x2 }
+sub NUMERIC_RESULT () { 0x4 }
+
+sub numeric_binop {
+ my ($op, $operator, $flags) = @_;
+ my $force_int = 0;
+ $force_int ||= ($flags & INT_RESULT);
+ $force_int ||= ($flags & INTS_CLOSED && @stack >= 2
+ && valid_int($stack[-2]) && valid_int($stack[-1]));
+ if ($op->flags & OPf_STACKED) {
+ my $right = pop_numeric();
+ if (@stack >= 1) {
+ my $left = top_numeric();
+ if ($force_int) {
+ $stack[-1]->set_int(&$operator($left, $right));
+ } else {
+ $stack[-1]->set_numeric(&$operator($left, $right));
+ }
+ } else {
+ if ($force_int) {
+ runtime(sprintf("sv_setiv(TOPs, %s);",
+ &$operator("TOPi", $right)));
+ } else {
+ runtime(sprintf("sv_setnv(TOPs, %s);",
+ &$operator("TOPn", $right)));
+ }
+ }
+ } else {
+ my $targ = $pad[$op->targ];
+ $force_int ||= ($targ->{type} == T_INT);
+ if ($force_int) {
+ my $right = new B::Pseudoreg ("IV", "riv");
+ my $left = new B::Pseudoreg ("IV", "liv");
+ runtime(sprintf("$$right = %s; $$left = %s;",
+ pop_numeric(), pop_numeric));
+ $targ->set_int(&$operator($$left, $$right));
+ } else {
+ my $right = new B::Pseudoreg ("double", "rnv");
+ my $left = new B::Pseudoreg ("double", "lnv");
+ runtime(sprintf("$$right = %s; $$left = %s;",
+ pop_numeric(), pop_numeric));
+ $targ->set_numeric(&$operator($$left, $$right));
+ }
+ push(@stack, $targ);
+ }
+ return $op->next;
+}
+
+sub sv_binop {
+ my ($op, $operator, $flags) = @_;
+ if ($op->flags & OPf_STACKED) {
+ my $right = pop_sv();
+ if (@stack >= 1) {
+ my $left = top_sv();
+ if ($flags & INT_RESULT) {
+ $stack[-1]->set_int(&$operator($left, $right));
+ } elsif ($flags & NUMERIC_RESULT) {
+ $stack[-1]->set_numeric(&$operator($left, $right));
+ } else {
+ # XXX Does this work?
+ runtime(sprintf("sv_setsv($left, %s);",
+ &$operator($left, $right)));
+ $stack[-1]->invalidate;
+ }
+ } else {
+ my $f;
+ if ($flags & INT_RESULT) {
+ $f = "sv_setiv";
+ } elsif ($flags & NUMERIC_RESULT) {
+ $f = "sv_setnv";
+ } else {
+ $f = "sv_setsv";
+ }
+ runtime(sprintf("%s(TOPs, %s);", $f, &$operator("TOPs", $right)));
+ }
+ } else {
+ my $targ = $pad[$op->targ];
+ runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv));
+ if ($flags & INT_RESULT) {
+ $targ->set_int(&$operator("left", "right"));
+ } elsif ($flags & NUMERIC_RESULT) {
+ $targ->set_numeric(&$operator("left", "right"));
+ } else {
+ # XXX Does this work?
+ runtime(sprintf("sv_setsv(%s, %s);",
+ $targ->as_sv, &$operator("left", "right")));
+ $targ->invalidate;
+ }
+ push(@stack, $targ);
+ }
+ return $op->next;
+}
+
+sub bool_int_binop {
+ my ($op, $operator) = @_;
+ my $right = new B::Pseudoreg ("IV", "riv");
+ my $left = new B::Pseudoreg ("IV", "liv");
+ runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int()));
+ my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
+ $bool->set_int(&$operator($$left, $$right));
+ push(@stack, $bool);
+ return $op->next;
+}
+
+sub bool_numeric_binop {
+ my ($op, $operator) = @_;
+ my $right = new B::Pseudoreg ("double", "rnv");
+ my $left = new B::Pseudoreg ("double", "lnv");
+ runtime(sprintf("$$right = %s; $$left = %s;",
+ pop_numeric(), pop_numeric()));
+ my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
+ $bool->set_numeric(&$operator($$left, $$right));
+ push(@stack, $bool);
+ return $op->next;
+}
+
+sub bool_sv_binop {
+ my ($op, $operator) = @_;
+ runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv()));
+ my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
+ $bool->set_numeric(&$operator("left", "right"));
+ push(@stack, $bool);
+ return $op->next;
+}
+
+sub infix_op {
+ my $opname = shift;
+ return sub { "$_[0] $opname $_[1]" }
+}
+
+sub prefix_op {
+ my $opname = shift;
+ return sub { sprintf("%s(%s)", $opname, join(", ", @_)) }
+}
+
+BEGIN {
+ my $plus_op = infix_op("+");
+ my $minus_op = infix_op("-");
+ my $multiply_op = infix_op("*");
+ my $divide_op = infix_op("/");
+ my $modulo_op = infix_op("%");
+ my $lshift_op = infix_op("<<");
+ my $rshift_op = infix_op("<<");
+ my $ncmp_op = sub { "($_[0] > $_[1] ? 1 : ($_[0] < $_[1]) ? -1 : 0)" };
+ my $scmp_op = prefix_op("sv_cmp");
+ my $seq_op = prefix_op("sv_eq");
+ my $sne_op = prefix_op("!sv_eq");
+ my $slt_op = sub { "sv_cmp($_[0], $_[1]) < 0" };
+ my $sgt_op = sub { "sv_cmp($_[0], $_[1]) > 0" };
+ my $sle_op = sub { "sv_cmp($_[0], $_[1]) <= 0" };
+ my $sge_op = sub { "sv_cmp($_[0], $_[1]) >= 0" };
+ my $eq_op = infix_op("==");
+ my $ne_op = infix_op("!=");
+ my $lt_op = infix_op("<");
+ my $gt_op = infix_op(">");
+ my $le_op = infix_op("<=");
+ my $ge_op = infix_op(">=");
+
+ #
+ # XXX The standard perl PP code has extra handling for
+ # some special case arguments of these operators.
+ #
+ sub pp_add { numeric_binop($_[0], $plus_op, INTS_CLOSED) }
+ sub pp_subtract { numeric_binop($_[0], $minus_op, INTS_CLOSED) }
+ sub pp_multiply { numeric_binop($_[0], $multiply_op, INTS_CLOSED) }
+ sub pp_divide { numeric_binop($_[0], $divide_op) }
+ sub pp_modulo { int_binop($_[0], $modulo_op) } # differs from perl's
+ sub pp_ncmp { numeric_binop($_[0], $ncmp_op, INT_RESULT) }
+
+ sub pp_left_shift { int_binop($_[0], $lshift_op) }
+ sub pp_right_shift { int_binop($_[0], $rshift_op) }
+ sub pp_i_add { int_binop($_[0], $plus_op) }
+ sub pp_i_subtract { int_binop($_[0], $minus_op) }
+ sub pp_i_multiply { int_binop($_[0], $multiply_op) }
+ sub pp_i_divide { int_binop($_[0], $divide_op) }
+ sub pp_i_modulo { int_binop($_[0], $modulo_op) }
+
+ sub pp_eq { bool_numeric_binop($_[0], $eq_op) }
+ sub pp_ne { bool_numeric_binop($_[0], $ne_op) }
+ sub pp_lt { bool_numeric_binop($_[0], $lt_op) }
+ sub pp_gt { bool_numeric_binop($_[0], $gt_op) }
+ sub pp_le { bool_numeric_binop($_[0], $le_op) }
+ sub pp_ge { bool_numeric_binop($_[0], $ge_op) }
+
+ sub pp_i_eq { bool_int_binop($_[0], $eq_op) }
+ sub pp_i_ne { bool_int_binop($_[0], $ne_op) }
+ sub pp_i_lt { bool_int_binop($_[0], $lt_op) }
+ sub pp_i_gt { bool_int_binop($_[0], $gt_op) }
+ sub pp_i_le { bool_int_binop($_[0], $le_op) }
+ sub pp_i_ge { bool_int_binop($_[0], $ge_op) }
+
+ sub pp_scmp { sv_binop($_[0], $scmp_op, INT_RESULT) }
+ sub pp_slt { bool_sv_binop($_[0], $slt_op) }
+ sub pp_sgt { bool_sv_binop($_[0], $sgt_op) }
+ sub pp_sle { bool_sv_binop($_[0], $sle_op) }
+ sub pp_sge { bool_sv_binop($_[0], $sge_op) }
+ sub pp_seq { bool_sv_binop($_[0], $seq_op) }
+ sub pp_sne { bool_sv_binop($_[0], $sne_op) }
+}
+
+
+sub pp_sassign {
+ my $op = shift;
+ my $backwards = $op->private & OPpASSIGN_BACKWARDS;
+ my ($dst, $src);
+ if (@stack >= 2) {
+ $dst = pop @stack;
+ $src = pop @stack;
+ ($src, $dst) = ($dst, $src) if $backwards;
+ my $type = $src->{type};
+ if ($type == T_INT) {
+ $dst->set_int($src->as_int);
+ } elsif ($type == T_DOUBLE) {
+ $dst->set_numeric($src->as_numeric);
+ } else {
+ $dst->set_sv($src->as_sv);
+ }
+ push(@stack, $dst);
+ } elsif (@stack == 1) {
+ if ($backwards) {
+ my $src = pop @stack;
+ my $type = $src->{type};
+ runtime("if (tainting && tainted) TAINT_NOT;");
+ if ($type == T_INT) {
+ runtime sprintf("sv_setiv(TOPs, %s);", $src->as_int);
+ } elsif ($type == T_DOUBLE) {
+ runtime sprintf("sv_setnv(TOPs, %s);", $src->as_double);
+ } else {
+ runtime sprintf("sv_setsv(TOPs, %s);", $src->as_sv);
+ }
+ runtime("SvSETMAGIC(TOPs);");
+ } else {
+ my $dst = pop @stack;
+ my $type = $dst->{type};
+ runtime("sv = POPs;");
+ runtime("MAYBE_TAINT_SASSIGN_SRC(sv);");
+ if ($type == T_INT) {
+ $dst->set_int("SvIV(sv)");
+ } elsif ($type == T_DOUBLE) {
+ $dst->set_double("SvNV(sv)");
+ } else {
+ runtime("SvSetSV($dst->{sv}, sv);");
+ $dst->invalidate;
+ }
+ }
+ } else {
+ if ($backwards) {
+ runtime("src = POPs; dst = TOPs;");
+ } else {
+ runtime("dst = POPs; src = TOPs;");
+ }
+ runtime("MAYBE_TAINT_SASSIGN_SRC(src);",
+ "SvSetSV(dst, src);",
+ "SvSETMAGIC(dst);",
+ "SETs(dst);");
+ }
+ return $op->next;
+}
+
+sub pp_preinc {
+ my $op = shift;
+ if (@stack >= 1) {
+ my $obj = $stack[-1];
+ my $type = $obj->{type};
+ if ($type == T_INT || $type == T_DOUBLE) {
+ $obj->set_int($obj->as_int . " + 1");
+ } else {
+ runtime sprintf("PP_PREINC(%s);", $obj->as_sv);
+ $obj->invalidate();
+ }
+ } else {
+ runtime sprintf("PP_PREINC(TOPs);");
+ }
+ return $op->next;
+}
+
+sub pp_pushmark {
+ my $op = shift;
+ write_back_stack();
+ runtime("PUSHMARK(sp);");
+ return $op->next;
+}
+
+sub pp_list {
+ my $op = shift;
+ write_back_stack();
+ my $gimme = gimme($op);
+ if ($gimme == 1) { # sic
+ runtime("POPMARK;"); # need this even though not a "full" pp_list
+ } else {
+ runtime("PP_LIST($gimme);");
+ }
+ return $op->next;
+}
+
+sub pp_entersub {
+ my $op = shift;
+ write_back_lexicals(REGISTER|TEMPORARY);
+ write_back_stack();
+ my $sym = doop($op);
+ runtime("if (op != ($sym)->op_next) op = (*op->op_ppaddr)();");
+ runtime("SPAGAIN;");
+ $know_op = 0;
+ invalidate_lexicals(REGISTER|TEMPORARY);
+ return $op->next;
+}
+
+sub doeval {
+ my $op = shift;
+ $curcop->write_back;
+ write_back_lexicals(REGISTER|TEMPORARY);
+ write_back_stack();
+ my $sym = loadop($op);
+ my $ppaddr = $op->ppaddr;
+ runtime("PP_EVAL($ppaddr, ($sym)->op_next);");
+ $know_op = 1;
+ invalidate_lexicals(REGISTER|TEMPORARY);
+ return $op->next;
+}
+
+sub pp_entereval { doeval(@_) }
+sub pp_require { doeval(@_) }
+sub pp_dofile { doeval(@_) }
+
+sub pp_entertry {
+ my $op = shift;
+ $curcop->write_back;
+ write_back_lexicals(REGISTER|TEMPORARY);
+ write_back_stack();
+ my $sym = doop($op);
+ my $jmpbuf = sprintf("jmpbuf%d", $jmpbuf_ix++);
+ declare("Sigjmp_buf", $jmpbuf);
+ runtime(sprintf("PP_ENTERTRY(%s,%s);", $jmpbuf, label($op->other->next)));
+ invalidate_lexicals(REGISTER|TEMPORARY);
+ return $op->next;
+}
+
+sub pp_grepstart {
+ my $op = shift;
+ if ($need_freetmps && $freetmps_each_loop) {
+ runtime("FREETMPS;"); # otherwise the grepwhile loop messes things up
+ $need_freetmps = 0;
+ }
+ write_back_stack();
+ doop($op);
+ return $op->next->other;
+}
+
+sub pp_mapstart {
+ my $op = shift;
+ if ($need_freetmps && $freetmps_each_loop) {
+ runtime("FREETMPS;"); # otherwise the mapwhile loop messes things up
+ $need_freetmps = 0;
+ }
+ write_back_stack();
+ doop($op);
+ return $op->next->other;
+}
+
+sub pp_grepwhile {
+ my $op = shift;
+ my $next = $op->next;
+ unshift(@bblock_todo, $next);
+ write_back_lexicals();
+ write_back_stack();
+ my $sym = doop($op);
+ # pp_grepwhile can return either op_next or op_other and we need to
+ # be able to distinguish the two at runtime. Since it's possible for
+ # both ops to be "inlined", the fields could both be zero. To get
+ # around that, we hack op_next to be our own op (purely because we
+ # know it's a non-NULL pointer and can't be the same as op_other).
+ push_init("((LOGOP*)$sym)->op_next = $sym;");
+ runtime(sprintf("if (op == ($sym)->op_next) goto %s;", label($next)));
+ $know_op = 0;
+ return $op->other;
+}
+
+sub pp_mapwhile {
+ pp_grepwhile(@_);
+}
+
+sub pp_return {
+ my $op = shift;
+ write_back_lexicals(REGISTER|TEMPORARY);
+ write_back_stack();
+ doop($op);
+ runtime("PUTBACK;", "return 0;");
+ $know_op = 0;
+ return $op->next;
+}
+
+sub nyi {
+ my $op = shift;
+ warn sprintf("%s not yet implemented properly\n", $op->ppaddr);
+ return default_pp($op);
+}
+
+sub pp_range {
+ my $op = shift;
+ my $flags = $op->flags;
+ if (!($flags & OPf_KNOW)) {
+ error("context of range unknown at compile-time");
+ }
+ write_back_lexicals();
+ write_back_stack();
+ if (!($flags & OPf_LIST)) {
+ # We need to save our UNOP structure since pp_flop uses
+ # it to find and adjust out targ. We don't need it ourselves.
+ $op->save;
+ runtime sprintf("if (SvTRUE(curpad[%d])) goto %s;",
+ $op->targ, label($op->false));
+ unshift(@bblock_todo, $op->false);
+ }
+ return $op->true;
+}
+
+sub pp_flip {
+ my $op = shift;
+ my $flags = $op->flags;
+ if (!($flags & OPf_KNOW)) {
+ error("context of flip unknown at compile-time");
+ }
+ if ($flags & OPf_LIST) {
+ return $op->first->false;
+ }
+ write_back_lexicals();
+ write_back_stack();
+ # We need to save our UNOP structure since pp_flop uses
+ # it to find and adjust out targ. We don't need it ourselves.
+ $op->save;
+ my $ix = $op->targ;
+ my $rangeix = $op->first->targ;
+ runtime(($op->private & OPpFLIP_LINENUM) ?
+ "if (last_in_gv && SvIV(TOPs) == IoLINES(GvIOp(last_in_gv))) {"
+ : "if (SvTRUE(TOPs)) {");
+ runtime("\tsv_setiv(curpad[$rangeix], 1);");
+ if ($op->flags & OPf_SPECIAL) {
+ runtime("sv_setiv(curpad[$ix], 1);");
+ } else {
+ runtime("\tsv_setiv(curpad[$ix], 0);",
+ "\tsp--;",
+ sprintf("\tgoto %s;", label($op->first->false)));
+ }
+ runtime("}",
+ qq{sv_setpv(curpad[$ix], "");},
+ "SETs(curpad[$ix]);");
+ $know_op = 0;
+ return $op->next;
+}
+
+sub pp_flop {
+ my $op = shift;
+ default_pp($op);
+ $know_op = 0;
+ return $op->next;
+}
+
+sub enterloop {
+ my $op = shift;
+ my $nextop = $op->nextop;
+ my $lastop = $op->lastop;
+ my $redoop = $op->redoop;
+ $curcop->write_back;
+ debug "enterloop: pushing on cxstack" if $debug_cxstack;
+ push(@cxstack, {
+ type => CXt_LOOP,
+ op => $op,
+ "label" => $curcop->[0]->label,
+ nextop => $nextop,
+ lastop => $lastop,
+ redoop => $redoop
+ });
+ $nextop->save;
+ $lastop->save;
+ $redoop->save;
+ return default_pp($op);
+}
+
+sub pp_enterloop { enterloop(@_) }
+sub pp_enteriter { enterloop(@_) }
+
+sub pp_leaveloop {
+ my $op = shift;
+ if (!@cxstack) {
+ die "panic: leaveloop";
+ }
+ debug "leaveloop: popping from cxstack" if $debug_cxstack;
+ pop(@cxstack);
+ return default_pp($op);
+}
+
+sub pp_next {
+ my $op = shift;
+ my $cxix;
+ if ($op->flags & OPf_SPECIAL) {
+ $cxix = dopoptoloop();
+ if ($cxix < 0) {
+ error('"next" used outside loop');
+ return $op->next; # ignore the op
+ }
+ } else {
+ $cxix = dopoptolabel($op->pv);
+ if ($cxix < 0) {
+ error('Label not found at compile time for "next %s"', $op->pv);
+ return $op->next; # ignore the op
+ }
+ }
+ default_pp($op);
+ my $nextop = $cxstack[$cxix]->{nextop};
+ push(@bblock_todo, $nextop);
+ runtime(sprintf("goto %s;", label($nextop)));
+ return $op->next;
+}
+
+sub pp_redo {
+ my $op = shift;
+ my $cxix;
+ if ($op->flags & OPf_SPECIAL) {
+ $cxix = dopoptoloop();
+ if ($cxix < 0) {
+ error('"redo" used outside loop');
+ return $op->next; # ignore the op
+ }
+ } else {
+ $cxix = dopoptolabel($op->pv);
+ if ($cxix < 0) {
+ error('Label not found at compile time for "redo %s"', $op->pv);
+ return $op->next; # ignore the op
+ }
+ }
+ default_pp($op);
+ my $redoop = $cxstack[$cxix]->{redoop};
+ push(@bblock_todo, $redoop);
+ runtime(sprintf("goto %s;", label($redoop)));
+ return $op->next;
+}
+
+sub pp_last {
+ my $op = shift;
+ my $cxix;
+ if ($op->flags & OPf_SPECIAL) {
+ $cxix = dopoptoloop();
+ if ($cxix < 0) {
+ error('"last" used outside loop');
+ return $op->next; # ignore the op
+ }
+ } else {
+ $cxix = dopoptolabel($op->pv);
+ if ($cxix < 0) {
+ error('Label not found at compile time for "last %s"', $op->pv);
+ return $op->next; # ignore the op
+ }
+ # XXX Add support for "last" to leave non-loop blocks
+ if ($cxstack[$cxix]->{type} != CXt_LOOP) {
+ error('Use of "last" for non-loop blocks is not yet implemented');
+ return $op->next; # ignore the op
+ }
+ }
+ default_pp($op);
+ my $lastop = $cxstack[$cxix]->{lastop}->next;
+ push(@bblock_todo, $lastop);
+ runtime(sprintf("goto %s;", label($lastop)));
+ return $op->next;
+}
+
+sub pp_subst {
+ my $op = shift;
+ write_back_lexicals();
+ write_back_stack();
+ my $sym = doop($op);
+ my $replroot = $op->pmreplroot;
+ if (ad($replroot)) {
+ runtime sprintf("if (op == ((PMOP*)(%s))->op_pmreplroot) goto %s;",
+ $sym, label($replroot));
+ $op->pmreplstart->save;
+ push(@bblock_todo, $replroot);
+ }
+ invalidate_lexicals();
+ return $op->next;
+}
+
+sub pp_substcont {
+ my $op = shift;
+ write_back_lexicals();
+ write_back_stack();
+ doop($op);
+ my $pmop = $op->other;
+ my $pmopsym = objsym($pmop);
+ runtime sprintf("if (op == ((PMOP*)(%s))->op_pmreplstart) goto %s;",
+ $pmopsym, label($pmop->pmreplstart));
+ invalidate_lexicals();
+ return $pmop->next;
+}
+
+sub default_pp {
+ my $op = shift;
+ my $ppname = $op->ppaddr;
+ write_back_lexicals() unless $skip_lexicals{$ppname};
+ write_back_stack() unless $skip_stack{$ppname};
+ doop($op);
+ # XXX If the only way that ops can write to a TEMPORARY lexical is
+ # when it's named in $op->targ then we could call
+ # invalidate_lexicals(TEMPORARY) and avoid having to write back all
+ # the temporaries. For now, we'll play it safe and write back the lot.
+ invalidate_lexicals() unless $skip_invalidate{$ppname};
+ return $op->next;
+}
+
+sub compile_op {
+ my $op = shift;
+ my $ppname = $op->ppaddr;
+ if (exists $ignore_op{$ppname}) {
+ return $op->next;
+ }
+ debug peek_stack() if $debug_stack;
+ if ($debug_op) {
+ debug sprintf("%s [%s]\n",
+ peekop($op),
+ $op->flags & OPf_STACKED ? "OPf_STACKED" : $op->targ);
+ }
+ no strict 'refs';
+ if (defined(&$ppname)) {
+ $know_op = 0;
+ return &$ppname($op);
+ } else {
+ return default_pp($op);
+ }
+}
+
+sub compile_bblock {
+ my $op = shift;
+ #warn "compile_bblock: ", peekop($op), "\n"; # debug
+ write_label($op);
+ $know_op = 0;
+ do {
+ $op = compile_op($op);
+ } while (defined($op) && $$op && !exists($leaders->{$$op}));
+ write_back_stack(); # boo hoo: big loss
+ reload_lexicals();
+ return $op;
+}
+
+sub cc {
+ my ($name, $root, $start, @padlist) = @_;
+ my $op;
+ init_pp($name);
+ load_pad(@padlist);
+ B::Pseudoreg->new_scope;
+ @cxstack = ();
+ if ($debug_timings) {
+ warn sprintf("Basic block analysis at %s\n", timing_info);
+ }
+ $leaders = find_leaders($root, $start);
+ @bblock_todo = ($start, values %$leaders);
+ if ($debug_timings) {
+ warn sprintf("Compilation at %s\n", timing_info);
+ }
+ while (@bblock_todo) {
+ $op = shift @bblock_todo;
+ #warn sprintf("Considering basic block %s\n", peekop($op)); # debug
+ next if !defined($op) || !$$op || $done{$$op};
+ #warn "...compiling it\n"; # debug
+ do {
+ $done{$$op} = 1;
+ $op = compile_bblock($op);
+ if ($need_freetmps && $freetmps_each_bblock) {
+ runtime("FREETMPS;");
+ $need_freetmps = 0;
+ }
+ } while defined($op) && $$op && !$done{$$op};
+ if ($need_freetmps && $freetmps_each_loop) {
+ runtime("FREETMPS;");
+ $need_freetmps = 0;
+ }
+ if (!$$op) {
+ runtime("PUTBACK;", "return 0;");
+ } elsif ($done{$$op}) {
+ runtime(sprintf("goto %s;", label($op)));
+ }
+ }
+ if ($debug_timings) {
+ warn sprintf("Saving runtime at %s\n", timing_info);
+ }
+ save_runtime();
+}
+
+sub cc_recurse {
+ my $ccinfo;
+ my $start;
+ $start = cc_queue(@_) if @_;
+ while ($ccinfo = shift @cc_todo) {
+ cc(@$ccinfo);
+ }
+ return $start;
+}
+
+sub cc_obj {
+ my ($name, $cvref) = @_;
+ my $cv = svref_2object($cvref);
+ my @padlist = $cv->PADLIST->ARRAY;
+ my $curpad_sym = $padlist[1]->save;
+ cc_recurse($name, $cv->ROOT, $cv->START, @padlist);
+}
+
+sub cc_main {
+ my @comppadlist = comppadlist->ARRAY;
+ my $curpad_sym = $comppadlist[1]->save;
+ my $start = cc_recurse("pp_main", main_root, main_start, @comppadlist);
+ if (@unused_sub_packages) {
+ save_unused_subs(@unused_sub_packages);
+ # That only queues them. Now we need to generate code for them.
+ cc_recurse();
+ }
+ return if $errors;
+ push_init(sprintf("main_root = sym_%x;", ad(main_root)),
+ "main_start = $start;",
+ "curpad = AvARRAY($curpad_sym);");
+ output_boilerplate();
+ print "\n";
+ output_all("perl_init");
+ output_runtime();
+ print "\n";
+ output_main();
+ if ($debug_timings) {
+ warn sprintf("Done at %s\n", timing_info);
+ }
+}
+
+sub compile {
+ my @options = @_;
+ my ($option, $opt, $arg);
+ OPTION:
+ while ($option = shift @options) {
+ if ($option =~ /^-(.)(.*)/) {
+ $opt = $1;
+ $arg = $2;
+ } else {
+ unshift @options, $option;
+ last OPTION;
+ }
+ if ($opt eq "-" && $arg eq "-") {
+ shift @options;
+ last OPTION;
+ } elsif ($opt eq "o") {
+ $arg ||= shift @options;
+ open(STDOUT, ">$arg") or return "$arg: $!\n";
+ } elsif ($opt eq "n") {
+ $arg ||= shift @options;
+ $module_name = $arg;
+ } elsif ($opt eq "u") {
+ $arg ||= shift @options;
+ push(@unused_sub_packages, $arg);
+ } elsif ($opt eq "f") {
+ $arg ||= shift @options;
+ my $value = $arg !~ s/^no-//;
+ $arg =~ s/-/_/g;
+ my $ref = $optimise{$arg};
+ if (defined($ref)) {
+ $$ref = $value;
+ } else {
+ warn qq(ignoring unknown optimisation option "$arg"\n);
+ }
+ } elsif ($opt eq "O") {
+ $arg = 1 if $arg eq "";
+ my $ref;
+ foreach $ref (values %optimise) {
+ $$ref = 0;
+ }
+ if ($arg >= 2) {
+ $freetmps_each_loop = 1;
+ }
+ if ($arg >= 1) {
+ $freetmps_each_bblock = 1 unless $freetmps_each_loop;
+ }
+ } elsif ($opt eq "D") {
+ $arg ||= shift @options;
+ foreach $arg (split(//, $arg)) {
+ if ($arg eq "o") {
+ B->debug(1);
+ } elsif ($arg eq "O") {
+ $debug_op = 1;
+ } elsif ($arg eq "s") {
+ $debug_stack = 1;
+ } elsif ($arg eq "c") {
+ $debug_cxstack = 1;
+ } elsif ($arg eq "p") {
+ $debug_pad = 1;
+ } elsif ($arg eq "r") {
+ $debug_runtime = 1;
+ } elsif ($arg eq "S") {
+ $debug_shadow = 1;
+ } elsif ($arg eq "q") {
+ $debug_queue = 1;
+ } elsif ($arg eq "l") {
+ $debug_lineno = 1;
+ } elsif ($arg eq "t") {
+ $debug_timings = 1;
+ }
+ }
+ }
+ }
+ init_init();
+ if (@options) {
+ return sub {
+ my ($objname, $ppname);
+ foreach $objname (@options) {
+ $objname = "main::$objname" unless $objname =~ /::/;
+ ($ppname = $objname) =~ s/^.*?:://;
+ eval "cc_obj(qq(pp_sub_$ppname), \\&$objname)";
+ die "cc_obj(qq(pp_sub_$ppname, \\&$objname) failed: $@" if $@;
+ return if $errors;
+ }
+ output_boilerplate();
+ print "\n";
+ output_all($module_name || "init_module");
+ output_runtime();
+ }
+ } else {
+ return sub { cc_main() };
+ }
+}
+
+1;
--- /dev/null
+package B::Debug;
+use strict;
+use B qw(peekop class ad walkoptree walkoptree_exec
+ main_start main_root cstring sv_undef);
+use B::Asmdata qw(@specialsv_name);
+
+sub B::OP::debug {
+ my ($op) = @_;
+ printf <<'EOT', class($op), ad($op), ad($op->next), ad($op->sibling), $op->ppaddr, $op->targ, $op->type, $op->seq, $op->flags, $op->private;
+%s (0x%lx)
+ op_next 0x%x
+ op_sibling 0x%x
+ op_ppaddr %s
+ op_targ %d
+ op_type %d
+ op_seq %d
+ op_flags %d
+ op_private %d
+EOT
+}
+
+sub B::UNOP::debug {
+ my ($op) = @_;
+ $op->B::OP::debug();
+ printf "\top_first\t0x%x\n", ad($op->first);
+}
+
+sub B::BINOP::debug {
+ my ($op) = @_;
+ $op->B::UNOP::debug();
+ printf "\top_last\t\t0x%x\n", ad($op->last);
+}
+
+sub B::LOGOP::debug {
+ my ($op) = @_;
+ $op->B::UNOP::debug();
+ printf "\top_other\t0x%x\n", ad($op->other);
+}
+
+sub B::CONDOP::debug {
+ my ($op) = @_;
+ $op->B::UNOP::debug();
+ printf "\top_true\t0x%x\n", ad($op->true);
+ printf "\top_false\t0x%x\n", ad($op->false);
+}
+
+sub B::LISTOP::debug {
+ my ($op) = @_;
+ $op->B::BINOP::debug();
+ printf "\top_children\t%d\n", $op->children;
+}
+
+sub B::PMOP::debug {
+ my ($op) = @_;
+ $op->B::LISTOP::debug();
+ printf "\top_pmreplroot\t0x%x\n", ad($op->pmreplroot);
+ printf "\top_pmreplstart\t0x%x\n", ad($op->pmreplstart);
+ printf "\top_pmnext\t0x%x\n", ad($op->pmnext);
+ printf "\top_pmregexp->precomp\t%s\n", cstring($op->precomp);
+ printf "\top_pmshort\t0x%x\n", ad($op->pmshort);
+ printf "\top_pmflags\t0x%x\n", $op->pmflags;
+ printf "\top_pmslen\t%d\n", $op->pmslen;
+ $op->pmshort->debug;
+ $op->pmreplroot->debug;
+}
+
+sub B::COP::debug {
+ my ($op) = @_;
+ $op->B::OP::debug();
+ my ($filegv) = $op->filegv;
+ printf <<'EOT', $op->label, ad($op->stash), ad($filegv), $op->seq, $op->arybase, $op->line;
+ cop_label %s
+ cop_stash 0x%x
+ cop_filegv 0x%x
+ cop_seq %d
+ cop_arybase %d
+ cop_line %d
+EOT
+ $filegv->debug;
+}
+
+sub B::SVOP::debug {
+ my ($op) = @_;
+ $op->B::OP::debug();
+ printf "\top_sv\t\t0x%x\n", ad($op->sv);
+ $op->sv->debug;
+}
+
+sub B::PVOP::debug {
+ my ($op) = @_;
+ $op->B::OP::debug();
+ printf "\top_pv\t\t0x%x\n", $op->pv;
+}
+
+sub B::GVOP::debug {
+ my ($op) = @_;
+ $op->B::OP::debug();
+ printf "\top_gv\t\t0x%x\n", ad($op->gv);
+}
+
+sub B::CVOP::debug {
+ my ($op) = @_;
+ $op->B::OP::debug();
+ printf "\top_cv\t\t0x%x\n", ad($op->cv);
+}
+
+sub B::NULL::debug {
+ my ($sv) = @_;
+ if (ad($sv) == ad(sv_undef())) {
+ print "&sv_undef\n";
+ } else {
+ printf "NULL (0x%x)\n", ad($sv);
+ }
+}
+
+sub B::SV::debug {
+ my ($sv) = @_;
+ if (!$$sv) {
+ print class($sv), " = NULL\n";
+ return;
+ }
+ printf <<'EOT', class($sv), ad($sv), $sv->REFCNT, $sv->FLAGS;
+%s (0x%x)
+ REFCNT %d
+ FLAGS 0x%x
+EOT
+}
+
+sub B::PV::debug {
+ my ($sv) = @_;
+ $sv->B::SV::debug();
+ my $pv = $sv->PV();
+ printf <<'EOT', cstring($pv), length($pv);
+ xpv_pv %s
+ xpv_cur %d
+EOT
+}
+
+sub B::IV::debug {
+ my ($sv) = @_;
+ $sv->B::SV::debug();
+ printf "\txiv_iv\t\t%d\n", $sv->IV;
+}
+
+sub B::NV::debug {
+ my ($sv) = @_;
+ $sv->B::IV::debug();
+ printf "\txnv_nv\t\t%s\n", $sv->NV;
+}
+
+sub B::PVIV::debug {
+ my ($sv) = @_;
+ $sv->B::PV::debug();
+ printf "\txiv_iv\t\t%d\n", $sv->IV;
+}
+
+sub B::PVNV::debug {
+ my ($sv) = @_;
+ $sv->B::PVIV::debug();
+ printf "\txnv_nv\t\t%s\n", $sv->NV;
+}
+
+sub B::PVLV::debug {
+ my ($sv) = @_;
+ $sv->B::PVNV::debug();
+ printf "\txlv_targoff\t%d\n", $sv->TARGOFF;
+ printf "\txlv_targlen\t%u\n", $sv->TARGLEN;
+ printf "\txlv_type\t%s\n", cstring(chr($sv->TYPE));
+}
+
+sub B::BM::debug {
+ my ($sv) = @_;
+ $sv->B::PVNV::debug();
+ printf "\txbm_useful\t%d\n", $sv->USEFUL;
+ printf "\txbm_previous\t%u\n", $sv->PREVIOUS;
+ printf "\txbm_rare\t%s\n", cstring(chr($sv->RARE));
+}
+
+sub B::CV::debug {
+ my ($sv) = @_;
+ $sv->B::PVNV::debug();
+ my ($stash) = $sv->STASH;
+ my ($start) = $sv->START;
+ my ($root) = $sv->ROOT;
+ my ($padlist) = $sv->PADLIST;
+ my ($gv) = $sv->GV;
+ my ($filegv) = $sv->FILEGV;
+ printf <<'EOT', ad($stash), ad($start), ad($root), ad($gv), ad($filegv), $sv->DEPTH, $padlist, ad($sv->OUTSIDE);
+ STASH 0x%x
+ START 0x%x
+ ROOT 0x%x
+ GV 0x%x
+ FILEGV 0x%x
+ DEPTH %d
+ PADLIST 0x%x
+ OUTSIDE 0x%x
+EOT
+ $start->debug if $start;
+ $root->debug if $root;
+ $gv->debug if $gv;
+ $filegv->debug if $filegv;
+ $padlist->debug if $padlist;
+}
+
+sub B::AV::debug {
+ my ($av) = @_;
+ $av->B::SV::debug;
+ my(@array) = $av->ARRAY;
+ print "\tARRAY\t\t(", join(", ", map("0x" . ad($_), @array)), ")\n";
+ printf <<'EOT', scalar(@array), $av->MAX, $av->OFF, $av->AvFLAGS;
+ FILL %d
+ MAX %d
+ OFF %d
+ AvFLAGS %d
+EOT
+}
+
+sub B::GV::debug {
+ my ($gv) = @_;
+ my ($sv) = $gv->SV;
+ my ($av) = $gv->AV;
+ my ($cv) = $gv->CV;
+ $gv->B::SV::debug;
+ printf <<'EOT', $gv->NAME, $gv->STASH, ad($sv), $gv->GvREFCNT, $gv->FORM, ad($av), ad($gv->HV), ad($gv->EGV), ad($cv), $gv->CVGEN, $gv->LINE, $gv->FILEGV, $gv->GvFLAGS;
+ NAME %s
+ STASH 0x%x
+ SV 0x%x
+ GvREFCNT %d
+ FORM 0x%x
+ AV 0x%x
+ HV 0x%x
+ EGV 0x%x
+ CV 0x%x
+ CVGEN %d
+ LINE %d
+ FILEGV 0x%x
+ GvFLAGS 0x%x
+EOT
+ $sv->debug if $sv;
+ $av->debug if $av;
+ $cv->debug if $cv;
+}
+
+sub B::SPECIAL::debug {
+ my $sv = shift;
+ print $specialsv_name[$$sv], "\n";
+}
+
+sub compile {
+ my $order = shift;
+ if ($order eq "exec") {
+ return sub { walkoptree_exec(main_start, "debug") }
+ } else {
+ return sub { walkoptree(main_root, "debug") }
+ }
+}
+
+1;
--- /dev/null
+# Disassembler.pm
+#
+# Copyright (c) 1996 Malcolm Beattie
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the README file.
+package B::Disassembler::BytecodeStream;
+use FileHandle;
+use Carp;
+use B qw(cstring cast_I32);
+@ISA = qw(FileHandle);
+sub readn {
+ my ($fh, $len) = @_;
+ my $data;
+ read($fh, $data, $len);
+ croak "reached EOF while reading $len bytes" unless length($data) == $len;
+ return $data;
+}
+
+sub GET_U8 {
+ my $fh = shift;
+ my $c = $fh->getc;
+ croak "reached EOF while reading U8" unless defined($c);
+ return ord($c);
+}
+
+sub GET_U16 {
+ my $fh = shift;
+ my $str = $fh->readn(2);
+ croak "reached EOF while reading U16" unless length($str) == 2;
+ return unpack("n", $str);
+}
+
+sub GET_U32 {
+ my $fh = shift;
+ my $str = $fh->readn(4);
+ croak "reached EOF while reading U32" unless length($str) == 4;
+ return unpack("N", $str);
+}
+
+sub GET_I32 {
+ my $fh = shift;
+ my $str = $fh->readn(4);
+ croak "reached EOF while reading I32" unless length($str) == 4;
+ return cast_I32(unpack("N", $str));
+}
+
+sub GET_objindex {
+ my $fh = shift;
+ my $str = $fh->readn(4);
+ croak "reached EOF while reading objindex" unless length($str) == 4;
+ return unpack("N", $str);
+}
+
+sub GET_strconst {
+ my $fh = shift;
+ my ($str, $c);
+ while (defined($c = $fh->getc) && $c ne "\0") {
+ $str .= $c;
+ }
+ croak "reached EOF while reading strconst" unless defined($c);
+ return cstring($str);
+}
+
+sub GET_pvcontents {}
+
+sub GET_PV {
+ my $fh = shift;
+ my $str;
+ my $len = $fh->GET_U32;
+ if ($len) {
+ read($fh, $str, $len);
+ croak "reached EOF while reading PV" unless length($str) == $len;
+ return cstring($str);
+ } else {
+ return '""';
+ }
+}
+
+sub GET_comment {
+ my $fh = shift;
+ my ($str, $c);
+ while (defined($c = $fh->getc) && $c ne "\n") {
+ $str .= $c;
+ }
+ croak "reached EOF while reading comment" unless defined($c);
+ return cstring($str);
+}
+
+sub GET_double {
+ my $fh = shift;
+ my ($str, $c);
+ while (defined($c = $fh->getc) && $c ne "\0") {
+ $str .= $c;
+ }
+ croak "reached EOF while reading double" unless defined($c);
+ return $str;
+}
+
+sub GET_none {}
+
+sub GET_op_tr_array {
+ my $fh = shift;
+ my @ary = unpack("n256", $fh->readn(256 * 2));
+ return join(",", @ary);
+}
+
+sub GET_IV64 {
+ my $fh = shift;
+ my ($hi, $lo) = unpack("NN", $fh->readn(8));
+ return sprintf("0x%4x%04x", $hi, $lo); # cheat
+}
+
+package B::Disassembler;
+use Exporter;
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(disassemble_fh);
+use Carp;
+use strict;
+
+use B::Asmdata qw(%insn_data @insn_name);
+
+sub disassemble_fh {
+ my ($fh, $out) = @_;
+ my ($c, $getmeth, $insn, $arg);
+ bless $fh, "B::Disassembler::BytecodeStream";
+ while (defined($c = $fh->getc)) {
+ $c = ord($c);
+ $insn = $insn_name[$c];
+ if (!defined($insn) || $insn eq "unused") {
+ my $pos = $fh->tell - 1;
+ die "Illegal instruction code $c at stream offset $pos\n";
+ }
+ $getmeth = $insn_data{$insn}->[2];
+ $arg = $fh->$getmeth();
+ if (defined($arg)) {
+ &$out($insn, $arg);
+ } else {
+ &$out($insn);
+ }
+ }
+}
+
+1;
--- /dev/null
+package B::Showlex;
+use strict;
+use B qw(svref_2object comppadlist class);
+use B::Terse ();
+
+#
+# Invoke as
+# perl -MO=Showlex,foo bar.pl
+# to see the names of lexical variables used by &foo
+# or as
+# perl -MO=Showlex bar.pl
+# to see the names of file scope lexicals used by bar.pl
+#
+
+sub showarray {
+ my ($name, $av) = @_;
+ my @els = $av->ARRAY;
+ my $count = @els;
+ my $i;
+ print "$name has $count entries\n";
+ for ($i = 0; $i < $count; $i++) {
+ print "$i: ";
+ $els[$i]->terse;
+ }
+}
+
+sub showlex {
+ my ($objname, $namesav, $valsav) = @_;
+ showarray("Pad of lexical names for $objname", $namesav);
+ showarray("Pad of lexical values for $objname", $valsav);
+}
+
+sub showlex_obj {
+ my ($objname, $obj) = @_;
+ $objname =~ s/^&main::/&/;
+ showlex($objname, svref_2object($obj)->PADLIST->ARRAY);
+}
+
+sub showlex_main {
+ showlex("comppadlist", comppadlist->ARRAY);
+}
+
+sub compile {
+ my @options = @_;
+ if (@options) {
+ return sub {
+ my $objname;
+ foreach $objname (@options) {
+ $objname = "main::$objname" unless $objname =~ /::/;
+ eval "showlex_obj('&$objname', \\&$objname)";
+ }
+ }
+ } else {
+ return \&showlex_main;
+ }
+}
+
+1;
--- /dev/null
+# Stackobj.pm
+#
+# Copyright (c) 1996 Malcolm Beattie
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the README file.
+#
+package B::Stackobj;
+use Exporter ();
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(set_callback T_UNKNOWN T_DOUBLE T_INT
+ VALID_INT VALID_DOUBLE VALID_SV REGISTER TEMPORARY);
+%EXPORT_TAGS = (types => [qw(T_UNKNOWN T_DOUBLE T_INT)],
+ flags => [qw(VALID_INT VALID_DOUBLE VALID_SV
+ REGISTER TEMPORARY)]);
+
+use Carp qw(confess);
+use strict;
+use B qw(class);
+
+# Perl internal constants that I should probably define elsewhere.
+sub SVf_IOK () { 0x10000 }
+sub SVf_NOK () { 0x20000 }
+
+# Types
+sub T_UNKNOWN () { 0 }
+sub T_DOUBLE () { 1 }
+sub T_INT () { 2 }
+
+# Flags
+sub VALID_INT () { 0x01 }
+sub VALID_DOUBLE () { 0x02 }
+sub VALID_SV () { 0x04 }
+sub REGISTER () { 0x08 } # no implicit write-back when calling subs
+sub TEMPORARY () { 0x10 } # no implicit write-back needed at all
+
+#
+# Callback for runtime code generation
+#
+my $runtime_callback = sub { confess "set_callback not yet called" };
+sub set_callback (&) { $runtime_callback = shift }
+sub runtime { &$runtime_callback(@_) }
+
+#
+# Methods
+#
+
+sub write_back { confess "stack object does not implement write_back" }
+
+sub invalidate { shift->{flags} &= ~(VALID_INT | VALID_DOUBLE) }
+
+sub as_sv {
+ my $obj = shift;
+ if (!($obj->{flags} & VALID_SV)) {
+ $obj->write_back;
+ $obj->{flags} |= VALID_SV;
+ }
+ return $obj->{sv};
+}
+
+sub as_int {
+ my $obj = shift;
+ if (!($obj->{flags} & VALID_INT)) {
+ $obj->load_int;
+ $obj->{flags} |= VALID_INT;
+ }
+ return $obj->{iv};
+}
+
+sub as_double {
+ my $obj = shift;
+ if (!($obj->{flags} & VALID_DOUBLE)) {
+ $obj->load_double;
+ $obj->{flags} |= VALID_DOUBLE;
+ }
+ return $obj->{nv};
+}
+
+sub as_numeric {
+ my $obj = shift;
+ return $obj->{type} == T_INT ? $obj->as_int : $obj->as_double;
+}
+
+#
+# Debugging methods
+#
+sub peek {
+ my $obj = shift;
+ my $type = $obj->{type};
+ my $flags = $obj->{flags};
+ my @flags;
+ if ($type == T_UNKNOWN) {
+ $type = "T_UNKNOWN";
+ } elsif ($type == T_INT) {
+ $type = "T_INT";
+ } elsif ($type == T_DOUBLE) {
+ $type = "T_DOUBLE";
+ } else {
+ $type = "(illegal type $type)";
+ }
+ push(@flags, "VALID_INT") if $flags & VALID_INT;
+ push(@flags, "VALID_DOUBLE") if $flags & VALID_DOUBLE;
+ push(@flags, "VALID_SV") if $flags & VALID_SV;
+ push(@flags, "REGISTER") if $flags & REGISTER;
+ push(@flags, "TEMPORARY") if $flags & TEMPORARY;
+ @flags = ("none") unless @flags;
+ return sprintf("%s type=$type flags=%s sv=$obj->{sv}",
+ class($obj), join("|", @flags));
+}
+
+sub minipeek {
+ my $obj = shift;
+ my $type = $obj->{type};
+ my $flags = $obj->{flags};
+ if ($type == T_INT || $flags & VALID_INT) {
+ return $obj->{iv};
+ } elsif ($type == T_DOUBLE || $flags & VALID_DOUBLE) {
+ return $obj->{nv};
+ } else {
+ return $obj->{sv};
+ }
+}
+
+#
+# Caller needs to ensure that set_int, set_double,
+# set_numeric and set_sv are only invoked on legal lvalues.
+#
+sub set_int {
+ my ($obj, $expr) = @_;
+ runtime("$obj->{iv} = $expr;");
+ $obj->{flags} &= ~(VALID_SV | VALID_DOUBLE);
+ $obj->{flags} |= VALID_INT;
+}
+
+sub set_double {
+ my ($obj, $expr) = @_;
+ runtime("$obj->{nv} = $expr;");
+ $obj->{flags} &= ~(VALID_SV | VALID_INT);
+ $obj->{flags} |= VALID_DOUBLE;
+}
+
+sub set_numeric {
+ my ($obj, $expr) = @_;
+ if ($obj->{type} == T_INT) {
+ $obj->set_int($expr);
+ } else {
+ $obj->set_double($expr);
+ }
+}
+
+sub set_sv {
+ my ($obj, $expr) = @_;
+ runtime("SvSetSV($obj->{sv}, $expr);");
+ $obj->invalidate;
+ $obj->{flags} |= VALID_SV;
+}
+
+#
+# Stackobj::Padsv
+#
+
+@B::Stackobj::Padsv::ISA = 'B::Stackobj';
+sub B::Stackobj::Padsv::new {
+ my ($class, $type, $extra_flags, $ix, $iname, $dname) = @_;
+ bless {
+ type => $type,
+ flags => VALID_SV | $extra_flags,
+ sv => "curpad[$ix]",
+ iv => "$iname",
+ nv => "$dname"
+ }, $class;
+}
+
+sub B::Stackobj::Padsv::load_int {
+ my $obj = shift;
+ if ($obj->{flags} & VALID_DOUBLE) {
+ runtime("$obj->{iv} = $obj->{nv};");
+ } else {
+ runtime("$obj->{iv} = SvIV($obj->{sv});");
+ }
+ $obj->{flags} |= VALID_INT;
+}
+
+sub B::Stackobj::Padsv::load_double {
+ my $obj = shift;
+ runtime("$obj->{nv} = SvNV($obj->{sv});");
+ $obj->{flags} |= VALID_DOUBLE;
+}
+
+sub B::Stackobj::Padsv::write_back {
+ my $obj = shift;
+ my $flags = $obj->{flags};
+ return if $flags & VALID_SV;
+ if ($flags & VALID_INT) {
+ runtime("sv_setiv($obj->{sv}, $obj->{iv});");
+ } elsif ($flags & VALID_DOUBLE) {
+ runtime("sv_setnv($obj->{sv}, $obj->{nv});");
+ } else {
+ confess "write_back failed for lexical @{[$obj->peek]}\n";
+ }
+ $obj->{flags} |= VALID_SV;
+}
+
+#
+# Stackobj::Const
+#
+
+@B::Stackobj::Const::ISA = 'B::Stackobj';
+sub B::Stackobj::Const::new {
+ my ($class, $sv) = @_;
+ my $obj = bless {
+ flags => 0,
+ sv => $sv # holds the SV object until write_back happens
+ }, $class;
+ my $svflags = $sv->FLAGS;
+ if ($svflags & SVf_IOK) {
+ $obj->{flags} = VALID_INT|VALID_DOUBLE;
+ $obj->{type} = T_INT;
+ $obj->{nv} = $obj->{iv} = $sv->IV;
+ } elsif ($svflags & SVf_NOK) {
+ $obj->{flags} = VALID_INT|VALID_DOUBLE;
+ $obj->{type} = T_DOUBLE;
+ $obj->{iv} = $obj->{nv} = $sv->NV;
+ } else {
+ $obj->{type} = T_UNKNOWN;
+ }
+ return $obj;
+}
+
+sub B::Stackobj::Const::write_back {
+ my $obj = shift;
+ return if $obj->{flags} & VALID_SV;
+ # Save the SV object and replace $obj->{sv} by its C source code name
+ $obj->{sv} = $obj->{sv}->save;
+ $obj->{flags} |= VALID_SV|VALID_INT|VALID_DOUBLE;
+}
+
+sub B::Stackobj::Const::load_int {
+ my $obj = shift;
+ $obj->{iv} = int($obj->{sv}->PV);
+ $obj->{flags} |= VALID_INT;
+}
+
+sub B::Stackobj::Const::load_double {
+ my $obj = shift;
+ $obj->{nv} = $obj->{sv}->PV + 0.0;
+ $obj->{flags} |= VALID_DOUBLE;
+}
+
+sub B::Stackobj::Const::invalidate {}
+
+#
+# Stackobj::Bool
+#
+
+@B::Stackobj::Bool::ISA = 'B::Stackobj';
+sub B::Stackobj::Bool::new {
+ my ($class, $preg) = @_;
+ my $obj = bless {
+ type => T_INT,
+ flags => VALID_INT|VALID_DOUBLE,
+ iv => $$preg,
+ nv => $$preg,
+ preg => $preg # this holds our ref to the pseudo-reg
+ }, $class;
+ return $obj;
+}
+
+sub B::Stackobj::Bool::write_back {
+ my $obj = shift;
+ return if $obj->{flags} & VALID_SV;
+ $obj->{sv} = "($obj->{iv} ? &sv_yes : &sv_no)";
+ $obj->{flags} |= VALID_SV;
+}
+
+# XXX Might want to handle as_double/set_double/load_double?
+
+sub B::Stackobj::Bool::invalidate {}
+
+1;
--- /dev/null
+package B::Terse;
+use strict;
+use B qw(peekop class ad walkoptree walkoptree_exec
+ main_start main_root cstring svref_2object);
+use B::Asmdata qw(@specialsv_name);
+
+sub terse {
+ my ($order, $cvref) = @_;
+ my $cv = svref_2object($cvref);
+ if ($order eq "exec") {
+ walkoptree_exec($cv->START, "terse");
+ } else {
+ walkoptree($cv->ROOT, "terse");
+ }
+}
+
+sub compile {
+ my $order = shift;
+ my @options = @_;
+ if (@options) {
+ return sub {
+ my $objname;
+ foreach $objname (@options) {
+ $objname = "main::$objname" unless $objname =~ /::/;
+ eval "terse(\$order, \\&$objname)";
+ die "terse($order, \\&$objname) failed: $@" if $@;
+ }
+ }
+ } else {
+ if ($order eq "exec") {
+ return sub { walkoptree_exec(main_start, "terse") }
+ } else {
+ return sub { walkoptree(main_root, "terse") }
+ }
+ }
+}
+
+sub indent {
+ my $level = shift;
+ return " " x $level;
+}
+
+sub B::OP::terse {
+ my ($op, $level) = @_;
+ my $targ = $op->targ;
+ $targ = ($targ > 0) ? " [$targ]" : "";
+ print indent($level), peekop($op), $targ, "\n";
+}
+
+sub B::SVOP::terse {
+ my ($op, $level) = @_;
+ print indent($level), peekop($op), " ";
+ $op->sv->terse(0);
+}
+
+sub B::GVOP::terse {
+ my ($op, $level) = @_;
+ print indent($level), peekop($op), " ";
+ $op->gv->terse(0);
+}
+
+sub B::PMOP::terse {
+ my ($op, $level) = @_;
+ my $precomp = $op->precomp;
+ print indent($level), peekop($op),
+ defined($precomp) ? " /$precomp/\n" : " (regexp not compiled)\n";
+
+}
+
+sub B::PVOP::terse {
+ my ($op, $level) = @_;
+ print indent($level), peekop($op), " ", cstring($op->pv), "\n";
+}
+
+sub B::COP::terse {
+ my ($op, $level) = @_;
+ my $label = $op->label;
+ if ($label) {
+ $label = " label ".cstring($label);
+ }
+ print indent($level), peekop($op), $label, "\n";
+}
+
+sub B::PV::terse {
+ my ($sv, $level) = @_;
+ print indent($level);
+ printf "%s (0x%lx) %s\n", class($sv), ad($sv), cstring($sv->PV);
+}
+
+sub B::AV::terse {
+ my ($sv, $level) = @_;
+ print indent($level);
+ printf "%s (0x%lx) FILL %d\n", class($sv), ad($sv), $sv->FILL;
+}
+
+sub B::GV::terse {
+ my ($gv, $level) = @_;
+ my $stash = $gv->STASH->NAME;
+ if ($stash eq "main") {
+ $stash = "";
+ } else {
+ $stash = $stash . "::";
+ }
+ print indent($level);
+ printf "%s (0x%lx) *%s%s\n", class($gv), ad($gv), $stash, $gv->NAME;
+}
+
+sub B::IV::terse {
+ my ($sv, $level) = @_;
+ print indent($level);
+ printf "%s (0x%lx) %d\n", class($sv), ad($sv), $sv->IV;
+}
+
+sub B::NV::terse {
+ my ($sv, $level) = @_;
+ print indent($level);
+ printf "%s (0x%lx) %s\n", class($sv), ad($sv), $sv->NV;
+}
+
+sub B::NULL::terse {
+ my ($sv, $level) = @_;
+ print indent($level);
+ printf "%s (0x%lx)\n", class($sv), ad($sv);
+}
+
+sub B::SPECIAL::terse {
+ my ($sv, $level) = @_;
+ print indent($level);
+ printf "%s #%d %s\n", class($sv), $$sv, $specialsv_name[$$sv];
+}
+
+1;
--- /dev/null
+package B::Xref;
+
+=head1 NAME
+
+B::Xref - Generates cross reference reports for Perl programs
+
+=head1 SYNOPSIS
+
+perl -MO=Xref[,OPTIONS] foo.pl
+
+=head1 DESCRIPTION
+
+The B::Xref module is used to generate a cross reference listing of all
+definitions and uses of variables, subroutines and formats in a Perl program.
+It is implemented as a backend for the Perl compiler.
+
+The report generated is in the following format:
+
+ File filename1
+ Subroutine subname1
+ Package package1
+ object1 C<line numbers>
+ object2 C<line numbers>
+ ...
+ Package package2
+ ...
+
+Each B<File> section reports on a single file. Each B<Subroutine> section
+reports on a single subroutine apart from the special cases
+"(definitions)" and "(main)". These report, respectively, on subroutine
+definitions found by the initial symbol table walk and on the main part of
+the program or module external to all subroutines.
+
+The report is then grouped by the B<Package> of each variable,
+subroutine or format with the special case "(lexicals)" meaning
+lexical variables. Each B<object> name (implicitly qualified by its
+containing B<Package>) includes its type character(s) at the beginning
+where possible. Lexical variables are easier to track and even
+included dereferencing information where possible.
+
+The C<line numbers> are a comma separated list of line numbers (some
+preceded by code letters) where that object is used in some way.
+Simple uses aren't preceded by a code letter. Introductions (such as
+where a lexical is first defined with C<my>) are indicated with the
+letter "i". Subroutine and method calls are indicated by the character
+"&". Subroutine definitions are indicated by "s" and format
+definitions by "f".
+
+=head1 OPTIONS
+
+Option words are separated by commas (not whitespace) and follow the
+usual conventions of compiler backend options.
+
+=over 8
+
+=item C<-oFILENAME>
+
+Directs output to C<FILENAME> instead of standard output.
+
+=item C<-r>
+
+Raw output. Instead of producing a human-readable report, outputs a line
+in machine-readable form for each definition/use of a variable/sub/format.
+
+=item C<-D[tO]>
+
+(Internal) debug options, probably only useful if C<-r> included.
+The C<t> option prints the object on the top of the stack as it's
+being tracked. The C<O> option prints each operator as it's being
+processed in the execution order of the program.
+
+=back
+
+=head1 BUGS
+
+Non-lexical variables are quite difficult to track through a program.
+Sometimes the type of a non-lexical variable's use is impossible to
+determine. Introductions of non-lexical non-scalars don't seem to be
+reported properly.
+
+=head1 AUTHOR
+
+Malcolm Beattie, mbeattie@sable.ox.ac.uk.
+
+=cut
+
+use strict;
+use B qw(peekop class ad comppadlist main_start svref_2object walksymtable);
+
+# Constants (should probably be elsewhere)
+sub OPpLVAL_INTRO () { 128 }
+sub SVf_POK () { 0x40000 }
+
+sub UNKNOWN { ["?", "?", "?"] }
+
+my @pad; # lexicals in current pad
+ # as ["(lexical)", type, name]
+my %done; # keyed by $$op: set when each $op is done
+my $top = UNKNOWN; # shadows top element of stack as
+ # [pack, type, name] (pack can be "(lexical)")
+my $file; # shadows current filename
+my $line; # shadows current line number
+my $subname; # shadows current sub name
+my %table; # Multi-level hash to record all uses etc.
+my @todo = (); # List of CVs that need processing
+
+my %code = (intro => "i", used => "",
+ subdef => "s", subused => "&",
+ formdef => "f", meth => "->");
+
+
+# Options
+my ($debug_op, $debug_top, $nodefs, $raw);
+
+sub process {
+ my ($var, $event) = @_;
+ my ($pack, $type, $name) = @$var;
+ if ($type eq "*") {
+ if ($event eq "used") {
+ return;
+ } elsif ($event eq "subused") {
+ $type = "&";
+ }
+ }
+ $type =~ s/(.)\*$/$1/g;
+ if ($raw) {
+ printf "%-16s %-12s %5d %-12s %4s %-16s %s\n",
+ $file, $subname, $line, $pack, $type, $name, $event;
+ } else {
+ # Wheee
+ push(@{$table{$file}->{$subname}->{$pack}->{$type.$name}->{$event}},
+ $line);
+ }
+}
+
+sub load_pad {
+ my $padlist = shift;
+ my ($namelistav, @namelist, $ix);
+ @pad = ();
+ return if class($padlist) eq "SPECIAL";
+ ($namelistav) = $padlist->ARRAY;
+ @namelist = $namelistav->ARRAY;
+ for ($ix = 1; $ix < @namelist; $ix++) {
+ my $namesv = $namelist[$ix];
+ next if class($namesv) eq "SPECIAL";
+ my ($type, $name) = $namesv->PV =~ /^(.)(.*)$/;
+ $pad[$ix] = ["(lexical)", $type, $name];
+ }
+}
+
+sub xref {
+ my $start = shift;
+ my $op;
+ for ($op = $start; $$op; $op = $op->next) {
+ last if $done{$$op}++;
+ warn sprintf("top = [%s, %s, %s]\n", @$top) if $debug_top;
+ warn peekop($op), "\n" if $debug_op;
+ my $ppname = $op->ppaddr;
+ if ($ppname =~ /^pp_(or|and|mapwhile|grepwhile)$/) {
+ xref($op->other);
+ } elsif ($ppname eq "pp_match" || $ppname eq "pp_subst") {
+ xref($op->pmreplstart);
+ } elsif ($ppname eq "pp_substcont") {
+ xref($op->other->pmreplstart);
+ $op = $op->other;
+ redo;
+ } elsif ($ppname eq "pp_cond_expr") {
+ # pp_cond_expr never returns op_next
+ xref($op->true);
+ $op = $op->false;
+ redo;
+ } elsif ($ppname eq "pp_enterloop") {
+ xref($op->redoop);
+ xref($op->nextop);
+ xref($op->lastop);
+ } elsif ($ppname eq "pp_subst") {
+ xref($op->pmreplstart);
+ } else {
+ no strict 'refs';
+ &$ppname($op) if defined(&$ppname);
+ }
+ }
+}
+
+sub xref_cv {
+ my $cv = shift;
+ my $pack = $cv->GV->STASH->NAME;
+ $subname = ($pack eq "main" ? "" : "$pack\::") . $cv->GV->NAME;
+ load_pad($cv->PADLIST);
+ xref($cv->START);
+ $subname = "(main)";
+}
+
+sub xref_object {
+ my $cvref = shift;
+ xref_cv(svref_2object($cvref));
+}
+
+sub xref_main {
+ $subname = "(main)";
+ load_pad(comppadlist);
+ xref(main_start);
+ while (@todo) {
+ xref_cv(shift @todo);
+ }
+}
+
+sub pp_nextstate {
+ my $op = shift;
+ $file = $op->filegv->SV->PV;
+ $line = $op->line;
+ $top = UNKNOWN;
+}
+
+sub pp_padsv {
+ my $op = shift;
+ $top = $pad[$op->targ];
+ process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
+}
+
+sub pp_padav { pp_padsv(@_) }
+sub pp_padhv { pp_padsv(@_) }
+
+sub deref {
+ my ($var, $as) = @_;
+ $var->[1] = $as . $var->[1];
+ process($var, "used");
+}
+
+sub pp_rv2cv { deref($top, "&"); }
+sub pp_rv2hv { deref($top, "%"); }
+sub pp_rv2sv { deref($top, "\$"); }
+sub pp_rv2av { deref($top, "\@"); }
+sub pp_rv2gv { deref($top, "*"); }
+
+sub pp_gvsv {
+ my $op = shift;
+ my $gv = $op->gv;
+ $top = [$gv->STASH->NAME, '$', $gv->NAME];
+ process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
+}
+
+sub pp_gv {
+ my $op = shift;
+ my $gv = $op->gv;
+ $top = [$gv->STASH->NAME, "*", $gv->NAME];
+ process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
+}
+
+sub pp_const {
+ my $op = shift;
+ my $sv = $op->sv;
+ $top = ["?", "", $sv->FLAGS & SVf_POK ? $sv->PV : "?"];
+}
+
+sub pp_method {
+ my $op = shift;
+ $top = ["(method)", "->".$top->[1], $top->[2]];
+}
+
+sub pp_entersub {
+ my $op = shift;
+ if ($top->[1] eq "m") {
+ process($top, "meth");
+ } else {
+ process($top, "subused");
+ }
+ $top = UNKNOWN;
+}
+
+#
+# Stuff for cross referencing definitions of variables and subs
+#
+
+sub B::GV::xref {
+ my $gv = shift;
+ my $cv = $gv->CV;
+ if (ad($cv)) {
+ #return if $done{$$cv}++;
+ $file = $gv->FILEGV->SV->PV;
+ $line = $gv->LINE;
+ process([$gv->STASH->NAME, "&", $gv->NAME], "subdef");
+ push(@todo, $cv);
+ }
+ my $form = $gv->FORM;
+ if (ad($form)) {
+ return if $done{$$form}++;
+ $file = $gv->FILEGV->SV->PV;
+ $line = $gv->LINE;
+ process([$gv->STASH->NAME, "", $gv->NAME], "formdef");
+ }
+}
+
+sub xref_definitions {
+ my ($pack, %exclude);
+ return if $nodefs;
+ $subname = "(definitions)";
+ foreach $pack (qw(B O AutoLoader DynaLoader Config DB VMS
+ strict vars FileHandle Exporter Carp)) {
+ $exclude{$pack."::"} = 1;
+ }
+ no strict qw(vars refs);
+ walksymtable(\%{"main::"}, "xref", sub { !defined($exclude{$_[0]}) });
+}
+
+sub output {
+ return if $raw;
+ my ($file, $subname, $pack, $name, $ev, $perfile, $persubname,
+ $perpack, $pername, $perev);
+ foreach $file (sort(keys(%table))) {
+ $perfile = $table{$file};
+ print "File $file\n";
+ foreach $subname (sort(keys(%$perfile))) {
+ $persubname = $perfile->{$subname};
+ print " Subroutine $subname\n";
+ foreach $pack (sort(keys(%$persubname))) {
+ $perpack = $persubname->{$pack};
+ print " Package $pack\n";
+ foreach $name (sort(keys(%$perpack))) {
+ $pername = $perpack->{$name};
+ my @lines;
+ foreach $ev (qw(intro formdef subdef meth subused used)) {
+ $perev = $pername->{$ev};
+ if (defined($perev) && @$perev) {
+ my $code = $code{$ev};
+ push(@lines, map("$code$_", @$perev));
+ }
+ }
+ printf " %-16s %s\n", $name, join(", ", @lines);
+ }
+ }
+ }
+ }
+}
+
+sub compile {
+ my @options = @_;
+ my ($option, $opt, $arg);
+ OPTION:
+ while ($option = shift @options) {
+ if ($option =~ /^-(.)(.*)/) {
+ $opt = $1;
+ $arg = $2;
+ } else {
+ unshift @options, $option;
+ last OPTION;
+ }
+ if ($opt eq "-" && $arg eq "-") {
+ shift @options;
+ last OPTION;
+ } elsif ($opt eq "o") {
+ $arg ||= shift @options;
+ open(STDOUT, ">$arg") or return "$arg: $!\n";
+ } elsif ($opt eq "d") {
+ $nodefs = 1;
+ } elsif ($opt eq "r") {
+ $raw = 1;
+ } elsif ($opt eq "D") {
+ $arg ||= shift @options;
+ foreach $arg (split(//, $arg)) {
+ if ($arg eq "o") {
+ B->debug(1);
+ } elsif ($arg eq "O") {
+ $debug_op = 1;
+ } elsif ($arg eq "t") {
+ $debug_top = 1;
+ }
+ }
+ }
+ }
+ if (@options) {
+ return sub {
+ my $objname;
+ xref_definitions();
+ foreach $objname (@options) {
+ $objname = "main::$objname" unless $objname =~ /::/;
+ eval "xref_object(\\&$objname)";
+ die "xref_object(\\&$objname) failed: $@" if $@;
+ }
+ output();
+ }
+ } else {
+ return sub {
+ xref_definitions();
+ xref_main();
+ output();
+ }
+ }
+}
+
+1;
--- /dev/null
+ GNU GENERAL PUBLIC LICENSE
+ Version 1, February 1989
+
+ Copyright (C) 1989 Free Software Foundation, Inc.
+ 675 Mass Ave, Cambridge, MA 02139, USA
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+ Preamble
+
+ The license agreements of most software companies try to keep users
+at the mercy of those companies. By contrast, our General Public
+License is intended to guarantee your freedom to share and change free
+software--to make sure the software is free for all its users. The
+General Public License applies to the Free Software Foundation's
+software and to any other program whose authors commit to using it.
+You can use it for your programs, too.
+
+ When we speak of free software, we are referring to freedom, not
+price. Specifically, the General Public License is designed to make
+sure that you have the freedom to give away or sell copies of free
+software, that you receive source code or can get it if you want it,
+that you can change the software or use pieces of it in new free
+programs; and that you know you can do these things.
+
+ To protect your rights, we need to make restrictions that forbid
+anyone to deny you these rights or to ask you to surrender the rights.
+These restrictions translate to certain responsibilities for you if you
+distribute copies of the software, or if you modify it.
+
+ For example, if you distribute copies of a such a program, whether
+gratis or for a fee, you must give the recipients all the rights that
+you have. You must make sure that they, too, receive or can get the
+source code. And you must tell them their rights.
+
+ We protect your rights with two steps: (1) copyright the software, and
+(2) offer you this license which gives you legal permission to copy,
+distribute and/or modify the software.
+
+ Also, for each author's protection and ours, we want to make certain
+that everyone understands that there is no warranty for this free
+software. If the software is modified by someone else and passed on, we
+want its recipients to know that what they have is not the original, so
+that any problems introduced by others will not reflect on the original
+authors' reputations.
+
+ The precise terms and conditions for copying, distribution and
+modification follow.
+\f
+ GNU GENERAL PUBLIC LICENSE
+ TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+ 0. This License Agreement applies to any program or other work which
+contains a notice placed by the copyright holder saying it may be
+distributed under the terms of this General Public License. The
+"Program", below, refers to any such program or work, and a "work based
+on the Program" means either the Program or any work containing the
+Program or a portion of it, either verbatim or with modifications. Each
+licensee is addressed as "you".
+
+ 1. You may copy and distribute verbatim copies of the Program's source
+code as you receive it, in any medium, provided that you conspicuously and
+appropriately publish on each copy an appropriate copyright notice and
+disclaimer of warranty; keep intact all the notices that refer to this
+General Public License and to the absence of any warranty; and give any
+other recipients of the Program a copy of this General Public License
+along with the Program. You may charge a fee for the physical act of
+transferring a copy.
+
+ 2. You may modify your copy or copies of the Program or any portion of
+it, and copy and distribute such modifications under the terms of Paragraph
+1 above, provided that you also do the following:
+
+ a) cause the modified files to carry prominent notices stating that
+ you changed the files and the date of any change; and
+
+ b) cause the whole of any work that you distribute or publish, that
+ in whole or in part contains the Program or any part thereof, either
+ with or without modifications, to be licensed at no charge to all
+ third parties under the terms of this General Public License (except
+ that you may choose to grant warranty protection to some or all
+ third parties, at your option).
+
+ c) If the modified program normally reads commands interactively when
+ run, you must cause it, when started running for such interactive use
+ in the simplest and most usual way, to print or display an
+ announcement including an appropriate copyright notice and a notice
+ that there is no warranty (or else, saying that you provide a
+ warranty) and that users may redistribute the program under these
+ conditions, and telling the user how to view a copy of this General
+ Public License.
+
+ d) You may charge a fee for the physical act of transferring a
+ copy, and you may at your option offer warranty protection in
+ exchange for a fee.
+
+Mere aggregation of another independent work with the Program (or its
+derivative) on a volume of a storage or distribution medium does not bring
+the other work under the scope of these terms.
+\f
+ 3. You may copy and distribute the Program (or a portion or derivative of
+it, under Paragraph 2) in object code or executable form under the terms of
+Paragraphs 1 and 2 above provided that you also do one of the following:
+
+ a) accompany it with the complete corresponding machine-readable
+ source code, which must be distributed under the terms of
+ Paragraphs 1 and 2 above; or,
+
+ b) accompany it with a written offer, valid for at least three
+ years, to give any third party free (except for a nominal charge
+ for the cost of distribution) a complete machine-readable copy of the
+ corresponding source code, to be distributed under the terms of
+ Paragraphs 1 and 2 above; or,
+
+ c) accompany it with the information you received as to where the
+ corresponding source code may be obtained. (This alternative is
+ allowed only for noncommercial distribution and only if you
+ received the program in object code or executable form alone.)
+
+Source code for a work means the preferred form of the work for making
+modifications to it. For an executable file, complete source code means
+all the source code for all modules it contains; but, as a special
+exception, it need not include source code for modules which are standard
+libraries that accompany the operating system on which the executable
+file runs, or for standard header files or definitions files that
+accompany that operating system.
+
+ 4. You may not copy, modify, sublicense, distribute or transfer the
+Program except as expressly provided under this General Public License.
+Any attempt otherwise to copy, modify, sublicense, distribute or transfer
+the Program is void, and will automatically terminate your rights to use
+the Program under this License. However, parties who have received
+copies, or rights to use copies, from you under this General Public
+License will not have their licenses terminated so long as such parties
+remain in full compliance.
+
+ 5. By copying, distributing or modifying the Program (or any work based
+on the Program) you indicate your acceptance of this license to do so,
+and all its terms and conditions.
+
+ 6. Each time you redistribute the Program (or any work based on the
+Program), the recipient automatically receives a license from the original
+licensor to copy, distribute or modify the Program subject to these
+terms and conditions. You may not impose any further restrictions on the
+recipients' exercise of the rights granted herein.
+\f
+ 7. The Free Software Foundation may publish revised and/or new versions
+of the General Public License from time to time. Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+Each version is given a distinguishing version number. If the Program
+specifies a version number of the license which applies to it and "any
+later version", you have the option of following the terms and conditions
+either of that version or of any later version published by the Free
+Software Foundation. If the Program does not specify a version number of
+the license, you may choose any version ever published by the Free Software
+Foundation.
+
+ 8. If you wish to incorporate parts of the Program into other free
+programs whose distribution conditions are different, write to the author
+to ask for permission. For software which is copyrighted by the Free
+Software Foundation, write to the Free Software Foundation; we sometimes
+make exceptions for this. Our decision will be guided by the two goals
+of preserving the free status of all derivatives of our free software and
+of promoting the sharing and reuse of software generally.
+
+ NO WARRANTY
+
+ 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
+REPAIR OR CORRECTION.
+
+ 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGES.
+
+ END OF TERMS AND CONDITIONS
+\f
+ Appendix: How to Apply These Terms to Your New Programs
+
+ If you develop a new program, and you want it to be of the greatest
+possible use to humanity, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these
+terms.
+
+ To do so, attach the following notices to the program. It is safest to
+attach them to the start of each source file to most effectively convey
+the exclusion of warranty; and each file should have at least the
+"copyright" line and a pointer to where the full notice is found.
+
+ <one line to give the program's name and a brief idea of what it does.>
+ Copyright (C) 19yy <name of author>
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 1, or (at your option)
+ any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+Also add information on how to contact you by electronic and paper mail.
+
+If the program is interactive, make it output a short notice like this
+when it starts in an interactive mode:
+
+ Gnomovision version 69, Copyright (C) 19xx name of author
+ Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+ This is free software, and you are welcome to redistribute it
+ under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the
+appropriate parts of the General Public License. Of course, the
+commands you use may be called something other than `show w' and `show
+c'; they could even be mouse-clicks or menu items--whatever suits your
+program.
+
+You should also get your employer (if you work as a programmer) or your
+school, if any, to sign a "copyright disclaimer" for the program, if
+necessary. Here a sample; alter the names:
+
+ Yoyodyne, Inc., hereby disclaims all copyright interest in the
+ program `Gnomovision' (a program to direct compilers to make passes
+ at assemblers) written by James Hacker.
+
+ <signature of Ty Coon>, 1 April 1989
+ Ty Coon, President of Vice
+
+That's all there is to it!
--- /dev/null
+use ExtUtils::MakeMaker;
+use Config;
+
+WriteMakefile(
+ NAME => "B",
+ VERSION => "a2",
+ MAP_TARGET => "bperl",
+ OBJECT => "B.o ccop.o byterun.o",
+ depend => {
+ "B.o" => "B.c ccop.h bytecode.h byterun.h",
+ "ccop.o" => "ccop.c ccop.h"
+ },
+ clean => {
+ FILES => "bperl byteperl btest btest.c *.o B.c *~"
+ }
+);
+
+sub MY::post_constants {
+ "\nLIBS = $Config{libs}\n"
+}
+
+sub MY::top_targets {
+ my $self = shift;
+ my $targets = $self->MM::top_targets();
+ $targets =~ s/^(all ::.*)$/$1 byteperl/m;
+ return <<'EOT' . $targets;
+#
+# byterun.h, byterun.c and Asmdata.pm are auto-generated. If any of the
+# files are missing or if you change bytecode.pl (which is what generates
+# them all) then you can "make regen_headers" to regenerate them.
+#
+regen_headers:
+ $(PERL) bytecode.pl
+ $(MV) Asmdata.pm B
+#
+# byteperl is *not* a standard perl+XSUB executable. It's a special
+# program for running standalone bytecode executables. It isn't an XSUB
+# at the moment because a standlone Perl program needs to set up curpad
+# which is overwritten on exit from an XSUB.
+#
+byteperl: byteperl.o B.o ccop.o byterun.o
+ $(CC) -o byteperl byteperl.o B.o ccop.o byterun.o $(LDFLAGS) -L$(PERL_ARCHLIB)/CORE -lperl $(LIBS)
+EOT
+}
--- /dev/null
+C backend invocation
+ If there are any non-option arguments, they are taken to be
+ names of objects to be saved (probably doesn't work properly yet).
+ Without extra arguments, it saves the main program.
+ -ofilename Output to filename instead of STDOUT
+ -v Verbose (currently gives a few compilation statistics)
+ -- Force end of options
+ -uPackname Force apparently unused subs from package Packname to
+ be compiled. This allows programs to use eval "foo()"
+ even when sub foo is never seen to be used at compile
+ time. The down side is that any subs which really are
+ never used also have code generated. This option is
+ necessary, for example, if you have a signal handler
+ foo which you initialise with $SIG{BAR} = "foo".
+ A better fix, though, is just to change it to
+ $SIG{BAR} = \&foo. You can have multiple -u options.
+ -D Debug options (concat or separate flags like perl -D)
+ o OPs, prints each OP as it's processed
+ c COPs, prints COPs as processed (incl. file & line num)
+ A prints AV information on saving
+ C prints CV information on saving
+ M prints MAGIC information on saving
+ -f Force optimisations on or off one at a time.
+ cog Copy-on-grow: PVs declared and initialised statically
+ no-cog No copy-on-grow
+ -On Optimisation level (n = 0, 1, 2, ...). -O means -O1.
+ Currently, -O1 and higher set -fcog.
+
+Examples
+ perl -MO=C foo.pl > foo.c
+ perl cc_harness -o foo foo.c
+
+ perl -MO=C,-v,-DcA bar.pl > /dev/null
+
+CC backend invocation
+ If there are any non-option arguments, they are taken to be names of
+ subs to be saved. Without extra arguments, it saves the main program.
+ -ofilename Output to filename instead of STDOUT
+ -- Force end of options
+ -uPackname Force apparently unused subs from package Packname to
+ be compiled. This allows programs to use eval "foo()"
+ even when sub foo is never seen to be used at compile
+ time. The down side is that any subs which really are
+ never used also have code generated. This option is
+ necessary, for example, if you have a signal handler
+ foo which you initialise with $SIG{BAR} = "foo".
+ A better fix, though, is just to change it to
+ $SIG{BAR} = \&foo. You can have multiple -u options.
+ -D Debug options (concat or separate flags like perl -D)
+ r Writes debugging output to STDERR just as it's about
+ to write to the program's runtime (otherwise writes
+ debugging info as comments in its C output).
+ O Outputs each OP as it's compiled
+ s Outputs the contents of the shadow stack at each OP
+ p Outputs the contents of the shadow pad of lexicals as
+ it's loaded for each sub or the main program.
+ q Outputs the name of each fake PP function in the queue
+ as it's about to processes.
+ l Output the filename and line number of each original
+ line of Perl code as it's processed (pp_nextstate).
+ t Outputs timing information of compilation stages
+ -f Force optimisations on or off one at a time.
+ [
+ cog Copy-on-grow: PVs declared and initialised statically
+ no-cog No copy-on-grow
+ These two not in CC yet.
+ ]
+ freetmps-each-bblock Delays FREETMPS from the end of each
+ statement to the end of the each basic
+ block.
+ freetmps-each-loop Delays FREETMPS from the end of each
+ statement to the end of the group of
+ basic blocks forming a loop. At most
+ one of the freetmps-each-* options can
+ be used.
+ omit-taint Omits generating code for handling
+ perl's tainting mechanism.
+ -On Optimisation level (n = 0, 1, 2, ...). -O means -O1.
+ Currently, -O1 sets -ffreetmps-each-bblock and -O2
+ sets -ffreetmps-each-loop.
+
+Example
+ perl -MO=CC,-O2,-ofoo.c foo.pl
+ perl cc_harness -o foo foo.c
+
+
+Bytecode backend invocation
+
+ If there are any non-option arguments, they are taken to be
+ names of objects to be saved (probably doesn't work properly yet).
+ Without extra arguments, it saves the main program.
+ -ofilename Output to filename instead of STDOUT.
+ -- Force end of options.
+ -f Force optimisations on or off one at a time.
+ Each can be preceded by no- to turn the option off.
+ compress-nullops
+ Only fills in the necessary fields of ops which have
+ been optimised away by perl's internal compiler.
+ omit-sequence-numbers
+ Leaves out code to fill in the op_seq field of all ops
+ which is only used by perl's internal compiler.
+ bypass-nullops
+ If op->op_next ever points to a NULLOP, replaces the
+ op_next field with the first non-NULLOP in the path
+ of execution.
+ strip-syntax-tree
+ Leaves out code to fill in the pointers which link the
+ internal syntax tree together. They're not needed at
+ run-time but leaving them out will make it impossible
+ to recompile or disassemble the resulting program.
+ It will also stop "goto label" statements from working.
+ -On Optimisation level (n = 0, 1, 2, ...). -O means -O1.
+ -O1 sets -fcompress-nullops -fomit-sequence numbers.
+ -O6 adds -fstrip-syntax-tree.
+ -D Debug options (concat or separate flags like perl -D)
+ o OPs, prints each OP as it's processed.
+ a tells the assembler to include source assembler lines
+ in its output as bytecode comments.
+ C prints each CV taken from the final symbol tree walk.
+ -S Output assembler source rather than piping it
+ through the assembler and outputting bytecode.
+ -m Compile as a module rather than a standalone program.
+ Currently this just means that the bytecodes for
+ initialising main_start, main_root and curpad are
+ omitted.
+
+Example
+ perl -MO=Bytecode,-O6,-o,foo.plc foo.pl
+
+ perl -MO=Bytecode,-S foo.pl > foo.S
+ assemble foo.S > foo.plc
+ byteperl foo.plc
+
+ perl -MO=Bytecode,-m,-oFoo.pmc Foo.pm
+
+Backends for debugging
+ perl -MO=Terse,exec foo.pl
+ perl -MO=Debug bar.pl
+
+O module
+ Used with "perl -MO=Backend,foo,bar prog.pl" to invoke the backend
+ B::Backend with options foo and bar. O invokes the sub
+ B::Backend::compile() with arguments foo and bar at BEGIN time.
+ That compile() sub must do any inital argument processing replied.
+ If unsuccessful, it should return a string which O arranges to be
+ printed as an error message followed by a clean error exit. In the
+ normal case where any option processing in compile() is successful,
+ it should return a sub ref (usually a closure) to perform the
+ actual compilation. When O regains control, it ensures that the
+ "-c" option is forced (so that the program being compiled doesn't
+ end up running) and registers an END block to call back the sub ref
+ returned from the backend's compile(). Perl then continues by
+ parsing prog.pl (just as it would with "perl -c prog.pl") and after
+ doing so, assuming there are no parse-time errors, the END block
+ of O gets called and the actual backend compilation happens. Phew.
--- /dev/null
+package O;
+use B qw(minus_c);
+use Carp;
+
+my $compilesub;
+
+sub import {
+ my ($class, $backend, @options) = @_;
+ eval "use B::$backend ()";
+ if ($@) {
+ croak "use of backend $backend failed: $@";
+ }
+ $compilesub = &{"B::${backend}::compile"}(@options);
+ if (ref($compilesub) eq "CODE") {
+ minus_c;
+ eval 'END { &$compilesub() }';
+ } else {
+ die $compilesub;
+ }
+}
+
+1;
+
--- /dev/null
+ Perl Compiler Kit, Version alpha3
+
+ Copyright (c) 1996, Malcolm Beattie
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of either:
+
+ a) the GNU General Public License as published by the Free
+ Software Foundation; either version 1, or (at your option) any
+ later version, or
+
+ b) the "Artistic License" which comes with this kit.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either
+ the GNU General Public License or the Artistic License for more details.
+
+ You should have received a copy of the Artistic License with this kit,
+ in the file named "Artistic". If not, you can get one from the Perl
+ distribution. You should also have received a copy of the GNU General
+ Public License, in the file named "Copying". If not, you can get one
+ from the Perl distribution or else write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+CHANGES
+
+New since alpha2
+ CC backend now supports ".." and s//e.
+ Xref backend generates cross-reference reports
+ Cleanups to fix benign but irritating "-w" warnings
+ Minor cxstack fix
+New since alpha1
+ Working CC backend
+ Shared globs and pre-initialised hash support
+ Some XSUB support
+ Assorted bug fixes
+
+INSTALLATION
+
+(1) You need perl5.002 or perl5.003.
+
+(2) If you want to compile and run programs with the C or CC backends
+which undefine (or redefine) subroutines, then you need to apply a
+one-line patch to perl itself. One or two of the programs in perl's
+own test suite do this. The patch is in file op.patch. It prevents
+perl from calling free() on OPs with the magic sequence number (U16)-1.
+The compiler declares all OPs as static structures and uses that magic
+sequence number.
+
+(3) Type
+ perl Makefile.PL
+to write a personalised Makefile for your system. If you want the
+bytecode modules to support reading bytecode from strings (instead of
+just from files) then add the option
+ -DINDIRECT_BGET_MACROS
+into the middle of the definition of the CCCMD macro in the Makefile.
+Your C compiler may need to be able to cope with Standard C for this.
+I haven't tested this option yet with an old pre-Standard compiler.
+
+(4) If your platform supports dynamic loading then just type
+ make
+and you can then use
+ perl -Iblib/arch -MO=foo bar baz
+to use the compiler modules (see later for details).
+If you need/want instead to make a statically linked perl which
+contains the appropriate modules, then type
+ make bperl
+ make byteperl
+and you can then use
+ ./bperl -MO=foo bar baz
+to use the compiler modules.
+In both cases, the byteperl executable is required for running standalone
+bytecode programs. It is *not* a standard perl+XSUB perl executable.
+
+USAGE
+
+As of the alpha3 release, the Bytecode, C and CC backends are now all
+functional enough to compile almost the whole of the main perl test
+suite. In the case of the CC backend, any failures are all due to
+differences and/or known bugs documented below. See the file TESTS.
+In the following examples, you'll need to replace "perl" by
+ perl -Iblib/arch
+if you have built the extensions for a dynamic loading platform but
+haven't installed the extensions completely. You'll need to replace
+"perl" by
+ ./bperl
+if you have built the extensions into a statically linked perl binary.
+
+(1) To compile perl program foo.pl with the C backend, do
+ perl -MO=C,-ofoo.c foo.pl
+Then use the cc_harness perl program to compile the resulting C source:
+ perl cc_harness -O2 -o foo foo.c
+
+If you are using a non-ANSI pre-Standard C compiler that can't handle
+pre-declaring static arrays, then add -DBROKEN_STATIC_REDECL to the
+options you use:
+ perl cc_harness -O2 -o foo -DBROKEN_STATIC_REDECL foo.c
+If you are using a non-ANSI pre-Standard C compiler that can't handle
+static initialisation of structures with union members then add
+-DBROKEN_UNION_INIT to the options you use. If you want command line
+arguments passed to your executable to be interpreted by perl (e.g. -Dx)
+then compile foo.c with -DALLOW_PERL_OPTIONS. Otherwise, all command line
+arguments passed to foo will appear directly in @ARGV. The resulting
+executable foo is the compiled version of foo.pl. See the file NOTES for
+extra options you can pass to -MO=C.
+
+There are some constraints on the contents on foo.pl if you want to be
+able to compile it successfully. Some problems can be fixed fairly easily
+by altering foo.pl; some problems with the compiler are known to be
+straightforward to solve and I'll do so soon. The file Todo lists a
+number of known problems. See the XSUB section lower down for information
+about compiling programs which use XSUBs.
+
+(2) To compile foo.pl with the CC backend (which generates actual
+optimised C code for the execution path of your perl program), use
+ perl -MO=CC,-ofoo.c foo.pl
+
+and proceed just as with the C backend. You should almost certainly
+use an option such as -O2 with the subsequent cc_harness invocation
+so that your C compiler uses optimisation. The C code generated by
+the Perl compiler's CC backend looks ugly to humans but is easily
+optimised by C compilers.
+
+To make the most of this compiler backend, you need to tell the
+compiler when you're using int or double variables so that it can
+optimise appropriately (although this part of the compiler is the most
+buggy). You currently do that by naming lexical variables ending in
+"_i" for ints, "_d" for doubles, "_ir" for int "register" variables or
+"_dr" for double "register" variables. Here "register" is a promise
+that you won't pass a reference to the variable into a sub which then
+modifies the variable. The compiler ought to catch attempts to use
+"\$i" just as C compilers catch attempts to do "&i" for a register int
+i but it doesn't at the moment. Bugs in the CC backend may make your
+program fail in mysterious ways and give wrong answers rather than just
+crash in boring ways. But, hey, this is an alpha release so you knew
+that anyway. See the XSUB section lower down for information about
+compiling programs which use XSUBs.
+
+If your program uses classes which define methods (or other subs which
+are not exported and not apparently used until runtime) then you'll
+need to use -u compile-time options (see the NOTES file) to force the
+subs to be compiled. Future releases will probably default the other
+way, do more auto-detection and provide more fine-grained control.
+
+Since compiled executables need linking with libperl, you may want
+to turn libperl.a into a shared library if your platform supports
+it. For example, with Digital UNIX, do something like
+ ld -shared -o libperl.so -all libperl.a -none -lc
+and with Linux/ELF, rebuild the perl .c files with -fPIC (and I
+also suggest -fomit-frame-pointer for Linux on Intel architetcures),
+do "Make libperl.a" and then do
+ gcc -shared -Wl,-soname,libperl.so.5 -o libperl.so.5.3 `ar t libperl.a`
+and then
+ # cp libperl.so.5.3 /usr/lib
+ # cd /usr/lib
+ # ln -s libperl.so.5.3 libperl.so.5
+ # ln -s libperl.so.5 libperl.so
+ # ldconfig
+When you compile perl executables with cc_harness, append -L/usr/lib
+otherwise the -L for the perl source directory will override it. For
+example,
+ perl -Iblib/arch -MO=CC,-O2,-ofoo3.c foo3.bench
+ perl cc_harness -o foo3 -O2 foo3.c -L/usr/lib
+ ls -l foo3
+ -rwxr-xr-x 1 mbeattie xzdg 11218 Jul 1 15:28 foo3
+You'll probably also want to link your main perl executable against
+libperl.so; it's nice having an 11K perl executable.
+
+(3) To compile foo.pl into bytecode do
+ perl -MO=Bytecode,-ofoo foo.pl
+To run the resulting bytecode file foo as a standalone program, you
+use the program byteperl which should have been built along with the
+extensions.
+ ./byteperl foo
+Any extra arguments are passed in as @ARGV; they are not interpreted
+as perl options. If you want to load chunks of bytecode into an already
+running perl program then use the -m option and investigate the
+byteload_fh and byteload_string functions exported by the B module.
+See the NOTES file for details of these and other options (including
+optimisation options and ways of getting at the intermediate "assembler"
+code that the Bytecode backend uses).
+
+(3) There are little Bourne shell scripts and perl programs to aid with
+some common operations: assemble, disassemble, run_bytecode_test,
+run_test, cc_harness, test_harness, test_harness_bytecode.
+
+(4) Walk the op tree in execution order printing terse info about each op
+ perl -MO=Terse,exec foo.pl
+
+(5) Walk the op tree in syntax order printing lengthier debug info about
+each op. You can also append ",exec" to walk in execution order, but the
+formatting is designed to look nice with Terse rather than Debug.
+ perl -MO=Debug foo.pl
+
+(6) Produce a cross-reference report of the line numbers at which all
+variables, subs and formats are defined and used.
+ perl -MO=Xref foo.pl
+
+XSUBS
+
+The C and CC backends can successfully compile some perl programs which
+make use of XSUB extensions. [I'll add more detail to this section in a
+later release.] As a prerequisite, such extensions must not need to do
+anything in their BOOT: section which needs to be done at runtime rather
+than compile time. Normally, the only code in the boot_Foo() function is
+a list of newXS() calls which xsubpp puts there and the compiler handles
+saving those XS subs itself. For each XSUB used, the C and CC compiler
+will generate an initialiser in their C output which refers to the name
+of the relevant C function (XS_Foo_somesub). What is not yet automated
+is the necessary commands and cc command-line options (e.g. via
+"perl cc_harness") which link against the extension libraries. For now,
+you need the XSUB extension to have installed files in the right format
+for using as C libraries (e.g. Foo.a or Foo.so). As the Foo.so files (or
+your platform's version) aren't suitable for linking against, you will
+have to reget the extension source and rebuild it as a static extension
+to force the generation of a suitable Foo.a file. Then you need to make
+a symlink (or copy or rename) of that file into a libFoo.a suitable for
+cc linking. Then add the appropriate -L and -l options to your
+"perl cc_harness" command line to find and link against those libraries.
+You may also need to fix up some platform-dependent environment variable
+to ensure that linked-against .so files are found at runtime too.
+
+DIFFERENCES
+
+The result of running a compiled Perl program can sometimes be different
+from running the same program with standard perl. Think of the compiler
+as having a slightly different implementation of the language Perl.
+Unfortunately, since Perl has had a single implementation until now,
+there are no formal standards or documents defining what behaviour is
+guaranteed of Perl the language and what just "happens to work".
+Some of the differences below are almost impossible to change because of
+the way the compiler works. Others can be changed to produce "standard"
+perl behaviour if it's deemed proper and the resulting performance hit
+is accepted. I'll use "standard perl" to mean the result of running a
+Perl program using the perl executable from the perl distribution.
+I'll use "compiled Perl program" to mean running an executable produced
+by this compiler kit ("the compiler") with the CC backend.
+
+Loops
+ Standard perl calculates the target of "next", "last", and "redo"
+ at run-time. The compiler calculates the targets at compile-time.
+ For example, the program
+
+ sub skip_on_odd { next NUMBER if $_[0] % 2 }
+ NUMBER: for ($i = 0; $i < 5; $i++) {
+ skip_on_odd($i);
+ print $i;
+ }
+
+ produces the output
+ 024
+ with standard perl but gives a compile-time error with the compiler.
+
+Context of ".."
+ The context (scalar or array) of the ".." operator determines whether
+ it behaves as a range or a flip/flop. Standard perl delays until
+ runtime the decision of which context it is in but the compiler needs
+ to know the context at compile-time. For example,
+ @a = (4,6,1,0,0,1);
+ sub range { (shift @a)..(shift @a) }
+ print range();
+ while (@a) { print scalar(range()) }
+ generates the output
+ 456123E0
+ with standard Perl but gives a compile-time error with compiled Perl.
+
+Arithmetic
+ Compiled Perl programs use native C arithemtic much more frequently
+ than standard perl. Operations on large numbers or on boundary
+ cases may produce different behaviour.
+
+Deprecated features
+ Features of standard perl such as $[ which have been deprecated
+ in standard perl since version 5 was released have not been
+ implemented in the compiler.
+
+Others
+ I'll add to this list as I remember what they are.
+
+BUGS
+
+Here are some things which may cause the compiler problems.
+
+The following render the compiler useless (without serious hacking):
+* Use of the DATA filehandle (via __END__ or __DATA__ tokens)
+* Operator overloading with %OVERLOAD
+* The (deprecated) magic array-offset variable $[ does not work
+* The following operators are not yet implemented for CC
+ goto
+ sort with a non-default comparison (i.e. a named sub or inline block)
+* You can't use "last" to exit from a non-loop block.
+
+The following may give significant problems:
+* BEGIN blocks containing complex initialisation code
+* Code which is only ever referred to at runtime (e.g. via eval "..." or
+ via method calls): see the -u option for the C and CC backends.
+* Run-time lookups of lexical variables in "outside" closures
+
+The following may cause problems (not thoroughly tested):
+* Dependencies on whether values of some "magic" Perl variables are
+ determined at compile-time or runtime.
+* For the C and CC backends: compile-time strings which are longer than
+ your C compiler can cope with in a single line or definition.
+* Reliance on intimate details of global destruction
+* For the Bytecode backend: high -On optimisation numbers with code
+ that has complex flow of control.
+* Any "-w" option in the first line of your perl program is seen and
+ acted on by perl itself before the compiler starts. The compiler
+ itself then runs with warnings turned on. This may cause perl to
+ print out warnings about the compiler itself since I haven't tested
+ it thoroughly with warnings turned on.
+
+There is a terser but more complete list in the Todo file.
+
+Malcolm Beattie
+2 September 1996
--- /dev/null
+Test results from compiling t/*/*.t
+ C Bytecode CC
+
+base/cond.t OK OK OK
+base/if.t OK OK OK
+base/lex.t OK OK OK
+base/pat.t OK OK OK
+base/term.t OK OK OK
+cmd/elsif.t OK OK OK
+cmd/for.t OK OK OK
+cmd/mod.t OK OK OK
+cmd/subval.t OK OK 1..34, not ok 27,28 (simply
+ because filename changes).
+cmd/switch.t OK OK OK
+cmd/while.t OK OK OK
+io/argv.t OK OK OK
+io/dup.t OK OK OK
+io/fs.t OK OK OK
+io/inplace.t OK OK OK
+io/pipe.t OK with -umain OK OK with -umain
+io/print.t OK OK OK
+io/tell.t OK OK OK
+op/append.t OK OK OK
+op/array.t OK OK 1..36, not ok 7,10 (no $[)
+op/auto.t OK OK OK
+op/chop.t OK OK OK
+op/cond.t OK OK OK
+op/delete.t OK OK OK
+op/do.t OK OK OK
+op/each.t OK OK OK
+op/eval.t OK OK OK
+op/exec.t OK OK OK
+op/exp.t OK OK OK
+op/flip.t OK OK OK
+op/fork.t OK OK OK
+op/glob.t OK OK OK
+op/goto.t OK OK 1..9, Can't find label label1.
+op/groups.t OK (s/ucb/bin/ under Linux) OK 1..0 for now.
+op/index.t OK OK OK
+op/int.t OK OK OK
+op/join.t OK OK OK
+op/list.t OK OK OK
+op/local.t OK OK OK
+op/magic.t OK OK OK with -umain
+op/misc.t no DATA filehandle so succeeds trivially with 1..0
+op/mkdir.t OK OK OK
+op/my.t OK OK OK
+op/oct.t OK OK OK (C large const warnings)
+op/ord.t OK OK OK
+op/overload.t Mostly not ok Mostly not ok C errors.
+op/pack.t OK OK OK
+op/pat.t OK OK OK
+op/push.t OK OK OK
+op/quotemeta.t OK OK OK
+op/rand.t OK OK OK
+op/range.t OK OK OK
+op/read.t OK OK OK
+op/readdir.t OK OK OK
+op/ref.t omits "ok 40" (lex destruction) OK (Bytecode)
+ CC: need -u for OBJ,BASEOBJ,
+ MYHASH,UNIVERSAL,WHATEVER,main
+ FINALE. 1..41, ok1-33,36-38,
+ then ok 41, ok 39.DESTROY probs
+op/regexp.t OK OK OK (trivially all eval'd)
+op/repeat.t OK OK OK
+op/sleep.t OK OK OK
+op/sort.t OK OK 1..10, ok 1, Out of memory!
+op/split.t OK OK OK
+op/sprintf.t OK OK OK
+op/stat.t OK OK OK
+op/study.t OK OK OK
+op/subst.t OK OK OK
+op/substr.t OK OK ok1-22 except 7-9,11 (all $[)
+op/time.t OK OK OK
+op/undef.t OK OK OK
+op/unshift.t OK OK OK
+op/vec.t OK OK OK
+op/write.t not ok 3 (no CvOUTSIDE lex from runtime eval). CC: 1..3, hang
--- /dev/null
+Test results from compiling t/*/*.t
+ C Bytecode CC
+
+base/cond.t OK OK OK
+base/if.t OK OK OK
+base/lex.t OK OK OK
+base/pat.t OK OK OK
+base/term.t OK OK OK
+cmd/elsif.t OK OK OK
+cmd/for.t OK OK C label used but not defined
+cmd/mod.t OK OK OK
+cmd/subval.t OK OK 1..34, not ok 27,28 (simply
+ because filename changes).
+cmd/switch.t OK OK OK
+cmd/while.t OK OK OK
+io/argv.t OK OK OK
+io/dup.t OK OK OK
+io/fs.t OK OK OK
+io/inplace.t OK OK OK
+io/pipe.t OK with -umain OK OK with -umain
+io/print.t OK OK OK
+io/tell.t OK OK OK
+op/append.t OK OK OK
+op/array.t OK OK 1..36, not ok 7,10 (no $[)
+op/auto.t OK OK OK
+op/chop.t OK OK OK
+op/cond.t OK OK OK
+op/delete.t OK OK OK
+op/do.t OK OK OK
+op/each.t OK OK OK
+op/eval.t OK OK OK
+op/exec.t OK OK OK
+op/exp.t OK OK OK
+op/flip.t OK OK 1..8, not ok 6, 7, nothing else
+op/fork.t OK OK OK
+op/glob.t OK OK OK
+op/goto.t OK OK 1..9, Can't find label label1.
+op/groups.t OK (s/ucb/bin/ under Linux) OK 1..0 for now.
+op/index.t OK OK OK
+op/int.t OK OK OK
+op/join.t OK OK OK
+op/list.t OK OK OK
+op/local.t OK OK OK
+op/magic.t OK OK OK with -umain
+op/misc.t no DATA filehandle so succeeds trivially with 1..0
+op/mkdir.t OK OK OK
+op/my.t OK OK OK
+op/oct.t OK OK OK (C large const warnings)
+op/ord.t OK OK OK
+op/overload.t Mostly not ok Mostly not ok C errors.
+op/pack.t OK OK OK
+op/pat.t OK OK OK
+op/push.t OK OK OK
+op/quotemeta.t OK OK OK
+op/rand.t OK OK OK
+op/range.t OK OK ok 1,3-8. not ok 2 (no pp_flip)
+op/read.t OK OK OK
+op/readdir.t OK OK OK
+op/ref.t omits "ok 40" (lex destruction) OK (Bytecode)
+ CC: need -u for OBJ,BASEOBJ,
+ MYHASH,UNIVERSAL,WHATEVER,main
+ FINALE. 1..41, ok1-33,36-38,
+ then ok 41, ok 39.DESTROY probs
+op/regexp.t OK OK OK (trivially all eval'd)
+op/repeat.t OK OK OK
+op/sleep.t OK OK OK
+op/sort.t OK OK 1..10, ok 1, Out of memory!
+op/split.t OK OK OK
+op/sprintf.t OK OK OK
+op/stat.t OK OK OK
+op/study.t OK OK OK
+op/subst.t OK OK C errors (s//e broken).
+op/substr.t OK OK ok1-22 except 7-9,11 (all $[)
+op/time.t OK OK OK
+op/undef.t OK OK OK
+op/unshift.t OK OK OK
+op/vec.t OK OK OK
+op/write.t not ok 3 (no CvOUTSIDE lex from runtime eval). CC: 1..3, hang
--- /dev/null
+* Fixes
+
+CC backend: goto, sort with non-default comparison. last for non-loop blocks.
+Version checking
+improve XSUB handling (both static and dynamic)
+sv_magic can do SvREFCNT_inc(obj) which messes up precalculated refcounts
+allocation of XPV[INAHC]V structures needs fixing: Perl tries to free
+them whereas the compiler expects them to be linked to a xpv[inahc]v_root
+list the same as X[IPR]V structures.
+ref counts
+perl_parse replacement
+fix cstring for long strings
+compile-time initialisation of AvARRAYs
+signed/unsigned problems with NV (and IV?) initialisation and elsewhere?
+CvOUTSIDE for ordinary subs
+DATA filehandle for standalone Bytecode program (easy)
+DATA filehandle for multiple bytecode-compiled modules (harder)
+DATA filehandle for C-compiled program (yet harder)
+
+* Features
+
+type checking
+compile time v. runtime initialisation
+save PMOPs in compiled form
+selection of what to dump
+options for cutting out line info etc.
+comment output
+shared constants
+module dependencies
+
+* Optimisations
+collapse LISTOPs to UNOPs or BASEOPs
+compile-time qw(), constant subs
+global analysis of variables, type hints etc.
+demand-loaded bytecode (leader of each basic block replaced by an op
+which loads in bytecode for its block)
+fast sub calls for CC backend
--- /dev/null
+#!./bperl
+use B::Assembler qw(assemble_fh);
+use FileHandle;
+
+my ($filename, $fh);
+
+if ($ARGV[0] eq "-d") {
+ B::Assembler::debug(1);
+ shift;
+}
+
+if (@ARGV == 0) {
+ $fh = \*STDIN;
+ $filename = "-";
+} elsif (@ARGV == 1) {
+ $filename = $ARGV[0];
+ $fh = new FileHandle "<$filename";
+} else {
+ die "Usage: assemble [filename]\n";
+}
+
+$SIG{__WARN__} = sub { warn "$filename:@_" };
+$SIG{__DIE__} = sub { die "$filename: @_" };
+assemble_fh($fh, sub { print @_ });
--- /dev/null
+typedef char *pvcontents;
+typedef char *strconst;
+typedef U32 PV;
+typedef char *op_tr_array;
+typedef int comment;
+typedef SV *svindex;
+typedef OP *opindex;
+typedef IV IV64;
+
+EXT int iv_overflows INIT(0);
+void *bset_obj_store _((void *, I32));
+void freadpv _((U32, void *));
+
+EXT SV *sv;
+EXT OP *op;
+EXT XPV pv;
+
+EXT void **obj_list;
+EXT I32 obj_list_fill INIT(-1);
+
+#ifdef INDIRECT_BGET_MACROS
+#define FREAD(argp, len, nelem) bs.fread((char*)(argp),(len),(nelem),bs.data)
+#define FGETC() bs.fgetc(bs.data)
+#else
+#define FREAD(argp, len, nelem) fread((argp), (len), (nelem), fp)
+#define FGETC() getc(fp)
+#endif /* INDIRECT_BGET_MACROS */
+
+#define BGET_U32(arg) FREAD(&arg, sizeof(U32), 1); arg = ntohl((U32)arg)
+#define BGET_I32(arg) FREAD(&arg, sizeof(I32), 1); arg = (I32)ntohl((U32)arg)
+#define BGET_U16(arg) FREAD(&arg, sizeof(U16), 1); arg = ntohs((U16)arg)
+#define BGET_U8(arg) arg = FGETC()
+
+#if INDIRECT_BGET_MACROS
+#define BGET_PV(arg) do { \
+ BGET_U32(arg); \
+ if (arg) \
+ bs.freadpv(arg, bs.data); \
+ else { \
+ pv.xpv_pv = 0; \
+ pv.xpv_len = 0; \
+ pv.xpv_cur = 0; \
+ } \
+ } while (0)
+#else
+#define BGET_PV(arg) do { \
+ BGET_U32(arg); \
+ if (arg) { \
+ New(666, pv.xpv_pv, arg, char); \
+ fread(pv.xpv_pv, 1, arg, fp); \
+ pv.xpv_len = arg; \
+ pv.xpv_cur = arg - 1; \
+ } else { \
+ pv.xpv_pv = 0; \
+ pv.xpv_len = 0; \
+ pv.xpv_cur = 0; \
+ } \
+ } while (0)
+#endif /* INDIRECT_BGET_MACROS */
+
+#define BGET_comment(arg) \
+ do { arg = FGETC(); } while (arg != '\n' && arg != EOF)
+
+/*
+ * In the following, sizeof(IV)*4 is just a way of encoding 32 on 64-bit-IV
+ * machines such that 32-bit machine compilers don't whine about the shift
+ * count being too high even though the code is never reached there.
+ */
+#define BGET_IV64(arg) do { \
+ U32 hi, lo; \
+ BGET_U32(hi); \
+ BGET_U32(lo); \
+ if (sizeof(IV) == 8) \
+ arg = (IV) (hi << (sizeof(IV)*4) | lo); \
+ else if (((I32)hi == -1 && (I32)lo < 0) \
+ || ((I32)hi == 0 && (I32)lo >= 0)) { \
+ arg = (I32)lo; \
+ } \
+ else { \
+ iv_overflows++; \
+ arg = 0; \
+ } \
+ } while (0)
+
+#define BGET_op_tr_array(arg) do { \
+ unsigned short *ary; \
+ int i; \
+ New(666, ary, 256, unsigned short); \
+ FREAD(ary, 256, 2); \
+ for (i = 0; i < 256; i++) \
+ ary[i] = ntohs(ary[i]); \
+ arg = (char *) ary; \
+ } while (0)
+
+#define BGET_pvcontents(arg) arg = pv.xpv_pv
+#define BGET_strconst(arg) do { \
+ for (arg = tokenbuf; (*arg = FGETC()); arg++) /* nothing */; \
+ arg = tokenbuf; \
+ } while (0)
+
+#define BGET_double(arg) do { \
+ char *str; \
+ BGET_strconst(str); \
+ arg = atof(str); \
+ } while (0)
+
+#define BGET_objindex(arg) do { \
+ U32 ix; \
+ BGET_U32(ix); \
+ arg = obj_list[ix]; \
+ } while (0)
+
+#define BSET_ldspecsv(sv, arg) sv = specialsv_list[arg]
+
+#define BSET_sv_refcnt_add(svrefcnt, arg) svrefcnt += arg
+#define BSET_gp_refcnt_add(gprefcnt, arg) gprefcnt += arg
+#define BSET_gp_share(sv, arg) do { \
+ gp_free((GV*)sv); \
+ GvGP(sv) = GvGP(arg); \
+ } while (0)
+
+#define BSET_gv_fetchpv(sv, arg) sv = (SV*)gv_fetchpv(arg, TRUE, SVt_PV)
+#define BSET_gv_stashpv(sv, arg) sv = (SV*)gv_stashpv(arg, TRUE)
+#define BSET_sv_magic(sv, arg) sv_magic(sv, Nullsv, arg, 0, 0)
+#define BSET_mg_pv(mg, arg) mg->mg_ptr = arg; mg->mg_len = pv.xpv_cur
+#define BSET_sv_upgrade(sv, arg) (void)SvUPGRADE(sv, arg)
+#define BSET_xpv(sv) do { \
+ SvPV_set(sv, pv.xpv_pv); \
+ SvCUR_set(sv, pv.xpv_cur); \
+ SvLEN_set(sv, pv.xpv_len); \
+ } while (0)
+#define BSET_av_extend(sv, arg) av_extend((AV*)sv, arg)
+
+#define BSET_av_push(sv, arg) av_push((AV*)sv, arg)
+#define BSET_hv_store(sv, arg) \
+ hv_store((HV*)sv, pv.xpv_pv, pv.xpv_cur, arg, 0)
+#define BSET_pv_free(pv) Safefree(pv.xpv_pv)
+#define BSET_pregcomp(op, arg) \
+ cPMOP->op_pmregexp = arg ? pregcomp(arg, arg + pv.xpv_cur, cPMOP) : 0
+#define BSET_newsv(sv, arg) sv = NEWSV(666,0); SvUPGRADE(sv, arg)
+#define BSET_newop(op, arg) op = (OP*)safemalloc(optype_size[arg])
+#define BSET_newopn(op, arg) do { \
+ OP *oldop = op; \
+ BSET_newop(op, arg); \
+ oldop->op_next = op; \
+ } while (0)
+
+#define BSET_ret(foo) return
+
+/*
+ * Kludge special-case workaround for OP_MAPSTART
+ * which needs the ppaddr for OP_GREPSTART. Blech.
+ */
+#define BSET_op_type(op, arg) do { \
+ op->op_type = arg; \
+ op->op_ppaddr = (arg != OP_MAPSTART) ? ppaddr[arg] : pp_grepstart; \
+ } while (0)
+#define BSET_op_ppaddr(op, arg) croak("op_ppaddr not yet implemented")
+#define BSET_curpad(pad, arg) pad = AvARRAY(arg)
+
+#define BSET_OBJ_STORE(obj, ix) \
+ (I32)ix > obj_list_fill ? \
+ bset_obj_store(obj, (I32)ix) : (obj_list[ix] = obj)
--- /dev/null
+use strict;
+my %alias_to = (
+ U32 => [qw(PADOFFSET STRLEN)],
+ I32 => [qw(SSize_t long)],
+ U16 => [qw(OPCODE line_t short)],
+ U8 => [qw(char)],
+ objindex => [qw(svindex opindex)]
+);
+
+my @optype= qw(OP UNOP BINOP LOGOP CONDOP LISTOP PMOP SVOP GVOP PVOP LOOP COP);
+
+# Nullsv *must* come first in the following so that the condition
+# ($$sv == 0) can continue to be used to test (sv == Nullsv).
+my @specialsv = qw(Nullsv &sv_undef &sv_yes &sv_no);
+
+my (%alias_from, $from, $tos);
+while (($from, $tos) = each %alias_to) {
+ map { $alias_from{$_} = $from } @$tos;
+}
+
+my $c_header = <<'EOT';
+/*
+ * Copyright (c) 1996 Malcolm Beattie
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+/*
+ * This file is autogenerated from bytecode.pl. Changes made here will be lost.
+ */
+EOT
+
+my $perl_header;
+($perl_header = $c_header) =~ s{[/ ]?\*/?}{#}g;
+
+if (-f "byterun.c") {
+ rename("byterun.c", "byterun.c.old");
+}
+if (-f "byterun.h") {
+ rename("byterun.h", "byterun.h.old");
+}
+if (-f "Asmdata.pm") {
+ rename("Asmdata.pm", "Asmdata.pm.old");
+}
+
+#
+# Start with boilerplate for Asmdata.pm
+#
+open(ASMDATA_PM, ">Asmdata.pm") or die "Asmdata.pm: $!";
+print ASMDATA_PM $perl_header, <<'EOT';
+package B::Asmdata;
+use Exporter;
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(%insn_data @insn_name @optype @specialsv_name);
+use vars qw(%insn_data @insn_name @optype @specialsv_name);
+
+EOT
+print ASMDATA_PM <<"EOT";
+\@optype = qw(@optype);
+\@specialsv_name = qw(@specialsv);
+
+# XXX insn_data is initialised this way because with a large
+# %insn_data = (foo => [...], bar => [...], ...) initialiser
+# I get a hard-to-track-down stack underflow and segfault.
+EOT
+
+#
+# Boilerplate for byterun.c
+#
+open(BYTERUN_C, ">byterun.c") or die "byterun.c: $!";
+print BYTERUN_C $c_header, <<'EOT';
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "bytecode.h"
+#include "byterun.h"
+
+#ifdef INDIRECT_BGET_MACROS
+void byterun(bs)
+struct bytestream bs;
+#else
+void byterun(fp)
+FILE *fp;
+#endif /* INDIRECT_BGET_MACROS */
+{
+ int insn;
+ while ((insn = FGETC()) != EOF) {
+ switch (insn) {
+EOT
+
+
+my (@insn_name, $insn_num, $insn, $lvalue, $argtype, $flags, $fundtype);
+
+while (<DATA>) {
+ chop;
+ s/#.*//; # remove comments
+ next unless length;
+ if (/^%number\s+(.*)/) {
+ $insn_num = $1;
+ next;
+ } elsif (/%enum\s+(.*?)\s+(.*)/) {
+ create_enum($1, $2); # must come before instructions
+ next;
+ }
+ ($insn, $lvalue, $argtype, $flags) = split;
+ $insn_name[$insn_num] = $insn;
+ $fundtype = $alias_from{$argtype} || $argtype;
+
+ #
+ # Add the case statement and code for the bytecode interpreter in byterun.c
+ #
+ printf BYTERUN_C "\t case INSN_%s:\t\t/* %d */\n\t {\n",
+ uc($insn), $insn_num;
+ my $optarg = $argtype eq "none" ? "" : ", arg";
+ if ($optarg) {
+ printf BYTERUN_C "\t\t$argtype arg;\n\t\tBGET_%s(arg);\n", $fundtype;
+ }
+ if ($flags =~ /x/) {
+ print BYTERUN_C "\t\tBSET_$insn($lvalue$optarg);\n";
+ } elsif ($flags =~ /s/) {
+ # Store instructions store to obj_list[arg]. "lvalue" field is rvalue.
+ print BYTERUN_C "\t\tBSET_OBJ_STORE($lvalue$optarg);\n";
+ }
+ elsif ($optarg && $lvalue ne "none") {
+ print BYTERUN_C "\t\t$lvalue = arg;\n";
+ }
+ print BYTERUN_C "\t\tbreak;\n\t }\n";
+
+ #
+ # Add the initialiser line for %insn_data in Asmdata.pm
+ #
+ print ASMDATA_PM <<"EOT";
+\$insn_data{$insn} = [$insn_num, \\&PUT_$fundtype, "GET_$fundtype"];
+EOT
+
+ # Find the next unused instruction number
+ do { $insn_num++ } while $insn_name[$insn_num];
+}
+
+#
+# Finish off byterun.c
+#
+print BYTERUN_C <<'EOT';
+ default:
+ croak("Illegal bytecode instruction %d\n", insn);
+ /* NOTREACHED */
+ }
+ }
+}
+EOT
+
+#
+# Write the instruction and optype enum constants into byterun.h
+#
+open(BYTERUN_H, ">byterun.h") or die "byterun.h: $!";
+print BYTERUN_H $c_header, <<'EOT';
+#ifdef INDIRECT_BGET_MACROS
+struct bytestream {
+ void *data;
+ int (*fgetc)(void *);
+ int (*fread)(char *, size_t, size_t, void*);
+ void (*freadpv)(U32, void*);
+};
+void freadpv _((U32, void *));
+void byterun _((struct bytestream));
+#else
+void byterun _((FILE *));
+#endif /* INDIRECT_BGET_MACROS */
+
+enum {
+EOT
+
+my $i = 0;
+my $add_enum_value = 0;
+my $max_insn;
+for ($i = 0; $i < @insn_name; $i++) {
+ $insn = uc($insn_name[$i]);
+ if (defined($insn)) {
+ $max_insn = $i;
+ if ($add_enum_value) {
+ print BYTERUN_H " INSN_$insn = $i,\t\t\t/* $i */\n";
+ $add_enum_value = 0;
+ } else {
+ print BYTERUN_H " INSN_$insn,\t\t\t/* $i */\n";
+ }
+ } else {
+ $add_enum_value = 1;
+ }
+}
+
+print BYTERUN_H " MAX_INSN = $max_insn\n};\n";
+
+print BYTERUN_H "\nenum {\n";
+for ($i = 0; $i < @optype - 1; $i++) {
+ printf BYTERUN_H " OPt_%s,\t\t/* %d */\n", $optype[$i], $i;
+}
+printf BYTERUN_H " OPt_%s\t\t/* %d */\n};\n\n", $optype[$i], $i;
+print BYTERUN_H <<'EOT';
+EXT int optype_size[]
+#ifdef DOINIT
+= {
+EOT
+for ($i = 0; $i < @optype - 1; $i++) {
+ printf BYTERUN_H " sizeof(%s),\n", $optype[$i], $i;
+}
+printf BYTERUN_H " sizeof(%s)\n}\n", $optype[$i], $i;
+print BYTERUN_H <<'EOT';
+#endif /* DOINIT */
+;
+
+EOT
+
+printf BYTERUN_H <<'EOT', scalar(@specialsv);
+EXT SV * specialsv_list[%d]
+#ifdef DOINIT
+EOT
+print BYTERUN_H "= { ", join(", ", @specialsv), " }\n";
+print BYTERUN_H <<'EOT';
+#endif /* DOINIT */
+;
+EOT
+
+#
+# Finish off insn_data and create array initialisers in Asmdata.pm
+#
+print ASMDATA_PM <<'EOT';
+
+my ($insn_name, $insn_data);
+while (($insn_name, $insn_data) = each %insn_data) {
+ $insn_name[$insn_data->[0]] = $insn_name;
+}
+# Fill in any gaps
+@insn_name = map($_ || "unused", @insn_name);
+
+1;
+EOT
+
+__END__
+# First set instruction ord("#") to read comment to end-of-line (sneaky)
+%number 35
+comment arg comment
+# Then make ord("\n") into a no-op
+%number 10
+nop none none
+# Now for the rest of the ordinary ones, beginning with \0 which is
+# ret so that \0-terminated strings can be read properly as bytecode.
+%number 0
+#
+#opcode lvalue argtype flags
+#
+ret none none x
+ldsv sv svindex
+ldop op opindex
+stsv sv U32 s
+stop op U32 s
+ldspecsv sv U8 x
+newsv sv U8 x
+newop op U8 x
+newopn op U8 x
+newpv none PV
+pv_cur pv.xpv_cur STRLEN
+pv_free pv none x
+sv_upgrade sv char x
+sv_refcnt SvREFCNT(sv) U32
+sv_refcnt_add SvREFCNT(sv) I32 x
+sv_flags SvFLAGS(sv) U32
+xrv SvRV(sv) svindex
+xpv sv none x
+xiv32 SvIVX(sv) I32
+xiv64 SvIVX(sv) IV64
+xnv SvNVX(sv) double
+xlv_targoff LvTARGOFF(sv) STRLEN
+xlv_targlen LvTARGLEN(sv) STRLEN
+xlv_targ LvTARG(sv) svindex
+xlv_type LvTYPE(sv) char
+xbm_useful BmUSEFUL(sv) I32
+xbm_previous BmPREVIOUS(sv) U16
+xbm_rare BmRARE(sv) U8
+xfm_lines FmLINES(sv) I32
+xio_lines IoLINES(sv) long
+xio_page IoPAGE(sv) long
+xio_page_len IoPAGE_LEN(sv) long
+xio_lines_left IoLINES_LEFT(sv) long
+xio_top_name IoTOP_NAME(sv) pvcontents
+xio_top_gv IoTOP_GV(sv) svindex
+xio_fmt_name IoFMT_NAME(sv) pvcontents
+xio_fmt_gv IoFMT_GV(sv) svindex
+xio_bottom_name IoBOTTOM_NAME(sv) pvcontents
+xio_bottom_gv IoBOTTOM_GV(sv) svindex
+xio_subprocess IoSUBPROCESS(sv) short
+xio_type IoTYPE(sv) char
+xio_flags IoFLAGS(sv) char
+xcv_stash *(SV**)&CvSTASH(sv) svindex
+xcv_start CvSTART(sv) opindex
+xcv_root CvROOT(sv) opindex
+xcv_gv CvGV(sv) svindex
+xcv_filegv CvFILEGV(sv) svindex
+xcv_depth CvDEPTH(sv) long
+xcv_padlist *(SV**)&CvPADLIST(sv) svindex
+xcv_outside *(SV**)&CvOUTSIDE(sv) svindex
+xcv_flags CvFLAGS(sv) U8
+av_extend sv SSize_t x
+av_push sv svindex x
+xav_fill AvFILL(sv) SSize_t
+xav_max AvMAX(sv) SSize_t
+xav_flags AvFLAGS(sv) U8
+xhv_riter HvRITER(sv) I32
+xhv_name HvNAME(sv) pvcontents
+hv_store sv svindex x
+sv_magic sv char x
+mg_obj SvMAGIC(sv)->mg_obj svindex
+mg_private SvMAGIC(sv)->mg_private U16
+mg_flags SvMAGIC(sv)->mg_flags U8
+mg_pv SvMAGIC(sv) pvcontents x
+xmg_stash *(SV**)&SvSTASH(sv) svindex
+gv_fetchpv sv strconst x
+gv_stashpv sv strconst x
+gp_sv GvSV(sv) svindex
+gp_refcnt GvREFCNT(sv) U32
+gp_refcnt_add GvREFCNT(sv) I32 x
+gp_av *(SV**)&GvAV(sv) svindex
+gp_hv *(SV**)&GvHV(sv) svindex
+gp_cv *(SV**)&GvCV(sv) svindex
+gp_filegv *(SV**)&GvFILEGV(sv) svindex
+gp_io *(SV**)&GvIOp(sv) svindex
+gp_form *(SV**)&GvFORM(sv) svindex
+gp_cvgen GvCVGEN(sv) U32
+gp_line GvLINE(sv) line_t
+gp_share sv svindex x
+xgv_flags GvFLAGS(sv) U8
+op_next op->op_next opindex
+op_sibling op->op_sibling opindex
+op_ppaddr op->op_ppaddr strconst x
+op_targ op->op_targ PADOFFSET
+op_type op OPCODE x
+op_seq op->op_seq U16
+op_flags op->op_flags U8
+op_private op->op_private U8
+op_first cUNOP->op_first opindex
+op_last cBINOP->op_last opindex
+op_other cLOGOP->op_other opindex
+op_true cCONDOP->op_true opindex
+op_false cCONDOP->op_false opindex
+op_children cLISTOP->op_children U32
+op_pmreplroot cPMOP->op_pmreplroot opindex
+op_pmreplrootgv *(SV**)&cPMOP->op_pmreplroot svindex
+op_pmreplstart cPMOP->op_pmreplstart opindex
+op_pmnext *(OP**)&cPMOP->op_pmnext opindex
+pregcomp op pvcontents x
+op_pmshort cPMOP->op_pmshort svindex
+op_pmflags cPMOP->op_pmflags U16
+op_pmpermflags cPMOP->op_pmpermflags U16
+op_pmslen cPMOP->op_pmslen char
+op_sv cSVOP->op_sv svindex
+op_gv cGVOP->op_gv svindex
+op_pv cPVOP->op_pv pvcontents
+op_pv_tr cPVOP->op_pv op_tr_array
+op_redoop cLOOP->op_redoop opindex
+op_nextop cLOOP->op_nextop opindex
+op_lastop cLOOP->op_lastop opindex
+cop_label cCOP->cop_label pvcontents
+cop_stash *(SV**)&cCOP->cop_stash svindex
+cop_filegv cCOP->cop_filegv svindex
+cop_seq cCOP->cop_seq U32
+cop_arybase cCOP->cop_arybase I32
+cop_line cCOP->cop_line line_t
+main_start main_start opindex
+main_root main_root opindex
+curpad curpad svindex x
--- /dev/null
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "byterun.h"
+
+#ifdef __cplusplus
+}
+# define EXTERN_C extern "C"
+#else
+# define EXTERN_C extern
+#endif
+
+static void xs_init _((void));
+static PerlInterpreter *my_perl;
+
+int
+#ifndef CAN_PROTOTYPE
+main(argc, argv, env)
+int argc;
+char **argv;
+char **env;
+#else /* def(CAN_PROTOTYPE) */
+main(int argc, char **argv, char **env)
+#endif /* def(CAN_PROTOTYPE) */
+{
+ int exitstatus;
+ int i;
+ char **fakeargv;
+ FILE *fp;
+#ifdef INDIRECT_BGET_MACROS
+ struct bytestream bs;
+#endif /* INDIRECT_BGET_MACROS */
+
+ PERL_SYS_INIT(&argc,&argv);
+
+#if PATCHLEVEL > 3 || (PATCHLEVEL == 3 && SUBVERSION >= 1)
+ perl_init_i18nl10n(1);
+#else
+ perl_init_i18nl14n(1);
+#endif
+
+ if (!do_undump) {
+ my_perl = perl_alloc();
+ if (!my_perl)
+ exit(1);
+ perl_construct( my_perl );
+ }
+
+ if (!cshlen)
+ cshlen = strlen(cshname);
+
+ if (argc < 2)
+ fp = stdin;
+ else {
+ fp = fopen(argv[1], "r");
+ if (!fp) {
+ perror(argv[1]);
+ exit(1);
+ }
+ argv++;
+ argc--;
+ }
+ New(666, fakeargv, argc + 4, char *);
+ fakeargv[0] = argv[0];
+ fakeargv[1] = "-e";
+ fakeargv[2] = "";
+ fakeargv[3] = "--";
+ for (i = 1; i < argc; i++)
+ fakeargv[i + 3] = argv[i];
+ fakeargv[argc + 3] = 0;
+
+ exitstatus = perl_parse(my_perl, xs_init, argc + 3, fakeargv, NULL);
+ if (exitstatus)
+ exit( exitstatus );
+
+ sv_setpv(GvSV(gv_fetchpv("0", TRUE, SVt_PV)), argv[0]);
+ main_cv = compcv;
+ compcv = 0;
+
+#ifdef INDIRECT_BGET_MACROS
+ bs.data = fp;
+ bs.fgetc = (int(*) _((void*)))fgetc;
+ bs.fread = (int(*) _((char*,size_t,size_t,void*)))fread;
+ bs.freadpv = freadpv;
+ byterun(bs);
+#else
+ byterun(fp);
+#endif /* INDIRECT_BGET_MACROS */
+
+ exitstatus = perl_run( my_perl );
+
+ perl_destruct( my_perl );
+ perl_free( my_perl );
+
+ exit( exitstatus );
+}
+
+static void
+xs_init()
+{
+}
--- /dev/null
+/*
+ * Copyright (c) 1996 Malcolm Beattie
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+/*
+ * This file is autogenerated from bytecode.pl. Changes made here will be lost.
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "bytecode.h"
+#include "byterun.h"
+
+#ifdef INDIRECT_BGET_MACROS
+void byterun(bs)
+struct bytestream bs;
+#else
+void byterun(fp)
+FILE *fp;
+#endif /* INDIRECT_BGET_MACROS */
+{
+ int insn;
+ while ((insn = FGETC()) != EOF) {
+ switch (insn) {
+ case INSN_COMMENT: /* 35 */
+ {
+ comment arg;
+ BGET_comment(arg);
+ arg = arg;
+ break;
+ }
+ case INSN_NOP: /* 10 */
+ {
+ break;
+ }
+ case INSN_RET: /* 0 */
+ {
+ BSET_ret(none);
+ break;
+ }
+ case INSN_LDSV: /* 1 */
+ {
+ svindex arg;
+ BGET_objindex(arg);
+ sv = arg;
+ break;
+ }
+ case INSN_LDOP: /* 2 */
+ {
+ opindex arg;
+ BGET_objindex(arg);
+ op = arg;
+ break;
+ }
+ case INSN_STSV: /* 3 */
+ {
+ U32 arg;
+ BGET_U32(arg);
+ BSET_OBJ_STORE(sv, arg);
+ break;
+ }
+ case INSN_STOP: /* 4 */
+ {
+ U32 arg;
+ BGET_U32(arg);
+ BSET_OBJ_STORE(op, arg);
+ break;
+ }
+ case INSN_LDSPECSV: /* 5 */
+ {
+ U8 arg;
+ BGET_U8(arg);
+ BSET_ldspecsv(sv, arg);
+ break;
+ }
+ case INSN_NEWSV: /* 6 */
+ {
+ U8 arg;
+ BGET_U8(arg);
+ BSET_newsv(sv, arg);
+ break;
+ }
+ case INSN_NEWOP: /* 7 */
+ {
+ U8 arg;
+ BGET_U8(arg);
+ BSET_newop(op, arg);
+ break;
+ }
+ case INSN_NEWOPN: /* 8 */
+ {
+ U8 arg;
+ BGET_U8(arg);
+ BSET_newopn(op, arg);
+ break;
+ }
+ case INSN_NEWPV: /* 9 */
+ {
+ PV arg;
+ BGET_PV(arg);
+ break;
+ }
+ case INSN_PV_CUR: /* 11 */
+ {
+ STRLEN arg;
+ BGET_U32(arg);
+ pv.xpv_cur = arg;
+ break;
+ }
+ case INSN_PV_FREE: /* 12 */
+ {
+ BSET_pv_free(pv);
+ break;
+ }
+ case INSN_SV_UPGRADE: /* 13 */
+ {
+ char arg;
+ BGET_U8(arg);
+ BSET_sv_upgrade(sv, arg);
+ break;
+ }
+ case INSN_SV_REFCNT: /* 14 */
+ {
+ U32 arg;
+ BGET_U32(arg);
+ SvREFCNT(sv) = arg;
+ break;
+ }
+ case INSN_SV_REFCNT_ADD: /* 15 */
+ {
+ I32 arg;
+ BGET_I32(arg);
+ BSET_sv_refcnt_add(SvREFCNT(sv), arg);
+ break;
+ }
+ case INSN_SV_FLAGS: /* 16 */
+ {
+ U32 arg;
+ BGET_U32(arg);
+ SvFLAGS(sv) = arg;
+ break;
+ }
+ case INSN_XRV: /* 17 */
+ {
+ svindex arg;
+ BGET_objindex(arg);
+ SvRV(sv) = arg;
+ break;
+ }
+ case INSN_XPV: /* 18 */
+ {
+ BSET_xpv(sv);
+ break;
+ }
+ case INSN_XIV32: /* 19 */
+ {
+ I32 arg;
+ BGET_I32(arg);
+ SvIVX(sv) = arg;
+ break;
+ }
+ case INSN_XIV64: /* 20 */
+ {
+ IV64 arg;
+ BGET_IV64(arg);
+ SvIVX(sv) = arg;
+ break;
+ }
+ case INSN_XNV: /* 21 */
+ {
+ double arg;
+ BGET_double(arg);
+ SvNVX(sv) = arg;
+ break;
+ }
+ case INSN_XLV_TARGOFF: /* 22 */
+ {
+ STRLEN arg;
+ BGET_U32(arg);
+ LvTARGOFF(sv) = arg;
+ break;
+ }
+ case INSN_XLV_TARGLEN: /* 23 */
+ {
+ STRLEN arg;
+ BGET_U32(arg);
+ LvTARGLEN(sv) = arg;
+ break;
+ }
+ case INSN_XLV_TARG: /* 24 */
+ {
+ svindex arg;
+ BGET_objindex(arg);
+ LvTARG(sv) = arg;
+ break;
+ }
+ case INSN_XLV_TYPE: /* 25 */
+ {
+ char arg;
+ BGET_U8(arg);
+ LvTYPE(sv) = arg;
+ break;
+ }
+ case INSN_XBM_USEFUL: /* 26 */
+ {
+ I32 arg;
+ BGET_I32(arg);
+ BmUSEFUL(sv) = arg;
+ break;
+ }
+ case INSN_XBM_PREVIOUS: /* 27 */
+ {
+ U16 arg;
+ BGET_U16(arg);
+ BmPREVIOUS(sv) = arg;
+ break;
+ }
+ case INSN_XBM_RARE: /* 28 */
+ {
+ U8 arg;
+ BGET_U8(arg);
+ BmRARE(sv) = arg;
+ break;
+ }
+ case INSN_XFM_LINES: /* 29 */
+ {
+ I32 arg;
+ BGET_I32(arg);
+ FmLINES(sv) = arg;
+ break;
+ }
+ case INSN_XIO_LINES: /* 30 */
+ {
+ long arg;
+ BGET_I32(arg);
+ IoLINES(sv) = arg;
+ break;
+ }
+ case INSN_XIO_PAGE: /* 31 */
+ {
+ long arg;
+ BGET_I32(arg);
+ IoPAGE(sv) = arg;
+ break;
+ }
+ case INSN_XIO_PAGE_LEN: /* 32 */
+ {
+ long arg;
+ BGET_I32(arg);
+ IoPAGE_LEN(sv) = arg;
+ break;
+ }
+ case INSN_XIO_LINES_LEFT: /* 33 */
+ {
+ long arg;
+ BGET_I32(arg);
+ IoLINES_LEFT(sv) = arg;
+ break;
+ }
+ case INSN_XIO_TOP_NAME: /* 34 */
+ {
+ pvcontents arg;
+ BGET_pvcontents(arg);
+ IoTOP_NAME(sv) = arg;
+ break;
+ }
+ case INSN_XIO_TOP_GV: /* 36 */
+ {
+ svindex arg;
+ BGET_objindex(arg);
+ IoTOP_GV(sv) = arg;
+ break;
+ }
+ case INSN_XIO_FMT_NAME: /* 37 */
+ {
+ pvcontents arg;
+ BGET_pvcontents(arg);
+ IoFMT_NAME(sv) = arg;
+ break;
+ }
+ case INSN_XIO_FMT_GV: /* 38 */
+ {
+ svindex arg;
+ BGET_objindex(arg);
+ IoFMT_GV(sv) = arg;
+ break;
+ }
+ case INSN_XIO_BOTTOM_NAME: /* 39 */
+ {
+ pvcontents arg;
+ BGET_pvcontents(arg);
+ IoBOTTOM_NAME(sv) = arg;
+ break;
+ }
+ case INSN_XIO_BOTTOM_GV: /* 40 */
+ {
+ svindex arg;
+ BGET_objindex(arg);
+ IoBOTTOM_GV(sv) = arg;
+ break;
+ }
+ case INSN_XIO_SUBPROCESS: /* 41 */
+ {
+ short arg;
+ BGET_U16(arg);
+ IoSUBPROCESS(sv) = arg;
+ break;
+ }
+ case INSN_XIO_TYPE: /* 42 */
+ {
+ char arg;
+ BGET_U8(arg);
+ IoTYPE(sv) = arg;
+ break;
+ }
+ case INSN_XIO_FLAGS: /* 43 */
+ {
+ char arg;
+ BGET_U8(arg);
+ IoFLAGS(sv) = arg;
+ break;
+ }
+ case INSN_XCV_STASH: /* 44 */
+ {
+ svindex arg;
+ BGET_objindex(arg);
+ *(SV**)&CvSTASH(sv) = arg;
+ break;
+ }
+ case INSN_XCV_START: /* 45 */
+ {
+ opindex arg;
+ BGET_objindex(arg);
+ CvSTART(sv) = arg;
+ break;
+ }
+ case INSN_XCV_ROOT: /* 46 */
+ {
+ opindex arg;
+ BGET_objindex(arg);
+ CvROOT(sv) = arg;
+ break;
+ }
+ case INSN_XCV_GV: /* 47 */
+ {
+ svindex arg;
+ BGET_objindex(arg);
+ CvGV(sv) = arg;
+ break;
+ }
+ case INSN_XCV_FILEGV: /* 48 */
+ {
+ svindex arg;
+ BGET_objindex(arg);
+ CvFILEGV(sv) = arg;
+ break;
+ }
+ case INSN_XCV_DEPTH: /* 49 */
+ {
+ long arg;
+ BGET_I32(arg);
+ CvDEPTH(sv) = arg;
+ break;
+ }
+ case INSN_XCV_PADLIST: /* 50 */
+ {
+ svindex arg;
+ BGET_objindex(arg);
+ *(SV**)&CvPADLIST(sv) = arg;
+ break;
+ }
+ case INSN_XCV_OUTSIDE: /* 51 */
+ {
+ svindex arg;
+ BGET_objindex(arg);
+ *(SV**)&CvOUTSIDE(sv) = arg;
+ break;
+ }
+ case INSN_XCV_FLAGS: /* 52 */
+ {
+ U8 arg;
+ BGET_U8(arg);
+ CvFLAGS(sv) = arg;
+ break;
+ }
+ case INSN_AV_EXTEND: /* 53 */
+ {
+ SSize_t arg;
+ BGET_I32(arg);
+ BSET_av_extend(sv, arg);
+ break;
+ }
+ case INSN_AV_PUSH: /* 54 */
+ {
+ svindex arg;
+ BGET_objindex(arg);
+ BSET_av_push(sv, arg);
+ break;
+ }
+ case INSN_XAV_FILL: /* 55 */
+ {
+ SSize_t arg;
+ BGET_I32(arg);
+ AvFILL(sv) = arg;
+ break;
+ }
+ case INSN_XAV_MAX: /* 56 */
+ {
+ SSize_t arg;
+ BGET_I32(arg);
+ AvMAX(sv) = arg;
+ break;
+ }
+ case INSN_XAV_FLAGS: /* 57 */
+ {
+ U8 arg;
+ BGET_U8(arg);
+ AvFLAGS(sv) = arg;
+ break;
+ }
+ case INSN_XHV_RITER: /* 58 */
+ {
+ I32 arg;
+ BGET_I32(arg);
+ HvRITER(sv) = arg;
+ break;
+ }
+ case INSN_XHV_NAME: /* 59 */
+ {
+ pvcontents arg;
+ BGET_pvcontents(arg);
+ HvNAME(sv) = arg;
+ break;
+ }
+ case INSN_HV_STORE: /* 60 */
+ {
+ svindex arg;
+ BGET_objindex(arg);
+ BSET_hv_store(sv, arg);
+ break;
+ }
+ case INSN_SV_MAGIC: /* 61 */
+ {
+ char arg;
+ BGET_U8(arg);
+ BSET_sv_magic(sv, arg);
+ break;
+ }
+ case INSN_MG_OBJ: /* 62 */
+ {
+ svindex arg;
+ BGET_objindex(arg);
+ SvMAGIC(sv)->mg_obj = arg;
+ break;
+ }
+ case INSN_MG_PRIVATE: /* 63 */
+ {
+ U16 arg;
+ BGET_U16(arg);
+ SvMAGIC(sv)->mg_private = arg;
+ break;
+ }
+ case INSN_MG_FLAGS: /* 64 */
+ {
+ U8 arg;
+ BGET_U8(arg);
+ SvMAGIC(sv)->mg_flags = arg;
+ break;
+ }
+ case INSN_MG_PV: /* 65 */
+ {
+ pvcontents arg;
+ BGET_pvcontents(arg);
+ BSET_mg_pv(SvMAGIC(sv), arg);
+ break;
+ }
+ case INSN_XMG_STASH: /* 66 */
+ {
+ svindex arg;
+ BGET_objindex(arg);
+ *(SV**)&SvSTASH(sv) = arg;
+ break;
+ }
+ case INSN_GV_FETCHPV: /* 67 */
+ {
+ strconst arg;
+ BGET_strconst(arg);
+ BSET_gv_fetchpv(sv, arg);
+ break;
+ }
+ case INSN_GV_STASHPV: /* 68 */
+ {
+ strconst arg;
+ BGET_strconst(arg);
+ BSET_gv_stashpv(sv, arg);
+ break;
+ }
+ case INSN_GP_SV: /* 69 */
+ {
+ svindex arg;
+ BGET_objindex(arg);
+ GvSV(sv) = arg;
+ break;
+ }
+ case INSN_GP_REFCNT: /* 70 */
+ {
+ U32 arg;
+ BGET_U32(arg);
+ GvREFCNT(sv) = arg;
+ break;
+ }
+ case INSN_GP_REFCNT_ADD: /* 71 */
+ {
+ I32 arg;
+ BGET_I32(arg);
+ BSET_gp_refcnt_add(GvREFCNT(sv), arg);
+ break;
+ }
+ case INSN_GP_AV: /* 72 */
+ {
+ svindex arg;
+ BGET_objindex(arg);
+ *(SV**)&GvAV(sv) = arg;
+ break;
+ }
+ case INSN_GP_HV: /* 73 */
+ {
+ svindex arg;
+ BGET_objindex(arg);
+ *(SV**)&GvHV(sv) = arg;
+ break;
+ }
+ case INSN_GP_CV: /* 74 */
+ {
+ svindex arg;
+ BGET_objindex(arg);
+ *(SV**)&GvCV(sv) = arg;
+ break;
+ }
+ case INSN_GP_FILEGV: /* 75 */
+ {
+ svindex arg;
+ BGET_objindex(arg);
+ *(SV**)&GvFILEGV(sv) = arg;
+ break;
+ }
+ case INSN_GP_IO: /* 76 */
+ {
+ svindex arg;
+ BGET_objindex(arg);
+ *(SV**)&GvIOp(sv) = arg;
+ break;
+ }
+ case INSN_GP_FORM: /* 77 */
+ {
+ svindex arg;
+ BGET_objindex(arg);
+ *(SV**)&GvFORM(sv) = arg;
+ break;
+ }
+ case INSN_GP_CVGEN: /* 78 */
+ {
+ U32 arg;
+ BGET_U32(arg);
+ GvCVGEN(sv) = arg;
+ break;
+ }
+ case INSN_GP_LINE: /* 79 */
+ {
+ line_t arg;
+ BGET_U16(arg);
+ GvLINE(sv) = arg;
+ break;
+ }
+ case INSN_GP_SHARE: /* 80 */
+ {
+ svindex arg;
+ BGET_objindex(arg);
+ BSET_gp_share(sv, arg);
+ break;
+ }
+ case INSN_XGV_FLAGS: /* 81 */
+ {
+ U8 arg;
+ BGET_U8(arg);
+ GvFLAGS(sv) = arg;
+ break;
+ }
+ case INSN_OP_NEXT: /* 82 */
+ {
+ opindex arg;
+ BGET_objindex(arg);
+ op->op_next = arg;
+ break;
+ }
+ case INSN_OP_SIBLING: /* 83 */
+ {
+ opindex arg;
+ BGET_objindex(arg);
+ op->op_sibling = arg;
+ break;
+ }
+ case INSN_OP_PPADDR: /* 84 */
+ {
+ strconst arg;
+ BGET_strconst(arg);
+ BSET_op_ppaddr(op->op_ppaddr, arg);
+ break;
+ }
+ case INSN_OP_TARG: /* 85 */
+ {
+ PADOFFSET arg;
+ BGET_U32(arg);
+ op->op_targ = arg;
+ break;
+ }
+ case INSN_OP_TYPE: /* 86 */
+ {
+ OPCODE arg;
+ BGET_U16(arg);
+ BSET_op_type(op, arg);
+ break;
+ }
+ case INSN_OP_SEQ: /* 87 */
+ {
+ U16 arg;
+ BGET_U16(arg);
+ op->op_seq = arg;
+ break;
+ }
+ case INSN_OP_FLAGS: /* 88 */
+ {
+ U8 arg;
+ BGET_U8(arg);
+ op->op_flags = arg;
+ break;
+ }
+ case INSN_OP_PRIVATE: /* 89 */
+ {
+ U8 arg;
+ BGET_U8(arg);
+ op->op_private = arg;
+ break;
+ }
+ case INSN_OP_FIRST: /* 90 */
+ {
+ opindex arg;
+ BGET_objindex(arg);
+ cUNOP->op_first = arg;
+ break;
+ }
+ case INSN_OP_LAST: /* 91 */
+ {
+ opindex arg;
+ BGET_objindex(arg);
+ cBINOP->op_last = arg;
+ break;
+ }
+ case INSN_OP_OTHER: /* 92 */
+ {
+ opindex arg;
+ BGET_objindex(arg);
+ cLOGOP->op_other = arg;
+ break;
+ }
+ case INSN_OP_TRUE: /* 93 */
+ {
+ opindex arg;
+ BGET_objindex(arg);
+ cCONDOP->op_true = arg;
+ break;
+ }
+ case INSN_OP_FALSE: /* 94 */
+ {
+ opindex arg;
+ BGET_objindex(arg);
+ cCONDOP->op_false = arg;
+ break;
+ }
+ case INSN_OP_CHILDREN: /* 95 */
+ {
+ U32 arg;
+ BGET_U32(arg);
+ cLISTOP->op_children = arg;
+ break;
+ }
+ case INSN_OP_PMREPLROOT: /* 96 */
+ {
+ opindex arg;
+ BGET_objindex(arg);
+ cPMOP->op_pmreplroot = arg;
+ break;
+ }
+ case INSN_OP_PMREPLROOTGV: /* 97 */
+ {
+ svindex arg;
+ BGET_objindex(arg);
+ *(SV**)&cPMOP->op_pmreplroot = arg;
+ break;
+ }
+ case INSN_OP_PMREPLSTART: /* 98 */
+ {
+ opindex arg;
+ BGET_objindex(arg);
+ cPMOP->op_pmreplstart = arg;
+ break;
+ }
+ case INSN_OP_PMNEXT: /* 99 */
+ {
+ opindex arg;
+ BGET_objindex(arg);
+ *(OP**)&cPMOP->op_pmnext = arg;
+ break;
+ }
+ case INSN_PREGCOMP: /* 100 */
+ {
+ pvcontents arg;
+ BGET_pvcontents(arg);
+ BSET_pregcomp(op, arg);
+ break;
+ }
+ case INSN_OP_PMSHORT: /* 101 */
+ {
+ svindex arg;
+ BGET_objindex(arg);
+ cPMOP->op_pmshort = arg;
+ break;
+ }
+ case INSN_OP_PMFLAGS: /* 102 */
+ {
+ U16 arg;
+ BGET_U16(arg);
+ cPMOP->op_pmflags = arg;
+ break;
+ }
+ case INSN_OP_PMPERMFLAGS: /* 103 */
+ {
+ U16 arg;
+ BGET_U16(arg);
+ cPMOP->op_pmpermflags = arg;
+ break;
+ }
+ case INSN_OP_PMSLEN: /* 104 */
+ {
+ char arg;
+ BGET_U8(arg);
+ cPMOP->op_pmslen = arg;
+ break;
+ }
+ case INSN_OP_SV: /* 105 */
+ {
+ svindex arg;
+ BGET_objindex(arg);
+ cSVOP->op_sv = arg;
+ break;
+ }
+ case INSN_OP_GV: /* 106 */
+ {
+ svindex arg;
+ BGET_objindex(arg);
+ cGVOP->op_gv = arg;
+ break;
+ }
+ case INSN_OP_PV: /* 107 */
+ {
+ pvcontents arg;
+ BGET_pvcontents(arg);
+ cPVOP->op_pv = arg;
+ break;
+ }
+ case INSN_OP_PV_TR: /* 108 */
+ {
+ op_tr_array arg;
+ BGET_op_tr_array(arg);
+ cPVOP->op_pv = arg;
+ break;
+ }
+ case INSN_OP_REDOOP: /* 109 */
+ {
+ opindex arg;
+ BGET_objindex(arg);
+ cLOOP->op_redoop = arg;
+ break;
+ }
+ case INSN_OP_NEXTOP: /* 110 */
+ {
+ opindex arg;
+ BGET_objindex(arg);
+ cLOOP->op_nextop = arg;
+ break;
+ }
+ case INSN_OP_LASTOP: /* 111 */
+ {
+ opindex arg;
+ BGET_objindex(arg);
+ cLOOP->op_lastop = arg;
+ break;
+ }
+ case INSN_COP_LABEL: /* 112 */
+ {
+ pvcontents arg;
+ BGET_pvcontents(arg);
+ cCOP->cop_label = arg;
+ break;
+ }
+ case INSN_COP_STASH: /* 113 */
+ {
+ svindex arg;
+ BGET_objindex(arg);
+ *(SV**)&cCOP->cop_stash = arg;
+ break;
+ }
+ case INSN_COP_FILEGV: /* 114 */
+ {
+ svindex arg;
+ BGET_objindex(arg);
+ cCOP->cop_filegv = arg;
+ break;
+ }
+ case INSN_COP_SEQ: /* 115 */
+ {
+ U32 arg;
+ BGET_U32(arg);
+ cCOP->cop_seq = arg;
+ break;
+ }
+ case INSN_COP_ARYBASE: /* 116 */
+ {
+ I32 arg;
+ BGET_I32(arg);
+ cCOP->cop_arybase = arg;
+ break;
+ }
+ case INSN_COP_LINE: /* 117 */
+ {
+ line_t arg;
+ BGET_U16(arg);
+ cCOP->cop_line = arg;
+ break;
+ }
+ case INSN_MAIN_START: /* 118 */
+ {
+ opindex arg;
+ BGET_objindex(arg);
+ main_start = arg;
+ break;
+ }
+ case INSN_MAIN_ROOT: /* 119 */
+ {
+ opindex arg;
+ BGET_objindex(arg);
+ main_root = arg;
+ break;
+ }
+ case INSN_CURPAD: /* 120 */
+ {
+ svindex arg;
+ BGET_objindex(arg);
+ BSET_curpad(curpad, arg);
+ break;
+ }
+ default:
+ croak("Illegal bytecode instruction %d\n", insn);
+ /* NOTREACHED */
+ }
+ }
+}
--- /dev/null
+/*
+ * Copyright (c) 1996 Malcolm Beattie
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+/*
+ * This file is autogenerated from bytecode.pl. Changes made here will be lost.
+ */
+#ifdef INDIRECT_BGET_MACROS
+struct bytestream {
+ void *data;
+ int (*fgetc)(void *);
+ int (*fread)(char *, size_t, size_t, void*);
+ void (*freadpv)(U32, void*);
+};
+void freadpv _((U32, void *));
+void byterun _((struct bytestream));
+#else
+void byterun _((FILE *));
+#endif /* INDIRECT_BGET_MACROS */
+
+enum {
+ INSN_RET, /* 0 */
+ INSN_LDSV, /* 1 */
+ INSN_LDOP, /* 2 */
+ INSN_STSV, /* 3 */
+ INSN_STOP, /* 4 */
+ INSN_LDSPECSV, /* 5 */
+ INSN_NEWSV, /* 6 */
+ INSN_NEWOP, /* 7 */
+ INSN_NEWOPN, /* 8 */
+ INSN_NEWPV, /* 9 */
+ INSN_NOP, /* 10 */
+ INSN_PV_CUR, /* 11 */
+ INSN_PV_FREE, /* 12 */
+ INSN_SV_UPGRADE, /* 13 */
+ INSN_SV_REFCNT, /* 14 */
+ INSN_SV_REFCNT_ADD, /* 15 */
+ INSN_SV_FLAGS, /* 16 */
+ INSN_XRV, /* 17 */
+ INSN_XPV, /* 18 */
+ INSN_XIV32, /* 19 */
+ INSN_XIV64, /* 20 */
+ INSN_XNV, /* 21 */
+ INSN_XLV_TARGOFF, /* 22 */
+ INSN_XLV_TARGLEN, /* 23 */
+ INSN_XLV_TARG, /* 24 */
+ INSN_XLV_TYPE, /* 25 */
+ INSN_XBM_USEFUL, /* 26 */
+ INSN_XBM_PREVIOUS, /* 27 */
+ INSN_XBM_RARE, /* 28 */
+ INSN_XFM_LINES, /* 29 */
+ INSN_XIO_LINES, /* 30 */
+ INSN_XIO_PAGE, /* 31 */
+ INSN_XIO_PAGE_LEN, /* 32 */
+ INSN_XIO_LINES_LEFT, /* 33 */
+ INSN_XIO_TOP_NAME, /* 34 */
+ INSN_COMMENT, /* 35 */
+ INSN_XIO_TOP_GV, /* 36 */
+ INSN_XIO_FMT_NAME, /* 37 */
+ INSN_XIO_FMT_GV, /* 38 */
+ INSN_XIO_BOTTOM_NAME, /* 39 */
+ INSN_XIO_BOTTOM_GV, /* 40 */
+ INSN_XIO_SUBPROCESS, /* 41 */
+ INSN_XIO_TYPE, /* 42 */
+ INSN_XIO_FLAGS, /* 43 */
+ INSN_XCV_STASH, /* 44 */
+ INSN_XCV_START, /* 45 */
+ INSN_XCV_ROOT, /* 46 */
+ INSN_XCV_GV, /* 47 */
+ INSN_XCV_FILEGV, /* 48 */
+ INSN_XCV_DEPTH, /* 49 */
+ INSN_XCV_PADLIST, /* 50 */
+ INSN_XCV_OUTSIDE, /* 51 */
+ INSN_XCV_FLAGS, /* 52 */
+ INSN_AV_EXTEND, /* 53 */
+ INSN_AV_PUSH, /* 54 */
+ INSN_XAV_FILL, /* 55 */
+ INSN_XAV_MAX, /* 56 */
+ INSN_XAV_FLAGS, /* 57 */
+ INSN_XHV_RITER, /* 58 */
+ INSN_XHV_NAME, /* 59 */
+ INSN_HV_STORE, /* 60 */
+ INSN_SV_MAGIC, /* 61 */
+ INSN_MG_OBJ, /* 62 */
+ INSN_MG_PRIVATE, /* 63 */
+ INSN_MG_FLAGS, /* 64 */
+ INSN_MG_PV, /* 65 */
+ INSN_XMG_STASH, /* 66 */
+ INSN_GV_FETCHPV, /* 67 */
+ INSN_GV_STASHPV, /* 68 */
+ INSN_GP_SV, /* 69 */
+ INSN_GP_REFCNT, /* 70 */
+ INSN_GP_REFCNT_ADD, /* 71 */
+ INSN_GP_AV, /* 72 */
+ INSN_GP_HV, /* 73 */
+ INSN_GP_CV, /* 74 */
+ INSN_GP_FILEGV, /* 75 */
+ INSN_GP_IO, /* 76 */
+ INSN_GP_FORM, /* 77 */
+ INSN_GP_CVGEN, /* 78 */
+ INSN_GP_LINE, /* 79 */
+ INSN_GP_SHARE, /* 80 */
+ INSN_XGV_FLAGS, /* 81 */
+ INSN_OP_NEXT, /* 82 */
+ INSN_OP_SIBLING, /* 83 */
+ INSN_OP_PPADDR, /* 84 */
+ INSN_OP_TARG, /* 85 */
+ INSN_OP_TYPE, /* 86 */
+ INSN_OP_SEQ, /* 87 */
+ INSN_OP_FLAGS, /* 88 */
+ INSN_OP_PRIVATE, /* 89 */
+ INSN_OP_FIRST, /* 90 */
+ INSN_OP_LAST, /* 91 */
+ INSN_OP_OTHER, /* 92 */
+ INSN_OP_TRUE, /* 93 */
+ INSN_OP_FALSE, /* 94 */
+ INSN_OP_CHILDREN, /* 95 */
+ INSN_OP_PMREPLROOT, /* 96 */
+ INSN_OP_PMREPLROOTGV, /* 97 */
+ INSN_OP_PMREPLSTART, /* 98 */
+ INSN_OP_PMNEXT, /* 99 */
+ INSN_PREGCOMP, /* 100 */
+ INSN_OP_PMSHORT, /* 101 */
+ INSN_OP_PMFLAGS, /* 102 */
+ INSN_OP_PMPERMFLAGS, /* 103 */
+ INSN_OP_PMSLEN, /* 104 */
+ INSN_OP_SV, /* 105 */
+ INSN_OP_GV, /* 106 */
+ INSN_OP_PV, /* 107 */
+ INSN_OP_PV_TR, /* 108 */
+ INSN_OP_REDOOP, /* 109 */
+ INSN_OP_NEXTOP, /* 110 */
+ INSN_OP_LASTOP, /* 111 */
+ INSN_COP_LABEL, /* 112 */
+ INSN_COP_STASH, /* 113 */
+ INSN_COP_FILEGV, /* 114 */
+ INSN_COP_SEQ, /* 115 */
+ INSN_COP_ARYBASE, /* 116 */
+ INSN_COP_LINE, /* 117 */
+ INSN_MAIN_START, /* 118 */
+ INSN_MAIN_ROOT, /* 119 */
+ INSN_CURPAD, /* 120 */
+ MAX_INSN = 120
+};
+
+enum {
+ OPt_OP, /* 0 */
+ OPt_UNOP, /* 1 */
+ OPt_BINOP, /* 2 */
+ OPt_LOGOP, /* 3 */
+ OPt_CONDOP, /* 4 */
+ OPt_LISTOP, /* 5 */
+ OPt_PMOP, /* 6 */
+ OPt_SVOP, /* 7 */
+ OPt_GVOP, /* 8 */
+ OPt_PVOP, /* 9 */
+ OPt_LOOP, /* 10 */
+ OPt_COP /* 11 */
+};
+
+EXT int optype_size[]
+#ifdef DOINIT
+= {
+ sizeof(OP),
+ sizeof(UNOP),
+ sizeof(BINOP),
+ sizeof(LOGOP),
+ sizeof(CONDOP),
+ sizeof(LISTOP),
+ sizeof(PMOP),
+ sizeof(SVOP),
+ sizeof(GVOP),
+ sizeof(PVOP),
+ sizeof(LOOP),
+ sizeof(COP)
+}
+#endif /* DOINIT */
+;
+
+EXT SV * specialsv_list[4]
+#ifdef DOINIT
+= { Nullsv, &sv_undef, &sv_yes, &sv_no }
+#endif /* DOINIT */
+;
--- /dev/null
+use Config;
+
+$libdir = "$Config{installarchlib}/CORE";
+
+if (!grep(/^-[cS]$/, @ARGV)) {
+ $linkargs = sprintf("%s -L$libdir -lperl %s", @Config{qw(ldflags libs)});
+}
+
+$cccmd = "$Config{cc} $Config{ccflags} -I$libdir @ARGV $linkargs";
+print "$cccmd\n";
+exec $cccmd;
--- /dev/null
+#define DOOP(ppname) PUTBACK; op = ppname(); SPAGAIN
+
+#define PP_LIST(g) do { \
+ dMARK; \
+ if (g != G_ARRAY) { \
+ if (++MARK <= SP) \
+ *MARK = *SP; \
+ else \
+ *MARK = &sv_undef; \
+ SP = MARK; \
+ } \
+ } while (0)
+
+#define MAYBE_TAINT_SASSIGN_SRC(sv) \
+ if (tainting && tainted && (!SvGMAGICAL(left) || !SvSMAGICAL(left) || \
+ !((mg=mg_find(left, 't')) && mg->mg_len & 1)))\
+ TAINT_NOT
+
+#define PP_PREINC(sv) do { \
+ if (SvIOK(sv)) { \
+ ++SvIVX(sv); \
+ SvFLAGS(sv) &= ~(SVf_NOK|SVf_POK|SVp_NOK|SVp_POK); \
+ } \
+ else \
+ sv_inc(sv); \
+ SvSETMAGIC(sv); \
+ } while (0)
+
+#define PP_UNSTACK do { \
+ TAINT_NOT; \
+ stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp; \
+ FREETMPS; \
+ oldsave = scopestack[scopestack_ix - 1]; \
+ LEAVE_SCOPE(oldsave); \
+ SPAGAIN; \
+ } while(0)
+
+#include "patchlevel.h"
+#if PATCHLEVEL < 3
+#define RUN() run()
+#else
+#define RUN() runops()
+#endif
+
+/* Anyone using eval "" deserves this mess */
+#define PP_EVAL(ppaddr, nxt) do { \
+ Sigjmp_buf oldtop; \
+ Copy(top_env,oldtop,1,Sigjmp_buf); \
+ PUTBACK; \
+ switch (Sigsetjmp(top_env,1)) { \
+ case 0: \
+ op = ppaddr(); \
+ retstack[retstack_ix - 1] = Nullop; \
+ Copy(oldtop,top_env,1,Sigjmp_buf); \
+ if (op != nxt) RUN(); \
+ break; \
+ case 1: Copy(oldtop,top_env,1,Sigjmp_buf); Siglongjmp(top_env,1); \
+ case 2: Copy(oldtop,top_env,1,Sigjmp_buf); Siglongjmp(top_env,2); \
+ case 3: \
+ Copy(oldtop,top_env,1,Sigjmp_buf); \
+ if (restartop != nxt) \
+ Siglongjmp(top_env, 3); \
+ } \
+ op = nxt; \
+ SPAGAIN; \
+ } while (0)
+
+#define PP_ENTERTRY(jmpbuf,label) do { \
+ Copy(top_env,jmpbuf,1,Sigjmp_buf); \
+ switch (Sigsetjmp(top_env,1)) { \
+ case 1: Copy(jmpbuf,top_env,1,Sigjmp_buf); Siglongjmp(top_env,1); \
+ case 2: Copy(jmpbuf,top_env,1,Sigjmp_buf); Siglongjmp(top_env,2); \
+ case 3: Copy(jmpbuf,top_env,1,Sigjmp_buf); SPAGAIN; goto label; \
+ } \
+ } while (0)
--- /dev/null
+/* ccop.c
+ *
+ * Copyright (c) 1996 Malcolm Beattie
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+#include "ccop.h"
+
+static char *opclassnames[] = {
+ "B::NULL",
+ "B::OP",
+ "B::UNOP",
+ "B::BINOP",
+ "B::LOGOP",
+ "B::CONDOP",
+ "B::LISTOP",
+ "B::PMOP",
+ "B::SVOP",
+ "B::GVOP",
+ "B::PVOP",
+ "B::CVOP",
+ "B::LOOP",
+ "B::COP"
+};
+
+static opclass
+cc_baseop(o)
+OP *o;
+{
+ return OPc_BASEOP;
+}
+
+static opclass
+cc_unop(o)
+OP *o;
+{
+ return OPc_UNOP;
+}
+
+static opclass
+cc_binop(o)
+OP *o;
+{
+ return OPc_BINOP;
+}
+
+static opclass
+cc_logop(o)
+OP *o;
+{
+ return OPc_LOGOP;
+}
+
+static opclass
+cc_condop(o)
+OP *o;
+{
+ return OPc_CONDOP;
+}
+
+static opclass
+cc_listop(o)
+OP *o;
+{
+ return OPc_LISTOP;
+}
+
+static opclass
+cc_pmop(o)
+OP *o;
+{
+ return OPc_PMOP;
+}
+
+static opclass
+cc_svop(o)
+OP *o;
+{
+ return OPc_SVOP;
+}
+
+static opclass
+cc_gvop(o)
+OP *o;
+{
+ return OPc_GVOP;
+}
+
+static opclass
+cc_pvop(o)
+OP *o;
+{
+ return OPc_PVOP;
+}
+
+static opclass
+cc_cvop(o)
+OP *o;
+{
+ return OPc_CVOP;
+}
+
+static opclass
+cc_loop(o)
+OP *o;
+{
+ return OPc_LOOP;
+}
+
+static opclass
+cc_cop(o)
+OP *o;
+{
+ return OPc_COP;
+}
+
+/* Nullified ops with children still need to be able to find o->op_first */
+static opclass
+cc_nullop(o)
+OP *o;
+{
+ return ((o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP);
+}
+
+static opclass
+cc_stub(o)
+OP *o;
+{
+ warn("compiler stub for %s, assuming BASEOP\n", ppnames[o->op_type]);
+ return OPc_BASEOP; /* XXX lie */
+}
+
+/*
+ * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on whether
+ * bare parens were seen. perly.y uses OPf_SPECIAL to signal whether an
+ * OP or an UNOP was chosen.
+ * Frederic.Chauveau@pasteur.fr says we need to check for OPf_KIDS too.
+ */
+static opclass
+cc_baseop_or_unop(o)
+OP *o;
+{
+ return ((o->op_flags & OPf_SPECIAL) ? OPc_BASEOP :
+ (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP);
+}
+
+/*
+ * The file stat OPs are created via UNI(OP_foo) in toke.c but use
+ * the OPf_REF flag to distinguish between OP types instead of the
+ * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
+ * return OPc_UNOP so that walkoptree can find our children. If
+ * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
+ * (no argument to the operator) it's an OP; with OPf_REF set it's
+ * a GVOP (and op_gv is the GV for the filehandle argument).
+ */
+static opclass
+cc_filestatop(o)
+OP *o;
+{
+ return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
+ (o->op_flags & OPf_REF) ? OPc_GVOP : OPc_BASEOP);
+}
+
+/*
+ * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
+ * label was omitted (in which case it's a BASEOP) or else a term was
+ * seen. In this last case, all except goto are definitely PVOP but goto
+ * is either a PVOP (with an ordinary constant label), an UNOP with
+ * OPf_STACKED (with a non-constant non-sub) or an UNOP for OP_REFGEN
+ * (with goto &sub) in which case OPf_STACKED also seems to get set.
+ */
+
+static opclass
+cc_loopexop(o)
+OP *o;
+{
+ if (o->op_flags & OPf_STACKED)
+ return OPc_UNOP;
+ else if (o->op_flags & OPf_SPECIAL)
+ return OPc_BASEOP;
+ else
+ return OPc_PVOP;
+}
+
+static opclass
+cc_sassign(o)
+OP *o;
+{
+ return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
+}
+
+static opclass (*ccopaddr[])_((OP *o)) = {
+ cc_nullop, /* null */
+ cc_baseop, /* stub */
+ cc_baseop_or_unop, /* scalar */
+ cc_baseop, /* pushmark */
+ cc_baseop, /* wantarray */
+ cc_svop, /* const */
+ cc_gvop, /* gvsv */
+ cc_gvop, /* gv */
+ cc_binop, /* gelem */
+ cc_baseop, /* padsv */
+ cc_baseop, /* padav */
+ cc_baseop, /* padhv */
+ cc_baseop, /* padany */
+ cc_pmop, /* pushre */
+ cc_unop, /* rv2gv */
+ cc_unop, /* rv2sv */
+ cc_unop, /* av2arylen */
+ cc_unop, /* rv2cv */
+ cc_svop, /* anoncode */
+ cc_baseop_or_unop, /* prototype */
+ cc_unop, /* refgen */
+ cc_unop, /* srefgen */
+ cc_baseop_or_unop, /* ref */
+ cc_listop, /* bless */
+ cc_baseop_or_unop, /* backtick */
+ cc_listop, /* glob */
+ cc_baseop_or_unop, /* readline */
+ cc_stub, /* rcatline */
+ cc_unop, /* regcmaybe */
+ cc_logop, /* regcomp */
+ cc_pmop, /* match */
+ cc_pmop, /* subst */
+ cc_logop, /* substcont */
+ cc_pvop, /* trans */
+ cc_sassign, /* sassign */
+ cc_binop, /* aassign */
+ cc_baseop_or_unop, /* chop */
+ cc_baseop_or_unop, /* schop */
+ cc_baseop_or_unop, /* chomp */
+ cc_baseop_or_unop, /* schomp */
+ cc_baseop_or_unop, /* defined */
+ cc_baseop_or_unop, /* undef */
+ cc_baseop_or_unop, /* study */
+ cc_baseop_or_unop, /* pos */
+ cc_unop, /* preinc */
+ cc_unop, /* i_preinc */
+ cc_unop, /* predec */
+ cc_unop, /* i_predec */
+ cc_unop, /* postinc */
+ cc_unop, /* i_postinc */
+ cc_unop, /* postdec */
+ cc_unop, /* i_postdec */
+ cc_binop, /* pow */
+ cc_binop, /* multiply */
+ cc_binop, /* i_multiply */
+ cc_binop, /* divide */
+ cc_binop, /* i_divide */
+ cc_binop, /* modulo */
+ cc_binop, /* i_modulo */
+ cc_binop, /* repeat */
+ cc_binop, /* add */
+ cc_binop, /* i_add */
+ cc_binop, /* subtract */
+ cc_binop, /* i_subtract */
+ cc_binop, /* concat */
+ cc_listop, /* stringify */
+ cc_binop, /* left_shift */
+ cc_binop, /* right_shift */
+ cc_binop, /* lt */
+ cc_binop, /* i_lt */
+ cc_binop, /* gt */
+ cc_binop, /* i_gt */
+ cc_binop, /* le */
+ cc_binop, /* i_le */
+ cc_binop, /* ge */
+ cc_binop, /* i_ge */
+ cc_binop, /* eq */
+ cc_binop, /* i_eq */
+ cc_binop, /* ne */
+ cc_binop, /* i_ne */
+ cc_binop, /* ncmp */
+ cc_binop, /* i_ncmp */
+ cc_binop, /* slt */
+ cc_binop, /* sgt */
+ cc_binop, /* sle */
+ cc_binop, /* sge */
+ cc_binop, /* seq */
+ cc_binop, /* sne */
+ cc_binop, /* scmp */
+ cc_binop, /* bit_and */
+ cc_binop, /* bit_xor */
+ cc_binop, /* bit_or */
+ cc_unop, /* negate */
+ cc_unop, /* i_negate */
+ cc_unop, /* not */
+ cc_unop, /* complement */
+ cc_listop, /* atan2 */
+ cc_baseop_or_unop, /* sin */
+ cc_baseop_or_unop, /* cos */
+ cc_baseop_or_unop, /* rand */
+ cc_baseop_or_unop, /* srand */
+ cc_baseop_or_unop, /* exp */
+ cc_baseop_or_unop, /* log */
+ cc_baseop_or_unop, /* sqrt */
+ cc_baseop_or_unop, /* int */
+ cc_baseop_or_unop, /* hex */
+ cc_baseop_or_unop, /* oct */
+ cc_baseop_or_unop, /* abs */
+ cc_baseop_or_unop, /* length */
+ cc_listop, /* substr */
+ cc_listop, /* vec */
+ cc_listop, /* index */
+ cc_listop, /* rindex */
+ cc_listop, /* sprintf */
+ cc_listop, /* formline */
+ cc_baseop_or_unop, /* ord */
+ cc_baseop_or_unop, /* chr */
+ cc_listop, /* crypt */
+ cc_baseop_or_unop, /* ucfirst */
+ cc_baseop_or_unop, /* lcfirst */
+ cc_baseop_or_unop, /* uc */
+ cc_baseop_or_unop, /* lc */
+ cc_baseop_or_unop, /* quotemeta */
+ cc_unop, /* rv2av */
+ cc_gvop, /* aelemfast */
+ cc_binop, /* aelem */
+ cc_listop, /* aslice */
+ cc_baseop_or_unop, /* each */
+ cc_baseop_or_unop, /* values */
+ cc_baseop_or_unop, /* keys */
+ cc_baseop_or_unop, /* delete */
+ cc_baseop_or_unop, /* exists */
+ cc_unop, /* rv2hv */
+ cc_binop, /* helem */
+ cc_listop, /* hslice */
+ cc_listop, /* unpack */
+ cc_listop, /* pack */
+ cc_listop, /* split */
+ cc_listop, /* join */
+ cc_listop, /* list */
+ cc_binop, /* lslice */
+ cc_listop, /* anonlist */
+ cc_listop, /* anonhash */
+ cc_listop, /* splice */
+ cc_listop, /* push */
+ cc_baseop_or_unop, /* pop */
+ cc_baseop_or_unop, /* shift */
+ cc_listop, /* unshift */
+ cc_listop, /* sort */
+ cc_listop, /* reverse */
+ cc_listop, /* grepstart */
+ cc_logop, /* grepwhile */
+ cc_listop, /* mapstart */
+ cc_logop, /* mapwhile */
+ cc_condop, /* range */
+ cc_unop, /* flip */
+ cc_unop, /* flop */
+ cc_logop, /* and */
+ cc_logop, /* or */
+ cc_logop, /* xor */
+ cc_condop, /* cond_expr */
+ cc_logop, /* andassign */
+ cc_logop, /* orassign */
+ cc_unop, /* method */
+ cc_unop, /* entersub */
+ cc_unop, /* leavesub */
+ cc_baseop_or_unop, /* caller */
+ cc_listop, /* warn */
+ cc_listop, /* die */
+ cc_baseop_or_unop, /* reset */
+ cc_listop, /* lineseq */
+ cc_cop, /* nextstate */
+ cc_cop, /* dbstate */
+ cc_baseop, /* unstack */
+ cc_baseop, /* enter */
+ cc_listop, /* leave */
+ cc_listop, /* scope */
+ cc_loop, /* enteriter */
+ cc_baseop, /* iter */
+ cc_loop, /* enterloop */
+ cc_binop, /* leaveloop */
+ cc_listop, /* return */
+ cc_loopexop, /* last */
+ cc_loopexop, /* next */
+ cc_loopexop, /* redo */
+ cc_loopexop, /* dump */
+ cc_loopexop, /* goto */
+ cc_baseop_or_unop, /* exit */
+ cc_listop, /* open */
+ cc_baseop_or_unop, /* close */
+ cc_listop, /* pipe_op */
+ cc_baseop_or_unop, /* fileno */
+ cc_baseop_or_unop, /* umask */
+ cc_baseop_or_unop, /* binmode */
+ cc_listop, /* tie */
+ cc_baseop_or_unop, /* untie */
+ cc_baseop_or_unop, /* tied */
+ cc_listop, /* dbmopen */
+ cc_baseop_or_unop, /* dbmclose */
+ cc_listop, /* sselect */
+ cc_listop, /* select */
+ cc_baseop_or_unop, /* getc */
+ cc_listop, /* read */
+ cc_baseop_or_unop, /* enterwrite */
+ cc_unop, /* leavewrite */
+ cc_listop, /* prtf */
+ cc_listop, /* print */
+ cc_listop, /* sysopen */
+ cc_listop, /* sysread */
+ cc_listop, /* syswrite */
+ cc_listop, /* send */
+ cc_listop, /* recv */
+ cc_baseop_or_unop, /* eof */
+ cc_baseop_or_unop, /* tell */
+ cc_listop, /* seek */
+ cc_listop, /* truncate */
+ cc_listop, /* fcntl */
+ cc_listop, /* ioctl */
+ cc_listop, /* flock */
+ cc_listop, /* socket */
+ cc_listop, /* sockpair */
+ cc_listop, /* bind */
+ cc_listop, /* connect */
+ cc_listop, /* listen */
+ cc_listop, /* accept */
+ cc_listop, /* shutdown */
+ cc_listop, /* gsockopt */
+ cc_listop, /* ssockopt */
+ cc_baseop_or_unop, /* getsockname */
+ cc_baseop_or_unop, /* getpeername */
+ cc_filestatop, /* lstat */
+ cc_filestatop, /* stat */
+ cc_filestatop, /* ftrread */
+ cc_filestatop, /* ftrwrite */
+ cc_filestatop, /* ftrexec */
+ cc_filestatop, /* fteread */
+ cc_filestatop, /* ftewrite */
+ cc_filestatop, /* fteexec */
+ cc_filestatop, /* ftis */
+ cc_filestatop, /* fteowned */
+ cc_filestatop, /* ftrowned */
+ cc_filestatop, /* ftzero */
+ cc_filestatop, /* ftsize */
+ cc_filestatop, /* ftmtime */
+ cc_filestatop, /* ftatime */
+ cc_filestatop, /* ftctime */
+ cc_filestatop, /* ftsock */
+ cc_filestatop, /* ftchr */
+ cc_filestatop, /* ftblk */
+ cc_filestatop, /* ftfile */
+ cc_filestatop, /* ftdir */
+ cc_filestatop, /* ftpipe */
+ cc_filestatop, /* ftlink */
+ cc_filestatop, /* ftsuid */
+ cc_filestatop, /* ftsgid */
+ cc_filestatop, /* ftsvtx */
+ cc_filestatop, /* fttty */
+ cc_filestatop, /* fttext */
+ cc_filestatop, /* ftbinary */
+ cc_baseop_or_unop, /* chdir */
+ cc_listop, /* chown */
+ cc_baseop_or_unop, /* chroot */
+ cc_listop, /* unlink */
+ cc_listop, /* chmod */
+ cc_listop, /* utime */
+ cc_listop, /* rename */
+ cc_listop, /* link */
+ cc_listop, /* symlink */
+ cc_baseop_or_unop, /* readlink */
+ cc_listop, /* mkdir */
+ cc_baseop_or_unop, /* rmdir */
+ cc_listop, /* open_dir */
+ cc_baseop_or_unop, /* readdir */
+ cc_baseop_or_unop, /* telldir */
+ cc_listop, /* seekdir */
+ cc_baseop_or_unop, /* rewinddir */
+ cc_baseop_or_unop, /* closedir */
+ cc_baseop, /* fork */
+ cc_baseop, /* wait */
+ cc_listop, /* waitpid */
+ cc_listop, /* system */
+ cc_listop, /* exec */
+ cc_listop, /* kill */
+ cc_baseop, /* getppid */
+ cc_baseop_or_unop, /* getpgrp */
+ cc_listop, /* setpgrp */
+ cc_listop, /* getpriority */
+ cc_listop, /* setpriority */
+ cc_baseop, /* time */
+ cc_baseop, /* tms */
+ cc_baseop_or_unop, /* localtime */
+ cc_baseop_or_unop, /* gmtime */
+ cc_baseop_or_unop, /* alarm */
+ cc_baseop_or_unop, /* sleep */
+ cc_listop, /* shmget */
+ cc_listop, /* shmctl */
+ cc_listop, /* shmread */
+ cc_listop, /* shmwrite */
+ cc_listop, /* msgget */
+ cc_listop, /* msgctl */
+ cc_listop, /* msgsnd */
+ cc_listop, /* msgrcv */
+ cc_listop, /* semget */
+ cc_listop, /* semctl */
+ cc_listop, /* semop */
+ cc_baseop_or_unop, /* require */
+ cc_unop, /* dofile */
+ cc_baseop_or_unop, /* entereval */
+ cc_unop, /* leaveeval */
+ cc_logop, /* entertry */
+ cc_listop, /* leavetry */
+ cc_baseop_or_unop, /* ghbyname */
+ cc_listop, /* ghbyaddr */
+ cc_baseop, /* ghostent */
+ cc_baseop_or_unop, /* gnbyname */
+ cc_listop, /* gnbyaddr */
+ cc_baseop, /* gnetent */
+ cc_baseop_or_unop, /* gpbyname */
+ cc_listop, /* gpbynumber */
+ cc_baseop, /* gprotoent */
+ cc_listop, /* gsbyname */
+ cc_listop, /* gsbyport */
+ cc_baseop, /* gservent */
+ cc_baseop_or_unop, /* shostent */
+ cc_baseop_or_unop, /* snetent */
+ cc_baseop_or_unop, /* sprotoent */
+ cc_baseop_or_unop, /* sservent */
+ cc_baseop, /* ehostent */
+ cc_baseop, /* enetent */
+ cc_baseop, /* eprotoent */
+ cc_baseop, /* eservent */
+ cc_baseop_or_unop, /* gpwnam */
+ cc_baseop_or_unop, /* gpwuid */
+ cc_baseop, /* gpwent */
+ cc_baseop, /* spwent */
+ cc_baseop, /* epwent */
+ cc_baseop_or_unop, /* ggrnam */
+ cc_baseop_or_unop, /* ggrgid */
+ cc_baseop, /* ggrent */
+ cc_baseop, /* sgrent */
+ cc_baseop, /* egrent */
+ cc_baseop, /* getlogin */
+ cc_listop, /* syscall */
+};
+
+opclass
+cc_opclass(o)
+OP * o;
+{
+ return o ? (*ccopaddr[o->op_type])(o) : OPc_NULL;
+}
+
+char *
+cc_opclassname(o)
+OP * o;
+{
+ return opclassnames[o ? (*ccopaddr[o->op_type])(o) : OPc_NULL];
+}
+
--- /dev/null
+typedef enum {
+ OPc_NULL, /* 0 */
+ OPc_BASEOP, /* 1 */
+ OPc_UNOP, /* 2 */
+ OPc_BINOP, /* 3 */
+ OPc_LOGOP, /* 4 */
+ OPc_CONDOP, /* 5 */
+ OPc_LISTOP, /* 6 */
+ OPc_PMOP, /* 7 */
+ OPc_SVOP, /* 8 */
+ OPc_GVOP, /* 9 */
+ OPc_PVOP, /* 10 */
+ OPc_CVOP, /* 11 */
+ OPc_LOOP, /* 12 */
+ OPc_COP /* 13 */
+} opclass;
+
+opclass cc_opclass _((OP *o));
+char * cc_opclassname _((OP *o));
+
+#ifndef DOINIT
+EXT char *ppnames[];
+#else
+EXT char *ppnames[] = {
+ "pp_null",
+ "pp_stub",
+ "pp_scalar",
+ "pp_pushmark",
+ "pp_wantarray",
+ "pp_const",
+ "pp_gvsv",
+ "pp_gv",
+ "pp_gelem",
+ "pp_padsv",
+ "pp_padav",
+ "pp_padhv",
+ "pp_padany",
+ "pp_pushre",
+ "pp_rv2gv",
+ "pp_rv2sv",
+ "pp_av2arylen",
+ "pp_rv2cv",
+ "pp_anoncode",
+ "pp_prototype",
+ "pp_refgen",
+ "pp_srefgen",
+ "pp_ref",
+ "pp_bless",
+ "pp_backtick",
+ "pp_glob",
+ "pp_readline",
+ "pp_rcatline",
+ "pp_regcmaybe",
+ "pp_regcomp",
+ "pp_match",
+ "pp_subst",
+ "pp_substcont",
+ "pp_trans",
+ "pp_sassign",
+ "pp_aassign",
+ "pp_chop",
+ "pp_schop",
+ "pp_chomp",
+ "pp_schomp",
+ "pp_defined",
+ "pp_undef",
+ "pp_study",
+ "pp_pos",
+ "pp_preinc",
+ "pp_i_preinc",
+ "pp_predec",
+ "pp_i_predec",
+ "pp_postinc",
+ "pp_i_postinc",
+ "pp_postdec",
+ "pp_i_postdec",
+ "pp_pow",
+ "pp_multiply",
+ "pp_i_multiply",
+ "pp_divide",
+ "pp_i_divide",
+ "pp_modulo",
+ "pp_i_modulo",
+ "pp_repeat",
+ "pp_add",
+ "pp_i_add",
+ "pp_subtract",
+ "pp_i_subtract",
+ "pp_concat",
+ "pp_stringify",
+ "pp_left_shift",
+ "pp_right_shift",
+ "pp_lt",
+ "pp_i_lt",
+ "pp_gt",
+ "pp_i_gt",
+ "pp_le",
+ "pp_i_le",
+ "pp_ge",
+ "pp_i_ge",
+ "pp_eq",
+ "pp_i_eq",
+ "pp_ne",
+ "pp_i_ne",
+ "pp_ncmp",
+ "pp_i_ncmp",
+ "pp_slt",
+ "pp_sgt",
+ "pp_sle",
+ "pp_sge",
+ "pp_seq",
+ "pp_sne",
+ "pp_scmp",
+ "pp_bit_and",
+ "pp_bit_xor",
+ "pp_bit_or",
+ "pp_negate",
+ "pp_i_negate",
+ "pp_not",
+ "pp_complement",
+ "pp_atan2",
+ "pp_sin",
+ "pp_cos",
+ "pp_rand",
+ "pp_srand",
+ "pp_exp",
+ "pp_log",
+ "pp_sqrt",
+ "pp_int",
+ "pp_hex",
+ "pp_oct",
+ "pp_abs",
+ "pp_length",
+ "pp_substr",
+ "pp_vec",
+ "pp_index",
+ "pp_rindex",
+ "pp_sprintf",
+ "pp_formline",
+ "pp_ord",
+ "pp_chr",
+ "pp_crypt",
+ "pp_ucfirst",
+ "pp_lcfirst",
+ "pp_uc",
+ "pp_lc",
+ "pp_quotemeta",
+ "pp_rv2av",
+ "pp_aelemfast",
+ "pp_aelem",
+ "pp_aslice",
+ "pp_each",
+ "pp_values",
+ "pp_keys",
+ "pp_delete",
+ "pp_exists",
+ "pp_rv2hv",
+ "pp_helem",
+ "pp_hslice",
+ "pp_unpack",
+ "pp_pack",
+ "pp_split",
+ "pp_join",
+ "pp_list",
+ "pp_lslice",
+ "pp_anonlist",
+ "pp_anonhash",
+ "pp_splice",
+ "pp_push",
+ "pp_pop",
+ "pp_shift",
+ "pp_unshift",
+ "pp_sort",
+ "pp_reverse",
+ "pp_grepstart",
+ "pp_grepwhile",
+ "pp_mapstart",
+ "pp_mapwhile",
+ "pp_range",
+ "pp_flip",
+ "pp_flop",
+ "pp_and",
+ "pp_or",
+ "pp_xor",
+ "pp_cond_expr",
+ "pp_andassign",
+ "pp_orassign",
+ "pp_method",
+ "pp_entersub",
+ "pp_leavesub",
+ "pp_caller",
+ "pp_warn",
+ "pp_die",
+ "pp_reset",
+ "pp_lineseq",
+ "pp_nextstate",
+ "pp_dbstate",
+ "pp_unstack",
+ "pp_enter",
+ "pp_leave",
+ "pp_scope",
+ "pp_enteriter",
+ "pp_iter",
+ "pp_enterloop",
+ "pp_leaveloop",
+ "pp_return",
+ "pp_last",
+ "pp_next",
+ "pp_redo",
+ "pp_dump",
+ "pp_goto",
+ "pp_exit",
+ "pp_open",
+ "pp_close",
+ "pp_pipe_op",
+ "pp_fileno",
+ "pp_umask",
+ "pp_binmode",
+ "pp_tie",
+ "pp_untie",
+ "pp_tied",
+ "pp_dbmopen",
+ "pp_dbmclose",
+ "pp_sselect",
+ "pp_select",
+ "pp_getc",
+ "pp_read",
+ "pp_enterwrite",
+ "pp_leavewrite",
+ "pp_prtf",
+ "pp_print",
+ "pp_sysopen",
+ "pp_sysread",
+ "pp_syswrite",
+ "pp_send",
+ "pp_recv",
+ "pp_eof",
+ "pp_tell",
+ "pp_seek",
+ "pp_truncate",
+ "pp_fcntl",
+ "pp_ioctl",
+ "pp_flock",
+ "pp_socket",
+ "pp_sockpair",
+ "pp_bind",
+ "pp_connect",
+ "pp_listen",
+ "pp_accept",
+ "pp_shutdown",
+ "pp_gsockopt",
+ "pp_ssockopt",
+ "pp_getsockname",
+ "pp_getpeername",
+ "pp_lstat",
+ "pp_stat",
+ "pp_ftrread",
+ "pp_ftrwrite",
+ "pp_ftrexec",
+ "pp_fteread",
+ "pp_ftewrite",
+ "pp_fteexec",
+ "pp_ftis",
+ "pp_fteowned",
+ "pp_ftrowned",
+ "pp_ftzero",
+ "pp_ftsize",
+ "pp_ftmtime",
+ "pp_ftatime",
+ "pp_ftctime",
+ "pp_ftsock",
+ "pp_ftchr",
+ "pp_ftblk",
+ "pp_ftfile",
+ "pp_ftdir",
+ "pp_ftpipe",
+ "pp_ftlink",
+ "pp_ftsuid",
+ "pp_ftsgid",
+ "pp_ftsvtx",
+ "pp_fttty",
+ "pp_fttext",
+ "pp_ftbinary",
+ "pp_chdir",
+ "pp_chown",
+ "pp_chroot",
+ "pp_unlink",
+ "pp_chmod",
+ "pp_utime",
+ "pp_rename",
+ "pp_link",
+ "pp_symlink",
+ "pp_readlink",
+ "pp_mkdir",
+ "pp_rmdir",
+ "pp_open_dir",
+ "pp_readdir",
+ "pp_telldir",
+ "pp_seekdir",
+ "pp_rewinddir",
+ "pp_closedir",
+ "pp_fork",
+ "pp_wait",
+ "pp_waitpid",
+ "pp_system",
+ "pp_exec",
+ "pp_kill",
+ "pp_getppid",
+ "pp_getpgrp",
+ "pp_setpgrp",
+ "pp_getpriority",
+ "pp_setpriority",
+ "pp_time",
+ "pp_tms",
+ "pp_localtime",
+ "pp_gmtime",
+ "pp_alarm",
+ "pp_sleep",
+ "pp_shmget",
+ "pp_shmctl",
+ "pp_shmread",
+ "pp_shmwrite",
+ "pp_msgget",
+ "pp_msgctl",
+ "pp_msgsnd",
+ "pp_msgrcv",
+ "pp_semget",
+ "pp_semctl",
+ "pp_semop",
+ "pp_require",
+ "pp_dofile",
+ "pp_entereval",
+ "pp_leaveeval",
+ "pp_entertry",
+ "pp_leavetry",
+ "pp_ghbyname",
+ "pp_ghbyaddr",
+ "pp_ghostent",
+ "pp_gnbyname",
+ "pp_gnbyaddr",
+ "pp_gnetent",
+ "pp_gpbyname",
+ "pp_gpbynumber",
+ "pp_gprotoent",
+ "pp_gsbyname",
+ "pp_gsbyport",
+ "pp_gservent",
+ "pp_shostent",
+ "pp_snetent",
+ "pp_sprotoent",
+ "pp_sservent",
+ "pp_ehostent",
+ "pp_enetent",
+ "pp_eprotoent",
+ "pp_eservent",
+ "pp_gpwnam",
+ "pp_gpwuid",
+ "pp_gpwent",
+ "pp_spwent",
+ "pp_epwent",
+ "pp_ggrnam",
+ "pp_ggrgid",
+ "pp_ggrent",
+ "pp_sgrent",
+ "pp_egrent",
+ "pp_getlogin",
+ "pp_syscall",
+};
+#endif
--- /dev/null
+#!./bperl
+use B::Disassembler qw(disassemble_fh);
+use FileHandle;
+
+my $fh;
+if (@ARGV == 0) {
+ $fh = \*STDIN;
+} elsif (@ARGV == 1) {
+ $fh = new FileHandle "<$ARGV[0]";
+} else {
+ die "Usage: disassemble [filename]\n";
+}
+
+sub print_insn {
+ my ($insn, $arg) = @_;
+ if (defined($arg)) {
+ printf "%s %s\n", $insn, $arg;
+ } else {
+ print $insn, "\n";
+ }
+}
+
+disassemble_fh($fh, \&print_insn);
--- /dev/null
+The following is what you could do with an old snapshot. I've probably
+broken some things since then or made other ways to do them. It gives a
+bit of information about what's in there, though, so it may be worth a look.
+
+USAGE
+
+Here are a few things you can try. I'll assume the executable is called perl
+and I'll leave out all the debugging info that ends up on stderr.
+
+(1) Writing out bytecode for a main program
+% perl -Iblib -e 'use B::Bytecode; print "Hello world\n"; exit 0' > foo
+% perl -Iblib -e 'use B::Run "foo"'
+Hello world
+
+(2) Writing out bytecode for a sub (not as a main program)
+% perl -Iblib -e 'use B::Bytecode qw(\*main::foo); sub foo { my $arg = shift; my $c = 42; return $c + $arg }' > foo
+% perl -Iblib -le 'use B::Run "foo"; print foo(3)'
+45
+
+(3) Writing out C code for a main program
+% perl -Iblib -e 'use B::C; print "Hello world\n"; exit 0' > hello.c
+% make hello.o
+cc -I../perl/perl5.001m -D__USE_BSD_SIGNAL -Dbool=char -DHAS_BOOL -D_POSIX_SOURCE -DDEBUGGING -g -c hello.c -o hello.o
+[if you've done a proper Makefile, otherwise do it manually]
+% cc -o hello hello.o -L../perl/perl5.001m -lperl -lbsd -lm
+[or whatever libs you need along with libperl]
+% ./hello -e ""
+[you need the -e "" since perl_parse still reads the command line]
+Hello world
+
+(4) Writing out C code for a partial program (not working properly).
+% perl -Iblib -e 'use B::C qw(\*main::foo); sub foo { print "Hello world\n" }' > bar.c
+That should produce C source and you could then call perl_init() in it
+(ought to be renamed automagically) to load in the appropriate ops.
+The current problem at the moment is that CvOUTSIDE of the CV for &foo
+(which points to the next outermost lexical context) points into the CV
+for file-scope lexicals so you get an undefined symbol. It'll get fixed.
+
+(5) A utility op tree walker
+% perl -Iblib -ce 'use B; END { B::walkoptree(B::main_root, "terse") } my $i; for ($i = 0; $i < 10; $i++) { print "foo $i\n" }'
+
+LISTOP (0xc31c0) pp_leave
+ OP (0xc2480) pp_enter
+ COP (0xc3ec0) pp_nextstate
+ OP (0x1091c0) pp_padsv
+ COP (0xc35c0) pp_nextstate
+ BINOP (0xc2120) pp_sassign
+ SVOP (0xc2040) pp_const IV (0xbb86c) 0
+ OP (0xc2ee0) pp_padsv
+ LISTOP (0xc3600) pp_lineseq
+ COP (0xc3380) pp_nextstate
+ BINOP (0xc25a0) pp_leaveloop
+ LOOP (0xc3640) pp_enterloop
+ OP (0xc24c0) pp_null
+
+(6) Another utility op tree walker
+% perl -Iblib -ce 'use B; END { B::walkoptree(B::main_root, "debug")} print "Hello world\n"'
+-e syntax OK
+LISTOP (0xc3180)
+ op_next 0x0
+ op_sibling 0x0
+ op_ppaddr pp_leave
+ op_targ 0
+ op_type 174
+ op_seq 3777
+ op_flags 14
+ op_private 0
+ op_first 0xc5fc0
+ op_last 0xc31c0
+ op_children 3
+...
+SVOP (0x10bf40)
+ op_next 0xc31c0
+ op_sibling 0x0
+ op_ppaddr pp_const
+ op_targ 0
+ op_type 5
+ op_seq 3780
+ op_flags 2
+ op_private 0
+ op_sv 0xac514
+PV (0xac514)
+ REFCNT 1
+ FLAGS 0x4840004
+ xpv_pv "Hello world\n"
+ xpv_cur 12
+
+(7) An op tree walker for execution order
+perl -Iblib -ce 'use B; END { B::walkoptree_exec(B::main_start, "terse")} my $i; for ($i = 0; $i < 10; $i++) { next if $i == 5; print "foo\n" }'
+-e syntax OK
+OP (0xc2480) pp_enter
+COP (0xc4f40) pp_nextstate
+OP (0x10b920) pp_padsv
+COP (0xc3600) pp_nextstate
+SVOP (0xc2ee0) pp_const IV (0xbb86c) 0
+OP (0xc5000) pp_padsv
+BINOP (0xc2040) pp_sassign
+COP (0xc3380) pp_nextstate
+LOOP (0xc33c0) pp_enterloop
+REDO => {
+ COP (0xc31c0) pp_nextstate
+ OP (0xc21a0) pp_padsv
+ SVOP (0xc2160) pp_const IV (0xbb6b8) 5
+ BINOP (0xc22c0) pp_eq
+ LOGOP (0xc2340) pp_and
+ AND => {
+ OP (0xc2180) pp_next
+ COP (0xc3140) pp_nextstate
+ OP (0xc2300) pp_pushmark
+ SVOP (0xc22e0) pp_const PV (0xbb664) "foo\n"
+ LISTOP (0xc3400) pp_print
+ OP (0xc21c0) pp_padsv
+ UNOP (0xc22a0) pp_preinc
+ OP (0xc2320) pp_unstack
+ OP (0xc2120) pp_padsv
+ SVOP (0xc2020) pp_const IV (0xbb70c) 10
+ BINOP (0xc2140) pp_lt
+ LOGOP (0xc2440) pp_and
+ AND => {
+ goto COP (0xc31c0)
+ }
+ BINOP (0xc25a0) pp_leaveloop
+ LISTOP (0xc3ec0) pp_leave
+ }
+ goto COP (0xc3140)
+}
+NEXT => {
+ goto OP (0xc21c0)
+}
+LAST => {
+ goto BINOP (0xc25a0)
+}
+goto OP (0xc2120)
+
+
+Malcolm Beattie
+11 February 1996
--- /dev/null
+Test results from t/*/*.t compiled with -MO=C
+
+base/cond.t OK
+base/if.t OK
+base/lex.t not ok 7 :2591024652:
+base/pat.t OK
+
+cmd/elsif.t Linux: ok 1,2 then seg fault at pp_hot.c:1850, av is a
+ read-only IV, value 2. OSF/1: core dump
+cmd/for.t OK
+cmd/mod.t OK (run from right place so that t/TEST exists for test 7)
+cmd/subval.t core dump
+cmd/switch.t core dump
+cmd/while.t OK (but UNOP pp_eof has an SV* in its op_first field)
+
+io/argv.t compiler stub for pp_fteexec
+io/dup.t OK
+io/fs.t compiler stub for pp_fteexec
+io/inplace.t OK
+io/pipe.t "ok 4\n 5\n 6\nok 8"
+io/print.t OK
+io/tell.t needs ../Configure to exist
+
+op/append.t OK
+op/array.t OK
+op/auto.t OK
+op/chop.t core dump
+op/cond.t OK
+op/delete.t OK
+op/do.t core dump
+op/each.t not ok 2
+op/eval.t OK
+op/exec.t OK
+op/exp.t OK
+op/flip.t not ok 8 0::
+op/fork.t OK
+op/glob.t OK
+op/goto.t not ok 3, core dump
+op/groups.t compiler stub for pp_fteexec
+op/index.t OK
+op/int.t OK
+op/join.t OK
+op/list.t OK
+op/local.t core dump
+op/magic.t omits ok 3 and ok 4
+op/misc.t compiler stub for pp_ftdir
+op/mkdir.t compiler stub for pp_ftdir
+op/my.t core dump
+op/oct.t not ok: 4, 5, 6
+op/ord.t OK
+op/overload.t core dump
+op/pack.t omits ok 8: Can't open ../perl or ../perl.exe: No such
+ file or directory. Probably just cwd trouble.
+op/pat.t OK (but UNOP for pp_reset has an SV* in its op_first)
+op/push.t walkoptree gets called on a GV
+op/quotemeta.t OK
+op/rand.t OK
+op/range.t OK
+op/read.t Can't open op.read at ../perl5.002/t/op/read.t line 8.
+op/readdir.t OK (but UNOP pp_exit has an SV* in its op_first)
+op/ref.t OK
+op/sleep.t OK
+op/sort.t ok 1 then core dump
+op/split.t not ok 11
+op/sprintf.t OK
+op/stat.t compiler stub for pp_ftzero
+op/study.t OK
+op/subst.t not ok 44-49, 52-56
+op/substr.t no PVLV support
+op/time.t OK
+op/undef.t ok1-18 then core dump
+op/unshift.t OK
+op/vec.t no PVLV support
+op/write.t No format support (GvFORM(gv) not NULL while saving GV)
--- /dev/null
+Test results from t/*/*.t compiled with -MO=C
+
+base/cond.t OK
+base/if.t OK
+base/lex.t not ok 7 :2591024652:
+base/pat.t OK
+cmd/elsif.t Linux: ok 1,2 then seg fault at pp_hot.c:1850, av is a
+ read-only IV, value 2. OSF/1: core dump
+cmd/for.t OK
+cmd/mod.t OK
+cmd/subval.t core dump
+cmd/switch.t core dump
+cmd/while.t OK (but UNOP pp_eof has an SV* in its op_first field)
+io/argv.t OK
+io/dup.t OK
+io/fs.t OK
+io/inplace.t OK
+io/pipe.t "ok 4\n 5\n 6\nok 8"
+io/print.t OK
+io/tell.t OK
+op/append.t OK
+op/array.t OK
+op/auto.t OK
+op/chop.t core dump
+op/cond.t OK
+op/delete.t OK
+op/do.t core dump
+op/each.t not ok 2
+op/eval.t OK
+op/exec.t OK
+op/exp.t OK
+op/flip.t not ok 8 0::
+op/fork.t OK
+op/glob.t OK
+op/goto.t not ok 3, core dump
+op/groups.t prints "1..2\n", nothing more
+op/index.t OK
+op/int.t OK
+op/join.t OK
+op/list.t OK
+op/local.t core dump
+op/magic.t omits ok 3 and ok 4
+op/misc.t walkoptree gets called on a GV
+op/mkdir.t OK
+op/my.t core dump
+op/oct.t not ok: 4, 5, 6
+op/ord.t OK
+op/overload.t core dump
+op/pack.t OK
+op/pat.t OK (but UNOP for pp_reset has an SV* in its op_first)
+op/push.t walkoptree gets called on a GV
+op/quotemeta.t OK
+op/rand.t OK
+op/range.t OK
+op/read.t Can't open op.read at ../perl5.002/t/op/read.t line 8.
+op/readdir.t OK (but UNOP pp_exit has an SV* in its op_first)
+op/ref.t OK
+op/sleep.t OK
+op/sort.t ok 1 then core dump
+op/split.t not ok 11
+op/sprintf.t OK
+op/stat.t not ok 1, 2, 35, 36, 37, 40, 45, 48, 51, 53
+op/study.t OK
+op/subst.t not ok 44-49, 52-56
+op/substr.t no PVLV support
+op/time.t OK
+op/undef.t ok1-18 then core dump
+op/unshift.t OK
+op/vec.t no PVLV support
+op/write.t No format support (GvFORM(gv) not NULL while saving GV)
--- /dev/null
+Test results from compiling t/*/*.t
+ C Bytecode
+
+base/cond.t OK OK
+base/if.t OK OK
+base/lex.t OK OK
+base/pat.t OK OK
+base/term.t OK OK
+cmd/elsif.t OK OK
+cmd/for.t OK OK
+cmd/mod.t OK OK
+cmd/subval.t OK OK
+cmd/switch.t OK OK
+cmd/while.t OK OK
+io/argv.t OK OK
+io/dup.t OK OK
+io/fs.t OK OK
+io/inplace.t OK OK
+io/pipe.t OK OK
+io/print.t OK OK
+io/tell.t OK OK
+op/append.t OK OK
+op/array.t OK OK
+op/auto.t OK OK
+op/chop.t OK OK
+op/cond.t OK OK
+op/delete.t OK OK
+op/do.t OK OK
+op/each.t OK OK
+op/eval.t OK OK
+op/exec.t OK OK
+op/exp.t OK OK
+op/flip.t OK OK
+op/fork.t OK OK
+op/glob.t OK OK
+op/goto.t OK OK
+op/groups.t OK (s/ucb/bin/ under Linux)
+op/index.t OK OK
+op/int.t OK OK
+op/join.t OK OK
+op/list.t OK OK
+op/local.t OK OK
+op/magic.t OK OK
+op/misc.t no DATA filehandle so succeeds trivially with 1..0
+op/mkdir.t OK OK
+op/my.t OK OK
+op/oct.t OK OK
+op/ord.t OK OK
+op/overload.t Mostly not ok Mostly not ok
+op/pack.t OK OK
+op/pat.t OK OK
+op/push.t OK OK
+op/quotemeta.t OK OK
+op/rand.t OK OK
+op/range.t OK OK
+op/read.t OK OK
+op/readdir.t OK OK
+op/ref.t omits "ok 40" (lexical destruction) OK (Bytecode)
+op/regexp.t OK OK
+op/repeat.t OK OK
+op/sleep.t OK OK
+op/sort.t OK OK
+op/split.t OK OK
+op/sprintf.t OK OK
+op/stat.t OK OK
+op/study.t OK OK
+op/subst.t OK OK
+op/substr.t OK OK
+op/time.t OK OK
+op/undef.t OK OK
+op/unshift.t OK OK
+op/vec.t OK OK
+op/write.t not ok 3 (no CvOUTSIDE lexical visibility from runtime eval)
--- /dev/null
+Test results from compiling t/*/*.t
+ C Bytecode CC
+
+base/cond.t OK OK OK
+base/if.t OK OK OK
+base/lex.t OK OK 1..24, omits 5,10,11, not ok 7
+base/pat.t OK OK OK
+base/term.t OK OK OK
+cmd/elsif.t OK OK OK
+cmd/for.t OK OK C label used but not defined
+cmd/mod.t OK OK OK
+cmd/subval.t OK OK 1..34, not ok 27,28 (simply
+ because filename changes).
+cmd/switch.t OK OK 1..18, not ok 2-5,8-11
+cmd/while.t OK OK 1..10, not ok 1, 2, exits
+io/argv.t OK OK OK
+io/dup.t OK OK OK
+io/fs.t OK OK OK
+io/inplace.t OK OK OK
+io/pipe.t OK OK 1..8, not ok 8 (no walksymtable
+ to find unused subs yet)
+io/print.t OK OK OK
+io/tell.t OK OK OK
+op/append.t OK OK OK
+op/array.t OK OK 1..36, not ok 7,10,29,30
+op/auto.t OK OK ok 10,20,30-34. Not ok rest.
+op/chop.t OK OK OK
+op/cond.t OK OK OK
+op/delete.t OK OK OK
+op/do.t OK OK 1..15, not ok 5
+op/each.t OK OK OK
+op/eval.t OK OK C cast warning. 1..16, ok2,5.
+op/exec.t OK OK OK
+op/exp.t OK OK OK
+op/flip.t OK OK 1..8, not ok 6, 7, nothing else
+op/fork.t OK OK 1..2, ok 2.
+op/glob.t OK OK OK
+op/goto.t OK OK 1..9, Can't find label label1.
+op/groups.t OK (s/ucb/bin/ under Linux) OK 1..0 for now.
+op/index.t OK OK OK
+op/int.t OK OK OK
+op/join.t OK OK OK
+op/list.t OK OK ok 1-17, 24-27, not ok 18-23
+op/local.t OK OK Weird mixture of ok numbers.
+op/magic.t OK OK not ok 1, ok 2-4
+op/misc.t no DATA filehandle so succeeds trivially with 1..0
+op/mkdir.t OK OK OK
+op/my.t OK OK ok 1,2,6-20. 000ok 5.
+op/oct.t OK OK OK (C large const warnings)
+op/ord.t OK OK OK
+op/overload.t Mostly not ok Mostly not ok C errors.
+op/pack.t OK OK OK
+op/pat.t OK OK C ptr warning. 1..60, ok 1-44
+op/push.t OK OK 1..4, ok 1-3
+op/quotemeta.t OK OK 1..15. seg fault.
+op/rand.t OK OK OK
+op/range.t OK OK ok 1,3-8. not ok 2.
+op/read.t OK OK OK
+op/readdir.t OK OK OK
+op/ref.t omits "ok 40" (lex destruction) OK (Bytecode) 1..41, ok1-8 (CC)
+op/regexp.t OK OK 1..267, nothing else.
+op/repeat.t OK OK OK
+op/sleep.t OK OK OK
+op/sort.t OK OK 1..10, ok 1, Out of memory!
+op/split.t OK OK OK
+op/sprintf.t OK OK OK
+op/stat.t OK OK C ptr warn. 1..56, ok 1-3
+op/study.t OK OK OK
+op/subst.t OK OK C errors (s//e broken).
+op/substr.t OK OK ok 1-6,10,12-22. not ok 7-9,11
+op/time.t OK OK 1..5, nothing else
+op/undef.t OK OK ok 1-19, not ok 19, ok 20, hang
+op/unshift.t OK OK OK
+op/vec.t OK OK OK
+op/write.t not ok 3 (no CvOUTSIDE lex from runtime eval). CC: 1..3, hang
--- /dev/null
+*** op.c.ORI Sat Apr 6 15:14:05 1996
+--- op.c Sat Apr 6 15:16:05 1996
+***************
+*** 393,399 ****
+ {
+ register OP *kid, *nextkid;
+
+! if (!op)
+ return;
+
+ if (op->op_flags & OPf_KIDS) {
+--- 393,399 ----
+ {
+ register OP *kid, *nextkid;
+
+! if (!op || op->op_seq == (U16)-1)
+ return;
+
+ if (op->op_flags & OPf_KIDS) {
--- /dev/null
+At entry to each basic block, the following can be assumed (and hence
+must be forced where necessary at the end of each basic block):
+
+The shadow stack @stack is empty.
+For each lexical object in @pad, VALID_IV holds for each T_INT,
+VALID_DOUBLE holds for each T_DOUBLE and VALID_SV holds otherwise.
+The C shadow variable sp holds the stack pointer (not necessarily stack_sp).
+
+write_back_stack
+ Writes the contents of the shadow stack @stack back to the real stack.
+ A write-back of each object in the stack is forced so that its
+ backing SV contains the right value and that SV is then pushed onto the
+ real stack. On return, @stack is empty.
+
+write_back_lexicals
+ Forces a write-back (i.e. achieves VALID_SV), where necessary, for each
+ lexical object in @pad. Objects with the TEMPORARY flag are skipped. If
+ write_back_lexicals is called with an (optional) argument, then it is
+ taken to be a bitmask of more flags: any lexical object with one of those
+ flags set is also skipped and not written back to its SV.
+
+invalidate_lexicals($avoid)
+ The VALID_INT and VALID_DOUBLE flags are turned off for each lexical
+ object in @pad whose flags field doesn't overlap with $avoid.
+
+reload_lexicals
+ For each necessary lexical object in @pad, makes sure that VALID_IV
+ holds for objects of type T_INT, VALID_DOUBLE holds for objects for
+ type T_DOUBLE, and VALID_SV holds for other objects. An object is
+ considered for reloading if its flags field does not overlap with the
+ (optional) argument passed to reload_lexicals.
+
--- /dev/null
+PP code uses of curcop
+----------------------
+
+pp_rv2gv
+ when a new glob is created for an OPpLVAL_INTRO,
+ curcop->cop_line is stored as GvLINE() in the new GP.
+pp_bless
+ curcop->cop_stash is used as the stash in the one-arg form of bless
+
+pp_repeat
+ tests (curcop != &compiling) to warn "Can't x= to readonly value"
+
+pp_pos
+pp_substr
+pp_index
+pp_rindex
+pp_aslice
+pp_lslice
+pp_splice
+ curcop->cop_arybase
+
+pp_sort
+ curcop->cop_stash used to determine whether to gv_fetchpv $a and $b
+
+pp_caller
+ tests (curcop->cop_stash == debstash) to determine whether
+ to set DB::args
+
+pp_reset
+ resets vars in curcop->cop_stash
+
+pp_dbstate
+ sets curcop = (COP*)op
+
+doeval
+ compiles into curcop->cop_stash
+
+pp_nextstate
+ sets curcop = (COP*)op
--- /dev/null
+int
+perl_dontparse(sv_interp, xsinit, argc, argv, env)
+PerlInterpreter *sv_interp;
+void (*xsinit)_((void));
+int argc;
+char **argv;
+char **env;
+{
+ register char *s;
+ char *scriptname = NULL;
+ VOL bool dosearch = FALSE;
+ char *validarg = "";
+ AV* comppadlist;
+
+#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
+#ifdef IAMSUID
+#undef IAMSUID
+ croak("suidperl is no longer needed since the kernel can now execute\n\
+setuid perl scripts securely.\n");
+#endif
+#endif
+
+ if (!(curinterp = sv_interp))
+ return 255;
+
+ origargv = argv;
+ origargc = argc;
+#ifndef VMS /* VMS doesn't have environ array */
+ origenviron = environ;
+#endif
+
+ switch (Sigsetjmp(top_env,1)) {
+ case 1:
+#ifdef VMS
+ statusvalue = 255;
+#else
+ statusvalue = 1;
+#endif
+ case 2:
+ curstash = defstash;
+ if (endav)
+ calllist(endav);
+ return(statusvalue); /* my_exit() was called */
+ case 3:
+ fprintf(stderr, "panic: top_env\n");
+ return 1;
+ }
+
+ sv_setpvn(linestr,"",0);
+ init_main_stash();
+
+ scriptname = argv[0];
+ if (scriptname == Nullch) {
+#ifdef MSDOS
+ if ( isatty(fileno(stdin)) )
+ moreswitches("v");
+#endif
+ scriptname = "-";
+ }
+
+ init_perllib();
+
+ open_script(scriptname,dosearch,sv);
+
+ validate_suid(validarg);
+
+ if (doextract)
+ find_beginning();
+
+ compcv = (CV*)NEWSV(1104,0);
+ sv_upgrade((SV *)compcv, SVt_PVCV);
+
+ pad = newAV();
+ comppad = pad;
+ av_push(comppad, Nullsv);
+ curpad = AvARRAY(comppad);
+ padname = newAV();
+ comppad_name = padname;
+ comppad_name_fill = 0;
+ min_intro_pending = 0;
+ padix = 0;
+
+ comppadlist = newAV();
+ AvREAL_off(comppadlist);
+ av_store(comppadlist, 0, (SV*)comppad_name);
+ av_store(comppadlist, 1, (SV*)comppad);
+ CvPADLIST(compcv) = comppadlist;
+
+ if (xsinit)
+ (*xsinit)(); /* in case linked C routines want magical variables */
+#ifdef VMS
+ init_os_extras();
+#endif
+
+ init_predump_symbols();
+ init_postdump_symbols(argc,argv,env);
+
+ init_lexer();
+
+ /* now parse the script */
+
+ error_count = 0;
+ if (yyparse() || error_count) {
+ if (minus_c)
+ croak("%s had compilation errors.\n", origfilename);
+ else {
+ croak("Execution of %s aborted due to compilation errors.\n",
+ origfilename);
+ }
+ }
+ curcop->cop_line = 0;
+ curstash = defstash;
+ preprocess = FALSE;
+ if (e_fp) {
+ fclose(e_fp);
+ e_fp = Nullfp;
+ (void)UNLINK(e_tmpname);
+ }
+
+ /* now that script is parsed, we can modify record separator */
+ SvREFCNT_dec(rs);
+ rs = SvREFCNT_inc(nrs);
+ sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
+
+ if (do_undump)
+ my_unexec();
+
+ if (dowarn)
+ gv_check(defstash);
+
+ LEAVE;
+ FREETMPS;
+
+#ifdef DEBUGGING_MSTATS
+ if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
+ dump_mstats("after compilation:");
+#endif
+
+ ENTER;
+ restartop = 0;
+ return 0;
+}
--- /dev/null
+PP(pp_range)
+{
+ if (GIMME == G_ARRAY)
+ return cCONDOP->op_true;
+ return SvTRUEx(PAD_SV(op->op_targ)) ? cCONDOP->op_false : cCONDOP->op_true;
+}
+
+pp_range is a CONDOP.
+In array context, it just returns op_true.
+In scalar context it checks the truth of targ and returns
+op_false if true, op_true if false.
+
+flip is an UNOP.
+It "looks after" its child which is always a pp_range CONDOP.
+In array context, it just returns the child's op_false.
+In scalar context, there are three possible outcomes:
+ (1) set child's targ to 1, our targ to 1 and return op_next.
+ (2) set child's targ to 1, our targ to 0, sp-- and return child's op_false.
+ (3) Blank targ and TOPs and return op_next.
+Case 1 happens for a "..." with a matching lineno... or true TOPs.
+Case 2 happens for a ".." with a matching lineno... or true TOPs.
+Case 3 happens for a non-matching lineno or false TOPs.
+
+ $a = lhs..rhs;
+
+ ,-------> range
+ ^ / \
+ | true/ \false
+ | / \
+ first| lhs rhs
+ | \ first /
+ ^--- flip <----- flop
+ \ /
+ \ /
+ sassign
+
+
+/* range */
+if (SvTRUE(curpad[op->op_targ]))
+ goto label(op_false);
+/* op_true */
+...
+/* flip */
+/* For "..." returns op_next. For ".." returns op_next or op_first->op_false */
+/* end of basic block */
+goto out;
+label(range op_false):
+...
+/* flop */
+out:
+...
--- /dev/null
+# The following doesn't work: if $foo_ir and $bar_ir aren't initialised
+# then when we hit the $bar += $foo_ir in the middle of the loop for the
+# first time, we trigger a load_int for $bar_ir from its backing SV.
+# We don't write-back the shadow variable into the SV at the end of the
+# loop (which we ought to cope with) and so the next time through the loop
+# we're in the wrong state.
+# my ($foo_ir, $bar_ir);
+use integer;
+# If we initialise explicitly here then we're OK since INT_VALID is then set
+# by the time we're in the loop and so we don't have to reload from the SV
+my $foo_ir = 0;
+my $bar_ir = 0;
+
+for ($foo_ir = 0; $foo_ir < 3000000; $foo_ir += 2) {
+ $bar_ir += $foo_ir;
+}
+print "\$foo_ir = $foo_ir, \$bar_ir = $bar_ir\n";
+#[local/src/B]nonesuch% time ./foo
+#$foo_ir = 3000000, $bar_ir = -564363104
+#2.260u 0.090s 0:02.44 96.3% 0+0k 0+0io 89pf+0w
+#[local/src/B]nonesuch% time perl foo.pl
+#$foo_ir = 3000000, $bar_ir = -564363104
+#73.250u 0.090s 1:13.49 99.7% 0+0k 0+0io 130pf+0w
--- /dev/null
+# The following doesn't work: if $foo_ir and $bar_ir aren't initialised
+# then when we hit the $bar += $foo_ir in the middle of the loop for the
+# first time, we trigger a load_int for $bar_ir from its backing SV.
+use integer;
+my $foo_ir;
+my $bar_ir;
+
+for ($foo_ir = 0; $foo_ir < 3000000; $foo_ir += 2) {
+ $bar_ir += $foo_ir;
+}
+print "\$foo_ir = $foo_ir, \$bar_ir = $bar_ir\n";
--- /dev/null
+use integer;
+my $foo_ir = 0;
+my $bar_ir = 0;
+
+while ($foo_ir < 3000000) {
+ $bar_ir += $foo_ir;
+ $foo_ir += 2;
+}
+print "\$foo_ir = $foo_ir, \$bar_ir = $bar_ir\n";
--- /dev/null
+sv_magic()
+----------
+av.c
+av_store()
+ Storing a non-undef element into an SMAGICAL array, av,
+ assigns the equivalent lowercase form of magic (of the first
+ MAGIC in the chain) to the value (with obj = av, name = 0 and
+ namlen = array index).
+
+gv.c
+gv_init()
+ Initialising gv assigns '*' magic to it with obj = gv, name =
+ GvNAME and namlen = GvNAMELEN.
+gv_fetchpv()
+ @ISA gets 'I' magic with obj = gv, zero name and namlen.
+ %OVERLOAD gets 'A' magic with obj = gv, zero name and namlen.
+ $1 to $9, $&, $`, $', $+ get '\0' magic with obj = gv,
+ name = GvNAME and namlen = len ( = 1 presumably).
+Gv_AMupdate()
+ Stashes for overload magic seem to get 'c' magic with obj = 0,
+ name = &amt and namlen = sizeof(amt).
+hv_magic(hv, gv, how)
+ Gives magic how to hv with obj = gv and zero name and namlen.
+
+mg.c
+mg_copy(sv, nsv, key, klen)
+ Traverses the magic chain of sv. Upper case forms of magic
+ (only) are copied across to nsv, preserving obj but using
+ name = key and namlen = klen.
+magic_setpos()
+ LvTARG of a PVLV gets 'g' magic with obj = name = 0 and namlen = pos.
+
+op.c
+mod()
+ PVLV operators give magic to their targs with
+ obj = name = namlen = 0. OP_POS gives '.', OP_VEC gives 'v'
+ and OP_SUBSTR gives 'x'.
+
+perl.c
+magicname(sym, name, namlen)
+ Fetches/creates a GV with name sym and gives it '\0' magic
+ with obj = gv, name and namlen as passed.
+init_postdump_symbols()
+ Elements of the environment get given SVs with 'e' magic.
+ obj = sv and name and namlen point to the actual string
+ within env.
+
+pp.c
+pp_av2arylen()
+ $#foo gives '#' magic to the new SV with obj = av and
+ name = namlen = 0.
+pp_study()
+ SV gets 'g' magic with obj = name = namlen = 0.
+pp_substr()
+ PVLV gets 'x' magic with obj = name = namlen = 0.
+pp_vec()
+ PVLV gets 'x' magic with obj = name = namlen = 0.
+
+pp_hot.c
+pp_match()
+ m//g gets 'g' magic with obj = name = namlen = 0.
+
+pp_sys.c
+pp_tie()
+ sv gets magic with obj = sv and name = namlen = 0.
+ If an HV or an AV, it gets 'P' magic, otherwise 'q' magic.
+pp_dbmopen()
+ 'P' magic for the HV just as with pp_tie().
+pp_sysread()
+ If tainting, the buffer SV gets 't' magic with
+ obj = name = namlen = 0.
+
+sv.c
+sv_setsv()
+ Doing sv_setsv(dstr, gv) gives '*' magic to dstr with
+ obj = dstr, name = GvNAME, namlen = GvNAMELEN.
+
+util.c
+fbm_compile()
+ The PVBM gets 'B' magic with obj = name = namlen = 0 and SvVALID
+ is set to indicate that the Boyer-Moore table is valid.
+ magic_setbm() just clears the SvVALID flag.
+
+hv_magic()
+----------
+
+gv.c
+gv_fetchfile()
+ With perldb, the HV of a gvfile gv gets 'L' magic with obj = gv.
+gv_fetchpv()
+ %SIG gets 'S' magic with obj = siggv.
+init_postdump_symbols()
+ %ENV gets 'E' magic with obj = envgv.
--- /dev/null
+dSP;
+dATARGET;
+dPOPTOPiirl;
+SETi( left + right );
+RETURN;
+
+
+register SV **sp = stack_sp;
+SV * targ = op->op_flags & OPf_STACKED ? sp[-1] : curpad[op->op_targ];
+IV right, left;
+Sv = *sp--;
+right = SvIOK(Sv) ? SvIVX(Sv) : sv_2iv(Sv);
+left = SvIOK(sv) ? SvIVX(*sp) : sv_2iv(*sp);
+sv_setiv(targ, left + right);
+if (SvSMAGICAL(targ))
+ mg_set(targ);
+*sp = targ;
+stack_sp = sp;
+return op->op_next;
--- /dev/null
+while ($i--) {
+ foo();
+}
+exit
+
+ PP code if i an int register if i an int but not a
+ (i.e. can't be register (i.e. can be
+ implicitly invalidated) implicitly invalidated)
+ nextstate
+ enterloop
+
+
+ loop:
+ gvsv GV (0xe6078) *i validates i validates i
+ postdec invalidates $i invalidates $i
+ and if_false goto out;
+ i valid; $i invalid i valid; $i invalid
+
+ i valid; $i invalid i valid; $i invalid
+ nextstate
+ pushmark
+ gv GV (0xe600c) *foo
+ entersub validates $i; invals i
+
+ unstack
+ goto loop:
+
+ i valid; $i invalid
+ out:
+ leaveloop
+ nextstate
+ exit
--- /dev/null
+Notes on porting the perl runtime PP engine.
+Importance: 1 = who cares?, 10 = vital
+Difficulty: 1 = trivial, 10 = very difficult. Level assumes a
+reasonable implementation of the SV and OP API already ported.
+
+OP Import Diff Comments
+null 10 1
+stub 10 1
+scalar 10 1
+pushmark 10 1 PUSHMARK
+wantarray 7 3 cxstack, dopoptosub
+const 10 1
+gvsv 10 1 save_scalar
+gv 10 1
+gelem 3 3
+padsv 10 2 SAVECLEARSV, provide_ref
+padav 10 2
+padhv 10 2
+padany 1 1
+pushre 7 3 pushes an op. Blech.
+rv2gv 6 5
+rv2sv 10 4
+av2arylen 7 3 sv_magic
+rv2cv 8 5 sv_2cv
+anoncode 7 6 cv_clone
+prototype 4 4 sv_2cv
+refgen 8 3
+srefgen 8 2
+ref 8 3
+bless 7 3
+backtick 5 4
+glob 5 2 do_readline
+readline 8 2 do_readline
+rcatline 8 2
+regcmaybe 8 1
+regcomp 8 9 pregcomp
+match 8 10
+subst 8 10
+substcont 8 7
+trans 7 4 do_trans
+sassign 10 3 mg_find, SvSETMAGIC
+aassign 10 5
+chop 8 3 do_chop
+schop 8 3 do_chop
+chomp 8 3 do_chomp
+schomp 8 3 do_chomp
+defined 10 2
+undef 10 3
+study 4 5
+pos 8 3 PVLV, mg_find
+preinc 10 2 sv_inc, SvSETMAGIC
+i_preinc
+predec 10 2 sv_dec, SvSETMAGIC
+i_predec
+postinc 10 2 sv_dec, SvSETMAGIC
+i_postinc
+postdec 10 2 sv_dec, SvSETMAGIC
+i_postdec
+pow 10 1
+multiply 10 1
+i_multiply 10 1
+divide 10 2
+i_divide 10 1
+modulo 10 2
+i_modulo 10 1
+repeat 6 4
+add 10 1
+i_add 10 1
+subtract 10 1
+i_subtract 10 1
+concat 10 2 mg_get
+stringify 10 2 sv_setpvn
+left_shift 10 1
+right_shift 10 1
+lt 10 1
+i_lt 10 1
+gt 10 1
+i_gt 10 1
+le 10 1
+i_le 10 1
+ge 10 1
+i_ge 10 1
+eq 10 1
+i_eq 10 1
+ne 10 1
+i_ne 10 1
+ncmp 10 1
+i_ncmp 10 1
+slt 10 2
+sgt 10 2
+sle 10 2
+sge 10 2
+seq 10 2 sv_eq
+sne 10 2
+scmp 10 2
+bit_and 10 2
+bit_xor 10 2
+bit_or 10 2
+negate 10 3
+i_negate 10 1
+not 10 1
+complement 10 3
+atan2 6 1
+sin 6 1
+cos 6 1
+rand 5 2
+srand 5 2
+exp 6 1
+log 6 2
+sqrt 6 2
+int 10 2
+hex 9 2
+oct 9 2
+abs 10 1
+length 10 1
+substr 10 4 PVLV
+vec 5 4
+index 9 3
+rindex 9 3
+sprintf 9 4 do_sprintf
+formline 6 7
+ord 6 2
+chr 6 2
+crypt 3 2
+ucfirst 6 2
+lcfirst 6 2
+uc 6 2
+lc 6 2
+quotemeta 6 3
+rv2av 10 3 save_svref, mg_get, save_ary
+aelemfast 10 2 av_fetch
+aelem 10 3
+aslice 9 4
+each 10 3 hv_iternext
+values 10 3 do_kv
+keys 10 3 do_kv
+delete 10 3
+exists 10 3
+rv2hv 10 3 save_svref, mg_get, save_ary, do_kv
+helem 10 3 save_svref, provide_ref
+hslice 9 4
+unpack 9 6 lengthy
+pack 9 6 lengthy
+split 9 9
+join 10 4 do_join
+list 10 2
+lslice 9 4
+anonlist 10 2
+anonhash 10 3
+splice 9 6
+push 10 2
+pop 10 2
+shift 10 2
+unshift 10 2
+sort 6 7
+reverse 9 4
+grepstart 6 5 modifies flow of control
+grepwhile 6 5 modifies flow of control
+mapstart 1 1
+mapwhile 6 5 modifies flow of control
+range 7 3 modifies flow of control
+flip 7 4 modifies flow of control
+flop 7 4 modifies flow of control
+and 10 3 modifies flow of control
+or 10 3 modifies flow of control
+xor
+cond_expr 10 3 modifies flow of control
+andassign 7 3 modifies flow of control
+orassign 7 3 modifies flow of control
+method 8 5
+entersub 10 7
+leavesub 10 5
+caller 2 8
+warn 9 3
+die 9 3
+reset 2 2
+lineseq 1 1
+nextstate 10 1 Update stack_sp from cxstack. FREETMPS.
+dbstate 3 7
+unstack
+enter 10 3 cxstack, ENTER, SAVETMPS, PUSHBLOCK
+leave 10 3 cxstack, SAVETMPS, LEAVE, POPBLOCK
+scope 1 1
+enteriter 9 4 cxstack
+iter 9 3 cxstack
+enterloop 10 4
+leaveloop 10 4
+return 10 5
+last 9 6
+next 9 6
+redo 9 6
+dump 1 9 pp_goto
+goto 6 9
+exit 9 2 my_exit
+open 9 5 do_open
+close 9 3 do_close
+pipe_op 7 4
+fileno 9 2
+umask 4 2
+binmode 4 2
+tie 5 5 pp_entersub
+untie 5 2 sv_unmagic
+tied 5 2
+dbmopen 4 5
+dbmclose 4 2
+sselect 4 4
+select 7 3
+getc 7 2
+read 8 2 pp_sysread
+enterwrite 4 4 doform
+leavewrite 4 5
+prtf 4 4 do_sprintf
+print 8 6
+sysopen 8 2
+sysread 8 4
+syswrite 8 4 pp_send
+send 8 4
+recv 8 4 pp_sysread
+eof 9 2
+tell 9 3
+seek 9 2
+truncate 8 3
+fcntl 8 4 pp_ioctl
+ioctl 8 4
+flock 8 2
+socket 5 3
+sockpair 5 3
+bind 5 3
+connect 5 3
+listen 5 3
+accept 5 3
+shutdown 5 2
+gsockopt 5 3 pp_ssockopt
+ssockopt 5 3
+getsockname 5 3 pp_getpeername
+getpeername 5 3
+lstat 5 4 pp_stat
+stat 5 4 lengthy
+ftrread 5 2 cando
+ftrwrite 5 2 cando
+ftrexec 5 2 cando
+fteread 5 2 cando
+ftewrite 5 2 cando
+fteexec 5 2 cando
+ftis 5 2 cando
+fteowned 5 2 cando
+ftrowned 5 2 cando
+ftzero 5 2 cando
+ftsize 5 2 cando
+ftmtime 5 2 cando
+ftatime 5 2 cando
+ftctime 5 2 cando
+ftsock 5 2 cando
+ftchr 5 2 cando
+ftblk 5 2 cando
+ftfile 5 2 cando
+ftdir 5 2 cando
+ftpipe 5 2 cando
+ftlink 5 2 cando
+ftsuid 5 2 cando
+ftsgid 5 2 cando
+ftsvtx 5 2 cando
+fttty 5 2 cando
+fttext 5 4
+ftbinary 5 4 fttext
+chdir
+chown
+chroot
+unlink
+chmod
+utime
+rename
+link
+symlink
+readlink
+mkdir
+rmdir
+open_dir
+readdir
+telldir
+seekdir
+rewinddir
+closedir
+fork
+wait
+waitpid
+system
+exec
+kill
+getppid
+getpgrp
+setpgrp
+getpriority
+setpriority
+time
+tms
+localtime
+gmtime
+alarm
+sleep
+shmget
+shmctl
+shmread
+shmwrite
+msgget
+msgctl
+msgsnd
+msgrcv
+semget
+semctl
+semop
+require 6 9 doeval
+dofile 6 9 doeval
+entereval 6 9 doeval
+leaveeval 6 5
+entertry 7 4 modifies flow of control
+leavetry 7 3
+ghbyname
+ghbyaddr
+ghostent
+gnbyname
+gnbyaddr
+gnetent
+gpbyname
+gpbynumber
+gprotoent
+gsbyname
+gsbyport
+gservent
+shostent
+snetent
+sprotoent
+sservent
+ehostent
+enetent
+eprotoent
+eservent
+gpwnam
+gpwuid
+gpwent
+spwent
+epwent
+ggrnam
+ggrgid
+ggrent
+sgrent
+egrent
+getlogin
+syscall
+
\ No newline at end of file
--- /dev/null
+pp_sort (LISTOP)
+
+If scalar context, just drop all arguments, push undef and return op_next.
+
+if OPf_STACKED is set then there's a comparison sub: either inline
+(in which case OPf_SPECIAL is set) or via a named sub (OPf_SPECIAL not set).
+For an inline sub, the sortcop is op->first->sibling->first->first->next. Eek.
+For a named sub, CvROOT(cv)->op_ppaddr (the pp_leave at the end of the sub) is
+saved for recovery at end-of-scope and replaced by pp_addr[OP_NULL]. Ick.
+Nulls are then weeded out whilst copying down the stack.
+
+If there's no comparison sub (and the array is non-trivial), we just make a
+bit of room on the stack (in case of signals) and call qsort with "sortcmp"
+as the C comparison function. Otherwise, with a comparison sub (and a
+non-trivial array), we fake up a new stack, switch to it, set up $a and $b
+and call qsort with C comparison function "sortcv".
--- /dev/null
+/* Typical code executed for a sub call. */
+
+PP(pp_entersub)
+{
+ dSP; dPOPss;
+ GV *gv;
+ HV *stash;
+ register CV *cv;
+ register CONTEXT *cx;
+ I32 gimme;
+
+ if (!sv) ...;
+ switch (SvTYPE(sv)) {
+ ...;
+ case SVt_PVGV:
+ if (!(cv = GvCV((GV*)sv))) ...;
+ break;
+ }
+
+ ENTER;
+ SAVETMPS;
+
+ if (!cv) ...;
+ if (!CvROOT(cv) && !CvXSUB(cv)) ...;
+ gimme = GIMME;
+ if ((op->op_private & OPpENTERSUB_DB) && ...) ...;
+ if (CvXSUB(cv)) ...; else {
+ dMARK;
+ register I32 items = SP - MARK;
+ I32 hasargs = (op->op_flags & OPf_STACKED) != 0;
+ AV* padlist = CvPADLIST(cv);
+ SV** svp = AvARRAY(padlist);
+ push_return(op->op_next);
+ PUSHBLOCK(cx, CXt_SUB, MARK);
+ PUSHSUB(cx);
+ CvDEPTH(cv)++;
+ if (CvDEPTH(cv) < 2)
+ (void)SvREFCNT_inc(cv);
+ else ...;
+ SAVESPTR(curpad);
+ curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
+ if (hasargs) {
+ AV* av = (AV*)curpad[0];
+ SV** ary;
+
+ if (AvREAL(av)) ...;
+ cx->blk_sub.savearray = GvAV(defgv);
+ cx->blk_sub.argarray = av;
+ GvAV(defgv) = cx->blk_sub.argarray;
+ ++MARK;
+ if (items > AvMAX(av) + 1) ...;
+ Copy(MARK,AvARRAY(av),items,SV*);
+ AvFILL(av) = items - 1;
+ while (items--) {
+ if (*MARK)
+ SvTEMP_off(*MARK);
+ MARK++;
+ }
+ }
+ RETURNOP(CvSTART(cv));
+ }
+}
--- /dev/null
+pp_subst PMOP (pp_hot.c)
+Returns op_next or cPMOP->op_pmreplroot.
+
+pp_substcont LOGOP (pp_ctl.c)
+Gets PMOP pm from cLOGOP->op_other.
+Returns pm->op_next or pm->op_pmreplstart.
+
+pmreplroot is pp_substcont (I think).
+
+sub pp_subst {
+ ...
+ my $sym = doop($op);
+ runtime sprintf("if (op == ((PMOP*)(%s))->op_pmreplroot) goto %s;",
+ $sym, label($op->op_pmreplroot));
+ push(@bblock_todo, $op->pmreplroot);
+ ...
+}
+
+sub pp_substcont {
+ ...
+ doop($op);
+ my $pmop = op->other;
+ my $restartsym = objsym($pmop->pmreplstart);
+ runtime sprintf("if (op == ((PMOP*)(%s))->op_pmreplstart) goto %s;",
+ $restartsym, label($pmop->pmreplstart));
+ return $pmop->next;
+}
--- /dev/null
+#!/bin/sh
+testdir=../perl5.002/t
+cwd=`pwd`
+if [ -f bperl ]; then
+ perl=./bperl
+else
+ perl="perl -Iblib/arch"
+fi
+for pl in ${1+"$@"}
+do
+ echo "***** $pl *****"
+ $perl -MO=Bytecode,-obtest $pl \
+ && (cd $testdir; $cwd/byteperl $cwd/btest)
+done
--- /dev/null
+#!/bin/sh
+testdir=../perl5.002/t
+cwd=`pwd`
+if [ -f bperl ]; then
+ perl=./bperl
+else
+ perl="perl -Iblib/arch"
+fi
+for pl in ${1+"$@"}
+do
+ echo "***** $pl *****"
+ $perl -MO=CC,-obtest.tc $pl \
+ && mv btest.tc btest.c \
+ && $perl cc_harness -O2 -o btest btest.c\
+ && echo Running... \
+ && (cd $testdir; $cwd/btest)
+done
--- /dev/null
+#!/bin/sh
+testdir=../perl5.002/t
+cwd=`pwd`
+if [ -f bperl ]; then
+ perl=./bperl
+else
+ perl="perl -Iblib/arch"
+fi
+for pl in ${1+"$@"}
+do
+ echo "***** $pl *****"
+ $perl -MO=C,-obtest.tc $pl \
+ && mv btest.tc btest.c \
+ && $perl cc_harness -o btest btest.c \
+ && (cd $testdir; $cwd/btest)
+done
--- /dev/null
+#!/bin/sh
+if [ -f bperl ]; then
+ perl=./bperl
+else
+ perl="perl -Iblib/arch"
+fi
+for pl in ${1+"$@"}
+do
+ echo "***** $pl *****"
+ $perl -MO=C,-obtest.tc $pl \
+ && mv btest.tc btest.c \
+ && $perl cc_harness -o btest btest.c \
+ && ./btest
+done
--- /dev/null
+#!/bin/sh
+if [ -f bperl ]; then
+ perl=./bperl
+else
+ perl="perl -Iblib/arch"
+fi
+for pl in ${1+"$@"}
+do
+ echo "***** $pl *****"
+ $perl -MO=Bytecode,-obtest $pl && ./byteperl btest
+done
--- /dev/null
+#!/bin/sh
+if [ -f bperl ]; then
+ perl=./bperl
+else
+ perl="perl -Iblib/arch"
+fi
+for pl in ${1+"$@"}
+do
+ echo "***** $pl *****"
+ $perl -MO=CC,-obtest.tc $pl \
+ && mv btest.tc btest.c \
+ && $perl cc_harness -O2 -o btest btest.c\
+ && ./btest
+done
--- /dev/null
+TYPEMAP
+
+B::OP T_OP_OBJ
+B::UNOP T_OP_OBJ
+B::BINOP T_OP_OBJ
+B::LOGOP T_OP_OBJ
+B::CONDOP T_OP_OBJ
+B::LISTOP T_OP_OBJ
+B::PMOP T_OP_OBJ
+B::SVOP T_OP_OBJ
+B::GVOP T_OP_OBJ
+B::PVOP T_OP_OBJ
+B::CVOP T_OP_OBJ
+B::LOOP T_OP_OBJ
+B::COP T_OP_OBJ
+
+B::SV T_SV_OBJ
+B::PV T_SV_OBJ
+B::IV T_SV_OBJ
+B::NV T_SV_OBJ
+B::PVMG T_SV_OBJ
+B::PVLV T_SV_OBJ
+B::BM T_SV_OBJ
+B::RV T_SV_OBJ
+B::GV T_SV_OBJ
+B::CV T_SV_OBJ
+B::HV T_SV_OBJ
+B::AV T_SV_OBJ
+B::IO T_SV_OBJ
+
+B::MAGIC T_MG_OBJ
+SSize_t T_IV
+STRLEN T_IV
+
+INPUT
+T_OP_OBJ
+ if (SvROK($arg)) {
+ IV tmp = SvIV((SV*)SvRV($arg));
+ $var = ($type) tmp;
+ }
+ else
+ croak(\"$var is not a reference\")
+
+T_SV_OBJ
+ if (SvROK($arg)) {
+ IV tmp = SvIV((SV*)SvRV($arg));
+ $var = ($type) tmp;
+ }
+ else
+ croak(\"$var is not a reference\")
+
+T_MG_OBJ
+ if (SvROK($arg)) {
+ IV tmp = SvIV((SV*)SvRV($arg));
+ $var = ($type) tmp;
+ }
+ else
+ croak(\"$var is not a reference\")
+
+OUTPUT
+T_OP_OBJ
+ sv_setiv(newSVrv($arg, cc_opclassname((OP*)$var)), (IV)$var);
+
+T_SV_OBJ
+ make_sv_object(($arg), ($var));
+
+
+T_MG_OBJ
+ sv_setiv(newSVrv($arg, "B::MAGIC"), (IV)$var);
projects / p5sagit/p5-mst-13.2.git / commitdiff