Menu
▾
▴
[Sbcl-commits] master: Use one fewer variable in SB-PCL::EMIT-CACHE-LOOKUP
|
From: Douglas K. <sn...@us...> - 2014-11-30 02:49:11
|
The branch "master" has been updated in SBCL:
via 884ef36df8a85f64cd91dc7ec44952deb6587952 (commit)
from 2e7a98ac187300ee5ac349ab02206c6d01277f67 (commit)
- Log -----------------------------------------------------------------
commit 884ef36df8a85f64cd91dc7ec44952deb6587952
Author: Douglas Katzman <do...@go...>
Date: Sat Nov 29 21:46:36 2014 -0500
Use one fewer variable in SB-PCL::EMIT-CACHE-LOOKUP
and sprinkle some comments around.
---
src/pcl/cache.lisp | 69 +++++++++++++++++++++++++++++++---------------------
src/pcl/dlisp.lisp | 46 ++++++++++++++++++++++------------
2 files changed, 71 insertions(+), 44 deletions(-)
diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp
index c0c6abc..68346ba 100644
--- a/src/pcl/cache.lisp
+++ b/src/pcl/cache.lisp
@@ -184,40 +184,53 @@
;;; number of keys and presence of values in the cache is known
;;; beforehand.
(defun emit-cache-lookup (cache-var layout-vars miss-tag value-var)
- (let ((line-size (power-of-two-ceiling (+ (length layout-vars)
- (if value-var 1 0)))))
- (with-unique-names (n-index n-vector n-depth n-pointer n-mask
- MATCH-WRAPPERS EXIT-WITH-HIT)
- `(let* ((,n-index (hash-layout-or ,(car layout-vars) (go ,miss-tag)))
- (,n-vector (cache-vector ,cache-var))
- (,n-mask (cache-mask ,cache-var)))
- (declare (index ,n-index))
+ (with-unique-names (probe n-vector n-depth n-mask
+ MATCH-WRAPPERS EXIT-WITH-HIT)
+ (let* ((num-keys (length layout-vars))
+ (pointer
+ ;; We don't need POINTER if the cache has 1 key and no value,
+ ;; or if FOLD-INDEX-ADDRESSING is supported, in which case adding
+ ;; a constant to the base index for each cell-ref yields better code.
+ #-(or x86 x86-64)
+ (when (or (> num-keys 1) value-var) (make-symbol "PTR")))
+ (line-size (power-of-two-ceiling (+ num-keys (if value-var 1 0)))))
+ `(let ((,n-mask (cache-mask ,cache-var))
+ (,probe (hash-layout-or ,(car layout-vars) (go ,miss-tag))))
+ (declare (index ,probe))
,@(mapcar (lambda (layout-var)
- `(mixf ,n-index (hash-layout-or ,layout-var (go ,miss-tag))))
+ `(mixf ,probe (hash-layout-or ,layout-var (go ,miss-tag))))
(cdr layout-vars))
;; align with cache lines
- (setf ,n-index (logand ,n-index ,n-mask))
+ (setf ,probe (logand ,probe ,n-mask))
(let ((,n-depth (cache-depth ,cache-var))
- (,n-pointer ,n-index))
- (declare (index ,n-depth ,n-pointer))
+ (,n-vector (cache-vector ,cache-var))
+ ,@(when pointer `((,pointer ,probe))))
+ (declare (index ,n-depth ,@(when pointer (list pointer))))
(tagbody
,MATCH-WRAPPERS
- (when (and ,@(mapcar
- (lambda (layout-var)
- `(prog1
- (eq ,layout-var (svref ,n-vector ,n-pointer))
- (incf ,n-pointer)))
- layout-vars))
- ,@(when value-var
- `((setf ,value-var (non-empty-or (svref ,n-vector ,n-pointer)
- (go ,miss-tag)))))
- (go ,EXIT-WITH-HIT))
- (if (zerop ,n-depth)
- (go ,miss-tag)
- (decf ,n-depth))
- (setf ,n-index (next-cache-index ,n-mask ,n-index ,line-size)
- ,n-pointer ,n-index)
- (go ,MATCH-WRAPPERS)
+ (when (and ,@(loop for layout-var in layout-vars
+ for i from 0
+ collect
+ (if pointer
+ `(prog1 (eq ,layout-var
+ (svref ,n-vector ,pointer))
+ (incf ,pointer))
+ `(eq ,layout-var
+ (svref ,n-vector
+ (the index (+ ,probe ,i)))))))
+ ,@(when value-var
+ `((setf ,value-var
+ (non-empty-or (svref ,n-vector
+ ,(or pointer
+ `(the index
+ (+ ,probe ,num-keys))))
+ (go ,miss-tag)))))
+ (go ,EXIT-WITH-HIT))
+ (when (zerop ,n-depth) (go ,miss-tag))
+ (decf ,n-depth)
+ (setf ,probe (next-cache-index ,n-mask ,probe ,line-size))
+ ,@(if pointer `((setf ,pointer ,probe)))
+ (go ,MATCH-WRAPPERS)
,EXIT-WITH-HIT))))))
;;; Probes CACHE for LAYOUTS.
diff --git a/src/pcl/dlisp.lisp b/src/pcl/dlisp.lisp
index b5824ba..852b132 100644
--- a/src/pcl/dlisp.lisp
+++ b/src/pcl/dlisp.lisp
@@ -266,6 +266,9 @@
(values
(emit-reader/writer reader/writer 1-or-2-class class-slot-p))))
+;; If CACHED-INDEX-P is false, then the slot location is a constant and
+;; the cache holds layouts eligible to use that index.
+;; If true, then the cache is a map of layout -> index.
(defun emit-one-or-n-index-reader/writer (reader/writer
cached-index-p
class-slot-p)
@@ -304,6 +307,14 @@
.more-count.))
`(funcall ,miss-fn ,@args)))
+;; (cache-emf, return-value):
+;; NIL / NIL : GF has a single EMF. Invoke it when layouts are in cache.
+;; NIL / T : GF has a single EMF. Return T when layouts are in cache.
+;; T / NIL : Look for the EMF for argument layouts. Invoke it when in cache.
+;; T / T : Look for the EMF for argument layouts. Return it when in cache.
+;;
+;; METATYPES must be acceptable to EMIT-FETCH-WRAPPER.
+;; APPLYP says whether there is a &MORE context.
(defun emit-checking-or-caching (cached-emf-p return-value-p metatypes applyp)
(multiple-value-bind (lambda-list args rest-arg more-arg)
(make-dlap-lambda-list (length metatypes) applyp)
@@ -355,7 +366,9 @@
,miss-tag
(return ,miss-form))))
-(defun emit-fetch-wrapper (metatype argument miss-tag &optional slot)
+;; SLOTS-VAR, if supplied, is the variable to update with instance-slots
+;; by side-effect of fetching the wrapper for ARGUMENT.
+(defun emit-fetch-wrapper (metatype argument miss-tag &optional slots-var)
(ecase metatype
((standard-instance)
;; This branch may run on non-pcl instances (structures). The
@@ -368,27 +381,28 @@
;; instance-slots-layout instead of for-std-class-p, as if there
;; are no layouts there are no slots to worry about.
(with-unique-names (wrapper)
- `(cond
- ((std-instance-p ,argument)
- (let ((,wrapper (std-instance-wrapper ,argument)))
- ,@(when slot
- `((when (layout-for-std-class-p ,wrapper)
- (setq ,slot (std-instance-slots ,argument)))))
- ,wrapper))
- ((fsc-instance-p ,argument)
- (let ((,wrapper (fsc-instance-wrapper ,argument)))
- ,@(when slot
- `((when (layout-for-std-class-p ,wrapper)
- (setq ,slot (fsc-instance-slots ,argument)))))
- ,wrapper))
- (t (go ,miss-tag)))))
+ `(cond ((std-instance-p ,argument)
+ ,(if slots-var
+ `(let ((,wrapper (std-instance-wrapper ,argument)))
+ (when (layout-for-std-class-p ,wrapper)
+ (setq ,slots-var (std-instance-slots ,argument)))
+ ,wrapper)
+ `(std-instance-wrapper ,argument)))
+ ((fsc-instance-p ,argument)
+ ,(if slots-var
+ `(let ((,wrapper (fsc-instance-wrapper ,argument)))
+ (when (layout-for-std-class-p ,wrapper)
+ (setq ,slots-var (fsc-instance-slots ,argument)))
+ ,wrapper)
+ `(fsc-instance-wrapper ,argument)))
+ (t (go ,miss-tag)))))
;; Sep92 PCL used to distinguish between some of these cases (and
;; spuriously exclude others). Since in SBCL
;; WRAPPER-OF/LAYOUT-OF/BUILT-IN-OR-STRUCTURE-WRAPPER are all
;; equivalent and inlined to each other, we can collapse some
;; spurious differences.
((class system-instance structure-instance condition-instance)
- (when slot
+ (when slots-var
(bug "SLOT requested for metatype ~S, but it isn't going to happen."
metatype))
`(layout-of ,argument))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|