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
(291) |
Apr
(215) |
May
(145) |
Jun
(128) |
Jul
(164) |
Aug
(143) |
Sep
(119) |
Oct
|
Nov
|
Dec
|
From: Douglas K. <sn...@us...> - 2015-07-08 23:17:25
|
The branch "master" has been updated in SBCL: via 1a64192727e7ce9659ad46e4cea2e2f01f1fbb34 (commit) from 6be1f09a1b6414c85d35708bf15ded8f3747efe1 (commit) - Log ----------------------------------------------------------------- commit 1a64192727e7ce9659ad46e4cea2e2f01f1fbb34 Author: Douglas Katzman <do...@go...> Date: Wed Jul 8 18:36:55 2015 -0400 Eliminate another 700 lines of stderr output in self-build. --- build-order.lisp-expr | 6 ++-- src/code/backq.lisp | 2 +- src/code/cross-byte.lisp | 4 +++ src/code/cross-misc.lisp | 17 ++++++++++++ src/code/cross-thread.lisp | 2 + src/code/defbangmacro.lisp | 6 ++-- src/code/defsetfs.lisp | 4 +- src/code/early-extensions.lisp | 9 ++++++ src/cold/warm.lisp | 2 +- src/compiler/early-globaldb.lisp | 18 +++++++++++++ src/compiler/generic/early-vm.lisp | 1 + src/compiler/info-vector.lisp | 48 ++++++++++++----------------------- src/compiler/macros.lisp | 7 ----- src/compiler/node.lisp | 7 +++++ src/pcl/slot-name.lisp | 2 +- 15 files changed, 86 insertions(+), 49 deletions(-) diff --git a/build-order.lisp-expr b/build-order.lisp-expr index 690c5d2..62de2c6 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -81,9 +81,9 @@ ;;; cross-compiler-only replacements for stuff which in target Lisp would be ;;; supplied by basic machinery + ("src/code/cross-byte" :not-target) ("src/code/cross-misc" :not-target) ("src/code/cross-char" :not-target) - ("src/code/cross-byte" :not-target) ("src/code/cross-boole" :not-target) ("src/code/cross-float" :not-target) ("src/code/cross-io" :not-target) @@ -128,6 +128,7 @@ ;; required for some code in 'early-extensions' ("src/code/barrier" :not-host) ("src/code/parse-body") ; on host for PARSE-BODY + ("src/code/unportable-float") ("src/code/early-extensions") ; on host for COLLECT, SYMBOLICATE, etc. ("src/compiler/parse-lambda-list") ("src/compiler/deftype") ; on host for SB!XC:DEFTYPE @@ -164,8 +165,6 @@ ("src/code/defbangstruct") - ("src/code/unportable-float") - ("src/code/funutils" :not-host) ;; This needs DEF!STRUCT, and is itself needed early so that structure @@ -199,6 +198,7 @@ ;; FIXME: more informative and up-to-date comment? ("src/code/toplevel" :not-host) ("src/code/cold-error" :not-host) + ("src/pcl/slot-name") ; for calls from 'info-vector' ;; 'info-vector' is needed at least as early as 'fdefinition' so that the ;; inlined INFO-VECTOR-FDEFINITION is available to %COERCE-CALLABLE-TO-FUN. ("src/compiler/info-vector") diff --git a/src/code/backq.lisp b/src/code/backq.lisp index 9aeb33c..d6e4858 100644 --- a/src/code/backq.lisp +++ b/src/code/backq.lisp @@ -342,6 +342,6 @@ ;;; function condition on SIMPLE-READER-ERROR. #+sb-xc-host ; proper definition happens for the target (defun simple-reader-error (stream format-string &rest format-args) - (bug "READER-ERROR on stream ~S: ~?" stream format-string format-args)) + (error "READER-ERROR on stream ~S: ~?" stream format-string format-args)) (/show0 "done with backq.lisp") diff --git a/src/code/cross-byte.lisp b/src/code/cross-byte.lisp index 319ad7d..c6e95d6 100644 --- a/src/code/cross-byte.lisp +++ b/src/code/cross-byte.lisp @@ -12,6 +12,9 @@ (in-package "SB!INT") +;; Inlining these allows type inference to work. +(declaim (inline sb!xc:dpb sb!xc:ldb sb!xc:mask-field)) + (defun sb!xc:byte (size position) (cons size position)) @@ -39,6 +42,7 @@ (defun sb!xc:deposit-field (new cross-byte int) (cl:deposit-field new (uncross-byte cross-byte) int)) +(declaim (ftype function bug)) (define-setf-expander sb!xc:ldb (cross-byte int &environment env) (multiple-value-bind (temps vals stores store-form access-form) (get-setf-expansion int env) diff --git a/src/code/cross-misc.lisp b/src/code/cross-misc.lisp index ade94fb..0374dd3 100644 --- a/src/code/cross-misc.lisp +++ b/src/code/cross-misc.lisp @@ -12,6 +12,23 @@ (in-package "SB!IMPL") +;;; Forward declarations + +(declaim (ftype (function (t &rest t) nil) sb!c::compiler-error) + (ftype function + bad-type + parse-body + sane-package + style-warn) + (ftype function + sb!fasl::allocate-struct + sb!fasl::target-push + sb!fasl::cold-cons + sb!fasl::cold-intern + sb!fasl::cold-svset + sb!fasl::cold-symbol-value + sb!fasl::write-slots)) + ;;; In correct code, TRULY-THE has only a performance impact and can ;;; be safely degraded to ordinary THE. (defmacro truly-the (type expr) diff --git a/src/code/cross-thread.lisp b/src/code/cross-thread.lisp index ddc0127..aa386ab 100644 --- a/src/code/cross-thread.lisp +++ b/src/code/cross-thread.lisp @@ -26,3 +26,5 @@ (defmacro barrier ((kind) &body body) (declare (ignore kind)) `(progn ,@body)) + +(defun thread-yield () nil) diff --git a/src/code/defbangmacro.lisp b/src/code/defbangmacro.lisp index 723a04e..85fd928 100644 --- a/src/code/defbangmacro.lisp +++ b/src/code/defbangmacro.lisp @@ -21,8 +21,8 @@ (progn ;; a description of the DEF!MACRO call to be stored until we get enough ;; of the system running to finish processing it - (defstruct delayed-def!macro - (args (missing-arg) :type cons) + (defstruct (delayed-def!macro (:constructor make-delayed-def!macro (args))) + (args nil :type cons) (package (sane-package) :type package)) ;; a list of DELAYED-DEF!MACROs stored until we get DEF!MACRO working fully ;; so that we can apply it to them. After DEF!MACRO is made to work, this @@ -41,7 +41,7 @@ (defmacro ,name ,@rest) ,(let ((uncrossed-args `(,(uncross name) ,@rest))) (if (boundp '*delayed-def!macros*) - `(push (make-delayed-def!macro :args ',uncrossed-args) + `(push (make-delayed-def!macro ',uncrossed-args) *delayed-def!macros*) `(sb!xc:defmacro ,@uncrossed-args)))) ;; When cross-compiling, we don't want the DEF!MACRO to have any diff --git a/src/code/defsetfs.lisp b/src/code/defsetfs.lisp index 95cc66c..93637cd 100644 --- a/src/code/defsetfs.lisp +++ b/src/code/defsetfs.lisp @@ -66,8 +66,8 @@ (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun %cxr-setf-expander (sub-accessor setter) (flet ((expand (place-reader original-form) - (let ((temp (sb!xc:gensym "LIST")) - (newval (sb!xc:gensym "NEW"))) + (let ((temp (make-symbol "LIST")) + (newval (make-symbol "NEW"))) (values (list temp) `((,@place-reader ,@(cdr original-form))) (list newval) diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 4c3b2dd..8c5baa9 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -1226,6 +1226,10 @@ :runtime-error runtime-error)) (defun deprecated-function (since name replacements &optional doc) + (declare (ignorable since name replacements doc)) + #+sb-xc-host + (error "Can't define deprecated functions on the host") + #-sb-xc-host (let ((closure ;; setting the name is mildly redundant since the closure captures ;; its name. However %FUN-DOC can't make use of that fact. @@ -1238,6 +1242,8 @@ (setf (%fun-doc closure) doc)) closure)) +;; Note: Naming a lambda does not work on the host, so we can't actually +;; detect deprecated functions. (defun deprecation-compiler-macro (state since name replacements) ;; this lambda's name is significant - see DEPRECATED-THING-P (named-lambda .deprecation-warning. (form env) @@ -1247,8 +1253,11 @@ ;; Return the stage of deprecation of thing identified by KIND and NAME, or NIL. (defun deprecated-thing-p (kind name) + (declare (ignorable kind name)) (ecase kind (:function + ;; This can't work on the host due to CLOSUREP,%FUN-NAME, etc. + #-sb-xc-host (let ((macro-fun (info :function :compiler-macro-function name))) (and (closurep macro-fun) (eq (%fun-name macro-fun) '.deprecation-warning.) diff --git a/src/cold/warm.lisp b/src/cold/warm.lisp index 363a70a..4cc3ec3 100644 --- a/src/cold/warm.lisp +++ b/src/cold/warm.lisp @@ -107,7 +107,7 @@ "SRC;PCL;MACROS" "SRC;PCL;COMPILER-SUPPORT" "SRC;PCL;LOW" - "SRC;PCL;SLOT-NAME" + #+nil "SRC;PCL;SLOT-NAME" ; moved to build-order.lisp-expr "SRC;PCL;DEFCLASS" "SRC;PCL;DEFS" "SRC;PCL;FNGEN" diff --git a/src/compiler/early-globaldb.lisp b/src/compiler/early-globaldb.lisp index eb817b8..a758182 100644 --- a/src/compiler/early-globaldb.lisp +++ b/src/compiler/early-globaldb.lisp @@ -15,6 +15,10 @@ ;;; but such nuance isn't hugely important. (in-package "SB!C") +(declaim (ftype (function (t t t) (values t t &optional)) info) + (ftype (function (t t t) (values t &optional)) clear-info) + (ftype (function (t t t t) (values t &optional)) (setf info))) + ;;; At run time, we represent the type of a piece of INFO in the globaldb ;;; by a small integer between 1 and 63. [0 is reserved for internal use.] ;;; CLISP, and maybe others, need EVAL-WHEN because without it, the constant @@ -62,6 +66,12 @@ ;; Refer to info-vector.lisp for the meaning of this constant. (defconstant +no-auxilliary-key+ 0) +;;; SYMBOL-INFO is a primitive object accessor defined in 'objdef.lisp' +;;; But in the host Lisp, there is no such thing as a symbol-info slot. +;;; Instead, symbol-info is kept in the host symbol's plist. +#+sb-xc-host +(defmacro symbol-info-vector (symbol) `(get ,symbol :sb-xc-globaldb-info)) + ;; Perform the equivalent of (GET-INFO-VALUE KIND +INFO-METAINFO-TYPE-NUM+) ;; but skipping the defaulting logic. ;; Return zero or more META-INFOs that match on KIND, which is usually @@ -75,6 +85,14 @@ +info-metainfo-type-num+)))) (if index (svref info-vector index)))) +;; (UNSIGNED-BYTE 16) is an arbitrarily generous limit on the number of +;; cells in an info-vector. Most vectors have a fewer than a handful of things, +;; and performance would need to be re-thought if more than about a dozen +;; cells were in use. (It would want to become hash-based probably) +(declaim (ftype (function (simple-vector (or (eql 0) symbol) info-number) + (or null (unsigned-byte 16))) + packed-info-value-index)) + ;; Return the META-INFO object for CATEGORY and KIND, signaling an error ;; if not found and ERRORP is non-nil. Note that the two-level logical hierarchy ;; of CATEGORY + KIND is physically grouped by KIND first, then CATEGORY. diff --git a/src/compiler/generic/early-vm.lisp b/src/compiler/generic/early-vm.lisp index 91d916b..9c2bd17 100644 --- a/src/compiler/generic/early-vm.lisp +++ b/src/compiler/generic/early-vm.lisp @@ -85,6 +85,7 @@ (let ((stop (1- (ash 1 n-word-bits))) (start dynamic-space-start)) (dolist (other-start (list read-only-space-start static-space-start linkage-table-space-start)) + (declare (notinline <)) ; avoid dead code note (when (< start other-start) (setf stop (min stop other-start)))) stop)) diff --git a/src/compiler/info-vector.lisp b/src/compiler/info-vector.lisp index f005131..9ca15fd 100644 --- a/src/compiler/info-vector.lisp +++ b/src/compiler/info-vector.lisp @@ -502,17 +502,9 @@ ;; A field is either a count of info-numbers, or an info-number. (declaim (inline packed-info-field)) (defun packed-info-field (vector desc-index field-index) - ;; Should not need (THE INFO-NUMBER) however type inference - ;; seems borked during cross-compilation due to the shadowed LDB - ;; (see "don't watch:" in cold/defun-load-or-cload-xcompiler) - ;; and in particular it sees especially weird that this message appears - ;; note: type assertion too complex to check: - ;; (VALUES (UNSIGNED-BYTE 6) &REST T). - ;; because nothing here should be possibly-multiple-value-producing. - (the info-number - (ldb (byte info-number-bits - (* (the (mod #.+infos-per-word+) field-index) info-number-bits)) - (the info-descriptor (svref vector desc-index))))) + (ldb (byte info-number-bits + (* (the (mod #.+infos-per-word+) field-index) info-number-bits)) + (the info-descriptor (svref vector desc-index)))) ;; Compute the number of elements needed to hold unpacked VECTOR after packing. ;; This is not "compute-packed-info-size" since that could be misconstrued @@ -862,10 +854,6 @@ ;; Search packed VECTOR for AUX-KEY and INFO-NUMBER, returning ;; the index of the data if found, or NIL if not found. ;; -(declaim (ftype (function (simple-vector (or (eql 0) symbol) info-number) - (or null index)) - packed-info-value-index)) - (defun packed-info-value-index (vector aux-key type-num) (declare (optimize (safety 0))) ; vector bounds are AVERed (let ((data-idx (length vector)) (descriptor-idx 0) (field-idx 0)) @@ -1120,20 +1108,16 @@ This is interpreted as ;;; Some of this stuff might belong in 'symbol.lisp', but can't be, ;;; because 'symbol.lisp' is :NOT-HOST in build-order. +;; In the target, UPDATE-SYMBOL-INFO is defined in 'symbol.lisp'. #+sb-xc-host -;; SYMBOL-INFO is a primitive object accessor defined in 'objdef.lisp' -;; and UPDATE-SYMBOL-INFO is defined in 'symbol.lisp'. -;; But in the host Lisp, there is no such thing as a symbol-info slot, -;; even if the host is SBCL. Instead, symbol-info is kept in the symbol-plist. -(macrolet ((get-it () '(get symbol :sb-xc-globaldb-info))) - (defun symbol-info (symbol) (get-it)) - (defun update-symbol-info (symbol update-fn) - ;; Never pass NIL to an update-fn. Pass the minimal info-vector instead, - ;; a vector describing 0 infos and 0 auxilliary keys. - (let ((newval (funcall update-fn (or (get-it) +nil-packed-infos+)))) - (when newval - (setf (get-it) newval)) - (values)))) +(defun update-symbol-info (symbol update-fn) + ;; Never pass NIL to an update-fn. Pass the minimal info-vector instead, + ;; a vector describing 0 infos and 0 auxilliary keys. + (let ((newval (funcall update-fn (or (symbol-info-vector symbol) + +nil-packed-infos+)))) + (when newval + (setf (symbol-info-vector symbol) newval)) + (values))) ;; Return the globaldb info for SYMBOL. With respect to the state diagram ;; presented at the definition of SYMBOL-PLIST, if the object in SYMBOL's @@ -1142,11 +1126,13 @@ This is interpreted as ;; In terms of this function being named "-vector", implying always a vector, ;; it is understood that NIL is a proxy for +NIL-PACKED-INFOS+, a vector. ;; -#!-symbol-info-vops (declaim (inline symbol-info-vector)) -(defun symbol-info-vector (symbol) +#-sb-xc-host +(progn + #!-symbol-info-vops (declaim (inline symbol-info-vector)) + (defun symbol-info-vector (symbol) (let ((info-holder (symbol-info symbol))) (truly-the (or null simple-vector) - (if (listp info-holder) (cdr info-holder) info-holder)))) + (if (listp info-holder) (cdr info-holder) info-holder))))) ;;; The current *INFO-ENVIRONMENT*, a structure of type INFO-HASHTABLE. ;;; Cheat by setting to nil before the type is proclaimed diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index 153d534..7fedfd5 100644 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -721,13 +721,6 @@ (%with-ir1-environment-from-node ,node #'closure-needing-ir1-environment-from-node))) -(defun %with-ir1-environment-from-node (node fun) - (declare (type node node) (type function fun)) - (let ((*current-component* (node-component node)) - (*lexenv* (node-lexenv node)) - (*current-path* (node-source-path node))) - (aver-live-component *current-component*) - (funcall fun))) (defmacro with-source-paths (&body forms) (with-unique-names (source-paths) diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp index 217ebe4..e946410 100644 --- a/src/compiler/node.lisp +++ b/src/compiler/node.lisp @@ -136,6 +136,13 @@ ;; If the back-end breaks tail-recursion for some reason, then it ;; can null out this slot. (tail-p nil :type boolean)) +(defun %with-ir1-environment-from-node (node fun) + (declare (type node node) (type function fun)) + (let ((*current-component* (node-component node)) + (*lexenv* (node-lexenv node)) + (*current-path* (node-source-path node))) + (aver-live-component *current-component*) + (funcall fun))) (def!struct (valued-node (:conc-name node-) (:include node) diff --git a/src/pcl/slot-name.lisp b/src/pcl/slot-name.lisp index ef34268..015648f 100644 --- a/src/pcl/slot-name.lisp +++ b/src/pcl/slot-name.lisp @@ -21,7 +21,7 @@ ;;;; warranty about the software, its performance or its conformity to any ;;;; specification. -(in-package "SB-PCL") +(in-package "SB!PCL") ;; This choice of naming structure is perhaps unfortunate, because were the ;; names 2-lists, the globaldb hack to support this would instead be ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2015-07-08 23:17:23
|
The branch "master" has been updated in SBCL: via 6be1f09a1b6414c85d35708bf15ded8f3747efe1 (commit) from 888b6b856f4fbe01bcbebe9f5671e42944485c3c (commit) - Log ----------------------------------------------------------------- commit 6be1f09a1b6414c85d35708bf15ded8f3747efe1 Author: Douglas Katzman <do...@go...> Date: Wed Jul 8 18:35:40 2015 -0400 Define %INSTANCE-REF later in the cross-compiler. Putting it after CLASSOID is defined avoids some efficiency notes. --- src/code/defbangstruct.lisp | 74 ------------------------------------------- src/code/defstruct.lisp | 63 ++++++++++++++++++++++++++++++++++++ 2 files changed, 63 insertions(+), 74 deletions(-) diff --git a/src/code/defbangstruct.lisp b/src/code/defbangstruct.lisp index f1cbe08..9304d16 100644 --- a/src/code/defbangstruct.lisp +++ b/src/code/defbangstruct.lisp @@ -165,80 +165,6 @@ (push `(:include ,def!struct-supertype) options))) (values name `((,name ,@options) ,@rest) mlff def!struct-supertype))))) -;;; Part of the raison d'etre for DEF!STRUCT is to be able to emulate -;;; these low-level CMU CL functions in a vanilla ANSI Common Lisp -;;; cross compilation host. (The emulation doesn't need to be -;;; efficient, since it's needed for things like dumping objects, not -;;; inner loops.) -#+sb-xc-host -(progn - (defun xc-dumpable-structure-instance-p (x) - (and (typep x 'cl:structure-object) - (let ((name (type-of x))) - ;; Don't allow totally random structures, only ones that the - ;; cross-compiler has been advised will work. - (and (get name :sb-xc-allow-dumping-instances) - ;; but we must also have cross-compiled it for real. - (sb!kernel::compiler-layout-ready-p name) - ;; and I don't know anything about raw slots - ;; Coincidentally, in either representation of - ;; raw-slot-metadata, 0 represents no untagged slots. - (zerop (layout-raw-slot-metadata - (info :type :compiler-layout name))))))) - (defun %instance-layout (instance) - (aver (or (typep instance 'structure!object) - (xc-dumpable-structure-instance-p instance))) - (classoid-layout (find-classoid (type-of instance)))) - (defun %instance-length (instance) - ;; INSTANCE-LENGTH tells you how many data words the backend is able to - ;; physically access in this structure. Since every structure occupies - ;; an even number of words, the storage slots comprise an odd number - ;; of words after subtracting 1 for the header. - ;; And in fact the fasl dumper / loader do write and read potentially - ;; one cell beyond the instance's LAYOUT-LENGTH if it was not odd. - ;; I'm not sure whether that is a good or bad thing. - ;; But be that as it may, in the cross-compiler you must not access - ;; more cells than there are in the declared structure because there - ;; is no lower level storage that you can peek at. - ;; So INSTANCE-LENGTH is exactly the same as LAYOUT-LENGTH on the host. - (layout-length (%instance-layout instance))) - (defun %instance-ref (instance index) - (let ((layout (%instance-layout instance))) - ;; with compact headers, 0 is an ordinary slot index. - ;; without, it's the layout. - (if (eql index (1- sb!vm:instance-data-start)) - (error "XC Host should use %INSTANCE-LAYOUT, not %INSTANCE-REF 0") - (let* ((dd (layout-info layout)) - ;; If data starts at 1, then subtract 1 from index. - ;; otherwise use the index as-is. - (dsd (elt (dd-slots dd) - (- index sb!vm:instance-data-start))) - (accessor-name (dsd-accessor-name dsd))) - ;; Why AVER these: because it is slightly abstraction-breaking - ;; to assume that the slot-index N is the NTH item in the DSDs. - ;; The target Lisp never assumes that. - (aver (and (eql (dsd-index dsd) index) (eq (dsd-raw-type dsd) t))) - (funcall accessor-name instance))))) - ;; I believe this approach is technically nonportable because CLHS says that - ;; "The mechanism by which defstruct arranges for slot accessors to be usable - ;; with setf is implementation-dependent; for example, it may use setf - ;; functions, setf expanders, or some other implementation-dependent - ;; mechanism ..." - ;; As it happens, many implementations provide both functions and expanders. - ;; But ... this seems never to be needed. - (defun %instance-set (instance index new-value) - (aver (typep instance 'structure!object)) ; a stronger condition than above - (let ((layout (%instance-layout instance))) - (if (< index sb!vm:instance-data-start) - (error "can't set %INSTANCE-REF FOO 0 in cross-compilation host") - (let* ((dd (layout-info layout)) - (dsd (elt (dd-slots dd) (- index sb!vm:instance-data-start))) - (accessor-name (dsd-accessor-name dsd))) - (declare (type symbol accessor-name)) - (funcall (fdefinition `(setf ,accessor-name)) - new-value - instance)))))) - ;;; a helper function for DEF!STRUCT in the #+SB-XC-HOST case: Return ;;; DEFSTRUCT-style arguments with any class names in the SB!XC ;;; package (i.e. the name of the class being defined, and/or the diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 8d351b2..86de3d5 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -1984,4 +1984,67 @@ or they must be declared locally notinline at each call site.~@:>") (defstruct-slot-description-p (cdr info)) info))) +;;; These functions are required to emulate SBCL kernel functions +;;; in a vanilla ANSI Common Lisp cross-compilation host. +;;; The emulation doesn't need to be efficient, since it's needed +;;; only for object dumping. +#+sb-xc-host +(progn + (defun xc-dumpable-structure-instance-p (x) + (and (typep x 'cl:structure-object) + (let ((name (type-of x))) + ;; Don't allow totally random structures, only ones that the + ;; cross-compiler has been advised will work. + (and (get name :sb-xc-allow-dumping-instances) + ;; but we must also have cross-compiled it for real. + (sb!kernel::compiler-layout-ready-p name) + ;; and I don't know anything about raw slots + ;; Coincidentally, in either representation of + ;; raw-slot-metadata, 0 represents no untagged slots. + (zerop (layout-raw-slot-metadata + (info :type :compiler-layout name))))))) + (defun %instance-layout (instance) + (aver (or (typep instance 'structure!object) + (xc-dumpable-structure-instance-p instance))) + (classoid-layout (find-classoid (type-of instance)))) + (defun %instance-length (instance) + ;; INSTANCE-LENGTH tells you how many data words the backend is able to + ;; physically access in this structure. Since every structure occupies + ;; an even number of words, the storage slots comprise an odd number + ;; of words after subtracting 1 for the header. + ;; And in fact the fasl dumper / loader do write and read potentially + ;; one cell beyond the instance's LAYOUT-LENGTH if it was not odd. + ;; I'm not sure whether that is a good or bad thing. + ;; But be that as it may, in the cross-compiler you must not access + ;; more cells than there are in the declared structure because there + ;; is no lower level storage that you can peek at. + ;; So INSTANCE-LENGTH is exactly the same as LAYOUT-LENGTH on the host. + (layout-length (%instance-layout instance))) + (defun %instance-ref (instance index) + (let ((layout (%instance-layout instance))) + ;; with compact headers, 0 is an ordinary slot index. + ;; without, it's the layout. + (if (eql index (1- sb!vm:instance-data-start)) + (error "XC Host should use %INSTANCE-LAYOUT, not %INSTANCE-REF 0") + (let* ((dd (layout-info layout)) + ;; If data starts at 1, then subtract 1 from index. + ;; otherwise use the index as-is. + (dsd (elt (dd-slots dd) + (- index sb!vm:instance-data-start))) + (accessor-name (dsd-accessor-name dsd))) + ;; Why AVER these: because it is slightly abstraction-breaking + ;; to assume that the slot-index N is the NTH item in the DSDs. + ;; The target Lisp never assumes that. + (aver (and (eql (dsd-index dsd) index) (eq (dsd-raw-type dsd) t))) + (funcall accessor-name instance))))) + ;; Setting with (FUNCALL `(SETF ,accessor) ...) is unportable because + ;; "The mechanism by which defstruct arranges for slot accessors to be + ;; usable with setf is implementation-dependent; for example, it may + ;; use setf functions, setf expanders, or some other + ;; implementation-dependent mechanism ..." + ;; But such capability seems not to be needed. + (defun %instance-set (instance index new-value) + (declare (ignore instance index new-value)) + (error "Can not use %INSTANCE-SET on cross-compilation host."))) + (/show0 "code/defstruct.lisp end of file") ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2015-07-08 23:17:21
|
The branch "master" has been updated in SBCL: via 888b6b856f4fbe01bcbebe9f5671e42944485c3c (commit) from 94af48bb907c10a7ef25a4d31a44a4d625fb5f84 (commit) - Log ----------------------------------------------------------------- commit 888b6b856f4fbe01bcbebe9f5671e42944485c3c Author: Douglas Katzman <do...@go...> Date: Tue Jul 7 22:41:58 2015 -0400 Make SANE-PACKAGE really robust against type errors. The sanity-check achieved just about nothing in a self-hosted build, and unsafe code could have still destroyed the target system. Also fix a bunch of style-warnings in package tests. --- src/code/primordial-extensions.lisp | 35 ++++++++++++------ tests/packages.impure.lisp | 68 ++++++++++++++++------------------- 2 files changed, 54 insertions(+), 49 deletions(-) diff --git a/src/code/primordial-extensions.lisp b/src/code/primordial-extensions.lisp index 50614eb..6cb208b 100644 --- a/src/code/primordial-extensions.lisp +++ b/src/code/primordial-extensions.lisp @@ -194,42 +194,53 @@ (apply #'symbolicate things))) ;;; Access *PACKAGE* in a way which lets us recover when someone has -;;; done something silly like (SETF *PACKAGE* :CL-USER). (Such an -;;; assignment is undefined behavior, so it's sort of reasonable for +;;; done something silly like (SETF *PACKAGE* :CL-USER) in unsafe code. +;;; (Such an assignment is undefined behavior, so it's sort of reasonable for ;;; it to cause the system to go totally insane afterwards, but it's a -;;; fairly easy mistake to make, so let's try to recover gracefully -;;; instead.) +;;; fairly easy mistake to make, so let's try to recover gracefully instead.) ;;; This function is called while compiling this file because DO-ANONYMOUS ;;; is a delayed-def!macro, the constructor for which calls SANE-PACKAGE. (eval-when (:load-toplevel :execute #+sb-xc-host :compile-toplevel) (defun sane-package () - (let ((maybe-package *package*)) - (cond ((and (packagep maybe-package) + ;; Perhaps it's possible for *PACKAGE* to be set to a non-package in some + ;; host Lisp, but in SBCL it isn't, and the PACKAGEP test below would be + ;; elided unless forced to be NOTINLINE. + (declare (notinline packagep)) + (let* ((maybe-package *package*) + (packagep (packagep maybe-package))) + ;; And if we don't also always check for deleted packages - as was true + ;; when the "#+sb-xc-host" reader condition was absent - then half of the + ;; COND becomes unreachable, making this function merely return *PACKAGE* + ;; in the cross-compiler, producing a code deletion note. + (cond ((and packagep ;; For good measure, we also catch the problem of ;; *PACKAGE* being bound to a deleted package. ;; Technically, this is not undefined behavior in itself, ;; but it will immediately lead to undefined to behavior, ;; since almost any operation on a deleted package is ;; undefined. - #-sb-xc-host - (package-%name maybe-package)) + ;; The "%" accessor avoids calling %FIND-PACKAGE-OR-LOSE, + ;; though it probably does not make much difference, if any. + (#+sb-xc-host package-name #-sb-xc-host package-%name + maybe-package)) maybe-package) (t ;; We're in the undefined behavior zone. First, munge the ;; system back into a defined state. - (let ((really-package (find-package :cl-user))) + (let ((really-package + (load-time-value (find-package :cl-user) t))) (setf *package* really-package) ;; Then complain. (error 'simple-type-error :datum maybe-package :expected-type '(and package (satisfies package-name)) :format-control - "~@<~S can't be a ~A: ~2I~_~S has been reset to ~S.~:>" + "~@<~S can't be a ~A: ~2I~_It has been reset to ~S.~:>" :format-arguments (list '*package* - (if (packagep maybe-package) + (if packagep "deleted package" (type-of maybe-package)) - '*package* really-package)))))))) + really-package)))))))) ;;; Access *DEFAULT-PATHNAME-DEFAULTS*, issuing a warning if its value ;;; is silly. (Unlike the vaguely-analogous SANE-PACKAGE, we don't diff --git a/tests/packages.impure.lisp b/tests/packages.impure.lisp index aa78ab1..ceabc2c 100644 --- a/tests/packages.impure.lisp +++ b/tests/packages.impure.lisp @@ -11,6 +11,14 @@ ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. +(defun set-bad-package (x) + (declare (optimize (safety 0))) + (setq *package* x)) + +(with-test (:name :set-bad-package) + (set-bad-package :cl-user) + (assert-error (intern "FRED") type-error)) + (with-test (:name :packages-sanely-nicknamed) (dolist (p (list-all-packages)) (let* ((nicks (package-nicknames p)) @@ -300,7 +308,7 @@ if a restart was invoked." ;; This used to fail with "NIL does not name a package" (with-test (:name :with-package-iterator-nil-list) (with-package-iterator (iter '() :internal) - (print (nth-value 1 (iter))))) + (assert (null (iter))))) ;;; MAKE-PACKAGE error in another thread blocking FIND-PACKAGE & FIND-SYMBOL (with-test (:name :bug-511072 :skipped-on '(not :sb-thread)) @@ -313,11 +321,19 @@ if a restart was invoked." (sb-thread:wait-on-semaphore sem2) (abort c)))) (make-package :bug-511072)))))) + (declare (ignore p t2)) (sb-thread:wait-on-semaphore sem1) (with-timeout 10 (assert (eq 'cons (read-from-string "CL:CONS")))) (sb-thread:signal-semaphore sem2))) +(defmacro handling ((condition restart-name) form) + `(handler-bind ((,condition (lambda (c) + (declare (ignore c)) + (invoke-restart ',restart-name)))) + ,form)) + + (with-test (:name :quick-name-conflict-resolution-import) (let (p1 p2) (unwind-protect @@ -325,12 +341,10 @@ if a restart was invoked." (setf p1 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-IMPORT.1") p2 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-IMPORT.2")) (intern "FOO" p1) - (handler-bind ((name-conflict (lambda (c) - (invoke-restart 'sb-impl::dont-import-it)))) + (handling (name-conflict sb-impl::dont-import-it) (import (intern "FOO" p2) p1)) (assert (not (eq (intern "FOO" p1) (intern "FOO" p2)))) - (handler-bind ((name-conflict (lambda (c) - (invoke-restart 'sb-impl::shadowing-import-it)))) + (handling (name-conflict sb-impl::shadowing-import-it) (import (intern "FOO" p2) p1)) (assert (eq (intern "FOO" p1) (intern "FOO" p2)))) (when p1 (delete-package p1)) @@ -344,8 +358,7 @@ if a restart was invoked." p2 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-EXPORT.2a")) (intern "FOO" p1) (use-package p2 p1) - (handler-bind ((name-conflict (lambda (c) - (invoke-restart 'sb-impl::keep-old)))) + (handling (name-conflict sb-impl::keep-old) (export (intern "FOO" p2) p2)) (assert (not (eq (intern "FOO" p1) (intern "FOO" p2))))) (when p1 (delete-package p1)) @@ -359,8 +372,7 @@ if a restart was invoked." p2 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-EXPORT.2b")) (intern "FOO" p1) (use-package p2 p1) - (handler-bind ((name-conflict (lambda (c) - (invoke-restart 'sb-impl::take-new)))) + (handling (name-conflict sb-impl::take-new) (export (intern "FOO" p2) p2)) (assert (eq (intern "FOO" p1) (intern "FOO" p2)))) (when p1 (delete-package p1)) @@ -376,8 +388,7 @@ if a restart was invoked." (intern "BAR" p1) (export (intern "FOO" p2) p2) (export (intern "BAR" p2) p2) - (handler-bind ((name-conflict (lambda (c) - (invoke-restart 'sb-impl::keep-old)))) + (handling (name-conflict sb-impl::keep-old) (use-package p2 p1)) (assert (not (eq (intern "FOO" p1) (intern "FOO" p2)))) (assert (not (eq (intern "BAR" p1) (intern "BAR" p2))))) @@ -394,8 +405,7 @@ if a restart was invoked." (intern "BAR" p1) (export (intern "FOO" p2) p2) (export (intern "BAR" p2) p2) - (handler-bind ((name-conflict (lambda (c) - (invoke-restart 'sb-impl::take-new)))) + (handling (name-conflict sb-impl::take-new) (use-package p2 p1)) (assert (eq (intern "FOO" p1) (intern "FOO" p2))) (assert (eq (intern "BAR" p1) (intern "BAR" p2)))) @@ -410,15 +420,11 @@ if a restart was invoked." (setf p (eval `(defpackage :package-at-variance-restarts.1 (:use :cl) (:shadow "CONS")))) - (handler-bind ((sb-kernel::package-at-variance-error - (lambda (c) - (invoke-restart 'sb-impl::keep-them)))) + (handling (sb-kernel::package-at-variance-error sb-impl::keep-them) (eval `(defpackage :package-at-variance-restarts.1 (:use :cl)))) (assert (not (eq 'cl:cons (intern "CONS" p)))) - (handler-bind ((sb-kernel::package-at-variance-error - (lambda (c) - (invoke-restart 'sb-impl::drop-them)))) + (handling (sb-kernel::package-at-variance-error sb-impl::drop-them) (eval `(defpackage :package-at-variance-restarts.1 (:use :cl)))) (assert (eq 'cl:cons (intern "CONS" p)))) @@ -431,15 +437,11 @@ if a restart was invoked." (progn (setf p (eval `(defpackage :package-at-variance-restarts.2 (:use :cl)))) - (handler-bind ((sb-kernel::package-at-variance-error - (lambda (c) - (invoke-restart 'sb-impl::keep-them)))) + (handling (sb-kernel::package-at-variance-error sb-impl::keep-them) (eval `(defpackage :package-at-variance-restarts.2 (:use)))) (assert (eq 'cl:cons (intern "CONS" p))) - (handler-bind ((sb-kernel::package-at-variance-error - (lambda (c) - (invoke-restart 'sb-impl::drop-them)))) + (handling (sb-kernel::package-at-variance-error sb-impl::drop-them) (eval `(defpackage :package-at-variance-restarts.2 (:use)))) (assert (not (eq 'cl:cons (intern "CONS" p))))) @@ -452,14 +454,10 @@ if a restart was invoked." (progn (setf p (eval `(defpackage :package-at-variance-restarts.4 (:export "FOO")))) - (handler-bind ((sb-kernel::package-at-variance-error - (lambda (c) - (invoke-restart 'sb-impl::keep-them)))) + (handling (sb-kernel::package-at-variance-error sb-impl::keep-them) (eval `(defpackage :package-at-variance-restarts.4))) (assert (eq :external (nth-value 1 (find-symbol "FOO" p)))) - (handler-bind ((sb-kernel::package-at-variance-error - (lambda (c) - (invoke-restart 'sb-impl::drop-them)))) + (handling (sb-kernel::package-at-variance-error sb-impl::drop-them) (eval `(defpackage :package-at-variance-restarts.4))) (assert (eq :internal (nth-value 1 (find-symbol "FOO" p))))) (when p (delete-package p))))) @@ -471,14 +469,10 @@ if a restart was invoked." (progn (setf p (eval `(defpackage :package-at-variance-restarts.5 (:implement :sb-int)))) - (handler-bind ((sb-kernel::package-at-variance-error - (lambda (c) - (invoke-restart 'sb-impl::keep-them)))) + (handling (sb-kernel::package-at-variance-error sb-impl::keep-them) (eval `(defpackage :package-at-variance-restarts.5))) (assert (member p (package-implemented-by-list :sb-int))) - (handler-bind ((sb-kernel::package-at-variance-error - (lambda (c) - (invoke-restart 'sb-impl::drop-them)))) + (handling (sb-kernel::package-at-variance-error sb-impl::drop-them) (eval `(defpackage :package-at-variance-restarts.5))) (assert (not (member p (package-implemented-by-list :sb-int))))) (when p (delete-package p))))) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2015-07-08 23:17:18
|
The branch "master" has been updated in SBCL: via 94af48bb907c10a7ef25a4d31a44a4d625fb5f84 (commit) from c2be985fb9d4e2ef905e033c5283e6479d7597f9 (commit) - Log ----------------------------------------------------------------- commit 94af48bb907c10a7ef25a4d31a44a4d625fb5f84 Author: Douglas Katzman <do...@go...> Date: Tue Jul 7 21:27:43 2015 -0400 Remove SAP+ from xc. It is unused. And there is no SAP-INT type nor MAKE-SAP function. --- src/code/cross-sap.lisp | 3 --- 1 files changed, 0 insertions(+), 3 deletions(-) diff --git a/src/code/cross-sap.lisp b/src/code/cross-sap.lisp index e5f7d51..c613328 100644 --- a/src/code/cross-sap.lisp +++ b/src/code/cross-sap.lisp @@ -21,9 +21,6 @@ (int nil :type unsigned-byte :read-only t)) ;;; cross-compilation-host analogues of target-CMU CL primitive SAP operations -(defun sap+ (sap offset) - (declare (type system-area-pointer sap) (type sap-int offset)) - (make-sap :int (+ (sap-int sap) offset))) #.`(progn ,@(mapcar (lambda (info) (destructuring-bind (sap-fun int-fun) info ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Jan M. <sc...@us...> - 2015-07-08 21:51:36
|
The branch "master" has been updated in SBCL: via c2be985fb9d4e2ef905e033c5283e6479d7597f9 (commit) from 912f83f8ac0c1458fc2f4f38001ac50503b1fce7 (commit) - Log ----------------------------------------------------------------- commit c2be985fb9d4e2ef905e033c5283e6479d7597f9 Author: Jan Moringen <jmo...@te...> Date: Wed Jul 8 03:39:26 2015 +0200 sb-mpfr: Fix use of deprecated package SB-C-CALL --- contrib/sb-mpfr/mpfr.lisp | 2 +- 1 files changed, 1 insertions(+), 1 deletions(-) diff --git a/contrib/sb-mpfr/mpfr.lisp b/contrib/sb-mpfr/mpfr.lisp index 6a6fa92..323968e 100644 --- a/contrib/sb-mpfr/mpfr.lisp +++ b/contrib/sb-mpfr/mpfr.lisp @@ -1,5 +1,5 @@ (defpackage :sb-mpfr - (:use "COMMON-LISP" "SB-ALIEN" "SB-C-CALL") + (:use "COMMON-LISP" "SB-ALIEN") (:import-from "SB-GMP" #:make-gmp-rstate #:make-gmp-rstate-lc ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Jan M. <sc...@us...> - 2015-07-08 21:51:34
|
The branch "master" has been updated in SBCL: via 912f83f8ac0c1458fc2f4f38001ac50503b1fce7 (commit) from 6102b240d6bd41b73236d26cbe88104365a6d03f (commit) - Log ----------------------------------------------------------------- commit 912f83f8ac0c1458fc2f4f38001ac50503b1fce7 Author: Jan Moringen <jmo...@te...> Date: Wed Jul 8 03:38:03 2015 +0200 sb-aclrepl: Fix uses of deprecated SB-{DEBUG,THREAD} functions * SB-DEBUG:BACKTRACE -> SB-DEBUG:PRINT-BACKTRACE * SB-THREAD:DESTROY-THREAD -> SB-THREAD:DESTROY-THREAD --- contrib/sb-aclrepl/repl.lisp | 4 ++-- 1 files changed, 2 insertions(+), 2 deletions(-) diff --git a/contrib/sb-aclrepl/repl.lisp b/contrib/sb-aclrepl/repl.lisp index 7997a79..d59a35f 100644 --- a/contrib/sb-aclrepl/repl.lisp +++ b/contrib/sb-aclrepl/repl.lisp @@ -491,7 +491,7 @@ (values)) (defun bt-cmd (&optional (n most-positive-fixnum)) - (sb-debug::backtrace n)) + (sb-debug:print-backtrace n)) (defun current-cmd () (sb-debug::describe-debug-command)) @@ -580,7 +580,7 @@ (if found (progn (format *output* "~&Destroying thread ~A" thread) - (sb-thread:destroy-thread found)) + (sb-thread:terminate-thread found)) (format *output* "~&Thread ~A not found" thread)))) #-sb-thread (declare (ignore selected-threads)) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2015-07-07 01:55:04
|
The branch "master" has been updated in SBCL: via 6102b240d6bd41b73236d26cbe88104365a6d03f (commit) from 44ca6f2f37cc9ffc8b6ec8ae15791e7157f81053 (commit) - Log ----------------------------------------------------------------- commit 6102b240d6bd41b73236d26cbe88104365a6d03f Author: Douglas Katzman <do...@go...> Date: Mon Jul 6 21:37:28 2015 -0400 Define quantifiers as source-transforms. This avoids style-warnings during self-build due to the compiler-macro being defined too late. --- build-order.lisp-expr | 1 + src/code/early-extensions.lisp | 12 ++-- src/code/quantifiers.lisp | 99 ++++++++++++++++++++++++++++++++++++++++ src/code/seq.lisp | 94 -------------------------------------- 4 files changed, 106 insertions(+), 100 deletions(-) diff --git a/build-order.lisp-expr b/build-order.lisp-expr index ecd3207..690c5d2 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -522,6 +522,7 @@ ("src/compiler/float-tran") ("src/compiler/saptran") ("src/compiler/srctran") + ("src/code/quantifiers") ("src/compiler/bitops-derive-type") ("src/compiler/generic/vm-tran") ("src/compiler/locall") diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index a9f5170..4c3b2dd 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -1541,17 +1541,17 @@ to :INTERPRET, an interpreter will be used.") ;;; Helper for making the DX closure allocation in macros expanding ;;; to CALL-WITH-FOO less ugly. -(defmacro dx-flet (functions &body forms) +(def!macro dx-flet (functions &body forms) `(flet ,functions - (declare (#+sb-xc-host dynamic-extent #-sb-xc-host truly-dynamic-extent - ,@(mapcar (lambda (func) `(function ,(car func))) functions))) + (declare (truly-dynamic-extent ,@(mapcar (lambda (func) `#',(car func)) + functions))) ,@forms)) ;;; Another similar one. -(defmacro dx-let (bindings &body forms) +(def!macro dx-let (bindings &body forms) `(let ,bindings - (declare (#+sb-xc-host dynamic-extent #-sb-xc-host truly-dynamic-extent - ,@(mapcar (lambda (bind) (if (consp bind) (car bind) bind)) + (declare (truly-dynamic-extent + ,@(mapcar (lambda (bind) (if (listp bind) (car bind) bind)) bindings))) ,@forms)) diff --git a/src/code/quantifiers.lisp b/src/code/quantifiers.lisp new file mode 100644 index 0000000..dbf7e5b --- /dev/null +++ b/src/code/quantifiers.lisp @@ -0,0 +1,99 @@ +;;;; 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") + +;;;; quantifiers + +;;; We borrow the logic from (MAP NIL ..) to handle iteration over +;;; arbitrary sequence arguments, both in the full call case and in +;;; the open code case. +(flet ((expand (pred sequences test found-result unfound-result) + (unless (proper-list-of-length-p sequences 1 call-arguments-limit) + (return-from expand (values nil t))) ; give up + (binding* ((elements (make-gensym-list (length sequences))) + ((bind-fun call-it) (funarg-bind/call-forms pred elements)) + (blockname (sb!xc:gensym "BLOCK")) + (wrapper (sb!xc:gensym "WRAPPER")) + (value (sb!xc:gensym "VAL"))) + (let ((form + `(block ,blockname + (dx-flet ((,wrapper (,@elements) + (declare (optimize + (sb!c::check-tag-existence 0))) + (let ((,value ,call-it)) + (,test ,value + (return-from ,blockname + ,(if (eq found-result :value) + value + found-result)))))) + (declare (inline ,wrapper)) + (map nil #',wrapper ,@sequences) + ,unfound-result)))) + (values (if bind-fun `(let ,bind-fun ,form) form) nil))))) + (macrolet ((defquantifier (name found-test found-result + &key doc (unfound-result (not found-result))) + (declare (ignorable doc)) + `(progn + ;; KLUDGE: It would be really nice if we could simply + ;; do something like this + ;; (declaim (inline ,name)) + ;; (defun ,name (pred first-seq &rest more-seqs) + ;; ,doc + ;; (flet ((map-me (&rest rest) + ;; (let ((pred-value (apply pred rest))) + ;; (,found-test pred-value + ;; (return-from ,name + ;; ,found-result))))) + ;; (declare (inline map-me)) + ;; (apply #'map nil #'map-me first-seq more-seqs) + ;; ,unfound-result)) + ;; but Python doesn't seem to be smart enough about + ;; inlining and APPLY to recognize that it can use + ;; the DEFTRANSFORM for MAP in the resulting inline + ;; expansion. I don't have any appetite for deep + ;; compiler hacking right now, so I'll just work + ;; around the apparent problem by using a compiler + ;; macro instead. -- WHN 20000410 + (sb!c:define-source-transform ,name (pred &rest sequences) + (expand pred sequences + ',found-test ',found-result ',unfound-result)) + #-sb-xc-host ; don't redefine CL builtins! + (defun ,name (pred first-seq &rest more-seqs) + #!+sb-doc ,doc + (flet ((map-me (&rest rest) + (let ((value (apply pred rest))) + (,found-test value + (return-from ,name + ,(if (eq found-result :value) + 'value + found-result)))))) + (declare (inline map-me)) + (apply #'map nil #'map-me first-seq more-seqs) + ,unfound-result))))) + + (defquantifier some when :value :unfound-result nil + :doc "Apply PREDICATE to the 0-indexed elements of the sequences, then + possibly to those with index 1, and so on. Return the first + non-NIL value encountered, or NIL if the end of any sequence is reached.") + (defquantifier every unless nil + :doc "Apply PREDICATE to the 0-indexed elements of the sequences, then + possibly to those with index 1, and so on. Return NIL as soon + as any invocation of PREDICATE returns NIL, or T if every invocation + is non-NIL.") + (defquantifier notany when nil + :doc "Apply PREDICATE to the 0-indexed elements of the sequences, then + possibly to those with index 1, and so on. Return NIL as soon + as any invocation of PREDICATE returns a non-NIL value, or T if the end + of any sequence is reached.") + (defquantifier notevery unless t + :doc "Apply PREDICATE to 0-indexed elements of the sequences, then + possibly to those with index 1, and so on. Return T as soon + as any invocation of PREDICATE returns NIL, or NIL if every invocation + is non-NIL."))) diff --git a/src/code/seq.lisp b/src/code/seq.lisp index 2cab206..0727ad9 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -1185,100 +1185,6 @@ many elements are copied." iter from-end))))))) result-sequence) -;;;; quantifiers - -;;; We borrow the logic from (MAP NIL ..) to handle iteration over -;;; arbitrary sequence arguments, both in the full call case and in -;;; the open code case. -(macrolet ((defquantifier (name found-test found-result - &key doc (unfound-result (not found-result))) - `(progn - ;; KLUDGE: It would be really nice if we could simply - ;; do something like this - ;; (declaim (inline ,name)) - ;; (defun ,name (pred first-seq &rest more-seqs) - ;; ,doc - ;; (flet ((map-me (&rest rest) - ;; (let ((pred-value (apply pred rest))) - ;; (,found-test pred-value - ;; (return-from ,name - ;; ,found-result))))) - ;; (declare (inline map-me)) - ;; (apply #'map nil #'map-me first-seq more-seqs) - ;; ,unfound-result)) - ;; but Python doesn't seem to be smart enough about - ;; inlining and APPLY to recognize that it can use - ;; the DEFTRANSFORM for MAP in the resulting inline - ;; expansion. I don't have any appetite for deep - ;; compiler hacking right now, so I'll just work - ;; around the apparent problem by using a compiler - ;; macro instead. -- WHN 20000410 - (defun ,name (pred first-seq &rest more-seqs) - #!+sb-doc ,doc - (flet ((map-me (&rest rest) - (let ((pred-value (apply pred rest))) - (,found-test pred-value - (return-from ,name - ,found-result))))) - (declare (inline map-me)) - (apply #'map nil #'map-me first-seq more-seqs) - ,unfound-result)) - ;; KLUDGE: It would be more obviously correct -- but - ;; also significantly messier -- for PRED-VALUE to be - ;; a gensym. However, a private symbol really does - ;; seem to be good enough; and anyway the really - ;; obviously correct solution is to make Python smart - ;; enough that we can use an inline function instead - ;; of a compiler macro (as above). -- WHN 20000410 - ;; - ;; FIXME: The DEFINE-COMPILER-MACRO here can be - ;; important for performance, and it'd be good to have - ;; it be visible throughout the compilation of all the - ;; target SBCL code. That could be done by defining - ;; SB-XC:DEFINE-COMPILER-MACRO and using it here, - ;; moving this DEFQUANTIFIER stuff (and perhaps other - ;; inline definitions in seq.lisp as well) into a new - ;; seq.lisp, and moving remaining target-only stuff - ;; from the old seq.lisp into target-seq.lisp. - (define-compiler-macro ,name (pred first-seq &rest more-seqs) - (binding* ((elements - (make-gensym-list (1+ (length more-seqs)))) - (blockname (sb!xc:gensym "BLOCK")) - (wrapper (sb!xc:gensym "WRAPPER")) - ((bind call) - (funarg-bind/call-forms pred elements))) - `(let ,bind - (block ,blockname - (flet ((,wrapper (,@elements) - (declare (optimize (sb!c::check-tag-existence 0))) - (let ((pred-value ,call)) - (,',found-test pred-value - (return-from ,blockname ,',found-result))))) - (declare (inline ,wrapper) - (dynamic-extent #',wrapper)) - (map nil #',wrapper ,first-seq - ,@more-seqs)) - ,',unfound-result))))))) - (defquantifier some when pred-value :unfound-result nil :doc - "Apply PREDICATE to the 0-indexed elements of the sequences, then - possibly to those with index 1, and so on. Return the first - non-NIL value encountered, or NIL if the end of any sequence is reached.") - (defquantifier every unless nil :doc - "Apply PREDICATE to the 0-indexed elements of the sequences, then - possibly to those with index 1, and so on. Return NIL as soon - as any invocation of PREDICATE returns NIL, or T if every invocation - is non-NIL.") - (defquantifier notany when nil :doc - "Apply PREDICATE to the 0-indexed elements of the sequences, then - possibly to those with index 1, and so on. Return NIL as soon - as any invocation of PREDICATE returns a non-NIL value, or T if the end - of any sequence is reached.") - (defquantifier notevery unless t :doc - "Apply PREDICATE to 0-indexed elements of the sequences, then - possibly to those with index 1, and so on. Return T as soon - as any invocation of PREDICATE returns NIL, or NIL if every invocation - is non-NIL.")) - ;;;; REDUCE (eval-when (:compile-toplevel :execute) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2015-07-06 23:27:03
|
The branch "master" has been updated in SBCL: via 44ca6f2f37cc9ffc8b6ec8ae15791e7157f81053 (commit) from 000386712d44d89c95e10649210363cf64e5b149 (commit) - Log ----------------------------------------------------------------- commit 44ca6f2f37cc9ffc8b6ec8ae15791e7157f81053 Author: Douglas Katzman <do...@go...> Date: Mon Jul 6 19:21:56 2015 -0400 Remove 5 repetitions of the same kludge re. FIND-CLASSOID. Make transform work in cold-init, rather than make excuses. --- src/code/class.lisp | 33 +++++++----------------------- src/code/condition.lisp | 30 ++------------------------- src/compiler/generic/genesis.lisp | 39 ++++++++++++++++++++++++++++++++---- src/compiler/main.lisp | 7 ++++++ 4 files changed, 52 insertions(+), 57 deletions(-) diff --git a/src/code/class.lisp b/src/code/class.lisp index da9f61a..49160fd 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -23,7 +23,13 @@ ;;; away as with the merger of SB-PCL:CLASS and CL:CLASS it's no ;;; longer necessary) (def!struct (classoid - (:make-load-form-fun classoid-make-load-form-fun) + (:make-load-form-fun + (lambda (self) + (let ((name (classoid-name self))) + (if (and name (eq (find-classoid name nil) self)) + `(find-classoid ',name) + (error "can't use anonymous or undefined class as constant:~% ~S" + self))))) (:include ctype (class-info (type-class-or-lose 'classoid))) (:constructor nil) @@ -63,21 +69,6 @@ ;; we don't just call it the CLASS slot) object for this class, or ;; NIL if none assigned yet (pcl-class nil)) - -(defun classoid-make-load-form-fun (class) - (/show "entering CLASSOID-MAKE-LOAD-FORM-FUN" class) - (let ((name (classoid-name class))) - (unless (and name (eq (find-classoid name nil) class)) - (/show "anonymous/undefined class case") - (error "can't use anonymous or undefined class as constant:~% ~S" - class)) - `(locally - ;; KLUDGE: There's a FIND-CLASSOID DEFTRANSFORM for constant - ;; class names which creates fast but non-cold-loadable, - ;; non-compact code. In this context, we'd rather have compact, - ;; cold-loadable code. -- WHN 19990928 - (declare (notinline find-classoid)) - (find-classoid ',name)))) ;;;; basic LAYOUT stuff @@ -1585,15 +1576,7 @@ between the ~A definition and the ~A definition" (!cold-init-forms #-sb-xc-host (/show0 "about to set *BUILT-IN-CLASS-CODES*") (setq **built-in-class-codes** - (let* ((initial-element - (locally - ;; KLUDGE: There's a FIND-CLASSOID DEFTRANSFORM for - ;; constant class names which creates fast but - ;; non-cold-loadable, non-compact code. In this - ;; context, we'd rather have compact, cold-loadable - ;; code. -- WHN 19990928 - (declare (notinline find-classoid)) - (classoid-layout (find-classoid 'random-class)))) + (let* ((initial-element (classoid-layout (find-classoid 'random-class))) (res (make-array 256 :initial-element initial-element))) (dolist (x *!built-in-classes* res) (destructuring-bind (name &key codes &allow-other-keys) diff --git a/src/code/condition.lisp b/src/code/condition.lisp index f89686b..c363a4c 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -86,30 +86,12 @@ ;;; figured out whether it's right. -- WHN 19990612 (eval-when (:compile-toplevel :load-toplevel :execute) (/show0 "condition.lisp 103") - (let ((condition-class (locally - ;; KLUDGE: There's a DEFTRANSFORM - ;; FIND-CLASSOID for constant class names - ;; which creates fast but - ;; non-cold-loadable, non-compact code. In - ;; this context, we'd rather have compact, - ;; cold-loadable code. -- WHN 19990928 - (declare (notinline find-classoid)) - (find-classoid 'condition)))) + (let ((condition-class (find-classoid 'condition))) (setf (condition-classoid-cpl condition-class) (list condition-class))) (/show0 "condition.lisp 103")) -(setf (condition-classoid-report (locally - ;; KLUDGE: There's a DEFTRANSFORM - ;; FIND-CLASSOID for constant class - ;; names which creates fast but - ;; non-cold-loadable, non-compact - ;; code. In this context, we'd - ;; rather have compact, - ;; cold-loadable code. -- WHN - ;; 19990928 - (declare (notinline find-classoid)) - (find-classoid 'condition))) +(setf (condition-classoid-report (find-classoid 'condition)) (lambda (cond stream) (format stream "Condition ~S was signalled." (type-of cond)))) @@ -333,13 +315,7 @@ ;; => (#<DEFSTRUCT-SLOT-DESCRIPTION ACTUAL-INITARGS> ;; #<DEFSTRUCT-SLOT-DESCRIPTION ASSIGNED-SLOTS>) (setf (layout-info layout) - (locally - ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for constant class - ;; names which creates fast but non-cold-loadable, non-compact - ;; code. In this context, we'd rather have compact, cold-loadable - ;; code. -- WHN 19990928 - (declare (notinline find-classoid)) - (layout-info (classoid-layout (find-classoid 'condition))))) + (layout-info (classoid-layout (find-classoid 'condition)))) (setf (find-classoid name) class) diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 55cd209..b9b930c 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -1107,6 +1107,19 @@ core and return a descriptor to it." (or (car (gethash name *cold-package-symbols*)) (error "Genesis could not find a target package named ~S" name)))) +(defvar *classoid-cells*) +(setf (get 'find-classoid-cell :sb-cold-funcall-handler/for-value) + (lambda (name &key create) + (aver (eq create t)) + (or (gethash name *classoid-cells*) + (let ((layout (gethash 'sb!kernel::classoid-cell *cold-layouts*))) + (setf (gethash name *classoid-cells*) + (write-slots (allocate-struct *dynamic* layout) + (find-layout 'sb!kernel::classoid-cell) + :name name + :pcl-class *nil-descriptor* + :classoid *nil-descriptor*)))))) + ;;; a map from descriptors to symbols, so that we can back up. The key ;;; is the address in the target core. (defvar *cold-symbols*) @@ -1535,7 +1548,9 @@ core and return a descriptor to it." cold-pkg-inits))) (cold-set 'sb!impl::*!initial-symbols* cold-pkg-inits)) - (attach-fdefinitions-to-symbols) + (dump-symbol-info-vectors + (attach-fdefinitions-to-symbols + (attach-classoid-cells-to-symbols (make-hash-table :test #'eq)))) (cold-set '*!reversed-cold-toplevels* *current-reversed-cold-toplevels*) (cold-set '*!initial-debug-sources* *current-debug-sources*) @@ -1697,10 +1712,20 @@ core and return a descriptor to it." (error "Offset from FDEFN ~S to ~S is ~W, not ~W." sym nil offset desired)))))) +(defun attach-classoid-cells-to-symbols (hashtable) + (let ((num (sb!c::meta-info-number (sb!c::meta-info :type :classoid-cell)))) + ;; Iteration order is immaterial. The symbols will get sorted later. + (maphash (lambda (symbol cold-classoid-cell) + (setf (gethash symbol hashtable) + (packed-info-insert + (gethash symbol hashtable +nil-packed-infos+) + sb!c::+no-auxilliary-key+ num cold-classoid-cell))) + *classoid-cells*)) + hashtable) + ;; Create pointer from SYMBOL and/or (SETF SYMBOL) to respective fdefinition ;; -(defun attach-fdefinitions-to-symbols () - (let ((hashtable (make-hash-table :test #'eq))) +(defun attach-fdefinitions-to-symbols (hashtable) ;; Collect fdefinitions that go with one symbol, e.g. CAR and (SETF CAR), ;; using the host's code for manipulating a packed info-vector. (maphash (lambda (warm-name cold-fdefn) @@ -1712,6 +1737,9 @@ core and return a descriptor to it." (gethash key1 hashtable +nil-packed-infos+) key2 +fdefn-info-num+ cold-fdefn)))) *cold-fdefn-objects*) + hashtable) + +(defun dump-symbol-info-vectors (hashtable) ;; Emit in the same order symbols reside in core to avoid ;; sensitivity to the iteration order of host's maphash. (loop for (warm-sym . info) @@ -1720,14 +1748,14 @@ core and return a descriptor to it." do (write-wordindexed (cold-intern warm-sym) sb!vm:symbol-info-slot ;; Each vector will have one fixnum, possibly the symbol SETF, - ;; and one or two #<fdefn> objects in it. + ;; and one or two #<fdefn> objects in it, and/or a classoid-cell. (vector-in-core (map 'list (lambda (elt) (etypecase elt (symbol (cold-intern elt)) (fixnum (make-fixnum-descriptor elt)) (descriptor elt))) - info)))))) + info))))) ;;;; fixups and related stuff @@ -3580,6 +3608,7 @@ initially undefined function references:~2%") (cons nil nil))))) ; (externals . internals) (*nil-descriptor* (make-nil-descriptor target-cl-pkg-info)) (*known-structure-classoids* nil) + (*classoid-cells* (make-hash-table :test 'eq)) (*current-reversed-cold-toplevels* *nil-descriptor*) (*current-debug-sources* *nil-descriptor*) (*unbound-marker* (make-other-immediate-descriptor diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 45a8356..3997971 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -1496,6 +1496,8 @@ necessary, since type inference may take arbitrarily long to converge.") ;;; Compile FORM and arrange for it to be called at load-time. Return ;;; the dumper handle and our best guess at the type of the object. +;;; It would be nice if L-T-V forms were generally eligible +;;; for fopcompilation, as it could eliminate special cases below. (defun compile-load-time-value (form) (let ((ctype (cond @@ -1505,6 +1507,11 @@ necessary, since type inference may take arbitrarily long to converge.") ;; compiled lambdas don't cause a chicken-and-egg problem. ((typep form '(cons (eql find-package) (cons string null))) (specifier-type 'package)) + #+sb-xc-host + ((typep form '(cons (eql find-classoid-cell) + (cons (cons (eql quote))))) + (aver (eq (getf (cddr form) :create) t)) + (specifier-type 'sb!kernel::classoid-cell)) ;; Special case for the cross-compiler, necessary for at least ;; SETUP-PRINTER-STATE, but also anything that would be dumped ;; using FOP-KNOWN-FUN in the target compiler, to avoid going ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2015-07-06 23:27:01
|
The branch "master" has been updated in SBCL: via 000386712d44d89c95e10649210363cf64e5b149 (commit) from a9d874dfcbf4ae5b2a029d15e44032fde223f018 (commit) - Log ----------------------------------------------------------------- commit 000386712d44d89c95e10649210363cf64e5b149 Author: Douglas Katzman <do...@go...> Date: Mon Jul 6 09:35:47 2015 -0400 Assign LAYOUT-PURE slot in %TARGET-DEFSTRUCT. --- src/code/defstruct.lisp | 6 ------ src/code/target-defstruct.lisp | 3 ++- 2 files changed, 2 insertions(+), 7 deletions(-) diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 61b6029..8d351b2 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -311,12 +311,6 @@ ,@(accessor-definitions dd))) ;; This must be in the same lexical environment ,@(constructor-definitions dd) - ,@(when (eq (dd-pure dd) t) - ;; Seems like %TARGET-DEFSTRUCT should do this - `((locally - (declare (notinline find-classoid)) - (setf (layout-pure (classoid-layout - (find-classoid ',name))) t)))) ,@print-method ;; Various other operations only make sense on the target SBCL. (%target-defstruct ',dd)))) diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp index 494fa24..43b5052 100644 --- a/src/code/target-defstruct.lisp +++ b/src/code/target-defstruct.lisp @@ -140,7 +140,8 @@ (let* ((classoid (find-classoid (dd-name dd))) (layout (classoid-layout classoid))) - (declare (ignorable layout)) + (when (eq (dd-pure dd) t) + (setf (layout-pure layout) t)) #!+interleaved-raw-slots ;; Make a vector of EQUALP slots comparators, indexed by (- word-index data-start). ;; This has to be assigned to something regardless of whether there are ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: stassats <sta...@us...> - 2015-07-06 15:04:53
|
The branch "master" has been updated in SBCL: via a9d874dfcbf4ae5b2a029d15e44032fde223f018 (commit) from d974716f791c36dcaedd743ab48a5f0361fc0067 (commit) - Log ----------------------------------------------------------------- commit a9d874dfcbf4ae5b2a029d15e44032fde223f018 Author: Stas Boukarev <sta...@gm...> Date: Mon Jul 6 18:04:30 2015 +0300 Remove private keywords from sb-thread:make-mutex. --- src/code/thread.lisp | 3 ++- 1 files changed, 2 insertions(+), 1 deletions(-) diff --git a/src/code/thread.lisp b/src/code/thread.lisp index ddc2f5e..5436160 100644 --- a/src/code/thread.lisp +++ b/src/code/thread.lisp @@ -52,7 +52,8 @@ temporarily.") (signal-number nil :type integer)) (declaim (inline make-mutex)) ;; for possible DX-allocating -(def!struct mutex +(def!struct (mutex + (:constructor make-mutex (&key name))) #!+sb-doc "Mutex type." (name nil :type (or null thread-name)) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2015-07-06 01:23:16
|
The branch "master" has been updated in SBCL: via d974716f791c36dcaedd743ab48a5f0361fc0067 (commit) from 9b9b66f7a89f1dfbbc89316d99d6e21c0f2ad477 (commit) - Log ----------------------------------------------------------------- commit d974716f791c36dcaedd743ab48a5f0361fc0067 Author: Douglas Katzman <do...@go...> Date: Sun Jul 5 20:55:24 2015 -0400 Annotate some defects in PARSE-LAMBDA-LIST Also a minor noise reduction in self-build. --- src/compiler/parse-lambda-list.lisp | 99 +++++++++++++++++++++-------------- src/compiler/policy.lisp | 12 ---- 2 files changed, 59 insertions(+), 52 deletions(-) diff --git a/src/compiler/parse-lambda-list.lisp b/src/compiler/parse-lambda-list.lisp index fededa8..4b0ffef 100644 --- a/src/compiler/parse-lambda-list.lisp +++ b/src/compiler/parse-lambda-list.lisp @@ -122,16 +122,27 @@ (if (destructuring-p) (croak "~A is not a symbol or list: ~S" why x) (croak "~A is not a symbol: ~S" why x)))) + (defaultp (x what-kind) + (cond ((symbolp x) nil) + ((listp x) t) + (t (croak "~A parameter is not a symbol or cons: ~S" + what-kind x)))) (croak (string &optional (a1 0 a1p) (a2 0 a2p) (a3 0 a3p)) ;; Don't care that FUNCALL can't elide fdefinition here. (declare (optimize (speed 1))) (let ((l (if a1p (list a1 a2 a3)))) (if (and l (not a3p)) (rplacd (if a2p (cdr l) l) nil)) ;; KLUDGE: When this function was limited to parsing - ;; ordinary lambda lists, this error call was COMPILER-ERROR. - ;; To make all tests pass, it has to decide what to be. - ;; It's possible the tests are poorly designed and are - ;; acting as "change detectors" + ;; ordinary lambda lists, this error call was always + ;; COMPILER-ERROR, which must be used, not plain old ERROR, + ;; to avoid the compiler itself crashing. But outside of + ;; the compiler, it must be ERROR. This discrepancy is sad + ;; since DESTRUCTURING-BIND herein can cause a compiler crash. + ;; It seems that the right thing is for the compiler to wrap + ;; a condition handler around PARSE-LAMBDA-LIST. + ;; Expecting a callee to understand how to signal conditions + ;; tailored to a particular caller is not how things are + ;; supposed to work. (funcall (if (destructuring-p) 'error 'compiler-error) condition-class :format-control string :format-arguments l)))) @@ -266,46 +277,42 @@ (dolist (arg required) (need-bindable arg "Required argument")) ;; FIXME: why not check symbol-ness of supplied-p variables now? - (flet ((defaultp (x what-kind) - (cond ((symbolp x) nil) - ((listp x) t) - (t (croak "~A parameter is not a symbol or cons: ~S" - what-kind x)))) - ;; Inform the user about a possibly malformed destructuring - ;; lambda list (&OPTIONAL (A &OPTIONAL B)). - ;; It's technically legal but unlikely to be right, as it makes - ;; A's default form the expression &OPTIONAL, which is an - ;; unlikely name for a local variable or macro, and an illegal - ;; name for a DEFVAR or such, being in the CL package. - (check-suspicious (default suppliedp-var) - (unless silent - (when (and (probably-ll-keyword-p default) - (member default sb!xc:lambda-list-keywords)) - (style-warn "suspicious default ~S in lambda list: ~S." - default list)) - (when (and (probably-ll-keyword-p suppliedp-var) - (member suppliedp-var sb!xc:lambda-list-keywords)) - (style-warn - "suspicious supplied-p variable ~S in lambda list: ~S." - suppliedp-var list))))) - (dolist (arg optional) - (when (defaultp arg '&optional) - (destructuring-bind (var &optional init-form supplied-p) arg - (need-bindable var "&OPTIONAL parameter name") - (check-suspicious init-form supplied-p)))) + (flet ((scan-opt/key (list what-kind description) + (dolist (arg list) + (when (defaultp arg what-kind) + ;; FIXME: (DEFUN F (&OPTIONAL (A B C D)) 42) crashes the + ;; compiler, but not as consequence of the new parser. + ;; (This is not a regression) + (destructuring-bind (var &optional default sup-p) arg + (if (and (consp var) (eq what-kind '&key)) + (destructuring-bind (keyword-name var) var + (declare (ignore keyword-name)) + (need-bindable var description)) + (need-bindable var description)) + ;; Inform the user about a possibly malformed + ;; destructuring list (&OPTIONAL (A &OPTIONAL B)). + ;; It's technically legal but unlikely to be right, + ;; as A's default form is the symbol &OPTIONAL, + ;; which is an unlikely name for a local variable, + ;; and an illegal name for a DEFVAR or such, + ;; being in the CL package. + (unless silent + (when (and (probably-ll-keyword-p default) + (member default sb!xc:lambda-list-keywords)) + (style-warn "suspicious default ~S in lambda list: ~S." + default list)) + (when (and (probably-ll-keyword-p sup-p) + (member sup-p sb!xc:lambda-list-keywords)) + (style-warn + "suspicious supplied-p variable ~S in lambda list: ~S." + sup-p list)))))))) + (scan-opt/key optional '&optional "&OPTIONAL parameter name") (when rest (need-bindable (car rest) "&REST argument")) - (dolist (arg keys) - (when (defaultp arg '&key) - (destructuring-bind (var-or-kv &optional init-form supplied-p) arg - (if (atom var-or-kv) - (need-symbol var-or-kv "&KEY parameter name") - (destructuring-bind (keyword-name var) var-or-kv - (declare (ignore keyword-name)) - (need-bindable var "&KEY parameter name"))) - (check-suspicious init-form supplied-p)))) + (scan-opt/key keys '&key "&KEY parameter name") (dolist (arg aux) (when (defaultp arg '&aux) + ;; FIXME: also potentially compiler-crash-inducing (destructuring-bind (var &optional init-form) arg (declare (ignore init-form)) ;; &AUX is not destructured @@ -1013,6 +1020,18 @@ ''*)) ,@body)) +(defvar *macro-policy* nil) +;; Turn the macro policy into an OPTIMIZE declaration for insertion +;; into a macro body for DEFMACRO, MACROLET, or DEFINE-COMPILER-MACRO. +;; Note that despite it being a style-warning to insert a duplicate, +;; we need no precaution against that even though users may write +;; (DEFMACRO FOO (X) (DECLARE (OPTIMIZE (SAFETY 1))) ...) +;; The expansion of macro-defining forms is such that the macro-policy +;; appears in a different lexical scope from the user's declarations. +(defun macro-policy-decls () + (and *macro-policy* + `((declare (optimize ,@(policy-to-decl-spec *macro-policy*)))))) + ;;; Make a lambda expression that receives an s-expression, destructures it ;;; according to LAMBDA-LIST, and executes BODY. ;;; NAME and KIND provide error-reporting context. diff --git a/src/compiler/policy.lisp b/src/compiler/policy.lisp index 3b28729..8f923cd 100644 --- a/src/compiler/policy.lisp +++ b/src/compiler/policy.lisp @@ -15,7 +15,6 @@ (def!type policy-quality () '(integer 0 3)) (defvar *policy*) -(defvar *macro-policy* nil) ;;; global policy restrictions as a POLICY object or nil (!defvar *policy-restrictions* nil) @@ -366,14 +365,3 @@ EXPERIMENTAL INTERFACE: Subject to change." ;; But most probably the current behavior is entirely reasonable. (setq *macro-policy* (process-optimize-decl `(optimize ,@list) **baseline-policy**))) - -;; Turn the macro policy into an OPTIMIZE declaration for insertion -;; into a macro body for DEFMACRO, MACROLET, or DEFINE-COMPILER-MACRO. -;; Note that despite it being a style-warning to insert a duplicate, -;; we need no precaution against that even though users may write -;; (DEFMACRO FOO (X) (DECLARE (OPTIMIZE (SAFETY 1))) ...) -;; The expansion of macro-defining forms is such that the macro-policy -;; appears in a different lexical scope from the user's declarations. -(defun macro-policy-decls () - (and *macro-policy* - `((declare (optimize ,@(policy-to-decl-spec *macro-policy*)))))) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: stassats <sta...@us...> - 2015-07-05 18:29:25
|
The branch "master" has been updated in SBCL: via 9b9b66f7a89f1dfbbc89316d99d6e21c0f2ad477 (commit) from a153a2506e3c12bc12cf622aca711678ae760371 (commit) - Log ----------------------------------------------------------------- commit 9b9b66f7a89f1dfbbc89316d99d6e21c0f2ad477 Author: Stas Boukarev <sta...@gm...> Date: Sun Jul 5 20:49:08 2015 +0300 Reduce debug-info size on x86oids and ARM. They have constant return-pc-save-offset and old-fp-passing-offset across all functions. Make constants for those and don't save them in compiled-debug-fun. --- make-config.sh | 4 +++- package-data-list.lisp-expr | 2 ++ src/code/debug-info.lisp | 2 ++ src/code/debug-int.lisp | 30 ++++++++++++++++++++++-------- src/compiler/arm/call.lisp | 13 ++++++++----- src/compiler/debug-dump.lisp | 6 ++++-- src/compiler/x86-64/call.lisp | 6 ++++++ src/compiler/x86/call.lisp | 6 ++++++ 8 files changed, 53 insertions(+), 16 deletions(-) diff --git a/make-config.sh b/make-config.sh index 2f4cecf..38cd789 100755 --- a/make-config.sh +++ b/make-config.sh @@ -642,6 +642,7 @@ if [ "$sbcl_arch" = "x86" ]; then printf ' :stack-allocatable-lists :stack-allocatable-fixed-objects' >> $ltf printf ' :alien-callbacks :cycle-counter :inline-constants :precise-arg-count-error' >> $ltf printf ' :memory-barrier-vops :multiply-high-vops :ash-right-vops :symbol-info-vops' >> $ltf + printf ' :fp-and-pc-standard-save' >> $ltf case "$sbcl_os" in linux | freebsd | gnu-kfreebsd | netbsd | openbsd | sunos | darwin | win32 | dragonfly) printf ' :linkage-table' >> $ltf @@ -658,7 +659,7 @@ if [ "$sbcl_arch" = "x86" ]; then elif [ "$sbcl_arch" = "x86-64" ]; then printf ' :gencgc :stack-grows-downward-not-upward :c-stack-is-control-stack :linkage-table' >> $ltf printf ' :compare-and-swap-vops :unwind-to-frame-and-call-vop :raw-instance-init-vops' >> $ltf - printf ' :interleaved-raw-slots :precise-arg-count-error' >> $ltf + printf ' :interleaved-raw-slots :precise-arg-count-error :fp-and-pc-standard-save' >> $ltf printf ' :stack-allocatable-closures :stack-allocatable-vectors' >> $ltf printf ' :stack-allocatable-lists :stack-allocatable-fixed-objects' >> $ltf printf ' :alien-callbacks :cycle-counter :complex-float-vops' >> $ltf @@ -731,6 +732,7 @@ elif [ "$sbcl_arch" = "arm" ]; then printf ' :stack-allocatable-lists :stack-allocatable-fixed-objects' >> $ltf printf ' :stack-allocatable-vectors :stack-allocatable-closures' >> $ltf printf ' :precise-arg-count-error :unwind-to-frame-and-call-vop' >> $ltf + printf ' :fp-and-pc-standard-save' >> $ltf else # Nothing need be done in this case, but sh syntax wants a placeholder. echo > /dev/null diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index a8ac8d7..9331117 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -382,6 +382,8 @@ of SBCL which maintained the CMU-CL-style split into two packages.)" "MAKE-RETURN-PC-PASSING-LOCATION" "MAKE-OLD-FP-PASSING-LOCATION" "MAKE-OLD-FP-SAVE-LOCATION" + "RETURN-PC-PASSING-OFFSET" + "OLD-FP-PASSING-OFFSET" "MAKE-RETURN-PC-SAVE-LOCATION" "MAKE-ARG-COUNT-LOCATION" "MAKE-NFP-TN" diff --git a/src/code/debug-info.lisp b/src/code/debug-info.lisp index d61a33a..89e6c38 100644 --- a/src/code/debug-info.lisp +++ b/src/code/debug-info.lisp @@ -163,7 +163,9 @@ ;; in order to save space, we elected not to store a vector. (returns :fixed :type (or (simple-array * (*)) (member :standard :fixed))) ;; SC-OFFSETs describing where the return PC and return FP are kept. + #!-fp-and-pc-standard-save (return-pc (missing-arg) :type sc-offset) + #!-fp-and-pc-standard-save (old-fp (missing-arg) :type sc-offset) ;; SC-OFFSET for the number stack FP in this function, or NIL if no ;; NFP allocated. diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 5406aac..ac5af1c 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -647,16 +647,23 @@ (setf (frame-%down frame) (etypecase debug-fun (compiled-debug-fun - (let ((c-d-f (compiled-debug-fun-compiler-debug-fun + (let (#!-fp-and-pc-standard-save + (c-d-f (compiled-debug-fun-compiler-debug-fun debug-fun))) (compute-calling-frame (descriptor-sap (get-context-value frame ocfp-save-offset - (sb!c::compiled-debug-fun-old-fp c-d-f))) + #!-fp-and-pc-standard-save + (sb!c::compiled-debug-fun-old-fp c-d-f) + #!+fp-and-pc-standard-save + sb!c:old-fp-passing-offset)) (get-context-value frame lra-save-offset - (sb!c::compiled-debug-fun-return-pc c-d-f)) + #!-fp-and-pc-standard-save + (sb!c::compiled-debug-fun-return-pc c-d-f) + #!+fp-and-pc-standard-save + sb!c:return-pc-passing-offset) frame))) (bogus-debug-fun (let ((fp (frame-pointer frame))) @@ -2855,8 +2862,11 @@ register." (declare (ignore breakpoint) (type frame frame)) (let ((lra-sc-offset - (sb!c::compiled-debug-fun-return-pc - (compiled-debug-fun-compiler-debug-fun debug-fun)))) + #!-fp-and-pc-standard-save + (sb!c::compiled-debug-fun-return-pc + (compiled-debug-fun-compiler-debug-fun debug-fun)) + #!+fp-and-pc-standard-save + sb!c:return-pc-passing-offset)) (multiple-value-bind (lra component offset) (make-bogus-lra (get-context-value frame @@ -2889,9 +2899,13 @@ register." ;;; series of cookies is valid. (defun fun-end-cookie-valid-p (frame cookie) (let ((lra (fun-end-cookie-bogus-lra cookie)) - (lra-sc-offset (sb!c::compiled-debug-fun-return-pc - (compiled-debug-fun-compiler-debug-fun - (fun-end-cookie-debug-fun cookie))))) + (lra-sc-offset + #!-fp-and-pc-standard-save + (sb!c::compiled-debug-fun-return-pc + (compiled-debug-fun-compiler-debug-fun + (fun-end-cookie-debug-fun cookie))) + #!+fp-and-pc-standard-save + sb!c:return-pc-passing-offset)) (do ((frame frame (frame-down frame))) ((not frame) nil) (when (and (compiled-frame-p frame) diff --git a/src/compiler/arm/call.lisp b/src/compiler/arm/call.lisp index 5fc3cf2..fd5bb20 100644 --- a/src/compiler/arm/call.lisp +++ b/src/compiler/arm/call.lisp @@ -32,16 +32,16 @@ (defconstant arg-count-sc (make-sc-offset immediate-arg-scn nargs-offset)) (defconstant closure-sc (make-sc-offset descriptor-reg-sc-number lexenv-offset)) -;;; Make a passing location TN for a local call return PC. If -;;; standard is true, then use the standard (full call) location, -;;; otherwise use any legal location. Even in the non-standard case, -;;; this may be restricted by a desire to use a subroutine call -;;; instruction. +;;; Always wire the return PC location to the stack in its standard +;;; location. (defun make-return-pc-passing-location (standard) (declare (ignore standard)) (make-wired-tn *backend-t-primitive-type* control-stack-sc-number lra-save-offset)) +(defconstant return-pc-passing-offset + (make-sc-offset control-stack-sc-number lra-save-offset)) + ;;; This is similar to MAKE-RETURN-PC-PASSING-LOCATION, but makes a ;;; location to pass OLD-FP in. ;;; @@ -54,6 +54,9 @@ (make-wired-tn *fixnum-primitive-type* control-stack-sc-number ocfp-save-offset)) +(defconstant old-fp-passing-offset + (make-sc-offset control-stack-sc-number ocfp-save-offset)) + ;;; Make the TNs used to hold OLD-FP and RETURN-PC within the current ;;; function. We treat these specially so that the debugger can find ;;; them at a known location. diff --git a/src/compiler/debug-dump.lisp b/src/compiler/debug-dump.lisp index 423c6f3..5b29a54 100644 --- a/src/compiler/debug-dump.lisp +++ b/src/compiler/debug-dump.lisp @@ -505,8 +505,10 @@ (make-compiled-debug-fun :name (leaf-debug-name fun) :kind (if main-p nil (functional-kind fun)) - :return-pc (tn-sc-offset (ir2-physenv-return-pc 2env)) - :old-fp (tn-sc-offset (ir2-physenv-old-fp 2env)) + #!-fp-and-pc-standard-save :return-pc + #!-fp-and-pc-standard-save (tn-sc-offset (ir2-physenv-return-pc 2env)) + #!-fp-and-pc-standard-save :old-fp + #!-fp-and-pc-standard-save (tn-sc-offset (ir2-physenv-old-fp 2env)) :start-pc (label-position (ir2-physenv-environment-start 2env)) :elsewhere-pc (label-position (ir2-physenv-elsewhere-start 2env)) :closure-save (when (ir2-physenv-closure-save-tn 2env) diff --git a/src/compiler/x86-64/call.lisp b/src/compiler/x86-64/call.lisp index dff818f..a7d22f0 100644 --- a/src/compiler/x86-64/call.lisp +++ b/src/compiler/x86-64/call.lisp @@ -41,6 +41,9 @@ (make-wired-tn (primitive-type-or-lose 'system-area-pointer) sap-stack-sc-number return-pc-save-offset)) +(defconstant return-pc-passing-offset + (make-sc-offset sap-stack-sc-number return-pc-save-offset)) + ;;; This is similar to MAKE-RETURN-PC-PASSING-LOCATION, but makes a ;;; location to pass OLD-FP in. ;;; @@ -53,6 +56,9 @@ (make-wired-tn *fixnum-primitive-type* control-stack-sc-number ocfp-save-offset)) +(defconstant old-fp-passing-offset + (make-sc-offset control-stack-sc-number ocfp-save-offset)) + ;;; Make the TNs used to hold OLD-FP and RETURN-PC within the current ;;; function. We treat these specially so that the debugger can find ;;; them at a known location. diff --git a/src/compiler/x86/call.lisp b/src/compiler/x86/call.lisp index 730721b..d8122aa 100644 --- a/src/compiler/x86/call.lisp +++ b/src/compiler/x86/call.lisp @@ -41,6 +41,9 @@ (make-wired-tn (primitive-type-or-lose 'system-area-pointer) sap-stack-sc-number return-pc-save-offset)) +(defconstant return-pc-passing-offset + (make-sc-offset sap-stack-sc-number return-pc-save-offset)) + ;;; This is similar to MAKE-RETURN-PC-PASSING-LOCATION, but makes a ;;; location to pass OLD-FP in. ;;; @@ -53,6 +56,9 @@ (make-wired-tn *fixnum-primitive-type* control-stack-sc-number ocfp-save-offset)) +(defconstant old-fp-passing-offset + (make-sc-offset control-stack-sc-number ocfp-save-offset)) + ;;; Make the TNs used to hold OLD-FP and RETURN-PC within the current ;;; function. We treat these specially so that the debugger can find ;;; them at a known location. ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: stassats <sta...@us...> - 2015-07-05 18:29:23
|
The branch "master" has been updated in SBCL: via a153a2506e3c12bc12cf622aca711678ae760371 (commit) from 91750a7d084b33cf35b7a77663da0c6db7642e84 (commit) - Log ----------------------------------------------------------------- commit a153a2506e3c12bc12cf622aca711678ae760371 Author: Stas Boukarev <sta...@gm...> Date: Sun Jul 5 20:00:38 2015 +0300 Optimize FASL size. Replace the frequently used dump-pop/dump-push combination to get an argument from the stack to the table with a special dump-to-table which moves the object from the stack to the table without affecting the stack. --- src/code/fop.lisp | 3 +++ src/compiler/dump.lisp | 26 ++++++++++++++------------ 2 files changed, 17 insertions(+), 12 deletions(-) diff --git a/src/code/fop.lisp b/src/code/fop.lisp index a354372..4d0610d 100644 --- a/src/code/fop.lisp +++ b/src/code/fop.lisp @@ -142,6 +142,9 @@ (!define-fop 3 (fop-truth) t) (!define-fop 4 (fop-push ((:operands index))) (ref-fop-table (fasl-input) index)) +(!define-fop 9 (fop-move-to-table (x)) + (push-fop-table x (fasl-input)) + x) ;;; CMU CL had FOP-POP-FOR-EFFECT as fop 65, but it was never used and seemed ;;; to have no possible use. diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp index 2a566e9..224e4a6 100644 --- a/src/compiler/dump.lisp +++ b/src/compiler/dump.lisp @@ -207,6 +207,12 @@ (dump-fop 'fop-pop fasl-output) (incf (fasl-output-table-free fasl-output)))) +(defun dump-to-table (fasl-output) + (prog1 + (fasl-output-table-free fasl-output) + (dump-fop 'fop-move-to-table fasl-output) + (incf (fasl-output-table-free fasl-output)))) + ;;; If X is in File's EQUAL-TABLE, then push the object and return T, ;;; otherwise NIL. (defun equal-check-table (x fasl-output) @@ -231,27 +237,24 @@ ;;; be on the top of the FOP stack. (defun eq-save-object (x fasl-output) (declare (type fasl-output fasl-output)) - (let ((handle (dump-pop fasl-output))) - (setf (gethash x (fasl-output-eq-table fasl-output)) handle) - (dump-push handle fasl-output)) + (setf (gethash x (fasl-output-eq-table fasl-output)) + (dump-to-table fasl-output)) (values)) (defun equal-save-object (x fasl-output) (declare (type fasl-output fasl-output)) - (let ((handle (dump-pop fasl-output))) + (let ((handle (dump-to-table fasl-output))) (setf (gethash x (fasl-output-equal-table fasl-output)) handle) - (setf (gethash x (fasl-output-eq-table fasl-output)) handle) - (dump-push handle fasl-output)) + (setf (gethash x (fasl-output-eq-table fasl-output)) handle)) (values)) (defun string-save-object (x fasl-output) (declare (type fasl-output fasl-output) (type string x)) - (let ((handle (dump-pop fasl-output))) + (let ((handle (dump-to-table fasl-output))) (push (cons #+sb-xc-host 'base-char ; repeatable xc fasls #-sb-xc-host (array-element-type x) handle) (gethash x (fasl-output-equal-table fasl-output))) - (setf (gethash x (fasl-output-eq-table fasl-output)) handle) - (dump-push handle fasl-output)) + (setf (gethash x (fasl-output-eq-table fasl-output)) handle)) (values)) ;;; Record X in File's CIRCULARITY-TABLE. This is called on objects ;;; that we are about to dump might have a circular path through them. @@ -1119,9 +1122,8 @@ (let ((info (sb!c::debug-info-for-component component)) (*dump-only-valid-structures* nil)) (dump-object info fasl-output) - (let ((info-handle (dump-pop fasl-output))) - (dump-push info-handle fasl-output) - (push info-handle (fasl-output-debug-info fasl-output)))) + (push (dump-to-table fasl-output) + (fasl-output-debug-info fasl-output))) (let ((num-consts (- header-length sb!vm:code-constants-offset))) (dump-fop 'fop-code fasl-output num-consts code-length)) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: stassats <sta...@us...> - 2015-07-05 18:29:21
|
The branch "master" has been updated in SBCL: via 91750a7d084b33cf35b7a77663da0c6db7642e84 (commit) from afd554b58bde8973aa8a9621c72687362cd6bd3d (commit) - Log ----------------------------------------------------------------- commit 91750a7d084b33cf35b7a77663da0c6db7642e84 Author: Stas Boukarev <sta...@gm...> Date: Sun Jul 5 19:57:04 2015 +0300 Reduce FASL size for some top-level functions. By having infrequently used parameters as optional, they can be omitted saving space in FASLs on passing NIL. --- src/code/condition.lisp | 9 +++++---- src/code/defboot.lisp | 30 ++++++++++++++++++------------ src/code/defpackage.lisp | 14 +++++++------- src/code/setf.lisp | 12 +++++++----- src/compiler/compiler-deftype.lisp | 2 +- src/compiler/defconstant.lisp | 11 ++++++----- src/compiler/deftype.lisp | 10 +++------- src/compiler/generic/genesis.lisp | 2 +- src/pcl/defclass.lisp | 5 +++-- src/pcl/std-class.lisp | 2 +- tests/load.impure.lisp | 1 - 11 files changed, 52 insertions(+), 46 deletions(-) diff --git a/src/code/condition.lisp b/src/code/condition.lisp index 1eb0f71..f89686b 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -407,9 +407,9 @@ (setf (condition-classoid-report (find-classoid name)) report)) -(defun %define-condition (name parent-types layout slots documentation +(defun %define-condition (name parent-types layout slots direct-default-initargs all-readers all-writers - source-location) + source-location &optional documentation) (with-single-package-locked-error (:symbol name "defining ~A as a condition") (%compiler-define-condition name parent-types layout all-readers all-writers) @@ -576,11 +576,12 @@ ',parent-types ',layout (list ,@(slots)) - ,documentation (list ,@direct-default-initargs) ',(all-readers) ',(all-writers) - (sb!c:source-location)) + (sb!c:source-location) + ,@(and documentation + `(,documentation))) ;; This needs to be after %DEFINE-CONDITION in case :REPORT ;; is a lambda referring to condition slot accessors: ;; they're not proclaimed as functions before it has run if diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index 7b28eff..6d90595 100644 --- a/src/code/defboot.lisp +++ b/src/code/defboot.lisp @@ -207,11 +207,12 @@ evaluated as a PROGN." ,@(when (typep name '(cons (eql setf))) `((eval-when (:compile-toplevel :execute) (sb!c::warn-if-setf-macro ',name)))) - (%defun ',name ,named-lambda ',inline-lambda - (sb!c:source-location)))))) + (%defun ',name ,named-lambda (sb!c:source-location) + ,@(and inline-lambda + `(',inline-lambda))))))) #-sb-xc-host -(progn (defun %defun (name def inline-lambda source-location) +(progn (defun %defun (name def source-location &optional inline-lambda) (declare (type function def)) ;; should've been checked by DEFMACRO DEFUN (aver (legal-fun-name-p name)) @@ -245,9 +246,12 @@ evaluated as a PROGN." `(progn (eval-when (:compile-toplevel) (%compiler-defvar ',var)) - (%defvar ',var (unless (boundp ',var) ,val) - ',valp ,doc ',docp - (sb!c:source-location)))) + (%defvar ',var + (sb!c:source-location) + ,@(and valp + `((unless (boundp ',var) ,val))) + ,@(and docp + `(,doc))))) (defmacro-mundanely defparameter (var val &optional (doc nil docp)) #!+sb-doc @@ -259,17 +263,19 @@ evaluated as a PROGN." `(progn (eval-when (:compile-toplevel) (%compiler-defvar ',var)) - (%defparameter ',var ,val ,doc ',docp (sb!c:source-location)))) + (%defparameter ',var ,val (sb!c:source-location) + ,@(and docp + `(,doc))))) (defun %compiler-defvar (var) (sb!xc:proclaim `(special ,var))) #-sb-xc-host -(defun %defvar (var val valp doc docp source-location) +(defun %defvar (var source-location &optional (val nil valp) (doc nil docp)) (%compiler-defvar var) - (when valp - (unless (boundp var) - (set var val))) + (when (and valp + (not (boundp var))) + (set var val)) (when docp (setf (fdocumentation var 'variable) doc)) (sb!c:with-source-location (source-location) @@ -277,7 +283,7 @@ evaluated as a PROGN." var) #-sb-xc-host -(defun %defparameter (var val doc docp source-location) +(defun %defparameter (var val source-location &optional (doc nil docp)) (%compiler-defvar var) (set var val) (when docp diff --git a/src/code/defpackage.lisp b/src/code/defpackage.lisp index 51af91e..b44aaa8 100644 --- a/src/code/defpackage.lisp +++ b/src/code/defpackage.lisp @@ -153,8 +153,9 @@ (%defpackage ,(stringify-string-designator package) ',nicknames ',size ',shadows ',shadowing-imports ',(if use-p use :default) ',imports ',interns ',exports ',implement ',local-nicknames - ',lock ',doc - (sb!c:source-location))))) + ',lock (sb!c:source-location) + ,@(and doc + `(,doc)))))) (defun check-disjoint (&rest args) ;; An arg is (:key . set) @@ -383,13 +384,12 @@ specifies to signal a warning if SWANK package is in variance, and an error othe (defun %defpackage (name nicknames size shadows shadowing-imports use imports interns exports implement local-nicknames - lock doc-string - source-location) + lock source-location &optional doc) (declare (type simple-string name) (type list nicknames shadows shadowing-imports imports interns exports) (type (or list (member :default)) use) - (type (or simple-string null) doc-string)) + (type (or simple-string null) doc)) (with-package-graph () (let* ((existing-package (find-package name)) (use (use-list-packages existing-package use)) @@ -401,7 +401,7 @@ specifies to signal a warning if SWANK package is in variance, and an error othe shadows shadowing-imports use imports interns exports implement local-nicknames - lock doc-string) + lock doc) (let ((package (make-package name :use nil :internal-symbols (or size 10) @@ -412,7 +412,7 @@ specifies to signal a warning if SWANK package is in variance, and an error othe shadows shadowing-imports use imports interns exports implement local-nicknames - lock doc-string)))))) + lock doc)))))) (defun find-or-make-symbol (name package) (multiple-value-bind (symbol how) (find-symbol name package) diff --git a/src/code/setf.lisp b/src/code/setf.lisp index f333804..0120d2d 100644 --- a/src/code/setf.lisp +++ b/src/code/setf.lisp @@ -405,7 +405,7 @@ (when doc (setf (fdocumentation name 'setf) doc)) name))) - (defun %defsetf (name expander expander-lambda-list inverse doc) + (defun %defsetf (name expander expander-lambda-list inverse &optional doc) #+sb-xc-host (declare (ignore expander-lambda-list)) (with-single-package-locked-error (:symbol name "defining a setf-expander for ~A")) @@ -433,7 +433,7 @@ (style-warn "defining setf macro for ~S when ~S is also defined" name setf-fn-name))))) (assign-it)) - (defun !quietly-defsetf (name expander expander-lambda-list inverse doc) + (defun !quietly-defsetf (name expander expander-lambda-list inverse &optional doc) #+sb-xc-host (declare (ignore expander-lambda-list)) (assign-it)))) @@ -447,7 +447,7 @@ (typecase rest ((cons (and symbol (not null)) (or null (cons string null))) `(eval-when (:load-toplevel :compile-toplevel :execute) - (%defsetf ',access-fn nil nil ',(car rest) ',(cadr rest)))) + (%defsetf ',access-fn nil nil ',(car rest) ,@(cdr rest)))) ((cons list (cons list)) (destructuring-bind (lambda-list (&rest stores) &body body) rest (binding* (((llks req opt rest key aux env) @@ -473,7 +473,8 @@ (apply (lambda ,lambda-list ,@inner-decls (block ,access-fn ,@forms)) ,subforms))) - ',lambda-list nil ',doc))))) + ',lambda-list nil ,@(and doc + `(,doc))))))) (t (error "Ill-formed DEFSETF for ~S" access-fn)))) @@ -585,7 +586,8 @@ :doc-string-allowed :external) (declare (ignore arglist)) `(eval-when (:compile-toplevel :load-toplevel :execute) - (%defsetf ',access-fn ,def ',lambda-list nil ',doc)))) + (%defsetf ',access-fn ,def ',lambda-list nil ,@(and doc + `(,doc)))))) (sb!xc:define-setf-expander values (&rest places &environment env) (declare (type sb!c::lexenv env)) diff --git a/src/compiler/compiler-deftype.lisp b/src/compiler/compiler-deftype.lisp index 7b94a3c..d496ea7 100644 --- a/src/compiler/compiler-deftype.lisp +++ b/src/compiler/compiler-deftype.lisp @@ -13,7 +13,7 @@ (/show0 "compiler-deftype.lisp 14") -(defun %compiler-deftype (name lambda-list expander doc source-location) +(defun %compiler-deftype (name lambda-list expander source-location &optional doc) #+sb-xc-host (declare (ignore lambda-list)) (with-single-package-locked-error (:symbol name "defining ~A as a type specifier")) diff --git a/src/compiler/defconstant.lisp b/src/compiler/defconstant.lisp index 9a90707..e79a7f1 100644 --- a/src/compiler/defconstant.lisp +++ b/src/compiler/defconstant.lisp @@ -29,18 +29,19 @@ (declare (ignore indicator)) (values value (not (null foundp)))))) -(def!macro sb!xc:defconstant (name value &optional documentation) +(def!macro sb!xc:defconstant (name value &optional (doc nil docp)) #!+sb-doc "Define a global constant, saying that the value is constant and may be compiled into code. If the variable already has a value, and this is not EQL to the new value, the code is not portable (undefined behavior). The third argument is an optional documentation string for the variable." `(eval-when (:compile-toplevel :load-toplevel :execute) - (sb!c::%defconstant ',name ,value ',documentation - (sb!c:source-location)))) + (sb!c::%defconstant ',name ,value (sb!c:source-location) + ,@(and docp + `(,doc))))) ;;; the guts of DEFCONSTANT -(defun sb!c::%defconstant (name value doc source-location) +(defun sb!c::%defconstant (name value source-location &optional (doc nil docp)) (unless (symbolp name) (error "The constant name is not a symbol: ~S" name)) (when (looks-like-name-of-special-var-p name) @@ -89,7 +90,7 @@ ;; :macro-expansion of something that is getting defined as constant. (clear-info :variable :macro-expansion name) (clear-info :source-location :symbol-macro name) - (when doc + (when docp (setf (fdocumentation name 'variable) doc)) #-sb-xc-host (%set-symbol-value name value) diff --git a/src/compiler/deftype.lisp b/src/compiler/deftype.lisp index fbb7ced..c8a8d5f 100644 --- a/src/compiler/deftype.lisp +++ b/src/compiler/deftype.lisp @@ -16,9 +16,6 @@ (sb!kernel::arg-count-error 'deftype (car whole) (cdr whole) nil 0 0) expansion))) -(defun %deftype (name) - (setf (classoid-cell-pcl-class (find-classoid-cell name :create t)) nil)) - (defvar !*xc-processed-deftypes* nil) (def!macro sb!xc:deftype (&whole form name lambda-list &body body) #!+sb-doc @@ -54,7 +51,6 @@ (%compiler-deftype ',name ',lambda-list ,expander-form - ,doc - ,source-location-form)) - (%deftype ',name) - ',name))) + ,source-location-form + ,@(and doc + `(,doc))))))) diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 7d295b5..55cd209 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -1664,7 +1664,7 @@ core and return a descriptor to it." (defparameter *cold-fset-warm-names* (make-hash-table :test 'equal)) ; names can be conses, e.g. (SETF CAR) -(defun cold-fset (name compiled-lambda inline-expansion source-loc) +(defun cold-fset (name compiled-lambda source-loc &optional inline-expansion) ;; SOURCE-LOC can be ignored, because functions intrinsically store ;; their location as part of the code component. ;; The argument is supplied here only to provide context for diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp index 608ab0b..1bde1f1 100644 --- a/src/pcl/defclass.lisp +++ b/src/pcl/defclass.lisp @@ -73,7 +73,8 @@ ',*writers-for-this-defclass* ',*slot-names-for-this-defclass* (sb-c:source-location) - ',(safe-code-p env))))) + ,@(and (safe-code-p env) + '(t)))))) (if defstruct-p (progn ;; FIXME: (YUK!) Why do we do this? Because in order @@ -470,7 +471,7 @@ (declaim (notinline load-defclass)) (defun load-defclass (name metaclass supers canonical-slots canonical-options - readers writers slot-names source-location safe-p) + readers writers slot-names source-location &optional safe-p) ;; SAFE-P is used by REAL-LOAD-DEFCLASS, but can be ignored here, since ;; during the bootstrap we won't have (SAFETY 3). (declare (ignore safe-p)) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index f0cd1d3..ca4ff2e 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -344,7 +344,7 @@ (make-member-type :members (list (specializer-object specl))))) (defun real-load-defclass (name metaclass-name supers slots other - readers writers slot-names source-location safe-p) + readers writers slot-names source-location &optional safe-p) (with-single-package-locked-error (:symbol name "defining ~S as a class") (%compiler-defclass name readers writers slot-names) (let ((res (apply #'ensure-class name :metaclass metaclass-name diff --git a/tests/load.impure.lisp b/tests/load.impure.lisp index 97477d7..e9638cf 100644 --- a/tests/load.impure.lisp +++ b/tests/load.impure.lisp @@ -447,7 +447,6 @@ ";; SOME-FANCY-MACRO ;; *SOME-VAR* ;; MY-FAVORITE-TYPE -;; NIL ;; FRED ;; (A)")) (delete-file *tmp-filename*))) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: stassats <sta...@us...> - 2015-07-05 15:59:55
|
The branch "master" has been updated in SBCL webpage: from 0d49827e2be42980b5c874192d3c6f13a4ea7013 (commit) - Log ----------------------------------------------------------------- commit c8e08f9a94b3914f9db34190a48b5bea861c0f8a Author: Stas Boukarev <sta...@gm...> Date: Sun Jul 5 18:55:03 2015 +0300 +1.2.13 Windows. --- platform-support-platforms.lisp | 4 ++-- 1 files changed, 2 insertions(+), 2 deletions(-) diff --git a/platform-support-platforms.lisp b/platform-support-platforms.lisp index e925a59..ad4506a 100644 --- a/platform-support-platforms.lisp +++ b/platform-support-platforms.lisp @@ -59,5 +59,5 @@ (define-port :x86 :debian-kfreebsd :available "1.2.7") (define-port :x86-64 :debian-kfreebsd :available "1.2.7") -(define-port :x86 :windows :available "1.2.12" :file-type "msi") -(define-port :x86-64 :windows :available "1.2.12" :file-type "msi") +(define-port :x86 :windows :available "1.2.13" :file-type "msi") +(define-port :x86-64 :windows :available "1.2.13" :file-type "msi") ----------------------------------------------------------------------- hooks/post-receive -- SBCL webpage |
From: Douglas K. <sn...@us...> - 2015-07-05 03:09:25
|
The branch "master" has been updated in SBCL: via afd554b58bde8973aa8a9621c72687362cd6bd3d (commit) from 159451e5efd4f98103431c87a90e33248e362fd3 (commit) - Log ----------------------------------------------------------------- commit afd554b58bde8973aa8a9621c72687362cd6bd3d Author: Douglas Katzman <do...@go...> Date: Sat Jul 4 23:07:59 2015 -0400 Remove ~300 lines of noise from stderr during build --- src/code/cross-type.lisp | 5 ----- src/code/early-fasl.lisp | 6 ++++++ src/code/early-raw-slots.lisp | 5 +++++ src/code/load.lisp | 8 +------- src/code/typedefs.lisp | 2 +- src/compiler/generic/early-vm.lisp | 6 ++++++ src/compiler/lexenv.lisp | 4 ++-- src/compiler/macros.lisp | 2 +- 8 files changed, 22 insertions(+), 16 deletions(-) diff --git a/src/code/cross-type.lisp b/src/code/cross-type.lisp index 18d4727..e318d41 100644 --- a/src/code/cross-type.lisp +++ b/src/code/cross-type.lisp @@ -11,11 +11,6 @@ (in-package "SB!KERNEL") -;;; Is X a fixnum in the target Lisp? -(defun fixnump (x) - (and (integerp x) - (<= sb!xc:most-negative-fixnum x sb!xc:most-positive-fixnum))) - ;;; (This was a useful warning when trying to get bootstrapping ;;; to work, but it's mostly irrelevant noise now that the system ;;; works.) diff --git a/src/code/early-fasl.lisp b/src/code/early-fasl.lisp index c5e145f..7145601 100644 --- a/src/code/early-fasl.lisp +++ b/src/code/early-fasl.lisp @@ -159,6 +159,12 @@ "the current number of recursive LOADs") (declaim (type index *load-depth*)) +(defun make-fop-vector (size) + (declare (type index size)) + (let ((vector (make-array size))) + (setf (aref vector 0) 0) + vector)) + ;;; a holder for the FASL file we're reading from (defstruct (fasl-input (:conc-name %fasl-input-) (:constructor make-fasl-input (stream)) diff --git a/src/code/early-raw-slots.lisp b/src/code/early-raw-slots.lisp index 351e48c..674ef83 100644 --- a/src/code/early-raw-slots.lisp +++ b/src/code/early-raw-slots.lisp @@ -132,6 +132,11 @@ (defglobal *raw-slot-data-list* nil) (setq *raw-slot-data-list* (macrolet ((make-comparer (accessor-name) + #+sb-xc-host + `(lambda (x y) + (declare (ignore x y)) + (error "~S comparator called" ',accessor-name)) + #-sb-xc-host ;; Not a symbol, because there aren't any so-named functions. `(named-lambda ,(string (symbolicate accessor-name "=")) (index x y) diff --git a/src/code/load.lisp b/src/code/load.lisp index b85c9ab..fa74206 100644 --- a/src/code/load.lisp +++ b/src/code/load.lisp @@ -147,13 +147,7 @@ (setf (aref table 0) index (aref table index) thing))) -;;; These three routines are used for both the stack and the table. -(defun make-fop-vector (size) - (declare (type index size)) - (let ((vector (make-array size))) - (setf (aref vector 0) 0) - vector)) - +;;; These two routines are used for both the stack and the table. (defun grow-fop-vector (old-vector old-size) (declare (simple-vector old-vector) (type index old-size)) diff --git a/src/code/typedefs.lisp b/src/code/typedefs.lisp index f1906ab..c32ad6b 100644 --- a/src/code/typedefs.lisp +++ b/src/code/typedefs.lisp @@ -31,7 +31,7 @@ ;;; an explicit default of '*, or else it assumes a default of NIL. (defmacro !def-type-translator (name arglist &body body) (declare (type symbol name)) - (multiple-value-bind (fun arglist) + (multiple-value-bind (fun #-sb-xc-host arglist) (make-macro-lambda (format nil "~A-TYPE-PARSE" name) arglist body nil nil :environment nil) `(!cold-init-forms diff --git a/src/compiler/generic/early-vm.lisp b/src/compiler/generic/early-vm.lisp index 05b0159..91d916b 100644 --- a/src/compiler/generic/early-vm.lisp +++ b/src/compiler/generic/early-vm.lisp @@ -93,3 +93,9 @@ ;; a slot of data that is not the instance-layout. ;; To get a layout, you must call %INSTANCE-LAYOUT - don't assume index 0. (def!constant instance-data-start 1) + +;;; Is X a fixnum in the target Lisp? +#+sb-xc-host +(defun fixnump (x) + (and (integerp x) + (<= sb!xc:most-negative-fixnum x sb!xc:most-positive-fixnum))) diff --git a/src/compiler/lexenv.lisp b/src/compiler/lexenv.lisp index fbfc110..35749b8 100644 --- a/src/compiler/lexenv.lisp +++ b/src/compiler/lexenv.lisp @@ -131,7 +131,7 @@ ;; #+sb-xc-host (declare (ignore x)) #+sb-xc-host ;; KLUDGE: too complicated for cross-compilation - (return t) + (progn x (return t)) ; lp#719585 #-sb-xc-host (let ((name (car x)) (what (cdr x))) @@ -155,7 +155,7 @@ #+sb-xc-host ;; KLUDGE: too complicated for cross-compilation (and ;; failure of OAOO in comments, *sigh*) - (return t) + (progn x (return t)) ; lp#719585 #-sb-xc-host (let ((name (car x)) (what (cdr x))) diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index eb9344a..153d534 100644 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -34,7 +34,7 @@ (multiple-value-bind (lambda-expr arglist doc) (make-macro-lambda nil lambda-list body :special-form name :doc-string-allowed :external :wrap-block nil) - (declare (ignorable doc)) + (declare (ignorable arglist doc)) `(progn (declaim (ftype (function (ctran ctran (or lvar null) t) (values)) ,fn-name)) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2015-07-05 01:24:52
|
The branch "master" has been updated in SBCL: via 159451e5efd4f98103431c87a90e33248e362fd3 (commit) from a7879501ae25a4c8c60d8a208419e272ec4e3a7e (commit) - Log ----------------------------------------------------------------- commit 159451e5efd4f98103431c87a90e33248e362fd3 Author: Douglas Katzman <do...@go...> Date: Sat Jul 4 20:47:41 2015 -0400 An atom given to destructuring-bind isn't a special case. It's just an ARG-COUNT-ERROR, not a TYPE-ERROR. --- src/code/destructuring-bind.lisp | 7 +------ src/code/full-eval.lisp | 7 ------- src/compiler/ir1-translators.lisp | 1 + tests/type.pure.lisp | 2 +- 4 files changed, 3 insertions(+), 14 deletions(-) diff --git a/src/code/destructuring-bind.lisp b/src/code/destructuring-bind.lisp index d6cbbb0..32867bc 100644 --- a/src/code/destructuring-bind.lisp +++ b/src/code/destructuring-bind.lisp @@ -13,10 +13,5 @@ #!+sb-doc "Bind the variables in LAMBDA-LIST to the corresponding values in the tree structure resulting from the evaluation of EXPRESSION." - ;; (THE LIST ...) is not really right, because it means that - ;; the descriptive message about the lambda list won't be shown. - ;; It'll just be type-error. - `(binding* ,(sb!c::expand-ds-bind lambda-list - `(the list ,expression) - t nil) + `(binding* ,(sb!c::expand-ds-bind lambda-list expression t nil) ,@body)) diff --git a/src/code/full-eval.lisp b/src/code/full-eval.lisp index c6075ea..1fb90b5 100644 --- a/src/code/full-eval.lisp +++ b/src/code/full-eval.lisp @@ -54,13 +54,6 @@ ;; OAOOM? (see destructuring-bind.lisp) (defmacro program-destructuring-bind (lambda-list arg-list &body body) - ;; Not wrapping ARG-LIST in (THE LIST) is better than what DESTRUCTURING-BIND - ;; does, because this gives a more descriptive message if you pass a non-list - ;; to the form handler, like (IF . 3) will say that 3 does not match the - ;; list (TEST IF-TRUE &OPTIONAL IF-FALSE) rather than just "3 is not a list". - ;; For the sake of compatibility, DESTRUCTURING-BIND signals TYPE-ERROR - ;; in that situation, which is less than ideal. - ;; ;; (:EVAL) is a dummy context. We don't have enough information to ;; show the operator name without using debugger internals to get the stack frame. ;; It would be easier to make the name an argument to this macro. diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index c71443b..1570cd3 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -287,6 +287,7 @@ Evaluate the FORMS in the specified SITUATIONS (any of :COMPILE-TOPLEVEL, ;;; Call DEFINITIONIZE-FUN on each element of DEFINITIONS to find its ;;; in-lexenv representation, stuff the results into *LEXENV*, and ;;; call FUN (with no arguments). +;;; lp#1395952 suggests that this needs to be more careful. (defun %funcall-in-foomacrolet-lexenv (definitionize-fun definitionize-keyword definitions diff --git a/tests/type.pure.lisp b/tests/type.pure.lisp index 67beb51..6fa0d3c 100644 --- a/tests/type.pure.lisp +++ b/tests/type.pure.lisp @@ -515,7 +515,7 @@ (with-test (:name :parse-safely) (dolist (x '(array integer cons)) (assert (handler-case (sb-kernel:specifier-type `(,x . 0)) - (type-error () t) + (sb-kernel::arg-count-error () t) (error (c) (print c) nil))))) (with-test (:name :unparse-safely) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2015-07-05 01:24:50
|
The branch "master" has been updated in SBCL: via a7879501ae25a4c8c60d8a208419e272ec4e3a7e (commit) from e0721f45d2a1b750f624b09e070f4a4bd6aa9419 (commit) - Log ----------------------------------------------------------------- commit a7879501ae25a4c8c60d8a208419e272ec4e3a7e Author: Douglas Katzman <do...@go...> Date: Sat Jul 4 20:21:32 2015 -0400 Remove some test noise. A drop in the ocean unfortunately. --- tests/package-locks.impure.lisp | 9 ++++++--- 1 files changed, 6 insertions(+), 3 deletions(-) diff --git a/tests/package-locks.impure.lisp b/tests/package-locks.impure.lisp index 15f9977..096e8fb 100644 --- a/tests/package-locks.impure.lisp +++ b/tests/package-locks.impure.lisp @@ -115,6 +115,7 @@ (defmacro with-error-info ((string &rest args) &body forms) `(handler-bind ((error (lambda (e) + (declare (ignorable e)) (format t ,string ,@args) (finish-output)))) (progn ,@forms))) @@ -201,6 +202,7 @@ (defmacro test:unused () ''foo) (setf (macro-function 'test:unused) (constantly 'foo)) (define-compiler-macro test:unused (&whole form arg) + (declare (ignore arg)) form) (setf (compiler-macro-function 'test:unused) (constantly 'foo)) @@ -241,6 +243,7 @@ (define-setf-expander test:car (place) (multiple-value-bind (dummies vals newval setter getter) (get-setf-expansion place) + (declare (ignore newval setter)) (let ((store (gensym))) (values dummies vals @@ -406,7 +409,7 @@ (let ((error-count 0)) ;; check that we don't get multiple errors from a single form (handler-bind ((package-lock-violation (lambda (x) - (declare (ignore x)) + (declare (ignorable x)) (incf error-count) (continue x)))) (eval form) @@ -418,8 +421,7 @@ ;;; ;;; This is not part of the interface, but it is the behaviour we want (let* ((tmp "package-locks.tmp.lisp") - (fasl (compile-file-pathname tmp)) - (n 0)) + (fasl (compile-file-pathname tmp))) (dolist (form *illegal-runtime-forms*) (unwind-protect (with-simple-restart (next "~S failed, continue with next test" form) @@ -427,6 +429,7 @@ (with-open-file (f tmp :direction :output) (prin1 form f)) (multiple-value-bind (file warnings failure-p) (compile-file tmp) + (declare (ignore file warnings failure-p)) (set-test-locks t) (assert-error (load fasl) sb-ext:package-lock-violation))) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Jan M. <sc...@us...> - 2015-07-04 23:50:56
|
The branch "master" has been updated in SBCL: via e0721f45d2a1b750f624b09e070f4a4bd6aa9419 (commit) from bc0f003fd7c85e1ccb84531e1796eb8f29e73517 (commit) - Log ----------------------------------------------------------------- commit e0721f45d2a1b750f624b09e070f4a4bd6aa9419 Author: Jan Moringen <jmo...@te...> Date: Mon Sep 9 02:24:01 2013 +0200 Add ENSURE-LIST, use where appropriate --- contrib/sb-executable/sb-executable.lisp | 2 +- contrib/sb-introspect/introspect.lisp | 8 +---- package-data-list.lisp-expr | 4 +- src/code/array.lisp | 2 +- src/code/dyncount.lisp | 2 +- src/code/early-extensions.lisp | 4 +++ src/code/loop.lisp | 11 +++----- src/code/module.lisp | 3 +- src/code/target-package.lisp | 7 +--- src/code/target-thread.lisp | 4 +-- src/compiler/aliencomp.lisp | 40 ++++++++++++++--------------- src/compiler/array-tran.lisp | 4 +- src/compiler/ir1util.lisp | 26 ++++++++----------- src/compiler/target-disassem.lisp | 5 +--- src/compiler/x86-64/pred.lisp | 4 +-- src/compiler/x86/pred.lisp | 4 +-- src/pcl/cache.lisp | 4 +-- src/pcl/defs.lisp | 2 +- src/pcl/methods.lisp | 2 +- src/pcl/vector.lisp | 15 +++++------ tests/compiler.pure.lisp | 4 +-- 21 files changed, 65 insertions(+), 92 deletions(-) diff --git a/contrib/sb-executable/sb-executable.lisp b/contrib/sb-executable/sb-executable.lisp index 77740e0..5befd9b 100644 --- a/contrib/sb-executable/sb-executable.lisp +++ b/contrib/sb-executable/sb-executable.lisp @@ -48,7 +48,7 @@ exec sbcl --noinform ~{~A ~}--eval \"(with-open-file (i \\\"$0\\\" :element-type (write-sequence (map 'vector #'char-code (format nil *exec-header* runtime-flags (or initial-function 'values))) out) - (dolist (input-file (if (listp fasls) fasls (list fasls))) + (dolist (input-file (sb-int:ensure-list fasls)) (with-open-file (in (merge-pathnames input-file (make-pathname :type "fasl")) :element-type '(unsigned-byte 8)) diff --git a/contrib/sb-introspect/introspect.lisp b/contrib/sb-introspect/introspect.lisp index 518369c..a589157 100644 --- a/contrib/sb-introspect/introspect.lisp +++ b/contrib/sb-introspect/introspect.lisp @@ -221,11 +221,7 @@ name. Type can currently be one of the following: If an unsupported TYPE is requested, the function will return NIL. " - (flet ((listify (x) - (if (listp x) - x - (list x))) - (get-class (name) + (flet ((get-class (name) (and (symbolp name) (find-class name nil))) (real-fdefinition (name) @@ -235,7 +231,7 @@ If an unsupported TYPE is requested, the function will return NIL. (if profile-info (sb-profile::profile-info-encapsulated-fun profile-info) (fdefinition name))))) - (listify + (sb-int:ensure-list (case type ((:variable) (when (and (symbolp name) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index cf3ba5a..a8ac8d7 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1238,8 +1238,8 @@ possibly temporarily, because it might be used internally." "PROPER-LIST-OF-LENGTH-P" "PROPER-LIST-P" "LIST-OF-LENGTH-AT-LEAST-P" "LIST-WITH-LENGTH-P" - "SINGLETON-P" - "MISSING-ARG" + "SINGLETON-P" "ENSURE-LIST" + "MISSING-ARG" "FEATUREP" "FLUSH-STANDARD-OUTPUT-STREAMS" "WITH-UNIQUE-NAMES" "MAKE-GENSYM-LIST" diff --git a/src/code/array.lisp b/src/code/array.lisp index cd98cda..0d893a8 100644 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@ -1109,7 +1109,7 @@ of specialized arrays is supported." "Adjust ARRAY's dimensions to the given DIMENSIONS and stuff." (when (invalid-array-p array) (invalid-array-error array)) - (binding* ((dimensions (if (listp dimensions) dimensions (list dimensions))) + (binding* ((dimensions (ensure-list dimensions)) (array-rank (array-rank array)) (() (unless (= (length dimensions) array-rank) diff --git a/src/code/dyncount.lisp b/src/code/dyncount.lisp index 5380c3b..738891b 100644 --- a/src/code/dyncount.lisp +++ b/src/code/dyncount.lisp @@ -299,7 +299,7 @@ comments from CMU CL: (defun matches-pattern (name pattern) (declare (simple-string name)) (let ((name (concatenate 'string "$" name "$"))) - (dolist (pat (if (listp pattern) pattern (list pattern)) nil) + (dolist (pat (ensure-list pattern) nil) (when (search (the simple-string (string pat)) name :test #'char=) (return t))))) diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index fdccaa1..a9f5170 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -215,6 +215,10 @@ (and (consp x) (list-of-length-at-least-p (cdr x) (1- n))))) +(declaim (inline ensure-list)) +(defun ensure-list (thing) + (if (listp thing) thing (list thing))) + ;;; Is X is a positive prime integer? (defun positive-primep (x) ;; This happens to be called only from one place in sbcl-0.7.0, and diff --git a/src/code/loop.lisp b/src/code/loop.lisp index 2adabb9..ae93b20 100644 --- a/src/code/loop.lisp +++ b/src/code/loop.lisp @@ -1464,16 +1464,13 @@ code to be loaded. (defun add-loop-path (names function universe &key preposition-groups inclusive-permitted user-data) (declare (type loop-universe universe)) - (unless (listp names) - (setq names (list names))) - (let ((ht (loop-universe-path-keywords universe)) - (lp (make-loop-path + (let* ((names (sb!int:ensure-list names)) + (ht (loop-universe-path-keywords universe)) + (lp (make-loop-path :names (mapcar #'symbol-name names) :function function :user-data user-data - :preposition-groups (mapcar (lambda (x) - (if (listp x) x (list x))) - preposition-groups) + :preposition-groups (mapcar #'sb!int:ensure-list preposition-groups) :inclusive-permitted inclusive-permitted))) (dolist (name names) (setf (gethash (symbol-name name) ht) lp)) diff --git a/src/code/module.lisp b/src/code/module.lisp index 8d00580..1bf770a 100644 --- a/src/code/module.lisp +++ b/src/code/module.lisp @@ -63,10 +63,9 @@ (*requiring* (cons name *requiring*))) (unless (member name *modules* :test #'string=) (cond (pathnames - (unless (listp pathnames) (setf pathnames (list pathnames))) ;; ambiguity in standard: should we try all pathnames in the ;; list, or should we stop as soon as one of them calls PROVIDE? - (dolist (ele pathnames t) + (dolist (ele (ensure-list pathnames) t) (load ele))) (t (unless (some (lambda (p) (funcall p module-name)) diff --git a/src/code/target-package.lisp b/src/code/target-package.lisp index 1069ab2..0457ed4 100644 --- a/src/code/target-package.lisp +++ b/src/code/target-package.lisp @@ -577,8 +577,7 @@ REMOVE-PACKAGE-LOCAL-NICKNAME, and the DEFPACKAGE option :LOCAL-NICKNAMES." ;;; Return a list of packages given a package designator or list of ;;; package designators, or die trying. (defun package-listify (thing) - (mapcar #'find-undeleted-package-or-lose - (if (listp thing) thing (list thing)))) + (mapcar #'find-undeleted-package-or-lose (ensure-list thing))) ;;; ANSI specifies (in the definition of DELETE-PACKAGE) that PACKAGE-NAME ;;; returns NIL (not an error) for a deleted package, so this is a special @@ -1244,9 +1243,7 @@ uninterned." thing)))) (defun string-listify (thing) - (mapcar #'string (if (listp thing) - thing - (list thing)))) + (mapcar #'string (ensure-list thing))) (defun export (symbols &optional (package (sane-package))) #!+sb-doc diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index df4f356..ff52738 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -1523,9 +1523,7 @@ See also: RETURN-FROM-THREAD, ABORT-THREAD." make-mutex)) (let* ((setup-sem (make-semaphore :name "Thread setup semaphore")) (real-function (coerce function 'function)) - (arguments (if (listp arguments) - arguments - (list arguments))) + (arguments (ensure-list arguments)) #!+win32 (fp-modes (dpb 0 sb!vm::float-sticky-bits ;; clear accrued bits (sb!vm:floating-point-modes))) diff --git a/src/compiler/aliencomp.lisp b/src/compiler/aliencomp.lisp index 6f15234..2100f1c 100644 --- a/src/compiler/aliencomp.lisp +++ b/src/compiler/aliencomp.lisp @@ -812,28 +812,26 @@ (vop sb!vm::move-single-to-int-arg call block float-tn i1-tn)))))) (aver (null args)) - (unless (listp result-tns) - (setf result-tns (list result-tns))) (let ((arg-tns (remove-if-not #'tn-p (flatten-list arg-tns))) - (result-tns (remove-if-not #'tn-p result-tns))) + (result-tns (remove-if-not #'tn-p (ensure-list result-tns)))) (vop* call-out call block ((lvar-tn call block function) (reference-tn-list arg-tns nil)) - ((reference-tn-list result-tns t)))) - #!-x86 - (vop dealloc-number-stack-space call block stack-frame-size) - #!+x86 - (progn - (vop reset-stack-pointer call block stack-pointer) - (vop set-fpu-word-for-lisp call block)) - (cond - #!+arm-softfp - ((and lvar - (proper-list-of-length-p result-tns 3) - (symbolp (third result-tns))) - (emit-template call block - (template-or-lose (third result-tns)) - (reference-tn-list (butlast result-tns) nil) - (reference-tn (car (ir2-lvar-locs (lvar-info lvar))) t))) - (t - (move-lvar-result call block result-tns lvar)))))) + ((reference-tn-list result-tns t))) + #!-x86 + (vop dealloc-number-stack-space call block stack-frame-size) + #!+x86 + (progn + (vop reset-stack-pointer call block stack-pointer) + (vop set-fpu-word-for-lisp call block)) + (cond + #!+arm-softfp + ((and lvar + (proper-list-of-length-p result-tns 3) + (symbolp (third result-tns))) + (emit-template call block + (template-or-lose (third result-tns)) + (reference-tn-list (butlast result-tns) nil) + (reference-tn (car (ir2-lvar-locs (lvar-info lvar))) t))) + (t + (move-lvar-result call block result-tns lvar))))))) diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index e5f867a..92439d2 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -319,7 +319,7 @@ '*)) ,(cond ((constant-lvar-p dims) (let* ((val (lvar-value dims)) - (cdims (if (listp val) val (list val)))) + (cdims (ensure-list val))) (if simple cdims (length cdims)))) @@ -413,7 +413,7 @@ (multiple-value-bind (new-dimensions rank) (flet ((constant-dims (dimensions) (let* ((dims (constant-form-value dimensions env)) - (canon (if (listp dims) dims (list dims))) + (canon (ensure-list dims)) (rank (length canon))) (values (if (= rank 1) (list 'quote (car canon)) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 8a4643f..60d5154 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -64,10 +64,7 @@ ;;; Return a list of all the nodes which use LVAR. (declaim (ftype (sfunction (lvar) list) find-uses)) (defun find-uses (lvar) - (let ((uses (lvar-uses lvar))) - (if (listp uses) - uses - (list uses)))) + (ensure-list (lvar-uses lvar))) (declaim (ftype (sfunction (lvar) lvar) principal-lvar)) (defun principal-lvar (lvar) @@ -531,7 +528,7 @@ (lvar-good-for-dx-p (trivial-lambda-var-ref-lvar use) dx component)))))) (defun lvar-good-for-dx-p (lvar dx &optional component) - (let ((uses (lvar-uses lvar))) + (let ((uses (lvar-uses lvar))) ; TODO use ENSURE-LIST? or is it too slow? (if (listp uses) (when uses (every (lambda (use) @@ -662,7 +659,7 @@ (handle-nested-dynamic-extent-lvars dx other recheck-component))))))) (cons (cons dx lvar) - (if (listp uses) + (if (listp uses) ; TODO use ENSURE-LIST? or is it too slow? (loop for use in uses when (use-good-for-dx-p use dx recheck-component) nconc (recurse use)) @@ -1879,17 +1876,16 @@ is :ANY, the function name is not checked." (declare (type lvar lvar) (type (or symbol list) fun) (type index num-args)) - (let ((fun (if (listp fun) fun (list fun)))) - (let ((inside (lvar-uses lvar))) - (unless (combination-p inside) + (let ((inside (lvar-uses lvar))) + (unless (combination-p inside) + (give-up-ir1-transform)) + (let ((inside-fun (combination-fun inside))) + (unless (member (lvar-fun-name inside-fun) (ensure-list fun)) (give-up-ir1-transform)) - (let ((inside-fun (combination-fun inside))) - (unless (member (lvar-fun-name inside-fun) fun) + (let ((inside-args (combination-args inside))) + (unless (= (length inside-args) num-args) (give-up-ir1-transform)) - (let ((inside-args (combination-args inside))) - (unless (= (length inside-args) num-args) - (give-up-ir1-transform)) - (values (lvar-fun-name inside-fun) inside-args)))))) + (values (lvar-fun-name inside-fun) inside-args))))) (defun flush-combination (combination) (declare (type combination combination)) diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp index 5885e72..3d222c9 100644 --- a/src/compiler/target-disassem.lisp +++ b/src/compiler/target-disassem.lisp @@ -1544,10 +1544,7 @@ (disassemble-fun fun :stream stream :use-labels use-labels))) - (let ((funs (compiled-funs-or-lose object))) - (if (listp funs) - (dolist (fun funs) (disassemble1 fun)) - (disassemble1 funs)))) + (mapc #'disassemble1 (ensure-list (compiled-funs-or-lose object)))) nil) ;;; Disassembles the given area of memory starting at ADDRESS and diff --git a/src/compiler/x86-64/pred.lisp b/src/compiler/x86-64/pred.lisp index 6265605..360157a 100644 --- a/src/compiler/x86-64/pred.lisp +++ b/src/compiler/x86-64/pred.lisp @@ -64,13 +64,11 @@ (mapcan (lambda (entry) (destructuring-bind (ptypes &optional sc vop) entry - (unless (listp ptypes) - (setf ptypes (list ptypes))) (mapcar (if (and vop sc) (lambda (ptype) (list ptype sc vop)) #'list) - ptypes))) + (ensure-list ptypes)))) '((t descriptor-reg move-if/t) ((fixnum positive-fixnum) diff --git a/src/compiler/x86/pred.lisp b/src/compiler/x86/pred.lisp index 5ed4fd9..3282681 100644 --- a/src/compiler/x86/pred.lisp +++ b/src/compiler/x86/pred.lisp @@ -51,13 +51,11 @@ (mapcan (lambda (entry) (destructuring-bind (ptypes &optional sc vop) entry - (unless (listp ptypes) - (setf ptypes (list ptypes))) (mapcar (if (and vop sc) (lambda (ptype) (list ptype sc vop)) #'list) - ptypes))) + (ensure-list ptypes)))) '((t descriptor-reg move-if/t) ((fixnum positive-fixnum) diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp index 68346ba..835c14d 100644 --- a/src/pcl/cache.lisp +++ b/src/pcl/cache.lisp @@ -426,9 +426,7 @@ (%fill-cache (copy-cache cache) layouts value t)) (t (copy-and-expand-cache cache layouts value))))) - (if (listp layouts) - (%fill-cache cache layouts value nil) - (%fill-cache cache (list layouts) value nil)))) + (%fill-cache cache (ensure-list layouts) value nil))) ;;; Calls FUNCTION with all layouts and values in cache. (defun map-cache (function cache) diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index 6ca3fd2..24e24e2 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -128,7 +128,7 @@ (let ((class (find-class type nil))) (if class (let ((type (specializer-type class))) - (if (listp type) type `(,type))) + (ensure-list type)) `(,type)))) ((or (not (eq **boot-state** 'complete)) (specializerp type)) diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index c7faf91..1858c45 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -761,7 +761,7 @@ (defun get-wrappers-from-classes (nkeys wrappers classes metatypes) (let* ((w wrappers) (w-tail w) (mt-tail metatypes)) - (dolist (class (if (listp classes) classes (list classes))) + (dolist (class (ensure-list classes)) (unless (eq t (car mt-tail)) (let ((c-w (class-wrapper class))) (unless c-w (return-from get-wrappers-from-classes nil)) diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index 57b5c05..5d8fc10 100644 --- a/src/pcl/vector.lisp +++ b/src/pcl/vector.lisp @@ -98,9 +98,8 @@ (slot-missing class object slot-name 'setf new-value))))) (defun compute-pv (slot-name-lists wrappers) - (unless (listp wrappers) - (setq wrappers (list wrappers))) - (let (elements) + (let ((wrappers (ensure-list wrappers)) + elements) (dolist (slot-names slot-name-lists) (when slot-names (let* ((wrapper (pop wrappers)) @@ -108,18 +107,18 @@ (class (wrapper-class* wrapper))) (dolist (slot-name (cdr slot-names)) (let ((cell - (or (find-slot-cell wrapper slot-name) - (cons nil (slot-missing-info class slot-name))))) + (or (find-slot-cell wrapper slot-name) + (cons nil (slot-missing-info class slot-name))))) (push (when (and std-p (use-standard-slot-access-p class slot-name 'all)) (car cell)) - elements) + elements) (push (or (cdr cell) (bug "No SLOT-INFO for ~S in ~S" slot-name class)) - elements)))))) + elements)))))) (let* ((n (length elements)) (pv (make-array n))) (loop for i from (1- n) downto 0 - do (setf (svref pv i) (pop elements))) + do (setf (svref pv i) (pop elements))) pv))) (defun pv-table-lookup (pv-table pv-wrappers) diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 26a1777..2469d25 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -257,9 +257,7 @@ "The return value of NSET-DIFFERENCE should not be discarded.") ((progn (nset-exclusive-or (list 1 3) (list 2 4)) t) "The return value of NSET-EXCLUSIVE-OR should not be discarded.")) - for expected = (if (listp expected-des) - expected-des - (list expected-des)) + for expected = (sb-int:ensure-list expected-des) do (multiple-value-bind (fun warnings-p failure-p) (handler-bind ((style-warning (lambda (c) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Jan M. <sc...@us...> - 2015-07-04 23:50:54
|
The branch "master" has been updated in SBCL: via bc0f003fd7c85e1ccb84531e1796eb8f29e73517 (commit) from be5cb7ee138291b348573d567fdd7ff4bfc466b8 (commit) - Log ----------------------------------------------------------------- commit bc0f003fd7c85e1ccb84531e1796eb8f29e73517 Author: Jan Moringen <jmo...@te...> Date: Tue Jun 23 20:21:43 2015 +0200 Use !UNCROSS-FORMAT-CONTROL for deprecation condition reports --- src/code/condition.lisp | 33 +++++++++++---------------------- 1 files changed, 11 insertions(+), 22 deletions(-) diff --git a/src/code/condition.lisp b/src/code/condition.lisp index cbaa939..1eb0f71 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -1674,32 +1674,21 @@ the usual naming convention (names like *FOO*) for special variables" (deprecated-name condition))))))) (define-deprecation-warning early-deprecation-warning style-warning nil - #+sb-xc-host - "~%~@<~:@_In future SBCL versions ~ - ~/sb!impl:print-symbol-with-prefix/ will signal a full warning ~ - at compile-time.~:@>" - #-sb-xc-host - "~%~@<~:@_In future SBCL versions ~ - ~/sb-impl:print-symbol-with-prefix/ will signal a full warning ~ - at compile-time.~:@>") + (!uncross-format-control + "~%~@<~:@_In future SBCL versions ~ + ~/sb!impl:print-symbol-with-prefix/ will signal a full warning ~ + at compile-time.~:@>")) (define-deprecation-warning late-deprecation-warning warning t - #+sb-xc-host - "~%~@<~:@_In future SBCL versions ~ - ~/sb!impl:print-symbol-with-prefix/ will signal a runtime ~ - error.~:@>" - #-sb-xc-host - "~%~@<~:@_In future SBCL versions ~ - ~/sb-impl:print-symbol-with-prefix/ will signal a runtime ~ - error.~:@>") + (!uncross-format-control + "~%~@<~:@_In future SBCL versions ~ + ~/sb!impl:print-symbol-with-prefix/ will signal a runtime ~ + error.~:@>")) (define-deprecation-warning final-deprecation-warning warning t - #+sb-xc-host - "~%~@<~:@_An error will be signaled at runtime for ~ - ~/sb!impl:print-symbol-with-prefix/.~:@>" - #-sb-xc-host - "~%~@<~:@_An error will be signaled at runtime for ~ - ~/sb-impl:print-symbol-with-prefix/.~:@>")) + (!uncross-format-control + "~%~@<~:@_An error will be signaled at runtime for ~ + ~/sb!impl:print-symbol-with-prefix/.~:@>"))) (define-condition deprecation-error (error deprecation-condition) ()) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2015-07-02 19:20:11
|
The branch "master" has been updated in SBCL: via be5cb7ee138291b348573d567fdd7ff4bfc466b8 (commit) from 07338b735fb3aa0c2770a29ba4520bcd73f45d02 (commit) - Log ----------------------------------------------------------------- commit be5cb7ee138291b348573d567fdd7ff4bfc466b8 Author: Douglas Katzman <do...@go...> Date: Thu Jul 2 15:04:02 2015 -0400 Delete all remnants of parse-defmacro --- build-order.lisp-expr | 3 +- package-data-list.lisp-expr | 2 +- src/code/parse-defmacro-errors.lisp | 19 +-- src/code/parse-defmacro.lisp | 453 ----------------------------------- src/compiler/parse-lambda-list.lisp | 26 ++- src/pcl/defcombin.lisp | 2 +- tests/lambda-list.pure.lisp | 2 +- tests/macroexpand.impure.lisp | 3 +- 8 files changed, 30 insertions(+), 480 deletions(-) diff --git a/build-order.lisp-expr b/build-order.lisp-expr index 1d37873..ecd3207 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -129,8 +129,7 @@ ("src/code/barrier" :not-host) ("src/code/parse-body") ; on host for PARSE-BODY ("src/code/early-extensions") ; on host for COLLECT, SYMBOLICATE, etc. - ("src/compiler/parse-lambda-list") ; needed by PARSE-DEFMACRO - ("src/code/parse-defmacro") ; on host for PARSE-DEFMACRO + ("src/compiler/parse-lambda-list") ("src/compiler/deftype") ; on host for SB!XC:DEFTYPE ("src/code/restart" :not-host) ; %DEFCONSTANT can bind a restart ("src/compiler/defconstant") diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 59f2d36..cf3ba5a 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1777,7 +1777,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "PACKAGE-DESIGNATOR" "PACKAGE-DOC-STRING" "PACKAGE-HASHTABLE-SIZE" "PACKAGE-HASHTABLE-FREE" "PACKAGE-INTERNAL-SYMBOLS" "PACKAGE-EXTERNAL-SYMBOLS" - "PARSE-DEFMACRO" "PARSE-UNKNOWN-TYPE" + "PARSE-UNKNOWN-TYPE" "PARSE-UNKNOWN-TYPE-SPECIFIER" "PATHNAME-DESIGNATOR" "POINTER-HASH" #!+(or x86 x86-64) "*PSEUDO-ATOMIC-BITS*" diff --git a/src/code/parse-defmacro-errors.lisp b/src/code/parse-defmacro-errors.lisp index ece99d0..a16b7b7 100644 --- a/src/code/parse-defmacro-errors.lisp +++ b/src/code/parse-defmacro-errors.lisp @@ -1,5 +1,5 @@ -;;;; error-handling machinery for PARSE-DEFMACRO, separated from -;;;; PARSE-DEFMACRO code itself because the happy path can be handled +;;;; error-handling machinery for MAKE-MACRO-LAMBDA separated from +;;;; that code because the happy path can be handled ;;;; earlier in the bootstrap sequence than DEFINE-CONDITION can be ;;;; This software is part of the SBCL system. See the README file for @@ -41,21 +41,6 @@ (pprint-logical-block (stream nil) (funcall fun stream)))) -;;; FIXME: This is not an exported symbol, so it can probably be removed, -;;; since nothing signals the condition afaict. -(define-condition defmacro-bogus-sublist-error - (defmacro-lambda-list-bind-error) - ((object :reader defmacro-bogus-sublist-error-object :initarg :object) - (lambda-list :reader defmacro-bogus-sublist-error-lambda-list - :initarg :lambda-list)) - (:report - (lambda (condition stream) - (!printing-defmacro-lambda-list-bind-error (condition stream) - (format stream - "bogus sublist ~2I~_~S ~I~_to satisfy lambda-list ~2I~_~:S" - (defmacro-bogus-sublist-error-object condition) - (defmacro-bogus-sublist-error-lambda-list condition)))))) - (define-condition arg-count-error (defmacro-lambda-list-bind-error) ((args :reader arg-count-error-args :initarg :args) (lambda-list :reader arg-count-error-lambda-list diff --git a/src/code/parse-defmacro.lisp b/src/code/parse-defmacro.lisp deleted file mode 100644 index 82a4f89..0000000 --- a/src/code/parse-defmacro.lisp +++ /dev/null @@ -1,453 +0,0 @@ -;;;; the PARSE-DEFMACRO function and related code - -;;;; 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!KERNEL") - -;;; variables for accumulating the results of parsing a DEFMACRO. (Declarations -;;; in DEFMACRO are the reason this isn't as easy as it sounds.) -(defvar *arg-tests*) ; tests that do argument counting at expansion time -(declaim (type list *arg-tests*)) -(defvar *system-lets*) ; LET bindings done to allow lambda-list parsing -(declaim (type list *system-lets*)) -(defvar *user-lets*) ; LET bindings that the user has explicitly supplied -(declaim (type list *user-lets*)) -(defvar *env-var*) ; &ENVIRONMENT variable name - -;; the default default for unsupplied &OPTIONAL and &KEY args -(defvar *default-default*) - -;;; temps that we introduce and might not reference -(defvar *ignorable-vars*) -(declaim (type list *ignorable-vars*)) - -;;; Return, as multiple values, a body, possibly a DECLARE form to put -;;; where this code is inserted, the documentation for the parsed -;;; body, and bounds on the number of arguments. -(defun parse-defmacro (lambda-list whole-var body name context - &key - (anonymousp nil) - (doc-string-allowed t) - ((:environment env-arg-name)) - ((:default-default *default-default*)) - (error-fun 'error) - (wrap-block t)) - (unless (listp lambda-list) - (bad-type lambda-list 'list "~S lambda-list is not a list: ~S" - context lambda-list)) - (multiple-value-bind (forms declarations documentation) - (parse-body body :doc-string-allowed doc-string-allowed) - (let ((*arg-tests* ()) - (*user-lets* ()) - (*system-lets* ()) - (*ignorable-vars* ()) - (*env-var* nil)) - (multiple-value-bind (env-arg-used minimum maximum) - (parse-defmacro-lambda-list lambda-list whole-var name context - :error-fun error-fun - :anonymousp anonymousp) - (values `(let* (,@(nreverse *system-lets*)) - #-sb-xc-host - (declare (muffle-conditions code-deletion-note)) - ,@(when *ignorable-vars* - `((declare (ignorable ,@*ignorable-vars*)))) - ,@*arg-tests* - (let* (,@(when env-arg-used - `((,*env-var* ,env-arg-name))) - ,@(nreverse *user-lets*)) - ,@declarations - ,@(if wrap-block - `((block ,(fun-name-block-name name) - ,@forms)) - forms))) - `(,@(when (and env-arg-name (not env-arg-used)) - `((declare (ignore ,env-arg-name))))) - documentation - minimum - maximum))))) - -(defun parse-defmacro-lambda-list (possibly-dotted-lambda-list - whole-var - name - context - &key - error-fun - anonymousp - env-illegal - sublist) - (let* (;; PATH is a sort of pointer into the part of the lambda list we're - ;; considering at this point in the code. PATH-0 is the root of the - ;; lambda list, which is the initial value of PATH. - (path-0 (if (or anonymousp sublist) whole-var `(cdr ,whole-var))) - (path path-0) ; will change below - (compiler-macro-whole (gensym "CMACRO-&WHOLE")) - (now-processing :required) - (maximum 0) - (minimum 0) - (keys ()) - (key-seen nil) - (aux-seen nil) - (optional-seen nil) - ;; ANSI specifies that dotted lists are "treated exactly as if the - ;; parameter name that ends the list had appeared preceded by &REST." - ;; We force this behavior by transforming dotted lists into ordinary - ;; lists with explicit &REST elements. - (lambda-list (do ((in-pdll possibly-dotted-lambda-list (cdr in-pdll)) - (reversed-result nil)) - ((atom in-pdll) - (nreverse (if in-pdll - (list* in-pdll '&rest reversed-result) - reversed-result))) - (push (car in-pdll) reversed-result))) - rest-name restp allow-other-keys-p env-arg-used) - (when (member '&whole (rest lambda-list)) - (error "&WHOLE may only appear first in ~S lambda-list." context)) - ;; Special case compiler-macros: if car of the form is FUNCALL, - ;; skip over it for destructuring, pretending cdr of the form is - ;; the actual form. Save original for &WHOLE. - (when (and (not sublist) (eq context 'define-compiler-macro)) - (push-let-binding compiler-macro-whole whole-var :system t) - (push compiler-macro-whole *ignorable-vars*) - (push-let-binding whole-var whole-var - :system t - :when `(not (eq 'funcall (car ,whole-var))) - ;; Do we need to SETF too? - :else `(setf ,whole-var (cdr ,whole-var)))) - (do ((rest-of-lambda-list lambda-list (cdr rest-of-lambda-list))) - ((null rest-of-lambda-list)) - (macrolet ((process-sublist (var kind path) - (once-only ((var var)) - `(if (listp ,var) - (let ((sublist-name (gensym ,kind))) - (push-sublist-binding sublist-name ,path ,var - name context error-fun) - (parse-defmacro-lambda-list ,var sublist-name name - context - :error-fun error-fun - :sublist t)) - (push-let-binding ,var ,path)))) - (normalize-singleton (var) - `(when (null (cdr ,var)) - (setf (cdr ,var) (list *default-default*))))) - (let ((var (car rest-of-lambda-list))) - (typecase var - (list - (case now-processing - ((:required) - (when restp - (defmacro-error (format nil "required argument after ~A" - restp) - context name)) - (process-sublist var "REQUIRED-" `(car ,path)) - (setq path `(cdr ,path) - minimum (1+ minimum) - maximum (1+ maximum))) - ((:optionals) - (normalize-singleton var) - (destructuring-bind - (varname &optional default-form suppliedp-name) - var - (push-optional-binding varname default-form suppliedp-name - :is-supplied-p `(not (null ,path)) - :path `(car ,path) - :name name - :context context - :error-fun error-fun)) - (setq path `(cdr ,path) - maximum (1+ maximum))) - ((:keywords) - (normalize-singleton var) - (let* ((keyword-given (consp (car var))) - (variable (if keyword-given - (cadar var) - (car var))) - (keyword (if keyword-given - (caar var) - (keywordicate variable))) - (default-form (cadr var)) - (suppliedp-name (caddr var))) - (push-optional-binding variable default-form suppliedp-name - :is-supplied-p - `(keyword-supplied-p ',keyword - ,rest-name) - :path - `(lookup-keyword ',keyword ,rest-name) - :name name - :context context - :error-fun error-fun) - (push keyword keys))) - ((:auxs) - (push-let-binding (car var) (cadr var))))) - ((and symbol (not (eql nil))) - (case var - (&whole - (cond ((cdr rest-of-lambda-list) - (pop rest-of-lambda-list) - (process-sublist (car rest-of-lambda-list) - "WHOLE-LIST-" - (if (eq 'define-compiler-macro context) - compiler-macro-whole - whole-var))) - (t - (defmacro-error "&WHOLE" context name)))) - (&environment - (cond (env-illegal - (error "&ENVIRONMENT is not valid with ~S." context)) - (sublist - (error "&ENVIRONMENT is only valid at top level of ~ - lambda-list.")) - (env-arg-used - (error "Repeated &ENVIRONMENT."))) - (cond ((and (cdr rest-of-lambda-list) - (symbolp (cadr rest-of-lambda-list))) - (setq rest-of-lambda-list (cdr rest-of-lambda-list)) - (check-defmacro-arg (car rest-of-lambda-list)) - (setq *env-var* (car rest-of-lambda-list) - env-arg-used t)) - (t - (defmacro-error "&ENVIRONMENT" context name)))) - ((&rest &body) - (cond ((or key-seen aux-seen) - (error "~A after ~A in ~A" - var (or key-seen aux-seen) context)) - ((and (not restp) (cdr rest-of-lambda-list)) - (setq rest-of-lambda-list (cdr rest-of-lambda-list) - restp var) - (process-sublist (car rest-of-lambda-list) - "REST-LIST-" path)) - (t - (defmacro-error (symbol-name var) context name)))) - (&optional - (when (or key-seen aux-seen restp) - (error "~A after ~A in ~A lambda-list." - var (or key-seen aux-seen restp) context)) - (when optional-seen - (error "Multiple ~A in ~A lambda list." var context)) - (setq now-processing :optionals - optional-seen var)) - (&key - (when aux-seen - (error "~A after ~A in ~A lambda-list." '&key '&aux context)) - (when key-seen - (error "Multiple ~A in ~A lambda-list." '&key context)) - (setf now-processing :keywords - rest-name (gensym "KEYWORDS-") - restp var - key-seen var) - (push rest-name *ignorable-vars*) - (push-let-binding rest-name path :system t)) - (&allow-other-keys - (unless (eq now-processing :keywords) - (error "~A outside ~A section of lambda-list in ~A." - var '&key context)) - (when allow-other-keys-p - (error "Multiple ~A in ~A lambda-list." var context)) - (setq allow-other-keys-p t)) - (&aux - (when (eq context 'defsetf) - (error "~A not allowed in a ~A lambda-list." var context)) - (when aux-seen - (error "Multiple ~A in ~A lambda-list." '&aux context)) - (setq now-processing :auxs - aux-seen var)) - ;; FIXME: Other lambda list keywords. - (t - (case now-processing - ((:required) - (when restp - (defmacro-error (format nil "required argument after ~A" - restp) - context name)) - (push-let-binding var `(car ,path)) - (setq minimum (1+ minimum) - maximum (1+ maximum) - path `(cdr ,path))) - ((:optionals) - (push-let-binding var `(car ,path) - :when `(not (null ,path))) - (setq path `(cdr ,path) - maximum (1+ maximum))) - ((:keywords) - (let ((key (keywordicate var))) - (push-let-binding - var - `(lookup-keyword ,key ,rest-name) - :when `(keyword-supplied-p ,key ,rest-name)) - (push key keys))) - ((:auxs) - (push-let-binding var nil)))))) - (t - (error "non-symbol in lambda-list: ~S" var)))))) - (let (;; common subexpression, suitable for passing to functions - ;; which expect a MAXIMUM argument regardless of whether - ;; there actually is a maximum number of arguments - ;; (expecting MAXIMUM=NIL when there is no maximum) - (explicit-maximum (and (not restp) maximum))) - (unless (and restp (zerop minimum)) - (push (let ((args-form (if (eq 'define-compiler-macro context) - `(if (eq 'funcall (car ,whole-var)) - (cdr ,path-0) - ,path-0) - path-0))) - (with-unique-names (args) - `(let ((,args ,args-form)) - (unless ,(if restp - ;; (If RESTP, then the argument list - ;; might be dotted, in which case - ;; ordinary LENGTH won't work.) - `(list-of-length-at-least-p ,args ,minimum) - `(proper-list-of-length-p ,args - ,minimum - ,maximum)) - ,(if (eq error-fun 'error) - `(arg-count-error ',context ',name ,args - ',lambda-list ,minimum - ,explicit-maximum) - `(,error-fun 'arg-count-error - :kind ',context - ,@(when name `(:name ',name)) - :args ,args - :lambda-list ',lambda-list - :minimum ,minimum - :maximum ,explicit-maximum)))))) - *arg-tests*)) - (when key-seen - (with-unique-names (problem info) - (push `(multiple-value-bind (,problem ,info) - (verify-keywords ,rest-name - ',keys - ',allow-other-keys-p - ,(eq 'define-compiler-macro context)) - (when ,problem - (,error-fun - 'defmacro-lambda-list-broken-key-list-error - :kind ',context - ,@(when name `(:name ',name)) - :problem ,problem - :info ,info))) - *arg-tests*))) - (values env-arg-used minimum explicit-maximum)))) - -;;; We save space in macro definitions by calling this function. -(defun arg-count-error (context name args lambda-list minimum maximum) - ;; Tail-call ERROR, contrary to usual behavior. - #-sb-xc-host (declare (optimize sb!c::allow-non-returning-tail-call)) - (error 'arg-count-error - :kind context - :name name - :args args - :lambda-list lambda-list - :minimum minimum - :maximum maximum)) - -(defun push-sublist-binding (variable path object name context error-fun) - (check-defmacro-arg variable) - (let ((var (gensym "TEMP-"))) - (push `(,variable - (let ((,var ,path)) - (if (listp ,var) - ,var - (,error-fun 'defmacro-bogus-sublist-error - :kind ',context - ,@(when name `(:name ',name)) - :object ,var - :lambda-list ',object)))) - *system-lets*))) - -(defun push-let-binding (variable form - &key system when (else *default-default*)) - (check-defmacro-arg variable) - (let ((let-form (if when - `(,variable (if ,when ,form ,else)) - `(,variable ,form)))) - (if system - (push let-form *system-lets*) - (push let-form *user-lets*)))) - -(defun push-optional-binding (value-var init-form suppliedp-name - &key is-supplied-p path name context error-fun) - (let ((sym (gensym "SUPPLIEDP-"))) - (push-let-binding sym is-supplied-p :system t) - (cond ((consp value-var) - (let ((whole-thing (gensym "OPTIONAL-SUBLIST-"))) - (push-sublist-binding whole-thing - `(if ,sym ,path ,init-form) - value-var name context error-fun) - (parse-defmacro-lambda-list value-var whole-thing name - context - :error-fun error-fun - :sublist t))) - ((symbolp value-var) - (push-let-binding value-var path :when sym :else init-form)) - (t - (error "Illegal optional variable name: ~S" value-var))) - ;; Shouldn't be bound during the initform evaluation - (when suppliedp-name - (push-let-binding suppliedp-name sym)))) - -(defun defmacro-error (problem context name) - (error "illegal or ill-formed ~A argument in ~A~@[ ~S~]" - problem context name)) - -(defun check-defmacro-arg (arg) - (when (or (and *env-var* (eq arg *env-var*)) - (member arg *system-lets* :key #'car) - (member arg *user-lets* :key #'car)) - (error "variable ~S occurs more than once" arg))) - -;;; Determine whether KEY-LIST is a valid list of keyword/value pairs. -;;; Do not signal the error directly, 'cause we don't know how it -;;; should be signaled. -(defun verify-keywords (key-list valid-keys allow-other-keys &optional compiler-macro) - (do ((already-processed nil) - (unknown-keyword nil) - (remaining key-list (cddr remaining))) - ((null remaining) - (if (and unknown-keyword - (not allow-other-keys) - (not (lookup-keyword :allow-other-keys key-list))) - (values :unknown-keyword (list unknown-keyword valid-keys)) - (values nil nil))) - (let ((key (when (consp remaining) - (car remaining)))) - (cond ((not (and (consp remaining) (listp (cdr remaining)))) - (return (values :dotted-list key-list))) - ((null (cdr remaining)) - (return (values :odd-length key-list)))) - ;; Compiler-macro lambda lists are macro lambda lists -- meaning that - ;; &key ((a a) t) should match a literal A, not a form evaluating to A - ;; as in an ordinary lambda list. - ;; - ;; That, however, breaks the evaluation model unless A is also a - ;; constant evaluating to itself. So, signal a condition telling the - ;; compiler to punt on the expansion. - (when (and compiler-macro - (not (or (keywordp key) - (and (symbolp key) - (constantp key) - (eq key (symbol-value key)))))) - (signal 'compiler-macro-keyword-problem :argument key)) - (cond ((or (eq key :allow-other-keys) - (member key valid-keys)) - (push key already-processed)) - (t - (setq unknown-keyword key)))))) - -(defun lookup-keyword (keyword key-list) - (do ((remaining key-list (cddr remaining))) - ((endp remaining)) - (when (eq keyword (car remaining)) - (return (cadr remaining))))) - -(defun keyword-supplied-p (keyword key-list) - (do ((remaining key-list (cddr remaining))) - ((endp remaining)) - (when (eq keyword (car remaining)) - (return t)))) diff --git a/src/compiler/parse-lambda-list.lisp b/src/compiler/parse-lambda-list.lisp index e6116b0..fededa8 100644 --- a/src/compiler/parse-lambda-list.lisp +++ b/src/compiler/parse-lambda-list.lisp @@ -78,9 +78,6 @@ ;;; This is possibly surprising to people since there seems to be some ;;; expectation that a DEFSETF lambda list is a macro lambda list, ;;; which it isn't. We'll relax and accept &ENVIRONMENT in the middle. -;;; But we won't accept the ugly syntax that parse-defmacro accidentally -;;; allows of (A B &ENVIRONMENT E X Y) which has 4 positional parameters. -;;; Nor can it appear between &KEY and &ALLOW-OTHER-KEYS. ;;; (defun parse-lambda-list (list &key (context "an ordinary lambda list") @@ -1066,7 +1063,8 @@ ;; Signal a style warning for duplicate names, but disregard &AUX variables ;; because most folks agree that (LET* ((X (F)) (X (G X))) ..) makes sense ;; - some would even say that it is idiomatic - and &AUX bindings are just - ;; LET* bindings. PARSE-DEFMACRO signals an error, but that seems harsh. + ;; LET* bindings. + ;; The obsolete PARSE-DEFMACRO signaled an error, but that seems harsh. ;; Other implementations permit (X &OPTIONAL X), and the fact that ;; nesting is allowed makes this issue even less clear. (mapl (lambda (tail) @@ -1094,4 +1092,24 @@ (unparse-ds-lambda-list parse) docstring))) +;;; We save space in macro definitions by calling this function. +;;; FIXME: that consideration no longer seems relevant +;;; given how macros expand now - they don't call this at all. +;;; And the SB!KERNEL versus SB!C issue is pretty dang confusing +;;; (the SB!C thing is a vop) so if nothing else, this deserves +;;; to be renamed. +(defun sb!kernel::arg-count-error + (context name args lambda-list minimum maximum) + ;; Tail-call ERROR, contrary to usual behavior. + #-sb-xc-host (declare (optimize sb!c::allow-non-returning-tail-call)) + ;; And why isn't the condition class name an exported symbol? + ;; Perhaps to avoid conflict with the one exported from SB-C. + (error 'sb!kernel::arg-count-error + :kind context + :name name + :args args + :lambda-list lambda-list + :minimum minimum + :maximum maximum)) + (/show0 "parse-lambda-list.lisp end of file") diff --git a/src/pcl/defcombin.lisp b/src/pcl/defcombin.lisp index 62e5eae..9b3f46b 100644 --- a/src/pcl/defcombin.lisp +++ b/src/pcl/defcombin.lisp @@ -436,7 +436,7 @@ ;;; option are bound to the symbols in the intercept lambda list. ;;; ;;; FIXME: in here we have not one but two mini-copies of a weird -;;; hybrid of PARSE-LAMBDA-LIST and PARSE-DEFMACRO-LAMBDA-LIST. +;;; hybrid of PARSE-LAMBDA-LIST and (obsolete) PARSE-DEFMACRO-LAMBDA-LIST. (defun deal-with-args-option (wrapped-body args-lambda-list) (let ((intercept-rebindings (let (rebindings) diff --git a/tests/lambda-list.pure.lisp b/tests/lambda-list.pure.lisp index 785a9d9..7dfb1a0 100644 --- a/tests/lambda-list.pure.lisp +++ b/tests/lambda-list.pure.lisp @@ -236,7 +236,7 @@ (cdr (parse '(a b c &environment foo . rest))))) (assert-error (parse '(a b c &environment foo &rest r . rest))) - ;; lp# 707556 will be fixed once PARSE-DEFMACRO uses PARSE-LAMBDA-LIST + ;; lp# 707556 (assert-error (parse '(a &key b &allow-other-keys c))))) (with-test (:name :ds-lambda-list-symbols) diff --git a/tests/macroexpand.impure.lisp b/tests/macroexpand.impure.lisp index 5e1a769..d75e30e 100644 --- a/tests/macroexpand.impure.lisp +++ b/tests/macroexpand.impure.lisp @@ -190,7 +190,8 @@ (assert-error (macroexpand-1 '(defsetf foof (a b &optional k &aux) (v1 v2) (forms)))) - ;; 3.4.8 - DEFTYPE currently uses parse-defmacro + ;; 3.4.8 - DEFTYPE is exactly like DEFMACRO + ;; except for the implied default-default of '* ;; 3.4.9 - DEFINE-MODIFY-MACRO allows only &OPTIONAL and &REST (assert-error (macroexpand-1 ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2015-07-02 18:16:49
|
The branch "master" has been updated in SBCL: via 07338b735fb3aa0c2770a29ba4520bcd73f45d02 (commit) from a86cac2825c24fc8f2c3bd01f7d0860bb71512c7 (commit) - Log ----------------------------------------------------------------- commit 07338b735fb3aa0c2770a29ba4520bcd73f45d02 Author: Douglas Katzman <do...@go...> Date: Thu Jul 2 14:15:55 2015 -0400 Remove last use of PARSE-DEFMACRO. The interpreter rolled its own variation of DS-BIND, for better or worse. Moreover it rolled its own MAKE-MACRO-LAMBDA (effectively). There should be no difference between how the innards of a macro look, whether that macro came from the compiler or interpreter, so EVAL-LOCAL-MACRO-DEF uses MAKE-MACRO-LAMBDA directly. The only thing preventing deletion of 'parse-defmacro' is defining ARG-COUNT-ERROR somewhere else. --- NEWS | 3 + src/code/full-eval.lisp | 92 ++++++++++++----------------------- src/code/parse-defmacro-errors.lisp | 2 + src/compiler/parse-lambda-list.lisp | 33 +++++++++---- 4 files changed, 59 insertions(+), 71 deletions(-) diff --git a/NEWS b/NEWS index 821459f..f341294 100644 --- a/NEWS +++ b/NEWS @@ -2,6 +2,9 @@ changes relative to sbcl-1.2.13: * DESTRUCTURING-BIND has been totally reimplemented from scratch to address a handful of performance and correctness issues. + Some minor behavioral differences exist regarding order of evaluation + of default forms for unsupplied &OPTIONAL and &KEY arguments + when nested destructuring patterns are involved. (lp#707556, lp#707573, lp#707578, lp#708051) changes in sbcl-1.2.13 relative to sbcl-1.2.12: diff --git a/src/code/full-eval.lisp b/src/code/full-eval.lisp index 133717f..c6075ea 100644 --- a/src/code/full-eval.lisp +++ b/src/code/full-eval.lisp @@ -36,23 +36,36 @@ program-error) ()) -(defun arg-count-program-error (datum &rest arguments) - (declare (ignore datum)) - (apply #'error 'arg-count-program-error arguments)) +;;; FIXME: This macro is not clearly better than plain destructuring-bind. +;;; +;;; First of all, it's ridiculous that the error message says +;;; "error while parsing arguments to PROGRAM-DESTRUCTURING-BIND". +;;; The user doesn't care what the macro was that parsed the arguments +;;; to the special operator. It should instead say +;;; "... while parsing arguments to special operator <foo>" +;;; +;;; Second, it is naive to think that existence of this macro suffices +;;; to always signal an INTEPRETED-PROGRAM-ERROR and not just ERROR. +;;; e.g. (LET ((X 1)) . JUNK) binds the &BODY variable to the non-list JUNK. +;;; To fix the general problem, every use of DOLIST and other things +;;; would have to be replaced by something like SB-PCL::DOLIST-CAREFULLY. +;;; Similarly for ((&REST BINDINGS) &BODY BODY) wherein it's not even +;;; obvious that BINDINGS is enforced by the macro to be a list. [lp#1469275] ;; OAOOM? (see destructuring-bind.lisp) (defmacro program-destructuring-bind (lambda-list arg-list &body body) - (let ((arg-list-name (gensym "ARG-LIST-"))) - (multiple-value-bind (body local-decls) - (parse-defmacro lambda-list arg-list-name body nil - 'program-destructuring-bind - :anonymousp t - :doc-string-allowed nil - :wrap-block nil - :error-fun 'arg-count-program-error) - `(let ((,arg-list-name ,arg-list)) - ,@local-decls - ,body)))) + ;; Not wrapping ARG-LIST in (THE LIST) is better than what DESTRUCTURING-BIND + ;; does, because this gives a more descriptive message if you pass a non-list + ;; to the form handler, like (IF . 3) will say that 3 does not match the + ;; list (TEST IF-TRUE &OPTIONAL IF-FALSE) rather than just "3 is not a list". + ;; For the sake of compatibility, DESTRUCTURING-BIND signals TYPE-ERROR + ;; in that situation, which is less than ideal. + ;; + ;; (:EVAL) is a dummy context. We don't have enough information to + ;; show the operator name without using debugger internals to get the stack frame. + ;; It would be easier to make the name an argument to this macro. + `(sb!int:binding* ,(sb!c::expand-ds-bind lambda-list arg-list t nil '(:eval)) + ,@body)) (defun ip-error (format-control &rest format-arguments) (error 'interpreted-program-error @@ -725,53 +738,10 @@ ;; definition form FUNCTION-DEF. (defun eval-local-macro-def (function-def env) (program-destructuring-bind (name lambda-list &body local-body) function-def - (multiple-value-bind (local-body documentation declarations) - (parse-lambda-headers local-body :doc-string-allowed t) - ;; HAS-ENVIRONMENT and HAS-WHOLE will be either NIL or the name - ;; of the variable. (Better names?) - (let (has-environment has-whole) - ;; Filter out &WHOLE and &ENVIRONMENT from the lambda-list, and - ;; do some syntax checking. - (when (eq (car lambda-list) '&whole) - (setf has-whole (second lambda-list)) - (setf lambda-list (cddr lambda-list))) - (setf lambda-list - (loop with skip = 0 - for element in lambda-list - if (cond - ((/= skip 0) - (decf skip) - (setf has-environment element) - nil) - ((eq element '&environment) - (if has-environment - (ip-error "Repeated &ENVIRONMENT.") - (setf skip 1)) - nil) - ((eq element '&whole) - (ip-error "&WHOLE may only appear first ~ - in MACROLET lambda-list.")) - (t t)) - collect element)) - (let ((outer-whole (gensym "WHOLE")) - (environment (or has-environment (gensym "ENVIRONMENT"))) - (macro-name (gensym "NAME"))) - (%eval `#'(lambda (,outer-whole ,environment) - ,@(if documentation - (list documentation) - nil) - (declare ,@(unless has-environment - `((ignore ,environment)))) - (program-destructuring-bind - (,@(if has-whole - (list '&whole has-whole) - nil) - ,macro-name ,@lambda-list) - ,outer-whole - (declare (ignore ,macro-name) - ,@declarations) - (block ,name ,@local-body))) - env)))))) + (%eval (sb!int:make-macro-lambda nil ; the lambda is anonymous. + lambda-list local-body + 'macrolet name) + env))) (defun eval-macrolet (body env) (program-destructuring-bind ((&rest local-functions) &body body) body diff --git a/src/code/parse-defmacro-errors.lisp b/src/code/parse-defmacro-errors.lisp index 7b2932b..ece99d0 100644 --- a/src/code/parse-defmacro-errors.lisp +++ b/src/code/parse-defmacro-errors.lisp @@ -41,6 +41,8 @@ (pprint-logical-block (stream nil) (funcall fun stream)))) +;;; FIXME: This is not an exported symbol, so it can probably be removed, +;;; since nothing signals the condition afaict. (define-condition defmacro-bogus-sublist-error (defmacro-lambda-list-bind-error) ((object :reader defmacro-bogus-sublist-error-object :initarg :object) diff --git a/src/compiler/parse-lambda-list.lisp b/src/compiler/parse-lambda-list.lisp index 69294bc..e6116b0 100644 --- a/src/compiler/parse-lambda-list.lisp +++ b/src/compiler/parse-lambda-list.lisp @@ -816,6 +816,8 @@ (values (car context) (cdr context) (cdr pattern)))) (:special-form (values (cdr marker) :special-form (cdr pattern))) + (:eval + (values nil :eval (cdr pattern))) (t (values nil 'destructuring-bind pattern))))) @@ -852,16 +854,27 @@ ;; changes how DS-BIND has to expand. `(multiple-value-bind (name kind lambda-list) (get-ds-bind-context ,pattern) - (if (eq kind :special-form) - (compiler-error 'sb!kernel::arg-count-error - :kind "special form" - :name name - :args input - :lambda-list lambda-list - :minimum min - :maximum ,effective-max) - (sb!kernel::arg-count-error - kind name input lambda-list min ,effective-max))))) + (case kind + (:special-form + (compiler-error 'sb!kernel::arg-count-error + :kind "special operator" + :name name + :args input + :lambda-list lambda-list + :minimum min + :maximum ,effective-max)) + (:eval + (error 'sb!eval::arg-count-program-error + ;; This is stupid. Maybe we should just say + ;; "error parsing special form"? + ;; It would be more sensible than mentioning + ;; a random nonstandard macro. + :kind 'sb!eval::program-destructuring-bind + :args input :lambda-list lambda-list + :minimum min :maximum ,effective-max)) + (t + (sb!kernel::arg-count-error + kind name input lambda-list min ,effective-max)))))) ;; Assert that INPUT has the requisite number of elements as ;; specified by MIN/MAX. PATTERN does not contain &REST or &KEY. ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2015-07-02 08:59:22
|
The branch "master" has been updated in SBCL: via a86cac2825c24fc8f2c3bd01f7d0860bb71512c7 (commit) from d15c0aba3919197253508c84adf3c1cb5aa0ff8b (commit) - Log ----------------------------------------------------------------- commit a86cac2825c24fc8f2c3bd01f7d0860bb71512c7 Author: Douglas Katzman <do...@go...> Date: Thu Jul 2 04:56:43 2015 -0400 Change all but 1 last use of PARSE-DEFMACRO to MAKE-MACRO-LAMBDA. --- NEWS | 5 +++++ contrib/sb-cltl2/env.lisp | 10 ++-------- src/code/defmacro.lisp | 26 ++++++-------------------- src/code/destructuring-bind.lisp | 19 +++++++------------ src/compiler/parse-lambda-list.lisp | 6 +++--- tests/lambda-list.pure.lisp | 4 ++-- 6 files changed, 25 insertions(+), 45 deletions(-) diff --git a/NEWS b/NEWS index 3c1da8a..821459f 100644 --- a/NEWS +++ b/NEWS @@ -1,4 +1,9 @@ ;;;; -*- coding: utf-8; fill-column: 78 -*- +changes relative to sbcl-1.2.13: + * DESTRUCTURING-BIND has been totally reimplemented from scratch + to address a handful of performance and correctness issues. + (lp#707556, lp#707573, lp#707578, lp#708051) + changes in sbcl-1.2.13 relative to sbcl-1.2.12: * incompatible change: on success, TRY-SEMAPHORE and WAIT-ON-SEMAPHORE return the new count diff --git a/contrib/sb-cltl2/env.lisp b/contrib/sb-cltl2/env.lisp index 7f3cadc..4327e86 100644 --- a/contrib/sb-cltl2/env.lisp +++ b/contrib/sb-cltl2/env.lisp @@ -407,14 +407,8 @@ lambda expression will parse its form argument, binding the variables in LAMBDA-LIST appropriately, and then execute BODY with those bindings in effect." (declare (ignore env)) - (with-unique-names (whole environment) - (multiple-value-bind (body decls) - (parse-defmacro lambda-list whole body name - 'parse-macro - :environment environment) - `(lambda (,whole ,environment) - ,@decls - ,body)))) + (make-macro-lambda (if (and name (symbolp name)) (string name) "PARSE-MACRO") + lambda-list body 'parse-macro name)) (defun enclose (lambda-expression &optional environment) "Return a function consistent with LAMBDA-EXPRESSION in ENVIRONMENT: the diff --git a/src/code/defmacro.lisp b/src/code/defmacro.lisp index b3fa89a..49557be 100644 --- a/src/code/defmacro.lisp +++ b/src/code/defmacro.lisp @@ -31,25 +31,11 @@ (when (special-operator-p name) (error "The special operator ~S can't be redefined as a macro." name)) - (let ((whole (make-symbol ".WHOLE.")) - (environment (make-symbol ".ENVIRONMENT."))) - (multiple-value-bind (new-body local-decs doc) - (parse-defmacro lambda-list whole body name 'defmacro - :environment environment) - (let ((def ;; Use a named-lambda rather than a lambda so that - ;; proper xref information can be stored. Use a - ;; list-based name, since otherwise the compiler - ;; will momentarily assume that it names a normal - ;; function, and report spurious warnings about - ;; redefinition a macro as a function, and then - ;; vice versa. - `(named-lambda ,(sb!c::debug-name 'macro-function name) - (,whole ,environment) - ,@(when doc (list doc)) - ,@(sb!c:macro-policy-decls) - ,@local-decs - ,new-body))) - `(progn + ;; The name of the lambda is (MACRO-FUNCTION name) + ;; which does not conflict with any legal function name. + (let ((def (make-macro-lambda (sb!c::debug-name 'macro-function name) + lambda-list body 'defmacro name))) + `(progn #-sb-xc-host ;; Getting this to cross-compile with the check enabled ;; would require %COMPILER-DEFMACRO to be defined earlier, @@ -59,7 +45,7 @@ (sb!c::%compiler-defmacro :macro-function ',name t)) (eval-when (:compile-toplevel :load-toplevel :execute) (sb!c::%defmacro ',name ,def ',lambda-list - (sb!c:source-location))))))))) + (sb!c:source-location))))))) (macrolet ((def (times set-p) diff --git a/src/code/destructuring-bind.lisp b/src/code/destructuring-bind.lisp index c485b75..d6cbbb0 100644 --- a/src/code/destructuring-bind.lisp +++ b/src/code/destructuring-bind.lisp @@ -13,15 +13,10 @@ #!+sb-doc "Bind the variables in LAMBDA-LIST to the corresponding values in the tree structure resulting from the evaluation of EXPRESSION." - (let ((whole-name (gensym "WHOLE"))) - (multiple-value-bind (body local-decls) - (parse-defmacro lambda-list whole-name body nil 'destructuring-bind - :anonymousp t - :doc-string-allowed nil - :wrap-block nil) - `(let ((,whole-name ,expression)) - ;; This declaration-as-assertion should protect us from - ;; (DESTRUCTURING-BIND (X . Y) 'NOT-A-LIST ...). - (declare (type list ,whole-name)) - ,@local-decls - ,body)))) + ;; (THE LIST ...) is not really right, because it means that + ;; the descriptive message about the lambda list won't be shown. + ;; It'll just be type-error. + `(binding* ,(sb!c::expand-ds-bind lambda-list + `(the list ,expression) + t nil) + ,@body)) diff --git a/src/compiler/parse-lambda-list.lisp b/src/compiler/parse-lambda-list.lisp index 678f007..69294bc 100644 --- a/src/compiler/parse-lambda-list.lisp +++ b/src/compiler/parse-lambda-list.lisp @@ -887,7 +887,7 @@ ;; the keys are - &ALLOW-OTHER-KEYS was present in the lambda-list, ;; and we don't care if non-symbols are found in keyword position. ;; We always enforce that the list is not odd-length though. - (flet ((check-plist (input plist valid-keys pattern) + (defun check-plist (input plist valid-keys pattern) (let ((list plist) seen-allowp seen-other bad-key) (flet ((validp (key) (find key (truly-the simple-vector valid-keys) :test 'eq)) @@ -919,7 +919,7 @@ (setf seen-allowp t)) (when (and (not seen-other) (not (validp key))) (setq seen-other t bad-key key))))) - (setq list (cdr next)))))))) + (setq list (cdr next))))))) ;; The pattern contains &KEY. Anything beyond the final optional arg ;; must be a well-formed property list regardless of existence of &REST. @@ -972,7 +972,7 @@ :if-list-exhausted input :if-max-reached (progn (require-constant-keys list) (check-plist input list valid-keys - pattern))))))) + pattern)))))) ;; Like GETF but return CDR of the cell whose CAR contained the found key, ;; instead of CADR; and return 0 for not found. diff --git a/tests/lambda-list.pure.lisp b/tests/lambda-list.pure.lisp index 9e03dea..785a9d9 100644 --- a/tests/lambda-list.pure.lisp +++ b/tests/lambda-list.pure.lisp @@ -241,7 +241,7 @@ (with-test (:name :ds-lambda-list-symbols) (flet ((try (list expect) - (assert (equal sb-c::(ds-lambda-list-symbols + (assert (equal sb-c::(ds-lambda-list-variables (parse-ds-lambda-list list)) expect)))) (try '(a ((b c)) @@ -296,7 +296,7 @@ (lambda (args) (sb-int:binding* ,(sb-c::expand-ds-bind lambda-list 'args nil 'the) - (list ,@(sb-c::ds-lambda-list-symbols + (list ,@(sb-c::ds-lambda-list-variables (sb-c::parse-ds-lambda-list lambda-list)))))) (ast (sb-c::meta-abstractify-ds-lambda-list (sb-c::parse-ds-lambda-list ',lambda-list)))) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2015-07-02 07:42:26
|
The branch "master" has been updated in SBCL: via d15c0aba3919197253508c84adf3c1cb5aa0ff8b (commit) from b4622386a3f0ceecc0d8d62c9ef84b79014837c7 (commit) - Log ----------------------------------------------------------------- commit d15c0aba3919197253508c84adf3c1cb5aa0ff8b Author: Douglas Katzman <do...@go...> Date: Thu Jul 2 02:12:52 2015 -0400 Change MACROLET IR1 translator to use MAKE-MACRO-LAMBDA There is a minor discrepancy in whether repetition of variables in a destructuring lambda list is permitted. MAKE-MACRO-LAMBDA allows it but PARSE-DEFMACRO does not, which is slightly wrong at least according to a quick survey of other implementations, most of which permit (X &REST X), though in some cases you'll get a warning about non-use of the earlier X. When everything has been converted to MAKE-MACRO-LAMBDA we should add a NEWS entry documenting the relaxed stance. --- src/compiler/ir1-translators.lisp | 17 +++++------------ src/compiler/parse-lambda-list.lisp | 29 ++++++++++++++++++++++------- tests/compiler.pure.lisp | 6 +++++- 3 files changed, 32 insertions(+), 20 deletions(-) diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index 5a44261..c71443b 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -330,18 +330,11 @@ Evaluate the FORMS in the specified SITUATIONS (any of :COMPILE-TOPLEVEL, (unless (listp arglist) (fail "The local macro argument list ~S is not a list." arglist)) - (with-unique-names (whole environment) - (multiple-value-bind (body local-decls) - (parse-defmacro arglist whole body name 'macrolet - :environment environment) - `(,name macro . - ,(compile-in-lexenv - nil - `(lambda (,whole ,environment) - ,@(macro-policy-decls) - ,@local-decls - ,body) - lexenv)))))))) + `(,name macro . + ,(compile-in-lexenv + nil + (make-macro-lambda nil arglist body 'macrolet name) + lexenv)))))) (defun funcall-in-macrolet-lexenv (definitions fun context) (%funcall-in-foomacrolet-lexenv diff --git a/src/compiler/parse-lambda-list.lisp b/src/compiler/parse-lambda-list.lisp index 51b78d4..678f007 100644 --- a/src/compiler/parse-lambda-list.lisp +++ b/src/compiler/parse-lambda-list.lisp @@ -325,11 +325,14 @@ ;;; - a &REST arg that destructures preceded by any optional args. ;;; It's suspicious because if &REST destructures, then in essence it ;;; must not be NIL, which means the optionals aren't really optional. -(defun parse-ds-lambda-list (lambda-list &key silent) +(defun parse-ds-lambda-list (lambda-list + &key silent + (condition-class 'simple-program-error)) (multiple-value-bind (llks required optional rest keys aux env whole) (parse-lambda-list lambda-list :accept (lambda-list-keyword-mask 'destructuring-bind) - :silent silent :context 'destructuring-bind) + :context 'destructuring-bind + :silent silent :condition-class condition-class) (declare (ignore env) (notinline mapcar)) (labels ((parse (list) (if (atom list) list (parse-ds-lambda-list list :silent silent))) @@ -521,7 +524,7 @@ (t (error "Excess args"))))) (doer)) |# -(defun ds-lambda-list-symbols (parsed-lambda-list) +(defun ds-lambda-list-variables (parsed-lambda-list &optional (include-aux t)) (collect ((output)) (labels ((recurse (x) (if (vectorp x) (scan x) (output x))) (copy (x) (dolist (elt x) (recurse elt))) @@ -540,8 +543,9 @@ (t (let ((k (car x))) (if (symbolp k) (output k) (recurse (cadr k))) (suppliedp-var x))))) - (dolist (x aux) - (output (if (symbolp x) x (car x))))))) + (when include-aux + (dolist (x aux) + (output (if (symbolp x) x (car x)))))))) (recurse parsed-lambda-list) (output)))) @@ -1043,8 +1047,19 @@ (when whole `((,(car whole) ,ll-whole))))) ;; Drop &WHOLE and &ENVIRONMENT (new-ll (make-lambda-list llks nil req opt rest keys aux)) + (parse (parse-ds-lambda-list new-ll)) (arg-accessor (if (eq kind 'define-compiler-macro) 'compiler-macro-args 'cdr))) + ;; Signal a style warning for duplicate names, but disregard &AUX variables + ;; because most folks agree that (LET* ((X (F)) (X (G X))) ..) makes sense + ;; - some would even say that it is idiomatic - and &AUX bindings are just + ;; LET* bindings. PARSE-DEFMACRO signals an error, but that seems harsh. + ;; Other implementations permit (X &OPTIONAL X), and the fact that + ;; nesting is allowed makes this issue even less clear. + (mapl (lambda (tail) + (when (memq (car tail) (cdr tail)) + (style-warn "variable ~S occurs more than once" (car tail)))) + (append whole env (ds-lambda-list-variables parse nil))) (values `(,@(if lambda-name `(named-lambda ,lambda-name) '(lambda)) (,ll-whole ,@ll-env ,@(and ll-aux (cons '&aux ll-aux))) ,@(when (and docstring (eq doc-string-allowed :internal)) @@ -1062,8 +1077,8 @@ ,@(if wrap-block `((block ,(fun-name-block-name name) ,@forms)) forms))) - ;; Normalize the lambda list by parsing and unparsing. - (unparse-ds-lambda-list (parse-ds-lambda-list new-ll)) + ;; Normalize the lambda list by unparsing. + (unparse-ds-lambda-list parse) docstring))) (/show0 "parse-lambda-list.lisp end of file") diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 7be86dc..26a1777 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -464,6 +464,9 @@ (x &key (y nil x)) (&key (y nil z) (z nil w)) (&whole x &optional x) + ;; Uh, this test is semi-bogus - it's trying to test that + ;; you can't repeat, but it's now actually testing that + ;; &WHOLE has to appear first, per the formal spec. (&environment x &whole x))) (assert (nth-value 2 (handler-case @@ -473,7 +476,8 @@ (bar (&environment env) `',(macro-function 'foo env))) (bar)))) - (error (c) + ((or warning error) (c) + (declare (ignore c)) (values nil t t)))))) (assert (typep (eval `(the arithmetic-error ----------------------------------------------------------------------- hooks/post-receive -- SBCL |
From: Douglas K. <sn...@us...> - 2015-07-02 00:50:20
|
The branch "master" has been updated in SBCL: via b4622386a3f0ceecc0d8d62c9ef84b79014837c7 (commit) from 751ca661b8fffcc271e90d2d1869c28dc3646808 (commit) - Log ----------------------------------------------------------------- commit b4622386a3f0ceecc0d8d62c9ef84b79014837c7 Author: Douglas Katzman <do...@go...> Date: Wed Jul 1 20:45:19 2015 -0400 Additional optimization to uses of *{CL|KEYWORD|PCL}-PACKAGE* --- src/code/function-names.lisp | 2 +- src/code/primordial-extensions.lisp | 21 ++++++++++++--------- src/compiler/fopcompile.lisp | 4 +++- src/compiler/generic/genesis.lisp | 23 +++++++++++------------ src/compiler/globaldb.lisp | 2 +- src/compiler/main.lisp | 33 +++++++++++++++++++++------------ src/pcl/early-low.lisp | 17 +++-------------- 7 files changed, 52 insertions(+), 50 deletions(-) diff --git a/src/code/function-names.lisp b/src/code/function-names.lisp index 5a9accf..644be98 100644 --- a/src/code/function-names.lisp +++ b/src/code/function-names.lisp @@ -11,7 +11,7 @@ (acons symbol checker *valid-fun-names-alist*))))) #+sb-xc-host -(setf (get '%define-fun-name-syntax :sb-cold-funcall-handler) +(setf (get '%define-fun-name-syntax :sb-cold-funcall-handler/for-effect) (lambda (symbol checker) (sb!fasl::target-push (sb!fasl::cold-cons (sb!fasl::cold-intern symbol) checker) diff --git a/src/code/primordial-extensions.lisp b/src/code/primordial-extensions.lisp index 29819d1..50614eb 100644 --- a/src/code/primordial-extensions.lisp +++ b/src/code/primordial-extensions.lisp @@ -152,15 +152,18 @@ ;;; Lots of code wants to get to the KEYWORD package or the ;;; COMMON-LISP package without a lot of fuss, so we cache them in -;;; variables. TO DO: How much does this actually buy us? It sounds -;;; sensible, but I don't know for sure that it saves space or time.. -;;; -- WHN 19990521 -;;; -;;; (The initialization forms here only matter on the cross-compilation -;;; host; In the target SBCL, these variables are set in cold init.) -(declaim (type package *cl-package* *keyword-package*)) -(defglobal *cl-package* (find-package "COMMON-LISP")) -(defglobal *keyword-package* (find-package "KEYWORD")) +;;; variables on the host, or use L-T-V forms on the target. +(macrolet ((def-it (sym expr) + #+sb-xc-host + `(progn (declaim (type package ,sym)) + (defglobal ,sym ,expr)) + #-sb-xc-host + ;; We don't need to declaim the type. FIND-PACKAGE + ;; returns a package, and L-T-V propagates types. + ;; It's ugly how it achieves that, but it's a separate concern. + `(define-symbol-macro ,sym (load-time-value ,expr t)))) + (def-it *cl-package* (find-package "COMMON-LISP")) + (def-it *keyword-package* (find-package "KEYWORD"))) ;;; Concatenate together the names of some strings and symbols, ;;; producing a symbol in the current package. diff --git a/src/compiler/fopcompile.lisp b/src/compiler/fopcompile.lisp index 815c19c..e117ba4 100644 --- a/src/compiler/fopcompile.lisp +++ b/src/compiler/fopcompile.lisp @@ -83,7 +83,9 @@ sb!impl::%defsetf sb!kernel::%defstruct)) (and (symbolp function) ; no ((lambda ...) ...) - (not (null (get function :sb-cold-funcall-handler)))) + (get-properties (symbol-plist function) + '(:sb-cold-funcall-handler/for-effect + :sb-cold-funcall-handler/for-value))) (and (eq function 'setf) (fopcompilable-p (%macroexpand form *lexenv*))) (and (eq function 'sb!kernel:%svset) diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 8c7d8a4..7d295b5 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -1102,6 +1102,11 @@ core and return a descriptor to it." (defvar *cold-package-symbols*) (declaim (type hash-table *cold-package-symbols*)) +(setf (get 'find-package :sb-cold-funcall-handler/for-value) + (lambda (descriptor &aux (name (base-string-from-core descriptor))) + (or (car (gethash name *cold-package-symbols*)) + (error "Genesis could not find a target package named ~S" name)))) + ;;; a map from descriptors to symbols, so that we can back up. The key ;;; is the address in the target core. (defvar *cold-symbols*) @@ -1153,12 +1158,6 @@ core and return a descriptor to it." (dolist (pd package-data-list) (init-cold-package (sb-cold:package-data-name pd) #!+sb-doc(sb-cold::package-data-doc pd))) - ;; MISMATCH needs !HAIRY-DATA-VECTOR-REFFER-INIT to have been done, - ;; and FIND-PACKAGE calls MISMATCH - which it shouldn't - but until - ;; that is fixed, doing this in genesis allows packages to be - ;; completely sane, modulo the naming, extremely early in cold-init. - (cold-set '*keyword-package* (find-cold-package "KEYWORD")) - (cold-set '*cl-package* (find-cold-package "COMMON-LISP")) ;; pass 2: set the 'use' lists and collect the 'used-by' lists (dolist (pd package-data-list) (let ((this (find-cold-package (sb-cold:package-data-name pd))) @@ -2497,7 +2496,10 @@ core and return a descriptor to it." (stack (%fasl-input-stack fasl-input))) (dotimes (i (read-byte-arg (%fasl-input-stream fasl-input)) (values (pop-fop-stack stack) args)) - (push (pop-fop-stack stack) args))))) + (push (pop-fop-stack stack) args)))) + (call (fun-name handler-name args) + (acond ((get fun-name handler-name) (apply it args)) + (t (error "Can't ~S ~S in cold load" handler-name fun-name))))) (define-cold-fop (fop-funcall) (multiple-value-bind (fun args) (pop-args (fasl-input)) @@ -2509,8 +2511,7 @@ core and return a descriptor to it." (target-symbol-function (car args))) (cons (cold-cons (first args) (second args))) (symbol-global-value (cold-symbol-value (first args))) - (t - (error "Can't FUNCALL ~S in cold load" fun))) + (t (call fun :sb-cold-funcall-handler/for-value args))) (let ((counter *load-time-value-counter*)) (cold-push (cold-list (cold-intern :load-time-value) fun (number-to-core counter)) @@ -2537,9 +2538,7 @@ core and return a descriptor to it." (let ((val (second args))) (if (symbolp val) (cold-intern val) val)))) (%svset (apply 'cold-svset args)) - (t (acond ((get fun :sb-cold-funcall-handler) (apply it args)) - (t (error "Can't FUNCALL-FOR-EFFECT ~S in cold load" - fun))))))))) + (t (call fun :sb-cold-funcall-handler/for-effect args))))))) (defun finalize-load-time-value-noise () (cold-set '*!load-time-values* diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp index b2fdbc3..8011ba8 100644 --- a/src/compiler/globaldb.lisp +++ b/src/compiler/globaldb.lisp @@ -126,7 +126,7 @@ ) ; EVAL-WHEN #-sb-xc -(setf (get '!%define-info-type :sb-cold-funcall-handler) +(setf (get '!%define-info-type :sb-cold-funcall-handler/for-effect) (lambda (category kind type-spec checker validator default id) ;; The SB!FASL: symbols are poor style, but the lesser evil. ;; If exported, then they'll stick around in the target image. diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index cce159b..45a8356 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -1497,18 +1497,27 @@ necessary, since type inference may take arbitrarily long to converge.") ;;; Compile FORM and arrange for it to be called at load-time. Return ;;; the dumper handle and our best guess at the type of the object. (defun compile-load-time-value (form) - ;; Special case for the cross-compiler. While the normal ltv stuff is fine - ;; for the most part, it is inadequate for SETUP-PRINTER-STATE. - ;; In cold-init we want the printer to work before regular ltv forms are run, - ;; so this is fop-based magic, slightly dangerous in that it can produce a - ;; use of #'F before the referenced function has been defined. - ;; Just be careful not to do that. - #+sb-xc-host - (when (typep form '(cons (eql function) (cons symbol null))) - (fopcompile form nil t) - (return-from compile-load-time-value - (values (sb!fasl::dump-pop *compile-object*) - (specifier-type 'function)))) + (let ((ctype + (cond + ;; Ideally any ltv would test FOPCOMPILABLE-P on its form, + ;; but be that as it may, this case is picked off because of + ;; its importance during cross-compilation to ensure that + ;; compiled lambdas don't cause a chicken-and-egg problem. + ((typep form '(cons (eql find-package) (cons string null))) + (specifier-type 'package)) + ;; Special case for the cross-compiler, necessary for at least + ;; SETUP-PRINTER-STATE, but also anything that would be dumped + ;; using FOP-KNOWN-FUN in the target compiler, to avoid going + ;; through an fdefn. + ;; I'm pretty sure that as of change 00298ec6, it works to + ;; compile #'F before the defun would have been seen by Genesis. + #+sb-xc-host + ((typep form '(cons (eql function) (cons symbol null))) + (specifier-type 'function))))) + (when ctype + (fopcompile form nil t) + (return-from compile-load-time-value + (values (sb!fasl::dump-pop *compile-object*) ctype)))) (let ((lambda (compile-load-time-stuff form t))) (values (fasl-dump-load-time-value-lambda lambda *compile-object*) diff --git a/src/pcl/early-low.lisp b/src/pcl/early-low.lisp index 425510f..2f0e989 100644 --- a/src/pcl/early-low.lisp +++ b/src/pcl/early-low.lisp @@ -28,21 +28,10 @@ (/show "starting early-low.lisp") -;;; FIXME: The PCL package is internal and is used by code in potential -;;; bottlenecks. Access to it might be faster through #.(find-package "SB-PCL") -;;; than through *PCL-PACKAGE*. And since it's internal, no one should be +;;; The PCL package is internal and is used by code in potential +;;; bottlenecks. And since it's internal, no one should be ;;; doing things like deleting and recreating it in a running target Lisp. -;;; So perhaps we should replace it uses of *PCL-PACKAGE* with uses of -;;; (PCL-PACKAGE), and make PCL-PACKAGE a macro which expands into -;;; the SB-PCL package itself. Maybe we should even use this trick for -;;; COMMON-LISP and KEYWORD, too. (And the definition of PCL-PACKAGE etc. -;;; could be made less viciously brittle when SB-FLUID.) -;;; (Or perhaps just define a macro -;;; (DEFMACRO PKG (NAME) -;;; #-SB-FLUID (FIND-PACKAGE NAME) -;;; #+SB-FLUID `(FIND-PACKAGE ,NAME)) -;;; and use that to replace all three variables.) -(defvar *pcl-package* (find-package "SB-PCL")) +(define-symbol-macro *pcl-package* (load-time-value (find-package "SB-PCL") t)) (declaim (inline defstruct-classoid-p)) (defun defstruct-classoid-p (classoid) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |