Steel Bank Common Lisp

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv6783

Modified Files:
	build-order.lisp-expr package-data-list.lisp-expr 
	version.lisp-expr 
Log Message:
0.9.0.30: towards callbacks: static-vectors
 * SB-INT:MAKE-STATIC-VECTOR allows direct allocation of specialized
    vectors to static space. This is eventually destined to become
    SB-EXT:MAKE-STATIC-ARRAY, but needs more frills before that --
    current setup is enough to support callbacks (and a bit more then 
    that).
 * unrelated defrobnification, s/&rest/&body/ in a few places, and
    commentary on cunning punning.


Index: build-order.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/build-order.lisp-expr,v
retrieving revision 1.49
retrieving revision 1.50
diff -u -d -r1.49 -r1.50
--- build-order.lisp-expr	9 Apr 2005 06:37:02 -0000	1.49
+++ build-order.lisp-expr	13 May 2005 18:30:44 -0000	1.50
@@ -635,6 +635,7 @@
  ("src/code/save"              :not-host) ; uses the definition of PATHNAME
                                           ;   from "code/pathname"
  ("src/code/sharpm"            :not-host) ; uses stuff from "code/reader"
+ ("src/code/alloc"             :not-host)
 
  #!+sb-thread
  ("src/code/target-thread"     :not-host)

Index: package-data-list.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/package-data-list.lisp-expr,v
retrieving revision 1.315
retrieving revision 1.316
diff -u -d -r1.315 -r1.316
--- package-data-list.lisp-expr	8 Apr 2005 12:30:16 -0000	1.315
+++ package-data-list.lisp-expr	13 May 2005 18:30:44 -0000	1.316
@@ -790,10 +790,10 @@
 	       ;; error-reporting facilities
 	       "ENCAPSULATED-CONDITION" "COMPILED-PROGRAM-ERROR"
 	       "SIMPLE-CONTROL-ERROR" "SIMPLE-FILE-ERROR"
-	       "SIMPLE-PARSE-ERROR"
-	       "SIMPLE-PROGRAM-ERROR" "SIMPLE-STREAM-ERROR"
-
+	       "SIMPLE-PARSE-ERROR" "SIMPLE-PROGRAM-ERROR" 
+	       "SIMPLE-STREAM-ERROR" "SIMPLE-STORAGE-CONDITION"
 	       "SIMPLE-STYLE-WARNING"
+
 	       "SPECIAL-FORM-FUNCTION"
 	       "STYLE-WARN" "SIMPLE-COMPILER-NOTE"
 
@@ -966,6 +966,9 @@
 	       ;; need it:
 	       "*EOF-OBJECT*"
 
+	       ;; allocation to static space
+	       "MAKE-STATIC-VECTOR"
+
 	       ;; alien interface utilities
 	       "C-STRINGS->STRING-LIST"
 
@@ -1131,7 +1134,8 @@
                "WORD-LOGICAL-OR" "WORD-LOGICAL-ORC1" "WORD-LOGICAL-ORC2"
                "WORD-LOGICAL-XOR" "ALIEN-TYPE-TYPE"
                "ALIEN-TYPE-TYPE-ALIEN-TYPE" "ALIEN-TYPE-TYPE-P"
-               "ALLOCATE-VECTOR" "ASSERT-SYMBOL-HOME-PACKAGE-UNLOCKED"
+               "ALLOCATE-VECTOR" "ALLOCATE-STATIC-VECTOR"
+	       "ASSERT-SYMBOL-HOME-PACKAGE-UNLOCKED"
                "COMPILER-ASSERT-SYMBOL-HOME-PACKAGE-UNLOCKED"
                "DISABLED-PACKAGE-LOCKS"
                "WITH-SINGLE-PACKAGE-LOCKED-ERROR"

Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.2132
retrieving revision 1.2133
diff -u -d -r1.2132 -r1.2133
--- version.lisp-expr	12 May 2005 21:47:12 -0000	1.2132
+++ version.lisp-expr	13 May 2005 18:30:44 -0000	1.2133
@@ -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".)
-"0.9.0.29"
+"0.9.0.30"

Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv6783/src/code

Modified Files:
	array.lisp condition.lisp sysmacs.lisp 
Added Files:
	alloc.lisp 
Log Message:
0.9.0.30: towards callbacks: static-vectors
 * SB-INT:MAKE-STATIC-VECTOR allows direct allocation of specialized
    vectors to static space. This is eventually destined to become
    SB-EXT:MAKE-STATIC-ARRAY, but needs more frills before that --
    current setup is enough to support callbacks (and a bit more then 
    that).
 * unrelated defrobnification, s/&rest/&body/ in a few places, and
    commentary on cunning punning.


--- NEW FILE: alloc.lisp ---
;;;; Lisp-side allocation (used currently only for direct allocation
;;;; to static space).

;;;; 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")

#!-sb-fluid (declaim (inline store-word))
(defun store-word (word base &optional (offset 0) (lowtag 0))
  (declare (type (unsigned-byte #.sb!vm:n-word-bits) word base offset)
	   (type (unsigned-byte #.n-lowtag-bits) lowtag))
  (setf (sap-ref-word (int-sap base) (- (ash offset word-shift) lowtag)) word))

(defun allocate-static-vector (widetag length words)
  (declare (type (unsigned-byte #.n-widetag-bits) widetag)
	   (type (unsigned-byte #.n-word-bits) words)
	   (type index length))
  (handler-case
      ;; FIXME: Is WITHOUT-GCING enough to do lisp-side allocation
      ;; to static space, or should we have WITHOUT-INTERRUPTS here
      ;; as well?
      (without-gcing
	(let* ((pointer *static-space-free-pointer*) ; in words
	       (free (* pointer n-word-bytes))
	       (vector (logior free other-pointer-lowtag)) ; in bytes, yay
	       ;; rounded to dual word boundary
	       (nwords (logandc2 (+ lowtag-mask (+ words vector-data-offset 1))
				 lowtag-mask))
	       (new-pointer (+ *static-space-free-pointer* nwords))
	       (new-free (* new-pointer n-word-bytes)))
	  (unless (> static-space-end new-free)
	    (error 'simple-storage-condition
		   :format-control "Not enough memory left in static space to ~
                                   allocate vector."))
	  (store-word widetag 
		      vector 0 other-pointer-lowtag)
	  (store-word (ash length word-shift)
		      vector vector-length-slot other-pointer-lowtag)
	  (store-word 0 new-free)
	  (prog1
	      (make-lisp-obj vector)
	    (setf *static-space-free-pointer* new-pointer))))
    (serious-condition (c)
      ;; unwind from WITHOUT-GCING
      (error c))))

  
Index: array.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/array.lisp,v
retrieving revision 1.49
retrieving revision 1.50
diff -u -d -r1.49 -r1.50
--- array.lisp	10 Feb 2005 04:23:12 -0000	1.49
+++ array.lisp	13 May 2005 18:30:45 -0000	1.50
@@ -160,7 +160,7 @@
 			 type
 			 length
 			 (ceiling
-                          (* (if (or (= type sb!vm:simple-base-string-widetag)
+			  (* (if (or (= type sb!vm:simple-base-string-widetag)
                                      #!+sb-unicode
                                      (= type
                                         sb!vm:simple-character-string-widetag))
@@ -235,6 +235,51 @@
 	      (incf axis)))
 	  array))))
 
+(defun make-static-vector (length &key 
+			   (element-type '(unsigned-byte 8))
+			   (initial-contents nil initial-contents-p)
+			   (initial-element nil initial-element-p))
+  "Allocate vector of LENGTH elements in static space. Only allocation
+of specialized arrays is supported."
+  ;; STEP 1: check inputs fully
+  ;;
+  ;; This way of doing explicit checks before the vector is allocated
+  ;; is expensive, but probably worth the trouble as once we've allocated
+  ;; the vector we have no way to get rid of it anymore... 
+  (when (eq t (upgraded-array-element-type element-type))
+    (error "Static arrays of type ~S not supported." 
+	   element-type))
+  (when initial-contents-p
+    (when initial-element-p
+      (error "can't specify both :INITIAL-ELEMENT and :INITIAL-CONTENTS"))
+    (unless (= length (length initial-contents))
+      (error "There are ~W elements in the :INITIAL-CONTENTS, but the ~
+              vector length is ~W."
+	     (length initial-contents)
+	     length))
+    (unless (every (lambda (x) (typep x element-type)) initial-contents)
+      (error ":INITIAL-CONTENTS contains elements not of type ~S."
+	     element-type)))
+  (when initial-element-p
+    (unless (typep initial-element element-type)
+      (error ":INITIAL-ELEMENT ~S is not of type ~S." 
+	     initial-element element-type)))
+  ;; STEP 2
+  ;;
+  ;; Allocate and possibly initialize the vector.
+  (multiple-value-bind (type n-bits)
+      (sb!impl::%vector-widetag-and-n-bits element-type)
+    (let ((vector 
+	   (allocate-static-vector type length
+				   (ceiling (* length n-bits) 
+					    sb!vm:n-word-bits))))
+      (cond (initial-element-p
+	     (fill vector initial-element))
+	    (initial-contents-p
+	     (replace vector initial-contents))
+	    (t
+	     vector)))))
+
 ;;; DATA-VECTOR-FROM-INITS returns a simple vector that has the
 ;;; specified array characteristics. Dimensions is only used to pass
 ;;; to FILL-DATA-VECTOR for error checking on the structure of

Index: condition.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/condition.lisp,v
retrieving revision 1.60
retrieving revision 1.61
diff -u -d -r1.60 -r1.61
--- condition.lisp	22 Feb 2005 10:34:51 -0000	1.60
+++ condition.lisp	13 May 2005 18:30:46 -0000	1.61
@@ -775,6 +775,8 @@
               <http://sbcl.sourceforge.net/>.~:@>"
 	     '((fmakunbound 'compile))))))
 
+(define-condition simple-storage-condition (storage-condition simple-condition) ())
+
 ;;; a condition for use in stubs for operations which aren't supported
 ;;; on some platforms
 ;;;

Index: sysmacs.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/sysmacs.lisp,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -d -r1.19 -r1.20
--- sysmacs.lisp	29 Apr 2005 14:37:37 -0000	1.19
+++ sysmacs.lisp	13 May 2005 18:30:46 -0000	1.20
@@ -23,7 +23,7 @@
 (declaim (type index *gc-inhibit*))
 (defvar *gc-inhibit*) ; initialized in cold init
 
-(defmacro without-gcing (&rest body)
+(defmacro without-gcing (&body body)
   #!+sb-doc
   "Executes the forms in the body without doing a garbage collection."
   `(unwind-protect

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

Modified Files:
	macros.lisp 
Log Message:
0.9.0.30: towards callbacks: static-vectors
 * SB-INT:MAKE-STATIC-VECTOR allows direct allocation of specialized
    vectors to static space. This is eventually destined to become
    SB-EXT:MAKE-STATIC-ARRAY, but needs more frills before that --
    current setup is enough to support callbacks (and a bit more then 
    that).
 * unrelated defrobnification, s/&rest/&body/ in a few places, and
    commentary on cunning punning.


Index: macros.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/sparc/macros.lisp,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -d -r1.10 -r1.11
--- macros.lisp	6 May 2005 18:58:37 -0000	1.10
+++ macros.lisp	13 May 2005 18:30:46 -0000	1.11
@@ -21,11 +21,11 @@
        (inst move ,n-dst ,n-src))))
 
 (macrolet
-    ((frob (op inst shift)
+    ((def (op inst shift)
        `(defmacro ,op (object base &optional (offset 0) (lowtag 0))
 	  `(inst ,',inst ,object ,base (- (ash ,offset ,,shift) ,lowtag)))))
-  (frob loadw ld word-shift)
-  (frob storew st word-shift))
+  (def loadw ld word-shift)
+  (def storew st word-shift))
 
 (defmacro load-symbol (reg symbol)
   `(inst add ,reg null-tn (static-symbol-offset ,symbol)))

Update of /cvsroot/sbcl/sbcl/src/assembly/sparc
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv6783/src/assembly/sparc

Modified Files:
	array.lisp 
Log Message:
0.9.0.30: towards callbacks: static-vectors
 * SB-INT:MAKE-STATIC-VECTOR allows direct allocation of specialized
    vectors to static space. This is eventually destined to become
    SB-EXT:MAKE-STATIC-ARRAY, but needs more frills before that --
    current setup is enough to support callbacks (and a bit more then 
    that).
 * unrelated defrobnification, s/&rest/&body/ in a few places, and
    commentary on cunning punning.


Index: array.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/assembly/sparc/array.lisp,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -d -r1.2 -r1.3
--- array.lisp	6 Sep 2003 11:03:21 -0000	1.2
+++ array.lisp	13 May 2005 18:30:45 -0000	1.3
@@ -26,6 +26,7 @@
 			  (:temp vector descriptor-reg a3-offset))
   (pseudo-atomic ()
     (inst or vector alloc-tn other-pointer-lowtag)
+    ;; boxed words == unboxed bytes
     (inst add ndescr words (* (1+ vector-data-offset) n-word-bytes))
     (inst andn ndescr 7)
     (inst add alloc-tn ndescr)

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

Modified Files:
	macros.lisp 
Log Message:
0.9.0.30: towards callbacks: static-vectors
 * SB-INT:MAKE-STATIC-VECTOR allows direct allocation of specialized
    vectors to static space. This is eventually destined to become
    SB-EXT:MAKE-STATIC-ARRAY, but needs more frills before that --
    current setup is enough to support callbacks (and a bit more then 
    that).
 * unrelated defrobnification, s/&rest/&body/ in a few places, and
    commentary on cunning punning.


Index: macros.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ppc/macros.lisp,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -d -r1.8 -r1.9
--- macros.lisp	6 May 2005 18:58:37 -0000	1.8
+++ macros.lisp	13 May 2005 18:30:46 -0000	1.9
@@ -21,11 +21,11 @@
        (inst mr ,n-dst ,n-src))))
 
 (macrolet
-    ((frob (op inst shift)
+    ((def (op inst shift)
        `(defmacro ,op (object base &optional (offset 0) (lowtag 0))
 	  `(inst ,',inst ,object ,base (- (ash ,offset ,,shift) ,lowtag)))))
-  (frob loadw lwz word-shift)
-  (frob storew stw word-shift))
+  (def loadw lwz word-shift)
+  (def storew stw word-shift))
 
 (defmacro load-symbol (reg symbol)
   `(inst addi ,reg null-tn (static-symbol-offset ,symbol)))
@@ -218,7 +218,7 @@
 ;;; aligns ALLOC-TN again and (b) makes ALLOC-TN go negative. We then
 ;;; trap if ALLOC-TN's negative (handling the deferred interrupt) and
 ;;; using FLAG-TN - minus the large constant - to correct ALLOC-TN.
-(defmacro pseudo-atomic ((flag-tn &key (extra 0)) &rest forms)
+(defmacro pseudo-atomic ((flag-tn &key (extra 0)) &body forms)
   (let ((n-extra (gensym)))
     `(let ((,n-extra ,extra))
        (without-scheduling ()

Update of /cvsroot/sbcl/sbcl/tests
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv6783/tests

Added Files:
	static-alloc.impure.lisp 
Log Message:
0.9.0.30: towards callbacks: static-vectors
 * SB-INT:MAKE-STATIC-VECTOR allows direct allocation of specialized
    vectors to static space. This is eventually destined to become
    SB-EXT:MAKE-STATIC-ARRAY, but needs more frills before that --
    current setup is enough to support callbacks (and a bit more then 
    that).
 * unrelated defrobnification, s/&rest/&body/ in a few places, and
    commentary on cunning punning.


--- NEW FILE: static-alloc.impure.lisp ---

(dolist (type '(single-float double-float (unsigned-byte 8)
		(unsigned-byte 32) (signed-byte 32)))
  (let* ((vectors (loop 
		     for i upto 1024
		     collect (sb-int:make-static-vector
			      256 :element-type type)))
	 (saps (mapcar #'sb-sys:vector-sap vectors)))
    (gc :full t)
    (assert (every #'sb-sys:sap=
		   saps
		   (mapcar #'sb-sys:vector-sap vectors)))))

(quit :unix-status 104)

Update of /cvsroot/sbcl/sbcl/src/assembly/ppc
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv6783/src/assembly/ppc

Modified Files:
	array.lisp 
Log Message:
0.9.0.30: towards callbacks: static-vectors
 * SB-INT:MAKE-STATIC-VECTOR allows direct allocation of specialized
    vectors to static space. This is eventually destined to become
    SB-EXT:MAKE-STATIC-ARRAY, but needs more frills before that --
    current setup is enough to support callbacks (and a bit more then 
    that).
 * unrelated defrobnification, s/&rest/&body/ in a few places, and
    commentary on cunning punning.


Index: array.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/assembly/ppc/array.lisp,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -d -r1.4 -r1.5
--- array.lisp	12 Apr 2005 20:14:48 -0000	1.4
+++ array.lisp	13 May 2005 18:30:45 -0000	1.5
@@ -18,23 +18,25 @@
 			  (: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 nl3-offset)
-			  (:temp vector descriptor-reg a3-offset))
+    ((: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 nl3-offset)
+     (:temp vector descriptor-reg a3-offset))
   (pseudo-atomic (pa-flag)
-    (inst ori vector alloc-tn sb!vm:other-pointer-lowtag)
-    (inst addi ndescr words (* (1+ sb!vm:vector-data-offset) sb!vm:n-word-bytes))
+    (inst ori vector alloc-tn other-pointer-lowtag)
+    ;; boxed words == unboxed bytes
+    (inst addi ndescr words (* (1+ vector-data-offset) n-word-bytes))
     (inst clrrwi ndescr ndescr n-lowtag-bits)
     (inst add alloc-tn alloc-tn ndescr)
-    (inst srwi ndescr type sb!vm:word-shift)
-    (storew ndescr vector 0 sb!vm:other-pointer-lowtag)
-    (storew length vector sb!vm:vector-length-slot sb!vm:other-pointer-lowtag))
+    (inst srwi ndescr type word-shift)
+    (storew ndescr vector 0 other-pointer-lowtag)
+    (storew length vector vector-length-slot other-pointer-lowtag))
   ;; This makes sure the zero byte at the end of a string is paged in so
   ;; the kernel doesn't bitch if we pass it the string.
   (storew zero-tn alloc-tn 0)
   (move result vector))
+