From cb296ae5a022a5b0f1fd573584301b0d2a9493f9 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Mon, 1 Nov 2004 12:35:59 +0000 Subject: [PATCH] 0.8.16.22: Some more changes that can be common to both a widechar sbcl and a narrow one. This patch brought to you by character_branch and shell brace expansion --- src/code/cold-init.lisp | 2 +- src/code/cross-type.lisp | 3 +++ src/code/reader.lisp | 6 +++--- src/code/run-program.lisp | 10 ++++++---- src/code/stream.lisp | 38 +++++++++++++++++++------------------ src/code/target-pathname.lisp | 2 +- src/compiler/alpha/c-call.lisp | 4 +--- src/compiler/alpha/vm.lisp | 10 +++++++--- src/compiler/generic/genesis.lisp | 21 ++++++++++---------- src/compiler/hppa/c-call.lisp | 15 ++++++++++++--- src/compiler/hppa/vm.lisp | 9 +++++++-- src/compiler/mips/c-call.lisp | 15 ++++++++++++--- src/compiler/mips/vm.lisp | 9 +++++++-- src/compiler/ppc/c-call.lisp | 2 +- src/compiler/ppc/vm.lisp | 20 +++++++++++++------ src/compiler/seqtran.lisp | 3 ++- src/compiler/sparc/vm.lisp | 9 +++++++-- src/compiler/x86/c-call.lisp | 2 +- src/compiler/x86/vm.lisp | 8 ++++++-- version.lisp-expr | 2 +- 20 files changed, 123 insertions(+), 67 deletions(-) diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp index 45d3d39..3beb397 100644 --- a/src/code/cold-init.lisp +++ b/src/code/cold-init.lisp @@ -315,7 +315,7 @@ instead (which is another name for the same thing).")) (defun hexstr (thing) (/noshow0 "entering HEXSTR") (let ((addr (get-lisp-obj-address thing)) - (str (make-string 10))) + (str (make-string 10 :element-type 'base-char))) (/noshow0 "ADDR and STR calculated") (setf (char str 0) #\0 (char str 1) #\x) diff --git a/src/code/cross-type.lisp b/src/code/cross-type.lisp index 1aefd7f..47fc196 100644 --- a/src/code/cross-type.lisp +++ b/src/code/cross-type.lisp @@ -82,6 +82,9 @@ 'fixnum) (t 'integer))) + ((subtypep raw-result 'simple-string) + `(simple-base-string ,(length object))) + ((subtypep raw-result 'string) 'base-string) ((some (lambda (type) (subtypep raw-result type)) '(array character list symbol)) raw-result) diff --git a/src/code/reader.lisp b/src/code/reader.lisp index a8081ae..f4352e6 100644 --- a/src/code/reader.lisp +++ b/src/code/reader.lisp @@ -1465,10 +1465,10 @@ (start start) (end (%check-vector-sequence-bounds string start end))) (unless *read-from-string-spares* - (push (internal-make-string-input-stream "" 0 0) - *read-from-string-spares*)) + (push (make-string-input-stream "" 0 0) *read-from-string-spares*)) (let ((stream (pop *read-from-string-spares*))) - (setf (string-input-stream-string stream) string) + (setf (string-input-stream-string stream) + (coerce string '(simple-array character (*)))) (setf (string-input-stream-current stream) start) (setf (string-input-stream-end stream) end) (unwind-protect diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp index e3a1299..cc5a595 100644 --- a/src/code/run-program.lisp +++ b/src/code/run-program.lisp @@ -347,7 +347,9 @@ (declare (simple-string s)) (let ((n (length s))) ;; Blast the string into place. - (sb-kernel:copy-to-system-area (the simple-string s) + (sb-kernel:copy-to-system-area (the simple-base-string + ;; FIXME + (coerce s 'simple-base-string)) (* sb-vm:vector-data-offset sb-vm:n-word-bits) string-sap 0 @@ -615,7 +617,7 @@ ;;; stream. (defun copy-descriptor-to-stream (descriptor stream cookie) (incf (car cookie)) - (let ((string (make-string 256)) + (let ((string (make-string 256 :element-type 'base-char)) handler) (setf handler (sb-sys:add-fd-handler @@ -684,7 +686,7 @@ ;; Use /dev/null. (multiple-value-bind (fd errno) - (sb-unix:unix-open "/dev/null" + (sb-unix:unix-open #.(coerce "/dev/null" 'base-string) (case direction (:input sb-unix:o_rdonly) (:output sb-unix:o_wronly) @@ -736,7 +738,7 @@ (dotimes (count 256 (error "could not open a temporary file in /tmp")) - (let* ((name (format nil "/tmp/.run-program-~D" count)) + (let* ((name (coerce (format nil "/tmp/.run-program-~D" count) 'base-string)) (fd (sb-unix:unix-open name (logior sb-unix:o_rdwr sb-unix:o_creat diff --git a/src/code/stream.lisp b/src/code/stream.lisp index a99b5e3..b33dfb9 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -1233,14 +1233,19 @@ (element-type (string-output-stream-element-type stream)) (result (case element-type - ;; Overwhelmingly common case; can be inlined. + ;; overwhelmingly common case: can be inlined ((character) (make-string length)) + ;; slightly less common cases: inline it anyway + ((base-char standard-char) + (make-string length :element-type 'base-char)) (t (make-string length :element-type element-type))))) ;; For the benefit of the REPLACE transform, let's do this, so ;; that the common case isn't ludicrously expensive. (etypecase result ((simple-array character (*)) (replace result (string-output-stream-string stream))) + (simple-base-string + (replace result (string-output-stream-string stream))) ((simple-array nil (*)) (replace result (string-output-stream-string stream)))) (setf (string-output-stream-index stream) 0 @@ -1263,6 +1268,8 @@ ;;; the CLM, but they are required for the implementation of ;;; WITH-OUTPUT-TO-STRING. +;;; FIXME: need to support (VECTOR BASE-CHAR) and (VECTOR NIL), +;;; ideally without destroying all hope of efficiency. (deftype string-with-fill-pointer () '(and (vector character) (satisfies array-has-fill-pointer-p))) @@ -1292,9 +1299,9 @@ (if (= offset-current end) (let* ((new-length (1+ (* current 2))) (new-workspace (make-string new-length))) - (declare (simple-string new-workspace)) - (%byte-blt workspace start - new-workspace 0 current) + (declare (type (simple-array character (*)) new-workspace)) + (replace new-workspace workspace + :start2 start :end2 offset-current) (setf workspace new-workspace offset-current current) (set-array-header buffer workspace new-length @@ -1322,21 +1329,16 @@ (let* ((new-length (+ (the fixnum (* current 2)) string-len)) (new-workspace (make-string new-length))) (declare (type (simple-array character (*)) new-workspace)) - (%byte-blt workspace dst-start - new-workspace 0 current) - (setf workspace new-workspace) - (setf offset-current current) - (setf offset-dst-end dst-end) - (set-array-header buffer - workspace - new-length - dst-end - 0 - new-length - nil)) + (replace new-workspace workspace + :start2 dst-start :end2 offset-current) + (setf workspace new-workspace + offset-current current + offset-dst-end dst-end) + (set-array-header buffer workspace new-length + dst-end 0 new-length nil)) (setf (fill-pointer buffer) dst-end)) - (%byte-blt string start - workspace offset-current offset-dst-end))) + (replace workspace string + :start1 offset-current :start2 start :end2 end))) dst-end)) (defun fill-pointer-misc (stream operation &optional arg1 arg2) diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp index 6848a57..8c7d5e7 100644 --- a/src/code/target-pathname.lisp +++ b/src/code/target-pathname.lisp @@ -44,7 +44,7 @@ (let ((namestring (handler-case (namestring pathname) (error nil)))) (if namestring - (format stream "#P~S" namestring) + (format stream "#P~S" (coerce namestring '(simple-array character (*)))) (print-unreadable-object (pathname stream :type t) (format stream "~@<(with no namestring) ~_:HOST ~S ~_:DEVICE ~S ~_:DIRECTORY ~S ~ diff --git a/src/compiler/alpha/c-call.lisp b/src/compiler/alpha/c-call.lisp index c82458e..6b3ead7 100644 --- a/src/compiler/alpha/c-call.lisp +++ b/src/compiler/alpha/c-call.lisp @@ -67,8 +67,6 @@ 'single-stack (* 2 (- stack-frame-size 6)))))) - - (define-alien-type-method (integer :result-tn) (type state) (declare (ignore state)) (multiple-value-bind @@ -113,7 +111,7 @@ (:translate foreign-symbol-address) (:policy :fast-safe) (:args) - (:arg-types (:constant simple-base-string)) + (:arg-types (:constant simple-string)) (:info foreign-symbol) (:results (res :scs (sap-reg))) (:result-types system-area-pointer) diff --git a/src/compiler/alpha/vm.lisp b/src/compiler/alpha/vm.lisp index 599c234..7cd45fc 100644 --- a/src/compiler/alpha/vm.lisp +++ b/src/compiler/alpha/vm.lisp @@ -354,6 +354,10 @@ ;;; occure in the symbol table (for example, prepending an ;;; underscore). (defun extern-alien-name (name) - (declare (type simple-base-string name)) - ;; On the Alpha we don't do anything. - name) + (declare (type string name)) + ;; ELF ports currently don't need any prefix + (typecase name + (simple-base-string name) + (base-string (coerce name 'simple-base-string)) + (t (handler-case (coerce name 'simple-base-string) + (type-error () (error "invalid external alien name: ~S" name)))))) diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 57668a8..f9d6614 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -608,9 +608,10 @@ ;;;; copying simple objects into the cold core -(defun string-to-core (string &optional (gspace *dynamic*)) +(defun base-string-to-core (string &optional (gspace *dynamic*)) #!+sb-doc - "Copy string into the cold core and return a descriptor to it." + "Copy STRING (which must only contain STANDARD-CHARs) into the cold +core and return a descriptor to it." ;; (Remember that the system convention for storage of strings leaves an ;; extra null byte at the end to aid in call-out to C.) (let* ((length (length string)) @@ -808,7 +809,7 @@ (make-fixnum-descriptor 0)) (write-wordindexed symbol sb!vm:symbol-plist-slot *nil-descriptor*) (write-wordindexed symbol sb!vm:symbol-name-slot - (string-to-core name *dynamic*)) + (base-string-to-core name *dynamic*)) (write-wordindexed symbol sb!vm:symbol-package-slot *nil-descriptor*) symbol)) @@ -1194,7 +1195,7 @@ ;; because that's the way CMU CL did it; I'm ;; not sure whether there's an underlying ;; reason. -- WHN 1990826 - (string-to-core "NIL" *dynamic*)) + (base-string-to-core "NIL" *dynamic*)) (write-wordindexed des (+ 1 sb!vm:symbol-package-slot) result) @@ -1279,7 +1280,7 @@ (let* ((cold-package (car cold-package-symbols-entry)) (symbols (cdr cold-package-symbols-entry)) (shadows (package-shadowing-symbols cold-package)) - (documentation (string-to-core (documentation cold-package t))) + (documentation (base-string-to-core (documentation cold-package t))) (internal *nil-descriptor*) (external *nil-descriptor*) (imported-internal *nil-descriptor*) @@ -1359,7 +1360,7 @@ (res *nil-descriptor*)) (dolist (u (package-use-list pkg)) (when (assoc u *cold-package-symbols*) - (cold-push (string-to-core (package-name u)) use))) + (cold-push (base-string-to-core (package-name u)) use))) (let* ((pkg-name (package-name pkg)) ;; Make the package nickname lists for the standard packages ;; be the minimum specified by ANSI, regardless of what value @@ -1380,7 +1381,7 @@ (t (package-nicknames pkg))))) (dolist (warm-nickname warm-nicknames) - (cold-push (string-to-core warm-nickname) cold-nicknames))) + (cold-push (base-string-to-core warm-nickname) cold-nicknames))) (cold-push (number-to-core (truncate (package-internal-symbol-count pkg) 0.8)) @@ -1397,7 +1398,7 @@ (cold-push use res) (cold-push (cold-intern :use) res) - (cold-push (string-to-core (package-name pkg)) res) + (cold-push (base-string-to-core (package-name pkg)) res) res)) ;;;; functions and fdefinition objects @@ -1850,7 +1851,7 @@ (defun foreign-symbols-to-core () (let ((result *nil-descriptor*)) (maphash (lambda (symbol value) - (cold-push (cold-cons (string-to-core symbol) + (cold-push (cold-cons (base-string-to-core symbol) (number-to-core value)) result)) *cold-foreign-symbol-table*) @@ -2103,7 +2104,7 @@ (let* ((len (clone-arg)) (string (make-string len))) (read-string-as-bytes *fasl-input-stream* string) - (string-to-core string))) + (base-string-to-core string))) (clone-cold-fop (fop-vector) (fop-small-vector) diff --git a/src/compiler/hppa/c-call.lisp b/src/compiler/hppa/c-call.lisp index 68dd40f..0d83e19 100644 --- a/src/compiler/hppa/c-call.lisp +++ b/src/compiler/hppa/c-call.lisp @@ -1,3 +1,14 @@ +;;;; VOPs and other machine-specific support routines for call-out to C + +;;;; 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") (defun my-make-wired-tn (prim-type-name sc-name offset) @@ -101,12 +112,11 @@ :result-tn (alien-fun-type-result-type type))))) - (define-vop (foreign-symbol-address) (:translate foreign-symbol-address) (:policy :fast-safe) (:args) - (:arg-types (:constant simple-base-string)) + (:arg-types (:constant simple-string)) (:info foreign-symbol) (:results (res :scs (sap-reg))) (:result-types system-area-pointer) @@ -136,7 +146,6 @@ (when cur-nfp (load-stack-tn cur-nfp nfp-save))))) - (define-vop (alloc-number-stack-space) (:info amount) (:results (result :scs (sap-reg any-reg))) diff --git a/src/compiler/hppa/vm.lisp b/src/compiler/hppa/vm.lisp index 128d75f..e80187c 100644 --- a/src/compiler/hppa/vm.lisp +++ b/src/compiler/hppa/vm.lisp @@ -350,5 +350,10 @@ ;;; occure in the symbol table (for example, prepending an ;;; underscore). On the HPPA we just leave it alone. (defun extern-alien-name (name) - (declare (type simple-base-string name)) - name) + (declare (type string name)) + ;; ELF ports currently don't need any prefix + (typecase name + (simple-base-string name) + (base-string (coerce name 'simple-base-string)) + (t (handler-case (coerce name 'simple-base-string) + (type-error () (error "invalid external alien name: ~S" name)))))) diff --git a/src/compiler/mips/c-call.lisp b/src/compiler/mips/c-call.lisp index c37991e..cef3b3b 100644 --- a/src/compiler/mips/c-call.lisp +++ b/src/compiler/mips/c-call.lisp @@ -1,3 +1,14 @@ +;;;; VOPs and other machine-specific support routines for call-out to C + +;;;; 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") (defun my-make-wired-tn (prim-type-name sc-name offset) @@ -76,7 +87,6 @@ 'single-int-carg-reg (+ stack-frame-size 4)))))) - (defstruct result-state (num-results 0)) @@ -133,12 +143,11 @@ (alien-fun-type-result-type type) (make-result-state)))))) - (define-vop (foreign-symbol-address) (:translate foreign-symbol-address) (:policy :fast-safe) (:args) - (:arg-types (:constant simple-base-string)) + (:arg-types (:constant simple-string)) (:info foreign-symbol) (:results (res :scs (sap-reg))) (:result-types system-area-pointer) diff --git a/src/compiler/mips/vm.lisp b/src/compiler/mips/vm.lisp index 321161b..6d37198 100644 --- a/src/compiler/mips/vm.lisp +++ b/src/compiler/mips/vm.lisp @@ -352,5 +352,10 @@ (immediate-constant "Immed")))) (defun extern-alien-name (name) - (declare (type simple-base-string name)) - name) + (declare (type string name)) + ;; ELF ports currently don't need any prefix + (typecase name + (simple-base-string name) + (base-string (coerce name 'simple-base-string)) + (t (handler-case (coerce name 'simple-base-string) + (type-error () (error "invalid external alien name: ~S" name)))))) diff --git a/src/compiler/ppc/c-call.lisp b/src/compiler/ppc/c-call.lisp index 15cf2c1..d14fe07 100644 --- a/src/compiler/ppc/c-call.lisp +++ b/src/compiler/ppc/c-call.lisp @@ -303,7 +303,7 @@ (:translate foreign-symbol-address) (:policy :fast-safe) (:args) - (:arg-types (:constant simple-base-string)) + (:arg-types (:constant simple-string)) (:info foreign-symbol) (:results (res :scs (sap-reg))) (:result-types system-area-pointer) diff --git a/src/compiler/ppc/vm.lisp b/src/compiler/ppc/vm.lisp index a8ab042..dbc2fa3 100644 --- a/src/compiler/ppc/vm.lisp +++ b/src/compiler/ppc/vm.lisp @@ -332,11 +332,19 @@ (immediate-constant "Immed")))) ;;; The loader uses this to convert alien names to the form they -;;; occur in the symbol table. This is ELF, so do nothing. +;;; occur in the symbol table. (defun extern-alien-name (name) - (declare (type simple-base-string name)) - ;; Darwin is non-ELF, and needs a _ prefix - #!+darwin (concatenate 'string "_" name) - ;; The other (ELF) ports currently don't need any prefix - #!-darwin name) + (declare (type string name)) + ;; Darwin is non-ELF, and needs a _ prefix. The other (ELF) ports + ;; currently don't need any prefix. + (flet ((maybe-prefix (name) + #!+darwin (concatenate 'simple-base-string "_" name) + #!-darwin name)) + (typecase name + (simple-base-string (maybe-prefix name)) + (base-string (coerce (maybe-prefix name) 'simple-base-string)) + (t + (handler-case (coerce (maybe-prefix name) 'simple-base-string) + (type-error () + (error "invalid external alien name: ~S" name))))))) diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 8b0215a..b1fb39d 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -771,7 +771,8 @@ (declare (ignore rtype)) (let* (,@lets (res (make-string (truncate (the index (+ ,@all-lengths)) - sb!vm:n-byte-bits)))) + sb!vm:n-byte-bits) + :element-type 'base-char))) (declare (type index ,@all-lengths)) (let (,@(mapcar (lambda (name) `(,name 0)) starts)) (declare (type index ,@starts)) diff --git a/src/compiler/sparc/vm.lisp b/src/compiler/sparc/vm.lisp index 53f89cf..a315d90 100644 --- a/src/compiler/sparc/vm.lisp +++ b/src/compiler/sparc/vm.lisp @@ -372,5 +372,10 @@ ;;; occure in the symbol table (for example, prepending an ;;; underscore). On the SPARC, we don't prepend an underscore. (defun extern-alien-name (name) - (declare (type simple-base-string name)) - (concatenate 'string #+nil "_" name)) + (declare (type string name)) + ;; ELF ports currently don't need any prefix + (typecase name + (simple-base-string name) + (base-string (coerce name 'simple-base-string)) + (t (handler-case (coerce name 'simple-base-string) + (type-error () (error "invalid external alien name: ~S" name)))))) diff --git a/src/compiler/x86/c-call.lisp b/src/compiler/x86/c-call.lisp index 3c954f5..0672d53 100644 --- a/src/compiler/x86/c-call.lisp +++ b/src/compiler/x86/c-call.lisp @@ -185,7 +185,7 @@ (:translate foreign-symbol-address) (:policy :fast-safe) (:args) - (:arg-types (:constant simple-base-string)) + (:arg-types (:constant simple-string)) (:info foreign-symbol) (:results (res :scs (sap-reg))) (:result-types system-area-pointer) diff --git a/src/compiler/x86/vm.lisp b/src/compiler/x86/vm.lisp index 2839abb..48fc7ad 100644 --- a/src/compiler/x86/vm.lisp +++ b/src/compiler/x86/vm.lisp @@ -450,6 +450,10 @@ ;;; The loader uses this to convert alien names to the form they need in ;;; the symbol table (for example, prepending an underscore). (defun extern-alien-name (name) - (declare (type simple-base-string name)) + (declare (type string name)) ;; ELF ports currently don't need any prefix - name) + (typecase name + (simple-base-string name) + (base-string (coerce name 'simple-base-string)) + (t (handler-case (coerce name 'simple-base-string) + (type-error () (error "invalid external alien name: ~S" name)))))) diff --git a/version.lisp-expr b/version.lisp-expr index 36d6358..3a3df16 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".) -"0.8.16.21" +"0.8.16.22" -- 1.7.10.4