X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fearly-c.lisp;h=b51bf8b6c0c492baa36e615c868df8dce1d57aca;hb=b63c4fb9b98fa8188e17ba926e150ba417a74635;hp=e2c677a62c082187015526f30aee78a7bc530f25;hpb=f46d27c212eb12011b772cb8eefe904da4e7c778;p=sbcl.git

diff --git a/src/compiler/early-c.lisp b/src/compiler/early-c.lisp
index e2c677a..b51bf8b 100644
--- a/src/compiler/early-c.lisp
+++ b/src/compiler/early-c.lisp
@@ -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*)
@@ -116,6 +124,11 @@
 (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
@@ -165,3 +178,59 @@
 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)))))))))