src/compiler/x86/cell.lisp

   1 ;;;; various primitive memory access VOPs for the x86 VM
   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 (file-comment
  15  "$Header$")
  16 \f
  17 ;;;; data object ref/set stuff
  18
  19 (define-vop (slot)
  20   (:args (object :scs (descriptor-reg)))
  21   (:info name offset lowtag)
  22   (:ignore name)
  23   (:results (result :scs (descriptor-reg any-reg)))
  24   (:generator 1
  25     (loadw result object offset lowtag)))
  26
  27 (define-vop (set-slot)
  28   (:args (object :scs (descriptor-reg))
  29          (value :scs (descriptor-reg any-reg immediate)))
  30   (:info name offset lowtag)
  31   (:ignore name)
  32   (:results)
  33   (:generator 1
  34      (if (sc-is value immediate)
  35         (let ((val (tn-value value)))
  36            (etypecase val
  37               (integer
  38                (inst mov
  39                      (make-ea :dword :base object
  40                               :disp (- (* offset word-bytes) lowtag))
  41                      (fixnumize val)))
  42               (symbol
  43                (inst mov
  44                      (make-ea :dword :base object
  45                               :disp (- (* offset word-bytes) lowtag))
  46                      (+ *nil-value* (static-symbol-offset val))))
  47               (character
  48                (inst mov
  49                      (make-ea :dword :base object
  50                               :disp (- (* offset word-bytes) lowtag))
  51                      (logior (ash (char-code val) type-bits)
  52                              base-char-type)))))
  53        ;; Else, value not immediate.
  54        (storew value object offset lowtag))))
  55 \f
  56 ;;;; symbol hacking VOPs
  57
  58 ;;; these next two cf the sparc version, by jrd.
  59 ;;; FIXME: Deref this ^ reference.
  60
  61 ;;; The compiler likes to be able to directly SET symbols.
  62 (define-vop (set cell-set)
  63   (:variant symbol-value-slot other-pointer-type))
  64
  65 ;;; Do a cell ref with an error check for being unbound.
  66 (define-vop (checked-cell-ref)
  67   (:args (object :scs (descriptor-reg) :target obj-temp))
  68   (:results (value :scs (descriptor-reg any-reg)))
  69   (:policy :fast-safe)
  70   (:vop-var vop)
  71   (:save-p :compute-only)
  72   (:temporary (:sc descriptor-reg :from (:argument 0)) obj-temp))
  73
  74 ;;; With Symbol-Value, we check that the value isn't the trap object. So
  75 ;;; Symbol-Value of NIL is NIL.
  76 (define-vop (symbol-value)
  77   (:translate symbol-value)
  78   (:policy :fast-safe)
  79   (:args (object :scs (descriptor-reg) :to (:result 1)))
  80   (:results (value :scs (descriptor-reg any-reg)))
  81   (:vop-var vop)
  82   (:save-p :compute-only)
  83   (:generator 9
  84     (let ((err-lab (generate-error-code vop unbound-symbol-error object)))
  85       (loadw value object symbol-value-slot other-pointer-type)
  86       (inst cmp value unbound-marker-type)
  87       (inst jmp :e err-lab))))
  88
  89 (define-vop (fast-symbol-value cell-ref)
  90   (:variant symbol-value-slot other-pointer-type)
  91   (:policy :fast)
  92   (:translate symbol-value))
  93
  94 (defknown fast-symbol-value-xadd (symbol fixnum) fixnum ())
  95 (define-vop (fast-symbol-value-xadd cell-xadd)
  96   (:variant symbol-value-slot other-pointer-type)
  97   (:policy :fast)
  98   (:translate fast-symbol-value-xadd)
  99   (:arg-types * tagged-num))
 100
 101 (define-vop (boundp)
 102   (:translate boundp)
 103   (:policy :fast-safe)
 104   (:args (object :scs (descriptor-reg)))
 105   (:conditional)
 106   (:info target not-p)
 107   (:temporary (:sc descriptor-reg :from (:argument 0)) value)
 108   (:generator 9
 109     (loadw value object symbol-value-slot other-pointer-type)
 110     (inst cmp value unbound-marker-type)
 111     (inst jmp (if not-p :e :ne) target)))
 112
 113 (define-vop (symbol-hash)
 114   (:policy :fast-safe)
 115   (:translate symbol-hash)
 116   (:args (symbol :scs (descriptor-reg)))
 117   (:results (res :scs (any-reg)))
 118   (:result-types positive-fixnum)
 119   (:generator 2
 120     ;; The symbol-hash slot of NIL holds NIL because it is also the cdr slot,
 121     ;; so we have to strip off the two low bits to make sure it is a fixnum.
 122     ;;
 123     ;; FIXME: Is this still true? It seems to me from my reading of
 124     ;; the DEFINE-PRIMITIVE-OBJECT in objdef.lisp that the symbol-hash
 125     ;; is the second slot, and offset 0 = tags and stuff (and CAR slot in
 126     ;; a CONS), offset 1 = value slot (and CDR slot in a CONS), and
 127     ;; offset 2 = hash slot.
 128     (loadw res symbol symbol-hash-slot other-pointer-type)
 129     (inst and res (lognot #b11))))
 130 \f
 131 ;;;; fdefinition (fdefn) objects
 132
 133 (define-vop (fdefn-function cell-ref)   ; /pfw - alpha
 134   (:variant fdefn-function-slot other-pointer-type))
 135
 136 (define-vop (safe-fdefn-function)
 137   (:args (object :scs (descriptor-reg) :to (:result 1)))
 138   (:results (value :scs (descriptor-reg any-reg)))
 139   (:vop-var vop)
 140   (:save-p :compute-only)
 141   (:generator 10
 142     (loadw value object fdefn-function-slot other-pointer-type)
 143     (inst cmp value *nil-value*)
 144     ;; FIXME: UNDEFINED-SYMBOL-ERROR seems to actually be for symbols with no
 145     ;; function value, not, as the name might suggest, symbols with no ordinary
 146     ;; value. Perhaps the name could be made more mnemonic?
 147     (let ((err-lab (generate-error-code vop undefined-symbol-error object)))
 148       (inst jmp :e err-lab))))
 149
 150 (define-vop (set-fdefn-function)
 151   (:policy :fast-safe)
 152   (:translate (setf fdefn-function))
 153   (:args (function :scs (descriptor-reg) :target result)
 154          (fdefn :scs (descriptor-reg)))
 155   (:temporary (:sc unsigned-reg) raw)
 156   (:temporary (:sc byte-reg) type)
 157   (:results (result :scs (descriptor-reg)))
 158   (:generator 38
 159     (load-type type function (- function-pointer-type))
 160     (inst lea raw
 161           (make-ea :byte :base function
 162                    :disp (- (* function-code-offset word-bytes)
 163                             function-pointer-type)))
 164     (inst cmp type function-header-type)
 165     (inst jmp :e normal-fn)
 166     (inst lea raw (make-fixup (extern-alien-name "closure_tramp") :foreign))
 167     NORMAL-FN
 168     (storew function fdefn fdefn-function-slot other-pointer-type)
 169     (storew raw fdefn fdefn-raw-addr-slot other-pointer-type)
 170     (move result function)))
 171
 172 (define-vop (fdefn-makunbound)
 173   (:policy :fast-safe)
 174   (:translate fdefn-makunbound)
 175   (:args (fdefn :scs (descriptor-reg) :target result))
 176   (:results (result :scs (descriptor-reg)))
 177   (:generator 38
 178     (storew *nil-value* fdefn fdefn-function-slot other-pointer-type)
 179     (storew (make-fixup (extern-alien-name "undefined_tramp") :foreign)
 180             fdefn fdefn-raw-addr-slot other-pointer-type)
 181     (move result fdefn)))
 182 \f
 183 ;;;; binding and unbinding
 184
 185 ;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and
 186 ;;; the symbol on the binding stack and stuff the new value into the
 187 ;;; symbol.
 188
 189 (define-vop (bind)
 190   (:args (val :scs (any-reg descriptor-reg))
 191          (symbol :scs (descriptor-reg)))
 192   (:temporary (:sc unsigned-reg) temp bsp)
 193   (:generator 5
 194     (load-symbol-value bsp *binding-stack-pointer*)
 195     (loadw temp symbol symbol-value-slot other-pointer-type)
 196     (inst add bsp (* binding-size word-bytes))
 197     (store-symbol-value bsp *binding-stack-pointer*)
 198     (storew temp bsp (- binding-value-slot binding-size))
 199     (storew symbol bsp (- binding-symbol-slot binding-size))
 200     (storew val symbol symbol-value-slot other-pointer-type)))
 201
 202 (define-vop (unbind)
 203   (:temporary (:sc unsigned-reg) symbol value bsp)
 204   (:generator 0
 205     (load-symbol-value bsp *binding-stack-pointer*)
 206     (loadw symbol bsp (- binding-symbol-slot binding-size))
 207     (loadw value bsp (- binding-value-slot binding-size))
 208     (storew value symbol symbol-value-slot other-pointer-type)
 209     (storew 0 bsp (- binding-symbol-slot binding-size))
 210     (inst sub bsp (* binding-size word-bytes))
 211     (store-symbol-value bsp *binding-stack-pointer*)))
 212
 213 (define-vop (unbind-to-here)
 214   (:args (where :scs (descriptor-reg any-reg)))
 215   (:temporary (:sc unsigned-reg) symbol value bsp)
 216   (:generator 0
 217     (load-symbol-value bsp *binding-stack-pointer*)
 218     (inst cmp where bsp)
 219     (inst jmp :e done)
 220
 221     LOOP
 222     (loadw symbol bsp (- binding-symbol-slot binding-size))
 223     (inst or symbol symbol)
 224     (inst jmp :z skip)
 225     (loadw value bsp (- binding-value-slot binding-size))
 226     (storew value symbol symbol-value-slot other-pointer-type)
 227     (storew 0 bsp (- binding-symbol-slot binding-size))
 228
 229     SKIP
 230     (inst sub bsp (* binding-size word-bytes))
 231     (inst cmp where bsp)
 232     (inst jmp :ne loop)
 233     (store-symbol-value bsp *binding-stack-pointer*)
 234
 235     DONE))
 236 \f
 237 ;;;; closure indexing
 238
 239 (define-full-reffer closure-index-ref *
 240   closure-info-offset function-pointer-type
 241   (any-reg descriptor-reg) * %closure-index-ref)
 242
 243 (define-full-setter set-funcallable-instance-info *
 244   funcallable-instance-info-offset function-pointer-type
 245   (any-reg descriptor-reg) * %set-funcallable-instance-info)
 246
 247 (define-full-reffer funcallable-instance-info *
 248   funcallable-instance-info-offset function-pointer-type
 249   (descriptor-reg any-reg) * %funcallable-instance-info)
 250
 251 (define-vop (funcallable-instance-lexenv cell-ref)
 252   (:variant funcallable-instance-lexenv-slot function-pointer-type))
 253
 254 (define-vop (closure-ref slot-ref)
 255   (:variant closure-info-offset function-pointer-type))
 256
 257 (define-vop (closure-init slot-set)
 258   (:variant closure-info-offset function-pointer-type))
 259 \f
 260 ;;;; value cell hackery
 261
 262 (define-vop (value-cell-ref cell-ref)
 263   (:variant value-cell-value-slot other-pointer-type))
 264
 265 (define-vop (value-cell-set cell-set)
 266   (:variant value-cell-value-slot other-pointer-type))
 267 \f
 268 ;;;; structure hackery
 269
 270 (define-vop (instance-length)
 271   (:policy :fast-safe)
 272   (:translate %instance-length)
 273   (:args (struct :scs (descriptor-reg)))
 274   (:results (res :scs (unsigned-reg)))
 275   (:result-types positive-fixnum)
 276   (:generator 4
 277     (loadw res struct 0 instance-pointer-type)
 278     (inst shr res type-bits)))
 279
 280 (define-vop (instance-ref slot-ref)
 281   (:variant instance-slots-offset instance-pointer-type)
 282   (:policy :fast-safe)
 283   (:translate %instance-ref)
 284   (:arg-types instance (:constant index)))
 285
 286 (define-vop (instance-set slot-set)
 287   (:policy :fast-safe)
 288   (:translate %instance-set)
 289   (:variant instance-slots-offset instance-pointer-type)
 290   (:arg-types instance (:constant index) *))
 291
 292 (define-full-reffer instance-index-ref * instance-slots-offset
 293   instance-pointer-type (any-reg descriptor-reg) * %instance-ref)
 294
 295 (define-full-setter instance-index-set * instance-slots-offset
 296   instance-pointer-type (any-reg descriptor-reg) * %instance-set)
 297
 298 (defknown sb!kernel::%instance-set-conditional (instance index t t) t
 299   (unsafe))
 300
 301 (define-vop (instance-set-conditional-c slot-set-conditional)
 302   (:policy :fast-safe)
 303   (:translate sb!kernel::%instance-set-conditional)
 304   (:variant instance-slots-offset instance-pointer-type)
 305   (:arg-types instance (:constant index) * *))
 306
 307 (define-vop (instance-set-conditional)
 308   (:translate sb!kernel::%instance-set-conditional)
 309   (:args (object :scs (descriptor-reg) :to :eval)
 310          (slot :scs (any-reg) :to :result)
 311          (old-value :scs (descriptor-reg any-reg) :target eax)
 312          (new-value :scs (descriptor-reg any-reg) :target temp))
 313   (:arg-types instance positive-fixnum * *)
 314   (:temporary (:sc descriptor-reg :offset eax-offset
 315                    :from (:argument 1) :to :result :target result)  eax)
 316   (:temporary (:sc descriptor-reg :from (:argument 2) :to :result) temp)
 317   (:results (result :scs (descriptor-reg)))
 318   (:policy :fast-safe)
 319   (:generator 5
 320     (move eax old-value)
 321     (move temp new-value)
 322     (inst cmpxchg (make-ea :dword :base object :index slot :scale 1
 323                            :disp (- (* instance-slots-offset word-bytes)
 324                                     instance-pointer-type))
 325           temp)
 326     (move result eax)))
 327
 328 (defknown %instance-xadd (instance index fixnum) fixnum ())
 329 (define-vop (instance-xadd-c slot-xadd)
 330   (:policy :fast-safe)
 331   (:translate %instance-xadd)
 332   (:variant instance-slots-offset instance-pointer-type)
 333   (:arg-types instance (:constant index) tagged-num))
 334 \f
 335 ;;;; code object frobbing
 336
 337 (define-full-reffer code-header-ref * 0 other-pointer-type
 338   (any-reg descriptor-reg) * code-header-ref)
 339
 340 (define-full-setter code-header-set * 0 other-pointer-type
 341   (any-reg descriptor-reg) * code-header-set)