From: William Harold Newman Date: Wed, 16 Jan 2002 20:31:48 +0000 (+0000) Subject: 0.pre7.138: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=9a241987c408980164f71237f7d840265302bbc1;p=sbcl.git 0.pre7.138: merged CSR "{find,position}-if-not" patch from sbcl-devel 2002-01-15 tweaked %NATURALIZE-C-STRING to reduce the ridiculous consing (reported on cmucl-imp ca. 2002-01-15 by Lynn Quam) in the reinvent-the-strlen() code added assertion in GENESIS to try to catch "SB!"-vs.-"SB-" prefix mistakes in code it works with --- diff --git a/BUGS b/BUGS index 081092a..6a51487 100644 --- a/BUGS +++ b/BUGS @@ -1222,6 +1222,12 @@ Error in function C::GET-LAMBDA-TO-COMPILE: * (lisp-implementation-version) "0.pre7.129" +142: + (as reported by Lynn Quam on cmucl-imp ca. 2002-01-16) + %NATURALIZE-C-STRING conses a lot, like 16 bytes per byte + of the naturalized string. We could probably port the patches + from the cmucl-imp mailing list. + KNOWN BUGS RELATED TO THE IR1 INTERPRETER diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 3cf97ac..4829f4c 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -903,6 +903,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "%DOUBLE-FLOAT" "%DPB" "%EXP" "%EXPM1" "%FIND-POSITION" "%FIND-POSITION-VECTOR-MACRO" "%FIND-POSITION-IF" "%FIND-POSITION-IF-VECTOR-MACRO" + "%FIND-POSITION-IF-NOT" "%FIND-POSITION-IF-NOT-VECTOR-MACRO" "%FUN-DOC" "%FUN-NAME" "%HYPOT" "%LDB" "%LOG" "%LOGB" "%LOG10" "%LOG1P" "%LONG-FLOAT" diff --git a/src/code/seq.lisp b/src/code/seq.lisp index fbb59c6..adf36db 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -1910,6 +1910,14 @@ (vector*-frob (sequence) `(%find-position-if-vector-macro predicate ,sequence from-end start end key))) + (frobs))) + (defun %find-position-if-not (predicate sequence-arg from-end start end key) + (macrolet ((frob (sequence from-end) + `(%find-position-if-not predicate ,sequence + ,from-end start end key)) + (vector*-frob (sequence) + `(%find-position-if-not-vector-macro predicate ,sequence + from-end start end key))) (frobs)))) ;;; the user interface to FIND and POSITION: Get all our ducks in a @@ -1956,11 +1964,10 @@ (def-find-position-if find-if 0) (def-find-position-if position-if 1)) -;;; the deprecated functions FIND-IF-NOT and POSITION-IF-NOT. We don't -;;; bother to worry about optimizing them. -;;; -;;; (Except note that on Sat, Oct 06, 2001 at 04:22:38PM +0100, -;;; Christophe Rhodes wrote on sbcl-devel +;;; the deprecated functions FIND-IF-NOT and POSITION-IF-NOT. We +;;; didn't bother to worry about optimizing them, except note that on +;;; Sat, Oct 06, 2001 at 04:22:38PM +0100, Christophe Rhodes wrote on +;;; sbcl-devel ;;; ;;; My understanding is that while the :test-not argument is ;;; deprecated in favour of :test (complement #'foo) because of @@ -1981,18 +1988,19 @@ ;;; ;;; FIXME: Remove uses of these deprecated functions (and of :TEST-NOT ;;; too) within the implementation of SBCL. +(declaim (inline find-if-not position-if-not)) (macrolet ((def-find-position-if-not (fun-name values-index) `(defun ,fun-name (predicate sequence &key from-end (start 0) end key) (nth-value ,values-index - (%find-position-if (complement (%coerce-callable-to-fun - predicate)) - sequence - from-end - start - end - (effective-find-position-key key)))))) + (%find-position-if-not (%coerce-callable-to-fun predicate) + sequence + from-end + start + end + (effective-find-position-key key)))))) + (def-find-position-if-not find-if-not 0) (def-find-position-if-not position-if-not 1)) diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp index 3150c14..deaff2c 100644 --- a/src/code/target-alieneval.lisp +++ b/src/code/target-alieneval.lisp @@ -195,7 +195,7 @@ (let ((alien-type (parse-alien-type type env))) (if (eq (compute-alien-rep-type alien-type) 'system-area-pointer) `(%sap-alien ,sap ',alien-type) - (error "cannot make aliens of type ~S out of SAPs" type)))) + (error "cannot make an alien of type ~S out of a SAP" type)))) (defun %sap-alien (sap type) (declare (type system-area-pointer sap) diff --git a/src/code/target-c-call.lisp b/src/code/target-c-call.lisp index 38b4cd1..4b70eaf 100644 --- a/src/code/target-c-call.lisp +++ b/src/code/target-c-call.lisp @@ -30,18 +30,17 @@ (define-alien-type-translator void () (parse-alien-type '(values) (sb!kernel:make-null-lexenv))) +#+nil +(define-alien-routine strlen integer + (s (* char))) + (defun %naturalize-c-string (sap) (declare (type system-area-pointer sap)) (with-alien ((ptr (* char) sap)) - (locally - (declare (optimize (speed 3) (safety 0))) - (let ((length (loop - for offset of-type fixnum upfrom 0 - until (zerop (deref ptr offset)) - finally (return offset)))) - (let ((result (make-string length))) - (sb!kernel:copy-from-system-area (alien-sap ptr) 0 - result (* sb!vm:vector-data-offset - sb!vm:n-word-bits) - (* length sb!vm:n-byte-bits)) - result))))) + (let* ((length (alien-funcall (extern-alien "strlen" + (function integer (* char))) + ptr)) + (result (make-string length))) + (declare (optimize (speed 3) (safety 0))) + (sb!kernel:%byte-blt sap 0 result 0 length) + result))) diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 72bab46..8a148a1 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -1304,7 +1304,7 @@ (t sequence t index sequence-end function function) (values t (or index null)) (flushable call)) -(defknown %find-position-if +(defknown (%find-position-if %find-position-if-not) (function sequence t index sequence-end function) (values t (or index null)) (call)) diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 2a19595..8fa8d50 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -1013,7 +1013,7 @@ (defun cold-intern (symbol &optional (package (symbol-package symbol))) ;; Anything on the cross-compilation host which refers to the target - ;; machinery through the host SB-XC package can be translated to + ;; machinery through the host SB-XC package should be translated to ;; something on the target which refers to the same machinery ;; through the target COMMON-LISP package. (let ((p (find-package "SB-XC"))) @@ -1022,6 +1022,25 @@ (when (eq (symbol-package symbol) p) (setf symbol (intern (symbol-name symbol) *cl-package*)))) + ;; Make sure that the symbol has an appropriate package. In + ;; particular, catch the so-easy-to-make error of typing something + ;; like SB-KERNEL:%BYTE-BLT in cold sources when what you really + ;; need is SB!KERNEL:%BYTE-BLT. + (let ((package-name (package-name package))) + (cond ((find package-name '("COMMON-LISP" "KEYWORD") :test #'string=) + ;; That's OK then. + (values)) + ((string= package-name "SB!" :end1 3 :end2 3) + ;; That looks OK, too. (All the target-code packages + ;; have names like that.) + (values)) + (t + ;; looks bad: maybe COMMON-LISP-USER? maybe an extension + ;; package in the xc host? something we can't think of + ;; a valid reason to dump, anyway... + (error "internal error: PACKAGE-NAME=~S looks too much like a typo." + package-name)))) + (let (;; Information about each cold-interned symbol is stored ;; in COLD-INTERN-INFO. ;; (CAR COLD-INTERN-INFO) = descriptor of symbol diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 71416a0..96d47e9 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -704,41 +704,48 @@ (give-up-ir1-transform "sequence type not known at compile time"))))) -;;; %FIND-POSITION-IF for LIST data -(deftransform %find-position-if ((predicate sequence from-end start end key) - (function list t t t function) - * - :policy (> speed space) - :important t) - "expand inline" - '(let ((index 0) - (find nil) - (position nil)) - (declare (type index index)) - (dolist (i sequence (values find position)) - (let ((key-i (funcall key i))) - (when (and end (>= index end)) - (return (values find position))) - (when (>= index start) - (when (funcall predicate key-i) - ;; This hack of dealing with non-NIL FROM-END for list - ;; data by iterating forward through the list and keeping - ;; track of the last time we found a match might be more - ;; screwy than what the user expects, but it seems to be - ;; allowed by the ANSI standard. (And if the user is - ;; screwy enough to ask for FROM-END behavior on list - ;; data, turnabout is fair play.) - ;; - ;; It's also not enormously efficient, calling PREDICATE - ;; and KEY more often than necessary; but all the - ;; alternatives seem to have their own efficiency - ;; problems. - (if from-end - (setf find i - position index) - (return (values i index)))))) - (incf index)))) - +;;; %FIND-POSITION-IF and %FIND-POSITION-IF-NOT for LIST data +(macrolet ((def-frob (name condition) + `(deftransform ,name ((predicate sequence from-end start end key) + (function list t t t function) + * + :policy (> speed space) + :important t) + "expand inline" + `(let ((index 0) + (find nil) + (position nil)) + (declare (type index index)) + (dolist (i sequence (values find position)) + (let ((key-i (funcall key i))) + (when (and end (>= index end)) + (return (values find position))) + (when (>= index start) + (,',condition (funcall predicate key-i) + ;; This hack of dealing with non-NIL + ;; FROM-END for list data by iterating + ;; forward through the list and keeping + ;; track of the last time we found a match + ;; might be more screwy than what the user + ;; expects, but it seems to be allowed by + ;; the ANSI standard. (And if the user is + ;; screwy enough to ask for FROM-END + ;; behavior on list data, turnabout is + ;; fair play.) + ;; + ;; It's also not enormously efficient, + ;; calling PREDICATE and KEY more often + ;; than necessary; but all the + ;; alternatives seem to have their own + ;; efficiency problems. + (if from-end + (setf find i + position index) + (return (values i index)))))) + (incf index)))))) + (def-frob %find-position-if when) + (def-frob %find-position-if-not unless)) + ;;; %FIND-POSITION for LIST data can be expanded into %FIND-POSITION-IF ;;; without loss of efficiency. (I.e., the optimizer should be able ;;; to straighten everything out.) @@ -844,7 +851,19 @@ element `(funcall ,predicate (funcall ,key ,element))))) -;;; %FIND-POSITION and %FIND-POSITION-IF for VECTOR data +(def!macro %find-position-if-not-vector-macro (predicate sequence + from-end start end key) + (let ((element (gensym "ELEMENT"))) + (%find-position-or-find-position-if-vector-expansion + sequence + from-end + start + end + element + `(not (funcall ,predicate (funcall ,key ,element)))))) + +;;; %FIND-POSITION, %FIND-POSITION-IF and %FIND-POSITION-IF-NOT for +;;; VECTOR data (deftransform %find-position-if ((predicate sequence from-end start end key) (function vector t t t function) * @@ -854,6 +873,17 @@ (check-inlineability-of-find-position-if sequence from-end) '(%find-position-if-vector-macro predicate sequence from-end start end key)) + +(deftransform %find-position-if-not ((predicate sequence from-end start end key) + (function vector t t t function) + * + :policy (> speed space) + :important t) + "expand inline" + (check-inlineability-of-find-position-if sequence from-end) + '(%find-position-if-not-vector-macro predicate sequence + from-end start end key)) + (deftransform %find-position ((item sequence from-end start end key test) (t vector t t t function function) * diff --git a/src/runtime/ldso-stubs.S b/src/runtime/ldso-stubs.S index 88b8868..35568f2 100644 --- a/src/runtime/ldso-stubs.S +++ b/src/runtime/ldso-stubs.S @@ -2,8 +2,11 @@ * stubs for C-linkage library functions which we need to refer to * from Lisp * - * These exist for the benefit of Lisp code that needs to refer to - * foreign symbols when dlsym() is not available (i.e. when dumping + * (But note this is only the Linux version, as per the FIXME + * note in the BSD version in undefineds.h.) + * + * These stubs exist for the benefit of Lisp code that needs to refer + * to foreign symbols when dlsym() is not available (i.e. when dumping * cold-sbcl.core, when we may be running in a host that's not SBCL, * or on platforms that don't have it at all). If the runtime is * dynamically linked, library functions won't be linked into it, so @@ -140,6 +143,7 @@ ldso_stub__ ## fct: ; \ LDSO_STUBIFY(socket) LDSO_STUBIFY(stat) LDSO_STUBIFY(strerror) + LDSO_STUBIFY(strlen) LDSO_STUBIFY(symlink) LDSO_STUBIFY(sync) LDSO_STUBIFY(tanh) diff --git a/src/runtime/undefineds.h b/src/runtime/undefineds.h index 9283ed5..dc20144 100644 --- a/src/runtime/undefineds.h +++ b/src/runtime/undefineds.h @@ -1,5 +1,21 @@ /* * routines that must be linked into the core for Lisp to work + * + * but note this is only the BSD version, as per the FIXME + * + * FIXME: It's tedious and error-prone having to edit both this file and + * the analogous ldso-stubs.S file when we change the references to + * functions, enough so that it would probably be good to rewrite + * both files in terms of a shared list of function names. + * E.g. the function names could be in shared-function-names.h + * SHARED_FUNCTION(cos) + * SHARED_FUNCTION(sinh) + * SHARED_FUNCTION(strlen) + * etc. and the per-OS files could look like + * #define SHARED_FUNCTION(f) .... + * #include "shared-function-names.h" + * ...then going on to do OS-specific things + * "Once and only once." */ /* @@ -12,7 +28,7 @@ * provided with absolutely no warranty. See the COPYING and CREDITS * files for more information. */ - + /* Pick up all the syscalls. */ F(accept) F(access) @@ -227,6 +243,9 @@ F(sqrt) #endif F(hypot) +/* string things */ +F(strlen) + /* network support */ F(gethostbyname) F(gethostbyaddr) diff --git a/version.lisp-expr b/version.lisp-expr index d22c22c..e90844a 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; for internal versions, especially for internal versions off the ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.pre7.137" +"0.pre7.138"