From c9d7864be8f430331e3f85cdd2e53963ac25b576 Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Tue, 25 Feb 1992 07:10:28 +0000
Subject: [PATCH] Changed all the SAP-{REF,SET}-mumble VOPs to take the offset
 in bytes.

---
 compiler/sparc/sap.lisp | 329 +++++++++++++++-------------------------
 1 file changed, 120 insertions(+), 209 deletions(-)

diff --git a/compiler/sparc/sap.lisp b/compiler/sparc/sap.lisp
index 46386d94e..26d0a774f 100644
--- a/compiler/sparc/sap.lisp
+++ b/compiler/sparc/sap.lisp
@@ -1,13 +1,15 @@
 ;;; -*- Package: SPARC -*-
 ;;;
 ;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/sap.lisp,v 1.3 1992/02/25 07:10:28 wlott Exp $")
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/sap.lisp,v 1.2 1992/01/14 16:03:35 ram Exp $
+;;; **********************************************************************
 ;;;
 ;;; This file contains the SPARC VM definition of SAP operations.
 ;;;
@@ -149,186 +151,118 @@
 
 ;;;; mumble-SYSTEM-REF and mumble-SYSTEM-SET
 
-(define-vop (sap-ref)
-  (:policy :fast-safe)
-  (:variant-vars size signed)
-  (:args (sap :scs (sap-reg))
-	 (offset :scs (any-reg signed-reg zero immediate)))
-  (:arg-types system-area-pointer positive-fixnum)
-  (:results (result))
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:generator 5
-    (let* ((shift (ecase size
-		    (:byte 0)
-		    (:short 1)
-		    ((:long :single :double) 2)))
-	   (offset
-	    (sc-case offset
-	      (zero offset)
-	      (immediate
-	       (let ((offset (ash (tn-value offset) shift)))
-		 (cond ((typep offset '(signed-byte 13))
-			offset)
-		       (t
-			(inst li temp offset)
-			temp))))
-	      ((any-reg signed-reg)
-	       (when (sc-is offset any-reg)
-		 (decf shift 2))
-	       (cond ((plusp shift)
-		      (inst sll temp offset shift)
-		      temp)
-		     ((minusp shift)
-		      (inst sra temp offset (- shift))
-		      temp)
-		     (t
-		      offset))))))
-      (ecase size
-	(:byte
-	 (if signed
-	     (inst ldsb result sap offset)
-	     (inst ldub result sap offset)))
-	(:short
-	 (if signed
-	     (inst ldsh result sap offset)
-	     (inst lduh result sap offset)))
-	(:long
-	 (inst ld result sap offset))
-	(:single
-	 (inst ldf result sap offset))
-	(:double
-	 (inst lddf result sap offset))))))
-
-
-(define-vop (sap-set)
-  (:policy :fast-safe)
-  (:variant-vars size)
-  (:args (sap :scs (sap-reg))
-	 (offset :scs (any-reg signed-reg zero immediate))
-	 (value :scs (signed-reg unsigned-reg) :target result))
-  (:arg-types system-area-pointer positive-fixnum (:or signed-num unsigned-num))
-  (:results (result :scs (signed-reg unsigned-reg)))
-  (:result-types (:or signed-num unsigned-num))
-  (:temporary (:scs (non-descriptor-reg)) temp)
-  (:generator 5
-    (let* ((shift (ecase size
-		    (:byte 0)
-		    (:short 1)
-		    ((:long :single :double) 2)))
-	   (offset
-	    (sc-case offset
-	      (zero offset)
-	      (immediate
-	       (let ((offset (ash (tn-value offset) shift)))
-		 (cond ((typep offset '(signed-byte 13))
-			offset)
-		       (t
-			(inst li temp offset)
-			temp))))
-	      ((any-reg signed-reg)
-	       (when (sc-is offset any-reg)
-		 (decf shift 2))
-	       (cond ((plusp shift)
-		      (inst sll temp offset shift)
-		      temp)
-		     ((minusp shift)
-		      (inst sra temp offset (- shift))
-		      temp)
-		     (t
-		      offset))))))
-      (ecase size
-	(:byte
-	 (inst stb value sap offset)
-	 (move result value))
-	(:short
-	 (inst sth value sap offset)
-	 (move result value))
-	(:long
-	 (inst st value sap offset)
-	 (move result value))
-	(:single
-	 (inst stf value sap offset)
-	 (unless (location= result value)
-	   (inst fmovs result value)))
-	(:double
-	 (inst stdf value sap offset)
-	 (unless (location= result value)
-	   (inst fmovs result value)
-	   (inst fmovs-odd result value)))))))
-
-
-
-(define-vop (sap-system-ref sap-ref)
-  (:translate sap-ref-sap)
-  (:results (result :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:variant :long nil))
-
-(define-vop (sap-system-set sap-set)
-  (:translate %set-sap-ref-sap)
-  (:args (sap :scs (sap-reg))
-	 (offset :scs (any-reg signed-reg zero immediate))
-	 (value :scs (sap-reg) :target result))
-  (:arg-types system-area-pointer positive-fixnum system-area-pointer)
-  (:results (result :scs (sap-reg)))
-  (:result-types system-area-pointer)
-  (:variant :long))
-
-
-
-(define-vop (32bit-system-ref sap-ref)
-  (:translate sap-ref-32)
-  (:results (result :scs (unsigned-reg)))
-  (:result-types unsigned-num)
-  (:variant :long nil))
-
-(define-vop (signed-32bit-system-ref sap-ref)
-  (:translate signed-sap-ref-32)
-  (:results (result :scs (signed-reg)))
-  (:result-types signed-num)
-  (:variant :long t))
-
-(define-vop (32bit-system-set sap-set)
-  (:translate %set-sap-ref-32)
-  (:arg-types system-area-pointer positive-fixnum
-	      (:or unsigned-num signed-num))
-  (:variant :long))
-
-
-(define-vop (16bit-system-ref sap-ref)
-  (:translate sap-ref-16)
-  (:results (result :scs (unsigned-reg)))
-  (:result-types positive-fixnum)
-  (:variant :short nil))
-
-(define-vop (signed-16bit-system-ref sap-ref)
-  (:translate signed-sap-ref-16)
-  (:results (result :scs (signed-reg)))
-  (:result-types tagged-num)
-  (:variant :short t))
-
-(define-vop (16bit-system-set sap-set)
-  (:translate %set-sap-ref-16)
-  (:arg-types system-area-pointer positive-fixnum tagged-num)
-  (:variant :short))
-
-
-(define-vop (8bit-system-ref sap-ref)
-  (:translate sap-ref-8)
-  (:results (result :scs (unsigned-reg)))
-  (:result-types positive-fixnum)
-  (:variant :byte nil))
-
-(define-vop (signed-8bit-system-ref sap-ref)
-  (:translate signed-sap-ref-8)
-  (:results (result :scs (signed-reg)))
-  (:result-types tagged-num)
-  (:variant :byte t))
-
-(define-vop (8bit-system-set sap-set)
-  (:translate %set-sap-ref-8)
-  (:arg-types system-area-pointer positive-fixnum tagged-num)
-  (:variant :byte))
+(eval-when (compile eval)
+
+(defmacro def-system-ref-and-set
+	  (ref-name set-name sc type size &optional signed)
+  (let ((ref-name-c (symbolicate ref-name "-C"))
+	(set-name-c (symbolicate set-name "-C")))
+    `(progn
+       (define-vop (,ref-name)
+	 (:translate ,ref-name)
+	 (:policy :fast-safe)
+	 (:args (sap :scs (sap-reg))
+		(offset :scs (unsigned-reg)))
+	 (:arg-types system-area-pointer unsigned-num)
+	 (:results (result :scs (,sc)))
+	 (:result-types ,type)
+	 (:generator 5
+	   (inst ,(ecase size
+		    (:byte (if signed 'ldsb 'ldub))
+		    (:short (if signed 'ldsh 'lsuh))
+		    (:long 'ld)
+		    (:single 'ldf)
+		    (:double 'lddf))
+		 result sap offset)))
+       (define-vop (,ref-name-c)
+	 (:translate ,ref-name)
+	 (:policy :fast-safe)
+	 (:args (sap :scs (sap-reg)))
+	 (:arg-types system-area-pointer (:constant (signed-byte 13)))
+	 (:info offset)
+	 (:results (result :scs (,sc)))
+	 (:result-types ,type)
+	 (:generator 4
+	   (inst ,(ecase size
+		    (:byte (if signed 'ldsb 'ldub))
+		    (:short (if signed 'ldsh 'lsuh))
+		    (:long 'ld)
+		    (:single 'ldf)
+		    (:double 'lddf))
+		 result sap offset)))
+       (define-vop (,set-name)
+	 (:translate ,set-name)
+	 (:policy :fast-safe)
+	 (:args (sap :scs (sap-reg))
+		(offset :scs (unsigned-reg))
+		(value :scs (,sc) :target result))
+	 (:arg-types system-area-pointer unsigned-num ,type)
+	 (:results (result :scs (,sc)))
+	 (:result-types ,type)
+	 (:generator 5
+	   (inst ,(ecase size
+		    (:byte 'stb)
+		    (:short 'sth)
+		    (:long 'st)
+		    (:single 'stf)
+		    (:double 'stdf))
+		 value sap offset)
+	   (unless (location= result value)
+	     ,@(case size
+		 (:single
+		  '((inst fmovs result value)))
+		 (:double
+		  '((inst fmovs result value)
+		    (inst fmovs-odd result value)))
+		 (t
+		  '((inst move result value)))))))
+       (define-vop (,set-name-c)
+	 (:translate ,set-name)
+	 (:policy :fast-safe)
+	 (:args (sap :scs (sap-reg))
+		(value :scs (,sc) :target result))
+	 (:arg-types system-area-pointer (:constant (signed-byte 13)) ,type)
+	 (:info offset)
+	 (:results (result :scs (,sc)))
+	 (:result-types ,type)
+	 (:generator 4
+	   (inst ,(ecase size
+		    (:byte 'stb)
+		    (:short 'sth)
+		    (:long 'st)
+		    (:single 'stf)
+		    (:double 'stdf))
+		 value sap offset)
+	   (unless (location= result value)
+	     ,@(case size
+		 (:single
+		  '((inst fmovs result value)))
+		 (:double
+		  '((inst fmovs result value)
+		    (inst fmovs-odd result value)))
+		 (t
+		  '((inst move result value))))))))))
+
+); eval-when (compile eval)
+
+(def-system-ref-and-set sap-ref-8 %set-sap-ref-8
+  unsigned-reg positive-fixnum :byte nil)
+(def-system-ref-and-set signed-sap-ref-8 %set-signed-sap-ref-8
+  signed-reg tagged-num :byte t)
+(def-system-ref-and-set sap-ref-16 %set-sap-ref-16
+  unsigned-reg positive-fixnum :short nil)
+(def-system-ref-and-set signed-sap-ref-16 %set-signed-sap-ref-16
+  signed-reg tagged-num :short t)
+(def-system-ref-and-set sap-ref-32 %set-sap-ref-32
+  unsigned-reg unsigned-num :long nil)
+(def-system-ref-and-set signed-sap-ref-32 %set-signed-sap-ref-32
+  signed-reg signed-num :long t)
+(def-system-ref-and-set sap-ref-sap %set-sap-ref-sap
+  sap-reg system-area-pointer :long)
+(def-system-ref-and-set sap-ref-single %set-sap-ref-single
+  single-reg single-float :single)
+(def-system-ref-and-set sap-ref-double %set-sap-ref-double
+  double-reg double-float :double)
 
 
 
@@ -344,26 +278,3 @@
     (inst add sap vector
 	  (- (* vector-data-offset word-bytes) other-pointer-type))))
 
-
-
-;;;; ### Noise to allow old forms to continue to work until they are gone.
-
-(macrolet ((frob (prim func)
-	     `(def-primitive-translator ,prim (&rest args)
-		(warn "Someone used %primitive ~S -- should be ~S."
-		      ',prim ',func)
-		`(,',func ,@args))))
-  (frob 32bit-system-ref sap-ref-32)
-  (frob unsigned-32bit-system-ref sap-ref-32)
-  (frob 16bit-system-ref sap-ref-16)
-  (frob 8bit-system-ref sap-ref-8))
-
-(macrolet ((frob (prim func)
-	     `(def-primitive-translator ,prim (&rest args)
-		(warn "Someone used %primitive ~S -- should be ~S."
-		      ',prim (list 'setf ',func))
-		`(setf ,',func ,@args))))
-  (frob 32bit-system-set sap-ref-32)
-  (frob signed-32bit-system-set sap-ref-32)
-  (frob 16bit-system-set sap-ref-16)
-  (frob 8bit-system-set sap-ref-8))
-- 
GitLab