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.
17 ;;; We can load/store into fp registers through the top of
18 ;;; stack %st(0) (fr0 here). Loads imply a push to an empty register
19 ;;; which then changes all the reg numbers. These macros help manage that.
21 ;;; Use this when we don't have to load anything. It preserves old tos value,
22 ;;; but probably destroys tn with operation.
23 (defmacro with-tn@fp-top((tn) &body body)
25 (unless (zerop (tn-offset ,tn))
28 (unless (zerop (tn-offset ,tn))
31 ;;; Use this to prepare for load of new value from memory. This
32 ;;; changes the register numbering so the next instruction had better
33 ;;; be a FP load from memory; a register load from another register
34 ;;; will probably be loading the wrong register!
35 (defmacro with-empty-tn@fp-top((tn) &body body)
39 (unless (zerop (tn-offset ,tn))
40 (inst fxch ,tn)))) ; save into new dest and restore st(0)
42 ;;;; instruction-like macros
44 (defmacro move (dst src)
46 "Move SRC into DST unless they are location=."
47 (once-only ((n-dst dst)
49 `(unless (location= ,n-dst ,n-src)
50 (inst mov ,n-dst ,n-src))))
52 (defmacro make-ea-for-object-slot (ptr slot lowtag)
53 `(make-ea :dword :base ,ptr :disp (- (* ,slot word-bytes) ,lowtag)))
55 (defmacro loadw (value ptr &optional (slot 0) (lowtag 0))
56 `(inst mov ,value (make-ea-for-object-slot ,ptr ,slot ,lowtag)))
58 (defmacro storew (value ptr &optional (slot 0) (lowtag 0))
59 (once-only ((value value))
60 `(inst mov (make-ea-for-object-slot ,ptr ,slot ,lowtag) ,value)))
62 (defmacro pushw (ptr &optional (slot 0) (lowtag 0))
63 `(inst push (make-ea-for-object-slot ,ptr ,slot ,lowtag)))
65 (defmacro popw (ptr &optional (slot 0) (lowtag 0))
66 `(inst pop (make-ea-for-object-slot ,ptr ,slot ,lowtag)))
68 ;;;; macros to generate useful values
70 (defmacro load-symbol (reg symbol)
71 `(inst mov ,reg (+ nil-value (static-symbol-offset ,symbol))))
73 (defmacro load-symbol-value (reg symbol)
77 (static-symbol-offset ',symbol)
78 (ash symbol-value-slot word-shift)
79 (- other-pointer-type)))))
81 (defmacro store-symbol-value (reg symbol)
85 (static-symbol-offset ',symbol)
86 (ash symbol-value-slot word-shift)
87 (- other-pointer-type)))
91 (defmacro load-type (target source &optional (offset 0))
93 "Loads the type bits of a pointer into target independent of
94 byte-ordering issues."
95 (once-only ((n-target target)
98 (ecase *backend-byte-order*
101 (make-ea :byte :base ,n-source :disp ,n-offset)))
104 (make-ea :byte :base ,n-source :disp (+ ,n-offset 3)))))))
106 ;;;; allocation helpers
108 ;;; Two allocation approaches are implemented. A call into C can be
109 ;;; used, and in that case special care can be taken to disable
110 ;;; interrupts. Alternatively with gencgc inline allocation is possible
111 ;;; although it isn't interrupt safe.
113 ;;; For GENCGC it is possible to inline object allocation, to permit
114 ;;; this set the following variable to True.
116 ;;; FIXME: The comment above says that this isn't interrupt safe. Is that
117 ;;; right? If so, do we want to do this? And surely we don't want to do this by
118 ;;; default? How much time does it save to do this? Is it any different in the
119 ;;; current CMU CL version instead of the one that I grabbed in 1998?
120 ;;; (Later observation: In order to be interrupt safe, it'd probably
121 ;;; have to use PSEUDO-ATOMIC, so it's probably not -- yuck. Try benchmarks
122 ;;; with and without inline allocation, and unless the inline allocation
123 ;;; wins by a whole lot, it's not likely to be worth messing with. If
124 ;;; we want to hack up memory allocation for performance, effort spent
125 ;;; on DYNAMIC-EXTENT would probably give a better payoff.)
126 (defvar *maybe-use-inline-allocation* t)
130 ;;; FIXME: Except when inline allocation is enabled..?
132 ;;; FIXME: Also, calls to
133 ;;; ALLOCATION are always wrapped with PSEUDO-ATOMIC -- why? Is it to
134 ;;; make sure that no GC happens between the time of allocation and the
135 ;;; time that the allocated memory has its tag bits set correctly?
136 ;;; If so, then ALLOCATION itself might as well set the PSEUDO-ATOMIC
137 ;;; bits, so that the caller need only clear them. Check whether it's
138 ;;; true that every ALLOCATION is surrounded by PSEUDO-ATOMIC, and
139 ;;; that every PSEUDO-ATOMIC contains a single ALLOCATION, which is
140 ;;; its first instruction. If so, the connection should probably be
141 ;;; formalized, in documentation and in macro definition,
142 ;;; with the macro becoming e.g. PSEUDO-ATOMIC-ALLOCATION.
143 (defun allocation (alloc-tn size &optional inline)
145 "Emit code to allocate an object with a size in bytes given by Size.
146 The size may be an integer of a TN.
147 If Inline is a VOP node-var then it is used to make an appropriate
148 speed vs size decision."
149 (flet ((load-size (dst-tn size)
150 (unless (and (tn-p size) (location= alloc-tn size))
151 (inst mov dst-tn size))))
152 (let ((alloc-tn-offset (tn-offset alloc-tn)))
153 ;; FIXME: All these (MAKE-FIXUP (EXTERN-ALIEN-NAME "foo") :FOREIGN)
154 ;; expressions should be moved into MACROLET ((ALIEN-FIXUP ..)),
155 ;; and INST CALL (MAKE-FIXUP ..) should become CALL-ALIEN-FIXUP.
156 (if (and #!+gencgc t #!-gencgc nil
157 *maybe-use-inline-allocation*
158 (or (null inline) (policy inline (>= speed space))))
159 ;; Inline allocation with GENCGC.
160 (let ((ok (gen-label)))
161 ;; Load the size first so that the size can be in the same
162 ;; register as alloc-tn.
163 (load-size alloc-tn size)
165 (make-fixup (extern-alien-name "current_region_free_pointer")
168 (make-fixup (extern-alien-name "current_region_end_addr")
171 ;; Dispatch to the appropriate overflow routine. There is a
172 ;; routine for each destination.
173 ;; FIXME: Could we use an alist here instead of an ECASE with lots
174 ;; of duplicate code? (and similar question for next ECASE, too)
175 (ecase alloc-tn-offset
176 (#.eax-offset ;; FIXME: Why the #\# #\.?
177 (inst call (make-fixup (extern-alien-name "alloc_overflow_eax")
180 (inst call (make-fixup (extern-alien-name "alloc_overflow_ecx")
183 (inst call (make-fixup (extern-alien-name "alloc_overflow_edx")
186 (inst call (make-fixup (extern-alien-name "alloc_overflow_ebx")
189 (inst call (make-fixup (extern-alien-name "alloc_overflow_esi")
192 (inst call (make-fixup (extern-alien-name "alloc_overflow_edi")
195 (inst xchg (make-fixup
196 (extern-alien-name "current_region_free_pointer")
199 ;; C call to allocate via dispatch routines. Each
200 ;; destination has a special entry point. The size may be a
201 ;; register or a constant.
202 (ecase alloc-tn-offset
205 (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_eax")
207 (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_eax")
210 (load-size eax-tn size)
211 (inst call (make-fixup (extern-alien-name "alloc_to_eax")
215 (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_ecx")
217 (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_ecx")
220 (load-size ecx-tn size)
221 (inst call (make-fixup (extern-alien-name "alloc_to_ecx")
225 (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_edx")
227 (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_edx")
230 (load-size edx-tn size)
231 (inst call (make-fixup (extern-alien-name "alloc_to_edx")
235 (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_ebx")
237 (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_ebx")
240 (load-size ebx-tn size)
241 (inst call (make-fixup (extern-alien-name "alloc_to_ebx")
245 (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_esi")
247 (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_esi")
250 (load-size esi-tn size)
251 (inst call (make-fixup (extern-alien-name "alloc_to_esi")
255 (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_edi")
257 (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_edi")
260 (load-size edi-tn size)
261 (inst call (make-fixup (extern-alien-name "alloc_to_edi")
265 (defmacro with-fixed-allocation ((result-tn type-code size &optional inline)
268 "Allocate an other-pointer object of fixed Size with a single
269 word header having the specified Type-Code. The result is placed in
272 (allocation ,result-tn (pad-data-block ,size) ,inline)
273 (storew (logior (ash (1- ,size) sb!vm:type-bits) ,type-code) ,result-tn)
275 (make-ea :byte :base ,result-tn :disp other-pointer-type))
281 (defvar *adjustable-vectors* nil)
283 (defmacro with-adjustable-vector ((var) &rest body)
284 `(let ((,var (or (pop *adjustable-vectors*)
286 :element-type '(unsigned-byte 8)
289 (setf (fill-pointer ,var) 0)
293 (push ,var *adjustable-vectors*))))
295 (eval-when (:compile-toplevel :load-toplevel :execute)
296 (defun emit-error-break (vop kind code values)
297 (let ((vector (gensym)))
298 `((inst int 3) ; i386 breakpoint instruction
299 ;; The return PC points here; note the location for the debugger.
302 (note-this-location vop :internal-error)))
303 (inst byte ,kind) ; eg trap_Xyyy
304 (with-adjustable-vector (,vector) ; interr arguments
305 (write-var-integer (error-number-or-lose ',code) ,vector)
306 ,@(mapcar (lambda (tn)
308 ;; classic CMU CL comment:
309 ;; zzzzz jrd here. tn-offset is zero for constant
311 (write-var-integer (make-sc-offset (sc-number
317 (inst byte (length ,vector))
318 (dotimes (i (length ,vector))
319 (inst byte (aref ,vector i))))))))
321 (defmacro error-call (vop error-code &rest values)
323 "Cause an error. ERROR-CODE is the error to cause."
325 (emit-error-break vop error-trap error-code values)))
329 (defmacro cerror-call (vop label error-code &rest values)
331 "Cause a continuable error. If the error is continued, execution resumes
334 ,@(emit-error-break vop cerror-trap error-code values)
338 (defmacro generate-error-code (vop error-code &rest values)
340 "Generate-Error-Code Error-code Value*
341 Emit code for an error with the specified Error-Code and context Values."
342 `(assemble (*elsewhere*)
343 (let ((start-lab (gen-label)))
344 (emit-label start-lab)
345 (error-call ,vop ,error-code ,@values)
350 (defmacro generate-cerror-code (vop error-code &rest values)
352 "Generate-CError-Code Error-code Value*
353 Emit code for a continuable error with the specified Error-Code and
354 context Values. If the error is continued, execution resumes after
355 the GENERATE-CERROR-CODE form."
356 (let ((continue (gensym "CONTINUE-LABEL-"))
357 (error (gensym "ERROR-LABEL-")))
358 `(let ((,continue (gen-label))
359 (,error (gen-label)))
360 (emit-label ,continue)
361 (assemble (*elsewhere*)
363 (cerror-call ,vop ,continue ,error-code ,@values))
369 ;;; FIXME: This should be a compile-time option, not a runtime option. Doing it
370 ;;; at runtime is bizarre. As I understand it, the default should definitely be
371 ;;; to have pseudo-atomic behavior, but for a performance-critical program
372 ;;; which is guaranteed not to have asynchronous exceptions, it could be worth
373 ;;; something to compile with :SB-NO-PSEUDO-ATOMIC.
374 (defvar *enable-pseudo-atomic* t)
376 ;;; FIXME: *PSEUDO-ATOMIC-ATOMIC* and *PSEUDO-ATOMIC-INTERRUPTED*
377 ;;; should be in package SB!VM or SB!KERNEL, not SB!IMPL.
379 ;;; FIXME: *PSEUDO-ATOMIC-FOO* could be made into *PSEUDO-ATOMIC-BITS*,
380 ;;; set with a single operation and cleared with SHR *PSEUDO-ATOMIC-BITS*,-2;
381 ;;; the ATOMIC bit is bit 0, the INTERRUPTED bit is bit 1, and you check
382 ;;; the C flag after the shift to see whether you were interrupted.
384 ;;; FIXME: It appears that PSEUDO-ATOMIC is used to wrap operations which leave
385 ;;; untagged memory lying around, but some documentation would be nice.
386 (defmacro pseudo-atomic (&rest forms)
387 (let ((label (gensym "LABEL-")))
388 `(let ((,label (gen-label)))
389 (when *enable-pseudo-atomic*
390 ;; FIXME: The MAKE-EA noise should become a MACROLET macro or
391 ;; something. (perhaps SVLB, for static variable low byte)
392 (inst mov (make-ea :byte :disp (+ nil-value
393 (static-symbol-offset
394 'sb!impl::*pseudo-atomic-interrupted*)
395 (ash symbol-value-slot word-shift)
396 ;; FIXME: Use mask, not minus, to
397 ;; take out type bits.
398 (- other-pointer-type)))
400 (inst mov (make-ea :byte :disp (+ nil-value
401 (static-symbol-offset
402 'sb!impl::*pseudo-atomic-atomic*)
403 (ash symbol-value-slot word-shift)
404 (- other-pointer-type)))
407 (when *enable-pseudo-atomic*
408 (inst mov (make-ea :byte :disp (+ nil-value
409 (static-symbol-offset
410 'sb!impl::*pseudo-atomic-atomic*)
411 (ash symbol-value-slot word-shift)
412 (- other-pointer-type)))
414 ;; KLUDGE: Is there any requirement for interrupts to be
415 ;; handled in order? It seems as though an interrupt coming
416 ;; in at this point will be executed before any pending interrupts.
417 ;; Or do incoming interrupts check to see whether any interrupts
418 ;; are pending? I wish I could find the documentation for
419 ;; pseudo-atomics.. -- WHN 19991130
420 (inst cmp (make-ea :byte
422 (static-symbol-offset
423 'sb!impl::*pseudo-atomic-interrupted*)
424 (ash symbol-value-slot word-shift)
425 (- other-pointer-type)))
427 (inst jmp :eq ,label)
428 (inst break pending-interrupt-trap)
429 (emit-label ,label)))))
431 ;;;; indexed references
433 (defmacro define-full-reffer (name type offset lowtag scs el-type &optional translate)
437 `((:translate ,translate)))
439 (:args (object :scs (descriptor-reg))
440 (index :scs (any-reg)))
441 (:arg-types ,type tagged-num)
442 (:results (value :scs ,scs))
443 (:result-types ,el-type)
444 (:generator 3 ; pw was 5
445 (inst mov value (make-ea :dword :base object :index index
446 :disp (- (* ,offset word-bytes) ,lowtag)))))
447 (define-vop (,(symbolicate name "-C"))
449 `((:translate ,translate)))
451 (:args (object :scs (descriptor-reg)))
453 (:arg-types ,type (:constant (signed-byte 30)))
454 (:results (value :scs ,scs))
455 (:result-types ,el-type)
456 (:generator 2 ; pw was 5
457 (inst mov value (make-ea :dword :base object
458 :disp (- (* (+ ,offset index) word-bytes)
461 (defmacro define-full-setter (name type offset lowtag scs el-type &optional translate)
465 `((:translate ,translate)))
467 (:args (object :scs (descriptor-reg))
468 (index :scs (any-reg))
469 (value :scs ,scs :target result))
470 (:arg-types ,type tagged-num ,el-type)
471 (:results (result :scs ,scs))
472 (:result-types ,el-type)
473 (:generator 4 ; was 5
474 (inst mov (make-ea :dword :base object :index index
475 :disp (- (* ,offset word-bytes) ,lowtag))
477 (move result value)))
478 (define-vop (,(symbolicate name "-C"))
480 `((:translate ,translate)))
482 (:args (object :scs (descriptor-reg))
483 (value :scs ,scs :target result))
485 (:arg-types ,type (:constant (signed-byte 30)) ,el-type)
486 (:results (result :scs ,scs))
487 (:result-types ,el-type)
488 (:generator 3 ; was 5
489 (inst mov (make-ea :dword :base object
490 :disp (- (* (+ ,offset index) word-bytes) ,lowtag))
492 (move result value)))))