:FAST-MODE NIL)
188: "compiler performance fiasco involving type inference and UNION-TYPE"
- (In sbcl-0.7.6.10, DEFTRANSFORM CONCATENATE was commented out until this
- bug could be fixed properly, so you won't see the bug unless you restore
- the DEFTRANSFORM by hand.) In sbcl-0.7.5.11 on a 700 MHz Pentium III,
- (time (compile
- nil
- '(lambda ()
- (declare (optimize (safety 3)))
- (declare (optimize (compilation-speed 2)))
- (declare (optimize (speed 1) (debug 1) (space 1)))
- (let ((fn "if-this-file-exists-the-universe-is-strange"))
- (load fn :if-does-not-exist nil)
- (load (concatenate 'string fn ".lisp") :if-does-not-exist nil)
- (load (concatenate 'string fn ".fasl") :if-does-not-exist nil)
- (load (concatenate 'string fn ".misc-garbage")
- :if-does-not-exist nil)))))
- reports
- 134.552 seconds of real time
- 133.35156 seconds of user run time
- 0.03125 seconds of system run time
- [Run times include 2.787 seconds GC run time.]
- 0 page faults and
- 246883368 bytes consed.
- BACKTRACE from Ctrl-C in the compilation shows that the compiler is
- thinking about type relationships involving types like
- #<UNION-TYPE
- (OR (INTEGER 576 576)
- (INTEGER 1192 1192)
- (INTEGER 2536 2536)
- (INTEGER 1816 1816)
- (INTEGER 2752 2752)
- (INTEGER 1600 1600)
- (INTEGER 2640 2640)
- (INTEGER 1808 1808)
- (INTEGER 1296 1296)
- ...)>)[:EXTERNAL]
-
- In recent SBCL the following example also illustrates this bug:
-
(time (compile
nil
'(lambda ()
does not cause a warning. (BTW: old SBCL issued a warning, but for a
function, which was never called!)
-255:
- (fixed in 0.8.0.57)
+256:
+ Compiler does not emit warnings for
+
+ a. (lambda () (svref (make-array 8 :adjustable t) 1))
+
+ b. (lambda (x)
+ (list (let ((y (the real x)))
+ (unless (floatp y) (error ""))
+ y)
+ (integer-length x)))
+
+ c. (lambda (x)
+ (declare (optimize (debug 0)))
+ (declare (type vector x))
+ (list (fill-pointer x)
+ (svref x 1)))
+
+257:
+ Complex array type does not have corresponding type specifier.
DEFUNCT CATEGORIES OF BUGS
IR1-#:
(defpackage :sb-cltl2
(:use :cl :sb-c :sb-int)
(:export #:compiler-let
- #:macroexpand-all))
+ #:macroexpand-all
+ ;; environment access
+ #:variable-information
+ #:function-information
+ #:declaration-information
+ #:augment-environment
+ #:define-declaration
+ #:parse-macro
+ #:enclose
+ ))
--- /dev/null
+(in-package :sb-cltl2)
+
+#| TODO:
+function-information
+declaration-information
+augment-environment
+define-declaration
+(map-environment)
+|#
+
+(declaim (ftype (sfunction
+ (symbol &optional (or null sb-kernel:lexenv))
+ (values (member nil :special :lexical :symbol-macro :constant)
+ boolean
+ list))
+ variable-information))
+(defun variable-information (var &optional env)
+ (let* ((*lexenv* (or env (sb-kernel:make-null-lexenv)))
+ (info (lexenv-find var vars)))
+ (etypecase info
+ (sb-c::leaf (let ((type (sb-kernel:type-specifier
+ (sb-kernel:type-intersection
+ (sb-c::leaf-type info)
+ (or (lexenv-find info type-restrictions)
+ sb-kernel:*universal-type*)))))
+ (etypecase info
+ (sb-c::lambda-var
+ (values :lexical t
+ `((ignore . ,(sb-c::lambda-var-ignorep info))
+ (type . ,type))))
+ (sb-c::global-var
+ (values :special t
+ `((type . ,type)) ; XXX ignore
+ ))
+ (sb-c::constant
+ (values :constant nil
+ `((type . ,type)) ; XXX ignore
+ )))))
+ (cons (values :symbol-macro t
+ nil ; FIXME: also in the compiler
+ ))
+ (null (values (ecase (info :variable :kind var)
+ (:special :special)
+ (:constant :constant)
+ (:macro :symbol-macro)
+ (:global nil))
+ nil
+ `( ; XXX ignore
+ (type . ,(sb-kernel:type-specifier ; XXX local type
+ (info :variable :type var)))))))))
+
+(defun parse-macro (name lambda-list body
+ &optional env)
+ (declare (ignore env))
+ (with-unique-names (whole environment)
+ (multiple-value-bind (body decls)
+ (sb-kernel:parse-defmacro lambda-list whole body name
+ 'parse-macro
+ :environment environment)
+ `(lambda (,whole ,environment)
+ ,@decls
+ ,body))))
+
+(defun enclose (lambda-expression
+ &optional env)
+ (let ((env (if env
+ (sb-c::make-restricted-lexenv env)
+ (sb-kernel:make-null-lexenv))))
+ (compile-in-lexenv nil lambda-expression env)))
:description "Some functionality, mentioned in CLtL2, but not present in ANSI."
:components ((:file "defpackage")
(:file "compiler-let" :depends-on ("defpackage"))
- (:file "macroexpand" :depends-on ("defpackage"))))
+ (:file "macroexpand" :depends-on ("defpackage"))
+ (:file "env" :depends-on ("defpackage"))))
(defmethod perform :after ((o load-op) (c (eql (find-system :sb-cltl2))))
(provide 'sb-cltl2))
(defoptimizer (%with-array-data derive-type) ((array start end))
(let ((atype (continuation-type array)))
(when (array-type-p atype)
- (values-specifier-type
- `(values (simple-array ,(type-specifier
- (array-type-specialized-element-type atype))
- (*))
- index index index)))))
+ (specifier-type
+ `(simple-array ,(type-specifier
+ (array-type-specialized-element-type atype))
+ (*))))))
(defoptimizer (array-row-major-index derive-type) ((array &rest indices))
(assert-array-rank array (length indices))
(continuation-value element-type))
(t
'*))
- ,(cond ((not simple)
- '*)
- ((constant-continuation-p dims)
+ ,(cond ((constant-continuation-p dims)
(let ((val (continuation-value dims)))
(if (listp val) val (list val))))
((csubtypep (continuation-type dims)
(t &rest simple-string)
simple-string
:policy (< safety 3))
- (collect ((lets)
- (forms)
- (all-lengths)
- (args))
- (dolist (seq sequences)
- (declare (ignorable seq))
- (let ((n-seq (gensym))
- (n-length (gensym)))
- (args n-seq)
- (lets `(,n-length (the index (* (length ,n-seq) sb!vm:n-byte-bits))))
- (all-lengths n-length)
- (forms `(bit-bash-copy ,n-seq ,vector-data-bit-offset
- res start
- ,n-length))
- (forms `(setq start (opaque-identity (+ start ,n-length))))))
- `(lambda (rtype ,@(args))
- (declare (ignore rtype))
- ;; KLUDGE
- (flet ((opaque-identity (x) x))
- (declare (notinline opaque-identity))
- (let* (,@(lets)
- (res (make-string (truncate (the index (+ ,@(all-lengths)))
- sb!vm:n-byte-bits)))
- (start ,vector-data-bit-offset))
- (declare (type index start ,@(all-lengths)))
- ,@(forms)
- res)))))
+ (loop for rest-seqs on sequences
+ for n-seq = (gensym "N-SEQ")
+ for n-length = (gensym "N-LENGTH")
+ for start = vector-data-bit-offset then next-start
+ for next-start = (gensym "NEXT-START")
+ collect n-seq into args
+ collect `(,n-length (* (length ,n-seq) sb!vm:n-byte-bits)) into lets
+ collect n-length into all-lengths
+ collect next-start into starts
+ collect `(bit-bash-copy ,n-seq ,vector-data-bit-offset
+ res ,start ,n-length)
+ into forms
+ collect `(setq ,next-start (+ ,start ,n-length)) into forms
+ finally
+ (return
+ `(lambda (rtype ,@args)
+ (declare (ignore rtype))
+ (let* (,@lets
+ (res (make-string (truncate (the index (+ ,@all-lengths))
+ sb!vm:n-byte-bits))))
+ (declare (type index ,@all-lengths))
+ (let (,@(mapcar (lambda (name) `(,name 0)) starts))
+ (declare (type index ,@starts))
+ ,@forms)
+ res)))))
\f
;;;; CONS accessor DERIVE-TYPE optimizers
(defsetf #6=#:foo (&optional (x (return-from #6#))) ()))))
(dolist (form forms)
(assert (nth-value 2 (compile nil `(lambda () ,form))))))
+
+(assert (nth-value 2 (compile nil
+ '(lambda ()
+ (svref (make-array '(8 9) :adjustable t) 1)))))
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.0.64"
+"0.8.0.65"
projects / sbcl.git / commitdiff