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