;;;; This file contains macro-like source transformations which
;;;; convert uses of certain functions into the canonical form desired
-;;;; within the compiler. ### and other IR1 transforms and stuff.
+;;;; within the compiler. FIXME: and other IR1 transforms and stuff.
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
(define-source-transform logtest (x y) `(not (zerop (logand ,x ,y))))
(define-source-transform logbitp (index integer)
`(not (zerop (logand (ash 1 ,index) ,integer))))
-(define-source-transform byte (size position) `(cons ,size ,position))
+(define-source-transform byte (size position)
+ `(cons ,size ,position))
(define-source-transform byte-size (spec) `(car ,spec))
(define-source-transform byte-position (spec) `(cdr ,spec))
(define-source-transform ldb-test (bytespec integer)
;;; Apply the function F to a bound X. If X is an open bound, then
;;; the result will be open. IF X is NIL, the result is NIL.
(defun bound-func (f x)
+ (declare (type function f))
(and x
(with-float-traps-masked (:underflow :overflow :inexact :divide-by-zero)
;; With these traps masked, we might get things like infinity
;;; result makes sense. It will if F is monotonic increasing (or
;;; non-decreasing).
(defun interval-func (f x)
- (declare (type interval x))
+ (declare (type function f)
+ (type interval x))
(let ((lo (bound-func f (interval-low x)))
(hi (bound-func f (interval-high x))))
(make-interval :low lo :high hi)))
;;; positive. If we didn't do this, we wouldn't be able to tell.
(defun two-arg-derive-type (arg1 arg2 derive-fcn fcn
&optional (convert-type t))
+ (declare (type function derive-fcn fcn))
#!+negative-zero-is-not-zero
(declare (ignore convert-type))
(flet (#!-negative-zero-is-not-zero
(define-source-transform char-not-equal (&rest args)
(multi-not-equal 'char-equal args))
+;;; FIXME: can go away once bug 194 is fixed and we can use (THE REAL X)
+;;; as God intended
+(defun error-not-a-real (x)
+ (error 'simple-type-error
+ :datum x
+ :expected-type 'real
+ :format-control "not a REAL: ~S"
+ :format-arguments (list x)))
+
;;; Expand MAX and MIN into the obvious comparisons.
-(define-source-transform max (arg &rest more-args)
- (if (null more-args)
- `(values ,arg)
- (once-only ((arg1 arg)
- (arg2 `(max ,@more-args)))
- `(if (> ,arg1 ,arg2)
- ,arg1 ,arg2))))
-(define-source-transform min (arg &rest more-args)
- (if (null more-args)
- `(values ,arg)
- (once-only ((arg1 arg)
- (arg2 `(min ,@more-args)))
- `(if (< ,arg1 ,arg2)
- ,arg1 ,arg2))))
+(define-source-transform max (arg0 &rest rest)
+ (once-only ((arg0 arg0))
+ (if (null rest)
+ `(values (the real ,arg0))
+ `(let ((maxrest (max ,@rest)))
+ (if (> ,arg0 maxrest) ,arg0 maxrest)))))
+(define-source-transform min (arg0 &rest rest)
+ (once-only ((arg0 arg0))
+ (if (null rest)
+ `(values (the real ,arg0))
+ `(let ((minrest (min ,@rest)))
+ (if (< ,arg0 minrest) ,arg0 minrest)))))
\f
;;;; converting N-arg arithmetic functions
;;;;
;;; Do source transformations for transitive functions such as +.
;;; One-arg cases are replaced with the arg and zero arg cases with
-;;; the identity. If LEAF-FUN is true, then replace two-arg calls with
-;;; a call to that function.
-(defun source-transform-transitive (fun args identity &optional leaf-fun)
+;;; the identity. ONE-ARG-RESULT-TYPE is, if non-NIL, the type to
+;;; ensure (with THE) that the argument in one-argument calls is.
+(defun source-transform-transitive (fun args identity
+ &optional one-arg-result-type)
(declare (symbol fun leaf-fun) (list args))
(case (length args)
(0 identity)
- (1 `(values ,(first args)))
- (2 (if leaf-fun
- `(,leaf-fun ,(first args) ,(second args))
- (values nil t)))
+ (1 (if one-arg-result-type
+ `(values (the ,one-arg-result-type ,(first args)))
+ `(values ,(first args))))
+ (2 (values nil t))
(t
(associate-args fun (first args) (rest args)))))
(define-source-transform + (&rest args)
- (source-transform-transitive '+ args 0))
+ (source-transform-transitive '+ args 0 'number))
(define-source-transform * (&rest args)
- (source-transform-transitive '* args 1))
+ (source-transform-transitive '* args 1 'number))
(define-source-transform logior (&rest args)
- (source-transform-transitive 'logior args 0))
+ (source-transform-transitive 'logior args 0 'integer))
(define-source-transform logxor (&rest args)
- (source-transform-transitive 'logxor args 0))
+ (source-transform-transitive 'logxor args 0 'integer))
(define-source-transform logand (&rest args)
- (source-transform-transitive 'logand args -1))
+ (source-transform-transitive 'logand args -1 'integer))
(define-source-transform logeqv (&rest args)
(if (evenp (length args))
;;; Do source transformations for intransitive n-arg functions such as
;;; /. With one arg, we form the inverse. With two args we pass.
;;; Otherwise we associate into two-arg calls.
-(declaim (ftype (function (symbol list t) list) source-transform-intransitive))
+(declaim (ftype (function (symbol list t)
+ (values list &optional (member nil t)))
+ source-transform-intransitive))
(defun source-transform-intransitive (function args inverse)
(case (length args)
((0 2) (values nil t))
*universal-type*)))))
(defoptimizer (array-element-type derive-type) ((array))
- (let* ((array-type (continuation-type array)))
+ (let ((array-type (continuation-type array)))
(labels ((consify (list)
(if (endp list)
'(eql nil)
(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
projects / sbcl.git / blobdiff