;;; Retain expansion, but only use it opportunistically.
(deftype inlinep () '(member :inline :maybe-inline :notinline nil))
\f
-;;;; the POLICY macro
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
-
-;;; a helper function for the POLICY macro: Look up a named optimization
-;;; quality in POLICY.
-(declaim (ftype (function (policy symbol) policy-quality)))
-(defun policy-quality (policy quality-name)
- (the policy-quality
- (cdr (assoc quality-name policy))))
-
-;;; A helper function for the POLICY macro: Return a list of symbols
-;;; naming the qualities which appear in EXPR.
-(defun policy-qualities-used-by (expr)
- (let ((result nil))
- (labels ((recurse (x)
- (if (listp x)
- (map nil #'recurse x)
- (when (policy-quality-p x)
- (pushnew x result)))))
- (recurse expr)
- result)))
-
-) ; EVAL-WHEN
-
-;;; syntactic sugar for querying optimization policy qualities
-;;;
-;;; Evaluate EXPR in terms of the current optimization policy for
-;;; NODE, or if NODE is NIL, in terms of the current policy as defined
-;;; by *DEFAULT-POLICY* and *CURRENT-POLICY*. (Using NODE=NIL is only
-;;; well-defined during IR1 conversion.)
-;;;
-;;; EXPR is a form which accesses the policy values by referring to
-;;; them by name, e.g. (> SPEED SPACE).
-(defmacro policy (node expr)
- (let* ((n-policy (gensym))
- (binds (mapcar (lambda (name)
- `(,name (policy-quality ,n-policy ',name)))
- (policy-qualities-used-by expr))))
- (/show "in POLICY" expr binds)
- `(let* ((,n-policy (lexenv-policy ,(if node
- `(node-lexenv ,node)
- '*lexenv*)))
- ,@binds)
- ,expr)))
-\f
;;;; source-hacking defining forms
;;; to be passed to PARSE-DEFMACRO when we want compiler errors
(values (cdr ,n-res) t)
(values nil nil))))
\f
-;;; These functions are called by the expansion of the DEFPRINTER
-;;; macro to do the actual printing.
-(declaim (ftype (function (symbol t stream &optional t) (values))
- defprinter-prin1 defprinter-princ))
-(defun defprinter-prin1 (name value stream &optional indent)
- (declare (ignore indent))
- (defprinter-prinx #'prin1 name value stream))
-(defun defprinter-princ (name value stream &optional indent)
- (declare (ignore indent))
- (defprinter-prinx #'princ name value stream))
-(defun defprinter-prinx (prinx name value stream)
- (declare (type function prinx))
- (write-char #\space stream)
- (when *print-pretty*
- (pprint-newline :linear stream))
- (format stream ":~A " name)
- (funcall prinx value stream)
- (values))
-
-;; Define some kind of reasonable PRINT-OBJECT method for a STRUCTURE-OBJECT.
-;;
-;; NAME is the name of the structure class, and CONC-NAME is the same as in
-;; DEFSTRUCT.
-;;
-;; The SLOT-DESCS describe how each slot should be printed. Each SLOT-DESC can
-;; be a slot name, indicating that the slot should simply be printed. A
-;; SLOT-DESC may also be a list of a slot name and other stuff. The other stuff
-;; is composed of keywords followed by expressions. The expressions are
-;; evaluated with the variable which is the slot name bound to the value of the
-;; slot. These keywords are defined:
-;;
-;; :PRIN1 Print the value of the expression instead of the slot value.
-;; :PRINC Like :PRIN1, only princ the value
-;; :TEST Only print something if the test is true.
-;;
-;; If no printing thing is specified then the slot value is printed as PRIN1.
-;;
-;; The structure being printed is bound to STRUCTURE and the stream is bound to
-;; STREAM.
-(defmacro defprinter ((name &key (conc-name (concatenate 'simple-string
- (symbol-name name)
- "-")))
- &rest slot-descs)
- (flet ((sref (slot-name)
- `(,(symbolicate conc-name slot-name) structure)))
- (collect ((prints))
- (dolist (slot-desc slot-descs)
- (if (atom slot-desc)
- (prints `(defprinter-prin1 ',slot-desc ,(sref slot-desc) stream))
- (let ((sname (first slot-desc))
- (test t))
- (collect ((stuff))
- (do ((option (rest slot-desc) (cddr option)))
- ((null option)
- (prints
- `(let ((,sname ,(sref sname)))
- (when ,test
- ,@(or (stuff)
- `((defprinter-prin1 ',sname ,sname
- stream)))))))
- (case (first option)
- (:prin1
- (stuff `(defprinter-prin1 ',sname ,(second option)
- stream)))
- (:princ
- (stuff `(defprinter-princ ',sname ,(second option)
- stream)))
- (:test (setq test (second option)))
- (t
- (error "bad DEFPRINTER option: ~S" (first option)))))))))
-
- `(def!method print-object ((structure ,name) stream)
- (print-unreadable-object (structure stream :type t)
- (pprint-logical-block (stream nil)
- ;;(pprint-indent :current 2 stream)
- ,@(prints)))))))
-\f
-;;;; the Event statistics/trace utility
+;;;; the EVENT statistics/trace utility
;;; FIXME: This seems to be useful for troubleshooting and
;;; experimentation, not for ordinary use, so it should probably
(eval-when (:compile-toplevel :load-toplevel :execute)
-(defstruct event-info
+(defstruct (event-info (:copier nil))
;; The name of this event.
(name (required-argument) :type symbol)
;; The string rescribing this event.
projects / sbcl.git / blobdiff