tests/private-cons.impure.lisp

   1 ;;;; Tests of gc_private_cons
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 (defun private-list (&rest items)
  15   (let ((list 0))
  16     (dolist (x (reverse items) list)
  17       (setq list
  18             (alien-funcall
  19              (extern-alien "gc_private_cons" (function unsigned unsigned unsigned))
  20              (the fixnum x)
  21              list)))))
  22
  23 (defun sapify-private-list (ptr)
  24   (sb-int:collect ((items))
  25     (loop (when (zerop ptr) (return (items)))
  26           (items (sb-sys:int-sap ptr))
  27           (setq ptr (sb-sys:sap-ref-word (sb-sys:int-sap ptr)
  28                                          sb-vm:n-word-bytes)))))
  29
  30 (defun private-free (list)
  31   (alien-funcall (extern-alien "gc_private_free" (function void unsigned))
  32                  list))
  33
  34 #+gencgc
  35 (defun test-private-consing ()
  36   (let ((conses-per-page ; subtract one for the page header cons
  37          (1- (/ sb-vm:gencgc-card-bytes (* 2 sb-vm:n-word-bytes))))
  38         (counter 0)
  39         (pages)
  40         (recycle-me))
  41     (dotimes (i 10)
  42       (let* ((cons (private-list (incf counter)))
  43              (index (sb-vm::find-page-index cons))
  44              (base-address
  45               (+ sb-vm:dynamic-space-start (* index sb-vm:gencgc-card-bytes)))
  46              (final))
  47         (push index pages)
  48         (assert (= cons (+ base-address (* 2 sb-vm:n-word-bytes))))
  49         ;; bytes-used should correspond to 2 conses,
  50         ;; and the dirty flag should be 1.
  51         (assert (= (slot (deref sb-vm::page-table index) 'sb-vm::bytes-used)
  52                    (logior (* 4 sb-vm:n-word-bytes) 1)))
  53         (dotimes (i (1- conses-per-page))
  54           (setq final (private-list (incf counter))))
  55         (assert (= final (+ base-address sb-vm:gencgc-card-bytes
  56                             (* -2 sb-vm:n-word-bytes))))
  57         (push final recycle-me)))
  58     (dolist (list recycle-me)
  59       (private-free list)) ; push each page's last cons back onto the recycle list
  60     ;; Make a list of 10 conses
  61     (let ((morelist (private-list 1 2 3 4 5 6 7 8 9 10))
  62           (pages pages))
  63       (dolist (sap (sapify-private-list morelist))
  64         ;; Should be on a page that was previously allocated
  65         (assert (= (sb-vm::find-page-index (sb-sys:sap-int sap))
  66                    (pop pages)))))
  67     (alien-funcall (extern-alien "gc_dispose_private_pages" (function void)))
  68     ;; Each of the pages should have zero bytes used and need-to-zero = 1
  69     (dolist (index pages)
  70       (assert (= (slot (deref sb-vm::page-table index) 'sb-vm::bytes-used) 1)))))
  71
  72 #-gencgc
  73 (defun test-private-consing ()
  74   (let ((conses-per-chunk ; subtract one for the chunk header cons
  75          (1- (/ 4096 (* 2 sb-vm:n-word-bytes)))) ; 4096 = CHUNKSIZE
  76         (counter 0)
  77         (chain))
  78     (dotimes (i 5) ; 5 = number of times to invoke malloc()
  79       (push nil chain)
  80       ;; Use up the chunk, which happens in descending address order.
  81       ;; So the last cons allocated is nearest the head of the chunk.
  82       (dotimes (i conses-per-chunk)
  83         (let ((list (private-list (incf counter))))
  84           (setf (car chain) list)))
  85       ;; The malloc() result was 1 cons below the lowest cons
  86       ;; return by the suballocator.
  87       (decf (car chain) (* 2 sb-vm:n-word-bytes)))
  88     ;; Test that there are 5 chunks on which to invoke free()
  89     (let ((len 0))
  90       (loop (unless chain (return))
  91             (assert (= (sb-sys:sap-ref-word (sb-sys:int-sap (car chain))
  92                                             sb-vm:n-word-bytes)
  93                        (or (cadr chain) 0)))
  94             (incf len)
  95             (pop chain))
  96       (assert (= len 5))))
  97   (alien-funcall (extern-alien "gc_dispose_private_pages" (function void))))
  98
  99 ;;; These tests disable GC because the private cons allocator
 100 ;;; assumes exclusive use of the page table, and moreover if GC
 101 ;;; were to occur, free_oldspace() could obliterate our test data.
 102 (with-test (:name :private-consing)
 103   (sb-sys:without-gcing
 104    (test-private-consing)
 105    ;; Test pushback
 106    (let* ((data '(1 2 3 4 5 6))
 107           (list (apply 'private-list data))
 108           (saps (sapify-private-list list)))
 109      (private-free list)
 110      (dolist (x data)
 111        (progn x)
 112        ;; pull items from the recycle list.
 113        (let ((cons (sb-sys:int-sap (private-list 42))))
 114          (assert (member cons saps :test 'sb-sys:sap=))
 115          (setf saps (delete cons saps :test 'sb-sys:sap=)))))
 116    ;; Clean up
 117    (alien-funcall (extern-alien "gc_dispose_private_pages" (function void)))))