mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
Optimize instance layout bitmaps
* Flag the layout as a raw slot in the bitmap. Tracing an instance will always examine the layout as a one-off before proceeding to the data slots. This ensures that we don't accidentally visit a tagged slot twice in situations where it matters (heap relocation, for one). * If all words are raw or all fixnums (or characters), nothing needs examining. The bitmap reduces to 0 which is an early exit. * It becomes more feasible to unify much of the handling of ordinary instances and funcallable-instances.
This commit is contained in:
Douglas Katzman
parent
80f03e2028
commit
532b885acb
|
|
@ -997,6 +997,7 @@
|
|||
(<= (#.(MAKE-SINGLE-FLOAT #x3F800000) #.(MAKE-SINGLE-FLOAT #x0)) NIL)
|
||||
(<= (#.(MAKE-SINGLE-FLOAT #x3F800000) #.(MAKE-SINGLE-FLOAT #x3D800000)) NIL)
|
||||
(<= (#.(MAKE-SINGLE-FLOAT #x3F800000) #.(MAKE-SINGLE-FLOAT #x3F800000)) T)
|
||||
(<= (#.(MAKE-SINGLE-FLOAT #x3FC90FDB) #.(MAKE-SINGLE-FLOAT #x3FC90FDB)) T)
|
||||
(<= (#.(MAKE-SINGLE-FLOAT #x40490FDB) #.(MAKE-SINGLE-FLOAT #x40490FDB)) T)
|
||||
(<= (#.(MAKE-SINGLE-FLOAT #x447A0000) #.(MAKE-SINGLE-FLOAT #x40000000)) NIL)
|
||||
(<= (#.(MAKE-SINGLE-FLOAT #x49742400) #.(MAKE-SINGLE-FLOAT #x40000000)) NIL)
|
||||
|
|
@ -2614,6 +2615,7 @@
|
|||
(>= (#.(MAKE-SINGLE-FLOAT #x-40800000) #.(MAKE-SINGLE-FLOAT #x0)) NIL)
|
||||
(>= (#.(MAKE-SINGLE-FLOAT #x-40800000) #.(MAKE-SINGLE-FLOAT #x3DCCCCCD)) NIL)
|
||||
(>= (#.(MAKE-SINGLE-FLOAT #x-40800000) #.(MAKE-SINGLE-FLOAT #x3F800000)) NIL)
|
||||
(>= (#.(MAKE-SINGLE-FLOAT #x-4036F025) #.(MAKE-SINGLE-FLOAT #x-4036F025)) T)
|
||||
(>= (#.(MAKE-SINGLE-FLOAT #x-4036F025) #.(MAKE-SINGLE-FLOAT #x-3136F025)) T)
|
||||
(>= (#.(MAKE-SINGLE-FLOAT #x-4036F025) #.(MAKE-SINGLE-FLOAT #x-21B6F025)) T)
|
||||
(>= (#.(MAKE-SINGLE-FLOAT #x-4036F025) #.(MAKE-SINGLE-FLOAT #x-20B6F025)) T)
|
||||
|
|
|
|||
|
|
@ -766,6 +766,9 @@ unless :NAMED is also specified.")))
|
|||
(layout-inherits super) (vector super)))))
|
||||
(proto-classoid
|
||||
(if (dd-class-p dd)
|
||||
;; The classoid needs a layout whereby to convey inheritance.
|
||||
;; Classoids only store a *direct* superclass list.
|
||||
;; Both the layout and classoid are throwaway objects.
|
||||
(let* ((classoid (make-structure-classoid :name (dd-name dd)))
|
||||
(layout (make-layout (hash-layout-name (dd-name dd))
|
||||
classoid :inherits inherits)))
|
||||
|
|
@ -1502,49 +1505,143 @@ or they must be declared locally notinline at each call site.~@:>"
|
|||
(values))
|
||||
|
||||
;;; Compute DD's bitmap, storing 1 for each tagged word.
|
||||
;;; The bitmap should be stored as a negative fixnum in two cases:
|
||||
;;; (1) if the positive value is a bignum but the negative is a fixnum.
|
||||
;;; (2) if there are no raw slots at all.
|
||||
;;; Example: given (DEFSTRUCT S A B C), the computed bitmap is #b11111 -
|
||||
;;; one bit for the layout; one each for A, B, C; and one for padding.
|
||||
;;; Whether this is stored as 31 or -1 is mostly immaterial,
|
||||
;;; but -1 is preferable because GC has a special case for it.
|
||||
;;; Suppose instead we have 1 untagged word followed by N tagged words
|
||||
;;; for N > n-fixnum-bits. The computed bitmap is #b111...11101
|
||||
;;; but the sign-extended value is -3, which is a fixnum.
|
||||
;;; If both the + and - values are fixnums, and raw slots are present,
|
||||
;;; we'll choose the positive value.
|
||||
(defun dd-bitmap (dd)
|
||||
;; With compact instances, LAYOUT is not reflected in the bitmap.
|
||||
;; Without compact instances, the 0th bitmap bit (for the LAYOUT) is always 1.
|
||||
;; In neither case is the place for the layout represented in in DD-SLOTS.
|
||||
(let ((bitmap sb-vm:instance-data-start))
|
||||
;;; The GC can parse signed fixnums and bignums, with which we can
|
||||
;;; represent an unlimited number of "&rest" slots all with the same
|
||||
;;; nature - tagged or raw. If REST is :TAGGED or :UNTAGGED, it
|
||||
;;; specifies a particular nature. If :UNSPECIFIC, then we sign-extend
|
||||
;;; from the last specified slot which tends to reduce the bitmap to
|
||||
;;; -1 in the case of everything being tagged, (or -2 if non-compact
|
||||
;;; header), or a small positive fixnum if the last is untagged.
|
||||
;;;
|
||||
;;; Bit indices correspond to physical word indices excluding
|
||||
;;; the header word. So the least-significant bit of a bitmap is
|
||||
;;; always the word just after the instance header word.
|
||||
;;;
|
||||
;;; Examples: (Legend: u=untaggged slot, t=tagged slot)
|
||||
;;;
|
||||
;;; logical arithmetic
|
||||
;;; bitmap value
|
||||
;;; Funcallable object:
|
||||
;;; Non-compact header: #b...1010 -6
|
||||
;;; word0: header
|
||||
;;; word1: (*) entry address
|
||||
;;; word2: (t) implementation-fun
|
||||
;;; word3: (u) layout
|
||||
;;; word4: (t) tagged slots ...
|
||||
;;; Compact header:
|
||||
;;; External trampoline: #b...1111 -1
|
||||
;;; word0: header/layout
|
||||
;;; word1: (*) entry address
|
||||
;;; word2: (t) implementation-fun
|
||||
;;; word3: (t) tagged slots ...
|
||||
;;; Internal trampoline: #b..00110 6
|
||||
;;; word0: header/layout
|
||||
;;; word1: (*) entry address [= word 4]
|
||||
;;; word2: (t) implementation-fun
|
||||
;;; word3: (t) tagged slot
|
||||
;;; word4: (u) machine code
|
||||
;;; word5: (u) machine code
|
||||
;;; (*) entry address can be treated as either tagged or raw.
|
||||
;;; For some architectures it has a lowtag, but points to
|
||||
;;; read-only space. For others it is a fixnum.
|
||||
;;; In either case the GC need not observe the value.
|
||||
;;; Compact-header with external trampoline can indicate
|
||||
;;; all slots as tagged. The other two cases above have at
|
||||
;;; least one slot which must be marked raw.
|
||||
;;;
|
||||
;;; Ordinary instance with only tagged slots:
|
||||
;;; Non-compact header: #b...1110 -2
|
||||
;;; word0: header
|
||||
;;; word1: (u) layout
|
||||
;;; word2: (t) tagged slots ...
|
||||
;;; Compact header: #b...1111 -1
|
||||
;;; word0: header/layout
|
||||
;;; word1: (t) tagged slots ...
|
||||
;;; Ordinary instance with only raw slots slots:
|
||||
;;; [this also includes objects whose slots all have types
|
||||
;;; ignorable by GC such as fixum/character]
|
||||
;;; Non-compact header: #b...0000 0
|
||||
;;; word0: header
|
||||
;;; word1: (u) layout
|
||||
;;; word2: (u) raw slots ...
|
||||
;;; Compact header: #b...0000 0
|
||||
;;; word0: header/layout
|
||||
;;; word1: (u) raw slots ...
|
||||
;;;
|
||||
;;; Notes:
|
||||
;;; 1. LAYOUT has to be scanned separately regardless of where stored.
|
||||
;;; (compact header or not). Hence it is regarded as an untagged slot.
|
||||
;;; 2. For funcallable objects these examples are exhaustive of all
|
||||
;;; possible bitmaps. The instance length can be anything,
|
||||
;;; but untagged slots are not generally supported.
|
||||
;;; For ordinary instance the examples are merely illustrative.
|
||||
;;;
|
||||
(defun dd-bitmap (dd &optional (rest :unspecific))
|
||||
(declare (type (member :unspecific :tagged :untagged) rest))
|
||||
#-compact-instance-header
|
||||
(when (eq (car (dd-alternate-metaclass dd)) 'function)
|
||||
;; There is only one bitmap, which excludes LAYOUT from tagged slots
|
||||
(return-from dd-bitmap standard-gf-primitive-obj-layout-bitmap))
|
||||
;; Compute two masks with a 1 bit for each dsd-index which contains a descriptor.
|
||||
;; The "mininal" bitmap contains a 1 for each slot which *must* be scanned in GC,
|
||||
;; and the "maximal" bitmap contains a 1 for each which *may* be scanned.
|
||||
;; If a non-raw slot type can be ignored - such as (OR FIXNUM NULL), then it
|
||||
;; sets a 1 in the maximal bitmap but not in the minimal bitmap.
|
||||
;; Note that the GC can always add one slot for a stable hash, but that slot
|
||||
;; can only hold a fixnum, so need not be traced even though it is a descriptor.
|
||||
(let ((n-bits (dd-length dd))
|
||||
(any-raw)
|
||||
(maximal-bitmap 0)
|
||||
(minimal-bitmap 0))
|
||||
(dolist (slot (dd-slots dd))
|
||||
(when (eql t (dsd-raw-type slot))
|
||||
(setf bitmap (logior bitmap (ash 1 (dsd-index slot))))))
|
||||
;; The garbage collector can add one more word, but it doesn't need
|
||||
;; to be accounted for in the bitmap.
|
||||
;; If the bitmap is -1 ("all tagged"), we leave it alone; if a positive
|
||||
;; number, the added trailing slot can be regarded as untagged.
|
||||
(let* ((length (dd-length dd))
|
||||
(n-bits (logior length 1)))
|
||||
(when (evenp length) ; Add padding word if necessary.
|
||||
(setq bitmap (logior bitmap (ash 1 length))))
|
||||
(when (and (logbitp (1- n-bits) bitmap)
|
||||
;; Bitmap of -1 implies that all slots are tagged,
|
||||
;; and no extraordinary GC treatment is needed.
|
||||
;; If all are tagged but any special treatment is required,
|
||||
;; then the bitmap can't be -1.
|
||||
(named-let admits-bitmap-optimization ((dd dd))
|
||||
(cond ((eq (dd-name dd) 'list-node) nil)
|
||||
((not (dd-include dd)) t)
|
||||
((admits-bitmap-optimization
|
||||
(find-defstruct-description (car (dd-include dd))))))))
|
||||
(let ((sign-ext (logior (ash -1 n-bits) bitmap)))
|
||||
(when (or (and (fixnump sign-ext) (sb-xc:typep bitmap 'bignum))
|
||||
(eql sign-ext -1))
|
||||
(return-from dd-bitmap sign-ext)))))
|
||||
bitmap))
|
||||
(cond ((eql t (dsd-raw-type slot))
|
||||
(let ((bit (ash 1 (dsd-index slot))))
|
||||
(setf maximal-bitmap (logior maximal-bitmap bit))
|
||||
(unless (dsd-gc-ignorable slot)
|
||||
(setf minimal-bitmap (logior minimal-bitmap bit)))))
|
||||
(t
|
||||
(setq any-raw t))))
|
||||
|
||||
;; If the structure has a custom GC scavenging method then always return
|
||||
;; the minimal bitmap, and disallow arbitrary trailing slots.
|
||||
;; The optimization for all-tagged (avoiding use of the bitmap)
|
||||
;; indicates in addition to no raw slots, no custom GC method either.
|
||||
;; As of now this only pertains to lockfree-singly-linked-list nodes
|
||||
;; and descendant types. (The lockfree list uses one pointer bit
|
||||
;; as a pending-deletion flag. See "src/code/target-lflist.lisp")
|
||||
(when (named-let has-custom-gc-method ((dd dd))
|
||||
(cond ((eq (dd-name dd) 'list-node) t)
|
||||
((dd-include dd)
|
||||
(has-custom-gc-method
|
||||
(find-defstruct-description (car (dd-include dd)))))))
|
||||
(aver (eq rest :unspecific))
|
||||
(return-from dd-bitmap minimal-bitmap))
|
||||
|
||||
;; The minimal bitmap will have the least number of bits set, and the maximal
|
||||
;; will have the most, but it is not always a performance improvement to prefer
|
||||
;; fewer bits. If the total number of bits is large, and there are no raw slots,
|
||||
;; then the "all tagged" treatment may be better because it does not need to
|
||||
;; parse the bitmap. But if there are any raw slots, the minimal bitmap is best.
|
||||
(let ((bitmap
|
||||
(if (or (= minimal-bitmap 0) ; don't need a bitmap
|
||||
any-raw ; must use a bitmap
|
||||
;; for other cases, it is not clear-cut
|
||||
(and (> (logcount maximal-bitmap) 10) ; arb
|
||||
(< (logcount minimal-bitmap)
|
||||
(floor (logcount maximal-bitmap) 2))))
|
||||
minimal-bitmap
|
||||
maximal-bitmap)))
|
||||
|
||||
;; If the trailing slots have tagged nature, extend bitmap with
|
||||
;; an infinite sequence of 1 bits. If :UNSPECIFIC, replicate
|
||||
;; the most-significant-bit whether it be 0 or 1.
|
||||
(cond ((or (eq rest :tagged)
|
||||
(and (eq rest :unspecific)
|
||||
(plusp n-bits)
|
||||
(logbitp (1- n-bits) bitmap)))
|
||||
(dpb bitmap (byte n-bits 0) -1))
|
||||
(t
|
||||
bitmap)))))
|
||||
|
||||
;;; This is called when we are about to define a structure class. It
|
||||
;;; returns a (possibly new) class object and the layout which should
|
||||
|
|
|
|||
|
|
@ -230,6 +230,12 @@
|
|||
(dd-slots (find-defstruct-description type-name))
|
||||
:key #'dsd-name)))
|
||||
|
||||
(defmacro set-layout-bitmap (layout bitmap)
|
||||
#+sb-xc-host (declare (ignore layout bitmap))
|
||||
#-sb-xc-host
|
||||
`(setf (%instance-ref (the layout ,layout) (get-dsd-index layout bitmap))
|
||||
,bitmap))
|
||||
|
||||
(defmacro set-bitmap-from-layout (to-layout from-layout)
|
||||
#+sb-xc-host (declare (ignore to-layout from-layout))
|
||||
;; While this obviously has a straightforward implementation for now,
|
||||
|
|
@ -238,40 +244,70 @@
|
|||
`(setf (%instance-ref (the layout ,to-layout) (get-dsd-index layout bitmap))
|
||||
(layout-bitmap ,from-layout)))
|
||||
|
||||
(defmacro set-layout-inherits (layout inherits &optional depthoid)
|
||||
`(let* ((l ,layout) (i ,inherits) (d ,(or depthoid '(length i))))
|
||||
(declare (ignorable i d))
|
||||
;; I tried putting a /SHOW here for debugging, but it's just too broken
|
||||
;; because layouts affect the printer dispatch mechanism.
|
||||
#+nil
|
||||
(let ((*print-pretty* nil))
|
||||
(fresh-line)
|
||||
(write-string "SET-INHERITS ")
|
||||
(write (layout-classoid-name l))
|
||||
(write-string " ")
|
||||
(write (map 'list #'layout-classoid-name i))
|
||||
(terpri))
|
||||
;;; It is purely coincidental that these are the negatives of one another.
|
||||
;;; See the pictures above DD-BITMAP in src/code/defstruct for the details.
|
||||
(defconstant standard-gf-primitive-obj-layout-bitmap
|
||||
#+immobile-code 6
|
||||
#-immobile-code -6)
|
||||
|
||||
#+sb-xc-host
|
||||
(defmacro set-layout-inherits (layout inherits)
|
||||
`(setf (layout-inherits ,layout) ,inherits))
|
||||
#-sb-xc-host
|
||||
(defmacro set-layout-inherits (layout inherits &optional recompute-bitmap)
|
||||
`(let* ((l ,layout) (i ,inherits) (d (length i)))
|
||||
(setf (layout-inherits l) i)
|
||||
#-sb-xc-host
|
||||
(setf (layout-ancestor_2 l) (if (> d 2) (svref i 2) 0)
|
||||
(layout-ancestor_3 l) (if (> d 3) (svref i 3) 0)
|
||||
(layout-ancestor_4 l) (if (> d 4) (svref i 4) 0)
|
||||
(layout-ancestor_5 l) (if (> d 5) (svref i 5) 0))
|
||||
;; This part is for PCL where a class can forward-reference its superclasses
|
||||
;; and we only decide at class finalization time whether it is funcallable.
|
||||
;; Picking the right bitmap could probably be done sooner given the metaclass,
|
||||
;; but this approach avoids changing how PCL uses MAKE-LAYOUT.
|
||||
;; The big comment above MAKE-IMMOBILE-FUNINSTANCE in src/code/x86-64-vm
|
||||
;; explains why we differentiate between SGF and everything else.
|
||||
,(when recompute-bitmap
|
||||
`(when (find ,(find-layout 'function) i)
|
||||
(set-layout-bitmap
|
||||
l
|
||||
#+immobile-code ; there are two possible bitmap
|
||||
;; *SGF-WRAPPER* isn't defined as yet, but this is just an s-expression.
|
||||
(if (find sb-pcl::*sgf-wrapper* i)
|
||||
standard-gf-primitive-obj-layout-bitmap
|
||||
+layout-all-tagged+)
|
||||
;; there is only one possible bitmap otherwise
|
||||
#-immobile-code standard-gf-primitive-obj-layout-bitmap)))
|
||||
l))
|
||||
(push '("SB-KERNEL" set-layout-inherits) *!removable-symbols*)
|
||||
|
||||
;;; For lack of any better to place to write up some detail surrounding
|
||||
;;; layout creation for structure types, I'm putting here.
|
||||
;;; When you issue a DEFSTRUCT at the REPL, there are *three* instances
|
||||
;;; of LAYOUT makde for the new structure.
|
||||
;;; 1) The first is one associated with a temporary instance of
|
||||
;;; structure-classoid used in parsing the DEFSTRUCT form so that
|
||||
;;; we don't signal an UNKNOWN-TYPE condition for something like:
|
||||
;;; (defstruct chain (next nil :type (or null chain)).
|
||||
;;; The temporary classoid is garbage immediately after parsing
|
||||
;;; and is never installed.
|
||||
;;; 2) The next is the actual LAYOUT that ends up being registered.
|
||||
;;; 3) The third is a layout created when setting the "compiler layout"
|
||||
;;; which contains copies of the length/depthoid/inherits etc
|
||||
;;; that we compare against the isntalled one to make sure they match.
|
||||
;;; The third one also gets thrown away.
|
||||
#-sb-xc-host
|
||||
(defun make-layout (clos-hash classoid
|
||||
&key (depthoid -1) (length 0) (flags 0)
|
||||
(inherits #() inheritsp)
|
||||
(inherits #())
|
||||
(info nil)
|
||||
(bitmap (if info (dd-bitmap info) +layout-all-tagged+))
|
||||
(bitmap (if info (dd-bitmap info) 0))
|
||||
(invalid :uninitialized))
|
||||
(let ((layout (%make-layout clos-hash classoid
|
||||
#+64-bit (pack-layout-flags depthoid length flags)
|
||||
#-64-bit depthoid #-64-bit length #-64-bit flags
|
||||
info bitmap)))
|
||||
(when inheritsp
|
||||
(set-layout-inherits layout inherits))
|
||||
(set-layout-inherits layout inherits)
|
||||
(setf (layout-invalid layout) invalid)
|
||||
layout))
|
||||
|
||||
|
|
|
|||
|
|
@ -45,7 +45,7 @@
|
|||
;; these abstractions are provided as soon as the raw slots defs are.
|
||||
(def!type sb-vm:word () `(unsigned-byte ,sb-vm:n-word-bits))
|
||||
(def!type sb-vm:signed-word () `(signed-byte ,sb-vm:n-word-bits))
|
||||
(defconstant +layout-all-tagged+ -1)
|
||||
(defconstant +layout-all-tagged+ (ash -1 sb-vm:instance-data-start))
|
||||
|
||||
;; information about how a slot of a given DSD-RAW-TYPE is to be accessed
|
||||
(defstruct (raw-slot-data
|
||||
|
|
|
|||
|
|
@ -1075,19 +1075,33 @@ We could try a few things to mitigate this:
|
|||
;; As for INSTANCE, allow the functoid to see the access form
|
||||
(,functoid (%fun-layout ,obj) ,@more)
|
||||
(,functoid (%funcallable-instance-fun ,obj) ,@more)
|
||||
;; Unfortunately for FUNCALLABLE-INSTANCEs, the relation
|
||||
;; between layout bitmap indices and indices as given to
|
||||
;; FUNCALLABLE-INSTANCE-INFO is not so obvious, and it's
|
||||
;; both tricky and unnecessary to generalize iteration.
|
||||
;; So just hardcode the few cases that exist.
|
||||
#+compact-instance-header
|
||||
(ecase (layout-bitmap .l.)
|
||||
(#.sb-kernel:+layout-all-tagged+
|
||||
(loop for .i. from instance-data-start ; exclude layout
|
||||
(-1 ; external trampoline, all slots are tagged
|
||||
;; In this case, the trampoline word is scanned, with no ill effect.
|
||||
(loop for .i. from 0
|
||||
to (- (get-closure-length ,obj) funcallable-instance-info-offset)
|
||||
do (,functoid (%funcallable-instance-info ,obj .i.) ,@more)))
|
||||
(#b0110
|
||||
;; A pedantically correct kludge which shall remain unless need arises
|
||||
;; for more general partially unboxed FINs.
|
||||
;; payload word 0 is raw (but looks like a fixnum, by design)
|
||||
;; word 1 is the fin-fun which we already accounted for above
|
||||
;; word 2 (info slot 0) is the only one that hasn't been processed.
|
||||
;; words 3 and 4 are raw but looks like fixnums by accident.
|
||||
(,functoid (%funcallable-instance-info ,obj 0) ,@more)))))
|
||||
(#b0110 ; internal trampoline, 2 raw slots, 1 tagged slot
|
||||
;; ^ payload word 0 is raw (but looks fixnum-like)
|
||||
;; ^ word 1 is the fin-fun which we already accounted for above
|
||||
;; ^ word 2 (INFO index 0) is the only one that hasn't been processed.
|
||||
;; and the rest of the words are raw.
|
||||
(,functoid (%funcallable-instance-info ,obj 0) ,@more)))
|
||||
#-compact-instance-header
|
||||
(progn
|
||||
(aver (eql (layout-bitmap .l.) -6))
|
||||
;; v---- trampoline
|
||||
;; -6 = #b1...1010
|
||||
;; ^------ layout pointer = (FUNCALLABLE-INSTANCE-INFO 0)
|
||||
(loop for .i. from 1
|
||||
to (- (get-closure-length ,obj) funcallable-instance-info-offset)
|
||||
do (,functoid (%funcallable-instance-info ,obj .i.) ,@more)))))
|
||||
.,(make-case 'function))) ; in case there was code provided for it
|
||||
(t
|
||||
;; TODO: the generated code is pretty horrible. OTHER-POINTER-LOWTAG
|
||||
|
|
|
|||
|
|
@ -218,13 +218,9 @@
|
|||
(or (and (eql kind sb-vm:funcallable-instance-widetag)
|
||||
;; if the FIN has no raw words then it has no internal trampoline
|
||||
(eql (layout-bitmap (%fun-layout fun))
|
||||
sb-kernel:+layout-all-tagged+))
|
||||
+layout-all-tagged+))
|
||||
(eql kind sb-vm:closure-widetag))))
|
||||
|
||||
(defconstant sb-pcl::+machine-code-embedding-fsc-instance-bitmap+
|
||||
(logxor (1- (ash 1 funcallable-instance-info-offset))
|
||||
(ash 1 (1- funcallable-instance-trampoline-slot))))
|
||||
|
||||
;;; This allocator is in its own function because the immobile allocator
|
||||
;;; VOPs are impolite (i.e. bad) and trash all registers.
|
||||
;;; Since there are no callee-saved registers, this makes it legit'
|
||||
|
|
|
|||
|
|
@ -49,10 +49,7 @@
|
|||
;;; otherwise a slot unto itself.
|
||||
(def!type layout-depthoid () '(integer -1 #x7FFF))
|
||||
(def!type layout-length () '(integer 0 #xFFFF))
|
||||
(def!type layout-bitmap ()
|
||||
;; FIXME: Probably should exclude negative bignum
|
||||
#+compact-instance-header 'integer
|
||||
#-compact-instance-header '(and integer (not (eql 0))))
|
||||
(def!type layout-bitmap () 'integer)
|
||||
|
||||
;;; An INLINEP value describes how a function is called. The values
|
||||
;;; have these meanings:
|
||||
|
|
|
|||
|
|
@ -1974,7 +1974,7 @@ bootstrapping.
|
|||
(define-load-time-global *sgf-wrapper*
|
||||
(!boot-make-wrapper (!early-class-size 'standard-generic-function)
|
||||
'standard-generic-function
|
||||
#+immobile-code +machine-code-embedding-fsc-instance-bitmap+))
|
||||
sb-kernel::standard-gf-primitive-obj-layout-bitmap))
|
||||
|
||||
(define-load-time-global *sgf-slots-init*
|
||||
(mapcar (lambda (canonical-slot)
|
||||
|
|
|
|||
|
|
@ -173,6 +173,9 @@
|
|||
(multiple-value-bind (slots cpl default-initargs direct-subclasses)
|
||||
(!early-collect-inheritance name)
|
||||
(let* ((class (find-class name))
|
||||
(bitmap (if (memq name '(standard-generic-function))
|
||||
sb-kernel::standard-gf-primitive-obj-layout-bitmap
|
||||
+layout-all-tagged+))
|
||||
(wrapper (cond ((eq class slot-class)
|
||||
slot-class-wrapper)
|
||||
((eq class standard-class)
|
||||
|
|
@ -196,7 +199,7 @@
|
|||
((eq class standard-generic-function)
|
||||
standard-generic-function-wrapper)
|
||||
(t
|
||||
(!boot-make-wrapper (length slots) name))))
|
||||
(!boot-make-wrapper (length slots) name bitmap))))
|
||||
(proto nil))
|
||||
(let ((symbol (make-class-symbol name)))
|
||||
(when (eq (info :variable :kind symbol) :global)
|
||||
|
|
@ -661,7 +664,8 @@
|
|||
(set-layout-inherits layout
|
||||
(order-layout-inherits
|
||||
(map 'simple-vector #'class-wrapper
|
||||
(reverse (rest (class-precedence-list class))))))
|
||||
(reverse (rest (class-precedence-list class)))))
|
||||
t)
|
||||
(register-layout layout :invalidate t)
|
||||
|
||||
;; FIXME: I don't think this should be necessary, but without it
|
||||
|
|
|
|||
|
|
@ -561,7 +561,8 @@
|
|||
(set-layout-inherits layout
|
||||
(order-layout-inherits
|
||||
(map 'simple-vector #'class-wrapper
|
||||
(reverse (rest cpl))))))
|
||||
(reverse (rest cpl))))
|
||||
t))
|
||||
(register-layout layout :invalidate t))))
|
||||
(mapc #'make-preliminary-layout (class-direct-subclasses class))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -470,7 +470,7 @@
|
|||
#|
|
||||
;;; To find templateized symbols that aren't special operators:
|
||||
(do-all-symbols (s)
|
||||
(let ((template
|
||||
(let ((template
|
||||
(sb-int:info :function :walker-template s)))
|
||||
(when (and template (not (special-operator-p s)))
|
||||
(format t "Why? ~S~%" s))))
|
||||
|
|
|
|||
|
|
@ -32,7 +32,7 @@
|
|||
;;; This is called in BRAID when we are making wrappers for classes
|
||||
;;; whose slots are not initialized yet, and which may be built-in
|
||||
;;; classes.
|
||||
(defun !boot-make-wrapper (length name &optional (bitmap -1))
|
||||
(defun !boot-make-wrapper (length name &optional (bitmap +layout-all-tagged+))
|
||||
(let ((found (find-classoid name nil)))
|
||||
(cond
|
||||
(found
|
||||
|
|
@ -72,6 +72,7 @@
|
|||
(t
|
||||
(bug "Got to T branch in ~S" 'make-wrapper))))))
|
||||
(make-layout (hash-layout-name name) classoid
|
||||
:bitmap +layout-all-tagged+
|
||||
:invalid nil :length length :flags +pcl-object-layout-flag+)))
|
||||
(t
|
||||
(let* ((found (find-classoid (slot-value class 'name)))
|
||||
|
|
|
|||
|
|
@ -164,14 +164,11 @@ static uword_t coalesce_range(lispobj* where, lispobj* limit, uword_t arg)
|
|||
next = where + nwords;
|
||||
switch (widetag) {
|
||||
case INSTANCE_WIDETAG: // mixed boxed/unboxed objects
|
||||
#ifdef LISP_FEATURE_COMPACT_INSTANCE_HEADER
|
||||
case FUNCALLABLE_INSTANCE_WIDETAG:
|
||||
#endif
|
||||
layout = instance_layout(where);
|
||||
layout = layout_of(where);
|
||||
bitmap = LAYOUT(layout)->bitmap;
|
||||
for(i=1; i<nwords; ++i)
|
||||
if (layout_bitmap_logbitp(i-1, bitmap))
|
||||
coalesce_obj(where+i, ht);
|
||||
for (i=0; i<(nwords-1); ++i)
|
||||
if (bitmap_logbitp(i, bitmap)) coalesce_obj(where+1+i, ht);
|
||||
continue;
|
||||
case CODE_HEADER_WIDETAG:
|
||||
nwords = code_header_words((struct code*)where);
|
||||
|
|
|
|||
|
|
@ -383,10 +383,9 @@ static inline void fix_fun_header_layout(lispobj __attribute__((unused)) *fun,
|
|||
struct heap_adjust __attribute__((unused)) *adj)
|
||||
{
|
||||
#if defined(LISP_FEATURE_COMPACT_INSTANCE_HEADER) && defined(LISP_FEATURE_64_BIT)
|
||||
lispobj ptr = function_layout(fun);
|
||||
lispobj ptr = funinstance_layout(fun);
|
||||
lispobj adjusted = adjust_word(adj, ptr);
|
||||
if (adjusted != ptr)
|
||||
FIXUP(set_function_layout(fun, adjusted), fun);
|
||||
if (adjusted != ptr) FIXUP(funinstance_layout(fun)=adjusted, fun);
|
||||
#endif
|
||||
}
|
||||
|
||||
|
|
@ -398,6 +397,7 @@ static void relocate_space(uword_t start, lispobj* end, struct heap_adjust* adj)
|
|||
lispobj layout, adjusted_layout, bitmap;
|
||||
struct code* code;
|
||||
sword_t delta;
|
||||
int i;
|
||||
|
||||
adj->n_relocs_abs = adj->n_relocs_rel = 0;
|
||||
for ( ; where < end ; where += nwords ) {
|
||||
|
|
@ -419,15 +419,11 @@ static void relocate_space(uword_t start, lispobj* end, struct heap_adjust* adj)
|
|||
adjust_word_at(where+1, adj);
|
||||
/* FALLTHROUGH */
|
||||
case INSTANCE_WIDETAG:
|
||||
layout = (widetag == FUNCALLABLE_INSTANCE_WIDETAG) ?
|
||||
funinstance_layout(where) : instance_layout(where);
|
||||
layout = layout_of(where);
|
||||
adjusted_layout = adjust_word(adj, layout);
|
||||
// Do not alter the layout as stored in the instance if non-compact
|
||||
// header. instance_scan() will do it if necessary.
|
||||
#ifdef LISP_FEATURE_COMPACT_INSTANCE_HEADER
|
||||
if (adjusted_layout != layout)
|
||||
instance_layout(where) = adjusted_layout;
|
||||
#endif
|
||||
// writeback the layout if it changed. The layout is not a tagged slot
|
||||
// so it would not be fixed up otherwise.
|
||||
if (adjusted_layout != layout) layout_of(where) = adjusted_layout;
|
||||
bitmap = LAYOUT(adjusted_layout)->bitmap;
|
||||
gc_assert(fixnump(bitmap)
|
||||
|| widetag_of(native_pointer(bitmap))==BIGNUM_WIDETAG);
|
||||
|
|
@ -441,9 +437,9 @@ static void relocate_space(uword_t start, lispobj* end, struct heap_adjust* adj)
|
|||
// the bitmap slot will be rewritten if needed.
|
||||
bitmap = adjust_word(adj, bitmap);
|
||||
}
|
||||
|
||||
instance_scan((void(*)(lispobj*,sword_t,uword_t))adjust_pointers,
|
||||
where+1, nwords-1, bitmap, (uintptr_t)adj);
|
||||
lispobj* slots = where+1;
|
||||
for (i=0; i<(nwords-1); ++i)
|
||||
if (bitmap_logbitp(i, bitmap)) adjust_pointers(slots+i, 1, adj);
|
||||
continue;
|
||||
case FDEFN_WIDETAG:
|
||||
adjust_pointers(where+1, 2, adj);
|
||||
|
|
@ -465,7 +461,6 @@ static void relocate_space(uword_t start, lispobj* end, struct heap_adjust* adj)
|
|||
// Fixup absolute jump table
|
||||
lispobj* jump_table = code_jumptable_start(code);
|
||||
int count = jumptable_count(jump_table);
|
||||
int i;
|
||||
for (i = 1; i < count; ++i) adjust_word_at(jump_table+i, adj);
|
||||
#endif
|
||||
// Fixup all embedded simple-funs
|
||||
|
|
@ -1145,28 +1140,23 @@ static void graph_visit(lispobj __attribute__((unused)) referer,
|
|||
nwords = fixnum_value(obj[1]); // vector length
|
||||
for(i=0; i<nwords; ++i) RECURSE(obj[i+2]);
|
||||
break;
|
||||
// In all the following cases except for CODE, 'nwords' is the count
|
||||
// of payload words (following the header), so we iterate up to and
|
||||
// including that word index. For example, if there are 2 payload words,
|
||||
// then we scan word indices 1 and 2 off the object base address.
|
||||
case INSTANCE_WIDETAG:
|
||||
layout = instance_layout(obj);
|
||||
graph_visit(ptr, layout, seen);
|
||||
nwords = instance_length(*obj);
|
||||
bitmap = LAYOUT(layout)->bitmap;
|
||||
for(i=1; i<=nwords; ++i)
|
||||
if (layout_bitmap_logbitp(i-1, bitmap)) RECURSE(obj[i]);
|
||||
break;
|
||||
case FUNCALLABLE_INSTANCE_WIDETAG:
|
||||
layout = funinstance_layout(obj);
|
||||
layout = layout_of(obj);
|
||||
graph_visit(ptr, layout, seen);
|
||||
nwords = sizetab[widetag_of(obj)](obj);
|
||||
bitmap = LAYOUT(layout)->bitmap;
|
||||
nwords = SHORT_BOXED_NWORDS(*obj);
|
||||
// We don't need to scan the word at index 1 (the trampoline pointer)
|
||||
// because it either points to the FIN itself or to readonly space.
|
||||
for(i=2; i<=nwords; ++i)
|
||||
if (layout_bitmap_logbitp(i-1, bitmap)) RECURSE(obj[i]);
|
||||
for (i=0; i<(nwords-1); ++i)
|
||||
if (bitmap_logbitp(i, bitmap)) RECURSE(obj[1+i]);
|
||||
break;
|
||||
case CODE_HEADER_WIDETAG:
|
||||
nwords = code_header_words((struct code*)obj);
|
||||
for(i=2; i<nwords; ++i) RECURSE(obj[i]);
|
||||
break;
|
||||
// In all the remaining cases, 'nwords' is the count of payload words
|
||||
// (following the header), so we iterate up to and including that
|
||||
// word index. For example, if there are 2 payload words,
|
||||
// then we scan word indices 1 and 2 off the object base address.
|
||||
case CLOSURE_WIDETAG:
|
||||
// We must scan the closure's trampoline word.
|
||||
graph_visit(ptr, fun_taggedptr_from_self(obj[1]), seen);
|
||||
|
|
@ -1187,10 +1177,6 @@ static void graph_visit(lispobj __attribute__((unused)) referer,
|
|||
RECURSE(obj[2]);
|
||||
RECURSE(fdefn_callee_lispobj((struct fdefn*)obj));
|
||||
break;
|
||||
case CODE_HEADER_WIDETAG:
|
||||
nwords = code_header_words((struct code*)obj);
|
||||
for(i=2; i<nwords; ++i) RECURSE(obj[i]);
|
||||
break;
|
||||
default:
|
||||
if (!leaf_obj_widetag_p(widetag_of(obj))) {
|
||||
nwords = BOXED_NWORDS(*obj);
|
||||
|
|
|
|||
|
|
@ -244,49 +244,45 @@ void gc_mark_range(lispobj* where, long count) {
|
|||
#define HT_ENTRY_LIVENESS_FUN_ARRAY_NAME alivep_funs
|
||||
#include "weak-hash-pred.inc"
|
||||
|
||||
static void trace_using_layout(lispobj layout, lispobj* where, int nslots)
|
||||
{
|
||||
// Apart from the allowance for untagged pointers in lockfree list nodes,
|
||||
// this contains almost none of the special cases that gencgc does.
|
||||
if (!layout) return;
|
||||
gc_mark_obj(layout);
|
||||
lispobj bitmap = LAYOUT(layout)->bitmap;
|
||||
if (!bitmap) return;
|
||||
if (lockfree_list_node_layout_p(LAYOUT(layout))) { // allow untagged 'next'
|
||||
struct instance* node = (struct instance*)where;
|
||||
lispobj next = node->slots[INSTANCE_DATA_START];
|
||||
// ignore if 0
|
||||
if (fixnump(next) && next) __mark_obj(next|INSTANCE_POINTER_LOWTAG);
|
||||
}
|
||||
int i;
|
||||
lispobj* slots = where+1;
|
||||
for (i=0; i<nslots; ++i)
|
||||
if (bitmap_logbitp(i, bitmap) && is_lisp_pointer(slots[i]))
|
||||
__mark_obj(slots[i]);
|
||||
}
|
||||
|
||||
static void trace_object(lispobj* where)
|
||||
{
|
||||
lispobj header = *where;
|
||||
int widetag = header_widetag(header);
|
||||
|
||||
switch (widetag) {
|
||||
case INSTANCE_WIDETAG:
|
||||
return trace_using_layout(instance_layout(where),
|
||||
where, instance_length(header));
|
||||
case FUNCALLABLE_INSTANCE_WIDETAG:
|
||||
return trace_using_layout(funinstance_layout(where),
|
||||
where, HeaderValue(header) & SHORT_HEADER_MAX_WORDS);
|
||||
}
|
||||
sword_t scan_from = 1;
|
||||
sword_t scan_to = sizetab[widetag](where);
|
||||
sword_t i;
|
||||
struct weak_pointer *weakptr;
|
||||
lispobj layout, bitmap;
|
||||
|
||||
/* If the C compiler emits this switch as a jump table, order doesn't matter.
|
||||
* But if as consecutive tests, instance and vector should be tested first
|
||||
* as they are the most freequent */
|
||||
switch (widetag) {
|
||||
case INSTANCE_WIDETAG:
|
||||
#ifdef LISP_FEATURE_COMPACT_INSTANCE_HEADER
|
||||
/* No need to deal with FINs for non-compact header, because the layout
|
||||
pointer isn't in the header word, the trampoline pointer can only point
|
||||
to readonly space, and all slots are tagged. */
|
||||
case FUNCALLABLE_INSTANCE_WIDETAG:
|
||||
layout = instance_layout(where);
|
||||
gc_mark_obj(layout);
|
||||
#else
|
||||
layout = instance_layout(where); // will be marked as where[1]
|
||||
#endif
|
||||
if (!layout) break; // fall into general case
|
||||
// mixed boxed/unboxed objects
|
||||
bitmap = LAYOUT(layout)->bitmap;
|
||||
// If no raw slots, just scan without use of the bitmap.
|
||||
// A bitmap of -1 implies that not only are all slots tagged,
|
||||
// there is no special GC method for any slot.
|
||||
if (bitmap == make_fixnum(-1)) break;
|
||||
// Otherwise, the first slot might merit special treatment.
|
||||
if (lockfree_list_node_layout_p(LAYOUT(layout))) {
|
||||
struct instance* node = (struct instance*)where;
|
||||
lispobj next = node->slots[INSTANCE_DATA_START];
|
||||
if (fixnump(next) && next) // ignore initially 0 heap words
|
||||
__mark_obj(next|INSTANCE_POINTER_LOWTAG);
|
||||
}
|
||||
for(i=1; i<scan_to; ++i)
|
||||
if (layout_bitmap_logbitp(i-1, bitmap) && is_lisp_pointer(where[i]))
|
||||
__mark_obj(where[i]);
|
||||
return; // do not scan slots
|
||||
case SIMPLE_VECTOR_WIDETAG:
|
||||
// non-weak hashtable kv vectors are trivial in fullcgc. Keys don't move
|
||||
// so the table will not need rehash as a result of gc.
|
||||
|
|
|
|||
|
|
@ -659,87 +659,33 @@ DEF_SCAV_BOXED(boxed, BOXED_NWORDS)
|
|||
DEF_SCAV_BOXED(short_boxed, SHORT_BOXED_NWORDS)
|
||||
DEF_SCAV_BOXED(tiny_boxed, TINY_BOXED_NWORDS)
|
||||
|
||||
static inline boolean bignum_logbitp_inline(int index, struct bignum* bignum)
|
||||
{
|
||||
int len = HeaderValue(bignum->header);
|
||||
int word_index = index / N_WORD_BITS;
|
||||
int bit_index = index % N_WORD_BITS;
|
||||
return word_index < len ? (bignum->digits[word_index] >> bit_index) & 1 : 0;
|
||||
}
|
||||
boolean positive_bignum_logbitp(int index, struct bignum* bignum)
|
||||
{
|
||||
/* If the bignum in the layout has another pointer to it (besides the layout)
|
||||
acting as a root, and which is scavenged first, then transporting the
|
||||
bignum causes the layout to see a FP, as would copying an instance whose
|
||||
layout that is. This is a nearly impossible scenario to create organically
|
||||
in Lisp, because mostly nothing ever looks again at that exact (EQ) bignum
|
||||
except for a few things that would cause it to be pinned anyway,
|
||||
such as it being kept in a local variable during structure manipulation.
|
||||
See 'interleaved-raw.impure.lisp' for a way to trigger this */
|
||||
if (forwarding_pointer_p((lispobj*)bignum)) {
|
||||
lispobj forwarded = forwarding_pointer_value((lispobj*)bignum);
|
||||
#if 0
|
||||
fprintf(stderr, "GC bignum_logbitp(): fwd from %p to %p\n",
|
||||
(void*)bignum, (void*)forwarded);
|
||||
#endif
|
||||
bignum = (struct bignum*)native_pointer(forwarded);
|
||||
}
|
||||
return bignum_logbitp_inline(index, bignum);
|
||||
}
|
||||
|
||||
// Helper function for stepping through the tagged slots of an instance in
|
||||
// scav_instance and verify_space.
|
||||
void
|
||||
instance_scan(void (*proc)(lispobj*, sword_t, uword_t),
|
||||
lispobj *instance_slots,
|
||||
sword_t nslots, /* number of payload words */
|
||||
lispobj layout_bitmap,
|
||||
uword_t arg)
|
||||
{
|
||||
sword_t index;
|
||||
|
||||
if (fixnump(layout_bitmap)) {
|
||||
if (layout_bitmap == make_fixnum(-1))
|
||||
proc(instance_slots, nslots, arg);
|
||||
else {
|
||||
sword_t bitmap = fixnum_value(layout_bitmap); // signed integer!
|
||||
for (index = 0; index < nslots ; index++, bitmap >>= 1)
|
||||
if (bitmap & 1)
|
||||
proc(instance_slots + index, 1, arg);
|
||||
}
|
||||
} else { /* huge bitmap */
|
||||
struct bignum * bitmap;
|
||||
bitmap = (struct bignum*)native_pointer(layout_bitmap);
|
||||
for (index = 0; index < nslots ; index++)
|
||||
if (bignum_logbitp_inline(index, bitmap))
|
||||
proc(instance_slots + index, 1, arg);
|
||||
}
|
||||
}
|
||||
|
||||
static sword_t
|
||||
scav_instance(lispobj *where, lispobj header)
|
||||
{
|
||||
int nslots = instance_length(header) | 1;
|
||||
if (!instance_layout(where)) return 1 + nslots;
|
||||
int nslots = instance_length(header); // un-padded length
|
||||
int total_nwords = 1 + (nslots | 1);
|
||||
|
||||
lispobj *layout = native_pointer(instance_layout(where));
|
||||
#ifdef LISP_FEATURE_COMPACT_INSTANCE_HEADER
|
||||
if (immobile_obj_gen_bits(layout) == from_space)
|
||||
enliven_immobile_obj(layout, 1);
|
||||
#else
|
||||
if (forwarding_pointer_p(layout))
|
||||
layout = native_pointer(forwarding_pointer_value(layout));
|
||||
#endif
|
||||
// First things first: fix or enliven the layout pointer as necessary,
|
||||
// writing it back if and only if it changed.
|
||||
lispobj layoutptr = instance_layout(where), old = layoutptr;
|
||||
if (!layoutptr) return total_nwords; // instance can't point to any data yet
|
||||
scav1(&layoutptr, layoutptr);
|
||||
if (layoutptr != old) instance_layout(where) = layoutptr;
|
||||
struct layout *layout = (void*)(layoutptr - INSTANCE_POINTER_LOWTAG);
|
||||
lispobj lbitmap = ((struct layout*)layout)->bitmap;
|
||||
if (lbitmap == make_fixnum(-1)) {
|
||||
scavenge(where+1, nslots);
|
||||
return 1 + nslots;
|
||||
|
||||
if (lbitmap == (make_fixnum(-1) << INSTANCE_DATA_START)) { // all tagged slots
|
||||
scavenge(where+1+INSTANCE_DATA_START, nslots-INSTANCE_DATA_START);
|
||||
return total_nwords;
|
||||
}
|
||||
|
||||
if (lbitmap == 0) return total_nwords; // special-case: no tagged slots
|
||||
|
||||
// Specially scavenge the 'next' slot of a lockfree list node. If the node is
|
||||
// pending deletion, 'next' will satisfy fixnump() but is in fact a pointer.
|
||||
// GC doesn't care too much about the deletion algorithm, but does have to
|
||||
// ensure liveness of the pointee, which may move unless pinned.
|
||||
if (lockfree_list_node_layout_p((struct layout*)layout)) {
|
||||
if (lockfree_list_node_layout_p(layout)) {
|
||||
struct instance* node = (struct instance*)where;
|
||||
lispobj next = node->slots[INSTANCE_DATA_START];
|
||||
if (fixnump(next) && next) { // ignore initially 0 heap words
|
||||
|
|
@ -750,6 +696,10 @@ scav_instance(lispobj *where, lispobj header)
|
|||
node->slots[INSTANCE_DATA_START] = descriptor & ~LOWTAG_MASK;
|
||||
}
|
||||
}
|
||||
|
||||
++where; // skip over the header
|
||||
sword_t mask = fixnum_value(lbitmap); // optimistically assume fixnum
|
||||
lispobj obj;
|
||||
if (!fixnump(lbitmap)) {
|
||||
/* It is conceivable that 'lbitmap' points to from_space, AND that it
|
||||
* is stored in one of the slots of the instance about to be scanned.
|
||||
|
|
@ -757,19 +707,32 @@ scav_instance(lispobj *where, lispobj header)
|
|||
* one or two words, rendering it bogus for use as the instance's bitmap.
|
||||
* So scavenge it up front to fix its address */
|
||||
scav1(&lbitmap, lbitmap);
|
||||
instance_scan((void(*)(lispobj*,sword_t,uword_t))scavenge,
|
||||
where+1, nslots, lbitmap, 0);
|
||||
} else {
|
||||
sword_t bitmap = fixnum_value(lbitmap); // signed integer!
|
||||
int n = nslots;
|
||||
lispobj obj;
|
||||
for ( ; n-- ; bitmap >>= 1) {
|
||||
++where;
|
||||
if ((bitmap & 1) && is_lisp_pointer(obj = *where))
|
||||
scav1(where, obj);
|
||||
struct bignum* bignum = (void*)(lbitmap - OTHER_POINTER_LOWTAG);
|
||||
int n_bitmap_words = HeaderValue(bignum->header);
|
||||
mask = bignum->digits[0];
|
||||
// Process all but the final word of the bitmap.
|
||||
// This loop will not execute if the bignum has exactly 1 word.
|
||||
int bitmap_word_index = 1;
|
||||
while (bitmap_word_index < n_bitmap_words) {
|
||||
// I suspect that mutating a structure layout with raw slots
|
||||
// could cause this assertion to fail, but at least we'll catch
|
||||
// that the user did something dangerous, exiting with an error
|
||||
// rather than causing heap corruption.
|
||||
if (nslots < N_WORD_BITS) lose("Mutated structure layout %p", (void*)layout);
|
||||
nslots -= N_WORD_BITS;
|
||||
lispobj* limit = where + N_WORD_BITS;
|
||||
for ( ; where < limit ; mask >>= 1, ++where )
|
||||
if ((mask & 1) && is_lisp_pointer(obj = *where)) scav1(where, obj);
|
||||
mask = bignum->digits[bitmap_word_index++];
|
||||
}
|
||||
}
|
||||
return 1 + nslots;
|
||||
// Scan the final word of the mask, letting the sign bit repeat.
|
||||
// There might be 0 slots remaining though.
|
||||
lispobj* limit = where + nslots;
|
||||
for ( ; where < limit ; mask >>= 1, ++where )
|
||||
if ((mask & 1) && is_lisp_pointer(obj = *where)) scav1(where, obj);
|
||||
|
||||
return total_nwords;
|
||||
}
|
||||
|
||||
static sword_t size_instance(lispobj *where) {
|
||||
|
|
@ -779,30 +742,24 @@ static sword_t size_instance(lispobj *where) {
|
|||
static sword_t
|
||||
scav_funinstance(lispobj *where, lispobj header)
|
||||
{
|
||||
#ifdef LISP_FEATURE_COMPACT_INSTANCE_HEADER
|
||||
// Do a similar thing as scav_instance but do not split into 3 cases
|
||||
// based on whether the bitmap is a fixnum or a bignum or the special
|
||||
// case of all tagged; it's always a fixnum, with at least 1 raw slot.
|
||||
int nslots = SHORT_BOXED_NWORDS(header);
|
||||
if (!instance_layout(where)) return 1 + nslots;
|
||||
|
||||
lispobj *layout = native_pointer(instance_layout(where));
|
||||
if (immobile_obj_gen_bits(layout) == from_space)
|
||||
enliven_immobile_obj(layout, 1);
|
||||
lispobj lbitmap = ((struct layout*)layout)->bitmap;
|
||||
gc_assert(fixnump(lbitmap));
|
||||
sword_t bitmap = fixnum_value(lbitmap);
|
||||
int n = nslots;
|
||||
int nslots = HeaderValue(header) & SHORT_HEADER_MAX_WORDS;
|
||||
// First things first: fix or enliven the layout pointer as necessary,
|
||||
// writing it back if and only if it changed.
|
||||
lispobj layoutptr = funinstance_layout(where), old = layoutptr;
|
||||
if (!layoutptr) return 1 + (nslots | 1); // skip, instance can't point to data
|
||||
scav1(&layoutptr, layoutptr);
|
||||
if (layoutptr != old) funinstance_layout(where) = layoutptr;
|
||||
// Do a similar thing as scav_instance but without any special cases.
|
||||
// Bitmap is always a nonzero fixnum.
|
||||
struct layout *layout = (void*)(layoutptr - INSTANCE_POINTER_LOWTAG);
|
||||
gc_assert(fixnump(layout->bitmap));
|
||||
sword_t mask = fixnum_value(layout->bitmap);
|
||||
++where;
|
||||
lispobj* limit = where + nslots;
|
||||
lispobj obj;
|
||||
for ( ; n-- ; bitmap >>= 1) {
|
||||
++where;
|
||||
if ((bitmap & 1) && is_lisp_pointer(obj = *where))
|
||||
scav1(where, obj);
|
||||
}
|
||||
return 1 + nslots;
|
||||
#else
|
||||
return scav_short_boxed(where, header);
|
||||
#endif
|
||||
for ( ; where < limit ; mask >>= 1, ++where )
|
||||
if ((mask & 1) && is_lisp_pointer(obj = *where)) scav1(where, obj);
|
||||
return 1 + (nslots | 1);
|
||||
}
|
||||
|
||||
/* Bignums use the high bit as the mark, and all remaining bits
|
||||
|
|
@ -2388,3 +2345,9 @@ void gc_heapsort_uwords(heap array, int length)
|
|||
page_index_t ext_lispobj_size(lispobj *addr) {
|
||||
return OBJECT_SIZE(*addr,addr) * N_WORD_BYTES;
|
||||
}
|
||||
/// Eeternal function for calling from Lisp.
|
||||
/// This would be better build into a '.so' from a test
|
||||
/// because it really serves no other purpose.
|
||||
int test_bitmap_logbitp(int i, lispobj bitmap) {
|
||||
return bitmap_logbitp(i, bitmap);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -131,35 +131,6 @@ instance_scan(void (*proc)(lispobj*, sword_t, uword_t),
|
|||
|
||||
extern int simple_fun_index(struct code*, struct simple_fun*);
|
||||
|
||||
#ifdef LISP_FEATURE_COMPACT_INSTANCE_HEADER
|
||||
static inline lispobj funinstance_layout(lispobj* funinstance_ptr) { // native ptr
|
||||
return instance_layout(funinstance_ptr);
|
||||
}
|
||||
static inline lispobj function_layout(lispobj* fun_ptr) { // native ptr
|
||||
return instance_layout(fun_ptr);
|
||||
}
|
||||
static inline void set_function_layout(lispobj* fun_ptr, lispobj layout) {
|
||||
instance_layout(fun_ptr) = layout;
|
||||
}
|
||||
#else
|
||||
static inline lispobj funinstance_layout(lispobj* instance_ptr) { // native ptr
|
||||
// first 4 words are: header, trampoline, fin-fun, layout
|
||||
return instance_ptr[3];
|
||||
}
|
||||
// No layout in simple-fun or closure, because there are no free bits
|
||||
static inline lispobj
|
||||
function_layout(lispobj __attribute__((unused)) *fun_ptr) { // native ptr
|
||||
return 0;
|
||||
}
|
||||
static inline void set_function_layout(lispobj __attribute__((unused)) *fun_ptr,
|
||||
lispobj __attribute__((unused)) layout) {
|
||||
lose("Can't assign layout");
|
||||
}
|
||||
#endif
|
||||
|
||||
#include "genesis/bignum.h"
|
||||
extern boolean positive_bignum_logbitp(int,struct bignum*);
|
||||
|
||||
extern lispobj fdefn_callee_lispobj(struct fdefn *fdefn);
|
||||
|
||||
boolean valid_widetag_p(unsigned char widetag);
|
||||
|
|
|
|||
|
|
@ -238,14 +238,30 @@ static inline void add_to_weak_pointer_chain(struct weak_pointer *wp) {
|
|||
weak_pointer_chain = wp;
|
||||
}
|
||||
|
||||
/// Same as Lisp LOGBITP, except no negative bignums allowed.
|
||||
static inline boolean layout_bitmap_logbitp(int index, lispobj bitmap)
|
||||
/* Basically like LOGBITP in lisp. Cribbed from src/code/bignum.lisp
|
||||
* The'index' is 0-based starting at the first "payload" word.
|
||||
* word0: header
|
||||
* word1: payload word index 0
|
||||
* word2: payload word index 1
|
||||
* etc
|
||||
* so depending how this is called, you may or may not need to
|
||||
* subtract 1 at the call site.
|
||||
* (Whichever way it is, invariably something either has to add or subtract 1)
|
||||
*/
|
||||
#include "genesis/bignum.h"
|
||||
static inline boolean bitmap_logbitp(unsigned int index, lispobj bitmap)
|
||||
{
|
||||
if (fixnump(bitmap))
|
||||
return (index < (N_WORD_BITS - N_FIXNUM_TAG_BITS))
|
||||
? (bitmap >> (index+N_FIXNUM_TAG_BITS)) & 1
|
||||
: (sword_t)bitmap < 0;
|
||||
return positive_bignum_logbitp(index, (struct bignum*)native_pointer(bitmap));
|
||||
sword_t single_word_bignum = fixnum_value(bitmap);
|
||||
sword_t* digits = &single_word_bignum;
|
||||
unsigned int len = 1;
|
||||
if (!fixnump(bitmap)) {
|
||||
digits = ((struct bignum*)(bitmap - OTHER_POINTER_LOWTAG))->digits;
|
||||
len = HeaderValue(digits[-1]);
|
||||
}
|
||||
unsigned int word_index = index / N_WORD_BITS;
|
||||
unsigned int bit_index = index % N_WORD_BITS;
|
||||
if (word_index >= len) return digits[len-1] < 0;
|
||||
return (digits[word_index] >> bit_index) & 1;
|
||||
}
|
||||
|
||||
/* Keep in sync with 'target-hash-table.lisp' */
|
||||
|
|
@ -334,15 +350,56 @@ static inline void protect_page(void* page_addr, page_index_t page_index)
|
|||
#define KV_PAIRS_HIGH_WATER_MARK(kvv) fixnum_value(kvv[0])
|
||||
#define KV_PAIRS_REHASH(kvv) kvv[1]
|
||||
|
||||
extern lispobj layout_of_layout;
|
||||
|
||||
#include "genesis/layout.h"
|
||||
// Generalize over INSTANCEish things. (Not general like SB-KERNEL:LAYOUT-OF)
|
||||
static inline lispobj layout_of(lispobj* instance) { // native ptr
|
||||
// Smart C compilers eliminate the ternary operator if exprs are the same
|
||||
return widetag_of(instance) == FUNCALLABLE_INSTANCE_WIDETAG
|
||||
? funinstance_layout(instance) : instance_layout(instance);
|
||||
static inline int lockfree_list_node_layout_p(struct layout* layout) {
|
||||
return layout->flags & flag_LockfreeListNode;
|
||||
}
|
||||
|
||||
extern lispobj layout_of_layout;
|
||||
/* This is NOT the same value that lisp's %INSTANCE-LENGTH returns.
|
||||
* Lisp always uses the logical length (as originally allocated),
|
||||
* except when heap-walking which requires exact physical sizes */
|
||||
static inline int instance_length(lispobj header)
|
||||
{
|
||||
// * Byte 3 of an instance header word holds the immobile gen# and visited bit,
|
||||
// so those have to be masked off.
|
||||
// * fullcgc uses bit index 31 as a mark bit, so that has to
|
||||
// be cleared. Lisp does not have to clear bit 31 because fullcgc does not
|
||||
// operate concurrently.
|
||||
// * If the object is in hashed-and-moved state and the original instance payload
|
||||
// length was odd (total object length was even), then add 1.
|
||||
// This can be detected by ANDing some bits, bit 10 being the least-significant
|
||||
// bit of the original size, and bit 9 being the 'hashed+moved' bit.
|
||||
// * 64-bit machines do not need 'long' right-shifts, so truncate to int.
|
||||
|
||||
int extra = ((unsigned int)header >> 10) & ((unsigned int)header >> 9) & 1;
|
||||
return (((unsigned int)header >> INSTANCE_LENGTH_SHIFT) & 0x3FFF) + extra;
|
||||
}
|
||||
|
||||
/// instance_layout() and layout_of() macros takes a lispobj* and are lvalues
|
||||
#ifdef LISP_FEATURE_COMPACT_INSTANCE_HEADER
|
||||
|
||||
# ifdef LISP_FEATURE_LITTLE_ENDIAN
|
||||
# define instance_layout(native_ptr) ((uint32_t*)(native_ptr))[1]
|
||||
# else
|
||||
# error "No instance_layout() defined"
|
||||
# endif
|
||||
# define funinstance_layout(native_ptr) instance_layout(native_ptr)
|
||||
// generalize over either metatype, but not as general as SB-KERNEL:LAYOUT-OF
|
||||
# define layout_of(native_ptr) instance_layout(native_ptr)
|
||||
|
||||
#else
|
||||
|
||||
// first 2 words of ordinary instance are: header, layout
|
||||
# define instance_layout(native_ptr) ((lispobj*)native_ptr)[1]
|
||||
// first 4 words of funcallable instance are: header, trampoline, fin-fun, layout
|
||||
# define funinstance_layout(native_ptr) ((lispobj*)native_ptr)[3]
|
||||
# define layout_of(native_ptr) \
|
||||
((lispobj*)native_ptr)[widetag_of(native_ptr)==FUNCALLABLE_INSTANCE_WIDETAG?3:1]
|
||||
|
||||
#endif
|
||||
|
||||
/// Return true if 'thing' is a layout.
|
||||
static inline boolean layoutp(lispobj thing)
|
||||
{
|
||||
|
|
@ -353,8 +410,4 @@ static inline boolean layoutp(lispobj thing)
|
|||
return layout == layout_of_layout;
|
||||
}
|
||||
|
||||
static inline int lockfree_list_node_layout_p(struct layout* layout) {
|
||||
return layout->flags & flag_LockfreeListNode;
|
||||
}
|
||||
|
||||
#endif /* _GC_PRIVATE_H_ */
|
||||
|
|
|
|||
|
|
@ -3009,9 +3009,6 @@ verify_range(lispobj *where, sword_t nwords, struct verify_state *state)
|
|||
} else switch(widetag) {
|
||||
/* boxed or partially boxed objects */
|
||||
lispobj layout_word;
|
||||
// Two reasons for including funcallable instance here:
|
||||
// (1) the layout may be in the header, and we need to verify it
|
||||
// (2) there may be unboxed words in the object
|
||||
case FUNCALLABLE_INSTANCE_WIDETAG:
|
||||
case INSTANCE_WIDETAG:
|
||||
layout_word = layout_of(where);
|
||||
|
|
@ -3021,10 +3018,17 @@ verify_range(lispobj *where, sword_t nwords, struct verify_state *state)
|
|||
state->vaddr = 0;
|
||||
gc_assert(layoutp(layout_word));
|
||||
struct layout *layout = LAYOUT(layout_word);
|
||||
sword_t nslots = instance_length(thing) | 1;
|
||||
lispobj bitmap = layout->bitmap;
|
||||
gc_assert(fixnump(bitmap)
|
||||
|| widetag_of(native_pointer(bitmap))==BIGNUM_WIDETAG);
|
||||
if (widetag_of(where) == FUNCALLABLE_INSTANCE_WIDETAG) {
|
||||
#ifdef LISP_FEATURE_COMPACT_INSTANCE_HEADER
|
||||
gc_assert(bitmap == make_fixnum(-1) || bitmap == make_fixnum(6));
|
||||
#else
|
||||
gc_assert(bitmap == make_fixnum(-6));
|
||||
#endif
|
||||
} else {
|
||||
gc_assert(fixnump(bitmap)
|
||||
|| widetag_of(native_pointer(bitmap))==BIGNUM_WIDETAG);
|
||||
}
|
||||
if (lockfree_list_node_layout_p(layout)) {
|
||||
struct instance* node = (struct instance*)where;
|
||||
lispobj next = node->slots[INSTANCE_DATA_START];
|
||||
|
|
@ -3035,9 +3039,12 @@ verify_range(lispobj *where, sword_t nwords, struct verify_state *state)
|
|||
state->vaddr = 0;
|
||||
}
|
||||
}
|
||||
instance_scan((void (*)(lispobj*, sword_t, uword_t))verify_range,
|
||||
where+1, nslots, bitmap, (uintptr_t)state);
|
||||
count = 1 + nslots;
|
||||
int i;
|
||||
int nwords = sizetab[widetag](where);
|
||||
lispobj* slots = where+1;
|
||||
for (i=0; i<(nwords-1); ++i)
|
||||
if (bitmap_logbitp(i, bitmap)) verify_range(slots+i, 1, state);
|
||||
count = nwords;
|
||||
}
|
||||
break;
|
||||
case CODE_HEADER_WIDETAG:
|
||||
|
|
@ -3061,7 +3068,7 @@ verify_range(lispobj *where, sword_t nwords, struct verify_state *state)
|
|||
for_each_simple_fun(i, fheaderp, code, 1, {
|
||||
#if defined(LISP_FEATURE_COMPACT_INSTANCE_HEADER)
|
||||
lispobj __attribute__((unused)) layout =
|
||||
function_layout((lispobj*)fheaderp);
|
||||
funinstance_layout((lispobj*)fheaderp);
|
||||
gc_assert(!layout || layout == LAYOUT_OF_FUNCTION);
|
||||
#endif
|
||||
});
|
||||
|
|
|
|||
|
|
@ -1526,8 +1526,7 @@ static boolean forwardable_ptr_p(lispobj ptr)
|
|||
forwarding_pointer_p(native_pointer(ptr));
|
||||
}
|
||||
|
||||
static void adjust_words(lispobj *where, sword_t n_words,
|
||||
uword_t __attribute__((unused)) arg)
|
||||
static void adjust_words(lispobj *where, sword_t n_words)
|
||||
{
|
||||
int i;
|
||||
for (i=0;i<n_words;++i) {
|
||||
|
|
@ -1546,7 +1545,7 @@ static lispobj adjust_fun_entrypoint(lispobj raw_addr)
|
|||
if (asm_routines_start <= raw_addr && raw_addr < asm_routines_end)
|
||||
return raw_addr;
|
||||
lispobj simple_fun = fun_taggedptr_from_self(raw_addr);
|
||||
adjust_words(&simple_fun, 1, 0);
|
||||
adjust_words(&simple_fun, 1);
|
||||
return fun_self_from_taggedptr(simple_fun);
|
||||
}
|
||||
|
||||
|
|
@ -1571,16 +1570,8 @@ static void adjust_fdefn_raw_addr(struct fdefn* fdefn)
|
|||
}
|
||||
}
|
||||
|
||||
/* Fix the layout of OBJ, and return the layout's address in tempspace.
|
||||
* If compact headers, store the layout back into the object.
|
||||
* If non-compact headers, DO NOT store the layout back into the object,
|
||||
* because that will be done when instance_scan() touches all slots.
|
||||
* If it were wrongly done now, then the following (real example) happens:
|
||||
* instance @ 0x1000000000 has layout pointer 0x203cb483.
|
||||
* layout @ 0x203cb483 forwards to 0x2030c483.
|
||||
* object _currently_ at 0x2030c480 (NOT a layout) forwards to 0x203c39cf.
|
||||
* so the instance winds up with a non-layout in its layout after
|
||||
* instance_scan() forwards that slot "again". */
|
||||
/* Fix the layout of OBJ, storing it back to the object,
|
||||
* and return the layout's address in tempspace. */
|
||||
static struct layout* fix_object_layout(lispobj* obj)
|
||||
{
|
||||
// This works on instances, funcallable instances (and/or closures)
|
||||
|
|
@ -1592,13 +1583,11 @@ static struct layout* fix_object_layout(lispobj* obj)
|
|||
#else
|
||||
gc_assert(widetag_of(obj) == INSTANCE_WIDETAG);
|
||||
#endif
|
||||
lispobj layout = instance_layout(obj);
|
||||
lispobj layout = layout_of(obj);
|
||||
if (layout == 0) return 0;
|
||||
if (forwarding_pointer_p(native_pointer(layout))) { // usually
|
||||
layout = forwarding_pointer_value(native_pointer(layout));
|
||||
#ifdef LISP_FEATURE_COMPACT_INSTANCE_HEADER
|
||||
instance_layout(obj) = layout;
|
||||
#endif
|
||||
layout_of(obj) = layout;
|
||||
}
|
||||
struct layout* native_layout = (struct layout*)tempspace_addr(LAYOUT(layout));
|
||||
gc_assert(header_widetag(native_layout->header) == INSTANCE_WIDETAG);
|
||||
|
|
@ -1623,7 +1612,7 @@ static void fixup_space(lispobj* where, size_t n_words)
|
|||
gc_assert(!forwarding_pointer_p(where));
|
||||
lispobj header_word = *where;
|
||||
if (!is_header(header_word)) {
|
||||
adjust_words(where, 2, 0); // A cons. (It can only be filler?)
|
||||
adjust_words(where, 2); // A cons. (It can only be filler?)
|
||||
where += 2;
|
||||
continue;
|
||||
}
|
||||
|
|
@ -1634,18 +1623,20 @@ static void fixup_space(lispobj* where, size_t n_words)
|
|||
if (!leaf_obj_widetag_p(widetag))
|
||||
lose("Unhandled widetag in fixup_space: %p", (void*)header_word);
|
||||
break;
|
||||
#ifdef LISP_FEATURE_COMPACT_INSTANCE_HEADER
|
||||
case FUNCALLABLE_INSTANCE_WIDETAG:
|
||||
#endif
|
||||
case INSTANCE_WIDETAG:
|
||||
instance_scan(adjust_words, where+1, size-1,
|
||||
fix_object_layout(where)->bitmap,
|
||||
0);
|
||||
case FUNCALLABLE_INSTANCE_WIDETAG:
|
||||
{
|
||||
lispobj* slots = where+1;
|
||||
int i;
|
||||
lispobj bitmap = fix_object_layout(where)->bitmap;
|
||||
for(i=0; i<(size-1); ++i)
|
||||
if (bitmap_logbitp(i, bitmap)) adjust_words(slots+i, 1);
|
||||
}
|
||||
break;
|
||||
case CODE_HEADER_WIDETAG:
|
||||
// Fixup the constant pool.
|
||||
code = (struct code*)where;
|
||||
adjust_words(where+2, code_header_words(code)-2, 0);
|
||||
adjust_words(where+2, code_header_words(code)-2);
|
||||
apply_absolute_fixups(code->fixups, code);
|
||||
break;
|
||||
case CLOSURE_WIDETAG:
|
||||
|
|
@ -1655,10 +1646,10 @@ static void fixup_space(lispobj* where, size_t n_words)
|
|||
case FUNCALLABLE_INSTANCE_WIDETAG:
|
||||
#endif
|
||||
// skip the trampoline word at where[1]
|
||||
adjust_words(where+2, size-2, 0);
|
||||
adjust_words(where+2, size-2);
|
||||
break;
|
||||
case FDEFN_WIDETAG:
|
||||
adjust_words(where+1, 2, 0);
|
||||
adjust_words(where+1, 2);
|
||||
adjust_fdefn_raw_addr((struct fdefn*)where);
|
||||
break;
|
||||
|
||||
|
|
@ -1707,7 +1698,7 @@ static void fixup_space(lispobj* where, size_t n_words)
|
|||
// Use the sizing functions for generality.
|
||||
// Symbols can contain strange header bytes,
|
||||
// and vectors might have a padding word, etc.
|
||||
adjust_words(where+1, size-1, 0);
|
||||
adjust_words(where+1, size-1);
|
||||
break;
|
||||
}
|
||||
where += size;
|
||||
|
|
|
|||
|
|
@ -25,6 +25,7 @@
|
|||
#include "runtime.h"
|
||||
#include "code.h"
|
||||
#include "gc-internal.h"
|
||||
#include "gc-private.h"
|
||||
#include <stdarg.h>
|
||||
#include "thread.h" /* genesis/primitive-objects.h needs this */
|
||||
#include <errno.h>
|
||||
|
|
|
|||
|
|
@ -560,23 +560,14 @@ pscav(lispobj *addr, long nwords, boolean constant)
|
|||
|
||||
case INSTANCE_WIDETAG:
|
||||
{
|
||||
lispobj lbitmap = LAYOUT(instance_layout(addr))->bitmap;
|
||||
lispobj* slots = addr + 1;
|
||||
long nslots = instance_length(*addr) | 1;
|
||||
int index;
|
||||
if (fixnump(lbitmap)) {
|
||||
sword_t bitmap = fixnum_value(lbitmap);
|
||||
for (index = 0; index < nslots ; index++, bitmap >>= 1)
|
||||
if (bitmap & 1)
|
||||
pscav(slots + index, 1, constant);
|
||||
} else {
|
||||
struct bignum * bitmap;
|
||||
bitmap = (struct bignum*)native_pointer(lbitmap);
|
||||
for (index = 0; index < nslots ; index++)
|
||||
if (positive_bignum_logbitp(index, bitmap))
|
||||
pscav(slots + index, 1, constant);
|
||||
}
|
||||
count = 1 + nslots;
|
||||
lispobj lbitmap = LAYOUT(instance_layout(addr))->bitmap;
|
||||
long nslots = instance_length(*addr);
|
||||
int index;
|
||||
for (index = 0; index < nslots ; index++)
|
||||
// logically treat index 0 (layout) as a tagged slot
|
||||
if (index == 0 || bitmap_logbitp(index, lbitmap))
|
||||
pscav((addr+1) + index, 1, constant);
|
||||
count = 1 + (nslots | 1);
|
||||
}
|
||||
break;
|
||||
|
||||
|
|
|
|||
|
|
@ -240,36 +240,6 @@ static inline int simple_vector_p(lispobj obj) {
|
|||
widetag_of((lispobj*)(obj-OTHER_POINTER_LOWTAG)) == SIMPLE_VECTOR_WIDETAG;
|
||||
}
|
||||
|
||||
/* This is NOT the same value that lisp's %INSTANCE-LENGTH returns.
|
||||
* Lisp always uses the logical length (as originally allocated),
|
||||
* except when heap-walking which requires exact physical sizes */
|
||||
static inline int instance_length(lispobj header)
|
||||
{
|
||||
// * Byte 3 of an instance header word holds the immobile gen# and visited bit,
|
||||
// so those have to be masked off.
|
||||
// * fullcgc uses bit index 31 as a mark bit, so that has to
|
||||
// be cleared. Lisp does not have to clear bit 31 because fullcgc does not
|
||||
// operate concurrently.
|
||||
// * If the object is in hashed-and-moved state and the original instance payload
|
||||
// length was odd (total object length was even), then add 1.
|
||||
// This can be detected by ANDing some bits, bit 10 being the least-significant
|
||||
// bit of the original size, and bit 9 being the 'hashed+moved' bit.
|
||||
// * 64-bit machines do not need 'long' right-shifts, so truncate to int.
|
||||
|
||||
int extra = ((unsigned int)header >> 10) & ((unsigned int)header >> 9) & 1;
|
||||
return (((unsigned int)header >> INSTANCE_LENGTH_SHIFT) & 0x3FFF) + extra;
|
||||
}
|
||||
|
||||
/// instance_layout() macro takes a lispobj* and is an lvalue
|
||||
#ifndef LISP_FEATURE_COMPACT_INSTANCE_HEADER
|
||||
# define instance_layout(instance_ptr) ((lispobj*)instance_ptr)[1]
|
||||
#elif defined(LISP_FEATURE_64_BIT) && defined(LISP_FEATURE_LITTLE_ENDIAN)
|
||||
// so that this stays an lvalue, it can't be cast to lispobj
|
||||
# define instance_layout(instance_ptr) ((uint32_t*)(instance_ptr))[1]
|
||||
#else
|
||||
# error "No instance_layout() defined"
|
||||
#endif
|
||||
|
||||
/* Is the Lisp object obj something with pointer nature (as opposed to
|
||||
* e.g. a fixnum or character or unbound marker)? */
|
||||
static inline int
|
||||
|
|
|
|||
|
|
@ -163,18 +163,14 @@ static int find_ref(lispobj* source, lispobj target)
|
|||
scan_limit = sizetab[widetag](source);
|
||||
switch (widetag) {
|
||||
case INSTANCE_WIDETAG:
|
||||
#ifdef LISP_FEATURE_COMPACT_INSTANCE_HEADER
|
||||
case FUNCALLABLE_INSTANCE_WIDETAG:
|
||||
#endif
|
||||
// mixed boxed/unboxed objects
|
||||
// Unlike in scav_instance where the slot loop is unswitched for
|
||||
// speed into three cases (no raw slots, fixnum bitmap, bignum bitmap),
|
||||
// here we just go for clarity by abstracting out logbitp.
|
||||
layout = instance_layout(source);
|
||||
// Unlike in scav_instance where the slot loop is optimized for
|
||||
// certain special cases, here we opt for simplicity.
|
||||
layout = layout_of(source);
|
||||
check_ptr(0, layout);
|
||||
bitmap = layout ? LAYOUT(layout)->bitmap : make_fixnum(-1);
|
||||
for(i=1; i<scan_limit; ++i)
|
||||
if (layout_bitmap_logbitp(i-1, bitmap)) check_ptr(i, source[i]);
|
||||
if (bitmap_logbitp(i-1, bitmap)) check_ptr(i, source[i]);
|
||||
// FIXME: check lockfree_list_node_p() also
|
||||
return -1;
|
||||
#if FUN_SELF_FIXNUM_TAGGED
|
||||
|
|
@ -737,19 +733,15 @@ static uword_t build_refs(lispobj* where, lispobj* end,
|
|||
nwords = scan_limit = sizetab[widetag](where);
|
||||
switch (widetag) {
|
||||
case INSTANCE_WIDETAG:
|
||||
#ifdef LISP_FEATURE_COMPACT_INSTANCE_HEADER
|
||||
case FUNCALLABLE_INSTANCE_WIDETAG:
|
||||
#endif
|
||||
// mixed boxed/unboxed objects
|
||||
layout = instance_layout(where);
|
||||
layout = layout_of(where);
|
||||
check_ptr(layout);
|
||||
// Partially initialized instance can't have nonzero words yet
|
||||
bitmap = layout ? LAYOUT(layout)->bitmap : make_fixnum(-1);
|
||||
// If no raw slots, just scan without use of the bitmap.
|
||||
// FIXME: check lockfree_list_node_p() also
|
||||
if (bitmap == make_fixnum(-1)) break;
|
||||
for(i=1; i<scan_limit; ++i)
|
||||
if (layout_bitmap_logbitp(i-1, bitmap)) check_ptr(where[i]);
|
||||
if (bitmap_logbitp(i-1, bitmap)) check_ptr(where[i]);
|
||||
continue;
|
||||
#if FUN_SELF_FIXNUM_TAGGED
|
||||
case CLOSURE_WIDETAG:
|
||||
|
|
|
|||
|
|
@ -66,37 +66,34 @@
|
|||
(princ 'did-pass-2) (terpri)
|
||||
(force-output)
|
||||
|
||||
;; Test the C bignum bit extractor.
|
||||
;; Surprisingly, there was a bug in it, unrelated to forwarding
|
||||
;; pointers that remained dormant until the randomized
|
||||
;; HUGE-MANYRAW test in 'defstruct.impure.lisp' found it.
|
||||
(defun c-bignum-logbitp (index bignum)
|
||||
(assert (typep bignum 'bignum))
|
||||
(sb-sys:with-pinned-objects (bignum)
|
||||
(alien-funcall (extern-alien "positive_bignum_logbitp"
|
||||
(function boolean int system-area-pointer))
|
||||
index
|
||||
(sb-sys:int-sap
|
||||
(- (sb-kernel:get-lisp-obj-address bignum)
|
||||
sb-vm:other-pointer-lowtag)))))
|
||||
;; Test the C bitmap bit extractor.
|
||||
(defun c-bitmap-logbitp (index integer)
|
||||
(eql (sb-sys:with-pinned-objects (integer)
|
||||
(alien-funcall (extern-alien "test_bitmap_logbitp"
|
||||
(function int int unsigned))
|
||||
index
|
||||
(sb-kernel:get-lisp-obj-address integer)))
|
||||
1))
|
||||
|
||||
(with-test (:name :c-bignum-logbitp)
|
||||
(with-test (:name :bigmap-logbitp)
|
||||
;; walking 1 bit
|
||||
(dotimes (i 256)
|
||||
(let ((num (ash 1 i)))
|
||||
(when (typep num 'bignum)
|
||||
(dotimes (j 257)
|
||||
(assert (eq (c-bignum-logbitp j num)
|
||||
(logbitp j num)))))))
|
||||
(dotimes (j 257)
|
||||
(assert (eq (c-bitmap-logbitp j num) (logbitp j num))))))
|
||||
;; walking 0 bit
|
||||
(dotimes (i 256)
|
||||
(let ((num (lognot (ash 1 i))))
|
||||
(dotimes (j 257)
|
||||
(assert (eq (c-bitmap-logbitp j num) (logbitp j num))))))
|
||||
;; random bits
|
||||
(let ((max (ash 1 768)))
|
||||
(dotimes (i 100)
|
||||
(let ((num (random max)))
|
||||
(when (typep num 'bignum)
|
||||
(dotimes (j (* (sb-bignum:%bignum-length num)
|
||||
sb-vm:n-word-bits))
|
||||
(assert (eq (c-bignum-logbitp j num)
|
||||
(logbitp j num)))))))))
|
||||
(let ((num (- (random max) (floor max 20)))) ; test both + and -
|
||||
(dotimes (j (if (typep num 'bignum)
|
||||
(* (sb-bignum:%bignum-length num) sb-vm:n-word-bits)
|
||||
sb-vm:n-word-bits))
|
||||
(assert (eq (c-bitmap-logbitp j num) (logbitp j num))))))))
|
||||
|
||||
;; for testing the comparator
|
||||
(defstruct foo1
|
||||
|
|
|
|||
Loading…
Reference in a new issue