X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-extensions.lisp;h=c9cdbf718426bc96f779668ac0dd626d02506354;hb=7e24349c17298e2959e853ea411b5f65d9f7f332;hp=0b2b05af094d7db4eac37edcda136ece5a4affc6;hpb=970dd272dc84f7420252eadb4829cc193f795716;p=sbcl.git diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 0b2b05a..c9cdbf7 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -30,6 +30,10 @@ ;;; bound because ANSI specifies it as an exclusive bound.) (def!type index () `(integer 0 (,sb!xc:array-dimension-limit))) +;;; like INDEX, but only up to half the maximum. Used by hash-table +;;; code that does plenty to (aref v (* 2 i)) and (aref v (1+ (* 2 i))). +(def!type index/2 () `(integer 0 (,(floor sb!xc:array-dimension-limit 2)))) + ;;; like INDEX, but augmented with -1 (useful when using the index ;;; to count downwards to 0, e.g. LOOP FOR I FROM N DOWNTO 0, with ;;; an implementation which terminates the loop by testing for the @@ -65,6 +69,30 @@ (* max-offset sb!vm:n-word-bytes)) scale))) +#!+x86 +(defun displacement-bounds (lowtag element-size data-offset) + (let* ((adjustment (- (* data-offset sb!vm:n-word-bytes) lowtag)) + (bytes-per-element (ceiling element-size sb!vm:n-byte-bits)) + (min (truncate (+ sb!vm::minimum-immediate-offset adjustment) + bytes-per-element)) + (max (truncate (+ sb!vm::maximum-immediate-offset adjustment) + bytes-per-element))) + (values min max))) + +#!+x86 +(def!type constant-displacement (lowtag element-size data-offset) + (flet ((integerify (x) + (etypecase x + (integer x) + (symbol (symbol-value x))))) + (let ((lowtag (integerify lowtag)) + (element-size (integerify element-size)) + (data-offset (integerify data-offset))) + (multiple-value-bind (min max) (displacement-bounds lowtag + element-size + data-offset) + `(integer ,min ,max))))) + ;;; Similar to FUNCTION, but the result type is "exactly" specified: ;;; if it is an object type, then the function returns exactly one ;;; value, if it is a short form of VALUES, then this short form @@ -378,18 +406,32 @@ `(labels ((,name ,(mapcar #'first binds) ,@body)) (,name ,@(mapcar #'second binds)))) +(defun filter-dolist-declarations (decls) + (mapcar (lambda (decl) + `(declare ,@(remove-if + (lambda (clause) + (and (consp clause) + (or (eq (car clause) 'type) + (eq (car clause) 'ignore)))) + (cdr decl)))) + decls)) + ;;; just like DOLIST, but with one-dimensional arrays -(defmacro dovector ((elt vector &optional result) &rest forms) - (let ((index (gensym)) - (length (gensym)) - (vec (gensym))) - `(let ((,vec ,vector)) - (declare (type vector ,vec)) - (do ((,index 0 (1+ ,index)) - (,length (length ,vec))) - ((>= ,index ,length) ,result) - (let ((,elt (aref ,vec ,index))) - ,@forms))))) +(defmacro dovector ((elt vector &optional result) &body body) + (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil) + (with-unique-names (index length vec) + `(let ((,vec ,vector)) + (declare (type vector ,vec)) + (do ((,index 0 (1+ ,index)) + (,length (length ,vec))) + ((>= ,index ,length) (let ((,elt nil)) + ,@(filter-dolist-declarations decls) + ,elt + ,result)) + (let ((,elt (aref ,vec ,index))) + ,@decls + (tagbody + ,@forms))))))) ;;; Iterate over the entries in a HASH-TABLE. (defmacro dohash ((key-var value-var table &optional result) &body body) @@ -423,6 +465,17 @@ ;;; its first arg, but need not return any particular value. ;;; TEST-FUNCTION may be any thing that can be placed in CAR position. ;;; +;;; This code used to store all the arguments / return values directly +;;; in the cache vector. This was both interrupt- and thread-unsafe, since +;;; it was possible that *-CACHE-ENTER would scribble over a region of the +;;; cache vector which *-CACHE-LOOKUP had only partially processed. Instead +;;; we now store the contents of each cache bucket as a separate array, which +;;; is stored in the appropriate cell in the cache vector. A new bucket array +;;; is created every time *-CACHE-ENTER is called, and the old ones are never +;;; modified. This means that *-CACHE-LOOKUP will always work with a set +;;; of consistent data. The overhead caused by consing new buckets seems to +;;; be insignificant on the grand scale of things. -- JES, 2006-11-02 +;;; ;;; NAME is used to define these functions: ;;; -CACHE-LOOKUP Arg* ;;; See whether there is an entry for the specified ARGs in the @@ -452,12 +505,12 @@ (values 1)) (let* ((var-name (symbolicate "*" name "-CACHE-VECTOR*")) (nargs (length args)) - (entry-size (+ nargs values)) (size (ash 1 hash-bits)) - (total-size (* entry-size size)) (default-values (if (and (consp default) (eq (car default) 'values)) (cdr default) (list default))) + (args-and-values (gensym)) + (args-and-values-size (+ nargs values)) (n-index (gensym)) (n-cache (gensym))) @@ -468,14 +521,16 @@ (collect ((inlines) (forms) (inits) - (tests) (sets) + (tests) (arg-vars) - (values-indices) + (values-refs) (values-names)) (dotimes (i values) - (values-indices `(+ ,n-index ,(+ nargs i))) - (values-names (gensym))) + (let ((name (gensym))) + (values-names name) + (values-refs `(svref ,args-and-values (+ ,nargs ,i))) + (sets `(setf (svref ,args-and-values (+ ,nargs ,i)) ,name)))) (let ((n 0)) (dolist (arg args) (unless (= (length arg) 2) @@ -483,8 +538,8 @@ (let ((arg-name (first arg)) (test (second arg))) (arg-vars arg-name) - (tests `(,test (svref ,n-cache (+ ,n-index ,n)) ,arg-name)) - (sets `(setf (svref ,n-cache (+ ,n-index ,n)) ,arg-name))) + (tests `(,test (svref ,args-and-values ,n) ,arg-name)) + (sets `(setf (svref ,args-and-values ,n) ,arg-name))) (incf n))) (when *profile-hash-cache* @@ -502,12 +557,12 @@ `(defun ,fun-name ,(arg-vars) ,@(when *profile-hash-cache* `((incf ,(symbolicate "*" name "-CACHE-PROBES*")))) - (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size)) - (,n-cache ,var-name)) - (declare (type fixnum ,n-index)) - (cond ((and ,@(tests)) - (values ,@(mapcar (lambda (x) `(svref ,n-cache ,x)) - (values-indices)))) + (let* ((,n-index (,hash-function ,@(arg-vars))) + (,n-cache ,var-name) + (,args-and-values (svref ,n-cache ,n-index))) + (cond ((and ,args-and-values + ,@(tests)) + (values ,@(values-refs))) (t ,@(when *profile-hash-cache* `((incf ,(symbolicate "*" name "-CACHE-MISSES*")))) @@ -517,41 +572,26 @@ (inlines fun-name) (forms `(defun ,fun-name (,@(arg-vars) ,@(values-names)) - (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size)) - (,n-cache ,var-name)) - (declare (type fixnum ,n-index)) + (let ((,n-index (,hash-function ,@(arg-vars))) + (,n-cache ,var-name) + (,args-and-values (make-array ,args-and-values-size))) ,@(sets) - ,@(mapcar (lambda (i val) - `(setf (svref ,n-cache ,i) ,val)) - (values-indices) - (values-names)) - (values))))) + (setf (svref ,n-cache ,n-index) ,args-and-values)) + (values)))) (let ((fun-name (symbolicate name "-CACHE-CLEAR"))) (forms `(defun ,fun-name () - (do ((,n-index ,(- total-size entry-size) (- ,n-index ,entry-size)) - (,n-cache ,var-name)) - ((minusp ,n-index)) - (declare (type fixnum ,n-index)) - ,@(collect ((arg-sets)) - (dotimes (i nargs) - (arg-sets `(setf (svref ,n-cache (+ ,n-index ,i)) nil))) - (arg-sets)) - ,@(mapcar (lambda (i val) - `(setf (svref ,n-cache ,i) ,val)) - (values-indices) - default-values)) - (values))) + (fill ,var-name nil))) (forms `(,fun-name))) (inits `(unless (boundp ',var-name) - (setq ,var-name (make-array ,total-size)))) + (setq ,var-name (make-array ,size :initial-element nil)))) #!+sb-show (inits `(setq *hash-caches-initialized-p* t)) `(progn (defvar ,var-name) - (declaim (type (simple-vector ,total-size) ,var-name)) + (declaim (type (simple-vector ,size) ,var-name)) #!-sb-fluid (declaim (inline ,@(inlines))) (,init-wrapper ,@(inits)) ,@(forms)