File Coverage

blib/lib/CPU/Emulator/DCPU16.pm

Criterion	Covered	Total	%
statement	167	217	76.9
branch	51	86	59.3
condition	14	26	53.8
subroutine	29	43	67.4
pod	13	13	100.0
total	274	385	71.1

package CPU::Emulator::DCPU16;

use strict;
use warnings;

use CPU::Emulator::DCPU16::Assembler;
use CPU::Emulator::DCPU16::Disassembler;

use CPU::Emulator::DCPU16::Device::Console;

our $VERSION       = 0.3;
our $MAX_REGISTERS = 8;
our $MAX_MEMORY    = 65536; # 0x10000

=head1 NAME

CPU::Emulator::DCPU16 - an emulator for Notch's DCPU-16 virtual CPU for the game 0x10c

=head1 SYNOPSIS

    open(my $fh, ">:raw", $file) || die "Couldn't read file $file: $!";
    my $program = do { local $/=undef; <$fh> };
    $program    = CPU::Emulator::DCPU16::Assembler->assemble($program) if $file =~ /\.dasm(16)?$/;

    # Create a new CPU and load a file
    my $cpu = CPU::Emulator::DCPU16->new();
    $cpu->load($program);

    # Run it ...
    $cpu->run;
    # ... which is basically the same as
    do { $cpu->step } until $cpu->halt;

=head1 DESCRIPTION

DCPU-16 is a spec for a virtual CPU by Notch from Mojang (of Minecraft fame).

The spec is available here

http://0x10c.com/doc/dcpu-16.txt

=cut


=head1 METHODS

=cut

=head2 new

Create a new CPU.

=cut
sub new {
    my $class = shift;
    my %opts  = @_;
    return bless \%opts, $class;
}

sub _init {
    my $self = shift;
    $self->halt = 0;
    $self->pc   = 0;
    $self->sp   = 0xffff;
    $self->o    = 0;

    $self->{_devices}   = [];

    # TODO these could be done with scalars and bit masks
    $self->{_registers} = [(0x0000) x $MAX_REGISTERS],
    $self->{_memory}    = [(0x0000) x $MAX_MEMORY],

}

=head2 load  [opt[s]]

Load a program. Forces as re-init of the CPU.

You can also do

    my $cpu = CPU::Emulator::DCPU16->load($program, %opts);

which is exactly the same as

    my $cpu = CPU::Emulator::DCPU16->new(%opts);
    $cpu->load($program);

=cut
sub load {
    my $self  = shift;
    my $bytes = shift;
    my %opts  = @_;
    $self     = $self->new(%opts) unless ref($self);
    $self->_init;
    my @bytes = $self->bytes_to_array($bytes);
    die "No program was loaded\n" unless @bytes;
    $self->{_program_top} = scalar(@bytes);
    splice(@{$self->{_memory}}, 0, scalar(@bytes), @bytes);
    return $self;
}

=head2 bytes_to_array

Turn a scalar of bytes into an array of words

=cut
sub bytes_to_array {
    my $class = shift;
    my $bytes = shift;
    my @ret;
    while (my $word = substr($bytes, 0, 2, '')) {
        push @ret, ord($word) * 2**8 + ord(substr($word, 1, 1));
    }
    @ret;
}

=head2 map_device    [opt[s]]

Map a device of the given class to these addresses

=cut
sub map_device {
    my $self  = shift;
    my $dev   = shift;
    my $start = shift;
    my $end   = shift;
    my %opts  = @_;
    push @{$self->{_devices}}, $dev->new($self->{_memory}, $start, $end, %opts);
    $self->{_devices}->[-1];
}

=head2 run [opt[s]]

Run CPU until completion.

Options available are:

=over 4

=item debug

Whether or not we should print debug information and at what level.

Default is 0 (no debug output).

=item limit

Maxinum number of instructions to execute.

Default is 0 (no limit).

=item cycle_penalty

The time penalty for each instruction cycle in milliseconds.

Default is 0 (no penalty)

=item full_memory

Allow the PC to continue past the last instruction of the program (i.e the program_top).

This would allow programs to rewrite themselves into a larger program.

Default is 0 (no access)

=back

=cut
sub run {
    my $self       = shift;
    my %opts       = @_;
    my $count      = 1;
    $opts{limit} ||= 0;
    $opts{debug} ||= 0;
    $self->_debug($self->_dump_header) if $opts{debug}>=1;

    do {
        $self->step(%opts);
        $self->halt = 1 if $opts{limit}>0 and ++$count>$opts{limit};
        $self->halt = 1 if $self->pc >= $self->program_top && !$opts{full_memory};
    } until $self->halt;
}

=head2 step [opt[s]]

Run a single clock cycle of the CPU.

Takes the same options as C.

=cut
sub step {
    my $self = shift;
    my %opts = @_;

    $opts{debug}         ||= 0;
    $opts{cycle_penalty} ||= 0;
    $self->_debug($self->_dump_state) if $opts{debug}>=1;

    my $pc   = $self->pc;
    my $word = $self->memory($self->pc);
    die "Unknown memory at PC ".sprintf("0x%04x",$self->pc)."\n" unless defined $word;
    my $op   = $word & 0x0F;
    my $a    = ($word >> 4) & 0x3f;
    my $b    = ($word >> 10) & 0x3f;

    $self->pc  += 1;
    $self->o    = 0;

    my $cost = 0;

    my $meth;
    # Basic opcodes
    if ($op) {
        $meth = qw(NOOP _SET _ADD _SUB _MUL _DIV _MOD _SHL _SHR _AND _BOR _XOR _IFE _IFN _IFG _IFB)[$op];
        die "Illegal opcode $op\n" unless defined $meth;
    # Defined non-basic opcodes
    } elsif ($a == 0x01) {
        $meth = "_JSR";
    # Reserved non-basic opcodes
    } else {
        die "Illegal extended opcode $a\n";
    }

    my $aa = $self->_get_value($a, \$cost);
    my $bb = $self->_get_value($b, \$cost);

    $self->$meth($aa, $bb, \$cost);
    select(undef, undef, undef, $cost*$opts{cycle_penalty}/1000) if $opts{cycle_penalty}>0;
    $_->tick for @{$self->{_devices}};
    return $cost;
}

=head1 METHODS TO GET THE STATE OF THE CPU

=head2 pc

The current program counter.

=cut
sub pc : lvalue {
    my $self = shift;
    $self->{_pc} = shift if @_;
    $self->{_pc};
}

=head2 sp

The current stack pointer.

=cut
sub sp : lvalue {
    my $self = shift;
    $self->{_sp} = shift if @_;
    $self->{_sp};
}

=head2 o

The current overflow.

=cut
sub o : lvalue {
    my $self = shift;
    $self->{_o} = shift if @_;
    $self->{_o};
}

=head2 halt [halt state]

Halt the CPU or check to see whether it's halted.

=cut
sub halt : lvalue {
    my $self = shift;
    $self->{_halt} = shift if @_;
    $self->{_halt};
}

=head2 program_top

The address of the first memory location after the loaded program.

=cut
sub program_top : lvalue {
    my $self = shift;
    $self->{_program_top} = shift if @_;
    $self->{_program_top};
}

=head2 register

Get or set the value of a register.

=cut
sub register : lvalue {
    my $self = shift;
    return $self->{_registers} unless @_;
    my $loc  = shift; die "Invalid register $loc at pc ".$self->pc." (".sprintf("%02x", $self->pc).")\n" if $loc<0 || $loc>=$MAX_REGISTERS;
    $self->{_registers}[$loc] = shift if @_;
    $self->{_registers}[$loc];
}
# TODO ugly
sub _reg_ref {
    my $self = shift;
    my $loc  = shift; die "Invalid register $loc at pc ".$self->pc." (".sprintf("%02x", $self->pc).")\n" if $loc<0 || $loc>=$MAX_REGISTERS;
    \($self->{_registers}[$loc]);
}

=head2 memory

Get or set the value of a memory location.

=cut
sub memory : lvalue {
    my $self = shift;
    return $self->{_memory} unless @_;
    my $loc  = shift;
    die "Invalid memory $loc at pc ".$self->pc." (".sprintf("%02x", $self->pc).")\n" if $loc<0 || $loc>=$MAX_MEMORY;
    $self->{_memory}[$loc] = shift if @_;
    $self->{_memory}[$loc];
}
# TODO ugly
sub _mem_ref {
    my $self = shift;
    my $loc  = shift;
    die "Invalid memory $loc at pc ".$self->pc." (".sprintf("%02x", $self->pc).")\n" if $loc<0 || $loc>=$MAX_MEMORY;
    \($self->{_memory}[$loc]);
}

sub _dump_header {
    "PC   SP   OV   A    B    C    X    Y    Z    I    J    Instruction\n".
    "---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- -----------";
}

sub _dump_state {
    my $self = shift;
    sprintf("%04x %04x %04x %04x %04x %04x %04x %04x %04x %04x %04x %s",
        $self->pc, $self->sp, $self->o,
        $self->register(0), $self->register(1), $self->register(2), $self->register(3),
        $self->register(4), $self->register(5), $self->register(6), $self->register(7),
        CPU::Emulator::DCPU16::Disassembler->disassemble($self->pc, @{$self->memory}));
}

sub _debug {
    my $self = shift;
    my $mess = shift;
    print "$mess\n";
}

sub _get_value {
    my $self  = shift;
    my $value = shift;
    my $cost  = shift;
    my $ret;
    if ($value < 0x08) {
        $ret = $self->_reg_ref($value);
    } elsif ($value < 0x10) {
        $ret = $self->_mem_ref($self->register($value & 7));
    } elsif ($value < 0x18) {
        $$cost += 1;
        my $next = $self->memory($self->pc++);
        $ret = $self->_mem_ref($next + $self->register($value & 7) & 0xffff);
    } elsif ($value == 0x18) {
        $ret = $self->_mem_ref($self->sp++);
    } elsif ($value == 0x19) {
        $ret = $self->_mem_ref($self->sp);
    } elsif ($value == 0x1A) {
        $ret = $self->_mem_ref($self->sp--);
    } elsif ($value == 0x1B) {
        $ret = \($self->{_sp});
    } elsif ($value == 0x1C) {
        $ret = \($self->{_pc});
    } elsif ($value == 0x1D) {
        $ret = \($self->{_o});
    } elsif ($value == 0x1E) {
        $$cost += 1;
        $ret = $self->_mem_ref($self->memory($self->pc++));
    } elsif ($value == 0x1F) {
        $$cost += 1;
        $ret = $self->_mem_ref($self->pc++);
    } else {
        $ret = ($value - 0x20)
    }
    return ref($ret) ? $ret : \$ret;
}

our %_skiptable = (0x10 => 1, 0x11 => 1, 0x12 => 1, 0x13 => 1, 0x14 => 1, 0x15 => 1, 0x1E => 1, 0x1F => 1);
sub _skip {
    my $self = shift;
    my $cost = shift;
    $$cost++;
    my $op   = $self->memory($self->pc++);
    $self->pc += $_skiptable{$op  >> 10};
    $self->pc += $_skiptable{($op >> 4) & 31} if (($op & 0x0F) == 0);
}

sub _NOOP {
    # Just what it says on the tin
}

sub _JSR {
    my ($self, $a, $b, $cost) = @_;
    $$cost += 2;
    $self->memory(--$self->sp) = $self->pc;
    $self->pc = $$b;

}

# 0x1: SET a, b - sets a to b
sub _SET {
    my ($self, $a, $b, $cost) = @_;
    $$cost += 1;
    $$a = $$b;
}

# 0x2: ADD a, b - sets a to a+b, sets O to 0x0001 if there's an overflow, 0x0 otherwise
sub _ADD {
    my ($self, $a, $b, $cost) = @_;
    $$cost += 2;
    $$a += $$b;
    $self->o = $$a >> 16;
}

# 0x3: SUB a, b - sets a to a-b, sets O to 0xffff if there's an underflow, 0x0 otherwise
sub _SUB {
    my ($self, $a, $b, $cost) = @_;
    $$cost += 2;
    $$a -= $$b;
    $self->o = $$a >> 16;
}

# 0x4: MUL a, b - sets a to a*b, sets O to ((a*b)>>16)&0xffff
sub _MUL {
    my ($self, $a, $b, $cost) = @_;
    $$cost += 2;
    $$a *= $$b;
    $self->o = $$a >> 16;
}

# 0x5: DIV a, b - sets a to a/b, sets O to ((a<<16)/b)&0xffff. if b==0, sets a and O to 0 instead.
sub _DIV {
    my ($self, $a, $b, $cost) = @_;
    $$cost += 3;
    if ($$b) {
        $$a /= $$b;
    } else {
        $$a = 0;
    }
    $self->o = $$a >> 16;
}

# 0x6: MOD a, b - sets a to a%b. if b==0, sets a to 0 instead.
sub _MOD {
    my ($self, $a, $b, $cost) = @_;
    $$cost += 3;
    if ($$b) {
        $$a %= $$b;
    } else {
        $$a = 0;
    }
}

# 0x7: SHL a, b - sets a to a<>16)&0xffff
sub _SHL {
    my ($self, $a, $b, $cost) = @_;
    $$cost += 2;
    $$a <<= $$b;
    $self->o = $$a >> 16;
}

# 0x8: SHR a, b - sets a to a>>b, sets O to ((a<<16)>>b)&0xffff
sub _SHR {
    my ($self, $a, $b, $cost) = @_;
    $$cost += 2;
    $$a >>= $$b;
    $self->o = $$a >> 16;
}

# 0x9: AND a, b - sets a to a&b
sub _AND {
    my ($self, $a, $b, $cost) = @_;
    $$cost += 1;
    $$a &= $$b;
}

# 0xa: BOR a, b - sets a to a|b
sub _BOR {
    my ($self, $a, $b, $cost) = @_;
    $$cost += 1;
    $$a |= $b;
}

# 0xb: XOR a, b - sets a to a^b
sub _XOR {
    my ($self, $a, $b, $cost) = @_;
    $$cost += 1;
    $$a ^= $b;
}

# 0xc: IFE a, b - performs next instruction only if a==b
sub _IFE {
    my ($self, $a, $b, $cost) = @_;
    $$cost += 2;
    $self->_skip($cost) unless $$a+0 == $$b+0;
}

# 0xd: IFN a, b - performs next instruction only if a!=b
sub _IFN {
    my ($self, $a, $b, $cost) = @_;
    $$cost += 2;
    $self->_skip($cost) unless $$a+0 != $$b+0;
}

# 0xe: IFG a, b - performs next instruction only if a>b
sub _IFG {
    my ($self, $a, $b, $cost) = @_;
    $$cost += 2;
    $self->_skip($cost) unless $$a+0 > $$b+0;
}

# 0xf: IFB a, b - performs next instruction only if (a&b)!=0
sub _IFB {
    my ($self, $a, $b, $cost) = @_;
    $$cost += 2;
    $self->_skip($cost) unless ($$a+0 & $$b+0) != 0;
}


=head1 SEE ALSO

L

L

=head1 ACKNOWLEDGEMENTS

Implementation inspiration came from:

=over 4

=item Matt Bell's Javascript implementation (https://github.com/mappum/DCPU-16)

=item Brian Swetland's C Implementation (https://github.com/swetland/dcpu16)

=item Jesse Luehrs's Perl Implementation (https://github.com/doy/games-emulation-dcpu16)

=back

=head1 AUTHOR

Simon Wistow

=head1 COPYRIGHT

Copyright 2011 - Simon Wistow

Released under the same terms as Perl itself.

=head1 DEVELOPMENT

Latest development version available from

https://github.com/simonwistow/CPU-Emulator-DCPU16

=cut

1;