From: Malcolm Beattie Date: Fri, 20 Feb 1998 18:05:33 +0000 (+0000) Subject: Move lib/B/... and lib/[BO].pm over to where they should be, X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a798dbf2f5009fe67f7460a594ffd57a76c0fa98;hp=a8581515f26a081f18157dc1cf5553deae632d07;p=p5sagit%2Fp5-mst-13.2.git Move lib/B/... and lib/[BO].pm over to where they should be, under ext/B. p4raw-id: //depot/perl@564 --- diff --git a/ext/B/B.pm b/ext/B/B.pm new file mode 100644 index 0000000..8545c5c --- /dev/null +++ b/ext/B/B.pm @@ -0,0 +1,271 @@ +# B.pm +# +# Copyright (c) 1996, 1997 Malcolm Beattie +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the README file. +# +package B; +require DynaLoader; +require Exporter; +@ISA = qw(Exporter DynaLoader); +@EXPORT_OK = qw(byteload_fh byteload_string minus_c ppname + class peekop cast_I32 cstring cchar hash threadsv_names + main_root main_start main_cv svref_2object + walkoptree walkoptree_slow walkoptree_exec walksymtable + parents comppadlist sv_undef compile_stats timing_info); + +use strict; +@B::SV::ISA = 'B::OBJECT'; +@B::NULL::ISA = 'B::SV'; +@B::PV::ISA = 'B::SV'; +@B::IV::ISA = 'B::SV'; +@B::NV::ISA = 'B::IV'; +@B::RV::ISA = 'B::SV'; +@B::PVIV::ISA = qw(B::PV B::IV); +@B::PVNV::ISA = qw(B::PV B::NV); +@B::PVMG::ISA = 'B::PVNV'; +@B::PVLV::ISA = 'B::PVMG'; +@B::BM::ISA = 'B::PVMG'; +@B::AV::ISA = 'B::PVMG'; +@B::GV::ISA = 'B::PVMG'; +@B::HV::ISA = 'B::PVMG'; +@B::CV::ISA = 'B::PVMG'; +@B::IO::ISA = 'B::CV'; + +@B::OP::ISA = 'B::OBJECT'; +@B::UNOP::ISA = 'B::OP'; +@B::BINOP::ISA = 'B::UNOP'; +@B::LOGOP::ISA = 'B::UNOP'; +@B::CONDOP::ISA = 'B::UNOP'; +@B::LISTOP::ISA = 'B::BINOP'; +@B::SVOP::ISA = 'B::OP'; +@B::GVOP::ISA = 'B::OP'; +@B::PVOP::ISA = 'B::OP'; +@B::CVOP::ISA = 'B::OP'; +@B::LOOP::ISA = 'B::LISTOP'; +@B::PMOP::ISA = 'B::LISTOP'; +@B::COP::ISA = 'B::OP'; + +@B::SPECIAL::ISA = 'B::OBJECT'; + +{ + # Stop "-w" from complaining about the lack of a real B::OBJECT class + package B::OBJECT; +} + +my $debug; +my $op_count = 0; +my @parents = (); + +sub debug { + my ($class, $value) = @_; + $debug = $value; + walkoptree_debug($value); +} + +# sub OPf_KIDS; +# add to .xs for perl5.002 +sub OPf_KIDS () { 4 } + +sub class { + my $obj = shift; + my $name = ref $obj; + $name =~ s/^.*:://; + return $name; +} + +sub parents { \@parents } + +# For debugging +sub peekop { + my $op = shift; + return sprintf("%s (0x%x) %s", class($op), $$op, $op->ppaddr); +} + +sub walkoptree_slow { + my($op, $method, $level) = @_; + $op_count++; # just for statistics + $level ||= 0; + warn(sprintf("walkoptree: %d. %s\n", $level, peekop($op))) if $debug; + $op->$method($level); + if ($$op && ($op->flags & OPf_KIDS)) { + my $kid; + unshift(@parents, $op); + for ($kid = $op->first; $$kid; $kid = $kid->sibling) { + walkoptree_slow($kid, $method, $level + 1); + } + shift @parents; + } +} + +sub compile_stats { + return "Total number of OPs processed: $op_count\n"; +} + +sub timing_info { + my ($sec, $min, $hr) = localtime; + my ($user, $sys) = times; + sprintf("%02d:%02d:%02d user=$user sys=$sys", + $hr, $min, $sec, $user, $sys); +} + +my %symtable; +sub savesym { + my ($obj, $value) = @_; +# warn(sprintf("savesym: sym_%x => %s\n", $$obj, $value)); # debug + $symtable{sprintf("sym_%x", $$obj)} = $value; +} + +sub objsym { + my $obj = shift; + return $symtable{sprintf("sym_%x", $$obj)}; +} + +sub walkoptree_exec { + my ($op, $method, $level) = @_; + my ($sym, $ppname); + my $prefix = " " x $level; + for (; $$op; $op = $op->next) { + $sym = objsym($op); + if (defined($sym)) { + print $prefix, "goto $sym\n"; + return; + } + savesym($op, sprintf("%s (0x%lx)", class($op), $$op)); + $op->$method($level); + $ppname = $op->ppaddr; + if ($ppname =~ /^pp_(or|and|mapwhile|grepwhile|entertry)$/) { + print $prefix, uc($1), " => {\n"; + walkoptree_exec($op->other, $method, $level + 1); + print $prefix, "}\n"; + } elsif ($ppname eq "pp_match" || $ppname eq "pp_subst") { + my $pmreplstart = $op->pmreplstart; + if ($$pmreplstart) { + print $prefix, "PMREPLSTART => {\n"; + walkoptree_exec($pmreplstart, $method, $level + 1); + print $prefix, "}\n"; + } + } elsif ($ppname eq "pp_substcont") { + print $prefix, "SUBSTCONT => {\n"; + walkoptree_exec($op->other->pmreplstart, $method, $level + 1); + print $prefix, "}\n"; + $op = $op->other; + } elsif ($ppname eq "pp_cond_expr") { + # pp_cond_expr never returns op_next + print $prefix, "TRUE => {\n"; + walkoptree_exec($op->true, $method, $level + 1); + print $prefix, "}\n"; + $op = $op->false; + redo; + } elsif ($ppname eq "pp_range") { + print $prefix, "TRUE => {\n"; + walkoptree_exec($op->true, $method, $level + 1); + print $prefix, "}\n", $prefix, "FALSE => {\n"; + walkoptree_exec($op->false, $method, $level + 1); + print $prefix, "}\n"; + } elsif ($ppname eq "pp_enterloop") { + print $prefix, "REDO => {\n"; + walkoptree_exec($op->redoop, $method, $level + 1); + print $prefix, "}\n", $prefix, "NEXT => {\n"; + walkoptree_exec($op->nextop, $method, $level + 1); + print $prefix, "}\n", $prefix, "LAST => {\n"; + walkoptree_exec($op->lastop, $method, $level + 1); + print $prefix, "}\n"; + } elsif ($ppname eq "pp_subst") { + my $replstart = $op->pmreplstart; + if ($$replstart) { + print $prefix, "SUBST => {\n"; + walkoptree_exec($replstart, $method, $level + 1); + print $prefix, "}\n"; + } + } + } +} + +sub walksymtable { + my ($symref, $method, $recurse, $prefix) = @_; + my $sym; + no strict 'vars'; + local(*glob); + while (($sym, *glob) = each %$symref) { + if ($sym =~ /::$/) { + $sym = $prefix . $sym; + if ($sym ne "main::" && &$recurse($sym)) { + walksymtable(\%glob, $method, $recurse, $sym); + } + } else { + svref_2object(\*glob)->EGV->$method(); + } + } +} + +{ + package B::Section; + my $output_fh; + my %sections; + + sub new { + my ($class, $section, $symtable, $default) = @_; + $output_fh ||= FileHandle->new_tmpfile; + my $obj = bless [-1, $section, $symtable, $default], $class; + $sections{$section} = $obj; + return $obj; + } + + sub get { + my ($class, $section) = @_; + return $sections{$section}; + } + + sub add { + my $section = shift; + while (defined($_ = shift)) { + print $output_fh "$section->[1]\t$_\n"; + $section->[0]++; + } + } + + sub index { + my $section = shift; + return $section->[0]; + } + + sub name { + my $section = shift; + return $section->[1]; + } + + sub symtable { + my $section = shift; + return $section->[2]; + } + + sub default { + my $section = shift; + return $section->[3]; + } + + sub output { + my ($section, $fh, $format) = @_; + my $name = $section->name; + my $sym = $section->symtable || {}; + my $default = $section->default; + + seek($output_fh, 0, 0); + while (<$output_fh>) { + chomp; + s/^(.*?)\t//; + if ($1 eq $name) { + s{(s\\_[0-9a-f]+)} { + exists($sym->{$1}) ? $sym->{$1} : $default; + }ge; + printf $fh $format, $_; + } + } + } +} + +bootstrap B; + +1; diff --git a/ext/B/B/Asmdata.pm b/ext/B/B/Asmdata.pm new file mode 100644 index 0000000..3a3cf6d --- /dev/null +++ b/ext/B/B/Asmdata.pm @@ -0,0 +1,150 @@ +# +# 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/ext/B/B/Assembler.pm b/ext/B/B/Assembler.pm new file mode 100644 index 0000000..0729b90 --- /dev/null +++ b/ext/B/B/Assembler.pm @@ -0,0 +1,207 @@ +# 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/ext/B/B/Bblock.pm b/ext/B/B/Bblock.pm new file mode 100644 index 0000000..125c8a3 --- /dev/null +++ b/ext/B/B/Bblock.pm @@ -0,0 +1,142 @@ +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/ext/B/B/Bytecode.pm b/ext/B/B/Bytecode.pm new file mode 100644 index 0000000..447bd37 --- /dev/null +++ b/ext/B/B/Bytecode.pm @@ -0,0 +1,778 @@ +# 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/ext/B/B/C.pm b/ext/B/B/C.pm new file mode 100644 index 0000000..4158bc4 --- /dev/null +++ b/ext/B/B/C.pm @@ -0,0 +1,1201 @@ +# 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/ext/B/B/CC.pm b/ext/B/B/CC.pm new file mode 100644 index 0000000..fc7cf6d --- /dev/null +++ b/ext/B/B/CC.pm @@ -0,0 +1,1528 @@ +# 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/ext/B/B/Debug.pm b/ext/B/B/Debug.pm new file mode 100644 index 0000000..d88cef3 --- /dev/null +++ b/ext/B/B/Debug.pm @@ -0,0 +1,263 @@ +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/ext/B/B/Deparse.pm b/ext/B/B/Deparse.pm new file mode 100644 index 0000000..9802cb4 --- /dev/null +++ b/ext/B/B/Deparse.pm @@ -0,0 +1,102 @@ +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/ext/B/B/Disassembler.pm b/ext/B/B/Disassembler.pm new file mode 100644 index 0000000..36db354 --- /dev/null +++ b/ext/B/B/Disassembler.pm @@ -0,0 +1,144 @@ +# 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/ext/B/B/Lint.pm b/ext/B/B/Lint.pm new file mode 100644 index 0000000..d34bd77 --- /dev/null +++ b/ext/B/B/Lint.pm @@ -0,0 +1,367 @@ +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/ext/B/B/Showlex.pm b/ext/B/B/Showlex.pm new file mode 100644 index 0000000..9cf8ecc --- /dev/null +++ b/ext/B/B/Showlex.pm @@ -0,0 +1,58 @@ +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/ext/B/B/Stackobj.pm b/ext/B/B/Stackobj.pm new file mode 100644 index 0000000..8be047f --- /dev/null +++ b/ext/B/B/Stackobj.pm @@ -0,0 +1,281 @@ +# 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/ext/B/B/Terse.pm b/ext/B/B/Terse.pm new file mode 100644 index 0000000..6489dc0 --- /dev/null +++ b/ext/B/B/Terse.pm @@ -0,0 +1,132 @@ +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/ext/B/B/Xref.pm b/ext/B/B/Xref.pm new file mode 100644 index 0000000..0102856 --- /dev/null +++ b/ext/B/B/Xref.pm @@ -0,0 +1,392 @@ +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/ext/B/B/assemble b/ext/B/B/assemble new file mode 100755 index 0000000..43cc5bc --- /dev/null +++ b/ext/B/B/assemble @@ -0,0 +1,30 @@ +use B::Assembler qw(assemble_fh); +use FileHandle; + +my ($filename, $fh, $out); + +if ($ARGV[0] eq "-d") { + B::Assembler::debug(1); + shift; +} + +$out = \*STDOUT; + +if (@ARGV == 0) { + $fh = \*STDIN; + $filename = "-"; +} elsif (@ARGV == 1) { + $filename = $ARGV[0]; + $fh = new FileHandle "<$filename"; +} elsif (@ARGV == 2) { + $filename = $ARGV[0]; + $fh = new FileHandle "<$filename"; + $out = new FileHandle ">$ARGV[1]"; +} else { + die "Usage: assemble [filename] [outfilename]\n"; +} + +binmode $out; +$SIG{__WARN__} = sub { warn "$filename:@_" }; +$SIG{__DIE__} = sub { die "$filename: @_" }; +assemble_fh($fh, sub { print $out @_ }); diff --git a/ext/B/B/cc_harness b/ext/B/B/cc_harness new file mode 100644 index 0000000..79f8727 --- /dev/null +++ b/ext/B/B/cc_harness @@ -0,0 +1,12 @@ +use Config; + +$libdir = $ENV{PERL_SRC} || "$Config{installarchlib}/CORE"; + +if (!grep(/^-[cS]$/, @ARGV)) { + $linkargs = sprintf("%s $libdir/$Config{libperl} %s", + @Config{qw(ldflags libs)}); +} + +$cccmd = "$Config{cc} $Config{ccflags} -I$libdir @ARGV $linkargs"; +print "$cccmd\n"; +exec $cccmd; diff --git a/ext/B/B/disassemble b/ext/B/B/disassemble new file mode 100755 index 0000000..6530b80 --- /dev/null +++ b/ext/B/B/disassemble @@ -0,0 +1,22 @@ +use B::Disassembler qw(disassemble_fh); +use FileHandle; + +my $fh; +if (@ARGV == 0) { + $fh = \*STDIN; +} elsif (@ARGV == 1) { + $fh = new FileHandle "<$ARGV[0]"; +} else { + die "Usage: disassemble [filename]\n"; +} + +sub print_insn { + my ($insn, $arg) = @_; + if (defined($arg)) { + printf "%s %s\n", $insn, $arg; + } else { + print $insn, "\n"; + } +} + +disassemble_fh($fh, \&print_insn); diff --git a/ext/B/B/makeliblinks b/ext/B/B/makeliblinks new file mode 100644 index 0000000..8256078 --- /dev/null +++ b/ext/B/B/makeliblinks @@ -0,0 +1,54 @@ +use File::Find; +use Config; + +if (@ARGV != 2) { + warn <<"EOT"; +Usage: makeliblinks libautodir targetdir +where libautodir is the architecture-dependent auto directory +(e.g. $Config::Config{archlib}/auto). +EOT + exit 2; +} + +my ($libautodir, $targetdir) = @ARGV; + +# Calculate relative path prefix from $targetdir to $libautodir +sub relprefix { + my ($to, $from) = @_; + my $up; + for ($up = 0; substr($to, 0, length($from)) ne $from; $up++) { + $from =~ s( + [^/]+ (?# a group of non-slashes) + /* (?# maybe with some trailing slashes) + $ (?# at the end of the path) + )()x; + } + return (("../" x $up) . substr($to, length($from))); +} + +my $relprefix = relprefix($libautodir, $targetdir); + +my ($dlext, $lib_ext) = @Config::Config{qw(dlext lib_ext)}; + +sub link_if_library { + if (/\.($dlext|$lib_ext)$/o) { + my $ext = $1; + my $name = $File::Find::name; + if (substr($name, 0, length($libautodir) + 1) ne "$libautodir/") { + die "directory of $name doesn't match $libautodir\n"; + } + substr($name, 0, length($libautodir) + 1) = ''; + my @parts = split(m(/), $name); + if ($parts[-1] ne "$parts[-2].$ext") { + die "module name $_ doesn't match its directory $libautodir\n"; + } + pop @parts; + my $libpath = "$targetdir/lib" . join("__", @parts) . ".$ext"; + print "$libpath -> $relprefix/$name\n"; + symlink("$relprefix/$name", $libpath) + or warn "above link failed with error: $!\n"; + } +} + +find(\&link_if_library, $libautodir); +exit 0; diff --git a/ext/B/O.pm b/ext/B/O.pm new file mode 100644 index 0000000..40d336e --- /dev/null +++ b/ext/B/O.pm @@ -0,0 +1,21 @@ +package O; +use B qw(minus_c); +use Carp; + +sub import { + my ($class, $backend, @options) = @_; + eval "use B::$backend ()"; + if ($@) { + croak "use of backend $backend failed: $@"; + } + my $compilesub = &{"B::${backend}::compile"}(@options); + if (ref($compilesub) eq "CODE") { + minus_c; + eval 'END { &$compilesub() }'; + } else { + die $compilesub; + } +} + +1; +