Skip to content
Browse files

Initial import

  • Loading branch information...
0 parents commit 69038f09dbbc3ee2a52558f655e64204bdaf21f2 @gfx committed Nov 17, 2009
Showing with 5,642 additions and 0 deletions.
  1. +21 −0 .gitignore
  2. +7 −0 .shipit
  3. +29 −0 Changes
  4. +41 −0 MANIFEST.SKIP
  5. +24 −0 Makefile.PL
  6. +27 −0 README
  7. +10 −0 author/b-list-const.pl
  8. +10 −0 author/b-list-funcs.pl
  9. +13 −0 author/b-list-methods.pl
  10. +8 −0 author/foreach.pl
  11. +18 −0 author/heavy.pl
  12. +26 −0 author/mg-local.pl
  13. +27 −0 example/for.pl
  14. +27 −0 example/foreach.pl
  15. +14 −0 example/funcall.pl
  16. +4 −0 example/hello-Dt.pl
  17. +5 −0 example/hello-concise.pl
  18. +10 −0 example/hello-trace.pl
  19. +9 −0 example/hello.pl
  20. +17 −0 example/methcall.pl
  21. +13 −0 example/quine.pl
  22. +18 −0 example/trace.pl
  23. +17 −0 example/warn.pl
  24. +1,178 −0 lib/Acme/Perl/VM.pm
  25. +264 −0 lib/Acme/Perl/VM/B.pm
  26. +288 −0 lib/Acme/Perl/VM/Context.pm
  27. +302 −0 lib/Acme/Perl/VM/JA.pod
  28. +1,660 −0 lib/Acme/Perl/VM/PP.pm
  29. +48 −0 lib/Acme/Perl/VM/Run.pm
  30. +309 −0 lib/Acme/Perl/VM/Scope.pm
  31. +9 −0 t/00_load.t
  32. +68 −0 t/01_print.t
  33. +28 −0 t/02_return.t
  34. +30 −0 t/03_assign.t
  35. +77 −0 t/04_funcall.t
  36. +61 −0 t/05_methcall.t
  37. +35 −0 t/06_misc.t
  38. +121 −0 t/07_loop.t
  39. +110 −0 t/08_array.t
  40. +95 −0 t/09_hash.t
  41. +85 −0 t/10_rv2xv.t
  42. +31 −0 t/11_readline.t
  43. +32 −0 t/12_anon.t
  44. +97 −0 t/13_foreach.t
  45. +21 −0 t/14_assign2.t
  46. +20 −0 t/15_range.t
  47. +57 −0 t/16_wantarray.t
  48. +21 −0 t/17_pushpop.t
  49. +32 −0 t/18_extern.t
  50. +59 −0 t/19_bless.t
  51. +26 −0 t/20_join.t
  52. +37 −0 t/21_assign3.t
  53. +18 −0 xt/01_podspell.t
  54. +9 −0 xt/02_pod.t
  55. +13 −0 xt/03_pod-coverage.t
  56. +6 −0 xt/04_synopsis.t
21 .gitignore
@@ -0,0 +1,21 @@
+Acme-Perl-VM-*
+.*
+!.gitignore
+!.shipit
+*.o
+*.obj
+*.bs
+*.def
+Makefile*
+!Makefile.PL
+*blib
+META.yml
+inc/
+MANIFEST
+*.out
+*.bak
+nytprof*
+cover_db*
+*.gcda
+*.gno
+*.gcov
7 .shipit
@@ -0,0 +1,7 @@
+# auto-generated shipit config file.
+steps = FindVersion, ChangeAllVersions, CheckVersionsMatch, CheckChangeLog, DistTest, Commit, Tag, MakeDist
+
+git.tagpattern = %v
+git.push_to = origin
+
+CheckChangeLog.files = Changes
29 Changes
@@ -0,0 +1,29 @@
+Revision history for Perl extension Acme::Perl::VM
+
+0.0.5 Tue May 26 23:28:48 2009
+ - mention Devel::Optrace
+ - add pp_andassign/pp_orassign
+
+0.0.4 Sat May 2 15:34:24 2009
+ - fix some bugs
+ - add ppcodes
+
+0.0.3 Sun Apr 26 14:13:42 2009
+ - add description to Acme/Perl/VM/JA.pod
+ - add a number of ppcodes and tests
+ - improve trace mode
+
+0.0.2 Sun Apr 19 12:58:14 2009
+ - release for Shibuya.pm#11
+ - improve trace mode (APVM_DEBUG=trace)
+
+0.0.1_03 Fri Apr 17 23:33:58 2009
+ - fix pp_entersub
+ - add a number of ppcodes and tests
+ - remove Carp::Always dependency
+
+0.0.1_02 Wed Apr 15 18:11:26 2009
+ - implement OPpASSIGN_COMMON
+
+0.0.1_01 Sat Mar 28 16:40:41 2009
+ - original version; created by Module::Setup
41 MANIFEST.SKIP
@@ -0,0 +1,41 @@
+
+#!start included /usr/local/lib/perl5/5.10.0/ExtUtils/MANIFEST.SKIP
+# Avoid version control files.
+\bRCS\b
+\bCVS\b
+\bSCCS\b
+,v$
+\B\.svn\b
+\b_darcs\b
+
+# Avoid Makemaker generated and utility files.
+\bMANIFEST\.bak
+\bMakefile$
+\bblib/
+\bMakeMaker-\d
+\bpm_to_blib\.ts$
+\bpm_to_blib$
+\bblibdirs\.ts$ # 6.18 through 6.25 generated this
+
+# Avoid Module::Build generated and utility files.
+\bBuild$
+\b_build/
+
+# Avoid temp and backup files.
+~$
+\.old$
+\#$
+\b\.#
+\.bak$
+
+# Avoid Devel::Cover files.
+\bcover_db\b
+#!end included /usr/local/lib/perl5/5.10.0/ExtUtils/MANIFEST.SKIP
+
+
+# skip dot files
+^\.
+
+# skip author's files
+\bauthor\b
+
24 Makefile.PL
@@ -0,0 +1,24 @@
+use strict;
+use warnings;
+use inc::Module::Install;
+
+name 'Acme-Perl-VM';
+all_from 'lib/Acme/Perl/VM.pm';
+
+requires 'Exporter' => 5.57;
+requires 'Mouse' => 0.21;
+requires 'B';
+
+test_requires 'Test::More' => 0.62;
+
+tests 't/*.t';
+author_tests 'xt';
+
+WriteMakefile(
+ clean => {FILES => q(
+ Acme-Perl-VM-* *.stackdump
+ cover_db
+ nytprof
+ *.out
+ )},
+);
27 README
@@ -0,0 +1,27 @@
+This is Perl module Acme::Perl::VM.
+
+INSTALLATION
+
+Acme::Perl::VM installation is straightforward. If your CPAN shell is set up,
+you should just be able to do
+
+ $ cpan Acme::Perl::VM
+
+Download it, unpack it, then build it as per the usual:
+
+ $ perl Makefile.PL
+ $ make && make test
+
+Then install it:
+
+ $ make install
+
+DOCUMENTATION
+
+Acme::Perl::VM documentation is available as in POD. So you can do:
+
+ $ perldoc Acme::Perl::VM
+
+to read the documentation online with your favorite pager.
+
+Goro Fuji (gfx)
10 author/b-list-const.pl
@@ -0,0 +1,10 @@
+#!perl -w
+
+use strict;
+use B;
+use Config;
+printf "Perl %vd $Config{archname}\n\n", $^V;
+
+foreach my $name(grep{ /^[A-Z]/ } @B::EXPORT_OK ){
+ printf "%-30s=%12s\n", $name, B->$name();
+}
10 author/b-list-funcs.pl
@@ -0,0 +1,10 @@
+#!perl -w
+
+use strict;
+use B;
+use Config;
+printf "Perl %vd $Config{archname}\n\n", $^V;
+
+foreach my $name(sort grep{ !/^[A-Z]/ } @B::EXPORT_OK ){
+ printf "%-30s\n", $name;
+}
13 author/b-list-methods.pl
@@ -0,0 +1,13 @@
+#!perl -w
+
+use strict;
+use B;
+use Config;
+use Class::Inspector;
+
+printf "Perl %vd $Config{archname}\n\n", $^V;
+
+my $class = shift(@ARGV) || 'B::SV';
+foreach my $name( sort @{Class::Inspector->methods($class, 'full')} ){
+ printf "%s\n", $name;
+}
8 author/foreach.pl
@@ -0,0 +1,8 @@
+#!perl -w
+
+use strict;
+
+my $sum = 0;
+foreach my $i(1 .. 10){
+ $sum += $i;
+}
18 author/heavy.pl
@@ -0,0 +1,18 @@
+#!perl -w
+
+use strict;
+use 5.010;
+use Acme::Perl::VM;
+
+my $file = `perldoc -l perlrun`;
+chomp $file;
+open my $in, '<', $file;
+
+run_block{
+ local $|= 1;
+ my $i = 0;
+ while(<$in>){
+ print $i++, "\r";
+ }
+ say $i;
+};
26 author/mg-local.pl
@@ -0,0 +1,26 @@
+#!perl -w
+
+use strict;
+use Devel::Peek;
+
+$| = 0;
+
+my $mgref = \$|;
+my $r;
+{
+ local $| = 1;
+ $r = \$|;
+ Dump($mgref);
+ Dump($r);
+
+
+ print "$$mgref\n";
+ print "$$r\n";
+}
+
+Dump($mgref);
+Dump($r);
+
+print "$$mgref\n";
+print "$$r\n";
+print "[$|]\n";
27 example/for.pl
@@ -0,0 +1,27 @@
+#!perl -w
+use strict;
+use FindBin qw($Bin);
+use lib "$Bin/../lib";
+
+use Acme::Perl::VM;
+
+sub f{
+ my($x) = @_;
+ print $x, "\r";
+ return $x;
+}
+
+run_block {
+ local $| = 1;
+
+ my $sum = 0;
+ for(my $i = 1; $i <= 100; $i++){
+ for(my $j = 1; $j <= 10; $j++){
+ $sum += f($i * $j);
+ }
+ }
+
+ print "\n", $sum, "\n";
+};
+
+print B::timing_info(), "\n";
27 example/foreach.pl
@@ -0,0 +1,27 @@
+#!perl -w
+use strict;
+use FindBin qw($Bin);
+use lib "$Bin/../lib";
+
+use Acme::Perl::VM;
+
+sub f{
+ my($x) = @_;
+ print $x, "\r";
+ return $x;
+}
+
+run_block {
+ local $| = 1;
+
+ my $sum = 0;
+ foreach my $i(1 .. 100){
+ foreach my $j(1 .. 10){
+ $sum += f($i * $j);
+ }
+ }
+
+ print "\n", $sum, "\n";
+};
+
+print B::timing_info(), "\n";
14 example/funcall.pl
@@ -0,0 +1,14 @@
+#!perl -w
+use strict;
+use FindBin qw($Bin);
+use lib "$Bin/../lib";
+
+use Acme::Perl::VM::Run;
+
+sub hello{
+ my($s) = @_;
+
+ print "Hello, $s world!\n";
+}
+
+hello("APVM");
4 example/hello-Dt.pl
@@ -0,0 +1,4 @@
+#!perl -w -Dt
+
+my $x = 'APVM';
+print "Hello, $x world!\n";
5 example/hello-concise.pl
@@ -0,0 +1,5 @@
+#!perl -w
+use O Concise => '-exec';
+
+my $x = 'APVM';
+print "Hello, $x world!\n";
10 example/hello-trace.pl
@@ -0,0 +1,10 @@
+#!perl -w
+BEGIN{ $ENV{APVM_DEBUG} = 'trace' }
+use strict;
+use FindBin qw($Bin);
+use lib "$Bin/../lib";
+
+use Acme::Perl::VM::Run;
+
+my $x = 'APVM';
+print "Hello, $x world!\n";
9 example/hello.pl
@@ -0,0 +1,9 @@
+#!perl -w
+use strict;
+use FindBin qw($Bin);
+use lib "$Bin/../lib";
+
+use Acme::Perl::VM::Run;
+
+my $x = 'APVM';
+print "Hello, $x world!\n";
17 example/methcall.pl
@@ -0,0 +1,17 @@
+#!perl -w
+use strict;
+use FindBin qw($Bin);
+use lib "$Bin/../lib";
+
+use Acme::Perl::VM;
+
+sub Foo::hello{
+ my(undef, $s) = @_;
+
+ print "Hello, $s world!\n";
+}
+
+run_block {
+ Foo->hello("Acme::Perl::VM");
+ Foo->hello("APVM");
+};
13 example/quine.pl
@@ -0,0 +1,13 @@
+#!perl -w
+use strict;
+use FindBin qw($Bin);
+use lib "$Bin/../lib";
+
+use Acme::Perl::VM;
+
+open *SELF, '<', $0;
+run_block{
+ while(<SELF>){
+ print;
+ }
+};
18 example/trace.pl
@@ -0,0 +1,18 @@
+#!perl -w
+BEGIN{ $ENV{APVM_DEBUG} = 'trace' }
+use strict;
+use FindBin qw($Bin);
+use lib "$Bin/../lib";
+
+use Acme::Perl::VM::Run;
+
+sub Foo::hello{
+ my(undef, $msg) = @_;
+
+ print "Hello, $msg world!\n";
+}
+
+for(my $i = 1; $i <= 1; $i++){
+ Foo->hello('APVM');
+}
+
17 example/warn.pl
@@ -0,0 +1,17 @@
+#!perl -w
+use strict;
+use FindBin qw($Bin);
+use lib "$Bin/../lib";
+
+use Acme::Perl::VM;
+
+sub f{
+ print 42 + undef, "\n";
+}
+sub g{
+ f(42);
+}
+
+run_block {
+ &g;
+};
1,178 lib/Acme/Perl/VM.pm
@@ -0,0 +1,1178 @@
+package Acme::Perl::VM;
+
+use 5.008_001;
+use strict;
+use warnings;
+
+our $VERSION = 0.006;
+
+use constant APVM_DEBUG => ( $ENV{APVM_DEBUG} || 0 );
+use constant {
+ APVM_TRACE => scalar(APVM_DEBUG =~ /\b trace \b/xmsi),
+ APVM_SCOPE => scalar(APVM_DEBUG =~ /\b scope \b/xmsi),
+ APVM_CX => scalar(APVM_DEBUG =~ /\b (?: cx | context ) \b/xmsi),
+ APVM_STACK => scalar(APVM_DEBUG =~ /\b stack \b/xmsi),
+
+ APVM_DUMMY => scalar(APVM_DEBUG =~ /\b dummy \b/xmsi),
+};
+
+use Exporter qw(import);
+
+BEGIN{
+ our @EXPORT = qw(run_block call_sv);
+ our @EXPORT_OK = qw(
+ $PL_op $PL_curcop
+ @PL_stack @PL_markstack @PL_cxstack @PL_scopestack @PL_savestack @PL_tmps
+ $PL_tmps_floor
+ $PL_comppad $PL_comppad_name @PL_curpad
+ $PL_last_in_gv
+ $PL_runops
+ %PL_ppaddr
+
+ PUSHMARK POPMARK TOPMARK
+ PUSH POP TOP SET SETval
+ mPUSH
+ GET_TARGET
+ GET_TARGETSTACKED
+ GET_ATARGET
+ MAXARG
+
+ PUSHBLOCK POPBLOCK TOPBLOCK
+ PUSHSUB POPSUB
+ PUSHLOOP POPLOOP
+
+ dounwind
+
+ ENTER LEAVE LEAVE_SCOPE
+ SAVETMPS FREETMPS
+ SAVE SAVECOMPPAD SAVECLEARSV
+ SAVEPADSV
+ save_scalar save_ary save_hash
+
+ OP_GIMME GIMME_V LVRET
+
+ PAD_SV PAD_SET_CUR_NOSAVE PAD_SET_CUR
+ CX_CURPAD_SAVE CX_CURPAD_SV
+
+ dopoptosub dopoptoloop dopoptolabel
+
+ deb apvm_warn apvm_die croak ddx
+
+ GVOP_gv
+
+ vivify_ref
+ sv_newmortal sv_mortalcopy sv_2mortal
+ SvPV SvNV SvIV SvTRUE
+ av_assign av_store
+ hv_store hv_store_ent hv_scalar
+
+ defoutgv
+ gv_fullname
+
+ looks_like_number
+ sv_defined is_null is_not_null
+ mark_list
+ not_implemented
+ dump_object dump_value dump_stack dump_si
+
+ apvm_extern
+ cv_external
+
+ APVM_DEBUG APVM_DUMMY
+ APVM_SCOPE APVM_TRACE
+ );
+ our %EXPORT_TAGS = (
+ perl_h => \@EXPORT_OK,
+ );
+
+
+
+ if(APVM_DEBUG && -t *STDERR){
+ require Term::ANSIColor;
+
+ *deb = \&_deb_colored;
+ }
+ else{
+ *deb = \&_deb;
+ }
+}
+
+use Scalar::Util qw(looks_like_number refaddr);
+use Carp ();
+
+use Acme::Perl::VM::Context;
+use Acme::Perl::VM::Scope;
+use Acme::Perl::VM::PP;
+use Acme::Perl::VM::B;
+
+our $PL_op;
+our $PL_curcop;
+
+our @PL_stack;
+our @PL_markstack;
+our @PL_cxstack;
+our @PL_scopestack;
+our @PL_savestack;
+our @PL_tmps;
+
+our $PL_tmps_floor;
+
+our $PL_comppad;
+our $PL_comppad_name;
+our @PL_curpad;
+
+our $PL_last_in_gv;
+
+our $PL_runops = \&runops_standard;
+our %PL_ppaddr;
+{
+ while(my($name, $value) = each %Acme::Perl::VM::PP::){
+ if($name =~ s/^pp_//){
+ $PL_ppaddr{$name} = *{$value}{CODE};
+ }
+ }
+}
+
+if(APVM_TRACE || APVM_STACK){
+ $PL_runops = \&runops_debug;
+}
+
+our $color = 'GREEN BOLD';
+
+sub not_implemented;
+
+sub runops_standard{ # run.c
+ 1 while(${ $PL_op = &{$PL_ppaddr{ $PL_op->name } || not_implemented($PL_op->ppaddr)} });
+ return;
+}
+
+sub _op_trace{
+ my $flags = $PL_op->flags;
+ my $name = $PL_op->name;
+
+ deb '.%s', $name;
+ if(ref($PL_op) eq 'B::COP'){
+ deb '(%s%s %s:%d)',
+ ($PL_op->label ? $PL_op->label.': ' : ''),
+ $PL_op->stashpv,
+ $PL_op->file, $PL_op->line,
+ ;
+ }
+ elsif($name eq 'entersub'){
+ my $gv = TOP;
+ if(!$gv->isa('B::GV')){
+ $gv = $gv->GV;
+ }
+ deb '(%s)', gv_fullname($gv, '&');
+ }
+ elsif($name eq 'aelemfast'){
+ my $name;
+ if($flags & OPf_SPECIAL){
+ my $padname = $PL_comppad_name->ARRAYelt($PL_op->targ);
+ $name = $padname->POK ? '@'.$padname->PVX : '[...]';
+ }
+ else{
+ $name = gv_fullname(GVOP_gv($PL_op), '@');
+ }
+ deb '[%s[%s]]', $name, $PL_op->private;
+ }
+ elsif($PL_op->targ && $name !~ /leave/){
+ if($name eq 'const' || $name eq 'method_named'){
+ my $sv = PAD_SV($PL_op->targ);
+
+ if(is_scalar($sv)){
+ deb '(%s)', $sv->POK ? B::perlstring($sv->PVX) : $sv->as_string;
+ }
+ else{
+ deb '(%s)', ddx([$sv->object_2svref])->Indent(0)->Dump;
+ }
+ }
+ else{
+ my $padname = $PL_comppad_name->ARRAYelt($PL_op->targ);
+ if($padname->POK){
+ deb '(%s)', $padname->PVX;
+ deb ' INTRO' if $PL_op->private & OPpLVAL_INTRO;
+ }
+ }
+ }
+ elsif($PL_op->can('sv')){
+ my $sv = SVOP_sv($PL_op);
+ if($sv->class eq 'GV'){
+ my $prefix = $name eq 'gvsv' ? '$' : '*';
+ deb '(%s)', gv_fullname($sv, $prefix);
+ deb ' INTRO' if $PL_op->private & OPpLVAL_INTRO;
+ }
+ else{
+ deb '(%s)', B::perlstring(SvPV(SVOP_sv($PL_op)));
+ }
+ }
+
+ deb ' VOID' if( ($flags & OPf_WANT) == OPf_WANT_VOID );
+ deb ' SCALAR' if( ($flags & OPf_WANT) == OPf_WANT_SCALAR );
+ deb ' LIST' if( ($flags & OPf_WANT) == OPf_WANT_LIST );
+
+ deb ' KIDS' if $flags & OPf_KIDS;
+ deb ' PARENS' if $flags & OPf_PARENS;
+ deb ' REF' if $flags & OPf_REF;
+ deb ' MOD' if $flags & OPf_MOD;
+ deb ' STACKED' if $flags & OPf_STACKED;
+ deb ' SPECIAL' if $flags & OPf_SPECIAL;
+
+ deb "\n";
+}
+
+sub runops_debug{
+ _op_trace();
+ while(${ $PL_op = &{$PL_ppaddr{ $PL_op->name } || not_implemented($PL_op->ppaddr)} }){
+ if(APVM_STACK){
+ dump_stack();
+ }
+
+ _op_trace();
+ }
+ if(APVM_STACK){
+ dump_stack();
+ }
+ return;
+}
+
+sub _deb_colored{
+ my($fmt, @args) = @_;
+ printf STDERR Term::ANSIColor::colored($fmt, $color), @args;
+ return;
+}
+sub _deb{
+ my($fmt, @args) = @_;
+ printf STDERR $fmt, @args;
+ return;
+}
+
+sub mess{ # util.c
+ my($fmt, @args) = @_;
+ my $msg = sprintf $fmt, @args;
+ return sprintf "[APVM] %s in %s at %s line %d.\n",
+ $msg, $PL_op->desc, $PL_curcop->file, $PL_curcop->line;
+}
+
+sub longmess{
+ my $msg = mess(@_);
+ my $cxix = $#PL_cxstack;
+ while( ($cxix = dopoptosub($cxix)) >= 0 ){
+ my $cx = $PL_cxstack[$cxix];
+ my $cop = $cx->oldcop;
+
+ my $args;
+
+ if($cx->argarray){
+ $args = sprintf '(%s)', join q{,},
+ map{ defined($_) ? qq{'$_'} : 'undef' }
+ @{ $cx->argarray->object_2svref };
+ }
+ else{
+ $args = '';
+ }
+
+ my $cvgv = $cx->cv->GV;
+ $msg .= sprintf qq{[APVM] %s%s called at %s line %d.\n},
+ gv_fullname($cvgv), $args,
+ $cop->file, $cop->line;
+
+ $cxix--;
+ }
+ return $msg;
+}
+
+sub apvm_warn{
+ #warn APVM_DEBUG ? longmess(@_) : mess(@_);
+ print STDERR longmess(@_);
+}
+sub apvm_die{
+ # not yet implemented completely
+ # cf.
+ # die_where() in pp_ctl.c
+ # vdie() in util.c
+ die APVM_DEBUG ? longmess(@_) : mess(@_);
+}
+sub croak{
+ die APVM_DEBUG ? longmess(@_) : mess(@_);
+}
+
+sub PUSHMARK(){
+ push @PL_markstack, $#PL_stack;
+ return;
+}
+sub POPMARK(){
+ return pop @PL_markstack;
+}
+sub TOPMARK(){
+ return $PL_markstack[-1];
+}
+
+sub PUSH{
+ push @PL_stack, @_;
+ return;
+}
+sub mPUSH{
+ PUSH(map{ sv_2mortal($_) } @_);
+ return;
+}
+sub POP(){
+ return pop @PL_stack;
+}
+sub TOP(){
+ return $PL_stack[-1];
+}
+sub SET{
+ my($sv) = @_;
+ $PL_stack[-1] = $sv;
+ return;
+}
+sub SETval{
+ my($val) = @_;
+ $PL_stack[-1] = PAD_SV( $PL_op->targ )->setval($val);
+ return;
+}
+
+sub GET_TARGET{
+ return PAD_SV($PL_op->targ);
+}
+sub GET_TARGETSTACKED{
+ return $PL_op->flags & OPf_STACKED ? POP : PAD_SV($PL_op->targ);
+}
+sub GET_ATARGET{
+ return $PL_op->flags & OPf_STACKED ? $PL_stack[$#PL_stack-1] : PAD_SV($PL_op->targ);
+}
+
+sub MAXARG{
+ return $PL_op->private & 0x0F;
+}
+
+sub PUSHBLOCK{
+ my($type, %args) = @_;
+
+ $args{oldcop} = $PL_curcop;
+ $args{oldmarksp} = $#PL_markstack;
+ $args{oldscopesp} = $#PL_scopestack;
+
+ my $cx = "Acme::Perl::VM::Context::$type"->new(\%args);
+ push @PL_cxstack, $cx;
+
+ if(APVM_CX){
+ deb "%s" . "Entering %s\n", (q{>} x @PL_cxstack), $type;
+ }
+
+ return $cx;
+}
+
+sub POPBLOCK{
+ my $cx = pop @PL_cxstack;
+
+ $PL_curcop = $cx->oldcop;
+ $#PL_markstack = $cx->oldmarksp;
+ $#PL_scopestack = $cx->oldscopesp;
+
+ if(APVM_CX){
+ deb "%s" . "Leaving %s\n", (q{>} x (@PL_cxstack+1)), $cx->type;
+ }
+
+ return $cx;
+}
+sub TOPBLOCK{
+ my $cx = $PL_cxstack[-1];
+
+ $#PL_stack = $cx->oldsp;
+ $#PL_markstack = $cx->oldmarksp;
+ $#PL_scopestack = $cx->oldscopesp;
+
+ return $cx;
+}
+
+sub POPSUB{
+ my($cx) = @_;
+ if($cx->hasargs){
+ *_ = $cx->savearray;
+
+ @{ $cx->argarray->object_2svref } = ();
+ }
+ return;
+}
+
+sub POPLOOP{
+ my($cx) = @_;
+
+ if($cx->ITERVAR){
+ if($cx->padvar){
+ my $padix = $cx->iterdata;
+ #my $curpad = $PL_comppad->object_2svref;
+
+ #delete $curpad->[$padix];
+ #$curpad->[$padix] = $cx->itersave;
+ #dump_object($PL_curpad[$padix], $cx->itersave);
+ $PL_curpad[$padix] = $cx->itersave;
+ }
+ }
+ return;
+}
+
+sub dounwind{
+ my($cxix) = @_;
+
+ while($#PL_cxstack > $cxix){
+ my $cx = pop @PL_cxstack;
+ my $type = $cx->type;
+
+ if($type eq 'SUBST'){
+ POPSUBST($cx);
+ }
+ elsif($type eq 'SUB'){
+ POPSUB($cx);
+ }
+ elsif($type eq 'EVAL'){
+ POPEVAL($cx);
+ }
+ elsif($type eq 'LOOP'){
+ POPLOOP($cx);
+ }
+ }
+ return;
+}
+
+sub ENTER{
+ push @PL_scopestack, $#PL_savestack;
+ if(APVM_SCOPE){
+ deb "%s" . "ENTER\n", ('>' x @PL_scopestack);
+ }
+ return;
+}
+
+sub LEAVE{
+ my $oldsave = pop @PL_scopestack;
+ LEAVE_SCOPE($oldsave);
+
+ if(APVM_SCOPE){
+ deb "%s" . "LEAVE\n", ('>' x (@PL_scopestack+1));
+ }
+ return;
+}
+sub LEAVE_SCOPE{
+ my($oldsave) = @_;
+
+ while( $oldsave < $#PL_savestack ){
+ my $ss = pop @PL_savestack;
+
+ if(APVM_SCOPE){
+ deb "%s" . "leave %s %s\n",
+ ('>' x (@PL_cxstack+1)), $ss->type, $ss->saved_state;
+ }
+ $ss->leave();
+ }
+ return;
+}
+
+sub SAVETMPS{
+ push @PL_savestack, Acme::Perl::VM::Scope::Tmps->new(
+ value => $PL_tmps_floor,
+ value_ref => \$PL_tmps_floor,
+ );
+ $PL_tmps_floor = $#PL_tmps;
+ return;
+}
+sub FREETMPS{
+ $#PL_tmps = $PL_tmps_floor;
+ return;
+}
+
+sub SAVE{
+ push @PL_savestack, Acme::Perl::VM::Scope::Value->new(
+ value => $_[0],
+ value_ref => \$_[0],
+ );
+ return;
+}
+sub SAVECOMPPAD{
+ push @PL_savestack, Acme::Perl::VM::Scope::Comppad->new(
+ comppad => $PL_comppad,
+ comppad_name => $PL_comppad_name,
+ );
+ return;
+}
+sub SAVECLEARSV{
+ my($sv) = @_;
+ push @PL_savestack, Acme::Perl::VM::Scope::Clearsv->new(
+ sv => $sv,
+ );
+ return;
+}
+sub SAVEPADSV{
+ my($off) = @_;
+ push @PL_savestack, Acme::Perl::VM::Scope::Padsv->new(
+ off => $off,
+ value => ${$PL_curpad[$off]->object_2svref},
+ comppad => $PL_comppad,
+ );
+ return;
+}
+sub save_scalar{
+ my($gv) = @_;
+ push @PL_savestack, Acme::Perl::VM::Scope::Scalar->new(gv => $gv);
+ return $PL_savestack[-1]->sv;
+}
+sub save_ary{
+ my($gv) = @_;
+ push @PL_savestack, Acme::Perl::VM::Scope::Array->new(gv => $gv);
+ return $PL_savestack[-1]->sv;
+}
+sub save_hash{
+ my($gv) = @_;
+ push @PL_savestack, Acme::Perl::VM::Scope::Hash->new(gv => $gv);
+ return $PL_savestack[-1]->sv;
+}
+
+sub PAD_SET_CUR_NOSAVE{
+ my($padlist, $nth) = @_;
+
+ $PL_comppad_name = $padlist->ARRAYelt(0);
+ $PL_comppad = $padlist->ARRAYelt($nth);
+ @PL_curpad = ($PL_comppad->ARRAY);
+
+ return;
+}
+sub PAD_SET_CUR{
+ my($padlist, $nth) = @_;
+
+ SAVECOMPPAD();
+ PAD_SET_CUR_NOSAVE($padlist, $nth);
+
+ return;
+}
+
+sub PAD_SV{
+ #my($targ) = @_;
+
+ return $PL_curpad[ $_[0] ];
+}
+
+sub dopoptosub{
+ my($startingblock) = @_;
+
+ for(my $i = $startingblock; $i >= 0; $i--){
+ my $type = $PL_cxstack[$i]->type;
+
+ if($type eq 'EVAL' or $type eq 'SUB'){
+ return $i;
+ }
+ }
+ return -1;
+}
+
+my %loop;
+@loop{qw(SUBST SUB EVAL NULL)} = ();
+$loop{LOOP} = TRUE;
+
+sub dopoptoloop{
+ my($startingblock) = @_;
+
+ for(my $i = $startingblock; $i >= 0; --$i){
+ my $cx = $PL_cxstack[$i];
+ my $type = $cx->type;
+
+ if(exists $loop{$type}){
+ if(!$loop{$type}){
+ apvm_warn 'Exsiting %s via %s', $type, $PL_op->name;
+ $i = -1 if $type eq 'NULL';
+ }
+ return $i;
+ }
+ }
+ return -1;
+}
+sub dopoptolabel{
+ my($label) = @_;
+
+ for(my $i = $#PL_cxstack; $i >= 0; --$i){
+ my $cx = $PL_cxstack[$i];
+ my $type = $cx->type;
+
+ if(exists $loop{$type}){
+ if(!$loop{$type}){
+ apvm_warn 'Exsiting %s via %s', $type, $PL_op->name;
+ return $type eq 'NULL' ? -1 : $i;
+ }
+ elsif($cx->label && $cx->label eq $label){
+ return $i;
+ }
+ }
+ }
+ return -1;
+}
+
+sub OP_GIMME{ # op.h
+ my($op, $default) = @_;
+ my $op_gimme = $op->flags & OPf_WANT;
+ return $op_gimme == OPf_WANT_VOID ? G_VOID
+ : $op_gimme == OPf_WANT_SCALAR ? G_SCALAR
+ : $op_gimme == OPf_WANT_LIST ? G_ARRAY
+ : $default;
+}
+
+sub OP_GIMME_REVERSE{ # op.h
+ my($flags) = @_;
+
+ return $flags & G_VOID ? OPf_WANT_VOID
+ : $flags & G_ARRAY ? OPf_WANT_LIST
+ : OPf_WANT_SCALAR;
+}
+
+sub gimme2want{
+ my($gimme) = @_;
+
+ return $gimme == G_VOID ? undef
+ : $gimme == G_SCALAR ? 0
+ : 1;
+}
+sub want2gimme{
+ my($wantarray) = @_;
+
+ return !defined($wantarray) ? G_VOID
+ : !$wantarray ? G_SCALAR
+ : G_ARRAY;
+}
+sub block_gimme{
+ my $cxix = dopoptosub($#PL_cxstack);
+
+ if($cxix < 0){
+ return G_VOID;
+ }
+
+ return $PL_cxstack[$cxix]->gimme;
+}
+
+sub GIMME_V(){ # op.h
+ my $gimme = OP_GIMME($PL_op, -1);
+ return $gimme != -1 ? $gimme : block_gimme();
+}
+
+sub LVRET(){ # cf. is_lvalue_sub() in pp_ctl.h
+ if($PL_op->flags & OPpMAYBE_LVSUB){
+ my $cxix = dopoptosub($#PL_cxstack);
+
+ if($PL_cxstack[$cxix]->lval && $PL_cxstack[$cxix]->cv->CvFLAGS & CVf_LVALUE){
+ not_implemented 'lvalue';
+ return TRUE;
+ }
+ }
+ return FALSE;
+}
+
+sub SVOP_sv{
+ my($op) = @_;
+ return USE_ITHREADS ? PAD_SV($op->padix) : $op->sv;
+}
+sub GVOP_gv{
+ my($op) = @_;
+ return USE_ITHREADS ? PAD_SV($op->padix) : $op->gv;
+}
+
+sub vivify_ref{
+ not_implemented 'vivify_ref';
+}
+
+sub sv_newmortal{
+ my $sv;
+ push @PL_tmps, \$sv;
+ return B::svref_2object(\$sv);
+}
+sub sv_mortalcopy{
+ my($sv) = @_;
+
+ if(!defined $sv){
+ Carp::confess('sv_mortalcopy(NULL)');
+ }
+
+ my $newsv =${$sv->object_2svref};
+ push @PL_tmps, \$newsv;
+ return B::svref_2object(\$newsv);
+}
+sub sv_2mortal{
+ my($sv) = @_;
+
+ if(!defined $sv){
+ Carp::confess('sv_2mortal(NULL)');
+ }
+
+ push @PL_tmps, $sv->object_2svref;
+ return $sv;
+}
+
+sub SvTRUE{
+ my($sv) = @_;
+
+ return ${ $sv->object_2svref } ? TRUE : FALSE;
+}
+
+sub SvPV{
+ my($sv) = @_;
+ my $ref = $sv->object_2svref;
+
+ if(!defined ${$ref}){
+ apvm_warn 'Use of uninitialized value';
+ return q{};
+ }
+
+ return "${$ref}";
+}
+
+sub SvNV{
+ my($sv) = @_;
+ my $ref = $sv->object_2svref;
+
+ if(!defined ${$ref}){
+ apvm_warn 'Use of uninitialized value';
+ return 0;
+ }
+
+ return ${$ref} + 0;
+}
+
+sub SvIV{
+ my($sv) = @_;
+ my $ref = $sv->object_2svref;
+
+ if(!defined ${$ref}){
+ apvm_warn 'Use of uninitialized value';
+ return 0;
+ }
+
+ return int(${$ref});
+}
+
+sub av_assign{
+ my $av = shift;
+ my $ref = $av->object_2svref;
+ $#{$ref} = $#_;
+ for(my $i = 0; $i < @_; $i++){
+ tie $ref->[$i], 'Acme::Perl::VM::Alias', $_[$i]->object_2svref;
+ }
+ return;
+}
+
+sub av_store{
+ my($av, $ix, $sv) = @_;
+ tie $av->object_2svref->[$ix],
+ 'Acme::Perl::VM::Alias', $sv->object_2svref;
+ return;
+}
+
+sub hv_store{
+ my($hv, $key, $sv) = @_;
+ tie $hv->object_2svref->{$key},
+ 'Acme::Perl::VM::Alias', $sv->object_2svref;
+ return;
+}
+
+sub hv_store_ent{
+ my($hv, $key, $sv) = @_;
+ tie $hv->object_2svref->{ ${$key->object_2svref} },
+ 'Acme::Perl::VM::Alias', $sv->object_2svref;
+ return;
+}
+
+sub hv_scalar{
+ my($hv) = @_;
+ my $sv = sv_newmortal();
+ $sv->setval(scalar %{ $hv->object_2svref });
+ return $sv;
+}
+
+sub defoutgv{
+ no strict 'refs';
+ return \*{ select() };
+}
+
+sub gv_fullname{
+ my($gv, $prefix) = @_;
+ $prefix = '' unless defined $prefix;
+
+ my $stashname = $gv->STASH->NAME;
+ if($stashname eq 'main'){
+ $prefix .= $gv->SAFENAME;
+ }
+ else{
+ $prefix .= join q{::}, $stashname, $gv->SAFENAME;
+ }
+ return $prefix;
+}
+
+# Utilities
+
+sub sv_defined{
+ my($sv) = @_;
+
+ return $sv && ${$sv} && defined(${ $sv->object_2svref });
+}
+
+sub is_not_null{
+ my($sv) = @_;
+ return ${$sv};
+}
+sub is_null{
+ my($sv) = @_;
+ return !${$sv};
+}
+
+my %not_a_scalar;
+@not_a_scalar{qw(AV HV CV IO)} = ();
+sub is_scalar{
+ my($sv) = @_;
+ return !exists $not_a_scalar{ $sv->class };
+}
+
+sub mark_list{
+ my($mark) = @_;
+ return map{ ${ $_->object_2svref } } splice @PL_stack, $mark+1;
+}
+
+{
+ our %external;
+
+ sub apvm_extern{
+ foreach my $arg(@_){
+ if(ref $arg){
+ if(ref($arg) ne 'CODE'){
+ Carp::croak('Not a CODE reference for apvm_extern()');
+ }
+ $external{refaddr $arg} = 1;
+ }
+ else{
+ my $stash = do{ no strict 'refs'; \%{$arg .'::'} };
+ while(my $name = each %{$stash}){
+ my $code_ref = do{ no strict 'refs'; *{$arg . '::' . $name}{CODE} };
+ if(defined $code_ref){
+ $external{refaddr $code_ref} = 1;
+ }
+ }
+ }
+ }
+ return;
+ }
+
+ sub cv_external{
+ my($cv) = @_;
+ return $cv->XSUB || $external{ ${$cv} };
+ }
+}
+
+sub ddx{
+ require Data::Dumper;
+ my $ddx = Data::Dumper->new(@_);
+ $ddx->Indent(1);
+ $ddx->Terse(TRUE);
+ $ddx->Quotekeys(FALSE);
+ $ddx->Useqq(TRUE);
+ return $ddx if defined wantarray;
+
+ my $name = ( split '::', (caller 2)[3] )[-1];
+ print STDERR $name, ': ', $ddx->Dump(), "\n";
+ return;
+}
+sub dump_object{
+ ddx([[ map{ $_ ? $_->object_2svref : $_ } @_ ]]);
+}
+
+sub dump_value{
+ ddx([\@_]);
+}
+
+
+sub dump_stack{
+ require Data::Dumper;
+ no warnings 'once';
+
+ local $Data::Dumper::Indent = 0;
+ local $Data::Dumper::Terse = TRUE;
+ local $Data::Dumper::Quotekeys = FALSE;
+ local $Data::Dumper::Useqq = TRUE;
+
+ deb "(%s)\n", join q{,}, map{
+ # find variable name
+ my $varname = '';
+ my $class = $_->class;
+
+ if($class eq 'SPECIAL'){
+ ($varname = $_->special_name) =~ s/^\&PL_//;
+ $varname;
+ }
+ elsif($class eq 'CV'){
+ $varname = '&' . gv_fullname($_->GV);
+ }
+ else{
+ for(my $padix = 0; $padix < @PL_curpad; $padix++){
+ my $padname;
+ if(${ $PL_curpad[$padix] } == ${ $_ }){
+ $padname = $PL_comppad_name->ARRAYelt($padix);
+ }
+ elsif($_->ROK && ${$PL_curpad[$padix]} == ${ $_->RV }){
+ $padname = $PL_comppad_name->ARRAYelt($padix);
+ $varname .= '\\';
+ }
+
+ if($padname){
+ if($padname->POK){
+ $varname .= $padname->PVX . ' ';
+ }
+ last;
+ }
+ }
+ $varname . Data::Dumper->Dump([is_scalar($_) ? ${$_->object_2svref} : $_->object_2svref], [$_->ROK ? 'SV' : '*SV']);
+ }
+
+ } @PL_stack;
+
+ return;
+}
+sub _dump_stack{
+ my $warn;
+ my $ddx = ddx([[map{
+ if(ref $_){
+ is_scalar($_) ? ${$_->object_2svref} : $_->object_2svref;
+ }
+ else{
+ $warn++;
+ $_;
+ }
+ } @PL_stack]], ['*PL_stack']);
+ $ddx->Indent(0);
+ deb " %s\n", $ddx->Dump();
+
+ if($warn){
+ apvm_die 'No sv found (%d)', $warn;
+ }
+ return;
+}
+
+sub dump_si{
+ my %stack_info = (
+ stack => \@PL_stack,
+ markstack => \@PL_markstack,
+ cxstack => \@PL_cxstack,
+ scopstack => \@PL_scopestack,
+ savestack => \@PL_savestack,
+ tmps => \@PL_tmps,
+ );
+
+ ddx([\%stack_info]);
+}
+
+sub not_implemented{
+ if(!@_){
+ if($PL_op && is_not_null($PL_op)){
+ @_ = ($PL_op->name);
+ }
+ else{
+ @_ = (caller 0)[3];
+ }
+ }
+
+ push @_, ' is not implemented';
+ goto &Carp::confess;
+}
+
+
+sub call_sv{ # perl.h
+ my($sv, $flags) = @_;
+
+ if($flags & G_DISCARD){
+ ENTER;
+ SAVETMPS;
+ }
+
+ my $cv = $sv->toCV();
+
+ my $old_op = $PL_op;
+ my $old_cop = $PL_curcop;
+
+ $PL_op = Acme::Perl::VM::OP_CallSV->new(
+ cv => $cv,
+ next => NULL,
+ flags => OP_GIMME_REVERSE($flags),
+ );
+ $PL_curcop = $PL_op;
+
+ PUSH($cv);
+ my $oldmark = TOPMARK;
+
+ $PL_runops->();
+
+ my $retval = $#PL_stack - $oldmark;
+
+ if($flags & G_DISCARD){
+ $#PL_stack = $oldmark;
+ $retval = 0;
+ FREETMPS;
+ LEAVE;
+ }
+
+ $PL_op = $old_op;
+ $PL_curcop = $old_cop;
+
+ return $retval;
+}
+
+sub run_block(&@){
+ my($code, @args) = @_;
+
+ if(APVM_DUMMY){
+ return $code->(@args);
+ }
+ local $SIG{__DIE__} = \&Carp::confess if APVM_DEBUG;
+ local $SIG{__WARN__} = \&Carp::cluck if APVM_DEBUG;
+
+ ENTER;
+ SAVETMPS;
+
+ PUSHMARK;
+ PUSH(@args);
+
+ my $gimme = want2gimme(wantarray);
+ my $mark = $#PL_stack - call_sv(B::svref_2object($code), $gimme);
+ my @retval = mark_list($mark);
+
+ FREETMPS;
+ LEAVE;
+
+ if($gimme == G_SCALAR){
+ return $retval[-1];
+ }
+ elsif($gimme == G_ARRAY){
+ return @retval;
+ }
+
+ return;
+}
+
+package
+ Acme::Perl::VM::OP_CallSV;
+
+use Mouse;
+
+has cv => (
+ is => 'ro',
+ isa => 'B::CV',
+
+ required => 1,
+);
+
+has next => (
+ is => 'ro',
+ isa => 'B::OBJECT',
+
+ required => 1,
+);
+
+has flags => (
+ is => 'ro',
+ isa => 'Int',
+
+ required => 1,
+);
+
+sub class(){ 'OP' }
+sub name(){ 'entersub' }
+sub desc(){ 'subroutine entry' }
+
+sub file(){ __FILE__ }
+sub line(){ 0 }
+
+sub isa{
+ shift;
+ return B::COP->isa(@_);
+}
+
+__PACKAGE__->meta->make_immutable();
+
+package
+ Acme::Perl::VM::Alias;
+
+
+sub TIESCALAR{
+ my($class, $scalar_ref) = @_;
+ return bless [$scalar_ref], $class;
+}
+sub FETCH{
+ return ${ $_[0]->[0] }
+}
+sub STORE{
+ ${ $_[0]->[0] } = $_[1];
+ return;
+}
+
+
+1;
+__END__
+
+=head1 NAME
+
+Acme::Perl::VM - An implementation of Perl5 Virtual Machine in Pure Perl (APVM)
+
+=head1 VERSION
+
+This document describes Acme::Perl::VM version 0.0.5.
+
+=head1 SYNOPSIS
+
+ use Acme::Perl::VM;
+
+ run_block{
+ print "Hello, APVM world!\n",
+ };
+
+=head1 DESCRIPTION
+
+C<Acme::Perl::VM> is a Perl5 Virtual Machine implemented in Pure Perl.
+
+=head1 DEPENDENCIES
+
+Perl 5.8.1 or later.
+
+=head1 BUGS
+
+No bugs have been reported.
+
+Please report any bugs or feature requests to the author.
+
+=head1 AUTHOR
+
+Goro Fuji (gfx) E<lt>gfuji(at)cpan.orgE<gt>.
+
+=head1 SEE ALSO
+
+L<perlapi>.
+
+L<perlhack>.
+
+F<pp.h> for PUSH/POP macros.
+
+F<pp.c>, F<pp_ctl.c>, and F<pp_hot.c> for ppcodes.
+
+F<op.h> for opcodes.
+
+F<cop.h> for COP and context blocks.
+
+F<scope.h> and F<scope.c> for scope stacks.
+
+F<pad.h> and F<pad.c> for pad variables.
+
+F<run.c> for runops.
+
+L<B::Concise>.
+
+L<Devel::Optrace>.
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright (c) 2009, Goro Fuji (gfx). Some rights reserved.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
264 lib/Acme/Perl/VM/B.pm
@@ -0,0 +1,264 @@
+package Acme::Perl::VM::B;
+
+use strict;
+use warnings;
+
+use Exporter qw(import);
+
+use B();
+our @EXPORT = grep{ /^[A-Z]/ } @B::EXPORT_OK; # constants
+push @EXPORT, qw(sv_undef svref_2object);
+B->import(@EXPORT);
+
+unless(defined &OPpPAD_STATE){
+ constant->import(OPpPAD_STATE => 0x00);
+ push @EXPORT, qw(OPpPAD_STATE);
+}
+
+push @EXPORT, qw(NULL TRUE FALSE USE_ITHREADS sv_yes sv_no);
+use constant {
+ NULL => bless(\do{ my $addr = 0 }, 'B::SPECIAL'),
+ TRUE => 1,
+ FALSE => 0,
+ USE_ITHREADS => defined(&B::regex_padav),
+
+ sv_yes => B::sv_yes,
+ sv_no => B::sv_no,
+};
+
+package
+ B::OBJECT;
+
+use B qw(class);
+
+sub dump{
+ my($obj) = @_;
+ require Devel::Peek;
+ Devel::Peek::Dump($obj->object_2svref);
+ return;
+}
+
+package
+ B::OP;
+
+sub dump{
+ my($obj) = @_;
+ require B::Debug;
+
+ $obj->debug;
+ return;
+}
+
+package
+ B::SPECIAL;
+
+my %special_sv = (
+ ${ B::sv_undef() } => \(undef),
+ ${ B::sv_yes() } => \(1 == 1),
+ ${ B::sv_no() } => \(1 != 1),
+);
+
+unless(@B::specialsv_name){
+ @B::specialsv_name = qw(
+ Nullsv
+ &PL_sv_undef
+ &PL_sv_yes
+ &PL_sv_no
+ pWARN_ALL
+ pWARN_NONE
+ pWARN_STD
+ );
+}
+
+sub object_2svref{
+ my($obj) = @_;
+
+ return $special_sv{ $$obj } || do{
+ Carp::confess($obj->special_name, ' is not a normal SV object');
+ };
+}
+
+sub setval{
+ my($obj) = @_;
+
+ Acme::Perl::VM::apvm_die('Modification of read-only value (%s) attempted', $obj->special_name);
+}
+
+sub STASH(){ undef }
+
+sub POK(){ 0 }
+sub ROK(){ 0 }
+
+sub special_name{
+ my($obj) = @_;
+ return $B::specialsv_name[$$obj] || sprintf 'SPECIAL(0x%x)', $$obj;
+}
+
+package
+ B::SV;
+
+# for sv_setsv()
+sub setsv{
+ my($dst, $src) = @_;
+
+ my $dst_ref = $dst->object_2svref;
+ ${$dst_ref} = ${$src->object_2svref};
+ bless $dst, ref(B::svref_2object( $dst_ref ));
+
+ return $dst;
+}
+
+# for sv_setpv()/sv_setiv()/sv_setnv() etc.
+sub setval{
+ my($dst, $val) = @_;
+
+ my $dst_ref = $dst->object_2svref;
+ ${$dst_ref} = $val;
+ bless $dst, ref(B::svref_2object( $dst_ref ));
+
+ return $dst;
+}
+
+sub clear{
+ my($sv) = @_;
+
+ ${$sv->object_2svref} = undef;
+ return;
+}
+
+sub toCV{
+ my($sv) = @_;
+ Carp::croak(sprintf 'Cannot convert %s to a CV', B::class($sv));
+}
+
+sub STASH(){ undef }
+
+package
+ B::PVMG;
+
+sub ROK{
+ my($obj) = @_;
+ my $dummy = ${ $obj->object_2svref }; # invoke mg_get()
+ return $obj->SUPER::ROK;
+}
+
+package
+ B::CV;
+
+sub toCV{ $_[0] }
+
+sub clear{
+ Carp::croak('Cannot clear a CV');
+}
+
+sub ROK(){ 0 }
+
+package
+ B::GV;
+
+
+sub toCV{ $_[0]->CV }
+
+sub clear{
+ Carp::croak('Cannot clear a CV');
+}
+
+sub ROK(){ 0 }
+
+package
+ B::AV;
+
+sub setsv{
+ my($sv) = @_;
+ Carp::croak('Cannot call setsv() for ' . B::class($sv));
+}
+
+sub clear{
+ my($sv) = @_;
+
+ @{$sv->object_2svref} = ();
+ return;
+}
+
+unless(__PACKAGE__->can('OFF')){
+ # some versions of B::Debug requires this
+ constant->import(OFF => 0);
+}
+
+sub ROK(){ 0 }
+
+package
+ B::HV;
+
+sub ROK(){ 0 }
+
+*setsv = \&B::AV::setsv;
+
+sub clear{
+ my($sv) = @_;
+
+ %{$sv->object_2svref} = ();
+ return;
+}
+
+sub fetch{
+ my($hv, $key, $lval) = @_;
+
+ if($lval){
+ return B::svref_2object(\$hv->object_2svref->{$key});
+ }
+ else{
+ my $ref = $hv->object_2svref;
+
+ if(exists $ref->{$key}){
+ return B::svref_2object(\$ref->{$key});
+ }
+ else{
+ return Acme::Perl::VM::B::NULL;
+ }
+ }
+}
+
+sub fetch_ent{
+ my($hv, $keysv, $lval) = @_;
+ return $hv->fetch(${ $keysv->object_2svref }, $lval);
+}
+
+sub exists{
+ my($hv, $key) = @_;
+ return exists $hv->object_2svref->{$key};
+}
+sub exists_ent{
+ my($hv, $keysv) = @_;
+ return exists $hv->object_2svref->{${ $keysv->object_2svref}};
+}
+
+sub store{
+ my($hv, $key, $val) = @_;
+
+ $hv->object_2svref->{$key} = ${ $val->object_2svref };
+ return B::svref_2object(\$hv->object_2svref->{$key}) if defined wantarray;
+}
+sub store_ent{
+ my($hv, $keysv, $val) = @_;
+
+ $hv->object_2svref->{${ $keysv->object_2svref }} = ${ $val->object_2svref };
+ return B::svref_2object(\$hv->object_2svref->{${ $keysv->object_2svref }}) if defined wantarray;
+}
+1;
+
+__END__
+
+=head1 NAME
+
+Acme::Perl::VM::B - Extra B functions and constants
+
+=head1 SYNOPSIS
+
+ use Acme::Perl::VM;
+
+=head1 SEE ALSO
+
+L<Acme::Perl::VM>.
+
+=cut
288 lib/Acme/Perl/VM/Context.pm
@@ -0,0 +1,288 @@
+package Acme::Perl::VM::Context;
+use Mouse;
+
+
+sub type{
+ (my $type = ref($_[0])) =~ s/^Acme::Perl::VM::Context:://;
+
+ return $type;
+}
+
+__PACKAGE__->meta->make_immutable();
+
+package Acme::Perl::VM::Context::BLOCK;
+use Mouse;
+use Acme::Perl::VM qw($PL_comppad);
+
+extends 'Acme::Perl::VM::Context';
+
+has gimme => (
+ is => 'rw',
+ isa => 'Int',
+
+ required => 1,
+);
+has oldsp => (
+ is => 'rw',
+ isa => 'Int',
+
+ required => 1
+);
+has oldcop => (
+ is => 'rw',
+ isa => 'B::COP',
+
+ required => 1,
+);
+has oldmarksp => (
+ is => 'rw',
+ isa => 'Int',
+
+ required => 1,
+);
+has oldscopesp => (
+ is => 'rw',
+ isa => 'Int',
+
+ required => 1,
+);
+
+sub CURPAD_SAVE{
+ my($cx) = @_;
+
+ $cx->oldcomppad($PL_comppad);
+ return;
+}
+
+sub CURPAD_SV{
+ my($cx, $ix) = @_;
+
+ return $cx->oldcomppad->ARRAYelt($ix);
+}
+
+
+__PACKAGE__->meta->make_immutable();
+
+package Acme::Perl::VM::Context::SUB;
+use Mouse;
+extends 'Acme::Perl::VM::Context::BLOCK';
+
+has cv => (
+ is => 'rw',
+ isa => 'B::CV',
+
+ required => 1,
+);
+
+has olddepth => (
+ is => 'rw',
+ isa => 'Int',
+);
+has hasargs => (
+ is => 'rw',
+ isa => 'Bool',
+
+ required => 1,
+);
+
+has retop => (
+ is => 'rw',
+ isa => 'B::OBJECT', # NULL or B::OP
+
+ required => 1,
+);
+
+has oldcomppad => (
+ is => 'rw',
+ isa => 'B::AV',
+);
+has savearray => (
+ is => 'rw',
+ isa => 'ArrayRef',
+);
+has argarray => (
+ is => 'rw',
+ isa => 'B::AV',
+);
+
+has lval => (
+ is => 'rw',
+ isa => 'Bool',
+);
+
+sub BUILD{
+ my($cx) = @_;
+
+ $cx->olddepth($cx->cv->DEPTH);
+ return;
+}
+
+__PACKAGE__->meta->make_immutable();
+
+package Acme::Perl::VM::Context::EVAL;
+use Mouse;
+extends 'Acme::Perl::VM::Context::BLOCK';
+
+__PACKAGE__->meta->make_immutable();
+
+package Acme::Perl::VM::Context::LOOP;
+use Mouse;
+extends 'Acme::Perl::VM::Context::BLOCK';
+
+use Acme::Perl::VM qw($PL_op $PL_curcop);
+
+has label => (
+ is => 'rw',
+ isa => 'Maybe[Str]',
+);
+has resetsp => (
+ is => 'rw',
+ isa => 'Int',
+
+ required => 1,
+);
+has myop => (
+ is => 'rw',
+ isa => 'B::LOOP',
+);
+has nextop => (
+ is => 'rw',
+ isa => 'B::OP',
+);
+
+sub BUILD{
+ my($cx) = @_;
+
+ $cx->label($PL_curcop->label);
+ $cx->myop($PL_op);
+ $cx->nextop($PL_op->nextop);
+
+ return;
+}
+
+sub ITERVAR(){ undef }
+
+__PACKAGE__->meta->make_immutable();
+
+package Acme::Perl::VM::Context::FOREACH;
+use Mouse;
+use Acme::Perl::VM::B qw(USE_ITHREADS);
+extends 'Acme::Perl::VM::Context::LOOP';
+
+has padvar => (
+ is => 'rw',
+ isa => 'Bool',
+
+ required => 1,
+);
+has for_def => (
+ is => 'rw',
+ isa => 'Bool',
+
+ required => 1,
+);
+
+has iterdata => (
+ is => 'rw',
+ isa => 'Defined',
+
+ required => 1,
+);
+if(USE_ITHREADS){
+ has oldcomppad => (
+ is => 'rw',
+ isa => 'B::AV',
+ );
+}
+
+has itersave => (
+ is => 'rw',
+);
+has iterlval => (
+ is => 'rw',
+);
+has iterary => (
+ is => 'rw',
+);
+has iterix => (
+ is => 'rw',
+ isa => 'Int',
+);
+has itermax => (
+ is => 'rw',
+ isa => 'Int',
+);
+
+sub type(){ 'LOOP' } # this is a LOOP
+
+sub BUILD{
+ my($cx) = @_;
+ $cx->ITERDATA_SET($cx->iterdata);
+ return;
+}
+
+
+sub ITERVAR{
+ my($cx) = @_;
+ if(USE_ITHREADS){
+ if($cx->padvar){
+ return $cx->CURPAD_SV($cx->iterdata);
+ }
+ else{
+ return $cx->iterdata->SV;
+ }
+ }
+ else{
+ return $cx->iterdata;
+ }
+}
+sub ITERDATA_SET{
+ my($cx, $idata) = @_;
+ if(USE_ITHREADS){
+ $cx->CURPAD_SAVE();
+ }
+
+ $cx->itersave($cx->ITERVAR);
+}
+
+__PACKAGE__->meta->make_immutable();
+
+package Acme::Perl::VM::Context::GivenWhen;
+use Mouse;
+extends 'Acme::Perl::VM::Context::BLOCK';
+
+__PACKAGE__->meta->make_immutable();
+
+package Acme::Perl::VM::Context::GIVEN;
+use Mouse;
+extends 'Acme::Perl::VM::Context::GivenWhen';
+
+__PACKAGE__->meta->make_immutable();
+
+package Acme::Perl::VM::Context::WHEN;
+use Mouse;
+extends 'Acme::Perl::VM::Context::GivenWhen';
+
+__PACKAGE__->meta->make_immutable();
+
+package Acme::Perl::VM::Context::SUBST;
+use Mouse;
+extends 'Acme::Perl::VM::Context';
+
+__PACKAGE__->meta->make_immutable();
+
+__END__
+
+=head1 NAME
+
+Acme::Perl::VM::Context - Context classes for APVM
+
+=head1 SYNOPSIS
+
+ use Acme::Perl::VM;
+
+=head1 SEE ALSO
+
+L<Acme::Perl::VM>.
+
+=cut
302 lib/Acme/Perl/VM/JA.pod
@@ -0,0 +1,302 @@
+
+=encoding utf-8
+
+=head1 NAME
+
+Acme::Perl::VM::JA - Pure PerlによるPerl5仮想マシンの実装(AVPM)
+
+=head1 SYNOPSIS
+
+ use Acme::Perl::VM;
+
+ run_block{
+ print "Hello, APVM world!\n";
+ };
+
+
+=head1 DESCRIPTION
+
+C<Amce::Perl::VM>(APVM)はPure Perlで実装されたPerl5の仮想マシンです。
+
+Perlディストリビューションにはコンパイルされた構文木にアクセスするためのモジュールが用意されており,B<B - The Perl Compiler>と呼ばれています。
+APVMはこのBモジュールを利用して構文木を解釈・実行するモジュールです。
+
+この文書では,Perl5の仮想マシンについて概説しつつ,APVMとPerl5実装との対応について解説します。
+
+=head2 The Perl5 Virtual Machine
+
+Perl5の仮想マシンはスタックマシンであり,組み込み演算子やサブルーチンなどの手続きの引数と戻り値を,スタックを通じてやり取りします。
+
+この仮想マシンのマシンコードはopcodeと呼ばれ,これがコンパイルされたPerlプログラムの最小単位となります。opcodeはさらにデータと手続きからなるオブジェクトとして表現され,その手続きはppcode(PUSH/POP code)と呼ばれる関数として実現されます。
+
+opcodeオブジェクトは他のopcodeオブジェクトへのリンクを持つ木構造を成しており,このopcodeの木を構文木と呼びます。したがって,Perlプログラムを実行するというのは,opcodeを実行しつつ,この木構造をたどって行く過程ということになります。
+
+ここでは以下のPerlコードを例にとり,プログラムの実行を追っていきます:
+
+ print(10 + 20);
+
+まず,このコードをコンパイルすると,以下のような構文木が生成されます:
+
+ nextstate # ステートメントの始まり
+ print # 引数リストを印字
+ pushmark # 可変長引数のためのマーク
+ add # 加算演算
+ const(10) # 定数[10]
+ const(20) # 定数[20]
+
+構文木は子ノードから実行されるので,この構文木を解釈すると以下の順になります。
+
+ nextstate
+ pushmark
+ const(10)
+ const(20)
+ add
+ print
+
+それぞれのopcodeは必要に応じてスタックから引数をポップし,戻り値をプッシュします。opcodeの実行とスタックの中身を同時に表すと以下のようになります。
+
+ nextstate ()
+ pushmark () # mark = -1 (MARKについては後のセクションで解説)
+ const(10) (10) # スタックに値をPUSH
+ const(20) (10, 20) # スタックに値をPUSH
+ add (30) # 値を2つPOPし,演算結果をPUSH
+ print (1) # mark+1からTOPまでを印字し,結果(真)をPUSH
+
+これが構文木を解釈する基本的な流れです。プログラムの分岐やサブルーチンの呼び出しなどがあると更に複雑になりますが,一連の流れは同じです。
+
+以下のセクションでは,仮想マシンの実装の中で特に重要なコンポーネントについて説明します。
+
+=head2 The Perl Stack (PL_stack_base)
+
+Perlプログラムの手続きと戻り値のために使われるスタックです。
+このスタックは組み込み関数とサブルーチンの両方で使われます。
+
+現在のperl5の実装では,このスタックはCの配列で表現され,必要に応じてC<realloc()>で拡張されます。スタックの先頭はスタックポインタ(C<PL_stack_sp>)として参照できるのですが,ppcode内ではこのグローバルなスタックポインタを一旦ローカルにコピーします(C<dSP>)。C<PUSHs>/C<POPs>/C<TOPs>などのマクロはこのローカルコピーを参照します。そしてスタックポインタを使った操作が終わったところでC<PUTBACK>マクロによりローカルスタックポインタをグローバルスタックポインタ変数に戻します。なお,C<SPAGAIN>マクロはローカルスタックポインタ変数をグローバルスタックポインタで再初期化するマクロで,スタックを操作する可能性のあるPerl API(C<call_sv()>など)を呼び出した後に使用します。
+
+APVMではこれはPerlの配列で表現され,スタックポインタは配列の最後の添え字です。
+ローカルコピーは作りません。
+
+AVPMとの対応:
+ perl APVM
+
+ PL_stack_base @PL_stack
+ PL_stack_sp $#PL_stack
+ dSP (nothing)
+ SP $#PL_stack
+ TOPs TOP
+ PUSHs(sv) PUSH($sv)
+ POPs POP
+ SPAGAIN (nothing)
+ PUTBACK (nothing)
+ EXTEND(SP, n) (nothing)
+
+See also F<pp.h>.
+
+=head2 The Perl Stack Marker (PL_markstack)
+
+可変長引数を扱うためのスタックのマーカーです。
+
+二項演算子などは引数の数が固定ですが,C<print>のように引数の数が可変長である組み込み関数もあります。可変長引数を扱うためには,引数スタック中で引数が始まる位置を保存する必要があります。また,このマーカーは入れ子になる可能性があるので,このマーカーそれ自体もスタックとして表現されます。
+
+可変長引数の開始を宣言するためには,C<PUSHMARK(SP)>マクロを使います。
+また,C<dMARK>マクロによりスタックから値をポップし,C<MARK>マクロを使えるようにします。
+
+APVMとの対応:
+ perl APVM
+
+ PUSHMARK(SP) PUSHMARK($#PL_stack)
+ TOPMARK TOPMARK
+ POPMARK POPMARK
+ dMARK my $mark = POPMARK
+ MARK++ $mark++
+ *MARK $PL_stack[$mark]
+
+ dORIGMARK my $origmark = $mark
+ SP = ORIGMARK $#PL_stack = $origmark
+
+See also F<pp.h>.
+
+=head2 The Opcode Family
+
+Perlプログラムの最小単位である,手続きとデータを持ったオブジェクトです。
+opcodeクラス群はCの構造体の先頭メンバをいくつか共有する構造体群として表現されます。
+
+opcodeオブジェクトの持つ手続きは対応するppcodeであり,C<op_ppaddr>メンバで参照します。
+データはPerlの値やCの値,または他のopcodeへのリンクです。
+
+各opcodeオブジェクトは名前と外部出力用の説明を持ち,それぞれC<OP_NAME(op)>,C<OP_DESC(op)>マクロで得ることができます。
+
+See also F<op.h>, F<cop.h>, F<opcode.h> and F<opcode.pl>.
+
+=head2 The PPcodes
+
+opcodeが持つ手続きで,実際に行う処理を実装した関数です。
+
+たとえば,OP_CONSTに対応するppcodeは以下のようになっています:
+
+ /* in pp_hot.c (5.8.8) */
+ PP(pp_const)
+ {
+ dSP;
+ XPUSHs(cSVOP_sv);
+ RETURN;
+ }
+
+マクロをいくつか展開すると以下のようになります。
+
+ PP(pp_const)
+ {
+ dSP;
+ EXTEND(SP, 1);
+ PUSHs(cSVOPx_sv(PL_op));
+ PUTBACK;
+ return PL_op->next;
+ }
+
+一つひとつを順に追うと以下のようになります。
+
+=over 4
+
+=item C<dSP>
+
+ローカルスタックポインタ変数(SP)を宣言し,グローバルスタックポインタの値で初期化します。
+
+=item C<EXTEND(SP, 1)>
+
+スタックポインタに値を1つプッシュすることを宣言します。このとき,必要に応じてスタックは拡張されます。
+
+=item C<cSVOPx_sv(PL_op)>
+
+現在実行中のopcodeのsvフィールドを参照します。
+
+=item C<PUSH(sv)>
+
+スタックポインタを通じて引数スタックに値を1つプッシュします。
+
+=item C<PUTBACK>
+
+ローカルスタックポインタをグローバルスタックポインタ変数に戻します。
+
+=item C<< return PL_op->op_next >>
+
+次に実行するopcodeを返します。
+
+OP_CONSTであれば可能性のあるプログラムの経路は常に一つですが,OP_COND_EXPRのような制御を担うopcodeであればC<< PL_op->next >>以外のopcodeを返すことがあります。
+
+=back
+
+ppcodeはopcodeオブジェクトのC<op_ppaddr>メンバを通じて取得・変更することができます。このC<op_ppaddr>をC<PL_check>というコンパイル時フックテーブルを通じて変更し,プログラムの挙動を変える手法がB<PL_check hack>として知られています。たとえば,C<autobox>はこのC<PL_check>ハックを用いてプリミティブ値に対するメソッド呼び出しを実現しています。
+
+See also F<pp.c>, F<pp_hot.c>, F<pp_ctl.c>, F<pp_sys.c>, F<pp_sort.c> and F<pp_pack.c>.
+
+=head2 The interpreter loop (PL_runops)
+
+構文木を解釈・実行するループの実装です。
+
+デフォルトでは,F<run.c>にあるC<Perl_runops_standard()>が用いられます。
+これは,perl 5.8.8では以下のようになっています:
+
+ int
+ Perl_runops_standard(pTHX)
+ {
+ while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX))) {
+ PERL_ASYNC_CHECK();
+ }
+
+ TAINT_NOT;
+ return 0;
+ }
+
+C<PL_op>は現在実行中のopcodeオブジェクトが入っているスレッドグローバルな変数です。C<op_ppaddr>はopcodeに対応したppcodeが入っており,ppcodeは次に実行するopcodeを返すことになっています。
+
+C<PERL_ASYNC_CHECK()>は単にセーフシグナルの処理なので実行には関係ありません。したがって,インタプリタループの実体は一行しかありません。
+
+ところで,このようなopcodeの多態性を利用した実行ループと対極にあるのが,switch文やifの連鎖による分岐を利用した実行ループです。perlの実装の中にはそのような実行ループも存在します。たとえば,F<scope.c>にあるC<leave_scope()>はまさに巨大なswitch文を利用した実行ループでスコープの後処理を行っています。
+
+インタプリタループについては,APVMのC<runops_standard()>でも実装はほぼ同じです。
+
+See also F<run.c>.
+
+=head2 Other components
+
+この他にもいくつか重要なコンポーネントがありますが,それらについては後日解説します。
+
+=over 4
+
+=item *
+
+The Scratchpads (PL_comppad and PL_curpad)
+
+=item *
+
+The Save Stack (PL_savestack)
+
+=item *
+
+The Temporary Value Stack (PL_tmps)
+
+=item *
+
+The Context and Block Stack (PL_cxstack)
+
+=item *
+
+The Stack Infomation (PL_curstackinfo)
+
+=back
+
+なお,この文書ではPerlの値の実装であるSV構造体群については解説しません。
+SV構造体群のAPIについてはL<perlapi>を,その実装についてはF<sv.[hc]>, F<av.[hc]>, F<hv.[hc]>, F<gv.[hc]>を参照してください。
+
+=head1 DEBUGGING
+
+=head2 Opcode Tracing
+
+perlをC<-DDEBUGGING>コンパイルオプションを指定してビルドすると,プログラムの実行をopcodeレベルでトレースできるようになります。C<perl>コマンドにC<-Dt>またはC<-Dts>を渡して実行してみてください。
+
+APVMにもopcodeトレース機能があります。環境変数C<APVM_DEBUG>にC<trace>を指定すると,opcodeトレースを行います。また,C<stack>を指定すると,opcodeトレースと同時に引数スタックの中身も報告します。
+
+Perlの標準モジュールC<B::Concise>でも構文木を出力することができます。このときC<-exec>オプションを渡すと,実行順にopcodeを並べて出力します。ただし,C<B::Concise>では静的な解析しかできません。
+
+CPANにあるC<Devel::Optrace>はAPVMのopcodeトレース機能を標準Perl VMで使えるようにしたモジュールです。このモジュールはC<-DDEBUGGING>が指定されていないperlでも利用できます。
+
+=head1 NOTES
+
+このモジュールは2009年4月22日に東京で開催されたB<Shibuya.pm テクニカルトーク#11>で発表されました。
+
+=head1 AUTHOR
+
+Goro Fuji (gfx) E<lt>gfuji(at)cpan.orgE<gt>.
+
+=head1 SEE ALSO