src/compiler/x86-64/vm.lisp

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