perlvm - A Perl Virtual Machine

Nurse says I'm not allowed to work on this any more.

% perl -MO=Bytecode -e 'print "Hello".undef, ", world\n".undef' > byte
-e syntax OK
% ./perlvm < byte

-------- PERL OUTPUT --------
                                                                       pp_enter
                                                                   pp_nextstate
                                                                    pp_pushmark
                                                                       pp_const
                                                                       pp_undef
                                                                      pp_concat
                                                                       pp_const
                                                                       pp_undef
                                                                      pp_concat
                                                                       pp_print
Hello, world
                                                                       pp_leave

-------- PERL OUTPUT --------
Freeing unreferenced scalar 1
Freeing unreferenced scalar 10, 5


#!/usr/bin/perl
# perlvm - A Perl Virtual Machine.
use B::Disassembler qw(disassemble_fh);
use Data::Dumper;
use FileHandle;
use Opcode qw(opset_to_ops full_opset);
my $DEBUG=1;
my @opnames = opset_to_ops(full_opset);

my $perl= new Perl; # Scared yet?
my $fh;
if (@ARGV == 0) {
    $fh = \*STDIN;
} elsif (@ARGV == 1) {
    $fh = new FileHandle "<$ARGV[0]";
} else {
    die "Usage: $0 [filename]\n";
}


# Instruction codes go here. Used to be goto &$AUTOLOAD, but that's ick.
my %instr = (
newsv => sub { my $where=shift; $perl->cursv(\$perl->svtable($where, new SV))},
newop => sub { my $where=shift; $perl->curop(\(new OP)); },
stsv  => sub { my $where=shift; $perl->svtable($where,${$perl->cursv}); },
stop  => sub { my $where=shift; $perl->optable($where,${$perl->curop}); },
ldspecsv => sub { my $sv= new SV; 
	$sv->value((undef,undef,1,0)[shift()]); $perl->cursv(\$sv);
},
ldsv => sub { $perl->cursv(\($perl->svtable(shift)))},
ldop => sub { $perl->curop(\($perl->optable(shift)))},
sv_refcnt => sub { ${$perl->cursv}->refcnt(shift()); },
sv_refcnt_add => sub { my $sv = ${$perl->cursv}; 
				$sv->refcnt($sv->refcnt+shift()); },
sv_flags => sub { ${$perl->cursv}->flags(@_);    },
op_flags => sub { ${$perl->curop}->flags(@_);    },
op_targ  => sub { ${$perl->curop}->targ(@_);     },
op_next  => sub { ${$perl->curop}->next(@_);     },
op_sibling => sub { ${$perl->curop}->sibling(@_);},
op_children => sub { ${$perl->curop}->children(@_);},
op_seq   => sub { ${$perl->curop}->seq(@_);      },
op_first => sub { ${$perl->curop}->first(@_);    },
op_last  => sub { ${$perl->curop}->last(@_);     },
op_redoop => sub { my $op = ${$perl->curop};
	my $redo = shift; # Check first
	die "Botched" unless ref $perl->optable($redo) eq "OP";
	$op->redoop(\($perl->optable($redo)));
},
op_nextop => sub { my $op = ${$perl->curop};
	my $next = shift;
	die "Botched" unless ref $perl->optable($next) eq "OP";
	$op->nextop(\($perl->optable($next)));
},
op_lastop => sub { my $op = ${$perl->curop};
	my $last = shift;
	die "Botched" unless ref $perl->optable($last) eq "OP";
	$op->lastop(\($perl->optable($last)));
},
op_type => sub  { ${$perl->curop}->type($opnames[$_[0]]); },
op_private => sub { ${$perl->curop}->private(@_);       },
op_other   => sub { ${$perl->curop}->other(@_);         },
newpv      => sub { $perl->curpv(perlify(shift));       },
op_sv      => sub { ${$perl->curop}->sv($perl->svtable(shift)) },
gv_fetchpv => sub { $perl->curpv($perl->stash(shift))   }, ## INCORRECT
cop_stashpv => sub { ${$perl->curop}->pv($perl->curpv)  },
cop_file  => sub  { ${$perl->curop}->file($perl->curpv) },
cop_label => sub  { ${$perl->curop}->label($perl->curpv)},
cop_line  => sub  { ${$perl->curop}->line(shift)        },
cop_seq   => sub  { ${$perl->curop}->seq(shift)         },
cop_arybase => sub { ${$perl->curop}->arybase(shift)    },
cop_warnings => sub { ${$perl->curop}->warnings(shift)  },
nop       => sub {},
xpv       => sub { ${$perl->cursv}->value($perl->curpv) },
xnv       => sub { ${$perl->cursv}->value(shift) },
xiv32     => sub { ${$perl->cursv}->value(shift) },
main_root => sub {},
curpad    => sub {},
main_start => sub { # Let's roll.
	my $curop=shift;
	print "\n-------- PERL OUTPUT --------\n";
	while ($curop) {
		my $cop = $perl->{optable}->{$curop};
		my $doit = "pp_".$cop->type;
		print " "x(79-length($doit)),$doit,"\n" if $DEBUG;
		$perl->$doit($cop); # XXX This isn't nice.
		last unless ref $perl->{optable}->{$cop->next} eq "OP";
		$curop = $cop->next;
	}
	print "\n-------- PERL OUTPUT --------\n";
}
);

# Here's the runner.
disassemble_fh($fh, 
	sub {
		my $ins = shift; 
		if (exists $instr{$ins}) { $instr{$ins}->(@_); }
		else { warn "Can't do $ins yet\n" unless $DEBUG}
	}
);
$perl->gc(); # Post-run cleanup.
print "\n";

# Fix a PV to make it look Perlish.
sub perlify {
	my $pv = shift;
	$pv =~ s/"(.*)"/$1/;
	$pv =~ s/\\000//g;
	$pv;
}
#########################################################################
# Utility classes : SVs and OPs
package SV;
sub new { bless {}, shift; }
sub AUTOLOAD { my $self = shift; my $thing = $SV::AUTOLOAD;
    $self->{$thing} = $_[0] if defined $_[0]; return $self->{$thing};
}

package OP;
sub new { bless {}, shift; }
sub AUTOLOAD { my $self = shift; my $thing = $OP::AUTOLOAD;
    $self->{$thing} = $_[0] if defined $_[0]; return $self->{$thing};
}

#########################################################################
# The perl interpreter proper.
package Perl;
sub new { bless {}, shift; }
sub svtable { my ($self, $svno, $what) = @_; 
	# Change this back to an array at some point!
	if (defined $what) { $self->{svtable}->{$svno}=$what ; }
	$self->{svtable}->{$svno}; # XXX Re-array
}
sub optable { my ($self, $opno, $what) = @_; 
	if (defined $what) { $self->{optable}->{$opno}=$what ; }
	$self->{optable}->{$opno}; # XXX array
}

sub gc { # SV-level garbage collection
	my $self=shift;
	my $freeing =0;
	$|=1;
	for (keys %{$self->{svtable}}) {
		my $sv = $perl->{svtable}->{$_};
		next unless ref $sv eq "SV";
		unless ($sv->refcnt) {
			print (($freeing++?", ":"Freeing unreferenced scalar "),$_);
			delete $self->{svtable}->{$_};
		} else {
			print "\n" if $freeing;
			$freeing=0;
		}
	}
}
sub AUTOLOAD { my $self = shift; my $thing = $Perl::AUTOLOAD;
	if ($thing=~/pp_/) {
		unless ($DEBUG) { die "Unimplemented PP $thing"}
		warn "Unimplemented PP $thing";
	}
    $self->{$thing} = $_[0] if defined $_[0]; # Simple get/set
    return $self->{$thing};
}
sub pp_enter () {} sub pp_nextstate () {} # XXX
sub pp_leave () {} sub pp_pushmark  () {} # XXX
sub pp_const { my $self=shift;
	my $op=shift;
	push @{$self->{stack}}, $op->sv;
}
sub pp_print { my $self=shift;
	while (my $sv=shift @{$self->{stack}}) {
		my $pv=$sv->value;
	    $pv =~ s/\\(.)/"\"\\$1\""/eeg; # Unbackwhack, messy.
		print $pv;
	}
}
sub pp_concat {
	my $self=shift;
	my $op=shift;
	my $right=pop @{$self->{stack}};
	my $left=pop @{$self->{stack}};
	unless ($left) { push @{$self->{stack}}, $right; return; }
	$right->value($left->value.$right->value);
	push @{$self->{stack}}, $right;
}
sub pp_undef { # CHEAP HACK
	my $self=shift;
	my $push=new SV;
	$push->value(undef);
	return push (@{$self->{stack}}, $push);
}
sub pp_dump { # Debug a PP op I haven't grokked yet.
	my $op=shift; my $i=0; print "Stack dump!\n";
	for ($perl->{stack}) { print $i++,": ",Data::Dumper::Dumper($_); }
	print "\nOp dump:\n"; print Data::Dumper::Dumper(\$op);
	exit;
}

• perlvm - A Perl Virtual Machine by simon