DASM
DASMIO/Hardware.pm
Go to the documentation of this file.
00001 #!/usr/bin/perl -w
00002 ##
00003 # DCPU-16 execution environment - hardware profile initialisation
00004 #
00005 # This module provides the initialisation of the hardware mapped devices
00006 # in the core of the DCPU-16 emulation. The mappings are defined in a
00007 # hardware profile which describes the base address of the devices.
00008 #
00009 # Each device is implemented by a device module in the directory DExecHW.
00010 # An instance of the devices is created and attached to the addresses
00011 # through a DExecHWAdapter. The adapter supplies the offset parameter to
00012 # the device object, allowing multiple registers to be easily implemented
00013 # in the device, despite not being known to the execution environment.
00014 #
00015 # The hardware profiles take the form of lines in a file of the form:
00016 #
00017 # @code
00018 #   <address> <device> [ '(' <arguments> ')' ]
00019 # @endcode
00020 #
00021 # @li @c <address>   : a 4 character hexadecimal address that the hardware is
00022 #                      mapped to
00023 # @li @c <device>    : device, as a module in the DExecHW directory.
00024 # @li @c <arguments> : comma separated arguments to pass to the device
00025 #
00026 # Comments are prefixed by a '#' character.
00027 #
00028 # Devices may be registered in multiple locations with different arguments.
00029 #
00030 # Each device has a window size, which it defines. This is the number of
00031 # registers it provides and which will be allocated in the core.
00032 #
00033 # @file
00034 # @author Justin Fletcher
00035 #
00036 
00037 package DASMIO::Hardware;
00038 
00039 use DASM;
00040 use DCPU;
00041 
00042 use DExecHWAdapter;
00043 
00044 use Carp;
00045 
00046 ## Whether we debug the registrations
00047 my $debug_reg = 0;
00048 
00049 
00050 ##
00051 # Create an object upon which we can work.
00052 #
00053 # @param[in] $proto  Prototype object, or this class's name
00054 # @param[in] $dasm   DASM object we're working on
00055 #
00056 # @return new object
00057 sub new
00058 {
00059     my $proto = shift;
00060     my $dasm  = shift;
00061     my $class = ref($proto) || $proto;
00062     my $self  = {};
00063 
00064     bless $self, $class;
00065     
00066     $self->{'dasm'} = $dasm;
00067     
00068     # Prefix on all hardware symbols
00069     $self->{'symbolprefix'} = "";
00070     
00071     # Separator for symbols
00072     $self->{'symbolseparator'} = "_";
00073 
00074     # Base symbol name
00075     $self->{'symbolbase'} = "_Base";
00076     
00077     return $self;
00078 }
00079 
00080 
00081 
00082 ##
00083 # Register a region of memory with a device.
00084 #
00085 # @param[in] $self      This hardware object
00086 # @param[in] $address   The address to assign the device at
00087 # @param[in] $device    The device name
00088 # @param[in] $args      arrayref of arguments for the device
00089 sub register
00090 {
00091     my ($self, $address, $device, $args) = @_;
00092     my $dasm = $self->{'dasm'};
00093     
00094     if (!defined $device || $device eq '')
00095     {
00096         confess "No device supplied to Hardware::register";
00097     }
00098     
00099     # Load the device class
00100     eval {
00101         require "DExecHW/$device.pm";
00102     };
00103     if ($@)
00104     {
00105         $dasm->error( sprintf "Cannot attach device '%s' at %04x: %s",
00106                               $device,
00107                               $address,
00108                               $@);
00109     }
00110 
00111     # Create the object for the hardware device, with the
00112     # arguments supplied
00113     my $object = "DExecHW::$device"->new( @$args );
00114     
00115     # Create the initial symbol name
00116     my $symbol = $self->{'symbolprefix'} . $device;
00117     $symbol =~ s/::/$symbolseparator/g;
00118 
00119     # Set the base symbol to the address
00120     # FIXME: This does not cope with multiple instances of a device
00121     $dasm->setsymbol($symbol . $self->{'symbolbase'}, $address, 'constant');
00122 
00123     # Create one adapter for each offset of the window of this device
00124     my $window = $object->window();
00125     for my $offset (0..$window-1)
00126     {
00127         my $regaddress = $address + $offset;
00128         
00129         # FIXME: Replace with a method
00130         if (defined $dasm->{'core'}->{$regaddress})
00131         {
00132             die "Overlapping data/devices at ".sprintf("%04x",$regaddress);
00133         }
00134         
00135         my $obj = new DExecHWAdapter( $object, $offset);
00136         $dasm->store($regaddress, $obj);
00137         
00138         # Create a symbol for this address.
00139         my $symname = $obj->symbol();
00140         if (defined $symname)
00141         {
00142             $dasm->setsymbol($symbol . $self->{'symbolseparator'} . $symname,
00143                              $regaddress,
00144                              'constant');
00145         }
00146     }
00147 
00148     # Register the hardware so that we know about it.
00149     $dasm->addhardware($address, $object);
00150 }
00151 
00152 
00153 ##
00154 # Identify whether we can handle reading or writing a given file
00155 # by its filename.
00156 #
00157 # @param[in]  $self     Our object
00158 # @param[in]  $filename Filename we're accessing
00159 # @param[in]  $type     'read' or 'write'
00160 #
00161 # @retval 1 if we can access it
00162 # @retval 0 if we cannot access it
00163 sub identify
00164 {
00165     my ($self, $filename, $type) = @_;
00166     
00167     # We can only read the hardware definitions, not write them
00168     if ($filename =~ /\.hw$/ && $type eq 'read')
00169     {
00170         return 1;
00171     }
00172     
00173     return 0;
00174 }
00175 
00176 
00177 ##
00178 # List the extensions we support
00179 #
00180 # @param[in]  $self     Our object
00181 #
00182 # @return arrayref of extensions
00183 sub extensions
00184 {
00185     return [ 'hw' ];
00186 }
00187 
00188 
00189 ##
00190 # Parse an instruction line.
00191 #
00192 # @param[in] $self    IO object
00193 # @param[in] $line    Line to process
00194 sub parseline
00195 {
00196     my ($self, $line) = @_;
00197     my $dasm = $self->{'dasm'};
00198 
00199     # Trim any trailing newline that might have been left
00200     chomp $line;
00201 
00202     if ($line =~ /^\s*#/ ||
00203         $line =~ /^\s*$/)
00204     {
00205         # Skip comments and blank lines
00206         return;
00207     }
00208 
00209     # Parse the address and device from:
00210     #   <hex address> <device name> ...
00211     my ($address, $device, $_) = ($line =~ /^(?:0x)?([A-Fa-f0-9]+)\s*([\w:]+)\s*(.*$)/);
00212     if (!defined $address ||
00213         !defined $device)
00214     {
00215         $self->error("Unrecognised line '$_' in hardware profile");
00216     }
00217 
00218     # Convert the address to a number
00219     $address = hex($address);
00220 
00221     if ($address >= 0x10000)
00222     {
00223         $self->error(sprintf "Address 0x%x too large", $address);
00224     }
00225 
00226     # The device name can be followed by a list of arguments in brackets,
00227     # which we parse into an array.
00228     my $args = [];
00229     if ($line =~ s/^\(\s*//)
00230     {
00231         while (1)
00232         {
00233             $line =~ s/\s*//; # Strip leading spaces
00234             if ($line =~ s/^(\d+)//)
00235             {
00236                 # Basic number
00237                 push @$args, $1;
00238             }
00239             elsif ($line =~ s/^0x([A-Fa-f0-9]+)//)
00240             {
00241                 # Hex number
00242                 push @$args, hex($1);
00243             }
00244             elsif ($line =~ s/^"([^"]+)"// ||
00245                    $line =~ s/^'([^']+)'//)
00246             {
00247                 # "d string (double or single)
00248                 push @$args, $1;
00249             }
00250             else
00251             {
00252                 $self->error("Unrecognised argument to $device device: '$line'");
00253             }
00254 
00255             if ($line =~ s/\s*,\s*//)
00256             {
00257                 # There's more arguments coming, so go around for
00258                 # more
00259             }
00260             elsif ($line =~ s/\s*\)//)
00261             {
00262                 # That's the end of the arguments, so we can stop
00263                 last;
00264             }
00265             elsif ($line =~ /\s*$/)
00266             {
00267                 # End of the arguments list... odd
00268                 $self->error("Unexpected end of arguments");
00269             }
00270             else
00271             {
00272                 $self->error("Garbage after arguments '$line'");
00273             }
00274         }
00275     }
00276 
00277     # Having parsed the arguments, the rest of the line should be
00278     # empty (or a comment)
00279     if (!$line =~ /\s*$/ &&
00280         !$line =~ /\s*#/)
00281     {
00282         $self->error("Garbage at end of device $device: $1");
00283     }
00284 
00285     printf "Registering at 0x%04x: %s\n", $address, $device if ($debug_reg);
00286     $self->register($address, $device, $args);
00287 }
00288 
00289 # Must return true.
00290 1;