4,887,235
	193	194
(defun types-other-than (types)
  ;;I feel bad about (check-data-type foo fixnum) trapping everything.
  (loop for type in types
	unless (memq type *unduplicated-data-types*)
	do (retch "You have invalid data type ~S" type))
  (loop for type in *unduplicated-data-types*
	unless (memq type types)
	collect type))

;General "higher-level" traps. Any condition on the skip condition
;multiplexor may be selected, and true or false may be selected. If the
;condition is satisfied the machine traps to the next-microinstruction
;address. expressed here as either a goto or a microsequence as with IF.
(defmicro trap-if (pred trap-sequence)
  (if (eq pred 'true)
	(setq prod '(cdr-code? (a-constant 0) 0))) 	;--- Something better?
  (let* ((test (microexpand pred))
	 (trap-if 'condition-true)
	 (cond (cond ((neq (car test) 'microcondition)
		      (retch "~S expanded to ~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)))))
    (if (eq (caddr test) 'false) (setq trap-if 'condition-false))
    `(parallel
      ,(cadddr test)
      (microinstruction condition ,cond
			trap-enables (,trap-if)
			trap-sequence ,(microexpand-if trap-sequence)
			,@(selectq cond
			    ;;--- This may be over-conservative. These, conditions
			    ;; come out a little bit later than the others.
			    ((alu-31 equal-pointer not-equal-fixnum not-equal-typed-pointer)
			     '(speed slow-second-half)))))))

;Simply eliminate duplicates. For now at least,	no compatibility issues.
(defun (trap-enables merge-fields) (en1 en2)
  (append en1 (loop for en in en2 unless (memq en en1) collect en)))

;Can have a data type check at the same time as a transporter check
;In that case, the wrong-type-argument prevails. The error handler can print a different
;message if it finds an illegal data type than one that fails to match.
(defprop error-table merge-error-table-entries merge-fields)

(defun merge-error-table-entries (err1 err2 &optional (error-p t) &aux errt1 errt2)
  (setq errt1 (car err1)
	errt2 (car err2))
  (cond ((equal errl err2)
	 err 1)
	((or (null err2)
	     (and (eq errt1 'wrong-type-argument) (eq errt2 'bad-data-type)))
	 err1)
	((or (null err1)
	     (and (eq errt1 'bad-data-type) (eq errt2 'wrong-type-argument)))
	 err2)
	((not error-p)
	 'no-go)
	(t
	 (retch "Error table conflict: ~S and ~S" err1 err2))))

(defun compatible-error-table-entries (err1 err2)
  (neq 'no-go (merge-error-table-entries err1 err2 nil)))

;The type cap for normal arithmetic, which has cond for non-fixnum numbers
;and bad-argument trap for non-numbers.
(declare (special *arithmetic-type-map*))	;in UUX

;;; Micros for arithmetic traps

;2-operand arithmetic instructions use this
(defmicro check-fixnum-2args (a-opnd b-opnd &rest exception-routines)
  (paralyze (get-to-abus a-opnd)
	    (get-to-bbus b-opnd)
	    `(microinstruction
	      type-map ,*arithmetic-type-map*
	      trap-enables (type-condition bbus-non-fixnum)
	      spec trap-if-type-cond-or-bbus-not-fixnum
	      error-table (wrong-type-argument any (:number)))
	    (make-arith-dispatch-microinstruction exception-routines)))

;1-operand arithmetic instructions use one of the next two
(defmicro check-fixnum-1arg-a (a-opnd &rest exception-routines)
  (paralyze (get-to-abus a-opnd)
	    `(microinstruction
	      type-map ,*arithmetic-type-map*
	      trap-enables (type-condition)
	      spec trap-if-type-cond
	      error-table (wrong-type-argument nil (:number)))
	    (make-arith-dispatch-microinstruction exception-routines)))
4,887,235
	195	196
(defmicro check-fixnum-1arg-b (b-opnd &rest exception-routines)
  (paralyze (get-to-bbus b-opnd)
	    '(microinstruction		;Assume no type-cond bits set in map ----
	      trap-enables (type-condition bbus-non-fixnum)
	      spec trap-if-type-cond-or-bbus-not-fixnum)
	    (make-arith-dispatch-microinstruction exception-routines)))

(defmicro check-fixnum-b (b-opnd &rest exception-routines)
  (paralyze (get-to-bbus b-opnd)
	    '(microinstruction 	;Assume no type-cond bits set in map ----
	      trap-enables (type-condition bbus-non-fixnum)
	      spec trap-if-type-cond-or-bbus-not-fixnum)
	    (and exception-routines
		 `(microinstruction
		   next-microaddress ,(microexpand exception-routines)))))

;Trap if opnd is of any of the named types, and do an arithmetic dispatch
;into the trap routine. This is mainly for EQL.
(defmicro check-data-type-and-dispatch (opnd-and-types &rest exception-routines)
  (let ((opnd (car opnd-and-types))
	(types (cdr opnd-and-types)))
    (paralyze (get-to-abus opnd)
	      `(microinstruction
		type-map ((,types cond))
		trap-enables (type-condition)
		spec trap-if-type-cond)
	      (make-arith-dispatch-microinstruction exception-routines))))

;Arithmetic trap dispatches on ABUS<33:32>|BBUS<33:32>
;3 in either field can't happen, if a type check was done
;Unfortunately this isn't really true, since Sbus type checking incomplete (use OTHERWISE)
(declare (special *arithmetic-trap-dispatch-cues-alist*))	;in UUX

;Make up a microinstruction that either dispatches or doesn't depending on
;whether the arithmetic trap exception routines consist of more than
;just an otherwise clause.
;With no excepion routines at all, any exception is an error.
;The caller is assumed to provide the trap enables. Merging will switch
;to spec/arithmetic-trap-enb and supply the magic-number bite as needed.
(defun make-arith-dispatch-microinstruction (exception-routines)
  (let ((disp (expand-dispatch-clauses exception-routines
				       *arithmetic-trap-dispatch-cues-alist*)))
    (cond ((null disp)
	   '(microinstruction trap-sequence error-trap))
	  ((and (null (cdr disp)) (eq (caar disp) 'otherwise))
	   '(microinstruction trap-sequence (cadar disp)))
	  ((not (assq 'otherwise disp))		;Compensate for lack of Bbus type check
	   `(microinstruction spec arithmetic-trap-with-dispatch
			      arith-trap-dispatch-table (arith ((3 7 13) error-trap)
							       . ,disp)))
	  (t `(microinstruction spec arithmetic-trap-with-dispatch
				arith-trap-dispatch-table (arith . ,disp))))))
;;; "Data Processing"

;Construct a microdata out of a data location and some microcode.
;The microcode is expanded now to make life simpler and to make
;the backtracing come out right.
(defun make-microdata (location code)
  (let ((expcode (microexpand code)))
    (if (or (atom expcode)
	    (not (memq (car expcode) '(microinstruction microsequence))))
	(ferror nil "not microinstruction in microdata: ~S == ~S"
		code expcode))
    `(microdata ,location ,expcode)))

;The valid 'places' for data are ABUS, BBUS, XBUS, YBUS, ALUB, and OBUS
;Maybe more will be put in later

;Discard the result of a microdata, just perform the microcode.
(defmicro for-effect (val)
  (setq val (microexpand val))
  (cond ((atom val) val)
	((eq (car val) 'microdata) (caddr val))
	((eq (car val) 'microcondition) (cadddr val))
	(t val)))

;Routines which understand the various bus routes

;Put data on obus. Returns an instruction.
;Note that this is only guaranteed to get the low 32 bite, not the 4 high tag bits
(defun get-to-obus32 (form)
  (let* ((*backtrace* (cons '(get-to-obus32) *backtrace*))
	 (data (microexpand form)))
    (if (not (and (not (atom data))
		  (eq (car data) 'microdata)
		  (memq (cadr data) '(abus bbus xbus ybus alub obus))))
	(retch "Cannot get data onto Obus: ~S == ~S" form data)
      (let ((code (caddr data)))
	(if (eq (cadr data) 'obus) 	;If not already on obus, put it there
	    code
4,887,235
	197	198
	(paralyze
	   code
	   (selectq (cadr data)
	     (abus '(microinstruction xbus abus
				      alu xbus))
	     (bbus '(microinstruction ybus bbus
				      byte-func ybus
				      alu alub))
	     (xbus '(microinstruction alu xbus))
	     (ybus '(microinstruction byte-func ybus
				      alu alub))
	     (alub '(microinstruction alu alub)))))))))

;Same but transfers all the bits (not just low 32)
(defun get-to-obus (form)
  (let* ((*backtrace* (cons '(get-to-obus) *backtrace*))
	 (data (microexpand form)))
    (if (not (and (not (atom data))
		  (eq (car data) 'microdata)
		  (memq (cadr data) '(abus bbus xbus ybus alub obus))))
	(retch "Cannot get data onto Obus: ~S == ~S" form data)
      (let ((code (caddr data)))
	(if (eq (cadr data) 'obus)	;If not already on obus, put it there
	    code
	    (paralyze
	       code
	       (selectq (cadr data)
			(abus '(microinstruction xbus abus
						 alu xbus
						 ;force-obus<35-34> abus	;will default
						 ;forcs-obus<33-32> abus	;will default
						 ))
			(bbus '(microinstruction ybus bbus
						 byte-func ybus
						 force-obus<33-32> bbus))
			(xbus '(microinstruction alu xbus))
			(ybus '(microinstruction byte-func ybus
						 alu alub))
			(alub '(microinstruction alu alub)))))))))

(defun get-to-abus (form)
  (let* ((*backtrace* (cons '(get-to-abus) *backtrace*))
	 (data (microexpand form)))
    (if (not (and (not (atom data))
		  (eq (car data) 'microdata)
		  (eq (cadr data) 'abus)))
	(retch "Data not accessible on Abus: ~S == ~S" form data)
      (caddr data))))

(defun get-to-bbus (form)
  (let* ((*backtrace* (cons '(get-to-bbus) *backtrace*))
	 (data (microexpand form)))
    (if (not (and (not (atom data))
		  (eq (car data) 'microdata)
		  (eq (cadr data) 'bbus)))
	(retch "Data not accessible on bbus: ~S == ~SS" form data)
      (caddr data))))

(defun get-to-xbus (form)
  (let* ((*backtrace* (cons '(get-to-xbus) *backtrace*))
	 (data (microexpand form)))
    (cond ((or (atom data) (neq (car data) 'microdata))
	   (retch "Not microdata: ~S == ~S" form data))
	  ((eq (cadr data) 'xbus)
	   (caddr data))
	  ((eq (cadr data) 'abus)
	   (paralyze (caddr data) '(microinstruction xbus abus)))
	  ((eq (cadr data) 'bbus)
	   (paralyze (caddr data) '(microinstruction xbus bbus)))
	  (t
	   (retch "Data not accessible on Xbus: ~S == ~S" form data)))))

(defun get-to-ybus (form)
  (let* ((*backtrace* (cons '(get-to-ybus) *backtrace*))
	 (data (microexpand form)))
    (cond ((or (atom data) (neq (car data) 'microdata))
	   (retch "Not microdata: ~S == ~S" form data))
	  ((eq (cadr data) 'ybus)
	   (caddr data))
	  ((eq (cadr data) 'abus)
	   (paralyze (caddr data) '(microinstruction ybus abus)))
	  ((eq (cadr data) 'bbus)
	   (paralyze (caddr data) '(microinstruction ybus bbus)))
	  (t
	   (retch "Data not accessible on Ybus: ~S == ~S" form data)))))

(defun get-to-alub (form)
  (let* ((*backtrace* (cons '(get-to-alub) *backtrace*))
	 (data (microexpand form)))
    (cond ((or (atom data)
4,887,235
	199	200 _
	(neq (car data) 'microdata)
	(not (memq (cadr data) '(abus bbus ybus alub))))
	   (retch "Data not accessible on ALUB: ~S == ~S" form data))
	  ((eq (cadr data) 'alub) (caddr data))		;Already there
	  (t (paralyze	;Get it there through shift/mask
	      (get-to-ybus data)
	      '(microinstruction byte-func ybus))))))

(defun can-get-to-xbus (data)
  (cond ((or (atom data) (neq (car data) 'microdata))
	 (retch "Not microdata: ~S" data))
	(t (memq (cadr data) '(xbus abus bbus)))))

(defun can-get-to-ybus (data)
  (cond ((or (atom data) (neq (car data) 'microdata))
	 (retch "Not microdata: ~S" data))
	(t (memq (cadr data) '(ybus abus bbus)))))

(defun can-get-to-alub (data)
  (cond ((or (atom data) (neq (car data) 'microdata))
	 (retch "Not microdata: ~S" data))
	(t (memq (cadr data) '(alub ybus abus bbus)))))

;First value is code, second is t if form2 is on Xbus, nil if formi is
(defun get-to-xbus-and-alub (form1 form2)
  (let* ((*backtrace* (cons '(get-to-xbus-and-alub) *backtrace*))
	 (data1 (microexpand form1))
	 (data2 (microexpand form2)))
    (cond ((or (atom data1)
	       (neq (car data1) 'microdata)
	       (not (memq (cadr data1) '(abus bbus xbus ybus alub))))
	   (retch "Data not accessible: ~S == ~S" form1 data1))
	  ((or (atom data2)
	       (neq (car data2) 'microdata)
	       (not (memq (cadr data2) '(abus bbus xbus ybus alub))))
	   (retch "Data not accessible: ~S == ~S" form2 data2))
	  ((eq (cadr data1) 'xbus)
	   (values (paralyze (caddr data1) (get-to-alub data2)) nil))
	  ((memq (cadr data1) '(ybus alub))
	   (values (paralyze (get-to-alub data1) (get-to-xbus data2)) t))
	  ((eq (cadr data2) 'xbus)
	   (values (paralyze (get-to-alub data1) (caddr data2)) t))
	  ((memq (cadr data2) '(ybus alub))
	   (values (paralyze (get-to-xbus datal) (get-to-alub data2)) nil))
	  ((slow-source-p data2)
	   (values (paralyze (get-to-xbus data2) (get-to-alub data1)) nil))
	  (t ;Unconstrained. pick arbitrarily
	   (values (paralyze (get-to-xbus data1) (get-to-alub data2)) nil)))))

;Regard all off-board sources as slow
(defun slow-source-p (datum)
  (selectq (cadr datum)
	   (abus (memq (get (caddr datum) 'abus) '(memory-data lbus memory-data-force vma pc map)))
	   (otherwise nil)))
;Test whether a given field of an instruction has a given value
;Should this barf if the field is not specified at all?
(defun fieldp (code field value)
  (or (eq (car code) 'microinstruction)
      (retch "~S not a microinstruction - fieldp" code))
  (equal (get code field) value))

;Change a piece of code according to specified field renamings a-list.
;Renaming something to nil deletes it completely.
(defun modify-code (code changes)
  (or (eq (car code) 'microinstruction)
      (retch "~S not a microinstruction - modify-code" code))
  (cons 'microinstruction
	(loop for (field val) on (cdr code) by 'cddr
	      as change = (assq field changes)
	      when (not change)
	      collect field and collect val
	      else when (cadr change)
	      collect (cadr change) and collect val)))

;Microcode version of setf
(defmicro assign (original-destination original-source &aux destination source)
  (setq destination (microexpand original-destination)
	source (microexpand original-source))
  (cond ;; WRITE-ONLY REGISTERS
   ((eq destination 'xbas)
    (paralyze (get-to-obus32 source)
	      '(microinstruction spec load-xbas)))
   ;For the temporary memory control, there is an inst register we can write
   ((eq destination inst)
    (or (memq *machine-version* '(sim proto))
	(retch "Cannot assign to INST--it only exists inside the IFU!"))
    (paralyze (get-to-obus32 source)
	      '(microinstruction spec clear-stack-adjustment))) ;code 7

   ((or (atom destination) (neq (car destination) 'microdata))
    (retch "~S == ~S~%is not a description of a valid data destination"
4,887,235
	201	202
	original-destination destination))
   ((and (neq source 'array-index-shift-prom)	;BYTE-R kludge
	 (or (atom source)
	     (neq (car source) 'microdata)
	     (not (memq (cadr source) '(abus bbus xbus ybus alub obus)))))
    (retch "~S == ~S~%is not a description of data"
	   original-source source))

   ;; A DESTINATIONS
   ((and (eq (cadr destination) 'abus)
	 (fieldp (caddr destination) 'abus 'memory-data))
    ;Store into memory by putting source on obus and writing lbus dcv
    ;Also must set up the amem-write-addr in case location maps into ames
    ;User is responsible for doing start-memory in parallel with this
    (paralyze (get-to-obus source)
	      (modify-code (caddr destination) '((abus nil) (amem-read-addr nil)))
	      (selectq *machine-version*
		 ((proto sim) '(microinstruction write-lbus obus
						 lbus-dev-addr write-memory
						 amem-write-addr (bus-address)))
		 (otherwise '(microinstruction amem-write-addr (bus-address))))))
   ((and (eq (cadr destination) 'abus)
	 (fieldp (caddr destination) 'abus 'frame-pointer))
    ;Store into frame-pointer by putting the source on the obusand
    ;asserting write-frame-pointer
    (paralyze (get-to-obus32 source)
	      (modify-code (caddr destination) '((abus nil)))
	      '(microinstruction spec load-frmp)))
   ((and (eq (cadr destination) 'abus)
	 (fieldp (caddr destination) 'abus 'stack-pointer))
    ;Store into stack-pointer by putting the source on the obus and
    ;asserting write-stack-pointer
    (paralyze (get-to-obus32 source)
	      (modify-code (caddr destination)
			   '((abus nil)))
	      '(microinstruction spec load-stkp)))
;This version for real memory control (TMC board)
   ((and (eq (cadr destination) 'abus)
	 (fieldp (caddr destination) 'abus 'vma))
    (if (memq *machine-version* '(sim proto))
	(retch "There is no VMA register on this machine"))
    ;Store into vma by putting source on obus and doing appropriate me. function
    ;For TMC, data can come from Obus or Memory
    (paralyze (get-to-obus32 source)
	      (modify-code (caddr destination) '((abus nil)))
	      `(microinstruction write-lbus
				 ,(if (and (memq *machine-version* '(tmc tmc5))
					   (eq (car source) 'microdata)
					   (eq (cadr source) 'abus)
					   (fieldp (caddr source) 'abus 'memory-data))
				      'memory-data 'obus)
				 mem write-vma)))
    ;This version for temporary memory control (FEP board)
   ((and (memq *machine-version* '(sim proto))

	 (eq (cadr destination) 'abus)
	 (fieldp (caddr destination) 'abus 'amem)
	 (fieldp (caddr destination) 'amem-read-addr 2501))
    ;Store into both hardware VMA and A-memory copy
    (paralyze (get-to-obus32 source)
	      (modify-code (caddr destination) '((abus nil)
						 (amem-read-addr amem-write-addr)))
	      '(microinstruction write-amem obus
				 mem write-vma)))
   ((and (eq (cadr destination) 'abus)
	 (fieldp (caddr destination) 'abus 'pc))
    (if (memq *machine-version* '(sim proto))
	(retch "There is no PC register on this machine"))
    ;Storing into PC -- for TMC, data can come from Obus or Memory
    (paralyze (get-to-obus32 source)
	      (modify-code (caddr destination) '((abus nil)))
	      (selectq *machine-version*
		       ((tmc)
			`(microinstruction writs-lbus ,(if (and (eq (car source) 'microdata)
								(eq (cadr source) 'abus)
								(fieldp (caddr source)
									'abus 'memory-data))
							   'memory-data 'obus)
					   mem microdevice
					   lbus-dev-addr write-vma-and-pc))
		       ((tmc5)
			`(microinstruction write-lbus ,(if (and (eq (car source) 'microdata)
								(eq (cadr source) 'abus)
								(fieldp (caddr source)
									'abus 'memory-data))
							   'memory-data 'sbus)
					   mem write-vma
					   spec ifu-control
					   magic 0
					   magic-mask 3))
		       (otherwise (retch "Don't know how to assign to PC on ~S yet"
					 *machine-version*)))))
4,887,235
	203	204
	((and (eq (cadr destination) 'abus)
	      (fieldp (caddr destination) 'abus amem))
	 ;Store into amem by selecting the appropriate write address, putting
	 ;the source on the obus, and asserting write-amem. Forget the speed
	 ;specifier since there is plenty of time for the write address calculation,
	 ;If the write address must come from the AMRA field, UH will put the speed back in.
	 (paralyze (get-to-obus source)
		   (modify-code (caddr destination) '((amem-read-addr amem-write-addr)
						      (abus nil)
						      (speed nil)))
		   '(microinstruction write-amem obus)))

	;; B DESTINATIONS
	((and (eq (cadr destination) 'bbus)
	      (fieldp (caddr destination) 'bbus 'bmem))
	 ;Store into bmem by putting source on xbus if possible, otherwise
	 ;on obus. selecting the appropriate write address, and asserting
	 ;write-bmem. Note that putting something on xbus never precludes
	 ;later deciding to put it on obus too. when writing bmem from xbus
	 ;the high 4 bits come from abus.
	 (let ((code (modify-code (caddr destination)
				  '((bmem-read-addr bmem-write-addr)
				    (bbus nil)))))
	;If writing the hard-to-write locations, need spec function
	   (if (< (get code 'bmem-write-addr) 360)
	       (setq code (paralyze code
				    '(microinstruction spec crocks magic 10))))
					;AMWA gets plugged in later
	   (if (memq (cadr source) '(abus xbus))
	       (paralyze (get-to-xbus source)
			 code
			 '(microinstruction write-bmem xbus))
	     (paralyze (get-to-obus source)
		       code
		       '(microinstruction write-bmem obus)))))

	;; BYTE-R and BYTE-S registers (write-only on proto)
	((and (eq (cadr destination) 'alub)	;BYTE-S
	      (fieldp (caddr destination) 'ybus 'ybus-crocks-2)
	      (fieldp (caddr destination) 'byte-func '(ldb 10 5)))
	 (paralyze (get-to-obus32 source)
		   (modify-code (caddr destination) '((ybus nil) (byte-func nil) (spec nil)))
		   '(microinstruction spec load-byte-s)))
	((and (eq (cadr destination) 'alub)	;BYTE-R
	      (fieldp (caddr destination) 'ybus 'ybus-crocks-1)
	      (fieldp (caddr destination) 'byte-func '(ldb 10 5)))
	 (paralyze (if (eq source 'array-index-shift-prom)
		       '(microinstruction magic 10 magic-mask 10)
		     (paralyze (get-to-obus32 source)
			       '(microinstruction magic 0 magic-mask 10)))
		   (modify-code (caddr destination) '((ybus nil) (byte-func nil) (spec nil)))
		   '(microinstruction spec load-byte-r)))

	;; ALUB (BYTE) DESTINATIONS
	((eq (cadr destination) 'alub)

	;; Assign to a byte by putting the byte's word on one bus (A or B)
	;; and dpb'ing the byte value into it from the other bus, then assigning
	;; the result back into the byte's word.
	 (let ((background-bus (get (caddr destination) 'ybus))
	       (byte-bus (cadr source)))
	   (if (not (or (and (eq background-bus 'abus) (eq byte-bus 'bbus))
			(and (eq background-bus 'bbus) (eq byte-bus 'abus))))
	       (retch "Storing ~S (on ~S bus) into ~S (on ~S bus)~e
		       cannot be done; one must be Abus and the other SBus"
		      original-source byte-bus original-destination background-bus)
	     (let ((word (make-microdata background-bus
					 (modify-code (caddr destination)
						      '((ybus nil) (byte-func nil)))))
		   (rot (second (get (caddr destination) 'byte-func)))
		   (siz (third (get (caddr destination) 'byte-func))))
	       `(assign ,word ,(make-microdata 'obus
				 (paralyze (get-to-xbus word)
					   (get-to-ybus source)
					   `(microinstruction
					     byte-func (dpb ,(logand 37 (- 40 rot))
							    ,siz
							    merge)
					     alu alub
					     force-obus<33-32> ,background-bus
					     force-obus<35-34>
					        ,(if (eq background-bus 'abus) 'abus 0)
						))))))))

	(t (retch "I don't know how to store into this: ~S~% == ~S"
		  original-destination destination))))
;Referencing amem via the address arithmetic
;Valid forms for addr are:
4,887,235
	205	206
;	(frame-pointer fixnum)
;	(stack-pointer fixnum)
;	(macrocode)
;	fixnum			;between 0 and 7777 I guess
;	(constant val)		;address of constant to be allocated later

(defmicro amem (addr)
  `(microdata abus (microinstruction abus amem
				     amem-read-addr ,addr
				     ,@(and (listp addr) (neq (car addr) 'constant)
					    '(speed slow-first-half)))))

(defatomicro address-operand	;of a format-2 instruction
  (amem (macrocode)))

;Allow the obus to be referenced explicitly, for convenience in writing
;code which stores into two destinations simultaneously
(defatomicro obus
  (microdata obus (microinstruction)))

;Defining registers in amem or bmem
;These forms define registers at specific locations
;You can use these, but normally they are just used by the SYSDEF stuff

(defmacro defareg-at-loc (name location
			  &optional initial-value (simulator-initial-value initial-value))
  (check-arg location (<= 0 location 7777) "a 12-bit number")
  `(progn 'compile
     ,@(if initial-value `((add-a-memory-value ,location ,initial-value)))
     ,@(if simulator-initial-value `((aset ,simulator-initial-value *a-memory* ,location)))
     (defprop ,name ,location defareg-at-loc)
     (add-a-memory-symbol ',name ,location)
     #Q (si:record-source-file-name ',name 'defareg-at-loc)
     (eval-when (compile load eval)
       (add-atomicro ',name '(microdata abus (microinstruction abus amem
							       amem-read-addr ,location))))))

(defmacro defbreg-at-loc (name location
			       &optional initial-value (simulator-initial-value initial-value))
  (check-arg location (<= 0 location 377) "an 8-bit number")
  `(progn 'compile
	  ,@(if initial-value `((add-b-memory-value ,location ,initial-value)))
	  ,@(if simulator-initial-value `((aset ,simulator-initial-value *b-memory* ,location)))
	  (defprop ,name ,location defbreg-at-loc)
	  (add-b-memory-symbol ',name ,location)
	  #Q (si:record-source-file-name ',name 'defbreg-at-loc)
	  (eval-when (compile load eval)
	    (add-atomicro ',name '(microdata bbus (microinstruction bbus bmem
								    bmem-read-addr ,location))))))

;Defining registers at variable locations
;Note that if you do this after doing a defareg-at-loc of the same name, you
;get the same register at the same location. This can be useful for
;specifying initial values for registers set up by SYSDEF.






(defvar *next-defareg-address*)
(defvar *defareg-limit*)
(defvar *next-defbreg-address*)
(defvar *defbreg-limit*)
(defvar *b-temps-base* 365)		;Anything from here up is a temporary, possibly
					;overlapped with other temporaries (see UA)
					;except for the b-temp ... b-temp-3 series

(defmacro reserve-scratchpad-memory (first-a last-a &optional first-b last-b)
  `(eval-when (compile eval)
     (setq *next-defareg-address* ,first-a
	   *defareg-limit* ,last-a)
     ,(if first-b
	  `(setq *next-defbreg-address* ,first-b
		 *defbreg-limit* ,last-b))))

(defmacro defareg (name &optional initial-value (simulator-initial-value initial-value))
  (let ((location (or (get name 'defareg-at-loc)
		      (prog1 *next-defareg-address*
			(if (>= *next-defareg-address* *defareg-limit*)
			    (ferror nil "Not enough A-memory reserved"))
			(incf *next-defareg-address*)))))
    `(progn 'compile
	    ,@(if initial-value `((add-a-memory-value ,location ,initial-value)))
	    ,@(if simulator-initial-value `((aset ,simulator-initial-value *a-memory* ,location)))
	    (add-a-memory-symbol ',name ,location)
	    #Q (si:record-source-file-name ',name 'defareg)
	    (eval-when (compile load evil)
4,887,235
	207	208
	    (add-atomicro ',name
			  `(microdata abus (microinstruction abus amem
							     amem-read-addr ,location)))))))

(defmacro defbreg (name &optional initial-value (simulator-initial-value initial-value))
  (let ((location (or (get name 'defbreg-at-loc)
		      (prog1 *next-defbreg-address*
			(if (>= *next-defbreg-address* *defbreg-limit*)
			    (ferror nil "Not enough B-memory reserved"))
			(incf *next-defbreg-address*)))))
    (or (< 7 location 377)
	(ferror	nil "~OeB is not a normal B-memory location, you don't want to put ~S there"
		location name))
    `(progn 'compile
	    ,@(if initial-value `((add-b-memory-value ,location ,initial-value)))
	    ,@(if simulator-initial-value `((aset ,simulator-initial-value *b-memory* ,location)))
	    (add-b-memory-symbol ',name ,location)
	    #Q (si:record-source-file-name ',name 'defbreg)
	    (eval-when (compile load eval)
	      (add-atomicro ',name
			    '(microdata bbus (microinstruction bbus bmem
							       bmem-read-addr ,location)))))))

;Define B temporaries. All files' B-temps go in the same memory locations.
(defmacro define-b-temps (&rest names)
  `(progn 'compile
     . ,(loop for name in names as loc upfrom *b-temps-base*
	      ;; Note that location 377 cannot be used since it gets clobbered
	      when (>= 377) do (ferror "Not enough B-temp space for ~S" name)
	      nconc `((add-b-memory-symbol ',name ,loc t)
		      #Q (si:record-source-file-name ',name 'define-b-temps)
		      (eval-when (compile load eval)
			(add-atomicro ',name '(microdata bbus
						 (microinstruction bbus bmem
								   bmem-read-addr ,loc))))))))

;These are the values actually to be loaded into the hardware
(defvar *a-memory-values* nil)
(defvar *b-memory-values* nil)

(defun add-a-memory-value (location value &aux tem)
  (if (setq tem (assoc location *a-memory-values*)) (rplacd tem value)
    (push (cons location value) *a-memory-values*)))

(defun add-b-memory-value (location value &aux tee)
  (if (setq tem (assoc location *b-memory-values*)) (rplacd tem value)
    (push (cons location value) *b-memory-values*)))

;These are symbol tables for the debugger
(defvar *a-memory-symbols* nil)
(defvar *b-memory-symbols* nil)
(defvar *b-temp-symbols* nil)

(defun add-a-memory-symbol (name location &aux tem)
  (cond ((setq tem (assq name *a-memory-symbols*))
	 (or (= (cdr tem) location)
		(format	error-output "~&Warning: ~A defined at both ~OeA and ~OeA"
			name (cdr tem) location))
	     (rplacd tem location))
	 (t (if (setq tem (rassoc location *a-memory-symbols*))
		(format error-output "~&~-S and ~S at same address (~0eA)"
			name (car tee) location))
	    (push (cons name location) *a-memory-symbols*))))

(defun add-b-memory-symbol (name location &optional temp-p &aux tee)
  (and temp-p (not (memq name *b-temp-symbol*))
       (push name *b-temp-symbols*))
  (cond ((setq tem (assq name *b-memory-symbols*))
	 (or (= (cdr tem) location)
	     (format error-output "~&Warning: ~A defined at both ~0eB and ~0eB"
		     name (cdr tee) location))
	 (rplacd tee location))
	(t (and (setq tem (rassoc location *b-memory-symbols*))
	   (not (and temp-p (memq (car tem) *b-temp-symbols*)))
	   (format error-output "~&~S and ~S at same address (~0eB)"
		   name (car tem) location))
	(push (cons name location) *b-memory-symbols*))))

;Constants on the A side.
;The final assembly phase will allocate Amem locations for these,
;but for now we just stick the constant in the amem address for the Lispifier
(defmicro a-constant (value)
  `(microdata abus (microinstruction abus amem
				     amem-read-addr (constant ,(eval value)))))

;Constantm on the B side
(defmicro b-constant (value)
  `(microdata bbus (microinstruction bbus bmem
				     bmem-read-addr (constant ,(eval value)))))

;The base registers for the amem addressing hardware
4,887,235
	209	210
(defatomicro frame-pointer
  (microdata abus (microinstruction abus frame-pointer)))

(defatomicro stack-pointer
  (microdata abus (microinstruction abus stack-pointer)))

(defmicro increment-stack-pointer ()
  '(microinstruction stack-pointer increment))

(defmicro decrement-stack-pointer ()
  '(microinstruction stack-pointer decrement))

;Explicit routing kludges (PARALLEL won't rewrite the code to make it compatible)
(defmicro via-xbus (source)
  (make-microdata 'xbus (get-to-xbus source)))

(defmicro via-ybus (source)
  (make-microdata 'ybus (get-to-ybus source)))

;The macro program counter.
;This is a word address, with bit 31 selecting between the two
;halfwords. The hardware supplies the tag when reading, and
;looks at bit 31 when writing. The date type field is 60 or 70.

(defatomicro pc
  (pc-kludge))

(defmicro pc-kludge ()
  (selectp *machine-version*
    ((sim proto)
     ;; Use 2500eA, a location kludgily known about...
     '(microdata abus (microinstruction abus amem amem-read-addr 2500)))
    (otherwise
     '(microdata abus (microinstruction abus pc)))))

;To translate the PC into a 32-bit halfword index, rotate it left 1
(defmicro halfword-pc (word-pc)
  `(rotate ,word-pc 1))

;To translate a halfword index into a PC value, rotate it right one place
;then plug 3 into the high-oroer 2 data-type bits, selecting type 60 or 70.
(defmicro word-pc (halfword-pc)
  (make-microdata 'obus
    (paralyze (get-to-ybus halfword-pc)
	      '(microinstruction byte-func (ldb 31. 32.)
				 alu alub
				 force-obus<33-32> 3)))) ; dtp-even-pc/dtp-odd-pc

;To translate a word address into a PC which points at the odd (second)
;instruction in that word all we have to do is set the data type.
(defmicro odd-pc (address)
  `(set-type ,address dtp-odd-pc))

;Translate a word address into a PC which points at the first instruction in that word
(defmicro even-pc (address)
  `(set-type ,address dtp-even-pc))

;This kludge is to avoid conflicts for the magic number field
(defmicro even-pc-except-30-through-28 (address)
  (let ((dtp-code (find-position-in-list 'dtp-even-pc *data-types*)))
    (make-microdata 'obus
      `(parallel ,(get-to-obus32 address)
		 (microinstruction forcc-obus<33-32>  ,(lsh dtp-code -4))
		 (microinstruction magic ,(logand dtp-code 10)
				   magic-mask 10)))))	;force-obus<31>

;Predicate for checking "low" bit of PC
(defmicro odd-pc? (pc)
  (make-microcondition 'alub-0 'true
		       (paralyze (get-to-ybus pc)
				 '(microinstruction byte-func (ldb 132.)))))

;Macroinstruction fields that come in on the B side
(defatomicro macro-unsigned-immediate
  (microdata bbus (microinstruction bbus macro-unsigned-immediate)))

(defatomicro macro-signed-immediate
  (microdata bbus (microinstruction bbus macro-signed-immediate)))

;Two words of magic hardware fields
(defatomicro ybus-crocks-1
  (microdata ybus (microinstruction ybus ybus-crocks-1
				    spec crocks-to-ybus)))

(defatomicro ybus-crocks-2
  (microdata ybus (microinstruction ybus ybus-crocks-2
				    spec crocks-to-ybus)))
4,887,235
	211	212
F:>LMach>Ucode>NET.LISP.71

(defucode service-net-transmit-done
  (assign net-b-temp %net-free-list)
  (parallel (start-memory write physical %net-packet-being-transmitted)
	    (assign memory-data (set-type net-b-temp dtp-fix)))
  (assign %net-free-list %net-packet-being-transmitted)
  (assign %net-packet-being-transmitted (b-constant -1))
  (parallel (set-net-status %net-micro-status-idle)
	    (jump service-net-idle)))

;;; Read net status, and increment meters. If there was an error, throw the packet
;;; away, and wakeup the regular process
(defucode net-receive-completion
  (start-memory read physical %net-control-address)
  (io-board-bug-delay)
  (nop)
  (assign net-dma-temp memory-data)
  (if (bit-test net-dma-temp (b-constant (get '%nsr-error-mask 'sysconstant)))
      (goto net-receive-error)
      (drop-through))
  (assign net-dma-temp (+ %net-packet-being-received
			  (b-constant (field-word-offset 'ether-packet-final-pointer))))
  (assign net-b-temp %net-memory-address)
  (parallel (start-memory write physical net-dma-temp)
	    (assign memory-data net-b-temp))
  ;; Link onto received list
  (assign net-b-temp %net-received-list)
  (parallel (start-memory write physical %net-packet-being-received)
	    (assign memory-data (set-type net-b-temp dtp-fix)))
  (assign %net-received-list %net-packet-being-received)
  (assign %net-packet-being-received (b-constant -1))
  (parallel (set-net-status %net-micro-status-idle)
	    (jump service-net-idle)))

(defucode net-receive-error
  ;; Increment counters for the exact kind of error we received
  (if (field-bit net-dma-temp %%nsr-crc-error)
      (increment %net-crc-errors)
      (drop-through))
  (if (field-bit net-dma-temp %%nsr-alignment-error)
      (increment %net-alignment-errors)
      (drop-through))
  (if (field-bit net-dma-temp %%nsr-preamble-error)
      (increment %net-preamble-errors)
      (drop-through))
  (if (field-bit net-dma-temp %%nsr-buffer-overflow)
      (increment %net-buffer-overflow)
    (drop-through))
  (jump reset-net-dma))

(defucode net-transmit-collision
  (start-memory read physical %net-control-address)
  (io-board-bug-delay)
  (nop)
  (assign net-dma-temp memory-data)
  ;; Here increment meters
  (increment %net-collisions)

  ;; If we have backed off too many times, fail transmission
  (if (equal-fixnum %net-next-backoff (b-constant (1- (lsh 1 (+ 2 15.)))))
      (goto net-transmit-failure)
    (drop-through))
  ;; Mask for pseudo random number generation
  (assign net-b-temp (logand %net-next-backoff (b-constant (1- (lsh 1 (+ 2 10.))))))

  ;; Kludging is because we dont have a b-temp to read microsecond clock into
  (disable-tasking)
  (parallel (disable-tasking)
	    (for-effect (read-lbus-dev 36 0)))
  ;; Backoff is mask & microsecond-clock
  (parallel (declare-memory-timing data-cycle)
	    (assign %net-backoff-count (logand memory-data net-b-temp)))
  ;; %net-next-backoff <= (1- (^ 2 n+1))
  (parallel (assign %net-next-backoff (logior (rotate %net-next-backoff 1)
					      (b-constant 1)))
	    (jump start-net-backoff)))

(defucode start-net-backoff
  (set-net-status %net-micro-status-backing-off)
  (parallel (start-memory write physical %net-control-address)
	    (assign memory-data (b-constant (get '%nsr-backoff-start 'sysconstant))))
  (parallel (start-net-dma backoff-timer)
	    (jump device-service-end)))

(defucode net-transmit-failure
  (parallel (increment %net-transmit-aborts)
	    (jump reset-net-dma)))