tests/heapsort.impure-cload.lisp

   1
   2 ;; The debug version of my C code asserts that the guard elements
   3 ;; in the vector are not touched.
   4 (defparameter n-guard-words 4)
   5
   6 (defun effective-length (vector) (- (length vector) (* 2 n-guard-words)))
   7
   8 (defun make-test-vector (n-items)
   9   (make-array (+ n-items (* 2 n-guard-words))
  10               :element-type `(unsigned-byte ,sb-vm:n-word-bits)
  11               :initial-element 0))
  12
  13 (defun my-sort-vector (vector)
  14   (declare (type (simple-array (unsigned-byte #.sb-vm:n-word-bits) (*))
  15                  vector))
  16   (sb-sys:with-pinned-objects (vector)
  17     (alien-funcall (extern-alien "gc_heapsort_uwords"
  18                                  (function void system-area-pointer int))
  19       (sb-sys:sap+ (sb-sys:vector-sap vector)
  20                    (* n-guard-words sb-vm:n-word-bytes))
  21       (effective-length vector)))
  22   vector)
  23
  24 (defun assert-sorted (vector)
  25   (declare (type (simple-array (unsigned-byte #.sb-vm:n-word-bits) (*))
  26                  vector))
  27   (let ((n-items (effective-length vector)))
  28     (when (> n-items 1)
  29       (let ((predecessor (aref vector n-guard-words)))
  30         (loop for i from 1 below n-items
  31               for thing = (aref vector (+ n-guard-words i))
  32               do (assert (>= thing predecessor))
  33                  (setq predecessor thing))))))
  34
  35 (defun randomly-pound-on-heapsort (&key (n-iter 100)
  36                                         (min-size 0)
  37                                         (max-size 10000))
  38   (dotimes (i n-iter)
  39     (let* ((range (1+ (- max-size min-size)))
  40            (n-items (+ min-size (random range)))
  41            (vector (make-test-vector n-items)))
  42       (dotimes (i n-items)
  43         (setf (aref vector (+ i n-guard-words))
  44               (1+ (random most-positive-word)))) ; never 0
  45       (assert-sorted (my-sort-vector vector)))))
  46
  47 (defun perms (vector)
  48   (declare (vector vector))
  49   (if (= (length vector) 1)
  50       (return-from perms (list (list (elt vector 0)))))
  51   (loop for i from 0 below (length vector)
  52         for item = (elt vector i)
  53         for others = (perms (concatenate 'vector
  54                                          (subseq vector 0 i)
  55                                          (subseq vector (1+ i))))
  56         nconc (mapcar (lambda (other) (cons item other))
  57                       others)))
  58
  59 (defun fact (n)
  60   (if (= n 0)
  61       1
  62       (* n (fact (1- n)))))
  63
  64 (defun try-permutations ()
  65   (loop for n from 1 to 8
  66         for items = (subseq #(10 20 30 40 50 60 70 80) 0 n)
  67         for perms = (perms items)
  68         for vector = (make-test-vector n)
  69         do (assert (= (length perms) (fact n)))
  70            (dolist (perm (perms items))
  71              (replace vector perm :start1 n-guard-words)
  72              (assert-sorted (my-sort-vector vector)))))
  73
  74 (with-test (:name :c-heapsort-smoke-test)
  75   (try-permutations))
  76 (with-test (:name :c-heapsort-random-test)
  77   (randomly-pound-on-heapsort))