0.pre7.20:
[sbcl.git] / src / compiler / x86 / vm.lisp
1 ;;;; miscellaneous VM definition noise 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 ;;; the size of an INTEGER representation of a SYSTEM-AREA-POINTER, i.e.
15 ;;; size of a native memory address
16 (deftype sap-int-type () '(unsigned-byte 32))
17 ;;; FIXME: This should just named be SAP-INT, not SAP-INT-TYPE. And
18 ;;; grep for SAPINT in the code and replace it with SAP-INT as
19 ;;; appropriate.
20 \f
21 ;;;; register specs
22
23 (eval-when (:compile-toplevel :load-toplevel :execute)
24   (defvar *byte-register-names* (make-array 8 :initial-element nil))
25   (defvar *word-register-names* (make-array 16 :initial-element nil))
26   (defvar *dword-register-names* (make-array 16 :initial-element nil))
27   (defvar *float-register-names* (make-array 8 :initial-element nil)))
28
29 (macrolet ((defreg (name offset size)
30              (let ((offset-sym (symbolicate name "-OFFSET"))
31                    (names-vector (symbolicate "*" size "-REGISTER-NAMES*")))
32                `(progn
33                   (eval-when (:compile-toplevel :load-toplevel :execute)
34                     ;; EVAL-WHEN is necessary because stuff like #.EAX-OFFSET
35                     ;; (in the same file) depends on compile-time evaluation
36                     ;; of the DEFCONSTANT. -- AL 20010224
37                     (defconstant ,offset-sym ,offset))
38                   (setf (svref ,names-vector ,offset-sym)
39                         ,(symbol-name name)))))
40            ;; FIXME: It looks to me as though DEFREGSET should also
41            ;; define the related *FOO-REGISTER-NAMES* variable.
42            (defregset (name &rest regs)
43              `(eval-when (:compile-toplevel :load-toplevel :execute)
44                 (defparameter ,name
45                   (list ,@(mapcar (lambda (name)
46                                     (symbolicate name "-OFFSET"))
47                                   regs))))))
48
49   ;; byte registers
50   ;;
51   ;; Note: the encoding here is different than that used by the chip.
52   ;; We use this encoding so that the compiler thinks that AX (and
53   ;; EAX) overlap AL and AH instead of AL and CL.
54   (defreg al 0 :byte)
55   (defreg ah 1 :byte)
56   (defreg cl 2 :byte)
57   (defreg ch 3 :byte)
58   (defreg dl 4 :byte)
59   (defreg dh 5 :byte)
60   (defreg bl 6 :byte)
61   (defreg bh 7 :byte)
62   (defregset *byte-regs* al ah cl ch dl dh bl bh)
63
64   ;; word registers
65   (defreg ax 0 :word)
66   (defreg cx 2 :word)
67   (defreg dx 4 :word)
68   (defreg bx 6 :word)
69   (defreg sp 8 :word)
70   (defreg bp 10 :word)
71   (defreg si 12 :word)
72   (defreg di 14 :word)
73   (defregset *word-regs* ax cx dx bx si di)
74
75   ;; double word registers
76   (defreg eax 0 :dword)
77   (defreg ecx 2 :dword)
78   (defreg edx 4 :dword)
79   (defreg ebx 6 :dword)
80   (defreg esp 8 :dword)
81   (defreg ebp 10 :dword)
82   (defreg esi 12 :dword)
83   (defreg edi 14 :dword)
84   (defregset *dword-regs* eax ecx edx ebx esi edi)
85
86   ;; floating point registers
87   (defreg fr0 0 :float)
88   (defreg fr1 1 :float)
89   (defreg fr2 2 :float)
90   (defreg fr3 3 :float)
91   (defreg fr4 4 :float)
92   (defreg fr5 5 :float)
93   (defreg fr6 6 :float)
94   (defreg fr7 7 :float)
95   (defregset *float-regs* fr0 fr1 fr2 fr3 fr4 fr5 fr6 fr7)
96
97   ;; registers used to pass arguments
98   ;;
99   ;; the number of arguments/return values passed in registers
100   (defconstant  register-arg-count 3)
101   ;; names and offsets for registers used to pass arguments
102   (eval-when (:compile-toplevel :load-toplevel :execute)
103     (defparameter *register-arg-names* '(edx edi esi)))
104   (defregset    *register-arg-offsets* edx edi esi))
105 \f
106 ;;;; SB definitions
107
108 ;;; Despite the fact that there are only 8 different registers, we consider
109 ;;; them 16 in order to describe the overlap of byte registers. The only
110 ;;; thing we need to represent is what registers overlap. Therefore, we
111 ;;; consider bytes to take one unit, and words or dwords to take two. We
112 ;;; don't need to tell the difference between words and dwords, because
113 ;;; you can't put two words in a dword register.
114 (define-storage-base registers :finite :size 16)
115
116 ;;; jrd changed this from size 1 to size 8. It doesn't seem to make much
117 ;;; sense to use the 387's idea of a stack; 8 separate registers is easier
118 ;;; to deal with.
119 ;;; the old way:
120 ;;;   (define-storage-base float-registers :finite :size 1)
121 ;;; the new way:
122 (define-storage-base float-registers :finite :size 8)
123
124 (define-storage-base stack :unbounded :size 8)
125 (define-storage-base constant :non-packed)
126 (define-storage-base immediate-constant :non-packed)
127 (define-storage-base noise :unbounded :size 2)
128 \f
129 ;;;; SC definitions
130
131 ;;; a handy macro so we don't have to keep changing all the numbers whenever
132 ;;; we insert a new storage class
133 ;;;
134 ;;; FIXME: This macro is not needed in the runtime target.
135 (defmacro define-storage-classes (&rest classes)
136   (collect ((forms))
137     (let ((index 0))
138       (dolist (class classes)
139         (let* ((sc-name (car class))
140                (constant-name (symbolicate sc-name "-SC-NUMBER")))
141           (forms `(define-storage-class ,sc-name ,index
142                     ,@(cdr class)))
143           (forms `(defconstant ,constant-name ,index))
144           (incf index))))
145     `(progn
146        ,@(forms))))
147
148 ;;; The DEFINE-STORAGE-CLASS call for CATCH-BLOCK refers to the size
149 ;;; of CATCH-BLOCK. The size of CATCH-BLOCK isn't calculated until
150 ;;; later in the build process, and the calculation is entangled with
151 ;;; code which has lots of predependencies, including dependencies on
152 ;;; the prior call of DEFINE-STORAGE-CLASS. The proper way to
153 ;;; unscramble this would be to untangle the code, so that the code
154 ;;; which calculates the size of CATCH-BLOCK can be separated from the
155 ;;; other lots-of-dependencies code, so that the code which calculates
156 ;;; the size of CATCH-BLOCK can be executed early, so that this value
157 ;;; is known properly at this point in compilation. However, that
158 ;;; would be a lot of editing of code that I (WHN 19990131) can't test
159 ;;; until the project is complete. So instead, I set the correct value
160 ;;; by hand here (a sort of nondeterministic guess of the right
161 ;;; answer:-) and add an assertion later, after the value is
162 ;;; calculated, that the original guess was correct.
163 ;;;
164 ;;; (What a KLUDGE! Anyone who wants to come in and clean up this mess
165 ;;; has my gratitude.) (FIXME: Maybe this should be me..)
166 (defconstant sb!vm::kludge-nondeterministic-catch-block-size 6)
167
168 (define-storage-classes
169
170   ;; non-immediate contstants in the constant pool
171   (constant constant)
172
173   ;; some FP constants can be generated in the i387 silicon
174   (fp-constant immediate-constant)
175
176   (immediate immediate-constant)
177
178   ;;
179   ;; the stacks
180   ;;
181   
182   ;; the control stack
183   (control-stack stack)                 ; may be pointers, scanned by GC
184
185   ;; the non-descriptor stacks
186   (signed-stack stack)                  ; (signed-byte 32)
187   (unsigned-stack stack)                ; (unsigned-byte 32)
188   (base-char-stack stack)               ; non-descriptor characters.
189   (sap-stack stack)                     ; System area pointers.
190   (single-stack stack)                  ; single-floats
191   (double-stack stack :element-size 2)  ; double-floats.
192   #!+long-float
193   (long-stack stack :element-size 3)    ; long-floats.
194   (complex-single-stack stack :element-size 2)  ; complex-single-floats
195   (complex-double-stack stack :element-size 4)  ; complex-double-floats
196   #!+long-float
197   (complex-long-stack stack :element-size 6)    ; complex-long-floats
198
199   ;;
200   ;; magic SCs
201   ;;
202
203   (ignore-me noise)
204
205   ;;
206   ;; things that can go in the integer registers
207   ;;
208
209   ;; On the X86, we don't have to distinguish between descriptor and
210   ;; non-descriptor registers, because of the conservative GC.
211   ;; Therefore, we use different scs only to distinguish between
212   ;; descriptor and non-descriptor values and to specify size.
213
214   ;; immediate descriptor objects. Don't have to be seen by GC, but nothing
215   ;; bad will happen if they are. (fixnums, characters, header values, etc).
216   (any-reg registers
217            :locations #.*dword-regs*
218            :element-size 2
219 ;          :reserve-locations (#.eax-offset)
220            :constant-scs (immediate)
221            :save-p t
222            :alternate-scs (control-stack))
223
224   ;; pointer descriptor objects -- must be seen by GC
225   (descriptor-reg registers
226                   :locations #.*dword-regs*
227                   :element-size 2
228 ;                 :reserve-locations (#.eax-offset)
229                   :constant-scs (constant immediate)
230                   :save-p t
231                   :alternate-scs (control-stack))
232
233   ;; non-descriptor characters
234   (base-char-reg registers
235                  :locations #.*byte-regs*
236                  :reserve-locations (#.ah-offset #.al-offset)
237                  :constant-scs (immediate)
238                  :save-p t
239                  :alternate-scs (base-char-stack))
240
241   ;; non-descriptor SAPs (arbitrary pointers into address space)
242   (sap-reg registers
243            :locations #.*dword-regs*
244            :element-size 2
245 ;          :reserve-locations (#.eax-offset)
246            :constant-scs (immediate)
247            :save-p t
248            :alternate-scs (sap-stack))
249
250   ;; non-descriptor (signed or unsigned) numbers
251   (signed-reg registers
252               :locations #.*dword-regs*
253               :element-size 2
254 ;             :reserve-locations (#.eax-offset)
255               :constant-scs (immediate)
256               :save-p t
257               :alternate-scs (signed-stack))
258   (unsigned-reg registers
259                 :locations #.*dword-regs*
260                 :element-size 2
261 ;               :reserve-locations (#.eax-offset)
262                 :constant-scs (immediate)
263                 :save-p t
264                 :alternate-scs (unsigned-stack))
265
266   ;; miscellaneous objects that must not be seen by GC. Used only as
267   ;; temporaries.
268   (word-reg registers
269             :locations #.*word-regs*
270             :element-size 2
271 ;           :reserve-locations (#.ax-offset)
272             )
273   (byte-reg registers
274             :locations #.*byte-regs*
275 ;           :reserve-locations (#.al-offset #.ah-offset)
276             )
277
278   ;; that can go in the floating point registers
279
280   ;; non-descriptor SINGLE-FLOATs
281   (single-reg float-registers
282               :locations (0 1 2 3 4 5 6 7)
283               :constant-scs (fp-constant)
284               :save-p t
285               :alternate-scs (single-stack))
286
287   ;; non-descriptor DOUBLE-FLOATs
288   (double-reg float-registers
289               :locations (0 1 2 3 4 5 6 7)
290               :constant-scs (fp-constant)
291               :save-p t
292               :alternate-scs (double-stack))
293
294   ;; non-descriptor LONG-FLOATs
295   #!+long-float
296   (long-reg float-registers
297             :locations (0 1 2 3 4 5 6 7)
298             :constant-scs (fp-constant)
299             :save-p t
300             :alternate-scs (long-stack))
301
302   (complex-single-reg float-registers
303                       :locations (0 2 4 6)
304                       :element-size 2
305                       :constant-scs ()
306                       :save-p t
307                       :alternate-scs (complex-single-stack))
308
309   (complex-double-reg float-registers
310                       :locations (0 2 4 6)
311                       :element-size 2
312                       :constant-scs ()
313                       :save-p t
314                       :alternate-scs (complex-double-stack))
315
316   #!+long-float
317   (complex-long-reg float-registers
318                     :locations (0 2 4 6)
319                     :element-size 2
320                     :constant-scs ()
321                     :save-p t
322                     :alternate-scs (complex-long-stack))
323
324   ;; a catch or unwind block
325   (catch-block stack
326                :element-size sb!vm::kludge-nondeterministic-catch-block-size))
327
328 (eval-when (:compile-toplevel :load-toplevel :execute)
329 (defparameter *byte-sc-names* '(base-char-reg byte-reg base-char-stack))
330 (defparameter *word-sc-names* '(word-reg))
331 (defparameter *dword-sc-names*
332   '(any-reg descriptor-reg sap-reg signed-reg unsigned-reg control-stack
333     signed-stack unsigned-stack sap-stack single-stack constant))
334 ;;; added by jrd. I guess the right thing to do is to treat floats
335 ;;; as a separate size...
336 ;;;
337 ;;; These are used to (at least) determine operand size.
338 (defparameter *float-sc-names* '(single-reg))
339 (defparameter *double-sc-names* '(double-reg double-stack))
340 ) ; EVAL-WHEN
341 \f
342 ;;;; miscellaneous TNs for the various registers
343
344 (macrolet ((def-misc-reg-tns (sc-name &rest reg-names)
345              (collect ((forms))
346                       (dolist (reg-name reg-names)
347                         (let ((tn-name (symbolicate reg-name "-TN"))
348                               (offset-name (symbolicate reg-name "-OFFSET")))
349                           ;; FIXME: It'd be good to have the special
350                           ;; variables here be named with the *FOO*
351                           ;; convention.
352                           (forms `(defparameter ,tn-name
353                                     (make-random-tn :kind :normal
354                                                     :sc (sc-or-lose ',sc-name)
355                                                     :offset
356                                                     ,offset-name)))))
357                       `(progn ,@(forms)))))
358
359   (def-misc-reg-tns unsigned-reg eax ebx ecx edx ebp esp edi esi)
360   (def-misc-reg-tns word-reg ax bx cx dx bp sp di si)
361   (def-misc-reg-tns byte-reg al ah bl bh cl ch dl dh)
362   (def-misc-reg-tns single-reg fr0 fr1 fr2 fr3 fr4 fr5 fr6 fr7))
363
364 ;;; TNs for registers used to pass arguments
365 (defparameter *register-arg-tns*
366   (mapcar (lambda (register-arg-name)
367             (symbol-value (symbolicate register-arg-name "-TN")))
368           *register-arg-names*))
369
370 ;;; FIXME: doesn't seem to be used in SBCL
371 #|
372 ;;; added by pw
373 (defparameter fp-constant-tn
374   (make-random-tn :kind :normal
375                   :sc (sc-or-lose 'fp-constant)
376                   :offset 31))          ; Offset doesn't get used.
377 |#
378 \f
379 ;;; If value can be represented as an immediate constant, then return
380 ;;; the appropriate SC number, otherwise return NIL.
381 (!def-vm-support-routine immediate-constant-sc (value)
382   (typecase value
383     ((or fixnum #-sb-xc-host system-area-pointer character)
384      (sc-number-or-lose 'immediate))
385     (symbol
386      (when (static-symbol-p value)
387        (sc-number-or-lose 'immediate)))
388     (single-float
389      (when (or (eql value 0f0) (eql value 1f0))
390        (sc-number-or-lose 'fp-constant)))
391     (double-float
392      (when (or (eql value 0d0) (eql value 1d0))
393        (sc-number-or-lose 'fp-constant)))
394     #!+long-float
395     (long-float
396      (when (or (eql value 0l0) (eql value 1l0)
397                (eql value pi)
398                (eql value (log 10l0 2l0))
399                (eql value (log 2.718281828459045235360287471352662L0 2l0))
400                (eql value (log 2l0 10l0))
401                (eql value (log 2l0 2.718281828459045235360287471352662L0)))
402        (sc-number-or-lose 'fp-constant)))))
403 \f
404 ;;;; miscellaneous function call parameters
405
406 ;;; offsets of special stack frame locations
407 (defconstant ocfp-save-offset 0)
408 (defconstant return-pc-save-offset 1)
409 (defconstant code-save-offset 2)
410
411 ;;; FIXME: This is a bad comment (changed since when?) and there are others
412 ;;; like it in this file. It'd be nice to clarify them. Failing that deleting
413 ;;; them or flagging them with KLUDGE might be better than nothing.
414 ;;;
415 ;;; names of these things seem to have changed. these aliases by jrd
416 (defconstant lra-save-offset return-pc-save-offset)
417
418 (defconstant cfp-offset ebp-offset)     ; pfw - needed by stuff in /code
419                                         ; related to signal context stuff
420
421 ;;; This is used by the debugger.
422 (defconstant single-value-return-byte-offset 2)
423 \f
424 ;;; This function is called by debug output routines that want a pretty name
425 ;;; for a TN's location. It returns a thing that can be printed with PRINC.
426 (!def-vm-support-routine location-print-name (tn)
427   (declare (type tn tn))
428   (let* ((sc (tn-sc tn))
429          (sb (sb-name (sc-sb sc)))
430          (offset (tn-offset tn)))
431     (ecase sb
432       (registers
433        (let* ((sc-name (sc-name sc))
434               (name-vec (cond ((member sc-name *byte-sc-names*)
435                                *byte-register-names*)
436                               ((member sc-name *word-sc-names*)
437                                *word-register-names*)
438                               ((member sc-name *dword-sc-names*)
439                                *dword-register-names*))))
440          (or (and name-vec
441                   (< -1 offset (length name-vec))
442                   (svref name-vec offset))
443              ;; FIXME: Shouldn't this be an ERROR?
444              (format nil "<unknown reg: off=~D, sc=~A>" offset sc-name))))
445       (float-registers (format nil "FR~D" offset))
446       (stack (format nil "S~D" offset))
447       (constant (format nil "Const~D" offset))
448       (immediate-constant "Immed")
449       (noise (symbol-name (sc-name sc))))))
450 ;;; FIXME: Could this, and everything that uses it, be made #!+SB-SHOW?
451 \f
452 ;;; The loader uses this to convert alien names to the form they need in
453 ;;; the symbol table (for example, prepending an underscore).
454 (defun extern-alien-name (name)
455   (declare (type simple-string name))
456   ;; On the X86 we don't do anything.
457   name)