Merge pull request #1617 from clasp-developers/cleanup-log

Cleanup log

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<core::T_O>());
   _sym_STARbuiltin_macro_function_namesSTAR->defparameter(nil<core::T_O>());
   _sym_STARbuiltin_setf_function_namesSTAR->defparameter(nil<core::T_O>());
-  _sym_STARdebug_dispatchSTAR->defparameter(nil<core::T_O>());
   _sym_STARdebug_valuesSTAR->defparameter(nil<core::T_O>());
   _sym_STARdebug_hash_tableSTAR->defparameter(nil<core::T_O>());
   _sym_STARforeign_data_reader_callbackSTAR->defparameter(nil<core::T_O>());

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

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 <whatever> ... Dispatch miss for <whatever> ..." 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.

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

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

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

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))

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,40 +257,30 @@ 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.
     ;; We go with the latter.
     (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)

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