src/compiler/x86-64/move.lisp

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