From: Malcolm Beattie Date: Sat, 3 May 1997 14:47:06 +0000 (+0000) Subject: Initial check-in of perl compiler. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=79ee829736f0059fc3a1c40f89ec42de04dad28e;p=p5sagit%2Fp5-mst-13.2.git Initial check-in of perl compiler. p4raw-id: //depot/perlext/Compiler@10 --- 79ee829736f0059fc3a1c40f89ec42de04dad28e diff --git a/Artistic b/Artistic new file mode 100644 index 0000000..11f4d82 --- /dev/null +++ b/Artistic @@ -0,0 +1,131 @@ + + + + + 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 diff --git a/B.pm b/B.pm new file mode 100644 index 0000000..4a9a202 --- /dev/null +++ b/B.pm @@ -0,0 +1,203 @@ +# 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; diff --git a/B.xs b/B.xs new file mode 100644 index 0000000..a89b530 --- /dev/null +++ b/B.xs @@ -0,0 +1,1028 @@ +/* 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)); + } + } diff --git a/B/Asmdata.pm b/B/Asmdata.pm new file mode 100644 index 0000000..bcfa0cc --- /dev/null +++ b/B/Asmdata.pm @@ -0,0 +1,152 @@ +# +# 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; diff --git a/B/Assembler.pm b/B/Assembler.pm new file mode 100644 index 0000000..0729b90 --- /dev/null +++ b/B/Assembler.pm @@ -0,0 +1,207 @@ +# 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; diff --git a/B/Bblock.pm b/B/Bblock.pm new file mode 100644 index 0000000..cd43d37 --- /dev/null +++ b/B/Bblock.pm @@ -0,0 +1,149 @@ +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; diff --git a/B/Bytecode.pm b/B/Bytecode.pm new file mode 100644 index 0000000..9e763de --- /dev/null +++ b/B/Bytecode.pm @@ -0,0 +1,757 @@ +# 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; diff --git a/B/C.pm b/B/C.pm new file mode 100644 index 0000000..338b9c9 --- /dev/null +++ b/B/C.pm @@ -0,0 +1,1197 @@ +# 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; diff --git a/B/CC.pm b/B/CC.pm new file mode 100644 index 0000000..a25e7e2 --- /dev/null +++ b/B/CC.pm @@ -0,0 +1,1466 @@ +# 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; diff --git a/B/Debug.pm b/B/Debug.pm new file mode 100644 index 0000000..859e6f1 --- /dev/null +++ b/B/Debug.pm @@ -0,0 +1,258 @@ +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; diff --git a/B/Disassembler.pm b/B/Disassembler.pm new file mode 100644 index 0000000..36db354 --- /dev/null +++ b/B/Disassembler.pm @@ -0,0 +1,144 @@ +# 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; diff --git a/B/Showlex.pm b/B/Showlex.pm new file mode 100644 index 0000000..9cf8ecc --- /dev/null +++ b/B/Showlex.pm @@ -0,0 +1,58 @@ +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; diff --git a/B/Stackobj.pm b/B/Stackobj.pm new file mode 100644 index 0000000..fa9de7d --- /dev/null +++ b/B/Stackobj.pm @@ -0,0 +1,280 @@ +# 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; diff --git a/B/Terse.pm b/B/Terse.pm new file mode 100644 index 0000000..eec2b00 --- /dev/null +++ b/B/Terse.pm @@ -0,0 +1,132 @@ +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; diff --git a/B/Xref.pm b/B/Xref.pm new file mode 100644 index 0000000..8a29ba3 --- /dev/null +++ b/B/Xref.pm @@ -0,0 +1,391 @@ +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 + object2 C + ... + Package package2 + ... + +Each B section reports on a single file. Each B 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 of each variable, +subroutine or format with the special case "(lexicals)" meaning +lexical variables. Each B name (implicitly qualified by its +containing B) 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 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) 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 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 option prints the object on the top of the stack as it's +being tracked. The C 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; diff --git a/Copying b/Copying new file mode 100644 index 0000000..3c68f02 --- /dev/null +++ b/Copying @@ -0,0 +1,248 @@ + 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. + + 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. + + 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. + + 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 + + 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. + + + Copyright (C) 19yy + + 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. + + , 1 April 1989 + Ty Coon, President of Vice + +That's all there is to it! diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..5ac4e8e --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,44 @@ +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 +} diff --git a/NOTES b/NOTES new file mode 100644 index 0000000..52910d2 --- /dev/null +++ b/NOTES @@ -0,0 +1,155 @@ +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. diff --git a/O.pm b/O.pm new file mode 100644 index 0000000..cc9f7f9 --- /dev/null +++ b/O.pm @@ -0,0 +1,23 @@ +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; + diff --git a/README b/README new file mode 100644 index 0000000..b1bffce --- /dev/null +++ b/README @@ -0,0 +1,317 @@ + 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 diff --git a/TESTS b/TESTS new file mode 100644 index 0000000..bf5d20d --- /dev/null +++ b/TESTS @@ -0,0 +1,78 @@ +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 diff --git a/TESTS.alpha2 b/TESTS.alpha2 new file mode 100644 index 0000000..b7ecfc1 --- /dev/null +++ b/TESTS.alpha2 @@ -0,0 +1,78 @@ +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 diff --git a/Todo b/Todo new file mode 100644 index 0000000..495be2e --- /dev/null +++ b/Todo @@ -0,0 +1,37 @@ +* 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 diff --git a/assemble b/assemble new file mode 100755 index 0000000..491210e --- /dev/null +++ b/assemble @@ -0,0 +1,24 @@ +#!./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 @_ }); diff --git a/bytecode.h b/bytecode.h new file mode 100644 index 0000000..2cdc028 --- /dev/null +++ b/bytecode.h @@ -0,0 +1,163 @@ +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) diff --git a/bytecode.pl b/bytecode.pl new file mode 100644 index 0000000..359110d --- /dev/null +++ b/bytecode.pl @@ -0,0 +1,370 @@ +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 () { + 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 diff --git a/byteperl.c b/byteperl.c new file mode 100644 index 0000000..e81a45b --- /dev/null +++ b/byteperl.c @@ -0,0 +1,104 @@ +#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() +{ +} diff --git a/byterun.c b/byterun.c new file mode 100644 index 0000000..1ff3239 --- /dev/null +++ b/byterun.c @@ -0,0 +1,870 @@ +/* + * 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 */ + } + } +} diff --git a/byterun.h b/byterun.h new file mode 100644 index 0000000..fee8eda --- /dev/null +++ b/byterun.h @@ -0,0 +1,187 @@ +/* + * 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 */ +; diff --git a/cc_harness b/cc_harness new file mode 100644 index 0000000..6db623a --- /dev/null +++ b/cc_harness @@ -0,0 +1,11 @@ +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; diff --git a/cc_runtime.h b/cc_runtime.h new file mode 100644 index 0000000..b7658a9 --- /dev/null +++ b/cc_runtime.h @@ -0,0 +1,75 @@ +#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) diff --git a/ccop.c b/ccop.c new file mode 100644 index 0000000..84df353 --- /dev/null +++ b/ccop.c @@ -0,0 +1,557 @@ +/* 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]; +} + diff --git a/ccop.h b/ccop.h new file mode 100644 index 0000000..b170b63 --- /dev/null +++ b/ccop.h @@ -0,0 +1,369 @@ +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 diff --git a/disassemble b/disassemble new file mode 100755 index 0000000..12483f7 --- /dev/null +++ b/disassemble @@ -0,0 +1,23 @@ +#!./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); diff --git a/old/README.feb11 b/old/README.feb11 new file mode 100644 index 0000000..11e2fce --- /dev/null +++ b/old/README.feb11 @@ -0,0 +1,137 @@ +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 diff --git a/old/TESTS.mar11 b/old/TESTS.mar11 new file mode 100644 index 0000000..d3678fb --- /dev/null +++ b/old/TESTS.mar11 @@ -0,0 +1,74 @@ +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) diff --git a/old/TESTS.mar20 b/old/TESTS.mar20 new file mode 100644 index 0000000..8b6bac7 --- /dev/null +++ b/old/TESTS.mar20 @@ -0,0 +1,70 @@ +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) diff --git a/old/TESTS.may11 b/old/TESTS.may11 new file mode 100644 index 0000000..aeedef9 --- /dev/null +++ b/old/TESTS.may11 @@ -0,0 +1,73 @@ +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) diff --git a/old/TESTS.pre-jul27 b/old/TESTS.pre-jul27 new file mode 100644 index 0000000..98d129a --- /dev/null +++ b/old/TESTS.pre-jul27 @@ -0,0 +1,75 @@ +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 diff --git a/op.patch b/op.patch new file mode 100644 index 0000000..1add385 --- /dev/null +++ b/op.patch @@ -0,0 +1,19 @@ +*** 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) { diff --git a/ramblings/cc.notes b/ramblings/cc.notes new file mode 100644 index 0000000..47bd65a --- /dev/null +++ b/ramblings/cc.notes @@ -0,0 +1,32 @@ +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. + diff --git a/ramblings/curcop.runtime b/ramblings/curcop.runtime new file mode 100644 index 0000000..9b8b7d5 --- /dev/null +++ b/ramblings/curcop.runtime @@ -0,0 +1,39 @@ +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 diff --git a/ramblings/dontparse.c b/ramblings/dontparse.c new file mode 100644 index 0000000..62f8315 --- /dev/null +++ b/ramblings/dontparse.c @@ -0,0 +1,142 @@ +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; +} diff --git a/ramblings/flip-flop b/ramblings/flip-flop new file mode 100644 index 0000000..183d541 --- /dev/null +++ b/ramblings/flip-flop @@ -0,0 +1,51 @@ +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: +... diff --git a/ramblings/foo.bench b/ramblings/foo.bench new file mode 100644 index 0000000..3ffae08 --- /dev/null +++ b/ramblings/foo.bench @@ -0,0 +1,23 @@ +# 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 diff --git a/ramblings/foo2.bench b/ramblings/foo2.bench new file mode 100644 index 0000000..f0b6dd9 --- /dev/null +++ b/ramblings/foo2.bench @@ -0,0 +1,11 @@ +# 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"; diff --git a/ramblings/foo3.bench b/ramblings/foo3.bench new file mode 100644 index 0000000..ee3955e --- /dev/null +++ b/ramblings/foo3.bench @@ -0,0 +1,9 @@ +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"; diff --git a/ramblings/magic b/ramblings/magic new file mode 100644 index 0000000..e41930a --- /dev/null +++ b/ramblings/magic @@ -0,0 +1,93 @@ +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. diff --git a/ramblings/pp_i_add b/ramblings/pp_i_add new file mode 100644 index 0000000..cb9dbe0 --- /dev/null +++ b/ramblings/pp_i_add @@ -0,0 +1,19 @@ +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; diff --git a/ramblings/reg.alloc b/ramblings/reg.alloc new file mode 100644 index 0000000..7fd69f2 --- /dev/null +++ b/ramblings/reg.alloc @@ -0,0 +1,32 @@ +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 diff --git a/ramblings/runtime.porting b/ramblings/runtime.porting new file mode 100644 index 0000000..4699b25 --- /dev/null +++ b/ramblings/runtime.porting @@ -0,0 +1,350 @@ +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 diff --git a/ramblings/sort.notes b/ramblings/sort.notes new file mode 100644 index 0000000..55d393f --- /dev/null +++ b/ramblings/sort.notes @@ -0,0 +1,16 @@ +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". diff --git a/ramblings/sub.call b/ramblings/sub.call new file mode 100644 index 0000000..ed8f165 --- /dev/null +++ b/ramblings/sub.call @@ -0,0 +1,62 @@ +/* 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)); + } +} diff --git a/ramblings/subst.notes b/ramblings/subst.notes new file mode 100644 index 0000000..7eda080 --- /dev/null +++ b/ramblings/subst.notes @@ -0,0 +1,27 @@ +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; +} diff --git a/run_bytecode_test b/run_bytecode_test new file mode 100755 index 0000000..62eca5a --- /dev/null +++ b/run_bytecode_test @@ -0,0 +1,14 @@ +#!/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 diff --git a/run_cc_test b/run_cc_test new file mode 100755 index 0000000..8781ec9 --- /dev/null +++ b/run_cc_test @@ -0,0 +1,17 @@ +#!/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 diff --git a/run_test b/run_test new file mode 100755 index 0000000..f13df36 --- /dev/null +++ b/run_test @@ -0,0 +1,16 @@ +#!/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 diff --git a/test_harness b/test_harness new file mode 100755 index 0000000..f930c35 --- /dev/null +++ b/test_harness @@ -0,0 +1,14 @@ +#!/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 diff --git a/test_harness_bytecode b/test_harness_bytecode new file mode 100755 index 0000000..d0aba85 --- /dev/null +++ b/test_harness_bytecode @@ -0,0 +1,11 @@ +#!/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 diff --git a/test_harness_cc b/test_harness_cc new file mode 100755 index 0000000..da58b78 --- /dev/null +++ b/test_harness_cc @@ -0,0 +1,14 @@ +#!/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 diff --git a/typemap b/typemap new file mode 100644 index 0000000..ed4aecc --- /dev/null +++ b/typemap @@ -0,0 +1,69 @@ +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);