4,887,235
	353	354
    (if (not (page-tag-bit 1))
	(parallel (pop2push next-on-stack)
		  (next-instruction))
        (drop-through))
  (disable-tasking))
(address-page-tag a-temp)
(parallel (assign next-on-stack (+ next-on-stack (b-constant *page-size*)))
	  (write-lbus-dev 36 21 nil)
	  (jump %scan-reference-tags)))

;Scan the GC tags, returning NIL or the physical address of the first page uhose tag is set.
;This is bummed for speed (2 cycles per page).
(definst %scan-gc-tags (no-operand needs-stack)
  (parallel
    (check-fixnum-2args next-on-stack top-of-stack)
    (assign a-temp next-on-stack)) 			;Move address to faster memory
  (parallel
    (assign b-temp (- top-of-stack-a (b-constant *page-size*)))
    (disable-tasking)
    (jump scan-gc-tags-loop)))

(defucode scan-gc-tags-loop
  ;; First cycle emits physical address, checks for done
  (parallel
    (address-page-tag a-temp)
    (if (greater-or-equal-fixnum-unsigned a-temp b-temp)
	;; Doing last location (do it differently to avoid reading random address)
	(if (page-tag-bit 0)
	    (parallel (pop2push (set-type a-temp dtp-fix))
		      (next-instruction))
	    (parallel (pop2push quote-nil)
		      (next-instruction)))
      (drop-through)))
  ;;Second cycle tests the tag bit, increments address. disables tasking after next
  (parallel
    (assign a-temp (+ a-temp (b-constant *page-size*)))
    (disable-tasking)
    (if (page-tag-bit 0)
	(parallel (pop2push (set-type (- a-temp (b-constant *page-size*)) dtp-fix))
		  (next-instruction))
        (goto scan-gc-tags-loop))))

;Write into the gc map. Args are virtual address and contents (including odd parity).
(definst %gc-map-write (no-operand needs-stack smashes-stack)
  (parallel
    (check-fixnum-2args next-on-stack top-of-stack)
    (decrement-stack-pointer))
  (parallel
    (write-gc-map top-of-stack-a top-of-stack)
    (decrement-stack-pointer)
    (next-instruction)))


F:>lmach>ucode>IFU.LISP.55

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

;; Microcode for IFU simulation

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

(reserve-scratchpad-memory 2440 2444)
(defareg a-instruction)				;Current instruction
(defareg a-break-pc 0)				;Stop before executing instruction here

(defucode main-loop
  (parallel (assign vma pc)			;Fetch instruction (pair)
	    (assign b-temp pc)
	    (check-data-type pc dtp-even-pc dtp-odd-pc)
	    ;; Increment PC, start mescry, take appropriate instruction halfwodcrd,
	    ;; and halt if macrocode breakpoint reached
	    (if (data-type? pc dtp-even-pc)
		(sequential (parallel
			      (start-memory read)
			      (assign pc (set-type pc dtp-odd-pc)))
			    (if (equal-typed-pointer b-temp a-break-pc)
				(parallel
				  (assign a-instruction (ldb memory-data 16. 0))
				  (halt breakpoint))
			        (assign a-instruction (ldb memory-data 16. 0))))
	        (sequential (parallel
			      (start-memory read)
			      (assign pc (set-type (1+ pc) dtp-even-pc)))
4,887,235
	355	356
			    (if (equal-typed-pointer b-temp a-break-pc)
				(parallel
				  (assign a-instruction (ldb memory-data 16. 16.))
				  (halt breakpoint))
			        (assign a-instruction (ldb memory-data 16. 16.))))))
  (assign b-temp (logand (rotate a-instruction 26.)	;(ldb 8 8) then shift left 2
			 (b-constant 377_2)))
  (parallel
    (long-dispatch b-temp)			;Can't overlap with byte operation above
    (call-and-return-to main-loop-1 main-loop)))

(defucode main-loop-1
  (parallel
    (assign inst (ldb a-instruction 8 0))
    (take-dispatch)))

(defucode-at-loc no-operand-subdispatch 376_2
  (assign b-temp (dpb a-instruction 9 2 (b-constant 1000_2)))
  (long-dispatch b-temp)
  (take-dispatch))


F:>lmach>ucode>funcall3.lisp.61

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

; Microcode for function call/return (part 4)
; This file contains function return & housekeeping instructions

;--- use fast-blt-stack rather than blt-stack, but make it take
;--- its argument in xbas so we don't have to save and restore FP

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


;;; Function Return

;Temporary registers local to these routines
(reserve-scratchpad-memory 2420 2424)

(defareg a-temp-prev-frame)
(defareg a-temp-misc-data)

;Typical of a class of single value returning instructions which try
;to use a quick path through the code if no special conditions occur.
;
;Care is needed in dealing with the PC. If we page fault on an instruction
;fetch, the current frame had better be one that we are supposed to be
;returning from, the top of the stack had better be the value being returned.
;and the PC had better point at a RETURN-STACK instruction.
;With the real IFU, the EPC remains pointing at the original return-stack.
;On the PROTO machine and the simulator, no page faults can occur.
;With the TMC, writing the PC cannot be undone, so we avoid page
;faults by not pre-fetching the instructions being returned to,
;losing some time.
;On the TMC5.

(definst return-stack (no-operand needs-stack)
  (keep-function-history return)
  (parallel (check-arg-type return-pc frame-return-pc dtp-even-pc dtp-odd-pc)
	    (assign pc frame-return-pc))
  (sequential	;--- make tnis parallel when you are trying to make the machine fast
   		;--- I would suggest putting lognand into the non-wierd alu functions
    (trap-if (not-zero-fixnum frame-cleanup-bits)
	     ;Must escape to the slower, more general return microcode.
	     (parallel (trap-no-save)
		       (assign a-temp (set-type (b-constant 1) dtp-fix))
		       (assign b-temp obus)
		       (jump general-return)))
    (machine-version-case
     ((ifu tmc5) (start-memory read block instruction-fetch))
     (otherwise nil)))
  (parallel (assign stack-pointer frame-previous-top)
	    (dispatch-after-this (cdr-code frame-previous-top)
			(assign frame-pointer frame-previous-frame)
	      ((0)	;Ignore
	       (parallel (assign top-of-stack top-of-stack-a)
			 (next-instruction)))
	      ((1)	;Stack
	       (parallel (pushval top-of-stack)
			 (next-instruction)))
	      ((2)	;Return
	       (parallel (pushval top-of-stack)
			 (clear-stack-adjustment)
			 (jump return-stack)))
4,887,235
	357	358
	      ((3)	;Multiple
	       (pushval top-of-stack)
	       (parallel (pushval (set-type (b-constant 1) dtp-fix))
			 (next-instruction))))))

;The more general, multiple-value-returning instruction
(definst return-n unsigned-immediate-operand
  ;--- insert code here to look at all the values and do unsafe-ptr checks
  (parallel (assign a-temp (set-type micro-unsigned-immediate dtp-fix))
	    (assign b-temp obus)
	    (jump general-return)))

;The even more general one, returning a variable number of values
;The count is on the stack, i.e. it is a multiple group
(definst return-multiple no-operand
  ;--- insert code here to look at all the values and do unsafe-ptr checks
  (parallel (check-arg-type top-of-stack top-of-stack-a dtp-fix)
	    (assign a-temp top-of-stack-a)
	    (assign b-temp obus)
	    (decrement-stack-pointer)
	    (jump general-return)))

;Values to be returned are on the stack
;Values on the stack have already been filtered for, unsafe pointers
;Tne top-of-stack register need not be valid
;a-temp and b-temp have the number of values
;The PC is irrelevant since if we trap, we will change the PC to point
;to a return-multiple instruction, and push the number of values onto the stack.
;This is necessary since we can get here from a variety of different.
;incompatible return instructions, and we don't know how to restore their
;arguments so that they can be used to retry the return operation.
;We cannot do instruction prefetching on the code being returned to,
;because the page fault would happen with the pc inconsistent with fp/sp.
(defucode general-return
  ;; The general idea is to blt the values down from the top of the returning
  ;; frame to the top of the caller frame, then check whether the caller
  ;; frame needs to brought into the stack buffer. But we start by dispatching
  ;; on the value disposition which affects whetner or not we blt all the
  ;; values down as well as what to do about the PC.
  (keep-function-history return)
  (dispatch-after-this (cdr-code frame-previous-top)
	;; Xct-next:	Check for exceptions other than stack buffer underflow
	(trap-if (bit-test frame-misc-data
			   (b-constant (logxor (byte-mask frame-buffer-underflow-bit)
					       (byte-mask frame-cleanup-bits))))
		 general-return-cleanup)
	((0)	;Ignore
	 (parallel (check-arg-type return-pc frame-return-pc dtp-even-pc dtp-odd-pc)
		   (assign pc frame-return-pc))
	 (assign stack-pointer frame-previous-top)
	 (assign top-of-stack top-of-stack-a)
	 (if (not (bit frame-buffer-underflow-bit))
	     (parallel (assign frame-pointer frame-previous-frame)
		       (next-instruction))
	   (sequential (assign frame-pointer frame-previous-frame)
		       (take-post-trap reload-stack-buffer preserve-stack))))
	((1)	;Stack
	 (parallel (check-arg-type return-pc frame-return-pc dtp-even-pc dtp-odd-pc)
		   (assign pc frame-return-pc))
	 (if (zero-fixnum a-temp)
	     ;; Returning no values. Return nil (rather than error!)
	     (assign top-of-stack quote-nil)
	     ;; Return first value
	     (sequential
	       (assign stack-pointer (- stack-pointer b-temp))
	       (assign top-of-stack (amem (stack-pointer 1)))))
	 (assign stack-pointer frame-previous-top)
	 (if (not (bit frame-buffer-underflow-bit))
	     (sequential (assign frame-pointer frame-previous-frame)
			 (parallel (pushval top-of-stack)
				   (next-instruction)))
	     (sequential (assign frame-pointer frame-previous-frame)
			 (pushval top-of-stack)
			 (take-post-trap reload-stack-buffer preserve-stack))))
	((2)	;Return
	 (parallel (assign a-temp-misc-data frame-misc-data)
		   (call blt-values-down))
	 (assign frame-pointer a-temp-prev-frame)
	 (if (not (bit-test a-temp-misc-data
			    (b-constant (byte-mask frame-buffer-underflow-bit))))
	     ;Now return from caller's frame to his caller
	     (goto general-return)
	     ;Reload stack buffer, then popj to RETURN-MULTIPLE instruction
	   (sequential
	     (pushval (set-type a-temp dtp-fix))	;Number of values returning
	     (take-jump-trap-with-continuation reload-stack-buffer
					       return-multiple-escape-pc
					       preserve-stack))))
4,887,235
	359	360
	((3)	;Multiple
	 (parallel (check-arg-type return-pc frame-return-pc dtp-even-pc dtp-odd-pc)
		   (assign pc frame-return-pc))
	 (parallel (assign a-temp-misc-data frame-misc-data)
		   (call blt-values-down))
	 (assign frame-pointer a-temp-prev-frame)
	 (if (not (bit-test a-temp-misc-data
			    (b-constant (byte-mask frame-buffer-underflow-bit))))
	     ;; Now finish off by storing number of values returned
	     (parallel (pushval (set-type a-temp dtp-fix))
		       (next-instruction))
	     ;;Reload stack buffer, then popj
	     (sequential
	       (pushval (set-type a-temp dtp-fix)) ;Number of values returning
	       (take-jump-trap-with-continuation reload-stack-buffer pc preserve-stack))))))

;Here if a frame being deallocated needs some cleanup, typically popping
;of associated binding and data stack frames, or checking of potentially
;unsafe pointers. The cleanup may involve calling a macrocode routine
;and arranging for it to return to an appropriate PC.
;If an error signalled here, the PC may not be meaningful (due to d-return)
;Note that if we go back around to general-return a-temp and b-temp must still be valid
(defucode general-return-cleanup
  (parallel
   (trap-no-save)
   (if (bit frame-catch-bit)
       (goto catch-cleanup)
       (drop-through)))

  (if (bit frame-bindings-bit)
      (sequential
        (parallel
	  (pushval (set-type a-temp dtp-fix))	;Number of values returning
	  (clear-stack-adjustment))		;Leave this in the stack if we trap
	(restart-pc return-multiple-escape-pc)	;PC -> RETURN-MULTIPLE instruction in
	(parallel				; case of a page fault
	  (accept-restart-pc)
	  (call frame-cleanup-bind-stack-unwind))
	(parallel (assign a-temp top-of-stack) ;Retrieve number of values
		  (assign b-temp top-of-stack)
		  (decrement-stack-pointer)
		  (jump general-return)))
    (drop-through))

  (if (bit frame-bottom-bit)
      (sequential		;Return one value Ire's stack group
        (if (zero-fixnum a-temp)
	    ;Returning no values. Return nil (rather than error!)
	    (pushval quote-nil)
	    ;Return first value
	    (sequential (assign xbas (- stack-pointer b-temp))
			(pushval (amem (xbas 1)))))
	(take-jump-trap stack-group-exhausted preserve-stack))
    (drop-through))

  (if (bit frame-trace-bit)
      (sequential
        (pushval (set-type a-temp dtp-fix)) ;Make values a multiple group
	(signal-error-no-restore-stack return-from-traced-frame))
    (drop-through))

  ;Some unknown frame-cleanup bit was set
  (pushval (set-type a-temp dtp-fix))	;Make values a multiple group
  (signal-error-no-restore-stack garbage-in-frame-cleanup-bits))

;Get rid of a catch block in this frame, then try to return again
;Preserve a-temp and b-temp (for general-return)
(defucode catch-cleanup
  (assign xbas %catch-block-list)		;Inspect the catch block
  (if (equal-typed-pointer (amem (xbas 0))	;catch-block-tag
			   b-quote-t)		;unwind-protect (--- change tag later ---)
      (sequential
        (parallel
	  (pushval (set-type a-temp dtp-fix))	;Number of values returning
	  (clear-stack-adjustment))		;Leave this in the stack if we trap
	(restart-pc return-multiple-escape-pc)	;RETURN-MULTIPLE instruction pair
	(parallel (accept-restart-pc)
		  (assign a-catch-nwords (1+ a-temp))
		  (jump catch-close-1)))	;Run cleanup handler then retry return
    (drop-through))
  ;Not an unwind-protect. Simply unthread it from the list and continue
  (parallel (assign %catch-block-list (amem (xbas 3))) ;catch-block-previous
	    (assign b-temp-2 obus))
  (if (data-type? %catch-block-list dtp-nil)
      (parallel (assign frame-catch-bit (b-constant 0))
		(jump general-return))
    (if (lesser-pointer b-temp-2 frame-pointer)
	(parallel (assign frame-catch-bit (b-constant 0))
		  (jump general-return))
      (goto catch-cleanup))))		;more catch blocks in this frame

4,887,235
	361	362
;Subroutine of general-call for case where all values may be needed
;Simply sets up the correct arguments for blt-stack
;Returns with correct value in stack-pointer
;and a-temp-prev-frame having what belongs in frame-pointer
;Here the number of values is in a-temp and b-temp rather than
;on the top of the stack
(defucode blt-values-down
  (assign a-temp-2 frame-previous-top)
  (assign a-temp-prev-frame frame-previous-frame)
  (parallel (assign frame-pointer (- stack-pointer b-temp))
	    (assign b-temp-2 stack-pointer))
  (parallel (assign stack-pointer a-temp-2)
	    (jump blt-stack)))

;Some words are to be pushed into the stack. frame-pointer points before
;the first of them and b-temp-2 points at the last of them.
;frame-pointer is smashed.
;3 cycles per word moved plus 3 cycles of overhead.
;Could be sped up to 2 cycles per if we had two counters that addressed Amem.
(defucode blt-stack
  (assign frame-pointer (1+ frame-pointer))
  (if (greater-pointer frame-pointer b-temp-2) (return)
      (parallel (pushval-with-cdr (amem (frame-pointer 0)))
		(jump blt-stack))))

;Fast version of above, using unrolled loop
;Some words are to be pushed into the stack. frame-pointer points before
;the first of them and b-temp-2 points at the last of them.
;frame-pointer, a-temp2 are smashed.
;Time to move N words = 2*N (1<N<9)
;  N=0 -> 2. N=1 -> 4.  N>8 -> 11 (N/8)+time(N mod 8) (-3 if N mod 8 = 0)
;35 control memory locations.
(defucode fast-blt-stack
  (parallel 	;Negative number of words to do, minus one to make ALU happy
   (assign a-temp-2 (set-type (- frame-pointer b-temp-2 1) dtp-77))
   (if (equal-pointer frame-pointer b-temp-2) (return)
     (parallel
      (if (minus-fixnum (+ a-temp-2 (b-constant 8) 1))
	  (sequential	;More than 8 words, move 8 and retry
	    (parallel
	      (pushval-with-cdr (amem (frame-pointer 1)))
	      (call fast-blt-stack-8))
	    (parallel
	      (assign frame-pointer (+ frame-pointer (b-constant 8)))
	      (jump fast-blt-stack)))
	(parallel	;Less than 8 words, move 1 and dispatch
	  (pushval-with-cdr (amem (frame-pointer 1)))
	  (take-dispatch)))
      (dispatch-after-next (ldb a-temp-2 3 0)
	((6) (return))					;1
	((5) (parallel (pushval-with-cdr (amem (frame-pointer 2)))	;2
		       (return)))
	((4) (pushval-with-cdr (amem (frame-pointer 2)))		;3
	     (parallel (pushval-with-cdr (amem (frame-pointer 3)))
		       (return)))
	((3) (pushval-with-cdr (amem (frame-pointer 2)))		;4
	     (pushval-with-cdr (amem (frame-pointer 3)))
	     (parallel (pushval-with-cdr (amem (frame-pointer 4)))
		       (return)))
	((2) (pushval-with-cdr (amem (frame-pointer 2)))		;5
	     (pushval-with-cdr (amem (frame-pointer 3)))
	     (pushval-with-cdr (seem (frame-pointer 4)))
	     (parallel (pushval-with-cdr (amem (frame-pointer 5)))
		       (return)))
	((1) (pushval-with-cdr (amem (frame-pointer 2)))		;6
	     (pushval-with-cdr (amem (frame-pointer 3)))
	     (pushval-with-cdr (amem (frame-pointer 4)))
	     (pushval-with-cdr (amem (frame-pointer 5)))
	     (parallel (pushval-with-cdr (amem (frame-pointer 5)))
		       (return)))
	((8) (pushval-with-cdr (amem (frame-pointer 2)))		;7
	     (pushval-with-cdr (amem (frame-pointer 3)))
	     (pushval-with-cdr (amem (frame-pointer 4)))
	     (puehval-with-cdr (amem (frame-pointer 5)))
	     (pushval-with-cdr (amem (frame-pointer 6)))
	     (parallel (pushval-with-cdr (amem (frame-pointer 7)))
		       (return)))
	((7) (goto fast-blt-stack-8)))))))				;8

(defucode fast-blt-stack-8
  (pushval-with-cdr (amem (frame-pointer 2)))
  (pushval-with-cdr (amem (frame-pointer 3)))
  (pushval-with-cdr (amem (frame-pointer 4)))
  (pushval-with-cdr (amem (frame-pointer 5)))
  (pushval-with-cdr (amem (frame-pointer 6)))
  (pushval-with-cdr (amem (frame-pointer 7)))
  (parallel (pushval-with-cdr (amem (frame-pointer 8)))
	    (return)))

4,887,235
	363	364
(definst popj no-operand
  (parallel (check-arg-type top-of-stack top-of-stack-a dtp-even-pc dtp-odd-pc)
	    (set-pc top-of-stack-a
		    (for-effect (popval)))))

;Top N stack locations to be preserved. squeeze return PC out from under there
;--- This can be written better when blt-stack is changed to use xbas
(definst popj-n unsigned-immediate-operand
  (assign xbas (- stack-pointer macro-unsigned-immediate))
  (parallel (check-arg-type nil (amem (xbas 0)) dtp-even-pc dtp-odd-pc)
	    (assign a-temp-2 (amem (xbas 0))))
  (parallel (assign a-temp frame-pointer))
  (parallel (assign frame-pointer (- stack-pointer macro-unsigned-immediate))
	    (assign b-temp-2 stack-pointer))
  (parallel (assign stack-pointer (1- frame-pointer))
	    (call blt-stack))
  (assign frame-pointer a-temp)
  (set-pc a-temp-2)) ;Set PC after all side-effects out of way, in case pg fIt

;Multiple at top of stack to be preserved, squeeze return PC out from under
;--- This can be written better when blt-stack is changed to use xbas
(definst popj-multiple (no-operand needs-stack)
  (assign xbas (- stack-pointer top-of-stack 1))
  (parallel (check-arg-type nil (amem (xbas 0)) dtp-even-pc dtp-odd-pc)
	    (assign a-temp-2 (amem (xbas 0))))
  (parallel (assign a-temp frame-pointer))
  (parallel (assign frame-pointer (- stack-pointer top-of-stack 1))
	    (assign b-temp-2 stack-pointer))
  (parallel (assign stack-pointer (1- frame-pointer))
	    (call blt-stack))
  (assign frame-pointer a-temp)
  (set-pc a-temp-2)) ;Set PC after all side-effects out of way, in case pg fIt

;Instructions for picking up multiple values left in the stack

;For now, the only one I will do is the one for a fixed number of
;values. not the multiple-value-list, &optional, and &rest ones.

;The values and the number of them are on the stack.

;Take specified number of values. Adjust the size of the block of values
;on the stack, and get rid of the values count.
(definst take-values unsigned-immediate-operand
  (parallel
    (check-arg-type top-of-stack top-of-stack-a dtp-fix)
    (if (equal-fixnum top-of-stack-a macro-unsigned-immediate)
	;Have right number of values, just flush count and exit
	(parallel (for-effect (popval))
		  (next-instruction))
      (drop-through)))
  (parallel
    (assign b-temp (- top-of-stack-a macro-unsigned-immediate))
    (decrement-stack-pointer)
    (if (plus-or-zero-fixnum obus)	;-or-zero to make ALU happy
	;Have too many values, flush extraneous ones and the count
	(sequential 	;Pop extraneous values
	  (assign stack-pointer (- stack-pointer b-temp))
	  (parallel (assign top-of-stack (amem (stack-pointer 0)))
		    (next-instruction)))
	;Not enough values, push some NILs
        (goto push-missing-values))))

;Push (minus b-temp) nils
;This takes two cycles per nil, and could be bummed to take 9/8 cycle
(defucode push-missing-values
  (parallel (assign b-temp (1+ b-temp))
	    (if (plus-or-zero-fixnum obus)
		(parallel (pushval quote-nil)
			  (next-instruction))
	      (parallel (pushval quote-nil)
			(jump push-missing-values)))))

;;; The more general, slower calling code (more than 4 arguments,
;;; variable number of arguments, restarting from trapped call)

;This instruction starts up a call in the current frame. Normally there
;will be nothing pushed after the frame header, but there could be an
;environment or other extra arguments.
(definst restart-trapped-call no-operand
  (dispatch-after-next frame-argument-format
    ((%frame-arguments-normal) (goto general-call-1))
    ((%frame-arguments-lexpr) (goto restart-lexpr-funcall))
    ((%frame-arguments-instance) (goto method-call-1))
    ((%frame-arguments-lexpr-instance) (goto restart-lexpr-method-call)))
  (parallel
   (assign a-nargs frame-number-of-args)
   (assign b-temp frame-number-of-args)
   (take-dispatch)))

4,887,235
	365	366
;Current frame is all set up and a-nargs has the number of arguments.
;Per form the call
(defucode general-call-1
  (parallel (trap-if (not-data-type? frame-function dtp-compiled-function)
		     general-call-funny-function)
	    (function-entry-instruction-fetch frame-function))
		;Last place to page fault. Point PC after the entry instr, not
		;setting it until we are guaranteed there will be no page fault.
                ;If caller gave many args, only slow case of callee applies
                ;Otherwise dispatch to appropriate code for number of args




  (dismatch-after-next (ldb a-nargs 3 0)
     ((0) (goto call-indirect-disp-0))
     ((1) (goto call-indirect-disp-1))
     ((2) (goto call-indirect-disp-2))
     ((3) (goto call-indirect-disp-3))
     ((4) (goto call-indirect-disp-4)))
  (parallel
    (trap-if (greater-fixnum a-nargs (b-constant 4))
	     (parallel
	       (trap-no-save)
	       (declare-memory-timing data-cycle)	;compiler check is conservative
	       (if (zero-fixnum (entry-instruction-dispatch memory-data))
		   (sequential
		     (keep-function-history call)
		     (next-instruction))
		 (signal-error-no-restore-stack wrong-number-of-arguments))))
    (take-dispatch)))

;Same when entering a method. The first two arguments have already been pushed into
;the callee's frame.
(defucode method-call-1
  (parallel (trap-if (not-data-type? frame-function dtp-compiled-function)
		     general-call-funny-function)
	    (function-entry-instruction-fetch frame-function))
		;Last place to page fault. Point PC points after the entry ir,ctr.
		;If caller gave many args, only slow case of callee applies
		;Otherwise dispatch to appropriate code for number of args
		;Note that the first two arguments (self and self-mapping-table)
		;have already been received.
  ;; Same timing comment applies as above
  (dispatch-after-next (ldb a-nargs 2 0)
    ((0) (call-indirect-part-3 2 t))
    ((1) (call-indirect-part-3 3 t))
    ((2) (call-indirect-part-3 4 t)))
  (parallel
    (trap-if (greater-fixnum a-nargs (b-constant 2))
	     (parallel
	       (trap-no-save)
	       (declare-memory-timing data-cycle)	;compiler check is conservative
	       (if (zero-fixnum (entry-instruction-dispatch memory-data))
		   (sequential
		     (keep-function-history call)
		     (next-instruction))
		 (signal-error-no-restore-stack wrong-number-of-arguments))))
    (take-dispatch)))


;;; Lexpr calling

;restart-trapped-call will come back here. This is analogous to general-call-1.
(defucode restart-lexpr-funcall
  (parallel (trap-if (not-data-type? frame-function dtp-compiled-function)
		     general-call-funny-function)
	    (function-entry-instruction-fetch frame-function))
		;Last place to page fault. Point PC after the entry instr.
  (nop)
  (keep-function-history call)
  (dispatch-after-next (entry-instruction-dispatch memory-data)
     ((0) (next-instruction))			;Callee will do it himself
     ;Here callee does not want a rest argument. So this is either too
     ;many arguments, or need to call a support routine to pop some
     ;arguments off the list, which is known not to be NIL.
     ;Put in b-temp the maximum number of spread arguments the callee wants.
     ((1) (lexpr-funcall-fast 0 b-temp))
     ((2 3) (lexpr-funcall-fast 1 b-temp))
     ((4 5 6) (lexpr-funcall-fast 2 b-temp))
     ((7 10 11 12) (lexpr-funcall-fast 3 b-temp))
     ((13 14 15	16 17) (lexpr-funcall-fast 4 b-temp)))
		;Check for space in stack buffer
  (parallel (trap-if (greater-pointer stack-pointer stack-limit)
		     (take-jump-trap stack-buffer-overflow-handler preserve-stack))
	    (take-dispatch)))

4,887,235
	367	368
;Same for case where a method is being invoked and hence the first two "arguments" are there
(defucode restart-lexpr-method-call
  (parallel (trap-if (not-data-type? frame-function dtp-compiled-function)
		     general-call-funny-function)
	    (function-entry-instruction-fetch frame-function))
		;Last place to page fault. Point PC after the entry instr.
  (nop)
  (keep-function-history call)
  (dispatch-after-next (entry-instruction-dispatch memory-data)
     ((0) (next-instruction))			;Callee will do it himself
     ;Here callee does not want a rest argument. So this is either too
     ;many arguments, or need to call a support routine to pop some
     ;arguments off the list, which is known not to be NIL.
     ;Put in b-temp the maximum number of spread arguments the callee wants.
     ((1 2 3 4 5 7 8 11. 12.)		;Must have at least 2 required arguments
      (signal-error-no-restore-stack wrong-number-of-arguments))
     ((6) (lexpr-funcall-fast 0 b-temp))
     ((9. 18.) (lexpr-funcall-fast 1 b-temp))
     ((13. 14. 15.) (lexpr-funcall-fast 2 b-temp)))
		;Check for snace in stack buffer
  (parallel (trap-if (greater-pointer stack-pointer stack-limit)
		     (take-jump-trap stack-buffer-overflow-handler preserve-stack))
	    (take-dispatch)))

;Need to pull some more arguments, and caller uses the fast entry sequence, so
;the PC isn't valid yet.
(defucode lexpr-funcall-fast-trap
  (restart-pc restart-trapped-call-escape-pc)
  (parallel (accept-restart-pc)
	    (jump pull-lexpr-args-no-restore-sp)))

;Come back here with stack containing number of unsupplied arguments and return PC
;in the case where there werent enough elements in the rest arg to satisfy the
;number of spread arguments the callee wants. Turn into a normal call.
;A couple of cycles could be bummed out of this code with some care.
(definst un-lexpr-funcall no-operand
  (assign b-temp (1+ next-on-stack))	;Number of stack words to flush
  (pushval frame-pointer)
  (assign b-temp-2 stack-pointer)	;Last word to preserve
  (assign frame-pointer (- top-of-stack (a-constant 6)))	;-> rest arg. last to flush
  (parallel
    (assign stack-pointer (- frame-pointer b-temp))		;where that moves to
    (call blt-stack)) 			;Squeeze out the extra spread args and the rest arg
  (parallel
    (assign frame-pointer (- top-of-stack-a b-temp)) 	;Restore fp
    (decrement-stack-pointer))		; and restore sp
  (assign a-temp frame-number-of-args)	;Correct the frame's arg count
  (assign b-temp (- a-temp b-temp))
  (assign frame-number-of-args b-temp)
  (assign frame-lexpr-called (b-constant 0))
  (parallel 				;Clean stack and jump to restart PC
    (assign next-on-stack top-of-stack-a)
    (decrement-stack-pointer)
    (jump popj)))


;;; Buncha random instructions
(definst push-n-nils unsigned-immediate-operand		;1+2 cycles per NIL
  (parallel (assign b-temp (- (a-constant 0) macro-unsigned-immediate))
	    (jump push-missing-values)))

(definst1 fixup-tos no-operand				;1 cycle
  (assign top-of-stack (amem (stack-pointer 0))))

(definst pop-n unsigned-immediate-operand		;2 cycles
  (parallel (assign stack-pointer (- stack-pointer macro-unsigned-immediate))
	    (jump fixup-tos)))

(definst pop-n-save-1 (unsigned-immediate-operand needs-stack) ;2 cycles
  (assign stack-pointer (- stack-pointer macro-unsigned-immediate))
  (parallel (assign (amem (stack-pointer 0)) top-of-stack)
	    (next-instruction)))



(definst pop-n-save-m (unsigned-immediate-operand needs-stack) ;7+3M cycles
  (parallel (assign a-temp frame-pointer)
	    (decrement-stack-pointer))
  (parallel (assign frame-pointer (- stack-pointer macro-unsigned-immediate))
	    (assign b-temp-2 stack-pointer))
  (parallel (assign stack-pointer (- frame-pointer top-of-stack))
	    (call blt-stack))
  (parallel (assign frame-pointer a-temp)
	    (next-instruction)))

(definst pop-multiple-save-n unsigned-immediate-operand
  (parallel (assign a-temp frame-pointer))
  (parallel (assign frame-pointer (- stack-pointer macro-unsigned-immediate 1))
	    (assign b-temp-2 stack-pointer))		     ;Range to save

4,887,235
	369	370
  (assign b-temp (1+ (amem (frame-pointer 0))))		;Size of multiple
  (parallel (assign stack-pointer (- frame-pointer b-temp))
	    (call blt-stack))
  (parallel (assign frame-pointer a-temp)
	    (next-instruction)))

(definst pop-n-save-multiple (unsigned-immediate-operand needs-stack)
  (parallel (assign a-temp frame-pointer))
  (parallel (assign frame-pointer (- stack-pointer top-of-stack 1))
	    (assign b-temp-2 stack-pointer))		;Range to save
  (parallel (assign stack-pointer (- frame-pointer macro-unsigned-immediate))
	    (call blt-stack))
  (parallel (assign frame-pointer a-temp)
	    (next-instruction)))

(definst pop-multiple-save-multiple (no-operand needs-stack)
  (parallel (assign a-temp frame-pointer))
  (parallel (assign frame-pointer (- stack-pointer top-of-stack 1))
	    (assign b-temp-2 stack-pointer))	;Range to save
  (assign b-temp (1+ (amem (frame-pointer 0))))	;Size of multiple
  (parallel (assign stack-pointer (- frame-pointer b-temp))
	    (call blt-stack))
  (parallel (assign frame-pointer a-temp)
	    (next-instruction)))

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

; Microcode for function call/return (part 2)
; This file contains the instructions that functions
; with more than 4 arguments use to pick up their arge.

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


;Random disorganimed local register definitions
(reserve-scratchpad-memory 2410 2413)

(defareg a-nargs)
(defareg a-min-args)
(defareg a-max-args)

(define-b-temps b-save-fp b-nargs)

;Note: a simplified version of this code exists at TAKE-REST-ARG. Keep them consistent.
(defmicro general-take-args (min-args max-args optional-args? rest-arg?)
  '(sequential
    ;Check for lexpr and method calls
    (dispatch-after-next frame-argument-format
      ((%frame-arguments-normal)
       ,@(general-take-args-internal min-args max-args optional-args? rest-arg? nil))
      ((%frame-arguments-lexpr)
       (pushval ,(or min-args '(b-constant 0)))		;Number of required arguments
       (parallel
	(pushval (set-type ,(if max-args		;Number of optional arguments
				'(- ,max-args top-of-stack-a)
			        '(b-constant 0))
			   dtp-fix))
	,(if rest-arg?
	     '(call-require-args-lexpr-rest)	;Returns if exact match, stack popped
	     '(jump require-args-lexpr-no-rest)))
       ,@(if rest-arg?
	     (general-take-args-internal min-args max-args optional-args? t nil)))

      ((%frame-arguments-instance)
       (assign a-nargs (+ a-nargs (b-constant 2)))
       ,@(general-take-args-internal min-args max-args optional-args? rest-arg? t))

      ((%frame-arguments-lexpr-instance)
       (pushval ,(or min-args (b-constant 0)))		;Number of required arguments
       (parallel
	 (pushval (set-type ,(if max-args		;Number of optional arguments
				 '(- ,max-args top-of-stack-a)
			         '(b-constant 0))
			    dtp-fix))
	 ,(if rest-arg?
	      '(call require-args-lexpr-instance-rest) ;Returns if exact match, stack popped
	      '(jump require-args-lexpr-instance-no-rest)))
       ,@(if rest-arg?
	     '((assign a-nargs (+ a-nargs (b-constant 2)))
	       ,@(general-take-args-internal min-args max-args optional-args? t t)))))
	;Get number of arguments supplied	
    (parallel
     (assign a-nargs frame-number-of-args)
     (assign b-nargs frame-number-of-args)
     (take-dispatch))))

4,887,235
	371	372
;Entered with b-nargs containing frame-number-of-args, a-nargs containing that
;or that+2 in the method case.
(eval-when (eval load compile)
(defun general-take-args-internal (min-args max-args optional-args? rest-arg? method?
				   &aux (b-side-reg 'b-nargs))
  ;Check for wrong number of args. increment PC by the number of optional
  ;arguments that were supplied. put the number of arguments to be
  ;copied in the b-side register indicated by b-side-ring, leave the
  ;number of arguments supplied in b-nargs, and do all this in the
  ;minimum number of cycles
  '(,@(if (not optional-args?)
	  (cond ((not rest-arg?)
		 '((error-if (not-equal-fixnum a-nargs ,min-args) wrong-number-of-arguments)))
		((not min-args)
		 (setq b-side-reg nil)		;Nothing but a rest argument
		 nil)
		((not method?)
		 (setq b-side-reg min-args) 	;Copy all the spread args
		 '((error-if (lesser-fixnum a-nargs ,min-args) wrong-number-of-arguments)))
		(t (setq b-side-ring 'b-temp-2)
		   '((assign b-temp-2 (- ,min-args (a-constant 2))) ;2 args already copied
		     (error-if (lesser-fixnum a-nargs ,min-args) wrong-number-of-arguments))))
	'(,@(cond
	     (not rest-arg?)
	     '((error-if (greater-fixnum a-nargs ,max-args) wrong-number-of-arguments)
	       ,@(cond (min-args
			'((parallel
			   (assign b-temp-2 (- a-nargs ,min-args))
			   (error-if (lesser-fixnum-unsigned a-nargs ,min-args)
				     wrong-number-of-arguments))
			  (assign pc (pc-plus-number pc b-temp-2))))
		       ((not method?)
			'((assign pc (pc-plus-number pc b-nargs))))
		       (t
			((assign b-temp-2 a-nargs)
			 (assign pc (pc-plus-number pc b-temp-2)))))))
	    ((not min-args)
	     (setq b-side-reg 'b-temp-2)
	     '((parallel
		(assign b-temp-2 a-nargs)
		(if (greater-fixnum a-nargs ,max-args)
		    (sequential			;rest arg present
		     (assign b-temp-2 ,max-args)
		     (assign pc (inc-plus-number pc b-temp-2 1)))
		  (assign pc (pc-plus-number pc b-temp-2))))
	       ,@(if method? '((assign b-temp-2 (- b-temp-2 (a-constant 2)))))))
	    (t (setq b-side-reg 'b-temp-2)
	       '((parallel
		  (assign b-temp-2 a-nargs)
		  (if (greater-fixnum a-nargs ,max-args)
		      (sequential		;rest arg present
		       (parallel (assign b-temp-2 ,max-args)
				 (assign a-max-args ,max-args))
		       (assign b-temp-3 (- a-max-args ,min-args))
		       (assign pc (pc-plus-number pc b-temp-3 1)))
		    (sequential
		      (parallel
		        (assign b-temp-3 (- a-nargs ,min-args))
			(error-if (lesser-fixnum-unsigned a-nargs ,min-args)
				  wrong-number-of-arguments))
		      (assign pc (pc-plus-number pc b-temp-3)))))
		 ,@(if method? '((assign b-temp-2 (- b-temp-2 (a-constant 2))))))))))
;We are now committed to completing the instruction (PC changed)
;However we cannot prefetch the next instruction, because that might
;take a page fault and this instruction still has side-effects to do.
;Make a-temp -> last argument, save the frame-pointer in b-save-fp
(parallel (assign a-temp (- frame-pointer (b-constant 6)))
	  (assign b-save-fp frame-pointer))
;Copy up the arguments that were supplied, or some prefix of them.
;blt-stack wants first-1 in frame-pointer, last in b-temp-2
;b-nargs still has the number of arguments in the caller s frame
,(cond ((eq b-side-reg 'b-nargs) 	;Copy all the arguments
	'(parallel (assign frame-pointer (- a-temp b-nargs))
		   (assign b-temp-2 a-temp)
		   (call blt-stack)))
       ((not (null b-side-reg))		;Copy some of the arguments
	'(sequential
	   (parallel (assign frame-pointer (- a-temp b-nargs)))
	   (parallel (assign b-temp-2 (+ frame-pointer ,b-side-reg))
		     (assign a-temp obus)
		     (call blt-stack)))))
;Now handle rest argument if necessary. a-temp -> last normal arg
;If there are missing optionals, the defaulting of the rest arg will
;be done by macrocode. But if there are no optionals we do it here.
,(if rest-arg?
     ;Restore frame pointer, then decide whether there is a rest argument and push it
     '(sequential
        (parallel (assign frame-pointer (set-type b-save-fp dtp-null))
		  (assign a-pclsr-top-of-stack (set-type b-save-fp dtp-null)))
	(parallel