1 ;;;; miscellaneous kernel-level definitions
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
12 (in-package "SB!KERNEL")
14 ;;;; SIMPLE-FUN and accessors
16 (deftype simple-fun
()
17 '(satisfies simple-fun-p
))
19 (declaim (inline code-header-words
))
20 (defun code-header-words (code)
21 (logand (get-header-data code
) sb
!vm
:short-header-max-words
))
23 ;;; Extract halves of SIMPLE-FUN-INFO, which is a string if it holds
24 ;;; documentation, a SIMPLE-VECTOR if XREFS,
25 ;;; or (CONS STRING SIMPLE-VECTOR) for both, or NIL if neither.
26 (macrolet ((def (name info-part if-simple-vector if-string
)
27 `(defun ,name
(simple-fun)
28 (declare (simple-fun simple-fun
))
29 (let ((info (%simple-fun-info simple-fun
)))
31 (list (,info-part info
))
32 (simple-vector ,if-simple-vector
)
34 (t (bug "bogus INFO for ~S: ~S" simple-fun info
)))))))
35 (def %simple-fun-doc car nil info
)
36 (def %simple-fun-xrefs cdr info nil
))
38 (defun (setf %simple-fun-doc
) (doc simple-fun
)
39 (declare (type (or null string
) doc
)
40 (simple-fun simple-fun
))
41 (let ((info (%simple-fun-info simple-fun
)))
42 (setf (%simple-fun-info simple-fun
)
43 (cond ((typep info
'(or null string
))
45 ((simple-vector-p info
)
54 (bug "bogus INFO for ~S: ~S" simple-fun info
))))))
56 ;;; Extract the type from the function header FUNC.
57 (defun %simple-fun-type
(func)
58 (let ((internal-type (sb!vm
::%%simple-fun-type func
)))
59 ;; For backward-compatibility we expand SFUNCTION -> FUNCTION.
60 (if (and (listp internal-type
) (eq (car internal-type
) 'sfunction
))
61 (sb!ext
:typexpand-1 internal-type
)
64 (defun %code-entry-points
(code-obj) ; DO NOT USE IN NEW CODE
65 (%code-entry-point code-obj
0))
67 (defun %simple-fun-next
(simple-fun) ; DO NOT USE IN NEW CODE
68 (let ((code-obj (fun-code-header simple-fun
)))
69 (dotimes (i (code-n-entries code-obj
))
70 (when (eq simple-fun
(%code-entry-point code-obj i
))
71 (return (%code-entry-point code-obj
(1+ i
)))))))
73 ;;;; CLOSURE type and accessors
76 '(satisfies closurep
))
78 ;;; FIXME: this should probably exclude the closure name slot, if named
79 (defmacro do-closure-values
((value closure
) &body body
)
80 (with-unique-names (i nclosure
)
81 `(let ((,nclosure
,closure
))
82 (declare (closure ,nclosure
))
83 (dotimes (,i
(- (1+ (get-closure-length ,nclosure
)) sb
!vm
:closure-info-offset
))
84 (let ((,value
(%closure-index-ref
,nclosure
,i
)))
87 (defun %closure-values
(closure)
88 (declare (closure closure
))
90 (do-closure-values (elt closure
)
94 (defun %set-vector-raw-bits
(object offset value
)
95 (setf (%vector-raw-bits object offset
) value
))
97 ;;; A unique GC id. This is supplied for code that needs to detect
98 ;;; whether a GC has happened since some earlier point in time. For
101 ;;; (let ((epoch *gc-epoch*))
103 ;;; (unless (eql epoch *gc-epoch)
106 ;;; This isn't just a fixnum counter since then we'd have theoretical
107 ;;; problems when exactly 2^29 GCs happen between epoch
108 ;;; comparisons. Unlikely, but the cost of using a cons instead is too
109 ;;; small to measure. -- JES, 2007-09-30
110 (declaim (type cons
*gc-epoch
*))
111 (!defglobal
*gc-epoch
* '(nil . nil
))
113 (declaim (inline lowtag-of
))
114 (defun lowtag-of (x) (logand (get-lisp-obj-address x
) sb
!vm
:lowtag-mask
))
116 ;;; Unlike most other "Stub functions" that never called called except
117 ;;; by the interpreter, these two do get called, by MAKE-UNPORTABLE-FLOAT
118 (defun make-single-float (x) (make-single-float x
))
119 (defun make-double-float (hi lo
) (make-double-float hi lo
))