;;; -*- Mode: LISP; Package: UA -*- ; ** (c) Copyright 1980 Massachusetts Institute of Technology ** ;Managing microcode entries and stuff: ; All actual microcode entry address are stored in MICRO-CODE-SYMBOL-AREA. ;This area is 1000 locations long. The first 600 are accessible via ;misc macroinstruction (values 200-777). ; How DTP-U-ENTRY works: DTP-U-ENTRY is sort of an indirect pointer relative ;to the origin of MICRO-CODE-ENTRY-AREA. The Q referenced is to be interpreted ;in functional context in the normal fashion, with one exception: If the ;data type is DTP-FIX, this is a "real" ucode entry. ;In that case, various data (the number of args, etc), can be obtained ;by referencing various other specified areas with the same offset as was used ;to reference MICRO-CODE-ENTRY-AREA. The address to transfer to in microcode ;is gotten by referencing MICRO-CODE-SYMBOL-AREA at the relative address ;that was obtained from MICRO-CODE-ENTRY-AREA. The reason for the indirecting ;step from MICRO-CODE-ENTRY-AREA to MICRO-CODE-SYMBOL-AREA is to separate ;the world into two independant pieces. (The microcode and MICRO-CODE-SYMBOL-AREA ;separate from the rest of the load). ; Making new microcoded functions. Two "degrees of commitment" are available, ;ie, the newly added function can be made available as a misc instruction or not. ;If it is available as a misc instruction, the system becomes completely committed ;to this function remaining microcoded forever. If not, it is possible in the future to ;decommit this function from microcode, reinstating the macrocoded definition. ; Decommiting can be done either by restoring the DTP-FEF-POINTER to the function cell, ;or by putting it in the MICRO-CODE-ENTRY-AREA position. This latter option allows ;the microcoded definition to be quickly reinstalled. ; One problem with decomitting concerns activation-records for the microcoded ;which may be lying around on various stack-groups. If later, an attempt is made ;to return through these, randomness will occur. To avoid this, on a ;macro-to-micro return, the microcode can check that the function being returnned ;to is still in fact microcoded. ;RE A-MEM AND M-MEM. SEPARATE REGISTER ADDRESSES HAVE BEEN RETAINED SINCE ; THERE REALLY ARE TWO REGISTERS IN THE HARDWARE AND WE WANT TO BE ; ABLE TO EXAMINE BOTH IN CC. HOWEVER, IN THE FOLLOWING, THERE IS ; REALLY ONLY ONE ARRAY, 0-37 OF WHICH IS CONSIDERED TO BE M-MEM, THE REST, A-MEM. (DECLARE SI:(SPECIAL RAPC RASIR RAOBS RANOOPF RASTS RACMO RACME RADME RAPBE RAM1E RAM2E RAAME RAUSE RAMME RAFSE RAFDE RARGE RACSWE RARDRE RACIBE RAGO RASTOP RARDRO RAFDO RAOPCE RARS RASTEP RASA RAAMO RAMMO RARCON RAPBO RAUSO RADMO RADME)) ;A "TOTAL" SNAPSHOT OF THE PROCESSOR CONSISTS OF A UCODE-IMAGE AND A UCODE-STATE. ;THE UCODE-IMAGE CONTAINS QUANTITIES WHICH ARE UNCHANGED ONCE THEY ARE LOADED, ;WHILE ALL "DYNAMIC" QUANTITIES ARE CONTAINED IN THE UCODE-STATE. THE ASSIGNMENT ;AS TO WHICH ONE IS MADE ON A MEMORY BY MEMORY BASIS EXCEPT FOR A-MEMORY ;IS ASSIGNED ON A LOCATION BY LOCATION BASIS. AS WELL AS THE ;CONTENTS OF ALL HARDWARE MEMORIES, THE COMBINED UCODE-IMAGE AND UCODE-STATE ;ALSO CONTAIN COPIES OF MICRO-CODE-RELATED MAIN MEMORY ;AREAS SUCH AS MICRO-CODE-SYMBOL-AREA AND PAGE-TABLE-AREA. THE INTENTION IS THAT ;ALL DATA WHICH CHANGES "MAGICALLY" FROM THE POINT OF VIEW OF LISP BE INCLUDED IN UCODE-STATE. ;THUS THE INCLUSION OF PAGE-TABLE-AREA. ONE MOTOVATION FOR HAVING SUCH AN INCLUSIVE ;UCODE-STATE IS TO BE ABLE TO FIND POSSIBLE BUGS BY CHECKING THE PAGE-TABLES ETC, FOR ;CONSISTENCY. ALSO, IT MAY BE POSSIBLE IN THE FUTURE TO SINGLE STEP MICROCODE ;VIA THIS MECHANISM (EITHER VIA HARDWARE OR VIA A SIMULATOR). (DECLARE (SPECIAL CURRENT-UCODE-IMAGE CURRENT-ASSEMBLY-DEFMICS CURRENT-ASSEMBLY-TABLE CURRENT-ASSEMBLY-HIGHEST-MISC-ENTRY)) (DEFVAR NUMBER-MICRO-ENTRIES NIL) ;Should have same value as SYSTEM:%NUMBER-OF-MICRO-ENTRIES ;Point is, that one is stored in A-MEM and is reloaded ;if machine gets warm-booted. ;A UCODE-IMAGE AND ASSOCIATED STUFF DESCRIBE THE COMPLETE STATE OF A MICRO-LOAD. ; NOTE THAT THIS IS NOT NECESSARILY THE MICRO-LOAD ACTUALLY LOADED INTO THE MACHINE ; AT A GIVEN TIME. (DEFSTRUCT (UCODE-IMAGE :ARRAY :NAMED) UCODE-IMAGE-VERSION ;VERSION # OF MICROCODE THIS IS. UCODE-IMAGE-MODULE-POINTS ;LIST OF UCODE-MODULE STRUCTURES, "MOST RECENT" FIRST. ; THESE GIVE MODULES ;THAT WERE LOADED AND STATE OF LOAD AFTER EACH SO ;THAT IT IS POSSIBLE TO UNLOAD A MODULE, ETC. (IN PUSH ;DOWN FASHION. ALL MODULES LOADED SINCE THAT ; MODULE MUST ALSO BE UNLOADED, ETC.) UCODE-IMAGE-MODULE-LOADED ;A TAIL OF UCODE-IMAGE-MODULE-POINTS, WHICH IS ; IS LIST OF MODULES ACTUALLY LOADED NOW. UCODE-IMAGE-TABLE-LOADED ;THE CONCENTATIONATION OF THE UCODE-TABLES FOR ; THE MODULES LOADED. UCODE-IMAGE-ASSEMBLER-STATE ;ASSEMBLER STATE AFTER MAIN ASSEMBLY (UCODE-IMAGE-CONTROL-MEMORY-ARRAY ;DATA AS LOADED INTO CONTROL MEMORY (MAKE-ARRAY NIL 'ART-Q 30000)) ;SIZE-OF-HARDWARE-EXISTING-CONTROL-MEMORY ;SIZE-OF-HARDWARE-CONTROL-MEMORY (UCODE-IMAGE-DISPATCH-MEMORY-ARRAY ;DATA AS LOADED INTO DISPATCH MEMORY (MAKE-ARRAY NIL ; 1 ENTRY/ WORD 'ART-Q SI:SIZE-OF-HARDWARE-DISPATCH-MEMORY)) (UCODE-IMAGE-A-MEMORY-LOCATION-IN-IMAGE ;1 -> THIS A-MEM LOCATION PART OF UCODE-IMAGE (MAKE-ARRAY NIL ;0 -> PART OF UCODE-STATE 'ART-1B SI:SIZE-OF-HARDWARE-A-MEMORY)) (UCODE-IMAGE-A-MEMORY-ARRAY ;DATA AS LOADED INTO A MEMORY (MAKE-ARRAY NIL 'ART-Q SI:SIZE-OF-HARDWARE-A-MEMORY)) (UCODE-IMAGE-ENTRY-POINTS-ARRAY ;IMAGE OF THE STUFF THAT NORMALLY GETS (MAKE-ARRAY NIL ; LOADED INTO MICRO-CODE-SYMBOL-AREA IN 'ART-Q ; MAIN MEMORY, W/ FILL POINTER. 1000 ; FIRST 600 LOCS ARE ENTRIES FOR MISC NIL ; INSTS 200-777. '(577))) ; NEXT 200 ARE FOR MICRO-CODE-ENTRIES ; (SPECIFIED VIA MICRO-CODE-ENTRY PSEUDO IN ; CONSLP) ; REST ARE ENTRY POINTS TO MICROCOMPILED FCTNS. (UCODE-IMAGE-SYMBOL-ARRAY ;CONSLP SYMBOLS. ALTERNATING SYMBOL, TYPE, VALUE (MAKE-ARRAY NIL ; W/ FILL POINTER 'ART-Q 3000 NIL '(0))) ) (DEFUN UCODE-IMAGE (OP &OPTIONAL UCODE-IMAGE &REST ARGS) (SELECTQ OP (:WHICH-OPERATIONS '(:PRINT :PRINT-SELF)) ((:PRINT :PRINT-SELF) (FORMAT (CAR ARGS) "[UCODE-IMAGE version ~d, modules ~s]" (UCODE-IMAGE-VERSION UCODE-IMAGE) (UCODE-IMAGE-MODULE-POINTS UCODE-IMAGE))) (:OTHERWISE (FERROR 'BAD-OP "~S Bad operation for a named-structure" op)))) (DEFUN UCODE-MODULE (OP &OPTIONAL UCODE-MODULE &REST ARGS) (SELECTQ OP (:WHICH-OPERATIONS '(:PRINT :PRINT-SELF)) ((:PRINT :PRINT-SELF) (FORMAT (CAR ARGS) "[UCODE-MODULE ~s]" (UCODE-MODULE-SOURCE UCODE-MODULE))) (:OTHERWISE (FERROR 'BAD-OP "~S Bad operation for a named-structure" op)))) (DEFVAR CURRENT-UCODE-IMAGE (MAKE-UCODE-IMAGE)) (DEFVAR CURRENT-ASSEMBLY-DEFMICS NIL) (DEFVAR CURRENT-ASSEMBLY-TABLE NIL) (DEFVAR CC-UCODE-IMAGE (MAKE-UCODE-IMAGE)) ;Use this for frobbing other machine with CC. ; A UCODE-MODULE IS THE UNIT IN WHICH UCODE IS LOADED. THE UCODE-MODULE ;CONTAINTS ENUF INFORMATION TO COMPLETELY HOLD THE LOGICAL STATE OF THE UCODE-LOADER ;JUST AFTER THE MODULE WAS LOADED. THUS, MODULES MAY BE OFF-LOADED IN REVERSE ;ORDER FROM THAT IN WHICH THEY WERE LOADED. THE ACTIVE UCODE-MODULES ARE ;CONTAINED IN A LIST OFF OF UCODE-IMAGE-MODULE-POINTS, THE LAST ELEMENT IN THAT ;LIST REFERS TO THE INITIAL MICROCODE LOAD. ; A-MEMORY IS ALLOCATED IN TWO REGIONS, AN ASCENDING CONSTANTS BLOCK, AND A ;VARIABLE BLOCK DESCENDING FROM THE TOP. IF THE TWO COLLIDE, A-MEMORY IS EXHAUSTED. (DEFSTRUCT (UCODE-MODULE :ARRAY :NAMED) UCODE-MODULE-IMAGE ;IMAGE THIS MODULE PART OF UCODE-MODULE-SOURCE ;WHERE CAME FROM: IF A STRING, IS THE FILE NAME. UCODE-MODULE-FILE-GROUP-SYMBOL ;FILE-GROUP-SYMBOL IF CAME FROM FILE. UCODE-MODULE-ASSEMBLER-STATE ;assembler state after module assembly UCODE-MODULE-TABLE ;as output by assembler. UCODE-MODULE-ENTRY-POINTS-INDEX ;fill-pointer of UCODE-IMAGE-ENTRY-POINTS-ARRAY UCODE-MODULE-DEFMICS UCODE-MODULE-SYM-ADR ;final fill pointer for UCODE-IMAGE-SYMBOL-ARRAY ) (DEFSTRUCT (UCODE-STATE) ;THE FOLLOWING REGISTERS "SHOULD" BE IN THE UCODE-STATE. HOWEVER, THEY ARE ;COMMENTED OUT FOR THE TIME BEING BECAUSE (1) THEY ARE NOT NEEDED FOR PRESENT ;PURPOSES. (2) THEY ARE AWKWARD TO DO WITHOUT BIGNUMS, ETC. THEY ;ARE IN THE SAME ORDER THEY ARE IN (ALMOST) THE ; REGISTER ADDRESS SPACE ; (UCODE-STATE-PC 0) ; PC (PC) ; (UCODE-STATE-USP 0) ; U STACK POINTER (USP) ;;RAIR==62562 ; .IR (PUT IN DIAG INST REG, THEN LOAD INTO IR, THEN ;; ; UPDATE OBUS DISPLAY. DIAGNOSTIC ONLY) ; (UCODE-STATE-IR 0) ; SAVED IR (THE ONE SAVE ON FULL STATE SAVE ; ; AND RESTORED ON FULL RESTORE) ; ; THIS IS NORMALLY THE UINST ABOUT TO GET EXECUTED. ; (UCODE-STATE-Q 0) ; Q REGISTER (Q) ; (UCODE-STATE-DISPATCH-CONSTANT 0) ; DISPATCH CONSTANT REGISTER (DC) ;;RARSET==62566 ; RESET REGISTER! DEPOSITING HERE ; ; CLEARS ENTIRE C, D, P, M1, M2, A, U AND ; ; M MEMORIES! ;;RASTS==62567 ; STATUS REGISTER (32 BIT, AS READ BY ERERWS) ; (UCODE-STATE-OUTPUT-BUS 0) ; OUTPUT BUS STATUS (32 BITS) ; ;;DUE TO LOSSAGE, THE FOLLOWING 4 ARE IN THE REGISTER ADDRESS SPACE AT A RANDOM PLACE ; (UCODE-STATE-MEM-WRITE-REG 0) ;MAIN MEM WRITE DATA REGISTER ; (UCODE-STATE-VMA 0) ;VMA (VIRTUAL MEMORY ADDRESS) ; (UCODE-STATE-PDL-POINTER 0) ;PDL POINTER (TO PDL BUFFER) ; (UCODE-STATE-PDL-INDEX 0) ;PDL INDEX (TO PDL BUFFER) (UCODE-STATE-A-MEMORY-ARRAY ;DATA AS LOADED INTO A MEMORY (MAKE-ARRAY NIL 'ART-16B SI:SIZE-OF-HARDWARE-A-MEMORY)) (UCODE-STATE-PDL-BUFFER-ARRAY ;DATA AS LOADED INTO PDL BUFFER (MAKE-ARRAY NIL 'ART-16B SI:SIZE-OF-HARDWARE-PDL-BUFFER)) (UCODE-STATE-MICRO-STACK-ARRAY ;DATA AS LOADED INTO USTACK (MAKE-ARRAY NIL 'ART-Q SI:SIZE-OF-HARDWARE-MICRO-STACK)) (UCODE-STATE-LEVEL-1-MAP ;DATA AS LOADED INTO LEVEL 1 MAP. (MAKE-ARRAY NIL 'ART-8B SI:SIZE-OF-HARDWARE-LEVEL-1-MAP)) (UCODE-STATE-LEVEL-2-MAP ;DATA AS LOADED INTO LEVEL 2 MAP (MAKE-ARRAY NIL 'ART-16B SI:SIZE-OF-HARDWARE-LEVEL-2-MAP)) (UCODE-STATE-UNIBUS-MAP ;DATA AS LOADED INTO UNIBUS MAP. (MAKE-ARRAY NIL 'ART-16B SI:SIZE-OF-HARDWARE-UNIBUS-MAP)) (UCODE-STATE-PAGE-TABLE ;COPY OF PAGE-TABLE-AREA (MAKE-ARRAY NIL 'ART-Q (SI:ROOM-GET-AREA-LENGTH-USED PAGE-TABLE-AREA))) (UCODE-STATE-PHYSICAL-PAGE-AREA-NUMBER ;COPY OF LIKE NAMED AREA (MAKE-ARRAY NIL 'ART-Q (SI:ROOM-GET-AREA-LENGTH-USED PHYSICAL-PAGE-AREA-NUMBER))) ) ;This is really useful only for wired areas, but may as well work for all. (DEFUN LOWEST-ADDRESS-IN-AREA (AREA) (DO ((REGION (SYSTEM:AREA-REGION-LIST AREA) (SYSTEM:REGION-LIST-THREAD REGION)) (BSF 1_22. (MIN BSF (SYSTEM:REGION-ORIGIN REGION)))) ((BIT-TEST (LSH 1 23.) REGION) BSF))) (DEFUN UCODE-IMAGE-STORE-ASSEMBLER-STATE (STATE UCODE-IMAGE) (SETF (UCODE-IMAGE-ASSEMBLER-STATE UCODE-IMAGE) STATE) ) (DEFUN UCODE-IMAGE-INITIALIZE (UCODE-IMAGE &AUX TEM) (COND ((NULL UCODE-IMAGE) (MAKE-UCODE-IMAGE)) (T (SETF (UCODE-IMAGE-MODULE-POINTS UCODE-IMAGE) NIL) ;RESET POINTERS, ETC (SETQ TEM (UCODE-IMAGE-A-MEMORY-LOCATION-IN-IMAGE UCODE-IMAGE)) (DO I 0 (1+ I) (= I SI:SIZE-OF-HARDWARE-A-MEMORY) (AS-1 0 TEM I)) (STORE-ARRAY-LEADER 577 (UCODE-IMAGE-ENTRY-POINTS-ARRAY UCODE-IMAGE) 0) (STORE-ARRAY-LEADER 0 (UCODE-IMAGE-SYMBOL-ARRAY UCODE-IMAGE) 0) UCODE-IMAGE)) ) (DEFUN READ-SIGNED-OCTAL-FIXNUM (&OPTIONAL (STREAM STANDARD-INPUT)) (PROG (NUM CH SIGN) (SETQ SIGN 1) (SETQ NUM 0) L1 (COND ((= (SETQ CH (FUNCALL STREAM 'TYI)) #/-) (SETQ SIGN (* SIGN -1)) (GO L1)) ((OR (< CH 60) (> CH 71)) (GO L1))) ;FLUSH ANY GARBAGE BEFORE NUMBER (CR-LF MOSTLY) L2 (SETQ NUM (+ (* NUM 10) (- CH 60))) (COND ((= (SETQ CH (FUNCALL STREAM 'TYI)) #/_) (RETURN (* SIGN (LSH NUM (READ-SIGNED-OCTAL-FIXNUM STREAM))))) ((OR (< CH 60) (> CH 71)) (RETURN (* NUM SIGN)))) (GO L2))) (DEFUN ADD-ASSEMBLY (&OPTIONAL FILE-NAME (IMAGE CURRENT-UCODE-IMAGE) &AUX ASSEMBLER-STATE-AFTER FILE-SYMBOL FILE-GROUP-SYMBOL) (COND ((NOT (EQ %MICROCODE-VERSION-NUMBER (UCODE-IMAGE-VERSION IMAGE))) (READ-UCODE-VERSION %MICROCODE-VERSION-NUMBER IMAGE))) (MULTIPLE-VALUE (FILE-SYMBOL FILE-GROUP-SYMBOL) (FS:GET-FILE-SYMBOLS FILE-NAME)) (COND ((EQ (UCODE-MODULE-FILE-GROUP-SYMBOL (CAR (UCODE-IMAGE-MODULE-POINTS IMAGE))) FILE-GROUP-SYMBOL) (FLUSH-MODULE NIL IMAGE))) ;EVIDENTLY A NEW VERSION, FLUSH THE OLD ;(UA-DEFINE-SYMS IMAGE) (ASSEMBLE FILE-NAME (UCODE-IMAGE-ASSEMBLER-STATE IMAGE)) (SETQ ASSEMBLER-STATE-AFTER (MAKE-ASSEMBLER-STATE-LIST)) ;MERGE RESULTS AND FORM NEW MODULE (MERGE-MEM-ARRAY (FUNCTION I-MEM) SI:RACMO IMAGE) (MERGE-MEM-ARRAY (FUNCTION D-MEM) SI:RADMO IMAGE) (MERGE-MEM-ARRAY (FUNCTION A-MEM) SI:RAAMO IMAGE) (LET ((MODULE (MAKE-UCODE-MODULE))) (SETF (UCODE-MODULE-IMAGE MODULE) IMAGE) (SETF (UCODE-MODULE-SOURCE MODULE) FILE-SYMBOL) (SETF (UCODE-MODULE-FILE-GROUP-SYMBOL MODULE) FILE-GROUP-SYMBOL) (SETF (UCODE-MODULE-ASSEMBLER-STATE MODULE) ASSEMBLER-STATE-AFTER) (SETF (UCODE-MODULE-ENTRY-POINTS-INDEX MODULE) (ARRAY-LEADER (UCODE-IMAGE-ENTRY-POINTS-ARRAY IMAGE) 0)) (SETF (UCODE-MODULE-DEFMICS MODULE) CURRENT-ASSEMBLY-DEFMICS) (SETF (UCODE-MODULE-TABLE MODULE) CURRENT-ASSEMBLY-TABLE) (SETF (UCODE-MODULE-SYM-ADR MODULE) (ARRAY-LEADER (UCODE-IMAGE-SYMBOL-ARRAY IMAGE) 0)) (SETF (UCODE-IMAGE-MODULE-POINTS IMAGE) (CONS MODULE (UCODE-IMAGE-MODULE-POINTS IMAGE)))) ) (DEFUN UNLOAD-MODULE (&OPTIONAL MOD (IMAGE CURRENT-UCODE-IMAGE)) (COND ((NULL MOD) (SETQ MOD (CAR (UCODE-IMAGE-MODULE-POINTS IMAGE))))) (COND ((NOT (EQ MOD (CAR (UCODE-IMAGE-MODULE-POINTS IMAGE)))) (FERROR NIL "Must unload modules in reverse order loaded"))) (COND ((EQ (UCODE-IMAGE-MODULE-POINTS IMAGE) (UCODE-IMAGE-MODULE-LOADED IMAGE)) (SETF (UCODE-IMAGE-MODULE-LOADED IMAGE) (CDR (UCODE-IMAGE-MODULE-POINTS IMAGE))))) ) (DEFUN FLUSH-MODULE (&OPTIONAL MOD (IMAGE CURRENT-UCODE-IMAGE)) (COND ((NULL MOD) (SETQ MOD (CAR (UCODE-IMAGE-MODULE-POINTS IMAGE))))) (COND ((NOT (EQ MOD (CAR (UCODE-IMAGE-MODULE-POINTS IMAGE)))) (FERROR NIL "Must flush modules in reverse order loaded"))) (COND ((EQ (UCODE-IMAGE-MODULE-POINTS IMAGE) (UCODE-IMAGE-MODULE-LOADED IMAGE)) (SETF (UCODE-IMAGE-MODULE-LOADED IMAGE) (CDR (UCODE-IMAGE-MODULE-POINTS IMAGE))))) (SETF (UCODE-IMAGE-MODULE-POINTS IMAGE) (CDR (UCODE-IMAGE-MODULE-POINTS IMAGE)))) ;UA-DEFMIC is called during readin phase for incremental assemblies. ;Dont do anything immediately, since the world might bomb ; out before you really win. Just buffers it up for later processing. ;OPCODE is value to appear in MISC instructions. The entry point is stored in ; MICRO-CODE-SYMBOL-AREA at this location less 200. The OPCODE can also be ; NIL, in which case the system will assign the next available one. ; Note, however, that there is a possible screw in using NIL in conjunction ; with a QINTCMP property and compiling QFASL files to disk: the compiled file ; might be loaded at a later time when the actual OPCODE was different and lose. (DEFUN UA-DEFMIC ("E NAME OPCODE ARGLIST LISP-FUNCTION-P &OPTIONAL (NO-QINTCMP NIL)) (SETQ CURRENT-ASSEMBLY-DEFMICS (CONS (LIST NAME OPCODE ARGLIST LISP-FUNCTION-P NO-QINTCMP) CURRENT-ASSEMBLY-DEFMICS))) ;This called on buffered stuff from UA:ASSEMBLE just before assembly actually done. ;ASSEMBLER-STATE environment has been established. (DEFUN UA-DO-DEFMIC (NAME OPCODE ARGLIST LISP-FUNCTION-P NO-QINTCMP &AUX FUNCTION-NAME INSTRUCTION-NAME MICRO-CODE-ENTRY-INDEX NARGS) (COND ((ATOM NAME) (SETQ FUNCTION-NAME NAME INSTRUCTION-NAME NAME)) ((SETQ FUNCTION-NAME (CAR NAME) INSTRUCTION-NAME (CDR NAME)))) (COND ((NULL OPCODE) (SETQ OPCODE (COND ((GET INSTRUCTION-NAME 'QLVAL)) (T (UA-ASSIGN-MICRO-ENTRY NAME)))))) (PUTPROP INSTRUCTION-NAME OPCODE 'QLVAL) (SETQ NARGS (ARGS-INFO-FROM-LAMBDA-LIST ARGLIST)) (COND ((OR (BIT-TEST NARGS %ARG-DESC-QUOTED-REST) (BIT-TEST NARGS %ARG-DESC-EVALED-REST) (BIT-TEST NARGS %ARG-DESC-INTERPRETED) (BIT-TEST NARGS %ARG-DESC-FEF-QUOTE-HAIR) (AND (NOT NO-QINTCMP) (NOT (= (LDB %%ARG-DESC-MAX-ARGS NARGS) (LDB %%ARG-DESC-MIN-ARGS NARGS))))) (FERROR NIL "~%The arglist of the function ~s, ~s, is too hairy to microcompile. ARGS-INFO = ~O~%" NAME ARGLIST NARGS))) (COND (LISP-FUNCTION-P (SETQ MICRO-CODE-ENTRY-INDEX (ALLOCATE-MICRO-CODE-ENTRY-SLOT FUNCTION-NAME)) (STORE (SYSTEM:MICRO-CODE-ENTRY-ARGLIST-AREA MICRO-CODE-ENTRY-INDEX) ARGLIST) (STORE (SYSTEM:MICRO-CODE-ENTRY-ARGS-INFO-AREA MICRO-CODE-ENTRY-INDEX) NARGS) )) (COND ((NOT NO-QINTCMP) (PUTPROP INSTRUCTION-NAME (LDB %%ARG-DESC-MAX-ARGS NARGS) 'QINTCMP) (OR (EQ FUNCTION-NAME INSTRUCTION-NAME) (PUTPROP FUNCTION-NAME (LDB %%ARG-DESC-MAX-ARGS NARGS) 'QINTCMP)))) ) (DEFUN UA-ASSIGN-MICRO-ENTRY (NAME) NAME (COND ((= CURRENT-ASSEMBLY-HIGHEST-MISC-ENTRY 0) (FERROR NIL "lossage assigning micro-entries"))) (SETQ CURRENT-ASSEMBLY-HIGHEST-MISC-ENTRY (1+ CURRENT-ASSEMBLY-HIGHEST-MISC-ENTRY))) ;Do this when module containing DEFMIC is actually loaded (DEFUN UA-LOAD-DEFMIC (NAME OPCODE ARGLIST LISP-FUNCTION-P NO-QINTCMP &AUX FUNCTION-NAME INSTRUCTION-NAME MICRO-CODE-ENTRY-INDEX MICRO-CODE-SYMBOL-INDEX) NO-QINTCMP ARGLIST (COND ((ATOM NAME) (SETQ FUNCTION-NAME NAME INSTRUCTION-NAME NAME)) ((SETQ FUNCTION-NAME (CAR NAME) INSTRUCTION-NAME (CDR NAME)))) (COND ((NULL (SETQ OPCODE (GET INSTRUCTION-NAME 'QLVAL))) (FERROR NIL "OPCODE not assigned ~s" NAME))) (SETQ MICRO-CODE-SYMBOL-INDEX (- OPCODE 200)) (COND (LISP-FUNCTION-P (LET ((FS (FSYMEVAL FUNCTION-NAME))) (COND ((NOT (= (%DATA-TYPE FS) DTP-U-ENTRY)) (FERROR NIL "Function cell of ~s not DTP-U-ENTRY" FUNCTION-NAME)) (T (SETQ MICRO-CODE-ENTRY-INDEX (%POINTER FS))))))) (LET ((PREV (AR-1 (FUNCTION SYSTEM:MICRO-CODE-ENTRY-AREA) MICRO-CODE-ENTRY-INDEX))) (COND ((AND PREV (NOT (FIXP PREV))) (PUTPROP FUNCTION-NAME PREV 'DEFINITION-BEFORE-MICROCODED)))) (AS-1 MICRO-CODE-SYMBOL-INDEX (FUNCTION SYSTEM:MICRO-CODE-ENTRY-AREA) MICRO-CODE-ENTRY-INDEX) ) (DEFUN ALLOCATE-MICRO-CODE-ENTRY-SLOT (FCTN) (LET ((FC (COND ((FBOUNDP FCTN) (FSYMEVAL FCTN))))) (COND ((= (%DATA-TYPE FC) DTP-U-ENTRY) (%POINTER FC)) (T (LET ((ARGS-INFO (COND (FC (ARGS-INFO FC)))) ;DO THIS FIRST SO AS NOT TO GET (ARGLIST (COND (FC (ARGLIST FC))))) ; THINGS OUT OF PHASE IF ERROR. (LET ((IDX (ARRAY-PUSH (FUNCTION SYSTEM:MICRO-CODE-ENTRY-NAME-AREA) FCTN))) (COND ((NULL IDX) (FERROR NIL "MICRO-CODE-ENTRY-ARRAYS FULL")) (T (ARRAY-PUSH (FUNCTION SYSTEM:MICRO-CODE-ENTRY-AREA) FC) (ARRAY-PUSH (FUNCTION SYSTEM:MICRO-CODE-ENTRY-ARGS-INFO-AREA) ARGS-INFO) (ARRAY-PUSH (FUNCTION SYSTEM:MICRO-CODE-ENTRY-ARGLIST-AREA) ARGLIST) (SETQ NUMBER-MICRO-ENTRIES (SETQ SYSTEM:%NUMBER-OF-MICRO-ENTRIES (1+ IDX))) (FSET FCTN (%MAKE-POINTER DTP-U-ENTRY IDX)) IDX)))))))) ;Call this to repair the damage if a reboot (either warm or cold) is done. (DEFUN UA-REBOOT (&OPTIONAL (IMAGE CURRENT-UCODE-IMAGE)) (DO () ((NULL (CDR (UCODE-IMAGE-MODULE-LOADED IMAGE)))) (UNLOAD-MODULE (CAR (UCODE-IMAGE-MODULE-LOADED IMAGE)))) (LOAD-MODULE NIL IMAGE)) ;NIL as module means load all (DEFUN LOAD-MODULE (&OPTIONAL MODULE (IMAGE CURRENT-UCODE-IMAGE)) (PROG (TEM AS) (COND ((NULL MODULE) (DOLIST (M (REVERSE (LDIFF (UCODE-IMAGE-MODULE-POINTS IMAGE) (UCODE-IMAGE-MODULE-LOADED IMAGE)))) (LOAD-MODULE M IMAGE)) (RETURN T))) (COND ((NOT (EQ %MICROCODE-VERSION-NUMBER (UCODE-IMAGE-VERSION IMAGE))) (FERROR NIL "WRONG UCODE VERSION, MACHINE ~S, IMAGE ~S" %MICROCODE-VERSION-NUMBER (UCODE-IMAGE-VERSION IMAGE)))) (SETQ AS (UCODE-MODULE-ASSEMBLER-STATE MODULE)) (LET ((ARRAY (UCODE-IMAGE-CONTROL-MEMORY-ARRAY IMAGE)) (RANGE-LIST (GET-FROM-ALTERNATING-LIST AS 'I-MEMORY-RANGE-LIST))) (DOLIST (R RANGE-LIST) (DO ((ADR (CAR R) (1+ ADR)) (CNT (CADR R) (1- CNT))) ((<= CNT 0)) (COND ((NOT (NULL (SETQ TEM (AR-1 ARRAY ADR)))) (SI:%WRITE-INTERNAL-PROCESSOR-MEMORIES 1 ADR (%LOGDPB (LDB 4020 TEM) 1020 (LDB 3010 TEM)) ;ASSURE NO BIGNUMS, AND (%LOGDPB (LDB 1020 TEM) 1020 (LDB 0010 TEM)))))))) ;SIGN BIT LOSSAGE (LET ((ARRAY (UCODE-IMAGE-DISPATCH-MEMORY-ARRAY IMAGE)) (RANGE-LIST (GET-FROM-ALTERNATING-LIST AS 'D-MEMORY-RANGE-LIST))) (DOLIST (R RANGE-LIST) (DO ((ADR (CAR R) (1+ ADR)) (CNT (CADR R) (1- CNT))) ((<= CNT 0)) (COND ((NOT (NULL (SETQ TEM (AR-1 ARRAY ADR)))) (SI:%WRITE-INTERNAL-PROCESSOR-MEMORIES 2 ADR ;D (%LOGDPB (LDB 4020 TEM) 1020 (LDB 3010 TEM)) (%LOGDPB (LDB 1020 TEM) 1020 (LDB 0010 TEM)))))))) (LET ((ARRAY (UCODE-IMAGE-A-MEMORY-ARRAY IMAGE)) (RANGE-LIST (GET-FROM-ALTERNATING-LIST AS 'A-MEMORY-RANGE-LIST))) (DOLIST (R RANGE-LIST) (DO ((ADR (CAR R) (1+ ADR)) (CNT (CADR R) (1- CNT)) (IN-IMAGE (UCODE-IMAGE-A-MEMORY-LOCATION-IN-IMAGE IMAGE))) ((<= CNT 0)) (COND ((NOT (NULL (SETQ TEM (AR-1 ARRAY ADR)))) (AS-1 1 IN-IMAGE ADR) (SI:%WRITE-INTERNAL-PROCESSOR-MEMORIES 4 ADR ;A/M (%LOGDPB (LDB 4020 TEM) 1020 (LDB 3010 TEM)) (%LOGDPB (LDB 1020 TEM) 1020 (LDB 0010 TEM)))))))) (DOLIST (E (GET-FROM-ALTERNATING-LIST AS 'MICRO-ENTRIES)) (LET ((IDX (COND ((EQ (CAR E) 'MISC-INST-ENTRY) (- (GET (CADR E) 'QLVAL) 200)) (T (FERROR NIL "Unknown micro-entry ~s" E))))) (AS-1 (CADDR E) (FUNCTION SYSTEM:MICRO-CODE-SYMBOL-AREA) IDX) (AS-1 (CADDR E) (UCODE-IMAGE-ENTRY-POINTS-ARRAY IMAGE) IDX))) (COND (NUMBER-MICRO-ENTRIES ;in case machine has been warm booted. (SETQ SYSTEM:%NUMBER-OF-MICRO-ENTRIES NUMBER-MICRO-ENTRIES))) (DOLIST (X (UCODE-MODULE-DEFMICS MODULE)) (APPLY (FUNCTION UA-LOAD-DEFMIC) X)) (DO ((L (UCODE-IMAGE-MODULE-POINTS IMAGE) (CDR L)) (C (UCODE-IMAGE-MODULE-LOADED IMAGE))) ((OR (NULL L) (EQ (CDR L) C)) (COND ((AND L (EQ (CAR L) MODULE)) (SETF (UCODE-IMAGE-MODULE-LOADED IMAGE) L))))) )) ;Load into the other machine with CC. (DEFUN CC-LOAD-MODULE (&OPTIONAL MODULE (IMAGE CC-UCODE-IMAGE)) (PROG (TEM AS) (COND ((NULL MODULE) (DOLIST (M (REVERSE (LDIFF (UCODE-IMAGE-MODULE-POINTS IMAGE) (UCODE-IMAGE-MODULE-LOADED IMAGE)))) (CC-LOAD-MODULE M IMAGE)) (RETURN T))) (COND ((NOT (EQ %MICROCODE-VERSION-NUMBER (UCODE-IMAGE-VERSION IMAGE))) (FERROR NIL "WRONG UCODE VERSION, MACHINE ~S, IMAGE ~S" %MICROCODE-VERSION-NUMBER (UCODE-IMAGE-VERSION IMAGE)))) (SETQ AS (UCODE-MODULE-ASSEMBLER-STATE MODULE)) (LET ((ARRAY (UCODE-IMAGE-CONTROL-MEMORY-ARRAY IMAGE)) (RANGE-LIST (GET-FROM-ALTERNATING-LIST AS 'I-MEMORY-RANGE-LIST))) (DOLIST (R RANGE-LIST) (DO ((ADR (CAR R) (1+ ADR)) (CNT (CADR R) (1- CNT))) ((<= CNT 0)) (COND ((NOT (NULL (SETQ TEM (AR-1 ARRAY ADR)))) (CADR:CC-R-D (+ ADR RACMO) TEM)))))) ;SIGN BIT LOSSAGE (LET ((ARRAY (UCODE-IMAGE-DISPATCH-MEMORY-ARRAY IMAGE)) (RANGE-LIST (GET-FROM-ALTERNATING-LIST AS 'D-MEMORY-RANGE-LIST))) (DOLIST (R RANGE-LIST) (DO ((ADR (CAR R) (1+ ADR)) (CNT (CADR R) (1- CNT))) ((<= CNT 0)) (COND ((NOT (NULL (SETQ TEM (AR-1 ARRAY ADR)))) (CADR:CC-R-D (+ ADR RADMO) TEM)))))) (LET ((ARRAY (UCODE-IMAGE-A-MEMORY-ARRAY IMAGE)) (RANGE-LIST (GET-FROM-ALTERNATING-LIST AS 'A-MEMORY-RANGE-LIST))) (DOLIST (R RANGE-LIST) (DO ((ADR (CAR R) (1+ ADR)) (CNT (CADR R) (1- CNT)) (IN-IMAGE (UCODE-IMAGE-A-MEMORY-LOCATION-IN-IMAGE IMAGE))) ((<= CNT 0)) (COND ((NOT (NULL (SETQ TEM (AR-1 ARRAY ADR)))) (AS-1 1 IN-IMAGE ADR) (CADR:CC-R-D (+ ADR RAAMO) TEM)))))) (DOLIST (E (GET-FROM-ALTERNATING-LIST AS 'MICRO-ENTRIES)) (LET ((IDX (COND ((EQ (CAR E) 'MISC-INST-ENTRY) (- (GET (CADR E) 'QLVAL) 200)) (T (FERROR NIL "Unknown micro-entry ~s" E))))) ; (AS-1 (CADDR E) (FUNCTION SYSTEM:MICRO-CODE-SYMBOL-AREA) IDX) (AS-1 (CADDR E) (UCODE-IMAGE-ENTRY-POINTS-ARRAY IMAGE) IDX))) ; (DOLIST (X (UCODE-MODULE-DEFMICS MODULE)) ; (APPLY (FUNCTION UA-LOAD-DEFMIC) X)) )) (DEFUN BLAST-WITH-IMAGE (&OPTIONAL (IMAGE CURRENT-UCODE-IMAGE) &AUX TEM) (COND ((NOT (EQ %MICROCODE-VERSION-NUMBER (UCODE-IMAGE-VERSION IMAGE))) (FERROR NIL "WRONG UCODE VERSION, MACHINE ~S, IMAGE ~S" %MICROCODE-VERSION-NUMBER (UCODE-IMAGE-VERSION IMAGE)))) (LET ((ARRAY (UCODE-IMAGE-CONTROL-MEMORY-ARRAY IMAGE))) (DO ((ADR 0 (1+ ADR)) (LIM (ARRAY-LENGTH ARRAY))) ((< ADR LIM)) (COND ((NOT (NULL (SETQ TEM (AR-1 ARRAY ADR)))) (SI:%WRITE-INTERNAL-PROCESSOR-MEMORIES 1 ADR (%LOGDPB (LDB 4020 TEM) 1020 (LDB 3010 TEM)) ;ASSURE NO BIGNUMS, AND (%LOGDPB (LDB 1020 TEM) 1020 (LDB 0010 TEM))))))) ;SIGN BIT LOSSAGE (LET ((ARRAY (UCODE-IMAGE-DISPATCH-MEMORY-ARRAY IMAGE))) (DO ((ADR 0 (1+ ADR)) (LIM (ARRAY-LENGTH ARRAY))) ((< ADR LIM)) (COND ((NOT (NULL (SETQ TEM (AR-1 ARRAY ADR)))) (SI:%WRITE-INTERNAL-PROCESSOR-MEMORIES 2 ADR ;D (%LOGDPB (LDB 4020 TEM) 1020 (LDB 3010 TEM)) (%LOGDPB (LDB 1020 TEM) 1020 (LDB 0010 TEM))))))) ; (LET ((ARRAY (UCODE-IMAGE-A-MEMORY-ARRAY IMAGE))) ; (DO ((ADR 0 (1+ ADR)) ; (LIM (ARRAY-LENGTH ARRAY)) ; (IN-IMAGE (UCODE-IMAGE-A-MEMORY-LOCATION-IN-IMAGE IMAGE))) ;HMM REALLY LOSES. ; ((< ADR LIM)) ; (COND ((AND (NOT (ZEROP (AR-1 IN-IMAGE ADR))) ; (NOT (NULL (SETQ TEM (AR-1 ARRAY ADR))))) ; (SI:%WRITE-INTERNAL-PROCESSOR-MEMORIES 4 ADR ;A/M ; (%LOGDPB (LDB 4020 TEM) 1020 (LDB 3010 TEM)) ; (%LOGDPB (LDB 1020 TEM) 1020 (LDB 0010 TEM))))))) ) (DEFUN MERGE-MEM-ARRAY (ARRAYP RA-ORG IMAGE) (PROG (IDX LIM TEM) (SETQ IDX 0) (SETQ LIM (CADR (ARRAYDIMS ARRAYP))) L (COND ((NOT (< IDX LIM)) (RETURN T)) ((SETQ TEM (AR-1 ARRAYP IDX)) (CC-IMAGE-REGISTER-DEPOSIT IMAGE NIL (+ RA-ORG IDX) TEM T))) (SETQ IDX (1+ IDX)) (GO L))) (DEFUN READ-UCODE-VERSION (&OPTIONAL (VERSION %MICROCODE-VERSION-NUMBER) (IMAGE CURRENT-UCODE-IMAGE)) (PKG-BIND "UA" (COND ((NULL (BOUNDP 'SI:RACMO)) (READFILE "LMCONS;CADREG >"))) ; (READ-SYM-FILE VERSION IMAGE) (UCODE-IMAGE-STORE-ASSEMBLER-STATE (GET-UCADR-STATE-LIST VERSION) IMAGE) (READ-MCR-FILE VERSION IMAGE) (READ-TABLE-FILE VERSION IMAGE) (LET ((MODULE (MAKE-UCODE-MODULE))) (SETF (UCODE-MODULE-IMAGE MODULE) IMAGE) (SETF (UCODE-MODULE-SOURCE MODULE) (FORMAT NIL "LISPM1;UCADR ~D" VERSION)) (SETF (UCODE-MODULE-ASSEMBLER-STATE MODULE) (UCODE-IMAGE-ASSEMBLER-STATE IMAGE)) (SETF (UCODE-MODULE-ENTRY-POINTS-INDEX MODULE) (ARRAY-LEADER (UCODE-IMAGE-ENTRY-POINTS-ARRAY IMAGE) 0)) (SETF (UCODE-MODULE-TABLE MODULE) (UCODE-IMAGE-TABLE-LOADED IMAGE)) (SETF (UCODE-MODULE-SYM-ADR MODULE) (ARRAY-LEADER (UCODE-IMAGE-SYMBOL-ARRAY IMAGE) 0)) (SETF (UCODE-IMAGE-MODULE-LOADED IMAGE) (SETF (UCODE-IMAGE-MODULE-POINTS IMAGE) (LIST MODULE))))) ) (DEFUN READ-TABLE-FILE (VERSION &OPTIONAL (IMAGE CURRENT-UCODE-IMAGE)) (PROG (STREAM FILENAME TABLE) (SETQ FILENAME (COND ((NUMBERP VERSION) (FORMAT NIL "LISPM1;UCADR ~DTBL" VERSION)) (T VERSION))) (SETQ STREAM (OPEN FILENAME '(READ))) (READ STREAM) ;FLUSH (SETQ MICROCODE-ERROR-TABLE-VERSION-NUMBER ..) (SETQ TABLE (READ STREAM)) ;GOBBLE (SETQ MICROCODE-ERROR-TABLE '(...)) (SETF (UCODE-IMAGE-TABLE-LOADED IMAGE) (CADR (CADDR TABLE))) ;FLUSH SETQ, QUOTE, ETC. (CLOSE STREAM))) (DEFUN GET-UCADR-STATE-LIST (&OPTIONAL (VERSION %MICROCODE-VERSION-NUMBER)) (PROG (STREAM ITEM FILENAME ASSEMBLER-STATE) (SETQ FILENAME (FORMAT NIL "LISPM1;UCADR ~DSYM" VERSION)) (SETQ STREAM (OPEN FILENAME '(READ))) COM0 (COND ((NOT (< (SETQ ITEM (READ STREAM)) 0)) (GO COM0))) COM (COND ((= ITEM -1) (GO FIN)) ((= ITEM -2) (GO FIN)) ;ignore ((= ITEM -4) (SETQ ASSEMBLER-STATE (READ STREAM)) (GO FIN)) (T (FERROR NIL "~O is not a valid block header" ITEM))) FIN (CLOSE STREAM) (RETURN ASSEMBLER-STATE))) ;dont do this by default any more (DEFUN READ-SYM-FILE (VERSION &OPTIONAL (IMAGE CURRENT-UCODE-IMAGE)) (PROG (STREAM ITEM SYM TYPE VAL SYM-ARRAY FILENAME) (SETQ FILENAME (COND ((NUMBERP VERSION) (FORMAT NIL "LISPM1;UCADR ~DSYM" VERSION)) (T VERSION))) (SETQ STREAM (OPEN FILENAME '(READ))) COM0 (COND ((NOT (< (SETQ ITEM (READ-SIGNED-OCTAL-FIXNUM STREAM)) 0)) (GO COM0))) COM (COND ((= ITEM -1) (GO FIN)) ((= ITEM -2) (GO SYMLOD)) ((= ITEM -4) (UCODE-IMAGE-STORE-ASSEMBLER-STATE (READ STREAM) IMAGE) (GO COM0)) (T (FERROR NIL "~O is not a valid block header" ITEM))) FIN (CLOSE STREAM) (RETURN IMAGE) SYMLOD (SETQ SYM-ARRAY (UCODE-IMAGE-SYMBOL-ARRAY IMAGE)) (STORE-ARRAY-LEADER 0 SYM-ARRAY 0) SYML1 (SETQ SYM (READ STREAM)) (COND ((AND (NUMBERP SYM) (< SYM 0)) (SETQ ITEM SYM) (GO COM))) (SETQ TYPE (READ STREAM) VAL (READ STREAM)) (ARRAY-PUSH-EXTEND SYM-ARRAY SYM 1000) (ARRAY-PUSH-EXTEND SYM-ARRAY TYPE 1000) (ARRAY-PUSH-EXTEND SYM-ARRAY VAL 1000) (GO SYML1) )) (DEFUN UA-DEFINE-SYMS (&OPTIONAL (IMAGE CURRENT-UCODE-IMAGE)) ;CAUSE SYMBOLS TO EXIST. TEMPORARILY CONS-LAP-SYM. (LET ((SYM-ARRAY (UCODE-IMAGE-SYMBOL-ARRAY IMAGE))) (COND (T ; (NULL (GET (AR-1 SYM-ARRAY 0) 'CONS-LAP-SYM)) ;SAVE TIME IF IT LOOKS LIKE ITS THERE (DO ((ADR 0 (+ ADR 3)) (LIM (ARRAY-ACTIVE-LENGTH SYM-ARRAY))) ((>= ADR LIM)) (LET ((SYM (AR-1 SYM-ARRAY ADR)) (TYPE (AR-1 SYM-ARRAY (1+ ADR))) (VAL (AR-1 SYM-ARRAY (+ 2 ADR)))) (PUTPROP SYM (COND ((EQ TYPE 'NUMBER) VAL) (T (LIST TYPE (CONS 'FIELD (COND ((EQ TYPE 'I-MEM) (LIST 'JUMP-ADDRESS-MULTIPLIER VAL)) ((EQ TYPE 'A-MEM) (LIST 'A-SOURCE-MULTIPLIER VAL)) ((EQ TYPE 'M-MEM) (LIST 'M-SOURCE-MULTIPLIER VAL)) ((EQ TYPE 'D-MEM) (LIST 'DISPATCH-ADDRESS-MULTIPLIER VAL)) (T (FERROR NIL "~%The symbol ~S has bad type ~S. Its value is ~S" SYM TYPE VAL)) ))))) 'CONS-LAP-SYM))))))) (DEFUN READ-MCR-FILE (VERSION &OPTIONAL (IMAGE CURRENT-UCODE-IMAGE)) (PROG (STREAM HCODE LCODE HADR LADR HCOUNT LCOUNT HD LD FILENAME UDSP-NBLKS UDSP-RELBLK) (SETQ FILENAME (COND ((NUMBERP VERSION) (FORMAT NIL "LISPM1;UCADR ~DMCR" VERSION)) (T VERSION))) (SETF (UCODE-IMAGE-VERSION IMAGE) VERSION) (SETQ STREAM (OPEN FILENAME '(:IN :BLOCK :FIXNUM :BYTE-SIZE 16. ))) L0 (SETQ HCODE (FUNCALL STREAM 'TYI) LCODE (FUNCALL STREAM 'TYI)) (COND ((OR (NOT (ZEROP HCODE)) (< LCODE 0) (> LCODE 5)) (FERROR NIL "BAD CODE HCODE=~O LCODE=~O" HCODE LCODE))) (SETQ HADR (FUNCALL STREAM 'TYI) LADR (FUNCALL STREAM 'TYI)) (SETQ HCOUNT (FUNCALL STREAM 'TYI) LCOUNT (FUNCALL STREAM 'TYI)) (COND ((OR (NOT (ZEROP HADR)) (NOT (ZEROP HCOUNT))) (FERROR NIL "BAD HEADER SA ~O,~O COUNT ~O,~O" HADR LADR HCOUNT LCOUNT))) (COND ((ZEROP LCODE) (COND (UDSP-NBLKS (FUNCALL STREAM ':SET-POINTER (* 2 UDSP-RELBLK SI:PAGE-SIZE)) (DO ((UE-ARRAY (UCODE-IMAGE-ENTRY-POINTS-ARRAY IMAGE)) (ADR 0 (1+ ADR)) (FIN (* UDSP-NBLKS SI:PAGE-SIZE))) ((= ADR FIN)) (AS-1 (DPB (FUNCALL STREAM 'TYI) 2020 (DPB (FUNCALL STREAM 'TYI) 0020 0)) UE-ARRAY ADR)))) (CLOSE STREAM) (RETURN IMAGE)) ((= LCODE 1) (GO LI)) ;I-MEM ((= LCODE 2) (GO LD)) ;D-MEM ((= LCODE 3) ;IGNORE MAIN MEMORY LOAD (SETQ UDSP-NBLKS LADR) (SETQ UDSP-RELBLK LCOUNT) (SETQ HD (FUNCALL STREAM 'TYI) LD (FUNCALL STREAM 'TYI)) ;PHYS MEM ADR (GO L0)) ((= LCODE 4) (GO LA))) ;A-MEM LD (COND ((< (SETQ LCOUNT (1- LCOUNT)) 0) (GO L0))) (AS-1 (DPB (FUNCALL STREAM 'TYI) 1020 (DPB (FUNCALL STREAM 'TYI) 0020 0)) (UCODE-IMAGE-DISPATCH-MEMORY-ARRAY IMAGE) LADR) (SETQ LADR (1+ LADR)) (GO LD) LA (COND ((< (SETQ LCOUNT (1- LCOUNT)) 0) (GO L0))) (AS-1 (DPB (FUNCALL STREAM 'TYI) 2020 (DPB (FUNCALL STREAM 'TYI) 0020 0)) (UCODE-IMAGE-A-MEMORY-ARRAY IMAGE) LADR) (AS-1 1 (UCODE-IMAGE-A-MEMORY-LOCATION-IN-IMAGE IMAGE) LADR) (SETQ LADR (1+ LADR)) (GO LA) LI (COND ((< (SETQ LCOUNT (1- LCOUNT)) 0) (GO L0))) (AS-1 (DPB (FUNCALL STREAM 'TYI) 6020 (DPB (FUNCALL STREAM 'TYI) 4020 (DPB (FUNCALL STREAM 'TYI) 2020 (DPB (FUNCALL STREAM 'TYI) 0020 0)))) (UCODE-IMAGE-CONTROL-MEMORY-ARRAY IMAGE) LADR) (SETQ LADR (1+ LADR)) (GO LI) )) ;--- ; FOLLOWING CODE ADOPTED FROM CC. EVENTUALLY, IT WOULD BE NICE FOR CC ;TO BE ABLE TO OPERATE INTERCHANGABLY ON EITHER A UCODE-IMAGE, UCODE-STATE ;IN THE HOME MACHINE, OR ON A REMOTE MACHINE VIA THE DEBUGGING INTERFACE. ;DUE TO LACK OF BIGNUMS AND LOTS OF REASONS, WE RE NOT REALLY TRYING TO ;ACCOMPLISH THIS NOW. HOWEVER, WE ARE TRYING TO KEEP THE STRUCTURE OF THINGS ;AS MUCH CC LIKE AS POSSIBLE TO SIMPLIFY DOING THIS IN THE FUTURE. (DEFUN CC-IMAGE-PRINT-REG-ADR-CONTENTS (IMAGE STATE ADR) (PROG (DATA) ; (SETQ RANGE (CC-IMAGE-FIND-REG-ADR-RANGE ADR)) (SETQ DATA (CC-IMAGE-REGISTER-EXAMINE IMAGE STATE ADR)) ; (COND ((MEMQ RANGE '(C CIB)) ; (CC-TYPE-OUT DATA CC-UINST-DESC T)) ; ((MEMQ RANGE '(U OPC)) ; (CC-IMAGE-PRINT-ADDRESS (+ DATA SI:RACMO)) ; (PRINC '/ )) ; ((EQ RANGE 'RAIDR) ; (CC-IMAGE-PRINT-ADDRESS DATA) (PRINC '/ )) ; (T (PRIN1-THEN-SPACE DATA))) (PRIN1-THEN-SPACE DATA) (PRINC '/ / ))) (DEFUN CC-IMAGE-REGISTER-EXAMINE (IMAGE STATE ADR) (MULTIPLE-VALUE-BIND (RANGE IDX) (CC-IMAGE-FIND-REG-ADR-RANGE ADR) (COND ((EQ RANGE 'C) (AR-1 (UCODE-IMAGE-CONTROL-MEMORY-ARRAY IMAGE) IDX)) ((EQ RANGE 'D) (AR-1 (UCODE-IMAGE-DISPATCH-MEMORY-ARRAY IMAGE) IDX)) ((EQ RANGE 'P) (AR-1 (UCODE-STATE-PDL-BUFFER-ARRAY STATE) IDX)) ((EQ RANGE '/1) (AR-1 (UCODE-STATE-LEVEL-1-MAP STATE) IDX)) ((EQ RANGE '/2) (AR-1 (UCODE-STATE-LEVEL-2-MAP STATE) IDX)) ((EQ RANGE 'A) (AR-1 (COND ((ZEROP (AR-1 (UCODE-IMAGE-A-MEMORY-LOCATION-IN-IMAGE IMAGE) IDX)) (UCODE-IMAGE-A-MEMORY-ARRAY IMAGE)) (T (UCODE-STATE-A-MEMORY-ARRAY STATE))) IDX)) ((EQ RANGE 'U) (AR-1 (UCODE-STATE-MICRO-STACK-ARRAY STATE) IDX)) (T (FERROR NIL "~S is not a valid range for ~O" RANGE ADR))) )) (DEFUN CC-IMAGE-REGISTER-DEPOSIT (IMAGE STATE ADR DATA &OPTIONAL IMAGE-FLAG) (MULTIPLE-VALUE-BIND (RANGE IDX) (CC-IMAGE-FIND-REG-ADR-RANGE ADR) (COND ((EQ RANGE 'C) (AS-1 DATA (UCODE-IMAGE-CONTROL-MEMORY-ARRAY IMAGE) IDX)) ((EQ RANGE 'D) (AS-1 DATA (UCODE-IMAGE-DISPATCH-MEMORY-ARRAY IMAGE) IDX)) ((EQ RANGE 'P) (AS-1 DATA (UCODE-STATE-PDL-BUFFER-ARRAY STATE) IDX)) ((EQ RANGE '/1) (AS-1 DATA (UCODE-STATE-LEVEL-1-MAP STATE) IDX)) ((EQ RANGE '/2) (AS-1 DATA (UCODE-STATE-LEVEL-2-MAP STATE) IDX)) ((EQ RANGE 'A) (AS-1 (COND (IMAGE-FLAG 0) (T 1)) (UCODE-IMAGE-A-MEMORY-LOCATION-IN-IMAGE IMAGE) IDX) (AS-1 DATA (COND (IMAGE-FLAG (UCODE-IMAGE-A-MEMORY-ARRAY IMAGE)) (T (UCODE-STATE-A-MEMORY-ARRAY STATE))) IDX)) ((EQ RANGE 'U) (AS-1 DATA (UCODE-STATE-MICRO-STACK-ARRAY STATE) IDX)) (T (FERROR NIL "~S is not a valid range for ~O" RANGE ADR))) )) ;RETURNS SYMBOL TYPE AND VALUE OR NIL, NOT ASSQ LIST ELEMENT AS IN CC. (DEFUN CC-IMAGE-EVAL-SYM (IMAGE SYM) (PROG (SYMTAB IDX LIM) (SETQ SYMTAB (UCODE-IMAGE-SYMBOL-ARRAY IMAGE)) (SETQ IDX 0 LIM (ARRAY-LEADER SYMTAB 0)) L (COND ((NOT (< IDX LIM)) (RETURN NIL)) ((EQ SYM (AR-1 SYMTAB IDX)) (RETURN (AR-1 SYMTAB (1+ IDX)) (AR-1 SYMTAB (+ IDX 2))))) (SETQ IDX (+ IDX 3)) (GO L))) ;RETURNS: NIL IF NONE FOUND CLOSER THAN 20 TO DESIRED REG ADR ; SYMBOL IF EXACT MATCH FOUND ; (LIST SYMBOL DIFFERENCE) IF ONE FOUND CLOSER THAN 20 ;**** (DEFUN CC-IMAGE-FIND-CLOSEST-SYM (IMAGE REG-ADR) (PROG (BSF BSF-VAL VAL SYMTAB IDX LIM) (SETQ BSF-VAL 0) (SETQ SYMTAB (UCODE-IMAGE-SYMBOL-ARRAY IMAGE)) (SETQ IDX 0 LIM (ARRAY-LEADER SYMTAB 0)) L (COND ((NOT (< IDX LIM)) (GO X)) ((= REG-ADR (SETQ VAL (AR-1 SYMTAB (1+ IDX)))) (RETURN (AR-1 SYMTAB IDX))) ((AND (> VAL BSF-VAL) (< VAL REG-ADR)) (SETQ BSF (AR-1 SYMTAB IDX)) (SETQ BSF-VAL VAL))) (SETQ IDX (+ IDX 3)) (GO L) X (COND ((OR (NULL BSF) (> (- REG-ADR BSF-VAL) 20)) (RETURN NIL)) (T (RETURN (LIST BSF (- REG-ADR BSF-VAL))))) )) (DEFUN CC-IMAGE-FIND-REG-ADR-RANGE (REG-ADR) (PROG NIL (COND ((< REG-ADR SI:RACMO) (RETURN 'TOO-LOW 0)) ((< REG-ADR SI:RACME) (RETURN 'C (- REG-ADR SI:RACMO))) ((< REG-ADR SI:RADME) (RETURN 'D (- REG-ADR SI:RACME))) ((< REG-ADR SI:RAPBE) (RETURN 'P (- REG-ADR SI:RADME))) ((< REG-ADR SI:RAM1E) (RETURN '/1 (- REG-ADR SI:RAPBE))) ((< REG-ADR SI:RAM2E) (RETURN '/2 (- REG-ADR SI:RAM1E))) ((< REG-ADR SI:RAAME) (RETURN 'A (- REG-ADR SI:RAM2E))) ((< REG-ADR SI:RAUSE) (RETURN 'U (- REG-ADR SI:RAAME))) ((< REG-ADR SI:RAMME) (RETURN 'A (- REG-ADR SI:RAUSE))) ;M-MEM (T (RETURN 'TOO-HIGH 0))) ; ((< REG-ADR SI:RAFSE) 'FS) ; ((< REG-ADR SI:RAFDE) 'FD) ; ((< REG-ADR SI:RARGE) 'CC) ; ((< REG-ADR SI:RACSWE) 'CSW) ; ((< REG-ADR SI:RARDRE) 'RAIDR) ; ((< REG-ADR SI:RACIBE) 'CIB) ; ((< REG-ADR SI:RAOPCE) 'OPC) ; ((< REG-ADR CC-REG-ADR-PHYS-MEM-OFFSET) 'TOO-HIGH) ; ((< REG-ADR CC-REG-ADR-VIRT-MEM-OFFSET) 'PHYSICAL) ; (T 'VIRTUAL) )) (DEFPROP C SI:RACMO CC-LOWEST-ADR) (DEFPROP D SI:RADMO CC-LOWEST-ADR) (DEFPROP P SI:RAPBO CC-LOWEST-ADR) (DEFPROP /1 SI:RAM1O CC-LOWEST-ADR) (DEFPROP /2 SI:RAM2O CC-LOWEST-ADR) (DEFPROP A SI:RAAMO CC-LOWEST-ADR) (DEFPROP U SI:RAUSO CC-LOWEST-ADR) (DEFPROP M SI:RAMMO CC-LOWEST-ADR) ;(DEFPROP FS SI:RAFSO CC-LOWEST-ADR) ;(DEFPROP FD SI:RAFDO CC-LOWEST-ADR) ;(DEFPROP CC SI:RARGO CC-LOWEST-ADR) ;(DEFPROP CSW SI:RACSWO CC-LOWEST-ADR) ;(DEFPROP RAIDR SI:RARDRO CC-LOWEST-ADR) ;(DEFPROP CIB SI:RACIBO CC-LOWEST-ADR) ;(DEFPROP OPC SI:RAOPCO CC-LOWEST-ADR) (DEFPROP C C CC-@-NAME) (DEFPROP D D CC-@-NAME) (DEFPROP P P CC-@-NAME) (DEFPROP /1 1 CC-@-NAME) (DEFPROP /2 2 CC-@-NAME) (DEFPROP A A CC-@-NAME) (DEFPROP U U CC-@-NAME) (DEFUN CC-IMAGE-PRINT-ADDRESS (IMAGE REG-ADR) (PROG (RANGE-NAME RANGE-BASE @-NAME TEM) (SETQ RANGE-NAME (CC-IMAGE-FIND-REG-ADR-RANGE REG-ADR)) (COND ((AND (SETQ TEM (CC-IMAGE-FIND-CLOSEST-SYM IMAGE REG-ADR)) (OR (ATOM TEM) (EQ RANGE-NAME 'C) (EQ RANGE-NAME 'D))) (PRIN1 TEM)) ((SETQ RANGE-BASE (GET RANGE-NAME 'CC-LOWEST-ADR)) (COND ((SETQ @-NAME (GET RANGE-NAME 'CC-@-NAME)) (PRIN1 (- REG-ADR (SYMEVAL RANGE-BASE))) (PRINC '@) (PRIN1 @-NAME)) (T (PRIN1 RANGE-NAME) (PRINC '/ ) (PRIN1 (- REG-ADR (SYMEVAL RANGE-BASE)))))) (T (PRIN1 REG-ADR))) X (RETURN T) ))