src/compiler/x86-64/memory.lisp

   1 ;;;; the x86 definitions of some general purpose memory reference VOPs
   2 ;;;; inherited by basic memory reference operations
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; This software is derived from the CMU CL system, which was
   8 ;;;; written at Carnegie Mellon University and released into the
   9 ;;;; public domain. The software is in the public domain and is
  10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  11 ;;;; files for more information.
  12
  13 (in-package "SB!VM")
  14
  15 ;;; CELL-REF and CELL-SET are used to define VOPs like CAR, where the
  16 ;;; offset to be read or written is a property of the VOP used.
  17 ;;; CELL-SETF is similar to CELL-SET, but delivers the new value as
  18 ;;; the result. CELL-SETF-FUN takes its arguments as if it were a
  19 ;;; SETF function (new value first, as apposed to a SETF macro, which
  20 ;;; takes the new value last).
  21 (define-vop (cell-ref)
  22   (:args (object :scs (descriptor-reg)))
  23   (:results (value :scs (descriptor-reg any-reg)))
  24   (:variant-vars offset lowtag)
  25   (:policy :fast-safe)
  26   (:generator 4
  27     (loadw value object offset lowtag)))
  28 (define-vop (cell-set)
  29   (:args (object :scs (descriptor-reg))
  30          (value :scs (descriptor-reg any-reg)))
  31   (:variant-vars offset lowtag)
  32   (:policy :fast-safe)
  33   (:generator 4
  34     (storew value object offset lowtag)))
  35 (define-vop (cell-setf)
  36   (:args (object :scs (descriptor-reg))
  37          (value :scs (descriptor-reg any-reg) :target result))
  38   (:results (result :scs (descriptor-reg any-reg)))
  39   (:variant-vars offset lowtag)
  40   (:policy :fast-safe)
  41   (:generator 4
  42     (storew value object offset lowtag)
  43     (move result value)))
  44 (define-vop (cell-setf-fun)
  45   (:args (value :scs (descriptor-reg any-reg) :target result)
  46          (object :scs (descriptor-reg)))
  47   (:results (result :scs (descriptor-reg any-reg)))
  48   (:variant-vars offset lowtag)
  49   (:policy :fast-safe)
  50   (:generator 4
  51     (storew value object offset lowtag)
  52     (move result value)))
  53
  54 ;;; Define accessor VOPs for some cells in an object. If the operation
  55 ;;; name is NIL, then that operation isn't defined. If the translate
  56 ;;; function is null, then we don't define a translation.
  57 (defmacro define-cell-accessors (offset lowtag
  58                                         ref-op ref-trans set-op set-trans)
  59   `(progn
  60      ,@(when ref-op
  61          `((define-vop (,ref-op cell-ref)
  62              (:variant ,offset ,lowtag)
  63              ,@(when ref-trans
  64                  `((:translate ,ref-trans))))))
  65      ,@(when set-op
  66          `((define-vop (,set-op cell-setf)
  67              (:variant ,offset ,lowtag)
  68              ,@(when set-trans
  69                  `((:translate ,set-trans))))))))
  70
  71 ;;; X86 special
  72 (define-vop (cell-xadd)
  73   (:args (object :scs (descriptor-reg) :to :result)
  74          (value :scs (any-reg) :target result))
  75   (:results (result :scs (any-reg) :from (:argument 1)))
  76   (:result-types tagged-num)
  77   (:variant-vars offset lowtag)
  78   (:policy :fast-safe)
  79   (:generator 4
  80     (move result value)
  81     (inst xadd (make-ea-for-object-slot object offset lowtag) result :lock)))
  82
  83 (define-vop (cell-xsub cell-xadd)
  84   (:args (object)
  85          (value :scs (any-reg immediate) :target result))
  86   (:generator 5
  87     ;; For constant delta we can avoid a mov followed by neg
  88     ;; but if 'delta' is most-negative-fixnum, don't negate it.
  89     ;; Decrementing by most-negative-fixnum is the same as incrementing.
  90     (sc-case value
  91      (immediate
  92       (let ((k (tn-value value)))
  93         (inst mov result (fixnumize (if (= k most-negative-fixnum) k (- k))))))
  94      (t
  95       (move result value)
  96       (inst neg result)))
  97     (inst xadd (make-ea-for-object-slot object offset lowtag) result :lock)))
  98
  99 (define-vop (atomic-inc-symbol-global-value cell-xadd)
 100   (:translate %atomic-inc-symbol-global-value)
 101   ;; The function which this vop translates will not
 102   ;; be used unless the variable is proclaimed as fixnum.
 103   ;; All stores are checked in a safe policy, so this
 104   ;; vop is safe because it increments a known fixnum.
 105   (:policy :fast-safe)
 106   (:arg-types * tagged-num)
 107   (:variant symbol-value-slot other-pointer-lowtag))
 108
 109 (define-vop (atomic-dec-symbol-global-value cell-xsub)
 110   (:translate %atomic-dec-symbol-global-value)
 111   (:policy :fast-safe)
 112   (:arg-types * tagged-num)
 113   (:variant symbol-value-slot other-pointer-lowtag))
 114
 115 (macrolet
 116     ((def-atomic (fun-name inherit slot)
 117        `(progn
 118           (define-vop (,(symbolicate fun-name "/FAST") ,inherit)
 119             (:translate ,fun-name)
 120             (:policy :fast)
 121             (:arg-types * tagged-num)
 122             (:variant ,slot list-pointer-lowtag))
 123           (define-vop (,(symbolicate fun-name "/SAFE"))
 124             (:translate ,fun-name)
 125             (:policy :fast-safe)
 126             (:args (cell :scs (descriptor-reg))
 127                    (delta :scs (any-reg immediate)))
 128             (:results (result :scs (any-reg)))
 129             (:temporary (:sc descriptor-reg :offset rax-offset) rax)
 130             (:temporary (:sc any-reg) newval)
 131             (:arg-types * tagged-num)
 132             (:result-types tagged-num)
 133             (:vop-var vop)
 134             (:generator 10
 135              (let ((err (generate-error-code vop 'object-not-fixnum-error rax))
 136                    (const (if (sc-is delta immediate)
 137                               (fixnumize ,(if (eq inherit 'cell-xsub)
 138                                               `(let ((x (tn-value delta)))
 139                                                  (if (= x most-negative-fixnum)
 140                                                      x (- x)))
 141                                               `(tn-value delta)))))
 142                    (retry (gen-label)))
 143                (loadw rax cell ,slot list-pointer-lowtag)
 144                (emit-label retry)
 145                (inst test rax fixnum-tag-mask)
 146                (inst jmp :nz err)
 147                (if const
 148                    (cond ((typep const '(signed-byte 32))
 149                           (inst lea newval
 150                                 (make-ea :qword :base rax :disp const)))
 151                          (t
 152                           (inst mov newval const)
 153                           (inst add newval rax)))
 154                    ,(if (eq inherit 'cell-xsub)
 155                         `(progn (move newval rax)
 156                                 (inst sub newval delta))
 157                         `(inst lea newval
 158                                (make-ea :qword :base rax :index delta))))
 159                (inst cmpxchg
 160                      (make-ea-for-object-slot cell ,slot list-pointer-lowtag)
 161                      newval :lock)
 162                (inst jmp :ne retry)
 163                (inst mov result rax)))))))
 164   (def-atomic %atomic-inc-car cell-xadd cons-car-slot)
 165   (def-atomic %atomic-inc-cdr cell-xadd cons-cdr-slot)
 166   (def-atomic %atomic-dec-car cell-xsub cons-car-slot)
 167   (def-atomic %atomic-dec-cdr cell-xsub cons-cdr-slot))
 168
 169 ;;; SLOT-REF and SLOT-SET are used to define VOPs like CLOSURE-REF,
 170 ;;; where the offset is constant at compile time, but varies for
 171 ;;; different uses.
 172 (define-vop (slot-ref)
 173   (:args (object :scs (descriptor-reg)))
 174   (:results (value :scs (descriptor-reg any-reg)))
 175   (:variant-vars base lowtag)
 176   (:info offset)
 177   (:generator 4
 178     (loadw value object (+ base offset) lowtag)))
 179 (define-vop (slot-set)
 180   (:args (object :scs (descriptor-reg))
 181          (value :scs (descriptor-reg any-reg immediate)))
 182   (:temporary (:sc unsigned-reg) temp)
 183   (:variant-vars base lowtag)
 184   (:info offset)
 185   (:generator 4
 186      (if (sc-is value immediate)
 187          (let ((val (tn-value value)))
 188            (move-immediate (make-ea :qword :base object
 189                                     :disp (- (* (+ base offset) n-word-bytes)
 190                                              lowtag))
 191                            (etypecase val
 192                              (integer
 193                               (fixnumize val))
 194                              (symbol
 195                               (+ nil-value (static-symbol-offset val)))
 196                              (character
 197                               (logior (ash (char-code val) n-widetag-bits)
 198                                       character-widetag)))
 199                            temp))
 200          ;; Else, value not immediate.
 201          (storew value object (+ base offset) lowtag))))
 202
 203 (define-vop (slot-set-conditional)
 204   (:args (object :scs (descriptor-reg) :to :eval)
 205          (old-value :scs (descriptor-reg any-reg) :target eax)
 206          (new-value :scs (descriptor-reg any-reg) :target temp))
 207   (:temporary (:sc descriptor-reg :offset eax-offset
 208                    :from (:argument 1) :to :result :target result)  eax)
 209   (:temporary (:sc descriptor-reg :from (:argument 2) :to :result) temp)
 210   (:variant-vars base lowtag)
 211   (:results (result :scs (descriptor-reg)))
 212   (:info offset)
 213   (:generator 4
 214     (move eax old-value)
 215     (move temp new-value)
 216     (inst cmpxchg (make-ea :dword :base object
 217                            :disp (- (* (+ base offset) n-word-bytes) lowtag))
 218           temp)
 219     (move result eax)))
 220
 221 ;;; X86 special
 222 ;;; FIXME: Figure out whether we should delete this.
 223 ;;; It looks just like 'cell-xadd' and is buggy in the same ways:
 224 ;;;   - modifies 'value' operand which *should* be in the same physical reg
 225 ;;;     as 'result' operand, but would cause harm if not.
 226 ;;;   - operand width needs to be :qword
 227 ;;;   - :LOCK is missing
 228 (define-vop (slot-xadd)
 229   (:args (object :scs (descriptor-reg) :to :result)
 230          (value :scs (any-reg) :target result))
 231   (:results (result :scs (any-reg) :from (:argument 1)))
 232   (:result-types tagged-num)
 233   (:variant-vars base lowtag)
 234   (:info offset)
 235   (:generator 4
 236     (move result value)
 237     (inst xadd (make-ea :dword :base object
 238                         :disp (- (* (+ base offset) n-word-bytes) lowtag))
 239           value)))