From 7ba077bff178bb91408d6a17482944d34401ec2d Mon Sep 17 00:00:00 2001
From: dtc <dtc>
Date: Fri, 21 Nov 1997 12:26:52 +0000
Subject: [PATCH] Clean up the NLX entry VOPs so that the argument start is
 passed in the EBX register rather than in stack slot 0 where it corrupts the
 OCFP. New vm-support-routine make-nlx-entry-argument-start-location. No
 longer need to save/restore the OCFP with the dynamic state as it isn't
 corrupted.

---
 assembly/x86/assem-rtns.lisp |  29 ++---
 compiler/backend.lisp        |   3 +-
 compiler/ir2tran.lisp        |   5 +-
 compiler/x86/nlx.lisp        | 204 ++++++-----------------------------
 4 files changed, 48 insertions(+), 193 deletions(-)

diff --git a/assembly/x86/assem-rtns.lisp b/assembly/x86/assem-rtns.lisp
index b7b22eb15..556d22109 100644
--- a/assembly/x86/assem-rtns.lisp
+++ b/assembly/x86/assem-rtns.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/x86/assem-rtns.lisp,v 1.2 1997/11/18 10:48:01 dtc Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/x86/assem-rtns.lisp,v 1.3 1997/11/21 12:26:48 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;; 
@@ -17,6 +17,7 @@
 ;;; Written by William Lott
 ;;;
 ;;; Debugged by Paul F. Werkowski -- Spring/Summer 1995.
+;;; Enhancements/debugging by Douglas T. Crosher 1997.
 ;;;
 (in-package :x86)
 
@@ -195,10 +196,6 @@
   (pushw ebp-tn -2)
 
   ;; And away we go.
-;  (inst jmp-indirect
-;	(make-ea :byte :base eax :disp (- (* closure-function-slot word-bytes)
-;					  function-pointer-type)))
-  ;; -- jrd
   (inst jmp
 	(make-ea :byte :base eax :disp (- (* closure-function-slot word-bytes)
 					  function-pointer-type)))
@@ -248,7 +245,7 @@
 			  (:arg start (any-reg descriptor-reg) ebx-offset)
 			  (:arg count (any-reg descriptor-reg) ecx-offset)
 			  (:temp uwp dword-reg esi-offset))
-  (declare (ignore count))
+  (declare (ignore start count))
 
   (let ((error (generate-error-code nil invalid-unwind-error)))
     (inst or block block)		; check for NULL pointer
@@ -256,8 +253,9 @@
   
   (load-symbol-value uwp lisp::*current-unwind-protect-block*)
 
-  (inst;; does *cuwpb* match value stored in argument cuwp slot?
-   cmp uwp (make-ea-for-object-slot block unwind-block-current-uwp-slot 0))
+  ;; Does *cuwpb* match value stored in argument cuwp slot?
+  (inst cmp uwp
+	(make-ea-for-object-slot block unwind-block-current-uwp-slot 0))
   ;; If a match, return to context in arg block.
   (inst jmp :e do-exit)
 
@@ -273,18 +271,9 @@
   
   (loadw ebp-tn block unwind-block-current-cont-slot)
   
-  ;; apparently a carefully held secret is that uwp-entry expects
-  ;; some things in known locations so that they can be saved on
-  ;; the stack! Jeesh!
- 
-  ;;(move edx-tn block)			; gets shoved into 'block'
-  ;;(move ecx-tn count)			; a noop
-
-  ;; This seems needed to properly save the 'start' value so that the
-  ;; correct thing gets passed into the various nlx entry points although
-  ;; I think the compiler really ought to do it.
-
-  (storew start ebp-tn (- (1+ ocfp-save-offset)))
+  ;; Uwp-entry expects some things in known locations so that they can
+  ;; be saved on the stack: the block in edx-tn; start in ebx-tn; and
+  ;; count in ecx-tn
 
   (inst jmp (make-ea :byte :base block
 		     :disp (* unwind-block-entry-pc-slot word-bytes))))
diff --git a/compiler/backend.lisp b/compiler/backend.lisp
index 35082383b..8b3f6ab4b 100644
--- a/compiler/backend.lisp
+++ b/compiler/backend.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/backend.lisp,v 1.28 1994/10/31 04:27:28 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/backend.lisp,v 1.29 1997/11/21 12:26:50 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -85,6 +85,7 @@
   ;; From NLX.LISP
   make-nlx-sp-tn
   make-dynamic-state-tns
+  #+x86 make-nlx-entry-argument-start-location
   
   ;; From SUPPORT.LISP
   generate-call-sequence
diff --git a/compiler/ir2tran.lisp b/compiler/ir2tran.lisp
index 3d7fdeaf9..fca74782a 100644
--- a/compiler/ir2tran.lisp
+++ b/compiler/ir2tran.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir2tran.lisp,v 1.61 1997/04/16 18:06:20 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir2tran.lisp,v 1.62 1997/11/21 12:26:52 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1601,7 +1601,8 @@
 	 (2cont (continuation-info cont))
 	 (2info (nlx-info-info info))
 	 (top-loc (ir2-nlx-info-save-sp 2info))
-	 (start-loc (make-old-fp-passing-location t))
+	 (start-loc #-x86 (make-old-fp-passing-location t)
+		    #+x86 (make-nlx-entry-argument-start-location))
 	 (count-loc (make-argument-count-location))
 	 (target (ir2-nlx-info-target 2info)))
 
diff --git a/compiler/x86/nlx.lisp b/compiler/x86/nlx.lisp
index 2d8f334e7..6247c8dd4 100644
--- a/compiler/x86/nlx.lisp
+++ b/compiler/x86/nlx.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/nlx.lisp,v 1.7 1997/11/18 10:53:24 dtc Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/nlx.lisp,v 1.8 1997/11/21 12:26:46 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -29,6 +29,14 @@
    (make-representation-tn *fixnum-primitive-type* any-reg-sc-number)
    env))
 
+;;; Make-NLX-Entry-Argument-Start-Location  --  Interface
+;;;
+;;;    Make a TN for the argument count passing location for a
+;;; non-local entry.
+;;;
+(def-vm-support-routine make-nlx-entry-argument-start-location ()
+  (make-wired-tn *fixnum-primitive-type* any-reg-sc-number ebx-offset))
+
 (defun catch-block-ea (tn)
   (assert (sc-is tn catch-block))
   (make-ea :dword :base ebp-tn
@@ -37,10 +45,13 @@
 
 ;;; Save and restore dynamic environment.
 ;;;
-;;;    These VOPs are used in the reentered function to restore the appropriate
-;;; dynamic environment.  Currently we only save the Current-Catch and eval
-;;; stack pointer.  We don't need to save/restore the current unwind-protect,
-;;; since unwind-protects are implicitly processed during unwinding.
+;;;    These VOPs are used in the reentered function to restore the
+;;; appropriate dynamic environment.  Currently we only save the
+;;; Current-Catch, the eval stack pointer, and the alien stack
+;;; pointer.
+;;;
+;;; We don't need to save/restore the current unwind-protect, since
+;;; unwind-protects are implicitly processed during unwinding.
 ;;;
 ;;; We don't need to save the BSP, because that is handled automatically.
 
@@ -50,30 +61,25 @@
 ;;; use with the Save/Restore-Dynamic-Environment VOPs.
 ;;;
 (def-vm-support-routine make-dynamic-state-tns ()
-  (make-n-tns 4 *any-primitive-type*))
+  (make-n-tns 3 *any-primitive-type*))
 
 (define-vop (save-dynamic-state)
   (:results (catch :scs (descriptor-reg))
 	    (eval :scs (descriptor-reg))
-	    (oldfp :scs (descriptor-reg))
 	    (alien-stack :scs (descriptor-reg)))
   (:generator 13
     (load-symbol-value catch lisp::*current-catch-block*)
     (load-symbol-value eval lisp::*eval-stack-top*)
-    (load-symbol-value alien-stack *alien-stack*)
-    (loadw oldfp ebp-tn  (- (1+ ocfp-save-offset)))))
+    (load-symbol-value alien-stack *alien-stack*)))
   
-
 (define-vop (restore-dynamic-state)
   (:args (catch :scs (descriptor-reg))
 	 (eval :scs (descriptor-reg))
-	 (oldfp :scs (descriptor-reg))
 	 (alien-stack :scs (descriptor-reg)))
   (:generator 10
     (store-symbol-value catch lisp::*current-catch-block*)
     (store-symbol-value eval lisp::*eval-stack-top*)
-    (store-symbol-value alien-stack *alien-stack*)
-    (storew oldfp ebp-tn (- (1+ ocfp-save-offset)))))
+    (store-symbol-value alien-stack *alien-stack*)))
 
 (define-vop (current-stack-pointer)
   (:results (res :scs (any-reg control-stack)))
@@ -160,76 +166,14 @@
 
 
 ;;;; NLX entry VOPs:
-#+nil ;; this is bogus?
-(define-vop (nlx-entry)
-  (:args (sp) ; Note: we can't list an sc-restriction, 'cause any load vops
-	      ; would be inserted before the return-pc label.
-	 (start)
-	 (count))
-  (:results (values :more t))
-  (:temporary (:sc descriptor-reg) nil-temp move-temp)
-  (:info label nvals)
-  (:save-p :force-to-stack)
-  (:vop-var vop)
-  (:generator 30
-    (emit-label label)
-    (note-this-location vop :non-local-entry)
-    (cond ((zerop nvals))
-	  ((= nvals 1)
-	   (let ((no-values (gen-label)))
-	     ;; (move (tn-ref-tn values) nil-value) -- jrd
-	     (inst mov (tn-ref-tn values) nil-value)
-
-	     (inst jecxz no-values)
-
-	     ;; jrd rewrote this piece.  because we can't issue an sc-restriction, 
-	     ;; as above, we generate a bogus EA here (see the expansion of LOADW)
-	     ;; and croak.  Do the move by hand.
-	     ;; (loadw (tn-ref-tn values) start -1)
-	     (inst mov move-temp start)
-	     (loadw (tn-ref-tn values) move-temp -1)
-
-	     (emit-label no-values)))
-	  (t
-	   (collect ((defaults))
-	     (inst mov nil-temp nil-value)
-	     (do ((i 0 (1+ i))
-		  (tn-ref values (tn-ref-across tn-ref)))
-		 ((null tn-ref))
-	       (let ((default-lab (gen-label))
-		     (tn (tn-ref-tn tn-ref)))
-		 (defaults (cons default-lab tn))
-		 
-		 (inst cmp count (fixnum i))
-		 (inst jmp :le default-lab)
-		 (sc-case tn
-		   ((descriptor-reg any-reg)
-		    ;; see above -- jrd
-		    ;; (loadw tn start (- (1+ i)))
-		    (inst mov move-temp start)
-		    (loadw tn move-temp (- (1+ i))))
-		   ((control-stack immediate-stack)
-		    ;; (loadw move-temp start (- (1+ i)))
-		    (inst mov move-temp start)
-		    (loadw move-temp move-temp (- (1+ i)))
-		    (move tn move-temp)))))
-	     (let ((defaulting-done (gen-label)))
-	       (emit-label defaulting-done)
-	       (assemble (*elsewhere*)
-		 (dolist (def (defaults))
-		   (emit-label (car def))
-		   (move (cdr def) nil-temp))
-		 (inst jmp defaulting-done))))))
-    (inst mov esp-tn sp)))
-
-;;; see comments below regarding start arg to nlx-entry-multiple
 (define-vop (nlx-entry)
-  (:args (sp) ; Note: we can't list an sc-restriction, 'cause any load vops
-	      ; would be inserted before the return-pc label.
+  ;; Note: we can't list an sc-restriction, 'cause any load vops would
+  ;; be inserted before the return-pc label.
+  (:args (sp)
 	 (start)
 	 (count))
   (:results (values :more t))
-  (:temporary (:sc descriptor-reg) nil-temp move-temp)
+  (:temporary (:sc descriptor-reg) move-temp)
   (:info label nvals)
   (:save-p :force-to-stack)
   (:vop-var vop)
@@ -239,18 +183,12 @@
     (cond ((zerop nvals))
 	  ((= nvals 1)
 	   (let ((no-values (gen-label)))
-	     ;; (move (tn-ref-tn values) nil-value) -- jrd
 	     (inst mov (tn-ref-tn values) nil-value)
-	     
 	     (inst jecxz no-values)
-	     
-	     (move move-temp start)
-	     (loadw (tn-ref-tn values) move-temp -1)
-
+	     (loadw (tn-ref-tn values) start -1)
 	     (emit-label no-values)))
 	  (t
 	   (collect ((defaults))
-	     (inst mov nil-temp nil-value)
 	     (do ((i 0 (1+ i))
 		  (tn-ref values (tn-ref-across tn-ref)))
 		 ((null tn-ref))
@@ -262,79 +200,19 @@
 		 (inst jmp :le default-lab)
 		 (sc-case tn
 		   ((descriptor-reg any-reg)
-		    ;; see above -- jrd
-		    ;; (loadw tn start (- (1+ i)))
-		    (move move-temp start)
-		    (loadw tn move-temp (- (1+ i))))
+		    (loadw tn start (- (1+ i))))
 		   ((control-stack)
-		    ;; (loadw move-temp start (- (1+ i)))
-		    (move move-temp start)
-		    (loadw move-temp move-temp (- (1+ i)))
-		    (move tn move-temp)))))
+		    (loadw move-temp start (- (1+ i)))
+		    (inst mov tn move-temp)))))
 	     (let ((defaulting-done (gen-label)))
 	       (emit-label defaulting-done)
 	       (assemble (*elsewhere*)
 		 (dolist (def (defaults))
 		   (emit-label (car def))
-		   (move (cdr def) nil-temp))
+		   (inst mov (cdr def) nil-value))
 		 (inst jmp defaulting-done))))))
     (inst mov esp-tn sp)))
 
-#+nil ;;; this is badly broken and just kept here for reference -pw
-      ;;; actually maybe it's not so broken -- check later
-(define-vop (nlx-entry-multiple)
-  (:args (top)
-	 (source)
-	 (count :target ecx))
-  ;; Again, no SC restrictions for the args, 'cause the loading would
-  ;; happen before the entry label.
-  (:info label)
-  ;;(:temporary (:sc dword-reg :offset esi-offset) esi)
-  (:temporary (:sc dword-reg :offset ecx-offset :from (:argument 2)) ecx)
-  (:temporary (:sc dword-reg :offset esi-offset) esi)
-  (:temporary (:sc dword-reg :offset edi-offset) edi)
-  (:results (result :scs (any-reg) :from (:argument 0))
-	    (num :scs (any-reg immediate-stack)))
-  (:save-p :force-to-stack)
-  (:vop-var vop)
-  (:generator 30
-    #+x86-lra
-    (progn 
-      (align lowtag-bits #x90)
-      (inst lra-header-word)
-      (inst nop)
-      (inst nop)
-      (inst nop))
-    (emit-label label)
-    (note-this-location vop :non-local-entry)
-
-    ;; Set up the result values and copy the arguments.
-    (move result top)
-
-    ;; -- jrd.  see comments above.  need to do extra moves by hand, to
-    ;; get the ea's into registers
-    ;; (inst lea esi (make-ea :dword :base source :disp (- word-bytes)))
-    (inst lea edi (make-ea :dword :base result :disp (- word-bytes)))
-    (inst mov esi source)
-    (inst lea esi (make-ea :dword :base esi :disp (- word-bytes)))
-    (inst mov edi result)
-    (inst lea edi (make-ea :dword :base edi :disp (- word-bytes)))
-
-    (move ecx count)			; fixnum words == bytes
-    (move num ecx)
-    (inst shr ecx word-shift)		; word count for <rep movs>
-    ;; If we got zero, we be done.
-    (inst jecxz done)
-
-    ;; Copy them down.
-    (inst std)
-    (inst rep)
-    (inst movs :dword)
-
-    ;; Reset the CSP.
-    DONE
-    (inst lea esp-tn (make-ea :dword :base edi :disp word-bytes))))
-
 (define-vop (nlx-entry-multiple)
   (:args (top)
 	 (source)
@@ -360,26 +238,14 @@
     (emit-label label)
     (note-this-location vop :non-local-entry)
 
-    ;; The RISC implementations have ocfp-save wired to a register.
-    ;; ir2tran calls (make-old-fp-save-location) to retrieve that tn
-    ;; as the source address for the thrown results. Doing that here
-    ;; provides the S0 slot as that source which is the wrong end of
-    ;; the stack. Examination of the throw-catch-unwind process shows
-    ;; that %ebx is the analog of OCFP here and at least in testing so
-    ;; far does actually point (1 above)  the values.
-    ;; Actually, now it seems that 'unwind' is supposed to set up
-    ;; edx and ocfp with certain values so that the compiler can
-    ;; call these nlx entry points correctly. NOT.
-    (move esi source)			; ocfp
-    (inst lea esi (make-ea :dword :base esi :disp (- word-bytes)))
-    ;; The 'top' arg contains the %esp value saved prior to creating
-    ;; the catch block and dynamic save structures and points to where
-    ;; the thrown values should sit.
+    (inst lea esi (make-ea :dword :base source :disp (- word-bytes)))
+    ;; The 'top' arg contains the %esp value saved at the time the
+    ;; catch block was created and and points to where the thrown
+    ;; values should sit.
     (move edi top)
     (move result edi)
-    ;; not too sure here -- yes! this seems to be correct
-    (inst lea edi (make-ea :dword :base edi :disp (- word-bytes)))
 
+    (inst sub edi word-bytes)
     (move ecx count)			; fixnum words == bytes
     (move num ecx)
     (inst shr ecx word-shift)		; word count for <rep movs>
@@ -390,16 +256,14 @@
     (inst rep)
     (inst movs :dword)
 
-    ;; Reset the CSP (at last moved arg??)
     DONE
+    ;; Reset the CSP at last moved arg.
     (inst lea esp-tn (make-ea :dword :base edi :disp word-bytes))))
 
 
 ;;; This VOP is just to force the TNs used in the cleanup onto the stack.
 ;;;
 (define-vop (uwp-entry)
-  #+info-only
-  (:args (target)(block)(start)(count))
   (:info label)
   (:save-p :force-to-stack)
   (:results (block) (start) (count))
-- 
GitLab