From: Malcolm Beattie Date: Fri, 20 Feb 1998 18:23:47 +0000 (+0000) Subject: Remove compiler files from their old lib/B locations. The compiler X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e21c45ac3eeaa7a94c61f7c376ce867a862637e4;p=p5sagit%2Fp5-mst-13.2.git Remove compiler files from their old lib/B locations. The compiler now builds by default (without the byteperl executable so far) and seems to work at least minimally. p4raw-id: //depot/perl@565 --- diff --git a/MANIFEST b/MANIFEST index 7d2920b..a0e0dd5 100644 --- a/MANIFEST +++ b/MANIFEST @@ -32,7 +32,9 @@ XSUB.h Include file for extension subroutines av.c Array value code av.h Array value header bytecode.h Bytecode header for compiler -bytecode.pl Produces byterun.h, byterun.c and lib/B/Asmdata.pm +bytecode.pl Produces byterun.h, byterun.c and ext/B/Asmdata.pm +byterun.c Runtime support for compiler-generated bytecode +byterun.h Header for byterun.c cc_runtime.h Macros need by runtime of compiler-generated code cflags.SH A script that emits C compilation flags per file compat3.sym List of symbols for binary-compatibility with 5.003 @@ -123,9 +125,29 @@ emacs/ptags Creates smart TAGS file embed.h Maps symbols to safer names embed.pl Produces embed.h embedvar.h C namespace management +ext/B/B.pm Compiler backend support functions and methods ext/B/B.xs Compiler backend external subroutines +ext/B/B/Asmdata.pm Compiler backend data for assembler +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/C.pm Compiler C backend +ext/B/B/CC.pm Compiler CC backend +ext/B/B/Debug.pm Compiler Debug backend +ext/B/B/Deparse.pm Compiler Deparse backend +ext/B/B/Disassembler.pm Compiler Disassembler backend +ext/B/B/Lint.pm Compiler Lint backend +ext/B/B/Showlex.pm Compiler Showlex backend +ext/B/B/Stackobj.pm Compiler stack objects support functions +ext/B/B/Terse.pm Compiler Terse backend +ext/B/B/Xref.pm Compiler Xref backend +ext/B/B/assemble Assemble compiler bytecode +ext/B/B/cc_harness Simplistic wrapper for using -MO=CC compiler +ext/B/B/disassemble Disassemble compiler bytecode output +ext/B/B/makeliblinks Make a simplistic XSUB .so symlink tree for compiler 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/README Compiler backend README ext/B/TESTS Compiler backend test data ext/B/Todo Compiler backend Todo list @@ -368,11 +390,6 @@ keywords.pl Program to write keywords.h lib/AnyDBM_File.pm Perl module to emulate dbmopen lib/AutoLoader.pm Autoloader base class lib/AutoSplit.pm Split up autoload functions -lib/B.pm Compiler backend support functions and methods -lib/B/assemble Assemble compiler bytecode -lib/B/cc_harness Simplistic wrapper for using -MO=CC compiler -lib/B/disassemble Disassemble compiler bytecode output -lib/B/makeliblinks Make a simplistic XSUB .so symlink tree for compiler lib/Benchmark.pm Measure execution time lib/Bundle/CPAN.pm The CPAN bundle lib/CGI.pm Web server interface ("Common Gateway Interface") @@ -433,7 +450,6 @@ lib/Net/hostent.pm By-name interface to Perl's builtin gethost* lib/Net/netent.pm By-name interface to Perl's builtin getnet* lib/Net/protoent.pm By-name interface to Perl's builtin getproto* lib/Net/servent.pm By-name interface to Perl's builtin getserv* -lib/O.pm Compiler front-end module (-MO=...) lib/Pod/Functions.pm used by pod/splitpod lib/Pod/Html.pm Convert POD data to HTML lib/Pod/Text.pm Convert POD data to formatted ASCII text diff --git a/bytecode.pl b/bytecode.pl index 7fa3fe4..8eadbdd 100644 --- a/bytecode.pl +++ b/bytecode.pl @@ -34,12 +34,12 @@ EOT my $perl_header; ($perl_header = $c_header) =~ s{[/ ]?\*/?}{#}g; -unlink "byterun.c", "byterun.h", "lib/B/Asmdata.pm"; +unlink "byterun.c", "byterun.h", "ext/B/Asmdata.pm"; # # Start with boilerplate for Asmdata.pm # -open(ASMDATA_PM, ">lib/B/Asmdata.pm") or die "Asmdata.pm: $!"; +open(ASMDATA_PM, ">ext/B/Asmdata.pm") or die "Asmdata.pm: $!"; print ASMDATA_PM $perl_header, <<'EOT'; package B::Asmdata; use Exporter; diff --git a/lib/B.pm b/lib/B.pm deleted file mode 100644 index 8545c5c..0000000 --- a/lib/B.pm +++ /dev/null @@ -1,271 +0,0 @@ -# B.pm -# -# Copyright (c) 1996, 1997 Malcolm Beattie -# -# You may distribute under the terms of either the GNU General Public -# License or the Artistic License, as specified in the README file. -# -package B; -require DynaLoader; -require Exporter; -@ISA = qw(Exporter DynaLoader); -@EXPORT_OK = qw(byteload_fh byteload_string minus_c ppname - class peekop cast_I32 cstring cchar hash threadsv_names - main_root main_start main_cv svref_2object - walkoptree walkoptree_slow walkoptree_exec walksymtable - parents comppadlist sv_undef compile_stats timing_info); - -use strict; -@B::SV::ISA = 'B::OBJECT'; -@B::NULL::ISA = 'B::SV'; -@B::PV::ISA = 'B::SV'; -@B::IV::ISA = 'B::SV'; -@B::NV::ISA = 'B::IV'; -@B::RV::ISA = 'B::SV'; -@B::PVIV::ISA = qw(B::PV B::IV); -@B::PVNV::ISA = qw(B::PV B::NV); -@B::PVMG::ISA = 'B::PVNV'; -@B::PVLV::ISA = 'B::PVMG'; -@B::BM::ISA = 'B::PVMG'; -@B::AV::ISA = 'B::PVMG'; -@B::GV::ISA = 'B::PVMG'; -@B::HV::ISA = 'B::PVMG'; -@B::CV::ISA = 'B::PVMG'; -@B::IO::ISA = 'B::CV'; - -@B::OP::ISA = 'B::OBJECT'; -@B::UNOP::ISA = 'B::OP'; -@B::BINOP::ISA = 'B::UNOP'; -@B::LOGOP::ISA = 'B::UNOP'; -@B::CONDOP::ISA = 'B::UNOP'; -@B::LISTOP::ISA = 'B::BINOP'; -@B::SVOP::ISA = 'B::OP'; -@B::GVOP::ISA = 'B::OP'; -@B::PVOP::ISA = 'B::OP'; -@B::CVOP::ISA = 'B::OP'; -@B::LOOP::ISA = 'B::LISTOP'; -@B::PMOP::ISA = 'B::LISTOP'; -@B::COP::ISA = 'B::OP'; - -@B::SPECIAL::ISA = 'B::OBJECT'; - -{ - # Stop "-w" from complaining about the lack of a real B::OBJECT class - package B::OBJECT; -} - -my $debug; -my $op_count = 0; -my @parents = (); - -sub debug { - my ($class, $value) = @_; - $debug = $value; - walkoptree_debug($value); -} - -# sub OPf_KIDS; -# add to .xs for perl5.002 -sub OPf_KIDS () { 4 } - -sub class { - my $obj = shift; - my $name = ref $obj; - $name =~ s/^.*:://; - return $name; -} - -sub parents { \@parents } - -# For debugging -sub peekop { - my $op = shift; - return sprintf("%s (0x%x) %s", class($op), $$op, $op->ppaddr); -} - -sub walkoptree_slow { - my($op, $method, $level) = @_; - $op_count++; # just for statistics - $level ||= 0; - warn(sprintf("walkoptree: %d. %s\n", $level, peekop($op))) if $debug; - $op->$method($level); - if ($$op && ($op->flags & OPf_KIDS)) { - my $kid; - unshift(@parents, $op); - for ($kid = $op->first; $$kid; $kid = $kid->sibling) { - walkoptree_slow($kid, $method, $level + 1); - } - shift @parents; - } -} - -sub compile_stats { - return "Total number of OPs processed: $op_count\n"; -} - -sub timing_info { - my ($sec, $min, $hr) = localtime; - my ($user, $sys) = times; - sprintf("%02d:%02d:%02d user=$user sys=$sys", - $hr, $min, $sec, $user, $sys); -} - -my %symtable; -sub savesym { - my ($obj, $value) = @_; -# warn(sprintf("savesym: sym_%x => %s\n", $$obj, $value)); # debug - $symtable{sprintf("sym_%x", $$obj)} = $value; -} - -sub objsym { - my $obj = shift; - return $symtable{sprintf("sym_%x", $$obj)}; -} - -sub walkoptree_exec { - my ($op, $method, $level) = @_; - my ($sym, $ppname); - my $prefix = " " x $level; - for (; $$op; $op = $op->next) { - $sym = objsym($op); - if (defined($sym)) { - print $prefix, "goto $sym\n"; - return; - } - savesym($op, sprintf("%s (0x%lx)", class($op), $$op)); - $op->$method($level); - $ppname = $op->ppaddr; - if ($ppname =~ /^pp_(or|and|mapwhile|grepwhile|entertry)$/) { - print $prefix, uc($1), " => {\n"; - walkoptree_exec($op->other, $method, $level + 1); - print $prefix, "}\n"; - } elsif ($ppname eq "pp_match" || $ppname eq "pp_subst") { - my $pmreplstart = $op->pmreplstart; - if ($$pmreplstart) { - print $prefix, "PMREPLSTART => {\n"; - walkoptree_exec($pmreplstart, $method, $level + 1); - print $prefix, "}\n"; - } - } elsif ($ppname eq "pp_substcont") { - print $prefix, "SUBSTCONT => {\n"; - walkoptree_exec($op->other->pmreplstart, $method, $level + 1); - print $prefix, "}\n"; - $op = $op->other; - } elsif ($ppname eq "pp_cond_expr") { - # pp_cond_expr never returns op_next - print $prefix, "TRUE => {\n"; - walkoptree_exec($op->true, $method, $level + 1); - print $prefix, "}\n"; - $op = $op->false; - redo; - } elsif ($ppname eq "pp_range") { - print $prefix, "TRUE => {\n"; - walkoptree_exec($op->true, $method, $level + 1); - print $prefix, "}\n", $prefix, "FALSE => {\n"; - walkoptree_exec($op->false, $method, $level + 1); - print $prefix, "}\n"; - } elsif ($ppname eq "pp_enterloop") { - print $prefix, "REDO => {\n"; - walkoptree_exec($op->redoop, $method, $level + 1); - print $prefix, "}\n", $prefix, "NEXT => {\n"; - walkoptree_exec($op->nextop, $method, $level + 1); - print $prefix, "}\n", $prefix, "LAST => {\n"; - walkoptree_exec($op->lastop, $method, $level + 1); - print $prefix, "}\n"; - } elsif ($ppname eq "pp_subst") { - my $replstart = $op->pmreplstart; - if ($$replstart) { - print $prefix, "SUBST => {\n"; - walkoptree_exec($replstart, $method, $level + 1); - print $prefix, "}\n"; - } - } - } -} - -sub walksymtable { - my ($symref, $method, $recurse, $prefix) = @_; - my $sym; - no strict 'vars'; - local(*glob); - while (($sym, *glob) = each %$symref) { - if ($sym =~ /::$/) { - $sym = $prefix . $sym; - if ($sym ne "main::" && &$recurse($sym)) { - walksymtable(\%glob, $method, $recurse, $sym); - } - } else { - svref_2object(\*glob)->EGV->$method(); - } - } -} - -{ - package B::Section; - my $output_fh; - my %sections; - - sub new { - my ($class, $section, $symtable, $default) = @_; - $output_fh ||= FileHandle->new_tmpfile; - my $obj = bless [-1, $section, $symtable, $default], $class; - $sections{$section} = $obj; - return $obj; - } - - sub get { - my ($class, $section) = @_; - return $sections{$section}; - } - - sub add { - my $section = shift; - while (defined($_ = shift)) { - print $output_fh "$section->[1]\t$_\n"; - $section->[0]++; - } - } - - sub index { - my $section = shift; - return $section->[0]; - } - - sub name { - my $section = shift; - return $section->[1]; - } - - sub symtable { - my $section = shift; - return $section->[2]; - } - - sub default { - my $section = shift; - return $section->[3]; - } - - sub output { - my ($section, $fh, $format) = @_; - my $name = $section->name; - my $sym = $section->symtable || {}; - my $default = $section->default; - - seek($output_fh, 0, 0); - while (<$output_fh>) { - chomp; - s/^(.*?)\t//; - if ($1 eq $name) { - s{(s\\_[0-9a-f]+)} { - exists($sym->{$1}) ? $sym->{$1} : $default; - }ge; - printf $fh $format, $_; - } - } - } -} - -bootstrap B; - -1; diff --git a/lib/B/Asmdata.pm b/lib/B/Asmdata.pm deleted file mode 100644 index 3a3cf6d..0000000 --- a/lib/B/Asmdata.pm +++ /dev/null @@ -1,150 +0,0 @@ -# -# Copyright (c) 1996, 1997 Malcolm Beattie -# -# You may distribute under the terms of either the GNU General Public -# License or the Artistic License, as specified in the README file. -# -# -# -# This file is autogenerated from bytecode.pl. Changes made here will be lost. -# -package B::Asmdata; -use Exporter; -@ISA = qw(Exporter); -@EXPORT_OK = qw(%insn_data @insn_name @optype @specialsv_name); -use vars qw(%insn_data @insn_name @optype @specialsv_name); - -@optype = qw(OP UNOP BINOP LOGOP CONDOP LISTOP PMOP SVOP GVOP PVOP LOOP COP); -@specialsv_name = qw(Nullsv &sv_undef &sv_yes &sv_no); - -# XXX insn_data is initialised this way because with a large -# %insn_data = (foo => [...], bar => [...], ...) initialiser -# I get a hard-to-track-down stack underflow and segfault. -$insn_data{comment} = [35, \&PUT_comment, "GET_comment"]; -$insn_data{nop} = [10, \&PUT_none, "GET_none"]; -$insn_data{ret} = [0, \&PUT_none, "GET_none"]; -$insn_data{ldsv} = [1, \&PUT_objindex, "GET_objindex"]; -$insn_data{ldop} = [2, \&PUT_objindex, "GET_objindex"]; -$insn_data{stsv} = [3, \&PUT_U32, "GET_U32"]; -$insn_data{stop} = [4, \&PUT_U32, "GET_U32"]; -$insn_data{ldspecsv} = [5, \&PUT_U8, "GET_U8"]; -$insn_data{newsv} = [6, \&PUT_U8, "GET_U8"]; -$insn_data{newop} = [7, \&PUT_U8, "GET_U8"]; -$insn_data{newopn} = [8, \&PUT_U8, "GET_U8"]; -$insn_data{newpv} = [9, \&PUT_PV, "GET_PV"]; -$insn_data{pv_cur} = [11, \&PUT_U32, "GET_U32"]; -$insn_data{pv_free} = [12, \&PUT_none, "GET_none"]; -$insn_data{sv_upgrade} = [13, \&PUT_U8, "GET_U8"]; -$insn_data{sv_refcnt} = [14, \&PUT_U32, "GET_U32"]; -$insn_data{sv_refcnt_add} = [15, \&PUT_I32, "GET_I32"]; -$insn_data{sv_flags} = [16, \&PUT_U32, "GET_U32"]; -$insn_data{xrv} = [17, \&PUT_objindex, "GET_objindex"]; -$insn_data{xpv} = [18, \&PUT_none, "GET_none"]; -$insn_data{xiv32} = [19, \&PUT_I32, "GET_I32"]; -$insn_data{xiv64} = [20, \&PUT_IV64, "GET_IV64"]; -$insn_data{xnv} = [21, \&PUT_double, "GET_double"]; -$insn_data{xlv_targoff} = [22, \&PUT_U32, "GET_U32"]; -$insn_data{xlv_targlen} = [23, \&PUT_U32, "GET_U32"]; -$insn_data{xlv_targ} = [24, \&PUT_objindex, "GET_objindex"]; -$insn_data{xlv_type} = [25, \&PUT_U8, "GET_U8"]; -$insn_data{xbm_useful} = [26, \&PUT_I32, "GET_I32"]; -$insn_data{xbm_previous} = [27, \&PUT_U16, "GET_U16"]; -$insn_data{xbm_rare} = [28, \&PUT_U8, "GET_U8"]; -$insn_data{xfm_lines} = [29, \&PUT_I32, "GET_I32"]; -$insn_data{xio_lines} = [30, \&PUT_I32, "GET_I32"]; -$insn_data{xio_page} = [31, \&PUT_I32, "GET_I32"]; -$insn_data{xio_page_len} = [32, \&PUT_I32, "GET_I32"]; -$insn_data{xio_lines_left} = [33, \&PUT_I32, "GET_I32"]; -$insn_data{xio_top_name} = [34, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{xio_top_gv} = [36, \&PUT_objindex, "GET_objindex"]; -$insn_data{xio_fmt_name} = [37, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{xio_fmt_gv} = [38, \&PUT_objindex, "GET_objindex"]; -$insn_data{xio_bottom_name} = [39, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{xio_bottom_gv} = [40, \&PUT_objindex, "GET_objindex"]; -$insn_data{xio_subprocess} = [41, \&PUT_U16, "GET_U16"]; -$insn_data{xio_type} = [42, \&PUT_U8, "GET_U8"]; -$insn_data{xio_flags} = [43, \&PUT_U8, "GET_U8"]; -$insn_data{xcv_stash} = [44, \&PUT_objindex, "GET_objindex"]; -$insn_data{xcv_start} = [45, \&PUT_objindex, "GET_objindex"]; -$insn_data{xcv_root} = [46, \&PUT_objindex, "GET_objindex"]; -$insn_data{xcv_gv} = [47, \&PUT_objindex, "GET_objindex"]; -$insn_data{xcv_filegv} = [48, \&PUT_objindex, "GET_objindex"]; -$insn_data{xcv_depth} = [49, \&PUT_I32, "GET_I32"]; -$insn_data{xcv_padlist} = [50, \&PUT_objindex, "GET_objindex"]; -$insn_data{xcv_outside} = [51, \&PUT_objindex, "GET_objindex"]; -$insn_data{xcv_flags} = [52, \&PUT_U8, "GET_U8"]; -$insn_data{av_extend} = [53, \&PUT_I32, "GET_I32"]; -$insn_data{av_push} = [54, \&PUT_objindex, "GET_objindex"]; -$insn_data{xav_fill} = [55, \&PUT_I32, "GET_I32"]; -$insn_data{xav_max} = [56, \&PUT_I32, "GET_I32"]; -$insn_data{xav_flags} = [57, \&PUT_U8, "GET_U8"]; -$insn_data{xhv_riter} = [58, \&PUT_I32, "GET_I32"]; -$insn_data{xhv_name} = [59, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{hv_store} = [60, \&PUT_objindex, "GET_objindex"]; -$insn_data{sv_magic} = [61, \&PUT_U8, "GET_U8"]; -$insn_data{mg_obj} = [62, \&PUT_objindex, "GET_objindex"]; -$insn_data{mg_private} = [63, \&PUT_U16, "GET_U16"]; -$insn_data{mg_flags} = [64, \&PUT_U8, "GET_U8"]; -$insn_data{mg_pv} = [65, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{xmg_stash} = [66, \&PUT_objindex, "GET_objindex"]; -$insn_data{gv_fetchpv} = [67, \&PUT_strconst, "GET_strconst"]; -$insn_data{gv_stashpv} = [68, \&PUT_strconst, "GET_strconst"]; -$insn_data{gp_sv} = [69, \&PUT_objindex, "GET_objindex"]; -$insn_data{gp_refcnt} = [70, \&PUT_U32, "GET_U32"]; -$insn_data{gp_refcnt_add} = [71, \&PUT_I32, "GET_I32"]; -$insn_data{gp_av} = [72, \&PUT_objindex, "GET_objindex"]; -$insn_data{gp_hv} = [73, \&PUT_objindex, "GET_objindex"]; -$insn_data{gp_cv} = [74, \&PUT_objindex, "GET_objindex"]; -$insn_data{gp_filegv} = [75, \&PUT_objindex, "GET_objindex"]; -$insn_data{gp_io} = [76, \&PUT_objindex, "GET_objindex"]; -$insn_data{gp_form} = [77, \&PUT_objindex, "GET_objindex"]; -$insn_data{gp_cvgen} = [78, \&PUT_U32, "GET_U32"]; -$insn_data{gp_line} = [79, \&PUT_U16, "GET_U16"]; -$insn_data{gp_share} = [80, \&PUT_objindex, "GET_objindex"]; -$insn_data{xgv_flags} = [81, \&PUT_U8, "GET_U8"]; -$insn_data{op_next} = [82, \&PUT_objindex, "GET_objindex"]; -$insn_data{op_sibling} = [83, \&PUT_objindex, "GET_objindex"]; -$insn_data{op_ppaddr} = [84, \&PUT_strconst, "GET_strconst"]; -$insn_data{op_targ} = [85, \&PUT_U32, "GET_U32"]; -$insn_data{op_type} = [86, \&PUT_U16, "GET_U16"]; -$insn_data{op_seq} = [87, \&PUT_U16, "GET_U16"]; -$insn_data{op_flags} = [88, \&PUT_U8, "GET_U8"]; -$insn_data{op_private} = [89, \&PUT_U8, "GET_U8"]; -$insn_data{op_first} = [90, \&PUT_objindex, "GET_objindex"]; -$insn_data{op_last} = [91, \&PUT_objindex, "GET_objindex"]; -$insn_data{op_other} = [92, \&PUT_objindex, "GET_objindex"]; -$insn_data{op_true} = [93, \&PUT_objindex, "GET_objindex"]; -$insn_data{op_false} = [94, \&PUT_objindex, "GET_objindex"]; -$insn_data{op_children} = [95, \&PUT_U32, "GET_U32"]; -$insn_data{op_pmreplroot} = [96, \&PUT_objindex, "GET_objindex"]; -$insn_data{op_pmreplrootgv} = [97, \&PUT_objindex, "GET_objindex"]; -$insn_data{op_pmreplstart} = [98, \&PUT_objindex, "GET_objindex"]; -$insn_data{op_pmnext} = [99, \&PUT_objindex, "GET_objindex"]; -$insn_data{pregcomp} = [100, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{op_pmflags} = [101, \&PUT_U16, "GET_U16"]; -$insn_data{op_pmpermflags} = [102, \&PUT_U16, "GET_U16"]; -$insn_data{op_sv} = [103, \&PUT_objindex, "GET_objindex"]; -$insn_data{op_gv} = [104, \&PUT_objindex, "GET_objindex"]; -$insn_data{op_pv} = [105, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{op_pv_tr} = [106, \&PUT_op_tr_array, "GET_op_tr_array"]; -$insn_data{op_redoop} = [107, \&PUT_objindex, "GET_objindex"]; -$insn_data{op_nextop} = [108, \&PUT_objindex, "GET_objindex"]; -$insn_data{op_lastop} = [109, \&PUT_objindex, "GET_objindex"]; -$insn_data{cop_label} = [110, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{cop_stash} = [111, \&PUT_objindex, "GET_objindex"]; -$insn_data{cop_filegv} = [112, \&PUT_objindex, "GET_objindex"]; -$insn_data{cop_seq} = [113, \&PUT_U32, "GET_U32"]; -$insn_data{cop_arybase} = [114, \&PUT_I32, "GET_I32"]; -$insn_data{cop_line} = [115, \&PUT_U16, "GET_U16"]; -$insn_data{main_start} = [116, \&PUT_objindex, "GET_objindex"]; -$insn_data{main_root} = [117, \&PUT_objindex, "GET_objindex"]; -$insn_data{curpad} = [118, \&PUT_objindex, "GET_objindex"]; - -my ($insn_name, $insn_data); -while (($insn_name, $insn_data) = each %insn_data) { - $insn_name[$insn_data->[0]] = $insn_name; -} -# Fill in any gaps -@insn_name = map($_ || "unused", @insn_name); - -1; diff --git a/lib/B/Assembler.pm b/lib/B/Assembler.pm deleted file mode 100644 index 0729b90..0000000 --- a/lib/B/Assembler.pm +++ /dev/null @@ -1,207 +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); - -@ISA = qw(Exporter); -@EXPORT_OK = qw(assemble_fh assemble_insn strip_comments - parse_statement uncstring); - -use strict; -my %opnumber; -my ($i, $opname); -for ($i = 0; defined($opname = ppname($i)); $i++) { - $opnumber{$opname} = $i; -} - -my ($linenum, $errors); - -sub error { - my $str = shift; - warn "$linenum: $str\n"; - $errors++; -} - -my $debug = 0; -sub debug { $debug = shift } - -# -# First define all the data conversion subs to which Asmdata will refer -# - -sub B::Asmdata::PUT_U8 { - my $arg = shift; - my $c = uncstring($arg); - if (defined($c)) { - if (length($c) != 1) { - error "argument for U8 is too long: $c"; - $c = substr($c, 0, 1); - } - } else { - $c = chr($arg); - } - return $c; -} - -sub B::Asmdata::PUT_U16 { pack("n", $_[0]) } -sub B::Asmdata::PUT_U32 { pack("N", $_[0]) } -sub B::Asmdata::PUT_I32 { pack("N", $_[0]) } -sub B::Asmdata::PUT_objindex { pack("N", $_[0]) } # could allow names here - -sub B::Asmdata::PUT_strconst { - my $arg = shift; - $arg = uncstring($arg); - if (!defined($arg)) { - error "bad string constant: $arg"; - return ""; - } - if ($arg =~ s/\0//g) { - error "string constant argument contains NUL: $arg"; - } - return $arg . "\0"; -} - -sub B::Asmdata::PUT_pvcontents { - my $arg = shift; - error "extraneous argument: $arg" if defined $arg; - return ""; -} -sub B::Asmdata::PUT_PV { - my $arg = shift; - $arg = uncstring($arg); - error "bad string argument: $arg" unless defined($arg); - return pack("N", length($arg)) . $arg; -} -sub B::Asmdata::PUT_comment { - my $arg = shift; - $arg = uncstring($arg); - error "bad string argument: $arg" unless defined($arg); - if ($arg =~ s/\n//g) { - error "comment argument contains linefeed: $arg"; - } - return $arg . "\n"; -} -sub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) } -sub B::Asmdata::PUT_none { - my $arg = shift; - error "extraneous argument: $arg" if defined $arg; - return ""; -} -sub B::Asmdata::PUT_op_tr_array { - my $arg = shift; - my @ary = split(/\s*,\s*/, $arg); - if (@ary != 256) { - error "wrong number of arguments to op_tr_array"; - @ary = (0) x 256; - } - return pack("n256", @ary); -} -# XXX Check this works -sub B::Asmdata::PUT_IV64 { - my $arg = shift; - return pack("NN", $arg >> 32, $arg & 0xffffffff); -} - -my %unesc = (n => "\n", r => "\r", t => "\t", a => "\a", - b => "\b", f => "\f", v => "\013"); - -sub uncstring { - my $s = shift; - $s =~ s/^"// and $s =~ s/"$// or return undef; - $s =~ s/\\(\d\d\d|.)/length($1) == 3 ? chr(oct($1)) : ($unesc{$1}||$1)/eg; - return $s; -} - -sub strip_comments { - my $stmt = shift; - # Comments only allowed in instructions which don't take string arguments - $stmt =~ s{ - (?sx) # Snazzy extended regexp coming up. Also, treat - # string as a single line so .* eats \n characters. - ^\s* # Ignore leading whitespace - ( - [^"]* # A double quote '"' indicates a string argument. If we - # find a double quote, the match fails and we strip nothing. - ) - \s*\# # Any amount of whitespace plus the comment marker... - .*$ # ...which carries on to end-of-string. - }{$1}; # Keep only the instruction and optional argument. - return $stmt; -} - -sub parse_statement { - my $stmt = shift; - my ($insn, $arg) = $stmt =~ m{ - (?sx) - ^\s* # allow (but ignore) leading whitespace - (.*?) # Instruction continues up until... - (?: # ...an optional whitespace+argument group - \s+ # first whitespace. - (.*) # The argument is all the rest (newlines included). - )?$ # anchor at end-of-line - }; - if (defined($arg)) { - if ($arg =~ s/^0x(?=[0-9a-fA-F]+$)//) { - $arg = hex($arg); - } elsif ($arg =~ s/^0(?=[0-7]+$)//) { - $arg = oct($arg); - } elsif ($arg =~ /^pp_/) { - $arg =~ s/\s*$//; # strip trailing whitespace - my $opnum = $opnumber{$arg}; - if (defined($opnum)) { - $arg = $opnum; - } else { - error qq(No such op type "$arg"); - $arg = 0; - } - } - } - return ($insn, $arg); -} - -sub assemble_insn { - my ($insn, $arg) = @_; - my $data = $insn_data{$insn}; - if (defined($data)) { - my ($bytecode, $putsub) = @{$data}[0, 1]; - my $argcode = &$putsub($arg); - return chr($bytecode).$argcode; - } else { - error qq(no such instruction "$insn"); - return ""; - } -} - -sub assemble_fh { - my ($fh, $out) = @_; - my ($line, $insn, $arg); - $linenum = 0; - $errors = 0; - while ($line = <$fh>) { - $linenum++; - chomp $line; - if ($debug) { - my $quotedline = $line; - $quotedline =~ s/\\/\\\\/g; - $quotedline =~ s/"/\\"/g; - &$out(assemble_insn("comment", qq("$quotedline"))); - } - $line = strip_comments($line) or next; - ($insn, $arg) = parse_statement($line); - &$out(assemble_insn($insn, $arg)); - if ($debug) { - &$out(assemble_insn("nop", undef)); - } - } - if ($errors) { - die "Assembly failed with $errors error(s)\n"; - } -} - -1; diff --git a/lib/B/Bblock.pm b/lib/B/Bblock.pm deleted file mode 100644 index 125c8a3..0000000 --- a/lib/B/Bblock.pm +++ /dev/null @@ -1,142 +0,0 @@ -package B::Bblock; -use Exporter (); -@ISA = "Exporter"; -@EXPORT_OK = qw(find_leaders); - -use B qw(peekop walkoptree walkoptree_exec - main_root main_start svref_2object); -use B::Terse; -use strict; - -my $bblock; -my @bblock_ends; - -sub mark_leader { - my $op = shift; - if ($$op) { - $bblock->{$$op} = $op; - } -} - -sub find_leaders { - my ($root, $start) = @_; - $bblock = {}; - mark_leader($start); - walkoptree($root, "mark_if_leader"); - return $bblock; -} - -# Debugging -sub walk_bblocks { - my ($root, $start) = @_; - my ($op, $lastop, $leader, $bb); - $bblock = {}; - mark_leader($start); - walkoptree($root, "mark_if_leader"); - my @leaders = values %$bblock; - while ($leader = shift @leaders) { - $lastop = $leader; - $op = $leader->next; - while ($$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); - } - print "-------\n"; - walkoptree_exec($start, "terse"); -} - -sub walk_bblocks_obj { - my $cvref = shift; - my $cv = svref_2object($cvref); - walk_bblocks($cv->ROOT, $cv->START); -} - -sub B::OP::mark_if_leader {} - -sub B::COP::mark_if_leader { - my $op = shift; - if ($op->label) { - mark_leader($op); - } -} - -sub B::LOOP::mark_if_leader { - my $op = shift; - mark_leader($op->next); - mark_leader($op->nextop); - mark_leader($op->redoop); - mark_leader($op->lastop->next); -} - -sub B::LOGOP::mark_if_leader { - my $op = shift; - my $ppaddr = $op->ppaddr; - mark_leader($op->next); - if ($ppaddr eq "pp_entertry") { - mark_leader($op->other->next); - } else { - mark_leader($op->other); - } -} - -sub B::CONDOP::mark_if_leader { - my $op = shift; - mark_leader($op->next); - mark_leader($op->true); - mark_leader($op->false); -} - -sub B::PMOP::mark_if_leader { - my $op = shift; - if ($op->ppaddr ne "pp_pushre") { - my $replroot = $op->pmreplroot; - if ($$replroot) { - mark_leader($replroot); - mark_leader($op->next); - mark_leader($op->pmreplstart); - } - } -} - -# PMOP stuff omitted - -sub compile { - my @options = @_; - if (@options) { - return sub { - my $objname; - foreach $objname (@options) { - $objname = "main::$objname" unless $objname =~ /::/; - eval "walk_bblocks_obj(\\&$objname)"; - die "walk_bblocks_obj(\\&$objname) failed: $@" if $@; - } - } - } else { - return sub { walk_bblocks(main_root, main_start) }; - } -} - -# Basic block leaders: -# Any COP (pp_nextstate) with a non-NULL label -# [The op after a pp_enter] 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 ops pointed at by op_true and op_false of a CONDOP -# The op pointed at by op_pmreplstart of a PMOP -# The op pointed at by op_other->op_pmreplstart of pp_substcont? -# [The op after a pp_return] Omit - -1; diff --git a/lib/B/Bytecode.pm b/lib/B/Bytecode.pm deleted file mode 100644 index 447bd37..0000000 --- a/lib/B/Bytecode.pm +++ /dev/null @@ -1,778 +0,0 @@ -# Bytecode.pm -# -# Copyright (c) 1996-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::Bytecode; -use strict; -use Carp; -use IO::File; - -use B qw(minus_c main_cv main_root main_start comppadlist - class peekop walkoptree svref_2object cstring walksymtable); -use B::Asmdata qw(@optype @specialsv_name); -use B::Assembler qw(assemble_fh); - -my %optype_enum; -my $i; -for ($i = 0; $i < @optype; $i++) { - $optype_enum{$optype[$i]} = $i; -} - -# Following is SVf_POK|SVp_POK -# XXX Shouldn't be hardwired -sub POK () { 0x04040000 } - -# Following is SVf_IOK|SVp_OK -# XXX Shouldn't be hardwired -sub IOK () { 0x01010000 } - -my ($verbose, $module_only, $no_assemble, $debug_bc, $debug_cv); -my $assembler_pid; - -# Optimisation options. On the command line, use hyphens instead of -# underscores for compatibility with gcc-style options. We use -# underscores here because they are OK in (strict) barewords. -my ($strip_syntree, $compress_nullops, $omit_seq, $bypass_nullops); -my %optimise = (strip_syntax_tree => \$strip_syntree, - compress_nullops => \$compress_nullops, - omit_sequence_numbers => \$omit_seq, - bypass_nullops => \$bypass_nullops); - -my $nextix = 0; -my %symtable; # maps object addresses to object indices. - # Filled in at allocation (newsv/newop) time. -my %saved; # maps object addresses (for SVish classes) to "saved yet?" - # flag. Set at FOO::bytecode time usually by SV::bytecode. - # Manipulated via saved(), mark_saved(), unmark_saved(). - -my $svix = -1; # we keep track of when the sv register contains an element - # of the object table to avoid unnecessary repeated - # consecutive ldsv instructions. -my $opix = -1; # Ditto for the op register. - -sub ldsv { - my $ix = shift; - if ($ix != $svix) { - print "ldsv $ix\n"; - $svix = $ix; - } -} - -sub stsv { - my $ix = shift; - print "stsv $ix\n"; - $svix = $ix; -} - -sub set_svix { - $svix = shift; -} - -sub ldop { - my $ix = shift; - if ($ix != $opix) { - print "ldop $ix\n"; - $opix = $ix; - } -} - -sub stop { - my $ix = shift; - print "stop $ix\n"; - $opix = $ix; -} - -sub set_opix { - $opix = shift; -} - -sub pvstring { - my $str = shift; - if (defined($str)) { - return cstring($str . "\0"); - } else { - return '""'; - } -} - -sub saved { $saved{${$_[0]}} } -sub mark_saved { $saved{${$_[0]}} = 1 } -sub unmark_saved { $saved{${$_[0]}} = 0 } - -sub debug { $debug_bc = shift } - -sub B::OBJECT::nyi { - my $obj = shift; - warn sprintf("bytecode save method for %s (0x%x) not yet implemented\n", - class($obj), $$obj); -} - -# -# objix may stomp on the op register (for op objects) -# or the sv register (for SV objects) -# -sub B::OBJECT::objix { - my $obj = shift; - my $ix = $symtable{$$obj}; - if (defined($ix)) { - return $ix; - } else { - $obj->newix($nextix); - return $symtable{$$obj} = $nextix++; - } -} - -sub B::SV::newix { - my ($sv, $ix) = @_; - printf "newsv %d\t# %s\n", $sv->FLAGS & 0xf, class($sv); - stsv($ix); -} - -sub B::GV::newix { - my ($gv, $ix) = @_; - my $gvname = $gv->NAME; - my $name = cstring($gv->STASH->NAME . "::" . $gvname); - print "gv_fetchpv $name\n"; - stsv($ix); -} - -sub B::HV::newix { - my ($hv, $ix) = @_; - my $name = $hv->NAME; - if ($name) { - # It's a stash - printf "gv_stashpv %s\n", cstring($name); - stsv($ix); - } else { - # It's an ordinary HV. Fall back to ordinary newix method - $hv->B::SV::newix($ix); - } -} - -sub B::SPECIAL::newix { - my ($sv, $ix) = @_; - # Special case. $$sv is not the address of the SV but an - # index into svspecialsv_list. - printf "ldspecsv $$sv\t# %s\n", $specialsv_name[$$sv]; - stsv($ix); -} - -sub B::OP::newix { - my ($op, $ix) = @_; - my $class = class($op); - my $typenum = $optype_enum{$class}; - croak "OP::newix: can't understand class $class" unless defined($typenum); - print "newop $typenum\t# $class\n"; - stop($ix); -} - -sub B::OP::walkoptree_debug { - my $op = shift; - warn(sprintf("walkoptree: %s\n", peekop($op))); -} - -sub B::OP::bytecode { - my $op = shift; - my $next = $op->next; - my $nextix; - my $sibix = $op->sibling->objix; - my $ix = $op->objix; - my $type = $op->type; - - if ($bypass_nullops) { - $next = $next->next while $$next && $next->type == 0; - } - $nextix = $next->objix; - - printf "# %s\n", peekop($op) if $debug_bc; - ldop($ix); - print "op_next $nextix\n"; - print "op_sibling $sibix\n" unless $strip_syntree; - printf "op_type %s\t# %d\n", $op->ppaddr, $type; - printf("op_seq %d\n", $op->seq) unless $omit_seq; - if ($type || !$compress_nullops) { - printf "op_targ %d\nop_flags 0x%x\nop_private 0x%x\n", - $op->targ, $op->flags, $op->private; - } -} - -sub B::UNOP::bytecode { - my $op = shift; - my $firstix = $op->first->objix; - $op->B::OP::bytecode; - if (($op->type || !$compress_nullops) && !$strip_syntree) { - print "op_first $firstix\n"; - } -} - -sub B::LOGOP::bytecode { - my $op = shift; - my $otherix = $op->other->objix; - $op->B::UNOP::bytecode; - print "op_other $otherix\n"; -} - -sub B::SVOP::bytecode { - my $op = shift; - my $sv = $op->sv; - my $svix = $sv->objix; - $op->B::OP::bytecode; - print "op_sv $svix\n"; - $sv->bytecode; -} - -sub B::GVOP::bytecode { - my $op = shift; - my $gv = $op->gv; - my $gvix = $gv->objix; - $op->B::OP::bytecode; - print "op_gv $gvix\n"; - $gv->bytecode; -} - -sub B::PVOP::bytecode { - my $op = shift; - my $pv = $op->pv; - $op->B::OP::bytecode; - # - # This would be easy except that OP_TRANS uses a PVOP to store an - # endian-dependent array of 256 shorts instead of a plain string. - # - if ($op->ppaddr eq "pp_trans") { - my @shorts = unpack("s256", $pv); # assembler handles endianness - print "op_pv_tr ", join(",", @shorts), "\n"; - } else { - printf "newpv %s\nop_pv\n", pvstring($pv); - } -} - -sub B::BINOP::bytecode { - my $op = shift; - my $lastix = $op->last->objix; - $op->B::UNOP::bytecode; - if (($op->type || !$compress_nullops) && !$strip_syntree) { - print "op_last $lastix\n"; - } -} - -sub B::CONDOP::bytecode { - my $op = shift; - my $trueix = $op->true->objix; - my $falseix = $op->false->objix; - $op->B::UNOP::bytecode; - print "op_true $trueix\nop_false $falseix\n"; -} - -sub B::LISTOP::bytecode { - my $op = shift; - my $children = $op->children; - $op->B::BINOP::bytecode; - if (($op->type || !$compress_nullops) && !$strip_syntree) { - print "op_children $children\n"; - } -} - -sub B::LOOP::bytecode { - my $op = shift; - my $redoopix = $op->redoop->objix; - my $nextopix = $op->nextop->objix; - my $lastopix = $op->lastop->objix; - $op->B::LISTOP::bytecode; - print "op_redoop $redoopix\nop_nextop $nextopix\nop_lastop $lastopix\n"; -} - -sub B::COP::bytecode { - my $op = shift; - my $stash = $op->stash; - my $stashix = $stash->objix; - my $filegv = $op->filegv; - my $filegvix = $filegv->objix; - my $line = $op->line; - if ($debug_bc) { - printf "# line %s:%d\n", $filegv->SV->PV, $line; - } - $op->B::OP::bytecode; - printf <<"EOT", pvstring($op->label), $op->cop_seq, $op->arybase; -newpv %s -cop_label -cop_stash $stashix -cop_seq %d -cop_filegv $filegvix -cop_arybase %d -cop_line $line -EOT - $filegv->bytecode; - $stash->bytecode; -} - -sub B::PMOP::bytecode { - my $op = shift; - my $replroot = $op->pmreplroot; - my $replrootix = $replroot->objix; - my $replstartix = $op->pmreplstart->objix; - my $ppaddr = $op->ppaddr; - # pmnext is corrupt in some PMOPs (see misc.t for example) - #my $pmnextix = $op->pmnext->objix; - - if ($$replroot) { - # OP_PUSHRE (a mutated version of OP_MATCH for the regexp - # argument to a split) stores a GV in op_pmreplroot instead - # of a substitution syntax tree. We don't want to walk that... - if ($ppaddr eq "pp_pushre") { - $replroot->bytecode; - } else { - walkoptree($replroot, "bytecode"); - } - } - $op->B::LISTOP::bytecode; - if ($ppaddr eq "pp_pushre") { - printf "op_pmreplrootgv $replrootix\n"; - } else { - print "op_pmreplroot $replrootix\nop_pmreplstart $replstartix\n"; - } - my $re = pvstring($op->precomp); - # op_pmnext omitted since a perl bug means it's sometime corrupt - printf <<"EOT", $op->pmflags, $op->pmpermflags; -op_pmflags 0x%x -op_pmpermflags 0x%x -newpv $re -pregcomp -EOT -} - -sub B::SV::bytecode { - my $sv = shift; - return if saved($sv); - my $ix = $sv->objix; - my $refcnt = $sv->REFCNT; - my $flags = sprintf("0x%x", $sv->FLAGS); - ldsv($ix); - print "sv_refcnt $refcnt\nsv_flags $flags\n"; - mark_saved($sv); -} - -sub B::PV::bytecode { - my $sv = shift; - return if saved($sv); - $sv->B::SV::bytecode; - printf("newpv %s\nxpv\n", pvstring($sv->PV)) if $sv->FLAGS & POK; -} - -sub B::IV::bytecode { - my $sv = shift; - return if saved($sv); - my $iv = $sv->IVX; - $sv->B::SV::bytecode; - printf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32"; -} - -sub B::NV::bytecode { - my $sv = shift; - return if saved($sv); - $sv->B::SV::bytecode; - printf "xnv %s\n", $sv->NVX; -} - -sub B::RV::bytecode { - my $sv = shift; - return if saved($sv); - my $rv = $sv->RV; - my $rvix = $rv->objix; - $rv->bytecode; - $sv->B::SV::bytecode; - print "xrv $rvix\n"; -} - -sub B::PVIV::bytecode { - my $sv = shift; - return if saved($sv); - my $iv = $sv->IVX; - $sv->B::PV::bytecode; - printf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32"; -} - -sub B::PVNV::bytecode { - my ($sv, $flag) = @_; - # The $flag argument is passed through PVMG::bytecode by BM::bytecode - # and AV::bytecode and indicates special handling. $flag = 1 is used by - # BM::bytecode and means that we should ensure we save the whole B-M - # table. It consists of 257 bytes (256 char array plus a final \0) - # which follow the ordinary PV+\0 and the 257 bytes are *not* reflected - # in SvCUR. $flag = 2 is used by AV::bytecode and means that we only - # call SV::bytecode instead of saving PV and calling NV::bytecode since - # PV/NV/IV stuff is different for AVs. - return if saved($sv); - if ($flag == 2) { - $sv->B::SV::bytecode; - } else { - my $pv = $sv->PV; - $sv->B::IV::bytecode; - printf "xnv %s\n", $sv->NVX; - if ($flag == 1) { - $pv .= "\0" . $sv->TABLE; - printf "newpv %s\npv_cur %d\nxpv\n", pvstring($pv),length($pv)-257; - } else { - printf("newpv %s\nxpv\n", pvstring($pv)) if $sv->FLAGS & POK; - } - } -} - -sub B::PVMG::bytecode { - my ($sv, $flag) = @_; - # See B::PVNV::bytecode for an explanation of $flag. - return if saved($sv); - # XXX We assume SvSTASH is already saved and don't save it later ourselves - my $stashix = $sv->SvSTASH->objix; - my @mgchain = $sv->MAGIC; - my (@mgobjix, $mg); - # - # We need to traverse the magic chain and get objix for each OBJ - # field *before* we do B::PVNV::bytecode since objix overwrites - # the sv register. However, we need to write the magic-saving - # bytecode *after* B::PVNV::bytecode since sv isn't initialised - # to refer to $sv until then. - # - @mgobjix = map($_->OBJ->objix, @mgchain); - $sv->B::PVNV::bytecode($flag); - print "xmg_stash $stashix\n"; - foreach $mg (@mgchain) { - printf "sv_magic %s\nmg_obj %d\nnewpv %s\nmg_pv\n", - cstring($mg->TYPE), shift(@mgobjix), pvstring($mg->PTR); - } -} - -sub B::PVLV::bytecode { - my $sv = shift; - return if saved($sv); - $sv->B::PVMG::bytecode; - printf <<'EOT', $sv->TARGOFF, $sv->TARGLEN, cstring($sv->TYPE); -xlv_targoff %d -xlv_targlen %d -xlv_type %s -EOT -} - -sub B::BM::bytecode { - my $sv = shift; - return if saved($sv); - # See PVNV::bytecode for an explanation of what the argument does - $sv->B::PVMG::bytecode(1); - printf "xbm_useful %d\nxbm_previous %d\nxbm_rare %d\n", - $sv->USEFUL, $sv->PREVIOUS, $sv->RARE; -} - -sub B::GV::bytecode { - my $gv = shift; - return if saved($gv); - my $ix = $gv->objix; - mark_saved($gv); - my $gvname = $gv->NAME; - my $name = cstring($gv->STASH->NAME . "::" . $gvname); - my $egv = $gv->EGV; - my $egvix = $egv->objix; - ldsv($ix); - printf <<"EOT", $gv->FLAGS, $gv->GvFLAGS, $gv->LINE; -sv_flags 0x%x -xgv_flags 0x%x -gp_line %d -EOT - my $refcnt = $gv->REFCNT; - printf("sv_refcnt_add %d\n", $refcnt - 1) if $refcnt > 1; - my $gvrefcnt = $gv->GvREFCNT; - printf("gp_refcnt_add %d\n", $gvrefcnt - 1) if $gvrefcnt > 1; - if ($gvrefcnt > 1 && $ix != $egvix) { - print "gp_share $egvix\n"; - } else { - if ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) { - my $i; - my @subfield_names = qw(SV AV HV CV FILEGV FORM IO); - my @subfields = map($gv->$_(), @subfield_names); - my @ixes = map($_->objix, @subfields); - # Reset sv register for $gv - ldsv($ix); - for ($i = 0; $i < @ixes; $i++) { - printf "gp_%s %d\n", lc($subfield_names[$i]), $ixes[$i]; - } - # Now save all the subfields - my $sv; - foreach $sv (@subfields) { - $sv->bytecode; - } - } - } -} - -sub B::HV::bytecode { - my $hv = shift; - return if saved($hv); - mark_saved($hv); - my $name = $hv->NAME; - my $ix = $hv->objix; - if (!$name) { - # It's an ordinary HV. Stashes have NAME set and need no further - # saving beyond the gv_stashpv that $hv->objix already ensures. - my @contents = $hv->ARRAY; - my ($i, @ixes); - for ($i = 1; $i < @contents; $i += 2) { - push(@ixes, $contents[$i]->objix); - } - for ($i = 1; $i < @contents; $i += 2) { - $contents[$i]->bytecode; - } - ldsv($ix); - for ($i = 0; $i < @contents; $i += 2) { - printf("newpv %s\nhv_store %d\n", - pvstring($contents[$i]), $ixes[$i / 2]); - } - printf "sv_refcnt %d\nsv_flags 0x%x\n", $hv->REFCNT, $hv->FLAGS; - } -} - -sub B::AV::bytecode { - my $av = shift; - return if saved($av); - my $ix = $av->objix; - my $fill = $av->FILL; - my $max = $av->MAX; - my (@array, @ixes); - if ($fill > -1) { - @array = $av->ARRAY; - @ixes = map($_->objix, @array); - my $sv; - foreach $sv (@array) { - $sv->bytecode; - } - } - # See PVNV::bytecode for the meaning of the flag argument of 2. - $av->B::PVMG::bytecode(2); - # Recover sv register and set AvMAX and AvFILL to -1 (since we - # create an AV with NEWSV and SvUPGRADE rather than doing newAV - # which is what sets AvMAX and AvFILL. - ldsv($ix); - printf "xav_flags 0x%x\nxav_max -1\nxav_fill -1\n", $av->AvFLAGS; - if ($fill > -1) { - my $elix; - foreach $elix (@ixes) { - print "av_push $elix\n"; - } - } else { - if ($max > -1) { - print "av_extend $max\n"; - } - } -} - -sub B::CV::bytecode { - my $cv = shift; - return if saved($cv); - my $ix = $cv->objix; - $cv->B::PVMG::bytecode; - my $i; - my @subfield_names = qw(ROOT START STASH GV FILEGV PADLIST OUTSIDE); - my @subfields = map($cv->$_(), @subfield_names); - my @ixes = map($_->objix, @subfields); - # Save OP tree from CvROOT (first element of @subfields) - my $root = shift @subfields; - if ($$root) { - walkoptree($root, "bytecode"); - } - # Reset sv register for $cv (since above ->objix calls stomped on it) - ldsv($ix); - for ($i = 0; $i < @ixes; $i++) { - printf "xcv_%s %d\n", lc($subfield_names[$i]), $ixes[$i]; - } - printf "xcv_depth %d\nxcv_flags 0x%x\n", $cv->DEPTH, $cv->FLAGS; - # Now save all the subfields (except for CvROOT which was handled - # above) and CvSTART (now the initial element of @subfields). - shift @subfields; # bye-bye CvSTART - my $sv; - foreach $sv (@subfields) { - $sv->bytecode; - } -} - -sub B::IO::bytecode { - my $io = shift; - return if saved($io); - my $ix = $io->objix; - my $top_gv = $io->TOP_GV; - my $top_gvix = $top_gv->objix; - my $fmt_gv = $io->FMT_GV; - my $fmt_gvix = $fmt_gv->objix; - my $bottom_gv = $io->BOTTOM_GV; - my $bottom_gvix = $bottom_gv->objix; - - $io->B::PVMG::bytecode; - ldsv($ix); - print "xio_top_gv $top_gvix\n"; - print "xio_fmt_gv $fmt_gvix\n"; - print "xio_bottom_gv $bottom_gvix\n"; - my $field; - foreach $field (qw(TOP_NAME FMT_NAME BOTTOM_NAME)) { - printf "newpv %s\nxio_%s\n", pvstring($io->$field()), lc($field); - } - foreach $field (qw(LINES PAGE PAGE_LEN LINES_LEFT SUBPROCESS)) { - printf "xio_%s %d\n", lc($field), $io->$field(); - } - printf "xio_type %s\nxio_flags 0x%x\n", cstring($io->IoTYPE), $io->IoFLAGS; - $top_gv->bytecode; - $fmt_gv->bytecode; - $bottom_gv->bytecode; -} - -sub B::SPECIAL::bytecode { - # nothing extra needs doing -} - -sub bytecompile_object { - my $sv; - foreach $sv (@_) { - svref_2object($sv)->bytecode; - } -} - -sub B::GV::bytecodecv { - my $gv = shift; - my $cv = $gv->CV; - if ($$cv && !saved($cv)) { - if ($debug_cv) { - warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n", - $gv->STASH->NAME, $gv->NAME, $$cv, $$gv); - } - $gv->bytecode; - } -} - -sub bytecompile_main { - my $curpad = (comppadlist->ARRAY)[1]; - my $curpadix = $curpad->objix; - $curpad->bytecode; - walkoptree(main_root, "bytecode"); - warn "done main program, now walking symbol table\n" if $debug_bc; - my ($pack, %exclude); - foreach $pack (qw(B O AutoLoader DynaLoader Config DB VMS strict vars - FileHandle Exporter Carp UNIVERSAL IO Fcntl Symbol - SelectSaver blib Cwd)) - { - $exclude{$pack."::"} = 1; - } - no strict qw(vars refs); - walksymtable(\%{"main::"}, "bytecodecv", sub { - warn "considering $_[0]\n" if $debug_bc; - return !defined($exclude{$_[0]}); - }); - if (!$module_only) { - printf "main_root %d\n", main_root->objix; - printf "main_start %d\n", main_start->objix; - printf "curpad $curpadix\n"; - # XXX Do min_intro_pending and max_intro_pending matter? - } -} - -sub prepare_assemble { - my $newfh = IO::File->new_tmpfile; - select($newfh); - binmode $newfh; - return $newfh; -} - -sub do_assemble { - my $fh = shift; - seek($fh, 0, 0); # rewind the temporary file - assemble_fh($fh, sub { print OUT @_ }); -} - -sub compile { - my @options = @_; - my ($option, $opt, $arg); - open(OUT, ">&STDOUT"); - binmode OUT; - select(OUT); - 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(OUT, ">$arg") or return "$arg: $!\n"; - binmode OUT; - } elsif ($opt eq "D") { - $arg ||= shift @options; - foreach $arg (split(//, $arg)) { - if ($arg eq "b") { - $| = 1; - debug(1); - } elsif ($arg eq "o") { - B->debug(1); - } elsif ($arg eq "a") { - B::Assembler::debug(1); - } elsif ($arg eq "C") { - $debug_cv = 1; - } - } - } elsif ($opt eq "v") { - $verbose = 1; - } elsif ($opt eq "m") { - $module_only = 1; - } elsif ($opt eq "S") { - $no_assemble = 1; - } elsif ($opt eq "f") { - $arg ||= shift @options; - my $value = $arg !~ s/^no-//; - $arg =~ s/-/_/g; - my $ref = $optimise{$arg}; - if (defined($ref)) { - $$ref = $value; - } else { - warn qq(ignoring unknown optimisation option "$arg"\n); - } - } elsif ($opt eq "O") { - $arg = 1 if $arg eq ""; - my $ref; - foreach $ref (values %optimise) { - $$ref = 0; - } - if ($arg >= 6) { - $strip_syntree = 1; - } - if ($arg >= 2) { - $bypass_nullops = 1; - } - if ($arg >= 1) { - $compress_nullops = 1; - $omit_seq = 1; - } - } - } - if (@options) { - return sub { - my $objname; - my $newfh; - $newfh = prepare_assemble() unless $no_assemble; - foreach $objname (@options) { - eval "bytecompile_object(\\$objname)"; - } - do_assemble($newfh) unless $no_assemble; - } - } else { - return sub { - my $newfh; - $newfh = prepare_assemble() unless $no_assemble; - bytecompile_main(); - do_assemble($newfh) unless $no_assemble; - } - } -} - -1; diff --git a/lib/B/C.pm b/lib/B/C.pm deleted file mode 100644 index 4158bc4..0000000 --- a/lib/B/C.pm +++ /dev/null @@ -1,1201 +0,0 @@ -# C.pm -# -# Copyright (c) 1996, 1997 Malcolm Beattie -# -# You may distribute under the terms of either the GNU General Public -# License or the Artistic License, as specified in the README file. -# -package B::C; -use Exporter (); -@ISA = qw(Exporter); -@EXPORT_OK = qw(output_all output_boilerplate output_main - init_sections set_callback save_unused_subs objsym); - -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); -use B::Asmdata qw(@specialsv_name); - -use FileHandle; -use Carp; -use strict; - -my $hv_index = 0; -my $gv_index = 0; -my $re_index = 0; -my $pv_index = 0; -my $anonsub_index = 0; - -my %symtable; -my $warn_undefined_syms; -my $verbose; -my @unused_sub_packages; -my $nullop_count; -my $pv_copy_on_grow; -my ($debug_cops, $debug_av, $debug_cv, $debug_mg); - -my @threadsv_names; -BEGIN { - @threadsv_names = threadsv_names(); -} - -# Code sections -my ($init, $decl, $symsect, $binopsect, $condopsect, $copsect, $cvopsect, - $gvopsect, $listopsect, $logopsect, $loopsect, $opsect, $pmopsect, - $pvopsect, $svopsect, $unopsect, $svsect, $xpvsect, $xpvavsect, - $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect, - $xrvsect, $xpvbmsect, $xpviosect); - -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); -} - -# Current workaround/fix for op_free() trying to free statically -# defined OPs is to set op_seq = -1 and check for that in op_free(). -# Instead of hardwiring -1 in place of $op->seq, we use $op_seq -# so that it can be changed back easily if necessary. In fact, to -# stop compilers from moaning about a U16 being initialised with an -# uncast -1 (the printf format is %d so we can't tweak it), we have -# to "know" that op_seq is a U16 and use 65535. Ugh. -my $op_seq = 65535; - -sub AVf_REAL () { 1 } - -# XXX This shouldn't really be hardcoded here but it saves -# looking up the name of every BASEOP in B::OP -sub OP_THREADSV () { 345 } - -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 savepv { - my $pv = shift; - my $pvsym = 0; - my $pvmax = 0; - if ($pv_copy_on_grow) { - my $cstring = cstring($pv); - if ($cstring ne "0") { # sic - $pvsym = sprintf("pv%d", $pv_index++); - $decl->add(sprintf("static char %s[] = %s;", $pvsym, $cstring)); - } - } else { - $pvmax = length($pv) + 1; - } - return ($pvsym, $pvmax); -} - -sub B::OP::save { - my ($op, $level) = @_; - my $type = $op->type; - $nullop_count++ unless $type; - 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(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x", - ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ, - $type, $op_seq, $op->flags, $op->private)); - savesym($op, sprintf("&op_list[%d]", $opsect->index)); -} - -sub B::FAKEOP::new { - my ($class, %objdata) = @_; - bless \%objdata, $class; -} - -sub B::FAKEOP::save { - my ($op, $level) = @_; - $opsect->add(sprintf("%s, %s, %s, %u, %u, %u, 0x%x, 0x%x", - $op->next, $op->sibling, $op->ppaddr, $op->targ, - $op->type, $op_seq, $op->flags, $op->private)); - return sprintf("&op_list[%d]", $opsect->index); -} - -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) = @_; - $unopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x", - ${$op->next}, ${$op->sibling}, $op->ppaddr, - $op->targ, $op->type, $op_seq, $op->flags, - $op->private, ${$op->first})); - savesym($op, sprintf("(OP*)&unop_list[%d]", $unopsect->index)); -} - -sub B::BINOP::save { - my ($op, $level) = @_; - $binopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x", - ${$op->next}, ${$op->sibling}, $op->ppaddr, - $op->targ, $op->type, $op_seq, $op->flags, - $op->private, ${$op->first}, ${$op->last})); - savesym($op, sprintf("(OP*)&binop_list[%d]", $binopsect->index)); -} - -sub B::LISTOP::save { - my ($op, $level) = @_; - $listopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u", - ${$op->next}, ${$op->sibling}, $op->ppaddr, - $op->targ, $op->type, $op_seq, $op->flags, - $op->private, ${$op->first}, ${$op->last}, - $op->children)); - savesym($op, sprintf("(OP*)&listop_list[%d]", $listopsect->index)); -} - -sub B::LOGOP::save { - my ($op, $level) = @_; - $logopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x", - ${$op->next}, ${$op->sibling}, $op->ppaddr, - $op->targ, $op->type, $op_seq, $op->flags, - $op->private, ${$op->first}, ${$op->other})); - savesym($op, sprintf("(OP*)&logop_list[%d]", $logopsect->index)); -} - -sub B::CONDOP::save { - my ($op, $level) = @_; - $condopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, s\\_%x", - ${$op->next}, ${$op->sibling}, $op->ppaddr, - $op->targ, $op->type, $op_seq, $op->flags, - $op->private, ${$op->first}, ${$op->true}, - ${$op->false})); - savesym($op, sprintf("(OP*)&condop_list[%d]", $condopsect->index)); -} - -sub B::LOOP::save { - my ($op, $level) = @_; - #warn sprintf("LOOP: redoop %s, nextop %s, lastop %s\n", - # peekop($op->redoop), peekop($op->nextop), - # peekop($op->lastop)); # debug - $loopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u, s\\_%x, s\\_%x, s\\_%x", - ${$op->next}, ${$op->sibling}, $op->ppaddr, - $op->targ, $op->type, $op_seq, $op->flags, - $op->private, ${$op->first}, ${$op->last}, - $op->children, ${$op->redoop}, ${$op->nextop}, - ${$op->lastop})); - savesym($op, sprintf("(OP*)&loop_list[%d]", $loopsect->index)); -} - -sub B::PVOP::save { - my ($op, $level) = @_; - $pvopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s", - ${$op->next}, ${$op->sibling}, $op->ppaddr, - $op->targ, $op->type, $op_seq, $op->flags, - $op->private, cstring($op->pv))); - savesym($op, sprintf("(OP*)&pvop_list[%d]", $pvopsect->index)); -} - -sub B::SVOP::save { - my ($op, $level) = @_; - my $svsym = $op->sv->save; - $svopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s", - ${$op->next}, ${$op->sibling}, $op->ppaddr, - $op->targ, $op->type, $op_seq, $op->flags, - $op->private, "(SV*)$svsym")); - savesym($op, sprintf("(OP*)&svop_list[%d]", $svopsect->index)); -} - -sub B::GVOP::save { - my ($op, $level) = @_; - my $gvsym = $op->gv->save; - $gvopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, Nullgv", - ${$op->next}, ${$op->sibling}, $op->ppaddr, - $op->targ, $op->type, $op_seq, $op->flags, - $op->private)); - $init->add(sprintf("gvop_list[%d].op_gv = %s;", $gvopsect->index, $gvsym)); - savesym($op, sprintf("(OP*)&gvop_list[%d]", $gvopsect->index)); -} - -sub B::COP::save { - my ($op, $level) = @_; - my $gvsym = $op->filegv->save; - my $stashsym = $op->stash->save; - warn sprintf("COP: line %d file %s\n", $op->line, $op->filegv->SV->PV) - if $debug_cops; - $copsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s, Nullhv, Nullgv, %u, %d, %u", - ${$op->next}, ${$op->sibling}, $op->ppaddr, - $op->targ, $op->type, $op_seq, $op->flags, - $op->private, cstring($op->label), $op->cop_seq, - $op->arybase, $op->line)); - my $copix = $copsect->index; - $init->add(sprintf("cop_list[%d].cop_filegv = %s;", $copix, $gvsym), - sprintf("cop_list[%d].cop_stash = %s;", $copix, $stashsym)); - savesym($op, "(OP*)&cop_list[$copix]"); -} - -sub B::PMOP::save { - my ($op, $level) = @_; - my $replroot = $op->pmreplroot; - my $replstart = $op->pmreplstart; - my $replrootfield = sprintf("s\\_%x", $$replroot); - my $replstartfield = sprintf("s\\_%x", $$replstart); - my $gvsym; - my $ppaddr = $op->ppaddr; - if ($$replroot) { - # OP_PUSHRE (a mutated version of OP_MATCH for the regexp - # argument to a split) stores a GV in op_pmreplroot instead - # of a substitution syntax tree. We don't want to walk that... - if ($ppaddr eq "pp_pushre") { - $gvsym = $replroot->save; -# warn "PMOP::save saving a pp_pushre with GV $gvsym\n"; # debug - $replrootfield = 0; - } else { - $replstartfield = saveoptree("*ignore*", $replroot, $replstart); - } - } - # pmnext handling is broken in perl itself, I think. Bad op_pmnext - # fields aren't noticed in perl's runtime (unless you try reset) but we - # segfault when trying to dereference it to find op->op_pmnext->op_type - $pmopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u, %s, %s, 0, 0, 0x%x, 0x%x", - ${$op->next}, ${$op->sibling}, $ppaddr, $op->targ, - $op->type, $op_seq, $op->flags, $op->private, - ${$op->first}, ${$op->last}, $op->children, - $replrootfield, $replstartfield, - $op->pmflags, $op->pmpermflags,)); - my $pm = sprintf("pmop_list[%d]", $pmopsect->index); - my $re = $op->precomp; - if (defined($re)) { - my $resym = sprintf("re%d", $re_index++); - $decl->add(sprintf("static char *$resym = %s;", cstring($re))); - $init->add(sprintf("$pm.op_pmregexp = pregcomp($resym, $resym + %u, &$pm);", - length($re))); - } - if ($gvsym) { - $init->add("$pm.op_pmreplroot = (OP*)$gvsym;"); - } - savesym($op, sprintf("(OP*)&pmop_list[%d]", $pmopsect->index)); -} - -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"; - #} - $svsect->add(sprintf("0, %u, 0x%x", $sv->REFCNT + 1, $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 + 1, $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; - $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $sv->NVX)); - $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x", - $xpvnvsect->index, $sv->REFCNT + 1, $sv->FLAGS)); - return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); -} - -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 + 1, $sv->FLAGS)); - if (!$pv_copy_on_grow) { - $init->add(sprintf("xpvlv_list[%d].xpv_pv = savepvn(%s, %u);", - $xpvlvsect->index, cstring($pv), $len)); - } - $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 $pv = $sv->PV; - my $len = length($pv); - my ($pvsym, $pvmax) = savepv($pv); - $xpvivsect->add(sprintf("%s, %u, %u, %d", $pvsym, $len, $pvmax, $sv->IVX)); - $svsect->add(sprintf("&xpviv_list[%d], %u, 0x%x", - $xpvivsect->index, $sv->REFCNT + 1, $sv->FLAGS)); - if (!$pv_copy_on_grow) { - $init->add(sprintf("xpviv_list[%d].xpv_pv = savepvn(%s, %u);", - $xpvivsect->index, cstring($pv), $len)); - } - 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 $pv = $sv->PV; - my $len = length($pv); - my ($pvsym, $pvmax) = savepv($pv); - $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s", - $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX)); - $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x", - $xpvnvsect->index, $sv->REFCNT + 1, $sv->FLAGS)); - if (!$pv_copy_on_grow) { - $init->add(sprintf("xpvnv_list[%d].xpv_pv = savepvn(%s,%u);", - $xpvnvsect->index, cstring($pv), $len)); - } - 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 = $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 + 1, $sv->FLAGS)); - $sv->save_magic; - $init->add(sprintf("xpvbm_list[%d].xpv_pv = savepvn(%s, %u);", - $xpvbmsect->index, cstring($pv), $len), - 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 $pv = $sv->PV; - my $len = length($pv); - my ($pvsym, $pvmax) = savepv($pv); - $xpvsect->add(sprintf("%s, %u, %u", $pvsym, $len, $pvmax)); - $svsect->add(sprintf("&xpv_list[%d], %lu, 0x%x", - $xpvsect->index, $sv->REFCNT + 1, $sv->FLAGS)); - if (!$pv_copy_on_grow) { - $init->add(sprintf("xpv_list[%d].xpv_pv = savepvn(%s, %u);", - $xpvsect->index, cstring($pv), $len)); - } - 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 $pv = $sv->PV; - my $len = length($pv); - my ($pvsym, $pvmax) = savepv($pv); - $xpvmgsect->add(sprintf("%s, %u, %u, %d, %s, 0, 0", - $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX)); - $svsect->add(sprintf("&xpvmg_list[%d], %lu, 0x%x", - $xpvmgsect->index, $sv->REFCNT + 1, $sv->FLAGS)); - if (!$pv_copy_on_grow) { - $init->add(sprintf("xpvmg_list[%d].xpv_pv = savepvn(%s, %u);", - $xpvmgsect->index, cstring($pv), $len)); - } - $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; - 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); - foreach $mg (@mgchain) { - $type = $mg->TYPE; - $obj = $mg->OBJ; - $ptr = $mg->PTR; - my $len = defined($ptr) ? length($ptr) : 0; - if ($debug_mg) { - warn sprintf("magic %s (0x%x), obj %s (0x%x), type %s, ptr %s\n", - class($sv), $$sv, class($obj), $$obj, - cchar($type), cstring($ptr)); - } - $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);", - $$sv, $$obj, cchar($type),cstring($ptr),$len)); - } -} - -sub B::RV::save { - my ($sv) = @_; - my $sym = objsym($sv); - return $sym if defined $sym; - $xrvsect->add($sv->RV->save); - $svsect->add(sprintf("&xrv_list[%d], %lu, 0x%x", - $xrvsect->index, $sv->REFCNT + 1, $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 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 $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 CV 0x%x as $sym\n", $$cv) if $debug_cv; - my $gv = $cv->GV; - my $cvstashname = $gv->STASH->NAME; - my $cvname = $gv->NAME; - my $root = $cv->ROOT; - my $cvxsub = $cv->XSUB; - 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 (!$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; - } - } - elsif ($cvxsub) { - $xsubany = sprintf("ANYINIT((void*)0x%x)", $cv->XSUBANY); - # Try to find out canonical name of XSUB function from EGV. - # XXX Doesn't work for XSUBs with PREFIX set (or anyone who - # calls newXS() manually with weird arguments). - my $egv = $gv->EGV; - my $stashname = $egv->STASH->NAME; - $stashname =~ s/::/__/g; - $xsub = sprintf("XS_%s_%s", $stashname, $egv->NAME); - $decl->add("void $xsub _((CV*));"); - } - else { - warn sprintf("No definition for sub %s::%s (unable to autoload)\n", - $cvstashname, $cvname); # debug - } - $symsect->add(sprintf("xpvcvix%d\t%s, %u, 0, %d, %s, 0, Nullhv, Nullhv, %s, s\\_%x, $xsub, $xsubany, Nullgv, Nullgv, %d, s\\_%x, (CV*)s\\_%x, 0", - $xpvcv_ix, cstring($pv), length($pv), $cv->IVX, - $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH, - $$padlist, ${$cv->OUTSIDE})); - 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; - } - my $filegv = $cv->FILEGV; - if ($$filegv) { - $filegv->save; - $init->add(sprintf("CvFILEGV(s\\_%x) = s\\_%x;", $$cv, $$filegv)); - warn sprintf("done saving FILEGV 0x%x for CV 0x%x\n", - $$filegv, $$cv) if $debug_cv; - } - 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, $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 $gvname = $gv->NAME; - my $name = cstring($gv->STASH->NAME . "::" . $gvname); - #warn "GV name is $name\n"; # debug - my $egv = $gv->EGV; - my $egvsym; - 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), - sprintf("GvLINE($sym) = %u;", $gv->LINE)); - # Shouldn't need to do save_magic since gv_fetchpv handles that - #$gv->save_magic; - my $refcnt = $gv->REFCNT + 1; - $init->add(sprintf("SvREFCNT($sym) += %u;", $refcnt - 1)) if $refcnt > 1; - my $gvrefcnt = $gv->GvREFCNT; - if ($gvrefcnt > 1) { - $init->add(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1)); - } - if (defined($egvsym)) { - # Shared glob *foo = *bar - $init->add("gp_free($sym);", - "GvGP($sym) = GvGP($egvsym);"); - } elsif ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) { - # Don't save subfields of special GVs (*_, *1, *# and so on) -# warn "GV::save saving subfields\n"; # debug - my $gvsv = $gv->SV; - if ($$gvsv) { - $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv)); -# warn "GV::save \$$name\n"; # debug - $gvsv->save; - } - my $gvav = $gv->AV; - if ($$gvav) { - $init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav)); -# warn "GV::save \@$name\n"; # debug - $gvav->save; - } - my $gvhv = $gv->HV; - if ($$gvhv) { - $init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv)); -# warn "GV::save \%$name\n"; # debug - $gvhv->save; - } - my $gvcv = $gv->CV; - if ($$gvcv) { - $init->add(sprintf("GvCV($sym) = (CV*)s\\_%x;", $$gvcv)); -# warn "GV::save &$name\n"; # debug - $gvcv->save; - } - my $gvfilegv = $gv->FILEGV; - if ($$gvfilegv) { - $init->add(sprintf("GvFILEGV($sym) = s\\_%x;",$$gvfilegv)); -# warn "GV::save GvFILEGV(*$name)\n"; # debug - $gvfilegv->save; - } - my $gvform = $gv->FORM; - if ($$gvform) { - $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform)); -# warn "GV::save GvFORM(*$name)\n"; # debug - $gvform->save; - } - my $gvio = $gv->IO; - if ($$gvio) { - $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio)); -# warn "GV::save GvIO(*$name)\n"; # debug - $gvio->save; - } - } - return $sym; -} -sub B::AV::save { - my ($av) = @_; - my $sym = objsym($av); - return $sym if defined $sym; - my $avflags = $av->AvFLAGS; - $xpvavsect->add(sprintf("0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0, 0x%x", - $avflags)); - $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x", - $xpvavsect->index, $av->REFCNT + 1, $av->FLAGS)); - my $sv_list_index = $svsect->index; - my $fill = $av->FILL; - $av->save_magic; - warn sprintf("saving AV 0x%x FILL=$fill AvFLAGS=0x%x", $$av, $avflags) - if $debug_av; - # XXX AVf_REAL is wrong test: need to save comppadlist but not stack - #if ($fill > -1 && ($avflags & AVf_REAL)) { - if ($fill > -1) { - my @array = $av->ARRAY; - if ($debug_av) { - my $el; - my $i = 0; - foreach $el (@array) { - warn sprintf("AV 0x%x[%d] = %s 0x%x\n", - $$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++] = ...; - $init->add("{", - "\tSV **svp;", - "\tAV *av = (AV*)&sv_list[$sv_list_index];", - "\tav_extend(av, $fill);", - "\tsvp = AvARRAY(av);", - map("\t*svp++ = (SV*)$_;", @names), - "\tAvFILLp(av) = $fill;", - "}"); - } 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 + 1, $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->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($key),$value, hash($key))); - } - $init->add("}"); - } - return savesym($hv, "(HV*)&sv_list[$sv_list_index]"); -} - -sub B::IO::save { - my ($io) = @_; - my $sym = objsym($io); - return $sym if defined $sym; - my $pv = $io->PV; - my $len = length($pv); - $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 + 1, $io->FLAGS)); - $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index)); - 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, $gvopsect, $pvopsect, - $cvopsect, $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"; - } - } - $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 },\n"); - print "};\n\n"; - } - } - - print <<"EOT"; -static int $init_name() -{ - dTHR; -EOT - $init->output(\*STDOUT, "\t%s\n"); - print "\treturn 0;\n}\n"; - 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 -/* - * Cribbed from cv.h with ANY (a union) replaced by void*. - * Some pre-Standard compilers can't cope with initialising unions. Ho hum. - */ -typedef struct { - char * xpv_pv; /* pointer to malloced string */ - STRLEN xpv_cur; /* length of xp_pv as a C string */ - STRLEN xpv_len; /* allocated size */ - IV xof_off; /* integer value */ - double xnv_nv; /* numeric value, if any */ - MAGIC* xmg_magic; /* magic for scalar array */ - HV* xmg_stash; /* class package */ - - HV * xcv_stash; - OP * xcv_start; - OP * xcv_root; - void (*xcv_xsub) _((CV*)); - void * xcv_xsubany; - GV * xcv_gv; - GV * xcv_filegv; - long xcv_depth; /* >= 2 indicates recursive call */ - AV * xcv_padlist; - CV * xcv_outside; -#ifdef USE_THREADS - perl_mutex *xcv_mutexp; - struct perl_thread *xcv_owner; /* current owner thread */ -#endif /* USE_THREADS */ - U8 xcv_flags; -} XPVCV_or_similar; -#define ANYINIT(i) i -#else -#define XPVCV_or_similar XPVCV -#define ANYINIT(i) {i} -#endif /* BROKEN_UNION_INIT */ -#define Nullany ANYINIT(0) - -#define UNUSED 0 -#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" -#ifndef PATCHLEVEL -#include "patchlevel.h" -#endif - -/* Workaround for mapstart: the only op which needs a different ppaddr */ -#undef pp_mapstart -#define pp_mapstart pp_grepstart - -static void xs_init _((void)); -static PerlInterpreter *my_perl; -EOT -} - -sub output_main { - print <<'EOT'; -int -#ifndef CAN_PROTOTYPE -main(argc, argv, env) -int argc; -char **argv; -char **env; -#else /* def(CAN_PROTOTYPE) */ -main(int argc, char **argv, char **env) -#endif /* def(CAN_PROTOTYPE) */ -{ - int exitstatus; - int i; - char **fakeargv; - - PERL_SYS_INIT(&argc,&argv); - - perl_init_i18nl10n(1); - - if (!do_undump) { - my_perl = perl_alloc(); - if (!my_perl) - exit(1); - perl_construct( my_perl ); - } - -#ifdef CSH - if (!cshlen) - cshlen = strlen(cshname); -#endif - -#ifdef ALLOW_PERL_OPTIONS -#define EXTRA_OPTIONS 2 -#else -#define EXTRA_OPTIONS 3 -#endif /* ALLOW_PERL_OPTIONS */ - New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *); - fakeargv[0] = argv[0]; - fakeargv[1] = "-e"; - fakeargv[2] = ""; -#ifndef ALLOW_PERL_OPTIONS - fakeargv[3] = "--"; -#endif /* ALLOW_PERL_OPTIONS */ - for (i = 1; i < argc; i++) - fakeargv[i + EXTRA_OPTIONS] = argv[i]; - fakeargv[argc + EXTRA_OPTIONS] = 0; - - exitstatus = perl_parse(my_perl, xs_init, argc + EXTRA_OPTIONS, - fakeargv, NULL); - if (exitstatus) - exit( exitstatus ); - - sv_setpv(GvSV(gv_fetchpv("0", TRUE, SVt_PV)), argv[0]); - main_cv = compcv; - compcv = 0; - - exitstatus = perl_init(); - if (exitstatus) - exit( exitstatus ); - - exitstatus = perl_run( my_perl ); - - perl_destruct( my_perl ); - perl_free( my_perl ); - - exit( exitstatus ); -} - -static void -xs_init() -{ -} -EOT -} - -sub dump_symtable { - # For debugging - my ($sym, $val); - warn "----Symbol table:\n"; - while (($sym, $val) = each %symtable) { - warn "$sym => $val\n"; - } - warn "---End of symbol table\n"; -} - -sub save_object { - my $sv; - foreach $sv (@_) { - svref_2object($sv)->save; - } -} - -sub B::GV::savecv { - my $gv = shift; - my $cv = $gv->CV; - my $name = $gv->NAME; - if ($$cv && !objsym($cv) && !($name eq "bootstrap" && $cv->XSUB)) { - if ($debug_cv) { - warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n", - $gv->STASH->NAME, $name, $$cv, $$gv); - } - $gv->save; - } -} - -sub save_unused_subs { - my %search_pack; - map { $search_pack{$_} = 1 } @_; - no strict qw(vars refs); - walksymtable(\%{"main::"}, "savecv", sub { - my $package = shift; - $package =~ s/::$//; - #warn "Considering $package\n";#debug - return 1 if exists $search_pack{$package}; - #warn " (nothing explicit)\n";#debug - # 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") { - return 0; - } - my $m; - foreach $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH)) { - if (defined(&{$package."::$m"})) { - warn "$package has method $m: -u$package assumed\n";#debug - return 1; - } - } - return 0; - }); -} - -sub save_main { - my $curpad_sym = (comppadlist->ARRAY)[1]->save; - walkoptree(main_root, "save"); - warn "done main optree, walking symtable for extras\n" if $debug_cv; - save_unused_subs(@unused_sub_packages); - - $init->add(sprintf("main_root = s\\_%x;", ${main_root()}), - sprintf("main_start = s\\_%x;", ${main_start()}), - "curpad = AvARRAY($curpad_sym);"); - output_boilerplate(); - print "\n"; - output_all("perl_init"); - print "\n"; - output_main(); -} - -sub init_sections { - my @sections = (init => \$init, decl => \$decl, sym => \$symsect, - binop => \$binopsect, condop => \$condopsect, - cop => \$copsect, cvop => \$cvopsect, gvop => \$gvopsect, - 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::Section $name, \%symtable, 0; - } -} - -sub compile { - my @options = @_; - my ($option, $opt, $arg); - OPTION: - while ($option = shift @options) { - if ($option =~ /^-(.)(.*)/) { - $opt = $1; - $arg = $2; - } else { - unshift @options, $option; - last OPTION; - } - if ($opt eq "-" && $arg eq "-") { - shift @options; - last OPTION; - } - if ($opt eq "w") { - $warn_undefined_syms = 1; - } elsif ($opt eq "D") { - $arg ||= shift @options; - foreach $arg (split(//, $arg)) { - if ($arg eq "o") { - B->debug(1); - } elsif ($arg eq "c") { - $debug_cops = 1; - } elsif ($arg eq "A") { - $debug_av = 1; - } elsif ($arg eq "C") { - $debug_cv = 1; - } elsif ($arg eq "M") { - $debug_mg = 1; - } else { - warn "ignoring unknown debug option: $arg\n"; - } - } - } elsif ($opt eq "o") { - $arg ||= shift @options; - open(STDOUT, ">$arg") or return "$arg: $!\n"; - } elsif ($opt eq "v") { - $verbose = 1; - } elsif ($opt eq "u") { - $arg ||= shift @options; - push(@unused_sub_packages, $arg); - } elsif ($opt eq "f") { - $arg ||= shift @options; - if ($arg eq "cog") { - $pv_copy_on_grow = 1; - } elsif ($arg eq "no-cog") { - $pv_copy_on_grow = 0; - } - } elsif ($opt eq "O") { - $arg = 1 if $arg eq ""; - $pv_copy_on_grow = 0; - if ($arg >= 1) { - # Optimisations for -O1 - $pv_copy_on_grow = 1; - } - } - } - init_sections(); - if (@options) { - return sub { - my $objname; - foreach $objname (@options) { - eval "save_object(\\$objname)"; - } - output_all(); - } - } else { - return sub { save_main() }; - } -} - -1; diff --git a/lib/B/CC.pm b/lib/B/CC.pm deleted file mode 100644 index fc7cf6d..0000000 --- a/lib/B/CC.pm +++ /dev/null @@ -1,1528 +0,0 @@ -# CC.pm -# -# Copyright (c) 1996, 1997 Malcolm Beattie -# -# You may distribute under the terms of either the GNU General Public -# License or the Artistic License, as specified in the README file. -# -package B::CC; -use strict; -use B qw(main_start main_root class comppadlist peekop svref_2object - timing_info); -use B::C qw(save_unused_subs objsym init_sections - output_all output_boilerplate output_main); -use B::Bblock qw(find_leaders); -use B::Stackobj qw(:types :flags); - -# These should probably be elsewhere -# Flags for $op->flags -sub OPf_LIST () { 1 } -sub OPf_KNOW () { 2 } -sub OPf_MOD () { 32 } -sub OPf_STACKED () { 64 } -sub OPf_SPECIAL () { 128 } -# op-specific flags for $op->private -sub OPpASSIGN_BACKWARDS () { 64 } -sub OPpLVAL_INTRO () { 128 } -sub OPpDEREF_AV () { 32 } -sub OPpDEREF_HV () { 64 } -sub OPpDEREF () { OPpDEREF_AV|OPpDEREF_HV } -sub OPpFLIP_LINENUM () { 64 } -sub G_ARRAY () { 1 } -# cop.h -sub CXt_NULL () { 0 } -sub CXt_SUB () { 1 } -sub CXt_EVAL () { 2 } -sub CXt_LOOP () { 3 } -sub CXt_SUBST () { 4 } -sub CXt_BLOCK () { 5 } - -my $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 - -BEGIN { - foreach (qw(pp_scalar pp_regcmaybe pp_lineseq pp_scope pp_null)) { - $ignore_op{$_} = 1; - } -} - -my @unused_sub_packages; # list of packages (given by -u options) to search - # explicitly and save every sub we find there, even - # if apparently unused (could be only referenced from - # an eval "" or from a $SIG{FOO} = "bar"). - -my ($module_name); -my ($debug_op, $debug_stack, $debug_cxstack, $debug_pad, $debug_runtime, - $debug_shadow, $debug_queue, $debug_lineno, $debug_timings); - -# Optimisation options. On the command line, use hyphens instead of -# underscores for compatibility with gcc-style options. We use -# underscores here because they are OK in (strict) barewords. -my ($freetmps_each_bblock, $freetmps_each_loop, $omit_taint); -my %optimise = (freetmps_each_bblock => \$freetmps_each_bblock, - freetmps_each_loop => \$freetmps_each_loop, - omit_taint => \$omit_taint); -# 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); - -sub debug { - if ($debug_runtime) { - warn(@_); - } else { - runtime(map { chomp; "/* $_ */"} @_); - } -} - -sub declare { - my ($type, $var) = @_; - push(@{$declare_ref->{$type}}, $var); -} - -sub push_runtime { - push(@$runtime_list_ref, @_); - warn join("\n", @_) . "\n" if $debug_runtime; -} - -sub save_runtime { - push(@pp_list, [$ppname, $runtime_list_ref, $declare_ref]); -} - -sub output_runtime { - my $ppdata; - print qq(#include "cc_runtime.h"\n); - foreach $ppdata (@pp_list) { - my ($name, $runtime, $declare) = @$ppdata; - print "\nstatic\nPP($name)\n{\n"; - my ($type, $varlist, $line); - while (($type, $varlist) = each %$declare) { - print "\t$type ", join(", ", @$varlist), ";\n"; - } - foreach $line (@$runtime) { - print $line, "\n"; - } - print "}\n"; - } -} - -sub runtime { - my $line; - foreach $line (@_) { - push_runtime("\t$line"); - } -} - -sub init_pp { - $ppname = shift; - $runtime_list_ref = []; - $declare_ref = {}; - runtime("djSP;"); - declare("I32", "oldsave"); - declare("SV", "**svp"); - map { declare("SV", "*$_") } qw(sv src dst left right); - declare("MAGIC", "*mg"); - $decl->add("static OP * $ppname _((ARGSproto));"); - debug "init_pp: $ppname\n" if $debug_queue; -} - -# Initialise runtime_callback function for Stackobj class -BEGIN { B::Stackobj::set_callback(\&runtime) } - -# Initialise saveoptree_callback for B::C class -sub cc_queue { - my ($name, $root, $start, @pl) = @_; - debug "cc_queue: name $name, root $root, start $start, padlist (@pl)\n" - if $debug_queue; - if ($name eq "*ignore*") { - $name = 0; - } else { - push(@cc_todo, [$name, $root, $start, (@pl ? @pl : @padlist)]); - } - my $fakeop = new B::FAKEOP ("next" => 0, sibling => 0, ppaddr => $name); - $start = $fakeop->save; - debug "cc_queue: name $name returns $start\n" if $debug_queue; - return $start; -} -BEGIN { B::C::set_callback(\&cc_queue) } - -sub valid_int { $_[0]->{flags} & VALID_INT } -sub valid_double { $_[0]->{flags} & VALID_DOUBLE } -sub valid_numeric { $_[0]->{flags} & (VALID_INT | VALID_DOUBLE) } -sub valid_sv { $_[0]->{flags} & VALID_SV } - -sub top_int { @stack ? $stack[-1]->as_int : "TOPi" } -sub top_double { @stack ? $stack[-1]->as_double : "TOPn" } -sub top_numeric { @stack ? $stack[-1]->as_numeric : "TOPn" } -sub top_sv { @stack ? $stack[-1]->as_sv : "TOPs" } -sub top_bool { @stack ? $stack[-1]->as_numeric : "SvTRUE(TOPs)" } - -sub pop_int { @stack ? (pop @stack)->as_int : "POPi" } -sub pop_double { @stack ? (pop @stack)->as_double : "POPn" } -sub pop_numeric { @stack ? (pop @stack)->as_numeric : "POPn" } -sub pop_sv { @stack ? (pop @stack)->as_sv : "POPs" } -sub pop_bool { - if (@stack) { - return ((pop @stack)->as_numeric); - } else { - # Careful: POPs has an auto-decrement and SvTRUE evaluates - # its argument more than once. - runtime("sv = POPs;"); - return "SvTRUE(sv)"; - } -} - -sub write_back_lexicals { - my $avoid = shift || 0; - debug "write_back_lexicals($avoid) called from @{[(caller(1))[3]]}\n" - if $debug_shadow; - my $lex; - foreach $lex (@pad) { - next unless ref($lex); - $lex->write_back unless $lex->{flags} & $avoid; - } -} - -sub write_back_stack { - my $obj; - return unless @stack; - runtime(sprintf("EXTEND(sp, %d);", scalar(@stack))); - foreach $obj (@stack) { - runtime(sprintf("PUSHs((SV*)%s);", $obj->as_sv)); - } - @stack = (); -} - -sub invalidate_lexicals { - my $avoid = shift || 0; - debug "invalidate_lexicals($avoid) called from @{[(caller(1))[3]]}\n" - if $debug_shadow; - my $lex; - foreach $lex (@pad) { - next unless ref($lex); - $lex->invalidate unless $lex->{flags} & $avoid; - } -} - -sub reload_lexicals { - my $lex; - foreach $lex (@pad) { - next unless ref($lex); - my $type = $lex->{type}; - if ($type == T_INT) { - $lex->as_int; - } elsif ($type == T_DOUBLE) { - $lex->as_double; - } else { - $lex->as_sv; - } - } -} - -{ - package B::Pseudoreg; - # - # This class allocates pseudo-registers (OK, so they're C variables). - # - my %alloc; # Keyed by variable name. A value of 1 means the - # variable has been declared. A value of 2 means - # it's in use. - - sub new_scope { %alloc = () } - - sub new ($$$) { - my ($class, $type, $prefix) = @_; - my ($ptr, $i, $varname, $status, $obj); - $prefix =~ s/^(\**)//; - $ptr = $1; - $i = 0; - do { - $varname = "$prefix$i"; - $status = $alloc{$varname}; - } while $status == 2; - if ($status != 1) { - # Not declared yet - B::CC::declare($type, "$ptr$varname"); - $alloc{$varname} = 2; # declared and in use - } - $obj = bless \$varname, $class; - return $obj; - } - sub DESTROY { - my $obj = shift; - $alloc{$$obj} = 1; # no longer in use but still declared - } -} -{ - package B::Shadow; - # - # This class gives a standard API for a perl object to shadow a - # C variable and only generate reloads/write-backs when necessary. - # - # Use $obj->load($foo) instead of runtime("shadowed_c_var = foo"). - # Use $obj->write_back whenever shadowed_c_var needs to be up to date. - # Use $obj->invalidate whenever an unknown function may have - # set shadow itself. - - sub new { - my ($class, $write_back) = @_; - # Object fields are perl shadow variable, validity flag - # (for *C* variable) and callback sub for write_back - # (passed perl shadow variable as argument). - bless [undef, 1, $write_back], $class; - } - sub load { - my ($obj, $newval) = @_; - $obj->[1] = 0; # C variable no longer valid - $obj->[0] = $newval; - } - sub write_back { - my $obj = shift; - if (!($obj->[1])) { - $obj->[1] = 1; # C variable will now be valid - &{$obj->[2]}($obj->[0]); - } - } - sub invalidate { $_[0]->[1] = 0 } # force C variable to be invalid -} -my $curcop = new B::Shadow (sub { - my $opsym = shift->save; - runtime("curcop = (COP*)$opsym;"); -}); - -# -# Context stack shadowing. Mimics stuff in pp_ctl.c, cop.h and so on. -# -sub dopoptoloop { - my $cxix = $#cxstack; - while ($cxix >= 0 && $cxstack[$cxix]->{type} != CXt_LOOP) { - $cxix--; - } - debug "dopoptoloop: returning $cxix" if $debug_cxstack; - return $cxix; -} - -sub dopoptolabel { - my $label = shift; - my $cxix = $#cxstack; - while ($cxix >= 0 && $cxstack[$cxix]->{type} != CXt_LOOP - && $cxstack[$cxix]->{label} ne $label) { - $cxix--; - } - debug "dopoptolabel: returning $cxix" if $debug_cxstack; - return $cxix; -} - -sub error { - my $format = shift; - my $file = $curcop->[0]->filegv->SV->PV; - my $line = $curcop->[0]->line; - $errors++; - if (@_) { - warn sprintf("%s:%d: $format\n", $file, $line, @_); - } else { - warn sprintf("%s:%d: %s\n", $file, $line, $format); - } -} - -# -# Load pad takes (the elements of) a PADLIST as arguments and loads -# up @pad with Stackobj-derived objects which represent those lexicals. -# If/when perl itself can generate type information (my int $foo) then -# we'll take advantage of that here. Until then, we'll use various hacks -# to tell the compiler when we want a lexical to be a particular type -# or to be a register. -# -sub load_pad { - my ($namelistav, $valuelistav) = @_; - @padlist = @_; - my @namelist = $namelistav->ARRAY; - my @valuelist = $valuelistav->ARRAY; - my $ix; - @pad = (); - debug "load_pad: $#namelist names, $#valuelist values\n" if $debug_pad; - # Temporary lexicals don't get named so it's possible for @valuelist - # to be strictly longer than @namelist. We count $ix up to the end of - # @valuelist but index into @namelist for the name. Any temporaries which - # run off the end of @namelist will make $namesv undefined and we treat - # that the same as having an explicit SPECIAL sv_undef object in @namelist. - # [XXX If/when @_ becomes a lexical, we must start at 0 here.] - for ($ix = 1; $ix < @valuelist; $ix++) { - my $namesv = $namelist[$ix]; - my $type = T_UNKNOWN; - my $flags = 0; - my $name = "tmp$ix"; - my $class = class($namesv); - if (!defined($namesv) || $class eq "SPECIAL") { - # temporaries have &sv_undef instead of a PVNV for a name - $flags = VALID_SV|TEMPORARY|REGISTER; - } else { - if ($namesv->PV =~ /^\$(.*)_([di])(r?)$/) { - $name = $1; - if ($2 eq "i") { - $type = T_INT; - $flags = VALID_SV|VALID_INT; - } elsif ($2 eq "d") { - $type = T_DOUBLE; - $flags = VALID_SV|VALID_DOUBLE; - } - $flags |= REGISTER if $3; - } - } - $pad[$ix] = new B::Stackobj::Padsv ($type, $flags, $ix, - "i_$name", "d_$name"); - declare("IV", $type == T_INT ? "i_$name = 0" : "i_$name"); - declare("double", $type == T_DOUBLE ? "d_$name = 0" : "d_$name"); - debug sprintf("curpad[$ix] = %s\n", $pad[$ix]->peek) if $debug_pad; - } -} - -# -# Debugging stuff -# -sub peek_stack { sprintf "stack = %s\n", join(" ", map($_->minipeek, @stack)) } - -# -# OP stuff -# - -sub label { - my $op = shift; - # XXX Preserve original label name for "real" labels? - return sprintf("lab_%x", $$op); -} - -sub write_label { - my $op = shift; - push_runtime(sprintf(" %s:", label($op))); -} - -sub loadop { - my $op = shift; - my $opsym = $op->save; - runtime("op = $opsym;") unless $know_op; - return $opsym; -} - -sub doop { - my $op = shift; - my $ppname = $op->ppaddr; - my $sym = loadop($op); - runtime("DOOP($ppname);"); - $know_op = 1; - return $sym; -} - -sub gimme { - my $op = shift; - my $flags = $op->flags; - return (($flags & OPf_KNOW) ? ($flags & OPf_LIST) : "dowantarray()"); -} - -# -# Code generation for PP code -# - -sub pp_null { - my $op = shift; - return $op->next; -} - -sub pp_stub { - my $op = shift; - my $gimme = gimme($op); - if ($gimme != 1) { - # XXX Change to push a constant sv_undef Stackobj onto @stack - write_back_stack(); - runtime("if ($gimme != G_ARRAY) XPUSHs(&sv_undef);"); - } - return $op->next; -} - -sub pp_unstack { - my $op = shift; - @stack = (); - runtime("PP_UNSTACK;"); - return $op->next; -} - -sub pp_and { - my $op = shift; - my $next = $op->next; - reload_lexicals(); - unshift(@bblock_todo, $next); - if (@stack >= 1) { - my $bool = pop_bool(); - write_back_stack(); - runtime(sprintf("if (!$bool) goto %s;", label($next))); - } else { - runtime(sprintf("if (!%s) goto %s;", top_bool(), label($next)), - "*sp--;"); - } - return $op->other; -} - -sub pp_or { - my $op = shift; - my $next = $op->next; - reload_lexicals(); - unshift(@bblock_todo, $next); - if (@stack >= 1) { - my $obj = pop @stack; - write_back_stack(); - runtime(sprintf("if (%s) { XPUSHs(%s); goto %s; }", - $obj->as_numeric, $obj->as_sv, label($next))); - } else { - runtime(sprintf("if (%s) goto %s;", top_bool(), label($next)), - "*sp--;"); - } - return $op->other; -} - -sub pp_cond_expr { - my $op = shift; - my $false = $op->false; - unshift(@bblock_todo, $false); - reload_lexicals(); - my $bool = pop_bool(); - write_back_stack(); - runtime(sprintf("if (!$bool) goto %s;", label($false))); - return $op->true; -} - -sub pp_padsv { - my $op = shift; - my $ix = $op->targ; - push(@stack, $pad[$ix]); - if ($op->flags & OPf_MOD) { - my $private = $op->private; - if ($private & OPpLVAL_INTRO) { - runtime("SAVECLEARSV(curpad[$ix]);"); - } elsif ($private & OPpDEREF) { - runtime(sprintf("vivify_ref(curpad[%d], %d);", - $ix, $private & OPpDEREF)); - $pad[$ix]->invalidate; - } - } - return $op->next; -} - -sub pp_const { - my $op = shift; - my $sv = $op->sv; - my $obj = $constobj{$$sv}; - if (!defined($obj)) { - $obj = $constobj{$$sv} = new B::Stackobj::Const ($sv); - } - push(@stack, $obj); - return $op->next; -} - -sub pp_nextstate { - my $op = shift; - $curcop->load($op); - @stack = (); - debug(sprintf("%s:%d\n", $op->filegv->SV->PV, $op->line)) if $debug_lineno; - runtime("TAINT_NOT;") unless $omit_taint; - runtime("sp = stack_base + cxstack[cxstack_ix].blk_oldsp;"); - if ($freetmps_each_bblock || $freetmps_each_loop) { - $need_freetmps = 1; - } else { - runtime("FREETMPS;"); - } - return $op->next; -} - -sub pp_dbstate { - my $op = shift; - $curcop->invalidate; # XXX? - return default_pp($op); -} - -sub pp_rv2gv { $curcop->write_back; default_pp(@_) } -sub pp_bless { $curcop->write_back; default_pp(@_) } -sub pp_repeat { $curcop->write_back; default_pp(@_) } -# The following subs need $curcop->write_back if we decide to support arybase: -# pp_pos, pp_substr, pp_index, pp_rindex, pp_aslice, pp_lslice, pp_splice -sub pp_sort { $curcop->write_back; default_pp(@_) } -sub pp_caller { $curcop->write_back; default_pp(@_) } -sub pp_reset { $curcop->write_back; default_pp(@_) } - -sub pp_gv { - my $op = shift; - my $gvsym = $op->gv->save; - write_back_stack(); - runtime("XPUSHs((SV*)$gvsym);"); - return $op->next; -} - -sub pp_gvsv { - my $op = shift; - my $gvsym = $op->gv->save; - write_back_stack(); - if ($op->private & OPpLVAL_INTRO) { - runtime("XPUSHs(save_scalar($gvsym));"); - } else { - runtime("XPUSHs(GvSV($gvsym));"); - } - return $op->next; -} - -sub pp_aelemfast { - my $op = shift; - my $gvsym = $op->gv->save; - my $ix = $op->private; - my $flag = $op->flags & OPf_MOD; - write_back_stack(); - runtime("svp = av_fetch(GvAV($gvsym), $ix, $flag);", - "PUSHs(svp ? *svp : &sv_undef);"); - return $op->next; -} - -sub int_binop { - my ($op, $operator) = @_; - if ($op->flags & OPf_STACKED) { - my $right = pop_int(); - if (@stack >= 1) { - my $left = top_int(); - $stack[-1]->set_int(&$operator($left, $right)); - } else { - runtime(sprintf("sv_setiv(TOPs, %s);",&$operator("TOPi", $right))); - } - } else { - my $targ = $pad[$op->targ]; - my $right = new B::Pseudoreg ("IV", "riv"); - my $left = new B::Pseudoreg ("IV", "liv"); - runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int)); - $targ->set_int(&$operator($$left, $$right)); - push(@stack, $targ); - } - return $op->next; -} - -sub INTS_CLOSED () { 0x1 } -sub INT_RESULT () { 0x2 } -sub NUMERIC_RESULT () { 0x4 } - -sub numeric_binop { - my ($op, $operator, $flags) = @_; - my $force_int = 0; - $force_int ||= ($flags & INT_RESULT); - $force_int ||= ($flags & INTS_CLOSED && @stack >= 2 - && valid_int($stack[-2]) && valid_int($stack[-1])); - if ($op->flags & OPf_STACKED) { - my $right = pop_numeric(); - if (@stack >= 1) { - my $left = top_numeric(); - if ($force_int) { - $stack[-1]->set_int(&$operator($left, $right)); - } else { - $stack[-1]->set_numeric(&$operator($left, $right)); - } - } else { - if ($force_int) { - runtime(sprintf("sv_setiv(TOPs, %s);", - &$operator("TOPi", $right))); - } else { - runtime(sprintf("sv_setnv(TOPs, %s);", - &$operator("TOPn", $right))); - } - } - } else { - my $targ = $pad[$op->targ]; - $force_int ||= ($targ->{type} == T_INT); - if ($force_int) { - my $right = new B::Pseudoreg ("IV", "riv"); - my $left = new B::Pseudoreg ("IV", "liv"); - runtime(sprintf("$$right = %s; $$left = %s;", - pop_numeric(), pop_numeric)); - $targ->set_int(&$operator($$left, $$right)); - } else { - my $right = new B::Pseudoreg ("double", "rnv"); - my $left = new B::Pseudoreg ("double", "lnv"); - runtime(sprintf("$$right = %s; $$left = %s;", - pop_numeric(), pop_numeric)); - $targ->set_numeric(&$operator($$left, $$right)); - } - push(@stack, $targ); - } - return $op->next; -} - -sub sv_binop { - my ($op, $operator, $flags) = @_; - if ($op->flags & OPf_STACKED) { - my $right = pop_sv(); - if (@stack >= 1) { - my $left = top_sv(); - if ($flags & INT_RESULT) { - $stack[-1]->set_int(&$operator($left, $right)); - } elsif ($flags & NUMERIC_RESULT) { - $stack[-1]->set_numeric(&$operator($left, $right)); - } else { - # XXX Does this work? - runtime(sprintf("sv_setsv($left, %s);", - &$operator($left, $right))); - $stack[-1]->invalidate; - } - } else { - my $f; - if ($flags & INT_RESULT) { - $f = "sv_setiv"; - } elsif ($flags & NUMERIC_RESULT) { - $f = "sv_setnv"; - } else { - $f = "sv_setsv"; - } - runtime(sprintf("%s(TOPs, %s);", $f, &$operator("TOPs", $right))); - } - } else { - my $targ = $pad[$op->targ]; - runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv)); - if ($flags & INT_RESULT) { - $targ->set_int(&$operator("left", "right")); - } elsif ($flags & NUMERIC_RESULT) { - $targ->set_numeric(&$operator("left", "right")); - } else { - # XXX Does this work? - runtime(sprintf("sv_setsv(%s, %s);", - $targ->as_sv, &$operator("left", "right"))); - $targ->invalidate; - } - push(@stack, $targ); - } - return $op->next; -} - -sub bool_int_binop { - my ($op, $operator) = @_; - my $right = new B::Pseudoreg ("IV", "riv"); - my $left = new B::Pseudoreg ("IV", "liv"); - runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int())); - my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b")); - $bool->set_int(&$operator($$left, $$right)); - push(@stack, $bool); - return $op->next; -} - -sub bool_numeric_binop { - my ($op, $operator) = @_; - my $right = new B::Pseudoreg ("double", "rnv"); - my $left = new B::Pseudoreg ("double", "lnv"); - runtime(sprintf("$$right = %s; $$left = %s;", - pop_numeric(), pop_numeric())); - my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b")); - $bool->set_numeric(&$operator($$left, $$right)); - push(@stack, $bool); - return $op->next; -} - -sub bool_sv_binop { - my ($op, $operator) = @_; - runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv())); - my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b")); - $bool->set_numeric(&$operator("left", "right")); - push(@stack, $bool); - return $op->next; -} - -sub infix_op { - my $opname = shift; - return sub { "$_[0] $opname $_[1]" } -} - -sub prefix_op { - my $opname = shift; - return sub { sprintf("%s(%s)", $opname, join(", ", @_)) } -} - -BEGIN { - my $plus_op = infix_op("+"); - my $minus_op = infix_op("-"); - my $multiply_op = infix_op("*"); - my $divide_op = infix_op("/"); - my $modulo_op = infix_op("%"); - my $lshift_op = infix_op("<<"); - my $rshift_op = infix_op("<<"); - my $ncmp_op = sub { "($_[0] > $_[1] ? 1 : ($_[0] < $_[1]) ? -1 : 0)" }; - my $scmp_op = prefix_op("sv_cmp"); - my $seq_op = prefix_op("sv_eq"); - my $sne_op = prefix_op("!sv_eq"); - my $slt_op = sub { "sv_cmp($_[0], $_[1]) < 0" }; - my $sgt_op = sub { "sv_cmp($_[0], $_[1]) > 0" }; - my $sle_op = sub { "sv_cmp($_[0], $_[1]) <= 0" }; - my $sge_op = sub { "sv_cmp($_[0], $_[1]) >= 0" }; - my $eq_op = infix_op("=="); - my $ne_op = infix_op("!="); - my $lt_op = infix_op("<"); - my $gt_op = infix_op(">"); - my $le_op = infix_op("<="); - my $ge_op = infix_op(">="); - - # - # XXX The standard perl PP code has extra handling for - # some special case arguments of these operators. - # - sub pp_add { numeric_binop($_[0], $plus_op, INTS_CLOSED) } - sub pp_subtract { numeric_binop($_[0], $minus_op, INTS_CLOSED) } - sub pp_multiply { numeric_binop($_[0], $multiply_op, INTS_CLOSED) } - sub pp_divide { numeric_binop($_[0], $divide_op) } - sub pp_modulo { int_binop($_[0], $modulo_op) } # differs from perl's - sub pp_ncmp { numeric_binop($_[0], $ncmp_op, INT_RESULT) } - - sub pp_left_shift { int_binop($_[0], $lshift_op) } - sub pp_right_shift { int_binop($_[0], $rshift_op) } - sub pp_i_add { int_binop($_[0], $plus_op) } - sub pp_i_subtract { int_binop($_[0], $minus_op) } - sub pp_i_multiply { int_binop($_[0], $multiply_op) } - sub pp_i_divide { int_binop($_[0], $divide_op) } - sub pp_i_modulo { int_binop($_[0], $modulo_op) } - - sub pp_eq { bool_numeric_binop($_[0], $eq_op) } - sub pp_ne { bool_numeric_binop($_[0], $ne_op) } - sub pp_lt { bool_numeric_binop($_[0], $lt_op) } - sub pp_gt { bool_numeric_binop($_[0], $gt_op) } - sub pp_le { bool_numeric_binop($_[0], $le_op) } - sub pp_ge { bool_numeric_binop($_[0], $ge_op) } - - sub pp_i_eq { bool_int_binop($_[0], $eq_op) } - sub pp_i_ne { bool_int_binop($_[0], $ne_op) } - sub pp_i_lt { bool_int_binop($_[0], $lt_op) } - sub pp_i_gt { bool_int_binop($_[0], $gt_op) } - sub pp_i_le { bool_int_binop($_[0], $le_op) } - sub pp_i_ge { bool_int_binop($_[0], $ge_op) } - - sub pp_scmp { sv_binop($_[0], $scmp_op, INT_RESULT) } - sub pp_slt { bool_sv_binop($_[0], $slt_op) } - sub pp_sgt { bool_sv_binop($_[0], $sgt_op) } - sub pp_sle { bool_sv_binop($_[0], $sle_op) } - sub pp_sge { bool_sv_binop($_[0], $sge_op) } - sub pp_seq { bool_sv_binop($_[0], $seq_op) } - sub pp_sne { bool_sv_binop($_[0], $sne_op) } -} - - -sub pp_sassign { - my $op = shift; - my $backwards = $op->private & OPpASSIGN_BACKWARDS; - my ($dst, $src); - if (@stack >= 2) { - $dst = pop @stack; - $src = pop @stack; - ($src, $dst) = ($dst, $src) if $backwards; - my $type = $src->{type}; - if ($type == T_INT) { - $dst->set_int($src->as_int); - } elsif ($type == T_DOUBLE) { - $dst->set_numeric($src->as_numeric); - } else { - $dst->set_sv($src->as_sv); - } - push(@stack, $dst); - } elsif (@stack == 1) { - if ($backwards) { - my $src = pop @stack; - my $type = $src->{type}; - runtime("if (tainting && tainted) TAINT_NOT;"); - if ($type == T_INT) { - runtime sprintf("sv_setiv(TOPs, %s);", $src->as_int); - } elsif ($type == T_DOUBLE) { - runtime sprintf("sv_setnv(TOPs, %s);", $src->as_double); - } else { - runtime sprintf("sv_setsv(TOPs, %s);", $src->as_sv); - } - runtime("SvSETMAGIC(TOPs);"); - } else { - my $dst = pop @stack; - my $type = $dst->{type}; - runtime("sv = POPs;"); - runtime("MAYBE_TAINT_SASSIGN_SRC(sv);"); - if ($type == T_INT) { - $dst->set_int("SvIV(sv)"); - } elsif ($type == T_DOUBLE) { - $dst->set_double("SvNV(sv)"); - } else { - runtime("SvSetSV($dst->{sv}, sv);"); - $dst->invalidate; - } - } - } else { - if ($backwards) { - runtime("src = POPs; dst = TOPs;"); - } else { - runtime("dst = POPs; src = TOPs;"); - } - runtime("MAYBE_TAINT_SASSIGN_SRC(src);", - "SvSetSV(dst, src);", - "SvSETMAGIC(dst);", - "SETs(dst);"); - } - return $op->next; -} - -sub pp_preinc { - my $op = shift; - if (@stack >= 1) { - my $obj = $stack[-1]; - my $type = $obj->{type}; - if ($type == T_INT || $type == T_DOUBLE) { - $obj->set_int($obj->as_int . " + 1"); - } else { - runtime sprintf("PP_PREINC(%s);", $obj->as_sv); - $obj->invalidate(); - } - } else { - runtime sprintf("PP_PREINC(TOPs);"); - } - return $op->next; -} - -sub pp_pushmark { - my $op = shift; - write_back_stack(); - runtime("PUSHMARK(sp);"); - return $op->next; -} - -sub pp_list { - my $op = shift; - write_back_stack(); - my $gimme = gimme($op); - if ($gimme == 1) { # sic - runtime("POPMARK;"); # need this even though not a "full" pp_list - } else { - runtime("PP_LIST($gimme);"); - } - return $op->next; -} - -sub pp_entersub { - my $op = shift; - write_back_lexicals(REGISTER|TEMPORARY); - write_back_stack(); - my $sym = doop($op); - runtime("if (op != ($sym)->op_next) op = (*op->op_ppaddr)(ARGS);"); - runtime("SPAGAIN;"); - $know_op = 0; - invalidate_lexicals(REGISTER|TEMPORARY); - return $op->next; -} - -sub pp_enterwrite { - my $op = shift; - pp_entersub($op); -} - -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 (op) op = (*op->op_ppaddr)(ARGS);"); - runtime("SPAGAIN;"); - $know_op = 0; - invalidate_lexicals(REGISTER|TEMPORARY); - return $op->next; -} - -sub doeval { - my $op = shift; - $curcop->write_back; - write_back_lexicals(REGISTER|TEMPORARY); - write_back_stack(); - my $sym = loadop($op); - my $ppaddr = $op->ppaddr; - runtime("PP_EVAL($ppaddr, ($sym)->op_next);"); - $know_op = 1; - invalidate_lexicals(REGISTER|TEMPORARY); - return $op->next; -} - -sub pp_entereval { doeval(@_) } -sub pp_require { doeval(@_) } -sub pp_dofile { doeval(@_) } - -sub pp_entertry { - my $op = shift; - $curcop->write_back; - write_back_lexicals(REGISTER|TEMPORARY); - write_back_stack(); - my $sym = doop($op); - my $jmpbuf = sprintf("jmpbuf%d", $jmpbuf_ix++); - declare("Sigjmp_buf", $jmpbuf); - runtime(sprintf("PP_ENTERTRY(%s,%s);", $jmpbuf, label($op->other->next))); - invalidate_lexicals(REGISTER|TEMPORARY); - return $op->next; -} - -sub pp_grepstart { - my $op = shift; - if ($need_freetmps && $freetmps_each_loop) { - runtime("FREETMPS;"); # otherwise the grepwhile loop messes things up - $need_freetmps = 0; - } - write_back_stack(); - doop($op); - return $op->next->other; -} - -sub pp_mapstart { - my $op = shift; - if ($need_freetmps && $freetmps_each_loop) { - runtime("FREETMPS;"); # otherwise the mapwhile loop messes things up - $need_freetmps = 0; - } - write_back_stack(); - doop($op); - return $op->next->other; -} - -sub pp_grepwhile { - my $op = shift; - my $next = $op->next; - unshift(@bblock_todo, $next); - write_back_lexicals(); - write_back_stack(); - my $sym = doop($op); - # pp_grepwhile can return either op_next or op_other and we need to - # be able to distinguish the two at runtime. Since it's possible for - # both ops to be "inlined", the fields could both be zero. To get - # around that, we hack op_next to be our own op (purely because we - # know it's a non-NULL pointer and can't be the same as op_other). - $init->add("((LOGOP*)$sym)->op_next = $sym;"); - runtime(sprintf("if (op == ($sym)->op_next) goto %s;", label($next))); - $know_op = 0; - return $op->other; -} - -sub pp_mapwhile { - pp_grepwhile(@_); -} - -sub pp_return { - my $op = shift; - write_back_lexicals(REGISTER|TEMPORARY); - write_back_stack(); - doop($op); - runtime("PUTBACK;", "return 0;"); - $know_op = 0; - return $op->next; -} - -sub nyi { - my $op = shift; - warn sprintf("%s not yet implemented properly\n", $op->ppaddr); - return default_pp($op); -} - -sub pp_range { - my $op = shift; - my $flags = $op->flags; - if (!($flags & OPf_KNOW)) { - error("context of range unknown at compile-time"); - } - write_back_lexicals(); - write_back_stack(); - if (!($flags & OPf_LIST)) { - # We need to save our UNOP structure since pp_flop uses - # it to find and adjust out targ. We don't need it ourselves. - $op->save; - runtime sprintf("if (SvTRUE(curpad[%d])) goto %s;", - $op->targ, label($op->false)); - unshift(@bblock_todo, $op->false); - } - return $op->true; -} - -sub pp_flip { - my $op = shift; - my $flags = $op->flags; - if (!($flags & OPf_KNOW)) { - error("context of flip unknown at compile-time"); - } - if ($flags & OPf_LIST) { - return $op->first->false; - } - write_back_lexicals(); - write_back_stack(); - # We need to save our UNOP structure since pp_flop uses - # it to find and adjust out targ. We don't need it ourselves. - $op->save; - my $ix = $op->targ; - my $rangeix = $op->first->targ; - runtime(($op->private & OPpFLIP_LINENUM) ? - "if (last_in_gv && SvIV(TOPs) == IoLINES(GvIOp(last_in_gv))) {" - : "if (SvTRUE(TOPs)) {"); - runtime("\tsv_setiv(curpad[$rangeix], 1);"); - if ($op->flags & OPf_SPECIAL) { - runtime("sv_setiv(curpad[$ix], 1);"); - } else { - runtime("\tsv_setiv(curpad[$ix], 0);", - "\tsp--;", - sprintf("\tgoto %s;", label($op->first->false))); - } - runtime("}", - qq{sv_setpv(curpad[$ix], "");}, - "SETs(curpad[$ix]);"); - $know_op = 0; - return $op->next; -} - -sub pp_flop { - my $op = shift; - default_pp($op); - $know_op = 0; - return $op->next; -} - -sub enterloop { - my $op = shift; - my $nextop = $op->nextop; - my $lastop = $op->lastop; - my $redoop = $op->redoop; - $curcop->write_back; - debug "enterloop: pushing on cxstack" if $debug_cxstack; - push(@cxstack, { - type => CXt_LOOP, - op => $op, - "label" => $curcop->[0]->label, - nextop => $nextop, - lastop => $lastop, - redoop => $redoop - }); - $nextop->save; - $lastop->save; - $redoop->save; - return default_pp($op); -} - -sub pp_enterloop { enterloop(@_) } -sub pp_enteriter { enterloop(@_) } - -sub pp_leaveloop { - my $op = shift; - if (!@cxstack) { - die "panic: leaveloop"; - } - debug "leaveloop: popping from cxstack" if $debug_cxstack; - pop(@cxstack); - return default_pp($op); -} - -sub pp_next { - my $op = shift; - my $cxix; - if ($op->flags & OPf_SPECIAL) { - $cxix = dopoptoloop(); - if ($cxix < 0) { - error('"next" used outside loop'); - return $op->next; # ignore the op - } - } else { - $cxix = dopoptolabel($op->pv); - if ($cxix < 0) { - error('Label not found at compile time for "next %s"', $op->pv); - return $op->next; # ignore the op - } - } - default_pp($op); - my $nextop = $cxstack[$cxix]->{nextop}; - push(@bblock_todo, $nextop); - runtime(sprintf("goto %s;", label($nextop))); - return $op->next; -} - -sub pp_redo { - my $op = shift; - my $cxix; - if ($op->flags & OPf_SPECIAL) { - $cxix = dopoptoloop(); - if ($cxix < 0) { - error('"redo" used outside loop'); - return $op->next; # ignore the op - } - } else { - $cxix = dopoptolabel($op->pv); - if ($cxix < 0) { - error('Label not found at compile time for "redo %s"', $op->pv); - return $op->next; # ignore the op - } - } - default_pp($op); - my $redoop = $cxstack[$cxix]->{redoop}; - push(@bblock_todo, $redoop); - runtime(sprintf("goto %s;", label($redoop))); - return $op->next; -} - -sub pp_last { - my $op = shift; - my $cxix; - if ($op->flags & OPf_SPECIAL) { - $cxix = dopoptoloop(); - if ($cxix < 0) { - error('"last" used outside loop'); - return $op->next; # ignore the op - } - } else { - $cxix = dopoptolabel($op->pv); - if ($cxix < 0) { - error('Label not found at compile time for "last %s"', $op->pv); - return $op->next; # ignore the op - } - # XXX Add support for "last" to leave non-loop blocks - if ($cxstack[$cxix]->{type} != CXt_LOOP) { - error('Use of "last" for non-loop blocks is not yet implemented'); - return $op->next; # ignore the op - } - } - default_pp($op); - my $lastop = $cxstack[$cxix]->{lastop}->next; - push(@bblock_todo, $lastop); - runtime(sprintf("goto %s;", label($lastop))); - return $op->next; -} - -sub pp_subst { - my $op = shift; - write_back_lexicals(); - write_back_stack(); - my $sym = doop($op); - my $replroot = $op->pmreplroot; - if ($$replroot) { - runtime sprintf("if (op == ((PMOP*)(%s))->op_pmreplroot) goto %s;", - $sym, label($replroot)); - $op->pmreplstart->save; - push(@bblock_todo, $replroot); - } - invalidate_lexicals(); - return $op->next; -} - -sub pp_substcont { - my $op = shift; - write_back_lexicals(); - write_back_stack(); - doop($op); - my $pmop = $op->other; - 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 - runtime sprintf("if (op == ((PMOP*)(%s))->op_pmreplstart) goto %s;", - $pmopsym, label($pmop->pmreplstart)); - invalidate_lexicals(); - return $pmop->next; -} - -sub default_pp { - my $op = shift; - my $ppname = $op->ppaddr; - write_back_lexicals() unless $skip_lexicals{$ppname}; - write_back_stack() unless $skip_stack{$ppname}; - doop($op); - # XXX If the only way that ops can write to a TEMPORARY lexical is - # when it's named in $op->targ then we could call - # invalidate_lexicals(TEMPORARY) and avoid having to write back all - # the temporaries. For now, we'll play it safe and write back the lot. - invalidate_lexicals() unless $skip_invalidate{$ppname}; - return $op->next; -} - -sub compile_op { - my $op = shift; - my $ppname = $op->ppaddr; - if (exists $ignore_op{$ppname}) { - return $op->next; - } - debug peek_stack() if $debug_stack; - if ($debug_op) { - debug sprintf("%s [%s]\n", - peekop($op), - $op->flags & OPf_STACKED ? "OPf_STACKED" : $op->targ); - } - no strict 'refs'; - if (defined(&$ppname)) { - $know_op = 0; - return &$ppname($op); - } else { - return default_pp($op); - } -} - -sub compile_bblock { - my $op = shift; - #warn "compile_bblock: ", peekop($op), "\n"; # debug - write_label($op); - $know_op = 0; - do { - $op = compile_op($op); - } while (defined($op) && $$op && !exists($leaders->{$$op})); - write_back_stack(); # boo hoo: big loss - reload_lexicals(); - return $op; -} - -sub cc { - my ($name, $root, $start, @padlist) = @_; - my $op; - init_pp($name); - load_pad(@padlist); - B::Pseudoreg->new_scope; - @cxstack = (); - if ($debug_timings) { - warn sprintf("Basic block analysis at %s\n", timing_info); - } - $leaders = find_leaders($root, $start); - @bblock_todo = ($start, values %$leaders); - if ($debug_timings) { - warn sprintf("Compilation at %s\n", timing_info); - } - while (@bblock_todo) { - $op = shift @bblock_todo; - #warn sprintf("Considering basic block %s\n", peekop($op)); # debug - next if !defined($op) || !$$op || $done{$$op}; - #warn "...compiling it\n"; # debug - do { - $done{$$op} = 1; - $op = compile_bblock($op); - if ($need_freetmps && $freetmps_each_bblock) { - runtime("FREETMPS;"); - $need_freetmps = 0; - } - } while defined($op) && $$op && !$done{$$op}; - if ($need_freetmps && $freetmps_each_loop) { - runtime("FREETMPS;"); - $need_freetmps = 0; - } - if (!$$op) { - runtime("PUTBACK;", "return 0;"); - } elsif ($done{$$op}) { - runtime(sprintf("goto %s;", label($op))); - } - } - if ($debug_timings) { - warn sprintf("Saving runtime at %s\n", timing_info); - } - save_runtime(); -} - -sub cc_recurse { - my $ccinfo; - my $start; - $start = cc_queue(@_) if @_; - while ($ccinfo = shift @cc_todo) { - cc(@$ccinfo); - } - return $start; -} - -sub cc_obj { - my ($name, $cvref) = @_; - my $cv = svref_2object($cvref); - my @padlist = $cv->PADLIST->ARRAY; - my $curpad_sym = $padlist[1]->save; - cc_recurse($name, $cv->ROOT, $cv->START, @padlist); -} - -sub cc_main { - my @comppadlist = comppadlist->ARRAY; - my $curpad_sym = $comppadlist[1]->save; - my $start = cc_recurse("pp_main", main_root, main_start, @comppadlist); - save_unused_subs(@unused_sub_packages); - cc_recurse(); - - return if $errors; - if (!defined($module)) { - $init->add(sprintf("main_root = s\\_%x;", ${main_root()}), - "main_start = $start;", - "curpad = AvARRAY($curpad_sym);"); - } - 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; - SAVESPTR(curpad); - SAVESPTR(op); - curpad = AvARRAY($curpad_sym); - op = $start; - pp_main(ARGS); - FREETMPS; - LEAVE; - ST(0) = &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 "$arg: $!\n"; - } elsif ($opt eq "n") { - $arg ||= shift @options; - $module_name = $arg; - } elsif ($opt eq "u") { - $arg ||= shift @options; - push(@unused_sub_packages, $arg); - } elsif ($opt eq "f") { - $arg ||= shift @options; - my $value = $arg !~ s/^no-//; - $arg =~ s/-/_/g; - my $ref = $optimise{$arg}; - if (defined($ref)) { - $$ref = $value; - } else { - warn qq(ignoring unknown optimisation option "$arg"\n); - } - } elsif ($opt eq "O") { - $arg = 1 if $arg eq ""; - my $ref; - foreach $ref (values %optimise) { - $$ref = 0; - } - if ($arg >= 2) { - $freetmps_each_loop = 1; - } - if ($arg >= 1) { - $freetmps_each_bblock = 1 unless $freetmps_each_loop; - } - } elsif ($opt eq "m") { - $arg ||= shift @options; - $module = $arg; - push(@unused_sub_packages, $arg); - } 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; diff --git a/lib/B/Debug.pm b/lib/B/Debug.pm deleted file mode 100644 index d88cef3..0000000 --- a/lib/B/Debug.pm +++ /dev/null @@ -1,263 +0,0 @@ -package B::Debug; -use strict; -use B qw(peekop class walkoptree walkoptree_exec - main_start main_root cstring sv_undef); -use B::Asmdata qw(@specialsv_name); - -my %done_gv; - -sub B::OP::debug { - my ($op) = @_; - printf <<'EOT', class($op), $$op, ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ, $op->type, $op->seq, $op->flags, $op->private; -%s (0x%lx) - op_next 0x%x - op_sibling 0x%x - op_ppaddr %s - op_targ %d - op_type %d - op_seq %d - op_flags %d - op_private %d -EOT -} - -sub B::UNOP::debug { - my ($op) = @_; - $op->B::OP::debug(); - printf "\top_first\t0x%x\n", ${$op->first}; -} - -sub B::BINOP::debug { - my ($op) = @_; - $op->B::UNOP::debug(); - printf "\top_last\t\t0x%x\n", ${$op->last}; -} - -sub B::LOGOP::debug { - my ($op) = @_; - $op->B::UNOP::debug(); - printf "\top_other\t0x%x\n", ${$op->other}; -} - -sub B::CONDOP::debug { - my ($op) = @_; - $op->B::UNOP::debug(); - printf "\top_true\t0x%x\n", ${$op->true}; - printf "\top_false\t0x%x\n", ${$op->false}; -} - -sub B::LISTOP::debug { - my ($op) = @_; - $op->B::BINOP::debug(); - printf "\top_children\t%d\n", $op->children; -} - -sub B::PMOP::debug { - my ($op) = @_; - $op->B::LISTOP::debug(); - printf "\top_pmreplroot\t0x%x\n", ${$op->pmreplroot}; - printf "\top_pmreplstart\t0x%x\n", ${$op->pmreplstart}; - printf "\top_pmnext\t0x%x\n", ${$op->pmnext}; - printf "\top_pmregexp->precomp\t%s\n", cstring($op->precomp); - printf "\top_pmflags\t0x%x\n", $op->pmflags; - $op->pmshort->debug; - $op->pmreplroot->debug; -} - -sub B::COP::debug { - my ($op) = @_; - $op->B::OP::debug(); - my ($filegv) = $op->filegv; - printf <<'EOT', $op->label, ${$op->stash}, $$filegv, $op->seq, $op->arybase, $op->line; - cop_label %s - cop_stash 0x%x - cop_filegv 0x%x - cop_seq %d - cop_arybase %d - cop_line %d -EOT - $filegv->debug; -} - -sub B::SVOP::debug { - my ($op) = @_; - $op->B::OP::debug(); - printf "\top_sv\t\t0x%x\n", ${$op->sv}; - $op->sv->debug; -} - -sub B::PVOP::debug { - my ($op) = @_; - $op->B::OP::debug(); - printf "\top_pv\t\t0x%x\n", $op->pv; -} - -sub B::GVOP::debug { - my ($op) = @_; - $op->B::OP::debug(); - printf "\top_gv\t\t0x%x\n", ${$op->gv}; - $op->gv->debug; -} - -sub B::CVOP::debug { - my ($op) = @_; - $op->B::OP::debug(); - printf "\top_cv\t\t0x%x\n", ${$op->cv}; -} - -sub B::NULL::debug { - my ($sv) = @_; - if ($$sv == ${sv_undef()}) { - print "&sv_undef\n"; - } else { - printf "NULL (0x%x)\n", $$sv; - } -} - -sub B::SV::debug { - my ($sv) = @_; - if (!$$sv) { - print class($sv), " = NULL\n"; - return; - } - printf <<'EOT', class($sv), $$sv, $sv->REFCNT, $sv->FLAGS; -%s (0x%x) - REFCNT %d - FLAGS 0x%x -EOT -} - -sub B::PV::debug { - my ($sv) = @_; - $sv->B::SV::debug(); - my $pv = $sv->PV(); - printf <<'EOT', cstring($pv), length($pv); - xpv_pv %s - xpv_cur %d -EOT -} - -sub B::IV::debug { - my ($sv) = @_; - $sv->B::SV::debug(); - printf "\txiv_iv\t\t%d\n", $sv->IV; -} - -sub B::NV::debug { - my ($sv) = @_; - $sv->B::IV::debug(); - printf "\txnv_nv\t\t%s\n", $sv->NV; -} - -sub B::PVIV::debug { - my ($sv) = @_; - $sv->B::PV::debug(); - printf "\txiv_iv\t\t%d\n", $sv->IV; -} - -sub B::PVNV::debug { - my ($sv) = @_; - $sv->B::PVIV::debug(); - printf "\txnv_nv\t\t%s\n", $sv->NV; -} - -sub B::PVLV::debug { - my ($sv) = @_; - $sv->B::PVNV::debug(); - printf "\txlv_targoff\t%d\n", $sv->TARGOFF; - printf "\txlv_targlen\t%u\n", $sv->TARGLEN; - printf "\txlv_type\t%s\n", cstring(chr($sv->TYPE)); -} - -sub B::BM::debug { - my ($sv) = @_; - $sv->B::PVNV::debug(); - printf "\txbm_useful\t%d\n", $sv->USEFUL; - printf "\txbm_previous\t%u\n", $sv->PREVIOUS; - printf "\txbm_rare\t%s\n", cstring(chr($sv->RARE)); -} - -sub B::CV::debug { - my ($sv) = @_; - $sv->B::PVNV::debug(); - my ($stash) = $sv->STASH; - my ($start) = $sv->START; - my ($root) = $sv->ROOT; - my ($padlist) = $sv->PADLIST; - my ($gv) = $sv->GV; - my ($filegv) = $sv->FILEGV; - printf <<'EOT', $$stash, $$start, $$root, $$gv, $$filegv, $sv->DEPTH, $padlist, ${$sv->OUTSIDE}; - STASH 0x%x - START 0x%x - ROOT 0x%x - GV 0x%x - FILEGV 0x%x - DEPTH %d - PADLIST 0x%x - OUTSIDE 0x%x -EOT - $start->debug if $start; - $root->debug if $root; - $gv->debug if $gv; - $filegv->debug if $filegv; - $padlist->debug if $padlist; -} - -sub B::AV::debug { - my ($av) = @_; - $av->B::SV::debug; - my(@array) = $av->ARRAY; - print "\tARRAY\t\t(", join(", ", map("0x" . $$_, @array)), ")\n"; - printf <<'EOT', scalar(@array), $av->MAX, $av->OFF, $av->AvFLAGS; - FILL %d - MAX %d - OFF %d - AvFLAGS %d -EOT -} - -sub B::GV::debug { - my ($gv) = @_; - if ($done_gv{$$gv}++) { - printf "GV %s::%s\n", $gv->STASH->NAME, $gv->NAME; - return; - } - my ($sv) = $gv->SV; - my ($av) = $gv->AV; - my ($cv) = $gv->CV; - $gv->B::SV::debug; - printf <<'EOT', $gv->NAME, $gv->STASH->NAME, $gv->STASH, $$sv, $gv->GvREFCNT, $gv->FORM, $$av, ${$gv->HV}, ${$gv->EGV}, $$cv, $gv->CVGEN, $gv->LINE, $gv->FILEGV, $gv->GvFLAGS; - NAME %s - STASH %s (0x%x) - SV 0x%x - GvREFCNT %d - FORM 0x%x - AV 0x%x - HV 0x%x - EGV 0x%x - CV 0x%x - CVGEN %d - LINE %d - FILEGV 0x%x - GvFLAGS 0x%x -EOT - $sv->debug if $sv; - $av->debug if $av; - $cv->debug if $cv; -} - -sub B::SPECIAL::debug { - my $sv = shift; - print $specialsv_name[$$sv], "\n"; -} - -sub compile { - my $order = shift; - if ($order eq "exec") { - return sub { walkoptree_exec(main_start, "debug") } - } else { - return sub { walkoptree(main_root, "debug") } - } -} - -1; diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm deleted file mode 100644 index 9802cb4..0000000 --- a/lib/B/Deparse.pm +++ /dev/null @@ -1,102 +0,0 @@ -package B::Deparse; -use strict; -use B qw(peekop class main_root); - -my $debug; - -sub compile { - my $opt = shift; - if ($opt eq "-d") { - $debug = 1; - } - return sub { print deparse(main_root), "\n" } -} - -sub ppname { - my $op = shift; - my $ppname = $op->ppaddr; - warn sprintf("ppname %s\n", peekop($op)) if $debug; - no strict "refs"; - return defined(&$ppname) ? &$ppname($op) : 0; -} - -sub deparse { - my $op = shift; - my $expr; - warn sprintf("deparse %s\n", peekop($op)) if $debug; - while (ref($expr = ppname($op))) { - $op = $expr; - warn sprintf("Redirecting to %s\n", peekop($op)) if $debug; - } - return $expr; -} - -sub pp_leave { - my $op = shift; - my ($child, $expr); - for ($child = $op->first; !$expr; $child = $child->sibling) { - $expr = ppname($child); - } - return $expr; -} - -sub SWAP_CHILDREN () { 1 } - -sub binop { - my ($op, $opname, $flags) = @_; - my $left = $op->first; - my $right = $op->last; - if ($flags & SWAP_CHILDREN) { - ($left, $right) = ($right, $left); - } - warn sprintf("binop deparsing first %s\n", peekop($op->first)) if $debug; - $left = deparse($left); - warn sprintf("binop deparsing last %s\n", peekop($op->last)) if $debug; - $right = deparse($right); - return "($left $opname $right)"; -} - -sub pp_add { binop($_[0], "+") } -sub pp_multiply { binop($_[0], "*") } -sub pp_subtract { binop($_[0], "-") } -sub pp_divide { binop($_[0], "/") } -sub pp_modulo { binop($_[0], "%") } -sub pp_eq { binop($_[0], "==") } -sub pp_ne { binop($_[0], "!=") } -sub pp_lt { binop($_[0], "<") } -sub pp_gt { binop($_[0], ">") } -sub pp_ge { binop($_[0], ">=") } - -sub pp_sassign { binop($_[0], "=", SWAP_CHILDREN) } - -sub pp_null { - my $op = shift; - warn sprintf("Skipping null op %s\n", peekop($op)) if $debug; - return $op->first; -} - -sub pp_const { - my $op = shift; - my $sv = $op->sv; - if (class($sv) eq "IV") { - return $sv->IV; - } elsif (class($sv) eq "NV") { - return $sv->NV; - } else { - return $sv->PV; - } -} - -sub pp_gvsv { - my $op = shift; - my $gv = $op->gv; - my $stash = $gv->STASH->NAME; - if ($stash eq "main") { - $stash = ""; - } else { - $stash = $stash . "::"; - } - return sprintf('$%s%s', $stash, $gv->NAME); -} - -1; diff --git a/lib/B/Disassembler.pm b/lib/B/Disassembler.pm deleted file mode 100644 index 36db354..0000000 --- a/lib/B/Disassembler.pm +++ /dev/null @@ -1,144 +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. -package B::Disassembler::BytecodeStream; -use FileHandle; -use Carp; -use B qw(cstring cast_I32); -@ISA = qw(FileHandle); -sub readn { - my ($fh, $len) = @_; - my $data; - read($fh, $data, $len); - croak "reached EOF while reading $len bytes" unless length($data) == $len; - return $data; -} - -sub GET_U8 { - my $fh = shift; - my $c = $fh->getc; - croak "reached EOF while reading U8" unless defined($c); - return ord($c); -} - -sub GET_U16 { - my $fh = shift; - my $str = $fh->readn(2); - croak "reached EOF while reading U16" unless length($str) == 2; - return unpack("n", $str); -} - -sub GET_U32 { - my $fh = shift; - my $str = $fh->readn(4); - croak "reached EOF while reading U32" unless length($str) == 4; - return unpack("N", $str); -} - -sub GET_I32 { - my $fh = shift; - my $str = $fh->readn(4); - croak "reached EOF while reading I32" unless length($str) == 4; - return cast_I32(unpack("N", $str)); -} - -sub GET_objindex { - my $fh = shift; - my $str = $fh->readn(4); - croak "reached EOF while reading objindex" unless length($str) == 4; - return unpack("N", $str); -} - -sub GET_strconst { - my $fh = shift; - my ($str, $c); - while (defined($c = $fh->getc) && $c ne "\0") { - $str .= $c; - } - croak "reached EOF while reading strconst" unless defined($c); - return cstring($str); -} - -sub GET_pvcontents {} - -sub GET_PV { - my $fh = shift; - my $str; - my $len = $fh->GET_U32; - if ($len) { - read($fh, $str, $len); - croak "reached EOF while reading PV" unless length($str) == $len; - return cstring($str); - } else { - return '""'; - } -} - -sub GET_comment { - my $fh = shift; - my ($str, $c); - while (defined($c = $fh->getc) && $c ne "\n") { - $str .= $c; - } - croak "reached EOF while reading comment" unless defined($c); - return cstring($str); -} - -sub GET_double { - my $fh = shift; - my ($str, $c); - while (defined($c = $fh->getc) && $c ne "\0") { - $str .= $c; - } - croak "reached EOF while reading double" unless defined($c); - return $str; -} - -sub GET_none {} - -sub GET_op_tr_array { - my $fh = shift; - my @ary = unpack("n256", $fh->readn(256 * 2)); - return join(",", @ary); -} - -sub GET_IV64 { - my $fh = shift; - my ($hi, $lo) = unpack("NN", $fh->readn(8)); - return sprintf("0x%4x%04x", $hi, $lo); # cheat -} - -package B::Disassembler; -use Exporter; -@ISA = qw(Exporter); -@EXPORT_OK = qw(disassemble_fh); -use Carp; -use strict; - -use B::Asmdata qw(%insn_data @insn_name); - -sub disassemble_fh { - my ($fh, $out) = @_; - my ($c, $getmeth, $insn, $arg); - bless $fh, "B::Disassembler::BytecodeStream"; - while (defined($c = $fh->getc)) { - $c = ord($c); - $insn = $insn_name[$c]; - if (!defined($insn) || $insn eq "unused") { - my $pos = $fh->tell - 1; - die "Illegal instruction code $c at stream offset $pos\n"; - } - $getmeth = $insn_data{$insn}->[2]; - $arg = $fh->$getmeth(); - if (defined($arg)) { - &$out($insn, $arg); - } else { - &$out($insn); - } - } -} - -1; diff --git a/lib/B/Lint.pm b/lib/B/Lint.pm deleted file mode 100644 index d34bd77..0000000 --- a/lib/B/Lint.pm +++ /dev/null @@ -1,367 +0,0 @@ -package B::Lint; - -=head1 NAME - -B::Lint - Perl lint - -=head1 SYNOPSIS - -perl -MO=Lint[,OPTIONS] foo.pl - -=head1 DESCRIPTION - -The B::Lint module is equivalent to an extended version of the B<-w> -option of B. It is named after the program B which carries -out a similar process for C programs. - -=head1 OPTIONS AND LINT CHECKS - -Option words are separated by commas (not whitespace) and follow the -usual conventions of compiler backend options. Following any options -(indicated by a leading B<->) come lint check arguments. Each such -argument (apart from the special B and B options) is a -word representing one possible lint check (turning on that check) or -is B (turning off that check). Before processing the check -arguments, a standard list of checks is turned on. Later options -override earlier ones. Available options are: - -=over 8 - -=item B - -Produces a warning whenever an array is used in an implicit scalar -context. For example, both of the lines - - $foo = length(@bar); - $foo = @bar; -will elicit a warning. Using an explicit B silences the -warning. For example, - - $foo = scalar(@bar); - -=item B and B - -These options produce a warning whenever an operation implicitly -reads or (respectively) writes to one of Perl's special variables. -For example, B will warn about these: - - /foo/; - -and B will warn about these: - - s/foo/bar/; - -Both B and B warn about this: - - for (@a) { ... } - -=item B - -This option warns whenever $_ is used either explicitly anywhere or -as the implicit argument of a B statement. - -=item B - -This option warns on each use of any variable, subroutine or -method name that lives in a non-current package but begins with -an underscore ("_"). Warnings aren't issued for the special case -of the single character name "_" by itself (e.g. $_ and @_). - -=item B - -This option warns whenever an undefined subroutine is invoked. -This option will only catch explicitly invoked subroutines such -as C and not indirect invocations such as C<&$subref()> -or C<$obj-Emeth()>. Note that some programs or modules delay -definition of subs until runtime by means of the AUTOLOAD -mechanism. - -=item B - -This option warns whenever one of the regexp variables $', $& or -$' is used. Any occurrence of any of these variables in your -program can slow your whole program down. See L for -details. - -=item B - -Turn all warnings on. - -=item B - -Turn all warnings off. - -=back - -=head1 NON LINT-CHECK OPTIONS - -=over 8 - -=item B<-u Package> - -Normally, Lint only checks the main code of the program together -with all subs defined in package main. The B<-u> option lets you -include other package names whose subs are then checked by Lint. - -=back - -=head1 BUGS - -This is only a very preliminary version. - -=head1 AUTHOR - -Malcolm Beattie, mbeattie@sable.ox.ac.uk. - -=cut - -use strict; -use B qw(walkoptree_slow main_root walksymtable svref_2object parents); - -# Constants (should probably be elsewhere) -sub G_ARRAY () { 1 } -sub OPf_LIST () { 1 } -sub OPf_KNOW () { 2 } -sub OPf_STACKED () { 64 } - -my $file = "unknown"; # shadows current filename -my $line = 0; # shadows current line number -my $curstash = "main"; # shadows current stash - -# Lint checks -my %check; -my %implies_ok_context; -BEGIN { - map($implies_ok_context{$_}++, - qw(pp_scalar pp_av2arylen pp_aelem pp_aslice pp_helem pp_hslice - pp_keys pp_values pp_hslice pp_defined pp_undef pp_delete)); -} - -# Lint checks turned on by default -my @default_checks = qw(context); - -my %valid_check; -# All valid checks -BEGIN { - map($valid_check{$_}++, - qw(context implicit_read implicit_write dollar_underscore - private_names undefined_subs regexp_variables)); -} - -# Debugging options -my ($debug_op); - -my %done_cv; # used to mark which subs have already been linted -my @extra_packages; # Lint checks mainline code and all subs which are - # in main:: or in one of these packages. - -sub warning { - my $format = (@_ < 2) ? "%s" : shift; - warn sprintf("$format at %s line %d\n", @_, $file, $line); -} - -# This gimme can't cope with context that's only determined -# at runtime via dowantarray(). -sub gimme { - my $op = shift; - my $flags = $op->flags; - if ($flags & OPf_KNOW) { - return(($flags & OPf_LIST) ? 1 : 0); - } - return undef; -} - -sub B::OP::lint {} - -sub B::COP::lint { - my $op = shift; - if ($op->ppaddr eq "pp_nextstate") { - $file = $op->filegv->SV->PV; - $line = $op->line; - $curstash = $op->stash->NAME; - } -} - -sub B::UNOP::lint { - my $op = shift; - my $ppaddr = $op->ppaddr; - if ($check{context} && ($ppaddr eq "pp_rv2av" || $ppaddr eq "pp_rv2hv")) { - my $parent = parents->[0]; - my $pname = $parent->ppaddr; - return if gimme($op) || $implies_ok_context{$pname}; - # Two special cases to deal with: "foreach (@foo)" and "delete $a{$b}" - # null out the parent so we have to check for a parent of pp_null and - # a grandparent of pp_enteriter or pp_delete - if ($pname eq "pp_null") { - my $gpname = parents->[1]->ppaddr; - return if $gpname eq "pp_enteriter" || $gpname eq "pp_delete"; - } - warning("Implicit scalar context for %s in %s", - $ppaddr eq "pp_rv2av" ? "array" : "hash", $parent->desc); - } - if ($check{private_names} && $ppaddr eq "pp_method") { - my $methop = $op->first; - if ($methop->ppaddr eq "pp_const") { - my $method = $methop->sv->PV; - if ($method =~ /^_/ && !defined(&{"$curstash\::$method"})) { - warning("Illegal reference to private method name $method"); - } - } - } -} - -sub B::PMOP::lint { - my $op = shift; - if ($check{implicit_read}) { - my $ppaddr = $op->ppaddr; - if ($ppaddr eq "pp_match" && !($op->flags & OPf_STACKED)) { - warning('Implicit match on $_'); - } - } - if ($check{implicit_write}) { - my $ppaddr = $op->ppaddr; - if ($ppaddr eq "pp_subst" && !($op->flags & OPf_STACKED)) { - warning('Implicit substitution on $_'); - } - } -} - -sub B::LOOP::lint { - my $op = shift; - if ($check{implicit_read} || $check{implicit_write}) { - my $ppaddr = $op->ppaddr; - if ($ppaddr eq "pp_enteriter") { - my $last = $op->last; - if ($last->ppaddr eq "pp_gv" && $last->gv->NAME eq "_") { - warning('Implicit use of $_ in foreach'); - } - } - } -} - -sub B::GVOP::lint { - my $op = shift; - if ($check{dollar_underscore} && $op->ppaddr eq "pp_gvsv" - && $op->gv->NAME eq "_") - { - warning('Use of $_'); - } - if ($check{private_names}) { - my $ppaddr = $op->ppaddr; - my $gv = $op->gv; - if (($ppaddr eq "pp_gv" || $ppaddr eq "pp_gvsv") - && $gv->NAME =~ /^_./ && $gv->STASH->NAME ne $curstash) - { - warning('Illegal reference to private name %s', $gv->NAME); - } - } - if ($check{undefined_subs}) { - if ($op->ppaddr eq "pp_gv" && $op->next->ppaddr eq "pp_entersub") { - my $gv = $op->gv; - my $subname = $gv->STASH->NAME . "::" . $gv->NAME; - no strict 'refs'; - if (!defined(&$subname)) { - $subname =~ s/^main:://; - warning('Undefined subroutine %s called', $subname); - } - } - } - if ($check{regexp_variables} && $op->ppaddr eq "pp_gvsv") { - my $name = $op->gv->NAME; - if ($name =~ /^[&'`]$/) { - warning('Use of regexp variable $%s', $name); - } - } -} - -sub B::GV::lintcv { - my $gv = shift; - my $cv = $gv->CV; - #warn sprintf("lintcv: %s::%s (done=%d)\n", - # $gv->STASH->NAME, $gv->NAME, $done_cv{$$cv});#debug - return if !$$cv || $done_cv{$$cv}++; - my $root = $cv->ROOT; - #warn " root = $root (0x$$root)\n";#debug - walkoptree_slow($root, "lint") if $$root; -} - -sub do_lint { - my %search_pack; - walkoptree_slow(main_root, "lint") if ${main_root()}; - - # Now do subs in main - no strict qw(vars refs); - my $sym; - local(*glob); - while (($sym, *glob) = each %{"main::"}) { - #warn "Trying $sym\n";#debug - svref_2object(\*glob)->EGV->lintcv unless $sym =~ /::$/; - } - - # Now do subs in non-main packages given by -u options - map { $search_pack{$_} = 1 } @extra_packages; - walksymtable(\%{"main::"}, "lintcv", sub { - my $package = shift; - $package =~ s/::$//; - #warn "Considering $package\n";#debug - return exists $search_pack{$package}; - }); -} - -sub compile { - my @options = @_; - my ($option, $opt, $arg); - # Turn on default lint checks - for $opt (@default_checks) { - $check{$opt} = 1; - } - 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 "D") { - $arg ||= shift @options; - foreach $arg (split(//, $arg)) { - if ($arg eq "o") { - B->debug(1); - } elsif ($arg eq "O") { - $debug_op = 1; - } - } - } elsif ($opt eq "u") { - $arg ||= shift @options; - push(@extra_packages, $arg); - } - } - foreach $opt (@default_checks, @options) { - $opt =~ tr/-/_/; - if ($opt eq "all") { - %check = %valid_check; - } - elsif ($opt eq "none") { - %check = (); - } - else { - if ($opt =~ s/^no-//) { - $check{$opt} = 0; - } - else { - $check{$opt} = 1; - } - warn "No such check: $opt\n" unless defined $valid_check{$opt}; - } - } - # Remaining arguments are things to check - - return \&do_lint; -} - -1; diff --git a/lib/B/Showlex.pm b/lib/B/Showlex.pm deleted file mode 100644 index 9cf8ecc..0000000 --- a/lib/B/Showlex.pm +++ /dev/null @@ -1,58 +0,0 @@ -package B::Showlex; -use strict; -use B qw(svref_2object comppadlist class); -use B::Terse (); - -# -# Invoke as -# perl -MO=Showlex,foo bar.pl -# to see the names of lexical variables used by &foo -# or as -# perl -MO=Showlex bar.pl -# to see the names of file scope lexicals used by bar.pl -# - -sub showarray { - my ($name, $av) = @_; - my @els = $av->ARRAY; - my $count = @els; - my $i; - print "$name has $count entries\n"; - for ($i = 0; $i < $count; $i++) { - print "$i: "; - $els[$i]->terse; - } -} - -sub showlex { - my ($objname, $namesav, $valsav) = @_; - showarray("Pad of lexical names for $objname", $namesav); - showarray("Pad of lexical values for $objname", $valsav); -} - -sub showlex_obj { - my ($objname, $obj) = @_; - $objname =~ s/^&main::/&/; - showlex($objname, svref_2object($obj)->PADLIST->ARRAY); -} - -sub showlex_main { - showlex("comppadlist", comppadlist->ARRAY); -} - -sub compile { - my @options = @_; - if (@options) { - return sub { - my $objname; - foreach $objname (@options) { - $objname = "main::$objname" unless $objname =~ /::/; - eval "showlex_obj('&$objname', \\&$objname)"; - } - } - } else { - return \&showlex_main; - } -} - -1; diff --git a/lib/B/Stackobj.pm b/lib/B/Stackobj.pm deleted file mode 100644 index 8be047f..0000000 --- a/lib/B/Stackobj.pm +++ /dev/null @@ -1,281 +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; -use Exporter (); -@ISA = qw(Exporter); -@EXPORT_OK = qw(set_callback T_UNKNOWN T_DOUBLE T_INT - VALID_INT VALID_DOUBLE VALID_SV REGISTER TEMPORARY); -%EXPORT_TAGS = (types => [qw(T_UNKNOWN T_DOUBLE T_INT)], - flags => [qw(VALID_INT VALID_DOUBLE VALID_SV - REGISTER TEMPORARY)]); - -use Carp qw(confess); -use strict; -use B qw(class); - -# Perl internal constants that I should probably define elsewhere. -sub SVf_IOK () { 0x10000 } -sub SVf_NOK () { 0x20000 } - -# Types -sub T_UNKNOWN () { 0 } -sub T_DOUBLE () { 1 } -sub T_INT () { 2 } - -# Flags -sub VALID_INT () { 0x01 } -sub VALID_DOUBLE () { 0x02 } -sub VALID_SV () { 0x04 } -sub REGISTER () { 0x08 } # no implicit write-back when calling subs -sub TEMPORARY () { 0x10 } # no implicit write-back needed at all - -# -# Callback for runtime code generation -# -my $runtime_callback = sub { confess "set_callback not yet called" }; -sub set_callback (&) { $runtime_callback = shift } -sub runtime { &$runtime_callback(@_) } - -# -# Methods -# - -sub write_back { confess "stack object does not implement write_back" } - -sub invalidate { shift->{flags} &= ~(VALID_INT | VALID_DOUBLE) } - -sub as_sv { - my $obj = shift; - if (!($obj->{flags} & VALID_SV)) { - $obj->write_back; - $obj->{flags} |= VALID_SV; - } - return $obj->{sv}; -} - -sub as_int { - my $obj = shift; - if (!($obj->{flags} & VALID_INT)) { - $obj->load_int; - $obj->{flags} |= VALID_INT; - } - return $obj->{iv}; -} - -sub as_double { - my $obj = shift; - if (!($obj->{flags} & VALID_DOUBLE)) { - $obj->load_double; - $obj->{flags} |= VALID_DOUBLE; - } - return $obj->{nv}; -} - -sub as_numeric { - my $obj = shift; - return $obj->{type} == T_INT ? $obj->as_int : $obj->as_double; -} - -# -# Debugging methods -# -sub peek { - my $obj = shift; - my $type = $obj->{type}; - my $flags = $obj->{flags}; - my @flags; - if ($type == T_UNKNOWN) { - $type = "T_UNKNOWN"; - } elsif ($type == T_INT) { - $type = "T_INT"; - } elsif ($type == T_DOUBLE) { - $type = "T_DOUBLE"; - } else { - $type = "(illegal type $type)"; - } - push(@flags, "VALID_INT") if $flags & VALID_INT; - push(@flags, "VALID_DOUBLE") if $flags & VALID_DOUBLE; - push(@flags, "VALID_SV") if $flags & VALID_SV; - push(@flags, "REGISTER") if $flags & REGISTER; - push(@flags, "TEMPORARY") if $flags & TEMPORARY; - @flags = ("none") unless @flags; - return sprintf("%s type=$type flags=%s sv=$obj->{sv}", - class($obj), join("|", @flags)); -} - -sub minipeek { - my $obj = shift; - my $type = $obj->{type}; - my $flags = $obj->{flags}; - if ($type == T_INT || $flags & VALID_INT) { - return $obj->{iv}; - } elsif ($type == T_DOUBLE || $flags & VALID_DOUBLE) { - return $obj->{nv}; - } else { - return $obj->{sv}; - } -} - -# -# Caller needs to ensure that set_int, set_double, -# set_numeric and set_sv are only invoked on legal lvalues. -# -sub set_int { - my ($obj, $expr) = @_; - runtime("$obj->{iv} = $expr;"); - $obj->{flags} &= ~(VALID_SV | VALID_DOUBLE); - $obj->{flags} |= VALID_INT; -} - -sub set_double { - my ($obj, $expr) = @_; - runtime("$obj->{nv} = $expr;"); - $obj->{flags} &= ~(VALID_SV | VALID_INT); - $obj->{flags} |= VALID_DOUBLE; -} - -sub set_numeric { - my ($obj, $expr) = @_; - if ($obj->{type} == T_INT) { - $obj->set_int($expr); - } else { - $obj->set_double($expr); - } -} - -sub set_sv { - my ($obj, $expr) = @_; - runtime("SvSetSV($obj->{sv}, $expr);"); - $obj->invalidate; - $obj->{flags} |= VALID_SV; -} - -# -# Stackobj::Padsv -# - -@B::Stackobj::Padsv::ISA = 'B::Stackobj'; -sub B::Stackobj::Padsv::new { - my ($class, $type, $extra_flags, $ix, $iname, $dname) = @_; - bless { - type => $type, - flags => VALID_SV | $extra_flags, - sv => "curpad[$ix]", - iv => "$iname", - nv => "$dname" - }, $class; -} - -sub B::Stackobj::Padsv::load_int { - my $obj = shift; - if ($obj->{flags} & VALID_DOUBLE) { - runtime("$obj->{iv} = $obj->{nv};"); - } else { - runtime("$obj->{iv} = SvIV($obj->{sv});"); - } - $obj->{flags} |= VALID_INT; -} - -sub B::Stackobj::Padsv::load_double { - my $obj = shift; - $obj->write_back; - runtime("$obj->{nv} = SvNV($obj->{sv});"); - $obj->{flags} |= VALID_DOUBLE; -} - -sub B::Stackobj::Padsv::write_back { - my $obj = shift; - my $flags = $obj->{flags}; - return if $flags & VALID_SV; - if ($flags & VALID_INT) { - runtime("sv_setiv($obj->{sv}, $obj->{iv});"); - } elsif ($flags & VALID_DOUBLE) { - runtime("sv_setnv($obj->{sv}, $obj->{nv});"); - } else { - confess "write_back failed for lexical @{[$obj->peek]}\n"; - } - $obj->{flags} |= VALID_SV; -} - -# -# Stackobj::Const -# - -@B::Stackobj::Const::ISA = 'B::Stackobj'; -sub B::Stackobj::Const::new { - my ($class, $sv) = @_; - my $obj = bless { - flags => 0, - sv => $sv # holds the SV object until write_back happens - }, $class; - my $svflags = $sv->FLAGS; - if ($svflags & SVf_IOK) { - $obj->{flags} = VALID_INT|VALID_DOUBLE; - $obj->{type} = T_INT; - $obj->{nv} = $obj->{iv} = $sv->IV; - } elsif ($svflags & SVf_NOK) { - $obj->{flags} = VALID_INT|VALID_DOUBLE; - $obj->{type} = T_DOUBLE; - $obj->{iv} = $obj->{nv} = $sv->NV; - } else { - $obj->{type} = T_UNKNOWN; - } - return $obj; -} - -sub B::Stackobj::Const::write_back { - my $obj = shift; - return if $obj->{flags} & VALID_SV; - # Save the SV object and replace $obj->{sv} by its C source code name - $obj->{sv} = $obj->{sv}->save; - $obj->{flags} |= VALID_SV|VALID_INT|VALID_DOUBLE; -} - -sub B::Stackobj::Const::load_int { - my $obj = shift; - $obj->{iv} = int($obj->{sv}->PV); - $obj->{flags} |= VALID_INT; -} - -sub B::Stackobj::Const::load_double { - my $obj = shift; - $obj->{nv} = $obj->{sv}->PV + 0.0; - $obj->{flags} |= VALID_DOUBLE; -} - -sub B::Stackobj::Const::invalidate {} - -# -# Stackobj::Bool -# - -@B::Stackobj::Bool::ISA = 'B::Stackobj'; -sub B::Stackobj::Bool::new { - my ($class, $preg) = @_; - my $obj = bless { - type => T_INT, - flags => VALID_INT|VALID_DOUBLE, - iv => $$preg, - nv => $$preg, - preg => $preg # this holds our ref to the pseudo-reg - }, $class; - return $obj; -} - -sub B::Stackobj::Bool::write_back { - my $obj = shift; - return if $obj->{flags} & VALID_SV; - $obj->{sv} = "($obj->{iv} ? &sv_yes : &sv_no)"; - $obj->{flags} |= VALID_SV; -} - -# XXX Might want to handle as_double/set_double/load_double? - -sub B::Stackobj::Bool::invalidate {} - -1; diff --git a/lib/B/Terse.pm b/lib/B/Terse.pm deleted file mode 100644 index 6489dc0..0000000 --- a/lib/B/Terse.pm +++ /dev/null @@ -1,132 +0,0 @@ -package B::Terse; -use strict; -use B qw(peekop class walkoptree_slow walkoptree_exec - main_start main_root cstring svref_2object); -use B::Asmdata qw(@specialsv_name); - -sub terse { - my ($order, $cvref) = @_; - my $cv = svref_2object($cvref); - if ($order eq "exec") { - walkoptree_exec($cv->START, "terse"); - } else { - walkoptree_slow($cv->ROOT, "terse"); - } -} - -sub compile { - my $order = shift; - my @options = @_; - if (@options) { - return sub { - my $objname; - foreach $objname (@options) { - $objname = "main::$objname" unless $objname =~ /::/; - eval "terse(\$order, \\&$objname)"; - die "terse($order, \\&$objname) failed: $@" if $@; - } - } - } else { - if ($order eq "exec") { - return sub { walkoptree_exec(main_start, "terse") } - } else { - return sub { walkoptree_slow(main_root, "terse") } - } - } -} - -sub indent { - my $level = shift; - return " " x $level; -} - -sub B::OP::terse { - my ($op, $level) = @_; - my $targ = $op->targ; - $targ = ($targ > 0) ? " [$targ]" : ""; - print indent($level), peekop($op), $targ, "\n"; -} - -sub B::SVOP::terse { - my ($op, $level) = @_; - print indent($level), peekop($op), " "; - $op->sv->terse(0); -} - -sub B::GVOP::terse { - my ($op, $level) = @_; - print indent($level), peekop($op), " "; - $op->gv->terse(0); -} - -sub B::PMOP::terse { - my ($op, $level) = @_; - my $precomp = $op->precomp; - print indent($level), peekop($op), - defined($precomp) ? " /$precomp/\n" : " (regexp not compiled)\n"; - -} - -sub B::PVOP::terse { - my ($op, $level) = @_; - print indent($level), peekop($op), " ", cstring($op->pv), "\n"; -} - -sub B::COP::terse { - my ($op, $level) = @_; - my $label = $op->label; - if ($label) { - $label = " label ".cstring($label); - } - print indent($level), peekop($op), $label, "\n"; -} - -sub B::PV::terse { - my ($sv, $level) = @_; - print indent($level); - printf "%s (0x%lx) %s\n", class($sv), $$sv, cstring($sv->PV); -} - -sub B::AV::terse { - my ($sv, $level) = @_; - print indent($level); - printf "%s (0x%lx) FILL %d\n", class($sv), $$sv, $sv->FILL; -} - -sub B::GV::terse { - my ($gv, $level) = @_; - my $stash = $gv->STASH->NAME; - if ($stash eq "main") { - $stash = ""; - } else { - $stash = $stash . "::"; - } - print indent($level); - printf "%s (0x%lx) *%s%s\n", class($gv), $$gv, $stash, $gv->NAME; -} - -sub B::IV::terse { - my ($sv, $level) = @_; - print indent($level); - printf "%s (0x%lx) %d\n", class($sv), $$sv, $sv->IV; -} - -sub B::NV::terse { - my ($sv, $level) = @_; - print indent($level); - printf "%s (0x%lx) %s\n", class($sv), $$sv, $sv->NV; -} - -sub B::NULL::terse { - my ($sv, $level) = @_; - print indent($level); - printf "%s (0x%lx)\n", class($sv), $$sv; -} - -sub B::SPECIAL::terse { - my ($sv, $level) = @_; - print indent($level); - printf "%s #%d %s\n", class($sv), $$sv, $specialsv_name[$$sv]; -} - -1; diff --git a/lib/B/Xref.pm b/lib/B/Xref.pm deleted file mode 100644 index 0102856..0000000 --- a/lib/B/Xref.pm +++ /dev/null @@ -1,392 +0,0 @@ -package B::Xref; - -=head1 NAME - -B::Xref - Generates cross reference reports for Perl programs - -=head1 SYNOPSIS - -perl -MO=Xref[,OPTIONS] foo.pl - -=head1 DESCRIPTION - -The B::Xref module is used to generate a cross reference listing of all -definitions and uses of variables, subroutines and formats in a Perl program. -It is implemented as a backend for the Perl compiler. - -The report generated is in the following format: - - File filename1 - Subroutine subname1 - Package package1 - object1 C - object2 C - ... - Package package2 - ... - -Each B section reports on a single file. Each B section -reports on a single subroutine apart from the special cases -"(definitions)" and "(main)". These report, respectively, on subroutine -definitions found by the initial symbol table walk and on the main part of -the program or module external to all subroutines. - -The report is then grouped by the B of each variable, -subroutine or format with the special case "(lexicals)" meaning -lexical variables. Each B name (implicitly qualified by its -containing B) includes its type character(s) at the beginning -where possible. Lexical variables are easier to track and even -included dereferencing information where possible. - -The C are a comma separated list of line numbers (some -preceded by code letters) where that object is used in some way. -Simple uses aren't preceded by a code letter. Introductions (such as -where a lexical is first defined with C) are indicated with the -letter "i". Subroutine and method calls are indicated by the character -"&". Subroutine definitions are indicated by "s" and format -definitions by "f". - -=head1 OPTIONS - -Option words are separated by commas (not whitespace) and follow the -usual conventions of compiler backend options. - -=over 8 - -=item C<-oFILENAME> - -Directs output to C instead of standard output. - -=item C<-r> - -Raw output. Instead of producing a human-readable report, outputs a line -in machine-readable form for each definition/use of a variable/sub/format. - -=item C<-D[tO]> - -(Internal) debug options, probably only useful if C<-r> included. -The C option prints the object on the top of the stack as it's -being tracked. The C option prints each operator as it's being -processed in the execution order of the program. - -=back - -=head1 BUGS - -Non-lexical variables are quite difficult to track through a program. -Sometimes the type of a non-lexical variable's use is impossible to -determine. Introductions of non-lexical non-scalars don't seem to be -reported properly. - -=head1 AUTHOR - -Malcolm Beattie, mbeattie@sable.ox.ac.uk. - -=cut - -use strict; -use B qw(peekop class comppadlist main_start svref_2object walksymtable); - -# Constants (should probably be elsewhere) -sub OPpLVAL_INTRO () { 128 } -sub SVf_POK () { 0x40000 } - -sub UNKNOWN { ["?", "?", "?"] } - -my @pad; # lexicals in current pad - # as ["(lexical)", type, name] -my %done; # keyed by $$op: set when each $op is done -my $top = UNKNOWN; # shadows top element of stack as - # [pack, type, name] (pack can be "(lexical)") -my $file; # shadows current filename -my $line; # shadows current line number -my $subname; # shadows current sub name -my %table; # Multi-level hash to record all uses etc. -my @todo = (); # List of CVs that need processing - -my %code = (intro => "i", used => "", - subdef => "s", subused => "&", - formdef => "f", meth => "->"); - - -# Options -my ($debug_op, $debug_top, $nodefs, $raw); - -sub process { - my ($var, $event) = @_; - my ($pack, $type, $name) = @$var; - if ($type eq "*") { - if ($event eq "used") { - return; - } elsif ($event eq "subused") { - $type = "&"; - } - } - $type =~ s/(.)\*$/$1/g; - if ($raw) { - printf "%-16s %-12s %5d %-12s %4s %-16s %s\n", - $file, $subname, $line, $pack, $type, $name, $event; - } else { - # Wheee - push(@{$table{$file}->{$subname}->{$pack}->{$type.$name}->{$event}}, - $line); - } -} - -sub load_pad { - my $padlist = shift; - my ($namelistav, @namelist, $ix); - @pad = (); - return if class($padlist) eq "SPECIAL"; - ($namelistav) = $padlist->ARRAY; - @namelist = $namelistav->ARRAY; - for ($ix = 1; $ix < @namelist; $ix++) { - my $namesv = $namelist[$ix]; - next if class($namesv) eq "SPECIAL"; - my ($type, $name) = $namesv->PV =~ /^(.)(.*)$/; - $pad[$ix] = ["(lexical)", $type, $name]; - } -} - -sub xref { - my $start = shift; - my $op; - for ($op = $start; $$op; $op = $op->next) { - last if $done{$$op}++; - warn sprintf("top = [%s, %s, %s]\n", @$top) if $debug_top; - warn peekop($op), "\n" if $debug_op; - my $ppname = $op->ppaddr; - if ($ppname =~ /^pp_(or|and|mapwhile|grepwhile)$/) { - xref($op->other); - } elsif ($ppname eq "pp_match" || $ppname eq "pp_subst") { - xref($op->pmreplstart); - } elsif ($ppname eq "pp_substcont") { - xref($op->other->pmreplstart); - $op = $op->other; - redo; - } elsif ($ppname eq "pp_cond_expr") { - # pp_cond_expr never returns op_next - xref($op->true); - $op = $op->false; - redo; - } elsif ($ppname eq "pp_enterloop") { - xref($op->redoop); - xref($op->nextop); - xref($op->lastop); - } elsif ($ppname eq "pp_subst") { - xref($op->pmreplstart); - } else { - no strict 'refs'; - &$ppname($op) if defined(&$ppname); - } - } -} - -sub xref_cv { - my $cv = shift; - my $pack = $cv->GV->STASH->NAME; - $subname = ($pack eq "main" ? "" : "$pack\::") . $cv->GV->NAME; - load_pad($cv->PADLIST); - xref($cv->START); - $subname = "(main)"; -} - -sub xref_object { - my $cvref = shift; - xref_cv(svref_2object($cvref)); -} - -sub xref_main { - $subname = "(main)"; - load_pad(comppadlist); - xref(main_start); - while (@todo) { - xref_cv(shift @todo); - } -} - -sub pp_nextstate { - my $op = shift; - $file = $op->filegv->SV->PV; - $line = $op->line; - $top = UNKNOWN; -} - -sub pp_padsv { - my $op = shift; - $top = $pad[$op->targ]; - process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used"); -} - -sub pp_padav { pp_padsv(@_) } -sub pp_padhv { pp_padsv(@_) } - -sub deref { - my ($var, $as) = @_; - $var->[1] = $as . $var->[1]; - process($var, "used"); -} - -sub pp_rv2cv { deref($top, "&"); } -sub pp_rv2hv { deref($top, "%"); } -sub pp_rv2sv { deref($top, "\$"); } -sub pp_rv2av { deref($top, "\@"); } -sub pp_rv2gv { deref($top, "*"); } - -sub pp_gvsv { - my $op = shift; - my $gv = $op->gv; - $top = [$gv->STASH->NAME, '$', $gv->NAME]; - process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used"); -} - -sub pp_gv { - my $op = shift; - my $gv = $op->gv; - $top = [$gv->STASH->NAME, "*", $gv->NAME]; - process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used"); -} - -sub pp_const { - my $op = shift; - my $sv = $op->sv; - $top = ["?", "", - (class($sv) ne "SPECIAL" && $sv->FLAGS & SVf_POK) ? $sv->PV : "?"]; -} - -sub pp_method { - my $op = shift; - $top = ["(method)", "->".$top->[1], $top->[2]]; -} - -sub pp_entersub { - my $op = shift; - if ($top->[1] eq "m") { - process($top, "meth"); - } else { - process($top, "subused"); - } - $top = UNKNOWN; -} - -# -# Stuff for cross referencing definitions of variables and subs -# - -sub B::GV::xref { - my $gv = shift; - my $cv = $gv->CV; - if ($$cv) { - #return if $done{$$cv}++; - $file = $gv->FILEGV->SV->PV; - $line = $gv->LINE; - process([$gv->STASH->NAME, "&", $gv->NAME], "subdef"); - push(@todo, $cv); - } - my $form = $gv->FORM; - if ($$form) { - return if $done{$$form}++; - $file = $gv->FILEGV->SV->PV; - $line = $gv->LINE; - process([$gv->STASH->NAME, "", $gv->NAME], "formdef"); - } -} - -sub xref_definitions { - my ($pack, %exclude); - return if $nodefs; - $subname = "(definitions)"; - foreach $pack (qw(B O AutoLoader DynaLoader Config DB VMS - strict vars FileHandle Exporter Carp)) { - $exclude{$pack."::"} = 1; - } - no strict qw(vars refs); - walksymtable(\%{"main::"}, "xref", sub { !defined($exclude{$_[0]}) }); -} - -sub output { - return if $raw; - my ($file, $subname, $pack, $name, $ev, $perfile, $persubname, - $perpack, $pername, $perev); - foreach $file (sort(keys(%table))) { - $perfile = $table{$file}; - print "File $file\n"; - foreach $subname (sort(keys(%$perfile))) { - $persubname = $perfile->{$subname}; - print " Subroutine $subname\n"; - foreach $pack (sort(keys(%$persubname))) { - $perpack = $persubname->{$pack}; - print " Package $pack\n"; - foreach $name (sort(keys(%$perpack))) { - $pername = $perpack->{$name}; - my @lines; - foreach $ev (qw(intro formdef subdef meth subused used)) { - $perev = $pername->{$ev}; - if (defined($perev) && @$perev) { - my $code = $code{$ev}; - push(@lines, map("$code$_", @$perev)); - } - } - printf " %-16s %s\n", $name, join(", ", @lines); - } - } - } - } -} - -sub compile { - my @options = @_; - my ($option, $opt, $arg); - OPTION: - while ($option = shift @options) { - if ($option =~ /^-(.)(.*)/) { - $opt = $1; - $arg = $2; - } else { - unshift @options, $option; - last OPTION; - } - if ($opt eq "-" && $arg eq "-") { - shift @options; - last OPTION; - } elsif ($opt eq "o") { - $arg ||= shift @options; - open(STDOUT, ">$arg") or return "$arg: $!\n"; - } elsif ($opt eq "d") { - $nodefs = 1; - } elsif ($opt eq "r") { - $raw = 1; - } elsif ($opt eq "D") { - $arg ||= shift @options; - foreach $arg (split(//, $arg)) { - if ($arg eq "o") { - B->debug(1); - } elsif ($arg eq "O") { - $debug_op = 1; - } elsif ($arg eq "t") { - $debug_top = 1; - } - } - } - } - if (@options) { - return sub { - my $objname; - xref_definitions(); - foreach $objname (@options) { - $objname = "main::$objname" unless $objname =~ /::/; - eval "xref_object(\\&$objname)"; - die "xref_object(\\&$objname) failed: $@" if $@; - } - output(); - } - } else { - return sub { - xref_definitions(); - xref_main(); - output(); - } - } -} - -1; diff --git a/lib/B/assemble b/lib/B/assemble deleted file mode 100755 index 43cc5bc..0000000 --- a/lib/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/lib/B/cc_harness b/lib/B/cc_harness deleted file mode 100644 index 79f8727..0000000 --- a/lib/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/lib/B/disassemble b/lib/B/disassemble deleted file mode 100755 index 6530b80..0000000 --- a/lib/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/lib/B/makeliblinks b/lib/B/makeliblinks deleted file mode 100644 index 8256078..0000000 --- a/lib/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/lib/O.pm b/lib/O.pm deleted file mode 100644 index 40d336e..0000000 --- a/lib/O.pm +++ /dev/null @@ -1,21 +0,0 @@ -package O; -use B qw(minus_c); -use Carp; - -sub import { - my ($class, $backend, @options) = @_; - eval "use B::$backend ()"; - if ($@) { - croak "use of backend $backend failed: $@"; - } - my $compilesub = &{"B::${backend}::compile"}(@options); - if (ref($compilesub) eq "CODE") { - minus_c; - eval 'END { &$compilesub() }'; - } else { - die $compilesub; - } -} - -1; -