From b9b7b8ac94801e906e39a4be6f20fe653338163a Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Tue, 23 Oct 1990 02:25:46 +0000
Subject: [PATCH] Changed return-multiple and tail-call-variable to jump off to
 assembly routines.  Also several minor tweaks here and there to fill delay
 slots better.

---
 compiler/mips/call.lisp | 416 +++++++++++++++-------------------------
 1 file changed, 155 insertions(+), 261 deletions(-)

diff --git a/compiler/mips/call.lisp b/compiler/mips/call.lisp
index cc403fdbb..0c41cd5f6 100644
--- a/compiler/mips/call.lisp
+++ b/compiler/mips/call.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/call.lisp,v 1.31 1990/09/28 06:42:34 ram Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/call.lisp,v 1.32 1990/10/23 02:25:46 wlott Exp $
 ;;;
 ;;;    This file contains the VM definition of function call for the MIPS.
 ;;;
@@ -47,7 +47,6 @@
       (make-wired-tn *any-primitive-type* register-arg-scn lra-offset)
       (make-restricted-tn *any-primitive-type* register-arg-scn)))
 
-
 ;;; Make-Old-FP-Passing-Location  --  Interface
 ;;;
 ;;;    Similar to Make-Return-PC-Passing-Location, but makes a location to pass
@@ -186,11 +185,11 @@
     ;; Build our stack frames.
     (inst addu csp-tn fp-tn
 	  (* vm:word-bytes (sb-allocated-size 'control-stack)))
-    (let ((nfp-tn (current-nfp-tn vop)))
-      (when nfp-tn
+    (let ((nfp (current-nfp-tn vop)))
+      (when nfp
 	(inst addu nsp-tn nsp-tn
 	      (- (bytes-needed-for-non-descriptor-stack-frame)))
-	(move nfp-tn nsp-tn)))))
+	(move nfp nsp-tn)))))
 
 (define-vop (allocate-frame)
   (:results (res :scs (any-reg))
@@ -227,10 +226,10 @@
 ;;; locations that the values are to be received into.  Nvals is the number of
 ;;; values that are to be received (should equal the length of Values).
 ;;;
-;;;    Move-Temp and Nil-Temp are Descriptor-Reg TNs used as temporaries.
+;;;    Move-Temp is a Descriptor-Reg TN used as a temporary.
 ;;;
 ;;;    This code exploits the fact that in the unknown-values convention, a
-;;; single value return returns at the return PC + 4, whereas a return of other
+;;; single value return returns at the return PC + 8, whereas a return of other
 ;;; than one value returns directly at the return PC.
 ;;;
 ;;;    If 0 or 1 values are expected, then we just emit an instruction to reset
@@ -253,19 +252,19 @@
 	move a1 null-tn			; Default register values
 	...
 	loadi nargs 1			; Force defaulting of stack values
-	move old-fp sp			; Set up args for SP resetting
+	move old-fp csp			; Set up args for SP resetting
 
 regs-defaulted
-	sub temp nargs register-arg-count
+	subu temp nargs register-arg-count
 
-	bltz temp default-value-4	; jump to default code
+	bltz temp default-value-7	; jump to default code
         addu temp temp -1
-	loadw move-temp old-fp-tn 3	; Move value to correct location.
+	loadw move-temp old-fp-tn 6	; Move value to correct location.
 	store-stack-tn val4-tn move-temp
 
-	bltz temp default-value-5
+	bltz temp default-value-8
         addu temp temp -1
-	loadw move-temp old-fp-tn 4
+	loadw move-temp old-fp-tn 7
 	store-stack-tn val5-tn move-temp
 
 	...
@@ -275,11 +274,11 @@ defaulting-done
 <end of code>
 
 <elsewhere>
-default-value-4 
-	store-stack-tn val4-tn null-tn	; Nil out 4'th value.
+default-value-7
+	store-stack-tn val4-tn null-tn	; Nil out 7'th value. (first on stack)
 
-default-value-5
-	store-stack-tn val5-tn null-tn	; Nil out 5'th value.
+default-value-8
+	store-stack-tn val5-tn null-tn	; Nil out 8'th value.
 
 	...
 
@@ -328,19 +327,23 @@ default-value-5
 		(defaults (cons default-lab tn))
 		
 		(inst bltz temp default-lab)
+		(inst lw move-temp old-fp-tn (* i vm:word-bytes))
 		(inst addu temp temp (fixnum -1))
-		(loadw move-temp old-fp-tn i)
 		(store-stack-tn tn move-temp)))
 	    
 	    (emit-label defaulting-done)
 	    (move csp-tn old-fp-tn)
 	    
-	    (assemble (*elsewhere*)
-	      (dolist (def (defaults))
-		(emit-label (car def))
-		(store-stack-tn (cdr def) null-tn))
-	      (inst b defaulting-done)
-	      (inst nop))))))
+	    (let ((defaults (defaults)))
+	      (when defaults
+		(assemble (*elsewhere*)
+		  (do ((remaining defaults (cdr remaining)))
+		      ((null remaining))
+		    (let ((def (car remaining)))
+		      (emit-label (car def))
+		      (when (null (cdr remaining))
+			(inst b defaulting-done))
+		      (store-stack-tn (cdr def) null-tn))))))))))
   (undefined-value))
 
 
@@ -847,74 +850,37 @@ default-value-5
 ;;; Defined separately, since needs special code that BLT's the arguments
 ;;; down.
 ;;;
-(expand
- `(define-vop (tail-call-variable)
-    (:args
-     (args :scs (any-reg) :to (:result 0))
-     (function-arg :scs (descriptor-reg) :target lexenv)
-     (old-fp-arg :scs (any-reg) :target old-fp)
-     (return-pc-arg :scs (descriptor-reg) :target return-pc))
-    (:temporary (:sc any-reg :offset lexenv-offset :from (:argument 0))
-		lexenv)
-    (:temporary (:sc any-reg :offset old-fp-offset :from (:argument 1))
-		old-fp)
-    (:temporary (:sc any-reg :offset lra-offset :from (:argument 2))
-		return-pc)
-    (:temporary (:sc any-reg :offset nargs-offset) nargs)
-    (:temporary (:scs (descriptor-reg)) function)
-    ,@(mapcar #'(lambda (offset name)
-		  `(:temporary (:sc any-reg :offset ,offset) ,name))
-	      register-arg-offsets register-arg-names)
-    (:temporary (:scs (any-reg) :type fixnum) src dst count)
-    (:temporary (:scs (descriptor-reg)) temp)
-    (:temporary (:scs (interior-reg) :type interior) lip)
-    (:vop-var vop)
-    (:generator 75
-      (let ((loop (gen-label))
-	    (test (gen-label)))
-	;; Move these into the passing locations if they are not already there.
-	(move lexenv function-arg)
-	(move old-fp old-fp-arg)
-	(move return-pc return-pc-arg)
-
-	;; Calculate NARGS (as a fixnum)
-	(inst subu nargs csp-tn args)
-	
-	;; Load the argument regs (must do this now, 'cause the blt might
-	;; trash these locations)
-	,@(let ((index -1))
-	    (mapcar #'(lambda (name)
-			`(loadw ,name args ,(incf index)))
-		    register-arg-names))
-	
-	;; Calc SRC, DST, and COUNT
-	(inst addu src args (* vm:word-bytes register-arg-count))
-	(inst addu dst fp-tn (* vm:word-bytes register-arg-count))
-	(inst b test)
-	(inst addu count nargs (fixnum (- register-arg-count)))
-	
-	(emit-label loop)
-	;; Copy one arg.
-	(loadw temp src)
-	(inst addu src src vm:word-bytes)
-	(storew temp dst)
-	(inst addu dst dst vm:word-bytes)
-	
-	;; Are we done?
-	(emit-label test)
-	(inst bgtz count loop)
-	(inst addu count count (fixnum -1))
-	
-	;; Clear the number stack if anything is there.
-	(let ((cur-nfp (current-nfp-tn vop)))
-	  (when cur-nfp
-	    (inst addu nsp-tn cur-nfp
-		  (bytes-needed-for-non-descriptor-stack-frame))))
+(define-vop (tail-call-variable)
+  (:args
+   (args-arg :scs (any-reg) :target args)
+   (function-arg :scs (descriptor-reg) :target lexenv)
+   (old-fp-arg :scs (any-reg) :target old-fp)
+   (lra-arg :scs (descriptor-reg) :target lra))
+
+  (:temporary (:sc any-reg :offset nl0-offset :from (:argument 0)) args)
+  (:temporary (:sc any-reg :offset lexenv-offset :from (:argument 1)) lexenv)
+  (:temporary (:sc any-reg :offset old-fp-offset :from (:argument 2)) old-fp)
+  (:temporary (:sc any-reg :offset lra-offset :from (:argument 3)) lra)
+
+  (:vop-var vop)
 
-	;; We are done.  Do the jump.
-	(loadw function lexenv vm:closure-function-slot
-	       vm:function-pointer-type)
-	(lisp-jump function lip)))))
+  (:generator 75
+
+    ;; Move these into the passing locations if they are not already there.
+    (move args args-arg)
+    (move lexenv function-arg)
+    (move old-fp old-fp-arg)
+    (move lra lra-arg)
+
+    ;; Clear the number stack if anything is there.
+    (let ((cur-nfp (current-nfp-tn vop)))
+      (when cur-nfp
+	(inst addu nsp-tn cur-nfp
+	      (bytes-needed-for-non-descriptor-stack-frame))))
+
+    ;; And jump to the assembly-routine that does the bliting.
+    (inst j (make-fixup 'tail-call-variable :assembly-routine))
+    (inst nop)))
 
 
 ;;;; Unknown values return:
@@ -925,7 +891,7 @@ default-value-5
 ;;; number of values returned.
 ;;;
 ;;; If returning a single value, then deallocate the current frame, restore
-;;; FP and jump to the single-value entry at Return-PC + 4.
+;;; FP and jump to the single-value entry at Return-PC + 8.
 ;;;
 ;;; If returning other than one value, then load the number of values returned,
 ;;; NIL out unsupplied values registers, restore FP and return at Return-PC.
@@ -933,177 +899,104 @@ default-value-5
 ;;; point to the beginning of the values block (which is the beginning of the
 ;;; current frame.)
 ;;;
-(expand
- `(define-vop (return)
-    (:args
-     (old-fp :scs (any-reg))
-     (return-pc :scs (descriptor-reg) :to (:eval 1))
-     (values :more t))
-    (:ignore values)
-    (:info nvals)
-    ,@(mapcar #'(lambda (name offset)
-		  `(:temporary (:sc descriptor-reg :offset ,offset
-				    :from (:eval 0) :to (:eval 1))
-			       ,name))
-	      register-arg-names register-arg-offsets)
-    (:temporary (:sc any-reg :offset nargs-offset) nargs)
-    (:temporary (:sc any-reg :offset old-fp-offset) val-ptr)
-    (:temporary (:scs (interior-reg) :type interior) lip)
-    (:vop-var vop)
-    (:generator 6
-      (cond ((= nvals 1)
-	     ;; Clear the stacks.
-	     (let ((cur-nfp (current-nfp-tn vop)))
-	       (when cur-nfp
-		 (inst addu nsp-tn cur-nfp
-		       (bytes-needed-for-non-descriptor-stack-frame))))
-	     (move csp-tn fp-tn)
-	     ;; Reset the frame pointer.
-	     (move fp-tn old-fp)
-	     ;; Out of here.
-	     (inst addu lip return-pc (- (* 3 word-bytes) other-pointer-type))
-	     (inst j lip)
-	     (move code-tn return-pc))
-	    (t
-	     (inst li nargs (fixnum nvals))
-	     ;; Clear the number stack.
-	     (let ((cur-nfp (current-nfp-tn vop)))
-	       (when cur-nfp
-		 (inst addu nsp-tn cur-nfp
-		       (bytes-needed-for-non-descriptor-stack-frame))))
-	     (move val-ptr fp-tn)
-	     ;; Reset the frame pointer.
-	     (move fp-tn old-fp)
-	     
-	     (inst addu csp-tn val-ptr (* nvals word-bytes))
-	     
-	     ,@(let ((index 0))
-		 (mapcar #'(lambda (name)
-			     `(when (< nvals ,(incf index))
-				(move ,name null-tn)))
-			 register-arg-names))
-	     
-	     (lisp-return return-pc lip))))))
+(define-vop (return)
+  (:args
+   (old-fp :scs (any-reg))
+   (return-pc :scs (descriptor-reg) :to (:eval 1))
+   (values :more t))
+  (:ignore values)
+  (:info nvals)
+  (:temporary (:sc descriptor-reg :offset a0-offset :from (:eval 0)) a0)
+  (:temporary (:sc descriptor-reg :offset a1-offset :from (:eval 0)) a1)
+  (:temporary (:sc descriptor-reg :offset a2-offset :from (:eval 0)) a2)
+  (:temporary (:sc descriptor-reg :offset a3-offset :from (:eval 0)) a3)
+  (:temporary (:sc descriptor-reg :offset a4-offset :from (:eval 0)) a4)
+  (:temporary (:sc descriptor-reg :offset a5-offset :from (:eval 0)) a5)
+  (:temporary (:sc any-reg :offset nargs-offset) nargs)
+  (:temporary (:sc any-reg :offset old-fp-offset) val-ptr)
+  (:temporary (:scs (interior-reg) :type interior) lip)
+  (:vop-var vop)
+  (:generator 6
+    ;; Clear the number stack.
+    (let ((cur-nfp (current-nfp-tn vop)))
+      (when cur-nfp
+	(inst addu nsp-tn cur-nfp
+	      (bytes-needed-for-non-descriptor-stack-frame))))
+    (cond ((= nvals 1)
+	   ;; Clear the control stack, and restore the frame pointer.
+	   (move csp-tn fp-tn)
+	   (move fp-tn old-fp)
+	   ;; Out of here.
+	   (lisp-return return-pc lip :offset 2))
+	  (t
+	   ;; Establish the values pointer and values count.
+	   (move val-ptr fp-tn)
+	   (inst li nargs (fixnum nvals))
+	   ;; restore the frame pointer and clear as much of the control
+	   ;; stack as possible.
+	   (move fp-tn old-fp)
+	   (inst addu csp-tn val-ptr (* nvals word-bytes))
+	   ;; pre-default any argument register that need it.
+	   (when (< nvals register-arg-count)
+	     (dolist (reg (subseq (list a0 a1 a2 a3 a4 a5) nvals))
+	       (move reg null-tn)))
+	   ;; And away we go.
+	   (lisp-return return-pc lip)))))
 
 ;;; Do unknown-values return of an arbitrary number of values (passed on the
 ;;; stack.)  We check for the common case of a single return value, and do that
 ;;; inline using the normal single value return convention.  Otherwise, we
-;;; branch off to code that calls a miscop.
-;;;
-;;; The Return-Multiple miscop uses a non-standard calling convention.  For one
-;;; thing, it doesn't return.  We only use BALA because there isn't a BA
-;;; instruction.   Also, we don't use A0..A2 for argument passing, since the
-;;; miscop will want to load these with values off of the stack.  Instead, we
-;;; pass Old-Fp, Start and Count in the normal locations for these values.
-;;; Return-PC is passed in A3 since PC is trashed by the BALA. 
-;;;
-
-
-(expand
- (let ((label-names (mapcar #'(lambda (name)
-				(intern (concatenate 'simple-string
-						     "DEFAULT-"
-						     (string name)
-						     "-AND-ON")))
-			    register-arg-names)))
-   `(define-vop (return-multiple)
-      (:args
-       (old-fp :scs (any-reg) :to (:eval 1))
-       (return-pc :scs (descriptor-reg) :to (:eval 1))
-       (start :scs (any-reg) :target src)
-       (nvals :scs (any-reg) :target nargs))
-      (:temporary (:sc any-reg :offset nargs-offset :from (:argument 3)) nargs)
-      ,@(mapcar #'(lambda (name offset)
-		    `(:temporary (:sc descriptor-reg :offset ,offset
-				      :from (:eval 0) :to (:eval 1))
-				 ,name))
-		register-arg-names register-arg-offsets)
-      (:temporary (:sc any-reg :offset old-fp-offset :type fixnum) vals)
-      (:temporary (:scs (any-reg) :type fixnum) count dst)
-      (:temporary (:scs (any-reg) :type fixnum :from (:argument 2)) src)
-      (:temporary (:scs (descriptor-reg)) temp)
-      (:temporary (:scs (interior-reg) :type interior) lip)
-      (:vop-var vop)
-      (:generator 13
-	(let ((not-single (gen-label))
-	      (loop (gen-label))
-	      ,@(mapcar #'(lambda (name)
-			    `(,name (gen-label)))
-			label-names)
-	      (done (gen-label)))
-	  
-	  ;; Clear the number stack.
-	  (let ((cur-nfp (current-nfp-tn vop)))
-	    (when cur-nfp
-	      (inst addu nsp-tn cur-nfp
-		    (bytes-needed-for-non-descriptor-stack-frame))))
-
-	  ;; Single case?
-	  (inst li count (fixnum 1))
-	  (inst bne count nvals not-single)
-	  (inst nop)
-	  
-	  ;; Return with one value.
-	  (loadw ,(first register-arg-names) start)
-	  (move csp-tn fp-tn)
-	  (move fp-tn old-fp)
-	  ;; Note: we can't use the lisp-return macro, 'cause we want to
-	  ;; skip two instructions.
-	  (inst addu lip return-pc (- (* 3 word-bytes) other-pointer-type))
-	  (inst j lip)
-	  (move code-tn return-pc)
-
-	  ;; Nope, not the single case.
-	  (emit-label not-single)
-	  
-	  ;; Load the register args, bailing out when we are done.
-	  (move nargs nvals)
-	  (move count nvals)
-	  (move src start)
-	  ,@(mapcar #'(lambda (name label)
-			`(progn
-			   (inst blez count ,label)
-			   (inst addu count count (fixnum -1))
-			   (loadw ,name src)
-			   (inst addu src src vm:word-bytes)))
-		    register-arg-names
-		    label-names)
-	  
-	  ;; Copy the remaining args to the top of the stack.
-	  (inst addu dst fp-tn (* vm:word-bytes register-arg-count))
-	  
-	  (emit-label loop)
-	  (inst blez count done)
-	  (inst addu count count (fixnum -1))
-	  (loadw temp src)
-	  (inst addu src src vm:word-bytes)
-	  (storew temp dst)
-	  (inst b loop)
-	  (inst addu dst dst vm:word-bytes)
-	  
-	  ;; Default some number of registers.
-	  ,@(mapcar #'(lambda (name label)
-			`(progn
-			   (emit-label ,label)
-			   (move ,name null-tn)))
-		    register-arg-names label-names)
-	  
-	  ;; Clear the stack.
-	  (emit-label done)
-	  (move vals fp-tn)
-	  (inst addu csp-tn vals nargs)
-	  (move fp-tn old-fp)
-	  
-	  ;; Return.
-	  (lisp-return return-pc lip))))))
+;;; branch off to code that calls an assembly-routine.
+;;;
+(define-vop (return-multiple)
+  (:args
+   (old-fp-arg :scs (any-reg) :to (:eval 1))
+   (lra-arg :scs (descriptor-reg) :to (:eval 1))
+   (vals-arg :scs (any-reg) :target vals)
+   (nvals-arg :scs (any-reg) :target nvals))
+
+  (:temporary (:sc any-reg :offset nl1-offset :from (:argument 0)) old-fp)
+  (:temporary (:sc descriptor-reg :offset lra-offset :from (:argument 1)) lra)
+  (:temporary (:sc any-reg :offset nl0-offset :from (:argument 2)) vals)
+  (:temporary (:sc any-reg :offset nargs-offset :from (:argument 3)) nvals)
+  (:temporary (:sc descriptor-reg :offset a0-offset) a0)
+  (:temporary (:scs (interior-reg) :type interior) lip)
 
+  (:vop-var vop)
+
+  (:generator 13
+    (let ((not-single (gen-label)))
+      ;; Clear the number stack.
+      (let ((cur-nfp (current-nfp-tn vop)))
+	(when cur-nfp
+	  (inst addu nsp-tn cur-nfp
+		(bytes-needed-for-non-descriptor-stack-frame))))
+
+      ;; Check for the single case.
+      (inst li a0 (fixnum 1))
+      (inst bne nvals-arg a0 not-single)
+      (inst lw a0 vals-arg)
+
+      ;; Return with one value.
+      (move csp-tn fp-tn)
+      (move fp-tn old-fp-arg)
+      (lisp-return lra-arg lip :offset 2)
+		
+      ;; Nope, not the single case.
+      (emit-label not-single)
+      (move old-fp old-fp-arg)
+      (move lra lra-arg)
+      (move vals vals-arg)
+      (move nvals nvals-arg)
+      (inst j (make-fixup 'return-multiple :assembly-routine))
+      (inst nop))))
 
 
 
 ;;;; XEP hackery:
 
 
-;;; Fetch the constant pool from the function entry structure.
+;;; We don't need to do anything special for regular functions.
 ;;;
 (define-vop (setup-environment)
   (:info label)
@@ -1112,8 +1005,7 @@ default-value-5
     ;; Don't bother doing anything.
     ))
 
-;;; Return the current Env as our result, then indirect throught the closure
-;;; and the closure-entry to find the constant pool
+;;; Get the lexical environment from it's passing location.
 ;;;
 (define-vop (setup-closure-environment)
   (:temporary (:sc descriptor-reg :offset lexenv-offset :target closure
@@ -1146,9 +1038,8 @@ default-value-5
 	(move result csp-tn))
       ;; Allocate the space on the stack.
       (cond ((zerop fixed)
-	     (inst addu csp-tn csp-tn nargs-tn)
 	     (inst beq nargs-tn done)
-	     (inst nop))
+	     (inst addu csp-tn csp-tn nargs-tn))
 	    (t
 	     (inst addu count nargs-tn (fixnum (- fixed)))
 	     (inst blez count done)
@@ -1177,14 +1068,17 @@ default-value-5
       (emit-label do-regs)
       (when (< fixed register-arg-count)
 	;; Now we have to deposit any more args that showed up in registers.
-	(inst addu count nargs-tn (fixnum (- fixed)))
+	;; We know there is at least one more arg, otherwise we would have
+	;; branched to done up at the top.
+	(inst subu count nargs-tn (fixnum (1+ fixed)))
 	(do ((i fixed (1+ i)))
 	    ((>= i register-arg-count))
-	  ;; Don't deposit any more than there are.
-	  (inst beq count zero-tn done)
-	  (inst addu count count (fixnum -1))
+	  ;; Is this the last one?
+	  (inst beq count done)
 	  ;; Store it relative to the pointer saved at the start.
-	  (storew (nth i register-arg-tns) result (- i fixed))))
+	  (storew (nth i register-arg-tns) result (- i fixed))
+	  ;; Decrement count.
+	  (inst subu count (fixnum 1))))
       (emit-label done))))
 
 
-- 
GitLab