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 aux-vars
675 &key hash-function hash-bits memoizer
676 flush-function
(values 1))
677 (declare (ignore memoizer
))
679 (unless (<= 2 (length arg
) 3)
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 (nvalues (if (listp values
) (length values
) values
))
697 values
; use the names provided by the user
698 (loop for i from
1 to nvalues
; else invent some names
699 collect
(make-symbol (format nil
"R~D" i
)))))
700 (temps (append (mapcar (lambda (x) (make-symbol (string x
)))
703 ;; Mnemonic: (FIND x SEQ :test #'f) calls f with x as the LHS
704 (tests (mapcar (lambda (spec temp
) ; -> (EQx ARG #:ARG)
705 `(,(cadr spec
) ,(car spec
) ,temp
))
707 (cache-type `(simple-vector ,size
))
708 (line-type (let ((n (+ nargs nvalues
)))
709 (if (<= n
3) 'cons
`(simple-vector ,n
))))
711 `((,hashval
(the (signed-byte #.sb
!vm
:n-fixnum-bits
)
712 (funcall ,hash-function
,@arg-vars
)))
715 (lambda (ignore action
)
717 (let ((,hashval
,hashval
) ; gets clobbered in probe loop
718 (,cache
(truly-the ,cache-type
,cache
)))
720 (declare (type (signed-byte #.sb
!vm
:n-fixnum-bits
) ,hashval
))
724 (ldb (byte ,hash-bits
0) ,hashval
))))
725 (unless (eql ,entry
0)
726 ;; This barrier is a no-op on all multi-threaded SBCL
727 ;; architectures. No CPU except Alpha will move a
728 ;; load prior to a load on which it depends.
729 (sb!thread
:barrier
(:data-dependency
))
730 (locally (declare (type ,line-type
,entry
))
731 (let* ,(case (length temps
)
732 (2 `((,(first temps
) (car ,entry
))
733 (,(second temps
) (cdr ,entry
))))
734 (3 (let ((arg-temp (sb!xc
:gensym
"ARGS")))
735 `((,arg-temp
(cdr ,entry
))
736 (,(first temps
) (car ,entry
))
738 (car (truly-the cons
,arg-temp
)))
739 (,(third temps
) (cdr ,arg-temp
)))))
740 (t (loop for i from
0 for x in temps
741 collect
`(,x
(svref ,entry
,i
)))))
743 (when (and ,@tests
) ,action
))))
744 (setq ,hashval
(ash ,hashval
,(- hash-bits
)))))))))
746 `(defun ,fun-name
(,thunk
,@arg-vars
,@aux-vars
)
747 ,@(when *profile-hash-cache
* ; count seeks
748 `((when (boundp ',statistics-name
)
749 (incf (aref ,statistics-name
0)))))
751 ,(funcall probe-it nil
752 `(return-from ,fun-name
(values ,@result-temps
)))
753 (multiple-value-bind ,result-temps
(funcall ,thunk
)
755 (,(hash-cache-line-allocator (+ nargs nvalues
))
756 ,@(mapcar (lambda (spec) (or (caddr spec
) (car spec
)))
760 (truly-the ,cache-type
761 (or ,cache
(alloc-hash-cache ,size
',var-name
))))
762 (idx1 (ldb (byte ,hash-bits
0) ,hashval
))
763 (idx2 (ldb (byte ,hash-bits
,hash-bits
) ,hashval
)))
764 ,@(when *profile-hash-cache
*
765 `((incf (aref ,statistics-name
1)))) ; count misses
766 ;; Why a barrier: the pointer to 'entry' (a cons or vector)
767 ;; MUST NOT be observed by another thread before its cells
768 ;; are filled. Equally bad, the 'output' cells in the line
769 ;; could be 0 while the 'input' cells matched something.
770 (sb!thread
:barrier
(:write
))
771 (cond ((eql (svref ,cache idx1
) 0)
772 (setf (svref ,cache idx1
) ,entry
))
773 ((eql (svref ,cache idx2
) 0)
774 (setf (svref ,cache idx2
) ,entry
))
776 ,@(when *profile-hash-cache
* ; count evictions
777 `((incf (aref ,statistics-name
2))))
778 (setf (svref ,cache idx1
) ,entry
))))
779 (values ,@result-temps
))))))
781 (pushnew ',var-name
*cache-vector-symbols
*)
782 (defglobal ,var-name nil
)
783 ,@(when *profile-hash-cache
*
784 `((declaim (type (simple-array fixnum
(3)) ,statistics-name
))
785 (defvar ,statistics-name
)))
786 (declaim (type (or null
,cache-type
) ,var-name
))
787 (defun ,(symbolicate name
"-CACHE-CLEAR") () (setq ,var-name nil
))
788 ,@(when flush-function
789 `((defun ,flush-function
,arg-vars
792 `((declare (ignore ,@result-temps
)))
793 `(return (setf (svref ,cache
794 (ldb (byte ,hash-bits
0) ,hashval
))
796 (declaim (inline ,fun-name
))
799 ;;; some syntactic sugar for defining a function whose values are
800 ;;; cached by !DEFINE-HASH-CACHE
801 ;;; These keywords are mostly defined at !DEFINE-HASH-CACHE.
802 ;;; Additional options:
804 ;;; If provided, it is the name of a local macro that must be called
805 ;;; within the body forms to perform cache lookup/insertion.
806 ;;; If not provided, then the function's behavior is to automatically
807 ;;; attempt cache lookup, and on miss, execute the body code and
808 ;;; insert into the cache.
809 ;;; Manual control over memoization is useful if there are cases for
810 ;;; which it is undesirable to pollute the cache.
812 ;;; FIXME: this macro holds onto the DEFINE-HASH-CACHE macro,
815 ;;; Possible FIXME: if the function has a type proclamation, it forces
816 ;;; a type-check every time the cache finds something. Instead, values should
817 ;;; be checked once only when inserted into the cache, and not when read out.
819 ;;; N.B.: it is not obvious that the intended use of an explicit MEMOIZE macro
820 ;;; is to call it exactly once or not at all. If you call it more than once,
821 ;;; then you inline all of its logic every time. Probably the code generated
822 ;;; by DEFINE-HASH-CACHE should be an FLET inside the body of DEFUN-CACHED,
823 ;;; but the division of labor is somewhat inverted at present.
824 ;;; Since we don't have caches that aren't in direct support of DEFUN-CACHED
825 ;;; - did we ever? - this should be possible to change.
827 (defmacro defun-cached
((name &rest options
&key
828 (memoizer (make-symbol "MEMOIZE")
831 args
&body body-decls-doc
)
832 (binding* (((forms decls doc
) (parse-body body-decls-doc
))
834 (let ((aux (member '&aux args
)))
836 (values (ldiff args aux
) aux
)
838 (arg-names (mapcar #'car inputs
)))
840 (!define-hash-cache
,name
,inputs
,aux-vars
,@options
)
841 (defun ,name
,arg-names
843 ,@(if doc
(list doc
))
844 (macrolet ((,memoizer
(&body body
)
845 ;; We don't need (DX-FLET ((,thunk () ,@body)) ...)
846 ;; This lambda is a single-use local call within
847 ;; the inline memoizing wrapper.
848 `(,',(symbolicate name
"-MEMO-WRAPPER")
849 (lambda () ,@body
) ,@',arg-names
)))
850 ,@(if memoizer-supplied-p
852 `((,memoizer
,@forms
))))))))
854 ;;; FIXME: maybe not the best place
856 ;;; FIXME: think of a better name -- not only does this not have the
857 ;;; CAR recursion of EQUAL, it also doesn't have the special treatment
858 ;;; of pathnames, bit-vectors and strings.
860 ;;; KLUDGE: This means that we will no longer cache specifiers of the
861 ;;; form '(INTEGER (0) 4). This is probably not a disaster.
863 ;;; A helper function for the type system, which is the main user of
864 ;;; these caches: we must be more conservative than EQUAL for some of
865 ;;; our equality tests, because MEMBER and friends refer to EQLity.
867 (defun equal-but-no-car-recursion (x y
)
869 (cond ((eql x y
) (return t
))
872 (eql (pop x
) (pop y
))))
878 ;;; Note: Almost always you want to use FIND-UNDELETED-PACKAGE-OR-LOSE
879 ;;; instead of this function. (The distinction only actually matters when
880 ;;; PACKAGE-DESIGNATOR is actually a deleted package, and in that case
881 ;;; you generally do want to signal an error instead of proceeding.)
882 (defun %find-package-or-lose
(package-designator)
883 (or (find-package package-designator
)
884 (error 'simple-package-error
885 :package package-designator
886 :format-control
"The name ~S does not designate any package."
887 :format-arguments
(list package-designator
))))
889 ;;; ANSI specifies (in the section for FIND-PACKAGE) that the
890 ;;; consequences of most operations on deleted packages are
891 ;;; unspecified. We try to signal errors in such cases.
892 (defun find-undeleted-package-or-lose (package-designator)
893 (let ((maybe-result (%find-package-or-lose package-designator
)))
894 (if (package-name maybe-result
) ; if not deleted
896 (error 'simple-package-error
897 :package maybe-result
898 :format-control
"The package ~S has been deleted."
899 :format-arguments
(list maybe-result
)))))
901 ;;;; various operations on names
903 ;;; Is NAME a legal function name?
904 (declaim (inline legal-fun-name-p
))
905 (defun legal-fun-name-p (name)
906 (values (valid-function-name-p name
)))
908 (deftype function-name
() '(satisfies legal-fun-name-p
))
910 ;;; Signal an error unless NAME is a legal function name.
911 (defun legal-fun-name-or-type-error (name)
912 (unless (legal-fun-name-p name
)
913 (error 'simple-type-error
915 :expected-type
'function-name
916 :format-control
"invalid function name: ~S"
917 :format-arguments
(list name
))))
919 ;;; Given a function name, return the symbol embedded in it.
921 ;;; The ordinary use for this operator (and the motivation for the
922 ;;; name of this operator) is to convert from a function name to the
923 ;;; name of the BLOCK which encloses its body.
925 ;;; Occasionally the operator is useful elsewhere, where the operator
926 ;;; name is less mnemonic. (Maybe it should be changed?)
927 (declaim (ftype (function ((or symbol cons
)) symbol
) fun-name-block-name
))
928 (defun fun-name-block-name (fun-name)
929 (if (symbolp fun-name
)
931 (multiple-value-bind (legalp block-name
)
932 (valid-function-name-p fun-name
)
935 (error "not legal as a function name: ~S" fun-name
)))))
937 (defun looks-like-name-of-special-var-p (x)
940 (let ((name (symbol-name x
)))
941 (and (> (length name
) 2) ; to exclude '* and '**
942 (char= #\
* (aref name
0))
943 (char= #\
* (aref name
(1- (length name
))))))))
947 ;;;; "The macro ONCE-ONLY has been around for a long time on various
948 ;;;; systems [..] if you can understand how to write and when to use
949 ;;;; ONCE-ONLY, then you truly understand macro." -- Peter Norvig,
950 ;;;; _Paradigms of Artificial Intelligence Programming: Case Studies
951 ;;;; in Common Lisp_, p. 853
953 ;;; ONCE-ONLY is a utility useful in writing source transforms and
954 ;;; macros. It provides a concise way to wrap a LET around some code
955 ;;; to ensure that some forms are only evaluated once.
957 ;;; Create a LET* which evaluates each value expression, binding a
958 ;;; temporary variable to the result, and wrapping the LET* around the
959 ;;; result of the evaluation of BODY. Within the body, each VAR is
960 ;;; bound to the corresponding temporary variable.
961 (defmacro once-only
(specs &body body
)
962 (named-let frob
((specs specs
)
966 (let ((spec (first specs
)))
967 ;; FIXME: should just be DESTRUCTURING-BIND of SPEC
968 (unless (proper-list-of-length-p spec
2)
969 (error "malformed ONCE-ONLY binding spec: ~S" spec
))
970 (let* ((name (first spec
))
971 (exp-temp (gensym "ONCE-ONLY")))
972 `(let ((,exp-temp
,(second spec
))
973 (,name
(sb!xc
:gensym
,(symbol-name name
))))
974 `(let ((,,name
,,exp-temp
))
975 ,,(frob (rest specs
) body
))))))))
977 ;;;; various error-checking utilities
979 ;;; This function can be used as the default value for keyword
980 ;;; arguments that must be always be supplied. Since it is known by
981 ;;; the compiler to never return, it will avoid any compile-time type
982 ;;; warnings that would result from a default value inconsistent with
983 ;;; the declared type. When this function is called, it signals an
984 ;;; error indicating that a required &KEY argument was not supplied.
985 ;;; This function is also useful for DEFSTRUCT slot defaults
986 ;;; corresponding to required arguments.
987 (declaim (ftype (function () nil
) missing-arg
))
988 (defun missing-arg ()
990 (/show0
"entering MISSING-ARG")
991 (error "A required &KEY or &OPTIONAL argument was not supplied."))
993 ;;; like CL:ASSERT and CL:CHECK-TYPE, but lighter-weight
995 ;;; (As of sbcl-0.6.11.20, we were using some 400 calls to CL:ASSERT.
996 ;;; The CL:ASSERT restarts and whatnot expand into a significant
997 ;;; amount of code when you multiply them by 400, so replacing them
998 ;;; with this should reduce the size of the system by enough to be
1000 (defmacro aver
(expr)
1002 (%failed-aver
',expr
)))
1004 (defun %failed-aver
(expr)
1005 ;; hackish way to tell we're in a cold sbcl and output the
1006 ;; message before signalling error, as it may be this is too
1007 ;; early in the cold init.
1008 (when (find-package "SB!C")
1010 (write-line "failed AVER:")
1013 (bug "~@<failed AVER: ~2I~_~A~:>" expr
))
1015 (defun bug (format-control &rest format-arguments
)
1017 :format-control format-control
1018 :format-arguments format-arguments
))
1020 ;;; Return a function like FUN, but expecting its (two) arguments in
1021 ;;; the opposite order that FUN does.
1022 (declaim (inline swapped-args-fun
))
1023 (defun swapped-args-fun (fun)
1024 (declare (type function fun
))
1028 ;;; Return the numeric value of a type bound, i.e. an interval bound
1029 ;;; more or less in the format of bounds in ANSI's type specifiers,
1030 ;;; where a bare numeric value is a closed bound and a list of a
1031 ;;; single numeric value is an open bound.
1033 ;;; The "more or less" bit is that the no-bound-at-all case is
1034 ;;; represented by NIL (not by * as in ANSI type specifiers); and in
1035 ;;; this case we return NIL.
1036 (defun type-bound-number (x)
1038 (destructuring-bind (result) x result
)
1041 ;;; some commonly-occuring CONSTANTLY forms
1042 (macrolet ((def-constantly-fun (name constant-expr
)
1043 `(setf (symbol-function ',name
)
1044 (constantly ,constant-expr
))))
1045 (def-constantly-fun constantly-t t
)
1046 (def-constantly-fun constantly-nil nil
)
1047 (def-constantly-fun constantly-0
0))
1049 ;;; If X is a symbol, see whether it is present in *FEATURES*. Also
1050 ;;; handle arbitrary combinations of atoms using NOT, AND, OR.
1058 (error "too many subexpressions in feature expression: ~S" x
))
1060 (error "too few subexpressions in feature expression: ~S" x
))
1061 (t (not (featurep (cadr x
))))))
1062 ((:and and
) (every #'featurep
(cdr x
)))
1063 ((:or or
) (some #'featurep
(cdr x
)))
1065 (error "unknown operator in feature expression: ~S." x
))))
1066 (symbol (not (null (memq x
*features
*))))
1068 (error "invalid feature expression: ~S" x
))))
1071 ;;;; utilities for two-VALUES predicates
1073 (defmacro not
/type
(x)
1074 (let ((val (gensym "VAL"))
1075 (win (gensym "WIN")))
1076 `(multiple-value-bind (,val
,win
)
1079 (values (not ,val
) t
)
1080 (values nil nil
)))))
1082 (defmacro and
/type
(x y
)
1083 `(multiple-value-bind (val1 win1
) ,x
1084 (if (and (not val1
) win1
)
1086 (multiple-value-bind (val2 win2
) ,y
1089 (values nil
(and win2
(not val2
))))))))
1091 ;;; sort of like ANY and EVERY, except:
1092 ;;; * We handle two-VALUES predicate functions, as SUBTYPEP does.
1093 ;;; (And if the result is uncertain, then we return (VALUES NIL NIL),
1094 ;;; as SUBTYPEP does.)
1095 ;;; * THING is just an atom, and we apply OP (an arity-2 function)
1096 ;;; successively to THING and each element of LIST.
1097 (defun any/type
(op thing list
)
1098 (declare (type function op
))
1100 (dolist (i list
(values nil certain?
))
1101 (multiple-value-bind (sub-value sub-certain?
) (funcall op thing i
)
1103 (when sub-value
(return (values t t
)))
1104 (setf certain? nil
))))))
1105 (defun every/type
(op thing list
)
1106 (declare (type function op
))
1108 (dolist (i list
(if certain?
(values t t
) (values nil nil
)))
1109 (multiple-value-bind (sub-value sub-certain?
) (funcall op thing i
)
1111 (unless sub-value
(return (values nil t
)))
1112 (setf certain? nil
))))))
1116 ;;; These functions are called by the expansion of the DEFPRINTER
1117 ;;; macro to do the actual printing.
1118 (declaim (ftype (function (symbol t stream
) (values))
1119 defprinter-prin1 defprinter-princ
))
1120 (defun defprinter-prin1 (name value stream
)
1121 (defprinter-prinx #'prin1 name value stream
))
1122 (defun defprinter-princ (name value stream
)
1123 (defprinter-prinx #'princ name value stream
))
1124 (defun defprinter-prinx (prinx name value stream
)
1125 (declare (type function prinx
))
1126 (when *print-pretty
*
1127 (pprint-newline :linear stream
))
1128 (format stream
":~A " name
)
1129 (funcall prinx value stream
)
1131 (defun defprinter-print-space (stream)
1132 (write-char #\space stream
))
1134 ;;; Define some kind of reasonable PRINT-OBJECT method for a
1135 ;;; STRUCTURE-OBJECT class.
1137 ;;; NAME is the name of the structure class, and CONC-NAME is the same
1138 ;;; as in DEFSTRUCT.
1140 ;;; The SLOT-DESCS describe how each slot should be printed. Each
1141 ;;; SLOT-DESC can be a slot name, indicating that the slot should
1142 ;;; simply be printed. A SLOT-DESC may also be a list of a slot name
1143 ;;; and other stuff. The other stuff is composed of keywords followed
1144 ;;; by expressions. The expressions are evaluated with the variable
1145 ;;; which is the slot name bound to the value of the slot. These
1146 ;;; keywords are defined:
1148 ;;; :PRIN1 Print the value of the expression instead of the slot value.
1149 ;;; :PRINC Like :PRIN1, only PRINC the value
1150 ;;; :TEST Only print something if the test is true.
1152 ;;; If no printing thing is specified then the slot value is printed
1155 ;;; The structure being printed is bound to STRUCTURE and the stream
1156 ;;; is bound to STREAM.
1157 (defmacro defprinter
((name
1159 (conc-name (concatenate 'simple-string
1166 (reversed-prints nil
)
1167 (stream (sb!xc
:gensym
"STREAM")))
1168 (flet ((sref (slot-name)
1169 `(,(symbolicate conc-name slot-name
) structure
)))
1170 (dolist (slot-desc slot-descs
)
1172 (setf maybe-print-space nil
1174 (setf maybe-print-space
`(defprinter-print-space ,stream
)))
1175 (cond ((atom slot-desc
)
1176 (push maybe-print-space reversed-prints
)
1177 (push `(defprinter-prin1 ',slot-desc
,(sref slot-desc
) ,stream
)
1180 (let ((sname (first slot-desc
))
1183 (do ((option (rest slot-desc
) (cddr option
)))
1185 (push `(let ((,sname
,(sref sname
)))
1190 ',sname
,sname
,stream
)))))
1192 (case (first option
)
1194 (stuff `(defprinter-prin1
1195 ',sname
,(second option
) ,stream
)))
1197 (stuff `(defprinter-princ
1198 ',sname
,(second option
) ,stream
)))
1199 (:test
(setq test
(second option
)))
1201 (error "bad option: ~S" (first option
)))))))))))
1202 `(sb!xc
:defmethod
print-object ((structure ,name
) ,stream
)
1203 (pprint-logical-block (,stream nil
)
1204 (print-unreadable-object (structure
1207 :identity
,identity
)
1208 ,@(nreverse reversed-prints
))))))
1210 (defun print-symbol-with-prefix (stream symbol
&optional colon at
)
1212 "For use with ~/: Write SYMBOL to STREAM as if it is not accessible from
1213 the current package."
1214 (declare (ignore colon at
))
1215 ;; Only keywords should be accessible from the keyword package, and
1216 ;; keywords are always printed with colons, so this guarantees that the
1217 ;; symbol will not be printed without a prefix.
1218 (let ((*package
* *keyword-package
*))
1219 (write symbol
:stream stream
:escape t
)))
1223 ;;; Given a pathname, return a corresponding physical pathname.
1224 (defun physicalize-pathname (possibly-logical-pathname)
1225 (if (typep possibly-logical-pathname
'logical-pathname
)
1226 (translate-logical-pathname possibly-logical-pathname
)
1227 possibly-logical-pathname
))
1229 ;;;; Deprecating stuff
1231 (deftype deprecation-state
()
1232 '(member :early
:late
:final
))
1234 (deftype deprecation-software-and-version
()
1235 '(or string
(cons string
(cons string null
))))
1237 (defun normalize-deprecation-since (since)
1238 (unless (typep since
'deprecation-software-and-version
)
1239 (error 'simple-type-error
1241 :expected-type
'deprecation-software-and-version
1242 :format-control
"~@<The value ~S does not designate a ~
1243 version or a software name and a version.~@:>"
1244 :format-arguments
(list since
)))
1245 (if (typep since
'string
)
1247 (values-list since
)))
1249 (defun normalize-deprecation-replacements (replacements)
1250 (if (or (not (listp replacements
))
1251 (eq 'setf
(car replacements
)))
1255 (defstruct (deprecation-info
1256 (:constructor make-deprecation-info
1257 (state software version
&optional replacement-spec
1259 (replacements (normalize-deprecation-replacements
1260 replacement-spec
))))
1262 (state (missing-arg) :type deprecation-state
:read-only t
)
1263 (software (missing-arg) :type
(or null string
) :read-only t
)
1264 (version (missing-arg) :type string
:read-only t
)
1265 (replacements '() :type list
:read-only t
))
1267 ;; Return the state of deprecation of the thing identified by
1268 ;; NAMESPACE and NAME, or NIL.
1269 (defun deprecated-thing-p (namespace name
)
1270 (multiple-value-bind (info infop
)
1272 (variable (info :variable
:deprecated name
))
1273 (function (info :function
:deprecated name
))
1274 (type (info :type
:deprecated name
)))
1276 (values (deprecation-info-state info
)
1277 (list (deprecation-info-software info
)
1278 (deprecation-info-version info
))
1279 (deprecation-info-replacements info
)))))
1281 (defun deprecation-error (software version namespace name replacements
)
1282 (error 'deprecation-error
1283 :namespace namespace
1287 :replacements
(normalize-deprecation-replacements replacements
)))
1289 (defun deprecation-warn (state software version namespace name replacements
1290 &key
(runtime-error (neq :early state
)))
1292 (:early
'early-deprecation-warning
)
1293 (:late
'late-deprecation-warning
)
1294 (:final
'final-deprecation-warning
))
1295 :namespace namespace
1299 :replacements
(normalize-deprecation-replacements replacements
)
1300 :runtime-error runtime-error
))
1302 (defun check-deprecated-thing (namespace name
)
1303 (multiple-value-bind (state since replacements
)
1304 (deprecated-thing-p namespace name
)
1307 state
(first since
) (second since
) namespace name replacements
)
1308 (values state since replacements
))))
1310 ;;; For-effect-only variant of CHECK-DEPRECATED-THING for
1311 ;;; type-specifiers that descends into compound type-specifiers.
1312 (defun %check-deprecated-type
(type-specifier)
1314 ;; KLUDGE: we have to use SPECIFIER-TYPE to sanely traverse
1315 ;; TYPE-SPECIFIER and detect references to deprecated types. But
1316 ;; then we may have to drop its cache to get the
1317 ;; PARSE-DEPRECATED-TYPE condition when TYPE-SPECIFIER is parsed
1320 ;; Proper fix would be a
1322 ;; walk-type function type-specifier
1324 ;; mechanism that could drive VALUES-SPECIFIER-TYPE but also
1325 ;; things like this function.
1328 ((sb!kernel
::parse-deprecated-type
1330 (let ((type-specifier (sb!kernel
::parse-deprecated-type-specifier
1332 (aver (symbolp type-specifier
))
1333 (unless (memq type-specifier seen
)
1334 (push type-specifier seen
)
1335 (check-deprecated-thing 'type type-specifier
)))))
1336 ((or error sb
!kernel
:parse-unknown-type
)
1338 (declare (ignore condition
))
1340 (specifier-type type-specifier
)))))
1342 (defun check-deprecated-type (type-specifier)
1343 (typecase type-specifier
1344 ((and type-specifier
(not instance
))
1345 (%check-deprecated-type type-specifier
))
1347 ;; FIXME: this case does not acknowledge that improperly named classes
1348 ;; can exist. Suppose a few classes each have CLASS-NAME = FRED
1349 ;; but (FIND-CLASS 'FRED) does not return any of them; and simultaneously
1350 ;; FRED is a completely unrelated type specifier defined via DEFTYPE.
1351 ;; This should see that class-name does not properly name the class.
1352 (let ((name (class-name type-specifier
)))
1353 (when (and name
(symbolp name
))
1354 (%check-deprecated-type name
))))))
1356 ;; This is the moral equivalent of a warning from /usr/bin/ld that
1357 ;; "gets() is dangerous." You're informed by both the compiler and linker.
1358 (defun loader-deprecation-warn (stuff whence
)
1359 ;; Stuff is a list: ((<state> name . category) ...)
1360 ;; For now we only deal with category = :FUNCTION so we ignore it.
1361 (let ((warning-class
1362 ;; We're only going to warn once (per toplevel form),
1363 ;; so pick the most stern warning applicable.
1364 (if (every (lambda (x) (eq (car x
) :early
)) stuff
)
1365 'simple-style-warning
'simple-warning
)))
1367 :format-control
"Reference to deprecated function~P ~S~@[ from ~S~]"
1369 (list (length stuff
) (mapcar #'second stuff
) whence
))))
1373 ;;; :EARLY, for a compile-time style-warning.
1374 ;;; :LATE, for a compile-time full warning.
1375 ;;; :FINAL, for a compile-time full warning and runtime error.
1377 ;;; Suggested duration of each stage is one year, but some things can move faster,
1378 ;;; and some widely used legacy APIs might need to move slower. Internals we don't
1379 ;;; usually add deprecation notes for, but sometimes an internal API actually has
1380 ;;; several external users, in which case we try to be nice about it.
1382 ;;; When you deprecate something, note it here till it is fully gone: makes it
1383 ;;; easier to keep things progressing orderly. Also add the relevant section
1384 ;;; (or update it when deprecation proceeds) in the manual, in
1385 ;;; deprecated.texinfo.
1388 ;;; - SOCKINT::WIN32-BIND since 1.2.10 (03/2015) -> Late: 08/2015
1389 ;;; - SOCKINT::WIN32-GETSOCKNAME since 1.2.10 (03/2015) -> Late: 08/2015
1390 ;;; - SOCKINT::WIN32-LISTEN since 1.2.10 (03/2015) -> Late: 08/2015
1391 ;;; - SOCKINT::WIN32-RECV since 1.2.10 (03/2015) -> Late: 08/2015
1392 ;;; - SOCKINT::WIN32-RECVFROM since 1.2.10 (03/2015) -> Late: 08/2015
1393 ;;; - SOCKINT::WIN32-SEND since 1.2.10 (03/2015) -> Late: 08/2015
1394 ;;; - SOCKINT::WIN32-SENDTO since 1.2.10 (03/2015) -> Late: 08/2015
1395 ;;; - SOCKINT::WIN32-CLOSE since 1.2.10 (03/2015) -> Late: 08/2015
1396 ;;; - SOCKINT::WIN32-CONNECT since 1.2.10 (03/2015) -> Late: 08/2015
1397 ;;; - SOCKINT::WIN32-GETPEERNAME since 1.2.10 (03/2015) -> Late: 08/2015
1398 ;;; - SOCKINT::WIN32-IOCTL since 1.2.10 (03/2015) -> Late: 08/2015
1399 ;;; - SOCKINT::WIN32-SETSOCKOPT since 1.2.10 (03/2015) -> Late: 08/2015
1400 ;;; - SOCKINT::WIN32-GETSOCKOPT since 1.2.10 (03/2015) -> Late: 08/2015
1402 ;;; - SB-C::MERGE-TAIL-CALLS (policy) since 1.0.53.74 (11/2011) -> Late: 11/2012
1405 ;;; - SB-C::STACK-ALLOCATE-DYNAMIC-EXTENT (policy) since 1.0.19.7 -> Final: anytime
1406 ;;; - SB-C::STACK-ALLOCATE-VECTOR (policy) since 1.0.19.7 -> Final: anytime
1407 ;;; - SB-C::STACK-ALLOCATE-VALUE-CELLS (policy) since 1.0.19.7 -> Final: anytime
1409 (defun print-deprecation-replacements (stream replacements
&optional colonp atp
)
1410 (declare (ignore colonp atp
))
1411 (apply #'format stream
1412 (!uncross-format-control
1414 Use ~/sb!impl:print-symbol-with-prefix/ instead.~;~
1415 Use ~/sb!impl:print-symbol-with-prefix/ or ~
1416 ~/sb!impl:print-symbol-with-prefix/ instead.~:;~
1418 ~/sb!impl:print-symbol-with-prefix/~^,~} instead.~
1422 (defun print-deprecation-message (namespace name software version
1423 &optional replacements stream
)
1425 (!uncross-format-control
1426 "The ~(~A~) ~/sb!impl:print-symbol-with-prefix/ has been ~
1427 deprecated as of ~@[~A ~]version ~A.~
1428 ~@[~2%~/sb!impl::print-deprecation-replacements/~]")
1429 namespace name software version replacements
))
1431 (defun setup-function-in-final-deprecation
1432 (software version name replacement-spec
)
1433 #+sb-xc-host
(declare (ignore software version name replacement-spec
))
1435 (setf (fdefinition name
)
1436 (sb!impl
::set-closure-name
1437 (lambda (&rest args
)
1438 (declare (ignore args
))
1439 (deprecation-error software version
'function name replacement-spec
))
1442 (defun setup-variable-in-final-deprecation
1443 (software version name replacement-spec
)
1444 (sb!c
::%define-symbol-macro
1447 ,software
,version
'variable
',name
1449 (lambda (replacement)
1451 (normalize-deprecation-replacements replacement-spec
))))
1454 (defun setup-type-in-final-deprecation
1455 (software version name replacement-spec
)
1456 (declare (ignore software version replacement-spec
))
1457 (%compiler-deftype name
(constant-type-expander t
) nil
))
1459 (defmacro define-deprecated-function
(state version name replacements lambda-list
1461 (declare (type deprecation-state state
)
1462 (type string version
)
1463 (type function-name name
)
1464 (type (or function-name list
) replacements
)
1465 (type list lambda-list
)
1466 #+sb-xc-host
(ignore version replacements
))
1469 (declaim (deprecated
1470 ,state
("SBCL" ,version
)
1471 (function ,name
,@(when replacements
1472 `(:replacement
,replacements
)))))
1475 `(defun ,name
,lambda-list
1480 (defmacro define-deprecated-variable
(state version name
1481 &key
(value nil valuep
) replacement
)
1482 (declare (type deprecation-state state
)
1483 (type string version
)
1485 #+sb-xc-host
(ignore version replacement
))
1488 (declaim (deprecated
1489 ,state
("SBCL" ,version
)
1490 (variable ,name
,@(when replacement
1491 `(:replacement
,replacement
)))))
1494 `(defvar ,name
,@(when valuep
(list value
))))
1498 ;; Given DECLS as returned by from parse-body, and SYMBOLS to be bound
1499 ;; (with LET, MULTIPLE-VALUE-BIND, etc) return two sets of declarations:
1500 ;; those which pertain to the variables and those which don't.
1501 ;; The first returned value is NIL or a single expression headed by DECLARE.
1502 ;; The second is a list of expressions resembling the input DECLS.
1503 (defun extract-var-decls (decls symbols
)
1504 (unless symbols
; Don't bother filtering DECLS, just return them.
1505 (return-from extract-var-decls
(values nil decls
)))
1506 (labels ((applies-to-variables (decl)
1507 ;; If DECL is a variable-affecting declaration, then return
1508 ;; the subset of SYMBOLS to which DECL applies.
1509 (let ((id (car decl
)))
1510 (remove-if (lambda (x) (not (memq x symbols
)))
1511 (cond ((eq id
'type
)
1513 ((or (listp id
) ; must be a type-specifier
1514 (memq id
'(special ignorable ignore
1516 truly-dynamic-extent
))
1517 (info :type
:kind id
))
1520 ;; If SPEC is a declaration affecting some variables in SYMBOLS
1521 ;; and some not, split it into two mutually exclusive declarations.
1522 (acond ((applies-to-variables spec
)
1523 (multiple-value-bind (decl-head all-symbols
)
1524 (if (eq (car spec
) 'type
)
1525 (values `(type ,(cadr spec
)) (cddr spec
))
1526 (values `(,(car spec
)) (cdr spec
)))
1527 (let ((more (set-difference all-symbols it
)))
1528 (values `(,@decl-head
,@it
)
1529 (and more
`(,@decl-head
,@more
))))))
1531 (values nil spec
)))))
1532 ;; This loop is less inefficient than theoretically possible,
1533 ;; reconstructing the tree even if no need,
1534 ;; but it's just a macroexpander, so... fine.
1535 (collect ((binding-decls))
1537 (mapcar (lambda (decl-expr) ; a list headed by DECLARE
1538 (mapcan (lambda (spec)
1539 (multiple-value-bind (binding other
)
1542 (binding-decls binding
))
1543 (if other
(list other
))))
1546 (values (awhen (binding-decls) `(declare ,@it
))
1547 (mapcan (lambda (x) (if x
(list `(declare ,@x
)))) filtered
))))))
1549 ;;; Delayed evaluation
1550 (defmacro delay
(form)
1551 `(cons nil
(lambda () ,form
)))
1553 (defun force (promise)
1554 (cond ((not (consp promise
)) promise
)
1555 ((car promise
) (cdr promise
))
1556 (t (setf (car promise
) t
1557 (cdr promise
) (funcall (cdr promise
))))))
1559 (defun promise-ready-p (promise)
1560 (or (not (consp promise
))
1564 (defmacro with-rebound-io-syntax
(&body body
)
1565 `(%with-rebound-io-syntax
(lambda () ,@body
)))
1567 (defun %with-rebound-io-syntax
(function)
1568 (declare (type function function
))
1569 (let ((*package
* *package
*)
1570 (*print-array
* *print-array
*)
1571 (*print-base
* *print-base
*)
1572 (*print-case
* *print-case
*)
1573 (*print-circle
* *print-circle
*)
1574 (*print-escape
* *print-escape
*)
1575 (*print-gensym
* *print-gensym
*)
1576 (*print-length
* *print-length
*)
1577 (*print-level
* *print-level
*)
1578 (*print-lines
* *print-lines
*)
1579 (*print-miser-width
* *print-miser-width
*)
1580 (*print-pretty
* *print-pretty
*)
1581 (*print-radix
* *print-radix
*)
1582 (*print-readably
* *print-readably
*)
1583 (*print-right-margin
* *print-right-margin
*)
1584 (*read-base
* *read-base
*)
1585 (*read-default-float-format
* *read-default-float-format
*)
1586 (*read-eval
* *read-eval
*)
1587 (*read-suppress
* *read-suppress
*)
1588 (*readtable
* *readtable
*))
1589 (funcall function
)))
1591 ;;; Bind a few "potentially dangerous" printer control variables to
1592 ;;; safe values, respecting current values if possible.
1593 (defmacro with-sane-io-syntax
(&body forms
)
1594 `(call-with-sane-io-syntax (lambda () ,@forms
)))
1596 (defun call-with-sane-io-syntax (function)
1597 (declare (type function function
))
1598 (macrolet ((true (sym)
1599 `(and (boundp ',sym
) ,sym
)))
1600 (let ((*print-readably
* nil
)
1601 (*print-level
* (or (true *print-level
*) 6))
1602 (*print-length
* (or (true *print-length
*) 12)))
1603 (funcall function
))))
1605 ;;; Returns a list of members of LIST. Useful for dealing with circular lists.
1606 ;;; For a dotted list returns a secondary value of T -- in which case the
1607 ;;; primary return value does not include the dotted tail.
1608 ;;; If the maximum length is reached, return a secondary value of :MAYBE.
1609 (defun list-members (list &key max-length
)
1611 (do ((tail (cdr list
) (cdr tail
))
1612 (members (list (car list
)) (cons (car tail
) members
))
1613 (count 0 (1+ count
)))
1614 ((or (not (consp tail
)) (eq tail list
)
1615 (and max-length
(>= count max-length
)))
1616 (values members
(or (not (listp tail
))
1617 (and (>= count max-length
) :maybe
)))))))
1619 ;;; Default evaluator mode (interpeter / compiler)
1621 (declaim (type (member :compile
#!+sb-eval
:interpret
) *evaluator-mode
*))
1622 (!defparameter
*evaluator-mode
* :compile
1624 "Toggle between different evaluator implementations. If set to :COMPILE,
1625 an implementation of EVAL that calls the compiler will be used. If set
1626 to :INTERPRET, an interpreter will be used.")
1628 ;;; Helper for making the DX closure allocation in macros expanding
1629 ;;; to CALL-WITH-FOO less ugly.
1630 (def!macro dx-flet
(functions &body forms
)
1632 (declare (truly-dynamic-extent ,@(mapcar (lambda (func) `#',(car func
))
1636 ;;; Another similar one.
1637 (def!macro dx-let
(bindings &body forms
)
1639 (declare (truly-dynamic-extent
1640 ,@(mapcar (lambda (bind) (if (listp bind
) (car bind
) bind
))
1644 ;; This is not my preferred name for this function, but chosen for harmony
1645 ;; with everything else that refers to these as 'hash-caches'.
1646 ;; Hashing is just one particular way of memoizing, and it would have been
1647 ;; slightly more abstract and yet at the same time more concrete to say
1648 ;; "memoized-function-caches". "hash-caches" is pretty nonspecific.
1649 #.
(if *profile-hash-cache
*
1650 '(defun show-hash-cache-statistics ()
1651 (flet ((cache-stats (symbol)
1652 (let* ((name (string symbol
))
1653 (statistics (let ((*package
* (symbol-package symbol
)))
1654 (symbolicate symbol
"STATISTICS")))
1656 (subseq name
0 (- (length name
) (length "VECTOR**")))))
1657 (values (if (boundp statistics
)
1658 (symbol-value statistics
)
1659 (make-array 3 :element-type
'fixnum
))
1660 (subseq prefix
2 (1- (length prefix
)))))))
1661 (format t
"~%Type function memoization:~% Seek Hit (%)~:
1662 Evict (%) Size full~%")
1663 ;; Sort by descending seek count to rank by likely relative importance
1664 (dolist (symbol (sort (copy-list *cache-vector-symbols
*) #'>
1665 :key
(lambda (x) (aref (cache-stats x
) 0))))
1666 (binding* (((stats short-name
) (cache-stats symbol
))
1667 (seek (aref stats
0))
1668 (miss (aref stats
1))
1670 (evict (aref stats
2))
1671 (cache (symbol-value symbol
)))
1672 (format t
"~9d ~9d (~5,1f%) ~8d (~5,1f%) ~4d ~6,1f% ~A~%"
1674 (if (plusp seek
) (* 100 (/ hit seek
)))
1676 (if (plusp seek
) (* 100 (/ evict seek
)))
1678 (if (plusp (length cache
))
1679 (* 100 (/ (count-if-not #'fixnump cache
)
1683 (in-package "SB!KERNEL")
1685 (defun fp-zero-p (x)
1687 (single-float (zerop x
))
1688 (double-float (zerop x
))
1690 (long-float (zerop x
))
1693 (defun neg-fp-zero (x)
1697 (make-unportable-float :single-float-negative-zero
)
1701 (make-unportable-float :double-float-negative-zero
)
1706 (make-unportable-float :long-float-negative-zero
)
1709 (declaim (inline schwartzian-stable-sort-list
))
1710 (defun schwartzian-stable-sort-list (list comparator
&key key
)
1712 (stable-sort (copy-list list
) comparator
)
1713 (let* ((key (if (functionp key
)
1715 (symbol-function key
)))
1716 (wrapped (mapcar (lambda (x)
1717 (cons x
(funcall key x
)))
1719 (sorted (stable-sort wrapped comparator
:key
#'cdr
)))
1720 (map-into sorted
#'car sorted
))))
1722 ;;; Just like WITH-OUTPUT-TO-STRING but doesn't close the stream,
1723 ;;; producing more compact code.
1724 (defmacro with-simple-output-to-string
1725 ((var &optional string
)
1727 (multiple-value-bind (forms decls
)
1728 (parse-body body
:doc-string-allowed nil
)
1730 `(let ((,var
(sb!impl
::make-fill-pointer-output-stream
,string
)))
1733 `(let ((,var
(make-string-output-stream)))
1736 (truly-the (simple-array character
(*))
1737 (get-output-stream-string ,var
))))))