-;;; -*- Package: ALPHA; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the CMU Common Lisp project at
-;;; Carnegie Mellon University, and has been placed in the public domain.
-;;;
-
-;;;
-;;; **********************************************************************
-;;;
-;;; This file contains the VM definition of various primitive memory access
-;;; VOPs for the Alpha.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-;;; Converted by Sean Hallgren
-;;;
+;;;; the VM definition of various primitive memory access VOPs for the
+;;;; Alpha
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
(in-package "SB!VM")
-
-
\f
-;;;; Data object ref/set stuff.
+;;;; data object ref/set stuff
(define-vop (slot)
(:args (object :scs (descriptor-reg)))
(storew value object offset lowtag))
#-gengc
(storew value object offset lowtag)))
-
\f
-;;;; Symbol hacking VOPs:
+;;;; symbol hacking VOPs
;;; The compiler likes to be able to directly SET symbols.
-;;;
(define-vop (set cell-set)
- (:variant symbol-value-slot other-pointer-type))
+ (:variant symbol-value-slot other-pointer-lowtag))
;;; Do a cell ref with an error check for being unbound.
-;;;
(define-vop (checked-cell-ref)
(:args (object :scs (descriptor-reg) :target obj-temp))
(:results (value :scs (descriptor-reg any-reg)))
(:temporary (:scs (non-descriptor-reg)) temp)
(:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp))
-;;; With Symbol-Value, we check that the value isn't the trap object. So
-;;; Symbol-Value of NIL is NIL.
-;;;
+;;; With SYMBOL-VALUE, we check that the value isn't the trap object.
+;;; So SYMBOL-VALUE of NIL is NIL.
(define-vop (symbol-value checked-cell-ref)
(:translate symbol-value)
(:generator 9
(move object obj-temp)
- (loadw value obj-temp symbol-value-slot other-pointer-type)
+ (loadw value obj-temp symbol-value-slot other-pointer-lowtag)
(let ((err-lab (generate-error-code vop unbound-symbol-error obj-temp)))
- (inst xor value unbound-marker-type temp)
+ (inst xor value unbound-marker-widetag temp)
(inst beq temp err-lab))))
-;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell is bound.
+;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell
+;;; is bound.
(define-vop (boundp-frob)
(:args (object :scs (descriptor-reg)))
(:conditional)
(define-vop (boundp boundp-frob)
(:translate boundp)
(:generator 9
- (loadw value object symbol-value-slot other-pointer-type)
- (inst xor value unbound-marker-type temp)
+ (loadw value object symbol-value-slot other-pointer-lowtag)
+ (inst xor value unbound-marker-widetag temp)
(if not-p
(inst beq temp target)
(inst bne temp target))))
(define-vop (fast-symbol-value cell-ref)
- (:variant symbol-value-slot other-pointer-type)
+ (:variant symbol-value-slot other-pointer-lowtag)
(:policy :fast)
(:translate symbol-value))
\f
-;;;; Fdefinition (fdefn) objects.
+;;;; fdefinition (FDEFN) objects
-(define-vop (fdefn-function cell-ref)
- (:variant fdefn-function-slot other-pointer-type))
+(define-vop (fdefn-fun cell-ref)
+ (:variant fdefn-fun-slot other-pointer-lowtag))
-(define-vop (safe-fdefn-function)
+(define-vop (safe-fdefn-fun)
(:args (object :scs (descriptor-reg) :target obj-temp))
(:results (value :scs (descriptor-reg any-reg)))
(:vop-var vop)
(:temporary (:scs (non-descriptor-reg)) temp)
(:generator 10
(move object obj-temp)
- (loadw value obj-temp fdefn-function-slot other-pointer-type)
+ (loadw value obj-temp fdefn-fun-slot other-pointer-lowtag)
(let ((err-lab (generate-error-code vop undefined-symbol-error obj-temp)))
(inst cmpeq value null-tn temp)
(inst bne temp err-lab))))
-(define-vop (set-fdefn-function)
+(define-vop (set-fdefn-fun)
(:policy :fast-safe)
- (:translate (setf fdefn-function))
+ (:translate (setf fdefn-fun))
(:args (function :scs (descriptor-reg) :target result)
(fdefn :scs (descriptor-reg)))
(:temporary (:scs (interior-reg)) lip)
(:results (result :scs (descriptor-reg)))
(:generator 38
(let ((normal-fn (gen-label)))
- (load-type type function (- function-pointer-type))
- (inst xor type function-header-type type)
+ (load-type type function (- fun-pointer-lowtag))
+ (inst xor type simple-fun-header-widetag type)
(inst addq function
- (- (ash function-code-offset word-shift) function-pointer-type)
+ (- (ash simple-fun-code-offset word-shift) fun-pointer-lowtag)
lip)
(inst beq type normal-fn)
(inst li (make-fixup "closure_tramp" :foreign) lip)
(emit-label normal-fn)
- (storew lip fdefn fdefn-raw-addr-slot other-pointer-type)
- (storew function fdefn fdefn-function-slot other-pointer-type)
+ (storew lip fdefn fdefn-raw-addr-slot other-pointer-lowtag)
+ (storew function fdefn fdefn-fun-slot other-pointer-lowtag)
(move function result))))
(:temporary (:scs (non-descriptor-reg)) temp)
(:results (result :scs (descriptor-reg)))
(:generator 38
- (storew null-tn fdefn fdefn-function-slot other-pointer-type)
+ (storew null-tn fdefn fdefn-fun-slot other-pointer-lowtag)
(inst li (make-fixup "undefined_tramp" :foreign) temp)
(move fdefn result)
- (storew temp fdefn fdefn-raw-addr-slot other-pointer-type)))
-
-
+ (storew temp fdefn fdefn-raw-addr-slot other-pointer-lowtag)))
\f
-;;;; Binding and Unbinding.
-
-;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and
-;;; the symbol on the binding stack and stuff the new value into the
-;;; symbol.
+;;;; binding and Unbinding
+;;; Establish VAL as a binding for SYMBOL. Save the old value and the
+;;; symbol on the binding stack and stuff the new value into the symbol.
(define-vop (bind)
(:args (val :scs (any-reg descriptor-reg))
(symbol :scs (descriptor-reg)))
(:temporary (:scs (descriptor-reg)) temp)
(:generator 5
- (loadw temp symbol symbol-value-slot other-pointer-type)
- (inst addq bsp-tn (* 2 word-bytes) bsp-tn)
+ (loadw temp symbol symbol-value-slot other-pointer-lowtag)
+ (inst addq bsp-tn (* 2 n-word-bytes) bsp-tn)
(storew temp bsp-tn (- binding-value-slot binding-size))
(storew symbol bsp-tn (- binding-symbol-slot binding-size))
(#+gengc storew-and-remember-slot #-gengc storew
- val symbol symbol-value-slot other-pointer-type)))
+ val symbol symbol-value-slot other-pointer-lowtag)))
(define-vop (unbind)
(loadw symbol bsp-tn (- binding-symbol-slot binding-size))
(loadw value bsp-tn (- binding-value-slot binding-size))
(#+gengc storew-and-remember-slot #-gengc storew
- value symbol symbol-value-slot other-pointer-type)
+ value symbol symbol-value-slot other-pointer-lowtag)
(storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
- (inst subq bsp-tn (* 2 word-bytes) bsp-tn)))
+ (inst subq bsp-tn (* 2 n-word-bytes) bsp-tn)))
(define-vop (unbind-to-here)
(loadw value bsp-tn (- binding-value-slot binding-size))
(inst beq symbol skip)
(#+gengc storew-and-remember-slot #-gengc storew
- value symbol symbol-value-slot other-pointer-type)
+ value symbol symbol-value-slot other-pointer-lowtag)
(storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
(emit-label skip)
- (inst subq bsp-tn (* 2 word-bytes) bsp-tn)
+ (inst subq bsp-tn (* 2 n-word-bytes) bsp-tn)
(inst cmpeq where bsp-tn temp)
(inst beq temp loop)
(emit-label done))))
-
-
\f
-;;;; Closure indexing.
+;;;; closure indexing
(define-full-reffer closure-index-ref *
- closure-info-offset function-pointer-type
+ closure-info-offset fun-pointer-lowtag
(descriptor-reg any-reg) * %closure-index-ref)
(define-full-setter set-funcallable-instance-info *
- funcallable-instance-info-offset function-pointer-type
+ funcallable-instance-info-offset fun-pointer-lowtag
(descriptor-reg any-reg null zero) * %set-funcallable-instance-info)
(define-full-reffer funcallable-instance-info *
- funcallable-instance-info-offset function-pointer-type
+ funcallable-instance-info-offset fun-pointer-lowtag
(descriptor-reg any-reg) * %funcallable-instance-info)
(define-vop (funcallable-instance-lexenv cell-ref)
- (:variant funcallable-instance-lexenv-slot function-pointer-type))
+ (:variant funcallable-instance-lexenv-slot fun-pointer-lowtag))
(define-vop (closure-ref slot-ref)
- (:variant closure-info-offset function-pointer-type))
+ (:variant closure-info-offset fun-pointer-lowtag))
(define-vop (closure-init slot-set)
- (:variant closure-info-offset function-pointer-type))
-
+ (:variant closure-info-offset fun-pointer-lowtag))
\f
-;;;; Value Cell hackery.
+;;;; value cell hackery
(define-vop (value-cell-ref cell-ref)
- (:variant value-cell-value-slot other-pointer-type))
+ (:variant value-cell-value-slot other-pointer-lowtag))
(define-vop (value-cell-set cell-set)
- (:variant value-cell-value-slot other-pointer-type))
-
-
+ (:variant value-cell-value-slot other-pointer-lowtag))
\f
-;;;; Instance hackery:
+;;;; instance hackery
(define-vop (instance-length)
(:policy :fast-safe)
(:results (res :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:generator 4
- (loadw res struct 0 instance-pointer-type)
- (inst srl res type-bits res)))
+ (loadw res struct 0 instance-pointer-lowtag)
+ (inst srl res n-widetag-bits res)))
(define-vop (instance-ref slot-ref)
- (:variant instance-slots-offset instance-pointer-type)
+ (:variant instance-slots-offset instance-pointer-lowtag)
(:policy :fast-safe)
(:translate %instance-ref)
(:arg-types instance (:constant index)))
(define-vop (instance-set slot-set)
(:policy :fast-safe)
(:translate %instance-set)
- (:variant instance-slots-offset instance-pointer-type)
+ (:variant instance-slots-offset instance-pointer-lowtag)
(:arg-types instance (:constant index) *))
(define-full-reffer instance-index-ref * instance-slots-offset
- instance-pointer-type (descriptor-reg any-reg) * %instance-ref)
+ instance-pointer-lowtag (descriptor-reg any-reg) * %instance-ref)
(define-full-setter instance-index-set * instance-slots-offset
- instance-pointer-type (descriptor-reg any-reg null zero) * %instance-set)
-
-
+ instance-pointer-lowtag (descriptor-reg any-reg null zero) * %instance-set)
\f
-;;;; Code object frobbing.
+;;;; code object frobbing
-(define-full-reffer code-header-ref * 0 other-pointer-type
+(define-full-reffer code-header-ref * 0 other-pointer-lowtag
(descriptor-reg any-reg) * code-header-ref)
-(define-full-setter code-header-set * 0 other-pointer-type
+(define-full-setter code-header-set * 0 other-pointer-lowtag
(descriptor-reg any-reg null zero) * code-header-set)
-
-
\f
-;;;; Mutator accessing.
+;;;; mutator accessing
+
+#+gengc
+(progn
-#+gengc (progn
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ ;; SBCL has never had GENGC. Now that we have Alpha support, it
+ ;; would probably be nice to restore GENGC support so that the Alpha
+ ;; doesn't have to crawl along with stop'n'copy. When we do, the CMU
+ ;; CL code below will need updating to the SBCL way of looking at
+ ;; things, e.g. at least using "SB-KERNEL" or "SB!KERNEL" instead of
+ ;; :KERNEL. -- WHN 2001-05-08
+ (error "This code is stale as of sbcl-0.6.12."))
(define-vop (mutator-ub32-ref)
(:policy :fast-safe)
(lisp-type ref-vop set-vop)
(ecase type
(:des
- (values t 'mutator-descriptor-ref 'mutator-descriptor-set))
+ (values t
+ 'mutator-descriptor-ref
+ 'mutator-descriptor-set))
(:ub32
- (values '(unsigned-byte 32) 'mutator-ub32-ref 'mutator-ub32-set))
+ (values '(unsigned-byte 32)
+ 'mutator-ub32-ref
+ 'mutator-ub32-set))
(:sap
- (values 'system-area-pointer 'mutator-sap-ref 'mutator-sap-set)))
+ (values 'system-area-pointer
+ 'mutator-sap-ref
+ 'mutator-sap-set)))
`(progn
(export ',fn :kernel)
(defknown ,fn () ,lisp-type (flushable))
(:translate ,fn)
(:variant ,offset))
,@(when writable
- `((defknown ((setf ,fn)) (,lisp-type) ,lisp-type (unsafe))
+ `((defknown ((setf ,fn)) (,lisp-type) ,lisp-type
+ (unsafe))
(define-vop (,set ,set-vop)
(:translate (setf ,fn))
(:variant ,offset)))))))))
projects / sbcl.git / blobdiff