Menu
▾
▴
[Sbcl-commits] CVS: sbcl/src/compiler array-tran.lisp,1.40,1.40.2.1 checkgen.lisp,1.29.2.2,1.29.2.3 constraint.lisp,1.16.4.1,1.16.4.2 debug.lisp,1.24.8.1,1.24.8.2 fndb.lisp,1.57,1.57.2.1 ir1-translators.lisp,1.40.2.1,1.40.2.2 ir1opt.lisp,1.55.2.1,1.55.2.2 ir1tran.lisp,1.99.2.1,1.99.2.2 ir1util.lisp,1.52.2.1,1.52.2.2 ir2tran.lisp,1.39.8.2,1.39.8.3 locall.lisp,1.43.2.1,1.43.2.2 ltn.lisp,1.22.8.2,1.22.8.3 macros.lisp,1.34.6.1,1.34.6.2 node.lisp,1.38.2.1,1.38.2.2 seqtran.lisp,1.38,1.38.2.1 srctran.lisp,1.55,1.55.6.1 target-disassem.lisp,1.38,1.38.10.1 typetran.lisp,1.30,1.30.8.1
Update of /cvsroot/sbcl/sbcl/src/compiler
In directory sc8-pr-cvs1:/tmp/cvs-serv12440/src/compiler
Modified Files:
Tag: apd-0-7-cast
array-tran.lisp checkgen.lisp constraint.lisp debug.lisp
fndb.lisp ir1-translators.lisp ir1opt.lisp ir1tran.lisp
ir1util.lisp ir2tran.lisp locall.lisp ltn.lisp macros.lisp
node.lisp seqtran.lisp srctran.lisp target-disassem.lisp
typetran.lisp
Log Message:
0.7.13.30-cast.4: (updated to 0.7.13.30)
* Small steps towards ANSI VALUES type specifier:
** removed checks for VALUES-TYPE-{KEYP,KEYWORDS};
** &OPTIONAL type in VALUES does not automatically allow NIL;
** object type <type> in a values context \approx (VALUES &OPTIONAL
<type> &REST T); DEFKNOWN uses the old meaning;
* added type checking for single value and MV-BIND receivers;
* THE coerces the asserted type to VALUES;
* fixed order of CAST LTN-annotating;
Index: array-tran.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/array-tran.lisp,v
retrieving revision 1.40
retrieving revision 1.40.2.1
diff -u -d -r1.40 -r1.40.2.1
--- array-tran.lisp 3 Feb 2003 15:41:48 -0000 1.40
+++ array-tran.lisp 20 Mar 2003 10:18:03 -0000 1.40.2.1
@@ -187,13 +187,13 @@
,n-vec))))
;;; Just convert it into a MAKE-ARRAY.
-(define-source-transform make-string (length &key
- (element-type ''base-char)
- (initial-element
- '#.*default-init-char-form*))
- `(make-array (the index ,length)
- :element-type ,element-type
- :initial-element ,initial-element))
+(deftransform make-string ((length &key
+ (element-type 'base-char)
+ (initial-element
+ #.*default-init-char-form*)))
+ '(make-array (the index length)
+ :element-type element-type
+ :initial-element initial-element))
(defstruct (specialized-array-element-type-properties
(:conc-name saetp-)
@@ -227,7 +227,10 @@
(destructuring-bind (type-spec &rest rest) args
(let ((ctype (specifier-type type-spec)))
(apply #'!make-saetp ctype rest))))
- `((base-char ,(code-char 0) 8 ,sb!vm:simple-string-widetag
+ `(;; Erm. Yeah. There aren't a lot of things that make sense
+ ;; for an initial element for (ARRAY NIL). -- CSR, 2002-03-07
+ (nil '#:mu 0 ,sb!vm:simple-array-nil-widetag)
+ (base-char ,(code-char 0) 8 ,sb!vm:simple-string-widetag
;; (SIMPLE-STRINGs are stored with an extra trailing
;; #\NULL for convenience in calling out to C.)
:n-pad-elements 1)
@@ -366,14 +369,17 @@
'length
`(+ length ,n-pad-elements)))
(n-words-form
- (if (>= n-bits-per-element sb!vm:n-word-bits)
- `(* ,padded-length-form
- (the fixnum ; i.e., not RATIO
- ,(/ n-bits-per-element sb!vm:n-word-bits)))
- (let ((n-elements-per-word (/ sb!vm:n-word-bits
- n-bits-per-element)))
- (declare (type index n-elements-per-word)) ; i.e., not RATIO
- `(ceiling ,padded-length-form ,n-elements-per-word)))))
+ (cond
+ ((= n-bits-per-element 0) 0)
+ ((>= n-bits-per-element sb!vm:n-word-bits)
+ `(* ,padded-length-form
+ (the fixnum ; i.e., not RATIO
+ ,(/ n-bits-per-element sb!vm:n-word-bits))))
+ (t
+ (let ((n-elements-per-word (/ sb!vm:n-word-bits
+ n-bits-per-element)))
+ (declare (type index n-elements-per-word)) ; i.e., not RATIO
+ `(ceiling ,padded-length-form ,n-elements-per-word))))))
(values
`(truly-the ,result-type-spec
(allocate-vector ,typecode length ,n-words-form))
Index: checkgen.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/checkgen.lisp,v
retrieving revision 1.29.2.2
retrieving revision 1.29.2.3
diff -u -d -r1.29.2.2 -r1.29.2.3
--- checkgen.lisp 11 Feb 2003 11:41:13 -0000 1.29.2.2
+++ checkgen.lisp 20 Mar 2003 10:18:04 -0000 1.29.2.3
@@ -109,9 +109,7 @@
:optional (mapcar #'weaken-type
(values-type-optional type))
:rest (acond ((values-type-rest type)
- (weaken-type it))
- ((values-type-keyp type)
- *universal-type*))))
+ (weaken-type it)))))
(t (weaken-type type))))
;;;; checking strategy determination
@@ -221,32 +219,66 @@
;;; negation of this type instead.
(defun cast-check-types (cast force-hairy)
(declare (type cast cast))
- (let* ((ctype (cast-type-to-check cast))
+ (let* ((cont (node-cont cast))
+ (ctype (cast-type-to-check cast))
(atype (cast-asserted-type cast))
- (value (cast-value cast)))
+ (value (cast-value cast))
+ (dest (continuation-dest cont)))
(aver (not (eq ctype *wild-type*)))
(multiple-value-bind (ctypes count) (no-fun-values-types ctype)
(multiple-value-bind (atypes acount) (no-fun-values-types atype)
(aver (eq count acount))
(cond ((not (eq count :unknown))
- (maybe-negate-check value ctypes atypes force-hairy)
- #+nil
+ (let ((dtype (coerce-to-values (node-derived-type cast))))
+ (setf (node-derived-type cast)
+ (make-values-type
+ :required (adjust-list (values-type-types dtype)
+ count
+ (or (values-type-rest dtype)
+ *universal-type*)))))
(if (or (exit-p dest)
(and (return-p dest)
(multiple-value-bind (ignore count)
(values-types (return-result-type dest))
(declare (ignore ignore))
(eq count :unknown))))
- (maybe-negate-check cont ctypes atypes t)
- (maybe-negate-check cont ctypes atypes force-hairy)))
- #+nil
+ (maybe-negate-check value ctypes atypes t)
+ (maybe-negate-check value ctypes atypes force-hairy)))
+ ((and (continuation-single-value-p cont)
+ (or (not (values-type-p ctype))
+ (not (args-type-rest ctype))
+ (eq (args-type-rest ctype) *universal-type*)))
+ (when (values-type-p ctype)
+ (let ((creq (car (args-type-required ctype))))
+ (multiple-value-setq (ctype atype)
+ (if creq
+ (values creq (car (args-type-required atype)))
+ (values (car (args-type-optional ctype))
+ (car (args-type-optional atype)))))
+ (setf (cast-type-to-check cast)
+ (make-values-type :required (list ctype)))
+ (setf (cast-asserted-type cast)
+ (make-values-type :required (list atype)))))
+ (setf (node-derived-type cast)
+ (single-value-type (node-derived-type cast)))
+ (maybe-negate-check value
+ (list ctype) (list atype)
+ force-hairy))
((and (mv-combination-p dest)
- (eq (basic-combination-kind dest) :local))
+ (eq (mv-combination-kind dest) :local))
(aver (values-type-p ctype))
- (maybe-negate-check cont
- (args-type-optional ctype)
- (args-type-optional atype)
- force-hairy))
+ (aver (null (args-type-required atype)))
+ (aver (null (args-type-required ctype)))
+ (let* ((fun-ref (continuation-use (mv-combination-fun dest)))
+ (length (length (lambda-vars (ref-leaf fun-ref)))))
+ (maybe-negate-check value
+ (adjust-list (args-type-optional ctype)
+ length
+ *universal-type*)
+ (adjust-list (args-type-optional atype)
+ length
+ *universal-type*)
+ force-hairy)))
(t
(values :too-hairy nil)))))))
@@ -282,18 +314,14 @@
;;; -- the continuation is an argument to a known function that has
;;; no IR2-CONVERT method or :FAST-SAFE templates that are
;;; compatible with the call's type.
-;;;
-;;; We must only return NIL when it is *certain* that a check will not
-;;; be done, since if we pass up this chance to do the check, it will
-;;; be too late. The penalty for being too conservative is duplicated
-;;; type checks. The penalty for erring by being too speculative is
-;;; much nastier, e.g. falling through without ever being able to find
-;;; an appropriate VOP.
(defun probable-type-check-p (cast)
(declare (type cast cast))
- t
- #+nil
- (let ((dest (continuation-dest cont)))
+ (let* ((cont (node-cont cast))
+ (dest (continuation-dest cont)))
+ (cond ((not dest) nil)
+ ((continuation-single-value-p cont) t)
+ (t nil))
+ #+nil
(cond ((or (not dest)
(policy dest (zerop safety)))
nil)
@@ -508,9 +536,6 @@
(when (cast-p node)
(cond ((worth-type-check-p node)
(casts (cons node (not (probable-type-check-p node)))))
- #+nil
- ((probable-type-check-p cont)
- (setf (continuation-%type-check cont) :deleted))
(t
(aver (null (cast-%type-check node)))))))
(setf (block-type-check block) nil)))
Index: constraint.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/constraint.lisp,v
retrieving revision 1.16.4.1
retrieving revision 1.16.4.2
diff -u -d -r1.16.4.1 -r1.16.4.2
--- constraint.lisp 10 Feb 2003 14:54:04 -0000 1.16.4.1
+++ constraint.lisp 20 Mar 2003 10:18:04 -0000 1.16.4.2
@@ -441,7 +441,7 @@
(let ((cons (lambda-var-constraints var)))
(when cons
(sset-difference gen cons)
- (let* ((type (node-derived-type node))
+ (let* ((type (single-value-type (node-derived-type node)))
(con (find-constraint 'typep var type nil)))
(sset-adjoin con gen)))))))))
Index: debug.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/debug.lisp,v
retrieving revision 1.24.8.1
retrieving revision 1.24.8.2
diff -u -d -r1.24.8.1 -r1.24.8.2
--- debug.lisp 10 Feb 2003 14:54:04 -0000 1.24.8.1
+++ debug.lisp 20 Mar 2003 10:18:04 -0000 1.24.8.2
@@ -965,7 +965,8 @@
(ref (print-leaf (ref-leaf node)))
(basic-combination
(let ((kind (basic-combination-kind node)))
- (format t "~(~A ~A~) c~D"
+ (format t "~(~A~A ~A~) c~D"
+ (if (node-tail-p node) "tail " "")
(if (fun-info-p kind) "known" kind)
(type-of node)
(cont-num (basic-combination-fun node)))
@@ -983,7 +984,9 @@
(print-continuation (block-start (if-alternative node))))
(bind
(write-string "bind ")
- (print-leaf (bind-lambda node)))
+ (print-leaf (bind-lambda node))
+ (when (functional-kind (bind-lambda node))
+ (format t " ~S ~S" :kind (functional-kind (bind-lambda node)))))
(creturn
(format t "return c~D " (cont-num (return-result node)))
(print-leaf (return-lambda node)))
Index: fndb.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/fndb.lisp,v
retrieving revision 1.57
retrieving revision 1.57.2.1
diff -u -d -r1.57 -r1.57.2.1
--- fndb.lisp 3 Feb 2003 15:41:49 -0000 1.57
+++ fndb.lisp 20 Mar 2003 10:18:05 -0000 1.57.2.1
@@ -108,7 +108,14 @@
;;; This is not FLUSHABLE, since it's required to signal an error if
;;; unbound.
-(defknown (symbol-value symbol-function) (symbol) t ())
+(defknown (symbol-value) (symbol) t ())
+;;; From CLHS, "If the symbol is globally defined as a macro or a
+;;; special operator, an object of implementation-dependent nature and
+;;; identity is returned. If the symbol is not globally defined as
+;;; either a macro or a special operator, and if the symbol is fbound,
+;;; a function object is returned". Our objects of
+;;; implementation-dependent nature happen to be functions.
+(defknown (symbol-function) (symbol) function ())
(defknown boundp (symbol) boolean (flushable))
(defknown fboundp ((or symbol cons)) boolean (unsafely-flushable explicit-check))
@@ -791,8 +798,8 @@
(defknown vector (&rest t) simple-vector (flushable unsafe))
-(defknown aref (array &rest index) t (foldable flushable))
-(defknown row-major-aref (array index) t (foldable flushable))
+(defknown aref (array &rest index) t (foldable))
+(defknown row-major-aref (array index) t (foldable))
(defknown array-element-type (array)
type-specifier
@@ -822,6 +829,9 @@
(foldable)
#|:derive-type #'result-type-last-arg|#)
+(defknown bit-vector-= (bit-vector bit-vector) boolean
+ (movable foldable flushable))
+
(defknown array-has-fill-pointer-p (array) boolean
(movable foldable flushable))
(defknown fill-pointer (vector) index (foldable unsafely-flushable))
@@ -946,7 +956,7 @@
(defknown (read read-preserving-whitespace read-char-no-hang read-char)
(&optional streamlike t t t) t (explicit-check))
-(defknown read-delimited-list (character &optional streamlike t) t
+(defknown read-delimited-list (character &optional streamlike t) list
(explicit-check))
(defknown read-line (&optional streamlike t t t) (values t boolean)
(explicit-check))
@@ -1195,9 +1205,10 @@
(:block-compile t))
(values (or pathname null) boolean boolean))
-(defknown disassemble (callable &key
- (:stream stream)
- (:use-labels t))
+;; FIXME: consider making (OR CALLABLE CONS) something like
+;; EXTENDED-FUNCTION-DESIGNATOR
+(defknown disassemble ((or callable cons) &key
+ (:stream stream) (:use-labels t))
null)
(defknown fdocumentation (t symbol)
@@ -1309,10 +1320,10 @@
(defknown %negate (number) number (movable foldable flushable explicit-check))
(defknown %check-bound (array index fixnum) index (movable foldable flushable))
(defknown data-vector-ref (simple-array index) t
- (foldable flushable explicit-check))
+ (foldable explicit-check))
(defknown data-vector-set (array index t) t (unsafe explicit-check))
(defknown hairy-data-vector-ref (array index) t
- (foldable flushable explicit-check))
+ (foldable explicit-check))
(defknown hairy-data-vector-set (array index t) t (unsafe explicit-check))
(defknown %caller-frame-and-pc () (values t t) (flushable))
(defknown %with-array-data (array index (or index null))
@@ -1344,7 +1355,8 @@
;;; get efficient compilation of the inline expansion of
;;; %FIND-POSITION-IF, so it should maybe be in a more
;;; compiler-friendly package (SB-INT?)
-(defknown sb!impl::signal-bounding-indices-bad-error (sequence index index)
+(defknown sb!impl::signal-bounding-indices-bad-error
+ (sequence index sequence-end)
nil) ; never returns
Index: ir1-translators.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1-translators.lisp,v
retrieving revision 1.40.2.1
retrieving revision 1.40.2.2
diff -u -d -r1.40.2.1 -r1.40.2.2
--- ir1-translators.lisp 10 Feb 2003 14:54:04 -0000 1.40.2.1
+++ ir1-translators.lisp 20 Mar 2003 10:18:05 -0000 1.40.2.2
@@ -346,15 +346,6 @@
macrobindings
(lambda (&key vars)
(ir1-translate-locally body start cont :vars vars))))
-
-;;; not really a special form, but..
-(def-ir1-translator declare ((&rest stuff) start cont)
- (declare (ignore stuff))
- ;; We ignore START and CONT too, but we can't use DECLARE IGNORE to
- ;; tell the compiler about it here, because the DEF-IR1-TRANSLATOR
- ;; macro would put the DECLARE in the wrong place, so..
- start cont
- (compiler-error "misplaced declaration"))
;;;; %PRIMITIVE
;;;;
@@ -444,7 +435,7 @@
thing
:debug-name (debug-namify "#'~S" thing)
:allow-debug-catch-tag t)))
- ((setf sb!pcl::class-predicate)
+ ((setf sb!pcl::class-predicate sb!pcl::slot-accessor)
(let ((var (find-lexically-apparent-fun
thing "as the argument to FUNCTION")))
(reference-leaf start cont var)))
@@ -680,12 +671,14 @@
;;; A logic shared among THE and TRULY-THE.
(defun the-in-policy (type value policy start cont)
- (let ((type (if (ctype-p type) type
- (compiler-values-specifier-type type))))
+ (let ((type (coerce-to-values
+ (if (ctype-p type) type
+ (compiler-values-specifier-type type)))))
(cond ((or (and (leaf-p value)
(values-subtypep (leaf-type value) type))
(and (sb!xc:constantp value)
- (ctypep (constant-form-value value) type)))
+ (ctypep (constant-form-value value)
+ (single-value-type type))))
(ir1-convert start cont value))
(t (let ((value-cont (make-continuation)))
(ir1-convert start value-cont value)
Index: ir1opt.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1opt.lisp,v
retrieving revision 1.55.2.1
retrieving revision 1.55.2.2
diff -u -d -r1.55.2.1 -r1.55.2.2
--- ir1opt.lisp 10 Feb 2003 14:54:04 -0000 1.55.2.1
+++ ir1opt.lisp 20 Mar 2003 10:18:06 -0000 1.55.2.2
@@ -190,7 +190,8 @@
;;; moving uses behind a new CAST node. If we improve the assertion,
;;; we set TYPE-CHECK and TYPE-ASSERTED to guarantee that the new
;;; assertion will be checked.
-(defun assert-continuation-type (cont type policy)
+(defun assert-continuation-type (cont type policy
+ &aux (type (coerce-to-values type)))
(declare (type continuation cont) (type ctype type))
(when (values-subtypep (continuation-type cont) type)
(return-from assert-continuation-type))
@@ -288,7 +289,7 @@
(aver (not (block-delete-p block)))
(ir1-optimize-block block))
- (cond ((block-delete-p block)
+ (cond ((and (block-delete-p block) (block-component block))
(delete-block block))
((and (block-flush-p block) (block-component block))
(flush-dead-code block))))))
@@ -1130,21 +1131,24 @@
;;; possible to do this starting from debug names as well as source
;;; names, but as of sbcl-0.7.1.5, there was no need for this
;;; generality, since source names are always known to our callers.)
-(defun transform-call (node res source-name)
- (declare (type combination node) (list res))
+(defun transform-call (call res source-name)
+ (declare (type combination call) (list res))
(aver (and (legal-fun-name-p source-name)
(not (eql source-name '.anonymous.))))
- (with-ir1-environment-from-node node
+ (node-ends-block call)
+ (with-ir1-environment-from-node call
+ (with-component-last-block (*current-component*
+ (block-next (node-block call)))
(let ((new-fun (ir1-convert-inline-lambda
res
:debug-name (debug-namify "LAMBDA-inlined ~A"
(as-debug-name
source-name
"<unknown function>"))))
- (ref (continuation-use (combination-fun node))))
+ (ref (continuation-use (combination-fun call))))
(change-ref-leaf ref new-fun)
- (setf (combination-kind node) :full)
- (locall-analyze-component *current-component*)))
+ (setf (combination-kind call) :full)
+ (locall-analyze-component *current-component*))))
(values))
;;; Replace a call to a foldable function of constant arguments with
@@ -1725,7 +1729,8 @@
(ensure-block-start value)
(ensure-block-start cont)
(substitute-continuation-uses cont value)
- (unlink-node cast)))
+ (unlink-node cast)
+ (setf (continuation-dest value) nil)))
((values-subtypep value-type
(cast-type-to-check cast))
(setf (cast-%type-check cast) nil))))
Index: ir1tran.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1tran.lisp,v
retrieving revision 1.99.2.1
retrieving revision 1.99.2.2
diff -u -d -r1.99.2.1 -r1.99.2.2
--- ir1tran.lisp 10 Feb 2003 14:54:04 -0000 1.99.2.1
+++ ir1tran.lisp 20 Mar 2003 10:18:06 -0000 1.99.2.2
@@ -886,7 +886,7 @@
(declare (list decl vars) (type lexenv res))
(let ((type (compiler-specifier-type (first decl))))
(collect ((restr nil cons)
- (new-vars nil cons))
+ (new-vars nil cons))
(dolist (var-name (rest decl))
(let* ((bound-var (find-in-bindings vars var-name))
(var (or bound-var
@@ -894,26 +894,31 @@
(find-free-var var-name))))
(etypecase var
(leaf
- (let* ((old-type (or (lexenv-find var type-restrictions)
- (leaf-type var)))
- (int (if (or (fun-type-p type)
- (fun-type-p old-type))
- type
- (type-approx-intersection2 old-type type))))
- (cond ((eq int *empty-type*)
- (unless (policy *lexenv* (= inhibit-warnings 3))
- (compiler-warn
- "The type declarations ~S and ~S for ~S conflict."
- (type-specifier old-type) (type-specifier type)
- var-name)))
- (bound-var (setf (leaf-type bound-var) int))
- (t
- (restr (cons var int))))))
+ (flet ((process-var (var bound-var)
+ (let* ((old-type (or (lexenv-find var type-restrictions)
+ (leaf-type var)))
+ (int (if (or (fun-type-p type)
+ (fun-type-p old-type))
+ type
+ (type-approx-intersection2 old-type type))))
+ (cond ((eq int *empty-type*)
+ (unless (policy *lexenv* (= inhibit-warnings 3))
+ (compiler-warn
+ "The type declarations ~S and ~S for ~S conflict."
+ (type-specifier old-type) (type-specifier type)
+ var-name)))
+ (bound-var (setf (leaf-type bound-var) int))
+ (t
+ (restr (cons var int)))))))
+ (process-var var bound-var)
+ (awhen (and (lambda-var-p var)
+ (lambda-var-specvar var))
+ (process-var it nil))))
(cons
;; FIXME: non-ANSI weirdness
(aver (eq (car var) 'MACRO))
(new-vars `(,var-name . (MACRO . (the ,(first decl)
- ,(cdr var))))))
+ ,(cdr var))))))
(heap-alien-info
(compiler-error
"~S is an alien variable, so its type can't be declared."
@@ -1420,7 +1425,8 @@
aux-vals
result
(source-name '.anonymous.)
- debug-name)
+ debug-name
+ (note-lexical-bindings t))
(declare (list body vars aux-vars aux-vals)
(type (or continuation null) result))
@@ -1458,7 +1464,8 @@
(svars var)
(new-venv (cons (leaf-source-name specvar) specvar)))
(t
- (note-lexical-binding (leaf-source-name var))
+ (when note-lexical-bindings
+ (note-lexical-binding (leaf-source-name var)))
(new-venv (cons (leaf-source-name var) var))))))
(let ((*lexenv* (make-lexenv :vars (new-venv)
@@ -1507,8 +1514,6 @@
(declare (type clambda fun) (list vars vals defaults))
(let* ((fvars (reverse vars))
(arg-vars (mapcar (lambda (var)
- (unless (lambda-var-specvar var)
- (note-lexical-binding (leaf-source-name var)))
(make-lambda-var
:%source-name (leaf-source-name var)
:type (leaf-type var)
@@ -1519,7 +1524,8 @@
,@(reverse vals)
,@defaults))
arg-vars
- :debug-name "&OPTIONAL processor")))
+ :debug-name "&OPTIONAL processor"
+ :note-lexical-bindings nil)))
(mapc (lambda (var arg-var)
(when (cdr (leaf-refs arg-var))
(setf (leaf-ever-used var) t)))
@@ -1690,7 +1696,8 @@
(%funcall ,(optional-dispatch-main-entry res)
,@(arg-vals))))
(arg-vars)
- :debug-name (debug-namify "~S processing" '&more))))
+ :debug-name (debug-namify "~S processing" '&more)
+ :note-lexical-bindings nil)))
(setf (optional-dispatch-more-entry res) ep))))
(values))
Index: ir1util.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1util.lisp,v
retrieving revision 1.52.2.1
retrieving revision 1.52.2.2
diff -u -d -r1.52.2.1 -r1.52.2.2
--- ir1util.lisp 10 Feb 2003 14:54:05 -0000 1.52.2.1
+++ ir1util.lisp 20 Mar 2003 10:18:07 -0000 1.52.2.2
@@ -37,17 +37,19 @@
(type (or cleanup null) cleanup))
(setf (component-reanalyze (block-component block1)) t)
(with-ir1-environment-from-node node
- (let* ((start (make-continuation))
- (block (continuation-starts-block start))
- (cont (make-continuation))
- (*lexenv* (if cleanup
- (make-lexenv :cleanup cleanup)
- *lexenv*)))
- (change-block-successor block1 block2 block)
- (link-blocks block block2)
- (ir1-convert start cont form)
- (setf (block-last block) (continuation-use cont))
- block)))
+ (with-component-last-block (*current-component*
+ (block-next (component-head *current-component*)))
+ (let* ((start (make-continuation))
+ (block (continuation-starts-block start))
+ (cont (make-continuation))
+ (*lexenv* (if cleanup
+ (make-lexenv :cleanup cleanup)
+ *lexenv*)))
+ (change-block-successor block1 block2 block)
+ (link-blocks block block2)
+ (ir1-convert start cont form)
+ (setf (block-last block) (continuation-use cont))
+ block))))
;;;; continuation use hacking
@@ -195,16 +197,16 @@
(ecase (continuation-kind cont)
(:unused
(aver (not (continuation-block cont)))
- (let* ((head (component-head *current-component*))
- (next (block-next head))
- (new-block (make-block cont)))
+ (let* ((next (component-last-block *current-component*))
+ (prev (block-prev next))
+ (new-block (make-block cont)))
(setf (block-next new-block) next
- (block-prev new-block) head
- (block-prev next) new-block
- (block-next head) new-block
- (continuation-block cont) new-block
- (continuation-use cont) nil
- (continuation-kind cont) :block-start)
+ (block-prev new-block) prev
+ (block-prev next) new-block
+ (block-next prev) new-block
+ (continuation-block cont) new-block
+ (continuation-use cont) nil
+ (continuation-kind cont) :block-start)
new-block))
(:block-start
(continuation-block cont))))
@@ -564,7 +566,7 @@
(defun make-empty-component ()
(let* ((head (make-block-key :start nil :component nil))
(tail (make-block-key :start nil :component nil))
- (res (make-component :head head :tail tail)))
+ (res (make-component head tail)))
(setf (block-flag head) t)
(setf (block-flag tail) t)
(setf (block-component head) res)
Index: ir2tran.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir2tran.lisp,v
retrieving revision 1.39.8.2
retrieving revision 1.39.8.3
diff -u -d -r1.39.8.2 -r1.39.8.3
--- ir2tran.lisp 11 Feb 2003 11:41:13 -0000 1.39.8.2
+++ ir2tran.lisp 20 Mar 2003 10:18:07 -0000 1.39.8.3
@@ -472,14 +472,14 @@
(2value (continuation-info value)))
(cond ((not 2cont))
((eq (ir2-continuation-kind 2cont) :unused))
- ((and (eq (ir2-continuation-kind 2cont) :unknown)
- (eq (ir2-continuation-kind 2value) :unknown))
+ ((eq (ir2-continuation-kind 2cont) :unknown)
+ (aver (eq (ir2-continuation-kind 2value) :unknown))
(aver (not (cast-type-check node)))
(move-results-coerced node block
(ir2-continuation-locs 2value)
(ir2-continuation-locs 2cont)))
- ((and (eq (ir2-continuation-kind 2cont) :fixed)
- (eq (ir2-continuation-kind 2value) :fixed))
+ ((eq (ir2-continuation-kind 2cont) :fixed)
+ (aver (eq (ir2-continuation-kind 2value) :fixed))
(if (cast-type-check node)
(move-results-checked node block
(ir2-continuation-locs 2value)
@@ -491,8 +491,7 @@
(move-results-coerced node block
(ir2-continuation-locs 2value)
(ir2-continuation-locs 2cont))))
- ;; FIXME: unknown values packing/unpacking -- APD, 2002-02-11
- (t (bug "quux")))))
+ (t (bug "CAST cannot be :DELAYED.")))))
;;;; template conversion
@@ -1049,9 +1048,11 @@
(bug "full call to ~S" fname)))
(when (consp fname)
- (destructuring-bind (setf stem) fname
- (aver (eq setf 'setf))
- (setf (gethash stem *setf-assumed-fboundp*) t)))))
+ (destructuring-bind (setfoid &rest stem) fname
+ (aver (member setfoid
+ '(setf sb!pcl::class-predicate sb!pcl::slot-accessor)))
+ (when (eq setfoid 'setf)
+ (setf (gethash (car stem) *setf-assumed-fboundp*) t))))))
;;; If the call is in a tail recursive position and the return
;;; convention is standard, then do a tail full call. If one or fewer
Index: locall.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/locall.lisp,v
retrieving revision 1.43.2.1
retrieving revision 1.43.2.2
diff -u -d -r1.43.2.1 -r1.43.2.2
--- locall.lisp 10 Feb 2003 14:54:05 -0000 1.43.2.1
+++ locall.lisp 20 Mar 2003 10:18:07 -0000 1.43.2.2
@@ -931,12 +931,21 @@
(cond ((not return))
((or next-block call-return)
(unless (block-delete-p (node-block return))
+ (when (and (node-tail-p call)
+ call-return
+ (not (eq (node-cont call)
+ (return-result call-return))))
+ ;; We do not care to give a meaningful continuation to
+ ;; a tail combination, but here we need it.
+ (delete-continuation-use call)
+ (add-continuation-use call (return-result call-return)))
(move-return-uses fun call
(or next-block (node-block call-return)))))
(t
(aver (node-tail-p call))
(setf (lambda-return call-fun) return)
- (setf (return-lambda return) call-fun))))
+ (setf (return-lambda return) call-fun)
+ (setf (lambda-return fun) nil))))
(move-let-call-cont fun)
(values))
Index: ltn.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ltn.lisp,v
retrieving revision 1.22.8.2
retrieving revision 1.22.8.3
diff -u -d -r1.22.8.2 -r1.22.8.3
--- ltn.lisp 11 Feb 2003 11:41:14 -0000 1.22.8.2
+++ ltn.lisp 20 Mar 2003 10:18:08 -0000 1.22.8.3
@@ -199,19 +199,25 @@
;;; IR2-COMPONENT-VALUES-FOO would get all messed up.
(defun annotate-unknown-values-continuation (cont)
(declare (type continuation cont))
- (let* ((block (node-block (continuation-dest cont)))
- (use (continuation-use cont))
- (2block (block-info block)))
- (unless (and use (eq (node-block use) block))
- (setf (ir2-block-popped 2block)
- (nconc (ir2-block-popped 2block) (list cont)))))
(let ((2cont (make-ir2-continuation nil)))
(setf (ir2-continuation-kind 2cont) :unknown)
(setf (ir2-continuation-locs 2cont) (make-unknown-values-locations))
(setf (continuation-info cont) 2cont))
+ ;; The CAST chain with corresponding continuations constitute the
+ ;; same "principal continuation", so we must preserve only inner
+ ;; annotation order and the order of the whole p.c. with other
+ ;; continiations. -- APD, 2002-02-27
(ltn-annotate-casts cont)
+
+ (let* ((block (node-block (continuation-dest cont)))
+ (use (continuation-use cont))
+ (2block (block-info block)))
+ (unless (and use (eq (node-block use) block))
+ (setf (ir2-block-popped 2block)
+ (nconc (ir2-block-popped 2block) (list cont)))))
+
(values))
;;; Annotate CONT for a fixed, but arbitrary number of values, of the
@@ -879,14 +885,12 @@
(declare (type component component))
(let ((2comp (component-info component)))
(do-blocks (block component)
- ;; This assertion seems to protect us from compiling a component
- ;; twice. As noted above, "this is where we allocate IR2-BLOCKS
- ;; because it is the first place we need them", so if one is
- ;; already allocated here, something is wrong. -- WHN 2001-09-14
(aver (not (block-info block)))
(let ((2block (make-ir2-block block)))
(setf (block-info block) 2block)
- (ltn-analyze-block block)
+ (ltn-analyze-block block)))
+ (do-blocks (block component)
+ (let ((2block (block-info block)))
(let ((popped (ir2-block-popped 2block)))
(when popped
(push block (ir2-component-values-receivers 2comp)))))))
Index: macros.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/macros.lisp,v
retrieving revision 1.34.6.1
retrieving revision 1.34.6.2
diff -u -d -r1.34.6.1 -r1.34.6.2
--- macros.lisp 10 Feb 2003 14:54:06 -0000 1.34.6.1
+++ macros.lisp 20 Mar 2003 10:18:08 -0000 1.34.6.2
@@ -462,18 +462,30 @@
;;; keywords specify the initial values for various optimizers that
;;; the function might have.
(defmacro defknown (name arg-types result-type &optional (attributes '(any))
- &rest keys)
+ &rest keys)
(when (and (intersection attributes '(any call unwind))
(intersection attributes '(movable)))
(error "function cannot have both good and bad attributes: ~S" attributes))
(when (member 'any attributes)
- (setf attributes (union '(call unsafe unwind) attributes)))
+ (setq attributes (union '(call unsafe unwind) attributes)))
(when (member 'flushable attributes)
(pushnew 'unsafely-flushable attributes))
+ ;; FIXME: We use non-ANSI "exact" interpretation of VALUES types
+ ;; here. It would be better to give such ability to the user too. --
+ ;; APD, 2003-03-18
+ (setq result-type
+ (cond ((eq result-type '*) '*)
+ ((or (atom result-type)
+ (neq (car result-type) 'values))
+ `(values ,result-type &optional))
+ ((intersection (cdr result-type) lambda-list-keywords)
+ result-type)
+ (t `(values ,@(cdr result-type) &optional))))
+
`(%defknown ',(if (and (consp name)
- (not (eq (car name) 'setf)))
+ (not (legal-fun-name-p name)))
name
(list name))
'(function ,arg-types ,result-type)
@@ -682,6 +694,19 @@
`(if ,n-res
(values (cdr ,n-res) t)
(values nil nil))))
+
+(defmacro with-component-last-block ((component block) &body body)
+ (let ((old-last-block (gensym "OLD-LAST-BLOCK")))
+ (once-only ((component component)
+ (block block))
+ `(let ((,old-last-block (component-last-block ,component)))
+ (unwind-protect
+ (progn (setf (component-last-block ,component)
+ ,block)
+ ,@body)
+ (setf (component-last-block ,component)
+ ,old-last-block))))))
+
;;;; the EVENT statistics/trace utility
Index: node.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/node.lisp,v
retrieving revision 1.38.2.1
retrieving revision 1.38.2.2
diff -u -d -r1.38.2.1 -r1.38.2.2
--- node.lisp 10 Feb 2003 14:54:07 -0000 1.38.2.1
+++ node.lisp 20 Mar 2003 10:18:08 -0000 1.38.2.2
@@ -303,7 +303,9 @@
;;; size of flow analysis problems, this allows back-end data
;;; structures to be reclaimed after the compilation of each
;;; component.
-(defstruct (component (:copier nil))
+(defstruct (component (:copier nil)
+ (:constructor
+ make-component (head tail &aux (last-block tail))))
;; unique ID for debugging
#!+sb-show (id (new-object-id) :read-only t)
;; the kind of component
@@ -337,13 +339,15 @@
;; the blocks that are the dummy head and tail of the DFO
;;
;; Entry/exit points have these blocks as their
- ;; predecessors/successors. Null temporarily. The start and return
- ;; from each non-deleted function is linked to the component head
- ;; and tail. Until physical environment analysis links NLX entry
- ;; stubs to the component head, every successor of the head is a
- ;; function start (i.e. begins with a BIND node.)
- (head nil :type (or null cblock))
- (tail nil :type (or null cblock))
+ ;; predecessors/successors. The start and return from each
+ ;; non-deleted function is linked to the component head and
+ ;; tail. Until physical environment analysis links NLX entry stubs
+ ;; to the component head, every successor of the head is a function
+ ;; start (i.e. begins with a BIND node.)
+ (head (missing-arg) :type cblock)
+ (tail (missing-arg) :type cblock)
+ ;; New blocks are inserted before this.
+ (last-block (missing-arg) :type cblock)
;; This becomes a list of the CLAMBDA structures for all functions
;; in this component. OPTIONAL-DISPATCHes are represented only by
;; their XEP and other associated lambdas. This doesn't contain any
@@ -1107,8 +1111,6 @@
(leaf
&aux (leaf-type (leaf-type leaf))
(derived-type
- #-nil leaf-type
- #+nil
(make-values-type
:required (list leaf-type)))))
(:copier nil))
@@ -1138,7 +1140,8 @@
alternative)
(defstruct (cset (:include node
- (derived-type *universal-type*))
+ (derived-type (make-values-type
+ :required (list *universal-type*))))
(:conc-name set-)
(:predicate set-p)
(:constructor make-set)
Index: seqtran.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/seqtran.lisp,v
retrieving revision 1.38
retrieving revision 1.38.2.1
diff -u -d -r1.38 -r1.38.2.1
--- seqtran.lisp 3 Feb 2003 15:41:49 -0000 1.38
+++ seqtran.lisp 20 Mar 2003 10:18:08 -0000 1.38.2.1
@@ -26,25 +26,29 @@
(tests `(endp ,v))
(args-to-fn (if take-car `(car ,v) v))))
- (let ((call `(funcall ,fn . ,(args-to-fn)))
- (endtest `(or ,@(tests))))
+ (let* ((fn-sym (gensym)) ; for ONCE-ONLY-ish purposes
+ (call `(funcall ,fn-sym . ,(args-to-fn)))
+ (endtest `(or ,@(tests))))
(ecase accumulate
(:nconc
(let ((temp (gensym))
(map-result (gensym)))
- `(let ((,map-result (list nil)))
+ `(let ((,fn-sym ,fn)
+ (,map-result (list nil)))
(do-anonymous ((,temp ,map-result) . ,(do-clauses))
(,endtest (cdr ,map-result))
(setq ,temp (last (nconc ,temp ,call)))))))
(:list
(let ((temp (gensym))
(map-result (gensym)))
- `(let ((,map-result (list nil)))
+ `(let ((,fn-sym ,fn)
+ (,map-result (list nil)))
(do-anonymous ((,temp ,map-result) . ,(do-clauses))
(,endtest (cdr ,map-result))
(rplacd ,temp (setq ,temp (list ,call)))))))
((nil)
- `(let ((,n-first ,(first arglists)))
+ `(let ((,fn-sym ,fn)
+ (,n-first ,(first arglists)))
(do-anonymous ,(do-clauses)
(,endtest ,n-first) ,call))))))))
@@ -807,26 +811,10 @@
:important t)
"expand inline"
'(%find-position-if (let ((test-fun (%coerce-callable-to-fun test)))
- ;; I'm having difficulty believing I'm
- ;; reading it right, but as far as I can see,
- ;; the only guidance that ANSI gives for the
- ;; order of arguments to asymmetric tests is
- ;; the character-set dependent example from
- ;; the definition of FIND,
- ;; (find #\d "here are some.." :test #'char>)
- ;; => #\Space
- ;; (In ASCII, we have (CHAR> #\d #\SPACE)=>T.)
- ;; (Neither the POSITION definition page nor
- ;; section 17.2 ("Rules about Test Functions")
- ;; seem to consider the possibility of
- ;; asymmetry.)
- ;;
- ;; So, judging from the example, we want to
- ;; do (FUNCALL TEST-FUN ITEM I), because
- ;; (FUNCALL #'CHAR> #\d #\SPACE)=>T.
- ;;
- ;; -- WHN (whose attention was drawn to it by
- ;; Alexey Dejneka's bug report/fix)
+ ;; The order of arguments for asymmetric tests
+ ;; (e.g. #'<, as opposed to order-independent
+ ;; tests like #'=) is specified in the spec
+ ;; section 17.2.1 -- the O/Zi stuff there.
(lambda (i)
(funcall test-fun item i)))
sequence
@@ -949,44 +937,48 @@
;;; 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)))
+ (once-only ((test test)
+ (test-not 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))
+ (once-only ((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))))))
+ `(deftransform ,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))))))
+ `(deftransform ,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))
@@ -1011,14 +1003,14 @@
;;; 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))))))
+ `(deftransform ,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))
Index: srctran.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/srctran.lisp,v
retrieving revision 1.55
retrieving revision 1.55.6.1
diff -u -d -r1.55 -r1.55.6.1
--- srctran.lisp 21 Dec 2002 10:53:29 -0000 1.55
+++ srctran.lisp 20 Mar 2003 10:18:09 -0000 1.55.6.1
@@ -29,12 +29,14 @@
(define-source-transform identity (x) `(prog1 ,x))
(define-source-transform values (x) `(prog1 ,x))
-;;; Bind the values and make a closure that returns them.
+;;; Bind the value and make a closure that returns it.
(define-source-transform constantly (value)
- (let ((rest (gensym "CONSTANTLY-REST-")))
- `(lambda (&rest ,rest)
- (declare (ignore ,rest))
- ,value)))
+ (let ((rest (gensym "CONSTANTLY-REST-"))
+ (n-value (gensym "CONSTANTLY-VALUE-")))
+ `(let ((,n-value ,value))
+ (lambda (&rest ,rest)
+ (declare (ignore ,rest))
+ ,n-value))))
;;; If the function has a known number of arguments, then return a
;;; lambda with the appropriate fixed number of args. If the
@@ -1345,16 +1347,19 @@
) ; PROGN
-
-;;; KLUDGE: All this ASH optimization is suppressed under CMU CL
-;;; because as of version 2.4.6 for Debian, CMU CL blows up on (ASH
-;;; 1000000000 -100000000000) (i.e. ASH of two bignums yielding zero)
-;;; and it's hard to avoid that calculation in here.
-#-(and cmu sb-xc-host)
-(progn
-
(defun ash-derive-type-aux (n-type shift same-arg)
(declare (ignore same-arg))
+ ;; KLUDGE: All this ASH optimization is suppressed under CMU CL for
+ ;; some bignum cases because as of version 2.4.6 for Debian and 18d,
+ ;; CMU CL blows up on (ASH 1000000000 -100000000000) (i.e. ASH of
+ ;; two bignums yielding zero) and it's hard to avoid that
+ ;; calculation in here.
+ #+(and cmu sb-xc-host)
+ (when (and (or (typep (numeric-type-low n-type) 'bignum)
+ (typep (numeric-type-high n-type) 'bignum))
+ (or (typep (numeric-type-low shift) 'bignum)
+ (typep (numeric-type-high shift) 'bignum)))
+ (return-from ash-derive-type-aux *universal-type*))
(flet ((ash-outer (n s)
(when (and (fixnump s)
(<= s 64)
@@ -1387,7 +1392,6 @@
(defoptimizer (ash derive-type) ((n shift))
(two-arg-derive-type n shift #'ash-derive-type-aux #'ash))
-) ; PROGN
#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(macrolet ((frob (fun)
@@ -2587,7 +2591,8 @@
(or result 0)))
;;; If arg is a constant power of two, turn FLOOR into a shift and
-;;; mask. If CEILING, add in (1- (ABS Y)) and then do FLOOR.
+;;; mask. If CEILING, add in (1- (ABS Y)), do FLOOR and correct a
+;;; remainder.
(flet ((frob (y ceil-p)
(unless (constant-continuation-p y)
(give-up-ir1-transform))
@@ -2597,13 +2602,14 @@
(unless (= y-abs (ash 1 len))
(give-up-ir1-transform))
(let ((shift (- len))
- (mask (1- y-abs)))
- `(let ,(when ceil-p `((x (+ x ,(1- y-abs)))))
+ (mask (1- y-abs))
+ (delta (if ceil-p (* (signum y) (1- y-abs)) 0)))
+ `(let ((x (+ x ,delta)))
,(if (minusp y)
`(values (ash (- x) ,shift)
- (- (logand (- x) ,mask)))
+ (- (- (logand (- x) ,mask)) ,delta))
`(values (ash x ,shift)
- (logand x ,mask))))))))
+ (- (logand x ,mask) ,delta))))))))
(deftransform floor ((x y) (integer integer) *)
"convert division by 2^k to shift"
(frob y nil))
Index: target-disassem.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/target-disassem.lisp,v
retrieving revision 1.38
retrieving revision 1.38.10.1
diff -u -d -r1.38 -r1.38.10.1
--- target-disassem.lisp 19 Aug 2002 12:14:00 -0000 1.38
+++ target-disassem.lisp 20 Mar 2003 10:18:09 -0000 1.38.10.1
@@ -1467,9 +1467,7 @@
(compile nil lambda)))
(defun compiled-fun-or-lose (thing &optional (name thing))
- (cond ((or (symbolp thing)
- (and (listp thing)
- (eq (car thing) 'setf)))
+ (cond ((legal-fun-name-p thing)
(compiled-fun-or-lose (fdefinition thing) thing))
((functionp thing)
thing)
Index: typetran.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/typetran.lisp,v
retrieving revision 1.30
retrieving revision 1.30.8.1
diff -u -d -r1.30 -r1.30.8.1
--- typetran.lisp 2 Oct 2002 15:24:17 -0000 1.30
+++ typetran.lisp 20 Mar 2003 10:18:09 -0000 1.30.8.1
@@ -276,6 +276,11 @@
`(typep ,n-obj ',x))
(rest spec))))))))))
+(defun source-transform-negation-typep (object type)
+ (declare (type negation-type type))
+ (let ((spec (type-specifier (negation-type-type type))))
+ `(not (typep ,object ',spec))))
+
;;; Do source transformation for TYPEP of a known union type. If a
;;; union type contains LIST, then we pull that out and make it into a
;;; single LISTP call. Note that if SYMBOL is in the union, then LIST
@@ -505,6 +510,8 @@
(typecase type
(hairy-type
(source-transform-hairy-typep object type))
+ (negation-type
+ (source-transform-negation-typep object type))
(union-type
(source-transform-union-typep object type))
(intersection-type
|