4,887,235
	433	434
  (start-memory write physical %disk-command-address)
  (assign memory-data disk-command-stop))
;; Switch disk over to write operation, then feed first word without dismissing
(parallel
 (start-memory write physical %disk-command-address)
 (assign memory-data disk-command-val2)
 (jump disk-write-startup)))

;For first DnA transfer when writing, must not check state machine aliveness since
;it hasn’t sent us any wakeups yet. Must decide whethmr this is last (and first) DAP.
(defucode disk-write-startup
  ;; Increment MA, start memory to fetch first word of write data
  (parallel
   (start-memory read physical disk-memory-address dma iob 3)
   (assign disk-memory-address (1+ disk-memory-address))
   (dismiss)
   (if (minus-fixnum obus)
       (goto disk-write-loop-1)
       (goto disk-write-loop-last-1))))

;DMA transfer boo, not last DAP
(defucode disk-write-loop
  ;; First cycle: increment MA, start memory
  (parallel
   (start-memory read 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)
     (goto disk-write-loop-1))))

(defucode disk-write-loop-1
  ;; Second cycle: count down LIC.
  (parallel
   (assign disk-word-count (1- disk-word-count))
   (if (minus-fixnum obus)
       (parallel
	;; Transfer last word and fetch new DAP
	(start-memory read physical disk-memory-address dma iob 1)
	(assign disk-memory-address (1+ disk-memory-address))
	(call-and-return-skip disk-new-dap disk-write-loop-last disk-write-loop))
     (goto disk-write-loop))))

;DMA transfer loop, last DAP
(defucode disk-write-loop-last
  ;; First cycle: increment MA, start memory
  (parallel
   (start-memory read 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)
     (goto disk-write-loop-last-1))))

(defucode disk-write-loop-last-1
  ;; Second cycle: count down WC.
  (parallel
   (assign disk-word-count (1- disk-word-count))
   (if (minus-fixnum obus)
       (goto disk-write-drain)
       (goto disk-write-loop-last))))

;Transfer last two words in sector with end flag
(defucode disk-write-drain
  (parallel (start-memory read 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)))
  (nop)
  (parallel (start-memory read 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)))
  (nop)
  ;; Wake up here when state machine has swallowed last word
  (dismiss-disk-task)
  (nop)
  ;; Wake up here when state machine stops, after writing ECC
  (terminate-disk-dma %disk-micro-status-end-write))

;Read-compare routine. Use this for both 32-bit and 36-bit reads.
;This is a hybrid of read and write
(define-disk-search-ucode disk-read-compare
  ;; Stop the disk state machine
  (parallel
   (start-memory write physical %disk-command-address)
   (assign memory-data disk-command-stop))
  ;; Switch disk over to read/compare operation, then feed first word without dismissing
  (parallel
4,887,235
	435	436
    (start-memory write physical %disk-command-address)
    (assign memory-data disk-command-val2)
    (jump disk-read-compare-startup)))

;For first DMA transfer, must not check state machine aliveness since
;it hasn’t sent us any wakeups yet. riust decide whether this is last (and first) DAP.
(defucode disk-read-compare-startup
  ;; Increment MA, start memory to fetch first word of data
  (parallel
   (start-memory read physical disk-memory-address dma iob 3)
   (assign disk-memory-address (1+ disk-memory-address))
   (dismiss)
   (if (minus-fixnum obus)
       (goto disk-read-compare-loop-1)
       (goto disk-read-compare-loop-last-1))))

;DMA transfer loop, not last DAP
(defucode disk-read-compare-loop
  ;; First cycle: increment MA, start memory
  (parallel
   (start-memory read physical disk-memory-address dma iob 3)
   (assion disk-memory-address (1+ disk-memory-address))
   (dismiss)
   (if lbus-dev-cond
       (terminate-disk-dma %disk-micro-status-disk-error)
     (goto disk-read-compare-loop-1))))

(defucode disk-read-compare-loop-1
  ;; Second cycle: count down WC.
  (parallel
   (assign disk-word-count (1- disk-word-count))
   (if (minus-fixnum obus)
       (parallel
	;; Transfer last word and fetch new DAP
	(start-memory read physical disk-memory-address dma iob 1)
	(assign disk-memory-address (1+ disk-memory-address))
	(call-and-return-skip disk-new-dap
			      disk-read-compare-loop-last disk-read-compare-loop))
     (goto disk-read-compare-loop))))

;DMA transfer loop, last DAP
(defucode disk-read-compare-loop-last
  ;; First cycle: increment MA. start memory
  (parallel
   (start-memory read 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)
       (goto disk-read-compare-loop-last-1))))

(defucode disk-read-compare-loop-last-1
  ;; Second cycle: count down WC.
  (parallel
   (assign disk-word-count (1- disk-word-count))
   (if (minus-fixnum obus)
       (goto disk-read-compare-drain)
       (goto disk-read-compare-loop-last))))

;Transfer last two words in sector with end flag
(defucode disk-read-compare-drain	
  (parallel
   (start-memory read 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)))
  (nop)
  (parallel
   (start-memory read 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)))
  (nop)
  ;; Wake up here when state machine has swallowed last word
  (dismiss-disk-task)
  (nop)
  ;; Wake up here when state machine stops, after reading ECC
  (terminate-disk-dma %disk-micro-status-end-read-compare))

;Write-all command. Wait for’ an index pulse then go start writing.
(defucode disk-write-a;;
  (call-and-return-to start-read-or-write-all disk-write-startup))

;Read-all command. Wait for an index pulse then start reading.
(defucode disk-read-all
  (call start-read-or-write-all)
  (dismiss-disk-task)
  (if (minus-fixnum disk-memory-address)
4,887,235
	438
      (goto disk-read-loop)
      (goto disk-read-loop-last)))

;Since index pulse is narrow, we actually loop in this high-priority task
(defucode start-read-or-write-all
  ;; Loop until Index is true
  (read-disk-status-to-val1)
  (if (field-bit disk-command-val1 %%dsr-index)
      (drop-through)
      (goto start-read-or-write-all))
  :; Start up the disk state machine. By the time it gets going we should
  ;; be near the trailing edge of Index.
  (parallel
   (start-memory write physical %disk-command-address)
   (assign memory-data disk-command-val2)
   (return)))


;Sector-wait command (used for seek-wait)
;Service task starts hardware in Sector Wait command. We wakeup immediately
;and then again at the beginning of the next sector
(defucode disk-sector-wait
  (dismiss-disk-task)
  (nop)
  ;; Wake up here when state machine sees sector pulse
  (terminate-disk-dma %disk-micro-status-end-sector-wait))

;Read-header command
;Service task starts hardware in Read command, we awaken immediately
;and then again when sector header found
;--- This is pretty much guaranteed to cause an overrun...what to do?
(defucode disk-read-header
  (dismiss-disk-task)
  (nop)
  ;; Do a DMA write of the header into the DCW list (in the immediate arg of the read-header)
  (start-memory write physical disk-dap-address dma iob 1)
  (terminate-disk-dma %disk-micro-status-end-write))

;;; Service task
;--- for now, only serves the disk. Add the network later.
(defucode device-service-loop
  ;; Scan requests for service
  (if (bit %%service-disk)
      ;; Disk service (DMA task not running now)
      (dispatch-after-this disk-micro-status
			   (assign %%service-disk (b-constant 0))
	((%disk-micro-status-idle %disk-micro-status-in-sector %disk-micro-status-stop)
	 (jump device-service-end)) ;Use jump rather than goto to save space
	((%disk-micro-status-search-error %disk-micro-status-disk-error
					  %disk-micro-status-ecc-done)
	 (parallel (wakeup-driver)
		   (jump device-service-end)))
	((%disk-micro-status-start)
	 (goto fetch-disk-dcw))
	((%disk-micro-status-end-sector-wait)
	 (jump disk-seek-wait)) ;Use jump rather than goto to save space
	((%disk-micro-status-end-write)
	 (call-and-return-to check-disk-status next-disk-dcw))
	((%disk-micro-status-end-read)
	 (call check-disk-status)
	 (parallel
	  (trap-if (not (field-bit disk-command-val1 %%dsr-ecc-ok)) disk-error-detected)
	  (jump next-disk-dcw)))
	((%disk-micro-status-end-read-compare)
	 (call check-disk-status)
	 (trap-if (field-bit disk-command-val1 %%dsr-compare-error) disk-error-detected)
	 (parallel
	  (trap-if (not (field-bit disk-command-val1 %%dsr-ecc-ok)) disk-error-detected)
	  (jump next-disk-dcw)))
	(otherwise
	 (goto device-service-end)))	;Ignore any garbage status
    ;; No requests for service
    (goto net-service-loop)))

;; If no requests, dismiss. If more requests have come in, go do them without
;; dismissing. Check must be in same cycle as dismiss to avoid hazard.
(defucode device-service-end
  (parallel
   (trap-if (not-zero-fixnum service-task-requests)
	    device-service-loop)
   (dismiss))
  (nop)					;Wait two cycles for dismiss
  (jump device-service-loop))

;Read disk status register. Die if error, and return status in disk-command-vali.
;Note that the control stack can remain pushed spuriously if an error is detected.
;This is not a problem since there are no magic locations in this task's control stack.
(defucode check-disk-status
  (read-disk-status-to-val1)
  (parallel
4,887,235
	439	440
    (trap-if (bit-test (a-constant (get '%dsr-error-mask 'sysconstant)) disk-command-val1)
	     disk-error-detected)
    (return)))

(defucode disk-error-detected
  (assign %disk-micro-status (set-type %disk-micro-status-disk-error dtp-fix))
  (parallel (wakeup-driver)
	    (jump device-service-end)))

;; Do next DCW after the one we just did
(defucode next-disk-dcw
  (parallel
   (assign %disk-dcw-address (+ %disk-dcw-address (ldb-field current-disk-dcw %%dcw-length)))
   (jump fetch-disk-dcw)))

;; Do DCLI whose address has been set up
(defucode fetch-disk-dcw
  ;; Start fetch of first word
  (parallel (start-memory read physical %disk-dcw-address)
	    (assign disk-dap-address (1+ %disk-dcw-address)))
  ;; Start fetch of second word
  (parallel (start-memory read physical disk-dap-address)
	    (assign disk-dap-address (1+ disk-dap-address)))
  ;; Store the DCW away. Cannot be overlapped with dispatch due to damnable field conflicts
  (assign current-disk-dcw memory-data)
  (assign current-disk-dcw2 memory-data)
  ;; Decode the DCW
  (dispatch-after-this (ldb-field current-disk-dcw %%dcw-micro-command)
	;; Initialize micro status
	(assign %disk-micro-status (set-type %disk-micro-status-in-sector dtp-fix))
	((%dcw-u-nop)
	 (goto next-disk-dcw))
	((%dcw-u-stop)
	 (sequential
	  (assign %disk-micro-status (set-type %disk-micro-status-stop dtp-fix))
	  (parallel (wakeup-driver)
		    (jump device-service-end))))
	((%dcw-u-wakeup)
	 (parallel (wakeup-driver)
		   (jump next-disk-dcw)))
	((%dcw-u-goto)
	 (parallel
	  (assign %disk-dcw-address current-disk-dcw2)
	  (jump fetch-disk-dcw)))
	((%dcw-u-head)
	 (goto disk-head-select))
	((%dcw-u-seek-wait)
	 (goto disk-seek-wait))
	((%dcw-u-read-header)
	 (start-disk-dma disk-read-header)
	 (parallel (start-memory write physical %disk-command-address)
		   (assign memory-data current-disk-dcw2)
		   (jump device-service-end)))
	((%dcw-u-read)
	 (parallel (start-disk-dma disk-read)
		   (jump start-disk-transfer)))
	((%dcw-u-write)
	 (parallel (start-disk-dma disk-write)
		   (jump start-disk-transfer)))
	((%dcw-u-read-compare)
	 (parallel (start-disk-dma disk-read-compare)
		   (jump start-disk-transfer)))
	((%dcw-u-read-all)
	 (parallel (start-disk-dma disk-read-all)
		   (jump start-disk-transfer)))
	((%dcw-u-write-all)
	 (parallel (start-disk-dma disk-write-all)
		   (jump start-disk-transfer)))
	((%dcw-u-ecc)
	 (start-disk-dma disk-ecc)
	 (parallel (start-memory write physical %disk-command-address)
		   (assign memory-data current-disk-dcw2)
		   (jump device-service-end)))
	(otherwise 		;Die if garbage seen
	 (sequential
	  (assign %disk-micro-status (set-type %disk-micro-status-stop dtp-fix))
	  (parallel (wakeup-driver)
		    (jump device-service-end))))))

;Transfer DCWs come here. The state of the DMA task has been set.
(defucode start-disk-transfer
  ;; Start fetch of third word (command)
  (parallel (start-memory read physical disk-dap-address)
	    (assign disk-dap-address (1+ disk-dap-address)))
  ;; Start fetch of first DAP
  (parallel (start-memory read physical disk-dap-address)
	    (assign disk-dap-address (1+ disk-dap-address)))
  ;; Stash command
  (assign disk-command-val1 memory-data)
  ;; Complete fetch cf first DAP
  (assign disk-word-count memory-data)
4,887,235
	441	442
  (parallel (start-memory read physical disk-dap-address)
	    (assign disk-dap-address (1+ disk-dap-address)))
  (assign disk-command-stop (logand disk-command-val1
				    (a-constant (lognot (field-mask %%dcr-busy)))))
  (assign disk-memory-address memory-data)
  ;; Screw around for 2 extra cycles because of conflicts for AMWA
  (assign disk-sector-tries (ldb-field current-disk-dcw %%dcw-dcr-command))
  (assign disk-sector-tries (dpb-field disk-sector-tries %%dcr-command disk-command-val1))
  (assign disk-command-val2 disk-secter-tries)

  (assign disk-sector-tries %disk-sector-max-tries)
  (parallel (start-memory write physical %disk-command-address)
	    (assign memory-data disk-command-stop)	;Wake up and go to sleep
	    (jump device-service-end)))

;Check whether seek has completed immediately and at every sector pulse thereafter
(defucode disk-seek-wait
  (parallel (assign %disk-micro-status (set-type %disk-micro-status-in-sector dtp-fix))
	    (call check-disk-status))
  (if (field-bit disk-command-val1 %%dsr-on-cylinder)
      (goto next-disk-dcw)
    (drop-through))
  (start-disk-dma disk-sector-wait)
  (parallel (start-memory write physical %disk-command-address)
	    (assign memory-data current-disk-dcw2)
	    (jump device-service-end)))

;Head select -- need to twiddle tog bit up end down
(defucode disk-head-select
  ;; Write bus, with tag bit turned off
  (parallel (start-memory write physical %disk-command-address)
	    (assign memory-data current-disk-dcw2))
  ;; Write again, with tag bit turned on
  (assign disk-command-val1 (logior (a-constant (field-mask %%dcr-head-tag))
				    current-disk-dcw2))
  (parallel (start-memory write physical %disk-command-address)
	    (assign memory-data disk-command-val1)
	    ;; Delay a microsecond or so by checking for error status
	    (call check-disk-status))
  ;; Clear tag bit, leaving same value on bus
  (parallel (start-memory write physical %disk-command-address)
	    (assign memory-data current-disk-dcw2)
	    (jump next-disk-dcw)))

;Error correction computation. We have to do the word counting here.
;Do it in %disk-memory-add’ess so when we’re done the macrocode can read it.
;First, have to take 335-72 wakeups to rec~cle the ecc code (335 is the
;ecc code field size of 42987 divided by 128. 72 is the sector size
;divided by 128). The state machine takes care of the extra bits for
;the remainder of 42987/128, minus the 32 bits already clocked when the
;ecc was read at the end of the sector and the 64 bits already clocked
;when the prefix was read.
;The -4 is because if %disk-memory-address starts out negative the state
;machine will still process 3 128-bit chunks before it sees the end flag.
(defucode disk-ecc
  (parallel (assign %disk-memory-address (set-type (b-constant (- 335. 72. 4)) dtp-fix))
	    (dismiss-disk-task)
	    (jump disk-ecc-loop-1)))

(defucode disk-ecc-loop-1
  (if (minus-fixnum %disk-memory-address)
      ;; Finished recycling code, start counting words of data field
      ;; Start at -3 because we will wake up twice while two more 128-bit
      ;; chunks are passed over, and if we stop after the first word, that
      ;; is word 0
      (parallel (assign %disk-memory-address (set-type (b-constant -3) dtp-fix))
		(dismiss-disk-task-and-ack end-flag)
		(jump disk-ecc-loop-2))
    (drop-through))
  ;; Wakes up here
  (parallel (assign %disk-memory-address (set-type (1- %disk-memory-address) dtp-fix))
	    (dismiss-disk-task-and-ack)
	    (jump disk-ecc-loop-1)))

;Now run and count words until state machine stops or full sector size has been scanned.
(defucode disk-ecc-loop-2
  (if (greater-or-equal-fixnum %disk-memory-address (b-constant 290.))
      (terminate-disk-dma %disk-micro-status-ecc-done) ;Uncorrectable error
    (drop-through))
  ;; Wakes up here
  (parallel (assign %disk-memory-address (set-type (1+ %disk-memory-address) dtp-fix))
	    (dismiss-disk-task-and-ack)
	    (if lbus-dev-cond		;Was this a complete word, or did at mach stop?
		(terminate-disk-dma %disk-micro-status-ecc-done)	;Correctable error
	      (goto disk-ecc-loop-2))))

;;; Initialization--maybe some day the microcode loader can take care of this?
;;; In the meantime the startup microcode should call this subroutine
(defucode disk-initialize
  (parallel
   (write-task-state %device-service-task
;XXXbrad - missing...
)))

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


;;; Microcode for master control

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

(define-sysconstant main-stack-buffer-address)
(define-sysconstant auxiliary-stack-buffer-address)
(reserve-scratchpad-memory 2514 2520)

(defareg current-dp-control)		;Copy of dp-control register (can’t read back)
(defareg a-page-fault-address)		;VMA of last page fault (for debugging)
(defareg a-page-fault-micro-pc)		;Micro-PC of last page fault (for debugging)

;If this register is non-zero and we pclsr, save-bitblt-buffer must be
;called after restoring the stack pointer.
(defareg bitblt-buffer-active 0)

;Start the machine here
(defucode-at-loc start 1		;105 FOOBAR
  (assign b-quote-t quote-t)		;These are needed on the B side
  (parallel
    (assign b-quote-nil quote-nil)
    (call disk-initialize))		;Initialize other tasks
  ;; Initialize virtual address map
  (parallel (assign vma (a-constant 0))
	    (call clear-map-cache))
  ;; Initialize flags
  (assign a-pclsr-top-of-stack (set-type (b-constant 0) dtp-null))
  (assign bitblt-buffer-active (b-constant 0))
  (assign stack-load-started (b-constant 0))
  (assign current-dp-control (b-constant 0))
  (assign a-stack-group-lock quote-nil)
  (assign b-cached-mapping-table quote-nil)
  (assign %stack-buffer-low (set-type (b-constant 0) dtp-fix)) ;do this in macrocode later...
  (assign %stack-buffer-limit (set-type (b-constant 0) dtp-fix))



  (call switch-to-auxiliary-stack-buffer)
  (parallel (pushval function-system-startup)	;Call this function to start up
	    (call funcall-0-ignore)) 		;Build frame header, set PC
  ;; Mark this frame as the bottom frame so we trap if it tries to return
  (parallel
    (assign frame-misc-data (logior frame-misc-data	;Cause trap on return
				    (b-constant (+ (byte-mask frame-buffer-underflow-bit)
						   (byte-mask frame-bottom-bit)))))
    (call initialize-net))	;Initialize the network
  (parallel
   (assign frame-previous-frame quote-nil)	;No back-pointer in this frame
   (jump pclsr)))		;Adjust CSP and take instruction dispatch

;;; Pclsr

;Come here with new PC (to escape to) loaded. Clear the micro stack, reset the
;main stack, and return to the main loop (eventually the IFU dispatch address)
(defucode pclsr-restore-stack
  (call-and-return-to restore-stack-pointer pclsr))

(defucode pclsr
  ;; Pop stack until clear. If not in emulator task. halt.
  ;; Don’t pop control-stack simultaneous with test, it would cause SQ NEXT INST
  ;; to come on spuriously if stack uas already clear.
  (if (not-zero-fixnum (read-cur-task))
      ;; Not in emulator task
      (halt pclsr-in-io-task)
      ;; In emulator task, check csp left In b-temp as bi-product
      (if (equal-fixnum (ldb b-temp 4 16.) (a-constant 17))
	  ;; Stack is empty, exit
	  (parallel (assign a-pclsr-top-of-stack (set-type (a-constant 0) dtp-null))
		    (jump pclsr-done))		;Must make sure above flag is clear
	;; Stack not empty, pop and try again
	(parallel
	  (for-effect (pop-control-stack))
	  (jump pclsr)))))

(defucode pclsr-done
  (if (not-zero-fixnum bitblt-buffer-active)
      (goto save-bitblt-buffer)
      (next-instruction)))

;Restore stack-pointer to its value at the start of thio macroinstruction,
;clobbering top-of-stack (but no temporaries!)
(defucode restore-stack-pointer
  (assign top-of-stack (logior (a-constant -1_4) stack-adjustment))
  (if (ldb-bit-test top-of-stack 3)
4,887,235
	445	446
      (assign stack-pointer (- stack-pointer top-of-stack))
      (assign stack-pointer (- stack-pointer (ldb top-of-stack 3 0))))
  (if (not (data-type? a-pclsr-top-of-stack dtp-null))
      (parallel (assign top-of-stack-a a-pclsr-top-of-stack)
		(return))
    (return)))

;;; Multiple stack-buffer primitives

;Discard the state of the auxiliary stack buffer and resume the saved state
;of the main stack buffer. If %sequence-break-pending is set, trap imeadiately.
(definst %resume-main-stack-buffer no-operand
  (error-if (not (equal-pointer %current-stack-buffer auxiliary-stack-buffer-address))
	    illegal-instruction)
  (if (not-data-type? %sequence-break-pending dtp-nil)
      (parallel (assign %sequence-break-pending quote-nil)
		(call set-sequence-break))
    (drop-through))
  (assign %control-stack-low %other-control-stack-low)
  (assign %control-stack-limit %other-control-stack-limit)
  (assign %binding-stack-low %other-binding-stack-low)
  (assign %binding-stack-limit %other-binding-stack-limit)
  (assign %binding-stack-pointer %other-binding-stack-pointer)
  (assign %catch-block-list %other-catch-block-list)
  (assign %current-stack-group-status-bits %other-stack-group-status-bits)
  (assign pc %other-pc)		;No instruction fetch since page fault muat be deferred
  (assign frame-pointer %other-frame-pointer)
  (assign stack-pointer %other-stack-pointer)
  (parallel
   (assign %current-stack-buffer (set-type main-stack-buffer-address dtp-fix))
   (assign b-temp obus)
   (call set-stack-buffer))
  (parallel
   (assign top-of-stack top-of-stack-a)
   (jump set-stack-buffer-limit)))

;Explicit switch to aux sb.
;Stack contains function, args, count of args. All popped upon return, no values
;returned unless they are pushed "by hand" before resuming,
(definst %funcall-in-auxiliary-stack-buffer (no-operand needs-stack)
  ;; Perform context switch and pop our arguments
  (assign a-temp (- stack-pointer top-of-stack 1))	;Address of the function
  (parallel
   (assign vma (ldb a-temp 10. 0 main-stack-buffer-address)) ;Translate to physical address
   (decrement-stack-pointer)
   (call switch-to-auxiliary-stack-buffer))
  (parallel
   (assign %other-stack-pointer (- %other-stack-pointer top-of-stack 1))
   (jump %funcall-in-auxiliary-stack-buffer1)))

(defucode %funcall-in-auxiliary-stack-buffer1
  ;; Copy function, args, count into new stack, then perform a function call
  (parallel
    (start-memory read block)
    (assign top-of-stack (1- top-of-stack)))
  (if (greater-fixnum top-of-stack (a-constant -2))
      (sequential
       (parallel
	(assign (amem (stack-pointer 1)) memory-data)
	(increment-stack-pointer))
       (parallel
	(assign vma (ldb vma 10. 0 main-stack-buffer-address))
	(jump %funcall-in-auxiliary-stack-buffer1)))
    (parallel
     (assign (amem (stack-pointer 1)) memory-data)
     (increment-stack-pointer)
     (assign top-of-stack memory-data)
     (call funcall-n-ignore)))
  ;; Mark this frame as the bottom frame so we trap if it tries to return
  (assign frame-misc-data (logior frame-misc-data	;Cause trap on return
				  (b-constant (+ (byte-mask frame-buffer-underflow-bit)
						 (byte-mask frame-bottom-bit)
						 (byte-mask frame-trace-bit)))))
  (parallel
   (assign frame-previous-frame quote-nil)	;No back-pointer in this frame
   (next-instruction)))

;Subroutine to save the main stack buffer’s context and select the auxiliary buffer,
;giving it a freshly-created small control stack, and no binding stack
;This control stack resides in virtual-physical space.
(defucode switch-to-auxiliary-stack-buffer
  ;; State save
  (assign %other-pc pc)
  (assign %other-frame-pointer frame-pointer)
  (assign %other-stack-pointer stack-pointer)
  (assign %other-control-stack-low %control-stack-low)
  (assign %other-control-stack-limit %control-stack-limit)
  (assign %other-binding-stack-low %binding-stack-low)
  (assign %other-binding-stack-limit %binding-stack-limit)
  (assign %other-binding-stack-pointer %binding-stack-pointer)
  (assign %other-catch-block-list %catch-block-list)
4,887,235
	447	448
  (assign %other-stack-group-status-bits %current-stack-group-status-bits)
  ;; Setup new state
  (assign %control-stack-low (set-type auxiliary-stack-buffer-address dtp-locative))
  (assign %control-stack-limit (set-type (+ %control-stack-low (b-constant 1400))
					 dtp-locative))
  (assign %binding-stack-low (set-type (b-constant 0) dtp-locative))
  (assign %binding-stack-limit %binding-stack-low)

  (assign %binding-stack-pointer %binding-stack-low)
  (assign %catch-block-list quote-nil)
  (assign %current-stack-group-status-bits
	  (set-type (a-constant (field-mask sg-halt-on-error)) dtp-fix))
  (assign frame-pointer (set-type (b-constant 0) dtp-null))	;I guess...
  (assign stack-pointer (1- %control-stack-low))
  (assign stack-limit %control-stack-limit)
  (parallel
   (assign %current-stack-buffer (set-type auxiliary-stack-buffer-address dtp-fix))
   (assign b-temp obus)
   (jump set-stack-buffer)))

;Tell the hardware to use the stack buffer whose address is in b-temp
(defucode set-stack-buffer
  (parallel
   (write-dp-control (ldb b-temp 2 10. current-dp-control))
   (assign current-dp-control obus)
   (return)))

;;; Sequence Break

;Set the sequence break flag in the hardware. This is usually called in an I/O task.
(defucode set-sequence-break
  (parallel
   (write-dp-control (dpb (b-constant 1) 1 2 current-dp-control))
   (assign current-dp-control obus)
   (return)))

;Sequence break is deferred if we are already in the auxiliary stack buffer.
;Otherwise switch stack buffers and call the function SEQUENCE-BREAK with no args.
;There is guaranteed always to be enough extra room in the main stack buffer
;to do the necessary pushes for this. We don’t use an escape function because
;there are no pclsring issues, we want to store the real pc in %other-pc,
;and it would save at most one control-memory location.
;Note that the harduare ensures that the EPC is not incremented past the
;instruction that would have been executed next were it not for the sequence break.
;In the TMC5 the DPC gets incremented, however.
(defucode-at-loc sequence-break 16000
  ;; Clear the flag in the hardware
  (parallel
   (write-dp-control (dpb (b-constant 0) 1 2 current-dp-control))
   (assign current-dp-control obus))
  ;; Defer if already on aux buffer
  (if (equal-pointer %current-stack-buffer auxiliary-stack-buffer-address)
      (parallel (assign %sequence-break-pending quote-t)
		(jump ifu-empty-trap))		;Recycle fake IFU by loading PC
    (drop-through))
  ;; Go call the sequence-break handler
  (machine-version-case
   ((tmc5 ifu)					;Function call will advance the return PC
    (assign pc (pc-plus-number pc (b-constant -1)))) ;so decrement it to cancel that cut
   (otherwise nil))
  (pushval function-sequence-break)
  (parallel
   (pushval (set-type (a-constant 0) dtp-fix))	;No arguments
   (jump %funcall-in-auxiliary-stack-buffer)))

;;;; Page fault trap-out

;Come here if there is a page fault, with the referencing address in VI’IA,
;and the fault tyom (%page-pht-miss or %page-write-fault) in a-temp.
;We will do a "take-pre-trap restore-stack" then call PAGE-FAULT with two
;arguments, on the auxiliary stack buffer, whether or not we were already there.
;The macrocode is in charge of figuring our whether this was a "recursive" page fault.
;There is guaranteed always to be enough extra room in the main stack buffer
;to do the necessary pushes for this.


(defucode page-fault
;; Save debugging information. Storing micro-pc takes two cycles because of
;; AMWA conflict and also because valid NPC needed for following call.
  (assign b-temp (logand (pop-control-stack) (b-constant 37777)))
  (assign a-page-fault-micro-pc (set-type b-temp dtp-fix))
  (parallel
   (assign a-page-fault-address vma)
   ;; Restore sp to its state at the start of the instruction
   (call restore-stack-pointer))
  ;; Push funcall block for entering the page-fault macrocode
  (pushval function-page-fault)
  (pushval (set-type vma dtp-fix))
  (pushval (set-type a-temp dtp-fix))
  (pushval (set-type (a-constant 2) dtp-fix))	;2 args
  ;; Restore pc to its state at start of instruction (now that vma is saved)
  (machine-version-case
   ((ifu tmc5) nil)	;Hardware takes care of it
4,887,235
	449	450
   ((tmc)
    (if (equal-pointer a-page-fault-micro-pc
		       (b-constant '(build-task-state cpc ifu-empty-trap-1 npc 0 csp 0)))
	(drop-through)		;Kludge: don’t back up PC if fault on inst fetch
        (assign pc (pc-plus-number pc (b-constant -1))))))
  ;; Call the function, switching to auxiliary stack buffer if not already there
  (call-select-and-return-to
   (equal-pointer %current-stack-buffer auxiliary-stack-buffer-address)
   funcall-n-ignore %funcall-in-auxiliary-stack-buffer
   pclsr))

  ;Temporary for debugging. If you see this, it isn’t here.
  (definst %hack no-operand
    (nop)
    (nop)
    (nop)
    (next-instruction))

F:>lmach>ucode>CATCH.LISP.10

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

; Microcode for catch/throw/unwind-protect instructions

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

;Initialize %catch-block-list to nil (temporary kludge)
; This is now done by >lmach>sysdfl
;(defareg %catch-block-list *nil*)

;Temporaries
(reserve-scratchpad-memory 2424 2430)

(defareg a-catch-pc)
(defareg a-catch-nwords)

;:PUSHVAL without setting the top-of-stack register
(defmicro pushval1 (val)
  `(parallel (assign (amem (stack-pointer 1)) (set-cdr ,val cdr-next))
	     (increment-stack-pointer)))

;This micro writes the code for the catch-block-creation instructions
(defmicro catch-open (value-disposition &optional unwind-protect-hair)
  (setq value-disposition (find-position-in-list value-disposition
						 '(ignore stack return multiple)))
  `(sequential
    ;; The tag is already in the stack. Now push the PC, BSP, and thread.
    (if (not-zero-fixnum macro-unsigned-immediate)
	(pushval1 (pc-add pc macro-unsigned-immediate))
      ;; Offset of zero means pop offset off the stack, and push PC back on.
      ,(if (not unwind-protect-hair)
	   `(newtop (pc-add pc top-of-stack))
	 ;; hairy case for unwind-protect, twiddle the stack
	 `(sequential
	   (parallel
	    (assign b-temp next-on-stack)
	    (assign next-on-stack top-of-stack))
	   (newtop (pc-add pc b-temp)))))
    (pushval %binding-stack-pointer)
    (pushval-with-cdr (set-ccr %catch-block-list ,value-disposition))
    ;; Now link up to the list and set the flag bit in the frame
    (assign %catch-block-list
	    (set-type (- stack-pointer (b-constant 3)) dtp-locative))
    (parallel (assign frame-catch-bit (b-constant 1))
	      (next-instruction))))

(definst catch-open-ignore (unsigned-pc-relative needs-stack)
  (catch-open ignore))

(definst catch-open-stack (unsigned-pc-relative needs-stack)
  (catch-open stack))

(definst catch-open-return (unsigned-pc-relative needs-stack)
  (catch-open return))

(definst catch-open-multiple (unsigned-pc-relative needs-stack)
  (catch-open multiple))

;---This uses T as the magic tag meaning unwind-protect, This is temporary.
(definst unwind-protect-open unsigned-pc-relative
  (sequential (pushval quote-t)
	      (catch-open ignore t)))


;Closing off the current catch block. We are given a number of words at
;the top of the stack to be preserved. Everything between them and the
;base of the catch block is recoved from the stack, the binding stack
4,887,235
	451	452
;is unwound if necessary, the block is unthreaded, bits in the frame
;header are cleared as necessary. Now if the catch block was an unwind-protect,
;the cleanup handler is pushj’ed to; otherwise the instruction simply returns.

(definst catch-close unsigned-immediate-operand
  (parallel (assign a-catch-nwords macro-unsigned-immediate)
	    (jump catch-close-1)))

(definst catch-close-multiple no-operand
  (parallel (check-arg-type top-of-stack top-of-stack-a dtp-fix)
;;XXXbrad (1+?
	    (assign b-catch-nwords (1- top-of-stack-a))
	    (jump catch-close-1)))

;a-catch-nwords has the number of words to be preserved at the top of the stack
(defucode catch-close-1
  ;; Make the catch block addressable. Assume it resides in the current frame.
  (assign xbas %catch-block-list)
  ;; --- First we should fcol around with unsafe pointer-s to the stack
  ;; Pop tho binding stack since that can pclsr
  (assign b-temp (amem (xbas 2)))
  (if (not-equal-pointer b-temp %binding-stack-pointer)
      (call pop-binding-stack-to-b-temp)
		;restore xbas?
    (drop-through))
  ;; Copy Out the parts of the catch block that we will need
  (assign b-temp (amem (xbas 0)))		;Catch tag
  (if (equal-typed-pointer b-temp quote-t)	;unwind-protect
      (sequential
       (parallel
	(assign a-catch-pc (amem (xbas 1)))	;Cleanup handler address
	(call catch-close-2))
       (pushval pc)				;Now pushj to cleanup handler
       (assign pc a-catch-pc)			;Don’t use set-pc. We must not pclsr
       (nop)					;and try to close the catch over again.
	(next-instruction))			;Set the PC first. then take any page foult.
	(goto catch-close-2)))

;Blt down the stack (cannot pclsr after this point)
(defucode catch-close-2
  (assign b-temp frame-pointer)			;Save FP used as a temporary
  (assign b-temp-2 stack-pointer)		;Last word to save
  (assign frame-pointer (- b-temp-2 a-catch-nwords))	;First word to save-1
  (assign stack-pointer (1- %catch-block-list))	;Flush stack down to base of block
  (parallel
    (assign %catch-block-list (amem (xbas 3))) ;Unthread this catch block
    (call blt-stack))
  (parallel
    (assign frame-pointer b-temp)		;Restore FP
    (if (data-type? %catch-block-list dtp-locative)
	(if (greater-or-equal-pointer %catch-block-list b-temp)
	    (return)				;Still some catch blocks in this frame
	    (drop-through))
      (drop-through)))
  (parallel
   (assign frame-catch-bit (b-constant 0))		;No more blocks this frame, clear bit
   (return)))
F:>lmach>ucode>

; -*- Mode:Lisp; Base:8; Lowercase:yes -*-

; Bogus Microcode for testing that various things are possible
; Not all of this will work in the simulator

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

;Micro for the first cycle of a trap handler.
;Finishes the state save by calling for a PUSHJ. which saves
;the original CPC (now in NPC) onto the stack. The original NPC
;is already on the stack.
(defmicro trap-save ()
  '(microinstruction control-stack pushj))

;Micro for the last two cycles of a trap handler.
;Takes arguments of what else to do in those cycles, that
;seeming clear-er- than throwino a parallel around the sequence.
;We restore the NPC and the CPC by twice popping the control
;stack into NPC. In the second cycle we also use NPC as
;as the source for CPC. Thus the push order is NPC, CPC and
;the pop order is CPC, NPC.
(defmicro trap-restore (cycle-1 cycle-2)
  `(sequential
    (parallel
     ,cycle-1
     (microinstruction control-stack popj npc ctos))
    (parallel
     ,cycle-2
     (microinstruction control-stack popj npc ctos cpc npc))))