"DOUBLE-FLOAT-TYPE" "DOUBLE-FLOAT-VALUE-SLOT"
"DOUBLE-INT-CARG-REG-SC-NUMBER" "DOUBLE-REG-SC-NUMBER"
"DOUBLE-STACK-SC-NUMBER"
- "ERROR-TRAP" "EVEN-FIXNUM-TYPE"
+ "ERROR-TRAP" "EVEN-FIXNUM-LOWTAG"
"EXPORTED-STATIC-SYMBOLS" "EXTERN-ALIEN-NAME"
"FDEFN-FUN-SLOT" "FDEFN-NAME-SLOT" "FDEFN-RAW-ADDR-SLOT"
"FDEFN-SIZE" "FDEFN-TYPE" "FIND-HOLES" "FIXNUMIZE"
"SIMPLE-FUN-HEADER-TYPE-SLOT"
"SIMPLE-FUN-NAME-SLOT"
"SIMPLE-FUN-NEXT-SLOT"
- "FUN-POINTER-TYPE"
+ "FUN-POINTER-LOWTAG"
"SIMPLE-FUN-SELF-SLOT"
"SIMPLE-FUN-TYPE-SLOT"
"FUNCALLABLE-INSTANCE-LAYOUT-SLOT"
"GENESIS" "HALT-TRAP" "IGNORE-ME-SC-NUMBER"
"IMMEDIATE-BASE-CHAR-SC-NUMBER" "IMMEDIATE-SAP-SC-NUMBER"
"IMMEDIATE-SC-NUMBER" "*INITIAL-DYNAMIC-SPACE-FREE-POINTER*"
- "INSTANCE-HEADER-TYPE" "INSTANCE-POINTER-TYPE"
+ "INSTANCE-HEADER-TYPE" "INSTANCE-POINTER-LOWTAG"
"INSTANCE-SLOTS-OFFSET" "INSTANCE-USAGE"
"INTERIOR-REG-SC-NUMBER" "INTERNAL-ERROR-ARGUMENTS"
- "INTERRUPTED-FLAG" "LIST-ALLOCATED-OBJECTS" "LIST-POINTER-TYPE"
+ "INTERRUPTED-FLAG" "LIST-ALLOCATED-OBJECTS" "LIST-POINTER-LOWTAG"
"LONG-FLOAT-BIAS" "LONG-FLOAT-DIGITS" "LONG-FLOAT-EXPONENT-BYTE"
"LONG-FLOAT-HIDDEN-BIT" "LONG-FLOAT-NORMAL-EXPONENT-MAX"
"LONG-FLOAT-NORMAL-EXPONENT-MIN" "LONG-FLOAT-SIGNIFICAND-BYTE"
"LOWTAG-BITS" "LOWTAG-LIMIT" "LOWTAG-MASK"
"MEMORY-USAGE" "MOST-POSITIVE-COST"
"NEGATIVE-IMMEDIATE-SC-NUMBER" "NON-DESCRIPTOR-REG-SC-NUMBER"
- "NULL-SC-NUMBER" "OBJECT-NOT-LIST-TRAP" "OBJECT-NOT-INSTANCE-TRAP"
- "ODD-FIXNUM-TYPE" "OFFSET-STATIC-SYMBOL" "OTHER-IMMEDIATE-0-TYPE"
- "OTHER-IMMEDIATE-1-TYPE" "OTHER-POINTER-TYPE"
+ "NULL-SC-NUMBER"
+ "OBJECT-NOT-LIST-TRAP" "OBJECT-NOT-INSTANCE-TRAP"
+ "ODD-FIXNUM-LOWTAG"
+ "OFFSET-STATIC-SYMBOL" "OTHER-IMMEDIATE-0-LOWTAG"
+ "OTHER-IMMEDIATE-1-LOWTAG" "OTHER-POINTER-LOWTAG"
"PAD-DATA-BLOCK" "PENDING-INTERRUPT-TRAP"
"PRIMITIVE-OBJECT" "PRIMITIVE-OBJECT-HEADER"
"PRIMITIVE-OBJECT-LOWTAG" "PRIMITIVE-OBJECT-NAME"
(inst bis temp2 bignum-type temp2)
(pseudo-atomic (:extra (pad-data-block (+ bignum-digits-offset 3)))
- (inst bis alloc-tn other-pointer-type res)
- (storew temp2 res 0 other-pointer-type)
- (storew temp3 res bignum-digits-offset other-pointer-type)
+ (inst bis alloc-tn other-pointer-lowtag res)
+ (storew temp2 res 0 other-pointer-lowtag)
+ (storew temp3 res bignum-digits-offset other-pointer-lowtag)
(inst srl temp3 32 temp)
- (storew temp res (1+ bignum-digits-offset) other-pointer-type))
+ (storew temp res (1+ bignum-digits-offset) other-pointer-lowtag))
DONE
(lisp-return lra lip :offset 2)
(inst bis temp2 bignum-type temp2)
(pseudo-atomic (:extra (pad-data-block (+ bignum-digits-offset 3)))
- (inst bis alloc-tn other-pointer-type res)
- (storew temp2 res 0 other-pointer-type)
- (storew temp3 res bignum-digits-offset other-pointer-type)
+ (inst bis alloc-tn other-pointer-lowtag res)
+ (storew temp2 res 0 other-pointer-lowtag)
+ (storew temp3 res bignum-digits-offset other-pointer-lowtag)
(inst srl temp3 32 temp)
- (storew temp res (1+ bignum-digits-offset) other-pointer-type))
+ (storew temp res (1+ bignum-digits-offset) other-pointer-lowtag))
DONE
(lisp-return lra lip :offset 2)
(inst li (logior (ash 1 type-bits) bignum-type) temp2)
;; Allocate one word.
(pseudo-atomic (:extra (pad-data-block (1+ bignum-digits-offset)))
- (inst bis alloc-tn other-pointer-type res)
- (storew temp2 res 0 other-pointer-type))
+ (inst bis alloc-tn other-pointer-lowtag res)
+ (storew temp2 res 0 other-pointer-lowtag))
;; Store one word
- (storew lo res bignum-digits-offset other-pointer-type)
+ (storew lo res bignum-digits-offset other-pointer-lowtag)
;; Out of here
(lisp-return lra lip :offset 2)
TWO-WORDS
;; Allocate two words.
(pseudo-atomic (:extra (pad-data-block (+ 2 bignum-digits-offset)))
- (inst bis alloc-tn other-pointer-type res)
- (storew temp2 res 0 other-pointer-type))
+ (inst bis alloc-tn other-pointer-lowtag res)
+ (storew temp2 res 0 other-pointer-lowtag))
;; Store two words.
- (storew lo res bignum-digits-offset other-pointer-type)
- (storew hi res (1+ bignum-digits-offset) other-pointer-type)
+ (storew lo res bignum-digits-offset other-pointer-lowtag)
+ (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag)
;; out of here
(lisp-return lra lip :offset 2)
(inst srl type word-shift ndescr)
(pseudo-atomic ()
- (inst bis alloc-tn other-pointer-type result)
+ (inst bis alloc-tn other-pointer-lowtag result)
(inst addq alloc-tn words alloc-tn)
- (storew ndescr result 0 other-pointer-type)
- (storew length result vector-length-slot other-pointer-type)))
+ (storew ndescr result 0 other-pointer-lowtag)
+ (storew length result vector-length-slot other-pointer-lowtag)))
\f
;;;; hash primitives
#|
(progn result lip accum data byte retaddr)
(inst li (make-fixup 'sxhash-simple-substring :assembly-routine) temp1)
- (loadw length string vector-length-slot other-pointer-type)
+ (loadw length string vector-length-slot other-pointer-lowtag)
(inst jmp zero-tn temp1
(make-fixup 'sxhash-simple-substring :assembly-routine)))
;; Get a pointer to the data.
(inst addq string
- (- (* vector-data-offset word-bytes) other-pointer-type)
+ (- (* vector-data-offset word-bytes) other-pointer-lowtag)
lip)
(move zero-tn accum)
(inst br zero-tn test)
DONE
;; We are done. Do the jump.
(progn
- (loadw temp lexenv closure-fun-slot fun-pointer-type)
+ (loadw temp lexenv closure-fun-slot fun-pointer-lowtag)
(lisp-jump temp lip)))
\f
BIGNUM
(with-fixed-allocation (ebx bignum-type (+ bignum-digits-offset 1))
- (storew eax ebx bignum-digits-offset other-pointer-type))
+ (storew eax ebx bignum-digits-offset other-pointer-lowtag))
(inst ret))
;; Two word bignum
(with-fixed-allocation (ebx bignum-type (+ bignum-digits-offset 2))
- (storew eax ebx bignum-digits-offset other-pointer-type))
+ (storew eax ebx bignum-digits-offset other-pointer-lowtag))
(inst ret)
ONE-WORD-BIGNUM
(with-fixed-allocation (ebx bignum-type (+ bignum-digits-offset 1))
- (storew eax ebx bignum-digits-offset other-pointer-type))
+ (storew eax ebx bignum-digits-offset other-pointer-lowtag))
(inst ret))
(move ecx res)
(with-fixed-allocation (res bignum-type (1+ bignum-digits-offset))
- (storew ecx res bignum-digits-offset other-pointer-type))
+ (storew ecx res bignum-digits-offset other-pointer-lowtag))
OKAY)
(move ecx res)
(with-fixed-allocation (res bignum-type (1+ bignum-digits-offset))
- (storew ecx res bignum-digits-offset other-pointer-type))
+ (storew ecx res bignum-digits-offset other-pointer-lowtag))
OKAY)
(define-generic-arith-routine (* 30)
(inst jmp :e SINGLE-WORD-BIGNUM)
(with-fixed-allocation (res bignum-type (+ bignum-digits-offset 2))
- (storew eax res bignum-digits-offset other-pointer-type)
- (storew ecx res (1+ bignum-digits-offset) other-pointer-type))
+ (storew eax res bignum-digits-offset other-pointer-lowtag)
+ (storew ecx res (1+ bignum-digits-offset) other-pointer-lowtag))
(inst jmp DONE)
SINGLE-WORD-BIGNUM
(with-fixed-allocation (res bignum-type (1+ bignum-digits-offset))
- (storew eax res bignum-digits-offset other-pointer-type))
+ (storew eax res bignum-digits-offset other-pointer-lowtag))
(inst jmp DONE)
OKAY
(move ecx res)
(with-fixed-allocation (res bignum-type (1+ bignum-digits-offset))
- (storew ecx res bignum-digits-offset other-pointer-type))
+ (storew ecx res bignum-digits-offset other-pointer-lowtag))
OKAY)
\f
(inst mov y (make-ea :dword :base state :index k :scale 4
:disp (- (* (+ 3 sb!vm:vector-data-offset)
sb!vm:word-bytes)
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(inst mov tmp (make-ea :dword :base state :index k :scale 4
:disp (- (* (+ 1 3 sb!vm:vector-data-offset)
sb!vm:word-bytes)
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(inst and y #x80000000)
(inst and tmp #x7fffffff)
(inst or y tmp)
(inst xor y (make-ea :dword :base state :index k :scale 4
:disp (- (* (+ 397 3 sb!vm:vector-data-offset)
sb!vm:word-bytes)
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(inst mov (make-ea :dword :base state :index k :scale 4
:disp (- (* (+ 3 sb!vm:vector-data-offset)
sb!vm:word-bytes)
- sb!vm:other-pointer-type))
+ sb!vm:other-pointer-lowtag))
y)
(inst inc k)
(inst cmp k (- 624 397))
(inst mov y (make-ea :dword :base state :index k :scale 4
:disp (- (* (+ 3 sb!vm:vector-data-offset)
sb!vm:word-bytes)
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(inst mov tmp (make-ea :dword :base state :index k :scale 4
:disp (- (* (+ 1 3 sb!vm:vector-data-offset)
sb!vm:word-bytes)
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(inst and y #x80000000)
(inst and tmp #x7fffffff)
(inst or y tmp)
(inst xor y (make-ea :dword :base state :index k :scale 4
:disp (- (* (+ (- 397 624) 3 sb!vm:vector-data-offset)
sb!vm:word-bytes)
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(inst mov (make-ea :dword :base state :index k :scale 4
:disp (- (* (+ 3 sb!vm:vector-data-offset)
sb!vm:word-bytes)
- sb!vm:other-pointer-type))
+ sb!vm:other-pointer-lowtag))
y)
(inst inc k)
(inst cmp k (- 624 1))
(inst mov y (make-ea :dword :base state
:disp (- (* (+ (- 624 1) 3 sb!vm:vector-data-offset)
sb!vm:word-bytes)
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(inst mov tmp (make-ea :dword :base state
:disp (- (* (+ 0 3 sb!vm:vector-data-offset)
sb!vm:word-bytes)
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(inst and y #x80000000)
(inst and tmp #x7fffffff)
(inst or y tmp)
(inst xor y (make-ea :dword :base state
:disp (- (* (+ (- 397 1) 3 sb!vm:vector-data-offset)
sb!vm:word-bytes)
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(inst mov (make-ea :dword :base state
:disp (- (* (+ (- 624 1) 3 sb!vm:vector-data-offset)
sb!vm:word-bytes)
- sb!vm:other-pointer-type))
+ sb!vm:other-pointer-lowtag))
y)
;; Restore the temporary registers and return.
(inst and result (lognot sb!vm:lowtag-mask))
(pseudo-atomic
(allocation result result)
- (inst lea result (make-ea :byte :base result :disp other-pointer-type))
- (storew type result 0 other-pointer-type)
- (storew length result vector-length-slot other-pointer-type))
+ (inst lea result (make-ea :byte :base result :disp other-pointer-lowtag))
+ (storew type result 0 other-pointer-lowtag)
+ (storew length result vector-length-slot other-pointer-lowtag))
(inst ret))
\f
;;;; Note: CMU CL had assembly language primitives for hashing strings,
(inst jmp
(make-ea :byte :base eax
:disp (- (* closure-fun-slot word-bytes)
- fun-pointer-type)))
+ fun-pointer-lowtag)))
;; All the arguments fit in registers, so load them.
REGISTER-ARGS
;; And away we go.
(inst jmp (make-ea :byte :base eax
:disp (- (* closure-fun-slot word-bytes)
- fun-pointer-type))))
+ fun-pointer-lowtag))))
\f
(define-assembly-routine (throw
(:return-style :none))
:inherits (sequence mutable-sequence mutable-collection
generic-sequence collection))
(cons
- :codes (#.sb!vm:list-pointer-type)
+ :codes (#.sb!vm:list-pointer-lowtag)
:translation cons
:inherits (list sequence
mutable-sequence mutable-collection
#.sb!vm:*target-most-positive-fixnum*)
:inherits (integer rational real number
generic-number)
- :codes (#.sb!vm:even-fixnum-type #.sb!vm:odd-fixnum-type))
+ :codes (#.sb!vm:even-fixnum-lowtag #.sb!vm:odd-fixnum-lowtag))
(bignum
:translation (and integer (not fixnum))
:inherits (integer rational real number
(defun component-from-component-ptr (component-ptr)
(declare (type system-area-pointer component-ptr))
(make-lisp-obj (logior (sap-int component-ptr)
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
;;;; X86 support
(code-header-len (* (get-header-data code) sb!vm:word-bytes))
(pc-offset (- (sap-int pc)
(- (get-lisp-obj-address code)
- sb!vm:other-pointer-type)
+ sb!vm:other-pointer-lowtag)
code-header-len)))
; (format t "c-lra-fpc ~A ~A ~A~%" pc code pc-offset)
(values pc-offset code)))))
(pc-offset
(- (sap-int (sb!vm:context-pc context))
(- (get-lisp-obj-address code)
- sb!vm:other-pointer-type)
+ sb!vm:other-pointer-lowtag)
code-header-len)))
(/show "got PC-OFFSET")
(unless (<= 0 pc-offset
(pc-offset
(- (sap-int (sb!vm:context-pc scp))
(- (get-lisp-obj-address code)
- sb!vm:other-pointer-type)
+ sb!vm:other-pointer-lowtag)
code-header-len)))
;; Check to see whether we were executing in a branch
;; delay slot.
(or (fun-code-header object)
:undefined-function)
(let ((lowtag (get-lowtag object)))
- (if (= lowtag sb!vm:other-pointer-type)
+ (if (= lowtag sb!vm:other-pointer-lowtag)
(let ((type (get-type object)))
(cond ((= type sb!vm:code-header-type)
object)
#!+x86
(- (sap-int ra)
(- (get-lisp-obj-address component)
- sb!vm:other-pointer-type)
+ sb!vm:other-pointer-lowtag)
(* (get-header-data component) sb!vm:word-bytes))))
(push (cons #!-x86
(stack-ref catch sb!vm:catch-block-tag-slot)
;;; this to determine if the value stored is the actual value or an
;;; indirection cell.
(defun indirect-value-cell-p (x)
- (and (= (get-lowtag x) sb!vm:other-pointer-type)
+ (and (= (get-lowtag x) sb!vm:other-pointer-lowtag)
(= (get-type x) sb!vm:value-cell-header-type)))
;;; Return three values reflecting the validity of DEBUG-VAR's value
(values dst-start code-object (sap- trap-loc src-start))
#!-x86
(let ((new-lra (make-lisp-obj (+ (sap-int dst-start)
- sb!vm:other-pointer-type))))
+ sb!vm:other-pointer-lowtag))))
(set-header-data
new-lra
(logandc2 (+ sb!vm:code-constants-offset bogus-lra-constants 1)
;;; meaning of FOP-FSET, and changed the layouts of various
;;; internal compiler structures (e.g. DEFSTRUCT CLAMBDA)
;;; 18 = sbcl-0.pre7.39 swapped FUNCTION-POINTER-TYPE and
-;;; INSTANCE-POINTER-TYPE low-level type codes to help with
+;;; INSTANCE-POINTER-LOWTAG low-level type codes to help with
;;; the PPC port
;;; (In 0.pre7.48, the low-level object layout of SYMBOL on the
;;; non-X86 ports changed. I forgot to bump the fasl version number:
(print-unreadable-object (object stream :identity t)
(let ((lowtag (get-lowtag object)))
(case lowtag
- (#.sb!vm:other-pointer-type
+ (#.sb!vm:other-pointer-lowtag
(let ((type (get-type object)))
(case type
(#.sb!vm:value-cell-header-type
(write-string "unknown pointer object, type=" stream)
(let ((*print-base* 16) (*print-radix* t))
(output-integer type stream))))))
- ((#.sb!vm:fun-pointer-type
- #.sb!vm:instance-pointer-type
- #.sb!vm:list-pointer-type)
+ ((#.sb!vm:fun-pointer-lowtag
+ #.sb!vm:instance-pointer-lowtag
+ #.sb!vm:list-pointer-lowtag)
(write-string "unknown pointer object, type=" stream))
(t
(case (get-type object)
(let ((size (* cons-size word-bytes)))
(funcall fun
(make-lisp-obj (logior (sap-int current)
- list-pointer-type))
- list-pointer-type
+ list-pointer-lowtag))
+ list-pointer-lowtag
size)
(setq current (sap+ current size))))
((eql header-type closure-header-type)
(let* ((obj (make-lisp-obj (logior (sap-int current)
- fun-pointer-type)))
+ fun-pointer-lowtag)))
(size (round-to-dualword
(* (the fixnum (1+ (get-closure-length obj)))
word-bytes))))
(setq current (sap+ current size))))
((eq (room-info-kind info) :instance)
(let* ((obj (make-lisp-obj
- (logior (sap-int current) instance-pointer-type)))
+ (logior (sap-int current) instance-pointer-lowtag)))
(size (round-to-dualword
(* (+ (%instance-length obj) 1) word-bytes))))
(declare (fixnum size))
(setq current (sap+ current size))))
(t
(let* ((obj (make-lisp-obj
- (logior (sap-int current) other-pointer-type)))
+ (logior (sap-int current) other-pointer-lowtag)))
(size (ecase (room-info-kind info)
(:fixed
(aver (or (eql (room-info-length info)
#.simple-array-complex-double-float-type)
(incf non-descriptor-headers)
(incf non-descriptor-bytes (- size word-bytes)))
- ((#.list-pointer-type
- #.instance-pointer-type
+ ((#.list-pointer-lowtag
+ #.instance-pointer-lowtag
#.ratio-type
#.complex-type
#.simple-array-type
"No debug info."))))
(#.symbol-header-type
(format stream "~&~S~%" obj))
- (#.list-pointer-type
+ (#.list-pointer-lowtag
(unless (gethash obj printed-conses)
(note-conses obj)
(let ((*print-circle* t)
(control-stack
(load-stack-tn temp ,tn)
temp))))
- (storew reg ,list ,slot list-pointer-type))))
+ (storew reg ,list ,slot list-pointer-lowtag))))
(let ((cons-cells (if star (1- num) num)))
(pseudo-atomic (:extra (* (pad-data-block cons-size)
cons-cells))
- (inst bis alloc-tn list-pointer-type res)
+ (inst bis alloc-tn list-pointer-lowtag res)
(move res ptr)
(dotimes (i (1- cons-cells))
(store-car (tn-ref-tn things) ptr)
(inst lda ptr (pad-data-block cons-size) ptr)
(storew ptr ptr
(- cons-cdr-slot cons-size)
- list-pointer-type))
+ list-pointer-lowtag))
(store-car (tn-ref-tn things) ptr)
(cond (star
(setf things (tn-ref-across things))
(store-car (tn-ref-tn things) ptr cons-cdr-slot))
(t
(storew null-tn ptr
- cons-cdr-slot list-pointer-type)))
+ cons-cdr-slot list-pointer-lowtag)))
(assert (null (tn-ref-across things)))
(move res result))))))))
(inst bis ndescr code-header-type ndescr)
(pseudo-atomic ()
- (inst bis alloc-tn other-pointer-type result)
- (storew ndescr result 0 other-pointer-type)
- (storew unboxed result code-code-size-slot other-pointer-type)
- (storew null-tn result code-entry-points-slot other-pointer-type)
+ (inst bis alloc-tn other-pointer-lowtag result)
+ (storew ndescr result 0 other-pointer-lowtag)
+ (storew unboxed result code-code-size-slot other-pointer-lowtag)
+ (storew null-tn result code-entry-points-slot other-pointer-lowtag)
(inst addq alloc-tn boxed alloc-tn)
(inst addq alloc-tn unboxed alloc-tn))
- (storew null-tn result code-debug-info-slot other-pointer-type)))
+ (storew null-tn result code-debug-info-slot other-pointer-lowtag)))
(define-vop (make-fdefn)
(:policy :fast-safe)
(:results (result :scs (descriptor-reg) :from :argument))
(:generator 37
(with-fixed-allocation (result temp fdefn-type fdefn-size)
- (storew name result fdefn-name-slot other-pointer-type)
- (storew null-tn result fdefn-fun-slot other-pointer-type)
+ (storew name result fdefn-name-slot other-pointer-lowtag)
+ (storew null-tn result fdefn-fun-slot other-pointer-lowtag)
(inst li (make-fixup "undefined_tramp" :foreign) temp)
- (storew temp result fdefn-raw-addr-slot other-pointer-type))))
+ (storew temp result fdefn-raw-addr-slot other-pointer-lowtag))))
(define-vop (make-closure)
(:args (function :to :save :scs (descriptor-reg)))
(let ((size (+ length closure-info-offset)))
(inst li (logior (ash (1- size) type-bits) closure-header-type) temp)
(pseudo-atomic (:extra (pad-data-block size))
- (inst bis alloc-tn fun-pointer-type result)
- (storew temp result 0 fun-pointer-type))
- (storew function result closure-fun-slot fun-pointer-type))))
+ (inst bis alloc-tn fun-pointer-lowtag result)
+ (storew temp result 0 fun-pointer-lowtag))
+ (storew function result closure-fun-slot fun-pointer-lowtag))))
;;; The compiler likes to be able to directly make value cells.
;;;
(:generator 10
(with-fixed-allocation
(result temp value-cell-header-type value-cell-size))
- (storew value result value-cell-value-slot other-pointer-type)))
+ (storew value result value-cell-value-slot other-pointer-lowtag)))
\f
;;;; automatic allocators for primitive objects
(:translate sb!bignum::%bignum-set-length)
(:policy :fast-safe))
-(define-full-reffer bignum-ref * bignum-digits-offset other-pointer-type
+(define-full-reffer bignum-ref * bignum-digits-offset other-pointer-lowtag
(unsigned-reg) unsigned-num sb!bignum::%bignum-ref)
-(define-full-setter bignum-set * bignum-digits-offset other-pointer-type
+(define-full-setter bignum-set * bignum-digits-offset other-pointer-lowtag
(unsigned-reg) unsigned-num sb!bignum::%bignum-set #+gengc nil)
(define-vop (digit-0-or-plus)
(inst bis header type header)
(inst srl header 2 header)
(pseudo-atomic ()
- (inst bis alloc-tn other-pointer-type result)
- (storew header result 0 other-pointer-type)
+ (inst bis alloc-tn other-pointer-lowtag result)
+ (storew header result 0 other-pointer-lowtag)
(inst addq alloc-tn bytes alloc-tn))))
())
(define-full-reffer %array-dimension *
- array-dimensions-offset other-pointer-type
+ array-dimensions-offset other-pointer-lowtag
(any-reg) positive-fixnum sb!impl::%array-dimension)
(define-full-setter %set-array-dimension *
- array-dimensions-offset other-pointer-type
+ array-dimensions-offset other-pointer-lowtag
(any-reg) positive-fixnum sb!impl::%set-array-dimension #+gengc nil)
(:temporary (:scs (non-descriptor-reg)) temp)
(:results (res :scs (any-reg descriptor-reg)))
(:generator 6
- (loadw temp x 0 other-pointer-type)
+ (loadw temp x 0 other-pointer-lowtag)
(inst sra temp type-bits temp)
(inst subq temp (1- array-dimensions-offset) temp)
(inst sll temp 2 res)))
`(progn
(define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type)
,type
- vector-data-offset other-pointer-type
+ vector-data-offset other-pointer-lowtag
,(remove-if #'(lambda (x) (member x '(null zero))) scs)
,element-type
data-vector-ref)
(define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type)
,type
- vector-data-offset other-pointer-type ,scs ,element-type
+ vector-data-offset other-pointer-lowtag ,scs ,element-type
data-vector-set #+gengc ,(if (member 'descriptor-reg scs)
t
nil))))
`(progn
(define-partial-reffer ,(symbolicate "DATA-VECTOR-REF/" type)
,type
- ,size ,signed vector-data-offset other-pointer-type ,scs
+ ,size ,signed vector-data-offset other-pointer-lowtag ,scs
,element-type data-vector-ref)
(define-partial-setter ,(symbolicate "DATA-VECTOR-SET/" type)
,type
- ,size vector-data-offset other-pointer-type ,scs
+ ,size vector-data-offset other-pointer-lowtag ,scs
,element-type data-vector-set)))
(def-small-data-vector-frobs (type bits)
(let* ((elements-per-word (floor word-bits bits))
(inst addq object temp lip)
(inst ldl result
(- (* vector-data-offset word-bytes)
- other-pointer-type)
+ other-pointer-lowtag)
lip)
(inst and index ,(1- elements-per-word) temp)
,@(unless (= bits 1)
(:constant
(integer 0
,(1- (* (1+ (- (floor (+ #x7fff
- other-pointer-type)
+ other-pointer-lowtag)
word-bytes)
vector-data-offset))
elements-per-word)))))
(floor index ,elements-per-word)
(loadw result object (+ word
vector-data-offset)
- other-pointer-type)
+ other-pointer-lowtag)
(unless (zerop extra)
(inst srl result (* extra ,bits) result))
(unless (= extra ,(1- elements-per-word))
(inst addq object temp lip)
(inst ldl old
(- (* vector-data-offset word-bytes)
- other-pointer-type)
+ other-pointer-lowtag)
lip)
(inst and index ,(1- elements-per-word) shift)
,@(unless (= bits 1)
(inst bis old temp old))
(inst stl old
(- (* vector-data-offset word-bytes)
- other-pointer-type)
+ other-pointer-lowtag)
lip)
(sc-case value
(immediate
(:constant
(integer 0
,(1- (* (1+ (- (floor (+ #x7fff
- other-pointer-type)
+ other-pointer-lowtag)
word-bytes)
vector-data-offset))
elements-per-word))))
(inst ldl object
(- (* (+ word vector-data-offset)
word-bytes)
- other-pointer-type)
+ other-pointer-lowtag)
old)
(unless (and (sc-is value immediate)
(= (tn-value value)
(inst stl old
(- (* (+ word vector-data-offset)
word-bytes)
- other-pointer-type)
+ other-pointer-lowtag)
object)
(sc-case value
(immediate
(inst addq object index lip)
(inst lds value
(- (* vector-data-offset word-bytes)
- other-pointer-type)
+ other-pointer-lowtag)
lip)))
(define-vop (data-vector-set/simple-array-single-float)
(inst addq object index lip)
(inst sts value
(- (* vector-data-offset word-bytes)
- other-pointer-type)
+ other-pointer-lowtag)
lip)
(unless (location= result value)
(inst fmove value result))))
(inst addq lip index lip)
(inst ldt value
(- (* vector-data-offset word-bytes)
- other-pointer-type)
+ other-pointer-lowtag)
lip)))
(define-vop (data-vector-set/simple-array-double-float)
(inst addq lip index lip)
(inst stt value
(- (* vector-data-offset word-bytes)
- other-pointer-type) lip)
+ other-pointer-lowtag) lip)
(unless (location= result value)
(inst fmove value result))))
\f
(inst addq object index lip)
(inst addq lip index lip)
(inst lds real-tn
- (- (* vector-data-offset word-bytes) other-pointer-type)
+ (- (* vector-data-offset word-bytes) other-pointer-lowtag)
lip))
(let ((imag-tn (complex-single-reg-imag-tn value)))
(inst lds imag-tn
- (- (* (1+ vector-data-offset) word-bytes) other-pointer-type)
+ (- (* (1+ vector-data-offset) word-bytes) other-pointer-lowtag)
lip))))
(define-vop (data-vector-set/simple-array-complex-single-float)
(inst addq object index lip)
(inst addq lip index lip)
(inst sts value-real
- (- (* vector-data-offset word-bytes) other-pointer-type)
+ (- (* vector-data-offset word-bytes) other-pointer-lowtag)
lip)
(unless (location= result-real value-real)
(inst fmove value-real result-real)))
(let ((value-imag (complex-single-reg-imag-tn value))
(result-imag (complex-single-reg-imag-tn result)))
(inst sts value-imag
- (- (* (1+ vector-data-offset) word-bytes) other-pointer-type)
+ (- (* (1+ vector-data-offset) word-bytes) other-pointer-lowtag)
lip)
(unless (location= result-imag value-imag)
(inst fmove value-imag result-imag)))))
(inst addq lip index lip)
(inst addq lip index lip)
(inst ldt real-tn
- (- (* vector-data-offset word-bytes) other-pointer-type)
+ (- (* vector-data-offset word-bytes) other-pointer-lowtag)
lip))
(let ((imag-tn (complex-double-reg-imag-tn value)))
(inst ldt imag-tn
- (- (* (+ vector-data-offset 2) word-bytes) other-pointer-type)
+ (- (* (+ vector-data-offset 2) word-bytes) other-pointer-lowtag)
lip))))
(define-vop (data-vector-set/simple-array-complex-double-float)
(inst addq lip index lip)
(inst addq lip index lip)
(inst stt value-real
- (- (* vector-data-offset word-bytes) other-pointer-type)
+ (- (* vector-data-offset word-bytes) other-pointer-lowtag)
lip)
(unless (location= result-real value-real)
(inst fmove value-real result-real)))
(let ((value-imag (complex-double-reg-imag-tn value))
(result-imag (complex-double-reg-imag-tn result)))
(inst stt value-imag
- (- (* (+ vector-data-offset 2) word-bytes) other-pointer-type)
+ (- (* (+ vector-data-offset 2) word-bytes) other-pointer-lowtag)
lip)
(unless (location= result-imag value-imag)
(inst fmove value-imag result-imag)))))
;;; These vops are useful for accessing the bits of a vector irrespective of
;;; what type of vector it is.
;;;
-(define-full-reffer raw-bits * 0 other-pointer-type (unsigned-reg) unsigned-num
+(define-full-reffer raw-bits * 0 other-pointer-lowtag (unsigned-reg) unsigned-num
%raw-bits)
-(define-full-setter set-raw-bits * 0 other-pointer-type (unsigned-reg)
+(define-full-setter set-raw-bits * 0 other-pointer-lowtag (unsigned-reg)
unsigned-num %set-raw-bits #+gengc nil)
\f
(when cur-nfp
(inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame)
nsp-tn)))
- (inst subq return-pc-temp (- other-pointer-type word-bytes) lip)
+ (inst subq return-pc-temp (- other-pointer-lowtag word-bytes) lip)
(move ocfp-temp cfp-tn)
(inst ret zero-tn lip 1)
(trace-table-entry trace-table-normal)))
(constant
(inst ldl name-pass
(- (ash (tn-offset name) word-shift)
- other-pointer-type) code-tn)
+ other-pointer-lowtag) code-tn)
(do-next-filler)))
(inst ldl entry-point
(- (ash fdefn-raw-addr-slot word-shift)
- other-pointer-type) name-pass)
+ other-pointer-lowtag) name-pass)
(do-next-filler))
`((sc-case arg-fun
(descriptor-reg (move arg-fun lexenv))
(constant
(inst ldl lexenv
(- (ash (tn-offset arg-fun) word-shift)
- other-pointer-type) code-tn)
+ other-pointer-lowtag) code-tn)
(do-next-filler)))
#!-gengc
(inst ldl function
(- (ash closure-fun-slot word-shift)
- fun-pointer-type) lexenv)
+ fun-pointer-lowtag) lexenv)
#!-gengc
(do-next-filler)
#!-gengc
(inst addq function
(- (ash simple-fun-code-offset word-shift)
- fun-pointer-type) entry-point)
+ fun-pointer-lowtag) entry-point)
#!+gengc
(inst ldl entry-point
(- (ash closure-entry-point-slot word-shift)
- fun-pointer-type) lexenv)
+ fun-pointer-lowtag) lexenv)
#!+gengc
(do-next-filler)))
(loop
;; We need to do this atomically.
(pseudo-atomic ()
;; Allocate a cons (2 words) for each item.
- (inst bis alloc-tn list-pointer-type result)
+ (inst bis alloc-tn list-pointer-lowtag result)
(move result dst)
(inst sll count 1 temp)
(inst addq alloc-tn temp alloc-tn)
;; Store the current cons in the cdr of the previous cons.
(emit-label loop)
(inst addq dst (* 2 word-bytes) dst)
- (storew dst dst -1 list-pointer-type)
+ (storew dst dst -1 list-pointer-lowtag)
(emit-label enter)
;; Grab one value.
(inst addq context word-bytes context)
;; Store the value in the car (in delay slot)
- (storew temp dst 0 list-pointer-type)
+ (storew temp dst 0 list-pointer-lowtag)
;; Decrement count, and if != zero, go back for more.
(inst subq count (fixnumize 1) count)
(inst bne count loop)
;; NIL out the last cons.
- (storew null-tn dst 1 list-pointer-type))
+ (storew null-tn dst 1 list-pointer-lowtag))
(emit-label done))))
;;; Return the location and size of the &MORE arg glob created by
;;; 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)
(: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 beq temp err-lab))))
(define-vop (boundp boundp-frob)
(:translate boundp)
(:generator 9
- (loadw value object symbol-value-slot other-pointer-type)
+ (loadw value object symbol-value-slot other-pointer-lowtag)
(inst xor value unbound-marker-type 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))
;;;; fdefinition (FDEFN) objects
(define-vop (fdefn-fun cell-ref)
- (:variant fdefn-fun-slot other-pointer-type))
+ (:variant fdefn-fun-slot other-pointer-lowtag))
(define-vop (safe-fdefn-fun)
(:args (object :scs (descriptor-reg) :target obj-temp))
(:temporary (:scs (non-descriptor-reg)) temp)
(:generator 10
(move object obj-temp)
- (loadw value obj-temp fdefn-fun-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))))
(:results (result :scs (descriptor-reg)))
(:generator 38
(let ((normal-fn (gen-label)))
- (load-type type function (- fun-pointer-type))
+ (load-type type function (- fun-pointer-lowtag))
(inst xor type simple-fun-header-type type)
(inst addq function
- (- (ash simple-fun-code-offset word-shift) fun-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-fun-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-fun-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
(symbol :scs (descriptor-reg)))
(:temporary (:scs (descriptor-reg)) temp)
(:generator 5
- (loadw temp symbol symbol-value-slot other-pointer-type)
+ (loadw temp symbol symbol-value-slot other-pointer-lowtag)
(inst addq bsp-tn (* 2 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)))
(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)
;;;; closure indexing
(define-full-reffer closure-index-ref *
- closure-info-offset fun-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 fun-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 fun-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 fun-pointer-type))
+ (:variant funcallable-instance-lexenv-slot fun-pointer-lowtag))
(define-vop (closure-ref slot-ref)
- (:variant closure-info-offset fun-pointer-type))
+ (:variant closure-info-offset fun-pointer-lowtag))
(define-vop (closure-init slot-set)
- (:variant closure-info-offset fun-pointer-type))
+ (:variant closure-info-offset fun-pointer-lowtag))
\f
;;;; 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
(:results (res :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:generator 4
- (loadw res struct 0 instance-pointer-type)
+ (loadw res struct 0 instance-pointer-lowtag)
(inst srl res type-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
-(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
(inst srl temp sb!vm:type-bits temp)
(inst beq temp bogus)
(inst sll temp (1- (integer-length sb!vm:word-bytes)) temp)
- (unless (= lowtag sb!vm:other-pointer-type)
- (inst subq temp (- sb!vm:other-pointer-type lowtag) temp))
+ (unless (= lowtag sb!vm:other-pointer-lowtag)
+ (inst subq temp (- sb!vm:other-pointer-lowtag lowtag) temp))
(inst subq thing temp code)
(emit-label done)
(assemble (*elsewhere*)
(define-vop (code-from-lra code-from-mumble)
(:translate lra-code-header)
- (:variant sb!vm:other-pointer-type))
+ (:variant sb!vm:other-pointer-lowtag))
(define-vop (code-from-function code-from-mumble)
(:translate fun-code-header)
- (:variant sb!vm:fun-pointer-type))
+ (:variant sb!vm:fun-pointer-lowtag))
(define-vop (make-lisp-obj)
(:policy :fast-safe)
(:results (res :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:generator 5
- (loadw res fun 0 fun-pointer-type)
+ (loadw res fun 0 fun-pointer-lowtag)
(inst srl res sb!vm:type-bits res)))
(defknown make-number-stack-pointer ((unsigned-byte 32)) system-area-pointer
(:generator 13
(with-fixed-allocation (y ndescr type size)
(if double-p
- (inst stt x (- (* data word-bytes) other-pointer-type) y)
- (inst sts x (- (* data word-bytes) other-pointer-type) y)))))
+ (inst stt x (- (* data word-bytes) other-pointer-lowtag) y)
+ (inst sts x (- (* data word-bytes) other-pointer-lowtag) y)))))
(macrolet ((frob (name sc &rest args)
`(progn
(:generator 2
,@(if double-p
`((inst ldt y (- (* ,value word-bytes)
- other-pointer-type)
+ other-pointer-lowtag)
x))
`((inst lds y (- (* ,value word-bytes)
- other-pointer-type)
+ other-pointer-lowtag)
x)))))
(define-move-vop ,name :move (descriptor-reg) (,sc)))))
(frob move-to-single single-reg nil single-float-value-slot)
(let ((real-tn (complex-single-reg-real-tn x)))
(inst sts real-tn (- (* sb!vm:complex-single-float-real-slot
sb!vm:word-bytes)
- sb!vm:other-pointer-type)
+ sb!vm:other-pointer-lowtag)
y))
(let ((imag-tn (complex-single-reg-imag-tn x)))
(inst sts imag-tn (- (* sb!vm:complex-single-float-imag-slot
sb!vm:word-bytes)
- sb!vm:other-pointer-type)
+ sb!vm:other-pointer-lowtag)
y)))))
;;;
(define-move-vop move-from-complex-single :move
(let ((real-tn (complex-double-reg-real-tn x)))
(inst stt real-tn (- (* sb!vm:complex-double-float-real-slot
sb!vm:word-bytes)
- sb!vm:other-pointer-type)
+ sb!vm:other-pointer-lowtag)
y))
(let ((imag-tn (complex-double-reg-imag-tn x)))
(inst stt imag-tn (- (* sb!vm:complex-double-float-imag-slot
sb!vm:word-bytes)
- sb!vm:other-pointer-type)
+ sb!vm:other-pointer-lowtag)
y)))))
;;;
(define-move-vop move-from-complex-double :move
(:generator 2
(let ((real-tn (complex-single-reg-real-tn y)))
(inst lds real-tn (- (* complex-single-float-real-slot sb!vm:word-bytes)
- sb!vm:other-pointer-type)
+ sb!vm:other-pointer-lowtag)
x))
(let ((imag-tn (complex-single-reg-imag-tn y)))
(inst lds imag-tn (- (* complex-single-float-imag-slot sb!vm:word-bytes)
- sb!vm:other-pointer-type)
+ sb!vm:other-pointer-lowtag)
x))))
(define-move-vop move-to-complex-single :move
(descriptor-reg) (complex-single-reg))
(:generator 2
(let ((real-tn (complex-double-reg-real-tn y)))
(inst ldt real-tn (- (* complex-double-float-real-slot sb!vm:word-bytes)
- sb!vm:other-pointer-type)
+ sb!vm:other-pointer-lowtag)
x))
(let ((imag-tn (complex-double-reg-imag-tn y)))
(inst ldt imag-tn (- (* complex-double-float-imag-slot sb!vm:word-bytes)
- sb!vm:other-pointer-type)
+ sb!vm:other-pointer-lowtag)
x))))
(define-move-vop move-to-complex-double :move
(descriptor-reg) (complex-double-reg))
(* (tn-offset float) sb!vm:word-bytes)
(current-nfp-tn vop)))
(descriptor-reg
- (loadw bits float sb!vm:single-float-value-slot sb!vm:other-pointer-type))))
+ (loadw bits float sb!vm:single-float-value-slot
+ sb!vm:other-pointer-lowtag))))
(signed-stack
(sc-case float
(single-reg
(current-nfp-tn vop)))
(descriptor-reg
(loadw hi-bits float (1+ sb!vm:double-float-value-slot)
- sb!vm:other-pointer-type)))))
+ sb!vm:other-pointer-lowtag)))))
(define-vop (double-float-low-bits)
(:args (float :scs (double-reg descriptor-reg)
(current-nfp-tn vop)))
(descriptor-reg
(loadw lo-bits float sb!vm:double-float-value-slot
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(inst mskll lo-bits 4 lo-bits)))
\f
(:emitter
(emit-compute-inst segment vop dst src label temp
#'(lambda (label posn delta-if-after)
- (- other-pointer-type
+ (- other-pointer-lowtag
(label-position label posn delta-if-after)
(component-header-length))))))
`(inst ldl ,reg
(+ (static-symbol-offset ',symbol)
(ash symbol-value-slot word-shift)
- (- other-pointer-type))
+ (- other-pointer-lowtag))
null-tn))
(defmacro store-symbol-value (reg symbol)
`(inst stl ,reg
(+ (static-symbol-offset ',symbol)
(ash symbol-value-slot word-shift)
- (- other-pointer-type))
+ (- other-pointer-lowtag))
null-tn))
(defmacro load-type (target source &optional (offset 0))
"Jump to the lisp function FUNCTION. LIP is an interior-reg temporary."
`(progn
(inst lda ,lip (- (ash sb!vm:simple-fun-code-offset sb!vm:word-shift)
- sb!vm:fun-pointer-type)
+ sb!vm:fun-pointer-lowtag)
,function)
(move ,function code-tn)
(inst jsr zero-tn ,lip 1)))
"Return to RETURN-PC. LIP is an interior-reg temporary."
`(progn
(inst lda ,lip
- (- (* (1+ ,offset) word-bytes) other-pointer-type)
+ (- (* (1+ ,offset) word-bytes) other-pointer-lowtag)
,return-pc)
,@(when frob-code
`((move ,return-pc code-tn)))
(defmacro with-fixed-allocation ((result-tn temp-tn type-code size)
&body body)
`(pseudo-atomic (:extra (pad-data-block ,size))
- (inst bis alloc-tn other-pointer-type ,result-tn)
+ (inst bis alloc-tn other-pointer-lowtag ,result-tn)
(inst li (logior (ash (1- ,size) type-bits) ,type-code) ,temp-tn)
- (storew ,temp-tn ,result-tn 0 other-pointer-type)
+ (storew ,temp-tn ,result-tn 0 other-pointer-lowtag)
,@body))
(define-move-function (load-constant 5) (vop x y)
((constant) (descriptor-reg any-reg))
- (loadw y code-tn (tn-offset x) other-pointer-type))
+ (loadw y code-tn (tn-offset x) other-pointer-lowtag))
(define-move-function (load-stack 5) (vop x y)
((control-stack) (any-reg descriptor-reg))
(inst sra x 2 y)
(inst beq temp done)
- (loadw header x 0 other-pointer-type)
+ (loadw header x 0 other-pointer-lowtag)
(inst srl header (1+ type-bits) header)
- (loadw y x bignum-digits-offset other-pointer-type)
+ (loadw y x bignum-digits-offset other-pointer-lowtag)
(inst beq header one)
- (loadw header x (1+ bignum-digits-offset) other-pointer-type)
+ (loadw header x (1+ bignum-digits-offset) other-pointer-lowtag)
(inst sll header 32 header)
(inst mskll y 4 y)
(inst bis header y y)
(inst bis header bignum-type header)
(pseudo-atomic (:extra (pad-data-block (+ bignum-digits-offset 3)))
- (inst bis alloc-tn other-pointer-type y)
- (storew header y 0 other-pointer-type)
- (storew x y bignum-digits-offset other-pointer-type)
+ (inst bis alloc-tn other-pointer-lowtag y)
+ (storew header y 0 other-pointer-lowtag)
+ (storew x y bignum-digits-offset other-pointer-lowtag)
(inst srl x 32 temp)
- (storew temp y (1+ bignum-digits-offset) other-pointer-type))
+ (storew temp y (1+ bignum-digits-offset) other-pointer-lowtag))
DONE))
;;;
(inst bis temp bignum-type temp)
(pseudo-atomic (:extra (pad-data-block (+ bignum-digits-offset 3)))
- (inst bis alloc-tn other-pointer-type y)
- (storew temp y 0 other-pointer-type)
- (storew x y bignum-digits-offset other-pointer-type)
+ (inst bis alloc-tn other-pointer-lowtag y)
+ (storew temp y 0 other-pointer-lowtag)
+ (storew x y bignum-digits-offset other-pointer-lowtag)
(inst srl x 32 temp)
- (storew temp y (1+ bignum-digits-offset) other-pointer-type))
+ (storew temp y (1+ bignum-digits-offset) other-pointer-lowtag))
DONE))
;;;
(:results (y :scs (sap-reg)))
(:note "system area pointer indirection")
(:generator 1
- (loadq y x sap-pointer-slot other-pointer-type)))
+ (loadq y x sap-pointer-slot other-pointer-lowtag)))
(define-move-vop move-to-sap :move
(descriptor-reg) (sap-reg))
(:generator 20
(move x sap)
(with-fixed-allocation (y ndescr sap-type sap-size)
- (storeq sap y sap-pointer-slot other-pointer-type))))
+ (storeq sap y sap-pointer-slot other-pointer-lowtag))))
(define-move-vop move-from-sap :move
(sap-reg) (descriptor-reg))
(:result-types system-area-pointer)
(:generator 2
(inst lda sap
- (- (* vector-data-offset word-bytes) other-pointer-type)
+ (- (* vector-data-offset word-bytes) other-pointer-lowtag)
vector)))
(inst bne temp done)
(inst and ptr lowtag-mask temp)
- (inst xor temp list-pointer-type temp)
+ (inst xor temp list-pointer-lowtag temp)
(inst bne temp not-list)
- (loadw ptr ptr cons-cdr-slot list-pointer-type)
+ (loadw ptr ptr cons-cdr-slot list-pointer-lowtag)
(inst addq count (fixnumize 1) count)
(inst br zero-tn loop)
(:generator 6
;; Pick off objects with headers.
(inst and object lowtag-mask result)
- (inst cmpeq result other-pointer-type ndescr)
+ (inst cmpeq result other-pointer-lowtag ndescr)
(inst bne ndescr other-ptr)
- (inst cmpeq result fun-pointer-type ndescr)
+ (inst cmpeq result fun-pointer-lowtag ndescr)
(inst bne ndescr function-ptr)
;; Pick off structure and list pointers.
(inst br zero-tn done)
FUNCTION-PTR
- (load-type result object (- fun-pointer-type))
+ (load-type result object (- fun-pointer-lowtag))
(inst br zero-tn done)
OTHER-PTR
- (load-type result object (- other-pointer-type))
+ (load-type result object (- other-pointer-lowtag))
DONE))
(:results (result :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:generator 6
- (load-type result function (- fun-pointer-type))))
+ (load-type result function (- fun-pointer-lowtag))))
(define-vop (set-function-subtype)
(:translate (setf function-subtype))
(:results (result :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:generator 6
- (inst ldl temp (- fun-pointer-type) function)
+ (inst ldl temp (- fun-pointer-lowtag) function)
(inst and temp #xff temp)
(inst bis type temp temp)
- (inst stl temp (- fun-pointer-type) function)
+ (inst stl temp (- fun-pointer-lowtag) function)
(move type result)))
(:results (res :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:generator 6
- (loadw res x 0 other-pointer-type)
+ (loadw res x 0 other-pointer-lowtag)
(inst srl res type-bits res)))
(define-vop (get-closure-length)
(:results (res :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:generator 6
- (loadw res x 0 fun-pointer-type)
+ (loadw res x 0 fun-pointer-lowtag)
(inst srl res type-bits res)))
(define-vop (set-header-data)
(:results (res :scs (descriptor-reg)))
(:temporary (:scs (non-descriptor-reg)) t1 t2)
(:generator 6
- (loadw t1 x 0 other-pointer-type)
+ (loadw t1 x 0 other-pointer-lowtag)
(inst and t1 type-mask t1)
(sc-case data
(any-reg
(inst li c t2)
(inst bis t1 t2 t1)))))
(zero))
- (storew t1 x 0 other-pointer-type)
+ (storew t1 x 0 other-pointer-lowtag)
(move x res)))
(define-vop (make-fixnum)
(:results (sap :scs (sap-reg)))
(:result-types system-area-pointer)
(:generator 10
- (loadw ndescr code 0 other-pointer-type)
+ (loadw ndescr code 0 other-pointer-lowtag)
(inst srl ndescr type-bits ndescr)
(inst sll ndescr word-shift ndescr)
- (inst subq ndescr other-pointer-type ndescr)
+ (inst subq ndescr other-pointer-lowtag ndescr)
(inst addq code ndescr sap)))
(define-vop (compute-function)
(:results (func :scs (descriptor-reg)))
(:temporary (:scs (non-descriptor-reg)) ndescr)
(:generator 10
- (loadw ndescr code 0 other-pointer-type)
+ (loadw ndescr code 0 other-pointer-lowtag)
(inst srl ndescr type-bits ndescr)
(inst sll ndescr word-shift ndescr)
(inst addq ndescr offset ndescr)
- (inst subq ndescr (- other-pointer-type fun-pointer-type) ndescr)
+ (inst subq ndescr (- other-pointer-lowtag fun-pointer-lowtag) ndescr)
(inst addq code ndescr func)))
\f
;;;; other random VOPs.
(:temporary (:scs (non-descriptor-reg)) count)
(:generator 1
(let ((offset
- (- (* (+ index vector-data-offset) word-bytes) other-pointer-type)))
+ (- (* (+ index vector-data-offset) word-bytes) other-pointer-lowtag)))
(inst ldl count offset count-vector)
(inst addq count 1 count)
(inst stl count offset count-vector))))
(collect ((results))
(let ((start nil)
(prev nil)
- (delta (- other-immediate-1-type other-immediate-0-type)))
+ (delta (- other-immediate-1-lowtag other-immediate-0-lowtag)))
(flet ((emit-test ()
(results (if (= start prev)
start
(macrolet ((test-type (value temp target not-p &rest type-codes)
;; Determine what interesting combinations we need to test for.
(let* ((type-codes (mapcar #'eval type-codes))
- (fixnump (and (member even-fixnum-type type-codes)
- (member odd-fixnum-type type-codes)
+ (fixnump (and (member even-fixnum-lowtag type-codes)
+ (member odd-fixnum-lowtag type-codes)
t))
(lowtags (remove lowtag-limit type-codes :test #'<))
(extended (remove lowtag-limit type-codes :test #'>))
(cond
(fixnump
(when (remove-if #'(lambda (x)
- (or (= x even-fixnum-type)
- (= x odd-fixnum-type)))
+ (or (= x even-fixnum-lowtag)
+ (= x odd-fixnum-lowtag)))
lowtags)
(error "Can't mix fixnum testing with other lowtags."))
(when function-p
(defun %test-headers (value temp target not-p function-p headers
&optional (drop-through (gen-label)))
- (let ((lowtag (if function-p fun-pointer-type other-pointer-type)))
+ (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
(multiple-value-bind
(when-true when-false)
;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when
(def-type-vops fixnump check-fixnum fixnum object-not-fixnum-error
- even-fixnum-type odd-fixnum-type)
+ even-fixnum-lowtag odd-fixnum-lowtag)
(def-type-vops functionp check-function function
- object-not-function-error fun-pointer-type)
+ object-not-function-error fun-pointer-lowtag)
(def-type-vops listp check-list list object-not-list-error
- list-pointer-type)
+ list-pointer-lowtag)
(def-type-vops %instancep check-instance instance object-not-instance-error
- instance-pointer-type)
+ instance-pointer-lowtag)
(def-type-vops bignump check-bignum bignum
object-not-bignum-error bignum-type)
complex-array-type)
(def-type-vops numberp check-number nil object-not-number-error
- even-fixnum-type odd-fixnum-type bignum-type ratio-type
+ even-fixnum-lowtag odd-fixnum-lowtag bignum-type ratio-type
single-float-type double-float-type complex-type
complex-single-float-type complex-double-float-type)
(def-type-vops rationalp check-rational nil object-not-rational-error
- even-fixnum-type odd-fixnum-type ratio-type bignum-type)
+ even-fixnum-lowtag odd-fixnum-lowtag ratio-type bignum-type)
(def-type-vops integerp check-integer nil object-not-integer-error
- even-fixnum-type odd-fixnum-type bignum-type)
+ even-fixnum-lowtag odd-fixnum-lowtag bignum-type)
(def-type-vops floatp check-float nil object-not-float-error
single-float-type double-float-type)
(def-type-vops realp check-real nil object-not-real-error
- even-fixnum-type odd-fixnum-type ratio-type bignum-type
+ even-fixnum-lowtag odd-fixnum-lowtag ratio-type bignum-type
single-float-type double-float-type)
\f
(inst and value 3 temp)
(inst beq temp yep)
(inst and value lowtag-mask temp)
- (inst xor temp other-pointer-type temp)
+ (inst xor temp other-pointer-lowtag temp)
(inst bne temp nope)
- (loadw temp value 0 other-pointer-type)
+ (loadw temp value 0 other-pointer-lowtag)
(inst li (+ (ash 1 type-bits) bignum-type) temp1)
(inst xor temp temp1 temp)
(if not-p
;; If not, is it an other pointer?
(inst and value lowtag-mask temp)
- (inst xor temp other-pointer-type temp)
+ (inst xor temp other-pointer-lowtag temp)
(inst bne temp nope)
;; Get the header.
- (loadw temp value 0 other-pointer-type)
+ (loadw temp value 0 other-pointer-lowtag)
;; Is it one?
(inst li (+ (ash 1 type-bits) bignum-type) temp1)
(inst xor temp temp1 temp)
(inst xor temp temp1 temp)
(inst bne temp nope)
;; Get the second digit.
- (loadw temp value (1+ bignum-digits-offset) other-pointer-type)
+ (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
;; All zeros, its an (unsigned-byte 32).
(inst beq temp yep)
(inst br zero-tn nope)
SINGLE-WORD
;; Get the single digit.
- (loadw temp value bignum-digits-offset other-pointer-type)
+ (loadw temp value bignum-digits-offset other-pointer-lowtag)
;; positive implies (unsigned-byte 32).
FIXNUM
(:generator 8
(inst cmpeq value null-tn temp)
(inst bne temp (if not-p target drop-thru))
- (test-type value temp target not-p list-pointer-type)
+ (test-type value temp target not-p list-pointer-lowtag)
DROP-THRU))
(define-vop (check-cons check-type)
(let ((error (generate-error-code vop object-not-cons-error value)))
(inst cmpeq value null-tn temp)
(inst bne temp error)
- (test-type value temp error t list-pointer-type))
+ (test-type value temp error t list-pointer-lowtag))
(move value result)))
) ; MACROLET
\ No newline at end of file
LOOP
(inst cmpeq list null-tn temp)
(inst bne temp done)
- (loadw temp list cons-car-slot list-pointer-type)
- (loadw list list cons-cdr-slot list-pointer-type)
+ (loadw temp list cons-car-slot list-pointer-lowtag)
+ (loadw list list cons-cdr-slot list-pointer-lowtag)
(inst lda csp-tn word-bytes csp-tn)
(storew temp csp-tn -1)
(inst and list lowtag-mask ndescr)
- (inst xor ndescr list-pointer-type ndescr)
+ (inst xor ndescr list-pointer-lowtag ndescr)
(inst beq ndescr loop)
(error-call vop bogus-argument-to-values-list-error list)
;;; FIXME: It's clever using :SUFFIX -TYPE for these things, but it's
;;; a pain for people just learning to find their way around the code
;;; who want to use lexical search to figure out where things like
-;;; EVEN-FIXNUM-TYPE are defined. Remove the :SUFFIXes and just expand
-;;; out the full names. Or even define them in DEF-FROB EVEN-FIXNUM-TYPE
-;;; style so searches like 'def.*even-fixnum-type' can find them.
+;;; EVEN-FIXNUM-LOWTAG are defined. Remove the :SUFFIXes and just expand
+;;; out the full names. Or even define them in DEF-FROB EVEN-FIXNUM-LOWTAG
+;;; style so searches like 'def.*even-fixnum-lowtag' can find them.
-;;; the main types. These types are represented by the low three bits
-;;; of the pointer or immediate object.
+;;; tags for the main low-level types, to be stored in the low three
+;;; bits to identify the type of a machine word
(eval-when (:compile-toplevel :load-toplevel :execute)
;; The EVAL-WHEN is necessary (at least for Lispworks), because the
- ;; second DEFENUM uses the value of OTHER-IMMEDIATE-0-TYPE, which is
+ ;; second DEFENUM uses the value of OTHER-IMMEDIATE-0-LOWTAG, which is
;; defined in the first DEFENUM. -- AL 20000216
- (defenum (:suffix -type)
+ (defenum (:suffix -lowtag)
even-fixnum
- ;; Note: CMU CL, and SBCL < 0.pre7.39, had FUN-POINTER-TYPE
- ;; here. We swapped FUN-POINTER-TYPE and
- ;; INSTANCE-POINTER-TYPE in sbcl-0.pre7.39 in order to help with a
+ ;; Note: CMU CL, and SBCL < 0.pre7.39, had FUN-POINTER-LOWTAG
+ ;; here. We swapped FUN-POINTER-LOWTAG and
+ ;; INSTANCE-POINTER-LOWTAG in sbcl-0.pre7.39 in order to help with a
;; low-level pun in the function call sequence on the PPC port.
;; For more information, see the PPC port code. -- WHN 2001-10-03
instance-pointer
other-immediate-1
other-pointer))
-;;; the heap types. Each of these types is in the header of objects in
-;;; the heap.
+;;; the heap types, stored in 8 bits of the header of an object on the
+;;; heap, to identify the type of the heap object (which'll be at
+;;; least two machine words, often more)
(defenum (:suffix -type
- :start (+ (ash 1 lowtag-bits) other-immediate-0-type)
+ :start (+ (ash 1 lowtag-bits) other-immediate-0-lowtag)
:step (ash 1 (1- lowtag-bits)))
bignum
ratio
(def!method print-object ((des descriptor) stream)
(let ((lowtag (descriptor-lowtag des)))
(print-unreadable-object (des stream :type t)
- (cond ((or (= lowtag sb!vm:even-fixnum-type)
- (= lowtag sb!vm:odd-fixnum-type))
+ (cond ((or (= lowtag sb!vm:even-fixnum-lowtag)
+ (= lowtag sb!vm:odd-fixnum-lowtag))
(let ((unsigned (logior (ash (descriptor-high des)
(1+ (- descriptor-low-bits
sb!vm:lowtag-bits)))
(if (> unsigned #x1FFFFFFF)
(- unsigned #x40000000)
unsigned))))
- ((or (= lowtag sb!vm:other-immediate-0-type)
- (= lowtag sb!vm:other-immediate-1-type))
+ ((or (= lowtag sb!vm:other-immediate-0-lowtag)
+ (= lowtag sb!vm:other-immediate-1-lowtag))
(format stream
"for other immediate: #X~X, type #b~8,'0B"
(ash (descriptor-bits des) (- sb!vm:type-bits))
(let ((lowtag (descriptor-lowtag des))
(high (descriptor-high des))
(low (descriptor-low des)))
- (if (or (eql lowtag sb!vm:fun-pointer-type)
- (eql lowtag sb!vm:instance-pointer-type)
- (eql lowtag sb!vm:list-pointer-type)
- (eql lowtag sb!vm:other-pointer-type))
+ (if (or (eql lowtag sb!vm:fun-pointer-lowtag)
+ (eql lowtag sb!vm:instance-pointer-lowtag)
+ (eql lowtag sb!vm:list-pointer-lowtag)
+ (eql lowtag sb!vm:other-pointer-lowtag))
(dolist (gspace (list *dynamic* *static* *read-only*)
(error "couldn't find a GSPACE for ~S" des))
- ;; This code relies on the fact that GSPACEs are aligned such that
- ;; the descriptor-low-bits low bits are zero.
+ ;; This code relies on the fact that GSPACEs are aligned
+ ;; such that the descriptor-low-bits low bits are zero.
(when (and (>= high (ash (gspace-word-address gspace)
(- sb!vm:word-shift descriptor-low-bits)))
(<= high (ash (+ (gspace-word-address gspace)
(let* ((bytes (/ (* element-bits length) sb!vm:byte-bits))
(des (allocate-cold-descriptor gspace
(+ bytes sb!vm:word-bytes)
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(write-memory des
(make-other-immediate-descriptor (ash bytes
(- sb!vm:word-shift))
(let* ((bytes (/ (* element-bits length) sb!vm:byte-bits))
(des (allocate-cold-descriptor gspace
(+ bytes (* 2 sb!vm:word-bytes))
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(write-memory des (make-other-immediate-descriptor 0 type))
(write-wordindexed des
sb!vm:vector-length-slot
;;; Allocate a cons cell in GSPACE and fill it in with CAR and CDR.
(defun cold-cons (car cdr &optional (gspace *dynamic*))
- (let ((dest (allocate-boxed-object gspace 2 sb!vm:list-pointer-type)))
+ (let ((dest (allocate-boxed-object gspace 2 sb!vm:list-pointer-lowtag)))
(write-memory dest car)
(write-wordindexed dest 1 cdr)
dest))
(let ((result (allocate-boxed-object *dynamic*
;; KLUDGE: Why 1+? -- WHN 19990901
(1+ target-layout-length)
- sb!vm:instance-pointer-type)))
+ sb!vm:instance-pointer-lowtag)))
(write-memory result
(make-other-immediate-descriptor target-layout-length
sb!vm:instance-header-type))
(result (make-descriptor (descriptor-high des)
(+ (descriptor-low des)
(* 2 sb!vm:word-bytes)
- (- sb!vm:list-pointer-type
- sb!vm:other-pointer-type)))))
+ (- sb!vm:list-pointer-lowtag
+ sb!vm:other-pointer-lowtag)))))
(write-wordindexed des
1
(make-other-immediate-descriptor
;;; like CL:CAR, CL:CDR, and CL:NULL but for cold values
(defun cold-car (des)
- (aver (= (descriptor-lowtag des) sb!vm:list-pointer-type))
+ (aver (= (descriptor-lowtag des) sb!vm:list-pointer-lowtag))
(read-wordindexed des sb!vm:cons-car-slot))
(defun cold-cdr (des)
- (aver (= (descriptor-lowtag des) sb!vm:list-pointer-type))
+ (aver (= (descriptor-lowtag des) sb!vm:list-pointer-lowtag))
(read-wordindexed des sb!vm:cons-cdr-slot))
(defun cold-null (des)
(= (descriptor-bits des)
(defun warm-fun-name (des)
(let ((result
(ecase (descriptor-lowtag des)
- (#.sb!vm:list-pointer-type
+ (#.sb!vm:list-pointer-lowtag
(aver (not (cold-null des))) ; function named NIL? please no..
;; Do cold (DESTRUCTURING-BIND (COLD-CAR COLD-CADR) DES ..).
(let* ((car-des (cold-car des))
(aver (cold-null cddr-des))
(list (warm-symbol car-des)
(warm-symbol cadr-des))))
- (#.sb!vm:other-pointer-type
+ (#.sb!vm:other-pointer-lowtag
(warm-symbol des)))))
(unless (legal-function-name-p result)
(error "not a legal function name: ~S" result))
(or (gethash warm-name *cold-fdefn-objects*)
(let ((fdefn (allocate-boxed-object (or *cold-fdefn-gspace* *dynamic*)
(1- sb!vm:fdefn-size)
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(setf (gethash warm-name *cold-fdefn-objects*) fdefn)
(write-memory fdefn (make-other-immediate-descriptor
(dolist (sym sb!vm:*static-functions*)
(let* ((fdefn (cold-fdefinition-object (cold-intern sym)))
(offset (- (+ (- (descriptor-low fdefn)
- sb!vm:other-pointer-type)
+ sb!vm:other-pointer-lowtag)
(* sb!vm:fdefn-raw-addr-slot sb!vm:word-bytes))
(descriptor-low *nil-descriptor*)))
(desired (sb!vm:static-function-offset sym)))
(let* ((size (clone-arg))
(result (allocate-boxed-object *dynamic*
(1+ size)
- sb!vm:instance-pointer-type)))
+ sb!vm:instance-pointer-lowtag)))
(write-memory result (make-other-immediate-descriptor
size
sb!vm:instance-header-type))
(data-vector (pop-stack))
(result (allocate-boxed-object *dynamic*
(+ sb!vm:array-dimensions-offset rank)
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(write-memory result
(make-other-immediate-descriptor rank
sb!vm:simple-array-type))
(let ((total-elements 1))
(dotimes (axis rank)
(let ((dim (pop-stack)))
- (unless (or (= (descriptor-lowtag dim) sb!vm:even-fixnum-type)
- (= (descriptor-lowtag dim) sb!vm:odd-fixnum-type))
+ (unless (or (= (descriptor-lowtag dim) sb!vm:even-fixnum-lowtag)
+ (= (descriptor-lowtag dim) sb!vm:odd-fixnum-lowtag))
(error "non-fixnum dimension? (~S)" dim))
(setf total-elements
(* total-elements
(write-wordindexed obj
(+ idx
(ecase (descriptor-lowtag obj)
- (#.sb!vm:instance-pointer-type 1)
- (#.sb!vm:other-pointer-type 2)))
+ (#.sb!vm:instance-pointer-lowtag 1)
+ (#.sb!vm:other-pointer-lowtag 2)))
(pop-stack))))
(define-cold-fop (fop-structset nil)
(+ (ash header-n-words
sb!vm:word-shift)
code-size)
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(write-memory des
(make-other-immediate-descriptor header-n-words
sb!vm:code-header-type))
(offset (calc-offset code-object (read-arg 4)))
(fn (descriptor-beyond code-object
offset
- sb!vm:fun-pointer-type))
+ sb!vm:fun-pointer-lowtag))
(next (read-wordindexed code-object sb!vm:code-entry-points-slot)))
(unless (zerop (logand offset sb!vm:lowtag-mask))
;; FIXME: This should probably become a fatal error.
;; FIXME: We should mask out the type
;; bits, not assume we know what they
;; are and subtract them out this way.
- sb!vm:fun-pointer-type))))
+ sb!vm:fun-pointer-lowtag))))
(write-wordindexed fn sb!vm:simple-fun-next-slot next)
(write-wordindexed fn sb!vm:simple-fun-name-slot name)
(write-wordindexed fn sb!vm:simple-fun-arglist-slot arglist)
(+ (ash header-n-words
sb!vm:word-shift)
length)
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(write-memory des
(make-other-immediate-descriptor header-n-words
sb!vm:code-header-type))
\f
;;;; emitting C header file
-(defun tail-comp (string tail)
+(defun tailwise-equal (string tail)
(and (>= (length string) (length tail))
(string= string tail :start1 (- (length string) (length tail)))))
-(defun head-comp (string head)
- (and (>= (length string) (length head))
- (string= string head :end1 (length head))))
-
(defun write-c-header ()
;; writing beginning boilerplate
(symbol-value symbol)
(documentation symbol 'variable))
constants))
- ;; machinery for old-style CMU CL Lisp-to-C naming
+ ;; machinery for old-style CMU CL Lisp-to-C
+ ;; arbitrary renaming, being phased out in favor of
+ ;; the newer systematic RECORD-WITH-TRANSLATED-NAME
+ ;; renaming
(record-with-munged-name (prefix string priority)
(record (concatenate
'simple-string
prefix
(delete #\- (string-capitalize string)))
priority))
- (test-tail (tail prefix priority)
- (when (tail-comp name tail)
+ (maybe-record-with-munged-name (tail prefix priority)
+ (when (tailwise-equal name tail)
(record-with-munged-name prefix
(subseq name 0
(- (length name)
(length tail)))
priority)))
- (test-head (head prefix priority)
- (when (head-comp name head)
- (record-with-munged-name prefix
- (subseq name (length head))
- priority)))
;; machinery for new-style SBCL Lisp-to-C naming
(record-with-translated-name (priority)
(record (substitute #\_ #\- name)
- priority)))
- ;; This style of munging of names is used in the code
- ;; inherited from CMU CL.
- (test-tail "-TYPE" "type_" 0)
- (test-tail "-FLAG" "flag_" 1)
- (test-tail "-TRAP" "trap_" 2)
- (test-tail "-SUBTYPE" "subtype_" 3)
- (test-head "TRACE-TABLE-" "tracetab_" 4)
- (test-tail "-SC-NUMBER" "sc_" 5)
- ;; This simpler style of translation of names seems less
- ;; confusing, and is used for newer code.
- (when (some (lambda (suffix) (tail-comp name suffix))
- #("-START" "-END"))
- (record-with-translated-name 6))))))
+ priority))
+ (maybe-record-with-translated-name (suffixes priority)
+ (when (some (lambda (suffix)
+ (tailwise-equal name suffix))
+ suffixes)
+ (record-with-translated-name priority))))
+
+ (maybe-record-with-translated-name '("-LOWTAG") 0)
+ (maybe-record-with-munged-name "-TYPE" "type_" 1)
+ (maybe-record-with-munged-name "-FLAG" "flag_" 2)
+ (maybe-record-with-munged-name "-TRAP" "trap_" 3)
+ (maybe-record-with-munged-name "-SUBTYPE" "subtype_" 4)
+ (maybe-record-with-munged-name "-SC-NUMBER" "sc_" 5)
+ (maybe-record-with-translated-name '("-START" "-END") 6)))))
(setf constants
(sort constants
#'(lambda (const1 const2)
;; We didn't run GENESIS, so guess at the address.
(+ sb!vm:static-space-start
sb!vm:word-bytes
- sb!vm:other-pointer-type
+ sb!vm:other-pointer-lowtag
(if symbol (sb!vm:static-symbol-offset symbol) 0)))))
;; Voila.
(cold-set 'sb!vm:*read-only-space-free-pointer*
(allocate-cold-descriptor *read-only*
0
- sb!vm:even-fixnum-type))
+ sb!vm:even-fixnum-lowtag))
(cold-set 'sb!vm:*static-space-free-pointer*
(allocate-cold-descriptor *static*
0
- sb!vm:even-fixnum-type))
+ sb!vm:even-fixnum-lowtag))
(cold-set 'sb!vm:*initial-dynamic-space-free-pointer*
(allocate-cold-descriptor *dynamic*
0
- sb!vm:even-fixnum-type))
+ sb!vm:even-fixnum-lowtag))
(/show "done setting free pointers")
;; Write results to files.
\f
;;;; the primitive objects themselves
-(define-primitive-object (cons :lowtag list-pointer-type
+(define-primitive-object (cons :lowtag list-pointer-lowtag
:alloc-trans cons)
(car :ref-trans car :set-trans sb!c::%rplaca :init :arg)
(cdr :ref-trans cdr :set-trans sb!c::%rplacd :init :arg))
-(define-primitive-object (instance :lowtag instance-pointer-type
+(define-primitive-object (instance :lowtag instance-pointer-lowtag
:header instance-header-type
:alloc-trans %make-instance)
(slots :rest-p t))
-(define-primitive-object (bignum :lowtag other-pointer-type
+(define-primitive-object (bignum :lowtag other-pointer-lowtag
:header bignum-type
:alloc-trans sb!bignum::%allocate-bignum)
(digits :rest-p t :c-type #!-alpha "long" #!+alpha "u32"))
(define-primitive-object (ratio :type ratio
- :lowtag other-pointer-type
+ :lowtag other-pointer-lowtag
:header ratio-type
:alloc-trans %make-ratio)
(numerator :type integer
:ref-trans %denominator
:init :arg))
-(define-primitive-object (single-float :lowtag other-pointer-type
+(define-primitive-object (single-float :lowtag other-pointer-lowtag
:header single-float-type)
(value :c-type "float"))
-(define-primitive-object (double-float :lowtag other-pointer-type
+(define-primitive-object (double-float :lowtag other-pointer-lowtag
:header double-float-type)
(filler)
(value :c-type "double" :length 2))
#!+long-float
-(define-primitive-object (long-float :lowtag other-pointer-type
+(define-primitive-object (long-float :lowtag other-pointer-lowtag
:header long-float-type)
#!+sparc (filler)
(value :c-type "long double" :length #!+x86 3 #!+sparc 4))
(define-primitive-object (complex :type complex
- :lowtag other-pointer-type
+ :lowtag other-pointer-lowtag
:header complex-type
:alloc-trans %make-complex)
(real :type real
:ref-trans %imagpart
:init :arg))
-(define-primitive-object (array :lowtag other-pointer-type
+(define-primitive-object (array :lowtag other-pointer-lowtag
:header t)
(fill-pointer :type index
:ref-trans %array-fill-pointer
(dimensions :rest-p t))
(define-primitive-object (vector :type vector
- :lowtag other-pointer-type
+ :lowtag other-pointer-lowtag
:header t)
(length :ref-trans sb!c::vector-length
:type index)
(data :rest-p t :c-type #!-alpha "unsigned long" #!+alpha "u32"))
(define-primitive-object (code :type code-component
- :lowtag other-pointer-type
+ :lowtag other-pointer-lowtag
:header t)
(code-size :type index
:ref-known (flushable movable)
(constants :rest-p t))
(define-primitive-object (fdefn :type fdefn
- :lowtag other-pointer-type
+ :lowtag other-pointer-lowtag
:header fdefn-type)
(name :ref-trans fdefn-name)
(fun :type (or function null) :ref-trans fdefn-fun)
;;; a simple function (as opposed to hairier things like closures
;;; which are also subtypes of Common Lisp's FUNCTION type)
(define-primitive-object (simple-fun :type function
- :lowtag fun-pointer-type
+ :lowtag fun-pointer-lowtag
:header simple-fun-header-type)
#!-x86 (self :ref-trans %simple-fun-self
:set-trans (setf %simple-fun-self))
:set-trans (setf %simple-fun-type))
(code :rest-p t :c-type "unsigned char"))
-(define-primitive-object (return-pc :lowtag other-pointer-type :header t)
+(define-primitive-object (return-pc :lowtag other-pointer-lowtag :header t)
(return-point :c-type "unsigned char" :rest-p t))
-(define-primitive-object (closure :lowtag fun-pointer-type
+(define-primitive-object (closure :lowtag fun-pointer-lowtag
:header closure-header-type)
(fun :init :arg :ref-trans %closure-fun)
(info :rest-p t))
(define-primitive-object (funcallable-instance
- :lowtag fun-pointer-type
+ :lowtag fun-pointer-lowtag
:header funcallable-instance-header-type
:alloc-trans %make-funcallable-instance)
#!-x86
:set-known (unsafe) :set-trans (setf %funcallable-instance-layout))
(info :rest-p t))
-(define-primitive-object (value-cell :lowtag other-pointer-type
+(define-primitive-object (value-cell :lowtag other-pointer-lowtag
:header value-cell-header-type
:alloc-trans make-value-cell)
(value :set-trans value-cell-set
:init :arg))
#!+alpha
-(define-primitive-object (sap :lowtag other-pointer-type
+(define-primitive-object (sap :lowtag other-pointer-lowtag
:header sap-type)
(padding)
(pointer :c-type "char *" :length 2))
#!-alpha
-(define-primitive-object (sap :lowtag other-pointer-type
+(define-primitive-object (sap :lowtag other-pointer-lowtag
:header sap-type)
(pointer :c-type "char *"))
(define-primitive-object (weak-pointer :type weak-pointer
- :lowtag other-pointer-type
+ :lowtag other-pointer-lowtag
:header weak-pointer-type
:alloc-trans make-weak-pointer)
(value :ref-trans sb!c::%weak-pointer-value :ref-known (flushable)
(defknown symbol-hash (symbol) (integer 0 #.*target-most-positive-fixnum*)
(flushable movable))
-(define-primitive-object (symbol :lowtag other-pointer-type
+(define-primitive-object (symbol :lowtag other-pointer-lowtag
:header symbol-header-type
#!-x86 :alloc-trans #!-x86 make-symbol)
(value :set-trans %set-symbol-value
:init :null))
(define-primitive-object (complex-single-float
- :lowtag other-pointer-type
+ :lowtag other-pointer-lowtag
:header complex-single-float-type)
(real :c-type "float")
(imag :c-type "float"))
(define-primitive-object (complex-double-float
- :lowtag other-pointer-type
+ :lowtag other-pointer-lowtag
:header complex-double-float-type)
(filler)
(real :c-type "double" :length 2)
#!+long-float
(define-primitive-object (complex-long-float
- :lowtag other-pointer-type
+ :lowtag other-pointer-lowtag
:header complex-long-float-type)
#!+sparc (filler)
(real :c-type "long double" :length #!+x86 3 #!+sparc 4)
(unless posn (error "~S is not a static symbol." symbol))
(+ (* posn (pad-data-block symbol-size))
(pad-data-block (1- symbol-size))
- other-pointer-type
- (- list-pointer-type)))
+ other-pointer-lowtag
+ (- list-pointer-lowtag)))
0))
(defun offset-static-symbol (offset)
(if (zerop offset)
nil
(multiple-value-bind (n rem)
- (truncate (+ offset list-pointer-type (- other-pointer-type)
+ (truncate (+ offset list-pointer-lowtag (- other-pointer-lowtag)
(- (pad-data-block (1- symbol-size))))
(pad-data-block symbol-size))
(unless (and (zerop rem) (<= 0 n (1- (length *static-symbols*))))
(error "~S isn't a static function." name))
(+ (* static-syms (pad-data-block symbol-size))
(pad-data-block (1- symbol-size))
- (- list-pointer-type)
+ (- list-pointer-lowtag)
(* static-function-index (pad-data-block fdefn-size))
(* fdefn-raw-addr-slot word-bytes))))
(defun fun-address (function)
(declare (type compiled-function function))
- (- (sb!kernel:get-lisp-obj-address function) sb!vm:fun-pointer-type))
+ (- (sb!kernel:get-lisp-obj-address function) sb!vm:fun-pointer-lowtag))
;;; the offset of FUNCTION from the start of its code-component's
;;; instruction area
(maybe-symbol-addr (- address slot-offset))
(maybe-symbol
(sb!kernel:make-lisp-obj
- (+ maybe-symbol-addr sb!vm:other-pointer-type))))
+ (+ maybe-symbol-addr sb!vm:other-pointer-lowtag))))
(when (symbolp maybe-symbol)
(return (values maybe-symbol (cdr field))))))))
(values
(sb!kernel:code-header-ref code
(ash (+ byte-offset
- sb!vm:other-pointer-type)
+ sb!vm:other-pointer-lowtag)
(- sb!vm:word-shift)))
t)
(values nil nil))))
(let ((code-size (ash (sb!kernel:get-header-data code) sb!vm:word-shift)))
(sb!sys:without-gcing
(let ((code-addr (- (sb!kernel:get-lisp-obj-address code)
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(if (or (< addr code-addr) (>= addr (+ code-addr code-size)))
(values nil nil)
(values (sb!kernel:code-header-ref
((control-stack)
(move temp ,tn)
temp))))
- (storew reg ,list ,slot sb!vm:list-pointer-type))))
+ (storew reg ,list ,slot sb!vm:list-pointer-lowtag))))
(let ((cons-cells (if star (1- num) num)))
(pseudo-atomic
(allocation res (* (pad-data-block cons-size) cons-cells) node)
(inst lea res
- (make-ea :byte :base res :disp list-pointer-type))
+ (make-ea :byte :base res :disp list-pointer-lowtag))
(move ptr res)
(dotimes (i (1- cons-cells))
(store-car (tn-ref-tn things) ptr)
(setf things (tn-ref-across things))
(inst add ptr (pad-data-block cons-size))
(storew ptr ptr (- cons-cdr-slot cons-size)
- list-pointer-type))
+ list-pointer-lowtag))
(store-car (tn-ref-tn things) ptr)
(cond (star
(setf things (tn-ref-across things))
(store-car (tn-ref-tn things) ptr cons-cdr-slot))
(t
(storew nil-value ptr cons-cdr-slot
- list-pointer-type)))
+ list-pointer-lowtag)))
(aver (null (tn-ref-across things)))))
(move result res))))))
;;
;; FIXME: should have a check for overflow of static space
(load-symbol-value temp sb!vm:*static-space-free-pointer*)
- (inst lea result (make-ea :byte :base temp :disp other-pointer-type))
+ (inst lea result (make-ea :byte :base temp :disp other-pointer-lowtag))
(inst add temp boxed)
(inst add temp unboxed)
(store-symbol-value temp sb!vm:*static-space-free-pointer*)
(inst shl boxed (- type-bits word-shift))
(inst or boxed code-header-type)
- (storew boxed result 0 other-pointer-type)
- (storew unboxed result code-code-size-slot other-pointer-type)
+ (storew boxed result 0 other-pointer-lowtag)
+ (storew unboxed result code-code-size-slot other-pointer-lowtag)
(inst mov temp nil-value)
- (storew temp result code-entry-points-slot other-pointer-type))
- (storew temp result code-debug-info-slot other-pointer-type)))
+ (storew temp result code-entry-points-slot other-pointer-lowtag))
+ (storew temp result code-debug-info-slot other-pointer-lowtag)))
(define-vop (allocate-dynamic-code-object)
(:args (boxed-arg :scs (any-reg) :target boxed)
(inst add result unboxed)
(pseudo-atomic
(allocation result result node)
- (inst lea result (make-ea :byte :base result :disp other-pointer-type))
+ (inst lea result (make-ea :byte :base result :disp other-pointer-lowtag))
(inst shl boxed (- type-bits word-shift))
(inst or boxed code-header-type)
- (storew boxed result 0 other-pointer-type)
- (storew unboxed result code-code-size-slot other-pointer-type)
- (storew nil-value result code-entry-points-slot other-pointer-type))
- (storew nil-value result code-debug-info-slot other-pointer-type)))
+ (storew boxed result 0 other-pointer-lowtag)
+ (storew unboxed result code-code-size-slot other-pointer-lowtag)
+ (storew nil-value result code-entry-points-slot other-pointer-lowtag))
+ (storew nil-value result code-debug-info-slot other-pointer-lowtag)))
\f
(define-vop (make-fdefn)
(:policy :fast-safe)
(:node-var node)
(:generator 37
(with-fixed-allocation (result fdefn-type fdefn-size node)
- (storew name result fdefn-name-slot other-pointer-type)
- (storew nil-value result fdefn-fun-slot other-pointer-type)
+ (storew name result fdefn-name-slot other-pointer-lowtag)
+ (storew nil-value result fdefn-fun-slot other-pointer-lowtag)
(storew (make-fixup (extern-alien-name "undefined_tramp") :foreign)
- result fdefn-raw-addr-slot other-pointer-type))))
+ result fdefn-raw-addr-slot other-pointer-lowtag))))
(define-vop (make-closure)
(:args (function :to :save :scs (descriptor-reg)))
(let ((size (+ length closure-info-offset)))
(allocation result (pad-data-block size) node)
(inst lea result
- (make-ea :byte :base result :disp fun-pointer-type))
+ (make-ea :byte :base result :disp fun-pointer-lowtag))
(storew (logior (ash (1- size) type-bits) closure-header-type)
- result 0 fun-pointer-type))
- (loadw temp function closure-fun-slot fun-pointer-type)
- (storew temp result closure-fun-slot fun-pointer-type))))
+ result 0 fun-pointer-lowtag))
+ (loadw temp function closure-fun-slot fun-pointer-lowtag)
+ (storew temp result closure-fun-slot fun-pointer-lowtag))))
;;; The compiler likes to be able to directly make value cells.
(define-vop (make-value-cell)
(:generator 10
(with-fixed-allocation
(result value-cell-header-type value-cell-size node))
- (storew value result value-cell-value-slot other-pointer-type)))
+ (storew value result value-cell-value-slot other-pointer-lowtag)))
\f
;;;; automatic allocators for primitive objects
(:node-var node)
(:generator 37
(with-fixed-allocation (result symbol-header-type symbol-size node)
- (storew name result symbol-name-slot other-pointer-type)
- (storew unbound-marker-type result symbol-value-slot other-pointer-type)
+ (storew name result symbol-name-slot other-pointer-lowtag)
+ (storew unbound-marker-type result symbol-value-slot other-pointer-lowtag)
;; Set up a random hash value for the symbol. Perhaps the object
;; address could be used for even faster and smaller code!
;; FIXME: We don't mind the symbol hash not being repeatable, so
;; We want a positive fixnum for the hash value, so discard the LS bits.
(inst shr temp 1)
(inst and temp #xfffffffc)
- (storew temp result symbol-hash-slot other-pointer-type)
- (storew nil-value result symbol-plist-slot other-pointer-type)
- (storew nil-value result symbol-package-slot other-pointer-type))))
+ (storew temp result symbol-hash-slot other-pointer-lowtag)
+ (storew nil-value result symbol-plist-slot other-pointer-lowtag)
+ (storew nil-value result symbol-package-slot other-pointer-lowtag))))
(:translate sb!bignum::%bignum-set-length)
(:policy :fast-safe))
-(define-full-reffer bignum-ref * bignum-digits-offset other-pointer-type
+(define-full-reffer bignum-ref * bignum-digits-offset other-pointer-lowtag
(unsigned-reg) unsigned-num sb!bignum::%bignum-ref)
-(define-full-setter bignum-set * bignum-digits-offset other-pointer-type
+(define-full-setter bignum-set * bignum-digits-offset other-pointer-lowtag
(unsigned-reg) unsigned-num sb!bignum::%bignum-set)
(define-vop (digit-0-or-plus)
(inst mov k (make-ea :dword :base state
:disp (- (* (+ 2 sb!vm:vector-data-offset)
sb!vm:word-bytes)
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(inst cmp k 624)
(inst jmp :ne no-update)
(inst mov tmp state) ; The state is passed in EAX.
(inst mov y (make-ea :dword :base state :index k :scale 4
:disp (- (* (+ 3 sb!vm:vector-data-offset)
sb!vm:word-bytes)
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
;; y ^= (y >> 11);
(inst shr y 11)
(inst xor y (make-ea :dword :base state :index k :scale 4
:disp (- (* (+ 3 sb!vm:vector-data-offset)
sb!vm:word-bytes)
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
;; y ^= (y << 7) & #x9d2c5680
(inst mov tmp y)
(inst inc k)
(inst mov (make-ea :dword :base state
:disp (- (* (+ 2 sb!vm:vector-data-offset)
sb!vm:word-bytes)
- sb!vm:other-pointer-type))
+ sb!vm:other-pointer-lowtag))
k)
(inst and tmp #x9d2c5680)
(inst xor y tmp)
(inst shr header 2)
(pseudo-atomic
(allocation result bytes node)
- (inst lea result (make-ea :dword :base result :disp other-pointer-type))
- (storew header result 0 other-pointer-type))))
+ (inst lea result (make-ea :dword :base result :disp other-pointer-lowtag))
+ (storew header result 0 other-pointer-lowtag))))
\f
;;;; additional accessors and setters for the array header
())
(define-full-reffer %array-dimension *
- array-dimensions-offset other-pointer-type
+ array-dimensions-offset other-pointer-lowtag
(any-reg) positive-fixnum sb!impl::%array-dimension)
(define-full-setter %set-array-dimension *
- array-dimensions-offset other-pointer-type
+ array-dimensions-offset other-pointer-lowtag
(any-reg) positive-fixnum sb!impl::%set-array-dimension)
(defknown sb!impl::%array-rank (t) index (flushable))
(:results (res :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:generator 6
- (loadw res x 0 other-pointer-type)
+ (loadw res x 0 other-pointer-lowtag)
(inst shr res type-bits)
(inst sub res (1- array-dimensions-offset))))
\f
(macrolet ((def-full-data-vector-frobs (type element-type &rest scs)
`(progn
(define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type)
- ,type vector-data-offset other-pointer-type ,scs
+ ,type vector-data-offset other-pointer-lowtag ,scs
,element-type data-vector-ref)
(define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type)
- ,type vector-data-offset other-pointer-type ,scs
+ ,type vector-data-offset other-pointer-lowtag ,scs
,element-type data-vector-set))))
(def-full-data-vector-frobs simple-vector * descriptor-reg any-reg)
(def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num
(inst mov result
(make-ea :dword :base object :index ecx :scale 4
:disp (- (* vector-data-offset word-bytes)
- other-pointer-type)))
+ other-pointer-lowtag)))
(move ecx index)
(inst and ecx ,(1- elements-per-word))
,@(unless (= bits 1)
(:generator 15
(multiple-value-bind (word extra) (floor index ,elements-per-word)
(loadw result object (+ word vector-data-offset)
- other-pointer-type)
+ other-pointer-lowtag)
(unless (zerop extra)
(inst shr result (* extra ,bits)))
(unless (= extra ,(1- elements-per-word))
(inst lea ptr
(make-ea :dword :base object :index word-index :scale 4
:disp (- (* vector-data-offset word-bytes)
- other-pointer-type)))
+ other-pointer-lowtag)))
(loadw old ptr)
(move ecx index)
(inst and ecx ,(1- elements-per-word))
(inst mov old
(make-ea :dword :base object
:disp (- (* (+ word vector-data-offset) word-bytes)
- other-pointer-type)))
+ other-pointer-lowtag)))
(sc-case value
(immediate
(let* ((value (tn-value value))
(inst mov (make-ea :dword :base object
:disp (- (* (+ word vector-data-offset)
word-bytes)
- other-pointer-type))
+ other-pointer-lowtag))
old)
(sc-case value
(immediate
(with-empty-tn@fp-top(value)
(inst fld (make-ea :dword :base object :index index :scale 1
:disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
- sb!vm:other-pointer-type))))))
+ sb!vm:other-pointer-lowtag))))))
(define-vop (data-vector-ref-c/simple-array-single-float)
(:note "inline array access")
:disp (- (+ (* sb!vm:vector-data-offset
sb!vm:word-bytes)
(* 4 index))
- sb!vm:other-pointer-type))))))
+ sb!vm:other-pointer-lowtag))))))
(define-vop (data-vector-set/simple-array-single-float)
(:note "inline array store")
(inst fst (make-ea :dword :base object :index index :scale 1
:disp (- (* sb!vm:vector-data-offset
sb!vm:word-bytes)
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(unless (zerop (tn-offset result))
;; Value is in ST0 but not result.
(inst fst result)))
(inst fst (make-ea :dword :base object :index index :scale 1
:disp (- (* sb!vm:vector-data-offset
sb!vm:word-bytes)
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(cond ((zerop (tn-offset result))
;; The result is in ST0.
(inst fst value))
:disp (- (+ (* sb!vm:vector-data-offset
sb!vm:word-bytes)
(* 4 index))
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(unless (zerop (tn-offset result))
;; Value is in ST0 but not result.
(inst fst result)))
:disp (- (+ (* sb!vm:vector-data-offset
sb!vm:word-bytes)
(* 4 index))
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(cond ((zerop (tn-offset result))
;; The result is in ST0.
(inst fst value))
(with-empty-tn@fp-top(value)
(inst fldd (make-ea :dword :base object :index index :scale 2
:disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
- sb!vm:other-pointer-type))))))
+ sb!vm:other-pointer-lowtag))))))
(define-vop (data-vector-ref-c/simple-array-double-float)
(:note "inline array access")
:disp (- (+ (* sb!vm:vector-data-offset
sb!vm:word-bytes)
(* 8 index))
- sb!vm:other-pointer-type))))))
+ sb!vm:other-pointer-lowtag))))))
(define-vop (data-vector-set/simple-array-double-float)
(:note "inline array store")
(inst fstd (make-ea :dword :base object :index index :scale 2
:disp (- (* sb!vm:vector-data-offset
sb!vm:word-bytes)
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(unless (zerop (tn-offset result))
;; Value is in ST0 but not result.
(inst fstd result)))
(inst fstd (make-ea :dword :base object :index index :scale 2
:disp (- (* sb!vm:vector-data-offset
sb!vm:word-bytes)
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(cond ((zerop (tn-offset result))
;; The result is in ST0.
(inst fstd value))
:disp (- (+ (* sb!vm:vector-data-offset
sb!vm:word-bytes)
(* 8 index))
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(unless (zerop (tn-offset result))
;; Value is in ST0 but not result.
(inst fstd result)))
:disp (- (+ (* sb!vm:vector-data-offset
sb!vm:word-bytes)
(* 8 index))
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(cond ((zerop (tn-offset result))
;; The result is in ST0.
(inst fstd value))
(inst fldl (make-ea :dword :base object :index temp :scale 1
:disp (- (* sb!vm:vector-data-offset
sb!vm:word-bytes)
- sb!vm:other-pointer-type))))))
+ sb!vm:other-pointer-lowtag))))))
#!+long-float
(define-vop (data-vector-ref-c/simple-array-long-float)
:disp (- (+ (* sb!vm:vector-data-offset
sb!vm:word-bytes)
(* 12 index))
- sb!vm:other-pointer-type))))))
+ sb!vm:other-pointer-lowtag))))))
#!+long-float
(define-vop (data-vector-set/simple-array-long-float)
(store-long-float
(make-ea :dword :base object :index temp :scale 1
:disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(unless (zerop (tn-offset result))
;; Value is in ST0 but not result.
(inst fstd result)))
(store-long-float
(make-ea :dword :base object :index temp :scale 1
:disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(cond ((zerop (tn-offset result))
;; The result is in ST0.
(inst fstd value))
:disp (- (+ (* sb!vm:vector-data-offset
sb!vm:word-bytes)
(* 12 index))
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(unless (zerop (tn-offset result))
;; Value is in ST0 but not result.
(inst fstd result)))
:disp (- (+ (* sb!vm:vector-data-offset
sb!vm:word-bytes)
(* 12 index))
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(cond ((zerop (tn-offset result))
;; The result is in ST0.
(inst fstd value))
(inst fld (make-ea :dword :base object :index index :scale 2
:disp (- (* sb!vm:vector-data-offset
sb!vm:word-bytes)
- sb!vm:other-pointer-type)))))
+ sb!vm:other-pointer-lowtag)))))
(let ((imag-tn (complex-single-reg-imag-tn value)))
(with-empty-tn@fp-top (imag-tn)
(inst fld (make-ea :dword :base object :index index :scale 2
:disp (- (* (1+ sb!vm:vector-data-offset)
sb!vm:word-bytes)
- sb!vm:other-pointer-type)))))))
+ sb!vm:other-pointer-lowtag)))))))
(define-vop (data-vector-ref-c/simple-array-complex-single-float)
(:note "inline array access")
:disp (- (+ (* sb!vm:vector-data-offset
sb!vm:word-bytes)
(* 8 index))
- sb!vm:other-pointer-type)))))
+ sb!vm:other-pointer-lowtag)))))
(let ((imag-tn (complex-single-reg-imag-tn value)))
(with-empty-tn@fp-top (imag-tn)
(inst fld (make-ea :dword :base object
:disp (- (+ (* sb!vm:vector-data-offset
sb!vm:word-bytes)
(* 8 index) 4)
- sb!vm:other-pointer-type)))))))
+ sb!vm:other-pointer-lowtag)))))))
(define-vop (data-vector-set/simple-array-complex-single-float)
(:note "inline array store")
(inst fst (make-ea :dword :base object :index index :scale 2
:disp (- (* sb!vm:vector-data-offset
sb!vm:word-bytes)
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(unless (zerop (tn-offset result-real))
;; Value is in ST0 but not result.
(inst fst result-real)))
(inst fst (make-ea :dword :base object :index index :scale 2
:disp (- (* sb!vm:vector-data-offset
sb!vm:word-bytes)
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(cond ((zerop (tn-offset result-real))
;; The result is in ST0.
(inst fst value-real))
:disp (- (+ (* sb!vm:vector-data-offset
sb!vm:word-bytes)
4)
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(unless (location= value-imag result-imag)
(inst fst result-imag))
(inst fxch value-imag))))
:disp (- (+ (* sb!vm:vector-data-offset
sb!vm:word-bytes)
(* 8 index))
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(unless (zerop (tn-offset result-real))
;; Value is in ST0 but not result.
(inst fst result-real)))
:disp (- (+ (* sb!vm:vector-data-offset
sb!vm:word-bytes)
(* 8 index))
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(cond ((zerop (tn-offset result-real))
;; The result is in ST0.
(inst fst value-real))
:disp (- (+ (* sb!vm:vector-data-offset
sb!vm:word-bytes)
(* 8 index) 4)
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(unless (location= value-imag result-imag)
(inst fst result-imag))
(inst fxch value-imag))))
(inst fldd (make-ea :dword :base object :index index :scale 4
:disp (- (* sb!vm:vector-data-offset
sb!vm:word-bytes)
- sb!vm:other-pointer-type)))))
+ sb!vm:other-pointer-lowtag)))))
(let ((imag-tn (complex-double-reg-imag-tn value)))
(with-empty-tn@fp-top (imag-tn)
(inst fldd (make-ea :dword :base object :index index :scale 4
:disp (- (+ (* sb!vm:vector-data-offset
sb!vm:word-bytes)
8)
- sb!vm:other-pointer-type)))))))
+ sb!vm:other-pointer-lowtag)))))))
(define-vop (data-vector-ref-c/simple-array-complex-double-float)
(:note "inline array access")
:disp (- (+ (* sb!vm:vector-data-offset
sb!vm:word-bytes)
(* 16 index))
- sb!vm:other-pointer-type)))))
+ sb!vm:other-pointer-lowtag)))))
(let ((imag-tn (complex-double-reg-imag-tn value)))
(with-empty-tn@fp-top (imag-tn)
(inst fldd (make-ea :dword :base object
:disp (- (+ (* sb!vm:vector-data-offset
sb!vm:word-bytes)
(* 16 index) 8)
- sb!vm:other-pointer-type)))))))
+ sb!vm:other-pointer-lowtag)))))))
(define-vop (data-vector-set/simple-array-complex-double-float)
(:note "inline array store")
(inst fstd (make-ea :dword :base object :index index :scale 4
:disp (- (* sb!vm:vector-data-offset
sb!vm:word-bytes)
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(unless (zerop (tn-offset result-real))
;; Value is in ST0 but not result.
(inst fstd result-real)))
(inst fstd (make-ea :dword :base object :index index :scale 4
:disp (- (* sb!vm:vector-data-offset
sb!vm:word-bytes)
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(cond ((zerop (tn-offset result-real))
;; The result is in ST0.
(inst fstd value-real))
:disp (- (+ (* sb!vm:vector-data-offset
sb!vm:word-bytes)
8)
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(unless (location= value-imag result-imag)
(inst fstd result-imag))
(inst fxch value-imag))))
:disp (- (+ (* sb!vm:vector-data-offset
sb!vm:word-bytes)
(* 16 index))
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(unless (zerop (tn-offset result-real))
;; Value is in ST0 but not result.
(inst fstd result-real)))
:disp (- (+ (* sb!vm:vector-data-offset
sb!vm:word-bytes)
(* 16 index))
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(cond ((zerop (tn-offset result-real))
;; The result is in ST0.
(inst fstd value-real))
:disp (- (+ (* sb!vm:vector-data-offset
sb!vm:word-bytes)
(* 16 index) 8)
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(unless (location= value-imag result-imag)
(inst fstd result-imag))
(inst fxch value-imag))))
(inst fldl (make-ea :dword :base object :index temp :scale 2
:disp (- (* sb!vm:vector-data-offset
sb!vm:word-bytes)
- sb!vm:other-pointer-type)))))
+ sb!vm:other-pointer-lowtag)))))
(let ((imag-tn (complex-long-reg-imag-tn value)))
(with-empty-tn@fp-top (imag-tn)
(inst fldl (make-ea :dword :base object :index temp :scale 2
:disp (- (+ (* sb!vm:vector-data-offset
sb!vm:word-bytes)
12)
- sb!vm:other-pointer-type)))))))
+ sb!vm:other-pointer-lowtag)))))))
#!+long-float
(define-vop (data-vector-ref-c/simple-array-complex-long-float)
:disp (- (+ (* sb!vm:vector-data-offset
sb!vm:word-bytes)
(* 24 index))
- sb!vm:other-pointer-type)))))
+ sb!vm:other-pointer-lowtag)))))
(let ((imag-tn (complex-long-reg-imag-tn value)))
(with-empty-tn@fp-top (imag-tn)
(inst fldl (make-ea :dword :base object
:disp (- (+ (* sb!vm:vector-data-offset
sb!vm:word-bytes)
(* 24 index) 12)
- sb!vm:other-pointer-type)))))))
+ sb!vm:other-pointer-lowtag)))))))
#!+long-float
(define-vop (data-vector-set/simple-array-complex-long-float)
(store-long-float
(make-ea :dword :base object :index temp :scale 2
:disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(unless (zerop (tn-offset result-real))
;; Value is in ST0 but not result.
(inst fstd result-real)))
(store-long-float
(make-ea :dword :base object :index temp :scale 2
:disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(cond ((zerop (tn-offset result-real))
;; The result is in ST0.
(inst fstd value-real))
(store-long-float
(make-ea :dword :base object :index temp :scale 2
:disp (- (+ (* sb!vm:vector-data-offset sb!vm:word-bytes) 12)
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(unless (location= value-imag result-imag)
(inst fstd result-imag))
(inst fxch value-imag))))
:disp (- (+ (* sb!vm:vector-data-offset
sb!vm:word-bytes)
(* 24 index))
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(unless (zerop (tn-offset result-real))
;; Value is in ST0 but not result.
(inst fstd result-real)))
:disp (- (+ (* sb!vm:vector-data-offset
sb!vm:word-bytes)
(* 24 index))
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(cond ((zerop (tn-offset result-real))
;; The result is in ST0.
(inst fstd value-real))
;; instead of appearing to flirt with supporting
;; this maintenance nightmare.
(* 24 index) 12)
- sb!vm:other-pointer-type)))
+ sb!vm:other-pointer-lowtag)))
(unless (location= value-imag result-imag)
(inst fstd result-imag))
(inst fxch value-imag))))
(inst movzx value
(make-ea :byte :base object :index index :scale 1
:disp (- (* vector-data-offset word-bytes)
- other-pointer-type)))))
+ other-pointer-lowtag)))))
(define-vop (data-vector-ref-c/simple-array-unsigned-byte-8)
(:translate data-vector-ref)
(inst movzx value
(make-ea :byte :base object
:disp (- (+ (* vector-data-offset word-bytes) index)
- other-pointer-type)))))
+ other-pointer-lowtag)))))
(define-vop (data-vector-set/simple-array-unsigned-byte-8)
(:translate data-vector-set)
(move eax value)
(inst mov (make-ea :byte :base object :index index :scale 1
:disp (- (* vector-data-offset word-bytes)
- other-pointer-type))
+ other-pointer-lowtag))
al-tn)
(move result eax)))
(move eax value)
(inst mov (make-ea :byte :base object
:disp (- (+ (* vector-data-offset word-bytes) index)
- other-pointer-type))
+ other-pointer-lowtag))
al-tn)
(move result eax)))
(inst movzx value
(make-ea :word :base object :index index :scale 2
:disp (- (* vector-data-offset word-bytes)
- other-pointer-type)))))
+ other-pointer-lowtag)))))
(define-vop (data-vector-ref-c/simple-array-unsigned-byte-16)
(:translate data-vector-ref)
(inst movzx value
(make-ea :word :base object
:disp (- (+ (* vector-data-offset word-bytes) (* 2 index))
- other-pointer-type)))))
+ other-pointer-lowtag)))))
(define-vop (data-vector-set/simple-array-unsigned-byte-16)
(:translate data-vector-set)
(move eax value)
(inst mov (make-ea :word :base object :index index :scale 2
:disp (- (* vector-data-offset word-bytes)
- other-pointer-type))
+ other-pointer-lowtag))
ax-tn)
(move result eax)))
(inst mov (make-ea :word :base object
:disp (- (+ (* vector-data-offset word-bytes)
(* 2 index))
- other-pointer-type))
+ other-pointer-lowtag))
ax-tn)
(move result eax)))
(inst mov al-tn
(make-ea :byte :base object :index index :scale 1
:disp (- (* vector-data-offset word-bytes)
- other-pointer-type)))
+ other-pointer-lowtag)))
(move value al-tn)))
(define-vop (data-vector-ref-c/simple-string)
(inst mov al-tn
(make-ea :byte :base object
:disp (- (+ (* vector-data-offset word-bytes) index)
- other-pointer-type)))
+ other-pointer-lowtag)))
(move value al-tn)))
(define-vop (data-vector-set/simple-string)
(:generator 5
(inst mov (make-ea :byte :base object :index index :scale 1
:disp (- (* vector-data-offset word-bytes)
- other-pointer-type))
+ other-pointer-lowtag))
value)
(move result value)))
(:generator 4
(inst mov (make-ea :byte :base object
:disp (- (+ (* vector-data-offset word-bytes) index)
- other-pointer-type))
+ other-pointer-lowtag))
value)
(move result value)))
(inst movsx value
(make-ea :byte :base object :index index :scale 1
:disp (- (* vector-data-offset word-bytes)
- other-pointer-type)))))
+ other-pointer-lowtag)))))
(define-vop (data-vector-ref-c/simple-array-signed-byte-8)
(:translate data-vector-ref)
(inst movsx value
(make-ea :byte :base object
:disp (- (+ (* vector-data-offset word-bytes) index)
- other-pointer-type)))))
+ other-pointer-lowtag)))))
(define-vop (data-vector-set/simple-array-signed-byte-8)
(:translate data-vector-set)
(move eax value)
(inst mov (make-ea :byte :base object :index index :scale 1
:disp (- (* vector-data-offset word-bytes)
- other-pointer-type))
+ other-pointer-lowtag))
al-tn)
(move result eax)))
(move eax value)
(inst mov (make-ea :byte :base object
:disp (- (+ (* vector-data-offset word-bytes) index)
- other-pointer-type))
+ other-pointer-lowtag))
al-tn)
(move result eax)))
(inst movsx value
(make-ea :word :base object :index index :scale 2
:disp (- (* vector-data-offset word-bytes)
- other-pointer-type)))))
+ other-pointer-lowtag)))))
(define-vop (data-vector-ref-c/simple-array-signed-byte-16)
(:translate data-vector-ref)
(make-ea :word :base object
:disp (- (+ (* vector-data-offset word-bytes)
(* 2 index))
- other-pointer-type)))))
+ other-pointer-lowtag)))))
(define-vop (data-vector-set/simple-array-signed-byte-16)
(:translate data-vector-set)
(move eax value)
(inst mov (make-ea :word :base object :index index :scale 2
:disp (- (* vector-data-offset word-bytes)
- other-pointer-type))
+ other-pointer-lowtag))
ax-tn)
(move result eax)))
(make-ea :word :base object
:disp (- (+ (* vector-data-offset word-bytes)
(* 2 index))
- other-pointer-type))
+ other-pointer-lowtag))
ax-tn)
(move result eax)))
\f
;;; These vops are useful for accessing the bits of a vector
;;; irrespective of what type of vector it is.
-(define-full-reffer raw-bits * 0 other-pointer-type (unsigned-reg)
+(define-full-reffer raw-bits * 0 other-pointer-lowtag (unsigned-reg)
unsigned-num %raw-bits)
-(define-full-setter set-raw-bits * 0 other-pointer-type (unsigned-reg)
+(define-full-setter set-raw-bits * 0 other-pointer-lowtag (unsigned-reg)
unsigned-num %set-raw-bits)
\f
;;;; miscellaneous array VOPs
:disp (+ nil-value
(static-symbol-offset '*alien-stack*)
(ash symbol-value-slot word-shift)
- (- other-pointer-type)))
+ (- other-pointer-lowtag)))
delta)))
(load-symbol-value result *alien-stack*)))
:disp (+ nil-value
(static-symbol-offset '*alien-stack*)
(ash symbol-value-slot word-shift)
- (- other-pointer-type)))
+ (- other-pointer-lowtag)))
delta)))))
(make-ea :dword :base eax
:disp ,(if named
'(- (* fdefn-raw-addr-slot word-bytes)
- other-pointer-type)
+ other-pointer-lowtag)
'(- (* closure-fun-slot word-bytes)
- fun-pointer-type))))
+ fun-pointer-lowtag))))
,@(ecase return
(:fixed
'((default-unknown-values vop values nvals)))
(inst lea dst (make-ea :dword :index ecx :scale 2))
(pseudo-atomic
(allocation dst dst node)
- (inst lea dst (make-ea :byte :base dst :disp list-pointer-type))
+ (inst lea dst (make-ea :byte :base dst :disp list-pointer-lowtag))
;; Convert the count into a raw value, so that we can use the LOOP inst.
(inst shr ecx 2)
;; Set decrement mode (successive args at lower addresses)
;; Compute a pointer to the next cons.
(inst add dst (* cons-size word-bytes))
;; Store a pointer to this cons in the CDR of the previous cons.
- (storew dst dst -1 list-pointer-type)
+ (storew dst dst -1 list-pointer-lowtag)
(emit-label enter)
;; Grab one value and stash it in the car of this cons.
(inst lods eax)
- (storew eax dst 0 list-pointer-type)
+ (storew eax dst 0 list-pointer-lowtag)
;; Go back for more.
(inst loop loop)
;; NIL out the last cons.
- (storew nil-value dst 1 sb!vm:list-pointer-type))
+ (storew nil-value dst 1 sb!vm:list-pointer-lowtag))
(emit-label done))))
-;;; Return the location and size of the more arg glob created by Copy-More-Arg.
-;;; Supplied is the total number of arguments supplied (originally passed in
-;;; ECX.) Fixed is the number of non-rest arguments.
+;;; Return the location and size of the &MORE arg glob created by
+;;; COPY-MORE-Arg. SUPPLIED is the total number of arguments supplied
+;;; (originally passed in ECX). FIXED is the number of non-rest
+;;; arguments.
;;;
-;;; We must duplicate some of the work done by Copy-More-Arg, since at that
-;;; time the environment is in a pretty brain-damaged state, preventing this
-;;; info from being returned as values. What we do is compute
-;;; supplied - fixed, and return a pointer that many words below the current
-;;; stack top.
+;;; We must duplicate some of the work done by COPY-MORE-ARG, since at
+;;; that time the environment is in a pretty brain-damaged state,
+;;; preventing this info from being returned as values. What we do is
+;;; compute supplied - fixed, and return a pointer that many words
+;;; below the current stack top.
(define-vop (more-arg-context)
(:policy :fast-safe)
(:translate sb!c::%more-arg-context)
(unless (zerop fixed)
(inst sub count (fixnumize fixed)))))
-;;; Signal wrong argument count error if Nargs isn't = to Count.
+;;; Signal wrong argument count error if NARGS isn't equal to COUNT.
(define-vop (verify-argument-count)
(:policy :fast-safe)
(:translate sb!c::%verify-argument-count)
;;; 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)
(:save-p :compute-only)
(:generator 9
(let ((err-lab (generate-error-code vop unbound-symbol-error object)))
- (loadw value object symbol-value-slot other-pointer-type)
+ (loadw value object symbol-value-slot other-pointer-lowtag)
(inst cmp value unbound-marker-type)
(inst jmp :e err-lab))))
(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))
(defknown fast-symbol-value-xadd (symbol fixnum) fixnum ())
(define-vop (fast-symbol-value-xadd cell-xadd)
- (:variant symbol-value-slot other-pointer-type)
+ (:variant symbol-value-slot other-pointer-lowtag)
(:policy :fast)
(:translate fast-symbol-value-xadd)
(:arg-types * tagged-num))
(:info target not-p)
(:temporary (:sc descriptor-reg :from (:argument 0)) value)
(:generator 9
- (loadw value object symbol-value-slot other-pointer-type)
+ (loadw value object symbol-value-slot other-pointer-lowtag)
(inst cmp value unbound-marker-type)
(inst jmp (if not-p :e :ne) target)))
;; is the second slot, and offset 0 = tags and stuff (and CAR slot in
;; a CONS), offset 1 = value slot (and CDR slot in a CONS), and
;; offset 2 = hash slot.
- (loadw res symbol symbol-hash-slot other-pointer-type)
+ (loadw res symbol symbol-hash-slot other-pointer-lowtag)
(inst and res (lognot #b11))))
\f
;;;; fdefinition (FDEFN) objects
(define-vop (fdefn-fun cell-ref) ; /pfw - alpha
- (:variant fdefn-fun-slot other-pointer-type))
+ (:variant fdefn-fun-slot other-pointer-lowtag))
(define-vop (safe-fdefn-fun)
(:args (object :scs (descriptor-reg) :to (:result 1)))
(:vop-var vop)
(:save-p :compute-only)
(:generator 10
- (loadw value object fdefn-fun-slot other-pointer-type)
+ (loadw value object fdefn-fun-slot other-pointer-lowtag)
(inst cmp value nil-value)
;; FIXME: UNDEFINED-SYMBOL-ERROR seems to actually be for symbols with no
;; function value, not, as the name might suggest, symbols with no ordinary
(:temporary (:sc byte-reg) type)
(:results (result :scs (descriptor-reg)))
(:generator 38
- (load-type type function (- fun-pointer-type))
+ (load-type type function (- fun-pointer-lowtag))
(inst lea raw
(make-ea :byte :base function
:disp (- (* simple-fun-code-offset word-bytes)
- fun-pointer-type)))
+ fun-pointer-lowtag)))
(inst cmp type simple-fun-header-type)
(inst jmp :e normal-fn)
(inst lea raw (make-fixup (extern-alien-name "closure_tramp") :foreign))
NORMAL-FN
- (storew function fdefn fdefn-fun-slot other-pointer-type)
- (storew raw fdefn fdefn-raw-addr-slot other-pointer-type)
+ (storew function fdefn fdefn-fun-slot other-pointer-lowtag)
+ (storew raw fdefn fdefn-raw-addr-slot other-pointer-lowtag)
(move result function)))
(define-vop (fdefn-makunbound)
(:args (fdefn :scs (descriptor-reg) :target result))
(:results (result :scs (descriptor-reg)))
(:generator 38
- (storew nil-value fdefn fdefn-fun-slot other-pointer-type)
+ (storew nil-value fdefn fdefn-fun-slot other-pointer-lowtag)
(storew (make-fixup (extern-alien-name "undefined_tramp") :foreign)
- fdefn fdefn-raw-addr-slot other-pointer-type)
+ fdefn fdefn-raw-addr-slot other-pointer-lowtag)
(move result fdefn)))
\f
;;;; binding and unbinding
(:temporary (:sc unsigned-reg) temp bsp)
(:generator 5
(load-symbol-value bsp *binding-stack-pointer*)
- (loadw temp symbol symbol-value-slot other-pointer-type)
+ (loadw temp symbol symbol-value-slot other-pointer-lowtag)
(inst add bsp (* binding-size word-bytes))
(store-symbol-value bsp *binding-stack-pointer*)
(storew temp bsp (- binding-value-slot binding-size))
(storew symbol bsp (- binding-symbol-slot binding-size))
- (storew val symbol symbol-value-slot other-pointer-type)))
+ (storew val symbol symbol-value-slot other-pointer-lowtag)))
(define-vop (unbind)
(:temporary (:sc unsigned-reg) symbol value bsp)
(load-symbol-value bsp *binding-stack-pointer*)
(loadw symbol bsp (- binding-symbol-slot binding-size))
(loadw value bsp (- binding-value-slot binding-size))
- (storew value symbol symbol-value-slot other-pointer-type)
+ (storew value symbol symbol-value-slot other-pointer-lowtag)
(storew 0 bsp (- binding-symbol-slot binding-size))
(inst sub bsp (* binding-size word-bytes))
(store-symbol-value bsp *binding-stack-pointer*)))
(inst or symbol symbol)
(inst jmp :z skip)
(loadw value bsp (- binding-value-slot binding-size))
- (storew value symbol symbol-value-slot other-pointer-type)
+ (storew value symbol symbol-value-slot other-pointer-lowtag)
(storew 0 bsp (- binding-symbol-slot binding-size))
SKIP
;;;; closure indexing
(define-full-reffer closure-index-ref *
- closure-info-offset fun-pointer-type
+ closure-info-offset fun-pointer-lowtag
(any-reg descriptor-reg) * %closure-index-ref)
(define-full-setter set-funcallable-instance-info *
- funcallable-instance-info-offset fun-pointer-type
+ funcallable-instance-info-offset fun-pointer-lowtag
(any-reg descriptor-reg) * %set-funcallable-instance-info)
(define-full-reffer funcallable-instance-info *
- funcallable-instance-info-offset fun-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 fun-pointer-type))
+ (:variant funcallable-instance-lexenv-slot fun-pointer-lowtag))
(define-vop (closure-ref slot-ref)
- (:variant closure-info-offset fun-pointer-type))
+ (:variant closure-info-offset fun-pointer-lowtag))
(define-vop (closure-init slot-set)
- (:variant closure-info-offset fun-pointer-type))
+ (:variant closure-info-offset fun-pointer-lowtag))
\f
;;;; 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
;;;; structure hackery
(:results (res :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:generator 4
- (loadw res struct 0 instance-pointer-type)
+ (loadw res struct 0 instance-pointer-lowtag)
(inst shr res type-bits)))
(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 (any-reg descriptor-reg) * %instance-ref)
+ instance-pointer-lowtag (any-reg descriptor-reg) * %instance-ref)
(define-full-setter instance-index-set * instance-slots-offset
- instance-pointer-type (any-reg descriptor-reg) * %instance-set)
+ instance-pointer-lowtag (any-reg descriptor-reg) * %instance-set)
(defknown sb!kernel::%instance-set-conditional (instance index t t) t
(unsafe))
(define-vop (instance-set-conditional-c slot-set-conditional)
(:policy :fast-safe)
(:translate sb!kernel::%instance-set-conditional)
- (:variant instance-slots-offset instance-pointer-type)
+ (:variant instance-slots-offset instance-pointer-lowtag)
(:arg-types instance (:constant index) * *))
(define-vop (instance-set-conditional)
(move temp new-value)
(inst cmpxchg (make-ea :dword :base object :index slot :scale 1
:disp (- (* instance-slots-offset word-bytes)
- instance-pointer-type))
+ instance-pointer-lowtag))
temp)
(move result eax)))
(define-vop (instance-xadd-c slot-xadd)
(:policy :fast-safe)
(:translate %instance-xadd)
- (:variant instance-slots-offset instance-pointer-type)
+ (:variant instance-slots-offset instance-pointer-lowtag)
(:arg-types instance (:constant index) tagged-num))
\f
;;;; code object frobbing
-(define-full-reffer code-header-ref * 0 other-pointer-type
+(define-full-reffer code-header-ref * 0 other-pointer-lowtag
(any-reg descriptor-reg) * code-header-ref)
-(define-full-setter code-header-set * 0 other-pointer-type
+(define-full-setter code-header-set * 0 other-pointer-lowtag
(any-reg descriptor-reg) * code-header-set)
(inst shr temp type-bits)
(inst jmp :z bogus)
(inst shl temp (1- (integer-length word-bytes)))
- (unless (= lowtag other-pointer-type)
- (inst add temp (- lowtag other-pointer-type)))
+ (unless (= lowtag other-pointer-lowtag)
+ (inst add temp (- lowtag other-pointer-lowtag)))
(move code thing)
(inst sub code temp)
(emit-label done)
(define-vop (code-from-lra code-from-mumble)
(:translate sb!di::lra-code-header)
- (:variant other-pointer-type))
+ (:variant other-pointer-lowtag))
(define-vop (code-from-function code-from-mumble)
(:translate sb!di::fun-code-header)
- (:variant fun-pointer-type))
+ (:variant fun-pointer-lowtag))
(define-vop (make-lisp-obj)
(:policy :fast-safe)
(:results (res :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:generator 5
- (loadw res fun 0 fun-pointer-type)
+ (loadw res fun 0 fun-pointer-lowtag)
(inst shr res type-bits)))
(macrolet ((ea-for-xf-desc (tn slot)
`(make-ea
:dword :base ,tn
- :disp (- (* ,slot sb!vm:word-bytes) sb!vm:other-pointer-type))))
+ :disp (- (* ,slot sb!vm:word-bytes)
+ sb!vm:other-pointer-lowtag))))
(defun ea-for-sf-desc (tn)
(ea-for-xf-desc tn sb!vm:single-float-value-slot))
(defun ea-for-df-desc (tn)
(descriptor-reg
(loadw
bits float sb!vm:single-float-value-slot
- sb!vm:other-pointer-type))))
+ sb!vm:other-pointer-lowtag))))
(signed-stack
(sc-case float
(single-reg
(loadw hi-bits ebp-tn (- (1+ (tn-offset float)))))
(descriptor-reg
(loadw hi-bits float (1+ sb!vm:double-float-value-slot)
- sb!vm:other-pointer-type)))))
+ sb!vm:other-pointer-lowtag)))))
(define-vop (double-float-low-bits)
(:args (float :scs (double-reg descriptor-reg)
(loadw lo-bits ebp-tn (- (+ 2 (tn-offset float)))))
(descriptor-reg
(loadw lo-bits float sb!vm:double-float-value-slot
- sb!vm:other-pointer-type)))))
+ sb!vm:other-pointer-lowtag)))))
#!+long-float
(define-vop (long-float-exp-bits)
(make-ea :word :base float
:disp (- (* (+ 2 sb!vm:long-float-value-slot)
word-bytes)
- sb!vm:other-pointer-type)))))))
+ sb!vm:other-pointer-lowtag)))))))
#!+long-float
(define-vop (long-float-high-bits)
(loadw hi-bits ebp-tn (- (+ (tn-offset float) 2))))
(descriptor-reg
(loadw hi-bits float (1+ sb!vm:long-float-value-slot)
- sb!vm:other-pointer-type)))))
+ sb!vm:other-pointer-lowtag)))))
#!+long-float
(define-vop (long-float-low-bits)
(loadw lo-bits ebp-tn (- (+ (tn-offset float) 3))))
(descriptor-reg
(loadw lo-bits float sb!vm:long-float-value-slot
- sb!vm:other-pointer-type)))))
+ sb!vm:other-pointer-lowtag)))))
\f
;;;; float mode hackery
(- (+ (component-header-length)
(or (label-position offset)
0))
- other-pointer-type))))
+ other-pointer-lowtag))))
(emit-dword segment (or offset 0)))))
(defun emit-relative-fixup (segment fixup)
(make-fixup nil
:code-object
(- (* (tn-offset thing) word-bytes)
- other-pointer-type))))))
+ other-pointer-lowtag))))))
(ea
(let* ((base (ea-base thing))
(index (ea-index thing))
:disp (+ nil-value
(static-symbol-offset ',symbol)
(ash symbol-value-slot word-shift)
- (- other-pointer-type)))))
+ (- other-pointer-lowtag)))))
(defmacro store-symbol-value (reg symbol)
`(inst mov
:disp (+ nil-value
(static-symbol-offset ',symbol)
(ash symbol-value-slot word-shift)
- (- other-pointer-type)))
+ (- other-pointer-lowtag)))
,reg))
(allocation ,result-tn (pad-data-block ,size) ,inline)
(storew (logior (ash (1- ,size) sb!vm:type-bits) ,type-code) ,result-tn)
(inst lea ,result-tn
- (make-ea :byte :base ,result-tn :disp other-pointer-type))
+ (make-ea :byte :base ,result-tn :disp other-pointer-lowtag))
,@forms))
\f
;;;; error code
(ash symbol-value-slot word-shift)
;; FIXME: Use mask, not minus, to
;; take out type bits.
- (- other-pointer-type)))
+ (- other-pointer-lowtag)))
0)
(inst mov (make-ea :byte :disp (+ nil-value
(static-symbol-offset
'*pseudo-atomic-atomic*)
(ash symbol-value-slot word-shift)
- (- other-pointer-type)))
+ (- other-pointer-lowtag)))
(fixnumize 1)))
,@forms
(when *enable-pseudo-atomic*
(static-symbol-offset
'*pseudo-atomic-atomic*)
(ash symbol-value-slot word-shift)
- (- other-pointer-type)))
+ (- other-pointer-lowtag)))
0)
;; KLUDGE: Is there any requirement for interrupts to be
;; handled in order? It seems as though an interrupt coming
(static-symbol-offset
'*pseudo-atomic-interrupted*)
(ash symbol-value-slot word-shift)
- (- other-pointer-type)))
+ (- other-pointer-lowtag)))
0)
(inst jmp :eq ,label)
(inst break pending-interrupt-trap)
(move eax x)
(inst test al-tn 3)
(inst jmp :z fixnum)
- (loadw y eax bignum-digits-offset other-pointer-type)
+ (loadw y eax bignum-digits-offset other-pointer-lowtag)
(inst jmp done)
FIXNUM
(inst sar eax 2)
(emit-label bignum)
(with-fixed-allocation
(y bignum-type (+ bignum-digits-offset 1) node)
- (storew x y bignum-digits-offset other-pointer-type))
+ (storew x y bignum-digits-offset other-pointer-lowtag))
(inst jmp done)))))
(define-move-vop move-from-signed :move
(signed-reg) (descriptor-reg))
(pseudo-atomic
(allocation alloc (pad-data-block (+ bignum-digits-offset 2)) node)
(storew y alloc)
- (inst lea y (make-ea :byte :base alloc :disp other-pointer-type))
- (storew x y bignum-digits-offset other-pointer-type))
+ (inst lea y (make-ea :byte :base alloc :disp other-pointer-lowtag))
+ (storew x y bignum-digits-offset other-pointer-lowtag))
(inst jmp done)))))
(define-move-vop move-from-unsigned :move
(unsigned-reg) (descriptor-reg))
(:results (y :scs (sap-reg)))
(:note "pointer to SAP coercion")
(:generator 1
- (loadw y x sap-pointer-slot other-pointer-type)))
+ (loadw y x sap-pointer-slot other-pointer-lowtag)))
(define-move-vop move-to-sap :move
(descriptor-reg) (sap-reg))
(:node-var node)
(:generator 20
(with-fixed-allocation (res sap-type sap-size node)
- (storew sap res sap-pointer-slot other-pointer-type))))
+ (storew sap res sap-pointer-slot other-pointer-lowtag))))
(define-move-vop move-from-sap :move
(sap-reg) (descriptor-reg))
(:result-types system-area-pointer)
(:generator 2
(move sap vector)
- (inst add sap (- (* vector-data-offset word-bytes) other-pointer-type))))
+ (inst add sap (- (* vector-data-offset word-bytes) other-pointer-lowtag))))
;; list, because this is a :fast-safe vop.
LOOP
;; Get the CDR and boost the count.
- (loadw ptr ptr cons-cdr-slot list-pointer-type)
+ (loadw ptr ptr cons-cdr-slot list-pointer-lowtag)
(inst add count (fixnumize 1))
;; If we hit NIL, then we are done.
(inst cmp ptr nil-value)
;; not, loop back for more.
(move eax ptr)
(inst and al-tn lowtag-mask)
- (inst cmp al-tn list-pointer-type)
+ (inst cmp al-tn list-pointer-lowtag)
(inst jmp :e loop)
;; It's dotted all right. Flame out.
(error-call vop object-not-list-error ptr)
(inst jmp :e done)
;; Indirect the next cons cell, and boost the count.
LOOP
- (loadw ptr ptr cons-cdr-slot list-pointer-type)
+ (loadw ptr ptr cons-cdr-slot list-pointer-lowtag)
(inst add count (fixnumize 1))
;; If we aren't done, go back for more.
(inst cmp ptr nil-value)
(:generator 6
(inst mov eax object)
(inst and al-tn lowtag-mask)
- (inst cmp al-tn other-pointer-type)
+ (inst cmp al-tn other-pointer-lowtag)
(inst jmp :e other-ptr)
- (inst cmp al-tn fun-pointer-type)
+ (inst cmp al-tn fun-pointer-lowtag)
(inst jmp :e function-ptr)
;; Pick off structures and list pointers.
(inst jmp done)
FUNCTION-PTR
- (load-type al-tn object (- sb!vm:fun-pointer-type))
+ (load-type al-tn object (- sb!vm:fun-pointer-lowtag))
(inst jmp done)
OTHER-PTR
- (load-type al-tn object (- sb!vm:other-pointer-type))
+ (load-type al-tn object (- sb!vm:other-pointer-lowtag))
DONE
(inst movzx result al-tn)))
(:results (result :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:generator 6
- (load-type temp function (- sb!vm:fun-pointer-type))
+ (load-type temp function (- sb!vm:fun-pointer-lowtag))
(inst movzx result temp)))
(define-vop (set-function-subtype)
(:generator 6
(move eax type)
(inst mov
- (make-ea :byte :base function :disp (- fun-pointer-type))
+ (make-ea :byte :base function :disp (- fun-pointer-lowtag))
al-tn)
(move result eax)))
(:results (res :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:generator 6
- (loadw res x 0 other-pointer-type)
+ (loadw res x 0 other-pointer-lowtag)
(inst shr res type-bits)))
(define-vop (get-closure-length)
(:results (res :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:generator 6
- (loadw res x 0 fun-pointer-type)
+ (loadw res x 0 fun-pointer-lowtag)
(inst shr res type-bits)))
(define-vop (set-header-data)
(:generator 6
(move eax data)
(inst shl eax (- type-bits 2))
- (inst mov al-tn (make-ea :byte :base x :disp (- other-pointer-type)))
- (storew eax x 0 other-pointer-type)
+ (inst mov al-tn (make-ea :byte :base x :disp (- other-pointer-lowtag)))
+ (storew eax x 0 other-pointer-lowtag)
(move res x)))
\f
(define-vop (make-fixnum)
(:results (sap :scs (sap-reg) :from (:argument 0)))
(:result-types system-area-pointer)
(:generator 10
- (loadw sap code 0 other-pointer-type)
+ (loadw sap code 0 other-pointer-lowtag)
(inst shr sap type-bits)
(inst lea sap (make-ea :byte :base code :index sap :scale 4
- :disp (- other-pointer-type)))))
+ :disp (- other-pointer-lowtag)))))
(define-vop (compute-function)
(:args (code :scs (descriptor-reg) :to (:result 0))
(:arg-types * positive-fixnum)
(:results (func :scs (descriptor-reg) :from (:argument 0)))
(:generator 10
- (loadw func code 0 other-pointer-type)
+ (loadw func code 0 other-pointer-lowtag)
(inst shr func type-bits)
(inst lea func
(make-ea :byte :base offset :index func :scale 4
- :disp (- fun-pointer-type other-pointer-type)))
+ :disp (- fun-pointer-lowtag other-pointer-lowtag)))
(inst add func code)))
(define-vop (%simple-fun-self)
(:args (function :scs (descriptor-reg)))
(:results (result :scs (descriptor-reg)))
(:generator 3
- (loadw result function simple-fun-self-slot fun-pointer-type)
+ (loadw result function simple-fun-self-slot fun-pointer-lowtag)
(inst lea result
(make-ea :byte :base result
- :disp (- fun-pointer-type
+ :disp (- fun-pointer-lowtag
(* simple-fun-code-offset word-bytes))))))
;;; The closure function slot is a pointer to raw code on X86 instead
(inst lea temp
(make-ea :byte :base new-self
:disp (- (ash simple-fun-code-offset word-shift)
- fun-pointer-type)))
- (storew temp function simple-fun-self-slot fun-pointer-type)
+ fun-pointer-lowtag)))
+ (storew temp function simple-fun-self-slot fun-pointer-lowtag)
(move result new-self)))
;;; KLUDGE: This seems to be some kind of weird override of the way
(:generator 0
(inst inc (make-ea :dword :base count-vector
:disp (- (* (+ vector-data-offset index) word-bytes)
- other-pointer-type)))))
+ other-pointer-lowtag)))))
(collect ((results))
(let ((start nil)
(prev nil)
- (delta (- other-immediate-1-type other-immediate-0-type)))
+ (delta (- other-immediate-1-lowtag other-immediate-0-lowtag)))
(flet ((emit-test ()
(results (if (= start prev)
start
(macrolet ((test-type (value target not-p &rest type-codes)
;; Determine what interesting combinations we need to test for.
(let* ((type-codes (mapcar #'eval type-codes))
- (fixnump (and (member even-fixnum-type type-codes)
- (member odd-fixnum-type type-codes)
+ (fixnump (and (member even-fixnum-lowtag type-codes)
+ (member odd-fixnum-lowtag type-codes)
t))
(lowtags (remove lowtag-limit type-codes :test #'<))
(extended (remove lowtag-limit type-codes :test #'>))
(cond
(fixnump
(when (remove-if #'(lambda (x)
- (or (= x even-fixnum-type)
- (= x odd-fixnum-type)))
+ (or (= x even-fixnum-lowtag)
+ (= x odd-fixnum-lowtag)))
lowtags)
(error "can't mix fixnum testing with other lowtags"))
(when function-p
(defun %test-headers (value target not-p function-p headers
&optional (drop-through (gen-label)) al-loaded)
- (let ((lowtag (if function-p fun-pointer-type other-pointer-type)))
+ (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
(multiple-value-bind (equal less-or-equal when-true when-false)
;; EQUAL and LESS-OR-EQUAL are the conditions for branching to TARGET.
;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when we know
#+nil
(defun %test-headers (value target not-p function-p headers
&optional (drop-through (gen-label)) al-loaded)
- (let ((lowtag (if function-p fun-pointer-type other-pointer-type)))
+ (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
(multiple-value-bind (equal less-or-equal when-true when-false)
;; EQUAL and LESS-OR-EQUAL are the conditions for branching to TARGET.
;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when we know
`((primitive-type-vop ,check-name (:check) ,ptype))))))
(def-simple-type-vops fixnump check-fixnum fixnum object-not-fixnum-error
- even-fixnum-type odd-fixnum-type)
+ even-fixnum-lowtag odd-fixnum-lowtag)
(def-type-vops functionp check-function function
- object-not-function-error fun-pointer-type)
+ object-not-function-error fun-pointer-lowtag)
(def-type-vops listp check-list list object-not-list-error
- list-pointer-type)
+ list-pointer-lowtag)
(def-type-vops %instancep check-instance instance object-not-instance-error
- instance-pointer-type)
+ instance-pointer-lowtag)
(def-type-vops bignump check-bignum bignum
object-not-bignum-error bignum-type)
complex-array-type)
(def-type-vops numberp check-number nil object-not-number-error
- even-fixnum-type odd-fixnum-type bignum-type ratio-type
+ even-fixnum-lowtag odd-fixnum-lowtag bignum-type ratio-type
single-float-type double-float-type #!+long-float long-float-type complex-type
complex-single-float-type complex-double-float-type
#!+long-float complex-long-float-type)
(def-type-vops rationalp check-rational nil object-not-rational-error
- even-fixnum-type odd-fixnum-type ratio-type bignum-type)
+ even-fixnum-lowtag odd-fixnum-lowtag ratio-type bignum-type)
(def-type-vops integerp check-integer nil object-not-integer-error
- even-fixnum-type odd-fixnum-type bignum-type)
+ even-fixnum-lowtag odd-fixnum-lowtag bignum-type)
(def-type-vops floatp check-float nil object-not-float-error
single-float-type double-float-type #!+long-float long-float-type)
(def-type-vops realp check-real nil object-not-real-error
- even-fixnum-type odd-fixnum-type ratio-type bignum-type
+ even-fixnum-lowtag odd-fixnum-lowtag ratio-type bignum-type
single-float-type double-float-type #!+long-float long-float-type)
\f
;;;; other integer ranges
(inst jmp :e yep)
(move eax-tn value)
(inst and al-tn lowtag-mask)
- (inst cmp al-tn other-pointer-type)
+ (inst cmp al-tn other-pointer-lowtag)
(inst jmp :ne nope)
- (loadw eax-tn value 0 other-pointer-type)
+ (loadw eax-tn value 0 other-pointer-lowtag)
(inst cmp eax-tn (+ (ash 1 type-bits) bignum-type))
(inst jmp (if not-p :ne :e) target))
NOT-TARGET))
(inst jmp :e yep)
(move eax-tn value)
(inst and al-tn lowtag-mask)
- (inst cmp al-tn other-pointer-type)
+ (inst cmp al-tn other-pointer-lowtag)
(inst jmp :ne nope)
- (loadw eax-tn value 0 other-pointer-type)
+ (loadw eax-tn value 0 other-pointer-lowtag)
(inst cmp eax-tn (+ (ash 1 type-bits) bignum-type))
(inst jmp :ne nope))
YEP
;; If not, is it an other pointer?
(inst and al-tn lowtag-mask)
- (inst cmp al-tn other-pointer-type)
+ (inst cmp al-tn other-pointer-lowtag)
(inst jmp :ne nope)
;; Get the header.
- (loadw eax-tn value 0 other-pointer-type)
+ (loadw eax-tn value 0 other-pointer-lowtag)
;; Is it one?
(inst cmp eax-tn (+ (ash 1 type-bits) bignum-type))
(inst jmp :e single-word)
(inst cmp eax-tn (+ (ash 2 type-bits) bignum-type))
(inst jmp :ne nope)
;; Get the second digit.
- (loadw eax-tn value (1+ bignum-digits-offset) other-pointer-type)
+ (loadw eax-tn value (1+ bignum-digits-offset) other-pointer-lowtag)
;; All zeros, its an (unsigned-byte 32).
(inst or eax-tn eax-tn)
(inst jmp :z yep)
(emit-label single-word)
;; Get the single digit.
- (loadw eax-tn value bignum-digits-offset other-pointer-type)
+ (loadw eax-tn value bignum-digits-offset other-pointer-lowtag)
;; positive implies (unsigned-byte 32).
(emit-label fixnum)
;; If not, is it an other pointer?
(inst and al-tn lowtag-mask)
- (inst cmp al-tn other-pointer-type)
+ (inst cmp al-tn other-pointer-lowtag)
(inst jmp :ne nope)
;; Get the header.
- (loadw eax-tn value 0 other-pointer-type)
+ (loadw eax-tn value 0 other-pointer-lowtag)
;; Is it one?
(inst cmp eax-tn (+ (ash 1 type-bits) bignum-type))
(inst jmp :e single-word)
(inst cmp eax-tn (+ (ash 2 type-bits) bignum-type))
(inst jmp :ne nope)
;; Get the second digit.
- (loadw eax-tn value (1+ bignum-digits-offset) other-pointer-type)
+ (loadw eax-tn value (1+ bignum-digits-offset) other-pointer-lowtag)
;; All zeros, its an (unsigned-byte 32).
(inst or eax-tn eax-tn)
(inst jmp :z yep)
(emit-label single-word)
;; Get the single digit.
- (loadw eax-tn value bignum-digits-offset other-pointer-type)
+ (loadw eax-tn value bignum-digits-offset other-pointer-lowtag)
;; positive implies (unsigned-byte 32).
(emit-label fixnum)
(let ((is-not-cons-label (if not-p target drop-thru)))
(inst cmp value nil-value)
(inst jmp :e is-not-cons-label)
- (test-type value target not-p list-pointer-type))
+ (test-type value target not-p list-pointer-lowtag))
DROP-THRU))
(define-vop (check-cons check-type)
(let ((error (generate-error-code vop object-not-cons-error value)))
(inst cmp value nil-value)
(inst jmp :e error)
- (test-type value error t list-pointer-type)
+ (test-type value error t list-pointer-lowtag)
(move result value))))
\f
) ; MACROLET
LOOP
(inst cmp list nil-temp)
(inst jmp :e done)
- (pushw list cons-car-slot list-pointer-type)
- (loadw list list cons-cdr-slot list-pointer-type)
+ (pushw list cons-car-slot list-pointer-lowtag)
+ (loadw list list cons-cdr-slot list-pointer-lowtag)
(inst mov eax list)
(inst and al-tn lowtag-mask)
- (inst cmp al-tn list-pointer-type)
+ (inst cmp al-tn list-pointer-lowtag)
(inst jmp :e loop)
(error-call vop bogus-argument-to-values-list-error list)
#define SET_GC_TRIGGER(new_value) \
clear_auto_gc_trigger(); set_auto_gc_trigger(new_value);
-#define ALIGNED_SIZE(n) (n+lowtag_Mask) & ~lowtag_Mask
+#define ALIGNED_SIZE(n) (n+LOWTAG_MASK) & ~LOWTAG_MASK
#if defined GENCGC
extern lispobj *alloc(int bytes);
lispobj *result;
/* Round to dual word boundary. */
- bytes = (bytes + lowtag_Mask) & ~lowtag_Mask;
+ bytes = (bytes + LOWTAG_MASK) & ~LOWTAG_MASK;
result = GET_FREE_POINTER();
lispobj *result;
result = alloc(ALIGNED_SIZE((1 + words) * sizeof(lispobj)));
- *result = (lispobj) (words << type_Bits) | type;
+ *result = (lispobj) (words << N_TYPE_BITS) | type;
return result;
}
result->header = type;
result->length = make_fixnum(length);
- return ((lispobj)result)|type_OtherPointer;
+ return ((lispobj)result)|OTHER_POINTER_LOWTAG;
}
lispobj
ptr->car = car;
ptr->cdr = cdr;
- return (lispobj)ptr | type_ListPointer;
+ return (lispobj)ptr | LIST_POINTER_LOWTAG;
}
lispobj
ptr->digits[0] = n;
- return (lispobj) ptr | type_OtherPointer;
+ return (lispobj) ptr | OTHER_POINTER_LOWTAG;
}
}
struct sap *sap =
(struct sap *)alloc_unboxed((int)type_Sap, n_words_to_alloc);
sap->pointer = ptr;
- return (lispobj) sap | type_OtherPointer;
+ return (lispobj) sap | OTHER_POINTER_LOWTAG;
}
ldl reg_A5,20(reg_CFP)
/* This call will 'return' into the LRA page below */
- lda reg_LRA,call_into_lisp_LRA_page+type_OtherPointer
+ lda reg_LRA,call_into_lisp_LRA_page+OTHER_POINTER_LOWTAG
/* Indirect the closure */
ldl reg_CODE, CLOSURE_FUN_OFFSET(reg_LEXENV)
- addl reg_CODE,6*4-type_FunPointer, reg_LIP
+ addl reg_CODE,6*4-FUN_POINTER_LOWTAG, reg_LIP
/* And into lisp we go. */
jsr reg_ZERO,(reg_LIP)
addq reg_CFP, 32, reg_CSP
stl reg_OCFP, 0(reg_CFP)
subl reg_LIP, reg_CODE, reg_L1
- addl reg_L1, type_OtherPointer, reg_L1
+ addl reg_L1, OTHER_POINTER_LOWTAG, reg_L1
stl reg_L1, 4(reg_CFP)
stl reg_CODE, 8(reg_CFP)
stl reg_NULL, 12(reg_CFP)
/* can you see anything here which touches LRA? I can't ...*/
ldl reg_CODE, 8(reg_CFP)
ldl reg_NL0, 4(reg_CFP)
- subq reg_NL0, type_OtherPointer, reg_NL0
+ subq reg_NL0, OTHER_POINTER_LOWTAG, reg_NL0
addq reg_CODE, reg_NL0, reg_NL0
mov reg_CFP, reg_CSP
unsigned long pc;
info->interrupted = 1;
- if (LowtagOf(*os_context_register_addr(context, reg_CODE))
- == type_FunPointer) {
+ if (lowtagof(*os_context_register_addr(context, reg_CODE))
+ == FUN_POINTER_LOWTAG) {
/* We tried to call a function, but crapped out before $CODE could
* be fixed up. Probably an undefined function. */
info->frame =
if (info.code != (struct code *) 0) {
lispobj function;
- printf("CODE: 0x%08X, ", (unsigned long) info.code | type_OtherPointer);
+ printf("CODE: 0x%08X, ", (unsigned long) info.code | OTHER_POINTER_LOWTAG);
#ifndef alpha
function = info.code->entry_points;
header = (struct simple_fun *) native_pointer(function);
name = header->name;
- if (LowtagOf(name) == type_OtherPointer) {
+ if (lowtagof(name) == OTHER_POINTER_LOWTAG) {
lispobj *object;
object = (lispobj *) native_pointer(name);
lispobj code = *os_context_register_addr(context, reg_CODE);
lispobj header;
- if (LowtagOf(code) != type_OtherPointer)
+ if (lowtagof(code) != OTHER_POINTER_LOWTAG)
return NIL;
- header = *(lispobj *)(code-type_OtherPointer);
+ header = *(lispobj *)(code-OTHER_POINTER_LOWTAG);
if (TypeOf(header) == type_CodeHeader)
return code;
if (codeptr == 0) {
return NIL;
} else {
- return codeptr + type_OtherPointer;
+ return codeptr + OTHER_POINTER_LOWTAG;
}
}
#endif
}
#endif
undo_fake_foreign_function_call(context);
- return (void *)(lra-type_OtherPointer+sizeof(lispobj));
+ return (void *)(lra-OTHER_POINTER_LOWTAG+sizeof(lispobj));
}
#else
void *handle_fun_end_breakpoint(int signal, siginfo_t *info,
gc_assert((nwords & 0x01) == 0);
/* get tag of object */
- tag = LowtagOf(object);
+ tag = lowtagof(object);
/* allocate space */
new = new_space_free_pointer;
index = boxed_registers[i];
reg = *os_context_register_addr(context, index);
/* would be using PTR if not for integer length issues */
- if ((reg & ~((1L<<lowtag_Bits)-1)) <= lip) {
+ if ((reg & ~((1L<<N_LOWTAG_BITS)-1)) <= lip) {
offset = lip - reg;
if (offset < lip_offset) {
lip_offset = offset;
int tag;
lispobj *pointer;
- tag = LowtagOf(object);
+ tag = lowtagof(object);
switch (tag) {
- case type_ListPointer:
+ case LIST_POINTER_LOWTAG:
nwords = 2;
break;
- case type_InstancePointer:
+ case INSTANCE_POINTER_LOWTAG:
printf("Don't know about instances yet!\n");
nwords = 1;
break;
- case type_FunPointer:
+ case FUN_POINTER_LOWTAG:
nwords = 1;
break;
- case type_OtherPointer:
+ case OTHER_POINTER_LOWTAG:
pointer = (lispobj *) native_pointer(object);
header = *pointer;
type = TypeOf(header);
\f
/* code and code-related objects */
-/* FIXME: (1) Shouldn't this be defined in sbcl.h? (2) Shouldn't it
- * be in the same units as FDEFN_RAW_ADDR_OFFSET? (This is measured
- * in words, that's measured in bytes. Gotta love CMU CL..) */
-#define FUN_RAW_ADDR_OFFSET (6*sizeof(lispobj) - type_FunPointer)
+/* FIXME: Shouldn't this be defined in sbcl.h? */
+#define FUN_RAW_ADDR_OFFSET (6*sizeof(lispobj) - FUN_POINTER_LOWTAG)
static lispobj trans_fun_header(lispobj object);
static lispobj trans_boxed(lispobj object);
gc_assert(TypeOf(first) == type_CodeHeader);
/* prepare to transport the code vector */
- l_code = (lispobj) LOW_WORD(code) | type_OtherPointer;
+ l_code = (lispobj) LOW_WORD(code) | OTHER_POINTER_LOWTAG;
ncode_words = fixnum_value(code->code_size);
nheader_words = HeaderValue(code->header);
struct code *ncode;
ncode = trans_code((struct code *) native_pointer(object));
- return (lispobj) LOW_WORD(ncode) | type_OtherPointer;
+ return (lispobj) LOW_WORD(ncode) | OTHER_POINTER_LOWTAG;
}
static int
if(object==0x304748d7) {
/* monitor_or_something(); */
}
- ret= ((lispobj) LOW_WORD(ncode) + offset) | type_OtherPointer;
+ ret= ((lispobj) LOW_WORD(ncode) + offset) | OTHER_POINTER_LOWTAG;
#ifdef DEBUG_CODE_GC
printf("trans_return_pc_header returning %x\n",ret);
#endif
code = (struct code *) ((unsigned long) fheader - offset);
ncode = trans_code(code);
- return ((lispobj) LOW_WORD(ncode) + offset) | type_FunPointer;
+ return ((lispobj) LOW_WORD(ncode) + offset) | FUN_POINTER_LOWTAG;
}
cdr = cons->cdr;
- if (LowtagOf(cdr) != type_ListPointer ||
+ if (lowtagof(cdr) != LIST_POINTER_LOWTAG ||
!from_space_p(cdr) ||
(is_lisp_pointer(first = *(lispobj *)native_pointer(cdr))
&& new_space_p(first)))
scav_vector(lispobj *where, lispobj object)
{
if (HeaderValue(object) == subtype_VectorValidHashing)
- *where = (subtype_VectorMustRehash<<type_Bits) | type_SimpleVector;
+ *where = (subtype_VectorMustRehash<<N_TYPE_BITS) | type_SimpleVector;
return 1;
}
/* scavtab[i] = scav_immediate; */
for (i = 0; i < 32; i++) {
- scavtab[type_EvenFixnum|(i<<3)] = scav_immediate;
- scavtab[type_FunPointer|(i<<3)] = scav_fun_pointer;
- /* OtherImmediate0 */
- scavtab[type_ListPointer|(i<<3)] = scav_list_pointer;
- scavtab[type_OddFixnum|(i<<3)] = scav_immediate;
- scavtab[type_InstancePointer|(i<<3)] = scav_instance_pointer;
- /* OtherImmediate1 */
- scavtab[type_OtherPointer|(i<<3)] = scav_other_pointer;
+ scavtab[EVEN_FIXNUM_LOWTAG|(i<<3)] = scav_immediate;
+ scavtab[FUN_POINTER_LOWTAG|(i<<3)] = scav_fun_pointer;
+ /* skipping OTHER_IMMEDIATE_0_LOWTAG */
+ scavtab[LIST_POINTER_LOWTAG|(i<<3)] = scav_list_pointer;
+ scavtab[ODD_FIXNUM_LOWTAG|(i<<3)] = scav_immediate;
+ scavtab[INSTANCE_POINTER_LOWTAG|(i<<3)] =scav_instance_pointer;
+ /* skipping OTHER_IMMEDIATE_1_LOWTAG */
+ scavtab[OTHER_POINTER_LOWTAG|(i<<3)] = scav_other_pointer;
}
scavtab[type_Bignum] = scav_unboxed;
sizetab[i] = size_lose;
for (i = 0; i < 32; i++) {
- sizetab[type_EvenFixnum|(i<<3)] = size_immediate;
- sizetab[type_FunPointer|(i<<3)] = size_pointer;
- /* OtherImmediate0 */
- sizetab[type_ListPointer|(i<<3)] = size_pointer;
- sizetab[type_OddFixnum|(i<<3)] = size_immediate;
- sizetab[type_InstancePointer|(i<<3)] = size_pointer;
- /* OtherImmediate1 */
- sizetab[type_OtherPointer|(i<<3)] = size_pointer;
+ sizetab[EVEN_FIXNUM_LOWTAG|(i<<3)] = size_immediate;
+ sizetab[FUN_POINTER_LOWTAG|(i<<3)] = size_pointer;
+ /* skipping OTHER_IMMEDIATE_0_LOWTAG */
+ sizetab[LIST_POINTER_LOWTAG|(i<<3)] = size_pointer;
+ sizetab[ODD_FIXNUM_LOWTAG|(i<<3)] = size_immediate;
+ sizetab[INSTANCE_POINTER_LOWTAG|(i<<3)] = size_pointer;
+ /* skipping OTHER_IMMEDIATE_1_LOWTAG */
+ sizetab[OTHER_POINTER_LOWTAG|(i<<3)] = size_pointer;
}
sizetab[type_Bignum] = size_unboxed;
gc_assert((nwords & 0x01) == 0);
/* Get tag of object. */
- tag = LowtagOf(object);
+ tag = lowtagof(object);
/* Allocate space. */
new = gc_quick_alloc(nwords*4);
return(object);
} else {
/* Get tag of object. */
- tag = LowtagOf(object);
+ tag = lowtagof(object);
/* Allocate space. */
new = gc_quick_alloc_large(nwords*4);
gc_assert((nwords & 0x01) == 0);
/* Get tag of object. */
- tag = LowtagOf(object);
+ tag = lowtagof(object);
/* Allocate space. */
new = gc_quick_alloc_unboxed(nwords*4);
}
else {
/* Get tag of object. */
- tag = LowtagOf(object);
+ tag = lowtagof(object);
/* Allocate space. */
new = gc_quick_alloc_large_unboxed(nwords*4);
* code and code-related objects
*/
-/* FIXME: (1) Shouldn't this be defined in sbcl.h? (2) Shouldn't it
- * be in the same units as FDEFN_RAW_ADDR_OFFSET? (This is measured
- * in words, that's measured in bytes. Gotta love CMU CL..) */
-#define FUN_RAW_ADDR_OFFSET (6*sizeof(lispobj) - type_FunPointer)
+/* FIXME: (1) Shouldn't this be defined in sbcl.h? */
+#define FUN_RAW_ADDR_OFFSET (6*sizeof(lispobj) - FUN_POINTER_LOWTAG)
static lispobj trans_fun_header(lispobj object);
static lispobj trans_boxed(lispobj object);
gc_assert(TypeOf(code->header) == type_CodeHeader);
/* Prepare to transport the code vector. */
- l_code = (lispobj) code | type_OtherPointer;
+ l_code = (lispobj) code | OTHER_POINTER_LOWTAG;
ncode_words = fixnum_value(code->code_size);
nheader_words = HeaderValue(code->header);
struct code *ncode;
ncode = trans_code((struct code *) native_pointer(object));
- return (lispobj) ncode | type_OtherPointer;
+ return (lispobj) ncode | OTHER_POINTER_LOWTAG;
}
static int
code = (struct code *) ((unsigned long) return_pc - offset);
ncode = trans_code(code);
- return ((lispobj) ncode + offset) | type_OtherPointer;
+ return ((lispobj) ncode + offset) | OTHER_POINTER_LOWTAG;
}
/* On the 386, closures hold a pointer to the raw address instead of the
code = (struct code *) ((unsigned long) fheader - offset);
ncode = trans_code(code);
- return ((lispobj) ncode + offset) | type_FunPointer;
+ return ((lispobj) ncode + offset) | FUN_POINTER_LOWTAG;
}
\f
/*
new_cons = (struct cons *) gc_quick_alloc(sizeof(struct cons));
new_cons->car = cons->car;
new_cons->cdr = cons->cdr; /* updated later */
- new_list_pointer = (lispobj)new_cons | LowtagOf(object);
+ new_list_pointer = (lispobj)new_cons | lowtagof(object);
/* Grab the cdr before it is clobbered. */
cdr = cons->cdr;
lispobj new_cdr;
struct cons *cdr_cons, *new_cdr_cons;
- if (LowtagOf(cdr) != type_ListPointer || !from_space_p(cdr)
+ if (lowtagof(cdr) != LIST_POINTER_LOWTAG || !from_space_p(cdr)
|| (*((lispobj *)native_pointer(cdr)) == 0x01))
break;
new_cdr_cons = (struct cons*) gc_quick_alloc(sizeof(struct cons));
new_cdr_cons->car = cdr_cons->car;
new_cdr_cons->cdr = cdr_cons->cdr;
- new_cdr = (lispobj)new_cdr_cons | LowtagOf(cdr);
+ new_cdr = (lispobj)new_cdr_cons | lowtagof(cdr);
/* Grab the cdr before it is clobbered. */
cdr = cdr_cons->cdr;
if (!gencgc_hash) {
/* This is set for backward compatibility. FIXME: Do we need
* this any more? */
- *where = (subtype_VectorMustRehash << type_Bits) | type_SimpleVector;
+ *where = (subtype_VectorMustRehash << N_TYPE_BITS) | type_SimpleVector;
return 1;
}
* alone, set multiple entries in our 8-bit scavenge table (one for each
* possible value of the high 5 bits). */
for (i = 0; i < 32; i++) { /* FIXME: bare constant length, ick! */
- scavtab[type_EvenFixnum|(i<<3)] = scav_immediate;
- scavtab[type_FunPointer|(i<<3)] = scav_fun_pointer;
- /* OtherImmediate0 */
- scavtab[type_ListPointer|(i<<3)] = scav_list_pointer;
- scavtab[type_OddFixnum|(i<<3)] = scav_immediate;
- scavtab[type_InstancePointer|(i<<3)] = scav_instance_pointer;
- /* OtherImmediate1 */
- scavtab[type_OtherPointer|(i<<3)] = scav_other_pointer;
+ scavtab[EVEN_FIXNUM_LOWTAG|(i<<3)] = scav_immediate;
+ scavtab[FUN_POINTER_LOWTAG|(i<<3)] = scav_fun_pointer;
+ /* skipping OTHER_IMMEDIATE_0_LOWTAG */
+ scavtab[LIST_POINTER_LOWTAG|(i<<3)] = scav_list_pointer;
+ scavtab[ODD_FIXNUM_LOWTAG|(i<<3)] = scav_immediate;
+ scavtab[INSTANCE_POINTER_LOWTAG|(i<<3)] = scav_instance_pointer;
+ /* skipping OTHER_IMMEDIATE_1_LOWTAG */
+ scavtab[OTHER_POINTER_LOWTAG|(i<<3)] = scav_other_pointer;
}
/* Other-pointer types (those selected by all eight bits of the tag) get
for (i = 0; i < 256; i++)
sizetab[i] = size_lose;
for (i = 0; i < 32; i++) {
- sizetab[type_EvenFixnum|(i<<3)] = size_immediate;
- sizetab[type_FunPointer|(i<<3)] = size_pointer;
- /* OtherImmediate0 */
- sizetab[type_ListPointer|(i<<3)] = size_pointer;
- sizetab[type_OddFixnum|(i<<3)] = size_immediate;
- sizetab[type_InstancePointer|(i<<3)] = size_pointer;
- /* OtherImmediate1 */
- sizetab[type_OtherPointer|(i<<3)] = size_pointer;
+ sizetab[EVEN_FIXNUM_LOWTAG|(i<<3)] = size_immediate;
+ sizetab[FUN_POINTER_LOWTAG|(i<<3)] = size_pointer;
+ /* skipping OTHER_IMMEDIATE_0_LOWTAG */
+ sizetab[LIST_POINTER_LOWTAG|(i<<3)] = size_pointer;
+ sizetab[ODD_FIXNUM_LOWTAG|(i<<3)] = size_immediate;
+ sizetab[INSTANCE_POINTER_LOWTAG|(i<<3)] = size_pointer;
+ /* skipping OTHER_IMMEDIATE_1_LOWTAG */
+ sizetab[OTHER_POINTER_LOWTAG|(i<<3)] = size_pointer;
}
sizetab[type_Bignum] = size_unboxed;
sizetab[type_Ratio] = size_boxed;
* recording the result of the last call to allocate-lisp-memory,
* and returning true from this function when *pointer is
* a reference to that result. */
- switch (LowtagOf((lispobj)pointer)) {
- case type_FunPointer:
+ switch (lowtagof((lispobj)pointer)) {
+ case FUN_POINTER_LOWTAG:
/* Start_addr should be the enclosing code object, or a closure
* header. */
switch (TypeOf(*start_addr)) {
case type_ClosureHeader:
case type_FuncallableInstanceHeader:
if ((unsigned)pointer !=
- ((unsigned)start_addr+type_FunPointer)) {
+ ((unsigned)start_addr+FUN_POINTER_LOWTAG)) {
if (gencgc_verbose)
FSHOW((stderr,
"/Wf2: %x %x %x\n",
return 0;
}
break;
- case type_ListPointer:
+ case LIST_POINTER_LOWTAG:
if ((unsigned)pointer !=
- ((unsigned)start_addr+type_ListPointer)) {
+ ((unsigned)start_addr+LIST_POINTER_LOWTAG)) {
if (gencgc_verbose)
FSHOW((stderr,
"/Wl1: %x %x %x\n",
pointer, start_addr, *start_addr));
return 0;
}
- case type_InstancePointer:
+ case INSTANCE_POINTER_LOWTAG:
if ((unsigned)pointer !=
- ((unsigned)start_addr+type_InstancePointer)) {
+ ((unsigned)start_addr+INSTANCE_POINTER_LOWTAG)) {
if (gencgc_verbose)
FSHOW((stderr,
"/Wi1: %x %x %x\n",
return 0;
}
break;
- case type_OtherPointer:
+ case OTHER_POINTER_LOWTAG:
if ((unsigned)pointer !=
- ((int)start_addr+type_OtherPointer)) {
+ ((int)start_addr+OTHER_POINTER_LOWTAG)) {
if (gencgc_verbose)
FSHOW((stderr,
"/Wo1: %x %x %x\n",
== current_control_frame_pointer) {
/* There is a small window during call where the callee's
* frame isn't built yet. */
- if (LowtagOf(*os_context_register_addr(context, reg_CODE))
- == type_FunPointer) {
+ if (lowtagof(*os_context_register_addr(context, reg_CODE))
+ == FUN_POINTER_LOWTAG) {
/* We have called, but not built the new frame, so
* build it for them. */
current_control_frame_pointer[0] =
* support decides to pass on it. */
lose("no handler for signal %d in interrupt_handle_now(..)", signal);
- } else if (LowtagOf(handler.lisp) == type_FunPointer) {
+ } else if (lowtagof(handler.lisp) == FUN_POINTER_LOWTAG) {
/* Allocate the SAPs while the interrupts are still disabled.
* (FIXME: Why? This is the way it was done in CMU CL, and it
addr = end;
end += 2;
if (TypeOf(obj) == type_SimpleFunHeader) {
- print((long)addr | type_FunPointer);
- } else if (LowtagOf(obj) == type_OtherImmediate0 ||
- LowtagOf(obj) == type_OtherImmediate1) {
- print((lispobj)addr | type_OtherPointer);
+ print((long)addr | FUN_POINTER_LOWTAG);
+ } else if (lowtagof(obj) == OTHER_IMMEDIATE_0_LOWTAG ||
+ lowtagof(obj) == OTHER_IMMEDIATE_1_LOWTAG) {
+ print((lispobj)addr | OTHER_POINTER_LOWTAG);
} else {
print((lispobj)addr);
} if (count == -1) {
lispobj thing = parse_lispobj(ptr), function, result = 0, cons, args[3];
int numargs;
- if (LowtagOf(thing) == type_OtherPointer) {
- switch (TypeOf(*(lispobj *)(thing-type_OtherPointer))) {
+ if (lowtagof(thing) == OTHER_POINTER_LOWTAG) {
+ switch (TypeOf(*(lispobj *)(thing-OTHER_POINTER_LOWTAG))) {
case type_SymbolHeader:
for (cons = SymbolValue(INITIAL_FDEFN_OBJECTS);
cons != NIL;
return;
}
}
- else if (LowtagOf(thing) != type_FunPointer) {
+ else if (lowtagof(thing) != FUN_POINTER_LOWTAG) {
printf("0x%08lx is not a function pointer, symbol, or fdefn object.\n",
(long unsigned)thing);
return;
(unsigned long)catch, (unsigned long)(catch->current_uwp),
(unsigned long)(catch->current_cont),
(unsigned long)component_ptr_from_pc((void*)catch->entry_pc) +
- type_OtherPointer,
+ OTHER_POINTER_LOWTAG,
(unsigned long)catch->entry_pc);
#endif
brief_print((lispobj)catch->tag);
(lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER) -
(lispobj *)STATIC_SPACE_START;
if (search_for_symbol(name, &headerptr, &count)) {
- *result = (lispobj)headerptr | type_OtherPointer;
+ *result = (lispobj)headerptr | OTHER_POINTER_LOWTAG;
return 1;
}
(lispobj *)DYNAMIC_SPACE_START;
#endif
if (search_for_symbol(name, &headerptr, &count)) {
- *result = (lispobj)headerptr | type_OtherPointer;
+ *result = (lispobj)headerptr | OTHER_POINTER_LOWTAG;
return 1;
}
printf("NIL");
else {
putchar('(');
- while (LowtagOf(obj) == type_ListPointer) {
+ while (lowtagof(obj) == LIST_POINTER_LOWTAG) {
struct cons *cons = (struct cons *)native_pointer(obj);
if (space)
type = TypeOf(header);
print_obj("header: ", header);
- if (LowtagOf(header) != type_OtherImmediate0 && LowtagOf(header) != type_OtherImmediate1) {
+ if (lowtagof(header) != OTHER_IMMEDIATE_0_LOWTAG &&
+ lowtagof(header) != OTHER_IMMEDIATE_1_LOWTAG) {
NEWLINE_OR_RETURN;
printf("(invalid header object)");
return;
static void (*brief_fns[])(lispobj obj)
= {brief_fixnum, brief_otherptr, brief_otherimm, brief_list,
brief_fixnum, brief_struct, brief_otherimm, brief_otherptr};
- int type = LowtagOf(obj);
+ int type = lowtagof(obj);
struct var *var = lookup_by_obj(obj);
char buffer[256];
boolean verbose = cur_depth < brief_depth;
if (var == NULL &&
/* FIXME: What does this "x & y & z & .." expression mean? */
- (obj & type_FunPointer & type_ListPointer & type_InstancePointer & type_OtherPointer) != 0)
+ (obj & FUN_POINTER_LOWTAG & LIST_POINTER_LOWTAG & INSTANCE_POINTER_LOWTAG & OTHER_POINTER_LOWTAG) != 0)
var = define_var(NULL, obj, 0);
if (var != NULL)
#define CEILING(x,y) (((x) + ((y) - 1)) & (~((y) - 1)))
#define NWORDS(x,y) (CEILING((x),(y)) / (y))
-/* FIXME: (1) Shouldn't this be defined in sbcl.h? (2) Shouldn't it
- * be in the same units as FDEFN_RAW_ADDR_OFFSET? (This is measured
- * in words, that's measured in bytes. Gotta love CMU CL..) */
+/* FIXME: (1) Shouldn't this be defined in sbcl.h? */
#ifdef sparc
#define FUN_RAW_ADDR_OFFSET 0
#else
-#define FUN_RAW_ADDR_OFFSET (6*sizeof(lispobj) - type_FunPointer)
+#define FUN_RAW_ADDR_OFFSET (6*sizeof(lispobj) - FUN_POINTER_LOWTAG)
#endif
\f
static boolean
/* Check that the object pointed to is consistent with the pointer
* low tag. */
- switch (LowtagOf((lispobj)pointer)) {
- case type_FunPointer:
+ switch (lowtagof((lispobj)pointer)) {
+ case FUN_POINTER_LOWTAG:
/* Start_addr should be the enclosing code object, or a closure
* header. */
switch (TypeOf(*start_addr)) {
break;
case type_ClosureHeader:
case type_FuncallableInstanceHeader:
- if ((int)pointer != ((int)start_addr+type_FunPointer)) {
+ if ((int)pointer != ((int)start_addr+FUN_POINTER_LOWTAG)) {
if (pointer_filter_verbose) {
fprintf(stderr,"*Wf2: %x %x %x\n", (unsigned int) pointer,
(unsigned int) start_addr, *start_addr);
return 0;
}
break;
- case type_ListPointer:
- if ((int)pointer != ((int)start_addr+type_ListPointer)) {
+ case LIST_POINTER_LOWTAG:
+ if ((int)pointer != ((int)start_addr+LIST_POINTER_LOWTAG)) {
if (pointer_filter_verbose)
fprintf(stderr,"*Wl1: %x %x %x\n", (unsigned int) pointer,
(unsigned int) start_addr, *start_addr);
}
return 0;
}
- case type_InstancePointer:
- if ((int)pointer != ((int)start_addr+type_InstancePointer)) {
+ case INSTANCE_POINTER_LOWTAG:
+ if ((int)pointer != ((int)start_addr+INSTANCE_POINTER_LOWTAG)) {
if (pointer_filter_verbose) {
fprintf(stderr,"*Wi1: %x %x %x\n", (unsigned int) pointer,
(unsigned int) start_addr, *start_addr);
return 0;
}
break;
- case type_OtherPointer:
- if ((int)pointer != ((int)start_addr+type_OtherPointer)) {
+ case OTHER_POINTER_LOWTAG:
+ if ((int)pointer != ((int)start_addr+OTHER_POINTER_LOWTAG)) {
if (pointer_filter_verbose) {
fprintf(stderr,"*Wo1: %x %x %x\n", (unsigned int) pointer,
(unsigned int) start_addr, *start_addr);
MAX_STACK_RETURN_ADDRESSES);
valid_stack_ra_locations[num_valid_stack_ra_locations] = sp;
valid_stack_ra_code_objects[num_valid_stack_ra_locations++] =
- (lispobj *)((int)start_addr + type_OtherPointer);
+ (lispobj *)((int)start_addr + OTHER_POINTER_LOWTAG);
} else {
if (valid_dynamic_space_pointer((void *)thing, start_addr)) {
gc_assert(num_valid_stack_locations < MAX_STACK_POINTERS);
bcopy(old, new, nwords * sizeof(lispobj));
/* Deposit forwarding pointer. */
- result = (lispobj)new | LowtagOf(thing);
+ result = (lispobj)new | lowtagof(thing);
*old = result;
/* Scavenge it. */
bcopy(old, new, nwords * sizeof(lispobj));
/* Deposit forwarding pointer. */
- result = (lispobj)new | LowtagOf(thing);
+ result = (lispobj)new | lowtagof(thing);
*old = result;
/* Scavenge it. */
bcopy(old, new, nwords * sizeof(lispobj));
/* Deposit forwarding pointer. */
- result = (lispobj)new | LowtagOf(thing);
+ result = (lispobj)new | lowtagof(thing);
*old = result;
/* Scavenge the function. */
bcopy(old, new, nwords * sizeof(lispobj));
/* Deposit forwarding pointer. */
- result = (lispobj)new | LowtagOf(thing);
+ result = (lispobj)new | lowtagof(thing);
*old = result;
return result;
bcopy(vector, new, nwords * sizeof(lispobj));
- result = (lispobj)new | LowtagOf(thing);
+ result = (lispobj)new | lowtagof(thing);
vector->header = result;
if (boxed)
apply_code_fixups_during_purify(code,new);
#endif
- result = (lispobj)new | type_OtherPointer;
+ result = (lispobj)new | OTHER_POINTER_LOWTAG;
/* Stick in a forwarding pointer for the code object. */
*(lispobj *)code = result;
func != NIL;
func = ((struct simple_fun *)native_pointer(func))->next) {
- gc_assert(LowtagOf(func) == type_FunPointer);
+ gc_assert(lowtagof(func) == FUN_POINTER_LOWTAG);
*(lispobj *)native_pointer(func) = result + (func - thing);
}
for (func = new->entry_points;
func != NIL;
func = ((struct simple_fun *)native_pointer(func))->next) {
- gc_assert(LowtagOf(func) == type_FunPointer);
+ gc_assert(lowtagof(func) == FUN_POINTER_LOWTAG);
gc_assert(!dynamic_pointer_p(func));
#ifdef __i386__
code =
(native_pointer(thing) -
(HeaderValue(function->header)*sizeof(lispobj))) |
- type_OtherPointer;
+ OTHER_POINTER_LOWTAG;
/* This will cause the function's header to be replaced with a
* forwarding pointer. */
bcopy(old, new, nwords * sizeof(lispobj));
/* Deposit forwarding pointer. */
- result = (lispobj)new | LowtagOf(thing);
+ result = (lispobj)new | lowtagof(thing);
*old = result;
/* Scavenge it. */
thing = new->cdr = old->cdr;
/* Set up the forwarding pointer. */
- *(lispobj *)old = ((lispobj)new) | type_ListPointer;
+ *(lispobj *)old = ((lispobj)new) | LIST_POINTER_LOWTAG;
/* And count this cell. */
length++;
- } while (LowtagOf(thing) == type_ListPointer &&
+ } while (lowtagof(thing) == LIST_POINTER_LOWTAG &&
dynamic_pointer_p(thing) &&
!(forwarding_pointer_p(*(lispobj *)native_pointer(thing))));
/* Scavenge the list we just copied. */
pscav((lispobj *)orig, length * WORDS_PER_CONS, constant);
- return ((lispobj)orig) | type_ListPointer;
+ return ((lispobj)orig) | LIST_POINTER_LOWTAG;
}
static lispobj
for (func = code->entry_points;
func != NIL;
func = ((struct simple_fun *)native_pointer(func))->next) {
- gc_assert(LowtagOf(func) == type_FunPointer);
+ gc_assert(lowtagof(func) == FUN_POINTER_LOWTAG);
gc_assert(!dynamic_pointer_p(func));
#ifdef __i386__
thing = header;
else {
/* Nope, copy the object. */
- switch (LowtagOf(thing)) {
- case type_FunPointer:
+ switch (lowtagof(thing)) {
+ case FUN_POINTER_LOWTAG:
thing = ptrans_func(thing, header);
break;
- case type_ListPointer:
+ case LIST_POINTER_LOWTAG:
thing = ptrans_list(thing, constant);
break;
- case type_InstancePointer:
+ case INSTANCE_POINTER_LOWTAG:
thing = ptrans_instance(thing, header, constant);
break;
- case type_OtherPointer:
+ case OTHER_POINTER_LOWTAG:
thing = ptrans_otherptr(thing, header, constant);
break;
case type_SimpleVector:
if (HeaderValue(thing) == subtype_VectorValidHashing)
- *addr = (subtype_VectorMustRehash<<type_Bits) |
+ *addr = (subtype_VectorMustRehash<<N_TYPE_BITS) |
type_SimpleVector;
count = 1;
break;
* problem.. */
#define QSHOW_SIGNALS 0
-/* FIXME: There seems to be no reason that LowtagOf can't be defined
- * as a (possibly inline) function instead of a macro. It would also
- * be reasonable to rename the constants in ALL CAPS. */
-
-#define lowtag_Bits 3
-#define lowtag_Mask ((1<<lowtag_Bits)-1)
-#define LowtagOf(obj) ((obj)&lowtag_Mask)
-#define type_Bits 8
-#define type_Mask ((1<<type_Bits)-1)
+#define N_LOWTAG_BITS 3
+#define LOWTAG_MASK ((1<<N_LOWTAG_BITS)-1)
+#define N_TYPE_BITS 8
+#define TYPE_MASK ((1<<N_TYPE_BITS)-1)
/* FIXME: There seems to be no reason that TypeOf, HeaderValue, CONS,
* SYMBOL, and FDEFN can't be defined as (possibly inline) functions
* instead of macros. */
-#define TypeOf(obj) ((obj)&type_Mask)
-#define HeaderValue(obj) ((unsigned long) ((obj)>>type_Bits))
+#define TypeOf(obj) ((obj)&TYPE_MASK)
+#define HeaderValue(obj) ((unsigned long) ((obj)>>N_TYPE_BITS))
-#define CONS(obj) ((struct cons *)((obj)-type_ListPointer))
-#define SYMBOL(obj) ((struct symbol *)((obj)-type_OtherPointer))
-#define FDEFN(obj) ((struct fdefn *)((obj)-type_OtherPointer))
+#define CONS(obj) ((struct cons *)((obj)-LIST_POINTER_LOWTAG))
+#define SYMBOL(obj) ((struct symbol *)((obj)-OTHER_POINTER_LOWTAG))
+#define FDEFN(obj) ((struct fdefn *)((obj)-OTHER_POINTER_LOWTAG))
/* KLUDGE: These are in theory machine-dependent and OS-dependent, but
* in practice the "foo int" definitions work for all the machines
typedef u32 lispobj;
+static inline int
+lowtagof(lispobj obj) {
+ return obj & LOWTAG_MASK;
+}
+
/* Is the Lisp object obj something with pointer nature (as opposed to
* e.g. a fixnum or character or unbound marker)? */
static inline int
static inline lispobj
native_pointer(lispobj obj)
{
- return obj & ~lowtag_Mask;
+ return obj & ~LOWTAG_MASK;
}
/* FIXME: There seems to be no reason that make_fixnum and fixnum_value
* instead of macros. */
#define SymbolValue(sym) \
- (((struct symbol *)((sym)-type_OtherPointer))->value)
+ (((struct symbol *)((sym)-OTHER_POINTER_LOWTAG))->value)
#define SetSymbolValue(sym,val) \
- (((struct symbol *)((sym)-type_OtherPointer))->value = (val))
+ (((struct symbol *)((sym)-OTHER_POINTER_LOWTAG))->value = (val))
/* This only works for static symbols. */
/* FIXME: should be called StaticSymbolFunction, right? */
#define SymbolFunction(sym) \
- (((struct fdefn *)(SymbolValue(sym)-type_OtherPointer))->fun)
+ (((struct fdefn *)(SymbolValue(sym)-OTHER_POINTER_LOWTAG))->fun)
/* KLUDGE: As far as I can tell there's no ANSI C way of saying
* "this function never returns". This is the way that you do it
while (search_for_type(type_SymbolHeader, start, count)) {
symbol = (struct symbol *)native_pointer((lispobj)*start);
- if (LowtagOf(symbol->name) == type_OtherPointer) {
+ if (lowtagof(symbol->name) == OTHER_POINTER_LOWTAG) {
symbol_name = (struct vector *)native_pointer(symbol->name);
if (is_valid_lisp_addr((os_vm_address_t)symbol_name) &&
TypeOf(symbol_name->header) == type_SimpleString &&
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.pre7.55"
+"0.pre7.56"
projects / sbcl.git / commitdiff