Raymond Toy pushed to branch rtoy-bignum-mult-less-consing at cmucl / cmucl

Commits:

1 changed file:

Changes:

  • tests/bignum.lisp
    1 
    +;;; Tests for the bignum operations
    2 
    +
    3 
    +(defpackage :bignum-tests
    4 
    +  (:use :cl :lisp-unit))
    5 
    +
    6 
    +(in-package #:bignum-tests)
    7 
    +
    8 
    +(define-test hd-mult
    9 
    +  "Test bignum multiplier"
    10 
    +  (:tag :bignum-tests)
    11 
    +  (let ((rng (kernel::make-random-object :state (kernel:init-random-state)
    12 
    +					 :rand 0
    13 
    +					 :cached-p nil))
    14 
    +	(range (ash 1 128)))
    15 
    +    (flet ((gen-bignum (x sign)
    16 
    +	     (do ((r (random x rng) (random x rng)))
    17 
    +		 ((typep r 'bignum)
    18 
    +		  (if (zerop sign)
    19 
    +		      r
    20 
    +		      (- r))))))
    21 
    +      (dotimes (k 100)
    22 
    +	(let* ((r1 (gen-bignum range (random 2 rng)))
    23 
    +	       (r2 (gen-bignum range (random 2 rng)))
    24 
    +	       (prod-knuth (bignum::classical-multiply-bignums r1 r2))
    25 
    +	       (prod-hd (bignum::classical-multiply-bignum-hd r1 r2)))
    26 
    +	  (assert-equal prod-knuth prod-hd r1 r2))))))
    27 
    +
    28 
    +
    29 
    +;; Just for simple timing tests so we can redo the timing tests if needed.
    30 
    +#+nil
    31 
    +(define-test hd-timing
    32 
    +  "Test execution time"
    33 
    +  (:tag :bignum-tests)
    34 
    +  (let ((rng (kernel::make-random-object :state
    35 
    +					 (kernel:init-random-state)
    36 
    +					 :rand 0 :cached-p nil))
    37 
    +	(range (ash 1 128))
    38 
    +	(reps 10000))
    39 
    +    (flet ((gen-bignum (x sign)
    40 
    +	     (do ((r (random x rng) (random x rng)))
    41 
    +		 ((typep r 'bignum)
    42 
    +		  (if (zerop sign)
    43 
    +		      r (- r))))))
    44 
    +      (let* ((r1 (gen-bignum range 1))
    45 
    +	     (r2 (gen-bignum range 1)) res)
    46 
    +	(time
    47 
    +	 (dotimes (k reps)
    48 
    +	   (declare (fixnum k)) (setf res
    49 
    +				      (bignum::classical-multiply-bignums r1 r2))))
    50 
    +	(print res)
    51 
    +	(time
    52 
    +	 (dotimes (k reps)
    53 
    +	   (declare (fixnum k)) (setf res
    54 
    +				      (bignum::classical-multiply-bignum-hd r1 r2))))
    55 
    +	(print res)))))
    56 
    +

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.common-lisp.net. If you'd like to receive fewer emails, you can adjust your notification settings.