(deftransform complement ((fun) * * :node node :when :both)
"open code"
(multiple-value-bind (min max)
- (function-type-nargs (continuation-type fun))
+ (fun-type-nargs (continuation-type fun))
(cond
((and min (eql min max))
(let ((dums (make-gensym-list min)))
;;; Translate CxR into CAR/CDR combos.
(defun source-transform-cxr (form)
- (if (or (byte-compiling) (/= (length form) 2))
+ (if (/= (length form) 2)
(values nil t)
(let ((name (symbol-name (car form))))
(do ((i (- (length name) 2) (1- i))
;; The bound exists, so keep it open still.
(list new-val))))
(t
- (error "Unknown bound type in make-interval!")))))
+ (error "unknown bound type in MAKE-INTERVAL")))))
(%make-interval :low (normalize-bound low)
:high (normalize-bound high))))
:low (bound-mul (interval-low x) (interval-low y))
:high (bound-mul (interval-high x) (interval-high y))))
(t
- (error "This shouldn't happen!"))))))
+ (error "internal error in INTERVAL-MUL"))))))
;;; Divide two intervals.
(defun interval-div (top bot)
:low (bound-div (interval-low top) (interval-high bot) t)
:high (bound-div (interval-high top) (interval-low bot) nil)))
(t
- (error "This shouldn't happen!"))))))
+ (error "internal error in INTERVAL-DIV"))))))
;;; Apply the function F to the interval X. If X = [a, b], then the
;;; result is [f(a), f(b)]. It is up to the user to make sure the
(if (and (numeric-type-p size)
(csubtypep size (specifier-type 'integer)))
(let ((size-high (numeric-type-high size)))
- (if (and size-high (<= size-high sb!vm:word-bits))
+ (if (and size-high (<= size-high sb!vm:n-word-bits))
(specifier-type `(unsigned-byte ,size-high))
(specifier-type 'unsigned-byte)))
*universal-type*)))
(let ((size-high (numeric-type-high size))
(posn-high (numeric-type-high posn)))
(if (and size-high posn-high
- (<= (+ size-high posn-high) sb!vm:word-bits))
+ (<= (+ size-high posn-high) sb!vm:n-word-bits))
(specifier-type `(unsigned-byte ,(+ size-high posn-high)))
(specifier-type 'unsigned-byte)))
*universal-type*)))
(high (numeric-type-high int))
(low (numeric-type-low int)))
(if (and size-high posn-high high low
- (<= (+ size-high posn-high) sb!vm:word-bits))
+ (<= (+ size-high posn-high) sb!vm:n-word-bits))
(specifier-type
(list (if (minusp low) 'signed-byte 'unsigned-byte)
(max (integer-length high)
(high (numeric-type-high int))
(low (numeric-type-low int)))
(if (and size-high posn-high high low
- (<= (+ size-high posn-high) sb!vm:word-bits))
+ (<= (+ size-high posn-high) sb!vm:n-word-bits))
(specifier-type
(list (if (minusp low) 'signed-byte 'unsigned-byte)
(max (integer-length high)
(deftransform %ldb ((size posn int)
(fixnum fixnum integer)
- (unsigned-byte #.sb!vm:word-bits))
+ (unsigned-byte #.sb!vm:n-word-bits))
"convert to inline logical operations"
`(logand (ash int (- posn))
- (ash ,(1- (ash 1 sb!vm:word-bits))
- (- size ,sb!vm:word-bits))))
+ (ash ,(1- (ash 1 sb!vm:n-word-bits))
+ (- size ,sb!vm:n-word-bits))))
(deftransform %mask-field ((size posn int)
(fixnum fixnum integer)
- (unsigned-byte #.sb!vm:word-bits))
+ (unsigned-byte #.sb!vm:n-word-bits))
"convert to inline logical operations"
`(logand int
- (ash (ash ,(1- (ash 1 sb!vm:word-bits))
- (- size ,sb!vm:word-bits))
+ (ash (ash ,(1- (ash 1 sb!vm:n-word-bits))
+ (- size ,sb!vm:n-word-bits))
posn)))
;;; Note: for %DPB and %DEPOSIT-FIELD, we can't use
(deftransform %dpb ((new size posn int)
*
- (unsigned-byte #.sb!vm:word-bits))
+ (unsigned-byte #.sb!vm:n-word-bits))
"convert to inline logical operations"
`(let ((mask (ldb (byte size 0) -1)))
(logior (ash (logand new mask) posn)
(deftransform %dpb ((new size posn int)
*
- (signed-byte #.sb!vm:word-bits))
+ (signed-byte #.sb!vm:n-word-bits))
"convert to inline logical operations"
`(let ((mask (ldb (byte size 0) -1)))
(logior (ash (logand new mask) posn)
(deftransform %deposit-field ((new size posn int)
*
- (unsigned-byte #.sb!vm:word-bits))
+ (unsigned-byte #.sb!vm:n-word-bits))
"convert to inline logical operations"
`(let ((mask (ash (ldb (byte size 0) -1) posn)))
(logior (logand new mask)
(deftransform %deposit-field ((new size posn int)
*
- (signed-byte #.sb!vm:word-bits))
+ (signed-byte #.sb!vm:n-word-bits))
"convert to inline logical operations"
`(let ((mask (ash (ldb (byte size 0) -1) posn)))
(logior (logand new mask)
(deftransform commutative-arg-swap ((x y) * * :defun-only t :node node)
(if (and (constant-continuation-p x)
(not (constant-continuation-p y)))
- `(,(continuation-function-name (basic-combination-fun node))
+ `(,(continuation-fun-name (basic-combination-fun node))
y
,(continuation-value x))
(give-up-ir1-transform)))
(logand x ,mask)))))
\f
;;;; arithmetic and logical identity operation elimination
-;;;;
-;;;; Flush calls to various arith functions that convert to the
-;;;; identity function or a constant.
+;;; Flush calls to various arith functions that convert to the
+;;; identity function or a constant.
+;;;
+;;; FIXME: Rewrite as DEF-FROB.
(dolist (stuff '((ash 0 x)
(logand -1 x)
(logand 0 0)
'(%negate y))
(deftransform * ((x y) (rational (constant-argument (member 0))) *
:when :both)
- "convert (* x 0) to 0."
+ "convert (* x 0) to 0"
0)
;;; Return T if in an arithmetic op including continuations X and Y,
(dolist (x '(eq char= equal))
(%deftransform x '(function * *) #'simple-equality-transform))
-;;; Similar to SIMPLE-EQUALITY-PREDICATE, except that we also try to
-;;; convert to a type-specific predicate or EQ:
+;;; This is similar to SIMPLE-EQUALITY-PREDICATE, except that we also
+;;; try to convert to a type-specific predicate or EQ:
;;; -- If both args are characters, convert to CHAR=. This is better than
;;; just converting to EQ, since CHAR= may have special compilation
;;; strategies for non-standard representations, etc.
(defoptimizer (array-element-type derive-type) ((array))
(let* ((array-type (continuation-type array)))
- #!+sb-show
- (format t "~& defoptimizer array-elt-derive-type - array-element-type ~~
-~A~%" array-type)
(labels ((consify (list)
(if (endp list)
'(eql nil)
`(cons (eql ,(car list)) ,(consify (rest list)))))
(get-element-type (a)
- (let ((element-type (type-specifier
- (array-type-specialized-element-type a))))
- (cond ((symbolp element-type)
+ (let ((element-type
+ (type-specifier (array-type-specialized-element-type a))))
+ (cond ((eq element-type '*)
+ (specifier-type 'type-specifier))
+ ((symbolp element-type)
(make-member-type :members (list element-type)))
((consp element-type)
(specifier-type (consify element-type)))
(t
- (error "Can't grok type ~A~%" element-type))))))
+ (error "can't understand type ~S~%" element-type))))))
(cond ((array-type-p array-type)
- (get-element-type array-type))
- ((union-type-p array-type)
+ (get-element-type array-type))
+ ((union-type-p array-type)
(apply #'type-union
(mapcar #'get-element-type (union-type-types array-type))))
- (t
- *universal-type*)))))
+ (t
+ *universal-type*)))))
\f
;;;; debuggers' little helpers
projects / sbcl.git / blobdiff