diff --git a/src/core/corePackage.cc b/src/core/corePackage.cc index cfb9cdad30..a83482aa7d 100644 --- a/src/core/corePackage.cc +++ b/src/core/corePackage.cc @@ -149,7 +149,6 @@ SYMBOL_EXPORT_SC_(CorePkg, STARdebugSourcePosInfoSTAR); SYMBOL_EXPORT_SC_(CorePkg, STARdebugStartupSTAR); SYMBOL_EXPORT_SC_(CorePkg, STARdebugVaslistSTAR); SYMBOL_EXPORT_SC_(CorePkg, STARdebug_accessorsSTAR); -SYMBOL_EXPORT_SC_(CorePkg, STARdebug_dispatchSTAR); SYMBOL_EXPORT_SC_(CorePkg, STARdebug_dtree_interpreterSTAR); SYMBOL_EXPORT_SC_(CorePkg, STARdebug_fastgfSTAR); SYMBOL_EXPORT_SC_(CorePkg, STARdebug_hash_tableSTAR) @@ -711,7 +710,6 @@ void CoreExposer_O::define_essential_globals(LispPtr lisp) { _sym_STARbuiltin_single_dispatch_method_namesSTAR->defparameter(nil()); _sym_STARbuiltin_macro_function_namesSTAR->defparameter(nil()); _sym_STARbuiltin_setf_function_namesSTAR->defparameter(nil()); - _sym_STARdebug_dispatchSTAR->defparameter(nil()); _sym_STARdebug_valuesSTAR->defparameter(nil()); _sym_STARdebug_hash_tableSTAR->defparameter(nil()); _sym_STARforeign_data_reader_callbackSTAR->defparameter(nil()); diff --git a/src/lisp/kernel/cleavir/translate.lisp b/src/lisp/kernel/cleavir/translate.lisp index 61ba9c45c4..33940fa03d 100644 --- a/src/lisp/kernel/cleavir/translate.lisp +++ b/src/lisp/kernel/cleavir/translate.lisp @@ -2228,8 +2228,6 @@ COMPILE-FILE will use the default *clasp-env*." "repl-code")))) ;; Link the C++ intrinsics into the module (cmp::with-module (:module module) - (cmp::cmp-log "Dumping module%N") - (cmp::cmp-log-dump-module module) (multiple-value-bind (ordered-raw-constants-list constants-table startup-shutdown-id) (cmp:with-debug-info-generator (:module cmp:*the-module* :pathname pathname) (literal:with-rtv diff --git a/src/lisp/kernel/clos/README b/src/lisp/kernel/clos/README index 9414cebff6..c6e2ae9dd1 100644 --- a/src/lisp/kernel/clos/README +++ b/src/lisp/kernel/clos/README @@ -252,8 +252,6 @@ Modification Proceed with caution. -There are informational debug macros. mlog is defined in hierarchy.lsp and is good if you have a problem before generic function calls. Various places use mlog, which just expands into nothing normally. However, mlog puts out a lot of output, and once generic functions start being called this output will be too voluminous for humans to make serious use of. - At the top of closfastgf is a thing putting :debug-fastgf in *features*. This is how you debug problems with generic function calls. There's a lot of output so it dumps it into a file in /tmp based on the PID. What it essentially does is log the dispatch miss "slow path" in which a generic function has to compute a new effective method etc. If a function should be satiated but isn't, this will be represented in this log as infinite recursive calls, like "Dispatch miss for ... Dispatch miss for ..." This indicates that the dispatch miss code is itself trying to call the function. The solution is probably to throw the function into satiation.lsp. There is a recursion checker enabled when log-fastgf is on, but it might not always work. diff --git a/src/lisp/kernel/clos/change.lisp b/src/lisp/kernel/clos/change.lisp index cc7607a55b..4c7243ce06 100644 --- a/src/lisp/kernel/clos/change.lisp +++ b/src/lisp/kernel/clos/change.lisp @@ -58,7 +58,6 @@ (list (list #'update-instance-for-different-class (list old-data new-data)) (list #'shared-initialize (list new-data added-slots))))) - (mlog "change.lisp update-instance-for-different-class about to apply shared-initialize%N") (apply #'shared-initialize new-data added-slots initargs))) ;;; Mutate new-rack based on old-rack, for change-class. @@ -178,7 +177,6 @@ (list (list #'update-instance-for-redefined-class (list instance added-slots discarded-slots property-list)) (list #'shared-initialize (list instance added-slots))))) - (mlog "change.lisp update-instance-for-redefined-class about to apply shared-initialize%N") (apply #'shared-initialize instance added-slots initargs)) ;;; This function works on racks directly rather than instances, @@ -219,7 +217,7 @@ (let ((old-rack (si:instance-rack instance)) (new-rack (make-rack-for-class (class-of instance)))) (multiple-value-bind (added-slots discarded-slots property-list) - (update-instance-aux (si:instance-rack instance) new-rack) + (update-instance-aux old-rack new-rack) (setf (si:instance-rack instance) new-rack) ;; If U-I-F-R-C signals an error or otherwise nonlocally exits, roll back ;; the instance. This does not seem to be required by the standard, but diff --git a/src/lisp/kernel/clos/combin.lisp b/src/lisp/kernel/clos/combin.lisp index 99e87be945..34869ed3e0 100644 --- a/src/lisp/kernel/clos/combin.lisp +++ b/src/lisp/kernel/clos/combin.lisp @@ -174,11 +174,6 @@ collect (call-method-aux gf nmethod))) (defun std-expand-apply-method (method method-arguments arguments env) - (mlog "combin.lisp:std-expand-apply-method method -> {} method-arguments -> {} arguments -> {} env -> {}%N" - (core:safe-repr method) - (core:safe-repr method-arguments) - (core:safe-repr arguments) - (core:safe-repr env)) (destructuring-bind (&optional ((&rest next-methods))) method-arguments (let ((arg-info (argforms-to-arg-info arguments env))) (cond diff --git a/src/lisp/kernel/clos/dtree.lisp b/src/lisp/kernel/clos/dtree.lisp index 1e7832991b..007e764374 100644 --- a/src/lisp/kernel/clos/dtree.lisp +++ b/src/lisp/kernel/clos/dtree.lisp @@ -2,15 +2,6 @@ ;;; Misc -(defparameter *debug-dtree* nil) -#+(or)(defmacro dtree-log (fmt &rest args) - `(when *debug-dtree* - (format t ,fmt ,@args))) - -(defmacro dtree-log (fmt &rest args) - (declare (ignore fmt args)) - nil) - (defun insert-sorted (item lst &optional (test #'<) (key #'identity)) (if (null lst) (list item) @@ -124,21 +115,17 @@ (defun bc-basic-tree (call-history specializer-profile) (assert (not (null call-history))) - (dtree-log "Entered bc-basic-tree call-history: ~a specializer-profile: ~a~%" (core:safe-repr call-history) (core::safe-repr specializer-profile)) (let ((last-specialized (position nil specializer-profile :from-end t :test-not #'eq)) (first-specialized (position-if #'identity specializer-profile))) - (dtree-log "A first-specialized ~a last-specialized ~a~%" first-specialized last-specialized) (let ((specializer-indices (when (and (integerp first-specialized) (integerp last-specialized)) (loop for index from first-specialized to last-specialized when (elt specializer-profile index) collect index)))) - (dtree-log "B specializer-indices ~s~%" specializer-indices) (when (null last-specialized) ;; no specialization - we go immediately to the outcome ;; (we could assert all outcomes are identical) (return-from bc-basic-tree (values (cdr (first call-history)) 0))) ;; usual case - (dtree-log "C~%") (loop with result = (make-test :index (car specializer-indices)) with specialized-length = (1+ last-specialized) for (specializers . outcome) in call-history diff --git a/src/lisp/kernel/clos/fixup.lisp b/src/lisp/kernel/clos/fixup.lisp index 5774c2820a..1de2bdef8a 100644 --- a/src/lisp/kernel/clos/fixup.lisp +++ b/src/lisp/kernel/clos/fixup.lisp @@ -17,31 +17,12 @@ (in-package "CLOS") -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; For debugging this file -;;; (Which happens a fair amount, because it's where CLOS begins use.) - -;;; This will print every form as its compiled -#+mlog -(eval-when (:compile-toplevel :load-toplevel :execute) - (format t "Starting fixup.lisp") - (setq *echo-repl-tpl-read* t) - (setq *load-print* t) - (setq *echo-repl-read* t)) - -#+mlog -(eval-when (:compile-toplevel :execute) - (setq core::*debug-dispatch* t)) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Define generics for core functions. (defun function-to-method (name lambda-list specializers &optional satiation-specializers (function (fdefinition name))) - (mlog "function-to-method: name -> {} specializers -> {} lambda-list -> {}%N" name specializers lambda-list) - (mlog "function-to-method: function -> {}%N" function) ;; since we still have method.lisp's add-method in place, it will try to add ;; the function-to-method-temp entry to *early-methods*. but then we unbind ;; that, so things are a bit screwy. We do it more manually. @@ -70,7 +51,6 @@ into new-call-history finally (append-generic-function-call-history f new-call-history)) ;; Finish setup - (mlog "function-to-method: installed method%N") (core:setf-lambda-list f lambda-list) ; hook up the introspection ;; (setf generic-function-name) itself goes through here, so to minimize ;; bootstrap headaches we use the underlying writer directly. @@ -116,8 +96,6 @@ '(new-name generic-function) '(t standard-generic-function)) -(mlog "done with the first function-to-methods%N") - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Satiate @@ -129,8 +107,6 @@ (dolist (method-info *early-methods*) (compute-gf-specializer-profile (fdefinition (car method-info)))) -(mlog "About to satiate%N") - ;;; Trickiness here. ;;; During build we first load this file as source. In that case we add only ;;; enough call history entries to boot the system. @@ -146,8 +122,6 @@ (eval-when (:load-toplevel) (satiate-clos)) -(mlog "Done satiating%N") - ;;; Generic functions can be called now! ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -181,30 +155,21 @@ ;;; so after this they will do generic function calls. (defun ensure-generic-function (name &rest args &key &allow-other-keys) - (mlog "ensure-generic-function name -> {} args -> {} %N" name args) - (mlog "(not (fboundp name)) -> {}%N" (not (fboundp name))) (let ((gfun (si::traced-old-definition name))) (cond ((not (legal-generic-function-name-p name)) (core:simple-program-error "~A is not a valid generic function name" name)) ((not (fboundp name)) - (mlog "A gfun -> {} name -> {} args -> {}%N" gfun name args) - ;; (break "About to setf (fdefinition name)") - (mlog "#'ensure-generic-function-using-class -> {}%N" #'ensure-generic-function-using-class ) (setf (fdefinition name) (apply #'ensure-generic-function-using-class gfun name args))) ((si::instancep (or gfun (setf gfun (fdefinition name)))) - (mlog "B%N") (let ((new-gf (apply #'ensure-generic-function-using-class gfun name args))) new-gf)) ((special-operator-p name) - (mlog "C%N") (core:simple-program-error "The special operator ~A is not a valid name for a generic function" name)) ((macro-function name) - (mlog "D%N") (core:simple-program-error "The symbol ~A is bound to a macro and is not a valid name for a generic function" name)) ((not *clos-booted*) - (mlog "E%N") (setf (fdefinition name) (apply #'ensure-generic-function-using-class nil name args)) (fdefinition name)) @@ -286,8 +251,6 @@ ;; during boot it's a structure accessor (declare (notinline method-qualifiers remove-method)) (declare (notinline reinitialize-instance)) ; bootstrap stuff - - (mlog "fixup.lisp::add-method entered for gf {}%N" (core:safe-repr gf)) ;; ;; 1) The method must not be already installed in another generic function. ;; @@ -302,19 +265,15 @@ and cannot be added to ~A." method other-gf gf))) ;; function does. ;; (let ((new-lambda-list (method-lambda-list method))) - (mlog "fixup.lisp::add-method (slot-boundp gf 'lambda-list) -> {}%N" (slot-boundp gf 'lambda-list)) (if (slot-boundp gf 'lambda-list) (let ((old-lambda-list (generic-function-lambda-list gf))) (unless (congruent-lambda-p old-lambda-list new-lambda-list) (error "Cannot add the method ~A to the generic function ~A because their lambda lists ~A and ~A are not congruent." method gf new-lambda-list old-lambda-list)) ;; Add any keywords from the method to the gf display lambda list. - (mlog "fixup.lisp::add-method About to call maybe-augment-generic-function-lambda-list new-lambda-list->{}%N" (core:safe-repr new-lambda-list)) (maybe-augment-generic-function-lambda-list gf new-lambda-list)) - (progn - (mlog "fixup.lisp::add-method About to call reinitialize-instance lambda-list ->{}%N" (core:safe-repr (method-lambda-list-for-gf new-lambda-list))) - (reinitialize-instance - gf :lambda-list (method-lambda-list-for-gf new-lambda-list))))) + (reinitialize-instance + gf :lambda-list (method-lambda-list-for-gf new-lambda-list)))) ;; ;; 3) Finally, it is inserted in the list of methods, and the method is ;; marked as belonging to a generic function. @@ -506,17 +465,14 @@ and cannot be added to ~A." method other-gf gf))) (%satiate map-dependents (standard-generic-function core:closure) (standard-class core:closure)) -(mlog "TOP: defgeneric update-dependent%N") (defgeneric update-dependent (object dependent &rest initargs)) ;; After this, update-dependents will work (setf *clos-booted* 'map-dependents) -(mlog "TOP: (defclass initargs-updater ()%N") (defclass initargs-updater () ()) -(mlog "TOP: (defun recursively-update-class-initargs-cache (a-class)%N") (defun recursively-update-class-initargs-cache (a-class) ;; Bug #588: If a class is forward referenced and you define an initialize-instance ;; (or whatever) method on it, it got here and tried to compute valid initargs, which @@ -526,7 +482,6 @@ and cannot be added to ~A." method other-gf gf))) (precompute-valid-initarg-keywords a-class) (mapc #'recursively-update-class-initargs-cache (class-direct-subclasses a-class)))) -(mlog "TOP: (defmethod update-dependent ((object generic-function) (dep initargs-updater)%N") (defmethod update-dependent ((object generic-function) (dep initargs-updater) &rest initargs &key ((add-method added-method) nil am-p) @@ -546,32 +501,27 @@ and cannot be added to ~A." method other-gf gf))) ;; that the loader can't handle yet. ;; We could use NOTINLINE now that bclasp handles it, ;; but we don't need to go through make-instance's song and dance anyway. -(mlog "TOP: (let ((x (with-early-make-instance () (x (find-class 'initargs-updater)) x)))%N") (let ((x (with-early-make-instance () (x (find-class 'initargs-updater)) x))) (add-dependent #'shared-initialize x) (add-dependent #'initialize-instance x) (add-dependent #'allocate-instance x)) ;; can't satiate this one, because the environment class will vary. -(mlog "TOP: (function-to-method 'make-method-lambda%N") (function-to-method 'make-method-lambda '(gf method lambda-form environment) '(standard-generic-function standard-method t t)) ;; ditto -(mlog "TOP: (function-to-method 'expand-apply-method%N") (function-to-method 'expand-apply-method '(method method-arguments arguments env) '(standard-method t t t) nil #'std-expand-apply-method) -(mlog "TOP: (function-to-method 'compute-discriminating-function '(gf)%N") (function-to-method 'compute-discriminating-function '(gf) '(standard-generic-function) '((standard-generic-function))) -(mlog "TOP: (function-to-method 'print-object%N") (function-to-method 'print-object '(object stream) '(t t)) diff --git a/src/lisp/kernel/clos/generic.lisp b/src/lisp/kernel/clos/generic.lisp index 498b144742..33b4b2f9da 100644 --- a/src/lisp/kernel/clos/generic.lisp +++ b/src/lisp/kernel/clos/generic.lisp @@ -132,7 +132,6 @@ &aux (gfun-name (or (core:function-name gfun) name :anonymous))) (declare (ignore slot-names)) ;; Check the validity of several fields. - (mlog "standard.lisp::shared-initialize:before instance -> {} l-l-p -> {} lambda-list -> {}%N" (core:safe-repr gfun) l-l-p (core:safe-repr lambda-list)) (when a-o-p (unless l-l-p (core:simple-program-error "When defining generic function ~A @@ -184,16 +183,13 @@ Not a valid documentation object ~A" &allow-other-keys) (declare (ignore slot-names argument-precedence-order) (core:lambda-name shared-initialize.generic-function)) - (mlog "generic.lisp::shared-initialize :after entered gfun -> {} lambda-list -> {}%N" (core:safe-repr gfun) (core:safe-repr lambda-list)) ;; Coerce a method combination if required. (let ((combination (generic-function-method-combination gfun))) (unless (typep combination 'method-combination) (setf (%generic-function-method-combination gfun) (find-method-combination gfun (first combination) (rest combination))))) ;; If we have a new lambda list but no argument precedence, default the latter. - (mlog "generic.lisp::shared-initialize :after l-l-p -> {} (not a-o-p) -> {}%N" (core:safe-repr l-l-p) (core:safe-repr (not a-o-p))) (when (and l-l-p (not a-o-p)) - (mlog "generic.lisp::shared-initialize :after (lambda-list-required-arguments lambda-list)->{}%N" (core:safe-repr (lambda-list-required-arguments lambda-list))) (setf (%generic-function-argument-precedence-order gfun) (lambda-list-required-arguments lambda-list))) ;; If we have a new name, set the internal name. @@ -231,7 +227,6 @@ Not a valid documentation object ~A" (invalidate-discriminating-function gfun)) (defmethod reinitialize-instance :after ((gfun standard-generic-function) &rest initargs) - (mlog "generic.lisp::reinitialize-instance :after initargs -> {}%N" (core:safe-repr initargs)) (update-dependents gfun initargs) ;; Check if the redefinition is trivial. ;; I am not sure of the fine details here. What happens if you reinitialize-instance @@ -262,18 +257,14 @@ Not a valid documentation object ~A" (generic-function-class (class-of gfun) gfcp) (delete-methods nil) &allow-other-keys) - (mlog "In ensure-generic-function-using-class (gfun generic-function) gfun -> {} name -> {} args -> {}%N" gfun name args) ;; modify the existing object (setf args (copy-list args)) (remf args :generic-function-class) (remf args :declare) (remf args :environment) (remf args :delete-methods) - (mlog "In ensure-generic-function-using-class B%N") - (when (symbolp generic-function-class) (setf generic-function-class (find-class generic-function-class))) - (mlog "In ensure-generic-function-using-class C%N") (when gfcp ;; ANSI DEFGENERIC talks about the possibility of change-class-ing a ;; generic function, but AMOP specifically rules this possibility out. @@ -281,21 +272,15 @@ Not a valid documentation object ~A" (unless (eq generic-function-class (class-of gfun)) (error "Cannot change the class of generic function ~a from ~a to ~a. See AMOP, ENSURE-GENERIC-FUNCTION-USING-CLASS." name (class-name (class-of gfun)) (class-name generic-function-class)))) - (mlog "In ensure-generic-function-using-class D%N") (when (and method-class-p (symbolp method-class)) (setf args (list* :method-class (find-class method-class) args))) - (mlog "In ensure-generic-function-using-class E%N") (when delete-methods (dolist (m (copy-list (generic-function-methods gfun))) (when (getf (method-plist m) :method-from-defgeneric-p) (remove-method gfun m)))) - (mlog "In ensure-generic-function-using-class F%N") (if (eq (class-of gfun) generic-function-class) - (progn - (mlog "In ensure-generic-function-using-class F: About to reinitialize-instance args->{}%N" (core:safe-repr args)) - (apply #'reinitialize-instance gfun :name name args)) - (progn - (apply #'change-class gfun generic-function-class :name name args)))) + (apply #'reinitialize-instance gfun :name name args) + (apply #'change-class gfun generic-function-class :name name args))) (defmethod ensure-generic-function-using-class ((gfun null) name &rest args &key @@ -304,7 +289,6 @@ Not a valid documentation object ~A" (delete-methods nil) &allow-other-keys) (declare (ignore delete-methods gfun)) - (mlog "In ensure-generic-function-using-class (gfun null) gfun -> {} name -> {} args -> {}%N" gfun name args) ;; else create a new generic function object (setf args (copy-list args)) (remf args :generic-function-class) diff --git a/src/lisp/kernel/clos/hierarchy.lisp b/src/lisp/kernel/clos/hierarchy.lisp index 7acfe373eb..f694d4249d 100644 --- a/src/lisp/kernel/clos/hierarchy.lisp +++ b/src/lisp/kernel/clos/hierarchy.lisp @@ -21,14 +21,6 @@ (in-package "CLOS") -#+(or) -(eval-when (:compile-toplevel :execute :load-toplevel) - (push :mlog *features*) - (defmacro mlog (fmt &rest fmtargs) - `(core:fmt *error-output* ,fmt ,@fmtargs))) -;;;#+(or) -(defmacro mlog (fmt &rest fmtargs) (declare (ignore fmt fmtargs))) - ;;; ---------------------------------------------------------------------- ;;; Class SPECIALIZER diff --git a/src/lisp/kernel/clos/kernel.lisp b/src/lisp/kernel/clos/kernel.lisp index fbcd9ccca0..eb3b315460 100644 --- a/src/lisp/kernel/clos/kernel.lisp +++ b/src/lisp/kernel/clos/kernel.lisp @@ -58,8 +58,6 @@ (defun install-method (name qualifiers specializers lambda-list fun &rest options) (declare (notinline ensure-generic-function)) - (mlog "kernel.lisp::install-method name -> {} lambda-list -> {} %N" (core:safe-repr name) (core:safe-repr lambda-list)) -; (record-definition 'method `(method ,name ,@qualifiers ,specializers)) (let* ((gf (ensure-generic-function name)) (method (make-method (generic-function-method-class gf) qualifiers specializers lambda-list @@ -165,37 +163,9 @@ when (applicable-method-p method args) collect method)))) -#+mlog -(defun std-compute-applicable-methods-using-classes (gf classes) - (declare (optimize (speed 3))) - (with-early-accessors - (+eql-specializer-slots+ +standard-generic-function-slots+) - (flet ((applicable-method-p (method classes) - (loop for spec in (safe-method-specializers method) - for class in classes - always (cond ((eql-specializer-p spec) - ;; EQL specializer invalidate computation - ;; we return NIL - (when (si::of-class-p (eql-specializer-object spec) class) - (return-from std-compute-applicable-methods-using-classes - (values nil nil))) - nil) - ((si::subclassp class spec)))))) - (mlog "std-compute-applicable-methods-using-classes gf -> {} classes -> {}%N" gf (length classes)) - (let ((result (sort-applicable-methods - gf - (loop for method in (generic-function-methods gf) - when (applicable-method-p method classes) - collect method) - classes))) - (mlog " result -> {}%N" result) - (values result t))))) - -#-mlog (defun std-compute-applicable-methods-using-classes (gf classes) (declare (optimize (speed 3))) (with-early-accessors (+eql-specializer-slots+ +standard-generic-function-slots+) - (mlog "std-compute-applicable-methods-using-classes gf -> {} classes -> {}%N" (core:safe-repr gf) (length classes)) (flet ((applicable-method-p (method classes) (loop for spec in (safe-method-specializers method) for class in classes diff --git a/src/lisp/kernel/clos/standard.lisp b/src/lisp/kernel/clos/standard.lisp index 4cc6807598..c6800248cd 100644 --- a/src/lisp/kernel/clos/standard.lisp +++ b/src/lisp/kernel/clos/standard.lisp @@ -12,18 +12,11 @@ (in-package "CLOS") -#+(or) -(defmacro dbg-standard (fmt &rest args) - `(format t ,fmt ,@args)) -(defmacro dbg-standard (fmt &rest args) (declare (ignore fmt args))) - ;;; ---------------------------------------------------------------------- ;;; INSTANCES INITIALIZATION AND REINITIALIZATION ;;; (defmethod initialize-instance ((instance T) core:&va-rest initargs) - (dbg-standard "standard.lisp:29 initialize-instance unbound instance ->~a~%" (eq (core:unbound) instance)) - (mlog "standard.lisp:26 about to apply shared-initialize%N") (apply #'shared-initialize instance 'T initargs)) (defmethod reinitialize-instance ((instance T ) &rest initargs) @@ -31,13 +24,11 @@ ;; NOTE: This dynamic extent declaration relies on the fact clasp's APPLY ;; does not reuse rest lists. If it did, a method on #'shared-initialize, ;; or whatever, could potentially let the rest list escape. - (mlog "standard.lisp::reinitialize-instance instance initargs -> {}%N" (core:safe-repr initargs)) (when initargs (check-initargs-uncached (class-of instance) initargs (list (list #'reinitialize-instance (list instance)) (list #'shared-initialize (list instance t))))) - (mlog "standard.lisp:40 about to apply shared-initialize initargs -> {}%N" (core:safe-repr initargs)) (apply #'shared-initialize instance '() initargs)) (defmethod shared-initialize ((instance T) slot-names core:&va-rest initargs) @@ -61,7 +52,6 @@ ;; () ;; no slots are set from initforms ;; - (mlog "standard.lisp::shared-initialize instance -> {} initargs -> {}%N" (core:safe-repr instance) (core:list-from-vaslist initargs)) (let* ((class (class-of instance))) ;; initialize-instance slots (dolist (slotd (class-slots class)) @@ -150,7 +140,6 @@ (defmethod make-instance ((class class) &rest initargs) (declare (dynamic-extent initargs)) ; see NOTE in reinitialize-instance/T - (dbg-standard "standard.lisp:128 make-instance class ->~a~%" class) ;; Without finalization we can not find initargs. (unless (class-finalized-p class) (finalize-inheritance class)) @@ -165,8 +154,6 @@ (precompute-valid-initarg-keywords class))))) (check-initargs class initargs keywords)) (let ((instance (apply #'allocate-instance class initargs))) - #+mlog(or instance (error "allocate-instance returned NIL!!!!!!! class -> ~a initargs -> ~a" class initargs)) - (dbg-standard "standard.lisp:143 allocate-instance class -> ~a instance checking if unbound -> ~a~%" class (eq instance (core:unbound))) (apply #'initialize-instance instance initargs) instance)) @@ -242,7 +229,6 @@ ((class class) &rest initargs &key direct-slots) (declare (dynamic-extent initargs) ; see NOTE in reinitialize-instance/T (ignore initargs direct-slots)) - (dbg-standard "standard.lisp:227 initialize-instance class->~a~%" class) (finalize-unless-forward class) ;; In this case we are assigning the stamp for the first time. (core:class-new-stamp class)) @@ -252,8 +238,6 @@ &key (direct-superclasses () dscp) (direct-slots nil direct-slots-p)) (declare (dynamic-extent initargs)) ; see NOTE in reinitialize-instance/T - ;; verify that the inheritance list makes sense - (dbg-standard "standard.lisp:238 shared-initialize of class-> ~a direct-superclasses-> ~a~%" class direct-superclasses) ;;; Convert the list of direct slots into actual slot definitions. (when direct-slots-p (setf initargs @@ -321,7 +305,6 @@ (remove child (%class-direct-subclasses parent)))) (defun check-direct-superclasses (class supplied-superclasses) - (dbg-standard "check-direct-superclasses class -> ~a supplied-superclasses->~a (type-of ~a) -> ~a~%" class supplied-superclasses class (type-of class)) (if supplied-superclasses (loop for superclass in supplied-superclasses ;; Until we process streams.lisp there are some invalid combinations diff --git a/src/lisp/kernel/cmp/arguments.lisp b/src/lisp/kernel/cmp/arguments.lisp index cfdf2eb919..407d1e6648 100644 --- a/src/lisp/kernel/cmp/arguments.lisp +++ b/src/lisp/kernel/cmp/arguments.lisp @@ -38,7 +38,6 @@ ;; cc is the calling-convention object. (dolist (req (cdr reqargs)) (let ((arg (calling-convention-vaslist.va-arg cc))) - (cmp-log "(calling-convention-vaslist.va-arg cc) -> {}%N" arg) (funcall *argument-out* arg req)))) ;;; Unlike the other compile-*-arguments, this one returns a value- @@ -371,7 +370,6 @@ a_p = a_p_temp; a = a_temp; allow-other-keys calling-conv &key argument-out (safep t)) - (cmp-log "Entered compile-general-lambda-list-code%N") (let* ((*argument-out* argument-out) (nargs (calling-convention-nargs calling-conv)) (nreq (car reqargs)) @@ -415,7 +413,6 @@ a_p = a_p_temp; a = a_temp; ;; we could use it in the error check to save a subtraction, though. (compile-optional-arguments optargs nreq calling-conv iNIL iT)) (when safep - (cmp-log "Last if-too-many-arguments {} {}" cmax nargs) (compile-error-if-too-many-arguments wrong-nargs-block cmax nargs))))))) @@ -543,21 +540,13 @@ a_p = a_p_temp; a = a_temp; (multiple-value-bind (reqargs optargs rest-var key-flag keyargs allow-other-keys auxargs varest-p) (core:process-lambda-list lambda-list 'function) (declare (ignore auxargs allow-other-keys varest-p key-flag)) - (cmp-log "reqargs = {}%N" reqargs) - (cmp-log "optargs = {}%N" optargs) - (cmp-log "rest-var = {}%N" rest-var) - (cmp-log "keyargs = {}%N" keyargs) (let ((args '())) (dolist (req (rest reqargs)) - (cmp-log "req-name = {}%N" req) (push req args)) (do ((cur (rest optargs) (cdddr cur))) ((null cur) nil) (let ((opt-name (car cur)) (opt-flag (cadr cur))) - (cmp-log "opt cur = {}%N" cur) - (cmp-log "opt-name = {}%N" opt-name) - (cmp-log "opt-flag = {}%N" opt-flag) (push opt-name args) (when opt-flag (push opt-flag args)))) (when rest-var (push rest-var args)) @@ -565,8 +554,6 @@ a_p = a_p_temp; a = a_temp; ((null cur) nil) (let ((key-name (caddr cur)) (key-flag (cadddr cur))) - (cmp-log "key-name = {}%N" key-name) - (cmp-log "key-flag = {}%N" key-flag) (push key-name args) (when key-flag (push key-flag args)))) (nreverse args)))) @@ -577,7 +564,6 @@ a_p = a_p_temp; a = a_temp; ;; 2) optional arguments are ( ) ;; 3) keyword arguments are ( ) ;; this lets us cheap out on parsing, except &rest and &allow-other-keys. - (cmp-log "calculate-cleavir-lambda-list-analysis lambda-list -> {}%N" lambda-list) (let (required optional rest-type rest key aok-p key-flag (required-count 0) (optional-count 0) (key-count 0)) (dolist (item lambda-list) @@ -646,13 +632,9 @@ a_p = a_p_temp; a = a_temp; (defun compile-lambda-list-code (cleavir-lambda-list-analysis calling-conv arity &key argument-out (safep t)) "Return T if arguments were processed and NIL if they were not" - (cmp-log "about to compile-lambda-list-code cleavir-lambda-list-analysis: {}%N" cleavir-lambda-list-analysis) (multiple-value-bind (reqargs optargs rest-var key-flag keyargs allow-other-keys unused-auxs varest-p) (process-cleavir-lambda-list-analysis cleavir-lambda-list-analysis) (declare (ignore unused-auxs)) - (cmp-log " reqargs -> {}%N" reqargs) - (cmp-log " optargs -> {}%N" optargs) - (cmp-log " keyargs -> {}%N" keyargs) (cond ((eq arity :general-entry) (compile-general-lambda-list-code reqargs diff --git a/src/lisp/kernel/cmp/cmpexports.lisp b/src/lisp/kernel/cmp/cmpexports.lisp index db72e124c7..3797212aa7 100644 --- a/src/lisp/kernel/cmp/cmpexports.lisp +++ b/src/lisp/kernel/cmp/cmpexports.lisp @@ -132,9 +132,6 @@ calling-convention-vaslist.va-arg calling-convention-nargs calling-convention-register-args - cmp-log - cmp-log-dump-module - cmp-log-dump-function make-file-metadata make-function-metadata function-info diff --git a/src/lisp/kernel/cmp/cmpintrinsics.lisp b/src/lisp/kernel/cmp/cmpintrinsics.lisp index 04d41f36a7..6355232a10 100644 --- a/src/lisp/kernel/cmp/cmpintrinsics.lisp +++ b/src/lisp/kernel/cmp/cmpintrinsics.lisp @@ -634,19 +634,13 @@ Boehm and MPS use a single pointer" ;; Parse the function arguments into a calling-convention (defun initialize-calling-convention (llvm-function arity &key debug-on cleavir-lambda-list-analysis rest-alloc) - (cmp-log "llvm-function: {}%N" llvm-function) (let ((arguments (llvm-sys:get-argument-list llvm-function))) - (cmp-log "llvm-function arguments: {}%N" (llvm-sys:get-argument-list llvm-function)) - (cmp-log "llvm-function isVarArg: {}%N" (llvm-sys:is-var-arg llvm-function)) (let ((register-save-area* (when debug-on (alloca-register-save-area arity :label "register-save-area"))) (closure (first arguments))) - (cmp-log "A%N") (unless (first arguments) (error "initialize-calling-convention for arguments ~a - the closure is NIL" arguments)) - (cmp-log "A%N") (cond ((eq arity :general-entry) - (cmp-log "B%N") (let* ((nargs (second arguments)) (args (third arguments)) (vaslist* (alloca-vaslist))) @@ -694,8 +688,6 @@ Boehm and MPS use a single pointer" ;; (Maybe) generate code to store registers in memory. Return value unspecified. (defun maybe-spill-to-register-save-area (arity register-save-area* registers) - (cmp-log "maybe-spill-to-register-save-area register-save-area* -> {}%N" register-save-area*) - (cmp-log "maybe-spill-to-register-save-area registers -> {}%N" registers) (when register-save-area* (let ((words (irc-arity-info arity))) (flet ((spill-reg (idx reg addr-name) @@ -1117,7 +1109,6 @@ and initialize it with an array consisting of one function pointer." (codegen-shutdown module shutdown-function-name gcroots-in-module) (make-boot-function-global-variable module startup-shutdown-id :position startup-shutdown-id) - (cmp-log-dump-module *the-module*) (values))) @@ -1169,7 +1160,6 @@ It has appending linkage.") "-" name-suffix) :type "ll" :defaults full-directory))) - (cmp-log "Dumping module to {}%N" output-path) (ensure-directories-exist output-path) output-path)) @@ -1216,7 +1206,6 @@ they are dumped into /tmp" "If called under COMPILE-FILE the modules are dumped into the same directory as the COMPILE-FILE output. If called under COMPILE they are dumped into /tmp" - (cmp-log "About to dump module - {}%N" name-modifier) (if *compile-file-output-pathname* (compile-file-quick-module-dump module name-modifier *compile-file-debug-dump-module*) (compile-quick-module-dump module name-modifier *compile-debug-dump-module*))) diff --git a/src/lisp/kernel/cmp/cmpir.lisp b/src/lisp/kernel/cmp/cmpir.lisp index 747f235eb6..c2eeb1c74b 100644 --- a/src/lisp/kernel/cmp/cmpir.lisp +++ b/src/lisp/kernel/cmp/cmpir.lisp @@ -638,8 +638,6 @@ representing a tagged fixnum." (defun irc-prev-inst-terminator-inst-p () (let ((cur-block (irc-get-insert-block))) - (cmp-log "irc-prev-inst-terminator-inst-p dumping current block:%N") - (cmp-log " cur-block -> {}%N" cur-block) (if cur-block (if (= (llvm-sys:basic-block-size cur-block) 0) nil @@ -817,7 +815,6 @@ Otherwise do a variable shift." (defun irc-phi-add-incoming (phi-node value basic-block) (unless value - (cmp-log-dump-module *the-module*) (error "value is NULL for phi-node ~a basic-block ~a" phi-node basic-block)) (llvm-sys:add-incoming phi-node value basic-block)) @@ -1051,7 +1048,6 @@ function-description - for debugging." ;; MULTIPLE-ENTRY-POINT first return value is list of entry points (let ((rev-xep-aritys '())) (dolist (arity (list* :general-entry (subseq (list 0 1 2 3 4 5 6 7 8) +entry-point-arity-begin+ +entry-point-arity-end+))) - (cmp-log "Creating xep function for {}%N" arity) (let* ((xep-function-name (concatenate 'string function-name (format nil "-xep~a" (if (eq arity :general-entry) "" arity)))) (fn (if (generate-function-for-arity-p arity cleavir-lambda-list-analysis) (let* ((function-type (fn-prototype arity)) @@ -1066,7 +1062,6 @@ function-description - for debugging." )) (xep-arity (make-xep-arity :arity arity :function-or-placeholder fn))) (push xep-arity rev-xep-aritys))) - (cmp-log "Created xep-arities%N") (let* ((xep-aritys (nreverse rev-xep-aritys)) (entry-point-reference (irc-create-global-entry-point-reference xep-aritys module @@ -1077,7 +1072,6 @@ function-description - for debugging." :arities xep-aritys :entry-point-reference entry-point-reference :local-function local-function))) - (cmp-log "Created entry-point-info {}%N" entry-point-info) entry-point-info))) (defun irc-pointer-cast (from totype &optional (label "")) @@ -1105,9 +1099,7 @@ function-description - for debugging." (defmacro with-irbuilder ((irbuilder) &rest code) "Set *irbuilder* to the given IRBuilder" `(let ((*irbuilder* ,irbuilder)) - (cmp-log "Switching to irbuilder --> {}%N" (core:fmt nil "{}" *irbuilder*)) - (multiple-value-prog1 (progn ,@code) - (cmp-log "Leaving irbuilder --> {}%N" (core:fmt nil "{}" *irbuilder*))))) + ,@code)) ;;; ALLOCA functions @@ -1253,9 +1245,7 @@ function-description - for debugging." (ep-bc (irc-bit-cast ep-i8** %i8**% "ep-bc")) (ep-arity-i8** (irc-typed-gep %i8*% ep-bc (list arity-index) (format nil "xep-~a-i8**" arity))) (ep-arity-i8* (irc-typed-load %i8*% ep-arity-i8** (format nil "xep-~a-i8*" arity)))) - (cmp-log "Got ep-arity-i8* -> {}%N" ep-arity-i8*) - (prog1 (irc-bit-cast ep-arity-i8* function-type "ep") - (cmp-log-dump-module *the-module*)))) + (irc-bit-cast ep-arity-i8* function-type "ep"))) ;;; Our present convention is that Lisp functions uniformly have @@ -1444,17 +1434,14 @@ function-description - for debugging." (defun irc-verify-function (fn &optional (continue t)) (when *verify-llvm-functions* - (cmp-log "At top of irc-verify-function ---- about to verify-function - if there is a problem it will not return%N") (multiple-value-bind (failed-verify error-msg) (llvm-sys:verify-function fn) - (if failed-verify - (progn - (core:fmt t "!!!!!!!!!!! Function in module failed to verify !!!!!!!!!!!!!!!!!!!%N") - (core:fmt t "llvm::verifyFunction error[{}]%N" error-msg) - (if continue - (break "Error when trying to verify-function") - (error "Failed function verify"))) - (cmp-log "-------------- Function verified OK!!!!!!!%N"))))) + (when failed-verify + (core:fmt t "!!!!!!!!!!! Function in module failed to verify !!!!!!!!!!!!!!!!!!!%N") + (core:fmt t "llvm::verifyFunction error[{}]%N" error-msg) + (if continue + (break "Error when trying to verify-function") + (error "Failed function verify")))))) (defun declare-function-in-module (module dispatch-name primitive-info) (let ((return-ty (primitive-return-type primitive-info)) diff --git a/src/lisp/kernel/cmp/cmprunall.lisp b/src/lisp/kernel/cmp/cmprunall.lisp index 92d7d3cdbb..c5974a9923 100644 --- a/src/lisp/kernel/cmp/cmprunall.lisp +++ b/src/lisp/kernel/cmp/cmprunall.lisp @@ -34,12 +34,10 @@ load-time-value manager (true - in COMPILE-FILE) or not (false - in COMPILE)." )) (irbuilder-alloca (llvm-sys:make-irbuilder (thread-local-llvm-context))) (irbuilder-body (llvm-sys:make-irbuilder (thread-local-llvm-context)))) - (cmp-log "Setting special variables do-make-new-run-all%N") (let* ((*run-all-function* run-all-fn) (*irbuilder-run-all-alloca* irbuilder-alloca) (*irbuilder-run-all-body* irbuilder-body) (*current-function* run-all-fn)) - (cmp-log "Entering with-dbg-function%N") (cmp:with-guaranteed-*current-source-pos-info* () (cmp:with-dbg-function (:lineno 0 :function run-all-fn @@ -47,7 +45,6 @@ load-time-value manager (true - in COMPILE-FILE) or not (false - in COMPILE)." ;; Set up dummy debug info for these irbuilders (let ((entry-bb (irc-basic-block-create "entry" run-all-fn))) (irc-set-insert-point-basic-block entry-bb irbuilder-alloca)) - (cmp-log "bb work do-make-new-run-all%N") (let ((body-bb (irc-basic-block-create "body" run-all-fn))) (irc-set-insert-point-basic-block body-bb irbuilder-body) ;; Setup exception handling and cleanup landing pad @@ -55,9 +52,7 @@ load-time-value manager (true - in COMPILE-FILE) or not (false - in COMPILE)." (let ((entry-branch (irc-br body-bb))) (irc-set-insert-point-instruction entry-branch irbuilder-alloca) (with-irbuilder (irbuilder-body) - (progn - (cmp-log "running body do-make-new-run-all%N") - (funcall body run-all-fn)) + (funcall body run-all-fn) (irc-ret-null-t*)))))))) (values run-all-fn))) diff --git a/src/lisp/kernel/cmp/cmpsetup.lisp b/src/lisp/kernel/cmp/cmpsetup.lisp index a7a5db671d..6c0d1cc866 100644 --- a/src/lisp/kernel/cmp/cmpsetup.lisp +++ b/src/lisp/kernel/cmp/cmpsetup.lisp @@ -106,49 +106,11 @@ Options are :tagbody :go :all :eh-landing-pads (setq *compile-debug-dump-module* t) (core:fmt t "!%N!%N!\n! Turning on compiler debugging\n!\n!\n!\n")) - -;;#+(or) -(progn - (defmacro debug-print-i32 (num) (declare (ignore num)) nil) - (defmacro cmp-log-dump-function (fn) (declare (ignore fn)) nil) - (defmacro cmp-log-dump-module (fn) (declare (ignore fn)) nil) - (defmacro cmp-log (fmt &rest args) (declare (ignore fmt args)) nil) - (defun is-debug-compiler-on () nil)) - (defvar *suppress-llvm-output* nil) ;; List of function names which have been declared NOTINLINE. (defvar *notinlines* nil) -#+(or) -(progn - (eval-when (:compile-toplevel :load-toplevel :execute) - (core:fmt *error-output* "!%N!%N! WARNING - cmp-log (bclasp compiler debugging) is on - Disable the macros in cmpsetup.lisp\n!\n!\n!\n")) - (defun is-debug-compiler-on () - *debug-compiler*) - (defmacro debug-print-i32 (num) - `(if (is-debug-compiler-on) - (irc-intrinsic "debugPrintI32" (jit-constant-i32 ,num)) - nil)) - (defmacro cmp-log (fmt &rest args) - `(if (is-debug-compiler-on) - (progn - (core:fmt t "CMP-LOG ") - (core:fmt t ,fmt ,@args)) - nil))) - -(defmacro cmp-log-compile-file-dump-module (module &optional (name-modifier "")) - `(when *debug-compiler* - (compile-file-quick-module-dump ,module ,name-modifier))) - -(defmacro cmp-log-dump-function (fn) (declare (ignore fn)) nil) - -(defmacro cmp-log-dump-module (module) - `(if (is-debug-compiler-on) - (llvm-sys:dump-module ,module) - nil)) - - ;; When Cleavir is installed set the value of *cleavir-compile-hook* to use it to compile forms ;; It expects a function of one argument (lambda (form) ...) that will generate code in the ;; current *module* for the form. The lambda returns T if cleavir succeeded in compiling the form diff --git a/src/lisp/kernel/cmp/codegen-special-form.lisp b/src/lisp/kernel/cmp/codegen-special-form.lisp index c7d7193078..39968b6a50 100644 --- a/src/lisp/kernel/cmp/codegen-special-form.lisp +++ b/src/lisp/kernel/cmp/codegen-special-form.lisp @@ -116,13 +116,6 @@ (defparameter *nexti* 10000) -#+(or) -(defmacro blog (fmt &rest fargs) - `(core:fmt *error-output* ,fmt ,@fargs)) -(defmacro blog (fmt &rest fargs) - (declare (ignore fmt fargs)) - nil) - ;;; FOREIGN-CALL, FOREIGN-CALL-POINTER (defun function-type-create-on-the-fly (foreign-types) diff --git a/src/lisp/kernel/cmp/compile-file-parallel.lisp b/src/lisp/kernel/cmp/compile-file-parallel.lisp index 6ecf063e85..cbdb6dd647 100644 --- a/src/lisp/kernel/cmp/compile-file-parallel.lisp +++ b/src/lisp/kernel/cmp/compile-file-parallel.lisp @@ -1,24 +1,6 @@ (in-package :cmp) -#+(or) -(defmacro cf2-log (fmt &rest args) - `(format *error-output* ,fmt ,@args)) -(defmacro cf2-log (fmt &rest args) (declare (ignore fmt args))) - -#+(or) -(progn - (defparameter *cfp-message-mutex* (mp:make-lock :name "message-mutex")) - (defmacro cfp-log (fmt &rest args) - `(unwind-protect - (progn - (mp:get-lock *cfp-message-mutex*) - (format *error-output* ,fmt ,@args) - (finish-output *error-output*)) - (mp:giveup-lock *cfp-message-mutex*)))) -;;;#+(or) -(defmacro cfp-log (fmt &rest args) (declare (ignore fmt args))) - (defclass thread-pool () ((%queue :initarg :queue :reader thread-pool-queue) (%threads :initarg :threads :reader thread-pool-threads))) @@ -36,9 +18,7 @@ (loop for job = (core:dequeue queue :timeout 1.0 :timeout-val nil) until (eq job :quit) when job - do (cfp-log "Thread ~a working on ~s~%" - (mp:process-name mp:*current-process*) job) - (block nil + do (block nil (handler-bind ((serious-condition (lambda (e) @@ -53,10 +33,7 @@ (lambda (n) (push n (job-notes job)) (muffle-note n))) ((not (or ext:compiler-note serious-condition warning)) (lambda (c) (push c (job-other-conditions job))))) - (apply function job arguments))) - (cfp-log "Thread ~a done with job~%" - (mp:process-name mp:*current-process*))) - (cfp-log "Leaving thread ~a~%" (mp:process-name mp:*current-process*))))) + (apply function job arguments))))))) (defgeneric report-job-conditions (job) (:method ((job job)) @@ -96,15 +73,12 @@ (defun thread-pool-quit (pool) (loop with queue = (thread-pool-queue pool) for thread in (thread-pool-threads pool) - do (cfp-log "Sending two :quit (why not?) for thread ~a~%" - (mp:process-name thread)) - (core:atomic-enqueue queue :quit) + do (core:atomic-enqueue queue :quit) (core:atomic-enqueue queue :quit))) (defun thread-pool-join (pool) (loop for thread in (thread-pool-threads pool) - do (mp:process-join thread) - (cfp-log "Process-join of thread ~a~%" (mp:process-name thread)))) + do (mp:process-join thread))) ;;; @@ -175,8 +149,6 @@ (make-boot-function-global-variable module run-all-function :position (ast-job-form-index job) ))) - (cmp-log "About to verify the module%N") - (cmp-log-dump-module module) (irc-verify-module-safe module) (quick-module-dump module (format nil "preoptimize~a" (ast-job-form-index job))) ;; ALWAYS link the builtins in, inline them and then remove them. @@ -272,7 +244,6 @@ multithreaded performance that we should explore." 'cl:compile-file) #+(or cclasp eclasp)(eclector.reader:*client* cmp:*cst-client*) ast-jobs - (_ (cfp-log "Starting the pool of threads~%")) (job-args `(:optimize ,optimize :optimize-level ,optimize-level :intermediate-output-type ,intermediate-output-type)) (pool (make-thread-pool (if compile-from-module diff --git a/src/lisp/kernel/cmp/compile-file.lisp b/src/lisp/kernel/cmp/compile-file.lisp index f2aada8929..612fb2fc65 100644 --- a/src/lisp/kernel/cmp/compile-file.lisp +++ b/src/lisp/kernel/cmp/compile-file.lisp @@ -176,23 +176,16 @@ Compile a Lisp source stream and return a corresponding LLVM module." (module (llvm-create-module name)) run-all-name) (unless module (error "module is NIL")) - (cmp-log "About to with-module%N") (with-module (:module module :optimize (when optimize #'llvm-sys:optimize-module) :optimize-level optimize-level) ;; (1) Generate the code - (cmp-log "About to with-debug-info-generator%N") (with-debug-info-generator (:module *the-module* :pathname *compile-file-source-debug-pathname*) - (cmp-log "About to with-make-new-run-all%N") (with-make-new-run-all (run-all-function name) - (cmp-log "About to with-literal-table%N") (with-literal-table (:id 0) - (cmp-log "About to loop-read-and-compile-file-forms%N") (loop-read-and-compile-file-forms source-sin environment)) (setf run-all-name (llvm-sys:get-name run-all-function)))) - (cmp-log "About to verify the module%N") - (cmp-log-dump-module *the-module*) (irc-verify-module-safe *the-module*) (quick-module-dump *the-module* "preoptimize") ;; (2) Add the CTOR next diff --git a/src/lisp/kernel/cmp/compile.lisp b/src/lisp/kernel/cmp/compile.lisp index 62182d8ded..a9eb268bce 100644 --- a/src/lisp/kernel/cmp/compile.lisp +++ b/src/lisp/kernel/cmp/compile.lisp @@ -13,8 +13,6 @@ (multiple-value-prog1 (with-irbuilder ((llvm-sys:make-irbuilder (thread-local-llvm-context))) ,@body) - (cmp-log "About to optimize-module%N") - ;;(cmp-log-dump-module ,module) (when (and ,optimize ,optimize-level (null ,dry-run)) (funcall ,optimize ,module ,optimize-level ))))) (defun compile-with-hook (compile-hook definition env) diff --git a/src/lisp/kernel/cmp/debuginfo.lisp b/src/lisp/kernel/cmp/debuginfo.lisp index c77a104bff..c39f1853a4 100644 --- a/src/lisp/kernel/cmp/debuginfo.lisp +++ b/src/lisp/kernel/cmp/debuginfo.lisp @@ -80,11 +80,9 @@ (defmacro with-dbg-compile-unit ((source-pathname) &rest body) (let ((path (gensym)) - (file (gensym)) - (dir-name (gensym))) + (file (gensym))) `(let* ((,path (pathname ,source-pathname)) (,file *dbg-current-file*) - (,dir-name (directory-namestring ,path)) (*dbg-function-metadata-cache* (make-hash-table :test #'equal)) (*dbg-compile-unit* (llvm-sys:create-compile-unit *the-module-dibuilder* ; dibuilder @@ -104,11 +102,6 @@ "" ; 15 SysRoot (-isysroot value) "" ; 16 SDK ))) - (declare (ignorable ,dir-name)) ; cmp-log may expand empty - (cmp-log "with-dbg-compile-unit *dbg-compile-unit*: {}%N" *dbg-compile-unit*) - (cmp-log "with-dbg-compile-unit source-pathname: {}%N" ,source-pathname) - (cmp-log "with-dbg-compile-unit file-name: [{}]%N" ,file) - (cmp-log "with-dbg-compile-unit dir-name: [{}]%N" ,dir-name) ,@body))) (defun do-make-create-file-args (pathname logical-pathname) @@ -220,7 +213,6 @@ ,@body))) (defmacro with-dbg-function ((&key lineno function-type function) &rest body) - (cmp-log "Entered with-dbg-function%N") `(do-dbg-function (lambda () (progn ,@body)) ,lineno ,function-type ,function)) @@ -238,7 +230,6 @@ *dbg-current-scope* *dbg-current-file* lineno 0))) - (cmp-log "with-dbg-lexical-block%N") (funcall closure))) (funcall closure)))) diff --git a/src/lisp/kernel/lsp/format-pprint.lisp b/src/lisp/kernel/lsp/format-pprint.lisp index 0cbe1bf690..557731717d 100644 --- a/src/lisp/kernel/lsp/format-pprint.lisp +++ b/src/lisp/kernel/lsp/format-pprint.lisp @@ -289,7 +289,6 @@ (format-directive-params first-semi) (setf newline-string (with-output-to-string (stream) - (fmt-log "line 2609") (setf args (interpret-directive-list stream (pop segments) diff --git a/src/lisp/kernel/lsp/format.lisp b/src/lisp/kernel/lsp/format.lisp index 549cd8508e..4497ef6575 100644 --- a/src/lisp/kernel/lsp/format.lisp +++ b/src/lisp/kernel/lsp/format.lisp @@ -20,9 +20,6 @@ (in-package "SYS") -;;(defmacro fmt-log (&rest args) `(core:fmt t "FMT-LOG: {}%N" (list ,@args))) -(defmacro fmt-log (&rest args) (declare (ignore args))) - (pushnew :cdr-7 *features*) ;;;; Float printing. @@ -445,12 +442,10 @@ (*output-layout-mode* nil) (*default-format-error-control-string* string) (*logical-block-popper* nil)) - (fmt-log "line 498") (interpret-directive-list stream (tokenize-control-string string) orig-args args))))) (defun interpret-directive-list (stream directives orig-args args) - (fmt-log "interpret-directive-list directives: " directives " orig-args: " orig-args " args: " args) (if directives (let ((directive (car directives))) (etypecase directive @@ -605,7 +600,6 @@ ;;; (defmacro next-arg (&optional offset) `(progn - (fmt-log "Getting next arg from: " args) (when (null args) (error 'format-error :complaint "No more arguments." @@ -722,13 +716,11 @@ (defmacro interpret-bind-defaults (specs params &body body) (once-only ((params params)) (collect ((bindings)) - (fmt-log "line 776 specs: " specs ) (dolist (spec specs) (destructuring-bind (var default) spec (bindings `(,var (let* ((param-and-offset (pop ,params)) (offset (car param-and-offset)) (param (cdr param-and-offset))) - (fmt-log "MEISTER param-and-offset: " param-and-offset) (case param (:arg (or (next-arg offset) ,default)) (:remaining (length args)) @@ -801,7 +793,6 @@ mincol colinc minpad padchar atsignp)) (def-format-directive #\A (colonp atsignp params) - (fmt-log "format-directive A") (if params (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) @@ -1819,9 +1810,7 @@ (if atsignp :capitalize-first :downcase))))) - (fmt-log "line 2012") (setf args (interpret-directive-list stream before orig-args args)) - (fmt-log "line 2014 args: " args) after) #+(or ecl clasp) (let* ((posn (position close directives)) @@ -1831,7 +1820,6 @@ :adjustable t :fill-pointer 0))) (unwind-protect (with-output-to-string (stream string) - (fmt-log "line 2025") (setf args (interpret-directive-list stream before orig-args args))) (princ (funcall (if colonp @@ -1909,7 +1897,6 @@ remaining))) (defun expand-maybe-conditional (sublist) - (fmt-log "expand-maybe-conditional") (flet ((hairy () `(let ((prev-args args) (arg ,(expand-next-arg))) @@ -1979,50 +1966,35 @@ (def-complex-format-interpreter #\[ (colonp atsignp params directives) (multiple-value-bind - (sublists last-semi-with-colon-p remaining) + (sublists last-semi-with-colon-p remaining) (parse-conditional-directive directives) - (fmt-log "line 2174 colonp: " colonp " atsignp: " atsignp " params: " params " directives: " directives " args:" args) (setf args - (progn - (fmt-log "line 2177 args: " args) - (if atsignp - (progn - (fmt-log "line 2180 args: " args) - (if colonp + (if atsignp + (if colonp + (error 'format-error + :complaint + "Cannot specify both the colon and at-sign modifiers.") + (if (cdr sublists) (error 'format-error :complaint - "Cannot specify both the colon and at-sign modifiers.") - (progn - (fmt-log "line 2182 args:" args) - (if (cdr sublists) - (error 'format-error - :complaint - "Can only specify one section") - (progn - (fmt-log "line 2188 params: " params " args: " args) - (interpret-bind-defaults () params - (let ((prev-args args) - (arg (next-arg))) - (if arg - (progn - (fmt-log "line 2203") - (interpret-directive-list stream - (car sublists) - orig-args - prev-args)) - args)))))))) + "Can only specify one section") + (interpret-bind-defaults () params + (let ((prev-args args) + (arg (next-arg))) + (if arg + (interpret-directive-list stream + (car sublists) + orig-args + prev-args) + args))))) (if colonp (if (= (length sublists) 2) (interpret-bind-defaults () params (if (next-arg) - (progn - (fmt-log "line 2215") - (interpret-directive-list stream (car sublists) - orig-args args)) - (progn - (fmt-log "line 2218") - (interpret-directive-list stream (cadr sublists) - orig-args args)))) + (interpret-directive-list stream (car sublists) + orig-args args) + (interpret-directive-list stream (cadr sublists) + orig-args args))) (error 'format-error :complaint "Must specify exactly two sections.")) @@ -2031,12 +2003,11 @@ (pop sublists))) (last (1- (length sublists))) (sublist - (if (<= 0 index last) - (nth (- last index) sublists) - default))) - (fmt-log "2233") + (if (<= 0 index last) + (nth (- last index) sublists) + default))) (interpret-directive-list stream sublist orig-args - args))))))) + args)))))) remaining)) (def-complex-format-directive #\; () @@ -2209,10 +2180,8 @@ :control-string string :offset (1- end))))) (formatter-aux stream insides orig-args args)) - (progn - (fmt-log "line 2409") - (interpret-directive-list stream insides - orig-args args)))) + (interpret-directive-list stream insides + orig-args args))) (bind-args (orig-args args) (if colonp (let* ((arg (next-arg))