common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Merge codeblob tree changes from master

Browse source
This commit is contained in:
Douglas Katzman 2022-06-09 14:32:09 -04:00
parent fdd3c5e5af
commit 95d71c33d7
22 changed files with 280 additions and 123 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
make-target-2-load.lisp
View file

@ -433,6 +433,7 @@ Please check that all strings which were not recognizable to the compiler
#.(find-package "SB-PCL")
#.(find-package "SB-MOP")
#.(find-package "SB-PRETTY")
#.(find-package "SB-BROTHERTREE")
#.(find-package "SB-KERNEL"))
;; Assume all and only external symbols must be retained
(eq accessibility :external))

10
src/code/alloc.lisp
View file

@ -453,6 +453,8 @@
(defun immobile-space-obj-p (obj)
(immobile-space-addr-p (get-lisp-obj-address obj)))
(define-load-time-global *codeblob-tree* nil)
;;; Enforce limit on boxed words based on maximum total number of words
;;; that can be indicated in the header for 32-bit words.
;;; 22 bits = 4MiB, quite generous for one code object.
@ -502,6 +504,14 @@
(with-pinned-objects (code)
(let ((sap (sap+ (int-sap (get-lisp-obj-address code))
(- other-pointer-lowtag))))
;; Record it in the balanced tree.
(let ((tree *codeblob-tree*) (addr (sap-int sap)))
(loop (let ((newtree (sb-brothertree:insert addr tree)))
;; check that it hasn't been promoted from gen0 -> gen1 already
;; (very unlikely, but certainly possible).
(unless (eq (generation-of code) 0) (return))
(let ((oldval (cas *codeblob-tree* tree newtree)))
(if (eq oldval tree) (return) (setq tree oldval))))))
;; The immobile space allocator pre-zeroes, and also it needs a nonzero
;; value in the boxed word count because otherwise it looks like
;; an immobile space page filler. So don't do any more zeroing there.

39
src/code/brothertree.lisp
View file

@ -9,11 +9,6 @@
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(defpackage "SB-BROTHERTREE"
(:use "CL" "SB-EXT")
(:import-from "SB-INT" #:named-let #:binding* #:awhen #:acond #:it)
(:shadow #:delete))
(in-package "SB-BROTHERTREE")
;;;; Translated from the Haskell code in
@ -21,10 +16,12 @@
;(declaim (optimize (sb-c::store-coverage-data 3)))
(deftype keytype () 'sb-vm:word)
(defstruct (binary-node (:copier nil)
(:constructor make-binary-node (key %left %right)))
;; key must be in slot index 0 because fringe binary nodes have only this slot
(key 0 :type fixnum)
(key 0 :type keytype)
%left %right)
(defstruct (unary-node (:copier nil)
(:conc-name "")
@ -79,9 +76,11 @@
(error "won't make binary node from ~S ~S" left right))
(if (or left right)
(make-binary-node key left right)
(let ((instance (sb-kernel:%new-instance #.(sb-kernel:find-layout 'binary-node)
(let ((instance (sb-kernel:%make-instance/mixed
(1+ sb-vm:instance-data-start))))
(sb-kernel:%instance-set instance sb-vm:instance-data-start key)
(sb-kernel:%set-instance-layout instance #.(sb-kernel:find-layout 'binary-node))
;; Nodes are immutable, hence no setf'er exists.
(sb-kernel:%raw-instance-set/word instance sb-vm:instance-data-start key)
(truly-the binary-node instance))))
(defmacro binary-node-parts (node)
@ -108,8 +107,9 @@
(format stream "child=~D"
(if child (binary-node-key child))))))
(defun insert (a tree)
(declare (fixnum a))
(defun insert (a tree &aux (leaf (L2 a)))
(declare (keytype a))
(declare (dynamic-extent leaf))
;; The Haskell code uses different definitions of 'root' and 'n2'
;; for insert and delete. That's certainly confusing.
;; Anyway these have to be internal functions to avoid duplication.
@ -156,7 +156,7 @@
(values l b (ins r)))))
(|n2| new-left new-key new-right)))
(unary-node (|n1| (ins (child x))))
(null (L2 a))))
(null leaf)))
(root (x) ; bubble up. not sure why 'root' is a good name for this
(typecase x
((cons (eql leaf)) (N2 nil (cdr x) nil))
@ -172,7 +172,6 @@
;;; sure we don't wrongly pick the last.
;;; Hence it doesn't really matter much in what order the others are tried.
(defglobal *cases* (make-array 8))
(eval-when (:compile-toplevel :execute)
(defmacro pattern-case ((L R) &rest clauses &aux (n -1))
(flet ((shape-is (node shape)
;; SHAPE has a small number of hardcoded possibilities which are
@ -206,10 +205,10 @@
,(shape-is R (second test)))
;; (incf (aref *cases* ,n))
,consequent))))
clauses)))))
clauses))))
(defun delete (a tree)
(declare (fixnum a))
(declare (keytype a))
(labels ((|n2| (left key right)
;; this surely isn't as readable as pattern-matching in Haskell,
;; but it'll do.
@ -293,7 +292,7 @@
(t x))))
(root (del tree))))
(defun print-tree (tree)
(defun print-tree (tree &optional converter)
(named-let recurse ((depth 0) (node tree))
(etypecase node
(unary-node
@ -302,13 +301,17 @@
(recurse (1+ depth) (child node)))
(binary-node
(multiple-value-bind (left key right) (binary-node-parts node)
(format t "~2d: ~v@t Key=~D ~x~%"
depth (* depth 2) key (sb-kernel:get-lisp-obj-address node))
(let ((*print-pretty* nil))
(format t "~2d: ~v@t Key=~X ~x~@[ ~A~]~%"
depth (* depth 2) key (sb-kernel:get-lisp-obj-address node)
(if converter (funcall converter node key))))
(recurse (1+ depth) left)
(recurse (1+ depth) right)))
(null))))
(export 'print-tree)
(defun find= (key tree)
(declare (keytype key))
(loop
(typecase tree
(binary-node
@ -320,7 +323,7 @@
(null (return nil)))))
(defun find<= (key tree)
(declare (fixnum key))
(declare (keytype key))
(when tree
(named-let recurse ((node tree) (best nil))
(if (unary-node-p (truly-the sb-kernel:instance node))

1
src/code/cold-init.lisp
View file

@ -136,6 +136,7 @@
(/show0 "entering !COLD-INIT")
#+sb-show (setq */show* t)
(setq sb-vm::*codeblob-tree* nil)
(setq sb-kernel::*defstruct-hooks* '(sb-kernel::!bootstrap-defstruct-hook)
sb-kernel::*struct-accesss-fragments-delayed* nil)
(let ((stream (!make-cold-stderr-stream)))

4
src/code/debug-int.lisp
View file

@ -562,7 +562,7 @@
;;; (1) use unsafe %MAKE-LISP-OBJ, since we've already determined
;;; where the code object starts with certainty, and we don't need
;;; yet another search to test validity of the address.
;;; (2) wrap the calls in WITHOUT-GCING.
;;; (2) wrap the calls in WITH-CODE-PAGES-PINNED.
;;;
;;; Here's a concrete example, assuming the following objects exists:
;;; 0x8000: vector header |
@ -598,7 +598,7 @@
;;; to any object on a specified page.
;;;
;;; On top of the considerations about dynamic space, there is a further issue
;;; with allocatin of immobile code. The allocator creates transient inconsistent
;;; with allocation of immobile code. The allocator creates transient inconsistent
;;; states when it reuses holes. Even if the header could be written atomically,
;;; there can be junk in the remaining bytes of the hole that gets rewritten as
;;; a smaller hole. It's evident that acquiring the allocator mutex works around

36
src/code/gc.lisp
View file

@ -424,6 +424,42 @@ statistics are appended to it."
(define-alien-variable generations
(array generation #.(1+ sb-vm:+pseudo-static-generation+)))
;;; Why is PAGE-INDEX-T in SB-KERNEL but PAGE and the page table are in SB-VM?
(define-alien-type (struct sb-vm::page)
(struct sb-vm::page
;; To cut down the size of the page table, the scan_start_offset
;; - a/k/a "start" - is measured in 4-byte integers regardless
;; of word size. This is fine for 32-bit address space,
;; but if 64-bit then we have to scale the value. Additionally
;; there is a fallback for when even the scaled value is too big.
(sb-vm::start #+64-bit (unsigned 32) #-64-bit signed)
;; On platforms with small enough GC pages, this field
;; will be a short. On platforms with larger ones, it'll
;; be an int. It should probably never be an int.
(sb-vm::words-used (unsigned
#.(if (typep sb-vm::gencgc-page-words '(unsigned-byte 16))
16
32)))
(sb-vm::flags (unsigned 8)) ; in C this is {type, need_zerofill, pinned}
(sb-vm::gen (signed 8))))
(define-alien-variable ("page_table" sb-vm:page-table) (* (struct sb-vm::page)))
(declaim (inline sb-vm:find-page-index))
(define-alien-routine ("ext_find_page_index" sb-vm:find-page-index) page-index-t (address unsigned))
(defun generation-of (object)
(with-pinned-objects (object)
(let* ((addr (get-lisp-obj-address object))
(page (sb-vm:find-page-index addr)))
(cond ((>= page 0) (slot (deref sb-vm:page-table page) 'sb-vm::gen))
#+immobile-space
((immobile-space-addr-p addr)
;; SIMPLE-FUNs don't contain a generation byte
(when (simple-fun-p object)
(setq addr (get-lisp-obj-address (fun-code-header object))))
(let ((sap (int-sap (logandc2 addr sb-vm:lowtag-mask))))
(logand (if (fdefn-p object) (sap-ref-8 sap 1) (sap-ref-8 sap 3))
#xF)))))))
(export 'page-protected-p)
(macrolet ((addr->mark (addr)
`(sap-ref-8 (extern-alien "gc_card_mark" system-area-pointer)

17
src/code/redblack.lisp
View file

@ -9,8 +9,6 @@
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB-RBTREE")
;;; For testing
;;; (declaim (optimize sb-c:store-coverage-data))
@ -23,6 +21,19 @@
;;; http://matt.might.net/papers/germane2014deletion.pdf
;;; which I found to be less simple when translated from Haskell.
(defpackage "SB-RBTREE"
(:use "CL" "SB-INT" "SB-EXT"))
(defpackage "SB-RBTREE.WORD"
(:use "CL")
(:shadow "DELETE")
(:export "INSERT" "DELETE"))
(defpackage "SB-RBTREE.MAP"
(:use "CL")
(:shadow "DELETE")
(:export "INSERT" "DELETE"))
(in-package "SB-RBTREE")
(defmacro define-tree-class (&key key-type value-type (lessp '<)
&aux (data-type (if value-type 'cons key-type))
(name (intern "RBNODE"))
@ -239,8 +250,6 @@
((,lessp (node-key node) key) (recurse (right node) best))
(t node))))))))
(mapc 'unintern '(define-tree-class define-search-methods))
;;; Each specialization of the structure is in its own package.
;;; This may not be the best way to do it.
;;; I was hoping that the FLET of BALANCE would eliminate consing when passing

38
src/code/room.lisp
View file

@ -225,25 +225,6 @@
;;; Access to the GENCGC page table for better precision in
;;; MAP-ALLOCATED-OBJECTS
#+gencgc
(progn
(define-alien-type (struct page)
(struct page
;; To cut down the size of the page table, the scan_start_offset
;; - a/k/a "start" - is measured in 4-byte integers regardless
;; of word size. This is fine for 32-bit address space,
;; but if 64-bit then we have to scale the value. Additionally
;; there is a fallback for when even the scaled value is too big.
(start #+64-bit (unsigned 32) #-64-bit signed)
;; On platforms with small enough GC pages, this field
;; will be a short. On platforms with larger ones, it'll
;; be an int. It should probably never be an int.
(words-used (unsigned
#.(if (typep gencgc-page-words '(unsigned-byte 16))
16
32)))
(flags (unsigned 8)) ; in C this is {type, need_zerofill, pinned}
(gen (signed 8))))
#+immobile-space
(progn
(define-alien-type (struct immobile-page)
@ -257,11 +238,7 @@
(page-link (unsigned 16))
(prior-free-index (unsigned 16))))
(define-alien-variable "fixedobj_pages" (* (struct immobile-page))))
(declaim (inline find-page-index))
(define-alien-routine ("ext_find_page_index" find-page-index)
long (index unsigned))
(define-alien-variable "next_free_page" sb-kernel::page-index-t)
(define-alien-variable "page_table" (* (struct page))))
#+immobile-space
(progn
@ -1206,21 +1183,6 @@ We could try a few things to mitigate this:
(%make-lisp-obj varyobj-space-start)
(%make-lisp-obj (sap-int *varyobj-space-free-pointer*))))))
#+gencgc
(defun generation-of (object)
(with-pinned-objects (object)
(let* ((addr (get-lisp-obj-address object))
(page (find-page-index addr)))
(cond ((>= page 0) (slot (deref page-table page) 'gen))
#+immobile-space
((immobile-space-addr-p addr)
;; SIMPLE-FUNs don't contain a generation byte
(when (simple-fun-p object)
(setq addr (get-lisp-obj-address (fun-code-header object))))
(let ((sap (int-sap (logandc2 addr lowtag-mask))))
(logand (if (fdefn-p object) (sap-ref-8 sap 1) (sap-ref-8 sap 3))
#xF)))))))
;;; Show objects in a much simpler way than print-allocated-objects.
;;; Probably don't use this for generation 0 of dynamic space. Other spaces are ok.
;;; (And this is removed from the image; it's meant for developers)

4
src/cold/build-order.lisp-expr
View file

@ -518,6 +518,7 @@
; "compiler/generic/core"
("src/code/alloc" :not-host) ; needs foo-SPACE-START
("src/code/brothertree" :not-host)
#+metaspace ("src/code/metaspace" :not-host)
("src/code/simple-fun" :not-host) ; function slot accessors
("src/code/eval" :not-host) ; uses INFO, wants compiler macro
@ -606,8 +607,7 @@
("src/code/format") ; needs SB-XC:DEFMACRO
("src/code/target-format" :not-host)
("src/code/late-globaldb" :not-host)
("src/code/redblack" :not-host))
("src/code/late-globaldb" :not-host))
;;; make-target-2 build steps
(("src/code/early-ntrace" ; lets PCL hook into tracing

14
src/cold/exports.lisp
View file

@ -3530,17 +3530,9 @@ package is deprecated in favour of SB-MOP.")
"CLASS-NOT-FOUND-ERROR"
"SPECIALIZER-NAME-SYNTAX-ERROR"))
(defpackage* "SB-RBTREE"
(:documentation "internal: red/black tree")
(:use "CL" "SB-INT" "SB-EXT"))
(defpackage* "SB-RBTREE.WORD"
(:documentation nil)
(:use "CL")
(:shadow "DELETE")
(:export "INSERT" "DELETE"))
(defpackage* "SB-RBTREE.MAP"
(:documentation nil)
(:use "CL")
(defpackage* "SB-BROTHERTREE"
(:use "CL" "SB-EXT" "SB-INT")
(:documentation "internal: 1-2-Brother tree")
(:shadow "DELETE")
(:export "INSERT" "DELETE"))

35
src/compiler/generic/genesis.lisp
View file

@ -1220,36 +1220,6 @@ core and return a descriptor to it."
descriptor)
make-cold-layout))
(defvar *general-layout-uniqueid-counter* ; incremented before use
(ecase sb-kernel::layout-id-type
(signed-byte 127) ; predefined IDs range from -128 to 127
(unsigned-byte 255))) ; all IDs are unsigned integers
;;; Conditions are numbered from -128 downward,
;;; but only if layout IDs can be negative.
(defvar *condition-layout-uniqueid-counter* -128) ; decremented before use
(defun choose-layout-id (name conditionp)
;; If you change these, then also change src/runtime/gc-private.h
;; The ID of T is irrelevant since we'll never try to compare to it.
(case name
((t) 0)
(structure-object 1)
#+metaspace (wrapper 2)
(#+metaspace sb-vm:layout #-metaspace wrapper 3)
(sb-lockless::list-node 4)
(t (or (cdr (assq name sb-kernel::*popular-structure-types*))
(ecase sb-kernel::layout-id-type
(unsigned-byte
(incf *general-layout-uniqueid-counter*))
(signed-byte
(if conditionp
;; It doesn't really matter what ID is assigned to a CONDITION subtype
;; because we don't use the IDs for type testing. Nor for standard-object.
;; But I'd like to a have a quick visual scan of the IDs assigned during
;; genesis by giving them negative values which can't otherwise occur.
(decf *condition-layout-uniqueid-counter*)
(incf *general-layout-uniqueid-counter*))))))))
(defun cold-wrapper-id (wrapper-descriptor)
(let* ((layout-descriptor (->layout wrapper-descriptor))
(proxy (gethash (descriptor-bits layout-descriptor) *cold-layout-by-addr*)))
@ -1275,7 +1245,7 @@ core and return a descriptor to it."
(or (awhen (gethash 'wrapper *cold-layouts*)
(cold-layout-descriptor it))
(make-fixnum-descriptor 0))))
(this-id (choose-layout-id name (logtest flags +condition-layout-flag+)))
(this-id (sb-kernel::choose-layout-id name (logtest flags +condition-layout-flag+)))
(hash (make-fixnum-descriptor (sb-impl::hash-layout-name name))))
(let ((proxy (%make-cold-layout :id this-id
@ -1900,7 +1870,8 @@ core and return a descriptor to it."
;; increment, so we need to add 1 to get to the next value for it because
;; we always pre-increment *general-layout-uniqueid-counter* when reading it.
(cold-set 'sb-kernel::*layout-id-generator*
(cold-list (make-fixnum-descriptor (1+ *general-layout-uniqueid-counter*))))
(cold-list (make-fixnum-descriptor
(1+ sb-kernel::*general-layout-uniqueid-counter*))))
(cold-set 'sb-c::*!initial-parsed-types*
(vector-in-core
(mapcar (lambda (x)

45
src/compiler/generic/layout-ids.lisp
View file

@ -24,13 +24,14 @@
(defparameter *popular-structure-types* (mapcar 'list '(
SB-KERNEL:CTYPE
HASH-TABLE
SB-IMPL::GENERAL-HASH-TABLE
SB-C::NODE
SB-C::GLOBAL-CONFLICTS
SB-C::GLOBAL-VAR
SB-C::FUNCTIONAL
SB-C::LEAF
SB-KERNEL:ANSI-STREAM
SB-C::IR2-BLOCK
SB-RBTREE::RBNODE
SB-C::VALUED-NODE
RANDOM-STATE
CAST
@ -40,15 +41,14 @@ SB-SYS:FD-STREAM
SB-C::BASIC-COMBINATION
SB-INT:SSET-ELEMENT
SB-C:TN-REF
SB-RBTREE::RED-NODE
SB-KERNEL:ARGS-TYPE
SB-C::VOP
SB-C:STORAGE-BASE
SB-C:STORAGE-CLASS
SB-KERNEL:LEXENV
SB-ASSEM::ANNOTATION
SB-KERNEL:INTERSECTION-TYPE
SB-C:PRIMITIVE-TYPE
SB-RBTREE::BLACK-NODE
#+sb-fasteval SB-INTERPRETER:BASIC-ENV
SB-KERNEL:NUMERIC-TYPE
SB-KERNEL:CLASSOID
@ -67,6 +67,7 @@ SB-KERNEL:ARRAY-TYPE
SB-KERNEL:COMPOUND-TYPE
SB-KERNEL:NEGATION-TYPE
SB-REGALLOC::VERTEX
SB-THREAD:THREAD
SB-THREAD::AVLNODE
SB-C::ABSTRACT-LEXENV
SB-KERNEL:UNKNOWN-TYPE
@ -202,6 +203,8 @@ SB-ALIEN-INTERNALS:ALIEN-ENUM-TYPE
SB-INT:DEPRECATION-INFO
SB-DI::FUN-END-COOKIE
SB-ALIEN::SHARED-OBJECT
SB-PCL::FAST-METHOD-CALL
SB-C::DXABLE-ARGS
)))
;;; The rationale for using (signed-byte 8) for small IDs on the x86
@ -221,10 +224,11 @@ SB-ALIEN::SHARED-OBJECT
;;; 2 = WRAPPER if #+metaspace, unused if #-metaspace
;;; 3 = SB-VM:LAYOUT if #+metaspace, WRAPPER if #-metaspace
;;; 4 = SB-LOCKLESS::LIST-NODE
;;; 5 = SB-BROTHERTREE::UNARY-NODE
(ecase layout-id-type
(unsigned-byte
;; Assign all the above an (UNSIGNED-BYTE 8) layout-id.
(let ((id 4)) ; pre-increment when using
(let ((id 5)) ; pre-increment when using
(dolist (item *popular-structure-types*)
;; Because of (MAPCAR #'LIST ...) it is ok to modify this list.
(rplacd item (incf id)))))
@ -237,5 +241,36 @@ SB-ALIEN::SHARED-OBJECT
(dolist (item *popular-structure-types*)
;; Because of (MAPCAR #'LIST ...) it is ok to modify this list.
(rplacd item id)
(setq id (if (= id -1) 5 ; hop over the wired IDs
(setq id (if (= id -1) 6 ; hop over the wired IDs
(1+ id)))))))
(defvar *general-layout-uniqueid-counter* ; incremented before use
(ecase sb-kernel::layout-id-type
(signed-byte 127) ; predefined IDs range from -128 to 127
(unsigned-byte 255))) ; all IDs are unsigned integers
;;; Conditions are numbered from -128 downward,
;;; but only if layout IDs can be negative.
(defvar *condition-layout-uniqueid-counter* -128) ; decremented before use
(defun choose-layout-id (name conditionp)
;; If you change these, then also change src/runtime/gc-private.h
;; The ID of T is irrelevant since we'll never try to compare to it.
(case name
((t) 0)
(structure-object 1)
#+metaspace (wrapper 2)
(#+metaspace sb-vm:layout #-metaspace wrapper 3)
(sb-lockless::list-node 4)
(sb-brothertree::unary-node 5)
(t (or (cdr (assq name sb-kernel::*popular-structure-types*))
(ecase sb-kernel::layout-id-type
(unsigned-byte
(incf *general-layout-uniqueid-counter*))
(signed-byte
(if conditionp
;; It doesn't really matter what ID is assigned to a CONDITION subtype
;; because we don't use the IDs for type testing. Nor for standard-object.
;; But I'd like to a have a quick visual scan of the IDs assigned during
;; genesis by giving them negative values which can't otherwise occur.
(decf *condition-layout-uniqueid-counter*)
(incf *general-layout-uniqueid-counter*))))))))

1
src/compiler/generic/parms.lisp
View file

@ -220,6 +220,7 @@
;; threading support
#+sb-thread ,@'(sb-thread::*starting-threads* *free-tls-index*)
*codeblob-tree*
;; runtime linking of lisp->C calls (regardless of whether
;; the C function is in a dynamic shared object or not)

19
src/runtime/brothertree.h Normal file
View file

@ -0,0 +1,19 @@
#include "lispobj.h"
struct binary_node {
lispobj header;
#ifndef LISP_FEATURE_COMPACT_INSTANCE_HEADER
lispobj layout;
#endif
uword_t key;
lispobj left, right;
};
struct unary_node {
lispobj header;
#ifndef LISP_FEATURE_COMPACT_INSTANCE_HEADER
lispobj layout;
#endif
lispobj child;
};
extern uword_t brothertree_find_lesseql(uword_t key, lispobj tree);

2
src/runtime/gc-common.c
View file

@ -1907,6 +1907,8 @@ sword_t scav_code_blob(lispobj *object, lispobj header);
lispobj *
component_ptr_from_pc(char *pc)
{
/* FIXME: this is the wrong way to go about finding code,
* because it won't look in the codeblob tree for immobile space. */
lispobj *object = search_all_gc_spaces(pc);
if (object != NULL && widetag_of(object) == CODE_HEADER_WIDETAG)

1
src/runtime/gc-private.h
View file

@ -553,6 +553,7 @@ static inline int layout_depth2_id(struct layout* layout) {
#define WRAPPER_LAYOUT_ID 2
#define LAYOUT_LAYOUT_ID 3
#define LFLIST_NODE_LAYOUT_ID 4
#define BROTHERTREE_UNARY_NODE_LAYOUT_ID 5
/// Return true if 'thing' is a layout.
/// This predicate is careful, as is it used to verify heap invariants.

29
src/runtime/gencgc.c
View file

@ -1516,9 +1516,9 @@ gc_find_freeish_pages(page_index_t *restart_page_ptr, sword_t nbytes,
- page_bytes_used(first_page)) > 0 &&
// "extensible" means all PTE fields are compatible
page_extensible_p(first_page, gen, page_type)) {
// XXX: Prefer to start non-code on new pages.
// This is temporary until scavenging of small-object pages
// is made a little more intelligent (work in progress).
// TODO: Now that BOXED, CONS, and SMALL_MIXED pages exist, investigate
// whether the bias against returning partial pages is still useful.
// It probably isn't.
if (bytes_found < nbytes && !is_code(page_type)) {
if (bytes_found > most_bytes_found)
most_bytes_found = bytes_found;
@ -1861,6 +1861,7 @@ copy_unboxed_object(lispobj object, sword_t nwords)
/* This will NOT reliably work for objects in a currently open allocation region,
* because page_words_used() is not sync'ed to the free pointer until closing */
#include "brothertree.h"
lispobj *search_dynamic_space(void *pointer)
{
page_index_t page_index = find_page_index(pointer);
@ -1876,6 +1877,20 @@ lispobj *search_dynamic_space(void *pointer)
else
return NULL;
}
// Generation 0 code is in the tree usually - it isn't for objects
// in generation 0 following a non-promotion cycle.
if (type == PAGE_TYPE_CODE && page_table[page_index].gen == 0) {
lispobj node = brothertree_find_lesseql((uword_t)pointer,
SYMBOL(CODEBLOB_TREE)->value);
if (node != NIL) {
lispobj *codeblob = (lispobj*)((struct binary_node*)INSTANCE(node))->key;
if (widetag_of(codeblob) != CODE_HEADER_WIDETAG)
lose("widetag @ %p is not code? %lx\n", codeblob, *codeblob);
int nwords = code_total_nwords((struct code*)codeblob);
lispobj *upper_bound = codeblob + nwords;
if (pointer < (void*)upper_bound) return codeblob;
}
}
lispobj *start;
if (type == PAGE_TYPE_SMALL_MIXED) { // find the nearest card boundary below 'pointer'
if ((char*)pointer > page_address(page_index)+page_bytes_used(page_index)) return NULL;
@ -4488,6 +4503,13 @@ garbage_collect_generation(generation_index_t generation, int raise,
g->num_gc = raise ? 0 : (1 + g->num_gc);
maybe_verify:
/* After a GC, pages of code are safe to linearly scan because
* there won't be random junk on them below page_bytes_used.
* And we don't want to see forwarding pointers on objects in the tree,
* so just erase the tree now.
* This is WRONG for immobile code, but not worse than status quo
* in terms of inability to find objects in the SIGPROF handler etc */
SYMBOL(CODEBLOB_TREE)->value = NIL;
if (generation >= verify_gens)
verify_heap(VERIFY_POST_GC | (generation<<16));
extern int n_unboxed_instances;
@ -4662,6 +4684,7 @@ collect_garbage(generation_index_t last_gen)
/* Verify the new objects created by Lisp code. */
if (pre_verify_gen_0) verify_heap(VERIFY_PRE_GC);
// validate_brothertree(SYMBOL(CODEBLOB_TREE)->value);
if (gencgc_verbose > 1) {
print_generation_stats();

56
src/runtime/search.c
View file

@ -18,9 +18,11 @@
#include "search.h"
#include "thread.h"
#include "gc-internal.h"
#include "gc-private.h"
#include "genesis/primitive-objects.h"
#include "genesis/hash-table.h"
#include "genesis/package.h"
#include "brothertree.h"
lispobj *
search_read_only_space(void *pointer)
@ -201,3 +203,57 @@ lispobj* find_symbol(char* symbol_name, lispobj package, unsigned int* hint)
{
return package ? search_package_symbols(package, symbol_name, hint) : 0;
}
uword_t brothertree_find_lesseql(uword_t key, lispobj tree)
{
lispobj best = NIL;
while (tree != NIL) {
lispobj layout = instance_layout(INSTANCE(tree));
if (layout_depth2_id(LAYOUT(layout)) == BROTHERTREE_UNARY_NODE_LAYOUT_ID) {
tree = ((struct unary_node*)INSTANCE(tree))->child;
} else {
struct binary_node* node = (void*)INSTANCE(tree);
if (node->key == key) return tree;
lispobj l = NIL, r = NIL;
int len = ((unsigned int)node->header >> INSTANCE_LENGTH_SHIFT)
& INSTANCE_LENGTH_MASK;
// unless a fringe node, read the left and right pointers
if (len > (int)(1+INSTANCE_DATA_START)) l = node->left, r = node->right;
if (key < node->key) tree = l; else { best = tree; tree = r; }
}
}
return best;
}
#include <stdio.h>
static void validate_recurse(lispobj tree, int* n_nodes, int* n_keys)
{
if (tree == NIL) return;
lispobj layout = instance_layout(INSTANCE(tree));
++*n_nodes;
if (layout_depth2_id(LAYOUT(layout)) == BROTHERTREE_UNARY_NODE_LAYOUT_ID) {
validate_recurse(((struct unary_node*)INSTANCE(tree))->child,
n_nodes, n_keys);
} else {
++*n_keys;
struct binary_node* node = (void*)INSTANCE(tree);
lispobj key = node->key;
gc_assert(lowtag_of(key) == 0);
gc_assert(find_page_index((void*)key) >= 0);
gc_assert(widetag_of((lispobj*)key) == CODE_HEADER_WIDETAG);
lispobj l = NIL, r = NIL;
int len = ((unsigned int)node->header >> INSTANCE_LENGTH_SHIFT)
& INSTANCE_LENGTH_MASK;
// unless a fringe node, read the left and right pointers
if (len > (int)(1+INSTANCE_DATA_START)) l = node->left, r = node->right;
if (l != NIL) validate_recurse(l, n_nodes, n_keys);
if (r != NIL) validate_recurse(r, n_nodes, n_keys);
}
}
void validate_brothertree(lispobj tree) {
int n_nodes = 0, n_keys = 0;
validate_recurse(tree, &n_nodes, &n_keys);
printf("code tree: %d nodes, %d keys\n", n_nodes, n_keys);
}

38
tests/brothertree.impure.lisp
View file

@ -12,8 +12,8 @@
(n-unary-internal 0)
(n-unary-leaf 0))
(sb-int:named-let recurse ((depth 0) (node root)
(min most-negative-fixnum)
(max most-positive-fixnum))
(min -1)
(max (1+ sb-ext:most-positive-word)))
(etypecase node
(unary-node
(assert (not (unary-node-p (child node))))
@ -116,11 +116,11 @@
;(print *cases*)
nil))
(defun random-big-list (count)
(defun random-big-list (count &optional (maxval (ash 1 30)))
(let ((h (make-hash-table)))
(loop
(when (zerop count) (return (loop for k being each hash-key of h collect k)))
(let ((n (random (min most-positive-fixnum (ash 1 30)))))
(let ((n (random (min most-positive-fixnum maxval))))
(unless (gethash n h)
(setf (gethash n h) t)
(decf count))))))
@ -240,6 +240,36 @@
(assert (null tree))
))
(defun c-find<= (key tree)
(declare (sb-vm:word key))
(sb-sys:with-pinned-objects (tree)
(let ((result
(sb-alien:alien-funcall
(sb-alien:extern-alien "brothertree_find_lesseql"
(function sb-alien:unsigned sb-alien:unsigned
sb-alien:unsigned))
key
(sb-kernel:get-lisp-obj-address tree))))
(unless (eql result sb-vm:nil-value)
(sb-kernel:make-lisp-obj result)))))
(test-util:with-test (:name :find<=)
(let* ((list (test-util:shuffle (loop for i from 100 by 100 repeat 25 collect i)))
(tree (tree-from-list list)))
(assert (not (find<= 99 tree)))
(assert (not (c-find<= 99 tree)))
(loop for key from 100 by 100 repeat 25
do
(let ((node (find<= key tree)))
(assert (= (binary-node-key node) key))
(assert (eq (c-find<= key tree) node)))
(let ((node (find<= (1+ key) tree)))
(assert (= (binary-node-key node) key))
(assert (eq (c-find<= (1+ key) tree) node)))
(let ((node (find<= (+ key 99) tree)))
(assert (= (binary-node-key node) key))
(assert (eq (c-find<= (+ key 99) tree) node))))))
(test-util:with-test (:name :insert-delete)
(try-delete-everything (tree-from-list (random-big-list 2500))))

4
tests/input-manifest.lisp-expr
View file

@ -63,7 +63,9 @@
("octets.pure.lisp"
"tests/data/compile-file-pos.lisp"
"tests/data/compile-file-pos-utf16be.lisp")
("redblack.pure.lisp" "tests/bbtree-test-util.lisp")
("redblack.impure.lisp"
"tests/bbtree-test-util.lisp"
"src/code/redblack.lisp")
("run-program.impure.lisp" "contrib/sb-posix.fasl")
("sb-graph.impure.lisp" "contrib/sb-graph.fasl" "contrib/uiop.fasl")
("signals.impure.lisp" "contrib/sb-posix.fasl")

2
tests/redblack.pure.lisp → tests/redblack.impure.lisp
View file

@ -1,5 +1,7 @@
;;;; Tests
(let ((*evaluator-mode* :compile)) (load "../src/code/redblack.lisp"))
(add-package-local-nickname "REDBLACK" "SB-RBTREE.MAP")
(use-package 'sb-int)
(import 'sb-rbtree::(red black))

1
tests/run-tests.lisp
View file

@ -197,6 +197,7 @@
sb-impl::*token-buf-pool*
sb-impl::*user-hash-table-tests*
sb-impl::**finalizer-store**
sb-vm::*codeblob-tree*
,(maybe "SB-KERNEL" "*EVAL-CALLS*")
sb-kernel::*type-cache-nonce*
sb-ext:*gc-run-time*