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