4,887,235 233 234 ;Multiplier input registers here named after the busses they are ;on, rather than the TRW names which are reversed. ;Loading the multiplier is not done with ASSIGN, mainly because ;of the weirdnecs that it loads frcm the -high- half of Ybus. ;Writing into the X register. signed or unsigned (defmicro write-mpy-x (x-source &optional signed) (paralyze (get-to-xbus x-source) `(microinstruction spec multiply magic ,(if signed 6 2)))) ;Writing into the Y register, signed or unsigned (defmicro write-mpy-y-from-high (y-source &optional signed) (paralyze (get-to-ybus y-source) `(microinstruction spec multiply magic ,(if signed 11 1)))) ;;; Main memory (defatomicro memory-data (microdata abus (microinstruction abus memory-data amem-read-addr (bus-address)))) ;The virtual-address register (defatomicro vma (vma-kludge)) ;For temporary memory control, cannot read back hardware VMA, so keep copy in A-memory (defareg-at-loc a-vma-copy 2501) ;Location kludgily known about... (defmicro vma-kludge () (if (eq *machine-version* 'proto) 'a-vma-copy '(microdata abus (microinstruction abus vma)))) ;Also there is hair in ASSIGN ;Start a memory cycle ;Do this the cycle after loading vma ;The modes argument says what kind of cycle. It is not used on the proto machine; ;the kind of cycle is determined by what you do in parallel with this. ;See the microcompiler documentation for the modes. (defmicro start-memory (&rest modes) (selectq *machine-version* ((sim proto) '(microinstruction trap-enables (map-miss) mem start-cycle)) ((tmc tmc5) (let ((direction nil) (physical-address nil) (spec nil) (dma-device nil) (block nil) (ifetch nil) (inst nil)) (loop until (null modes) as mode = (pop modes) do (selectp code ((read write) (if (null direction) (setq direction mode) (if spec (retch "Conflicting spec funcs: ~S and ~S" spec 'check-write-access)) (setq direction 'read spec 'check-write-access))) (physical (if (null modes) (retch "No physical address specified")) (setq physical-address (pop modes))) (dma (if (null (cdr modes)) (retch "No DMA card//subdevice specified")) (if spec (retch "'Conflicting spec funcs: ~S and ~S" spec mode)) (setq dma-device (list (pop modes) (pop modes)) spec 'dma)) ((inhibit-page-tags address-phtc) (if spec (retch Conflicting spec funcs: ~S and ~S spec mode)) (setq spec mode)) (block (setp block t)) (instruction-fetch (setq ifetch t)) (otherwise (retch "~S unrecognized START-MEMORY code" mode)))) (or direction (retch "Neither READ nor WRITE specified in START-MEMORY")) (cond ((not physical-address)) ((null spec) (setq spec 'addr-from-abus)) ((not (memq spec '(dma inhibit-page-tags))) (retch "Conflicting spec funcs: ~S and ~5" spec 'addr-from-abus))) (and block spec (retch "Combination of block mode and special memory features is illegal")) (setq inst (list 'mem (if (not block) (if (eq direction 'read) 'start-read 'start-write) (if (eq direction 'read) 'block-read 'block-write)))) (cond (ifetch (if spec (retch "Conflicting spec funcs: ~S and ~S" spec 'ifu-control)) (setq inst 4,887,235 235 236 (if (eq *machine-version* 'tmc) (list* 'spec 'ifu-control 'magic 0 'magic-mask 1 inst) (list* 'spec 'ifu-control 'magic 2 'magic-mask 3 inst)))) (spec (setq inst (lists 'spec spec inst)))) (setq inst (cons 'microinstruction inst)) (if dma-device (setq inst `(parallel (select-lbus-dev ,(car dma-device) ,(cadr dma-device)) ,inst))) (if physical-address ;; Need extra time when taKing addr from amem, and cannot use addr-calc ;; hardware, in order to get enough address-to-clock setup time (let ((addr (get-to-abus physical-address))) (or (atom (get addr 'amem-read-addr)) (eq (car (get addr 'amem-read-addr)) 'constant) (retch "~S is too slow as a source of physical address" physical-address)) (setq inst `(parallel ,addr ,inst (microinstruction speed slow-first-half)))) ;; Need extra time when using the map cache because it isn't fast enough (setq inst `(parallel ,inst (microinstruction speed slow-first-half)))) inst)) (otherwise (retch "Don't know how to do START-MEMORY on this machine.")))) (defmicro nop () (microinctruction)) ;Use this at a subroutine which is jumped to with the memory going, ;to defeat bogus error messages when you know what uou're doing. ;Note: this doesn't distinnuish between IO and emulator tasks. (defmicro declare-memory-timing (&rest states) (dolist (state states) (or (memq (if (and (listp state) (eq (car state) 'next) (= (length state) 2)) (cadr state) state) '(active-cycle data-cycle)) (retch "~S illegal memory timing state: use ACTIVE-CYCLE or DATA-CYCLE" state))) `(microinstruction declare-memory-timing ,states)) (defmicro declare-speed (speed) (or (memq speed '(slow slow-first-half slow-second-half very-slow)) (retch "~S not a legal speed name" speed)) `(microinstruction speed ,speed)) ;Allowed transport types are: ; DATA all invisibles, error if null or header ; WRITE all invisibles, no transport, error if header ; CDR only header/body forward invisible, no transport, error if header ; BIND evcp not invisible, error if header ; BIND-WRITE evcp not invisible, no transport, error if header ; HEADER header-forward invisible, transport, other tuoes error ; HEADER-OR-DATA same as HEADER but no error if non-header type ; does not actually transport any normal-data word it sees ; NO-TRAP ? - the A machine uses this in one place, I don't think we need it ; SCAV no invisible pointers, no errors. transport ; ;For transport, the type map is: ; Regular pointer => COND (enables oldspace check) ; Invisible-pointer => COND, TRAP-2 (oldspace overrides invisible) ; Bad type => TRAP-0 (e.g. unbound-variable error) (defmicro transport (&optional (transport-type 'data)) (or (memq transport-type '(data write cdr bind bind-write header header-or-data scav)) (retch "~S illegal transport-type" transport-type)) (paralyze (get-to-abus 'memory-data) `(microinstruction type-map ,(type-map-for-transport transport-type) trap-enables (transport) error-table (bad-data-type)))) (defconst transporter-type-map-alist nil) ;Note that this function has to be modified if *data-types* is changed! ;--- dtp-monitor-forward not put in yet (defun type-map-for-transport (transport-type #Q &aux #Q (default-cons-area working-storage-area)) ;Sigh.... (or (cdr (assq transport-type transporter-type-map-alist)) (let ((invisible-pointer-types (selectq transport-type ((data write) '(dtp-external-value-cell-pointer dtp-one-q-forward dtp-header-forward dtp-body-forward)) ((bind bind-write) '(dtp-one-q-forward dtp-header-forward dtp-body-forward)) ((cdr) '(dtp-header-forward dtp-body-forward)) ((header header-or-data) '(dtp-header-forward)) ((scav) nil))) (error-types (selectq transport-type ((data) '(dtp-null dtp-11 dtp-13 dtp-14 dtp-15 dtp-16 dtp-1 dtp-header-p dtp-header-i dtp-monitor-forward dtp-72 dtp-73 dtp-74 dtp-75 dtp-76 dtp-77)) 4,887,235 237 238 ((cdr) '(dtp-11 dtp-13 dtp-14 dtp-15 dtp-16 dtp-17 dtp-header-p dtp-header-i dtp-monitor-forward dtp-72 dtp-73 dtp-74 dtp-75 dtp-76 dtp-77)) ((write bind bind-write) '(dtp-header-p dtp-header-i dtp-11 dtp-13 dtp-14 dtp-1S dtp-16 dtp-17 dtp-monitor-forward dtp-72 dtp-73 dtp-74 dtp-75 dtp-75 dtp-77)) ((header) (types-other-than '(dtp-header-forward dtp-header-p dtp-header-i))) ((header-or-data scav) '(dtp-11 dtp-13 dtp-14 dtp-15 dtp-16 dtp-17 dtp-72 dtp-73 dtp-74 dtp-75 dtp-76 dtp-77)))) (regular-pointer-types (selectq transport-type ((write bind-write cdr header header-or-data) nil) ((data) '(dtp-nil dtp-symbol dtp-extended-number dtp-locative dtp-list dtp-compiled-function dtp-array dtp-closure dtp-instance dtp-even-pc dtp-odd-pc)) ((bind) '(dtp-null dtp-nil dtp-symbol dtp-extended-number dtp-locative dtp-external-value-cell-pointer dtp-list dtp-compiled-function dtp-array dtp-closure dtp-instance dtp-even-pc dtp-odd-pc)) ((scav) '(dtp-null dtp-nil dtp-symbol dtp-extended-number dtp-locative dtp-external-value-cell-pointer dtp-one-q-forward dtp-header-forward dtp-list dtp-compiled-function dtp-array dtp-closure dtp-instance dtp-header-p dtp-even-pc dtp-odd-pc))))) (iet ((map (nconc (and invisible-pointer-types `((,invisible-pointer-types pointer trap-2))) (and regular-pointer-types `((,regular-pointer-types pointer))) (and error-types `((,error-types trap-0)))))) (push (cons transport-type map) transporter-type-map-alist) map)))) F:>lmach>ucode>uu.lisp.429 ;;; Jumping all over the place ;Note that the condition field is also relevant to next-microinstruction ;selection. The skip-true-sequence and skir-false-sequence fields get boiled ;down to the next-microaddress field, with placing of microinstructions at ;suitable addresses and duplication of microinstructions in some cases. ;Note that IF and DISPATCH may be used at the same time, and in this case the ;IF's skip modifies the NPC rather than the next-microaddress field. The ;microassembler has to be aware of this and put instructions in the appropriate ;places. (defmicro call (ucode) `(microinstruction sequencer pushj jump-sequence ,ucode)) (defmicro jump (ucode) `(microinstruction next-sequence ,ucode)) (defmicro return () `(microinstruction sequencer popj)) (defmicro return-skip (pred) (let* ((test (microexpand pred)) (skip (cond ((neq (car test) 'microcondition) (retch "~S expanded into ~S, not a valid microcondition" pred test)) ((memq (cadr test) valid-skip-conditions) (cadr test)) (t (retch "~S invalid skip condition in ~S" (cadr test) pred))))) (or (eq (caddr test) 'true) (retch "~S is a reversed-sense skip condition, illegal in RETURN-SKIP" pred)) (paralyze (cadddr test) `(microinstruction condition ,skip sequencer popj return-skip t)))) ;This makes the return address of a call be the pending dispatch. ;This is just for the simulator. The rec~ hardware can't avoid doing this. (defmicro call-and-dispatch-upon-return (ucode) `(microinstruction sequencer pushj-return-dispatch jump-sequence ,ucode)) (defmicro call-and-return-to (ucode return-to) `(microinstruction sequencer pushj jump-sequence ,ucode next-sequence ,return-to)) (defmicro call-and-return-skip (ucode normal-return skip-return) `(microinstruction sequencer pushj jump-sequence ,ucode return-true-sequence ,skip-return return-false-sequence ,normal-return)) ;Call in combination with a skip (defmicro call-select (condition true-subroutine false-subroutine) `(parallel (microinstruction sequencer pushj) (if ,condition ,(if (atom true-subroutine) `(goto ,true-subroutine) true-subroutine) ,(if (atom false-subroutine) `(goto ,false-subroutine) false-subroutine)))) 4,887,235 239 240 ;Combination of that and call-and-return-to (defmicro call-select-and-return-to (condition true-subroutine false-subroutine return-to) `(parallel (microinstruction sequencer pushj next-sequence ,return-to) (if ,condition ,(if (atom true-subroutine) `(goto ,true-subroutine) true-subroutine) ,(if (atom false-subroutine) `(goto ,false-subroutine) false-subroutine)))) ;Really ifu & no popj. Hardware makes the distinction when stack is empty. (defmicro next-instruction () '(microinstruction sequencer next-instruction)) (defmicro increment-pc () (selectq *machine-version* ((tmc) '(microinstruction spec ifu-control magic 1 magic-mask 1)) ((tmc5) '(microinstruction spec ifu-control magic 3 magic-mask 3)) (otherwise (retch "I don't know how to do this except on TMC machine")))) ;:; Temporary until real IFU ;;; Takes 2 cycles and can't be done in parallel with other things ;:; Use a subroutine to save microcode space (defmicro increment-fake-pc () '(call-select (odd-pc? pc) (parallel (assign pc (set-type (1+ po) dtp-even-pc)) (return)) (parallel (assign pc (set-type pc dtp-odd-pc)) (return)))) ;;; Add an offset to the PC. using the special format of offset used in branch instructions (defmicro pc-add (base-pc magic-offset) `(parallel (+ ,base-pc (rotate ,magic-offset 37)) (microinstruction force-obus<33-32> 3))) ;dtp-even-pc/dtp-odd-pc ;;; Add an offset to the PC, using an ordinary number as the offset ;;; offset can be one argument, or two arguments (the second being 1) ;;; Uses b-temp-3 (but either argument being b-temp-3 is okay) (defmicro pc-plus-number (base-pc &rest offset) `(sequential (assign b-temp-3 (+ (halfword-pc ,base-pc) . ,offset)) (word-pc b-temp-3))) ;This micro assigns to the PC and does whatever else is necessary to make the ;IFU happy, For now, just next-instruction. For the TMC IFU, will start a ;2-word read and wait for the appropriate length of time, then NEXT-INSTRUCTIDN, ;Other code to be done in parallel with the memory access may be supplied. (defmicro set-pc (new-pc &optional other-code) (selectq *machine-version* ((sim proto) (if other-code `(sequential (assign pc ,new-pc) (parallel ,other-code (next-instruction))) `(parallel (assign pc ,new-pc) (next-instruction)))) ((tmc) (if (null other-code) ;This instruction is completed, PC may advance `(parallel (assign pc ,new-pc) (clear-stack-adjustment) (jump ifu-empty-trap-1)) `(sequential (assign vma ,new-pc) ;Check for page fault first because the TMC (start-memory read) ;does not have a senarate EPC (assign pc ,new-pc) ;Now set PC (and VMA again) for real (parallel ,other-code (start-memory read block instruction-fetch)) (start-memory read block instruction-fetch) ;Active(1) (nop) ;Data(1) Active(2) (next-instruction)))) ;Decode(l),Data(2) ((tmc5) `(sequential (assign pc ,new-pc) ;Assign to DPC and VMA (leave EPC alone) (parallel ,other-code (start-memory read block instruction-fetch)) (start-memory read block instruction-fetch) ;Active(1) (nop) ;Data(1),Active(2) (next-instruction))) ;Decode(1),Data(2) (otherwise (retch "~S machine version not handled yet" *machine-version*)))) ;Set the PC at which execution will restart if this instruction is pclsred ;No instruction fetch is done since that PC will normally not be used ;The PC must be at an even halfword (usually it is an escape function) ;ACCEPT-RESTART-PC must be done in the next cycle (or some later cycle before it's needed) (defmicro restart-pc (new-pc) (selectq *machine-version* ((sim proto tmc) ;PC will get backed up if pclsr, so advance it `(assign pc (odd-pc ,new-pc))) ((tmc5 ifu) `(assign pc (even-pc-except-30-through-28 ,new-pc))) (otherwise (retch "~S machine version not handled yet" *machine-version*)))) 4,887,235 241 242 ;Accept the restart PC into the EPC from the DPC/IPC, and increment the DPC/IPC past it. (defmicro accept-restart-pc () (selectq *machine-version* ((sim proto tmc) nil) ((tmc5 ifu) '(increment-pc)) (otherwise (retch "~S machine version not handled yet" *machine-version*)))) (defmicro lisp (form) `(microinstruction escape-to-lisp ,form)) (defmicro signal-error (&rest code) `(error-if true . ,code)) ;(trap-if (signal-error )) but saves an instruction (defmicro error-if (condition &rest error-code) `(parallel (trap-if ,condition (goto error-trap)) (microinstruction error-table ,(copylist error-code)))) (defmicro signal-error-no-restore-stack (&rest code) `(error-no-restore-stack-if true . ,code)) (defmicro error-no-restore-stack-if (condition &rest error-code) `(parallel (trap-if ,condition (goto error-trap-no-restore-stack)) (microinstruction error-table ,(copylist error-code)))) ;'field' somehow selects a field ;It can either be a microdata on the alub, using normal field selection, or ;it can be a microdata on the alub which selects one of several special abus ;fields, or it can me one of the following special forms: ; (cdr-code ) ; ..more in the future?.. ;The value of the dispatch field in tho resulting code is the symbol alub or ; one of several special symbols for the special dispatches. ;'clauses' are something like selectq clauses, car of each one is a ; list of symbolic or numeric values, cdr of each one is a microcode ; sequence or a defucode tag, as with IF. (defmicro dispatch-after-next (field &rest clauses) (multiple-value-bind (ufield magic code symbolic-cues-alist) (expand-dispatch-field field) `(parallel ,code (microinstruction dispatch ,ufield magic ,magic magic-mask 7 dispatch-table (,ufield . ,(expand-dispatch-clauses clauses symbolic-cues-alist)))))) (defmicro dispatch-after-this (operand this &body clauses) `(sequential (dispatch-after-next ,operand ,@clauses) (parallel ,this (take-dispatch)))) (defun expand-dispatch-field (field &aux efield code tem table alist) ;returns dispatch field, magic number field, other microcode, symbolic-cues-alist (setq alist (get (or (get (if (symbolp field) field (car field)) 'enumerated-type-name) (and (listp field) (eq (car field) 'ldp-field) (get (caddr field) 'enumerated-type-name))) 'enumerated-type-codes)) (setq efield (microexpand field)) (setq table '((3404 . abus<31-28>) ;2 array registers (2604 . abus<25-22>) ;3 array-dispatch (2204 . abus<21-18>) ;4 array-type (0003 . abus<2-0>))) ;5 function calling (cond ((atom efield) (retch "Garbage dispatch field: ~S == ~S" field efield)) ;;Special forms ((eq (car efield) 'cdr-code) (values 'cdr-code 1 (net-to-abus (cadr efield)) alist)) ((not (and (eq (car efield) 'microdata) (eq (cadr efield) 'alub))) (retch "Garbage dispatch field: ~S == ~S" field efield)) ;;Special abus fields ((and (fieldp (setq code (caddr efield)) 'ybus 'abus) (setq tem (assoc (dpb (- 40 (second (get code 'byte-func))) 0605 (third (get code 'byte-func))) table))) (values (cdr tem) (+ (find-position-in-list tem table) 2) (modify-code code '((ybus nil) (byte-func nil))) alist)) ;;Normal field extraction through alub (t (values 'alub 0 code alist)))) (associate-dispatch-cues cdr-code *cdr-codes*) ;Car of clause is list of selectors ;Cdr of clause is body of a sequence, or goto special form like if (defun expand-dispatch-clauses (clauses symbolic-cues-alist) (mapcar #'(lambda (clause) 4,887,235 243 244 (list (expand-dispatch-cues (car clause) symbolic-cues-alist) (cond ((and (= (length clause) 2) (not (atom (cadr clause))) (eq (caadr clause) 'goto)) (cadadr clause)) (t (microexpand `(sequential . ,(cdr clause))))))) clauses)) (defun expand-dispatch-cues (cues symbolic-cues-alist) (if (eq cues 'otherwise) cues (loop for cue in cues collect (cond ((numberp cue) cue) ((cdr (assq cue symbolic-cues-alist))) (t (retch "~S unrecognized dispatch cue" cue)))))) ;Dispatch only takes effect if this is executed in the following cycle. (defmicro take-dispatch () '(microinstruction sequencer take-dispatch)) ;i.e. CPC from NPC ;;; Definition of closed microroutines (defprop defucode "Microcode routine" si:definition-type-name) (defprop defucode-at-loc defucode zwei:definition-function-spec-type) (defprop definst defucode zwei:definition-function-spec-type) (defprop definst1 defucode zwei:definition-function-spec-type) (declare (*expr microcode-to-lisp-function ;Suppress compiler warning check-microcode)) ;;; defucode defines a microroutine which can either be jumped to, ;;; called, or trapped to. 'name' is aiwaus a symbol. ;;; The body has an implicit 'sequential'. (defmacro defucode (name &body body) (defucode-1 'defucode name body)) ;;; loc is a number which is either a single location or a list of ;;; locations; the first microinstruction will be replicated through ;;; those locations. (defmacro defucode-at-loc (name loc &body body) (defucode-1 'defucode-at-loc name body loc)) ;;; definst defines the microcode to execute a particular macroinstruction ;;; It is very much like defucode but stores the microcode in a different table ;;; Put in the (next-instruction) yourself if you need it, or use definst1 (defmacro definst (name format-and-attributes &body body) (validate-definst name format-and-attributes) (defucode-1 'definst name body (if (atom format-and-attributes) format-and-attributes (car format-and-attributes)))) ;;; Like definst but defines a 1-cycle instruction. All clauses of the body ;;; are done in parallel, and the (next-instruction) is put in automatically. (defmacro definst1 (name format-and-attributes &body body) `(definst ,name ,format-and-attributes (parallel ,@body (next-instruction)))) (defun defucode-1 (flavor name body &optional data) (let* ((*backtrace* `((,flavor ,name))) (microcode (microexpand `(sequential . ,body)))) (setq *top-level-code* microcode) (check-microcode microcode name) `(progn 'compile ,@(if (eq data '10-bit-immediate-operand) (loop for i from 0 below 4 nconc (defucode-2 flavor name microcode data i)) (defucode-2 flavor name microcode data)) ',name))) (defun defucode-2 (flavor name microcode data &optional (offset 0) &aux (iname name)) (and (plusp offset) (setq iname (fintern "~A-~D" name offset))) (let ((lisp-name (fintern '|~A-LISPMICROCODE| iname))) `(,@(cond ((eq *machine-version* 'sim) (nconc (if (eq flavor 'definst) (ncons `(defprop ,iname ,lisp-name micro-executor))) (ncons (microcode-to-lisp-function lisp-name microcode #Q iname))))) ,(let ((address-constraint (selectq flavor (definst (let ((loc (instruction-dispatch-loc name))) (+ loc (* offset 4)))) (defucode-at-loc data) (otherwise nil)))) `(put-ucode ',iname ',microcode ',(if (eq *machine-version* 'sim) lisp-name (assemble-microinstruction-plist iname microcode address-constraint offset)) ',*machine-version*))))) (defun put-ucode (tag microcode micrel machine-version) (or (si:record-source-file-name tag 'defucode) (ferror nil "Sorry, I already did most of it")) 4,887,235 245 246 (let ((ucode (assq machine-version *ucode-alist-alist*)) tem) (or ucode (push (setq ucode (cons machine-version nil)) *ucode-alist-alist*)) (cond ((setq tem (assq tag (cdr ucode))) (setf (cadr tem) microcode) (setf (caddr tem) micrel)) (t (push (list tag microcode micrel) (cdr ucode))))) (setq *need-to-link* t) tag) ;Due to universal opcodes, this works for both normal and format-3 instructions (defun instruction-dispatch-loc (name) (lsh (car (get name instruction-data)) 2)) ;;; Reading in of the opcode definitions file ;XXXbrad - line missing $%#%$# (defmacro defopcode (name opcode format &rest attributes) `(defopcode1 ',name ',opcode ',format ',attributes)) (defun defopcode1 (name opcode format attributes) (or (<= 0 opcode 377) ;Temporary 8-bit opcodes (<= 1000 opcode 1377) ;But do have 8 bits of format-3 also (ferror nil "Opcode ~O for instruction ~S out of range" opcode name)) (or (memq format '(unsigned-immediate-operand signed-immediate-operand address-operand no-operand quick-external-call constant-operand indirect-operand lexical-operand instance-operand microcode-operand unsigned-pc-relative signed-pc-relative constant-pc-relative 10-bit-immediate-operand)) (ferror nil "Format ~S for instruction ~S not recognized" format name)) (and (bit-test 1000 opcode) (neq format 'no-operand) (ferror nil "Instruction ~S with opcode ~O must be NO-OPERAND, not ~S" name opcode format)) (loop for attr in attributes do (or (memq attr '(needs-stack smashes-stack branch-predict stop-ifu)) (and (listp attr) (eq (car attr) 'function) (<= 3 (length attr) 4)) (and (listp attr) (eq (car attr) 'operand) (= (length attr) 2)) (ferror nil "Attribute ~S for instruction ~S not recognized" attr name))) (putprop name (list* opcode format attributes) 'instruction-data) (if (eq format '10-bit-immediate-operand) (loop for i from 1 to 3 do (aset name *opcode-table* (+ opcode i)))) (aset name *opcode-table* opcode)) (defun validate-definst (name format-and-attributes) (let ((format (if (atom format-and-attributes) format-and-attributes (car format-and-attributes))) (attributes (if (atom format-and-attributes) nil (cdr format-and-attributes))) (data (get name 'instruction-data))) (cond ((null data) (ferror nil "~S not defined in OPDEFS file" name)) ((neq format (cadr data)) (ferror nil "~S in format ~S disagrees with OPDEFS file, which says ~S" name format (cadr data))) ;Check attributes that affect the microcode. I think IFU ones don't. ((loop for attrib in '(needs-stack smashes-stack) thereis (neq (not (memq attrib attributes)) (not (memq attrib (cddr data))))) (ferror nil "Attributes for ~S disagrees with OPDEFS file" name))))) ;;; Reading in of the system definitions files (defun sysconstant-eval-fun (type value) (selectq type (nil (or (get value 'sysconstant) (car (qet value 'byte-field)) ;PPSS (ferror nil "~S has no DEFSYSCONSTANT nor DEFSYSBYTE value" value))) (dcfsysbyte-limit-value (1+ (byte-field-ones value))) (defsysbyte-ones (byte-field-ones value)) (defstorage-size (get value 'defstorage-size)) (otherwise (ferror nil "Do not understand ~S for ~S" type value)))) (defun byte-field-ones (ref) (dpb -1 (ldb 0006 (car (or (get ref 'byte-field) (ferror nil "~S has no DEFSYSBYTE value" ref)))) 0)) (defmacro defsysconstant (name form) (setq form (llc:defsysconstant-eval form #'sysconstant-eval-fun)) `(putprop ',name ',form 'sysconstant)) (defmacro defsysbyte (name n-bits bits-over) (setq n-bits (llc:defsysconstant-eval n-bits #'sysconstant-eval-fun)) (setq bits-over (llc:defsysconstant-eval bits-over #'sysconstant-eval-fun)) `(eval-when (compile load eval) (putprop ',name `(,(byte-numbers-to-ppss n-bits bits-over)) 'byte-field))) 4,887,235 247 248 ;;; (defenumerated list-name (names...) [starting-value] [increment] [endingvalue]) ;;; starting-value defaults 0, increment to 1 ;;; If endingvalue is supplied, it is error-checked (defmacro defenumerated (list-name code-list &optional (start 0) (increment 1) end) ;XXXbrad not convinced '=' below is right, maybe 'approx equal'? (and end (= (length code-list) (// (- end start) increment)) (ferror nil "~S has ~S codes where ~S are required" list-name (length code-list) (// (- end start) increment))) `(progn 'compile (defconst ,list-name ',code-list) (defprop ,list-name ,(loop for code in code-list and prev = 0 then code as value from start by increment unless (eq code prev) ;kludge for data-types collect `(,code . ,value)) enumerated-type-codes) ;; sysconstant properties ore expected by some embedded expressions ,@(loop for code in code-list and prev = 0 then code as value from start by increment unless (eq code prev) ;kludge for data-types collect `(putprop ',code ',value sysconstant)))) ;;; (defstorage (structure-name options...) ;;; fields...) ;;; field = (name n-bits right-hand-bit-number) or a list of subfields. ;;: Omitting the bit specification gets you a word-filling Lisp object. ;;; The top-level fields are really words, the rest are packed bytes. ;:; Options: ;;; BACKWARDS (word offsets count down from 0 instead of up from 0) ;;; ;;; For the microassembler, this defines def-byte-field type accessors ;;; for the defined bytes, and assumes that the microprogrammer takes ;;; care of the word offsets. That will do for the simple structures like arrays. ;;; The offsets do get saved on a word-offset property for possible future use. (local-declare ((special *defstorage-fields*)) (defmacro defstorage ((structure-name . options) . fields) (let ((increment 1) (*defstorage-fields* nil)) (dolist (opt options) (selectq opt (backwards (setq increment -1)) (otherwise (ferror nil "DEFSTORAGE ~S - unrecognized option ~S" structure-name opt)))) ;XXXbrad backquote before progn? `(progn 'compile ,@(loop for field in fields as word from 0 by increment nconc (defstorage-fields field word structure-name)) (defprop ,structure-name ,(length fields) defstorage-size) (defprop ,structure-name ,*defstorage-fields* defstorage-fields)))) (defun defstorage-fields (field word structure-name) (cond ((or (listp field) (null field)) ;until listp is fixed... (if (listp (car field)) (loop for subfield in field nconc (defstorage-fields subfield word structure-name)) (defstorage-field field word structure-name))) (t (defstorage-field (list field) word structure-name)))) (defun defstorage-field (field word structure-name) structure-name ;not used (push (car field) *defstorage-fields*) (list `(defprop ,(car field) ,word word-offset) (and (cdr field) `(def-byte-field ,(car field) ,(cdr field) place)))) ); local-declare ;Extract word offset for a field; use this inside an a-constant or b-constant form (defun field-word-offset (name) (or (get name 'word-offset) (terror nil "~S has no word-offset; probably not defined with DEFSTORAGE" name))) (defvar *escape-function-next-pc-location*) ;Define a-memory locations that are uscd microcode/Lisp communication ;If the microcode wants to initialize these, it can defareg them itself; ;that defareg will get put in the same address. (defmacro define-magic-locations ((block-name . options) &body slots &aux tem) (cond ((setq tem (get (locf options) 'a-memory-address)) ;Interesting to microcode? (if (eq block-name 'microcode-escape-routines) (setq *escape-function-next-pc-location* tem)) `(progn 'compile (defprop ,block-name ,tem a-memory-block-address) . ,(loop for slot in slots as loc upfrom tem collect `(defareg-at-loc ,(if (symbolp slot) slot (intern (format nil "~A-~A" (car slot) (cadr slot)))) ,loc)))) ((setq tem (get (locf options) 'virtual-address)) `(progn 'compile . ,(loop for slot in slots as loc upfrom tem collect `(defprop ,slot ,loc virtual-address)))))) 4,887,235 249 250 ;Define a-memory locations that hold PC's of escape functions ;--- Someone needs to store an initial value for the simulator --- (defmacro define-escape-function (name &body ignore) (let ((a-mem-p t)) (cond ((listp name) (dolist (opt (cdr name)) (selectq opt (no-a-memory (setq a-mem-p nil)) (wired ) (otherwise (ferror nil "Unknown keyword ~S" opt)))) (setq name (car name)))) (and a-mem-p (prog1 `(defareg-at-loc ,(intern (string-append name "ESCAPE-PC")) ,*escape-function-next-pc-location*) (incf *escape-function-next-pc-location*))))) F:>lmach>ucode>UL.LISP.167 ;;; -*- Mode:Lisp; Package:Micro; Base:8; Lowercase:yes -*- ;;; (c) Copyright 1982, Symbolics, Inc. ; Microcode to Lisp translator (makes Lisp that will run with SIM) ;The order of the defconsts is the order of execution in the Lisp. (defconst read-phase-fields '(abus amem-read-addr bbus bmem-read-addr xbus ybus)) (defconst data-path-fields '(alu byte-func)) (defconst force-obus-fields '(force-obus<35-34> force-obus<33-32> force-obus<31-28>)) (defconst trap-phase-fields '(type-map trap-enables trap-sequence arith-trap-dispatch-table)) (defconst operate-phase-fields '(dispatch dispatch-table escape-to-lisp error-table)) (defconst register-write-fields '(write-amem amem-write-addr write-bmem bmem-write-addr write-lbus lbus-dev-addr mem stack-pointer)) (defconst jump-phase-fields '(sequencer jump-sequence next-sequence condition skip-true-sequence skip-false-sequence)) (defconst all-over-the-place-fields '(spec magic magic-mask declare-memory-timing unique speed)) (defvar *microlisp-function-name*) (declare (special *backtrace*)) ;in UU (defvar *microinstruction*) (defun bletch (format-string &rest args) (declare (special args)) ;For accessibility from breakpoint (let #M ((^w nil) (^r nil) (^q nil)) #Q ((msgfiles error-output)) (format msgfiles "~&>>Error: ") (lexpr-funcall #'format msgfiles format-string args) (format msgfiles "~& While compiling microcode to lisp for ~S" *microlisp-function-name*) (format msgfiles "~& Microinstruction: ~S" *microinstruction*) (format msgfiles "~& Microexpand backtrace: ~{~<~% ~2:;~A~>~^, ~}~%" *backtrace*) (break bletch t))) ;selectq with appropriate error processing (defmacro eselectq (valname val &rest clauses) (let ((nil-present (loop for (key) in clauses thereis (or (eq key nil) (and (listp key) (memq nil key)))))) `(selectq ,val ,@clauses ,@(and (not nil-present) '(((nil) nil))) (otherwise (bletch "~S invalid value for ~S" ,val ',valname))))) (defun mksetq (var val) (and val (ncons `(setq ,var ,val)))) (defun mksetq2 (var1 var2 val) (and val (ncons `(setq ,var1 (setq ,var2 ,val))))) 4,887,235 251 252 (defvar *dispatch-destination* nil) #M (declare-special squid) #M (defun eval-at-load-time (form) (cond ((status feature conplr) (list squid form)) (t (eval form)))) #Q (defun eval-at-load-time (form) `',(if (and compiler:qc-file-in-progress (not compiler:qc-file-load-flag)) (cons compiler:eval-at-load-time-marker form) (eval form))) (declare (*expr fieldp)) ;in UU ;Simulation routines for shifter #M (declare (fixnum (rot32 fixnum fixnum) (ash32 fixnum fixnum) (merge32 fixnum fixnum fixnum) (mask32 fixnum)) (special *pc*)) ;in SIM (eval-when (eval compile load) (defun ash32 (value amount) (ash (logand value #.(1- 1_32.)) amount)) ); eval-when (defun rot32 (value amount) (setq amount (logand 37 amount)) #M (dpb value (+ (lsh amount 6) (- 40 amount)) (ldb (+ (lsh (- 40 amount) 6) amount) value)) #Q (logior (logand (ash32 value amount) #.(1- 1 32.)) (logand (ash32 value (- amount 40)) (1- (ash 1 amount))))) (defun mask32 (nbits) (1- (ash 1 nbits))) (defun merge32 (shifted mask unshifted) (logior (logand mask shifted) (logand (lognot mask) unshifted))) ;More simulation routines. These are used instead of open-codinq ;things so that ncomplr doesn't expand my code by a factor of 100 #M (declare (muzzled t) ;Don't give me a hard time about haulong (load 'sim) ;Get certain macros needed below (fixnus (address-add-fp fixnum) (address-add-sp fixnum) (address-add-macrocode) (aref-amem fixnum) (aref-bmem fixnum) (aref bmem-360) (16-bit-sign-extend fixnum)) (notype (aset-amem fixnum fixnum) (aset-bmem fixnum fixnum) (aset-bmem-360 fixnum) (setq-vma fixnum) (setq-fp fixnum) (setq-sp fixnum) (carry28 fixnum fixnum fixnum) (carry32 fixnum fixnum fixnum))) (declare (special *frame-pointer* *stack-pointer* *xbas* *pc* *vma* *pma* *instruction* *a-memory* *b-memory* *byte-r* *byte-s* *type-map* *multiply-x* *multiply-y* *last-error-table-entry-seen*)) #M (declare (*lexpr address-add) (*expr even-instruction odd-instruction instruction-opcode instruction-unsigned-immediate instruction-signed-immediate pc-add instruction-baseno instruction-offset stack-address set-pma-from-vma) (fixnum (even-instruction fixnum) (odd-instruction fixnum) (instruction-opcode) (instruction-unsigned-immediate) (instruction-signed-immediate) (pc-add fixnum fixnum) (instruction-baseno) (instruction-offset) (stack-address fixnum) (address-add notype fixnum))) (defun address-add-fp (offset) (address-add '*frame-pointer* offset)) (defun address-add-sp (offset) (address-add '*stack-pointer* offset)) (defun address-add-xb (offset) (address-add '*xbas* offset))