You can subscribe to this list here.
2002 |
Jan
|
Feb
|
Mar
(23) |
Apr
(68) |
May
(99) |
Jun
(109) |
Jul
(112) |
Aug
(104) |
Sep
(177) |
Oct
(211) |
Nov
(162) |
Dec
(135) |
---|---|---|---|---|---|---|---|---|---|---|---|---|
2003 |
Jan
(126) |
Feb
(228) |
Mar
(238) |
Apr
(299) |
May
(257) |
Jun
(283) |
Jul
(192) |
Aug
(227) |
Sep
(295) |
Oct
(202) |
Nov
(180) |
Dec
(70) |
2004 |
Jan
(88) |
Feb
(73) |
Mar
(133) |
Apr
(141) |
May
(205) |
Jun
(130) |
Jul
(148) |
Aug
(247) |
Sep
(228) |
Oct
(175) |
Nov
(158) |
Dec
(222) |
2005 |
Jan
(159) |
Feb
(96) |
Mar
(145) |
Apr
(192) |
May
(132) |
Jun
(190) |
Jul
(194) |
Aug
(280) |
Sep
(195) |
Oct
(207) |
Nov
(154) |
Dec
(101) |
2006 |
Jan
(156) |
Feb
(110) |
Mar
(261) |
Apr
(183) |
May
(148) |
Jun
(133) |
Jul
(94) |
Aug
(141) |
Sep
(137) |
Oct
(111) |
Nov
(172) |
Dec
(124) |
2007 |
Jan
(111) |
Feb
(72) |
Mar
(155) |
Apr
(286) |
May
(138) |
Jun
(170) |
Jul
(129) |
Aug
(156) |
Sep
(170) |
Oct
(90) |
Nov
(119) |
Dec
(112) |
2008 |
Jan
(135) |
Feb
(102) |
Mar
(115) |
Apr
(42) |
May
(132) |
Jun
(106) |
Jul
(94) |
Aug
(67) |
Sep
(33) |
Oct
(123) |
Nov
(54) |
Dec
(219) |
2009 |
Jan
(143) |
Feb
(168) |
Mar
(68) |
Apr
(142) |
May
(224) |
Jun
(202) |
Jul
(83) |
Aug
(86) |
Sep
(68) |
Oct
(37) |
Nov
(93) |
Dec
(80) |
2010 |
Jan
(39) |
Feb
(76) |
Mar
(144) |
Apr
(141) |
May
(27) |
Jun
(70) |
Jul
(23) |
Aug
(155) |
Sep
(152) |
Oct
(167) |
Nov
(87) |
Dec
(12) |
2011 |
Jan
(18) |
Feb
(39) |
Mar
(18) |
Apr
(27) |
May
(45) |
Jun
(135) |
Jul
(31) |
Aug
(82) |
Sep
(14) |
Oct
(60) |
Nov
(112) |
Dec
(117) |
2012 |
Jan
(15) |
Feb
(4) |
Mar
(30) |
Apr
(62) |
May
(45) |
Jun
(30) |
Jul
(9) |
Aug
(23) |
Sep
(41) |
Oct
(56) |
Nov
(35) |
Dec
(43) |
2013 |
Jan
(19) |
Feb
(41) |
Mar
(31) |
Apr
(28) |
May
(109) |
Jun
(90) |
Jul
(24) |
Aug
(37) |
Sep
(52) |
Oct
(45) |
Nov
(58) |
Dec
(35) |
2014 |
Jan
(24) |
Feb
(48) |
Mar
(93) |
Apr
(100) |
May
(204) |
Jun
(107) |
Jul
(85) |
Aug
(89) |
Sep
(79) |
Oct
(70) |
Nov
(92) |
Dec
(54) |
2015 |
Jan
(100) |
Feb
(103) |
Mar
(94) |
Apr
(77) |
May
(96) |
Jun
(63) |
Jul
(116) |
Aug
(76) |
Sep
(81) |
Oct
(269) |
Nov
(253) |
Dec
(143) |
2016 |
Jan
(78) |
Feb
(150) |
Mar
(151) |
Apr
(107) |
May
(52) |
Jun
(49) |
Jul
(71) |
Aug
(68) |
Sep
(127) |
Oct
(95) |
Nov
(73) |
Dec
(106) |
2017 |
Jan
(224) |
Feb
(144) |
Mar
(144) |
Apr
(99) |
May
(84) |
Jun
(112) |
Jul
(136) |
Aug
(200) |
Sep
(206) |
Oct
(255) |
Nov
(210) |
Dec
(324) |
2018 |
Jan
(289) |
Feb
(140) |
Mar
(223) |
Apr
(171) |
May
(174) |
Jun
(131) |
Jul
(108) |
Aug
(139) |
Sep
(126) |
Oct
(142) |
Nov
(109) |
Dec
(195) |
2019 |
Jan
(129) |
Feb
(102) |
Mar
(120) |
Apr
(157) |
May
(126) |
Jun
(99) |
Jul
(102) |
Aug
(117) |
Sep
(128) |
Oct
(143) |
Nov
(153) |
Dec
(156) |
2020 |
Jan
(139) |
Feb
(149) |
Mar
(251) |
Apr
(175) |
May
(140) |
Jun
(117) |
Jul
(140) |
Aug
(209) |
Sep
(194) |
Oct
(160) |
Nov
(177) |
Dec
(170) |
2021 |
Jan
(41) |
Feb
(126) |
Mar
(155) |
Apr
(152) |
May
(150) |
Jun
(116) |
Jul
(54) |
Aug
(151) |
Sep
(102) |
Oct
(182) |
Nov
(230) |
Dec
(161) |
2022 |
Jan
(213) |
Feb
(164) |
Mar
(206) |
Apr
(232) |
May
(219) |
Jun
(196) |
Jul
(177) |
Aug
(142) |
Sep
(179) |
Oct
(161) |
Nov
(165) |
Dec
(212) |
2023 |
Jan
(265) |
Feb
(98) |
Mar
(149) |
Apr
(87) |
May
(110) |
Jun
(207) |
Jul
(176) |
Aug
(223) |
Sep
(136) |
Oct
(117) |
Nov
(202) |
Dec
(217) |
2024 |
Jan
(228) |
Feb
(246) |
Mar
(254) |
Apr
|
May
|
Jun
|
Jul
|
Aug
|
Sep
|
Oct
|
Nov
|
Dec
|
From: Douglas K. <sn...@us...> - 2014-07-30 12:36:17
|
The branch "master" has been updated in SBCL: via 35884f663327cf173a89b55e0054197a2ef21cba (commit) from 28c92ea34cbb243e471d3dbd05efa71732183c76 (commit) - Log ----------------------------------------------------------------- commit 35884f663327cf173a89b55e0054197a2ef21cba Author: Douglas Katzman <do...@go...> Date: Wed Jul 30 02:11:48 2014 -0400 Avoid a GETHASH in constructor for each subtype of CTYPE. --- src/code/late-type.lisp | 3 +- src/code/type-class.lisp | 79 +++++++++++++++++++++++++++++++++++++--------- src/code/typedefs.lisp | 12 +++---- 3 files changed, 70 insertions(+), 24 deletions(-) diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index d140740..b9245d5 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -38,8 +38,7 @@ ;;; chance to run, instead of immediately returning NIL, T. (defun delegate-complex-subtypep-arg2 (type1 type2) (let ((subtypep-arg1 - (type-class-complex-subtypep-arg1 - (type-class-info type1)))) + (type-class-complex-subtypep-arg1 (type-class-info type1)))) (if subtypep-arg1 (funcall subtypep-arg1 type1 type2) (values nil t)))) diff --git a/src/code/type-class.lisp b/src/code/type-class.lisp index f9704f9..3cacc48 100644 --- a/src/code/type-class.lisp +++ b/src/code/type-class.lisp @@ -13,15 +13,56 @@ (!begin-collecting-cold-init-forms) -(defvar *type-classes*) -(!cold-init-forms - (unless (boundp '*type-classes*) ; FIXME: How could this be bound? - (setq *type-classes* (make-hash-table :test 'eq)))) +;; We can't make an instance of any CTYPE descendant until its type-class +;; exists in *TYPE-CLASSES* and the random state has been made. +;; By initializing the random state and type-class storage vector at once, +;; it is obvious that either both have been made or neither one has been. +;; As such, a type-class need never call MAKE-RANDOM-STATE in its constructor. +;; FIXME: the random state is shared across all threads and works only +;; by accident of the fact that the PRNG doesn't suffer "hard" failure from +;; multiple writers. +#-sb-xc +(progn (defvar *type-random-state* (make-random-state)) + (defvar *type-classes* (make-array 20 :fill-pointer 0))) +#+sb-xc +(macrolet ((def () + (let ((n (length *type-classes*))) + `(progn + (declaim (type random-state *type-random-state*) + (type (simple-vector ,n) *type-classes*)) + ;; The value forms are for type-correctness only. + ;; COLD-INIT-FORMS will already have been run. + (defglobal *type-random-state* (make-random-state)) + (defglobal *type-classes* (make-array ,n)) + (!cold-init-forms + (setq *type-random-state* (make-random-state) + *type-classes* (make-array ,n))))))) + (def)) (defun type-class-or-lose (name) - (or (gethash name *type-classes*) + (or (find name *type-classes* :key #'type-class-name) (error "~S is not a defined type class." name))) +#-sb-xc-host +(define-compiler-macro type-class-or-lose (&whole form name) + ;; If NAME is a quoted constant, the resultant form should be + ;; a fixed index into *TYPE-CLASSES* except that during the building + ;; of the cross-compiler the array hasn't been populated yet. + ;; One solution to that, which I favored, is that DEFINE-TYPE-CLASS + ;; appear before the structure definition that uses the corresponding + ;; type-class in its slot initializer. That posed a problem for + ;; the :INHERITS option, because the constructor of a descendant + ;; grabs all the methods [sic] from its ancestor at the time the + ;; descendant is defined, which means the methods of the ancestor + ;; should have been filled in, which means at least one DEFINE-TYPE-CLASS + ;; wants to appear _after_ a structure definition that uses it. + (if (constantp name) + (let ((name (constant-form-value name))) + `(aref *type-classes* + ,(or (position name *type-classes* :key #'type-class-name) + (error "~S is not a defined type class." name)))) + form)) + (defun must-supply-this (&rest foo) (/show0 "failing in MUST-SUPPLY-THIS") (error "missing type method for ~S" foo)) @@ -36,7 +77,7 @@ (print-unreadable-object (x stream :type t) (prin1 (type-class-name x) stream))))) ;; the name of this type class (used to resolve references at load time) - (name nil :type symbol) ; FIXME: should perhaps be (MISSING-ARG) default? + (name (missing-arg) :type symbol) ;; Dyadic type methods. If the classes of the two types are EQ, then ;; we call the SIMPLE-xxx method. If the classes are not EQ, and ;; either type's class has a COMPLEX-xxx method, then we call it. @@ -113,6 +154,7 @@ (coerce :type (or symbol null)) |# ) +#!-sb-fluid (declaim (freeze-type type-class)) (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun !type-class-fun-slot (name) @@ -133,15 +175,22 @@ ',name))) (defmacro !define-type-class (name &key inherits) - `(!cold-init-forms - ,(once-only ((n-class (if inherits - `(copy-structure (type-class-or-lose - ',inherits)) - '(make-type-class)))) - `(progn - (setf (type-class-name ,n-class) ',name) - (setf (gethash ',name *type-classes*) ,n-class) - ',name)))) + (let ((make-it + (if inherits + `(let ((class (copy-structure (type-class-or-lose ',inherits)))) + (setf (type-class-name class) ',name) + class) + `(make-type-class :name ',name)))) + #-sb-xc + `(progn + (eval-when (:compile-toplevel :load-toplevel :execute) + (unless (find ',name *type-classes* :key #'type-class-name) + (vector-push-extend ,make-it *type-classes*)))) + #+sb-xc + `(!cold-init-forms + (setf (svref *type-classes* + ,(position name *type-classes* :key #'type-class-name)) + ,make-it)))) ;;; Invoke a type method on TYPE1 and TYPE2. If the two types have the ;;; same class, invoke the simple method. Otherwise, invoke any diff --git a/src/code/typedefs.lisp b/src/code/typedefs.lisp index bfb0416..ab4ecd8 100644 --- a/src/code/typedefs.lisp +++ b/src/code/typedefs.lisp @@ -59,8 +59,6 @@ ',name)))) -(defvar *type-random-state*) - ;;; the base class for the internal representation of types (def!struct (ctype (:conc-name type-) (:constructor nil) @@ -72,6 +70,10 @@ ;; named TYPE-CLASS-INFO which is an accessor for the CTYPE structure ;; even though the TYPE-CLASS structure also exists in the system. ;; Rename this slot: TYPE-CLASS or ASSOCIATED-TYPE-CLASS or something. + ;; [or TYPE-VTABLE or TYPE-METHODS either of which basically equates + ;; a type-class with the set of things it can do, while avoiding + ;; ambiguity to whether it is a 'CLASS-INFO' slot in a 'TYPE' + ;; or an 'INFO' slot in a 'TYPE-CLASS'] (class-info (missing-arg) :type type-class) ;; True if this type has a fixed number of members, and as such ;; could possibly be completely specified in a MEMBER type. This is @@ -82,11 +84,7 @@ ;; In the target lisp, we could grab some bits of the address and assign ;; them into this slot rather than use RANDOM. The object isn't created ;; yet, so there's a chicken-and-egg issue to solve. - (hash-value (random #.(ash 1 28) - (if (boundp '*type-random-state*) - *type-random-state* - (setf *type-random-state* - (make-random-state)))) + (hash-value (random #.(ash 1 28) *type-random-state*) :type (and fixnum unsigned-byte) :read-only t) ;; Can this object contain other types? A global property of our ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2014-07-30 04:02:40
|
The branch "master" has been updated in SBCL: via 28c92ea34cbb243e471d3dbd05efa71732183c76 (commit) from 623d15fa9e04f958ad597ffd10b7170edbdcc87e (commit) - Log ----------------------------------------------------------------- commit 28c92ea34cbb243e471d3dbd05efa71732183c76 Author: Douglas Katzman <do...@go...> Date: Wed Jul 30 00:01:40 2014 -0400 Disable inapplicable test if no sb-unicode feature --- tests/type.pure.lisp | 4 ++-- 1 files changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/type.pure.lisp b/tests/type.pure.lisp index 24369fb..38dc75c 100644 --- a/tests/type.pure.lisp +++ b/tests/type.pure.lisp @@ -549,8 +549,8 @@ (try '(vector t) 'simple-vector) (try 'bit-vector 'simple-bit-vector) (try 'string 'simple-string) - (try 'base-string 'simple-base-string) - (try 'character-string 'simple-character-string)) + #+sb-unicode(try 'character-string 'simple-character-string) + (try 'base-string 'simple-base-string)) ;; if X is a known string and not an array-header ;; it must be a SIMPLE-STRING ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2014-07-30 03:11:56
|
The branch "master" has been updated in SBCL: via 623d15fa9e04f958ad597ffd10b7170edbdcc87e (commit) from 71e1bd4be8be59a647763eb346e81e32192ebcab (commit) - Log ----------------------------------------------------------------- commit 623d15fa9e04f958ad597ffd10b7170edbdcc87e Author: Douglas Katzman <do...@go...> Date: Tue Jul 29 23:09:48 2014 -0400 Type-class lint removal - HAS-SUPERCLASSES-COMPLEX-SUBTYPEP-ARG1 is runtime, not bootstrap-only - KEY-INFO structure slots must be read-only due to caching - CONTAINS-UNKNOWN-TYPE-P could combine two cases --- src/code/late-type.lisp | 14 ++++++-------- 1 files changed, 6 insertions(+), 8 deletions(-) diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index bf9c9c9..d140740 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -51,17 +51,15 @@ (defun contains-unknown-type-p (ctype) (cond ((unknown-type-p ctype) t) - ((intersection-type-p ctype) - (some #'contains-unknown-type-p (intersection-type-types ctype))) - ((union-type-p ctype) - (some #'contains-unknown-type-p (union-type-types ctype))) + ((compound-type-p ctype) + (some #'contains-unknown-type-p (compound-type-types ctype))) ((negation-type-p ctype) (contains-unknown-type-p (negation-type-type ctype))))) ;;; This is used by !DEFINE-SUPERCLASSES to define the SUBTYPE-ARG1 ;;; method. INFO is a list of conses ;;; (SUPERCLASS-CLASS . {GUARD-TYPE-SPECIFIER | NIL}). -(defun !has-superclasses-complex-subtypep-arg1 (type1 type2 info) +(defun has-superclasses-complex-subtypep-arg1 (type1 type2 info) ;; If TYPE2 might be concealing something related to our class ;; hierarchy (if (type-might-contain-other-types-p type2) @@ -110,7 +108,7 @@ ',specs))) (setf (type-class-complex-subtypep-arg1 ,type-class) (lambda (type1 type2) - (!has-superclasses-complex-subtypep-arg1 type1 type2 ,info))) + (has-superclasses-complex-subtypep-arg1 type1 type2 ,info))) (setf (type-class-complex-subtypep-arg2 ,type-class) #'delegate-complex-subtypep-arg2) (setf (type-class-complex-intersection2 ,type-class) @@ -136,9 +134,9 @@ (defstruct (key-info #-sb-xc-host (:pure t) (:copier nil)) ;; the key (not necessarily a keyword in ANSI Common Lisp) - (name (missing-arg) :type symbol) + (name (missing-arg) :type symbol :read-only t) ;; the type of the argument value - (type (missing-arg) :type ctype)) + (type (missing-arg) :type ctype :read-only t)) (!define-type-method (values :simple-subtypep :complex-subtypep-arg1) (type1 type2) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2014-07-30 02:40:56
|
The branch "master" has been updated in SBCL: via 71e1bd4be8be59a647763eb346e81e32192ebcab (commit) from 437490ed66172686a3f9d1d264b66fa2cfb2bb8e (commit) - Log ----------------------------------------------------------------- commit 71e1bd4be8be59a647763eb346e81e32192ebcab Author: Douglas Katzman <do...@go...> Date: Tue Jul 29 22:36:07 2014 -0400 Implement another atomic globaldb (INFO) primitive operation. --- src/compiler/globaldb.lisp | 20 +++++++++++++++ src/compiler/info-vector.lisp | 42 ++++++++++++++++++++++++++++++- tests/info.impure.lisp | 54 +++++++++++++++++++++++++++++++++++++++++ 3 files changed, 114 insertions(+), 2 deletions(-) diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp index ce8ab0b..9e4f485 100644 --- a/src/compiler/globaldb.lisp +++ b/src/compiler/globaldb.lisp @@ -414,6 +414,26 @@ (dx-flet ((,proc () ,creation-form)) (%get-info-value-initializing ,name ,type-number #',proc))))) +;; interface to %ATOMIC-SET-INFO-VALUE +;; GET-INFO-VALUE-INITIALIZING is a restricted case of this, +;; and perhaps could be implemented as such. +;; Atomic update will be important for making the fasloader threadsafe +;; using a predominantly lock-free design, and other nice things. +(def!macro atomic-set-info-value (info-class info-type name lambda) + (with-unique-names (type-number proc) + `(let ((,type-number + ,(if (and (keywordp info-type) (keywordp info-class)) + (type-info-number (type-info-or-lose info-class info-type)) + `(type-info-number + (type-info-or-lose ,info-class ,info-type))))) + ,(if (and (listp lambda) (eq (car lambda) 'lambda)) + ;; rewrite as FLET because the compiler is unable to dxify + ;; (DX-LET ((x (LAMBDA <whatever>))) (F x)) + (destructuring-bind (lambda-list . body) (cdr lambda) + `(dx-flet ((,proc ,lambda-list ,@body)) + (%atomic-set-info-value ,name ,type-number #',proc))) + `(%atomic-set-info-value ,name ,type-number ,lambda))))) + ;; Call FUNCTION once for each Name in globaldb that has information associated ;; with it, passing the function the Name as its only argument. ;; diff --git a/src/compiler/info-vector.lisp b/src/compiler/info-vector.lisp index e7529e1..ae8b048 100644 --- a/src/compiler/info-vector.lisp +++ b/src/compiler/info-vector.lisp @@ -1164,8 +1164,8 @@ This is interpreted as ;;; the cell contents does not affecting the globaldb. In contrast, ;;; (INCF (INFO :function :full-calls myname)) would perform poorly. ;;; -;;; See also ATOMICALLY-GET-OR-PUT-SYMBOL-INFO for atomic -;;; read/modify/write operations. +;;; See also ATOMIC-SET-INFO-VALUE and GET-INFO-VALUE-INITIALIZING +;;; for atomic read/modify/write operations. ;;; ;;; Return the new value so that this can be conveniently used in a ;;; SETF function. @@ -1197,6 +1197,44 @@ This is interpreted as (info-puthash *info-environment* name #'hairy-name))))) new-value) +;; Instead of accepting a new-value, call NEW-VALUE-FUN to compute it +;; from the existing value. The function receives two arguments: +;; if there was already a value, that value and T; otherwise two NILs. +;; Return the newly-computed value. If NEW-VALUE-FUN returns the old value +;; (compared by EQ) when there was one, then no globaldb update is made. +(defun %atomic-set-info-value (name type-number new-value-fun) + (declare (function new-value-fun)) + (when (typep name 'fixnum) + (error "~D is not a legal INFO name." name)) + (let ((name (uncross name)) new-value) + (dx-flet ((augment (vect aux-key) ; VECT is a packed vector, never NIL + (declare (simple-vector vect)) + (let ((index + (packed-info-value-index vect aux-key type-number))) + (if (not index) + (packed-info-insert + vect aux-key type-number + (setq new-value (funcall new-value-fun nil nil))) + (let ((oldval (svref vect index))) + (setq new-value (funcall new-value-fun oldval t)) + (if (eq new-value oldval) + vect ; return the old vector + (let ((copy (copy-seq vect))) + (setf (svref copy index) new-value) + copy))))))) + (with-globaldb-name (key1 key2) name + :simple + ;; UPDATE-SYMBOL-INFO never supplies OLD-INFO as NIL. + (dx-flet ((simple-name (old-info) (augment old-info key2))) + (update-symbol-info key1 #'simple-name)) + :hairy + ;; INFO-PUTHASH supplies NIL for OLD-INFO if NAME was absent. + (dx-flet ((hairy-name (old-info) + (augment (or old-info +nil-packed-infos+) + +no-auxilliary-key+))) + (info-puthash *info-environment* name #'hairy-name)))) + new-value)) + ;; %GET-INFO-VALUE-INITIALIZING is provided as a low-level operation similar ;; to the above because it does not require info metadata for defaulting, ;; nor deal with the keyword-based info type designators at all. diff --git a/tests/info.impure.lisp b/tests/info.impure.lisp index 180677e..e30a12a 100644 --- a/tests/info.impure.lisp +++ b/tests/info.impure.lisp @@ -549,4 +549,58 @@ (aref output name-index)) random-results))))))))) +;; As explained in the comments at the top of 'info-vector.lisp', +;; it is a bad idea to use globaldb to store an atomic counter as +;; a piece of info for a name, as it is quite brutal and consy, +;; but for this test, that's precisely the goal. +;; This test conses ~5 Megabytes on 64-bit almost entirely due +;; to allocation of each immutable info storage vector. +(test-util:with-test (:name :get-info-value-updating + :skipped-on '(not :sb-thread)) + (flet ((run (names) + (declare (simple-vector names)) + (let* ((n (length names)) + (counts (make-array n :element-type 'sb-ext:word)) + (threads)) + (dotimes (i 15) + (push (sb-thread:make-thread + (lambda () + (dotimes (iter 1000) + ;; increment (:variable :macro-expansion) + ;; for a randomly chosen name. That particular + ;; info-type harmlessly accepts any data type. + (let* ((index (random n)) + (name (aref names index))) + (atomic-incf (aref counts index)) + ;; should probably be SB-INT: + (sb-c::atomic-set-info-value + :variable :macro-expansion name + (lambda (old old-p) + (if old-p (1+ old) 1)))) + ;; randomly touch an item of info + ;; for another (or the same) name. + (let* ((index (random n)) + (name (aref names index))) + ;; source-location also accepts anything :-( + (setf (info :type :source-location name) iter))))) + threads)) + (mapc #'sb-thread:join-thread threads) + ;; assert that no updates were lost + (loop for name across names + for count across counts + for val = (info :variable :macro-expansion name) + do (assert (eql (or val 0) count)))))) + ;; Try it when names are symbols or "simple" 2-list names + (run (coerce (loop repeat 50 + for sym = (gensym) + nconc (list `(setf ,sym) sym)) + 'vector)) + ;; For hairy names, the tricky piece is in the rehash algorithm, + ;; but there's no way to stress-test that because *INFO-ENVIRONMENT* + ;; would have to keep doubling in size. To that end, it would have to begin + ;; as a tiny table again, but it can't, without destroying the Lisp runtime. + ;; The :lockfree-hash-concurrent-twiddling test should give high confidence + ;; that it works, by creating and testing a standalone hash-table. + (run (coerce (loop repeat 50 collect `(foo ,(gensym) hair)) 'vector)))) + ;;; success ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2014-07-29 22:35:11
|
The branch "master" has been updated in SBCL: via 437490ed66172686a3f9d1d264b66fa2cfb2bb8e (commit) from 0ad7c5ca279e332b616666e92782ca1ec8e15f16 (commit) - Log ----------------------------------------------------------------- commit 437490ed66172686a3f9d1d264b66fa2cfb2bb8e Author: Douglas Katzman <do...@go...> Date: Tue Jul 29 18:31:58 2014 -0400 Fix discrepancies in handling toplevel forms per CLHS 3.2.3.1 This patch makes compiler macros be consistently used in file compilation subject of course to the stipulation that NOTINLINE disables them. Previously the main compiler didn't use a compiler-macro if a global functoid was both a macro and compiler-macro, and the use was toplevel. The fopcompiler never used compiler-macros, toplevel or not. Such behavior was opaque and inexplicable to users except by an explanation involving discussion of the loader's DSL and what it is capable of versus truly compiled - i.e. assembly language - code. Even to document the kinds of forms that are amenable to fop compilation as a "remedy" to this issue would be a brittle one. --- src/compiler/fopcompile.lisp | 17 ++++++++-- src/compiler/ir1tran.lisp | 44 +++++++++++++++----------- src/compiler/main.lisp | 10 +++++- tests/fopcompiler.impure-cload.lisp | 48 +++++++++++++++++++++++++++++ tests/fopcompiler.impure.lisp | 58 +++++++++++++++++++++++++--------- 5 files changed, 138 insertions(+), 39 deletions(-) diff --git a/src/compiler/fopcompile.lisp b/src/compiler/fopcompile.lisp index 9187c2b..683c70c 100644 --- a/src/compiler/fopcompile.lisp +++ b/src/compiler/fopcompile.lisp @@ -50,6 +50,10 @@ (member kind '(:special :constant :global :unknown)))))) (and (listp form) (ignore-errors (list-length form)) + (let ((macroexpansion (expand-compiler-macro form))) + (if (neq macroexpansion form) + (return-from fopcompilable-p (fopcompilable-p macroexpansion)) + t)) (multiple-value-bind (macroexpansion macroexpanded-p) (%macroexpand form *lexenv*) (if macroexpanded-p @@ -124,7 +128,7 @@ ;; DECLARE would violate a package lock. (not (eq operator 'declare)) (not (special-operator-p operator)) - (not (macro-function operator)) + (not (macro-function operator)) ; redundant check ;; We can't FOP-FUNCALL with more than 255 ;; parameters. (We could theoretically use ;; APPLY, but then we'd need to construct @@ -274,6 +278,11 @@ path for-value-p)))))))))) ((listp form) + (let ((macroexpansion (expand-compiler-macro form))) + (if (neq macroexpansion form) + ;; could expand into an atom, so start from the top + (return-from fopcompile + (fopcompile macroexpansion path for-value-p)))) (multiple-value-bind (macroexpansion macroexpanded-p) (%macroexpand form *lexenv*) (if macroexpanded-p @@ -291,9 +300,9 @@ ((function) (fopcompile-function (second form) path for-value-p)) ;; KLUDGE! SB!C:SOURCE-LOCATION calls are normally handled - ;; by a compiler-macro. Doing general compiler-macro - ;; expansion in the fopcompiler is probably not sensible, - ;; so we'll just special-case it. + ;; by a compiler-macro. But if SPACE > DEBUG we choose not + ;; to record locations, which is strange because the main + ;; compiler does not have similar logic afaict. ((source-location) (if (policy *policy* (and (> space 1) (> space debug))) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 374942c..99d616b 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -732,34 +732,42 @@ (values (sb!xc:compiler-macro-function opname *lexenv*) opname) (values nil nil)))) +;;; If FORM has a usable compiler macro, use it; otherwise return FORM itself. +;;; Return the name of the compiler-macro as a secondary value, if applicable. +(defun expand-compiler-macro (form) + (multiple-value-bind (cmacro-fun cmacro-fun-name) + (find-compiler-macro (car form) form) + (if (and cmacro-fun + ;; CLHS 3.2.2.1.3 specifies that NOTINLINE + ;; suppresses compiler-macros. + (not (fun-lexically-notinline-p cmacro-fun-name))) + (values (handler-case (careful-expand-macro cmacro-fun form t) + (compiler-macro-keyword-problem (c) + (print-compiler-message *error-output* "note: ~A" (list c)) + form)) + cmacro-fun-name) + (values form nil)))) + ;;; Picks off special forms and compiler-macro expansions, and hands ;;; the rest to IR1-CONVERT-COMMON-FUNCTOID (defun ir1-convert-functoid (start next result form) (let* ((op (car form)) (translator (and (symbolp op) (info :function :ir1-convert op)))) (cond (translator + ;; FIXME: redundant? A macro can not be defined in the first place. (when (sb!xc:compiler-macro-function op *lexenv*) (compiler-warn "ignoring compiler macro for special form")) (funcall translator start next result form)) (t - (multiple-value-bind (cmacro-fun cmacro-fun-name) - (find-compiler-macro op form) - (if (and cmacro-fun - ;; CLHS 3.2.2.1.3 specifies that NOTINLINE - ;; suppresses compiler-macros. - (not (fun-lexically-notinline-p cmacro-fun-name))) - (let ((res (handler-case - (careful-expand-macro cmacro-fun form t) - (compiler-macro-keyword-problem (c) - (print-compiler-message *error-output* "note: ~A" (list c)) - form)))) - (cond ((eq res form) - (ir1-convert-common-functoid start next result form op)) - (t - (unless (policy *lexenv* (zerop store-xref-data)) - (record-call cmacro-fun-name (ctran-block start) *current-path*)) - (ir1-convert start next result res)))) - (ir1-convert-common-functoid start next result form op))))))) + (multiple-value-bind (res cmacro-fun-name) + (expand-compiler-macro form) + (cond ((eq res form) + (ir1-convert-common-functoid start next result form op)) + (t + (unless (policy *lexenv* (zerop store-xref-data)) + (record-call cmacro-fun-name (ctran-block start) + *current-path*)) + (ir1-convert start next result res)))))))) ;;; Handles the "common" cases: any other forms except special forms ;;; and compiler-macros. diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 1faddd6..8f735fc 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -1000,8 +1000,16 @@ necessary, since type inference may take arbitrarily long to converge.") ;;; Macroexpand FORM in the current environment with an error handler. ;;; We only expand one level, so that we retain all the intervening -;;; forms in the source path. +;;; forms in the source path. A compiler-macro takes precedence over +;;; an ordinary macro as specified in CLHS 3.2.3.1 +;;; Note that this function is _only_ for processing of toplevel forms. +;;; Non-toplevel forms use IR1-CONVERT-FUNCTOID which considers compiler macros. (defun preprocessor-macroexpand-1 (form) + (if (listp form) + (let ((expansion (expand-compiler-macro form))) + (if (neq expansion form) + (return-from preprocessor-macroexpand-1 + (values expansion t))))) (handler-case (%macroexpand-1 form *lexenv*) (error (condition) (compiler-error "(during macroexpansion of ~A)~%~A" diff --git a/tests/fopcompiler.impure-cload.lisp b/tests/fopcompiler.impure-cload.lisp index 09e06c8..35ec45f 100644 --- a/tests/fopcompiler.impure-cload.lisp +++ b/tests/fopcompiler.impure-cload.lisp @@ -93,3 +93,51 @@ (let* ((x (bar (foo))) (y (bar (x foo)))) (bar (y x foo)))) + +;;; Some tests involving compiler-macros. + +(defvar *cmacro-result* nil) + +(defun baz (x) (declare (ignore x))) + +;; functional foo - a function with a compiler-macro +(defun ffoo (x) (push `(regular-ffoo ,x) *cmacro-result*)) +(define-compiler-macro ffoo (x) + `(push `(cmacro-ffoo ,,x) *cmacro-result*)) + +;; macro foo - a macro with a compiler-macro +(defmacro mfoo (x) `(push `(regular-mfoo ,,x) *cmacro-result*)) +(define-compiler-macro mfoo (x) + `(push `(cmacro-mfoo ,,x) *cmacro-result*)) + +(defun get-s () (declare (special s)) s) + +;; Verify some assumptions that the tests will test what was intended. +(eval-when (:compile-toplevel) + (let ((sb-c::*lexenv* (sb-kernel:make-null-lexenv))) + (assert (sb-c::fopcompilable-p '(baz (ffoo 3)))) + (assert (sb-c::fopcompilable-p '(baz (mfoo 3)))) + ;; The special binding of S makes these forms not fopcompilable. + (assert (not (sb-c::fopcompilable-p + '(ffoo (let ((s 3)) (declare (special s)) (get-s)))))) + (assert (not (sb-c::fopcompilable-p + '(mfoo (let ((s 3)) (declare (special s)) (get-s)))))))) + +;; fopcompilable toplevel form should execute the compiler macro +(ffoo 1) +(mfoo 1) +;; fopcompilable form expands embedded compiler-macro +(baz (ffoo 2)) +(baz (mfoo 2)) +;; not-fopcompilable toplevel form should execute the compiler macro. +;; This was ok if the toplevel call was a function with a compiler-macro, +;; but was not working for a toplevel macro having a compiler-macro. +(ffoo (let ((s 3)) (declare (special s)) (get-s))) +(mfoo (let ((s 3)) (declare (special s)) (get-s))) + +(with-test (:name :compiler-macros-at-toplevel) + ;; Now assert about the macroexpansions that happened. + (assert (equal *cmacro-result* + '((CMACRO-MFOO 3) (CMACRO-FFOO 3) + (CMACRO-MFOO 2) (CMACRO-FFOO 2) + (CMACRO-MFOO 1) (CMACRO-FFOO 1))))) diff --git a/tests/fopcompiler.impure.lisp b/tests/fopcompiler.impure.lisp index 3aa5676..0f79838 100644 --- a/tests/fopcompiler.impure.lisp +++ b/tests/fopcompiler.impure.lisp @@ -10,27 +10,53 @@ ;;;; more information. ;;; These tests don't need to be processed by the compiler before -;;; being executed. +;;; being executed, in fact mustn't go in "fopcompiler.impure-cload.lisp" +;;; because the call to COMPILE-FILE needs to be wrapped in HANDLER-BIND. (defvar *tmp-filename* "fopcompile-test.tmp") -;; Ensure we can get a style-warning about undefined functions from FOPCOMPILE. -(with-test (:name :fopcompiler-undefined-warning) - (let ((form '(defvar *foo* (i-do-not-exist)))) - ;; Assert that the test case is handled by the fopcompiler. - (let ((sb-c::*lexenv* (sb-kernel:make-null-lexenv))) - (assert (sb-c::fopcompilable-p form))) - ;; Make sure some wiseacre didn't defconstant *FOO* - (assert (eq (sb-int:info :variable :kind '*foo*) :unknown)) - ;; ... or define the I-DO-NOT-EXIST function. - (assert (eq (sb-int:info :function :where-from 'i-do-not-exist) :assumed)) +;; Assert that FORM is handled by the fopcompiler, then compile it. +(defun assert-fopcompilable-and-compile-it (form) + ;; Since FOPCOMPILABLE-P now expands compiler-macros, and the macro for + ;; SOURCE-LOCATION expands to a literal structure, we end up calling + ;; CONSTANT-FOPCOMPILABLE-P which needs *COMPILE-OBJECT* to be bound. + (let ((sb-c::*compile-object* + (sb-fasl::make-fasl-output :stream (make-broadcast-stream))) + (sb-c::*lexenv* (sb-kernel:make-null-lexenv))) + (assert (sb-c::fopcompilable-p form)) (with-open-file (stream *tmp-filename* :direction :output :if-exists :supersede) (prin1 form stream)) - (multiple-value-bind (output warningp errorp) - (compile-file *tmp-filename*) - (when output - (delete-file output)) - (assert (and warningp (not errorp)))))) + (let (warning) + (handler-bind ((warning + (lambda (c) + (when (null warning) + (setq warning c) + (muffle-warning))))) + (multiple-value-bind (output warningp errorp) + (compile-file *tmp-filename*) + (when output + (delete-file output)) + (if (and (not warningp) (not errorp)) + ;; return muffled warning, which didn't count as a warning + warning)))))) + +;; Ensure we can get a style-warning about undefined functions from FOPCOMPILE. +(with-test (:name :fopcompiler-undefined-warning) + ;; Make sure some wiseacre didn't defconstant *FOO* + (assert (eq (sb-int:info :variable :kind '*foo*) :unknown)) + ;; ... or define the I-DO-NOT-EXIST function. + (assert (eq (sb-int:info :function :where-from 'i-do-not-exist) :assumed)) + (let ((w (assert-fopcompilable-and-compile-it + '(defvar *foo* (i-do-not-exist))))) + (assert (and (typep w 'sb-int:simple-style-warning) + (eql (search "undefined" + (simple-condition-format-control w)) 0))))) + +;; Ensure that FOPCOMPILE warns about deprecated variables. +(with-test (:name :fopcompiler-deprecated-var-warning) + (assert (typep (assert-fopcompilable-and-compile-it + '(defvar *frob* (if *SHOW-ENTRY-POINT-DETAILS* 'yes 'no))) + 'sb-ext:deprecation-condition))) (ignore-errors (delete-file *tmp-filename*)) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2014-07-29 12:55:28
|
The branch "master" has been updated in SBCL: via 0ad7c5ca279e332b616666e92782ca1ec8e15f16 (commit) from 0d0927a469f608fe95fcd8b8d0258a931e992fb9 (commit) - Log ----------------------------------------------------------------- commit 0ad7c5ca279e332b616666e92782ca1ec8e15f16 Author: Douglas Katzman <do...@go...> Date: Tue Jul 29 08:54:26 2014 -0400 SETQ of a :global variable is fopcompilable. --- src/compiler/fopcompile.lisp | 14 ++++++-------- 1 files changed, 6 insertions(+), 8 deletions(-) diff --git a/src/compiler/fopcompile.lisp b/src/compiler/fopcompile.lisp index 50bec1e..9187c2b 100644 --- a/src/compiler/fopcompile.lisp +++ b/src/compiler/fopcompile.lisp @@ -85,15 +85,13 @@ ((if) (and (<= 2 (length args) 3) (every #'fopcompilable-p args))) - ;; Allow SETQ only on special variables + ;; Allow SETQ only on special or global variables ((setq) (loop for (name value) on args by #'cddr - unless (and (symbolp name) - (let ((kind (info :variable :kind name))) - (eq kind :special)) - (fopcompilable-p value)) - return nil - finally (return t))) + always (and (symbolp name) + (member (info :variable :kind name) + '(:special :global)) + (fopcompilable-p value)))) ;; The real toplevel form processing has already been ;; done, so EVAL-WHEN handling will be easy. ((eval-when) @@ -174,7 +172,7 @@ (member (car form) '(lambda named-lambda lambda-with-lexenv)))) -;;; Check that a literal form is fopcompilable. It would not for example +;;; Check that a literal form is fopcompilable. It would not be, for example, ;;; when the form contains structures with funny MAKE-LOAD-FORMS. (defun constant-fopcompilable-p (constant) (let ((xset (alloc-xset))) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2014-07-28 23:03:16
|
The branch "master" has been updated in SBCL: via 0d0927a469f608fe95fcd8b8d0258a931e992fb9 (commit) from 447119c2d244f6463226eac3e49d57b72df34f78 (commit) - Log ----------------------------------------------------------------- commit 0d0927a469f608fe95fcd8b8d0258a931e992fb9 Author: Douglas Katzman <do...@go...> Date: Mon Jul 28 19:02:50 2014 -0400 Spelling fix --- src/compiler/ir1tran.lisp | 2 +- 1 files changed, 1 insertions(+), 1 deletions(-) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 82175ff..374942c 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -732,7 +732,7 @@ (values (sb!xc:compiler-macro-function opname *lexenv*) opname) (values nil nil)))) -;;; Picks of special forms and compiler-macro expansions, and hands +;;; Picks off special forms and compiler-macro expansions, and hands ;;; the rest to IR1-CONVERT-COMMON-FUNCTOID (defun ir1-convert-functoid (start next result form) (let* ((op (car form)) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2014-07-28 22:26:25
|
The branch "master" has been updated in SBCL: via 447119c2d244f6463226eac3e49d57b72df34f78 (commit) from ffdee7d37657f7a62abb029d0c6ac98302b72b18 (commit) - Log ----------------------------------------------------------------- commit 447119c2d244f6463226eac3e49d57b72df34f78 Author: Douglas Katzman <do...@go...> Date: Mon Jul 28 18:25:10 2014 -0400 x86[-64]: fix %MORE-ARG-VALUES for 'skip' operand other than zero --- src/compiler/x86-64/values.lisp | 38 +++++++++++++++++--------------------- src/compiler/x86/values.lisp | 20 +++++++------------- tests/compiler.impure.lisp | 35 +++++++++++++++++++++++++++++++++++ 3 files changed, 59 insertions(+), 34 deletions(-) diff --git a/src/compiler/x86-64/values.lisp b/src/compiler/x86-64/values.lisp index 624483b..7737118 100644 --- a/src/compiler/x86-64/values.lisp +++ b/src/compiler/x86-64/values.lisp @@ -118,29 +118,25 @@ (:generator 20 (sc-case skip (immediate - (cond ((zerop (tn-value skip)) + (if (zerop (tn-value skip)) + (move src context) + (inst lea src (make-ea :dword :base context + :disp (- (* (tn-value skip) + n-word-bytes)))))) + (any-reg + (cond ((= word-shift n-fixnum-tag-bits) (move src context) - (move count num)) + (inst sub src skip)) (t - (inst lea src (make-ea :dword :base context - :disp (- (* (tn-value skip) - n-word-bytes)))) - (move count num) - (inst sub count (* (tn-value skip) n-word-bytes))))) - - (any-reg - (move src context) - #!+#.(cl:if (cl:= sb!vm:word-shift sb!vm:n-fixnum-tag-bits) '(and) '(or)) - (inst sub src skip) - #!-#.(cl:if (cl:= sb!vm:word-shift sb!vm:n-fixnum-tag-bits) '(and) '(or)) - (progn - ;; FIXME: This can't be efficient, but LEA (my first choice) - ;; doesn't do subtraction. - (inst shl skip (- word-shift n-fixnum-tag-bits)) - (inst sub src skip) - (inst shr skip (- word-shift n-fixnum-tag-bits))) - (move count num) - (inst sub count skip))) + ;; TODO: Reducing CALL-ARGUMENTS-LIMIT to something reasonable to + ;; allow DWORD ops without it looking like a bug would make sense. + ;; With a stack size of about 2MB, the limit is absurd anyway. + (inst neg skip) + (inst lea src + (make-ea :qword :base context :index skip + :scale (ash 1 (- word-shift n-fixnum-tag-bits)))) + (inst neg skip))))) + (move count num) (inst lea loop-index (make-ea :byte :index count :scale (ash 1 (- word-shift n-fixnum-tag-bits)))) diff --git a/src/compiler/x86/values.lisp b/src/compiler/x86/values.lisp index 082ad2c..8084ac4 100644 --- a/src/compiler/x86/values.lisp +++ b/src/compiler/x86/values.lisp @@ -120,21 +120,15 @@ (:generator 20 (sc-case skip (immediate - (cond ((zerop (tn-value skip)) - (move src context) - (move count num)) - (t - (inst lea src (make-ea :dword :base context - :disp (- (* (tn-value skip) - n-word-bytes)))) - (move count num) - (inst sub count (* (tn-value skip) n-word-bytes))))) - + (if (zerop (tn-value skip)) + (move src context) + (inst lea src (make-ea :dword :base context + :disp (- (* (tn-value skip) + n-word-bytes)))))) (any-reg (move src context) - (inst sub src skip) - (move count num) - (inst sub count skip))) + (inst sub src skip))) + (move count num) (move loop-index count) (inst mov start esp-tn) diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index 7b4940e..0941359 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -2514,4 +2514,39 @@ (assert (string= (funcall f) "Weird transform answer is 14")))) +(defun skip-1-passthrough (a b sb-int:&more context count) + (declare (ignore a b)) + (multiple-value-call 'list + 'start + (sb-c::%more-arg-values context 1 (1- (truly-the fixnum count))) + 'end)) +(defun skip-2-passthrough (a b sb-int:&more context count) + (declare (ignore a b)) + (multiple-value-call 'list + 'start + (sb-c::%more-arg-values context 2 (- (truly-the fixnum count) 2)) + 'end)) +(defun skip-n-passthrough (n-skip n-copy sb-int:&more context count) + (assert (>= count (+ n-copy n-skip))) ; prevent crashes + (multiple-value-call 'list + 'start + (sb-c::%more-arg-values context n-skip n-copy) + 'end)) + +;; %MORE-ARG-VALUES was wrong on x86 and x86-64 with nonzero 'skip'. +;; It's entirely possible that other backends are also not working. +(test-util:with-test (:name more-arg-fancy) + (assert (equal (skip-1-passthrough 0 0 'a 'b 'c 'd 'e 'f) + '(start b c d e f end))) + (assert (equal (skip-2-passthrough 0 0 'a 'b 'c 'd 'e 'f) + '(start c d e f end))) + (assert (equal (skip-n-passthrough 1 5 'a 'b 'c 'd 'e 'f) + '(start b c d e f end))) + (assert (equal (skip-n-passthrough 1 5 'a 'b 'c 'd 'e 'f 'g) + '(start b c d e f end))) + (assert (equal (skip-n-passthrough 2 5 'a 'b 'c 'd 'e 'f 'g) + '(start c d e f g end))) + (assert (equal (skip-n-passthrough 2 5 'a 'b 'c 'd 'e 'f 'g 'h) + '(start c d e f g end)))) + ;;; success ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2014-07-28 21:55:28
|
The branch "master" has been updated in SBCL: via ffdee7d37657f7a62abb029d0c6ac98302b72b18 (commit) from 1c95d655b0dcc663b4ebedd6df8e17184601c31b (commit) - Log ----------------------------------------------------------------- commit ffdee7d37657f7a62abb029d0c6ac98302b72b18 Author: Douglas Katzman <do...@go...> Date: Mon Jul 28 15:00:31 2014 -0400 A CHARACTER-SET type can unparse to MEMBER, not the other way around. --- src/code/late-type.lisp | 9 ++++----- 1 files changed, 4 insertions(+), 5 deletions(-) diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 2fbc81b..bf9c9c9 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -2807,10 +2807,8 @@ used for a COMPLEX component.~:@>" (!define-type-method (member :unparse) (type) (let ((members (member-type-members type))) - (cond - ((equal members '(nil)) 'null) - ((type= type (specifier-type 'standard-char)) 'standard-char) - (t `(member ,@members))))) + (cond ((equal members '(nil)) 'null) + (t `(member ,@members))))) (!define-type-method (member :singleton-p) (type) (if (eql 1 (member-type-size type)) @@ -3432,7 +3430,8 @@ used for a COMPLEX component.~:@>" ((type= type (specifier-type 'standard-char)) 'standard-char) (t ;; Unparse into either MEMBER or CHARACTER-SET. We use MEMBER if there - ;; are at most as many characters than there are character code ranges. + ;; are at most as many characters as there are character code ranges. + ;; (basically saying to use MEMBER if each range is one character) (let* ((pairs (character-set-type-pairs type)) (count (length pairs)) (chars (loop named outer ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2014-07-28 17:42:06
|
The branch "master" has been updated in SBCL: via 1c95d655b0dcc663b4ebedd6df8e17184601c31b (commit) from 39d08435de97e2e3c0b247e9920141259abb97e1 (commit) - Log ----------------------------------------------------------------- commit 1c95d655b0dcc663b4ebedd6df8e17184601c31b Author: Douglas Katzman <do...@go...> Date: Mon Jul 28 13:11:19 2014 -0400 Improve negation method for array-types. --- src/code/late-type.lisp | 18 +++++++++++++++++- src/compiler/constraint.lisp | 2 +- tests/type.pure.lisp | 37 +++++++++++++++++++++++++++++++++++++ 3 files changed, 55 insertions(+), 2 deletions(-) diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 320891f..2fbc81b 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -2424,7 +2424,23 @@ used for a COMPLEX component.~:@>" ;; FIXME (and hint to PFD): we're vulnerable here to attacks of the ;; form "are (AND ARRAY (NOT (ARRAY T))) and (OR (ARRAY BIT) (ARRAY ;; NIL) (ARRAY CHAR) ...) equivalent?" -- CSR, 2003-12-10 - (make-negation-type :type type)) + ;; A symptom of the aforementioned is that the following are not TYPE= + ;; (AND (VECTOR T) (NOT SIMPLE-ARRAY)) ; an ARRAY-TYPE + ;; (AND (VECTOR T) (NOT SIMPLE-VECTOR)) ; an INTERSECTION-TYPE + ;; even though (VECTOR T) makes it so that the (NOT) clause in each can + ;; only provide one additional bit of information: that the vector + ;; is complex as opposed to simple. The rank and element-type are fixed. + (if (and (eq (array-type-dimensions type) '*) + (eq (array-type-complexp type) 't) + (eq (array-type-element-type type) *wild-type*)) + ;; (NOT <hairy-array>) = either SIMPLE-ARRAY or (NOT ARRAY). + ;; This is deliberately asymmetric - trying to say that NOT simple-array + ;; equals hairy-array leads to infinite recursion. + (type-union (make-array-type '* :complexp nil + :element-type *wild-type*) + (make-negation-type + :type (make-array-type '* :element-type *wild-type*))) + (make-negation-type :type type))) (!define-type-method (array :unparse) (type) (let* ((dims (array-type-dimensions type)) diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp index cd9f9f7..668988b 100644 --- a/src/compiler/constraint.lisp +++ b/src/compiler/constraint.lisp @@ -50,7 +50,7 @@ ;;; *CONSTRAINT-UNIVERSE* gets bound in IR1-PHASES to a fresh, ;;; zero-length, non-zero-total-size vector-with-fill-pointer. -(declaim (type (and vector (not simple-vector)) *constraint-universe*)) +(declaim (type (and (vector t) (not simple-array)) *constraint-universe*)) (defvar *constraint-universe*) (deftype constraint-y () '(or ctype lvar lambda-var constant)) diff --git a/tests/type.pure.lisp b/tests/type.pure.lisp index 37a71a6..24369fb 100644 --- a/tests/type.pure.lisp +++ b/tests/type.pure.lisp @@ -523,3 +523,40 @@ ;; and not *wild-type* (assert (sb-kernel:type/= (sb-kernel:array-type-specialized-element-type intersection) (sb-kernel:specifier-type 'bit))))) + +(in-package "SB-KERNEL") +(test-util:with-test (:name :partition-array-into-simple/hairy) + ;; Some tests that (simple-array | hairy-array) = array + ;; At present this works only for wild element-type. + (multiple-value-bind (eq winp) + (type= (specifier-type '(not (and array (not simple-array)))) + (specifier-type '(or (not array) simple-array))) + (assert (and eq winp))) + + ;; if X is neither simple-array nor hairy-array, it is not an array + (assert (type= (specifier-type '(and (not simple-array) + (not (and array (not simple-array))))) + (specifier-type '(not array)))) + + ;; (simple-array * (*)) = (AND (NOT <hairy-array>) VECTOR) etc + (flet ((try (unrestricted simple) + (assert (type= (specifier-type simple) + (type-intersection + (specifier-type + '(not (and array (not simple-array)))) + (specifier-type unrestricted)))))) + (try 'vector '(simple-array * (*))) + (try '(vector t) 'simple-vector) + (try 'bit-vector 'simple-bit-vector) + (try 'string 'simple-string) + (try 'base-string 'simple-base-string) + (try 'character-string 'simple-character-string)) + + ;; if X is a known string and not an array-header + ;; it must be a SIMPLE-STRING + (assert (type= (type-intersection + (specifier-type 'string) + (specifier-type + '(not (or (and simple-array (not vector)) + (and array (not simple-array)))))) + (specifier-type 'simple-string)))) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Christophe R. <cr...@us...> - 2014-07-28 11:05:43
|
The branch "master" has been updated in SBCL webpage: from b97931c3c6281b9350f7d7dab3806bf0b7ece2b7 (commit) - Log ----------------------------------------------------------------- commit 73e85ba4d93713ee2331815955c83b9197759dd1 Author: Christophe Rhodes <cs...@ca...> Date: Mon Jul 28 12:05:35 2014 +0100 Update for 1.2.2 --- platform-support-platforms.lisp | 2 +- sbcl | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/platform-support-platforms.lisp b/platform-support-platforms.lisp index f52650e..8b5be94 100644 --- a/platform-support-platforms.lisp +++ b/platform-support-platforms.lisp @@ -24,7 +24,7 @@ (define-status :not-applicable "not-applicable" "No such system" " ") (define-port :x86 :linux :available "1.0.58") -(define-port :x86-64 :linux :available "1.2.1") +(define-port :x86-64 :linux :available "1.2.2") (define-port :armel :linux :available "1.2.1") (define-port :armhf :linux :available "1.2.1") (define-port :powerpc :linux :available "1.0.28") diff --git a/sbcl b/sbcl index e568bbc..39d0843 160000 --- a/sbcl +++ b/sbcl @@ -1 +1 @@ -Subproject commit e568bbccb4858a16592f0241c9e5239066a016ef +Subproject commit 39d08435de97e2e3c0b247e9920141259abb97e1 ----------------------------------------------------------------------- hooks/post-receive -- SBCL webpage |
From: Christophe R. <cr...@us...> - 2014-07-28 10:49:40
|
The annotated tag "sbcl-1.2.2" has been created in SBCL: at 1ce3283119f10bdbd89786baded4b574c2efef5b (tag) tagging 39d08435de97e2e3c0b247e9920141259abb97e1 (commit) replaces sbcl-1.2.1 tagged by Christophe Rhodes on Mon Jul 28 10:14:59 2014 +0000 - Log ----------------------------------------------------------------- changes in sbcl-1.2.2 relative to sbcl-1.2.1: * incompatible change: the #\` ("backquote") reader macro was reimplemented to support robust pretty-printing. Reading a form involving #\` produces an invocation of the QUASIQUOTE ordinary macro which may contain subforms that are not lists. Code that unportably attempts operations on un-evaluated forms resulting therefrom, e.g. (SUBST a b (read-from-string "`(x (,y))")) might generate incorrect results and/or errors. * enhancement: support for GNU/kFreeBSD x86. * enhancement: ATOMIC-INCF and ATOMIC-DECF can operate on (CAR x), (CDR x) and DEFGLOBAL variables of type fixnum. * enhancement: arithmetic constant reduction is now performed on defconstant constants too. (lp#1337069). * bug fix: certain ftype proclamations containing &optional t &rest t no longer cause subsequent definitions to signal bogus style-warnings. * bug fix: #\Bell and #\Bel now read to different characters. (lp#1319452). * bug fix: CAS SYMBOL-VALUE on locally special variables didn't work. (lp#1098355) -----BEGIN PGP SIGNATURE----- Version: GnuPG v1.4.10 (GNU/Linux) iQEcBAABCgAGBQJT1iKkAAoJEOvVlakQDWPNR2MH/RURmCRlatosE0gT90BxqJeT KyFJc/NPd+UYuwJfyYW9UQhbanN7GcHOCOsZ0tlxoufaGnr0dXbC4LY4MabvtOup hi4iCpb55oinNMC+ZuBbesLODZkLIww0ONcdHdGDihxB8Haz1Srz0scsKTZ1pd68 VYznMhXn8l/YczYQ4ziQPzzm+IwNvd403KsdkStHF/5WzblPZOfsXDx9/gOsIXn/ cWkxHelGG+xmZMlw5xdL8LBbnVEbPBE05+eef2zQZXqs69NOl3gR7H1DOr+nS7Kq FXYJvpStHkYaJvw1z8zCUE4JtOOVahVSx4oylCKGs2cjL0g3No/IC5f9mX3iBrw= =zbZZ -----END PGP SIGNATURE----- Christophe Rhodes (3): restore clisp buildability really fix clisp build 1.2.2: will be tagged as "sbcl-1.2.2" Douglas Katzman (49): Remove unnecessary cases from PCL-INSTANCE-P Don't cons in INITIAL-THREAD-FUNCTION-TRAMPOLINE before clearing *gc-inhibit* More improvements to DEFINE-HASH-CACHE / DEFUN-CACHED De-cruft CLEAN-UP-PACK-STRUCTURES. Empty bit vectors are not a problem. Delete duplicate DEFTYPE INLINEP. Move comments to the first occurrence. Handle additional generalized places in ATOMIC-{INCF,DECF} Don't warn about everything from 'setf-funs' in the cross-compiler Combine the special-form-constantp hash-tables into one. Get rid of a bunch of useless gensyms from the image Make specialized vector treatment in cross-compilation more consistent. Avoid calling SEQUENCEP in the XEP for some seq-dispatching functions. Remove 15K lines of useless noise, revealing the interesting noise Refactor SEQUENCEP and EXTENDED-SEQUENCE-P Minor tweak to instance TYPEP transforms. Refactor INTERN and FIND-SYMBOL. Threadsafe most-recently-used package optimization in FIND-SYMBOL* Shorten TYPEP test on stream and condition types. Express print-object on a PACKAGE more concisely. Fix RANDOMLY-PUNTING-LAMBDA - the sign bit is not random. "Downgrade" FIXME comment. It's not broken, just complicated. Freeze CLASSOID-CELL type. Remove unused macro. Improve STRING= on x86[-64] by using memcmp() sometimes. Avoid globaldb hashtable for some PCL generalized function names Replace CLEAR-INFO-VALUE with CLEAR-INFO-VALUES Change how the reader records escaped characters. Some reader cleanups. Consistently pass a readtable to the character attribute testers. Tweak %INSTANCE-TYPEP deftransform a little more: x86-64: Allow constant TNs for CMOV. Also unbreak "chill" Pedantically replace many uses of :EOF, NIL, and *EOF-OBJECT* with +EOF+. Update some internal notes Recognize NOTINLINE in IR2-CONVERT-GLOBAL-VAR. Fix comments: STRING-INPUT-STREAM-STRING is read-only and simple. Freeze INTERPRETED-FUNCTION type Add expected results for #\` expansion incl. pvk's change f2503917. Fix indentation Store unibyte mapping tables more densely by specializing the vectors. The long-awaited backquote patch. Add a minor FIXME for a whole bunch of style-warnings Fix some style warnings in tests Fix regression due to 7cdfa1f6 Allow declarations in DEFOPTIMIZER. Don't auto-ignoreable-ize vars. Fix parsing of type-specifier (MEMBER 0.0 -0.0 FOO) Correctly spell what I think was supposed to be "MUMBLE" Suppress spurious type-check in hash-cache functions Don't need *TYPE-CLASS-FUN-SLOTS* Various type-class cleanups. Re-un-break hash-cach profiling, and adjust whitespace. Undo premature optimization from change b821d53b Jan Moringen (6): Section on writing tests in HACKING Fix typo in compiler note in SB-PCL:CAN-OPTIMIZE-ACCESS Remove duplicate invalid-superclass handling in SHARED-INITIALIZE :AFTER STD-CLASS Fix &OPTIONAL + &REST handling in FIND-OPTIONAL-DISPATCH-TYPES Fix ftype proclamation and definition of ASSERT[-SYMBOL-HOME]-PACKAGE-UNLOCKED Fix typo in NEWS Paul Khuong (1): Restore CCL bootstrap Stas Boukarev (15): Optimize (EQUAL[P] "" ...). Optimize (string= (the string string) ""). Add a comment to x86-64/pred.lisp:move-if. Optimize (LOGIOR SIGNED UNSIGNED) on x86-64. Don't alias #\Bell to #\Bel. Fix CAS SYMBOL-VALUE for locally special variables. Optimize (- (the (integer 0 2^63) x)) on x86-64. Add FAST-NEGATE/UNSIGNED VOP to x86 and ARM. Optimize (LOGIOR SIGNED UNSIGNED) on x86 and ARM. Clean up *.exe files from tools-for-build/ Don't transpose sole constants within arithmetic functions. Reduce +constants+ for arithmetic functions. Fix GNU/kFreeBSD x86-64 and add x86 support. Fix handling of do_pending_interrupt on ARM. Fix sigtrap_handler on ARM. ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Christophe R. <cr...@us...> - 2014-07-28 10:49:32
|
The branch "master" has been updated in SBCL: via 39d08435de97e2e3c0b247e9920141259abb97e1 (commit) from 80e9a6e539a9b0bd158d2d382ac59ce388e9df6c (commit) - Log ----------------------------------------------------------------- commit 39d08435de97e2e3c0b247e9920141259abb97e1 Author: Christophe Rhodes <cs...@ca...> Date: Mon Jul 28 10:14:59 2014 +0000 1.2.2: will be tagged as "sbcl-1.2.2" --- NEWS | 2 +- 1 files changed, 1 insertions(+), 1 deletions(-) diff --git a/NEWS b/NEWS index 4935b59..8aa2dfc 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,5 @@ ;;;; -*- coding: utf-8; fill-column: 78 -*- -changes relative to sbcl-1.2.1: +changes in sbcl-1.2.2 relative to sbcl-1.2.1: * incompatible change: the #\` ("backquote") reader macro was reimplemented to support robust pretty-printing. Reading a form involving #\` produces an invocation of the QUASIQUOTE ordinary macro which may contain subforms ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2014-07-21 19:36:24
|
The branch "master" has been updated in SBCL: via 80e9a6e539a9b0bd158d2d382ac59ce388e9df6c (commit) from 4f2f8417a5ed2f9e026011a81e6018377193ca8b (commit) - Log ----------------------------------------------------------------- commit 80e9a6e539a9b0bd158d2d382ac59ce388e9df6c Author: Douglas Katzman <do...@go...> Date: Mon Jul 21 14:49:52 2014 -0400 Undo premature optimization from change b821d53b --- src/code/pred.lisp | 27 +++++++++++++++++++++++---- tests/seq.impure.lisp | 3 +++ 2 files changed, 26 insertions(+), 4 deletions(-) diff --git a/src/code/pred.lisp b/src/code/pred.lisp index 8e3ef55..1998662 100644 --- a/src/code/pred.lisp +++ b/src/code/pred.lisp @@ -46,14 +46,33 @@ (t (return-from extended-sequence-p nil))))) (when (layout-invalid layout) (setq layout (update-object-layout-or-invalid x slayout))) - ;; It's impossible to create an instance which is exactly + ;; It's _nearly_ impossible to create an instance which is exactly ;; of type SEQUENCE. To wit: (make-instance 'sequence) => ;; "Cannot allocate an instance of #<BUILT-IN-CLASS SEQUENCE>." - ;; So we do not need to check for that. Just use the 'inherits' vector. + ;; We should not need to check for that, just the 'inherits' vector. + ;; However, bootstrap code does a sleazy thing, making an instance of + ;; the abstract base type which is impossible for user code to do. + ;; Preferably the prototype instance for SEQUENCE would be one that could + ;; exist, so it would be a STANDARD-OBJECT and SEQUENCE. But it's not. + ;; Hence we have to check for a layout that no code using the documented + ;; sequence API would ever see, just to get the boundary case right. + ;; Note also: + ;; - Some builtins use a prototype object that is strictly deeper than + ;; layout of the named class because it is indeed the case that no + ;; object's layout can ever be EQ to that of the ancestor. + ;; e.g. a fixnum as representative of class REAL + ;; - Some builtins actually fail (TYPEP (CLASS-PROTOTYPE X) X) + ;; but that's not an excuse for getting SEQUENCE wrong: + ;; (CLASS-PROTOTYPE (FIND-CLASS 'FLOAT)) => 42 + ;; (CLASS-PROTOTYPE (FIND-CLASS 'VECTOR)) => 42 + ;; (CLASS-PROTOTYPE (FIND-CLASS 'LIST)) => 42 + ;; (CLASS-PROTOTYPE (FIND-CLASS 'STRING)) => 42 (let ((inherits (layout-inherits (truly-the layout layout)))) (declare (optimize (safety 0))) - (and (> (length inherits) depthoid) - (eq (svref inherits depthoid) slayout))))) + (if (and (> (length inherits) depthoid) + (eq (svref inherits depthoid) slayout)) + t + (eq layout slayout))))) ;;; Is X a SEQUENCE? Harder than just (OR VECTOR LIST) (defun sequencep (x) diff --git a/tests/seq.impure.lisp b/tests/seq.impure.lisp index bbc8b15..dc29ada 100644 --- a/tests/seq.impure.lisp +++ b/tests/seq.impure.lisp @@ -1293,4 +1293,7 @@ (with-test (:name :generic-sequence-reverse) (assert-error (reverse (make-instance 'bogus-reversal-seq)))) +(with-test (:name :abstract-base-sequence-satisfies-sequencep) + (assert (typep (sb-pcl::class-prototype (find-class 'sequence)) 'sequence))) + ;;; success ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2014-07-21 15:51:15
|
The branch "master" has been updated in SBCL: via 4f2f8417a5ed2f9e026011a81e6018377193ca8b (commit) from bc18b32a6ff053c1a80754f273a23d8e618744bf (commit) - Log ----------------------------------------------------------------- commit 4f2f8417a5ed2f9e026011a81e6018377193ca8b Author: Douglas Katzman <do...@go...> Date: Mon Jul 21 11:50:17 2014 -0400 Re-un-break hash-cach profiling, and adjust whitespace. --- src/code/early-extensions.lisp | 26 +++++++++++++------------- 1 files changed, 13 insertions(+), 13 deletions(-) diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 531a945..87e4839 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -659,8 +659,6 @@ (return-from ,fun-name (values ,@result-temps)))))) (setq ,hashval (ash ,hashval ,(- hash-bits))))))) - ,@(when *profile-hash-cache* - `((incf (aref ,statistics-name 1)))) ; count misses (multiple-value-bind ,result-temps (funcall ,thunk) (let ((,entry (,(let ((*package* (symbol-package 'alloc-hash-cache))) @@ -672,11 +670,13 @@ (or ,cache (alloc-hash-cache ,size ',var-name)))) (idx1 (ldb (byte ,hash-bits 0) ,hashval)) (idx2 (ldb (byte ,hash-bits ,hash-bits) ,hashval))) - (cond ((eql (svref ,cache idx1) 0) - (setf (svref ,cache idx1) ,entry)) - ((eql (svref ,cache idx2) 0) - (setf (svref ,cache idx2) ,entry)) - (t + ,@(when *profile-hash-cache* + `((incf (aref ,statistics-name 1)))) ; count misses + (cond ((eql (svref ,cache idx1) 0) + (setf (svref ,cache idx1) ,entry)) + ((eql (svref ,cache idx2) 0) + (setf (svref ,cache idx2) ,entry)) + (t ,@(when *profile-hash-cache* ; count evictions `((incf (aref ,statistics-name 2)))) ;; Use one bit of randomness to pick a victim. @@ -1519,14 +1519,14 @@ to :INTERPRET, an interpreter will be used.") '(defun show-hash-cache-statistics () (flet ((cache-stats (symbol) (let* ((name (string symbol)) + (statistics (let ((*package* (symbol-package symbol))) + (symbolicate symbol "STATISTICS"))) (prefix (subseq name 0 (- (length name) (length "VECTOR**"))))) - (values - (handler-case - (symbol-value (let ((*package* (symbol-package symbol))) - (symbolicate symbol "STATISTICS"))) - (unbound-symbol-error () (make-array 3 :element-type 'fixnum))) - (subseq prefix 2 (1- (length prefix))))))) + (values (if (boundp statistics) + (symbol-value statistics) + (make-array 3 :element-type 'fixnum)) + (subseq prefix 2 (1- (length prefix))))))) (format t "~%Type function memoization:~% Seek Hit (%)~: Evict (%) Size full~%") ;; Sort by descending seek count to rank by likely relative importance ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2014-07-19 20:29:03
|
The branch "master" has been updated in SBCL: via bc18b32a6ff053c1a80754f273a23d8e618744bf (commit) from 87e94cc05ec1ada53f46978896c3b7ba2c5953a1 (commit) - Log ----------------------------------------------------------------- commit bc18b32a6ff053c1a80754f273a23d8e618744bf Author: Douglas Katzman <do...@go...> Date: Sat Jul 19 14:19:57 2014 -0400 Various type-class cleanups. - For descendants of ctype other than classoid, make all slots readonly. - Don't "hand-roll" an array-type using COPY-STRUCTURE. - Make the DIMENSIONS argument to MAKE-ARRAY-TYPE a positional arg. --- src/code/alien-type.lisp | 2 +- src/code/cross-type.lisp | 2 +- src/code/early-type.lisp | 42 ++++++++++++++++++------------------ src/code/late-type.lisp | 20 ++++++++--------- src/code/target-type.lisp | 2 +- src/compiler/generic/vm-type.lisp | 4 +- src/compiler/ir1opt.lisp | 1 - src/compiler/knownfun.lisp | 20 +++++++++-------- 8 files changed, 46 insertions(+), 47 deletions(-) diff --git a/src/code/alien-type.lisp b/src/code/alien-type.lisp index b0aeb65..7cd968c 100644 --- a/src/code/alien-type.lisp +++ b/src/code/alien-type.lisp @@ -22,7 +22,7 @@ (class-info (type-class-or-lose 'alien))) (:constructor %make-alien-type-type (alien-type)) (:copier nil)) - (alien-type nil :type alien-type)) + (alien-type nil :type alien-type :read-only t)) (!define-type-class alien) diff --git a/src/code/cross-type.lisp b/src/code/cross-type.lisp index ab29c1e..18d4727 100644 --- a/src/code/cross-type.lisp +++ b/src/code/cross-type.lisp @@ -440,7 +440,7 @@ (array ;; It is critical not to inquire of the host for the array's element type. (let ((etype (specifier-type (!specialized-array-element-type x)))) - (make-array-type :dimensions (array-dimensions x) + (make-array-type (array-dimensions x) ;; complexp relies on the host implementation, ;; but in practice any array for which we need to ;; call ctype-of will be a simple-array. diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp index cdc0818..be7fb4a 100644 --- a/src/code/early-type.lisp +++ b/src/code/early-type.lisp @@ -24,7 +24,7 @@ (:copier nil) #!+cmu (:pure nil)) ;; the Common Lisp type-specifier of the type we represent - (specifier nil :type t)) + (specifier nil :type t :read-only t)) (!define-type-class hairy) @@ -62,7 +62,7 @@ (might-contain-other-types-p t)) (:copier nil) #!+cmu (:pure nil)) - (type (missing-arg) :type ctype)) + (type (missing-arg) :type ctype :read-only t)) (!define-type-class negation) @@ -72,16 +72,16 @@ (:constructor nil) (:copier nil)) ;; Lists of the type for each required and optional argument. - (required nil :type list) - (optional nil :type list) + (required nil :type list :read-only t) + (optional nil :type list :read-only t) ;; The type for the rest arg. NIL if there is no &REST arg. - (rest nil :type (or ctype null)) + (rest nil :type (or ctype null) :read-only t) ;; true if &KEY arguments are specified - (keyp nil :type boolean) + (keyp nil :type boolean :read-only t) ;; list of KEY-INFO structures describing the &KEY arguments - (keywords nil :type list) + (keywords nil :type list :read-only t) ;; true if other &KEY arguments are allowed - (allowp nil :type boolean)) + (allowp nil :type boolean :read-only t)) (defun canonicalize-args-type-args (required optional rest &optional keyp) (when (eq rest *empty-type*) @@ -194,10 +194,10 @@ nil rest))))) ;; true if the arguments are unrestrictive, i.e. * - (wild-args nil :type boolean) + (wild-args nil :type boolean :read-only t) ;; type describing the return values. This is a values type ;; when multiple values were specified for the return. - (returns (missing-arg) :type ctype)) + (returns (missing-arg) :type ctype :read-only t)) ;;; The CONSTANT-TYPE structure represents a use of the CONSTANT-ARG ;;; "type specifier", which is only meaningful in function argument @@ -209,7 +209,7 @@ (:copier nil)) ;; The type which the argument must be a constant instance of for this type ;; specifier to win. - (type (missing-arg) :type ctype)) + (type (missing-arg) :type ctype :read-only t)) ;;; The NAMED-TYPE is used to represent *, T and NIL, the standard ;;; special cases, as well as other special cases needed to @@ -223,7 +223,7 @@ (defstruct (named-type (:include ctype (class-info (type-class-or-lose 'named))) (:copier nil)) - (name nil :type symbol)) + (name nil :type symbol :read-only t)) ;;; a list of all the float "formats" (i.e. internal representations; ;;; nothing to do with #'FORMAT), in order of decreasing precision @@ -362,17 +362,19 @@ ;;; things such as SIMPLE-BASE-STRING. (defstruct (array-type (:include ctype (class-info (type-class-or-lose 'array))) - (:constructor %make-array-type) + (:constructor %make-array-type + (dimensions &key complexp element-type + specialized-element-type)) (:copier nil)) ;; the dimensions of the array, or * if unspecified. If a dimension ;; is unspecified, it is *. - (dimensions '* :type (or list (member *))) + (dimensions '* :type (or list (member *)) :read-only t) ;; Is this not a simple array type? (:MAYBE means that we don't know.) - (complexp :maybe :type (member t nil :maybe)) + (complexp :maybe :type (member t nil :maybe) :read-only t) ;; the element type as originally specified - (element-type (missing-arg) :type ctype) + (element-type (missing-arg) :type ctype :read-only t) ;; the element type as it is specialized in this implementation - (specialized-element-type *wild-type* :type ctype)) + (specialized-element-type *wild-type* :type ctype :read-only t)) (define-cached-synonym make-array-type) ;;; A MEMBER-TYPE represent a use of the MEMBER type specifier. We @@ -384,8 +386,8 @@ (:copier nil) (:constructor %make-member-type (xset fp-zeroes)) #-sb-xc-host (:pure nil)) - (xset (missing-arg) :type xset) - (fp-zeroes (missing-arg) :type list)) + (xset (missing-arg) :type xset :read-only t) + (fp-zeroes (missing-arg) :type list :read-only t)) (defun make-member-type (&key xset fp-zeroes members) (unless xset (aver (not fp-zeroes)) @@ -511,8 +513,6 @@ cdr-type)) (:copier nil)) ;; the CAR and CDR element types (to support ANSI (CONS FOO BAR) types) - ;; - ;; FIXME: Most or all other type structure slots could also be :READ-ONLY. (car-type (missing-arg) :type ctype :read-only t) (cdr-type (missing-arg) :type ctype :read-only t)) (defun make-cons-type (car-type cdr-type) diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 1595ea4..320891f 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -1603,7 +1603,7 @@ (neltype (array-type-element-type ntype))) (if (and (eql ndims '*) (null ncomplexp) (eql neltype *wild-type*) (eql nseltype *wild-type*)) - (make-array-type :dimensions (array-type-dimensions type1) + (make-array-type (array-type-dimensions type1) :complexp t :element-type (array-type-element-type type1) :specialized-element-type (array-type-specialized-element-type type1))))) @@ -2702,8 +2702,7 @@ used for a COMPLEX component.~:@>" (not (eq result-eltype :incompatible)) (unite-array-types-supertypes-compatible-p eltype-supertype complexp-supertype dimensions-supertype)) - (make-array-type - :dimensions result-dimensions + (make-array-type result-dimensions :complexp result-complexp :element-type result-eltype :specialized-element-type result-stype)))))) @@ -2719,12 +2718,11 @@ used for a COMPLEX component.~:@>" (eltype2 (array-type-element-type type2)) (stype1 (array-type-specialized-element-type type1)) (stype2 (array-type-specialized-element-type type2))) - (make-array-type - :dimensions (cond ((eq dims1 '*) dims2) - ((eq dims2 '*) dims1) - (t - (mapcar (lambda (x y) (if (eq x '*) y x)) - dims1 dims2))) + (make-array-type (cond ((eq dims1 '*) dims2) + ((eq dims2 '*) dims1) + (t + (mapcar (lambda (x y) (if (eq x '*) y x)) + dims1 dims2))) :complexp (if (eq complexp1 :maybe) complexp2 complexp1) :element-type (cond ((eq eltype1 *wild-type*) eltype2) @@ -3587,7 +3585,7 @@ used for a COMPLEX component.~:@>" (let ((eltype (if (eq element-type '*) *wild-type* (specifier-type element-type)))) - (make-array-type :dimensions (canonical-array-dimensions dimensions) + (make-array-type (canonical-array-dimensions dimensions) :complexp :maybe :element-type eltype :specialized-element-type (%upgraded-array-element-type @@ -3598,7 +3596,7 @@ used for a COMPLEX component.~:@>" (let ((eltype (if (eq element-type '*) *wild-type* (specifier-type element-type)))) - (make-array-type :dimensions (canonical-array-dimensions dimensions) + (make-array-type (canonical-array-dimensions dimensions) :complexp nil :element-type eltype :specialized-element-type (%upgraded-array-element-type diff --git a/src/code/target-type.lisp b/src/code/target-type.lisp index 16ac6a7..e4d24f2 100644 --- a/src/code/target-type.lisp +++ b/src/code/target-type.lisp @@ -156,7 +156,7 @@ (ctype-of-number x)) (array (let ((etype (specifier-type (array-element-type x)))) - (make-array-type :dimensions (array-dimensions x) + (make-array-type (array-dimensions x) :complexp (not (typep x 'simple-array)) :element-type etype :specialized-element-type etype))) diff --git a/src/compiler/generic/vm-type.lisp b/src/compiler/generic/vm-type.lisp index 65cfb89..c6886c9 100644 --- a/src/compiler/generic/vm-type.lisp +++ b/src/compiler/generic/vm-type.lisp @@ -262,8 +262,8 @@ (position (array-type-specialized-element-type type) array-props :key #'sb!vm:saetp-ctype :test #'type=))) (wild (type) - (make-array-type :element-type *wild-type* - :dimensions (array-type-dimensions type) + (make-array-type (array-type-dimensions type) + :element-type *wild-type* :complexp (array-type-complexp type)))) ;; Bucket the array types by <dimensions,complexp> where each bucket ;; tracks which SAETPs were seen. diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index a9c17ca..ccd706b 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -154,7 +154,6 @@ (if (array-type-complexp type) (make-array-type ;; ADJUST-ARRAY may change dimensions, but rank stays same. - :dimensions (let ((old (array-type-dimensions type))) (if (eq '* old) old diff --git a/src/compiler/knownfun.lisp b/src/compiler/knownfun.lisp index 741fa4d..077bf5b 100644 --- a/src/compiler/knownfun.lisp +++ b/src/compiler/knownfun.lisp @@ -339,6 +339,13 @@ ;;; with the additional restriptions noted in the CLHS for STRING and ;;; SIMPLE-STRING, defined to specialize on CHARACTER, and for VECTOR ;;; (under the page for MAKE-SEQUENCE). +;;; At present this is used to derive the output type of CONCATENATE, +;;; MAKE-SEQUENCE, and MERGE. Two things seem slightly amiss: +;;; 1. The sequence type actually produced might not be exactly that specified. +;;; (TYPE-OF (MAKE-SEQUENCE '(AND (NOT SIMPLE-ARRAY) (VECTOR BIT)) 9)) +;;; => (SIMPLE-BIT-VECTOR 9) +;;; 2. Because we *know* that a hairy array won't be produced, +;;; why does derivation preserve the non-simpleness, if so specified? (defun creation-result-type-specifier-nth-arg (n) (lambda (call) (declare (type combination call)) @@ -364,15 +371,10 @@ (if (and (array-type-p ctype) (eq (array-type-specialized-element-type ctype) *wild-type*)) - ;; I don't think I'm allowed to modify what I get - ;; back from SPECIFIER-TYPE; it is, after all, - ;; cached. Better copy it, then. - (let ((real-ctype (copy-structure ctype))) - (setf (array-type-element-type real-ctype) - *universal-type* - (array-type-specialized-element-type real-ctype) - *universal-type*) - real-ctype) + (make-array-type (array-type-dimensions ctype) + :complexp (array-type-complexp ctype) + :element-type *universal-type* + :specialized-element-type *universal-type*) ctype))))))))) (defun remove-non-constants-and-nils (fun) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2014-07-19 13:12:22
|
The branch "master" has been updated in SBCL: via 87e94cc05ec1ada53f46978896c3b7ba2c5953a1 (commit) from 21d82cd3ae54663d2b627e47f6631aa4b4f12b41 (commit) - Log ----------------------------------------------------------------- commit 87e94cc05ec1ada53f46978896c3b7ba2c5953a1 Author: Douglas Katzman <do...@go...> Date: Sat Jul 19 08:19:20 2014 -0400 Don't need *TYPE-CLASS-FUN-SLOTS* --- src/code/type-class.lisp | 72 ++++----------------------------------------- 1 files changed, 7 insertions(+), 65 deletions(-) diff --git a/src/code/type-class.lisp b/src/code/type-class.lisp index 94bf055..f9704f9 100644 --- a/src/code/type-class.lisp +++ b/src/code/type-class.lisp @@ -114,67 +114,9 @@ |# ) -(eval-when (:compile-toplevel :load-toplevel :execute) - ;; KLUDGE: If the slots of TYPE-CLASS ever change, the slots here - ;; will have to be tweaked to match. -- WHN 19991021 - (defparameter *type-class-fun-slots* - '((:simple-subtypep . type-class-simple-subtypep) - (:complex-subtypep-arg1 . type-class-complex-subtypep-arg1) - (:complex-subtypep-arg2 . type-class-complex-subtypep-arg2) - (:simple-union2 . type-class-simple-union2) - (:complex-union2 . type-class-complex-union2) - (:simple-intersection2 . type-class-simple-intersection2) - (:complex-intersection2 . type-class-complex-intersection2) - (:simple-= . type-class-simple-=) - (:complex-= . type-class-complex-=) - (:negate . type-class-negate) - (:unparse . type-class-unparse) - (:singleton-p . type-class-singleton-p)))) - -(declaim (ftype (function (type-class) type-class) copy-type-class-coldly)) (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) -;;; Copy TYPE-CLASS object X, using only operations which will work -;;; early in cold load. (COPY-STRUCTURE won't work early in cold load, -;;; because it needs RAW-INDEX and RAW-LENGTH information from -;;; LAYOUT-INFO, and LAYOUT-INFO isn't initialized early in cold -;;; load.) -;;; -;;; FIXME: It's nasty having to maintain this hand-written copy -;;; function. And it seems intrinsically dain-bramaged to have -;;; RAW-INDEX and RAW-LENGTH in LAYOUT-INFO instead of directly in -;;; LAYOUT. We should fix this: -;;; * Move RAW-INDEX and RAW-LENGTH slots into LAYOUT itself. -;;; * Rewrite the various CHECK-LAYOUT-related functions so that -;;; they check RAW-INDEX and RAW-LENGTH too. -;;; * Remove this special hacked copy function, just use -;;; COPY-STRUCTURE instead. -;;; (For even more improvement, it might be good to move the raw slots -;;; into the same object as the ordinary slots, instead of having the -;;; unfortunate extra level of indirection. But that'd probably -;;; require a lot of work, including updating the garbage collector to -;;; understand it. And it might even hurt overall performance, because -;;; the positive effect of removing indirection could be cancelled by -;;; the negative effect of imposing an unnecessary GC write barrier on -;;; raw data which doesn't actually affect GC.) -(defun copy-type-class-coldly (x) - ;; KLUDGE: If the slots of TYPE-CLASS ever change in a way not - ;; reflected in *TYPE-CLASS-FUN-SLOTS*, the slots here will - ;; have to be hand-tweaked to match. -- WHN 2001-03-19 - (make-type-class :name (type-class-name x) - . #.(mapcan (lambda (type-class-fun-slot) - (destructuring-bind (keyword . slot-accessor) - type-class-fun-slot - `(,keyword (,slot-accessor x)))) - *type-class-fun-slots*))) - -(defun class-fun-slot-or-lose (name) - (or (cdr (assoc name *type-class-fun-slots*)) - (error "~S is not a defined type class method." name))) -;;; FIXME: This seems to be called at runtime by cold init code. -;;; Make sure that it's not being called at runtime anywhere but -;;; one-time toplevel initialization code. - -) ; EVAL-WHEN + (defun !type-class-fun-slot (name) + (symbolicate "TYPE-CLASS-" name))) (defmacro !define-type-method ((class method &rest more-methods) lambda-list &body body) @@ -184,7 +126,7 @@ ,@body) (!cold-init-forms ,@(mapcar (lambda (method) - `(setf (,(class-fun-slot-or-lose method) + `(setf (,(!type-class-fun-slot method) (type-class-or-lose ',class)) #',name)) (cons method more-methods))) @@ -193,7 +135,7 @@ (defmacro !define-type-class (name &key inherits) `(!cold-init-forms ,(once-only ((n-class (if inherits - `(copy-type-class-coldly (type-class-or-lose + `(copy-structure (type-class-or-lose ',inherits)) '(make-type-class)))) `(progn @@ -218,10 +160,10 @@ (default '(values nil t)) (complex-arg1 :foo complex-arg1-p)) (declare (type keyword simple complex-arg1 complex-arg2)) - (let ((simple (class-fun-slot-or-lose simple)) - (cslot1 (class-fun-slot-or-lose + (let ((simple (!type-class-fun-slot simple)) + (cslot1 (!type-class-fun-slot (if complex-arg1-p complex-arg1 complex-arg2))) - (cslot2 (class-fun-slot-or-lose complex-arg2))) + (cslot2 (!type-class-fun-slot complex-arg2))) (once-only ((ntype1 type1) (ntype2 type2)) (once-only ((class1 `(type-class-info ,ntype1)) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2014-07-19 12:01:29
|
The branch "master" has been updated in SBCL: via 21d82cd3ae54663d2b627e47f6631aa4b4f12b41 (commit) from 9b653246b47c35999c1e797885d7dcbd5fac7bdb (commit) - Log ----------------------------------------------------------------- commit 21d82cd3ae54663d2b627e47f6631aa4b4f12b41 Author: Douglas Katzman <do...@go...> Date: Sat Jul 19 07:59:20 2014 -0400 Suppress spurious type-check in hash-cache functions --- src/code/early-extensions.lisp | 10 +++++----- 1 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 573f221..531a945 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -659,8 +659,6 @@ (return-from ,fun-name (values ,@result-temps)))))) (setq ,hashval (ash ,hashval ,(- hash-bits))))))) - (unless ,cache - (setq ,cache (alloc-hash-cache ,size ',var-name))) ,@(when *profile-hash-cache* `((incf (aref ,statistics-name 1)))) ; count misses (multiple-value-bind ,result-temps (funcall ,thunk) @@ -669,9 +667,11 @@ (symbolicate "ALLOC-HASH-CACHE-LINE/" (write-to-string (+ nargs values)))) ,@arg-vars ,@result-temps)) - (idx1 (ldb (byte ,hash-bits 0) ,hashval)) - (idx2 (ldb (byte ,hash-bits ,hash-bits) ,hashval))) - (declare (type (simple-vector ,size) ,cache)) + (,cache + (truly-the ,cache-type + (or ,cache (alloc-hash-cache ,size ',var-name)))) + (idx1 (ldb (byte ,hash-bits 0) ,hashval)) + (idx2 (ldb (byte ,hash-bits ,hash-bits) ,hashval))) (cond ((eql (svref ,cache idx1) 0) (setf (svref ,cache idx1) ,entry)) ((eql (svref ,cache idx2) 0) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2014-07-19 11:51:29
|
The branch "master" has been updated in SBCL: via 9b653246b47c35999c1e797885d7dcbd5fac7bdb (commit) from 60ab8e4270658848734252e2cf8cc1dd25c01801 (commit) - Log ----------------------------------------------------------------- commit 9b653246b47c35999c1e797885d7dcbd5fac7bdb Author: Douglas Katzman <do...@go...> Date: Sat Jul 19 07:50:10 2014 -0400 Correctly spell what I think was supposed to be "MUMBLE" --- src/compiler/array-tran.lisp | 6 +++--- 1 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index 7e5e81f..1503dd1 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -1031,7 +1031,7 @@ (the index ,cumulative-offset))) (declare (type index ,cumulative-offset)))))) -(defun transform-%with-array-data/muble (array node check-fill-pointer) +(defun transform-%with-array-data/mumble (array node check-fill-pointer) (let ((element-type (upgraded-element-type-specifier-or-give-up array)) (type (lvar-type array)) (check-bounds (policy node (plusp insert-array-bounds-checks)))) @@ -1071,14 +1071,14 @@ :node node :policy (> speed space)) "inline non-SIMPLE-vector-handling logic" - (transform-%with-array-data/muble array node nil)) + (transform-%with-array-data/mumble array node nil)) (deftransform %with-array-data/fp ((array start end) ((or vector simple-array) index (or index null) t) * :node node :policy (> speed space)) "inline non-SIMPLE-vector-handling logic" - (transform-%with-array-data/muble array node t)) + (transform-%with-array-data/mumble array node t)) ;;;; array accessors ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2014-07-19 10:44:26
|
The branch "master" has been updated in SBCL: via 60ab8e4270658848734252e2cf8cc1dd25c01801 (commit) from d87f69404ab54048c5f167522f53e1a73bfc6564 (commit) - Log ----------------------------------------------------------------- commit 60ab8e4270658848734252e2cf8cc1dd25c01801 Author: Douglas Katzman <do...@go...> Date: Sat Jul 19 06:41:48 2014 -0400 Fix parsing of type-specifier (MEMBER 0.0 -0.0 FOO) --- src/code/early-type.lisp | 33 +++++++++++++++++---------------- tests/type.impure.lisp | 12 ++++++++++++ 2 files changed, 29 insertions(+), 16 deletions(-) diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp index a90860c..cdc0818 100644 --- a/src/code/early-type.lisp +++ b/src/code/early-type.lisp @@ -398,21 +398,23 @@ ;; canonicalize to (DOUBLE-FLOAT 0.0d0 0.0d0), because numeric ;; ranges are compared by arithmetic operators (while MEMBERship is ;; compared by EQL). -- CSR, 2003-04-23 - (let ((unpaired nil) + (let ((presence 0) + (unpaired nil) (union-types nil)) - (do ((tail (cdr fp-zeroes) (cdr tail)) - (zero (car fp-zeroes) (car tail))) - ((not zero)) - (macrolet ((frob (c) - `(let ((neg (neg-fp-zero zero))) - (if (member neg tail) - (push (ctype-of ,c) union-types) - (push zero unpaired))))) - (etypecase zero - (single-float (frob 0.0f0)) - (double-float (frob 0.0d0)) - #!+long-float - (long-float (frob 0.0l0))))) + (dotimes (pass 2) + (dolist (z fp-zeroes) + (let ((sign (if (minusp (nth-value 2 (integer-decode-float z))) 1 0)) + (pair-idx + (etypecase z + (single-float 0) + (double-float 2 + #!+long-float (long-float 4))))) + (if (= pass 0) + (setf (ldb (byte 1 (+ pair-idx sign)) presence) 1) + (if (eq (ldb (byte 2 pair-idx) presence) #b11) + (when (= sign 0) + (push (ctype-of z) union-types)) + (push z unpaired)))))) ;; The actual member-type contains the XSET (with no FP zeroes), ;; and a list of unpaired zeroes. (let ((member-type (unless (and (xset-empty-p xset) (not unpaired)) @@ -421,8 +423,7 @@ (make-union-type t (if member-type (cons member-type union-types) union-types))) - (member-type - member-type) + (member-type) (t *empty-type*))))) diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp index f9b6286..95c8770 100644 --- a/tests/type.impure.lisp +++ b/tests/type.impure.lisp @@ -244,6 +244,18 @@ (assert-t-t (subtypep '(float 0.0) '(float -0.0))) (assert-t-t (subtypep '(float (0.0)) '(float (-0.0)))) (assert-t-t (subtypep '(float (-0.0)) '(float (0.0)))) + +(with-test (:name :member-type-and-numeric) + ;; (MEMBER 0s0 -s0) used to appear to parse correctly, + ;; but it didn't because MAKE-MEMBER-TYPE returned a union type + ;; (OR (MEMBER 0.0) (SINGLE-FLOAT 0.0 0.0)) which was further reduced + ;; to just the numeric type, being a supertype of the singleton. + ;; The parsing problem became evident when any other member was added in, + ;; because in that case the member type is not a subtype of the numeric. + (let* ((x (sb-kernel:specifier-type '(member 0s0 foo -0s0))) + (m (find-if #'sb-kernel:member-type-p (sb-kernel:union-type-types x)))) + (assert (equal (sb-kernel:member-type-members m) '(foo))))) + ;;;; Douglas Thomas Crosher rewrote the CMU CL type test system to ;;;; allow inline type tests for CONDITIONs and STANDARD-OBJECTs, and ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2014-07-18 02:01:34
|
The branch "master" has been updated in SBCL: via d87f69404ab54048c5f167522f53e1a73bfc6564 (commit) from 8d5ef869aadadb209c3bb93525c6fd7f6d6a337a (commit) - Log ----------------------------------------------------------------- commit d87f69404ab54048c5f167522f53e1a73bfc6564 Author: Douglas Katzman <do...@go...> Date: Thu Jul 17 21:09:04 2014 -0400 Allow declarations in DEFOPTIMIZER. Don't auto-ignoreable-ize vars. --- contrib/sb-rotate-byte/compiler.lisp | 1 + package-data-list.lisp-expr | 2 +- src/compiler/aliencomp.lisp | 3 + src/compiler/array-tran.lisp | 10 ++++- src/compiler/ctype.lisp | 14 +++---- src/compiler/generic/vm-ir2tran.lisp | 12 +++++- src/compiler/generic/vm-tran.lisp | 1 + src/compiler/ir2tran.lisp | 7 +++- src/compiler/ltn.lisp | 6 +- src/compiler/macros.lisp | 78 +++++++++++++++++++-------------- src/compiler/srctran.lisp | 11 ++++- src/compiler/typetran.lisp | 1 + 12 files changed, 97 insertions(+), 49 deletions(-) diff --git a/contrib/sb-rotate-byte/compiler.lisp b/contrib/sb-rotate-byte/compiler.lisp index 0af37d7..3113dc3 100644 --- a/contrib/sb-rotate-byte/compiler.lisp +++ b/contrib/sb-rotate-byte/compiler.lisp @@ -37,6 +37,7 @@ (defoptimizer (%rotate-byte derive-type) ((count size posn num)) ;; FIXME: this looks fairly unwieldy. I'm sure it can be made ;; simpler, and also be made to deal with negative integers too. + (declare (ignore count posn)) (let ((size (sb-c::lvar-type size))) (if (numeric-type-p size) (let ((size-high (numeric-type-high size)) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 7eda4dd..c37f409 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1091,7 +1091,7 @@ possibly temporarily, because it might be used internally." "AVER" "ENFORCE-TYPE" "DX-FLET" "DX-LET" "AWHEN" "ACOND" "IT" - "BINDING*" + "BINDING*" "EXTRACT-VAR-DECLS" "!DEF-BOOLEAN-ATTRIBUTE" "QUASIQUOTE" "WITH-REBOUND-IO-SYNTAX" diff --git a/src/compiler/aliencomp.lisp b/src/compiler/aliencomp.lisp index 75e0870..a24483d 100644 --- a/src/compiler/aliencomp.lisp +++ b/src/compiler/aliencomp.lisp @@ -413,6 +413,7 @@ '(error "This should be eliminated as dead code.")))) (defoptimizer (%local-alien-addr derive-type) ((info var)) + (declare (ignore var)) (if (constant-lvar-p info) (let* ((info (lvar-value info)) (alien-type (local-alien-info-type info))) @@ -444,6 +445,7 @@ ;;;; %CAST (defoptimizer (%cast derive-type) ((alien type)) + (declare (ignore alien)) (or (when (constant-lvar-p type) (let ((alien-type (lvar-value type))) (when (alien-type-p alien-type) @@ -688,6 +690,7 @@ (defoptimizer (%alien-funcall ltn-annotate) ((function type &rest args) node ltn-policy) + (declare (ignore type ltn-policy)) (setf (basic-combination-info node) :funny) (setf (node-tail-p node) nil) (annotate-ordinary-lvar function) diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index c7f3e35..7e5e81f 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -226,7 +226,7 @@ t (give-up)))))))) -(defoptimizer (aref derive-type) ((array &rest indices) node) +(defoptimizer (aref derive-type) ((array &rest indices)) (assert-array-rank array (length indices)) (derive-aref-type array)) @@ -236,6 +236,7 @@ (macrolet ((define (name) `(defoptimizer (,name derive-type) ((array index)) + (declare (ignore index)) (derive-aref-type array)))) (define hairy-data-vector-ref) (define hairy-data-vector-ref/check-bounds) @@ -243,10 +244,12 @@ #!+(or x86 x86-64) (defoptimizer (data-vector-ref-with-offset derive-type) ((array index offset)) + (declare (ignore index offset)) (derive-aref-type array)) (macrolet ((define (name) `(defoptimizer (,name derive-type) ((array index new-value)) + (declare (ignore index)) (assert-new-value-type new-value array)))) (define hairy-data-vector-set) (define hairy-data-vector-set/check-bounds) @@ -254,6 +257,7 @@ #!+(or x86 x86-64) (defoptimizer (data-vector-set-with-offset derive-type) ((array index offset new-value)) + (declare (ignore index offset)) (assert-new-value-type new-value array)) ;;; Figure out the type of the data vector if we know the argument @@ -266,8 +270,10 @@ (array-type-specialized-element-type atype)) (*)))))) (defoptimizer (%with-array-data derive-type) ((array start end)) + (declare (ignore start end)) (derive-%with-array-data/mumble-type array)) (defoptimizer (%with-array-data/fp derive-type) ((array start end)) + (declare (ignore start end)) (derive-%with-array-data/mumble-type array)) (defoptimizer (array-row-major-index derive-type) ((array &rest indices)) @@ -275,9 +281,11 @@ *universal-type*) (defoptimizer (row-major-aref derive-type) ((array index)) + (declare (ignore index)) (derive-aref-type array)) (defoptimizer (%set-row-major-aref derive-type) ((array index new-value)) + (declare (ignore index)) (assert-new-value-type new-value array)) (defun derive-make-array-type (dims element-type adjustable diff --git a/src/compiler/ctype.lisp b/src/compiler/ctype.lisp index 1849a3b..1030449 100644 --- a/src/compiler/ctype.lisp +++ b/src/compiler/ctype.lisp @@ -969,16 +969,14 @@ (defoptimizer (%compile-time-type-error ir2-convert) ((objects atype dtype context) node block) + (declare (ignore objects)) (let ((*compiler-error-context* node)) (setf (node-source-path node) (cdr (node-source-path node))) - (destructuring-bind (values atype dtype context) - (basic-combination-args node) - (declare (ignore values)) - (let ((atype (lvar-value atype)) - (dtype (lvar-value dtype)) - (detail (cdr (lvar-value context)))) - (unless (eq atype nil) + (let ((atype (lvar-value atype)) + (dtype (lvar-value dtype)) + (detail (cdr (lvar-value context)))) + (unless (eq atype nil) (if (singleton-p detail) (let ((detail (first detail))) (if (constantp detail) @@ -998,5 +996,5 @@ "~@<Derived type of ~2I~_~{~S~^~#[~; and ~:;, ~]~} ~ ~I~_in ~2I~_~S ~I~_is ~2I~_~S, ~I~_conflicting with ~ their asserted type ~2I~_~S.~@:>" - :format-arguments (list (rest detail) (first detail) dtype atype)))))) + :format-arguments (list (rest detail) (first detail) dtype atype))))) (ir2-convert-full-call node block))) diff --git a/src/compiler/generic/vm-ir2tran.lisp b/src/compiler/generic/vm-ir2tran.lisp index 373f346..afa0c99 100644 --- a/src/compiler/generic/vm-ir2tran.lisp +++ b/src/compiler/generic/vm-ir2tran.lisp @@ -14,7 +14,9 @@ nil) #!+stack-allocatable-fixed-objects -(defoptimizer (%make-structure-instance stack-allocate-result) ((defstruct-description &rest args) node dx) +(defoptimizer (%make-structure-instance stack-allocate-result) + ((defstruct-description &rest args) node dx) + (declare (ignore args dx)) (aver (constant-lvar-p defstruct-description)) ;; A structure instance can be stack-allocated if it has no raw ;; slots, or if we're on a target with a conservatively-scavenged @@ -168,6 +170,7 @@ (defoptimizer ir2-convert-structure-allocation ((dd slot-specs &rest args) node block name words type lowtag inits) + (declare (ignore inits)) (let* ((lvar (node-lvar node)) (locs (lvar-result-tns lvar (list *backend-t-primitive-type*))) (result (first locs))) @@ -247,6 +250,7 @@ (progn (defoptimizer (allocate-vector stack-allocate-result) ((type length words) node dx) + (declare (ignorable type) (ignore length)) (and ;; Can't put unboxed data on the stack unless we scavenge it ;; conservatively. @@ -267,6 +271,7 @@ sb!vm:vector-data-offset)))))))) (defoptimizer (allocate-vector ltn-annotate) ((type length words) call ltn-policy) + (declare (ignore type length words)) (let ((args (basic-combination-args call)) (template (template-or-lose (if (awhen (node-lvar call) (lvar-dynamic-extent it)) @@ -288,16 +293,21 @@ #!+stack-allocatable-lists (progn (defoptimizer (list stack-allocate-result) ((&rest args) node dx) + (declare (ignore dx)) (not (null args))) (defoptimizer (list* stack-allocate-result) ((&rest args) node dx) + (declare (ignore dx)) (not (null (rest args)))) (defoptimizer (%listify-rest-args stack-allocate-result) ((&rest args) node dx) + (declare (ignore args dx)) t)) ;;; ...conses #!+stack-allocatable-fixed-objects (progn (defoptimizer (cons stack-allocate-result) ((&rest args) node dx) + (declare (ignore args dx)) t) (defoptimizer (%make-complex stack-allocate-result) ((&rest args) node dx) + (declare (ignore args dx)) t)) diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp index cccdd3e..70d514d 100644 --- a/src/compiler/generic/vm-tran.lisp +++ b/src/compiler/generic/vm-tran.lisp @@ -289,6 +289,7 @@ (def array-storage-vector)) (defoptimizer (%data-vector-and-index derive-type) ((array index)) + (declare (ignore index)) (let ((spec (maybe-array-data-vector-type-specifier array))) (when spec (values-specifier-type `(values ,spec index))))) diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index ad752f1..5851e02 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -302,7 +302,7 @@ (find-in-physenv what this-env))) (defoptimizer (%allocate-closures ltn-annotate) ((leaves) node ltn-policy) - ltn-policy ; a hack to effectively (DECLARE (IGNORE LTN-POLICY)) + (declare (ignore ltn-policy)) (when (lvar-dynamic-extent leaves) (let ((info (make-ir2-lvar *backend-t-primitive-type*))) (setf (ir2-lvar-kind info) :delayed) @@ -779,6 +779,7 @@ ;;; case of IR2-CONVERT-TEMPLATE is that there can be codegen-info ;;; arguments. (defoptimizer (%%primitive ir2-convert) ((template info &rest args) call block) + (declare (ignore args)) (let* ((template (lvar-value template)) (info (lvar-value info)) (lvar (node-lvar call)) @@ -799,6 +800,7 @@ (values)) (defoptimizer (%%primitive derive-type) ((template info &rest args)) + (declare (ignore info args)) (let ((type (template-type (lvar-value template)))) (if (fun-type-p type) (fun-type-returns type) @@ -1559,6 +1561,7 @@ (vop sb!vm::bind/let node block (lvar-tn node block value) name)))) (defoptimizer (%special-unbind ir2-convert) ((var) node block) + (declare (ignore var)) (vop unbind node block)) ;;; ### It's not clear that this really belongs in this file, or @@ -1717,6 +1720,7 @@ (check-catch-tag-type tag) (emit-nlx-start node block (lvar-value info-lvar) tag)) (defoptimizer (%unwind-protect ir2-convert) ((info-lvar cleanup) node block) + (declare (ignore cleanup)) (emit-nlx-start node block (lvar-value info-lvar) nil)) ;;; Emit the entry code for a non-local exit. We receive values and @@ -1850,6 +1854,7 @@ ;; just a fancy identity (defoptimizer (%typep-wrapper ir2-convert) ((value variable type) node block) + (declare (ignore variable type)) (let* ((lvar (node-lvar node)) (results (lvar-result-tns lvar (list (primitive-type-or-lose t))))) (emit-move node block (lvar-tn node block value) (first results)) diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp index 20d1099..da0a51f 100644 --- a/src/compiler/ltn.lisp +++ b/src/compiler/ltn.lisp @@ -420,7 +420,7 @@ (defoptimizer (%unwind-protect ltn-annotate) ((escape cleanup) node ltn-policy) - ltn-policy ; a hack to effectively (DECLARE (IGNORE LTN-POLICY)) + (declare (ignore escape cleanup ltn-policy)) (setf (basic-combination-info node) :funny) (setf (node-tail-p node) nil)) @@ -428,11 +428,11 @@ ;;; (Otherwise the compiler may dump its internal structures as ;;; constants :-() (defoptimizer (%pop-values ltn-annotate) ((%lvar) node ltn-policy) - %lvar node ltn-policy) + (declare (ignore %lvar node ltn-policy))) (defoptimizer (%nip-values ltn-annotate) ((last-nipped last-preserved &rest moved) node ltn-policy) - last-nipped last-preserved moved node ltn-policy) + (declare (ignore last-nipped last-preserved moved node ltn-policy))) ;;;; known call annotation diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index 596da2d..8e7f8c8 100644 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -272,9 +272,9 @@ (defun parse-deftransform (lambda-list node-var error-form) (multiple-value-bind (req opt restp rest keyp keys allowp) (parse-lambda-list lambda-list) - (let* ((all-dummies (make-gensym-list 3)) - (dummies all-dummies) - (tail (pop dummies)) + (let* ((tail (make-symbol "ARGS")) + (dummies (make-gensym-list 2)) + (all-dummies (cons tail dummies)) (keys (mapcar (lambda (spec) (multiple-value-bind (key var) (if (atom spec) @@ -291,8 +291,7 @@ ;; The way this code checks for mandatory args is to verify that ;; the last positional arg is not null (it should be an LVAR). ;; But somebody could pedantically declare IGNORE on the last arg - ;; (though we typically make them IGNORABLE), so bind a dummy for - ;; it and then bind from the dummy. + ;; so bind a dummy for it and then bind from the dummy. (mapl (lambda (args) (cond ((cdr args) (binds `(,(car args) (pop ,tail)))) @@ -319,16 +318,16 @@ ,error-form)))) (when restp (binds `(,rest ,tail))) - ;; Return list of bindings and list of ignorables. Actually the caller - ;; should make *all* bindings ignorable but might need to know the - ;; symbols from the lambda-list per se. + ;; Return list of bindings, the list of user-specified symbols, + ;; and the list of gensyms to be declared ignorable. (values (append (binds) (mapcar (lambda (k) `(,(car k) (find-keyword-lvar ,tail ',(cdr k)))) keys)) (append (nset-difference (mapcar #'car (binds)) all-dummies) - (mapcar #'car keys))))))) + (mapcar #'car keys)) + (intersection (mapcar #'car (binds)) (cdr all-dummies))))))) ) ; EVAL-WHEN ;;;; DEFTRANSFORM @@ -499,32 +498,45 @@ ;;; the rest of the optimizer function's lambda-list. LTN-ANNOTATE ;;; methods are passed an additional POLICY argument, and IR2-CONVERT ;;; methods are passed an additional IR2-BLOCK argument. -(defmacro defoptimizer (what (lambda-list &optional (n-node (sb!xc:gensym)) - &rest vars) - &body body) - (flet ((function-name (name) - (etypecase name - (symbol name) - ((cons (eql setf) (cons symbol null)) - (symbolicate (car name) "-" (cadr name)))))) - (let ((name (if (symbolp what) - what - (symbolicate (function-name (first what)) - "-" (second what) "-OPTIMIZER")))) - - (let ((binds (parse-deftransform lambda-list n-node - `(return-from ,name nil)))) - `(progn - (defun ,name (,n-node ,@vars) - (declare (ignorable ,@vars)) - (let* ,binds - (declare (ignorable ,@(mapcar #'car binds))) - ,@body)) - ,@(when (consp what) - `((setf (,(let ((*package* (symbol-package 'fun-info))) +(defmacro defoptimizer (what (lambda-list + &optional (node (sb!xc:gensym) node-p) + &rest vars) + &body body) + (binding* ((name + (flet ((function-name (name) + (etypecase name + (symbol name) + ((cons (eql setf) (cons symbol null)) + (symbolicate (car name) "-" (cadr name)))))) + (if (symbolp what) + what + (symbolicate (function-name (first what)) + "-" (second what) "-OPTIMIZER")))) + ((forms decls) (parse-body body :doc-string-allowed nil)) + ((var-decls more-decls) (extract-var-decls decls vars)) + ;; In case the BODY declares IGNORE of the formal NODE var, + ;; we rebind it from N-NODE and never reference it from BINDS. + (n-node (make-symbol "NODE")) + ((binds lambda-vars gensyms) + (parse-deftransform lambda-list n-node + `(return-from ,name nil)))) + (declare (ignore lambda-vars)) + `(progn + ;; We can't stuff the BINDS as &AUX vars into the lambda list + ;; because there can be a RETURN-FROM in there. + (defun ,name (,n-node ,@vars) + ,@(if var-decls (list var-decls)) + (let* (,@binds ,@(if node-p `((,node ,n-node)))) + ;; Syntax requires naming NODE even if undesired if VARS + ;; are present, so in that case make NODE ignorable. + (declare (ignorable ,@(if (and vars node-p) `(,node)) + ,@gensyms)) + ,@more-decls ,@forms)) + ,@(when (consp what) + `((setf (,(let ((*package* (symbol-package 'fun-info))) (symbolicate "FUN-INFO-" (second what))) (fun-info-or-lose ',(first what))) - #',name)))))))) + #',name)))))) ;;;; IR groveling macros diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 9312b4e..4292ee1 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -134,7 +134,7 @@ (1 `(cons ,(first args) nil)) (t (values nil t)))) -(defoptimizer (list derive-type) ((&rest args) node) +(defoptimizer (list derive-type) ((&rest args)) (if args (specifier-type 'cons) (specifier-type 'null))) @@ -2476,6 +2476,7 @@ #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (defoptimizer (random derive-type) ((bound &optional state)) + (declare (ignore state)) (one-arg-derive-type bound #'random-derive-type-aux nil)) ;;;; miscellaneous derive-type methods @@ -2647,6 +2648,7 @@ `(%deposit-field ,newbyte ,size ,pos ,int)))) (defoptimizer (%ldb derive-type) ((size posn num)) + (declare (ignore posn num)) (let ((size (lvar-type size))) (if (and (numeric-type-p size) (csubtypep size (specifier-type 'integer))) @@ -2657,6 +2659,7 @@ *universal-type*))) (defoptimizer (%mask-field derive-type) ((size posn num)) + (declare (ignore num)) (let ((size (lvar-type size)) (posn (lvar-type posn))) (if (and (numeric-type-p size) @@ -2703,9 +2706,11 @@ `(unsigned-byte* ,raw-bit-count))))))))) (defoptimizer (%dpb derive-type) ((newbyte size posn int)) + (declare (ignore newbyte)) (%deposit-field-derive-type-aux size posn int)) (defoptimizer (%deposit-field derive-type) ((newbyte size posn int)) + (declare (ignore newbyte)) (%deposit-field-derive-type-aux size posn int)) (deftransform %ldb ((size posn int) @@ -2764,6 +2769,7 @@ (logand int (lognot mask))))) (defoptimizer (mask-signed-field derive-type) ((size x)) + (declare (ignore x)) (let ((size (lvar-type size))) (if (numeric-type-p size) (let ((size-high (numeric-type-high size))) @@ -3155,6 +3161,7 @@ ))))))) (defoptimizer (mask-signed-field optimizer) ((width x) node) + (declare (ignore width)) (let ((result-type (single-value-type (node-derived-type node)))) (multiple-value-bind (low high) (integer-type-numeric-bounds result-type) @@ -4503,6 +4510,7 @@ :format-arguments (list nargs fun string max)))))))) (defoptimizer (format optimizer) ((dest control &rest args)) + (declare (ignore dest)) (when (constant-lvar-p control) (let ((x (lvar-value control))) (when (stringp x) @@ -4756,6 +4764,7 @@ *universal-type*))))))) (defoptimizer (compile derive-type) ((nameoid function)) + (declare (ignore function)) (when (csubtypep (lvar-type nameoid) (specifier-type 'null)) (values-specifier-type '(values function boolean boolean)))) diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp index 168016f..a03f99f 100644 --- a/src/compiler/typetran.lisp +++ b/src/compiler/typetran.lisp @@ -134,6 +134,7 @@ (defoptimizer (%typep-wrapper constraint-propagate-if) ((test-value variable type) node gen) + (declare (ignore test-value gen)) (aver (constant-lvar-p type)) (let ((type (lvar-value type))) (values variable (if (ctype-p type) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2014-07-17 02:09:16
|
The branch "master" has been updated in SBCL: via 8d5ef869aadadb209c3bb93525c6fd7f6d6a337a (commit) from 27d6427ca3ca909761438a77af6c2b25a9a847db (commit) - Log ----------------------------------------------------------------- commit 8d5ef869aadadb209c3bb93525c6fd7f6d6a337a Author: Douglas Katzman <do...@go...> Date: Wed Jul 16 22:06:22 2014 -0400 Fix regression due to 7cdfa1f6 Having changed to EXPLICIT-CHECK, the generic branch needs to perform a type-check; and I missed that it formerly discarded multiple values. --- src/code/seq.lisp | 14 ++++++++++++-- tests/seq.impure.lisp | 8 ++++++++ 2 files changed, 20 insertions(+), 2 deletions(-) diff --git a/src/code/seq.lisp b/src/code/seq.lisp index 3374fcc..afb7ae3 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -775,7 +775,14 @@ many elements are copied." (seq-dispatch-checking sequence (list-reverse* sequence) (vector-reverse* sequence) - (the sequence (sb!sequence:reverse sequence)))) + ;; The type deriver says that LIST => LIST and VECTOR => VECTOR + ;; but does not claim to know anything about extended-sequences. + ;; So this could theoretically return any subtype of SEQUENCE + ;; given an EXTENDED-SEQUENCE as input. But fndb says this returns + ;; a CONSED-SEQUENCE, which precludes non-simple vectors. + ;; But a CLOS sequence can apparently decide to return a LIST when + ;; reversed. [Is that too weird? Make this EXTENDED-SEQUENCE maybe?] + (the consed-sequence (values (sb!sequence:reverse sequence))))) ;;; internal frobs @@ -822,7 +829,10 @@ many elements are copied." (seq-dispatch-checking sequence (list-nreverse* sequence) (vector-nreverse* sequence) - (the sequence (sb!sequence:nreverse sequence)))) + ;; The type deriver for this is 'result-type-first-arg', + ;; meaning it should return definitely an EXTENDED-SEQUENCE + ;; and not a list or vector. + (the extended-sequence (values (sb!sequence:nreverse sequence))))) ;;;; CONCATENATE diff --git a/tests/seq.impure.lisp b/tests/seq.impure.lisp index 5e43627..bbc8b15 100644 --- a/tests/seq.impure.lisp +++ b/tests/seq.impure.lisp @@ -1285,4 +1285,12 @@ (with-test (:name (:bit-position :random-test)) (random-test-bit-position 10000)) +;; REVERSE and NREVERSE should assert that the returned value +;; from a generic sequence operation is of type SEQUENCE. +(defclass bogus-reversal-seq (sequence standard-object) ()) +(defmethod sequence:reverse ((self bogus-reversal-seq)) + #2a((x y) (1 2))) +(with-test (:name :generic-sequence-reverse) + (assert-error (reverse (make-instance 'bogus-reversal-seq)))) + ;;; success ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2014-07-17 01:56:54
|
The branch "master" has been updated in SBCL: via 27d6427ca3ca909761438a77af6c2b25a9a847db (commit) from 9f904c8a85b8b03fc9a091d715ca0592cf66638e (commit) - Log ----------------------------------------------------------------- commit 27d6427ca3ca909761438a77af6c2b25a9a847db Author: Douglas Katzman <do...@go...> Date: Wed Jul 16 21:56:28 2014 -0400 Fix some style warnings in tests --- tests/seq.impure.lisp | 12 +++++++----- 1 files changed, 7 insertions(+), 5 deletions(-) diff --git a/tests/seq.impure.lisp b/tests/seq.impure.lisp index b6b28bd..5e43627 100644 --- a/tests/seq.impure.lisp +++ b/tests/seq.impure.lisp @@ -58,6 +58,7 @@ (coerce base-seq type)) ((cons (eql simple-array) (cons * (cons (eql 1) null))) (destructuring-bind (eltype one) (rest type) + (declare (ignore one)) (when (entirely eltype) (coerce base-seq type)))) ((cons (eql vector)) @@ -360,8 +361,8 @@ ;;; As pointed out by Raymond Toy on #lisp IRC, MERGE had some issues ;;; with user-defined types until sbcl-0.7.8.11 +(deftype list-typeoid () 'list) (with-test (:name :merge-user-types) - (deftype list-typeoid () 'list) (assert (equal '(1 2 3 4) (merge 'list-typeoid (list 1 3) (list 2 4) '<))) ;;; and also with types that weren't precicely LIST (assert (equal '(1 2 3 4) (merge 'cons (list 1 3) (list 2 4) '<)))) @@ -1159,10 +1160,10 @@ ;;; Both :TEST and :TEST-NOT provided (with-test (:name :test-and-test-not-to-adjoin) - (let* ((wc 0) + (let* ((wc 0) ; warning counter (fun (handler-bind (((and warning (not style-warning)) - (lambda (w) (incf wc)))) + (lambda (w) (declare (ignore w)) (incf wc)))) (compile nil `(lambda (item test test-not) (adjoin item '(1 2 3 :foo) :test test :test-not test-not)))))) @@ -1183,14 +1184,15 @@ (dolist (type '(%string %simple-string string-3 simple-string-3)) (assert (string= "foo" (coerce '(#\f #\o #\o) type))) (assert (string= "foo" (map type 'identity #(#\f #\o #\o)))) - (assert (string= "foo" (merge type '(#\o) '(#\f #\o) 'char<))) + (assert (string= "foo" (merge type (copy-seq '(#\o)) (copy-seq '(#\f #\o)) + 'char<))) (assert (string= "foo" (concatenate type '(#\f) "oo"))) (assert (string= "ooo" (make-sequence type 3 :initial-element #\o))))) (with-test (:name :user-defined-string-types-map-etc-error) (dolist (type '(string-3 simple-string-3)) (assert-error (coerce '(#\q #\u #\u #\x) type)) (assert-error (map type 'identity #(#\q #\u #\u #\x))) - (assert-error (merge type '(#\q #\x) "uu" 'char<)) + (assert-error (merge type (copy-seq '(#\q #\x)) (copy-seq "uu") 'char<)) (assert-error (concatenate type "qu" '(#\u #\x))) (assert-error (make-sequence type 4 :initial-element #\u)))) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2014-07-16 02:45:44
|
The branch "master" has been updated in SBCL: via 9f904c8a85b8b03fc9a091d715ca0592cf66638e (commit) from d7265bc05d7c3ba83194cb80b3371a54d3c136e4 (commit) - Log ----------------------------------------------------------------- commit 9f904c8a85b8b03fc9a091d715ca0592cf66638e Author: Douglas Katzman <do...@go...> Date: Tue Jul 15 22:44:50 2014 -0400 Add a minor FIXME for a whole bunch of style-warnings --- src/code/numbers.lisp | 4 ++++ 1 files changed, 4 insertions(+), 0 deletions(-) diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp index 53e6d99..e375677 100644 --- a/src/code/numbers.lisp +++ b/src/code/numbers.lisp @@ -363,6 +363,10 @@ #!+sb-doc ,doc (if numbers + ;; FIXME: using NTH here produces + ;; "caught STYLE-WARNING: + ;; The binding of RESULT is not a NUMBER" + ;; Same warning occurs in -, /, =, /=, etc (do ((result (nth 0 numbers) (,op result (nth i numbers))) (i 1 (1+ i))) ((>= i (length numbers)) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2014-07-16 02:23:55
|
The branch "master" has been updated in SBCL: via d7265bc05d7c3ba83194cb80b3371a54d3c136e4 (commit) from d12f5387f9da24da72cb7cb09680ccc1d507f8d5 (commit) - Log ----------------------------------------------------------------- commit d7265bc05d7c3ba83194cb80b3371a54d3c136e4 Author: Douglas Katzman <do...@go...> Date: Tue Jul 15 14:56:53 2014 -0400 The long-awaited backquote patch. This makes the pprinter for backquote faster, safer, and less consy, and fixes lp#1063414. --- NEWS | 7 + build-order.lisp-expr | 1 - make-host-2.lisp | 9 +- package-data-list.lisp-expr | 6 +- src/code/backq.lisp | 460 +++++++++++++++++++------------------- src/code/defsetfs.lisp | 9 - src/code/early-pprint.lisp | 25 ++- src/code/pp-backq.lisp | 124 ---------- src/code/pprint.lisp | 57 +++--- src/code/reader.lisp | 9 + src/code/sharpm.lisp | 41 ++-- src/compiler/array-tran.lisp | 9 +- src/compiler/fndb.lisp | 12 +- src/compiler/seqtran.lisp | 15 +- src/pcl/defs.lisp | 6 +- src/pcl/env.lisp | 4 + tests/backq.impure.lisp | 47 +++- tests/dynamic-extent.impure.lisp | 17 +- tests/pprint.impure.lisp | 9 +- tests/walk.impure.lisp | 3 + 20 files changed, 396 insertions(+), 474 deletions(-) diff --git a/NEWS b/NEWS index 1fdcd28..4935b59 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,12 @@ ;;;; -*- coding: utf-8; fill-column: 78 -*- changes relative to sbcl-1.2.1: + * incompatible change: the #\` ("backquote") reader macro was reimplemented + to support robust pretty-printing. Reading a form involving #\` produces + an invocation of the QUASIQUOTE ordinary macro which may contain subforms + that are not lists. Code that unportably attempts operations on + un-evaluated forms resulting therefrom, e.g. + (SUBST a b (read-from-string "`(x (,y))")) + might generate incorrect results and/or errors. * enhancement: support for GNU/kFreeBSD x86. * enhancement: ATOMIC-INCF and ATOMIC-DECF can operate on (CAR x), (CDR x) and DEFGLOBAL variables of type fixnum. diff --git a/build-order.lisp-expr b/build-order.lisp-expr index dc7fd59..afa882b 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -279,7 +279,6 @@ ("src/code/early-format") ("src/code/target-format" :not-host) ("src/code/defpackage" :not-host) - ("src/code/pp-backq" :not-host) ("src/code/error-error" :not-host) ; needs WITH-STANDARD-IO-SYNTAX macro diff --git a/make-host-2.lisp b/make-host-2.lisp index aca0cce..0bbac70 100644 --- a/make-host-2.lisp +++ b/make-host-2.lisp @@ -50,8 +50,8 @@ ;; instead of host code. ;; FIXME: Isn't this now taken care of automatically by ;; toplevel forms in the xcompiler backq.lisp file? - (set-macro-character #\` #'sb!impl::backquote-macro) - (set-macro-character #\, #'sb!impl::comma-macro) + (set-macro-character #\` #'sb!impl::backquote-charmacro) + (set-macro-character #\, #'sb!impl::comma-charmacro) (set-dispatch-macro-character #\# #\+ #'she-reader) (set-dispatch-macro-character #\# #\- #'she-reader) @@ -79,6 +79,11 @@ sb!kernel:layout-inherits)) (setf (sb!int:info :function :kind f) :function (sb!int:info :function :where-from f) :declared)) +;; ... and since the cross-compiler hasn't seen a DEFMACRO for QUASIQUOTE, +;; make it think it has, otherwise it fails more-or-less immediately. +(setf (sb!int:info :function :kind 'sb!int:quasiquote) :macro + (sb!int:info :function :macro-function 'sb!int:quasiquote) + (cl:macro-function 'sb!int:quasiquote)) (load "src/cold/compile-cold-sbcl.lisp") ;; After cross-compiling, show me a list of types that checkgen diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 7a1e4f8..7eda4dd 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1093,6 +1093,7 @@ possibly temporarily, because it might be used internally." "AWHEN" "ACOND" "IT" "BINDING*" "!DEF-BOOLEAN-ATTRIBUTE" + "QUASIQUOTE" "WITH-REBOUND-IO-SYNTAX" "WITH-SANE-IO-SYNTAX" "WITH-PROGRESSIVE-TIMEOUT" @@ -1247,10 +1248,6 @@ possibly temporarily, because it might be used internally." "WITH-FAST-READ-BYTE" "PREPARE-FOR-FAST-READ-CHAR" - ;; reflection of our backquote implementation that the - ;; pprinter needs - "*BACKQ-TOKENS*" - ;; hackery to help set up for cold init "!BEGIN-COLLECTING-COLD-INIT-FORMS" "!COLD-INIT-FORMS" @@ -2407,6 +2404,7 @@ package is deprecated in favour of SB-MOP." :name "SB!PRETTY" :doc "private: implementation of pretty-printing" :use ("CL" "SB!EXT" "SB!INT" "SB!KERNEL") + :import-from (("SB!IMPL" "COMMA" "COMMA-KIND" "COMMA-EXPR")) :export ("OUTPUT-PRETTY-OBJECT" "PRETTY-STREAM" "PRETTY-STREAM-P" "PPRINT-DISPATCH-TABLE" diff --git a/src/code/backq.lisp b/src/code/backq.lisp index 580753f..670b834 100644 --- a/src/code/backq.lisp +++ b/src/code/backq.lisp @@ -13,249 +13,274 @@ (/show0 "entering backq.lisp") -;; An unquoting COMMA struct. Not used yet. +;; An unquoting COMMA struct. ;; Were these slots writable, the out-of-line defuns for setting them would ;; call #'(SETF %INSTANCE-REF) provoking a warning later that %INSTANCE-REF ;; gets a SETF macro. The warning is fatal. Read-only is what I want anyway. ;; This is only an issue for files compiled prior to "defsetfs". -(defstruct (comma (:constructor unquote (expr bits))) +(defstruct (comma (:constructor unquote (expr &optional (kind 0))) + ;; READing unpretty commas requires a default constructor. + (:constructor %default-comma-constructor) + (:copier nil)) (expr nil :read-only t) - (bits nil :read-only t :type (and unsigned-byte fixnum))) + (kind nil :read-only t :type (member 0 1 2))) #+sb-xc (declaim (freeze-type comma)) + +(defconstant !+comma-dot+ 1) +(defconstant !+comma-at+ 2) +(defun unquote-nsplice (x) (unquote x !+comma-dot+)) +(defun unquote-splice (x) (unquote x !+comma-at+)) +(defun unquote* (list) (mapcar #'unquote list)) +(defun unquote*-splice (list) (mapcar #'unquote-splice list)) +(declaim (inline comma-constructor comma-splicing-p)) +(defun comma-constructor (x) + (svref #(unquote unquote-nsplice unquote-splice) (comma-kind x))) +(defun comma-splicing-p (comma) (not (zerop (comma-kind comma)))) + +;; The host Lisp needs a MAKE-LOAD-FORM for commas. The warm image does too, +;; but can't have until PCL is compiled. It's too early for DEF!METHOD, +;; so we need a different way to avoid writing this code in two places. +(declaim (inline !unquoting-comma-load-form)) +(defun !unquoting-comma-load-form (obj) + (list (comma-constructor obj) (list 'quote (comma-expr obj)))) #+sb-xc-host (progn ;; tell the host how to dump it (defmethod make-load-form ((self comma) &optional environment) - (list 'unquote (list 'quote (comma-expr self)) (comma-bits self))) + (declare (ignore environment)) + (!unquoting-comma-load-form self)) ;; tell the cross-compiler that it can do :just-dump-it-normally (setf (get 'comma :sb-xc-allow-dumping-instances) t)) -;;; The flags passed back by BACKQUOTIFY can be interpreted as follows: -;;; -;;; |`,|: [a] => a -;;; NIL: [a] => a ;the NIL flag is used only when a is NIL -;;; T: [a] => a ;the T flag is used when a is self-evaluating -;;; QUOTE: [a] => (QUOTE a) -;;; APPEND: [a] => (APPEND . a) -;;; NCONC: [a] => (NCONC . a) -;;; LIST: [a] => (LIST . a) -;;; LIST*: [a] => (LIST* . a) -;;; -;;; The flags are combined according to the following set of rules: -;;; ([a] means that a should be converted according to the previous table) -;;; -;;; \ car || otherwise | QUOTE or | |`,@| | |`,.| -;;;cdr \ || | T or NIL | | -;;;================================================================================ -;;; |`,| || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a [d]) | NCONC (a [d]) -;;; NIL || LIST ([a]) | QUOTE (a) | <hair> a | <hair> a -;;;QUOTE or T|| LIST* ([a] [d]) | QUOTE (a . d) | APPEND (a [d]) | NCONC (a [d]) -;;; APPEND || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a . d) | NCONC (a [d]) -;;; NCONC || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a [d]) | NCONC (a . d) -;;; LIST || LIST ([a] . d) | LIST ([a] . d) | APPEND (a [d]) | NCONC (a [d]) -;;; LIST* || LIST* ([a] . d) | LIST* ([a] . d) | APPEND (a [d]) | NCONC (a [d]) -;;; -;;;<hair> involves starting over again pretending you had read ".,a)" instead -;;; of ",@a)" - -(defvar *backquote-count* 0 #!+sb-doc "how deep we are into backquotes") -(defvar *bq-comma-flag* '(|,|)) -(defvar *bq-at-flag* '(|,@|)) -(defvar *bq-dot-flag* '(|,.|)) -(defvar *bq-vector-flag* '(|bqv|)) +(defvar *backquote-depth* 0 #!+sb-doc "how deep we are into backquotes") (defvar *bq-error* "Comma not inside a backquote.") (/show0 "backq.lisp 50") ;;; the actual character macro -(defun backquote-macro (stream ignore) - (declare (ignore ignore)) - (let ((*backquote-count* (1+ *backquote-count*))) - (multiple-value-bind (flag thing) - (backquotify stream (read stream t nil t)) - (when (eq flag *bq-at-flag*) - (simple-reader-error stream ",@ after backquote in ~S" thing)) - (when (eq flag *bq-dot-flag*) - (simple-reader-error stream ",. after backquote in ~S" thing)) - (backquotify-1 flag thing)))) +(defun backquote-charmacro (stream char) + (declare (ignore char)) + (let* ((expr (let ((*backquote-depth* (1+ *backquote-depth*))) + (read stream t nil t))) + (result (list 'quasiquote expr))) + (if (and (comma-p expr) (comma-splicing-p expr)) + ;; use RESULT rather than EXPR in the error so it pprints nicely + (simple-reader-error + stream "~S is not a well-formed backquote expression" result) + result))) (/show0 "backq.lisp 64") -(defun comma-macro (stream ignore) - (declare (ignore ignore)) - (unless (> *backquote-count* 0) +(defun comma-charmacro (stream char) + (declare (ignore char)) + (unless (> *backquote-depth* 0) (when *read-suppress* - (return-from comma-macro nil)) + (return-from comma-charmacro nil)) (simple-reader-error stream *bq-error*)) - (let ((c (read-char stream)) - (*backquote-count* (1- *backquote-count*))) - (flet ((check (what) - (let ((x (peek-char t stream t nil t))) - (when (and (char= x #\)) - (eq 'read-right-paren (get-macro-character #\)))) + (let ((flag (let ((c (read-char stream))) + (case c + (#\@ !+comma-at+) + (#\. !+comma-dot+) + (t (unread-char c stream) 0)))) + (x (peek-char t stream t nil t))) + (when (and (char= x #\)) (eq (get-macro-character x) 'read-right-paren)) ;; Easier to figure out than an "unmatched parenthesis". - (simple-reader-error stream "Trailing ~A in backquoted expression." what))))) - (cond ((char= c #\@) - (check "comma-at") - (cons *bq-at-flag* (read stream t nil t))) - ((char= c #\.) - (check "comma-dot") - (cons *bq-dot-flag* (read stream t nil t))) - (t - (unread-char c stream) - (check "comma") - (cons *bq-comma-flag* (read stream t nil t))))))) + (simple-reader-error stream "Trailing ~A in backquoted expression." + (svref #("comma" "comma-dot" "comma-at") flag))) + (unquote (let ((*backquote-depth* (1- *backquote-depth*))) + (read stream t nil t)) flag))) (/show0 "backq.lisp 83") -;;; -(defun expandable-backq-expression-p (object) - (and (consp object) - (let ((flag (car object))) - (or (eq flag *bq-at-flag*) - (eq flag *bq-dot-flag*))))) +(declaim (ftype (function (t fixnum) (values t t &optional)) + qq-template-to-sexpr qq-template-1)) -(defun backquote-splice (method dflag a d what stream) - (cond (dflag - (values method - (cond ((eq dflag method) - (cons a d)) - (t (list a (backquotify-1 dflag d)))))) - ((expandable-backq-expression-p a) - (values method (list a))) - ((not (and (atom a) (backq-constant-p a))) - ;; COMMA special cases a few constant atoms, which - ;; are illegal in splices. - (comma a)) +;; A QQ-SUBFORM is a cons whose car is an arbitrary S-expression, and +;; cdr one of {EVAL,QUOTE,NCONC,|Append|} signifying how to treat the car. +;; QUOTE and EVAL mean that a single element should be inserted, +;; literally or after being evaluated; NCONC/Append evaluate and splice. +(declaim (inline qq-subform-splicing-p)) +(defun qq-subform-splicing-p (subform) + (case (cdr subform) + (|Append| '|Append|) + (nconc 'nconc))) + +(defmacro quasiquote (thing) + ;; QQ-TEMPLATE-TO-SEXPR returns the parts of a QQ-SUBFORM as 2 values. + (multiple-value-bind (expr operator) (qq-template-to-sexpr thing 0) + (ecase operator ; Splicing is illegal at toplevel + (eval expr) + (quote (list 'quote expr))))) + +;; Convert a quasi-quote template to a Lisp form that when evaluated constructs +;; the template, substituting into the outermost commas. Return two values: +;; the S-expression, and an indicator of how to incorporate it into its parent. +(defun qq-template-to-sexpr (expr depth) + (cond ((not expr) (values nil 'quote)) + ((listp expr) + (qq-template-1 expr (+ (if (eq (car expr) 'quasiquote) 1 0) depth))) + ((simple-vector-p expr) (qq-template-1 expr depth)) + ((not (comma-p expr)) (values expr 'quote)) + ((zerop depth) + (values (comma-expr expr) + (svref #(eval nconc |Append|) (comma-kind expr)))) (t - (simple-reader-error stream "Invalid splice in backquote: ~A~A" what a)))) - -;;; This does the expansion from table 2. -(defun backquotify (stream code) - (cond ((atom code) - (cond ((null code) (values nil nil)) - ((or (consp code) - (symbolp code)) - ;; Keywords are self-evaluating. Install after packages. - (values 'quote code)) - (t (values t code)))) - ((or (eq (car code) *bq-at-flag*) - (eq (car code) *bq-dot-flag*)) - (values (car code) (cdr code))) - ((eq (car code) *bq-comma-flag*) - (comma (cdr code))) - ((eq (car code) *bq-vector-flag*) - (multiple-value-bind (dflag d) (backquotify stream (cdr code)) - (values 'vector (backquotify-1 dflag d)))) - (t (multiple-value-bind (aflag a) (backquotify stream (car code)) - (multiple-value-bind (dflag d) (backquotify stream (cdr code)) - (when (eq dflag *bq-at-flag*) - ;; Get the errors later. - (simple-reader-error stream ",@ after dot in ~S" code)) - (when (eq dflag *bq-dot-flag*) - (simple-reader-error stream ",. after dot in ~S" code)) - (cond - ((eq aflag *bq-at-flag*) - (backquote-splice 'append dflag a d ",@" stream)) - ((eq aflag *bq-dot-flag*) - (backquote-splice 'nconc dflag a d ",." stream)) - ((null dflag) - (if (member aflag '(quote t nil)) - (values 'quote (list a)) - (values 'list (list (backquotify-1 aflag a))))) - ((member dflag '(quote t)) - (if (member aflag '(quote t nil)) - (values 'quote (cons a d )) - (values 'list* (list (backquotify-1 aflag a) - (backquotify-1 dflag d))))) - (t (setq a (backquotify-1 aflag a)) - (if (member dflag '(list list*)) - (values dflag (cons a d)) - (values 'list* - (list a (backquotify-1 dflag d))))))))))) + ;; A comma is "pure data" if deeper than the current backquote depth. + ;; If its expression interpolates 1 item, reconstruct it using its + ;; ordinary constructor, otherwise its multi-constructor. + (multiple-value-bind (subexpr operator) + (qq-template-to-sexpr (comma-expr expr) (1- depth)) + (when (eq operator 'quote) + (setq subexpr (list 'quote subexpr) operator 'eval)) + (values (list (cond ((eq operator 'eval) (comma-constructor expr)) + ((comma-splicing-p expr) 'unquote*-splice) + (t 'unquote*)) + subexpr) + operator))))) (/show0 "backq.lisp 139") -(defun backq-constant-p (x) - (or (numberp x) (eq x t))) +;; Find the longest suffix comprised wholly of self-evaluating and/or quoted +;; SUBFORMS. DOTTED-P indicates that the last item represents what was in the +;; CDR of the last cons of the original list. Return the modified SUBFORMS +;; as a proper list, and new DOTTED-P flag. i.e. Conceptually: +;; `(a ,[@]b c d) -> `(a ,[@]b . (c d)) +;; `(a ,[@]b c . d) -> `(a ,[@]b . (c . d)) +(defun qq-fold-suffix (subforms dotted-p) + (labels ((const-tailp (list) + (if list + (let* ((rest (cdr list)) + (const-part (const-tailp rest))) + (if (and (eq const-part rest) (eq (cdar list) 'quote)) + list + const-part))))) + (let ((const-tail (and (cdr subforms) (const-tailp subforms)))) + (if const-tail + (let* ((constants (mapcar #'car const-tail)) + (new-tail (if dotted-p (apply 'list* constants) constants))) + (setq subforms (nconc (ldiff subforms const-tail) + (list (cons new-tail 'quote))) + dotted-p t))))) + ;; If the only splicing operator is in the last element of a proper list, + ;; get rid of the splice and make it an improper list. + (labels ((convertible-p (list) + (if (cdr list) + (and (not (qq-subform-splicing-p (car list))) + (convertible-p (cdr list))) + (qq-subform-splicing-p (car list))))) + (when (and (not dotted-p) (convertible-p subforms)) + (let ((tail (car (last subforms)))) + (setq subforms (nconc (nbutlast subforms) (list (list (car tail)))) + dotted-p t)))) + (values subforms dotted-p)) -;;; This handles the <hair> cases. -(defun comma (code) - (cond ((atom code) - (cond ((null code) - (values nil nil)) - ((backq-constant-p code) - (values t code)) - (t - (values *bq-comma-flag* code)))) - ((and (eq (car code) 'quote) - (not (expandable-backq-expression-p (cadr code)))) - (values (car code) (cadr code))) - ((member (car code) '(append list list* nconc)) - (values (car code) (cdr code))) - ((eq (car code) 'cons) - (values 'list* (cdr code))) - (t (values *bq-comma-flag* code)))) +;; Map TEMPLATE-TO-SEXPR over INPUT, a list or simple-vector, producing a list +;; as if by MAP. The cdr of the last cons of the input (if a list) may be a +;; non-nil atom. Return a secondary value indicating whether it was or not. +;; The output list never "dots" its last cons, regardless of the input. +(defun qq-map-template-to-list (input depth) + (let ((original input) list dotted-p) + (flet ((to-sexpr (x) + (multiple-value-call #'cons (qq-template-to-sexpr x depth)))) + (typecase input + (cons + (loop + (push (to-sexpr (pop input)) list) + ;; Ensure that QQ-TEMPLATE-TO-SEXPR sees each occurrence of + ;; (QUASIQUOTE <form>) as a proper list so that it can + ;; bump the depth counter. The oddball case `(a . `(b)) + ;; would otherwise be seen as not nested `(a quasiquote (b)). + (cond ((null input) (return)) + ((comma-p input) ; (... . ,<expr>) + (when (comma-splicing-p input) ; uncaught by reader + ;; Actually I don't even know how to get this error + (error "~S is not a well-formed backquote expression" + original)) + ;; (A B . ,X) becomes (A B ,@X). It matters only if there + ;; are commas in X like (... . ,,@C). Otherwise no effect. + (push (to-sexpr (unquote-splice (comma-expr input))) list) + (return)) + ((or (not (listp input)) (eq (car input) 'quasiquote)) + (push (to-sexpr input) list) + (setq dotted-p t) + (return)))) + (setq list (nreverse list))) + (simple-vector + (setq list (map 'list #'to-sexpr input))))) + ;; For lists, find the longest suffix comprised wholly of literals. + ;; For vectors without splicing we don't do that because (VECTOR 'A B 'C 'D) + ;; is better than (COERCE (LIST* 'A B '(C D)) 'VECTOR) by avoiding a step. + ;; But if splicing is required then we're going to construct the interim + ;; list no matter what. It could theoretically be avoided by doing: + ;; (MULTIPLE-VALUE-CALL #'VECTOR ... (VALUES-LIST <splice>) ...) + (if (or (listp original) (some #'qq-subform-splicing-p list)) + (qq-fold-suffix list dotted-p) + (values list dotted-p)))) -(/show0 "backq.lisp 157") +;; Return an expression to quasi-quote INPUT, which is either a list +;; or simple-vector, by recursing over its subexpressions. +(defun qq-template-1 (input depth) + (multiple-value-bind (subforms dot-p) (qq-map-template-to-list input depth) + (labels ((const-p (subform) ; is SUBFORM constant? + ;; This needs to notice only the QQ-SUBFORM kind of QUOTE, + ;; but it helps to get EVAL forms whose expression is (QUOTE x). + ;; Otherwise, work is deferred to IR1 in processing `(A ,'B C). + (or (eq (cdr subform) 'quote) ; either the kind is QUOTE + (let ((exp (car subform))) + (if (atom exp) ; or it's a self-evaluating atom + (atom-const-p exp) + (and (eq (car exp) 'quote) (consp (cdr exp)) + (not (cddr exp))))))) ; or (QUOTE <thing>) + (atom-const-p (atom) ; is known to be an atom + (typep atom '(or (not symbol) (member t nil) keyword))) + (const-val (subform) ; given that it is known CONST-P + (let ((exp (car subform))) + (if (or (eq (cdr subform) 'quote) (atom exp)) + exp + (second exp)))) ; (QUOTE x) in a for-evaluation position + (render (subform) ; Return a sexpr that evaluates to SUBFORM + ;; For subform kind = QUOTE, wrap it in a QUOTE unless + ;; the quoted object is self-evaluating, then elide the QUOTE. + (let ((exp (car subform))) + (if (and (eq (cdr subform) 'quote) + (not (and (atom exp) (atom-const-p exp)))) + (list 'quote exp) + exp))) + (recurse (list &aux (elt (car list)) (rest (cdr list))) + (if (endp rest) + (cond ((or dot-p (qq-subform-splicing-p elt)) (render elt)) + ((const-p elt) (list 'quote (list (const-val elt)))) + (t (list '|List| (render elt)))) ; singleton list + (let ((fn (or (qq-subform-splicing-p elt) '|List*|)) + (head (render elt)) + (tail (recurse rest))) + (if (and (listp tail) (eq (car tail) fn)) + (list* fn head (cdr tail)) ; (F a (F b c)) -> (F a b c) + (list fn head tail)))))) + (let ((vect-p (vectorp input))) + ;; If at least one splicing comma, use the recursive algorithm. + (if (some #'qq-subform-splicing-p (the list subforms)) + (let ((x (recurse subforms))) + (values (if vect-p (list 'coerce x ''simple-vector) x) 'eval)) + (let ((fn (cond (vect-p '|Vector|) (dot-p '|List*|) (t '|List|)))) + (if (every #'const-p subforms) + (values (apply fn (mapcar #'const-val subforms)) 'quote) + (values (cons fn (mapcar #'render subforms)) 'eval)))))))) -;;; This handles table 1. -(defun backquotify-1 (flag thing) - (cond ((or (eq flag *bq-comma-flag*) - (member flag '(t nil))) - thing) - ((eq flag 'quote) - (list 'quote thing)) - ((eq flag 'list*) - (cond ((and (null (cddr thing)) - (not (expandable-backq-expression-p (car thing))) - (not (expandable-backq-expression-p (cadr thing)))) - (cons 'backq-cons thing)) - ((expandable-backq-expression-p (car (last thing))) - (list 'backq-append - (cons 'backq-list (butlast thing)) - ;; Can it be optimized further? -- APD, 2001-12-21 - (car (last thing)))) - (t - (cons 'backq-list* thing)))) - ((eq flag 'vector) - (list 'backq-vector thing)) - (t (cons (ecase flag - ((list) 'backq-list) - ((append) 'backq-append) - ((nconc) 'backq-nconc)) - thing)))) - -;;;; magic BACKQ- versions of builtin functions - -(/show0 "backq.lisp 184") - -;;; Define synonyms for the lisp functions we use, so that by using -;;; them, the backquoted material will be recognizable to the -;;; pretty-printer. -;;; These pass-through functions all have IR1 transforms whose signatures -;;; are more restrictive than &REST, so it's kind of weird to write -;;; (DEFUN BACKQ-CONS (&REST REST) (APPLY #'CONS REST)) -;;; as was previously done. -;;; Better to say that pairs of symbols share functional bindings. -(macrolet ((def (b-name name) - `(setf (symbol-function ',b-name) #',name))) - (def backq-list list) - (def backq-list* list*) - (def backq-append append) - (def backq-nconc nconc) - (def backq-cons cons)) - -(/show0 "backq.lisp 204") - -(defun backq-vector (list) - (declare (list list)) - (coerce list 'simple-vector)) +;;; COMPILE-FILE may treat anything as constant that is part of quoted +;;; structure, including quasi-quoted structure (lp#1026439). +;;; As such, we use foldable versions of the standard sequence constructors +;;; which are otherwise identical to their ordinary counterparts. +;;; Pretty-printing doesn't care about these names, only recognizing QUASIQUOTE. +;;; Generated code looks nicer to me without prepending BACKQ-. +;;; Also note there is no alter-ego of CONS or NCONC. +(setf (symbol-function '|Append|) #'append + (symbol-function '|List|) #'list + (symbol-function '|List*|) #'list* + (symbol-function '|Vector|) #'vector) ;;;; initialization -(/show0 "backq.lisp 212") - ;;; Install BACKQ stuff in the current *READTABLE*. ;;; ;;; In the target Lisp, we have to wait to do this until the readtable @@ -269,27 +294,10 @@ ;;; exist on the target Lisp, we ensure that backquote expansions in ;;; code-generating code work properly.) -;; A test of the ability of the cross-compiler to dump a function -;; that references as constant a tree containing a COMMA struct. - -(defun !backq-cold-init (&optional (test t)) - (set-macro-character #\` #'backquote-macro) - (set-macro-character #\, #'comma-macro) - (when test - (assert (equalp (cons 'foo (unquote '*print-case* 4)) - (!a-random-comma-object-do-not-use))))) - -;; If this function causes compilation failure, -;; the transform for MAPCAR is broken. Otherwise it isn't. -(defun !a-random-mapcar-do-not-use (x) - (mapcar #'cdr x)) - -#+sb-xc-host (!backq-cold-init nil) - -;;; The pretty-printer needs to know about our special tokens -(defvar *backq-tokens* - '(backq-comma backq-comma-at backq-comma-dot backq-list - backq-list* backq-append backq-nconc backq-cons backq-vector)) +(defun !backq-cold-init () + (set-macro-character #\` 'backquote-charmacro) + (set-macro-character #\, 'comma-charmacro)) +#-sb-xc (!backq-cold-init) ;;; Since our backquote is installed on the host lisp, and since ;;; developers make mistakes with backquotes and commas too, let's diff --git a/src/code/defsetfs.lisp b/src/code/defsetfs.lisp index a95ab0e..402f915 100644 --- a/src/code/defsetfs.lisp +++ b/src/code/defsetfs.lisp @@ -138,15 +138,6 @@ (in-package "SB!KERNEL") (defsetf code-header-ref code-header-set) -(in-package "SB!IMPL") - -;; A test of the ability of the cross-compiler to dump a function -;; that references as constant a tree containing a COMMA struct. -;; Does not really belong here, but ensures that stays working. -;; It is called by !backq-cold-init. -(defun !a-random-comma-object-do-not-use () - '(foo . #.(unquote '*print-case* 4))) - ;;; from x86-vm.lisp (in-package "SB!VM") (defsetf context-register %set-context-register) diff --git a/src/code/early-pprint.lisp b/src/code/early-pprint.lisp index 8e8cff8..8e15108 100644 --- a/src/code/early-pprint.lisp +++ b/src/code/early-pprint.lisp @@ -88,10 +88,10 @@ (block ,block-name (flet ((,pp-pop-name () ,@(when object - `((unless (listp ,object-var) - (write-string ". " ,stream-var) - (output-object ,object-var ,stream-var) - (return-from ,block-name nil)))) + `((unless (listp-for-pprint ,object-var) + (return-from ,block-name + (%pprint-dotted-tail ,object-var + ,stream-var))))) (when (and (not *print-readably*) (eql ,count-name *print-length*)) (write-string "..." ,stream-var) @@ -154,3 +154,20 @@ If the LIST argument to PPRINT-LOGICAL-BLOCK was NIL, then nothing is popped, but the *PRINT-LENGTH* testing still happens." (error "PPRINT-POP must be lexically inside PPRINT-LOGICAL-BLOCK.")) + +;; utilities needed by PPRINT-POP +;; Consider (A . `(,B C)) = (A QUASIQUOTE ,B C) +;; We have to detect this and print as the form on the left since pretty commas +;; with no containing #\` will fail at read-time due to a nesting error. +;; There isn't an equivalent of *BACKQUOTE-DEPTH* for output streams so we +;; can't revert to printing the comma as #S(SB-IMPL::COMMA ...) +(declaim (inline listp-for-pprint)) +(defun listp-for-pprint (x) + (and (listp x) + (if (and (eq (car x) 'quasiquote) + (let ((cdr (cdr x))) (and (consp cdr) (not (cdr cdr))))) + nil t))) +(defun %pprint-dotted-tail (obj stream) + (write-string ". " stream) + (output-object obj stream) + nil) diff --git a/src/code/pp-backq.lisp b/src/code/pp-backq.lisp deleted file mode 100644 index d3e901a..0000000 --- a/src/code/pp-backq.lisp +++ /dev/null @@ -1,124 +0,0 @@ -;;;; pretty-printing of backquote expansions - -;;;; This software is part of the SBCL system. See the README file for -;;;; more information. -;;;; -;;;; This software is derived from the CMU CL system, which was -;;;; written at Carnegie Mellon University and released into the -;;;; public domain. The software is in the public domain and is -;;;; provided with absolutely no warranty. See the COPYING and CREDITS -;;;; files for more information. - -(in-package "SB!IMPL") - -(defstruct (backq-comma (:constructor make-backq-comma (form)) - (:copier nil) (:predicate nil)) - form) -(defstruct (backq-comma-at (:include backq-comma) - (:constructor make-backq-comma-at (form)) - (:copier nil) (:predicate nil))) -(defstruct (backq-comma-dot (:include backq-comma) - (:constructor make-backq-comma-dot (form)) - (:copier nil) (:predicate nil))) - -(defun backq-unparse-expr (form splicing) - (ecase splicing - ((nil) (make-backq-comma form)) - ((t) `(,(make-backq-comma-at form))) - (:nconc `(,(make-backq-comma-dot form))))) - -(defun backq-unparse (form &optional splicing) - #!+sb-doc - "Given a lisp form containing the magic functions BACKQ-LIST, BACKQ-LIST*, - BACKQ-APPEND, etc. produced by the backquote reader macro, will return a - corresponding backquote input form. In this form, `,' `,@' and `,.' are - represented by structures of type BACKQ-COMMA, BACKQ-COMMA-AT, and - BACKQ-COMMA-DOT respectively. - SPLICING indicates whether a comma-escape return should be modified for - splicing with other forms: a value of T or :NCONC meaning that an extra - level of parentheses should be added." - (cond - ((atom form) - (backq-unparse-expr form splicing)) - ((not (null (cdr (last form)))) - ;; FIXME: this probably throws a recursive error - (bug "found illegal dotted backquote form: ~S" form)) - (t - (case (car form) - (backq-list - (mapcar #'backq-unparse (cdr form))) - (backq-list* - (do ((tail (cdr form) (cdr tail)) - (accum nil)) - ((null (cdr tail)) - (nconc (nreverse accum) - (backq-unparse (car tail) t))) - (push (backq-unparse (car tail)) accum))) - (backq-append - (apply #'append - (mapcar (lambda (el) (backq-unparse el t)) - (cdr form)))) - (backq-nconc - (apply #'append - (mapcar (lambda (el) (backq-unparse el :nconc)) - (cdr form)))) - (backq-cons - (cons (backq-unparse (cadr form) nil) - (backq-unparse (caddr form) t))) - (backq-vector - ;; The special-case of empty vector isn't technically necessary, - ;; but avoids the valid though ugly result "`#(,@NIL)" - (acond ((cadr form) (coerce (backq-unparse it t) 'vector)) - (t #()))) - (quote - ;; FIXME: This naively assumes that the form is exactly (QUOTE x). - ;; Therefore (QUOTE . x) and (QUOTE x y z*) will lose. - (let ((thing (cadr form))) - (cond ((atom thing) - (if (typep thing 'backq-comma) - (backq-unparse-expr form splicing) - thing)) - ((member (car thing) *backq-tokens*) - (backq-unparse-expr form splicing)) - (t - (cons (backq-unparse `(quote ,(car thing))) - (backq-unparse `(quote ,(cdr thing)))))))) - (t - (backq-unparse-expr form splicing)))))) - -(defun pprint-backquote (stream form &rest noise) - (declare (ignore noise)) - (write-char #\` stream) - (write (backq-unparse form) :stream stream)) - -(defun pprint-backq-comma (stream thing &rest noise) - (declare (ignore noise) (backq-comma thing)) - (etypecase thing - (backq-comma-at - (write-string ",@" stream)) - (backq-comma-dot - (write-string ",." stream)) - (backq-comma - (write-char #\, stream) - (setf (sb!pretty::pretty-stream-char-out-oneshot-hook stream) - (lambda (stream char) - ;; Ensure a space is written before any output that would - ;; erroneously be interpreted as a splicing frob on readback. - (when (or (char= char #\.) (char= char #\@)) - (write-char #\Space stream)))))) - (write (backq-comma-form thing) :stream stream)) - -;;; This is called by !PPRINT-COLD-INIT, fairly late, because -;;; SET-PPRINT-DISPATCH doesn't work until the compiler works. -;;; -;;; FIXME: It might be cleaner to just make these be toplevel forms and -;;; enforce the delay by putting this file late in the build sequence. -(defun !backq-pp-cold-init () - (set-pprint-dispatch '(cons (eql backq-list)) #'pprint-backquote) - (set-pprint-dispatch '(cons (eql backq-list*)) #'pprint-backquote) - (set-pprint-dispatch '(cons (eql backq-append)) #'pprint-backquote) - (set-pprint-dispatch '(cons (eql backq-nconc)) #'pprint-backquote) - (set-pprint-dispatch '(cons (eql backq-cons)) #'pprint-backquote) - (set-pprint-dispatch '(cons (eql backq-vector)) #'pprint-backquote) - (set-pprint-dispatch 'backq-comma #'pprint-backq-comma)) - diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp index 78081e0..cd7de43 100644 --- a/src/code/pprint.lisp +++ b/src/code/pprint.lisp @@ -1063,15 +1063,6 @@ line break." (defun pprint-lambda-list (stream lambda-list &rest noise) (declare (ignore noise)) - (when (and (consp lambda-list) - (member (car lambda-list) *backq-tokens*)) - ;; if this thing looks like a backquoty thing, then we don't want - ;; to destructure it, we want to output it straight away. [ this - ;; is the exception to the normal processing: if we did this - ;; generally we would find lambda lists such as (FUNCTION FOO) - ;; being printed as #'FOO ] -- CSR, 2003-12-07 - (output-object lambda-list stream) - (return-from pprint-lambda-list nil)) (pprint-logical-block (stream lambda-list :prefix "(" :suffix ")") (let ((state :required) (first t)) @@ -1187,24 +1178,35 @@ line break." (funcall (formatter "~:<~^~W~^~3I ~:_~W~^ ~_~W~^~1I~@{ ~_~W~}~:>") stream list)) +(defun pprint-unquoting-comma (stream obj &rest noise) + (declare (ignore noise)) + (write-string (svref #("," ",." ",@") (comma-kind obj)) stream) + (when (eql (comma-kind obj) 0) + ;; Ensure a space is written before any output that would change the meaning + ;; of the preceding the comma to ",." or ",@" such as a symbol named "@BAR". + (setf (pretty-stream-char-out-oneshot-hook stream) + (lambda (stream char) + (when (member char '(#\. #\@)) + (write-char #\Space stream))))) + (output-object (comma-expr obj) stream)) + (defvar *pprint-quote-with-syntactic-sugar* t) (defun pprint-quote (stream list &rest noise) (declare (ignore noise)) - (if (and (consp list) - (consp (cdr list)) - (null (cddr list)) - *pprint-quote-with-syntactic-sugar*) - (case (car list) - (function - (write-string "#'" stream) - (output-object (cadr list) stream)) - (quote - (write-char #\' stream) - (output-object (cadr list) stream)) - (t - (pprint-fill stream list))) - (pprint-fill stream list))) + (when (and (consp list) + (let ((cdr (cdr list))) (and (consp cdr) (null (cdr cdr))))) + (let* ((pretty-p nil) + (sigil (case (car list) + (function "#'") + (quote "'") + ;; QUASIQUOTE can't choose not to print prettily. + ;; Wrongly nested commas beget unreadable sexprs. + (quasiquote (setq pretty-p t) "`")))) + (when (or pretty-p *pprint-quote-with-syntactic-sugar*) + (write-string sigil stream) + (return-from pprint-quote (output-object (cadr list) stream))))) + (pprint-fill stream list)) (defun pprint-declare (stream list &rest noise) (declare (ignore noise)) @@ -1498,6 +1500,7 @@ line break." (let ((*print-pprint-dispatch* *initial-pprint-dispatch-table*) (*building-initial-table* t)) (/show0 "doing SET-PPRINT-DISPATCH for regular types") + (set-pprint-dispatch 'comma #'pprint-unquoting-comma) (set-pprint-dispatch '(and array (not (or string bit-vector))) #'pprint-array) (set-pprint-dispatch '(cons (and symbol (satisfies mboundp))) #'pprint-macro-call -1) @@ -1576,6 +1579,7 @@ line break." (prog2 pprint-prog2) (psetf pprint-setq) (psetq pprint-setq) + (quasiquote pprint-quote) #+nil (restart-bind ...) #+nil (restart-case ...) (setf pprint-setq) @@ -1600,12 +1604,7 @@ line break." )) (set-pprint-dispatch `(cons (eql ,(first magic-form))) - (symbol-function (second magic-form)))) - - ;; other pretty-print init forms - (/show0 "about to call !BACKQ-PP-COLD-INIT") - (sb!impl::!backq-pp-cold-init) - (/show0 "leaving !PPRINT-COLD-INIT")) + (symbol-function (second magic-form))))) (setf *standard-pprint-dispatch-table* (copy-pprint-dispatch *initial-pprint-dispatch-table*)) diff --git a/src/code/reader.lisp b/src/code/reader.lisp index 4b0c3dc..e1713d7 100644 --- a/src/code/reader.lisp +++ b/src/code/reader.lisp @@ -804,6 +804,15 @@ standard Lisp readtable when NIL." (rplacd listtail ;; Return list containing last thing. (car (read-after-dot stream nextchar))) + ;; Check for improper ". ,@" or ". ,." now rather than + ;; in the #\` reader. The resulting QUASIQUOTE macro might + ;; never be exapanded, but nonetheless could be erroneous. + (when (and (plusp *backquote-depth*) (not *read-suppress*)) + (let ((lastcdr (cdr (last listtail)))) + (when (and (comma-p lastcdr) (comma-splicing-p lastcdr)) + (simple-reader-error + stream "~S contains a splicing comma after a dot" + (cdr thelist))))) (return (cdr thelist))) ;; Put back NEXTCHAR so that we can read it normally. (t (unread-char nextchar stream))))) diff --git a/src/code/sharpm.lisp b/src/code/sharpm.lisp index 63c4147..2d11b03 100644 --- a/src/code/sharpm.lisp +++ b/src/code/sharpm.lisp @@ -9,7 +9,7 @@ (in-package "SB!IMPL") -(declaim (special *read-suppress* *bq-vector-flag*)) +(declaim (special *read-suppress*)) ;;; FIXME: Is it standard to ignore numeric args instead of raising errors? (defun ignore-numarg (sub-char numarg) @@ -21,11 +21,10 @@ (defun sharp-left-paren (stream ignore length) (declare (ignore ignore)) (let* ((list (read-list stream nil)) - (list-length (handler-case (length list) - (type-error () - (simple-reader-error stream - "Improper list in #(): ~S." - list))))) + (list-length + (handler-case (length list) + (type-error () + (simple-reader-error stream "Improper list in #(): ~S." list))))) (declare (list list) (fixnum list-length)) (cond (*read-suppress* nil) @@ -34,19 +33,15 @@ stream "Vector longer than the specified length: #~S~S." length list)) - ((zerop *backquote-count*) - (if length - (fill (replace (make-array length) list) - (car (last list)) - :start list-length) - (coerce list 'vector))) + (length + ;; the syntax `#n(foo ,@bar) is not well-defined. [See lp#1096043.] + ;; We take it to mean that the vector as read should be padded to + ;; length 'n'. It could be argued that 'n' is the length after + ;; expansion, but that's not easy, not to mention unportable. + (fill (replace (make-array length) list) + (car (last list)) :start list-length)) (t - (cons *bq-vector-flag* - (if length - (append list - (make-list (- length list-length) - :initial-element (car (last list)))) - list)))))) + (coerce list 'vector))))) (defun sharp-star (stream ignore numarg) (declare (ignore ignore)) @@ -97,10 +92,10 @@ (simple-reader-error stream "No dimensions argument to #A.")) (collect ((dims)) (let* ((*bq-error* - (if (zerop *backquote-count*) + (if (zerop *backquote-depth*) *bq-error* "Comma inside a backquoted array (not a list or general vector.)")) - (*backquote-count* 0) + (*backquote-depth* 0) (contents (read stream t nil t)) (seq contents)) (dotimes (axis dimensions @@ -128,11 +123,11 @@ (read stream t nil t) (return-from sharp-S nil)) (let* ((*bq-error* - (if (zerop *backquote-count*) + (if (zerop *backquote-depth*) *bq-error* "Comma inside backquoted structure (not a list or general vector.)")) (body (if (char= (read-char stream t) #\( ) - (let ((*backquote-count* 0)) + (let ((*backquote-depth* 0)) (read-list stream nil)) (simple-reader-error stream "non-list following #S")))) (unless (listp body) @@ -471,7 +466,7 @@ (defun sharp-dot (stream sub-char numarg) (ignore-numarg sub-char numarg) - (let ((*backquote-count* 0)) + (let ((*backquote-depth* 0)) (let ((expr (read stream t nil t))) (unless *read-suppress* (unless *read-eval* diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index 89b0e60..c7f3e35 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -362,15 +362,13 @@ ;; - inline functions whose behavior is merely to call LIST don't work ;; e.g. :INITIAL-CONTENTS (MY-LIST a b) ; where MY-LIST is inline ;; ; and effectively just (LIST ...) -;; - in the current implementation it is only with difficulty that -;; backquoted vectors could be used as initializers because BACKQ-VECTOR -;; is not the analogous function to VECTOR. (New backq macro fixes that.) (defun rewrite-initial-contents (rank initial-contents env) (named-let recurse ((rank rank) (data initial-contents)) (declare (type index rank)) (if (plusp rank) (flet ((sequence-constructor-p (form) - (member (car form) '(list vector sb!impl::backq-list)))) + (member (car form) '(sb!impl::|List| list + sb!impl::|Vector| vector)))) (let (expanded) (cond ((not (listp data)) data) ((sequence-constructor-p data) @@ -467,7 +465,8 @@ ;; constant LENGTH. ((and initial-contents c-length (lvar-matches initial-contents - :fun-names '(list vector sb!impl::backq-list) + :fun-names '(list vector + sb!impl::|List| sb!impl::|Vector|) :arg-count c-length)) (let ((parameters (eliminate-keyword-args call 1 '((:element-type element-type) diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 974f969..6ab510b 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -745,14 +745,10 @@ (defknown make-list (index &key (:initial-element t)) list (movable flushable)) -(defknown sb!impl::backq-list (&rest t) list (movable flushable)) -(defknown sb!impl::backq-list* (t &rest t) t (movable flushable)) -(defknown sb!impl::backq-append (&rest t) t (flushable)) -(defknown sb!impl::backq-nconc (&rest t) t () - :destroyed-constant-args (remove-non-constants-and-nils #'butlast)) -(defknown sb!impl::backq-cons (t t) cons (foldable movable flushable)) -(defknown sb!impl::backq-vector (list) simple-vector - (foldable movable flushable)) +(defknown sb!impl::|List| (&rest t) list (movable flushable foldable)) +(defknown sb!impl::|List*| (t &rest t) t (movable flushable foldable)) +(defknown sb!impl::|Append| (&rest t) t (flushable foldable)) +(defknown sb!impl::|Vector| (&rest t) simple-vector (flushable foldable)) ;;; All but last must be of type LIST, but there seems to be no way to ;;; express that in this syntax. diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 959be35..9c48c6e 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -1723,14 +1723,14 @@ `(list* ,@variants ',tail) `(list ,@variants))))))))) -(deftransform sb!impl::backq-list ((&rest elts)) +(deftransform sb!impl::|List| ((&rest elts)) (transform-backq-list-or-list* 'list elts)) -(deftransform sb!impl::backq-list* ((&rest elts)) +(deftransform sb!impl::|List*| ((&rest elts)) (transform-backq-list-or-list* 'list* elts)) ;; Merge adjacent constant values -(deftransform sb!impl::backq-append ((&rest elts)) +(deftransform sb!impl::|Append| ((&rest elts)) (let ((gensyms (make-gensym-list (length elts))) (acc nil) (ignored '()) @@ -1757,12 +1757,3 @@ `(lambda ,gensyms (declare (ignore ,@ignored)) (append ,@arguments))))) - -;; Nothing special for nconc -(define-source-transform sb!impl::backq-nconc (&rest elts) - `(nconc ,@elts)) - -;; cons and vector are handled with regular constant folding... -;; but we still want to convert backq-cons into cl:cons. -(deftransform sb!impl::backq-cons ((x y)) - `(cons x y)) diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index 9e7e7ed..f1aa915 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -637,7 +637,11 @@ (unless (and name (eq (find-class name nil) class)) (error "~@<Can't use anonymous or undefined class as constant: ~S~:@>" class)) - `(find-class ',name))) + ;; Essentially we want `(FIND-CLASS ',NAME) but without using backquote. + ;; Because this is a delayed DEF!METHOD, its entire body is quoted structure + ;; and can't contain a comma object until a MAKE-LOAD-FORM exists for that. + ;; :JUST-DUMP-IT-NORMALLY was a temporary hack for cross-compilation. + (list 'find-class (list 'quote name)))) ;;; The class PCL-CLASS is an implementation-specific common ;;; superclass of all specified subclasses of the class CLASS. diff --git a/src/pcl/env.lisp b/src/pcl/env.lisp index 5975f6d..c8aff34 100644 --- a/src/pcl/env.lisp +++ b/src/pcl/env.lisp @@ -191,6 +191,10 @@ (error "~@<don't know how to dump ~S (default ~S method called).~>" object 'make-load-form)) +(defmethod make-load-form ((object sb-impl::comma) &optional env) + (declare (ignore env)) + (sb-impl::!unquoting-comma-load-form object)) + (defun make-load-form-saving-slots (object &key (slot-names nil slot-names-p) environment) (declare (ignore environment)) (let ((class (class-of object))) diff --git a/tests/backq.impure.lisp b/tests/backq.impure.lisp index fc18c41..247edcc 100644 --- a/tests/backq.impure.lisp +++ b/tests/backq.impure.lisp @@ -13,6 +13,10 @@ (in-package "CL-USER") +(with-test (:name :backq-smoke-test) + (assert (equalp (macroexpand '`#(() a #(#() nil x) #())) + ''#(NIL A #(#() NIL X) #())))) + (defparameter *qq* '(*rr* *ss*)) (defparameter *rr* '(3 5)) (defparameter *ss* '(4 6)) @@ -56,11 +60,11 @@ *backquote-tests*) (let ((string "`(foobar a b ,c ,'(e f g) d ,@'(e f g) (h i j) ,@foo)")) - (assert (equal (print (read-from-string string)) (read-from-string string)))) + (assert (equalp (print (read-from-string string)) (read-from-string string)))) (let ((a '`(1 ,@a ,@b ,.c ,.d))) (let ((*print-circle* t)) - (assert (equal (read-from-string (write-to-string a)) a)))) + (assert (equalp (read-from-string (write-to-string a)) a)))) (let ((s '``(,,@(list 1 2 3) 10))) (assert (equal (eval (eval s)) '(1 2 3 10)))) @@ -72,7 +76,7 @@ (handler-case (read-from-string "`(foo bar #.(max 5 ,*print-base*))") (reader-error () :error))))) -#+nil (with-test (:name :triple-backquote) +(with-test (:name :triple-backquote) (flet ((expect (expect val) (assert (string= (write-to-string val) expect)))) (let ((plet/fast 'val1) @@ -96,8 +100,8 @@ ;; due to syntax error via improper format of MORE-BINDINGS. ;; Regardless, the pprinter should faithfully indicate how BROKEN-MACRO expands. ;; All of these tests except for the baseline "accidentally working" case -;; either crash the pprinter or display incorrectly. -#+nil (with-test (:name :bug-1063414-unprintable-nested-backquote) +;; either crashed the pprinter or displayed incorrectly. +(with-test (:name :bug-1063414-unprintable-nested-backquote) (flet ((expect (expect form) (assert (string= (write-to-string (macroexpand-1 form)) expect)))) @@ -132,7 +136,7 @@ ,@BODY))) (WITH-BINDINGS (THING)))" '(broken-macro frob)))) -#+nil (with-test (:name :preserving-inner-backquotes) +(with-test (:name :preserving-inner-backquotes) (flet ((expect (expect val) (assert (string= (write-to-string val) expect)))) @@ -155,7 +159,7 @@ ;; That subform is "`,3" which is just 3. The inner quasiquote remains. (expect "`,3" ``,,`,3))) -#+nil (with-test (:name :preserving-backquotes-difficult) +(with-test (:name :preserving-backquotes-difficult) (assert (string= (write-to-string (let ((c 'cee) (d 'dee) (g 'gee) (h 'hooray)) `(`(a ,b ,',c ,,d) . `(e ,f ,',g ,,h)))) @@ -178,7 +182,7 @@ (sb-int:simple-reader-error (c) (simple-condition-format-control c))) "Trailing ~A in backquoted expression."))) -#+nil (with-test (:name :read-backq-vector-illegal) +(with-test (:name :read-backq-vector-illegal) (assert (eql (search "Improper list" (handler-case (read-from-string "`((a #(foo bar . ,(cons 1 2))))") @@ -201,10 +205,33 @@ ;; This is perhaps an interesting reason to make expansion policy-sensitive. ;; I'll test a case that definitely triggers the IR1 transform. (defun a-backq-expr (l1) `(,@l1 ,most-positive-fixnum a)) +(defun vector-backq-expr () `#(foo ,char-code-limit)) ; no xform, but folded (compile 'a-backq-expr) +(compile 'vector-backq-expr) (with-test (:name :backquote-ir1-simplifier) - ;; The compiled code should reference the a constant list + (assert (equal (macroexpand sb-impl::'`(,@l1 ,char-code-limit x)) + 'sb-impl::(|Append| l1 (|List*| char-code-limit '(X))))) + (assert (equal (macroexpand '`#(,char-code-limit sb-impl::foo)) + 'sb-impl::(|Vector| char-code-limit 'foo))) + ;; The compiled code should reference a constant list ;; whose two elements are #.MOST-POSITIVE-FIXNUM and A. (assert (member (list most-positive-fixnum 'a) (list-fun-referenced-constants #'a-backq-expr) - :test #'equal))) + :test #'equal)) + ;; Compiled code should reference a constant vector. + (assert (member (vector 'foo char-code-limit) + (list-fun-referenced-constants #'vector-backq-expr) + :test #'equalp))) + +(in-package sb-impl) + +(test-util:with-test (:name :backquote-more-weirdness) + ;; No expectation on any other Lisp. + (flet ((expect (expect val) + (assert (string= (write-to-string val) expect)))) + ;; There is one quasiquote and one comma + (expect "`(QUASIQUOTE QUASIQUOTE CADR ,FOO)" + '`(quasiquote quasiquote cadr ,foo)) + ;; There are three quasiquotes + (expect "```(CADR ,FOO)" + '`(quasiquote (quasiquote (cadr ,foo)))))) diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp index 73b9a27..4a138ab 100644 --- a/tests/dynamic-extent.impure.lisp +++ b/tests/dynamic-extent.impure.lisp @@ -971,16 +971,17 @@ (with-test (:name :bug-586105 :fails-on '(not (and :stack-allocatable-vectors :stack-allocatable-lists))) - (macrolet ((vector-of (a) `(vector ,a))) - (flet ((test (x) - (let ((vec1 (make-array 1 :initial-contents (list (list x)))) - (vec2 (make-array 1 :initial-contents `((,x)))) - (vec3 (make-array 1 :initial-contents (vector-of `(,x))))) - (declare (dynamic-extent vec1 vec2 vec3)) + (flet ((test (x) + (let ((vec1 (make-array 1 :initial-contents (list (list x)))) + (vec2 (make-array 1 :initial-contents `((,x)))) + (vec3 (make-array 1 :initial-contents `#((,x)))) + (vec4 (make-array 1 :initial-contents `(#(,x))))) + (declare (dynamic-extent vec1 vec2 vec3 vec4)) (assert (eql x (car (aref vec1 0)))) (assert (eql x (car (aref vec2 0)))) - (assert (eql x (car (aref vec3 0))))))) - (assert-no-consing (test 42))))) + (assert (eql x (car (aref vec3 0)))) + (assert (eql x (elt (aref vec4 0) 0)))))) + (assert-no-consing (test 42)))) (defun bug-681092 () (declare (optimize speed)) diff --git a/tests/pprint.impure.lisp b/tests/pprint.impure.lisp index 3635a4f..7ab82a2 100644 --- a/tests/pprint.impure.lisp +++ b/tests/pprint.impure.lisp @@ -122,7 +122,6 @@ (with-output-to-string (s) (write '`(foo ,@x) :stream s :pretty t :readably t)) "`(FOO ,@X)")) - #+nil ; '`(foo ,.x) => '`(foo ,@x) apparently. (assert (equal (with-output-to-string (s) (write '`(foo ,.x) :stream s :pretty t :readably t)) @@ -135,7 +134,6 @@ (with-output-to-string (s) (write '`(lambda ,@x) :stream s :pretty t :readably t)) "`(LAMBDA ,@X)")) - #+nil ; see above (assert (equal (with-output-to-string (s) (write '`(lambda ,.x) :stream s :pretty t :readably t)) @@ -146,12 +144,7 @@ "`(LAMBDA (,X))"))) ;;; more backquote printing brokenness, fixed quasi-randomly by CSR. -;;; NOTE KLUDGE FIXME: because our backquote optimizes at read-time, -;;; these assertions, like the ones above, are fragile. Likewise, it -;;; is very possible that at some point READABLY printing backquote -;;; expressions will have to change to printing the low-level conses, -;;; since the magical symbols are accessible though (car '`(,foo)) and -;;; friends. HATE HATE HATE. -- CSR, 2004-06-10 +;;; and fixed a little more by DPK. (with-test (:name :pprint-more-backquote-brokeness) (flet ((try (input expect) (assert (equalp (read-from-string expect) input)) diff --git a/tests/walk.impure.lisp b/tests/walk.impure.lisp index 2fefd8f..875fc18 100644 --- a/tests/walk.impure.lisp +++ b/tests/walk.impure.lisp @@ -861,6 +861,7 @@ Form: 'GLOBAL-FOO Context: EVAL `(INNER-FOO-EXPANDED ,A))) (FOO 1)) Context: EVAL Form: `(INNER-FOO-EXPANDED ,A) Context: EVAL +Form: (SB-IMPL::|List| 'INNER-FOO-EXPANDED A) Context: EVAL Form: 'INNER-FOO-EXPANDED Context: EVAL Form: A Context: EVAL; lexically bound Form: (FOO 1) Context: EVAL @@ -887,6 +888,7 @@ Form: (MACROLET ((BAR (A) `(IN... [truncated message content] |