From 09d7974601df2aaaa820ca576026b9b4f03e6ab1 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Wed, 4 Dec 2002 15:23:00 +0000 Subject: [PATCH] 0.7.10.10: Working INLINE inside MACROLET for user code. (more or less as per CSR sbcl-devel 2002-12-03) ... change tricky cross-compiled inline functions to source transforms (including adding some functions to the function database) ... use now-working FUNCTION-LAMBDA-EXPRESSION to get the expander function for local macros ... build a complex LAMBDA-WITH-LEXENV for inlining user code (like CMUCL's INLINE-SYNTACTIC-CLOSURE-LAMBDA does) Some miscellaneous frobs ... actually signal a style warning for array code (though it might actually be in currently-dead-but-should-be-alive code) ... actually test the return value in the second half of filesys.test.sh ... minor text adjustments (no more calling this period "early 0.7.x") --- BUGS | 2 + NEWS | 2 + TODO | 12 ++--- package-data-list.lisp-expr | 5 +- src/code/defboot.lisp | 32 ++++-------- src/code/numbers.lisp | 27 +++++----- src/code/seq.lisp | 106 +++++++++------------------------------- src/code/sort.lisp | 85 +------------------------------- src/compiler/array-tran.lisp | 6 +-- src/compiler/fndb.lisp | 9 ++++ src/compiler/lexenv.lisp | 94 ++++++++++++++++++++++++++++------- src/compiler/seqtran.lisp | 77 +++++++++++++++++++++++++++++ src/compiler/sparc/system.lisp | 2 + src/compiler/srctran.lisp | 73 +++++++++++++++++++++++++++ tests/compiler.impure.lisp | 21 ++++++++ tests/filesys.test.sh | 5 ++ version.lisp-expr | 2 +- 17 files changed, 329 insertions(+), 231 deletions(-) diff --git a/BUGS b/BUGS index 7cdead5..3c403d6 100644 --- a/BUGS +++ b/BUGS @@ -1040,6 +1040,8 @@ WORKAROUND: lexical environment. b. The body of (EVAL-WHEN (:COMPILE-TOPLEVEL) ...) is evaluated in the null lexical environment. + c. The cross-compiler cannot inline functions defined in a non-null + lexical environment. 206: ":SB-FLUID feature broken" (reported by Antonio Martinez-Shotton sbcl-devel 2002-10-07) diff --git a/NEWS b/NEWS index d1007b2..27cbbca 100644 --- a/NEWS +++ b/NEWS @@ -1436,6 +1436,8 @@ changes in sbcl-0.7.11 relative to sbcl-0.7.10: accessors that are related by inheritance, as specified in the :CONC-NAME section of the specification of DEFSTRUCT. (thanks to Valtteri Vuorikoski) + * the compiler is now able to inline functions that were defined in + a complex lexical environment (e.g. inside a MACROLET). * fixed some more bugs revealed by Paul Dietz' test suite: ** As required by ANSI, LOOP now disallows anonymous collection clauses such as COLLECT I in conjunction with aggregate boolean diff --git a/TODO b/TODO index de0a16e..5dc47f1 100644 --- a/TODO +++ b/TODO @@ -1,11 +1,8 @@ -for early 0.7.x: +for late 0.7.x: -* urgent EVAL/EVAL-WHEN/%COMPILE/DEFUN/DEFSTRUCT cleanup: - ** made inlining DEFUN inside MACROLET work again - ** (also, while working on INLINE anyway, it might be easy - to flush the old MAYBE-INLINE cruft entirely, - including e.g. on the man page) * test file reworking + ** *.pure.lisp tests run with assertoid.lisp loaded; assertoid + is moved to its own package, for use in *.impure.lisp. ** non-x86 ports now pass irrat.pure.lisp ** sparc and ppc now pass bit-vector.impure-cload.lisp * faster bootstrapping (both make.sh and slam.sh) @@ -42,7 +39,8 @@ for early 0.7.x: not quite ready for prime time..) of the system after cold init * fixups now feasible because of pre7 changes - ** ANSIfied DECLAIM INLINE stuff (deprecating MAYBE-INLINE) + ** ANSIfied DECLAIM INLINE stuff (deprecating MAYBE-INLINE, + including e.g. on the man page) * miscellaneous simple refactoring * belated renaming: ** renamed %PRIMITIVE to %VOP diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 4949776..2a7627b 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -239,9 +239,8 @@ of SBCL which maintained the CMU-CL-style split into two packages.)" "IR2-COMPONENT-CONSTANTS" "IR2-CONVERT" "IR2-PHYSENV-NUMBER-STACK-P" "KNOWN-CALL-LOCAL" "KNOWN-RETURN" - "LAMBDA-INDEPENDENT-OF-LEXENV-P" "LAMBDA-WITH-LEXENV" "LEXENV-FIND" - "LOCATION=" "LTN-ANNOTATE" + "LOCATION=" "LTN-ANNOTATE" "MAKE-ALIAS-TN" "MAKE-CATCH-BLOCK" "MAKE-CLOSURE" "MAKE-CONSTANT-TN" "MAKE-FIXNUM" "MAKE-LOAD-TIME-CONSTANT-TN" "MAKE-N-TNS" "MAKE-NORMAL-TN" @@ -249,6 +248,7 @@ of SBCL which maintained the CMU-CL-style split into two packages.)" "MAKE-REPRESENTATION-TN" "MAKE-RESTRICTED-TN" "MAKE-SC-OFFSET" "MAKE-STACK-POINTER-TN" "MAKE-TN-REF" "MAKE-UNWIND-BLOCK" "MAKE-WIRED-TN" "MAYBE-COMPILER-NOTE" + "MAYBE-INLINE-SYNTACTIC-CLOSURE" "META-PRIMITIVE-TYPE-OR-LOSE" "META-SB-OR-LOSE" "META-SC-NUMBER-OR-LOSE" "META-SC-OR-LOSE" "MORE-ARG-CONTEXT" "MOVABLE" "MOVE" "MULTIPLE-CALL" @@ -1037,6 +1037,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "DOUBLE-FLOAT-SIGNIFICAND" "FLOAT-WAIT" "DYNAMIC-SPACE-FREE-POINTER" "DYNAMIC-USAGE" + "EFFECTIVE-FIND-POSITION-TEST" "EFFECTIVE-FIND-POSITION-KEY" "END-TOO-LARGE-ERROR" "ERROR-NUMBER-OR-LOSE" "FAILED-%WITH-ARRAY-DATA" diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index 383c9f3..6e60eaf 100644 --- a/src/code/defboot.lisp +++ b/src/code/defboot.lisp @@ -164,29 +164,15 @@ #-sb-xc-host (named-lambda `(named-lambda ,name ,@lambda-guts)) (inline-lambda - (cond (;; Does the user not even want to inline? - (not (inline-fun-name-p name)) - nil) - (;; Does inlining look too hairy to handle? - (not (sb!c:lambda-independent-of-lexenv-p lambda env)) - (sb!c:maybe-compiler-note - "lexical environment too hairy, can't inline DEFUN ~S" - name) - nil) - (t - ;; FIXME: The only reason that we return - ;; LAMBDA-WITH-LEXENV instead of returning bare - ;; LAMBDA is to avoid modifying downstream code - ;; which expects LAMBDA-WITH-LEXENV. But the code - ;; here is the only code which feeds into the - ;; downstream code, and the generality of the - ;; interface is no longer used, so it'd make sense - ;; to simplify the interface instead of using the - ;; old general LAMBDA-WITH-LEXENV interface in this - ;; simplified way. - `(sb!c:lambda-with-lexenv - nil nil nil ; i.e. no DECLS, no MACROS, no SYMMACS - ,@lambda-guts))))) + (when (inline-fun-name-p name) + ;; we want to attempt to inline, so complain if we can't + (or (sb!c:maybe-inline-syntactic-closure lambda env) + (progn + (#+sb-xc-host warn + #-sb-xc-host sb!c:maybe-compiler-note + "lexical environment too hairy, can't inline DEFUN ~S" + name) + nil))))) `(progn ;; In cross-compilation of toplevel DEFUNs, we arrange diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp index e6ae297..b298f9f 100644 --- a/src/code/numbers.lisp +++ b/src/code/numbers.lisp @@ -685,19 +685,20 @@ (+ rem divisor) rem))) -(macrolet ((def (name op doc) - `(defun ,name (number &optional (divisor 1)) - ,doc - (multiple-value-bind (res rem) (,op number divisor) - (values (float res (if (floatp rem) rem 1.0)) rem))))) - (def ffloor floor - "Same as FLOOR, but returns first value as a float.") - (def fceiling ceiling - "Same as CEILING, but returns first value as a float." ) - (def ftruncate truncate - "Same as TRUNCATE, but returns first value as a float.") - (def fround round - "Same as ROUND, but returns first value as a float.")) +(defmacro !define-float-rounding-function (name op doc) + `(defun ,name (number &optional (divisor 1)) + ,doc + (multiple-value-bind (res rem) (,op number divisor) + (values (float res (if (floatp rem) rem 1.0)) rem)))) + +(!define-float-rounding-function ffloor floor + "Same as FLOOR, but returns first value as a float.") +(!define-float-rounding-function fceiling ceiling + "Same as CEILING, but returns first value as a float." ) +(!define-float-rounding-function ftruncate truncate + "Same as TRUNCATE, but returns first value as a float.") +(!define-float-rounding-function fround round + "Same as ROUND, but returns first value as a float.") ;;;; comparisons diff --git a/src/code/seq.lisp b/src/code/seq.lisp index aee2434..fa48cba 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -1897,23 +1897,10 @@ ;;;; FIND, POSITION, and their -IF and -IF-NOT variants -;;; logic to unravel :TEST, :TEST-NOT, and :KEY options in FIND, -;;; POSITION-IF, etc. -(declaim (inline effective-find-position-test effective-find-position-key)) (defun effective-find-position-test (test test-not) - (cond ((and test test-not) - (error "can't specify both :TEST and :TEST-NOT")) - (test (%coerce-callable-to-fun test)) - (test-not - ;; (Without DYNAMIC-EXTENT, this is potentially horribly - ;; inefficient, but since the TEST-NOT option is deprecated - ;; anyway, we don't care.) - (complement (%coerce-callable-to-fun test-not))) - (t #'eql))) + (effective-find-position-test test test-not)) (defun effective-find-position-key (key) - (if key - (%coerce-callable-to-fun key) - #'identity)) + (effective-find-position-key key)) ;;; shared guts of out-of-line FIND, POSITION, FIND-IF, and POSITION-IF (macrolet (;; shared logic for defining %FIND-POSITION and @@ -1961,76 +1948,31 @@ from-end start end key))) (frobs)))) -;;; the user interface to FIND and POSITION: Get all our ducks in a -;;; row, then call %FIND-POSITION. -(declaim (inline find position)) -(defmacro !def-find-position (fun-name values-index) - `(defun ,fun-name (item sequence &key - from-end (start 0) end - key test test-not) - (nth-value - ,values-index - (%find-position item sequence - from-end start - end (effective-find-position-key key) - (effective-find-position-test test test-not))))) -(!def-find-position find 0) -(!def-find-position position 1) +;;; the user interface to FIND and POSITION: just interpreter stubs, +;;; nowadays. +(defun find (item sequence &key from-end (start 0) end key test test-not) + ;; FIXME: this can't be the way to go, surely? + (find item sequence :from-end from-end :start start :end end :key key + :test test :test-not test-not)) +(defun position (item sequence &key from-end (start 0) end key test test-not) + (position item sequence :from-end from-end :start start :end end :key key + :test test :test-not test-not)) ;;; the user interface to FIND-IF and POSITION-IF, entirely analogous ;;; to the interface to FIND and POSITION -(declaim (inline find-if position-if)) -(defmacro !def-find-position-if (fun-name values-index) - `(defun ,fun-name (predicate sequence - &key from-end (start 0) end key) - (nth-value - ,values-index - (%find-position-if (%coerce-callable-to-fun predicate) - sequence - from-end - start - end - (effective-find-position-key key))))) - -(!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 -;;; 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 -;;; semantic difficulties (what happens if both :test and :test-not -;;; are supplied, etc) the -if-not variants, while officially -;;; deprecated, would be undeprecated were X3J13 actually to produce -;;; a revised standard, as there are perfectly legitimate idiomatic -;;; reasons for allowing the -if-not versions equal status, -;;; particularly remove-if-not (== filter). -;;; -;;; This is only an informal understanding, I grant you, but -;;; perhaps it's worth optimizing the -if-not versions in the same -;;; way as the others? -;;; -;;; FIXME: Maybe remove uses of these deprecated functions (and -;;; definitely of :TEST-NOT) within the implementation of SBCL. -(declaim (inline find-if-not position-if-not)) -(defmacro !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-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) - +(defun find-if (predicate sequence &key from-end (start 0) end key) + (find-if predicate sequence :from-end from-end :start start + :end end :key key)) +(defun position-if (predicate sequence &key from-end (start 0) end key) + (position-if predicate sequence :from-end from-end :start start + :end end :key key)) + +(defun find-if-not (predicate sequence &key from-end (start 0) end key) + (find-if-not predicate sequence :from-end from-end :start start + :end end :key key)) +(defun position-if-not (predicate sequence &key from-end (start 0) end key) + (position-if-not predicate sequence :from-end from-end :start start + :end end :key key)) ;;;; COUNT-IF, COUNT-IF-NOT, and COUNT diff --git a/src/code/sort.lisp b/src/code/sort.lisp index afff387..d1337f3 100644 --- a/src/code/sort.lisp +++ b/src/code/sort.lisp @@ -16,89 +16,8 @@ ;;; to generalize the CMU CL code to allow START and END values, this ;;; code has been written from scratch following Chapter 7 of ;;; _Introduction to Algorithms_ by Corman, Rivest, and Shamir. -(macrolet ((%index (x) `(truly-the index ,x)) - (%parent (i) `(ash ,i -1)) - (%left (i) `(%index (ash ,i 1))) - (%right (i) `(%index (1+ (ash ,i 1)))) - (%heapify (i) - `(do* ((i ,i) - (left (%left i) (%left i))) - ((> left current-heap-size)) - (declare (type index i left)) - (let* ((i-elt (%elt i)) - (i-key (funcall keyfun i-elt)) - (left-elt (%elt left)) - (left-key (funcall keyfun left-elt))) - (multiple-value-bind (large large-elt large-key) - (if (funcall predicate i-key left-key) - (values left left-elt left-key) - (values i i-elt i-key)) - (let ((right (%right i))) - (multiple-value-bind (largest largest-elt) - (if (> right current-heap-size) - (values large large-elt) - (let* ((right-elt (%elt right)) - (right-key (funcall keyfun right-elt))) - (if (funcall predicate large-key right-key) - (values right right-elt) - (values large large-elt)))) - (cond ((= largest i) - (return)) - (t - (setf (%elt i) largest-elt - (%elt largest) i-elt - i largest))))))))) - (%sort-vector (keyfun &optional (vtype 'vector)) - `(macrolet (;; KLUDGE: In SBCL ca. 0.6.10, I had trouble getting - ;; type inference to propagate all the way - ;; through this tangled mess of inlining. The - ;; TRULY-THE here works around that. -- WHN - (%elt (i) - `(aref (truly-the ,',vtype vector) - (%index (+ (%index ,i) start-1))))) - (let ((start-1 (1- start)) ; Heaps prefer 1-based addressing. - (current-heap-size (- end start)) - (keyfun ,keyfun)) - (declare (type (integer -1 #.(1- most-positive-fixnum)) - start-1)) - (declare (type index current-heap-size)) - (declare (type function keyfun)) - (loop for i of-type index - from (ash current-heap-size -1) downto 1 do - (%heapify i)) - (loop - (when (< current-heap-size 2) - (return)) - (rotatef (%elt 1) (%elt current-heap-size)) - (decf current-heap-size) - (%heapify 1)))))) - ;; FIXME: Oh dear. - (declaim (inline sort-vector)) - (defun sort-vector (vector start end predicate key) - (declare (type vector vector)) - (declare (type index start end)) - (declare (type function predicate)) - (declare (type (or function null) key)) - ;; This used to be (OPTIMIZE (SPEED 3) (SAFETY 3)), but now - ;; (0.7.1.39) that (SAFETY 3) means "absolutely safe (including - ;; expensive things like %DETECT-STACK-EXHAUSTION)" we get closer - ;; to what we want by using (SPEED 2) (SAFETY 2): "pretty fast, - ;; pretty safe, and safety is no more important than speed". - (declare (optimize (speed 2) (safety 2) (debug 1) (space 1))) - (if (typep vector 'simple-vector) - ;; (VECTOR T) is worth optimizing for, and SIMPLE-VECTOR is - ;; what we get from (VECTOR T) inside WITH-ARRAY-DATA. - (if (null key) - ;; Special-casing the KEY=NIL case lets us avoid some - ;; function calls. - (%sort-vector #'identity simple-vector) - (%sort-vector key simple-vector)) - ;; It's hard to anticipate many speed-critical applications for - ;; sorting vector types other than (VECTOR T), so we just lump - ;; them all together in one slow dynamically typed mess. - (locally - (declare (optimize (speed 2) (space 2) (inhibit-warnings 3))) - (%sort-vector (or key #'identity)))))) +(defun sort-vector (vector start end predicate key) + (sort-vector vector start end predicate key)) ;;; This is MAYBE-INLINE because it's not too hard to have an ;;; application where sorting is a major bottleneck, and inlining it diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index 7eabbc1..579064e 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -304,9 +304,9 @@ ;; elements before he reads elements (or to read manuals ;; before he writes code:-), we'll signal a STYLE-WARNING ;; in case he didn't realize this. - (compiler-note "The default initial element ~S is not a ~S." - (saetp-initial-element-default saetp) - eltype)) + (compiler-style-warn "The default initial element ~S is not a ~S." + (saetp-initial-element-default saetp) + eltype)) creation-form) (t `(let ((array ,creation-form)) diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 9022242..604f85b 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -614,6 +614,8 @@ (defknown (stable-sort sort) (sequence callable &key (:key callable)) sequence (call) :derive-type (sequence-result-nth-arg 1)) +(defknown sb!impl::sort-vector (vector index index function (or function null)) vector + (call)) (defknown merge (type-specifier sequence sequence callable &key (:key callable)) @@ -1316,6 +1318,13 @@ (function sequence t index sequence-end function) (values t (or index null)) (call)) +(defknown effective-find-position-test (callable callable) + function + (flushable foldable)) +(defknown effective-find-position-key (callable) + function + (flushable foldable)) + (defknown sb!kernel::arg-count-error (t t t t t t) nil (unsafe)) diff --git a/src/compiler/lexenv.lisp b/src/compiler/lexenv.lisp index 34f37ba..9a94062 100644 --- a/src/compiler/lexenv.lisp +++ b/src/compiler/lexenv.lisp @@ -76,21 +76,81 @@ (null (make-null-lexenv)) (lexenv x))) -;;; Is it safe to just grab the lambda expression LAMBDA in isolation, -;;; ignoring the LEXENV? -;;; -;;; Note: The corresponding CMU CL code did something hairier so that -;;; it could save inline definitions of DEFUNs in nontrivial lexical -;;; environments. If it's ever important to try to do that, take a -;;; look at the old CMU CL #'INLINE-SYNTACTIC-CLOSURE. -(defun lambda-independent-of-lexenv-p (lambda lexenv) +(defun maybe-inline-syntactic-closure (lambda lexenv) (declare (type list lambda) (type lexenv lexenv)) - (aver (eql (first lambda) 'lambda)) ; basic sanity check - ;; This is a trivial implementation that just makes sure that LEXENV - ;; doesn't have anything interesting in it. A more sophisticated - ;; implementation could skip things in LEXENV which aren't captured - ;; by LAMBDA, but this implementation doesn't try. - (and (null (lexenv-blocks lexenv)) - (null (lexenv-tags lexenv)) - (null (lexenv-vars lexenv)) - (null (lexenv-funs lexenv)))) + (aver (eql (first lambda) 'lambda)) + ;; We used to have a trivial implementation, verifying that lexenv + ;; was effectively null. However, this fails to take account of the + ;; idiom + ;; + ;; (declaim (inline foo)) + ;; (macrolet ((def (x) `(defun ,x () ...))) + ;; (def foo)) + ;; + ;; which, while too complicated for the cross-compiler to handle in + ;; unfriendly foreign lisp environments, would be good to support in + ;; the target compiler. -- CSR, 2002-05-13 and 2002-11-02 + (let ((vars (lexenv-vars lexenv)) + (funs (lexenv-funs lexenv))) + (collect ((decls) (macros) (symbol-macros)) + (cond + ((or (lexenv-blocks lexenv) (lexenv-tags lexenv)) nil) + ((and (null vars) (null funs)) `(lambda-with-lexenv + nil nil nil + ,@(cdr lambda))) + ((dolist (x vars nil) + #+sb-xc-host + ;; KLUDGE: too complicated for cross-compilation + (return t) + #-sb-xc-host + (let ((name (car x)) + (what (cdr x))) + ;; only worry about the innermost binding + (when (eq x (assoc name vars :test #'eq)) + (typecase what + (cons + (aver (eq (car what) 'macro)) + (symbol-macros x)) + (global-var + ;; A global should not appear in the lexical + ;; environment? Is this true? FIXME! + (aver (eq (global-var-kind what) :special)) + (decls `(special ,name))) + (t + ;; we can't inline in the presence of this object + (return t)))))) + nil) + ((dolist (x funs nil) + #+sb-xc-host + ;; KLUDGE: too complicated for cross-compilation (and + ;; failure of OAOO in comments, *sigh*) + (return t) + #-sb-xc-host + (let ((name (car x)) + (what (cdr x))) + ;; again, only worry about the innermost binding, but + ;; functions can have name (SETF FOO) so we need to use + ;; EQUAL for the test. + (when (eq x (assoc name funs :test #'equal)) + (typecase what + (cons + (macros (cons name (function-lambda-expression (cdr what))))) + ;; FIXME: Is there a good reason for this not to be + ;; DEFINED-FUN (which :INCLUDEs GLOBAL-VAR, in case + ;; you're wondering how this ever worked :-)? Maybe + ;; in conjunction with an AVERrance that it's not an + ;; (AND GLOBAL-VAR (NOT GLOBAL-FUN))? -- CSR, + ;; 2002-07-08 + (global-var + (when (defined-fun-p what) + (decls `(,(car (rassoc (defined-fun-inlinep what) + *inlinep-translations*)) + ,name)))) + (t (return t)))))) + nil) + (t + ;; if we get this far, we've successfully dealt with + ;; everything in FUNS and VARS, so: + `(lambda-with-lexenv ,(decls) ,(macros) ,(symbol-macros) + ,@(cdr lambda))))))) + diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 660f804..0e50c0f 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -927,3 +927,80 @@ (check-inlineability-of-find-position-if sequence from-end) '(%find-position-vector-macro item sequence from-end start end key test)) + +;;; logic to unravel :TEST, :TEST-NOT, and :KEY options in FIND, +;;; POSITION-IF, etc. +(define-source-transform effective-find-position-test (test test-not) + `(cond + ((and ,test ,test-not) + (error "can't specify both :TEST and :TEST-NOT")) + (,test (%coerce-callable-to-fun ,test)) + (,test-not + ;; (Without DYNAMIC-EXTENT, this is potentially horribly + ;; inefficient, but since the TEST-NOT option is deprecated + ;; anyway, we don't care.) + (complement (%coerce-callable-to-fun ,test-not))) + (t #'eql))) +(define-source-transform effective-find-position-key (key) + `(if ,key + (%coerce-callable-to-fun ,key) + #'identity)) + +(macrolet ((define-find-position (fun-name values-index) + `(define-source-transform ,fun-name (item sequence &key + from-end (start 0) end + key test test-not) + `(nth-value ,,values-index + (%find-position ,item ,sequence + ,from-end ,start + ,end + (effective-find-position-key ,key) + (effective-find-position-test ,test ,test-not)))))) + (define-find-position find 0) + (define-find-position position 1)) + +(macrolet ((define-find-position-if (fun-name values-index) + `(define-source-transform ,fun-name (predicate sequence &key + from-end (start 0) + end key) + `(nth-value + ,,values-index + (%find-position-if (%coerce-callable-to-fun ,predicate) + ,sequence ,from-end + ,start ,end + (effective-find-position-key ,key)))))) + (define-find-position-if find-if 0) + (define-find-position-if position-if 1)) + +;;; 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 +;;; semantic difficulties (what happens if both :test and :test-not +;;; are supplied, etc) the -if-not variants, while officially +;;; deprecated, would be undeprecated were X3J13 actually to produce +;;; a revised standard, as there are perfectly legitimate idiomatic +;;; reasons for allowing the -if-not versions equal status, +;;; particularly remove-if-not (== filter). +;;; +;;; This is only an informal understanding, I grant you, but +;;; perhaps it's worth optimizing the -if-not versions in the same +;;; way as the others? +;;; +;;; FIXME: Maybe remove uses of these deprecated functions (and +;;; definitely of :TEST-NOT) within the implementation of SBCL. +(macrolet ((define-find-position-if-not (fun-name values-index) + `(define-source-transform ,fun-name (predicate sequence &key + from-end (start 0) + end key) + `(nth-value + ,,values-index + (%find-position-if-not (%coerce-callable-to-fun ,predicate) + ,sequence ,from-end + ,start ,end + (effective-find-position-key ,key)))))) + (define-find-position-if-not find-if-not 0) + (define-find-position-if-not position-if-not 1)) diff --git a/src/compiler/sparc/system.lisp b/src/compiler/sparc/system.lisp index 77ab3ea..0ef87f4 100644 --- a/src/compiler/sparc/system.lisp +++ b/src/compiler/sparc/system.lisp @@ -68,6 +68,8 @@ (:generator 6 (load-type result function (- fun-pointer-lowtag)))) +;;; Is this VOP dead? I can't see anywhere that it is used... -- CSR, +;;; 2002-06-21 (define-vop (set-fun-subtype) (:translate (setf fun-subtype)) (:policy :fast-safe) diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index b82e87c..487bb15 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -3334,6 +3334,79 @@ (mapcar #'get-element-type (union-type-types array-type)))) (t *universal-type*))))) + +(define-source-transform sb!impl::sort-vector (vector start end predicate key) + `(macrolet ((%index (x) `(truly-the index ,x)) + (%parent (i) `(ash ,i -1)) + (%left (i) `(%index (ash ,i 1))) + (%right (i) `(%index (1+ (ash ,i 1)))) + (%heapify (i) + `(do* ((i ,i) + (left (%left i) (%left i))) + ((> left current-heap-size)) + (declare (type index i left)) + (let* ((i-elt (%elt i)) + (i-key (funcall keyfun i-elt)) + (left-elt (%elt left)) + (left-key (funcall keyfun left-elt))) + (multiple-value-bind (large large-elt large-key) + (if (funcall ,',predicate i-key left-key) + (values left left-elt left-key) + (values i i-elt i-key)) + (let ((right (%right i))) + (multiple-value-bind (largest largest-elt) + (if (> right current-heap-size) + (values large large-elt) + (let* ((right-elt (%elt right)) + (right-key (funcall keyfun right-elt))) + (if (funcall ,',predicate large-key right-key) + (values right right-elt) + (values large large-elt)))) + (cond ((= largest i) + (return)) + (t + (setf (%elt i) largest-elt + (%elt largest) i-elt + i largest))))))))) + (%sort-vector (keyfun &optional (vtype 'vector)) + `(macrolet (;; KLUDGE: In SBCL ca. 0.6.10, I had trouble getting + ;; type inference to propagate all the way + ;; through this tangled mess of + ;; inlining. The TRULY-THE here works + ;; around that. -- WHN + (%elt (i) + `(aref (truly-the ,',vtype ,',',vector) + (%index (+ (%index ,i) start-1))))) + (let ((start-1 (1- ,',start)) ; Heaps prefer 1-based addressing. + (current-heap-size (- ,',end ,',start)) + (keyfun ,keyfun)) + (declare (type (integer -1 #.(1- most-positive-fixnum)) + start-1)) + (declare (type index current-heap-size)) + (declare (type function keyfun)) + (loop for i of-type index + from (ash current-heap-size -1) downto 1 do + (%heapify i)) + (loop + (when (< current-heap-size 2) + (return)) + (rotatef (%elt 1) (%elt current-heap-size)) + (decf current-heap-size) + (%heapify 1)))))) + (if (typep ,vector 'simple-vector) + ;; (VECTOR T) is worth optimizing for, and SIMPLE-VECTOR is + ;; what we get from (VECTOR T) inside WITH-ARRAY-DATA. + (if (null ,key) + ;; Special-casing the KEY=NIL case lets us avoid some + ;; function calls. + (%sort-vector #'identity simple-vector) + (%sort-vector ,key simple-vector)) + ;; It's hard to anticipate many speed-critical applications for + ;; sorting vector types other than (VECTOR T), so we just lump + ;; them all together in one slow dynamically typed mess. + (locally + (declare (optimize (speed 2) (space 2) (inhibit-warnings 3))) + (%sort-vector (or ,key #'identity)))))) ;;;; debuggers' little helpers diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index f3f1d20..9a8458c 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -615,6 +615,27 @@ BUG 48c, not yet fixed: (assert (typep (check-embedded-thes 3 3 2 3.5f0) 'type-error)) +;;; INLINE inside MACROLET +(declaim (inline to-be-inlined)) +(macrolet ((def (x) `(defun ,x (y) (+ y 1)))) + (def to-be-inlined)) +(defun call-inlined (z) + (to-be-inlined z)) +(assert (= (call-inlined 3) 4)) +(macrolet ((frob (x) `(+ ,x 3))) + (defun to-be-inlined (y) + (frob y))) +(assert (= (call-inlined 3) + ;; we should have inlined the previous definition, so the + ;; new one won't show up yet. + 4)) +(defun call-inlined (z) + (to-be-inlined z)) +(assert (= (call-inlined 3) 6)) +(defun to-be-inlined (y) + (+ y 5)) +(assert (= (call-inlined 3) 6)) + ;;;; tests not in the problem domain, but of the consistency of the ;;;; compiler machinery itself diff --git a/tests/filesys.test.sh b/tests/filesys.test.sh index 10ba9e5..3580d86 100644 --- a/tests/filesys.test.sh +++ b/tests/filesys.test.sh @@ -184,7 +184,12 @@ Lisp filename syntax idiosyncrasies)." (need-match "animal/vertebrate/mammal/../**/robot/*.*" nil) (need-match "animal/vertebrate/mammal/robot/../**/../**/*.*" nil)) (need-matches) +(sb-ext:quit :unix-status 52) EOF +if [ $? != 52 ]; then + echo DIRECTORY/TRUENAME test part 1 failed, unexpected SBCL return code=$? + exit 1 +fi cd .. rm -r $testdir diff --git a/version.lisp-expr b/version.lisp-expr index c5aba7c..ea842f6 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.7.10.9" +"0.7.10.10" -- 1.7.10.4