test-vector.lisp

   1 #|
   2 Copyright (c) 2005 Risto Laakso
   3 All rights reserved.
   4
   5 Redistribution and use in source and binary forms, with or without
   6 modification, are permitted provided that the following conditions
   7 are met:
   8 1. Redistributions of source code must retain the above copyright
   9    notice, this list of conditions and the following disclaimer.
  10 2. Redistributions in binary form must reproduce the above copyright
  11    notice, this list of conditions and the following disclaimer in the
  12    documentation and/or other materials provided with the distribution.
  13 3. The name of the author may not be used to endorse or promote products
  14    derived from this software without specific prior written permission.
  15
  16 THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
  17 IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
  18 OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
  19 IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
  20 INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
  21 NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
  22 DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
  23 THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
  24 (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
  25 THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  26 |#
  27 (in-package :cl-user)
  28 ;;(declaim (optimize (speed 3) (space 0) (debug 0) (safety 0)))
  29
  30 (defmacro make-vector ()
  31   `(make-array 4 :element-type 'single-float :initial-element 0f0 :adjustable nil :fill-pointer nil))
  32
  33 (defmacro make-scalar ()
  34   `(make-array 1 :element-type 'single-float :initial-element 0f0 :adjustable nil :fill-pointer nil))
  35
  36 (declaim
  37  (ftype (function ((simple-array single-float (4)) single-float) (simple-array single-float (4))) v* v2*)
  38  (ftype (function ((simple-array single-float (4)) (simple-array single-float (4))) (simple-array single-float (4))) v+ v- v2+ v2-)
  39  (ftype (function ((simple-array single-float (4)) (simple-array single-float (4))) single-float) dot dot2)
  40  (ftype (function ((simple-array single-float (4))) (simple-array single-float (4))) unitise unitise2)
  41  (ftype (function (single-float single-float single-float) (simple-array single-float (4))) vec)
  42  )
  43
  44 (declaim (inline v* v+ v- dot unitise vec v2* v2+ v2- dot2 unitise2))
  45
  46 (defun v2* (a s)
  47   (let ((res (make-vector)))
  48     (declare (type (simple-array single-float (4)) a res) (type single-float s))
  49     (loop for i from 0 to 3 do (setf (aref res i) (* (aref a i) s)))
  50     res))
  51
  52 (defun v* (a s)
  53   (let ((res (make-vector)))
  54     (sb-sys:%primitive sb-vm::%sse-vect-scalar-mul/single-float res a s)
  55   res))
  56
  57 (defun v2+ (a b)
  58   (let ((res (make-vector)))
  59     (declare (type (simple-array single-float (4)) a b res))
  60     (loop for i from 0 to 3 do (setf (aref res i) (+ (aref a i) (aref b i))))
  61     res))
  62
  63 (defun v+ (a b)
  64   (let ((res (make-vector)))
  65     (sb-sys:%primitive sb-vm::%sse-vect-add/single-float res a b)
  66     res))
  67
  68 (defun v2- (a b)
  69   (let ((res (make-vector)))
  70     (declare (type (simple-array single-float (4)) a b res))
  71     (loop for i from 0 to 3 do (setf (aref res i) (- (aref a i) (aref b i))))
  72     res))
  73
  74 (defun v- (a b)
  75   (let ((res (make-vector)))
  76     (sb-sys:%primitive sb-vm::%sse-vect-sub/single-float res a b)
  77     res))
  78
  79 (defun dot2 (a b)
  80   (declare (type (simple-array single-float (4)) a b))
  81   (loop for i from 0 to 3 sum (* (aref a i) (aref b i)) into res finally (return res)))
  82
  83 (defun dot (a b)
  84   (let ((res (make-scalar)))
  85     (sb-sys:%primitive sb-vm::%sse-vect-dot/single-float res a b)
  86     (aref res 0)))
  87
  88 (defun unitise2 (a)
  89   (v2* a (/ 1f0 (sqrt (dot2 a a)))))
  90
  91 (defun unitise (a)
  92   (let ((res (make-vector)))
  93     (sb-sys:%primitive sb-vm::%sse-vect-normalize/single-float res a)
  94     res))
  95
  96 (defun vec (x y z)
  97   (let ((res (make-vector)))
  98     (setf (aref res 0) x (aref res 1) y (aref res 2) z)
  99     res))
 100
 101 (defun test-foo2 ()
 102   (let* ((v    (v- (vec 10f0 10f0 0f0) (vec 3f0 3f0 1f0)))
 103          (b    (dot v (vec 0f0 0f0 10f0)))
 104          (disc (+ (- (* b b) (dot v v)) (* 1.5 1.5))))
 105     disc))
 106
 107 (defun test-bar4 ()
 108 ;;  (let ((x (vec (random 1f6) (random 1f6) (random 1f6)))
 109 ;;      (y (vec (random 1f6) (random 1f6) (random 1f6)))
 110 ;;      (z (vec (random 1f6) (random 1f6) (random 1f6)))
 111 ;;      (idx 0)
 112 ;;      (res (make-vector)))
 113   (let ((x (Vec 1f0 2f0 3f0))
 114         (idx 0))
 115
 116 ;;    (sb-sys:%primitive sb-vm::%store-xmm-to-array/single-float res 0
 117 ;;                     (sb-sys:%primitive sb-vm::%sse-vect-add2/single-float
 118 ;;    (the xmm (sb-sys:%primitive sb-vm::data-vector-ref/simple-array-single-float/xmm x idx))
 119 ;;                                        (sb-sys:%primitive sb-vm::data-vector-ref/simple-array-single-float/xmm y idx))
 120
 121 ;;                                        (data-vector-ref x 0)
 122 ;;                                        (data-vector-ref y 0))
 123 ;;    (sb-sys:%primitive sb-vm::%store-xmm-to-array/single-float y 0
 124 ;;    (the xmm (sb-sys:%primitive sb-vm::%load-xmm-from-array/single-float x 0))
 125 ;;                                        (sb-sys:%primitive sb-vm::%load-xmm-from-array/single-float y 0)))
 126     (the single-float (sb-sys:%primitive sb-vm::data-vector-ref/simple-array-single-float x idx))
 127
 128 ;;    (sb-sys:%primitive sb-vm::move-from-xmm
 129 ;;                     (sb-sys:%primitive sb-vm::myvop4 x))))
 130
 131 ))
 132 (defun test-bar3 (x y)
 133   (v- (v+ x y) (unitise y)))
 134
 135 (defun test-bar ()
 136   (let ((x (vec (random 1f6) (random 1f6) (random 1f6)))
 137         (y (vec (random 1f6) (random 1f6) (random 1f6)))
 138         res)
 139     (time (dotimes (i 1000000)
 140             (setf res (dot (v- (v+ x y) y) (unitise y)))))
 141     (time (dotimes (i 1000000)
 142             (setf res (dot2 (v2- (v2+ x y) y) (unitise2 y)))))
 143     res))
 144
 145
 146
 147 (defun test-foo ()
 148   (format t "~S.~%"  (unitise (vec -1.0 -3.0 2.0))))
 149
 150 (defun test-vector ()
 151   (let ((vec1 (make-vector))
 152         (vec2 (make-vector))
 153         (vec3 (make-vector))
 154         (temp (make-array 1 :element-type 'single-float :initial-element 0f0))
 155         res)
 156
 157     (loop for i of-type fixnum from 0 below 3
 158           do (setf (aref vec1 i) (float (random 1f6))
 159                    (aref vec2 i) (float (random 1f6))))
 160
 161
 162     (format t "Data: ~S~%~S~%" vec1 vec2)
 163
 164     (sb-sys:%primitive sb-vm::%sse-vect-add/single-float vec3 vec1 vec2)
 165     (format t "Add: ~S, ok? ~A~%" vec3
 166             (loop for equal = t
 167                   for res-elt across res
 168                   for idx from 0
 169                   for ok-elt = (+ (aref vec1 idx) (aref vec2 idx))
 170                   when (/= ok-elt res-elt) do (setq equal nil)
 171                   finally (return equal)))
 172
 173     (sb-sys:%primitive sb-vm::%sse-vect-normalize/single-float vec3 vec1)
 174     (sb-sys:%primitive sb-vm::%sse-vect-len/single-float temp vec3)
 175     (format t "Normalize 1: ~S, len ~S.~%" vec3 temp)
 176
 177     (sb-sys:%primitive sb-vm::%sse-vect-normalize/single-float vec3 vec2)
 178     (sb-sys:%primitive sb-vm::%sse-vect-len/single-float temp vec3)
 179     (format t "Normalize 2: ~S, len ~S.~%" vec3 temp)
 180
 181     (sb-sys:%primitive sb-vm::%sse-vect-dot/single-float temp vec1 vec2)
 182     (format t "Dot: ~S, ok? ~A.~%" temp
 183             (loop for a across vec1
 184                   for b across vec2
 185                   sum (* a b) into res
 186                   finally (return (= res (aref temp 0)))))
 187
 188     ))
 189
 190