;;; 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
(* 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
\f
;;;; type-ish predicates
-;;; Is X a list containing a cycle?
-(defun cyclic-list-p (x)
+;;; X may contain cycles -- a conservative approximation. This
+;;; occupies a somewhat uncomfortable niche between being fast for
+;;; common cases (we don't want to allocate a hash-table), and not
+;;; falling down to exponential behaviour for large trees (so we set
+;;; an arbitrady depth limit beyond which we punt).
+(defun maybe-cyclic-p (x &optional (depth-limit 12))
(and (listp x)
- (labels ((safe-cddr (x) (if (listp (cdr x)) (cddr x))))
- (do ((y x (safe-cddr y))
- (started-p nil t)
- (z x (cdr z)))
- ((not (and (consp z) (consp y))) nil)
- (when (and started-p (eq y z))
- (return t))))))
+ (labels ((safe-cddr (cons)
+ (let ((cdr (cdr cons)))
+ (when (consp cdr)
+ (cdr cdr))))
+ (check-cycle (object seen depth)
+ (when (and (consp object)
+ (or (> depth depth-limit)
+ (member object seen)
+ (circularp object seen depth)))
+ (return-from maybe-cyclic-p t)))
+ (circularp (list seen depth)
+ ;; Almost regular circular list detection, with a twist:
+ ;; we also check each element of the list for upward
+ ;; references using CHECK-CYCLE.
+ (do ((fast (cons (car list) (cdr list)) (safe-cddr fast))
+ (slow list (cdr slow)))
+ ((not (consp fast))
+ ;; Not CDR-circular, need to check remaining CARs yet
+ (do ((tail slow (and (cdr tail))))
+ ((not (consp tail))
+ nil)
+ (check-cycle (car tail) (cons tail seen) (1+ depth))))
+ (check-cycle (car slow) (cons slow seen) (1+ depth))
+ (when (eq fast slow)
+ (return t)))))
+ (circularp x (list x) 0))))
;;; Is X a (possibly-improper) list of at least N elements?
(declaim (ftype (function (t index)) list-of-length-at-least-p))
;;; the implementation of things like *PRINT-CIRCLE* and the dumper.)
(defun compound-object-p (x)
(or (consp x)
- (typep x 'instance)
+ (%instancep x)
(typep x '(array t *))))
\f
;;;; the COLLECT macro
;;; not really an old-fashioned function, but what the calling
;;; convention should've been: like NTH, but with the same argument
-;;; order as in all the other dereferencing functions, with the
-;;; collection first and the index second
+;;; order as in all the other indexed dereferencing functions, with
+;;; the collection first and the index second
(declaim (inline nth-but-with-sane-arg-order))
(declaim (ftype (function (list index) t) nth-but-with-sane-arg-order))
(defun nth-but-with-sane-arg-order (list index)
\f
;;;; miscellaneous iteration extensions
-;;; "the ultimate iteration macro"
+;;; like Scheme's named LET
;;;
-;;; note for Schemers: This seems to be identical to Scheme's "named LET".
+;;; (CMU CL called this ITERATE, and commented it as "the ultimate
+;;; iteration macro...". I (WHN) found the old name insufficiently
+;;; specific to remind me what the macro means, so I renamed it.)
(defmacro named-let (name binds &body body)
- #!+sb-doc
(dolist (x binds)
(unless (proper-list-of-length-p x 2)
(error "malformed NAMED-LET variable spec: ~S" x)))
`(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)
;;; 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:
;;; <name>-CACHE-LOOKUP Arg*
;;; See whether there is an entry for the specified ARGs in the
(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)))
(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)
(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*
`(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*"))))
(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)
(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*))))))
\f
;;;; utilities for two-VALUES predicates
(*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 (...) <body-of-foo>))
+;;; (declare (optimize stack-allocate-dynamic-extent))
+;;; (flet ((foo (...)
+;;; (foo ...))
+;;; (declare (dynamic-extent #'foo))
+;;; <body-of-dx-flet>)))
+;;;
+;;; 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)))
+
projects / sbcl.git / blobdiff