Acme-6502
view release on metacpan or search on metacpan
lib/Acme/6502.pm view on Meta::CPAN
package Acme::6502;
use warnings FATAL => 'all';
use strict;
use Carp;
our $VERSION = '0.77';
# CPU flags
use constant {
N => 0x80,
V => 0x40,
R => 0x20,
B => 0x10,
D => 0x08,
I => 0x04,
Z => 0x02,
C => 0x01
};
use constant FLAGS => 'NVRBDIZC';
# Other CPU constants
use constant {
STACK => 0x0100,
BREAK => 0xFFFE
};
# Opcode to thunk into perlspace
use constant {
ESCAPE_OP => 0x0B,
ESCAPE_SIG => 0xAD
};
BEGIN {
for my $reg ( qw(a x y s p pc) ) {
no strict 'refs';
*{ __PACKAGE__ . "\::get_${reg}" } = sub {
my $self = shift;
return $self->{ reg }->{ $reg };
};
*{ __PACKAGE__ . "\::set_${reg}" } = sub {
my ( $self, $v ) = @_;
$self->{ reg }->{ $reg } = $v;
};
}
}
sub new {
my $class = shift;
my $self = bless { }, $class;
$self->_BUILD( @_ );
return $self;
}
my @OP_CACHE;
sub _BUILD {
my( $self, $args ) = @_;
$args ||= {};
$self->{ mem } = [ ( 0 ) x 65536 ];
$self->{ reg } = {
map { $_ => 0 } qw( a x y s p pc )
};
$self->{ os } = [ ];
$self->{ jumptab } = $args->{ jumptab } || 0xFA00;
$self->{ zn } = [ $self->Z, ( 0 ) x 127, ( $self->N ) x 128 ];
my $bad_inst = $self->can( '_bad_inst' );
@OP_CACHE = (
_inst( # 00 BRK
_push( '($pc + 1) >> 8', '($pc + 1)' ),
_push( '$p | B' ),
'$p = $p | I | B & ~D;',
_jmp_i( BREAK )
),
_inst( _ora( _zpix() ) ), # 01 ORA (zp, x)
$bad_inst, # 02
$bad_inst, # 03
_inst( _tsb( _zp() ) ), # 04 TSB zp
_inst( _ora( _zp() ) ), # 05 ORA zp
_inst( _asl( _zp() ) ), # 06 ASL zp
$bad_inst, # 07
_inst( _push( '$p | R' ) ), # 08 PHP
_inst( _ora( _imm() ) ), # 09 ORA #imm
_inst( _asl( _acc() ) ), # 0A ASL A
$bad_inst, # 0B
_inst( _tsb( _abs() ) ), # 0C TSB zp
_inst( _ora( _abs() ) ), # 0D ORA abs
_inst( _asl( _abs() ) ), # 0E ASL abs
$bad_inst, # 0F BBR0 rel
_inst( _bfz( _rel(), N ) ), # 10 BPL rel
_inst( _ora( _zpiy() ) ), # 11 ORA (zp), y
_inst( _ora( _zpi() ) ), # 12 ORA (zp)
$bad_inst, # 13
_inst( _trb( _zpi() ) ), # 14 TRB (zp)
_inst( _ora( _zpx() ) ), # 15 ORA zp, x
lib/Acme/6502.pm view on Meta::CPAN
_inst( _ror( _absx() ) ), # 7E ROR abs, x
$bad_inst, # 7F BBR7 rel
_inst( _bra( _rel() ) ), # 80 BRA rel
_inst( _sto( _zpix(), '$a' ) ), # 81 STA (zp, x)
$bad_inst, # 82
$bad_inst, # 83
_inst( _sto( _zp(), '$y' ) ), # 84 STY zp
_inst( _sto( _zp(), '$a' ) ), # 85 STA zp
_inst( _sto( _zp(), '$x' ) ), # 86 STX zp
$bad_inst, # 87
_inst( _dec( ( '', '$y' ) ) ), # 88 DEY
_inst( _bit( _imm() ) ), # 89 BIT #imm
_inst( '$a = $x;' . _status( '$a' ) ), # 8A TXA
$bad_inst, # 8B
_inst( _sto( _abs(), '$y' ) ), # 8C STY abs
_inst( _sto( _abs(), '$a' ) ), # 8D STA abs
_inst( _sto( _abs(), '$x' ) ), # 8E STX abs
$bad_inst, # 8F BBS0 rel
_inst( _bfz( _rel(), C ) ), # 90 BCC rel
_inst( _sto( _zpiy(), '$a' ) ), # 91 STA (zp), y
_inst( _sto( _zpi(), '$a' ) ), # 92 STA (zp)
$bad_inst, # 93
_inst( _sto( _zpx(), '$y' ) ), # 94 STY zp, x
_inst( _sto( _zpx(), '$a' ) ), # 95 STA zp, x
_inst( _sto( _zpy(), '$x' ) ), # 96 STX zp, y
$bad_inst, # 97
_inst( '$a = $y;' . _status( '$a' ) ), # 98 TYA
_inst( _sto( _absy(), '$a' ) ), # 99 STA abs, y
_inst( '$s = $x;' ), # 9A TXS
$bad_inst, # 9B
_inst( _sto( _abs(), '0' ) ), # 9C STZ abs
_inst( _sto( _absx(), '$a' ) ), # 9D STA abs, x
_inst( _sto( _absx(), '0' ) ), # 9E STZ abs, x
$bad_inst, # 9F BBS1 rel
_inst( _lod( _imm(), '$y' ) ), # A0 LDY #imm
_inst( _lod( _zpix(), '$a' ) ), # A1 LDA (zp, x)
_inst( _lod( _imm(), '$x' ) ), # A2 LDX #imm
$bad_inst, # A3
_inst( _lod( _zp(), '$y' ) ), # A4 LDY zp
_inst( _lod( _zp(), '$a' ) ), # A5 LDA zp
_inst( _lod( _zp(), '$x' ) ), # A6 LDX zp
$bad_inst, # A7
_inst( '$y = $a;' . _status( '$y' ) ), # A8 TAY
_inst( _lod( _imm(), '$a' ) ), # A9 LDA #imm
_inst( '$x = $a;' . _status( '$x' ) ), # AA TAX
$bad_inst, # AB
_inst( _lod( _abs(), '$y' ) ), # AC LDY abs
_inst( _lod( _abs(), '$a' ) ), # AD LDA abs
_inst( _lod( _abs(), '$x' ) ), # AE LDX abs
$bad_inst, # AF BBS2 rel
_inst( _bfnz( _rel(), C ) ), # B0 BCS rel
_inst( _lod( _zpiy(), '$a' ) ), # B1 LDA (zp), y
_inst( _lod( _zpi(), '$a' ) ), # B2 LDA (zp)
$bad_inst, # B3
_inst( _lod( _zpx(), '$y' ) ), # B4 LDY zp, x
_inst( _lod( _zpx(), '$a' ) ), # B5 LDA zp, x
_inst( _lod( _zpy(), '$x' ) ), # B6 LDX zp, y
$bad_inst, # B7
_inst( '$p &= ~V;' ), # B8 CLV
_inst( _lod( _absy(), '$a' ) ), # B9 LDA abs, y
_inst( '$x = $s;', _set_nz( '$x' ) ), # BA TSX
$bad_inst, # BB
_inst( _lod( _absx(), '$y' ) ), # BC LDY abs, x
_inst( _lod( _absx(), '$a' ) ), # BD LDA abs, x
_inst( _lod( _absy(), '$x' ) ), # BE LDX abs, y
$bad_inst, # BF BBS3 rel
_inst( _cmp( _imm(), '$y' ) ), # C0 CPY #imm
_inst( _cmp( _zpix(), '$a' ) ), # C1 CMP (zp, x)
$bad_inst, # C2
$bad_inst, # C3
_inst( _cmp( _zp(), '$y' ) ), # C4 CPY zp
_inst( _cmp( _zp(), '$a' ) ), # C5 CMP zp
_inst( _dec( _zp() ) ), # C6 DEC zp
$bad_inst, # C7
_inst( _inc( ( '', '$y' ) ) ), # C8 INY
_inst( _cmp( _imm(), '$a' ) ), # C9 CMP #imm
_inst( _dec( ( '', '$x' ) ) ), # CA DEX
$bad_inst, # CB
_inst( _cmp( _abs(), '$y' ) ), # CC CPY abs
_inst( _cmp( _abs(), '$a' ) ), # CD CMP abs
_inst( _dec( _abs() ) ), # CE DEC abs
$bad_inst, # CF BBS4 rel
_inst( _bfz( _rel(), Z ) ), # D0 BNE rel
_inst( _cmp( _zpiy(), '$a' ) ), # D1 CMP (zp), y
_inst( _cmp( _zpi(), '$a' ) ), # D2 CMP (zp)
$bad_inst, # D3
$bad_inst, # D4
_inst( _cmp( _zpx(), '$a' ) ), # D5 CMP zp, x
_inst( _dec( _zpx() ) ), # D6 DEC zp, x
$bad_inst, # D7
_inst( '$p &= ~D;' ), # D8 CLD
_inst( _cmp( _absy(), '$a' ) ), # D9 CMP abs, y
_inst( _push( '$x' ) ), # DA PHX
$bad_inst, # DB
$bad_inst, # DC
_inst( _cmp( _absx(), '$a' ) ), # DD CMP abs, x
_inst( _dec( _absx() ) ), # DE DEC abs, x
$bad_inst, # DF BBS5 rel
_inst( _cmp( _imm(), '$x' ) ), # E0 CPX #imm
_inst( _sbc( _zpix(), '$a' ) ), # E1 SBC (zp, x)
$bad_inst, # E2
$bad_inst, # E3
_inst( _cmp( _zp(), '$x' ) ), # E4 CPX zp
_inst( _sbc( _zp() ) ), # E5 SBC zp
_inst( _inc( _zp() ) ), # E6 INC zp
$bad_inst, # E7
_inst( _inc( ( '', '$x' ) ) ), # E8 INX
_inst( _sbc( _imm() ) ), # E9 SBC #imm
_inst(), # EA NOP
$bad_inst, # EB
_inst( _cmp( _abs(), '$x' ) ), # EC CPX abs
_inst( _sbc( _abs() ) ), # ED SBC abs
_inst( _inc( _abs() ) ), # EE INC abs
$bad_inst, # EF BBS6 rel
_inst( _bfnz( _rel(), Z ) ), # F0 BEQ rel
_inst( _sbc( _zpiy() ) ), # F1 SBC (zp), y
_inst( _sbc( _zpi() ) ), # F2 SBC (zp)
$bad_inst, # F3
$bad_inst, # F4
_inst( _sbc( _zpx() ) ), # F5 SBC zp, x
_inst( _inc( _zpx() ) ), # F6 INC zp, x
$bad_inst, # F7
_inst( '$p |= D;' ), # F8 SED
_inst( _sbc( _absy() ) ), # F9 SBC abs, y
_inst( _pop( '$x' ), _status( '$x' ) ), # FA PLX
$bad_inst, # FB
$bad_inst, # FC
_inst( _sbc( _absx() ) ), # FD SBC abs, x
_inst( _inc( _absx() ) ), # FE INC abs, x
$bad_inst, # FF BBS7 rel
) if !@OP_CACHE;
$self->{ ops } = [ @OP_CACHE ];
confess "Escape handler opcode not available"
unless $self->{ ops }->[ ESCAPE_OP ] == $bad_inst;
# Patch in the OS escape op handler
$self->{ ops }->[ ESCAPE_OP ] = sub {
my $self = shift;
if ( $self->{ mem }->[ $self->{ reg }->{ pc } ] != ESCAPE_SIG ) {
$bad_inst->( $self );
}
else {
$self->{ reg }->{ pc } += 2;
$self->call_os( $self->{ mem }->[ $self->{ reg }->{ pc } - 1 ] );
}
};
}
sub set_jumptab {
my $self = shift;
$self->{ jumptab } = shift;
}
sub get_state {
my $self = shift;
return @{ $self->{ reg } }{ qw( a x y s p pc ) };
}
sub get_xy {
my $self = shift;
return $self->get_x || ( $self->get_y << 8 );
}
sub set_xy {
my $self = shift;
my $v = shift;
$self->set_x( $v & 0xFF );
$self->set_y( ( $v >> 8 ) & 0xFF );
}
sub read_str {
my $self = shift;
my $addr = shift;
my $str = '';
while ( $self->{ mem }->[ $addr ] != 0x0D ) {
$str .= chr( $self->{ mem }->[ $addr++ ] );
}
return $str;
}
sub read_chunk {
my $self = shift;
my ( $from, $to ) = @_;
return pack( 'C*', @{ $self->{ mem } }[ $from .. $to - 1 ] );
}
sub write_chunk {
my $self = shift;
my ( $addr, $chunk ) = @_;
my $len = length( $chunk );
splice @{ $self->{ mem } }, $addr, $len, unpack( 'C*', $chunk );
}
sub read_8 {
my $self = shift;
my $addr = shift;
return $self->{ mem }->[ $addr ];
}
sub write_8 {
my $self = shift;
my( $addr, $val ) = @_;
$self->{ mem }->[ $addr ] = $val;
}
sub read_16 {
my $self = shift;
my $addr = shift;
return $self->{ mem }->[ $addr ] | ( $self->{ mem }->[ $addr + 1 ] << 8 );
}
sub write_16 {
my $self = shift;
my( $addr, $val ) = @_;
$self->{ mem }->[ $addr ] = $val & 0xFF;
$self->{ mem }->[ $addr + 1 ] = ( $val >> 8 ) & 0xFF;
}
sub read_32 {
my $self = shift;
my $addr = shift;
return $self->{ mem }->[ $addr ]
| ( $self->{ mem }->[ $addr + 1 ] << 8 )
| ( $self->{ mem }->[ $addr + 2 ] << 16 )
| ( $self->{ mem }->[ $addr + 3 ] << 32 );
}
sub write_32 {
my $self = shift;
my( $addr, $val ) = @_;
$self->{ mem }->[ $addr ] = $val & 0xFF;
$self->{ mem }->[ $addr + 1 ] = ( $val >> 8 ) & 0xFF;
$self->{ mem }->[ $addr + 2 ] = ( $val >> 16 ) & 0xFF;
$self->{ mem }->[ $addr + 3 ] = ( $val >> 24 ) & 0xFF;
}
sub poke_code {
my $self = shift;
my $addr = shift;
$self->{ mem }->[ $addr++ ] = $_ for @_;
}
sub load_rom {
my $self = shift;
my ( $f, $a ) = @_;
open my $fh, '<', $f or croak "Can't read $f ($!)\n";
binmode $fh;
my $sz = -s $fh;
sysread $fh, my $buf, $sz or croak "Error reading $f ($!)\n";
close $fh;
$self->write_chunk( $a, $buf );
}
sub call_os {
croak "call_os() not supported";
}
sub run {
my $self = shift;
my $ic = shift;
my $cb = shift;
while ( $ic-- > 0 ) {
my( $a, $x, $y, $s, $p, $pc ) = $self->get_state;
$cb->( $pc, $self->{ mem }->[ $pc ], $a, $x, $y, $s, $p ) if defined $cb;
$self->set_pc( $pc + 1 );
$self->{ ops }->[ $self->{ mem }->[ $pc ] ]->( $self );
}
}
sub make_vector {
my $self = shift;
my ( $call, $vec, $func ) = @_;
$self->{ mem }->[ $call ] = 0x6C; # JMP (indirect)
$self->{ mem }->[ $call + 1 ] = $vec & 0xFF;
$self->{ mem }->[ $call + 2 ] = ( $vec >> 8 ) & 0xFF;
my $jumptab = $self->{ jumptab };
my $addr = $jumptab;
$self->{ mem }->[ $jumptab++ ] = ESCAPE_OP;
$self->{ mem }->[ $jumptab++ ] = ESCAPE_SIG;
$self->{ mem }->[ $jumptab++ ] = $func;
$self->{ mem }->[ $jumptab++ ] = 0x60;
$self->set_jumptab( $jumptab );
$self->{ mem }->[ $vec ] = $addr & 0xFF;
$self->{ mem }->[ $vec + 1 ] = ( $addr >> 8 ) & 0xFF;
}
sub _inst {
my $src = join( "\n", @_ );
# registers
$src =~ s{\$(a|x|y|s|p|pc)\b}{\$self->{reg}->{$1}}g;
# memory and zn access
$src =~ s{\$(mem|zn)\[}{\$self->{$1}->[}g;
my $cr = eval "sub { my \$self=shift; ${src} }";
confess "$@" if $@;
return $cr;
}
sub _bad_inst {
my $self = shift;
my $pc = $self->get_pc;
croak sprintf( "Bad instruction at &%04x (&%02x)\n",
$pc - 1, $self->{ mem }->[ $pc - 1 ] );
}
# Functions that generate code fragments
sub _set_nz {
return
'$p &= ~(N|Z);' . 'if( '
. $_[0]
. ' & 0x80){ $p |= N }'
. 'elsif( '
. $_[0]
. ' == 0 ){ $p |= Z }';
}
sub _push {
my $r = '';
for ( @_ ) {
$r
.= '$mem[STACK + $s] = ('
. $_
. ') & 0xFF; $s = ($s - 1) & 0xFF;' . "\n";
}
return $r;
}
sub _pop {
my $r = '';
for ( @_ ) {
$r .= '$s = ($s + 1) & 0xFF; ' . $_ . ' = $mem[STACK + $s];' . "\n";
}
return $r;
}
sub _pop_p {
return '$s = ($s + 1) & 0xFF; $p = $mem[STACK + $s] | R; $p &= ~B;'
. "\n";
}
# Addressing modes return a list containing setup code, lvalue
sub _zpix {
return (
'my $ea = $mem[$pc++] + $x; '
. '$ea = $mem[$ea & 0xFF] | ($mem[($ea + 1) & 0xFF] << 8)' . ";\n",
'$mem[$ea]'
);
}
sub _zpi {
return (
'my $ea = $mem[$pc++]; '
. '$ea = $mem[$ea & 0xFF] | ($mem[($ea + 1) & 0xFF] << 8)' . ";\n",
'$mem[$ea]'
);
}
sub _zpiy {
return (
'my $ea = $mem[$pc++]; '
. '$ea = ($mem[$ea & 0xFF] | ($mem[($ea + 1) & 0xFF] << 8)) + $y'
. ";\n",
'$mem[$ea]'
);
}
sub _zp {
return ( 'my $ea = $mem[$pc++];' . "\n", '$mem[$ea]' );
}
sub _zpx {
return ( 'my $ea = ($mem[$pc++] + $x) & 0xFF;' . "\n", '$mem[$ea]' );
}
sub _zpy {
return ( 'my $ea = ($mem[$pc++] + $y) & 0xFF;' . "\n", '$mem[$ea]' );
}
sub _abs {
return ( 'my $ea = $mem[$pc] | ($mem[$pc+1] << 8); $pc += 2;' . "\n",
'$mem[$ea]' );
}
sub _absx {
return (
'my $ea = ($mem[$pc] | ($mem[$pc+1] << 8)) + $x; $pc += 2;' . "\n",
'$mem[$ea]'
);
}
sub _absy {
return (
'my $ea = ($mem[$pc] | ($mem[$pc+1] << 8)) + $y; $pc += 2;' . "\n",
'$mem[$ea]'
);
}
sub _imm {
return ( 'my $v = $mem[$pc++];' . "\n", '$v' );
}
lib/Acme/6502.pm view on Meta::CPAN
sub _jmp_i_bug {
my $a = shift;
# this should emulate a page boundary bug:
# JMP 0x80FF fetches from 0x80FF and 0x8000
# instead of 0x80FF and 0x8100
my $b = "($a & 0xFF00) | (($a + 1) & 0xFF)";
return '$pc = $mem[' . $a . '] | ($mem[' . $b . '] << 8);' . "\n";
}
sub _jmp {
return _jmp_i( '$pc' );
}
sub _jmpi {
return 'my $w = $mem[$pc] | ($mem[$pc + 1] << 8); '
. _jmp_i_bug( '$w' );
}
sub _jmpix {
return 'my $w = ($mem[$pc] | ($mem[$pc + 1] << 8)) + $x; '
. _jmp_i( '$w' );
}
sub _rti {
return
_pop( '$p' )
. '$p |= R;'
. 'my ($lo, $hi); '
. _pop( '$lo' )
. _pop( '$hi' )
. '$pc = $lo | ($hi << 8);' . "\n";
}
sub _rts {
return
'my ($lo, $hi); '
. _pop( '$lo' )
. _pop( '$hi' )
. '$pc = ($lo | ($hi << 8)) + 1;' . "\n";
}
1;
__END__
=head1 NAME
Acme::6502 - Pure Perl 65C02 simulator.
=head1 VERSION
This document describes Acme::6502 version 0.76
=head1 SYNOPSIS
use Acme::6502;
my $cpu = Acme::6502->new();
# Set start address
$cpu->set_pc(0x8000);
# Load ROM image
$cpu->load_rom('myrom.rom', 0x8000);
# Run for 1,000,000 instructions then return
$cpu->run(1_000_000);
=head1 DESCRIPTION
Imagine the nightmare scenario: your boss tells you about a legacy
system you have to support. How bad could it be? COBOL? Fortran? Worse:
it's an embedded 6502 system run by a family of squirrels (see Dilberts
passim). Fortunately there's a pure Perl 6502 emulator that works so
well the squirrels will never know the difference.
=head1 INTERFACE
=over
=item C<new>
Create a new 6502 CPU.
=item C<call_os( $vec_number )>
Subclass to provide OS entry points. OS vectors are installed by calling
C<make_vector>. When the vector is called C<call_os()> will be called
with the vector number.
=item C<get_a()>
Read the current value of the processor A register (accumulator).
=item C<get_p()>
Read the current value of the processor status register.
=item C<get_pc()>
Read the current value of the program counter.
=item C<get_s()>
Read the current value of the stack pointer.
=item C<get_x()>
Read the current value of the processor X index register.
=item C<get_y()>
Read the current value of the processor X index register.
=item C<get_xy()>
Read the value of X and Y as a sixteen bit number. X forms the lower 8
bits of the value and Y forms the upper 8 bits.
=item C<get_state()>
Returns an array containing the values of the A, X, Y, S, P and SP.
=item C<set_a( $value )>
Set the value of the processor A register (accumulator).
=item C<set_p( $value )>
Set the value of the processor status register.
=item C<set_pc( $value )>
Set the value of the program counter.
=item C<set_s( $value )>
Set the value of the stack pointer.
=item C<set_x( $value )>
Set the value of the X index register.
=item C<set_y( $value )>
Set the value of the Y index register.
=item C<set_xy( $value )>
Set the value of the X and Y registers to the specified sixteen bit
number. X gets the lower 8 bits, Y gets the upper 8 bits.
=item C<set_jumptab( $addr )>
Set the address of the block of memory that will be used to hold the
thunk blocks that correspond with vectored OS entry points. Each thunk
takes four bytes.
=item C<load_rom( $filename, $addr )>
Load a ROM image at the specified address.
=item C<make_vector( $jmp_addr, $vec_addr, $vec_number )>
Make a vectored entry point for an emulated OS. C<$jmp_addr> is the
address where an indirect JMP instruction (6C) will be placed,
C<$vec_addr> is the address of the vector and C<$vec_number> will be
passed to C<call_os> when the OS call is made.
=item C<poke_code( $addr, @bytes )>
Poke code directly at the specified address.
=item C<read_8( $addr )>
Read a byte at the specified address.
=item C<read_16( $addr )>
Read a sixteen bit (low, high) word at the specified address.
=item C<read_32( $addr )>
Read a 32 bit word at the specified address.
=item C<read_chunk( $start, $end )>
Read a chunk of data from C<$start> to C<$end> - 1 into a string.
=item C<read_str( $addr )>
Read a carriage return terminated (0x0D) string from the
specified address.
=item C<run( $count [, $callback ] )>
Execute the specified number of instructions and return. Optionally a
callback may be provided in which case it will be called before each
instruction is executed:
my $cb = sub {
my ($pc, $inst, $a, $x, $y, $s, $p) = @_;
# Maybe output trace info
}
$cpu->run(100, $cb);
=item C<write_8( $addr, $value )>
Write the byte at the specified address.
=item C<write_16( $addr, $value )>
( run in 2.468 seconds using v1.01-cache-2.11-cpan-cdf2f3d4e48 )