beos/beos.c BeOS port
beos/beosish.h BeOS port
beos/nm.c BeOS port
-bytecode.pl Produces ext/ByteLoader/byterun.h, ext/ByteLoader/byterun.c and ext/B/Asmdata.pm
+bytecode.pl Produces ext/B/Asmdata.pm
cc_runtime.h Macros need by runtime of compiler-generated code
cflags.SH A script that emits C compilation flags per file
Changes Differences from previous version
ext/attrs/Makefile.PL attrs extension makefile writer
ext/attrs/t/attrs.t See if attrs works with C<sub : attrs>
ext/B/B/Asmdata.pm Compiler backend data for assembler
-ext/B/B/assemble Assemble compiler bytecode
-ext/B/B/Assembler.pm Compiler backend assembler support functions
-ext/B/B/Bblock.pm Compiler basic block analysis support
-ext/B/B/Bytecode.pm Compiler Bytecode backend
-ext/B/B/cc_harness Simplistic wrapper for using -MO=CC compiler
-ext/B/B/CC.pm Compiler CC backend
ext/B/B/Concise.pm Compiler Concise backend
-ext/B/B/C.pm Compiler C backend
ext/B/B/Debug.pm Compiler Debug backend
ext/B/B/Deparse.pm Compiler Deparse backend
-ext/B/B/disassemble Disassemble compiler bytecode output
-ext/B/B/Disassembler.pm Compiler Disassembler backend
ext/B/B/Lint.pm Compiler Lint backend
-ext/B/B/makeliblinks Make a simplistic XSUB .so symlink tree for compiler
ext/B/B.pm Compiler backend support functions and methods
ext/B/B/Showlex.pm Compiler Showlex backend
-ext/B/B/Stackobj.pm Compiler stack objects support functions
-ext/B/B/Stash.pm Compiler module to identify stashes
ext/B/B/Terse.pm Compiler Terse backend
ext/B/B/Xref.pm Compiler Xref backend
ext/B/B.xs Compiler backend external subroutines
-ext/B/C/C.xs Compiler C backend external subroutines
-ext/B/C/Makefile.PL Compiler C backend makefile writer
ext/B/defsubs_h.PL Generator for constant subroutines
ext/B/hints/darwin.pl Hints for named architecture
ext/B/hints/openbsd.pl Hints for named architecture
ext/B/Makefile.PL Compiler backend makefile writer
-ext/B/NOTES Compiler backend notes
ext/B/O.pm Compiler front-end module (-MO=...)
-ext/B/ramblings/cc.notes Compiler ramblings: notes on CC backend
-ext/B/ramblings/curcop.runtime Compiler ramblings: notes on curcop use
-ext/B/ramblings/flip-flop Compiler ramblings: notes on flip-flop
-ext/B/ramblings/magic Compiler ramblings: notes on magic
-ext/B/ramblings/reg.alloc Compiler ramblings: register allocation
-ext/B/ramblings/runtime.porting Compiler ramblings: porting PP engine
-ext/B/README Compiler backend README
-ext/B/t/asmdata.t See if B::Asmdata works
-ext/B/t/assembler.t See if B::Assembler, B::Disassembler comply
-ext/B/t/bblock.t See if B::Bblock works
ext/B/t/b.t See if B works
-ext/B/t/bytecode.t See whether B::Bytecode works
ext/B/t/concise.t See whether B::Concise works
ext/B/t/concise-xs.t See whether B::Concise recognizes XS functions
ext/B/t/debug.t See if B::Debug works
ext/B/t/deparse.t See if B::Deparse works
-ext/B/TESTS Compiler backend test data
ext/B/t/f_map code from perldoc -f map
ext/B/t/f_map.t converted to optreeCheck()s
ext/B/t/f_sort optree test raw material
ext/B/t/f_sort.t optree test raw material
ext/B/t/lint.t See if B::Lint works
-ext/B/Todo Compiler backend Todo list
ext/B/t/OptreeCheck.pm optree comparison tool
ext/B/t/optree_check.t test OptreeCheck apparatus
ext/B/t/optree_concise.t more B::Concise tests
ext/B/t/optree_varinit.t my,our,local var init optimization
ext/B/t/o.t See if O works
ext/B/t/showlex.t See if B::ShowLex works
-ext/B/t/stash.t See if B::Stash works
ext/B/t/terse.t See if B::Terse works
ext/B/t/xref.t See if B::Xref works
ext/B/typemap Compiler backend interface types
-ext/ByteLoader/bytecode.h Bytecode header for bytecode loader
-ext/ByteLoader/ByteLoader.pm Bytecode loader Perl module
-ext/ByteLoader/ByteLoader.xs Bytecode loader external subroutines
-ext/ByteLoader/byterun.c Runtime support for bytecode loader
-ext/ByteLoader/byterun.h Header for byterun.c
-ext/ByteLoader/hints/sunos.pl Hints for named architecture
-ext/ByteLoader/Makefile.PL Bytecode loader makefile writer
ext/Compress/IO/Base/Changes IO::Compress::Base
ext/Compress/IO/Base/lib/File/GlobMapper.pm IO::Compress::Base
ext/Compress/IO/Base/lib/IO/Compress/Base/Common.pm IO::Compress::Base
utils.lst Lists utilities bundled with Perl
utils/Makefile Extract the utility scripts
utils/perlbug.PL A simple tool to submit a bug report
-utils/perlcc.PL Front-end for compiler
utils/perldoc.PL A simple tool to find & display perl's documentation
utils/perlivp.PL installation verification procedure
utils/piconv.PL iconv(1), reinvented in perl
@echo " ";
@echo " Everything is up to date. Type '$(MAKE) test' to run test suite."
-.PHONY: all compile translators utilities
-
-compile: all
- echo "testing compilation" > testcompile;
- cd utils; $(MAKE) compile;
- cd x2p; $(MAKE) compile;
- cd pod; $(MAKE) compile;
+.PHONY: all translators utilities
translators: miniperl$(EXE_EXT) $(CONFIGPM) FORCE
@echo " "; echo " Making x2p stuff"; cd x2p; $(LDLIBPTH) $(MAKE) all
INSTALL_DEPENDENCE = all
install.perl: $(INSTALL_DEPENDENCE) installperl
- if [ -n "$(COMPILE)" ]; \
- then \
- cd utils; $(MAKE) compile; \
- cd ../x2p; $(MAKE) compile; \
- cd ../pod; $(MAKE) compile; \
- else :; \
- fi
$(LDLIBPTH) ./perl installperl --destdir=$(DESTDIR) $(INSTALLFLAGS) $(STRIPFLAGS)
$(MAKE) extras.install
# The following files are generated automatically
# autodoc.pl: pod/perlapi.pod pod/perlintern.pod
-# bytecode.pl: ext/ByteLoader/byterun.h ext/ByteLoader/byterun.c
-# ext/B/B/Asmdata.pm
# embed.pl: proto.h embed.h embedvar.h global.sym
# perlapi.h perlapi.c
# [* embed.pl needs pp.sym generated by opcode.pl! *]
AUTOGEN_FILES = keywords.h opcode.h opnames.h pp_proto.h pp.sym proto.h \
embed.h embedvar.h global.sym \
pod/perlintern.pod pod/perlapi.pod \
- perlapi.h perlapi.c ext/ByteLoader/byterun.h \
- ext/ByteLoader/byterun.c ext/B/B/Asmdata.pm regnodes.h \
+ perlapi.h perlapi.c regnodes.h \
warnings.h lib/warnings.pm
.PHONY: regen_headers regen_pods regen_all
-@for x in $(DYNALOADER) $(dynamic_ext) $(static_ext) $(nonxs_ext) ; do \
$(LDLIBPTH) sh ext/util/make_ext clean $$x MAKE=$(MAKE) ; \
done
- rm -f testcompile compilelog
_cleaner1:
-cd os2; rm -f Makefile
rm -f h2ph.man pstruct
rm -rf .config
rm -f preload
- rm -f testcompile compilelog
rm -rf lib/Encode lib/Compress lib/Hash
rm -rf lib/IO/Compress lib/IO/Uncompress
rm -f lib/ExtUtils/ParseXS/t/XSTest.c
test.utf16 check.utf16 utest.utf16 ucheck.utf16 \
test.third check.third utest.third ucheck.third test_notty.third \
test.deparse test_notty.deparse test_harness test_harness_notty \
- test.bytecompile minitest coretest test.taintwarn
+ minitest coretest test.taintwarn
# Cannot delegate rebuilding of t/perl to make
# to allow interlaced test and minitest
test_notty.third: test_prep.third perl.third
PERL=./perl.third $(MAKE) PERL_DEBUG=PERL_3LOG=1 _test_notty
-# Targets for Bytecode/ByteLoader testing.
-
-test.bytecompile: test_prep
- PERL=./perl TEST_ARGS=-bytecompile $(MAKE) _test
-
# Targets for Deparse testing.
test.deparse: test_prep
..\utils\c2ph \
..\utils\h2xs \
..\utils\perldoc \
- ..\utils\perlcc \
..\pod\checkpods \
..\pod\pod2html \
..\pod\pod2latex \
my $perl_header;
($perl_header = $c_header) =~ s{[/ ]?\*/?}{#}g;
-safer_unlink "ext/ByteLoader/byterun.c", "ext/ByteLoader/byterun.h", "ext/B/B/Asmdata.pm";
+safer_unlink "ext/B/B/Asmdata.pm";
#
# Start with boilerplate for Asmdata.pm
# I get a hard-to-track-down stack underflow and segfault.
EOT
-#
-# Boilerplate for byterun.c
-#
-open(BYTERUN_C, ">ext/ByteLoader/byterun.c") or die "ext/ByteLoader/byterun.c: $!";
-binmode BYTERUN_C;
-print BYTERUN_C $c_header, <<'EOT';
-
-#define PERL_NO_GET_CONTEXT
-#include "EXTERN.h"
-#include "perl.h"
-#define NO_XSLOCKS
-#include "XSUB.h"
-
-#include "byterun.h"
-#include "bytecode.h"
-
-
-static const int optype_size[] = {
-EOT
-my $i = 0;
-for ($i = 0; $i < @optype - 1; $i++) {
- printf BYTERUN_C " sizeof(%s),\n", $optype[$i], $i;
-}
-printf BYTERUN_C " sizeof(%s)\n", $optype[$i], $i;
-
my $size = @specialsv;
-print BYTERUN_C <<"EOT";
-};
-
-void *
-bset_obj_store(pTHX_ struct byteloader_state *bstate, void *obj, I32 ix)
-{
- if (ix > bstate->bs_obj_list_fill) {
- Renew(bstate->bs_obj_list, ix + 32, void*);
- bstate->bs_obj_list_fill = ix + 31;
- }
- bstate->bs_obj_list[ix] = obj;
- return obj;
-}
-
-int
-byterun(pTHX_ register struct byteloader_state *bstate)
-{
- dVAR;
- register int insn;
- U32 ix;
- SV *specialsv_list[$size];
-
- BYTECODE_HEADER_CHECK; /* croak if incorrect platform */
- Newx(bstate->bs_obj_list, 32, void*); /* set op objlist */
- bstate->bs_obj_list_fill = 31;
- bstate->bs_obj_list[0] = NULL; /* first is always Null */
- bstate->bs_ix = 1;
-
-EOT
-
-for my $i ( 0 .. $#specialsv ) {
- print BYTERUN_C " specialsv_list[$i] = $specialsv[$i];\n";
-}
-
-print BYTERUN_C <<'EOT';
-
- while ((insn = BGET_FGETC()) != EOF) {
- switch (insn) {
-EOT
-
-
my (@insn_name, $insn_num, $insn, $lvalue, $argtype, $flags, $fundtype);
while (<DATA>) {
if (/^\s*#/) {
- print BYTERUN_C if /^\s*#\s*(?:if|endif|el)/;
next;
}
chop;
$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 bytecode_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 = ${rvalcast}arg;\n";
- }
- print BYTERUN_C "\t\tbreak;\n\t }\n";
-
- #
# Add the initialiser line for %insn_data in Asmdata.pm
#
print ASMDATA_PM <<"EOT";
}
#
-# Finish off byterun.c
-#
-print BYTERUN_C <<'EOT';
- default:
- Perl_croak(aTHX_ "Illegal bytecode instruction %d\n", insn);
- /* NOTREACHED */
- }
- }
- return 0;
-}
-
-/* ex: set ro: */
-EOT
-
-#
-# Write the instruction and optype enum constants into byterun.h
-#
-open(BYTERUN_H, ">ext/ByteLoader/byterun.h") or die "ext/ByteLoader/byterun.h: $!";
-binmode BYTERUN_H;
-print BYTERUN_H $c_header, <<'EOT';
-struct byteloader_fdata {
- SV *datasv;
- int next_out;
- int idx;
-};
-
-struct byteloader_pv_state {
- char *pvx;
- XPV xpv;
-};
-
-struct byteloader_state {
- struct byteloader_fdata *bs_fdata;
- SV *bs_sv;
- void **bs_obj_list;
- int bs_obj_list_fill;
- int bs_ix;
- struct byteloader_pv_state bs_pv;
- int bs_iv_overflows;
-};
-
-int bl_getc(struct byteloader_fdata *);
-int bl_read(struct byteloader_fdata *, char *, size_t, size_t);
-extern int byterun(pTHX_ struct byteloader_state *);
-
-enum {
-EOT
-
-my $add_enum_value = 0;
-my $max_insn;
-for $i ( 0 .. $#insn_name ) {
- $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 "/* ex: set ro: */\n";
-
-#
# Finish off insn_data and create array initialisers in Asmdata.pm
#
print ASMDATA_PM <<'EOT';
=head1 NAME
-B::Asmdata - Autogenerated data about Perl ops, used to generate bytecode
+B::Asmdata - Autogenerated data about Perl ops
=head1 SYNOPSIS
close ASMDATA_PM or die "Error closing ASMDATA_PM: $!";
-close BYTERUN_H or die "Error closing BYTERUN_H: $!";
-close BYTERUN_C or die "Error closing BYTERUN_C: $!";
__END__
# First set instruction ord("#") to read comment to end-of-line (sneaky)
$ WRITE CONFIG "$ instmodsh == """ + perl_setup_perl + " ''vms_prefix':[utils]instmodsh.com"""
$ WRITE CONFIG "$ libnetcfg == """ + perl_setup_perl + " ''vms_prefix':[utils]libnetcfg.com"""
$ WRITE CONFIG "$ perlbug == """ + perl_setup_perl + " ''vms_prefix':[utils]perlbug.com"""
-$ WRITE CONFIG "$!perlcc == """ + perl_setup_perl + " ''vms_prefix':[utils]perlcc.com"""
$ WRITE CONFIG "$ perldoc == """ + perl_setup_perl + " ''vms_prefix':[utils]perldoc.com """"-t"""""""
$ WRITE CONFIG "$ perlivp == """ + perl_setup_perl + " ''vms_prefix':[utils]perlivp.com"""
$ WRITE CONFIG "$ piconv == """ + perl_setup_perl + " ''vms_prefix':[utils]piconv.com"""
=head1 NAME
-B::Asmdata - Autogenerated data about Perl ops, used to generate bytecode
+B::Asmdata - Autogenerated data about Perl ops
=head1 SYNOPSIS
+++ /dev/null
-# Assembler.pm
-#
-# Copyright (c) 1996 Malcolm Beattie
-#
-# You may distribute under the terms of either the GNU General Public
-# License or the Artistic License, as specified in the README file.
-
-package B::Assembler;
-use Exporter;
-use B qw(ppname);
-use B::Asmdata qw(%insn_data @insn_name);
-use Config qw(%Config);
-require ByteLoader; # we just need its $VERSION
-
-no warnings; # XXX
-
-@ISA = qw(Exporter);
-@EXPORT_OK = qw(assemble_fh newasm endasm assemble asm);
-$VERSION = 0.07;
-
-use strict;
-my %opnumber;
-my ($i, $opname);
-for ($i = 0; defined($opname = ppname($i)); $i++) {
- $opnumber{$opname} = $i;
-}
-
-my($linenum, $errors, $out); # global state, set up by newasm
-
-sub error {
- my $str = shift;
- warn "$linenum: $str\n";
- $errors++;
-}
-
-my $debug = 0;
-sub debug { $debug = shift }
-
-sub limcheck($$$$){
- my( $val, $lo, $hi, $loc ) = @_;
- if( $val < $lo || $hi < $val ){
- error "argument for $loc outside [$lo, $hi]: $val";
- $val = $hi;
- }
- return $val;
-}
-
-#
-# First define all the data conversion subs to which Asmdata will refer
-#
-
-sub B::Asmdata::PUT_U8 {
- my $arg = shift;
- my $c = uncstring($arg);
- if (defined($c)) {
- if (length($c) != 1) {
- error "argument for U8 is too long: $c";
- $c = substr($c, 0, 1);
- }
- } else {
- $arg = limcheck( $arg, 0, 0xff, 'U8' );
- $c = chr($arg);
- }
- return $c;
-}
-
-sub B::Asmdata::PUT_U16 {
- my $arg = limcheck( $_[0], 0, 0xffff, 'U16' );
- pack("S", $arg);
-}
-sub B::Asmdata::PUT_U32 {
- my $arg = limcheck( $_[0], 0, 0xffffffff, 'U32' );
- pack("L", $arg);
-}
-sub B::Asmdata::PUT_I32 {
- my $arg = limcheck( $_[0], -0x80000000, 0x7fffffff, 'I32' );
- pack("l", $arg);
-}
-sub B::Asmdata::PUT_NV { sprintf("%s\0", $_[0]) } # "%lf" looses precision and pack('d',...)
- # may not even be portable between compilers
-sub B::Asmdata::PUT_objindex { # could allow names here
- my $arg = limcheck( $_[0], 0, 0xffffffff, '*index' );
- pack("L", $arg);
-}
-sub B::Asmdata::PUT_svindex { &B::Asmdata::PUT_objindex }
-sub B::Asmdata::PUT_opindex { &B::Asmdata::PUT_objindex }
-sub B::Asmdata::PUT_pvindex { &B::Asmdata::PUT_objindex }
-
-sub B::Asmdata::PUT_strconst {
- my $arg = shift;
- my $str = uncstring($arg);
- if (!defined($str)) {
- error "bad string constant: $arg";
- $str = '';
- }
- if ($str =~ s/\0//g) {
- error "string constant argument contains NUL: $arg";
- $str = '';
- }
- return $str . "\0";
-}
-
-sub B::Asmdata::PUT_pvcontents {
- my $arg = shift;
- error "extraneous argument: $arg" if defined $arg;
- return "";
-}
-sub B::Asmdata::PUT_PV {
- my $arg = shift;
- my $str = uncstring($arg);
- if( ! defined($str) ){
- error "bad string argument: $arg";
- $str = '';
- }
- return pack("L", length($str)) . $str;
-}
-sub B::Asmdata::PUT_comment_t {
- my $arg = shift;
- $arg = uncstring($arg);
- error "bad string argument: $arg" unless defined($arg);
- if ($arg =~ s/\n//g) {
- error "comment argument contains linefeed: $arg";
- }
- return $arg . "\n";
-}
-sub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) } # see PUT_NV above
-sub B::Asmdata::PUT_none {
- my $arg = shift;
- error "extraneous argument: $arg" if defined $arg;
- return "";
-}
-sub B::Asmdata::PUT_op_tr_array {
- my @ary = split /\s*,\s*/, shift;
- return pack "S*", @ary;
-}
-
-sub B::Asmdata::PUT_IV64 {
- return pack "Q", shift;
-}
-
-sub B::Asmdata::PUT_IV {
- $Config{ivsize} == 4 ? &B::Asmdata::PUT_I32 : &B::Asmdata::PUT_IV64;
-}
-
-sub B::Asmdata::PUT_PADOFFSET {
- $Config{ptrsize} == 8 ? &B::Asmdata::PUT_IV64 : &B::Asmdata::PUT_U32;
-}
-
-sub B::Asmdata::PUT_long {
- $Config{longsize} == 8 ? &B::Asmdata::PUT_IV64 : &B::Asmdata::PUT_U32;
-}
-
-sub B::Asmdata::PUT_svtype { # svtype is an enum, so an int.
- $Config{intsize} == 4 ? &B::Asmdata::PUT_U32 : &B::Asmdata::PUT_IV64;
-}
-
-my %unesc = (n => "\n", r => "\r", t => "\t", a => "\a",
- b => "\b", f => "\f", v => "\013");
-
-sub uncstring {
- my $s = shift;
- $s =~ s/^"// and $s =~ s/"$// or return undef;
- $s =~ s/\\(\d\d\d|.)/length($1) == 3 ? chr(oct($1)) : ($unesc{$1}||$1)/eg;
- return $s;
-}
-
-sub strip_comments {
- my $stmt = shift;
- # Comments only allowed in instructions which don't take string arguments
- # Treat string as a single line so .* eats \n characters.
- $stmt =~ s{
- ^\s* # Ignore leading whitespace
- (
- [^"]* # A double quote '"' indicates a string argument. If we
- # find a double quote, the match fails and we strip nothing.
- )
- \s*\# # Any amount of whitespace plus the comment marker...
- .*$ # ...which carries on to end-of-string.
- }{$1}sx; # Keep only the instruction and optional argument.
- return $stmt;
-}
-
-# create the ByteCode header: magic, archname, ByteLoader $VERSION, ivsize,
-# ptrsize, byteorder
-# nvtype is irrelevant (floats are stored as strings)
-# byteorder is strconst not U32 because of varying size issues
-
-sub gen_header {
- my $header = "";
-
- $header .= B::Asmdata::PUT_U32(0x43424c50); # 'PLBC'
- $header .= B::Asmdata::PUT_strconst('"' . $Config{archname}. '"');
- $header .= B::Asmdata::PUT_strconst(qq["$ByteLoader::VERSION"]);
- $header .= B::Asmdata::PUT_U32($Config{ivsize});
- $header .= B::Asmdata::PUT_U32($Config{ptrsize});
- $header;
-}
-
-sub parse_statement {
- my $stmt = shift;
- my ($insn, $arg) = $stmt =~ m{
- ^\s* # allow (but ignore) leading whitespace
- (.*?) # Instruction continues up until...
- (?: # ...an optional whitespace+argument group
- \s+ # first whitespace.
- (.*) # The argument is all the rest (newlines included).
- )?$ # anchor at end-of-line
- }sx;
- if (defined($arg)) {
- if ($arg =~ s/^0x(?=[0-9a-fA-F]+$)//) {
- $arg = hex($arg);
- } elsif ($arg =~ s/^0(?=[0-7]+$)//) {
- $arg = oct($arg);
- } elsif ($arg =~ /^pp_/) {
- $arg =~ s/\s*$//; # strip trailing whitespace
- my $opnum = $opnumber{$arg};
- if (defined($opnum)) {
- $arg = $opnum;
- } else {
- error qq(No such op type "$arg");
- $arg = 0;
- }
- }
- }
- return ($insn, $arg);
-}
-
-sub assemble_insn {
- my ($insn, $arg) = @_;
- my $data = $insn_data{$insn};
- if (defined($data)) {
- my ($bytecode, $putsub) = @{$data}[0, 1];
- my $argcode = &$putsub($arg);
- return chr($bytecode).$argcode;
- } else {
- error qq(no such instruction "$insn");
- return "";
- }
-}
-
-sub assemble_fh {
- my ($fh, $out) = @_;
- my $line;
- my $asm = newasm($out);
- while ($line = <$fh>) {
- assemble($line);
- }
- endasm();
-}
-
-sub newasm {
- my($outsub) = @_;
-
- die "Invalid printing routine for B::Assembler\n" unless ref $outsub eq 'CODE';
- die <<EOD if ref $out;
-Can't have multiple byteassembly sessions at once!
- (perhaps you forgot an endasm()?)
-EOD
-
- $linenum = $errors = 0;
- $out = $outsub;
-
- $out->(gen_header());
-}
-
-sub endasm {
- if ($errors) {
- die "There were $errors assembly errors\n";
- }
- $linenum = $errors = $out = 0;
-}
-
-sub assemble {
- my($line) = @_;
- my ($insn, $arg);
- $linenum++;
- chomp $line;
- if ($debug) {
- my $quotedline = $line;
- $quotedline =~ s/\\/\\\\/g;
- $quotedline =~ s/"/\\"/g;
- $out->(assemble_insn("comment", qq("$quotedline")));
- }
- if( $line = strip_comments($line) ){
- ($insn, $arg) = parse_statement($line);
- $out->(assemble_insn($insn, $arg));
- if ($debug) {
- $out->(assemble_insn("nop", undef));
- }
- }
-}
-
-### temporary workaround
-
-sub asm {
- return if $_[0] =~ /\s*\W/;
- if (defined $_[1]) {
- return if $_[1] eq "0" and
- $_[0] !~ /^(?:newsvx?|av_pushx?|av_extend|xav_flags)$/;
- return if $_[1] eq "1" and $_[0] =~ /^(?:sv_refcnt)$/;
- }
- assemble "@_";
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-B::Assembler - Assemble Perl bytecode
-
-=head1 SYNOPSIS
-
- use B::Assembler qw(newasm endasm assemble);
- newasm(\&printsub); # sets up for assembly
- assemble($buf); # assembles one line
- endasm(); # closes down
-
- use B::Assembler qw(assemble_fh);
- assemble_fh($fh, \&printsub); # assemble everything in $fh
-
-=head1 DESCRIPTION
-
-See F<ext/B/B/Assembler.pm>.
-
-=head1 AUTHORS
-
-Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
-Per-statement interface by Benjamin Stuhl, C<sho_pi@hotmail.com>
-
-=cut
+++ /dev/null
-package B::Bblock;
-
-our $VERSION = '1.02';
-
-use Exporter ();
-@ISA = "Exporter";
-@EXPORT_OK = qw(find_leaders);
-
-use B qw(peekop walkoptree walkoptree_exec
- main_root main_start svref_2object
- OPf_SPECIAL OPf_STACKED );
-
-use B::Concise qw(concise_cv concise_main set_style_standard);
-use strict;
-
-my $bblock;
-my @bblock_ends;
-
-sub mark_leader {
- my $op = shift;
- if ($$op) {
- $bblock->{$$op} = $op;
- }
-}
-
-sub remove_sortblock{
- foreach (keys %$bblock){
- my $leader=$$bblock{$_};
- delete $$bblock{$_} if( $leader == 0);
- }
-}
-sub find_leaders {
- my ($root, $start) = @_;
- $bblock = {};
- mark_leader($start) if ( ref $start ne "B::NULL" );
- walkoptree($root, "mark_if_leader") if ((ref $root) ne "B::NULL") ;
- remove_sortblock();
- return $bblock;
-}
-
-# Debugging
-sub walk_bblocks {
- my ($root, $start) = @_;
- my ($op, $lastop, $leader, $bb);
- $bblock = {};
- mark_leader($start);
- walkoptree($root, "mark_if_leader");
- my @leaders = values %$bblock;
- while ($leader = shift @leaders) {
- $lastop = $leader;
- $op = $leader->next;
- while ($$op && !exists($bblock->{$$op})) {
- $bblock->{$$op} = $leader;
- $lastop = $op;
- $op = $op->next;
- }
- push(@bblock_ends, [$leader, $lastop]);
- }
- foreach $bb (@bblock_ends) {
- ($leader, $lastop) = @$bb;
- printf "%s .. %s\n", peekop($leader), peekop($lastop);
- for ($op = $leader; $$op != $$lastop; $op = $op->next) {
- printf " %s\n", peekop($op);
- }
- printf " %s\n", peekop($lastop);
- }
-}
-
-sub walk_bblocks_obj {
- my $cvref = shift;
- my $cv = svref_2object($cvref);
- walk_bblocks($cv->ROOT, $cv->START);
-}
-
-sub B::OP::mark_if_leader {}
-
-sub B::COP::mark_if_leader {
- my $op = shift;
- if ($op->label) {
- mark_leader($op);
- }
-}
-
-sub B::LOOP::mark_if_leader {
- my $op = shift;
- mark_leader($op->next);
- mark_leader($op->nextop);
- mark_leader($op->redoop);
- mark_leader($op->lastop->next);
-}
-
-sub B::LOGOP::mark_if_leader {
- my $op = shift;
- my $opname = $op->name;
- mark_leader($op->next);
- if ($opname eq "entertry") {
- mark_leader($op->other->next);
- } else {
- mark_leader($op->other);
- }
-}
-
-sub B::LISTOP::mark_if_leader {
- my $op = shift;
- my $first=$op->first;
- $first=$first->next while ($first->name eq "null");
- mark_leader($op->first) unless (exists( $bblock->{$$first}));
- mark_leader($op->next);
- if ($op->name eq "sort" and $op->flags & OPf_SPECIAL
- and $op->flags & OPf_STACKED){
- my $root=$op->first->sibling->first;
- my $leader=$root->first;
- $bblock->{$$leader} = 0;
- }
-}
-
-sub B::PMOP::mark_if_leader {
- my $op = shift;
- if ($op->name ne "pushre") {
- my $replroot = $op->pmreplroot;
- if ($$replroot) {
- mark_leader($replroot);
- mark_leader($op->next);
- mark_leader($op->pmreplstart);
- }
- }
-}
-
-# PMOP stuff omitted
-
-sub compile {
- my @options = @_;
- B::clearsym();
- if (@options) {
- return sub {
- my $objname;
- foreach $objname (@options) {
- $objname = "main::$objname" unless $objname =~ /::/;
- eval "walk_bblocks_obj(\\&$objname)";
- die "walk_bblocks_obj(\\&$objname) failed: $@" if $@;
- print "-------\n";
- set_style_standard("terse");
- eval "concise_cv('exec', \\&$objname)";
- die "concise_cv('exec', \\&$objname) failed: $@" if $@;
- }
- }
- } else {
- return sub {
- walk_bblocks(main_root, main_start);
- print "-------\n";
- set_style_standard("terse");
- concise_main("exec");
- };
- }
-}
-
-# Basic block leaders:
-# Any COP (pp_nextstate) with a non-NULL label
-# [The op after a pp_enter] Omit
-# [The op after a pp_entersub. Don't count this one.]
-# The ops pointed at by nextop, redoop and lastop->op_next of a LOOP
-# The ops pointed at by op_next and op_other of a LOGOP, except
-# for pp_entertry which has op_next and op_other->op_next
-# The op pointed at by op_pmreplstart of a PMOP
-# The op pointed at by op_other->op_pmreplstart of pp_substcont?
-# [The op after a pp_return] Omit
-
-1;
-
-__END__
-
-=head1 NAME
-
-B::Bblock - Walk basic blocks
-
-=head1 SYNOPSIS
-
- # External interface
- perl -MO=Bblock[,OPTIONS] foo.pl
-
- # Programmatic API
- use B::Bblock qw(find_leaders);
- my $leaders = find_leaders($root_op, $start_op);
-
-=head1 DESCRIPTION
-
-This module is used by the B::CC back end. It walks "basic blocks".
-A basic block is a series of operations which is known to execute from
-start to finish, with no possibility of branching or halting.
-
-It can be used either stand alone or from inside another program.
-
-=for _private
-Somebody who understands the stand-alone options document them, please.
-
-=head2 Functions
-
-=over 4
-
-=item B<find_leaders>
-
- my $leaders = find_leaders($root_op, $start_op);
-
-Given the root of the op tree and an op from which to start
-processing, it will return a hash ref representing all the ops which
-start a block.
-
-=for _private
-The above description may be somewhat wrong.
-
-The values of %$leaders are the op objects themselves. Keys are $$op
-addresses.
-
-=for _private
-Above cribbed from B::CC's comments. What's a $$op address?
-
-=back
-
-
-=head1 AUTHOR
-
-Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
-
-=cut
+++ /dev/null
-# B::Bytecode.pm
-# Copyright (c) 2003 Enache Adrian. All rights reserved.
-# This module is free software; you can redistribute and/or modify
-# it under the same terms as Perl itself.
-
-# Based on the original Bytecode.pm module written by Malcolm Beattie.
-
-package B::Bytecode;
-
-our $VERSION = '1.02';
-
-use strict;
-use Config;
-use B qw(class main_cv main_root main_start cstring comppadlist
- defstash curstash begin_av init_av end_av inc_gv warnhook diehook
- dowarn SVt_PVGV SVt_PVHV OPf_SPECIAL OPf_STACKED OPf_MOD
- OPpLVAL_INTRO SVf_FAKE SVf_READONLY);
-use B::Asmdata qw(@specialsv_name);
-use B::Assembler qw(asm newasm endasm);
-
-#################################################
-
-my ($varix, $opix, $savebegins, %walked, %files, @cloop);
-my %strtab = (0,0);
-my %svtab = (0,0);
-my %optab = (0,0);
-my %spectab = (0,0);
-my $tix = 1;
-sub asm;
-sub nice ($) { }
-
-BEGIN {
- my $ithreads = $Config{'useithreads'} eq 'define';
- eval qq{
- sub ITHREADS() { $ithreads }
- sub VERSION() { $] }
- }; die $@ if $@;
-}
-
-#################################################
-
-sub pvstring {
- my $pv = shift;
- defined($pv) ? cstring ($pv."\0") : "\"\"";
-}
-
-sub pvix {
- my $str = pvstring shift;
- my $ix = $strtab{$str};
- defined($ix) ? $ix : do {
- asm "newpv", $str;
- asm "stpv", $strtab{$str} = $tix;
- $tix++;
- }
-}
-
-sub B::OP::ix {
- my $op = shift;
- my $ix = $optab{$$op};
- defined($ix) ? $ix : do {
- nice "[".$op->name." $tix]";
- asm "newopx", $op->size | $op->type <<7;
- $optab{$$op} = $opix = $ix = $tix++;
- $op->bsave($ix);
- $ix;
- }
-}
-
-sub B::SPECIAL::ix {
- my $spec = shift;
- my $ix = $spectab{$$spec};
- defined($ix) ? $ix : do {
- nice '['.$specialsv_name[$$spec].']';
- asm "ldspecsvx", $$spec;
- $spectab{$$spec} = $varix = $tix++;
- }
-}
-
-sub B::SV::ix {
- my $sv = shift;
- my $ix = $svtab{$$sv};
- defined($ix) ? $ix : do {
- nice '['.class($sv).']';
- asm "newsvx", $sv->FLAGS;
- $svtab{$$sv} = $varix = $ix = $tix++;
- $sv->bsave($ix);
- $ix;
- }
-}
-
-sub B::GV::ix {
- my ($gv,$desired) = @_;
- my $ix = $svtab{$$gv};
- defined($ix) ? $ix : do {
- if ($gv->GP) {
- my ($svix, $avix, $hvix, $cvix, $ioix, $formix);
- nice "[GV]";
- my $name = $gv->STASH->NAME . "::" . $gv->NAME;
- asm "gv_fetchpvx", cstring $name;
- $svtab{$$gv} = $varix = $ix = $tix++;
- asm "sv_flags", $gv->FLAGS;
- asm "sv_refcnt", $gv->REFCNT;
- asm "xgv_flags", $gv->GvFLAGS;
-
- asm "gp_refcnt", $gv->GvREFCNT;
- asm "load_glob", $ix if $name eq "CORE::GLOBAL::glob";
- return $ix
- unless $desired || desired $gv;
- $svix = $gv->SV->ix;
- $avix = $gv->AV->ix;
- $hvix = $gv->HV->ix;
-
- # XXX {{{{
- my $cv = $gv->CV;
- $cvix = $$cv && defined $files{$cv->FILE} ? $cv->ix : 0;
- my $form = $gv->FORM;
- $formix = $$form && defined $files{$form->FILE} ? $form->ix : 0;
-
- $ioix = $name !~ /STDOUT$/ ? $gv->IO->ix : 0;
- # }}}} XXX
-
- nice "-GV-",
- asm "ldsv", $varix = $ix unless $ix == $varix;
- asm "gp_sv", $svix;
- asm "gp_av", $avix;
- asm "gp_hv", $hvix;
- asm "gp_cv", $cvix;
- asm "gp_io", $ioix;
- asm "gp_cvgen", $gv->CVGEN;
- asm "gp_form", $formix;
- asm "gp_file", pvix $gv->FILE;
- asm "gp_line", $gv->LINE;
- asm "formfeed", $svix if $name eq "main::\cL";
- } else {
- nice "[GV]";
- asm "newsvx", $gv->FLAGS;
- $svtab{$$gv} = $varix = $ix = $tix++;
- my $stashix = $gv->STASH->ix;
- $gv->B::PVMG::bsave($ix);
- asm "xgv_flags", $gv->GvFLAGS;
- asm "xgv_stash", $stashix;
- }
- $ix;
- }
-}
-
-sub B::HV::ix {
- my $hv = shift;
- my $ix = $svtab{$$hv};
- defined($ix) ? $ix : do {
- my ($ix,$i,@array);
- my $name = $hv->NAME;
- if ($name) {
- nice "[STASH]";
- asm "gv_stashpvx", cstring $name;
- asm "sv_flags", $hv->FLAGS;
- $svtab{$$hv} = $varix = $ix = $tix++;
- asm "xhv_name", pvix $name;
- # my $pmrootix = $hv->PMROOT->ix; # XXX
- asm "ldsv", $varix = $ix unless $ix == $varix;
- # asm "xhv_pmroot", $pmrootix; # XXX
- } else {
- nice "[HV]";
- asm "newsvx", $hv->FLAGS;
- $svtab{$$hv} = $varix = $ix = $tix++;
- my $stashix = $hv->SvSTASH->ix;
- for (@array = $hv->ARRAY) {
- next if $i = not $i;
- $_ = $_->ix;
- }
- nice "-HV-",
- asm "ldsv", $varix = $ix unless $ix == $varix;
- ($i = not $i) ? asm ("newpv", pvstring $_) : asm("hv_store", $_)
- for @array;
- if (VERSION < 5.009) {
- asm "xnv", $hv->NVX;
- }
- asm "xmg_stash", $stashix;
- asm "xhv_riter", $hv->RITER;
- }
- asm "sv_refcnt", $hv->REFCNT;
- $ix;
- }
-}
-
-sub B::NULL::ix {
- my $sv = shift;
- $$sv ? $sv->B::SV::ix : 0;
-}
-
-sub B::NULL::opwalk { 0 }
-
-#################################################
-
-sub B::NULL::bsave {
- my ($sv,$ix) = @_;
-
- nice '-'.class($sv).'-',
- asm "ldsv", $varix = $ix unless $ix == $varix;
- asm "sv_refcnt", $sv->REFCNT;
-}
-
-sub B::SV::bsave;
- *B::SV::bsave = *B::NULL::bsave;
-
-sub B::RV::bsave {
- my ($sv,$ix) = @_;
- my $rvix = $sv->RV->ix;
- $sv->B::NULL::bsave($ix);
- asm "xrv", $rvix;
-}
-
-sub B::PV::bsave {
- my ($sv,$ix) = @_;
- $sv->B::NULL::bsave($ix);
- asm "newpv", pvstring $sv->PVBM;
- asm "xpv";
-}
-
-sub B::IV::bsave {
- my ($sv,$ix) = @_;
- $sv->B::NULL::bsave($ix);
- asm "xiv", $sv->IVX;
-}
-
-sub B::NV::bsave {
- my ($sv,$ix) = @_;
- $sv->B::NULL::bsave($ix);
- asm "xnv", sprintf "%.40g", $sv->NVX;
-}
-
-sub B::PVIV::bsave {
- my ($sv,$ix) = @_;
- $sv->POK ?
- $sv->B::PV::bsave($ix):
- $sv->ROK ?
- $sv->B::RV::bsave($ix):
- $sv->B::NULL::bsave($ix);
- if (VERSION >= 5.009) {
- # See note below in B::PVNV::bsave
- return if $sv->isa('B::AV');
- return if $sv->isa('B::HV');
- return if $sv->isa('B::CV');
- }
- asm "xiv", !ITHREADS && $sv->FLAGS & (SVf_FAKE|SVf_READONLY) ?
- "0 but true" : $sv->IVX;
-}
-
-sub B::PVNV::bsave {
- my ($sv,$ix) = @_;
- $sv->B::PVIV::bsave($ix);
- if (VERSION >= 5.009) {
- # Magical AVs end up here, but AVs now don't have an NV slot actually
- # allocated. Hence don't write out assembly to store the NV slot if
- # we're actually an array.
- return if $sv->isa('B::AV');
- # Likewise HVs have no NV slot actually allocated.
- # I don't think that they can get here, but better safe than sorry
- return if $sv->isa('B::HV');
- return if $sv->isa('B::CV');
- return if $sv->isa('B::FM');
- }
- asm "xnv", sprintf "%.40g", $sv->NVX;
-}
-
-sub B::PVMG::domagic {
- my ($sv,$ix) = @_;
- nice '-MAGICAL-';
- my @mglist = $sv->MAGIC;
- my (@mgix, @namix);
- for (@mglist) {
- push @mgix, $_->OBJ->ix;
- push @namix, $_->PTR->ix if $_->LENGTH == B::HEf_SVKEY;
- }
-
- nice '-'.class($sv).'-',
- asm "ldsv", $varix = $ix unless $ix == $varix;
- for (@mglist) {
- asm "sv_magic", cstring $_->TYPE;
- asm "mg_obj", shift @mgix;
- my $length = $_->LENGTH;
- if ($length == B::HEf_SVKEY) {
- asm "mg_namex", shift @namix;
- } elsif ($length) {
- asm "newpv", pvstring $_->PTR;
- asm "mg_name";
- }
- }
-}
-
-sub B::PVMG::bsave {
- my ($sv,$ix) = @_;
- my $stashix = $sv->SvSTASH->ix;
- $sv->B::PVNV::bsave($ix);
- asm "xmg_stash", $stashix;
- $sv->domagic($ix) if $sv->MAGICAL;
-}
-
-sub B::PVLV::bsave {
- my ($sv,$ix) = @_;
- my $targix = $sv->TARG->ix;
- $sv->B::PVMG::bsave($ix);
- asm "xlv_targ", $targix;
- asm "xlv_targoff", $sv->TARGOFF;
- asm "xlv_targlen", $sv->TARGLEN;
- asm "xlv_type", $sv->TYPE;
-
-}
-
-sub B::BM::bsave {
- my ($sv,$ix) = @_;
- $sv->B::PVMG::bsave($ix);
- asm "xpv_cur", $sv->CUR;
- asm "xbm_useful", $sv->USEFUL;
- asm "xbm_previous", $sv->PREVIOUS;
- asm "xbm_rare", $sv->RARE;
-}
-
-sub B::IO::bsave {
- my ($io,$ix) = @_;
- my $topix = $io->TOP_GV->ix;
- my $fmtix = $io->FMT_GV->ix;
- my $bottomix = $io->BOTTOM_GV->ix;
- $io->B::PVMG::bsave($ix);
- asm "xio_lines", $io->LINES;
- asm "xio_page", $io->PAGE;
- asm "xio_page_len", $io->PAGE_LEN;
- asm "xio_lines_left", $io->LINES_LEFT;
- asm "xio_top_name", pvix $io->TOP_NAME;
- asm "xio_top_gv", $topix;
- asm "xio_fmt_name", pvix $io->FMT_NAME;
- asm "xio_fmt_gv", $fmtix;
- asm "xio_bottom_name", pvix $io->BOTTOM_NAME;
- asm "xio_bottom_gv", $bottomix;
- asm "xio_subprocess", $io->SUBPROCESS;
- asm "xio_type", ord $io->IoTYPE;
- # asm "xio_flags", ord($io->IoFLAGS) & ~32; # XXX XXX
-}
-
-sub B::CV::bsave {
- my ($cv,$ix) = @_;
- my $stashix = $cv->STASH->ix;
- my $gvix = $cv->GV->ix;
- my $padlistix = $cv->PADLIST->ix;
- my $outsideix = $cv->OUTSIDE->ix;
- my $constix = $cv->CONST ? $cv->XSUBANY->ix : 0;
- my $startix = $cv->START->opwalk;
- my $rootix = $cv->ROOT->ix;
-
- $cv->B::PVMG::bsave($ix);
- asm "xcv_stash", $stashix;
- asm "xcv_start", $startix;
- asm "xcv_root", $rootix;
- asm "xcv_xsubany", $constix;
- asm "xcv_gv", $gvix;
- asm "xcv_file", pvix $cv->FILE if $cv->FILE; # XXX AD
- asm "xcv_padlist", $padlistix;
- asm "xcv_outside", $outsideix;
- asm "xcv_flags", $cv->CvFLAGS;
- asm "xcv_outside_seq", $cv->OUTSIDE_SEQ;
- asm "xcv_depth", $cv->DEPTH;
-}
-
-sub B::FM::bsave {
- my ($form,$ix) = @_;
-
- $form->B::CV::bsave($ix);
- asm "xfm_lines", $form->LINES;
-}
-
-sub B::AV::bsave {
- my ($av,$ix) = @_;
- return $av->B::PVMG::bsave($ix) if $av->MAGICAL;
- my @array = $av->ARRAY;
- $_ = $_->ix for @array;
- my $stashix = $av->SvSTASH->ix;
-
- nice "-AV-",
- asm "ldsv", $varix = $ix unless $ix == $varix;
- asm "av_extend", $av->MAX if $av->MAX >= 0;
- asm "av_pushx", $_ for @array;
- asm "sv_refcnt", $av->REFCNT;
- if (VERSION < 5.009) {
- asm "xav_flags", $av->AvFLAGS;
- }
- asm "xmg_stash", $stashix;
-}
-
-sub B::GV::desired {
- my $gv = shift;
- my ($cv, $form);
- $files{$gv->FILE} && $gv->LINE
- || ${$cv = $gv->CV} && $files{$cv->FILE}
- || ${$form = $gv->FORM} && $files{$form->FILE}
-}
-
-sub B::HV::bwalk {
- my $hv = shift;
- return if $walked{$$hv}++;
- my %stash = $hv->ARRAY;
- while (my($k,$v) = each %stash) {
- if ($v->SvTYPE == SVt_PVGV) {
- my $hash = $v->HV;
- if ($$hash && $hash->NAME) {
- $hash->bwalk;
- }
- $v->ix(1) if desired $v;
- } else {
- nice "[prototype]";
- asm "gv_fetchpvx", cstring $hv->NAME . "::$k";
- $svtab{$$v} = $varix = $tix;
- $v->bsave($tix++);
- asm "sv_flags", $v->FLAGS;
- }
- }
-}
-
-######################################################
-
-
-sub B::OP::bsave_thin {
- my ($op, $ix) = @_;
- my $next = $op->next;
- my $nextix = $optab{$$next};
- $nextix = 0, push @cloop, $op unless defined $nextix;
- if ($ix != $opix) {
- nice '-'.$op->name.'-',
- asm "ldop", $opix = $ix;
- }
- asm "op_next", $nextix;
- asm "op_targ", $op->targ if $op->type; # tricky
- asm "op_flags", $op->flags;
- asm "op_private", $op->private;
-}
-
-sub B::OP::bsave;
- *B::OP::bsave = *B::OP::bsave_thin;
-
-sub B::UNOP::bsave {
- my ($op, $ix) = @_;
- my $name = $op->name;
- my $flags = $op->flags;
- my $first = $op->first;
- my $firstix =
- $name =~ /fl[io]p/
- # that's just neat
- || (!ITHREADS && $name eq 'regcomp')
- # trick for /$a/o in pp_regcomp
- || $name eq 'rv2sv'
- && $op->flags & OPf_MOD
- && $op->private & OPpLVAL_INTRO
- # change #18774 made my life hard
- ? $first->ix
- : 0;
-
- $op->B::OP::bsave($ix);
- asm "op_first", $firstix;
-}
-
-sub B::BINOP::bsave {
- my ($op, $ix) = @_;
- if ($op->name eq 'aassign' && $op->private & B::OPpASSIGN_HASH()) {
- my $last = $op->last;
- my $lastix = do {
- local *B::OP::bsave = *B::OP::bsave_fat;
- local *B::UNOP::bsave = *B::UNOP::bsave_fat;
- $last->ix;
- };
- asm "ldop", $lastix unless $lastix == $opix;
- asm "op_targ", $last->targ;
- $op->B::OP::bsave($ix);
- asm "op_last", $lastix;
- } else {
- $op->B::OP::bsave($ix);
- }
-}
-
-# not needed if no pseudohashes
-
-*B::BINOP::bsave = *B::OP::bsave if VERSION >= 5.009;
-
-# deal with sort / formline
-
-sub B::LISTOP::bsave {
- my ($op, $ix) = @_;
- my $name = $op->name;
- sub blocksort() { OPf_SPECIAL|OPf_STACKED }
- if ($name eq 'sort' && ($op->flags & blocksort) == blocksort) {
- my $first = $op->first;
- my $pushmark = $first->sibling;
- my $rvgv = $pushmark->first;
- my $leave = $rvgv->first;
-
- my $leaveix = $leave->ix;
-
- my $rvgvix = $rvgv->ix;
- asm "ldop", $rvgvix unless $rvgvix == $opix;
- asm "op_first", $leaveix;
-
- my $pushmarkix = $pushmark->ix;
- asm "ldop", $pushmarkix unless $pushmarkix == $opix;
- asm "op_first", $rvgvix;
-
- my $firstix = $first->ix;
- asm "ldop", $firstix unless $firstix == $opix;
- asm "op_sibling", $pushmarkix;
-
- $op->B::OP::bsave($ix);
- asm "op_first", $firstix;
- } elsif ($name eq 'formline') {
- $op->B::UNOP::bsave_fat($ix);
- } else {
- $op->B::OP::bsave($ix);
- }
-}
-
-# fat versions
-
-sub B::OP::bsave_fat {
- my ($op, $ix) = @_;
- my $siblix = $op->sibling->ix;
-
- $op->B::OP::bsave_thin($ix);
- asm "op_sibling", $siblix;
- # asm "op_seq", -1; XXX don't allocate OPs piece by piece
-}
-
-sub B::UNOP::bsave_fat {
- my ($op,$ix) = @_;
- my $firstix = $op->first->ix;
-
- $op->B::OP::bsave($ix);
- asm "op_first", $firstix;
-}
-
-sub B::BINOP::bsave_fat {
- my ($op,$ix) = @_;
- my $last = $op->last;
- my $lastix = $op->last->ix;
- if (VERSION < 5.009 && $op->name eq 'aassign' && $last->name eq 'null') {
- asm "ldop", $lastix unless $lastix == $opix;
- asm "op_targ", $last->targ;
- }
-
- $op->B::UNOP::bsave($ix);
- asm "op_last", $lastix;
-}
-
-sub B::LOGOP::bsave {
- my ($op,$ix) = @_;
- my $otherix = $op->other->ix;
-
- $op->B::UNOP::bsave($ix);
- asm "op_other", $otherix;
-}
-
-sub B::PMOP::bsave {
- my ($op,$ix) = @_;
- my ($rrop, $rrarg, $rstart);
-
- # my $pmnextix = $op->pmnext->ix; # XXX
-
- if (ITHREADS) {
- if ($op->name eq 'subst') {
- $rrop = "op_pmreplroot";
- $rrarg = $op->pmreplroot->ix;
- $rstart = $op->pmreplstart->ix;
- } elsif ($op->name eq 'pushre') {
- $rrop = "op_pmreplrootpo";
- $rrarg = $op->pmreplroot;
- }
- $op->B::BINOP::bsave($ix);
- asm "op_pmstashpv", pvix $op->pmstashpv;
- } else {
- $rrop = "op_pmreplrootgv";
- $rrarg = $op->pmreplroot->ix;
- $rstart = $op->pmreplstart->ix if $op->name eq 'subst';
- my $stashix = $op->pmstash->ix;
- $op->B::BINOP::bsave($ix);
- asm "op_pmstash", $stashix;
- }
-
- asm $rrop, $rrarg if $rrop;
- asm "op_pmreplstart", $rstart if $rstart;
-
- asm "op_pmflags", $op->pmflags;
- asm "op_pmpermflags", $op->pmpermflags;
- asm "op_pmdynflags", $op->pmdynflags;
- # asm "op_pmnext", $pmnextix; # XXX
- asm "newpv", pvstring $op->precomp;
- asm "pregcomp";
-}
-
-sub B::SVOP::bsave {
- my ($op,$ix) = @_;
- my $svix = $op->sv->ix;
-
- $op->B::OP::bsave($ix);
- asm "op_sv", $svix;
-}
-
-sub B::PADOP::bsave {
- my ($op,$ix) = @_;
-
- $op->B::OP::bsave($ix);
- asm "op_padix", $op->padix;
-}
-
-sub B::PVOP::bsave {
- my ($op,$ix) = @_;
- $op->B::OP::bsave($ix);
- return unless my $pv = $op->pv;
-
- if ($op->name eq 'trans') {
- asm "op_pv_tr", join ',', length($pv)/2, unpack("s*", $pv);
- } else {
- asm "newpv", pvstring $pv;
- asm "op_pv";
- }
-}
-
-sub B::LOOP::bsave {
- my ($op,$ix) = @_;
- my $nextix = $op->nextop->ix;
- my $lastix = $op->lastop->ix;
- my $redoix = $op->redoop->ix;
-
- $op->B::BINOP::bsave($ix);
- asm "op_redoop", $redoix;
- asm "op_nextop", $nextix;
- asm "op_lastop", $lastix;
-}
-
-sub B::COP::bsave {
- my ($cop,$ix) = @_;
- my $warnix = $cop->warnings->ix;
- if (ITHREADS) {
- $cop->B::OP::bsave($ix);
- asm "cop_stashpv", pvix $cop->stashpv;
- asm "cop_file", pvix $cop->file;
- } else {
- my $stashix = $cop->stash->ix;
- my $fileix = $cop->filegv->ix(1);
- $cop->B::OP::bsave($ix);
- asm "cop_stash", $stashix;
- asm "cop_filegv", $fileix;
- }
- asm "cop_label", pvix $cop->label if $cop->label; # XXX AD
- asm "cop_seq", $cop->cop_seq;
- asm "cop_arybase", $cop->arybase;
- asm "cop_line", $cop->line;
- asm "cop_warnings", $warnix;
-}
-
-sub B::OP::opwalk {
- my $op = shift;
- my $ix = $optab{$$op};
- defined($ix) ? $ix : do {
- my $ix;
- my @oplist = $op->oplist;
- push @cloop, undef;
- $ix = $_->ix while $_ = pop @oplist;
- while ($_ = pop @cloop) {
- asm "ldop", $optab{$$_};
- asm "op_next", $optab{${$_->next}};
- }
- $ix;
- }
-}
-
-#################################################
-
-sub save_cq {
- my $av;
- if (($av=begin_av)->isa("B::AV")) {
- if ($savebegins) {
- for ($av->ARRAY) {
- next unless $_->FILE eq $0;
- asm "push_begin", $_->ix;
- }
- } else {
- for ($av->ARRAY) {
- next unless $_->FILE eq $0;
- # XXX BEGIN { goto A while 1; A: }
- for (my $op = $_->START; $$op; $op = $op->next) {
- next unless $op->name eq 'require' ||
- # this kludge needed for tests
- $op->name eq 'gv' && do {
- my $gv = class($op) eq 'SVOP' ?
- $op->gv :
- (($_->PADLIST->ARRAY)[1]->ARRAY)[$op->padix];
- $$gv && $gv->NAME =~ /use_ok|plan/
- };
- asm "push_begin", $_->ix;
- last;
- }
- }
- }
- }
- if (($av=init_av)->isa("B::AV")) {
- for ($av->ARRAY) {
- next unless $_->FILE eq $0;
- asm "push_init", $_->ix;
- }
- }
- if (($av=end_av)->isa("B::AV")) {
- for ($av->ARRAY) {
- next unless $_->FILE eq $0;
- asm "push_end", $_->ix;
- }
- }
-}
-
-sub compile {
- my ($head, $scan, $T_inhinc, $keep_syn);
- my $cwd = '';
- $files{$0} = 1;
- sub keep_syn {
- $keep_syn = 1;
- *B::OP::bsave = *B::OP::bsave_fat;
- *B::UNOP::bsave = *B::UNOP::bsave_fat;
- *B::BINOP::bsave = *B::BINOP::bsave_fat;
- *B::LISTOP::bsave = *B::LISTOP::bsave_fat;
- }
- sub bwarn { print STDERR "Bytecode.pm: @_\n" }
-
- for (@_) {
- if (/^-S/) {
- *newasm = *endasm = sub { };
- *asm = sub { print " @_\n" };
- *nice = sub ($) { print "\n@_\n" };
- } elsif (/^-H/) {
- require ByteLoader;
- $head = "#! $^X\nuse ByteLoader $ByteLoader::VERSION;\n";
- } elsif (/^-k/) {
- keep_syn;
- } elsif (/^-o(.*)$/) {
- open STDOUT, ">$1" or die "open $1: $!";
- } elsif (/^-f(.*)$/) {
- $files{$1} = 1;
- } elsif (/^-s(.*)$/) {
- $scan = length($1) ? $1 : $0;
- } elsif (/^-b/) {
- $savebegins = 1;
- # this is here for the testsuite
- } elsif (/^-TI/) {
- $T_inhinc = 1;
- } elsif (/^-TF(.*)/) {
- my $thatfile = $1;
- *B::COP::file = sub { $thatfile };
- } else {
- bwarn "Ignoring '$_' option";
- }
- }
- if ($scan) {
- my $f;
- if (open $f, $scan) {
- while (<$f>) {
- /^#\s*line\s+\d+\s+("?)(.*)\1/ and $files{$2} = 1;
- /^#/ and next;
- if (/\bgoto\b\s*[^&]/ && !$keep_syn) {
- bwarn "keeping the syntax tree: \"goto\" op found";
- keep_syn;
- }
- }
- } else {
- bwarn "cannot rescan '$scan'";
- }
- close $f;
- }
- binmode STDOUT;
- return sub {
- print $head if $head;
- newasm sub { print @_ };
-
- defstash->bwalk;
- asm "main_start", main_start->opwalk;
- asm "main_root", main_root->ix;
- asm "main_cv", main_cv->ix;
- asm "curpad", (comppadlist->ARRAY)[1]->ix;
-
- asm "signal", cstring "__WARN__" # XXX
- if warnhook->ix;
- asm "incav", inc_gv->AV->ix if $T_inhinc;
- save_cq;
- asm "incav", inc_gv->AV->ix if $T_inhinc;
- asm "dowarn", dowarn;
-
- {
- no strict 'refs';
- nice "<DATA>";
- my $dh = *{defstash->NAME."::DATA"};
- unless (eof $dh) {
- local undef $/;
- asm "data", ord 'D';
- print <$dh>;
- } else {
- asm "ret";
- }
- }
-
- endasm;
- }
-}
-
-1;
-
-=head1 NAME
-
-B::Bytecode - Perl compiler's bytecode backend
-
-=head1 SYNOPSIS
-
-B<perl -MO=Bytecode>[B<,-H>][B<,-o>I<script.plc>] I<script.pl>
-
-=head1 DESCRIPTION
-
-Compiles a Perl script into a bytecode format that could be loaded
-later by the ByteLoader module and executed as a regular Perl script.
-
-=head1 EXAMPLE
-
- $ perl -MO=Bytecode,-H,-ohi -e 'print "hi!\n"'
- $ perl hi
- hi!
-
-=head1 OPTIONS
-
-=over 4
-
-=item B<-b>
-
-Save all the BEGIN blocks. Normally only BEGIN blocks that C<require>
-other files (ex. C<use Foo;>) are saved.
-
-=item B<-H>
-
-prepend a C<use ByteLoader VERSION;> line to the produced bytecode.
-
-=item B<-k>
-
-keep the syntax tree - it is stripped by default.
-
-=item B<-o>I<outfile>
-
-put the bytecode in <outfile> instead of dumping it to STDOUT.
-
-=item B<-s>
-
-scan the script for C<# line ..> directives and for <goto LABEL>
-expressions. When gotos are found keep the syntax tree.
-
-=back
-
-=head1 KNOWN BUGS
-
-=over 4
-
-=item *
-
-C<BEGIN { goto A: while 1; A: }> won't even compile.
-
-=item *
-
-C<?...?> and C<reset> do not work as expected.
-
-=item *
-
-variables in C<(?{ ... })> constructs are not properly scoped.
-
-=item *
-
-scripts that use source filters will fail miserably.
-
-=back
-
-=head1 NOTICE
-
-There are also undocumented bugs and options.
-
-THIS CODE IS HIGHLY EXPERIMENTAL. USE AT YOUR OWN RISK.
-
-=head1 AUTHORS
-
-Originally written by Malcolm Beattie <mbeattie@sable.ox.ac.uk> and
-modified by Benjamin Stuhl <sho_pi@hotmail.com>.
-
-Rewritten by Enache Adrian <enache@rdslink.ro>, 2003 a.d.
-
-=cut
+++ /dev/null
-# C.pm
-#
-# Copyright (c) 1996, 1997, 1998 Malcolm Beattie
-#
-# You may distribute under the terms of either the GNU General Public
-# License or the Artistic License, as specified in the README file.
-#
-
-package B::C;
-
-our $VERSION = '1.05';
-
-package B::C::Section;
-
-use B ();
-use base B::Section;
-
-sub new
-{
- my $class = shift;
- my $o = $class->SUPER::new(@_);
- push @$o, { values => [] };
- return $o;
-}
-
-sub add
-{
- my $section = shift;
- push(@{$section->[-1]{values}},@_);
-}
-
-sub index
-{
- my $section = shift;
- return scalar(@{$section->[-1]{values}})-1;
-}
-
-sub output
-{
- my ($section, $fh, $format) = @_;
- my $sym = $section->symtable || {};
- my $default = $section->default;
- my $i;
- foreach (@{$section->[-1]{values}})
- {
- s{(s\\_[0-9a-f]+)}{ exists($sym->{$1}) ? $sym->{$1} : $default; }ge;
- printf $fh $format, $_, $i;
- ++$i;
- }
-}
-
-package B::C::InitSection;
-
-# avoid use vars
-@B::C::InitSection::ISA = qw(B::C::Section);
-
-sub new {
- my $class = shift;
- my $max_lines = 10000; #pop;
- my $section = $class->SUPER::new( @_ );
-
- $section->[-1]{evals} = [];
- $section->[-1]{chunks} = [];
- $section->[-1]{nosplit} = 0;
- $section->[-1]{current} = [];
- $section->[-1]{count} = 0;
- $section->[-1]{max_lines} = $max_lines;
-
- return $section;
-}
-
-sub split {
- my $section = shift;
- $section->[-1]{nosplit}--
- if $section->[-1]{nosplit} > 0;
-}
-
-sub no_split {
- shift->[-1]{nosplit}++;
-}
-
-sub inc_count {
- my $section = shift;
-
- $section->[-1]{count} += $_[0];
- # this is cheating
- $section->add();
-}
-
-sub add {
- my $section = shift->[-1];
- my $current = $section->{current};
- my $nosplit = $section->{nosplit};
-
- push @$current, @_;
- $section->{count} += scalar(@_);
- if( !$nosplit && $section->{count} >= $section->{max_lines} ) {
- push @{$section->{chunks}}, $current;
- $section->{current} = [];
- $section->{count} = 0;
- }
-}
-
-sub add_eval {
- my $section = shift;
- my @strings = @_;
-
- foreach my $i ( @strings ) {
- $i =~ s/\"/\\\"/g;
- }
- push @{$section->[-1]{evals}}, @strings;
-}
-
-sub output {
- my( $section, $fh, $format, $init_name ) = @_;
- my $sym = $section->symtable || {};
- my $default = $section->default;
- push @{$section->[-1]{chunks}}, $section->[-1]{current};
-
- my $name = "aaaa";
- foreach my $i ( @{$section->[-1]{chunks}} ) {
- print $fh <<"EOT";
-static int perl_init_${name}()
-{
- dTARG;
- dSP;
-EOT
- foreach my $j ( @$i ) {
- $j =~ s{(s\\_[0-9a-f]+)}
- { exists($sym->{$1}) ? $sym->{$1} : $default; }ge;
- print $fh "\t$j\n";
- }
- print $fh "\treturn 0;\n}\n";
-
- $section->SUPER::add( "perl_init_${name}();" );
- ++$name;
- }
- foreach my $i ( @{$section->[-1]{evals}} ) {
- $section->SUPER::add( sprintf q{eval_pv("%s",1);}, $i );
- }
-
- print $fh <<"EOT";
-static int ${init_name}()
-{
- dTARG;
- dSP;
-EOT
- $section->SUPER::output( $fh, $format );
- print $fh "\treturn 0;\n}\n";
-}
-
-
-package B::C;
-use Exporter ();
-our %REGEXP;
-
-{ # block necessary for caller to work
- my $caller = caller;
- if( $caller eq 'O' ) {
- require XSLoader;
- XSLoader::load( 'B::C' );
- }
-}
-
-@ISA = qw(Exporter);
-@EXPORT_OK = qw(output_all output_boilerplate output_main mark_unused
- init_sections set_callback save_unused_subs objsym save_context);
-
-use B qw(minus_c sv_undef walkoptree walksymtable main_root main_start peekop
- class cstring cchar svref_2object compile_stats comppadlist hash
- threadsv_names main_cv init_av end_av regex_padav opnumber amagic_generation
- HEf_SVKEY SVf_POK SVf_ROK CVf_CONST);
-use B::Asmdata qw(@specialsv_name);
-
-use FileHandle;
-use Carp;
-use strict;
-use Config;
-
-my $hv_index = 0;
-my $gv_index = 0;
-my $re_index = 0;
-my $pv_index = 0;
-my $cv_index = 0;
-my $anonsub_index = 0;
-my $initsub_index = 0;
-
-my %symtable;
-my %xsub;
-my $warn_undefined_syms;
-my $verbose;
-my %unused_sub_packages;
-my $use_xsloader;
-my $nullop_count;
-my $pv_copy_on_grow = 0;
-my $optimize_ppaddr = 0;
-my $optimize_warn_sv = 0;
-my $use_perl_script_name = 0;
-my $save_data_fh = 0;
-my $save_sig = 0;
-my ($debug_cops, $debug_av, $debug_cv, $debug_mg);
-my $max_string_len;
-
-my $ithreads = $Config{useithreads} eq 'define';
-
-my @threadsv_names;
-BEGIN {
- @threadsv_names = threadsv_names();
-}
-
-# Code sections
-my ($init, $decl, $symsect, $binopsect, $condopsect, $copsect,
- $padopsect, $listopsect, $logopsect, $loopsect, $opsect, $pmopsect,
- $pvopsect, $svopsect, $unopsect, $svsect, $xpvsect, $xpvavsect,
- $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect,
- $xrvsect, $xpvbmsect, $xpviosect );
-my @op_sections = \( $binopsect, $condopsect, $copsect, $padopsect, $listopsect,
- $logopsect, $loopsect, $opsect, $pmopsect, $pvopsect, $svopsect,
- $unopsect );
-
-sub walk_and_save_optree;
-my $saveoptree_callback = \&walk_and_save_optree;
-sub set_callback { $saveoptree_callback = shift }
-sub saveoptree { &$saveoptree_callback(@_) }
-
-sub walk_and_save_optree {
- my ($name, $root, $start) = @_;
- walkoptree($root, "save");
- return objsym($start);
-}
-
-# Look this up here so we can do just a number compare
-# rather than looking up the name of every BASEOP in B::OP
-my $OP_THREADSV = opnumber('threadsv');
-
-sub savesym {
- my ($obj, $value) = @_;
- my $sym = sprintf("s\\_%x", $$obj);
- $symtable{$sym} = $value;
-}
-
-sub objsym {
- my $obj = shift;
- return $symtable{sprintf("s\\_%x", $$obj)};
-}
-
-sub getsym {
- my $sym = shift;
- my $value;
-
- return 0 if $sym eq "sym_0"; # special case
- $value = $symtable{$sym};
- if (defined($value)) {
- return $value;
- } else {
- warn "warning: undefined symbol $sym\n" if $warn_undefined_syms;
- return "UNUSED";
- }
-}
-
-sub savere {
- my $re = shift;
- my $sym = sprintf("re%d", $re_index++);
- $decl->add(sprintf("static char *$sym = %s;", cstring($re)));
-
- return ($sym,length(pack "a*",$re));
-}
-
-sub savepv {
- my $pv = pack "a*", shift;
- my $pvsym = 0;
- my $pvmax = 0;
- if ($pv_copy_on_grow) {
- $pvsym = sprintf("pv%d", $pv_index++);
-
- if( defined $max_string_len && length($pv) > $max_string_len ) {
- my $chars = join ', ', map { cchar $_ } split //, $pv;
- $decl->add(sprintf("static char %s[] = { %s };", $pvsym, $chars));
- }
- else {
- my $cstring = cstring($pv);
- if ($cstring ne "0") { # sic
- $decl->add(sprintf("static char %s[] = %s;",
- $pvsym, $cstring));
- }
- }
- } else {
- $pvmax = length(pack "a*",$pv) + 1;
- }
- return ($pvsym, $pvmax);
-}
-
-sub save_rv {
- my $sv = shift;
-# confess "Can't save RV: not ROK" unless $sv->FLAGS & SVf_ROK;
- my $rv = $sv->RV->save;
-
- $rv =~ s/^\(([AGHS]V|IO)\s*\*\)\s*(\&sv_list.*)$/$2/;
-
- return $rv;
-}
-
-# savesym, pvmax, len, pv
-sub save_pv_or_rv {
- my $sv = shift;
-
- my $rok = $sv->FLAGS & SVf_ROK;
- my $pok = $sv->FLAGS & SVf_POK;
- my( $len, $pvmax, $savesym, $pv ) = ( 0, 0 );
- if( $rok ) {
- $savesym = '(char*)' . save_rv( $sv );
- }
- else {
- $pv = $pok ? (pack "a*", $sv->PV) : undef;
- $len = $pok ? length($pv) : 0;
- ($savesym, $pvmax) = $pok ? savepv($pv) : ( 'NULL', 0 );
- }
-
- return ( $savesym, $pvmax, $len, $pv );
-}
-
-# see also init_op_ppaddr below; initializes the ppaddt to the
-# OpTYPE; init_op_ppaddr iterates over the ops and sets
-# op_ppaddr to PL_ppaddr[op_ppaddr]; this avoids an explicit assignmente
-# in perl_init ( ~10 bytes/op with GCC/i386 )
-sub B::OP::fake_ppaddr {
- return $optimize_ppaddr ?
- sprintf("INT2PTR(void*,OP_%s)", uc( $_[0]->name ) ) :
- 'NULL';
-}
-
-# This pair is needed becase B::FAKEOP::save doesn't scalar dereference
-# $op->next and $op->sibling
-
-{
- # For 5.9 the hard coded text is the values for op_opt and op_static in each
- # op. The value of op_opt is irrelevant, and the value of op_static needs to
- # be 1 to tell op_free that this is a statically defined op and that is
- # shouldn't be freed.
-
- # For 5.8:
- # Current workaround/fix for op_free() trying to free statically
- # defined OPs is to set op_seq = -1 and check for that in op_free().
- # Instead of hardwiring -1 in place of $op->seq, we use $op_seq
- # so that it can be changed back easily if necessary. In fact, to
- # stop compilers from moaning about a U16 being initialised with an
- # uncast -1 (the printf format is %d so we can't tweak it), we have
- # to "know" that op_seq is a U16 and use 65535. Ugh.
-
- my $static = $] > 5.009 ? '0, 1, 0' : sprintf "%u", 65535;
- sub B::OP::_save_common_middle {
- my $op = shift;
- sprintf ("%s, %u, %u, $static, 0x%x, 0x%x",
- $op->fake_ppaddr, $op->targ, $op->type, $op->flags, $op->private);
- }
-}
-
-sub B::OP::_save_common {
- my $op = shift;
- return sprintf("s\\_%x, s\\_%x, %s",
- ${$op->next}, ${$op->sibling}, $op->_save_common_middle);
-}
-
-sub B::OP::save {
- my ($op, $level) = @_;
- my $sym = objsym($op);
- return $sym if defined $sym;
- my $type = $op->type;
- $nullop_count++ unless $type;
- if ($type == $OP_THREADSV) {
- # saves looking up ppaddr but it's a bit naughty to hard code this
- $init->add(sprintf("(void)find_threadsv(%s);",
- cstring($threadsv_names[$op->targ])));
- }
- $opsect->add($op->_save_common);
- my $ix = $opsect->index;
- $init->add(sprintf("op_list[$ix].op_ppaddr = %s;", $op->ppaddr))
- unless $optimize_ppaddr;
- savesym($op, "&op_list[$ix]");
-}
-
-sub B::FAKEOP::new {
- my ($class, %objdata) = @_;
- bless \%objdata, $class;
-}
-
-sub B::FAKEOP::save {
- my ($op, $level) = @_;
- $opsect->add(sprintf("%s, %s, %s",
- $op->next, $op->sibling, $op->_save_common_middle));
- my $ix = $opsect->index;
- $init->add(sprintf("op_list[$ix].op_ppaddr = %s;", $op->ppaddr))
- unless $optimize_ppaddr;
- return "&op_list[$ix]";
-}
-
-sub B::FAKEOP::next { $_[0]->{"next"} || 0 }
-sub B::FAKEOP::type { $_[0]->{type} || 0}
-sub B::FAKEOP::sibling { $_[0]->{sibling} || 0 }
-sub B::FAKEOP::ppaddr { $_[0]->{ppaddr} || 0 }
-sub B::FAKEOP::targ { $_[0]->{targ} || 0 }
-sub B::FAKEOP::flags { $_[0]->{flags} || 0 }
-sub B::FAKEOP::private { $_[0]->{private} || 0 }
-
-sub B::UNOP::save {
- my ($op, $level) = @_;
- my $sym = objsym($op);
- return $sym if defined $sym;
- $unopsect->add(sprintf("%s, s\\_%x", $op->_save_common, ${$op->first}));
- my $ix = $unopsect->index;
- $init->add(sprintf("unop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
- unless $optimize_ppaddr;
- savesym($op, "(OP*)&unop_list[$ix]");
-}
-
-sub B::BINOP::save {
- my ($op, $level) = @_;
- my $sym = objsym($op);
- return $sym if defined $sym;
- $binopsect->add(sprintf("%s, s\\_%x, s\\_%x",
- $op->_save_common, ${$op->first}, ${$op->last}));
- my $ix = $binopsect->index;
- $init->add(sprintf("binop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
- unless $optimize_ppaddr;
- savesym($op, "(OP*)&binop_list[$ix]");
-}
-
-sub B::LISTOP::save {
- my ($op, $level) = @_;
- my $sym = objsym($op);
- return $sym if defined $sym;
- $listopsect->add(sprintf("%s, s\\_%x, s\\_%x",
- $op->_save_common, ${$op->first}, ${$op->last}));
- my $ix = $listopsect->index;
- $init->add(sprintf("listop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
- unless $optimize_ppaddr;
- savesym($op, "(OP*)&listop_list[$ix]");
-}
-
-sub B::LOGOP::save {
- my ($op, $level) = @_;
- my $sym = objsym($op);
- return $sym if defined $sym;
- $logopsect->add(sprintf("%s, s\\_%x, s\\_%x",
- $op->_save_common, ${$op->first}, ${$op->other}));
- my $ix = $logopsect->index;
- $init->add(sprintf("logop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
- unless $optimize_ppaddr;
- savesym($op, "(OP*)&logop_list[$ix]");
-}
-
-sub B::LOOP::save {
- my ($op, $level) = @_;
- my $sym = objsym($op);
- return $sym if defined $sym;
- #warn sprintf("LOOP: redoop %s, nextop %s, lastop %s\n",
- # peekop($op->redoop), peekop($op->nextop),
- # peekop($op->lastop)); # debug
- $loopsect->add(sprintf("%s, s\\_%x, s\\_%x, s\\_%x, s\\_%x, s\\_%x",
- $op->_save_common, ${$op->first}, ${$op->last},
- ${$op->redoop}, ${$op->nextop},
- ${$op->lastop}));
- my $ix = $loopsect->index;
- $init->add(sprintf("loop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
- unless $optimize_ppaddr;
- savesym($op, "(OP*)&loop_list[$ix]");
-}
-
-sub B::PVOP::save {
- my ($op, $level) = @_;
- my $sym = objsym($op);
- return $sym if defined $sym;
- $pvopsect->add(sprintf("%s, %s", $op->_save_common, cstring($op->pv)));
- my $ix = $pvopsect->index;
- $init->add(sprintf("pvop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
- unless $optimize_ppaddr;
- savesym($op, "(OP*)&pvop_list[$ix]");
-}
-
-sub B::SVOP::save {
- my ($op, $level) = @_;
- my $sym = objsym($op);
- return $sym if defined $sym;
- my $sv = $op->sv;
- my $svsym = '(SV*)' . $sv->save;
- my $is_const_addr = $svsym =~ m/Null|\&/;
- $svopsect->add(sprintf("%s, %s", $op->_save_common,
- ( $is_const_addr ? $svsym : 'Nullsv' )));
- my $ix = $svopsect->index;
- $init->add(sprintf("svop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
- unless $optimize_ppaddr;
- $init->add("svop_list[$ix].op_sv = $svsym;")
- unless $is_const_addr;
- savesym($op, "(OP*)&svop_list[$ix]");
-}
-
-sub B::PADOP::save {
- my ($op, $level) = @_;
- my $sym = objsym($op);
- return $sym if defined $sym;
- $padopsect->add(sprintf("%s, %d",
- $op->_save_common, $op->padix));
- my $ix = $padopsect->index;
- $init->add(sprintf("padop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
- unless $optimize_ppaddr;
-# $init->add(sprintf("padop_list[$ix].op_padix = %ld;", $op->padix));
- savesym($op, "(OP*)&padop_list[$ix]");
-}
-
-sub B::COP::save {
- my ($op, $level) = @_;
- my $sym = objsym($op);
- return $sym if defined $sym;
- warn sprintf("COP: line %d file %s\n", $op->line, $op->file)
- if $debug_cops;
- # shameless cut'n'paste from B::Deparse
- my $warn_sv;
- my $warnings = $op->warnings;
- my $is_special = $warnings->isa("B::SPECIAL");
- if ($is_special && $$warnings == 4) {
- # use warnings 'all';
- $warn_sv = $optimize_warn_sv ?
- 'INT2PTR(SV*,1)' :
- 'pWARN_ALL';
- }
- elsif ($is_special && $$warnings == 5) {
- # no warnings 'all';
- $warn_sv = $optimize_warn_sv ?
- 'INT2PTR(SV*,2)' :
- 'pWARN_NONE';
- }
- elsif ($is_special) {
- # use warnings;
- $warn_sv = $optimize_warn_sv ?
- 'INT2PTR(SV*,3)' :
- 'pWARN_STD';
- }
- else {
- # something else
- $warn_sv = $warnings->save;
- }
-
- $copsect->add(sprintf("%s, %s, NULL, NULL, %u, %d, %u, %s",
- $op->_save_common, cstring($op->label), $op->cop_seq,
- $op->arybase, $op->line,
- ( $optimize_warn_sv ? $warn_sv : 'NULL' )));
- my $ix = $copsect->index;
- $init->add(sprintf("cop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
- unless $optimize_ppaddr;
- $init->add(sprintf("cop_list[$ix].cop_warnings = %s;", $warn_sv ))
- unless $optimize_warn_sv;
- $init->add(sprintf("CopFILE_set(&cop_list[$ix], %s);", cstring($op->file)),
- sprintf("CopSTASHPV_set(&cop_list[$ix], %s);", cstring($op->stashpv)));
-
- savesym($op, "(OP*)&cop_list[$ix]");
-}
-
-sub B::PMOP::save {
- my ($op, $level) = @_;
- my $sym = objsym($op);
- return $sym if defined $sym;
- my $replroot = $op->pmreplroot;
- my $replstart = $op->pmreplstart;
- my $replrootfield;
- my $replstartfield = sprintf("s\\_%x", $$replstart);
- my $gvsym;
- my $ppaddr = $op->ppaddr;
- # under ithreads, OP_PUSHRE.op_replroot is an integer
- $replrootfield = sprintf("s\\_%x", $$replroot) if ref $replroot;
- if($ithreads && $op->name eq "pushre") {
- $replrootfield = "INT2PTR(OP*,${replroot})";
- } elsif ($$replroot) {
- # OP_PUSHRE (a mutated version of OP_MATCH for the regexp
- # argument to a split) stores a GV in op_pmreplroot instead
- # of a substitution syntax tree. We don't want to walk that...
- if ($op->name eq "pushre") {
- $gvsym = $replroot->save;
-# warn "PMOP::save saving a pp_pushre with GV $gvsym\n"; # debug
- $replrootfield = 0;
- } else {
- $replstartfield = saveoptree("*ignore*", $replroot, $replstart);
- }
- }
- # pmnext handling is broken in perl itself, I think. Bad op_pmnext
- # fields aren't noticed in perl's runtime (unless you try reset) but we
- # segfault when trying to dereference it to find op->op_pmnext->op_type
- $pmopsect->add(sprintf("%s, s\\_%x, s\\_%x, %s, %s, 0, %u, 0x%x, 0x%x, 0x%x",
- $op->_save_common, ${$op->first}, ${$op->last},
- $replrootfield, $replstartfield,
- ( $ithreads ? $op->pmoffset : 0 ),
- $op->pmflags, $op->pmpermflags, $op->pmdynflags ));
- my $pm = sprintf("pmop_list[%d]", $pmopsect->index);
- $init->add(sprintf("$pm.op_ppaddr = %s;", $ppaddr))
- unless $optimize_ppaddr;
- my $re = $op->precomp;
- if (defined($re)) {
- my( $resym, $relen ) = savere( $re );
- $init->add(sprintf("PM_SETRE(&$pm,pregcomp($resym, $resym + %u, &$pm));",
- $relen));
- }
- if ($gvsym) {
- $init->add("$pm.op_pmreplroot = (OP*)$gvsym;");
- }
- savesym($op, "(OP*)&$pm");
-}
-
-sub B::SPECIAL::save {
- my ($sv) = @_;
- # special case: $$sv is not the address but an index into specialsv_list
-# warn "SPECIAL::save specialsv $$sv\n"; # debug
- my $sym = $specialsv_name[$$sv];
- if (!defined($sym)) {
- confess "unknown specialsv index $$sv passed to B::SPECIAL::save";
- }
- return $sym;
-}
-
-sub B::OBJECT::save {}
-
-sub B::NULL::save {
- my ($sv) = @_;
- my $sym = objsym($sv);
- return $sym if defined $sym;
-# warn "Saving SVt_NULL SV\n"; # debug
- # debug
- if ($$sv == 0) {
- warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n";
- return savesym($sv, "(void*)Nullsv /* XXX */");
- }
- $svsect->add(sprintf("0, %u, 0x%x", $sv->REFCNT , $sv->FLAGS));
- return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
-}
-
-sub B::IV::save {
- my ($sv) = @_;
- my $sym = objsym($sv);
- return $sym if defined $sym;
- $xpvivsect->add(sprintf("0, 0, 0, %d", $sv->IVX));
- $svsect->add(sprintf("&xpviv_list[%d], %lu, 0x%x",
- $xpvivsect->index, $sv->REFCNT , $sv->FLAGS));
- return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
-}
-
-sub B::NV::save {
- my ($sv) = @_;
- my $sym = objsym($sv);
- return $sym if defined $sym;
- my $val= $sv->NVX;
- $val .= '.00' if $val =~ /^-?\d+$/;
- $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $val));
- $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
- $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS));
- return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
-}
-
-sub savepvn {
- my ($dest,$pv) = @_;
- my @res;
- # work with byte offsets/lengths
- my $pv = pack "a*", $pv;
- if (defined $max_string_len && length($pv) > $max_string_len) {
- push @res, sprintf("Newx(%s,%u,char);", $dest, length($pv)+1);
- my $offset = 0;
- while (length $pv) {
- my $str = substr $pv, 0, $max_string_len, '';
- push @res, sprintf("Copy(%s,$dest+$offset,%u,char);",
- cstring($str), length($str));
- $offset += length $str;
- }
- push @res, sprintf("%s[%u] = '\\0';", $dest, $offset);
- }
- else {
- push @res, sprintf("%s = savepvn(%s, %u);", $dest,
- cstring($pv), length($pv));
- }
- return @res;
-}
-
-sub B::PVLV::save {
- my ($sv) = @_;
- my $sym = objsym($sv);
- return $sym if defined $sym;
- my $pv = $sv->PV;
- my $len = length($pv);
- my ($pvsym, $pvmax) = savepv($pv);
- my ($lvtarg, $lvtarg_sym);
- $xpvlvsect->add(sprintf("%s, %u, %u, %d, %g, 0, 0, %u, %u, 0, %s",
- $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX,
- $sv->TARGOFF, $sv->TARGLEN, cchar($sv->TYPE)));
- $svsect->add(sprintf("&xpvlv_list[%d], %lu, 0x%x",
- $xpvlvsect->index, $sv->REFCNT , $sv->FLAGS));
- if (!$pv_copy_on_grow) {
- $init->add(savepvn(sprintf("xpvlv_list[%d].xpv_pv",
- $xpvlvsect->index), $pv));
- }
- $sv->save_magic;
- return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
-}
-
-sub B::PVIV::save {
- my ($sv) = @_;
- my $sym = objsym($sv);
- return $sym if defined $sym;
- my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv );
- $xpvivsect->add(sprintf("%s, %u, %u, %d", $savesym, $len, $pvmax, $sv->IVX));
- $svsect->add(sprintf("&xpviv_list[%d], %u, 0x%x",
- $xpvivsect->index, $sv->REFCNT , $sv->FLAGS));
- if (defined($pv) && !$pv_copy_on_grow) {
- $init->add(savepvn(sprintf("xpviv_list[%d].xpv_pv",
- $xpvivsect->index), $pv));
- }
- return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
-}
-
-sub B::PVNV::save {
- my ($sv) = @_;
- my $sym = objsym($sv);
- return $sym if defined $sym;
- my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv );
- my $val= $sv->NVX;
- $val .= '.00' if $val =~ /^-?\d+$/;
- $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s",
- $savesym, $len, $pvmax, $sv->IVX, $val));
- $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
- $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS));
- if (defined($pv) && !$pv_copy_on_grow) {
- $init->add(savepvn(sprintf("xpvnv_list[%d].xpv_pv",
- $xpvnvsect->index), $pv));
- }
- return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
-}
-
-sub B::BM::save {
- my ($sv) = @_;
- my $sym = objsym($sv);
- return $sym if defined $sym;
- my $pv = pack "a*", ($sv->PV . "\0" . $sv->TABLE);
- my $len = length($pv);
- $xpvbmsect->add(sprintf("0, %u, %u, %d, %s, 0, 0, %d, %u, 0x%x",
- $len, $len + 258, $sv->IVX, $sv->NVX,
- $sv->USEFUL, $sv->PREVIOUS, $sv->RARE));
- $svsect->add(sprintf("&xpvbm_list[%d], %lu, 0x%x",
- $xpvbmsect->index, $sv->REFCNT , $sv->FLAGS));
- $sv->save_magic;
- $init->add(savepvn(sprintf("xpvbm_list[%d].xpv_pv",
- $xpvbmsect->index), $pv),
- sprintf("xpvbm_list[%d].xpv_cur = %u;",
- $xpvbmsect->index, $len - 257));
- return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
-}
-
-sub B::PV::save {
- my ($sv) = @_;
- my $sym = objsym($sv);
- return $sym if defined $sym;
- my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv );
- $xpvsect->add(sprintf("%s, %u, %u", $savesym, $len, $pvmax));
- $svsect->add(sprintf("&xpv_list[%d], %lu, 0x%x",
- $xpvsect->index, $sv->REFCNT , $sv->FLAGS));
- if (defined($pv) && !$pv_copy_on_grow) {
- $init->add(savepvn(sprintf("xpv_list[%d].xpv_pv",
- $xpvsect->index), $pv));
- }
- return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
-}
-
-sub B::PVMG::save {
- my ($sv) = @_;
- my $sym = objsym($sv);
- return $sym if defined $sym;
- my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv );
-
- $xpvmgsect->add(sprintf("%s, %u, %u, %d, %s, 0, 0",
- $savesym, $len, $pvmax,
- $sv->IVX, $sv->NVX));
- $svsect->add(sprintf("&xpvmg_list[%d], %lu, 0x%x",
- $xpvmgsect->index, $sv->REFCNT , $sv->FLAGS));
- if (defined($pv) && !$pv_copy_on_grow) {
- $init->add(savepvn(sprintf("xpvmg_list[%d].xpv_pv",
- $xpvmgsect->index), $pv));
- }
- $sym = savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
- $sv->save_magic;
- return $sym;
-}
-
-sub B::PVMG::save_magic {
- my ($sv) = @_;
- #warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv); # debug
- my $stash = $sv->SvSTASH;
- $stash->save;
- if ($$stash) {
- warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, $$stash)
- if $debug_mg;
- # XXX Hope stash is already going to be saved.
- $init->add(sprintf("SvSTASH(s\\_%x) = s\\_%x;", $$sv, $$stash));
- }
- my @mgchain = $sv->MAGIC;
- my ($mg, $type, $obj, $ptr,$len,$ptrsv);
- foreach $mg (@mgchain) {
- $type = $mg->TYPE;
- $ptr = $mg->PTR;
- $len=$mg->LENGTH;
- if ($debug_mg) {
- warn sprintf("magic %s (0x%x), obj %s (0x%x), type %s, ptr %s\n",
- class($sv), $$sv, class($obj), $$obj,
- cchar($type), cstring($ptr));
- }
-
- unless( $type eq 'r' ) {
- $obj = $mg->OBJ;
- $obj->save;
- }
-
- if ($len == HEf_SVKEY){
- #The pointer is an SV*
- $ptrsv=svref_2object($ptr)->save;
- $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s,(char *) %s, %d);",
- $$sv, $$obj, cchar($type),$ptrsv,$len));
- }elsif( $type eq 'r' ){
- my $rx = $mg->REGEX;
- my $pmop = $REGEXP{$rx};
-
- confess "PMOP not found for REGEXP $rx" unless $pmop;
-
- my( $resym, $relen ) = savere( $mg->precomp );
- my $pmsym = $pmop->save;
- $init->add( split /\n/, sprintf <<CODE, $$sv, cchar($type), cstring($ptr) );
-{
- REGEXP* rx = pregcomp($resym, $resym + $relen, (PMOP*)$pmsym);
- sv_magic((SV*)s\\_%x, (SV*)rx, %s, %s, %d);
-}
-CODE
- }else{
- $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);",
- $$sv, $$obj, cchar($type),cstring($ptr),$len));
- }
- }
-}
-
-sub B::RV::save {
- my ($sv) = @_;
- my $sym = objsym($sv);
- return $sym if defined $sym;
- my $rv = save_rv( $sv );
- # GVs need to be handled at runtime
- if( ref( $sv->RV ) eq 'B::GV' ) {
- $xrvsect->add( "(SV*)Nullgv" );
- $init->add(sprintf("xrv_list[%d].xrv_rv = (SV*)%s;\n", $xrvsect->index, $rv));
- }
- # and stashes, too
- elsif( $sv->RV->isa( 'B::HV' ) && $sv->RV->NAME ) {
- $xrvsect->add( "(SV*)Nullhv" );
- $init->add(sprintf("xrv_list[%d].xrv_rv = (SV*)%s;\n", $xrvsect->index, $rv));
- }
- else {
- $xrvsect->add($rv);
- }
- $svsect->add(sprintf("&xrv_list[%d], %lu, 0x%x",
- $xrvsect->index, $sv->REFCNT , $sv->FLAGS));
- return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
-}
-
-sub try_autoload {
- my ($cvstashname, $cvname) = @_;
- warn sprintf("No definition for sub %s::%s\n", $cvstashname, $cvname);
- # Handle AutoLoader classes explicitly. Any more general AUTOLOAD
- # use should be handled by the class itself.
- no strict 'refs';
- my $isa = \@{"$cvstashname\::ISA"};
- if (grep($_ eq "AutoLoader", @$isa)) {
- warn "Forcing immediate load of sub derived from AutoLoader\n";
- # Tweaked version of AutoLoader::AUTOLOAD
- my $dir = $cvstashname;
- $dir =~ s(::)(/)g;
- eval { require "auto/$dir/$cvname.al" };
- if ($@) {
- warn qq(failed require "auto/$dir/$cvname.al": $@\n);
- return 0;
- } else {
- return 1;
- }
- }
-}
-sub Dummy_initxs{};
-sub B::CV::save {
- my ($cv) = @_;
- my $sym = objsym($cv);
- if (defined($sym)) {
-# warn sprintf("CV 0x%x already saved as $sym\n", $$cv); # debug
- return $sym;
- }
- # Reserve a place in svsect and xpvcvsect and record indices
- my $gv = $cv->GV;
- my ($cvname, $cvstashname);
- if ($$gv){
- $cvname = $gv->NAME;
- $cvstashname = $gv->STASH->NAME;
- }
- my $root = $cv->ROOT;
- my $cvxsub = $cv->XSUB;
- my $isconst = $cv->CvFLAGS & CVf_CONST;
- if( $isconst ) {
- my $value = $cv->XSUBANY;
- my $stash = $gv->STASH;
- my $vsym = $value->save;
- my $stsym = $stash->save;
- my $name = cstring($cvname);
- $decl->add( "static CV* cv$cv_index;" );
- $init->add( "cv$cv_index = newCONSTSUB( $stsym, NULL, $vsym );" );
- my $sym = savesym( $cv, "cv$cv_index" );
- $cv_index++;
- return $sym;
- }
- #INIT is removed from the symbol table, so this call must come
- # from PL_initav->save. Re-bootstrapping will push INIT back in
- # so nullop should be sent.
- if (!$isconst && $cvxsub && ($cvname ne "INIT")) {
- my $egv = $gv->EGV;
- my $stashname = $egv->STASH->NAME;
- if ($cvname eq "bootstrap")
- {
- my $file = $gv->FILE;
- $decl->add("/* bootstrap $file */");
- warn "Bootstrap $stashname $file\n";
- # if it not isa('DynaLoader'), it should hopefully be XSLoaded
- # ( attributes being an exception, of course )
- if( $stashname ne 'attributes' &&
- !UNIVERSAL::isa($stashname,'DynaLoader') ) {
- $xsub{$stashname}='Dynamic-XSLoaded';
- $use_xsloader = 1;
- }
- else {
- $xsub{$stashname}='Dynamic';
- }
- # $xsub{$stashname}='Static' unless $xsub{$stashname};
- return qq/NULL/;
- }
- else
- {
- # XSUBs for IO::File, IO::Handle, IO::Socket,
- # IO::Seekable and IO::Poll
- # are defined in IO.xs, so let's bootstrap it
- svref_2object( \&IO::bootstrap )->save
- if grep { $stashname eq $_ } qw(IO::File IO::Handle IO::Socket
- IO::Seekable IO::Poll);
- }
- warn sprintf("stub for XSUB $cvstashname\:\:$cvname CV 0x%x\n", $$cv) if $debug_cv;
- return qq/(perl_get_cv("$stashname\:\:$cvname",TRUE))/;
- }
- if ($cvxsub && $cvname eq "INIT") {
- no strict 'refs';
- return svref_2object(\&Dummy_initxs)->save;
- }
- my $sv_ix = $svsect->index + 1;
- $svsect->add("svix$sv_ix");
- my $xpvcv_ix = $xpvcvsect->index + 1;
- $xpvcvsect->add("xpvcvix$xpvcv_ix");
- # Save symbol now so that GvCV() doesn't recurse back to us via CvGV()
- $sym = savesym($cv, "&sv_list[$sv_ix]");
- warn sprintf("saving $cvstashname\:\:$cvname CV 0x%x as $sym\n", $$cv) if $debug_cv;
- if (!$$root && !$cvxsub) {
- if (try_autoload($cvstashname, $cvname)) {
- # Recalculate root and xsub
- $root = $cv->ROOT;
- $cvxsub = $cv->XSUB;
- if ($$root || $cvxsub) {
- warn "Successful forced autoload\n";
- }
- }
- }
- my $startfield = 0;
- my $padlist = $cv->PADLIST;
- my $pv = $cv->PV;
- my $xsub = 0;
- my $xsubany = "Nullany";
- if ($$root) {
- warn sprintf("saving op tree for CV 0x%x, root = 0x%x\n",
- $$cv, $$root) if $debug_cv;
- my $ppname = "";
- if ($$gv) {
- my $stashname = $gv->STASH->NAME;
- my $gvname = $gv->NAME;
- if ($gvname ne "__ANON__") {
- $ppname = (${$gv->FORM} == $$cv) ? "pp_form_" : "pp_sub_";
- $ppname .= ($stashname eq "main") ?
- $gvname : "$stashname\::$gvname";
- $ppname =~ s/::/__/g;
- if ($gvname eq "INIT"){
- $ppname .= "_$initsub_index";
- $initsub_index++;
- }
- }
- }
- if (!$ppname) {
- $ppname = "pp_anonsub_$anonsub_index";
- $anonsub_index++;
- }
- $startfield = saveoptree($ppname, $root, $cv->START, $padlist->ARRAY);
- warn sprintf("done saving op tree for CV 0x%x, name %s, root 0x%x\n",
- $$cv, $ppname, $$root) if $debug_cv;
- if ($$padlist) {
- warn sprintf("saving PADLIST 0x%x for CV 0x%x\n",
- $$padlist, $$cv) if $debug_cv;
- $padlist->save;
- warn sprintf("done saving PADLIST 0x%x for CV 0x%x\n",
- $$padlist, $$cv) if $debug_cv;
- }
- }
- else {
- warn sprintf("No definition for sub %s::%s (unable to autoload)\n",
- $cvstashname, $cvname); # debug
- }
- $pv = '' unless defined $pv; # Avoid use of undef warnings
- $symsect->add(sprintf("xpvcvix%d\t%s, %u, 0, %d, %s, 0, Nullhv, Nullhv, %s, s\\_%x, $xsub, $xsubany, Nullgv, \"\", %d, s\\_%x, (CV*)s\\_%x, 0x%x, 0x%x",
- $xpvcv_ix, cstring($pv), length($pv), $cv->IVX,
- $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH,
- $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS,
- $cv->OUTSIDE_SEQ));
-
- if (${$cv->OUTSIDE} == ${main_cv()}){
- $init->add(sprintf("CvOUTSIDE(s\\_%x)=PL_main_cv;",$$cv));
- $init->add(sprintf("SvREFCNT_inc(PL_main_cv);"));
- }
-
- if ($$gv) {
- $gv->save;
- $init->add(sprintf("CvGV(s\\_%x) = s\\_%x;",$$cv,$$gv));
- warn sprintf("done saving GV 0x%x for CV 0x%x\n",
- $$gv, $$cv) if $debug_cv;
- }
- if( $ithreads ) {
- $init->add( savepvn( "CvFILE($sym)", $cv->FILE) );
- }
- else {
- $init->add(sprintf("CvFILE($sym) = %s;", cstring($cv->FILE)));
- }
- my $stash = $cv->STASH;
- if ($$stash) {
- $stash->save;
- $init->add(sprintf("CvSTASH(s\\_%x) = s\\_%x;", $$cv, $$stash));
- warn sprintf("done saving STASH 0x%x for CV 0x%x\n",
- $$stash, $$cv) if $debug_cv;
- }
- $symsect->add(sprintf("svix%d\t(XPVCV*)&xpvcv_list[%u], %lu, 0x%x",
- $sv_ix, $xpvcv_ix, $cv->REFCNT +1*0 , $cv->FLAGS));
- return $sym;
-}
-
-sub B::GV::save {
- my ($gv) = @_;
- my $sym = objsym($gv);
- if (defined($sym)) {
- #warn sprintf("GV 0x%x already saved as $sym\n", $$gv); # debug
- return $sym;
- } else {
- my $ix = $gv_index++;
- $sym = savesym($gv, "gv_list[$ix]");
- #warn sprintf("Saving GV 0x%x as $sym\n", $$gv); # debug
- }
- my $is_empty = $gv->is_empty;
- my $gvname = $gv->NAME;
- my $fullname = $gv->STASH->NAME . "::" . $gvname;
- my $name = cstring($fullname);
- #warn "GV name is $name\n"; # debug
- my $egvsym;
- unless ($is_empty) {
- my $egv = $gv->EGV;
- if ($$gv != $$egv) {
- #warn(sprintf("EGV name is %s, saving it now\n",
- # $egv->STASH->NAME . "::" . $egv->NAME)); # debug
- $egvsym = $egv->save;
- }
- }
- $init->add(qq[$sym = gv_fetchpv($name, TRUE, SVt_PV);],
- sprintf("SvFLAGS($sym) = 0x%x;", $gv->FLAGS ),
- sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS));
- $init->add(sprintf("GvLINE($sym) = %u;", $gv->LINE)) unless $is_empty;
- # XXX hack for when Perl accesses PVX of GVs
- $init->add("SvPVX($sym) = emptystring;\n");
- # Shouldn't need to do save_magic since gv_fetchpv handles that
- #$gv->save_magic;
- # XXX will always be > 1!!!
- my $refcnt = $gv->REFCNT + 1;
- $init->add(sprintf("SvREFCNT($sym) += %u;", $refcnt - 1 )) if $refcnt > 1;
-
- return $sym if $is_empty;
-
- # XXX B::walksymtable creates an extra reference to the GV
- my $gvrefcnt = $gv->GvREFCNT;
- if ($gvrefcnt > 1) {
- $init->add(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1));
- }
- # some non-alphavetic globs require some parts to be saved
- # ( ex. %!, but not $! )
- sub Save_HV() { 1 }
- sub Save_AV() { 2 }
- sub Save_SV() { 4 }
- sub Save_CV() { 8 }
- sub Save_FORM() { 16 }
- sub Save_IO() { 32 }
- my $savefields = 0;
- if( $gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/ ) {
- $savefields = Save_HV|Save_AV|Save_SV|Save_CV|Save_FORM|Save_IO;
- }
- elsif( $gvname eq '!' ) {
- $savefields = Save_HV;
- }
- # attributes::bootstrap is created in perl_parse
- # saving it would overwrite it, because perl_init() is
- # called after perl_parse()
- $savefields&=~Save_CV if $fullname eq 'attributes::bootstrap';
-
- # save it
- # XXX is that correct?
- if (defined($egvsym) && $egvsym !~ m/Null/ ) {
- # Shared glob *foo = *bar
- $init->add("gp_free($sym);",
- "GvGP($sym) = GvGP($egvsym);");
- } elsif ($savefields) {
- # Don't save subfields of special GVs (*_, *1, *# and so on)
-# warn "GV::save saving subfields\n"; # debug
- my $gvsv = $gv->SV;
- if ($$gvsv && $savefields&Save_SV) {
- $gvsv->save;
- $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv));
-# warn "GV::save \$$name\n"; # debug
- }
- my $gvav = $gv->AV;
- if ($$gvav && $savefields&Save_AV) {
- $gvav->save;
- $init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav));
-# warn "GV::save \@$name\n"; # debug
- }
- my $gvhv = $gv->HV;
- if ($$gvhv && $savefields&Save_HV) {
- $gvhv->save;
- $init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv));
-# warn "GV::save \%$name\n"; # debug
- }
- my $gvcv = $gv->CV;
- if ($$gvcv && $savefields&Save_CV) {
- my $origname=cstring($gvcv->GV->EGV->STASH->NAME .
- "::" . $gvcv->GV->EGV->NAME);
- if (0 && $gvcv->XSUB && $name ne $origname) { #XSUB alias
- # must save as a 'stub' so newXS() has a CV to populate
- $init->add("{ CV *cv;");
- $init->add("\tcv=perl_get_cv($origname,TRUE);");
- $init->add("\tGvCV($sym)=cv;");
- $init->add("\tSvREFCNT_inc((SV *)cv);");
- $init->add("}");
- } else {
- $init->add(sprintf("GvCV($sym) = (CV*)(%s);", $gvcv->save));
-# warn "GV::save &$name\n"; # debug
- }
- }
- $init->add(sprintf("GvFILE($sym) = %s;", cstring($gv->FILE)));
-# warn "GV::save GvFILE(*$name)\n"; # debug
- my $gvform = $gv->FORM;
- if ($$gvform && $savefields&Save_FORM) {
- $gvform->save;
- $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform));
-# warn "GV::save GvFORM(*$name)\n"; # debug
- }
- my $gvio = $gv->IO;
- if ($$gvio && $savefields&Save_IO) {
- $gvio->save;
- $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio));
- if( $fullname =~ m/::DATA$/ && $save_data_fh ) {
- no strict 'refs';
- my $fh = *{$fullname}{IO};
- use strict 'refs';
- $gvio->save_data( $fullname, <$fh> ) if $fh->opened;
- }
-# warn "GV::save GvIO(*$name)\n"; # debug
- }
- }
- return $sym;
-}
-
-sub B::AV::save {
- my ($av) = @_;
- my $sym = objsym($av);
- return $sym if defined $sym;
- my $line = "0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0";
- $line .= sprintf(", 0x%x", $av->AvFLAGS) if $] < 5.009;
- $xpvavsect->add($line);
- $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x",
- $xpvavsect->index, $av->REFCNT , $av->FLAGS));
- my $sv_list_index = $svsect->index;
- my $fill = $av->FILL;
- $av->save_magic;
- if ($debug_av) {
- $line = sprintf("saving AV 0x%x FILL=$fill", $$av);
- $line .= sprintf(" AvFLAGS=0x%x", $av->AvFLAGS) if $] < 5.009;
- warn $line;
- }
- # XXX AVf_REAL is wrong test: need to save comppadlist but not stack
- #if ($fill > -1 && ($avflags & AVf_REAL)) {
- if ($fill > -1) {
- my @array = $av->ARRAY;
- if ($debug_av) {
- my $el;
- my $i = 0;
- foreach $el (@array) {
- warn sprintf("AV 0x%x[%d] = %s 0x%x\n",
- $$av, $i++, class($el), $$el);
- }
- }
-# my @names = map($_->save, @array);
- # XXX Better ways to write loop?
- # Perhaps svp[0] = ...; svp[1] = ...; svp[2] = ...;
- # Perhaps I32 i = 0; svp[i++] = ...; svp[i++] = ...; svp[i++] = ...;
-
- # micro optimization: op/pat.t ( and other code probably )
- # has very large pads ( 20k/30k elements ) passing them to
- # ->add is a performance bottleneck: passing them as a
- # single string cuts runtime from 6min20sec to 40sec
-
- # you want to keep this out of the no_split/split
- # map("\t*svp++ = (SV*)$_;", @names),
- my $acc = '';
- foreach my $i ( 0..$#array ) {
- $acc .= "\t*svp++ = (SV*)" . $array[$i]->save . ";\n\t";
- }
- $acc .= "\n";
-
- $init->no_split;
- $init->add("{",
- "\tSV **svp;",
- "\tAV *av = (AV*)&sv_list[$sv_list_index];",
- "\tav_extend(av, $fill);",
- "\tsvp = AvARRAY(av);" );
- $init->add($acc);
- $init->add("\tAvFILLp(av) = $fill;",
- "}");
- $init->split;
- # we really added a lot of lines ( B::C::InitSection->add
- # should really scan for \n, but that would slow
- # it down
- $init->inc_count( $#array );
- } else {
- my $max = $av->MAX;
- $init->add("av_extend((AV*)&sv_list[$sv_list_index], $max);")
- if $max > -1;
- }
- return savesym($av, "(AV*)&sv_list[$sv_list_index]");
-}
-
-sub B::HV::save {
- my ($hv) = @_;
- my $sym = objsym($hv);
- return $sym if defined $sym;
- my $name = $hv->NAME;
- if ($name) {
- # It's a stash
-
- # A perl bug means HvPMROOT isn't altered when a PMOP is freed. Usually
- # the only symptom is that sv_reset tries to reset the PMf_USED flag of
- # a trashed op but we look at the trashed op_type and segfault.
- #my $adpmroot = ${$hv->PMROOT};
- my $adpmroot = 0;
- $decl->add("static HV *hv$hv_index;");
- # XXX Beware of weird package names containing double-quotes, \n, ...?
- $init->add(qq[hv$hv_index = gv_stashpv("$name", TRUE);]);
- if ($adpmroot) {
- $init->add(sprintf("HvPMROOT(hv$hv_index) = (PMOP*)s\\_%x;",
- $adpmroot));
- }
- $sym = savesym($hv, "hv$hv_index");
- $hv_index++;
- return $sym;
- }
- # It's just an ordinary HV
- $xpvhvsect->add(sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0",
- $hv->MAX, $hv->RITER));
- $svsect->add(sprintf("&xpvhv_list[%d], %lu, 0x%x",
- $xpvhvsect->index, $hv->REFCNT , $hv->FLAGS));
- my $sv_list_index = $svsect->index;
- my @contents = $hv->ARRAY;
- if (@contents) {
- my $i;
- for ($i = 1; $i < @contents; $i += 2) {
- $contents[$i] = $contents[$i]->save;
- }
- $init->no_split;
- $init->add("{", "\tHV *hv = (HV*)&sv_list[$sv_list_index];");
- while (@contents) {
- my ($key, $value) = splice(@contents, 0, 2);
- $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
- cstring($key),length(pack "a*",$key),
- $value, hash($key)));
-# $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
-# cstring($key),length($key),$value, 0));
- }
- $init->add("}");
- $init->split;
- }
- $hv->save_magic();
- return savesym($hv, "(HV*)&sv_list[$sv_list_index]");
-}
-
-sub B::IO::save_data {
- my( $io, $globname, @data ) = @_;
- my $data = join '', @data;
-
- # XXX using $DATA might clobber it!
- my $sym = svref_2object( \\$data )->save;
- $init->add( split /\n/, <<CODE );
- {
- GV* gv = (GV*)gv_fetchpv( "$globname", TRUE, SVt_PV );
- SV* sv = $sym;
- GvSV( gv ) = sv;
- }
-CODE
- # for PerlIO::scalar
- $use_xsloader = 1;
- $init->add_eval( sprintf 'open(%s, "<", $%s)', $globname, $globname );
-}
-
-sub B::IO::save {
- my ($io) = @_;
- my $sym = objsym($io);
- return $sym if defined $sym;
- my $pv = $io->PV;
- $pv = '' unless defined $pv;
- my $len = length($pv);
- $xpviosect->add(sprintf("0, %u, %u, %d, %s, 0, 0, 0, 0, 0, %d, %d, %d, %d, %s, Nullgv, %s, Nullgv, %s, Nullgv, %d, %s, 0x%x",
- $len, $len+1, $io->IVX, $io->NVX, $io->LINES,
- $io->PAGE, $io->PAGE_LEN, $io->LINES_LEFT,
- cstring($io->TOP_NAME), cstring($io->FMT_NAME),
- cstring($io->BOTTOM_NAME), $io->SUBPROCESS,
- cchar($io->IoTYPE), $io->IoFLAGS));
- $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x",
- $xpviosect->index, $io->REFCNT , $io->FLAGS));
- $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index));
- # deal with $x = *STDIN/STDOUT/STDERR{IO}
- my $perlio_func;
- foreach ( qw(stdin stdout stderr) ) {
- $io->IsSTD($_) and $perlio_func = $_;
- }
- if( $perlio_func ) {
- $init->add( "IoIFP(${sym})=PerlIO_${perlio_func}();" );
- $init->add( "IoOFP(${sym})=PerlIO_${perlio_func}();" );
- }
-
- my ($field, $fsym);
- foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) {
- $fsym = $io->$field();
- if ($$fsym) {
- $init->add(sprintf("Io$field($sym) = (GV*)s\\_%x;", $$fsym));
- $fsym->save;
- }
- }
- $io->save_magic;
- return $sym;
-}
-
-sub B::SV::save {
- my $sv = shift;
- # This is where we catch an honest-to-goodness Nullsv (which gets
- # blessed into B::SV explicitly) and any stray erroneous SVs.
- return 0 unless $$sv;
- confess sprintf("cannot save that type of SV: %s (0x%x)\n",
- class($sv), $$sv);
-}
-
-sub output_all {
- my $init_name = shift;
- my $section;
- my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect,
- $listopsect, $pmopsect, $svopsect, $padopsect, $pvopsect,
- $loopsect, $copsect, $svsect, $xpvsect,
- $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect,
- $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect);
- $symsect->output(\*STDOUT, "#define %s\n");
- print "\n";
- output_declarations();
- foreach $section (@sections) {
- my $lines = $section->index + 1;
- if ($lines) {
- my $name = $section->name;
- my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
- print "Static $typename ${name}_list[$lines];\n";
- }
- }
- # XXX hack for when Perl accesses PVX of GVs
- print 'Static char emptystring[] = "\0";';
-
- $decl->output(\*STDOUT, "%s\n");
- print "\n";
- foreach $section (@sections) {
- my $lines = $section->index + 1;
- if ($lines) {
- my $name = $section->name;
- my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
- printf "static %s %s_list[%u] = {\n", $typename, $name, $lines;
- $section->output(\*STDOUT, "\t{ %s }, /* %d */\n");
- print "};\n\n";
- }
- }
-
- $init->output(\*STDOUT, "\t%s\n", $init_name );
- if ($verbose) {
- warn compile_stats();
- warn "NULLOP count: $nullop_count\n";
- }
-}
-
-sub output_declarations {
- print <<'EOT';
-#ifdef BROKEN_STATIC_REDECL
-#define Static extern
-#else
-#define Static static
-#endif /* BROKEN_STATIC_REDECL */
-
-#ifdef BROKEN_UNION_INIT
-#error BROKEN_UNION_INIT no longer needed, as Perl requires an ANSI compiler
-#endif
-
-#define XPVCV_or_similar XPVCV
-#define ANYINIT(i) {i}
-#define Nullany ANYINIT(0)
-
-#define UNUSED 0
-#define sym_0 0
-EOT
- print "static GV *gv_list[$gv_index];\n" if $gv_index;
- print "\n";
-}
-
-
-sub output_boilerplate {
- print <<'EOT';
-#include "EXTERN.h"
-#include "perl.h"
-#include "XSUB.h"
-
-/* Workaround for mapstart: the only op which needs a different ppaddr */
-#undef Perl_pp_mapstart
-#define Perl_pp_mapstart Perl_pp_grepstart
-#undef OP_MAPSTART
-#define OP_MAPSTART OP_GREPSTART
-#define XS_DynaLoader_boot_DynaLoader boot_DynaLoader
-EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
-
-static void xs_init (pTHX);
-static void dl_init (pTHX);
-static PerlInterpreter *my_perl;
-EOT
-}
-
-sub init_op_addr {
- my( $op_type, $num ) = @_;
- my $op_list = $op_type."_list";
-
- $init->add( split /\n/, <<EOT );
- {
- int i;
-
- for( i = 0; i < ${num}; ++i )
- {
- ${op_list}\[i].op_ppaddr = PL_ppaddr[INT2PTR(int,${op_list}\[i].op_ppaddr)];
- }
- }
-EOT
-}
-
-sub init_op_warn {
- my( $op_type, $num ) = @_;
- my $op_list = $op_type."_list";
-
- # for resons beyond imagination, MSVC5 considers pWARN_ALL non-const
- $init->add( split /\n/, <<EOT );
- {
- int i;
-
- for( i = 0; i < ${num}; ++i )
- {
- switch( (int)(${op_list}\[i].cop_warnings) )
- {
- case 1:
- ${op_list}\[i].cop_warnings = pWARN_ALL;
- break;
- case 2:
- ${op_list}\[i].cop_warnings = pWARN_NONE;
- break;
- case 3:
- ${op_list}\[i].cop_warnings = pWARN_STD;
- break;
- default:
- break;
- }
- }
- }
-EOT
-}
-
-sub output_main {
- print <<'EOT';
-/* if USE_IMPLICIT_SYS, we need a 'real' exit */
-#if defined(exit)
-#undef exit
-#endif
-
-int
-main(int argc, char **argv, char **env)
-{
- int exitstatus;
- int i;
- char **fakeargv;
- GV* tmpgv;
- SV* tmpsv;
- int options_count;
-
- PERL_SYS_INIT3(&argc,&argv,&env);
-
- if (!PL_do_undump) {
- my_perl = perl_alloc();
- if (!my_perl)
- exit(1);
- perl_construct( my_perl );
- PL_perl_destruct_level = 0;
- }
-EOT
- if( $ithreads ) {
- # XXX init free elems!
- my $pad_len = regex_padav->FILL + 1 - 1; # first is an avref
-
- print <<EOT;
-#ifdef USE_ITHREADS
- for( i = 0; i < $pad_len; ++i ) {
- av_push( PL_regex_padav, newSViv(0) );
- }
- PL_regex_pad = AvARRAY( PL_regex_padav );
-#endif
-EOT
- }
-
- print <<'EOT';
-#ifdef CSH
- if (!PL_cshlen)
- PL_cshlen = strlen(PL_cshname);
-#endif
-
-#ifdef ALLOW_PERL_OPTIONS
-#define EXTRA_OPTIONS 3
-#else
-#define EXTRA_OPTIONS 4
-#endif /* ALLOW_PERL_OPTIONS */
- Newx(fakeargv, argc + EXTRA_OPTIONS + 1, char *);
-
- fakeargv[0] = argv[0];
- fakeargv[1] = "-e";
- fakeargv[2] = "";
- options_count = 3;
-EOT
- # honour -T
- print <<EOT;
- if( ${^TAINT} ) {
- fakeargv[options_count] = "-T";
- ++options_count;
- }
-EOT
- print <<'EOT';
-#ifndef ALLOW_PERL_OPTIONS
- fakeargv[options_count] = "--";
- ++options_count;
-#endif /* ALLOW_PERL_OPTIONS */
- for (i = 1; i < argc; i++)
- fakeargv[i + options_count - 1] = argv[i];
- fakeargv[argc + options_count - 1] = 0;
-
- exitstatus = perl_parse(my_perl, xs_init, argc + options_count - 1,
- fakeargv, NULL);
-
- if (exitstatus)
- exit( exitstatus );
-
- TAINT;
-EOT
-
- if( $use_perl_script_name ) {
- my $dollar_0 = $0;
- $dollar_0 =~ s/\\/\\\\/g;
- $dollar_0 = '"' . $dollar_0 . '"';
-
- print <<EOT;
- if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {/* $0 */
- tmpsv = GvSV(tmpgv);
- sv_setpv(tmpsv, ${dollar_0});
- SvSETMAGIC(tmpsv);
- }
-EOT
- }
- else {
- print <<EOT;
- if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {/* $0 */
- tmpsv = GvSV(tmpgv);
- sv_setpv(tmpsv, argv[0]);
- SvSETMAGIC(tmpsv);
- }
-EOT
- }
-
- print <<'EOT';
- if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
- tmpsv = GvSV(tmpgv);
-#ifdef WIN32
- sv_setpv(tmpsv,"perl.exe");
-#else
- sv_setpv(tmpsv,"perl");
-#endif
- SvSETMAGIC(tmpsv);
- }
-
- TAINT_NOT;
-
- /* PL_main_cv = PL_compcv; */
- PL_compcv = 0;
-
- exitstatus = perl_init();
- if (exitstatus)
- exit( exitstatus );
- dl_init(aTHX);
-
- exitstatus = perl_run( my_perl );
-
- perl_destruct( my_perl );
- perl_free( my_perl );
-
- PERL_SYS_TERM();
-
- exit( exitstatus );
-}
-
-/* yanked from perl.c */
-static void
-xs_init(pTHX)
-{
- char *file = __FILE__;
- dTARG;
- dSP;
-EOT
- print "\n#ifdef USE_DYNAMIC_LOADING";
- print qq/\n\tnewXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);/;
- print "\n#endif\n" ;
- # delete $xsub{'DynaLoader'};
- delete $xsub{'UNIVERSAL'};
- print("/* bootstrapping code*/\n\tSAVETMPS;\n");
- print("\ttarg=sv_newmortal();\n");
- print "#ifdef USE_DYNAMIC_LOADING\n";
- print "\tPUSHMARK(sp);\n";
- print qq/\tXPUSHp("DynaLoader",strlen("DynaLoader"));\n/;
- print qq/\tPUTBACK;\n/;
- print "\tboot_DynaLoader(aTHX_ NULL);\n";
- print qq/\tSPAGAIN;\n/;
- print "#endif\n";
- foreach my $stashname (keys %xsub){
- if ($xsub{$stashname} !~ m/Dynamic/ ) {
- my $stashxsub=$stashname;
- $stashxsub =~ s/::/__/g;
- print "\tPUSHMARK(sp);\n";
- print qq/\tXPUSHp("$stashname",strlen("$stashname"));\n/;
- print qq/\tPUTBACK;\n/;
- print "\tboot_$stashxsub(aTHX_ NULL);\n";
- print qq/\tSPAGAIN;\n/;
- }
- }
- print("\tFREETMPS;\n/* end bootstrapping code */\n");
- print "}\n";
-
-print <<'EOT';
-static void
-dl_init(pTHX)
-{
- char *file = __FILE__;
- dTARG;
- dSP;
-EOT
- print("/* Dynamicboot strapping code*/\n\tSAVETMPS;\n");
- print("\ttarg=sv_newmortal();\n");
- foreach my $stashname (@DynaLoader::dl_modules) {
- warn "Loaded $stashname\n";
- if (exists($xsub{$stashname}) && $xsub{$stashname} =~ m/Dynamic/) {
- my $stashxsub=$stashname;
- $stashxsub =~ s/::/__/g;
- print "\tPUSHMARK(sp);\n";
- print qq/\tXPUSHp("$stashname",/,length($stashname),qq/);\n/;
- print qq/\tPUTBACK;\n/;
- print "#ifdef USE_DYNAMIC_LOADING\n";
- warn "bootstrapping $stashname added to xs_init\n";
- if( $xsub{$stashname} eq 'Dynamic' ) {
- print qq/\tperl_call_method("bootstrap",G_DISCARD);\n/;
- }
- else {
- print qq/\tperl_call_pv("XSLoader::load",G_DISCARD);\n/;
- }
- print "#else\n";
- print "\tboot_$stashxsub(aTHX_ NULL);\n";
- print "#endif\n";
- print qq/\tSPAGAIN;\n/;
- }
- }
- print("\tFREETMPS;\n/* end Dynamic bootstrapping code */\n");
- print "}\n";
-}
-sub dump_symtable {
- # For debugging
- my ($sym, $val);
- warn "----Symbol table:\n";
- while (($sym, $val) = each %symtable) {
- warn "$sym => $val\n";
- }
- warn "---End of symbol table\n";
-}
-
-sub save_object {
- my $sv;
- foreach $sv (@_) {
- svref_2object($sv)->save;
- }
-}
-
-sub Dummy_BootStrap { }
-
-sub B::GV::savecv
-{
- my $gv = shift;
- my $package=$gv->STASH->NAME;
- my $name = $gv->NAME;
- my $cv = $gv->CV;
- my $sv = $gv->SV;
- my $av = $gv->AV;
- my $hv = $gv->HV;
-
- my $fullname = $gv->STASH->NAME . "::" . $gv->NAME;
-
- # We may be looking at this package just because it is a branch in the
- # symbol table which is on the path to a package which we need to save
- # e.g. this is 'Getopt' and we need to save 'Getopt::Long'
- #
- return unless ($unused_sub_packages{$package});
- return unless ($$cv || $$av || $$sv || $$hv);
- $gv->save;
-}
-
-sub mark_package
-{
- my $package = shift;
- unless ($unused_sub_packages{$package})
- {
- no strict 'refs';
- $unused_sub_packages{$package} = 1;
- if (defined @{$package.'::ISA'})
- {
- foreach my $isa (@{$package.'::ISA'})
- {
- if ($isa eq 'DynaLoader')
- {
- unless (defined(&{$package.'::bootstrap'}))
- {
- warn "Forcing bootstrap of $package\n";
- eval { $package->bootstrap };
- }
- }
-# else
- {
- unless ($unused_sub_packages{$isa})
- {
- warn "$isa saved (it is in $package\'s \@ISA)\n";
- mark_package($isa);
- }
- }
- }
- }
- }
- return 1;
-}
-
-sub should_save
-{
- no strict qw(vars refs);
- my $package = shift;
- $package =~ s/::$//;
- return $unused_sub_packages{$package} = 0 if ($package =~ /::::/); # skip ::::ISA::CACHE etc.
- # warn "Considering $package\n";#debug
- foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages))
- {
- # If this package is a prefix to something we are saving, traverse it
- # but do not mark it for saving if it is not already
- # e.g. to get to Getopt::Long we need to traverse Getopt but need
- # not save Getopt
- return 1 if ($u =~ /^$package\:\:/);
- }
- if (exists $unused_sub_packages{$package})
- {
- # warn "Cached $package is ".$unused_sub_packages{$package}."\n";
- delete_unsaved_hashINC($package) unless $unused_sub_packages{$package} ;
- return $unused_sub_packages{$package};
- }
- # Omit the packages which we use (and which cause grief
- # because of fancy "goto &$AUTOLOAD" stuff).
- # XXX Surely there must be a nicer way to do this.
- if ($package eq "FileHandle" || $package eq "Config" ||
- $package eq "SelectSaver" || $package =~/^(B|IO)::/)
- {
- delete_unsaved_hashINC($package);
- return $unused_sub_packages{$package} = 0;
- }
- # Now see if current package looks like an OO class this is probably too strong.
- foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE))
- {
- if (UNIVERSAL::can($package, $m))
- {
- warn "$package has method $m: saving package\n";#debug
- return mark_package($package);
- }
- }
- delete_unsaved_hashINC($package);
- return $unused_sub_packages{$package} = 0;
-}
-sub delete_unsaved_hashINC{
- my $packname=shift;
- $packname =~ s/\:\:/\//g;
- $packname .= '.pm';
-# warn "deleting $packname" if $INC{$packname} ;# debug
- delete $INC{$packname};
-}
-sub walkpackages
-{
- my ($symref, $recurse, $prefix) = @_;
- my $sym;
- my $ref;
- no strict 'vars';
- $prefix = '' unless defined $prefix;
- while (($sym, $ref) = each %$symref)
- {
- local(*glob);
- *glob = $ref;
- if ($sym =~ /::$/)
- {
- $sym = $prefix . $sym;
- if ($sym ne "main::" && $sym ne "<none>::" && &$recurse($sym))
- {
- walkpackages(\%glob, $recurse, $sym);
- }
- }
- }
-}
-
-
-sub save_unused_subs
-{
- no strict qw(refs);
- &descend_marked_unused;
- warn "Prescan\n";
- walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 });
- warn "Saving methods\n";
- walksymtable(\%{"main::"}, "savecv", \&should_save);
-}
-
-sub save_context
-{
- my $curpad_nam = (comppadlist->ARRAY)[0]->save;
- my $curpad_sym = (comppadlist->ARRAY)[1]->save;
- my $inc_hv = svref_2object(\%INC)->save;
- my $inc_av = svref_2object(\@INC)->save;
- my $amagic_generate= amagic_generation;
- $init->add( "PL_curpad = AvARRAY($curpad_sym);",
- "GvHV(PL_incgv) = $inc_hv;",
- "GvAV(PL_incgv) = $inc_av;",
- "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
- "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
- "PL_amagic_generation= $amagic_generate;" );
-}
-
-sub descend_marked_unused {
- foreach my $pack (keys %unused_sub_packages)
- {
- mark_package($pack);
- }
-}
-
-sub save_main {
- # this is mainly for the test suite
- my $warner = $SIG{__WARN__};
- local $SIG{__WARN__} = sub { print STDERR @_ };
-
- warn "Starting compile\n";
- warn "Walking tree\n";
- seek(STDOUT,0,0); #exclude print statements in BEGIN{} into output
- walkoptree(main_root, "save");
- warn "done main optree, walking symtable for extras\n" if $debug_cv;
- save_unused_subs();
- # XSLoader was used, force saving of XSLoader::load
- if( $use_xsloader ) {
- my $cv = svref_2object( \&XSLoader::load );
- $cv->save;
- }
- # save %SIG ( in case it was set in a BEGIN block )
- if( $save_sig ) {
- local $SIG{__WARN__} = $warner;
- $init->no_split;
- $init->add("{", "\tHV* hv = get_hv(\"main::SIG\",1);" );
- foreach my $k ( keys %SIG ) {
- next unless ref $SIG{$k};
- my $cv = svref_2object( \$SIG{$k} );
- my $sv = $cv->save;
- $init->add('{',sprintf 'SV* sv = (SV*)%s;', $sv );
- $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
- cstring($k),length(pack "a*",$k),
- 'sv', hash($k)));
- $init->add('mg_set(sv);','}');
- }
- $init->add('}');
- $init->split;
- }
- # honour -w
- $init->add( sprintf " PL_dowarn = ( %s ) ? G_WARN_ON : G_WARN_OFF;", $^W );
- #
- my $init_av = init_av->save;
- my $end_av = end_av->save;
- $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
- sprintf("PL_main_start = s\\_%x;", ${main_start()}),
- "PL_initav = (AV *) $init_av;",
- "PL_endav = (AV*) $end_av;");
- save_context();
- # init op addrs ( must be the last action, otherwise
- # some ops might not be initialized
- if( $optimize_ppaddr ) {
- foreach my $i ( @op_sections ) {
- my $section = $$i;
- next unless $section->index >= 0;
- init_op_addr( $section->name, $section->index + 1);
- }
- }
- init_op_warn( $copsect->name, $copsect->index + 1)
- if $optimize_warn_sv && $copsect->index >= 0;
-
- warn "Writing output\n";
- output_boilerplate();
- print "\n";
- output_all("perl_init");
- print "\n";
- output_main();
-}
-
-sub init_sections {
- my @sections = (decl => \$decl, sym => \$symsect,
- binop => \$binopsect, condop => \$condopsect,
- cop => \$copsect, padop => \$padopsect,
- listop => \$listopsect, logop => \$logopsect,
- loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
- pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
- sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect,
- xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect,
- xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
- xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
- xrv => \$xrvsect, xpvbm => \$xpvbmsect,
- xpvio => \$xpviosect);
- my ($name, $sectref);
- while (($name, $sectref) = splice(@sections, 0, 2)) {
- $$sectref = new B::C::Section $name, \%symtable, 0;
- }
- $init = new B::C::InitSection 'init', \%symtable, 0;
-}
-
-sub mark_unused
-{
- my ($arg,$val) = @_;
- $unused_sub_packages{$arg} = $val;
-}
-
-sub compile {
- my @options = @_;
- my ($option, $opt, $arg);
- my @eval_at_startup;
- my %option_map = ( 'cog' => \$pv_copy_on_grow,
- 'save-data' => \$save_data_fh,
- 'ppaddr' => \$optimize_ppaddr,
- 'warn-sv' => \$optimize_warn_sv,
- 'use-script-name' => \$use_perl_script_name,
- 'save-sig-hash' => \$save_sig,
- );
- my %optimization_map = ( 0 => [ qw() ], # special case
- 1 => [ qw(-fcog) ],
- 2 => [ qw(-fwarn-sv -fppaddr) ],
- );
- OPTION:
- while ($option = shift @options) {
- if ($option =~ /^-(.)(.*)/) {
- $opt = $1;
- $arg = $2;
- } else {
- unshift @options, $option;
- last OPTION;
- }
- if ($opt eq "-" && $arg eq "-") {
- shift @options;
- last OPTION;
- }
- if ($opt eq "w") {
- $warn_undefined_syms = 1;
- } elsif ($opt eq "D") {
- $arg ||= shift @options;
- foreach $arg (split(//, $arg)) {
- if ($arg eq "o") {
- B->debug(1);
- } elsif ($arg eq "c") {
- $debug_cops = 1;
- } elsif ($arg eq "A") {
- $debug_av = 1;
- } elsif ($arg eq "C") {
- $debug_cv = 1;
- } elsif ($arg eq "M") {
- $debug_mg = 1;
- } else {
- warn "ignoring unknown debug option: $arg\n";
- }
- }
- } elsif ($opt eq "o") {
- $arg ||= shift @options;
- open(STDOUT, ">$arg") or return "$arg: $!\n";
- } elsif ($opt eq "v") {
- $verbose = 1;
- } elsif ($opt eq "u") {
- $arg ||= shift @options;
- mark_unused($arg,undef);
- } elsif ($opt eq "f") {
- $arg ||= shift @options;
- $arg =~ m/(no-)?(.*)/;
- my $no = defined($1) && $1 eq 'no-';
- $arg = $no ? $2 : $arg;
- if( exists $option_map{$arg} ) {
- ${$option_map{$arg}} = !$no;
- } else {
- die "Invalid optimization '$arg'";
- }
- } elsif ($opt eq "O") {
- $arg = 1 if $arg eq "";
- my @opt;
- foreach my $i ( 1 .. $arg ) {
- push @opt, @{$optimization_map{$i}}
- if exists $optimization_map{$i};
- }
- unshift @options, @opt;
- } elsif ($opt eq "e") {
- push @eval_at_startup, $arg;
- } elsif ($opt eq "l") {
- $max_string_len = $arg;
- }
- }
- init_sections();
- foreach my $i ( @eval_at_startup ) {
- $init->add_eval( $i );
- }
- if (@options) {
- return sub {
- my $objname;
- foreach $objname (@options) {
- eval "save_object(\\$objname)";
- }
- output_all();
- }
- } else {
- return sub { save_main() };
- }
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-B::C - Perl compiler's C backend
-
-=head1 SYNOPSIS
-
- perl -MO=C[,OPTIONS] foo.pl
-
-=head1 DESCRIPTION
-
-This compiler backend takes Perl source and generates C source code
-corresponding to the internal structures that perl uses to run
-your program. When the generated C source is compiled and run, it
-cuts out the time which perl would have taken to load and parse
-your program into its internal semi-compiled form. That means that
-compiling with this backend will not help improve the runtime
-execution speed of your program but may improve the start-up time.
-Depending on the environment in which your program runs this may be
-either a help or a hindrance.
-
-=head1 OPTIONS
-
-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.
-
-=over 4
-
-=item B<-ofilename>
-
-Output to filename instead of STDOUT
-
-=item B<-v>
-
-Verbose compilation (currently gives a few compilation statistics).
-
-=item B<-->
-
-Force end of options
-
-=item B<-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 C<$SIG{BAR} = "foo">. A better fix, though, is just
-to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
-options. The compiler tries to figure out which packages may possibly
-have subs in which need compiling but the current version doesn't do
-it very well. In particular, it is confused by nested packages (i.e.
-of the form C<A::B>) where package C<A> does not contain any subs.
-
-=item B<-D>
-
-Debug options (concatenated or separate flags like C<perl -D>).
-
-=item B<-Do>
-
-OPs, prints each OP as it's processed
-
-=item B<-Dc>
-
-COPs, prints COPs as processed (incl. file & line num)
-
-=item B<-DA>
-
-prints AV information on saving
-
-=item B<-DC>
-
-prints CV information on saving
-
-=item B<-DM>
-
-prints MAGIC information on saving
-
-=item B<-f>
-
-Force options/optimisations on or off one at a time. You can explicitly
-disable an option using B<-fno-option>. All options default to
-B<disabled>.
-
-=over 4
-
-=item B<-fcog>
-
-Copy-on-grow: PVs declared and initialised statically.
-
-=item B<-fsave-data>
-
-Save package::DATA filehandles ( only available with PerlIO ).
-
-=item B<-fppaddr>
-
-Optimize the initialization of op_ppaddr.
-
-=item B<-fwarn-sv>
-
-Optimize the initialization of cop_warnings.
-
-=item B<-fuse-script-name>
-
-Use the script name instead of the program name as $0.
-
-=item B<-fsave-sig-hash>
-
-Save compile-time modifications to the %SIG hash.
-
-=back
-
-=item B<-On>
-
-Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.
-
-=over 4
-
-=item B<-O0>
-
-Disable all optimizations.
-
-=item B<-O1>
-
-Enable B<-fcog>.
-
-=item B<-O2>
-
-Enable B<-fppaddr>, B<-fwarn-sv>.
-
-=back
-
-=item B<-llimit>
-
-Some C compilers impose an arbitrary limit on the length of string
-constants (e.g. 2048 characters for Microsoft Visual C++). The
-B<-llimit> options tells the C backend not to generate string literals
-exceeding that limit.
-
-=back
-
-=head1 EXAMPLES
-
- perl -MO=C,-ofoo.c foo.pl
- perl cc_harness -o foo foo.c
-
-Note that C<cc_harness> lives in the C<B> subdirectory of your perl
-library directory. The utility called C<perlcc> may also be used to
-help make use of this compiler.
-
- perl -MO=C,-v,-DcA,-l2048 bar.pl > /dev/null
-
-=head1 BUGS
-
-Plenty. Current status: experimental.
-
-=head1 AUTHOR
-
-Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
-
-=cut
+++ /dev/null
-# CC.pm
-#
-# Copyright (c) 1996, 1997, 1998 Malcolm Beattie
-#
-# You may distribute under the terms of either the GNU General Public
-# License or the Artistic License, as specified in the README file.
-#
-package B::CC;
-
-our $VERSION = '1.00';
-
-use Config;
-use strict;
-use B qw(main_start main_root class comppadlist peekop svref_2object
- timing_info init_av sv_undef amagic_generation
- OPf_WANT_LIST OPf_WANT OPf_MOD OPf_STACKED OPf_SPECIAL
- OPpASSIGN_BACKWARDS OPpLVAL_INTRO OPpDEREF_AV OPpDEREF_HV
- OPpDEREF OPpFLIP_LINENUM G_ARRAY G_SCALAR
- CXt_NULL CXt_SUB CXt_EVAL CXt_LOOP CXt_SUBST CXt_BLOCK
- );
-use B::C qw(save_unused_subs objsym init_sections mark_unused
- output_all output_boilerplate output_main);
-use B::Bblock qw(find_leaders);
-use B::Stackobj qw(:types :flags);
-
-# These should probably be elsewhere
-# Flags for $op->flags
-
-my $module; # module name (when compiled with -m)
-my %done; # hash keyed by $$op of leaders of basic blocks
- # which have already been done.
-my $leaders; # ref to hash of basic block leaders. Keys are $$op
- # addresses, values are the $op objects themselves.
-my @bblock_todo; # list of leaders of basic blocks that need visiting
- # sometime.
-my @cc_todo; # list of tuples defining what PP code needs to be
- # saved (e.g. CV, main or PMOP repl code). Each tuple
- # is [$name, $root, $start, @padlist]. PMOP repl code
- # tuples inherit padlist.
-my @stack; # shadows perl's stack when contents are known.
- # Values are objects derived from class B::Stackobj
-my @pad; # Lexicals in current pad as Stackobj-derived objects
-my @padlist; # Copy of current padlist so PMOP repl code can find it
-my @cxstack; # Shadows the (compile-time) cxstack for next,last,redo
-my $jmpbuf_ix = 0; # Next free index for dynamically allocated jmpbufs
-my %constobj; # OP_CONST constants as Stackobj-derived objects
- # keyed by $$sv.
-my $need_freetmps = 0; # We may postpone FREETMPS to the end of each basic
- # block or even to the end of each loop of blocks,
- # depending on optimisation options.
-my $know_op = 0; # Set when C variable op already holds the right op
- # (from an immediately preceding DOOP(ppname)).
-my $errors = 0; # Number of errors encountered
-my %skip_stack; # Hash of PP names which don't need write_back_stack
-my %skip_lexicals; # Hash of PP names which don't need write_back_lexicals
-my %skip_invalidate; # Hash of PP names which don't need invalidate_lexicals
-my %ignore_op; # Hash of ops which do nothing except returning op_next
-my %need_curcop; # Hash of ops which need PL_curcop
-
-my %lexstate; #state of padsvs at the start of a bblock
-
-BEGIN {
- foreach (qw(pp_scalar pp_regcmaybe pp_lineseq pp_scope pp_null)) {
- $ignore_op{$_} = 1;
- }
-}
-
-my ($module_name);
-my ($debug_op, $debug_stack, $debug_cxstack, $debug_pad, $debug_runtime,
- $debug_shadow, $debug_queue, $debug_lineno, $debug_timings);
-
-# Optimisation options. On the command line, use hyphens instead of
-# underscores for compatibility with gcc-style options. We use
-# underscores here because they are OK in (strict) barewords.
-my ($freetmps_each_bblock, $freetmps_each_loop, $omit_taint);
-my %optimise = (freetmps_each_bblock => \$freetmps_each_bblock,
- freetmps_each_loop => \$freetmps_each_loop,
- omit_taint => \$omit_taint);
-# perl patchlevel to generate code for (defaults to current patchlevel)
-my $patchlevel = int(0.5 + 1000 * ($] - 5));
-
-# Could rewrite push_runtime() and output_runtime() to use a
-# temporary file if memory is at a premium.
-my $ppname; # name of current fake PP function
-my $runtime_list_ref;
-my $declare_ref; # Hash ref keyed by C variable type of declarations.
-
-my @pp_list; # list of [$ppname, $runtime_list_ref, $declare_ref]
- # tuples to be written out.
-
-my ($init, $decl);
-
-sub init_hash { map { $_ => 1 } @_ }
-
-#
-# Initialise the hashes for the default PP functions where we can avoid
-# either write_back_stack, write_back_lexicals or invalidate_lexicals.
-#
-%skip_lexicals = init_hash qw(pp_enter pp_enterloop);
-%skip_invalidate = init_hash qw(pp_enter pp_enterloop);
-%need_curcop = init_hash qw(pp_rv2gv pp_bless pp_repeat pp_sort pp_caller
- pp_reset pp_rv2cv pp_entereval pp_require pp_dofile
- pp_entertry pp_enterloop pp_enteriter pp_entersub
- pp_enter pp_method);
-
-sub debug {
- if ($debug_runtime) {
- warn(@_);
- } else {
- my @tmp=@_;
- runtime(map { chomp; "/* $_ */"} @tmp);
- }
-}
-
-sub declare {
- my ($type, $var) = @_;
- push(@{$declare_ref->{$type}}, $var);
-}
-
-sub push_runtime {
- push(@$runtime_list_ref, @_);
- warn join("\n", @_) . "\n" if $debug_runtime;
-}
-
-sub save_runtime {
- push(@pp_list, [$ppname, $runtime_list_ref, $declare_ref]);
-}
-
-sub output_runtime {
- my $ppdata;
- print qq(#include "cc_runtime.h"\n);
- foreach $ppdata (@pp_list) {
- my ($name, $runtime, $declare) = @$ppdata;
- print "\nstatic\nCCPP($name)\n{\n";
- my ($type, $varlist, $line);
- while (($type, $varlist) = each %$declare) {
- print "\t$type ", join(", ", @$varlist), ";\n";
- }
- foreach $line (@$runtime) {
- print $line, "\n";
- }
- print "}\n";
- }
-}
-
-sub runtime {
- my $line;
- foreach $line (@_) {
- push_runtime("\t$line");
- }
-}
-
-sub init_pp {
- $ppname = shift;
- $runtime_list_ref = [];
- $declare_ref = {};
- runtime("dSP;");
- declare("I32", "oldsave");
- declare("SV", "**svp");
- map { declare("SV", "*$_") } qw(sv src dst left right);
- declare("MAGIC", "*mg");
- $decl->add("static OP * $ppname (pTHX);");
- debug "init_pp: $ppname\n" if $debug_queue;
-}
-
-# Initialise runtime_callback function for Stackobj class
-BEGIN { B::Stackobj::set_callback(\&runtime) }
-
-# Initialise saveoptree_callback for B::C class
-sub cc_queue {
- my ($name, $root, $start, @pl) = @_;
- debug "cc_queue: name $name, root $root, start $start, padlist (@pl)\n"
- if $debug_queue;
- if ($name eq "*ignore*") {
- $name = 0;
- } else {
- push(@cc_todo, [$name, $root, $start, (@pl ? @pl : @padlist)]);
- }
- my $fakeop = new B::FAKEOP ("next" => 0, sibling => 0, ppaddr => $name);
- $start = $fakeop->save;
- debug "cc_queue: name $name returns $start\n" if $debug_queue;
- return $start;
-}
-BEGIN { B::C::set_callback(\&cc_queue) }
-
-sub valid_int { $_[0]->{flags} & VALID_INT }
-sub valid_double { $_[0]->{flags} & VALID_DOUBLE }
-sub valid_numeric { $_[0]->{flags} & (VALID_INT | VALID_DOUBLE) }
-sub valid_sv { $_[0]->{flags} & VALID_SV }
-
-sub top_int { @stack ? $stack[-1]->as_int : "TOPi" }
-sub top_double { @stack ? $stack[-1]->as_double : "TOPn" }
-sub top_numeric { @stack ? $stack[-1]->as_numeric : "TOPn" }
-sub top_sv { @stack ? $stack[-1]->as_sv : "TOPs" }
-sub top_bool { @stack ? $stack[-1]->as_bool : "SvTRUE(TOPs)" }
-
-sub pop_int { @stack ? (pop @stack)->as_int : "POPi" }
-sub pop_double { @stack ? (pop @stack)->as_double : "POPn" }
-sub pop_numeric { @stack ? (pop @stack)->as_numeric : "POPn" }
-sub pop_sv { @stack ? (pop @stack)->as_sv : "POPs" }
-sub pop_bool {
- if (@stack) {
- return ((pop @stack)->as_bool);
- } else {
- # Careful: POPs has an auto-decrement and SvTRUE evaluates
- # its argument more than once.
- runtime("sv = POPs;");
- return "SvTRUE(sv)";
- }
-}
-
-sub write_back_lexicals {
- my $avoid = shift || 0;
- debug "write_back_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
- if $debug_shadow;
- my $lex;
- foreach $lex (@pad) {
- next unless ref($lex);
- $lex->write_back unless $lex->{flags} & $avoid;
- }
-}
-
-sub save_or_restore_lexical_state {
- my $bblock=shift;
- unless( exists $lexstate{$bblock}){
- foreach my $lex (@pad) {
- next unless ref($lex);
- ${$lexstate{$bblock}}{$lex->{iv}} = $lex->{flags} ;
- }
- }
- else {
- foreach my $lex (@pad) {
- next unless ref($lex);
- my $old_flags=${$lexstate{$bblock}}{$lex->{iv}} ;
- next if ( $old_flags eq $lex->{flags});
- if (($old_flags & VALID_SV) && !($lex->{flags} & VALID_SV)){
- $lex->write_back;
- }
- if (($old_flags & VALID_DOUBLE) && !($lex->{flags} & VALID_DOUBLE)){
- $lex->load_double;
- }
- if (($old_flags & VALID_INT) && !($lex->{flags} & VALID_INT)){
- $lex->load_int;
- }
- }
- }
-}
-
-sub write_back_stack {
- my $obj;
- return unless @stack;
- runtime(sprintf("EXTEND(sp, %d);", scalar(@stack)));
- foreach $obj (@stack) {
- runtime(sprintf("PUSHs((SV*)%s);", $obj->as_sv));
- }
- @stack = ();
-}
-
-sub invalidate_lexicals {
- my $avoid = shift || 0;
- debug "invalidate_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
- if $debug_shadow;
- my $lex;
- foreach $lex (@pad) {
- next unless ref($lex);
- $lex->invalidate unless $lex->{flags} & $avoid;
- }
-}
-
-sub reload_lexicals {
- my $lex;
- foreach $lex (@pad) {
- next unless ref($lex);
- my $type = $lex->{type};
- if ($type == T_INT) {
- $lex->as_int;
- } elsif ($type == T_DOUBLE) {
- $lex->as_double;
- } else {
- $lex->as_sv;
- }
- }
-}
-
-{
- package B::Pseudoreg;
- #
- # This class allocates pseudo-registers (OK, so they're C variables).
- #
- my %alloc; # Keyed by variable name. A value of 1 means the
- # variable has been declared. A value of 2 means
- # it's in use.
-
- sub new_scope { %alloc = () }
-
- sub new ($$$) {
- my ($class, $type, $prefix) = @_;
- my ($ptr, $i, $varname, $status, $obj);
- $prefix =~ s/^(\**)//;
- $ptr = $1;
- $i = 0;
- do {
- $varname = "$prefix$i";
- $status = $alloc{$varname};
- } while $status == 2;
- if ($status != 1) {
- # Not declared yet
- B::CC::declare($type, "$ptr$varname");
- $alloc{$varname} = 2; # declared and in use
- }
- $obj = bless \$varname, $class;
- return $obj;
- }
- sub DESTROY {
- my $obj = shift;
- $alloc{$$obj} = 1; # no longer in use but still declared
- }
-}
-{
- package B::Shadow;
- #
- # This class gives a standard API for a perl object to shadow a
- # C variable and only generate reloads/write-backs when necessary.
- #
- # Use $obj->load($foo) instead of runtime("shadowed_c_var = foo").
- # Use $obj->write_back whenever shadowed_c_var needs to be up to date.
- # Use $obj->invalidate whenever an unknown function may have
- # set shadow itself.
-
- sub new {
- my ($class, $write_back) = @_;
- # Object fields are perl shadow variable, validity flag
- # (for *C* variable) and callback sub for write_back
- # (passed perl shadow variable as argument).
- bless [undef, 1, $write_back], $class;
- }
- sub load {
- my ($obj, $newval) = @_;
- $obj->[1] = 0; # C variable no longer valid
- $obj->[0] = $newval;
- }
- sub write_back {
- my $obj = shift;
- if (!($obj->[1])) {
- $obj->[1] = 1; # C variable will now be valid
- &{$obj->[2]}($obj->[0]);
- }
- }
- sub invalidate { $_[0]->[1] = 0 } # force C variable to be invalid
-}
-my $curcop = new B::Shadow (sub {
- my $opsym = shift->save;
- runtime("PL_curcop = (COP*)$opsym;");
-});
-
-#
-# Context stack shadowing. Mimics stuff in pp_ctl.c, cop.h and so on.
-#
-sub dopoptoloop {
- my $cxix = $#cxstack;
- while ($cxix >= 0 && $cxstack[$cxix]->{type} != CXt_LOOP) {
- $cxix--;
- }
- debug "dopoptoloop: returning $cxix" if $debug_cxstack;
- return $cxix;
-}
-
-sub dopoptolabel {
- my $label = shift;
- my $cxix = $#cxstack;
- while ($cxix >= 0 &&
- ($cxstack[$cxix]->{type} != CXt_LOOP ||
- $cxstack[$cxix]->{label} ne $label)) {
- $cxix--;
- }
- debug "dopoptolabel: returning $cxix" if $debug_cxstack;
- return $cxix;
-}
-
-sub error {
- my $format = shift;
- my $file = $curcop->[0]->file;
- my $line = $curcop->[0]->line;
- $errors++;
- if (@_) {
- warn sprintf("%s:%d: $format\n", $file, $line, @_);
- } else {
- warn sprintf("%s:%d: %s\n", $file, $line, $format);
- }
-}
-
-#
-# Load pad takes (the elements of) a PADLIST as arguments and loads
-# up @pad with Stackobj-derived objects which represent those lexicals.
-# If/when perl itself can generate type information (my int $foo) then
-# we'll take advantage of that here. Until then, we'll use various hacks
-# to tell the compiler when we want a lexical to be a particular type
-# or to be a register.
-#
-sub load_pad {
- my ($namelistav, $valuelistav) = @_;
- @padlist = @_;
- my @namelist = $namelistav->ARRAY;
- my @valuelist = $valuelistav->ARRAY;
- my $ix;
- @pad = ();
- debug "load_pad: $#namelist names, $#valuelist values\n" if $debug_pad;
- # Temporary lexicals don't get named so it's possible for @valuelist
- # to be strictly longer than @namelist. We count $ix up to the end of
- # @valuelist but index into @namelist for the name. Any temporaries which
- # run off the end of @namelist will make $namesv undefined and we treat
- # that the same as having an explicit SPECIAL sv_undef object in @namelist.
- # [XXX If/when @_ becomes a lexical, we must start at 0 here.]
- for ($ix = 1; $ix < @valuelist; $ix++) {
- my $namesv = $namelist[$ix];
- my $type = T_UNKNOWN;
- my $flags = 0;
- my $name = "tmp$ix";
- my $class = class($namesv);
- if (!defined($namesv) || $class eq "SPECIAL") {
- # temporaries have &PL_sv_undef instead of a PVNV for a name
- $flags = VALID_SV|TEMPORARY|REGISTER;
- } else {
- if ($namesv->PV =~ /^\$(.*)_([di])(r?)$/) {
- $name = $1;
- if ($2 eq "i") {
- $type = T_INT;
- $flags = VALID_SV|VALID_INT;
- } elsif ($2 eq "d") {
- $type = T_DOUBLE;
- $flags = VALID_SV|VALID_DOUBLE;
- }
- $flags |= REGISTER if $3;
- }
- }
- $pad[$ix] = new B::Stackobj::Padsv ($type, $flags, $ix,
- "i_$name", "d_$name");
-
- debug sprintf("PL_curpad[$ix] = %s\n", $pad[$ix]->peek) if $debug_pad;
- }
-}
-
-sub declare_pad {
- my $ix;
- for ($ix = 1; $ix <= $#pad; $ix++) {
- my $type = $pad[$ix]->{type};
- declare("IV", $type == T_INT ?
- sprintf("%s=0",$pad[$ix]->{iv}):$pad[$ix]->{iv}) if $pad[$ix]->save_int;
- declare("double", $type == T_DOUBLE ?
- sprintf("%s = 0",$pad[$ix]->{nv}):$pad[$ix]->{nv} )if $pad[$ix]->save_double;
-
- }
-}
-#
-# Debugging stuff
-#
-sub peek_stack { sprintf "stack = %s\n", join(" ", map($_->minipeek, @stack)) }
-
-#
-# OP stuff
-#
-
-sub label {
- my $op = shift;
- # XXX Preserve original label name for "real" labels?
- return sprintf("lab_%x", $$op);
-}
-
-sub write_label {
- my $op = shift;
- push_runtime(sprintf(" %s:", label($op)));
-}
-
-sub loadop {
- my $op = shift;
- my $opsym = $op->save;
- runtime("PL_op = $opsym;") unless $know_op;
- return $opsym;
-}
-
-sub doop {
- my $op = shift;
- my $ppname = $op->ppaddr;
- my $sym = loadop($op);
- runtime("DOOP($ppname);");
- $know_op = 1;
- return $sym;
-}
-
-sub gimme {
- my $op = shift;
- my $flags = $op->flags;
- return (($flags & OPf_WANT) ? (($flags & OPf_WANT)== OPf_WANT_LIST? G_ARRAY:G_SCALAR) : "dowantarray()");
-}
-
-#
-# Code generation for PP code
-#
-
-sub pp_null {
- my $op = shift;
- return $op->next;
-}
-
-sub pp_stub {
- my $op = shift;
- my $gimme = gimme($op);
- if ($gimme != G_ARRAY) {
- my $obj= new B::Stackobj::Const(sv_undef);
- push(@stack, $obj);
- # XXX Change to push a constant sv_undef Stackobj onto @stack
- #write_back_stack();
- #runtime("if ($gimme != G_ARRAY) XPUSHs(&PL_sv_undef);");
- }
- return $op->next;
-}
-
-sub pp_unstack {
- my $op = shift;
- @stack = ();
- runtime("PP_UNSTACK;");
- return $op->next;
-}
-
-sub pp_and {
- my $op = shift;
- my $next = $op->next;
- reload_lexicals();
- unshift(@bblock_todo, $next);
- if (@stack >= 1) {
- my $bool = pop_bool();
- write_back_stack();
- save_or_restore_lexical_state($$next);
- runtime(sprintf("if (!$bool) {XPUSHs(&PL_sv_no); goto %s;}", label($next)));
- } else {
- save_or_restore_lexical_state($$next);
- runtime(sprintf("if (!%s) goto %s;", top_bool(), label($next)),
- "*sp--;");
- }
- return $op->other;
-}
-
-sub pp_or {
- my $op = shift;
- my $next = $op->next;
- reload_lexicals();
- unshift(@bblock_todo, $next);
- if (@stack >= 1) {
- my $bool = pop_bool @stack;
- write_back_stack();
- save_or_restore_lexical_state($$next);
- runtime(sprintf("if (%s) { XPUSHs(&PL_sv_yes); goto %s; }",
- $bool, label($next)));
- } else {
- save_or_restore_lexical_state($$next);
- runtime(sprintf("if (%s) goto %s;", top_bool(), label($next)),
- "*sp--;");
- }
- return $op->other;
-}
-
-sub pp_cond_expr {
- my $op = shift;
- my $false = $op->next;
- unshift(@bblock_todo, $false);
- reload_lexicals();
- my $bool = pop_bool();
- write_back_stack();
- save_or_restore_lexical_state($$false);
- runtime(sprintf("if (!$bool) goto %s;", label($false)));
- return $op->other;
-}
-
-sub pp_padsv {
- my $op = shift;
- my $ix = $op->targ;
- push(@stack, $pad[$ix]);
- if ($op->flags & OPf_MOD) {
- my $private = $op->private;
- if ($private & OPpLVAL_INTRO) {
- runtime("SAVECLEARSV(PL_curpad[$ix]);");
- } elsif ($private & OPpDEREF) {
- runtime(sprintf("vivify_ref(PL_curpad[%d], %d);",
- $ix, $private & OPpDEREF));
- $pad[$ix]->invalidate;
- }
- }
- return $op->next;
-}
-
-sub pp_const {
- my $op = shift;
- my $sv = $op->sv;
- my $obj;
- # constant could be in the pad (under useithreads)
- if ($$sv) {
- $obj = $constobj{$$sv};
- if (!defined($obj)) {
- $obj = $constobj{$$sv} = new B::Stackobj::Const ($sv);
- }
- }
- else {
- $obj = $pad[$op->targ];
- }
- push(@stack, $obj);
- return $op->next;
-}
-
-sub pp_nextstate {
- my $op = shift;
- $curcop->load($op);
- @stack = ();
- debug(sprintf("%s:%d\n", $op->file, $op->line)) if $debug_lineno;
- runtime("TAINT_NOT;") unless $omit_taint;
- runtime("sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;");
- if ($freetmps_each_bblock || $freetmps_each_loop) {
- $need_freetmps = 1;
- } else {
- runtime("FREETMPS;");
- }
- return $op->next;
-}
-
-sub pp_dbstate {
- my $op = shift;
- $curcop->invalidate; # XXX?
- return default_pp($op);
-}
-
-#default_pp will handle this:
-#sub pp_bless { $curcop->write_back; default_pp(@_) }
-#sub pp_repeat { $curcop->write_back; default_pp(@_) }
-# The following subs need $curcop->write_back if we decide to support arybase:
-# pp_pos, pp_substr, pp_index, pp_rindex, pp_aslice, pp_lslice, pp_splice
-#sub pp_caller { $curcop->write_back; default_pp(@_) }
-#sub pp_reset { $curcop->write_back; default_pp(@_) }
-
-sub pp_rv2gv{
- my $op =shift;
- $curcop->write_back;
- write_back_lexicals() unless $skip_lexicals{$ppname};
- write_back_stack() unless $skip_stack{$ppname};
- my $sym=doop($op);
- if ($op->private & OPpDEREF) {
- $init->add(sprintf("((UNOP *)$sym)->op_first = $sym;"));
- $init->add(sprintf("((UNOP *)$sym)->op_type = %d;",
- $op->first->type));
- }
- return $op->next;
-}
-sub pp_sort {
- my $op = shift;
- my $ppname = $op->ppaddr;
- if ( $op->flags & OPf_SPECIAL && $op->flags & OPf_STACKED){
- #this indicates the sort BLOCK Array case
- #ugly surgery required.
- my $root=$op->first->sibling->first;
- my $start=$root->first;
- $op->first->save;
- $op->first->sibling->save;
- $root->save;
- my $sym=$start->save;
- my $fakeop=cc_queue("pp_sort".$$op,$root,$start);
- $init->add(sprintf("(%s)->op_next=%s;",$sym,$fakeop));
- }
- $curcop->write_back;
- write_back_lexicals();
- write_back_stack();
- doop($op);
- return $op->next;
-}
-
-sub pp_gv {
- my $op = shift;
- my $gvsym;
- if ($Config{useithreads}) {
- $gvsym = $pad[$op->padix]->as_sv;
- }
- else {
- $gvsym = $op->gv->save;
- }
- write_back_stack();
- runtime("XPUSHs((SV*)$gvsym);");
- return $op->next;
-}
-
-sub pp_gvsv {
- my $op = shift;
- my $gvsym;
- if ($Config{useithreads}) {
- $gvsym = $pad[$op->padix]->as_sv;
- }
- else {
- $gvsym = $op->gv->save;
- }
- write_back_stack();
- if ($op->private & OPpLVAL_INTRO) {
- runtime("XPUSHs(save_scalar($gvsym));");
- } else {
- runtime("XPUSHs(GvSV($gvsym));");
- }
- return $op->next;
-}
-
-sub pp_aelemfast {
- my $op = shift;
- my $gvsym;
- if ($Config{useithreads}) {
- $gvsym = $pad[$op->padix]->as_sv;
- }
- else {
- $gvsym = $op->gv->save;
- }
- my $ix = $op->private;
- my $flag = $op->flags & OPf_MOD;
- write_back_stack();
- runtime("svp = av_fetch(GvAV($gvsym), $ix, $flag);",
- "PUSHs(svp ? *svp : &PL_sv_undef);");
- return $op->next;
-}
-
-sub int_binop {
- my ($op, $operator) = @_;
- if ($op->flags & OPf_STACKED) {
- my $right = pop_int();
- if (@stack >= 1) {
- my $left = top_int();
- $stack[-1]->set_int(&$operator($left, $right));
- } else {
- runtime(sprintf("sv_setiv(TOPs, %s);",&$operator("TOPi", $right)));
- }
- } else {
- my $targ = $pad[$op->targ];
- my $right = new B::Pseudoreg ("IV", "riv");
- my $left = new B::Pseudoreg ("IV", "liv");
- runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int));
- $targ->set_int(&$operator($$left, $$right));
- push(@stack, $targ);
- }
- return $op->next;
-}
-
-sub INTS_CLOSED () { 0x1 }
-sub INT_RESULT () { 0x2 }
-sub NUMERIC_RESULT () { 0x4 }
-
-sub numeric_binop {
- my ($op, $operator, $flags) = @_;
- my $force_int = 0;
- $force_int ||= ($flags & INT_RESULT);
- $force_int ||= ($flags & INTS_CLOSED && @stack >= 2
- && valid_int($stack[-2]) && valid_int($stack[-1]));
- if ($op->flags & OPf_STACKED) {
- my $right = pop_numeric();
- if (@stack >= 1) {
- my $left = top_numeric();
- if ($force_int) {
- $stack[-1]->set_int(&$operator($left, $right));
- } else {
- $stack[-1]->set_numeric(&$operator($left, $right));
- }
- } else {
- if ($force_int) {
- my $rightruntime = new B::Pseudoreg ("IV", "riv");
- runtime(sprintf("$$rightruntime = %s;",$right));
- runtime(sprintf("sv_setiv(TOPs, %s);",
- &$operator("TOPi", $$rightruntime)));
- } else {
- my $rightruntime = new B::Pseudoreg ("double", "rnv");
- runtime(sprintf("$$rightruntime = %s;",$right));
- runtime(sprintf("sv_setnv(TOPs, %s);",
- &$operator("TOPn",$$rightruntime)));
- }
- }
- } else {
- my $targ = $pad[$op->targ];
- $force_int ||= ($targ->{type} == T_INT);
- if ($force_int) {
- my $right = new B::Pseudoreg ("IV", "riv");
- my $left = new B::Pseudoreg ("IV", "liv");
- runtime(sprintf("$$right = %s; $$left = %s;",
- pop_numeric(), pop_numeric));
- $targ->set_int(&$operator($$left, $$right));
- } else {
- my $right = new B::Pseudoreg ("double", "rnv");
- my $left = new B::Pseudoreg ("double", "lnv");
- runtime(sprintf("$$right = %s; $$left = %s;",
- pop_numeric(), pop_numeric));
- $targ->set_numeric(&$operator($$left, $$right));
- }
- push(@stack, $targ);
- }
- return $op->next;
-}
-
-sub pp_ncmp {
- my ($op) = @_;
- if ($op->flags & OPf_STACKED) {
- my $right = pop_numeric();
- if (@stack >= 1) {
- my $left = top_numeric();
- runtime sprintf("if (%s > %s){",$left,$right);
- $stack[-1]->set_int(1);
- $stack[-1]->write_back();
- runtime sprintf("}else if (%s < %s ) {",$left,$right);
- $stack[-1]->set_int(-1);
- $stack[-1]->write_back();
- runtime sprintf("}else if (%s == %s) {",$left,$right);
- $stack[-1]->set_int(0);
- $stack[-1]->write_back();
- runtime sprintf("}else {");
- $stack[-1]->set_sv("&PL_sv_undef");
- runtime "}";
- } else {
- my $rightruntime = new B::Pseudoreg ("double", "rnv");
- runtime(sprintf("$$rightruntime = %s;",$right));
- runtime sprintf(qq/if ("TOPn" > %s){/,$rightruntime);
- runtime sprintf("sv_setiv(TOPs,1);");
- runtime sprintf(qq/}else if ( "TOPn" < %s ) {/,$$rightruntime);
- runtime sprintf("sv_setiv(TOPs,-1);");
- runtime sprintf(qq/} else if ("TOPn" == %s) {/,$$rightruntime);
- runtime sprintf("sv_setiv(TOPs,0);");
- runtime sprintf(qq/}else {/);
- runtime sprintf("sv_setiv(TOPs,&PL_sv_undef;");
- runtime "}";
- }
- } else {
- my $targ = $pad[$op->targ];
- my $right = new B::Pseudoreg ("double", "rnv");
- my $left = new B::Pseudoreg ("double", "lnv");
- runtime(sprintf("$$right = %s; $$left = %s;",
- pop_numeric(), pop_numeric));
- runtime sprintf("if (%s > %s){",$$left,$$right);
- $targ->set_int(1);
- $targ->write_back();
- runtime sprintf("}else if (%s < %s ) {",$$left,$$right);
- $targ->set_int(-1);
- $targ->write_back();
- runtime sprintf("}else if (%s == %s) {",$$left,$$right);
- $targ->set_int(0);
- $targ->write_back();
- runtime sprintf("}else {");
- $targ->set_sv("&PL_sv_undef");
- runtime "}";
- push(@stack, $targ);
- }
- return $op->next;
-}
-
-sub sv_binop {
- my ($op, $operator, $flags) = @_;
- if ($op->flags & OPf_STACKED) {
- my $right = pop_sv();
- if (@stack >= 1) {
- my $left = top_sv();
- if ($flags & INT_RESULT) {
- $stack[-1]->set_int(&$operator($left, $right));
- } elsif ($flags & NUMERIC_RESULT) {
- $stack[-1]->set_numeric(&$operator($left, $right));
- } else {
- # XXX Does this work?
- runtime(sprintf("sv_setsv($left, %s);",
- &$operator($left, $right)));
- $stack[-1]->invalidate;
- }
- } else {
- my $f;
- if ($flags & INT_RESULT) {
- $f = "sv_setiv";
- } elsif ($flags & NUMERIC_RESULT) {
- $f = "sv_setnv";
- } else {
- $f = "sv_setsv";
- }
- runtime(sprintf("%s(TOPs, %s);", $f, &$operator("TOPs", $right)));
- }
- } else {
- my $targ = $pad[$op->targ];
- runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv));
- if ($flags & INT_RESULT) {
- $targ->set_int(&$operator("left", "right"));
- } elsif ($flags & NUMERIC_RESULT) {
- $targ->set_numeric(&$operator("left", "right"));
- } else {
- # XXX Does this work?
- runtime(sprintf("sv_setsv(%s, %s);",
- $targ->as_sv, &$operator("left", "right")));
- $targ->invalidate;
- }
- push(@stack, $targ);
- }
- return $op->next;
-}
-
-sub bool_int_binop {
- my ($op, $operator) = @_;
- my $right = new B::Pseudoreg ("IV", "riv");
- my $left = new B::Pseudoreg ("IV", "liv");
- runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int()));
- my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
- $bool->set_int(&$operator($$left, $$right));
- push(@stack, $bool);
- return $op->next;
-}
-
-sub bool_numeric_binop {
- my ($op, $operator) = @_;
- my $right = new B::Pseudoreg ("double", "rnv");
- my $left = new B::Pseudoreg ("double", "lnv");
- runtime(sprintf("$$right = %s; $$left = %s;",
- pop_numeric(), pop_numeric()));
- my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
- $bool->set_numeric(&$operator($$left, $$right));
- push(@stack, $bool);
- return $op->next;
-}
-
-sub bool_sv_binop {
- my ($op, $operator) = @_;
- runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv()));
- my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
- $bool->set_numeric(&$operator("left", "right"));
- push(@stack, $bool);
- return $op->next;
-}
-
-sub infix_op {
- my $opname = shift;
- return sub { "$_[0] $opname $_[1]" }
-}
-
-sub prefix_op {
- my $opname = shift;
- return sub { sprintf("%s(%s)", $opname, join(", ", @_)) }
-}
-
-BEGIN {
- my $plus_op = infix_op("+");
- my $minus_op = infix_op("-");
- my $multiply_op = infix_op("*");
- my $divide_op = infix_op("/");
- my $modulo_op = infix_op("%");
- my $lshift_op = infix_op("<<");
- my $rshift_op = infix_op(">>");
- my $scmp_op = prefix_op("sv_cmp");
- my $seq_op = prefix_op("sv_eq");
- my $sne_op = prefix_op("!sv_eq");
- my $slt_op = sub { "sv_cmp($_[0], $_[1]) < 0" };
- my $sgt_op = sub { "sv_cmp($_[0], $_[1]) > 0" };
- my $sle_op = sub { "sv_cmp($_[0], $_[1]) <= 0" };
- my $sge_op = sub { "sv_cmp($_[0], $_[1]) >= 0" };
- my $eq_op = infix_op("==");
- my $ne_op = infix_op("!=");
- my $lt_op = infix_op("<");
- my $gt_op = infix_op(">");
- my $le_op = infix_op("<=");
- my $ge_op = infix_op(">=");
-
- #
- # XXX The standard perl PP code has extra handling for
- # some special case arguments of these operators.
- #
- sub pp_add { numeric_binop($_[0], $plus_op) }
- sub pp_subtract { numeric_binop($_[0], $minus_op) }
- sub pp_multiply { numeric_binop($_[0], $multiply_op) }
- sub pp_divide { numeric_binop($_[0], $divide_op) }
- sub pp_modulo { int_binop($_[0], $modulo_op) } # differs from perl's
-
- sub pp_left_shift { int_binop($_[0], $lshift_op) }
- sub pp_right_shift { int_binop($_[0], $rshift_op) }
- sub pp_i_add { int_binop($_[0], $plus_op) }
- sub pp_i_subtract { int_binop($_[0], $minus_op) }
- sub pp_i_multiply { int_binop($_[0], $multiply_op) }
- sub pp_i_divide { int_binop($_[0], $divide_op) }
- sub pp_i_modulo { int_binop($_[0], $modulo_op) }
-
- sub pp_eq { bool_numeric_binop($_[0], $eq_op) }
- sub pp_ne { bool_numeric_binop($_[0], $ne_op) }
- sub pp_lt { bool_numeric_binop($_[0], $lt_op) }
- sub pp_gt { bool_numeric_binop($_[0], $gt_op) }
- sub pp_le { bool_numeric_binop($_[0], $le_op) }
- sub pp_ge { bool_numeric_binop($_[0], $ge_op) }
-
- sub pp_i_eq { bool_int_binop($_[0], $eq_op) }
- sub pp_i_ne { bool_int_binop($_[0], $ne_op) }
- sub pp_i_lt { bool_int_binop($_[0], $lt_op) }
- sub pp_i_gt { bool_int_binop($_[0], $gt_op) }
- sub pp_i_le { bool_int_binop($_[0], $le_op) }
- sub pp_i_ge { bool_int_binop($_[0], $ge_op) }
-
- sub pp_scmp { sv_binop($_[0], $scmp_op, INT_RESULT) }
- sub pp_slt { bool_sv_binop($_[0], $slt_op) }
- sub pp_sgt { bool_sv_binop($_[0], $sgt_op) }
- sub pp_sle { bool_sv_binop($_[0], $sle_op) }
- sub pp_sge { bool_sv_binop($_[0], $sge_op) }
- sub pp_seq { bool_sv_binop($_[0], $seq_op) }
- sub pp_sne { bool_sv_binop($_[0], $sne_op) }
-}
-
-
-sub pp_sassign {
- my $op = shift;
- my $backwards = $op->private & OPpASSIGN_BACKWARDS;
- my ($dst, $src);
- if (@stack >= 2) {
- $dst = pop @stack;
- $src = pop @stack;
- ($src, $dst) = ($dst, $src) if $backwards;
- my $type = $src->{type};
- if ($type == T_INT) {
- $dst->set_int($src->as_int,$src->{flags} & VALID_UNSIGNED);
- } elsif ($type == T_DOUBLE) {
- $dst->set_numeric($src->as_numeric);
- } else {
- $dst->set_sv($src->as_sv);
- }
- push(@stack, $dst);
- } elsif (@stack == 1) {
- if ($backwards) {
- my $src = pop @stack;
- my $type = $src->{type};
- runtime("if (PL_tainting && PL_tainted) TAINT_NOT;");
- if ($type == T_INT) {
- if ($src->{flags} & VALID_UNSIGNED){
- runtime sprintf("sv_setuv(TOPs, %s);", $src->as_int);
- }else{
- runtime sprintf("sv_setiv(TOPs, %s);", $src->as_int);
- }
- } elsif ($type == T_DOUBLE) {
- runtime sprintf("sv_setnv(TOPs, %s);", $src->as_double);
- } else {
- runtime sprintf("sv_setsv(TOPs, %s);", $src->as_sv);
- }
- runtime("SvSETMAGIC(TOPs);");
- } else {
- my $dst = $stack[-1];
- my $type = $dst->{type};
- runtime("sv = POPs;");
- runtime("MAYBE_TAINT_SASSIGN_SRC(sv);");
- if ($type == T_INT) {
- $dst->set_int("SvIV(sv)");
- } elsif ($type == T_DOUBLE) {
- $dst->set_double("SvNV(sv)");
- } else {
- runtime("SvSetMagicSV($dst->{sv}, sv);");
- $dst->invalidate;
- }
- }
- } else {
- if ($backwards) {
- runtime("src = POPs; dst = TOPs;");
- } else {
- runtime("dst = POPs; src = TOPs;");
- }
- runtime("MAYBE_TAINT_SASSIGN_SRC(src);",
- "SvSetSV(dst, src);",
- "SvSETMAGIC(dst);",
- "SETs(dst);");
- }
- return $op->next;
-}
-
-sub pp_preinc {
- my $op = shift;
- if (@stack >= 1) {
- my $obj = $stack[-1];
- my $type = $obj->{type};
- if ($type == T_INT || $type == T_DOUBLE) {
- $obj->set_int($obj->as_int . " + 1");
- } else {
- runtime sprintf("PP_PREINC(%s);", $obj->as_sv);
- $obj->invalidate();
- }
- } else {
- runtime sprintf("PP_PREINC(TOPs);");
- }
- return $op->next;
-}
-
-
-sub pp_pushmark {
- my $op = shift;
- write_back_stack();
- runtime("PUSHMARK(sp);");
- return $op->next;
-}
-
-sub pp_list {
- my $op = shift;
- write_back_stack();
- my $gimme = gimme($op);
- if ($gimme == G_ARRAY) { # sic
- runtime("POPMARK;"); # need this even though not a "full" pp_list
- } else {
- runtime("PP_LIST($gimme);");
- }
- return $op->next;
-}
-
-sub pp_entersub {
- my $op = shift;
- $curcop->write_back;
- write_back_lexicals(REGISTER|TEMPORARY);
- write_back_stack();
- my $sym = doop($op);
- runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){");
- runtime("PL_op = (*PL_op->op_ppaddr)(aTHX);");
- runtime("SPAGAIN;}");
- $know_op = 0;
- invalidate_lexicals(REGISTER|TEMPORARY);
- return $op->next;
-}
-sub pp_formline {
- my $op = shift;
- my $ppname = $op->ppaddr;
- write_back_lexicals() unless $skip_lexicals{$ppname};
- write_back_stack() unless $skip_stack{$ppname};
- my $sym=doop($op);
- # See comment in pp_grepwhile to see why!
- $init->add("((LISTOP*)$sym)->op_first = $sym;");
- runtime("if (PL_op == ((LISTOP*)($sym))->op_first){");
- save_or_restore_lexical_state(${$op->first});
- runtime( sprintf("goto %s;",label($op->first)));
- runtime("}");
- return $op->next;
-}
-
-sub pp_goto{
-
- my $op = shift;
- my $ppname = $op->ppaddr;
- write_back_lexicals() unless $skip_lexicals{$ppname};
- write_back_stack() unless $skip_stack{$ppname};
- my $sym=doop($op);
- runtime("if (PL_op != ($sym)->op_next && PL_op != (OP*)0){return PL_op;}");
- invalidate_lexicals() unless $skip_invalidate{$ppname};
- return $op->next;
-}
-sub pp_enterwrite {
- my $op = shift;
- pp_entersub($op);
-}
-sub pp_leavesub{
- my $op = shift;
- write_back_lexicals() unless $skip_lexicals{$ppname};
- write_back_stack() unless $skip_stack{$ppname};
- runtime("if (PL_curstackinfo->si_type == PERLSI_SORT){");
- runtime("\tPUTBACK;return 0;");
- runtime("}");
- doop($op);
- return $op->next;
-}
-sub pp_leavewrite {
- my $op = shift;
- write_back_lexicals(REGISTER|TEMPORARY);
- write_back_stack();
- my $sym = doop($op);
- # XXX Is this the right way to distinguish between it returning
- # CvSTART(cv) (via doform) and pop_return()?
- #runtime("if (PL_op) PL_op = (*PL_op->op_ppaddr)(aTHX);");
- runtime("SPAGAIN;");
- $know_op = 0;
- invalidate_lexicals(REGISTER|TEMPORARY);
- return $op->next;
-}
-
-sub doeval {
- my $op = shift;
- $curcop->write_back;
- write_back_lexicals(REGISTER|TEMPORARY);
- write_back_stack();
- my $sym = loadop($op);
- my $ppaddr = $op->ppaddr;
- #runtime(qq/printf("$ppaddr type eval\n");/);
- runtime("PP_EVAL($ppaddr, ($sym)->op_next);");
- $know_op = 1;
- invalidate_lexicals(REGISTER|TEMPORARY);
- return $op->next;
-}
-
-sub pp_entereval { doeval(@_) }
-sub pp_dofile { doeval(@_) }
-
-#pp_require is protected by pp_entertry, so no protection for it.
-sub pp_require {
- my $op = shift;
- $curcop->write_back;
- write_back_lexicals(REGISTER|TEMPORARY);
- write_back_stack();
- my $sym = doop($op);
- runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){");
- runtime("PL_op = (*PL_op->op_ppaddr)(ARGS);");
- runtime("SPAGAIN;}");
- $know_op = 1;
- invalidate_lexicals(REGISTER|TEMPORARY);
- return $op->next;
-}
-
-
-sub pp_entertry {
- my $op = shift;
- $curcop->write_back;
- write_back_lexicals(REGISTER|TEMPORARY);
- write_back_stack();
- my $sym = doop($op);
- my $jmpbuf = sprintf("jmpbuf%d", $jmpbuf_ix++);
- declare("JMPENV", $jmpbuf);
- runtime(sprintf("PP_ENTERTRY(%s,%s);", $jmpbuf, label($op->other->next)));
- invalidate_lexicals(REGISTER|TEMPORARY);
- return $op->next;
-}
-
-sub pp_leavetry{
- my $op=shift;
- default_pp($op);
- runtime("PP_LEAVETRY;");
- return $op->next;
-}
-
-sub pp_grepstart {
- my $op = shift;
- if ($need_freetmps && $freetmps_each_loop) {
- runtime("FREETMPS;"); # otherwise the grepwhile loop messes things up
- $need_freetmps = 0;
- }
- write_back_stack();
- my $sym= doop($op);
- my $next=$op->next;
- $next->save;
- my $nexttonext=$next->next;
- $nexttonext->save;
- save_or_restore_lexical_state($$nexttonext);
- runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;",
- label($nexttonext)));
- return $op->next->other;
-}
-
-sub pp_mapstart {
- my $op = shift;
- if ($need_freetmps && $freetmps_each_loop) {
- runtime("FREETMPS;"); # otherwise the mapwhile loop messes things up
- $need_freetmps = 0;
- }
- write_back_stack();
- # pp_mapstart can return either op_next->op_next or op_next->op_other and
- # we need to be able to distinguish the two at runtime.
- my $sym= doop($op);
- my $next=$op->next;
- $next->save;
- my $nexttonext=$next->next;
- $nexttonext->save;
- save_or_restore_lexical_state($$nexttonext);
- runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;",
- label($nexttonext)));
- return $op->next->other;
-}
-
-sub pp_grepwhile {
- my $op = shift;
- my $next = $op->next;
- unshift(@bblock_todo, $next);
- write_back_lexicals();
- write_back_stack();
- my $sym = doop($op);
- # pp_grepwhile can return either op_next or op_other and we need to
- # be able to distinguish the two at runtime. Since it's possible for
- # both ops to be "inlined", the fields could both be zero. To get
- # around that, we hack op_next to be our own op (purely because we
- # know it's a non-NULL pointer and can't be the same as op_other).
- $init->add("((LOGOP*)$sym)->op_next = $sym;");
- save_or_restore_lexical_state($$next);
- runtime(sprintf("if (PL_op == ($sym)->op_next) goto %s;", label($next)));
- $know_op = 0;
- return $op->other;
-}
-
-sub pp_mapwhile {
- pp_grepwhile(@_);
-}
-
-sub pp_return {
- my $op = shift;
- write_back_lexicals(REGISTER|TEMPORARY);
- write_back_stack();
- doop($op);
- runtime("PUTBACK;", "return PL_op;");
- $know_op = 0;
- return $op->next;
-}
-
-sub nyi {
- my $op = shift;
- warn sprintf("%s not yet implemented properly\n", $op->ppaddr);
- return default_pp($op);
-}
-
-sub pp_range {
- my $op = shift;
- my $flags = $op->flags;
- if (!($flags & OPf_WANT)) {
- error("context of range unknown at compile-time");
- }
- write_back_lexicals();
- write_back_stack();
- unless (($flags & OPf_WANT)== OPf_WANT_LIST) {
- # We need to save our UNOP structure since pp_flop uses
- # it to find and adjust out targ. We don't need it ourselves.
- $op->save;
- save_or_restore_lexical_state(${$op->other});
- runtime sprintf("if (SvTRUE(PL_curpad[%d])) goto %s;",
- $op->targ, label($op->other));
- unshift(@bblock_todo, $op->other);
- }
- return $op->next;
-}
-
-sub pp_flip {
- my $op = shift;
- my $flags = $op->flags;
- if (!($flags & OPf_WANT)) {
- error("context of flip unknown at compile-time");
- }
- if (($flags & OPf_WANT)==OPf_WANT_LIST) {
- return $op->first->other;
- }
- write_back_lexicals();
- write_back_stack();
- # We need to save our UNOP structure since pp_flop uses
- # it to find and adjust out targ. We don't need it ourselves.
- $op->save;
- my $ix = $op->targ;
- my $rangeix = $op->first->targ;
- runtime(($op->private & OPpFLIP_LINENUM) ?
- "if (PL_last_in_gv && SvIV(TOPs) == IoLINES(GvIOp(PL_last_in_gv))) {"
- : "if (SvTRUE(TOPs)) {");
- runtime("\tsv_setiv(PL_curpad[$rangeix], 1);");
- if ($op->flags & OPf_SPECIAL) {
- runtime("sv_setiv(PL_curpad[$ix], 1);");
- } else {
- save_or_restore_lexical_state(${$op->first->other});
- runtime("\tsv_setiv(PL_curpad[$ix], 0);",
- "\tsp--;",
- sprintf("\tgoto %s;", label($op->first->other)));
- }
- runtime("}",
- qq{sv_setpv(PL_curpad[$ix], "");},
- "SETs(PL_curpad[$ix]);");
- $know_op = 0;
- return $op->next;
-}
-
-sub pp_flop {
- my $op = shift;
- default_pp($op);
- $know_op = 0;
- return $op->next;
-}
-
-sub enterloop {
- my $op = shift;
- my $nextop = $op->nextop;
- my $lastop = $op->lastop;
- my $redoop = $op->redoop;
- $curcop->write_back;
- debug "enterloop: pushing on cxstack" if $debug_cxstack;
- push(@cxstack, {
- type => CXt_LOOP,
- op => $op,
- "label" => $curcop->[0]->label,
- nextop => $nextop,
- lastop => $lastop,
- redoop => $redoop
- });
- $nextop->save;
- $lastop->save;
- $redoop->save;
- return default_pp($op);
-}
-
-sub pp_enterloop { enterloop(@_) }
-sub pp_enteriter { enterloop(@_) }
-
-sub pp_leaveloop {
- my $op = shift;
- if (!@cxstack) {
- die "panic: leaveloop";
- }
- debug "leaveloop: popping from cxstack" if $debug_cxstack;
- pop(@cxstack);
- return default_pp($op);
-}
-
-sub pp_next {
- my $op = shift;
- my $cxix;
- if ($op->flags & OPf_SPECIAL) {
- $cxix = dopoptoloop();
- if ($cxix < 0) {
- error('"next" used outside loop');
- return $op->next; # ignore the op
- }
- } else {
- $cxix = dopoptolabel($op->pv);
- if ($cxix < 0) {
- error('Label not found at compile time for "next %s"', $op->pv);
- return $op->next; # ignore the op
- }
- }
- default_pp($op);
- my $nextop = $cxstack[$cxix]->{nextop};
- push(@bblock_todo, $nextop);
- save_or_restore_lexical_state($$nextop);
- runtime(sprintf("goto %s;", label($nextop)));
- return $op->next;
-}
-
-sub pp_redo {
- my $op = shift;
- my $cxix;
- if ($op->flags & OPf_SPECIAL) {
- $cxix = dopoptoloop();
- if ($cxix < 0) {
- error('"redo" used outside loop');
- return $op->next; # ignore the op
- }
- } else {
- $cxix = dopoptolabel($op->pv);
- if ($cxix < 0) {
- error('Label not found at compile time for "redo %s"', $op->pv);
- return $op->next; # ignore the op
- }
- }
- default_pp($op);
- my $redoop = $cxstack[$cxix]->{redoop};
- push(@bblock_todo, $redoop);
- save_or_restore_lexical_state($$redoop);
- runtime(sprintf("goto %s;", label($redoop)));
- return $op->next;
-}
-
-sub pp_last {
- my $op = shift;
- my $cxix;
- if ($op->flags & OPf_SPECIAL) {
- $cxix = dopoptoloop();
- if ($cxix < 0) {
- error('"last" used outside loop');
- return $op->next; # ignore the op
- }
- } else {
- $cxix = dopoptolabel($op->pv);
- if ($cxix < 0) {
- error('Label not found at compile time for "last %s"', $op->pv);
- return $op->next; # ignore the op
- }
- # XXX Add support for "last" to leave non-loop blocks
- if ($cxstack[$cxix]->{type} != CXt_LOOP) {
- error('Use of "last" for non-loop blocks is not yet implemented');
- return $op->next; # ignore the op
- }
- }
- default_pp($op);
- my $lastop = $cxstack[$cxix]->{lastop}->next;
- push(@bblock_todo, $lastop);
- save_or_restore_lexical_state($$lastop);
- runtime(sprintf("goto %s;", label($lastop)));
- return $op->next;
-}
-
-sub pp_subst {
- my $op = shift;
- write_back_lexicals();
- write_back_stack();
- my $sym = doop($op);
- my $replroot = $op->pmreplroot;
- if ($$replroot) {
- save_or_restore_lexical_state($$replroot);
- runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplroot) goto %s;",
- $sym, label($replroot));
- $op->pmreplstart->save;
- push(@bblock_todo, $replroot);
- }
- invalidate_lexicals();
- return $op->next;
-}
-
-sub pp_substcont {
- my $op = shift;
- write_back_lexicals();
- write_back_stack();
- doop($op);
- my $pmop = $op->other;
- # warn sprintf("substcont: op = %s, pmop = %s\n",
- # peekop($op), peekop($pmop));#debug
-# my $pmopsym = objsym($pmop);
- my $pmopsym = $pmop->save; # XXX can this recurse?
-# warn "pmopsym = $pmopsym\n";#debug
- save_or_restore_lexical_state(${$pmop->pmreplstart});
- runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplstart) goto %s;",
- $pmopsym, label($pmop->pmreplstart));
- invalidate_lexicals();
- return $pmop->next;
-}
-
-sub default_pp {
- my $op = shift;
- my $ppname = "pp_" . $op->name;
- if ($curcop and $need_curcop{$ppname}){
- $curcop->write_back;
- }
- write_back_lexicals() unless $skip_lexicals{$ppname};
- write_back_stack() unless $skip_stack{$ppname};
- doop($op);
- # XXX If the only way that ops can write to a TEMPORARY lexical is
- # when it's named in $op->targ then we could call
- # invalidate_lexicals(TEMPORARY) and avoid having to write back all
- # the temporaries. For now, we'll play it safe and write back the lot.
- invalidate_lexicals() unless $skip_invalidate{$ppname};
- return $op->next;
-}
-
-sub compile_op {
- my $op = shift;
- my $ppname = "pp_" . $op->name;
- if (exists $ignore_op{$ppname}) {
- return $op->next;
- }
- debug peek_stack() if $debug_stack;
- if ($debug_op) {
- debug sprintf("%s [%s]\n",
- peekop($op),
- $op->flags & OPf_STACKED ? "OPf_STACKED" : $op->targ);
- }
- no strict 'refs';
- if (defined(&$ppname)) {
- $know_op = 0;
- return &$ppname($op);
- } else {
- return default_pp($op);
- }
-}
-
-sub compile_bblock {
- my $op = shift;
- #warn "compile_bblock: ", peekop($op), "\n"; # debug
- save_or_restore_lexical_state($$op);
- write_label($op);
- $know_op = 0;
- do {
- $op = compile_op($op);
- } while (defined($op) && $$op && !exists($leaders->{$$op}));
- write_back_stack(); # boo hoo: big loss
- reload_lexicals();
- return $op;
-}
-
-sub cc {
- my ($name, $root, $start, @padlist) = @_;
- my $op;
- if($done{$$start}){
- #warn "repeat=>".ref($start)."$name,\n";#debug
- $decl->add(sprintf("#define $name %s",$done{$$start}));
- return;
- }
- init_pp($name);
- load_pad(@padlist);
- %lexstate=();
- B::Pseudoreg->new_scope;
- @cxstack = ();
- if ($debug_timings) {
- warn sprintf("Basic block analysis at %s\n", timing_info);
- }
- $leaders = find_leaders($root, $start);
- my @leaders= keys %$leaders;
- if ($#leaders > -1) {
- @bblock_todo = ($start, values %$leaders) ;
- } else{
- runtime("return PL_op?PL_op->op_next:0;");
- }
- if ($debug_timings) {
- warn sprintf("Compilation at %s\n", timing_info);
- }
- while (@bblock_todo) {
- $op = shift @bblock_todo;
- #warn sprintf("Considering basic block %s\n", peekop($op)); # debug
- next if !defined($op) || !$$op || $done{$$op};
- #warn "...compiling it\n"; # debug
- do {
- $done{$$op} = $name;
- $op = compile_bblock($op);
- if ($need_freetmps && $freetmps_each_bblock) {
- runtime("FREETMPS;");
- $need_freetmps = 0;
- }
- } while defined($op) && $$op && !$done{$$op};
- if ($need_freetmps && $freetmps_each_loop) {
- runtime("FREETMPS;");
- $need_freetmps = 0;
- }
- if (!$$op) {
- runtime("PUTBACK;","return PL_op;");
- } elsif ($done{$$op}) {
- save_or_restore_lexical_state($$op);
- runtime(sprintf("goto %s;", label($op)));
- }
- }
- if ($debug_timings) {
- warn sprintf("Saving runtime at %s\n", timing_info);
- }
- declare_pad(@padlist) ;
- save_runtime();
-}
-
-sub cc_recurse {
- my $ccinfo;
- my $start;
- $start = cc_queue(@_) if @_;
- while ($ccinfo = shift @cc_todo) {
- cc(@$ccinfo);
- }
- return $start;
-}
-
-sub cc_obj {
- my ($name, $cvref) = @_;
- my $cv = svref_2object($cvref);
- my @padlist = $cv->PADLIST->ARRAY;
- my $curpad_sym = $padlist[1]->save;
- cc_recurse($name, $cv->ROOT, $cv->START, @padlist);
-}
-
-sub cc_main {
- my @comppadlist = comppadlist->ARRAY;
- my $curpad_nam = $comppadlist[0]->save;
- my $curpad_sym = $comppadlist[1]->save;
- my $init_av = init_av->save;
- my $start = cc_recurse("pp_main", main_root, main_start, @comppadlist);
- # Do save_unused_subs before saving inc_hv
- save_unused_subs();
- cc_recurse();
-
- my $inc_hv = svref_2object(\%INC)->save;
- my $inc_av = svref_2object(\@INC)->save;
- my $amagic_generate= amagic_generation;
- return if $errors;
- if (!defined($module)) {
- $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
- "PL_main_start = $start;",
- "PL_curpad = AvARRAY($curpad_sym);",
- "PL_initav = (AV *) $init_av;",
- "GvHV(PL_incgv) = $inc_hv;",
- "GvAV(PL_incgv) = $inc_av;",
- "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
- "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
- "PL_amagic_generation= $amagic_generate;",
- );
-
- }
- seek(STDOUT,0,0); #prevent print statements from BEGIN{} into the output
- output_boilerplate();
- print "\n";
- output_all("perl_init");
- output_runtime();
- print "\n";
- output_main();
- if (defined($module)) {
- my $cmodule = $module;
- $cmodule =~ s/::/__/g;
- print <<"EOT";
-
-#include "XSUB.h"
-XS(boot_$cmodule)
-{
- dXSARGS;
- perl_init();
- ENTER;
- SAVETMPS;
- SAVEVPTR(PL_curpad);
- SAVEVPTR(PL_op);
- PL_curpad = AvARRAY($curpad_sym);
- PL_op = $start;
- pp_main(aTHX);
- FREETMPS;
- LEAVE;
- ST(0) = &PL_sv_yes;
- XSRETURN(1);
-}
-EOT
- }
- if ($debug_timings) {
- warn sprintf("Done at %s\n", timing_info);
- }
-}
-
-sub compile {
- my @options = @_;
- my ($option, $opt, $arg);
- OPTION:
- while ($option = shift @options) {
- if ($option =~ /^-(.)(.*)/) {
- $opt = $1;
- $arg = $2;
- } else {
- unshift @options, $option;
- last OPTION;
- }
- if ($opt eq "-" && $arg eq "-") {
- shift @options;
- last OPTION;
- } elsif ($opt eq "o") {
- $arg ||= shift @options;
- open(STDOUT, ">$arg") or return "open '>$arg': $!\n";
- } elsif ($opt eq "n") {
- $arg ||= shift @options;
- $module_name = $arg;
- } elsif ($opt eq "u") {
- $arg ||= shift @options;
- mark_unused($arg,undef);
- } elsif ($opt eq "f") {
- $arg ||= shift @options;
- my $value = $arg !~ s/^no-//;
- $arg =~ s/-/_/g;
- my $ref = $optimise{$arg};
- if (defined($ref)) {
- $$ref = $value;
- } else {
- warn qq(ignoring unknown optimisation option "$arg"\n);
- }
- } elsif ($opt eq "O") {
- $arg = 1 if $arg eq "";
- my $ref;
- foreach $ref (values %optimise) {
- $$ref = 0;
- }
- if ($arg >= 2) {
- $freetmps_each_loop = 1;
- }
- if ($arg >= 1) {
- $freetmps_each_bblock = 1 unless $freetmps_each_loop;
- }
- } elsif ($opt eq "m") {
- $arg ||= shift @options;
- $module = $arg;
- mark_unused($arg,undef);
- } elsif ($opt eq "p") {
- $arg ||= shift @options;
- $patchlevel = $arg;
- } elsif ($opt eq "D") {
- $arg ||= shift @options;
- foreach $arg (split(//, $arg)) {
- if ($arg eq "o") {
- B->debug(1);
- } elsif ($arg eq "O") {
- $debug_op = 1;
- } elsif ($arg eq "s") {
- $debug_stack = 1;
- } elsif ($arg eq "c") {
- $debug_cxstack = 1;
- } elsif ($arg eq "p") {
- $debug_pad = 1;
- } elsif ($arg eq "r") {
- $debug_runtime = 1;
- } elsif ($arg eq "S") {
- $debug_shadow = 1;
- } elsif ($arg eq "q") {
- $debug_queue = 1;
- } elsif ($arg eq "l") {
- $debug_lineno = 1;
- } elsif ($arg eq "t") {
- $debug_timings = 1;
- }
- }
- }
- }
- init_sections();
- $init = B::Section->get("init");
- $decl = B::Section->get("decl");
-
- if (@options) {
- return sub {
- my ($objname, $ppname);
- foreach $objname (@options) {
- $objname = "main::$objname" unless $objname =~ /::/;
- ($ppname = $objname) =~ s/^.*?:://;
- eval "cc_obj(qq(pp_sub_$ppname), \\&$objname)";
- die "cc_obj(qq(pp_sub_$ppname, \\&$objname) failed: $@" if $@;
- return if $errors;
- }
- output_boilerplate();
- print "\n";
- output_all($module_name || "init_module");
- output_runtime();
- }
- } else {
- return sub { cc_main() };
- }
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-B::CC - Perl compiler's optimized C translation backend
-
-=head1 SYNOPSIS
-
- perl -MO=CC[,OPTIONS] foo.pl
-
-=head1 DESCRIPTION
-
-This compiler backend takes Perl source and generates C source code
-corresponding to the flow of your program. In other words, this
-backend is somewhat a "real" compiler in the sense that many people
-think about compilers. Note however that, currently, it is a very
-poor compiler in that although it generates (mostly, or at least
-sometimes) correct code, it performs relatively few optimisations.
-This will change as the compiler develops. The result is that
-running an executable compiled with this backend may start up more
-quickly than running the original Perl program (a feature shared
-by the B<C> compiler backend--see F<B::C>) and may also execute
-slightly faster. This is by no means a good optimising compiler--yet.
-
-=head1 OPTIONS
-
-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.
-
-=over 4
-
-=item B<-ofilename>
-
-Output to filename instead of STDOUT
-
-=item B<-v>
-
-Verbose compilation (currently gives a few compilation statistics).
-
-=item B<-->
-
-Force end of options
-
-=item B<-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 C<$SIG{BAR} = "foo">. A better fix, though, is just
-to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
-options. The compiler tries to figure out which packages may possibly
-have subs in which need compiling but the current version doesn't do
-it very well. In particular, it is confused by nested packages (i.e.
-of the form C<A::B>) where package C<A> does not contain any subs.
-
-=item B<-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.
-
-
-=item B<-D>
-
-Debug options (concatenated or separate flags like C<perl -D>).
-
-=item B<-Dr>
-
-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).
-
-=item B<-DO>
-
-Outputs each OP as it's compiled
-
-=item B<-Ds>
-
-Outputs the contents of the shadow stack at each OP
-
-=item B<-Dp>
-
-Outputs the contents of the shadow pad of lexicals as it's loaded for
-each sub or the main program.
-
-=item B<-Dq>
-
-Outputs the name of each fake PP function in the queue as it's about
-to process it.
-
-=item B<-Dl>
-
-Output the filename and line number of each original line of Perl
-code as it's processed (C<pp_nextstate>).
-
-=item B<-Dt>
-
-Outputs timing information of compilation stages.
-
-=item B<-f>
-
-Force optimisations on or off one at a time.
-
-=item B<-ffreetmps-each-bblock>
-
-Delays FREETMPS from the end of each statement to the end of the each
-basic block.
-
-=item B<-ffreetmps-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.
-
-=item B<-fomit-taint>
-
-Omits generating code for handling perl's tainting mechanism.
-
-=item B<-On>
-
-Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.
-Currently, B<-O1> sets B<-ffreetmps-each-bblock> and B<-O2>
-sets B<-ffreetmps-each-loop>.
-
-=back
-
-=head1 EXAMPLES
-
- perl -MO=CC,-O2,-ofoo.c foo.pl
- perl cc_harness -o foo foo.c
-
-Note that C<cc_harness> lives in the C<B> subdirectory of your perl
-library directory. The utility called C<perlcc> may also be used to
-help make use of this compiler.
-
- perl -MO=CC,-mFoo,-oFoo.c Foo.pm
- perl cc_harness -shared -c -o Foo.so Foo.c
-
-=head1 BUGS
-
-Plenty. Current status: experimental.
-
-=head1 DIFFERENCES
-
-These aren't really bugs but they are constructs which are heavily
-tied to perl's compile-and-go implementation and with which this
-compiler backend cannot cope.
-
-=head2 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.
-
-=head2 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.
-
-=head2 Arithmetic
-
-Compiled Perl programs use native C arithmetic much more frequently
-than standard perl. Operations on large numbers or on boundary
-cases may produce different behaviour.
-
-=head2 Deprecated features
-
-Features of standard perl such as C<$[> which have been deprecated
-in standard perl since Perl5 was released have not been implemented
-in the compiler.
-
-=head1 AUTHOR
-
-Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
-
-=cut
+++ /dev/null
-# Disassembler.pm
-#
-# Copyright (c) 1996 Malcolm Beattie
-#
-# You may distribute under the terms of either the GNU General Public
-# License or the Artistic License, as specified in the README file.
-
-$B::Disassembler::VERSION = '1.05';
-
-package B::Disassembler::BytecodeStream;
-
-use FileHandle;
-use Carp;
-use Config qw(%Config);
-use B qw(cstring cast_I32);
-@ISA = qw(FileHandle);
-sub readn {
- my ($fh, $len) = @_;
- my $data;
- read($fh, $data, $len);
- croak "reached EOF while reading $len bytes" unless length($data) == $len;
- return $data;
-}
-
-sub GET_U8 {
- my $fh = shift;
- my $c = $fh->getc;
- croak "reached EOF while reading U8" unless defined($c);
- return ord($c);
-}
-
-sub GET_U16 {
- my $fh = shift;
- my $str = $fh->readn(2);
- croak "reached EOF while reading U16" unless length($str) == 2;
- return unpack("S", $str);
-}
-
-sub GET_NV {
- my $fh = shift;
- my ($str, $c);
- while (defined($c = $fh->getc) && $c ne "\0") {
- $str .= $c;
- }
- croak "reached EOF while reading double" unless defined($c);
- return $str;
-}
-
-sub GET_U32 {
- my $fh = shift;
- my $str = $fh->readn(4);
- croak "reached EOF while reading U32" unless length($str) == 4;
- return unpack("L", $str);
-}
-
-sub GET_I32 {
- my $fh = shift;
- my $str = $fh->readn(4);
- croak "reached EOF while reading I32" unless length($str) == 4;
- return unpack("l", $str);
-}
-
-sub GET_objindex {
- my $fh = shift;
- my $str = $fh->readn(4);
- croak "reached EOF while reading objindex" unless length($str) == 4;
- return unpack("L", $str);
-}
-
-sub GET_opindex {
- my $fh = shift;
- my $str = $fh->readn(4);
- croak "reached EOF while reading opindex" unless length($str) == 4;
- return unpack("L", $str);
-}
-
-sub GET_svindex {
- my $fh = shift;
- my $str = $fh->readn(4);
- croak "reached EOF while reading svindex" unless length($str) == 4;
- return unpack("L", $str);
-}
-
-sub GET_pvindex {
- my $fh = shift;
- my $str = $fh->readn(4);
- croak "reached EOF while reading pvindex" unless length($str) == 4;
- return unpack("L", $str);
-}
-
-sub GET_strconst {
- my $fh = shift;
- my ($str, $c);
- $str = '';
- while (defined($c = $fh->getc) && $c ne "\0") {
- $str .= $c;
- }
- croak "reached EOF while reading strconst" unless defined($c);
- return cstring($str);
-}
-
-sub GET_pvcontents {}
-
-sub GET_PV {
- my $fh = shift;
- my $str;
- my $len = $fh->GET_U32;
- if ($len) {
- read($fh, $str, $len);
- croak "reached EOF while reading PV" unless length($str) == $len;
- return cstring($str);
- } else {
- return '""';
- }
-}
-
-sub GET_comment_t {
- my $fh = shift;
- my ($str, $c);
- while (defined($c = $fh->getc) && $c ne "\n") {
- $str .= $c;
- }
- croak "reached EOF while reading comment" unless defined($c);
- return cstring($str);
-}
-
-sub GET_double {
- my $fh = shift;
- my ($str, $c);
- while (defined($c = $fh->getc) && $c ne "\0") {
- $str .= $c;
- }
- croak "reached EOF while reading double" unless defined($c);
- return $str;
-}
-
-sub GET_none {}
-
-sub GET_op_tr_array {
- my $fh = shift;
- my $len = unpack "S", $fh->readn(2);
- my @ary = unpack "S*", $fh->readn($len*2);
- return join(",", $len, @ary);
-}
-
-sub GET_IV64 {
- my $fh = shift;
- my $str = $fh->readn(8);
- croak "reached EOF while reading I32" unless length($str) == 8;
- return sprintf "0x%09llx", unpack("q", $str);
-}
-
-sub GET_IV {
- $Config{ivsize} == 4 ? &GET_I32 : &GET_IV64;
-}
-
-sub GET_PADOFFSET {
- $Config{ptrsize} == 8 ? &GET_IV64 : &GET_U32;
-}
-
-sub GET_long {
- $Config{longsize} == 8 ? &GET_IV64 : &GET_U32;
-}
-
-
-package B::Disassembler;
-use Exporter;
-@ISA = qw(Exporter);
-@EXPORT_OK = qw(disassemble_fh get_header);
-use Carp;
-use strict;
-
-use B::Asmdata qw(%insn_data @insn_name);
-
-our( $magic, $archname, $blversion, $ivsize, $ptrsize );
-
-sub dis_header($){
- my( $fh ) = @_;
- $magic = $fh->GET_U32();
- warn( "bad magic" ) if $magic != 0x43424c50;
- $archname = $fh->GET_strconst();
- $blversion = $fh->GET_strconst();
- $ivsize = $fh->GET_U32();
- $ptrsize = $fh->GET_U32();
-}
-
-sub get_header(){
- return( $magic, $archname, $blversion, $ivsize, $ptrsize);
-}
-
-sub disassemble_fh {
- my ($fh, $out) = @_;
- my ($c, $getmeth, $insn, $arg);
- bless $fh, "B::Disassembler::BytecodeStream";
- dis_header( $fh );
- while (defined($c = $fh->getc)) {
- $c = ord($c);
- $insn = $insn_name[$c];
- if (!defined($insn) || $insn eq "unused") {
- my $pos = $fh->tell - 1;
- die "Illegal instruction code $c at stream offset $pos\n";
- }
- $getmeth = $insn_data{$insn}->[2];
- $arg = $fh->$getmeth();
- if (defined($arg)) {
- &$out($insn, $arg);
- } else {
- &$out($insn);
- }
- }
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-B::Disassembler - Disassemble Perl bytecode
-
-=head1 SYNOPSIS
-
- use Disassembler;
-
-=head1 DESCRIPTION
-
-See F<ext/B/B/Disassembler.pm>.
-
-=head1 AUTHOR
-
-Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
-
-=cut
+++ /dev/null
-# Stackobj.pm
-#
-# Copyright (c) 1996 Malcolm Beattie
-#
-# You may distribute under the terms of either the GNU General Public
-# License or the Artistic License, as specified in the README file.
-#
-package B::Stackobj;
-
-our $VERSION = '1.00';
-
-use Exporter ();
-@ISA = qw(Exporter);
-@EXPORT_OK = qw(set_callback T_UNKNOWN T_DOUBLE T_INT VALID_UNSIGNED
- VALID_INT VALID_DOUBLE VALID_SV REGISTER TEMPORARY);
-%EXPORT_TAGS = (types => [qw(T_UNKNOWN T_DOUBLE T_INT)],
- flags => [qw(VALID_INT VALID_DOUBLE VALID_SV
- VALID_UNSIGNED REGISTER TEMPORARY)]);
-
-use Carp qw(confess);
-use strict;
-use B qw(class SVf_IOK SVf_NOK SVf_IVisUV);
-
-# Types
-sub T_UNKNOWN () { 0 }
-sub T_DOUBLE () { 1 }
-sub T_INT () { 2 }
-sub T_SPECIAL () { 3 }
-
-# Flags
-sub VALID_INT () { 0x01 }
-sub VALID_UNSIGNED () { 0x02 }
-sub VALID_DOUBLE () { 0x04 }
-sub VALID_SV () { 0x08 }
-sub REGISTER () { 0x10 } # no implicit write-back when calling subs
-sub TEMPORARY () { 0x20 } # no implicit write-back needed at all
-sub SAVE_INT () { 0x40 } #if int part needs to be saved at all
-sub SAVE_DOUBLE () { 0x80 } #if double part needs to be saved at all
-
-
-#
-# Callback for runtime code generation
-#
-my $runtime_callback = sub { confess "set_callback not yet called" };
-sub set_callback (&) { $runtime_callback = shift }
-sub runtime { &$runtime_callback(@_) }
-
-#
-# Methods
-#
-
-sub write_back { confess "stack object does not implement write_back" }
-
-sub invalidate { shift->{flags} &= ~(VALID_INT |VALID_UNSIGNED | VALID_DOUBLE) }
-
-sub as_sv {
- my $obj = shift;
- if (!($obj->{flags} & VALID_SV)) {
- $obj->write_back;
- $obj->{flags} |= VALID_SV;
- }
- return $obj->{sv};
-}
-
-sub as_int {
- my $obj = shift;
- if (!($obj->{flags} & VALID_INT)) {
- $obj->load_int;
- $obj->{flags} |= VALID_INT|SAVE_INT;
- }
- return $obj->{iv};
-}
-
-sub as_double {
- my $obj = shift;
- if (!($obj->{flags} & VALID_DOUBLE)) {
- $obj->load_double;
- $obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE;
- }
- return $obj->{nv};
-}
-
-sub as_numeric {
- my $obj = shift;
- return $obj->{type} == T_INT ? $obj->as_int : $obj->as_double;
-}
-
-sub as_bool {
- my $obj=shift;
- if ($obj->{flags} & VALID_INT ){
- return $obj->{iv};
- }
- if ($obj->{flags} & VALID_DOUBLE ){
- return $obj->{nv};
- }
- return sprintf("(SvTRUE(%s))", $obj->as_sv) ;
-}
-
-#
-# Debugging methods
-#
-sub peek {
- my $obj = shift;
- my $type = $obj->{type};
- my $flags = $obj->{flags};
- my @flags;
- if ($type == T_UNKNOWN) {
- $type = "T_UNKNOWN";
- } elsif ($type == T_INT) {
- $type = "T_INT";
- } elsif ($type == T_DOUBLE) {
- $type = "T_DOUBLE";
- } else {
- $type = "(illegal type $type)";
- }
- push(@flags, "VALID_INT") if $flags & VALID_INT;
- push(@flags, "VALID_DOUBLE") if $flags & VALID_DOUBLE;
- push(@flags, "VALID_SV") if $flags & VALID_SV;
- push(@flags, "REGISTER") if $flags & REGISTER;
- push(@flags, "TEMPORARY") if $flags & TEMPORARY;
- @flags = ("none") unless @flags;
- return sprintf("%s type=$type flags=%s sv=$obj->{sv}",
- class($obj), join("|", @flags));
-}
-
-sub minipeek {
- my $obj = shift;
- my $type = $obj->{type};
- my $flags = $obj->{flags};
- if ($type == T_INT || $flags & VALID_INT) {
- return $obj->{iv};
- } elsif ($type == T_DOUBLE || $flags & VALID_DOUBLE) {
- return $obj->{nv};
- } else {
- return $obj->{sv};
- }
-}
-
-#
-# Caller needs to ensure that set_int, set_double,
-# set_numeric and set_sv are only invoked on legal lvalues.
-#
-sub set_int {
- my ($obj, $expr,$unsigned) = @_;
- runtime("$obj->{iv} = $expr;");
- $obj->{flags} &= ~(VALID_SV | VALID_DOUBLE);
- $obj->{flags} |= VALID_INT|SAVE_INT;
- $obj->{flags} |= VALID_UNSIGNED if $unsigned;
-}
-
-sub set_double {
- my ($obj, $expr) = @_;
- runtime("$obj->{nv} = $expr;");
- $obj->{flags} &= ~(VALID_SV | VALID_INT);
- $obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE;
-}
-
-sub set_numeric {
- my ($obj, $expr) = @_;
- if ($obj->{type} == T_INT) {
- $obj->set_int($expr);
- } else {
- $obj->set_double($expr);
- }
-}
-
-sub set_sv {
- my ($obj, $expr) = @_;
- runtime("SvSetSV($obj->{sv}, $expr);");
- $obj->invalidate;
- $obj->{flags} |= VALID_SV;
-}
-
-#
-# Stackobj::Padsv
-#
-
-@B::Stackobj::Padsv::ISA = 'B::Stackobj';
-sub B::Stackobj::Padsv::new {
- my ($class, $type, $extra_flags, $ix, $iname, $dname) = @_;
- $extra_flags |= SAVE_INT if $extra_flags & VALID_INT;
- $extra_flags |= SAVE_DOUBLE if $extra_flags & VALID_DOUBLE;
- bless {
- type => $type,
- flags => VALID_SV | $extra_flags,
- sv => "PL_curpad[$ix]",
- iv => "$iname",
- nv => "$dname"
- }, $class;
-}
-
-sub B::Stackobj::Padsv::load_int {
- my $obj = shift;
- if ($obj->{flags} & VALID_DOUBLE) {
- runtime("$obj->{iv} = $obj->{nv};");
- } else {
- runtime("$obj->{iv} = SvIV($obj->{sv});");
- }
- $obj->{flags} |= VALID_INT|SAVE_INT;
-}
-
-sub B::Stackobj::Padsv::load_double {
- my $obj = shift;
- $obj->write_back;
- runtime("$obj->{nv} = SvNV($obj->{sv});");
- $obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE;
-}
-sub B::Stackobj::Padsv::save_int {
- my $obj = shift;
- return $obj->{flags} & SAVE_INT;
-}
-
-sub B::Stackobj::Padsv::save_double {
- my $obj = shift;
- return $obj->{flags} & SAVE_DOUBLE;
-}
-
-sub B::Stackobj::Padsv::write_back {
- my $obj = shift;
- my $flags = $obj->{flags};
- return if $flags & VALID_SV;
- if ($flags & VALID_INT) {
- if ($flags & VALID_UNSIGNED ){
- runtime("sv_setuv($obj->{sv}, $obj->{iv});");
- }else{
- runtime("sv_setiv($obj->{sv}, $obj->{iv});");
- }
- } elsif ($flags & VALID_DOUBLE) {
- runtime("sv_setnv($obj->{sv}, $obj->{nv});");
- } else {
- confess "write_back failed for lexical @{[$obj->peek]}\n";
- }
- $obj->{flags} |= VALID_SV;
-}
-
-#
-# Stackobj::Const
-#
-
-@B::Stackobj::Const::ISA = 'B::Stackobj';
-sub B::Stackobj::Const::new {
- my ($class, $sv) = @_;
- my $obj = bless {
- flags => 0,
- sv => $sv # holds the SV object until write_back happens
- }, $class;
- if ( ref($sv) eq "B::SPECIAL" ){
- $obj->{type}= T_SPECIAL;
- }else{
- my $svflags = $sv->FLAGS;
- if ($svflags & SVf_IOK) {
- $obj->{flags} = VALID_INT|VALID_DOUBLE;
- $obj->{type} = T_INT;
- if ($svflags & SVf_IVisUV){
- $obj->{flags} |= VALID_UNSIGNED;
- $obj->{nv} = $obj->{iv} = $sv->UVX;
- }else{
- $obj->{nv} = $obj->{iv} = $sv->IV;
- }
- } elsif ($svflags & SVf_NOK) {
- $obj->{flags} = VALID_INT|VALID_DOUBLE;
- $obj->{type} = T_DOUBLE;
- $obj->{iv} = $obj->{nv} = $sv->NV;
- } else {
- $obj->{type} = T_UNKNOWN;
- }
- }
- return $obj;
-}
-
-sub B::Stackobj::Const::write_back {
- my $obj = shift;
- return if $obj->{flags} & VALID_SV;
- # Save the SV object and replace $obj->{sv} by its C source code name
- $obj->{sv} = $obj->{sv}->save;
- $obj->{flags} |= VALID_SV|VALID_INT|VALID_DOUBLE;
-}
-
-sub B::Stackobj::Const::load_int {
- my $obj = shift;
- if (ref($obj->{sv}) eq "B::RV"){
- $obj->{iv} = int($obj->{sv}->RV->PV);
- }else{
- $obj->{iv} = int($obj->{sv}->PV);
- }
- $obj->{flags} |= VALID_INT;
-}
-
-sub B::Stackobj::Const::load_double {
- my $obj = shift;
- if (ref($obj->{sv}) eq "B::RV"){
- $obj->{nv} = $obj->{sv}->RV->PV + 0.0;
- }else{
- $obj->{nv} = $obj->{sv}->PV + 0.0;
- }
- $obj->{flags} |= VALID_DOUBLE;
-}
-
-sub B::Stackobj::Const::invalidate {}
-
-#
-# Stackobj::Bool
-#
-
-@B::Stackobj::Bool::ISA = 'B::Stackobj';
-sub B::Stackobj::Bool::new {
- my ($class, $preg) = @_;
- my $obj = bless {
- type => T_INT,
- flags => VALID_INT|VALID_DOUBLE,
- iv => $$preg,
- nv => $$preg,
- preg => $preg # this holds our ref to the pseudo-reg
- }, $class;
- return $obj;
-}
-
-sub B::Stackobj::Bool::write_back {
- my $obj = shift;
- return if $obj->{flags} & VALID_SV;
- $obj->{sv} = "($obj->{iv} ? &PL_sv_yes : &PL_sv_no)";
- $obj->{flags} |= VALID_SV;
-}
-
-# XXX Might want to handle as_double/set_double/load_double?
-
-sub B::Stackobj::Bool::invalidate {}
-
-1;
-
-__END__
-
-=head1 NAME
-
-B::Stackobj - Helper module for CC backend
-
-=head1 SYNOPSIS
-
- use B::Stackobj;
-
-=head1 DESCRIPTION
-
-See F<ext/B/README>.
-
-=head1 AUTHOR
-
-Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
-
-=cut
+++ /dev/null
-# Stash.pm -- show what stashes are loaded
-# vishalb@hotmail.com
-package B::Stash;
-
-our $VERSION = '1.00';
-
-=pod
-
-=head1 NAME
-
-B::Stash - show what stashes are loaded
-
-=cut
-
-BEGIN { %Seen = %INC }
-
-CHECK {
- my @arr=scan($main::{"main::"});
- @arr=map{s/\:\:$//;$_ eq "<none>"?():$_;} @arr;
- print "-umain,-u", join (",-u",@arr) ,"\n";
-}
-sub scan{
- my $start=shift;
- my $prefix=shift;
- $prefix = '' unless defined $prefix;
- my @return;
- foreach my $key ( keys %{$start}){
-# print $prefix,$key,"\n";
- if ($key =~ /::$/){
- unless ($start eq ${$start}{$key} or $key eq "B::" ){
- push @return, $key unless omit($prefix.$key);
- foreach my $subscan ( scan(${$start}{$key},$prefix.$key)){
- push @return, "$key".$subscan;
- }
- }
- }
- }
- return @return;
-}
-sub omit{
- my $module = shift;
- my %omit=("DynaLoader::" => 1 , "XSLoader::" => 1, "CORE::" => 1 ,
- "CORE::GLOBAL::" => 1, "UNIVERSAL::" => 1 );
- return 1 if $omit{$module};
- if ($module eq "IO::" or $module eq "IO::Handle::"){
- $module =~ s/::/\//g;
- return 1 unless $INC{$module};
- }
-
- return 0;
-}
-1;
+++ /dev/null
-use B::Assembler qw(assemble_fh);
-use FileHandle;
-
-my ($filename, $fh, $out);
-
-if ($ARGV[0] eq "-d") {
- B::Assembler::debug(1);
- shift;
-}
-
-$out = \*STDOUT;
-
-if (@ARGV == 0) {
- $fh = \*STDIN;
- $filename = "-";
-} elsif (@ARGV == 1) {
- $filename = $ARGV[0];
- $fh = new FileHandle "<$filename";
-} elsif (@ARGV == 2) {
- $filename = $ARGV[0];
- $fh = new FileHandle "<$filename";
- $out = new FileHandle ">$ARGV[1]";
-} else {
- die "Usage: assemble [filename] [outfilename]\n";
-}
-
-binmode $out;
-$SIG{__WARN__} = sub { warn "$filename:@_" };
-$SIG{__DIE__} = sub { die "$filename: @_" };
-assemble_fh($fh, sub { print $out @_ });
+++ /dev/null
-use Config;
-
-$libdir = $ENV{PERL_SRC} || "$Config{installarchlib}/CORE";
-
-if (!grep(/^-[cS]$/, @ARGV)) {
- $linkargs = sprintf("%s $libdir/$Config{libperl} %s",
- @Config{qw(ldflags libs)});
-}
-
-$cccmd = "$Config{cc} $Config{ccflags} -I$libdir @ARGV $linkargs";
-print "$cccmd\n";
-exec $cccmd;
+++ /dev/null
-use B::Disassembler qw(disassemble_fh);
-use FileHandle;
-
-my $fh;
-if (@ARGV == 0) {
- $fh = \*STDIN;
-} elsif (@ARGV == 1) {
- $fh = new FileHandle "<$ARGV[0]";
-} else {
- die "Usage: disassemble [filename]\n";
-}
-
-sub print_insn {
- my ($insn, $arg) = @_;
- if (defined($arg)) {
- printf "%s %s\n", $insn, $arg;
- } else {
- print $insn, "\n";
- }
-}
-
-disassemble_fh($fh, \&print_insn);
+++ /dev/null
-use File::Find;
-use Config;
-
-if (@ARGV != 2) {
- warn <<"EOT";
-Usage: makeliblinks libautodir targetdir
-where libautodir is the architecture-dependent auto directory
-(e.g. $Config::Config{archlib}/auto).
-EOT
- exit 2;
-}
-
-my ($libautodir, $targetdir) = @ARGV;
-
-# Calculate relative path prefix from $targetdir to $libautodir
-sub relprefix {
- my ($to, $from) = @_;
- my $up;
- for ($up = 0; substr($to, 0, length($from)) ne $from; $up++) {
- $from =~ s(
- [^/]+ (?# a group of non-slashes)
- /* (?# maybe with some trailing slashes)
- $ (?# at the end of the path)
- )()x;
- }
- return (("../" x $up) . substr($to, length($from)));
-}
-
-my $relprefix = relprefix($libautodir, $targetdir);
-
-my ($dlext, $lib_ext) = @Config::Config{qw(dlext lib_ext)};
-
-sub link_if_library {
- if (/\.($dlext|$lib_ext)$/o) {
- my $ext = $1;
- my $name = $File::Find::name;
- if (substr($name, 0, length($libautodir) + 1) ne "$libautodir/") {
- die "directory of $name doesn't match $libautodir\n";
- }
- substr($name, 0, length($libautodir) + 1) = '';
- my @parts = split(m(/), $name);
- if ($parts[-1] ne "$parts[-2].$ext") {
- die "module name $_ doesn't match its directory $libautodir\n";
- }
- pop @parts;
- my $libpath = "$targetdir/lib" . join("__", @parts) . ".$ext";
- print "$libpath -> $relprefix/$name\n";
- symlink("$relprefix/$name", $libpath)
- or warn "above link failed with error: $!\n";
- }
-}
-
-find(\&link_if_library, $libautodir);
-exit 0;
+++ /dev/null
-#include <EXTERN.h>
-#include <perl.h>
-#include <XSUB.h>
-
-static int
-my_runops(pTHX)
-{
- HV* regexp_hv = get_hv( "B::C::REGEXP", 0 );
- SV* key = newSViv( 0 );
-
- do {
- PERL_ASYNC_CHECK();
-
- if( PL_op->op_type == OP_QR ) {
- PMOP* op;
- REGEXP* rx = PM_GETRE( (PMOP*)PL_op );
- SV* rv = newSViv( 0 );
-
- Newx( op, 1, PMOP );
- Copy( PL_op, op, 1, PMOP );
- /* we need just the flags */
- op->op_next = NULL;
- op->op_sibling = NULL;
- op->op_first = NULL;
- op->op_last = NULL;
- op->op_pmreplroot = NULL;
- op->op_pmreplstart = NULL;
- op->op_pmnext = NULL;
-#ifdef USE_ITHREADS
- op->op_pmoffset = 0;
-#else
- op->op_pmregexp = 0;
-#endif
-
- sv_setiv( key, PTR2IV( rx ) );
- sv_setref_iv( rv, "B::PMOP", PTR2IV( op ) );
-
- hv_store_ent( regexp_hv, key, rv, 0 );
- }
- } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
-
- SvREFCNT_dec( key );
-
- TAINT_NOT;
- return 0;
-}
-
-MODULE=B__C PACKAGE=B::C
-
-PROTOTYPES: DISABLE
-
-BOOT:
- PL_runops = my_runops;
+++ /dev/null
-#!perl
-
-use ExtUtils::MakeMaker;
-
-WriteMakefile( NAME => 'B::C',
- VERSION_FROM => '../B/C.pm'
- );
-
+++ /dev/null
-C backend invocation
- If there are any non-option arguments, they are taken to be
- names of objects to be saved (probably doesn't work properly yet).
- Without extra arguments, it saves the main program.
- -ofilename Output to filename instead of STDOUT
- -v Verbose (currently gives a few compilation statistics)
- -- Force end of options
- -uPackname Force apparently unused subs from package Packname to
- be compiled. This allows programs to use eval "foo()"
- even when sub foo is never seen to be used at compile
- time. The down side is that any subs which really are
- never used also have code generated. This option is
- necessary, for example, if you have a signal handler
- foo which you initialise with $SIG{BAR} = "foo".
- A better fix, though, is just to change it to
- $SIG{BAR} = \&foo. You can have multiple -u options.
- -D Debug options (concat or separate flags like perl -D)
- o OPs, prints each OP as it's processed
- c COPs, prints COPs as processed (incl. file & line num)
- A prints AV information on saving
- C prints CV information on saving
- M prints MAGIC information on saving
- -f Force optimisations on or off one at a time.
- cog Copy-on-grow: PVs declared and initialised statically
- no-cog No copy-on-grow
- -On Optimisation level (n = 0, 1, 2, ...). -O means -O1.
- Currently, -O1 and higher set -fcog.
-
-Examples
- perl -MO=C foo.pl > foo.c
- perl cc_harness -o foo foo.c
-
- perl -MO=C,-v,-DcA bar.pl > /dev/null
-
-CC backend invocation
- If there are any non-option arguments, they are taken to be names of
- subs to be saved. Without extra arguments, it saves the main program.
- -ofilename Output to filename instead of STDOUT
- -- Force end of options
- -uPackname Force apparently unused subs from package Packname to
- be compiled. This allows programs to use eval "foo()"
- even when sub foo is never seen to be used at compile
- time. The down side is that any subs which really are
- never used also have code generated. This option is
- necessary, for example, if you have a signal handler
- foo which you initialise with $SIG{BAR} = "foo".
- A better fix, though, is just to change it to
- $SIG{BAR} = \&foo. You can have multiple -u options.
- -mModulename Instead of generating source for a runnable executable,
- generate source for an XSUB module. The
- boot_Modulename function (which DynaLoader can look
- for) does the appropriate initialisation and runs the
- main part of the Perl source that is being compiled.
- -pn Generate code for perl patchlevel n (e.g. 3 or 4).
- The default is to generate C code which will link
- with the currently executing version of perl.
- running the perl compiler.
- -D Debug options (concat or separate flags like perl -D)
- r Writes debugging output to STDERR just as it's about
- to write to the program's runtime (otherwise writes
- debugging info as comments in its C output).
- O Outputs each OP as it's compiled
- s Outputs the contents of the shadow stack at each OP
- p Outputs the contents of the shadow pad of lexicals as
- it's loaded for each sub or the main program.
- q Outputs the name of each fake PP function in the queue
- as it's about to processes.
- l Output the filename and line number of each original
- line of Perl code as it's processed (pp_nextstate).
- t Outputs timing information of compilation stages
- -f Force optimisations on or off one at a time.
- [
- cog Copy-on-grow: PVs declared and initialised statically
- no-cog No copy-on-grow
- These two not in CC yet.
- ]
- freetmps-each-bblock Delays FREETMPS from the end of each
- statement to the end of the each basic
- block.
- freetmps-each-loop Delays FREETMPS from the end of each
- statement to the end of the group of
- basic blocks forming a loop. At most
- one of the freetmps-each-* options can
- be used.
- omit-taint Omits generating code for handling
- perl's tainting mechanism.
- -On Optimisation level (n = 0, 1, 2, ...). -O means -O1.
- Currently, -O1 sets -ffreetmps-each-bblock and -O2
- sets -ffreetmps-each-loop.
-
-Example
- perl -MO=CC,-O2,-ofoo.c foo.pl
- perl cc_harness -o foo foo.c
-
- perl -MO=CC,-mFoo,-oFoo.c Foo.pm
- perl cc_harness -shared -c -o Foo.so Foo.c
-
-
-Bytecode backend invocation
-
- If there are any non-option arguments, they are taken to be
- names of objects to be saved (probably doesn't work properly yet).
- Without extra arguments, it saves the main program.
- -ofilename Output to filename instead of STDOUT.
- -- Force end of options.
- -f Force optimisations on or off one at a time.
- Each can be preceded by no- to turn the option off.
- compress-nullops
- Only fills in the necessary fields of ops which have
- been optimised away by perl's internal compiler.
- omit-sequence-numbers
- Leaves out code to fill in the op_seq field of all ops
- which is only used by perl's internal compiler.
- bypass-nullops
- If op->op_next ever points to a NULLOP, replaces the
- op_next field with the first non-NULLOP in the path
- of execution.
- strip-syntax-tree
- Leaves out code to fill in the pointers which link the
- internal syntax tree together. They're not needed at
- run-time but leaving them out will make it impossible
- to recompile or disassemble the resulting program.
- It will also stop "goto label" statements from working.
- -On Optimisation level (n = 0, 1, 2, ...). -O means -O1.
- -O1 sets -fcompress-nullops -fomit-sequence numbers.
- -O6 adds -fstrip-syntax-tree.
- -D Debug options (concat or separate flags like perl -D)
- o OPs, prints each OP as it's processed.
- b print debugging information about bytecompiler progress
- a tells the assembler to include source assembler lines
- in its output as bytecode comments.
- C prints each CV taken from the final symbol tree walk.
- -S Output assembler source rather than piping it
- through the assembler and outputting bytecode.
- -m Compile as a module rather than a standalone program.
- Currently this just means that the bytecodes for
- initialising main_start, main_root and curpad are
- omitted.
-
-Example
- perl -MO=Bytecode,-O6,-o,foo.plc foo.pl
-
- perl -MO=Bytecode,-S foo.pl > foo.S
- assemble foo.S > foo.plc
- byteperl foo.plc
-
- perl -MO=Bytecode,-m,-oFoo.pmc Foo.pm
-
-Backends for debugging
- perl -MO=Terse,exec foo.pl
- perl -MO=Debug bar.pl
-
-O module
- Used with "perl -MO=Backend,foo,bar prog.pl" to invoke the backend
- B::Backend with options foo and bar. O invokes the sub
- B::Backend::compile() with arguments foo and bar at BEGIN time.
- That compile() sub must do any inital argument processing replied.
- If unsuccessful, it should return a string which O arranges to be
- printed as an error message followed by a clean error exit. In the
- normal case where any option processing in compile() is successful,
- it should return a sub ref (usually a closure) to perform the
- actual compilation. When O regains control, it ensures that the
- "-c" option is forced (so that the program being compiled doesn't
- end up running) and registers a CHECK 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 CHECK block
- of O gets called and the actual backend compilation happens. Phew.
+++ /dev/null
- Perl Compiler Kit, Version alpha4
-
- Copyright (c) 1996, 1997, Malcolm Beattie
-
- This program is free software; you can redistribute it and/or modify
- it under the terms of either:
-
- a) the GNU General Public License as published by the Free
- Software Foundation; either version 1, or (at your option) any
- later version, or
-
- b) the "Artistic License" which comes with this kit.
-
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either
- the GNU General Public License or the Artistic License for more details.
-
- You should have received a copy of the Artistic License with this kit,
- in the file named "Artistic". If not, you can get one from the Perl
- distribution. You should also have received a copy of the GNU General
- Public License, in the file named "Copying". If not, you can get one
- from the Perl distribution or else write to the Free Software Foundation,
- Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
-
-CHANGES
-
-New since alpha3
- Anonymous subs work properly with C and CC.
- Heuristics for forcing compilation of apparently unused subs/methods.
- Subs which use the AutoLoader module are forcibly loaded at compile-time.
- Slightly faster compilation.
- Handles slightly more complex code within a BEGIN { }.
- Minor bug fixes.
-
-New since alpha2
- CC backend now supports ".." and s//e.
- Xref backend generates cross-reference reports
- Cleanups to fix benign but irritating "-w" warnings
- Minor cxstack fix
-New since alpha1
- Working CC backend
- Shared globs and pre-initialised hash support
- Some XSUB support
- Assorted bug fixes
-
-INSTALLATION
-
-(1) You need perl5.002 or later.
-
-(2) If you want to compile and run programs with the C or CC backends
-which undefine (or redefine) subroutines, then you need to apply a
-one-line patch to perl itself. One or two of the programs in perl's
-own test suite do this. The patch is in file op.patch. It prevents
-perl from calling free() on OPs with the magic sequence number (U16)-1.
-The compiler declares all OPs as static structures and uses that magic
-sequence number.
-
-(3) Type
- perl Makefile.PL
-to write a personalised Makefile for your system. If you want the
-bytecode modules to support reading bytecode from strings (instead of
-just from files) then add the option
- -DINDIRECT_BGET_MACROS
-into the middle of the definition of the CCCMD macro in the Makefile.
-Your C compiler may need to be able to cope with Standard C for this.
-I haven't tested this option yet with an old pre-Standard compiler.
-
-(4) If your platform supports dynamic loading then just type
- make
-and you can then use
- perl -Iblib/arch -MO=foo bar
-to use the compiler modules (see later for details).
-If you need/want instead to make a statically linked perl which
-contains the appropriate modules, then type
- make perl
- make byteperl
-and you can then use
- ./perl -MO=foo bar
-to use the compiler modules.
-In both cases, the byteperl executable is required for running standalone
-bytecode programs. It is *not* a standard perl+XSUB perl executable.
-
-USAGE
-
-As of the alpha3 release, the Bytecode, C and CC backends are now all
-functional enough to compile almost the whole of the main perl test
-suite. In the case of the CC backend, any failures are all due to
-differences and/or known bugs documented below. See the file TESTS.
-In the following examples, you'll need to replace "perl" by
- perl -Iblib/arch
-if you have built the extensions for a dynamic loading platform but
-haven't installed the extensions completely. You'll need to replace
-"perl" by
- ./perl
-if you have built the extensions into a statically linked perl binary.
-
-(1) To compile perl program foo.pl with the C backend, do
- perl -MO=C,-ofoo.c foo.pl
-Then use the cc_harness perl program to compile the resulting C source:
- perl cc_harness -O2 -o foo foo.c
-
-If you are using a non-ANSI pre-Standard C compiler that can't handle
-pre-declaring static arrays, then add -DBROKEN_STATIC_REDECL to the
-options you use:
- perl cc_harness -O2 -o foo -DBROKEN_STATIC_REDECL foo.c
-If you are using a non-ANSI pre-Standard C compiler that can't handle
-static initialisation of structures with union members then add
--DBROKEN_UNION_INIT to the options you use. If you want command line
-arguments passed to your executable to be interpreted by perl (e.g. -Dx)
-then compile foo.c with -DALLOW_PERL_OPTIONS. Otherwise, all command line
-arguments passed to foo will appear directly in @ARGV. The resulting
-executable foo is the compiled version of foo.pl. See the file NOTES for
-extra options you can pass to -MO=C.
-
-There are some constraints on the contents on foo.pl if you want to be
-able to compile it successfully. Some problems can be fixed fairly easily
-by altering foo.pl; some problems with the compiler are known to be
-straightforward to solve and I'll do so soon. The file Todo lists a
-number of known problems. See the XSUB section lower down for information
-about compiling programs which use XSUBs.
-
-(2) To compile foo.pl with the CC backend (which generates actual
-optimised C code for the execution path of your perl program), use
- perl -MO=CC,-ofoo.c foo.pl
-
-and proceed just as with the C backend. You should almost certainly
-use an option such as -O2 with the subsequent cc_harness invocation
-so that your C compiler uses optimisation. The C code generated by
-the Perl compiler's CC backend looks ugly to humans but is easily
-optimised by C compilers.
-
-To make the most of this compiler backend, you need to tell the
-compiler when you're using int or double variables so that it can
-optimise appropriately (although this part of the compiler is the most
-buggy). You currently do that by naming lexical variables ending in
-"_i" for ints, "_d" for doubles, "_ir" for int "register" variables or
-"_dr" for double "register" variables. Here "register" is a promise
-that you won't pass a reference to the variable into a sub which then
-modifies the variable. The compiler ought to catch attempts to use
-"\$i" just as C compilers catch attempts to do "&i" for a register int
-i but it doesn't at the moment. Bugs in the CC backend may make your
-program fail in mysterious ways and give wrong answers rather than just
-crash in boring ways. But, hey, this is an alpha release so you knew
-that anyway. See the XSUB section lower down for information about
-compiling programs which use XSUBs.
-
-If your program uses classes which define methods (or other subs which
-are not exported and not apparently used until runtime) then you'll
-need to use -u compile-time options (see the NOTES file) to force the
-subs to be compiled. Future releases will probably default the other
-way, do more auto-detection and provide more fine-grained control.
-
-Since compiled executables need linking with libperl, you may want
-to turn libperl.a into a shared library if your platform supports
-it. For example, with Digital UNIX, do something like
- ld -shared -o libperl.so -all libperl.a -none -lc
-and with Linux/ELF, rebuild the perl .c files with -fPIC (and I
-also suggest -fomit-frame-pointer for Linux on Intel architetcures),
-do "make libperl.a" and then do
- gcc -shared -Wl,-soname,libperl.so.5 -o libperl.so.5.3 `ar t libperl.a`
-and then
- # cp libperl.so.5.3 /usr/lib
- # cd /usr/lib
- # ln -s libperl.so.5.3 libperl.so.5
- # ln -s libperl.so.5 libperl.so
- # ldconfig
-When you compile perl executables with cc_harness, append -L/usr/lib
-otherwise the -L for the perl source directory will override it. For
-example,
- perl -Iblib/arch -MO=CC,-O2,-ofoo3.c foo3.bench
- perl cc_harness -o foo3 -O2 foo3.c -L/usr/lib
- ls -l foo3
- -rwxr-xr-x 1 mbeattie xzdg 11218 Jul 1 15:28 foo3
-You'll probably also want to link your main perl executable against
-libperl.so; it's nice having an 11K perl executable.
-
-(3) To compile foo.pl into bytecode do
- perl -MO=Bytecode,-ofoo foo.pl
-To run the resulting bytecode file foo as a standalone program, you
-use the program byteperl which should have been built along with the
-extensions.
- ./byteperl foo
-Any extra arguments are passed in as @ARGV; they are not interpreted
-as perl options. If you want to load chunks of bytecode into an already
-running perl program then use the -m option and investigate the
-byteload_fh and byteload_string functions exported by the B module.
-See the NOTES file for details of these and other options (including
-optimisation options and ways of getting at the intermediate "assembler"
-code that the Bytecode backend uses).
-
-(3) There are little Bourne shell scripts and perl programs to aid with
-some common operations: assemble, disassemble, run_bytecode_test,
-run_test, cc_harness, test_harness, test_harness_bytecode.
-
-(4) Walk the op tree in execution order printing terse info about each op
- perl -MO=Terse,exec foo.pl
-
-(5) Walk the op tree in syntax order printing lengthier debug info about
-each op. You can also append ",exec" to walk in execution order, but the
-formatting is designed to look nice with Terse rather than Debug.
- perl -MO=Debug foo.pl
-
-(6) Produce a cross-reference report of the line numbers at which all
-variables, subs and formats are defined and used.
- perl -MO=Xref foo.pl
-
-XSUBS
-
-The C and CC backends can successfully compile some perl programs which
-make use of XSUB extensions. [I'll add more detail to this section in a
-later release.] As a prerequisite, such extensions must not need to do
-anything in their BOOT: section which needs to be done at runtime rather
-than compile time. Normally, the only code in the boot_Foo() function is
-a list of newXS() calls which xsubpp puts there and the compiler handles
-saving those XS subs itself. For each XSUB used, the C and CC compiler
-will generate an initialiser in their C output which refers to the name
-of the relevant C function (XS_Foo_somesub). What is not yet automated
-is the necessary commands and cc command-line options (e.g. via
-"perl cc_harness") which link against the extension libraries. For now,
-you need the XSUB extension to have installed files in the right format
-for using as C libraries (e.g. Foo.a or Foo.so). As the Foo.so files (or
-your platform's version) aren't suitable for linking against, you will
-have to reget the extension source and rebuild it as a static extension
-to force the generation of a suitable Foo.a file. Then you need to make
-a symlink (or copy or rename) of that file into a libFoo.a suitable for
-cc linking. Then add the appropriate -L and -l options to your
-"perl cc_harness" command line to find and link against those libraries.
-You may also need to fix up some platform-dependent environment variable
-to ensure that linked-against .so files are found at runtime too.
-
-DIFFERENCES
-
-The result of running a compiled Perl program can sometimes be different
-from running the same program with standard perl. Think of the compiler
-as having a slightly different implementation of the language Perl.
-Unfortunately, since Perl has had a single implementation until now,
-there are no formal standards or documents defining what behaviour is
-guaranteed of Perl the language and what just "happens to work".
-Some of the differences below are almost impossible to change because of
-the way the compiler works. Others can be changed to produce "standard"
-perl behaviour if it's deemed proper and the resulting performance hit
-is accepted. I'll use "standard perl" to mean the result of running a
-Perl program using the perl executable from the perl distribution.
-I'll use "compiled Perl program" to mean running an executable produced
-by this compiler kit ("the compiler") with the CC backend.
-
-Loops
- Standard perl calculates the target of "next", "last", and "redo"
- at run-time. The compiler calculates the targets at compile-time.
- For example, the program
-
- sub skip_on_odd { next NUMBER if $_[0] % 2 }
- NUMBER: for ($i = 0; $i < 5; $i++) {
- skip_on_odd($i);
- print $i;
- }
-
- produces the output
- 024
- with standard perl but gives a compile-time error with the compiler.
-
-Context of ".."
- The context (scalar or array) of the ".." operator determines whether
- it behaves as a range or a flip/flop. Standard perl delays until
- runtime the decision of which context it is in but the compiler needs
- to know the context at compile-time. For example,
- @a = (4,6,1,0,0,1);
- sub range { (shift @a)..(shift @a) }
- print range();
- while (@a) { print scalar(range()) }
- generates the output
- 456123E0
- with standard Perl but gives a compile-time error with compiled Perl.
-
-Arithmetic
- Compiled Perl programs use native C arithemtic much more frequently
- than standard perl. Operations on large numbers or on boundary
- cases may produce different behaviour.
-
-Deprecated features
- Features of standard perl such as $[ which have been deprecated
- in standard perl since version 5 was released have not been
- implemented in the compiler.
-
-Others
- I'll add to this list as I remember what they are.
-
-BUGS
-
-Here are some things which may cause the compiler problems.
-
-The following render the compiler useless (without serious hacking):
-* Use of the DATA filehandle (via __END__ or __DATA__ tokens)
-* Operator overloading with %OVERLOAD
-* The (deprecated) magic array-offset variable $[ does not work
-* The following operators are not yet implemented for CC
- goto
- sort with a non-default comparison (i.e. a named sub or inline block)
-* You can't use "last" to exit from a non-loop block.
-
-The following may give significant problems:
-* BEGIN blocks containing complex initialisation code
-* Code which is only ever referred to at runtime (e.g. via eval "..." or
- via method calls): see the -u option for the C and CC backends.
-* Run-time lookups of lexical variables in "outside" closures
-
-The following may cause problems (not thoroughly tested):
-* Dependencies on whether values of some "magic" Perl variables are
- determined at compile-time or runtime.
-* For the C and CC backends: compile-time strings which are longer than
- your C compiler can cope with in a single line or definition.
-* Reliance on intimate details of global destruction
-* For the Bytecode backend: high -On optimisation numbers with code
- that has complex flow of control.
-* Any "-w" option in the first line of your perl program is seen and
- acted on by perl itself before the compiler starts. The compiler
- itself then runs with warnings turned on. This may cause perl to
- print out warnings about the compiler itself since I haven't tested
- it thoroughly with warnings turned on.
-
-There is a terser but more complete list in the Todo file.
-
-Malcolm Beattie
-2 September 1996
+++ /dev/null
-Test results from compiling t/*/*.t
- C Bytecode CC
-
-base/cond.t OK ok OK
-base/if.t OK ok OK
-base/lex.t OK ok OK
-base/pat.t OK ok OK
-base/term.t OK ok OK
-cmd/elsif.t OK ok OK
-cmd/for.t OK ok ok 1, 2, 3, panic: pp_iter
-cmd/mod.t OK ok ok
-cmd/subval.t OK ok 1..34, not ok 27,28 (simply
- because filename changes).
-cmd/switch.t OK ok ok
-cmd/while.t OK ok ok
-io/argv.t OK ok ok
-io/dup.t OK ok ok
-io/fs.t OK ok ok
-io/inplace.t OK ok ok
-io/pipe.t OK ok ok with -umain
-io/print.t OK ok ok
-io/tell.t OK ok ok
-op/append.t OK ok OK
-op/array.t OK ok 1..36, not ok 7,10 (no $[)
-op/auto.t OK ok OK
-op/chop.t OK ok OK
-op/cond.t OK ok OK
-op/delete.t OK ok OK
-op/do.t OK ok OK
-op/each.t OK ok OK
-op/eval.t OK ok ok 1-6 of 16 then exits
-op/exec.t OK ok OK
-op/exp.t OK ok OK
-op/flip.t OK ok OK
-op/fork.t OK ok OK
-op/glob.t OK ok OK
-op/goto.t OK ok 1..9, Can't find label label1.
-op/groups.t OK (s/ucb/bin/ under Linux) OK 1..0 for now.
-op/index.t OK ok OK
-op/int.t OK ok OK
-op/join.t OK ok OK
-op/list.t OK ok OK
-op/local.t OK ok OK
-op/magic.t OK ok OK
-op/misc.t no DATA filehandle so succeeds trivially with 1..0
-op/mkdir.t OK ok OK
-op/my.t OK ok OK
-op/oct.t OK ok OK (C large const warnings)
-op/ord.t OK ok OK
-op/overload.t Mostly not ok Mostly not ok C errors.
-op/pack.t OK ok OK
-op/pat.t omit 26 (reset) ok [lots of memory for compile]
-op/push.t OK ok OK
-op/quotemeta.t OK ok OK
-op/rand.t OK ok
-op/range.t OK ok OK
-op/read.t OK ok OK
-op/readdir.t OK ok OK (substcont works too)
-op/ref.t omits "ok 40" (lex destruction) ok (Bytecode)
- CC: need -u for OBJ,BASEOBJ,
- UNIVERSAL,WHATEVER,main.
- 1..41, ok1-33,36-38,
- then ok 41, ok 39.DESTROY probs
-op/regexp.t OK ok ok (trivially all eval'd)
-op/repeat.t OK ok ok
-op/sleep.t OK ok ok
-op/sort.t OK ok 1..10, ok 1, Out of memory!
-op/split.t OK ok ok
-op/sprintf.t OK ok ok
-op/stat.t OK ok ok
-op/study.t OK ok ok
-op/subst.t OK ok ok
-op/substr.t OK ok ok1-22 except 7-9,11 (all $[)
-op/time.t OK ok ok
-op/undef.t omit 21 ok ok
-op/unshift.t OK ok ok
-op/vec.t OK ok ok
-op/write.t not ok 3 (no CvOUTSIDE lex from runtime eval). CC: 1..3, hang
+++ /dev/null
-* Fixes
-
-CC backend: goto, sort with non-default comparison. last for non-loop blocks.
-Version checking
-improve XSUB handling (both static and dynamic)
-sv_magic can do SvREFCNT_inc(obj) which messes up precalculated refcounts
-allocation of XPV[INAHC]V structures needs fixing: Perl tries to free
-them whereas the compiler expects them to be linked to a xpv[inahc]v_root
-list the same as X[IPR]V structures.
-ref counts
-perl_parse replacement
-fix cstring for long strings
-compile-time initialisation of AvARRAYs
-signed/unsigned problems with NV (and IV?) initialisation and elsewhere?
-CvOUTSIDE for ordinary subs
-DATA filehandle for standalone Bytecode program (easy)
-DATA filehandle for multiple bytecode-compiled modules (harder)
-DATA filehandle for C-compiled program (yet harder)
-
-* Features
-
-type checking
-compile time v. runtime initialisation
-save PMOPs in compiled form
-selection of what to dump
-options for cutting out line info etc.
-comment output
-shared constants
-module dependencies
-
-* Optimisations
-collapse LISTOPs to UNOPs or BASEOPs
-compile-time qw(), constant subs
-global analysis of variables, type hints etc.
-demand-loaded bytecode (leader of each basic block replaced by an op
-which loads in bytecode for its block)
-fast sub calls for CC backend
+++ /dev/null
-At entry to each basic block, the following can be assumed (and hence
-must be forced where necessary at the end of each basic block):
-
-The shadow stack @stack is empty.
-For each lexical object in @pad, VALID_IV holds for each T_INT,
-VALID_DOUBLE holds for each T_DOUBLE and VALID_SV holds otherwise.
-The C shadow variable sp holds the stack pointer (not necessarily stack_sp).
-
-write_back_stack
- Writes the contents of the shadow stack @stack back to the real stack.
- A write-back of each object in the stack is forced so that its
- backing SV contains the right value and that SV is then pushed onto the
- real stack. On return, @stack is empty.
-
-write_back_lexicals
- Forces a write-back (i.e. achieves VALID_SV), where necessary, for each
- lexical object in @pad. Objects with the TEMPORARY flag are skipped. If
- write_back_lexicals is called with an (optional) argument, then it is
- taken to be a bitmask of more flags: any lexical object with one of those
- flags set is also skipped and not written back to its SV.
-
-invalidate_lexicals($avoid)
- The VALID_INT and VALID_DOUBLE flags are turned off for each lexical
- object in @pad whose flags field doesn't overlap with $avoid.
-
-reload_lexicals
- For each necessary lexical object in @pad, makes sure that VALID_IV
- holds for objects of type T_INT, VALID_DOUBLE holds for objects for
- type T_DOUBLE, and VALID_SV holds for other objects. An object is
- considered for reloading if its flags field does not overlap with the
- (optional) argument passed to reload_lexicals.
-
+++ /dev/null
-PP code uses of curcop
-----------------------
-
-pp_rv2gv
- when a new glob is created for an OPpLVAL_INTRO,
- curcop->cop_line is stored as GvLINE() in the new GP.
-pp_bless
- curcop->cop_stash is used as the stash in the one-arg form of bless
-
-pp_repeat
- tests (curcop != &compiling) to warn "Can't x= to readonly value"
-
-pp_pos
-pp_substr
-pp_index
-pp_rindex
-pp_aslice
-pp_lslice
-pp_splice
- curcop->cop_arybase
-
-pp_sort
- curcop->cop_stash used to determine whether to gv_fetchpv $a and $b
-
-pp_caller
- tests (curcop->cop_stash == debstash) to determine whether
- to set DB::args
-
-pp_reset
- resets vars in curcop->cop_stash
-
-pp_dbstate
- sets curcop = (COP*)op
-
-doeval
- compiles into curcop->cop_stash
-
-pp_nextstate
- sets curcop = (COP*)op
+++ /dev/null
-PP(pp_range)
-{
- if (GIMME == G_ARRAY)
- return NORMAL;
- if (SvTRUEx(PAD_SV(PL_op->op_targ)))
- return cLOGOP->op_other;
- else
- return NORMAL;
-}
-
-pp_range is a LOGOP.
-In list context, it just returns op_next.
-In scalar context it checks the truth of targ and returns
-op_other if true, op_next if false.
-
-flip is an UNOP.
-It "looks after" its child which is always a pp_range LOGOP.
-In list context, it just returns the child's op_other.
-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_other.
- (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_other);
-/* op_next */
-...
-/* flip */
-/* For "..." returns op_next. For ".." returns op_next or op_first->op_other */
-/* end of basic block */
-goto out;
-label(range op_other):
-...
-/* flop */
-out:
-...
+++ /dev/null
-sv_magic()
-----------
-av.c
-av_store()
- Storing a non-undef element into an SMAGICAL array, av,
- assigns the equivalent lowercase form of magic (of the first
- MAGIC in the chain) to the value (with obj = av, name = 0 and
- namlen = array index).
-
-gv.c
-gv_init()
- Initialising gv assigns '*' magic to it with obj = gv, name =
- GvNAME and namlen = GvNAMELEN.
-gv_fetchpv()
- @ISA gets 'I' magic with obj = gv, zero name and namlen.
- %OVERLOAD gets 'A' magic with obj = gv, zero name and namlen.
- $1 to $9, $&, $`, $', $+ get '\0' magic with obj = gv,
- name = GvNAME and namlen = len ( = 1 presumably).
-Gv_AMupdate()
- Stashes for overload magic seem to get 'c' magic with obj = 0,
- name = &amt and namlen = sizeof(amt).
-hv_magic(hv, gv, how)
- Gives magic how to hv with obj = gv and zero name and namlen.
-
-mg.c
-mg_copy(sv, nsv, key, klen)
- Traverses the magic chain of sv. Upper case forms of magic
- (only) are copied across to nsv, preserving obj but using
- name = key and namlen = klen.
-magic_setpos()
- LvTARG of a PVLV gets 'g' magic with obj = name = 0 and namlen = pos.
-
-op.c
-mod()
- PVLV operators give magic to their targs with
- obj = name = namlen = 0. OP_POS gives '.', OP_VEC gives 'v'
- and OP_SUBSTR gives 'x'.
-
-perl.c
-magicname(sym, name, namlen)
- Fetches/creates a GV with name sym and gives it '\0' magic
- with obj = gv, name and namlen as passed.
-init_postdump_symbols()
- Elements of the environment get given SVs with 'e' magic.
- obj = sv and name and namlen point to the actual string
- within env.
-
-pp.c
-pp_av2arylen()
- $#foo gives '#' magic to the new SV with obj = av and
- name = namlen = 0.
-pp_study()
- SV gets 'g' magic with obj = name = namlen = 0.
-pp_substr()
- PVLV gets 'x' magic with obj = name = namlen = 0.
-pp_vec()
- PVLV gets 'x' magic with obj = name = namlen = 0.
-
-pp_hot.c
-pp_match()
- m//g gets 'g' magic with obj = name = namlen = 0.
-
-pp_sys.c
-pp_tie()
- sv gets magic with obj = sv and name = namlen = 0.
- If an HV or an AV, it gets 'P' magic, otherwise 'q' magic.
-pp_dbmopen()
- 'P' magic for the HV just as with pp_tie().
-pp_sysread()
- If tainting, the buffer SV gets 't' magic with
- obj = name = namlen = 0.
-
-sv.c
-sv_setsv()
- Doing sv_setsv(dstr, gv) gives '*' magic to dstr with
- obj = dstr, name = GvNAME, namlen = GvNAMELEN.
-
-util.c
-fbm_compile()
- The PVBM gets 'B' magic with obj = name = namlen = 0 and SvVALID
- is set to indicate that the Boyer-Moore table is valid.
- magic_setbm() just clears the SvVALID flag.
-
-hv_magic()
-----------
-
-gv.c
-gv_fetchfile()
- With perldb, the HV of a gvfile gv gets 'L' magic with obj = gv.
-gv_fetchpv()
- %SIG gets 'S' magic with obj = siggv.
-init_postdump_symbols()
- %ENV gets 'E' magic with obj = envgv.
+++ /dev/null
-while ($i--) {
- foo();
-}
-exit
-
- PP code if i an int register if i an int but not a
- (i.e. can't be register (i.e. can be
- implicitly invalidated) implicitly invalidated)
- nextstate
- enterloop
-
-
- loop:
- gvsv GV (0xe6078) *i validates i validates i
- postdec invalidates $i invalidates $i
- and if_false goto out;
- i valid; $i invalid i valid; $i invalid
-
- i valid; $i invalid i valid; $i invalid
- nextstate
- pushmark
- gv GV (0xe600c) *foo
- entersub validates $i; invals i
-
- unstack
- goto loop:
-
- i valid; $i invalid
- out:
- leaveloop
- nextstate
- exit
+++ /dev/null
-Notes on porting the perl runtime PP engine.
-Importance: 1 = who cares?, 10 = vital
-Difficulty: 1 = trivial, 10 = very difficult. Level assumes a
-reasonable implementation of the SV and OP API already ported.
-
-OP Import Diff Comments
-null 10 1
-stub 10 1
-scalar 10 1
-pushmark 10 1 PUSHMARK
-wantarray 7 3 cxstack, dopoptosub
-const 10 1
-gvsv 10 1 save_scalar
-gv 10 1
-gelem 3 3
-padsv 10 2 SAVECLEARSV, provide_ref
-padav 10 2
-padhv 10 2
-padany 1 1
-pushre 7 3 pushes an op. Blech.
-rv2gv 6 5
-rv2sv 10 4
-av2arylen 7 3 sv_magic
-rv2cv 8 5 sv_2cv
-anoncode 7 6 cv_clone
-prototype 4 4 sv_2cv
-refgen 8 3
-srefgen 8 2
-ref 8 3
-bless 7 3
-backtick 5 4
-glob 5 2 do_readline
-readline 8 2 do_readline
-rcatline 8 2
-regcmaybe 8 1
-regcreset 8 1
-regcomp 8 9 pregcomp
-match 8 10
-qr 8 1
-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
-leavesublv
-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
-sysseek 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
-lock 6 1
-threadsv 6 2 unused if not USE_5005THREADS, absent post 5.8
-setstate 1 1 currently unused anywhere
-method_named 10 2
+++ /dev/null
-#!./perl -Tw
-
-BEGIN {
- if ($ENV{PERL_CORE}){
- chdir('t') if -d 't';
- @INC = ('.', '../lib');
- } else {
- unshift @INC, 't';
- }
- require Config;
- if (($Config::Config{'extensions'} !~ /\bB\b/) ){
- print "1..0 # Skip -- Perl configured without B module\n";
- exit 0;
- }
-}
-
-use Test::More tests => 13;
-
-use_ok('B::Asmdata', qw(%insn_data @insn_name @optype @specialsv_name));
-
-# check we got something.
-isnt( keys %insn_data, 0, '%insn_data exported and populated' );
-isnt( @insn_name, 0, ' @insn_name' );
-isnt( @optype, 0, ' @optype' );
-isnt( @specialsv_name, 0, ' @specialsv_name' );
-
-# pick an op that's not likely to go away in the future
-my @data = values %insn_data;
-is( (grep { ref eq 'ARRAY' } @data), @data, '%insn_data contains arrays' );
-
-# pick one at random to test with.
-my $opname = (keys %insn_data)[rand @data];
-my $data = $insn_data{$opname};
-like( $data->[0], qr/^\d+$/, ' op number' );
-is( ref $data->[1], 'CODE', ' PUT code ref' );
-ok( !ref $data->[2], ' GET method' );
-
-is( $insn_name[$data->[0]], $opname, '@insn_name maps correctly' );
-
-
-# I'm going to assume that op types will all be named /OP$/.
-# If this changes in the future, change this test.
-is( grep(/OP$/, @optype), @optype, '@optype is all /OP$/' );
-
-
-# comment in bytecode.pl says "Nullsv *must come first so that the
-# condition ($$sv == 0) can continue to be used to test (sv == Nullsv)."
-is( $specialsv_name[0], 'Nullsv', 'Nullsv come first in @special_sv_name' );
-
-# other than that, we can't really say much more about @specialsv_name
-# than it has to contain strings (on the off chance &PL_sv_undef gets
-# flubbed)
-is( grep(!ref, @specialsv_name), @specialsv_name, ' contains all strings' );
+++ /dev/null
-#!./perl -w
-
-=pod
-
-=head1 TEST FOR B::Assembler.pm AND B::Disassembler.pm
-
-=head2 Description
-
-The general idea is to test by assembling a choice set of assembler
-instructions, then disassemble them, and check that we've completed the
-round trip. Also, error checking of Assembler.pm is tested by feeding
-it assorted errors.
-
-Since Assembler.pm likes to assemble a file, we comply by writing a
-text file. This file contains three sections:
-
- testing operand categories
- use each opcode
- erronous assembler instructions
-
-An "operand category" is identified by the suffix of the PUT_/GET_
-subroutines as shown in the C<%Asmdata::insn_data> initialization, e.g.
-opcode C<ldsv> has operand category C<svindex>:
-
- insn_data{ldsv} = [1, \&PUT_svindex, "GET_svindex"];
-
-Because Disassembler.pm also assumes input from a file, we write the
-resulting object code to a file. And disassembled output is written to
-yet another text file which is then compared to the original input.
-(Erronous assembler instructions still generate code, but this is not
-written to the object file; therefore disassembly bails out at the first
-instruction in error.)
-
-All files are kept in memory by using TIEHASH.
-
-
-=head2 Caveats
-
-An error where Assembler.pm and Disassembler.pm agree but Assembler.pm
-generates invalid object code will not be detected.
-
-Due to the way this test has been set up, failure of a single test
-could cause all subsequent tests to fail as well: After an unexpected
-assembler error no output is written, and disassembled lines will be
-out of sync for all lines thereafter.
-
-Not all possibilities for writing a valid operand value can be tested
-because disassembly results in a uniform representation.
-
-
-=head2 Maintenance
-
-New opcodes are added automatically.
-
-A new operand category will cause this program to die ("no operand list
-for XXX"). The cure is to add suitable entries to C<%goodlist> and
-C<%badlist>. (Since the data in Asmdata.pm is autogenerated, it may also
-happen that the corresponding assembly or disassembly subroutine is
-missing.) Note that an empty array as a C<%goodlist> entry means that
-opcodes of the operand category do not take an operand (and therefore the
-corresponding entry in C<%badlist> should have one). An C<undef> entry
-in C<%badlist> means that any value is acceptable (and thus there is no
-way to cause an error).
-
-Set C<$dbg> to debug this test.
-
-=cut
-
-package VirtFile;
-use strict;
-
-# Note: This is NOT a general purpose package. It implements
-# sequential text and binary file i/o in a rather simple form.
-
-sub TIEHANDLE($;$){
- my( $class, $data ) = @_;
- my $obj = { data => defined( $data ) ? $data : '',
- pos => 0 };
- return bless( $obj, $class );
-}
-
-sub PRINT($@){
- my( $self ) = shift;
- $self->{data} .= join( '', @_ );
-}
-
-sub WRITE($$;$$){
- my( $self, $buf, $len, $offset ) = @_;
- unless( defined( $len ) ){
- $len = length( $buf );
- $offset = 0;
- }
- unless( defined( $offset ) ){
- $offset = 0;
- }
- $self->{data} .= substr( $buf, $offset, $len );
- return $len;
-}
-
-
-sub GETC($){
- my( $self ) = @_;
- return undef() if $self->{pos} >= length( $self->{data} );
- return substr( $self->{data}, $self->{pos}++, 1 );
-}
-
-sub READLINE($){
- my( $self ) = @_;
- return undef() if $self->{pos} >= length( $self->{data} );
- my $lfpos = index( $self->{data}, "\n", $self->{pos} );
- if( $lfpos < 0 ){
- $lfpos = length( $self->{data} );
- }
- my $pos = $self->{pos};
- $self->{pos} = $lfpos + 1;
- return substr( $self->{data}, $pos, $self->{pos} - $pos );
-}
-
-sub READ($@){
- my $self = shift();
- my $bufref = \$_[0];
- my( undef, $len, $offset ) = @_;
- if( $offset ){
- die( "offset beyond end of buffer\n" )
- if ! defined( $$bufref ) || $offset > length( $$bufref );
- } else {
- $$bufref = '';
- $offset = 0;
- }
- my $remlen = length( $self->{data} ) - $self->{pos};
- $len = $remlen if $remlen < $len;
- return 0 unless $len;
- substr( $$bufref, $offset, $len ) =
- substr( $self->{data}, $self->{pos}, $len );
- $self->{pos} += $len;
- return $len;
-}
-
-sub TELL($){
- my $self = shift();
- return $self->{pos};
-}
-
-sub CLOSE($){
- my( $self ) = @_;
- $self->{pos} = 0;
-}
-
-1;
-
-package main;
-
-use strict;
-use Test::More;
-use Config qw(%Config);
-
-BEGIN {
- if (($Config{'extensions'} !~ /\bB\b/) ){
- print "1..0 # Skip -- Perl configured without B module\n";
- exit 0;
- }
- if (($Config{'extensions'} !~ /\bByteLoader\b/) ){
- print "1..0 # Skip -- Perl configured without ByteLoader module\n";
- exit 0;
- }
-}
-
-use B::Asmdata qw( %insn_data );
-use B::Assembler qw( &assemble_fh );
-use B::Disassembler qw( &disassemble_fh &get_header );
-
-my( %opsByType, @code2name );
-my( $lineno, $dbg, $firstbadline, @descr );
-$dbg = 0; # debug switch
-
-# $SIG{__WARN__} handler to catch Assembler error messages
-#
-my $warnmsg;
-sub catchwarn($){
- $warnmsg = $_[0];
- print "error: $warnmsg\n" if $dbg;
-}
-
-# Callback for writing assembled bytes. This is where we check
-# that we do get an error.
-#
-sub putobj($){
- if( ++$lineno >= $firstbadline ){
- ok( $warnmsg && $warnmsg =~ /^\d+:\s/, $descr[$lineno] );
- undef( $warnmsg );
- } else {
- my $l = syswrite( OBJ, $_[0] );
- }
-}
-
-# Callback for writing a disassembled statement.
-#
-sub putdis(@){
- my $line = join( ' ', @_ );
- ++$lineno;
- print DIS "$line\n";
- printf "%5d %s\n", $lineno, $line if $dbg;
-}
-
-# Generate assembler instructions from a hash of operand types: each
-# existing entry contains a list of good or bad operand values. The
-# corresponding opcodes can be found in %opsByType.
-#
-sub gen_type($$$){
- my( $href, $descref, $text ) = @_;
- for my $odt ( sort( keys( %opsByType ) ) ){
- my $opcode = $opsByType{$odt}->[0];
- my $sel = $odt;
- $sel =~ s/^GET_//;
- die( "no operand list for $sel\n" ) unless exists( $href->{$sel} );
- if( defined( $href->{$sel} ) ){
- if( @{$href->{$sel}} ){
- for my $od ( @{$href->{$sel}} ){
- ++$lineno;
- $descref->[$lineno] = "$text: $code2name[$opcode] $od";
- print ASM "$code2name[$opcode] $od\n";
- printf "%5d %s %s\n", $lineno, $code2name[$opcode], $od if $dbg;
- }
- } else {
- ++$lineno;
- $descref->[$lineno] = "$text: $code2name[$opcode]";
- print ASM "$code2name[$opcode]\n";
- printf "%5d %s\n", $lineno, $code2name[$opcode] if $dbg;
- }
- }
- }
-}
-
-# Interesting operand values
-#
-my %goodlist = (
-comment_t => [ '"a comment"' ], # no \n
-none => [],
-svindex => [ 0x7fffffff, 0 ],
-opindex => [ 0x7fffffff, 0 ],
-pvindex => [ 0x7fffffff, 0 ],
-U32 => [ 0xffffffff, 0 ],
-U8 => [ 0xff, 0 ],
-PV => [ '""', '"a string"', ],
-I32 => [ -0x80000000, 0x7fffffff ],
-IV64 => [ '0x000000000', '0x0ffffffff', '0x000000001' ], # disass formats 0x%09x
-IV => $Config{ivsize} == 4 ?
- [ -0x80000000, 0x7fffffff ] :
- [ '0x000000000', '0x0ffffffff', '0x000000001' ],
-NV => [ 1.23456789E3 ],
-U16 => [ 0xffff, 0 ],
-pvcontents => [],
-strconst => [ '""', '"another string"' ], # no NUL
-op_tr_array => [ join( ',', 256, 0..255 ) ],
-PADOFFSET => undef,
-long => undef,
-svtype => undef,
- );
-
-# Erronous operand values
-#
-my %badlist = (
-comment_t => [ '"multi-line\ncomment"' ], # no \n
-none => [ '"spurious arg"' ],
-svindex => [ 0xffffffff * 2, -1 ],
-opindex => [ 0xffffffff * 2, -2 ],
-pvindex => [ 0xffffffff * 2, -3 ],
-U32 => [ 0xffffffff * 2, -4 ],
-U16 => [ 0x5ffff, -5 ],
-U8 => [ 0x6ff, -6 ],
-PV => [ 'no quote"' ],
-I32 => [ -0x80000001, 0x80000000 ],
-IV64 => undef, # PUT_IV64 doesn't check - no integrity there
-IV => $Config{ivsize} == 4 ?
- [ -0x80000001, 0x80000000 ] : undef,
-NV => undef, # PUT_NV accepts anything - it shouldn't, real-ly
-pvcontents => [ '"spurious arg"' ],
-strconst => [ 'no quote"', '"with NUL '."\0".' char"' ], # no NUL
-op_tr_array => undef, # op_pv_tr is no longer exactly 256 shorts
-PADOFFSET => undef,
-long => undef,
-svtype => undef,
- );
-
-
-# Determine all operand types from %Asmdata::insn_data
-#
-for my $opname ( keys( %insn_data ) ){
- my ( $opcode, $put, $getname ) = @{$insn_data{$opname}};
- push( @{$opsByType{$getname}}, $opcode );
- $code2name[$opcode] = $opname;
-}
-
-
-# Write instruction(s) for correct operand values each operand type class
-#
-$lineno = 0;
-tie( *ASM, 'VirtFile' );
-gen_type( \%goodlist, \@descr, 'round trip' );
-
-# Write one instruction for each opcode.
-#
-for my $opcode ( 0..$#code2name ){
- next unless defined( $code2name[$opcode] );
- my $sel = $insn_data{$code2name[$opcode]}->[2];
- $sel =~ s/^GET_//;
- die( "no operand list for $sel\n" ) unless exists( $goodlist{$sel} );
- if( defined( $goodlist{$sel} ) ){
- ++$lineno;
- if( @{$goodlist{$sel}} ){
- my $od = $goodlist{$sel}[0];
- $descr[$lineno] = "round trip: $code2name[$opcode] $od";
- print ASM "$code2name[$opcode] $od\n";
- printf "%5d %s %s\n", $lineno, $code2name[$opcode], $od if $dbg;
- } else {
- $descr[$lineno] = "round trip: $code2name[$opcode]";
- print ASM "$code2name[$opcode]\n";
- printf "%5d %s\n", $lineno, $code2name[$opcode] if $dbg;
- }
- }
-}
-
-# Write instruction(s) for incorrect operand values each operand type class
-#
-$firstbadline = $lineno + 1;
-gen_type( \%badlist, \@descr, 'asm error' );
-
-# invalid opcode is an odd-man-out ;-)
-#
-++$lineno;
-$descr[$lineno] = "asm error: Gollum";
-print ASM "Gollum\n";
-printf "%5d %s\n", $lineno, 'Gollum' if $dbg;
-
-close( ASM );
-
-# Now that we have defined all of our tests: plan
-#
-plan( tests => $lineno );
-print "firstbadline=$firstbadline\n" if $dbg;
-
-# assemble (guard against warnings and death from assembly errors)
-#
-$SIG{'__WARN__'} = \&catchwarn;
-
-$lineno = -1; # account for the assembly header
-tie( *OBJ, 'VirtFile' );
-eval { assemble_fh( \*ASM, \&putobj ); };
-print "eval: $@" if $dbg;
-close( ASM );
-close( OBJ );
-$SIG{'__WARN__'} = 'DEFAULT';
-
-# disassemble
-#
-print "--- disassembling ---\n" if $dbg;
-$lineno = 0;
-tie( *DIS, 'VirtFile' );
-disassemble_fh( \*OBJ, \&putdis );
-close( OBJ );
-close( DIS );
-
-# get header (for debugging only)
-#
-if( $dbg ){
- my( $magic, $archname, $blversion, $ivsize, $ptrsize, $byteorder ) =
- get_header();
- printf "Magic: 0x%08x\n", $magic;
- print "Architecture: $archname\n";
- print "Byteloader V: $blversion\n";
- print "ivsize: $ivsize\n";
- print "ptrsize: $ptrsize\n";
- print "Byteorder: $byteorder\n";
-}
-
-# check by comparing files line by line
-#
-print "--- checking ---\n" if $dbg;
-$lineno = 0;
-my( $asmline, $disline );
-while( defined( $asmline = <ASM> ) ){
- $disline = <DIS>;
- ++$lineno;
- last if $lineno eq $firstbadline; # bail out where errors begin
- ok( $asmline eq $disline, $descr[$lineno] );
- printf "%5d %s\n", $lineno, $asmline if $dbg;
-}
-close( ASM );
-close( DIS );
-
-__END__
+++ /dev/null
-#!./perl -Tw
-
-BEGIN {
- if ($ENV{PERL_CORE}){
- chdir('t') if -d 't';
- @INC = ('.', '../lib');
- } else {
- unshift @INC, 't';
- }
- require Config;
- if (($Config::Config{'extensions'} !~ /\bB\b/) ){
- print "1..0 # Skip -- Perl configured without B module\n";
- exit 0;
- }
-}
-
-use Test::More tests => 1;
-
-use_ok('B::Bblock', qw(find_leaders));
-
-# Someone who understands what this module does, please fill this out.
+++ /dev/null
-#!./perl
-my $keep_plc = 0; # set it to keep the bytecode files
-my $keep_plc_fail = 1; # set it to keep the bytecode files on failures
-
-BEGIN {
- if ($^O eq 'VMS') {
- print "1..0 # skip - Bytecode/ByteLoader doesn't work on VMS\n";
- exit 0;
- }
- if ($ENV{PERL_CORE}){
- chdir('t') if -d 't';
- @INC = ('.', '../lib');
- } else {
- unshift @INC, 't';
- push @INC, "../../t";
- }
- use Config;
- if (($Config{'extensions'} !~ /\bB\b/) ){
- print "1..0 # Skip -- Perl configured without B module\n";
- exit 0;
- }
- if ($Config{ccflags} =~ /-DPERL_OLD_COPY_ON_WRITE/) {
- print "1..0 # skip - no COW for now\n";
- exit 0;
- }
- require 'test.pl'; # for run_perl()
-}
-use strict;
-
-undef $/;
-my @tests = split /\n###+\n/, <DATA>;
-
-print "1..".($#tests+1)."\n";
-
-my $cnt = 1;
-my $test;
-
-for (@tests) {
- my $got;
- my ($script, $expect) = split />>>+\n/;
- $expect =~ s/\n$//;
- $test = "bytecode$cnt.pl";
- open T, ">$test"; print T $script; close T;
- $got = run_perl(switches => [ "-MO=Bytecode,-H,-o${test}c" ],
- verbose => 0, # for debugging
- stderr => 1, # to capture the "bytecode.pl syntax ok"
- progfile => $test);
- unless ($?) {
- $got = run_perl(progfile => "${test}c"); # run the .plc
- unless ($?) {
- if ($got =~ /^$expect$/) {
- print "ok $cnt\n";
- next;
- } else {
- $keep_plc = $keep_plc_fail unless $keep_plc;
- print <<"EOT"; next;
-not ok $cnt
---------- SCRIPT
-$script
---------- GOT
-$got
---------- EXPECT
-$expect
-----------------
-
-EOT
- }
- }
- }
- print <<"EOT";
-not ok $cnt
---------- SCRIPT
-$script
---------- \$\? = $?
-$got
-EOT
-} continue {
- 1 while unlink($test, $keep_plc ? () : "${test}c");
- $cnt++;
-}
-
-__DATA__
-
-print 'hi'
->>>>
-hi
-############################################################
-for (1,2,3) { print if /\d/ }
->>>>
-123
-############################################################
-$_ = "xyxyx"; %j=(1,2); s/x/$j{print('z')}/ge; print $_
->>>>
-zzz2y2y2
-############################################################
-$_ = "xyxyx"; %j=(1,2); s/x/$j{print('z')}/g; print $_
->>>>
-z2y2y2
-############################################################
-split /a/,"bananarama"; print @_
->>>>
-bnnrm
-############################################################
-{ package P; sub x { print 'ya' } x }
->>>>
-ya
-############################################################
-@z = split /:/,"b:r:n:f:g"; print @z
->>>>
-brnfg
-############################################################
-sub AUTOLOAD { print 1 } &{"a"}()
->>>>
-1
-############################################################
-my $l = 3; $x = sub { print $l }; &$x
->>>>
-3
-############################################################
-my $i = 1;
-my $foo = sub {$i = shift if @_};
-&$foo(3);
-print 'ok';
->>>>
-ok
-############################################################
-$x="Cannot use"; print index $x, "Can"
->>>>
-0
-############################################################
-my $i=6; eval "print \$i\n"
->>>>
-6
-############################################################
-BEGIN { %h=(1=>2,3=>4) } print $h{3}
->>>>
-4
-############################################################
-open our $T,"a";
-print 'ok';
->>>>
-ok
-############################################################
-print <DATA>
-__DATA__
-a
-b
->>>>
-a
-b
-############################################################
-BEGIN { tie @a, __PACKAGE__; sub TIEARRAY { bless{} } sub FETCH { 1 } }
-print $a[1]
->>>>
-1
-############################################################
-my $i=3; print 1 .. $i
->>>>
-123
-############################################################
-my $h = { a=>3, b=>1 }; print sort {$h->{$a} <=> $h->{$b}} keys %$h
->>>>
-ba
-############################################################
-print sort { my $p; $b <=> $a } 1,4,3
->>>>
-431
+++ /dev/null
-#!./perl
-
-BEGIN {
- if ($ENV{PERL_CORE}){
- chdir('t') if -d 't';
- if ($^O eq 'MacOS') {
- @INC = qw(: ::lib ::macos:lib);
- } else {
- @INC = '.';
- push @INC, '../lib';
- }
- } else {
- unshift @INC, 't';
- }
- require Config;
- if (($Config::Config{'extensions'} !~ /\bB\b/) ){
- print "1..0 # Skip -- Perl configured without B module\n";
- exit 0;
- }
-}
-
-$| = 1;
-use warnings;
-use strict;
-use Config;
-
-print "1..1\n";
-
-my $test = 1;
-
-sub ok { print "ok $test\n"; $test++ }
-
-
-my $got;
-my $Is_VMS = $^O eq 'VMS';
-my $Is_MacOS = $^O eq 'MacOS';
-
-my $path = join " ", map { qq["-I$_"] } @INC;
-$path = '"-I../lib" "-Iperl_root:[lib]"' if $Is_VMS; # gets too long otherwise
-my $redir = $Is_MacOS ? "" : "2>&1";
-
-chomp($got = `$^X $path "-MB::Stash" "-Mwarnings" -e1`);
-
-$got =~ s/-u//g;
-
-print "# got = $got\n";
-
-my @got = map { s/^\S+ //; $_ }
- sort { $a cmp $b }
- map { lc($_) . " " . $_ }
- split /,/, $got;
-
-print "# (after sorting)\n";
-print "# got = @got\n";
-
-@got = grep { ! /^(PerlIO|open)(?:::\w+)?$/ } @got;
-
-print "# (after perlio censorings)\n";
-print "# got = @got\n";
-
-@got = grep { ! /^Win32$/ } @got if $^O eq 'MSWin32';
-@got = grep { ! /^NetWare$/ } @got if $^O eq 'NetWare';
-@got = grep { ! /^(Cwd|File|File::Copy|OS2)$/ } @got if $^O eq 'os2';
-@got = grep { ! /^(Cwd|Cygwin)$/ } @got if $^O eq 'cygwin';
-
-if ($Is_VMS) {
- @got = grep { ! /^File(?:::Copy)?$/ } @got;
- @got = grep { ! /^VMS(?:::Filespec)?$/ } @got;
- @got = grep { ! /^vmsish$/ } @got;
- # Socket is optional/compiler version dependent
- @got = grep { ! /^Socket$/ } @got;
-}
-
-print "# (after platform censorings)\n";
-print "# got = @got\n";
-
-$got = "@got";
-
-my $expected = "attributes Carp Carp::Heavy DB Internals main Regexp utf8 version warnings";
-
-if ($] < 5.009) {
- $expected =~ s/version //;
- $expected =~ s/DB/DB Exporter Exporter::Heavy/;
-}
-
-{
- no strict 'vars';
- use vars '$OS2::is_aout';
-}
-
-if ((($Config{static_ext} eq ' ') || ($Config{static_ext} eq ''))
- && !($^O eq 'os2' and $OS2::is_aout)
- ) {
- print "# got [$got]\n# vs.\n# expected [$expected]\nnot " if $got ne $expected;
- ok;
-} else {
- print "ok $test # skipped: one or more static extensions\n"; $test++;
-}
-
+++ /dev/null
-package ByteLoader;
-
-use XSLoader ();
-
-our $VERSION = '0.06';
-
-XSLoader::load 'ByteLoader', $VERSION;
-
-1;
-__END__
-
-=head1 NAME
-
-ByteLoader - load byte compiled perl code
-
-=head1 SYNOPSIS
-
- use ByteLoader 0.06;
- <byte code>
-
- or just
-
- perl -MByteLoader bytecode_file
-
-=head1 DESCRIPTION
-
-This module is used to load byte compiled perl code as produced by
-C<perl -MO=Bytecode=...>. It uses the source filter mechanism to read
-the byte code and insert it into the compiled code at the appropriate point.
-
-=head1 AUTHOR
-
-Tom Hughes <tom@compton.nu> based on the ideas of Tim Bunce and others.
-Many changes by Enache Adrian <enache@rdslink.ro> 2003 a.d.
-
-=head1 SEE ALSO
-
-perl(1).
-
-=cut
+++ /dev/null
-#include "EXTERN.h"
-#include "perl.h"
-#include "XSUB.h"
-#include "byterun.h"
-
-/* Something arbitary for a buffer size */
-#define BYTELOADER_BUFFER 8096
-
-int
-bl_getc(struct byteloader_fdata *data)
-{
- dTHX;
- if (SvCUR(data->datasv) <= (STRLEN)data->next_out) {
- int result;
- /* Run out of buffered data, so attempt to read some more */
- *(SvPV_nolen (data->datasv)) = '\0';
- SvCUR_set (data->datasv, 0);
- data->next_out = 0;
- result = FILTER_READ (data->idx + 1, data->datasv, BYTELOADER_BUFFER);
-
- /* Filter returned error, or we got EOF and no data, then return EOF.
- Not sure if filter is allowed to return EOF and add data simultaneously
- Think not, but will bullet proof against it. */
- if (result < 0 || SvCUR(data->datasv) == 0)
- return EOF;
- /* Else there must be at least one byte present, which is good enough */
- }
-
- return *((U8 *) SvPV_nolen (data->datasv) + data->next_out++);
-}
-
-int
-bl_read(struct byteloader_fdata *data, char *buf, size_t size, size_t n)
-{
- dTHX;
- char *start;
- STRLEN len;
- size_t wanted = size * n;
-
- start = SvPV (data->datasv, len);
- if (len < (data->next_out + wanted)) {
- int result;
-
- /* Shuffle data to start of buffer */
- len -= data->next_out;
- if (len) {
- memmove (start, start + data->next_out, len + 1);
- } else {
- *start = '\0'; /* Avoid call to memmove. */
- }
- SvCUR_set(data->datasv, len);
- data->next_out = 0;
-
- /* Attempt to read more data. */
- do {
- result = FILTER_READ (data->idx + 1, data->datasv, BYTELOADER_BUFFER);
-
- start = SvPV (data->datasv, len);
- } while (result > 0 && len < wanted);
- /* Loop while not (EOF || error) and short reads */
-
- /* If not enough data read, truncate copy */
- if (wanted > len)
- wanted = len;
- }
-
- if (wanted > 0) {
- memcpy (buf, start + data->next_out, wanted);
- data->next_out += wanted;
- wanted /= size;
- }
- return (int) wanted;
-}
-
-static I32
-byteloader_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
-{
- OP *saveroot = PL_main_root;
- OP *savestart = PL_main_start;
- struct byteloader_state bstate;
- struct byteloader_fdata data;
- int len;
- (void)buf_sv;
- (void)maxlen;
-
- data.next_out = 0;
- data.datasv = FILTER_DATA(idx);
- data.idx = idx;
-
- bstate.bs_fdata = &data;
- bstate.bs_obj_list = Null(void**);
- bstate.bs_obj_list_fill = -1;
- bstate.bs_sv = Nullsv;
- bstate.bs_iv_overflows = 0;
-
-/* KLUDGE */
- if (byterun(aTHX_ &bstate)
- && (len = SvCUR(data.datasv) - (STRLEN)data.next_out))
- {
- PerlIO_seek(PL_rsfp, -len, SEEK_CUR);
- PL_rsfp = NULL;
- }
- filter_del(byteloader_filter);
-
- if (PL_in_eval) {
- OP *o;
-
- PL_eval_start = PL_main_start;
-
- o = newSVOP(OP_CONST, 0, newSViv(1));
- PL_eval_root = newLISTOP(OP_LINESEQ, 0, PL_main_root, o);
- PL_main_root->op_next = o;
- PL_eval_root = newUNOP(OP_LEAVEEVAL, 0, PL_eval_root);
- o->op_next = PL_eval_root;
-
- PL_main_root = saveroot;
- PL_main_start = savestart;
- }
-
- return 0;
-}
-
-MODULE = ByteLoader PACKAGE = ByteLoader
-
-PROTOTYPES: ENABLE
-
-void
-import(package="ByteLoader", ...)
- char *package
- PREINIT:
- SV *sv = newSVpvn ("", 0);
- PPCODE:
- if (!sv)
- croak ("Could not allocate ByteLoader buffers");
- filter_add(byteloader_filter, sv);
+++ /dev/null
-use ExtUtils::MakeMaker;
-
-WriteMakefile(
- NAME => 'ByteLoader',
- VERSION_FROM => 'ByteLoader.pm',
- XSPROTOARG => '-noprototypes',
- MAN3PODS => {}, # Pods will be built by installman.
- OBJECT => 'byterun$(OBJ_EXT) ByteLoader$(OBJ_EXT)',
-);
+++ /dev/null
-typedef char *pvcontents;
-typedef char *strconst;
-typedef U32 PV;
-typedef char *op_tr_array;
-typedef int comment_t;
-typedef SV *svindex;
-typedef OP *opindex;
-typedef char *pvindex;
-
-#define BGET_FREAD(argp, len, nelem) \
- bl_read(bstate->bs_fdata,(char*)(argp),(len),(nelem))
-#define BGET_FGETC() bl_getc(bstate->bs_fdata)
-
-/* all this should be made endianness-agnostic */
-
-#define BGET_U8(arg) STMT_START { \
- const int _arg = BGET_FGETC(); \
- if (_arg < 0) { \
- Perl_croak(aTHX_ \
- "EOF or error while trying to read 1 byte for U8"); \
- } \
- arg = (U8) _arg; \
- } STMT_END
-
-#define BGET_U16(arg) BGET_OR_CROAK(arg, U16)
-#define BGET_I32(arg) BGET_OR_CROAK(arg, U32)
-#define BGET_U32(arg) BGET_OR_CROAK(arg, U32)
-#define BGET_IV(arg) BGET_OR_CROAK(arg, IV)
-#define BGET_PADOFFSET(arg) BGET_OR_CROAK(arg, PADOFFSET)
-#define BGET_long(arg) BGET_OR_CROAK(arg, long)
-#define BGET_svtype(arg) BGET_OR_CROAK(arg, svtype)
-
-#define BGET_OR_CROAK(arg, type) STMT_START { \
- if (BGET_FREAD(&arg, sizeof(type), 1) < 1) { \
- Perl_croak(aTHX_ \
- "EOF or error while trying to read %d bytes for %s", \
- sizeof(type), STRINGIFY(type)); \
- } \
- } STMT_END
-
-#define BGET_PV(arg) STMT_START { \
- BGET_U32(arg); \
- if (arg) { \
- Newx(bstate->bs_pv.pvx, arg, char); \
- bl_read(bstate->bs_fdata, bstate->bs_pv.pvx, arg, 1); \
- bstate->bs_pv.xpv.xpv_len = arg; \
- bstate->bs_pv.xpv.xpv_cur = arg - 1; \
- } else { \
- bstate->bs_pv.pvx = 0; \
- bstate->bs_pv.xpv.xpv_len = 0; \
- bstate->bs_pv.xpv.xpv_cur = 0; \
- } \
- } STMT_END
-
-#ifdef BYTELOADER_LOG_COMMENTS
-# define BGET_comment_t(arg) \
- STMT_START { \
- char buf[1024]; \
- int i = 0; \
- do { \
- arg = BGET_FGETC(); \
- buf[i++] = (char)arg; \
- } while (arg != '\n' && arg != EOF); \
- buf[i] = '\0'; \
- PerlIO_printf(PerlIO_stderr(), "%s", buf); \
- } STMT_END
-#else
-# define BGET_comment_t(arg) \
- do { arg = BGET_FGETC(); } while (arg != '\n' && arg != EOF)
-#endif
-
-
-#define BGET_op_tr_array(arg) do { \
- unsigned short *ary, len; \
- BGET_U16(len); \
- Newx(ary, len, unsigned short); \
- BGET_FREAD(ary, sizeof(unsigned short), len); \
- arg = (char *) ary; \
- } while (0)
-
-#define BGET_pvcontents(arg) arg = bstate->bs_pv.pvx
-#define BGET_strconst(arg) STMT_START { \
- for (arg = PL_tokenbuf; (*arg = BGET_FGETC()); arg++) /* nothing */; \
- arg = PL_tokenbuf; \
- } STMT_END
-
-#define BGET_NV(arg) STMT_START { \
- char *str; \
- BGET_strconst(str); \
- arg = Atof(str); \
- } STMT_END
-
-#define BGET_objindex(arg, type) STMT_START { \
- BGET_U32(ix); \
- arg = (type)bstate->bs_obj_list[ix]; \
- } STMT_END
-#define BGET_svindex(arg) BGET_objindex(arg, svindex)
-#define BGET_opindex(arg) BGET_objindex(arg, opindex)
-#define BGET_pvindex(arg) STMT_START { \
- BGET_objindex(arg, pvindex); \
- arg = arg ? savepv(arg) : arg; \
- } STMT_END
-
-#define BSET_ldspecsv(sv, arg) STMT_START { \
- if(arg >= sizeof(specialsv_list) / sizeof(specialsv_list[0])) { \
- Perl_croak(aTHX_ "Out of range special SV number %d", arg); \
- } \
- sv = specialsv_list[arg]; \
- } STMT_END
-
-#define BSET_ldspecsvx(sv, arg) STMT_START { \
- BSET_ldspecsv(sv, arg); \
- BSET_OBJ_STOREX(sv); \
- } STMT_END
-
-#define BSET_stpv(pv, arg) STMT_START { \
- BSET_OBJ_STORE(pv, arg); \
- SAVEFREEPV(pv); \
- } STMT_END
-
-#define BSET_sv_refcnt_add(svrefcnt, arg) svrefcnt += arg
-#define BSET_gp_refcnt_add(gprefcnt, arg) gprefcnt += arg
-#define BSET_gp_share(sv, arg) STMT_START { \
- gp_free((GV*)sv); \
- GvGP(sv) = GvGP(arg); \
- } STMT_END
-
-#define BSET_gv_fetchpv(sv, arg) sv = (SV*)gv_fetchpv(arg, TRUE, SVt_PV)
-#define BSET_gv_fetchpvx(sv, arg) STMT_START { \
- BSET_gv_fetchpv(sv, arg); \
- BSET_OBJ_STOREX(sv); \
- } STMT_END
-
-#define BSET_gv_stashpv(sv, arg) sv = (SV*)gv_stashpv(arg, TRUE)
-#define BSET_gv_stashpvx(sv, arg) STMT_START { \
- BSET_gv_stashpv(sv, arg); \
- BSET_OBJ_STOREX(sv); \
- } STMT_END
-
-#define BSET_sv_magic(sv, arg) sv_magic(sv, Nullsv, arg, 0, 0)
-#define BSET_mg_name(mg, arg) mg->mg_ptr = arg; mg->mg_len = bstate->bs_pv.xpv.xpv_cur
-#define BSET_mg_namex(mg, arg) \
- (mg->mg_ptr = (char*)SvREFCNT_inc((SV*)arg), \
- mg->mg_len = HEf_SVKEY)
-#define BSET_xmg_stash(sv, arg) *(SV**)&(((XPVMG*)SvANY(sv))->xmg_stash) = (arg)
-#define BSET_sv_upgrade(sv, arg) (void)SvUPGRADE(sv, arg)
-#define BSET_xrv(sv, arg) SvRV_set(sv, arg)
-#define BSET_xpv(sv) do { \
- SvPV_set(sv, bstate->bs_pv.pvx); \
- SvCUR_set(sv, bstate->bs_pv.xpv.xpv_cur); \
- SvLEN_set(sv, bstate->bs_pv.xpv.xpv_len); \
- } while (0)
-#define BSET_xpv_cur(sv, arg) SvCUR_set(sv, arg)
-#define BSET_xpv_len(sv, arg) SvLEN_set(sv, arg)
-#define BSET_xiv(sv, arg) SvIV_set(sv, arg)
-#define BSET_xnv(sv, arg) SvNV_set(sv, arg)
-
-#define BSET_av_extend(sv, arg) av_extend((AV*)sv, arg)
-
-#define BSET_av_push(sv, arg) av_push((AV*)sv, arg)
-#define BSET_av_pushx(sv, arg) (AvARRAY(sv)[++AvFILLp(sv)] = arg)
-#define BSET_hv_store(sv, arg) \
- hv_store((HV*)sv, bstate->bs_pv.pvx, bstate->bs_pv.xpv.xpv_cur, arg, 0)
-#define BSET_pv_free(p) Safefree(p)
-
-
-#ifdef USE_ITHREADS
-
-/* copied after the code in newPMOP() */
-#define BSET_pregcomp(o, arg) \
- STMT_START { \
- SV* repointer; \
- REGEXP* rx = arg ? \
- CALLREGCOMP(aTHX_ arg, arg + bstate->bs_pv.xpv.xpv_cur, cPMOPx(o)) : \
- Null(REGEXP*); \
- if(av_len((AV*) PL_regex_pad[0]) > -1) { \
- repointer = av_pop((AV*)PL_regex_pad[0]); \
- cPMOPx(o)->op_pmoffset = SvIV(repointer); \
- SvREPADTMP_off(repointer); \
- sv_setiv(repointer,PTR2IV(rx)); \
- } else { \
- repointer = newSViv(PTR2IV(rx)); \
- av_push(PL_regex_padav,SvREFCNT_inc(repointer)); \
- cPMOPx(o)->op_pmoffset = av_len(PL_regex_padav); \
- PL_regex_pad = AvARRAY(PL_regex_padav); \
- } \
- } STMT_END
-
-#else
-#define BSET_pregcomp(o, arg) \
- STMT_START { \
- PM_SETRE(((PMOP*)o), (arg ? \
- CALLREGCOMP(aTHX_ arg, arg + bstate->bs_pv.xpv.xpv_cur, cPMOPx(o)): \
- Null(REGEXP*))); \
- } STMT_END
-
-#endif /* USE_THREADS */
-
-
-#define BSET_newsv(sv, arg) \
- switch(arg) { \
- case SVt_PVAV: \
- sv = (SV*)newAV(); \
- break; \
- case SVt_PVHV: \
- sv = (SV*)newHV(); \
- break; \
- default: \
- sv = newSV(0); \
- SvUPGRADE(sv, (arg)); \
- }
-#define BSET_newsvx(sv, arg) STMT_START { \
- BSET_newsv(sv, (svtype)(arg & SVTYPEMASK)); \
- SvFLAGS(sv) = arg; \
- BSET_OBJ_STOREX(sv); \
- } STMT_END
-
-#define BSET_newop(o, arg) NewOpSz(666, o, arg)
-#define BSET_newopx(o, arg) STMT_START { \
- register int sz = arg & 0x7f; \
- register OP* newop; \
- BSET_newop(newop, sz); \
- /* newop->op_next = o; XXX */ \
- o = newop; \
- arg >>=7; \
- BSET_op_type(o, arg); \
- BSET_OBJ_STOREX(o); \
- } STMT_END
-
-#define BSET_newopn(o, arg) STMT_START { \
- OP *oldop = o; \
- BSET_newop(o, arg); \
- oldop->op_next = o; \
- } STMT_END
-
-#define BSET_ret(foo) STMT_START { \
- Safefree(bstate->bs_obj_list); \
- return 0; \
- } STMT_END
-
-#define BSET_op_pmstashpv(op, arg) PmopSTASHPV_set(op, arg)
-
-/*
- * stolen from toke.c: better if that was a function.
- * in toke.c there are also #ifdefs for dosish systems and i/o layers
- */
-
-#if defined(HAS_FCNTL) && defined(F_SETFD)
-#define set_clonex(fp) \
- STMT_START { \
- int fd = PerlIO_fileno(fp); \
- fcntl(fd,F_SETFD,fd >= 3); \
- } STMT_END
-#else
-#define set_clonex(fp)
-#endif
-
-#define BSET_data(dummy,arg) \
- STMT_START { \
- GV *gv; \
- char *pname = "main"; \
- if (arg == 'D') \
- pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash); \
- gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);\
- GvMULTI_on(gv); \
- if (!GvIO(gv)) \
- GvIOp(gv) = newIO(); \
- IoIFP(GvIOp(gv)) = PL_rsfp; &n
https://perl5.git.perl.org / perl5.git / commitdiff