From: Thiemo Seufer <ths@networkno.de>
Date: Thu, 11 Dec 2008 20:28:13 +0000 (+0000)
Subject: 1.0.23.33: Stack-allocatable vectors for MIPS.
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=554d78debd8eab9455e5283639c2fb71fac75deb;p=sbcl.git

1.0.23.33: Stack-allocatable vectors for MIPS.
---

diff --git a/src/assembly/mips/array.lisp b/src/assembly/mips/array.lisp
index 3c53f1e..5e68e87 100644
--- a/src/assembly/mips/array.lisp
+++ b/src/assembly/mips/array.lisp
@@ -12,29 +12,4 @@
 
 (in-package "SB!VM")
 
-(define-assembly-routine (allocate-vector
-                          (:policy :fast-safe)
-                          (:translate allocate-vector)
-                          (:arg-types positive-fixnum
-                                      positive-fixnum
-                                      positive-fixnum))
-                         ((:arg type any-reg a0-offset)
-                          (:arg length any-reg a1-offset)
-                          (:arg words any-reg a2-offset)
-                          (:res result descriptor-reg a0-offset)
-
-                          (:temp ndescr non-descriptor-reg nl0-offset)
-                          (:temp pa-flag non-descriptor-reg nl4-offset))
-  ;; This is kinda sleezy, changing words like this.  But we can because
-  ;; the vop thinks it is temporary.
-  (inst addu words (+ lowtag-mask
-                      (* vector-data-offset n-word-bytes)))
-  (inst srl ndescr type word-shift)
-  (inst srl words n-lowtag-bits)
-  (inst sll words n-lowtag-bits)
-
-  (pseudo-atomic (pa-flag)
-    (inst or result alloc-tn other-pointer-lowtag)
-    (inst addu alloc-tn words)
-    (storew ndescr result 0 other-pointer-lowtag)
-    (storew length result vector-length-slot other-pointer-lowtag)))
+;;;; Note: ALLOCATE-VECTOR is now implemented as a VOP.
diff --git a/src/compiler/generic/vm-ir2tran.lisp b/src/compiler/generic/vm-ir2tran.lisp
index 40eb40c..c864d26 100644
--- a/src/compiler/generic/vm-ir2tran.lisp
+++ b/src/compiler/generic/vm-ir2tran.lisp
@@ -175,7 +175,7 @@
 ;;; Stack allocation optimizers per platform support
 ;;;
 ;;; Platforms with stack-allocatable vectors
-#!+(or x86 x86-64)
+#!+(or mips x86 x86-64)
 (progn
   (defoptimizer (allocate-vector stack-allocate-result)
       ((type length words) node dx)
diff --git a/src/compiler/mips/alloc.lisp b/src/compiler/mips/alloc.lisp
index dd9b304..30c1439 100644
--- a/src/compiler/mips/alloc.lisp
+++ b/src/compiler/mips/alloc.lisp
@@ -77,6 +77,61 @@
 
 ;;;; Special purpose inline allocators.
 
+;;; ALLOCATE-VECTOR
+(define-vop (allocate-vector-on-heap)
+  (:args (type :scs (unsigned-reg))
+         (length :scs (any-reg))
+         (words :scs (any-reg)))
+  (:arg-types positive-fixnum
+              positive-fixnum
+              positive-fixnum)
+  (:temporary (:sc non-descriptor-reg :offset nl0-offset) bytes)
+  (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
+  (:results (result :scs (descriptor-reg) :from :load))
+  (:policy :fast-safe)
+  (:generator 100
+    (inst addu bytes words (+ lowtag-mask
+                              (* vector-data-offset n-word-bytes)))
+    (inst srl bytes n-lowtag-bits)
+    (inst sll bytes n-lowtag-bits)
+    (pseudo-atomic (pa-flag)
+      (inst or result alloc-tn other-pointer-lowtag)
+      (inst addu alloc-tn bytes)
+      (storew type result 0 other-pointer-lowtag)
+      (storew length result vector-length-slot other-pointer-lowtag))))
+
+(define-vop (allocate-vector-on-stack)
+  (:args (type :scs (unsigned-reg))
+         (length :scs (any-reg))
+         (words :scs (any-reg)))
+  (:arg-types positive-fixnum
+              positive-fixnum
+              positive-fixnum)
+  (:temporary (:sc non-descriptor-reg :offset nl0-offset) bytes)
+  (:temporary (:sc non-descriptor-reg :offset nl1-offset) temp)
+  (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
+  (:results (result :scs (descriptor-reg) :from :load))
+  (:policy :fast-safe)
+  (:generator 100
+    (inst addu bytes words (+ lowtag-mask
+                              (* vector-data-offset n-word-bytes)))
+    (inst srl bytes n-lowtag-bits)
+    (inst sll bytes n-lowtag-bits)
+    ;; FIXME: It would be good to check for stack overflow here.
+    (pseudo-atomic (pa-flag)
+      (align-csp temp)
+      (inst or result csp-tn other-pointer-lowtag)
+      (inst addu temp csp-tn (* vector-data-offset n-word-bytes))
+      (inst addu csp-tn bytes)
+      (storew type result 0 other-pointer-lowtag)
+      (storew length result vector-length-slot other-pointer-lowtag)
+      (let ((loop (gen-label)))
+        (emit-label loop)
+        (storew zero-tn temp 0)
+        (inst bne temp csp-tn loop)
+        (inst addu temp n-word-bytes))
+      (align-csp temp))))
+
 (define-vop (allocate-code-object)
   (:args (boxed-arg :scs (any-reg))
          (unboxed-arg :scs (any-reg)))
diff --git a/version.lisp-expr b/version.lisp-expr
index cc4b0df..68858ff 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.23.32"
+"1.0.23.33"