compiler/alpha/cell.lisp

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