/[gcl]/gcl/pcl/pcl_dfun.lisp
ViewVC logotype

Diff of /gcl/pcl/pcl_dfun.lisp

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

revision 1.1 by camm, Wed Feb 26 22:21:39 2003 UTC revision 1.2 by camm, Thu Oct 23 15:19:32 2003 UTC
# Line 101  And so, we are saved. Line 101  And so, we are saved.
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)
# Line 165  And so, we are saved. Line 163  And so, we are saved.
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)
# Line 180  And so, we are saved. Line 180  And so, we are saved.
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  ;;;  ;;;
# Line 500  And so, we are saved. Line 501  And so, we are saved.
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)
# Line 574  And so, we are saved. Line 570  And so, we are saved.
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.
# Line 631  And so, we are saved. Line 627  And so, we are saved.
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)
# Line 731  And so, we are saved. Line 727  And so, we are saved.
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)
# Line 1006  And so, we are saved. Line 1003  And so, we are saved.
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))
# Line 1296  And so, we are saved. Line 1289  And so, we are saved.
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)
# Line 1526  And so, we are saved. Line 1523  And so, we are saved.
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))

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

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26