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 () '(unsigned-byte 32))
  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 *float-register-names* (make-array 8 :initial-element nil)))
  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 :load-toplevel :execute)
  31                     ;; EVAL-WHEN is necessary because stuff like #.EAX-OFFSET
  32                     ;; (in the same file) depends on compile-time evaluation
  33                     ;; of the DEFCONSTANT. -- AL 20010224
  34                     (def!constant ,offset-sym ,offset))
  35                   (setf (svref ,names-vector ,offset-sym)
  36                         ,(symbol-name name)))))
  37            ;; FIXME: It looks to me as though DEFREGSET should also
  38            ;; define the related *FOO-REGISTER-NAMES* variable.
  39            (defregset (name &rest regs)
  40              `(eval-when (:compile-toplevel :load-toplevel :execute)
  41                 (defparameter ,name
  42                   (list ,@(mapcar (lambda (name)
  43                                     (symbolicate name "-OFFSET"))
  44                                   regs))))))
  45
  46   ;; byte registers
  47   ;;
  48   ;; Note: the encoding here is different than that used by the chip.
  49   ;; We use this encoding so that the compiler thinks that AX (and
  50   ;; EAX) overlap AL and AH instead of AL and CL.
  51   (defreg al 0 :byte)
  52   (defreg ah 1 :byte)
  53   (defreg cl 2 :byte)
  54   (defreg ch 3 :byte)
  55   (defreg dl 4 :byte)
  56   (defreg dh 5 :byte)
  57   (defreg bl 6 :byte)
  58   (defreg bh 7 :byte)
  59   (defregset *byte-regs* al ah cl ch dl dh bl bh)
  60
  61   ;; word registers
  62   (defreg ax 0 :word)
  63   (defreg cx 2 :word)
  64   (defreg dx 4 :word)
  65   (defreg bx 6 :word)
  66   (defreg sp 8 :word)
  67   (defreg bp 10 :word)
  68   (defreg si 12 :word)
  69   (defreg di 14 :word)
  70   (defregset *word-regs* ax cx dx bx si di)
  71
  72   ;; double word registers
  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   (defreg fr0 0 :float)
  85   (defreg fr1 1 :float)
  86   (defreg fr2 2 :float)
  87   (defreg fr3 3 :float)
  88   (defreg fr4 4 :float)
  89   (defreg fr5 5 :float)
  90   (defreg fr6 6 :float)
  91   (defreg fr7 7 :float)
  92   (defregset *float-regs* fr0 fr1 fr2 fr3 fr4 fr5 fr6 fr7)
  93
  94   ;; registers used to pass arguments
  95   ;;
  96   ;; the number of arguments/return values passed in registers
  97   (def!constant  register-arg-count 3)
  98   ;; names and offsets for registers used to pass arguments
  99   (eval-when (:compile-toplevel :load-toplevel :execute)
 100     (defparameter *register-arg-names* '(edx edi esi)))
 101   (defregset    *register-arg-offsets* edx edi esi))
 102 \f
 103 ;;;; SB definitions
 104
 105 ;;; Despite the fact that there are only 8 different registers, we consider
 106 ;;; them 16 in order to describe the overlap of byte registers. The only
 107 ;;; thing we need to represent is what registers overlap. Therefore, we
 108 ;;; consider bytes to take one unit, and words or dwords to take two. We
 109 ;;; don't need to tell the difference between words and dwords, because
 110 ;;; you can't put two words in a dword register.
 111 (define-storage-base registers :finite :size 16)
 112
 113 ;;; jrd changed this from size 1 to size 8. It doesn't seem to make much
 114 ;;; sense to use the 387's idea of a stack; 8 separate registers is easier
 115 ;;; to deal with.
 116 ;;; the old way:
 117 ;;;   (define-storage-base float-registers :finite :size 1)
 118 ;;; the new way:
 119 (define-storage-base float-registers :finite :size 8)
 120
 121 (define-storage-base stack :unbounded :size 8)
 122 (define-storage-base constant :non-packed)
 123 (define-storage-base immediate-constant :non-packed)
 124 (define-storage-base noise :unbounded :size 2)
 125 \f
 126 ;;;; SC definitions
 127
 128 ;;; a handy macro so we don't have to keep changing all the numbers whenever
 129 ;;; we insert a new storage class
 130 ;;;
 131 (defmacro !define-storage-classes (&rest classes)
 132   (collect ((forms))
 133     (let ((index 0))
 134       (dolist (class classes)
 135         (let* ((sc-name (car class))
 136                (constant-name (symbolicate sc-name "-SC-NUMBER")))
 137           (forms `(define-storage-class ,sc-name ,index
 138                     ,@(cdr class)))
 139           (forms `(def!constant ,constant-name ,index))
 140           (incf index))))
 141     `(progn
 142        ,@(forms))))
 143
 144 ;;; The DEFINE-STORAGE-CLASS call for CATCH-BLOCK refers to the size
 145 ;;; of CATCH-BLOCK. The size of CATCH-BLOCK isn't calculated until
 146 ;;; later in the build process, and the calculation is entangled with
 147 ;;; code which has lots of predependencies, including dependencies on
 148 ;;; the prior call of DEFINE-STORAGE-CLASS. The proper way to
 149 ;;; unscramble this would be to untangle the code, so that the code
 150 ;;; which calculates the size of CATCH-BLOCK can be separated from the
 151 ;;; other lots-of-dependencies code, so that the code which calculates
 152 ;;; the size of CATCH-BLOCK can be executed early, so that this value
 153 ;;; is known properly at this point in compilation. However, that
 154 ;;; would be a lot of editing of code that I (WHN 19990131) can't test
 155 ;;; until the project is complete. So instead, I set the correct value
 156 ;;; by hand here (a sort of nondeterministic guess of the right
 157 ;;; answer:-) and add an assertion later, after the value is
 158 ;;; calculated, that the original guess was correct.
 159 ;;;
 160 ;;; (What a KLUDGE! Anyone who wants to come in and clean up this mess
 161 ;;; has my gratitude.) (FIXME: Maybe this should be me..)
 162 (eval-when (:compile-toplevel :load-toplevel :execute)
 163   (def!constant kludge-nondeterministic-catch-block-size
 164       #!-win32 5 #!+win32 7))
 165
 166 (!define-storage-classes
 167
 168   ;; non-immediate constants in the constant pool
 169   (constant constant)
 170
 171   ;; some FP constants can be generated in the i387 silicon
 172   (fp-constant immediate-constant)
 173   (fp-single-immediate immediate-constant)
 174   (fp-double-immediate immediate-constant)
 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   (character-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   (character-reg registers
 234                  :locations #!-sb-unicode #.*byte-regs*
 235                             #!+sb-unicode #.*dword-regs*
 236                  #!+sb-unicode #!+sb-unicode
 237                  :element-size 2
 238                  #!-sb-unicode #!-sb-unicode
 239                  :reserve-locations (#.ah-offset #.al-offset)
 240                  :constant-scs (immediate)
 241                  :save-p t
 242                  :alternate-scs (character-stack))
 243
 244   ;; non-descriptor SAPs (arbitrary pointers into address space)
 245   (sap-reg registers
 246            :locations #.*dword-regs*
 247            :element-size 2
 248 ;          :reserve-locations (#.eax-offset)
 249            :constant-scs (immediate)
 250            :save-p t
 251            :alternate-scs (sap-stack))
 252
 253   ;; non-descriptor (signed or unsigned) numbers
 254   (signed-reg registers
 255               :locations #.*dword-regs*
 256               :element-size 2
 257 ;             :reserve-locations (#.eax-offset)
 258               :constant-scs (immediate)
 259               :save-p t
 260               :alternate-scs (signed-stack))
 261   (unsigned-reg registers
 262                 :locations #.*dword-regs*
 263                 :element-size 2
 264 ;               :reserve-locations (#.eax-offset)
 265                 :constant-scs (immediate)
 266                 :save-p t
 267                 :alternate-scs (unsigned-stack))
 268
 269   ;; miscellaneous objects that must not be seen by GC. Used only as
 270   ;; temporaries.
 271   (word-reg registers
 272             :locations #.*word-regs*
 273             :element-size 2
 274 ;           :reserve-locations (#.ax-offset)
 275             )
 276   (byte-reg registers
 277             :locations #.*byte-regs*
 278 ;           :reserve-locations (#.al-offset #.ah-offset)
 279             )
 280
 281   ;; that can go in the floating point registers
 282
 283   ;; non-descriptor SINGLE-FLOATs
 284   (single-reg float-registers
 285               :locations (0 1 2 3 4 5 6 7)
 286               :constant-scs (fp-constant fp-single-immediate)
 287               :save-p t
 288               :alternate-scs (single-stack))
 289
 290   ;; non-descriptor DOUBLE-FLOATs
 291   (double-reg float-registers
 292               :locations (0 1 2 3 4 5 6 7)
 293               :constant-scs (fp-constant fp-double-immediate)
 294               :save-p t
 295               :alternate-scs (double-stack))
 296
 297   ;; non-descriptor LONG-FLOATs
 298   #!+long-float
 299   (long-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 (long-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   #!+long-float
 320   (complex-long-reg float-registers
 321                     :locations (0 2 4 6)
 322                     :element-size 2
 323                     :constant-scs ()
 324                     :save-p t
 325                     :alternate-scs (complex-long-stack))
 326
 327   ;; a catch or unwind block
 328   (catch-block stack :element-size kludge-nondeterministic-catch-block-size))
 329
 330 (eval-when (:compile-toplevel :load-toplevel :execute)
 331 (defparameter *byte-sc-names*
 332   '(#!-sb-unicode character-reg byte-reg #!-sb-unicode character-stack))
 333 (defparameter *word-sc-names* '(word-reg))
 334 (defparameter *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
 337     #!+sb-unicode character-reg #!+sb-unicode character-stack constant))
 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 (defparameter *float-sc-names* '(single-reg))
 343 (defparameter *double-sc-names* '(double-reg double-stack))
 344 ) ; EVAL-WHEN
 345 \f
 346 ;;;; miscellaneous TNs for the various registers
 347
 348 (macrolet ((def-misc-reg-tns (sc-name &rest reg-names)
 349              (collect ((forms))
 350                       (dolist (reg-name reg-names)
 351                         (let ((tn-name (symbolicate reg-name "-TN"))
 352                               (offset-name (symbolicate reg-name "-OFFSET")))
 353                           ;; FIXME: It'd be good to have the special
 354                           ;; variables here be named with the *FOO*
 355                           ;; convention.
 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 ;;; If value can be represented as an immediate constant, then return
 384 ;;; the appropriate SC number, otherwise return NIL.
 385 (!def-vm-support-routine immediate-constant-sc (value)
 386   (typecase value
 387     ((or (integer #.sb!xc:most-negative-fixnum #.sb!xc:most-positive-fixnum)
 388          character)
 389      (sc-number-or-lose 'immediate))
 390     (symbol
 391      (when (static-symbol-p value)
 392        (sc-number-or-lose 'immediate)))
 393     (single-float
 394        (case value
 395          ((0f0 1f0) (sc-number-or-lose 'fp-constant))
 396          (t (sc-number-or-lose 'fp-single-immediate))))
 397     (double-float
 398        (case value
 399          ((0d0 1d0) (sc-number-or-lose 'fp-constant))
 400          (t (sc-number-or-lose 'fp-double-immediate))))
 401     #!+long-float
 402     (long-float
 403        (when (or (eql value 0l0) (eql value 1l0)
 404                  (eql value pi)
 405                  (eql value (log 10l0 2l0))
 406                  (eql value (log 2.718281828459045235360287471352662L0 2l0))
 407                  (eql value (log 2l0 10l0))
 408                  (eql value (log 2l0 2.718281828459045235360287471352662L0)))
 409          (sc-number-or-lose 'fp-constant)))))
 410
 411 (!def-vm-support-routine boxed-immediate-sc-p (sc)
 412   (eql sc (sc-number-or-lose 'immediate)))
 413
 414 ;; For an immediate TN, return its value encoded for use as a literal.
 415 ;; For any other TN, return the TN.  Only works for FIXNUMs,
 416 ;; STATIC-SYMBOLs, and CHARACTERS (FLOATs and SAPs are handled
 417 ;; elsewhere).
 418 (defun encode-value-if-immediate (tn)
 419   (if (sc-is tn immediate)
 420       (let ((val (tn-value tn)))
 421         (etypecase val
 422           (integer (fixnumize val))
 423           (symbol (+ nil-value (static-symbol-offset val)))
 424           (character (logior (ash (char-code val) n-widetag-bits)
 425                              character-widetag))))
 426       tn))
 427 \f
 428 ;;;; miscellaneous function call parameters
 429
 430 ;;; Offsets of special stack frame locations relative to EBP.
 431 ;;;
 432 ;;; Consider the standard prologue PUSH EBP; MOV EBP, ESP: the return
 433 ;;; address is at EBP+4, the old control stack frame pointer is at
 434 ;;; EBP, the magic 3rd slot is at EBP-4. Then come the locals from
 435 ;;; EBP-8 on.
 436 (def!constant return-pc-save-offset 0)
 437 (def!constant ocfp-save-offset 1)
 438 ;;; Let SP be the stack pointer before CALLing, and FP is the frame
 439 ;;; pointer after the standard prologue. SP +
 440 ;;; FRAME-WORD-OFFSET(SP->FP-OFFSET + I) = FP + FRAME-WORD-OFFSET(I).
 441 (def!constant sp->fp-offset 2)
 442
 443 (declaim (inline frame-word-offset))
 444 (defun frame-word-offset (index)
 445   (- (1- index)))
 446
 447 (declaim (inline frame-byte-offset))
 448 (defun frame-byte-offset (index)
 449   (* (frame-word-offset index) n-word-bytes))
 450
 451 ;;; FIXME: This is a bad comment (changed since when?) and there are others
 452 ;;; like it in this file. It'd be nice to clarify them. Failing that deleting
 453 ;;; them or flagging them with KLUDGE might be better than nothing.
 454 ;;;
 455 ;;; names of these things seem to have changed. these aliases by jrd
 456 (def!constant lra-save-offset return-pc-save-offset)
 457
 458 (def!constant cfp-offset ebp-offset)    ; pfw - needed by stuff in /code
 459                                         ; related to signal context stuff
 460
 461 ;;; This is used by the debugger.
 462 (def!constant single-value-return-byte-offset 2)
 463 \f
 464 ;;; This function is called by debug output routines that want a pretty name
 465 ;;; for a TN's location. It returns a thing that can be printed with PRINC.
 466 (!def-vm-support-routine location-print-name (tn)
 467   (declare (type tn tn))
 468   (let* ((sc (tn-sc tn))
 469          (sb (sb-name (sc-sb sc)))
 470          (offset (tn-offset tn)))
 471     (ecase sb
 472       (registers
 473        (let* ((sc-name (sc-name sc))
 474               (name-vec (cond ((member sc-name *byte-sc-names*)
 475                                *byte-register-names*)
 476                               ((member sc-name *word-sc-names*)
 477                                *word-register-names*)
 478                               ((member sc-name *dword-sc-names*)
 479                                *dword-register-names*))))
 480          (or (and name-vec
 481                   (< -1 offset (length name-vec))
 482                   (svref name-vec offset))
 483              ;; FIXME: Shouldn't this be an ERROR?
 484              (format nil "<unknown reg: off=~W, sc=~A>" offset sc-name))))
 485       (float-registers (format nil "FR~D" offset))
 486       (stack (format nil "S~D" offset))
 487       (constant (format nil "Const~D" offset))
 488       (immediate-constant "Immed")
 489       (noise (symbol-name (sc-name sc))))))
 490 ;;; FIXME: Could this, and everything that uses it, be made #!+SB-SHOW?
 491
 492 (!def-vm-support-routine combination-implementation-style (node)
 493   (declare (type sb!c::combination node))
 494   (flet ((valid-funtype (args result)
 495            (sb!c::valid-fun-use node
 496                                 (sb!c::specifier-type
 497                                  `(function ,args ,result)))))
 498     (case (sb!c::combination-fun-source-name node)
 499       (logtest
 500        (cond
 501          ((valid-funtype '(fixnum fixnum) '*)
 502           (values :direct nil))
 503          ((valid-funtype '((signed-byte 32) (signed-byte 32)) '*)
 504           (values :direct nil))
 505          ((valid-funtype '((unsigned-byte 32) (unsigned-byte 32)) '*)
 506           (values :direct nil))
 507          (t (values :default nil))))
 508       (logbitp
 509        (cond
 510          ((and (valid-funtype '((integer 0 29) fixnum) '*)
 511                (sb!c::constant-lvar-p (first (sb!c::basic-combination-args node))))
 512           (values :transform '(lambda (index integer)
 513                                (%logbitp integer index))))
 514          ((valid-funtype '((integer 0 31) (signed-byte 32)) '*)
 515           (values :transform '(lambda (index integer)
 516                                (%logbitp integer index))))
 517          ((valid-funtype '((integer 0 31) (unsigned-byte 32)) '*)
 518           (values :transform '(lambda (index integer)
 519                                (%logbitp integer index))))
 520          (t (values :default nil))))
 521       (t (values :default nil)))))