DASM
DExec.pm
Go to the documentation of this file.
00001 #!/usr/bin/perl -w
00002 ##
00003 # Execution system for the DCPU-16 processor.
00004 #
00005 # This is a pretty simple interpreter for the core data.
00006 #
00007 # We work on the principle that all operands are references. If an operand
00008 # is read, we use the 'readref', and if the operand is written to we use
00009 # the 'writeref'. The references may be to registers, or to core memory
00010 # locations. They may also be objects which implement hardware, in which
00011 # case their 'read' or 'write' functions are called.
00012 #
00013 # Consequently some of the opcodes are implemented oddly. Where possible
00014 # we try to keep to the same semantics such that any memory accesses will
00015 # obey hardware mappings that might be present.
00016 #
00017 # Actual hardware regions will be implemented by separate objects, and
00018 # will be registered as part of hardware profiles. However, the hardware
00019 # devices registered with the core will be copied from the DASM object
00020 # if it is used to initialise the execution object. These hardware devices
00021 # may provide poll() methods in order to provide regular updates of the
00022 # devices, if necessary.
00023 #
00024 # Typical use of this class might be:
00025 # 
00026 # @code
00027 #    $dasm->readfile($infile);  # Assemble some code (or load a dump)
00028 # 
00029 #    # Resolve all the relocations
00030 #    die "Unresolved relocations" if (!$dasm->resolve($infile));
00031 #
00032 #    $dexec = new DExec($dasm);
00033 #    $dexec->start(1);
00034 #    while (1)
00035 #    {
00036 #        $dexec->runone();
00037 #    }
00038 #    $dexec->stop();
00039 # @endcode
00040 #
00041 # @file
00042 # @author Justin Fletcher
00043 #
00044 
00045 package DExec;
00046 
00047 use DCPU;
00048 
00049 use DExecHWAdapter;
00050 
00051 ## The indices of the registers in our 'registers' array.
00052 our $O  = 8;
00053 our $SP = 9;
00054 our $PC = 10;
00055 our @RegisterNames = (
00056         (sort { $DCPU::RegisterMap{$a} <=> $DCPU::RegisterMap{$b} }
00057             keys %DCPU::RegisterMap),  # 0-7
00058         'O',                        # 8
00059         'SP',                       # 9
00060         'PC',                       # 10
00061     );
00062 
00063 
00064 # Whether we want to debug the reference handling
00065 my $debug_ref = 0;
00066 
00067 ##
00068 # The functions to apply for every basic opcode.
00069 # 
00070 # Each function is passed the DExec object, operand a and operand b.
00071 my %basicFuncs = (
00072 
00073     # 0x1: SET a, b - sets a to b
00074     $DCPU::BasicOps{'SET'} => sub {
00075             my ($self, $operand_a, $operand_b) = @_;
00076 
00077             $self->writeref($operand_a, $self->readref($operand_b));
00078             $self->cycles(1);
00079         },
00080 
00081     # 0x2: ADD a, b - sets a to a+b, sets O to 0x0001 if there's
00082     #      an overflow, 0x0 otherwise
00083     $DCPU::BasicOps{'ADD'} => sub {
00084             my ($self, $operand_a, $operand_b) = @_;
00085 
00086             my $a = $self->readref($operand_a);
00087             my $b = $self->readref($operand_b);
00088             my $value = $a + $b;
00089             
00090             $self->writeref($operand_a, $value);
00091             $self->{'registers'}->[ $O ] = ($value >> 16) & 0xFFFF;
00092             $self->cycles(2);
00093         },
00094     
00095     # 0x3: SUB a, b - sets a to a-b, sets O to 0xffff if there's an
00096     #      underflow, 0x0 otherwise
00097     $DCPU::BasicOps{'SUB'} => sub {
00098             my ($self, $operand_a, $operand_b) = @_;
00099 
00100             my $a = $self->readref($operand_a);
00101             my $b = $self->readref($operand_b);
00102             my $value = $a - $b;
00103             
00104             $self->writeref($operand_a, $value);
00105             $self->{'registers'}->[ $O ] = ($value >> 16) & 0xFFFF;
00106             $self->cycles(2);
00107         },
00108 
00109     # 0x4: MUL a, b - sets a to a*b, sets O to ((a*b)>>16)&0xffff
00110     $DCPU::BasicOps{'MUL'} => sub {
00111             my ($self, $operand_a, $operand_b) = @_;
00112 
00113             my $a = $self->readref($operand_a);
00114             my $b = $self->readref($operand_b);
00115             my $value = $a * $b;
00116             
00117             $self->writeref($operand_a, $value);
00118             $self->{'registers'}->[ $O ] = ($value >> 16) & 0xFFFF;
00119             $self->cycles(2);
00120         },
00121 
00122     # 0x5: DIV a, b - sets a to a/b, sets O to ((a<<16)/b)&0xffff.
00123     #      if b==0, sets a and O to 0 instead.
00124     $DCPU::BasicOps{'DIV'} => sub {
00125             my ($self, $operand_a, $operand_b) = @_;
00126 
00127             my $a = $self->readref($operand_a);
00128             my $b = $self->readref($operand_b);
00129             if ($b == 0)
00130             {
00131                 $self->writeref($operand_a, 0);
00132                 $self->{'registers'}->[ $O ] = 0;
00133             }
00134             else
00135             {
00136                 my $value = $a / $b;
00137                 my $fraction = ($a << 16) / $b;
00138 
00139                 $self->writeref($operand_a, int($value));
00140                 $self->{'registers'}->[ $O ] = $fraction & 0xFFFF;
00141             }
00142             $self->cycles(3);
00143         },
00144         
00145     # 0x6: MOD a, b - sets a to a%b. if b==0, sets a to 0 instead.
00146     $DCPU::BasicOps{'MOD'} => sub {
00147             my ($self, $operand_a, $operand_b) = @_;
00148 
00149             my $a = $self->readref($operand_a);
00150             my $b = $self->readref($operand_b);
00151             if ($b == 0)
00152             {
00153                 $self->writeref($operand_a, 0);
00154             }
00155             else
00156             {
00157                 my $value = $a % $b;
00158 
00159                 $self->writeref($operand_a, int($value));
00160             }
00161             $self->cycles(3);
00162         },
00163 
00164     # 0x7: SHL a, b - sets a to a<<b, sets O to ((a<<b)>>16)&0xffff
00165     $DCPU::BasicOps{'SHL'} => sub {
00166             my ($self, $operand_a, $operand_b) = @_;
00167 
00168             my $a = $self->readref($operand_a);
00169             my $b = $self->readref($operand_b);
00170             my $value = $a << $b;
00171             
00172             $self->writeref($operand_a, $value);
00173             $self->{'registers'}->[ $O ] = ($value >> 16) & 0xFFFF;
00174             $self->cycles(2);
00175         },
00176 
00177     # 0x8: SHR a, b - sets a to a>>b, sets O to ((a<<16)>>b)&0xffff
00178     $DCPU::BasicOps{'SHR'} => sub {
00179             my ($self, $operand_a, $operand_b) = @_;
00180 
00181             my $a = $self->readref($operand_a);
00182             my $b = $self->readref($operand_b);
00183             my $value = $a >> $b;
00184             
00185             $self->writeref($operand_a, $value);
00186             $self->{'registers'}->[ $O ] = (($a<<16) >> $b) & 0xFFFF;
00187             $self->cycles(2);
00188         },
00189 
00190     # 0x9: AND a, b - sets a to a&b
00191     $DCPU::BasicOps{'AND'} => sub {
00192             my ($self, $operand_a, $operand_b) = @_;
00193 
00194             my $a = $self->readref($operand_a);
00195             my $b = $self->readref($operand_b);
00196             my $value = $a & $b;
00197             
00198             $self->writeref($operand_a, $value);
00199             $self->cycles(1);
00200         },
00201 
00202     # 0xa: BOR a, b - sets a to a|b
00203     $DCPU::BasicOps{'BOR'} => sub {
00204             my ($self, $operand_a, $operand_b) = @_;
00205 
00206             my $a = $self->readref($operand_a);
00207             my $b = $self->readref($operand_b);
00208             my $value = $a | $b;
00209             
00210             $self->writeref($operand_a, $value);
00211             $self->cycles(1);
00212         },
00213 
00214     # 0xb: XOR a, b - sets a to a^b
00215     $DCPU::BasicOps{'XOR'} => sub {
00216             my ($self, $operand_a, $operand_b) = @_;
00217 
00218             my $a = $self->readref($operand_a);
00219             my $b = $self->readref($operand_b);
00220             my $value = $a ^ $b;
00221             
00222             $self->writeref($operand_a, $value);
00223             $self->cycles(1);
00224         },
00225 
00226     # 0xc: IFE a, b - performs next instruction only if a==b
00227     $DCPU::BasicOps{'IFE'} => sub {
00228             my ($self, $operand_a, $operand_b) = @_;
00229 
00230             my $a = $self->readref($operand_a);
00231             my $b = $self->readref($operand_b);
00232             $self->{'executenext'} = ($a == $b);
00233             $self->cycles(2 + ($self->{'executenext'} ? 0 : 1));
00234         },
00235 
00236     # 0xd: IFN a, b - performs next instruction only if a!=b
00237     $DCPU::BasicOps{'IFN'} => sub {
00238             my ($self, $operand_a, $operand_b) = @_;
00239 
00240             my $a = $self->readref($operand_a);
00241             my $b = $self->readref($operand_b);
00242             $self->{'executenext'} = ($a != $b);
00243             $self->cycles(2 + ($self->{'executenext'} ? 0 : 1));
00244         },
00245 
00246     # 0xe: IFG a, b - performs next instruction only if a>b
00247     $DCPU::BasicOps{'IFG'} => sub {
00248             my ($self, $operand_a, $operand_b) = @_;
00249 
00250             my $a = $self->readref($operand_a);
00251             my $b = $self->readref($operand_b);
00252             $self->{'executenext'} = ($a > $b);
00253             $self->cycles(2 + ($self->{'executenext'} ? 0 : 1));
00254         },
00255 
00256     # 0xf: IFB a, b - performs next instruction only if (a&b)!=0
00257     $DCPU::BasicOps{'IFB'} => sub {
00258             my ($self, $operand_a, $operand_b) = @_;
00259 
00260             my $a = $self->readref($operand_a);
00261             my $b = $self->readref($operand_b);
00262             $self->{'executenext'} = ($a & $b) != 0;
00263             $self->cycles(2 + ($self->{'executenext'} ? 0 : 1));
00264         },
00265 );
00266 
00267 
00268 ##
00269 # The functions to apply for every extended opcode.
00270 # 
00271 # Each function is passed the DExec object, and operand a.
00272 my %extendedFuncs = (
00273 
00274     # 0x01: JSR a - pushes the address of the next instruction to the
00275     # stack, then sets PC to a
00276     $DCPU::ExtendedOps{'JSR'} => sub {
00277             my ($self, $operand_a) = @_;
00278             
00279             $self->writeref( $self->PUSH(), $self->{'registers'}->[ $PC ]);
00280 
00281             $self->{'registers'}->[ $PC ] = $self->readref($operand_a);
00282             $self->cycles(2);
00283         },
00284 );
00285 
00286 
00287 ##
00288 # Construct a new assembler object.
00289 #
00290 # @param[in]  $proto   This class object, or prototype to add to
00291 # @param[in]  $core    The core to execute (may be a hashref
00292 #                      of address=>value, or DASM object reference)
00293 #
00294 # @return Assembler object
00295 sub new
00296 {
00297     my $proto = shift;
00298     my $core = shift;
00299     my $class = ref($proto) || $proto;
00300     my $self;
00301     my $hardware = {};
00302     
00303     if (!defined $core)
00304     {
00305         $core = {};
00306     }
00307     elsif (ref $core eq 'DASM')
00308     {
00309         $hardware = $core->{'hardware'};
00310         $core = $core->{'core'};
00311     }
00312     # FIXME: Consider whether we should support hardware passed in
00313     #        arguments, or whether we should even support a non-DASM
00314     #        object as the core source.
00315 
00316     $self = {
00317             # Core values
00318             'core' => $core,
00319 
00320             # Hardware objects (hashref by address)
00321             'hardware' => $hardware,
00322             
00323             # Hardware objects that can poll (arrayref)
00324             'hardware-poll' => [ grep { $_->can('poll') } values %$hardware ],
00325             
00326             # Register values
00327             'registers' => [ 
00328                     map {
00329                         0
00330                     } (@RegisterNames)
00331                 ],
00332             
00333             # 'Execute next instruction' flag
00334             'executenext' => 1,
00335 
00336             # Cycle counter, incremented by each instruction
00337             'cycles' => 0,
00338 
00339             # Instructions executed
00340             'instructions' => 0,
00341             
00342             # Whether we have called the 'start' for hardware
00343             'started' => 0,
00344         };
00345     
00346     bless $self, $class;
00347     
00348     return $self;
00349 }
00350 
00351 
00352 ##
00353 # Destroy the object, implicitly ending all the hardware that wasn't
00354 # stopped previously.
00355 sub DESTROY
00356 {
00357     my ($self) = @_;
00358     
00359     # Stop all the hardware
00360     $self->stop();
00361 }
00362 
00363 
00364 
00365 ##
00366 # Increment the number of cycles taken
00367 #
00368 # @param[in] $self   DExec object
00369 # @param[in] $cycles Number of cycles consumed, or undef to read
00370 #
00371 # @return Total number of cycles.
00372 sub cycles
00373 {
00374     my ($self, $cycles) = @_;
00375     
00376     $self->{'cycles'} += $cycles if (defined $cycles);
00377     
00378     return $self->{'cycles'};
00379 }
00380 
00381 
00382 ##
00383 # Return the number of instructions executed
00384 #
00385 # @param[in] $self   DExec object
00386 #
00387 # @return Total number of instructions
00388 sub instructions
00389 {
00390     my ($self) = @_;
00391     
00392     return $self->{'instructions'};
00393 }
00394 
00395 
00396 ## 
00397 # Get a word from the core.
00398 #
00399 # Any core values that haven't been assigned will return 0.
00400 #
00401 # @param[in] $self   DExec object
00402 # @param[in] $addr   Address to read from
00403 #
00404 # @return value from the core
00405 sub getword
00406 {
00407     my ($self, $addr) = @_;
00408     
00409     $addr = $addr & 0xffff;
00410     
00411     if (defined $self->{'core'}->{ $addr })
00412     {
00413         return $self->{'core'}->{ $addr };
00414     }
00415     else
00416     {
00417         return 0;
00418     }
00419 }
00420 
00421 
00422 ## 
00423 # Get a reference to a word from the core.
00424 #
00425 # Any core values that haven't been assigned will be assigned 0.
00426 #
00427 # @param[in] $self   DExec object
00428 # @param[in] $addr   Address to read from
00429 #
00430 # @return reference to a value from the core
00431 sub getwordref
00432 {
00433     my ($self, $addr) = @_;
00434     
00435     $addr = $addr & 0xffff;
00436     
00437     if (!defined $self->{'core'}->{ $addr })
00438     {
00439         $self->{'core'}->{ $addr } = 0;
00440 
00441     }
00442     my $ref = \$self->{'core'}->{ $addr };
00443     
00444     printf "> getwordref: %s = %04x\n", $ref, $addr if ($debug_ref);
00445     
00446     return $ref;
00447 }
00448 
00449 
00450 ##
00451 # Read PC and increment.
00452 #
00453 # @param[in] $self   DExec object
00454 #
00455 # @return value from the core and increment PC
00456 sub nextword
00457 {
00458     my ($self) = @_;
00459     
00460     my $pc = $self->{'registers'}->[ $PC ]++;
00461     
00462     return $self->getword($pc);
00463 }
00464 
00465 
00466 ##
00467 # Get the value of an operand, given the operand value.
00468 #
00469 # @param[in] $self      DExec object
00470 # @param[in] $operand   Operand value
00471 #
00472 # @return $valref   reference to the operand value, or an
00473 #                   object to access value
00474 # @note Constants will still be returned as a reference (to a value
00475 #       that goes nowhere)
00476 sub getoperand
00477 {
00478     my ($self, $operand) = @_;
00479     
00480     # 0x00-0x07: register (A, B, C, X, Y, Z, I or J, in that order)
00481     if ($operand >= 0x00 && $operand <= 0x07)
00482     {
00483         return \$self->{'registers'}->[ $operand ];
00484     }
00485     # 0x08-0x0f: [register]
00486     elsif ($operand >= 0x08 && $operand <= 0x0f)
00487     {
00488         $self->cycles(1) if ($self->{'executenext'}); # 1 extra cycle for the read
00489         return $self->getwordref( $self->{'registers'}->[ $operand - 0x08 ]);
00490     }
00491     # 0x10-0x17: [next word + register]
00492     elsif ($operand >= 0x10 && $operand <= 0x17)
00493     {
00494         my $nextword = $self->nextword();
00495         # an extra cycles for the read of the referenced value
00496         $self->cycles(1) if ($self->{'executenext'});
00497         return $self->getwordref( $nextword +
00498                                   $self->{'registers'}->[ $operand - 0x10 ] );
00499     }
00500     #      0x18: POP / [SP++]
00501     elsif ($operand == 0x18)
00502     {
00503         $self->cycles(1) if ($self->{'executenext'}); # 1 extra cycle for the read
00504         return $self->POP();
00505     }
00506     #      0x19: PEEK / [SP]
00507     elsif ($operand == 0x19)
00508     {
00509         $self->cycles(1) if ($self->{'executenext'}); # 1 extra cycle for the read
00510         return $self->PEEK();
00511     }
00512     #      0x1a: PUSH / [--SP]
00513     elsif ($operand == 0x1a)
00514     {
00515         $self->cycles(1) if ($self->{'executenext'}); # 1 extra cycle for the read
00516         return $self->PUSH();
00517     }
00518     #      0x1b: SP
00519     elsif ($operand == 0x1b)
00520     {
00521         return \$self->{'registers'}->[ $SP ];
00522     }
00523     #      0x1c: PC
00524     elsif ($operand == 0x1c)
00525     {
00526         return \$self->{'registers'}->[ $PC ];
00527     }
00528     #      0x1d: O
00529     elsif ($operand == 0x1d)
00530     {
00531         return \$self->{'registers'}->[ $O ];
00532     }
00533     #      0x1e: [next word]
00534     elsif ($operand == 0x1e)
00535     {
00536         # 1 extra cycles for the referenced value
00537         $self->cycles(1) if ($self->{'executenext'});
00538         return $self->getwordref( $self->nextword() );
00539     }
00540     #      0x1f: next word (literal)
00541     elsif ($operand == 0x1f)
00542     {
00543         my $pc = $self->{'registers'}->[ $PC ]++;
00544         return $self->getwordref($pc);
00545     }
00546     # 0x20-0x3f: literal value 0x00-0x1f (literal)
00547     elsif ($operand >= 0x20 && $operand <= 0x3f)
00548     {
00549         my $value = $operand - 0x20;
00550         return \$value;
00551     }
00552     else
00553     {
00554         die "Invalid operand value $operand";
00555     }
00556 }
00557 
00558 
00559 ##
00560 # Read a value from a reference.
00561 #
00562 # @param[in] $self   DExec object
00563 # @param[in] $ref    Reference to read the value of
00564 #
00565 # @return value
00566 sub readref
00567 {
00568     my ($self, $ref) = @_;
00569     
00570     if (ref $$ref ne '')
00571     {
00572         # This is a hardware implementation, so invoke the writer
00573         print "> ReadRefHW: ".$$ref->describe()."\n" if ($debug_ref);
00574         return $$ref->read($exec, $value);
00575     }
00576     else
00577     {
00578         print "> ReadRef: $ref\n" if ($debug_ref);
00579         return $$ref;
00580     }
00581 }
00582 
00583 
00584 ##
00585 # Write a value to a reference.
00586 #
00587 # @param[in] $self   DExec object
00588 # @param[in] $ref    Reference to write to
00589 # @param[in] $value  Value to write
00590 sub writeref
00591 {
00592     my ($self, $ref, $value) = @_;
00593     
00594     die "Attempted to write an undef\n" if (!defined $value); 
00595     
00596     $value = $value & 0xFFFF;
00597     
00598     if (ref $$ref ne '')
00599     {
00600         # This is a hardware implementation, so invoke the writer
00601         print "> WriteRefHW: ".$$ref->describe()." : $value\n" if ($debug_ref);
00602         $$ref->write($exec, $value);
00603     }
00604     else
00605     {
00606         print "> WriteRef: $ref : $value\n" if ($debug_ref);
00607         $$ref = $value;
00608     }
00609 }
00610 
00611 
00612 
00613 ##
00614 # POP (unstack a value) from the full descending stack
00615 #
00616 # @param[in] $self   DExec object
00617 #
00618 # @return reference to the value popped
00619 sub POP
00620 {
00621     my ($self) = @_;
00622     my $sp = $self->{'registers'}->[ $SP ]++;
00623     if ($self->{'registers'}->[ $SP ] > 0xFFFF)
00624     {
00625         $self->{'registers'}->[ $SP ] = 0;
00626     }
00627     return $self->getwordref($sp);
00628 }
00629 
00630 
00631 ##
00632 # PUSH (stack a value) on to the full descending stack
00633 #
00634 # @param[in] $self   DExec object
00635 #
00636 # @return reference to the value popped
00637 sub PUSH
00638 {
00639     my ($self) = @_;
00640     $self->{'registers'}->[ $SP ] -= 1;
00641     if ($self->{'registers'}->[ $SP ] < 0)
00642     {
00643         $self->{'registers'}->[ $SP ] = 0xFFFF;
00644     }
00645     return $self->getwordref( $self->{'registers'}->[ $SP ] );
00646 }
00647 
00648 
00649 ##
00650 # PEEK (look at the stack value) in a full descending stack
00651 #
00652 # @param[in] $self   DExec object
00653 #
00654 # @return reference to the value popped
00655 sub PEEK
00656 {
00657     my ($self) = @_;
00658     my $sp = $self->{'registers'}->[ $SP ];
00659     return $self->getwordref($sp);
00660 }
00661 
00662 
00663 ##
00664 # Start execution in the CPU
00665 #
00666 # Calls the hardware initialisation entry points, sets the PC to the
00667 # requested value, and clears registers to their initial value.
00668 # IF the CPU has already been started, the end() execution will be
00669 # called for all the CPUs.
00670 #
00671 # @param[in] $self   DExec object
00672 # @param[in] $pc     PC to start at (defaults to 0)
00673 sub start
00674 {
00675     my ($self, $pc) = @_;
00676     $pc = 0 if (!defined $pc);
00677     
00678     if ($self->{'started'})
00679     {
00680         # The system has already started, so try again
00681         $self->end();
00682     }
00683     
00684     $self->{'started'} = 1;
00685     
00686     # Initialise all the devices, from lowest to highest
00687     for my $address (sort { $a <=> $b } keys %{ $self->{'hardware'} })
00688     {
00689         my $device = $self->{'hardware'}->{$address};
00690         if ($device->can('start'))
00691         {
00692             $device->start($dexec);
00693         }
00694     }
00695     
00696     $self->{'registers'}->[ $PC ] = $pc;
00697 }
00698 
00699 
00700 ##
00701 # Stop execution on a CPU.
00702 #
00703 # Calls all the 'stop' entry points to stop the devices from running.
00704 # Mostly this is intended to clear up their terminal controls, sync
00705 # any buffered data and otherwise tidy up cleanly.
00706 #
00707 # @param[in] $self   DExec object
00708 sub stop
00709 {
00710     my ($self, $pc) = @_;
00711     
00712     return if ($self->{'started'} == 0);
00713     
00714     # Clear our flag
00715     $self->{'started'} = 0;
00716     
00717     # Shutdown all the devices, from lowest to highest
00718     for my $address (sort { $a <=> $b } keys %{ $self->{'hardware'} })
00719     {
00720         my $device = $self->{'hardware'}->{$address};
00721         if ($device->can('stop'))
00722         {
00723             $device->stop($dexec);
00724         }
00725     }
00726 }
00727 
00728 
00729 ##
00730 # Run a single instruction.
00731 #
00732 # @param[in] $self   DExec object
00733 sub runone
00734 {
00735     my ($self) = @_;
00736 
00737     # If they haven't already called 'start', do so for them
00738     $self->start(0) if (!$self->{'started'});
00739 
00740     my $instruction = $self->nextword();
00741     
00742     my $opcode = ($instruction & 15);
00743     
00744     if ($opcode != 0)
00745     {
00746         # A basic opcode
00747         my $op = $basicFuncs{$opcode};
00748         my $pc = $self->{'registers'}->[ $PC ];
00749         my $operand_a = $self->getoperand(($instruction >> 4) & 0x3f);
00750         my $operand_b = $self->getoperand(($instruction >> 10) & 0x3f);
00751         my $extracycles = $self->{'registers'}->[ $PC ] - $pc;
00752         
00753         if ($self->{'executenext'})
00754         {
00755             if (!defined $op)
00756             {
00757                 # This should never happen
00758                 die "Attempt to execute invalid opcode $opcode";
00759             }
00760             
00761             # Increment our counter
00762             $self->{'instructions'}++;
00763             
00764             $self->{'cycles'} += $extracycles;
00765 
00766             # Run the instruction
00767             & $op ($self, $operand_a, $operand_b);
00768         }
00769         else
00770         {
00771             $self->{'executenext'} = 1;
00772         }
00773     }
00774     else
00775     {
00776         # Opcode 0 is an extended opcode
00777         $opcode = ($instruction >> 4) & 0x3f;
00778         my $op = $extendedFuncs{$opcode};
00779         
00780         my $operand_a = $self->getoperand(($instruction >> 10) & 0x3f);
00781         
00782         if ($self->{'executenext'})
00783         {
00784             if (!defined $op)
00785             {
00786                 # This should never happen
00787                 die "Attempt to execute invalid extended opcode $opcode";
00788             }
00789             
00790             # Increment our counter
00791             $self->{'instructions'}++;
00792 
00793             # Run the instruction
00794             & $op ($self, $operand_a);
00795         }
00796         else
00797         {
00798             $self->{'executenext'} = 1;
00799         }
00800     }
00801     
00802     # At the end of each instruction, we call the hardware devices
00803     # which have been configured to poll.
00804     for my $device (@{ $self->{'hardware-poll'} })
00805     {
00806         $device->poll($self);
00807     }
00808 }
00809 
00810 
00811 ##
00812 # Show the current registers state
00813 #
00814 # The registers will be listed, followed by value of the instruction
00815 # at PC, and 'NX' if the 'no execute' flag has been set for the next
00816 # instruction.
00817 # Following the registers, the stack will be printed, ascending from
00818 # SP to the top of memory.
00819 #
00820 # @param[in]  $self     DExec object
00821 # @param[in]  $prefix   Prefix for each line
00822 sub showregs
00823 {
00824     my ($self, $prefix) = @_;
00825     $prefix = "" if (!defined $prefix);
00826     
00827     print "$prefix";
00828     for my $i (0..$#RegisterNames)
00829     {
00830         printf "%2s: %04x ", $RegisterNames[$i],
00831                               $self->{'registers'}->[$i];
00832         if (($i & 7) == 7)
00833         {
00834             print "\n$prefix";
00835         }
00836     }
00837     printf "[%04x]  ", $self->getword( $self->{'registers'}->[ $PC ] );
00838 
00839     if (!$self->{'executenext'})
00840     {
00841         print "NX";
00842     }
00843     
00844     print "\n";
00845  
00846     # Show the stack
00847     my $sp = $self->{'registers'}->[$SP];
00848     print "${prefix}STK> ";
00849     my $wrote = 0;
00850     while ($sp != 0 && $sp < 0x10000)
00851     {
00852         printf "[%04x]  ", $self->getword( $sp );
00853         $sp++;
00854         $wrote++;
00855         if (($wrote & 16)==15 && $sp != 0x10000)
00856         {
00857             print "\n$prefix     ";
00858         }
00859     }
00860     print "\n\n";
00861 }
00862 
00863 
00864 ##
00865 # Read a named register.
00866 #
00867 # @param[in] $self   Dexec object
00868 # @param[in] $reg    named register
00869 #
00870 # @return register value
00871 sub getreg
00872 {
00873     my ($self, $reg) = @_;
00874     
00875     $reg = uc $reg;
00876     
00877     if (defined $DCPU::RegisterMap{$reg})
00878     {
00879         return $self->{'registers'}->[$DCPU::RegisterMap{$reg}];
00880     }
00881     elsif ($reg eq 'PC')
00882     {
00883         return $self->{'registers'}->[$PC];
00884     }
00885     elsif ($reg eq 'SP')
00886     {
00887         return $self->{'registers'}->[$SP];
00888     }
00889     elsif ($reg eq 'O')
00890     {
00891         return $self->{'registers'}->[$O];
00892     }
00893     else
00894     {
00895         die "Unrecognised register $reg\n";
00896     }
00897 }
00898 
00899 # Must return true
00900 1;