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