src/compiler/sparc/move.lisp

   1 ;;;; the Sparc 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   ((null immediate zero)
  16    (any-reg descriptor-reg))
  17   (let ((val (tn-value x)))
  18     (etypecase val
  19       (integer
  20        (inst li y (fixnumize val)))
  21       (null
  22        (move y null-tn))
  23       (symbol
  24        (load-symbol y val))
  25       (character
  26        (inst li y (logior (ash (char-code val) n-widetag-bits)
  27                           character-widetag))))))
  28
  29 (define-move-fun (load-number 1) (vop x y)
  30   ((immediate zero)
  31    (signed-reg unsigned-reg))
  32   (inst li y (tn-value x)))
  33
  34 (define-move-fun (load-character 1) (vop x y)
  35   ((immediate) (character-reg))
  36   (inst li y (char-code (tn-value x))))
  37
  38 (define-move-fun (load-system-area-pointer 1) (vop x y)
  39   ((immediate) (sap-reg))
  40   (inst li y (sap-int (tn-value x))))
  41
  42 (define-move-fun (load-constant 5) (vop x y)
  43   ((constant) (descriptor-reg))
  44   (loadw y code-tn (tn-offset x) other-pointer-lowtag))
  45
  46 (define-move-fun (load-stack 5) (vop x y)
  47   ((control-stack) (any-reg descriptor-reg))
  48   (load-stack-tn y x))
  49
  50 (define-move-fun (load-number-stack 5) (vop x y)
  51   ((character-stack) (character-reg)
  52    (sap-stack) (sap-reg)
  53    (signed-stack) (signed-reg)
  54    (unsigned-stack) (unsigned-reg))
  55   (let ((nfp (current-nfp-tn vop)))
  56     (loadw y nfp (tn-offset x))))
  57
  58 (define-move-fun (store-stack 5) (vop x y)
  59   ((any-reg descriptor-reg) (control-stack))
  60   (store-stack-tn y x))
  61
  62 (define-move-fun (store-number-stack 5) (vop x y)
  63   ((character-reg) (character-stack)
  64    (sap-reg) (sap-stack)
  65    (signed-reg) (signed-stack)
  66    (unsigned-reg) (unsigned-stack))
  67   (let ((nfp (current-nfp-tn vop)))
  68     (storew x nfp (tn-offset y))))
  69
  70 \f
  71 ;;;; The Move VOP:
  72
  73 (define-vop (move)
  74   (:args (x :target y
  75             :scs (any-reg descriptor-reg zero null)
  76             :load-if (not (location= x y))))
  77   (:results (y :scs (any-reg descriptor-reg)
  78                :load-if (not (location= x y))))
  79   (:effects)
  80   (:affected)
  81   (:generator 0
  82     (move y x)))
  83
  84 (define-move-vop move :move
  85   (any-reg descriptor-reg)
  86   (any-reg descriptor-reg))
  87
  88 ;;; Make Move the check VOP for T so that type check generation
  89 ;;; doesn't think it is a hairy type.  This also allows checking of a
  90 ;;; few of the values in a continuation to fall out.
  91 (primitive-type-vop move (:check) t)
  92
  93 ;;; The Move-Arg VOP is used for moving descriptor values into
  94 ;;; another frame for argument or known value passing.
  95 (define-vop (move-arg)
  96   (:args (x :target y
  97             :scs (any-reg descriptor-reg zero null))
  98          (fp :scs (any-reg)
  99              :load-if (not (sc-is y any-reg descriptor-reg))))
 100   (:results (y))
 101   (:generator 0
 102     (sc-case y
 103       ((any-reg descriptor-reg)
 104        (move y x))
 105       (control-stack
 106        (storew x fp (tn-offset y))))))
 107
 108 (define-move-vop move-arg :move-arg
 109   (any-reg descriptor-reg)
 110   (any-reg descriptor-reg))
 111 \f
 112 ;;;; ILLEGAL-MOVE
 113
 114 ;;; This VOP exists just to begin the lifetime of a TN that couldn't
 115 ;;; be written legally due to a type error.  An error is signalled
 116 ;;; before this VOP is so we don't need to do anything (not that there
 117 ;;; would be anything sensible to do anyway.)
 118 (define-vop (illegal-move)
 119   (:args (x) (type))
 120   (:results (y))
 121   (:ignore y)
 122   (:vop-var vop)
 123   (:save-p :compute-only)
 124   (:generator 666
 125     (error-call vop object-not-type-error x type)))
 126 \f
 127 ;;;; moves and coercions:
 128
 129 ;;; These MOVE-TO-WORD VOPs move a tagged integer to a raw full-word
 130 ;;; representation.  Similarly, the MOVE-FROM-WORD VOPs converts a raw
 131 ;;; integer to a tagged bignum or fixnum.
 132
 133 ;;; Arg is a fixnum, so just shift it.  We need a type restriction
 134 ;;; because some possible arg SCs (control-stack) overlap with
 135 ;;; possible bignum arg SCs.
 136 (define-vop (move-to-word/fixnum)
 137   (:args (x :scs (any-reg descriptor-reg)))
 138   (:results (y :scs (signed-reg unsigned-reg)))
 139   (:arg-types tagged-num)
 140   (:note "fixnum untagging")
 141   (:generator 1
 142     (inst sra y x n-fixnum-tag-bits)))
 143
 144 (define-move-vop move-to-word/fixnum :move
 145   (any-reg descriptor-reg) (signed-reg unsigned-reg))
 146
 147 ;;; Arg is a non-immediate constant, load it.
 148 (define-vop (move-to-word-c)
 149   (:args (x :scs (constant)))
 150   (:results (y :scs (signed-reg unsigned-reg)))
 151   (:note "constant load")
 152   (:generator 1
 153     (cond ((sb!c::tn-leaf x)
 154            (inst li y (tn-value x)))
 155           (t
 156            (loadw y code-tn (tn-offset x) other-pointer-lowtag)
 157            (inst sra y y n-fixnum-tag-bits)))))
 158
 159 (define-move-vop move-to-word-c :move
 160   (constant) (signed-reg unsigned-reg))
 161
 162
 163 ;;; Arg is a fixnum or bignum, figure out which and load if necessary.
 164 (define-vop (move-to-word/integer)
 165   (:args (x :scs (descriptor-reg)))
 166   (:results (y :scs (signed-reg unsigned-reg)))
 167   (:note "integer to untagged word coercion")
 168   (:temporary (:scs (non-descriptor-reg)) temp)
 169   (:generator 4
 170     (let ((done (gen-label)))
 171       (inst andcc temp x fixnum-tag-mask)
 172       (inst b :eq done)
 173       (inst sra y x n-fixnum-tag-bits)
 174
 175       (loadw y x bignum-digits-offset other-pointer-lowtag)
 176
 177       (emit-label done))))
 178
 179 (define-move-vop move-to-word/integer :move
 180   (descriptor-reg) (signed-reg unsigned-reg))
 181
 182 ;;; Result is a fixnum, so we can just shift.  We need the result type
 183 ;;; restriction because of the control-stack ambiguity noted above.
 184 (define-vop (move-from-word/fixnum)
 185   (:args (x :scs (signed-reg unsigned-reg)))
 186   (:results (y :scs (any-reg descriptor-reg)))
 187   (:result-types tagged-num)
 188   (:note "fixnum tagging")
 189   (:generator 1
 190     (inst sll y x n-fixnum-tag-bits)))
 191
 192 (define-move-vop move-from-word/fixnum :move
 193   (signed-reg unsigned-reg) (any-reg descriptor-reg))
 194
 195
 196 ;;; Result may be a bignum, so we have to check.  Use a worst-case
 197 ;;; cost to make sure people know they may be number consing.
 198 (define-vop (move-from-signed)
 199   (:args (arg :scs (signed-reg unsigned-reg) :target x))
 200   (:results (y :scs (any-reg descriptor-reg)))
 201   (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x temp)
 202   (:note "signed word to integer coercion")
 203   (:generator 20
 204     (move x arg)
 205     (let ((fixnum (gen-label))
 206           (done (gen-label)))
 207       (inst sra temp x n-positive-fixnum-bits)
 208       (inst cmp temp)
 209       (inst b :eq fixnum)
 210       (inst orncc temp zero-tn temp)
 211       (inst b :eq done)
 212       (inst sll y x n-fixnum-tag-bits)
 213
 214       (with-fixed-allocation
 215         (y temp bignum-widetag (1+ bignum-digits-offset))
 216         (storew x y bignum-digits-offset other-pointer-lowtag))
 217       (inst b done)
 218       (inst nop)
 219
 220       (emit-label fixnum)
 221       (inst sll y x n-fixnum-tag-bits)
 222       (emit-label done))))
 223
 224 (define-move-vop move-from-signed :move
 225   (signed-reg) (descriptor-reg))
 226
 227
 228 ;;; Check for fixnum, and possibly allocate one or two word bignum
 229 ;;; result.  Use a worst-case cost to make sure people know they may
 230 ;;; be number consing.
 231 (define-vop (move-from-unsigned)
 232   (:args (arg :scs (signed-reg unsigned-reg) :target x))
 233   (:results (y :scs (any-reg descriptor-reg)))
 234   (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x temp)
 235   (:note "unsigned word to integer coercion")
 236   (:generator 20
 237     (move x arg)
 238     (let ((done (gen-label))
 239           (one-word (gen-label)))
 240       (inst sra temp x n-positive-fixnum-bits)
 241       (inst cmp temp)
 242       (inst b :eq done)
 243       (inst sll y x n-fixnum-tag-bits)
 244
 245       ;; We always allocate 2 words even if we don't need it.  (The
 246       ;; copying GC will take care of freeing the unused extra word.)
 247       (with-fixed-allocation
 248           (y temp bignum-widetag (+ 2 bignum-digits-offset))
 249         (inst cmp x)
 250         (inst b :ge one-word)
 251         (inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag))
 252         (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag))
 253         (emit-label one-word)
 254         ;; Set the header word, then the actual digit.  The extra
 255         ;; digit, if any, is automatically set to zero, so we don't
 256         ;; have to.
 257         (storew temp y 0 other-pointer-lowtag)
 258         (storew x y bignum-digits-offset other-pointer-lowtag))
 259       (emit-label done))))
 260
 261 (define-move-vop move-from-unsigned :move
 262   (unsigned-reg) (descriptor-reg))
 263
 264
 265 ;;; Move untagged numbers.
 266 (define-vop (word-move)
 267   (:args (x :target y
 268             :scs (signed-reg unsigned-reg)
 269             :load-if (not (location= x y))))
 270   (:results (y :scs (signed-reg unsigned-reg)
 271                :load-if (not (location= x y))))
 272   (:effects)
 273   (:affected)
 274   (:note "word integer move")
 275   (:generator 0
 276     (move y x)))
 277
 278 (define-move-vop word-move :move
 279   (signed-reg unsigned-reg) (signed-reg unsigned-reg))
 280
 281
 282 ;;; Move untagged number arguments/return-values.
 283 (define-vop (move-word-arg)
 284   (:args (x :target y
 285             :scs (signed-reg unsigned-reg))
 286          (fp :scs (any-reg)
 287              :load-if (not (sc-is y sap-reg))))
 288   (:results (y))
 289   (:note "word integer argument move")
 290   (:generator 0
 291     (sc-case y
 292       ((signed-reg unsigned-reg)
 293        (move y x))
 294       ((signed-stack unsigned-stack)
 295        (storew x fp (tn-offset y))))))
 296
 297 (define-move-vop move-word-arg :move-arg
 298   (descriptor-reg any-reg signed-reg unsigned-reg) (signed-reg unsigned-reg))
 299
 300
 301 ;;; Use standard MOVE-ARGUMENT + coercion to move an untagged number
 302 ;;; to a descriptor passing location.
 303 (define-move-vop move-arg :move-arg
 304   (signed-reg unsigned-reg) (any-reg descriptor-reg))