[nongnu] externals/sly 6785833 37/47: clasp: implement profiling via metering

[ELPA Syncer]

branch: externals/sly
commit 678583314f94fcb450c751c2caf8e59dd4152b5c
Author: Karsten Poeck <karsten.poeck@icloud.com>
Commit: João Távora <joaotavora@gmail.com>

    clasp: implement profiling via metering
    
    * slynk/backend/clasp.lisp: Use monitor.
    * slynk/metering.lisp: Define Clasp on a bunch of things.
    
    Cherry-picked-from: SLIME commit d7b27f75d172c34c8e2ad78bae1d7953f536040b
    Co-authored-by: João Távora <joaotavora@gmail.com>
---
 slynk/backend/clasp.lisp | 28 ++++++++++++----------------
 slynk/metering.lisp      | 32 +++++++++++++++++++++++++++-----
 2 files changed, 39 insertions(+), 21 deletions(-)

diff --git a/slynk/backend/clasp.lisp b/slynk/backend/clasp.lisp
index 415f830..c5d2c9d 100644
--- a/slynk/backend/clasp.lisp
+++ b/slynk/backend/clasp.lisp
@@ -542,33 +542,29 @@
 
 ;;;; Profiling
 
-#+profile
-(progn
+;;;; as clisp and ccl
 
 (defimplementation profile (fname)
-  (when fname (eval `(profile:profile ,fname))))
+  (eval `(slynk-monitor:monitor ,fname)))         ;monitor is a macro
+
+(defimplementation profiled-functions ()
+  slynk-monitor:*monitored-functions*)
 
 (defimplementation unprofile (fname)
-  (when fname (eval `(profile:unprofile ,fname))))
+  (eval `(slynk-monitor:unmonitor ,fname)))       ;unmonitor is a macro
 
 (defimplementation unprofile-all ()
-  (profile:unprofile-all)
-  "All functions unprofiled.")
+  (slynk-monitor:unmonitor))
 
 (defimplementation profile-report ()
-  (profile:report))
+  (slynk-monitor:report-monitoring))
 
 (defimplementation profile-reset ()
-  (profile:reset)
-  "Reset profiling counters.")
-
-(defimplementation profiled-functions ()
-  (profile:profile))
+  (slynk-monitor:reset-all-monitoring))
 
-(defimplementation profile-package (package callers methods)
-  (declare (ignore callers methods))
-  (eval `(profile:profile ,(package-name (find-package package)))))
-) ; #+profile (progn ...
+(defimplementation profile-package (package callers-p methods)
+  (declare (ignore callers-p methods))
+  (slynk-monitor:monitor-all package))
 
 
 ;;;; Threads
diff --git a/slynk/metering.lisp b/slynk/metering.lisp
index d5eab93..7226b09 100644
--- a/slynk/metering.lisp
+++ b/slynk/metering.lisp
@@ -351,7 +351,7 @@ Estimated total monitoring overhead: 0.88 seconds
 ;;; Warn people using the wrong Lisp
 ;;; ********************************
 
-#-(or clisp openmcl)
+#-(or clisp openmcl clasp)
 (warn "metering.lisp does not support your Lisp implementation!")
 
 ;;; ********************************
@@ -395,14 +395,14 @@ Estimated total monitoring overhead: 0.88 seconds
 ;;; the beginning of time. time-units-per-second allows us to convert units
 ;;; to seconds.
 
-#-(or clisp openmcl)
+#-(or clasp clisp openmcl)
 (eval-when (compile eval)
   (warn
    "You may want to supply implementation-specific get-time functions."))
 
 (defconstant time-units-per-second internal-time-units-per-second)
 
-#+openmcl
+#+(or clasp openmcl)
 (progn
  (deftype time-type () 'unsigned-byte)
  (deftype consing-type () 'unsigned-byte))
@@ -449,7 +449,11 @@ Estimated total monitoring overhead: 0.88 seconds
 #+openmcl
 (defmacro get-cons () `(the consing-type (ccl::total-bytes-allocated)))
 
-#-(or clisp openmcl)
+#+clasp
+(defmacro get-cons ()
+  `(the consing-type (gctools::bytes-allocated)))
+
+#-(or clasp clisp openmcl)
 (progn
   (eval-when (compile eval)
     (warn "No consing will be reported unless a get-cons function is ~
@@ -550,7 +554,25 @@ Estimated total monitoring overhead: 0.88 seconds
         (values req-num (or (/= 0 opt-num) rest-p key-p keywords allow-p))
         (values 0 t))))
 
-#-(or clisp openmcl)
+#+clasp
+(defun required-arguments (name)
+  (multiple-value-bind (arglist foundp)
+      (core:function-lambda-list name)
+    (if foundp
+        (let ((position-and 
+               (position-if #'(lambda (x)
+                                (and (symbolp x)
+                                     (let ((name (symbol-name x)))
+                                       (and (>= (length name) 1)
+                                            (char= (schar name 0)
+                                                   #\&)))))
+                            arglist)))
+          (if position-and
+              (values position-and t)
+              (values (length arglist) nil)))
+        (values 0 t))))
+
+#-(or clasp clisp openmcl)
 (progn
  (eval-when (compile eval)
    (warn