/[VRac]/6502.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Contents of /6502.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3 - (show annotations)
Sun Jul 29 01:34:14 2007 UTC (16 years, 11 months ago) by dpavlin
File size: 33452 byte(s)
import CPU emulation from Acme-6502-v0.0.6
1 package Acme::6502;
2
3 use warnings FATAL => 'all';
4 use strict;
5 use Carp;
6 use Class::Std;
7
8 use version; our $VERSION = qv('0.0.6');
9
10 # CPU flags
11 use constant {
12 N => 0x80,
13 V => 0x40,
14 R => 0x20,
15 B => 0x10,
16 D => 0x08,
17 I => 0x04,
18 Z => 0x02,
19 C => 0x01
20 };
21
22 use constant FLAGS => 'NVRBDIZC';
23
24 # Other CPU constants
25 use constant {
26 STACK => 0x0100,
27 BREAK => 0xFFFE
28 };
29
30 # Opcode to thunk into perlspace
31 use constant {
32 ESCAPE_OP => 0x0B,
33 ESCAPE_SIG => 0xAD
34 };
35
36 my %cpu : ATTR;
37
38 sub BUILD {
39 my ($self, $id, $args) = @_;
40
41 my @mem = (0) x 65536;
42 my @os;
43 my ($a, $x, $y, $s, $p, $pc) = (0) x 6;
44
45 # Page used to allocate vector thunks
46 my $jumptab = $args->{jumptab} || 0xFA00;
47
48 my $bad_inst = sub {
49 croak sprintf("Bad instruction at &%04x (&%02x)\n",
50 $pc - 1, $mem[$pc - 1]);
51 };
52
53 my @zn = (Z, (0) x 127, (N) x 128);
54
55 my $inst = sub {
56 my $src = join("\n", @_);
57 my $cr = eval "sub { @_ }";
58 confess "$@" if $@;
59 return $cr;
60 };
61
62 my @decode = (
63 $inst->( # 00 BRK
64 _push('($pc + 1) >> 8', '($pc + 1)'),
65 _push('$p | B'),
66 '$p = $p | I & ~D;',
67 _jmp_i(BREAK)
68 ),
69 $inst->(_ora(_zpix())), # 01 ORA (zp, x)
70 $bad_inst, # 02
71 $bad_inst, # 03
72 $inst->(_tsb(_zp())), # 04 TSB zp
73 $inst->(_ora(_zp())), # 05 ORA zp
74 $inst->(_asl(_zp())), # 06 ASL zp
75 $bad_inst, # 07
76 $inst->(_push('$p | R')), # 08 PHP
77 $inst->(_ora(_imm())), # 09 ORA #imm
78 $inst->(_asl(_acc())), # 0A ASL A
79 $bad_inst, # 0B
80 $inst->(_tsb(_abs())), # 0C TSB zp
81 $inst->(_ora(_abs())), # 0D ORA abs
82 $inst->(_asl(_abs())), # 0E ASL abs
83 $bad_inst, # 0F BBR0 rel
84 $inst->(_bfz(_rel(), N)), # 10 BPL rel
85 $inst->(_ora(_zpiy())), # 11 ORA (zp), y
86 $inst->(_ora(_zpi())), # 12 ORA (zp)
87 $bad_inst, # 13
88 $inst->(_trb(_zpi())), # 14 TRB (zp)
89 $inst->(_ora(_zpx())), # 15 ORA zp, x
90 $inst->(_asl(_zpx())), # 16 ASL zp, x
91 $bad_inst, # 17
92 $inst->('$p &= ~C;'), # 18 CLC
93 $inst->(_ora(_absy())), # 19 ORA abs, y
94 $inst->(_inc(_acc())), # 1A INC A
95 $bad_inst, # 1B
96 $inst->(_trb(_abs())), # 1C TRB abs
97 $inst->(_ora(_absx())), # 1D ORA abs, x
98 $inst->(_asl(_absx())), # 1E ASL abs, x
99 $bad_inst, # 1F BBR1 rel
100 $inst->( # 20 JSR
101 _push('($pc + 1) >> 8', '($pc + 1)'),
102 _jmp()
103 ),
104 $inst->(_and(_zpix())), # 21 AND (zp, x)
105 $bad_inst, # 22
106 $bad_inst, # 23
107 $inst->(_bit(_zp())), # 24 BIT zp
108 $inst->(_and(_zp())), # 25 AND zp
109 $inst->(_rol(_zp())), # 26 ROL zp
110 $bad_inst, # 27
111 $inst->(_pop_p()), # 28 PLP
112 $inst->(_and(_imm())), # 29 AND #imm
113 $inst->(_rol(_acc())), # 2A ROL A
114 $bad_inst, # 2B
115 $inst->(_bit(_abs())), # 2C BIT abs
116 $inst->(_and(_abs())), # 2D AND abs
117 $inst->(_rol(_abs())), # 2E ROL abs
118 $bad_inst, # 2F BBR2 rel
119 $inst->(_bfnz(_rel(), N)), # 30 BPL rel
120 $inst->(_and(_zpiy())), # 31 AND (zp), y
121 $inst->(_and(_zpi())), # 32 AND (zp)
122 $bad_inst, # 33
123 $inst->(_bit(_zpx())), # 34 BIT zp, x
124 $inst->(_and(_zpx())), # 35 AND zp, x
125 $inst->(_rol(_zpx())), # 36 ROL zp, x
126 $bad_inst, # 37
127 $inst->('$p |= C;'), # 38 SEC
128 $inst->(_and(_absy())), # 39 AND abs, y
129 $inst->(_dec(_acc())), # 3A DEC A
130 $bad_inst, # 3B
131 $inst->(_bit(_absx())), # 3C BIT abs, x
132 $inst->(_and(_absx())), # 3D AND abs, x
133 $inst->(_rol(_absx())), # 3E ROL abs, x
134 $bad_inst, # 3F BBR3 rel
135 $inst->(_pop('$p'), _rts()), # 40 RTI
136 $inst->(_eor(_zpix())), # 41 EOR (zp, x)
137 $bad_inst, # 42
138 $bad_inst, # 43
139 $bad_inst, # 44
140 $inst->(_eor(_zp())), # 45 EOR zp
141 $inst->(_lsr(_zp())), # 46 LSR zp
142 $bad_inst, # 47
143 $inst->(_push('$a')), # 48 PHA
144 $inst->(_eor(_imm())), # 49 EOR imm
145 $inst->(_lsr(_acc())), # 4A LSR A
146 $bad_inst, # 4B
147 $inst->(_jmp()), # 4C JMP abs
148 $inst->(_eor(_abs())), # 4D EOR abs
149 $inst->(_lsr(_abs())), # 4E LSR abs
150 $bad_inst, # 4F BBR4 rel
151 $inst->(_bfz(_rel(), V)), # 50 BVC rel
152 $inst->(_eor(_zpiy())), # 51 EOR (zp), y
153 $inst->(_eor(_zpi())), # 52 EOR (zp)
154 $bad_inst, # 53
155 $bad_inst, # 54
156 $inst->(_eor(_zpx())), # 55 EOR zp, x
157 $inst->(_lsr(_zpx())), # 56 LSR zp, x
158 $bad_inst, # 57
159 $inst->('$p &= ~I;'), # 58 CLI
160 $inst->(_eor(_absy())), # 59 EOR abs, y
161 $inst->(_push('$y')), # 5A PHY
162 $bad_inst, # 5B
163 $bad_inst, # 5C
164 $inst->(_eor(_absx())), # 5D EOR abs, x
165 $inst->(_lsr(_absx())), # 5E LSR abs, x
166 $bad_inst, # 5F BBR5 rel
167 $inst->(_rts()), # 60 RTS
168 $inst->(_adc(_zpx())), # 61 ADC zp, x
169 $bad_inst, # 62
170 $bad_inst, # 63
171 $inst->(_sto(_zp(), '0')), # 64 STZ zp
172 $inst->(_adc(_zp())), # 65 ADC zp
173 $inst->(_ror(_zp())), # 66 ROR zp
174 $bad_inst, # 67
175 $inst->(_pop('$a'), _status('$a')), # 68 PLA
176 $inst->(_adc(_imm())), # 69 ADC #imm
177 $inst->(_ror(_acc())), # 6A ROR A
178 $bad_inst, # 6B
179 $inst->(_jmpi()), # 6C JMP (abs)
180 $inst->(_adc(_abs())), # 6D ADC abs
181 $inst->(_ror(_abs())), # 6E ROR abs
182 $bad_inst, # 6F BBR6 rel
183 $inst->(_bfnz(_rel(), V)), # 70 BVS rel
184 $inst->(_adc(_zpiy())), # 71 ADC (zp), y
185 $inst->(_adc(_zpi())), # 72 ADC (zp)
186 $bad_inst, # 73
187 $inst->(_sto(_zpx(), '0')), # 74 STZ zp, x
188 $inst->(_adc(_zpx())), # 75 ADC zp, x
189 $inst->(_adc(_zpx())), # 76 ROR zp, x
190 $bad_inst, # 77
191 $inst->('$p |= I;'), # 78 STI
192 $inst->(_adc(_absy())), # 79 ADC abs, y
193 $inst->(_pop('$y'), _status('$y')), # 7A PLY
194 $bad_inst, # 7B
195 $inst->(_jmpix()), # 7C JMP (abs, x)
196 $inst->(_adc(_absx())), # 7D ADC abs, x
197 $inst->(_ror(_absx())), # 7E ROR abs, x
198 $bad_inst, # 7F BBR7 rel
199 $inst->(_bra(_rel())), # 80 BRA rel
200 $inst->(_sto(_zpix(), '$a')), # 81 STA (zp, x)
201 $bad_inst, # 82
202 $bad_inst, # 83
203 $inst->(_sto(_zp(), '$y')), # 84 STY zp
204 $inst->(_sto(_zp(), '$a')), # 85 STA zp
205 $inst->(_sto(_zp(), '$x')), # 86 STX zp
206 $bad_inst, # 87
207 $inst->(_dec(('', '$y'))), # 88 DEY
208 $inst->(_bit(_imm())), # 89 BIT #imm
209 $inst->('$a = $x;' . _status('$a')), # 8A TXA
210 $bad_inst, # 8B
211 $inst->(_sto(_abs(), '$y')), # 8C STY abs
212 $inst->(_sto(_abs(), '$a')), # 8D STA abs
213 $inst->(_sto(_abs(), '$x')), # 8E STX abs
214 $bad_inst, # 8F BBS0 rel
215 $inst->(_bfz(_rel(), C)), # 90 BCC rel
216 $inst->(_sto(_zpiy(), '$a')), # 91 STA (zp), y
217 $inst->(_sto(_zpi(), '$a')), # 92 STA (zp)
218 $bad_inst, # 93
219 $inst->(_sto(_zpx(), '$y')), # 94 STY zp, x
220 $inst->(_sto(_zpx(), '$a')), # 95 STA zp, x
221 $inst->(_sto(_zpy(), '$x')), # 96 STX zp, y
222 $bad_inst, # 97
223 $inst->('$a = $y;' . _status('$a')), # 98 TYA
224 $inst->(_sto(_absy(), '$a')), # 99 STA abs, y
225 $inst->('$s = $x;'), # 9A TXS
226 $bad_inst, # 9B
227 $inst->(_sto(_abs(), '0')), # 9C STZ abs
228 $inst->(_sto(_absx(), '$a')), # 9D STA abs, x
229 $inst->(_sto(_absx(), '0')), # 9E STZ abs, x
230 $bad_inst, # 9F BBS1 rel
231 $inst->(_lod(_imm(), '$y')), # A0 LDY #imm
232 $inst->(_lod(_zpix(), '$a')), # A1 LDA (zp, x)
233 $inst->(_lod(_imm(), '$x')), # A2 LDX #imm
234 $bad_inst, # A3
235 $inst->(_lod(_zp(), '$y')), # A4 LDY zp
236 $inst->(_lod(_zp(), '$a')), # A5 LDA zp
237 $inst->(_lod(_zp(), '$x')), # A6 LDX zp
238 $bad_inst, # A7
239 $inst->('$y = $a;' . _status('$y')), # A8 TAY
240 $inst->(_lod(_imm(), '$a')), # A9 LDA #imm
241 $inst->('$x = $a;' . _status('$x')), # AA TAX
242 $bad_inst, # AB
243 $inst->(_lod(_abs(), '$y')), # AC LDY abs
244 $inst->(_lod(_abs(), '$a')), # AD LDA abs
245 $inst->(_lod(_abs(), '$x')), # AE LDX abs
246 $bad_inst, # AF BBS2 rel
247 $inst->(_bfnz(_rel(), C)), # B0 BCS rel
248 $inst->(_lod(_zpiy(), '$a')), # B1 LDA (zp), y
249 $inst->(_lod(_zpi(), '$a')), # B2 LDA (zp)
250 $bad_inst, # B3
251 $inst->(_lod(_zpx(), '$y')), # B4 LDY zp, x
252 $inst->(_lod(_zpx(), '$a')), # B5 LDA zp, x
253 $inst->(_lod(_zpy(), '$x')), # B6 LDX zp, y
254 $bad_inst, # B7
255 $inst->('$p &= ~V;'), # B8 CLV
256 $inst->(_lod(_absy(), '$a')), # B9 LDA abs, y
257 $inst->('$x = $s;'), # BA TSX
258 $bad_inst, # BB
259 $inst->(_lod(_absx(), '$y')), # BC LDY abs, x
260 $inst->(_lod(_absx(), '$a')), # BD LDA abs, x
261 $inst->(_lod(_absy(), '$x')), # BE LDX abs, y
262 $bad_inst, # BF BBS3 rel
263 $inst->(_cmp(_imm(), '$y')), # C0 CPY #imm
264 $inst->(_cmp(_zpix(), '$a')), # C1 CMP (zp, x)
265 $bad_inst, # C2
266 $bad_inst, # C3
267 $inst->(_cmp(_zp(), '$y')), # C4 CPY zp
268 $inst->(_cmp(_zp(), '$a')), # C5 CMP zp
269 $inst->(_dec(_zp())), # C6 DEC zp
270 $bad_inst, # C7
271 $inst->(_inc(('', '$y'))), # C8 INY
272 $inst->(_cmp(_imm(), '$a')), # C9 CMP #imm
273 $inst->(_dec(('', '$x'))), # CA DEX
274 $bad_inst, # CB
275 $inst->(_cmp(_abs(), '$y')), # CC CPY abs
276 $inst->(_cmp(_abs(), '$a')), # CD CMP abs
277 $inst->(_dec(_abs())), # CE DEC abs
278 $bad_inst, # CF BBS4 rel
279 $inst->(_bfz(_rel(), Z)), # D0 BNE rel
280 $inst->(_cmp(_zpiy(), '$a')), # D1 CMP (zp), y
281 $inst->(_cmp(_zpi(), '$a')), # D2 CMP (zp)
282 $bad_inst, # D3
283 $bad_inst, # D4
284 $inst->(_cmp(_zpx(), '$a')), # D5 CMP zp, x
285 $inst->(_dec(_zpx())), # D6 DEC zp, x
286 $bad_inst, # D7
287 $inst->('$p &= ~D;'), # D8 CLD
288 $inst->(_cmp(_absy(), '$a')), # D9 CMP abs, y
289 $inst->(_push('$x')), # DA PHX
290 $bad_inst, # DB
291 $bad_inst, # DC
292 $inst->(_cmp(_absx(), '$a')), # DD CMP abs, x
293 $inst->(_dec(_absx())), # DE DEC abs, x
294 $bad_inst, # DF BBS5 rel
295 $inst->(_cmp(_imm(), '$x')), # E0 CPX #imm
296 $inst->(_sbc(_zpix(), '$a')), # E1 SBC (zp, x)
297 $bad_inst, # E2
298 $bad_inst, # E3
299 $inst->(_cmp(_zp(), '$x')), # E4 CPX zp
300 $inst->(_sbc(_zp())), # E5 SBC zp
301 $inst->(_inc(_zp())), # E6 INC zp
302 $bad_inst, # E7
303 $inst->(_inc(('', '$x'))), # E8 INX
304 $inst->(_sbc(_imm())), # E9 SBC #imm
305 $inst->(), # EA NOP
306 $bad_inst, # EB
307 $inst->(_cmp(_abs(), '$x')), # EC CPX abs
308 $inst->(_sbc(_abs())), # ED SBC abs
309 $inst->(_inc(_abs())), # EE INC abs
310 $bad_inst, # EF BBS6 rel
311 $inst->(_bfnz(_rel(), Z)), # F0 BEQ rel
312 $inst->(_sbc(_zpiy())), # F1 SBC (zp), y
313 $inst->(_sbc(_zpi())), # F2 SBC (zp)
314 $bad_inst, # F3
315 $bad_inst, # F4
316 $inst->(_sbc(_zpx())), # F5 SBC zp, x
317 $inst->(_inc(_zpx())), # F6 INC zp, x
318 $bad_inst, # F7
319 $inst->('$p |= D;'), # F8 SED
320 $inst->(_sbc(_absy())), # F9 SBC abs, y
321 $inst->(_pop('$x'), _status('$x')), # FA PLX
322 $bad_inst, # FB
323 $bad_inst, # FC
324 $inst->(_sbc(_absx())), # FD SBC abs, x
325 $inst->(_inc(_absx())), # FE INC abs, x
326 $bad_inst # FF BBS7 rel
327 );
328
329 confess "Escape handler opcode not available"
330 unless $decode[ESCAPE_OP] == $bad_inst;
331
332 # Patch in the OS escape op handler
333 $decode[ESCAPE_OP] = sub {
334 if ($mem[$pc] != ESCAPE_SIG) {
335 $bad_inst->();
336 } else {
337 $pc += 2;
338 $self->call_os($mem[$pc - 1]);
339 }
340 };
341
342 $cpu{$id} = {
343 set_jumptab => sub {
344 $jumptab = shift;
345 },
346
347 read_str => sub {
348 my $addr = shift;
349 my $str = '';
350 while ($mem[$addr] != 0x0D) {
351 $str .= chr($mem[$addr++]);
352 }
353 return $str;
354 },
355
356 read_chunk => sub {
357 my ($from, $to) = @_;
358 return pack('C*', @mem[$from .. $to - 1]);
359 },
360
361 write_chunk => sub {
362 my ($addr, $chunk) = @_;
363 my $len = length($chunk);
364 splice @mem, $addr, $len, unpack('C*', $chunk);
365 },
366
367 read_8 => sub {
368 my $addr = shift;
369 return $mem[$addr];
370 },
371
372 write_8 => sub {
373 my ($addr, $val) = @_;
374 $mem[$addr] = $val;
375 },
376
377 read_16 => sub {
378 my $addr = shift;
379 return $mem[$addr] | ($mem[$addr + 1] << 8);
380 },
381
382 write_16 => sub {
383 my ($addr, $val) = @_;
384 $mem[$addr + 0] = ($val >> 0) & 0xFF;
385 $mem[$addr + 1] = ($val >> 8) & 0xFF;
386 },
387
388 read_32 => sub {
389 my $addr = shift;
390 return $mem[$addr] | ($mem[$addr + 1] << 8) |
391 ($mem[$addr + 2] << 16) | ($mem[$addr + 3] << 32);
392 },
393
394 write_32 => sub {
395 my ($addr, $val) = @_;
396 $mem[$addr + 0] = ($val >> 0) & 0xFF;
397 $mem[$addr + 1] = ($val >> 8) & 0xFF;
398 $mem[$addr + 2] = ($val >> 16) & 0xFF;
399 $mem[$addr + 3] = ($val >> 24) & 0xFF;
400 },
401
402 run => sub {
403 my $ic = shift;
404 my $cb = shift;
405 if (defined($cb)) {
406 while ($ic-- > 0) {
407 $cb->($pc, $mem[$pc], $a, $x, $y, $s, $p);
408 $decode[$mem[$pc++]]->();
409 }
410 } else {
411 while ($ic-- > 0) {
412 $decode[$mem[$pc++]]->();
413 }
414 }
415 },
416
417 load_rom => sub {
418 my ($f, $a) = @_;
419 open my $fh, '<', $f or croak "Can't read $f ($!)\n";
420 binmode $fh;
421 my $sz = -s $fh;
422 sysread $fh, my $buf, $sz
423 or croak "Error reading $f ($!)\n";
424 $self->write_chunk($a, $buf);
425 },
426
427 poke_code => sub {
428 my $addr = shift;
429 $mem[$addr++] = $_ for @_;
430 },
431
432 make_vector => sub {
433 my ($call, $vec, $func) = @_;
434 $mem[$call + 0] = 0x6C; # JMP (indirect)
435 $mem[$call + 1] = $vec & 0xFF;
436 $mem[$call + 2] = ($vec >> 8) & 0xFF;
437
438 my $addr = $jumptab;
439 $mem[$jumptab++] = ESCAPE_OP;
440 $mem[$jumptab++] = ESCAPE_SIG;
441 $mem[$jumptab++] = $func;
442 $mem[$jumptab++] = 0x60;
443
444 $mem[$vec + 0] = $addr & 0xFF;
445 $mem[$vec + 1] = ($addr >> 8) & 0xFF;
446 },
447
448 get_state => sub {
449 return ($a, $x, $y, $s, $p, $pc);
450 },
451
452 get_xy => sub {
453 return $x || ($y << 8);
454 },
455
456 set_xy => sub {
457 my $v = shift;
458 $x = $v & 0xFF;
459 $y = ($v >> 8) & 0xFF;
460 },
461
462 decode_flags => sub {
463 my $f = shift;
464 my $b = 0x80;
465 my $n = FLAGS;
466 my $desc = '';
467 while ($n) {
468 $desc .= ($f & $b) ? substr($n, 0, 1) : '-';
469 $n = substr($n, 1);
470 $b >>= 1;
471 }
472 return $desc;
473 }
474 };
475
476 # Generate register accessors.
477 for my $reg (qw(a x y s p pc)) {
478 $cpu{$id}->{"get_$reg"} = eval "sub { return \$$reg; }";
479 $cpu{$id}->{"set_$reg"} = eval "sub { \$$reg = \$_[0]; }";
480 }
481 }
482
483 sub AUTOMETHOD {
484 my ($self, $id, @args) = @_;
485 my $methname = $_;
486
487 if (exists($cpu{$id}->{$methname})) {
488 return sub {
489 return $cpu{$id}->{$methname}->(@args);
490 }
491 }
492
493 return;
494 }
495
496 sub call_os {
497 my $self = shift;
498 my $id = ident($self);
499 croak "call_os() not supported";
500 }
501
502 # Functions that generate code fragments
503 sub _push {
504 my $r = '';
505 for (@_) {
506 $r .=
507 '$mem[STACK + $s] = (' . $_
508 . ') & 0xFF; $s = ($s - 1) & 0xFF;' . "\n";
509 }
510 return $r;
511 }
512
513 sub _pop {
514 my $r = '';
515 for (@_) {
516 $r .=
517 '$s = ($s + 1) & 0xFF; ' . $_
518 . ' = $mem[STACK + $s];' . "\n";
519 }
520 return $r;
521 }
522
523 sub _pop_p {
524 return '$s = ($s + 1) & 0xFF; $p = $mem[STACK + $s] | R | B;'
525 . "\n";
526 }
527
528 # Addressing modes return a list containing setup code, lvalue
529 sub _zpix {
530 return (
531 'my $ea = $mem[$pc++] + $x; '
532 . '$ea = $mem[$ea & 0xFF] | ($mem[($ea + 1) & 0xFF] << 8)'
533 . ";\n",
534 '$mem[$ea]'
535 );
536 }
537
538 sub _zpi {
539 return (
540 'my $ea = $mem[$pc++]; '
541 . '$ea = $mem[$ea & 0xFF] | ($mem[($ea + 1) & 0xFF] << 8)'
542 . ";\n",
543 '$mem[$ea]'
544 );
545 }
546
547 sub _zpiy {
548 return (
549 'my $ea = $mem[$pc++]; '
550 . '$ea = ($mem[$ea & 0xFF] | ($mem[($ea + 1) & 0xFF] << 8)) + $y'
551 . ";\n",
552 '$mem[$ea]'
553 );
554 }
555
556 sub _zp {
557 return ('my $ea = $mem[$pc++];' . "\n", '$mem[$ea]');
558 }
559
560 sub _zpx {
561 return ('my $ea = ($mem[$pc++] + $x) & 0xFF;' . "\n", '$mem[$ea]');
562 }
563
564 sub _zpy {
565 return ('my $ea = ($mem[$pc++] + $y) & 0xFF;' . "\n", '$mem[$ea]');
566 }
567
568 sub _abs {
569 return ('my $ea = $mem[$pc] | ($mem[$pc+1] << 8); $pc += 2;' . "\n",
570 '$mem[$ea]');
571 }
572
573 sub _absx {
574 return (
575 'my $ea = ($mem[$pc] | ($mem[$pc+1] << 8)) + $x; $pc += 2;'
576 . "\n",
577 '$mem[$ea]'
578 );
579 }
580
581 sub _absy {
582 return (
583 'my $ea = ($mem[$pc] | ($mem[$pc+1] << 8)) + $y; $pc += 2;'
584 . "\n",
585 '$mem[$ea]'
586 );
587 }
588
589 sub _imm {
590 return ('my $v = $mem[$pc++];' . "\n", '$v');
591 }
592
593 sub _acc {
594 return ('', '$a');
595 }
596
597 sub _rel {
598 # Doesn't return an lvalue
599 return ('my $t = $mem[$pc++];' . "\n",
600 '($pc + $t - (($t & 0x80) ? 0x100 : 0))');
601 }
602
603 sub _status {
604 my $reg = shift || '$a';
605 return '$p = ($p & ~(N | Z) | $zn[' . $reg . ']);' . "\n";
606 }
607
608 sub _ora {
609 return $_[0] . '$a |= ' . $_[1] . ";\n" . _status();
610 }
611
612 sub _and {
613 return $_[0] . '$a &= ' . $_[1] . ";\n" . _status();
614 }
615
616 sub _eor {
617 return $_[0] . '$a ^= ' . $_[1] . ";\n" . _status();
618 }
619
620 sub _bit {
621 return $_[0]
622 . '$p = ($p & ~(N|V)) | ('
623 . $_[1]
624 . ' & (N|V));' . "\n"
625 . 'if (($a & '
626 . $_[1]
627 . ') == 0) { $p |= Z; } else { $p &= ~Z; }' . "\n";
628 }
629
630 sub _asl {
631 return $_[0]
632 . 'my $w = ('
633 . $_[1]
634 . ') << 1; ' . "\n"
635 . 'if ($w & 0x100) { $p |= C; $w &= ~0x100; } else { $p &= ~C; }'
636 . "\n"
637 . _status('$w')
638 . $_[1]
639 . ' = $w;' . "\n";
640 }
641
642 sub _lsr {
643 return $_[0]
644 . 'my $w = '
645 . $_[1] . ";\n"
646 . 'if (($w & 1) != 0) { $p |= C; } else { $p &= ~C; }' . "\n"
647 . '$w >>= 1;' . "\n"
648 . _status('$w')
649 . $_[1]
650 . ' = $w;' . "\n";
651 }
652
653 sub _rol {
654 return $_[0]
655 . 'my $w = ('
656 . $_[1]
657 . ' << 1) | ($p & C);' . "\n"
658 . 'if ($w >= 0x100) { $p |= C; $w -= 0x100; } else { $p &= ~C; };'
659 . "\n"
660 . _status('$w')
661 . $_[1]
662 . ' = $w;' . "\n";
663 }
664
665 sub _ror {
666 return $_[0]
667 . 'my $w = '
668 . $_[1]
669 . ' | (($p & C) << 8);' . "\n"
670 . 'if (($w & 1) != 0) { $p |= C; } else { $p &= ~C; }' . "\n"
671 . '$w >>= 1;' . "\n"
672 . _status('$w')
673 . $_[1]
674 . ' = $w;' . "\n";
675 }
676
677 sub _sto {
678 return $_[0] . "$_[1] = $_[2];\n";
679 }
680
681 sub _lod {
682 return $_[0] . "$_[2] = $_[1];\n" . _status($_[2]);
683 }
684
685 sub _cmp {
686 return $_[0]
687 . 'my $w = '
688 . $_[2] . ' - '
689 . $_[1] . ";\n"
690 . 'if ($w < 0) { $w += 0x100; $p &= ~C; } else { $p |= C; }'
691 . "\n"
692 . _status('$w');
693 }
694
695 sub _tsb {
696 return 'croak "TSB not supported\n";' . "\n";
697 }
698
699 sub _trb {
700 return 'croak "TRB not supported\n";' . "\n";
701 }
702
703 sub _inc {
704 return $_[0]
705 . $_[1] . ' = ('
706 . $_[1]
707 . ' + 1) & 0xFF;' . "\n"
708 . _status($_[1]);
709 }
710
711 sub _dec {
712 return $_[0]
713 . $_[1] . ' = ('
714 . $_[1]
715 . ' + 0xFF) & 0xFF;' . "\n"
716 . _status($_[1]);
717 }
718
719 sub _adc {
720 return $_[0]
721 . 'my $w = '
722 . $_[1] . ";\n"
723 . 'if ($p & D) {' . "\n"
724 . 'my $lo = ($a & 0x0F) + ($w & 0x0F) + ($p & C);' . "\n"
725 . 'if ($lo > 9) { $lo += 6; }' . "\n"
726 . 'my $hi = ($a >> 4) + ( $w >> 4) + ($lo > 15 ? 1 : 0);' . "\n"
727 . '$a = ($lo & 0x0F) | ($hi << 4);' . "\n"
728 . '$p = ($p & ~C) | ($hi > 15 ? C : 0);' . "\n"
729 . '} else {' . "\n"
730 . 'my $lo = $a + $w + ($p & C);' . "\n"
731 . '$p &= ~(N | V | Z | C);' . "\n"
732 . '$p |= (~($a ^ $w) & ($a ^ $lo) & 0x80 ? V : 0) | ($lo & 0x100 ? C : 0);'
733 . "\n"
734 . '$a = $lo & 0xFF;' . "\n"
735 . _status() . '}' . "\n";
736 }
737
738 sub _sbc {
739 return $_[0]
740 . 'my $w = '
741 . $_[1] . ";\n"
742 . 'if ($p & D) {' . "\n"
743 . 'my $lo = ($a & 0x0F) - ($w & 0x0F) - (~$p & C);' . "\n"
744 . 'if ($lo & 0x10) { $lo -= 6; }' . "\n"
745 . 'my $hi = ($a >> 4) - ($w >> 4) - (($lo & 0x10) >> 4);' . "\n"
746 . 'if ($hi & 0x10) { $hi -= 6; }' . "\n"
747 . '$a = ($lo & 0x0F) | ($hi << 4);' . "\n"
748 . '$p = ($p & ~C) | ($hi > 15 ? 0 : C);' . "\n"
749 . '} else {' . "\n"
750 . 'my $lo = $a - $w - (~$p & C);' . "\n"
751 . '$p &= ~(N | V | Z | C);' . "\n"
752 . '$p |= (($a ^ $w) & ($a ^ $lo) & 0x80 ? V : 0) | ($lo & 0x100 ? 0 : C);'
753 . "\n"
754 . '$a = $lo & 0xFF;' . "\n"
755 . _status() . '}' . "\n";
756 }
757
758 sub _bra {
759 return $_[0] . '$pc = ' . $_[1] . ";\n";
760 }
761
762 sub _bfz {
763 return $_[0]
764 . 'if (($p & '
765 . $_[2]
766 . ') == 0) { $pc = '
767 . $_[1] . '; }' . "\n";
768 }
769
770 sub _bfnz {
771 return $_[0]
772 . 'if (($p & '
773 . $_[2]
774 . ') != 0) { $pc = '
775 . $_[1] . '; }' . "\n";
776 }
777
778 sub _jmp_i {
779 my $a = shift;
780 return '$pc = $mem[' . $a
781 . '] | ($mem['
782 . $a
783 . ' + 1] << 8);' . "\n";
784 }
785
786 sub _jmp {
787 return _jmp_i('$pc');
788 }
789
790 sub _jmpi {
791 return 'my $w = $mem[$pc] | ($mem[$pc + 1] << 8); ' . _jmp_i('$w');
792 }
793
794 sub _jmpix {
795 return 'my $w = ($mem[$pc] | ($mem[$pc + 1] << 8)) + $x; '
796 . _jmp_i('$w');
797 }
798
799 sub _rts {
800 return 'my ($lo, $hi); '
801 . _pop('$lo')
802 . _pop('$hi')
803 . '$pc = ($lo | ($hi << 8)) + 1;' . "\n";
804 }
805
806 1;
807 __END__
808
809 =head1 NAME
810
811 Acme::6502 - Pure Perl 65C02 simulator.
812
813 =head1 VERSION
814
815 This document describes Acme::6502 version 0.0.6
816
817 =head1 SYNOPSIS
818
819 use Acme::6502;
820
821 my $cpu = Acme::6502->new();
822
823 # Set start address
824 $cpu->set_pc(0x8000);
825
826 # Load ROM image
827 $cpu->load_rom('myrom.rom', 0x8000);
828
829 # Run for 1,000,000 instructions then return
830 $cpu->run(1_000_000);
831
832 =head1 DESCRIPTION
833
834 Imagine the nightmare scenario: your boss tells you about a legacy
835 system you have to support. How bad could it be? COBOL? Fortran? Worse:
836 it's an embedded 6502 system run by a family of squirrels (see Dilberts
837 passim). Fortunately there's a pure Perl 6502 emulator that works so
838 well the squirrels will never know the difference.
839
840 =head1 INTERFACE
841
842 =over
843
844 =item C<call_os( $vec_number )>
845
846 Subclass to provide OS entry points. OS vectors are installed by calling
847 C<make_vector>. When the vector is called C<call_os()> will be called
848 with the vector number.
849
850 =item C<get_a()>
851
852 Read the current value of the processor A register (accumulator).
853
854 =item C<get_p()>
855
856 Read the current value of the processor status register.
857
858 =item C<get_pc()>
859
860 Read the current value of the program counter.
861
862 =item C<get_s()>
863
864 Read the current value of the stack pointer.
865
866 =item C<get_x()>
867
868 Read the current value of the processor X index register.
869
870 =item C<get_y()>
871
872 Read the current value of the processor X index register.
873
874 =item C<get_xy()>
875
876 Read the value of X and Y as a sixteen bit number. X forms the lower 8
877 bits of the value and Y forms the upper 8 bits.
878
879 =item C<get_state()>
880
881 Returns an array containing the values of the A, X, Y, S, P and SP.
882
883 =item C<set_a( $value )>
884
885 Set the value of the processor A register (accumulator).
886
887 =item C<set_p( $value )>
888
889 Set the value of the processor status register.
890
891 =item C<set_pc( $value )>
892
893 Set the value of the program counter.
894
895 =item C<set_s( $value )>
896
897 Set the value of the stack pointer.
898
899 =item C<set_x( $value )>
900
901 Set the value of the X index register.
902
903 =item C<set_y( $value )>
904
905 Set the value of the Y index register.
906
907 =item C<set_xy( $value )>
908
909 Set the value of the X and Y registers to the specified sixteen bit
910 number. X gets the lower 8 bits, Y gets the upper 8 bits.
911
912 =item C<set_jumptab( $addr )>
913
914 Set the address of the block of memory that will be used to hold the
915 thunk blocks that correspond with vectored OS entry points. Each thunk
916 takes four bytes.
917
918 =item C<load_rom( $filename, $addr )>
919
920 Load a ROM image at the specified address.
921
922 =item C<make_vector( $jmp_addr, $vec_addr, $vec_number )>
923
924 Make a vectored entry point for an emulated OS. C<$jmp_addr> is the
925 address where an indirect JMP instruction (6C) will be placed,
926 C<$vec_addr> is the address of the vector and C<$vec_number> will be
927 passed to C<call_os> when the OS call is made.
928
929 =item C<poke_code( $addr, @bytes )>
930
931 Poke code directly at the specified address.
932
933 =item C<read_8( $addr )>
934
935 Read a byte at the specified address.
936
937 =item C<read_16( $addr )>
938
939 Read a sixteen bit (low, high) word at the specified address.
940
941 =item C<read_32( $addr )>
942
943 Read a 32 bit word at the specified address.
944
945 =item C<read_chunk( $start, $end )>
946
947 Read a chunk of data from C<$start> to C<$end> - 1 into a string.
948
949 =item C<read_str( $addr )>
950
951 Read a carriage return terminated (0x0D) string from the
952 specified address.
953
954 =item C<run( $count [, $callback ] )>
955
956 Execute the specified number of instructions and return. Optionally a
957 callback may be provided in which case it will be called before each
958 instruction is executed:
959
960 my $cb = sub {
961 my ($pc, $inst, $a, $x, $y, $s, $p) = @_;
962 # Maybe output trace info
963 }
964
965 $cpu->run(100, $cb);
966
967 =item C<write_8( $addr, $value )>
968
969 Write the byte at the specified address.
970
971 =item C<write_16( $addr, $value )>
972
973 Write a sixteen bit (low, high) value at the specified address.
974
975 =item C<write_32( $addr, $value )>
976
977 Write a 32 bit value at the specified address.
978
979 =item C<write_chunk( $addr, $string )>
980
981 Write a chunk of data to memory.
982
983 =back
984
985 =head1 DIAGNOSTICS
986
987 =over
988
989 =item C<< Bad instruction at %s (%s) >>
990
991 The emulator hit an illegal 6502 instruction.
992
993 =back
994
995 =head1 CONFIGURATION AND ENVIRONMENT
996
997 Acme::6502 requires no configuration files or environment variables.
998
999 =head1 DEPENDENCIES
1000
1001 C<Acme::6502> needs C<Class::Std>.
1002
1003 =head1 INCOMPATIBILITIES
1004
1005 None reported.
1006
1007 =head1 BUGS AND LIMITATIONS
1008
1009 Doesn't have support for hardware emulation hooks - so memory mapped I/O
1010 is out of the question until someone fixes it.
1011
1012 Please report any bugs or feature requests to
1013 C<bug-acme-6502@rt.cpan.org>, or through the web interface at
1014 L<http://rt.cpan.org>.
1015
1016 =head1 AUTHOR
1017
1018 Andy Armstrong C<< <andy@hexten.net> >>
1019
1020 =head1 LICENCE AND COPYRIGHT
1021
1022 Copyright (c) 2006, Andy Armstrong C<< <andy@hexten.net> >>. All rights reserved.
1023
1024 This module is free software; you can redistribute it and/or
1025 modify it under the same terms as Perl itself. See L<perlartistic>.
1026
1027 =head1 DISCLAIMER OF WARRANTY
1028
1029 BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
1030 FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
1031 OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
1032 PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
1033 EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
1034 WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
1035 ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH
1036 YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
1037 NECESSARY SERVICING, REPAIR, OR CORRECTION.
1038
1039 IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
1040 WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
1041 REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE
1042 LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL,
1043 OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE
1044 THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
1045 RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
1046 FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
1047 SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
1048 SUCH DAMAGES.

  ViewVC Help
Powered by ViewVC 1.1.26