From a72b7117e8f2a832f85bf18f21dbbd8e804211ec Mon Sep 17 00:00:00 2001 From: Alexey Dejneka Date: Fri, 13 Jun 2003 09:04:19 +0000 Subject: [PATCH] 0.8.0.65: * SB-CLTL2: first try on VARIABLE-INFORMATION; * MAKE-ARRAY: infer array size in complex case; * second look at CONCATENATE optimization: create new START variable for each sequence. It would be nice to write a regression test for (time (compile nil '(lambda () (list (concatenate 'string "qqqqqqqqqqqqqqqqqqqqqq" "tttttttttttttttttttttttttt" "wwwwwwwwwwwwwwwwwwwwwwwwwwww"))))) --- BUGS | 59 +++++++++++--------------------- contrib/sb-cltl2/defpackage.lisp | 11 +++++- contrib/sb-cltl2/env.lisp | 69 ++++++++++++++++++++++++++++++++++++++ contrib/sb-cltl2/sb-cltl2.asd | 3 +- src/compiler/array-tran.lisp | 13 +++---- src/compiler/seqtran.lisp | 52 ++++++++++++++-------------- tests/compiler.pure.lisp | 4 +++ version.lisp-expr | 2 +- 8 files changed, 135 insertions(+), 78 deletions(-) create mode 100644 contrib/sb-cltl2/env.lisp diff --git a/BUGS b/BUGS index 534f427..2227e4c 100644 --- a/BUGS +++ b/BUGS @@ -672,44 +672,6 @@ WORKAROUND: :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 - #)[:EXTERNAL] - - In recent SBCL the following example also illustrates this bug: - (time (compile nil '(lambda () @@ -1064,8 +1026,25 @@ WORKAROUND: 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-#: diff --git a/contrib/sb-cltl2/defpackage.lisp b/contrib/sb-cltl2/defpackage.lisp index b335da2..bd948b3 100644 --- a/contrib/sb-cltl2/defpackage.lisp +++ b/contrib/sb-cltl2/defpackage.lisp @@ -1,4 +1,13 @@ (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 + )) diff --git a/contrib/sb-cltl2/env.lisp b/contrib/sb-cltl2/env.lisp new file mode 100644 index 0000000..0abdf8c --- /dev/null +++ b/contrib/sb-cltl2/env.lisp @@ -0,0 +1,69 @@ +(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))) diff --git a/contrib/sb-cltl2/sb-cltl2.asd b/contrib/sb-cltl2/sb-cltl2.asd index 470e821..e6ecbd3 100644 --- a/contrib/sb-cltl2/sb-cltl2.asd +++ b/contrib/sb-cltl2/sb-cltl2.asd @@ -5,7 +5,8 @@ :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)) diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index adca769..3bce548 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -111,11 +111,10 @@ (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)) @@ -140,9 +139,7 @@ (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) diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 647a862..df274b1 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -721,33 +721,31 @@ (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))))) ;;;; CONS accessor DERIVE-TYPE optimizers diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 19ddd19..b56ba99 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -419,3 +419,7 @@ (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))))) diff --git a/version.lisp-expr b/version.lisp-expr index 69a80d6..fadec12 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; 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" -- 1.7.10.4