4,887,235 113 114 ;This is the format-3 version, others will exist, too. (definstruction car-stack no-operand (or (data-type? (top-of-stack) dtp-list dtp-locative) (take-pre-trap *argtyp-trap-handler*)) (newtop (mem-read (top-of-stack)))) (definstruction cdr-stack no-operand (or (data-type? (top-of-stack) dtp-list dtp-locative) (take-pre-trap *argtyp-trap-handler*)) (mem-read (top-of-stack)) (cond ((data-type? (top-of-stack) dtp-locative) ;delayed test for speed (newtop *mem*)) ((cdr-code? *mem* cdr-normal) (newtop (mem-read (1+ *vma*)))) ((cdr-code? *mem* cdr-next) (newtop (1+ *vma*))) ((car-code? *mem* cdr-nil) (newtop *nil*)) (t (ferror nil "Where did this bogus cdr code come from?")))) (definstruction times-stack no-operand (or (and (data-type? (top-of-stack) dtp-fix) (data-type? (next-on-stack) dtp-fix)) (take-arithmetic-trap 'add 'stack)) ;;--- over flow checking (pop2push (set-type (times (unbox-fixnum (top-of-stack)) (unbox-fixnum (next-on-stack))) dtp-fix))) (definstruction branch-zerop signed-pc-relative (or (data-type? (top-of-stack) dtp-fix) (take-arithmetic-1arg-trap 'zerop 'stack)) ;--- or something (if (zerop (fixnum-field (top-of-stack))) (setq *pc* (pc-add *pc* (instruction-signed-immediate)))) (popval)) (definstruction branch-not-zerop signed-pc-relative (or (data-type? (top-of-stack) dtp-fix) (take-arithmetic-1arg-trap 'zerop 'stack)) ;--- or something (if (not (zerop (fixnum-field (top-of-stack)))) (setq *pc* (pc-add *pc* (instruction-signed-immediate)))) (popval)) (definstruction return-stack no-operand ; pseudo format 3 (common-return-processing (top-of-stack))) (definstruction popj-no-value no-operand (or (data-type? (top-of-stack) dtp-even-pc dtp-odd-pc) (ferror nil "pop to non-PC")) (setq *pc* (popval))) #.` ;heh, heh (progn 'compile .,(loop for nargs from 0 to 5 nconc (loop for value-disposition in '(effect value return multiple-value) collect `(definstruction ,(intern (format nil "CALL-~A~D" value-disposition nargs)) indirect-operand (common-call-processing ',value-disposition ',nargs (get-elink-operand)))))) (defun get-elink-operand () (mem-read (mem-read (- (frame-function) (instruction-unsigned-immediate) 1) 'no-evcp))) (declare (special *stack-buffer-overflow-handler*)) (defun common-call-processing (value-disposition nargs fcn) ;;Various pushes that are really overlapped with those two memory cycles (pushval (set-type *frame-pointer* dtp-locative)) (pushval-with-cdr (dpb (find-position-in-list value-disposition '(effect value return multiple-value)) 4202 ;cdr field (set-type (- *stack-pointer* (+ nargs 2)) dtp-locative))) (pushval *pc*) (pushval (set-type nargs dtp-fix)) ;initial frame-misc-data (pushval fcn) ;dtp-compiled-function (or (data-type? fcn dtp-compiled-function) (ferror nil "call of non-function")) (setq *pc* (set-type (pointer-field fcn) dtp-odd-pc)) (setq *frame-pointer* (1+ *stack-pointer*)) ;;Check for any Post-function-entry traps that need to go off. ;;Note that this happens -before- copying up the arguments so as to ;;take the stack-buffer-overflow trap with a fixed amount of stuff pushed. ;(stack-limit) has to allow for the additional pushage of up to 4 arguments. ;;When there are more than four to be pushed, additional explicit checking ;;will occur as needed later. (if (greater-pointer *stack-pointer* (stack-limit)) (take-post-trap *stack-buffer-overflow-handler*)) (resume-common-call-processing nargs)) 4,887,235 115 116 ;Comes back in here after taking a stack-buffer-overflow trap. ;Writing it this way doesn't really express the control structure ;in the real machine. See the microcode in the 'stack' file. (defun resume-common-call-processing (nargs) (mem-read *pc*) ;;Now the entry instruction is in *mem*. Perform the fast entry cases. (let ((argdesc (nth (ldb 1004 *mem*) '((0 . 777) (0. 0) (0. 1) (1 . 1) (0 . 2) (1 . 2) (2 . 2) (0 . 3) (1 . 3) (2 . 3) (3 . 3) (0 . 4) (1 . 4) (2 . 4) (3 . 4) (4 . 4))))) (if (or (< nargs (car argdesc)) (> nargs (cdr argdesc))) (ferror nil "wrong number of args")) ;;Advance the pc to skip over unneeded optional-argument initializations (and (not (zerop (ldb 1004 *mem*))) (> nargs (car argdesc)) (setq *pc* (pc-plus-number *pc* (- nargs (car argdesc))))) ;;Now copy up the arguments (loop for argno from 0 below nargs do (pushval (aref *a-memory* (address-add '*frame-pointer* (- argno (+ 5 nargs)))))))) (declare (special *return-continuation* *return-cleanup*)) (defun common-return-processing (value) (setf (temp-1) value) ;--- unsafe pointer check (cond ((not (zerop (frame-cleanup-bits))) (if (data-type? (frame-previous-frame) dtp-nil) ;Really in cleanup fcn (ferror nil "Return out top of SG?")) (pushval (temp-1)) (pushval *return-continuation*) ;PC to return to (take-jump-trap *return-cleanup*))) ;Cleanup then retry (or (data-type? (frame-return-pc) dtp-even-pc dtp-odd-pc) (ferror nil "Return address not a PC")) (setq *pc* (frame-return-pc)) (setq *stack-pointer* (pointer-field (frame-previous-top))) (let ((value-disposition (nth (cdr-field (frame-previous-top)) '(effect value return multiple-value)))) (setq *frame-pointer* (pointer-field (frame-previous-frame))) (selectq value-disposition (effect (setf (top-of-stack) (aref *a-memory* (address-add '*stack-pointer* 0)))) (value (pushval (temp-1))) (return (common-return-processing (temp-1))) (multiple-value (ferror nil "multiple-value ?"))))) ;stacklow is the lowest virtual address that is or will be valid ;in the stack buffer. Adjust the frame-buffer-underflow-bit of each ;fraee in the stack buffer so that the lowest frame has a 1 and the ;rest have a 0. (defun adjust-frame-buffer-underflow-bits (stacklow) (setq stacklow (+ stacklow 5)) ;Frame underhang (pushval *frame-pointer*) ;Going to use true to address int mem (setf (temp-2) *frame-pointer*) (loop until (lesser-pointer *frame-pointer* stacklow) doing (setf (temp-2) *frame-pointer*) (setf (frame-buffer-underflow-bit) 0) (setq *frame-pointer* (pointer-field (frame-previous-frame))) finally (setq *frame-pointer* (temp-2)) (setf (frame-buffer-underflow-bit) 1)) (setq *frame-pointer* (pointer-field (popval)))) );comment ;Do this before loading any macrocode (initialize-main-memory) ;Trapping (comment ;data-source can be unsigned-immed, signed-immed, local, stack, or mem ;In the stack case both operands are on the stack, otherwise the ;first operand is (top-of-stack) and the second is specified by data-source. ;Im not sure how this routine is going to work yet. (defun take-arithmetic-trap (operation data-source) (break arithmetic-trap t)) ;*** ;Another trap routine ;res is 1 bit too big to fit in a fixnum (defun overflow-bignum-create (res stack-adjustment) (setq *stack-pointer* (+ *stack-pointer* stack-adjustment)) (pushval (set-type (abs res) dtp-fix)) ;Truncates to 32 bits (pushval (set-type (if (minusp res) 1 0) dtp-fix)) (take-post-trap *overflow-bignum-create*)) (defun take-pre-trap (pc) (setq *pc* (pc-plus-number *pc* -1)) ;Back out of failed instruction (take-post-trap pc)) (defun take-post-trap (pc) 4,887,235 117 118 (pushval *pc*) ;Save continuation address (on stack?) (take-jump-trap pc)) (defun take-jump-trap (pc) ;When continuation not to be saved (or (numberp pc) (break take-post-trap t)) ;Probably unbound (setq *pc* pc) ;Jump to trap PC (*throw 'pclsr nil)) ;Start first instruction in trap subr ;;; Macrocode trap routines start at location 30000 ;This gets called when a function is being entered and therm is not enough ;space left in the stack buffer. The frame header has been pushed and the ;starting pc is on the stack, however the arguments have not yet been ;copied up into the frame. ;What we have to do is to check for genuine stack overflow. ;dump the lowest stack page out into rain memory, adjust the stack limit ;up oy one page. and restart the call at the argument-copying point. (definstruction check-stack-overflow no-operand ;--- dummy --- (if (greater-pointer (stack-limit) (- 37777 101)) (ferror nil "stack overflow"))) (definstruction setup-stack-dump no-operand (let ((stacklow (logand (- (stack-limit) 1400) (lognot (1- *page-size*))))) (adjust-frame-buffer-underflow-bits (+ stacklow *page-size*)) (pushval (set-type *frame-pointer* dtp-locative)) ;Termporary needed (pushval (set-type (+ stacklow *page-size*) dtp-locative)) (setq *frame-pointer* (pointer-field stacklow)) ;--- Also unmap the page from the stack buffer --- )) (definstruction increase-stack-limit no-operand (incf (stack-limit) *page-size*)) ;--- Also remap the page into the stack buffer ;This is pclsrable because its state is contained in the top ;two words on the stack and in *frame-pointer* ;Only form of pclsr can be a page fault on the very first cycle ;and after that we need to worry about stack-gc traps. (definstruction stack-dump no-operand (loop until (equal-pointer *frame-pointer* (top-of-stack)) doing ;--- really eight words at a time (raw-mem-write *frame-pointer* (aref *a-memory* (address-add '*frame-pointer* 0))) (incf *frame-pointer*)) ;;Now restore state and cleanup stack (popval) (setq *frame-pointer* (pointer-field (popval)))) (definstruction restart-trapped-call no-operand (setq *pc* (popval)) (resume-common-call-processing (frame-number-of-args))) (defmacrocode *stack-buffer-overflow-handler* 30000 ;--- disable interrupts --- (check-stack-overflow) ;--- this is a dummy (setup-stack-dump) (stack-dump) (increase-stack-limit) ;--- enable interrupts --- (restart-trapped-call)) (definstruction setup-stack-load no-operand (pushval (set-type *frame-pointer* dtp-locative)) ;Temporary needed ;; Compute the new lowest virtual address in the stack buffer. ;; What I am doing here is probably not reasonable. (let ((stacklow (logand (- (stack-limit) 2000) (lognot (1- *page-size*))))) (pushval (set-type (+ stacklow *page-size*) dtp-locative)) (setq *frame-pointer* (pointer-field stacklow)))) (definstruction finish-stack-load no-operand ;--- Also map the page into the stack buffer (let ((stacklow (logand (- (stack-limit) 2000) (lognot (1- *page-size*))))) (decf (stack-limit) *page-size*) (adjust-frame-buffer-underflow-bits stacklow))) ;This is pclsrable because its state is contained in the top ;two words on the stack and in *frame-pointer* ;Note that this can pclsr due to transport (definstruction stack-load no-operand (loop until (equal-pointer *frame-pointer* (top-of-stack)) doing ;--- really eight words at a time (aset (mem-read *frame-pointer*) *a-memory* (address-add '*frame-pointer* 0)) (incf *frame-pointer*)) 4,887,235 119 120 ;;Now restore state and cleanup stack (popval) (setq *frame-pointer* (pointer-field (popval)))) (defmacrocode *return-continuation* 30010 (return-stack)) (defmacrocode *return-cleanup* 30020 (setup-stack-load) (stack-load) (finish-stack-load) (popj-no-value)) );comment ;Test routine for instructions with args on the stack and ;possibly an immediate operand (defun try-inst (inst &rest args) (let ((original-sp *stack-pointer*) opcode executor) (lm-assemble 0 (if (atom inst) (list inst) inst)) (loop for arg in args do (pushval arg)) (setq *instruction* (logand (mask 16.) (raw-mem-read 0))) (setq opcode (aref *opcode-table* (instruction-opcode))) (setq executor (get opcode 'micro-executor)) (*catch 'pclsr (funcall executor)) (let ((*frame-pointer* (1+ original-sp))) (pp)) (setq *stack-pointer* original-sp))) F:>lmach>ucode>ua.lisp.140 ;;; -*- Mode:Lisp; Package:Micro; Base:8; Lowercase:yes -*- ;;; (c) Copyright 1982, Symbolics, Inc. ; Microcode definitions for the architecture #M (declare (cond ((not (status feature lmucode)) (setq **compiling-ua** t) (load 'udcls)))) ;Definitions of locations in hardware memories ;Must agree with SIM, which initializes them (reserve-scratchpad-memory 2400 2410 340 345) ;A-memory constants set up from the Lisp memory during booting ; This is now done by >lmach>sysdfl ;(defareg quote-nil nil *nil*) ;Initialize these in the simulator ;(detareg quote-t nil *t*) (defbreg b-quote-nil nil *nil*) ;Initialize these in the simulator (defbreg b-quote-t nil *nil*) ;In the real machine, boot microcode sets them (defbreg-at-loc stack-limit 344) ;Used by function-entry microcode ;--- The simulator knows the numeric addresses of these ;--- or, rather, it knows where they used to be! ;(defareg-at-loc stack-low 2403) ;The lowest virtual address in the stack buffer ;(defareg-at-loc a-stack-overflow 2404) ;stack-limit cannot become > this ;(defareg-at-loc stack-buffer-limit 2405) ;highest virtual address in stack buffer (defareg-at-loc a-temp 2406) (defareg-at-loc a-temp-2 2407) ;2410 and up special purpose temporaries local to particular routines (defatomicro a-zero (a-constant 0)) ;The top-of-stack buffer register on the B side ;Must be in location 360 for the simulator (defbreg-at-loc top-of-stack 360) ;Temporary storage on the B side (defbreg-at-loc b-temp 361) (defbreg-at-loc b-temp-2 362) (defbreg-at-loc b-temp-3 363) ;If this has type dtp-null, it is empty. Otherwise it contains the value ;which should be restored on the top of the stack if we pclsr. ;Note that we rely on the ability to write this in parallel with frame-pointer ;(which doesn't care if we give it a data type of dtp-null; it's only 28 bits). (defareg a-pclsr-top-of-stack (set-type 0 dtp-null)) ;B-VMA is (sometimes) a copy of the VMA register. The transporter does ;not depend on this, but if it changes VMA it also stores the new value ;here. Tne data type is indeterminate. B-VMA exists to make it possible ;to combine the VMA with data from the Abus. (defbreg-at-loc b-vma 364) (defbreg array-register-event-count (set-type 0 dtp-fix)) 4,887,235 121 122 ;;; Note that location 377 gets clobbered by the hardware ;;; Trap support for the real machine ;NOTE WELL: the NPC is not valid during the first microinstruction of a trap ;handler (actually, it always contains the address from which the trap came). ;Thus this first microinstruction must not use anything that compiles into ;an NPL-successor (for example, it must not call a subroutine). ;Micro for the first cycle of a trap handler. ;Finishes the state save by calling for a PUSHJ, which saves ;the original CPC (now in NPC) onto the stack. The original NPC ;is already on the stack. (defmicro trap-save () '(microinstruction sequencer push-npc)) ;Micro for the first cycle of a trap handler, where we aren't going ;to retry the trapped instruction. (defmicro trap-no-save () (if (eq *machine-version* 'proto) '(microinstruction sequencer pop))) ;Micro for the last two cycles of a trap handler. ;Takes arguments of what else to do in those cycles, that ;seeming clearer than throwing a parallel around the sequence. ;We restore the NPC and the CPC by twice popping the control ;stack into NPC. In the second cycle we also use NPC as ;as the source for CPC. Thus the push order is NPC, CPC and ;the pop order is CPC, NPC. (defmicro trap-restore (cycle-1 cycle-2) `(sequential (parallel ,cycle-1 (microinstruction sequencer pop-npc spec npc-magic magic 3 magic-mask 3)) (parallel ,cycle-2 (microinstruction sequencer pop-npc-and-cpc-from-npc spec npc-magic magic 3 magic-mask 3)))) ;The same thing broken down into its two component parts ;Note that trap-save will undo the effect of trap-restore-1, if done ;in the immediately-following cycle (defmicro trap-restore-1 () '(microinstruction sequencer pop-npc spec npc-magic magic 3 magic-mask 3)) (defmicro trap-restore-2 () '(microinstruction sequencer pop-npc-and-cpc-from-npc spec npc-magic magic 3 magic-mask 3)) ;;; Macrocode-trap-taking micros ;Back out of a failed instruction, save pc on stack, and jump to specified pc ;Backing out includes clearing the micro stack ;If the second argument is restore-stack, the main stack-pointer is reset to ;its value at the beginning of the macroinstruction, and a-pclsr-top-of-stack ;is respected. ;If the second argument is preserve-stack, stack-pointer remains the same. (defmicro take-pre-trap (escape-function-name preserve-or-restore-stack) `(,(if (eq preserve-or-restore-stack 'preserve-stack) 'sequential parallel) (assign pc (pc-plus-number pc (b-constant -1))) (take-post-trap ,escape-function-name ,preserve-or-restore-stack))) ;Current instruction completed, now save pc on stack and jump to trap pc (defmicro take-post-trap (escape-function-name preserve-or-restore-stack) (selectq preserve-or-restore-stack (preserve-stack `(sequential (pushval-with-cdr (set-cdr pc cdr-normal)) (take-jump-trap ,escape-function-name preserve-stack))) (restore-stack `(sequential (call restore-stack-pointer) (pushval-with-cdr (set-cdr pc cdr-normal)) (take-jump-trap ,escape-function-name preserve-stack))) (otherwise (retch "~S should be PRESERVE-STACK or RESTORE-STACK" preserve-or-restore-stack)))) ;Pclsr out of current instruction and jump to specified pc (defmicro take-jump-trap (escape-function-name preserve-or-restore-stack) `(parallel (assign pc ,(intern (string-append escape-function-name "-ESCAPE-PC"))) (jump ,(selectq preserve-or-restore-stack (preserve-stack 'pclsr) (restore-stack 'pclsr-restore-stack) (otherwise (retch "~S should be PRESERVE-STACK or RESTORE-STACK" preserve-or-restore-stack)))))) ;Save continuation pc and jump to trap pc (defmicro take-jump-trap-with-continuation (escape-function-name continuation-name preserve-or-restore-stack) (selectq preserve-or-restore-stack (preserve-stack `(sequential (pushval ,continuation-name) (take-jump-trap ,escape-function-name preserve-stack))) (restore-stack `(sequential (call restore-stack-pointer) (pushval ,continuation-name) 4,887,235 123 124 (take-jump-trap ,escape-function-name preserve-stack))) (otherwise (retch "~S should be PRESERVE-STACK or RESTORE-STACK" preserve-or-restore-stack)))) ;; We implement several dispatching schemes for binary arithmetic operations ;; This is because at a later date, we may have to trade off dispatch blocks for ;; speed in the floating point case. ;; Arguments are: ;; type - type of instruction (no-operand address-operand signed-immediate-operand) ;; index - the operation index ;; no-operand-version - the symbol for the no-operand version of this instruction ;; float-version - the symbol of the floating point version of this function ;; if non-existant, a callout will occur (defmicro check-binary-arithmetic-operands-fast (type index no-operand-version &optional float-version fixnum-overflow flonum-fixnum-version) (let ((ops (selectq type (no-operand '(next-on-stack top-of-stack)) (address-operand '(address-operand top-of-stack)) (signed-immediate-operand '(top-of-stack-a macro-signed-immediate)) (otherwise (retch "~S type instructions not handled" type))))) `(check-fixnum-2args ,@ ops . ,(selectq type (no-operand `(((fixnum-fixnum) ,(if fixnum-overflow `(goto ,fixnum-overflow) `(signal-error fixnum-overflow))) ((fixnum-flonum) ,(if float-version `(sequential ;; get NPC straightened out (nop) (call-and-return-to convert-first-fixnum-to-flonum ,float-version)) `(parallel (assign arith-operation-index ,index) (jump arith-binary-call-out))) ) ((flonum-fixnum) ,(cond (float-version `(sequential ;; get NPC straightened out (nop) (call-and-return-to convert-fixnum-to-flonum ,float-version))) (flonum-fixnum-version `(goto ,flonum-fixnum-version)) (t '(parallel (assign arith-operation-index index) (jump arith-binary-call-out))))) ((fixnum-extnum flonum-extnum extnum-extnum) (parallel (assign arith-operation-index ,index) (jump arith-binary-extnum-call-out))) ((flonum-flonum) ,(if float-version `(goto ,float-version) `(parallel (assign arith-operation-index ,index) (jump arith-binary-call-out)))) ((extnum-fixnum extnum-flonum) (parallel (assign arith-operation-index ,index) (jump arith-binary-call-out))))) (address-operand `((otherwise (parallel (trap-no-save) (pushval address-operand) (jump ,no-operand-version))))) (signed-immediate-operand `((otherwise (parallel (trap-no-save) (pushval macro-signed-immediate) (jump ,no-operand-version))))))))) ;; Slower version, which can be used to mave dispatches or because you cant use ;; arithmetic trap enable on the same cycle. Doesn't work unless you have ;; defucode'ed at loc and not clear what to do with float-version (defmicro check-binary-arithmetic-operands-slow (type index no-operand-version &optional float-version fixnum-overflow) no-operand-version fixnum-overflow (let ((ops (selectq type (no-operand '(next-on-stack top-of-stack)) (address-operand '(address-operand top-of-stack)) (signed-immediate-operand '(top-of-stack-a macro-signed-immediate)) (otherwise (retch "~S type instructions not handled" type))))) `(check-fixnus-2args ,@ ops (otherwise (sequential ,(selectq type (no-operand nil) (address-operand '(pushval address-operand)) (siqned-immediate-operand '(pushval macro-signed-immediate))) ,(if float-version `(assign arith-operation-floating-pc ,float-version)) (parallel (assign arith-operation-index ,index) ,(if float-version '(jump arith-binary-operand-dispatch-with-float) '(jump arith-binary-extnum-call-out)))))))) 4,887,235 125 126 ;; Fast version of unary operation dispatches ;; Only for no-operand versions and address-versions (defmicro check-unary-arithmetic-operation-fast (type index no-operand-version &optional float-version fixnum-overflow) (let ((source (selectq type (no-operand top-of-stack-a) (address-operand 'address-operand) (otherwise (retch "~S type instructions not handled" type))))) `(check-fixnum-1arg-a ,source . ,(selectq type (no-operand `(((fixnum-fixnum fixnum-flonum fixnum-extnum) ,(if fixnum-overflow `(goto ,fixnum-overflow) `(signal-error fixnum-overflow))) ((flonum-fixnum flonum-flonum flonum-extnum) ,(if float-version `(goto ,float-version) `(parallel (assign arith-operation-index ,index) (jump arith-unary-call-out)))) ((extnum-fixnum extnum-flonum extnum-extnum) (parallel (assign arith-operation-index ,index) (jump arith-unary-call-out))))) (address-operand `((otherwise (parallel (trap-no-save) (pushval address-operand) (jump ,no-operand-version))))))))) ;;; Accessor micros for the current frame ;The currently executing function (defatomicro frame-function (amem (frame-pointer -1))) ;A fixnum full of various fields (defatomicro frame-misc-data (amem (frame-pointer -2))) ;Caller's return PC (defatomicro frame-return-pc (amem (frame-pointer -3))) ;Top of previous frame = value to restore to (stack-pointer) ;The cdr code of this word is the value disposition (defatomicro frame-previous-top (amem (frame-pointer -4))) ;Base of previous frame = value to restore to (arg-pointer) (defatomicro frame-previous-frame (amem (frame-pointer -5))) ;Fields in frame-misc-data (these will all be moved around later) (defatomic-byte-field frame-number-of-args frame-number-of-args frame-misc-data) (defatomic-byte-field frame-cleanup-bits frame-cleanup-bits frame-misc-data) (defatomic-byte-field frame-buffer-underflow-bit frame-buffer-underflow-bit frame-misc-data) (defatomic-byte-field frame-unsafe-reference-bit frame-unsafe-reference-bit frame-misc-data) (defatomic-byte-field frame-catch-bit frame-catch-bit frame-misc-data) (defatomic-byte-field frame-bindings-bit frame-bindings-bit frame-misc-data) (defatomic-byte-field frame-trace-bit frame-trace-bit frame-misc-data) (defatomic-byte-field frame-bottom-bit frame-bottom-bit frame-misc-data) (defatomic-byte-field first-part-done frame-first-part-done frame-misc-data) (defatomic-byte-field frame-lexpr-called frame-lexpr-called frame-misc-data) (defatomic-byte-field frame-funcalled frame-funcalled frame-misc-data) (defatomic-byte-field frame-instance-called frame-instance-called frame-misc-data) (defatomic-byte-field frame-argument-format frame-argument-format frame-misc-data) (associate-dispatch-cues frame-argument-format *frame-argument-formats*) ;Fields in status bits word for current stack group (defatomic-byte-field stack-load-started sg-stack-load-started %current-stack-group-status-bits) ;;; Support micros for instructions ;;; These are open-coded and go in one cycle 4,887,235 127 128 ;Push argument onto stack (defmicro pushval (val) `(parallel (assign (amem (stack-pointer 1)) (set-cdr ,val cdr-next)) (assign top-of-stack obus) (increment-stack-pointer))) ;Use top of stack as value and pop it ;This uses up both the abus and the bbus (defmicro popval () '(parallel top-of-stack ;This is the data source we return (assign top-of-stack (amem (stack-pointer -1))) (decrement-stack-pointer))) ;Like pushval but replaces the top of stack rather than pushing (defmicro newtop (val) `(parallel (assign (amem (stack-pointer 0)) (set-cdr ,val cdr-next)) (assign top-of-stack obus))) ;The value below top-of-stack (defatomicro next-on-stack (amem (stack-pointer -1))) ;Top-of-stack on the A side (defatomicro top-of-stack-a (amem (stack-pointer 0))) ;This is like doing two popval's and then a pushval ;I.e. it is how single-cycle two-operand instructions store their result (defmicro pop2push (val) `(parallel (assign (amem (stack-pointer -1)) (set-cdr ,val cdr-next)) (assign top-of-stack obus) (decrement-stack-pointer))) ;Like pushval but doesn't smash the cdr code to cdr-next (defmicro pushval-with-cdr (val) `(parallel (assign (amem (stack-pointer 1)) ,val) (assign top-of-stack obus) (increment-stack-pointer))) (defmicro newtop-with-cdr (val cdr) `(parallel (assign (amem (stack-pointer 0)) (set-cdr ,val ,cdr)) (assign top-of-stack obus))) ;Call subroutine defined in SUBPRIM, returns with data available in memory-data (defmicro memread (addr) `(parallel (assign vma ,addr) (call memread) (declare-memory-timing active-cycle))) ;i.e. data-cycle when we return ;Like memread but checks write access (defmicro memread-write (addr) `(parallel (assign vma ,addr) (call memread-write) (declare-memory-timing (next data-cycle)))) F:>lmach>ucode>UDCLS.LISP.22 ; -*- Mode:Lisp; Base:8; Lowercase:yes -*- ; Load this into the compiler when compiling microcode (princ '#.(format nil "~%;Loading UDCLS (~A)." (namestring (truename infile))) msgfiles) ; Load the necessary mupport files (load 'sim) (load 'uu) (load 'check) (load 'ul) (or (boundp '**compiling-ua**) (load 'ua)) (*expr defmicro-wrong-number-of-args) ;prevent undef fcn warning (*lexpr fintern) ;It's in UU (*lexpr paralyze) ;.. (*lexpr retch) ;.. ; These are all the functions that can get called by UL-generated cods ; Prevent compiler warnings for calling them (*expr set-pma-from-vma pma-mem-read pma-mem-write simulate-transporter rot32 mask32 merge32 pc-readback pc-add rotate-pc-left rotate-pc-right instruction-signed-immediate instruction-unsigned-immediate instruction-baseno instruction-offset instruction-opcode stack-address encode-arithmetic-trap-condition overflow-p address-add-fp address-add-sp address-add-xb address-add-macrocode aref-amem aref-bmem aref-bmem-0 aset-amem aset-bmem aset-bmem-0 setq-pc setq-vma setq-fp setq-sp inc-sp dec-sp inc-pma inc-pc inc-macro carry28 carry32 16-bit-sign-extend) 4,887,235 129 130 (fixnum (rot32 fixnum fixnum) (merge32 fixnum fixnum fixnum) (mask32 fixnum) (pc-readback) (16-bit-sign-extend fixnum) (address-add-fp fixnum) (address-add-sp fixnum) (address-add-xb fixnum) (address-add-macrocode) (aref-amem fixnum) (aref-bmem fixnum) (aref-bmem-0)) (notype (aset-amem fixnum fixnum) (aset-bmem fixnum fixnum) (aset-bmem0 fixnum) (setq-pc fixnum) (setq-vma fixnum) (setq-fp fixnum) (setq-sp fixnum) (carry28 fixnum fixnum fixnum) (carry32 fixnum fixnum fixnum)) (special *frame-pointer* *stack-pointer* *xbas* *pc* *vma* *pma* *instruction* *a-memory* *b-memory* *byte-r* *byte-s* *type-map* *multiply-x* *multiply-y*)) (*lexpr address-add) (princ " ;Loading of UDCLS complete." msgfiles) (estatus feature lmucode) F:>lmach>ucode>uh.lisp.126 ;;; -*- Mode:Lisp; Package:Micro; Base:8; Lowercase:yes -*- ;;; (c) Copyright 1982, Symbolics, Inc. ; Microcode assembler & linker for the hardware ;;;; Definitions ;There are two structures that represent microcode: ; micrel -- the "relocatable" representation that is generated by ; the microcode compiler and stored in files. ; micabs -- the "absolute" representation used in ths linker, which ; links compiled files to make the final memory image. ; mic -- the shared part of those two structures (not instantiated by itself) (defstruct (mic :named :conc-name) (code *default-microinstruction*) ;103-bit number (parity added later) (tag nil) ;NIL or symbolic tag for this instruction (load-time-patches nil) ;Fields to be filled in by FEP when loading (address-constraints nil) ;Numeric location it must go at, or UNIQUE, or list of locs (npc-successor nil) ;Successor at .+1 (naf-successor nil) ;Successor addressed via NAF (error-table nil) ;Args to signal-error, if any ) (defstruct (micrel :named :conc-name (:include mic)) (a-constant nil) ;Amem and Bus. constants to be inserted, if any (b-constant nil) (type-map nil)) ;Type map (slots are assigned during linking) (defstruct (micabs :named :conc-name (:include mic)) (predecessors nil) ;List of micabs's whose npc-successor is me (blocks nil) ;List of address blocks that contain me (addresses nil) ;List of addresses actually stored at original-npc-successor ;For intern-micrel original-naf-successor ;.. (multiplicity 1)) ;Number of micrel's turned into this micabs ;A successor in a micrel is one of the following: ; instr - a single successor ; (SKIP true-instr false-instr) - a skip pair ; (DISPATCH ((cue.. .1 instr)...) - a dispatch block ;An instr is either a symbolic tag or a micrel structure or NIL meaning drop-through ;drop-through is only allowed in SKIP, not in DISPATCH ;Also the two instr's in a SKIP may be dispatch blocks (not supported at any level now!) ;Later the successor fields of a micabs are changed to something else... (defmacro pushnew (item list) `(or (memq ,item ,list) (push ,item ,list))) ;Associate from the code field to a list of micabs's, in order to merge those ;with identical code, identical successors, and compatible other attributes (defvar *microinstruction-hash-table* (make-array 27001)) ;Prims bigger than 8K (defvar *microinstruction-tag-alist*) (defvar *a-constant-hash-table* (make-equal-hash-table)) (defvar *a-constant-list*) (defvar *a-constant-address*) (defconst *a-constant-starting-address* 3000) ;Or whatever... (defconst *a-constant-ending-address* 4000) (defvar *b-constant-hash-table* (make-equal-hash-table)) (defvar *b-constant-list*) (defvar *b-constant-address*) 4,887,235 131 132 (defconst *b-constant-starting-address* 10) (defconst *b-constant-ending-address* 300) ;Leave fast 100 locations for microcode ;There are also the a-list *a-memory-values*, *b-memory-values* for initialized variables (defconst *microinstruction-memory-size* 20000) ;8K (defvar *microinstruction-memory* (make-array *microinstruction-memory-size*)) (defvar *address-block-hash-table* (make-equal-hash-table)) (defvar *address-block-list*) (defvar *unresolved-symbolic-references*) (defvar *undefined-tag-standin* nil) (defvar *undefined-opcode-standin* nil) (defvar *speed-histogram* (make-array 4)) ;Hardware parameters (defconst *skip-increment* 10000) ;Bit 12 is the skip bit, and 0-true (defconst *dispatch-increment* 400) ;Bits 11-8 are the dispatch bits (defconst *npc-increment* 1) ;Bits 7-8 are the NPC increment bits (defconst *npc-modulus* 400) ; This structure represents a block of instructions (possibly partially-full) ; which must be stored together. i.e. with addresces equal except in certain bits. ; The structure is an array of the instructions, with a leader. ; The size of the array is: ; 2 - a skip pair ; 20 - a dispatch block ; 40 - a dispatch block of Skip pairs ; For now I give up trying to be more general! ; A block may have a successor, which is another block that must be stored ; in the consecutive address. Valid successor lirks are: ; 2 -> 2 20 -> 40 40 -> 40 ; because dispatch always takes an explicit address, but skipping doesn't. ; A 1 -> 2 link becomes a 2 -> 2. (defstruct (address-block :named :array-leader :conc-name (:constructor make-address-block-internal)) ;Do not regrind above line into two--editor bug kind ;Symbolic address-block kind (successor nil) ;Block, if any, that must be at consecutive address (predecessor nil) ;Block, if any, in preceding conscc.utive address (mic-preaccessors nil);Microinstructions that must precede this block (skip into it) (aliases nil) ;Blocks, if any, that this is inside of or equivalent to ;Each element is actually a list (block offset) (locations nil) ;Base address list (normally only one element) bit-mask) ;Variable bits ;;;; Hardware Microinstruction Definitions - - ;Special form for defining fields in microinstruction word ;Defconsts the name to be 5 byte pointer and also sets up tables ;to drive the translation from plist format ; name - name of the field ; n-bits - width ; bits-over - rightmost bit number ; display-p - t if is to appear in disassembled instructions (if-set => only if non-default) ; default - default value for field (0 is the default default) ; indicator - how it appears in the plist form ; function - function to call when appears in plist form ; args - args to that function (after mic, value, and ppss) (defmacro defu (name n-bits bits-over &optional display-p default indicator function &rest args) (let ((ppss (+ (lsh bits-over 6) n-bits))) `(progn 'compile (defconst ,name ,ppss) ,@(if display-p `((push** '(,(or indicator name) ,ppss ,@(if (eq display-p 'if-set) `(,default))) *microinstruction-display-fields*))) ,@(if default `((setf (ldb ,ppss *default-microinstruction*) ,default))) ,@(if indicator `((push** '(,indicator ,function ,ppss ,@args) *plist-to-mic-table*))) ',name))) (defmacro push** (val field) `(let ((.val. ,val)) (or (assq (car .val.) ,field) (push .val. ,field)))) (defconst *default-microinstruction* 0) ;Changed by defu's below (defconst *microinstruction-display-fields* nil);.. ;Translation from plist fields to mic ;Each entru is (indicator function byte-pointer . args) ;The function is called with mic, field-value, byte-pointer, and the args. ;Some fields are not in this table and are handled as a special case, typically ;when several fields must be processed together. ;Some fields are not in this table because they aren't used at all at this level. (defconst *plist-to-mic-table* nil) ;Changed by dsfu's below (defu u-amra 12. 0 t nil amem-read-addr store-amem-read-addr) (defu u-r-base 2 9 nil 1) (defu u-r-offset 9 0) (defu u-amra-sel 2 12. t 3) ;Default Abus source is frame-pointer