This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Merge perlext/Compiler/... into mainline. Some files move to
authorMalcolm Beattie <mbeattie@sable.ox.ac.uk>
Fri, 20 Feb 1998 16:42:13 +0000 (16:42 +0000)
committerMalcolm Beattie <mbeattie@sable.ox.ac.uk>
Fri, 20 Feb 1998 16:42:13 +0000 (16:42 +0000)
ext/B/..., some to lib/B/..., O.pm and B.pm go in lib and some
move to the base perl directory (e.g. headers). Will need some
cleaning up before it builds properly, I would guess.

p4raw-id: //depot/perl@562

23 files changed:
bytecode.h [new file with mode: 0644]
bytecode.pl [new file with mode: 0644]
cc_runtime.h [new file with mode: 0644]
ext/B/B.xs [new file with mode: 0644]
ext/B/Makefile.PL [new file with mode: 0644]
ext/B/NOTES [new file with mode: 0644]
ext/B/README [new file with mode: 0644]
ext/B/TESTS [new file with mode: 0644]
ext/B/Todo [new file with mode: 0644]
ext/B/byteperl.c [new file with mode: 0644]
ext/B/ramblings/cc.notes [new file with mode: 0644]
ext/B/ramblings/curcop.runtime [new file with mode: 0644]
ext/B/ramblings/flip-flop [new file with mode: 0644]
ext/B/ramblings/magic [new file with mode: 0644]
ext/B/ramblings/reg.alloc [new file with mode: 0644]
ext/B/ramblings/runtime.porting [new file with mode: 0644]
ext/B/typemap [new file with mode: 0644]
lib/B.pm [new file with mode: 0644]
lib/B/assemble [new file with mode: 0755]
lib/B/cc_harness [new file with mode: 0644]
lib/B/disassemble [new file with mode: 0755]
lib/B/makeliblinks [new file with mode: 0644]
lib/O.pm [new file with mode: 0644]

diff --git a/bytecode.h b/bytecode.h
new file mode 100644 (file)
index 0000000..bfa4025
--- /dev/null
@@ -0,0 +1,168 @@
+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)
diff --git a/bytecode.pl b/bytecode.pl
new file mode 100644 (file)
index 0000000..2423e3c
--- /dev/null
@@ -0,0 +1,377 @@
+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
diff --git a/cc_runtime.h b/cc_runtime.h
new file mode 100644 (file)
index 0000000..fe830c0
--- /dev/null
@@ -0,0 +1,71 @@
+#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)
diff --git a/ext/B/B.xs b/ext/B/B.xs
new file mode 100644 (file)
index 0000000..0bb7acb
--- /dev/null
@@ -0,0 +1,1207 @@
+/*     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));
+           }
+       }
diff --git a/ext/B/Makefile.PL b/ext/B/Makefile.PL
new file mode 100644 (file)
index 0000000..bcc8baa
--- /dev/null
@@ -0,0 +1,54 @@
+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
+}
diff --git a/ext/B/NOTES b/ext/B/NOTES
new file mode 100644 (file)
index 0000000..ee10ba0
--- /dev/null
@@ -0,0 +1,168 @@
+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.
diff --git a/ext/B/README b/ext/B/README
new file mode 100644 (file)
index 0000000..4e4ed25
--- /dev/null
@@ -0,0 +1,325 @@
+                 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
diff --git a/ext/B/TESTS b/ext/B/TESTS
new file mode 100644 (file)
index 0000000..e050f6c
--- /dev/null
@@ -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 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
diff --git a/ext/B/Todo b/ext/B/Todo
new file mode 100644 (file)
index 0000000..495be2e
--- /dev/null
@@ -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/ext/B/byteperl.c b/ext/B/byteperl.c
new file mode 100644 (file)
index 0000000..c4bf6d7
--- /dev/null
@@ -0,0 +1,103 @@
+#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()
+{
+}
diff --git a/ext/B/ramblings/cc.notes b/ext/B/ramblings/cc.notes
new file mode 100644 (file)
index 0000000..47bd65a
--- /dev/null
@@ -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/ext/B/ramblings/curcop.runtime b/ext/B/ramblings/curcop.runtime
new file mode 100644 (file)
index 0000000..9b8b7d5
--- /dev/null
@@ -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/ext/B/ramblings/flip-flop b/ext/B/ramblings/flip-flop
new file mode 100644 (file)
index 0000000..183d541
--- /dev/null
@@ -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/ext/B/ramblings/magic b/ext/B/ramblings/magic
new file mode 100644 (file)
index 0000000..e41930a
--- /dev/null
@@ -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/ext/B/ramblings/reg.alloc b/ext/B/ramblings/reg.alloc
new file mode 100644 (file)
index 0000000..7fd69f2
--- /dev/null
@@ -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/ext/B/ramblings/runtime.porting b/ext/B/ramblings/runtime.porting
new file mode 100644 (file)
index 0000000..4699b25
--- /dev/null
@@ -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/ext/B/typemap b/ext/B/typemap
new file mode 100644 (file)
index 0000000..7206a6a
--- /dev/null
@@ -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), (SV*)($var));
+
+
+T_MG_OBJ
+       sv_setiv(newSVrv($arg, "B::MAGIC"), (IV)$var);
diff --git a/lib/B.pm b/lib/B.pm
new file mode 100644 (file)
index 0000000..8545c5c
--- /dev/null
+++ b/lib/B.pm
@@ -0,0 +1,271 @@
+#      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;
diff --git a/lib/B/assemble b/lib/B/assemble
new file mode 100755 (executable)
index 0000000..43cc5bc
--- /dev/null
@@ -0,0 +1,30 @@
+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 @_ });
diff --git a/lib/B/cc_harness b/lib/B/cc_harness
new file mode 100644 (file)
index 0000000..79f8727
--- /dev/null
@@ -0,0 +1,12 @@
+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;
diff --git a/lib/B/disassemble b/lib/B/disassemble
new file mode 100755 (executable)
index 0000000..6530b80
--- /dev/null
@@ -0,0 +1,22 @@
+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/lib/B/makeliblinks b/lib/B/makeliblinks
new file mode 100644 (file)
index 0000000..8256078
--- /dev/null
@@ -0,0 +1,54 @@
+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;
diff --git a/lib/O.pm b/lib/O.pm
new file mode 100644 (file)
index 0000000..40d336e
--- /dev/null
+++ b/lib/O.pm
@@ -0,0 +1,21 @@
+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;
+