1 ;;;; a bunch of handy macros for the x86
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.
14 ;;; We can load/store into fp registers through the top of stack
15 ;;; %st(0) (fr0 here). Loads imply a push to an empty register which
16 ;;; then changes all the reg numbers. These macros help manage that.
18 ;;; Use this when we don't have to load anything. It preserves old tos
19 ;;; value, but probably destroys tn with operation.
20 (defmacro with-tn@fp-top((tn) &body body)
22 (unless (zerop (tn-offset ,tn))
25 (unless (zerop (tn-offset ,tn))
28 ;;; Use this to prepare for load of new value from memory. This
29 ;;; changes the register numbering so the next instruction had better
30 ;;; be a FP load from memory; a register load from another register
31 ;;; will probably be loading the wrong register!
32 (defmacro with-empty-tn@fp-top((tn) &body body)
36 (unless (zerop (tn-offset ,tn))
37 (inst fxch ,tn)))) ; save into new dest and restore st(0)
39 ;;;; instruction-like macros
41 (defmacro move (dst src)
43 "Move SRC into DST unless they are location=."
44 (once-only ((n-dst dst)
46 `(unless (location= ,n-dst ,n-src)
47 (inst mov ,n-dst ,n-src))))
49 (defmacro make-ea-for-object-slot (ptr slot lowtag)
50 `(make-ea :dword :base ,ptr :disp (- (* ,slot n-word-bytes) ,lowtag)))
52 (defmacro loadw (value ptr &optional (slot 0) (lowtag 0))
53 `(inst mov ,value (make-ea-for-object-slot ,ptr ,slot ,lowtag)))
55 (defmacro storew (value ptr &optional (slot 0) (lowtag 0))
56 (once-only ((value value))
57 `(inst mov (make-ea-for-object-slot ,ptr ,slot ,lowtag) ,value)))
59 (defmacro pushw (ptr &optional (slot 0) (lowtag 0))
60 `(inst push (make-ea-for-object-slot ,ptr ,slot ,lowtag)))
62 (defmacro popw (ptr &optional (slot 0) (lowtag 0))
63 `(inst pop (make-ea-for-object-slot ,ptr ,slot ,lowtag)))
65 ;;;; macros to generate useful values
67 (defmacro load-symbol (reg symbol)
68 `(inst mov ,reg (+ nil-value (static-symbol-offset ,symbol))))
70 (defmacro load-symbol-value (reg symbol)
74 (static-symbol-offset ',symbol)
75 (ash symbol-value-slot word-shift)
76 (- other-pointer-lowtag)))))
78 (defmacro store-symbol-value (reg symbol)
82 (static-symbol-offset ',symbol)
83 (ash symbol-value-slot word-shift)
84 (- other-pointer-lowtag)))
88 (defmacro load-tl-symbol-value (reg symbol)
93 (static-symbol-offset ',symbol)
94 (ash symbol-tls-index-slot word-shift)
95 (- other-pointer-lowtag))))
96 (inst fs-segment-prefix)
97 (inst mov ,reg (make-ea :dword :scale 1 :index ,reg))))
99 (defmacro load-tl-symbol-value (reg symbol) `(load-symbol-value ,reg ,symbol))
102 (defmacro store-tl-symbol-value (reg symbol temp)
107 (static-symbol-offset ',symbol)
108 (ash symbol-tls-index-slot word-shift)
109 (- other-pointer-lowtag))))
110 (inst fs-segment-prefix)
111 (inst mov (make-ea :dword :scale 1 :index ,temp) ,reg)))
113 (defmacro store-tl-symbol-value (reg symbol temp)
114 (declare (ignore temp))
115 `(store-symbol-value ,reg ,symbol))
117 (defmacro load-type (target source &optional (offset 0))
119 "Loads the type bits of a pointer into target independent of
120 byte-ordering issues."
121 (once-only ((n-target target)
124 (ecase *backend-byte-order*
127 (make-ea :byte :base ,n-source :disp ,n-offset)))
130 (make-ea :byte :base ,n-source :disp (+ ,n-offset 3)))))))
132 ;;;; allocation helpers
134 ;;; Two allocation approaches are implemented. A call into C can be
135 ;;; used, and in that case special care can be taken to disable
136 ;;; interrupts. Alternatively with gencgc inline allocation is possible
137 ;;; although it isn't interrupt safe.
139 ;;; For GENCGC it is possible to inline object allocation, to permit
140 ;;; this set the following variable to True.
142 ;;; FIXME: The comment above says that this isn't interrupt safe. Is that
143 ;;; right? If so, do we want to do this? And surely we don't want to do this by
144 ;;; default? How much time does it save to do this? Is it any different in the
145 ;;; current CMU CL version instead of the one that I grabbed in 1998?
146 ;;; (Later observation: In order to be interrupt safe, it'd probably
147 ;;; have to use PSEUDO-ATOMIC, so it's probably not -- yuck. Try benchmarks
148 ;;; with and without inline allocation, and unless the inline allocation
149 ;;; wins by a whole lot, it's not likely to be worth messing with. If
150 ;;; we want to hack up memory allocation for performance, effort spent
151 ;;; on DYNAMIC-EXTENT would probably give a better payoff.)
152 (defvar *maybe-use-inline-allocation* t)
154 ;;; Emit code to allocate an object with a size in bytes given by
155 ;;; Size. The size may be an integer of a TN. If Inline is a VOP
156 ;;; node-var then it is used to make an appropriate speed vs size
159 ;;; FIXME: We call into C.. except when inline allocation is enabled..?
161 ;;; FIXME: Also, calls to
162 ;;; ALLOCATION are always wrapped with PSEUDO-ATOMIC -- why? Is it to
163 ;;; make sure that no GC happens between the time of allocation and the
164 ;;; time that the allocated memory has its tag bits set correctly?
165 ;;; If so, then ALLOCATION itself might as well set the PSEUDO-ATOMIC
166 ;;; bits, so that the caller need only clear them. Check whether it's
167 ;;; true that every ALLOCATION is surrounded by PSEUDO-ATOMIC, and
168 ;;; that every PSEUDO-ATOMIC contains a single ALLOCATION, which is
169 ;;; its first instruction. If so, the connection should probably be
170 ;;; formalized, in documentation and in macro definition,
171 ;;; with the macro becoming e.g. PSEUDO-ATOMIC-ALLOCATION.
172 (defun allocation (alloc-tn size &optional inline)
173 ;; FIXME: since it appears that inline allocation is gone, we should
174 ;; remove the INLINE parameter, and all the above comments.
175 (declare (ignore inline))
176 (flet ((load-size (dst-tn size)
177 (unless (and (tn-p size) (location= alloc-tn size))
178 (inst mov dst-tn size))))
179 (let ((alloc-tn-offset (tn-offset alloc-tn)))
180 ;; C call to allocate via dispatch routines. Each
181 ;; destination has a special entry point. The size may be a
182 ;; register or a constant.
183 (ecase alloc-tn-offset
186 (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_eax")
188 (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_eax")
191 (load-size eax-tn size)
192 (inst call (make-fixup (extern-alien-name "alloc_to_eax")
196 (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_ecx")
198 (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_ecx")
201 (load-size ecx-tn size)
202 (inst call (make-fixup (extern-alien-name "alloc_to_ecx")
206 (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_edx")
208 (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_edx")
211 (load-size edx-tn size)
212 (inst call (make-fixup (extern-alien-name "alloc_to_edx")
216 (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_ebx")
218 (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_ebx")
221 (load-size ebx-tn size)
222 (inst call (make-fixup (extern-alien-name "alloc_to_ebx")
226 (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_esi")
228 (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_esi")
231 (load-size esi-tn size)
232 (inst call (make-fixup (extern-alien-name "alloc_to_esi")
236 (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_edi")
238 (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_edi")
241 (load-size edi-tn size)
242 (inst call (make-fixup (extern-alien-name "alloc_to_edi")
246 ;;; Allocate an other-pointer object of fixed SIZE with a single word
247 ;;; header having the specified WIDETAG value. The result is placed in
249 (defmacro with-fixed-allocation ((result-tn widetag size &optional inline)
252 (allocation ,result-tn (pad-data-block ,size) ,inline)
253 (storew (logior (ash (1- ,size) n-widetag-bits) ,widetag)
256 (make-ea :byte :base ,result-tn :disp other-pointer-lowtag))
260 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
261 (defun emit-error-break (vop kind code values)
262 (let ((vector (gensym)))
263 `((inst int 3) ; i386 breakpoint instruction
264 ;; The return PC points here; note the location for the debugger.
267 (note-this-location vop :internal-error)))
268 (inst byte ,kind) ; eg trap_Xyyy
269 (with-adjustable-vector (,vector) ; interr arguments
270 (write-var-integer (error-number-or-lose ',code) ,vector)
271 ,@(mapcar (lambda (tn)
273 ;; classic CMU CL comment:
274 ;; zzzzz jrd here. tn-offset is zero for constant
276 (write-var-integer (make-sc-offset (sc-number
282 (inst byte (length ,vector))
283 (dotimes (i (length ,vector))
284 (inst byte (aref ,vector i))))))))
286 (defmacro error-call (vop error-code &rest values)
288 "Cause an error. ERROR-CODE is the error to cause."
290 (emit-error-break vop error-trap error-code values)))
292 (defmacro generate-error-code (vop error-code &rest values)
294 "Generate-Error-Code Error-code Value*
295 Emit code for an error with the specified Error-Code and context Values."
296 `(assemble (*elsewhere*)
297 (let ((start-lab (gen-label)))
298 (emit-label start-lab)
299 (error-call ,vop ,error-code ,@values)
305 ;;; FIXME: *PSEUDO-ATOMIC-FOO* could be made into *PSEUDO-ATOMIC-BITS*,
306 ;;; set with a single operation and cleared with SHR *PSEUDO-ATOMIC-BITS*,-2;
307 ;;; the ATOMIC bit is bit 0, the INTERRUPTED bit is bit 1, and you check
308 ;;; the C flag after the shift to see whether you were interrupted.
310 ;;; FIXME: It appears that PSEUDO-ATOMIC is used to wrap operations which leave
311 ;;; untagged memory lying around, but some documentation would be nice.
313 (defmacro pseudo-atomic (&rest forms)
314 (with-unique-names (label)
315 `(let ((,label (gen-label)))
316 (inst fs-segment-prefix)
317 (inst mov (make-ea :byte :disp (* 4 thread-pseudo-atomic-atomic-slot)) 1)
318 (inst fs-segment-prefix)
319 (inst mov (make-ea :byte
320 :disp (* 4 thread-pseudo-atomic-interrupted-slot)) 0)
322 (inst fs-segment-prefix)
323 (inst mov (make-ea :byte :disp (* 4 thread-pseudo-atomic-atomic-slot)) 0)
324 (inst fs-segment-prefix)
325 (inst cmp (make-ea :byte
326 :disp (* 4 thread-pseudo-atomic-interrupted-slot)) 0)
327 (inst jmp :eq ,label)
328 ;; if PAI was set, interrupts were disabled at the same time
329 ;; using the process signal mask.
330 (inst break pending-interrupt-trap)
331 (emit-label ,label))))
334 (defmacro pseudo-atomic (&rest forms)
335 (with-unique-names (label)
336 `(let ((,label (gen-label)))
337 ;; FIXME: The MAKE-EA noise should become a MACROLET macro or
338 ;; something. (perhaps SVLB, for static variable low byte)
339 (inst mov (make-ea :byte :disp (+ nil-value
340 (static-symbol-offset
341 '*pseudo-atomic-interrupted*)
342 (ash symbol-value-slot word-shift)
343 ;; FIXME: Use mask, not minus, to
344 ;; take out type bits.
345 (- other-pointer-lowtag)))
347 (inst mov (make-ea :byte :disp (+ nil-value
348 (static-symbol-offset
349 '*pseudo-atomic-atomic*)
350 (ash symbol-value-slot word-shift)
351 (- other-pointer-lowtag)))
354 (inst mov (make-ea :byte :disp (+ nil-value
355 (static-symbol-offset
356 '*pseudo-atomic-atomic*)
357 (ash symbol-value-slot word-shift)
358 (- other-pointer-lowtag)))
360 ;; KLUDGE: Is there any requirement for interrupts to be
361 ;; handled in order? It seems as though an interrupt coming
362 ;; in at this point will be executed before any pending interrupts.
363 ;; Or do incoming interrupts check to see whether any interrupts
364 ;; are pending? I wish I could find the documentation for
365 ;; pseudo-atomics.. -- WHN 19991130
366 (inst cmp (make-ea :byte
368 (static-symbol-offset
369 '*pseudo-atomic-interrupted*)
370 (ash symbol-value-slot word-shift)
371 (- other-pointer-lowtag)))
373 (inst jmp :eq ,label)
374 ;; if PAI was set, interrupts were disabled at the same time
375 ;; using the process signal mask.
376 (inst break pending-interrupt-trap)
377 (emit-label ,label))))
381 ;;;; indexed references
383 (defmacro define-full-reffer (name type offset lowtag scs el-type &optional translate)
387 `((:translate ,translate)))
389 (:args (object :scs (descriptor-reg))
390 (index :scs (any-reg)))
391 (:arg-types ,type tagged-num)
392 (:results (value :scs ,scs))
393 (:result-types ,el-type)
394 (:generator 3 ; pw was 5
395 (inst mov value (make-ea :dword :base object :index index
396 :disp (- (* ,offset n-word-bytes)
398 (define-vop (,(symbolicate name "-C"))
400 `((:translate ,translate)))
402 (:args (object :scs (descriptor-reg)))
404 (:arg-types ,type (:constant (signed-byte 30)))
405 (:results (value :scs ,scs))
406 (:result-types ,el-type)
407 (:generator 2 ; pw was 5
408 (inst mov value (make-ea :dword :base object
409 :disp (- (* (+ ,offset index) n-word-bytes)
412 (defmacro define-full-setter (name type offset lowtag scs el-type &optional translate)
416 `((:translate ,translate)))
418 (:args (object :scs (descriptor-reg))
419 (index :scs (any-reg))
420 (value :scs ,scs :target result))
421 (:arg-types ,type tagged-num ,el-type)
422 (:results (result :scs ,scs))
423 (:result-types ,el-type)
424 (:generator 4 ; was 5
425 (inst mov (make-ea :dword :base object :index index
426 :disp (- (* ,offset n-word-bytes) ,lowtag))
428 (move result value)))
429 (define-vop (,(symbolicate name "-C"))
431 `((:translate ,translate)))
433 (:args (object :scs (descriptor-reg))
434 (value :scs ,scs :target result))
436 (:arg-types ,type (:constant (signed-byte 30)) ,el-type)
437 (:results (result :scs ,scs))
438 (:result-types ,el-type)
439 (:generator 3 ; was 5
440 (inst mov (make-ea :dword :base object
441 :disp (- (* (+ ,offset index) n-word-bytes)
444 (move result value)))))