101 |
"enabled" "disabled")) |
"enabled" "disabled")) |
102 |
(dolist (generator-entry *dfun-constructors*) |
(dolist (generator-entry *dfun-constructors*) |
103 |
(dolist (args-entry (cdr generator-entry)) |
(dolist (args-entry (cdr generator-entry)) |
104 |
(format t "~&~S ~S ~A" |
(format t "~&~S ~S" |
105 |
(cons (car generator-entry) (car args-entry)) |
(cons (car generator-entry) (caar args-entry)) |
106 |
(caddr args-entry) |
(caddr args-entry))))) |
|
(if (cadddr args-entry) "(preliminary)" ""))))) |
|
107 |
|
|
108 |
(defvar *raise-metatypes-to-class-p* t) |
(defvar *raise-metatypes-to-class-p* t) |
109 |
|
|
110 |
(defun get-dfun-constructor (generator &rest args) |
(defun get-dfun-constructor (generator &rest args) |
111 |
(when (and *raise-metatypes-to-class-p* |
(when (and *raise-metatypes-to-class-p* |
112 |
(member generator |
(member generator '(emit-checking emit-caching |
|
'(emit-checking emit-caching |
|
113 |
emit-in-checking-cache-p emit-constant-value))) |
emit-in-checking-cache-p emit-constant-value))) |
114 |
(setq args (cons (mapcar #'(lambda (mt) |
(setq args (cons (mapcar #'(lambda (mt) |
115 |
(if (eq mt 't) |
(if (eq mt 't) |
163 |
(defmacro precompile-dfun-constructors (&optional system) |
(defmacro precompile-dfun-constructors (&optional system) |
164 |
(let ((*precompiling-lap* t)) |
(let ((*precompiling-lap* t)) |
165 |
`(progn |
`(progn |
166 |
,@(gathering1 (collecting) |
,@(let ((collected ())) |
167 |
(dolist (generator-entry *dfun-constructors*) |
(dolist (generator-entry *dfun-constructors* |
168 |
|
(nreverse collected)) |
169 |
(dolist (args-entry (cdr generator-entry)) |
(dolist (args-entry (cdr generator-entry)) |
170 |
(when (or (null (caddr args-entry)) |
(when (or (null (caddr args-entry)) |
171 |
(eq (caddr args-entry) system)) |
(eq (caddr args-entry) system)) |
172 |
(when system (setf (caddr args-entry) system)) |
(when system |
173 |
(gather1 |
(setf (caddr args-entry) system)) |
174 |
|
(push |
175 |
(make-top-level-form `(precompile-dfun-constructor |
(make-top-level-form `(precompile-dfun-constructor |
176 |
,(car generator-entry)) |
,(car generator-entry)) |
177 |
'(load) |
'(load) |
180 |
',(car args-entry) |
',(car args-entry) |
181 |
',system |
',system |
182 |
,(apply (symbol-function (car generator-entry)) |
,(apply (symbol-function (car generator-entry)) |
183 |
(car args-entry)))))))))))) |
(car args-entry)))) |
184 |
|
collected)))))))) |
185 |
|
|
186 |
|
|
187 |
;;; |
;;; |
501 |
(defun caching-limit-fn (nlines) |
(defun caching-limit-fn (nlines) |
502 |
(default-limit-fn nlines)) |
(default-limit-fn nlines)) |
503 |
|
|
504 |
(defun insure-dfun (gf caching-p) |
(defun insure-caching-dfun (gf) |
505 |
(multiple-value-bind (nreq applyp metatypes nkeys) |
(multiple-value-bind (nreq applyp metatypes nkeys) |
506 |
(get-generic-function-info gf) |
(get-generic-function-info gf) |
507 |
(declare (ignore nreq nkeys)) |
(declare (ignore nreq nkeys)) |
508 |
(when (or (null metatypes) |
(when (and metatypes |
509 |
(not (null (car metatypes)))) |
(not (null (car metatypes))) |
510 |
(cond ((use-constant-value-dfun-p gf) |
(dolist (mt metatypes nil) |
511 |
(get-dfun-constructor 'emit-constant-value metatypes)) |
(unless (eq mt t) (return t)))) |
512 |
(caching-p |
(get-dfun-constructor 'emit-caching metatypes applyp)))) |
|
(get-dfun-constructor 'emit-caching metatypes applyp)) |
|
|
((dolist (mt metatypes t) (unless (eq mt 't) (return nil))) |
|
|
(get-dfun-constructor 'emit-default-only metatypes applyp)) |
|
|
(t |
|
|
(get-dfun-constructor 'emit-checking metatypes applyp)))))) |
|
513 |
|
|
514 |
(defun use-constant-value-dfun-p (gf &optional boolean-values-p) |
(defun use-constant-value-dfun-p (gf &optional boolean-values-p) |
515 |
(multiple-value-bind (nreq applyp metatypes nkeys) |
(multiple-value-bind (nreq applyp metatypes nkeys) |
570 |
;; one (non built-in) typep. |
;; one (non built-in) typep. |
571 |
;; Otherwise, it is probably at least as fast to use |
;; Otherwise, it is probably at least as fast to use |
572 |
;; a caching dfun first, possibly followed by secondary dispatching. |
;; a caching dfun first, possibly followed by secondary dispatching. |
573 |
(let ((caching-cost (caching-dfun-cost gf))) |
(let ((cdc (caching-dfun-cost gf))) |
574 |
(< (dispatch-dfun-cost gf caching-cost) caching-cost))))) |
(> cdc (dispatch-dfun-cost gf cdc)))))) |
575 |
|
|
576 |
;; Try this on print-object, find-method-combination, and documentation. |
;; Try this on print-object, find-method-combination, and documentation. |
577 |
;; Look at pcl/generic-functions.lisp for other potential test cases. |
;; Look at pcl/generic-functions.lisp for other potential test cases. |
627 |
*secondary-dfun-call-cost* |
*secondary-dfun-call-cost* |
628 |
0)))) |
0)))) |
629 |
|
|
630 |
#+cmu |
;#+cmu |
631 |
(progn |
(progn |
632 |
(setq *non-built-in-typep-cost* 100) |
(setq *non-built-in-typep-cost* 100) |
633 |
(setq *structure-typep-cost* 15) |
(setq *structure-typep-cost* 15) |
727 |
(cond ((use-dispatch-dfun-p gf caching-p) |
(cond ((use-dispatch-dfun-p gf caching-p) |
728 |
(values initial-dfun nil (initial-dispatch-dfun-info))) |
(values initial-dfun nil (initial-dispatch-dfun-info))) |
729 |
(t |
(t |
730 |
(insure-dfun gf caching-p) |
(when caching-p |
731 |
|
(insure-caching-dfun gf)) |
732 |
(values initial-dfun nil (initial-dfun-info)))) |
(values initial-dfun nil (initial-dfun-info)))) |
733 |
(make-final-dfun-internal gf classes-list))) |
(make-final-dfun-internal gf classes-list))) |
734 |
(let ((arg-info (if (early-gf-p gf) |
(let ((arg-info (if (early-gf-p gf) |
1003 |
;;; in the object argument. |
;;; in the object argument. |
1004 |
;;; |
;;; |
1005 |
(defun cache-miss-values (gf args state) |
(defun cache-miss-values (gf args state) |
1006 |
(if (null (if (early-gf-p gf) |
(multiple-value-bind (nreq applyp metatypes nkeys arg-info) |
1007 |
(early-gf-methods gf) |
(get-generic-function-info gf) |
1008 |
(generic-function-methods gf))) |
(declare (ignore nreq applyp nkeys)) |
1009 |
(apply #'no-applicable-method gf args) |
(with-dfun-wrappers (args metatypes) |
1010 |
(multiple-value-bind (nreq applyp metatypes nkeys arg-info) |
(dfun-wrappers invalid-wrapper-p wrappers classes types) |
1011 |
(get-generic-function-info gf) |
(error "The function ~S requires at least ~D arguments" |
1012 |
(declare (ignore nreq applyp nkeys)) |
gf (length metatypes)) |
1013 |
(with-dfun-wrappers (args metatypes) |
(multiple-value-bind (emf methods accessor-type index) |
1014 |
(dfun-wrappers invalid-wrapper-p wrappers classes types) |
(cache-miss-values-internal gf arg-info wrappers classes types state) |
1015 |
(error "The function ~S requires at least ~D arguments" |
(values emf methods |
1016 |
gf (length metatypes)) |
dfun-wrappers |
1017 |
(multiple-value-bind (emf methods accessor-type index) |
invalid-wrapper-p |
1018 |
(cache-miss-values-internal gf arg-info wrappers classes types state) |
accessor-type index))))) |
|
(values emf methods |
|
|
dfun-wrappers |
|
|
invalid-wrapper-p |
|
|
accessor-type index)))))) |
|
1019 |
|
|
1020 |
(defun cache-miss-values-internal (gf arg-info wrappers classes types state) |
(defun cache-miss-values-internal (gf arg-info wrappers classes types state) |
1021 |
(let* ((for-accessor-p (eq state 'accessor)) |
(let* ((for-accessor-p (eq state 'accessor)) |
1289 |
|
|
1290 |
(defun compute-precedence (lambda-list nreq argument-precedence-order) |
(defun compute-precedence (lambda-list nreq argument-precedence-order) |
1291 |
(if (null argument-precedence-order) |
(if (null argument-precedence-order) |
1292 |
(let ((list nil))(dotimes (i nreq list) (push (- (1- nreq) i) list))) |
(let ((list nil)) |
1293 |
(mapcar #'(lambda (x) (position x lambda-list)) argument-precedence-order))) |
(dotimes (i nreq list) |
1294 |
|
(declare (fixnum i)) |
1295 |
|
(push (- (1- nreq) i) list))) |
1296 |
|
(mapcar #'(lambda (x) (position x lambda-list)) |
1297 |
|
argument-precedence-order))) |
1298 |
|
|
1299 |
(defun saut-and (specl type) |
(defun saut-and (specl type) |
1300 |
(let ((applicable nil) |
(let ((applicable nil) |
1523 |
(generic-function-name generic-function))) |
(generic-function-name generic-function))) |
1524 |
(ocache (gf-dfun-cache generic-function))) |
(ocache (gf-dfun-cache generic-function))) |
1525 |
(set-dfun generic-function dfun cache info) |
(set-dfun generic-function dfun cache info) |
1526 |
(let* ((dfun (if early-p |
(let ((dfun (if early-p |
1527 |
(or dfun (make-initial-dfun generic-function)) |
(or dfun (make-initial-dfun generic-function)) |
1528 |
(compute-discriminating-function generic-function))) |
(compute-discriminating-function generic-function)))) |
|
(info (gf-dfun-info generic-function))) |
|
|
(unless (eq 'default-method-only (type-of info)) |
|
|
(setq dfun (doctor-dfun-for-the-debugger |
|
|
generic-function |
|
|
#+cmu dfun #-cmu (set-function-name dfun gf-name)))) |
|
1529 |
(set-funcallable-instance-function generic-function dfun) |
(set-funcallable-instance-function generic-function dfun) |
1530 |
#+cmu (set-function-name generic-function gf-name) |
#+cmu (set-function-name generic-function gf-name) |
1531 |
(when (and ocache (not (eq ocache cache))) (free-cache ocache)) |
(when (and ocache (not (eq ocache cache))) (free-cache ocache)) |