diff --git a/float-math.lisp-expr b/float-math.lisp-expr index daeff5110..5144996b5 100644 --- a/float-math.lisp-expr +++ b/float-math.lisp-expr @@ -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) diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 2aa51b046..daa94ca3d 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -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 diff --git a/src/code/early-classoid.lisp b/src/code/early-classoid.lisp index 9e27d1d0e..2f37166d5 100644 --- a/src/code/early-classoid.lisp +++ b/src/code/early-classoid.lisp @@ -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)) diff --git a/src/code/early-raw-slots.lisp b/src/code/early-raw-slots.lisp index 25907c229..f4dfaa094 100644 --- a/src/code/early-raw-slots.lisp +++ b/src/code/early-raw-slots.lisp @@ -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 diff --git a/src/code/room.lisp b/src/code/room.lisp index 984af6e1b..cb946c87d 100644 --- a/src/code/room.lisp +++ b/src/code/room.lisp @@ -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 diff --git a/src/code/x86-64-vm.lisp b/src/code/x86-64-vm.lisp index b6399c75a..c6bd17516 100644 --- a/src/code/x86-64-vm.lisp +++ b/src/code/x86-64-vm.lisp @@ -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' diff --git a/src/compiler/early-c.lisp b/src/compiler/early-c.lisp index d63c98eb9..44544d81b 100644 --- a/src/compiler/early-c.lisp +++ b/src/compiler/early-c.lisp @@ -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: diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 532c52219..213b6a7a5 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -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) diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index 6e1b55e2f..ad3c1f86b 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -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 diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 2893bb8ad..4dc68046e 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -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)))))) diff --git a/src/pcl/walk.lisp b/src/pcl/walk.lisp index 34615b575..83031af22 100644 --- a/src/pcl/walk.lisp +++ b/src/pcl/walk.lisp @@ -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)))) diff --git a/src/pcl/wrapper.lisp b/src/pcl/wrapper.lisp index 2e8ee0d3c..a8ef071d3 100644 --- a/src/pcl/wrapper.lisp +++ b/src/pcl/wrapper.lisp @@ -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))) diff --git a/src/runtime/coalesce.c b/src/runtime/coalesce.c index 29f767a19..94852c961 100644 --- a/src/runtime/coalesce.c +++ b/src/runtime/coalesce.c @@ -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; in_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; ibitmap; - 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; ibitmap; + 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; ibitmap; - // 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; iheader); - 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); +} diff --git a/src/runtime/gc-internal.h b/src/runtime/gc-internal.h index cbedec973..52b69ead9 100644 --- a/src/runtime/gc-internal.h +++ b/src/runtime/gc-internal.h @@ -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); diff --git a/src/runtime/gc-private.h b/src/runtime/gc-private.h index 6b2ee9dcb..e038f17c5 100644 --- a/src/runtime/gc-private.h +++ b/src/runtime/gc-private.h @@ -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_ */ diff --git a/src/runtime/gencgc.c b/src/runtime/gencgc.c index 69e8ef6a4..75feb3983 100644 --- a/src/runtime/gencgc.c +++ b/src/runtime/gencgc.c @@ -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 }); diff --git a/src/runtime/immobile-space.c b/src/runtime/immobile-space.c index 1da2e5261..8798a921d 100644 --- a/src/runtime/immobile-space.c +++ b/src/runtime/immobile-space.c @@ -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;iheader) == 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; diff --git a/src/runtime/print.c b/src/runtime/print.c index 24a3616b6..cf9419657 100644 --- a/src/runtime/print.c +++ b/src/runtime/print.c @@ -25,6 +25,7 @@ #include "runtime.h" #include "code.h" #include "gc-internal.h" +#include "gc-private.h" #include #include "thread.h" /* genesis/primitive-objects.h needs this */ #include diff --git a/src/runtime/purify.c b/src/runtime/purify.c index 085675152..ca8425ccd 100644 --- a/src/runtime/purify.c +++ b/src/runtime/purify.c @@ -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; diff --git a/src/runtime/runtime.h b/src/runtime/runtime.h index 4b03f3f89..f751fc0b5 100644 --- a/src/runtime/runtime.h +++ b/src/runtime/runtime.h @@ -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 diff --git a/src/runtime/traceroot.c b/src/runtime/traceroot.c index a62b1d218..69e084807 100644 --- a/src/runtime/traceroot.c +++ b/src/runtime/traceroot.c @@ -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; ibitmap : 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