src/compiler/x86/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-FUNCTION 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-function)
  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 :dword :base object
  82                         :disp (- (* offset word-bytes) lowtag))
  83           value)))
  84
  85 ;;; SLOT-REF and SLOT-SET are used to define VOPs like CLOSURE-REF,
  86 ;;; where the offset is constant at compile time, but varies for
  87 ;;; different uses.
  88 (define-vop (slot-ref)
  89   (:args (object :scs (descriptor-reg)))
  90   (:results (value :scs (descriptor-reg any-reg)))
  91   (:variant-vars base lowtag)
  92   (:info offset)
  93   (:generator 4
  94     (loadw value object (+ base offset) lowtag)))
  95 (define-vop (slot-set)
  96   (:args (object :scs (descriptor-reg))
  97          (value :scs (descriptor-reg any-reg immediate)))
  98   (:variant-vars base lowtag)
  99   (:info offset)
 100   (:generator 4
 101      (if (sc-is value immediate)
 102          (let ((val (tn-value value)))
 103            (etypecase val
 104              (integer
 105               (inst mov
 106                     (make-ea :dword :base object
 107                              :disp (- (* (+ base offset) word-bytes) lowtag))
 108                     (fixnumize val)))
 109              (symbol
 110               (inst mov
 111                     (make-ea :dword :base object
 112                              :disp (- (* (+ base offset) word-bytes) lowtag))
 113                     (+ nil-value (static-symbol-offset val))))
 114              (character
 115               (inst mov
 116                     (make-ea :dword :base object
 117                              :disp (- (* (+ base offset) word-bytes) lowtag))
 118                     (logior (ash (char-code val) type-bits)
 119                             base-char-type)))))
 120          ;; Else, value not immediate.
 121          (storew value object (+ base offset) lowtag))))
 122
 123 (define-vop (slot-set-conditional)
 124   (:args (object :scs (descriptor-reg) :to :eval)
 125          (old-value :scs (descriptor-reg any-reg) :target eax)
 126          (new-value :scs (descriptor-reg any-reg) :target temp))
 127   (:temporary (:sc descriptor-reg :offset eax-offset
 128                    :from (:argument 1) :to :result :target result)  eax)
 129   (:temporary (:sc descriptor-reg :from (:argument 2) :to :result) temp)
 130   (:variant-vars base lowtag)
 131   (:results (result :scs (descriptor-reg)))
 132   (:info offset)
 133   (:generator 4
 134     (move eax old-value)
 135     (move temp new-value)
 136     (inst cmpxchg (make-ea :dword :base object
 137                            :disp (- (* (+ base offset) word-bytes) lowtag))
 138           temp)
 139     (move result eax)))
 140
 141 ;;; X86 special
 142 (define-vop (slot-xadd)
 143   (:args (object :scs (descriptor-reg) :to :result)
 144          (value :scs (any-reg) :target result))
 145   (:results (result :scs (any-reg) :from (:argument 1)))
 146   (:result-types tagged-num)
 147   (:variant-vars base lowtag)
 148   (:info offset)
 149   (:generator 4
 150     (move result value)
 151     (inst xadd (make-ea :dword :base object
 152                         :disp (- (* (+ base offset) word-bytes) lowtag))
 153           value)))