4,887,235
	213	214
(definst1 %net-wakeup no-operand
  (wakeup-net-service))

(defucode initialize-net
  (phys-mem-read (a-constant (get 'net-address-1 'virtual-address)))
  (assign %net-address-1 memory-data)
  (phys-mem-read (a-constant (get 'net-address-2 'virtual-address)))
  (parallel (return)
	    (assign %net-address-2 memory-data)))

;; This is separate, since we dont have an extra cycle
(defmicro wakeup-receive-end-service ()
  '(parallel (assign service-task-requests
		     (logior service-task-requests
			     (b-constant (byte-mask %%service-receive-end))))
	     (wakeup-task %device-service-task)
	     ))

;;; This is the receive end of the network
(defmicro check-packet-end ()
  '(if lbus-dev-cond
       (parallel (wakeup-receive-end-service)
		 (jump net-dma-dead))
     (drop-through)))

(defucode net-receive-dma
  ;; Starts with %net-block-pointer pointing to the dest-high
  (parallel (receive-dma %net-block-pointer)
	    (check-packet-end))
  (parallel (extra-time-to-drive-lbus)
	    (set-net-status %net-micro-status-receiving))
  ;; Task switch
  (parallel (receive-dma %net-block-pointer nil)
	    (check-packet-end))
  ;; Rewind pointer to dest-high
  (parallel (extra-time-to-drive-lbus)
	    (assign %net-block-pointer (- %net-block-pointer (b-constant 2))))
  (parallel (start-memory read physical %net-block-pointer)
	    (assign %net-block-pointer (1+ %net-block-pointer)))
  (parallel (start-memory read physical %net-block-pointer)
	    (assign %net-block-pointer (1+ %net-block-pointer)))
  ;; net-dma-temp is the first address word
  (assign net-dma-temp memory-data)
  (if (not (equal-fixnum (ldb memory-data 20 0) %net-address-2))
      (goto address-miss)
    (drop-through))
  (if (not (equal-fixnum net-dma-temp %net-address-1))
      (goto address-miss)
    (goto net-accept-packet)))

;;; Here address comparison failed, check for broadcast or promiscuity
;;; net-dma-temp is the first address word
(defucode address-miss
  (if (ldb-bit-test net-dma-temp 7)
      (goto net-accept-packet)
      (drop-through))
  ;; Here cneck for promiscuity and goto NET-ACCEPT-PACKET
  (jump net-ignore-packet))

(defucode net-ignore-packet
  (net-control nil t t)
  (set-net-status %net-micro-status-ignoring)
  ;; Task Switch
  (increment %net-ignored)
  (terminate-net-dma %net-micro-status-idle))

(defucode net-accept-packet
  (net-control nil t)
  (jump net-header-loop))

;;; Transfer the header into the packet block
(defucode net-header-loop
  (parallel (receive-dma %net-block-pointer)
	    (assign %net-block-pointer (1+ %net-block-pointer))
	    (check-packet-end))
  (parallel (extra-time-to-drive-lbus)
	    (assign %net-word-count (1- %net-word-count))
	    (if (not (minus-fixnum obus))
		(goto net-header-loop)
	      ;; After the header, the rev blocks follow directly
	      (goto net-block-fetch-loop))))

;;; Fetch next block pointer end count, and dma one word into it.
;;; If there are no blc~cks left, return with data-overflow error
(defucode net-block-fetch-loop
  (parallel (start-memory read physical %net-block-pointer)
	    (assign %net-block-pointer (1+ %net-block-pointer)))
  (parallel (start-memory read physical %net-block-pointer)
	    (assign %net-block-pointer (1+ %net-block-pointer)))
  (parallel (assign %net-memory-address memory-data)
	    (if (minus-fixnum memory-data)
4,887,235
	215	216
	(goto net-data-overflow)
	(drop-through)))
  (parallel (assign %net-word-count (1- memory-data))
	    (jump net-block-loop)))

;;; Transfer in all the words in this block until packet end
(defucode net-block-loop
  (parallel (receive-dma %net-memory-address)
	     (assign %net-memory-address (1+ %net-memory-address))
	     (check-packet-end))
  (parallel (extra-time-to-drive-lbus)
	    (assign %net-word-count (1- %net-word-count))
	    (if (not (minus-fixnum obus))
		(goto net-block-loop)
	      (goto net-block-fetch-loop))))

;; Store additional-flags, in packet we have not dismissed by this point
(defucode net-data-overflow
  ;; Increment a meter
  (terminate-net-dma %net-micro-status-idle t))

(defucode net-dma-dead
  (net-control nil t)
  (jump net-dma-dead))
;;; Transmit side

;: This is separate, since we dont have an extra cycle
(defmicro wakeup-transmit-collision-service ()
  '(parallel (assign service-task-requests
		     (logior service-task-requests
			     (b-constant (byte-mask %%service-transmit-collision))))
	     (wakeup-task %device-service-task)
	     ))

(defmicro check-transmit-collision ()
  '(if lbus-dev-cond
       (wakeup-transmit-collision-service)
     (drop-through)))

(defucode net-transmit-dma
  (start-memory read physical %net-control-address)
  (io-board-bug-delay)
  (assign %net-memory-address (+ %net-packet-being-transmitted
				 (b-constant (field-word-offset 'ether-packet-dest-high))))
  (if (field-bit memory-data %%nsr-not-transmitting)
      (goto switch-to-receive)
    (drop-through))
  (parallel (transmit-dma %net-memory-address)
	    (assign %net-memory-address (1+ %net-memory-address))
	    (check-transmit-collision))
  (set-net-status %net-micro-status-transmitting)
  ;; Task switch
  (assign %net-block-pointer (+ %net-packet-being-transmitted
				(b-constant
				 (field-word-offset 'ether-packet-xmt-0-address))))
  (parallel (start-memory read physical %net-block-pointer)
	    (assign %net-block-pointer (1+ %net-block-pointer)))
  ;; 4 words, but 1 already done, = 3 - 1 = 2
  (assign %net-word-count (b-constant 2))
  ;; net-dma-temp is the address of the first users block
  (parallel (assign net-dma-temp memory-data)
	    (jump net-transmit-block-loop)))

(defucode net-transmit-next-block
  ;; Read this blocks count and the next blocks address
  (parallel (start-memory read physical %net-block-pointer)
	    (assign %net-block-pointer (1+ %net-block-pointer)))
  (parallel (start-memory read physical %net-block-pointer)
	    (assign %net-block-pointer (1+ %net-block-pointer)))
  (assign %net-word-count (1- memory-data))
  (parallel (assign net-dma-temp memory-data)
	    (jump net-transmit-block-loop)))

(defucode net-transmit-block-loop
  (parallel (transmit-dma %net-memory-address)
	    (assign %net-memory-address (1+ %net-memory-address))
	    (check-transmit-collision))
  (parallel (assign %net-word-count (1- %net-word-count))
	    (if (not (minus-fixnum obus))
		(goto net-transmit-block-loop)
	      (drop-through)))
  (parallel (assign %net-memory-address net-dma-temp)
	    (if (minus-fixnum net-dma-temp)
		(goto net-transmitted-last-word)
	      (goto net-transmit-next-block))))

(defucode net-transmitted-last-word
  ;; When started here, the last data word is in the shift register, we want
  ;; to cause it to go to state CRC after this word
  (parallel (transmit-dma %net-memory-address t t)
	    (check-transmit-collision))
4,887,235
	217	218
	(nop)
	;; Task switch
	;; Here the CRC is in the output shift register so check for collision
	(set-net-status %net-micro-status-transmit-done)
	(parallel (transmit-dma %net-memory-address t)
		  (check-transmit-collision))
	(parallel (wakeup-net-service)
		  (jump net-dma-dead)))

;; here we want to switch to receive mode if possible
(defucode switch-to-receive
  ;; Change to receive mode
  (parallel (start-memory write physical %net-control-address)
	    (assign memory-data (b-constant (get '%nsr-receive-start 'sysconstant))))
  (parallel (assign %net-block-pointer (+ (b-constant
					   (field-word-offset 'ether-packet-dest-high))
					  %net-packet-being-received))
	    (if (minus-fixnum %net-packet-being-received)
		(jump net-ignore-packet)
	      (drop-through)))
;XXXbrad next 3 lines really sketchy
  (assign %net-word-count (1- (b-constant 2)))
  ;;  and wait for first receive data
  (net-control nil t)
  (parallel (set-net-status %net-micro-status-receive-wait)
	    (jump net-receive-dma)))

;;; %net-backoff-count has the count to back off (units are 12.8 usec)
;;; Check to see if packet is coming in
(defucode backoff-timer
  (start-memory read physical %net-control-address)
  (io-board-bug-delay)
  (nop)
  (if (field-bit memory-data %%nsr-data-valid)
      (goto switch-to-receive)
    (drop-through))
  (net-control nil t)
  (parallel (assign %net-backoff-count (1- %net-backoff-count))
	    (if (minus-fixnum obus)
		(drop-through)
	      (goto backoff-timer)))
  ;; Here backoff has expired
  (terminate-net-dma %net-micro-status-idle))

;;: This is logically part of the device service stuff
(defucode net-service-loop
  (if (bit %%service-receive-end)
      (parallel (assign %%servics-receive-end (b-constant 0))
		(jump net-receive-completion))
    (drop-through))
  (if (bit %%service-transmit-collision)
      (parallel (assign %%service-transmit-collision (b-constant 0))
		(jump net-transmit-collision))
    (drop-through))
  (if (bit %%service-net)
      (dispatch-after-this net-micro-status
			   (assign %%service-net (b-constant 0))
	;; These are all functionally equivalent, keep hands off dma task
	((%net-micro-status-transmit-wait %net-micro-status-receiving
	  %net-micro-status-transmitting %net-micro-status-ignoring
	  %net-micro-status-backing-off)
	(jump device-service-end))
	((%net-micro-status-idle)
	 (goto service-net-idle))
	((%net-micro-status-reset)
	 (assign %net-backoff-count (b-constant -1))
	 (assign %net-packet-being-received (b-constant -1))
	 (parallel (assign %net-packet-being-transmitted (b-constant -1))
		   (jump reset-net-dma)))
	((%net-micro-status-receive-wait)
	 ;; If we have a packet to transmit, try to
	 (if (minus-fixnum %net-transmit-list)
	     (jump device-service-end)
	   ;; Otherwise, reset and go to idle
	   (goto reset-net-dma)))
	((%net-micro-status-transmit-done)
	 (goto service-net-transmit-done))
	)
    (drop-through))
  (jump device-service-end))

(defucode reset-net-dma
  (parallel (start-memory write physical %net-control-address)
	    (assign memory-data (b-constant (get '%nsr-error-clear 'sysconstant))))
  (for-effect (service-net-control t))
  (parallel (set-net-status %net-micro-status-idle)
	    (jump service-net-idle)))

(defucode service-net-idle
  (parallel (start-memory write physical %net-control-address)
	    (assign memory-data (b-constant (get '%nsr-error-clear 'sysconstant))))
  ;; Always prepare a pacKet to be received into
  (if (minus-fixnum %net-packet-being-received)
4,887,235
	219	220
	(parallel
	 (assign %net-packet-being-received %net-free-list)
	 (if (not (minus-fixnum %net-free-list))
	     (sequential
	      (phys-mem-read %net-free-list)
	      (assign %net-free-list memory-data))
	   (drop-through)))
	(drop-through))
  ;; If we can transmit, try to
  (if (minus-fixnum %net-packet-being-transmitted)
      (parallel
       (assign %net-packet-being-tranmitted %net-transmit-list)
       (if (minus-fixnum %net-transmit-list)
	   (drop-through)
	 (sequential
	  (parallel (phys-mem-read %net-transmit-list)
		    (assign %net-next-backoff (b-constant (1- (lsh 1 2)))))
	  (parallel (assign %net-transmit-list memory-data)
		    (jump start-net-transmitter)))))
    (goto start-net-transmitter))
  ;; Otherwise start receiver if we can
  (if (minus-fixnum %net-packet-being-received)
      (jump device-service-end)
      (drop-through))
  (set-net-status %net-micro-status-receive-wait)
  (assign %net-block-pointer (+ %net-packet-being-received
				(b-constant (field-word-offset 'ether-packet-dest-high))))
  (assign %net-word-count (1- (b-constant 2)))
  (parallel (start-memory write physical %net-control-address)
	    (assign memory-data (b-constant (get '%nsr-receive-start 'sysconstant))))
  (parallel (start-net-dma net-receive-dma)
	    (jump device-service-end)))

(defucode start-net-transmitter
  (if (minus-fixnum %net-backoff-count)
      (drop-through)
      (goto start-net-backoff))
  (set-net-status %net-micro-status-transmit-wait)
  (parallel (start-memory write physical %net-control-address)
	    (assign memory-data (b-constant (get '%nsr-transmit-start 'sysconstant))))
  (parallel (start-net-dma net-transmit-dma)
	    (jump device-service-end)))

;;; Sequencer special functions



;Halt the machine after executing this eicroinstructicn
(defmicro halt (reason)
  reason ;ignored
  '(microinstruction spec halt))

;Pop a word off of the control stack and put it into NPC
(defmicro popj-into-npc ()
  '(microinstruction sequencer pop-npc spec npc-magic magic 3 magic-mask 3))

;Read the top of the control stack and pop it (also puts it into NPC)
;Read the input to the NPC (taken from the control stack) onto the Lbus
;and do a microdevice read from a nonexistent device to get the Lbus into
;the datapath. Use the FEP board subdevice 1 as the nonexistent device
;(this drives bus dev cond from the page tags, but doesn't drive lbus data).
(defmicro pop-control-stack ()
  '(parallel (read-lbus-dev 36 1)
	     (microinstruction spec npc-magic magic 1 magic-mask 3 sequencer pop-npc
			       speed very-slow)))

;Write NPC from Obus; use task-dispatch in next cycle to branch there.
;The spec does all the work, but we also need to do a bogus microdevice write
;in order to make bus scheduling happen properly.
;Use subdevice 7 in the FEP board (only subdevices 0-2 exist).
(defmicro long-dispatch (data)
  (paralyze (get-to-obus32 data)
	    (selectq *machine-version*
		     ((sim proto)
		      '(microinstruction spec npc-magic magic 2 magic-mask 3
					 write-lbus obus lbus-dev-addr #.(+ 36_5 7)))
		     (otherwise
		      '(microinstruction spec npc-magic magic 2 magic-mask 3 mem microdevice
					 write-lbus obus lbus-dev-addr #.(+ 36_5 7))))))

;Uses b-temp
(defmicro read-csp ()
  (selectq *machine-version*
    ((sim proto) (retch "Cannot read CSP on old machine"))
    (otherwise '(sequential
		 (parallel (assign b-temp (read-lbus-dev 36 1))		;Read dummy device
			   (microinstruction spec npc-magic magic 1 magic-mask 3
					     speed very-slow))
		 (ldb b-temp 4 16.)))))

;Uses b-temp
4,887,235
	221	222
(defmicro read-cur-task-and-csp ()
  (selectq *machine-version*
	   ((sim proto) (retch "Cannot read CUR-TASK and CSP on old machine"))
	   (otherwise '(sequential
			(parallel (assign b-temp (read-lbus-dev 36 1))	;Read dummy device
				  (microinstruction spec npc-magic magic 1 magic-mask 3
						    speed very-slow))
			(ldb b-temp 8 16.)))))

;Write into an Lbus device
;NIL may be specified for the data, which means we don't care what's written
(defmicro write-lbus-dev (cord subdevice data)
  (setq data (microexpand data))
  (paralyze (and data (get-to-obus data))
	    (microexpand `(select-lbus-dev ,card ,subdevice))
	    (selectq *machine-version*
		     ((sim proto) '(microinstruction write-lbus obus))
		     ((tmc tmc5) `(microinstruction
				   write-lbus ,(cond ((null data) 'junk)
						     ((and (eq (car data) 'microdata)
							   (eq (cadr data) 'abus)
							   (fieldp (caddr data) 'abus 'memory-data))
						      'memory-data)
						     (t 'obus))
				   mem microdevice))
		     (otherwise '(microinstruction write-lbus obus mem microdevice)))))

;Read from an Lbus device
(defmicro read-lbus-dev (card subdevice)
  (make-microdata 'abus
    (paralyze (microexpand `(select-lbus-dev ,card ,subdevice))
	      (selectq *machine-version*
		       ((sim proto) '(microinstruction abus lbus))
		       (otherwise '(microinstruction abus lbus mem microdevice
						     speed slow-second-half))))))
			       ;slow-second-half is because the IO MD latch on the TMC
			       ;does not open until second half, and then the data still
			       ;have to propagate to the OP board and through 8304.
			       ;Need this to avoid GC map parity error.

(defmicro select-lbus-dev (card subdevice)
  (or (and (fixp card) (<= 0 card 37))
      (and (symbolp card) (get card 'symbolic-lbus-slot))
      (retch "~S illegal slot number" card))
  (or (and (fixp subdevice) (<= 0 subdevice 37))
      (retch "~S illegal subdevice number" subdevice))
  `(microinstruction lbus-dev-addr ,(if (symbolp card)
					`(,card ,subdevice)
				      (dpb card 0505 subdevice))))

(defmacro define-lbus-card (name)
  `(eval-when (compile load eval)
	      (defprop ,name t symbolic-lbus-slot)))

;Write the control register on the data path
(defmicro write-dp-control (source)
  (paralyze (get-to-obus32 source)
	    '(microinstruction spec load-control)))

(defatomicro lbus-dev-cond
  (microcondition not-lbus-dev-cond false nil))

;;; Tasking

(defmicro read-cur-task ()
  (selectq *machine-version*
	   ((sim proto) (retch "Cannot read CUR-TASK on old machine"))
	   (otherwise '(sequential
			(parallel (assign b-temp (read-lbus-dev 36 1))	;Read dumey device
				  (microinstruction spec npc-magic magic 1 magic-mask 3
						    speed very-slow))
			(ldb b-temp 4 20.)))))

(defmicro wakeup-task (n)
  (setq n (decode-task-number n))
  `(microinstruction spec awaken-task magic-mask 3
		     magic ,(or (find-position-in-list n '(1 2 5 6))
				(retch "~S illegal task number here" n))))

(defmicro write-task-state (n value)
  (setq n (decode-task-number n))
  (paralyze (get-to-obus32 value)
	    `(microinstruction spec write-task
			       mem microdevice write-lbus obus lbus-dev-addr #.(+ 36_5 7)
			       force-obus<33-32> ,(ldb 0002 n)
			       force-obus<35-34> ,(ldb 0202 n))))

(defun decode-task-number (n)
  (and (symbolp n) (get n 'sysconstant) (setq n (get n 'sysconstant)))
  (or (and (fixp n) (<= 0 n 17))
      (retch "~S illegal task number here" n))
4,887,235
	223	224
  n)

(defmicro dismiss ()
  '(microinstruction sequencer dismiss))

;Must be used twice in a row to work
(defmicro disable-tasking ()
  '(microinstruction spec disable-tasking))
;cdr-code-insertion hardware
(declare (special *cdr-codes*))		;in SIM
(defmicro set-cdr (val cdr)
  (let ((cdr-code
	 (if (numberp cdr) cdr (find-position-in-list cdr *cdr-codes*))))
    (or cdr-code (retch "~S undefined cdr code" cdr))
    (make-microdata 'obus
       `(parallel (get-to-obus ,val)
		  (microinstruction force-obus<35-34> ,cdr-code)))))

;data-type-insertion hardware
(declare (special *data-types*))	;in SIM
(defmicro set-type (val dtp)
  (let ((dtp-code (if (numberp dtp) dtp (find-position-in-list dtp *data-types*))))
    (or dtp-code (retch "~S undefined data type" dtp))
    (make-microdata 'obus
       `(parallel ,(get-to-obus32 val)
		  (microinstruction force-obus<33-32> ,(lsh dtp-code -4))
		  ,(if (not (memq dtp '(dtp-fix dtp-float)))
		       (let ((num (logand 17 dtp-code)))
			 `(microinstruction force-obus<31-28> ,num
					    magic ,num)))))))

;Set-cdr from a 'variable' rather than a 'constant'
;--- This and the next could be changed to allow background on BBus also
(defmicro merge-cdr (typed-pointer cdr-background)
  (make-microdata 'obus
		  (paralyze (get-to-obus typed-pointer)
			    (get-to-abus cdr-background)
			    '(microinstruction force-obus<35-34> abus))))

;Take low 32 bits from one source and high 4 from another
(defmicro merge-high-tag (typed-pointer tag-background)
  (make-microdata 'obus
		  (paralyze (get-to-obus32 typed-pointer)
			    (get-to-abus tag-background)
			    '(microinstruction force-obus<35-34> abus
					       force-obus<33-32> abus))))

;Storing into memory
;The type map for normal storing, which simply identifies whether or
;not a pointer is being stored. This is what enables the gc tag hardware.
(declare (special *storing-type-map*)) ;in UUX

;Store the contents of the currently-addressed memory location, with
;gc tag enabled, and with the cdr code coming from either a constant
;or the cdr field of another source or the same source (if unspecified).
;This is different from assigning to memory-data, because the
;latter is a lower-level operation which does not turn on the gc tagging.
;Note that the data to be stored is normally assumed to be a typed pointer and
;hence must come from the Abus so that it gets to the data type
;logic.
;The following options may be specified:
;	NOT-POINTER	- Value is known not to be a pointer, may come from Sbus
;	BLOCK	- Increment VMA after storing
;	car-code-name	- set cdr-code to that
;	(CDR source) 	- get cdr code from source (number, cdr-code name, or datum)
;	OBUS-AS-GOOD-AS-ABUS - this kiudge says that gc-map looking at abus data
;			instead of obus data will not hurt anything
;	NO-AMEM		- this kludge saus that we won't be writing a mapped-into-amem address
(defmicro store-contents (typed-pointer &rest options
			  &aux (cdr nil) (cdr-inst nil) (not-pointer nil) (block nil)
			  (obus-as-good-as-abus nil) (amem t))
;; Parse Options
(dolist (opt options)
  (cond ((eq opt 'not-pointer) (setq not-pointer t))
	((eq opt 'block) (setq block t))
	((eq opt 'obus-as-good-as-abus) (setq obus-as-good-as-abus t))
	((eq opt 'no-amem) (setq amem nil))
	((memq opt *cdr-codes*)
	 (setq cdr (find-position-in-list opt *cdr-codes*)))
	((and (listp opt) (eq (car opt) 'cdr))
	 ;; Decompose into cdr, the obus cdr-field forcing, and cdr-inst, other code.
	 (setq cdr (cadr opt))
	 (cond ((numberp cdr))
	       ((memq cdr *cdr-codes*)
		(setq cdr (find-position-in-list cdr *cdr-codes*)))
	       ;((eq cdr 'memory-data)) ;this misfeature has been flushed from the hardware
	       ((and (not (atom (setq cdr-inst (microexpand cdr))))
		     (eq (cor cdr-inst) 'microdata)
		     (memq (cadr cdr-inst) '(abus bbus))) 	;abus-only on the proto...
		(setq cdr (cadr cdr-inst)
		      cdr-inst (caddr cdr-inst)))
4,887,235
	225	226
		(t (retch "~S not a data source that can feed cdr field" cdr)
		   (setq cdr nil cdr-inst nil))))
	(t (retch "~S not a valid option" opt))))
(paralyze (cond (not-pointer
		 (get-to-obus typed-pointer))
		(obus-as-good-as-abus
		 (paralyze
		  (get-to-obus typed-pointer)

		  `(microinstruction type-map ,*storing-type-map*)))
		(t
		 (paralyze
		  (get-to-abus typed-pointer)
		  `(microinstruction type-map ,*storing-type-map*
				     xbus abus
				     alu xbus))))
	  (and cdr `(microinstruction force-obus<35-34> ,cdr))
	  cdr-inst
	  (and amem '(microinstruction amem-write-addr (bus-address)))
	  (selectq *machine-version*
		   ((sim proto)
		    (if block (retch "store-contents block option not implemented"))
		    '(microinstruction write-lbus obus
				       lbus-dev-addr write-memory
				       trap-enables (map-miss)
				       mem start-cycle))
		   (otherwise
		    (microexpand (if (not block)
				     '(start-memory write)
				     '(start-memory write block)))))))
;ALU operations

;You get 16 functions of each kind
;Things depend on XBUS and ALUB not being weird
(defconst normal-alu-functions
  	  '(xbus alub X+1 X-1 X+Y X-Y X+Y+1 X-Y-1 and ior xor)) ;5 spares

(defconst weird-alu-functions
  	  '(X+1-overflow X-1-overflow X+Y-overflow X-Y-overflow
	    X-Y-signed X-Y-1-signed nand andcy))	;8 spares

(defun alu-microinstruction (func)
  (cond ((memq func normal-alu-functions)
	 `(microinstruction alu ,func))
	((memq func weird-alu-functions)
	 `(microinstruction alu ,func spec arithmetic-trap-enb magic 4))
	(t (retch "~S undefined ALU function" func))))

;Define 1-operand ALU function
;Hair so that ybus operands work, too.
(defmacro defaluop1 (name field ycode &optional other-code)
  `(defmicro ,name (x-opnd)
     (setq x-opnd (microexpand x-opnd))
     (paralyze (if (memq (cadr x-opnd) '(ybus alub))
		   (microexpand (subst x-opnd 'y ',ycode))
		   (make-microdata 'obus
				   (alu-paralyze (get-to-xbus x-opnd)
						 (alu-microinstruction ',field))))
	       ',other-code)))

;Define 2-operand ALU function (optional third operand is constant 1)
;If one-operand? is specified it is code for the one-operand case
;otherwise require 2 or 3 operands.
(defmacro defaluop2 (name field
		     &optional commutative? third-operand? one-operand?
		               other-code)
  `(defmicro ,name (x-opnd
		    ,@(if one-operand? '(&optional))
		    y-opnd
		    ,@(if third-operand?
			  (if (not one-operand?)
			      '(&optional one)
			      '(one))))
     ,(if third-operand?
	  `(or (null one) (equal one 1)
	       (retch "Third operand to ~S must be 1, not ~S" ',name one)))
     ,(let ((two-op-code
	     `(make-microdata 'obus
	         (alu-paralyze ,@(if commutative?
				     '((get-to-xbus-and-alub x-opnd y-opnd))
				     '((get-to-xbus x-opnd) (get-to-alub y-opnd)))
			       (alu-microinstruction
;XXXbrad - '` ?
				,(if (not third-operand?) `',field
				   `(if one ',third-operand? ',field)))))))
	(if (null other-code)
	    (if (not one-operand?) two-op-code
	      `(if u-opnd ,two-op-code
		 (subst x-opnd 'arg ',one-operand?)))
	  ``(parallel ,,(if (not one-operand?) two-op-code
			  `(if y-opnd ,two-op-code
			     (subst x-opnd 'arg ',one-operand?)))
4,887,235
	227	228
	,',other-code)))))

(defaluop1 1+ X+1 (xbus-constant-hack X+Y 1 y))
(defaluop1 I- X-1 (xbus-constant-hack X+Y -1 y))
(defaluop2 + X+Y t X+Y+1)
(defaluop2 - X-Y nil X-Y-1 (xbus-constant-hack X-Y 0 arg))
(defaluop2 commutative-diff X-Y t X-Y-1)
(defaluop2 logand and t)
(defaluop2 lognand nand t)
(defaluop2 logior ior t)
(defaluop2 logxor xor t)
(defaluop2 andc2 andcy nil)

(defaluop1 inc-checking-overflow X+1-overflow
  (xbus-constant-hack X+Y-overflow 1 y)
  (microinstruction trap-enables (overflow)))
(defaluop1 dec-checking-overflow X-1-overflow
  (xbus-constant-hack X+Y-overflow -1 y)
  (microinstruction trap-enables (overflow)))
(defaluop2 add-checking-overflow X+Y-overflow t nil nil
  (microinstruction trap-enables (overflow)))
(defaluop2 sub-checking-overflow X-Y-overflow nil nil nil
  (microinstruction trap-enables (overflow)))

;Used internally: ALU can also feed through xbus or alub

;This piece of hair generates an ALU operation with a constant on
;the xbus and an argument on the alub. The hair is to decide which
;memory to put the constant in.
(defmicro xbus-constant-hack (alu-op constant y-opnd)
  (setq y-opnd (get-to-alub y-opnd))
  (make-microdata 'obus
    (alu-paralyze y-opnd
		  (get-to-xbus (if (uses-bbus y-opnd) `(a-constant ,constant)
				    '(b-constant constant)))
		  `(microinstruction alu ,alu-opb))))

(defun uses-bbus (instruction)
  (cond ((eq (car instruction) 'microsequence)
	 (uses-bbus (car (last instruction))))
	((eq (car instruction) 'microinstruction)
	 (loop for (field value) on (cdr instruction)
	       thereis (eq field 'bbus)))
	((eq (car instruction) 'microdata)
	 (uses-bbus (caddr instruction)))
  (t (retch "uses-bbus: What da fuck is dis? -- ~S" instruction))))




(defun alu-paralize1 (inst)
  (selectq (car mint)
    ((microinstruction)
     (and (memq (get inst 'alu) '(X+Y X-Y X+Y+1 X-Y-1 X+Y-overflow X-Y-overflow
				  X-Y-signed X-Y-1-signed))
	  (selectq (get inst 'ybus)
	    (abus (selectq (get inst 'abus)
		    ((amem) (let ((a (get inst 'amem-read-addr)))
			      (or (atom a) (neq (car a) 'constant))))
		    ((memory-data memory-data-force lbus map) t)
		    (otherwise nil)))	;bases, vma, pc are fast
	    (bbus (selectq (get inst 'bbus)
		    ((bmem) (let ((a (get inst 'bmem-read-addr)))
			      (or (atom a) (neq (car a) 'constant))))
		    (otherwise nil)))) ;macro-immediate's are fast
	  (setq inst (paralyze inst '(microinstruction speed slow-second-half))))
     inst)
    ((microsequence)
     (cons 'microsequence (mapcar #'alu-paralyze1 (cdr mint))))
    (otherwise (retch "~S not a microinstruction" inst))))
;;; Support for byte fields

(defmacro byte-mask (ppss)
  (dpb -1
       (cond ((numberp ppss))
	     ((not (get ppss 'byte-field))
	      (retch "~S not a defined byte field" ppss))
	     ((car (get ppss 'byte-field))))
       0))

(defun byte-pp (ppss)
  (lsh ppss -6))

(defun byte-ss (ppss)
  (logand 77 ppss))
4,887,235
	229	230
(defun byte-pp-reflected (ppss)
  (logand 37 (- 40 (byte-pp ppss))))

(defun byte-numbers-to-ppss (n-bits bits-over)
  (+ (lsh bits-over 6) n-bits))

(defmacro defatomic-byte-field (name byte-specifier register)
  (let ((*backtrace* (cons `((defatomic-byte-field ,name)) *backtrace*))
	(ppss (if (listp byte-specifier)
		  (byte-numbers-to-ppss (first byte-specifier) (second byte-specifier))
		(car (get byte-specifier 'byte-field)))))
    (or ppss (ferror nil "~S not defined as a system byte" byte-specifier))
    `(eval-when (compile load eval)
       (defprop ,name (,ppss ,register) byte-field)
       (defatomicro ,name
	 ,(make-microdata 'alub
			  (paralyze (get-to-ybus register)
				    `(microinstruction
				      byte-func (ldb ,(byte-pp-reflected ppss)
						     ,(byte-ss ppss)))))))))

(defmacro def-byte-field (name byte-specifier place)
  (let ((*backtrace* (cons `((def-byte-field ,name)) *backtrace*))
	(ppss (if (listp byte-specifier)
		  (byte-numbers-to-ppss (first byte-specifier) (second byte-specifier))
		(car (get byte-specifier 'byte-field)))))
    (or ppss (ferror nil "~S not defined as a system byte" byte-specifier))
    `(eval-when (compile load eval)
       (defprop ,name (,ppss) byte-field)
       (defmicro ,name (,place)
	 (make-microdata 'alub
	   (paralyze (get-to-ybus ,place)
		     `(microinstruction
		          byte-func (ldb ,',(byte-pp-reflected ppss)
					 ,',(byte-ss ppss)))))))))

;Use this to define the a-list of symbolic dispatch cues associated with a field
(defmacro associate-dispatch-cues (field-name enumerated-type-name)
  `(eval-when (compile load eval)
     (defprop ,field-name ,enumerated-type-name enumerated-type-name)))

;Use this to define them as atomicros that are B-constants
(defmacro define-enumerated-value-constants (enumerated-type-name)
  (let ((codes (get enumerated-type-name 'enumerated-type-codes)))
    (if (null codes)
	(ferror nil "~S not declared as an enumerated type" enumerated-type-name))
    `(progn 'compile
       . ,(loop for (code . value) in codes
		collect `(defatomicro ,code
			   (b-constant ,value))))))

;Similar, for word offsets in a defstorage
(defmacro define-storage-word-offset-constants (defstorage-type-name)
  (let ((fields (get defstorage-type-name 'defstorage-fields)))
    (if (null fields)	
	(ferror nil "~S not declared as a defstorage type" defstorage-type-name))
    `(progn 'compile
       . ,(loop for field in fields
		collect `(defatomicro ,field
			   (b-constant ,(field-word-offset field)))))))

;Similar for a single constant defined with defsysconstant
(defmacro define-sysconstant (name)
  (or (get name 'sysconstant) (ferror nil "~S not declared with defsysconstant"))
  `(defatomicro ,name
     (b-constant ,(get name 'sysconstant))))

;;; Micros for more direct access to the shift/mask/merge logic
(defmicro rotate (opnd left-amt)
  (make-microdata 'alub
    (paralyze (get-to-ybus opnd)
	      `(microinstruction byte-func (ldb ,left-amt 32.)))))

(defmicro ldb (cond n-bits bits-over &optional background)
  (if (equal background 0) (setq background nil))
  (validate-byte-specifier n-bits bits-over)
  (make-microdata 'alub
    (paralyze (get-to-ybus opnd)
	      `(microinstruction
		byte-func (ldb ,(selectq bits-over
					 ((byte-r macro) bits-over)
					 (otherwise (logand 37 (- 40 bits-over))))
			       ,n-bits
			       ,@(if background '(merge))))
	      (if background (get-to-xbus background)))))

(defmicro dpb (opnd n-bits bits-over background)
  (if (equal background 0) (setq background nil))
  (validate-byte-specifier n-bits bits-over)
  (make-macrodata 'alub
4,887,235
	231	232
	(paralyze (get-to-ybus opnd)
		  `(microinstruction byte-func (dpb ,bits-over ,n-bits
						    ,@(if background '(merge))))
		  (if background (get-to-xbus background)))))

;Alternate version of LDB used by certain hacks (sunprimitives)
;Allows uou to take advantage of the fact that bytes split across the
;end of the word work (i.e. it really is a rotate followed by a mask).
(defmicro strange-ldb (opnd n-bits bits-over &optional background)
  (if (equal background 0) (setq background nil))
  (make-microdata 'alub
    (paralyze (get-to-ybus opnd)
	      `(microinstruction
		byte-func (ldb ,(logand 37 (- 40 bits-over))
			       ,n-bits
			       ,@(if background (merge))))
	      (if background (get-to-xbus background)))))

;Ensure that the specified byte lies within the low 32 bits and is otherwise legal.
(defun validate-byte-specifier (n-bits bits-over)
  (or (symbolp n-bits)
      (<= 1 n-bits 32.)
      (retch "The number of bits, ~S, is not between 1 and 32." n-bits))
  (or (symbolp bits-over)
      (<= 0 bits-over 31.)
      (retch "The bit position, ~S, is not between 0 and 31." bits-over))
  (or (symbolp n-bits) (symbolp bits-over) (<= (+ n-bits bits-over) 32.)
      (retch "The byte specified at ~S ~S overlaps the 32-bit word boundary"
	     n-bits bits-over)))

;Invoke special hair in the SHFMSK0 PAL
(defmicro complemented-sign-bit (opnd)
  `(parallel (ldb ,opnd 1 31.)
	     (microinstruction spec alub-sign-hack)))

;Get a byte by name rather than by bits,bits-over.
(defmicro ldb-field (operand field-name &optional (background 0))
  (multiple-value-bind (n-bits bits-over)
       (decode-byte-field-specifier field-name)
       `(ldb ,operand ,n-bits ,bits-over ,background)))

(defmicro dpb-field (operand field-name background)
  (multiple-value-bind (n-bits bits-over)
      (decode-byte-field-specifier field-name)
      `(dpb ,operand ,n-bits ,bits-over ,background)))

(defmacro ldb-field (operand field-name)
  (let ((ppss (car (get field-name 'byte-field))))
    (or ppss (ferror "~S is not a defined byte field" field-name))
    `(ldb ,ppss ,operand)))

(defmacro dpb-field (operand field-name background)
  (let ((ppss (car (get field-name 'byte-field))))
    (or ppss (ferror "~S is not a defined byte field" field-name))
    `(dpb ,operand ,ppss ,background)))

(defmacro field-mask (field-name)
  (let ((ppss (car (get field-name 'byte-field))))
    (or ppss (ferror "~S is not a defined byte field" field-name))
    (dpb -1 ppss 0)))

(defmicro field-bit (operand field-name)
  (multiple-value-bind (n-bits bits-over)
      (decode-byte-field-specifier field-name)
      (or (= n-bits 1) (retch "~S is not a single-bit field" field-name))
      (make-microcondition 'alub-0 'true
			   (paralyze `(microinstruction
				       byte-func (ldb ,(logand 37 (- 40 bits-over)) ,n-bits))
				     (get-to-ybus operand)))))

(defun decode-byte-field-specifier (field-name)
  (let ((ppss (car (get field-name 'byte-field))))
    (or ppss (retch "~S is not a defined byte field" field-name))
    (values (logand 77 ppss)
;XXXbrad -6?
	    (lsh ppss -6))))
;;;Since the proto machine is dead, don't bother checking.
(defatomicro byte-s
  (ldb ybus-crocks-2 5 24.))

(defatomicro byte-r
  (ldb ybus-crocks-1 5 24.))

;;; Multiplication

;Reading out the 32-bit signed product of X and Y registers
(defatomicro mpy-product
  (microdata xbus
	     (microinstruction xbus product
			       spec multiply
;XXXbrad magic 4?
			       magic 4
			       speed very-slow)))