/[cmucl]/src/pcl/combin.lisp
ViewVC logotype

Diff of /src/pcl/combin.lisp

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

revision 1.20 by gerd, Fri Sep 5 23:03:36 2003 UTC revision 1.21 by gerd, Wed Nov 5 17:01:18 2003 UTC
# Line 468  Line 468 
468                  ,body))))))                  ,body))))))
469    
470  ;;;  ;;;
471    ;;; Return true if a fast-method-call to METHOD can be inlined.
472    ;;;
473    ;;; We don't generate funcalls for standard accessor methods because
474    ;;; they have a fast function, but that's not what is actually to be
475    ;;; called.  What is called is a closure over MAKE-STD-*-METHOD-FUNCTION.
476    ;;;
477    (defun inlinable-method-p (method)
478      (and (eq *boot-state* 'complete)
479           *inline-methods-in-emfs*
480           (not (standard-accessor-method-p method))))
481    
482    ;;;
483  ;;; Return a form for calling METHOD's fast function.  METATYPES is a  ;;; Return a form for calling METHOD's fast function.  METATYPES is a
484  ;;; list of metatypes, whose length is used to figure out the names of  ;;; list of metatypes, whose length is used to figure out the names of
485  ;;; required emf parameters.  APPLY? true means the method has a &rest  ;;; required emf parameters.  REST? true means the method has a &rest
486  ;;; arg.  CALLABLE-VAR is the name of a closed-over variable  ;;; arg.  CALLABLE-VAR is the name of a closed-over variable
487  ;;; containing a FAST-METHOD-CALL instance corresponding to the  ;;; containing a FAST-METHOD-CALL instance corresponding to the
488  ;;; method invocation.  ;;; method invocation.
# Line 485  Line 497 
497      `(funcall ,fn ,cell ,next ,@req ,@(when rest? `(.dfun-rest-arg.)))))      `(funcall ,fn ,cell ,next ,@req ,@(when rest? `(.dfun-rest-arg.)))))
498    
499  ;;;  ;;;
 ;;; Return a form for successive calls to the fast functions of  
 ;;; the methods in METHODS.  LIST-VAR is the name of a  
 ;;; variable containing a list of FAST-METHOD-CALL structures  
 ;;; corresponding to the method function calls.  
 ;;;  
 (defun make-direct-calls (methods metatypes rest? list-var)  
   (collect ((calls))  
     (dolist (method methods)  
       (calls `(let ((.call. (pop .list.)))  
                 ,(make-direct-call method metatypes rest? '.call.))))  
     `(let ((.list. ,list-var))  
        (declare (ignorable .list.))  
        ,@(calls))))  
   
 ;;;  
500  ;;; Return the list of methods from a CALL-METHOD-LIST form.  ;;; Return the list of methods from a CALL-METHOD-LIST form.
501  ;;;  ;;;
502  (defun call-method-list-methods (call-method-list)  (defun call-method-list-methods (call-method-list)
503    (mapcar (lambda (call-method) (cadr call-method))    (loop for call-method-form in (cdr call-method-list)
504            (cdr call-method-list)))          collect (second call-method-form)))
505    
506  ;;;  ;;;
507  ;;; Compute a key from FORM.  This function is called via the  ;;; Compute a key from FORM.  This function is called via the
# Line 515  Line 512 
512  ;;; key, a previously compiled function can be used.  ;;; key, a previously compiled function can be used.
513  ;;;  ;;;
514  (defun memf-test-converter (form gf method-alist-p wrappers-p)  (defun memf-test-converter (form gf method-alist-p wrappers-p)
515    (case (car-safe form)    (flet ((method-key (method)
516      ;;             (if (inlinable-method-p method)
517      (call-method                 (method-function-name method)
518       (case (get-method-call-type gf form method-alist-p wrappers-p)                 '.fast-call-method.)))
519         (fast-method-call      (case (car-safe form)
520          (let ((method (cadr form)))        ;;
521            (if (and (eq *boot-state* 'complete) *inline-methods-in-emfs*)        (call-method
522                (method-function-name method)         (if (eq (get-method-call-type gf form method-alist-p wrappers-p)
523                '.fast-call-method.)))                 'fast-method-call)
524         (t '.call-method.)))             (method-key (second form))
525      ;;             '.call-method.))
526      (call-method-list        ;;
527       (case (get-method-list-call-type gf form method-alist-p wrappers-p)        (call-method-list
528         (fast-method-call         (if (eq (get-method-list-call-type gf form method-alist-p wrappers-p)
529          (if (and (eq *boot-state* 'complete) *inline-methods-in-emfs*)                 'fast-method-call)
530              (mapcar #'method-function-name (call-method-list-methods form))            (mapcar #'method-key (call-method-list-methods form))
531              '.fast-call-method-list.))            '.call-method-list.))
532         (t '.call-method-list.)))        ;;
533      ;;        (check-applicable-keywords
534      (check-applicable-keywords         'check-applicable-keywords)
535       'check-applicable-keywords)        (t
536      (t         (default-test-converter form)))))
      (default-test-converter form))))  
537    
538  ;;;  ;;;
539  ;;; This function is called via the GET-FUNCTION mechanism on forms of  ;;; This function is called via the GET-FUNCTION mechanism on forms of
# Line 545  Line 541 
541  ;;; lambda.  Second value is a list of variable names that become  ;;; lambda.  Second value is a list of variable names that become
542  ;;; closure variables.  ;;; closure variables.
543  ;;;  ;;;
544  (defun memf-code-converter (form gf metatypes applyp method-alist-p  (defun memf-code-converter (form gf metatypes rest? method-alist-p
545                              wrappers-p)                              wrappers-p)
546    (case (car-safe form)    (labels ((make-call (call-type method metatypes rest? callable-var)
547      ;;               (if (and (eq call-type 'fast-method-call)
548      ;; (CALL-METHOD <method-object> &optional <next-methods>)                        (inlinable-method-p method))
549      (call-method                   (make-direct-call method metatypes rest? callable-var)
550       (let ((method (cadr form))                   (make-emf-call metatypes rest? callable-var call-type)))
551             (callable-var (gensym))  
552             (call-type (get-method-call-type gf form method-alist-p             (make-calls (call-type methods metatypes rest? list-var)
553                                              wrappers-p)))               `(let ((.list. ,list-var))
554         (if (and (eq call-type 'fast-method-call)                  (declare (ignorable .list.))
555                  (eq *boot-state* 'complete)                  ,@(loop for method in methods collect
556                  *inline-methods-in-emfs*)                            `(let ((.call. (pop .list.)))
557             (values (make-direct-call method metatypes applyp callable-var)                               ,(make-call call-type method metatypes
558                     (list callable-var))                                           rest? '.call.))))))
559             (values (make-emf-call metatypes applyp callable-var call-type)      (case (car-safe form)
560                     (list callable-var)))))        ;;
561      ;;        ;; (CALL-METHOD <method-object> &optional <next-methods>)
562      ;; (CALL-METHOD-LIST <call-method-form>*)        (call-method
563      ;; where each CALL-METHOD form is (CALL-METHOD <method>)         (let ((method (cadr form))
564      (call-method-list               (callable-var (gensym))
565       (let ((list-var (gensym))               (call-type (get-method-call-type gf form method-alist-p
566             (call-type (get-method-list-call-type gf form method-alist-p                                                wrappers-p)))
567                                                   wrappers-p)))           (values (make-call call-type method metatypes rest? callable-var)
568         (if (and (eq call-type 'fast-method-call)                   (list callable-var))))
569                  (eq *boot-state* 'complete)        ;;
570                  *inline-methods-in-emfs*)        ;; (CALL-METHOD-LIST <call-method-form>*)
571             (let ((methods (call-method-list-methods form)))        ;; where each CALL-METHOD form is (CALL-METHOD <method>)
572               (values (make-direct-calls methods metatypes applyp list-var)        (call-method-list
573                       (list list-var)))         (let ((list-var (gensym))
574             (values `(dolist (.tem. ,list-var)               (call-type (get-method-list-call-type gf form method-alist-p
575                        ,(make-emf-call metatypes applyp '.tem. call-type))                                                     wrappers-p))
576                     (list list-var)))))               (methods (call-method-list-methods form)))
577      ;;           (values (make-calls call-type methods metatypes rest? list-var)
578      (check-applicable-keywords                   (list list-var))))
579       (values `(check-applicable-keywords .dfun-rest-arg.        ;;
580                                           .keyargs-start. .valid-keys.)        (check-applicable-keywords
581                '(.keyargs-start. .valid-keys.)))         (values `(check-applicable-keywords .dfun-rest-arg.
582      (t                                             .keyargs-start. .valid-keys.)
583       (default-code-converter form))))                 '(.keyargs-start. .valid-keys.)))
584          (t
585           (default-code-converter form)))))
586    
587  (defun memf-constant-converter (form gf)  (defun memf-constant-converter (form gf)
588    (case (car-safe form)    (case (car-safe form)

Legend:
Removed from v.1.20  
changed lines
  Added in v.1.21

  ViewVC Help
Powered by ViewVC 1.1.5