Steel Bank Common Lisp

Update of /cvsroot/sbcl/sbcl/src/compiler/mips
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv29172/src/compiler/mips

Modified Files:
      Tag: character_branch
	char.lisp float.lisp move.lisp vm.lisp 
Log Message:
0.8.13.77.character.45:
	"Ow!  Don't do that"

	Place the HEAD character_branch-related changes to the backends
	also on character_branch, for ease of merging.


Index: char.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/mips/char.lisp,v
retrieving revision 1.1
retrieving revision 1.1.48.1
diff -u -d -r1.1 -r1.1.48.1
--- char.lisp	1 Sep 2002 22:34:18 -0000	1.1
+++ char.lisp	28 Oct 2004 14:54:55 -0000	1.1.48.1
@@ -1,84 +1,79 @@
-(in-package "SB!VM")
+;;;; the MIPS VM definition of character operations
 
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
 
+(in-package "SB!VM")
 
 ;;;; Moves and coercions:
 
 ;;; Move a tagged char to an untagged representation.
-;;;
-(define-vop (move-to-base-char)
+(define-vop (move-to-character)
   (:args (x :scs (any-reg descriptor-reg)))
-  (:results (y :scs (base-char-reg)))
+  (:results (y :scs (character-reg)))
   (:generator 1
     (inst srl y x n-widetag-bits)))
-;;;
-(define-move-vop move-to-base-char :move
-  (any-reg descriptor-reg) (base-char-reg))
+(define-move-vop move-to-character :move
+  (any-reg descriptor-reg) (character-reg))
 
 
 ;;; Move an untagged char to a tagged representation.
-;;;
-(define-vop (move-from-base-char)
-  (:args (x :scs (base-char-reg)))
+(define-vop (move-from-character)
+  (:args (x :scs (character-reg)))
   (:results (y :scs (any-reg descriptor-reg)))
   (:generator 1
     (inst sll y x n-widetag-bits)
-    (inst or y y base-char-widetag)))
-;;;
-(define-move-vop move-from-base-char :move
-  (base-char-reg) (any-reg descriptor-reg))
+    (inst or y y character-widetag)))
+(define-move-vop move-from-character :move
+  (character-reg) (any-reg descriptor-reg))
 
-;;; Move untagged base-char values.
-;;;
-(define-vop (base-char-move)
+;;; Move untagged character values.
+(define-vop (character-move)
   (:args (x :target y
-	    :scs (base-char-reg)
+	    :scs (character-reg)
 	    :load-if (not (location= x y))))
-  (:results (y :scs (base-char-reg)
+  (:results (y :scs (character-reg)
 	       :load-if (not (location= x y))))
   (:effects)
   (:affected)
   (:generator 0
     (move y x)))
-;;;
-(define-move-vop base-char-move :move
-  (base-char-reg) (base-char-reg))
-
+(define-move-vop character-move :move
+  (character-reg) (character-reg))
 
-;;; Move untagged base-char arguments/return-values.
-;;;
-(define-vop (move-base-char-arg)
+;;; Move untagged character arguments/return-values.
+(define-vop (move-character-arg)
   (:args (x :target y
-	    :scs (base-char-reg))
+	    :scs (character-reg))
 	 (fp :scs (any-reg)
-	     :load-if (not (sc-is y base-char-reg))))
+	     :load-if (not (sc-is y character-reg))))
   (:results (y))
   (:generator 0
     (sc-case y
-      (base-char-reg
+      (character-reg
        (move y x))
-      (base-char-stack
+      (character-stack
        (storew x fp (tn-offset y))))))
-;;;
-(define-move-vop move-base-char-arg :move-arg
-  (any-reg base-char-reg) (base-char-reg))
-
+(define-move-vop move-character-arg :move-arg
+  (any-reg character-reg) (character-reg))
 
-;;; Use standard MOVE-ARGUMENT + coercion to move an untagged base-char
-;;; to a descriptor passing location.
-;;;
+;;; Use standard MOVE-ARG + coercion to move an untagged character to
+;;; a descriptor passing location.
 (define-move-vop move-arg :move-arg
-  (base-char-reg) (any-reg descriptor-reg))
-
-
+  (character-reg) (any-reg descriptor-reg))
 
 ;;;; Other operations:
-
 (define-vop (char-code)
   (:translate char-code)
   (:policy :fast-safe)
-  (:args (ch :scs (base-char-reg) :target res))
-  (:arg-types base-char)
+  (:args (ch :scs (character-reg) :target res))
+  (:arg-types character)
   (:results (res :scs (any-reg)))
   (:result-types positive-fixnum)
   (:generator 1
@@ -89,28 +84,28 @@
   (:policy :fast-safe)
   (:args (code :scs (any-reg) :target res))
   (:arg-types positive-fixnum)
-  (:results (res :scs (base-char-reg)))
-  (:result-types base-char)
+  (:results (res :scs (character-reg)))
+  (:result-types character)
   (:generator 1
     (inst srl res code 2)))
 
 
-;;; Comparison of base-chars.
+;;; Comparison of characters.
 ;;;
-(define-vop (base-char-compare pointer-compare)
-  (:args (x :scs (base-char-reg))
-	 (y :scs (base-char-reg)))
-  (:arg-types base-char base-char))
+(define-vop (character-compare pointer-compare)
+  (:args (x :scs (character-reg))
+	 (y :scs (character-reg)))
+  (:arg-types character character))
 
-(define-vop (fast-char=/base-char base-char-compare)
+(define-vop (fast-char=/character character-compare)
   (:translate char=)
   (:variant :eq))
 
-(define-vop (fast-char</base-char base-char-compare)
+(define-vop (fast-char</character character-compare)
   (:translate char<)
   (:variant :lt))
 
-(define-vop (fast-char>/base-char base-char-compare)
+(define-vop (fast-char>/character character-compare)
   (:translate char>)
   (:variant :gt))
 

Index: float.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/mips/float.lisp,v
retrieving revision 1.1
retrieving revision 1.1.48.1
diff -u -d -r1.1 -r1.1.48.1
--- float.lisp	1 Sep 2002 22:34:18 -0000	1.1
+++ float.lisp	28 Oct 2004 14:54:56 -0000	1.1.48.1
@@ -1,9 +1,18 @@
+;;;; the MIPS VM definition of floating point operations
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
 (in-package "SB!VM")
 
 
 ;;;; Move functions:
-
-
 (define-move-fun (load-single 1) (vop x y)
   ((single-stack) (single-reg))
   (inst lwc1 y (current-nfp-tn vop) (* (tn-offset x) n-word-bytes))
@@ -13,7 +22,6 @@
   ((single-reg) (single-stack))
   (inst swc1 x (current-nfp-tn vop) (* (tn-offset y) n-word-bytes)))
 
-
 (defun ld-double (r base offset)
   (ecase *backend-byte-order*
     (:big-endian
@@ -44,11 +52,8 @@
   (let ((nfp (current-nfp-tn vop))
 	(offset (* (tn-offset y) n-word-bytes)))
     (str-double x nfp offset)))
-
-
 
 ;;;; Move VOPs:
-
 (macrolet ((frob (vop sc format)
 	     `(progn
 		(define-vop (,vop)
@@ -65,7 +70,6 @@
   (frob single-move single-reg :single)
   (frob double-move double-reg :double))
 
-
 (define-vop (move-from-float)
   (:args (x :to :save))
   (:results (y))
@@ -91,7 +95,6 @@
   (frob move-from-double double-reg
     t double-float-size double-float-widetag double-float-value-slot))
 
-
 (macrolet ((frob (name sc double-p value)
 	     `(progn
 		(define-vop (,name)
@@ -122,7 +125,6 @@
   (frob move-to-single single-reg nil single-float-value-slot)
   (frob move-to-double double-reg t double-float-value-slot))
 
-
 (macrolet ((frob (name sc stack-sc format double-p)
 	     `(progn
 		(define-vop (,name)
@@ -155,7 +157,6 @@
 		  (,sc descriptor-reg) (,sc)))))
   (frob move-single-float-arg single-reg single-stack :single nil)
   (frob move-double-float-arg double-reg double-stack :double t))
-
 
 ;;;; Complex float move functions
 
@@ -173,7 +174,6 @@
   (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
 		  :offset (+ (tn-offset x) 2)))
 
-
 (define-move-fun (load-complex-single 2) (vop x y)
   ((complex-single-stack) (complex-single-reg))
   (let ((nfp (current-nfp-tn vop))
@@ -193,7 +193,6 @@
     (let ((imag-tn (complex-single-reg-imag-tn x)))
       (inst swc1 imag-tn nfp (+ offset n-word-bytes)))))
 
-
 (define-move-fun (load-complex-double 4) (vop x y)
   ((complex-double-stack) (complex-double-reg))
   (let ((nfp (current-nfp-tn vop))
@@ -213,9 +212,7 @@
     (let ((imag-tn (complex-double-reg-imag-tn x)))
       (str-double imag-tn nfp (+ offset (* 2 n-word-bytes))))))
 
-;;;
 ;;; Complex float register to register moves.
-;;;
 (define-vop (complex-single-move)
   (:args (x :scs (complex-single-reg) :target y
 	    :load-if (not (location= x y))))
@@ -231,7 +228,6 @@
        (let ((x-imag (complex-single-reg-imag-tn x))
 	     (y-imag (complex-single-reg-imag-tn y)))
 	 (inst fmove :single y-imag x-imag)))))
-;;;
 (define-move-vop complex-single-move :move
   (complex-single-reg) (complex-single-reg))
 
@@ -250,14 +246,11 @@
        (let ((x-imag (complex-double-reg-imag-tn x))
 	     (y-imag (complex-double-reg-imag-tn y)))
 	 (inst fmove :double y-imag x-imag)))))
-;;;
 (define-move-vop complex-double-move :move
   (complex-double-reg) (complex-double-reg))
 
-;;;
 ;;; Move from a complex float to a descriptor register allocating a
 ;;; new complex float object in the process.
-;;;
 (define-vop (move-from-complex-single)
   (:args (x :scs (complex-single-reg) :to :save))
   (:results (y :scs (descriptor-reg)))
@@ -275,7 +268,6 @@
 	(inst swc1 imag-tn y (- (* complex-single-float-imag-slot
 				   n-word-bytes)
 				other-pointer-lowtag))))))
-;;;
 (define-move-vop move-from-complex-single :move
   (complex-single-reg) (descriptor-reg))
 
@@ -296,13 +288,10 @@
 	(str-double imag-tn y (- (* complex-double-float-imag-slot
 				    n-word-bytes)
 				 other-pointer-lowtag))))))
-;;;
 (define-move-vop move-from-complex-double :move
   (complex-double-reg) (descriptor-reg))
 
-;;;
 ;;; Move from a descriptor to a complex float register
-;;;
 (define-vop (move-to-complex-single)
   (:args (x :scs (descriptor-reg)))
   (:results (y :scs (complex-single-reg)))
@@ -333,9 +322,7 @@
 (define-move-vop move-to-complex-double :move
   (descriptor-reg) (complex-double-reg))
 
-;;;
-;;; Complex float move-argument vop
-;;;
+;;; complex float MOVE-ARG VOP
 (define-vop (move-complex-single-float-arg)
   (:args (x :scs (complex-single-reg) :target y)
 	 (nfp :scs (any-reg) :load-if (not (sc-is y complex-single-reg))))
@@ -384,14 +371,12 @@
 (define-move-vop move-complex-double-float-arg :move-arg
   (complex-double-reg descriptor-reg) (complex-double-reg))
 
-
 (define-move-vop move-arg :move-arg
   (single-reg double-reg complex-single-reg complex-double-reg)
   (descriptor-reg))
 
 
 ;;;; stuff for c-call float-in-int-register arguments
-
 (define-vop (move-to-single-int-reg)
   (:args (x :scs (single-reg descriptor-reg)))
   (:results (y :scs (single-int-carg-reg) :load-if nil))

Index: move.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/mips/move.lisp,v
retrieving revision 1.1
retrieving revision 1.1.48.1
diff -u -d -r1.1 -r1.1.48.1
--- move.lisp	1 Sep 2002 22:34:18 -0000	1.1
+++ move.lisp	28 Oct 2004 14:54:56 -0000	1.1.48.1
@@ -14,15 +14,15 @@
        (load-symbol y val))
       (character
        (inst li y (logior (ash (char-code val) n-widetag-bits)
-			  base-char-widetag))))))
+			  character-widetag))))))
 
 (define-move-fun (load-number 1) (vop x y)
   ((zero immediate)
    (signed-reg unsigned-reg))
   (inst li y (tn-value x)))
 
-(define-move-fun (load-base-char 1) (vop x y)
-  ((immediate) (base-char-reg))
+(define-move-fun (load-character 1) (vop x y)
+  ((immediate) (character-reg))
   (inst li y (char-code (tn-value x))))
 
 (define-move-fun (load-system-area-pointer 1) (vop x y)
@@ -38,7 +38,7 @@
   (load-stack-tn y x))
 
 (define-move-fun (load-number-stack 5) (vop x y)
-  ((base-char-stack) (base-char-reg)
+  ((character-stack) (character-reg)
    (sap-stack) (sap-reg)
    (signed-stack) (signed-reg)
    (unsigned-stack) (unsigned-reg))
@@ -50,7 +50,7 @@
   (store-stack-tn y x))
 
 (define-move-fun (store-number-stack 5) (vop x y)
-  ((base-char-reg) (base-char-stack)
+  ((character-reg) (character-stack)
    (sap-reg) (sap-stack)
    (signed-reg) (signed-stack)
    (unsigned-reg) (unsigned-stack))

Index: vm.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/mips/vm.lisp,v
retrieving revision 1.4
retrieving revision 1.4.10.1
diff -u -d -r1.4 -r1.4.10.1
--- vm.lisp	15 Mar 2004 00:01:00 -0000	1.4
+++ vm.lisp	28 Oct 2004 14:54:56 -0000	1.4.10.1
@@ -124,7 +124,7 @@
   ;; The non-descriptor stacks.
   (signed-stack non-descriptor-stack) ; (signed-byte 32)
   (unsigned-stack non-descriptor-stack) ; (unsigned-byte 32)
-  (base-char-stack non-descriptor-stack) ; non-descriptor characters.
+  (character-stack non-descriptor-stack) ; non-descriptor characters.
   (sap-stack non-descriptor-stack) ; System area pointers.
   (single-stack non-descriptor-stack) ; single-floats
   (double-stack non-descriptor-stack :element-size 2) ; double floats.
@@ -156,12 +156,12 @@
    :alternate-scs (control-stack))
 
   ;; Non-Descriptor characters
-  (base-char-reg registers
+  (character-reg registers
    :locations #.non-descriptor-regs
    :reserve-locations #.reserve-non-descriptor-regs
    :constant-scs (immediate)
    :save-p t
-   :alternate-scs (base-char-stack))
+   :alternate-scs (character-stack))
 
   ;; Non-Descriptor SAP's (arbitrary pointers into address space)
   (sap-reg registers