Skip to content
Browse files

Initial import B-C-1.04_01

git-svn-id: http://perl-compiler.googlecode.com/svn/trunk@2 ed534f1a-1453-0410-ab30-dfc593a8b23c
  • Loading branch information...
1 parent da779c2 commit c21739460ca5c89a771f08ddece7d575d7a1f5be @rurban committed
Showing with 13,391 additions and 0 deletions.
  1. +244 −0 B/Asmdata.pm
  2. +334 −0 B/Assembler.pm
  3. +225 −0 B/Bblock.pm
  4. +904 −0 B/Bytecode.pm
  5. +2,236 −0 B/C.pm
  6. +2,005 −0 B/CC.pm
  7. +241 −0 B/Disassembler.pm
  8. +349 −0 B/Stackobj.pm
  9. +52 −0 B/Stash.pm
  10. +40 −0 ByteLoader/ByteLoader.pm
  11. +135 −0 ByteLoader/ByteLoader.xs
  12. +23 −0 ByteLoader/Makefile.PL
  13. +478 −0 ByteLoader/bytecode.h
  14. +1,115 −0 ByteLoader/byterun.c
  15. +205 −0 ByteLoader/byterun.h
  16. +2 −0 ByteLoader/hints/sunos.pl
  17. +56 −0 C.xs
  18. +13 −0 Changes
  19. +48 −0 MANIFEST
  20. +14 −0 META.yml
  21. +79 −0 Makefile.PL
  22. +168 −0 NOTES
  23. +325 −0 README
  24. +78 −0 TESTS
  25. +38 −0 Todo
  26. +587 −0 bytecode.pl
  27. +2 −0 hints/darwin.pl
  28. +2 −0 hints/openbsd.pl
  29. +32 −0 ramblings/cc.notes
  30. +39 −0 ramblings/curcop.runtime
  31. +54 −0 ramblings/flip-flop
  32. +93 −0 ramblings/magic
  33. +32 −0 ramblings/reg.alloc
  34. +357 −0 ramblings/runtime.porting
  35. +45 −0 regen_lib.pl
  36. +30 −0 scripts/assemble
  37. +12 −0 scripts/cc_harness
  38. +22 −0 scripts/disassemble
  39. +650 −0 scripts/perlcc
  40. +84 −0 t/TESTS
  41. +57 −0 t/asmdata.t
  42. +402 −0 t/assembler.t
  43. +194 −0 t/b.t
  44. +20 −0 t/bblock.t
  45. +123 −0 t/bytecode.t
  46. +55 −0 t/c.t
  47. +56 −0 t/cc.t
  48. +87 −0 t/o.t
  49. +103 −0 t/stash.t
  50. +841 −0 t/test.pl
  51. +5 −0 t/z_pod.t
View
244 B/Asmdata.pm
@@ -0,0 +1,244 @@
+# -#- buffer-read-only: t -#-
+#
+# Copyright (c) 1996-1999 Malcolm Beattie
+# Copyright (c) 2008 Reini Urban
+#
+# 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;
+
+our $VERSION = '1.02_01';
+
+use Exporter;
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(%insn_data @insn_name @optype @specialsv_name);
+our(%insn_data, @insn_name);
+
+use B qw(@optype @specialsv_name);
+
+
+# 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_t, "GET_comment_t"];
+$insn_data{nop} = [10, \&PUT_none, "GET_none"];
+$insn_data{ret} = [0, \&PUT_none, "GET_none"];
+$insn_data{ldsv} = [1, \&PUT_svindex, "GET_svindex"];
+$insn_data{ldop} = [2, \&PUT_opindex, "GET_opindex"];
+$insn_data{stsv} = [3, \&PUT_U32, "GET_U32"];
+$insn_data{stop} = [4, \&PUT_U32, "GET_U32"];
+$insn_data{stpv} = [5, \&PUT_U32, "GET_U32"];
+$insn_data{ldspecsv} = [6, \&PUT_U8, "GET_U8"];
+$insn_data{ldspecsvx} = [7, \&PUT_U8, "GET_U8"];
+$insn_data{newsv} = [8, \&PUT_U8, "GET_U8"];
+$insn_data{newsvx} = [9, \&PUT_U32, "GET_U32"];
+$insn_data{newop} = [11, \&PUT_U8, "GET_U8"];
+$insn_data{newopx} = [12, \&PUT_U16, "GET_U16"];
+$insn_data{newopn} = [13, \&PUT_U8, "GET_U8"];
+$insn_data{newpv} = [14, \&PUT_PV, "GET_PV"];
+$insn_data{pv_cur} = [15, \&PUT_PADOFFSET, "GET_PADOFFSET"];
+$insn_data{pv_free} = [16, \&PUT_none, "GET_none"];
+$insn_data{sv_upgrade} = [17, \&PUT_U8, "GET_U8"];
+$insn_data{sv_refcnt} = [18, \&PUT_U32, "GET_U32"];
+$insn_data{sv_refcnt_add} = [19, \&PUT_I32, "GET_I32"];
+$insn_data{sv_flags} = [20, \&PUT_U32, "GET_U32"];
+$insn_data{xrv} = [21, \&PUT_svindex, "GET_svindex"];
+$insn_data{xpv} = [22, \&PUT_none, "GET_none"];
+$insn_data{xpv_cur} = [23, \&PUT_PADOFFSET, "GET_PADOFFSET"];
+$insn_data{xpv_len} = [24, \&PUT_PADOFFSET, "GET_PADOFFSET"];
+$insn_data{xiv} = [25, \&PUT_IV, "GET_IV"];
+$insn_data{xnv} = [26, \&PUT_NV, "GET_NV"];
+$insn_data{xlv_targoff} = [27, \&PUT_PADOFFSET, "GET_PADOFFSET"];
+$insn_data{xlv_targlen} = [28, \&PUT_PADOFFSET, "GET_PADOFFSET"];
+$insn_data{xlv_targ} = [29, \&PUT_svindex, "GET_svindex"];
+$insn_data{xlv_type} = [30, \&PUT_U8, "GET_U8"];
+$insn_data{xbm_useful} = [31, \&PUT_I32, "GET_I32"];
+$insn_data{xbm_previous} = [32, \&PUT_U16, "GET_U16"];
+$insn_data{xbm_rare} = [33, \&PUT_U8, "GET_U8"];
+$insn_data{xfm_lines} = [34, \&PUT_IV, "GET_IV"];
+$insn_data{xio_lines} = [36, \&PUT_IV, "GET_IV"];
+$insn_data{xio_page} = [37, \&PUT_IV, "GET_IV"];
+$insn_data{xio_page_len} = [38, \&PUT_IV, "GET_IV"];
+$insn_data{xio_lines_left} = [39, \&PUT_IV, "GET_IV"];
+$insn_data{xio_top_name} = [40, \&PUT_pvindex, "GET_pvindex"];
+$insn_data{xio_top_gv} = [41, \&PUT_svindex, "GET_svindex"];
+$insn_data{xio_fmt_name} = [42, \&PUT_pvindex, "GET_pvindex"];
+$insn_data{xio_fmt_gv} = [43, \&PUT_svindex, "GET_svindex"];
+$insn_data{xio_bottom_name} = [44, \&PUT_pvindex, "GET_pvindex"];
+$insn_data{xio_bottom_gv} = [45, \&PUT_svindex, "GET_svindex"];
+$insn_data{xio_type} = [46, \&PUT_U8, "GET_U8"];
+$insn_data{xio_flags} = [47, \&PUT_U8, "GET_U8"];
+$insn_data{xcv_xsubany} = [48, \&PUT_svindex, "GET_svindex"];
+$insn_data{xcv_stash} = [49, \&PUT_svindex, "GET_svindex"];
+$insn_data{xcv_start} = [50, \&PUT_opindex, "GET_opindex"];
+$insn_data{xcv_root} = [51, \&PUT_opindex, "GET_opindex"];
+$insn_data{xcv_gv} = [52, \&PUT_svindex, "GET_svindex"];
+$insn_data{xcv_file} = [53, \&PUT_pvindex, "GET_pvindex"];
+$insn_data{xcv_depth} = [54, \&PUT_long, "GET_long"];
+$insn_data{xcv_padlist} = [55, \&PUT_svindex, "GET_svindex"];
+$insn_data{xcv_outside} = [56, \&PUT_svindex, "GET_svindex"];
+$insn_data{xcv_outside_seq} = [57, \&PUT_U32, "GET_U32"];
+$insn_data{xcv_flags} = [58, \&PUT_U16, "GET_U16"];
+$insn_data{av_extend} = [59, \&PUT_PADOFFSET, "GET_PADOFFSET"];
+$insn_data{av_pushx} = [60, \&PUT_svindex, "GET_svindex"];
+$insn_data{av_push} = [61, \&PUT_svindex, "GET_svindex"];
+$insn_data{xav_fill} = [62, \&PUT_PADOFFSET, "GET_PADOFFSET"];
+$insn_data{xav_max} = [63, \&PUT_PADOFFSET, "GET_PADOFFSET"];
+$insn_data{xav_flags} = [64, \&PUT_I32, "GET_I32"];
+$insn_data{xhv_name} = [65, \&PUT_pvindex, "GET_pvindex"];
+$insn_data{hv_store} = [66, \&PUT_svindex, "GET_svindex"];
+$insn_data{sv_magic} = [67, \&PUT_U8, "GET_U8"];
+$insn_data{mg_obj} = [68, \&PUT_svindex, "GET_svindex"];
+$insn_data{mg_private} = [69, \&PUT_U16, "GET_U16"];
+$insn_data{mg_flags} = [70, \&PUT_U8, "GET_U8"];
+$insn_data{mg_name} = [71, \&PUT_pvcontents, "GET_pvcontents"];
+$insn_data{mg_namex} = [72, \&PUT_svindex, "GET_svindex"];
+$insn_data{xmg_stash} = [73, \&PUT_svindex, "GET_svindex"];
+$insn_data{gv_fetchpv} = [74, \&PUT_strconst, "GET_strconst"];
+$insn_data{gv_fetchpvx} = [75, \&PUT_strconst, "GET_strconst"];
+$insn_data{gv_stashpv} = [76, \&PUT_strconst, "GET_strconst"];
+$insn_data{gv_stashpvx} = [77, \&PUT_strconst, "GET_strconst"];
+$insn_data{gp_sv} = [78, \&PUT_svindex, "GET_svindex"];
+$insn_data{gp_refcnt} = [79, \&PUT_U32, "GET_U32"];
+$insn_data{gp_refcnt_add} = [80, \&PUT_I32, "GET_I32"];
+$insn_data{gp_av} = [81, \&PUT_svindex, "GET_svindex"];
+$insn_data{gp_hv} = [82, \&PUT_svindex, "GET_svindex"];
+$insn_data{gp_cv} = [83, \&PUT_svindex, "GET_svindex"];
+$insn_data{gp_file} = [84, \&PUT_hekindex, "GET_hekindex"];
+$insn_data{gp_io} = [85, \&PUT_svindex, "GET_svindex"];
+$insn_data{gp_form} = [86, \&PUT_svindex, "GET_svindex"];
+$insn_data{gp_cvgen} = [87, \&PUT_U32, "GET_U32"];
+$insn_data{gp_line} = [88, \&PUT_U32, "GET_U32"];
+$insn_data{gp_share} = [89, \&PUT_svindex, "GET_svindex"];
+$insn_data{xgv_flags} = [90, \&PUT_U8, "GET_U8"];
+$insn_data{op_next} = [91, \&PUT_opindex, "GET_opindex"];
+$insn_data{op_sibling} = [92, \&PUT_opindex, "GET_opindex"];
+$insn_data{op_ppaddr} = [93, \&PUT_strconst, "GET_strconst"];
+$insn_data{op_targ} = [94, \&PUT_PADOFFSET, "GET_PADOFFSET"];
+$insn_data{op_type} = [95, \&PUT_U16, "GET_U16"];
+$insn_data{op_opt} = [96, \&PUT_U8, "GET_U8"];
+$insn_data{op_latefree} = [97, \&PUT_U8, "GET_U8"];
+$insn_data{op_latefreed} = [98, \&PUT_U8, "GET_U8"];
+$insn_data{op_attached} = [99, \&PUT_U8, "GET_U8"];
+$insn_data{op_flags} = [100, \&PUT_U8, "GET_U8"];
+$insn_data{op_private} = [101, \&PUT_U8, "GET_U8"];
+$insn_data{op_first} = [102, \&PUT_opindex, "GET_opindex"];
+$insn_data{op_last} = [103, \&PUT_opindex, "GET_opindex"];
+$insn_data{op_other} = [104, \&PUT_opindex, "GET_opindex"];
+$insn_data{op_pmreplroot} = [105, \&PUT_opindex, "GET_opindex"];
+$insn_data{op_pmreplstart} = [106, \&PUT_opindex, "GET_opindex"];
+$insn_data{op_pmstashpv} = [107, \&PUT_pvindex, "GET_pvindex"];
+$insn_data{op_pmreplrootpo} = [108, \&PUT_PADOFFSET, "GET_PADOFFSET"];
+$insn_data{op_pmreplrootgv} = [109, \&PUT_svindex, "GET_svindex"];
+$insn_data{pregcomp} = [110, \&PUT_svindex, "GET_svindex"];
+$insn_data{op_pmflags} = [111, \&PUT_U16, "GET_U16"];
+$insn_data{op_sv} = [112, \&PUT_svindex, "GET_svindex"];
+$insn_data{op_padix} = [113, \&PUT_PADOFFSET, "GET_PADOFFSET"];
+$insn_data{op_pv} = [114, \&PUT_pvcontents, "GET_pvcontents"];
+$insn_data{op_pv_tr} = [115, \&PUT_op_tr_array, "GET_op_tr_array"];
+$insn_data{op_redoop} = [116, \&PUT_opindex, "GET_opindex"];
+$insn_data{op_nextop} = [117, \&PUT_opindex, "GET_opindex"];
+$insn_data{op_lastop} = [118, \&PUT_opindex, "GET_opindex"];
+$insn_data{cop_label} = [119, \&PUT_pvindex, "GET_pvindex"];
+$insn_data{cop_stashpv} = [120, \&PUT_pvindex, "GET_pvindex"];
+$insn_data{cop_file} = [121, \&PUT_pvindex, "GET_pvindex"];
+$insn_data{cop_seq} = [122, \&PUT_U32, "GET_U32"];
+$insn_data{cop_line} = [123, \&PUT_U32, "GET_U32"];
+$insn_data{cop_warnings} = [124, \&PUT_svindex, "GET_svindex"];
+$insn_data{main_start} = [125, \&PUT_opindex, "GET_opindex"];
+$insn_data{main_root} = [126, \&PUT_opindex, "GET_opindex"];
+$insn_data{main_cv} = [127, \&PUT_svindex, "GET_svindex"];
+$insn_data{curpad} = [128, \&PUT_svindex, "GET_svindex"];
+$insn_data{push_begin} = [129, \&PUT_svindex, "GET_svindex"];
+$insn_data{push_init} = [130, \&PUT_svindex, "GET_svindex"];
+$insn_data{push_end} = [131, \&PUT_svindex, "GET_svindex"];
+$insn_data{curstash} = [132, \&PUT_svindex, "GET_svindex"];
+$insn_data{defstash} = [133, \&PUT_svindex, "GET_svindex"];
+$insn_data{data} = [134, \&PUT_U8, "GET_U8"];
+$insn_data{incav} = [135, \&PUT_svindex, "GET_svindex"];
+$insn_data{load_glob} = [136, \&PUT_svindex, "GET_svindex"];
+$insn_data{regex_padav} = [137, \&PUT_svindex, "GET_svindex"];
+$insn_data{dowarn} = [138, \&PUT_U8, "GET_U8"];
+$insn_data{comppad_name} = [139, \&PUT_svindex, "GET_svindex"];
+$insn_data{xgv_stash} = [140, \&PUT_svindex, "GET_svindex"];
+$insn_data{signal} = [141, \&PUT_strconst, "GET_strconst"];
+$insn_data{formfeed} = [142, \&PUT_svindex, "GET_svindex"];
+
+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;
+
+__END__
+
+=head1 NAME
+
+B::Asmdata - Autogenerated data about Perl ops, used to generate bytecode
+
+=head1 SYNOPSIS
+
+ use B::Asmdata qw(%insn_data @insn_name @optype @specialsv_name);
+
+=head1 DESCRIPTION
+
+Provides information about Perl ops in order to generate bytecode via
+a bunch of exported variables. Its mostly used by B::Assembler and
+B::Disassembler.
+
+=over 4
+
+=item %insn_data
+
+ my($bytecode_num, $put_sub, $get_meth) = @$insn_data{$op_name};
+
+For a given $op_name (for example, 'cop_label', 'sv_flags', etc...)
+you get an array ref containing the bytecode number of the op, a
+reference to the subroutine used to 'PUT', and the name of the method
+used to 'GET'.
+
+=for _private
+Add more detail about what $put_sub and $get_meth are and how to use them.
+
+=item @insn_name
+
+ my $op_name = $insn_name[$bytecode_num];
+
+A simple mapping of the bytecode number to the name of the op.
+Suitable for using with %insn_data like so:
+
+ my $op_info = $insn_data{$insn_name[$bytecode_num]};
+
+=item @optype
+
+ my $op_type = $optype[$op_type_num];
+
+A simple mapping of the op type number to its type (like 'COP' or 'BINOP').
+
+=item @specialsv_name
+
+ my $sv_name = $specialsv_name[$sv_index];
+
+Certain SV types are considered 'special'. They're represented by
+B::SPECIAL and are referred to by a number from the specialsv_list.
+This array maps that number back to the name of the SV (like 'Nullsv'
+or '&PL_sv_undef').
+
+=back
+
+=head1 AUTHOR
+
+Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
+Reini Urban added the version logic and 5.10 support.
+
+=cut
+
+# ex: set ro:
View
334 B/Assembler.pm
@@ -0,0 +1,334 @@
+# Assembler.pm
+#
+# Copyright (c) 1996 Malcolm Beattie
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the README file.
+
+package B::Assembler;
+use Exporter;
+use B qw(ppname);
+use B::Asmdata qw(%insn_data @insn_name);
+use Config qw(%Config);
+require ByteLoader; # we just need its $VERSION
+
+no warnings; # XXX
+
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(assemble_fh newasm endasm assemble asm);
+$VERSION = '0.07_01';
+
+use strict;
+my %opnumber;
+my ($i, $opname);
+for ($i = 0; defined($opname = ppname($i)); $i++) {
+ $opnumber{$opname} = $i;
+}
+
+my($linenum, $errors, $out); # global state, set up by newasm
+
+sub error {
+ my $str = shift;
+ warn "$linenum: $str\n";
+ $errors++;
+}
+
+my $debug = 0;
+sub debug { $debug = shift }
+
+sub limcheck($$$$){
+ my( $val, $lo, $hi, $loc ) = @_;
+ if( $val < $lo || $hi < $val ){
+ error "argument for $loc outside [$lo, $hi]: $val";
+ $val = $hi;
+ }
+ return $val;
+}
+
+#
+# First define all the data conversion subs to which Asmdata will refer
+#
+
+sub B::Asmdata::PUT_U8 {
+ my $arg = shift;
+ my $c = uncstring($arg);
+ if (defined($c)) {
+ if (length($c) != 1) {
+ error "argument for U8 is too long: $c";
+ $c = substr($c, 0, 1);
+ }
+ } else {
+ $arg = limcheck( $arg, 0, 0xff, 'U8' );
+ $c = chr($arg);
+ }
+ return $c;
+}
+
+sub B::Asmdata::PUT_U16 {
+ my $arg = limcheck( $_[0], 0, 0xffff, 'U16' );
+ pack("S", $arg);
+}
+sub B::Asmdata::PUT_U32 {
+ my $arg = limcheck( $_[0], 0, 0xffffffff, 'U32' );
+ pack("L", $arg);
+}
+sub B::Asmdata::PUT_I32 {
+ my $arg = limcheck( $_[0], -0x80000000, 0x7fffffff, 'I32' );
+ pack("l", $arg);
+}
+sub B::Asmdata::PUT_NV { sprintf("%s\0", $_[0]) } # "%lf" looses precision and pack('d',...)
+ # may not even be portable between compilers
+sub B::Asmdata::PUT_objindex { # could allow names here
+ my $arg = limcheck( $_[0], 0, 0xffffffff, '*index' );
+ pack("L", $arg);
+}
+sub B::Asmdata::PUT_svindex { &B::Asmdata::PUT_objindex }
+sub B::Asmdata::PUT_opindex { &B::Asmdata::PUT_objindex }
+sub B::Asmdata::PUT_pvindex { &B::Asmdata::PUT_objindex }
+sub B::Asmdata::PUT_hekindex { &B::Asmdata::PUT_objindex }
+
+sub B::Asmdata::PUT_strconst {
+ my $arg = shift;
+ my $str = uncstring($arg);
+ if (!defined($str)) {
+ error "bad string constant: $arg";
+ $str = '';
+ }
+ if ($str =~ s/\0//g) {
+ error "string constant argument contains NUL: $arg";
+ $str = '';
+ }
+ return $str . "\0";
+}
+
+sub B::Asmdata::PUT_pvcontents {
+ my $arg = shift;
+ error "extraneous argument: $arg" if defined $arg;
+ return "";
+}
+sub B::Asmdata::PUT_PV {
+ my $arg = shift;
+ my $str = uncstring($arg);
+ if( ! defined($str) ){
+ error "bad string argument: $arg";
+ $str = '';
+ }
+ return pack("L", length($str)) . $str;
+}
+sub B::Asmdata::PUT_comment_t {
+ my $arg = shift;
+ $arg = uncstring($arg);
+ error "bad string argument: $arg" unless defined($arg);
+ if ($arg =~ s/\n//g) {
+ error "comment argument contains linefeed: $arg";
+ }
+ return $arg . "\n";
+}
+sub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) } # see PUT_NV above
+sub B::Asmdata::PUT_none {
+ my $arg = shift;
+ error "extraneous argument: $arg" if defined $arg;
+ return "";
+}
+sub B::Asmdata::PUT_op_tr_array {
+ my @ary = split /\s*,\s*/, shift;
+ return pack "S*", @ary;
+}
+
+sub B::Asmdata::PUT_IV64 {
+ return pack "Q", shift;
+}
+
+sub B::Asmdata::PUT_IV {
+ $Config{ivsize} == 4 ? &B::Asmdata::PUT_I32 : &B::Asmdata::PUT_IV64;
+}
+
+sub B::Asmdata::PUT_PADOFFSET {
+ $Config{ptrsize} == 8 ? &B::Asmdata::PUT_IV64 : &B::Asmdata::PUT_U32;
+}
+
+sub B::Asmdata::PUT_long {
+ $Config{longsize} == 8 ? &B::Asmdata::PUT_IV64 : &B::Asmdata::PUT_U32;
+}
+
+sub B::Asmdata::PUT_svtype {
+ $Config{longsize} == 8 ? &B::Asmdata::PUT_IV64 : &B::Asmdata::PUT_U32;
+}
+
+my %unesc = (n => "\n", r => "\r", t => "\t", a => "\a",
+ b => "\b", f => "\f", v => "\013");
+
+sub uncstring {
+ my $s = shift;
+ $s =~ s/^"// and $s =~ s/"$// or return undef;
+ $s =~ s/\\(\d\d\d|.)/length($1) == 3 ? chr(oct($1)) : ($unesc{$1}||$1)/eg;
+ return $s;
+}
+
+sub strip_comments {
+ my $stmt = shift;
+ # Comments only allowed in instructions which don't take string arguments
+ # Treat string as a single line so .* eats \n characters.
+ $stmt =~ s{
+ ^\s* # Ignore leading whitespace
+ (
+ [^"]* # A double quote '"' indicates a string argument. If we
+ # find a double quote, the match fails and we strip nothing.
+ )
+ \s*\# # Any amount of whitespace plus the comment marker...
+ .*$ # ...which carries on to end-of-string.
+ }{$1}sx; # Keep only the instruction and optional argument.
+ return $stmt;
+}
+
+# create the ByteCode header: magic, archname, ByteLoader $VERSION, ivsize,
+# ptrsize, byteorder
+# nvtype is irrelevant (floats are stored as strings)
+# byteorder is strconst not U32 because of varying size issues
+
+sub gen_header {
+ my $header = "";
+
+ $header .= B::Asmdata::PUT_U32(0x43424c50); # 'PLBC'
+ $header .= B::Asmdata::PUT_strconst('"' . $Config{archname}. '"');
+ $header .= B::Asmdata::PUT_strconst(qq["$ByteLoader::VERSION"]);
+ $header .= B::Asmdata::PUT_U32($Config{ivsize});
+ $header .= B::Asmdata::PUT_U32($Config{ptrsize});
+ $header .= B::Asmdata::PUT_strconst('"'.$Config{byteorder}.'"');
+ $header;
+}
+
+sub parse_statement {
+ my $stmt = shift;
+ my ($insn, $arg) = $stmt =~ m{
+ ^\s* # allow (but ignore) leading whitespace
+ (.*?) # Instruction continues up until...
+ (?: # ...an optional whitespace+argument group
+ \s+ # first whitespace.
+ (.*) # The argument is all the rest (newlines included).
+ )?$ # anchor at end-of-line
+ }sx;
+ if (defined($arg)) {
+ if ($arg =~ s/^0x(?=[0-9a-fA-F]+$)//) {
+ $arg = hex($arg);
+ } elsif ($arg =~ s/^0(?=[0-7]+$)//) {
+ $arg = oct($arg);
+ } elsif ($arg =~ /^pp_/) {
+ $arg =~ s/\s*$//; # strip trailing whitespace
+ my $opnum = $opnumber{$arg};
+ if (defined($opnum)) {
+ $arg = $opnum;
+ } else {
+ error qq(No such op type "$arg");
+ $arg = 0;
+ }
+ }
+ }
+ return ($insn, $arg);
+}
+
+sub assemble_insn {
+ my ($insn, $arg) = @_;
+ my $data = $insn_data{$insn};
+ if (defined($data)) {
+ my ($bytecode, $putsub) = @{$data}[0, 1];
+ my $argcode = &$putsub($arg);
+ return chr($bytecode).$argcode;
+ } else {
+ error qq(no such instruction "$insn");
+ return "";
+ }
+}
+
+sub assemble_fh {
+ my ($fh, $out) = @_;
+ my $line;
+ my $asm = newasm($out);
+ while ($line = <$fh>) {
+ assemble($line);
+ }
+ endasm();
+}
+
+sub newasm {
+ my($outsub) = @_;
+
+ die "Invalid printing routine for B::Assembler\n" unless ref $outsub eq 'CODE';
+ die <<EOD if ref $out;
+Can't have multiple byteassembly sessions at once!
+ (perhaps you forgot an endasm()?)
+EOD
+
+ $linenum = $errors = 0;
+ $out = $outsub;
+
+ $out->(gen_header());
+}
+
+sub endasm {
+ if ($errors) {
+ die "There were $errors assembly errors\n";
+ }
+ $linenum = $errors = $out = 0;
+}
+
+sub assemble {
+ my($line) = @_;
+ my ($insn, $arg);
+ $linenum++;
+ chomp $line;
+ if ($debug) {
+ my $quotedline = $line;
+ $quotedline =~ s/\\/\\\\/g;
+ $quotedline =~ s/"/\\"/g;
+ $out->(assemble_insn("comment", qq("$quotedline")));
+ }
+ if( $line = strip_comments($line) ){
+ ($insn, $arg) = parse_statement($line);
+ $out->(assemble_insn($insn, $arg));
+ if ($debug) {
+ $out->(assemble_insn("nop", undef));
+ }
+ }
+}
+
+### temporary workaround
+
+sub asm {
+ return if $_[0] =~ /\s*\W/;
+ if (defined $_[1]) {
+ return if $_[1] eq "0" and
+ $_[0] !~ /^(?:newsvx?|av_pushx?|av_extend|xav_flags)$/;
+ return if $_[1] eq "1" and $_[0] =~ /^(?:sv_refcnt)$/;
+ }
+ assemble "@_";
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+B::Assembler - Assemble Perl bytecode
+
+=head1 SYNOPSIS
+
+ use B::Assembler qw(newasm endasm assemble);
+ newasm(\&printsub); # sets up for assembly
+ assemble($buf); # assembles one line
+ endasm(); # closes down
+
+ use B::Assembler qw(assemble_fh);
+ assemble_fh($fh, \&printsub); # assemble everything in $fh
+
+=head1 DESCRIPTION
+
+See F<ext/B/B/Assembler.pm>.
+
+=head1 AUTHORS
+
+Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
+Per-statement interface by Benjamin Stuhl, C<sho_pi@hotmail.com>
+
+=cut
View
225 B/Bblock.pm
@@ -0,0 +1,225 @@
+package B::Bblock;
+
+our $VERSION = '1.02_01';
+
+use Exporter ();
+@ISA = "Exporter";
+@EXPORT_OK = qw(find_leaders);
+
+use B qw(peekop walkoptree walkoptree_exec
+ main_root main_start svref_2object
+ OPf_SPECIAL OPf_STACKED );
+
+use B::Concise qw(concise_cv concise_main set_style_standard);
+use strict;
+
+my $bblock;
+my @bblock_ends;
+
+sub mark_leader {
+ my $op = shift;
+ if ($$op) {
+ $bblock->{$$op} = $op;
+ }
+}
+
+sub remove_sortblock{
+ foreach (keys %$bblock){
+ my $leader=$$bblock{$_};
+ delete $$bblock{$_} if( $leader == 0);
+ }
+}
+sub find_leaders {
+ my ($root, $start) = @_;
+ $bblock = {};
+ mark_leader($start) if ( ref $start ne "B::NULL" );
+ walkoptree($root, "mark_if_leader") if ((ref $root) ne "B::NULL") ;
+ remove_sortblock();
+ return $bblock;
+}
+
+# Debugging
+sub walk_bblocks {
+ my ($root, $start) = @_;
+ my ($op, $lastop, $leader, $bb);
+ $bblock = {};
+ mark_leader($start);
+ walkoptree($root, "mark_if_leader");
+ my @leaders = values %$bblock;
+ while ($leader = shift @leaders) {
+ $lastop = $leader;
+ $op = $leader->next;
+ while ($$op && !exists($bblock->{$$op})) {
+ $bblock->{$$op} = $leader;
+ $lastop = $op;
+ $op = $op->next;
+ }
+ push(@bblock_ends, [$leader, $lastop]);
+ }
+ foreach $bb (@bblock_ends) {
+ ($leader, $lastop) = @$bb;
+ printf "%s .. %s\n", peekop($leader), peekop($lastop);
+ for ($op = $leader; $$op != $$lastop; $op = $op->next) {
+ printf " %s\n", peekop($op);
+ }
+ printf " %s\n", peekop($lastop);
+ }
+}
+
+sub walk_bblocks_obj {
+ my $cvref = shift;
+ my $cv = svref_2object($cvref);
+ walk_bblocks($cv->ROOT, $cv->START);
+}
+
+sub B::OP::mark_if_leader {}
+
+sub B::COP::mark_if_leader {
+ my $op = shift;
+ if ($op->label) {
+ mark_leader($op);
+ }
+}
+
+sub B::LOOP::mark_if_leader {
+ my $op = shift;
+ mark_leader($op->next);
+ mark_leader($op->nextop);
+ mark_leader($op->redoop);
+ mark_leader($op->lastop->next);
+}
+
+sub B::LOGOP::mark_if_leader {
+ my $op = shift;
+ my $opname = $op->name;
+ mark_leader($op->next);
+ if ($opname eq "entertry") {
+ mark_leader($op->other->next);
+ } else {
+ mark_leader($op->other);
+ }
+}
+
+sub B::LISTOP::mark_if_leader {
+ my $op = shift;
+ my $first=$op->first;
+ $first=$first->next while ($first->name eq "null");
+ mark_leader($op->first) unless (exists( $bblock->{$$first}));
+ mark_leader($op->next);
+ if ($op->name eq "sort" and $op->flags & OPf_SPECIAL
+ and $op->flags & OPf_STACKED){
+ my $root=$op->first->sibling->first;
+ my $leader=$root->first;
+ $bblock->{$$leader} = 0;
+ }
+}
+
+sub B::PMOP::mark_if_leader {
+ my $op = shift;
+ if ($op->name ne "pushre") {
+ my $replroot = $op->pmreplroot;
+ if ($$replroot) {
+ mark_leader($replroot);
+ mark_leader($op->next);
+ mark_leader($op->pmreplstart);
+ }
+ }
+}
+
+# PMOP stuff omitted
+
+sub compile {
+ my @options = @_;
+ B::clearsym();
+ if (@options) {
+ return sub {
+ my $objname;
+ foreach $objname (@options) {
+ $objname = "main::$objname" unless $objname =~ /::/;
+ eval "walk_bblocks_obj(\\&$objname)";
+ die "walk_bblocks_obj(\\&$objname) failed: $@" if $@;
+ print "-------\n";
+ set_style_standard("terse");
+ eval "concise_cv('exec', \\&$objname)";
+ die "concise_cv('exec', \\&$objname) failed: $@" if $@;
+ }
+ }
+ } else {
+ return sub {
+ walk_bblocks(main_root, main_start);
+ print "-------\n";
+ set_style_standard("terse");
+ concise_main("exec");
+ };
+ }
+}
+
+# Basic block leaders:
+# Any COP (pp_nextstate) with a non-NULL label
+# [The op after a pp_enter] Omit
+# [The op after a pp_entersub. Don't count this one.]
+# The ops pointed at by nextop, redoop and lastop->op_next of a LOOP
+# The ops pointed at by op_next and op_other of a LOGOP, except
+# for pp_entertry which has op_next and op_other->op_next
+# The op pointed at by op_pmreplstart of a PMOP
+# The op pointed at by op_other->op_pmreplstart of pp_substcont?
+# [The op after a pp_return] Omit
+
+1;
+
+__END__
+
+=head1 NAME
+
+B::Bblock - Walk basic blocks
+
+=head1 SYNOPSIS
+
+ # External interface
+ perl -MO=Bblock[,OPTIONS] foo.pl
+
+ # Programmatic API
+ use B::Bblock qw(find_leaders);
+ my $leaders = find_leaders($root_op, $start_op);
+
+=head1 DESCRIPTION
+
+This module is used by the B::CC back end. It walks "basic blocks".
+A basic block is a series of operations which is known to execute from
+start to finish, with no possibility of branching or halting.
+
+It can be used either stand alone or from inside another program.
+
+=for _private
+Somebody who understands the stand-alone options document them, please.
+
+=head2 Functions
+
+=over 4
+
+=item B<find_leaders>
+
+ my $leaders = find_leaders($root_op, $start_op);
+
+Given the root of the op tree and an op from which to start
+processing, it will return a hash ref representing all the ops which
+start a block.
+
+=for _private
+The above description may be somewhat wrong.
+
+The values of %$leaders are the op objects themselves. Keys are $$op
+addresses.
+
+=for _private
+Above cribbed from B::CC's comments. What's a $$op address?
+A: See http://books.simon-cozens.org/index.php/Perl_5_Internals#Using_B_for_Simple_Things
+
+=back
+
+
+=head1 AUTHOR
+
+Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
+
+=cut
View
904 B/Bytecode.pm
@@ -0,0 +1,904 @@
+# B::Bytecode.pm
+# Copyright (c) 2003 Enache Adrian. All rights reserved.
+# This module is free software; you can redistribute and/or modify
+# it under the same terms as Perl itself.
+
+# Based on the original Bytecode.pm module written by Malcolm Beattie.
+
+package B::Bytecode;
+
+our $VERSION = '1.02_02';
+
+use strict;
+use Config;
+use B qw(class main_cv main_root main_start cstring comppadlist
+ defstash curstash begin_av init_av end_av inc_gv warnhook diehook
+ dowarn SVt_PVGV SVt_PVHV OPf_SPECIAL OPf_STACKED OPf_MOD
+ OPpLVAL_INTRO SVf_FAKE SVf_READONLY);
+use B::Asmdata qw(@specialsv_name);
+use B::Assembler qw(asm newasm endasm);
+
+#################################################
+
+my ($varix, $opix, $savebegins, %walked, %files, @cloop);
+my %strtab = (0,0);
+my %svtab = (0,0);
+my %optab = (0,0);
+my %spectab = (0,0);
+my $tix = 1;
+sub asm;
+sub nice ($) { }
+
+BEGIN {
+ my $ithreads = $Config{'useithreads'} eq 'define';
+ eval qq{
+ sub ITHREADS() { $ithreads }
+ sub VERSION() { $] }
+ }; die $@ if $@;
+}
+
+#################################################
+
+sub pvstring {
+ my $pv = shift;
+ defined($pv) ? cstring ($pv."\0") : "\"\"";
+}
+
+sub pvix {
+ my $str = pvstring shift;
+ my $ix = $strtab{$str};
+ defined($ix) ? $ix : do {
+ asm "newpv", $str;
+ asm "stpv", $strtab{$str} = $tix;
+ $tix++;
+ }
+}
+
+sub B::OP::ix {
+ my $op = shift;
+ my $ix = $optab{$$op};
+ defined($ix) ? $ix : do {
+ nice "[".$op->name." $tix]";
+ asm "newopx", $op->size | $op->type <<7;
+ $optab{$$op} = $opix = $ix = $tix++;
+ $op->bsave($ix);
+ $ix;
+ }
+}
+
+sub B::SPECIAL::ix {
+ my $spec = shift;
+ my $ix = $spectab{$$spec};
+ defined($ix) ? $ix : do {
+ nice '['.$specialsv_name[$$spec].']';
+ asm "ldspecsvx", $$spec;
+ $spectab{$$spec} = $varix = $tix++;
+ }
+}
+
+sub B::SV::ix {
+ my $sv = shift;
+ my $ix = $svtab{$$sv};
+ defined($ix) ? $ix : do {
+ nice '['.class($sv).']';
+ asm "newsvx", $sv->FLAGS;
+ $svtab{$$sv} = $varix = $ix = $tix++;
+ $sv->bsave($ix);
+ $ix;
+ }
+}
+
+sub B::GV::ix {
+ my ($gv,$desired) = @_;
+ my $ix = $svtab{$$gv};
+ defined($ix) ? $ix : do {
+ if ($gv->GP) {
+ my ($svix, $avix, $hvix, $cvix, $ioix, $formix);
+ nice "[GV]";
+ my $name = $gv->STASH->NAME . "::" . $gv->NAME;
+ asm "gv_fetchpvx", cstring $name;
+ $svtab{$$gv} = $varix = $ix = $tix++;
+ asm "sv_flags", $gv->FLAGS;
+ asm "sv_refcnt", $gv->REFCNT;
+ asm "xgv_flags", $gv->GvFLAGS;
+
+ asm "gp_refcnt", $gv->GvREFCNT;
+ asm "load_glob", $ix if $name eq "CORE::GLOBAL::glob";
+ return $ix
+ unless $desired || desired $gv;
+ $svix = $gv->SV->ix;
+ $avix = $gv->AV->ix;
+ $hvix = $gv->HV->ix;
+
+ # XXX {{{{
+ my $cv = $gv->CV;
+ $cvix = $$cv && defined $files{$cv->FILE} ? $cv->ix : 0;
+ my $form = $gv->FORM;
+ $formix = $$form && defined $files{$form->FILE} ? $form->ix : 0;
+
+ $ioix = $name !~ /STDOUT$/ ? $gv->IO->ix : 0;
+ # }}}} XXX
+
+ nice "-GV-",
+ asm "ldsv", $varix = $ix unless $ix == $varix;
+ asm "gp_sv", $svix;
+ asm "gp_av", $avix;
+ asm "gp_hv", $hvix;
+ asm "gp_cv", $cvix;
+ asm "gp_io", $ioix;
+ asm "gp_cvgen", $gv->CVGEN;
+ asm "gp_form", $formix;
+ asm "gp_file", pvix $gv->FILE;
+ asm "gp_line", $gv->LINE;
+ asm "formfeed", $svix if $name eq "main::\cL";
+ } else {
+ nice "[GV]";
+ asm "newsvx", $gv->FLAGS;
+ $svtab{$$gv} = $varix = $ix = $tix++;
+ my $stashix = $gv->STASH->ix;
+ $gv->B::PVMG::bsave($ix);
+ asm "xgv_flags", $gv->GvFLAGS;
+ asm "xgv_stash", $stashix;
+ }
+ $ix;
+ }
+}
+
+sub B::HV::ix {
+ my $hv = shift;
+ my $ix = $svtab{$$hv};
+ defined($ix) ? $ix : do {
+ my ($ix,$i,@array);
+ my $name = $hv->NAME;
+ if ($name) {
+ nice "[STASH]";
+ asm "gv_stashpvx", cstring $name;
+ asm "sv_flags", $hv->FLAGS;
+ $svtab{$$hv} = $varix = $ix = $tix++;
+ asm "xhv_name", pvix $name;
+ # my $pmrootix = $hv->PMROOT->ix; # XXX
+ asm "ldsv", $varix = $ix unless $ix == $varix;
+ # asm "xhv_pmroot", $pmrootix; # XXX
+ } else {
+ nice "[HV]";
+ asm "newsvx", $hv->FLAGS;
+ $svtab{$$hv} = $varix = $ix = $tix++;
+ my $stashix = $hv->SvSTASH->ix;
+ for (@array = $hv->ARRAY) {
+ next if $i = not $i;
+ $_ = $_->ix;
+ }
+ nice "-HV-",
+ asm "ldsv", $varix = $ix unless $ix == $varix;
+ ($i = not $i) ? asm ("newpv", pvstring $_) : asm("hv_store", $_)
+ for @array;
+ if (VERSION < 5.009) {
+ asm "xnv", $hv->NVX;
+ }
+ asm "xmg_stash", $stashix;
+ asm("xhv_riter", $hv->RITER) if VERSION < 5.009;
+ }
+ asm "sv_refcnt", $hv->REFCNT;
+ $ix;
+ }
+}
+
+sub B::NULL::ix {
+ my $sv = shift;
+ $$sv ? $sv->B::SV::ix : 0;
+}
+
+sub B::NULL::opwalk { 0 }
+
+#################################################
+
+sub B::NULL::bsave {
+ my ($sv,$ix) = @_;
+
+ nice '-'.class($sv).'-',
+ asm "ldsv", $varix = $ix unless $ix == $varix;
+ asm "sv_refcnt", $sv->REFCNT;
+}
+
+sub B::SV::bsave;
+ *B::SV::bsave = *B::NULL::bsave;
+
+sub B::RV::bsave {
+ my ($sv,$ix) = @_;
+ my $rvix = $sv->RV->ix;
+ $sv->B::NULL::bsave($ix);
+ asm "xrv", $rvix;
+}
+
+sub B::PV::bsave {
+ my ($sv,$ix) = @_;
+ $sv->B::NULL::bsave($ix);
+ asm "newpv", pvstring $sv->PVBM;
+ asm "xpv";
+}
+
+sub B::IV::bsave {
+ my ($sv,$ix) = @_;
+ $sv->B::NULL::bsave($ix);
+ asm "xiv", $sv->IVX;
+}
+
+sub B::NV::bsave {
+ my ($sv,$ix) = @_;
+ $sv->B::NULL::bsave($ix);
+ asm "xnv", sprintf "%.40g", $sv->NVX;
+}
+
+sub B::PVIV::bsave {
+ my ($sv,$ix) = @_;
+ $sv->POK ?
+ $sv->B::PV::bsave($ix):
+ $sv->ROK ?
+ $sv->B::RV::bsave($ix):
+ $sv->B::NULL::bsave($ix);
+ if (VERSION >= 5.009) {
+ # See note below in B::PVNV::bsave
+ return if $sv->isa('B::AV');
+ return if $sv->isa('B::HV');
+ return if $sv->isa('B::CV');
+ }
+ asm "xiv", !ITHREADS && $sv->FLAGS & (SVf_FAKE|SVf_READONLY) ?
+ "0 but true" : $sv->IVX;
+}
+
+sub B::PVNV::bsave {
+ my ($sv,$ix) = @_;
+ $sv->B::PVIV::bsave($ix);
+ if (VERSION >= 5.009) {
+ # Magical AVs end up here, but AVs now don't have an NV slot actually
+ # allocated. Hence don't write out assembly to store the NV slot if
+ # we're actually an array.
+ return if $sv->isa('B::AV');
+ # Likewise HVs have no NV slot actually allocated.
+ # I don't think that they can get here, but better safe than sorry
+ return if $sv->isa('B::HV');
+ return if $sv->isa('B::CV');
+ return if $sv->isa('B::FM');
+ }
+ asm "xnv", sprintf "%.40g", $sv->NVX;
+}
+
+sub B::PVMG::domagic {
+ my ($sv,$ix) = @_;
+ nice '-MAGICAL-';
+ my @mglist = $sv->MAGIC;
+ my (@mgix, @namix);
+ for (@mglist) {
+ push @mgix, $_->OBJ->ix;
+ push @namix, $_->PTR->ix if $_->LENGTH == B::HEf_SVKEY;
+ }
+
+ nice '-'.class($sv).'-',
+ asm "ldsv", $varix = $ix unless $ix == $varix;
+ for (@mglist) {
+ asm "sv_magic", cstring $_->TYPE;
+ asm "mg_obj", shift @mgix;
+ my $length = $_->LENGTH;
+ if ($length == B::HEf_SVKEY) {
+ asm "mg_namex", shift @namix;
+ } elsif ($length) {
+ asm "newpv", pvstring $_->PTR;
+ asm "mg_name";
+ }
+ }
+}
+
+sub B::PVMG::bsave {
+ my ($sv,$ix) = @_;
+ my $stashix = $sv->SvSTASH->ix;
+ $sv->B::PVNV::bsave($ix);
+ asm "xmg_stash", $stashix;
+ $sv->domagic($ix) if $sv->MAGICAL;
+}
+
+sub B::PVLV::bsave {
+ my ($sv,$ix) = @_;
+ my $targix = $sv->TARG->ix;
+ $sv->B::PVMG::bsave($ix);
+ asm "xlv_targ", $targix;
+ asm "xlv_targoff", $sv->TARGOFF;
+ asm "xlv_targlen", $sv->TARGLEN;
+ asm "xlv_type", $sv->TYPE;
+
+}
+
+sub B::BM::bsave {
+ my ($sv,$ix) = @_;
+ $sv->B::PVMG::bsave($ix);
+ asm "xpv_cur", $sv->CUR;
+ asm "xbm_useful", $sv->USEFUL;
+ asm "xbm_previous", $sv->PREVIOUS;
+ asm "xbm_rare", $sv->RARE;
+}
+
+sub B::IO::bsave {
+ my ($io,$ix) = @_;
+ my $topix = $io->TOP_GV->ix;
+ my $fmtix = $io->FMT_GV->ix;
+ my $bottomix = $io->BOTTOM_GV->ix;
+ $io->B::PVMG::bsave($ix);
+ asm "xio_lines", $io->LINES;
+ asm "xio_page", $io->PAGE;
+ asm "xio_page_len", $io->PAGE_LEN;
+ asm "xio_lines_left", $io->LINES_LEFT;
+ asm "xio_top_name", pvix $io->TOP_NAME;
+ asm "xio_top_gv", $topix;
+ asm "xio_fmt_name", pvix $io->FMT_NAME;
+ asm "xio_fmt_gv", $fmtix;
+ asm "xio_bottom_name", pvix $io->BOTTOM_NAME;
+ asm "xio_bottom_gv", $bottomix;
+ asm "xio_subprocess", $io->SUBPROCESS;
+ asm "xio_type", ord $io->IoTYPE;
+ # asm "xio_flags", ord($io->IoFLAGS) & ~32; # XXX XXX
+}
+
+sub B::CV::bsave {
+ my ($cv,$ix) = @_;
+ my $stashix = $cv->STASH->ix;
+ my $gvix = $cv->GV->ix;
+ my $padlistix = $cv->PADLIST->ix;
+ my $outsideix = $cv->OUTSIDE->ix;
+ my $constix = $cv->CONST ? $cv->XSUBANY->ix : 0;
+ my $startix = $cv->START->opwalk;
+ my $rootix = $cv->ROOT->ix;
+
+ $cv->B::PVMG::bsave($ix);
+ asm "xcv_stash", $stashix;
+ asm "xcv_start", $startix;
+ asm "xcv_root", $rootix;
+ asm "xcv_xsubany", $constix;
+ asm "xcv_gv", $gvix;
+ asm "xcv_file", pvix $cv->FILE if $cv->FILE; # XXX AD
+ asm "xcv_padlist", $padlistix;
+ asm "xcv_outside", $outsideix;
+ asm "xcv_flags", $cv->CvFLAGS;
+ asm "xcv_outside_seq", $cv->OUTSIDE_SEQ;
+ asm "xcv_depth", $cv->DEPTH;
+}
+
+sub B::FM::bsave {
+ my ($form,$ix) = @_;
+
+ $form->B::CV::bsave($ix);
+ asm "xfm_lines", $form->LINES;
+}
+
+sub B::AV::bsave {
+ my ($av,$ix) = @_;
+ return $av->B::PVMG::bsave($ix) if $av->MAGICAL;
+ my @array = $av->ARRAY;
+ $_ = $_->ix for @array;
+ my $stashix = $av->SvSTASH->ix;
+
+ nice "-AV-",
+ asm "ldsv", $varix = $ix unless $ix == $varix;
+ asm "av_extend", $av->MAX if $av->MAX >= 0;
+ asm "av_pushx", $_ for @array;
+ asm "sv_refcnt", $av->REFCNT;
+ if (VERSION < 5.009) {
+ asm "xav_flags", $av->AvFLAGS;
+ }
+ asm "xmg_stash", $stashix;
+}
+
+sub B::GV::desired {
+ my $gv = shift;
+ my ($cv, $form);
+ $files{$gv->FILE} && $gv->LINE
+ || ${$cv = $gv->CV} && $files{$cv->FILE}
+ || ${$form = $gv->FORM} && $files{$form->FILE}
+}
+
+sub B::HV::bwalk {
+ my $hv = shift;
+ return if $walked{$$hv}++;
+ my %stash = $hv->ARRAY;
+ while (my($k,$v) = each %stash) {
+ if ($v->SvTYPE == SVt_PVGV) {
+ my $hash = $v->HV;
+ if ($$hash && $hash->NAME) {
+ $hash->bwalk;
+ }
+ $v->ix(1) if desired $v;
+ } else {
+ nice "[prototype]";
+ asm "gv_fetchpvx", cstring $hv->NAME . "::$k";
+ $svtab{$$v} = $varix = $tix;
+ $v->bsave($tix++);
+ asm "sv_flags", $v->FLAGS;
+ }
+ }
+}
+
+######################################################
+
+
+sub B::OP::bsave_thin {
+ my ($op, $ix) = @_;
+ my $next = $op->next;
+ my $nextix = $optab{$$next};
+ $nextix = 0, push @cloop, $op unless defined $nextix;
+ if ($ix != $opix) {
+ nice '-'.$op->name.'-',
+ asm "ldop", $opix = $ix;
+ }
+ asm "op_next", $nextix;
+ asm "op_targ", $op->targ if $op->type; # tricky
+ asm "op_flags", $op->flags;
+ asm "op_private", $op->private;
+}
+
+sub B::OP::bsave;
+ *B::OP::bsave = *B::OP::bsave_thin;
+
+sub B::UNOP::bsave {
+ my ($op, $ix) = @_;
+ my $name = $op->name;
+ my $flags = $op->flags;
+ my $first = $op->first;
+ my $firstix =
+ $name =~ /fl[io]p/
+ # that's just neat
+ || (!ITHREADS && $name eq 'regcomp')
+ # trick for /$a/o in pp_regcomp
+ || $name eq 'rv2sv'
+ && $op->flags & OPf_MOD
+ && $op->private & OPpLVAL_INTRO
+ # change #18774 made my life hard
+ ? $first->ix
+ : 0;
+
+ $op->B::OP::bsave($ix);
+ asm "op_first", $firstix;
+}
+
+sub B::BINOP::bsave {
+ my ($op, $ix) = @_;
+ if ($op->name eq 'aassign' && $op->private & B::OPpASSIGN_HASH()) {
+ my $last = $op->last;
+ my $lastix = do {
+ local *B::OP::bsave = *B::OP::bsave_fat;
+ local *B::UNOP::bsave = *B::UNOP::bsave_fat;
+ $last->ix;
+ };
+ asm "ldop", $lastix unless $lastix == $opix;
+ asm "op_targ", $last->targ;
+ $op->B::OP::bsave($ix);
+ asm "op_last", $lastix;
+ } else {
+ $op->B::OP::bsave($ix);
+ }
+}
+
+# not needed if no pseudohashes
+
+*B::BINOP::bsave = *B::OP::bsave if VERSION >= 5.009;
+
+# deal with sort / formline
+
+sub B::LISTOP::bsave {
+ my ($op, $ix) = @_;
+ my $name = $op->name;
+ sub blocksort() { OPf_SPECIAL|OPf_STACKED }
+ if ($name eq 'sort' && ($op->flags & blocksort) == blocksort) {
+ my $first = $op->first;
+ my $pushmark = $first->sibling;
+ my $rvgv = $pushmark->first;
+ my $leave = $rvgv->first;
+
+ my $leaveix = $leave->ix;
+
+ my $rvgvix = $rvgv->ix;
+ asm "ldop", $rvgvix unless $rvgvix == $opix;
+ asm "op_first", $leaveix;
+
+ my $pushmarkix = $pushmark->ix;
+ asm "ldop", $pushmarkix unless $pushmarkix == $opix;
+ asm "op_first", $rvgvix;
+
+ my $firstix = $first->ix;
+ asm "ldop", $firstix unless $firstix == $opix;
+ asm "op_sibling", $pushmarkix;
+
+ $op->B::OP::bsave($ix);
+ asm "op_first", $firstix;
+ } elsif ($name eq 'formline') {
+ $op->B::UNOP::bsave_fat($ix);
+ } else {
+ $op->B::OP::bsave($ix);
+ }
+}
+
+# fat versions
+
+sub B::OP::bsave_fat {
+ my ($op, $ix) = @_;
+ my $siblix = $op->sibling->ix;
+
+ $op->B::OP::bsave_thin($ix);
+ asm "op_sibling", $siblix;
+ # asm "op_seq", -1; XXX don't allocate OPs piece by piece
+}
+
+sub B::UNOP::bsave_fat {
+ my ($op,$ix) = @_;
+ my $firstix = $op->first->ix;
+
+ $op->B::OP::bsave($ix);
+ asm "op_first", $firstix;
+}
+
+sub B::BINOP::bsave_fat {
+ my ($op,$ix) = @_;
+ my $last = $op->last;
+ my $lastix = $op->last->ix;
+ if (VERSION < 5.009 && $op->name eq 'aassign' && $last->name eq 'null') {
+ asm "ldop", $lastix unless $lastix == $opix;
+ asm "op_targ", $last->targ;
+ }
+
+ $op->B::UNOP::bsave($ix);
+ asm "op_last", $lastix;
+}
+
+sub B::LOGOP::bsave {
+ my ($op,$ix) = @_;
+ my $otherix = $op->other->ix;
+
+ $op->B::UNOP::bsave($ix);
+ asm "op_other", $otherix;
+}
+
+sub B::PMOP::bsave {
+ my ($op,$ix) = @_;
+ my ($rrop, $rrarg, $rstart);
+
+ # my $pmnextix = $op->pmnext->ix; # XXX
+
+ if (ITHREADS) {
+ if ($op->name eq 'subst') {
+ $rrop = "op_pmreplroot";
+ $rrarg = $op->pmreplroot->ix;
+ $rstart = $op->pmreplstart->ix;
+ } elsif ($op->name eq 'pushre') {
+ $rrop = "op_pmreplrootpo";
+ $rrarg = $op->pmreplroot;
+ }
+ $op->B::BINOP::bsave($ix);
+ asm "op_pmstashpv", pvix $op->pmstashpv;
+ } else {
+ $rrop = "op_pmreplrootgv";
+ $rrarg = $op->pmreplroot->ix;
+ $rstart = $op->pmreplstart->ix if $op->name eq 'subst';
+ my $stashix = $op->pmstash->ix;
+ $op->B::BINOP::bsave($ix);
+ asm "op_pmstash", $stashix;
+ }
+
+ asm $rrop, $rrarg if $rrop;
+ asm "op_pmreplstart", $rstart if $rstart;
+
+ asm "op_pmflags", $op->pmflags;
+ if ( VERSION < 5.009 ) {
+ asm "op_pmpermflags", $op->pmpermflags;
+ asm "op_pmdynflags", $op->pmdynflags;
+ # asm "op_pmnext", $pmnextix; # XXX
+ asm "newpv", pvstring $op->precomp;
+ asm "pregcomp";
+ } else {
+ # FIXME: add flags to sv
+ asm "pregcomp", pvix $op->precomp;
+ }
+}
+
+sub B::SVOP::bsave {
+ my ($op,$ix) = @_;
+ my $svix = $op->sv->ix;
+
+ $op->B::OP::bsave($ix);
+ asm "op_sv", $svix;
+}
+
+sub B::PADOP::bsave {
+ my ($op,$ix) = @_;
+
+ $op->B::OP::bsave($ix);
+ asm "op_padix", $op->padix;
+}
+
+sub B::PVOP::bsave {
+ my ($op,$ix) = @_;
+ $op->B::OP::bsave($ix);
+ return unless my $pv = $op->pv;
+
+ if ($op->name eq 'trans') {
+ asm "op_pv_tr", join ',', length($pv)/2, unpack("s*", $pv);
+ } else {
+ asm "newpv", pvstring $pv;
+ asm "op_pv";
+ }
+}
+
+sub B::LOOP::bsave {
+ my ($op,$ix) = @_;
+ my $nextix = $op->nextop->ix;
+ my $lastix = $op->lastop->ix;
+ my $redoix = $op->redoop->ix;
+
+ $op->B::BINOP::bsave($ix);
+ asm "op_redoop", $redoix;
+ asm "op_nextop", $nextix;
+ asm "op_lastop", $lastix;
+}
+
+sub B::COP::bsave {
+ my ($cop,$ix) = @_;
+ my $warnix = $cop->warnings->ix;
+ if (ITHREADS) {
+ $cop->B::OP::bsave($ix);
+ asm "cop_stashpv", pvix $cop->stashpv;
+ asm "cop_file", pvix $cop->file;
+ } else {
+ my $stashix = $cop->stash->ix;
+ my $fileix = $cop->filegv->ix(1);
+ $cop->B::OP::bsave($ix);
+ asm "cop_stash", $stashix;
+ asm "cop_filegv", $fileix;
+ }
+ asm "cop_label", pvix $cop->label if $cop->label; # XXX AD
+ asm "cop_seq", $cop->cop_seq;
+ asm "cop_arybase", $cop->arybase;
+ asm "cop_line", $cop->line;
+ asm "cop_warnings", $warnix;
+ if (VERSION < 5.009) {
+ my $ioix = $cop->io->ix;
+ asm "cop_io", $ioix;
+ }
+}
+
+sub B::OP::opwalk {
+ my $op = shift;
+ my $ix = $optab{$$op};
+ defined($ix) ? $ix : do {
+ my $ix;
+ my @oplist = $op->oplist;
+ push @cloop, undef;
+ $ix = $_->ix while $_ = pop @oplist;
+ while ($_ = pop @cloop) {
+ asm "ldop", $optab{$$_};
+ asm "op_next", $optab{${$_->next}};
+ }
+ $ix;
+ }
+}
+
+#################################################
+
+sub save_cq {
+ my $av;
+ if (($av=begin_av)->isa("B::AV")) {
+ if ($savebegins) {
+ for ($av->ARRAY) {
+ next unless $_->FILE eq $0;
+ asm "push_begin", $_->ix;
+ }
+ } else {
+ for ($av->ARRAY) {
+ next unless $_->FILE eq $0;
+ # XXX BEGIN { goto A while 1; A: }
+ for (my $op = $_->START; $$op; $op = $op->next) {
+ next unless $op->name eq 'require' ||
+ # this kludge needed for tests
+ $op->name eq 'gv' && do {
+ my $gv = class($op) eq 'SVOP' ?
+ $op->gv :
+ (($_->PADLIST->ARRAY)[1]->ARRAY)[$op->padix];
+ $$gv && $gv->NAME =~ /use_ok|plan/
+ };
+ asm "push_begin", $_->ix;
+ last;
+ }
+ }
+ }
+ }
+ if (($av=init_av)->isa("B::AV")) {
+ for ($av->ARRAY) {
+ next unless $_->FILE eq $0;
+ asm "push_init", $_->ix;
+ }
+ }
+ if (($av=end_av)->isa("B::AV")) {
+ for ($av->ARRAY) {
+ next unless $_->FILE eq $0;
+ asm "push_end", $_->ix;
+ }
+ }
+}
+
+sub compile {
+ my ($head, $scan, $T_inhinc, $keep_syn);
+ my $cwd = '';
+ $files{$0} = 1;
+ sub keep_syn {
+ $keep_syn = 1;
+ *B::OP::bsave = *B::OP::bsave_fat;
+ *B::UNOP::bsave = *B::UNOP::bsave_fat;
+ *B::BINOP::bsave = *B::BINOP::bsave_fat;
+ *B::LISTOP::bsave = *B::LISTOP::bsave_fat;
+ }
+ sub bwarn { print STDERR "Bytecode.pm: @_\n" }
+
+ for (@_) {
+ if (/^-S/) {
+ *newasm = *endasm = sub { };
+ *asm = sub { print " @_\n" };
+ *nice = sub ($) { print "\n@_\n" };
+ } elsif (/^-H/) {
+ require ByteLoader;
+ $head = "#! $^X
+use ByteLoader $ByteLoader::VERSION;
+";
+ #FIXME!
+ undef $head;
+ } elsif (/^-k/) {
+ keep_syn;
+ } elsif (/^-o(.*)$/) {
+ open STDOUT, ">$1" or die "open $1: $!";
+ } elsif (/^-f(.*)$/) {
+ $files{$1} = 1;
+ } elsif (/^-s(.*)$/) {
+ $scan = length($1) ? $1 : $0;
+ } elsif (/^-b/) {
+ $savebegins = 1;
+ # this is here for the testsuite
+ } elsif (/^-TI/) {
+ $T_inhinc = 1;
+ } elsif (/^-TF(.*)/) {
+ my $thatfile = $1;
+ *B::COP::file = sub { $thatfile };
+ } else {
+ bwarn "Ignoring '$_' option";
+ }
+ }
+ if ($scan) {
+ my $f;
+ if (open $f, $scan) {
+ while (<$f>) {
+ /^#\s*line\s+\d+\s+("?)(.*)\1/ and $files{$2} = 1;
+ /^#/ and next;
+ if (/\bgoto\b\s*[^&]/ && !$keep_syn) {
+ bwarn "keeping the syntax tree: \"goto\" op found";
+ keep_syn;
+ }
+ }
+ } else {
+ bwarn "cannot rescan '$scan'";
+ }
+ close $f;
+ }
+ binmode STDOUT;
+ return sub {
+ print $head if $head;
+ newasm sub { print @_ };
+
+ defstash->bwalk;
+ asm "main_start", main_start->opwalk;
+ asm "main_root", main_root->ix;
+ asm "main_cv", main_cv->ix;
+ asm "curpad", (comppadlist->ARRAY)[1]->ix;
+
+ asm "signal", cstring "__WARN__" # XXX
+ if warnhook->ix;
+ asm "incav", inc_gv->AV->ix if $T_inhinc;
+ save_cq;
+ asm "incav", inc_gv->AV->ix if $T_inhinc;
+ asm "dowarn", dowarn;
+
+ {
+ no strict 'refs';
+ nice "<DATA>";
+ my $dh = *{defstash->NAME."::DATA"};
+ unless (eof $dh) {
+ local undef $/;
+ asm "data", ord 'D';
+ print <$dh>;
+ } else {
+ asm "ret";
+ }
+ }
+
+ endasm;
+ }
+}
+
+1;
+
+=head1 NAME
+
+B::Bytecode - Perl compiler's bytecode backend
+
+=head1 SYNOPSIS
+
+B<perl -MO=Bytecode>[B<,-H>][B<,-o>I<script.plc>] I<script.pl>
+
+=head1 DESCRIPTION
+
+Compiles a Perl script into a bytecode format that could be loaded
+later by the ByteLoader module and executed as a regular Perl script.
+
+=head1 EXAMPLE
+
+ $ perl -MO=Bytecode,-H,-ohi -e 'print "hi!\n"'
+ $ perl hi
+ hi!
+
+=head1 OPTIONS
+
+=over 4
+
+=item B<-b>
+
+Save all the BEGIN blocks. Normally only BEGIN blocks that C<require>
+other files (ex. C<use Foo;>) are saved.
+
+=item B<-H>
+
+prepend a C<use ByteLoader VERSION;> line to the produced bytecode.
+Does not work currently.
+
+=item B<-k>
+
+keep the syntax tree - it is stripped by default.
+
+=item B<-o>I<outfile>
+
+put the bytecode in <outfile> instead of dumping it to STDOUT.
+
+=item B<-s>
+
+scan the script for C<# line ..> directives and for <goto LABEL>
+expressions. When gotos are found keep the syntax tree.
+
+=back
+
+=head1 KNOWN BUGS
+
+=over 4
+
+=item *
+
+C<BEGIN { goto A: while 1; A: }> won't even compile.
+
+=item *
+
+C<?...?> and C<reset> do not work as expected.
+
+=item *
+
+variables in C<(?{ ... })> constructs are not properly scoped.
+
+=item *
+
+scripts that use source filters will fail miserably.
+
+=back
+
+=head1 NOTICE
+
+There are also undocumented bugs and options.
+
+THIS CODE IS HIGHLY EXPERIMENTAL. USE AT YOUR OWN RISK.
+
+=head1 AUTHORS
+
+Originally written by Malcolm Beattie <mbeattie@sable.ox.ac.uk> and
+modified by Benjamin Stuhl <sho_pi@hotmail.com>.
+
+Rewritten by Enache Adrian <enache@rdslink.ro>, 2003 a.d.
+
+=cut
View
2,236 B/C.pm
2,236 additions, 0 deletions not shown because the diff is too large. Please use a local Git client to view these changes.
View
2,005 B/CC.pm
2,005 additions, 0 deletions not shown because the diff is too large. Please use a local Git client to view these changes.
View
241 B/Disassembler.pm
@@ -0,0 +1,241 @@
+# Disassembler.pm
+#
+# Copyright (c) 1996 Malcolm Beattie
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the README file.
+
+$B::Disassembler::VERSION = '1.05_01';
+
+package B::Disassembler::BytecodeStream;
+
+use FileHandle;
+use Carp;
+use Config qw(%Config);
+use B qw(cstring cast_I32);
+@ISA = qw(FileHandle);
+sub readn {
+ my ($fh, $len) = @_;
+ my $data;
+ read($fh, $data, $len);
+ croak "reached EOF while reading $len bytes" unless length($data) == $len;
+ return $data;
+}
+
+sub GET_U8 {
+ my $fh = shift;
+ my $c = $fh->getc;
+ croak "reached EOF while reading U8" unless defined($c);
+ return ord($c);
+}
+
+sub GET_U16 {
+ my $fh = shift;
+ my $str = $fh->readn(2);
+ croak "reached EOF while reading U16" unless length($str) == 2;
+ return unpack("S", $str);
+}
+
+sub GET_NV {
+ my $fh = shift;
+ my ($str, $c);
+ while (defined($c = $fh->getc) && $c ne "\0") {
+ $str .= $c;
+ }
+ croak "reached EOF while reading double" unless defined($c);
+ return $str;
+}
+
+sub GET_U32 {
+ my $fh = shift;
+ my $str = $fh->readn(4);
+ croak "reached EOF while reading U32" unless length($str) == 4;
+ return unpack("L", $str);
+}
+
+sub GET_I32 {
+ my $fh = shift;
+ my $str = $fh->readn(4);
+ croak "reached EOF while reading I32" unless length($str) == 4;
+ return unpack("l", $str);
+}
+
+sub GET_objindex {
+ my $fh = shift;
+ my $str = $fh->readn(4);
+ croak "reached EOF while reading objindex" unless length($str) == 4;
+ return unpack("L", $str);
+}
+
+sub GET_opindex {
+ my $fh = shift;
+ my $str = $fh->readn(4);
+ croak "reached EOF while reading opindex" unless length($str) == 4;
+ return unpack("L", $str);
+}
+
+sub GET_svindex {
+ my $fh = shift;
+ my $str = $fh->readn(4);
+ croak "reached EOF while reading svindex" unless length($str) == 4;
+ return unpack("L", $str);
+}
+
+sub GET_pvindex {
+ my $fh = shift;
+ my $str = $fh->readn(4);
+ croak "reached EOF while reading pvindex" unless length($str) == 4;
+ return unpack("L", $str);
+}
+
+sub GET_hekindex {
+ my $fh = shift;
+ my $str = $fh->readn(4);
+ croak "reached EOF while reading hekindex" unless length($str) == 4;
+ return unpack("L", $str);
+}
+
+sub GET_strconst {
+ my $fh = shift;
+ my ($str, $c);
+ $str = '';
+ while (defined($c = $fh->getc) && $c ne "\0") {
+ $str .= $c;
+ }
+ croak "reached EOF while reading strconst" unless defined($c);
+ return cstring($str);
+}
+
+sub GET_pvcontents {}
+
+sub GET_PV {
+ my $fh = shift;
+ my $str;
+ my $len = $fh->GET_U32;
+ if ($len) {
+ read($fh, $str, $len);
+ croak "reached EOF while reading PV" unless length($str) == $len;
+ return cstring($str);
+ } else {
+ return '""';
+ }
+}
+
+sub GET_comment_t {
+ my $fh = shift;
+ my ($str, $c);
+ while (defined($c = $fh->getc) && $c ne "\n") {
+ $str .= $c;
+ }
+ croak "reached EOF while reading comment" unless defined($c);
+ return cstring($str);
+}
+
+sub GET_double {
+ my $fh = shift;
+ my ($str, $c);
+ while (defined($c = $fh->getc) && $c ne "\0") {
+ $str .= $c;
+ }
+ croak "reached EOF while reading double" unless defined($c);
+ return $str;
+}
+
+sub GET_none {}
+
+sub GET_op_tr_array {
+ my $fh = shift;
+ my $len = unpack "S", $fh->readn(2);
+ my @ary = unpack "S*", $fh->readn($len*2);
+ return join(",", $len, @ary);
+}
+
+sub GET_IV64 {
+ my $fh = shift;
+ my $str = $fh->readn(8);
+ croak "reached EOF while reading I32" unless length($str) == 8;
+ return sprintf "0x%09llx", unpack("q", $str);
+}
+
+sub GET_IV {
+ $Config{ivsize} == 4 ? &GET_I32 : &GET_IV64;
+}
+
+sub GET_PADOFFSET {
+ $Config{ptrsize} == 8 ? &GET_IV64 : &GET_U32;
+}
+
+sub GET_long {
+ $Config{longsize} == 8 ? &GET_IV64 : &GET_U32;
+}
+
+
+package B::Disassembler;
+use Exporter;
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(disassemble_fh get_header);
+use Carp;
+use strict;
+
+use B::Asmdata qw(%insn_data @insn_name);
+
+our( $magic, $archname, $blversion, $ivsize, $ptrsize, $byteorder );
+
+sub dis_header($){
+ my( $fh ) = @_;
+ $magic = $fh->GET_U32();
+ warn( "bad magic" ) if $magic != 0x43424c50;
+ $archname = $fh->GET_strconst();
+ $blversion = $fh->GET_strconst();
+ $ivsize = $fh->GET_U32();
+ $ptrsize = $fh->GET_U32();
+ $byteorder = $fh->GET_strconst();
+}
+
+sub get_header(){
+ return( $magic, $archname, $blversion, $ivsize, $ptrsize, $byteorder);
+}
+
+sub disassemble_fh {
+ my ($fh, $out) = @_;
+ my ($c, $getmeth, $insn, $arg);
+ bless $fh, "B::Disassembler::BytecodeStream";
+ dis_header( $fh );
+ while (defined($c = $fh->getc)) {
+ $c = ord($c);
+ $insn = $insn_name[$c];
+ if (!defined($insn) || $insn eq "unused") {
+ my $pos = $fh->tell - 1;
+ die "Illegal instruction code $c at stream offset $pos\n";
+ }
+ $getmeth = $insn_data{$insn}->[2];
+ $arg = $fh->$getmeth();
+ if (defined($arg)) {
+ &$out($insn, $arg);
+ } else {
+ &$out($insn);
+ }
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+B::Disassembler - Disassemble Perl bytecode
+
+=head1 SYNOPSIS
+
+ use Disassembler;
+
+=head1 DESCRIPTION
+
+See F<ext/B/B/Disassembler.pm>.
+
+=head1 AUTHOR
+
+Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
+
+=cut
View
349 B/Stackobj.pm
@@ -0,0 +1,349 @@
+# Stackobj.pm
+#
+# Copyright (c) 1996 Malcolm Beattie
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the README file.
+#
+package B::Stackobj;
+
+our $VERSION = '1.00';
+
+use Exporter ();
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(set_callback T_UNKNOWN T_DOUBLE T_INT VALID_UNSIGNED
+ VALID_INT VALID_DOUBLE VALID_SV REGISTER TEMPORARY);
+%EXPORT_TAGS = (types => [qw(T_UNKNOWN T_DOUBLE T_INT)],
+ flags => [qw(VALID_INT VALID_DOUBLE VALID_SV
+ VALID_UNSIGNED REGISTER TEMPORARY)]);
+
+use Carp qw(confess);
+use strict;
+use B qw(class SVf_IOK SVf_NOK SVf_IVisUV);
+
+# Types
+sub T_UNKNOWN () { 0 }
+sub T_DOUBLE () { 1 }
+sub T_INT () { 2 }
+sub T_SPECIAL () { 3 }
+
+# Flags
+sub VALID_INT () { 0x01 }
+sub VALID_UNSIGNED () { 0x02 }
+sub VALID_DOUBLE () { 0x04 }
+sub VALID_SV () { 0x08 }
+sub REGISTER () { 0x10 } # no implicit write-back when calling subs
+sub TEMPORARY () { 0x20 } # no implicit write-back needed at all
+sub SAVE_INT () { 0x40 } #if int part needs to be saved at all
+sub SAVE_DOUBLE () { 0x80 } #if double part needs to be saved at all
+
+
+#
+# Callback for runtime code generation
+#
+my $runtime_callback = sub { confess "set_callback not yet called" };
+sub set_callback (&) { $runtime_callback = shift }
+sub runtime { &$runtime_callback(@_) }
+
+#
+# Methods
+#
+
+sub write_back { confess "stack object does not implement write_back" }
+
+sub invalidate { shift->{flags} &= ~(VALID_INT |VALID_UNSIGNED | VALID_DOUBLE) }
+
+sub as_sv {
+ my $obj = shift;
+ if (!($obj->{flags} & VALID_SV)) {
+ $obj->write_back;
+ $obj->{flags} |= VALID_SV;
+ }
+ return $obj->{sv};
+}
+
+sub as_int {
+ my $obj = shift;
+ if (!($obj->{flags} & VALID_INT)) {
+ $obj->load_int;
+ $obj->{flags} |= VALID_INT|SAVE_INT;
+ }
+ return $obj->{iv};
+}
+
+sub as_double {
+ my $obj = shift;
+ if (!($obj->{flags} & VALID_DOUBLE)) {
+ $obj->load_double;
+ $obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE;
+ }
+ return $obj->{nv};
+}
+
+sub as_numeric {
+ my $obj = shift;
+ return $obj->{type} == T_INT ? $obj->as_int : $obj->as_double;
+}
+
+sub as_bool {
+ my $obj=shift;
+ if ($obj->{flags} & VALID_INT ){
+ return $obj->{iv};
+ }
+ if ($obj->{flags} & VALID_DOUBLE ){
+ return $obj->{nv};
+ }
+ return sprintf("(SvTRUE(%s))", $obj->as_sv) ;
+}
+
+#
+# Debugging methods
+#
+sub peek {
+ my $obj = shift;
+ my $type = $obj->{type};
+ my $flags = $obj->{flags};
+ my @flags;
+ if ($type == T_UNKNOWN) {
+ $type = "T_UNKNOWN";
+ } elsif ($type == T_INT) {
+ $type = "T_INT";
+ } elsif ($type == T_DOUBLE) {
+ $type = "T_DOUBLE";
+ } else {
+ $type = "(illegal type $type)";
+ }
+ push(@flags, "VALID_INT") if $flags & VALID_INT;
+ push(@flags, "VALID_DOUBLE") if $flags & VALID_DOUBLE;
+ push(@flags, "VALID_SV") if $flags & VALID_SV;
+ push(@flags, "REGISTER") if $flags & REGISTER;
+ push(@flags, "TEMPORARY") if $flags & TEMPORARY;
+ @flags = ("none") unless @flags;
+ return sprintf("%s type=$type flags=%s sv=$obj->{sv}",
+ class($obj), join("|", @flags));
+}
+
+sub minipeek {
+ my $obj = shift;
+ my $type = $obj->{type};
+ my $flags = $obj->{flags};
+ if ($type == T_INT || $flags & VALID_INT) {
+ return $obj->{iv};
+ } elsif ($type == T_DOUBLE || $flags & VALID_DOUBLE) {
+ return $obj->{nv};
+ } else {
+ return $obj->{sv};
+ }
+}
+
+#
+# Caller needs to ensure that set_int, set_double,
+# set_numeric and set_sv are only invoked on legal lvalues.
+#
+sub set_int {
+ my ($obj, $expr,$unsigned) = @_;
+ runtime("$obj->{iv} = $expr;");
+ $obj->{flags} &= ~(VALID_SV | VALID_DOUBLE);
+ $obj->{flags} |= VALID_INT|SAVE_INT;
+ $obj->{flags} |= VALID_UNSIGNED if $unsigned;
+}
+
+sub set_double {
+ my ($obj, $expr) = @_;
+ runtime("$obj->{nv} = $expr;");
+ $obj->{flags} &= ~(VALID_SV | VALID_INT);
+ $obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE;
+}
+
+sub set_numeric {
+ my ($obj, $expr) = @_;
+ if ($obj->{type} == T_INT) {
+ $obj->set_int($expr);
+ } else {
+ $obj->set_double($expr);
+ }
+}
+
+sub set_sv {
+ my ($obj, $expr) = @_;
+ runtime("SvSetSV($obj->{sv}, $expr);");
+ $obj->invalidate;
+ $obj->{flags} |= VALID_SV;
+}
+
+#
+# Stackobj::Padsv
+#
+
+@B::Stackobj::Padsv::ISA = 'B::Stackobj';
+sub B::Stackobj::Padsv::new {
+ my ($class, $type, $extra_flags, $ix, $iname, $dname) = @_;
+ $extra_flags |= SAVE_INT if $extra_flags & VALID_INT;
+ $extra_flags |= SAVE_DOUBLE if $extra_flags & VALID_DOUBLE;
+ bless {
+ type => $type,
+ flags => VALID_SV | $extra_flags,
+ sv => "PL_curpad[$ix]",
+ iv => "$iname",
+ nv => "$dname"
+ }, $class;
+}
+
+sub B::Stackobj::Padsv::load_int {
+ my $obj = shift;
+ if ($obj->{flags} & VALID_DOUBLE) {
+ runtime("$obj->{iv} = $obj->{nv};");
+ } else {
+ runtime("$obj->{iv} = SvIV($obj->{sv});");
+ }
+ $obj->{flags} |= VALID_INT|SAVE_INT;
+}
+
+sub B::Stackobj::Padsv::load_double {
+ my $obj = shift;
+ $obj->write_back;
+ runtime("$obj->{nv} = SvNV($obj->{sv});");
+ $obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE;
+}
+sub B::Stackobj::Padsv::save_int {
+ my $obj = shift;
+ return $obj->{flags} & SAVE_INT;
+}
+
+sub B::Stackobj::Padsv::save_double {
+ my $obj = shift;
+ return $obj->{flags} & SAVE_DOUBLE;
+}
+
+sub B::Stackobj::Padsv::write_back {
+ my $obj = shift;
+ my $flags = $obj->{flags};
+ return if $flags & VALID_SV;
+ if ($flags & VALID_INT) {
+ if ($flags & VALID_UNSIGNED ){
+ runtime("sv_setuv($obj->{sv}, $obj->{iv});");
+ }else{
+ runtime("sv_setiv($obj->{sv}, $obj->{iv});");
+ }
+ } elsif ($flags & VALID_DOUBLE) {
+ runtime("sv_setnv($obj->{sv}, $obj->{nv});");
+ } else {
+ confess "write_back failed for lexical @{[$obj->peek]}\n";
+ }
+ $obj->{flags} |= VALID_SV;
+}
+
+#
+# Stackobj::Const
+#
+
+@B::Stackobj::Const::ISA = 'B::Stackobj';
+sub B::Stackobj::Const::new {
+ my ($class, $sv) = @_;
+ my $obj = bless {
+ flags => 0,
+ sv => $sv # holds the SV object until write_back happens
+ }, $class;
+ if ( ref($sv) eq "B::SPECIAL" ){
+ $obj->{type}= T_SPECIAL;
+ }else{
+ my $svflags = $sv->FLAGS;
+ if ($svflags & SVf_IOK) {
+ $obj->{flags} = VALID_INT|VALID_DOUBLE;
+ $obj->{type} = T_INT;
+ if ($svflags & SVf_IVisUV){
+ $obj->{flags} |= VALID_UNSIGNED;
+ $obj->{nv} = $obj->{iv} = $sv->UVX;
+ }else{
+ $obj->{nv} = $obj->{iv} = $sv->IV;
+ }
+ } elsif ($svflags & SVf_NOK) {
+ $obj->{flags} = VALID_INT|VALID_DOUBLE;
+ $obj->{type} = T_DOUBLE;
+ $obj->{iv} = $obj->{nv} = $sv->NV;
+ } else {
+ $obj->{type} = T_UNKNOWN;
+ }
+ }
+ return $obj;
+}
+
+sub B::Stackobj::Const::write_back {
+ my $obj = shift;
+ return if $obj->{flags} & VALID_SV;
+ # Save the SV object and replace $obj->{sv} by its C source code name
+ $obj->{sv} = $obj->{sv}->save;
+ $obj->{flags} |= VALID_SV|VALID_INT|VALID_DOUBLE;
+}
+
+sub B::Stackobj::Const::load_int {
+ my $obj = shift;
+ if (ref($obj->{sv}) eq "B::RV"){
+ $obj->{iv} = int($obj->{sv}->RV->PV);
+ }else{
+ $obj->{iv} = int($obj->{sv}->PV);
+ }
+ $obj->{flags} |= VALID_INT;
+}
+
+sub B::Stackobj::Const::load_double {
+ my $obj = shift;
+ if (ref($obj->{sv}) eq "B::RV"){
+ $obj->{nv} = $obj->{sv}->RV->PV + 0.0;
+ }else{
+ $obj->{nv} = $obj->{sv}->PV + 0.0;
+ }
+ $obj->{flags} |= VALID_DOUBLE;
+}
+
+sub B::Stackobj::Const::invalidate {}
+
+#
+# Stackobj::Bool
+#
+
+@B::Stackobj::Bool::ISA = 'B::Stackobj';
+sub B::Stackobj::Bool::new {
+ my ($class, $preg) = @_;
+ my $obj = bless {
+ type => T_INT,
+ flags => VALID_INT|VALID_DOUBLE,
+ iv => $$preg,
+ nv => $$preg,
+ preg => $preg # this holds our ref to the pseudo-reg
+ }, $class;
+ return $obj;
+}