Avoid some exceptions in WAIT-UNTIL-FD-USABLE on Windows
[sbcl.git] / src / code / kernel.lisp
1 ;;;; miscellaneous kernel-level definitions
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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.
11
12 (in-package "SB!KERNEL")
13
14 ;;; Return the 24 bits of data in the header of object X, which must
15 ;;; be an other-pointer object.
16 (defun get-header-data (x)
17   (get-header-data x))
18
19 ;;; Set the 24 bits of data in the header of object X (which must be
20 ;;; an other-pointer object) to VAL.
21 (defun set-header-data (x val)
22   (set-header-data x val))
23
24 ;;; Return the 24 bits of data in the header of object X, which must
25 ;;; be a fun-pointer object.
26 ;;;
27 ;;; FIXME: Should this not be called GET-FUN-LENGTH instead? Or even better
28 ;;; yet, if GET-HEADER-DATA masked the lowtag instead of substracting it, we
29 ;;; could just use it instead -- or at least this could just be a function on
30 ;;; top of the same VOP.
31 (defun get-closure-length (x)
32   (get-closure-length x))
33
34 (defun lowtag-of (x)
35   (lowtag-of x))
36
37 (defun widetag-of (x)
38   (widetag-of x))
39
40 ;;; WIDETAG-OF needs extra code to handle LIST and FUNCTION lowtags. When
41 ;;; we're only dealing with other pointers (eg. when dispatching on array
42 ;;; element type), this is going to be faster.
43 (declaim (inline %other-pointer-widetag))
44 (defun %other-pointer-widetag (x)
45   (sb!sys:sap-ref-8 (int-sap (get-lisp-obj-address x))
46                     #.(ecase sb!c:*backend-byte-order*
47                         (:little-endian
48                          (- sb!vm:other-pointer-lowtag))
49                         (:big-endian
50                          (- (1- sb!vm:n-word-bytes) sb!vm:other-pointer-lowtag)))))
51
52 ;;; Return a System-Area-Pointer pointing to the data for the vector
53 ;;; X, which must be simple.
54 ;;;
55 ;;; FIXME: So it should be SIMPLE-VECTOR-SAP, right? (or UNHAIRY-VECTOR-SAP,
56 ;;; if the meaning is (SIMPLE-ARRAY * 1) instead of SIMPLE-VECTOR)
57 ;;; (or maybe SIMPLE-VECTOR-DATA-SAP or UNHAIRY-VECTOR-DATA-SAP?)
58 (defun vector-sap (x)
59   (declare (type (simple-unboxed-array (*)) x))
60   (vector-sap x))
61
62 ;;; Return a System-Area-Pointer pointing to the end of the binding stack.
63 (defun sb!c::binding-stack-pointer-sap ()
64   (sb!c::binding-stack-pointer-sap))
65
66 ;;; Return a System-Area-Pointer pointing to the next free word of the
67 ;;; current dynamic space.
68 (defun sb!c::dynamic-space-free-pointer ()
69   (sb!c::dynamic-space-free-pointer))
70
71 ;;; Return a System-Area-Pointer pointing to the end of the control stack.
72 (defun sb!c::control-stack-pointer-sap ()
73   (sb!c::control-stack-pointer-sap))
74
75 ;;; Return the header typecode for FUNCTION. Can be set with SETF.
76 (defun fun-subtype (function)
77   (fun-subtype function))
78 (defun (setf fun-subtype) (type function)
79   (setf (fun-subtype function) type))
80
81 ;;;; SIMPLE-FUN and accessors
82
83 (declaim (inline simple-fun-p))
84 (defun simple-fun-p (object)
85   (= sb!vm:simple-fun-header-widetag (widetag-of object)))
86
87 (deftype simple-fun ()
88   '(satisfies simple-fun-p))
89
90 (defun %simple-fun-doc (simple-fun)
91   (declare (simple-fun simple-fun))
92   (let ((info (%simple-fun-info simple-fun)))
93     (cond ((typep info '(or null string))
94            info)
95           ((simple-vector-p info)
96            nil)
97           ((consp info)
98            (car info))
99           (t
100            (bug "bogus INFO for ~S: ~S" simple-fun info)))))
101
102 (defun (setf %simple-fun-doc) (doc simple-fun)
103   (declare (type (or null string) doc)
104            (simple-fun simple-fun))
105   (let ((info (%simple-fun-info simple-fun)))
106     (setf (%simple-fun-info simple-fun)
107           (cond ((typep info '(or null string))
108                  doc)
109                 ((simple-vector-p info)
110                  (if doc
111                      (cons doc info)
112                      info))
113                 ((consp info)
114                  (if doc
115                      (cons doc (cdr info))
116                      (cdr info)))
117                 (t
118                  (bug "bogus INFO for ~S: ~S" simple-fun info))))))
119
120 (defun %simple-fun-xrefs (simple-fun)
121   (declare (simple-fun simple-fun))
122   (let ((info (%simple-fun-info simple-fun)))
123     (cond ((typep info '(or null string))
124            nil)
125           ((simple-vector-p info)
126            info)
127           ((consp info)
128            (cdr info))
129           (t
130            (bug "bogus INFO for ~S: ~S" simple-fun info)))))
131
132 ;;; Extract the arglist from the function header FUNC.
133 (defun %simple-fun-arglist (func)
134   (%simple-fun-arglist func))
135
136 (defun (setf %simple-fun-arglist) (new-value func)
137   (setf (%simple-fun-arglist func) new-value))
138
139 ;;; Extract the name from the function header FUNC.
140 (defun %simple-fun-name (func)
141   (%simple-fun-name func))
142
143 (defun (setf %simple-fun-name) (new-value func)
144   (setf (%simple-fun-name func) new-value))
145
146 ;;; Extract the type from the function header FUNC.
147 (defun %simple-fun-type (func)
148   (%simple-fun-type func))
149
150 (defun %simple-fun-next (simple-fun)
151   (%simple-fun-next simple-fun))
152
153 (defun %simple-fun-self (simple-fun)
154   (%simple-fun-self simple-fun))
155
156 ;;;; CLOSURE type and accessors
157
158 (declaim (inline closurep))
159 (defun closurep (object)
160   (= sb!vm:closure-header-widetag (widetag-of object)))
161
162 (deftype closure ()
163   '(satisfies closurep))
164
165 (defmacro do-closure-values ((value closure) &body body)
166   (with-unique-names (i nclosure)
167     `(let ((,nclosure ,closure))
168        (declare (closure ,nclosure))
169        (dotimes (,i (- (1+ (get-closure-length ,nclosure)) sb!vm:closure-info-offset))
170          (let ((,value (%closure-index-ref ,nclosure ,i)))
171            ,@body)))))
172
173 (defun %closure-values (closure)
174   (declare (closure closure))
175   (let (values)
176     (do-closure-values (elt closure)
177       (push elt values))
178     (nreverse values)))
179
180 ;;; Extract the function from CLOSURE.
181 (defun %closure-fun (closure)
182   (%closure-fun closure))
183
184 ;;; Extract the INDEXth slot from CLOSURE.
185 (defun %closure-index-ref (closure index)
186   (%closure-index-ref closure index))
187
188 ;;; Return the length of VECTOR. There is no reason to use this in
189 ;;; ordinary code, 'cause length (the vector foo)) is the same.
190 (defun sb!c::vector-length (vector)
191   (sb!c::vector-length vector))
192
193 ;;; Allocate a unboxed, simple vector with type code TYPE, length LENGTH, and
194 ;;; WORDS words long. Note: it is your responsibility to ensure that the
195 ;;; relation between LENGTH and WORDS is correct.
196 (defun allocate-vector (type length words)
197   (allocate-vector type length words))
198
199 ;;; Allocate an array header with type code TYPE and rank RANK.
200 (defun make-array-header (type rank)
201   (make-array-header type rank))
202
203 ;;; Return a SAP pointing to the instructions part of CODE-OBJ.
204 (defun code-instructions (code-obj)
205   (code-instructions code-obj))
206
207 ;;; Extract the INDEXth element from the header of CODE-OBJ. Can be
208 ;;; set with SETF.
209 (defun code-header-ref (code-obj index)
210   (code-header-ref code-obj index))
211
212 (defun code-header-set (code-obj index new)
213   (code-header-set code-obj index new))
214
215 (defun %vector-raw-bits (object offset)
216   (declare (type index offset))
217   (sb!kernel:%vector-raw-bits object offset))
218
219 (defun %set-vector-raw-bits (object offset value)
220   (declare (type index offset))
221   (declare (type sb!vm:word value))
222   (setf (sb!kernel:%vector-raw-bits object offset) value))
223
224 (defun make-single-float (x) (make-single-float x))
225 (defun make-double-float (hi lo) (make-double-float hi lo))
226
227 (defun single-float-bits (x) (single-float-bits x))
228 (defun double-float-high-bits (x) (double-float-high-bits x))
229 (defun double-float-low-bits (x) (double-float-low-bits x))
230