0.pre7.20:
[sbcl.git] / src / compiler / x86 / macros.lisp
1 ;;;; a bunch of handy macros for the x86
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!VM")
13
14 ;;; We can load/store into fp registers through the top of
15 ;;; stack %st(0) (fr0 here). Loads imply a push to an empty register
16 ;;; which then changes all the reg numbers. These macros help manage that.
17
18 ;;; Use this when we don't have to load anything. It preserves old tos value,
19 ;;; but probably destroys tn with operation.
20 (defmacro with-tn@fp-top((tn) &body body)
21   `(progn
22     (unless (zerop (tn-offset ,tn))
23       (inst fxch ,tn))
24     ,@body
25     (unless (zerop (tn-offset ,tn))
26       (inst fxch ,tn))))
27
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)
33   `(progn
34     (inst fstp ,tn)
35     ,@body
36     (unless (zerop (tn-offset ,tn))
37       (inst fxch ,tn))))                ; save into new dest and restore st(0)
38 \f
39 ;;;; instruction-like macros
40
41 (defmacro move (dst src)
42   #!+sb-doc
43   "Move SRC into DST unless they are location=."
44   (once-only ((n-dst dst)
45               (n-src src))
46     `(unless (location= ,n-dst ,n-src)
47        (inst mov ,n-dst ,n-src))))
48
49 (defmacro make-ea-for-object-slot (ptr slot lowtag)
50   `(make-ea :dword :base ,ptr :disp (- (* ,slot word-bytes) ,lowtag)))
51
52 (defmacro loadw (value ptr &optional (slot 0) (lowtag 0))
53   `(inst mov ,value (make-ea-for-object-slot ,ptr ,slot ,lowtag)))
54
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)))
58
59 (defmacro pushw (ptr &optional (slot 0) (lowtag 0))
60   `(inst push (make-ea-for-object-slot ,ptr ,slot ,lowtag)))
61
62 (defmacro popw (ptr &optional (slot 0) (lowtag 0))
63   `(inst pop (make-ea-for-object-slot ,ptr ,slot ,lowtag)))
64 \f
65 ;;;; macros to generate useful values
66
67 (defmacro load-symbol (reg symbol)
68   `(inst mov ,reg (+ nil-value (static-symbol-offset ,symbol))))
69
70 (defmacro load-symbol-value (reg symbol)
71   `(inst mov ,reg
72          (make-ea :dword
73                   :disp (+ nil-value
74                            (static-symbol-offset ',symbol)
75                            (ash symbol-value-slot word-shift)
76                            (- other-pointer-type)))))
77
78 (defmacro store-symbol-value (reg symbol)
79   `(inst mov
80          (make-ea :dword
81                   :disp (+ nil-value
82                            (static-symbol-offset ',symbol)
83                            (ash symbol-value-slot word-shift)
84                            (- other-pointer-type)))
85          ,reg))
86
87
88 (defmacro load-type (target source &optional (offset 0))
89   #!+sb-doc
90   "Loads the type bits of a pointer into target independent of
91    byte-ordering issues."
92   (once-only ((n-target target)
93               (n-source source)
94               (n-offset offset))
95     (ecase *backend-byte-order*
96       (:little-endian
97        `(inst mov ,n-target
98               (make-ea :byte :base ,n-source :disp ,n-offset)))
99       (:big-endian
100        `(inst mov ,n-target
101               (make-ea :byte :base ,n-source :disp (+ ,n-offset 3)))))))
102 \f
103 ;;;; allocation helpers
104
105 ;;; Two allocation approaches are implemented. A call into C can be
106 ;;; used, and in that case special care can be taken to disable
107 ;;; interrupts. Alternatively with gencgc inline allocation is possible
108 ;;; although it isn't interrupt safe.
109
110 ;;; For GENCGC it is possible to inline object allocation, to permit
111 ;;; this set the following variable to True.
112 ;;;
113 ;;; FIXME: The comment above says that this isn't interrupt safe. Is that
114 ;;; right? If so, do we want to do this? And surely we don't want to do this by
115 ;;; default? How much time does it save to do this? Is it any different in the
116 ;;; current CMU CL version instead of the one that I grabbed in 1998?
117 ;;; (Later observation: In order to be interrupt safe, it'd probably
118 ;;; have to use PSEUDO-ATOMIC, so it's probably not -- yuck. Try benchmarks
119 ;;; with and without inline allocation, and unless the inline allocation
120 ;;; wins by a whole lot, it's not likely to be worth messing with. If
121 ;;; we want to hack up memory allocation for performance, effort spent
122 ;;; on DYNAMIC-EXTENT would probably give a better payoff.)
123 (defvar *maybe-use-inline-allocation* t)
124
125 ;;; Emit code to allocate an object with a size in bytes given by
126 ;;; Size. The size may be an integer of a TN. If Inline is a VOP
127 ;;; node-var then it is used to make an appropriate speed vs size
128 ;;; decision.
129 ;;;
130 ;;; FIXME: We call into C.. except when inline allocation is enabled..?
131 ;;;
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)
144   (flet ((load-size (dst-tn size)
145            (unless (and (tn-p size) (location= alloc-tn size))
146              (inst mov dst-tn size))))
147     (let ((alloc-tn-offset (tn-offset alloc-tn)))
148       ;; FIXME: All these (MAKE-FIXUP (EXTERN-ALIEN-NAME "foo") :FOREIGN)
149       ;; expressions should be moved into MACROLET ((ALIEN-FIXUP ..)),
150       ;; and INST CALL (MAKE-FIXUP ..) should become CALL-ALIEN-FIXUP.
151       (if (and #!+gencgc t #!-gencgc nil
152                *maybe-use-inline-allocation*
153                (or (null inline) (policy inline (>= speed space))))
154           ;; Inline allocation with GENCGC.
155           (let ((ok (gen-label)))
156             ;; Load the size first so that the size can be in the same
157             ;; register as alloc-tn.
158             (load-size alloc-tn size)
159             (inst add alloc-tn
160                   (make-fixup (extern-alien-name "current_region_free_pointer")
161                               :foreign))
162             (inst cmp alloc-tn
163                   (make-fixup (extern-alien-name "current_region_end_addr")
164                               :foreign))
165             (inst jmp :be OK)
166             ;; Dispatch to the appropriate overflow routine. There is a
167             ;; routine for each destination.
168             ;; FIXME: Could we use an alist here instead of an ECASE with lots
169             ;; of duplicate code? (and similar question for next ECASE, too)
170             (ecase alloc-tn-offset
171               (#.eax-offset ;; FIXME: Why the #\# #\.?
172                (inst call (make-fixup (extern-alien-name "alloc_overflow_eax")
173                                       :foreign)))
174               (#.ecx-offset
175                (inst call (make-fixup (extern-alien-name "alloc_overflow_ecx")
176                                       :foreign)))
177               (#.edx-offset
178                (inst call (make-fixup (extern-alien-name "alloc_overflow_edx")
179                                       :foreign)))
180               (#.ebx-offset
181                (inst call (make-fixup (extern-alien-name "alloc_overflow_ebx")
182                                       :foreign)))
183               (#.esi-offset
184                (inst call (make-fixup (extern-alien-name "alloc_overflow_esi")
185                                       :foreign)))
186               (#.edi-offset
187                (inst call (make-fixup (extern-alien-name "alloc_overflow_edi")
188                                       :foreign))))
189             (emit-label ok)
190             (inst xchg (make-fixup
191                         (extern-alien-name "current_region_free_pointer")
192                         :foreign)
193                   alloc-tn))
194           ;; C call to allocate via dispatch routines. Each
195           ;; destination has a special entry point. The size may be a
196           ;; register or a constant.
197           (ecase alloc-tn-offset
198             (#.eax-offset
199              (case size
200                (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_eax")
201                                          :foreign)))
202                (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_eax")
203                                           :foreign)))
204                (t
205                 (load-size eax-tn size)
206                 (inst call (make-fixup (extern-alien-name "alloc_to_eax")
207                                        :foreign)))))
208             (#.ecx-offset
209              (case size
210                (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_ecx")
211                                          :foreign)))
212                (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_ecx")
213                                           :foreign)))
214                (t
215                 (load-size ecx-tn size)
216                 (inst call (make-fixup (extern-alien-name "alloc_to_ecx")
217                                        :foreign)))))
218             (#.edx-offset
219              (case size
220                (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_edx")
221                                          :foreign)))
222                (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_edx")
223                                           :foreign)))
224                (t
225                 (load-size edx-tn size)
226                 (inst call (make-fixup (extern-alien-name "alloc_to_edx")
227                                        :foreign)))))
228             (#.ebx-offset
229              (case size
230                (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_ebx")
231                                          :foreign)))
232                (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_ebx")
233                                           :foreign)))
234                (t
235                 (load-size ebx-tn size)
236                 (inst call (make-fixup (extern-alien-name "alloc_to_ebx")
237                                        :foreign)))))
238             (#.esi-offset
239              (case size
240                (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_esi")
241                                          :foreign)))
242                (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_esi")
243                                           :foreign)))
244                (t
245                 (load-size esi-tn size)
246                 (inst call (make-fixup (extern-alien-name "alloc_to_esi")
247                                        :foreign)))))
248             (#.edi-offset
249              (case size
250                (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_edi")
251                                          :foreign)))
252                (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_edi")
253                                           :foreign)))
254                (t
255                 (load-size edi-tn size)
256                 (inst call (make-fixup (extern-alien-name "alloc_to_edi")
257                                        :foreign)))))))))
258   (values))
259
260 (defmacro with-fixed-allocation ((result-tn type-code size &optional inline)
261                                  &rest forms)
262   #!+sb-doc
263   "Allocate an other-pointer object of fixed Size with a single
264    word header having the specified Type-Code. The result is placed in
265    Result-TN."
266   `(pseudo-atomic
267     (allocation ,result-tn (pad-data-block ,size) ,inline)
268     (storew (logior (ash (1- ,size) sb!vm:type-bits) ,type-code) ,result-tn)
269     (inst lea ,result-tn
270      (make-ea :byte :base ,result-tn :disp other-pointer-type))
271     ,@forms))
272 \f
273 ;;;; error code
274
275 (defvar *adjustable-vectors* nil)
276
277 (defmacro with-adjustable-vector ((var) &rest body)
278   `(let ((,var (or (pop *adjustable-vectors*)
279                    (make-array 16
280                                :element-type '(unsigned-byte 8)
281                                :fill-pointer 0
282                                :adjustable t))))
283      (setf (fill-pointer ,var) 0)
284      (unwind-protect
285          (progn
286            ,@body)
287        (push ,var *adjustable-vectors*))))
288
289 (eval-when (:compile-toplevel :load-toplevel :execute)
290   (defun emit-error-break (vop kind code values)
291     (let ((vector (gensym)))
292       `((inst int 3)                            ; i386 breakpoint instruction
293         ;; The return PC points here; note the location for the debugger.
294         (let ((vop ,vop))
295           (when vop
296                 (note-this-location vop :internal-error)))
297         (inst byte ,kind)                       ; eg trap_Xyyy
298         (with-adjustable-vector (,vector)       ; interr arguments
299           (write-var-integer (error-number-or-lose ',code) ,vector)
300           ,@(mapcar (lambda (tn)
301                       `(let ((tn ,tn))
302                          ;; classic CMU CL comment:
303                          ;;   zzzzz jrd here. tn-offset is zero for constant
304                          ;;   tns.
305                          (write-var-integer (make-sc-offset (sc-number
306                                                              (tn-sc tn))
307                                                             (or (tn-offset tn)
308                                                                 0))
309                                             ,vector)))
310                     values)
311           (inst byte (length ,vector))
312           (dotimes (i (length ,vector))
313             (inst byte (aref ,vector i))))))))
314
315 (defmacro error-call (vop error-code &rest values)
316   #!+sb-doc
317   "Cause an error. ERROR-CODE is the error to cause."
318   (cons 'progn
319         (emit-error-break vop error-trap error-code values)))
320
321 ;;; not used in SBCL
322 #|
323 (defmacro cerror-call (vop label error-code &rest values)
324   #!+sb-doc
325   "Cause a continuable error. If the error is continued, execution resumes
326   at LABEL."
327   `(progn
328      ,@(emit-error-break vop cerror-trap error-code values)
329      (inst jmp ,label)))
330 |#
331
332 (defmacro generate-error-code (vop error-code &rest values)
333   #!+sb-doc
334   "Generate-Error-Code Error-code Value*
335   Emit code for an error with the specified Error-Code and context Values."
336   `(assemble (*elsewhere*)
337      (let ((start-lab (gen-label)))
338        (emit-label start-lab)
339        (error-call ,vop ,error-code ,@values)
340        start-lab)))
341
342 ;;; not used in SBCL
343 #|
344 (defmacro generate-cerror-code (vop error-code &rest values)
345   #!+sb-doc
346   "Generate-CError-Code Error-code Value*
347   Emit code for a continuable error with the specified Error-Code and
348   context Values. If the error is continued, execution resumes after
349   the GENERATE-CERROR-CODE form."
350   (let ((continue (gensym "CONTINUE-LABEL-"))
351         (error (gensym "ERROR-LABEL-")))
352     `(let ((,continue (gen-label))
353            (,error (gen-label)))
354        (emit-label ,continue)
355        (assemble (*elsewhere*)
356          (emit-label ,error)
357          (cerror-call ,vop ,continue ,error-code ,@values))
358        ,error)))
359 |#
360 \f
361 ;;;; PSEUDO-ATOMIC
362
363 ;;; FIXME: This should be a compile-time option, not a runtime option. Doing it
364 ;;; at runtime is bizarre. As I understand it, the default should definitely be
365 ;;; to have pseudo-atomic behavior, but for a performance-critical program
366 ;;; which is guaranteed not to have asynchronous exceptions, it could be worth
367 ;;; something to compile with :SB-NO-PSEUDO-ATOMIC.
368 (defvar *enable-pseudo-atomic* t)
369
370 ;;; FIXME: *PSEUDO-ATOMIC-FOO* could be made into *PSEUDO-ATOMIC-BITS*,
371 ;;; set with a single operation and cleared with SHR *PSEUDO-ATOMIC-BITS*,-2;
372 ;;; the ATOMIC bit is bit 0, the INTERRUPTED bit is bit 1, and you check
373 ;;; the C flag after the shift to see whether you were interrupted.
374
375 ;;; FIXME: It appears that PSEUDO-ATOMIC is used to wrap operations which leave
376 ;;; untagged memory lying around, but some documentation would be nice.
377 (defmacro pseudo-atomic (&rest forms)
378   (let ((label (gensym "LABEL-")))
379     `(let ((,label (gen-label)))
380        (when *enable-pseudo-atomic*
381          ;; FIXME: The MAKE-EA noise should become a MACROLET macro or
382          ;; something. (perhaps SVLB, for static variable low byte)
383          (inst mov (make-ea :byte :disp (+ nil-value
384                                            (static-symbol-offset
385                                             '*pseudo-atomic-interrupted*)
386                                            (ash symbol-value-slot word-shift)
387                                            ;; FIXME: Use mask, not minus, to
388                                            ;; take out type bits.
389                                            (- other-pointer-type)))
390                0)
391          (inst mov (make-ea :byte :disp (+ nil-value
392                                            (static-symbol-offset
393                                             '*pseudo-atomic-atomic*)
394                                            (ash symbol-value-slot word-shift)
395                                            (- other-pointer-type)))
396                (fixnumize 1)))
397        ,@forms
398        (when *enable-pseudo-atomic*
399          (inst mov (make-ea :byte :disp (+ nil-value
400                                            (static-symbol-offset
401                                             '*pseudo-atomic-atomic*)
402                                            (ash symbol-value-slot word-shift)
403                                            (- other-pointer-type)))
404                0)
405          ;; KLUDGE: Is there any requirement for interrupts to be
406          ;; handled in order? It seems as though an interrupt coming
407          ;; in at this point will be executed before any pending interrupts.
408          ;; Or do incoming interrupts check to see whether any interrupts
409          ;; are pending? I wish I could find the documentation for
410          ;; pseudo-atomics.. -- WHN 19991130
411          (inst cmp (make-ea :byte
412                             :disp (+ nil-value
413                                      (static-symbol-offset
414                                       '*pseudo-atomic-interrupted*)
415                                      (ash symbol-value-slot word-shift)
416                                      (- other-pointer-type)))
417                0)
418          (inst jmp :eq ,label)
419          (inst break pending-interrupt-trap)
420          (emit-label ,label)))))
421 \f
422 ;;;; indexed references
423
424 (defmacro define-full-reffer (name type offset lowtag scs el-type &optional translate)
425   `(progn
426      (define-vop (,name)
427        ,@(when translate
428            `((:translate ,translate)))
429        (:policy :fast-safe)
430        (:args (object :scs (descriptor-reg))
431               (index :scs (any-reg)))
432        (:arg-types ,type tagged-num)
433        (:results (value :scs ,scs))
434        (:result-types ,el-type)
435        (:generator 3                    ; pw was 5
436          (inst mov value (make-ea :dword :base object :index index
437                                   :disp (- (* ,offset word-bytes) ,lowtag)))))
438      (define-vop (,(symbolicate name "-C"))
439        ,@(when translate
440            `((:translate ,translate)))
441        (:policy :fast-safe)
442        (:args (object :scs (descriptor-reg)))
443        (:info index)
444        (:arg-types ,type (:constant (signed-byte 30)))
445        (:results (value :scs ,scs))
446        (:result-types ,el-type)
447        (:generator 2                    ; pw was 5
448          (inst mov value (make-ea :dword :base object
449                                   :disp (- (* (+ ,offset index) word-bytes)
450                                            ,lowtag)))))))
451
452 (defmacro define-full-setter (name type offset lowtag scs el-type &optional translate)
453   `(progn
454      (define-vop (,name)
455        ,@(when translate
456            `((:translate ,translate)))
457        (:policy :fast-safe)
458        (:args (object :scs (descriptor-reg))
459               (index :scs (any-reg))
460               (value :scs ,scs :target result))
461        (:arg-types ,type tagged-num ,el-type)
462        (:results (result :scs ,scs))
463        (:result-types ,el-type)
464        (:generator 4                    ; was 5
465          (inst mov (make-ea :dword :base object :index index
466                             :disp (- (* ,offset word-bytes) ,lowtag))
467                value)
468          (move result value)))
469      (define-vop (,(symbolicate name "-C"))
470        ,@(when translate
471            `((:translate ,translate)))
472        (:policy :fast-safe)
473        (:args (object :scs (descriptor-reg))
474               (value :scs ,scs :target result))
475        (:info index)
476        (:arg-types ,type (:constant (signed-byte 30)) ,el-type)
477        (:results (result :scs ,scs))
478        (:result-types ,el-type)
479        (:generator 3                    ; was 5
480          (inst mov (make-ea :dword :base object
481                             :disp (- (* (+ ,offset index) word-bytes) ,lowtag))
482                value)
483          (move result value)))))
484