[prev in list] [next in list] [prev in thread] [next in thread] 

List:       sbcl-devel
Subject:    Re: [Sbcl-devel] [Sbcl-commits] master: Optimize XSET-UNION
From:       Stas Boukarev <stassats () gmail ! com>
Date:       2023-01-05 16:46:18
Message-ID: CAF63=133fr4LBC9TxqNo9Zpf=UncT=K9S8iPRN0Rs4tGyQL-Qw () mail ! gmail ! com
[Download RAW message or body]

On windows:
::: Running :CTYPE-CACHE
Arena @ 0000000003033040: scavenging 00000000030330e0..0000000003038050
Checking threads...
fatal error encountered in SBCL pid 1012410128:
can't find interrupt context

On Thu, Jan 5, 2023 at 3:42 AM snuglas via Sbcl-commits
<sbcl-commits@lists.sourceforge.net> wrote:
>
> The branch "master" has been updated in SBCL:
>        via  9cc99c095dc5eb184506ae5356abb86e4b46cb6e (commit)
>       from  2dd4939e27783f0b20f2836ae143e3bb5f2b1777 (commit)
>
> - Log -----------------------------------------------------------------
> commit 9cc99c095dc5eb184506ae5356abb86e4b46cb6e
> Author: Douglas Katzman <dougk@google.com>
> Date:   Wed Jan 4 14:57:54 2023 -0500
>
>     Optimize XSET-UNION
>
>     Also, ensure no arena-allocation of stable MEMBER type hashes
> ---
>  src/code/xset.lisp      | 47 ++++++++++++++++++++++++++++++----------
>  tests/arena.impure.lisp | 57 +++++++++++++++++++++++++++++++++++++++++++++++++
>  tests/xset.pure.lisp    | 24 +++++++++++++++++++++
>  3 files changed, 117 insertions(+), 11 deletions(-)
>
> diff --git a/src/code/xset.lisp b/src/code/xset.lisp
> index 260a7f3a4..5f8907fb2 100644
> --- a/src/code/xset.lisp
> +++ b/src/code/xset.lisp
> @@ -81,16 +81,6 @@
>                        (xset-data xset) table))))
>          (setf (gethash elt data) t))))
>
> -(defun xset-union (a b)
> -  (let ((xset (alloc-xset)))
> -    (map-xset (lambda (x)
> -                (add-to-xset x xset))
> -              a)
> -    (map-xset (lambda (y)
> -                (add-to-xset y xset))
> -              b)
> -    xset))
> -
>  (defun xset-member-p (elt xset)
>    (let ((data (xset-data xset)))
>      (if (if (listp data)
> @@ -110,7 +100,14 @@
>                     data)
>            members))))
>
> +;;; Possible TODO:
> +;;; INTERSECTION and UNION could allocate the new xset where the input(s)
> +;;; were, to avoid an extra copy operation.
> +;;; The reason for not always forcing to dynamic space is that I'd like
> +;;; (eventually) the compiler to able to run in an arena, with only its
> +;;; output forced to the dynamic or immmobile space.
>  (defun xset-intersection (a b)
> +  (declare (inline alloc-xset))
>    (let ((intersection (alloc-xset)))
>      ;; Under the assumption that lookup time is constant in either set,
>      ;; you should scan the * smaller * set to see if each item
> @@ -131,6 +128,33 @@
>                   source)))
>      intersection))
>
> +;;; This attempts to return A or B if one is a subset of the other.
> +(defun xset-union (a b)
> +  (declare (inline !new-xset))
> +  (binding* (((small large)
> +              (if (< (xset-count a) (xset-count b)) (values a b) (values b a)))
> +             (data (xset-data large)))
> +  ;; If one of A or B is a hash-table, then surely it's the larger. The other might be too.
> +  ;; For each key in the smaller, count the elements missing from the larger.
> +  (if (hash-table-p data)
> +      (let ((missing 0))
> +        (declare (index missing))
> +        (map-xset (lambda (x) (unless (gethash x data) (incf missing))) small)
> +        (cond ((= missing 0) large)
> +              (t
> +               ;; We have an exact count for the resulting hash-table.
> +               (let ((new (make-hash-table :size (+ (hash-table-count data) missing))))
> +                 ;; Ideally we would have a valueless hash-table so we don't store all the Ts
> +                 (map-xset (lambda (k) (setf (gethash k new) t)) small)
> +                 (maphash (lambda (k v) (setf (gethash k new) v)) data)
> +                 (!new-xset new 0)))))
> +      ;; Both A and B are lists. Share list tails since the lists are immutable.
> +      ;; Let the resulting XSET dynamically become a hash-table if it wants to.
> +      (let ((xset (!new-xset data (xset-count large))))
> +        (dolist (elt (xset-data small)) (add-to-xset elt xset))
> +        ;; if nothing was actually added, then NEW can be GCed
> +        (if (eq (xset-data xset) data) large xset)))))
> +
>  (defun xset-subset-p (xset1 xset2)
>    (when (<= (xset-count xset1) (xset-count xset2))
>      (let ((data (xset-data xset2)))
> @@ -214,7 +238,8 @@
>  (define-load-time-global *xset-stable-hashes* (make-hash-table :test 'eq))
>
>  (defun xset-generate-stable-hashes (xset &aux (hashmap *xset-stable-hashes*))
> -  #-sb-xc-host (declare (notinline sb-impl::eql-hash)) ; forward ref
> +  #-sb-xc-host (declare (notinline sb-impl::eql-hash) ; forward ref
> +                        (sb-c::tlab :system))
>    (flet ((get-stable-hash-cell (obj)
>             (let ((cell (gethash obj hashmap)))
>               (cond (cell
> diff --git a/tests/arena.impure.lisp b/tests/arena.impure.lisp
> index aa05a3624..03e09709b 100644
> --- a/tests/arena.impure.lisp
> +++ b/tests/arena.impure.lisp
> @@ -354,6 +354,8 @@
>  ;;; except that the memory is still there so we can figure out what went wrong
>  ;;; with user code. This might pass on #+-linux but has not been tested.
>  (test-util:with-test (:name :arena-use-after-free :skipped-on (:not :linux))
> +  ;; scary messages scare me
> +  (format t "::: NOTE: Expect a \"CORRUPTION WARNING\" from this test~%")
>    (hide-arena *another-arena*)
>    (let (caught)
>      (block foo
> @@ -371,6 +373,61 @@
>    (rewind-arena *another-arena*)
>    (dotimes (i 10) (f *another-arena* 1000)))
>
> +;;;; Type specifier parsing and operations
> +
> +(defparameter *bunch-of-objects*
> +  `((foo)
> +    "astring"
> +    #*1010
> +    ,(find-package "CL")
> +    ,(pathname "/tmp/blub")
> +    ,#'open
> +    #2a((1 2) (3 4))
> +    ,(ash 1 64)
> +    ))
> +
> +;; These type-specs are themselves consed so that we can
> +;; ascertain whether there are arena pointers in internalized types.
> +(defun get-bunch-of-type-specs ()
> +  `((integer ,(random 47) *)
> +    (and bignum (not (eql ,(random 1000))))
> +    (and bignum (not (eql ,(logior #x8000000000000001
> +                                   (ash (1+ (random #xF00)) 10)))))
> +    (member ,(complex (coerce (random 10) 'single-float)
> +                      (coerce (- (random 10)) 'single-float))
> +            (goo)
> +            #\thumbs_up_sign)
> +    (or stream (member #\thumbs_down_sign :hello))
> +    (array t (,(+ 10 (random 10))))))
> +
> +(defun show-cache-counts ()
> +  (dolist (s sb-impl::*cache-vector-symbols*)
> +    (let ((v (symbol-value s)))
> +      (when (vectorp v)
> +        (format t "~5d  ~a~%"
> +                (count-if (lambda (x) (not (eql x 0))) v)
> +                s)))))
> +
> +(defun ctype-operator-tests (arena &aux (result 0))
> +  (sb-int:drop-all-hash-caches)
> +  (flet ((try (spec)
> +           (dolist (x *bunch-of-objects*)
> +             (when (typep x spec)
> +               (incf result)))))
> +    (sb-vm:with-arena (arena)
> +      (let ((specs (get-bunch-of-type-specs)))
> +        (dolist (spec1 specs)
> +          (dolist (spec2 specs)
> +            (try `(and ,spec1 ,spec2))
> +            (try `(or ,spec1 ,spec2))
> +            (try `(and ,spec1 (not ,spec2)))
> +            (try `(or ,spec1 (not ,spec2))))))))
> +  (assert (null (sb-vm:c-find-heap->arena arena)))
> +  result)
> +(test-util:with-test (:name :ctype-cache)
> +  (let ((arena (sb-vm:new-arena 1048576)))
> +    (ctype-operator-tests arena)))
> +
>  ;; #+sb-devel preserves some symbols that the test doesn't care about
>  ;; as the associated function will never be called.
>  (defvar *ignore* '("!EARLY-LOAD-METHOD"))
> diff --git a/tests/xset.pure.lisp b/tests/xset.pure.lisp
> index 44eff24cf..0c68fe335 100644
> --- a/tests/xset.pure.lisp
> +++ b/tests/xset.pure.lisp
> @@ -12,3 +12,27 @@
>          (assert (sb-int:xset= a b))
>          (assert (= (sb-int:xset-elts-hash a)
>                     (sb-int:xset-elts-hash b)))))))
> +
> +(with-test (:name :xset-fast-union)
> +  (let ((s1 (sb-int:alloc-xset))
> +        (s2 (sb-int:alloc-xset)))
> +    (sb-int:add-to-xset #\a s1)
> +    (sb-int:add-to-xset #\b s1)
> +    (sb-int:add-to-xset #\c s1)
> +    (assert (eq (sb-int:xset-union s1 s2) s1))
> +    (assert (eq (sb-int:xset-union s2 s1) s1))
> +    (sb-int:add-to-xset #\b s2)
> +    (assert (eq (sb-int:xset-union s1 s2) s1))
> +    (assert (eq (sb-int:xset-union s2 s1) s1)))
> +  (let ((s1 (sb-int:alloc-xset))
> +        (s2 (sb-int:alloc-xset)))
> +    (loop for i from (char-code #\a) to (char-code #\z)
> +          do (sb-int:add-to-xset (code-char i) s1))
> +    (sb-int:add-to-xset #\x s2)
> +    (loop for i from 1 to 10
> +          do (sb-int:add-to-xset (code-char i) s1))
> +    (assert (listp (sb-kernel::xset-data s2)))
> +    (let ((union1 (sb-int:xset-union s1 s2)))
> +      (assert (= (sb-int:xset-count union1) (+ 26 10)))
> +      (let ((union2 (sb-int:xset-union s2 s1))) ; had better commute
> +        (assert (sb-int:xset= union1 union2))))))
>
> -----------------------------------------------------------------------
>
>
> hooks/post-receive
> --
> SBCL
>
>
> _______________________________________________
> Sbcl-commits mailing list
> Sbcl-commits@lists.sourceforge.net
> https://lists.sourceforge.net/lists/listinfo/sbcl-commits


_______________________________________________
Sbcl-devel mailing list
Sbcl-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/sbcl-devel
[prev in list] [next in list] [prev in thread] [next in thread]