losp/muerte/environment.lisp

   1 ;;;;------------------------------------------------------------------
   2 ;;;;
   3 ;;;;    Copyright (C) 2001-2005,
   4 ;;;;    Department of Computer Science, University of Tromso, Norway.
   5 ;;;;
   6 ;;;;    For distribution policy, see the accompanying file COPYING.
   7 ;;;;
   8 ;;;; Filename:      environment.lisp
   9 ;;;; Description:
  10 ;;;; Author:        Frode Vatvedt Fjeld <frodef@acm.org>
  11 ;;;; Created at:    Sat Oct 20 00:41:57 2001
  12 ;;;;
  13 ;;;; $Id: environment.lisp,v 1.15 2006/04/07 21:53:47 ffjeld Exp $
  14 ;;;;
  15 ;;;;------------------------------------------------------------------
  16
  17 (require :muerte/basic-macros)
  18 (provide :muerte/environment)
  19
  20 (in-package muerte)
  21
  22 (defun pprint-clumps (stream clumps &optional colon at)
  23   "A clump is the quantity of 8 bytes."
  24   (declare (ignore colon at))
  25   (cond
  26    ((< clumps 64)
  27     (format stream "~D bytes" (* clumps 8)))
  28    ((< clumps #x20000)
  29     (format stream "~D.~D KB"
  30             (truncate clumps 128)
  31             (truncate (* 10 (rem clumps 128)) 128)))
  32    (t (format stream "~D.~D MB"
  33               (truncate clumps (* 128 1024))
  34               (truncate (* 10 (rem clumps #x20000)) #x20000)))))
  35
  36 (defun room (&optional x)
  37   (declare (ignore x))
  38   (let ((clumps (malloc-cons-pointer)))
  39     (format t "Heap used: ~D clumps = ~/muerte:pprint-clumps/." clumps clumps))
  40   (values))
  41
  42 (defparameter *trace-level* 0)
  43 (defparameter *trace-escape* nil)
  44 (defvar *trace-map* nil)
  45
  46 (defun function-name-symbol (function-name)
  47   (etypecase function-name
  48     (symbol
  49      function-name)
  50     ((cons (eql setf) (cons symbol null))
  51      (gethash (cadr function-name) *setf-namespace*))))
  52
  53 (defun match-caller (name)
  54   (do ((frame (stack-frame-uplink nil (current-stack-frame))
  55               (stack-frame-uplink nil frame)))
  56       ((not (plusp frame)))
  57     (let ((f (stack-frame-funobj nil frame)))
  58       (cond
  59        ((not (typep f 'function))
  60         (return nil))
  61        ((equal name (funobj-name f))
  62         (return t))
  63        ((and (consp (funobj-name f)) (eq 'method (car (funobj-name f)))
  64              (equal name (second (funobj-name f))))
  65         (return t))
  66        ((equal name 'eval)
  67         (return nil))))))
  68
  69 (defun do-trace (function-name &key (callers t))
  70   (when (assoc function-name *trace-map* :test #'equal)
  71     (do-untrace function-name))
  72   (let ((function-symbol (function-name-symbol function-name)))
  73     (assert (fboundp function-symbol) (function-name)
  74       "Can't trace undefined function ~S." function-name)
  75     (let* ((real-function (symbol-function function-symbol))
  76            (wrapper (lambda (&rest args)
  77                       (declare (dynamic-extent args))
  78                       (if *trace-escape*
  79                           (apply real-function args)
  80                         (let ((*trace-escape* t))
  81                           (cond
  82                            ((and (not (eq t callers))
  83                                  (notany 'match-caller callers))
  84                             (apply real-function args))
  85                            (t (let ((*trace-escape* t))
  86                                 (fresh-line *trace-output*)
  87                                 (dotimes (i *trace-level*)
  88                                   (write-string "  " *trace-output*))
  89                                 (format *trace-output* "~D: (~S~{ ~S~})~%"
  90                                         *trace-level* function-name args))
  91                               (multiple-value-call
  92                                   (lambda (&rest results)
  93                                     (declare (dynamic-extent results))
  94                                     (let ((*trace-escape* t))
  95                                       (fresh-line *trace-output*)
  96                                       (dotimes (i (min *trace-level* 10))
  97                                         (write-string "  " *trace-output*))
  98                                       (format *trace-output* "~D: =>~{ ~W~^,~}.~%"
  99                                               *trace-level* results)
 100                                       (values-list results)))
 101                                 (let ((*trace-level* (1+ *trace-level*))
 102                                       (*trace-escape* nil))
 103                                   (apply real-function args))))))))))
 104       (push (cons function-name
 105                   real-function)
 106             *trace-map*)
 107       (setf (symbol-function function-symbol)
 108         wrapper)))
 109   (values))
 110
 111 (defun do-untrace (name)
 112   (let ((map (assoc name *trace-map*)))
 113     (assert map () "~S is not traced." name)
 114     (let ((function-name-symbol (function-name-symbol name))
 115           (function (cdr map)))
 116       (setf (symbol-function function-name-symbol)
 117         function)
 118       (setf *trace-map*
 119         (delete name *trace-map* :key 'car))))
 120   (values))
 121
 122 (defun time-skew-measure (mem x-lo x-hi)
 123   (declare (ignore mem))
 124   (multiple-value-bind (y-lo y-hi)
 125       (read-time-stamp-counter)
 126     (assert (<= x-hi y-hi))
 127     (- y-lo x-lo (if (< y-lo x-lo) most-negative-fixnum 0))))
 128
 129 (defun report-time (start-mem start-time-lo start-time-hi)
 130   (multiple-value-bind (end-time-lo end-time-hi)
 131       (read-time-stamp-counter)
 132     (let* ((skew (or (get 'report-time 'skew)
 133                      (setf (get 'report-time 'skew)
 134                        (loop repeat 10  ; warm up caches.
 135                            as x = (multiple-value-bind (x-lo x-hi)
 136                                       (read-time-stamp-counter)
 137                                     (constantly-true 123)
 138                                     (time-skew-measure start-mem x-lo x-hi))
 139                            finally (return x)))))
 140            (clumps (and start-mem (- (malloc-cons-pointer) start-mem)))
 141            (delta-time (+ (ash (- end-time-hi start-time-hi) 29)
 142                           (- end-time-lo start-time-lo skew))))
 143       (format t "~&;; CPU cycles: ~:D.~%~@[;; Space used: ~D clumps = ~/muerte:pprint-clumps/.~]~%"
 144               delta-time clumps clumps))))
 145
 146 (defmacro time (form)
 147   `(let ((start-mem (malloc-cons-pointer)))
 148      (multiple-value-bind (start-time-lo start-time-hi)
 149          (read-time-stamp-counter)
 150        (multiple-value-prog1
 151            ,form
 152          (report-time start-mem start-time-lo start-time-hi)))))
 153
 154 (defun describe (object &optional stream)
 155   (describe-object object (output-stream-designator stream))
 156   (values))
 157
 158 (defmethod describe-object (object stream)
 159   (format stream "Don't know how to describe ~S." object))
 160
 161 (defmethod describe-object ((object function) stream)
 162   (let ((arglist (funobj-lambda-list object)))
 163     (format stream "The function ~S takes arglist ~:A."
 164             (funobj-name object)
 165             arglist)))
 166
 167 (defun sleep (seconds)
 168   (declare (ignore seconds))
 169   (error "There is no default implementation of sleep."))
 170
 171 (defstruct random-state state)
 172 (defstruct pathname name)