4,887,235
	413	414
  (parallel (nop) (trap-no-save))		;Cannot call in first cycle alter trap
  (call fsignum)
  (if (plus-fixnum top-of-stack)
      (goto true1)
      (goto false1)))

(defucode fminusp
  (parallel (nop) (trap-no-save))		;Cannot call in first cycle after trap
  (call fsignum)
  (if (minus-fixnum top-of-stack)
      (goto true1)
      (goto false1)))

(defucode fzerop
  (parallel (nop) (trap-no-save))		;Cannot call in first cycle after trap
  (call fsignum) 
  (if (zero-fixnum top-of-stack)
      (goto true1)
      (goto false1)))

(defucode minus-flonum
  (parallel (trap-no-save)
	    (if (equal-fixnum (ldb-field top-of-stack-a single-expt)
			       (b-constant single-expt-max))
		(goto minus-inf-or-nan)
	        (drop-through)))
  (parallel (newtop (set-type (logxor (b-constant (field-mask single-sign))
				      top-of-stack-a)
			      dtp-float))
	    (next-instruction)))

F:>lmach>ucode>flavor.lisp.25

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

; Microcode for flavor.

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

(reserve-scratchpad-memory 2452 2460 345 351)

;Data on the most recently used mapping table (an ART-16B array)
(defbreg b-cached-mapping-table)
(defareg a-cached-mapping-table-address)
(defareg a-cached-mapping-table-size)

(defatomicro self
  (amem (frame-pointer 0)))

(defatomicro self-mapping-table
  (amem (frame-pointer 1)))

(definst push-instance-variable-ordered unsigned-immediate-operand
  (parallel (check-arg-type instance self dtp-instance)
	    (memread (+ self macro-unsigned-immediate)))
  (parallel (transport data)
	    (pushval memory-data)
	    (next-instruction)))

(definst movem-instance-variable-ordered (unsigned-immediate-operand needs-stack)
  (parallel (check-arg-type instance self dtp-instance)
	    (memread (+ self macro-unsigned-immediate)))
  (parallel (transport write)		;Follow any forwarding pointer
	    (assign a-temp 		;Merge new data with old cdr cods
		    (merge-cdr top-of-stack memory-data)))
  (parallel (store-contents a-temp)	;Now write back the new car
	    (next-instruction)))

(definst pop-instance-variable-ordered (unsigned-immediate-operand needs-stack)
  (parallel (check-arg-type instance self dtp-instance)
	    (assign vma (+ self macro-unsigned-immediate)))
  (parallel (start-memory read)
	    (assign b-temp top-of-stack))
  (for-effect (popval))
  (parallel (transport write)		;Follow any forwarding pointer
	    (assign a-temp 		;Merge new data with old cdr code
		    (merge-cdr b-temp memory-data)))
  (parallel (store-contents a-temp)	;Now write back the new car
	    (next-instruction)))

(definst1 push-address-instance-variable-ordered unsigned-immediate-operand
  (check-arg-type instance self dtp-instance)
  (pushval (set-type (+ self macro-unsigned-immediate) dtp-locative)))

;8 cycles if the mapping table is already encached
;Additional 11 cycles to encache it if necessary
;Would be 7 cycles with no range check and assumed simple array format, thus no encaching
4,887,235
	415	416
(definst push-instance-variable unsigned-immediate-operand
  (parallel
    (check-arg-type self-mapping-table self-mapping-table dtp-array)
    (call-select (equal-typed-pointer self-mapping-table b-cached-mapping-table)
		 fast-mapping-table-lookup slow-mapping-table-lookup))
  (start-memory read)
  (nop)
  (parallel (transport data)
	    (pushval memory-data)
	    (next-instruction)))

(definst movem-instance-variable (unsigned-immediate-operand needs-stack)
  (parallel
   (check-arg-type self-mapping-table self-mapping-table dtp-array)
   (call-select (equal-typed-pointer self-mapping-table b-cached-mapping-table)
		fast-mapping-table-lookup slow-mapping-table-lookup)) 
  (start-memory read)
  (nop)
  (parallel (transport write)		;Follow any forwarding pointer
	    (assign a-temp		;Marge new data with old cdr code
		    (merge-cdr top-of-stack memory-data)))
  (parallel (store-contents a-temp)	;Now write back the new car
	    (next-instruction)))

(definst pop-instance-variable (unsigned-immediate-operand needs-stack)
  (parallel
   (check-org-type self-mapping-table self-mapping-table dtp-array)
   (call-select (equal-typed-pointer self-mapping-table b-cached-mapping-table)
		fast-mapping-table-lookup slow-mapping-table-lookup))
  (parallel (start-memory read)
	    (assign b-temp top-of-stack))
  (for-effect (popval))
  (parallel (transport write)		;Follow any forwarding pointer
	    (assign a-temp		;Merge new data with old cdr code
		    (merge-cdr b-temp memory-data)))
  (parallel (store-contents a-temp)	;Now write back the new car
	    (next-instruction)))

(definst push-address-instance-variable unsigned-immediate-operand
  (parallel
   (check-arg-type self-mapping-table self-mapping-table dtp-array)
   (call-select (equal-typed-pointer self-mapping-table b-cached-mapping-table)
		fast-mapping-table-lookup slow-mapping-table-lookup))
  (parallel (pushval (set-type vma dtp-locative))
	    (next-instruction)))

(defucode slow-mapping-table-lookup
  (parallel (check-arg-type self-mapping-table self-mapping-table dtp-array)
	    (assign vma self-mapping-table)
	    (assign b-vma sell-mapping-table)
	    (call array-setup-1d-zero))
;(trap-if (not-zero-fixnum top-of-stack) (signal-error "Index offset not handled"))
;(trap-if (not-equal-fixnum (array-register-dispatch-field (amem (stack-pointer 1)))
;			    %array-register-dispatch-16-bit)
;	  (signal-error "Mapping table must be art-16b"))
  (assign a-cached-mapping-table-address (amem (stack-pointer 2)))
  (assign a-cached-mapping-table-size (amem (stack-pointer 3)))
  (assign b-cached-mapping-table self-mapping-table)
  (parallel (assign top-of-stack top-of-stack-a)
	    (jump fast-mapping-table-lookup)))

(defucode fast-mapping-table-lookup
  ;; Divide the instance-variable number by 2 and access the art-lEb array
  (assign vma (+ a-cached-mapping-table-address (rotate macro-unsigned-immediate 37)))
  ;;Range-check the instance-variable number
  (parallel (start-memory read)
	   (error-if (greater-or-equal-fixnum-unsigned macro-unsigned-immediate
						       a-cached-mapping-table-size)
		     mapping-table-out-of-bounds))
  ;; Extract the appropriate halfword, put instance-variable address into VIIA
  (parallel
   (check-arg-type instance self dtp-instance)
   (assign b-temp self)
   (if (ldb-bit-test macro-unsigned-immediate 0) 	;oddp
       (machine-version-case
	((tmc tmc5) (sequential
		     (assign a-temp memory-data)
		     (assign vma (+ b-temp (ldb a-temp 20 20)))))
	(otherwise (assign vma (+ b-temp (ldb memory-data 20 20)))))
       (machine-version-case
	((tmc tmc5) (sequential
		     (assign a-temp memory-data)
		     (assign vma (+ b-temp (ldb a-temp 20 0)))))
	(otherwise (assign vma (+ b-temp (ldb memory-data 20 0)))))))
  ;This could check for instance-variable-number out of range, but that would
  ;require accessing ancther field in the instance descriptor. The flavor system
  ;is not supposed to let that happen. But instance variable zero is really
  ;accessed when an instance variable is deleted or only existed at compile time.
  (parallel
   (error-if (equal-pointer vma b-temp) instance-variable-zero-referenced)
   (return)))

4,887,235
	417	418
(define-storage-word-offset-constants instance-descriptor)

;; VMA has the address of an instance. Return its size in a-temp.
(defucode instance-size
  (start-memory read)				;Fetch instance-descriptor
  (nop)
  (parallel (transport header)
	    (machine-version-case
	     ((tmc tmc5) (sequential
			  (assign a-temp memory-data)
			  (assign vma (+ a-temp %instance-descriptor-size))))
	     (otherwise (assign vma (+ memory-data %instance-descriptor-size))))
	    (call memread))
  (parallel (declare-memory-timing data-cycle)
	    (check-arg-type instance-size memory-data dtp-fix)
	    (assign a-temp memory-data)
	    (return)))

(definst %instance-ref unsigned-immediate-operand
  (parallel (check-arg-type instance top-of-stack-a dtp-instance)
	    (assign vma top-of-stack-a)
	    (call instance-size))
  (error-if (greater-fixnum-unsigned macro-unsigned-immediate a-temp)
	    illegal-subscript)
  (parallel (assign vma (+ top-of-stack-a macro-unsigned-immediate))
	    (jump newtopmem)))

(definst %instance-loc unsigned-immediate-operand
  (parallel (check-arg-type instance top-of-stack-a dtp-instance)
	    (assign vma top-of-stack-a)
	    (call instance-size))
  (error-if (greater-fixnum-unsigned macro-unsigned-immediate a-temp)
	    illegal-subscript)
  (parallel (newtop (set-type (+ top-of-stack-a macro-unsigned-immediate) dtp-locative))
	    (next-instruction)))

(definst %instance-set unsigned-immediate-operand
  (parallel (check-arg-type instance top-of-stack-a dtp-instance)
	    (assign vma top-of-stack-a)
	    (call instance-size))
  (error-if (greater-fixnum-unsigned macro-unsigned-immediate a-temp)
	    illegal-subscript)
  (parallel (assign vma (+ top-of-stack-a macro-unsigned-immediate))
	    (decrement-stack-pointer)
	    (jump popmem)))

(defareg instance-descriptor)
(defareg a-hash-table)
(defbreg b-message)
(defbreg b-self)
(defareg a-hash-table-limit)

;Come here when calling a function that turns out to be an instance
(defucode funcall-instance
  (restart-pc restart-trapped-call-escape-pc)	;in case of page fault
  (parallel (accept-restart-pc)
	    (assign vma frame-function)		;Get the instance descriptor
	    (assign b-vma frame-function))
  (start-memory read)
  (if (not (bit first-part-done))
      (sequential
       (parallel (transport header)
		 (assign a-instance-descriptor memory-data))
       (assign vma (+ a-instance-descriptor %instance-descriptor-bindings))
       (parallel
	(start-memory read)
	(assign frame-function (set-type b-vma dtp-instance))) ;follow-structure-forwarding
       (pushval (set-type (a-constant 1) dtp-fix))	;Index of instance variable slot
	(parallel
	  (pushval memory-data)				;Bindings list
	  (transport data)
	  (check-arg-type instance-binding-table memory-data dtp-list dtp-nil)
	  (if (data-type? memory-data dtp-list)
	      (parallel
	        (assign frame-misc-data
		  (logior frame-misc-data (b-constant (+ (byte-mask frame-instance-called)
							(byte-mask first-part-done)))))
		(clear-stack-adjustment)
		(jump funcall-instance-binding-loop))
	      (parallel
	       (assign frame-misc-data
		 (logior frame-misc-data (b-constant (+ (byte-mask frame-instance-called)
							(byte-mask first-part-done)))))
	       (clear-stack-adjustment)
	       (jump funcall-instance-part-2)))))
    (parallel
      (transport header)			;Here when restarting after pclsr
      (assign a-instance-descriptor memory-data)
      (jump funcall-instance-binding-loop))))

(defucode funcall-instance-binding-loop
  (parallel (assign vma top-of-stack-a)
4,887,235
	419	420
    (if (not (data-type? top-of-stack-a dtp-list))
	(goto funcall-instance-part-2)		;Pclsred after binding-loop finished
      (drop-through)))
  (start-memory read)
  (assign b-self frame-function)
  (parallel (transport)
	    (check-arg-type instance-binding memory-data dtp-fix dtp-locative)
	    (assign b-temp memory-data)
	    (assign a-hash-table memory-data)
	    (if (data-type? memory-data dtp-fix)
		;; Skip over some instance variable slots
		(assign next-on-stack (set-type (+ next-on-stack b-temp) dtp-fix))
	        ;; Bind this cell
	        (sequential
		  (pushval (set-type (+ b-self next-on-stack)
				     dtp-external-value-cell-pointer))
		  (parallel
		    (assign vma a-hash-table)
		    (call bind-top-of-stack-closure))
		  (assign next-on-stack (set-type (1+ next-on-stack) dtp-fix)))))
  ;; a-hash-table still has the word from memory, check the cdr code to see if we’re done
  (parallel (newtop (set-type (1+ top-of-stack) dtp-list))
	    (if (cdr-code? a-hash-table cdr-next)
		(goto funcall-instance-binding-loop)
	      (parallel
	       (newtop quote-nil)		;Flag that we’re done binding
	       (jump funcall-instance-part-2)))))

;At this point, all of the bindings have been done, two words have been pushed on the
;stack (but their contents is garbage), and first-part-done is set. Find the
;hash table for the flavor, (The non-hash-table case has been punted since
;SELF is not a special variable and would not get bound.)
(defucode funcall-instance-part-2
  ;; Set a-hash-tamle to the hash table
  (memread (+ a-instance-descriptor %instance-descriptor-function))
  (parallel (transport)
	    (check-arg-type instance-hash-table memory-data dtp-array)
	    (assign a-hash-table memory-data))
  ;; Find the first araument (the message keyword), put it in b-message
  (if (not (bit frame-lexpr-called))
      (sequential
       (error-if (lesser-fixnum-unsigned frame-number-of-args (b-constant 1))
		 wrong-number-of-arguments)
       (assign b-temp frame-number-of-args)
       (assign xbas (- frame-pointer b-temp))
       (assign b-message (amem (xbas -5))))
    (if (greater-or-equal-fixnum-unsigned frame-number-of-args (b-constant 2))
	(sequential
	 (assign b-temp frame-number-of-args)
	 (assign xbas (- frame-pointer b-temp))
	 (assign b-message (amem (xbas -5))))
      (sequential
       (memread (amem (frame-pointer -6)))
       (parallel (transport)
		 (assign b-message memory-data)))))
  ;; The hash-table is a short-leader- array, with a 1-word prefix and a 4-word leader
  ;; The first 3 elements are: mask, undefined-message-handler, gc-generation-number
  (assign vma (+ a-hash-table (b-constant 5)))		;Get the mask
  (start-memory read)
  (assign a-hash-table (+ a-hash-table (b-constant (+ 1 4 3)))) ;Start of actual hash
  (parallel (check-arg-type instance-hash-table-entry memory-data dtp-fix)
	    (assign a-temp memory-data)
	    (assign b-temp memory-data))
  (assign b-temp-2 (+ a-temp (dpb b-temp 31. 1 0)))	;mask times 3
  (assign a-hash-table-limit (+ a-hash-table b-temp-2))
  (parallel
   (assign b-temp (logand b-message a-temp))		;mask symbol with mask
   (assign a-temp obus))
  (assign b-temp-2 (+ a-temp (dpb b-temp 31. 1 0)))	;multiply that by 3, use as hash
  (parallel (assign vma (+ a-hash-table b-temp-2))
	    (assign b-temp obus)
	    (jump funcall-instance-hash-loop)))

(defucode funcall-instance-hash-loop
  (parallel
   (start-memory read)
   (trap-if (greater-pointer b-temp a-hash-table-limit)
	    (parallel
	     (trap-no-save)
	     (assign vma a-hash-table)
	     (assign b-temp a-hash-table)
	     (jump funcall-instance-hash-loop))))
  (assign b-self frame-function)
  (parallel (trap-if (data-type? memory-data dtp-nil)
		     (goto funcall-instance-hash-miss))
	    (assign a-temp memory-data))
  (if (equal-typed-pointer a-temp b-message)
      (goto funcall-instance-hash-win)
    (parallel
     (assign vma (+ vma (b-constant 3)))
4,887,235
	421	422
	(assign b-temp obus)
	(jump funcall-instance-hash-loop))))

(defucode funcall-instance-hash-miss
  (parallel (trap-no-save)
	    (assign self-mapping-table quote-nil))
  (memread (- a-hash-table (b-constant 2)))	;Get miss handler
  (parallel (transport)
	    (assign frame-function memory-data))
  (assign self b-self)
  (parallel (assign first-part-done (b-constant 0))
	    (jump restart-trapped-call)))

(defucode funcall-instance-hash-win
  (memread (1+ vma))				;Get the mapping table
  (parallel (transport)
	    (assign self-mapping-table memory-data))
  ;; If it pclsrs here, self-mapping-table isn’t a list so it won’t
  ;; think it’s a binding list and go try to do the bindings 
  (memread (1+ vma))				;Get the method
  (parallel (transport)
	    (assign frame-function memory-data))
  ;Cannot pclsr any more, finish up
  (assign self b-self)
  (parallel (assign first-part-done (b-constant 0))
	    (jump restart-trapped-call)))

F:>lmach>ucode>DIVISION.LISP.34

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

; Microcode for division

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

;Temporary storage

(reserve-scratchpad-memory 2434 2437)

(defareg a-positive-divisor)		;Magnitude of divisor
(defareg a-negative-divisor)		;2’s-complement of that
(defareg a-divide-step-count)		;Number of bits over 2 minus 1 (counts down)

(define-b-temps b-high-dividend		;Ends up with remainder
  		b-low-dividend) 	;Ends Up with quotient

;Given dividend and divisor on the stack, set up internal variables
(defmicro integer-divide-setup (index &optional float-version)
  `(sequential
    (parallel
     (check-binary-arithmetic-operands-fast no-operand ,index nil ,float-version)
     (assign b-low-dividend next-on-stack)
     (if (minus-fixnum next-on-stack)
	 (assign b-low-dividend (- next-on-stack))
       (drop-through)))
    (parallel (assign b-high-dividend (b-constant 0))
	      (call divisor-setup))))

;TRUNC2 instruction takes dividend and divisor on the stack,
;returns truncated quotient and remainder on the stack.
;--- This code needs to be bummed, it wastes 5 whole cycles
(definst trunc2 no-operand
  (integer-divide-setup %arith-op-divide)
  (call trunc2-internal)
  (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)))

;;; This is necessary because for floating point calculating remainder is expensive.
;;; Therefore the compiler generates calls to these instructions if possible
(definst quotient-stack no-operand
  (integer-divide-setup %arith-op-divide fdiv)
  (call trunc2-internal)
  (parallel (next-instruction dtp-fix))

(definst remainder-stack no-operand
  (integer-divide-setup %arith-op-remainder)
  (call trunc2-internal)
  (parallel (pop2push (set-type b-high-dividend dtp-fix))
	    (next-instruction)))

(defucode trunc2-internal
  (call divide-subroutine)		;Do the division
4,887,235
	423	424
  ;Now compute results, using truncate mode
  (if (plus-or-zero-fixnum next-on-stack)	;Check sign of dividend
      (if (plus-or-zero-fixnum top-of-stack-a)	; and of divisor
	  (return)
	  (parallel (assign b-low-dividend (- b-low-dividend))
		    (return)))
    (sequential
     (if (plus-or-zero-fixnum top-of-stack-a)
	 (assign b-low-dividend (- b-low-dividend))
         (error-if (minus-fixnum b-low-dividend)
		   unimplemented-arithmetic))	;---
     (parallel (assign b-high-dividend (- b-high-dividend))
	       (return)))))

;Given divisor at the top of the stack, and dividend already set up,
;finish setting up the division.
(defucode divisor-setup
  (parallel (assign a-positive-divisor top-of-stack-a)
	    (if (minus-fixnum top-of-stack-a)
		(assign a-positive-divisor (- top-of-stack-a))
	        (drop-through)))
  (parallel (assign a-negative-divisor (- a-positive-divisor)))
  (parallel (assign a-divide-step-count (a-constant 15.))
	    (return)))			;15=32/2-1, see call to divide-routine

;Do 32 divide steps in a loop unrolled n-steps ways, 2 cycles per bit.
;D1VIDE-n-ADD-b is the nth (from the end) step for when we should add,
;because we subtracted too much last time, where b (8 or 1) is the
;next bit to shift in from the low half of the dividend.
;DIVIDE-n-SUB-b is the step for when we should subtract.
;DIVIDE-n-Q1 is the seccnd cycle of the step, with a quotient bit of 1.
;DIVIDE-n-Q0 is the second cycle with a quotient bit of -.

(defmacro divide-routine (n-steps)
  `(progn 'compile
     . ,(loop for step downfrom n-steps above 0
	  collect
	   `(defucode ,(fintern "DIVIDE-~D-SUB-0" step)
	      (parallel
	       (assign b-high-dividend
		       (+ a-negative-divisor (dpb b-high-dividend 31. 1 0)))
	       (if (minus-fixnum obus)
		   (goto ,(fintern "DIVIDE-~D-Q0" step))
		   (goto ,(fintern "DIVIDE-~D-Q1" step)))))
	  collect
	   `(defucode ,(fintern "DIVIDE-~D-SUB-1" step)
	      (parallel
	       (assign b-high-dividend
		       (+ a-negative-divisor (dpb b-high-dividend 31. 1 0) 1))
	       (if (minus-fixnum obus)
		   (goto ,(fintern "DIVIDE-~D-Q0" step))
		   (goto ,(fintern "DIVIDE-~D-Q1" step)))))
	  collect
	   `(defucode ,(fintern "DIVIDE-~D-ADD-0" step)
	      (parallel
	       (assign b-high-dividend
		       (+ a-positive-divisor (dpb b-high-dividend 31. 1 0)))
	       (if (minus-fixnum obus)
		   (goto ,(fintern "DIVIDE-~D-Q0" step))
		   (goto ,(fintern "DIVIDE-~D-Q1" step)))))
	   collect
	    `(defucode ,(fintern "DlVIDE-~D-ADD-1" step)
	       (parallel
		(assign b-high-dividend
			(+ a-positive-divisor (dpb b-high-dividend 31. 1 0) 1))
		(if (minus-fixnum obus)
		    (goto ,(fintern "DIVIDE-~D-Q0" step))
		    (goto ,(fintern "DIVIDE-~D-Q1" step)))))
	    collect
	     `(defucode ,(fintern "DIVIDE-~D0-Q0" step)
		,@(if (= step 1)
		      `((parallel
			 (assign a-divide-step-count (1- a-divide-step-count))
			 (if (minus-fixnum obus)
			     (sequential
			      ;Remainder correction
			      (assign b-high-dividend
				      (+ b-high-dividend a-positive-divisor))
			      (parallel
			       (assign b-low-dividend
				       (dpb b-low-dividend 31. 1 0))
			       (return)))
			   (drop-through)))))
		(parallel
		 (assign b-low-dividend (dpb b-low-dividend 31. 1 0))
		 (if ybus-31
		     (goto ,(fintern "DIVIDE-~D-ADD-1"
				     (if (> step 1) (1- step) n-steps)))
		     (goto ,(fintern "DIVIDE-~D-ADD-0"
				     (if (> step 1) (1- step) n-steps))))))
4,887,235
	425	426
	collect
	 `(defucode ,(fintern "DIVIDE-~D-Q1" step)
	    ,@(if (= step 1)
		  `((parallel
		     (assign a-divide-step-count (1- a-divide-step-count))
		     (if (minus-fixnum obus)
			 (parallel
			  (assign b-low-dividend
				  (1+ (dpb b-low-dividend 31. 1 0)))
			  (return))
		       (drop-through)))))
	    (parallel
	     (assign b-low-dividend (1+ (dpb b-low-dividend 31. 1 0)))
	     (if ybus-31
		 (goto ,(fintern "DIVIDE-~D-SUB-1"
				 (if (> step 1) (1- step) n-steps)))
	         (goto ,(fintern "DIVIDE-~D-SUB-0"
				 (if (> step 1) (1- step) n-steps)))))))))
;For the simulator, make it small and slow
(divide-routine 2)

;This does the first step and enterm the loop at the appropriate point
;The first step is different in that the dividend is not shifted beforehand.
;Tne first step is also different in that if it produces a quotient bit of 1
;there is divide overflow (unsigned quotient doesn’t fit in 32 bits).
;For inteaer division, this only happens when the divisor is zero,
;or when dividing setz by -1 (overflow to bignum)
(defucode divide-subroutine
  (parallel
   (assign b-high-dividend (+ a-negative-divisor b-high-dividend))
   (if (minus-fixnum obus)
       (parallel
	(assign b-low-dividend (dpb b-low-dividend 31. 1 0))
	(if ybus-31
	    (goto DIVIDE-2-ADD-1)	;2: see divide-routine macro above
	    (goto DIVIDE-2-ADD-0)))	;..
     (signal-error divide-by-zero))))

F:>lmach>ucode>disk.lisp.56

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

;;; Microcode for the disk

;To do:
; Save control memory by subroutinizing more, including the nops
; Add network to device service task

(reserve-scratchpad-memory 2510 2514 351 356)

;Do not use define-b-temps here, since this microprogram runs asynchronously
;with the emulator task

;;; "Hardware" definitions

;%device-service-task -- low-priority task started at device-service-loop
;%disk-dma-task -- high-priority tack started by service task when required

(define-lbus-card iob)

;;; Current state of the disk tasks

;This register contains the physical address of the next word to be transferred
;It can be looked at by macrocode (after a disk transfer)
;The sign bit is 0 if this is the last DAP, 1 if more addresses follow (data chaining)
(defareg %disk-memory-address)
(defatomicro disk-memory-address %disk-memory-address) ;synonym without the %

;This register contains the number of words remaining to be transferred, minus 2.
;before advancing to the next DAP. For the last DAP, this is the number of words
;remainin in the block, minus 3 for a write or read-compare, or 4 for a read.
;Note: this register must be in the top 16 B registers to avoid having to
;make disk-new-dap two cycles slower, which is undesirable since it runs
;in a high-priority task.
(defbreg-at-loc disk-word-count 376)

(defareg %disk-dcw-address)	;Physical address of the first word in the
				;DCW command block currently being executed

(defareg disk-dap-address)	;Address from which the next DAP will be fetched

(defbreg current-disk-dcw)	;Copy of DCW currently being executed

(defbreg current-disk-dcw2)	;Second word of current DCW
				;For transfer commands, this is the desired sector header

4,887,235
	427	428
(defareg %disk-sector-max-tries (set-type 20. dtp-fix))
(defareg disk-sector-tries)	;Counts header compares to detect "search error", maybe
				;due to disk heads being positioned wrong.

(defareg %disk-command-address) ;Physical address of disk command register
(defareg %disk-status-address)	;Physical address of disk status register

(defbreg disk-command-val1)	;First command to issue (search or transfer)
				;Also used generally to hold disk status and as temporary
(defbreg disk-command-val2)	;Second command to issue (transfer: write or read-compare)
(defbreg disk-command-stop)	;Value to store to stop it (no start bit)

(defareg disk-temp)		;Temporary for read-disk-status-to-val1

(defareg %disk-wakeup)		;Normally NIL, set to T by wakeup DCW, stop DCW, or error
(defareg %disk-micro-status)	;A fixnum which is the state of the microcode tasks
				;Used both for intercommunication between the 2 micro
				;tasks and for communication with the Lisp-coded driver

(defatomic-byte-field disk-micro-status (4 0) %disk-micro-status)
(associate-dispatch-cues disk-micro-status *disk-micro-status-codes*)
(define-enumerated-value-constants *disk-micro-status-codes*)

(asocciate-dispatch-cues %%dcw-micro-command *dcw-micro-commands*)

(defareg service-task-requests 0)	;Bits for each function required
(defatomic-byte-field %%service-disk (1 0) service-task-requests)
					;DMA task done; ready for next DCLI
;;; Regular net service
(defatomic-byte-field %%service-net (1 1) service-task-requests)
;;; Receive end service
(defatomic-byte-field %%service-receive-end (1 2) service-task-requests
;;; Abnormal transmit termination
(defatomic-byte-field %%service-transmit-collision (1 3) service-task-requests)

;Wakeup the disk driver macrocode
;This is called in the service task
(defmicro wakeup-driver ()
  `(parallel (assign %disk-wakeup quote-t)
	     (call set-sequence-break)))

;Wakeup the disk service task
;This is called in the DMA task usually, but can also be called by the emulator
(defmicro wakeup-disk-service ()
  `(parallel (assign service-task-requests
		     (logior service-task-requests (b-constant (byte-mask %%service-disk))))
	     (wakeup-task %device-service-task)))

;Set the state of the disk DMA task. Hardware will wake it up.
(defmicro start-disk-dma (location)
  `(write-task-state %disk-dma-task
		     (a-constant `(build-task-state cpc ,location
						    npc (npc-successor ,location)
						    csp 17))))

;Dismiss in both the CPU and the IOB, when not starting a dma cycle
(defmicro dismiss-disk-task ()
  `(parallel (write-lbus-dev iob 4 nil)
	     (dismiss)))

;Same, with task-acknowledge (prevent overrrun)
(defmicro dismiss-disk-task-and-ack (&optional end-flag)
  `(parallel (write-lbus-dev iob ,(if end-flag 6 2) nil)
	     (dismiss)))

;Space-saver
(defmicro phys-mem-read (address)
  `(parallel (start-memory read physical ,address)
	     (call phys-mem-read-delay)
	     (declare-memory-timing (next data-cycle))))

(defucode phys-mem-read-delay
  (return))

;Terminate the disk DMA task (called in that task). This is used for
;both normal and error termination. Sets %disk-micro-status to its
;argument, awakens the service task, kills the disk dma task assignment,
;and dismisses (looping a little until the dismiss takes effect).
;This also clears control tag, while leaving the rest of the command
;register, and the error status, intact. We must store into %disk-micro-status
;before awakening the service task, since we might enter this microsequence
;with a dismiss of the DMA task already pending.
(defmicro terminate-disk-dma (disk-status-code)
  `(sequential
    (parallel
     (extra-time-to-drive-lbus)			;Needed by many callers, save typing
     (assign %disk-micro-status (set-type ,disk-status-code dtp-fix)))
    (parallel
     (wakeup-disk-service)
     (jump terminate-disk-dma))))

4,887,235
	429	430
(defucode terminate-disk-dma
  (parallel
   (dismiss)
   (write-lbus-dev iob 5 nil)		;Clear tack assignment, control tag
   (jump terminate-disk-dma)))		;Keep stabbing until the blood flows

;The IOB is slow to drive the write-data onto the bus
;Put the extra tims in the first half so it occurs before the clock
;We want the ecc bits to be set up at the memory before the clock (write command)
(defmicro extra-time-to-drive-lbus ()
  `(microinstruction speed slow-first-half))

;It’s slow for microdevice reads, too, for the same reason
(defatomicro read-disk-buffer
  (parallel
   (read-lbus-dev iob 0)
   (declare-speed slow-first-half)))

;This kludge is to compensate for the fact that the disk status register is not
;synchronized with the Lbus clock. There is no safe way to read a consistent
;set of bits, however we can read whatever we get as long as we don’t put it
;in a place that has parity checking.
;Result ends up in the disk-command-val1 B-register (low 28 bits only)
(defmicro read-disk-status-to-val1 ()
  `(parallel
    (start-memory read physical %disk-status-address)
    (call read-disk-status-to-val1)))

(defucode read-disk-status-to-val1
  (parallel
   (declare-memory-timing active-cycle)
   (assign disk-temp frame-pointer))		;Save register while awaiting memory
  (assign frame-pointer memory-data)		;Capture and synchronize memory data
  (assign disk-command-val1 frame-pointer)	;Store result
  (parallel (assign frame-pointer disk-temp)
	    (return)))

;;; Disk DMA task.

;This micro generates the search for sector header at the front of a DMA routine
;Entered the first time with the disk idle, future times with the disk reading
;5 cycles per wakeup if sector not fcund
;1 cycle (plus body) when sector found
(defmacro define-disk-search-ucode (tag &body body)
  (or (eq (car body) 'goto) (setq body `(sequential . ,body)))
  `(defucode ,tag
     ;; Stop the disk state machine if it is running
     (parallel
      (start-memory write physical %disk-command-address)
      (assign memory-data disk-command-stop))
     ;; Start the hardware searching for the next sector header
     (parallel
      (start-memory write physical %disk-command-address)
      (assign memory-data disk-command-val1))
     ;; Dismiss until the header has been read
     (parallel
      (dismiss-disk-task)
      ;; Stop if too many tries without a header match
      (assign disk-sector-tries (1- disk-sector-tries))
      (if (minus-fixnum obus)
	  (terminate-disk-dma %disk-micro-status-search-error)
	(nop)))
     ;; Come back here on next wakeup, with header in disk buffer register
     ;; If header matches, drop through: otherwise keep searching
     (if (not-equal-fixnum current-disk-dcw2 read-disk-buffer)
	 (goto ,tag)
       ,body)))

;Call here when a DAP has been exhausted and we need to start transferring
;at a new address. Haven’t dismissed yet after transferring the last word
;in the old DAP’s block of addresses. Dismisses and returns on next wakeup,
;with address and word count set up from new DAP. Skips upon return if
;this was not the last DAP.
;We use up 6 cycles instead of the usual 2 per wakeup.
(defucode disk-new-dap
  (nop)					;Wait for memory to be unbusy
  (parallel				;Fetch first word of DAP
   (start-memory read physical disk-dap-address)
   (assign disk-dap-address (1+ disk-dap-address)))
  (parallel				;Fetch second word of DAP
   (start-memory read physical disk-dap-address)
   (assign disk-dap-address (1+ disk-dap-address)))
  (parallel
   (dismiss-disk-task)
   (assign disk-word-count memory-data))
  (parallel
   (assign disk-memory-address memory-data)
   (return-skip (minus-fixnum memory-data)))) ;Test chain bit

4,887,235
	431	432
;Read routine. Use this for both 32-bit and 36-bit reads.
(define-disk-search-ucode disk-read
  ;; Wait for first data word in sector
  (dismiss-disk-task-and-ack)
  (if (minus-fixnum disk-memory-address)
      (goto disk-read-loop)
      (goto disk-read-loop-last)))

;DMA transfer loop, when this is not the last DAP
(defucode disk-read-loop
  ;; First cycle: increment MA, start memory
  (parallel
   (start-memory write physical disk-memory-address dma iob 3)
   (assign disk-memory-address (1+ disk-memory-address))
   (dismiss)
   (if lbus-dev-cond
       (terminate-disk-dma %disk-micro-status-disk-error)
     (drop-through)))
  ;; Second cycle: count down WC.
  (parallel
   (extra-time-to-drive-lbus)
   (assign disk-word-count (1- disk-word-count))
   (if (minus-fixnum obus)
       (parallel
	;; First cycle for last word in this DAP. Transfer then fetch next DAP.
	;; We don’t check for disk-error here, but if there is one we’ll
	;; notice it soon enouch.
	(start-memory write physical disk-memory-address dma lob 1)
	(assign disk-memory-address (1+ disk-memory-address))
	(call-and-return-skip disk-new-dap disk-read-loop-last disk-read-loop))
     (goto disk-read-loop))))

;DMA transfer loop, when this is the last DAP
(defucode disk-read-loop-last
  ;; First cycle: increment MA, start memory
  (parallel
   (start-memory write physical disk-memory-address dma iob 3)
   (assign disk-memory-address (1+ disk-memory-address))
   (dismiss)
   (if lbus-dev-cond
       (terminate-disk-dma %disk-micro-status-disk-error)
     (drop-through)))
  ;; Second cycle: count down WC.
  (parallel
   (extra-time-to-drive-lbus)
   (assign disk-word-count (1- disk-word-count))
   (if (minus-fixnum obus)
       (goto disk-read-drain)
       (goto disk-read-loop-last))))

;Here to read the last 3 words
(defucode disk-read-drain
  ;; Transfer last word with end flag, then 2 more drain words which
  ;; the disk sends before it stops
  (parallel
   (start-memory write physical disk-memory-address dma iob 7)
   (assign disk-memory-address (1+ disk-memory-address))
   (dismiss)
   (if lbus-dev-cond
       (terminate-disk-dma %disk-micro-status-disk-error)
     (drop-through)))
  (parallel
   (extra-time-to-drive-lbus)
   (nop))
  (parallel
   (start-memory write physical disk-memory-address dma iob 7)
   (assign disk-memory-address (1+ disk-memory-address))
   (dismiss)
   (if lbus-dev-cond
       (terminate-disk-dma %disk-micro-status-disk-error)
     (drop-through)))
  (parallel
   (extra-time-to-drive-lbus)
   (nop))
  (parallel
   (start-memory write physical disk-memory-address dma iob 7)
   (assign disk-memory-address (1+ disk-memory-address))
   (dismiss)
   (if lbus-dev-cond
       (terminate-disk-dma %disk-micro-status-disk-error)
     (drop-through)))
  (parallel
   (extra-time-to-drive-lbus)
   (nop))
  ;; Wake up here when state machine stops, after reading ECC
  (terminate-disk-dma %disk-micro-status-end-read))

;Write routine, Use this for both 32-bit and 36-bit writes.
;6 cycles the first time through
(define-disk-search-ucode disk-write
  ;; Stop the disk state machine
  (parallel