1 ;;;; various extensions (including SB-INT "internal extensions")
2 ;;;; available both in the cross-compilation host Lisp and in the
5 ;;;; This software is part of the SBCL system. See the README file for
8 ;;;; This software is derived from the CMU CL system, which was
9 ;;;; written at Carnegie Mellon University and released into the
10 ;;;; public domain. The software is in the public domain and is
11 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
12 ;;;; files for more information.
14 (in-package "SB!IMPL")
16 (defvar *core-pathname
* nil
18 "The absolute pathname of the running SBCL core.")
20 (defvar *runtime-pathname
* nil
22 "The absolute pathname of the running SBCL runtime.")
24 ;;; something not EQ to anything we might legitimately READ
25 (defglobal *eof-object
* (make-symbol "EOF-OBJECT"))
27 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
28 (defconstant max-hash sb
!xc
:most-positive-fixnum
))
31 `(integer 0 ,max-hash
))
33 ;;; a type used for indexing into sequences, and for related
34 ;;; quantities like lengths of lists and other sequences.
36 ;;; A more correct value for the exclusive upper bound for indexing
37 ;;; would be (1- ARRAY-DIMENSION-LIMIT) since ARRAY-DIMENSION-LIMIT is
38 ;;; the exclusive maximum *size* of one array dimension (As specified
39 ;;; in CLHS entries for MAKE-ARRAY and "valid array dimensions"). The
40 ;;; current value is maintained to avoid breaking existing code that
41 ;;; also uses that type for upper bounds on indices (e.g. sequence
44 ;;; In SBCL, ARRAY-DIMENSION-LIMIT is arranged to be a little smaller
45 ;;; than MOST-POSITIVE-FIXNUM, for implementation (see comment above
46 ;;; ARRAY-DIMENSION-LIMIT) and efficiency reasons: staying below
47 ;;; MOST-POSITIVE-FIXNUM lets the system know it can increment a value
48 ;;; of type INDEX without having to worry about using a bignum to
49 ;;; represent the result.
50 (def!type index
() `(integer 0 (,sb
!xc
:array-dimension-limit
)))
52 ;;; like INDEX, but only up to half the maximum. Used by hash-table
53 ;;; code that does plenty to (aref v (* 2 i)) and (aref v (1+ (* 2 i))).
54 (def!type index
/2 () `(integer 0 (,(floor sb
!xc
:array-dimension-limit
2))))
56 ;;; like INDEX, but augmented with -1 (useful when using the index
57 ;;; to count downwards to 0, e.g. LOOP FOR I FROM N DOWNTO 0, with
58 ;;; an implementation which terminates the loop by testing for the
59 ;;; index leaving the loop range)
60 (def!type index-or-minus-1
() `(integer -
1 (,sb
!xc
:array-dimension-limit
)))
62 ;;; A couple of VM-related types that are currently used only on the
63 ;;; alpha platform. -- CSR, 2002-06-24
64 (def!type unsigned-byte-with-a-bite-out
(s bite
)
65 (cond ((eq s
'*) 'integer
)
66 ((and (integerp s
) (> s
0))
67 (let ((bound (ash 1 s
)))
68 `(integer 0 ,(- bound bite
1))))
70 (error "Bad size specified for UNSIGNED-BYTE type specifier: ~S." s
))))
72 ;;; Motivated by the mips port. -- CSR, 2002-08-22
73 (def!type signed-byte-with-a-bite-out
(s bite
)
74 (cond ((eq s
'*) 'integer
)
75 ((and (integerp s
) (> s
1))
76 (let ((bound (ash 1 (1- s
))))
77 `(integer ,(- bound
) ,(- bound bite
1))))
79 (error "Bad size specified for SIGNED-BYTE type specifier: ~S." s
))))
81 (def!type load
/store-index
(scale lowtag min-offset
82 &optional
(max-offset min-offset
))
83 `(integer ,(- (truncate (+ (ash 1 16)
84 (* min-offset sb
!vm
:n-word-bytes
)
87 ,(truncate (- (+ (1- (ash 1 16)) lowtag
)
88 (* max-offset sb
!vm
:n-word-bytes
))
92 (defun displacement-bounds (lowtag element-size data-offset
)
93 (let* ((adjustment (- (* data-offset sb
!vm
:n-word-bytes
) lowtag
))
94 (bytes-per-element (ceiling element-size sb
!vm
:n-byte-bits
))
95 (min (truncate (+ sb
!vm
::minimum-immediate-offset adjustment
)
97 (max (truncate (+ sb
!vm
::maximum-immediate-offset adjustment
)
102 (def!type constant-displacement
(lowtag element-size data-offset
)
103 (flet ((integerify (x)
106 (symbol (symbol-value x
)))))
107 (let ((lowtag (integerify lowtag
))
108 (element-size (integerify element-size
))
109 (data-offset (integerify data-offset
)))
110 (multiple-value-bind (min max
) (displacement-bounds lowtag
113 `(integer ,min
,max
)))))
115 ;;; Similar to FUNCTION, but the result type is "exactly" specified:
116 ;;; if it is an object type, then the function returns exactly one
117 ;;; value, if it is a short form of VALUES, then this short form
118 ;;; specifies the exact number of values.
119 (def!type sfunction
(args &optional result
)
120 (let ((result (cond ((eq result
'*) '*)
122 (not (eq (car result
) 'values
)))
123 `(values ,result
&optional
))
124 ((intersection (cdr result
) sb
!xc
:lambda-list-keywords
)
126 (t `(values ,@(cdr result
) &optional
)))))
127 `(function ,args
,result
)))
131 ;;; FIXME: The SB!KERNEL:INSTANCE here really means CL:CLASS.
132 ;;; However, the CL:CLASS type is only defined once PCL is loaded,
133 ;;; which is before this is evaluated. Once PCL is moved into cold
134 ;;; init, this might be fixable.
135 (def!type type-specifier
() '(or list symbol instance
))
137 ;;; the default value used for initializing character data. The ANSI
138 ;;; spec says this is arbitrary, so we use the value that falls
139 ;;; through when we just let the low-level consing code initialize
140 ;;; all newly-allocated memory to zero.
142 ;;; KLUDGE: It might be nice to use something which is a
143 ;;; STANDARD-CHAR, both to reduce user surprise a little and, probably
144 ;;; more significantly, to help SBCL's cross-compiler (which knows how
145 ;;; to dump STANDARD-CHARs). Unfortunately, the old CMU CL code is
146 ;;; shot through with implicit assumptions that it's #\NULL, and code
147 ;;; in several places (notably both DEFUN MAKE-ARRAY and DEFTRANSFORM
148 ;;; MAKE-ARRAY) would have to be rewritten. -- WHN 2001-10-04
149 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
150 ;; an expression we can use to construct a DEFAULT-INIT-CHAR value
151 ;; at load time (so that we don't need to teach the cross-compiler
152 ;; how to represent and dump non-STANDARD-CHARs like #\NULL)
153 (defparameter *default-init-char-form
* '(code-char 0)))
155 ;;; CHAR-CODE values for ASCII characters which we care about but
156 ;;; which aren't defined in section "2.1.3 Standard Characters" of the
157 ;;; ANSI specification for Lisp
159 ;;; KLUDGE: These are typically used in the idiom (CODE-CHAR
160 ;;; FOO-CHAR-CODE). I suspect that the current implementation is
161 ;;; expanding this idiom into a full call to CODE-CHAR, which is an
162 ;;; annoying overhead. I should check whether this is happening, and
163 ;;; if so, perhaps implement a DEFTRANSFORM or something to stop it.
164 ;;; (or just find a nicer way of expressing characters portably?) --
166 (def!constant bell-char-code
7)
167 (def!constant backspace-char-code
8)
168 (def!constant tab-char-code
9)
169 (def!constant line-feed-char-code
10)
170 (def!constant form-feed-char-code
12)
171 (def!constant return-char-code
13)
172 (def!constant escape-char-code
27)
173 (def!constant rubout-char-code
127)
175 ;;;; type-ish predicates
177 ;;; X may contain cycles -- a conservative approximation. This
178 ;;; occupies a somewhat uncomfortable niche between being fast for
179 ;;; common cases (we don't want to allocate a hash-table), and not
180 ;;; falling down to exponential behaviour for large trees (so we set
181 ;;; an arbitrady depth limit beyond which we punt).
182 (defun maybe-cyclic-p (x &optional
(depth-limit 12))
184 (labels ((safe-cddr (cons)
185 (let ((cdr (cdr cons
)))
188 (check-cycle (object seen depth
)
189 (when (and (consp object
)
190 (or (> depth depth-limit
)
192 (circularp object seen depth
)))
193 (return-from maybe-cyclic-p t
)))
194 (circularp (list seen depth
)
195 ;; Almost regular circular list detection, with a twist:
196 ;; we also check each element of the list for upward
197 ;; references using CHECK-CYCLE.
198 (do ((fast (cons (car list
) (cdr list
)) (safe-cddr fast
))
199 (slow list
(cdr slow
)))
201 ;; Not CDR-circular, need to check remaining CARs yet
202 (do ((tail slow
(and (cdr tail
))))
205 (check-cycle (car tail
) (cons tail seen
) (1+ depth
))))
206 (check-cycle (car slow
) (cons slow seen
) (1+ depth
))
209 (circularp x
(list x
) 0))))
211 ;;; Is X a (possibly-improper) list of at least N elements?
212 (declaim (ftype (function (t index
)) list-of-length-at-least-p
))
213 (defun list-of-length-at-least-p (x n
)
214 (or (zerop n
) ; since anything can be considered an improper list of length 0
216 (list-of-length-at-least-p (cdr x
) (1- n
)))))
218 (declaim (inline ensure-list
))
219 (defun ensure-list (thing)
220 (if (listp thing
) thing
(list thing
)))
222 ;;; Is X is a positive prime integer?
223 (defun positive-primep (x)
224 ;; This happens to be called only from one place in sbcl-0.7.0, and
225 ;; only for fixnums, we can limit it to fixnums for efficiency. (And
226 ;; if we didn't limit it to fixnums, we should use a cleverer
227 ;; algorithm, since this one scales pretty badly for huge X.)
230 (and (>= x
2) (/= x
4))
232 (not (zerop (rem x
3)))
235 (inc 2 (logxor inc
6)) ;; 2,4,2,4...
237 ((or (= r
0) (> d q
)) (/= r
0))
238 (declare (fixnum inc
))
239 (multiple-value-setq (q r
) (truncate x d
))))))
241 ;;; Could this object contain other objects? (This is important to
242 ;;; the implementation of things like *PRINT-CIRCLE* and the dumper.)
243 (defun compound-object-p (x)
246 (typep x
'(array t
*))))
248 ;;;; the COLLECT macro
250 ;;;; comment from CMU CL: "the ultimate collection macro..."
252 ;;; helper functions for COLLECT, which become the expanders of the
253 ;;; MACROLET definitions created by COLLECT
255 ;;; COLLECT-NORMAL-EXPANDER handles normal collection macros.
257 ;;; COLLECT-LIST-EXPANDER handles the list collection case. N-TAIL
258 ;;; is the pointer to the current tail of the list, or NIL if the list
260 (eval-when (#-sb-xc
:compile-toplevel
:load-toplevel
:execute
)
261 (defun collect-normal-expander (n-value fun forms
)
263 ,@(mapcar (lambda (form) `(setq ,n-value
(,fun
,form
,n-value
))) forms
)
265 (defun collect-list-expander (n-value n-tail forms
)
266 (let ((n-res (gensym)))
268 ,@(mapcar (lambda (form)
269 `(let ((,n-res
(cons ,form nil
)))
271 (setf (cdr ,n-tail
) ,n-res
)
272 (setq ,n-tail
,n-res
))
274 (setq ,n-tail
,n-res
,n-value
,n-res
)))))
278 ;;; Collect some values somehow. Each of the collections specifies a
279 ;;; bunch of things which collected during the evaluation of the body
280 ;;; of the form. The name of the collection is used to define a local
281 ;;; macro, a la MACROLET. Within the body, this macro will evaluate
282 ;;; each of its arguments and collect the result, returning the
283 ;;; current value after the collection is done. The body is evaluated
284 ;;; as a PROGN; to get the final values when you are done, just call
285 ;;; the collection macro with no arguments.
287 ;;; INITIAL-VALUE is the value that the collection starts out with,
288 ;;; which defaults to NIL. FUNCTION is the function which does the
289 ;;; collection. It is a function which will accept two arguments: the
290 ;;; value to be collected and the current collection. The result of
291 ;;; the function is made the new value for the collection. As a
292 ;;; totally magical special-case, FUNCTION may be COLLECT, which tells
293 ;;; us to build a list in forward order; this is the default. If an
294 ;;; INITIAL-VALUE is supplied for COLLECT, the stuff will be RPLACD'd
295 ;;; onto the end. Note that FUNCTION may be anything that can appear
296 ;;; in the functional position, including macros and lambdas.
297 (defmacro collect
(collections &body body
)
301 (dolist (spec collections
)
302 (unless (proper-list-of-length-p spec
1 3)
303 (error "malformed collection specifier: ~S" spec
))
304 (let* ((name (first spec
))
305 (default (second spec
))
306 (kind (or (third spec
) 'collect
))
307 (n-value (gensym (concatenate 'string
310 (push `(,n-value
,default
) binds
)
311 (if (eq kind
'collect
)
312 (let ((n-tail (gensym (concatenate 'string
315 (push n-tail ignores
)
317 (push `(,n-tail
(last ,n-value
)) binds
)
319 (push `(,name
(&rest args
)
320 (collect-list-expander ',n-value
',n-tail args
))
322 (push `(,name
(&rest args
)
323 (collect-normal-expander ',n-value
',kind args
))
326 (let* ,(nreverse binds
)
327 ;; Even if the user reads each collection result,
328 ;; reader conditionals might statically eliminate all writes.
329 ;; Since we don't know, all the -n-tail variable are ignorable.
330 ,@(if ignores
`((declare (ignorable ,@ignores
))))
333 ;;;; some old-fashioned functions. (They're not just for old-fashioned
334 ;;;; code, they're also used as optimized forms of the corresponding
335 ;;;; general functions when the compiler can prove that they're
338 ;;; like (MEMBER ITEM LIST :TEST #'EQ)
339 (defun memq (item list
)
341 "Return tail of LIST beginning with first element EQ to ITEM."
342 ;; KLUDGE: These could be and probably should be defined as
343 ;; (MEMBER ITEM LIST :TEST #'EQ)),
344 ;; but when I try to cross-compile that, I get an error from
345 ;; LTN-ANALYZE-KNOWN-CALL, "Recursive known function definition". The
346 ;; comments for that error say it "is probably a botched interpreter stub".
347 ;; Rather than try to figure that out, I just rewrote this function from
348 ;; scratch. -- WHN 19990512
349 (do ((i list
(cdr i
)))
351 (when (eq (car i
) item
)
354 ;;; like (ASSOC ITEM ALIST :TEST #'EQ):
355 ;;; Return the first pair of ALIST where ITEM is EQ to the key of
357 (defun assq (item alist
)
358 ;; KLUDGE: CMU CL defined this with
359 ;; (DECLARE (INLINE ASSOC))
360 ;; (ASSOC ITEM ALIST :TEST #'EQ))
361 ;; which is pretty, but which would have required adding awkward
362 ;; build order constraints on SBCL (or figuring out some way to make
363 ;; inline definitions installable at build-the-cross-compiler time,
364 ;; which was too ambitious for now). Rather than mess with that, we
365 ;; just define ASSQ explicitly in terms of more primitive
368 ;; though it may look more natural to write this as
369 ;; (AND PAIR (EQ (CAR PAIR) ITEM))
370 ;; the temptation to do so should be resisted, as pointed out by PFD
371 ;; sbcl-devel 2003-08-16, as NIL elements are rare in association
372 ;; lists. -- CSR, 2003-08-16
373 (when (and (eq (car pair
) item
) (not (null pair
)))
376 ;;; like (DELETE .. :TEST #'EQ):
377 ;;; Delete all LIST entries EQ to ITEM (destructively modifying
378 ;;; LIST), and return the modified LIST.
379 (defun delq (item list
)
381 (do ((x list
(cdr x
))
384 (cond ((eq item
(car x
))
387 (rplacd splice
(cdr x
))))
388 (t (setq splice x
)))))) ; Move splice along to include element.
391 ;;; like (POSITION .. :TEST #'EQ):
392 ;;; Return the position of the first element EQ to ITEM.
393 (defun posq (item list
)
394 (do ((i list
(cdr i
))
397 (when (eq (car i
) item
)
400 (declaim (inline neq
))
404 ;;; not really an old-fashioned function, but what the calling
405 ;;; convention should've been: like NTH, but with the same argument
406 ;;; order as in all the other indexed dereferencing functions, with
407 ;;; the collection first and the index second
408 (declaim (inline nth-but-with-sane-arg-order
))
409 (declaim (ftype (function (list index
) t
) nth-but-with-sane-arg-order
))
410 (defun nth-but-with-sane-arg-order (list index
)
413 (defun adjust-list (list length initial-element
)
414 (let ((old-length (length list
)))
415 (cond ((< old-length length
)
416 (append list
(make-list (- length old-length
)
417 :initial-element initial-element
)))
418 ((> old-length length
)
419 (subseq list
0 length
))
422 ;;;; miscellaneous iteration extensions
424 ;;; like Scheme's named LET
426 ;;; (CMU CL called this ITERATE, and commented it as "the ultimate
427 ;;; iteration macro...". I (WHN) found the old name insufficiently
428 ;;; specific to remind me what the macro means, so I renamed it.)
429 (defmacro named-let
(name binds
&body body
)
431 (unless (proper-list-of-length-p x
2)
432 (error "malformed NAMED-LET variable spec: ~S" x
)))
433 `(labels ((,name
,(mapcar #'first binds
) ,@body
))
434 (,name
,@(mapcar #'second binds
))))
436 (defun filter-dolist-declarations (decls)
437 (mapcar (lambda (decl)
438 `(declare ,@(remove-if
441 (or (eq (car clause
) 'type
)
442 (eq (car clause
) 'ignore
))))
445 ;;; just like DOLIST, but with one-dimensional arrays
446 (defmacro dovector
((elt vector
&optional result
) &body body
)
447 (multiple-value-bind (forms decls
) (parse-body body
:doc-string-allowed nil
)
448 (with-unique-names (index length vec
)
449 `(let ((,vec
,vector
))
450 (declare (type vector
,vec
))
451 (do ((,index
0 (1+ ,index
))
452 (,length
(length ,vec
)))
453 ((>= ,index
,length
) (let ((,elt nil
))
454 ,@(filter-dolist-declarations decls
)
457 (let ((,elt
(aref ,vec
,index
)))
462 ;;; Iterate over the entries in a HASH-TABLE, first obtaining the lock
463 ;;; if the table is a synchronized table.
464 (defmacro dohash
(((key-var value-var
) table
&key result locked
) &body body
)
465 (multiple-value-bind (forms decls
) (parse-body body
:doc-string-allowed nil
)
466 (with-unique-names (gen n-more n-table
)
467 (let ((iter-form `(with-hash-table-iterator (,gen
,n-table
)
469 (multiple-value-bind (,n-more
,key-var
,value-var
) (,gen
)
471 (unless ,n-more
(return ,result
))
473 `(let ((,n-table
,table
))
475 `(with-locked-system-table (,n-table
)
479 ;;; Executes BODY for all entries of PLIST with KEY and VALUE bound to
480 ;;; the respective keys and values.
481 (defmacro doplist
((key val
) plist
&body body
)
482 (with-unique-names (tail)
483 `(let ((,tail
,plist
) ,key
,val
)
484 (loop (when (null ,tail
) (return nil
))
485 (setq ,key
(pop ,tail
))
487 (error "malformed plist, odd number of elements"))
488 (setq ,val
(pop ,tail
))
491 ;;; (binding* ({(names initial-value [flag])}*) body)
492 ;;; FLAG may be NIL or :EXIT-IF-NULL
494 ;;; This form unites LET*, MULTIPLE-VALUE-BIND and AWHEN.
495 ;;; Any name in a list of names may be NIL to ignore the respective value.
496 ;;; If NAMES itself is nil, the initial-value form is evaluated only for effect.
498 ;;; Clauses with no flag and one binding are equivalent to LET.
500 ;;; Caution: don't use declarations of the form (<non-builtin-type-id> <var>)
501 ;;; before the INFO database is set up in building the cross-compiler,
502 ;;; or you will probably lose.
503 ;;; Of course, since some other host Lisps don't seem to think that's
504 ;;; acceptable syntax anyway, you're pretty much prevented from writing it.
506 (def!macro binding
* ((&rest clauses
) &body body
)
507 (unless clauses
; wrap in LET to preserve non-toplevelness
508 (return-from binding
* `(let () ,@body
)))
509 (multiple-value-bind (body decls
) (parse-body body
:doc-string-allowed nil
)
510 ;; Generate an abstract representation that combines LET* clauses.
512 (dolist (clause clauses
)
513 (destructuring-bind (symbols value-form
&optional flag
) clause
514 (declare (type (member :exit-if-null nil
) flag
))
517 (cond ((not (listp symbols
)) (list symbols
))
518 ((not symbols
) (setq ignore
(list (gensym))))
520 (lambda (x) (or x
(car (push (gensym) ignore
))))
522 (flags (logior (if (cdr symbols
) 1 0) (if flag
2 0)))
524 ;; EVENP => this clause does not entail multiple-value-bind
525 (cond ((and (evenp flags
) (eql (car last
) 0))
526 (setf (first last
) flags
)
527 (push (car symbols
) (second last
))
528 (push value-form
(third last
))
529 (setf (fourth last
) (nconc ignore
(fourth last
))))
531 (push (list flags symbols
(list value-form
) ignore
)
533 ;; Starting with the innermost binding clause, snarf out the
534 ;; applicable declarations. (Clauses are currently reversed)
535 (dolist (abstract-clause repr
)
537 (multiple-value-bind (binding-decls remaining-decls
)
538 (extract-var-decls decls
(second abstract-clause
))
539 (setf (cddddr abstract-clause
) binding-decls
)
540 (setf decls remaining-decls
))))
541 ;; Generate sexprs from inside out.
542 (loop with listp
= t
; BODY is already a list
543 for
(flags symbols values ignore . binding-decls
) in repr
544 ;; Maybe test the last bound symbol in the clause for LET*
545 ;; or 1st symbol for mv-bind. Either way, the first of SYMBOLS.
546 for inner
= (if (logtest flags
2) ; :EXIT-IF-NULL was specified.
547 (prog1 `(when ,(car symbols
)
548 ,@(if listp body
(list body
)))
552 `(,.
(if (evenp flags
)
553 `(let* ,(nreverse (mapcar #'list symbols values
)))
554 `(multiple-value-bind ,symbols
,(car values
)))
555 ,@(when binding-decls
(list binding-decls
))
556 ,@(when ignore
`((declare (ignorable ,@ignore
))))
557 ,@decls
; anything leftover
558 ,@(if listp inner
(list inner
)))
563 ;;;; hash cache utility
565 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
566 (defvar *profile-hash-cache
* nil
))
568 ;;; Define a hash cache that associates some number of argument values
569 ;;; with a result value. The TEST-FUNCTION paired with each ARG-NAME
570 ;;; is used to compare the value for that arg in a cache entry with a
571 ;;; supplied arg. The TEST-FUNCTION must not error when passed NIL as
572 ;;; its first arg, but need not return any particular value.
573 ;;; TEST-FUNCTION may be any thing that can be placed in CAR position.
575 ;;; This code used to store all the arguments / return values directly
576 ;;; in the cache vector. This was both interrupt- and thread-unsafe, since
577 ;;; it was possible that *-CACHE-ENTER would scribble over a region of the
578 ;;; cache vector which *-CACHE-LOOKUP had only partially processed. Instead
579 ;;; we now store the contents of each cache bucket as a separate array, which
580 ;;; is stored in the appropriate cell in the cache vector. A new bucket array
581 ;;; is created every time *-CACHE-ENTER is called, and the old ones are never
582 ;;; modified. This means that *-CACHE-LOOKUP will always work with a set
583 ;;; of consistent data. The overhead caused by consing new buckets seems to
584 ;;; be insignificant on the grand scale of things. -- JES, 2006-11-02
586 ;;; NAME is used to define these functions:
587 ;;; <name>-CACHE-LOOKUP Arg*
588 ;;; See whether there is an entry for the specified ARGs in the
589 ;;; cache. If not present, the :DEFAULT keyword (default NIL)
590 ;;; determines the result(s).
591 ;;; <name>-CACHE-ENTER Arg* Value*
592 ;;; Encache the association of the specified args with VALUE.
593 ;;; <name>-CACHE-CLEAR
594 ;;; Reinitialize the cache, invalidating all entries and allowing
595 ;;; the arguments and result values to be GC'd.
597 ;;; These other keywords are defined:
599 ;;; The size of the cache as a power of 2.
600 ;;; :HASH-FUNCTION function
601 ;;; Some thing that can be placed in CAR position which will compute
602 ;;; a fixnum with at least (* 2 <hash-bits>) of information in it.
604 ;;; the number of return values cached for each function call
605 (defvar *cache-vector-symbols
* nil
)
607 (defun drop-all-hash-caches ()
608 (dolist (name *cache-vector-symbols
*)
611 ;; Make a new hash-cache and optionally create the statistics vector.
612 (defun alloc-hash-cache (size symbol
)
614 ;; It took me a while to figure out why infinite recursion could occur
615 ;; in VALUES-SPECIFIER-TYPE. It's because SET calls VALUES-SPECIFIER-TYPE.
616 (macrolet ((set! (symbol value
)
618 #-sb-xc-host sb
!kernel
:%set-symbol-global-value
621 ;; If statistics gathering is not not compiled-in,
622 ;; no sense in setting a symbol that is never used.
623 ;; While this uses SYMBOLICATE at runtime,
624 ;; it is inconsequential to performance.
625 (if *profile-hash-cache
*
627 (let ((*package
* (symbol-package symbol
)))
628 (symbolicate symbol
"STATISTICS"))))
629 (unless (boundp statistics
)
631 (make-array 3 :element-type
'fixnum
632 :initial-contents
'(1 0 0))))))))
633 ;; It would be bad if another thread sees MAKE-ARRAY's result in the
634 ;; global variable before the vector's header+length have been set.
635 ;; Without a barrier, this would be theoretically possible if the
636 ;; architecture allows out-of-order memory writes.
637 (sb!thread
:barrier
(:write
)
639 (setq cache
(make-array size
:initial-element
0)))
640 (set! symbol cache
))))
642 ;; At present we make a new vector every time a line is re-written,
643 ;; to make it thread-safe and interrupt-safe. A multi-word compare-and-swap
644 ;; is tricky to code and stronger than we need. It is possible instead
645 ;; to provide multi-word reads that can detect failure of atomicity,
646 ;; and on x86 it's possible to have atomic double-wide read/write,
647 ;; so a 1-arg/1-result cache line needn't cons at all except once
648 ;; (and maybe not even that if we make the cache into pairs of cells).
649 ;; But this way is easier to understand, for now anyway.
650 (eval-when (#-sb-xc
:compile-toplevel
:load-toplevel
:execute
)
651 (defun hash-cache-line-allocator (n)
652 (aref #.
(coerce (loop for i from
2 to
6
653 collect
(symbolicate "ALLOC-HASH-CACHE-LINE/"
654 (char "23456" (- i
2))))
658 (let* ((ftype `(sfunction ,(make-list n
:initial-element t
) t
))
659 (fn (hash-cache-line-allocator n
))
660 (args (make-gensym-list n
)))
662 (declaim (ftype ,ftype
,fn
))
664 (declare (optimize (safety 0)))
667 `(vector ,@args
)))))))
674 (defmacro !define-hash-cache
(name args
675 &key hash-function hash-bits memoizer
677 (declare (ignore memoizer
))
679 (unless (= (length arg
) 2)
680 (error "bad argument spec: ~S" arg
)))
681 (assert (typep hash-bits
'(integer 5 14))) ; reasonable bounds
682 (let* ((fun-name (symbolicate name
"-MEMO-WRAPPER"))
683 (var-name (symbolicate "**" name
"-CACHE-VECTOR**"))
685 (when *profile-hash-cache
*
686 (symbolicate var-name
"STATISTICS")))
687 (nargs (length args
))
688 (size (ash 1 hash-bits
))
689 (hashval (make-symbol "HASH"))
690 (cache (make-symbol "CACHE"))
691 (entry (make-symbol "LINE"))
692 (thunk (make-symbol "THUNK"))
693 (arg-vars (mapcar #'first args
))
694 (result-temps (loop for i from
1 to values
695 collect
(make-symbol (format nil
"RES~D" i
))))
696 (temps (append (mapcar (lambda (x) (make-symbol (string x
)))
699 (tests (mapcar (lambda (arg temp
) ; -> (EQx ARG #:ARG)
700 `(,(cadr arg
) ,(car arg
) ,temp
))
702 (cache-type `(simple-vector ,size
))
703 (line-type (let ((n (+ nargs values
)))
704 (if (<= n
3) 'cons
`(simple-vector ,n
))))
707 (2 `((,(first temps
) (car ,entry
))
708 (,(second temps
) (cdr ,entry
))))
709 (3 (let ((arg-temp (sb!xc
:gensym
"ARGS")))
710 `((,arg-temp
(cdr ,entry
))
711 (,(first temps
) (car ,entry
))
712 (,(second temps
) (car (truly-the cons
,arg-temp
)))
713 (,(third temps
) (cdr ,arg-temp
)))))
714 (t (loop for i from
0 for x in temps
715 collect
`(,x
(svref ,entry
,i
))))))
717 `(defun ,fun-name
(,thunk
,@arg-vars
)
718 ,@(when *profile-hash-cache
* ; count seeks
719 `((when (boundp ',statistics-name
)
720 (incf (aref ,statistics-name
0)))))
721 (let ((,hashval
(the (signed-byte #.sb
!vm
:n-fixnum-bits
)
722 (funcall ,hash-function
,@arg-vars
)))
725 (let ((,hashval
,hashval
))
726 (declare (type (signed-byte #.sb
!vm
:n-fixnum-bits
) ,hashval
))
728 (let ((,entry
(svref (truly-the ,cache-type
,cache
)
729 (ldb (byte ,hash-bits
0) ,hashval
))))
730 (unless (eql ,entry
0)
731 ;; This barrier is a no-op on all multi-threaded SBCL
732 ;; architectures. No CPU except Alpha will move a read
733 ;; prior to a read on which it depends.
734 (sb!thread
:barrier
(:data-dependency
))
735 (locally (declare (type ,line-type
,entry
))
738 (return-from ,fun-name
739 (values ,@result-temps
))))))
740 (setq ,hashval
(ash ,hashval
,(- hash-bits
)))))))
741 (multiple-value-bind ,result-temps
(funcall ,thunk
)
743 (,(hash-cache-line-allocator (+ nargs values
))
744 ,@arg-vars
,@result-temps
))
746 (truly-the ,cache-type
747 (or ,cache
(alloc-hash-cache ,size
',var-name
))))
748 (idx1 (ldb (byte ,hash-bits
0) ,hashval
))
749 (idx2 (ldb (byte ,hash-bits
,hash-bits
) ,hashval
)))
750 ,@(when *profile-hash-cache
*
751 `((incf (aref ,statistics-name
1)))) ; count misses
752 ;; Why a barrier: the pointer to 'entry' (a cons or vector)
753 ;; MUST NOT be observed by another thread before its cells
754 ;; are filled. Equally bad, the 'output' cells in the line
755 ;; could be 0 while the 'input' cells matched something.
756 (sb!thread
:barrier
(:write
))
757 (cond ((eql (svref ,cache idx1
) 0)
758 (setf (svref ,cache idx1
) ,entry
))
759 ((eql (svref ,cache idx2
) 0)
760 (setf (svref ,cache idx2
) ,entry
))
762 ,@(when *profile-hash-cache
* ; count evictions
763 `((incf (aref ,statistics-name
2))))
764 (setf (svref ,cache idx1
) ,entry
))))
765 (values ,@result-temps
))))))
767 (pushnew ',var-name
*cache-vector-symbols
*)
768 (defglobal ,var-name nil
)
769 ,@(when *profile-hash-cache
*
770 `((declaim (type (simple-array fixnum
(3)) ,statistics-name
))
771 (defvar ,statistics-name
)))
772 (declaim (type (or null
,cache-type
) ,var-name
))
773 (defun ,(symbolicate name
"-CACHE-CLEAR") () (setq ,var-name nil
))
774 (declaim (inline ,fun-name
))
777 ;;; some syntactic sugar for defining a function whose values are
778 ;;; cached by !DEFINE-HASH-CACHE
779 ;;; These keywords are mostly defined at !DEFINE-HASH-CACHE.
780 ;;; Additional options:
782 ;;; If provided, it is the name of a local macro that must be called
783 ;;; within the body forms to perform cache lookup/insertion.
784 ;;; If not provided, then the function's behavior is to automatically
785 ;;; attempt cache lookup, and on miss, execute the body code and
786 ;;; insert into the cache.
787 ;;; Manual control over memoization is useful if there are cases for
788 ;;; which computing the result is simpler than cache lookup.
790 (defmacro defun-cached
((name &rest options
&key
791 (memoizer (make-symbol "MEMOIZE")
794 args
&body body-decls-doc
)
795 (binding* (((forms decls doc
) (parse-body body-decls-doc
))
796 (arg-names (mapcar #'car args
)))
798 (!define-hash-cache
,name
,args
,@options
)
799 (defun ,name
,arg-names
801 ,@(if doc
(list doc
))
802 (macrolet ((,memoizer
(&body body
)
803 ;; We don't need (DX-FLET ((,thunk () ,@body)) ...)
804 ;; This lambda is a single-use local call within
805 ;; the inline memoizing wrapper.
806 `(,',(symbolicate name
"-MEMO-WRAPPER")
807 (lambda () ,@body
) ,@',arg-names
)))
808 ,@(if memoizer-supplied-p
810 `((,memoizer
,@forms
))))))))
812 ;;; FIXME: maybe not the best place
814 ;;; FIXME: think of a better name -- not only does this not have the
815 ;;; CAR recursion of EQUAL, it also doesn't have the special treatment
816 ;;; of pathnames, bit-vectors and strings.
818 ;;; KLUDGE: This means that we will no longer cache specifiers of the
819 ;;; form '(INTEGER (0) 4). This is probably not a disaster.
821 ;;; A helper function for the type system, which is the main user of
822 ;;; these caches: we must be more conservative than EQUAL for some of
823 ;;; our equality tests, because MEMBER and friends refer to EQLity.
825 (defun equal-but-no-car-recursion (x y
)
827 (cond ((eql x y
) (return t
))
830 (eql (pop x
) (pop y
))))
836 ;;; Note: Almost always you want to use FIND-UNDELETED-PACKAGE-OR-LOSE
837 ;;; instead of this function. (The distinction only actually matters when
838 ;;; PACKAGE-DESIGNATOR is actually a deleted package, and in that case
839 ;;; you generally do want to signal an error instead of proceeding.)
840 (defun %find-package-or-lose
(package-designator)
841 (or (find-package package-designator
)
842 (error 'simple-package-error
843 :package package-designator
844 :format-control
"The name ~S does not designate any package."
845 :format-arguments
(list package-designator
))))
847 ;;; ANSI specifies (in the section for FIND-PACKAGE) that the
848 ;;; consequences of most operations on deleted packages are
849 ;;; unspecified. We try to signal errors in such cases.
850 (defun find-undeleted-package-or-lose (package-designator)
851 (let ((maybe-result (%find-package-or-lose package-designator
)))
852 (if (package-name maybe-result
) ; if not deleted
854 (error 'simple-package-error
855 :package maybe-result
856 :format-control
"The package ~S has been deleted."
857 :format-arguments
(list maybe-result
)))))
859 ;;;; various operations on names
861 ;;; Is NAME a legal function name?
862 (declaim (inline legal-fun-name-p
))
863 (defun legal-fun-name-p (name)
864 (values (valid-function-name-p name
)))
866 (deftype function-name
() '(satisfies legal-fun-name-p
))
868 ;;; Signal an error unless NAME is a legal function name.
869 (defun legal-fun-name-or-type-error (name)
870 (unless (legal-fun-name-p name
)
871 (error 'simple-type-error
873 :expected-type
'function-name
874 :format-control
"invalid function name: ~S"
875 :format-arguments
(list name
))))
877 ;;; Given a function name, return the symbol embedded in it.
879 ;;; The ordinary use for this operator (and the motivation for the
880 ;;; name of this operator) is to convert from a function name to the
881 ;;; name of the BLOCK which encloses its body.
883 ;;; Occasionally the operator is useful elsewhere, where the operator
884 ;;; name is less mnemonic. (Maybe it should be changed?)
885 (declaim (ftype (function ((or symbol cons
)) symbol
) fun-name-block-name
))
886 (defun fun-name-block-name (fun-name)
887 (if (symbolp fun-name
)
889 (multiple-value-bind (legalp block-name
)
890 (valid-function-name-p fun-name
)
893 (error "not legal as a function name: ~S" fun-name
)))))
895 (defun looks-like-name-of-special-var-p (x)
898 (let ((name (symbol-name x
)))
899 (and (> (length name
) 2) ; to exclude '* and '**
900 (char= #\
* (aref name
0))
901 (char= #\
* (aref name
(1- (length name
))))))))
905 ;;;; "The macro ONCE-ONLY has been around for a long time on various
906 ;;;; systems [..] if you can understand how to write and when to use
907 ;;;; ONCE-ONLY, then you truly understand macro." -- Peter Norvig,
908 ;;;; _Paradigms of Artificial Intelligence Programming: Case Studies
909 ;;;; in Common Lisp_, p. 853
911 ;;; ONCE-ONLY is a utility useful in writing source transforms and
912 ;;; macros. It provides a concise way to wrap a LET around some code
913 ;;; to ensure that some forms are only evaluated once.
915 ;;; Create a LET* which evaluates each value expression, binding a
916 ;;; temporary variable to the result, and wrapping the LET* around the
917 ;;; result of the evaluation of BODY. Within the body, each VAR is
918 ;;; bound to the corresponding temporary variable.
919 (defmacro once-only
(specs &body body
)
920 (named-let frob
((specs specs
)
924 (let ((spec (first specs
)))
925 ;; FIXME: should just be DESTRUCTURING-BIND of SPEC
926 (unless (proper-list-of-length-p spec
2)
927 (error "malformed ONCE-ONLY binding spec: ~S" spec
))
928 (let* ((name (first spec
))
929 (exp-temp (gensym "ONCE-ONLY")))
930 `(let ((,exp-temp
,(second spec
))
931 (,name
(sb!xc
:gensym
,(symbol-name name
))))
932 `(let ((,,name
,,exp-temp
))
933 ,,(frob (rest specs
) body
))))))))
935 ;;;; various error-checking utilities
937 ;;; This function can be used as the default value for keyword
938 ;;; arguments that must be always be supplied. Since it is known by
939 ;;; the compiler to never return, it will avoid any compile-time type
940 ;;; warnings that would result from a default value inconsistent with
941 ;;; the declared type. When this function is called, it signals an
942 ;;; error indicating that a required &KEY argument was not supplied.
943 ;;; This function is also useful for DEFSTRUCT slot defaults
944 ;;; corresponding to required arguments.
945 (declaim (ftype (function () nil
) missing-arg
))
946 (defun missing-arg ()
948 (/show0
"entering MISSING-ARG")
949 (error "A required &KEY or &OPTIONAL argument was not supplied."))
951 ;;; like CL:ASSERT and CL:CHECK-TYPE, but lighter-weight
953 ;;; (As of sbcl-0.6.11.20, we were using some 400 calls to CL:ASSERT.
954 ;;; The CL:ASSERT restarts and whatnot expand into a significant
955 ;;; amount of code when you multiply them by 400, so replacing them
956 ;;; with this should reduce the size of the system by enough to be
957 ;;; worthwhile. ENFORCE-TYPE is much less common, but might still be
958 ;;; worthwhile, and since I don't really like CERROR stuff deep in the
959 ;;; guts of complex systems anyway, I replaced it too.)
960 (defmacro aver
(expr)
962 (%failed-aver
',expr
)))
964 (defun %failed-aver
(expr)
965 ;; hackish way to tell we're in a cold sbcl and output the
966 ;; message before signalling error, as it may be this is too
967 ;; early in the cold init.
968 (when (find-package "SB!C")
970 (write-line "failed AVER:")
973 (bug "~@<failed AVER: ~2I~_~A~:>" expr
))
975 (defun bug (format-control &rest format-arguments
)
977 :format-control format-control
978 :format-arguments format-arguments
))
980 (defmacro enforce-type
(value type
)
981 (once-only ((value value
))
982 `(unless (typep ,value
',type
)
983 (%failed-enforce-type
,value
',type
))))
985 (defun %failed-enforce-type
(value type
)
986 ;; maybe should be TYPE-BUG, subclass of BUG? If it is changed,
987 ;; check uses of it in user-facing code (e.g. WARN)
988 (error 'simple-type-error
991 :format-control
"~@<~S ~_is not a ~_~S~:>"
992 :format-arguments
(list value type
)))
994 ;;; Return a function like FUN, but expecting its (two) arguments in
995 ;;; the opposite order that FUN does.
996 (declaim (inline swapped-args-fun
))
997 (defun swapped-args-fun (fun)
998 (declare (type function fun
))
1002 ;;; Return the numeric value of a type bound, i.e. an interval bound
1003 ;;; more or less in the format of bounds in ANSI's type specifiers,
1004 ;;; where a bare numeric value is a closed bound and a list of a
1005 ;;; single numeric value is an open bound.
1007 ;;; The "more or less" bit is that the no-bound-at-all case is
1008 ;;; represented by NIL (not by * as in ANSI type specifiers); and in
1009 ;;; this case we return NIL.
1010 (defun type-bound-number (x)
1012 (destructuring-bind (result) x result
)
1015 ;;; some commonly-occuring CONSTANTLY forms
1016 (macrolet ((def-constantly-fun (name constant-expr
)
1017 `(setf (symbol-function ',name
)
1018 (constantly ,constant-expr
))))
1019 (def-constantly-fun constantly-t t
)
1020 (def-constantly-fun constantly-nil nil
)
1021 (def-constantly-fun constantly-0
0))
1023 ;;; If X is a symbol, see whether it is present in *FEATURES*. Also
1024 ;;; handle arbitrary combinations of atoms using NOT, AND, OR.
1032 (error "too many subexpressions in feature expression: ~S" x
))
1034 (error "too few subexpressions in feature expression: ~S" x
))
1035 (t (not (featurep (cadr x
))))))
1036 ((:and and
) (every #'featurep
(cdr x
)))
1037 ((:or or
) (some #'featurep
(cdr x
)))
1039 (error "unknown operator in feature expression: ~S." x
))))
1040 (symbol (not (null (memq x
*features
*))))
1042 (error "invalid feature expression: ~S" x
))))
1045 ;;;; utilities for two-VALUES predicates
1047 (defmacro not
/type
(x)
1048 (let ((val (gensym "VAL"))
1049 (win (gensym "WIN")))
1050 `(multiple-value-bind (,val
,win
)
1053 (values (not ,val
) t
)
1054 (values nil nil
)))))
1056 (defmacro and
/type
(x y
)
1057 `(multiple-value-bind (val1 win1
) ,x
1058 (if (and (not val1
) win1
)
1060 (multiple-value-bind (val2 win2
) ,y
1063 (values nil
(and win2
(not val2
))))))))
1065 ;;; sort of like ANY and EVERY, except:
1066 ;;; * We handle two-VALUES predicate functions, as SUBTYPEP does.
1067 ;;; (And if the result is uncertain, then we return (VALUES NIL NIL),
1068 ;;; as SUBTYPEP does.)
1069 ;;; * THING is just an atom, and we apply OP (an arity-2 function)
1070 ;;; successively to THING and each element of LIST.
1071 (defun any/type
(op thing list
)
1072 (declare (type function op
))
1074 (dolist (i list
(values nil certain?
))
1075 (multiple-value-bind (sub-value sub-certain?
) (funcall op thing i
)
1077 (when sub-value
(return (values t t
)))
1078 (setf certain? nil
))))))
1079 (defun every/type
(op thing list
)
1080 (declare (type function op
))
1082 (dolist (i list
(if certain?
(values t t
) (values nil nil
)))
1083 (multiple-value-bind (sub-value sub-certain?
) (funcall op thing i
)
1085 (unless sub-value
(return (values nil t
)))
1086 (setf certain? nil
))))))
1090 ;;; These functions are called by the expansion of the DEFPRINTER
1091 ;;; macro to do the actual printing.
1092 (declaim (ftype (function (symbol t stream
) (values))
1093 defprinter-prin1 defprinter-princ
))
1094 (defun defprinter-prin1 (name value stream
)
1095 (defprinter-prinx #'prin1 name value stream
))
1096 (defun defprinter-princ (name value stream
)
1097 (defprinter-prinx #'princ name value stream
))
1098 (defun defprinter-prinx (prinx name value stream
)
1099 (declare (type function prinx
))
1100 (when *print-pretty
*
1101 (pprint-newline :linear stream
))
1102 (format stream
":~A " name
)
1103 (funcall prinx value stream
)
1105 (defun defprinter-print-space (stream)
1106 (write-char #\space stream
))
1108 ;;; Define some kind of reasonable PRINT-OBJECT method for a
1109 ;;; STRUCTURE-OBJECT class.
1111 ;;; NAME is the name of the structure class, and CONC-NAME is the same
1112 ;;; as in DEFSTRUCT.
1114 ;;; The SLOT-DESCS describe how each slot should be printed. Each
1115 ;;; SLOT-DESC can be a slot name, indicating that the slot should
1116 ;;; simply be printed. A SLOT-DESC may also be a list of a slot name
1117 ;;; and other stuff. The other stuff is composed of keywords followed
1118 ;;; by expressions. The expressions are evaluated with the variable
1119 ;;; which is the slot name bound to the value of the slot. These
1120 ;;; keywords are defined:
1122 ;;; :PRIN1 Print the value of the expression instead of the slot value.
1123 ;;; :PRINC Like :PRIN1, only PRINC the value
1124 ;;; :TEST Only print something if the test is true.
1126 ;;; If no printing thing is specified then the slot value is printed
1129 ;;; The structure being printed is bound to STRUCTURE and the stream
1130 ;;; is bound to STREAM.
1131 (defmacro defprinter
((name
1133 (conc-name (concatenate 'simple-string
1140 (reversed-prints nil
)
1141 (stream (sb!xc
:gensym
"STREAM")))
1142 (flet ((sref (slot-name)
1143 `(,(symbolicate conc-name slot-name
) structure
)))
1144 (dolist (slot-desc slot-descs
)
1146 (setf maybe-print-space nil
1148 (setf maybe-print-space
`(defprinter-print-space ,stream
)))
1149 (cond ((atom slot-desc
)
1150 (push maybe-print-space reversed-prints
)
1151 (push `(defprinter-prin1 ',slot-desc
,(sref slot-desc
) ,stream
)
1154 (let ((sname (first slot-desc
))
1157 (do ((option (rest slot-desc
) (cddr option
)))
1159 (push `(let ((,sname
,(sref sname
)))
1164 ',sname
,sname
,stream
)))))
1166 (case (first option
)
1168 (stuff `(defprinter-prin1
1169 ',sname
,(second option
) ,stream
)))
1171 (stuff `(defprinter-princ
1172 ',sname
,(second option
) ,stream
)))
1173 (:test
(setq test
(second option
)))
1175 (error "bad option: ~S" (first option
)))))))))))
1176 `(sb!xc
:defmethod
print-object ((structure ,name
) ,stream
)
1177 (pprint-logical-block (,stream nil
)
1178 (print-unreadable-object (structure
1181 :identity
,identity
)
1182 ,@(nreverse reversed-prints
))))))
1184 (defun print-symbol-with-prefix (stream symbol
&optional colon at
)
1186 "For use with ~/: Write SYMBOL to STREAM as if it is not accessible from
1187 the current package."
1188 (declare (ignore colon at
))
1189 ;; Only keywords should be accessible from the keyword package, and
1190 ;; keywords are always printed with colons, so this guarantees that the
1191 ;; symbol will not be printed without a prefix.
1192 (let ((*package
* *keyword-package
*))
1193 (write symbol
:stream stream
:escape t
)))
1197 ;;; Given a pathname, return a corresponding physical pathname.
1198 (defun physicalize-pathname (possibly-logical-pathname)
1199 (if (typep possibly-logical-pathname
'logical-pathname
)
1200 (translate-logical-pathname possibly-logical-pathname
)
1201 possibly-logical-pathname
))
1203 ;;;; Deprecating stuff
1205 (defun normalize-deprecation-replacements (replacements)
1206 (if (or (not (listp replacements
))
1207 (eq 'setf
(car replacements
)))
1211 (defun deprecation-error (since name replacements
)
1212 (error 'deprecation-error
1214 :replacements
(normalize-deprecation-replacements replacements
)
1217 (defun deprecation-warning (state since name replacements
1218 &key
(runtime-error (neq :early state
)))
1220 (:early
'early-deprecation-warning
)
1221 (:late
'late-deprecation-warning
)
1222 (:final
'final-deprecation-warning
))
1224 :replacements
(normalize-deprecation-replacements replacements
)
1226 :runtime-error runtime-error
))
1228 (defun deprecated-function (since name replacements
&optional doc
)
1230 ;; setting the name is mildly redundant since the closure captures
1231 ;; its name. However %FUN-DOC can't make use of that fact.
1233 (lambda (&rest deprecated-function-args
)
1234 (declare (ignore deprecated-function-args
))
1235 (deprecation-error since name replacements
))
1238 (setf (%fun-doc closure
) doc
))
1241 (defun deprecation-compiler-macro (state since name replacements
)
1242 ;; this lambda's name is significant - see DEPRECATED-THING-P
1243 (named-lambda .deprecation-warning.
(form env
)
1244 (declare (ignore env
))
1245 (deprecation-warning state since name replacements
)
1248 ;; Return the stage of deprecation of thing identified by KIND and NAME, or NIL.
1249 (defun deprecated-thing-p (kind name
)
1252 (let ((macro-fun (info :function
:compiler-macro-function name
)))
1253 (and (closurep macro-fun
)
1254 (eq (%fun-name macro-fun
) '.deprecation-warning.
)
1255 ;; If you name a function literally :EARLY and it happens to
1256 ;; be in :LATE deprecation, then this could be wrong; etc.
1257 ;; But come on now ... who would name a function like that?
1258 (find-if-in-closure (lambda (x) (member x
'(:early
:late
:final
)))
1261 ;; This is the moral equivalent of a warning from /usr/bin/ld that
1262 ;; "gets() is dangerous." You're informed by both the compiler and linker.
1263 (defun loader-deprecation-warn (stuff whence
)
1264 ;; Stuff is a list: ((<state> name . category) ...)
1265 ;; For now we only deal with category = :FUNCTION so we ignore it.
1266 (let ((warning-class
1267 ;; We're only going to warn once (per toplevel form),
1268 ;; so pick the most stern warning applicable.
1269 (if (every (lambda (x) (eq (car x
) :early
)) stuff
)
1270 'simple-style-warning
'simple-warning
)))
1272 :format-control
"Reference to deprecated function~P ~S~@[ from ~S~]"
1274 (list (length stuff
) (mapcar #'second stuff
) whence
))))
1278 ;;; :EARLY, for a compile-time style-warning.
1279 ;;; :LATE, for a compile-time full warning.
1280 ;;; :FINAL, for a compile-time full warning and runtime error.
1282 ;;; Suggested duration of each stage is one year, but some things can move faster,
1283 ;;; and some widely used legacy APIs might need to move slower. Internals we don't
1284 ;;; usually add deprecation notes for, but sometimes an internal API actually has
1285 ;;; several external users, in which case we try to be nice about it.
1287 ;;; When you deprecate something, note it here till it is fully gone: makes it
1288 ;;; easier to keep things progressing orderly. Also add the relevant section
1289 ;;; (or update it when deprecation proceeds) in the manual, in
1290 ;;; deprecated.texinfo.
1293 ;;; - SOCKINT::WIN32-BIND since 1.2.10 (03/2015) -> Late: 08/2015
1294 ;;; - SOCKINT::WIN32-GETSOCKNAME since 1.2.10 (03/2015) -> Late: 08/2015
1295 ;;; - SOCKINT::WIN32-LISTEN since 1.2.10 (03/2015) -> Late: 08/2015
1296 ;;; - SOCKINT::WIN32-RECV since 1.2.10 (03/2015) -> Late: 08/2015
1297 ;;; - SOCKINT::WIN32-RECVFROM since 1.2.10 (03/2015) -> Late: 08/2015
1298 ;;; - SOCKINT::WIN32-SEND since 1.2.10 (03/2015) -> Late: 08/2015
1299 ;;; - SOCKINT::WIN32-SENDTO since 1.2.10 (03/2015) -> Late: 08/2015
1300 ;;; - SOCKINT::WIN32-CLOSE since 1.2.10 (03/2015) -> Late: 08/2015
1301 ;;; - SOCKINT::WIN32-CONNECT since 1.2.10 (03/2015) -> Late: 08/2015
1302 ;;; - SOCKINT::WIN32-GETPEERNAME since 1.2.10 (03/2015) -> Late: 08/2015
1303 ;;; - SOCKINT::WIN32-IOCTL since 1.2.10 (03/2015) -> Late: 08/2015
1304 ;;; - SOCKINT::WIN32-SETSOCKOPT since 1.2.10 (03/2015) -> Late: 08/2015
1305 ;;; - SOCKINT::WIN32-GETSOCKOPT since 1.2.10 (03/2015) -> Late: 08/2015
1307 ;;; - SB-THREAD::GET-MUTEX, since 1.0.37.33 (04/2010) -> Late: 01/2013
1308 ;;; ^- initially deprecated without compile-time warning, hence the schedule
1309 ;;; - SB-THREAD::SPINLOCK (type), since 1.0.53.11 (08/2011) -> Late: 08/2012
1310 ;;; - SB-THREAD::MAKE-SPINLOCK, since 1.0.53.11 (08/2011) -> Late: 08/2012
1311 ;;; - SB-THREAD::WITH-SPINLOCK, since 1.0.53.11 (08/2011) -> Late: 08/2012
1312 ;;; - SB-THREAD::WITH-RECURSIVE-SPINLOCK, since 1.0.53.11 (08/2011) -> Late: 08/2012
1313 ;;; - SB-THREAD::GET-SPINLOCK, since 1.0.53.11 (08/2011) -> Late: 08/2012
1314 ;;; - SB-THREAD::RELEASE-SPINLOCK, since 1.0.53.11 (08/2011) -> Late: 08/2012
1315 ;;; - SB-THREAD::SPINLOCK-VALUE, since 1.0.53.11 (08/2011) -> Late: 08/2012
1316 ;;; - SB-THREAD::SPINLOCK-NAME, since 1.0.53.11 (08/2011) -> Late: 08/2012
1317 ;;; - SETF SB-THREAD::SPINLOCK-NAME, since 1.0.53.11 (08/2011) -> Late: 08/2012
1318 ;;; - SB-C::MERGE-TAIL-CALLS (policy), since 1.0.53.74 (11/2011) -> Late: 11/2012
1319 ;;; - SB-EXT:QUIT, since 1.0.56.55 (05/2012) -> Late: 05/2013
1320 ;;; - SB-UNIX:UNIX-EXIT, since 1.0.56.55 (05/2012) -> Late: 05/2013
1321 ;;; - SB-DEBUG:*SHOW-ENTRY-POINT-DETAILS*, since 1.1.4.9 (02/2013) -> Late: 02/2014
1324 ;;; - SB-SYS:OUTPUT-RAW-BYTES, since 1.0.8.16 (06/2007) -> Final: anytime
1325 ;;; Note: make sure CLX doesn't use it anymore!
1326 ;;; - SB-C::STACK-ALLOCATE-DYNAMIC-EXTENT (policy), since 1.0.19.7 -> Final: anytime
1327 ;;; - SB-C::STACK-ALLOCATE-VECTOR (policy), since 1.0.19.7 -> Final: anytime
1328 ;;; - SB-C::STACK-ALLOCATE-VALUE-CELLS (policy), since 1.0.19.7 -> Final: anytime
1329 ;;; - SB-INTROSPECT:FUNCTION-ARGLIST, since 1.0.24.5 (01/2009) -> Final: anytime
1330 ;;; - SB-THREAD:JOIN-THREAD-ERROR-THREAD, since 1.0.29.17 (06/2009) -> Final: 09/2012
1331 ;;; - SB-THREAD:INTERRUPT-THREAD-ERROR-THREAD since 1.0.29.17 (06/2009) -> Final: 06/2012
1333 (deftype deprecation-state
()
1334 '(member :early
:late
:final
))
1336 (defun print-deprecation-message (name since
&optional replacements stream
)
1337 (apply #'format stream
1338 (!uncross-format-control
1339 "~/sb!impl:print-symbol-with-prefix/ has been ~
1340 deprecated as of SBCL ~A.~
1342 ~2%Use ~/sb!impl:print-symbol-with-prefix/ instead.~;~
1343 ~2%Use ~/sb!impl:print-symbol-with-prefix/ or ~
1344 ~/sb!impl:print-symbol-with-prefix/ instead.~:;~
1345 ~2%Use~@{~#[~; or~] ~
1346 ~/sb!impl:print-symbol-with-prefix/~^,~} instead.~
1348 name since replacements
))
1350 (defmacro define-deprecated-function
(state since name replacements lambda-list
1352 (declare (type deprecation-state state
)
1354 (type function-name name
)
1355 (type (or function-name list
) replacements
)
1356 (type list lambda-list
))
1357 (let* ((replacements (normalize-deprecation-replacements replacements
))
1358 (doc (print-deprecation-message name since replacements
)))
1359 (declare (ignorable doc
))
1363 `(defun ,name
,lambda-list
1368 (declaim (ftype (function * nil
) ,name
))
1369 (setf (fdefinition ',name
)
1370 (deprecated-function ,since
',name
',replacements
1373 (setf (compiler-macro-function ',name
)
1374 (deprecation-compiler-macro ,state
,since
',name
',replacements
)))))
1376 (defun check-deprecated-variable (name)
1377 (let ((info (info :variable
:deprecated name
)))
1379 (deprecation-warning (first info
) (second info
) name
(third info
))
1380 (values-list info
))))
1382 (defmacro define-deprecated-variable
(state since name
1383 &key
(value nil valuep
) replacement
)
1384 (declare (ignorable replacement
)
1385 (type deprecation-state state
)
1389 (setf (info :variable
:deprecated
',name
)
1390 '(,state
,since
,(when replacement
`(,replacement
))))
1391 ,(if (member state
'(:early
:late
))
1392 `(defvar ,name
,@(when valuep
(list value
)))
1395 (setf (fdocumentation ',name
'variable
)
1396 ,(print-deprecation-message name since
(list replacement
)))))
1398 ;;; Anaphoric macros
1399 (defmacro awhen
(test &body body
)
1403 (defmacro acond
(&rest clauses
)
1406 (destructuring-bind ((test &body body
) &rest rest
) clauses
1407 (once-only ((test test
))
1409 (let ((it ,test
)) (declare (ignorable it
)),@body
)
1412 ;; Given DECLS as returned by from parse-body, and SYMBOLS to be bound
1413 ;; (with LET, MULTIPLE-VALUE-BIND, etc) return two sets of declarations:
1414 ;; those which pertain to the variables and those which don't.
1415 ;; The first returned value is NIL or a single expression headed by DECLARE.
1416 ;; The second is a list of expressions resembling the input DECLS.
1417 (defun extract-var-decls (decls symbols
)
1418 (unless symbols
; Don't bother filtering DECLS, just return them.
1419 (return-from extract-var-decls
(values nil decls
)))
1420 (labels ((applies-to-variables (decl)
1421 ;; If DECL is a variable-affecting declaration, then return
1422 ;; the subset of SYMBOLS to which DECL applies.
1423 (let ((id (car decl
)))
1424 (remove-if (lambda (x) (not (memq x symbols
)))
1425 (cond ((eq id
'type
)
1427 ((or (listp id
) ; must be a type-specifier
1428 (memq id
'(special ignorable ignore
1430 truly-dynamic-extent
))
1431 (info :type
:kind id
))
1434 ;; If SPEC is a declaration affecting some variables in SYMBOLS
1435 ;; and some not, split it into two mutually exclusive declarations.
1436 (acond ((applies-to-variables spec
)
1437 (multiple-value-bind (decl-head all-symbols
)
1438 (if (eq (car spec
) 'type
)
1439 (values `(type ,(cadr spec
)) (cddr spec
))
1440 (values `(,(car spec
)) (cdr spec
)))
1441 (let ((more (set-difference all-symbols it
)))
1442 (values `(,@decl-head
,@it
)
1443 (and more
`(,@decl-head
,@more
))))))
1445 (values nil spec
)))))
1446 ;; This loop is less inefficient than theoretically possible,
1447 ;; reconstructing the tree even if no need,
1448 ;; but it's just a macroexpander, so... fine.
1449 (collect ((binding-decls))
1451 (mapcar (lambda (decl-expr) ; a list headed by DECLARE
1452 (mapcan (lambda (spec)
1453 (multiple-value-bind (binding other
)
1456 (binding-decls binding
))
1457 (if other
(list other
))))
1460 (values (awhen (binding-decls) `(declare ,@it
))
1461 (mapcan (lambda (x) (if x
(list `(declare ,@x
)))) filtered
))))))
1463 ;;; Delayed evaluation
1464 (defmacro delay
(form)
1465 `(cons nil
(lambda () ,form
)))
1467 (defun force (promise)
1468 (cond ((not (consp promise
)) promise
)
1469 ((car promise
) (cdr promise
))
1470 (t (setf (car promise
) t
1471 (cdr promise
) (funcall (cdr promise
))))))
1473 (defun promise-ready-p (promise)
1474 (or (not (consp promise
))
1478 (defmacro with-rebound-io-syntax
(&body body
)
1479 `(%with-rebound-io-syntax
(lambda () ,@body
)))
1481 (defun %with-rebound-io-syntax
(function)
1482 (declare (type function function
))
1483 (let ((*package
* *package
*)
1484 (*print-array
* *print-array
*)
1485 (*print-base
* *print-base
*)
1486 (*print-case
* *print-case
*)
1487 (*print-circle
* *print-circle
*)
1488 (*print-escape
* *print-escape
*)
1489 (*print-gensym
* *print-gensym
*)
1490 (*print-length
* *print-length
*)
1491 (*print-level
* *print-level
*)
1492 (*print-lines
* *print-lines
*)
1493 (*print-miser-width
* *print-miser-width
*)
1494 (*print-pretty
* *print-pretty
*)
1495 (*print-radix
* *print-radix
*)
1496 (*print-readably
* *print-readably
*)
1497 (*print-right-margin
* *print-right-margin
*)
1498 (*read-base
* *read-base
*)
1499 (*read-default-float-format
* *read-default-float-format
*)
1500 (*read-eval
* *read-eval
*)
1501 (*read-suppress
* *read-suppress
*)
1502 (*readtable
* *readtable
*))
1503 (funcall function
)))
1505 ;;; Bind a few "potentially dangerous" printer control variables to
1506 ;;; safe values, respecting current values if possible.
1507 (defmacro with-sane-io-syntax
(&body forms
)
1508 `(call-with-sane-io-syntax (lambda () ,@forms
)))
1510 (defun call-with-sane-io-syntax (function)
1511 (declare (type function function
))
1512 (macrolet ((true (sym)
1513 `(and (boundp ',sym
) ,sym
)))
1514 (let ((*print-readably
* nil
)
1515 (*print-level
* (or (true *print-level
*) 6))
1516 (*print-length
* (or (true *print-length
*) 12)))
1517 (funcall function
))))
1519 ;;; Returns a list of members of LIST. Useful for dealing with circular lists.
1520 ;;; For a dotted list returns a secondary value of T -- in which case the
1521 ;;; primary return value does not include the dotted tail.
1522 ;;; If the maximum length is reached, return a secondary value of :MAYBE.
1523 (defun list-members (list &key max-length
)
1525 (do ((tail (cdr list
) (cdr tail
))
1526 (members (list (car list
)) (cons (car tail
) members
))
1527 (count 0 (1+ count
)))
1528 ((or (not (consp tail
)) (eq tail list
)
1529 (and max-length
(>= count max-length
)))
1530 (values members
(or (not (listp tail
))
1531 (and (>= count max-length
) :maybe
)))))))
1533 ;;; Default evaluator mode (interpeter / compiler)
1535 (declaim (type (member :compile
#!+sb-eval
:interpret
) *evaluator-mode
*))
1536 (!defparameter
*evaluator-mode
* :compile
1538 "Toggle between different evaluator implementations. If set to :COMPILE,
1539 an implementation of EVAL that calls the compiler will be used. If set
1540 to :INTERPRET, an interpreter will be used.")
1542 ;;; Helper for making the DX closure allocation in macros expanding
1543 ;;; to CALL-WITH-FOO less ugly.
1544 (def!macro dx-flet
(functions &body forms
)
1546 (declare (truly-dynamic-extent ,@(mapcar (lambda (func) `#',(car func
))
1550 ;;; Another similar one.
1551 (def!macro dx-let
(bindings &body forms
)
1553 (declare (truly-dynamic-extent
1554 ,@(mapcar (lambda (bind) (if (listp bind
) (car bind
) bind
))
1558 ;; This is not my preferred name for this function, but chosen for harmony
1559 ;; with everything else that refers to these as 'hash-caches'.
1560 ;; Hashing is just one particular way of memoizing, and it would have been
1561 ;; slightly more abstract and yet at the same time more concrete to say
1562 ;; "memoized-function-caches". "hash-caches" is pretty nonspecific.
1563 #.
(if *profile-hash-cache
*
1564 '(defun show-hash-cache-statistics ()
1565 (flet ((cache-stats (symbol)
1566 (let* ((name (string symbol
))
1567 (statistics (let ((*package
* (symbol-package symbol
)))
1568 (symbolicate symbol
"STATISTICS")))
1570 (subseq name
0 (- (length name
) (length "VECTOR**")))))
1571 (values (if (boundp statistics
)
1572 (symbol-value statistics
)
1573 (make-array 3 :element-type
'fixnum
))
1574 (subseq prefix
2 (1- (length prefix
)))))))
1575 (format t
"~%Type function memoization:~% Seek Hit (%)~:
1576 Evict (%) Size full~%")
1577 ;; Sort by descending seek count to rank by likely relative importance
1578 (dolist (symbol (sort (copy-list *cache-vector-symbols
*) #'>
1579 :key
(lambda (x) (aref (cache-stats x
) 0))))
1580 (binding* (((stats short-name
) (cache-stats symbol
))
1581 (seek (aref stats
0))
1582 (miss (aref stats
1))
1584 (evict (aref stats
2))
1585 (cache (symbol-value symbol
)))
1586 (format t
"~9d ~9d (~5,1f%) ~8d (~5,1f%) ~4d ~6,1f% ~A~%"
1588 (if (plusp seek
) (* 100 (/ hit seek
)))
1590 (if (plusp seek
) (* 100 (/ evict seek
)))
1592 (if (plusp (length cache
))
1593 (* 100 (/ (count-if-not #'fixnump cache
)
1597 (in-package "SB!KERNEL")
1599 (defun fp-zero-p (x)
1601 (single-float (zerop x
))
1602 (double-float (zerop x
))
1604 (long-float (zerop x
))
1607 (defun neg-fp-zero (x)
1611 (make-unportable-float :single-float-negative-zero
)
1615 (make-unportable-float :double-float-negative-zero
)
1620 (make-unportable-float :long-float-negative-zero
)
1623 ;;; Signalling an error when trying to print an error condition is
1624 ;;; generally a PITA, so whatever the failure encountered when
1625 ;;; wondering about FILE-POSITION within a condition printer, 'tis
1626 ;;; better silently to give up than to try to complain.
1627 (defun file-position-or-nil-for-error (stream &optional
(pos nil posp
))
1628 ;; Arguably FILE-POSITION shouldn't be signalling errors at all; but
1629 ;; "NIL if this cannot be determined" in the ANSI spec doesn't seem
1630 ;; absolutely unambiguously to prohibit errors when, e.g., STREAM
1631 ;; has been closed so that FILE-POSITION is a nonsense question. So
1632 ;; my (WHN) impression is that the conservative approach is to
1633 ;; IGNORE-ERRORS. (I encountered this failure from within a homebrew
1634 ;; defsystemish operation where the ERROR-STREAM had been CL:CLOSEd,
1635 ;; I think by nonlocally exiting through a WITH-OPEN-FILE, by the
1636 ;; time an error was reported.)
1639 (file-position stream pos
)
1640 (file-position stream
))))
1642 (defun stream-error-position-info (stream &optional position
)
1643 (when (and (not position
) (form-tracking-stream-p stream
))
1644 (let ((line/col
(line/col-from-charpos stream
)))
1645 (return-from stream-error-position-info
1646 `((:line
,(car line
/col
))
1647 (:column
,(cdr line
/col
))
1648 ,@(let ((position (file-position-or-nil-for-error stream
)))
1649 ;; FIXME: 1- is technically broken for multi-byte external
1650 ;; encodings, albeit bug-compatible with the broken code in
1651 ;; the general case (below) for non-form-tracking-streams.
1652 ;; i.e. If you position to this byte, it might not be the
1653 ;; first byte of any character.
1654 (when position
`((:file-position
,(1- position
)))))))))
1656 ;; Give up early for interactive streams and non-character stream.
1657 (when (or (ignore-errors (interactive-stream-p stream
))
1658 (not (subtypep (ignore-errors (stream-element-type stream
))
1660 (return-from stream-error-position-info
))
1662 (flet ((read-content (old-position position
)
1663 "Read the content of STREAM into a buffer in order to count
1665 (unless (and old-position position
1666 (< position sb
!xc
:array-dimension-limit
))
1667 (return-from read-content
))
1669 (make-string position
:element-type
(stream-element-type stream
))))
1670 (when (and (file-position-or-nil-for-error stream
:start
)
1671 (eql position
(ignore-errors (read-sequence content stream
))))
1672 (file-position-or-nil-for-error stream old-position
)
1674 ;; Lines count from 1, columns from 0. It's stupid and
1677 (1+ (count #\Newline string
)))
1678 (column (string position
)
1679 (- position
(or (position #\Newline string
:from-end t
) 0))))
1680 (let* ((stream-position (file-position-or-nil-for-error stream
))
1681 (position (or position
1682 ;; FILE-POSITION is the next character --
1683 ;; error is at the previous one.
1684 (and stream-position
(plusp stream-position
)
1685 (1- stream-position
))))
1686 (content (read-content stream-position position
)))
1687 `(,@(when content
`((:line
,(line content
))
1688 (:column
,(column content position
))))
1689 ,@(when position
`((:file-position
,position
)))))))
1691 (declaim (inline schwartzian-stable-sort-list
))
1692 (defun schwartzian-stable-sort-list (list comparator
&key key
)
1694 (stable-sort (copy-list list
) comparator
)
1695 (let* ((key (if (functionp key
)
1697 (symbol-function key
)))
1698 (wrapped (mapcar (lambda (x)
1699 (cons x
(funcall key x
)))
1701 (sorted (stable-sort wrapped comparator
:key
#'cdr
)))
1702 (map-into sorted
#'car sorted
))))
1704 ;;; Just like WITH-OUTPUT-TO-STRING but doesn't close the stream,
1705 ;;; producing more compact code.
1706 (defmacro with-simple-output-to-string
1707 ((var &optional string
)
1709 (multiple-value-bind (forms decls
)
1710 (parse-body body
:doc-string-allowed nil
)
1712 `(let ((,var
(sb!impl
::make-fill-pointer-output-stream
,string
)))
1715 `(let ((,var
(make-string-output-stream)))
1718 (truly-the (simple-array character
(*))
1719 (get-output-stream-string ,var
))))))