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 unnecded 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-larg-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
