X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsparc%2Fmove.lisp;h=fb3c9de49cdc18da6ae5bd26fffd7574be917350;hb=1ee20a4186d01454f5cf61a3049160c174568305;hp=4ff9eb552e6f9d4cccd44deccca0c13132dcaebc;hpb=ea775867d48327bf1179eb570263427f28083880;p=sbcl.git

diff --git a/src/compiler/sparc/move.lisp b/src/compiler/sparc/move.lisp
index 4ff9eb5..fb3c9de 100644
--- a/src/compiler/sparc/move.lisp
+++ b/src/compiler/sparc/move.lisp
@@ -24,15 +24,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)
   ((immediate zero)
    (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)
@@ -41,14 +41,38 @@
 
 (define-move-fun (load-constant 5) (vop x y)
   ((constant) (descriptor-reg))
-  (loadw y code-tn (tn-offset x) other-pointer-lowtag))
+  ;; Does the (positive) offset fit into our signed 13 bit immediate?
+  ;; Else go through a temporary register.  Note that PPC (for example)
+  ;; does not try to support arbitrarily large constant offsets, but PPC
+  ;; supports 16 bit immediates, so the restriction is not as severe
+  ;; there.
+  (let ((nbits 12))
+    (cond
+      ((<= (- (ash (tn-offset x) word-shift) other-pointer-lowtag)
+           (1- (ash 1 nbits)))
+       (loadw y code-tn (tn-offset x) other-pointer-lowtag))
+      (t
+       ;; Use LIP as a temporary.  This should be OK, because LIP is only
+       ;; used within VOPs, whereas we get called to supply the VOP's
+       ;; parameters much earlier.  And LIP-TN is relative to CODE-TN, so
+       ;; the GC should be fine with this.
+       (move lip-tn code-tn)
+       ;; When ADDing the offset, we need multiple steps, because ADD's
+       ;; immediate has the same size restriction as LOADW's.  Take care
+       ;; to add in word-sized steps, so that the LIP remains valid.
+       (let ((stepsize (logandc2 (1- (ash 1 nbits)) (1- (ash 1 word-shift)))))
+         (multiple-value-bind (q r)
+             (truncate (ash (tn-offset x) word-shift) stepsize)
+           (dotimes (x q) (inst add lip-tn stepsize))
+           (when (plusp r) (inst add lip-tn r))))
+       (loadw y lip-tn 0 other-pointer-lowtag)))))
 
 (define-move-fun (load-stack 5) (vop x y)
   ((control-stack) (any-reg descriptor-reg))
   (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))
@@ -60,7 +84,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))
@@ -72,10 +96,10 @@
 
 (define-vop (move)
   (:args (x :target y
-	    :scs (any-reg descriptor-reg zero null)
-	    :load-if (not (location= x y))))
+            :scs (any-reg descriptor-reg zero null)
+            :load-if (not (location= x y))))
   (:results (y :scs (any-reg descriptor-reg)
-	       :load-if (not (location= x y))))
+               :load-if (not (location= x y))))
   (:effects)
   (:affected)
   (:generator 0
@@ -94,9 +118,9 @@
 ;;; another frame for argument or known value passing.
 (define-vop (move-arg)
   (:args (x :target y
-	    :scs (any-reg descriptor-reg zero null))
-	 (fp :scs (any-reg)
-	     :load-if (not (sc-is y any-reg descriptor-reg))))
+            :scs (any-reg descriptor-reg zero null))
+         (fp :scs (any-reg)
+             :load-if (not (sc-is y any-reg descriptor-reg))))
   (:results (y))
   (:generator 0
     (sc-case y
@@ -150,7 +174,11 @@
   (:results (y :scs (signed-reg unsigned-reg)))
   (:note "constant load")
   (:generator 1
-    (inst li y (tn-value x))))
+    (cond ((sb!c::tn-leaf x)
+           (inst li y (tn-value x)))
+          (t
+           (loadw y code-tn (tn-offset x) other-pointer-lowtag)
+           (inst sra y y n-fixnum-tag-bits)))))
 
 (define-move-vop move-to-word-c :move
   (constant) (signed-reg unsigned-reg))
@@ -167,9 +195,9 @@
       (inst andcc temp x fixnum-tag-mask)
       (inst b :eq done)
       (inst sra y x n-fixnum-tag-bits)
-      
+
       (loadw y x bignum-digits-offset other-pointer-lowtag)
-      
+
       (emit-label done))))
 
 (define-move-vop move-to-word/integer :move
@@ -199,20 +227,20 @@
   (:generator 20
     (move x arg)
     (let ((fixnum (gen-label))
-	  (done (gen-label)))
+          (done (gen-label)))
       (inst sra temp x n-positive-fixnum-bits)
       (inst cmp temp)
       (inst b :eq fixnum)
       (inst orncc temp zero-tn temp)
       (inst b :eq done)
       (inst sll y x n-fixnum-tag-bits)
-      
+
       (with-fixed-allocation
-	(y temp bignum-widetag (1+ bignum-digits-offset))
-	(storew x y bignum-digits-offset other-pointer-lowtag))
+        (y temp bignum-widetag (1+ bignum-digits-offset))
+        (storew x y bignum-digits-offset other-pointer-lowtag))
       (inst b done)
       (inst nop)
-      
+
       (emit-label fixnum)
       (inst sll y x n-fixnum-tag-bits)
       (emit-label done))))
@@ -232,8 +260,7 @@
   (:generator 20
     (move x arg)
     (let ((done (gen-label))
-	  (one-word (gen-label))
-	  (initial-alloc (pad-data-block (1+ bignum-digits-offset))))
+          (one-word (gen-label)))
       (inst sra temp x n-positive-fixnum-bits)
       (inst cmp temp)
       (inst b :eq done)
@@ -242,17 +269,17 @@
       ;; We always allocate 2 words even if we don't need it.  (The
       ;; copying GC will take care of freeing the unused extra word.)
       (with-fixed-allocation
-	  (y temp bignum-widetag (+ 2 bignum-digits-offset))
-	(inst cmp x)
-	(inst b :ge one-word)
-	(inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag))
-	(inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag))
-	(emit-label one-word)
-	;; Set the header word, then the actual digit.  The extra
-	;; digit, if any, is automatically set to zero, so we don't
-	;; have to.
-	(storew temp y 0 other-pointer-lowtag)
-	(storew x y bignum-digits-offset other-pointer-lowtag))
+          (y temp bignum-widetag (+ 2 bignum-digits-offset))
+        (inst cmp x)
+        (inst b :ge one-word)
+        (inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag))
+        (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag))
+        (emit-label one-word)
+        ;; Set the header word, then the actual digit.  The extra
+        ;; digit, if any, is automatically set to zero, so we don't
+        ;; have to.
+        (storew temp y 0 other-pointer-lowtag)
+        (storew x y bignum-digits-offset other-pointer-lowtag))
       (emit-label done))))
 
 (define-move-vop move-from-unsigned :move
@@ -262,10 +289,10 @@
 ;;; Move untagged numbers.
 (define-vop (word-move)
   (:args (x :target y
-	    :scs (signed-reg unsigned-reg)
-	    :load-if (not (location= x y))))
+            :scs (signed-reg unsigned-reg)
+            :load-if (not (location= x y))))
   (:results (y :scs (signed-reg unsigned-reg)
-	       :load-if (not (location= x y))))
+               :load-if (not (location= x y))))
   (:effects)
   (:affected)
   (:note "word integer move")
@@ -279,9 +306,9 @@
 ;;; Move untagged number arguments/return-values.
 (define-vop (move-word-arg)
   (:args (x :target y
-	    :scs (signed-reg unsigned-reg))
-	 (fp :scs (any-reg)
-	     :load-if (not (sc-is y sap-reg))))
+            :scs (signed-reg unsigned-reg))
+         (fp :scs (any-reg)
+             :load-if (not (sc-is y sap-reg))))
   (:results (y))
   (:note "word integer argument move")
   (:generator 0