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;;;; register specs 15 16(eval-when (:compile-toplevel :load-toplevel :execute) 17 (defvar *byte-register-names* (make-array 8 :initial-element nil)) 18 (defvar *word-register-names* (make-array 16 :initial-element nil)) 19 (defvar *dword-register-names* (make-array 16 :initial-element nil)) 20 (defvar *float-register-names* (make-array 8 :initial-element nil))) 21 22(macrolet ((defreg (name offset size) 23 (let ((offset-sym (symbolicate name "-OFFSET")) 24 (names-vector (symbolicate "*" size "-REGISTER-NAMES*"))) 25 `(progn 26 (eval-when (:compile-toplevel :load-toplevel :execute) 27 ;; EVAL-WHEN is necessary because stuff like #.EAX-OFFSET 28 ;; (in the same file) depends on compile-time evaluation 29 ;; of the DEFCONSTANT. -- AL 20010224 30 (defconstant ,offset-sym ,offset)) 31 (setf (svref ,names-vector ,offset-sym) 32 ,(symbol-name name))))) 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) 37 (defparameter ,name 38 (list ,@(mapcar (lambda (name) 39 (symbolicate name "-OFFSET")) 40 regs)))))) 41 42 ;; byte registers 43 ;; 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. 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 (defreg ax 0 :word) 59 (defreg cx 2 :word) 60 (defreg dx 4 :word) 61 (defreg bx 6 :word) 62 (defreg sp 8 :word) 63 (defreg bp 10 :word) 64 (defreg si 12 :word) 65 (defreg di 14 :word) 66 (defregset *word-regs* ax cx dx bx si di) 67 68 ;; double word registers 69 (defreg eax 0 :dword) 70 (defreg ecx 2 :dword) 71 (defreg edx 4 :dword) 72 (defreg ebx 6 :dword) 73 (defreg esp 8 :dword) 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) 78 79 ;; floating point registers 80 (defreg fr0 0 :float) 81 (defreg fr1 1 :float) 82 (defreg fr2 2 :float) 83 (defreg fr3 3 :float) 84 (defreg fr4 4 :float) 85 (defreg fr5 5 :float) 86 (defreg fr6 6 :float) 87 (defreg fr7 7 :float) 88 (defregset *float-regs* fr0 fr1 fr2 fr3 fr4 fr5 fr6 fr7) 89 90 ;; registers used to pass arguments 91 ;; 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)) 98 99;;;; SB definitions 100 101;;; Despite the fact that there are only 8 different registers, we consider 102;;; them 16 in order to describe the overlap of byte registers. The only 103;;; thing we need to represent is what registers overlap. Therefore, we 104;;; consider bytes to take one unit, and words or dwords to take two. We 105;;; don't need to tell the difference between words and dwords, because 106;;; you can't put two words in a dword register. 107(define-storage-base registers :finite :size 16) 108 109;;; jrd changed this from size 1 to size 8. It doesn't seem to make much 110;;; sense to use the 387's idea of a stack; 8 separate registers is easier 111;;; to deal with. 112;;; the old way: 113;;; (define-storage-base float-registers :finite :size 1) 114;;; the new way: 115(define-storage-base float-registers :finite :size 8) 116 117(define-storage-base stack :unbounded :size 3 :size-increment 1) 118(define-storage-base constant :non-packed) 119(define-storage-base immediate-constant :non-packed) 120(define-storage-base noise :unbounded :size 2) 121 122;;;; SC definitions 123 124(!define-storage-classes 125 126 ;; non-immediate constants in the constant pool 127 (constant constant) 128 129 ;; some FP constants can be generated in the i387 silicon 130 (fp-constant immediate-constant) 131 (fp-single-immediate immediate-constant) 132 (fp-double-immediate immediate-constant) 133 (immediate immediate-constant) 134 135 ;; 136 ;; the stacks 137 ;; 138 139 ;; the control stack 140 (control-stack stack) ; may be pointers, scanned by GC 141 142 ;; the non-descriptor stacks 143 (signed-stack stack) ; (signed-byte 32) 144 (unsigned-stack stack) ; (unsigned-byte 32) 145 (character-stack stack) ; non-descriptor characters. 146 (sap-stack stack) ; System area pointers. 147 (single-stack stack) ; single-floats 148 (double-stack stack :element-size 2) ; double-floats. 149 #!+long-float 150 (long-stack stack :element-size 3) ; long-floats. 151 (complex-single-stack stack :element-size 2) ; complex-single-floats 152 (complex-double-stack stack :element-size 4) ; complex-double-floats 153 #!+long-float 154 (complex-long-stack stack :element-size 6) ; complex-long-floats 155 156 ;; 157 ;; magic SCs 158 ;; 159 160 (ignore-me noise) 161 162 ;; 163 ;; things that can go in the integer registers 164 ;; 165 166 ;; On the X86, we don't have to distinguish between descriptor and 167 ;; non-descriptor registers, because of the conservative GC. 168 ;; Therefore, we use different scs only to distinguish between 169 ;; descriptor and non-descriptor values and to specify size. 170 171 ;; immediate descriptor objects. Don't have to be seen by GC, but nothing 172 ;; bad will happen if they are. (fixnums, characters, header values, etc). 173 (any-reg registers 174 :locations #.*dword-regs* 175 :element-size 2 176; :reserve-locations (#.eax-offset) 177 :constant-scs (immediate) 178 :save-p t 179 :alternate-scs (control-stack)) 180 181 ;; pointer descriptor objects -- must be seen by GC 182 (descriptor-reg registers 183 :locations #.*dword-regs* 184 :element-size 2 185; :reserve-locations (#.eax-offset) 186 :constant-scs (constant immediate) 187 :save-p t 188 :alternate-scs (control-stack)) 189 190 ;; non-descriptor characters 191 (character-reg registers 192 :locations #!-sb-unicode #.*byte-regs* 193 #!+sb-unicode #.*dword-regs* 194 #!+sb-unicode #!+sb-unicode 195 :element-size 2 196 #!-sb-unicode #!-sb-unicode 197 :reserve-locations (#.ah-offset #.al-offset) 198 :constant-scs (immediate) 199 :save-p t 200 :alternate-scs (character-stack)) 201 202 ;; non-descriptor SAPs (arbitrary pointers into address space) 203 (sap-reg registers 204 :locations #.*dword-regs* 205 :element-size 2 206; :reserve-locations (#.eax-offset) 207 :constant-scs (immediate) 208 :save-p t 209 :alternate-scs (sap-stack)) 210 211 ;; non-descriptor (signed or unsigned) numbers 212 (signed-reg registers 213 :locations #.*dword-regs* 214 :element-size 2 215; :reserve-locations (#.eax-offset) 216 :constant-scs (immediate) 217 :save-p t 218 :alternate-scs (signed-stack)) 219 (unsigned-reg registers 220 :locations #.*dword-regs* 221 :element-size 2 222; :reserve-locations (#.eax-offset) 223 :constant-scs (immediate) 224 :save-p t 225 :alternate-scs (unsigned-stack)) 226 227 ;; miscellaneous objects that must not be seen by GC. Used only as 228 ;; temporaries. 229 (word-reg registers 230 :locations #.*word-regs* 231 :element-size 2 232; :reserve-locations (#.ax-offset) 233 ) 234 (byte-reg registers 235 :locations #.*byte-regs* 236; :reserve-locations (#.al-offset #.ah-offset) 237 ) 238 239 ;; that can go in the floating point registers 240 241 ;; non-descriptor SINGLE-FLOATs 242 (single-reg float-registers 243 :locations (0 1 2 3 4 5 6 7) 244 :constant-scs (fp-constant fp-single-immediate) 245 :save-p t 246 :alternate-scs (single-stack)) 247 248 ;; non-descriptor DOUBLE-FLOATs 249 (double-reg float-registers 250 :locations (0 1 2 3 4 5 6 7) 251 :constant-scs (fp-constant fp-double-immediate) 252 :save-p t 253 :alternate-scs (double-stack)) 254 255 ;; non-descriptor LONG-FLOATs 256 #!+long-float 257 (long-reg float-registers 258 :locations (0 1 2 3 4 5 6 7) 259 :constant-scs (fp-constant) 260 :save-p t 261 :alternate-scs (long-stack)) 262 263 (complex-single-reg float-registers 264 :locations (0 2 4 6) 265 :element-size 2 266 :constant-scs () 267 :save-p t 268 :alternate-scs (complex-single-stack)) 269 270 (complex-double-reg float-registers 271 :locations (0 2 4 6) 272 :element-size 2 273 :constant-scs () 274 :save-p t 275 :alternate-scs (complex-double-stack)) 276 277 #!+long-float 278 (complex-long-reg float-registers 279 :locations (0 2 4 6) 280 :element-size 2 281 :constant-scs () 282 :save-p t 283 :alternate-scs (complex-long-stack)) 284 285 (catch-block stack :element-size catch-block-size) 286 (unwind-block stack :element-size unwind-block-size)) 287 288(eval-when (:compile-toplevel :load-toplevel :execute) 289(defparameter *byte-sc-names* 290 '(#!-sb-unicode character-reg byte-reg #!-sb-unicode character-stack)) 291(defparameter *word-sc-names* '(word-reg)) 292(defparameter *dword-sc-names* 293 '(any-reg descriptor-reg sap-reg signed-reg unsigned-reg control-stack 294 signed-stack unsigned-stack sap-stack single-stack 295 #!+sb-unicode character-reg #!+sb-unicode character-stack constant)) 296;;; added by jrd. I guess the right thing to do is to treat floats 297;;; as a separate size... 298;;; 299;;; These are used to (at least) determine operand size. 300(defparameter *float-sc-names* '(single-reg)) 301(defparameter *double-sc-names* '(double-reg double-stack)) 302) ; EVAL-WHEN 303 304;;;; miscellaneous TNs for the various registers 305 306(macrolet ((def-misc-reg-tns (sc-name &rest reg-names) 307 (collect ((forms)) 308 (dolist (reg-name reg-names) 309 (let ((tn-name (symbolicate reg-name "-TN")) 310 (offset-name (symbolicate reg-name "-OFFSET"))) 311 ;; FIXME: It'd be good to have the special 312 ;; variables here be named with the *FOO* 313 ;; convention. 314 (forms `(defparameter ,tn-name 315 (make-random-tn :kind :normal 316 :sc (sc-or-lose ',sc-name) 317 :offset 318 ,offset-name))))) 319 `(progn ,@(forms))))) 320 321 (def-misc-reg-tns unsigned-reg eax ebx ecx edx ebp esp edi esi) 322 (def-misc-reg-tns word-reg ax bx cx dx bp sp di si) 323 (def-misc-reg-tns byte-reg al ah bl bh cl ch dl dh) 324 (def-misc-reg-tns single-reg fr0 fr1 fr2 fr3 fr4 fr5 fr6 fr7)) 325 326;;; TNs for registers used to pass arguments 327(defparameter *register-arg-tns* 328 (mapcar (lambda (register-arg-name) 329 (symbol-value (symbolicate register-arg-name "-TN"))) 330 *register-arg-names*)) 331 332;;; FIXME: doesn't seem to be used in SBCL 333#| 334;;; added by pw 335(defparameter fp-constant-tn 336 (make-random-tn :kind :normal 337 :sc (sc-or-lose 'fp-constant) 338 :offset 31)) ; Offset doesn't get used. 339|# 340 341;;; If value can be represented as an immediate constant, then return 342;;; the appropriate SC number, otherwise return NIL. 343(defun immediate-constant-sc (value) 344 (typecase value 345 ((or (integer #.sb!xc:most-negative-fixnum #.sb!xc:most-positive-fixnum) 346 character) 347 (sc-number-or-lose 'immediate)) 348 (symbol 349 (when (static-symbol-p value) 350 (sc-number-or-lose 'immediate))) 351 (single-float 352 (case value 353 ((0f0 1f0) (sc-number-or-lose 'fp-constant)) 354 (t (sc-number-or-lose 'fp-single-immediate)))) 355 (double-float 356 (case value 357 ((0d0 1d0) (sc-number-or-lose 'fp-constant)) 358 (t (sc-number-or-lose 'fp-double-immediate)))) 359 #!+long-float 360 (long-float 361 (when (or (eql value 0l0) (eql value 1l0) 362 (eql value pi) 363 (eql value (log 10l0 2l0)) 364 (eql value (log 2.718281828459045235360287471352662L0 2l0)) 365 (eql value (log 2l0 10l0)) 366 (eql value (log 2l0 2.718281828459045235360287471352662L0))) 367 (sc-number-or-lose 'fp-constant))))) 368 369(defun boxed-immediate-sc-p (sc) 370 (eql sc (sc-number-or-lose 'immediate))) 371 372;; For an immediate TN, return its value encoded for use as a literal. 373;; For any other TN, return the TN. Only works for FIXNUMs, 374;; STATIC-SYMBOLs, and CHARACTERS (FLOATs and SAPs are handled 375;; elsewhere). 376(defun encode-value-if-immediate (tn) 377 (if (sc-is tn immediate) 378 (let ((val (tn-value tn))) 379 (etypecase val 380 (integer (fixnumize val)) 381 (symbol (+ nil-value (static-symbol-offset val))) 382 (character (logior (ash (char-code val) n-widetag-bits) 383 character-widetag)))) 384 tn)) 385 386;;;; miscellaneous function call parameters 387 388;;; Offsets of special stack frame locations relative to EBP. 389;;; 390;;; Consider the standard prologue PUSH EBP; MOV EBP, ESP: the return 391;;; address is at EBP+4, the old control stack frame pointer is at 392;;; EBP, the magic 3rd slot is at EBP-4. Then come the locals from 393;;; EBP-8 on. 394(defconstant return-pc-save-offset 0) 395(defconstant ocfp-save-offset 1) 396;;; Let SP be the stack pointer before CALLing, and FP is the frame 397;;; pointer after the standard prologue. SP + 398;;; FRAME-WORD-OFFSET(SP->FP-OFFSET + I) = FP + FRAME-WORD-OFFSET(I). 399(defconstant sp->fp-offset 2) 400 401(declaim (inline frame-word-offset)) 402(defun frame-word-offset (index) 403 (- (1- index))) 404 405(declaim (inline frame-byte-offset)) 406(defun frame-byte-offset (index) 407 (* (frame-word-offset index) n-word-bytes)) 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(defconstant lra-save-offset return-pc-save-offset) 415 416(defconstant cfp-offset ebp-offset) ; pfw - needed by stuff in /code 417 ; related to signal context stuff 418 419;;; This is used by the debugger. 420(defconstant single-value-return-byte-offset 2) 421 422;;; This function is called by debug output routines that want a pretty name 423;;; for a TN's location. It returns a thing that can be printed with PRINC. 424(defun location-print-name (tn) 425 (declare (type tn tn)) 426 (let* ((sc (tn-sc tn)) 427 (sb (sb-name (sc-sb sc))) 428 (offset (tn-offset tn))) 429 (ecase sb 430 (registers 431 (let* ((sc-name (sc-name sc)) 432 (name-vec (cond ((member sc-name *byte-sc-names*) 433 *byte-register-names*) 434 ((member sc-name *word-sc-names*) 435 *word-register-names*) 436 ((member sc-name *dword-sc-names*) 437 *dword-register-names*)))) 438 (or (and name-vec 439 (< -1 offset (length name-vec)) 440 (svref name-vec offset)) 441 ;; FIXME: Shouldn't this be an ERROR? 442 (format nil "<unknown reg: off=~W, sc=~A>" offset sc-name)))) 443 (float-registers (format nil "FR~D" offset)) 444 (stack (format nil "S~D" offset)) 445 (constant (format nil "Const~D" offset)) 446 (immediate-constant "Immed") 447 (noise (symbol-name (sc-name sc)))))) 448;;; FIXME: Could this, and everything that uses it, be made #!+SB-SHOW? 449 450(defun combination-implementation-style (node) 451 (declare (type sb!c::combination node)) 452 (flet ((valid-funtype (args result) 453 (sb!c::valid-fun-use node 454 (sb!c::specifier-type 455 `(function ,args ,result))))) 456 (case (sb!c::combination-fun-source-name node) 457 (logtest 458 (cond 459 ((valid-funtype '(fixnum fixnum) '*) 460 (values :maybe nil)) 461 ((valid-funtype '((signed-byte 32) (signed-byte 32)) '*) 462 (values :maybe nil)) 463 ((valid-funtype '((unsigned-byte 32) (unsigned-byte 32)) '*) 464 (values :maybe nil)) 465 (t (values :default nil)))) 466 (logbitp 467 (cond 468 ((and (valid-funtype '((integer 0 29) fixnum) '*) 469 (sb!c::constant-lvar-p (first (sb!c::basic-combination-args node)))) 470 (values :transform '(lambda (index integer) 471 (%logbitp integer index)))) 472 ((valid-funtype '((integer 0 31) (signed-byte 32)) '*) 473 (values :transform '(lambda (index integer) 474 (%logbitp integer index)))) 475 ((valid-funtype '((integer 0 31) (unsigned-byte 32)) '*) 476 (values :transform '(lambda (index integer) 477 (%logbitp integer index)))) 478 (t (values :default nil)))) 479 (t (values :default nil))))) 480