src/compiler/alpha/cell.lisp

   1 ;;;; the VM definition of various primitive memory access VOPs for the
   2 ;;;; Alpha
   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 \f
  15 ;;;; data object ref/set stuff
  16
  17 (define-vop (slot)
  18   (:args (object :scs (descriptor-reg)))
  19   (:info name offset lowtag)
  20   (:ignore name)
  21   (:results (result :scs (descriptor-reg any-reg)))
  22   (:generator 1
  23     (loadw result object offset lowtag)))
  24
  25 (define-vop (set-slot)
  26   (:args (object :scs (descriptor-reg))
  27          (value :scs (descriptor-reg any-reg null zero)))
  28   (:info name offset lowtag #+gengc remember)
  29   (:ignore name)
  30   (:results)
  31   (:generator 1
  32     #+gengc
  33     (if remember
  34         (storew-and-remember-slot value object offset lowtag)
  35         (storew value object offset lowtag))
  36     #-gengc
  37     (storew value object offset lowtag)))
  38 \f
  39 ;;;; symbol hacking VOPs
  40
  41 ;;; The compiler likes to be able to directly SET symbols.
  42 (define-vop (set cell-set)
  43   (:variant symbol-value-slot other-pointer-type))
  44
  45 ;;; Do a cell ref with an error check for being unbound.
  46 (define-vop (checked-cell-ref)
  47   (:args (object :scs (descriptor-reg) :target obj-temp))
  48   (:results (value :scs (descriptor-reg any-reg)))
  49   (:policy :fast-safe)
  50   (:vop-var vop)
  51   (:save-p :compute-only)
  52   (:temporary (:scs (non-descriptor-reg)) temp)
  53   (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp))
  54
  55 ;;; With SYMBOL-VALUE, we check that the value isn't the trap object.
  56 ;;; So SYMBOL-VALUE of NIL is NIL.
  57 (define-vop (symbol-value checked-cell-ref)
  58   (:translate symbol-value)
  59   (:generator 9
  60     (move object obj-temp)
  61     (loadw value obj-temp symbol-value-slot other-pointer-type)
  62     (let ((err-lab (generate-error-code vop unbound-symbol-error obj-temp)))
  63       (inst xor value unbound-marker-type temp)
  64       (inst beq temp err-lab))))
  65
  66 ;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell
  67 ;;; is bound.
  68 (define-vop (boundp-frob)
  69   (:args (object :scs (descriptor-reg)))
  70   (:conditional)
  71   (:info target not-p)
  72   (:policy :fast-safe)
  73   (:temporary (:scs (descriptor-reg)) value)
  74   (:temporary (:scs (non-descriptor-reg)) temp))
  75
  76 (define-vop (boundp boundp-frob)
  77   (:translate boundp)
  78   (:generator 9
  79     (loadw value object symbol-value-slot other-pointer-type)
  80     (inst xor value unbound-marker-type temp)
  81     (if not-p
  82         (inst beq temp target)
  83         (inst bne temp target))))
  84
  85 (define-vop (fast-symbol-value cell-ref)
  86   (:variant symbol-value-slot other-pointer-type)
  87   (:policy :fast)
  88   (:translate symbol-value))
  89
  90
  91 \f
  92 ;;;; fdefinition (FDEFN) objects
  93
  94 (define-vop (fdefn-fun cell-ref)
  95   (:variant fdefn-fun-slot other-pointer-type))
  96
  97 (define-vop (safe-fdefn-fun)
  98   (:args (object :scs (descriptor-reg) :target obj-temp))
  99   (:results (value :scs (descriptor-reg any-reg)))
 100   (:vop-var vop)
 101   (:save-p :compute-only)
 102   (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp)
 103   (:temporary (:scs (non-descriptor-reg)) temp)
 104   (:generator 10
 105     (move object obj-temp)
 106     (loadw value obj-temp fdefn-fun-slot other-pointer-type)
 107     (let ((err-lab (generate-error-code vop undefined-symbol-error obj-temp)))
 108       (inst cmpeq value null-tn temp)
 109       (inst bne temp err-lab))))
 110
 111 (define-vop (set-fdefn-fun)
 112   (:policy :fast-safe)
 113   (:translate (setf fdefn-fun))
 114   (:args (function :scs (descriptor-reg) :target result)
 115          (fdefn :scs (descriptor-reg)))
 116   (:temporary (:scs (interior-reg)) lip)
 117   (:temporary (:scs (non-descriptor-reg)) type)
 118   (:results (result :scs (descriptor-reg)))
 119   (:generator 38
 120     (let ((normal-fn (gen-label)))
 121       (load-type type function (- fun-pointer-type))
 122       (inst xor type simple-fun-header-type type)
 123       (inst addq function
 124             (- (ash simple-fun-code-offset word-shift) fun-pointer-type)
 125             lip)
 126       (inst beq type normal-fn)
 127       (inst li (make-fixup "closure_tramp" :foreign) lip)
 128       (emit-label normal-fn)
 129       (storew lip fdefn fdefn-raw-addr-slot other-pointer-type)
 130       (storew function fdefn fdefn-fun-slot other-pointer-type)
 131       (move function result))))
 132
 133
 134 (define-vop (fdefn-makunbound)
 135   (:policy :fast-safe)
 136   (:translate fdefn-makunbound)
 137   (:args (fdefn :scs (descriptor-reg) :target result))
 138   (:temporary (:scs (non-descriptor-reg)) temp)
 139   (:results (result :scs (descriptor-reg)))
 140   (:generator 38
 141     (storew null-tn fdefn fdefn-fun-slot other-pointer-type)
 142     (inst li (make-fixup "undefined_tramp" :foreign) temp)
 143     (move fdefn result)
 144     (storew temp fdefn fdefn-raw-addr-slot other-pointer-type)))
 145 \f
 146 ;;;; binding and Unbinding
 147
 148 ;;; Establish VAL as a binding for SYMBOL. Save the old value and the
 149 ;;; symbol on the binding stack and stuff the new value into the symbol.
 150 (define-vop (bind)
 151   (:args (val :scs (any-reg descriptor-reg))
 152          (symbol :scs (descriptor-reg)))
 153   (:temporary (:scs (descriptor-reg)) temp)
 154   (:generator 5
 155     (loadw temp symbol symbol-value-slot other-pointer-type)
 156     (inst addq bsp-tn (* 2 word-bytes) bsp-tn)
 157     (storew temp bsp-tn (- binding-value-slot binding-size))
 158     (storew symbol bsp-tn (- binding-symbol-slot binding-size))
 159     (#+gengc storew-and-remember-slot #-gengc storew
 160              val symbol symbol-value-slot other-pointer-type)))
 161
 162
 163 (define-vop (unbind)
 164   (:temporary (:scs (descriptor-reg)) symbol value)
 165   (:generator 0
 166     (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
 167     (loadw value bsp-tn (- binding-value-slot binding-size))
 168     (#+gengc storew-and-remember-slot #-gengc storew
 169              value symbol symbol-value-slot other-pointer-type)
 170     (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
 171     (inst subq bsp-tn (* 2 word-bytes) bsp-tn)))
 172
 173
 174 (define-vop (unbind-to-here)
 175   (:args (arg :scs (descriptor-reg any-reg) :target where))
 176   (:temporary (:scs (any-reg) :from (:argument 0)) where)
 177   (:temporary (:scs (descriptor-reg)) symbol value)
 178   (:temporary (:scs (non-descriptor-reg)) temp)
 179   (:generator 0
 180     (let ((loop (gen-label))
 181           (skip (gen-label))
 182           (done (gen-label)))
 183       (move arg where)
 184       (inst cmpeq where bsp-tn temp)
 185       (inst bne temp done)
 186
 187       (emit-label loop)
 188       (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
 189       (loadw value bsp-tn (- binding-value-slot binding-size))
 190       (inst beq symbol skip)
 191       (#+gengc storew-and-remember-slot #-gengc storew
 192                value symbol symbol-value-slot other-pointer-type)
 193       (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
 194
 195       (emit-label skip)
 196       (inst subq bsp-tn (* 2 word-bytes) bsp-tn)
 197       (inst cmpeq where bsp-tn temp)
 198       (inst beq temp loop)
 199
 200       (emit-label done))))
 201 \f
 202 ;;;; closure indexing
 203
 204 (define-full-reffer closure-index-ref *
 205   closure-info-offset fun-pointer-type
 206   (descriptor-reg any-reg) * %closure-index-ref)
 207
 208 (define-full-setter set-funcallable-instance-info *
 209   funcallable-instance-info-offset fun-pointer-type
 210   (descriptor-reg any-reg null zero) * %set-funcallable-instance-info)
 211
 212 (define-full-reffer funcallable-instance-info *
 213   funcallable-instance-info-offset fun-pointer-type
 214   (descriptor-reg any-reg) * %funcallable-instance-info)
 215
 216 (define-vop (funcallable-instance-lexenv cell-ref)
 217   (:variant funcallable-instance-lexenv-slot fun-pointer-type))
 218
 219 (define-vop (closure-ref slot-ref)
 220   (:variant closure-info-offset fun-pointer-type))
 221
 222 (define-vop (closure-init slot-set)
 223   (:variant closure-info-offset fun-pointer-type))
 224 \f
 225 ;;;; value cell hackery
 226
 227 (define-vop (value-cell-ref cell-ref)
 228   (:variant value-cell-value-slot other-pointer-type))
 229
 230 (define-vop (value-cell-set cell-set)
 231   (:variant value-cell-value-slot other-pointer-type))
 232 \f
 233 ;;;; instance hackery
 234
 235 (define-vop (instance-length)
 236   (:policy :fast-safe)
 237   (:translate %instance-length)
 238   (:args (struct :scs (descriptor-reg)))
 239   (:results (res :scs (unsigned-reg)))
 240   (:result-types positive-fixnum)
 241   (:generator 4
 242     (loadw res struct 0 instance-pointer-type)
 243     (inst srl res type-bits res)))
 244
 245 (define-vop (instance-ref slot-ref)
 246   (:variant instance-slots-offset instance-pointer-type)
 247   (:policy :fast-safe)
 248   (:translate %instance-ref)
 249   (:arg-types instance (:constant index)))
 250
 251 (define-vop (instance-set slot-set)
 252   (:policy :fast-safe)
 253   (:translate %instance-set)
 254   (:variant instance-slots-offset instance-pointer-type)
 255   (:arg-types instance (:constant index) *))
 256
 257 (define-full-reffer instance-index-ref * instance-slots-offset
 258   instance-pointer-type (descriptor-reg any-reg) * %instance-ref)
 259
 260 (define-full-setter instance-index-set * instance-slots-offset
 261   instance-pointer-type (descriptor-reg any-reg null zero) * %instance-set)
 262 \f
 263 ;;;; code object frobbing
 264
 265 (define-full-reffer code-header-ref * 0 other-pointer-type
 266   (descriptor-reg any-reg) * code-header-ref)
 267
 268 (define-full-setter code-header-set * 0 other-pointer-type
 269   (descriptor-reg any-reg null zero) * code-header-set)
 270 \f
 271 ;;;; mutator accessing
 272
 273 #+gengc
 274 (progn
 275
 276 (eval-when (:compile-toplevel :load-toplevel :execute)
 277   ;; SBCL has never had GENGC. Now that we have Alpha support, it
 278   ;; would probably be nice to restore GENGC support so that the Alpha
 279   ;; doesn't have to crawl along with stop'n'copy. When we do, the CMU
 280   ;; CL code below will need updating to the SBCL way of looking at
 281   ;; things, e.g. at least using "SB-KERNEL" or "SB!KERNEL" instead of
 282   ;; :KERNEL. -- WHN 2001-05-08
 283   (error "This code is stale as of sbcl-0.6.12."))
 284
 285 (define-vop (mutator-ub32-ref)
 286   (:policy :fast-safe)
 287   (:args)
 288   (:results (res :scs (unsigned-reg)))
 289   (:result-types unsigned-num)
 290   (:variant-vars slot)
 291   (:generator 2
 292     (loadw res mutator-tn slot)))
 293
 294 (define-vop (mutator-descriptor-ref mutator-ub32-ref)
 295   (:results (res :scs (any-reg descriptor-reg)))
 296   (:result-types *))
 297
 298 (define-vop (mutator-sap-ref mutator-ub32-ref)
 299   (:results (res :scs (sap-reg)))
 300   (:result-types system-area-pointer))
 301
 302
 303 (define-vop (mutator-ub32-set)
 304   (:policy :fast-safe)
 305   (:args (arg :scs (unsigned-reg) :target res))
 306   (:arg-types unsigned-num)
 307   (:results (res :scs (unsigned-reg)))
 308   (:result-types unsigned-num)
 309   (:variant-vars slot)
 310   (:generator 2
 311     (storew arg mutator-tn slot)
 312     (move res arg)))
 313
 314 (define-vop (mutator-descriptor-set mutator-ub32-set)
 315   (:args (arg :scs (any-reg descriptor-reg null zero) :target res))
 316   (:arg-types *)
 317   (:results (res :scs (any-reg descriptor-reg)))
 318   (:result-types *))
 319
 320 (define-vop (mutator-sap-set mutator-ub32-set)
 321   (:args (arg :scs (sap-reg) :target res))
 322   (:arg-types system-area-pointer)
 323   (:results (res :scs (sap-reg)))
 324   (:result-types system-area-pointer))
 325
 326
 327 (macrolet ((define-mutator-accessors (slot type writable)
 328              (let ((ref (symbolicate "MUTATOR-" slot "-REF"))
 329                    (set (and writable (symbolicate "MUTATOR-" slot "-SET")))
 330                    (offset (symbolicate "MUTATOR-" slot "-SLOT"))
 331                    (fn
 332                     (let ((*package* (find-package :kernel)))
 333              (symbolicate "MUTATOR-" slot))))
 334                (multiple-value-bind
 335                    (lisp-type ref-vop set-vop)
 336                    (ecase type
 337                      (:des
 338                       (values t
 339                               'mutator-descriptor-ref
 340                               'mutator-descriptor-set))
 341                      (:ub32
 342                       (values '(unsigned-byte 32)
 343                               'mutator-ub32-ref
 344                               'mutator-ub32-set))
 345                      (:sap
 346                       (values 'system-area-pointer
 347                               'mutator-sap-ref
 348                               'mutator-sap-set)))
 349                  `(progn
 350                     (export ',fn :kernel)
 351                     (defknown ,fn () ,lisp-type (flushable))
 352                     (define-vop (,ref ,ref-vop)
 353                       (:translate ,fn)
 354                       (:variant ,offset))
 355                     ,@(when writable
 356                         `((defknown ((setf ,fn)) (,lisp-type) ,lisp-type
 357                             (unsafe))
 358                           (define-vop (,set ,set-vop)
 359                             (:translate (setf ,fn))
 360                             (:variant ,offset)))))))))
 361   (define-mutator-accessors thread :des t)
 362   (define-mutator-accessors suspends-disabled-count :ub32 t)
 363   (define-mutator-accessors suspend-pending :ub32 t)
 364   (define-mutator-accessors control-stack-base :sap nil)
 365   (define-mutator-accessors control-stack-end :sap nil)
 366   (define-mutator-accessors current-unwind-protect :sap nil)
 367   (define-mutator-accessors current-catch-block :sap nil)
 368   (define-mutator-accessors binding-stack-base :sap nil)
 369   (define-mutator-accessors binding-stack-end :sap nil)
 370   (define-mutator-accessors number-stack-base :sap nil)
 371   (define-mutator-accessors number-stack-end :sap nil)
 372   (define-mutator-accessors eval-stack :des t)
 373   (define-mutator-accessors eval-stack-top :ub32 t)
 374   (define-mutator-accessors nursery-start :sap nil)
 375   (define-mutator-accessors nursery-end :sap nil)
 376   (define-mutator-accessors storebuf-start :sap nil)
 377   (define-mutator-accessors storebuf-end :sap nil)
 378   (define-mutator-accessors words-consed :ub32 nil))
 379
 380 ); #+gengc progn