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