4,887,235
	573	574

  (assign vma b-vma)
  (start-memory read)
  (nop)
  (assign a-memory-data memory-data)
  ;Point vma at the first data word in the array
  (assign vma a-memory-data) ;Kludge for temporary memory control (field overlap)
  (assign vma (+ (array-leader-length-field vma) b-vma 1))
  ;Dispatch on the array type field
  (parallel (assign a-temp (array-short-length-field a-memory-data))
	    (assign byte-r array-index-shift-prom)
	    (dispatch-after-next (array-type-field a-memory-data)
	      ((art-1b) (as-1-ucode 1))
	      ((art-2b) (as-1-ucode 2))
	      ((art-4b) (as-1-ucode 4))
	      ((art-8b art-string) (as-1-ucode 8))
	      ((art-16b art-fat-string) (as-1-ucode 16.))
	      ((art-q art-q-list) (as-1-ucode Word))
	      ((art-boolean) (as-1-ucode 1 t))
	      (otherwise (signal-error unimplemented-or-illegal-array-type))))
  ;Point VMA at the addressed data word
  (parallel (assign vma (+ vma (ldb top-of-stack 27. byte-r)))
  (take-dispatch)))

;Hairier cases of AS-1.
(defucode as-1-hair
  (parallel (assign vma b-vma)			;Find out everything about this array
	    (call-and-return-to array-setup-1d as-1-hair-a)))

(defucode as-1-hair-a
  (parallel
   (assign byte-r array-index-shift-prom)
   (dispatch-after-next
    (array-register-dispatch-field (amem (stack-pointer 1)))
    ((%array-register-dispatch-1-bit) (as-1-hair 1))
    ((%array-register-dispatch-2-bit) (as-1-hair 2))
    ((%array-register-dispatch-4-bit) (as-1-hair 4))
    ((%array-register-dispatch-8-bit) (as-1-hair 8))
    ((%array-register-dispatch-16-bit) (as-1-hair 16.))
    ((%array-register-dispatch-word) (as-1-hair Word))
    ((%array-register-dispatch-boolean) (as-1-hair 1 t))
    (otherwise (signal-error unimplemented-or-illegal-array-type))))
  ;set the VMA
  (parallel
     (assign vma (+ (amem (stack-pointer 2))
		    (ldb top-of-stack 27. byte-r)))
     (take-dispatch)))
;;; Array leaders

;Format 1: Array on the stack, subscript as unsigned immediate argument
(definst array-leader-immed unsigned-immediate-operand
   (parallel (check-arg-type array top-of-stack-a dtp-array)
	     (assign vma top-of-stack-a)
	     (assign b-vma top-of-stack-a)
	     (call array-setup-leader))
   (assign vma (+ (amem (stack-pointer 2)) micro-unsigned-immediate))
   (array-ucode-read Word nil macro-unsigned-immediate
		     (amem (stack-pointer 3)) newtop))

;Format 3: Array and subscript on the stack
(definst array-leader (no-operand needs-stack)
  (parallel (check-arg-type array next-on-stack dtp-array)
	    (assign vma next-on-stack)
	    (assign b-vma next-on-stack)
	    (call array-setup-leader))
  (assign vma (+ (amem (stack-pointer 2)) top-of-stack))
  (array-ucode-read Word nil top-of-stack (amem (stack-pointer 3)) pop2push))

;Format 3: Value, array, and subscript on the stack
(definst store-array-leader (no-operand needs-stack smashes-stack)
  (parallel (check-arg-type array next-on-stack dtp-array)
	    (assign vma next-on-stack)
	    (assign b-vma next-on-stack)
	    (call array-setup-leader))
  (parallel (decrement-stack-pointer)
	    (assign vma (+ (amem (stack-pointer 2)) top-of-stack)))
  (array-ucode-write Word nil top-of-stack (amem (stack-pointer 4)) next-on-stack))

;Format 1: Value and array on the stack. subscript as unsigned immediate
(definst store-array-leader-immed (unsigned-immediate-operand smashes-stack)
  (parallel (check-arg-type array top-of-stack-a dtp-array)
	    (assign vma top-of-stack-a)
	    (assign b-vma top-of-stack-a)
	    (call array-setup-leader))
  (assign vma (+ (amem (stack-pointer 2)) macro-unsigned-immediate))
  (array-ucode-write Word nil macro-unsigned-immediate
		     (amem (stack-pointer 3)) next-on-stack))

;;; Accessing of arbitrary arrays as if they were 1-dimensional, and ALOC

(definst %1d-aref (no-operand needs-stack)
  ;First step is to check operand types and fetch array header
4,887,235
	575	576

  (parallel (check-arg-type array next-on-stack dtp-array)
	    (assign vma next-on-stack)
	    (assign b-vma next-on-stack)
;XXXbrad as-1-hair-a?
	    (call-and-return-to array-setup-force-1d as-1-hair-a)))

(definst %1d-aset (no-operand needs-stack smashes-stack)
  (parallel (check-arg-type array next-on-stack dtp-array)
	    (assign vma next-on-stack)
	    (assign b-vma next-on-stack)
	    (call-and-return-to array-setup-force-1d as-1-hair-a)))

(definst %1d-aloc (no-operand needs-stack)
  (parallel (check-arg-type array next-on-stack dtp-array)
	    (assign vma next-on-stack)
	    (assign b-vma next-on-stack)
	    (call-and-return-to array-setup-force-1d ap-1-hair-a)))

(definst ap-1 (no-operand needs-stack)
  (parallel (check-arg-type array next-on-stack dtp-array)
	    (assign vma next-on-stack)
	    (assign b-vma next-on-stack)
	    (call-and-return-to array-setup-1d ap-1-hair-a)))

(definst ap-leader (no-operand needs-stack)
  (parallel (check-arg-type array next-on-stack dtp-array)
	    (assign vma next-on-stack)
	    (assign b-vma next-on-stack)
	    (call-and-return-to array-setup-leader ap-1-hair-a)))

(defucode ap-1-hair-a
  (if (equal-fixnum (array-register-dispatch-field (amem (stack-pointer 1)))
		    %array-register-dispatch-word)
      (parallel
       (pop2push (set-type (+ (amem (stack-pointer 2)) top-of-stack) dtp-locative))
       (next-instruction))
    (signal-error locative-to-non-word-array)))

;;; Decoding 2-dimensional arrays
;;; Same as array-setup-1d except (amem (stack-pointer 3)) gets the width
;;; and (amem (stack-pointer 4) gets the height

(defucode array-setup-2d
  ;Fetch first word of array prefix
  (parallel (start-memory read)
	    (assign (amem (stack-pointer 1)) array-register-event-count))
  (nop)		;Time for memory
  ;Copy header because of temporary memory control
  (parallel
   (transport header)
   (assign a-memory-data memory-data)) ;temporary memory control
  ;Dispatch on kind, copy header to B side
  (parallel
   (assign b-temp a-memory-data)
   (dispatch-after-next (array-dispatch-field a-memory-data)
     ((%array-display-short-2d)
      (assign (amem (stack-pointer 3)) (set-type (array-rows-field b-temp) dtp-fix))
      (parallel
       (assign (amem (stack-pointer 4)) (set-type (array-columns-field b-temp) dtp-fix))
       (return)))
     ((%array-dispatch-long-multidimensional)
      (error-if	(not-equal-fixnum (array-dimensions-field a-memory-data) (b-constant 2))
		unimplemented-or-illegal-array-type)
      (assign b-temp (1- (array-long-prefix-length-field a-memory-data)))
      (parallel					;Save pointer to last word in prefix
       (assign (amem (stack-pointer 4)) (set-type (+ vma b-temp) dtp-locative))
       (call array-setup-long))
      ;; Now (ames (stack-pointer 2)) has the overall length and
      ;; (amem (stack-pointer 4)) has the address of the width -- convert to U and H
      ;; This could certainly be more modular...but can’t use the stack here
      (memread (amem (stack-pointer 4)))
      (assign a-positive-divisor memory-data)
      (assign a-negative-divisor (- a-positive-divisor))
      (assign b-low-dividend (amem (stack-pointer 3)))
      (assign-high-dividend (b-constant 0))
      (assign (amem (stack-pointer 3)) a-positive-divisor)
      (parallel (assign a-divide-step-count (a-constant 15.))
		(call divide-subroutine))	;15=32/2-1
      (parallel (assign (amem (stack-pointer 4)) (set-type b-low-dividend dtp-fix))
		(return)))
     (otherwise (signal-error unimplemented-or-illegal-array-type))))
  ;Set basepointer to word containing firot array element, assuming fast case
  (parallel (assign (amem (stack-pointer 2))
		    (set-type (1+ vma) dtp-locative))
	    (take-dispatch)))

;;: 2-dimensionai array referencing
;;; Don’t use tne decode routine on previous pigs to avoid extra mpy and div

;Call with stack containing array and 2 subscripts
;Return with stack popped once and "linear" subscript in top-of-stack (B side only)
;Return with a-memory-data containing array header word, a-array-base containing data address
;Ihis microcode checks array type, dimensionality, subscript type, and bounds
4,887,235
	577	578

(defmicro 2d-array-index ()
  '(parallel (check-arg-type array (amem (stack-pointer -2)) dtp-array)
	     (assign vma (amem (stack-pointer -2)))
	     (assign b-vma (amem (stack-pointer -2)))
	     (call 2d-array-index)))

(defucode 2d-array-index
  (parallel (start-memory read)
	    (check-arg-type subscript top-of-stack-a dtp-fix))
  (check-arg-type subscript next-on-stack dtp-fix)
  (parallel (transport header)
	    (assign b-temp memory-data)
	    (assign a-memory-data memory-data))
  (if (equal-fixnum (array-dispatch-field a-memory-data) %array-dispatch-short-2d)
      (goto 2d-array-index-short)
      (drop-through))
  (error-if (not-equal-fixnum (array-dispatch-field a-memory-data)
			      %array-dispatch-long-multidimensional)
	    unimplemented-or-illegal-array-type)
  (error-if (not-equal-fixnum (array-dimensions-field a-memory-data) (b-constant 2))
	    unimplemented-or-illegal-array-type)
  (assign b-temp-2 (1- (array-long-prefix-length-field a-memory-data)))
  (assign top-of-stack (a-constant 0))		;accumulate index offset here
  (parallel (assign a-temp-2 (set-type (+ vma b-temp-2) dtp-locative)) ;last wd in prefix
	    (call array-setup-long))		;Slower than necessary, but...
  (assign a-memory-data b-temp)			;Restore array header
  (assign a-array-base (amem (stack-pointer 2)))	;Base pointer
  (assign a-index-offset top-of-stack)
  (parallel (assign vma a-temp-2)	;Get the number of rows
	    (cal pushmem))
  (parallel (pushval next-on-stack)	;times the second subscript
	    (call 32-bit-multiply))
  (error-if (not (all-ones (- top-of-stack (complemented-sign-bit next-on-stack))))
	    illegal-subscript)			;multiply overflowed
	  ;--- this bounds checking probably has bugs in it ---
	  ;--- who cares, the array format is going to change anyway ---
  (assign b-temp-2 (amem (stack-pointer -3)))
  (parallel (assign top-of-stack (+ next-on-stack b-temp-2))	;add first subscript
	    (error-if (minus-fixnum obus) illegal-subscript)	;check for overflow in add
	    (decrement-stack-pointer))
  (parallel (error-if (greater-or-equal-fixnum-unsigned top-of-stack (amem (stack-pointer 2)))
		      illegal-subscript)
	    (decrement-stack-pointer))
  (parallel (assign top-of-stack (+ top-of-stack a-index-offset))
	    (decrement-stack-pointer)
	    (return)))

(defucode 2d-array-index-short
  ;; Short. fast case. Data follow header immediately
  (assign a-array-base (set-type (1+ b-vma) dtp-locative))
  ;; Check bounds
  (error-if (greater-or-equal-fixnum-unsigned next-on-stack (array-rows-field b-temp))
	    illegal-subscript)
  (error-if (greater-or-equal-fixnum-unsigned top-of-stack-a (array-columns-field b-temp))
	    illegal-subscript)
  ;; Column-major order so multiply second subscript by first dimenmion
  ;; Doing 9x9 unsignod multiply with no overflow possible, so open-code for speed
  (assign b-temp-2 (dpb b-temp 9 16. 0))	;array-rows-field in left half
  (parallel (write-mpy-x top-of-stack-a unsigned)
	    (write-mpy-y-from-high b-temp-2 unsigned))
  (parallel (assign top-of-stack (set-type (+ next-on-stack mpy-product) dtp-fix))
	    (decrement-stack-pointer)
	    (return)))

(definst ar-2 (no-operand)
  (2d-array-index)
  ;Dispatch on the array type field
  (parallel (assign byte-r array-index-shift-prom)
	    (dispatch-after-next (array-type-field a-memory-data)
	      ((art-1b) (ar-1-ucode 1 nil nil))
	      ((art-2b) (ar-1-ucode 2 nil nil))
	      ((art-4b) (ar-1-ucode 4 nil nil))
	      ((art-8b art-string) (ar-1-ucode 8 nil nil))
	      ((art-16b art-fat-string) (ar-1-ucode 16. nil nil))
	      ((art-q art-q-list) (ar-1-ucode Word nil nil))
	      ((art-boolean) (ar-1-ucode 1 t nil))
	      (otherwise (signal-error unimplemented-or-illegal-array-type))))
  ;Point vma at the adoressed data word
  (parallel (assign vma (+ a-array-base (ldb top-of-stack 27. byte-r)))
	    (take-dispatch)))

(definst as-2 (no-operand smashes-stack)
  (2d-array-index)
  ;Dispatch on the array type field
  (parallel (assign byte-r array-index-shift-prom)
	    (dispatch-after-next (array-type-field a-memory-data)
	      ((art-1b) (as-1-ucode 1 nil nil))
	      ((art-2b) (as-1-ucode 2 nil nil))
	      ((art-4b) (as-1-ucode 4 nil nil))
	      ((art-8b art-string) (as-1-ucode 8 nil nil))
4,887,235
	579	580
	      ((art-16b art-fat-string) (as-1-ucode i6. nil nil))
	      ((art-q art-q-list) (as-1-ucode Word nil nil))
	      ((art-booleon) (as-1-ucode 1 t nil))
	      (otherwise (signal-error unimplemented-or-illegal-array-type))))
  ;Point VMA at the addressed data word
  (parallel (assign vma (+ a-array-base (ldb top-of-stack 27. byte-r)))
	    (take-dispatch)))



(definst ap-2 (no-operand)
  (2d-array-index)
  (parallel (pop2push (set-type (+ a-array-base top-of-stack) dtp-locative))
	     (next-instruction)))

;;; Array register accessing instructions





;flavor is write, pushval, or newtop
(defmicro array-register-ucode (flavor)
  ;Get control word, dispatch, check event count, set byte-r
  ;Note that the xct-next cycle is buried inside the IF
 '(parallel
   (assign byte-r array-index-shift-prom)
   (increment-macro-immediate)
   (dispatch-after-next (array-register-dispatch-field address-operand)
     ,@(loop for n from 0 below 7
	     collect '((,n) (,(if (eq flavor 'write)
				  'array-register-ucode-write
				  'array-register-ucode-read)
			     ,(nth n '(1 2 4 8 16. q q q 1)1)
			     ,(= n 10)
			     ,flavor)))
     (otherwise (signal-error unimplemented-case-in-array-register)))
   (if (equal-pointer address-operand array-register-event-count)
       ;Set the VMA. Can’t type-check the subscript yet (spec field busy)
       (parallel
	(assign vma (+ address-operand (ldb top-of-stack 27. byte-r)))
	(increment-macro-immediate)	y
	(take-dispatch))
     ;Need to trap out and re-decode array, something has changed
     (goto array-register-recompute))))

(defmicro array-register-ucode-read (byte-size boolean-hack result)
  (array-ucode-read ,byte-size ,boolean-hack
		    top-of-stack address-operand ,result))

(defmicro array-register-ucode-write (byte-size boolean-hack ignore)
  (array-ucode-write ,byte-size ,boolean-hack
		     top-of-stack address-operand next-on-stack))

(definst fast-aref-pop (address-operand needs-stack) ;Subscript on stack, popped
  (array-register-ucode newtop))

(definst fast-aref-nopop (address-operand needs-stack) ;Subscript on stack, left there
  (array-register-ucode pushval))

						;Value and subscript on stack. popped
(definst fast-aset (address-operand needs-stack smashes-stack)
  (array-register-ucode write))

;Setting up array registers

;Leave array on the stack, and push control word, base pointer,
;upper bound, and lower bound
(definst setup-1d-array-sequential no-operand
  ;Call the standard array decoding stuff, get first three words on stack
  (parallel (check-arg-type array top-of-stack-a dtp-array)
	    (assign vma top-of-stack-a)
	    (assign b-vma top-of-stack-a)
	    (call array-setup-1d-zero))
   ;Advance the stack-pointer to leave it on the stack
  (assign stack-pointer (+ stack-pointer (b-constant 3)))
  ;Also push the lower bound
  (parallel (pushval top-of-stack)
	    (next-instruction)))

;Same as above but don’t push lower bound
;Leaves TOS incorrect
(definst setup-1d-array (no-operand smashes-stack)
  ;Call the standard array decoding stuff, get first three words on stack
  (parallel (check-arg-type array top-of-stack-a dtp-array)
	    (assign vma top-of-stack-a)
	    (assign b-vma top-of-stack-a)
	    (call array-setup-1d-zero))
  ;Now if the lower bound is non-zero, either factor it into the base
  ;pointer or set it to work the slow way. For now always the slow way
  (if (zero-fixnum top-of-stack)
      (drop-through)
4,887,235
	581	582
	(assign	(array-register-dispatch-field (amem (stack-pointer 1)))
		(b-constant 7)))
  (parallel (assign stack-pointer (+ stack-pointer (b-constant 3)))
	    (next-instruction)))

;Set up an array register, with upper and lower bounds, for a subset
;of an array defined by standard from and to arguments (either can
;be nil. which means use the extreme end of the array).
;---This assumes the array is always zero origin, in its error checking
;---of the bounds. I’m not sure whether that is a feature or a bug,
;---there seems to be some general fuzzy thinking here.
;---I'm also not sure what happens if have to use "slow array register" here
(definst setup-1d-array-from-to no-operand
  ;Call the standard array decoding stuff, get first three words on stack
  ;and get the index-offset in top-of-stack
  (parallel (check-arg-type array (amem (stack-pointer -2)) dtp-array)
	    (assign vma (amem (stack-pointer -2)))
	    (assign b-vma (amem (stack-pointer -2)))
	    (call array-setup-1d-zero))
  ;Apply index offset to upper and lower bounds, plug thus in to array reg
  (parallel
   (check-arg-type subscript (amem (stack-pointer 0)) dtp-nil dtp-fix)
   (if (data-type? (amem (stack-pointer 0)) dtp-fix)
       (sequential
	(parallel
	 (assign b-temp (+ (amem (stack-pointer 0)) top-of-stack))
	 ;This check is because we will be using unsigned comparison later
	 (error-if (minus-fixnum obus) illegal-subscript))
	;This check is for TO being specified as off the end of the array
	(error-if (lesser-fixnum (amem (stack-pointer 3)) b-temp)
		  illegal-subscript)
	(assign (amem (stack-pointer 3)) (set-type b-temp dtp-fix)))
     ;If TO not specified, use array’s upper bound
     (drop-through)))
  (parallel
   (check-arg-type subscript (amem (stack-pointer -1)) dtp-nil dtp-fix)
   (if (data-type? (amem (stack-pointer -1)) dtp-fix)
       (sequential
	(error-if (minus-fixnum (amem (stack-pointer -1))) illegal-subscript)
	(assign (amem (stack-pointer 4))
		(set-type (+ (amem (stack-pointer -1)) top-of-stack)
			  dtp-fix)))
     ;If FROM not specified, use array’s lower bound
     (assign (amem (stack-pointer 4)) top-of-stack)))
  ;Also bays the index oftseton the stack, for programs that want to
  ;know what their index into the array really is (e.g. str ing-sea-ch)
  (assign stack-pointer (+ stack-pointer (b-constant 4)))
  (parallel (pushval top-of-stack)
	    (next-instruction)))

);end comment
F:>lmach>ucode>arith-escape.lisp.1

;;; -*- Mode:Lisp; Package:Mlicro; Base:8; Lowercase:yes -*-
;;; (C) Copyright 1982, Symbolics. Inc.

;; Microcode for arithmetic exception cases
;; This is a DEFS file for the rest of the arithmetic stuff

;Get defmicro and all his hosts
#M
(declare (cond ((not (status feature lmucode))
		(load 'udcls))))

(define-enumerated-value-constants arithmetic-binary-operation-indices)
(define-enumerated-value-constants arithmetic-unary-operation-indices)
(define-enumerated-value-constants *header-number-types*)

(reserve-scratchpad-memory 2470 2474)
(defareg arith-operation-index)
(defareg arith-operation-floating-pc)

;; Here top-of-stack is the operation-index and the b side is next-on-stack
(defucode arith-binary-extnum-call-out
  (parallel (check-data-type top-of-stack-a
			     dtp-extended-number dtp-fix dtp-float)
	    (jump arith-binary-call-out)))

;; Build call out frame:
;; SP(0): PC; SP(1): TABLE; SP(2): IND-1; SP(3): IND-2; SP(4): Temp(eventually table)
;; SP(5): ARG-2; SP(6): ARG-1; SP(7): Operation index; SP(8): Temp(eventually pc)
(defucode arith-binary-call-out
  ;; Shift the arguments up by 2 stack locations
  (pushval next-on-stack)
  (pushval next-on-stack)
  ;; Push unused slot (table)
  (pushval quote-nil)
  ;; Push type index for arg-2
  (parallel (pushval (amem (stack-pointer -2)))

4,887,235
	583	584
	    (call %numeric-dispatch-index))
  ;; Push type index for arg-i
  (parallel (pushval (amem (stack-pointer -2)))
	    (call %numeric-dispatch-index))
  ;; Cant do this earlier for PCLSR reasons
  (assign (amem (stack-pointer -5)) (set-type arith-operation-index dtp-fix))
  ;; If arg-2 has bigger index than arg-1, interchange the arguments [leave indices alone]
  (if (greater-fixnum next-on-stack top-of-stack)
      (sequential (assign b-temp (amem (stack-pointer -3)))
		  (assign (amem (stack-pointer -3)) (amem (stack-pointer -4)))
		  (assign (amem (stack-pointer -4)) b-temp))
    (drop-through))
  (pushval arithmetic-binary-operation-dispatch)
  (take-post-trap arith-binary-escape preserve-stack)
  )

;; Build call out frame:
:; SP(0): PC; SP(1): IND-1; SP(2): Operation-index; SP(3): TABLE;
;; SP(4): ARG; SP(5): Temp(Eventual function); SP(6): Temp(eventual pc)
(defucode arith-unary-call-out
  ;; Leave room for eventual function
  (pushval quote-nil)
  ;; Push a copy of the argument
  (pushval (amem (stack-pointer -1)))
  ;; Push the table number
  (pushval arthmetic-unary-operation-dispatch)
  ;; Push the operation index
  (pushval (set-type arith-operation-index dtp-fix))
  ;; Push the argument type index
  (parallel (pushval (amem (stack-pointer -2)))
	    (call %numeric-dispatch-index))
  (take-post-trap arith-unary-escape preserve-stack)
  )

(defatomic-byte-field header-subtype-of-md %%header-subtype-field memory-data)

;; Takes argument on stack, pushes corresponding index on the stack
;; Error checking is for when this is an instruction
(definst %numeric-dispatch-index no-operand
  (parallel (check-data-type top-of-stack-a dtp-fix dtp-float dtp-extended-number)
	    (if (data-type? top-of-stack-a dtp-fix)
		(parallel (newtop (set-type (b-constant 0) dtp-fix))
			  (next-instruction))
	      (drop-through)))
  (parallel
   (if (data-type? top-of-stack-a dtp-float)
       (parallel (newtop (set-type (b-constant 1) dtp-fix))
		 (next-instruction))
     (drop-through))
   (assign vma top-of-stack-a))
  (start-memory read)
  (nop)
  (parallel (transport header)
	    (assign top-of-stack (+ header-subtype-of-md (b-constant 2))))
  (parallel (newtop (set-type top-of-stack dtp-fix))
	    (next-instruction)))

;; Convert next-on-stack to flonums
(defucode convert-first-fixnum-to-flonum
  (parallel (call convert-fixnum-to-flonum)
	    (assign a-temp (popval)))
  (parallel (return)
	    (pushval a-temp)))
F:>LMACH>UCODE.ARITH.LISP.61

;;; -*- Mode:Lisp; Package:Micro: Base:8; Lowercase:yes -*-
;;; (c) Copyright 1982, Symbolics, Inc.

;; Microcode for arithmetic primitives
;Get defmicro and all his hoats
#M
(declare (cond ((not (status feature lmucode))
		(load 'udcls))))

;; Binary operations
(definst add-immed signed-immediate-operand
  (check-binary-arithmetic-operands-fast signed-immediate-operand %arith-op-add
					 add-stack fadd add-overflow)
  (newtop (set-type
	   (add-checking-overflow top-of-stack-a macro-signed-immediate)
	   dtp-fix)))

(definst1 add-local (address-operand needs-stack)
  (check-binary-arithmetic-operands-fast address-operand %arith-op-add add-stack
					 fadd add-overflow)
  (newtop (set-type (add-checking-overflow address-operand top-of-stack)
		    dtp-fix)))
4,887,235
	585	586
(definst1 add-stack (no-operand needs-stack)
  (check-binary-arithmetic-operands-fast no-operand %arith-op-add add-stack
					 fadd add-overflow)
  (pop2push (set-type (add-checking-overflow next-on-stack top-of-stack)
		      dtp-fix)))

(definst1 sub-immed signed-immediate-operand
  (check-binary-arithmetic-operands-fast signed-immediate-operand %arith-op-subtract
					 sub-stack fsub)
  (newtop (set-type
	   (sub-checking-overflow top-of-stack-a macro-signed-immediate)
	   dtp-fix)))

(definst1 sub-local (address-operand needs-stack)
  (check-binary-arithmetic-operands-fast address-operand %arith-op-subtract
					 sub-stack fsub)
  (newtop (set-type (sub-checking-overflow top-of-stack address-operand)
		    dtp-fix)))

(definst1 sub-stack (no-operand needs-stack)
  (check-binary-arithmetic-operands-fast no-operand %arith-op-subtract sub-stack fsub)
  (pop2push (set-type (sub-checking-overflow next-on-stack top-of-stack)
		      dtp-fix)))

;;; This is trapped to via fixnum-fixnum overflow in an add instruction
(defucode add-overflow
  (parallel (pop2push (set-type (+ next-on-stack top-of-stack) dtp-fix))
	    (trap-no-save))
  (take-post-trap additive-fixnum-overflow preserve-stack))

;;; This is trapped to via fixnum-fixnum overflow in an subtract instruction
(defucode sub-overflow
  (parallel (pop2push (set-type (- next-on-stack top-of-stack) dtp-fix))
	    (trap-no-save))
  (take-post-trap additive-fixnum-overflow preserve-stack))

(definst1 logand-stack (no-operand needs-stack)
  (check-binary-arithmetic-operands-fast no-operand %arith-op-logand logand-stack)
  (pop2push (set-type (logand next-on-stack top-of-stack) dtp-fix)))

(definst1 logior-stack (no-operand needs-stack)
  (check-binary-arithmetic-operands-fast no-operand %arith-op-logior logior-stack)
  (pop2push (set-type (logior next-on-stack top-of-stack) dtp-fix)))

(definst1 logxor-stack (no-operand needs-stack)
  (check-binary-arithmetic-operands-fast no-operand %arith-op-logxor logxor-stack)
  (pop2push (set-type (logxor next-on-stack top-of-stack) dtp-fix)))

;; Binary predicates
(definst lessp (no-operand needs-stack)
  (parallel
   (check-binary-arithmetic-operands-fast no-operand %arith-op-lesep lessp flessp)
   (decrement-stack-pointer)
   (if (lesser-fixnum next-on-stack top-of-stack)
       (goto true1)
       (goto false1))))

(definst greaterp (no-operand needs-stack)
  (parallel
   (check-binary-arithmetic-operands-fast no-operand %arith-op-greaterp greaterp fgreaterp)
   (decrement-stack-pointer)
   (if (greater-fixnum next-on-stack top-of-stack)
       (goto true1)
       (goto faise1))))

(definst equal-number (no-operand needs-stack)
  (parallel
   (check-binary-arithmetic-operand-fast no-operand
					 %arith-op-equal-number equal-number fequal)
   (decrement-stack-pointer)
   (if (equal-fixnum next-on-stack top-of-stack)
       (goto true1)
       (goto false1))))

;;; Unary predicates
(definst zerop (no-operand needs-stack)
  (parallel
   (check-unary-arithmetic-operation-fast no-operand %arith-op-zerop zerop
					  fzerop)
   (if (zero-fixnum top-of-stack)
       (goto true1)
       (goto false1))))

(definst plusp (no-operand needs-stack)
  (parallel
   (check-unary-arithmetic-operator-fast no-operand %arith-op-plusp plusp
					  fplusp)
   (if (plus-fixnum top-of-stack)
       (goto true1)
       (goto false1))))
4,887,235
	587	588
(definst minusp (no-operand needs-stack)
  (parallel
   (check-unary-arithmetic-operator-fast no-operand %arith-op-minusp minusp
					  fminusp)
   (if (minus-fixnum top-of-stack)
       (goto true1)
       (goto false1))))

(definst fixp no-operand
  (if (data-type? top-of-stack-a dtp-fix)
      (goto true1)
      (drop-through))
  (if (not (data-type? top-of-stack-a dtp-extended-number))
      (goto false1)
      (drop-through))
  (memread top-of-stack-a)
  (parallel (transport header)
	    (if (equal-fixnum header-subtype-of-md %header-type-bignum)
		(goto true1)
	        (goto false1))))

;; Unary operations
(definst1 unary-minus no-operand
  (check-unary-arithmetic-operation-fast no-operand %arith-op-minus unary-minus
					 minus-flonum minus-overflow)
  (newtop (set-type (sub-checking-overflow (b-constant 0) top-of-stack-a)
		    dtp-fix)))

(defucode minus-overflow
  (parallel (newtop (set-type (- (b-constant 0) top-of-stack-a) dtp-fix))
	    (trap-no-save))
  (take-post-trap additive-fixnum-overflow preserve-stack))

;;; (%add-bignum-digits a b c) does a signed addition of a b and c
;;; returning two valus. The first is a 31 bit sum and the socond is
;;; the next higher 32 bits of the sum. This is accomplished by doing an
;;; unsignod addition, and then compensating for tha sIgn extension of negative
;;; arguments
(delinst %add-bignum-digits (no-operand needs-stack)
  (parallel (check-fixnum-2args next-on-stack top-of-stack
	       (otherwise (signal-error wrong-type-argument any (:fixnum))))
	    (assign b-temp (+ next-on-stack top-of-stack))
	    (if aiu-carry
		(parallel (assign b-temp-2 (- (b-constant 1)
					      (ldb top-of-stack-a 1 31.)))
			  (jump add-bignum-digits-internal)
			  (decrement-stack-pointer))
	      (parallel	(assign b-temp-2 (- (ldb top-of-stack-a l 31.)))
			(jump add-bignum-digits-internal)
			(decrement-stack-pointer)))))

:;; (%sub-bignum-digits a b c) does a signed addition of a b and subtracts c
;;; returning two values. Tne first is a 31 bit sum and the second is
;;; the next higher 32 bits of the sum. This is accomplished by doing an
;;; unsigned addition, and then compensating for the sign extension of negative
;;; arguments
(definst %sub-bignum-digits (no-operand needs-stack)
  (parallel (check-fixnum-2args next-on-stack top-of-stack
	       (otherwise (signal-error wrong-type-argument any (:fixnum))))
	    (assign b-temp (- next-on-stack top-of-stack))
	    (if alu-carry
		(parallel (assign b-temp-2 (ldb top-of-stack-a 1 31.))
			  (jump add-bignum-digits-internal)
			  (decrement-stack-pointer))
	        (parallel (assign b-temp-2 (+ (ldb top-of-stack-a 1 31.)
					      (b-constant -1)))
			  (jump add-bignum-digits-internal)
			  (decrement-stack-pointer)))))

(defucode add-bignum-digits-internal
  (parallel (assign b-temp-2 (- b-temp-2 (ldb top-of-stack-a 1 31.)))
	    (decrement-stack-pointer))
  (parallel (check-fixnum-1arg-a top-of-stack-a
	       (otherwise (signal-error wrong-type-argument any (:fixnum))))
	    (assign b-temp (+ b-temp top-of-stack-a))
	    (if alu-carry
		(assign b-temp-2 (1+ b-temp-2))
	      (drop-through)))
  (parallel (assign b-temp-2 (- b-temp-2 (ldb top-of-stack-a 1 31.)))
	    (decrement-stack-pointer)
	    (jump pack-bignum-digits)))

(defucode pack-bignum-digits
  (pushval (set-type (ldb b-temp 31. 0) dtp-fix))
  (assign a-temp (rotate b-temp 1))	;Sign bit is bottom bit of top word
  ;; These could be the same instruction, but there is a AMA, DPB conflict
  (assign a-temp (set-type (dpb b-temp-2 31. 1 a-temp) dtp-fix))
  (parallel (pushval a-temp)
	    (next-instruction)))

(defatomicro negative-result
  (microcondition alu-31 true nil))
4,887,235
	589	590
;;; (%lshc-bignum-digits a b shift) performs a LSHC on the bignum digits.
;;: The higher digit of the resuit of shifting (b,a) up is the value returned.
(definst %lshc-bignum=digits (no-operand needs-stack)
  (parallel (check-fixnum-2args next-on-stack top-of-stack
	       (otherwise (signal-error wrong-type-argument any (:fixnum))))
	    (assign a-temp top-of-stack)
	    (decrement-stack-pointer))
  (assign byte-r (- a-temp (b-constant 31.)))
  (parallel (assign byte-s (1- a-temp))
	    (if negative-result
		(parallel (check-fixnum-1arg-a next-on-stack
			     (otherwise (signal-error wrong-type-argument any (:fixnum))))
			  (assign b-temp-2 (b-constant 0)))
	        (parallel (check-fixnum-1arg-a next-on-stack
			     (otherwise (signal-error wrong-type-argument any (:fixnum))))
			  (assign b-temp-2 (ldb next-on-stack byte-s byte-r)))))
  (parallel (assign byte-s (- (b-constant 30.) a-temp))
	    (if negative-result
		(parallel (pop2push (set-type b-temp-2 dtp-fix))
			  (next-instruction))
	      (drop-through)))
  (assign byte-r a-temp)
  (parallel (poppush (set-type (dpb top-of-stack-a byte-s byte-r b-temp-2) dtp-fix))
	    (next-instruction)))

;;; (%multiply-bignum-digits x y) multiplies the bignum digits x and y and returns
;;; two digits which are the double precision product
(definst %multiply-bigum-digits (no-operand needs-stack)
  (check-fixnum-2args next-on-stack top-of-stack
     (otherwise (signal-error wrong-type-argument any (:fixnum))))
  (call 32-bit-multiply)			;TOS is high order word
  (parallel (assign b-temp-2 top-of-stack-a)	;
	    (decrement-stack-pointer))
  (parallel (assign b-temp top-of-stack-a)		;Low bits
	    (decrement-stack-pointer)
	    (jump pack-bignum-digits)))

;;; (%divide-bignum-digits low high x) concatenates two 31 bignum digits
;;; to form a positive 62 bit number, and divides it by another positive
;;; 31 bit digit. Returns the quotient and the remainder
(definst %divide-bignum-digits (no-operand needs-stack)
  (parallel (check-fixnum-2args next-on-stack top-of-stack
	       (otherwise (signal-error wrong-type-argument any (:fixnum))))
	    (assign a-positive-divisor (popval)))
  (assign a-negative-divisor (- a-positive-divisor))
  (assign a-divide-step-count (a-constant 15.))	; See divide routine (32 steps)
  (parallel (assign b-low-dividend next-on-stack)
	    (check-fixnum-1arg-a next-on-stack
	       (otherwise (signal-error wrong-type-argument any (:fixnum)))))
  ;; Low bit of high is the high bit of low
  (assign b-low-dividend (dpb top-of-stack-a 1 31. b-low-dividend))
  (parallel (assign b-high-dividend (ldb top-of-stack 30. 1))
	    (call divide-subroutine))
  ;; Quotient is in b-low-dividend, remainder in b-high-dividend
  (assign next-on-stack				;Quotient
	  (set-cdr (set-type b-low-dividend dtp-fix) cdr-next))
  (parallel
   (newtop (set-type b-high-dividend dtp-fix))	;Remainder
   (next-instruction)))

;;; Arithmetic Shift

;7 cycles to shift left
;5 cycles to shift right
(definst ash-stack (no-operand needs-stack)
  (parallel
   (check-binary-arithmetic-operands-fast no-operand %arith-op-ash ash-stack
					  nil nil ash-float)
   (if (minus-or-zero-fixnum top-of-stack)
       ;; Shift right by LDBing
       (sequential
	(assign byte-r top-of-stack)
	;; Get word full of sign bits
	(assign b-temp (- (ldb next-on-stack 1 31.)))		;Right rotate
	(parallel
	 (assign byte-s (+ (a-constant 31.) top-of-stack))	;Bytesize-1
	 (if (minus-fixnum obus)
	     ;; Shifted away--result is all sign bits
	     (parallel (pop2push (set-type b-temp dtp-fix))
		       (next-instruction))
	     ;; Normal result
	     (parallel
	      (pop2push (set-type (ldb next-on-stack byte-r b-temp)
				  dtp-fix))
	      (next-instruction)))))
     ;; Shift left by DPBing
     (sequential
       (assign byte-s top-of-stack)			;N discarded bits+1-1
       (parallel
	 (assign byte-r (1+ top-of-stack))
	 (if (minus-fixnum next-on-stack)
4,887,235
	591	592
	     ;; Argment is negative
	     ;; Check that discarded bits and new sign bit are all ones
	     (if (all-ones (ldb next-on-stack byte-s byte-r (b-constant -1)))
		 (sequential
		   (assign byte-r top-of-stack)	;Left rotate
		   (parallel				;N kept bits-1
		     (assign byte-s (- (a-constant 31.) top-of-stack))
		     (if (greater-or-equal-fixnum-unsigned (a-constant 31.) top-of-stack)
			 (parallel
			  (pop2push (set-type (dpb next-on-stack byte-s byte-r 0)
					      dtp-fix))
			  (next-instruction))
		       (goto ash-overflow))))		;Shift count too large
	       (goto ash-overflow))			;Result is bignum
	     ;; Argument is positive
	     ;; Check that discarded bits and new sign bit are all zero
	     (if (zero-fixnum (ldb next-on-stack byte-s byte-r))
		 (sequential
		   (assign byte-r top-of-stack)		;Left rotate
		   (parallel				;N kept bits-1
		     (assign byte-s (- (a-constant 31.) top-of-stack))
		     (if (greater-or-equal-fixnum-unsigned (a-constant 31.) top-of-stack)
			 (parallel
			  (pop2push (set-type (dpb next-on-stack byte-s byte-r 0)
					      dtp-fix))
			  (next-instruction)) 
		       (goto ash-overflow))))		;Shift count too large
	       (goto ash-overflow))))))))		;Result is bignum

(defucode asl-overflow
  (parallel (assign arith-operation-index %arith-op-ash)
	    (jump arith-binary-call-out)))

;;; -*- Mode:Lisp; Package:Micro; Baase:8; Lowercase:yes -*-
;;; (c) Copyright 1982, Symbolics, Inc.

; Microcode for A-memory map an the Rev.1 FEP board

;Get defmicro and all his hosts
#M
(declare (cond ((not (status feature lmucode))
		(load 'udcls))))

;Write the Amem map. Address must have been set up in VMA previously.
;Must use slowest speed so Lbus is stable during write pulse to RAM
;Also data must not come from pass-around path (it won’t if you just wrote vma).
(defmicro write-amem-map (data)
  '(parallel (write-lbus-dev 36 3 ,data)
	     (microinstruction speed 3)))

(defucode clear-amem-map
  (parallel (assign a-temp (- a-temp (b-constant 1_8)))
	    (it (minus-fixnum obus) (return) (drop-through)))
;XXXbrad ldb?
  (assign b-temp (ldb a-temp 2 10.))
  (assign vma b-temp)
  (parallel (write-amem-map b-temp)
	    (jump clear-amem-map)))

(defucode setup-amem-map		;Set up the direct-~aapped pert
  (assign b-temp (ldb a-temp 2 10. (b-constant 14)))
  (assign vma a-temp)
  (write-amem-map b-temp)
  (assign a-temp (+ a-temp (b-constant 1_8)))
;XXXbrad ldb-bit-test?
  (if (ldb-bit-test a-temp 21.)
      (return)
    (goto setup-amem-map)))

;Write a-temp into the amem-map. A subroutine only due to field confllcts
;and also the need to write the VMA.
;NOTE WELL: when writing the amem-map, the data must not come from the
;pass-around path, because that does’nt give enough time for the Lbus to
;be stable before the write pulse (running a slow cycle doesn’t make the
;pass-around path faster, since it is a negative delay from the end of
;l~<~ This is all crocks for the temporary memory control.
(defucode write-mem-map
  (assign vma a-temp)		;Clears pass-around path
  (parallel (write-amem-map a-temp)
	    (return)))

;Unmap page whose address (low 8 bits zero!) Is in b-temp, smashing a-temp, vma
(defucode unmap-page-from-amem
  (assign a-temp (ldb b-temp 2 10.))
  (assign vma b-temp)		;Clears pass-around path
  (parallel (write-amem-map 3-temp)
	    (return)))

MICROCODE BITS
Amem microcode data.

0: 000000000000 000000000000 000000000000 000000000000
4: 000000000000 000000000000 000000000000 000000000000