X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-extensions.lisp;h=68cf7c5f48430534d568015e50432a6b1243d4b6;hb=fbe3701ca881999e1b17ad35f11d3b2c6b66bf99;hp=5115fc0da4cefc5ee3201be8565a8c897fea8c17;hpb=23c0c48f562d7dc5d1615bf13cb831b46c91d106;p=sbcl.git diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 5115fc0..68cf7c5 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))) +#!+(or x86 x86-64) +(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))) + +#!+(or x86 x86-64) +(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) @@ -880,75 +920,24 @@ (def-constantly-fun constantly-nil nil) (def-constantly-fun constantly-0 0)) -;;; If X is an atom, see whether it is present in *FEATURES*. Also +;;; If X is a symbol, see whether it is present in *FEATURES*. Also ;;; handle arbitrary combinations of atoms using NOT, AND, OR. (defun featurep (x) - (if (consp x) - (case (car x) - ((:not not) - (if (cddr x) - (error "too many subexpressions in feature expression: ~S" x) - (not (featurep (cadr x))))) - ((:and and) (every #'featurep (cdr x))) - ((:or or) (some #'featurep (cdr x))) - (t - (error "unknown operator in feature expression: ~S." x))) - (not (null (memq x *features*))))) - -;;; Given a list of keyword substitutions `(,OLD ,NEW), and a -;;; &KEY-argument-list-style list of alternating keywords and -;;; arbitrary values, return a new &KEY-argument-list-style list with -;;; all substitutions applied to it. -;;; -;;; Note: If efficiency mattered, we could do less consing. (But if -;;; efficiency mattered, why would we be using &KEY arguments at -;;; all, much less renaming &KEY arguments?) -;;; -;;; KLUDGE: It would probably be good to get rid of this. -- WHN 19991201 -(defun rename-key-args (rename-list key-args) - (declare (type list rename-list key-args)) - ;; Walk through RENAME-LIST modifying RESULT as per each element in - ;; RENAME-LIST. - (do ((result (copy-list key-args))) ; may be modified below - ((null rename-list) result) - (destructuring-bind (old new) (pop rename-list) - ;; ANSI says &KEY arg names aren't necessarily KEYWORDs. - (declare (type symbol old new)) - ;; Walk through RESULT renaming any OLD key argument to NEW. - (do ((in-result result (cddr in-result))) - ((null in-result)) - (declare (type list in-result)) - (when (eq (car in-result) old) - (setf (car in-result) new)))))) - -;;; ANSI Common Lisp's READ-SEQUENCE function, unlike most of the -;;; other ANSI input functions, is defined to communicate end of file -;;; status with its return value, not by signalling. That is not the -;;; behavior that we usually want. This function is a wrapper which -;;; restores the behavior that we usually want, causing READ-SEQUENCE -;;; to communicate end-of-file status by signalling. -(defun read-sequence-or-die (sequence stream &key start end) - ;; implementation using READ-SEQUENCE - #-no-ansi-read-sequence - (let ((read-end (read-sequence sequence - stream - :start start - :end end))) - (unless (= read-end end) - (error 'end-of-file :stream stream)) - (values)) - ;; workaround for broken READ-SEQUENCE - #+no-ansi-read-sequence - (progn - (aver (<= start end)) - (let ((etype (stream-element-type stream))) - (cond ((equal etype '(unsigned-byte 8)) - (do ((i start (1+ i))) - ((>= i end) - (values)) - (setf (aref sequence i) - (read-byte stream)))) - (t (error "unsupported element type ~S" etype)))))) + (etypecase x + (cons + (case (car x) + ((:not not) + (cond + ((cddr x) + (error "too many subexpressions in feature expression: ~S" x)) + ((null (cdr x)) + (error "too few subexpressions in feature expression: ~S" x)) + (t (not (featurep (cadr x)))))) + ((:and and) (every #'featurep (cdr x))) + ((:or or) (some #'featurep (cdr x))) + (t + (error "unknown operator in feature expression: ~S." x)))) + (symbol (not (null (memq x *features*)))))) ;;;; utilities for two-VALUES predicates @@ -1207,3 +1196,63 @@ (*print-level* (or (true *print-level*) 6)) (*print-length* (or (true *print-length*) 12))) (funcall function)))) + +;;; Default evaluator mode (interpeter / compiler) + +(declaim (type (member :compile #!+sb-eval :interpret) *evaluator-mode*)) +(defparameter *evaluator-mode* :compile + #!+sb-doc + "Toggle between different evaluator implementations. If set to :COMPILE, +an implementation of EVAL that calls the compiler will be used. If set +to :INTERPRET, an interpreter will be used.") + +;;; Helper for making the DX closure allocation in macros expanding +;;; to CALL-WITH-FOO less ugly. +;;; +;;; This expands to something like +;;; +;;; (flet ((foo (...) )) +;;; (declare (optimize stack-allocate-dynamic-extent)) +;;; (flet ((foo (...) +;;; (foo ...)) +;;; (declare (dynamic-extent #'foo)) +;;; ))) +;;; +;;; The outer FLETs are inlined into the inner ones, and the inner ones +;;; are DX-allocated. The double-fletting is done to keep the bodies of +;;; the functions in an environment with correct policy: we don't want +;;; to force DX allocation in their bodies, which would be bad eg. +;;; in safe code. +(defmacro dx-flet (functions &body forms) + (let ((names (mapcar #'car functions))) + `(flet ,functions + #-sb-xc-host + (declare (optimize sb!c::stack-allocate-dynamic-extent)) + (flet ,(mapcar + (lambda (f) + (let ((args (cadr f)) + (name (car f))) + (when (intersection args lambda-list-keywords) + ;; No fundamental reason not to support them, but we + ;; don't currently need them here. + (error "Non-required arguments not implemented for DX-FLET.")) + `(,name ,args + (,name ,@args)))) + functions) + (declare (dynamic-extent ,@(mapcar (lambda (x) `(function ,x)) names))) + ,@forms)))) + +;;; Another similar one -- but actually touches the policy of the body, +;;; so take care with this one... +(defmacro dx-let (bindings &body forms) + `(locally + #-sb-xc-host + (declare (optimize sb!c::stack-allocate-dynamic-extent)) + (let ,bindings + (declare (dynamic-extent ,@(mapcar (lambda (bind) + (if (consp bind) + (car bind) + bind)) + bindings))) + ,@forms))) +