From de1254415ffeb03ba71a0802be6f212b10153304 Mon Sep 17 00:00:00 2001 From: Rafael Garcia-Suarez Date: Wed, 6 Sep 2006 14:04:33 +0000 Subject: [PATCH] Remove perlcc and the byteloader p4raw-id: //depot/perl@28790 --- MANIFEST | 39 +- Makefile.SH | 29 +- NetWare/Makefile | 1 - bytecode.pl | 169 +-- configure.com | 1 - ext/B/B/Asmdata.pm | 2 +- ext/B/B/Assembler.pm | 332 ------ ext/B/B/Bblock.pm | 224 ---- ext/B/B/Bytecode.pm | 890 ---------------- ext/B/B/C.pm | 2236 --------------------------------------- ext/B/B/CC.pm | 2005 ----------------------------------- ext/B/B/Disassembler.pm | 233 ---- ext/B/B/Stackobj.pm | 349 ------ ext/B/B/Stash.pm | 52 - ext/B/B/assemble | 30 - ext/B/B/cc_harness | 12 - ext/B/B/disassemble | 22 - ext/B/B/makeliblinks | 54 - ext/B/C/C.xs | 53 - ext/B/C/Makefile.PL | 8 - ext/B/NOTES | 168 --- ext/B/README | 325 ------ ext/B/TESTS | 78 -- ext/B/Todo | 37 - ext/B/ramblings/cc.notes | 32 - ext/B/ramblings/curcop.runtime | 39 - ext/B/ramblings/flip-flop | 54 - ext/B/ramblings/magic | 93 -- ext/B/ramblings/reg.alloc | 32 - ext/B/ramblings/runtime.porting | 357 ------- ext/B/t/asmdata.t | 53 - ext/B/t/assembler.t | 391 ------- ext/B/t/bblock.t | 21 - ext/B/t/bytecode.t | 167 --- ext/B/t/stash.t | 99 -- ext/ByteLoader/ByteLoader.pm | 40 - ext/ByteLoader/ByteLoader.xs | 135 --- ext/ByteLoader/Makefile.PL | 9 - ext/ByteLoader/bytecode.h | 435 -------- ext/ByteLoader/byterun.c | 1121 -------------------- ext/ByteLoader/byterun.h | 204 ---- ext/ByteLoader/hints/sunos.pl | 2 - ext/threads/shared/typemap | 0 pod/Makefile.SH | 6 - pod/perlcompile.pod | 170 +-- regen.pl | 4 +- t/TEST | 94 -- t/harness | 40 +- t/lib/1_compile.t | 3 - utils.lst | 1 - utils/Makefile | 21 +- utils/perlcc.PL | 691 ------------ vms/descrip_mms.template | 6 +- win32/Makefile | 3 +- win32/makefile.mk | 3 +- win32/pod.mak | 6 - x2p/Makefile.SH | 3 - 57 files changed, 21 insertions(+), 11663 deletions(-) delete mode 100644 ext/B/B/Assembler.pm delete mode 100644 ext/B/B/Bblock.pm delete mode 100644 ext/B/B/Bytecode.pm delete mode 100644 ext/B/B/C.pm delete mode 100644 ext/B/B/CC.pm delete mode 100644 ext/B/B/Disassembler.pm delete mode 100644 ext/B/B/Stackobj.pm delete mode 100644 ext/B/B/Stash.pm delete mode 100755 ext/B/B/assemble delete mode 100644 ext/B/B/cc_harness delete mode 100755 ext/B/B/disassemble delete mode 100644 ext/B/B/makeliblinks delete mode 100644 ext/B/C/C.xs delete mode 100644 ext/B/C/Makefile.PL delete mode 100644 ext/B/NOTES delete mode 100644 ext/B/README delete mode 100644 ext/B/TESTS delete mode 100644 ext/B/Todo delete mode 100644 ext/B/ramblings/cc.notes delete mode 100644 ext/B/ramblings/curcop.runtime delete mode 100644 ext/B/ramblings/flip-flop delete mode 100644 ext/B/ramblings/magic delete mode 100644 ext/B/ramblings/reg.alloc delete mode 100644 ext/B/ramblings/runtime.porting delete mode 100644 ext/B/t/asmdata.t delete mode 100644 ext/B/t/assembler.t delete mode 100644 ext/B/t/bblock.t delete mode 100644 ext/B/t/bytecode.t delete mode 100755 ext/B/t/stash.t delete mode 100644 ext/ByteLoader/ByteLoader.pm delete mode 100644 ext/ByteLoader/ByteLoader.xs delete mode 100644 ext/ByteLoader/Makefile.PL delete mode 100644 ext/ByteLoader/bytecode.h delete mode 100644 ext/ByteLoader/byterun.c delete mode 100644 ext/ByteLoader/byterun.h delete mode 100644 ext/ByteLoader/hints/sunos.pl delete mode 100644 ext/threads/shared/typemap delete mode 100644 utils/perlcc.PL diff --git a/MANIFEST b/MANIFEST index fa8a6d0..01b20bc 100644 --- a/MANIFEST +++ b/MANIFEST @@ -7,7 +7,7 @@ av.h Array value header 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 @@ -70,58 +70,30 @@ ext/attrs/attrs.xs attrs extension external subroutines ext/attrs/Makefile.PL attrs extension makefile writer ext/attrs/t/attrs.t See if attrs works with C 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 @@ -133,17 +105,9 @@ ext/B/t/optree_specials.t BEGIN, END, etc code 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 @@ -3612,7 +3576,6 @@ utils/libnetcfg.PL libnet 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 diff --git a/Makefile.SH b/Makefile.SH index 099fed2..999bd95 100644 --- a/Makefile.SH +++ b/Makefile.SH @@ -443,13 +443,7 @@ all: $(FIRSTMAKEFILE) miniperl$(EXE_EXT) extra.pods $(private) $(unidatafiles) $ @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 @@ -894,13 +888,6 @@ no-install: 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 @@ -963,8 +950,6 @@ CHMOD_W = chmod +w # 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! *] @@ -982,8 +967,7 @@ CHMOD_W = chmod +w 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 @@ -1084,7 +1068,6 @@ _tidy: -@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 @@ -1111,7 +1094,6 @@ _cleaner2: 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 @@ -1169,7 +1151,7 @@ makedepend: makedepend.SH config.sh 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 @@ -1268,11 +1250,6 @@ utest.third ucheck.third: test_prep.third perl.third 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 diff --git a/NetWare/Makefile b/NetWare/Makefile index 96e2657..adf617c 100644 --- a/NetWare/Makefile +++ b/NetWare/Makefile @@ -669,7 +669,6 @@ UTILS = \ ..\utils\c2ph \ ..\utils\h2xs \ ..\utils\perldoc \ - ..\utils\perlcc \ ..\pod\checkpods \ ..\pod\pod2html \ ..\pod\pod2latex \ diff --git a/bytecode.pl b/bytecode.pl index cbbdefa..95b5b12 100644 --- a/bytecode.pl +++ b/bytecode.pl @@ -39,7 +39,7 @@ EOT 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 @@ -66,79 +66,12 @@ print ASMDATA_PM <<"EOT"; # 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 () { if (/^\s*#/) { - print BYTERUN_C if /^\s*#\s*(?:if|endif|el)/; next; } chop; @@ -159,26 +92,6 @@ while () { $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"; @@ -190,82 +103,6 @@ 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'; @@ -283,7 +120,7 @@ __END__ =head1 NAME -B::Asmdata - Autogenerated data about Perl ops, used to generate bytecode +B::Asmdata - Autogenerated data about Perl ops =head1 SYNOPSIS @@ -346,8 +183,6 @@ EOT 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) diff --git a/configure.com b/configure.com index 45a69a1..b9e94f0 100644 --- a/configure.com +++ b/configure.com @@ -6989,7 +6989,6 @@ $ WRITE CONFIG "$ h2xs == """ + perl_setup_perl + " ''vms_prefix':[utils]h $ 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""" diff --git a/ext/B/B/Asmdata.pm b/ext/B/B/Asmdata.pm index f9dd98c..1cdbe13 100644 --- a/ext/B/B/Asmdata.pm +++ b/ext/B/B/Asmdata.pm @@ -187,7 +187,7 @@ __END__ =head1 NAME -B::Asmdata - Autogenerated data about Perl ops, used to generate bytecode +B::Asmdata - Autogenerated data about Perl ops =head1 SYNOPSIS diff --git a/ext/B/B/Assembler.pm b/ext/B/B/Assembler.pm deleted file mode 100644 index 461b9ebb..0000000 --- a/ext/B/B/Assembler.pm +++ /dev/null @@ -1,332 +0,0 @@ -# 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 <(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. - -=head1 AUTHORS - -Malcolm Beattie, C -Per-statement interface by Benjamin Stuhl, C - -=cut diff --git a/ext/B/B/Bblock.pm b/ext/B/B/Bblock.pm deleted file mode 100644 index ade8181..0000000 --- a/ext/B/B/Bblock.pm +++ /dev/null @@ -1,224 +0,0 @@ -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 - - 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 - -=cut diff --git a/ext/B/B/Bytecode.pm b/ext/B/B/Bytecode.pm deleted file mode 100644 index 4a81abc..0000000 --- a/ext/B/B/Bytecode.pm +++ /dev/null @@ -1,890 +0,0 @@ -# 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 ""; - 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[B<,-H>][B<,-o>I] I - -=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 -other files (ex. C) are saved. - -=item B<-H> - -prepend a C line to the produced bytecode. - -=item B<-k> - -keep the syntax tree - it is stripped by default. - -=item B<-o>I - -put the bytecode in instead of dumping it to STDOUT. - -=item B<-s> - -scan the script for C<# line ..> directives and for -expressions. When gotos are found keep the syntax tree. - -=back - -=head1 KNOWN BUGS - -=over 4 - -=item * - -C won't even compile. - -=item * - -C and C 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 and -modified by Benjamin Stuhl . - -Rewritten by Enache Adrian , 2003 a.d. - -=cut diff --git a/ext/B/B/C.pm b/ext/B/B/C.pm deleted file mode 100644 index 17ca257..0000000 --- a/ext/B/B/C.pm +++ /dev/null @@ -1,2236 +0,0 @@ -# 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 <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/, <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/, <add( split /\n/, <FILL + 1 - 1; # first is an avref - - print < $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 "::" && &$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) where package C does not contain any subs. - -=item B<-D> - -Debug options (concatenated or separate flags like C). - -=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. - -=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 lives in the C subdirectory of your perl -library directory. The utility called C 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 - -=cut diff --git a/ext/B/B/CC.pm b/ext/B/B/CC.pm deleted file mode 100644 index 43064fb..0000000 --- a/ext/B/B/CC.pm +++ /dev/null @@ -1,2005 +0,0 @@ -# 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 compiler backend--see F) 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) where package C 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). - -=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). - -=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 lives in the C subdirectory of your perl -library directory. The utility called C 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 - -=cut diff --git a/ext/B/B/Disassembler.pm b/ext/B/B/Disassembler.pm deleted file mode 100644 index e1993aa..0000000 --- a/ext/B/B/Disassembler.pm +++ /dev/null @@ -1,233 +0,0 @@ -# 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. - -=head1 AUTHOR - -Malcolm Beattie, C - -=cut diff --git a/ext/B/B/Stackobj.pm b/ext/B/B/Stackobj.pm deleted file mode 100644 index b17dfb8..0000000 --- a/ext/B/B/Stackobj.pm +++ /dev/null @@ -1,349 +0,0 @@ -# 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. - -=head1 AUTHOR - -Malcolm Beattie, C - -=cut diff --git a/ext/B/B/Stash.pm b/ext/B/B/Stash.pm deleted file mode 100644 index 5e60868..0000000 --- a/ext/B/B/Stash.pm +++ /dev/null @@ -1,52 +0,0 @@ -# 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 ""?():$_;} @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; diff --git a/ext/B/B/assemble b/ext/B/B/assemble deleted file mode 100755 index 43cc5bc..0000000 --- a/ext/B/B/assemble +++ /dev/null @@ -1,30 +0,0 @@ -use B::Assembler qw(assemble_fh); -use FileHandle; - -my ($filename, $fh, $out); - -if ($ARGV[0] eq "-d") { - B::Assembler::debug(1); - shift; -} - -$out = \*STDOUT; - -if (@ARGV == 0) { - $fh = \*STDIN; - $filename = "-"; -} elsif (@ARGV == 1) { - $filename = $ARGV[0]; - $fh = new FileHandle "<$filename"; -} elsif (@ARGV == 2) { - $filename = $ARGV[0]; - $fh = new FileHandle "<$filename"; - $out = new FileHandle ">$ARGV[1]"; -} else { - die "Usage: assemble [filename] [outfilename]\n"; -} - -binmode $out; -$SIG{__WARN__} = sub { warn "$filename:@_" }; -$SIG{__DIE__} = sub { die "$filename: @_" }; -assemble_fh($fh, sub { print $out @_ }); diff --git a/ext/B/B/cc_harness b/ext/B/B/cc_harness deleted file mode 100644 index 79f8727..0000000 --- a/ext/B/B/cc_harness +++ /dev/null @@ -1,12 +0,0 @@ -use Config; - -$libdir = $ENV{PERL_SRC} || "$Config{installarchlib}/CORE"; - -if (!grep(/^-[cS]$/, @ARGV)) { - $linkargs = sprintf("%s $libdir/$Config{libperl} %s", - @Config{qw(ldflags libs)}); -} - -$cccmd = "$Config{cc} $Config{ccflags} -I$libdir @ARGV $linkargs"; -print "$cccmd\n"; -exec $cccmd; diff --git a/ext/B/B/disassemble b/ext/B/B/disassemble deleted file mode 100755 index 6530b80..0000000 --- a/ext/B/B/disassemble +++ /dev/null @@ -1,22 +0,0 @@ -use B::Disassembler qw(disassemble_fh); -use FileHandle; - -my $fh; -if (@ARGV == 0) { - $fh = \*STDIN; -} elsif (@ARGV == 1) { - $fh = new FileHandle "<$ARGV[0]"; -} else { - die "Usage: disassemble [filename]\n"; -} - -sub print_insn { - my ($insn, $arg) = @_; - if (defined($arg)) { - printf "%s %s\n", $insn, $arg; - } else { - print $insn, "\n"; - } -} - -disassemble_fh($fh, \&print_insn); diff --git a/ext/B/B/makeliblinks b/ext/B/B/makeliblinks deleted file mode 100644 index 8256078..0000000 --- a/ext/B/B/makeliblinks +++ /dev/null @@ -1,54 +0,0 @@ -use File::Find; -use Config; - -if (@ARGV != 2) { - warn <<"EOT"; -Usage: makeliblinks libautodir targetdir -where libautodir is the architecture-dependent auto directory -(e.g. $Config::Config{archlib}/auto). -EOT - exit 2; -} - -my ($libautodir, $targetdir) = @ARGV; - -# Calculate relative path prefix from $targetdir to $libautodir -sub relprefix { - my ($to, $from) = @_; - my $up; - for ($up = 0; substr($to, 0, length($from)) ne $from; $up++) { - $from =~ s( - [^/]+ (?# a group of non-slashes) - /* (?# maybe with some trailing slashes) - $ (?# at the end of the path) - )()x; - } - return (("../" x $up) . substr($to, length($from))); -} - -my $relprefix = relprefix($libautodir, $targetdir); - -my ($dlext, $lib_ext) = @Config::Config{qw(dlext lib_ext)}; - -sub link_if_library { - if (/\.($dlext|$lib_ext)$/o) { - my $ext = $1; - my $name = $File::Find::name; - if (substr($name, 0, length($libautodir) + 1) ne "$libautodir/") { - die "directory of $name doesn't match $libautodir\n"; - } - substr($name, 0, length($libautodir) + 1) = ''; - my @parts = split(m(/), $name); - if ($parts[-1] ne "$parts[-2].$ext") { - die "module name $_ doesn't match its directory $libautodir\n"; - } - pop @parts; - my $libpath = "$targetdir/lib" . join("__", @parts) . ".$ext"; - print "$libpath -> $relprefix/$name\n"; - symlink("$relprefix/$name", $libpath) - or warn "above link failed with error: $!\n"; - } -} - -find(\&link_if_library, $libautodir); -exit 0; diff --git a/ext/B/C/C.xs b/ext/B/C/C.xs deleted file mode 100644 index b7fb7fa..0000000 --- a/ext/B/C/C.xs +++ /dev/null @@ -1,53 +0,0 @@ -#include -#include -#include - -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; diff --git a/ext/B/C/Makefile.PL b/ext/B/C/Makefile.PL deleted file mode 100644 index 7291b33..0000000 --- a/ext/B/C/Makefile.PL +++ /dev/null @@ -1,8 +0,0 @@ -#!perl - -use ExtUtils::MakeMaker; - -WriteMakefile( NAME => 'B::C', - VERSION_FROM => '../B/C.pm' - ); - diff --git a/ext/B/NOTES b/ext/B/NOTES deleted file mode 100644 index 89d03ba..0000000 --- a/ext/B/NOTES +++ /dev/null @@ -1,168 +0,0 @@ -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. diff --git a/ext/B/README b/ext/B/README deleted file mode 100644 index fa3f085..0000000 --- a/ext/B/README +++ /dev/null @@ -1,325 +0,0 @@ - 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 diff --git a/ext/B/TESTS b/ext/B/TESTS deleted file mode 100644 index e050f6c..0000000 --- a/ext/B/TESTS +++ /dev/null @@ -1,78 +0,0 @@ -Test results from compiling t/*/*.t - C Bytecode CC - -base/cond.t OK ok OK -base/if.t OK ok OK -base/lex.t OK ok OK -base/pat.t OK ok OK -base/term.t OK ok OK -cmd/elsif.t OK ok OK -cmd/for.t OK ok ok 1, 2, 3, panic: pp_iter -cmd/mod.t OK ok ok -cmd/subval.t OK ok 1..34, not ok 27,28 (simply - because filename changes). -cmd/switch.t OK ok ok -cmd/while.t OK ok ok -io/argv.t OK ok ok -io/dup.t OK ok ok -io/fs.t OK ok ok -io/inplace.t OK ok ok -io/pipe.t OK ok ok with -umain -io/print.t OK ok ok -io/tell.t OK ok ok -op/append.t OK ok OK -op/array.t OK ok 1..36, not ok 7,10 (no $[) -op/auto.t OK ok OK -op/chop.t OK ok OK -op/cond.t OK ok OK -op/delete.t OK ok OK -op/do.t OK ok OK -op/each.t OK ok OK -op/eval.t OK ok ok 1-6 of 16 then exits -op/exec.t OK ok OK -op/exp.t OK ok OK -op/flip.t OK ok OK -op/fork.t OK ok OK -op/glob.t OK ok OK -op/goto.t OK ok 1..9, Can't find label label1. -op/groups.t OK (s/ucb/bin/ under Linux) OK 1..0 for now. -op/index.t OK ok OK -op/int.t OK ok OK -op/join.t OK ok OK -op/list.t OK ok OK -op/local.t OK ok OK -op/magic.t OK ok OK -op/misc.t no DATA filehandle so succeeds trivially with 1..0 -op/mkdir.t OK ok OK -op/my.t OK ok OK -op/oct.t OK ok OK (C large const warnings) -op/ord.t OK ok OK -op/overload.t Mostly not ok Mostly not ok C errors. -op/pack.t OK ok OK -op/pat.t omit 26 (reset) ok [lots of memory for compile] -op/push.t OK ok OK -op/quotemeta.t OK ok OK -op/rand.t OK ok -op/range.t OK ok OK -op/read.t OK ok OK -op/readdir.t OK ok OK (substcont works too) -op/ref.t omits "ok 40" (lex destruction) ok (Bytecode) - CC: need -u for OBJ,BASEOBJ, - UNIVERSAL,WHATEVER,main. - 1..41, ok1-33,36-38, - then ok 41, ok 39.DESTROY probs -op/regexp.t OK ok ok (trivially all eval'd) -op/repeat.t OK ok ok -op/sleep.t OK ok ok -op/sort.t OK ok 1..10, ok 1, Out of memory! -op/split.t OK ok ok -op/sprintf.t OK ok ok -op/stat.t OK ok ok -op/study.t OK ok ok -op/subst.t OK ok ok -op/substr.t OK ok ok1-22 except 7-9,11 (all $[) -op/time.t OK ok ok -op/undef.t omit 21 ok ok -op/unshift.t OK ok ok -op/vec.t OK ok ok -op/write.t not ok 3 (no CvOUTSIDE lex from runtime eval). CC: 1..3, hang diff --git a/ext/B/Todo b/ext/B/Todo deleted file mode 100644 index 495be2e..0000000 --- a/ext/B/Todo +++ /dev/null @@ -1,37 +0,0 @@ -* Fixes - -CC backend: goto, sort with non-default comparison. last for non-loop blocks. -Version checking -improve XSUB handling (both static and dynamic) -sv_magic can do SvREFCNT_inc(obj) which messes up precalculated refcounts -allocation of XPV[INAHC]V structures needs fixing: Perl tries to free -them whereas the compiler expects them to be linked to a xpv[inahc]v_root -list the same as X[IPR]V structures. -ref counts -perl_parse replacement -fix cstring for long strings -compile-time initialisation of AvARRAYs -signed/unsigned problems with NV (and IV?) initialisation and elsewhere? -CvOUTSIDE for ordinary subs -DATA filehandle for standalone Bytecode program (easy) -DATA filehandle for multiple bytecode-compiled modules (harder) -DATA filehandle for C-compiled program (yet harder) - -* Features - -type checking -compile time v. runtime initialisation -save PMOPs in compiled form -selection of what to dump -options for cutting out line info etc. -comment output -shared constants -module dependencies - -* Optimisations -collapse LISTOPs to UNOPs or BASEOPs -compile-time qw(), constant subs -global analysis of variables, type hints etc. -demand-loaded bytecode (leader of each basic block replaced by an op -which loads in bytecode for its block) -fast sub calls for CC backend diff --git a/ext/B/ramblings/cc.notes b/ext/B/ramblings/cc.notes deleted file mode 100644 index 47bd65a..0000000 --- a/ext/B/ramblings/cc.notes +++ /dev/null @@ -1,32 +0,0 @@ -At entry to each basic block, the following can be assumed (and hence -must be forced where necessary at the end of each basic block): - -The shadow stack @stack is empty. -For each lexical object in @pad, VALID_IV holds for each T_INT, -VALID_DOUBLE holds for each T_DOUBLE and VALID_SV holds otherwise. -The C shadow variable sp holds the stack pointer (not necessarily stack_sp). - -write_back_stack - Writes the contents of the shadow stack @stack back to the real stack. - A write-back of each object in the stack is forced so that its - backing SV contains the right value and that SV is then pushed onto the - real stack. On return, @stack is empty. - -write_back_lexicals - Forces a write-back (i.e. achieves VALID_SV), where necessary, for each - lexical object in @pad. Objects with the TEMPORARY flag are skipped. If - write_back_lexicals is called with an (optional) argument, then it is - taken to be a bitmask of more flags: any lexical object with one of those - flags set is also skipped and not written back to its SV. - -invalidate_lexicals($avoid) - The VALID_INT and VALID_DOUBLE flags are turned off for each lexical - object in @pad whose flags field doesn't overlap with $avoid. - -reload_lexicals - For each necessary lexical object in @pad, makes sure that VALID_IV - holds for objects of type T_INT, VALID_DOUBLE holds for objects for - type T_DOUBLE, and VALID_SV holds for other objects. An object is - considered for reloading if its flags field does not overlap with the - (optional) argument passed to reload_lexicals. - diff --git a/ext/B/ramblings/curcop.runtime b/ext/B/ramblings/curcop.runtime deleted file mode 100644 index 9b8b7d5..0000000 --- a/ext/B/ramblings/curcop.runtime +++ /dev/null @@ -1,39 +0,0 @@ -PP code uses of curcop ----------------------- - -pp_rv2gv - when a new glob is created for an OPpLVAL_INTRO, - curcop->cop_line is stored as GvLINE() in the new GP. -pp_bless - curcop->cop_stash is used as the stash in the one-arg form of bless - -pp_repeat - tests (curcop != &compiling) to warn "Can't x= to readonly value" - -pp_pos -pp_substr -pp_index -pp_rindex -pp_aslice -pp_lslice -pp_splice - curcop->cop_arybase - -pp_sort - curcop->cop_stash used to determine whether to gv_fetchpv $a and $b - -pp_caller - tests (curcop->cop_stash == debstash) to determine whether - to set DB::args - -pp_reset - resets vars in curcop->cop_stash - -pp_dbstate - sets curcop = (COP*)op - -doeval - compiles into curcop->cop_stash - -pp_nextstate - sets curcop = (COP*)op diff --git a/ext/B/ramblings/flip-flop b/ext/B/ramblings/flip-flop deleted file mode 100644 index e08333d..0000000 --- a/ext/B/ramblings/flip-flop +++ /dev/null @@ -1,54 +0,0 @@ -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: -... diff --git a/ext/B/ramblings/magic b/ext/B/ramblings/magic deleted file mode 100644 index e41930a..0000000 --- a/ext/B/ramblings/magic +++ /dev/null @@ -1,93 +0,0 @@ -sv_magic() ----------- -av.c -av_store() - Storing a non-undef element into an SMAGICAL array, av, - assigns the equivalent lowercase form of magic (of the first - MAGIC in the chain) to the value (with obj = av, name = 0 and - namlen = array index). - -gv.c -gv_init() - Initialising gv assigns '*' magic to it with obj = gv, name = - GvNAME and namlen = GvNAMELEN. -gv_fetchpv() - @ISA gets 'I' magic with obj = gv, zero name and namlen. - %OVERLOAD gets 'A' magic with obj = gv, zero name and namlen. - $1 to $9, $&, $`, $', $+ get '\0' magic with obj = gv, - name = GvNAME and namlen = len ( = 1 presumably). -Gv_AMupdate() - Stashes for overload magic seem to get 'c' magic with obj = 0, - name = &amt and namlen = sizeof(amt). -hv_magic(hv, gv, how) - Gives magic how to hv with obj = gv and zero name and namlen. - -mg.c -mg_copy(sv, nsv, key, klen) - Traverses the magic chain of sv. Upper case forms of magic - (only) are copied across to nsv, preserving obj but using - name = key and namlen = klen. -magic_setpos() - LvTARG of a PVLV gets 'g' magic with obj = name = 0 and namlen = pos. - -op.c -mod() - PVLV operators give magic to their targs with - obj = name = namlen = 0. OP_POS gives '.', OP_VEC gives 'v' - and OP_SUBSTR gives 'x'. - -perl.c -magicname(sym, name, namlen) - Fetches/creates a GV with name sym and gives it '\0' magic - with obj = gv, name and namlen as passed. -init_postdump_symbols() - Elements of the environment get given SVs with 'e' magic. - obj = sv and name and namlen point to the actual string - within env. - -pp.c -pp_av2arylen() - $#foo gives '#' magic to the new SV with obj = av and - name = namlen = 0. -pp_study() - SV gets 'g' magic with obj = name = namlen = 0. -pp_substr() - PVLV gets 'x' magic with obj = name = namlen = 0. -pp_vec() - PVLV gets 'x' magic with obj = name = namlen = 0. - -pp_hot.c -pp_match() - m//g gets 'g' magic with obj = name = namlen = 0. - -pp_sys.c -pp_tie() - sv gets magic with obj = sv and name = namlen = 0. - If an HV or an AV, it gets 'P' magic, otherwise 'q' magic. -pp_dbmopen() - 'P' magic for the HV just as with pp_tie(). -pp_sysread() - If tainting, the buffer SV gets 't' magic with - obj = name = namlen = 0. - -sv.c -sv_setsv() - Doing sv_setsv(dstr, gv) gives '*' magic to dstr with - obj = dstr, name = GvNAME, namlen = GvNAMELEN. - -util.c -fbm_compile() - The PVBM gets 'B' magic with obj = name = namlen = 0 and SvVALID - is set to indicate that the Boyer-Moore table is valid. - magic_setbm() just clears the SvVALID flag. - -hv_magic() ----------- - -gv.c -gv_fetchfile() - With perldb, the HV of a gvfile gv gets 'L' magic with obj = gv. -gv_fetchpv() - %SIG gets 'S' magic with obj = siggv. -init_postdump_symbols() - %ENV gets 'E' magic with obj = envgv. diff --git a/ext/B/ramblings/reg.alloc b/ext/B/ramblings/reg.alloc deleted file mode 100644 index 7fd69f2..0000000 --- a/ext/B/ramblings/reg.alloc +++ /dev/null @@ -1,32 +0,0 @@ -while ($i--) { - foo(); -} -exit - - PP code if i an int register if i an int but not a - (i.e. can't be register (i.e. can be - implicitly invalidated) implicitly invalidated) - nextstate - enterloop - - - loop: - gvsv GV (0xe6078) *i validates i validates i - postdec invalidates $i invalidates $i - and if_false goto out; - i valid; $i invalid i valid; $i invalid - - i valid; $i invalid i valid; $i invalid - nextstate - pushmark - gv GV (0xe600c) *foo - entersub validates $i; invals i - - unstack - goto loop: - - i valid; $i invalid - out: - leaveloop - nextstate - exit diff --git a/ext/B/ramblings/runtime.porting b/ext/B/ramblings/runtime.porting deleted file mode 100644 index 20d05b3..0000000 --- a/ext/B/ramblings/runtime.porting +++ /dev/null @@ -1,357 +0,0 @@ -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 diff --git a/ext/B/t/asmdata.t b/ext/B/t/asmdata.t deleted file mode 100644 index 4e03f23..0000000 --- a/ext/B/t/asmdata.t +++ /dev/null @@ -1,53 +0,0 @@ -#!./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' ); diff --git a/ext/B/t/assembler.t b/ext/B/t/assembler.t deleted file mode 100644 index b00c45c..0000000 --- a/ext/B/t/assembler.t +++ /dev/null @@ -1,391 +0,0 @@ -#!./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 has operand category C: - - 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 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 = ) ){ - $disline = ; - ++$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__ diff --git a/ext/B/t/bblock.t b/ext/B/t/bblock.t deleted file mode 100644 index 4979ea5..0000000 --- a/ext/B/t/bblock.t +++ /dev/null @@ -1,21 +0,0 @@ -#!./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. diff --git a/ext/B/t/bytecode.t b/ext/B/t/bytecode.t deleted file mode 100644 index 3c7d282..0000000 --- a/ext/B/t/bytecode.t +++ /dev/null @@ -1,167 +0,0 @@ -#!./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/, ; - -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__ -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 diff --git a/ext/B/t/stash.t b/ext/B/t/stash.t deleted file mode 100755 index 9d6879b..0000000 --- a/ext/B/t/stash.t +++ /dev/null @@ -1,99 +0,0 @@ -#!./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++; -} - diff --git a/ext/ByteLoader/ByteLoader.pm b/ext/ByteLoader/ByteLoader.pm deleted file mode 100644 index 5ff3c91..0000000 --- a/ext/ByteLoader/ByteLoader.pm +++ /dev/null @@ -1,40 +0,0 @@ -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; - - - or just - - perl -MByteLoader bytecode_file - -=head1 DESCRIPTION - -This module is used to load byte compiled perl code as produced by -C. 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 based on the ideas of Tim Bunce and others. -Many changes by Enache Adrian 2003 a.d. - -=head1 SEE ALSO - -perl(1). - -=cut diff --git a/ext/ByteLoader/ByteLoader.xs b/ext/ByteLoader/ByteLoader.xs deleted file mode 100644 index 679298e..0000000 --- a/ext/ByteLoader/ByteLoader.xs +++ /dev/null @@ -1,135 +0,0 @@ -#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); diff --git a/ext/ByteLoader/Makefile.PL b/ext/ByteLoader/Makefile.PL deleted file mode 100644 index c3cfcc7..0000000 --- a/ext/ByteLoader/Makefile.PL +++ /dev/null @@ -1,9 +0,0 @@ -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)', -); diff --git a/ext/ByteLoader/bytecode.h b/ext/ByteLoader/bytecode.h deleted file mode 100644 index 160ae61..0000000 --- a/ext/ByteLoader/bytecode.h +++ /dev/null @@ -1,435 +0,0 @@ -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; \ - set_clonex(PL_rsfp); \ - /* Mark this internal pseudo-handle as clean */ \ - IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT; \ - if (PL_preprocess) \ - IoTYPE(GvIOp(gv)) = IoTYPE_PIPE; \ - else if ((PerlIO*)PL_rsfp == PerlIO_stdin()) \ - IoTYPE(GvIOp(gv)) = IoTYPE_STD; \ - else \ - IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY; \ - Safefree(bstate->bs_obj_list); \ - return 1; \ - } STMT_END - -/* stolen from op.c */ -#define BSET_load_glob(foo, gv) \ - STMT_START { \ - GV *glob_gv; \ - ENTER; \ - Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, \ - newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv); \ - glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV); \ - GvCV(gv) = GvCV(glob_gv); \ - SvREFCNT_inc((SV*)GvCV(gv)); \ - GvIMPORTED_CV_on(gv); \ - LEAVE; \ - } STMT_END - -/* - * Kludge special-case workaround for OP_MAPSTART - * which needs the ppaddr for OP_GREPSTART. Blech. - */ -#define BSET_op_type(o, arg) STMT_START { \ - o->op_type = arg; \ - if (arg == OP_MAPSTART) \ - arg = OP_GREPSTART; \ - o->op_ppaddr = PL_ppaddr[arg]; \ - } STMT_END -#define BSET_op_ppaddr(o, arg) Perl_croak(aTHX_ "op_ppaddr not yet implemented") -#define BSET_curpad(pad, arg) STMT_START { \ - PL_comppad = (AV *)arg; \ - pad = AvARRAY(arg); \ - } STMT_END - -#ifdef USE_ITHREADS -#define BSET_cop_file(cop, arg) CopFILE_set(cop,arg) -#define BSET_cop_stashpv(cop, arg) CopSTASHPV_set(cop,arg) -#else -/* this works now that Sarathy's changed the CopFILE_set macro to do the SvREFCNT_inc() - -- BKS 6-2-2000 */ -/* that really meant the actual CopFILEGV_set */ -#define BSET_cop_filegv(cop, arg) CopFILEGV_set(cop,arg) -#define BSET_cop_stash(cop,arg) CopSTASH_set(cop,(HV*)arg) -#endif - -/* this is simply stolen from the code in newATTRSUB() */ -#define BSET_push_begin(ary,cv) \ - STMT_START { \ - I32 oldscope = PL_scopestack_ix; \ - ENTER; \ - SAVECOPFILE(&PL_compiling); \ - SAVECOPLINE(&PL_compiling); \ - if (!PL_beginav) \ - PL_beginav = newAV(); \ - av_push(PL_beginav, (SV*)cv); \ - GvCV(CvGV(cv)) = 0; /* cv has been hijacked */\ - call_list(oldscope, PL_beginav); \ - PL_curcop = &PL_compiling; \ - CopHINTS_set(&PL_compiling, PL_hints); \ - LEAVE; \ - } STMT_END -#define BSET_push_init(ary,cv) \ - STMT_START { \ - av_unshift((PL_initav ? PL_initav : \ - (PL_initav = newAV(), PL_initav)), 1); \ - av_store(PL_initav, 0, cv); \ - } STMT_END -#define BSET_push_end(ary,cv) \ - STMT_START { \ - av_unshift((PL_endav ? PL_endav : \ - (PL_endav = newAV(), PL_endav)), 1); \ - av_store(PL_endav, 0, cv); \ - } STMT_END -#define BSET_OBJ_STORE(obj, ix) \ - ((I32)ix > bstate->bs_obj_list_fill ? \ - bset_obj_store(aTHX_ bstate, obj, (I32)ix) : \ - (bstate->bs_obj_list[ix] = obj), \ - bstate->bs_ix = ix+1) -#define BSET_OBJ_STOREX(obj) \ - (bstate->bs_ix > bstate->bs_obj_list_fill ? \ - bset_obj_store(aTHX_ bstate, obj, bstate->bs_ix) : \ - (bstate->bs_obj_list[bstate->bs_ix] = obj), \ - bstate->bs_ix++) - -#define BSET_signal(cv, name) \ - mg_set(*hv_store(GvHV(gv_fetchpv("SIG", TRUE, SVt_PVHV)), \ - name, strlen(name), cv, 0)) - -#define BSET_xhv_name(hv, name) hv_name_set((HV*)hv, name, strlen(name), 0) -#define BSET_cop_arybase(c, b) CopARYBASE_set(c, b) -#define BSET_cop_warnings(c, w) \ - STMT_START { \ - if (specialWARN((STRLEN *)w)) { \ - c->cop_warnings = (STRLEN *)w; \ - } else { \ - STRLEN len; \ - const char *const p = SvPV_const(w, len); \ - c->cop_warnings = \ - Perl_new_warnings_bitfield(aTHX_ NULL, p, len); \ - SvREFCNT_dec(w); \ - } \ - } STMT_END -#define BSET_gp_file(gv, file) \ - STMT_START { \ - STRLEN len = strlen(file); \ - U32 hash; \ - PERL_HASH(hash, file, len); \ - if(GvFILE_HEK(gv)) { \ - Perl_unshare_hek(aTHX_ GvFILE_HEK(gv)); \ - } \ - GvGP(gv)->gp_file_hek = share_hek(file, len, hash); \ - Safefree(file); \ - } STMT_END - -/* NOTE: the bytecode header only sanity-checks the bytecode. If a script cares about - * what version of Perl it's being called under, it should do a 'use 5.006_001' or - * equivalent. However, since the header includes checks requiring an exact match in - * ByteLoader versions (we can't guarantee forward compatibility), you don't - * need to specify one: - * use ByteLoader; - * is all you need. - * -- BKS, June 2000 -*/ - -#define HEADER_FAIL(f) \ - Perl_croak(aTHX_ "Invalid bytecode for this architecture: " f) -#define HEADER_FAIL1(f, arg1) \ - Perl_croak(aTHX_ "Invalid bytecode for this architecture: " f, arg1) -#define HEADER_FAIL2(f, arg1, arg2) \ - Perl_croak(aTHX_ "Invalid bytecode for this architecture: " f, arg1, arg2) - -#define BYTECODE_HEADER_CHECK \ - STMT_START { \ - U32 sz = 0; \ - strconst str; \ - \ - BGET_U32(sz); /* Magic: 'PLBC' */ \ - if (sz != 0x43424c50) { \ - HEADER_FAIL1("bad magic (want 0x43424c50, got %#x)", (int)sz); \ - } \ - BGET_strconst(str); /* archname */ \ - if (strNE(str, ARCHNAME)) { \ - HEADER_FAIL2("wrong architecture (want %s, you have %s)",str,ARCHNAME); \ - } \ - BGET_strconst(str); /* ByteLoader version */ \ - if (strNE(str, VERSION)) { \ - HEADER_FAIL2("mismatched ByteLoader versions (want %s, you have %s)", \ - str, VERSION); \ - } \ - BGET_U32(sz); /* ivsize */ \ - if (sz != IVSIZE) { \ - HEADER_FAIL("different IVSIZE"); \ - } \ - BGET_U32(sz); /* ptrsize */ \ - if (sz != PTRSIZE) { \ - HEADER_FAIL("different PTRSIZE"); \ - } \ - } STMT_END diff --git a/ext/ByteLoader/byterun.c b/ext/ByteLoader/byterun.c deleted file mode 100644 index 0c491c0..0000000 --- a/ext/ByteLoader/byterun.c +++ /dev/null @@ -1,1121 +0,0 @@ -/* -*- buffer-read-only: t -*- - * - * Copyright (c) 1996-1999 Malcolm Beattie - * - * You may distribute under the terms of either the GNU General Public - * License or the Artistic License, as specified in the README file. - * - */ -/* - * This file is autogenerated from bytecode.pl. Changes made here will be lost. - */ - -#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[] = { - sizeof(OP), - sizeof(UNOP), - sizeof(BINOP), - sizeof(LOGOP), - sizeof(LISTOP), - sizeof(PMOP), - sizeof(SVOP), - sizeof(PADOP), - sizeof(PVOP), - sizeof(LOOP), - sizeof(COP) -}; - -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[7]; - - 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; - - specialsv_list[0] = Nullsv; - specialsv_list[1] = &PL_sv_undef; - specialsv_list[2] = &PL_sv_yes; - specialsv_list[3] = &PL_sv_no; - specialsv_list[4] = (SV*)pWARN_ALL; - specialsv_list[5] = (SV*)pWARN_NONE; - specialsv_list[6] = (SV*)pWARN_STD; - - while ((insn = BGET_FGETC()) != EOF) { - switch (insn) { - case INSN_COMMENT: /* 35 */ - { - comment_t arg; - BGET_comment_t(arg); - arg = arg; - break; - } - case INSN_NOP: /* 10 */ - { - break; - } - case INSN_RET: /* 0 */ - { - BSET_ret(none); - break; - } - case INSN_LDSV: /* 1 */ - { - svindex arg; - BGET_svindex(arg); - bstate->bs_sv = arg; - break; - } - case INSN_LDOP: /* 2 */ - { - opindex arg; - BGET_opindex(arg); - PL_op = arg; - break; - } - case INSN_STSV: /* 3 */ - { - U32 arg; - BGET_U32(arg); - BSET_OBJ_STORE(bstate->bs_sv, arg); - break; - } - case INSN_STOP: /* 4 */ - { - U32 arg; - BGET_U32(arg); - BSET_OBJ_STORE(PL_op, arg); - break; - } - case INSN_STPV: /* 5 */ - { - U32 arg; - BGET_U32(arg); - BSET_stpv(bstate->bs_pv.pvx, arg); - break; - } - case INSN_LDSPECSV: /* 6 */ - { - U8 arg; - BGET_U8(arg); - BSET_ldspecsv(bstate->bs_sv, arg); - break; - } - case INSN_LDSPECSVX: /* 7 */ - { - U8 arg; - BGET_U8(arg); - BSET_ldspecsvx(bstate->bs_sv, arg); - break; - } - case INSN_NEWSV: /* 8 */ - { - svtype arg; - BGET_svtype(arg); - BSET_newsv(bstate->bs_sv, arg); - break; - } - case INSN_NEWSVX: /* 9 */ - { - svtype arg; - BGET_svtype(arg); - BSET_newsvx(bstate->bs_sv, arg); - break; - } - case INSN_NEWOP: /* 11 */ - { - U8 arg; - BGET_U8(arg); - BSET_newop(PL_op, arg); - break; - } - case INSN_NEWOPX: /* 12 */ - { - U16 arg; - BGET_U16(arg); - BSET_newopx(PL_op, arg); - break; - } - case INSN_NEWOPN: /* 13 */ - { - U8 arg; - BGET_U8(arg); - BSET_newopn(PL_op, arg); - break; - } - case INSN_NEWPV: /* 14 */ - { - PV arg; - BGET_PV(arg); - break; - } - case INSN_PV_CUR: /* 15 */ - { - STRLEN arg; - BGET_PADOFFSET(arg); - bstate->bs_pv.xpv.xpv_cur = arg; - break; - } - case INSN_PV_FREE: /* 16 */ - { - BSET_pv_free(bstate->bs_pv.pvx); - break; - } - case INSN_SV_UPGRADE: /* 17 */ - { - svtype arg; - BGET_svtype(arg); - BSET_sv_upgrade(bstate->bs_sv, arg); - break; - } - case INSN_SV_REFCNT: /* 18 */ - { - U32 arg; - BGET_U32(arg); - SvREFCNT(bstate->bs_sv) = arg; - break; - } - case INSN_SV_REFCNT_ADD: /* 19 */ - { - I32 arg; - BGET_I32(arg); - BSET_sv_refcnt_add(SvREFCNT(bstate->bs_sv), arg); - break; - } - case INSN_SV_FLAGS: /* 20 */ - { - U32 arg; - BGET_U32(arg); - SvFLAGS(bstate->bs_sv) = arg; - break; - } - case INSN_XRV: /* 21 */ - { - svindex arg; - BGET_svindex(arg); - BSET_xrv(bstate->bs_sv, arg); - break; - } - case INSN_XPV: /* 22 */ - { - BSET_xpv(bstate->bs_sv); - break; - } - case INSN_XPV_CUR: /* 23 */ - { - STRLEN arg; - BGET_PADOFFSET(arg); - BSET_xpv_cur(bstate->bs_sv, arg); - break; - } - case INSN_XPV_LEN: /* 24 */ - { - STRLEN arg; - BGET_PADOFFSET(arg); - BSET_xpv_len(bstate->bs_sv, arg); - break; - } - case INSN_XIV: /* 25 */ - { - IV arg; - BGET_IV(arg); - BSET_xiv(bstate->bs_sv, arg); - break; - } - case INSN_XNV: /* 26 */ - { - NV arg; - BGET_NV(arg); - BSET_xnv(bstate->bs_sv, arg); - break; - } - case INSN_XLV_TARGOFF: /* 27 */ - { - STRLEN arg; - BGET_PADOFFSET(arg); - LvTARGOFF(bstate->bs_sv) = arg; - break; - } - case INSN_XLV_TARGLEN: /* 28 */ - { - STRLEN arg; - BGET_PADOFFSET(arg); - LvTARGLEN(bstate->bs_sv) = arg; - break; - } - case INSN_XLV_TARG: /* 29 */ - { - svindex arg; - BGET_svindex(arg); - LvTARG(bstate->bs_sv) = arg; - break; - } - case INSN_XLV_TYPE: /* 30 */ - { - char arg; - BGET_U8(arg); - LvTYPE(bstate->bs_sv) = arg; - break; - } - case INSN_XBM_USEFUL: /* 31 */ - { - I32 arg; - BGET_I32(arg); - BmUSEFUL(bstate->bs_sv) = arg; - break; - } - case INSN_XBM_PREVIOUS: /* 32 */ - { - U16 arg; - BGET_U16(arg); - BmPREVIOUS(bstate->bs_sv) = arg; - break; - } - case INSN_XBM_RARE: /* 33 */ - { - U8 arg; - BGET_U8(arg); - BmRARE(bstate->bs_sv) = arg; - break; - } - case INSN_XFM_LINES: /* 34 */ - { - IV arg; - BGET_IV(arg); - FmLINES(bstate->bs_sv) = arg; - break; - } - case INSN_XIO_LINES: /* 36 */ - { - IV arg; - BGET_IV(arg); - IoLINES(bstate->bs_sv) = arg; - break; - } - case INSN_XIO_PAGE: /* 37 */ - { - IV arg; - BGET_IV(arg); - IoPAGE(bstate->bs_sv) = arg; - break; - } - case INSN_XIO_PAGE_LEN: /* 38 */ - { - IV arg; - BGET_IV(arg); - IoPAGE_LEN(bstate->bs_sv) = arg; - break; - } - case INSN_XIO_LINES_LEFT: /* 39 */ - { - IV arg; - BGET_IV(arg); - IoLINES_LEFT(bstate->bs_sv) = arg; - break; - } - case INSN_XIO_TOP_NAME: /* 40 */ - { - pvindex arg; - BGET_pvindex(arg); - IoTOP_NAME(bstate->bs_sv) = arg; - break; - } - case INSN_XIO_TOP_GV: /* 41 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&IoTOP_GV(bstate->bs_sv) = arg; - break; - } - case INSN_XIO_FMT_NAME: /* 42 */ - { - pvindex arg; - BGET_pvindex(arg); - IoFMT_NAME(bstate->bs_sv) = arg; - break; - } - case INSN_XIO_FMT_GV: /* 43 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&IoFMT_GV(bstate->bs_sv) = arg; - break; - } - case INSN_XIO_BOTTOM_NAME: /* 44 */ - { - pvindex arg; - BGET_pvindex(arg); - IoBOTTOM_NAME(bstate->bs_sv) = arg; - break; - } - case INSN_XIO_BOTTOM_GV: /* 45 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&IoBOTTOM_GV(bstate->bs_sv) = arg; - break; - } - case INSN_XIO_SUBPROCESS: /* 46 */ - { - short arg; - BGET_U16(arg); - IoSUBPROCESS(bstate->bs_sv) = arg; - break; - } - case INSN_XIO_TYPE: /* 47 */ - { - char arg; - BGET_U8(arg); - IoTYPE(bstate->bs_sv) = arg; - break; - } - case INSN_XIO_FLAGS: /* 48 */ - { - char arg; - BGET_U8(arg); - IoFLAGS(bstate->bs_sv) = arg; - break; - } - case INSN_XCV_XSUBANY: /* 49 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&CvXSUBANY(bstate->bs_sv).any_ptr = arg; - break; - } - case INSN_XCV_STASH: /* 50 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&CvSTASH(bstate->bs_sv) = arg; - break; - } - case INSN_XCV_START: /* 51 */ - { - opindex arg; - BGET_opindex(arg); - CvSTART(bstate->bs_sv) = arg; - break; - } - case INSN_XCV_ROOT: /* 52 */ - { - opindex arg; - BGET_opindex(arg); - CvROOT(bstate->bs_sv) = arg; - break; - } - case INSN_XCV_GV: /* 53 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&CvGV(bstate->bs_sv) = arg; - break; - } - case INSN_XCV_FILE: /* 54 */ - { - pvindex arg; - BGET_pvindex(arg); - CvFILE(bstate->bs_sv) = arg; - break; - } - case INSN_XCV_DEPTH: /* 55 */ - { - long arg; - BGET_long(arg); - CvDEPTH(bstate->bs_sv) = arg; - break; - } - case INSN_XCV_PADLIST: /* 56 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&CvPADLIST(bstate->bs_sv) = arg; - break; - } - case INSN_XCV_OUTSIDE: /* 57 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&CvOUTSIDE(bstate->bs_sv) = arg; - break; - } - case INSN_XCV_OUTSIDE_SEQ: /* 58 */ - { - U32 arg; - BGET_U32(arg); - CvOUTSIDE_SEQ(bstate->bs_sv) = arg; - break; - } - case INSN_XCV_FLAGS: /* 59 */ - { - U16 arg; - BGET_U16(arg); - CvFLAGS(bstate->bs_sv) = arg; - break; - } - case INSN_AV_EXTEND: /* 60 */ - { - SSize_t arg; - BGET_PADOFFSET(arg); - BSET_av_extend(bstate->bs_sv, arg); - break; - } - case INSN_AV_PUSHX: /* 61 */ - { - svindex arg; - BGET_svindex(arg); - BSET_av_pushx(bstate->bs_sv, arg); - break; - } - case INSN_AV_PUSH: /* 62 */ - { - svindex arg; - BGET_svindex(arg); - BSET_av_push(bstate->bs_sv, arg); - break; - } - case INSN_XAV_FILL: /* 63 */ - { - SSize_t arg; - BGET_PADOFFSET(arg); - AvFILLp(bstate->bs_sv) = arg; - break; - } - case INSN_XAV_MAX: /* 64 */ - { - SSize_t arg; - BGET_PADOFFSET(arg); - AvMAX(bstate->bs_sv) = arg; - break; - } - case INSN_XHV_RITER: /* 65 */ - { - I32 arg; - BGET_I32(arg); - HvRITER(bstate->bs_sv) = arg; - break; - } - case INSN_XHV_NAME: /* 66 */ - { - pvindex arg; - BGET_pvindex(arg); - BSET_xhv_name(bstate->bs_sv, arg); - break; - } - case INSN_HV_STORE: /* 67 */ - { - svindex arg; - BGET_svindex(arg); - BSET_hv_store(bstate->bs_sv, arg); - break; - } - case INSN_SV_MAGIC: /* 68 */ - { - char arg; - BGET_U8(arg); - BSET_sv_magic(bstate->bs_sv, arg); - break; - } - case INSN_MG_OBJ: /* 69 */ - { - svindex arg; - BGET_svindex(arg); - SvMAGIC(bstate->bs_sv)->mg_obj = arg; - break; - } - case INSN_MG_PRIVATE: /* 70 */ - { - U16 arg; - BGET_U16(arg); - SvMAGIC(bstate->bs_sv)->mg_private = arg; - break; - } - case INSN_MG_FLAGS: /* 71 */ - { - U8 arg; - BGET_U8(arg); - SvMAGIC(bstate->bs_sv)->mg_flags = arg; - break; - } - case INSN_MG_NAME: /* 72 */ - { - pvcontents arg; - BGET_pvcontents(arg); - BSET_mg_name(SvMAGIC(bstate->bs_sv), arg); - break; - } - case INSN_MG_NAMEX: /* 73 */ - { - svindex arg; - BGET_svindex(arg); - BSET_mg_namex(SvMAGIC(bstate->bs_sv), arg); - break; - } - case INSN_XMG_STASH: /* 74 */ - { - svindex arg; - BGET_svindex(arg); - BSET_xmg_stash(bstate->bs_sv, arg); - break; - } - case INSN_GV_FETCHPV: /* 75 */ - { - strconst arg; - BGET_strconst(arg); - BSET_gv_fetchpv(bstate->bs_sv, arg); - break; - } - case INSN_GV_FETCHPVX: /* 76 */ - { - strconst arg; - BGET_strconst(arg); - BSET_gv_fetchpvx(bstate->bs_sv, arg); - break; - } - case INSN_GV_STASHPV: /* 77 */ - { - strconst arg; - BGET_strconst(arg); - BSET_gv_stashpv(bstate->bs_sv, arg); - break; - } - case INSN_GV_STASHPVX: /* 78 */ - { - strconst arg; - BGET_strconst(arg); - BSET_gv_stashpvx(bstate->bs_sv, arg); - break; - } - case INSN_GP_SV: /* 79 */ - { - svindex arg; - BGET_svindex(arg); - GvSV(bstate->bs_sv) = arg; - break; - } - case INSN_GP_REFCNT: /* 80 */ - { - U32 arg; - BGET_U32(arg); - GvREFCNT(bstate->bs_sv) = arg; - break; - } - case INSN_GP_REFCNT_ADD: /* 81 */ - { - I32 arg; - BGET_I32(arg); - BSET_gp_refcnt_add(GvREFCNT(bstate->bs_sv), arg); - break; - } - case INSN_GP_AV: /* 82 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&GvAV(bstate->bs_sv) = arg; - break; - } - case INSN_GP_HV: /* 83 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&GvHV(bstate->bs_sv) = arg; - break; - } - case INSN_GP_CV: /* 84 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&GvCV(bstate->bs_sv) = arg; - break; - } - case INSN_GP_FILE: /* 85 */ - { - pvindex arg; - BGET_pvindex(arg); - BSET_gp_file(bstate->bs_sv, arg); - break; - } - case INSN_GP_IO: /* 86 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&GvIOp(bstate->bs_sv) = arg; - break; - } - case INSN_GP_FORM: /* 87 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&GvFORM(bstate->bs_sv) = arg; - break; - } - case INSN_GP_CVGEN: /* 88 */ - { - U32 arg; - BGET_U32(arg); - GvCVGEN(bstate->bs_sv) = arg; - break; - } - case INSN_GP_LINE: /* 89 */ - { - line_t arg; - BGET_U32(arg); - GvLINE(bstate->bs_sv) = arg; - break; - } - case INSN_GP_SHARE: /* 90 */ - { - svindex arg; - BGET_svindex(arg); - BSET_gp_share(bstate->bs_sv, arg); - break; - } - case INSN_XGV_FLAGS: /* 91 */ - { - U8 arg; - BGET_U8(arg); - GvFLAGS(bstate->bs_sv) = arg; - break; - } - case INSN_OP_NEXT: /* 92 */ - { - opindex arg; - BGET_opindex(arg); - PL_op->op_next = arg; - break; - } - case INSN_OP_SIBLING: /* 93 */ - { - opindex arg; - BGET_opindex(arg); - PL_op->op_sibling = arg; - break; - } - case INSN_OP_PPADDR: /* 94 */ - { - strconst arg; - BGET_strconst(arg); - BSET_op_ppaddr(PL_op->op_ppaddr, arg); - break; - } - case INSN_OP_TARG: /* 95 */ - { - PADOFFSET arg; - BGET_PADOFFSET(arg); - PL_op->op_targ = arg; - break; - } - case INSN_OP_TYPE: /* 96 */ - { - OPCODE arg; - BGET_U16(arg); - BSET_op_type(PL_op, arg); - break; - } - case INSN_OP_OPT: /* 97 */ - { - U8 arg; - BGET_U8(arg); - PL_op->op_opt = arg; - break; - } - case INSN_OP_STATIC: /* 98 */ - { - U8 arg; - BGET_U8(arg); - PL_op->op_static = arg; - break; - } - case INSN_OP_FLAGS: /* 99 */ - { - U8 arg; - BGET_U8(arg); - PL_op->op_flags = arg; - break; - } - case INSN_OP_PRIVATE: /* 100 */ - { - U8 arg; - BGET_U8(arg); - PL_op->op_private = arg; - break; - } - case INSN_OP_FIRST: /* 101 */ - { - opindex arg; - BGET_opindex(arg); - cUNOP->op_first = arg; - break; - } - case INSN_OP_LAST: /* 102 */ - { - opindex arg; - BGET_opindex(arg); - cBINOP->op_last = arg; - break; - } - case INSN_OP_OTHER: /* 103 */ - { - opindex arg; - BGET_opindex(arg); - cLOGOP->op_other = arg; - break; - } - case INSN_OP_PMREPLROOT: /* 104 */ - { - opindex arg; - BGET_opindex(arg); - cPMOP->op_pmreplroot = arg; - break; - } - case INSN_OP_PMREPLSTART: /* 105 */ - { - opindex arg; - BGET_opindex(arg); - cPMOP->op_pmreplstart = arg; - break; - } - case INSN_OP_PMNEXT: /* 106 */ - { - opindex arg; - BGET_opindex(arg); - *(OP**)&cPMOP->op_pmnext = arg; - break; - } -#ifdef USE_ITHREADS - case INSN_OP_PMSTASHPV: /* 107 */ - { - pvindex arg; - BGET_pvindex(arg); - BSET_op_pmstashpv(cPMOP, arg); - break; - } - case INSN_OP_PMREPLROOTPO: /* 108 */ - { - PADOFFSET arg; - BGET_PADOFFSET(arg); - cPMOP->op_pmreplroot = (OP*)arg; - break; - } -#else - case INSN_OP_PMSTASH: /* 109 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&cPMOP->op_pmstash = arg; - break; - } - case INSN_OP_PMREPLROOTGV: /* 110 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&cPMOP->op_pmreplroot = arg; - break; - } -#endif - case INSN_PREGCOMP: /* 111 */ - { - pvcontents arg; - BGET_pvcontents(arg); - BSET_pregcomp(PL_op, arg); - break; - } - case INSN_OP_PMFLAGS: /* 112 */ - { - U16 arg; - BGET_U16(arg); - cPMOP->op_pmflags = arg; - break; - } - case INSN_OP_PMPERMFLAGS: /* 113 */ - { - U16 arg; - BGET_U16(arg); - cPMOP->op_pmpermflags = arg; - break; - } - case INSN_OP_PMDYNFLAGS: /* 114 */ - { - U8 arg; - BGET_U8(arg); - cPMOP->op_pmdynflags = arg; - break; - } - case INSN_OP_SV: /* 115 */ - { - svindex arg; - BGET_svindex(arg); - cSVOP->op_sv = arg; - break; - } - case INSN_OP_PADIX: /* 116 */ - { - PADOFFSET arg; - BGET_PADOFFSET(arg); - cPADOP->op_padix = arg; - break; - } - case INSN_OP_PV: /* 117 */ - { - pvcontents arg; - BGET_pvcontents(arg); - cPVOP->op_pv = arg; - break; - } - case INSN_OP_PV_TR: /* 118 */ - { - op_tr_array arg; - BGET_op_tr_array(arg); - cPVOP->op_pv = arg; - break; - } - case INSN_OP_REDOOP: /* 119 */ - { - opindex arg; - BGET_opindex(arg); - cLOOP->op_redoop = arg; - break; - } - case INSN_OP_NEXTOP: /* 120 */ - { - opindex arg; - BGET_opindex(arg); - cLOOP->op_nextop = arg; - break; - } - case INSN_OP_LASTOP: /* 121 */ - { - opindex arg; - BGET_opindex(arg); - cLOOP->op_lastop = arg; - break; - } - case INSN_COP_LABEL: /* 122 */ - { - pvindex arg; - BGET_pvindex(arg); - cCOP->cop_label = arg; - break; - } -#ifdef USE_ITHREADS - case INSN_COP_STASHPV: /* 123 */ - { - pvindex arg; - BGET_pvindex(arg); - BSET_cop_stashpv(cCOP, arg); - break; - } - case INSN_COP_FILE: /* 124 */ - { - pvindex arg; - BGET_pvindex(arg); - BSET_cop_file(cCOP, arg); - break; - } -#else - case INSN_COP_STASH: /* 125 */ - { - svindex arg; - BGET_svindex(arg); - BSET_cop_stash(cCOP, arg); - break; - } - case INSN_COP_FILEGV: /* 126 */ - { - svindex arg; - BGET_svindex(arg); - BSET_cop_filegv(cCOP, arg); - break; - } -#endif - case INSN_COP_SEQ: /* 127 */ - { - U32 arg; - BGET_U32(arg); - cCOP->cop_seq = arg; - break; - } - case INSN_COP_ARYBASE: /* 128 */ - { - I32 arg; - BGET_I32(arg); - BSET_cop_arybase(cCOP, arg); - break; - } - case INSN_COP_LINE: /* 129 */ - { - line_t arg; - BGET_U32(arg); - cCOP->cop_line = arg; - break; - } - case INSN_COP_WARNINGS: /* 130 */ - { - svindex arg; - BGET_svindex(arg); - BSET_cop_warnings(cCOP, arg); - break; - } - case INSN_MAIN_START: /* 131 */ - { - opindex arg; - BGET_opindex(arg); - PL_main_start = arg; - break; - } - case INSN_MAIN_ROOT: /* 132 */ - { - opindex arg; - BGET_opindex(arg); - PL_main_root = arg; - break; - } - case INSN_MAIN_CV: /* 133 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&PL_main_cv = arg; - break; - } - case INSN_CURPAD: /* 134 */ - { - svindex arg; - BGET_svindex(arg); - BSET_curpad(PL_curpad, arg); - break; - } - case INSN_PUSH_BEGIN: /* 135 */ - { - svindex arg; - BGET_svindex(arg); - BSET_push_begin(PL_beginav, arg); - break; - } - case INSN_PUSH_INIT: /* 136 */ - { - svindex arg; - BGET_svindex(arg); - BSET_push_init(PL_initav, arg); - break; - } - case INSN_PUSH_END: /* 137 */ - { - svindex arg; - BGET_svindex(arg); - BSET_push_end(PL_endav, arg); - break; - } - case INSN_CURSTASH: /* 138 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&PL_curstash = arg; - break; - } - case INSN_DEFSTASH: /* 139 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&PL_defstash = arg; - break; - } - case INSN_DATA: /* 140 */ - { - U8 arg; - BGET_U8(arg); - BSET_data(none, arg); - break; - } - case INSN_INCAV: /* 141 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&GvAV(PL_incgv) = arg; - break; - } - case INSN_LOAD_GLOB: /* 142 */ - { - svindex arg; - BGET_svindex(arg); - BSET_load_glob(none, arg); - break; - } -#ifdef USE_ITHREADS - case INSN_REGEX_PADAV: /* 143 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&PL_regex_padav = arg; - break; - } -#endif - case INSN_DOWARN: /* 144 */ - { - U8 arg; - BGET_U8(arg); - PL_dowarn = arg; - break; - } - case INSN_COMPPAD_NAME: /* 145 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&PL_comppad_name = arg; - break; - } - case INSN_XGV_STASH: /* 146 */ - { - svindex arg; - BGET_svindex(arg); - *(SV**)&GvSTASH(bstate->bs_sv) = arg; - break; - } - case INSN_SIGNAL: /* 147 */ - { - strconst arg; - BGET_strconst(arg); - BSET_signal(bstate->bs_sv, arg); - break; - } - case INSN_FORMFEED: /* 148 */ - { - svindex arg; - BGET_svindex(arg); - PL_formfeed = arg; - break; - } - default: - Perl_croak(aTHX_ "Illegal bytecode instruction %d\n", insn); - /* NOTREACHED */ - } - } - return 0; -} - -/* ex: set ro: */ diff --git a/ext/ByteLoader/byterun.h b/ext/ByteLoader/byterun.h deleted file mode 100644 index 75c1ba0..0000000 --- a/ext/ByteLoader/byterun.h +++ /dev/null @@ -1,204 +0,0 @@ -/* -*- buffer-read-only: t -*- - * - * Copyright (c) 1996-1999 Malcolm Beattie - * - * You may distribute under the terms of either the GNU General Public - * License or the Artistic License, as specified in the README file. - * - */ -/* - * This file is autogenerated from bytecode.pl. Changes made here will be lost. - */ -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 { - INSN_RET, /* 0 */ - INSN_LDSV, /* 1 */ - INSN_LDOP, /* 2 */ - INSN_STSV, /* 3 */ - INSN_STOP, /* 4 */ - INSN_STPV, /* 5 */ - INSN_LDSPECSV, /* 6 */ - INSN_LDSPECSVX, /* 7 */ - INSN_NEWSV, /* 8 */ - INSN_NEWSVX, /* 9 */ - INSN_NOP, /* 10 */ - INSN_NEWOP, /* 11 */ - INSN_NEWOPX, /* 12 */ - INSN_NEWOPN, /* 13 */ - INSN_NEWPV, /* 14 */ - INSN_PV_CUR, /* 15 */ - INSN_PV_FREE, /* 16 */ - INSN_SV_UPGRADE, /* 17 */ - INSN_SV_REFCNT, /* 18 */ - INSN_SV_REFCNT_ADD, /* 19 */ - INSN_SV_FLAGS, /* 20 */ - INSN_XRV, /* 21 */ - INSN_XPV, /* 22 */ - INSN_XPV_CUR, /* 23 */ - INSN_XPV_LEN, /* 24 */ - INSN_XIV, /* 25 */ - INSN_XNV, /* 26 */ - INSN_XLV_TARGOFF, /* 27 */ - INSN_XLV_TARGLEN, /* 28 */ - INSN_XLV_TARG, /* 29 */ - INSN_XLV_TYPE, /* 30 */ - INSN_XBM_USEFUL, /* 31 */ - INSN_XBM_PREVIOUS, /* 32 */ - INSN_XBM_RARE, /* 33 */ - INSN_XFM_LINES, /* 34 */ - INSN_COMMENT, /* 35 */ - INSN_XIO_LINES, /* 36 */ - INSN_XIO_PAGE, /* 37 */ - INSN_XIO_PAGE_LEN, /* 38 */ - INSN_XIO_LINES_LEFT, /* 39 */ - INSN_XIO_TOP_NAME, /* 40 */ - INSN_XIO_TOP_GV, /* 41 */ - INSN_XIO_FMT_NAME, /* 42 */ - INSN_XIO_FMT_GV, /* 43 */ - INSN_XIO_BOTTOM_NAME, /* 44 */ - INSN_XIO_BOTTOM_GV, /* 45 */ - INSN_XIO_SUBPROCESS, /* 46 */ - INSN_XIO_TYPE, /* 47 */ - INSN_XIO_FLAGS, /* 48 */ - INSN_XCV_XSUBANY, /* 49 */ - INSN_XCV_STASH, /* 50 */ - INSN_XCV_START, /* 51 */ - INSN_XCV_ROOT, /* 52 */ - INSN_XCV_GV, /* 53 */ - INSN_XCV_FILE, /* 54 */ - INSN_XCV_DEPTH, /* 55 */ - INSN_XCV_PADLIST, /* 56 */ - INSN_XCV_OUTSIDE, /* 57 */ - INSN_XCV_OUTSIDE_SEQ, /* 58 */ - INSN_XCV_FLAGS, /* 59 */ - INSN_AV_EXTEND, /* 60 */ - INSN_AV_PUSHX, /* 61 */ - INSN_AV_PUSH, /* 62 */ - INSN_XAV_FILL, /* 63 */ - INSN_XAV_MAX, /* 64 */ - INSN_XHV_RITER, /* 65 */ - INSN_XHV_NAME, /* 66 */ - INSN_HV_STORE, /* 67 */ - INSN_SV_MAGIC, /* 68 */ - INSN_MG_OBJ, /* 69 */ - INSN_MG_PRIVATE, /* 70 */ - INSN_MG_FLAGS, /* 71 */ - INSN_MG_NAME, /* 72 */ - INSN_MG_NAMEX, /* 73 */ - INSN_XMG_STASH, /* 74 */ - INSN_GV_FETCHPV, /* 75 */ - INSN_GV_FETCHPVX, /* 76 */ - INSN_GV_STASHPV, /* 77 */ - INSN_GV_STASHPVX, /* 78 */ - INSN_GP_SV, /* 79 */ - INSN_GP_REFCNT, /* 80 */ - INSN_GP_REFCNT_ADD, /* 81 */ - INSN_GP_AV, /* 82 */ - INSN_GP_HV, /* 83 */ - INSN_GP_CV, /* 84 */ - INSN_GP_FILE, /* 85 */ - INSN_GP_IO, /* 86 */ - INSN_GP_FORM, /* 87 */ - INSN_GP_CVGEN, /* 88 */ - INSN_GP_LINE, /* 89 */ - INSN_GP_SHARE, /* 90 */ - INSN_XGV_FLAGS, /* 91 */ - INSN_OP_NEXT, /* 92 */ - INSN_OP_SIBLING, /* 93 */ - INSN_OP_PPADDR, /* 94 */ - INSN_OP_TARG, /* 95 */ - INSN_OP_TYPE, /* 96 */ - INSN_OP_OPT, /* 97 */ - INSN_OP_STATIC, /* 98 */ - INSN_OP_FLAGS, /* 99 */ - INSN_OP_PRIVATE, /* 100 */ - INSN_OP_FIRST, /* 101 */ - INSN_OP_LAST, /* 102 */ - INSN_OP_OTHER, /* 103 */ - INSN_OP_PMREPLROOT, /* 104 */ - INSN_OP_PMREPLSTART, /* 105 */ - INSN_OP_PMNEXT, /* 106 */ - INSN_OP_PMSTASHPV, /* 107 */ - INSN_OP_PMREPLROOTPO, /* 108 */ - INSN_OP_PMSTASH, /* 109 */ - INSN_OP_PMREPLROOTGV, /* 110 */ - INSN_PREGCOMP, /* 111 */ - INSN_OP_PMFLAGS, /* 112 */ - INSN_OP_PMPERMFLAGS, /* 113 */ - INSN_OP_PMDYNFLAGS, /* 114 */ - INSN_OP_SV, /* 115 */ - INSN_OP_PADIX, /* 116 */ - INSN_OP_PV, /* 117 */ - INSN_OP_PV_TR, /* 118 */ - INSN_OP_REDOOP, /* 119 */ - INSN_OP_NEXTOP, /* 120 */ - INSN_OP_LASTOP, /* 121 */ - INSN_COP_LABEL, /* 122 */ - INSN_COP_STASHPV, /* 123 */ - INSN_COP_FILE, /* 124 */ - INSN_COP_STASH, /* 125 */ - INSN_COP_FILEGV, /* 126 */ - INSN_COP_SEQ, /* 127 */ - INSN_COP_ARYBASE, /* 128 */ - INSN_COP_LINE, /* 129 */ - INSN_COP_WARNINGS, /* 130 */ - INSN_MAIN_START, /* 131 */ - INSN_MAIN_ROOT, /* 132 */ - INSN_MAIN_CV, /* 133 */ - INSN_CURPAD, /* 134 */ - INSN_PUSH_BEGIN, /* 135 */ - INSN_PUSH_INIT, /* 136 */ - INSN_PUSH_END, /* 137 */ - INSN_CURSTASH, /* 138 */ - INSN_DEFSTASH, /* 139 */ - INSN_DATA, /* 140 */ - INSN_INCAV, /* 141 */ - INSN_LOAD_GLOB, /* 142 */ - INSN_REGEX_PADAV, /* 143 */ - INSN_DOWARN, /* 144 */ - INSN_COMPPAD_NAME, /* 145 */ - INSN_XGV_STASH, /* 146 */ - INSN_SIGNAL, /* 147 */ - INSN_FORMFEED, /* 148 */ - MAX_INSN = 148 -}; - -enum { - OPt_OP, /* 0 */ - OPt_UNOP, /* 1 */ - OPt_BINOP, /* 2 */ - OPt_LOGOP, /* 3 */ - OPt_LISTOP, /* 4 */ - OPt_PMOP, /* 5 */ - OPt_SVOP, /* 6 */ - OPt_PADOP, /* 7 */ - OPt_PVOP, /* 8 */ - OPt_LOOP, /* 9 */ - OPt_COP /* 10 */ -}; - -/* ex: set ro: */ diff --git a/ext/ByteLoader/hints/sunos.pl b/ext/ByteLoader/hints/sunos.pl deleted file mode 100644 index 3faf498..0000000 --- a/ext/ByteLoader/hints/sunos.pl +++ /dev/null @@ -1,2 +0,0 @@ -$self->{CCFLAGS} = $Config{ccflags} . ' -DNEED_FGETC_PROTOTYPE -DNEED_FREAD_PROTOTYPE'; - diff --git a/ext/threads/shared/typemap b/ext/threads/shared/typemap deleted file mode 100644 index e69de29..0000000 diff --git a/pod/Makefile.SH b/pod/Makefile.SH index ef19169..74d299f 100644 --- a/pod/Makefile.SH +++ b/pod/Makefile.SH @@ -158,10 +158,4 @@ perlmodlib.pod: $(PERL) perlmodlib.PL ../MANIFEST rm -f perlmodlib.pod $(PERL) -I ../lib perlmodlib.PL -compile: all - $(REALPERL) -I../lib ../utils/perlcc -I .. -L .. -o pod2latex.exe pod2latex -log ../compilelog - $(REALPERL) -I../lib ../utils/perlcc -I .. -L .. -o pod2man.exe pod2man -log ../compilelog - $(REALPERL) -I../lib ../utils/perlcc -I .. -L .. -o pod2text.exe pod2text -log ../compilelog - $(REALPERL) -I../lib ../utils/perlcc -I .. -L .. -o checkpods.exe checkpods -log ../compilelog - !NO!SUBS! diff --git a/pod/perlcompile.pod b/pod/perlcompile.pod index 046576b..881f02b 100644 --- a/pod/perlcompile.pod +++ b/pod/perlcompile.pod @@ -14,12 +14,11 @@ native executable. The C module provides access to the parse tree, and other modules ("back ends") do things with the tree. Some write it out as -bytecode, C source code, or a semi-human-readable text. Another -traverses the parse tree to build a cross-reference of which -subroutines, formats, and variables are used where. Another checks -your code for dubious constructs. Yet another back end dumps the -parse tree back out as Perl source, acting as a source code beautifier -or deobfuscator. +semi-human-readable text. Another traverses the parse tree to build a +cross-reference of which subroutines, formats, and variables are used +where. Another checks your code for dubious constructs. Yet another back +end dumps the parse tree back out as Perl source, acting as a source code +beautifier or deobfuscator. Because its original purpose was to be a way to produce C code corresponding to a Perl program, and in turn a native executable, the @@ -37,8 +36,7 @@ what problems there are, and how to work around them. The compiler back ends are in the C hierarchy, and the front-end (the module that you, the user of the compiler, will sometimes -interact with) is the O module. Some back ends (e.g., C) have -programs (e.g., I) to hide the modules' complexity. +interact with) is the O module. Here are the important back ends to know about, with their status expressed as a number from 0 (outline for later implementation) to @@ -46,30 +44,6 @@ expressed as a number from 0 (outline for later implementation) to =over 4 -=item B::Bytecode - -Stores the parse tree in a machine-independent format, suitable -for later reloading through the ByteLoader module. Status: 5 (some -things work, some things don't, some things are untested). - -=item B::C - -Creates a C source file containing code to rebuild the parse tree -and resume the interpreter. Status: 6 (many things work adequately, -including programs using Tk). - -=item B::CC - -Creates a C source file corresponding to the run time code path in -the parse tree. This is the closest to a Perl-to-C translator there -is, but the code it generates is almost incomprehensible because it -translates the parse tree into a giant switch structure that -manipulates Perl structures. Eventual goal is to reduce (given -sufficient type information in the Perl program) some of the -Perl data structure manipulations into manipulations of C-level -ints, floats, etc. Status: 5 (some things work, including -uncomplicated Tk examples). - =item B::Lint Complains if it finds dubious constructs in your source code. Status: @@ -216,58 +190,6 @@ To disable context checks and undefined subroutines: See L for information on the options. -=head2 The Simple C Back End - -This module saves the internal compiled state of your Perl program -to a C source file, which can be turned into a native executable -for that particular platform using a C compiler. The resulting -program links against the Perl interpreter library, so it -will not save you disk space (unless you build Perl with a shared -library) or program size. It may, however, save you startup time. - -The C tool generates such executables by default. - - perlcc myperlprogram.pl - -=head2 The Bytecode Back End - -This back end is only useful if you also have a way to load and -execute the bytecode that it produces. The ByteLoader module provides -this functionality. - -To turn a Perl program into executable byte code, you can use C -with the C<-B> switch: - - perlcc -B myperlprogram.pl - -The byte code is machine independent, so once you have a compiled -module or program, it is as portable as Perl source (assuming that -the user of the module or program has a modern-enough Perl interpreter -to decode the byte code). - -See B for information on options to control the -optimization and nature of the code generated by the Bytecode module. - -=head2 The Optimized C Back End - -The optimized C back end will turn your Perl program's run time -code-path into an equivalent (but optimized) C program that manipulates -the Perl data structures directly. The program will still link against -the Perl interpreter library, to allow for eval(), C, -C, etc. - -The C tool generates such executables when using the -O -switch. To compile a Perl program (ending in C<.pl> -or C<.p>): - - perlcc -O myperlprogram.pl - -To produce a shared library from a Perl module (ending in C<.pm>): - - perlcc -O Myperlmodule.pm - -For more information, see L and L. - =head1 Module List for the Compiler Suite =over 4 @@ -289,54 +211,6 @@ called something like this: This is like saying C in your Perl program. -=item B::Asmdata - -This module is used by the B::Assembler module, which is in turn used -by the B::Bytecode module, which stores a parse-tree as -bytecode for later loading. It's not a back end itself, but rather a -component of a back end. - -=item B::Assembler - -This module turns a parse-tree into data suitable for storing -and later decoding back into a parse-tree. It's not a back end -itself, but rather a component of a back end. It's used by the -I program that produces bytecode. - -=item B::Bblock - -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. - -=item B::Bytecode - -This module is a back end that generates bytecode from a -program's parse tree. This bytecode is written to a file, from where -it can later be reconstructed back into a parse tree. The goal is to -do the expensive program compilation once, save the interpreter's -state into a file, and then restore the state from the file when the -program is to be executed. See L -for details about usage. - -=item B::C - -This module writes out C code corresponding to the parse tree and -other interpreter internal structures. You compile the corresponding -C file, and get an executable file that will restore the internal -structures and the Perl interpreter will begin running the -program. See L for details about usage. - -=item B::CC - -This module writes out C code corresponding to your program's -operations. Unlike the B::C module, which merely stores the -interpreter and its state in a C program, the B::CC module makes a -C program that does not involve the interpreter. As a consequence, -programs translated into C by B::CC can execute faster than normal -interpreted programs. See L for -details about usage. - =item B::Concise This module prints a concise (but complete) version of the Perl parse @@ -359,12 +233,6 @@ It is useful in debugging and deconstructing other people's code, also as a pretty-printer for your own source. See L for details about usage. -=item B::Disassembler - -This module turns bytecode back into a parse tree. It's not a back -end itself, but rather a component of a back end. It's used by the -I program that comes with the bytecode. - =item B::Lint This module inspects the compiled form of your source code for things @@ -387,19 +255,6 @@ To get a list of the my() variables used in the file myperlprogram: [BROKEN] -=item B::Stackobj - -This module is used by the B::CC module. It's not a back end itself, -but rather a component of a back end. - -=item B::Stash - -This module is used by the L program, which compiles a module -into an executable. B::Stash prints the symbol tables in use by a -program, and is used to prevent B::CC from producing C code for the -B::* and O modules. It's not a back end itself, but rather a -component of a back end. - =item B::Terse This module prints the contents of the parse tree, but without as much @@ -421,19 +276,6 @@ usage. =head1 KNOWN PROBLEMS -The simple C backend currently only saves typeglobs with alphanumeric -names. - -The optimized C backend outputs code for more modules than it should -(e.g., DirHandle). It also has little hope of properly handling -C outside the running subroutine (C is okay). -C currently does not work at all in this backend. -It also creates a huge initialization function that gives -C compilers headaches. Splitting the initialization function gives -better results. Other problems include: unsigned math does not -work correctly; some opcodes are handled incorrectly by default -opcode handling mechanism. - BEGIN{} blocks are executed while compiling your code. Any external state that is initialized in BEGIN{}, such as opening files, initiating database connections etc., do not behave properly. To work around diff --git a/regen.pl b/regen.pl index 55bd4dc..c7b9e13 100644 --- a/regen.pl +++ b/regen.pl @@ -18,9 +18,7 @@ safer_unlink ("warnings.h", "lib/warnings.pm"); my %gen = ( 'autodoc.pl' => [qw[pod/perlapi.pod pod/perlintern.pod]], - 'bytecode.pl' => [qw[ext/ByteLoader/byterun.h - ext/ByteLoader/byterun.c - ext/B/B/Asmdata.pm]], + 'bytecode.pl' => [qw[ext/B/B/Asmdata.pm]], 'embed.pl' => [qw[proto.h embed.h embedvar.h global.sym perlapi.h perlapi.c]], 'keywords.pl' => [qw[keywords.h]], diff --git a/t/TEST b/t/TEST index 8e02299..22d814d 100755 --- a/t/TEST +++ b/t/TEST @@ -29,8 +29,6 @@ our $show_elapsed_time = $ENV{HARNESS_TIMER} || 0; $::torture = 1 if $1 eq 'torture'; $::with_utf8 = 1 if $1 eq 'utf8'; $::with_utf16 = 1 if $1 eq 'utf16'; - $::bytecompile = 1 if $1 eq 'bytecompile'; - $::compile = 1 if $1 eq 'compile'; $::taintwarn = 1 if $1 eq 'taintwarn'; $ENV{PERL_CORE_MINITEST} = 1 if $1 eq 'minitest'; if ($1 =~ /^deparse(,.+)?$/) { @@ -171,19 +169,9 @@ unless (@ARGV) { } } -# Tests known to cause infinite loops for the perlcc tests. -# %::infinite = ( 'comp/require.t', 1, 'op/bop.t', 1, 'lib/hostname.t', 1 ); -%::infinite = (); - if ($::deparse) { _testprogs('deparse', '', @ARGV); } -elsif( $::compile ) { - _testprogs('compile', '', @ARGV); -} -elsif( $::bytecompile ) { - _testprogs('bytecompile', '', @ARGV); -} elsif ($::with_utf16) { for my $e (0, 1) { for my $b (0, 1) { @@ -211,34 +199,18 @@ elsif ($::with_utf16) { } } else { - _testprogs('compile', '', @ARGV) if -e "../testcompile"; _testprogs('perl', '', @ARGV); } sub _testprogs { my ($type, $args, @tests) = @_; - print <<'EOT' if ($type eq 'compile'); ------------------------------------------------------------------------------- -TESTING COMPILER ------------------------------------------------------------------------------- -EOT - print <<'EOT' if ($type eq 'deparse'); ------------------------------------------------------------------------------ TESTING DEPARSER ------------------------------------------------------------------------------ EOT - print <$null &&". - "$perl $testswitch $switch -I../lib $utf8 $test.plc |"; - open(RESULTS,$bytecompile_cmd) - or print "can't byte-compile '$bytecompile_cmd': $!.\n"; - } elsif ($type eq 'perl') { my $perl = $ENV{PERL} || './perl'; my $redir = $^O eq 'VMS' ? '2>&1' : ''; @@ -376,38 +318,6 @@ EOT . " $test $redir|"; open(RESULTS,$run) or print "can't run '$run': $!.\n"; } - else { - my $compile_cmd; - my $pl2c = "$testswitch -I../lib ../utils/perlcc --testsuite " . - # -O9 for good measure, -fcog is broken ATM - "$switch -Wb=-O9,-fno-cog -L .. " . - "-I \".. ../lib/CORE\" $args $utf8 $test -o "; - - if( $^O eq 'MSWin32' ) { - $test_executable = "$test.exe"; - # hopefully unused name... - open HACK, "> xweghyz.pl"; - print HACK <) {m/^\\w+\\.[cC]\$/ && next;print} -open HACK, '$test_executable |'; -while() {print} -EOT - close HACK; - $compile_cmd = 'xweghyz.pl |'; - } - else { - $test_executable = "$test.plc"; - $compile_cmd - = "./perl $pl2c $test_executable && $test_executable |"; - } - unlink $test_executable if -f $test_executable; - open(RESULTS, $compile_cmd) - or print "can't compile '$compile_cmd': $!.\n"; - } # Our environment may force us to use UTF-8, but we can't be sure that # anything we're reading from will be generating (well formed) UTF-8 # This may not be the best way - possibly we should unset ${^OPEN} up @@ -555,10 +465,6 @@ EOT rename("perl.3log", $tpp) || die "rename: perl3.log to $tpp: $!\n"; } - # test if the compiler compiled something - if( $type eq 'compile' && !-e "$test_executable" ) { - $failure = "Test did not compile"; - } if (not defined $failure and $next != $max) { $failure="FAILED--expected $max tests, saw $next"; } diff --git a/t/harness b/t/harness index b58bbb5..8c8ffaa 100644 --- a/t/harness +++ b/t/harness @@ -126,42 +126,4 @@ if ($^O eq 'MSWin32') { @tests=grep /$re/, @tests if $re; Test::Harness::runtests @tests; -exit(0) unless -e "../testcompile"; - -# %infinite = qw ( -# op/bop.t 1 -# lib/hostname.t 1 -# op/lex_assign.t 1 -# lib/ph.t 1 -# ); - -my $dhwrapper = <<'EOT'; -open DATA,"<".__FILE__; -until (($_=) =~ /^__END__/) {}; -EOT - -@tests = grep (!$infinite{$_}, @tests); -@tests = map { - my $new = $_; - if ($datahandle{$_} && !( -f "$new.t") ) { - $new .= '.t'; - local(*F, *T); - open(F,"<$_") or die "Can't open $_: $!"; - open(T,">$new") or die "Can't open $new: $!"; - print T $dhwrapper, ; - close F; - close T; - } - $new; - } @tests; - -print "The tests ", join(' ', keys(%infinite)), - " generate infinite loops! Skipping!\n"; - -$ENV{'HARNESS_COMPILE_TEST'} = 1; -$ENV{'PERLCC_TIMEOUT'} = 120 unless $ENV{'PERLCC_TIMEOUT'}; - -Test::Harness::runtests @tests; -foreach (keys %datahandle) { - unlink "$_.t"; -} +exit(0); diff --git a/t/lib/1_compile.t b/t/lib/1_compile.t index 9e86158..72628c3 100644 --- a/t/lib/1_compile.t +++ b/t/lib/1_compile.t @@ -24,9 +24,6 @@ if (eval { require Socket }) { push @Core_Modules, qw(Net::Cmd Net::POP3); } } -if(eval { require B }) { - push @Core_Modules, qw(B::C B::CC B::Stackobj); -} @Core_Modules = sort @Core_Modules; diff --git a/utils.lst b/utils.lst index 6f7579d..7de9fbb 100644 --- a/utils.lst +++ b/utils.lst @@ -16,7 +16,6 @@ utils/h2xs utils/instmodsh utils/libnetcfg utils/perlbug -utils/perlcc utils/perldoc # pod = pod/perldoc.pod utils/perlivp utils/piconv diff --git a/utils/Makefile b/utils/Makefile index 1835633..a37a570 100644 --- a/utils/Makefile +++ b/utils/Makefile @@ -5,25 +5,12 @@ REALPERL = ../perl # Files to be built with variable substitution after miniperl is # available. Dependencies handled manually below (for now). -pl = c2ph.PL config_data.PL corelist.PL cpan.PL h2ph.PL h2xs.PL instmodsh.PL perlbug.PL perldoc.PL perlivp.PL pl2pm.PL prove.PL ptar.PL ptardiff.PL shasum.PL splain.PL perlcc.PL dprofpp.PL libnetcfg.PL piconv.PL enc2xs.PL xsubpp.PL -plextract = c2ph config_data corelist cpan h2ph h2xs instmodsh perlbug perldoc perlivp pl2pm prove ptar ptardiff shasum splain perlcc dprofpp libnetcfg piconv enc2xs xsubpp -plextractexe = ./c2ph ./config_data ./corelist ./cpan ./h2ph ./h2xs ./instmodsh ./perlbug ./perldoc ./perlivp ./pl2pm ./prove ./ptar ./ptardiff ./shasum ./splain ./perlcc ./dprofpp ./libnetcfg ./piconv ./enc2xs ./xsubpp +pl = c2ph.PL config_data.PL corelist.PL cpan.PL h2ph.PL h2xs.PL instmodsh.PL perlbug.PL perldoc.PL perlivp.PL pl2pm.PL prove.PL ptar.PL ptardiff.PL shasum.PL splain.PL dprofpp.PL libnetcfg.PL piconv.PL enc2xs.PL xsubpp.PL +plextract = c2ph config_data corelist cpan h2ph h2xs instmodsh perlbug perldoc perlivp pl2pm prove ptar ptardiff shasum splain dprofpp libnetcfg piconv enc2xs xsubpp +plextractexe = ./c2ph ./config_data ./corelist ./cpan ./h2ph ./h2xs ./instmodsh ./perlbug ./perldoc ./perlivp ./pl2pm ./prove ./ptar ./ptardiff ./shasum ./splain ./dprofpp ./libnetcfg ./piconv ./enc2xs ./xsubpp all: $(plextract) -compile: all $(plextract) - $(REALPERL) -I../lib perlcc -I .. -L .. c2ph -o c2ph.exe -v 10 -log ../compilelog; - $(REALPERL) -I../lib perlcc -I .. -L .. h2ph -o h2ph.exe -v 10 -log ../compilelog; - $(REALPERL) -I../lib perlcc -I .. -L .. h2xs -o h2xs.exe -v 10 -log ../compilelog; - $(REALPERL) -I../lib perlcc -I .. -L .. perlbug -o perlbug.exe -v 10 -log ../compilelog; - $(REALPERL) -I../lib perlcc -I .. -L .. perldoc -o perldoc.exe -v 10 -log ../compilelog; - $(REALPERL) -I../lib perlcc -I .. -L .. perlivp -o perlivp.exe -v 10 -log ../compilelog; - $(REALPERL) -I../lib perlcc -I .. -L .. pl2pm -o pl2pm.exe -v 10 -log ../compilelog; - $(REALPERL) -I../lib perlcc -I .. -L .. splain -o splain.exe -v 10 -log ../compilelog; - $(REALPERL) -I../lib perlcc -I .. -L .. perlcc -I .. -L .. -o perlcc.exe -v 10 -log ../compilelog; - $(REALPERL) -I../lib perlcc -I .. -L .. dprofpp -o dprofpp.exe -v 10 -log ../compilelog; - $(REALPERL) -I../lib perlcc -I .. -L .. libnetcfg -o libnetcfg.exe -v 10 -log ../compilelog; - $(plextract): $(PERL) -I../lib $@.PL @@ -59,8 +46,6 @@ shasum: shasum.PL ../config.sh splain: splain.PL ../config.sh ../lib/diagnostics.pm -perlcc: perlcc.PL ../config.sh - dprofpp: dprofpp.PL ../config.sh libnetcfg: libnetcfg.PL ../config.sh diff --git a/utils/perlcc.PL b/utils/perlcc.PL deleted file mode 100644 index 361069e..0000000 --- a/utils/perlcc.PL +++ /dev/null @@ -1,691 +0,0 @@ -#!/usr/local/bin/perl - -use Config; -use File::Basename qw(&basename &dirname); -use File::Spec; -use Cwd; - -# List explicitly here the variables you want Configure to -# generate. Metaconfig only looks for shell variables, so you -# have to mention them as if they were shell variables, not -# %Config entries. Thus you write -# $startperl -# to ensure Configure will look for $Config{startperl}. -# Wanted: $archlibexp - -# This forces PL files to create target in same directory as PL file. -# This is so that make depend always knows where to find PL derivatives. -$origdir = cwd; -chdir dirname($0); -$file = basename($0, '.PL'); -$file .= '.com' if $^O eq 'VMS'; - -open OUT,">$file" or die "Can't create $file: $!"; - -print "Extracting $file (with variable substitutions)\n"; - -# In this section, perl variables will be expanded during extraction. -# You can use $Config{...} to use Configure variables. - -print OUT <<"!GROK!THIS!"; -$Config{startperl} - eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' - if \$running_under_some_shell; ---\$running_under_some_shell; -!GROK!THIS! - -# In the following, perl variables are not expanded during extraction. - -print OUT <<'!NO!SUBS!'; - -# Version 2.0, Simon Cozens, Thu Mar 30 17:52:45 JST 2000 -# Version 2.01, Tom Christiansen, Thu Mar 30 08:25:14 MST 2000 -# Version 2.02, Simon Cozens, Sun Apr 16 01:53:36 JST 2000 -# Version 2.03, Edward Peschko, Mon Feb 26 12:04:17 PST 2001 -# Version 2.04, Enache Adrian,Fri, 18 Jul 2003 23:15:37 +0300 - -use strict; -use warnings; -use 5.006_000; - -use FileHandle; -use Config; -use Fcntl qw(:DEFAULT :flock); -use File::Temp qw(tempfile); -use Cwd; -our $VERSION = 2.04; -$| = 1; - -$SIG{INT} = sub { exit(); }; # exit gracefully and clean up after ourselves. - -use subs qw{ - cc_harness check_read check_write checkopts_byte choose_backend - compile_byte compile_cstyle compile_module generate_code - grab_stash parse_argv sanity_check vprint yclept spawnit -}; -sub opt(*); # imal quoting -sub is_win32(); -sub is_msvc(); - -our ($Options, $BinPerl, $Backend); -our ($Input => $Output); -our ($logfh); -our ($cfile); -our (@begin_output); # output from BEGIN {}, for testsuite - -# eval { main(); 1 } or die; - -main(); - -sub main { - parse_argv(); - check_write($Output); - choose_backend(); - generate_code(); - run_code(); - _die("XXX: Not reached?"); -} - -####################################################################### - -sub choose_backend { - # Choose the backend. - $Backend = 'C'; - if (opt(B)) { - checkopts_byte(); - $Backend = 'Bytecode'; - } - if (opt(S) && opt(c)) { - # die "$0: Do you want me to compile this or not?\n"; - delete $Options->{S}; - } - $Backend = 'CC' if opt(O); -} - - -sub generate_code { - - vprint 0, "Compiling $Input"; - - $BinPerl = yclept(); # Calling convention for perl. - - if (opt(shared)) { - compile_module(); - } else { - if ($Backend eq 'Bytecode') { - compile_byte(); - } else { - compile_cstyle(); - } - } - exit(0) if (!opt('r')); -} - -sub run_code { - vprint 0, "Running code"; - run("$Output @ARGV"); - exit(0); -} - -# usage: vprint [level] msg args -sub vprint { - my $level; - if (@_ == 1) { - $level = 1; - } elsif ($_[0] =~ /^\d$/) { - $level = shift; - } else { - # well, they forgot to use a number; means >0 - $level = 0; - } - my $msg = "@_"; - $msg .= "\n" unless substr($msg, -1) eq "\n"; - if (opt(v) > $level) - { - print "$0: $msg" if !opt('log'); - print $logfh "$0: $msg" if opt('log'); - } -} - -sub parse_argv { - - use Getopt::Long; - - # disallows using long arguments - # Getopt::Long::Configure("bundling"); - - Getopt::Long::Configure("no_ignore_case"); - - # no difference in exists and defined for %ENV; also, a "0" - # argument or a "" would not help cc, so skip - unshift @ARGV, split ' ', $ENV{PERLCC_OPTS} if $ENV{PERLCC_OPTS}; - - $Options = {}; - Getopt::Long::GetOptions( $Options, - 'L:s', # lib directory - 'I:s', # include directories (FOR C, NOT FOR PERL) - 'o:s', # Output executable - 'v:i', # Verbosity level - 'e:s', # One-liner - 'r', # run resulting executable - 'B', # Byte compiler backend - 'O', # Optimised C backend - 'c', # Compile only - 'h', # Help me - 'S', # Dump C files - 'r', # run the resulting executable - 'T', # run the backend using perl -T - 't', # run the backend using perl -t - 'static', # Dirty hack to enable -shared/-static - 'shared', # Create a shared library (--shared for compat.) - 'log:s', # where to log compilation process information - 'Wb:s', # pass (comma-sepearated) options to backend - 'testsuite', # try to be nice to testsuite - ); - - $Options->{v} += 0; - - if( opt(t) && opt(T) ) { - warn "Can't specify both -T and -t, -t ignored"; - $Options->{t} = 0; - } - - helpme() if opt(h); # And exit - - $Output = opt(o) || ( is_win32 ? 'a.exe' : 'a.out' ); - $Output = is_win32() ? $Output : relativize($Output); - $logfh = new FileHandle(">> " . opt('log')) if (opt('log')); - - if (opt(e)) { - warn "$0: using -e 'code' as input file, ignoring @ARGV\n" if @ARGV; - # We don't use a temporary file here; why bother? - # XXX: this is not bullet proof -- spaces or quotes in name! - $Input = is_win32() ? # Quotes eaten by shell - '-e "'.opt(e).'"' : - "-e '".opt(e)."'"; - } else { - $Input = shift @ARGV; # XXX: more files? - _usage_and_die("$0: No input file specified\n") unless $Input; - # DWIM modules. This is bad but necessary. - $Options->{shared}++ if $Input =~ /\.pm\z/; - warn "$0: using $Input as input file, ignoring @ARGV\n" if @ARGV; - check_read($Input); - check_perl($Input); - sanity_check(); - } - -} - -sub opt(*) { - my $opt = shift; - return exists($Options->{$opt}) && ($Options->{$opt} || 0); -} - -sub compile_module { - die "$0: Compiling to shared libraries is currently disabled\n"; -} - -sub compile_byte { - my $command = "$BinPerl -MO=Bytecode,-H,-o$Output $Input"; - $Input =~ s/^-e.*$/-e/; - - my ($output_r, $error_r) = spawnit($command); - - if (@$error_r && $? != 0) { - _die("$0: $Input did not compile:\n@$error_r\n"); - } else { - my @error = grep { !/^$Input syntax OK$/o } @$error_r; - warn "$0: Unexpected compiler output:\n@error" if @error; - } - - chmod 0777 & ~umask, $Output or _die("can't chmod $Output: $!"); - exit 0; -} - -sub compile_cstyle { - my $stash = grab_stash(); - my $taint = opt(T) ? '-T' : - opt(t) ? '-t' : ''; - - # What are we going to call our output C file? - my $lose = 0; - my ($cfh); - my $testsuite = ''; - my $addoptions = opt(Wb); - - if( $addoptions ) { - $addoptions .= ',' if $addoptions !~ m/,$/; - } - - if (opt(testsuite)) { - my $bo = join '', @begin_output; - $bo =~ s/\\/\\\\\\\\/gs; - $bo =~ s/\n/\\n/gs; - $bo =~ s/,/\\054/gs; - # don't look at that: it hurts - $testsuite = q{-fuse-script-name,-fsave-data,-fsave-sig-hash,}. - qq[-e"print q{$bo}",] . - q{-e"open(Test::Builder::TESTOUT\054 '>&STDOUT') or die $!",} . - q{-e"open(Test::Builder::TESTERR\054 '>&STDERR') or die $!",}; - } - if (opt(S) || opt(c)) { - # We need to keep it. - if (opt(e)) { - $cfile = "a.out.c"; - } else { - $cfile = $Input; - # File off extension if present - # hold on: plx is executable; also, careful of ordering! - $cfile =~ s/\.(?:p(?:lx|l|h)|m)\z//i; - $cfile .= ".c"; - $cfile = $Output if opt(c) && $Output =~ /\.c\z/i; - } - check_write($cfile); - } else { - # Don't need to keep it, be safe with a tempfile. - $lose = 1; - ($cfh, $cfile) = tempfile("pccXXXXX", SUFFIX => ".c"); - close $cfh; # See comment just below - } - vprint 1, "Writing C on $cfile"; - - my $max_line_len = ''; - if ($^O eq 'MSWin32' && $Config{cc} =~ /^cl/i) { - $max_line_len = '-l2000,'; - } - - # This has to do the write itself, so we can't keep a lock. Life - # sucks. - my $command = "$BinPerl $taint -MO=$Backend,$addoptions$testsuite$max_line_len$stash,-o$cfile $Input"; - vprint 1, "Compiling..."; - vprint 1, "Calling $command"; - - my ($output_r, $error_r) = spawnit($command); - my @output = @$output_r; - my @error = @$error_r; - - if (@error && $? != 0) { - _die("$0: $Input did not compile, which can't happen:\n@error\n"); - } - - is_msvc ? - cc_harness_msvc($cfile,$stash) : - cc_harness($cfile,$stash) unless opt(c); - - if ($lose) { - vprint 2, "unlinking $cfile"; - unlink $cfile or _die("can't unlink $cfile: $!"); - } -} - -sub cc_harness_msvc { - my ($cfile,$stash)=@_; - use ExtUtils::Embed (); - my $obj = "${Output}.obj"; - my $compile = ExtUtils::Embed::ccopts." -c -Fo$obj $cfile "; - my $link = "-out:$Output $obj"; - $compile .= " -I".$_ for split /\s+/, opt(I); - $link .= " -libpath:".$_ for split /\s+/, opt(L); - my @mods = split /-?u /, $stash; - $link .= " ".ExtUtils::Embed::ldopts("-std", \@mods); - $link .= " perl5$Config{PERL_VERSION}.lib kernel32.lib msvcrt.lib"; - vprint 3, "running $Config{cc} $compile"; - system("$Config{cc} $compile"); - vprint 3, "running $Config{ld} $link"; - system("$Config{ld} $link"); -} - -sub cc_harness { - my ($cfile,$stash)=@_; - use ExtUtils::Embed (); - my $command = ExtUtils::Embed::ccopts." -o $Output $cfile "; - $command .= " -I".$_ for split /\s+/, opt(I); - $command .= " -L".$_ for split /\s+/, opt(L); - my @mods = split /-?u /, $stash; - $command .= " ".ExtUtils::Embed::ldopts("-std", \@mods); - $command .= " -lperl"; - vprint 3, "running $Config{cc} $command"; - system("$Config{cc} $command"); -} - -# Where Perl is, and which include path to give it. -sub yclept { - my $command = "$^X "; - - # DWIM the -I to be Perl, not C, include directories. - if (opt(I) && $Backend eq "Bytecode") { - for (split /\s+/, opt(I)) { - if (-d $_) { - push @INC, $_; - } else { - warn "$0: Include directory $_ not found, skipping\n"; - } - } - } - - $command .= "-I$_ " for @INC; - return $command; -} - -# Use B::Stash to find additional modules and stuff. -{ - my $_stash; - sub grab_stash { - - warn "already called get_stash once" if $_stash; - - my $taint = opt(T) ? '-T' : - opt(t) ? '-t' : ''; - my $command = "$BinPerl $taint -MB::Stash -c $Input"; - # Filename here is perfectly sanitised. - vprint 3, "Calling $command\n"; - - my ($stash_r, $error_r) = spawnit($command); - my @stash = @$stash_r; - my @error = @$error_r; - - if (@error && $? != 0) { - _die("$0: $Input did not compile:\n@error\n"); - } - - # band-aid for modules with noisy BEGIN {} - foreach my $i ( @stash ) { - $i =~ m/-u(?:[\w:]+|\)$/ and $stash[0] = $i and next; - push @begin_output, $i; - } - chomp $stash[0]; - $stash[0] =~ s/,-u\//; - $stash[0] =~ s/^.*?-u/-u/s; - vprint 2, "Stash: ", join " ", split /,?-u/, $stash[0]; - chomp $stash[0]; - return $_stash = $stash[0]; - } - -} - -# Check the consistency of options if -B is selected. -# To wit, (-B|-O) ==> no -shared, no -S, no -c -sub checkopts_byte { - - _die("$0: Please choose one of either -B and -O.\n") if opt(O); - - if (opt(shared)) { - warn "$0: Will not create a shared library for bytecode\n"; - delete $Options->{shared}; - } - - for my $o ( qw[c S] ) { - if (opt($o)) { - warn "$0: Compiling to bytecode is a one-pass process--", - "-$o ignored\n"; - delete $Options->{$o}; - } - } - -} - -# Check the input and output files make sense, are read/writeable. -sub sanity_check { - if ($Input eq $Output) { - if ($Input eq 'a.out') { - _die("$0: Compiling a.out is probably not what you want to do.\n"); - # You fully deserve what you get now. No you *don't*. typos happen. - } else { - warn "$0: Will not write output on top of input file, ", - "compiling to a.out instead\n"; - $Output = "a.out"; - } - } -} - -sub check_read { - my $file = shift; - unless (-r $file) { - _die("$0: Input file $file is a directory, not a file\n") if -d _; - unless (-e _) { - _die("$0: Input file $file was not found\n"); - } else { - _die("$0: Cannot read input file $file: $!\n"); - } - } - unless (-f _) { - # XXX: die? don't try this on /dev/tty - warn "$0: WARNING: input $file is not a plain file\n"; - } -} - -sub check_write { - my $file = shift; - if (-d $file) { - _die("$0: Cannot write on $file, is a directory\n"); - } - if (-e _) { - _die("$0: Cannot write on $file: $!\n") unless -w _; - } - unless (-w cwd()) { - _die("$0: Cannot write in this directory: $!\n"); - } -} - -sub check_perl { - my $file = shift; - unless (-T $file) { - warn "$0: Binary `$file' sure doesn't smell like perl source!\n"; - print "Checking file type... "; - system("file", $file); - _die("Please try a perlier file!\n"); - } - - open(my $handle, "<", $file) or _die("XXX: can't open $file: $!"); - local $_ = <$handle>; - if (/^#!/ && !/perl/) { - _die("$0: $file is a ", /^#!\s*(\S+)/, " script, not perl\n"); - } - -} - -# File spawning and error collecting -sub spawnit { - my ($command) = shift; - my (@error,@output); - my $errname; - (undef, $errname) = tempfile("pccXXXXX"); - { - open (S_OUT, "$command 2>$errname |") - or _die("$0: Couldn't spawn the compiler.\n"); - @output = ; - } - open (S_ERROR, $errname) or _die("$0: Couldn't read the error file.\n"); - @error = ; - close S_ERROR; - close S_OUT; - unlink $errname or _die("$0: Can't unlink error file $errname"); - return (\@output, \@error); -} - -sub helpme { - print "perlcc compiler frontend, version $VERSION\n\n"; - { no warnings; - exec "pod2usage $0"; - exec "perldoc $0"; - exec "pod2text $0"; - } -} - -sub relativize { - my ($args) = @_; - - return() if ($args =~ m"^[/\\]"); - return("./$args"); -} - -sub _die { - $logfh->print(@_) if opt('log'); - print STDERR @_; - exit(); # should die eventually. However, needed so that a 'make compile' - # can compile all the way through to the end for standard dist. -} - -sub _usage_and_die { - _die(<print(interruptrun(@commands)) if (opt('log')); -} - -sub interruptrun -{ - my (@commands) = @_; - - my $command = join('', @commands); - local(*FD); - my $pid = open(FD, "$command |"); - my $text; - - local($SIG{HUP}) = sub { kill 9, $pid; exit }; - local($SIG{INT}) = sub { kill 9, $pid; exit }; - - my $needalarm = - ($ENV{PERLCC_TIMEOUT} && - $Config{'osname'} ne 'MSWin32' && - $command =~ m"(^|\s)perlcc\s"); - - eval - { - local($SIG{ALRM}) = sub { die "INFINITE LOOP"; }; - alarm($ENV{PERLCC_TIMEOUT}) if ($needalarm); - $text = join('', ); - alarm(0) if ($needalarm); - }; - - if ($@) - { - eval { kill 'HUP', $pid }; - vprint 0, "SYSTEM TIMEOUT (infinite loop?)\n"; - } - - close(FD); - return($text); -} - -sub is_win32() { $^O =~ m/^MSWin/ } -sub is_msvc() { is_win32 && $Config{cc} =~ m/^cl/i } - -END { - unlink $cfile if ($cfile && !opt(S) && !opt(c)); -} - -__END__ - -=head1 NAME - -perlcc - generate executables from Perl programs - -=head1 SYNOPSIS - - $ perlcc hello # Compiles into executable 'a.out' - $ perlcc -o hello hello.pl # Compiles into executable 'hello' - - $ perlcc -O file # Compiles using the optimised C backend - $ perlcc -B file # Compiles using the bytecode backend - - $ perlcc -c file # Creates a C file, 'file.c' - $ perlcc -S -o hello file # Creates a C file, 'file.c', - # then compiles it to executable 'hello' - $ perlcc -c out.c file # Creates a C file, 'out.c' from 'file' - - $ perlcc -e 'print q//' # Compiles a one-liner into 'a.out' - $ perlcc -c -e 'print q//' # Creates a C file 'a.out.c' - - $ perlcc -I /foo hello # extra headers (notice the space after -I) - $ perlcc -L /foo hello # extra libraries (notice the space after -L) - - $ perlcc -r hello # compiles 'hello' into 'a.out', runs 'a.out'. - $ perlcc -r hello a b c # compiles 'hello' into 'a.out', runs 'a.out'. - # with arguments 'a b c' - - $ perlcc hello -log c # compiles 'hello' into 'a.out' logs compile - # log into 'c'. - -=head1 DESCRIPTION - -F creates standalone executables from Perl programs, using the -code generators provided by the L module. At present, you may -either create executable Perl bytecode, using the C<-B> option, or -generate and compile C files using the standard and 'optimised' C -backends. - -The code generated in this way is not guaranteed to work. The whole -codegen suite (C included) should be considered B -experimental. Use for production purposes is strongly discouraged. - -=head1 OPTIONS - -=over 4 - -=item -LI - -Adds the given directories to the library search path when C code is -passed to your C compiler. - -=item -II - -Adds the given directories to the include file search path when C code is -passed to your C compiler; when using the Perl bytecode option, adds the -given directories to Perl's include path. - -=item -o I - -Specifies the file name for the final compiled executable. - -=item -c I - -Create C code only; do not compile to a standalone binary. - -=item -e I - -Compile a one-liner, much the same as C - -=item -S - -Do not delete generated C code after compilation. - -=item -B - -Use the Perl bytecode code generator. - -=item -O - -Use the 'optimised' C code generator. This is more experimental than -everything else put together, and the code created is not guaranteed to -compile in finite time and memory, or indeed, at all. - -=item -v - -Increase verbosity of output; can be repeated for more verbose output. - -=item -r - -Run the resulting compiled script after compiling it. - -=item -log - -Log the output of compiling to a file rather than to stdout. - -=back - -=cut - -!NO!SUBS! - -close OUT or die "Can't close $file: $!"; -chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; -exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; -chdir $origdir; diff --git a/vms/descrip_mms.template b/vms/descrip_mms.template index c7b85e9..d789ea4 100644 --- a/vms/descrip_mms.template +++ b/vms/descrip_mms.template @@ -353,7 +353,7 @@ unidatadirs = lib/unicore/To lib/unicore/lib LIBPREREQ = $(ARCHDIR)Config.pm $(ARCHDIR)Config_heavy.pl [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm [.lib]XSLoader.pm [.lib]lib.pm [.lib.ExtUtils]XSSymSet.pm $(ARCHDIR)vmspipe.com [.lib]re.pm unidatafiles.ts utils1 = [.lib.pods]perldoc.com [.lib.ExtUtils]Miniperl.pm [.utils]c2ph.com [.utils]h2ph.com -utils2 = [.utils]h2xs.com [.utils]libnetcfg.com [.lib]perlbug.com [.lib]perlcc.com [.utils]dprofpp.com +utils2 = [.utils]h2xs.com [.utils]libnetcfg.com [.lib]perlbug.com [.utils]dprofpp.com utils3 = [.utils]perlivp.com [.lib]splain.com [.utils]pl2pm.com [.utils]xsubpp.com [.utils]instmodsh.com utils4 = [.utils]enc2xs.com [.utils]piconv.com [.utils]cpan.com [.utils]prove.com [.utils]ptar.com [.utils]ptardiff.com [.utils]shasum.com utils5 = [.utils]corelist.com [.utils]config_data.com @@ -603,10 +603,6 @@ dynext : $(LIBPREREQ) $(DBG)perlshr$(E) preplibrary makeppport $(MINIPERL) -"I[-.lib]" $(MMS$SOURCE) Copy/NoConfirm/Log [.utils]perlbug.com [.lib] -[.lib]perlcc.com : [.utils]perlcc.PL $(ARCHDIR)Config.pm - $(MINIPERL) -"I[-.lib]" $(MMS$SOURCE) - Copy/NoConfirm/Log [.utils]perlcc.com [.lib] - [.utils]piconv.com : [.utils]piconv.PL $(ARCHDIR)Config.pm $(MINIPERL) -"I[-.lib]" $(MMS$SOURCE) diff --git a/win32/Makefile b/win32/Makefile index a449a4b..2ab3254 100644 --- a/win32/Makefile +++ b/win32/Makefile @@ -545,7 +545,6 @@ UTILS = \ ..\utils\pstruct \ ..\utils\h2xs \ ..\utils\perldoc \ - ..\utils\perlcc \ ..\utils\perlivp \ ..\utils\libnetcfg \ ..\utils\enc2xs \ @@ -1237,7 +1236,7 @@ distclean: realclean pod2html pod2latex pod2man pod2text pod2usage \ podchecker podselect -cd ..\utils && del /f h2ph splain perlbug pl2pm c2ph pstruct h2xs \ - perldoc perlivp dprofpp perlcc libnetcfg enc2xs piconv cpan *.bat \ + perldoc perlivp dprofpp libnetcfg enc2xs piconv cpan *.bat \ xsubpp instmodsh prove ptar ptardiff shasum corelist config_data -cd ..\x2p && del /f find2perl s2p psed *.bat -del /f ..\config.sh ..\splittree.pl perlmain.c dlutils.c config.h.new diff --git a/win32/makefile.mk b/win32/makefile.mk index 8477401..bf05fc2 100644 --- a/win32/makefile.mk +++ b/win32/makefile.mk @@ -689,7 +689,6 @@ UTILS = \ ..\utils\pstruct \ ..\utils\h2xs \ ..\utils\perldoc \ - ..\utils\perlcc \ ..\utils\perlivp \ ..\utils\libnetcfg \ ..\utils\enc2xs \ @@ -1372,7 +1371,7 @@ distclean: realclean pod2html pod2latex pod2man pod2text pod2usage \ podchecker podselect -cd ..\utils && del /f h2ph splain perlbug pl2pm c2ph pstruct h2xs \ - perldoc perlivp dprofpp perlcc libnetcfg enc2xs piconv cpan *.bat \ + perldoc perlivp dprofpp libnetcfg enc2xs piconv cpan *.bat \ xsubpp instmodsh prove ptar ptardiff shasum corelist config_data -cd ..\x2p && del /f find2perl s2p psed *.bat -del /f ..\config.sh ..\splittree.pl perlmain.c dlutils.c config.h.new diff --git a/win32/pod.mak b/win32/pod.mak index 07181de..8a27402 100644 --- a/win32/pod.mak +++ b/win32/pod.mak @@ -541,9 +541,3 @@ podchecker: podchecker.PL ../lib/Config.pm podselect: podselect.PL ../lib/Config.pm $(PERL) -I ../lib podselect.PL - -compile: all - $(REALPERL) -I../lib ../utils/perlcc pod2latex -o pod2latex.exe -v 10 -log ../compilelog - $(REALPERL) -I../lib ../utils/perlcc pod2man -o pod2man.exe -v 10 -log ../compilelog - $(REALPERL) -I../lib ../utils/perlcc pod2text -o pod2text.exe -v 10 -log ../compilelog - $(REALPERL) -I../lib ../utils/perlcc checkpods -o checkpods.exe -v 10 -log ../compilelog diff --git a/x2p/Makefile.SH b/x2p/Makefile.SH index 1b48753..2c0b5c1 100755 --- a/x2p/Makefile.SH +++ b/x2p/Makefile.SH @@ -103,9 +103,6 @@ lintflags = -phbvxac all: $(public) $(private) $(util) @echo " " -compile: all - $(REALPERL) -I../lib ../utils/perlcc -I .. -L .. $(plextract) -v -log ../compilelog; - a2p$(EXE_EXT): $(obj) a2p$(OBJ_EXT) $(CC) -o a2p $(LDFLAGS) $(obj) a2p$(OBJ_EXT) $(libs) -- 1.8.3.1