X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fearly-c.lisp;h=b51bf8b6c0c492baa36e615c868df8dce1d57aca;hb=b63c4fb9b98fa8188e17ba926e150ba417a74635;hp=c0dba380715d21c42bfa08001cb7add1d24abf6e;hpb=5ec8d0c1c8b7939818b75118b472fac1af554f9a;p=sbcl.git diff --git a/src/compiler/early-c.lisp b/src/compiler/early-c.lisp index c0dba38..b51bf8b 100644 --- a/src/compiler/early-c.lisp +++ b/src/compiler/early-c.lisp @@ -16,16 +16,16 @@ (in-package "SB!C") ;;; ANSI limits on compilation -(defconstant sb!xc:call-arguments-limit most-positive-fixnum +(def!constant sb!xc:call-arguments-limit most-positive-fixnum #!+sb-doc "The exclusive upper bound on the number of arguments which may be passed to a function, including &REST args.") -(defconstant sb!xc:lambda-parameters-limit most-positive-fixnum +(def!constant sb!xc:lambda-parameters-limit most-positive-fixnum #!+sb-doc "The exclusive upper bound on the number of parameters which may be specifed in a given lambda list. This is actually the limit on required and &OPTIONAL parameters. With &KEY and &AUX you can get more.") -(defconstant sb!xc:multiple-values-limit most-positive-fixnum +(def!constant sb!xc:multiple-values-limit most-positive-fixnum #!+sb-doc "The exclusive upper bound on the number of multiple VALUES that you can return.") @@ -73,12 +73,12 @@ (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 (type 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 @@ -86,6 +86,12 @@ (defvar *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*) #!+sb-dyncount (defvar *collect-dynamic-statistics*) @@ -101,13 +107,15 @@ (defvar *current-path*) (defvar *current-component*) (defvar *delayed-ir1-transforms*) +(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*) (defvar *lexenv*) @@ -115,6 +123,23 @@ (defvar *trace-table*) (defvar *undefined-warnings*) (defvar *warnings-p*) + +;;; This lock is seized in the compiler, and related areas: the +;;; compiler is not presently thread-safe +(defvar *big-compiler-lock* + (sb!thread:make-mutex :name "big compiler lock")) + +;;; 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*)))) ;;;; miscellaneous utilities @@ -148,8 +173,64 @@ ;; (FOO 14))) ;; and then we happen to compile bar.lisp before foo.lisp. (when (looks-like-name-of-special-var-p symbol) - ;; FIXME: should be COMPILER-STYLE-WARNING? - (style-warn "using the lexical binding of the symbol ~S, not the~@ + ;; 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)) (values)) + +;;; Hacky (duplicating machinery found elsewhere because this function +;;; turns out to be on a critical path in the compiler) shorthand for +;;; creating debug names from source names or other stems, e.g. +;;; +;;; (DEBUG-NAMIFY "FLET " SOURCE-NAME) -> "FLET FOO:BAR" +;;; (DEBUG-NAMIFY "top level form " FORM) -> "top level form (QUUX :FOO)" +;;; +;;; If ALT is given it must be a string -- it is then used in place of +;;; either HEAD or TAIL if either of them is EQ to SB-C::.ANONYMOUS. +;;; +(declaim (inline debug-namify)) +(defun debug-namify (head tail &optional alt) + (declare (type (or null string) alt)) + (flet ((symbol-debug-name (symbol) + ;; KLUDGE: (OAOOM warning) very much akin to OUTPUT-SYMBOL. + (if (and alt (eq '.anonymous. symbol)) + alt + (let ((package (symbol-package symbol)) + (name (symbol-name symbol))) + (cond + ((eq package *keyword-package*) + (concatenate 'string ":" name)) + ((eq package *cl-package*) + name) + ((null package) + (concatenate 'string "#:" name)) + (t + (multiple-value-bind (symbol status) + (find-symbol name package) + (declare (ignore symbol)) + (concatenate 'string + (package-name package) + (if (eq status :external) ":" "::") + name)))))))) + (cond ((and (stringp head) (stringp tail)) + (concatenate 'string head tail)) + ((and (stringp head) (symbolp tail)) + (concatenate 'string head (symbol-debug-name tail))) + ((and (symbolp head) (stringp tail)) + (concatenate 'string (symbol-debug-name head) tail)) + (t + (macrolet ((out (obj s) + `(typecase ,obj + (string (write-string ,obj ,s)) + (symbol (write-string (symbol-debug-name ,obj) ,s)) + (t (prin1 ,obj ,s))))) + (with-standard-io-syntax + (let ((*print-readably* nil) + (*print-pretty* nil) + (*package* *cl-package*) + (*print-length* 3) + (*print-level* 2)) + (with-output-to-string (s) + (out head s) + (out tail s)))))))))