\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))
;;; 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)
(*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.")
+
projects / sbcl.git / blobdiff