(in-package "SB!C")
-;;; FIXME: Shouldn't SB!C::&MORE be in this list?
-(defconstant-eqx sb!xc:lambda-list-keywords
- '(&optional &rest &key &aux &body &whole &allow-other-keys &environment)
+;;; ANSI limits on compilation
+(def!constant sb!xc:call-arguments-limit sb!xc:most-positive-fixnum
#!+sb-doc
- #'equal
- "symbols which are magical in a lambda list")
+ "The exclusive upper bound on the number of arguments which may be passed
+ to a function, including &REST args.")
+(def!constant sb!xc:lambda-parameters-limit sb!xc:most-positive-fixnum
+ #!+sb-doc
+ "The exclusive upper bound on the number of parameters which may be specified
+ in a given lambda list. This is actually the limit on required and &OPTIONAL
+ parameters. With &KEY and &AUX you can get more.")
+(def!constant sb!xc:multiple-values-limit sb!xc:most-positive-fixnum
+ #!+sb-doc
+ "The exclusive upper bound on the number of multiple VALUES that you can
+ return.")
\f
;;;; cross-compiler-only versions of CL special variables, so that we
;;;; don't have weird interactions with the host compiler
;;; the type of LAYOUT-DEPTHOID slot values
(def!type sb!kernel::layout-depthoid () '(or index (integer -1 -1)))
-
-;;; a value for an optimization declaration
-(def!type policy-quality () '(or (rational 0 3) null))
-\f
-;;;; policy stuff
-
-;;; CMU CL used a special STRUCTURE-OBJECT type POLICY to represent
-;;; the state of optimization policy at any point in compilation. This
-;;; became a little unwieldy, especially because of cold init issues
-;;; for structures and structure accessors, so in SBCL we use an alist
-;;; instead.
-(deftype policy () 'list)
-
-;;; names of recognized optimization qualities which don't have
-;;; special defaulting behavior
-(defvar *policy-basic-qualities*)
-
-;;; FIXME: I'd like to get rid of DECLAIM OPTIMIZE-INTERFACE in favor
-;;; of e.g. (DECLAIM (OPTIMIZE (INTERFACE-SPEED 2) (INTERFACE-SAFETY 3))).
-#|
-;;; a list of conses (DEFAULTING-QUALITY . DEFAULT-QUALITY) of qualities
-;;; which default to other qualities when undefined, e.g. interface
-;;; speed defaulting to basic speed
-(defvar *policy-defaulting-qualities*)
-|#
-
-(defun optimization-quality-p (name)
- (or (member name *policy-basic-qualities*)
- ;; FIXME: Uncomment this when OPTIMIZE-INTERFACE goes away.
- #|(member name *policy-defaulting-qualities* :key #'car)|#))
-
-;;; *DEFAULT-POLICY* holds the current global compiler policy
-;;; information, as an alist mapping from optimization quality name to
-;;; quality value. Inside the scope of declarations, new entries are
-;;; added at the head of the alist.
-;;;
-;;; *DEFAULT-INTERFACE-POLICY* holds any values specified by an
-;;; OPTIMIZE-INTERFACE declaration.
-(declaim (type policy *default-policy* *default-interface-policy*))
-(defvar *default-policy*) ; initialized in cold init
-(defvar *default-interface-policy*) ; initialized in cold init
-
-;;; This is to be called early in cold init to set things up, and may
-;;; also be called again later in cold init in order to reset default
-;;; optimization policy back to default values after toplevel PROCLAIM
-;;; OPTIMIZE forms have messed with it.
-(defun !policy-cold-init-or-resanify ()
- (setf *policy-basic-qualities*
- '(;; ANSI standard qualities
- compilation-speed
- debug
- safety
- space
- speed
- ;; SBCL extensions
- ;;
- ;; FIXME: INHIBIT-WARNINGS is a misleading name for this.
- ;; Perhaps BREVITY would be better. But the ideal name would
- ;; have connotations of suppressing not warnings but only
- ;; optimization-related notes, which is already mostly the
- ;; behavior, and should probably become the exact behavior.
- ;; Perhaps INHIBIT-NOTES?
- inhibit-warnings))
- (setf *policy-defaulting-qualities*
- '((interface-speed . speed)
- (interface-safety . safety)))
- (setf *default-policy*
- (mapcar (lambda (name)
- ;; CMU CL didn't use 1 as the default for everything,
- ;; but since ANSI says 1 is the ordinary value, we do.
- (cons name 1))
- *policy-basic-qualities*))
- (setf *default-interface-policy*
- *default-policy*))
-;;; On the cross-compilation host, we initialize the compiler immediately.
-#+sb-xc-host (!policy-cold-init-or-resanify)
-
-;;; Is X the name of an optimization quality?
-(defun policy-quality-p (x)
- (memq x *policy-basic-qualities*))
\f
;;; possible values for the INLINE-ness of a function.
(deftype inlinep ()
(notinline . :notinline)
(maybe-inline . :maybe-inline)))
-;;; The lexical environment we are currently converting in.
+;;; the lexical environment we are currently converting in
(defvar *lexenv*)
(declaim (type lexenv *lexenv*))
-;;; *FREE-VARIABLES* translates from the names of variables referenced
-;;; globally to the LEAF structures for them. *FREE-FUNCTIONS* is like
-;;; *FREE-VARIABLES*, only it deals with function names.
-(defvar *free-variables*)
-(defvar *free-functions*)
-(declaim (hash-table *free-variables* *free-functions*))
+;;; *FREE-VARS* translates from the names of variables referenced
+;;; globally to the LEAF structures for them. *FREE-FUNS* is like
+;;; *FREE-VARS*, only it deals with function names.
+(defvar *free-vars*)
+(defvar *free-funs*)
+(declaim (type hash-table *free-vars* *free-funs*))
-;;; We use the same Constant structure to represent all equal anonymous
-;;; constants. This hashtable translates from constants to the Leafs that
+;;; We use the same CONSTANT structure to represent all equal anonymous
+;;; constants. This hashtable translates from constants to the LEAFs that
;;; represent them.
(defvar *constants*)
-(declaim (hash-table *constants*))
+(declaim (type hash-table *constants*))
+
+;;; *ALLOW-INSTRUMENTING* controls whether we should allow the
+;;; insertion of instrumenting code (like a (CATCH ...)) around code
+;;; to allow the debugger RETURN and STEP commands to function (we
+;;; disallow it for internal stuff).
+(defvar *allow-instrumenting*)
;;; miscellaneous forward declarations
(defvar *code-segment*)
(defvar *compiler-warning-count*)
(defvar *compiler-style-warning-count*)
(defvar *compiler-note-count*)
-(defvar *converting-for-interpreter*)
+(defvar *compiler-trace-output*)
+(defvar *constraint-universe*)
(defvar *count-vop-usages*)
(defvar *current-path*)
(defvar *current-component*)
-(defvar *default-policy*)
-(defvar *default-interface-policy*)
+(defvar *delayed-ir1-transforms*)
+(defvar *eval-tlf-index*)
+(defvar *handled-conditions*)
+(defvar *disabled-package-locks*)
+(defvar *policy*)
(defvar *dynamic-counts-tn*)
(defvar *elsewhere*)
(defvar *event-info*)
(defvar *event-note-threshold*)
(defvar *failure-p*)
-(defvar *fixups*)
+(defvar *fixup-notes*)
(defvar *in-pack*)
(defvar *info-environment*)
+#!+inline-constants
+(progn
+ (defvar *constant-segment*)
+ (defvar *constant-table*)
+ (defvar *constant-vector*))
(defvar *lexenv*)
(defvar *source-info*)
+(defvar *source-plist*)
+(defvar *source-namestring*)
(defvar *trace-table*)
(defvar *undefined-warnings*)
(defvar *warnings-p*)
+(defvar *lambda-conversions*)
+
+(defvar *stack-allocate-dynamic-extent* t
+ "If true (the default), the compiler respects DYNAMIC-EXTENT declarations
+and stack allocates otherwise inaccessible parts of the object whenever
+possible. Potentially long (over one page in size) vectors are, however, not
+stack allocated except in zero SAFETY code, as such a vector could overflow
+the stack without triggering overflow protection.")
+
+(!begin-collecting-cold-init-forms)
+;;; This lock is seized in the compiler, and related areas -- like the
+;;; classoid/layout/class system.
+(defglobal **world-lock** nil)
+(!cold-init-forms
+ (setf **world-lock** (sb!thread:make-mutex :name "World Lock")))
+(!defun-from-collected-cold-init-forms !world-lock-cold-init)
+
+(defmacro with-world-lock (() &body body)
+ `(sb!thread:with-recursive-lock (**world-lock**)
+ ,@body))
+
+(declaim (type fixnum *compiler-sset-counter*))
+(defvar *compiler-sset-counter* 0)
+
+;;; unique ID for the next object created (to let us track object
+;;; identity even across GC, useful for understanding weird compiler
+;;; bugs where something is supposed to be unique but is instead
+;;; exists as duplicate objects)
+#!+sb-show
+(progn
+ (defvar *object-id-counter* 0)
+ (defun new-object-id ()
+ (prog1
+ *object-id-counter*
+ (incf *object-id-counter*))))
\f
;;;; miscellaneous utilities
;;; benefit of the compiler, but it's sometimes called from stuff like
;;; type-defining code which isn't logically part of the compiler.
(declaim (ftype (function ((or symbol cons) keyword) (values))
- note-name-defined))
+ note-name-defined))
(defun note-name-defined (name kind)
;; We do this BOUNDP check because this function can be called when
- ;; not in a compilation unit (as when loading top-level forms).
+ ;; not in a compilation unit (as when loading top level forms).
(when (boundp '*undefined-warnings*)
(setq *undefined-warnings*
- (delete-if (lambda (x)
- (and (equal (undefined-warning-name x) name)
- (eq (undefined-warning-kind x) kind)))
- *undefined-warnings*)))
+ (delete-if (lambda (x)
+ (and (equal (undefined-warning-name x) name)
+ (eq (undefined-warning-kind x) kind)))
+ *undefined-warnings*)))
(values))
;;; to be called when a variable is lexically bound
(declaim (ftype (function (symbol) (values)) note-lexical-binding))
(defun note-lexical-binding (symbol)
- (let ((name (symbol-name symbol)))
;; This check is intended to protect us from getting silently
;; burned when we define
;; foo.lisp:
;; (LET ((*FOO* X))
;; (FOO 14)))
;; and then we happen to compile bar.lisp before foo.lisp.
- (when (and (char= #\* (aref name 0))
- (char= #\* (aref name (1- (length name)))))
- ;; FIXME: should be COMPILER-STYLE-WARNING?
- (style-warn "using the lexical binding of the symbol ~S, not the~@
-dynamic binding, even though the symbol name follows the usual naming~@
-convention (names like *FOO*) for special variables" symbol)))
+ (when (looks-like-name-of-special-var-p symbol)
+ ;; FIXME: should be COMPILER-STYLE-WARNING?
+ (style-warn 'sb!kernel:asterisks-around-lexical-variable-name
+ :format-control
+ "using the lexical binding of the symbol ~
+ ~/sb-impl::print-symbol-with-prefix/, not the~@
+ dynamic binding"
+ :format-arguments (list symbol)))
(values))
+
+(def!struct (debug-name-marker (:make-load-form-fun dump-debug-name-marker)
+ (:print-function print-debug-name-marker)))
+
+(defvar *debug-name-level* 4)
+(defvar *debug-name-length* 12)
+(defvar *debug-name-punt*)
+(defvar *debug-name-sharp*)
+(defvar *debug-name-ellipsis*)
+
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
+ (defun dump-debug-name-marker (marker &optional env)
+ (declare (ignore env))
+ (cond ((eq marker *debug-name-sharp*)
+ `(if (boundp '*debug-name-sharp*)
+ *debug-name-sharp*
+ (make-debug-name-marker)))
+ ((eq marker *debug-name-ellipsis*)
+ `(if (boundp '*debug-name-ellipsis*)
+ *debug-name-ellipsis*
+ (make-debug-name-marker)))
+ (t
+ (warn "Dumping unknown debug-name marker.")
+ '(make-debug-name-marker)))))
+
+(defun print-debug-name-marker (marker stream level)
+ (declare (ignore level))
+ (cond ((eq marker *debug-name-sharp*)
+ (write-char #\# stream))
+ ((eq marker *debug-name-ellipsis*)
+ (write-string "..." stream))
+ (t
+ (write-string "???" stream))))
+
+(setf *debug-name-sharp* (make-debug-name-marker)
+ *debug-name-ellipsis* (make-debug-name-marker))
+
+(defun debug-name (type thing &optional context)
+ (let ((*debug-name-punt* nil))
+ (labels ((walk (x)
+ (typecase x
+ (cons
+ (if (plusp *debug-name-level*)
+ (let ((*debug-name-level* (1- *debug-name-level*)))
+ (do ((tail (cdr x) (cdr tail))
+ (name (cons (walk (car x)) nil)
+ (cons (walk (car tail)) name))
+ (n (1- *debug-name-length*) (1- n)))
+ ((or (not (consp tail))
+ (not (plusp n))
+ *debug-name-punt*)
+ (cond (*debug-name-punt*
+ (setf *debug-name-punt* nil)
+ (nreverse name))
+ ((atom tail)
+ (nconc (nreverse name) (walk tail)))
+ (t
+ (setf *debug-name-punt* t)
+ (nconc (nreverse name) (list *debug-name-ellipsis*)))))))
+ *debug-name-sharp*))
+ ((or symbol number string)
+ x)
+ (t
+ (type-of x)))))
+ (let ((name (list* type (walk thing) (when context (name-context)))))
+ (when (legal-fun-name-p name)
+ (bug "~S is a legal function name, and cannot be used as a ~
+ debug name." name))
+ name))))
projects / sbcl.git / blobdiff