;;; Lisplab, ref.lisp ;;; Array reference functions. ;;; Note, most other files depends on this one ! ;;; ;;; Copyright (C) 2010 Joern Inge Vestgaarden ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License along ;;; with this program; if not, write to the Free Software Foundation, Inc., ;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ;;; TODO: change name of this to something about blas store ;;; ;;; This file contains manipulations of simple double-float arrays ;;; and should be called by the spesialized matrix methods. ;;; The purpose of this layer is that it can be used by ;;; many classes such as matrix-base-dge and matrix-base-ddi, etc. ;;; ;;; The content of this file must be highly optimized ;;; and should not depend anything exept Common Lisp itself. (in-package :lisplab) (declaim (inline column-major-idx)) (declaim (ftype (function (type-blas-idx type-blas-idx type-blas-idx) type-blas-idx) column-major-idx)) (defun column-major-idx (i j rows) (truly-the type-blas-idx (+ i (truly-the type-blas-idx (* j rows))))) (defun copy-matrix-stores (a b) (let ((len (length a))) (declare (type type-blas-store a b) (type type-blas-idx len)) (dotimes (i len) (setf (aref b i) (aref a i)))) b) ;;;; The real store (declaim (inline ref-blas-real-store (setf ref-blas-real-store))) (declaim (ftype (function (type-blas-store type-blas-idx type-blas-idx type-blas-idx) double-float) ref-blas-real-store)) (defun ref-blas-real-store (store row col rows) "Matrix accessor for the real blas store" (aref (truly-the type-blas-store store) (truly-the type-blas-idx (column-major-idx (truly-the type-blas-idx row) (truly-the type-blas-idx col) rows)))) (declaim (ftype (function (double-float type-blas-store type-blas-idx type-blas-idx type-blas-idx ) double-float) (setf ref-blas-real-store))) (defun (setf ref-blas-real-store) (value store row col rows) (setf (aref (truly-the type-blas-store store) (truly-the type-blas-idx (column-major-idx (truly-the type-blas-idx row) (truly-the type-blas-idx col) rows))) value) value) ;;; The complex store (declaim (inline ref-blas-complex-store (setf ref-blas-complex-store))) (declaim (ftype (function (type-blas-store type-blas-idx type-blas-idx type-blas-idx) (complex double-float)) ref-blas-complex-store)) (defun ref-blas-complex-store (store row col rows) "Matrix accessor for the complet blas store" (let ((idx (truly-the type-blas-idx (* 2 (column-major-idx (truly-the type-blas-idx row) (truly-the type-blas-idx col) rows))))) (declare (type-blas-idx idx)) (complex (aref store idx) (aref store (1+ idx))))) (declaim (ftype (function ((complex double-float) type-blas-store type-blas-idx type-blas-idx type-blas-idx ) (complex double-float)) (setf ref-blas-complex-store))) (defun (setf ref-blas-complex-store) (value store row col rows) (let ((idx (truly-the type-blas-idx (* 2 (column-major-idx (truly-the type-blas-idx row) (truly-the type-blas-idx col) rows))))) (declare (type-blas-idx idx)) (setf (aref store idx) (realpart value) (aref store (1+ idx)) (imagpart value)) value)) (declaim (ftype (function (type-blas-store type-blas-idx) (complex double-float)) vref-blas-complex-store)) (defun vref-blas-complex-store (store idx) "Matrix accessor for the complex blas store" (let ((idx2 (truly-the type-blas-idx (* 2 idx)))) (declare (type-blas-idx idx2)) (complex (aref store idx2) (aref store (1+ idx2))))) (declaim (ftype (function ((complex double-float) type-blas-store type-blas-idx ) (complex double-float)) (setf vref-blas-complex-store))) (defun (setf vref-blas-complex-store) (value store idx) (let ((idx2 (truly-the type-blas-idx (* 2 idx)))) (declare (type-blas-idx idx2)) (setf (aref store idx2) (realpart value) (aref store (1+ idx2)) (imagpart value)) value)) ;;; Alternative references used by fft (declaim (ftype (function (type-blas-store type-blas-idx type-blas-idx type-blas-idx) (complex double-float)) ref-blas-complex-store2)) (declaim (inline ref-blas-complex-store2)) (defun ref-blas-complex-store2 (store i start step) "Accessor for the complex blas store" (declare (type-blas-idx i start step) (type-blas-store store)) (let* ((idx (truly-the type-blas-idx (* 2 (+ (truly-the type-blas-idx (* step i)) start)))) (val (complex (aref store idx) (aref store (1+ idx))))) (declare (type type-blas-idx idx) (type (complex double-float) val)) val)) (declaim (inline ref-blas-complex-store2 (setf ref-blas-complex-store2))) (declaim (ftype (function ((complex double-float) type-blas-store type-blas-idx type-blas-idx type-blas-idx ) (complex double-float)) (setf ref-blas-complex-store2))) (defun (setf ref-blas-complex-store2) (value store i start step) (declare (type-blas-idx i start step) (type-blas-store store) ((complex double-float) value) ) (let ((idx (truly-the type-blas-idx (* 2 (truly-the type-blas-idx (+ (truly-the type-blas-idx (* step i)) start)))))) (declare (type-blas-idx idx)) (setf (aref store idx) (realpart value) (aref store (1+ idx)) (imagpart value)) value)) ;;;; The idx store (declaim (inline ref-idx-store (setf ref-idx-store))) (declaim (ftype (function (type-idx-store type-blas-idx type-blas-idx type-blas-idx) type-blas-idx) ref-idx-store)) (defun ref-idx-store (store row col rows) "Matrix accessor for the UB1 store" (aref (truly-the type-idx-store store) (truly-the type-blas-idx (column-major-idx (truly-the type-blas-idx row) (truly-the type-blas-idx col) rows)))) (declaim (ftype (function (type-blas-idx type-idx-store type-blas-idx type-blas-idx type-blas-idx) type-blas-idx) (setf ref-idx-store))) (defun (setf ref-idx-store) (value store row col rows) (setf (aref (truly-the type-idx-store store) (truly-the type-blas-idx (column-major-idx (truly-the type-blas-idx row) (truly-the type-blas-idx col) rows))) value) value) ;;;; The UB1 store (declaim (inline ref-ub1-store (setf ref-ub1-store))) (declaim (ftype (function (type-ub1-store type-blas-idx type-blas-idx type-blas-idx) (unsigned-byte 1)) ref-ub1-store)) (defun ref-ub1-store (store row col rows) "Matrix accessor for the UB1 store" (aref (truly-the type-ub1-store store) (truly-the type-blas-idx (column-major-idx (truly-the type-blas-idx row) (truly-the type-blas-idx col) rows)))) (declaim (ftype (function ((unsigned-byte 1) type-ub1-store type-blas-idx type-blas-idx type-blas-idx) (unsigned-byte 1)) (setf ref-ub1-store))) (defun (setf ref-ub1-store) (value store row col rows) (setf (aref (truly-the type-ub1-store store) (truly-the type-blas-idx (column-major-idx (truly-the type-blas-idx row) (truly-the type-blas-idx col) rows))) value) value) ;;;; The UB8 store (declaim (inline ref-ub8-store (setf ref-ub8-store))) (declaim (ftype (function (type-ub8-store type-blas-idx type-blas-idx type-blas-idx) (unsigned-byte 8)) ref-ub8-store)) (defun ref-ub8-store (store row col rows) "Matrix accessor for the UB8 store" (aref (truly-the type-ub8-store store) (truly-the type-blas-idx (column-major-idx (truly-the type-blas-idx row) (truly-the type-blas-idx col) rows)))) (declaim (ftype (function ((unsigned-byte 8) type-ub8-store type-blas-idx type-blas-idx type-blas-idx) (unsigned-byte 8)) (setf ref-ub8-store))) (defun (setf ref-ub8-store) (value store row col rows) (setf (aref (truly-the type-ub8-store store) (truly-the type-blas-idx (column-major-idx (truly-the type-blas-idx row) (truly-the type-blas-idx col) rows))) value) value) ;;;; The UB16 store (declaim (inline ref-ub16-store (setf ref-ub16-store))) (declaim (ftype (function (type-ub16-store type-blas-idx type-blas-idx type-blas-idx) (unsigned-byte 16)) ref-ub16-store)) (defun ref-ub16-store (store row col rows) "Matrix accessor for the UB16 store" (aref (truly-the type-ub16-store store) (truly-the type-blas-idx (column-major-idx (truly-the type-blas-idx row) (truly-the type-blas-idx col) rows)))) (declaim (ftype (function ((unsigned-byte 16) type-ub16-store type-blas-idx type-blas-idx type-blas-idx) (unsigned-byte 16)) (setf ref-ub16-store))) (defun (setf ref-ub16-store) (value store row col rows) (setf (aref (truly-the type-ub16-store store) (truly-the type-blas-idx (column-major-idx (truly-the type-blas-idx row) (truly-the type-blas-idx col) rows))) value) value) ;;;; The UB32 store (declaim (inline ref-ub32-store (setf ref-ub32-store))) (declaim (ftype (function (type-ub32-store type-blas-idx type-blas-idx type-blas-idx) (unsigned-byte 32)) ref-ub32-store)) (defun ref-ub32-store (store row col rows) "Matrix accessor for the UB32 store" (aref (truly-the type-ub32-store store) (truly-the type-blas-idx (column-major-idx (truly-the type-blas-idx row) (truly-the type-blas-idx col) rows)))) (declaim (ftype (function ((unsigned-byte 32) type-ub32-store type-blas-idx type-blas-idx type-blas-idx) (unsigned-byte 32)) (setf ref-ub32-store))) (defun (setf ref-ub32-store) (value store row col rows) (setf (aref (truly-the type-ub32-store store) (truly-the type-blas-idx (column-major-idx (truly-the type-blas-idx row) (truly-the type-blas-idx col) rows))) value) value)