From 78f21e4e36b8092d38c13526d73299d150f4f6d0 Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau Date: Fri, 28 Mar 2014 17:07:12 -0400 Subject: [PATCH] Do not trust *read-default-float-format* --- buffers/typedefs.lisp | 2 +- core/builtins.lisp | 8 +++---- cuda/target.lisp | 4 ++-- test/buffers.lisp | 42 ++++++++++++++++----------------- test/cuda-driver.lisp | 34 +++++++++++++-------------- test/translator.lisp | 54 +++++++++++++++++++++---------------------- test/utils.lisp | 41 ++++++++++++++++---------------- 7 files changed, 93 insertions(+), 92 deletions(-) diff --git a/buffers/typedefs.lisp b/buffers/typedefs.lisp index fb0eb54..99bb844 100644 --- a/buffers/typedefs.lisp +++ b/buffers/typedefs.lisp @@ -265,7 +265,7 @@ (def-native-type-info gpu-single-float-type :float "float" 4 4) (def method lisp-type-of ((type gpu-single-float-type)) - (lisp-real-type-name type 'single-float :cv (lambda (x) (float x 1.0)))) + (lisp-real-type-name type 'single-float :cv (lambda (x) (float x 1.0f0)))) (def class gpu-double-float-type (gpu-native-float-type) () diff --git a/core/builtins.lisp b/core/builtins.lisp index 25b2846..a64ac0b 100644 --- a/core/builtins.lisp +++ b/core/builtins.lisp @@ -441,7 +441,7 @@ (def delimited-builtin + "+" :zero 0) (def delimited-builtin - "-" :zero 0 :single-pfix "-") (def delimited-builtin * "*" :zero 1) -(def delimited-builtin / "/" :zero 1.0 +(def delimited-builtin / "/" :zero 1.0f0 :typechecker ensure-div-result-type :single-pfix (if (typep -ret-type- 'gpu-double-float-type) "1.0/" "1.0f/")) @@ -659,8 +659,8 @@ (mklog (gpu-single-float-type 10) (code "log10f(" arg ")")) (mklog (gpu-single-float-type 2) (code "log2f(" arg ")")) (mklog (gpu-single-float-type null) (code "logf(" arg ")")) - (mklog (gpu-single-float-type null real) (code (log (float arg 1.0)))) - (mklog (gpu-single-float-type real real) (code (log (float arg 1.0) base))) + (mklog (gpu-single-float-type null real) (code (log (float arg 1.0f0)))) + (mklog (gpu-single-float-type real real) (code (log (float arg 1.0f0) base))) ;; double (mklog (gpu-double-float-type 10) (code "log10(" arg ")")) (mklog (gpu-double-float-type 2) (code "log2(" arg ")")) @@ -686,7 +686,7 @@ (mkexp (gpu-single-float-type 10) (code "exp10f(" arg ")")) (mkexp (gpu-single-float-type 2) (code "exp2f(" arg ")")) (mkexp (gpu-single-float-type null) (code "expf(" arg ")")) - (mkexp (gpu-single-float-type real) (code "expf(" arg "*" (log (float base 1.0)) ")")) + (mkexp (gpu-single-float-type real) (code "expf(" arg "*" (log (float base 1.0f0)) ")")) (mkexp (gpu-single-float-type t) (code "powf(" base "," arg ")")) ;; double (mkexp (gpu-double-float-type 10) (code "exp10(" arg ")")) diff --git a/cuda/target.lisp b/cuda/target.lisp index e4d679e..f7bc314 100644 --- a/cuda/target.lisp +++ b/cuda/target.lisp @@ -229,7 +229,7 @@ (multiple-value-bind (arg1 rargs) (if (rest args) (values (first args) (rest args)) - (values 1.0 args)) + (values 1.0f0 args)) (code "__fdividef(" arg1 ",") (emit-separated -stream- rargs "*") (code ")")) @@ -286,7 +286,7 @@ (call-next-method))))) (mkexp (gpu-single-float-type 10) (code "__exp10f(" arg ")")) (mkexp (gpu-single-float-type null) (code "__expf(" arg ")")) - (mkexp (gpu-single-float-type real) (code "__expf(" arg "*" (log (float base 1.0)) ")")) + (mkexp (gpu-single-float-type real) (code "__expf(" arg "*" (log (float base 1.0f0)) ")")) (mkexp (gpu-single-float-type t) (code "__powf(" base "," arg ")"))) ;; Min/max builtins diff --git a/test/buffers.lisp b/test/buffers.lisp index 4e15a8d..5726a79 100644 --- a/test/buffers.lisp +++ b/test/buffers.lisp @@ -37,25 +37,25 @@ (is (equal (loop for i from 0 below 5 collect (bref buffer 1 i)) (loop for i from 0 below 5 collect (float (+ i 5))))) - (buffer-fill buffer 0.5 :start 2 :end 23) + (buffer-fill buffer 0.5f0 :start 2 :end 23) (is (index-buffer? buffer :start 0 :end 2)) (is (index-buffer? buffer :start 23)) - (is (buffer-filled? buffer 0.5 :start 2 :end 23))) + (is (buffer-filled? buffer 0.5f0 :start 2 :end 23))) (def test test/buffers/copy-array-buffer (buffer) (let ((arr1 (make-array '(5 5) :element-type 'single-float)) - (arr2 (make-array 25 :element-type 'single-float :initial-element 1.0))) + (arr2 (make-array 25 :element-type 'single-float :initial-element 1.0f0))) (buffer-fill buffer 0) (copy-full-buffer buffer arr2) (is (zero-buffer? arr2)) (set-index-buffer arr1) (copy-full-buffer arr1 buffer) (is (index-buffer? buffer)) - (buffer-fill arr2 0.5) + (buffer-fill arr2 0.5f0) (copy-buffer-data arr2 2 buffer 2 (- 23 2)) (is (index-buffer? buffer :start 0 :end 2)) (is (index-buffer? buffer :start 23)) - (is (buffer-filled? buffer 0.5 :start 2 :end 23)))) + (is (buffer-filled? buffer 0.5f0 :start 2 :end 23)))) (def test test/buffers/copy-buffer-buffer (buffer1 buffer2 buffer3 buffer4) (buffer-fill buffer1 0) @@ -82,35 +82,35 @@ (def test test/buffers/displaced-buffer (buffer1 buffer2) (let* ((arr1 (buffer-displace buffer1 :offset 5 :dimensions '(2 5))) (arr2 (buffer-displace buffer2 :offset 5 :dimensions '(2 5))) - (tmp (make-array '(5 5) :element-type 'single-float :initial-element 0.0)) + (tmp (make-array '(5 5) :element-type 'single-float :initial-element 0.0f0)) (tmp1 (buffer-displace tmp :offset 5 :dimensions '(2 5)))) (set-index-buffer buffer1) (is (index-buffer? arr1 :shift -5)) ; displaced read - (buffer-fill arr1 0.0) ; displaced fill + (buffer-fill arr1 0.0f0) ; displaced fill (is (index-buffer? buffer1 :start 0 :end 5)) - (is (buffer-filled? buffer1 0.0 :start 5 :end 15)) + (is (buffer-filled? buffer1 0.0f0 :start 5 :end 15)) (is (index-buffer? buffer1 :start 15)) (set-index-buffer arr1) ; displaced write (is (index-buffer? buffer1 :start 5 :end 15 :shift 5)) (set-index-buffer buffer2) - (buffer-fill buffer1 0.0) + (buffer-fill buffer1 0.0f0) (copy-full-buffer arr2 arr1) ; displaced dev -> dev - (is (buffer-filled? buffer1 0.0 :start 0 :end 5)) + (is (buffer-filled? buffer1 0.0f0 :start 0 :end 5)) (is (index-buffer? buffer1 :start 5 :end 15)) - (is (buffer-filled? buffer1 0.0 :start 15)) - (buffer-fill arr1 0.0) + (is (buffer-filled? buffer1 0.0f0 :start 15)) + (buffer-fill arr1 0.0f0) (is (zero-buffer? buffer1)) (set-index-buffer tmp) (copy-full-buffer tmp1 arr1) ; displaced host -> dev - (is (buffer-filled? buffer1 0.0 :start 0 :end 5)) + (is (buffer-filled? buffer1 0.0f0 :start 0 :end 5)) (is (index-buffer? buffer1 :start 5 :end 15)) - (is (buffer-filled? buffer1 0.0 :start 15)) - (buffer-fill tmp 0.0) + (is (buffer-filled? buffer1 0.0f0 :start 15)) + (buffer-fill tmp 0.0f0) (is (zero-buffer? tmp)) (copy-full-buffer arr1 tmp1) ; displaced dev -> host - (is (buffer-filled? tmp 0.0 :start 0 :end 5)) + (is (buffer-filled? tmp 0.0f0 :start 0 :end 5)) (is (index-buffer? tmp :start 5 :end 15)) - (is (buffer-filled? tmp 0.0 :start 15)))) + (is (buffer-filled? tmp 0.0f0 :start 15)))) (def test test/buffers/all (buffer1 buffer2 buffer3 buffer4) (test/buffers/basic-buffer buffer1) @@ -129,13 +129,13 @@ (def fixture foreign-arrs (with-deref-buffers ((*foreign-arr1* - (make-foreign-array '(5 5) :element-type 'single-float :initial-element 0.0)) + (make-foreign-array '(5 5) :element-type 'single-float :initial-element 0.0f0)) (*foreign-arr2* - (make-foreign-array '(5 5) :element-type 'single-float :initial-element 0.0)) + (make-foreign-array '(5 5) :element-type 'single-float :initial-element 0.0f0)) (*foreign-arr3* - (make-foreign-array 25 :element-type 'single-float :initial-element 0.0)) + (make-foreign-array 25 :element-type 'single-float :initial-element 0.0f0)) (*foreign-arr4* - (make-foreign-array 25 :element-type 'single-float :initial-element 0.0))) + (make-foreign-array 25 :element-type 'single-float :initial-element 0.0f0))) (-body-))) (def test test/buffers/foreign () diff --git a/test/cuda-driver.lisp b/test/cuda-driver.lisp index 2c924d7..849c880 100644 --- a/test/cuda-driver.lisp +++ b/test/cuda-driver.lisp @@ -27,9 +27,9 @@ (unwind-protect (progn (setf *cuda-arr1* (make-cuda-array '(5 5) :element-type 'single-float - :pitch-elt-size 4 :initial-element 0.0)) + :pitch-elt-size 4 :initial-element 0.0f0)) (setf *cuda-arr2* (make-cuda-array '(5 5) :element-type 'single-float - :pitch-elt-size 4 :initial-element 0.0)) + :pitch-elt-size 4 :initial-element 0.0f0)) (setf *cuda-arr3* (make-cuda-array '(5 5) :element-type 'single-float :pitch-elt-size 16 :initial-element 0)) (setf *cuda-arr4* (make-cuda-array '(5 5) :element-type 'single-float @@ -44,13 +44,13 @@ (def fixture cuda-host-arrs (with-deref-buffers ((*cuda-host-arr1* - (make-cuda-host-array '(5 5) :element-type 'single-float :initial-element 0.0)) + (make-cuda-host-array '(5 5) :element-type 'single-float :initial-element 0.0f0)) (*cuda-host-arr2* - (make-cuda-host-array '(5 5) :element-type 'single-float :initial-element 0.0)) + (make-cuda-host-array '(5 5) :element-type 'single-float :initial-element 0.0f0)) (*cuda-host-arr3* - (make-cuda-host-array 25 :element-type 'single-float :initial-element 0.0)) + (make-cuda-host-array 25 :element-type 'single-float :initial-element 0.0f0)) (*cuda-host-arr4* - (make-cuda-host-array 25 :element-type 'single-float :initial-element 0.0))) + (make-cuda-host-array 25 :element-type 'single-float :initial-element 0.0f0))) (-body-))) (def test verify-wrap-pitch (blk offset size commands) @@ -117,12 +117,12 @@ (baz-val (cl-gpu::gpu-global-value baz-var))) (is (eq instance instance)) ;; Initially zero - (is (eql foo-val 0.0)) + (is (eql foo-val 0.0f0)) (is (eql bar-val nil)) (is (zero-buffer? baz-val)) ;; Fill in static data - (setf foo-val 3.0) - (is (eql foo-val 3.0)) + (setf foo-val 3.0f0) + (is (eql foo-val 3.0f0)) (set-index-buffer baz-val) (is (index-buffer? baz-val)) ;; Attach an array @@ -139,7 +139,7 @@ (reinitialize-instance module) (is (not (eql old-handle (cl-gpu::cuda-module-instance-handle instance))))) ;; Verify that the values are still there - (is (eql foo-val 3.0)) + (is (eql foo-val 3.0f0)) (is (index-buffer? bar-val)) (is (index-buffer? baz-val)) ;; Verify auto-wipe @@ -149,7 +149,7 @@ (is (zero-buffer? (cl-gpu::buffer-of bar-var))))))) (declaim (type single-float *test-global-val*)) -(defparameter *test-global-val* 0.7) +(defparameter *test-global-val* 0.7f0) (def test test/cuda-driver/cuda-module-args () (with-fixture cuda-context @@ -182,11 +182,11 @@ (result (cl-gpu::gpu-global-value (aref items 3))) (ptr (cl-gpu::cuda-linear-handle (slot-value baz 'cl-gpu::blk)))) (is (zero-buffer? result)) - (funcall kernel 0.5 baz :baz baz) + (funcall kernel 0.5f0 baz :baz baz) (is (every #'= (buffer-as-array result) (list ptr 48 6 48 24 4 ptr))) - (is (= (bref baz 1 1 1) 1.2)))))) + (is (= (bref baz 1 1 1) 1.2f0)))))) (def test test/cuda-driver/compute () (with-fixture cuda-context @@ -232,12 +232,12 @@ (type (array single-float 2) avs)) (setf (aref data 0) (tuple-raw-aref avs 1 4) (aref res 1) (tuple-raw-aref avs 0 4)))) - (is (equalp (bref res 0) #(0.0 0.0 0.0 0.0))) - (is (equalp (bref res 1) #(0.0 0.0 0.0 0.0))) + (is (equalp (bref res 0) #(0.0f0 0.0f0 0.0f0 0.0f0))) + (is (equalp (bref res 1) #(0.0f0 0.0f0 0.0f0 0.0f0))) (set-index-buffer *cuda-arr1*) (kernel res *cuda-arr1*) - (is (equalp (bref res 1) #(0.0 1.0 2.0 3.0))) - (is (equalp (bref res 0) #(1.0 2.0 3.0 4.0)))))) + (is (equalp (bref res 1) #(0.0f0 1.0f0 2.0f0 3.0f0))) + (is (equalp (bref res 0) #(1.0f0 2.0f0 3.0f0 4.0f0)))))) (def function cuda-allocate-dummy-block () (make-cuda-array 10)) diff --git a/test/translator.lisp b/test/translator.lisp index c6d35c5..c8f8f77 100644 --- a/test/translator.lisp +++ b/test/translator.lisp @@ -38,7 +38,7 @@ (def function float= (a b) (ignore-errors (or (= a b) - (< (/ (abs (- a b)) (max a b)) 0.0001)))) + (< (/ (abs (- a b)) (max a b)) 1f-4)))) (defvar *last-tested-module* nil) @@ -89,14 +89,14 @@ (cast int32 (abs (the int64 -3))) (max 1) (max 4 2) (max 3 9 6) (max 1 8 2 3) (min 1) (min 4 2) (min 3 9 6) (min 1 8 2 3)) - (test-float (- 3.0) (+ 1 8.0 4) (- 2.0 7 3) (* 2.0 9 4) - (/ 5.0 2) (/ 5.0) (1+ 2.0) (1- 2.0) - (abs -3.0) (abs 3.0) - (max 1.0) (max 4.0 2) (max 3.0 9 6) (max 1.0 8 2 3) - (min 1.0) (min 4.0 2) (min 3.0 9 6) (min 1.0 8 2 3)) + (test-float (- 3.0f0) (+ 1 8.0f0 4) (- 2.0f0 7 3) (* 2.0f0 9 4) + (/ 5.0f0 2) (/ 5.0f0) (1+ 2.0f0) (1- 2.0f0) + (abs -3.0f0) (abs 3.0f0) + (max 1.0f0) (max 4.0f0 2) (max 3.0f0 9 6) (max 1.0f0 8 2 3) + (min 1.0f0) (min 4.0f0 2) (min 3.0f0 9 6) (min 1.0f0 8 2 3)) (test-bool t nil (not t) (not nil) - (zerop 0) (zerop 1) (zerop 0.0) (zerop 1.0) - (nonzerop 0) (nonzerop 1) (nonzerop 0.0) (nonzerop 1.0) + (zerop 0) (zerop 1) (zerop 0.0f0) (zerop 1.0f0) + (nonzerop 0) (nonzerop 1) (nonzerop 0.0f0) (nonzerop 1.0f0) (> 1 2) (> 2 1) (> 3 2 1) (> 3 1 2) (> 3 3 2) (>= 1 2) (>= 2 1) (>= 3 2 1) (>= 3 1 2) (>= 3 3 2) (= 1 1) (= 1 2) (= 1 1 1) (= 1 1 2) @@ -119,11 +119,11 @@ (def test test/translator/compute-3 (target) (test-computations (target) - (let ((a 12.3)) - (test-float (sin 0.39) (sinh 0.39) (asin 0.39) (asinh 1.39) - (cos 0.39) (cosh 0.39) (acos 0.39) (acosh 1.39) - (tan 0.39) (tanh 0.39) (atan 0.39) (atanh 0.39) - (exp 0.39) (sqrt 0.39) + (let ((a 12.3f0)) + (test-float (sin 0.39f0) (sinh 0.39f0) (asin 0.39f0) (asinh 1.39f0) + (cos 0.39f0) (cosh 0.39f0) (acos 0.39f0) (acosh 1.39f0) + (tan 0.39f0) (tanh 0.39f0) (atan 0.39f0) (atanh 0.39f0) + (exp 0.39f0) (sqrt 0.39f0) (log 100) (log 100 2) (log 100 10) (log 100 11) (log 100 a) (expt 2 10) (expt 10 10) (expt 11 10) (expt a 10))))) @@ -133,19 +133,19 @@ (let ((a 12)) (declare (type uint32 a)) (symbol-macrolet ((13U (the uint32 13))) - (test-float (ffloor 3.5) (ffloor -3.5) (fceiling 3.5) (fceiling -3.5) - (ftruncate 3.5) (ftruncate -3.5) (fround 3.5) (fround -3.5) - (ffloor 13.5 8) (ffloor -13.5 8) (ffloor 13.5 10) (ffloor -13.5 10) - (fceiling 13.5 8) (fceiling -13.5 8) (fceiling 13.5 10) (fceiling -13.5 10) - (ftruncate 13.5 8) (ftruncate -13.5 8) (ftruncate 13.5 10) (ftruncate -13.5 10) - (fround 13.5 8) (fround -13.5 8) (fround 13.5 10) (fround -13.5 10) - (rem 13.5 8) (rem -13.5 8) (rem 13.5 10) (rem -13.5 10)) - (test-int (floor 3.5) (floor -3.5) (ceiling 3.5) (ceiling -3.5) - (truncate 3.5) (truncate -3.5) (round 3.5) (round -3.5) - (floor 13.5 8) (floor -13.5 8) (floor 13.5 10) (floor -13.5 10) - (ceiling 13.5 8) (ceiling -13.5 8) (ceiling 13.5 10) (ceiling -13.5 10) - (truncate 13.5 8) (truncate -13.5 8) (truncate 13.5 10) (truncate -13.5 10) - (round 13.5 8) (round -13.5 8) (round 13.5 10) (round -13.5 10) + (test-float (ffloor 3.5f0) (ffloor -3.5f0) (fceiling 3.5f0) (fceiling -3.5f0) + (ftruncate 3.5f0) (ftruncate -3.5f0) (fround 3.5f0) (fround -3.5f0) + (ffloor 13.5f0 8) (ffloor -13.5f0 8) (ffloor 13.5f0 10) (ffloor -13.5f0 10) + (fceiling 13.5f0 8) (fceiling -13.5f0 8) (fceiling 13.5f0 10) (fceiling -13.5f0 10) + (ftruncate 13.5f0 8) (ftruncate -13.5f0 8) (ftruncate 13.5f0 10) (ftruncate -13.5f0 10) + (fround 13.5f0 8) (fround -13.5f0 8) (fround 13.5f0 10) (fround -13.5f0 10) + (rem 13.5f0 8) (rem -13.5f0 8) (rem 13.5f0 10) (rem -13.5f0 10)) + (test-int (floor 3.5f0) (floor -3.5f0) (ceiling 3.5f0) (ceiling -3.5f0) + (truncate 3.5f0) (truncate -3.5f0) (round 3.5f0) (round -3.5f0) + (floor 13.5f0 8) (floor -13.5f0 8) (floor 13.5f0 10) (floor -13.5f0 10) + (ceiling 13.5f0 8) (ceiling -13.5f0 8) (ceiling 13.5f0 10) (ceiling -13.5f0 10) + (truncate 13.5f0 8) (truncate -13.5f0 8) (truncate 13.5f0 10) (truncate -13.5f0 10) + (round 13.5f0 8) (round -13.5f0 8) (round 13.5f0 10) (round -13.5f0 10) (floor 13U 8) (floor -13 8) (floor 13U 10) (floor -13 10) (floor 13U a) (ceiling 13U 8) (ceiling -13 8) (ceiling 13U 10) (ceiling -13 10) (ceiling 13U a) (truncate 13U 8) (truncate -13 8) (truncate 13U 10) (truncate -13 10) (truncate 13U a) @@ -164,7 +164,7 @@ (test-int (test1 2 3) (test1 2 3 4) (test1 2 3 4 :d 5) (test1 2 3 4 :e 7) (test1 2 3 4 :e 7 :d 3) (test2 7 3) (test2 7 3 :c 9)) - (test-float (test2 0.3 0.2) (test-gpu-f 7 0.1 -2)) + (test-float (test2 0.3f0 0.2f0) (test-gpu-f 7 0.1f0 -2)) (let ((iv 0)) (test-int (test2 1 2 :z (incf iv)) (test2 1 2 :c (incf iv) :z (setf iv -3))))))) diff --git a/test/utils.lisp b/test/utils.lisp index 4a46330..6bc1550 100644 --- a/test/utils.lisp +++ b/test/utils.lisp @@ -13,26 +13,27 @@ (muffle-warning)) (def test test/utils/r-w-array () - (let ((arr (make-array 5 :element-type 'single-float - :initial-contents '(0.0 0.1 0.2 0.3 0.4)))) - (with-open-file (s "cl-gpu.test.tmp" - :direction :output - :if-exists :supersede - :element-type '(unsigned-byte 8)) - (write-array arr s)) - (let ((res (with-open-file (s "cl-gpu.test.tmp" - :direction :input - :element-type '(unsigned-byte 8)) - (read-array nil s :allocate t))) - (res2 (with-open-file (s "cl-gpu.test.tmp" - :direction :input - :element-type '(unsigned-byte 8)) - (read-array (make-array 5 :element-type 'single-float) s)))) - (delete-file "cl-gpu.test.tmp") - (is (equal (array-dimensions arr) - (array-dimensions res))) - (is (every #'eql arr res)) - (is (every #'eql arr res2))))) + (with-standard-io-syntax + (let ((arr (make-array 5 :element-type 'single-float + :initial-contents '(0.0f0 0.1f0 0.2f0 0.3f0 0.4f0)))) + (with-open-file (s "cl-gpu.test.tmp" + :direction :output + :if-exists :supersede + :element-type '(unsigned-byte 8)) + (write-array arr s)) + (let ((res (with-open-file (s "cl-gpu.test.tmp" + :direction :input + :element-type '(unsigned-byte 8)) + (read-array nil s :allocate t))) + (res2 (with-open-file (s "cl-gpu.test.tmp" + :direction :input + :element-type '(unsigned-byte 8)) + (read-array (make-array 5 :element-type 'single-float) s)))) + (delete-file "cl-gpu.test.tmp") + (is (equal (array-dimensions arr) + (array-dimensions res))) + (is (every #'eql arr res)) + (is (every #'eql arr res2)))))) (def test test/utils/copy-gvector () (let ((arr1 (make-array 5 :initial-contents '(1 2 3 4 5)))