- (unless wrappers (error "Every metatype is T."))
- `(block dfun
- (tagbody
- (let ((field (cache-field cache))
- (cache-vector (cache-vector cache))
- (mask (cache-mask cache))
- (size (cache-size cache))
- (overflow (cache-overflow cache))
- ,@wrapper-bindings)
- (declare (fixnum size field mask))
- ,(cond ((cdr wrappers)
- (emit-greater-than-1-dlap wrappers 'miss value-reg))
- (value-reg
- (emit-1-t-dlap (car wrappers) 'miss value-reg))
- (t
- (emit-1-nil-dlap (car wrappers) 'miss)))
- (return-from dfun ,hit))
- miss
- (return-from dfun ,miss)))))
-
-(defun emit-1-nil-dlap (wrapper miss-label)
- `(let* ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper miss-label))
- (location primary))
- (declare (fixnum primary location))
- (block search
- (loop (when (eq ,wrapper (cache-vector-ref cache-vector location))
- (return-from search nil))
- (setq location (the fixnum (+ location 1)))
- (when (= location size)
- (setq location 0))
- (when (= location primary)
- (dolist (entry overflow)
- (when (eq (car entry) ,wrapper)
- (return-from search nil)))
- (go ,miss-label))))))
-
-(defmacro get-cache-vector-lock-count (cache-vector)
- `(let ((lock-count (cache-vector-lock-count ,cache-vector)))
- (unless (typep lock-count 'fixnum)
- (error "My cache got freed somehow."))
- (the fixnum lock-count)))
-
-(defun emit-1-t-dlap (wrapper miss-label value)
- `(let ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper miss-label))
- (initial-lock-count (get-cache-vector-lock-count cache-vector)))
- (declare (fixnum primary initial-lock-count))
- (let ((location primary))
- (declare (fixnum location))
- (block search
- (loop (when (eq ,wrapper (cache-vector-ref cache-vector location))
- (setq ,value (cache-vector-ref cache-vector (1+ location)))
- (return-from search nil))
- (setq location (the fixnum (+ location 2)))
- (when (= location size)
- (setq location 0))
- (when (= location primary)
- (dolist (entry overflow)
- (when (eq (car entry) ,wrapper)
- (setq ,value (cdr entry))
- (return-from search nil)))
- (go ,miss-label))))
- (unless (= initial-lock-count
- (get-cache-vector-lock-count cache-vector))
- (go ,miss-label)))))
-
-(defun emit-greater-than-1-dlap (wrappers miss-label value)
- (declare (type list wrappers))
- (let ((cache-line-size (compute-line-size (+ (length wrappers) (if value 1 0)))))
- `(let ((primary 0) (size-1 (the fixnum (- size 1))))
- (declare (fixnum primary size-1))
- ,(emit-n-wrapper-compute-primary-cache-location wrappers miss-label)
- (let ((initial-lock-count (get-cache-vector-lock-count cache-vector)))
- (declare (fixnum initial-lock-count))
- (let ((location primary) (next-location 0))
- (declare (fixnum location next-location))
- (block search
- (loop (setq next-location (the fixnum (+ location ,cache-line-size)))
- (when (and ,@(mapcar
- #'(lambda (wrapper)
- `(eq ,wrapper
- (cache-vector-ref cache-vector
- (setq location
- (the fixnum (+ location 1))))))
- wrappers))
- ,@(when value
- `((setq location (the fixnum (+ location 1)))
- (setq ,value (cache-vector-ref cache-vector location))))
- (return-from search nil))
- (setq location next-location)
- (when (= location size-1)
- (setq location 0))
- (when (= location primary)
- (dolist (entry overflow)
- (let ((entry-wrappers (car entry)))
- (when (and ,@(mapcar #'(lambda (wrapper)
- `(eq ,wrapper (pop entry-wrappers)))
- wrappers))
- ,@(when value
- `((setq ,value (cdr entry))))
- (return-from search nil))))
- (go ,miss-label))))
- (unless (= initial-lock-count
- (get-cache-vector-lock-count cache-vector))
- (go ,miss-label)))))))
-
-(defun emit-1-wrapper-compute-primary-cache-location (wrapper miss-label)
- `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref ,wrapper field)))
- (declare (fixnum wrapper-cache-no))
- (when (zerop wrapper-cache-no) (go ,miss-label))
- ,(let ((form `(logand mask wrapper-cache-no)))
- `(the fixnum ,form))))
-
-(defun emit-n-wrapper-compute-primary-cache-location (wrappers miss-label)
- (declare (type list wrappers))
- ;; This returns 1 less that the actual location.
- `(progn
- ,@(let ((adds 0) (len (length wrappers)))
- (declare (fixnum adds len))
- (mapcar #'(lambda (wrapper)
- `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref
- ,wrapper field)))
- (declare (fixnum wrapper-cache-no))
- (when (zerop wrapper-cache-no) (go ,miss-label))
- (setq primary (the fixnum (+ primary wrapper-cache-no)))
- ,@(progn
- (incf adds)
- (when (or (zerop (mod adds wrapper-cache-number-adds-ok))
- (eql adds len))
- `((setq primary
- ,(let ((form `(logand primary mask)))
- `(the fixnum ,form))))))))
- wrappers))))
-
-;;; CMU17 (and SBCL) note: Since STD-INSTANCE-P is weakened in the CMU/SBCL
-;;; approach of using funcallable instances, that branch may run
-;;; on non-pcl instances (structures). The result will be the
-;;; non-wrapper layout for the structure, which will cause a miss. The "slots"
-;;; will be whatever the first slot is, but will be ignored. Similarly,
-;;; fsc-instance-p returns true on funcallable structures as well as PCL fins.
-(defun emit-fetch-wrapper (metatype argument miss-label &optional slot)