Changeset 12184


Ignore:
Timestamp:
10/10/09 12:15:20 (12 years ago)
Author:
ehuelsmann
Message:

Replace "cons + compile" with "use closure" where ever possible.

This should mean a performance increase.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/clos.lisp

    r12181 r12184  
    873873  (%init-eql-specializations gf (collect-eql-specializer-objects gf))
    874874  (set-funcallable-instance-function
    875    gf
    876    (make-closure `(lambda (&rest args)
    877                     (initial-discriminating-function ,gf args))
    878                  nil))
     875   gf #'(lambda (&rest args)
     876          (initial-discriminating-function gf args)))
    879877  ;; FIXME Do we need to warn on redefinition somewhere else?
    880878  (let ((*warn-on-redefinition* nil))
     
    12111209(defun std-compute-discriminating-function (gf)
    12121210  (let ((code
    1213          (cond ((and (= (length (generic-function-methods gf)) 1)
    1214                      (typep (car (generic-function-methods gf)) 'standard-reader-method))
    1215 ;;                 (sys::%format t "standard reader function ~S~%" (generic-function-name gf))
    1216                 (make-closure
    1217                  (let* ((method (%car (generic-function-methods gf)))
    1218                         (class (car (%method-specializers method)))
    1219                         (slot-name (reader-method-slot-name method)))
    1220                    `(lambda (arg)
    1221                       (declare (optimize speed))
    1222                       (let* ((layout (std-instance-layout arg))
    1223                              (location (get-cached-slot-location ,gf layout)))
    1224                         (unless location
    1225                           (unless (simple-typep arg ,class)
    1226                             ;; FIXME no applicable method
    1227                             (error 'simple-type-error
    1228                                    :datum arg
    1229                                    :expected-type ,class))
    1230                           (setf location (slow-reader-lookup ,gf layout ',slot-name)))
    1231                         (if (consp location)
    1232                             ;; Shared slot.
    1233                             (cdr location)
    1234                             (standard-instance-access arg location)))))
    1235                  nil))
    1236                (t
    1237                 (let* ((emf-table (classes-to-emf-table gf))
    1238                        (number-required (length (gf-required-args gf)))
    1239                        (lambda-list (%generic-function-lambda-list gf))
    1240                        (exact (null (intersection lambda-list
    1241                                                   '(&rest &optional &key
    1242                                                     &allow-other-keys &aux)))))
    1243                   (make-closure
    1244                    (cond ((= number-required 1)
    1245                           (if exact
    1246                               (cond ((and (eq (generic-function-method-combination gf) 'standard)
    1247                                           (= (length (generic-function-methods gf)) 1))
    1248                                      (let* ((method (%car (generic-function-methods gf)))
    1249                                             (specializer (car (%method-specializers method)))
    1250                                             (function (or (%method-fast-function method)
    1251                                                           (%method-function method))))
    1252                                        (if (eql-specializer-p specializer)
    1253                                            (let ((specializer-object (eql-specializer-object specializer)))
    1254                                              `(lambda (arg)
    1255                                                 (declare (optimize speed))
    1256                                                 (if (eql arg ',specializer-object)
    1257                                                     (funcall ,function arg)
    1258                                                     (no-applicable-method ,gf (list arg)))))
    1259                                            `(lambda (arg)
    1260                                               (declare (optimize speed))
    1261                                               (unless (simple-typep arg ,specializer)
    1262                                                 ;; FIXME no applicable method
    1263                                                 (error 'simple-type-error
    1264                                                        :datum arg
    1265                                                        :expected-type ,specializer))
    1266                                               (funcall ,function arg)))))
    1267                                     (t
    1268                                      `(lambda (arg)
    1269                                         (declare (optimize speed))
    1270                                         (let* ((specialization (%get-arg-specialization ,gf arg))
    1271                                                (emfun (or (gethash1 specialization ,emf-table)
    1272                                                           (slow-method-lookup-1 ,gf arg specialization))))
    1273                                           (if emfun
    1274                                               (funcall emfun (list arg))
    1275                                               (apply #'no-applicable-method ,gf (list arg)))))
    1276                                      ))
    1277                               `(lambda (&rest args)
    1278                                  (declare (optimize speed))
    1279                                  (unless (>= (length args) 1)
    1280                                    (error 'program-error
    1281                                           :format-control "Not enough arguments for generic function ~S."
    1282                                           :format-arguments (list (%generic-function-name ,gf))))
    1283                                  (let ((emfun (get-cached-emf ,gf args)))
    1284                                    (if emfun
    1285                                        (funcall emfun args)
    1286                                       (slow-method-lookup ,gf args))))))
    1287                          ((= number-required 2)
    1288                           (if exact
    1289                               `(lambda (arg1 arg2)
    1290                                  (declare (optimize speed))
    1291                                  (let* ((args (list arg1 arg2))
    1292                                         (emfun (get-cached-emf ,gf args)))
    1293                                    (if emfun
    1294                                        (funcall emfun args)
    1295                                        (slow-method-lookup ,gf args))))
    1296                               `(lambda (&rest args)
    1297                                  (declare (optimize speed))
    1298                                  (unless (>= (length args) 2)
    1299                                    (error 'program-error
    1300                                           :format-control "Not enough arguments for generic function ~S."
    1301                                           :format-arguments (list (%generic-function-name ,gf))))
    1302                                  (let ((emfun (get-cached-emf ,gf args)))
    1303                                    (if emfun
    1304                                        (funcall emfun args)
    1305                                        (slow-method-lookup ,gf args))))))
    1306                          ((= number-required 3)
    1307                           (if exact
    1308                               `(lambda (arg1 arg2 arg3)
    1309                                  (declare (optimize speed))
    1310                                  (let* ((args (list arg1 arg2 arg3))
    1311                                         (emfun (get-cached-emf ,gf args)))
    1312                                    (if emfun
    1313                                        (funcall emfun args)
    1314                                        (slow-method-lookup ,gf args))))
    1315                               `(lambda (&rest args)
    1316                                  (declare (optimize speed))
    1317                                  (unless (>= (length args) 3)
    1318                                    (error 'program-error
    1319                                           :format-control "Not enough arguments for generic function ~S."
    1320                                           :format-arguments (list (%generic-function-name ,gf))))
    1321                                  (let ((emfun (get-cached-emf ,gf args)))
    1322                                    (if emfun
    1323                                        (funcall emfun args)
    1324                                        (slow-method-lookup ,gf args))))))
    1325                          (t
    1326                           `(lambda (&rest args)
    1327                              (declare (optimize speed))
    1328                              (unless (,(if exact '= '>=) (length args) ,number-required)
    1329                                (error 'program-error
    1330                                       :format-control "Not enough arguments for generic function ~S."
    1331                                       :format-arguments (list (%generic-function-name ,gf))))
    1332                              (let ((emfun (get-cached-emf ,gf args)))
    1333                                (if emfun
    1334                                    (funcall emfun args)
    1335                                    (slow-method-lookup ,gf args))))))
    1336                    nil))))))
     1211         (cond
     1212           ((and (= (length (generic-function-methods gf)) 1)
     1213                 (typep (car (generic-function-methods gf)) 'standard-reader-method))
     1214            ;;                 (sys::%format t "standard reader function ~S~%" (generic-function-name gf))
     1215
     1216            (let* ((method (%car (generic-function-methods gf)))
     1217                   (class (car (%method-specializers method)))
     1218                   (slot-name (reader-method-slot-name method)))
     1219              #'(lambda (arg)
     1220                  (declare (optimize speed))
     1221                  (let* ((layout (std-instance-layout arg))
     1222                         (location (get-cached-slot-location gf layout)))
     1223                    (unless location
     1224                      (unless (simple-typep arg class)
     1225                        ;; FIXME no applicable method
     1226                        (error 'simple-type-error
     1227                               :datum arg
     1228                               :expected-type class))
     1229                      (setf location (slow-reader-lookup gf layout slot-name)))
     1230                    (if (consp location)
     1231                        ;; Shared slot.
     1232                        (cdr location)
     1233                        (standard-instance-access arg location))))))
     1234
     1235           (t
     1236            (let* ((emf-table (classes-to-emf-table gf))
     1237                   (number-required (length (gf-required-args gf)))
     1238                   (lambda-list (%generic-function-lambda-list gf))
     1239                   (exact (null (intersection lambda-list
     1240                                              '(&rest &optional &key
     1241                                                &allow-other-keys &aux)))))
     1242              (cond
     1243                ((= number-required 1)
     1244                 (if exact
     1245                     (cond
     1246                       ((and (eq (generic-function-method-combination gf) 'standard)
     1247                             (= (length (generic-function-methods gf)) 1))
     1248                        (let* ((method (%car (generic-function-methods gf)))
     1249                               (specializer (car (%method-specializers method)))
     1250                               (function (or (%method-fast-function method)
     1251                                             (%method-function method))))
     1252                          (if (eql-specializer-p specializer)
     1253                              (let ((specializer-object (eql-specializer-object specializer)))
     1254                                #'(lambda (arg)
     1255                                    (declare (optimize speed))
     1256                                    (if (eql arg specializer-object)
     1257                                        (funcall function arg)
     1258                                        (no-applicable-method gf (list arg)))))
     1259                              #'(lambda (arg)
     1260                                  (declare (optimize speed))
     1261                                  (unless (simple-typep arg specializer)
     1262                                    ;; FIXME no applicable method
     1263                                    (error 'simple-type-error
     1264                                           :datum arg
     1265                                           :expected-type specializer))
     1266                                  (funcall function arg)))))
     1267                       (t
     1268                        #'(lambda (arg)
     1269                            (declare (optimize speed))
     1270                            (let* ((specialization
     1271                                    (%get-arg-specialization gf arg))
     1272                                   (emfun (or (gethash1 specialization
     1273                                                        emf-table)
     1274                                              (slow-method-lookup-1
     1275                                               gf arg specialization))))
     1276                              (if emfun
     1277                                  (funcall emfun (list arg))
     1278                                  (apply #'no-applicable-method gf (list arg)))))
     1279                        ))
     1280                     #'(lambda (&rest args)
     1281                         (declare (optimize speed))
     1282                         (unless (>= (length args) 1)
     1283                           (error 'program-error
     1284                                  :format-control "Not enough arguments for generic function ~S."
     1285                                  :format-arguments (list (%generic-function-name gf))))
     1286                         (let ((emfun (get-cached-emf gf args)))
     1287                           (if emfun
     1288                               (funcall emfun args)
     1289                               (slow-method-lookup gf args))))))
     1290                ((= number-required 2)
     1291                 (if exact
     1292                     #'(lambda (arg1 arg2)
     1293                         (declare (optimize speed))
     1294                         (let* ((args (list arg1 arg2))
     1295                                (emfun (get-cached-emf gf args)))
     1296                           (if emfun
     1297                               (funcall emfun args)
     1298                               (slow-method-lookup gf args))))
     1299                     #'(lambda (&rest args)
     1300                         (declare (optimize speed))
     1301                         (unless (>= (length args) 2)
     1302                           (error 'program-error
     1303                                  :format-control "Not enough arguments for generic function ~S."
     1304                                  :format-arguments (list (%generic-function-name gf))))
     1305                         (let ((emfun (get-cached-emf gf args)))
     1306                           (if emfun
     1307                               (funcall emfun args)
     1308                               (slow-method-lookup gf args))))))
     1309                ((= number-required 3)
     1310                 (if exact
     1311                     #'(lambda (arg1 arg2 arg3)
     1312                         (declare (optimize speed))
     1313                         (let* ((args (list arg1 arg2 arg3))
     1314                                (emfun (get-cached-emf gf args)))
     1315                           (if emfun
     1316                               (funcall emfun args)
     1317                               (slow-method-lookup gf args))))
     1318                     #'(lambda (&rest args)
     1319                         (declare (optimize speed))
     1320                         (unless (>= (length args) 3)
     1321                           (error 'program-error
     1322                                  :format-control "Not enough arguments for generic function ~S."
     1323                                  :format-arguments (list (%generic-function-name gf))))
     1324                         (let ((emfun (get-cached-emf gf args)))
     1325                           (if emfun
     1326                               (funcall emfun args)
     1327                               (slow-method-lookup gf args))))))
     1328                (t
     1329                 (make-closure
     1330                  `(lambda (&rest args)
     1331                     (declare (optimize speed))
     1332                     (unless (,(if exact '= '>=) (length args) ,number-required)
     1333                       (error 'program-error
     1334                              :format-control "Not enough arguments for generic function ~S."
     1335                              :format-arguments (list (%generic-function-name ,gf))))
     1336                     (let ((emfun (get-cached-emf ,gf args)))
     1337                       (if emfun
     1338                           (funcall emfun args)
     1339                           (slow-method-lookup ,gf args)))) nil))))))))
    13371340
    13381341    (when (and (fboundp 'autocompile)
     
    14731476    (when (null primaries)
    14741477      (error "No primary methods for the generic function ~S." gf))
    1475     (cond (around
    1476            (let ((next-emfun
    1477                   (funcall
    1478                    (if (eq (class-of gf) (find-class 'standard-generic-function))
    1479                        #'std-compute-effective-method-function
    1480                        #'compute-effective-method-function)
    1481                    gf (remove around methods))))
    1482              (setf emf-form
    1483 ;;                    `(lambda (args)
    1484 ;;                       (funcall ,(%method-function around) args ,next-emfun))
    1485                    (generate-emf-lambda (%method-function around) next-emfun)
    1486                    )))
    1487           ((eq mc-name 'standard)
    1488            (let* ((next-emfun (compute-primary-emfun (cdr primaries)))
    1489                   (befores (remove-if-not #'before-method-p methods))
    1490                   (reverse-afters
    1491                    (reverse (remove-if-not #'after-method-p methods))))
    1492              (setf emf-form
    1493                    (cond ((and (null befores) (null reverse-afters))
    1494                           (if (%method-fast-function (car primaries))
    1495                               (ecase (length (gf-required-args gf))
    1496                                 (1
    1497                                  `(lambda (args)
    1498                                     (declare (optimize speed))
    1499                                     (funcall ,(%method-fast-function (car primaries)) (car args))))
    1500                                 (2
    1501                                  `(lambda (args)
    1502                                     (declare (optimize speed))
    1503                                     (funcall ,(%method-fast-function (car primaries))
    1504                                              (car args)
    1505                                              (cadr args)))))
    1506 ;;                               `(lambda (args)
    1507 ;;                                  (declare (optimize speed))
    1508 ;;                                  (funcall ,(%method-function (car primaries)) args ,next-emfun))
    1509                               (generate-emf-lambda (%method-function (car primaries))
    1510                                                    next-emfun)
    1511                               ))
    1512                          (t
    1513                           `(lambda (args)
    1514                              (declare (optimize speed))
    1515                              (dolist (before ',befores)
    1516                                (funcall (%method-function before) args nil))
    1517                              (multiple-value-prog1
    1518                               (funcall (%method-function ,(car primaries)) args ,next-emfun)
    1519                               (dolist (after ',reverse-afters)
    1520                                 (funcall (%method-function after) args nil)))))))))
     1478    (cond
     1479      (around
     1480       (let ((next-emfun
     1481              (funcall
     1482               (if (eq (class-of gf) (find-class 'standard-generic-function))
     1483                   #'std-compute-effective-method-function
     1484                   #'compute-effective-method-function)
     1485               gf (remove around methods))))
     1486         (setf emf-form
     1487;;;           `(lambda (args)
     1488;;;          (funcall ,(%method-function around) args ,next-emfun))
     1489               (generate-emf-lambda (%method-function around) next-emfun)
     1490               )))
     1491      ((eq mc-name 'standard)
     1492       (let* ((next-emfun (compute-primary-emfun (cdr primaries)))
     1493              (befores (remove-if-not #'before-method-p methods))
     1494              (reverse-afters
     1495               (reverse (remove-if-not #'after-method-p methods))))
     1496         (setf emf-form
     1497               (cond
     1498                 ((and (null befores) (null reverse-afters))
     1499                  (let ((fast-function (%method-fast-function (car primaries))))
     1500
     1501                    (if fast-function
     1502                        (ecase (length (gf-required-args gf))
     1503                          (1
     1504                           #'(lambda (args)
     1505                               (declare (optimize speed))
     1506                               (funcall fast-function (car args))))
     1507                          (2
     1508                           #'(lambda (args)
     1509                               (declare (optimize speed))
     1510                               (funcall fast-function (car args) (cadr args)))))
     1511                        ;;                               `(lambda (args)
     1512                        ;;                                  (declare (optimize speed))
     1513                        ;;                                  (funcall ,(%method-function (car primaries)) args ,next-emfun))
     1514                        (generate-emf-lambda (%method-function (car primaries))
     1515                                             next-emfun))))
     1516                 (t
     1517                  (let ((method-function (%method-function (car primaries))))
     1518
     1519                    #'(lambda (args)
     1520                        (declare (optimize speed))
     1521                        (dolist (before befores)
     1522                          (funcall (%method-function before) args nil))
     1523                        (multiple-value-prog1
     1524                            (funcall method-function args next-emfun)
     1525                          (dolist (after reverse-afters)
     1526                            (funcall (%method-function after) args nil))))))))))
    15211527          (t
    15221528           (let ((mc-obj (get mc-name 'method-combination-object)))
     
    15401546
    15411547(defun generate-emf-lambda (method-function next-emfun)
    1542   `(lambda (args)
    1543      (declare (optimize speed))
    1544      (funcall ,method-function args ,next-emfun)))
     1548  #'(lambda (args)
     1549      (declare (optimize speed))
     1550      (funcall method-function args next-emfun)))
    15451551
    15461552;;; compute an effective method function from a list of primary methods:
Note: See TracChangeset for help on using the changeset viewer.