Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

Faster IMAGE-TO-XIMAGE translator, courtesy of Nikodemus Siivola.

  • Loading branch information...
commit 748e11b17715e21f9e48b9f9f9429ffae2e9d4f1 1 parent 307f0fa
Andy Hefner authored

Showing 1 changed file with 23 additions and 11 deletions. Show diff stats Hide diff stats

  1. +23 11 Backends/CLX/medium.lisp
34 Backends/CLX/medium.lisp
@@ -1311,24 +1311,36 @@ time an indexed pattern is drawn.")
1311 1311 (let ((l (integer-length (logxor mask (1- (ash 1 h))))))
1312 1312 (byte (- h l) l))))
1313 1313
  1314 +
1314 1315 ;; fixme! This is not just incomplete, but also incorrect: The original
1315 1316 ;; true color code knew how to deal with non-linear RGB value
1316 1317 ;; allocation.
  1318 +
  1319 +(defvar *translator-cache-lock* (clim-sys:make-lock "translator cache lock"))
  1320 +(defvar *translator-cache* (make-hash-table :test #'equal))
  1321 +
1317 1322 (defun pixel-translator (colormap)
1318 1323 (unless (eq (xlib:visual-info-class (xlib:colormap-visual-info colormap))
1319 1324 :true-color)
1320 1325 (error "sorry, cannot draw rgb image for non-true-color drawable yet"))
1321   - colormap
1322 1326 (let* ((info (xlib:colormap-visual-info colormap))
1323 1327 (rbyte (mask->byte (xlib:visual-info-red-mask info)))
1324 1328 (gbyte (mask->byte (xlib:visual-info-green-mask info)))
1325   - (bbyte (mask->byte (xlib:visual-info-blue-mask info))))
1326   - (lambda (x y sample)
1327   - (declare (ignore x y))
1328   - (dpb (the (unsigned-byte 8) (ldb (byte 8 0) sample))
1329   - rbyte
1330   - (dpb (the (unsigned-byte 8) (ldb (byte 8 8) sample))
1331   - gbyte
1332   - (dpb (the (unsigned-byte 8) (ldb (byte 8 16) sample))
1333   - bbyte
1334   - 0))))))
  1329 + (bbyte (mask->byte (xlib:visual-info-blue-mask info)))
  1330 + (key (list rbyte gbyte bbyte)))
  1331 + (clim-sys:with-lock-held (*translator-cache-lock*)
  1332 + (or (gethash key *translator-cache*)
  1333 + ;; COMPILE instead of a closure, because out-of-line byte specifiers
  1334 + ;; are universally slow. Getting them inline like this is *much*
  1335 + ;; faster.
  1336 + (setf (gethash key *translator-cache*)
  1337 + (compile nil
  1338 + `(lambda (x y sample)
  1339 + (declare (ignore x y))
  1340 + (dpb (the (unsigned-byte 8) (ldb (byte 8 0) sample))
  1341 + ',rbyte
  1342 + (dpb (the (unsigned-byte 8) (ldb (byte 8 8) sample))
  1343 + ',gbyte
  1344 + (dpb (the (unsigned-byte 8) (ldb (byte 8 16) sample))
  1345 + ',bbyte
  1346 + 0))))))))))

0 comments on commit 748e11b

Please sign in to comment.
Something went wrong with that request. Please try again.