/[slime]/slime/metering.lisp
ViewVC logotype

Diff of /slime/metering.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2 by aruttenberg, Mon Sep 13 05:35:14 2004 UTC revision 1.3 by lgorrie, Fri Apr 1 18:24:53 2005 UTC
# Line 1  Line 1 
1  ;;; -*- Mode: LISP; Package: monitor; Syntax: Common-lisp; Base: 10.;  -*-  ;;; -*- Mode: LISP; Package: monitor; Syntax: Common-lisp; Base: 10.;  -*-
2  ;;; Tue Jan 25 18:32:28 1994 by Mark Kantrowitz <mkant@GLINDA.OZ.CS.CMU.EDU>  ;;; Tue Jan 25 18:32:28 1994 by Mark Kantrowitz <mkant@GLINDA.OZ.CS.CMU.EDU>
 ;;; metering.cl -- 56711 bytes  
3    
4  ;;; ****************************************************************  ;;; ****************************************************************
5  ;;; Metering System ************************************************  ;;; Metering System ************************************************
# Line 22  Line 21 
21  ;;; This code is in the public domain and is distributed without warranty  ;;; This code is in the public domain and is distributed without warranty
22  ;;; of any kind.  ;;; of any kind.
23  ;;;  ;;;
24  ;;; Bug reports, comments, and suggestions should be sent to mkant@cs.cmu.edu.  ;;; This copy is from SLIME, http://www.common-lisp.net/project/slime/
25  ;;;  ;;;
26  ;;;  ;;;
27    
# Line 58  Line 57 
57  ;;; 01-JAN-93 mk  v2.0  Support for MCL 2.0, CMU CL 16d, Allegro V3.1/4.0/4.1,  ;;; 01-JAN-93 mk  v2.0  Support for MCL 2.0, CMU CL 16d, Allegro V3.1/4.0/4.1,
58  ;;;                     Lucid 4.0, ibcl  ;;;                     Lucid 4.0, ibcl
59  ;;; 25-JAN-94 mk  v2.1  Patches for CLISP from Bruno Haible.  ;;; 25-JAN-94 mk  v2.1  Patches for CLISP from Bruno Haible.
60    ;;; 01-APR-05 lgorrie   Removed support for all Lisps except CLISP and OpenMCL.
61    ;;;                     Purely to cut down on stale code (e.g. #+cltl2) in this
62    ;;;                     version that is bundled with SLIME.
63    ;;;
64  ;;;  ;;;
65    
66  ;;; ********************************  ;;; ********************************
# Line 345  Estimated total monitoring overhead: 0.8 Line 347  Estimated total monitoring overhead: 0.8
347  ;;; ****************************************************************  ;;; ****************************************************************
348    
349  ;;; ********************************  ;;; ********************************
350  ;;; Fix up the *features* list *****  ;;; Warn people using the wrong Lisp
351  ;;; ********************************  ;;; ********************************
352    
353  (eval-when (compile load eval)  #-(or clisp openmcl)
354    ;; The *features* list for Macintosh Allegro Common Lisp 1.3.2  (warn "metering.lisp does not support your Lisp implementation!")
   ;; isn't really unambiguous, so we add the :mcl1.3.2 feature.  
   (when (or (and (string-equal (lisp-implementation-type)  
                                "Macintosh Allegro Common Lisp")  
                  (string-equal (lisp-implementation-version)  
                                "1.3.2"))  
             (and (find :ccl *features*)  
                  (not (find :lispworks *features*))  
                  (not (find :mcl *features*))))  
     (pushnew :mcl1.3.2 *features*))  
   ;; We assume that :mcl means version 2.0 or greater. If it doesn't,  
   ;; use :mcl2.0 which is defined by:  
   (when (or (and (string-equal (lisp-implementation-type)  
                                "Macintosh Common Lisp")  
                  (string-equal (lisp-implementation-version)  
                                "Version 2.0"))  
             (and (find :ccl *features*)  
                  (find :ccl-2 *features*)  
                  (not (find :lispworks *features*))  
                  (find :mcl *features*)))  
     (pushnew :mcl2.0 *features*))  
   )  
   
 ;;; Let's be smart about CLtL2 compatible Lisps:  
 (eval-when (compile load eval)  
   #+(or (and :excl (or :allegro-v4.0 (and :allegro-version>= (version>= 4 1))))  
         :mcl  
         :cmu)  
   (pushnew :cltl2 *features*))  
355    
356  ;;; ********************************  ;;; ********************************
357  ;;; Packages ***********************  ;;; Packages ***********************
358  ;;; ********************************  ;;; ********************************
359    
 #-(or cltl2 ansi-cl)  
 (in-package "MONITOR" :nicknames '("MON"))  
   
360  ;;; For CLtL2 compatible lisps  ;;; For CLtL2 compatible lisps
361    
 #+(and :excl (or :allegro-v4.0 (and :allegro-version>= (version>= 4 1))))  
 (defpackage "MONITOR" (:nicknames "MON") (:use "COMMON-LISP")  
   (:import-from cltl1 provide require))  
 #+:mcl  
 (defpackage "MONITOR" (:nicknames "MON") (:use "COMMON-LISP")  
   (:import-from ccl provide require))  
 #+(or :clisp :lispworks :cmu :sbcl)  
362  (defpackage "MONITOR" (:nicknames "MON") (:use "COMMON-LISP")  (defpackage "MONITOR" (:nicknames "MON") (:use "COMMON-LISP")
363    (:export "*MONITORED-FUNCTIONS*"    (:export "*MONITORED-FUNCTIONS*"
364             "MONITOR" "MONITOR-ALL" "UNMONITOR" "MONITOR-FORM"             "MONITOR" "MONITOR-ALL" "UNMONITOR" "MONITOR-FORM"
# Line 405  Estimated total monitoring overhead: 0.8 Line 369  Estimated total monitoring overhead: 0.8
369             "DISPLAY-MONITORING-RESULTS"             "DISPLAY-MONITORING-RESULTS"
370             "MONITORING-ENCAPSULATE" "MONITORING-UNENCAPSULATE"             "MONITORING-ENCAPSULATE" "MONITORING-UNENCAPSULATE"
371             "REPORT"))             "REPORT"))
 #+(and :cltl2  
        (not (or (and :excl (or :allegro-v4.0 (and :allegro-version>=  
                                                   (version>= 4 1))))  
                 :mcl :clisp :lispworks  
                 :cmu)))  
 (unless (find-package "MONITOR")  
   (make-package "MONITOR" :nicknames '("MON") :use '("COMMON-LISP")))  
   
 #+(or cltl2 ansi-cl)  
372  (in-package "MONITOR")  (in-package "MONITOR")
373    
   
 #+(and :excl :allegro-v4.0)  
 (cltl1:provide "monitor")  
 #+(and :excl :allegro-version>= (version>= 4 1) :openmcl)  
 (provide "monitor")  
 #+(and :mcl (not :openmcl))  
 (ccl:provide "monitor")  
 #+(and :cltl2  
        (not (or (and :excl (or :allegro-v4.0 (and :allegro-version>=  
                                                   (version>= 4 1))))  
                 :mcl  
                 :cmu)))  
 (provide "monitor")  
 #-:cltl2  
 (provide "monitor")  
   
 (export '(*monitored-functions*  
           monitor monitor-all unmonitor monitor-form  
           with-monitoring  
           reset-monitoring-info reset-all-monitoring  
           monitored  
           report-monitoring  
           display-monitoring-results  
           monitoring-encapsulate monitoring-unencapsulate  
           report))  
   
   
374  ;;; Warn user if they're loading the source instead of compiling it first.  ;;; Warn user if they're loading the source instead of compiling it first.
375  (eval-when (eval)  (eval-when (eval)
376     (warn "This file should be compiled before loading for best results."))     (warn "This file should be compiled before loading for best results."))
# Line 460  Estimated total monitoring overhead: 0.8 Line 388  Estimated total monitoring overhead: 0.8
388  ;;; ****************************************************************  ;;; ****************************************************************
389    
390  ;;; ********************************  ;;; ********************************
 ;;; Type Definitions ***************  
 ;;; ********************************  
   
 #+(or cmu sbcl)  
 (eval-when (compile load eval)  
   (deftype time-type () '(unsigned-byte 32))  
   (deftype consing-type () '(unsigned-byte 32)))  
   
 ;;; ********************************  
391  ;;; Timing Functions ***************  ;;; Timing Functions ***************
392  ;;; ********************************  ;;; ********************************
393  ;;; The get-time function is called to find the total number of ticks since  ;;; The get-time function is called to find the total number of ticks since
394  ;;; the beginning of time. time-units-per-second allows us to convert units  ;;; the beginning of time. time-units-per-second allows us to convert units
395  ;;; to seconds.  ;;; to seconds.
396    
397  (progn  #-(or clisp openmcl)
398    #-(or :cmu  (eval-when (compile eval)
399          :clisp    (warn
400          :allegro-v3.1 :allegro-v4.0 :allegro-v4.1 :allegro-v5.0.1     "You may want to supply implementation-specific get-time functions."))
         :mcl :mcl1.3.2  
         :lcl3.0 :lcl4.0)  
   (eval-when (compile eval)  
     (warn  
      "You may want to supply implementation-specific get-time functions."))  
401    
402    (defconstant time-units-per-second internal-time-units-per-second)  (defconstant time-units-per-second internal-time-units-per-second)
403    
404    (defmacro get-time ()  (defmacro get-time ()
405      `(the time-type (get-internal-run-time)))    `(the time-type (get-internal-run-time)))
 )  
406    
407  ;;; NOTE: In Macintosh Common Lisp, CCL::GCTIME returns the number of  ;;; NOTE: In Macintosh Common Lisp, CCL::GCTIME returns the number of
408  ;;;       milliseconds spent during GC. We could subtract this from  ;;;       milliseconds spent during GC. We could subtract this from
# Line 500  Estimated total monitoring overhead: 0.8 Line 413  Estimated total monitoring overhead: 0.8
413  ;;;       cost of doing business, and will average out in the long run.  ;;;       cost of doing business, and will average out in the long run.
414  ;;;       If it seems really important to a user that GC times not be  ;;;       If it seems really important to a user that GC times not be
415  ;;;       counted, then uncomment the following three lines and read-time  ;;;       counted, then uncomment the following three lines and read-time
416  ;;;       conditionalize the definition of get-time above with #-:mcl.  ;;;       conditionalize the definition of get-time above with #-:openmcl.
417  ;#+:mcl  ;#+openmcl
418  ;(defmacro get-time ()  ;(defmacro get-time ()
419  ;  `(the time-type (- (get-internal-run-time) (ccl:gctime))))  ;  `(the time-type (- (get-internal-run-time) (ccl:gctime))))
420    
# Line 511  Estimated total monitoring overhead: 0.8 Line 424  Estimated total monitoring overhead: 0.8
424  ;;; The get-cons macro is called to find the total number of bytes  ;;; The get-cons macro is called to find the total number of bytes
425  ;;; consed since the beginning of time.  ;;; consed since the beginning of time.
426    
427  #+:cmu  #+clisp
 (defmacro get-cons ()  
   "The get-cons macro is called to find the total number of bytes  
    consed since the beginning of time."  
 ;  #-:new-compiler  
 ;  '(ext:get-bytes-consed)  
 ;  #+:new-compiler  
   '(the consing-type (ext:get-bytes-consed)))  
   
 #+:clisp  
428  (defun get-cons ()  (defun get-cons ()
429    (multiple-value-bind (real1 real2 run1 run2 gc1 gc2 space1 space2 gccount)    (multiple-value-bind (real1 real2 run1 run2 gc1 gc2 space1 space2 gccount)
430        (sys::%%time)        (sys::%%time)
431      (declare (ignore real1 real2 run1 run2 gc1 gc2 gccount))      (declare (ignore real1 real2 run1 run2 gc1 gc2 gccount))
432      (dpb space1 (byte 24 24) space2)))      (dpb space1 (byte 24 24) space2)))
433    
 ;;; Lucid. 4 bytes/word. This returns bytes.  
 ;;; For some reason this doesn't work properly under Lucid 4.0, but  
 ;;; that's OK, because they have PC-based profiling which is more accurate.  
 #+(or :lcl3.0 :lcl4.0)  
 (defmacro get-cons () `(the consing-type (gc-size)))  
   
 ;;; Allegro V4.0/1. SYS::GSGC-MAP takes one argument, and returns an  
 ;;; array representing the memory state.  
 #+(or :allegro-v4.0 :allegro-v4.1 :allegro-v5.0.1)  
 (defvar *gc-space-array* (make-array 4 :element-type '(unsigned-byte 32)))  
 #+(or :allegro-v4.0 :allegro-v4.1 :allegro-v5.0.1)  
 (defun bytes-consed ()  
   (system::gsgc-totalloc *gc-space-array* t)  
   (aref *gc-space-array* 0))  
   
 #+:allegro-v3.1  
 (defun bytes-consed ()  
   (let ((gs (sys::gsgc-map)))  
     (+ (aref gs 3)                      ; new space  
        (let ((sum 0))                   ; old space  
          (dotimes (i (1+ (floor (/ (- (length gs) 13) 10))))  
            (incf sum (aref gs (+ (* i 10) 13))))  
          sum)))  
   )  
   
 #+(or :allegro-v3.1 :allegro-v4.0 :allegro-v4.1 :allegro-v5.0.1)  
 (defmacro get-cons () `(the consing-type (bytes-consed)))  
   
 ;;; Macintosh Allegro Common Lisp 1.3.2  
 ;;; Based on CCL's sample code for memory usage.  
 ;;; They key trick here is that we maintain the information about total  
 ;;; consing since time zero by keeping track of how much memory was free  
 ;;; before and after gc (by advising gc). Luckily, MACL's garbage collection  
 ;;; seems to always be invoked internally by calling GC.  
 ;;;  
 ;;; Maybe instead of showing bytes consed since time zero, we should  
 ;;; return bytes consed since the first time the function is called?  
 ;;; And the first time the function is called, it should set the  
 ;;; value to zero. No real need to do this -- what we have works fine,  
 ;;; and involves less code.  
 #+:mcl1.3.2  
 (in-package :ccl)  
   
 #+:mcl1.3.2  
 (defvar *bytes-consed-chkpt* 0)  
   
 #+:mcl1.3.2  
 (defun reset-consing () (setq *bytes-consed-chkpt* 0))  
   
 (eval-when (eval compile)  
   #+:mcl1.3.2(defconstant $currentA5 #x904)  
   #+:mcl1.3.2(defconstant $pagecounts #x-18e)  
   #+:mcl1.3.2(defconstant $lstFP #x-a42)  
   #+:mcl1.3.2(defconstant $consfirstob 64)  
   #+:mcl1.3.2(defconstant $pagesize 4096))  
   
 #+:mcl1.3.2  
 (let ((old-gc (symbol-function 'gc))  
       (ccl:*warn-if-redefine-kernel* nil))  
   (setf (symbol-function 'gc)  
         #'(lambda ()  
             (let ((old-consing (total-bytes-consed)))  
               (prog1  
                 (funcall old-gc)  
                 (incf *bytes-consed-chkpt*  
                       (- old-consing (total-bytes-consed))))))))  
   
 #+:mcl1.3.2  
 (defun total-bytes-consed (&aux pages fp)  
   "Returns number of conses (8 bytes each)"  
   (let* ((a5 (%get-ptr $currentA5))  
          (ptr (%inc-ptr a5 $pagecounts)))  
     (%ilsr 3 (%i+ (%i- (%ilsl 12 (%i- (setq pages (%get-word ptr 0)) 1))  
                        (%i* pages $consfirstob))  
                    (if (eq 0 (setq fp (%get-long a5 $lstFP)))  
                        $pagesize  
                      (%ilogand2 #xfff fp))))))  
   
 #+:mcl1.3.2  
 (in-package "MONITOR")  
   
 #+:mcl1.3.2  
 (defun get-cons ()  
   (the consing-type (+ (ccl::total-bytes-consed) ccl::*bytes-consed-chkpt*)))  
   
434  ;;; Macintosh Common Lisp 2.0  ;;; Macintosh Common Lisp 2.0
435  ;;; Note that this includes bytes that were allocated during GC.  ;;; Note that this includes bytes that were allocated during GC.
436  ;;; We could subtract this out by advising GC like we did under  ;;; We could subtract this out by advising GC like we did under
# Line 621  Estimated total monitoring overhead: 0.8 Line 440  Estimated total monitoring overhead: 0.8
440  ;;; avoid the consing values being too lopsided. If a user really really  ;;; avoid the consing values being too lopsided. If a user really really
441  ;;; wants to subtract out the consing during GC, replace the following  ;;; wants to subtract out the consing during GC, replace the following
442  ;;; two lines with the commented out code.  ;;; two lines with the commented out code.
443  #+:mcl  #+openmcl
444  (defmacro get-cons () `(the consing-type (ccl::total-bytes-allocated)))  (progn
445  ;#+:mcl    (defmacro get-cons () `(the consing-type (ccl::total-bytes-allocated)))
446  ;(in-package :ccl)    (in-package :ccl)
447  ;#+:mcl    (defvar *bytes-consed-chkpt* 0)
448  ;(defvar *bytes-consed-chkpt* 0)    (defun reset-consing () (setq *bytes-consed-chkpt* 0))
449  ;#+:mcl    (let ((old-gc (symbol-function 'gc))
450  ;(defun reset-consing () (setq *bytes-consed-chkpt* 0))          (ccl:*warn-if-redefine-kernel* nil))
451  ;#+:mcl      (setf (symbol-function 'gc)
452  ;(let ((old-gc (symbol-function 'gc))            #'(lambda ()
453  ;      (ccl:*warn-if-redefine-kernel* nil))                (let ((old-consing (total-bytes-consed)))
454  ;  (setf (symbol-function 'gc)                  (prog1
455  ;       #'(lambda ()                      (funcall old-gc)
456  ;           (let ((old-consing (total-bytes-consed)))                    (incf *bytes-consed-chkpt*
457  ;             (prog1                          (- old-consing (total-bytes-consed))))))))
458  ;               (funcall old-gc)    (defun total-bytes-consed ()
459  ;               (incf *bytes-consed-chkpt*      "Returns number of conses (8 bytes each)"
460  ;                     (- old-consing (total-bytes-consed))))))))      (ccl::total-bytes-allocated))
461  ;#+:mcl    (in-package "MONITOR")
462  ;(defun total-bytes-consed ()    (defun get-cons ()
463  ;  "Returns number of conses (8 bytes each)"      (the consing-type (+ (ccl::total-bytes-consed) ccl::*bytes-consed-chkpt*))))
464  ;  (ccl::total-bytes-allocated))  
465  ;#+:mcl  
466  ;(in-package "MONITOR")  #-(or clisp openmcl)
 ;#+:mcl  
 ;(defun get-cons ()  
 ;  (the consing-type (+ (ccl::total-bytes-consed) ccl::*bytes-consed-chkpt*)))  
   
   
 #-(or :cmu  
       :clisp  
       :lcl3.0 :lcl4.0  
       :allegro-v3.1 :allegro-v4.0 :allegro-v4.1 :allegro-v5.0.1  
       :mcl1.3.2 :mcl)  
467  (progn  (progn
468    (eval-when (compile eval)    (eval-when (compile eval)
469      (warn "No consing will be reported unless a get-cons function is ~      (warn "No consing will be reported unless a get-cons function is ~
# Line 676  Estimated total monitoring overhead: 0.8 Line 485  Estimated total monitoring overhead: 0.8
485                 (,delta-cons (- (get-cons) ,start-cons)))                 (,delta-cons (- (get-cons) ,start-cons)))
486             ,@post-process)))))             ,@post-process)))))
487    
488  #+:clisp  #+clisp
489  (defmacro delta4 (nv1 nv2 ov1 ov2 by)  (progn
490    `(- (dpb (- ,nv1 ,ov1) (byte ,by ,by) ,nv2) ,ov2))    (defmacro delta4 (nv1 nv2 ov1 ov2 by)
491  #+:clisp                        ; CLISP 2.29 built-in      `(- (dpb (- ,nv1 ,ov1) (byte ,by ,by) ,nv2) ,ov2))
492  (let ((del (find-symbol "DELTA4" "SYS")))  
493    (when del (setf (fdefinition 'delta4) (fdefinition del))))    (let ((del (find-symbol "DELTA4" "SYS")))
494  #+:clisp      (when del (setf (fdefinition 'delta4) (fdefinition del))))
495  (if (< internal-time-units-per-second 1000000)  
496      ;; TIME_1: AMIGA, OS/2, UNIX_TIMES    (if (< internal-time-units-per-second 1000000)
497      (defmacro delta4-time (new-time1 new-time2 old-time1 old-time2)        ;; TIME_1: AMIGA, OS/2, UNIX_TIMES
498        `(delta4 ,new-time1 ,new-time2 ,old-time1 ,old-time2 16))        (defmacro delta4-time (new-time1 new-time2 old-time1 old-time2)
499      ;; TIME_2: other UNIX, WIN32          `(delta4 ,new-time1 ,new-time2 ,old-time1 ,old-time2 16))
500      (defmacro delta4-time (new-time1 new-time2 old-time1 old-time2)        ;; TIME_2: other UNIX, WIN32
501        `(+ (* (- ,new-time1 ,old-time1) internal-time-units-per-second)        (defmacro delta4-time (new-time1 new-time2 old-time1 old-time2)
502            (- ,new-time2 ,old-time2))))          `(+ (* (- ,new-time1 ,old-time1) internal-time-units-per-second)
503  #+:clisp              (- ,new-time2 ,old-time2))))
504  (defmacro delta4-cons (new-cons1 new-cons2 old-cons1 old-cons2)  
505    `(delta4 ,new-cons1 ,new-cons2 ,old-cons1 ,old-cons2 24))    (defmacro delta4-cons (new-cons1 new-cons2 old-cons1 old-cons2)
506        `(delta4 ,new-cons1 ,new-cons2 ,old-cons1 ,old-cons2 24))
507  ;; avoid consing: when the application conses a lot,  
508  ;; get-cons may return a bignum, so we really should not use it.    ;; avoid consing: when the application conses a lot,
509  #+:clisp    ;; get-cons may return a bignum, so we really should not use it.
510  (defmacro with-time/cons ((delta-time delta-cons) form &body post-process)    (defmacro with-time/cons ((delta-time delta-cons) form &body post-process)
511    (let ((beg-cons1 (gensym "BEG-CONS1-")) (end-cons1 (gensym "END-CONS1-"))      (let ((beg-cons1 (gensym "BEG-CONS1-")) (end-cons1 (gensym "END-CONS1-"))
512          (beg-cons2 (gensym "BEG-CONS2-")) (end-cons2 (gensym "END-CONS2-"))            (beg-cons2 (gensym "BEG-CONS2-")) (end-cons2 (gensym "END-CONS2-"))
513          (beg-time1 (gensym "BEG-TIME1-")) (end-time1 (gensym "END-TIME1-"))            (beg-time1 (gensym "BEG-TIME1-")) (end-time1 (gensym "END-TIME1-"))
514          (beg-time2 (gensym "BEG-TIME2-")) (end-time2 (gensym "END-TIME2-"))            (beg-time2 (gensym "BEG-TIME2-")) (end-time2 (gensym "END-TIME2-"))
515          (re1 (gensym)) (re2 (gensym)) (gc1 (gensym)) (gc2 (gensym)))            (re1 (gensym)) (re2 (gensym)) (gc1 (gensym)) (gc2 (gensym)))
516      `(multiple-value-bind (,re1 ,re2 ,beg-time1 ,beg-time2        `(multiple-value-bind (,re1 ,re2 ,beg-time1 ,beg-time2
517                             ,gc1 ,gc2 ,beg-cons1 ,beg-cons2) (sys::%%time)                                    ,gc1 ,gc2 ,beg-cons1 ,beg-cons2) (sys::%%time)
518         (declare (ignore ,re1 ,re2 ,gc1 ,gc2))           (declare (ignore ,re1 ,re2 ,gc1 ,gc2))
519         (multiple-value-prog1 ,form           (multiple-value-prog1 ,form
520           (multiple-value-bind (,re1 ,re2 ,end-time1 ,end-time2             (multiple-value-bind (,re1 ,re2 ,end-time1 ,end-time2
521                                 ,gc1 ,gc2 ,end-cons1 ,end-cons2) (sys::%%time)                                        ,gc1 ,gc2 ,end-cons1 ,end-cons2) (sys::%%time)
522             (declare (ignore ,re1 ,re2 ,gc1 ,gc2))               (declare (ignore ,re1 ,re2 ,gc1 ,gc2))
523             (let ((,delta-time (delta4-time ,end-time1 ,end-time2               (let ((,delta-time (delta4-time ,end-time1 ,end-time2
524                                             ,beg-time1 ,beg-time2))                                               ,beg-time1 ,beg-time2))
525                   (,delta-cons (delta4-cons ,end-cons1 ,end-cons2                     (,delta-cons (delta4-cons ,end-cons1 ,end-cons2
526                                             ,beg-cons1 ,beg-cons2)))                                               ,beg-cons1 ,beg-cons2)))
527               ,@post-process))))))                 ,@post-process)))))))
528    
529  ;;; ********************************  ;;; ********************************
530  ;;; Required Arguments *************  ;;; Required Arguments *************
# Line 728  Estimated total monitoring overhead: 0.8 Line 537  Estimated total monitoring overhead: 0.8
537  ;;; arguments.  The function Required-Arguments returns two values: the first  ;;; arguments.  The function Required-Arguments returns two values: the first
538  ;;; is the number of required arguments, and the second is T iff there are any  ;;; is the number of required arguments, and the second is T iff there are any
539  ;;; non-required arguments (e.g. &optional, &rest, &key).  ;;; non-required arguments (e.g. &optional, &rest, &key).
 #+cmu  
 (progn  
   #| #-new-compiler  
   (defun required-arguments (name)  
     (let ((function (symbol-function name)))  
       (if (eql (system:%primitive get-type function) system:%function-type)  
           (let ((min (ldb system:%function-min-args-byte  
                           (system:%primitive header-ref function  
                                              system:%function-min-args-slot)))  
                 (max (ldb system:%function-max-args-byte  
                           (system:%primitive header-ref function  
                                              system:%function-max-args-slot)))  
                 (rest (ldb system:%function-rest-arg-byte  
                            (system:%primitive header-ref function  
                                               system:%function-rest-arg-slot)))  
                 (key (ldb system:%function-keyword-arg-byte  
                           (system:%primitive  
                            header-ref function  
                            system:%function-keyword-arg-slot))))  
             (values min (or (/= min max) (/= rest 0) (/= key 0))))  
           (values 0 t))))  
   |#  
   #| #+new-compiler  
   (defun required-arguments (name)  
     (let* ((function (symbol-function name))  
            (stype (system:%primitive get-vector-subtype function)))  
       (if (eql stype system:%function-entry-subtype)  
           (let* ((args (cadr (system:%primitive  
                               header-ref  
                               function  
                               system:%function-entry-type-slot)))  
                  (pos (position-if #'(lambda (x)  
                                        (and (symbolp x)  
                                             (let ((name (symbol-name x)))  
                                               (and (>= (length name) 1)  
                                                    (char= (schar name 0)  
                                                           #\&)))))  
                                    args)))  
             (if pos  
                 (values pos t)  
                 (values (length args) nil)))  
           (values 0 t)))))|#  
   
   (defun required-arguments (name)  
     (let ((type (ext:info function type name)))  
       (cond ((not (kernel:function-type-p type))  
              (warn "No argument count information available for:~%  ~S~@  
                   Allow for &rest arg consing."  
                    name)  
              (values 0 t))  
             (t  
              (values (length (kernel:function-type-required type))  
                      (if (or (kernel:function-type-optional type)  
                              (kernel:function-type-keyp type)  
                              (kernel:function-type-rest type))  
                          t nil))))))  
 )  
540    
541  ;;; Lucid, Allegro, and Macintosh Common Lisp  ;;; Lucid, Allegro, and Macintosh Common Lisp
542  #+(OR :lcl3.0 :lcl4.0 :excl :mcl)  #+openmcl
543  (defun required-arguments (name)  (defun required-arguments (name)
544    (let* ((function (symbol-function name))    (let* ((function (symbol-function name))
545           (args #+:excl(excl::arglist function)           (args (ccl:arglist function))
                #+:mcl(ccl:arglist function)  
                #-(or :excl :mcl)(arglist function))  
546           (pos (position-if #'(lambda (x)           (pos (position-if #'(lambda (x)
547                                 (and (symbolp x)                                 (and (symbolp x)
548                                      (let ((name (symbol-name x)))                                      (let ((name (symbol-name x)))
# Line 804  Estimated total monitoring overhead: 0.8 Line 554  Estimated total monitoring overhead: 0.8
554          (values pos t)          (values pos t)
555          (values (length args) nil))))          (values (length args) nil))))
556    
557  ;;; Macintosh Allegro Common Lisp version 1.3.2  #+clisp
 #+:mcl1.3.2  
 (defun required-arguments (name)  
   (let ((arguments-string  
          (let ((the-string  
                 (with-output-to-string (*standard-output*)  
                     (ccl:arglist-to-stream name *standard-output*))))  
            (cond ((and (>=  (length the-string) 23)  
                        (string-equal (subseq the-string 0 22)  
                                      "Can't find arglist for")) nil)  
                  ((position  #\( the-string :test 'char-equal) the-string)  
                  (T  (concatenate 'string "(" the-string ")"))))))  
     (if (null arguments-string)  
         (values 0 t)  
       (let* ((pos (position #\& arguments-string))  
              (args (length (read-from-string  
                             (concatenate 'string  
                                          (subseq arguments-string 0 pos)  
                                          ")")))))  
         (if pos  
             (values args t)  
           (values args nil))))))  
   
 #+:clisp  
558  (defun required-arguments (name)  (defun required-arguments (name)
559    (multiple-value-bind (name req-num opt-num rest-p key-p keywords allow-p)    (multiple-value-bind (name req-num opt-num rest-p key-p keywords allow-p)
560        (sys::function-signature name t)        (sys::function-signature name t)
# Line 835  Estimated total monitoring overhead: 0.8 Line 562  Estimated total monitoring overhead: 0.8
562          (values req-num (or (/= 0 opt-num) rest-p key-p keywords allow-p))          (values req-num (or (/= 0 opt-num) rest-p key-p keywords allow-p))
563          (values 0 t))))          (values 0 t))))
564    
565  #-(or :cmu :clisp :lcl3.0 :lcl4.0 :mcl1.3.2 :mcl :excl)  #-(or clisp openmcl)
566  (progn  (progn
567   (eval-when (compile eval)   (eval-when (compile eval)
568     (warn     (warn
# Line 954  variables/arrays/structures." Line 681  variables/arrays/structures."
681  ;;;  ;;;
682  (defstruct metering-functions  (defstruct metering-functions
683    (name nil)    (name nil)
684    (old-definition #-cmu nil    (old-definition nil :type function)
685                    #+cmu    (new-definition nil :type function)
686                    (error "Missing required keyword argument :old-definition")    (read-metering  nil :type function)
687                    :type function)    (reset-metering nil :type function))
   (new-definition #-cmu nil  
                   #+cmu  
                   (error "Missing required keyword argument :new-definition")  
                   :type function)  
   (read-metering  #-cmu nil  
                   #+cmu  
                   (error "Missing required keyword argument :read-metering")  
                   :type function)  
   (reset-metering #-cmu nil  
                   #+cmu  
                   (error "Missing required keyword argument :reset-metering")  
                   :type function))  
688    
689  ;;; In general using hash tables in time-critical programs is a bad idea,  ;;; In general using hash tables in time-critical programs is a bad idea,
690  ;;; because when one has to grow the table and rehash everything, the  ;;; because when one has to grow the table and rehash everything, the
# Line 1078  adjusted for overhead." Line 793  adjusted for overhead."
793           (setf (place-function name)           (setf (place-function name)
794                 #'(lambda (,@required-args                 #'(lambda (,@required-args
795                            ,@(when optionals-p                            ,@(when optionals-p
796                                    #+cmu `(c:&more arg-context arg-count)                                `(&rest optional-args)))
                                   #-cmu `(&rest optional-args)))  
797                     (let ((prev-total-time *total-time*)                     (let ((prev-total-time *total-time*)
798                           (prev-total-cons *total-cons*)                           (prev-total-cons *total-cons*)
799                           (prev-total-calls *total-calls*)                           (prev-total-calls *total-calls*)
# Line 1093  adjusted for overhead." Line 807  adjusted for overhead."
807                       (with-time/cons (delta-time delta-cons)                       (with-time/cons (delta-time delta-cons)
808                         ;; form                         ;; form
809                         ,(if optionals-p                         ,(if optionals-p
810                              #+cmu `(multiple-value-call                              `(apply old-definition
811                                         old-definition                                      ,@required-args optional-args)
                                      (values ,@required-args)  
                                      (c:%more-arg-values arg-context  
                                                          0  
                                                          arg-count))  
                             #-cmu `(apply old-definition  
                                           ,@required-args optional-args)  
812                              `(funcall old-definition ,@required-args))                              `(funcall old-definition ,@required-args))
813                         ;; post-processing:                         ;; post-processing:
814                         ;; Calls                         ;; Calls

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.3

  ViewVC Help
Powered by ViewVC 1.1.5