external/clem/src/mref.lisp

   1 ;;; mref.lisp
   2 ;;; macros, functions and methods for matrix element access
   3 ;;;
   4 ;;; Copyright (c) 2004-2006 Cyrus Harmon (ch-lisp@bobobeach.com)
   5 ;;; All rights reserved.
   6 ;;;
   7 ;;; Redistribution and use in source and binary forms, with or without
   8 ;;; modification, are permitted provided that the following conditions
   9 ;;; are met:
  10 ;;;
  11 ;;;   * Redistributions of source code must retain the above copyright
  12 ;;;     notice, this list of conditions and the following disclaimer.
  13 ;;;
  14 ;;;   * Redistributions in binary form must reproduce the above
  15 ;;;     copyright notice, this list of conditions and the following
  16 ;;;     disclaimer in the documentation and/or other materials
  17 ;;;     provided with the distribution.
  18 ;;;
  19 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  20 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  21 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  22 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  23 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  24 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  25 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  26 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  27 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  28 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  29 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  30 ;;;
  31
  32 (in-package :clem)
  33
  34 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  35 ;;; mref and friends
  36
  37 (defmethod mref ((m matrix) &rest indices)
  38   (apply #'aref (matrix-vals m) indices))
  39
  40 (defmethod (setf mref) (v (m matrix) &rest indices)
  41   (setf (apply #'aref (matrix-vals m) indices) v))
  42
  43 (defmethod row-major-mref ((m matrix) index)
  44   (row-major-aref (matrix-vals m) index))
  45
  46 (defmethod (setf row-major-mref) (v (m matrix) index)
  47   (setf (row-major-aref (matrix-vals m) index) v))
  48
  49 ;;; with-typed-mref establishes variables for the matrix-vals of the
  50 ;;; matrix and local macros that shadow mref and
  51 ;;; thanks to nyef, kpreid, rahul and Riastradh from #lisp for
  52 ;;; suggestions on how to make this work properly.
  53 ;;;
  54 ;;; (NOW FIXED) BIG NASTY HACK ALERT!
  55 ;;;
  56 ;;; Unfortunately, a naive implementation of with-typed-mref would
  57 ;;; rely on implementation-specific behavior of defmacro. The problem
  58 ;;; is that the environment might have dynamic extent and might not be
  59 ;;; around when we call the local mref macro, so this isn't guaranteed
  60 ;;; to work. It seems that the extent of the environment allows this
  61 ;;; to work on SBCL, but other implmenatations (or future versions of
  62 ;;; SBCL for that matter) aren't guaranteed to provide this, therefore
  63 ;;; this might break. Hopefully if it breaks it will do so in a really
  64 ;;; nasty, obvious way.
  65 ;;;
  66 ;;; it would be nice if this worked:
  67 ;;;
  68 ;; (defmacro with-typed-mref ((z element-type) &body body &environment env)
  69 ;;   (let ((vals (gensym "MATRIX-")))
  70 ;;     `(let ((,vals (matrix-vals ,z)))
  71 ;;        (declare (type (simple-array ,element-type *) ,vals))
  72 ;;        (macrolet ((mref (&whole whole mat &rest args)
  73 ;;                     (if (eql ',z mat)
  74 ;;                         `(aref ,',vals ,@args)
  75 ;;                         (macroexpand whole ,env)))
  76 ;;                   (row-major-mref (&whole whole mat &rest args)
  77 ;;                     (if (eql ',z mat)
  78 ;;                         `(row-major-aref ,',vals ,@args)
  79 ;;                         (macroexpand whole ,env))))
  80 ;;          ,@body))))
  81 ;;
  82 ;;; but we may not have access to the environment when we want to
  83 ;;; expand mref, so we need to do the following. Thanks to cmm on
  84 ;;; #lisp for the revised macro.
  85 ;;;
  86
  87 ;;; define a local symbol-macro that is initially bound to nil. This
  88 ;;; will hold an alist of matrices and their corresponding matrix-vals
  89 (define-symbol-macro .mref-expanders. nil)
  90
  91 ;;; 1. gensym a symbol to hold the result of (matrix-vals ,z)
  92 ;;; 2. declare the type of this array
  93 ;;; 3. (do a "shadowing") symbol-macrolet .mref-expanders. with the matrix and vals
  94 ;;;    consed on to the front of the list
  95 ;;; 4.
  96 (defmacro with-typed-mref ((z element-type) &body body &environment env)
  97   (let ((vals (gensym "MATRIX-VALS-")))
  98     `(let ((,vals (matrix-vals ,z)))
  99        (declare (type (simple-array ,element-type *) ,vals))
 100        (symbol-macrolet
 101            ((.mref-expanders. ,(acons z vals (macroexpand-1 '.mref-expanders. env))))
 102          (macrolet
 103              ((mref (mat &rest args &environment env)
 104                 (let ((vals (cdr (assoc mat (macroexpand-1 '.mref-expanders. env)))))
 105                   (if vals
 106                       `(aref ,vals ,@args)
 107                       `(aref (matrix-vals ,mat) ,@args))))
 108               (row-major-mref (mat &rest args &environment env)
 109                 (let ((vals (cdr (assoc mat (macroexpand-1 '.mref-expanders. env)))))
 110                   (if vals
 111                       `(row-major-aref ,vals ,@args)
 112                       `(row-major-aref (matrix-vals ,mat) ,@args)))))
 113            ,@body)))))
 114
 115 (defmacro matrix-total-size (matrix)
 116   `(array-total-size (matrix-vals ,matrix)))
 117
 118 (defmacro matrix-dimensions (matrix)
 119   `(array-dimensions (matrix-vals ,matrix)))
 120
 121
 122
 123 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 124 ;;; Old approahes to getting fast performance from matrices
 125
 126
 127 ;;; old approach 1: use with-typed-matrix-vals whereby we bind a
 128 ;;; (user-specified) local-variable to the matrix-vals of the array
 129 ;;; and the user accesses the matrix data via aref of this symbol.
 130 (defmacro with-typed-matrix-vals ((m element-type a) &body body)
 131   `(let ((,a (matrix-vals ,m)))
 132      (declare (type (simple-array ,element-type *) ,a))
 133      ,@body))
 134
 135 ;;; as an analog to with-typed-matrix-vals, we'd like to be able to
 136 ;;; use the same code for both typed and untyped matrices, therefore
 137 ;;; we define with-untyped-matrix-vals.
 138 (defmacro with-untyped-matrix-vals ((m element-type a) &body body)
 139   (declare (ignore element-type))
 140   `(let ((,a (matrix-vals ,m)))
 141      ,@body))
 142
 143 ;;; with-matrix-vals is supposed to choose between
 144 ;;; with-typed-matrix-vals and with-untyped-matrix-vals if 1) we know
 145 ;;; the type of the array and 2) it matches the element type of the
 146 ;;; matrix class.
 147 (defmacro with-matrix-vals ((m element-type a) &body body)
 148   `(if (equal ',element-type (element-type (class-of ,m)))
 149        (with-typed-matrix-vals (,m ,element-type ,a)
 150          ,@body)
 151        (with-untyped-matrix-vals (,m ,element-type ,a)
 152          ,@body)))
 153
 154 ;;; old approach 2: like with-typed-matrix-vals, but instead of
 155 ;;; specifying a symbol to hold the matrix-vals, we gensym that symbol
 156 ;;; and instead the users passes in the name of an accessor, which is
 157 ;;; then macrolet-ed to perform the aref of the gensym-ed symbol,
 158 ;;; which gets bound to the matrix-vals prior to exectuing the body.
 159 ;;;
 160 (defmacro with-typed-matrix-accessor ((m element-type ref) &body body)
 161   (let ((vals (gensym)))
 162     `(let ((,vals (matrix-vals ,m)))
 163        (declare (type (simple-array ,element-type *) ,vals))
 164        (macrolet ((,ref (&rest args)
 165                     `(aref ,',vals ,@args)))
 166          ,@body))))