From a0b33ff9274b0fb682e36a42e3aa70ce5581df7c Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Tue, 25 Aug 2015 06:41:46 -0400
Subject: Optimize matrix operations.

Guile's array procedures are slow, so switch to using raw bytevectors
instead.  Additionally, converting the bytevector to a pointer is also
slow, so the pointer is now cached for redundant calls.

There's more to be done, but this was low hanging fruit.

* sly/math/transform.scm (<transform>)[ptr]: New field.
  (transform-ptr): New accessor.
  (set-transform-ptr!): New setter.
  (make-4x4-matrix): Implement using bytevectors.
  (matrix-set!, matrix-ref): New procedures.
  (make-transform, transform-vector2, transform-position): Use
  'matrix-set!' and 'matrix-ref'.
  (transpose, transform+, transform*): Use new transform constructor.
  (transform->pointer): Cache pointer.
* sly/render/context.scm (copy-transform!): Use 'bytevector-copy!'
* sly/render/shader.scm: Use 'transform->pointer' in the transform
  uniform setter.
---
 sly/math/transform.scm | 91 ++++++++++++++++++++++++++++----------------------
 sly/render/context.scm |  5 ++-
 sly/render/shader.scm  |  4 +--
 3 files changed, 57 insertions(+), 43 deletions(-)

diff --git a/sly/math/transform.scm b/sly/math/transform.scm
index 5d65e4c..31881e1 100644
--- a/sly/math/transform.scm
+++ b/sly/math/transform.scm
@@ -25,6 +25,7 @@
   #:use-module (system foreign)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-4)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-42)
   #:use-module (sly math)
@@ -35,6 +36,7 @@
             transform? transform-matrix
             transpose transform-vector2
             transform-position
+            transform->pointer
             transform+ transform* transform*!
             scale translate rotate-x rotate-y rotate-z rotate
             build-transform
@@ -42,12 +44,19 @@
             look-at))
 
 (define-record-type <transform>
-  (%make-transform matrix)
+  (%make-transform matrix ptr)
   transform?
-  (matrix transform-matrix))
+  (matrix transform-matrix)
+  (ptr transform-ptr set-transform-ptr!))
 
 (define (make-4x4-matrix)
-  (make-typed-array 'f32 0 4 4))
+  (make-f32vector 16))
+
+(define (matrix-set! matrix row column x)
+  (f32vector-set! matrix (+ (* row 4) column) x))
+
+(define (matrix-ref matrix row column)
+  (f32vector-ref matrix (+ (* row 4) column)))
 
 (define (make-transform aa ab ac ad
                         ba bb bc bd
@@ -56,26 +65,26 @@
   "Return a new transform initialized with the given 16 values in
 column-major format."
   (let ((matrix (make-4x4-matrix)))
-    (array-set! matrix aa 0 0)
-    (array-set! matrix ab 0 1)
-    (array-set! matrix ac 0 2)
-    (array-set! matrix ad 0 3)
-    (array-set! matrix ba 1 0)
-    (array-set! matrix bb 1 1)
-    (array-set! matrix bc 1 2)
-    (array-set! matrix bd 1 3)
-    (array-set! matrix ca 2 0)
-    (array-set! matrix cb 2 1)
-    (array-set! matrix cc 2 2)
-    (array-set! matrix cd 2 3)
-    (array-set! matrix da 3 0)
-    (array-set! matrix db 3 1)
-    (array-set! matrix dc 3 2)
-    (array-set! matrix dd 3 3)
-    (%make-transform matrix)))
+    (matrix-set! matrix 0 0 aa)
+    (matrix-set! matrix 0 1 ab)
+    (matrix-set! matrix 0 2 ac)
+    (matrix-set! matrix 0 3 ad)
+    (matrix-set! matrix 1 0 ba)
+    (matrix-set! matrix 1 1 bb)
+    (matrix-set! matrix 1 2 bc)
+    (matrix-set! matrix 1 3 bd)
+    (matrix-set! matrix 2 0 ca)
+    (matrix-set! matrix 2 1 cb)
+    (matrix-set! matrix 2 2 cc)
+    (matrix-set! matrix 2 3 cd)
+    (matrix-set! matrix 3 0 da)
+    (matrix-set! matrix 3 1 db)
+    (matrix-set! matrix 3 2 dc)
+    (matrix-set! matrix 3 3 dd)
+    (%make-transform matrix #f)))
 
 (define null-transform
-  (%make-transform (make-4x4-matrix)))
+  (%make-transform (make-4x4-matrix) #f))
 
 (define identity-transform
   (make-transform 1 0 0 0
@@ -88,29 +97,29 @@ column-major format."
   (let ((m1 (transform-matrix transform))
         (m2 (make-4x4-matrix)))
     (do-ec (: r 4) (: c 4)
-           (array-set! m2 (array-ref m1 r c)
-                       c r))
-    (%make-transform m2)))
+           (matrix-set! m2 c r
+                        (matrix-ref m1 r c)))
+    (%make-transform m2 #f)))
 
 (define (transform-vector2 transform v)
   "Apply TRANSFORM to the 2D vector V."
   (let ((m (transform-matrix transform))
         (x (vx v))
         (y (vy v)))
-    (vector2 (+ (* x (array-ref m 0 0))
-                (* y (array-ref m 0 1))
-                (array-ref m 0 3))
-             (+ (* x (array-ref m 1 0))
-                (* y (array-ref m 1 1))
-                (array-ref m 1 3)))))
+    (vector2 (+ (* x (matrix-ref m 0 0))
+                (* y (matrix-ref m 0 1))
+                (matrix-ref m 0 3))
+             (+ (* x (matrix-ref m 1 0))
+                (* y (matrix-ref m 1 1))
+                (matrix-ref m 1 3)))))
 
 (define (transform-position transform)
   "Return a vector3 containing the positional data stored in
 TRANSFORM."
   (let ((matrix (transform-matrix transform)))
-    (vector3 (array-ref matrix 3 0)
-             (array-ref matrix 3 1)
-             (array-ref matrix 3 2))))
+    (vector3 (matrix-ref matrix 3 0)
+             (matrix-ref matrix 3 1)
+             (matrix-ref matrix 3 2))))
 
 (define (transform+ . transforms)
   "Return the sum of TRANSFORM.  Return 'null-transform' if called
@@ -120,20 +129,24 @@ without any arguments."
           (m2 (transform-matrix b))
           (m3 (make-4x4-matrix)))
       (do-ec (: r 4) (: c 4)
-             (let ((x (+ (array-ref m1 r c)
-                         (array-ref m2 r c))))
-               (array-set! m3 x r c)))
-      (%make-transform m3)))
+             (let ((x (+ (matrix-ref m1 r c)
+                         (matrix-ref m2 r c))))
+               (matrix-set! m3 r c x)))
+      (%make-transform m3 #f)))
   (reduce add null-transform transforms))
 
 (define (transform->pointer t)
-  (bytevector->pointer (array-contents (transform-matrix t))))
+  (let ((ptr (transform-ptr t)))
+    (or ptr
+        (let ((ptr (bytevector->pointer (transform-matrix t))))
+          (set-transform-ptr! t ptr)
+          ptr))))
 
 (define (transform* . transforms)
   "Return the product of TRANSFORMS.  Return identity-transform if
 called without any arguments."
   (define (mul a b)
-    (let ((result (%make-transform (make-4x4-matrix))))
+    (let ((result (%make-transform (make-4x4-matrix) #f)))
       (transform*! result a b)
       result))
   (reduce mul identity-transform transforms))
diff --git a/sly/render/context.scm b/sly/render/context.scm
index fe16104..a83b612 100644
--- a/sly/render/context.scm
+++ b/sly/render/context.scm
@@ -22,6 +22,7 @@
 ;;; Code:
 
 (define-module (sly render context)
+  #:use-module (rnrs bytevectors)
   #:use-module (ice-9 match)
   #:use-module (ice-9 q)
   #:use-module (srfi srfi-9)
@@ -155,7 +156,9 @@
   (compose q-pop! render-context-transform-stack))
 
 (define (copy-transform! src dest)
-  (array-copy! (transform-matrix src) (transform-matrix dest)))
+  (bytevector-copy! (transform-matrix src) 0
+                    (transform-matrix dest) 0
+                    64))
 
 ;; emacs: (put 'with-transform-excursion 'scheme-indent-function 1)
 (define-syntax-rule (with-transform-excursion context body ...)
diff --git a/sly/render/shader.scm b/sly/render/shader.scm
index 9f80d2a..392ebc5 100644
--- a/sly/render/shader.scm
+++ b/sly/render/shader.scm
@@ -353,9 +353,7 @@ location."
 
 (register-uniform-setter! transform?
                           (lambda (location t)
-                            (let ((pointer
-                                   (bytevector->pointer
-                                    (array-contents (transform-matrix t)))))
+                            (let ((pointer (transform->pointer t)))
                               (glUniformMatrix4fv location 1 #f
                                                   pointer))))
 
-- 
cgit v1.2.3