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