[mcclim-cvs] CVS mcclim/Backends/CLX - mcclim-cvs@common-lisp.net - mailman3.common-lisp.net

15 Nov 2009

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX
In directory cl-net:/tmp/cvs-serv4276
Modified Files:
    medium.lisp 
Log Message:
Faster IMAGE-TO-XIMAGE translator, courtesy of Nikodemus Siivola.

--- /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp	2009/04/20 10:21:00	1.90
+++ /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp	2009/11/15 11:27:26	1.91
@@ -1311,24 +1311,36 @@
     (let ((l (integer-length (logxor mask (1- (ash 1 h))))))
       (byte (- h l) l))))
+
 ;; fixme!  This is not just incomplete, but also incorrect: The original
 ;; true color code knew how to deal with non-linear RGB value
 ;; allocation.
+
+(defvar *translator-cache-lock* (clim-sys:make-lock "translator cache lock"))
+(defvar *translator-cache* (make-hash-table :test #'equal))
+
 (defun pixel-translator (colormap)
   (unless (eq (xlib:visual-info-class (xlib:colormap-visual-info colormap))
          :true-color)
     (error "sorry, cannot draw rgb image for non-true-color drawable yet"))
-  colormap
   (let* ((info (xlib:colormap-visual-info colormap))
     (rbyte (mask->byte (xlib:visual-info-red-mask info)))
     (gbyte (mask->byte (xlib:visual-info-green-mask info)))
-	 (bbyte (mask->byte (xlib:visual-info-blue-mask info))))
-    (lambda (x y sample)
-      (declare (ignore x y))
-      (dpb (the (unsigned-byte 8) (ldb (byte 8 0) sample))
-	   rbyte
-	   (dpb (the (unsigned-byte 8) (ldb (byte 8 8) sample))
-		gbyte
-		(dpb (the (unsigned-byte 8) (ldb (byte 8 16) sample))
-		     bbyte
-		     0))))))
+	 (bbyte (mask->byte (xlib:visual-info-blue-mask info)))
+         (key (list rbyte gbyte bbyte)))
+    (clim-sys:with-lock-held (*translator-cache-lock*)
+      (or (gethash key *translator-cache*)
+          ;; COMPILE instead of a closure, because out-of-line byte specifiers
+          ;; are universally slow. Getting them inline like this is *much*
+          ;; faster.
+          (setf (gethash key *translator-cache*)
+                (compile nil
+                         `(lambda (x y sample)
+                            (declare (ignore x y))
+                            (dpb (the (unsigned-byte 8) (ldb (byte 8 0) sample))
+                                 ',rbyte
+                                 (dpb (the (unsigned-byte 8) (ldb (byte 8 8) sample))
+                                      ',gbyte
+                                      (dpb (the (unsigned-byte 8) (ldb (byte 8 16) sample))
+                                           ',bbyte
+                                           0))))))))))

    