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")
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)
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
-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)
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
"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"
"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"
"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"
#-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
(+ 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.")
\f
;;;; comparisons
\f
;;;; 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
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))
\f
;;;; COUNT-IF, COUNT-IF-NOT, and COUNT
;;; 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
;; 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))
(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))
(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))
\f
(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)))))))
+
(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))
(: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)
(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))))))
\f
;;;; debuggers' little helpers
(assert (typep (check-embedded-thes 3 3 2 3.5f0) 'type-error))
\f
+;;; 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))
+\f
;;;; tests not in the problem domain, but of the consistency of the
;;;; compiler machinery itself
(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
;;; 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"
projects / sbcl.git / commitdiff