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