From 9c8ece2ca345028262886bc12d00001e2059724c Mon Sep 17 00:00:00 2001 From: dtc <dtc> Date: Thu, 25 Nov 1999 15:57:39 +0000 Subject: [PATCH] For support of compiler reentry and thread safety, avoid the use of global tables and counters for the continuation, TN, and label debug IDs; rather dynamically bind new tables and counters in the functions compiler and sub-compiler-file with the aid of the new macro with-debug-counters. --- compiler/debug.lisp | 10 +++-- compiler/macros.lisp | 21 ++++++++- compiler/main.lisp | 100 ++++++++++++++++++++++--------------------- 3 files changed, 77 insertions(+), 54 deletions(-) diff --git a/compiler/debug.lisp b/compiler/debug.lisp index fe0e376dd..8a9985a47 100644 --- a/compiler/debug.lisp +++ b/compiler/debug.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/debug.lisp,v 1.28 1999/11/25 15:54:21 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/debug.lisp,v 1.29 1999/11/25 15:57:39 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -965,12 +965,14 @@ ;;; Continuation-Number, Number-Continuation, ID-TN, TN-ID -- Interface ;;; ;;; When we print Continuations and TNs, we assign them small numeric IDs so -;;; that we can get a handle on anonymous objects given a printout. +;;; that we can get a handle on anonymous objects given a printout. Note that +;;; the variables are bound by the with-debug-counters macro which needs to be +;;; consistent with the definitions here. ;;; (macrolet ((frob (counter vto vfrom fto ffrom) `(progn - (defvar ,vto (make-hash-table :test #'eq)) - (defvar ,vfrom (make-hash-table :test #'eql)) + (defvar ,vto) + (defvar ,vfrom) (proclaim '(hash-table ,vto ,vfrom)) (defvar ,counter 0) (proclaim '(fixnum ,counter)) diff --git a/compiler/macros.lisp b/compiler/macros.lisp index 4a4563cf5..595b8b18d 100644 --- a/compiler/macros.lisp +++ b/compiler/macros.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/macros.lisp,v 1.42 1999/02/25 13:03:09 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/macros.lisp,v 1.43 1999/11/25 15:57:39 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -737,6 +737,25 @@ (values (cdr ,n-res) t) (values nil nil)))) + + +;;; With-debug-counters -- Interface +;;; +;;; Bind the hashtables and counters used for keeping track of +;;; continuation, TN, and label IDs for the debug dumping routines. +;;; +(defmacro with-debug-counters (&body forms) + `(let ((*continuation-numbers* (make-hash-table :test #'eq)) + (*number-continuations* (make-hash-table :test #'eql)) + (*continuation-number* 0) + (*tn-ids* (make-hash-table :test #'eq)) + (*id-tns* (make-hash-table :test #'eql)) + (*tn-id* 0) + (*id-labels* (make-hash-table :test #'eq)) + (*label-ids* (make-hash-table :test #'eql)) + (*label-id* 0)) + ,@forms)) + ;;;; The Defprinter macro: diff --git a/compiler/main.lisp b/compiler/main.lisp index e154fad95..fec476df6 100644 --- a/compiler/main.lisp +++ b/compiler/main.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/main.lisp,v 1.112 1999/11/25 15:54:22 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/main.lisp,v 1.113 1999/11/25 15:57:39 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -309,7 +309,7 @@ (when *check-consistency* (maybe-mumble "CheckL ") (check-life-consistency component)) - + (maybe-mumble "Pack ") (pack component) @@ -325,7 +325,7 @@ (multiple-value-bind (length trace-table fixups) (generate-code component) - + (when (and *compiler-trace-output* (backend-disassem-params *backend*)) (format *compiler-trace-output* @@ -346,7 +346,7 @@ length trace-table fixups *compile-object*)) (null)))) - + (when *code-segment* (new-assem:release-segment *code-segment*)) (when *elsewhere* @@ -1501,22 +1501,23 @@ (or (backend-info-environment *backend*) *info-environment*)) (*gensym-counter* 0)) - (clear-stuff) - (with-compilation-unit () - (process-sources info) - - (finish-block-compilation) - (compile-top-level-lambdas () t) - (let ((object *compile-object*)) - (etypecase object - (fasl-file (fasl-dump-source-info info object)) - (core-object (fix-core-source-info info object d-s-info)) - (null))) - - (cond ((> *compiler-error-count* start-errors) :error) - ((> *compiler-warning-count* start-warnings) :warning) - ((> *compiler-note-count* start-notes) :note) - (t nil)))))) + (with-debug-counters + (clear-stuff) + (with-compilation-unit () + (process-sources info) + + (finish-block-compilation) + (compile-top-level-lambdas () t) + (let ((object *compile-object*)) + (etypecase object + (fasl-file (fasl-dump-source-info info object)) + (core-object (fix-core-source-info info object d-s-info)) + (null))) + + (cond ((> *compiler-error-count* start-errors) :error) + ((> *compiler-warning-count* start-warnings) :warning) + ((> *compiler-note-count* start-notes) :note) + (t nil))))))) ;;; Verify-Source-Files -- Internal @@ -1856,35 +1857,36 @@ (*last-message-count* 0) (*compile-object* (make-core-object)) (*gensym-counter* 0)) - (clear-stuff) - (find-source-paths form 0) - (let ((lambda (ir1-top-level form '(original-source-start 0 0) t))) - - (compile-fix-function-name lambda name) - (let* ((component - (block-component (node-block (lambda-bind lambda)))) - (*all-components* (list component))) - (local-call-analyze component)) - - (multiple-value-bind (components top-components) - (find-initial-dfo (list lambda)) - (let ((*all-components* (append components top-components))) - (dolist (component *all-components*) - (compile-component component)))) - - (let* ((res (core-call-top-level-lambda lambda *compile-object*)) - (return (or name res))) - (fix-core-source-info *source-info* *compile-object* res) - (when name - (setf (fdefinition name) res)) - - (cond ((or (> *compiler-error-count* start-errors) - (> *compiler-warning-count* start-warnings)) - (values return t t)) - ((> *compiler-note-count* start-notes) - (values return t nil)) - (t - (values return nil nil))))))))) + (with-debug-counters + (clear-stuff) + (find-source-paths form 0) + (let ((lambda (ir1-top-level form '(original-source-start 0 0) t))) + + (compile-fix-function-name lambda name) + (let* ((component + (block-component (node-block (lambda-bind lambda)))) + (*all-components* (list component))) + (local-call-analyze component)) + + (multiple-value-bind (components top-components) + (find-initial-dfo (list lambda)) + (let ((*all-components* (append components top-components))) + (dolist (component *all-components*) + (compile-component component)))) + + (let* ((res (core-call-top-level-lambda lambda *compile-object*)) + (return (or name res))) + (fix-core-source-info *source-info* *compile-object* res) + (when name + (setf (fdefinition name) res)) + + (cond ((or (> *compiler-error-count* start-errors) + (> *compiler-warning-count* start-warnings)) + (values return t t)) + ((> *compiler-note-count* start-notes) + (values return t nil)) + (t + (values return nil nil)))))))))) ;;; UNCOMPILE -- Public ;;; -- GitLab