CPU::Emulator::Z80 - a Z80 emulator

CPU-Emulator-Z80 documentation Contained in the CPU-Emulator-Z80 distribution.

Index

Code Index:

NAME

Top

CPU::Emulator::Z80 - a Z80 emulator

SYNOPSIS

Top

    # create a CPU with 64K of zeroes in RAM
    my $cpu = CPU::Emulator::Z80->new();

    # set a breakpoint
    $cpu->memory()->poke16(0xF000, 0xDDDD); # STOP instruction
    $cpu->memory()->poke(0xF002, 0x00);

    $cpu->memory()->poke(0, 0xC3);     # JP 0xC000
    $cpu->memory()->poke16(1, 0xC000);

    # run until we hit a breakpoint ie RST 1
    eval { $cpu->run(); }
    print $cpu->format_registers();

DESCRIPTION

Top

This class provides a virtual Z80 micro-processor written in pure perl. You can program it in Z80 machine code. Machine code is fast! This will make your code faster!

METHODS

Top

new

The constructor returns an object representing a Z80 CPU. It takes several optional parameters:

memory

can be either an object inheriting from CPU::Emulator::Memory, or a string of data with which to initialise RAM. If a string is passed, then a CPU::Emulator::Memory::Banked is created of the appropriate size. If not specified at all, then a CPU::Emulator::Memory::Banked is created with 64K of zeroes.

ports

can be either 256 or 65536 (no other values are permitted) and defaults to 65536. This is the number of I/O ports that can be addressed. If set to 65536, the entire address bus is used to determine what port I/O instructions tickle. If 256, then the most significant 8 bits are ignored.

init_PC, init_A, init_B ...

For each of A B C D E F R HL IX IY PC SP, an integer, the starting value for that register, defaulting to 0.

init_A_, init_B_, ...

For each of A B C D E F HL, an integer for the starting value for that register in the alternate set, defaulting to 0. Note that contrary to normal Z80 custom these are named as X_ instead of X'. This is just for quoting convenience.

add_input_device

Takes two named parameters, 'address' and 'function', and creates an input port at that address. Reading from the port will call the function with no parameters, returning whatever the function returns.

In 256-port mode, the port is effectively replicated 256 times.

add_output_device

Takes two named parameters, 'address' and 'function', and creates an output port at that address. Writing to the port simply calls that function with the byte to be written as its only parameter.

In 256-port mode, the port is effectively replicated 256 times.

memory

Return a reference to the object that represent's the system's memory.

register

Return the object representing a specified register. This can be any of the real registers (eg D or D_) or a derived register (eg DE or L). For (HL) it returns the private internal DON'T TOUCH THIS 'W' register, for evil twisty internals reasons.

status

Return a scalar representing the entire state of the CPU or, if passed a scalar, attempt to initialise the CPU to the status it represents.

registers

Return a hashref of all the real registers and their values.

format_registers

A convenient method for getting all the registers in a nice printable format. It mostly exists to help me with debuggering, but if you promise to be good you can use it too. Just don't rely on the format remaining unchanged.

interrupt

Attempt to raise an interrupt. Whether any attention is paid to it or not depends on whether you've enabled interrupts or not in your Z80 code. Because only IM 1 is implemented, this will generate a RST 0x38 if interrupts are enabled. Note that interrupts are disabled at power-on.

This returns true if the interrupt will be acted upon, false otherwise. That is, it returns true if interrupts are enabled.

nmi

Raise a non-maskable interrupt. This generates a CALL 0x0066 as the next instruction.a This also disables interrupts. Interrupts are restored to their previous state by a RETN instruction.

run

Start the CPU running from whatever the Program Counter (PC) is set to. This will by default run for ever. However, it takes an optional parameter telling the CPU to run that number of instructions.

This returns either when that many instructions have been executed, or when a STOP instruction executed - see 'Extra Instructions' below.

On return, the PC will point at the next instruction to execute so that you can resume where you left off.

stopped

Returns true if the CPU has STOPped, false otherwise. You can use this to easily determine why the run() method returned.

EXTRA INSTRUCTIONS

Top

Whenever any combination of two of the 0xDD and 0xFD prefixes are met, behaviour deviates from that of a normal Z80 and instead depends on the following byte:

0x00 - STOP

The run() method stops, even if the desired number of instructions has not yet been reached.

anything else

Fatal error.

PROGRAMMING THE Z80

Top

I recommend "Programming the Z80" by Rodnay Zaks. This excellent book is unfortunately out of print, but may be available through abebooks.com http://www.abebooks.com/servlet/SearchResults?an=zaks&tn=programming+the+z80.

BUGS/WARNINGS/LIMITATIONS

Top

Claims about making your code faster may not be true in all realities.

I assume you're using a twos-complement machine. I *think* that that's true of anything perl runs on.

Only interrupt mode 1 is implemented. All interrupts are serviced by a RST 0x38 instruction.

The DDFD- and FDDD-prefixed instructions (the "use this index register - no, wait, I meant the other one" prefixes) and the DDDD- and FDFD-prefixed instructions (the "use this index register, no really, I mean it, pleeeeease" prefixes) are silly, and have been replaced - see "Extra Instructions" above.

FEEDBACK

Top

I welcome feedback about my code, including constructive criticism and bug reports. The best bug reports include files that I can add to the test suite, which fail with the current code in CVS and will pass once I've fixed the bug.

Feature requests are far more likely to get implemented if you submit a patch yourself.

SEE ALSO

Top

Acme::6502

CPU::Z80::Assembler

The FUSE Free Unix Spectrum Emulator: http://fuse-emulator.sourceforge.net/

CVS

Top

http://drhyde.cvs.sourceforge.net/drhyde/perlmodules/CPU-Emulator-Z80/

AUTHOR, COPYRIGHT and LICENCE

Top

Copyright 2008 David Cantrell <david@cantrell.org.uk>

This software is free-as-in-speech software, and may be used, distributed, and modified under the terms of either the GNU General Public Licence version 2 or the Artistic Licence. It's up to you which one you use. The full text of the licences can be found in the files GPL2.txt and ARTISTIC.txt, respectively.

CONSPIRACY

Top

This module is also free-as-in-mason software.

CPU-Emulator-Z80 documentation Contained in the CPU-Emulator-Z80 distribution. 
# $Id: Z80.pm,v 1.56 2008/06/13 14:42:08 drhyde Exp $

package CPU::Emulator::Z80;

use strict;
use warnings;

use vars qw($VERSION %INSTR_LENGTHS %INSTR_DISPATCH);

$VERSION = '1.0';

$SIG{__WARN__} = sub {
    warn(__PACKAGE__.": $_[0]\n");
};

use Carp;
use Scalar::Util qw(blessed reftype);
use Tie::Hash::Vivify;
use Carp qw(confess);
use Data::Dumper;

use CPU::Emulator::Memory::Banked;
use CPU::Emulator::Z80::Register8;
use CPU::Emulator::Z80::Register8F;
use CPU::Emulator::Z80::Register8R;
use CPU::Emulator::Z80::Register16;
use CPU::Emulator::Z80::Register16SP;
use CPU::Emulator::Z80::ALU; # import add/subtract methods

my @REGISTERS16 = qw(PC SP IX IY HL);          # 16 bit registers
# NB W and Z aren't programmer-accesible, for internal use only!
my @REGISTERS8  = qw(A B C D E F R W Z I);     # 8 bit registers
my @ALTREGISTERS = qw(A B C D E F HL);         # those which have alt.s
my @REGISTERS   = (@REGISTERS16, @REGISTERS8); # all registers


sub new {
    my($class, %args) = @_;
    if(exists($args{memory})) {
        if(blessed($args{memory})) {
            die("memory must be a CPU::Emulator::Memory")
                unless($args{memory}->isa('CPU::Emulator::Memory'));
        } elsif(!ref($args{memory})) {
            $args{memory} = CPU::Emulator::Memory::Banked->new(
                bytes => $args{memory},
                size  => length($args{memory})
            );
        } else {
            die("memory must be a string or an object\n");
        }
    } else {
        $args{memory} = CPU::Emulator::Memory::Banked->new();
    }

    if(exists($args{ports})) {
        die("$args{ports} is a stupid number of ports\n")
            unless($args{ports} == 256 || $args{ports} == 65536);
    } else {
        $args{ports} = 65536;
    }

    foreach my $register (@REGISTERS, map { "${_}_" } @ALTREGISTERS) {
        $args{"init_$register"} = 0
            if(!exists($args{"init_$register"}));
    }

    # bless early so we can close over it ...
    my $self;
    $self = bless {
        iff1        => 0,
        iff2        => 0,
        ports       => $args{ports},
        inputs      => {},
        outputs     => {},
        memory      => $args{memory},
        registers => Tie::Hash::Vivify->new(sub { confess("No auto-vivifying registers!\n".Dumper(\@_)) }),
        hw_registers => Tie::Hash::Vivify->new(sub { confess("No auto-vivifying hw_registers!\n".Dumper(\@_)) }),
        derived_registers => Tie::Hash::Vivify->new(sub { confess("No auto-vivifying derived_registers!\n".Dumper(\@_)) }),
    }, $class;

    $self->{hw_registers}->{$_} = CPU::Emulator::Z80::Register8->new(
        cpu => $self, value => $args{"init_$_"}
    ) foreach(@REGISTERS8);

    $self->{hw_registers}->{$_} = CPU::Emulator::Z80::Register16->new(
        cpu => $self, value => $args{"init_$_"}
    ) foreach(@REGISTERS16);

    $self->{hw_registers}->{$_.'_'} = blessed($self->{hw_registers}->{$_})->new(
        cpu => $self, value => $args{"init_$_"}
    ) foreach(@ALTREGISTERS);

    bless $self->{hw_registers}->{$_}, 'CPU::Emulator::Z80::Register8F'
        foreach(qw(F F_));
    bless $self->{hw_registers}->{R}, 'CPU::Emulator::Z80::Register8R';
    bless $self->{hw_registers}->{SP}, 'CPU::Emulator::Z80::Register16SP';


    $self->{derived_registers}->{AF}  = $self->_derive_register16(qw(A F));
    $self->{derived_registers}->{AF_} = $self->_derive_register16(qw(A_ F_));
    $self->{derived_registers}->{BC}  = $self->_derive_register16(qw(B C));
    $self->{derived_registers}->{BC_}  = $self->_derive_register16(qw(B_ C_));
    $self->{derived_registers}->{DE}  = $self->_derive_register16(qw(D E));
    $self->{derived_registers}->{DE_}  = $self->_derive_register16(qw(D_ E_));
    $self->{derived_registers}->{WZ}  = $self->_derive_register16(qw(W Z));
    $self->{derived_registers}->{H}   = $self->_derive_register8(qw(HL high));
    $self->{derived_registers}->{H_}   = $self->_derive_register8(qw(HL_ high));
    $self->{derived_registers}->{L}   = $self->_derive_register8(qw(HL low));
    $self->{derived_registers}->{L_}   = $self->_derive_register8(qw(HL_ low));
    $self->{derived_registers}->{HIX} = $self->_derive_register8(qw(IX high));
    $self->{derived_registers}->{LIX} = $self->_derive_register8(qw(IX low));
    $self->{derived_registers}->{HIY} = $self->_derive_register8(qw(IY high));
    $self->{derived_registers}->{LIY} = $self->_derive_register8(qw(IY low));

    $self->{registers}->{$_} = $self->{hw_registers}->{$_}
        foreach(keys %{$self->{hw_registers}});
    $self->{registers}->{$_} = $self->{derived_registers}->{$_}
        foreach(keys %{$self->{derived_registers}});

    return $self;
}

# create a 16-bit register-pair from two real 8-bit registers
sub _derive_register16 {
    my($self, $high, $low) = @_;
    return CPU::Emulator::Z80::Register16->new(
        get => sub {
                   return 256 * $self->register($high)->get() +
                                $self->register($low)->get()
               },
        set => sub {
                   my $value = shift;
                   $self->register($high)->set($value >>8);
                   $self->register($low)->set($value & 0xFF);
               },
        cpu => $self
    );
}
# create an 8-bit pseudo-register from a 16-bit register
sub _derive_register8 {
    my($self, $pair, $half) = @_;
    return CPU::Emulator::Z80::Register8->new(
        get => sub {
                   my $r = $self->register($pair)->get();
                   return ($half eq 'high')
                       ? $r >> 8
                       : $r & 0xFF
               },
        set => sub {
                   my $value = shift;
                   $self->register($pair)->set(
                       ($half eq 'high')
                           ? ($self->register($pair)->get() & 0xFF) |
                             ($value << 8)
                           : ($self->register($pair)->get() & 0xFF00) | $value
                   );
               },
        cpu => $self
    );
}


sub add_input_device {
    my($self, %params) = @_;
    my $address = $params{address} & ($self->{ports} - 1);
    die(sprintf("Device already exists at %#06x", $address))
        if(exists($self->{inputs}->{$address}));
    $self->{inputs}->{$address} = $params{function};
}

sub _get_from_input {
    my($self, $addr) = @_;
    $addr  = $addr & ($self->{ports} - 1);
    if(exists($self->{inputs}->{$addr})) {
        return $self->{inputs}->{$addr}->();
    } else {
        die(sprintf("No such port %#06x", $addr));
    }
}


sub add_output_device {
    my($self, %params) = @_;
    my $address = $params{address} & ($self->{ports} - 1);
    die(sprintf("Device already exists at %#06x", $address))
        if(exists($self->{outputs}->{$address}));
    $self->{outputs}->{$address} = $params{function};
}

sub _put_to_output {
    my($self, $addr, $byte) = @_;
    $addr  = $addr & ($self->{ports} - 1);
    if(exists($self->{outputs}->{$addr})) {
        $self->{outputs}->{$addr}->($byte);
    } else {
        carp(sprintf("No such port %#06x", $addr));
    }
}


sub memory {
    my $self = shift;
    return $self->{memory};
}


sub register {
    my($self, $r) = @_;
    return $self->{registers}->{($r eq '(HL)') ? 'W' : $r};
}


sub status {
    my $self = shift;
    if(@_) { $self->_status_load(@_); }
    return
        join('', map {
            chr($self->register($_)->get())
        } qw(A B C D E F A_ B_ C_ D_ E_ F_ R I))
       .join('', map {
            chr($self->register($_)->get() >> 8),
            chr($self->register($_)->get() & 0xFF),
        } qw(SP PC IX IY HL HL_));
}
sub _status_load {
    my($self, $status) = @_;
    my @regs = split(//, $status);
    $self->register($_)->set(ord(shift(@regs)))
        foreach(qw(A B C D E F A_ B_ C_ D_ E_ F_ R I));
    $self->register($_)->set(256 * ord(shift(@regs)) + ord(shift(@regs)))
        foreach(qw(SP PC IX IY HL HL_));
}


sub registers {
    my $self = shift;
    return {
        map {
            $_ => $self->register($_)->get()
        } grep { $_ !~ /^(W|Z)$/ } keys %{$self->{hw_registers}}
    }
}

sub format_registers {
    my $self = shift;
    sprintf("#
#              SZ5H3PNC                             SZ5H3PNC
# A:  0x%02X F:  %08b HL:  0x%04X    A_: 0x%02X F_: %08b HL_: 0x%04X
# B:  0x%02X C:  0x%02X                    B_: 0x%02X C_: 0x%02X
# D:  0x%02X E:  0x%02X                    D_: 0x%02X E_: 0x%02X
# 
# IX: 0x%04X IY: 0x%04X SP: 0x%04X PC: 0x%04X
#
# R:  0x%02X I:  0x%02X
# W:  0x%02X Z:  0x%02X (internal use only)
", map { $self->register($_)->get(); } qw(A F HL A_ F_ HL_ B C B_ C_ D E D_ E_ IX IY SP PC R I W Z));
}


# SEE http://www.z80.info/decoding.htm
#     http://www.z80.info/z80sflag.htm
# NB when decoding, x == first 2 bits, y == next 3, z == last 3
#                   p == first 2 bits of y, q == last bit of y
my @TABLE_R   = (qw(B C D E H L (HL) A));
my @TABLE_RP  = (qw(BC DE HL SP));
my @TABLE_RP2 = (qw(BC DE HL AF));
my @TABLE_CC  = (qw(NZ Z NC C PO PE P M));
my @TABLE_ALU = (
    \&_ADD_r8_r8, \&_ADC_r8_r8, \&_SUB_r8_r8, \&_SBC_r8_r8,
    \&_AND_r8_r8, \&_XOR_r8_r8, \&_OR_r8_r8, \&_CP_r8_r8
);
my @TABLE_ROT = (
    \&_RLC, \&_RRC, \&_RL, \&_RR, \&_SLA, \&_SRA, \&_SLL, \&_SRL
);
my @TABLE_BLI = (
    [\&_LDI, \&_CPI, \&_INI, \&_OUTI],
    [\&_LDD, \&_CPD, \&_IND, \&_OUTD],
    [\&_LDIR, \&_CPIR, \&_INIR, \&_OTIR],
    [\&_LDDR, \&_CPDR, \&_INDR, \&_OTDR],
);

# NB order is important in these tables
%INSTR_LENGTHS = (
    (map { $_ => 'UNDEFINED' } (0 .. 255)),
    # un-prefixed instructions
    # x=0, z=0
    (map { ($_ << 3) => 1 } (0, 1)), # NOP; EX AF, AF'
    (map { ($_ << 3) => 2 } (2 .. 7)), # DJNZ d; JR d; JR X, d
    # x=0, z=1
    (map { 0b00000001 | ($_ << 4 ) => 3 } (0 .. 3)), # LD rp[p], nn
    (map { 0b00001001 | ($_ << 4 ) => 1 } (0 .. 3)), # ADD HL, rp[p]
    # x=0, z=2
    (map { 0b00000010 | ($_ << 3) => 1 } (0 .. 3)), # LD (BC/DE), A; LD A, (BC/DE)
    (map { 0b00000010 | ($_ << 3) => 3 } (4 .. 7)), #  LD (nn), HL/A, LD HL/A, (nn)
    # x=0, z=3
    (map { 0b00000011 | ($_ << 3) => 1 } (0 .. 7)), # INC/DEC rp
    # x=0, z=4
    (map { 0b00000100 | ($_ << 3) => 1 } (0 .. 7)), # INC r[y]
    # x=0, z=5
    (map { 0b00000101 | ($_ << 3) => 1 } (0 .. 7)), # DEC r[y]
    # x=0, z=6
    (map { 0b00000110 | ($_ << 3) => 2 } (0 .. 7)), # LD r[y], n
    # x=0, z=7: RLCA, RRCA, RLA, RRA, DAA, CPL, SCF, CCF
    (map { 0b00000111 | ($_ << 3) => 1 } (0 .. 7)),
    # x=1
    (map { 0b01000000 + $_ => 1 } (0 .. 63)), # LD r[y], r[z], HALT
    # x=2
    (map { 0b10000000 + $_ => 1 } (0 .. 63)), # alu[y] on A and r[z]
    # x=3, z=0
    (map { 0b11000000 | ($_ << 3) => 1 } (0 .. 7)), # RET cc[y]
    (map { 0b11000001 | ($_ << 3) => 1 } (0 .. 7)), # POP rp2[p]/RET/EXX/JP HL/LD SP, HL
    (map { 0b11000010 | ($_ << 3) => 3 } (0 .. 7)), # JP cc[y], nn
    (map { 0b11000100 | ($_ << 3) => 3 } (0 .. 7)), # CALL cc[y], nn
    (map { 0b11000101 | ($_ << 4) => 1 } (0 .. 3)), # PUSH rp2[p]
    (map { 0b11000110 | ($_ << 3) => 2 } (0 .. 7)), # ALU[y] A, n
    (map { 0b11000111 | ($_ << 3) => 1 } (0 .. 7)), # RST y*8
    (map { 0b11000011 | ($_ << 3) => 1 } (4 .. 7)), # EX(SP), HL/EX DE, HL/DI/EI
    0b11010011 => 2, # OUT (n), A
    0b11011011 => 2, # IN A, (n)
    0xC3 => 3, # JP nn
    0xCD => 3, # CALL nn

    0xCB, { (map { $_ => 1 } (0 .. 255)) }, # roll/shift/bit/res/set
    0xED, {
            (map { 0b01000000 | ($_ << 3) => 1 } (0 .. 7)), # IN r[y],(C)
            (map { 0b01000001 | ($_ << 3) => 1 } (0 .. 7)), # OUT (C),r[y]/OUT (C), 0
            (map { 0b01000010 | ($_ << 3) => 1 } (0 .. 7)), # ADC/SBC HL, rp[p]
            (map { 0b01000011 | ($_ << 3) => 3 } (0 .. 7)), # LD (nn), rp[p]/LD rp[p], (nn)
            (map { 0b01000100 | ($_ << 3) => 1 } (0 .. 7)), # NEG
            (map { 0b01000101 | ($_ << 3) => 1 } (0 .. 7)), # RETI/RETN
            (map { 0b01000110 | ($_ << 3) => 1 } (0 .. 7)), # IM im[y]
            (map { 0b01000111 | ($_ << 3) => 1 } (0 .. 7)), # LD I/R,A;LD A,I/R;RRD;RLD;NOP
            (map { 0b10000000 | $_ => 1 } (0 .. 63)), # block instrs
            # invalid instr, equiv to NOP
            (map { $_ => 1 } ( 0b00000000 .. 0b00111111,
                               0b11000000 .. 0b11111111)),
          },
);
$INSTR_LENGTHS{0xDD} = $INSTR_LENGTHS{0xFD} = {
    # NB lengths in here do *not* include the prefix
    (map { $_ => $INSTR_LENGTHS{$_} } (0 .. 255)),
    0x34 => 2, # INC (IX + d)
    0x35 => 2, # DEC (IX + d)
    0x36 => 3, # LD (IX + d), n
    0x46 => 2, # LD B, (IX + n)
    0x4E => 2, # LD C, (IX + n)
    0x56 => 2, # LD D, (IX + n)
    0x5E => 2, # LD E, (IX + n)
    0x66 => 2, # LD H, (IX + n)
    0x6E => 2, # LD L, (IX + n)
    0x7E => 2, # LD A, (IX + n)
    0x70 => 2, # LD (IX + n), B
    0x71 => 2, # LD (IX + n), C
    0x72 => 2, # LD (IX + n), D
    0x73 => 2, # LD (IX + n), E
    0x74 => 2, # LD (IX + n), H
    0x75 => 2, # LD (IX + n), L
    0x77 => 2, # LD (IX + n), A
    0x86 => 2, # ADD A, (IX + n)
    0x8E => 2, # ADC A, (IX + n)
    0x96 => 2, # SUB A, (IX + n)
    0x9E => 2, # SBC A, (IX + n)
    0xA6 => 2, # AND (IX + n)
    0xAE => 2, # XOR (IX + n)
    0xB6 => 2, # OR  (IX + n)
    0xBE => 2, # CP  (IX + n)
    0xED => 1, # NOP
    0xCB => { map { $_ => 2 } (0 .. 255) },
    0xDD => { map { $_ => 1 } (0 .. 255) }, # magic
    0xFD => { map { $_ => 1 } (0 .. 255) }, # magic
};

# these are all passed a list of parameter bytes
%INSTR_DISPATCH = (
    # un-prefixed instructions
    0          => \&_NOP,
    0b00001000 => sub { _swap_regs(shift(), qw(AF AF_)); },
    0b00010000 => \&_DJNZ,
    0b00011000 => \&_JR_unconditional,
    (map { my $y = $_; ($_ << 3) => sub {
        _check_cond($_[0], $TABLE_CC[$y - 4]) &&
        _JR_unconditional(@_);
    } } (4 .. 7)),
    (map { my $p = $_; 0b00000001 | ($p << 4 ) => sub {
        _LD_r16_imm(shift(), $TABLE_RP[$p], @_) # LD rp[p], nn
    } } (0 .. 3)),
    (map { my $p = $_; 0b00001001 | ($_ << 4 ) => sub {
        _ADD_r16_r16(shift(), 'HL', $TABLE_RP[$p]) # ADD HL, rp[p]
    } } (0 .. 3)),
    0b00000010 => sub { _LD_indr16_r8($_[0], 'BC', 'A'); }, # LD (BC), A
    0b00001010 => sub { _LD_r8_indr16($_[0], 'A', 'BC'); }, # LD A, (BC)
    0b00010010 => sub { _LD_indr16_r8($_[0], 'DE', 'A'); }, # LD (DE), A
    0b00011010 => sub { _LD_r8_indr16($_[0], 'A', 'DE'); }, # LD A, (DE)
    0b00100010 => sub { _LD_ind_r16(shift(), 'HL', @_); }, # LD (nn), HL
    0b00101010 => sub { _LD_r16_ind(shift(), 'HL', @_); }, #LD HL, (nn)
    0b00110010 => sub { _LD_ind_r8(shift(), 'A', @_); }, # LD (nn), A
    0b00111010 => sub { _LD_r8_ind(shift(), 'A', @_); }, #LD A, (nn)
    (map {
        my($p, $q) = (($_ & 0b110) >> 1, $_ & 0b1);
        0b00000011 | ($_ << 3) => sub {
            $q ? _DEC($_[0], $TABLE_RP[$p]) # DEC rp[p]
               : _INC($_[0], $TABLE_RP[$p]) # INC rp[p]
        }
    } (0 .. 7)),
    (map { my $y = $_; 0b00000100 | ($_ << 3) => sub {
        _INC($_[0], $TABLE_R[$y], $_[1]) # INC r[y] or INC(IX/Y + d)
    } } (0 .. 7)),
    (map { my $y = $_; 0b00000101 | ($_ << 3) => sub {
        _DEC($_[0], $TABLE_R[$y], $_[1]) # DEC r[y] or DEC(IX/Y + d)
    } } (0 .. 7)),
    (map { my $y = $_; 0b00000110 | ($_ << 3) => sub {
        _LD_r8_imm(shift(), $TABLE_R[$y], @_) # LD r[y], n
    } } (0 .. 7)),
    0b00000111 => \&_RLCA,
    0b00001111 => \&_RRCA,
    0b00010111 => \&_RLA,
    0b00011111 => \&_RRA,
    0b00100111 => \&_DAA,
    0b00101111 => \&_CPL,
    0b00110111 => \&_SCF,
    0b00111111 => \&_CCF,
    (map { my $y = $_ >> 3; my $z = $_ & 0b111; 0b01000000 + $_ => sub {
        _LD_r8_r8(shift(), $TABLE_R[$y], $TABLE_R[$z], shift()); # LD r[y], r[z]
    } } (0 .. 0b111111)),
    0b01110110 => \&_HALT,
    (map { my $y = $_ >> 3; my $z = $_ & 0b111; 0b10000000 + $_ => sub {
        $TABLE_ALU[$y]->(shift(), 'A', $TABLE_R[$z], shift()); # alu[y] A, r[z]
    } } (0 .. 0b111111)),
    (map { my $y = $_; 0b11000110 | ($_ << 3) => sub {
        _LD_r8_imm($_[0], 'W', $_[1]);       # alu[y] A, n
        $TABLE_ALU[$y]->(shift(), 'A', 'W', shift());
    } } (0 .. 7)),
    (map { my $y = $_; 0b11000000 | ($_ << 3) => sub {
        _check_cond($_[0], $TABLE_CC[$y]) && # RET cc[y]
        _POP(shift(), 'PC');
    } } (0 .. 7)),
    (map { my $p = $_; 0b11000001 | ($_ << 4) => sub {
        _POP(shift(), $TABLE_RP2[$p]); # POP rp2[p]
    } } (0 .. 3)),
    (map { my $y = $_; 0b11000010 | ($_ << 3) => sub {
        _check_cond($_[0], $TABLE_CC[$y]) && # JP cc[y], nn
        _JP_unconditional(@_);
    } } (0 .. 7)),
    (map { my $y = $_; 0b11000100 | ($_ << 3) => sub {
        _check_cond($_[0], $TABLE_CC[$y]) && # CALL cc[y], nn
        _CALL_unconditional(@_);
    } } (0 .. 7)),
    (map { my $y = $_; 0b11000111 | ($_ << 3) => sub {
        _CALL_unconditional(shift(), $y * 8, 0); # RST y*8
    } } (0 .. 7)),
    0xC3 => \&_JP_unconditional,
    0b11010011 => \&_OUT_n_A, # OUT (n), A
    0b11011011 => \&_IN_A_n, # IN A, (n)
    0b11100011 => sub { # EX (SP), HL
        my $self = shift;
        _POP($self, 'WZ'); _PUSH($self, 'HL');
        _LD_r16_r16($self, 'HL', 'WZ');
    },
    0b11101011 => sub { _swap_regs(shift(), qw(DE HL)); },
    0b11110011 => \&_DI,
    0b11111011 => \&_EI,
    (map { my $p = $_; 0b11000101 | ($_ << 4) => sub {
        _PUSH(shift(), $TABLE_RP2[$p]); # PUSH rp2[p]
    } } (0 .. 3)),
    0xCD => \&_CALL_unconditional,
    0b11001001 => sub { _POP(shift(), 'PC'); }, # RET
    0b11011001 => \&_EXX,
    0b11101001 => sub { _LD_r16_r16($_[0], 'PC', 'HL'); }, # JP HL
    0b11111001 => sub { _LD_r16_r16($_[0], 'SP', 'HL'); }, # LD SP, HL

    # and finally,  prefixed instructions
    0xED, {
        (map { $_ => \&_NOP } ( 0b00000000 .. 0b00111111,
                                0b11000000 .. 0b11111111)),
        (map { my $y = $_; 0b01000000 | ($_ << 3) => sub {
            _IN_r_C(shift(), $TABLE_R[$y]); # IN r[y], (C)
        } } (0 .. 7)),
        (map { my $y = $_; 0b01000001 | ($_ << 3) => sub {
            _OUT_C_r(shift(), $TABLE_R[$y]); # OUT (C), r[y]
        } } (0 .. 5, 7)),
        0b01110001 => \&_OUT_C_0, # OUT (C), 0
        (map { my $p = $_; 0b01000010 | ($_ << 4) => sub {
            _SBC_r16_r16(shift(), 'HL', $TABLE_RP[$p]); # SBC HL, rp[p]
        } } (0 .. 3)),
        (map { my $p = $_; 0b01001010 | ($_ << 4) => sub {
            _ADC_r16_r16(shift(), 'HL', $TABLE_RP[$p]); # ADC HL, rp[p]
        } } (0 .. 3)),
        (map { my $p = $_; 0b01000011 | ($_ << 4) => sub {
            _LD_ind_r16(shift(), $TABLE_RP[$p], @_); # LD (nn), rp[p]
        } } (0 .. 3)),
        (map { my $p = $_; 0b01001011 | ($_ << 4) => sub {
            _LD_r16_ind(shift(), $TABLE_RP[$p], @_); # LD rp[p], (nn)
        } } (0 .. 3)),
        (map { 0b01000100 | ($_ << 3) => \&_NEG } (0 .. 7)), # NEG
        (map { 0b01000101 | ($_ << 3) => ($_== 1 ? \&_RETI : \&_RETN) }
            (0 .. 7)),
        (map { my $y = $_; 0b01000110 | ($_ << 3) => sub {
            _IM(shift(), $y); # IM im[y]
        } } (0 .. 7)),
        0b01000111 => sub { _LD_r8_r8(shift(), 'I', 'A'); }, # LD I, A
        0b01001111 => sub { _LD_r8_r8(shift(), 'R', 'A'); }, # LD R, A
        0b01010111 => \&_LD_A_I, # LD A, I
        0b01011111 => \&_LD_A_R, # LD A, R
        0b01100111 => \&_RRD,
        0b01101111 => \&_RLD,
        0b01110111 => \&_NOP,
        0b01111111 => \&_NOP,
        # x=1 is all invalid ...
        (map { 0b10000000 | $_ => \&_NOP } (0 .. 63)),
        # ... except for z = 0,1,2,3 and y = 4,5,6,7
        (map {
            my $y = $_; (map {
                my $z = $_;
                0b10000000 | ($y << 3) | $z => sub {
                    $TABLE_BLI[$y - 4]->[$z]->(@_)
                }
            } (0 .. 3))
        } (4 .. 7)),

    },
    0xCB, {
        (map { my $y = $_ >> 3; my $z = $_ & 7; 0b00000000 | $_ => sub {
                $TABLE_ROT[$y]->($_[0], $TABLE_R[$z], $_[1]);
        } } (0 .. 63)),
        (map { my $y = $_ >> 3; my $z = $_ & 7; 0b01000000 | $_ => sub {
                _BIT($_[0], $y, $TABLE_R[$z], $_[1]);
        } } (0 .. 63)),
        (map { my $y = $_ >> 3; my $z = $_ & 7; 0b10000000 | $_ => sub {
                _RES($_[0], $y, $TABLE_R[$z], $_[1]);
        } } (0 .. 63)),
        (map { my $y = $_ >> 3; my $z = $_ & 7; 0b11000000 | $_ => sub {
                _SET($_[0], $y, $TABLE_R[$z], $_[1]);
        } } (0 .. 63)),
    },
    0xDD, {
        (map { my $i = $_; $_ => sub {
               $INSTR_DISPATCH{$i}->(@_);
        } } (0 .. 255)),
        0xED => \&_NOP,
        0xDD => {
            0b00000000 => sub { $_[0]->{STOPREACHED} = 1 },
        },
        0xFD => {
            map { my $i = $_; $_ => sub {
                $INSTR_DISPATCH{0xDD}->{0xDD}->{$i}->(@_)
            } } (0 .. 255)
        },
        0xCB => {
            # these are all DD CB offset OPCODE. Yuck
            # the dispatcher calls DD->CB->offset passing the opcode
            # as a param.  This fixes things.
            map { my $d = $_; $_ => sub {
                $INSTR_DISPATCH{0xCB}->{$_[1]}->($_[0], $d)
            } } (0 .. 255)
        },
    },
    0xFD, {
        (map{my $i=$_; $_=>sub {$INSTR_DISPATCH{$i}->(@_)}} (0 .. 255)),
        0xED => \&_NOP,
        0xDD => {
            map { my $i = $_; $_ => sub {
                $INSTR_DISPATCH{0xDD}->{0xDD}->{$i}->(@_)
            } } (0 .. 255)
        },
        0xFD => {
            map { my $i = $_; $_ => sub {
                $INSTR_DISPATCH{0xDD}->{0xDD}->{$i}->(@_)
            } } (0 .. 255)
        },
        0xCB => {
            map { my $i = $_; $_ => sub {
                $INSTR_DISPATCH{0xDD}->{0xCB}->{$i}->(@_)
            } } (0 .. 255)
        }
    },
);

sub nmi {
    my $self = shift;
    $self->{iff2} = $self->{iff1};
    $self->{iff1} = 0;
    $self->{NMI} = 1;
}
sub interrupt {
    my $self = shift;
    if(_interrupts_enabled($self)) {
        $self->{INTERRUPT} = 1;
        _DI($self);
        return 1;
    }
    return 0;
}
sub _interrupts_enabled {
    my($self, $toggle) = @_;
    return $self->{iff1} if(!defined($toggle));
    $self->{iff1} = $self->{iff2} = $toggle;
}

sub run {
    my $self = shift;
    my $instrs_to_execute = -1;
    $instrs_to_execute = shift() if(@_);

    RUNLOOP: while($instrs_to_execute) {
        delete $self->{STOPREACHED};
        $instrs_to_execute--;
        $self->{instr_length_table} = \%INSTR_LENGTHS;
        $self->{instr_dispatch_table} = \%INSTR_DISPATCH;
        $self->{prefix_bytes} = [];
        if($self->{NMI}) {
            delete $self->{NMI};
            _DI($self);
            _CALL_unconditional($self, 0x66, 0x00);
        } elsif($self->{INTERRUPT}) {
            delete $self->{INTERRUPT};
            _DI($self);
            $self->_execute(0xFF);
        } else { $self->_execute($self->_fetch()); }
        delete $self->{instr_length_table};
        delete $self->{instr_dispatch_table};
        delete $self->{prefix_bytes};
        if($self->{STOPREACHED}) {
            last RUNLOOP;
        }
    }
}

sub stopped {
    my $self = shift;
    return exists($self->{STOPREACHED});
}

# fetch all the bytes for an instruction and return them
sub _fetch {
    my $self = shift;
    my $pc = $self->register('PC')->get();
    
    $self->register('R')->inc() # don't inc for DDCB and FDCB
        unless(
            $self->_got_prefix(0xCB) &&
            ($self->_got_prefix(0xDD) || $self->_got_prefix(0xFD))
        );
    my $byte = $self->memory()->peek($pc);
    my @bytes = ($byte);

    # prefix byte
    if(ref($self->{instr_length_table}->{$byte})) {
        # printf("Found prefix byte %#04x\n", $byte);
        $self->{instr_dispatch_table} = $self->{instr_dispatch_table}->{$byte};
        $self->{instr_length_table} = $self->{instr_length_table}->{$byte};
        push @{$self->{prefix_bytes}}, $byte;
        $self->register('PC')->inc(); # set($pc + 1);
        return $self->_fetch();
    }

    my $bytes_to_fetch = $self->{instr_length_table}->{$byte};
    
    die(sprintf(
        "_fetch: Unknown instruction 0x%02X at 0x%04X with prefix bytes ["
          .join(' ', map { "0x%02X" } @{$self->{prefix_bytes}})
          ."]\n", $byte, $pc, @{$self->{prefix_bytes}}
    )) if($bytes_to_fetch eq 'UNDEFINED');

    push @bytes, map { $self->memory()->peek($pc + $_) } (1 .. $bytes_to_fetch - 1);
    $self->register('PC')->set($pc + $bytes_to_fetch);
    return @bytes;
}

# execute an instruction. NB, the PC already points at the next instr
sub _execute {
    my($self, $instr) = (shift(), shift());
    if(
        exists($self->{instr_dispatch_table}->{$instr}) &&
        ref($self->{instr_dispatch_table}->{$instr}) &&
        reftype($self->{instr_dispatch_table}->{$instr}) eq 'CODE'
    ) {
        _swap_regs($self, qw(HL IX)) if($self->_got_prefix(0xDD));
        _swap_regs($self, qw(HL IY)) if($self->_got_prefix(0xFD));
        $self->{instr_dispatch_table}->{$instr}->($self, @_);
        _swap_regs($self, qw(HL IY)) if($self->_got_prefix(0xFD));
        _swap_regs($self, qw(HL IX)) if($self->_got_prefix(0xDD));
    } else {
        die(sprintf(
            "_execute: No entry in dispatch table for instr "
              .join(' ', map { "0x%02x" } (@{$self->{prefix_bytes}}, $instr))
              ." of known length, near addr 0x%04x\n",
            @{$self->{prefix_bytes}}, $instr, $self->register('PC')->get()
        ));
    }
}

sub _got_prefix {
    my($self, $prefix) = @_;
    return grep { $_ == $prefix } @{$self->{prefix_bytes}}
}

sub _check_cond {
    my($self, $cond) = @_;
    my $f = $self->register('F');
    return
           $cond eq 'NC' ? !$f->getC() :
           $cond eq 'C'  ?  $f->getC() :
           $cond eq 'NZ' ? !$f->getZ() :
           $cond eq 'Z'  ?  $f->getZ() :
           $cond eq 'PO' ? !$f->getP() :
           $cond eq 'PE' ?  $f->getP() :
           $cond eq 'P'  ? !$f->getS() :
                            $f->getS()
}

sub _ADD_r16_r16 {
    my($self, $r1, $r2, $c) = @_;
    # $c is defined if this is really SBC
    my $adc = 0 + defined($c);
    $c ||= 0;
    $self->register($r1)->add($self->register($r2)->get() + $c, $adc);
}
sub _ADC_r16_r16 {
    # ADC also frobs S, Z and P, unlike ADD. argh. the magic $c
    # will communicate that
    _ADD_r16_r16(@_, $_[0]->register('F')->getC());
}
sub _ADC_r8_r8 { _ADD_r8_r8(@_[0..3], $_[0]->register('F')->getC()); }
sub _ADD_r8_r8 {
    my($self, $r1, $r2, $d, $c) = @_;
    # $c is defined if this is really ADC
    $c ||= 0;
    _LD_r8_indHL($self, 'W', $d) if($r2 eq '(HL)');
    $self->register($r1)->add($self->register($r2)->get() + $c);
}
sub _RES { _RES_SET($_[0], 0, @_[1 .. $#_]); }
sub _SET { _RES_SET($_[0], 1, @_[1 .. $#_]); }
sub _RES_SET {
    my($self, $value, $bit, $r, $d) = @_;

    if(defined($d) && $r ne '(HL)') { # weirdo DDCB*
        my $realr = $r;
        $realr .= $self->_got_prefix(0xDD) ? 'IX' : 'IY'
            if($realr =~ /^[HL]$/);
        $r = '(HL)';
        _LD_r8_indHL($self, 'W', $d);
        $self->register($r)->set(            # RES by default
            $self->register($r)->get() & (255 - 2**$bit)
        );
        $self->register($r)->set(            # SET if asked to
             $self->register($r)->get() | (2**$bit)
        ) if($value);
        _LD_indHL_r8($self, 'W', $d) if($r eq '(HL)');
        _LD_r8_r8($self, $realr, 'W');
    } else {
        _LD_r8_indHL($self, 'W', $d);
        $self->register($r)->set(            # RES by default
            $self->register($r)->get() & (255 - 2**$bit)
        );
        $self->register($r)->set(            # SET if asked to
             $self->register($r)->get() | (2**$bit)
        ) if($value);
        _LD_indHL_r8($self, 'W', $d) if($r eq '(HL)');
    }

}
sub _BIT {
    my($self, $bit, $r, $d) = @_; # $d is for DDCB/FFCB - NYI
    
    my $realr = $r;
    $r = '(HL)' if(defined($d));

    _LD_r8_indHL($self, 'W', $d) if($r eq '(HL)');

    my $f = $self->register('F');
    $f->setZ(!($self->register($r)->get() & 2**$bit));
    $f->setH();
    $f->resetN();
    $f->setS($bit == 7 && $self->register($r)->get() & 0x80);
    $f->setP($self->register('F')->getZ());
    $f->set5($self->register($r)->get() & 0b100000);
    $f->set3($self->register($r)->get() & 0b1000);
    if(defined($d)) {
        $f->set5(((ALU_getsigned($d, 8) + $self->register('HL')->get()) >> 8) & 0b100000);
        $f->set3(((ALU_getsigned($d, 8) + $self->register('HL')->get()) >> 8) & 0b1000);
    }
}

sub _binop {
    my($self, $r1, $r2, $d, $op) = @_;
    # $r1 is always A, $r2 is A/B/C/D/EH/L/(HL)/W/Z
    _LD_r8_indHL($self, 'W', $d) if($r2 eq '(HL)');
    # if($r2 eq '(HL)') {
    #     my @addr = map { $self->register($_)->get()} qw(L H);
    #     _LD_r8_ind($self, 'W', @addr);
    #     $r2 = 'W';
    # }
    $self->register($r1)->set(eval
        '$self->register($r1)->get() '.$op.' $self->register($r2)->get()'
    );
    die($@) if($@);
    $self->register('F')->setS($self->register($r1)->get() & 0x80);
    $self->register('F')->setZ($self->register($r1)->get() == 0);
    $self->register('F')->set5($self->register($r1)->get() & 0b100000);
    $self->register('F')->setH($op eq '&');
    $self->register('F')->set3($self->register($r1)->get() & 0b1000);
    $self->register('F')->setP(ALU_parity($self->register($r1)->get()));
    $self->register('F')->resetN();
    $self->register('F')->resetC();
}
sub _AND_r8_r8 { _binop(@_, '&'); }
sub _OR_r8_r8  { _binop(@_, '|'); }
sub _XOR_r8_r8 { _binop(@_, '^'); }
sub _SBC_r8_r8 { _SUB_r8_r8(@_[0 .. 3], $_[0]->register('F')->getC()); }
sub _SBC_r16_r16 { _SUB_r16_r16(@_, $_[0]->register('F')->getC()); }
sub _SUB_r8_r8 {
    my($self, $r1, $r2, $d, $c) = @_;
    # $c is defined if this is really SBC
    $c ||= 0;
    die("Can't SUB with Z reg") if($r2 eq 'Z');
    _LD_r8_indHL($self, 'W', $d) if($r2 eq '(HL)');
    $self->register($r1)->sub($self->register($r2)->get() + $c);
}
sub _SUB_r16_r16 {
    my($self, $r1, $r2, $c) = @_;
    # $c is defined if this is really SBC
    $c ||= 0;
    $self->register($r1)->sub($self->register($r2)->get() + $c);
}
sub _CP_r8_r8 {
    # $r1 is always A, $r2 is A/B/C/D/EH/L/(HL)/W
    my($self, $r1, $r2, $d) = @_;

    # bleh, CP uses the *operand* to set flags 3 and 5, instead of
    # the result, so wrap SUB and correct afterwards.
    # this is why we can't SUB with the Z reg
    _LD_r8_r8($self, 'Z', $r1); # preserve r1
    _SUB_r8_r8($self, $r1, $r2, $d);
    # put result into Z - this is used by CPI
    _swap_regs($self, $r1, 'Z'); # restore r1, result into Z
    $self->register('F')->set5($self->register($r2)->get() & 0b100000);
    $self->register('F')->set3($self->register($r2)->get() & 0b1000);
}
sub _DEC {
    my($self, $r, $d) = @_;
    _LD_r8_indHL($self, 'W', $d) if($r eq '(HL)');
    $self->register($r)->dec();
    _LD_indHL_r8($self, 'W', $d) if($r eq '(HL)');
    # my($self, $r) = @_;
    # if($r eq '(HL)') {
    #     my @addr = map { $self->register($_)->get()} qw(L H);
    #     _LD_r8_ind($self, 'W', @addr);
    #     $self->register('W')->dec();
    #     _LD_ind_r8($self, 'W', @addr);
    # } else {
    #     $self->register($r)->dec();
   #  }
}
sub _EXX {
    my $self = shift;
    _swap_regs($self, qw(BC BC_));
    _swap_regs($self, qw(DE DE_));
    _swap_regs($self, qw(HL HL_));

}
sub _DJNZ {
    my($self, $offset) = @_;

    _LD_r8_r8($self, 'W', 'F');          # preserve flags

    $self->register('B')->dec();         # decrement B and ...
    if($self->register('B')->get()) {    # jump if not zero
        $self->register('PC')->set(
            $self->register('PC')->get() +
            ALU_getsigned($offset, 8)
        );
    }
    _LD_r8_r8($self, 'F', 'W');          # restore flags
}
sub _HALT { shift()->register('PC')->dec(); select(undef, undef, undef, 0.01) }
sub _INC {
    my($self, $r, $d) = @_;
    _LD_r8_indHL($self, 'W', $d) if($r eq '(HL)');
    $self->register($r)->inc();
    _LD_indHL_r8($self, 'W', $d) if($r eq '(HL)');
}
sub _LDI {
    my $self = shift;
    my $f = $self->register('F');
    _LD_r8_indr16($self, 'W', 'HL'); # get from (HL);
    _LD_indr16_r8($self, 'DE', 'W'); # put to (DE);
    $self->register('DE')->inc();
    $self->register('HL')->inc();
    $self->register('BC')->dec();
    $f->set5(($self->register('A')->get() + $self->register('W')->get()) & 2);
    $f->set3(($self->register('A')->get() + $self->register('W')->get()) & 8);
    $f->setP($self->register('BC')->get() != 0);
    $f->resetN();
    $f->resetH();
}
sub _LDIR {
    my $self = shift;
    _LDI($self);
    $self->register('PC')->set($self->register('PC')->get() - 2)
        if($self->register('BC')->get());
}
sub _LDD {
    my $self = shift;
    _LDI($self); # cheat, do an LDI then correct HL and DE
    _swap_regs($self, qw(W F));
    $self->register('DE')->sub(2);
    $self->register('HL')->sub(2);
    _swap_regs($self, qw(W F));
}
sub _LDDR {
    my $self = shift;
    _LDD($self);
    $self->register('PC')->set($self->register('PC')->get() - 2)
        if($self->register('BC')->get());
}
sub _CPI {
    my $self = shift;
    my $f = $self->register('F');
    my $c = $f->getC();
    _CP_r8_r8($self, 'A', '(HL)');   # Z = A - (HL), S/Z/H now set OK
    $self->register('HL')->inc();
    $self->register('BC')->dec();
    $f->setP($self->register('BC')->get() != 0);
    $f->setC($c);
    $f->setN();
    $f->set5(
        ($self->register('Z')->get() - $f->getH()) & 0b10
    );
    $f->set3(
        ($self->register('Z')->get() - $f->getH()) & 0b1000
    );
}
sub _CPIR {
    my $self = shift;
    _CPI($self);
    $self->register('PC')->set($self->register('PC')->get() - 2)
        if($self->register('BC')->get() && $self->register('Z')->get());
    
}
sub _CPD {
    my $self = shift;
    _CPI($self); # cheat, do a CPI then correct HL
    _swap_regs($self, qw(W F));
    $self->register('HL')->sub(2);
    _swap_regs($self, qw(W F));
}
sub _CPDR {
    my $self = shift;
    _CPD($self);
    $self->register('PC')->set($self->register('PC')->get() - 2)
        if($self->register('BC')->get() && $self->register('Z')->get());
}
sub _RLD {
    my $self = shift;
    my($a, $f, $w, $z) = map { $self->register($_) } (qw(A F W Z));
    _LD_r8_indHL($self, 'W');                         # get (HL)
    $z->set($a->get() & 0x0F);
    $a->set(($a->get() & 0xF0) | ($w->get() & 0xF0) >> 4);# A now kosher
    $w->set(($w->get() <<  4)  | $z->get());          # W now correct
    _LD_indHL_r8($self, 'W');                         # (HL) now correct
    $f->setS($a->get() & 0x80);
    $f->setZ($a->get() == 0);
    $f->set5($a->get() & 0b100000);
    $f->set3($a->get() & 0b1000);
    $f->setP(ALU_parity($a->get()));
    $f->resetH();
    $f->resetN();
}
sub _RRD {
    my $self = shift;
    my($a, $f, $w, $z) = map { $self->register($_) } (qw(A F W Z));
    _LD_r8_indHL($self, 'W');                         # get (HL)
    $z->set($a->get() << 4);
    $a->set(($a->get() & 0xF0) | ($w->get() & 0x0F)); # A now correct
    $w->set(($w->get() >> 4)   | $z->get());          # W now correct
    _LD_indHL_r8($self, 'W');                         # (HL) now correct
    $f->setS($a->get() & 0x80);
    $f->setZ($a->get() == 0);
    $f->set5($a->get() & 0b100000);
    $f->set3($a->get() & 0b1000);
    $f->setP(ALU_parity($a->get()));
    $f->resetH();
    $f->resetN();
}
sub _JR_unconditional {
    my($self, $offset) = @_;
    $self->register('PC')->set(
        $self->register('PC')->get() +
        ALU_getsigned($offset, 8)
    );
}
sub _JP_unconditional {
    _LD_r16_imm(shift(), 'PC', @_);
}
sub _CALL_unconditional {
    _PUSH($_[0], 'PC');
    _JP_unconditional(@_);
}
sub _LD_ind_r16 {
    my($self, $r16, @bytes) = @_;
    $self->memory()->poke16($bytes[0] + 256 * $bytes[1], $self->register($r16)->get())
}
sub _LD_ind_r8 {
    my($self, $r8, @bytes) = @_;
    $self->memory()->poke($bytes[0] + 256 * $bytes[1], $self->register($r8)->get())
}
sub _LD_indHL_r8 {
    my($self, $r8, $d) = @_;
    $d = ALU_getsigned($d || 0, 8);
    $self->memory()->poke($d + $self->register('HL')->get(), $self->register($r8)->get())
}
sub _LD_indr16_r8 {
    my($self, $r16, $r8) = @_;
    $self->memory()->poke($self->register($r16)->get(), $self->register($r8)->get());
}
sub _LD_r16_imm {
    # self, register, lo, hi
    my $self = shift;
    $self->register(shift())->set(shift() + 256 * shift());
}
sub _LD_r8_imm {
    # self, register, data
    my($self, $r, $d, $byte) = @_;
    # yuck, (IX+d) puts d first
    ($d, $byte) = ($byte, $d) if(!defined($byte));
    $self->register($r)->set($byte);
    _LD_indHL_r8($self, 'W', $d) if($r eq '(HL)');
}
sub _LD_r16_ind {
    my($self, $r16, @bytes) = @_;
    $self->register($r16)->set($self->memory()->peek16($bytes[0] + 256 * $bytes[1]));
}
sub _LD_r8_indr16 {
    my($self, $r8, $r16) = @_;
    $self->register($r8)->set($self->memory()->peek($self->register($r16)->get()));
}
sub _LD_r8_ind {
    my($self, $r8, @bytes) = @_;
    $self->register($r8)->set($self->memory()->peek($bytes[0] + 256 * $bytes[1]));
}
sub _LD_r8_indHL {
    my($self, $r8, $d) = @_;
    $d = ALU_getsigned($d || 0, 8);
    $self->register($r8)->set($self->memory()->peek($d + $self->register('HL')->get()));
}
sub _LD_r16_r16 {
    my($self, $r1, $r2) = @_;
    $self->register($r1)->set($self->register($r2)->get());
}
sub _LD_r8_r8 {
    my($self, $r1, $r2, $d) = @_;
    # print "_LD_r8_r8 $r1, $r2 $d\n" if($d);
    if(defined($d) && $r2 eq '(HL)' && $r1 =~ /^[HL]$/) { # LD H/L, (IX/IY+d)
        $r1 .= $self->_got_prefix(0xDD) ? 'IX' : 'IY';
    } elsif(defined($d) && $r1 eq '(HL)' && $r2 =~ /^[HL]$/) { # LD (IX/IY+d), H/L
        $r2 .= $self->_got_prefix(0xDD) ? 'IX' : 'IY';
    }
    my $addr = $self->register('HL')->get() + ALU_getsigned($d, 8);
    my @addr = ($addr & 0xFF, $addr >> 8);
    if($r2 eq '(HL)') {
        _LD_r8_ind($self, 'W', @addr);
        $r2 = 'W';
    }
    if($r1 eq '(HL)') {
        _LD_ind_r8($self, $r2, @addr);
    } else {
        $self->register($r1)->set($self->register($r2)->get());
    }
}
# special casesof LD_r8_r8 which also frob some flags
sub _LD_A_R { _LD_A_IR(shift(), 'R'); }
sub _LD_A_I { _LD_A_IR(shift(), 'I'); }
sub _LD_A_IR {
    my($self, $r2) = @_;
    my($a, $f) = map { $self->register($_) } qw(A F);
    _LD_r8_r8($self, 'A', $r2);
    $f->resetH();
    $f->resetN();
    $f->set5($a->get() & 0b100000);
    $f->set3($a->get() & 0b1000);
    $f->setS($a->get() & 0x80);
    $f->setZ($a->get() == 0);
    $f->setP($self->{iff2});
}
sub _NEG {
    my $self = shift();
    _LD_r8_imm($self, 'W', 0);
    _SUB_r8_r8($self, 'W', 'A');
    _LD_r8_r8($self, 'A', 'W');
}
sub _NOP { }
sub _RLCA {
    my $self = shift;
    $self->register('A')->set(
        (($self->register('A')->get() & 0b01111111) << 1) |
        (($self->register('A')->get() & 0b10000000) >> 7)
    );
    $self->register('F')->resetH();
    $self->register('F')->resetN();
    $self->register('F')->set5($self->register('A')->get() & 0b100000);
    $self->register('F')->set3($self->register('A')->get() & 0b1000);
    $self->register('F')->setC($self->register('A')->get() & 1);
}
sub _RRCA {
    my $self = shift;
    $self->register('A')->set(
        (($self->register('A')->get() & 0b11111110) >> 1) |
        (($self->register('A')->get() & 1) << 7)
    );
    $self->register('F')->resetH();
    $self->register('F')->resetN();
    $self->register('F')->set5($self->register('A')->get() & 0b100000);
    $self->register('F')->set3($self->register('A')->get() & 0b1000);
    $self->register('F')->setC($self->register('A')->get() & 0x80);
}
sub _RLA {
    my $self = shift;
    my $msb = $self->register('A')->get() & 0b10000000;
    $self->register('A')->set(
        (($self->register('A')->get() & 0b01111111) << 1) |
        $self->register('F')->getC()
    );
    $self->register('F')->setC($msb);
    $self->register('F')->resetH();
    $self->register('F')->resetN();
}
sub _RRA {
    my $self = shift;
    my $lsb = $self->register('A')->get() & 1;
    my $c = $self->register('F')->getC();
    $self->register('A')->set(
        (($self->register('A')->get() & 0b11111110) >> 1) |
        ($c << 7)
    );
    $self->register('F')->setC($lsb);
    $self->register('F')->resetH();
    $self->register('F')->resetN();
}
# generic wrapper for CB prefixed ROTs - wrap around A-reg version
# and also diddle P/S/Z flags
sub _cb_rot {
    my($self, $fn, $r, $d) = @_;

    if(defined($d) && $r ne '(HL)') {
        $r .= $self->_got_prefix(0xDD) ? 'IX' : 'IY' if($r =~ /^[HL]$/);
        my $realr = $r;
        $r = '(HL)';
        _LD_r8_indHL($self, 'W', $d) if($r eq '(HL)');
        _swap_regs($self, $r, 'A') if($r ne 'A'); # preserve A, mv r to A
        $fn->($self);
        _swap_regs($self, $r, 'A') if($r ne 'A'); # swap back again
        _LD_indHL_r8($self, 'W', $d) if($r eq '(HL)');
        _LD_r8_r8($self, $realr, 'W');
    } else {
        _LD_r8_indHL($self, 'W', $d) if($r eq '(HL)');
        _swap_regs($self, $r, 'A') if($r ne 'A'); # preserve A, mv r to A
        $fn->($self);
        _swap_regs($self, $r, 'A') if($r ne 'A'); # swap back again
        _LD_indHL_r8($self, 'W', $d) if($r eq '(HL)');
    }

    # now frob extra flags
    $self->register('F')->setP(ALU_parity($self->register($r)->get()));
    $self->register('F')->setS($self->register($r)->get() & 0x80);
    $self->register('F')->setZ($self->register($r)->get() == 0);
}
sub _RLC {
    my($self, $r, $d) = @_;
    $self->_cb_rot(\&_RLCA, $r, $d);
}
sub _RRC {
    my($self, $r, $d) = @_;
    _cb_rot($self, \&_RRCA, $r, $d);
}
sub _RL {
    my($self, $r, $d) = @_;
    _cb_rot($self, \&_RLA, $r, $d);

    # extra flags not done by _cb_rot
    $r .= $self->_got_prefix(0xDD) ? 'IX' :
          $self->_got_prefix(0xFD) ? 'IY' : ''
        if($r =~ /^[HL]$/);
    $self->register('F')->set5($self->register($r)->get() & 0b100000);
    $self->register('F')->set3($self->register($r)->get() & 0b1000);
}
sub _RR {
    my($self, $r, $d) = @_;
    _cb_rot($self, \&_RRA, $r, $d);
    $r .= $self->_got_prefix(0xDD) ? 'IX' :
          $self->_got_prefix(0xFD) ? 'IY' : ''
        if($r =~ /^[HL]$/);
    $self->register('F')->set5($self->register($r)->get() & 0b100000);
    $self->register('F')->set3($self->register($r)->get() & 0b1000);
}
sub _SLA {
    my($self, $r, $d) = @_;

    if(defined($d) && $r ne '(HL)') { # weirdo DDCB*
        my $realr = $r;
        $realr .= $self->_got_prefix(0xDD) ? 'IX' : 'IY'
            if($realr =~ /^[HL]$/);
        $r = '(HL)';
        _LD_r8_indHL($self, 'W', $d);
        $self->register('F')->setC($self->register($r)->get() & 0x80);
        $self->register($r)->set($self->register($r)->get() << 1);
        _LD_indHL_r8($self, 'W', $d);
        _LD_r8_r8($self, $realr, 'W');
    } else {
        _LD_r8_indHL($self, 'W', $d) if($r eq '(HL)');
        $self->register('F')->setC($self->register($r)->get() & 0x80);
        $self->register($r)->set($self->register($r)->get() << 1);
        _LD_indHL_r8($self, 'W', $d) if($r eq '(HL)');
    }

    $self->register('F')->setZ($self->register($r)->get() == 0);
    $self->register('F')->set5($self->register($r)->get() & 0b100000);
    $self->register('F')->set3($self->register($r)->get() & 0b1000);
    $self->register('F')->setP(ALU_parity($self->register($r)->get()));
    $self->register('F')->setS($self->register($r)->get() & 0x80);
    $self->register('F')->resetH();
    $self->register('F')->resetN();
}
sub _SLL {
    my($self, $r, $d) = @_;

    if(defined($d) && $r ne '(HL)') { # weirdo DDCB*
        my $realr = $r;
        $realr .= $self->_got_prefix(0xDD) ? 'IX' : 'IY'
            if($realr =~ /^[HL]$/);
        $r = '(HL)';
        _LD_r8_indHL($self, 'W', $d);
        $self->register('F')->setC($self->register($r)->get() & 0x80);
        $self->register($r)->set($self->register($r)->get() << 1);
        $self->register($r)->set($self->register($r)->get() | 1);
        _LD_indHL_r8($self, 'W', $d);
        _LD_r8_r8($self, $realr, 'W');
    } else {
        _LD_r8_indHL($self, 'W', $d) if($r eq '(HL)');
        $self->register('F')->setC($self->register($r)->get() & 0x80);
        $self->register($r)->set($self->register($r)->get() << 1);
        $self->register($r)->set($self->register($r)->get() | 1);
        _LD_indHL_r8($self, 'W', $d) if($r eq '(HL)');
    }

    $self->register('F')->setZ($self->register($r)->get() == 0);
    $self->register('F')->set5($self->register($r)->get() & 0b100000);
    $self->register('F')->set3($self->register($r)->get() & 0b1000);
    $self->register('F')->setP(ALU_parity($self->register($r)->get()));
    $self->register('F')->setS($self->register($r)->get() & 0x80);
    $self->register('F')->resetH();
    $self->register('F')->resetN();
}
sub _SRA {
    my($self, $r, $d) = @_;

    if(defined($d) && $r ne '(HL)') { # weirdo DDCB*
        my $realr = $r;
        $realr .= $self->_got_prefix(0xDD) ? 'IX' : 'IY'
            if($realr =~ /^[HL]$/);
        $r = '(HL)';
        _LD_r8_indHL($self, 'W', $d);
        $self->register('F')->setC($self->register($r)->get() & 1);
        $self->register($r)->set(
            ($self->register($r)->get() & 0x80) |
            ($self->register($r)->get() >> 1)
        );
        _LD_indHL_r8($self, 'W', $d);
        _LD_r8_r8($self, $realr, 'W');
    } else {
        _LD_r8_indHL($self, 'W', $d) if($r eq '(HL)');
        $self->register('F')->setC($self->register($r)->get() & 1);
        $self->register($r)->set(
            ($self->register($r)->get() & 0x80) |
            ($self->register($r)->get() >> 1)
        );
        _LD_indHL_r8($self, 'W', $d) if($r eq '(HL)');
    }

    $self->register('F')->setZ($self->register($r)->get() == 0);
    $self->register('F')->set5($self->register($r)->get() & 0b100000);
    $self->register('F')->set3($self->register($r)->get() & 0b1000);
    $self->register('F')->setP(ALU_parity($self->register($r)->get()));
    $self->register('F')->setS($self->register($r)->get() & 0x80);
    $self->register('F')->resetH();
    $self->register('F')->resetN();
}
sub _SRL {
    my($self, $r, $d) = @_;

    if(defined($d) && $r ne '(HL)') { # weirdo DDCB*
        my $realr = $r;
        $realr .= $self->_got_prefix(0xDD) ? 'IX' : 'IY'
            if($realr =~ /^[HL]$/);
        $r = '(HL)';
        _LD_r8_indHL($self, 'W', $d);
        $self->register('F')->setC($self->register($r)->get() & 1);
        $self->register($r)->set(
            ($self->register($r)->get() & 0x80) |
            ($self->register($r)->get() >> 1)
        );
        $self->register($r)->set($self->register($r)->get() & 0x7F);
        _LD_indHL_r8($self, 'W', $d);
        _LD_r8_r8($self, $realr, 'W');
    } else {
        _LD_r8_indHL($self, 'W', $d) if($r eq '(HL)');
        $self->register('F')->setC($self->register($r)->get() & 1);
        $self->register($r)->set(
            ($self->register($r)->get() & 0x80) |
            ($self->register($r)->get() >> 1)
        );
        $self->register($r)->set($self->register($r)->get() & 0x7F);
        _LD_indHL_r8($self, 'W', $d) if($r eq '(HL)');
    }

    $self->register('F')->setZ($self->register($r)->get() == 0);
    $self->register('F')->set5($self->register($r)->get() & 0b100000);
    $self->register('F')->set3($self->register($r)->get() & 0b1000);
    $self->register('F')->setP(ALU_parity($self->register($r)->get()));
    $self->register('F')->setS($self->register($r)->get() & 0x80);
    $self->register('F')->resetH();
    $self->register('F')->resetN();
}
sub _DAA {
    my $self = shift;
    my $a = $self->register('A');
    my $f = $self->register('F');
    my($n, $h, $lo, $hi) =
        ($f->getN(), $f->getH(),
         $a->get() & 0x0F, ($a->get() >> 4) & 0x0F);
    my $table = [
        # NB this table comes from Sean Young's "The Undocumented
        # Z80 Documented".  Zaks is wrong.
        # http://www.z80.info/zip/z80-documented.pdf
        #   C high   H low add Cafter
        [qw(0 0-9    0 0-9 0   0)],
        [qw(0 0-9    1 0-9 6   0)],
        [qw(0 0-8    . a-f 6   0)],
        [qw(0 a-f    0 0-9 60  1)],
        [qw(1 0-9a-f 0 0-9 60  1)],
        [qw(1 0-9a-f 1 0-9 66  1)],
        [qw(1 0-9a-f . a-f 66  1)],
        [qw(0 9a-f   . a-f 66  1)],
        [qw(0 a-f    1 0-9 66  1)],
    ];
    foreach my $row (@{$table}) {
        my @row = @{$row};
        if(
            $f->getC() == $row[0] &&
            ($row[2] eq '.' || $f->getH() == $row[2]) &&
            sprintf('%x', ($a->get() >> 4) & 0x0F) =~ /^[$row[1]]$/ &&
            sprintf('%x', $a->get() & 0x0F) =~ /^[$row[3]]$/
        ) {
            $f->getN() ? $a->set(ALU_sub8($f, $a->get(), hex($row[4])))
                       : $a->set(ALU_add8($f, $a->get(), hex($row[4])));
            $f->setC($row[5]);
            last;
        }
    }
    $f->setH($lo > 9) if(!$n);
    $f->resetH()      if($n && !$h);
    $f->setH($lo < 6) if($n && $h);
    $f->set3($a->get() & 0b1000);
    $f->set5($a->get() & 0b100000);
    $f->setP(ALU_parity($a->get()));
}
sub _CPL {
    my $self = shift;
    $self->register('A')->set(~ $self->register('A')->get());
    $self->register('F')->setH();
    $self->register('F')->setN();
    $self->register('F')->set3($self->register('A')->get() & 0b1000);
    $self->register('F')->set5($self->register('A')->get() & 0b100000);
}
sub _SCF {
    my $self = shift();
    my $f = $self->register('F');
    my $a = $self->register('A');
    $f->setC();
    $f->resetH();
    $f->resetN();
    $f->set5($a->get() & 0b100000);
    $f->set3($a->get() & 0b1000);
}
sub _CCF {
    my $self = shift;
    my $f = $self->register('F');
    my $a = $self->register('A');
    $f->setH($f->getC());
    $f->setC(!$f->getC());
    $f->resetN();
    $f->set5($a->get() & 0b100000);
    $f->set3($a->get() & 0b1000);
}
sub _POP {
    my($self, $r) = @_;
    $self->register($r)->set(
        $self->memory()->peek16($self->register('SP')->get())
    );
    $self->register('SP')->add(2);
}
sub _PUSH {
    my($self, $r) = @_;
    $self->register('SP')->sub(2);
    $self->memory()->poke16(
        $self->register('SP')->get(),
        $self->register($r)->get()
    );
}
sub _IN_A_n {
    my($self, $lobyte) = @_;
    $self->register('A')->set(
        $self->_get_from_input(($self->register('A')->get() << 8) + $lobyte)
    );
}
sub _IN_r_C {
    my($self, $r) = @_;
    $r = $self->register($r); # for (HL) this is W and magically correct!
    $r->set($self->_get_from_input($self->register('BC')->get()));
    
    my $f = $self->register('F');
    $f->setS($r->get() & 0x80);
    $f->setZ($r->get() == 0);
    $f->set5($r->get() & 0b100000);
    $f->resetH();
    $f->set3($r->get() & 0b1000);
    $f->setP(ALU_parity($r->get()));
}

sub _OUT_n_A { # output A to B<<8 + n
    my($self, $n) = @_;
    $self->_put_to_output(
        ($self->register('B')->get() << 8) + $n,
        $self->register('A')->get()
    );
}
sub _OUT_C_r {
    my($self, $r) = @_;
    $self->_put_to_output(
        $self->register('BC')->get(),
        $self->register($r)->get()
    );
}
sub _OUT_C_0 {
    my $self = shift();
    $self->register('W')->set(0);
    _OUT_C_r($self, 'W');
}
sub _IND {
    my $self = shift;
    _IN_r_C($self, '(HL)');
    _LD_indHL_r8($self, 'W', 0);
    $self->register($_)->dec() foreach(qw(HL B));
}
sub _INI {
    my $self = shift;
    _IN_r_C($self, '(HL)');
    _LD_indHL_r8($self, 'W');
    $self->register('HL')->inc();
    $self->register('B')->dec();
}
sub _INDR {
    my $self = shift;
    _IND($self);
    $self->register('PC')->set($self->register('PC')->get() - 2)
        if($self->register('B')->get());
}
sub _INIR {
    my $self = shift;
    _INI($self);
    $self->register('PC')->set($self->register('PC')->get() - 2)
        if($self->register('B')->get());
}
sub _OUTD {
    my $self = shift;
    $self->register('B')->dec();
    $self->_put_to_output(
        $self->register('BC')->get(),
        $self->memory()->peek($self->register('HL')->get())
    );
    $self->register('HL')->dec();
}
sub _OUTI {
    my $self = shift;
    $self->register('B')->dec();
    $self->_put_to_output(
        $self->register('BC')->get(),
        $self->memory()->peek($self->register('HL')->get())
    );
    $self->register('HL')->inc();
}
sub _OTDR {
    my $self = shift;
    _OUTD($self);
    $self->register('PC')->set($self->register('PC')->get() - 2)
        if($self->register('B')->get());
}
sub _OTIR {
    my $self = shift;
    _OUTI($self);
    $self->register('PC')->set($self->register('PC')->get() - 2)
        if($self->register('B')->get());
}

sub _IM {} # everything is IM 1

sub _RETI {
    _POP(shift(), 'PC');
}
sub _RETN {
    my $self = shift();
    $self->{iff1} = $self->{iff2};
    _POP($self, 'PC');
}
sub _DI {
    my $self = shift;
    _interrupts_enabled($self, 0);
}
sub _EI {
    my $self = shift;
    _interrupts_enabled($self, 1);
}
sub _swap_regs {
    my($self, $r1, $r2) = @_;
    my $temp = $self->register($r1)->get();
    $self->register($r1)->set($self->register($r2)->get());
    $self->register($r2)->set($temp);
}


1;