Acme::6502 - Pure Perl 65C02 simulator.

Acme-6502 documentation Contained in the Acme-6502 distribution.

Index

Code Index:

NAME

Top

Acme::6502 - Pure Perl 65C02 simulator.

VERSION

Top

This document describes Acme::6502 version 0.76

SYNOPSIS

Top

    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);

DESCRIPTION

Top

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.

INTERFACE

Top

new

Create a new 6502 CPU.

call_os( $vec_number )

Subclass to provide OS entry points. OS vectors are installed by calling make_vector. When the vector is called call_os() will be called with the vector number.

get_a()

Read the current value of the processor A register (accumulator).

get_p()

Read the current value of the processor status register.

get_pc()

Read the current value of the program counter.

get_s()

Read the current value of the stack pointer.

get_x()

Read the current value of the processor X index register.

get_y()

Read the current value of the processor X index register.

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.

get_state()

Returns an array containing the values of the A, X, Y, S, P and SP.

set_a( $value )

Set the value of the processor A register (accumulator).

set_p( $value )

Set the value of the processor status register.

set_pc( $value )

Set the value of the program counter.

set_s( $value )

Set the value of the stack pointer.

set_x( $value )

Set the value of the X index register.

set_y( $value )

Set the value of the Y index register.

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.

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.

load_rom( $filename, $addr )

Load a ROM image at the specified address.

make_vector( $jmp_addr, $vec_addr, $vec_number )

Make a vectored entry point for an emulated OS. $jmp_addr is the address where an indirect JMP instruction (6C) will be placed, $vec_addr is the address of the vector and $vec_number will be passed to call_os when the OS call is made.

poke_code( $addr, @bytes )

Poke code directly at the specified address.

read_8( $addr )

Read a byte at the specified address.

read_16( $addr )

Read a sixteen bit (low, high) word at the specified address.

read_32( $addr )

Read a 32 bit word at the specified address.

read_chunk( $start, $end )

Read a chunk of data from $start to $end - 1 into a string.

read_str( $addr )

Read a carriage return terminated (0x0D) string from the specified address.

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);
write_8( $addr, $value )

Write the byte at the specified address.

write_16( $addr, $value )

Write a sixteen bit (low, high) value at the specified address.

write_32( $addr, $value )

Write a 32 bit value at the specified address.

write_chunk( $addr, $string )

Write a chunk of data to memory.

DIAGNOSTICS

Top

Bad instruction at %s (%s)

The emulator hit an illegal 6502 instruction.

CONFIGURATION AND ENVIRONMENT

Top

Acme::6502 requires no configuration files or environment variables.

DEPENDENCIES

Top

None.

INCOMPATIBILITIES

Top

None reported.

BUGS AND LIMITATIONS

Top

Doesn't have support for hardware emulation hooks - so memory mapped I/O is out of the question until someone fixes it.

Please report any bugs or feature requests to bug-acme-6502@rt.cpan.org, or through the web interface at http://rt.cpan.org.

AUTHOR

Top

Andy Armstrong <andy@hexten.net>

Brian Cassidy <bricas@cpan.org>

LICENCE AND COPYRIGHT

Top

Copyright (c) 2006-2010, Andy Armstrong <andy@hexten.net>. All rights reserved.

This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See perlartistic.

DISCLAIMER OF WARRANTY

Top

BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR, OR CORRECTION.

IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.

Acme-6502 documentation Contained in the Acme-6502 distribution. 
package Acme::6502;

use warnings FATAL => 'all';
use strict;
use Carp;

our $VERSION = '0.76';

# 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
        _inst( _asl( _zpx() ) ),       # 16 ASL zp, x
        $bad_inst,                     # 17
        _inst( '$p &= ~C;' ),          # 18 CLC
        _inst( _ora( _absy() ) ),      # 19 ORA abs, y
        _inst( _inc( _acc() ) ),       # 1A INC A
        $bad_inst,                     # 1B
        _inst( _trb( _abs() ) ),       # 1C TRB abs
        _inst( _ora( _absx() ) ),      # 1D ORA abs, x
        _inst( _asl( _absx() ) ),      # 1E ASL abs, x
        $bad_inst,                     # 1F BBR1 rel
        _inst(                         # 20 JSR
          _push( '($pc + 1) >> 8', '($pc + 1)' ),
          _jmp()
        ),
        _inst( _and( _zpix() ) ),      # 21 AND (zp, x)
        $bad_inst,                     # 22
        $bad_inst,                     # 23
        _inst( _bit( _zp() ) ),        # 24 BIT zp
        _inst( _and( _zp() ) ),        # 25 AND zp
        _inst( _rol( _zp() ) ),        # 26 ROL zp
        $bad_inst,                     # 27
        _inst( _pop_p() ),             # 28 PLP
        _inst( _and( _imm() ) ),       # 29 AND  #imm
        _inst( _rol( _acc() ) ),       # 2A ROL A
        $bad_inst,                     # 2B
        _inst( _bit( _abs() ) ),       # 2C BIT abs
        _inst( _and( _abs() ) ),       # 2D AND abs
        _inst( _rol( _abs() ) ),       # 2E ROL abs
        $bad_inst,                     # 2F BBR2 rel
        _inst( _bfnz( _rel(), N ) ),   # 30 BPL rel
        _inst( _and( _zpiy() ) ),      # 31 AND (zp), y
        _inst( _and( _zpi() ) ),       # 32 AND (zp)
        $bad_inst,                     # 33
        _inst( _bit( _zpx() ) ),       # 34 BIT zp, x
        _inst( _and( _zpx() ) ),       # 35 AND zp, x
        _inst( _rol( _zpx() ) ),       # 36 ROL zp, x
        $bad_inst,                     # 37
        _inst( '$p |= C;' ),           # 38 SEC
        _inst( _and( _absy() ) ),      # 39 AND abs, y
        _inst( _dec( _acc() ) ),       # 3A DEC A
        $bad_inst,                     # 3B
        _inst( _bit( _absx() ) ),      # 3C BIT abs, x
        _inst( _and( _absx() ) ),      # 3D AND abs, x
        _inst( _rol( _absx() ) ),      # 3E ROL abs, x
        $bad_inst,                     # 3F BBR3 rel
        _inst( _pop( '$p' ), _rts() ), # 40 RTI
        _inst( _eor( _zpix() ) ),      # 41 EOR (zp, x)
        $bad_inst,                     # 42
        $bad_inst,                     # 43
        $bad_inst,                     # 44
        _inst( _eor( _zp() ) ),        # 45 EOR zp
        _inst( _lsr( _zp() ) ),        # 46 LSR zp
        $bad_inst,                     # 47
        _inst( _push( '$a' ) ),        # 48 PHA
        _inst( _eor( _imm() ) ),       # 49 EOR imm
        _inst( _lsr( _acc() ) ),       # 4A LSR A
        $bad_inst,                     # 4B
        _inst( _jmp() ),               # 4C JMP abs
        _inst( _eor( _abs() ) ),       # 4D EOR abs
        _inst( _lsr( _abs() ) ),       # 4E LSR abs
        $bad_inst,                     # 4F BBR4 rel
        _inst( _bfz( _rel(), V ) ),    # 50 BVC rel
        _inst( _eor( _zpiy() ) ),      # 51 EOR (zp), y
        _inst( _eor( _zpi() ) ),       # 52 EOR (zp)
        $bad_inst,                     # 53
        $bad_inst,                     # 54
        _inst( _eor( _zpx() ) ),       # 55 EOR zp, x
        _inst( _lsr( _zpx() ) ),       # 56 LSR zp, x
        $bad_inst,                     # 57
        _inst( '$p &= ~I;' ),          # 58 CLI
        _inst( _eor( _absy() ) ),      # 59 EOR abs, y
        _inst( _push( '$y' ) ),        # 5A PHY
        $bad_inst,                     # 5B
        $bad_inst,                     # 5C
        _inst( _eor( _absx() ) ),      # 5D EOR abs, x
        _inst( _lsr( _absx() ) ),      # 5E LSR abs, x
        $bad_inst,                     # 5F BBR5 rel
        _inst( _rts() ),               # 60 RTS
        _inst( _adc( _zpx() ) ),       # 61 ADC zp, x
        $bad_inst,                     # 62
        $bad_inst,                     # 63
        _inst( _sto( _zp(), '0' ) ),   # 64 STZ zp
        _inst( _adc( _zp() ) ),        # 65 ADC zp
        _inst( _ror( _zp() ) ),        # 66 ROR zp
        $bad_inst,                     # 67
        _inst( _pop( '$a' ), _status( '$a' ) ),    # 68 PLA
        _inst( _adc( _imm() ) ),                   # 69 ADC  #imm
        _inst( _ror( _acc() ) ),                   # 6A ROR A
        $bad_inst,                                 # 6B
        _inst( _jmpi() ),                          # 6C JMP (abs)
        _inst( _adc( _abs() ) ),                   # 6D ADC abs
        _inst( _ror( _abs() ) ),                   # 6E ROR abs
        $bad_inst,                                 # 6F BBR6 rel
        _inst( _bfnz( _rel(), V ) ),               # 70 BVS rel
        _inst( _adc( _zpiy() ) ),                  # 71 ADC (zp), y
        _inst( _adc( _zpi() ) ),                   # 72 ADC (zp)
        $bad_inst,                                 # 73
        _inst( _sto( _zpx(), '0' ) ),              # 74 STZ zp, x
        _inst( _adc( _zpx() ) ),                   # 75 ADC zp, x
        _inst( _adc( _zpx() ) ),                   # 76 ROR zp, x
        $bad_inst,                                 # 77
        _inst( '$p |= I;' ),                       # 78 STI
        _inst( _adc( _absy() ) ),                  # 79 ADC abs, y
        _inst( _pop( '$y' ), _status( '$y' ) ),    # 7A PLY
        $bad_inst,                                 # 7B
        _inst( _jmpix() ),                         # 7C JMP (abs, x)
        _inst( _adc( _absx() ) ),                  # 7D ADC abs, x
        _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' );
}

sub _acc {
  return ( '', '$a' );
}

sub _rel {
  # Doesn't return an lvalue
  return ( 'my $t = $mem[$pc++];' . "\n",
    '($pc + $t - (($t & 0x80) ? 0x100 : 0))' );
}

sub _status {
  my $reg = shift || '$a';
  return '$p = ($p & ~(N | Z) | $zn[' . $reg . ']);' . "\n";
}

sub _ora {
  return $_[0] . '$a |= ' . $_[1] . ";\n" . _status();
}

sub _and {
  return $_[0] . '$a &= ' . $_[1] . ";\n" . _status();
}

sub _eor {
  return $_[0] . '$a ^= ' . $_[1] . ";\n" . _status();
}

sub _bit {
  return
     $_[0]
   . '$p = ($p & ~(N|V)) | ('
   . $_[1]
   . ' & (N|V));' . "\n"
   . 'if (($a & '
   . $_[1]
   . ') == 0) { $p |= Z; } else { $p &= ~Z; }' . "\n";
}

sub _asl {
  return
     $_[0]
   . 'my $w = ('
   . $_[1]
   . ') << 1; ' . "\n"
   . 'if ($w & 0x100) { $p |= C; $w &= ~0x100; } else { $p &= ~C; }'
   . "\n"
   . _status( '$w' )
   . $_[1]
   . ' = $w;' . "\n";
}

sub _lsr {
  return
     $_[0]
   . 'my $w = '
   . $_[1] . ";\n"
   . 'if (($w & 1) != 0) { $p |= C; } else { $p &= ~C; }' . "\n"
   . '$w >>= 1;' . "\n"
   . _status( '$w' )
   . $_[1]
   . ' = $w;' . "\n";
}

sub _rol {
  return
     $_[0]
   . 'my $w = ('
   . $_[1]
   . ' << 1) | ($p & C);' . "\n"
   . 'if ($w >= 0x100) { $p |= C; $w -= 0x100; } else { $p &= ~C; };'
   . "\n"
   . _status( '$w' )
   . $_[1]
   . ' = $w;' . "\n";
}

sub _ror {
  return
     $_[0]
   . 'my $w = '
   . $_[1]
   . ' | (($p & C) << 8);' . "\n"
   . 'if (($w & 1) != 0) { $p |= C; } else { $p &= ~C; }' . "\n"
   . '$w >>= 1;' . "\n"
   . _status( '$w' )
   . $_[1]
   . ' = $w;' . "\n";
}

sub _sto {
  return $_[0] . "$_[1] = $_[2];\n";
}

sub _lod {
  return $_[0] . "$_[2] = $_[1];\n" . _status( $_[2] );
}

sub _cmp {
  return
     $_[0]
   . 'my $w = '
   . $_[2] . ' - '
   . $_[1] . ";\n"
   . 'if ($w < 0) { $w += 0x100; $p &= ~C; } else { $p |= C; }' . "\n"
   . _status( '$w' );
}

sub _tsb {
  return 'croak "TSB not supported\n";' . "\n";
}

sub _trb {
  return 'croak "TRB not supported\n";' . "\n";
}

sub _inc {
  return
     $_[0]
   . $_[1] . ' = ('
   . $_[1]
   . ' + 1) & 0xFF;' . "\n"
   . _status( $_[1] );
}

sub _dec {
  return
     $_[0]
   . $_[1] . ' = ('
   . $_[1]
   . ' + 0xFF) & 0xFF;' . "\n"
   . _status( $_[1] );
}

sub _adc {
  return
     $_[0]
   . 'my $w = '
   . $_[1] . ";\n"
   . 'if ($p & D) {' . "\n"
   . 'my $lo = ($a & 0x0F) + ($w & 0x0F) + ($p & C);' . "\n"
   . 'if ($lo > 9) { $lo += 6; }' . "\n"
   . 'my $hi = ($a >> 4) + ( $w >> 4) + ($lo > 15 ? 1 : 0);' . "\n"
   . '$a = ($lo & 0x0F) | ($hi << 4);' . "\n"
   . '$p = ($p & ~C) | ($hi > 15 ? C : 0);' . "\n"
   . '} else {' . "\n"
   . 'my $lo = $a + $w + ($p & C);' . "\n"
   . '$p &= ~(N | V | Z | C);' . "\n"
   . '$p |= (~($a ^ $w) & ($a ^ $lo) & 0x80 ? V : 0) | ($lo & 0x100 ? C : 0);'
   . "\n"
   . '$a = $lo & 0xFF;' . "\n"
   . _status() . '}' . "\n";
}

sub _sbc {
  return
     $_[0]
   . 'my $w = '
   . $_[1] . ";\n"
   . 'if ($p & D) {' . "\n"
   . 'my $lo = ($a & 0x0F) - ($w & 0x0F) - (~$p & C);' . "\n"
   . 'if ($lo & 0x10) { $lo -= 6; }' . "\n"
   . 'my $hi = ($a >> 4) - ($w >> 4) - (($lo & 0x10) >> 4);' . "\n"
   . 'if ($hi & 0x10) { $hi -= 6; }' . "\n"
   . '$a = ($lo & 0x0F) | ($hi << 4);' . "\n"
   . '$p = ($p & ~C) | ($hi > 15 ? 0 : C);' . "\n"
   . '} else {' . "\n"
   . 'my $lo = $a - $w - (~$p & C);' . "\n"
   . '$p &= ~(N | V | Z | C);' . "\n"
   . '$p |= (($a ^ $w) & ($a ^ $lo) & 0x80 ? V : 0) | ($lo & 0x100 ? 0 : C);'
   . "\n"
   . '$a = $lo & 0xFF;' . "\n"
   . _status() . '}' . "\n";
}

sub _bra {
  return $_[0] . '$pc = ' . $_[1] . ";\n";
}

sub _bfz {
  return
     $_[0]
   . 'if (($p & '
   . $_[2]
   . ') == 0) { $pc = '
   . $_[1] . '; }' . "\n";
}

sub _bfnz {
  return
     $_[0]
   . 'if (($p & '
   . $_[2]
   . ') != 0) { $pc = '
   . $_[1] . '; }' . "\n";
}

sub _jmp_i {
  my $a = shift;
  return '$pc = $mem[' . $a . '] | ($mem[' . $a . ' + 1] << 8);' . "\n";
}

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 _rts {
  return
     'my ($lo, $hi); '
   . _pop( '$lo' )
   . _pop( '$hi' )
   . '$pc = ($lo | ($hi << 8)) + 1;' . "\n";
}

1;
__END__