--- /dev/null
+typedef char *pvcontents;
+typedef char *strconst;
+typedef U32 PV;
+typedef char *op_tr_array;
+typedef int comment;
+typedef SV *svindex;
+typedef OP *opindex;
+typedef IV IV64;
+
+EXT int iv_overflows INIT(0);
+void *bset_obj_store _((void *, I32));
+void freadpv _((U32, void *));
+
+EXT SV *sv;
+#ifndef USE_THREADS
+EXT OP *op;
+#endif
+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(o, arg) \
+ ((PMOP*)o)->op_pmregexp = arg ? \
+ pregcomp(arg, arg + pv.xpv_cur, ((PMOP*)o)) : 0
+#define BSET_newsv(sv, arg) sv = NEWSV(666,0); SvUPGRADE(sv, arg)
+#define BSET_newop(o, arg) o = (OP*)safemalloc(optype_size[arg])
+#define BSET_newopn(o, arg) do { \
+ OP *oldop = o; \
+ BSET_newop(o, arg); \
+ oldop->op_next = o; \
+ } 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(o, arg) do { \
+ o->op_type = arg; \
+ if (arg == OP_MAPSTART) \
+ arg = OP_GREPSTART; \
+ o->op_ppaddr = ppaddr[arg]; \
+ } while (0)
+#define BSET_op_ppaddr(o, arg) croak("op_ppaddr not yet implemented")
+#define BSET_curpad(pad, arg) pad = AvARRAY(arg)
+
+#define BSET_OBJ_STORE(obj, ix) \
+ (I32)ix > obj_list_fill ? \
+ bset_obj_store(obj, (I32)ix) : (obj_list[ix] = obj)
--- /dev/null
+use strict;
+my %alias_to = (
+ U32 => [qw(PADOFFSET STRLEN)],
+ I32 => [qw(SSize_t long)],
+ U16 => [qw(OPCODE line_t short)],
+ U8 => [qw(char)],
+ objindex => [qw(svindex opindex)]
+);
+
+my @optype= qw(OP UNOP BINOP LOGOP CONDOP LISTOP PMOP SVOP GVOP PVOP LOOP COP);
+
+# Nullsv *must* come first in the following so that the condition
+# ($$sv == 0) can continue to be used to test (sv == Nullsv).
+my @specialsv = qw(Nullsv &sv_undef &sv_yes &sv_no);
+
+my (%alias_from, $from, $tos);
+while (($from, $tos) = each %alias_to) {
+ map { $alias_from{$_} = $from } @$tos;
+}
+
+my $c_header = <<'EOT';
+/*
+ * Copyright (c) 1996, 1997 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 "B/Asmdata.pm") {
+ rename("B/Asmdata.pm", "B/Asmdata.pm.old");
+}
+
+#
+# Start with boilerplate for Asmdata.pm
+#
+open(ASMDATA_PM, ">B/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 */
+{
+ dTHR;
+ int insn;
+ while ((insn = FGETC()) != EOF) {
+ switch (insn) {
+EOT
+
+
+my (@insn_name, $insn_num, $insn, $lvalue, $argtype, $flags, $fundtype);
+
+while (<DATA>) {
+ chop;
+ s/#.*//; # remove comments
+ next unless length;
+ if (/^%number\s+(.*)/) {
+ $insn_num = $1;
+ next;
+ } elsif (/%enum\s+(.*?)\s+(.*)/) {
+ create_enum($1, $2); # must come before instructions
+ next;
+ }
+ ($insn, $lvalue, $argtype, $flags) = split;
+ $insn_name[$insn_num] = $insn;
+ $fundtype = $alias_from{$argtype} || $argtype;
+
+ #
+ # Add the case statement and code for the bytecode interpreter in byterun.c
+ #
+ printf BYTERUN_C "\t case INSN_%s:\t\t/* %d */\n\t {\n",
+ uc($insn), $insn_num;
+ my $optarg = $argtype eq "none" ? "" : ", arg";
+ if ($optarg) {
+ printf BYTERUN_C "\t\t$argtype arg;\n\t\tBGET_%s(arg);\n", $fundtype;
+ }
+ if ($flags =~ /x/) {
+ print BYTERUN_C "\t\tBSET_$insn($lvalue$optarg);\n";
+ } elsif ($flags =~ /s/) {
+ # Store instructions store to obj_list[arg]. "lvalue" field is rvalue.
+ print BYTERUN_C "\t\tBSET_OBJ_STORE($lvalue$optarg);\n";
+ }
+ elsif ($optarg && $lvalue ne "none") {
+ print BYTERUN_C "\t\t$lvalue = arg;\n";
+ }
+ print BYTERUN_C "\t\tbreak;\n\t }\n";
+
+ #
+ # Add the initialiser line for %insn_data in Asmdata.pm
+ #
+ print ASMDATA_PM <<"EOT";
+\$insn_data{$insn} = [$insn_num, \\&PUT_$fundtype, "GET_$fundtype"];
+EOT
+
+ # Find the next unused instruction number
+ do { $insn_num++ } while $insn_name[$insn_num];
+}
+
+#
+# Finish off byterun.c
+#
+print BYTERUN_C <<'EOT';
+ default:
+ croak("Illegal bytecode instruction %d\n", insn);
+ /* NOTREACHED */
+ }
+ }
+}
+EOT
+
+#
+# Write the instruction and optype enum constants into byterun.h
+#
+open(BYTERUN_H, ">byterun.h") or die "byterun.h: $!";
+print BYTERUN_H $c_header, <<'EOT';
+#ifdef INDIRECT_BGET_MACROS
+struct bytestream {
+ void *data;
+ int (*fgetc)(void *);
+ int (*fread)(char *, size_t, size_t, void*);
+ void (*freadpv)(U32, void*);
+};
+void freadpv _((U32, void *));
+void byterun _((struct bytestream));
+#else
+void byterun _((FILE *));
+#endif /* INDIRECT_BGET_MACROS */
+
+#ifndef PATCHLEVEL
+#include "patchlevel.h"
+#endif
+#if PATCHLEVEL < 4 || (PATCHLEVEL == 4 && SUBVERSION < 50)
+#define dTHR extern int errno
+#endif
+
+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];
+#define INIT_SPECIALSV_LIST STMT_START { \
+EOT
+for ($i = 0; $i < @specialsv; $i++) {
+ print BYTERUN_H "specialsv_list[$i] = $specialsv[$i]; \\\n";
+}
+print BYTERUN_H <<'EOT';
+} STMT_END
+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 *(SV**)&IoTOP_GV(sv) svindex
+xio_fmt_name IoFMT_NAME(sv) pvcontents
+xio_fmt_gv *(SV**)&IoFMT_GV(sv) svindex
+xio_bottom_name IoBOTTOM_NAME(sv) pvcontents
+xio_bottom_gv *(SV**)&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 *(SV**)&CvGV(sv) svindex
+xcv_filegv *(SV**)&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 AvFILLp(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_pmflags cPMOP->op_pmflags U16
+op_pmpermflags cPMOP->op_pmpermflags U16
+op_sv cSVOP->op_sv svindex
+op_gv *(SV**)&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 *(SV**)&cCOP->cop_filegv svindex
+cop_seq cCOP->cop_seq U32
+cop_arybase cCOP->cop_arybase I32
+cop_line cCOP->cop_line line_t
+main_start main_start opindex
+main_root main_root opindex
+curpad curpad svindex x
--- /dev/null
+#define DOOP(ppname) PUTBACK; op = ppname(ARGS); 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)
+
+/* Anyone using eval "" deserves this mess */
+#define PP_EVAL(ppaddr, nxt) do { \
+ dJMPENV; \
+ int ret; \
+ PUTBACK; \
+ JMPENV_PUSH(ret); \
+ switch (ret) { \
+ case 0: \
+ op = ppaddr(ARGS); \
+ retstack[retstack_ix - 1] = Nullop; \
+ if (op != nxt) runops(); \
+ JMPENV_POP; \
+ break; \
+ case 1: JMPENV_POP; JMPENV_JUMP(1); \
+ case 2: JMPENV_POP; JMPENV_JUMP(2); \
+ case 3: \
+ JMPENV_POP; \
+ if (restartop != nxt) \
+ JMPENV_JUMP(3); \
+ } \
+ op = nxt; \
+ SPAGAIN; \
+ } while (0)
+
+#define PP_ENTERTRY(jmpbuf,label) do { \
+ dJMPENV; \
+ int ret; \
+ JMPENV_PUSH(ret); \
+ switch (ret) { \
+ case 1: JMPENV_POP; JMPENV_JUMP(1); \
+ case 2: JMPENV_POP; JMPENV_JUMP(2); \
+ case 3: JMPENV_POP; SPAGAIN; goto label;\
+ } \
+ } while (0)
--- /dev/null
+/* B.xs
+ *
+ * Copyright (c) 1996 Malcolm Beattie
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+#include "INTERN.h"
+#include "bytecode.h"
+#include "byterun.h"
+
+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",
+};
+
+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;
+
+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 int walkoptree_debug = 0; /* Flag for walkoptree debug hook */
+
+static opclass
+cc_opclass(OP *o)
+{
+ if (!o)
+ return OPc_NULL;
+
+ if (o->op_type == 0)
+ return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
+
+ if (o->op_type == OP_SASSIGN)
+ return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
+
+ switch (opargs[o->op_type] & OA_CLASS_MASK) {
+ case OA_BASEOP:
+ return OPc_BASEOP;
+
+ case OA_UNOP:
+ return OPc_UNOP;
+
+ case OA_BINOP:
+ return OPc_BINOP;
+
+ case OA_LOGOP:
+ return OPc_LOGOP;
+
+ case OA_CONDOP:
+ return OPc_CONDOP;
+
+ case OA_LISTOP:
+ return OPc_LISTOP;
+
+ case OA_PMOP:
+ return OPc_PMOP;
+
+ case OA_SVOP:
+ return OPc_SVOP;
+
+ case OA_GVOP:
+ return OPc_GVOP;
+
+ case OA_PVOP:
+ return OPc_PVOP;
+
+ case OA_LOOP:
+ return OPc_LOOP;
+
+ case OA_COP:
+ return OPc_COP;
+
+ case OA_BASEOP_OR_UNOP:
+ /*
+ * 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.
+ */
+ return ((o->op_flags & OPf_SPECIAL) ? OPc_BASEOP :
+ (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP);
+
+ case OA_FILESTATOP:
+ /*
+ * 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).
+ */
+ return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
+ (o->op_flags & OPf_REF) ? OPc_GVOP : OPc_BASEOP);
+
+ case OA_LOOPEXOP:
+ /*
+ * 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.
+ */
+ if (o->op_flags & OPf_STACKED)
+ return OPc_UNOP;
+ else if (o->op_flags & OPf_SPECIAL)
+ return OPc_BASEOP;
+ else
+ return OPc_PVOP;
+ }
+ warn("can't determine class of operator %s, assuming BASEOP\n",
+ op_name[o->op_type]);
+ return OPc_BASEOP;
+}
+
+static char *
+cc_opclassname(OP *o)
+{
+ return opclassnames[cc_opclass(o)];
+}
+
+static SV *
+make_sv_object(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(SV *arg, MAGIC *mg)
+{
+ sv_setiv(newSVrv(arg, "B::MAGIC"), (IV)mg);
+ return arg;
+}
+
+static SV *
+cstring(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 *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(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(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(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(void *data)
+{
+ char **strp = (char **)data;
+ return *(*strp)++;
+}
+
+static int fread_fromstring(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(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(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(FILE *fp)
+{
+ byterun(fp);
+}
+
+void byteload_string(char *str)
+{
+ croak("Must compile with -DINDIRECT_BGET_MACROS for byteload_string");
+}
+#endif /* INDIRECT_BGET_MACROS */
+
+void
+walkoptree(SV *opsv, char *method)
+{
+ dSP;
+ OP *o;
+
+ if (!SvROK(opsv))
+ croak("opsv is not a reference");
+ opsv = sv_mortalcopy(opsv);
+ o = (OP*)SvIV((SV*)SvRV(opsv));
+ if (walkoptree_debug) {
+ PUSHMARK(sp);
+ XPUSHs(opsv);
+ PUTBACK;
+ perl_call_method("walkoptree_debug", G_DISCARD);
+ }
+ PUSHMARK(sp);
+ XPUSHs(opsv);
+ PUTBACK;
+ perl_call_method(method, G_DISCARD);
+ if (o && (o->op_flags & OPf_KIDS)) {
+ OP *kid;
+ for (kid = ((UNOP*)o)->op_first; kid; kid = kid->op_sibling) {
+ /* Use the same opsv. Rely on methods not to mess it up. */
+ sv_setiv(newSVrv(opsv, cc_opclassname(kid)), (IV)kid);
+ walkoptree(opsv, method);
+ }
+ }
+}
+
+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
+
+BOOT:
+ INIT_SPECIALSV_LIST;
+
+#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
+walkoptree(opsv, method)
+ SV * opsv
+ char * method
+
+int
+walkoptree_debug(...)
+ CODE:
+ RETVAL = walkoptree_debug;
+ if (items > 0 && SvTRUE(ST(1)))
+ walkoptree_debug = 1;
+ OUTPUT:
+ RETVAL
+
+int
+byteload_fh(fp)
+ FILE * fp
+ CODE:
+ byteload_fh(fp);
+ RETVAL = 1;
+ OUTPUT:
+ RETVAL
+
+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 < maxo) {
+ sv_setpvn(ST(0), "pp_", 3);
+ sv_catpv(ST(0), op_name[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
+
+void
+threadsv_names()
+ PPCODE:
+#ifdef USE_THREADS
+ int i;
+ STRLEN len = strlen(threadsv_names);
+
+ EXTEND(sp, len);
+ for (i = 0; i < len; i++)
+ PUSHs(sv_2mortal(newSVpv(&threadsv_names[i], 1)));
+#endif
+
+
+#define OP_next(o) o->op_next
+#define OP_sibling(o) o->op_sibling
+#define OP_desc(o) op_desc[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
+ CODE:
+ ST(0) = sv_newmortal();
+ sv_setpvn(ST(0), "pp_", 3);
+ sv_catpv(ST(0), op_name[o->op_type]);
+
+char *
+OP_desc(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_pmflags(o) o->op_pmflags
+#define PMOP_pmpermflags(o) o->op_pmpermflags
+
+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
+
+U16
+PMOP_pmflags(o)
+ B::PMOP o
+
+U16
+PMOP_pmpermflags(o)
+ B::PMOP o
+
+void
+PMOP_precomp(o)
+ B::PMOP o
+ REGEXP * rx = NO_INIT
+ CODE:
+ ST(0) = sv_newmortal();
+ rx = o->op_pmregexp;
+ if (rx)
+ sv_setpvn(ST(0), rx->precomp, rx->prelen);
+
+#define SVOP_sv(o) o->op_sv
+
+MODULE = B PACKAGE = B::SVOP PREFIX = SVOP_
+
+
+B::SV
+SVOP_sv(o)
+ B::SVOP o
+
+#define GVOP_gv(o) o->op_gv
+
+MODULE = B PACKAGE = B::GVOP PREFIX = GVOP_
+
+
+B::GV
+GVOP_gv(o)
+ B::GVOP o
+
+MODULE = B PACKAGE = B::PVOP PREFIX = PVOP_
+
+void
+PVOP_pv(o)
+ B::PVOP o
+ CODE:
+ /*
+ * OP_TRANS uses op_pv to point to a table of 256 shorts
+ * whereas other PVOPs point to a null terminated string.
+ */
+ ST(0) = sv_2mortal(newSVpv(o->op_pv, (o->op_type == OP_TRANS) ?
+ 256 * sizeof(short) : 0));
+
+#define LOOP_redoop(o) o->op_redoop
+#define LOOP_nextop(o) o->op_nextop
+#define LOOP_lastop(o) o->op_lastop
+
+MODULE = B PACKAGE = B::LOOP PREFIX = LOOP_
+
+
+B::OP
+LOOP_redoop(o)
+ B::LOOP o
+
+B::OP
+LOOP_nextop(o)
+ B::LOOP o
+
+B::OP
+LOOP_lastop(o)
+ B::LOOP o
+
+#define COP_label(o) o->cop_label
+#define COP_stash(o) o->cop_stash
+#define COP_filegv(o) o->cop_filegv
+#define COP_cop_seq(o) o->cop_seq
+#define COP_arybase(o) o->cop_arybase
+#define COP_line(o) o->cop_line
+
+MODULE = B PACKAGE = B::COP PREFIX = COP_
+
+char *
+COP_label(o)
+ B::COP o
+
+B::HV
+COP_stash(o)
+ B::COP o
+
+B::GV
+COP_filegv(o)
+ B::COP o
+
+U32
+COP_cop_seq(o)
+ B::COP o
+
+I32
+COP_arybase(o)
+ B::COP o
+
+U16
+COP_line(o)
+ B::COP o
+
+MODULE = B PACKAGE = B::SV PREFIX = Sv
+
+U32
+SvREFCNT(sv)
+ B::SV sv
+
+U32
+SvFLAGS(sv)
+ B::SV sv
+
+MODULE = B PACKAGE = B::IV PREFIX = Sv
+
+IV
+SvIV(sv)
+ B::IV sv
+
+IV
+SvIVX(sv)
+ B::IV sv
+
+MODULE = B PACKAGE = B::IV
+
+#define needs64bits(sv) ((I32)SvIVX(sv) != SvIVX(sv))
+
+int
+needs64bits(sv)
+ B::IV sv
+
+void
+packiv(sv)
+ B::IV sv
+ CODE:
+ if (sizeof(IV) == 8) {
+ U32 wp[2];
+ IV iv = SvIVX(sv);
+ /*
+ * The following way of spelling 32 is to stop compilers on
+ * 32-bit architectures from moaning about the shift count
+ * being >= the width of the type. Such architectures don't
+ * reach this code anyway (unless sizeof(IV) > 8 but then
+ * everything else breaks too so I'm not fussed at the moment).
+ */
+ wp[0] = htonl(((U32)iv) >> (sizeof(IV)*4));
+ wp[1] = htonl(iv & 0xffffffff);
+ ST(0) = sv_2mortal(newSVpv((char *)wp, 8));
+ } else {
+ U32 w = htonl((U32)SvIVX(sv));
+ ST(0) = sv_2mortal(newSVpv((char *)&w, 4));
+ }
+
+MODULE = B PACKAGE = B::NV PREFIX = Sv
+
+double
+SvNV(sv)
+ B::NV sv
+
+double
+SvNVX(sv)
+ B::NV sv
+
+MODULE = B PACKAGE = B::RV PREFIX = Sv
+
+B::SV
+SvRV(sv)
+ B::RV sv
+
+MODULE = B PACKAGE = B::PV PREFIX = Sv
+
+void
+SvPV(sv)
+ B::PV sv
+ CODE:
+ ST(0) = sv_newmortal();
+ sv_setpvn(ST(0), SvPVX(sv), SvCUR(sv));
+
+MODULE = B PACKAGE = B::PVMG PREFIX = Sv
+
+void
+SvMAGIC(sv)
+ B::PVMG sv
+ MAGIC * mg = NO_INIT
+ PPCODE:
+ for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
+ XPUSHs(make_mg_object(sv_newmortal(), mg));
+
+MODULE = B PACKAGE = B::PVMG
+
+B::HV
+SvSTASH(sv)
+ B::PVMG sv
+
+#define MgMOREMAGIC(mg) mg->mg_moremagic
+#define MgPRIVATE(mg) mg->mg_private
+#define MgTYPE(mg) mg->mg_type
+#define MgFLAGS(mg) mg->mg_flags
+#define MgOBJ(mg) mg->mg_obj
+
+MODULE = B PACKAGE = B::MAGIC PREFIX = Mg
+
+B::MAGIC
+MgMOREMAGIC(mg)
+ B::MAGIC mg
+
+U16
+MgPRIVATE(mg)
+ B::MAGIC mg
+
+char
+MgTYPE(mg)
+ B::MAGIC mg
+
+U8
+MgFLAGS(mg)
+ B::MAGIC mg
+
+B::SV
+MgOBJ(mg)
+ B::MAGIC mg
+
+void
+MgPTR(mg)
+ B::MAGIC mg
+ CODE:
+ ST(0) = sv_newmortal();
+ if (mg->mg_ptr)
+ sv_setpvn(ST(0), mg->mg_ptr, mg->mg_len);
+
+MODULE = B PACKAGE = B::PVLV PREFIX = Lv
+
+U32
+LvTARGOFF(sv)
+ B::PVLV sv
+
+U32
+LvTARGLEN(sv)
+ B::PVLV sv
+
+char
+LvTYPE(sv)
+ B::PVLV sv
+
+B::SV
+LvTARG(sv)
+ B::PVLV sv
+
+MODULE = B PACKAGE = B::BM PREFIX = Bm
+
+I32
+BmUSEFUL(sv)
+ B::BM sv
+
+U16
+BmPREVIOUS(sv)
+ B::BM sv
+
+U8
+BmRARE(sv)
+ B::BM sv
+
+void
+BmTABLE(sv)
+ B::BM sv
+ STRLEN len = NO_INIT
+ char * str = NO_INIT
+ CODE:
+ str = SvPV(sv, len);
+ /* Boyer-Moore table is just after string and its safety-margin \0 */
+ ST(0) = sv_2mortal(newSVpv(str + len + 1, 256));
+
+MODULE = B PACKAGE = B::GV PREFIX = Gv
+
+void
+GvNAME(gv)
+ B::GV gv
+ CODE:
+ ST(0) = sv_2mortal(newSVpv(GvNAME(gv), GvNAMELEN(gv)));
+
+B::HV
+GvSTASH(gv)
+ B::GV gv
+
+B::SV
+GvSV(gv)
+ B::GV gv
+
+B::IO
+GvIO(gv)
+ B::GV gv
+
+B::CV
+GvFORM(gv)
+ B::GV gv
+
+B::AV
+GvAV(gv)
+ B::GV gv
+
+B::HV
+GvHV(gv)
+ B::GV gv
+
+B::GV
+GvEGV(gv)
+ B::GV gv
+
+B::CV
+GvCV(gv)
+ B::GV gv
+
+U32
+GvCVGEN(gv)
+ B::GV gv
+
+U16
+GvLINE(gv)
+ B::GV gv
+
+B::GV
+GvFILEGV(gv)
+ B::GV gv
+
+MODULE = B PACKAGE = B::GV
+
+U32
+GvREFCNT(gv)
+ B::GV gv
+
+U8
+GvFLAGS(gv)
+ B::GV gv
+
+MODULE = B PACKAGE = B::IO PREFIX = Io
+
+long
+IoLINES(io)
+ B::IO io
+
+long
+IoPAGE(io)
+ B::IO io
+
+long
+IoPAGE_LEN(io)
+ B::IO io
+
+long
+IoLINES_LEFT(io)
+ B::IO io
+
+char *
+IoTOP_NAME(io)
+ B::IO io
+
+B::GV
+IoTOP_GV(io)
+ B::IO io
+
+char *
+IoFMT_NAME(io)
+ B::IO io
+
+B::GV
+IoFMT_GV(io)
+ B::IO io
+
+char *
+IoBOTTOM_NAME(io)
+ B::IO io
+
+B::GV
+IoBOTTOM_GV(io)
+ B::IO io
+
+short
+IoSUBPROCESS(io)
+ B::IO io
+
+MODULE = B PACKAGE = B::IO
+
+char
+IoTYPE(io)
+ B::IO io
+
+U8
+IoFLAGS(io)
+ B::IO io
+
+MODULE = B PACKAGE = B::AV PREFIX = Av
+
+SSize_t
+AvFILL(av)
+ B::AV av
+
+SSize_t
+AvMAX(av)
+ B::AV av
+
+#define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off
+
+IV
+AvOFF(av)
+ B::AV av
+
+void
+AvARRAY(av)
+ B::AV av
+ PPCODE:
+ if (AvFILL(av) >= 0) {
+ SV **svp = AvARRAY(av);
+ I32 i;
+ for (i = 0; i <= AvFILL(av); i++)
+ XPUSHs(make_sv_object(sv_newmortal(), svp[i]));
+ }
+
+MODULE = B PACKAGE = B::AV
+
+U8
+AvFLAGS(av)
+ B::AV av
+
+MODULE = B PACKAGE = B::CV PREFIX = Cv
+
+B::HV
+CvSTASH(cv)
+ B::CV cv
+
+B::OP
+CvSTART(cv)
+ B::CV cv
+
+B::OP
+CvROOT(cv)
+ B::CV cv
+
+B::GV
+CvGV(cv)
+ B::CV cv
+
+B::GV
+CvFILEGV(cv)
+ B::CV cv
+
+long
+CvDEPTH(cv)
+ B::CV cv
+
+B::AV
+CvPADLIST(cv)
+ B::CV cv
+
+B::CV
+CvOUTSIDE(cv)
+ B::CV cv
+
+void
+CvXSUB(cv)
+ B::CV cv
+ CODE:
+ ST(0) = sv_2mortal(newSViv((IV)CvXSUB(cv)));
+
+
+void
+CvXSUBANY(cv)
+ B::CV cv
+ CODE:
+ ST(0) = sv_2mortal(newSViv(CvXSUBANY(cv).any_iv));
+
+MODULE = B PACKAGE = B::HV PREFIX = Hv
+
+STRLEN
+HvFILL(hv)
+ B::HV hv
+
+STRLEN
+HvMAX(hv)
+ B::HV hv
+
+I32
+HvKEYS(hv)
+ B::HV hv
+
+I32
+HvRITER(hv)
+ B::HV hv
+
+char *
+HvNAME(hv)
+ B::HV hv
+
+B::PMOP
+HvPMROOT(hv)
+ B::HV hv
+
+void
+HvARRAY(hv)
+ B::HV hv
+ PPCODE:
+ if (HvKEYS(hv) > 0) {
+ SV *sv;
+ char *key;
+ I32 len;
+ (void)hv_iterinit(hv);
+ EXTEND(sp, HvKEYS(hv) * 2);
+ while (sv = hv_iternextsv(hv, &key, &len)) {
+ PUSHs(newSVpv(key, len));
+ PUSHs(make_sv_object(sv_newmortal(), sv));
+ }
+ }
--- /dev/null
+use ExtUtils::MakeMaker;
+use Config;
+
+my $e = $Config{'exe_ext'};
+my $o = $Config{'obj_ext'};
+my $exeout_flag = '-o ';
+if ($^O eq 'MSWin32') {
+ if ($Config{'cc'} =~ /^cl/i) {
+ $exeout_flag = '-Fe';
+ }
+ elsif ($Config{'cc'} =~ /^bcc/i) {
+ $exeout_flag = '-e';
+ }
+}
+
+WriteMakefile(
+ NAME => "B",
+ VERSION => "a5",
+ OBJECT => "B$o byterun$o",
+ depend => {
+ "B$o" => "B.c bytecode.h byterun.h",
+ },
+ clean => {
+ FILES => "perl byteperl$e btest$e 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$e/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$e : byteperl$o B$o byterun$o
+ \$(CC) ${exeout_flag}byteperl$e byteperl$o B$o byterun$o \$(LDFLAGS) \$(PERL_ARCHLIB)/CORE/$Config{libperl} \$(LIBS)
+EOT
+}
--- /dev/null
+C backend invocation
+ If there are any non-option arguments, they are taken to be
+ names of objects to be saved (probably doesn't work properly yet).
+ Without extra arguments, it saves the main program.
+ -ofilename Output to filename instead of STDOUT
+ -v Verbose (currently gives a few compilation statistics)
+ -- Force end of options
+ -uPackname Force apparently unused subs from package Packname to
+ be compiled. This allows programs to use eval "foo()"
+ even when sub foo is never seen to be used at compile
+ time. The down side is that any subs which really are
+ never used also have code generated. This option is
+ necessary, for example, if you have a signal handler
+ foo which you initialise with $SIG{BAR} = "foo".
+ A better fix, though, is just to change it to
+ $SIG{BAR} = \&foo. You can have multiple -u options.
+ -D Debug options (concat or separate flags like perl -D)
+ o OPs, prints each OP as it's processed
+ c COPs, prints COPs as processed (incl. file & line num)
+ A prints AV information on saving
+ C prints CV information on saving
+ M prints MAGIC information on saving
+ -f Force optimisations on or off one at a time.
+ cog Copy-on-grow: PVs declared and initialised statically
+ no-cog No copy-on-grow
+ -On Optimisation level (n = 0, 1, 2, ...). -O means -O1.
+ Currently, -O1 and higher set -fcog.
+
+Examples
+ perl -MO=C foo.pl > foo.c
+ perl cc_harness -o foo foo.c
+
+ perl -MO=C,-v,-DcA bar.pl > /dev/null
+
+CC backend invocation
+ If there are any non-option arguments, they are taken to be names of
+ subs to be saved. Without extra arguments, it saves the main program.
+ -ofilename Output to filename instead of STDOUT
+ -- Force end of options
+ -uPackname Force apparently unused subs from package Packname to
+ be compiled. This allows programs to use eval "foo()"
+ even when sub foo is never seen to be used at compile
+ time. The down side is that any subs which really are
+ never used also have code generated. This option is
+ necessary, for example, if you have a signal handler
+ foo which you initialise with $SIG{BAR} = "foo".
+ A better fix, though, is just to change it to
+ $SIG{BAR} = \&foo. You can have multiple -u options.
+ -mModulename Instead of generating source for a runnable executable,
+ generate source for an XSUB module. The
+ boot_Modulename function (which DynaLoader can look
+ for) does the appropriate initialisation and runs the
+ main part of the Perl source that is being compiled.
+ -pn Generate code for perl patchlevel n (e.g. 3 or 4).
+ The default is to generate C code which will link
+ with the currently executing version of perl.
+ running the perl compiler.
+ -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
+
+ perl -MO=CC,-mFoo,-oFoo.c Foo.pm
+ perl cc_harness -shared -c -o Foo.so 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.
+ b print debugging information about bytecompiler progress
+ a tells the assembler to include source assembler lines
+ in its output as bytecode comments.
+ C prints each CV taken from the final symbol tree walk.
+ -S Output assembler source rather than piping it
+ through the assembler and outputting bytecode.
+ -m Compile as a module rather than a standalone program.
+ Currently this just means that the bytecodes for
+ initialising main_start, main_root and curpad are
+ omitted.
+
+Example
+ perl -MO=Bytecode,-O6,-o,foo.plc foo.pl
+
+ perl -MO=Bytecode,-S foo.pl > foo.S
+ assemble foo.S > foo.plc
+ byteperl foo.plc
+
+ perl -MO=Bytecode,-m,-oFoo.pmc Foo.pm
+
+Backends for debugging
+ perl -MO=Terse,exec foo.pl
+ perl -MO=Debug bar.pl
+
+O module
+ Used with "perl -MO=Backend,foo,bar prog.pl" to invoke the backend
+ B::Backend with options foo and bar. O invokes the sub
+ B::Backend::compile() with arguments foo and bar at BEGIN time.
+ That compile() sub must do any inital argument processing replied.
+ If unsuccessful, it should return a string which O arranges to be
+ printed as an error message followed by a clean error exit. In the
+ normal case where any option processing in compile() is successful,
+ it should return a sub ref (usually a closure) to perform the
+ actual compilation. When O regains control, it ensures that the
+ "-c" option is forced (so that the program being compiled doesn't
+ end up running) and registers an END block to call back the sub ref
+ returned from the backend's compile(). Perl then continues by
+ parsing prog.pl (just as it would with "perl -c prog.pl") and after
+ doing so, assuming there are no parse-time errors, the END block
+ of O gets called and the actual backend compilation happens. Phew.
--- /dev/null
+ Perl Compiler Kit, Version alpha4
+
+ Copyright (c) 1996, 1997, 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 alpha3
+ Anonymous subs work properly with C and CC.
+ Heuristics for forcing compilation of apparently unused subs/methods.
+ Subs which use the AutoLoader module are forcibly loaded at compile-time.
+ Slightly faster compilation.
+ Handles slightly more complex code within a BEGIN { }.
+ Minor bug fixes.
+
+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 later.
+
+(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
+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 perl
+ make byteperl
+and you can then use
+ ./perl -MO=foo bar
+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
+ ./perl
+if you have built the extensions into a statically linked perl binary.
+
+(1) To compile perl program foo.pl with the C backend, do
+ perl -MO=C,-ofoo.c foo.pl
+Then use the cc_harness perl program to compile the resulting C source:
+ perl cc_harness -O2 -o foo foo.c
+
+If you are using a non-ANSI pre-Standard C compiler that can't handle
+pre-declaring static arrays, then add -DBROKEN_STATIC_REDECL to the
+options you use:
+ perl cc_harness -O2 -o foo -DBROKEN_STATIC_REDECL foo.c
+If you are using a non-ANSI pre-Standard C compiler that can't handle
+static initialisation of structures with union members then add
+-DBROKEN_UNION_INIT to the options you use. If you want command line
+arguments passed to your executable to be interpreted by perl (e.g. -Dx)
+then compile foo.c with -DALLOW_PERL_OPTIONS. Otherwise, all command line
+arguments passed to foo will appear directly in @ARGV. The resulting
+executable foo is the compiled version of foo.pl. See the file NOTES for
+extra options you can pass to -MO=C.
+
+There are some constraints on the contents on foo.pl if you want to be
+able to compile it successfully. Some problems can be fixed fairly easily
+by altering foo.pl; some problems with the compiler are known to be
+straightforward to solve and I'll do so soon. The file Todo lists a
+number of known problems. See the XSUB section lower down for information
+about compiling programs which use XSUBs.
+
+(2) To compile foo.pl with the CC backend (which generates actual
+optimised C code for the execution path of your perl program), use
+ perl -MO=CC,-ofoo.c foo.pl
+
+and proceed just as with the C backend. You should almost certainly
+use an option such as -O2 with the subsequent cc_harness invocation
+so that your C compiler uses optimisation. The C code generated by
+the Perl compiler's CC backend looks ugly to humans but is easily
+optimised by C compilers.
+
+To make the most of this compiler backend, you need to tell the
+compiler when you're using int or double variables so that it can
+optimise appropriately (although this part of the compiler is the most
+buggy). You currently do that by naming lexical variables ending in
+"_i" for ints, "_d" for doubles, "_ir" for int "register" variables or
+"_dr" for double "register" variables. Here "register" is a promise
+that you won't pass a reference to the variable into a sub which then
+modifies the variable. The compiler ought to catch attempts to use
+"\$i" just as C compilers catch attempts to do "&i" for a register int
+i but it doesn't at the moment. Bugs in the CC backend may make your
+program fail in mysterious ways and give wrong answers rather than just
+crash in boring ways. But, hey, this is an alpha release so you knew
+that anyway. See the XSUB section lower down for information about
+compiling programs which use XSUBs.
+
+If your program uses classes which define methods (or other subs which
+are not exported and not apparently used until runtime) then you'll
+need to use -u compile-time options (see the NOTES file) to force the
+subs to be compiled. Future releases will probably default the other
+way, do more auto-detection and provide more fine-grained control.
+
+Since compiled executables need linking with libperl, you may want
+to turn libperl.a into a shared library if your platform supports
+it. For example, with Digital UNIX, do something like
+ ld -shared -o libperl.so -all libperl.a -none -lc
+and with Linux/ELF, rebuild the perl .c files with -fPIC (and I
+also suggest -fomit-frame-pointer for Linux on Intel architetcures),
+do "make libperl.a" and then do
+ gcc -shared -Wl,-soname,libperl.so.5 -o libperl.so.5.3 `ar t libperl.a`
+and then
+ # cp libperl.so.5.3 /usr/lib
+ # cd /usr/lib
+ # ln -s libperl.so.5.3 libperl.so.5
+ # ln -s libperl.so.5 libperl.so
+ # ldconfig
+When you compile perl executables with cc_harness, append -L/usr/lib
+otherwise the -L for the perl source directory will override it. For
+example,
+ perl -Iblib/arch -MO=CC,-O2,-ofoo3.c foo3.bench
+ perl cc_harness -o foo3 -O2 foo3.c -L/usr/lib
+ ls -l foo3
+ -rwxr-xr-x 1 mbeattie xzdg 11218 Jul 1 15:28 foo3
+You'll probably also want to link your main perl executable against
+libperl.so; it's nice having an 11K perl executable.
+
+(3) To compile foo.pl into bytecode do
+ perl -MO=Bytecode,-ofoo foo.pl
+To run the resulting bytecode file foo as a standalone program, you
+use the program byteperl which should have been built along with the
+extensions.
+ ./byteperl foo
+Any extra arguments are passed in as @ARGV; they are not interpreted
+as perl options. If you want to load chunks of bytecode into an already
+running perl program then use the -m option and investigate the
+byteload_fh and byteload_string functions exported by the B module.
+See the NOTES file for details of these and other options (including
+optimisation options and ways of getting at the intermediate "assembler"
+code that the Bytecode backend uses).
+
+(3) There are little Bourne shell scripts and perl programs to aid with
+some common operations: assemble, disassemble, run_bytecode_test,
+run_test, cc_harness, test_harness, test_harness_bytecode.
+
+(4) Walk the op tree in execution order printing terse info about each op
+ perl -MO=Terse,exec foo.pl
+
+(5) Walk the op tree in syntax order printing lengthier debug info about
+each op. You can also append ",exec" to walk in execution order, but the
+formatting is designed to look nice with Terse rather than Debug.
+ perl -MO=Debug foo.pl
+
+(6) Produce a cross-reference report of the line numbers at which all
+variables, subs and formats are defined and used.
+ perl -MO=Xref foo.pl
+
+XSUBS
+
+The C and CC backends can successfully compile some perl programs which
+make use of XSUB extensions. [I'll add more detail to this section in a
+later release.] As a prerequisite, such extensions must not need to do
+anything in their BOOT: section which needs to be done at runtime rather
+than compile time. Normally, the only code in the boot_Foo() function is
+a list of newXS() calls which xsubpp puts there and the compiler handles
+saving those XS subs itself. For each XSUB used, the C and CC compiler
+will generate an initialiser in their C output which refers to the name
+of the relevant C function (XS_Foo_somesub). What is not yet automated
+is the necessary commands and cc command-line options (e.g. via
+"perl cc_harness") which link against the extension libraries. For now,
+you need the XSUB extension to have installed files in the right format
+for using as C libraries (e.g. Foo.a or Foo.so). As the Foo.so files (or
+your platform's version) aren't suitable for linking against, you will
+have to reget the extension source and rebuild it as a static extension
+to force the generation of a suitable Foo.a file. Then you need to make
+a symlink (or copy or rename) of that file into a libFoo.a suitable for
+cc linking. Then add the appropriate -L and -l options to your
+"perl cc_harness" command line to find and link against those libraries.
+You may also need to fix up some platform-dependent environment variable
+to ensure that linked-against .so files are found at runtime too.
+
+DIFFERENCES
+
+The result of running a compiled Perl program can sometimes be different
+from running the same program with standard perl. Think of the compiler
+as having a slightly different implementation of the language Perl.
+Unfortunately, since Perl has had a single implementation until now,
+there are no formal standards or documents defining what behaviour is
+guaranteed of Perl the language and what just "happens to work".
+Some of the differences below are almost impossible to change because of
+the way the compiler works. Others can be changed to produce "standard"
+perl behaviour if it's deemed proper and the resulting performance hit
+is accepted. I'll use "standard perl" to mean the result of running a
+Perl program using the perl executable from the perl distribution.
+I'll use "compiled Perl program" to mean running an executable produced
+by this compiler kit ("the compiler") with the CC backend.
+
+Loops
+ Standard perl calculates the target of "next", "last", and "redo"
+ at run-time. The compiler calculates the targets at compile-time.
+ For example, the program
+
+ sub skip_on_odd { next NUMBER if $_[0] % 2 }
+ NUMBER: for ($i = 0; $i < 5; $i++) {
+ skip_on_odd($i);
+ print $i;
+ }
+
+ produces the output
+ 024
+ with standard perl but gives a compile-time error with the compiler.
+
+Context of ".."
+ The context (scalar or array) of the ".." operator determines whether
+ it behaves as a range or a flip/flop. Standard perl delays until
+ runtime the decision of which context it is in but the compiler needs
+ to know the context at compile-time. For example,
+ @a = (4,6,1,0,0,1);
+ sub range { (shift @a)..(shift @a) }
+ print range();
+ while (@a) { print scalar(range()) }
+ generates the output
+ 456123E0
+ with standard Perl but gives a compile-time error with compiled Perl.
+
+Arithmetic
+ Compiled Perl programs use native C arithemtic much more frequently
+ than standard perl. Operations on large numbers or on boundary
+ cases may produce different behaviour.
+
+Deprecated features
+ Features of standard perl such as $[ which have been deprecated
+ in standard perl since version 5 was released have not been
+ implemented in the compiler.
+
+Others
+ I'll add to this list as I remember what they are.
+
+BUGS
+
+Here are some things which may cause the compiler problems.
+
+The following render the compiler useless (without serious hacking):
+* Use of the DATA filehandle (via __END__ or __DATA__ tokens)
+* Operator overloading with %OVERLOAD
+* The (deprecated) magic array-offset variable $[ does not work
+* The following operators are not yet implemented for CC
+ goto
+ sort with a non-default comparison (i.e. a named sub or inline block)
+* You can't use "last" to exit from a non-loop block.
+
+The following may give significant problems:
+* BEGIN blocks containing complex initialisation code
+* Code which is only ever referred to at runtime (e.g. via eval "..." or
+ via method calls): see the -u option for the C and CC backends.
+* Run-time lookups of lexical variables in "outside" closures
+
+The following may cause problems (not thoroughly tested):
+* Dependencies on whether values of some "magic" Perl variables are
+ determined at compile-time or runtime.
+* For the C and CC backends: compile-time strings which are longer than
+ your C compiler can cope with in a single line or definition.
+* Reliance on intimate details of global destruction
+* For the Bytecode backend: high -On optimisation numbers with code
+ that has complex flow of control.
+* Any "-w" option in the first line of your perl program is seen and
+ acted on by perl itself before the compiler starts. The compiler
+ itself then runs with warnings turned on. This may cause perl to
+ print out warnings about the compiler itself since I haven't tested
+ it thoroughly with warnings turned on.
+
+There is a terser but more complete list in the Todo file.
+
+Malcolm Beattie
+2 September 1996
--- /dev/null
+Test results from compiling t/*/*.t
+ C Bytecode CC
+
+base/cond.t OK ok OK
+base/if.t OK ok OK
+base/lex.t OK ok OK
+base/pat.t OK ok OK
+base/term.t OK ok OK
+cmd/elsif.t OK ok OK
+cmd/for.t OK ok ok 1, 2, 3, panic: pp_iter
+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 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 1-6 of 16 then exits
+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
+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 omit 26 (reset) ok [lots of memory for compile]
+op/push.t OK ok OK
+op/quotemeta.t OK ok OK
+op/rand.t OK ok
+op/range.t OK ok OK
+op/read.t OK ok OK
+op/readdir.t OK ok OK (substcont works too)
+op/ref.t omits "ok 40" (lex destruction) ok (Bytecode)
+ CC: need -u for OBJ,BASEOBJ,
+ UNIVERSAL,WHATEVER,main.
+ 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 omit 21 ok ok
+op/unshift.t OK ok ok
+op/vec.t OK ok ok
+op/write.t not ok 3 (no CvOUTSIDE lex from runtime eval). CC: 1..3, hang
--- /dev/null
+* Fixes
+
+CC backend: goto, sort with non-default comparison. last for non-loop blocks.
+Version checking
+improve XSUB handling (both static and dynamic)
+sv_magic can do SvREFCNT_inc(obj) which messes up precalculated refcounts
+allocation of XPV[INAHC]V structures needs fixing: Perl tries to free
+them whereas the compiler expects them to be linked to a xpv[inahc]v_root
+list the same as X[IPR]V structures.
+ref counts
+perl_parse replacement
+fix cstring for long strings
+compile-time initialisation of AvARRAYs
+signed/unsigned problems with NV (and IV?) initialisation and elsewhere?
+CvOUTSIDE for ordinary subs
+DATA filehandle for standalone Bytecode program (easy)
+DATA filehandle for multiple bytecode-compiled modules (harder)
+DATA filehandle for C-compiled program (yet harder)
+
+* Features
+
+type checking
+compile time v. runtime initialisation
+save PMOPs in compiled form
+selection of what to dump
+options for cutting out line info etc.
+comment output
+shared constants
+module dependencies
+
+* Optimisations
+collapse LISTOPs to UNOPs or BASEOPs
+compile-time qw(), constant subs
+global analysis of variables, type hints etc.
+demand-loaded bytecode (leader of each basic block replaced by an op
+which loads in bytecode for its block)
+fast sub calls for CC backend
--- /dev/null
+#include "EXTERN.h"
+#include "perl.h"
+#ifndef PATCHLEVEL
+#include "patchlevel.h"
+#endif
+#include "byterun.h"
+
+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 */
+
+ INIT_SPECIALSV_LIST;
+ 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 );
+ }
+
+#ifdef CSH
+ if (!cshlen)
+ cshlen = strlen(cshname);
+#endif
+
+ if (argc < 2)
+ fp = stdin;
+ else {
+#ifdef WIN32
+ fp = fopen(argv[1], "rb");
+#else
+ fp = fopen(argv[1], "r");
+#endif
+ if (!fp) {
+ perror(argv[1]);
+ exit(1);
+ }
+ argv++;
+ argc--;
+ }
+ New(666, fakeargv, argc + 4, char *);
+ fakeargv[0] = argv[0];
+ fakeargv[1] = "-e";
+ fakeargv[2] = "";
+ fakeargv[3] = "--";
+ for (i = 1; i < argc; i++)
+ fakeargv[i + 3] = argv[i];
+ fakeargv[argc + 3] = 0;
+
+ exitstatus = perl_parse(my_perl, xs_init, argc + 3, fakeargv, NULL);
+ if (exitstatus)
+ exit( exitstatus );
+
+ sv_setpv(GvSV(gv_fetchpv("0", TRUE, SVt_PV)), argv[0]);
+ main_cv = compcv;
+ compcv = 0;
+
+#ifdef INDIRECT_BGET_MACROS
+ bs.data = fp;
+ bs.fgetc = (int(*) _((void*)))fgetc;
+ bs.fread = (int(*) _((char*,size_t,size_t,void*)))fread;
+ bs.freadpv = freadpv;
+ byterun(bs);
+#else
+ byterun(fp);
+#endif /* INDIRECT_BGET_MACROS */
+
+ exitstatus = perl_run( my_perl );
+
+ perl_destruct( my_perl );
+ perl_free( my_perl );
+
+ exit( exitstatus );
+}
+
+static void
+xs_init()
+{
+}
--- /dev/null
+At entry to each basic block, the following can be assumed (and hence
+must be forced where necessary at the end of each basic block):
+
+The shadow stack @stack is empty.
+For each lexical object in @pad, VALID_IV holds for each T_INT,
+VALID_DOUBLE holds for each T_DOUBLE and VALID_SV holds otherwise.
+The C shadow variable sp holds the stack pointer (not necessarily stack_sp).
+
+write_back_stack
+ Writes the contents of the shadow stack @stack back to the real stack.
+ A write-back of each object in the stack is forced so that its
+ backing SV contains the right value and that SV is then pushed onto the
+ real stack. On return, @stack is empty.
+
+write_back_lexicals
+ Forces a write-back (i.e. achieves VALID_SV), where necessary, for each
+ lexical object in @pad. Objects with the TEMPORARY flag are skipped. If
+ write_back_lexicals is called with an (optional) argument, then it is
+ taken to be a bitmask of more flags: any lexical object with one of those
+ flags set is also skipped and not written back to its SV.
+
+invalidate_lexicals($avoid)
+ The VALID_INT and VALID_DOUBLE flags are turned off for each lexical
+ object in @pad whose flags field doesn't overlap with $avoid.
+
+reload_lexicals
+ For each necessary lexical object in @pad, makes sure that VALID_IV
+ holds for objects of type T_INT, VALID_DOUBLE holds for objects for
+ type T_DOUBLE, and VALID_SV holds for other objects. An object is
+ considered for reloading if its flags field does not overlap with the
+ (optional) argument passed to reload_lexicals.
+
--- /dev/null
+PP code uses of curcop
+----------------------
+
+pp_rv2gv
+ when a new glob is created for an OPpLVAL_INTRO,
+ curcop->cop_line is stored as GvLINE() in the new GP.
+pp_bless
+ curcop->cop_stash is used as the stash in the one-arg form of bless
+
+pp_repeat
+ tests (curcop != &compiling) to warn "Can't x= to readonly value"
+
+pp_pos
+pp_substr
+pp_index
+pp_rindex
+pp_aslice
+pp_lslice
+pp_splice
+ curcop->cop_arybase
+
+pp_sort
+ curcop->cop_stash used to determine whether to gv_fetchpv $a and $b
+
+pp_caller
+ tests (curcop->cop_stash == debstash) to determine whether
+ to set DB::args
+
+pp_reset
+ resets vars in curcop->cop_stash
+
+pp_dbstate
+ sets curcop = (COP*)op
+
+doeval
+ compiles into curcop->cop_stash
+
+pp_nextstate
+ sets curcop = (COP*)op
--- /dev/null
+PP(pp_range)
+{
+ if (GIMME == G_ARRAY)
+ return cCONDOP->op_true;
+ return SvTRUEx(PAD_SV(op->op_targ)) ? cCONDOP->op_false : cCONDOP->op_true;
+}
+
+pp_range is a CONDOP.
+In array context, it just returns op_true.
+In scalar context it checks the truth of targ and returns
+op_false if true, op_true if false.
+
+flip is an UNOP.
+It "looks after" its child which is always a pp_range CONDOP.
+In array context, it just returns the child's op_false.
+In scalar context, there are three possible outcomes:
+ (1) set child's targ to 1, our targ to 1 and return op_next.
+ (2) set child's targ to 1, our targ to 0, sp-- and return child's op_false.
+ (3) Blank targ and TOPs and return op_next.
+Case 1 happens for a "..." with a matching lineno... or true TOPs.
+Case 2 happens for a ".." with a matching lineno... or true TOPs.
+Case 3 happens for a non-matching lineno or false TOPs.
+
+ $a = lhs..rhs;
+
+ ,-------> range
+ ^ / \
+ | true/ \false
+ | / \
+ first| lhs rhs
+ | \ first /
+ ^--- flip <----- flop
+ \ /
+ \ /
+ sassign
+
+
+/* range */
+if (SvTRUE(curpad[op->op_targ]))
+ goto label(op_false);
+/* op_true */
+...
+/* flip */
+/* For "..." returns op_next. For ".." returns op_next or op_first->op_false */
+/* end of basic block */
+goto out;
+label(range op_false):
+...
+/* flop */
+out:
+...
--- /dev/null
+sv_magic()
+----------
+av.c
+av_store()
+ Storing a non-undef element into an SMAGICAL array, av,
+ assigns the equivalent lowercase form of magic (of the first
+ MAGIC in the chain) to the value (with obj = av, name = 0 and
+ namlen = array index).
+
+gv.c
+gv_init()
+ Initialising gv assigns '*' magic to it with obj = gv, name =
+ GvNAME and namlen = GvNAMELEN.
+gv_fetchpv()
+ @ISA gets 'I' magic with obj = gv, zero name and namlen.
+ %OVERLOAD gets 'A' magic with obj = gv, zero name and namlen.
+ $1 to $9, $&, $`, $', $+ get '\0' magic with obj = gv,
+ name = GvNAME and namlen = len ( = 1 presumably).
+Gv_AMupdate()
+ Stashes for overload magic seem to get 'c' magic with obj = 0,
+ name = &amt and namlen = sizeof(amt).
+hv_magic(hv, gv, how)
+ Gives magic how to hv with obj = gv and zero name and namlen.
+
+mg.c
+mg_copy(sv, nsv, key, klen)
+ Traverses the magic chain of sv. Upper case forms of magic
+ (only) are copied across to nsv, preserving obj but using
+ name = key and namlen = klen.
+magic_setpos()
+ LvTARG of a PVLV gets 'g' magic with obj = name = 0 and namlen = pos.
+
+op.c
+mod()
+ PVLV operators give magic to their targs with
+ obj = name = namlen = 0. OP_POS gives '.', OP_VEC gives 'v'
+ and OP_SUBSTR gives 'x'.
+
+perl.c
+magicname(sym, name, namlen)
+ Fetches/creates a GV with name sym and gives it '\0' magic
+ with obj = gv, name and namlen as passed.
+init_postdump_symbols()
+ Elements of the environment get given SVs with 'e' magic.
+ obj = sv and name and namlen point to the actual string
+ within env.
+
+pp.c
+pp_av2arylen()
+ $#foo gives '#' magic to the new SV with obj = av and
+ name = namlen = 0.
+pp_study()
+ SV gets 'g' magic with obj = name = namlen = 0.
+pp_substr()
+ PVLV gets 'x' magic with obj = name = namlen = 0.
+pp_vec()
+ PVLV gets 'x' magic with obj = name = namlen = 0.
+
+pp_hot.c
+pp_match()
+ m//g gets 'g' magic with obj = name = namlen = 0.
+
+pp_sys.c
+pp_tie()
+ sv gets magic with obj = sv and name = namlen = 0.
+ If an HV or an AV, it gets 'P' magic, otherwise 'q' magic.
+pp_dbmopen()
+ 'P' magic for the HV just as with pp_tie().
+pp_sysread()
+ If tainting, the buffer SV gets 't' magic with
+ obj = name = namlen = 0.
+
+sv.c
+sv_setsv()
+ Doing sv_setsv(dstr, gv) gives '*' magic to dstr with
+ obj = dstr, name = GvNAME, namlen = GvNAMELEN.
+
+util.c
+fbm_compile()
+ The PVBM gets 'B' magic with obj = name = namlen = 0 and SvVALID
+ is set to indicate that the Boyer-Moore table is valid.
+ magic_setbm() just clears the SvVALID flag.
+
+hv_magic()
+----------
+
+gv.c
+gv_fetchfile()
+ With perldb, the HV of a gvfile gv gets 'L' magic with obj = gv.
+gv_fetchpv()
+ %SIG gets 'S' magic with obj = siggv.
+init_postdump_symbols()
+ %ENV gets 'E' magic with obj = envgv.
--- /dev/null
+while ($i--) {
+ foo();
+}
+exit
+
+ PP code if i an int register if i an int but not a
+ (i.e. can't be register (i.e. can be
+ implicitly invalidated) implicitly invalidated)
+ nextstate
+ enterloop
+
+
+ loop:
+ gvsv GV (0xe6078) *i validates i validates i
+ postdec invalidates $i invalidates $i
+ and if_false goto out;
+ i valid; $i invalid i valid; $i invalid
+
+ i valid; $i invalid i valid; $i invalid
+ nextstate
+ pushmark
+ gv GV (0xe600c) *foo
+ entersub validates $i; invals i
+
+ unstack
+ goto loop:
+
+ i valid; $i invalid
+ out:
+ leaveloop
+ nextstate
+ exit
--- /dev/null
+Notes on porting the perl runtime PP engine.
+Importance: 1 = who cares?, 10 = vital
+Difficulty: 1 = trivial, 10 = very difficult. Level assumes a
+reasonable implementation of the SV and OP API already ported.
+
+OP Import Diff Comments
+null 10 1
+stub 10 1
+scalar 10 1
+pushmark 10 1 PUSHMARK
+wantarray 7 3 cxstack, dopoptosub
+const 10 1
+gvsv 10 1 save_scalar
+gv 10 1
+gelem 3 3
+padsv 10 2 SAVECLEARSV, provide_ref
+padav 10 2
+padhv 10 2
+padany 1 1
+pushre 7 3 pushes an op. Blech.
+rv2gv 6 5
+rv2sv 10 4
+av2arylen 7 3 sv_magic
+rv2cv 8 5 sv_2cv
+anoncode 7 6 cv_clone
+prototype 4 4 sv_2cv
+refgen 8 3
+srefgen 8 2
+ref 8 3
+bless 7 3
+backtick 5 4
+glob 5 2 do_readline
+readline 8 2 do_readline
+rcatline 8 2
+regcmaybe 8 1
+regcomp 8 9 pregcomp
+match 8 10
+subst 8 10
+substcont 8 7
+trans 7 4 do_trans
+sassign 10 3 mg_find, SvSETMAGIC
+aassign 10 5
+chop 8 3 do_chop
+schop 8 3 do_chop
+chomp 8 3 do_chomp
+schomp 8 3 do_chomp
+defined 10 2
+undef 10 3
+study 4 5
+pos 8 3 PVLV, mg_find
+preinc 10 2 sv_inc, SvSETMAGIC
+i_preinc
+predec 10 2 sv_dec, SvSETMAGIC
+i_predec
+postinc 10 2 sv_dec, SvSETMAGIC
+i_postinc
+postdec 10 2 sv_dec, SvSETMAGIC
+i_postdec
+pow 10 1
+multiply 10 1
+i_multiply 10 1
+divide 10 2
+i_divide 10 1
+modulo 10 2
+i_modulo 10 1
+repeat 6 4
+add 10 1
+i_add 10 1
+subtract 10 1
+i_subtract 10 1
+concat 10 2 mg_get
+stringify 10 2 sv_setpvn
+left_shift 10 1
+right_shift 10 1
+lt 10 1
+i_lt 10 1
+gt 10 1
+i_gt 10 1
+le 10 1
+i_le 10 1
+ge 10 1
+i_ge 10 1
+eq 10 1
+i_eq 10 1
+ne 10 1
+i_ne 10 1
+ncmp 10 1
+i_ncmp 10 1
+slt 10 2
+sgt 10 2
+sle 10 2
+sge 10 2
+seq 10 2 sv_eq
+sne 10 2
+scmp 10 2
+bit_and 10 2
+bit_xor 10 2
+bit_or 10 2
+negate 10 3
+i_negate 10 1
+not 10 1
+complement 10 3
+atan2 6 1
+sin 6 1
+cos 6 1
+rand 5 2
+srand 5 2
+exp 6 1
+log 6 2
+sqrt 6 2
+int 10 2
+hex 9 2
+oct 9 2
+abs 10 1
+length 10 1
+substr 10 4 PVLV
+vec 5 4
+index 9 3
+rindex 9 3
+sprintf 9 4 do_sprintf
+formline 6 7
+ord 6 2
+chr 6 2
+crypt 3 2
+ucfirst 6 2
+lcfirst 6 2
+uc 6 2
+lc 6 2
+quotemeta 6 3
+rv2av 10 3 save_svref, mg_get, save_ary
+aelemfast 10 2 av_fetch
+aelem 10 3
+aslice 9 4
+each 10 3 hv_iternext
+values 10 3 do_kv
+keys 10 3 do_kv
+delete 10 3
+exists 10 3
+rv2hv 10 3 save_svref, mg_get, save_ary, do_kv
+helem 10 3 save_svref, provide_ref
+hslice 9 4
+unpack 9 6 lengthy
+pack 9 6 lengthy
+split 9 9
+join 10 4 do_join
+list 10 2
+lslice 9 4
+anonlist 10 2
+anonhash 10 3
+splice 9 6
+push 10 2
+pop 10 2
+shift 10 2
+unshift 10 2
+sort 6 7
+reverse 9 4
+grepstart 6 5 modifies flow of control
+grepwhile 6 5 modifies flow of control
+mapstart 1 1
+mapwhile 6 5 modifies flow of control
+range 7 3 modifies flow of control
+flip 7 4 modifies flow of control
+flop 7 4 modifies flow of control
+and 10 3 modifies flow of control
+or 10 3 modifies flow of control
+xor
+cond_expr 10 3 modifies flow of control
+andassign 7 3 modifies flow of control
+orassign 7 3 modifies flow of control
+method 8 5
+entersub 10 7
+leavesub 10 5
+caller 2 8
+warn 9 3
+die 9 3
+reset 2 2
+lineseq 1 1
+nextstate 10 1 Update stack_sp from cxstack. FREETMPS.
+dbstate 3 7
+unstack
+enter 10 3 cxstack, ENTER, SAVETMPS, PUSHBLOCK
+leave 10 3 cxstack, SAVETMPS, LEAVE, POPBLOCK
+scope 1 1
+enteriter 9 4 cxstack
+iter 9 3 cxstack
+enterloop 10 4
+leaveloop 10 4
+return 10 5
+last 9 6
+next 9 6
+redo 9 6
+dump 1 9 pp_goto
+goto 6 9
+exit 9 2 my_exit
+open 9 5 do_open
+close 9 3 do_close
+pipe_op 7 4
+fileno 9 2
+umask 4 2
+binmode 4 2
+tie 5 5 pp_entersub
+untie 5 2 sv_unmagic
+tied 5 2
+dbmopen 4 5
+dbmclose 4 2
+sselect 4 4
+select 7 3
+getc 7 2
+read 8 2 pp_sysread
+enterwrite 4 4 doform
+leavewrite 4 5
+prtf 4 4 do_sprintf
+print 8 6
+sysopen 8 2
+sysread 8 4
+syswrite 8 4 pp_send
+send 8 4
+recv 8 4 pp_sysread
+eof 9 2
+tell 9 3
+seek 9 2
+truncate 8 3
+fcntl 8 4 pp_ioctl
+ioctl 8 4
+flock 8 2
+socket 5 3
+sockpair 5 3
+bind 5 3
+connect 5 3
+listen 5 3
+accept 5 3
+shutdown 5 2
+gsockopt 5 3 pp_ssockopt
+ssockopt 5 3
+getsockname 5 3 pp_getpeername
+getpeername 5 3
+lstat 5 4 pp_stat
+stat 5 4 lengthy
+ftrread 5 2 cando
+ftrwrite 5 2 cando
+ftrexec 5 2 cando
+fteread 5 2 cando
+ftewrite 5 2 cando
+fteexec 5 2 cando
+ftis 5 2 cando
+fteowned 5 2 cando
+ftrowned 5 2 cando
+ftzero 5 2 cando
+ftsize 5 2 cando
+ftmtime 5 2 cando
+ftatime 5 2 cando
+ftctime 5 2 cando
+ftsock 5 2 cando
+ftchr 5 2 cando
+ftblk 5 2 cando
+ftfile 5 2 cando
+ftdir 5 2 cando
+ftpipe 5 2 cando
+ftlink 5 2 cando
+ftsuid 5 2 cando
+ftsgid 5 2 cando
+ftsvtx 5 2 cando
+fttty 5 2 cando
+fttext 5 4
+ftbinary 5 4 fttext
+chdir
+chown
+chroot
+unlink
+chmod
+utime
+rename
+link
+symlink
+readlink
+mkdir
+rmdir
+open_dir
+readdir
+telldir
+seekdir
+rewinddir
+closedir
+fork
+wait
+waitpid
+system
+exec
+kill
+getppid
+getpgrp
+setpgrp
+getpriority
+setpriority
+time
+tms
+localtime
+gmtime
+alarm
+sleep
+shmget
+shmctl
+shmread
+shmwrite
+msgget
+msgctl
+msgsnd
+msgrcv
+semget
+semctl
+semop
+require 6 9 doeval
+dofile 6 9 doeval
+entereval 6 9 doeval
+leaveeval 6 5
+entertry 7 4 modifies flow of control
+leavetry 7 3
+ghbyname
+ghbyaddr
+ghostent
+gnbyname
+gnbyaddr
+gnetent
+gpbyname
+gpbynumber
+gprotoent
+gsbyname
+gsbyport
+gservent
+shostent
+snetent
+sprotoent
+sservent
+ehostent
+enetent
+eprotoent
+eservent
+gpwnam
+gpwuid
+gpwent
+spwent
+epwent
+ggrnam
+ggrgid
+ggrent
+sgrent
+egrent
+getlogin
+syscall
+
\ No newline at end of file
--- /dev/null
+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), (SV*)($var));
+
+
+T_MG_OBJ
+ sv_setiv(newSVrv($arg, "B::MAGIC"), (IV)$var);
--- /dev/null
+# B.pm
+#
+# Copyright (c) 1996, 1997 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 cstring cchar hash threadsv_names
+ main_root main_start main_cv svref_2object
+ walkoptree walkoptree_slow walkoptree_exec walksymtable
+ parents 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;
+my @parents = ();
+
+sub debug {
+ my ($class, $value) = @_;
+ $debug = $value;
+ walkoptree_debug($value);
+}
+
+# sub OPf_KIDS;
+# add to .xs for perl5.002
+sub OPf_KIDS () { 4 }
+
+sub class {
+ my $obj = shift;
+ my $name = ref $obj;
+ $name =~ s/^.*:://;
+ return $name;
+}
+
+sub parents { \@parents }
+
+# For debugging
+sub peekop {
+ my $op = shift;
+ return sprintf("%s (0x%x) %s", class($op), $$op, $op->ppaddr);
+}
+
+sub walkoptree_slow {
+ 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 ($$op && ($op->flags & OPf_KIDS)) {
+ my $kid;
+ unshift(@parents, $op);
+ for ($kid = $op->first; $$kid; $kid = $kid->sibling) {
+ walkoptree_slow($kid, $method, $level + 1);
+ }
+ shift @parents;
+ }
+}
+
+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", $$obj, $value)); # debug
+ $symtable{sprintf("sym_%x", $$obj)} = $value;
+}
+
+sub objsym {
+ my $obj = shift;
+ return $symtable{sprintf("sym_%x", $$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), $$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 ($$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 ($$replstart) {
+ print $prefix, "SUBST => {\n";
+ walkoptree_exec($replstart, $method, $level + 1);
+ print $prefix, "}\n";
+ }
+ }
+ }
+}
+
+sub walksymtable {
+ my ($symref, $method, $recurse, $prefix) = @_;
+ my $sym;
+ no strict 'vars';
+ local(*glob);
+ while (($sym, *glob) = each %$symref) {
+ if ($sym =~ /::$/) {
+ $sym = $prefix . $sym;
+ if ($sym ne "main::" && &$recurse($sym)) {
+ walksymtable(\%glob, $method, $recurse, $sym);
+ }
+ } else {
+ svref_2object(\*glob)->EGV->$method();
+ }
+ }
+}
+
+{
+ package B::Section;
+ my $output_fh;
+ my %sections;
+
+ sub new {
+ my ($class, $section, $symtable, $default) = @_;
+ $output_fh ||= FileHandle->new_tmpfile;
+ my $obj = bless [-1, $section, $symtable, $default], $class;
+ $sections{$section} = $obj;
+ return $obj;
+ }
+
+ sub get {
+ my ($class, $section) = @_;
+ return $sections{$section};
+ }
+
+ sub add {
+ my $section = shift;
+ while (defined($_ = shift)) {
+ print $output_fh "$section->[1]\t$_\n";
+ $section->[0]++;
+ }
+ }
+
+ sub index {
+ my $section = shift;
+ return $section->[0];
+ }
+
+ sub name {
+ my $section = shift;
+ return $section->[1];
+ }
+
+ sub symtable {
+ my $section = shift;
+ return $section->[2];
+ }
+
+ sub default {
+ my $section = shift;
+ return $section->[3];
+ }
+
+ sub output {
+ my ($section, $fh, $format) = @_;
+ my $name = $section->name;
+ my $sym = $section->symtable || {};
+ my $default = $section->default;
+
+ seek($output_fh, 0, 0);
+ while (<$output_fh>) {
+ chomp;
+ s/^(.*?)\t//;
+ if ($1 eq $name) {
+ s{(s\\_[0-9a-f]+)} {
+ exists($sym->{$1}) ? $sym->{$1} : $default;
+ }ge;
+ printf $fh $format, $_;
+ }
+ }
+ }
+}
+
+bootstrap B;
+
+1;
--- /dev/null
+use B::Assembler qw(assemble_fh);
+use FileHandle;
+
+my ($filename, $fh, $out);
+
+if ($ARGV[0] eq "-d") {
+ B::Assembler::debug(1);
+ shift;
+}
+
+$out = \*STDOUT;
+
+if (@ARGV == 0) {
+ $fh = \*STDIN;
+ $filename = "-";
+} elsif (@ARGV == 1) {
+ $filename = $ARGV[0];
+ $fh = new FileHandle "<$filename";
+} elsif (@ARGV == 2) {
+ $filename = $ARGV[0];
+ $fh = new FileHandle "<$filename";
+ $out = new FileHandle ">$ARGV[1]";
+} else {
+ die "Usage: assemble [filename] [outfilename]\n";
+}
+
+binmode $out;
+$SIG{__WARN__} = sub { warn "$filename:@_" };
+$SIG{__DIE__} = sub { die "$filename: @_" };
+assemble_fh($fh, sub { print $out @_ });
--- /dev/null
+use Config;
+
+$libdir = $ENV{PERL_SRC} || "$Config{installarchlib}/CORE";
+
+if (!grep(/^-[cS]$/, @ARGV)) {
+ $linkargs = sprintf("%s $libdir/$Config{libperl} %s",
+ @Config{qw(ldflags libs)});
+}
+
+$cccmd = "$Config{cc} $Config{ccflags} -I$libdir @ARGV $linkargs";
+print "$cccmd\n";
+exec $cccmd;
--- /dev/null
+use B::Disassembler qw(disassemble_fh);
+use FileHandle;
+
+my $fh;
+if (@ARGV == 0) {
+ $fh = \*STDIN;
+} elsif (@ARGV == 1) {
+ $fh = new FileHandle "<$ARGV[0]";
+} else {
+ die "Usage: disassemble [filename]\n";
+}
+
+sub print_insn {
+ my ($insn, $arg) = @_;
+ if (defined($arg)) {
+ printf "%s %s\n", $insn, $arg;
+ } else {
+ print $insn, "\n";
+ }
+}
+
+disassemble_fh($fh, \&print_insn);
--- /dev/null
+use File::Find;
+use Config;
+
+if (@ARGV != 2) {
+ warn <<"EOT";
+Usage: makeliblinks libautodir targetdir
+where libautodir is the architecture-dependent auto directory
+(e.g. $Config::Config{archlib}/auto).
+EOT
+ exit 2;
+}
+
+my ($libautodir, $targetdir) = @ARGV;
+
+# Calculate relative path prefix from $targetdir to $libautodir
+sub relprefix {
+ my ($to, $from) = @_;
+ my $up;
+ for ($up = 0; substr($to, 0, length($from)) ne $from; $up++) {
+ $from =~ s(
+ [^/]+ (?# a group of non-slashes)
+ /* (?# maybe with some trailing slashes)
+ $ (?# at the end of the path)
+ )()x;
+ }
+ return (("../" x $up) . substr($to, length($from)));
+}
+
+my $relprefix = relprefix($libautodir, $targetdir);
+
+my ($dlext, $lib_ext) = @Config::Config{qw(dlext lib_ext)};
+
+sub link_if_library {
+ if (/\.($dlext|$lib_ext)$/o) {
+ my $ext = $1;
+ my $name = $File::Find::name;
+ if (substr($name, 0, length($libautodir) + 1) ne "$libautodir/") {
+ die "directory of $name doesn't match $libautodir\n";
+ }
+ substr($name, 0, length($libautodir) + 1) = '';
+ my @parts = split(m(/), $name);
+ if ($parts[-1] ne "$parts[-2].$ext") {
+ die "module name $_ doesn't match its directory $libautodir\n";
+ }
+ pop @parts;
+ my $libpath = "$targetdir/lib" . join("__", @parts) . ".$ext";
+ print "$libpath -> $relprefix/$name\n";
+ symlink("$relprefix/$name", $libpath)
+ or warn "above link failed with error: $!\n";
+ }
+}
+
+find(\&link_if_library, $libautodir);
+exit 0;
--- /dev/null
+package O;
+use B qw(minus_c);
+use Carp;
+
+sub import {
+ my ($class, $backend, @options) = @_;
+ eval "use B::$backend ()";
+ if ($@) {
+ croak "use of backend $backend failed: $@";
+ }
+ my $compilesub = &{"B::${backend}::compile"}(@options);
+ if (ref($compilesub) eq "CODE") {
+ minus_c;
+ eval 'END { &$compilesub() }';
+ } else {
+ die $compilesub;
+ }
+}
+
+1;
+
projects / platform / upstream / perl.git / commitdiff