viewvc.cgi/VRac/VRac.pm

package VRac;

use warnings;
use strict;

use Carp qw/confess croak cluck carp/;
use File::Slurp;
use Data::Dump qw/dump/;

use base qw(Class::Accessor);
__PACKAGE__->mk_accessors(qw(booted));

=head1 NAME

VRac - Virtualno Računalo

=head1 VERSION

Version 0.00

=cut

our $VERSION = '0.00';

=head1 DESCRIPTION

Emulator of 8-bit architectures based on L<M6502> or L<Z80> emulation.

This project is homage to 8-bit computers in Croatia and former Yugoslavia
from 1980-1990. Word B<vrac> means also I<wizard> in Croatian.

This project should enable anyone with limited knowledge of perl and 8-bit
arhitecture of some machine to write emulator in an afternoon. To achieve this,
code is written is as cleanly as possible.

Porting existing emulators should be especially easy: you need passive
understaning of language in which emulator is written and you can be on your
way C<:-)>

=cut

=head1 FUNCTIONS

=head2 run

Start emulator, open L<Screen>, load initial ROM images, and start emulator loop

  my $emu = Orao->new();
  $emu->run;

=cut

our $emu;

sub run {
        my $self = shift;
        confess "please implement $self::run\n";
}


=head1 Memory management

VRac implements callback for all I/O operations. This was main reason why
L<Acme::6502> module with tied memory was too slow to emulate L<Orao>, so I
had to write C binding for L<M6502>.

B<This functions will die with stack trace when called>. They should be
implemented for each architecture.

=cut

=head2 read

Read from memory

  $byte = read( $address );

=cut

sub read {
        my $self = shift;
        confess "please implement $self::read()";
}

=head2 write

Write into emory

  write( $address, $byte );

=cut

sub write {
        my $self = shift;
        confess "please implement $self::write()";
}

=head1 Helper functions

=head2 load_rom

called to init memory and load initial rom images

  $emu->load_rom;

=cut

sub load_rom {
    my ($self, $loaded_files) = @_;

    #my $time_base = time();

        foreach my $addr ( sort keys %$loaded_files ) {
                my $path = $loaded_files->{$addr};
                $self->load_image( $path, $addr );
        }
}

=head2 load_image

Load binary files, ROM images and VRac Emulator files

  $emu->load_image( '/path/to/file', 0x1000 );

Returns true on success.

=cut

sub load_image {
        my $self = shift;
        my ( $path, $addr ) = @_;

        croak "ERROR: file $path doesn't exist\n" if ( ! -e $path );

        my $size = -s $path || confess "no size for $path: $!";

        my $buff = read_file( $path );

        printf "loading %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
        $self->write_chunk( $addr, $buff );
        return 1;
};

=head2 save_dump

  $emu->save_dump( 'filename', $from, $to );

=cut

sub save_dump {
        my $self = shift;

        my ( $path, $from, $to ) = @_;

        $from ||= 0;
        $to ||= 0xffff;

        if ( open(my $fh, '>', $path) ) {
                print $fh $self->read_chunk( $from, $to );
                close($fh);

                my $size = -s $path;
                print sprintf "saved %s %04x-%04x %d %x bytes\n", $path, $from, $to, $size, $size;
        } else {
                warn "can't create $path: $!";
        }

}

=head2 hexdump

  $emu->hexdump( $address );

=cut

sub hexdump {
        my $self = shift;
        my $a = shift;
        return sprintf(" %04x %s\n", $a,
                join(" ",
                        map {
                                my $b = $self->read( $a + $_ );
                                if ( defined($b) ) {
                                        sprintf( "%02x", $b )
                                } else {
                                        '  '
                                }
                        } 0 .. 7
                )
        );
}

=head2 append_to_file

  $self->append_to_file( '/path/to/file', $byte, $byte ... );

=cut

sub append_to_file {
        my $self = shift;
        my $path = shift || confess "no path?";
        my $bytes = join('', @_);

        my $size = -s $path || 0;
        my $len = length($bytes);

        open(my $fh, '>>', $path) || confess "can't open $path: $!";
        print($fh $bytes);
        my $pos = tell($fh);

        my $expected = $size + $len;
        if ( $pos != $expected ) {
                #cluck "BUG: file grows too big got $pos, expected $expected !";
                truncate $fh, $expected;
        }

        close($fh);

        warn sprintf("## append_to_file('%s',%s)\n", $path, dump($bytes));
}

=head1 Command Line

Command-line debugging intrerface is implemented for communication with
emulated device

=head2 prompt

  my ( $entered_line, @p ) = $emu->prompt( $address, $last_command );

=cut

my $last = 'r 1';

sub prompt {
        my $self = shift;
        $self->app->sync;
        my $a = shift;
        print $self->hexdump( $a ),
                $last ? "[$last] " : '',
                "> ";
        my $in = <STDIN>;
        chomp($in);
        warn "## prompt got: $in\n" if $self->debug;
        $in ||= $last;
        $last = $in;
        return ( $in, split(/\s+/, $in) ) if $in;
}

=head2 cli

  my $run_for = $emu->cli;

=cut

my $show_R = 0;

sub cli {
        my $self = shift;
        my $a = $self->cpu_PC() || confess "can't find PC";
        my $run_for = 0;
        print $self->dump_R() if $show_R;
        while ( my ($line, @v) = $self->prompt( $a, $last ) ) {
                my $c = shift @v;
                next unless defined($c);
                my $v = shift @v;
                $v = hex($v) if $v && $v =~ m/^[0-9a-f]+$/;
                @v = map { hex($_) } @v;
                printf "## a: %04x parsed cli: c:%s v:%s %s\n", $a, $c, ($v || 'undef'), join(",",@v) if $self->debug;
                if ( $c =~ m/^[qx]/i ) {
                        exit;
                } elsif ( $c eq '?' ) {
                        my $t = $self->trace ? 'on' : 'off' ;
                        my $d = $self->debug ? 'on' : 'off' ;
                        print <<__USAGE__;
Usage:

x|q\t\texit
e 6000 6010\tdump memory, +/- to walk forward/backward
m 1000 ff 00\tput ff 00 on 1000
j|u 1000\t\tjump (change pc)
r 42\t\trun 42 instruction opcodes
t\t\ttrace [$t]
d\t\tdebug [$d]
tape name 168\tload tape and start at offset

__USAGE__
                        print $self->tape_status if $self->can('tape_status');
                        print $self->dump_R;
                        $last = '';
                } elsif ( $c =~ m/^e/i ) {
                        $a = $v if defined($v);
                        my $to = shift @v;
                        $to = $a + 32 if ( ! $to || $to <= $a );
                        $to = 0xffff if ( $to > 0xffff );
                        my $lines = int( ($to - $a + 8) / 8 );
                        printf "## e %04x %04x (%d bytes) lines: %d\n", $a, $to, ($to-$a), $lines;
                        while ( --$lines ) {
                                print $self->hexdump( $a );
                                $a += 8;
                        }
                        $last = '+';
                        $show_R = 0;
                } elsif ( $c =~ m/^\+/ ) {
                        $a += 8;
                        $show_R = 0;
                } elsif ( $c =~ m/^\-/ ) {
                        $a -= 8;
                        $show_R = 0;
                } elsif ( $c =~ m/^m/i ) {
                        $a = $v if defined($v);
                        $self->poke_code( $a, @v );
                        printf "poke %d bytes at %04x\n", $#v + 1, $a;
                        $last = '+';
                        $show_R = 0;
                } elsif ( $c =~ m/^l/i ) {
                        my $to = shift @v || 0x1000;
                        $a = $to;
                        $self->load_image( $v, $a );
                        $last = '';
                } elsif ( $c =~ m/^s/i ) {
                        $self->save_dump( $v || 'mem.dump', @v );
                        $last = '';
                } elsif ( $c =~ m/^re/i ) { # reset
                        M6502::reset();
                        $last = 'r 1';
                } elsif ( $c =~ m/^r/i ) {      # run
                        $run_for = $v || 1;
                        print "run_for $run_for instructions\n";
                        $show_R = 1;
                        last;
                } elsif ( $c =~ m/^(u|j)/i ) {
                        my $to = $v || $a;
                        # change PC to new address
                        $self->cpu_PC( $to );
                        $run_for = 1;
                        $last = "r $run_for";
                        $show_R = 1;
                        last;
                } elsif ( $c =~ m/^tape/ ) {
                        if ( ! $v ) {
                                warn "ERROR: please specify tape name!\n";
                        } elsif ( ! -e $v ) {
                                warn "ERROR: tape $v: $!\n";
                        } else {
                                $self->load_tape( $v, shift @v );
                        }
                        $last = '';
                } elsif ( $c =~ m/^t/i ) {
                        $self->trace( not $self->trace );
                        print "trace ", $self->trace ? 'on' : 'off', "\n";
                        $last = '';
                } elsif ( $c =~ m/^d/i ) {
                        $self->debug( not $self->debug );
                        print "debug ", $self->debug ? 'on' : 'off', "\n";
                        $last = '';
                } else {
                        warn "# ignored $line\n" if ($line);
                        $last = '';
                }
        }

        return $run_for;
}

=head1 SEE ALSO

Components: L<M6502>, L<Z80>, L<Screen>, L<Tape>, L<Session>

Emulators: L<Orao>, L<Galaksija>

L<References> about different architectures

=head1 AUTHOR

Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>

=head1 ACKNOWLEDGEMENTS

Structure and Interpretation of Computer Programs by Abelson, Sussman, and
Sussman L<http://mitpress.mit.edu/sicp/> is a great book. It gave me idea
that you should have wizard powers over your computer, even if it's 8 bit
one.

=head1 COPYRIGHT & LICENSE

Copyright 2007 Dobrica Pavlinusic, All Rights Reserved.

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

=cut

1; # End of VRac
1	dpavlin	128	package VRac;
2
3			use warnings;
4			use strict;
5
6	dpavlin	156	use Carp qw/confess croak cluck carp/;
7	dpavlin	128	use File::Slurp;
8			use Data::Dump qw/dump/;
9
10			use base qw(Class::Accessor);
11			__PACKAGE__->mk_accessors(qw(booted));
12
13			=head1 NAME
14
15	dpavlin	134	VRac - Virtualno Računalo
16	dpavlin	128
17			=head1 VERSION
18
19			Version 0.00
20
21			=cut
22
23			our $VERSION = '0.00';
24
25			=head1 DESCRIPTION
26
27			Emulator of 8-bit architectures based on L<M6502> or L<Z80> emulation.
28
29			This project is homage to 8-bit computers in Croatia and former Yugoslavia
30	dpavlin	134	from 1980-1990. Word B<vrac> means also I<wizard> in Croatian.
31	dpavlin	128
32	dpavlin	148	This project should enable anyone with limited knowledge of perl and 8-bit
33			arhitecture of some machine to write emulator in an afternoon. To achieve this,
34			code is written is as cleanly as possible.
35
36			Porting existing emulators should be especially easy: you need passive
37			understaning of language in which emulator is written and you can be on your
38			way C<:-)>
39
40	dpavlin	128	=cut
41
42			=head1 FUNCTIONS
43
44			=head2 run
45
46			Start emulator, open L<Screen>, load initial ROM images, and start emulator loop
47
48			my $emu = Orao->new();
49			$emu->run;
50
51			=cut
52
53			our $emu;
54
55			sub run {
56			my $self = shift;
57			confess "please implement $self::run\n";
58			}
59
60
61	dpavlin	145	=head1 Memory management
62
63			VRac implements callback for all I/O operations. This was main reason why
64			L<Acme::6502> module with tied memory was too slow to emulate L<Orao>, so I
65			had to write C binding for L<M6502>.
66
67			B<This functions will die with stack trace when called>. They should be
68			implemented for each architecture.
69
70			=cut
71
72			=head2 read
73
74			Read from memory
75
76			$byte = read( $address );
77
78			=cut
79
80			sub read {
81			my $self = shift;
82			confess "please implement $self::read()";
83			}
84
85			=head2 write
86
87			Write into emory
88
89			write( $address, $byte );
90
91			=cut
92
93			sub write {
94			my $self = shift;
95			confess "please implement $self::write()";
96			}
97
98	dpavlin	128	=head1 Helper functions
99
100			=head2 load_rom
101
102			called to init memory and load initial rom images
103
104			$emu->load_rom;
105
106			=cut
107
108			sub load_rom {
109			my ($self, $loaded_files) = @_;
110
111			#my $time_base = time();
112
113			foreach my $addr ( sort keys %$loaded_files ) {
114			my $path = $loaded_files->{$addr};
115			$self->load_image( $path, $addr );
116			}
117			}
118
119			=head2 load_image
120
121			Load binary files, ROM images and VRac Emulator files
122
123			$emu->load_image( '/path/to/file', 0x1000 );
124
125			Returns true on success.
126
127			=cut
128
129			sub load_image {
130			my $self = shift;
131			my ( $path, $addr ) = @_;
132
133			croak "ERROR: file $path doesn't exist\n" if ( ! -e $path );
134
135			my $size = -s $path \|\| confess "no size for $path: $!";
136
137			my $buff = read_file( $path );
138
139			printf "loading %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
140			$self->write_chunk( $addr, $buff );
141			return 1;
142			};
143
144			=head2 save_dump
145
146			$emu->save_dump( 'filename', $from, $to );
147
148			=cut
149
150			sub save_dump {
151			my $self = shift;
152
153			my ( $path, $from, $to ) = @_;
154
155			$from \|\|= 0;
156			$to \|\|= 0xffff;
157
158	dpavlin	145	if ( open(my $fh, '>', $path) ) {
159			print $fh $self->read_chunk( $from, $to );
160			close($fh);
161	dpavlin	128
162	dpavlin	145	my $size = -s $path;
163	dpavlin	169	print sprintf "saved %s %04x-%04x %d %x bytes\n", $path, $from, $to, $size, $size;
164	dpavlin	145	} else {
165			warn "can't create $path: $!";
166			}
167
168	dpavlin	128	}
169
170			=head2 hexdump
171
172			$emu->hexdump( $address );
173
174			=cut
175
176			sub hexdump {
177			my $self = shift;
178			my $a = shift;
179			return sprintf(" %04x %s\n", $a,
180			join(" ",
181			map {
182			my $b = $self->read( $a + $_ );
183			if ( defined($b) ) {
184			sprintf( "%02x", $b )
185			} else {
186			' '
187			}
188			} 0 .. 7
189			)
190			);
191			}
192
193	dpavlin	145	=head2 append_to_file
194	dpavlin	128
195	dpavlin	145	$self->append_to_file( '/path/to/file', $byte, $byte ... );
196	dpavlin	128
197			=cut
198
199	dpavlin	145	sub append_to_file {
200	dpavlin	128	my $self = shift;
201	dpavlin	145	my $path = shift \|\| confess "no path?";
202			my $bytes = join('', @_);
203	dpavlin	128
204	dpavlin	156	my $size = -s $path \|\| 0;
205			my $len = length($bytes);
206
207	dpavlin	145	open(my $fh, '>>', $path) \|\| confess "can't open $path: $!";
208	dpavlin	156	print($fh $bytes);
209			my $pos = tell($fh);
210	dpavlin	128
211	dpavlin	156	my $expected = $size + $len;
212			if ( $pos != $expected ) {
213	dpavlin	162	#cluck "BUG: file grows too big got $pos, expected $expected !";
214	dpavlin	156	truncate $fh, $expected;
215			}
216
217			close($fh);
218
219	dpavlin	145	warn sprintf("## append_to_file('%s',%s)\n", $path, dump($bytes));
220	dpavlin	128	}
221
222			=head1 Command Line
223
224			Command-line debugging intrerface is implemented for communication with
225			emulated device
226
227			=head2 prompt
228
229			my ( $entered_line, @p ) = $emu->prompt( $address, $last_command );
230
231			=cut
232
233			my $last = 'r 1';
234
235			sub prompt {
236			my $self = shift;
237			$self->app->sync;
238			my $a = shift;
239			print $self->hexdump( $a ),
240			$last ? "[$last] " : '',
241			"> ";
242			my $in = <STDIN>;
243			chomp($in);
244			warn "## prompt got: $in\n" if $self->debug;
245			$in \|\|= $last;
246			$last = $in;
247			return ( $in, split(/\s+/, $in) ) if $in;
248			}
249
250			=head2 cli
251
252			my $run_for = $emu->cli;
253
254			=cut
255
256			my $show_R = 0;
257
258			sub cli {
259			my $self = shift;
260			my $a = $self->cpu_PC() \|\| confess "can't find PC";
261			my $run_for = 0;
262	dpavlin	169	print $self->dump_R() if $show_R;
263	dpavlin	128	while ( my ($line, @v) = $self->prompt( $a, $last ) ) {
264			my $c = shift @v;
265			next unless defined($c);
266			my $v = shift @v;
267			$v = hex($v) if $v && $v =~ m/^[0-9a-f]+$/;
268			@v = map { hex($_) } @v;
269			printf "## a: %04x parsed cli: c:%s v:%s %s\n", $a, $c, ($v \|\| 'undef'), join(",",@v) if $self->debug;
270			if ( $c =~ m/^[qx]/i ) {
271			exit;
272			} elsif ( $c eq '?' ) {
273			my $t = $self->trace ? 'on' : 'off' ;
274			my $d = $self->debug ? 'on' : 'off' ;
275	dpavlin	211	print <<__USAGE__;
276	dpavlin	128	Usage:
277
278			x\|q\t\texit
279			e 6000 6010\tdump memory, +/- to walk forward/backward
280			m 1000 ff 00\tput ff 00 on 1000
281			j\|u 1000\t\tjump (change pc)
282			r 42\t\trun 42 instruction opcodes
283			t\t\ttrace [$t]
284			d\t\tdebug [$d]
285	dpavlin	211	tape name 168\tload tape and start at offset
286	dpavlin	128
287			__USAGE__
288	dpavlin	169	print $self->tape_status if $self->can('tape_status');
289			print $self->dump_R;
290	dpavlin	128	$last = '';
291			} elsif ( $c =~ m/^e/i ) {
292			$a = $v if defined($v);
293			my $to = shift @v;
294			$to = $a + 32 if ( ! $to \|\| $to <= $a );
295			$to = 0xffff if ( $to > 0xffff );
296			my $lines = int( ($to - $a + 8) / 8 );
297			printf "## e %04x %04x (%d bytes) lines: %d\n", $a, $to, ($to-$a), $lines;
298			while ( --$lines ) {
299			print $self->hexdump( $a );
300			$a += 8;
301			}
302			$last = '+';
303			$show_R = 0;
304			} elsif ( $c =~ m/^\+/ ) {
305			$a += 8;
306			$show_R = 0;
307			} elsif ( $c =~ m/^\-/ ) {
308			$a -= 8;
309			$show_R = 0;
310			} elsif ( $c =~ m/^m/i ) {
311			$a = $v if defined($v);
312			$self->poke_code( $a, @v );
313			printf "poke %d bytes at %04x\n", $#v + 1, $a;
314			$last = '+';
315			$show_R = 0;
316			} elsif ( $c =~ m/^l/i ) {
317			my $to = shift @v \|\| 0x1000;
318			$a = $to;
319			$self->load_image( $v, $a );
320			$last = '';
321			} elsif ( $c =~ m/^s/i ) {
322			$self->save_dump( $v \|\| 'mem.dump', @v );
323			$last = '';
324			} elsif ( $c =~ m/^re/i ) { # reset
325			M6502::reset();
326			$last = 'r 1';
327			} elsif ( $c =~ m/^r/i ) { # run
328			$run_for = $v \|\| 1;
329			print "run_for $run_for instructions\n";
330			$show_R = 1;
331			last;
332			} elsif ( $c =~ m/^(u\|j)/i ) {
333			my $to = $v \|\| $a;
334			# change PC to new address
335			$self->cpu_PC( $to );
336			$run_for = 1;
337			$last = "r $run_for";
338			$show_R = 1;
339			last;
340			} elsif ( $c =~ m/^tape/ ) {
341	dpavlin	169	if ( ! $v ) {
342	dpavlin	128	warn "ERROR: please specify tape name!\n";
343			} elsif ( ! -e $v ) {
344			warn "ERROR: tape $v: $!\n";
345			} else {
346	dpavlin	211	$self->load_tape( $v, shift @v );
347	dpavlin	128	}
348			$last = '';
349			} elsif ( $c =~ m/^t/i ) {
350			$self->trace( not $self->trace );
351			print "trace ", $self->trace ? 'on' : 'off', "\n";
352			$last = '';
353			} elsif ( $c =~ m/^d/i ) {
354			$self->debug( not $self->debug );
355			print "debug ", $self->debug ? 'on' : 'off', "\n";
356			$last = '';
357			} else {
358			warn "# ignored $line\n" if ($line);
359			$last = '';
360			}
361			}
362
363			return $run_for;
364			}
365
366	dpavlin	136	=head1 SEE ALSO
367
368	dpavlin	157	Components: L<M6502>, L<Z80>, L<Screen>, L<Tape>, L<Session>
369	dpavlin	136
370			Emulators: L<Orao>, L<Galaksija>
371
372	dpavlin	169	L<References> about different architectures
373
374	dpavlin	128	=head1 AUTHOR
375
376			Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
377
378			=head1 ACKNOWLEDGEMENTS
379
380	dpavlin	148	Structure and Interpretation of Computer Programs by Abelson, Sussman, and
381			Sussman L<http://mitpress.mit.edu/sicp/> is a great book. It gave me idea
382			that you should have wizard powers over your computer, even if it's 8 bit
383			one.
384
385	dpavlin	128	=head1 COPYRIGHT & LICENSE
386
387			Copyright 2007 Dobrica Pavlinusic, All Rights Reserved.
388
389			This program is free software; you can redistribute it and/or modify it
390			under the same terms as Perl itself.
391
392			=cut
393
394			1; # End of VRac