From e86b430441f5b461256cb7979c8cb8509c57356b Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Tue, 27 Feb 1990 00:12:10 +0000
Subject: [PATCH] Initial cut at rewrite for mips.  Not finished, but at least
 the VOPs will be there.

---
 compiler/mips/nlx.lisp | 232 +++++++++++++++++++++++++++--------------
 1 file changed, 151 insertions(+), 81 deletions(-)

diff --git a/compiler/mips/nlx.lisp b/compiler/mips/nlx.lisp
index f7564441a..45f83087f 100644
--- a/compiler/mips/nlx.lisp
+++ b/compiler/mips/nlx.lisp
@@ -7,6 +7,8 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/nlx.lisp,v 1.2 1990/02/27 00:12:10 wlott Exp $
+;;;
 ;;;    This file contains the definitions of VOPs used for non-local exit
 ;;; (throw, lexical exit, etc.)
 ;;;
@@ -31,53 +33,133 @@
 ;;; use with the Save/Restore-Dynamic-Environment VOPs.
 ;;;
 (defun make-dynamic-state-tns ()
-  (make-n-tns 3 *any-primitive-type*))
+  (make-n-tns 4 *any-primitive-type*))
 
 (define-vop (save-dynamic-state)
   (:results (catch :scs (descriptor-reg))
 	    (special :scs (descriptor-reg))
+	    (number :scs (descriptor-reg))
 	    (eval :scs (descriptor-reg)))
-  #+nil
   (:generator 13
-    (load-global catch clc::current-catch-block)
-    (inst lr special bs-tn)
-    (inst cau eval zero-tn clc::t-16)
-    (inst l eval eval (+ clc::*eval-stack-top*-offset clc::symbol-value))))
+    (load-symbol-value catch lisp::*current-catch-block*)
+    (move special bsp-tn)
+    (move number nsp-tn)
+    (load-symbol-value eval lisp::*eval-stack-top*)))
 
-(define-vop (restore-dynamic-state one-arg-no-value-miscop)
+(define-vop (restore-dynamic-state)
   (:args (catch :scs (descriptor-reg))
-	 (special :scs (descriptor-reg) :target a0)
+	 (special :scs (descriptor-reg))
+	 (number :scs (descriptor-reg))
 	 (eval :scs (descriptor-reg)))
-  (:temporary (:scs (descriptor-reg)) temp)
-  (:variant-vars)
-  #+nil
+  (:temporary (:scs (descriptor-reg)) symbol value)
   (:generator 10
-    (store-global catch clc::current-catch-block temp)
-    (inst cau temp zero-tn clc::t-16)
-    (inst st eval temp (+ clc::*eval-stack-top*-offset clc::symbol-value))
-    (let ((skip (gen-label)))
-      (inst c special bs-tn)
-      (inst bb :eq skip)
-      (unless (location= special a0)
-	(inst lr a0 special))
-      (inst miscop 'clc::unbind-to-here)
-      (emit-label skip))))
+    (let ((done (gen-label))
+	  (skip (gen-label))
+	  (loop (gen-label)))
+
+      (store-symbol-value catch lisp::*current-catch-block*)
+      (store-symbol-value eval lisp::*eval-stack-top*)
+      (move nsp-tn number)
+      
+      (inst beq special bsp-tn done)
+      (nop)
+
+      (emit-label loop)
+      (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
+      (inst beq symbol zero-tn skip)
+      (loadw value bsp-tn (- binding-value-slot binding-size))
+      (storew value symbol vm:symbol-value-slot vm:other-pointer-type)
+      (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
+      (emit-label skip)
+      (inst addiu bsp-tn bsp-tn (* -2 vm:word-bytes))
+      (inst bne bsp-tn special loop)
+      (nop)
+
+      (emit-label done))))
 
 (define-vop (current-stack-pointer)
   (:results (res :scs (any-reg descriptor-reg)))
-  #+nil
   (:generator 1
-    (inst lr res sp-tn)))
+    (move res csp-tn)))
 
 
 ;;;; Unwind miscop VOPs:
 
-(define-vop (unwind three-arg-no-value-miscop)
-  (:variant 'clc::unwind)
-  (:translate %continue-unwind))
+(define-vop (unwind)
+  (:translate %continue-unwind)
+  (:args (block-arg :target block)
+	 (start :target args)
+	 (count :target nargs))
+  (:temporary (:sc any-reg :offset (first register-arg-offsets)
+		   :from (:argument 0)) block)
+  (:temporary (:sc any-reg :offset args-offset :from (:argument 1)) args)
+  (:temporary (:sc any-reg :offset nargs-offset :from (:argument 2)) nargs)
+  (:temporary (:scs (any-reg) :type fixnum) cur-uwp target-uwp next-uwp)
+  (:temporary (:scs (descriptor-reg)) return-pc)
+  (:temporary (:scs (interior-reg) :type interior) lip)
+  (:node-var node)
+  (:generator 0
+    (let ((error (generate-error-code node di:invalid-unwind-error))
+	  (do-uwp (gen-label))
+	  (do-exit (gen-label)))
+      (move block block-arg)
+      (inst beq block zero-tn error)
+      
+      (move args start)
+      (move nargs count)
+      
+      (load-symbol-value cur-uwp lisp::*current-unwind-protect-block*)
+      (loadw target-uwp block vm:unwind-block-current-uwp-slot)
+      (inst bne cur-uwp target-uwp do-uwp)
+      (nop)
+      
+      (move cur-uwp block)
+
+      (emit-label do-exit)
+      
+      (loadw cont-tn cur-uwp vm:unwind-block-current-cont-slot)
+      (loadw code-tn cur-uwp vm:unwind-block-current-code-slot)
+      (loadw return-pc cur-uwp vm:unwind-block-entry-pc-slot)
+      (lisp-return return-pc lip)
+	     
+      (emit-label do-uwp)
+
+      (loadw next-uwp cur-uwp vm:unwind-block-current-uwp-slot)
+      (b do-exit)
+      (store-symbol-value next-uwp lisp::*current-unwind-protect-block*))))
+
+
+(define-vop (throw)
+  (:args (target)
+	 (start)
+	 (count))
+  (:temporary (:scs (any-reg) :type fixnum)
+	      catch)
+  (:temporary (:scs (descriptor-reg))
+	      tag)
+  (:node-var node)
+  (:generator 0
+    (let ((loop (gen-label))
+	  (exit (gen-label))
+	  (error (generate-error-code node di:unseen-throw-tag-error target)))
+      (load-symbol-value catch lisp::*current-catch-block*)
+
+      (emit-label loop)
+
+      (inst bne catch zero-tn error)
+
+      (loadw tag catch vm:catch-block-tag-slot)
+      (inst beq tag target exit)
+      (nop)
+      (b loop)
+      (loadw catch catch vm:catch-block-previous-catch-slot)
+
+      (emit-label exit)
+
+      ;; ### Need to call unwind somehow.
+
+    )))
 
-(define-vop (throw three-arg-no-value-miscop)
-  (:variant 'clc::throw))
 
 
 ;;;; Unwind block hackery:
@@ -91,16 +173,14 @@
   (:results (block :scs (descriptor-reg)))
   (:temporary (:scs (descriptor-reg)) temp)
   (:temporary (:scs (descriptor-reg) :target block) result)
-  #+nil
   (:generator 22
-    (inst ai result cont-tn (* (tn-offset tn) 4))
-    (load-global temp clc::current-unwind-protect-block)
-    (storew temp result system:%unwind-block-current-uwp)
-    (storew cont-tn result system:%unwind-block-current-cont)
-    (storew env-tn result system:%unwind-block-current-env)
-    (storew entry-offset result system:%unwind-block-entry-pc)
-    (unless (location= result block)
-      (inst lr block result))))
+    (inst addiu result cont-tn (* (tn-offset tn) vm:word-bytes))
+    (load-symbol-value temp lisp::*current-unwind-protect-block*)
+    (storew temp result vm:unwind-block-current-uwp-slot)
+    (storew cont-tn result vm:unwind-block-current-cont-slot)
+    (storew code-tn result vm:unwind-block-current-code-slot)
+    (storew entry-offset result vm:unwind-block-entry-pc-slot)
+    (move block result)))
 
 
 ;;; Like Make-Unwind-Block, except that we also store in the specified tag, and
@@ -113,22 +193,20 @@
   (:results (block :scs (descriptor-reg)))
   (:temporary (:scs (descriptor-reg)) temp)
   (:temporary (:scs (descriptor-reg) :target block) result)
-  #+nil
   (:generator 44
-    (inst ai result cont-tn (* (tn-offset tn) 4))
-    (load-global temp clc::current-unwind-protect-block)
-    (storew temp result system:%unwind-block-current-uwp)
-    (storew cont-tn result system:%unwind-block-current-cont)
-    (storew env-tn result system:%unwind-block-current-env)
-    (storew entry-offset result system:%unwind-block-entry-pc)
-
-    (storew tag result system:%catch-block-tag)
-    (load-global temp clc::current-catch-block)
-    (storew temp result system:%catch-block-previous-catch)
-    (store-global result clc::current-catch-block temp)
-    
-    (unless (location= result block)
-      (inst lr block result))))
+    (inst addiu result cont-tn (* (tn-offset tn) vm:word-bytes))
+    (load-symbol-value temp lisp::*current-unwind-protect-block*)
+    (storew temp result vm:catch-block-current-uwp-slot)
+    (storew cont-tn result vm:catch-block-current-cont-slot)
+    (storew code-tn result vm:catch-block-current-code-slot)
+    (storew entry-offset result vm:catch-block-entry-pc-slot)
+
+    (storew tag result vm:catch-block-tag-slot)
+    (load-symbol-value temp lisp::*current-catch-block-slot*)
+    (storew temp result vm:catch-block-previous-catch-slot)
+    (store-symbol-value result lisp::*current-catch-block*)
+
+    (move block result)))
 
 
 ;;; Just set the current unwind-protect to TN's address.  This instantiates an
@@ -136,30 +214,29 @@
 ;;;
 (define-vop (set-unwind-protect)
   (:args (tn))
-  (:temporary (:scs (descriptor-reg)) temp new-uwp)
-  #+nil
+  (:temporary (:scs (descriptor-reg)) new-uwp)
   (:generator 7
-    (inst ai new-uwp cont-tn (* (tn-offset tn) 4))
-    (store-global new-uwp clc::current-unwind-protect-block temp)))
+    (inst addiu new-uwp cont-tn (* (tn-offset tn) vm:word-bytes))
+    (store-symbol-value new-uwp lisp::*current-unwind-protect-block*)))
 
 
-(define-vop (unlink-unwind-block)
-  (:temporary (:scs (descriptor-reg)) block temp)
-  (:variant-vars global slot)
+(define-vop (unlink-catch-block)
+  (:temporary (:scs (descriptor-reg)) block)
   (:policy :fast-safe)
-  #+nil
+  (:translate %catch-breakup)
   (:generator 17
-    (load-global block global)
-    (loadw block block slot)
-    (store-global block global temp)))
-
-(define-vop (unlink-catch-block unlink-unwind-block)
-  (:variant clc::current-catch-block system:%catch-block-previous-catch)
-  (:translate %catch-breakup))
+    (load-symbol-value block lisp::*current-catch-block*)
+    (loadw block block vm:catch-block-previous-catch-slot)
+    (store-symbol-value block lisp::*current-catch-block*)))
 
-(define-vop (unlink-unwind-protect unlink-unwind-block)
-  (:variant clc::current-unwind-protect-block system:%unwind-block-current-uwp)
-  (:translate %unwind-protect-breakup))
+(define-vop (unlink-unwind-protect)
+  (:temporary (:scs (descriptor-reg)) block)
+  (:policy :fast-safe)
+  (:translate %unwind-protect-breakup)
+  (:generator 17
+    (load-symbol-value block lisp::*current-unwind-protect-block*)
+    (loadw block block vm:unwind-block-current-uwp-slot)
+    (store-symbol-value block lisp::*current-unwind-protect-block*)))
 
 
 ;;;; NLX entry VOPs:
@@ -168,15 +245,12 @@
 ;;; operands.
 ;;;
 
-(define-vop (nlx-entry two-arg-no-value-miscop)
-  (:args (top :scs (descriptor-reg)
-	      :target a0)
+(define-vop (nlx-entry)
+  (:args (top :scs (descriptor-reg))
 	 (start)
 	 (count))
   (:results (values :more t))
   (:info nvals)
-  (:ignore start count values nl0 nl1 a2 a3 misc-pc)
-  (:variant-vars)
   (:save-p :force-to-stack)
   #+nil
   (:generator 30
@@ -186,13 +260,10 @@
     (inst cal a1 zero-tn nvals)))
 
 
-(define-vop (nlx-entry-multiple two-arg-two-value-miscop)
-  (:args (top :scs (descriptor-reg)
-	      :target a0)
+(define-vop (nlx-entry-multiple)
+  (:args (top :scs (descriptor-reg))
 	 (start)
 	 (count))
-  (:ignore start count nl0 nl1 a2 a3 misc-pc)
-  (:variant-vars)
   (:save-p :force-to-stack)
   #+nil
   (:generator 30
@@ -211,5 +282,4 @@
   (:save-p :force-to-stack)
   (:results (block) (start) (count))
   (:ignore block start count)
-  #+nil
   (:generator 0))
-- 
GitLab