external/clem/test/test-clem3.cl

   1
   2 ;;; I'm trying to figure out how to generalize some matrix operations
   3 ;;; using SBCL's nice fast non-consing math operations.
   4 ;;;
   5 ;;; My first (well, the previous one anyway) attempt at this involved
   6 ;;; big hairy macros for each type. I'm trying to simplify things a
   7 ;;; bit with smaller functions with proper type definitions that get
   8 ;;; called as appropriate. I still, however, run into the problem that
   9 ;;; at some point I need a declare statement to tell the compiler what
  10 ;;; type of thing I'm working with. Perhaps this is a stupid idea.  In
  11 ;;; my defense, the previous approach does work and gives me nice fast
  12 ;;; matrix math, it just involves a whole lot of compiled functions. I
  13 ;;; still think there's some merit to trying to simplify/clean this up
  14 ;;; a bit.
  15
  16 (in-package :clem-test)
  17
  18 ;;; I need *my-pacakge* so the intern statement below doesn't intern
  19 ;;; the symbol into CL-USER and I put it up here to remind myself of
  20 ;;; this fact in case I switch packages
  21 (eval-when (:compile-toplevel :load-toplevel :execute)
  22   (defparameter *my-package* :clem-test))
  23
  24 ;;; macro to define typed accessor functions
  25 (defmacro make-accessors (element-type
  26                           &optional (element-name (symbol-name element-type)))
  27   (let ((funcname (intern
  28                    (string-upcase
  29                     (concatenate 'string "mref-" element-name)) *my-package*)))
  30     `(progn
  31        (declaim (inline ,funcname))
  32        (defun ,funcname (a i j)
  33          (declare (type (simple-array ,element-type (* *)) a))
  34          (aref a i j))
  35
  36        (declaim (inline (setf ,funcname)))
  37        (defun (setf ,funcname) (v a i j)
  38          (declare (type (simple-array ,element-type (* *)) a))
  39          (setf (aref a i j) v)))))
  40
  41 ;;; local macro to call make-accessors. saves a (very) few keystrokes
  42 ;;; but makes it easier to do more to these later if necessary.
  43 (macrolet ((frob (&rest args)
  44              `(make-accessors ,@args)))
  45   (frob double-float)
  46   (frob single-float)
  47   (frob (unsigned-byte 8) "ub8")
  48   (frob (unsigned-byte 16) "ub16")
  49   (frob (unsigned-byte 32) "ub32")
  50   (frob (signed-byte 8) "sb8")
  51   (frob (signed-byte 16) "sb16")
  52   (frob (signed-byte 32) "sb32")
  53   (frob fixnum)
  54   (frob bit))
  55
  56 ;;; get the accessor functions for an array
  57 ;;; returns multiple-values the getter and the setter
  58 (defun get-accessors (a)
  59   (typecase a
  60     ((simple-array double-float (* *))
  61      (values #'mref-double-float #'(setf mref-double-float)))
  62     ((simple-array single-float (* *))
  63      (values #'mref-single-float #'(setf mref-single-float)))
  64
  65     ((simple-array (unsigned-byte 8) (* *))
  66      (values #'mref-ub8 #'(setf mref-ub8)))
  67     ((simple-array (unsigned-byte 16) (* *))
  68      (values #'mref-ub16 #'(setf mref-ub16)))
  69     ((simple-array (unsigned-byte 32) (* *))
  70      (values #'mref-ub32 #'(setf mref-ub32)))
  71
  72     ((simple-array (signed-byte 8) (* *))
  73      (values #'mref-sb8 #'(setf mref-sb8)))
  74     ((simple-array (signed-byte 16) (* *))
  75      (values #'mref-sb16 #'(setf mref-sb16)))
  76     ((simple-array (signed-byte 32) (* *))
  77      (values #'mref-sb32 #'(setf mref-sb32)))
  78
  79     ((simple-array fixnum (* *))
  80      (values #'mref-fixnum #'(setf mref-fixnum)))
  81     ((simple-array bit (* *))
  82      (values #'mref-bit #'(setf mref-bit)))))
  83
  84 ;;; test arrays
  85 (defparameter uba (make-array '(1024 1024) :element-type '(unsigned-byte 8) :initial-element 2))
  86 (defparameter dfa (make-array '(1024 1024) :element-type 'double-float :initial-element 2d0))
  87
  88 ;;; test functions to see if this works
  89
  90 ;;; the old school way - works no consing - double floats
  91 (defun array-test-1 (a)
  92   (let ((getter #'mref-double-float)
  93         (setter #'(setf mref-double-float)))
  94     (destructuring-bind (r c) (array-dimensions a)
  95       (dotimes (i r)
  96         (dotimes (j c)
  97           (funcall setter (* (funcall getter a i j) 2.0d0) a i j))))))
  98
  99 ;;; the old school way - works no consing - unsigned bytes
 100 (defun array-test-2 (a)
 101   (let ((getter #'mref-ub8)
 102         (setter #'(setf mref-ub8)))
 103     (destructuring-bind (r c) (array-dimensions a)
 104       (dotimes (i r)
 105         (dotimes (j c)
 106           (funcall setter (* (funcall getter a i j) 2) a i j))))
 107     a))
 108
 109 (defun array-test-3 (a)
 110 ;;  (declare (optimize (speed 3) (space 0)))
 111   (multiple-value-bind (getter setter) (get-accessors a)
 112 ;;    (declare (type (function ((simple-array double-float (* *)) * *) double-float) getter)
 113 ;;           (type (function (double-float (simple-array double-float (* *)) * *) double-float) setter))
 114     (destructuring-bind (r c) (array-dimensions a)
 115       (dotimes (i r)
 116         (dotimes (j c)
 117           (funcall setter (* (funcall getter a i j) 2.0d0)) a i j)))))