for non-GENCGC systems has been increased to 20M (since that
seems much closer to the likely performance optimum for modern
systems than the old 4M value was)
+ * minor incompatible change: new larger values for *DEBUG-PRINT-LENGTH*
+ and *DEBUG-PRINT-LEVEL*
* SBCL runs on SPARC systems now. (thanks to Christophe Rhodes' port
of CMU CL's support for SPARC, and various endianness and other
SBCL portability fixes due to Christophe Rhodes and Dan Barlow)
+;;;; -*- Lisp -*-
+
;;;; tags which are set during the build process and which end up in
;;;; CL:*FEATURES* in the target SBCL, plus some comments about other
;;;; CL:*FEATURES* tags which have special meaning to SBCL or which
;; documented in the CMU CL code that SBCL is derived from, and is
;; present but stale in SBCL as of 0.6.12.)
;;
+ ;; properties derived from the machine architecture
+ ;; :stack-grows-downward, :stack-grows-downward
+ ;; One of these two should be present in the features list of any
+ ;; CPU supported as of sbcl-0.7.1.29. On the X86, the system stack
+ ;; grows downward. On the other supported CPU architectures, the
+ ;; system stack grows upward.
+ ;;
;; operating system features:
;; :linux = We're intended to run under some version of Linux.
;; :bsd = We're intended to run under some version of BSD Unix. (This
# the absence of :gencgc in *features*). This isn't a great
# separation, but for now, rather than have :gencgc in
# base-target-features.lisp-expr, we add it into local-target-features
-# if we're building for x86. -- CSR, 2002-02-21
+# if we're building for x86. -- CSR, 2002-02-21 Then we do something
+# similar with :STACK-GROWS-FOOWARD, too. -- WHN 2002-03-03
if [ "$sbcl_arch" = "x86" ] ; then
- echo -n ' :gencgc' >> $ltf
+ echo -n ' :gencgc :stack-grows-downward' >> $ltf
+else
+ echo -n ' :stack-grows-upward' >> $ltf
fi
for d in src/compiler src/assembly; do
echo //setting up symlink $d/target
-'#!/bin/sh
+#!/bin/sh
# "When we build software, it's a good idea to have a reliable method
# for getting an executable from it. We want any two reconstructions
"*CURRENT-LEVEL-IN-PRINT*" "*EMPTY-TYPE*"
"*GC-INHIBIT*"
"*NEED-TO-COLLECT-GARBAGE*"
- "*PRETTY-PRINTER*" "*UNIVERSAL-TYPE*"
+ "*PRETTY-PRINTER*" "*STACK-EXHAUSTION*" "*UNIVERSAL-TYPE*"
"*UNIVERSAL-FUN-TYPE*"
"*UNPARSE-FUN-TYPE-SIMPLIFY*" "*WILD-TYPE*"
"32BIT-LOGICAL-AND" "32BIT-LOGICAL-ANDC1"
"!TARGET-TYPE-COLD-INIT" "!RANDOM-COLD-INIT"
"!READER-COLD-INIT" "!TYPECHECKFUNS-COLD-INIT"
"STREAM-COLD-INIT-OR-RESET" "!LOADER-COLD-INIT"
+ "!EXHAUST-COLD-INIT"
"!PACKAGE-COLD-INIT" "SIGNAL-COLD-INIT-OR-REINIT"
"!POLICY-COLD-INIT-OR-RESANIFY" "!VM-TYPE-COLD-INIT"
"!BACKQ-COLD-INIT" "!SHARPM-COLD-INIT"
*cold-init-complete-p* nil
*type-system-initialized* nil)
+ (show-and-call !exhaust-cold-init)
(show-and-call !typecheckfuns-cold-init)
;; Anyone might call RANDOM to initialize a hash value or something;
#!-sb-fluid (declaim (inline cstack-pointer-valid-p))
(defun cstack-pointer-valid-p (x)
(declare (type system-area-pointer x))
- #!-x86 ; stack grows toward high address values
+ #!+stack-grows-upward
(and (sap< x (current-sp))
(sap<= (int-sap control-stack-start)
x)
(zerop (logand (sap-int x) #b11)))
- #!+x86 ; stack grows toward low address values
+ #!+stack-grows-downward
(and (sap>= x (current-sp))
(sap> (int-sap control-stack-end) x)
(zerop (logand (sap-int x) #b11))))
\f
;;;; variables and constants
-(defvar *debug-print-level* 3
+;;; things to consider when tweaking these values:
+;;; * We're afraid to just default them to NIL and NIL, in case the
+;;; user inadvertently causes a hairy data structure to be printed
+;;; when he inadvertently enters the debugger.
+;;; * We don't want to truncate output too much. These days anyone
+;;; can easily run their Lisp in a windowing system or under Emacs,
+;;; so it's not the end of the world even if the worst case is a
+;;; few thousand lines of output.
+;;; * As condition :REPORT methods are converted to use the pretty
+;;; printer, they acquire *PRINT-LEVEL* constraints, so e.g. under
+;;; sbcl-0.7.1.28's old value of *DEBUG-PRINT-LEVEL*=3, an
+;;; ARG-COUNT-ERROR printed as
+;;; error while parsing arguments to DESTRUCTURING-BIND:
+;;; invalid number of elements in
+;;; #
+;;; to satisfy lambda list
+;;; #:
+;;; exactly 2 expected, but 5 found
+(defvar *debug-print-level* 5
#!+sb-doc
"*PRINT-LEVEL* for the debugger")
-
-(defvar *debug-print-length* 5
+(defvar *debug-print-length* 7
#!+sb-doc
"*PRINT-LENGTH* for the debugger")
;;; These are bound on each invocation of INVOKE-DEBUGGER.
(defvar *debug-restarts*)
(defvar *debug-condition*)
+(defvar *nested-debug-condition*)
(defun invoke-debugger (condition)
#!+sb-doc
(*readtable* *debug-readtable*)
(*print-readably* nil)
(*print-pretty* t)
- (*package* original-package))
+ (*package* original-package)
+ (*nested-debug-condition* nil))
;; Before we start our own output, finish any pending output.
;; Otherwise, if the user tried to track the progress of
(type-of *debug-condition*)
*debug-condition*)
(error (condition)
- (format *error-output*
- "~&(caught ~S trying to print ~S when entering debugger)~%"
- (type-of condition)
- '*debug-condition*)
+ (setf *nested-debug-condition* condition)
+ (let ((ndc-type (type-of *nested-debug-condition*)))
+ (format *error-output*
+ "~&~@<(A ~S was caught when trying to print ~S when ~
+ entering the debugger. Printing was aborted and the ~
+ ~S was stored in ~S.)~@:>~%"
+ ndc-type
+ '*debug-condition*
+ ndc-type
+ '*nested-debug-condition*))
(when (typep condition 'cell-error)
;; what we really want to know when it's e.g. an UNBOUND-VARIABLE:
(format *error-output*
- "~&(CELL-ERROR-NAME = ~S)~%)"
+ "~&(CELL-ERROR-NAME ~S) = ~S~%"
+ '*debug-condition*
(cell-error-name *debug-condition*)))))
;; After the initial error/condition/whatever announcement to
(in-package "SB!KERNEL")
+;;; A native address on a 4-byte boundary can be thought of (and
+;;; passed around in Lisp code as) a FIXNUM. This function converts
+;;; from a byte address represented as an unsigned integer to such
+;;; a FIXNUM.
+;;;
+;;; FIXME: There should be some better place for this definition to
+;;; go. (Or a redundant definition might already exist. Especially
+;;; since this is essentially just a type pun, so there might be some
+;;; VOP or something which'd do it for us.)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun native-address-encoded-as-fixnum (native-address)
+ (declare (type unsigned-byte native-address))
+ (aver (zerop (logand native-address 3)))
+ (let* (;; naive encoding
+ (first-try (ash native-address -2))
+ ;; final encoding
+ (second-try
+ (if (<= first-try sb!vm:*target-most-positive-fixnum*)
+ ;; looks good
+ first-try
+ ;; When the naive encoding fails to make a FIXNUM
+ ;; because the sign is wrong, subtracting *T-M-P-F*
+ ;; should fix it.
+ (- first-try sb!vm:*target-most-positive-fixnum*))))
+ (aver (<= second-try sb!vm:*target-most-positive-fixnum*))
+ second-try)))
+
+;;; a FIXNUM, to be interpreted as a native pointer, which serves
+;;; as a boundary to catch stack overflow
+;;;
+;;; When stack overflow is detected, this is to be bound to a new
+;;; value (allowing some more space for error handling) around the
+;;; call to ERROR.
+;;;
+;;; FIXME: Maybe (probably?) this should be in SB!VM. And maybe the
+;;; size of the buffer zone should be set in src/compiler/cpu/parms.lisp
+;;; instead of constantly 1Mb for all CPU architectures?
+(defvar *stack-exhaustion*
+ ;; (initialized in cold init)
+ )
+(defun !exhaust-cold-init ()
+ (setf *stack-exhaustion*
+ #.(native-address-encoded-as-fixnum
+ #!+stack-grows-downward (+ sb!vm:control-stack-start (expt 2 20))
+ #!+stack-grows-upward (- sb!vm:control-stack-end (expt 2 20)))))
+
;;; FIXME: Even though this is only called when (> SAFETY (MAX SPEED SPACE))
;;; it's still annoyingly wasteful for it to be a full function call.
;;; It should probably be a VOP calling an assembly routine or something
(declare (type bit sign) (type (unsigned-byte 53) sig)
(type (unsigned-byte 11) exp))
(make-double-float (dpb exp sb!vm:double-float-exponent-byte
- (dpb (ash sig -32) sb!vm:double-float-significand-byte
+ (dpb (ash sig -32)
+ sb!vm:double-float-significand-byte
(if (zerop sign) 0 -1)))
(ldb (byte 32 0) sig)))
#!+(and long-float x86)
sb!vm:read-only-space-start))
(defun control-stack-usage ()
- #!-x86 (- (sb!sys:sap-int (sb!c::control-stack-pointer-sap))
- sb!vm:control-stack-start)
- #!+x86 (- sb!vm:control-stack-end
- (sb!sys:sap-int (sb!c::control-stack-pointer-sap))))
+ #!+stack-grows-upward (- (sb!sys:sap-int (sb!c::control-stack-pointer-sap))
+ sb!vm:control-stack-start)
+ #!+stack-grows-downward (- sb!vm:control-stack-end
+ (sb!sys:sap-int
+ (sb!c::control-stack-pointer-sap))))
(defun binding-stack-usage ()
(- (sb!sys:sap-int (sb!c::binding-stack-pointer-sap))
#!+long-float
(define-alien-type-class (long-float :include (float (bits #!+x86 96
- #!+sparc 128))
+ #!+sparc 128))
:include-args (type)))
#!+long-float
) ; EVAL-WHEN
\f
;;;; stubs for the Unix math library
-
-;;; Please refer to the Unix man pages for details about these routines.
+;;;;
+;;;; Many of these are unnecessary on the X86 because they're built
+;;;; into the FPU.
;;; trigonometric
#!-x86 (def-math-rtn "sin" 1)
:initarg :name
:initform nil)))
-(defun print-defmacro-ll-bind-error-intro (condition stream)
- (format stream
- "error while parsing arguments to ~A~@[ ~S~]:~%"
- (defmacro-lambda-list-bind-error-kind condition)
- (defmacro-lambda-list-bind-error-name condition)))
+;;; shared logic for REPORTing variants of DEFMACRO-LAMBDA-LIST-BIND-ERROR:
+;;; Set up appropriate prettying and indentation on STREAM, print some
+;;; boilerplate related to CONDITION (an instance of
+;;; DEFMACRO-LAMBDA-LIST-BIND-ERROR), then execute BODY.
+(defmacro !printing-defmacro-lambda-list-bind-error ((condition stream)
+ &body body)
+ `(%printing-defmacro-lambda-list-bind-error ,condition
+ ,stream
+ (lambda (,stream)
+ (declare (type stream ,stream))
+ ,@body)))
+(defun %printing-defmacro-lambda-list-bind-error (condition stream fun)
+ (declare (type stream stream) (type function fun))
+ (pprint-logical-block (stream nil)
+ (format stream
+ "error while parsing arguments to ~A~@[ ~S~]:~2I~:@_"
+ (defmacro-lambda-list-bind-error-kind condition)
+ (defmacro-lambda-list-bind-error-name condition))
+ (pprint-logical-block (stream nil)
+ (funcall fun stream))))
(define-condition defmacro-bogus-sublist-error
- (defmacro-lambda-list-bind-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)
- (print-defmacro-ll-bind-error-intro condition stream)
- (format stream
- "bogus sublist:~% ~S~%to satisfy lambda-list:~% ~:S~%"
- (defmacro-bogus-sublist-error-object condition)
- (defmacro-bogus-sublist-error-lambda-list condition)))))
+ (!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)
(maximum :reader arg-count-error-maximum :initarg :maximum))
(:report
(lambda (condition stream)
- (print-defmacro-ll-bind-error-intro condition stream)
- (format stream
- "invalid number of elements in:~% ~:S~%~
- to satisfy lambda list:~% ~:S~%"
- (arg-count-error-args condition)
- (arg-count-error-lambda-list condition))
- (cond ((null (arg-count-error-maximum condition))
- (format stream "at least ~W expected"
- (arg-count-error-minimum condition)))
- ((= (arg-count-error-minimum condition)
- (arg-count-error-maximum condition))
- (format stream "exactly ~W expected"
- (arg-count-error-minimum condition)))
- (t
- (format stream "between ~W and ~W expected"
- (arg-count-error-minimum condition)
- (arg-count-error-maximum condition))))
- (format stream ", but ~W found"
- (length (arg-count-error-args condition))))))
+ (!printing-defmacro-lambda-list-bind-error (condition stream)
+ (format stream
+ "invalid number of elements in ~2I~_~:S ~
+ ~I~_to satisfy lambda list ~2I~_~:S: ~I~_"
+ (arg-count-error-args condition)
+ (arg-count-error-lambda-list condition))
+ (cond ((null (arg-count-error-maximum condition))
+ (format stream "at least ~W expected"
+ (arg-count-error-minimum condition)))
+ ((= (arg-count-error-minimum condition)
+ (arg-count-error-maximum condition))
+ (format stream "exactly ~W expected"
+ (arg-count-error-minimum condition)))
+ (t
+ (format stream "between ~W and ~W expected"
+ (arg-count-error-minimum condition)
+ (arg-count-error-maximum condition))))
+ (format stream ", but ~W found"
+ (length (arg-count-error-args condition)))))))
-(define-condition defmacro-ll-broken-key-list-error
+(define-condition defmacro-lambda-list-broken-key-list-error
(defmacro-lambda-list-bind-error)
- ((problem :reader defmacro-ll-broken-key-list-error-problem
+ ((problem :reader defmacro-lambda-list-broken-key-list-error-problem
:initarg :problem)
- (info :reader defmacro-ll-broken-key-list-error-info :initarg :info))
+ (info :reader defmacro-lambda-list-broken-key-list-error-info
+ :initarg :info))
(:report (lambda (condition stream)
- (print-defmacro-ll-bind-error-intro condition stream)
- (format stream
- ;; FIXME: These should probably just be three
- ;; subclasses of the base class, so that we don't
- ;; need to maintain the set of tags both here and
- ;; implicitly wherever this macro is used.
- (ecase
- (defmacro-ll-broken-key-list-error-problem condition)
- (:dotted-list
- "dotted keyword/value list: ~S")
- (:odd-length
- "odd number of elements in keyword/value list: ~S")
- (:unknown-keyword
- "~{unknown keyword: ~S; expected one of ~{~S~^, ~}~}"))
- (defmacro-ll-broken-key-list-error-info condition)))))
+ (!printing-defmacro-lambda-list-bind-error (condition stream)
+ (format stream
+ ;; FIXME: These should probably just be three
+ ;; subclasses of the base class, so that we don't
+ ;; need to maintain the set of tags both here and
+ ;; implicitly wherever this macro is used. (This
+ ;; might get easier once CLOS is initialized in
+ ;; cold init.)
+ (ecase
+ (defmacro-lambda-list-broken-key-list-error-problem
+ condition)
+ (:dotted-list
+ "dotted keyword/value list: ~S")
+ (:odd-length
+ "odd number of elements in keyword/value list: ~S")
+ (:unknown-keyword
+ "~{unknown keyword: ~S; expected one of ~
+ ~{~S~^, ~}~}"))
+ (defmacro-lambda-list-broken-key-list-error-info
+ condition))))))
(push-let-binding var nil nil))))
(t
(error "non-symbol in lambda-list: ~S" var)))))
- (push `(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 ,path-0 ,minimum)
- `(proper-list-of-length-p ,path-0 ,minimum ,maximum))
- ,(if (eq error-fun 'error)
- `(arg-count-error ',error-kind ',name ,path-0
- ',lambda-list ,minimum
- ,(unless restp maximum))
- `(,error-fun 'arg-count-error
- :kind ',error-kind
- ,@(when name `(:name ',name))
- :args ,path-0
- :lambda-list ',lambda-list
- :minimum ,minimum
- ,@(unless restp
- `(:maximum ,maximum)))))
- *arg-tests*)
- (when keys
- (let ((problem (gensym "KEY-PROBLEM-"))
- (info (gensym "INFO-")))
- (push `(multiple-value-bind (,problem ,info)
- (verify-keywords ,rest-name
- ',keys
- ',allow-other-keys-p)
- (when ,problem
- (,error-fun
- 'defmacro-ll-broken-key-list-error
- :kind ',error-kind
- ,@(when name `(:name ',name))
- :problem ,problem
- :info ,info)))
- *arg-tests*)))
- (values env-arg-used minimum (if (null restp) maximum nil))))
+ (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)))
+ (push `(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 ,path-0 ,minimum)
+ `(proper-list-of-length-p ,path-0 ,minimum ,maximum))
+ ,(if (eq error-fun 'error)
+ `(arg-count-error ',error-kind ',name ,path-0
+ ',lambda-list ,minimum
+ ,explicit-maximum)
+ `(,error-fun 'arg-count-error
+ :kind ',error-kind
+ ,@(when name `(:name ',name))
+ :args ,path-0
+ :lambda-list ',lambda-list
+ :minimum ,minimum
+ :maximum ,explicit-maximum)))
+ *arg-tests*)
+ (when keys
+ (let ((problem (gensym "KEY-PROBLEM-"))
+ (info (gensym "INFO-")))
+ (push `(multiple-value-bind (,problem ,info)
+ (verify-keywords ,rest-name
+ ',keys
+ ',allow-other-keys-p)
+ (when ,problem
+ (,error-fun
+ 'defmacro-lambda-list-broken-key-list-error
+ :kind ',error-kind
+ ,@(when name `(:name ',name))
+ :problem ,problem
+ :info ,info)))
+ *arg-tests*)))
+ (values env-arg-used minimum explicit-maximum))))
(defun push-sub-list-binding (variable path object name error-kind error-fun)
(let ((var (gensym "TEMP-")))
symbol)
;;; Return the built-in hash value for SYMBOL.
-#!+(or x86 mips) ;; only backends for which a symbol-hash vop exists
+#!+(or x86 mips) ;; only backends for which a SYMBOL-HASH vop exists
(defun symbol-hash (symbol)
(symbol-hash symbol))
(declare (optimize (speed 3) (safety 0))
(values (unsigned-byte 20))) ; FIXME: DECLARE VALUES?
- #!-x86 ; machines where stack grows upwards (I guess) -- WHN 19990906
+ #!+stack-grows-upward
(labels
((scrub (ptr offset count)
(declare (type system-area-pointer ptr)
(* (floor initial-offset sb!vm:n-word-bytes) sb!vm:n-word-bytes)
0)))
- #!+x86 ;; (Stack grows downwards.)
+ #!+stack-grows-downward
(labels
((scrub (ptr offset count)
(declare (type system-area-pointer ptr)
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.7.1.28"
+"0.7.1.29"
projects / sbcl.git / commitdiff