1 ;;;; miscellaneous VM definition noise 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.
16 (defconstant-eqx +byte-register-names
+
17 #("AL" "AH" "CL" "CH" "DL" "DH" "BL" "BH")
19 (defconstant-eqx +word-register-names
+
20 #("AX" NIL
"CX" NIL
"DX" NIL
"BX" NIL
"SP" NIL
"BP" NIL
"SI" NIL
"DI" NIL
)
22 (defconstant-eqx +dword-register-names
+
23 #("EAX" NIL
"ECX" NIL
"EDX" NIL
"EBX" NIL
"ESP" NIL
"EBP" NIL
"ESI" NIL
"EDI" NIL
)
26 (macrolet ((defreg (name offset size
)
27 (declare (ignore size
))
28 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
29 ;; EVAL-WHEN is necessary because stuff like #.EAX-OFFSET
30 ;; (in the same file) depends on compile-time evaluation
31 ;; of the DEFCONSTANT. -- AL 20010224
32 (defconstant ,(symbolicate name
"-OFFSET") ,offset
)))
33 ;; FIXME: It looks to me as though DEFREGSET should also
34 ;; define the related *FOO-REGISTER-NAMES* variable.
35 (defregset (name &rest regs
)
36 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
38 (list ,@(mapcar (lambda (name)
39 (symbolicate name
"-OFFSET"))
44 ;; Note: the encoding here is different than that used by the chip.
45 ;; We use this encoding so that the compiler thinks that AX (and
46 ;; EAX) overlap AL and AH instead of AL and CL.
55 (defregset *byte-regs
* al ah cl ch dl dh bl bh
)
66 (defregset *word-regs
* ax cx dx bx si di
)
68 ;; double word registers
74 (defreg ebp
10 :dword
)
75 (defreg esi
12 :dword
)
76 (defreg edi
14 :dword
)
77 (defregset *dword-regs
* eax ecx edx ebx esi edi
)
79 ;; floating point registers
88 (defregset *float-regs
* fr0 fr1 fr2 fr3 fr4 fr5 fr6 fr7
)
90 ;; registers used to pass arguments
92 ;; the number of arguments/return values passed in registers
93 (defconstant register-arg-count
3)
94 ;; names and offsets for registers used to pass arguments
95 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
96 (defparameter *register-arg-names
* '(edx edi esi
)))
97 (defregset *register-arg-offsets
* edx edi esi
))
101 (!define-storage-bases
102 ;;; Despite the fact that there are only 8 different registers, we consider
103 ;;; them 16 in order to describe the overlap of byte registers. The only
104 ;;; thing we need to represent is what registers overlap. Therefore, we
105 ;;; consider bytes to take one unit, and words or dwords to take two. We
106 ;;; don't need to tell the difference between words and dwords, because
107 ;;; you can't put two words in a dword register.
108 (define-storage-base registers
:finite
:size
16)
110 ;;; jrd changed this from size 1 to size 8. It doesn't seem to make much
111 ;;; sense to use the 387's idea of a stack; 8 separate registers is easier
114 ;;; (define-storage-base float-registers :finite :size 1)
116 (define-storage-base float-registers
:finite
:size
8)
118 (define-storage-base stack
:unbounded
:size
3 :size-increment
1)
119 (define-storage-base constant
:non-packed
)
120 (define-storage-base immediate-constant
:non-packed
)
121 (define-storage-base noise
:unbounded
:size
2)
126 (!define-storage-classes
128 ;; non-immediate constants in the constant pool
131 ;; some FP constants can be generated in the i387 silicon
132 (fp-constant immediate-constant
)
133 (fp-single-immediate immediate-constant
)
134 (fp-double-immediate immediate-constant
)
135 (immediate immediate-constant
)
142 (control-stack stack
) ; may be pointers, scanned by GC
144 ;; the non-descriptor stacks
145 (signed-stack stack
) ; (signed-byte 32)
146 (unsigned-stack stack
) ; (unsigned-byte 32)
147 (character-stack stack
) ; non-descriptor characters.
148 (sap-stack stack
) ; System area pointers.
149 (single-stack stack
) ; single-floats
150 (double-stack stack
:element-size
2) ; double-floats.
152 (long-stack stack
:element-size
3) ; long-floats.
153 (complex-single-stack stack
:element-size
2) ; complex-single-floats
154 (complex-double-stack stack
:element-size
4) ; complex-double-floats
156 (complex-long-stack stack
:element-size
6) ; complex-long-floats
165 ;; things that can go in the integer registers
168 ;; On the X86, we don't have to distinguish between descriptor and
169 ;; non-descriptor registers, because of the conservative GC.
170 ;; Therefore, we use different scs only to distinguish between
171 ;; descriptor and non-descriptor values and to specify size.
173 ;; immediate descriptor objects. Don't have to be seen by GC, but nothing
174 ;; bad will happen if they are. (fixnums, characters, header values, etc).
176 :locations
#.
*dword-regs
*
178 ; :reserve-locations (#.eax-offset)
179 :constant-scs
(immediate)
181 :alternate-scs
(control-stack))
183 ;; pointer descriptor objects -- must be seen by GC
184 (descriptor-reg registers
185 :locations
#.
*dword-regs
*
187 ; :reserve-locations (#.eax-offset)
188 :constant-scs
(constant immediate
)
190 :alternate-scs
(control-stack))
192 ;; non-descriptor characters
193 (character-reg registers
194 :locations
#!-sb-unicode
#.
*byte-regs
*
195 #!+sb-unicode
#.
*dword-regs
*
196 #!+sb-unicode
#!+sb-unicode
198 #!-sb-unicode
#!-sb-unicode
199 :reserve-locations
(#.ah-offset
#.al-offset
)
200 :constant-scs
(immediate)
202 :alternate-scs
(character-stack))
204 ;; non-descriptor SAPs (arbitrary pointers into address space)
206 :locations
#.
*dword-regs
*
208 ; :reserve-locations (#.eax-offset)
209 :constant-scs
(immediate)
211 :alternate-scs
(sap-stack))
213 ;; non-descriptor (signed or unsigned) numbers
214 (signed-reg registers
215 :locations
#.
*dword-regs
*
217 ; :reserve-locations (#.eax-offset)
218 :constant-scs
(immediate)
220 :alternate-scs
(signed-stack))
221 (unsigned-reg registers
222 :locations
#.
*dword-regs
*
224 ; :reserve-locations (#.eax-offset)
225 :constant-scs
(immediate)
227 :alternate-scs
(unsigned-stack))
229 ;; miscellaneous objects that must not be seen by GC. Used only as
232 :locations
#.
*word-regs
*
234 ; :reserve-locations (#.ax-offset)
237 :locations
#.
*byte-regs
*
238 ; :reserve-locations (#.al-offset #.ah-offset)
241 ;; that can go in the floating point registers
243 ;; non-descriptor SINGLE-FLOATs
244 (single-reg float-registers
245 :locations
(0 1 2 3 4 5 6 7)
246 :constant-scs
(fp-constant fp-single-immediate
)
248 :alternate-scs
(single-stack))
250 ;; non-descriptor DOUBLE-FLOATs
251 (double-reg float-registers
252 :locations
(0 1 2 3 4 5 6 7)
253 :constant-scs
(fp-constant fp-double-immediate
)
255 :alternate-scs
(double-stack))
257 ;; non-descriptor LONG-FLOATs
259 (long-reg float-registers
260 :locations
(0 1 2 3 4 5 6 7)
261 :constant-scs
(fp-constant)
263 :alternate-scs
(long-stack))
265 (complex-single-reg float-registers
270 :alternate-scs
(complex-single-stack))
272 (complex-double-reg float-registers
277 :alternate-scs
(complex-double-stack))
280 (complex-long-reg float-registers
285 :alternate-scs
(complex-long-stack))
287 (catch-block stack
:element-size catch-block-size
)
288 (unwind-block stack
:element-size unwind-block-size
))
290 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
291 (defparameter *byte-sc-names
*
292 '(#!-sb-unicode character-reg byte-reg
#!-sb-unicode character-stack
))
293 (defparameter *word-sc-names
* '(word-reg))
294 (defparameter *dword-sc-names
*
295 '(any-reg descriptor-reg sap-reg signed-reg unsigned-reg control-stack
296 signed-stack unsigned-stack sap-stack single-stack
297 #!+sb-unicode character-reg
#!+sb-unicode character-stack constant
))
298 ;;; added by jrd. I guess the right thing to do is to treat floats
299 ;;; as a separate size...
301 ;;; These are used to (at least) determine operand size.
302 (defparameter *float-sc-names
* '(single-reg))
303 (defparameter *double-sc-names
* '(double-reg double-stack
))
306 ;;;; miscellaneous TNs for the various registers
308 (macrolet ((def-misc-reg-tns (sc-name &rest reg-names
)
310 (dolist (reg-name reg-names
)
311 (let ((tn-name (symbolicate reg-name
"-TN"))
312 (offset-name (symbolicate reg-name
"-OFFSET")))
313 ;; FIXME: It'd be good to have the special
314 ;; variables here be named with the *FOO*
316 (forms `(defparameter ,tn-name
317 (make-random-tn :kind
:normal
318 :sc
(sc-or-lose ',sc-name
)
321 `(progn ,@(forms)))))
323 (def-misc-reg-tns unsigned-reg eax ebx ecx edx ebp esp edi esi
)
324 (def-misc-reg-tns word-reg ax bx cx dx bp sp di si
)
325 (def-misc-reg-tns byte-reg al ah bl bh cl ch dl dh
)
326 (def-misc-reg-tns single-reg fr0 fr1 fr2 fr3 fr4 fr5 fr6 fr7
))
328 ;;; TNs for registers used to pass arguments
329 (defparameter *register-arg-tns
*
330 (mapcar (lambda (register-arg-name)
331 (symbol-value (symbolicate register-arg-name
"-TN")))
332 *register-arg-names
*))
334 ;;; FIXME: doesn't seem to be used in SBCL
337 (defparameter fp-constant-tn
338 (make-random-tn :kind
:normal
339 :sc
(sc-or-lose 'fp-constant
)
340 :offset
31)) ; Offset doesn't get used.
343 ;;; If value can be represented as an immediate constant, then return
344 ;;; the appropriate SC number, otherwise return NIL.
345 (defun immediate-constant-sc (value)
347 ((or (integer #.sb
!xc
:most-negative-fixnum
#.sb
!xc
:most-positive-fixnum
)
349 (sc-number-or-lose 'immediate
))
351 (when (static-symbol-p value
)
352 (sc-number-or-lose 'immediate
)))
355 ((0f0 1f0
) (sc-number-or-lose 'fp-constant
))
356 (t (sc-number-or-lose 'fp-single-immediate
))))
359 ((0d0 1d0
) (sc-number-or-lose 'fp-constant
))
360 (t (sc-number-or-lose 'fp-double-immediate
))))
363 (when (or (eql value
0l0) (eql value
1l0)
365 (eql value
(log 10l0 2l0))
366 (eql value
(log 2.718281828459045235360287471352662L0 2l0))
367 (eql value
(log 2l0 10l0))
368 (eql value
(log 2l0 2.718281828459045235360287471352662L0)))
369 (sc-number-or-lose 'fp-constant
)))))
371 (defun boxed-immediate-sc-p (sc)
372 (eql sc
(sc-number-or-lose 'immediate
)))
374 ;; For an immediate TN, return its value encoded for use as a literal.
375 ;; For any other TN, return the TN. Only works for FIXNUMs,
376 ;; STATIC-SYMBOLs, and CHARACTERS (FLOATs and SAPs are handled
378 (defun encode-value-if-immediate (tn)
379 (if (sc-is tn immediate
)
380 (let ((val (tn-value tn
)))
382 (integer (fixnumize val
))
383 (symbol (+ nil-value
(static-symbol-offset val
)))
384 (character (logior (ash (char-code val
) n-widetag-bits
)
385 character-widetag
))))
388 ;;;; miscellaneous function call parameters
390 ;;; Offsets of special stack frame locations relative to EBP.
392 ;;; Consider the standard prologue PUSH EBP; MOV EBP, ESP: the return
393 ;;; address is at EBP+4, the old control stack frame pointer is at
394 ;;; EBP, the magic 3rd slot is at EBP-4. Then come the locals from
396 (defconstant return-pc-save-offset
0)
397 (defconstant ocfp-save-offset
1)
398 ;;; Let SP be the stack pointer before CALLing, and FP is the frame
399 ;;; pointer after the standard prologue. SP +
400 ;;; FRAME-WORD-OFFSET(SP->FP-OFFSET + I) = FP + FRAME-WORD-OFFSET(I).
401 (defconstant sp-
>fp-offset
2)
403 (declaim (inline frame-word-offset
))
404 (defun frame-word-offset (index)
407 (declaim (inline frame-byte-offset
))
408 (defun frame-byte-offset (index)
409 (* (frame-word-offset index
) n-word-bytes
))
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.
415 ;;; names of these things seem to have changed. these aliases by jrd
416 (defconstant lra-save-offset return-pc-save-offset
)
418 (defconstant cfp-offset ebp-offset
) ; pfw - needed by stuff in /code
419 ; related to signal context stuff
421 ;;; This is used by the debugger.
422 (defconstant single-value-return-byte-offset
2)
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 (defun 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
)))
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
+))))
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=~W, 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
))))))
451 (defun combination-implementation-style (node)
452 (declare (type sb
!c
::combination node
))
453 (flet ((valid-funtype (args result
)
454 (sb!c
::valid-fun-use node
455 (sb!c
::specifier-type
456 `(function ,args
,result
)))))
457 (case (sb!c
::combination-fun-source-name node
)
460 ((valid-funtype '(fixnum fixnum
) '*)
462 ((valid-funtype '((signed-byte 32) (signed-byte 32)) '*)
464 ((valid-funtype '((unsigned-byte 32) (unsigned-byte 32)) '*)
466 (t (values :default nil
))))
469 ((and (valid-funtype '((integer 0 29) fixnum
) '*)
470 (sb!c
::constant-lvar-p
(first (sb!c
::basic-combination-args node
))))
471 (values :transform
'(lambda (index integer
)
472 (%logbitp integer index
))))
473 ((valid-funtype '((integer 0 31) (signed-byte 32)) '*)
474 (values :transform
'(lambda (index integer
)
475 (%logbitp integer index
))))
476 ((valid-funtype '((integer 0 31) (unsigned-byte 32)) '*)
477 (values :transform
'(lambda (index integer
)
478 (%logbitp integer index
))))
479 (t (values :default nil
))))
480 (t (values :default nil
)))))