home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 9 / 09.iso / e / e070 / 4.ddi / LISPLIB / UTIL.LSP < prev    next >
Encoding:
Text File  |  1984-11-06  |  3.6 KB  |  102 lines
  1. ;;; (C) Copyright 1984 by Gold Hill Computers
  2.  
  3. ;;;     An excution timer
  4.  
  5. ;;; Usage:
  6. ;;;     (TIME form) - macro
  7. ;;;        Form is the form to be timed.  Since TIME is
  8. ;;;        a macro form is not evaluated.
  9.  
  10. ;;; Usage:
  11. ;;;    (EVAL-TIME form) - function
  12. ;;;       Where form is the form to be timed.  In this case
  13. ;;;       form is evaluated.
  14.  
  15. ;;; Example:
  16. ;;;    (TIME (DOTIMES (I 10000)))
  17. ;;;        This will time the empty loop.
  18.  
  19. (DEFMACRO TIME X
  20.   `(EVAL-TIME ',(CAR X)))
  21.  
  22. (DEFUN EVAL-TIME (FORM)
  23.   (LET (START FINISH S-HSEC F-HSEC S-SEC F-SEC S-MIN F-MIN VALS)
  24.     (FORMAT *trace-output* "~&Evaluating: ~A" FORM)
  25.     ;; read the start time.
  26.     (MULTIPLE-VALUE-SETQ (NIL NIL NIL S-MIN START)
  27.       (%SYSINT #X21 #X2C00 0 0 0))
  28.     ;; Eval the form.
  29.     (SETQ VALS (MULTIPLE-VALUE-LIST (EVAL FORM)))
  30.     ;; Read the end time.
  31.     (MULTIPLE-VALUE-SETQ (NIL NIL NIL F-MIN FINISH)
  32.       (%SYSINT #X21 #X2C00 0 0 0))
  33.     ;; Unpack start and end times.
  34.     (SETQ S-HSEC (LOGAND START #X0FF)
  35.       F-HSEC (LOGAND FINISH #X0FF)
  36.       S-SEC (LSH START -8)
  37.       F-SEC (LSH FINISH -8)
  38.       S-MIN (LOGAND #X0FF S-MIN)
  39.       F-MIN (LOGAND #X0FF F-MIN))
  40.     (SETQ F-HSEC (- F-HSEC S-HSEC))            ; calc hundreths
  41.     (IF (MINUSP F-HSEC)
  42.         (SETQ F-HSEC (+ F-HSEC 100)
  43.           F-SEC (1- F-SEC)))
  44.     (SETQ F-SEC (- F-SEC S-SEC))            ; calc seconds
  45.     (IF (MINUSP F-SEC)
  46.         (SETQ F-SEC (+ F-SEC 60)
  47.           F-MIN (1- F-MIN)))
  48.     (SETQ F-MIN (- F-MIN S-MIN))            ; calc minutes
  49.     (IF (MINUSP F-MIN) (INCF F-MIN 60))
  50.     (FORMAT *trace-output* "~&Elapsed time: ~D:~:[~D~;0~D~].~:[~D~;0~D~]~%"
  51.       F-MIN (< F-SEC 10.) F-SEC (< F-HSEC 10) F-HSEC)
  52.     (VALUES-LIST VALS)))
  53.  
  54. ;;; This give data on the storage system and available memory.
  55. ;;; If the first arg is non-NIL then more detailed information is printed.
  56. ;;; If the second arg is NIL the GC is not performed.
  57. (DEFUN ROOM (&OPTIONAL DETAIL-P (GCP T))
  58.   (LET ((CNS 0) (FCNS 0) (OBJV 0) (FOBJV 0)(LSIZE 0.0))
  59.     (WHEN GCP
  60.       (FORMAT T "~&GC...")        ; do the GC
  61.       (GC))
  62.     (FORMAT T "~% GC data as of last GC (# ~D)" (ARRAY-LEADER *GC-DATA* 1))
  63.     (WHEN DETAIL-P
  64.       (FORMAT T "~%~%  Region    Type   Start    Length   Free"))
  65.     (DO ((I 0 (+ I 9))
  66.          (X)(Y))
  67.         ((= (AREF *GC-DATA* I) #X0FF))
  68.       (SETQ Y (LOGIOR (LSH (AREF *GC-DATA* (+ I 8)) 8)        ; free
  69.                   (AREF *GC-DATA* (+ I 7)))
  70.         X (LOGIOR (LSH (AREF *GC-DATA* (+ I 6)) 8)        ; length
  71.               (AREF *GC-DATA* (+ I 5)))
  72.         LSIZE (+ LSIZE 
  73.              (LSH X -10)
  74.              (/ (LOGAND X #X3FF) 1024)))        ; total size
  75.       (WHEN DETAIL-P
  76.        (FORMAT T "~%    ~D     ~:[  CONS~;  ATOM~]~:[ ~;*~]  ~X:~X   ~U    ~U"
  77.                 (TRUNCATE I 9)                    ; region #
  78.             (LOGBITP 0 (AREF *GC-DATA* I))            ; type
  79.             (LOGBITP 1 (AREF *GC-DATA* I))            ; static or not
  80.             (LOGIOR (LSH (AREF *GC-DATA* (+ I 4)) 8)    ; segment
  81.                 (AREF *GC-DATA* (+ I 3)))
  82.             (LOGIOR (LSH (AREF *GC-DATA* (+ I 2)) 8)    ; offset
  83.                 (AREF *GC-DATA* (+ I 1)))
  84.             X                        ; length
  85.             (IF (ZEROP (LOGAND 1 (AREF *GC-DATA* I)))    
  86.                 (*& 9 Y)                    ; cons case
  87.             Y)))
  88.     (COND ((NOT (LOGBITP 0 (AREF *GC-DATA* I)))            ; cons
  89.        (SETQ CNS (+& CNS (/& X 9)))
  90.            (SETQ FCNS (+& FCNS Y)))
  91.       (T                            ; objv
  92.        (SETQ OBJV (+& OBJV (/& X 1024.)))
  93.        (SETQ FOBJV (+& FOBJV (/& Y 1024.))))))
  94.     (WHEN DETAIL-P (FORMAT T "~%* indicates a static storage region."))
  95.     (FORMAT T "~%~% Approximately ~DK atom space and ~U conses"
  96.         OBJV CNS)
  97.     (FORMAT T "~% of which ~DK atom space and ~U conses are free."
  98.           FOBJV FCNS)
  99.     (FORMAT T "~% This lisp occupies ~AK bytes of memory.~%" LSIZE)
  100. ))
  101.  
  102.