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<wizzard> 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";
}

=head2 jump

Start execution from some location (modify PC)

=cut

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


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

        open(my $fh, '>', $path) || die "can't open $path: $!";
        print $fh $self->read_chunk( $from, $to );
        close($fh);

        my $size = -s $path;
        warn sprintf "saved %s %d %x bytes\n", $path, $size, $size;
}

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

=head1 Memory management

VRac implements all I/O using mmap addresses. This was main reason why
L<Acme::6502> was just too slow to handle it.

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