Changeset 13099


Ignore:
Timestamp:
Oct 25, 2009, 11:14:43 PM (10 years ago)
Author:
gb
Message:

Add and use a lock in the type-cache stuff. Defer errors that occur
while the lock is held. Both things probably add some undesirable
overhead, but the total lack of thread safety that's been here has
been causing real problems.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-1/l1-typesys.lisp

    r13067 r13099  
    14871487  (logand (sxhash spec) type-cache-mask))
    14881488
     1489
    14891490(let* ((type-cache-specs (make-array type-cache-size))
    14901491       (type-cache-ctypes (make-array type-cache-size))
     
    14921493       (hits 0)
    14931494       (ncleared 0)
    1494        (locked nil))
     1495       (locked nil)
     1496       (lock (make-lock)))
    14951497 
    14961498  (defun clear-type-cache ()
    1497     (%init-misc 0 type-cache-specs)
    1498     (%init-misc 0 type-cache-ctypes)
    1499     (incf ncleared)
     1499    (with-lock-grabbed (lock)
     1500      (%init-misc 0 type-cache-specs)
     1501      (%init-misc 0 type-cache-ctypes)
     1502      (incf ncleared))
    15001503    nil)
    15011504
     
    15041507      (let* ((class-ctype (%class.ctype spec)))
    15051508        (or (class-ctype-translation class-ctype) class-ctype))
    1506       (if locked
    1507         (or (values-specifier-type-internal spec env)
    1508             (make-unknown-ctype :specifier spec))
    1509         (unwind-protect
    1510           (progn
    1511             (setq locked t)
    1512             (if (or (symbolp spec)
    1513                     (and (consp spec)
    1514                          (symbolp (car spec))
    1515                          ;; hashing scheme uses equal, so only use when equivalent to eql
    1516                          (not (and (eq (car spec) 'member)
    1517                                    (some (lambda (x)
    1518                                            (typep x '(or cons string bit-vector pathname)))
    1519                                          (cdr spec))))))
    1520               (let* ((idx (hash-type-specifier spec)))
    1521                 (incf probes)
    1522                 (if (equal (svref type-cache-specs idx) spec)
    1523                   (progn
    1524                     (incf hits)
    1525                     (svref type-cache-ctypes idx))
    1526                   (let* ((ctype (values-specifier-type-internal spec env)))
    1527                     (if ctype
    1528                       (progn
    1529                         (when (cacheable-ctype-p ctype)
    1530                           (setf (svref type-cache-specs idx) (copy-tree spec)       ; in case it was stack-consed
    1531                                 (svref type-cache-ctypes idx) ctype))
    1532                         ctype)
    1533                       (make-unknown-ctype :specifier spec)))))
    1534               (values-specifier-type-internal spec env)))
    1535           (setq locked nil)))))
     1509      (handler-case
     1510          (with-lock-grabbed (lock)
     1511            (if locked
     1512              (or (values-specifier-type-internal spec env)
     1513                  (make-unknown-ctype :specifier spec))
     1514              (unwind-protect
     1515                   (progn
     1516                     (setq locked t)
     1517                     (if (or (symbolp spec)
     1518                             (and (consp spec)
     1519                                  (symbolp (car spec))
     1520                                  ;; hashing scheme uses equal, so only use when equivalent to eql
     1521                                  (not (and (eq (car spec) 'member)
     1522                                            (some (lambda (x)
     1523                                                    (typep x '(or cons string bit-vector pathname)))
     1524                                                  (cdr spec))))))
     1525                       (let* ((idx (hash-type-specifier spec)))
     1526                         (incf probes)
     1527                         (if (equal (svref type-cache-specs idx) spec)
     1528                           (progn
     1529                             (incf hits)
     1530                             (svref type-cache-ctypes idx))
     1531                           (let* ((ctype (values-specifier-type-internal spec env)))
     1532                             (if ctype
     1533                               (progn
     1534                                 (when (cacheable-ctype-p ctype)
     1535                                   (setf (svref type-cache-specs idx) (copy-tree spec) ; in case it was stack-consed
     1536                                         (svref type-cache-ctypes idx) ctype))
     1537                                 ctype)
     1538                               (make-unknown-ctype :specifier spec)))))
     1539                       (values-specifier-type-internal spec env)))
     1540                (setq locked nil))))
     1541        (error (condition) (error condition)))))
    15361542 
    15371543  (defun type-cache-hit-rate ()
     
    15431549  (defun lock-type-cache ()
    15441550    (setq locked t)))
    1545 
    15461551                   
    15471552
Note: See TracChangeset for help on using the changeset viewer.