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