src/compiler/x86-64/move.lisp

   1 ;;;; the x86-64 VM definition of operand loading/saving and the MOVE vop
   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 (defun zeroize (tn)
  15   (let ((offset (tn-offset tn)))
  16     ;; Using the 32-bit instruction accomplishes the same thing and is
  17     ;; one byte shorter.
  18     (if (<= offset edi-offset)
  19         (let ((tn (make-random-tn :kind :normal
  20                                   :sc (sc-or-lose 'dword-reg)
  21                                   :offset offset)))
  22           (inst xor tn tn))
  23         (inst xor tn tn))))
  24
  25 (define-move-fun (load-immediate 1) (vop x y)
  26   ((immediate)
  27    (any-reg descriptor-reg))
  28   (let ((val (tn-value x)))
  29     (etypecase val
  30       (integer
  31        (if (zerop val)
  32            (zeroize y)
  33          (inst mov y (fixnumize val))))
  34       (symbol
  35        (load-symbol y val))
  36       (character
  37        (inst mov y (logior (ash (char-code val) n-widetag-bits)
  38                            character-widetag))))))
  39
  40 (define-move-fun (load-number 1) (vop x y)
  41   ((immediate) (signed-reg unsigned-reg))
  42   (let ((val (tn-value x)))
  43     (if (zerop val)
  44         (zeroize y)
  45         (inst mov y val))))
  46
  47 (define-move-fun (load-character 1) (vop x y)
  48   ((immediate) (character-reg))
  49   (inst mov y (char-code (tn-value x))))
  50
  51 (define-move-fun (load-system-area-pointer 1) (vop x y)
  52   ((immediate) (sap-reg))
  53   (inst mov y (sap-int (tn-value x))))
  54
  55 (define-move-fun (load-constant 5) (vop x y)
  56   ((constant) (descriptor-reg any-reg))
  57   (inst mov y x))
  58
  59 (define-move-fun (load-stack 5) (vop x y)
  60   ((control-stack) (any-reg descriptor-reg)
  61    (character-stack) (character-reg)
  62    (sap-stack) (sap-reg)
  63    (signed-stack) (signed-reg)
  64    (unsigned-stack) (unsigned-reg))
  65   (inst mov y x))
  66
  67 (define-move-fun (store-stack 5) (vop x y)
  68   ((any-reg descriptor-reg) (control-stack)
  69    (character-reg) (character-stack)
  70    (sap-reg) (sap-stack)
  71    (signed-reg) (signed-stack)
  72    (unsigned-reg) (unsigned-stack))
  73   (inst mov y x))
  74 \f
  75 ;;;; the MOVE VOP
  76 (define-vop (move)
  77   (:args (x :scs (any-reg descriptor-reg immediate) :target y
  78             :load-if (not (location= x y))))
  79   (:results (y :scs (any-reg descriptor-reg)
  80                :load-if
  81                (not (or (location= x y)
  82                         (and (sc-is x any-reg descriptor-reg immediate)
  83                              (sc-is y control-stack))))))
  84   (:temporary (:sc unsigned-reg) temp)
  85   (:effects)
  86   (:affected)
  87   (:generator 0
  88     (if (and (sc-is x immediate)
  89              (sc-is y any-reg descriptor-reg control-stack))
  90         (let ((val (tn-value x)))
  91           (etypecase val
  92             (integer
  93              (if (and (zerop val) (sc-is y any-reg descriptor-reg))
  94                  (zeroize y)
  95                  (move-immediate y (fixnumize val) temp)))
  96             (symbol
  97              (inst mov y (+ nil-value (static-symbol-offset val))))
  98             (character
  99              (inst mov y (logior (ash (char-code val) n-widetag-bits)
 100                                  character-widetag)))))
 101         (move y x))))
 102
 103 (define-move-vop move :move
 104   (any-reg descriptor-reg immediate)
 105   (any-reg descriptor-reg))
 106
 107 ;;; Make MOVE the check VOP for T so that type check generation
 108 ;;; doesn't think it is a hairy type. This also allows checking of a
 109 ;;; few of the values in a continuation to fall out.
 110 (primitive-type-vop move (:check) t)
 111
 112 (defun move-immediate (target val &optional tmp-tn)
 113   (cond
 114     ;; If target is a register, we can just mov it there directly
 115     ((and (tn-p target)
 116           (sc-is target signed-reg unsigned-reg descriptor-reg any-reg))
 117      (inst mov target val))
 118     ;; Likewise if the value is small enough.
 119     ((typep val '(signed-byte 31))
 120      (inst mov target val))
 121     ;; Otherwise go through the temporary register
 122     (tmp-tn
 123      (inst mov tmp-tn val)
 124      (inst mov target tmp-tn))
 125     (t
 126      (error "~A is not a register, no temporary given, and immediate ~A too large" target val))))
 127
 128 ;;; The MOVE-ARG VOP is used for moving descriptor values into
 129 ;;; another frame for argument or known value passing.
 130 ;;;
 131 ;;; Note: It is not going to be possible to move a constant directly
 132 ;;; to another frame, except if the destination is a register and in
 133 ;;; this case the loading works out.
 134 (define-vop (move-arg)
 135   (:args (x :scs (any-reg descriptor-reg immediate) :target y
 136             :load-if (not (and (sc-is y any-reg descriptor-reg)
 137                                (sc-is x control-stack))))
 138          (fp :scs (any-reg)
 139              :load-if (not (sc-is y any-reg descriptor-reg))))
 140   (:results (y))
 141   (:generator 0
 142     (sc-case y
 143       ((any-reg descriptor-reg)
 144        (if (sc-is x immediate)
 145            (let ((val (tn-value x)))
 146              (etypecase val
 147                ((integer 0 0)
 148                 (zeroize y))
 149                ((or (signed-byte 29) (unsigned-byte 29))
 150                 (inst mov y (fixnumize val)))
 151                (integer
 152                 (move-immediate y (fixnumize val)))
 153                (symbol
 154                 (load-symbol y val))
 155                (character
 156                 (inst mov y (logior (ash (char-code val) n-widetag-bits)
 157                                     character-widetag)))))
 158            (move y x)))
 159       ((control-stack)
 160        (if (sc-is x immediate)
 161            (let ((val (tn-value x)))
 162              (if (= (tn-offset fp) esp-offset)
 163                  ;; C-call
 164                  (etypecase val
 165                    (integer
 166                     (storew (fixnumize val) fp (tn-offset y)))
 167                    (symbol
 168                     (storew (+ nil-value (static-symbol-offset val))
 169                             fp (tn-offset y)))
 170                    (character
 171                     (storew (logior (ash (char-code val) n-widetag-bits)
 172                                     character-widetag)
 173                             fp (tn-offset y))))
 174                ;; Lisp stack
 175                (etypecase val
 176                  (integer
 177                   (storew (fixnumize val) fp (- (1+ (tn-offset y)))))
 178                  (symbol
 179                   (storew (+ nil-value (static-symbol-offset val))
 180                           fp (- (1+ (tn-offset y)))))
 181                  (character
 182                   (storew (logior (ash (char-code val) n-widetag-bits)
 183                                   character-widetag)
 184                           fp (- (1+ (tn-offset y))))))))
 185          (if (= (tn-offset fp) esp-offset)
 186              ;; C-call
 187              (storew x fp (tn-offset y))
 188            ;; Lisp stack
 189            (storew x fp (- (1+ (tn-offset y))))))))))
 190
 191 (define-move-vop move-arg :move-arg
 192   (any-reg descriptor-reg)
 193   (any-reg descriptor-reg))
 194 \f
 195 ;;;; ILLEGAL-MOVE
 196
 197 ;;; This VOP exists just to begin the lifetime of a TN that couldn't
 198 ;;; be written legally due to a type error. An error is signalled
 199 ;;; before this VOP is so we don't need to do anything (not that there
 200 ;;; would be anything sensible to do anyway.)
 201 (define-vop (illegal-move)
 202   (:args (x) (type))
 203   (:results (y))
 204   (:ignore y)
 205   (:vop-var vop)
 206   (:save-p :compute-only)
 207   (:generator 666
 208     (error-call vop object-not-type-error x type)))
 209 \f
 210 ;;;; moves and coercions
 211
 212 ;;; These MOVE-TO-WORD VOPs move a tagged integer to a raw full-word
 213 ;;; representation. Similarly, the MOVE-FROM-WORD VOPs converts a raw
 214 ;;; integer to a tagged bignum or fixnum.
 215
 216 ;;; Arg is a fixnum, so just shift it. We need a type restriction
 217 ;;; because some possible arg SCs (control-stack) overlap with
 218 ;;; possible bignum arg SCs.
 219 (define-vop (move-to-word/fixnum)
 220   (:args (x :scs (any-reg descriptor-reg) :target y
 221             :load-if (not (location= x y))))
 222   (:results (y :scs (signed-reg unsigned-reg)
 223                :load-if (not (location= x y))))
 224   (:arg-types tagged-num)
 225   (:note "fixnum untagging")
 226   (:generator 1
 227     (move y x)
 228     (inst sar y  (1- n-lowtag-bits))))
 229 (define-move-vop move-to-word/fixnum :move
 230   (any-reg descriptor-reg) (signed-reg unsigned-reg))
 231
 232 ;;; Arg is a non-immediate constant, load it.
 233 (define-vop (move-to-word-c)
 234   (:args (x :scs (constant)))
 235   (:results (y :scs (signed-reg unsigned-reg)))
 236   (:note "constant load")
 237   (:generator 1
 238     (inst mov y (tn-value x))))
 239 (define-move-vop move-to-word-c :move
 240   (constant) (signed-reg unsigned-reg))
 241
 242
 243 ;;; Arg is a fixnum or bignum, figure out which and load if necessary.
 244 (define-vop (move-to-word/integer)
 245   (:args (x :scs (descriptor-reg) :target eax))
 246   (:results (y :scs (signed-reg unsigned-reg)))
 247   (:note "integer to untagged word coercion")
 248   (:temporary (:sc unsigned-reg :offset eax-offset
 249                    :from (:argument 0) :to (:result 0) :target y) eax)
 250   (:generator 4
 251     (move eax x)
 252     (inst test al-tn 7)                 ; a symbolic constant for this
 253     (inst jmp :z FIXNUM)                ; would be nice
 254     (loadw y eax bignum-digits-offset other-pointer-lowtag)
 255     (inst jmp DONE)
 256     FIXNUM
 257     (inst sar eax (1- n-lowtag-bits))
 258     (move y eax)
 259     DONE))
 260 (define-move-vop move-to-word/integer :move
 261   (descriptor-reg) (signed-reg unsigned-reg))
 262
 263
 264 ;;; Result is a fixnum, so we can just shift. We need the result type
 265 ;;; restriction because of the control-stack ambiguity noted above.
 266 (define-vop (move-from-word/fixnum)
 267   (:args (x :scs (signed-reg unsigned-reg) :target y
 268             :load-if (not (location= x y))))
 269   (:results (y :scs (any-reg descriptor-reg)
 270                :load-if (not (location= x y))))
 271   (:result-types tagged-num)
 272   (:note "fixnum tagging")
 273   (:generator 1
 274     (cond ((and (sc-is x signed-reg unsigned-reg)
 275                 (not (location= x y)))
 276            ;; Uses 7 bytes, but faster on the Pentium
 277            (inst lea y (make-ea :qword :index x :scale 8)))
 278           (t
 279            ;; Uses: If x is a reg 2 + 3; if x = y uses only 3 bytes
 280            (move y x)
 281            (inst shl y (1- n-lowtag-bits))))))
 282 (define-move-vop move-from-word/fixnum :move
 283   (signed-reg unsigned-reg) (any-reg descriptor-reg))
 284
 285 ;;; Result may be a bignum, so we have to check. Use a worst-case cost
 286 ;;; to make sure people know they may be number consing.
 287 (define-vop (move-from-signed)
 288   (:args (x :scs (signed-reg unsigned-reg) :to :result))
 289   (:results (y :scs (any-reg descriptor-reg) :from :argument))
 290   (:note "signed word to integer coercion")
 291   (:node-var node)
 292   (:generator 20
 293      (aver (not (location= x y)))
 294      (let ((bignum (gen-label))
 295            (done (gen-label)))
 296        ;; We can't do the overflow check with SHL Y, 3, since the
 297        ;; state of the overflow flag is only reliably set when
 298        ;; shifting by 1. There used to be code here for doing "shift
 299        ;; by one, check whether it overflowed" three times. But on all
 300        ;; x86-64 processors IMUL is a reasonably fast instruction, so
 301        ;; we can just do a straight multiply instead of trying to
 302        ;; optimize it to a shift. This is both faster and smaller.
 303        ;; -- JES, 2006-07-08
 304        (inst imul y x (ash 1 n-fixnum-tag-bits))
 305        (inst jmp :o bignum)
 306        (emit-label done)
 307
 308        (assemble (*elsewhere*)
 309           (emit-label bignum)
 310           (with-fixed-allocation
 311               (y bignum-widetag (+ bignum-digits-offset 1) node)
 312             (storew x y bignum-digits-offset other-pointer-lowtag))
 313           (inst jmp done)))))
 314 (define-move-vop move-from-signed :move
 315   (signed-reg) (descriptor-reg))
 316
 317 ;;; Check for fixnum, and possibly allocate one or two word bignum
 318 ;;; result. Use a worst-case cost to make sure people know they may be
 319 ;;; number consing.
 320
 321 (define-vop (move-from-unsigned)
 322   (:args (x :scs (signed-reg unsigned-reg) :to :save))
 323   (:temporary (:sc unsigned-reg) alloc)
 324   (:results (y :scs (any-reg descriptor-reg)))
 325   (:node-var node)
 326   (:note "unsigned word to integer coercion")
 327   (:generator 20
 328     (aver (not (location= x y)))
 329     (aver (not (location= x alloc)))
 330     (aver (not (location= y alloc)))
 331     (let ((bignum (gen-label))
 332           (done (gen-label))
 333           (one-word-bignum (gen-label))
 334           (L1 (gen-label)))
 335       (inst bsr y x)                    ;find msb
 336       (inst cmov :z y x)
 337       (inst cmp y 60)
 338       (inst jmp :ae bignum)
 339       (inst lea y (make-ea :qword :index x :scale 8))
 340       (emit-label done)
 341       (assemble (*elsewhere*)
 342          (emit-label bignum)
 343          ;; Note: As on the mips port, space for a two word bignum is
 344          ;; always allocated and the header size is set to either one
 345          ;; or two words as appropriate.
 346          (inst cmp y 63)
 347          (inst jmp :l one-word-bignum)
 348          ;; two word bignum
 349          (inst mov y (logior (ash (1- (+ bignum-digits-offset 2))
 350                                   n-widetag-bits)
 351                              bignum-widetag))
 352          (inst jmp L1)
 353          (emit-label one-word-bignum)
 354          (inst mov y (logior (ash (1- (+ bignum-digits-offset 1))
 355                                   n-widetag-bits)
 356                              bignum-widetag))
 357          (emit-label L1)
 358          (pseudo-atomic
 359           (allocation alloc (pad-data-block (+ bignum-digits-offset 2)) node)
 360           (storew y alloc)
 361           (inst lea y (make-ea :byte :base alloc :disp other-pointer-lowtag))
 362           (storew x y bignum-digits-offset other-pointer-lowtag))
 363          (inst jmp done)))))
 364 (define-move-vop move-from-unsigned :move
 365   (unsigned-reg) (descriptor-reg))
 366
 367 ;;; Move untagged numbers.
 368 (define-vop (word-move)
 369   (:args (x :scs (signed-reg unsigned-reg) :target y
 370             :load-if (not (location= x y))))
 371   (:results (y :scs (signed-reg unsigned-reg)
 372                :load-if
 373                (not (or (location= x y)
 374                         (and (sc-is x signed-reg unsigned-reg)
 375                              (sc-is y signed-stack unsigned-stack))))))
 376   (:effects)
 377   (:affected)
 378   (:note "word integer move")
 379   (:generator 0
 380     (move y x)))
 381 (define-move-vop word-move :move
 382   (signed-reg unsigned-reg) (signed-reg unsigned-reg))
 383
 384 ;;; Move untagged number arguments/return-values.
 385 (define-vop (move-word-arg)
 386   (:args (x :scs (signed-reg unsigned-reg) :target y)
 387          (fp :scs (any-reg) :load-if (not (sc-is y sap-reg))))
 388   (:results (y))
 389   (:note "word integer argument move")
 390   (:generator 0
 391     (sc-case y
 392       ((signed-reg unsigned-reg)
 393        (move y x))
 394       ((signed-stack unsigned-stack)
 395        (if (= (tn-offset fp) esp-offset)
 396            (storew x fp (tn-offset y))  ; c-call
 397            (storew x fp (- (1+ (tn-offset y)))))))))
 398 (define-move-vop move-word-arg :move-arg
 399   (descriptor-reg any-reg signed-reg unsigned-reg) (signed-reg unsigned-reg))
 400
 401 ;;; Use standard MOVE-ARG and coercion to move an untagged number
 402 ;;; to a descriptor passing location.
 403 (define-move-vop move-arg :move-arg
 404   (signed-reg unsigned-reg) (any-reg descriptor-reg))