4,887,235
	273	274
(definst %p-dpb-immed (10-bit-immediate-operand needs-stack)
  (assign vma top-of-stack)
  (parallel
    (start-memory read write)
    (assign b-temp next-on-stack)
    (decrement-stack-pointer))
  (for-effect (popval))
  (parallel
    (assign memory-data (dpb b-temp macro macro memory-data))
    (start-memory write)
    (next-instruction)))

;8 cycles. %p-store-cdr-code could be done in 4 cycles. Saves occodes...
(definst %p-tag-dpb-immed (unsigned-immediate-operand needs-stack)
  (assign vma top-of-stack)
  (parallel
    (start-memory read write)
    (assign b-temp next-on-stack)
    (decrement-stack-pointer))
  (for-effect (popval))
  (assign a-temp-2 memory-data)		;for temporary memory control
  (assign b-temp-2 (high-tag-field a-temp-2 a-temp-2))
  (assign a-temp (strange-ldb b-temp-2 8 34)) ; Rotate left 4 take low 8 bits
  ; Now we have the tag field right-justified, do the user's DPB
  (assign b-temp (dpb b-temp macro macro a-temp))
  ; Re-assembie the memory word and store it back. Not easy
  ; because everyone in sight is trying to use U AMWA field.
  ; Have to do the low & high tag fields separately.
  (assign b-temp-2 (dpb b-temp 4 28. a-temp-2))
  (assign a-temp b-temp-2)
  (parallel
    (assign memory-data (dpb-tag-field-high-only b-temp a-temp))
    (start-memory write)
    (next-instruction)))

;Leaves TOS wrong
(definst %p-store-contents (no-operand smashes-stack)
  (parallel (memread next-on-stack) ;--- request write access?
	    (decrement-stack-pointer))
  (assign a-temp (merge-cdr top-of-stack memory-data))
  (parallel (store-contents a-temp)
	    (decrement-stack-pointer)
	    (next-instruction)))

;Leaves TOS wrong
(definst %p-store-cdr-and-contents (no-operand smashes-stack)
  (parallel (assign vma (amem (stack-pointer -2)))	;Pointer
	    (decrement-stack-pointer))
  (parallel (assign b-temp (rotate (amem (stack-pointer 1)) 6)) ;Cdr
	    (decrement-stack-pointer))
  (assign a-temp (dpb-cdr-field (ldb b-temp 2 6) (amem (stack-pointer 1)))) ;merge Contents
  (parallel (store-contents a-temp)
	    (decrement-stack-pointer)
	    (next-instruction)))

;Leoves TOS wrong
(definst %p-store-tag-and-pointer (no-operand needs-stack smashes-stack)
  ; a-temp gets pointer-field. b-temp gets tag-field
  (parallel (assign a-temp top-of-stack)
	    (assign b-temp next-on-stack))
  ; a-temp gets the word to be stored
  (parallel (assign a-temp (dpb-tag-field b-temp a-temp))
	    (decrement-stack-pointer))
  ; vma gets address to store it into
  (parallel (assign vma next-on-stack)
	    (decrement-stack-pointer))
  ; store it
  (parallel
    (start-memory write)
    (assign memory-data a-temp)
    (decrement-stack-pointer)
    (next-instruction)))

(definst %p-contents-as-locative (no-operand needs-stack)
  (memread top-of-stack)
  (parallel (newtop (set-type memory-data dtp-locative))
	    (next-instruction)))

;Args are pointer and offset. Follow any structure forwarding in the
;header pointed to by the pointer, then return the result plus the
;offset, as a locative. Offset isn’t type checked since not convenient.
;This used to do a data-type check, forcing the base word to really be a header.
;That turned out to be too inconvenient, and the A machine doesn’t do it,
;so I flushed it.
(definst %p-structure-offset no-operand
  (parallel (memread next-on-stack)
	    (assign b-vma next-on-stack))
  (transport header-or-data)
  (parallel (pop2push (set-type (+ b-vma top-of-stack-a) dtp-locative))
	    (next-instruction)))
4,887,235
	275	276
(definst follow-structure-forwarding no-operand
  (parallel (memread top-of-stack-a)
	    (assign b-vma top-of-stack-a))
  (transport header-or-data)
  (parallel (newtop (pointer-field b-vma top-of-stack-a))
	    (next-instruction)))

(definst follow-cell-forwarding no-operand
  (parallel (check-arg-type 0 next-on-stack dtp-locative)
	    (assign vma next-on-stack)
	    (assign b-vma next-on-stack))
  (start-memory read)
  (if (data-type? top-of-stack-a dtp-nil)
      (parallel (transport bind-write)
		(pop2push (set-type b-vma dtp-locative))
		(next-instruction))
    (parallel (transport write)
	      (pop2push (set-type b-vma dtp-locative))
	      (next-instruction))))

;Stop the machine.
;For macrocode breakpoint, this must halt before incrementing the PC. Hence
;SEQUENTIAL rather than PARALLEL.
(definst %halt no-operand
  (sequential (halt %halt)
	      (next-instruction)))	;Allow manual proceed

;Read the microsecond clock
(definst %microsecond-clock no-operand
  (assign b-temp (set-type (read-lbus-dev 36 0) dtp-fix))
  (parallel (pushval b-temp)
	    (next-instruction)))

;;; Bulk memory initialization
;stack-offset                      -4     -3   -2    -1       0
;(%block-store-cdr-and-contents	address count cdr contents increment)
;(%block-store-tag-and-pointer	address count tag pointer  increment)
;a-temp holds word to be stored

(definst %block-store-cdr-and-contents (no-operand needs-stack smashes-stack)
  (assign b-temp (dpb (amem (stack-pointer -2))	2 6 0))	;Align cdr code
  (parallel						;Store-data
    (assign a-temp (dpb-cdr-field (ldb b-temp 2	6) (amem (stack-pointer -1))))
    (jump block-store-start)))

(definst %block-store-tag-and-pointer (no-operand needs-stack smashes-stack)
  (assign b-temp (amem (stack-pointer -2)))	;Tag field
  (assign a-temp (amem (stack-pointer -1)))	;Pointer field
  (parallel					;Store-data
   (assign a-temp (dpb-tag-field b-temp a-temp))
   (jump block-store-start)))

(defucode block-store-start
  (assign a-temp (merge-high-tag (- a-temp top-of-stack) a-temp)) ;Pre-decrement store-data
  (parallel (assign vma (amem (stack-pointer -4)))		;First address in block
	    (jump block-store-fast-loop)))

;Increment data, store result in memory and back in data.
;The increment must not cross a GC space boundary since the GC-map lookup
;is on the unincremented data. The address storing into must not be in Amem.
(defmicro store-contents-with-increment (data increment &rest options)
  '(parallel
    (assign ,data (merge-high-tag (+ ,data ,increment) ,data))
    (store-contents obus obus-as-good-as-abus no-amem . ,options)))

(defucode block-store-slow-loop
  ;; Test count
  (if (minus-or-zero-fixnum (amem (stack-pointer -3)))
      (parallel (assign stack-pointer (- stack-pointer (b-constant 5)))
		(next-instruction))
    (drop-through))
  (store-contents-with-increment a-temp top-of-stack block)
  ;;Update arguments
  (assign (amem (stack-pointer -3)) (set-type (1- (amem (stack-pointer -3))) dtp-fix))
  (assign (amem (stack-pointer -4))
	  (set-type (1+ (amem (stack-pointer -4))) dtp-locative))
  (parallel (assign (amem (stack-pointer -1))
		    (merge-high-tag (+ (amem (stack-pointer -1)) top-of-stack)
				    (amem (stack-pointer -1))))
	    (jump block-store-slow-loop)))

(defucode block-store-fast-loop
  (if (lesser-fixnum (amem (stack-pointer -3)) (b-constant 8))
      (goto block-store-slow-loop)	;Almost done, go slow
      (drop-through))			;Block-writa eight words
  (store-contents-with-increment a-temp top-of-stack block)
  (store-contents-with-increment a-temp top-of-stack block)
  (store-contents-with-increment a-temp top-of-stack block)
  (store-contents-with-increment a-temp top-of-stack block)
  (store-contents-with-increment a-temp top-of-stack block)
4,887,235
	277	278
  (store-contents-with-increment a-temp top-of-stack block)
  (store-contents-with-increment a-temp top-of-stack block)
  (store-contents-with-increment a-temp top-of-stack block)
  (assign (amem (stack-pointer -3))	;Now checkpoint into arguments
	  (set-type (- (amem (stack-pointer -3)) (b-constant 8)) dtp-fix))
  (assign (amem (stack-pointer -4))
	  (set-type (+ (amem (stack-pointer -4)) (b-constant 8)) dtp-locative))
  (parallel (assign (amem (stack-pointer -1))
		    (merge-high-tag (+ (amem (stack-pointer -1))
				       (dpb top-of-stack 29. 3 0))	;i.e. multiply by 8
				    (amem (stack-pointer -1))))
	    (jump block-store-fast-loop)))

;Read an unsynchronized device register. This relies on the fact that the
;emulator task has its own MD register(s), which can be used as a synchronizer.
;---Take out the forced dtp-fix when we get rid of the rev-1 I/O board, which
;---doesn’t always set the data type when reading registers.
(definst %unsynchronized-device-read no-operand
  (memread top-of-stack-a)
  (nop)						;Delay 1 cycle before looking at register
  (parallel (declare-memory-timing data-cycle)	;Fake out error checking in microcode compiler
	    (newtop (set-type memory-data dtp-fix))
	    (next-instruction)))

;This interlocks against tasks, but cannot interlock against the FEP
;Unlike the A-machine, pclsring enables interlocking to work even if the
;old value is transported. interlocking does not work in the presence
;of forwarding-pointers. however.
(definst store-conditional (no-operand needs-stack)
  (parallel
   (check-arg-type 0 (amem (stack-pointer -2))	dtp-locative)
   (memread-write (amem (stack-pointer -2))))	;First ensure write access
  (parallel					;Then read it again. interlocked
    (start-memory read)				;This won’t start if task switch impending
    (disable-tasking))				;Prevent task switch before data cycle
  (parallel
    (assign b-temp next-on-stack)		;Desired old contents
    (assign a-temp top-of-stack)		;New contents
    (decrement-stack-pointer)
    (disable-tasking))				;Prevent task switch before store started
  (parallel
   (transport)
   (assign b-temp memory-data)
   (if (equal-typed-pointer memory-data b-temp)
       (sequential				;Succecd
	 (store-contents a-temp (cdr b-temp))
	 (parallel
	   (pop2push quote-t)
	   (next-instruction)))
       (parallel				;Fail
	  (pop2push quote-nil)
	  (next-instruction)))))


F:>lmach>ucode>stack-buffer.lisp.67

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

; Microcode for maintenance of the stack buffer


#M
(declare (cond ((not (status feature lmucode))
		(load 'udcls))))

(declare (special *page-size*)) ;in SIM

;Dump a page out of the stack
;Checks for stack overflow. unmaps the page from the stack buffer, and pushes
;state into the stack, setting stack-load-started.
;	first address to dump
;	last address to dump +1
;This stack state allows the instruction to be pclsred during the dumping process
;After the dumping is complete, the stack-buffer-underflow bits are reset to
;reflect the new bottom frame in the stack, the state is removed. stack-load-started
;is cleared, the new page is mapped into A-memory, and the stack-buffer address and
;limit are adjusted.
;flush not attempt to stack-group-switch while stack-load-started flag is set!
(definst stack-dump no-operand
  (if (not (bit stack-load-started))
      (sequential
       (error-if (greater-or-equal-pointer stack-limit %control-stack-limit)
		 stack-overflow)
       (pushval (set-type %stack-buffer-low dtp-fix))
4,887,235
	279	280
	;;--- Temporary kludge necessary because stacks are arrays, which they
	;;--- shouldn’t be, and hence are not page-aligned
	(if (lesser-pointer top-of-stack %control-stack-low)
	    (newtop (set-type %control-stack-low dtp-fix))
	  (drop-through))
	(pushval (set-type (+ %stack-buffer-low (b-constant *page-size*)) dtp-fix))
	(parallel (assign b-temp %stack-buffer-low)	;Unmap old page
		  (assign %stack-buffer-low top-of-stack)
		  (call clear-b-temp-page-from-map-cache))
	(parallel (assign stack-load-started (b-constant 1))
		  (clear-stack-adjustment)))	;Keep this stack state if pclsr
    (drop-through))
  (parallel (assign xbas next-on-stack)
	    (assign vma next-on-stack)
	    (call stack-dump-loop))
  (parallel (assign vma (+ %stack-buffer-low (b-constant (* 3 *page-size*))))
	    (call map-page-to-stack-buffer))	;Map new fourth page
  (parallel (decrement-stack-pointer)
	    (assign stack-load-started (b-constant 0)))
  (parallel (for-effect (popval))
	    (jump adjust-frame-buffer-underflow-bits)))

(defucode stack-dump-loop
  (if (equal-pointer next-on-stack top-of-stack)
      (goto set-stack-buffer-limit)
    ;;Dump 1 word. For real memory control, can change this to do 8 words in a block
    ;;write. then advance xbas and next-on-stack by 8 instead of 1. Must be careful
    ;;:not to advance state until after guaranteed not to page-fault.
    (sequential
     (store-contents (amem (xbas 0)))
     (parallel (assign next-on-stack (1+ next-on-stack))
	       (assign xbas obus)
	       (assign vma obus)
	       (jump stack-dump-loop)))))

(defucode set-stack-buffer-limit
  ;; Now decide how many pages of stack buffer to use. Normally 4, unless we are
  ;; close to the erd of the stack.
  ;; Maximum frame size is 400 here. Decrease this to 100 later when compiler detects
  ;; larce frames and generates explicit checking instructions
  (assign stack-limit (set-type (+ %stack-buffer-low (b-constant (- 2000 400 1))) dtp-fix))
  (if (greater-pointer stack-limit %control-stack-limit)
      (assign stack-limit %control-stack-limit)
    (drop-through))
  ;; Set %stack-buffer-limit to highest virtual address in stack buffer.
  ;; This 1+ is hecause the maximum frame size is 400. if it was smaller it could be deleted.
  (assign %stack-buffer-limit (1+ stack-limit))
  (parallel
   (assign %stack-buffer-limit
	   (set-type (logior %stack-buffer-limit (b-constant (1- *page-size*))) dtp-fix))
   (return)))


;Stack-buffer loading. At this point the current frame is not even in
;the stack buffer.


;Find the previous frame and decide how many pages need to be loaded into the
;stack buffer. We need all of the current frame plus the part of its caller
;that contains our arguments. Unmap that many pages from the high end, copy
;the pages from main memory into the stack buffer, then map those addresses
;into A-memory. Adjust the frame-buffer-under-flow bits in the newly-loaded
;frames.
;The following state is kept in the stack across pclsrings, protected by stack-load-started.
;	First address to be loaded
;	Next address to be loaded
;	Last address to be loaded+1
(definst stack-load no-operand
  (if (not (bit stack-load-started))
      (sequential
        ;; Read frame-previous-top from memory
        (memread (- frame-pointer (b-constant 4)))
	(assign a-temp (1+ memory-data))	;Lowest address in frame
	;; Push state (new %stack-buffer-low, range of memory to be loaded)
	(pushval (set-type (logand a-temp (b-constant (- *page-size*))) dtp-fix))
	(pushval top-of-stack)
	;;--- Temporary kludge necessary because stacks are arrays, which they
	;;--- shouldn’t be, and hence are not page-aligned
	(if (lesser-pointer top-of-stack %control-stack-low)
	    (newtop (set-type %control-stack-low dtp-fix))
	  (drop-through))
	(pushval (set-type %stack-buffer-low dtp-fix))
		 (parallel (assign stack-lead-started (b-constant 1))
			   (clear-stack-adjustment)))	;Keep this stack state if pclsr
	(drop-through))
    (parallel (assign xbas next-on-stack)
	      (call stack-load-loop))
    (parallel (assign stack-load-started (b-constant 0))
	      (call stack-load-setup-map))
    (parallel (for-effect (popval))
	      (jump adjust-frame-buffer-underflow-bits)))

4,887,235
	281	282
;--- Make a temporary debugging test before entering the real stack-load-loop
;--- The original reason for this has been found, but it probably doesn’t hurt
;--- to leave the test around for a while. If the frame-previous-top of a frame
;--- ever gets clobbered, this will causa the machine to halt before the stack
;--- buffer contents get totally trashed.
(defucode stack-load-loop
  (assign b-temp (- top-of-stack next-on-stack))
  (parallel (trap-if (greater-pointer b-temp (a-constant 1400))
		     (halt stack-buffer-fucked-up))
	    (jump stack-load-loop-1)))

(defucode stack-load-loop-1
  (if (equal-pointer next-on-stack top-of-stack)
      (parallel (assign stack-pointer (- stack-pointer (b-constant 2)))
		(jump fixup-tos))
    ;;Load 1 word. For real memory control, can change this to do 8 words in a block
    ;;read, then advance xbas and next-on-stack by 8 instead of 1. Must be careful
    ;;not to advance state until after guaranteed not to page-fault.
    (sequential
      (assign vma next-on-stack)
      (start-memory read)
      (parallel (assign next-on-stack (1+ next-on-stack))
		(assign xbas obus))
      (parallel (transport)
		(assign (amem (xbas -1)) memory-data)
		(jump stack-load-loop-1)))))

;Loop moving %stack-buller-low down a page and mapping that page until all the pages
;that were loaded have been processed
;Also as we go, unmap the pages that used to map into the same Amem page (from the
;other end of the stack buffer)
(defucode stack-load-setup-map
  (assign %stack-buffer-low (- %stack-buffer-low (b-constant *page-size*)))
  (parallel (assign vma (+ %stack-buffer-low (b-constant (* 4 *page-size*))))
	    (call clear-page-from-map-cache))
  (if (equal-pointer %stack-buffer-low top-of-stack)
      (parallel (assign vma %stack-buffer-low)
		(call-and-return-to map-page-to-stack-buffer set-stack-buffer-limit))
    (parallel (assign vma %stack-buffer-low)
	      (call-and-return-to map-page-to-stack-buffer stack-load-setup-map))))

;Adjust the frame-buffer-underflow-bits of all frames in the stack buffer
;so that the lowest completely-in frame has a 1 and the rest have a 0.
;--- Possibilities for bumming this to avoid having to set bits to
;--- zero (saves one cycle per frame). Remember the frame whose bit
;--- is set, and before dumping clear it. Thus when loading all the
;--- bits will be loaded as zero, and when dumping we need not clear
;--- any bits since they are already clear.

;Frame field accessors relative to xbas rather than fp

(defatomicro xframe-misc-data
  (amem (xbas -2)))

(defatomicro xframe-previous-top
  (amem (xbas -4)))

(defatomicro xframe-previous-frame
  (amem (xbas -5)))

(defatomic-byte-field xframe-buffer-underflow-bit frame-buffer-underflow-bit
  xframe-misc-data)

(defatomic-byte-field xframe-bottom-bit frame-bottom-bit
  xframe-misc-data)

;The code
(defucode adjust-frame-buffer-underflow-bits
  (assign b-temp (+ %stack-buffer-low (b-constant 5))) ;Frame underhang
  (parallel (assign xbas frame-pointer)
	    (assign b-temp-3 obus)
	    (jump adjust-frame-buffer-underflow-bits-1)))

(defucode adjust-frame-buffer-underflow-bits-1
  (if (lesser-pointer xframe-previous-frame b-temp)	;Prev frame not in
      (sequential
        (assign b-temp (1- %stack-buffer-low))
	(if (lesser-pointer xframe-previous-top b-temp) ;This frame not all in
	    (assign xbas b-temp-2)			;so back up one frame
	  (drop-through))
	(parallel
	  (assign xframe-buffer-underflow-bit (b-constant 1))
	  (return)))
      (if (bit xframe-bottom-bit)
	  (return)				;Bottom of stack, all frames in
	(sequential
	  (assign xframe-buffer-underflow-bit (b-constant 0))
	  (assign b-temp-2 b-temp-3)
	  (parallel (assign xbas xframe-previous-frame)
		    (assign b-temp-3 obus)
		    (jump adjust-frame-buffer-underflow-bits-1))))))
4,887,235
	283	284
F:>lmach>ucode>sg.lisp.41
;;: -*- Mode:Lisp; Package:Micro; Base:8; Lowercase:yes -*-
;;; (c) Copyright 1982, Symbolics, Inc.

; Microcode for stack groups

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

(reserve-scratchpad-memory 2444 2450 337 340)

(defareg a-stack-group-lock)		;NIL normally, else how far we have gotten
					;in the process of switching (see the code)
(dafareg a-stack-group-entering)	;stack-group in process of entering
(defareg a-stack-group-leaving)		;tracks for debugging only
(defareg a-stack-group-argument)	;Value being conveyed across SG switch
(defbreg b-binding-boundary)		;Boundary betwesn swapped and unswapped binding stack

(define-enumerated-value-constants *sg-arg-status-codes*)

;This instruction is called by the stack-group-switch primitives, as well as
;from an escape function used for sequence breaks and error traps.
;Takes three arguments on the stack:
;	The value to be conveyed
;	The stack group to switch to
;	The new value for SG-STATUS-BITS of this stack group
;Normally the third argument is simply a new value for SG-ARG-STATUS, howevar
;if higher-order bits are on they get IORed in, allowed nonresumability bits to get set.
;
;Will return with a value on the stack unless the new SC-ARC-STATUS is %SC-ARG-N0NE.
;If the new SC-ARG-STATUS is %SC-ARG-BREAK. then the first argument is ths PC to
;be used when this SG is resumed, instead of the current PC, and no value is
;to me returned in the stack either.
;
;Also we have (associated with the stack group lock) an indication of how far
;we have progressed, so that this instruction can be pclsred.

;Proceed as follows:
;	If the stack-group lock is already locked, re-enter at appropriate point
;	Error if target stack group not resumable
;	Shuffle the stack to reflect how us want it to be upon return
;	This means leave a slot for the value if necessary, then push the PC
;	Lock the stack-group lock
;	Dump the entire stack buffer
;	Swap the special-variable bindings
;	Dump the stack group state (including FP. SP) into main memory
;	Load the new stack group state from main memory into A-memory, FP, SP
;	Load the stack buffer (for the current frame)
;	Stash the argument in the stack if wanted
;	Unswap the bindings
;	Unlock the stack-group lock
;	Popj

(definst %stack-group-switch (no-operand needs-stack)
  ;; Check for retrying after pclsr
  (parallel
    (dispatch-after-next (ldb a-stack-group-lock 3 0)
	      ((0) (goto continue-sg-stack-buffer-dump))
	      ((1) (goto continue-sg-swap-out-bindings))
	      ((2) (goto sg-dump-state))
	      ((3) (goto sg-load-state))
	      ((4) (goto continue-sg-stack-buffer-load))
	      ((5) (goto continue-sg-swap-in-bindings)))
    (if (not (data-type? a-stack-group-lock dtp-nil))
	(take-dispatch)
        (assign a-stack-group-leaving %current-stack-group)))
  ;; Check resumability of new stack group
  (parallel (check-data-type next-on-stack dtp-array)
	    (memread (+ next-on-stack (b-constant (field-word-offset 'sg-nonresumability)))))
  (parallel (transport data)
	    (trap-if (not (zero-fixnum (sg-nonresumability memory-data)))
		     (signal-error stack-group-not-resumable)))
  ;; Process arguments and shuffle the stack appropriately
  (assign (sg-arg-status %current-stack-group-status-bits) top-of-stack)
  (parallel (assign %current-stack-group-status-bits
		    (set-type (logior %current-stack-group-status-bits top-of-stack) dtp-fix))
	    (decrement-stack-pointer))
  (parallel (assign a-stack-group-entering top-of-stack-a)
	    (decrement-stack-pointer))
  (assign a-stack-group-argument top-of-stack-a)
  (if (lesser-or-equal-fixnum-unsigned (sg-arg-status %current-stack-group-status-bits)
				       %sg-arg-break)
      (if (equal-fixnum (sg-arg-status %current-stack-group-status-bits) %sg-arg-break)
	  ;; PC on stack, no value slot under it. pass self as argument
4,887,235
	285	286
	(assign a-stack-group-argument %current-stack-group)
	;; Put PC on stack, no value slot under it
	(newtop pc))
    ;; Normal case, put PC on stack with value slot under it
    (pushval pc))
  ;; Prppare to dumo the stack buffer
  (pushval (set-type %stack-buffer-low dtp-fix))	;First address to dump
  ;;--- Temporary kludge necessary because stacks are arrays, which they
  ;;---	shouldn’t be, and hence are not page-aligned
  (if (lesser-pointer top-of-stack %control-stack-low)
      (newtop (set-type %control-stack-low dtp-fix))
    (drop-through))
  (pushval (set-type stack-pointer dtp-fix))		;Last address to dump+1
  (parallel (assign a-stack-group-lock (set-type (a-constant 0) dtp-fix))
	    (clear-stack-adjustment)
	    (jump sg-stack-buffer-dump)))

(defucode sg-stack-buffer-dump
  ;; Unmap all of the stack buffer pages
  (assign b-temp %stack-buffer-low)
  (if (lesser-pointer b-temp %stack-buffer-limit)
      (parallel
        (assign %stack-buffer-low (+ %stack-buffer-low (b-constant *page-size*)))
	(call-and-return-to clear-b-temp-page-from-map-cache sg-stack-buffer-dump))
    (goto continue-sg-stack-buffer-dump)))

(defucode continue-sg-stack-buffer-dump
  (parallel (assign xbas next-on-stack)
	    (assign vma next-on-stack)
	    (call stack-dump-loop))
  ;; Remove stack-dump-loop arguments from the stack
  (assign stack-pointer (- stack-pointer (b-constant 2)))
  ;; Trere is now nothing mapped into the stack buffer, set it to highest possible pointer
  (assign %stack-buffer-low (set-type (a-constant 1777777777) dtp-fix))
  ;; Prepare to swap the special-variable bindings
  (assign b-binding-boundary (1+ %binding-stack-pointer))
  (parallel
    (assign a-stack-group-lock (set-type (a-constant 1) dtp-fix))
    (jump continue-sg-swap-out-bindings)))

(defucode continue-sg-swap-out-bindings
  (if (equal-pointer b-binding-boundary %binding-stack-low)
      ;; Done whole binding stack
      (goto sg-dump-state)
      (drop-through))
  ;; Read the pointer to the bound location
  (memread (1- b-binding-boundary))
  (parallel (transport)
	    (assign b-temp memory-data))
  ;; Read the old contents cf the bound location, checking write access
  (memread-write (- b-binding-boundary (a-constant 2)))
  (parallel (transport bind)
	    (assign a-temp-2 memory-data))
  ;; Read the current contents of the bound location
  (memread b-temp)
  (parallel (transport bind)
	    (assign a-temp memory-data)
	    (assign b-temp memory-data))
  ;; Write the old contents there (preserve cdr code)
  (store-contents a-temp-2 (cdr b-temp))
  ;; Store current contents into binding stack (better not pclsr!)
  (parallel (assign vma (- b-binding-boundary (a-constant 2)))
	    (assign b-binding-boundary (- b-binding-boundary (a-constant 2))))
  (parallel (store-contents a-temp)
	    (jump continue-sg-swap-out-bindings)))

(defucode sg-dump-state
  ;; Dump FP, SP, and the A-mem copy of the stack group state into memory
  ;; If this pclsrs in the middle, it can just start over from the beginning
  (assign a-stack-group-lock (set-type (a-constant 2) dtp-fix))
  ;; Write FP, SP in not-pointer mode to defeat the phantom stack gc that doesn’t exist yet
  (assign vma (+ %current-stack-group (b-constant (field-word-offset 'sg-frame-pointer))))
  (store-contents (set-type frame-pointer dtp-locative) block not-pointer)
  (store-contents (set-type stack-pointer dtp-locative) block not-pointer)
  ;; Make sure "active" is cleared in the stored state
  (assign (sg-active-bit %current-stack-group-status-bits) (b-constant 0))
  (assign vma (+ %current-stack-group
		 (b-constant (field-word-offset 'sg-binding-stack-pointer))))
  (store-contents %binding-stack-pointer block)
  (store-contents %catch-block-list block)
  (parallel (store-contents %current-stack-group-status-bits block)
	    (jump sg-load-state)))

;Micro to simulate block reads. Also does transport. Get a word every 4 cycles.
(defatomicro next-memory-data
  (parallel (declare-memory-timing data-cycle) ;Coder better get it right...
	    (transport data)
	    memory-data
	    (call start-read-next)))

4,887,235
	287	288
;Subroutine for the above
(defucode start-read-next
  (parallel (assign vma (1+ vma))
	    (jump memread)))

(defucode sg-load-state
  ;; Load FP, SP, and the A-mem copy of the stack group state from memory
  ;; If this pclsrs in the middle, it can just start over from the beginning
  (parallel
    (assign a-stack-group-lock (set-type (a-constant 3) dtp-fix))
    (call sg-load-state-internal))
  ;; Set up to load the stack buffer. Load from the beginning of the page
  ;; that includes tne beginning of the current frame up to top of stack.
  ;; Read frame-previous-top from memory
  (assign vma (- frame-pointer (b-constant 4)))
  (start-memory read)
  (assign a-stack-group-lock (set-type (a-constant 4) dtp-fix))
  (assign a-temp (set-type (1+ memory-data) 0)) ;Lowest address in frame (don’t transport’)
  (pushval (set-type (logand a-temp (b-constant (- *page-size*))) dtp-fix))
  (pushval top-of-stack)
  ;;--- Temporary kludge necessary because stacks are arrays, which they
  ;;--- shouldn’t be. and hence are not page-aligned
  (if (lesser-pointer top-of-stack %control-stack-low)
      (newtop (set-type %control-stack-low dtp-fix))
    (drop-through))
  (parallel (pushval (set-type (1- stack-pointer) dtp-fix)) ;First addr not to load
	    (clear-stack-adjustment)		;Leave in stack if pcler
	    (jump continue-sg-stack-buffer-load)))


(defucode sg-load-state-internal
  (memread (+ a-stack-group-entering (b-constant (field-word-offset 'sg-frame-pointer))))
  (assign frame-pointer next-memory-data)
  (assign stack-pointer next-memory-data)
  (assign %control-stack-low next-memory-data)
  (assign %control-stack-limit next-memory-data)
  (assign %binding-stack-low next-memory-data)
  (assign %binding-stack-limit next-memory-data)
  (assign %binding-stack-pointer next-memory-data)
  (assign %catch-block-list next-memory-data)
  (parallel (declare-memory-timing data-cycle)
	    (transport data)
	    (assign %current-stack-group-status-bits memory-data))
  (assign %current-stack-group a-stack-group-entering)

  ;; Set the active bit in this SG’s stored state, clear other nonresumability bits
  (memread (+ a-stack-group-entering (b-constant (field-word-offset 'sg-active-bit))))
  (parallel (check-data-type memory-data dtp-fix)
	    (assign a-temp (andc2 memory-data (b-constant (byte-mask sg-nonresumability)))))
  (parallel (store-contents (set-type (logior a-temp (b-constant (byte-mask sg-active-bit)))
				      dtp-fix)
			    not-pointer)
	    (return)))

(defucode continue-sg-stack-buffer-load
  ;; Load the current frame into the stack buffer, along with the rest of the page
  ;; containing the beginning of the current frame.
  (parallel (assign xbas next-on-stack)
	    (call stack-load-loop))
  ;; Decide how much stack buffer to use
  (parallel (assign %stack-buffer-low top-of-stack-a)
	    (assign top-of-stack top-of-stack-a)
	    (call-and-return-to set-stack-buffer-limit
				sg-stack-buffer-load-setup-map)))

(defucode sg-stack-buffer-load-setup-map
  ;; Loop mapping all pages that are in the stack buffer
  ;; including those beyond the current end of the stack.
  ;; Contorted way of writing it is to avoid getting too many blocks in a row
  ;; I can’t see a reasonable way to share code with normal stack-buffer maintenance
  (newtop (+ top-of-stack-a (b-constant *page-size*)))
  (parallel (assign vma (- top-of-stack-a (b-constant *page-size*)))
	    (call map-page-to-stack-buffer))
  (if (lesser-pointer top-of-stack %stack-buffer-limit)
      (jump sg-stack-buffer-load-setup-map) 	;should be goto, but,..
    (drop-through))
  ;; Finish loading up those frames, finish popping stack-load-loop’s state
  (parallel (for-effect (popval))
	    (clear-stack-adjustment)
	    (call adjust-frame-buffer-underflow-bits))
  ;; Now stash the argument in the stack, if wanted
  (if (greater-fixnum-unsigned (sg-arg-status %current-stack-group-status-bits)
			       %sg-arg-break)
      (assign next-on-stack a-stack-group-argument)
    (drop-through))

  ;; Set up to swap in the bindings
  (assign b-binding-boundary %binding-stack-low)
  (parallel
    (assign a-stack-group-lock (set-type (a-constant 5) dtp-fix))
    (jump continue-sg-swap-in-bindings)))

4,887,235
	289	290
(defucode continue-sg-swap-in-bindings
  (if (greater-pointer b-binding-boundary %binding-stack-pointer)
      ;; Done whole binding stack--we’re all done
      (parallel (assign a-stack-group-lock quote-nil)
		(jump popj))
    (drop-through))

  ;; Read the pointer to the bound location
  (memread (1+ b-binding-boundary))
  (parallel (transport)
	    (assign b-temp memory-data))
  ;; Read the bound contents of the bound location, checking write access
  (memread-write b-binding-boundary)
  (parallel (transport bind)
	    (assign a-temp-2 memory-data))
  ;; Read the current contents of the bound location
  (memread b-temp)
  (parallel (transport bind)
	    (assign a-temp memory-data)
	    (assign b-temp memory-data))
  ;; Write the bound contents there (preserve cdr code)
  (store-contents a-temp-2 (cdr b-temp))
  ;; Store current contents into binding stack (better- not pclsr!)
  (assign vma b-binding-boundary)
  (store-contents a-temp)
  (parallel (assign b-binding-boundary (+ b-binding-boundary (a-constant 2))]
		    (jump continue-sg-swap-in-bindings)))


F:>lmach>ucode>proto-trap.lisp.1
;;; -*- Mode:Lisp; Package:Micro; Base:8; Lowercase:yes -*-
;;; (c) Copyright 1982, Symbolics, Inc.

; Microcode for Trap Handling on "prototype" machine

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

;Invisible-pointer traps
;If transporting was needed, it has hanpened already
;Time= 2 cycles trapping + 2 cycles here
;+ 3 more because of the temporary memory control
(defucode-at-loc inviz-trap 10012	;trap-2 handler
  (parallel
    (trap-save)
    (assign vma a-vma-copy)
    (assign b-vma a-vma-copy))			;get the memory-data again
  (start-memory read)
  (nop)
  (parallel
    (assign vma memory-data)
    (if (data-type? memory-data dtp-body-forward)
	;; Body forward points to header forward
	(sequential
	  (start-memory read)
	  (assign b-vma (- b-vma a-vma-copy))	;Offset into structure
	  (assign vma (+ memory-data b-vma)))	;Address word in target structure
      (drop-through)))
  (trap-restore
    (start-memory read)
    (assign b-vma a-vma-copy)))

;Halt here if we accidentally popj with 17 in the CSP
(defucode-at-loc no-ifu-present 17774
  (parallel (halt no-ifu-present) (jump no-ifu-present)))

(defucode-at-loc error-trap 10010	;trap-0 handler
  (parallel (trap-save)
	    (lisp (enter-error-handler))
	    (if	(not (zero-fixnum (sg-halt-on-error %current-stack-group-status-bits)))
		(parallel (halt error-in-error-handler) (jump error-trap))
	      ;; Fixup the stack first, since we need to push some stuff
	      (call-and-return-to restore-stack-pointer error-trap-1))))

(defucode error-trap-no-restore-stack
  (parallel (trap-save)
	    (lisp (enter-error-handler))
	    (if (not (zero-fixnum (sg-halt-on-error %current-stack-group-status-bits)))
		(parallel (halt error-in-error-handler) (jump error-trap))
	      ;; Fixup the stack first, since we need to push some stuff
	      (goto error-trap-1))))

4,887,235
	291	292
(defucode error-trap-1
  ;; If an error- occurs, halt
  (assign (sg-halt-on-error %current-stack-group-status-bits) (b-constant 1))
  ;; Push the address of the microinstruction that signalled the error
  (assign b-temp (logand (pop-control-stack) (b-constant 37777)))
  (pushval (set-type b-temp dtp-fix))
  (pushval (set-type a-vma-copy dtp-locative))
  ;; Make the pc point such as to retry the failed instruction, The error handler is
  ;; likely as not going to mess with our state anyway.
  ; The stack was alr-eadu restored above.
  (take-pre-trap signal-error preserve-stack))


F:>lmach>ucode>PREDICATE.LISP.14

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

; Microcode for primitive predicates

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

(defucode true1
  (parallel (newtop quote-t)
	    (next-instruction)))

(defucode false1
  (parallel (newtop quote-nil)
	    (next-instruction)))

(definst eq (no-operand needs-stack)
  (parallel
    (if (equal-typed-pointer top-of-stack next-on-stack)
	(goto true1)
        (goto false1))
    (decrement-stack-pointer)))

(definst eql (no-operand needs-stack)
  (parallel
    (if (equal-typed-pointer top-of-stack next-on-stack)
	(goto true1)
      (goto false1))
    (decrement-stack-pointer)
    (check-data-type-and-dispatch
     (next-on-stack dtp-float dtp-extended-number)
     ;; If the types differ, simply return nil
     ;; This has the bug that flonum NAN's pass through.
     ((flonum-fixnum extnum-fixnum extnum-flonum flonum-extnum)
      (goto false1))
     ;; if the types are the same, do appropriate comparison
     ;; Due to IEEE standard, non-eq flonums can be equal,
     :; plus and minus zero for example
     ((flonum-flonum)
      (goto fequal))
     ((extnum-extnum)
      (jump extnum-equal)))))

(definst not no-operand
  (if (data-type? top-of-stack-a dtp-nil)
      (goto true1)
      (goto false1)))

(definst atom no-operand
  (if (data-type? top-of-stack-a dtp-list)
      (goto false1)
      (goto true1)))

;This is the Common Lisp version of LISTP, not the present one
(comment
(definst listp no-operand
  (if (data-type? top-of-stack-a dtp-list dtp-nil)
      (goto true1)
      (goto false1)))
);end comment


(definst floatp no-operand
  (if (data-type? top-of-stack-a dtp-float)
      (goto true1)
      (drop-through))
  (if (not (data-type? top-of-stack-a dtp-extended-number))
      (gate false1)
      (drop-through))
  ;--- Here see if it’s an extended-precision float
  (jump false1))