viewvc.cgi/VRac/VRac.pm

package VRac;

use warnings;
use strict;

use Carp qw/confess croak/;
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.

=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;
                warn 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('', @_);

        open(my $fh, '>>', $path) || confess "can't open $path: $!";

        print $fh $bytes;
        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;
        warn $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' ;
                        warn <<__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]

__USAGE__
                        warn $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 ( $c =~ m/rate/ ) {
                                $self->tape_rate( $v );
                                warn "will read table with rate $v\n";
                        } elsif ( ! $v ) {
                                warn "ERROR: please specify tape name!\n";
                        } elsif ( ! -e $v ) {
                                warn "ERROR: tape $v: $!\n";
                        } else {
                                $self->load_tape( $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>

Emulators: L<Orao>, L<Galaksija>

=head1 AUTHOR

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

=head1 BUGS

=head1 ACKNOWLEDGEMENTS

=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			use Carp qw/confess croak/;
7			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			=cut
33
34			=head1 FUNCTIONS
35
36			=head2 run
37
38			Start emulator, open L<Screen>, load initial ROM images, and start emulator loop
39
40			my $emu = Orao->new();
41			$emu->run;
42
43			=cut
44
45			our $emu;
46
47			sub run {
48			my $self = shift;
49			confess "please implement $self::run\n";
50			}
51
52
53	dpavlin	145	=head1 Memory management
54
55			VRac implements callback for all I/O operations. This was main reason why
56			L<Acme::6502> module with tied memory was too slow to emulate L<Orao>, so I
57			had to write C binding for L<M6502>.
58
59			B<This functions will die with stack trace when called>. They should be
60			implemented for each architecture.
61
62			=cut
63
64			=head2 read
65
66			Read from memory
67
68			$byte = read( $address );
69
70			=cut
71
72			sub read {
73			my $self = shift;
74			confess "please implement $self::read()";
75			}
76
77			=head2 write
78
79			Write into emory
80
81			write( $address, $byte );
82
83			=cut
84
85			sub write {
86			my $self = shift;
87			confess "please implement $self::write()";
88			}
89
90	dpavlin	128	=head1 Helper functions
91
92			=head2 load_rom
93
94			called to init memory and load initial rom images
95
96			$emu->load_rom;
97
98			=cut
99
100			sub load_rom {
101			my ($self, $loaded_files) = @_;
102
103			#my $time_base = time();
104
105			foreach my $addr ( sort keys %$loaded_files ) {
106			my $path = $loaded_files->{$addr};
107			$self->load_image( $path, $addr );
108			}
109			}
110
111			=head2 load_image
112
113			Load binary files, ROM images and VRac Emulator files
114
115			$emu->load_image( '/path/to/file', 0x1000 );
116
117			Returns true on success.
118
119			=cut
120
121			sub load_image {
122			my $self = shift;
123			my ( $path, $addr ) = @_;
124
125			croak "ERROR: file $path doesn't exist\n" if ( ! -e $path );
126
127			my $size = -s $path \|\| confess "no size for $path: $!";
128
129			my $buff = read_file( $path );
130
131			printf "loading %s at %04x - %04x %02x\n", $path, $addr, $addr+$size-1, $size;
132			$self->write_chunk( $addr, $buff );
133			return 1;
134			};
135
136			=head2 save_dump
137
138			$emu->save_dump( 'filename', $from, $to );
139
140			=cut
141
142			sub save_dump {
143			my $self = shift;
144
145			my ( $path, $from, $to ) = @_;
146
147			$from \|\|= 0;
148			$to \|\|= 0xffff;
149
150	dpavlin	145	if ( open(my $fh, '>', $path) ) {
151			print $fh $self->read_chunk( $from, $to );
152			close($fh);
153	dpavlin	128
154	dpavlin	145	my $size = -s $path;
155			warn sprintf "saved %s %04x-%04x %d %x bytes\n", $path, $from, $to, $size, $size;
156			} else {
157			warn "can't create $path: $!";
158			}
159
160	dpavlin	128	}
161
162			=head2 hexdump
163
164			$emu->hexdump( $address );
165
166			=cut
167
168			sub hexdump {
169			my $self = shift;
170			my $a = shift;
171			return sprintf(" %04x %s\n", $a,
172			join(" ",
173			map {
174			my $b = $self->read( $a + $_ );
175			if ( defined($b) ) {
176			sprintf( "%02x", $b )
177			} else {
178			' '
179			}
180			} 0 .. 7
181			)
182			);
183			}
184
185	dpavlin	145	=head2 append_to_file
186	dpavlin	128
187	dpavlin	145	$self->append_to_file( '/path/to/file', $byte, $byte ... );
188	dpavlin	128
189			=cut
190
191	dpavlin	145	sub append_to_file {
192	dpavlin	128	my $self = shift;
193	dpavlin	145	my $path = shift \|\| confess "no path?";
194			my $bytes = join('', @_);
195	dpavlin	128
196	dpavlin	145	open(my $fh, '>>', $path) \|\| confess "can't open $path: $!";
197	dpavlin	128
198	dpavlin	145	print $fh $bytes;
199			warn sprintf("## append_to_file('%s',%s)\n", $path, dump($bytes));
200	dpavlin	128	}
201
202			=head1 Command Line
203
204			Command-line debugging intrerface is implemented for communication with
205			emulated device
206
207			=head2 prompt
208
209			my ( $entered_line, @p ) = $emu->prompt( $address, $last_command );
210
211			=cut
212
213			my $last = 'r 1';
214
215			sub prompt {
216			my $self = shift;
217			$self->app->sync;
218			my $a = shift;
219			print $self->hexdump( $a ),
220			$last ? "[$last] " : '',
221			"> ";
222			my $in = <STDIN>;
223			chomp($in);
224			warn "## prompt got: $in\n" if $self->debug;
225			$in \|\|= $last;
226			$last = $in;
227			return ( $in, split(/\s+/, $in) ) if $in;
228			}
229
230			=head2 cli
231
232			my $run_for = $emu->cli;
233
234			=cut
235
236			my $show_R = 0;
237
238			sub cli {
239			my $self = shift;
240			my $a = $self->cpu_PC() \|\| confess "can't find PC";
241			my $run_for = 0;
242			warn $self->dump_R() if $show_R;
243			while ( my ($line, @v) = $self->prompt( $a, $last ) ) {
244			my $c = shift @v;
245			next unless defined($c);
246			my $v = shift @v;
247			$v = hex($v) if $v && $v =~ m/^[0-9a-f]+$/;
248			@v = map { hex($_) } @v;
249			printf "## a: %04x parsed cli: c:%s v:%s %s\n", $a, $c, ($v \|\| 'undef'), join(",",@v) if $self->debug;
250			if ( $c =~ m/^[qx]/i ) {
251			exit;
252			} elsif ( $c eq '?' ) {
253			my $t = $self->trace ? 'on' : 'off' ;
254			my $d = $self->debug ? 'on' : 'off' ;
255			warn <<__USAGE__;
256			Usage:
257
258			x\|q\t\texit
259			e 6000 6010\tdump memory, +/- to walk forward/backward
260			m 1000 ff 00\tput ff 00 on 1000
261			j\|u 1000\t\tjump (change pc)
262			r 42\t\trun 42 instruction opcodes
263			t\t\ttrace [$t]
264			d\t\tdebug [$d]
265
266			__USAGE__
267			warn $self->dump_R;
268			$last = '';
269			} elsif ( $c =~ m/^e/i ) {
270			$a = $v if defined($v);
271			my $to = shift @v;
272			$to = $a + 32 if ( ! $to \|\| $to <= $a );
273			$to = 0xffff if ( $to > 0xffff );
274			my $lines = int( ($to - $a + 8) / 8 );
275			printf "## e %04x %04x (%d bytes) lines: %d\n", $a, $to, ($to-$a), $lines;
276			while ( --$lines ) {
277			print $self->hexdump( $a );
278			$a += 8;
279			}
280			$last = '+';
281			$show_R = 0;
282			} elsif ( $c =~ m/^\+/ ) {
283			$a += 8;
284			$show_R = 0;
285			} elsif ( $c =~ m/^\-/ ) {
286			$a -= 8;
287			$show_R = 0;
288			} elsif ( $c =~ m/^m/i ) {
289			$a = $v if defined($v);
290			$self->poke_code( $a, @v );
291			printf "poke %d bytes at %04x\n", $#v + 1, $a;
292			$last = '+';
293			$show_R = 0;
294			} elsif ( $c =~ m/^l/i ) {
295			my $to = shift @v \|\| 0x1000;
296			$a = $to;
297			$self->load_image( $v, $a );
298			$last = '';
299			} elsif ( $c =~ m/^s/i ) {
300			$self->save_dump( $v \|\| 'mem.dump', @v );
301			$last = '';
302			} elsif ( $c =~ m/^re/i ) { # reset
303			M6502::reset();
304			$last = 'r 1';
305			} elsif ( $c =~ m/^r/i ) { # run
306			$run_for = $v \|\| 1;
307			print "run_for $run_for instructions\n";
308			$show_R = 1;
309			last;
310			} elsif ( $c =~ m/^(u\|j)/i ) {
311			my $to = $v \|\| $a;
312			# change PC to new address
313			$self->cpu_PC( $to );
314			$run_for = 1;
315			$last = "r $run_for";
316			$show_R = 1;
317			last;
318			} elsif ( $c =~ m/^tape/ ) {
319			if ( $c =~ m/rate/ ) {
320			$self->tape_rate( $v );
321			warn "will read table with rate $v\n";
322			} elsif ( ! $v ) {
323			warn "ERROR: please specify tape name!\n";
324			} elsif ( ! -e $v ) {
325			warn "ERROR: tape $v: $!\n";
326			} else {
327			$self->load_tape( $v );
328			}
329			$last = '';
330			} elsif ( $c =~ m/^t/i ) {
331			$self->trace( not $self->trace );
332			print "trace ", $self->trace ? 'on' : 'off', "\n";
333			$last = '';
334			} elsif ( $c =~ m/^d/i ) {
335			$self->debug( not $self->debug );
336			print "debug ", $self->debug ? 'on' : 'off', "\n";
337			$last = '';
338			} else {
339			warn "# ignored $line\n" if ($line);
340			$last = '';
341			}
342			}
343
344			return $run_for;
345			}
346
347	dpavlin	136	=head1 SEE ALSO
348
349			Components: L<M6502>, L<Z80>, L<Screen>, L<Tape>
350
351			Emulators: L<Orao>, L<Galaksija>
352
353	dpavlin	128	=head1 AUTHOR
354
355			Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
356
357			=head1 BUGS
358
359			=head1 ACKNOWLEDGEMENTS
360
361			=head1 COPYRIGHT & LICENSE
362
363			Copyright 2007 Dobrica Pavlinusic, All Rights Reserved.
364
365			This program is free software; you can redistribute it and/or modify it
366			under the same terms as Perl itself.
367
368			=cut
369
370			1; # End of VRac