Menu
▾
▴
matlisp-commit
|
From: Akshay S. <ak...@us...> - 2013-01-20 06:49:48
|
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "matlisp".
The branch, tensor has been updated
via 657120d7a8bc0b0e26bbb522697e75c9f5b92ec1 (commit)
from c8fdfac6f7cd8e4dd91f49bf7794a579cb8a5ffc (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 657120d7a8bc0b0e26bbb522697e75c9f5b92ec1
Author: Akshay Srinivasan <aks...@gm...>
Date: Sat Jan 19 22:44:18 2013 -0800
o Enclosed function generated functions inside eval-when.
diff --git a/src/base/standard-tensor.lisp b/src/base/standard-tensor.lisp
index 68301b2..101c7cb 100644
--- a/src/base/standard-tensor.lisp
+++ b/src/base/standard-tensor.lisp
@@ -355,7 +355,7 @@
;;Error checking
(assert (and f+ f- finv+ fid+ f* f/ finv* fid* f= store-allocator coercer coercer-unforgiving matrix vector reader value-writer reader-writer swapper))
;;
- `(progn
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
;;Class definitions
(defclass ,tensor-class (standard-tensor)
((store :type ,store-type))
diff --git a/src/level-1/axpy.lisp b/src/level-1/axpy.lisp
index b59480a..d161d97 100644
--- a/src/level-1/axpy.lisp
+++ b/src/level-1/axpy.lisp
@@ -34,41 +34,44 @@
;;Use only after checking the arguments for compatibility.
(let* ((opt (get-tensor-class-optimization-hashtable tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
- (setf (getf opt :axpy) func
- (get-tensor-class-optimization tensor-class) opt)
- `(defun ,func (alpha from to)
- (declare (type ,tensor-class from to)
- (type ,(getf opt :element-type) alpha))
- ,(let
- ((lisp-routine
- `(let ((f-sto (store from))
- (t-sto (store to)))
- (declare (type ,(linear-array-type (getf opt :store-type)) f-sto t-sto))
- (very-quickly
- (mod-dotimes (idx (dimensions from))
- with (linear-sums
- (f-of (strides from) (head from))
- (t-of (strides to) (head to)))
- do (let ((f-val (,(getf opt :reader) f-sto f-of))
- (t-val (,(getf opt :reader) t-sto t-of)))
- (declare (type ,(getf opt :element-type) f-val t-val))
- (let ((t-new (,(getf opt :f+) (,(getf opt :f*) f-val alpha) t-val)))
- (declare (type ,(getf opt :element-type) t-new))
- (,(getf opt :value-writer) t-new t-sto t-of))))))))
- (if blas-func
- `(let* ((call-fortran? (> (number-of-elements to)
- ,fortran-lb))
- (strd-p (when call-fortran? (blas-copyable-p from to))))
- (cond
- ((and call-fortran? strd-p)
- (,blas-func (number-of-elements from) alpha
- (store from) (first strd-p)
- (store to) (second strd-p)
- (head from) (head to)))
- (t
- ,lisp-routine)))
- lisp-routine))
- to)))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (let ((opt (get-tensor-class-optimization-hashtable ',tensor-class)))
+ (assert opt nil 'tensor-cannot-find-optimization :tensor-class ',tensor-class)
+ (setf (getf opt :axpy) ',func
+ (get-tensor-class-optimization ',tensor-class) opt))
+ (defun ,func (alpha from to)
+ (declare (type ,tensor-class from to)
+ (type ,(getf opt :element-type) alpha))
+ ,(let
+ ((lisp-routine
+ `(let ((f-sto (store from))
+ (t-sto (store to)))
+ (declare (type ,(linear-array-type (getf opt :store-type)) f-sto t-sto))
+ (very-quickly
+ (mod-dotimes (idx (dimensions from))
+ with (linear-sums
+ (f-of (strides from) (head from))
+ (t-of (strides to) (head to)))
+ do (let ((f-val (,(getf opt :reader) f-sto f-of))
+ (t-val (,(getf opt :reader) t-sto t-of)))
+ (declare (type ,(getf opt :element-type) f-val t-val))
+ (let ((t-new (,(getf opt :f+) (,(getf opt :f*) f-val alpha) t-val)))
+ (declare (type ,(getf opt :element-type) t-new))
+ (,(getf opt :value-writer) t-new t-sto t-of))))))))
+ (if blas-func
+ `(let* ((call-fortran? (> (number-of-elements to)
+ ,fortran-lb))
+ (strd-p (when call-fortran? (blas-copyable-p from to))))
+ (cond
+ ((and call-fortran? strd-p)
+ (,blas-func (number-of-elements from) alpha
+ (store from) (first strd-p)
+ (store to) (second strd-p)
+ (head from) (head to)))
+ (t
+ ,lisp-routine)))
+ lisp-routine))
+ to))))
(defmacro generate-typed-num-axpy! (func (tensor-class blas-func fortran-lb))
;;Be very careful when using functions generated by this macro.
@@ -77,62 +80,65 @@
;;Use only after checking the arguments for compatibility.
(let* ((opt (get-tensor-class-optimization tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
- (setf (getf opt :num-axpy) func
- (get-tensor-class-optimization tensor-class) opt)
- `(defun ,func (num-from to)
- (declare (type ,tensor-class to)
- (type ,(getf opt :element-type) num-from))
- ,(let
- ((lisp-routine
- `(let-typed
- ((t-sto (store to) :type ,(linear-array-type (getf opt :store-type))))
- (very-quickly
- (mod-dotimes (idx (dimensions to))
- with (linear-sums
- (t-of (strides to) (head to)))
- do (let-typed
- ((val (,(getf opt :reader) t-sto t-of) :type ,(getf opt :element-type)))
- (,(getf opt :value-writer) (,(getf opt :f+) num-from val) t-sto t-of)))))))
- (if blas-func
- `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
- (min-strd (when call-fortran? (consecutive-store-p to))))
- (cond
- ((and call-fortran? min-strd)
- (let ((num-array (,(getf opt :store-allocator) 1)))
- (declare (type ,(linear-array-type (getf opt :store-type)) num-array))
- (let-typed ((id (,(getf opt :fid+)) :type ,(getf opt :element-type)))
- (,(getf opt :value-writer) id num-array 0))
- (,blas-func (number-of-elements to) num-from
- num-array 0
- (store to) min-strd
- 0 (head to))))
- (t
- ,lisp-routine)))
- lisp-routine))
- to)))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (let ((opt (get-tensor-class-optimization-hashtable ',tensor-class)))
+ (assert opt nil 'tensor-cannot-find-optimization :tensor-class ',tensor-class)
+ (setf (getf opt :num-axpy) ',func
+ (get-tensor-class-optimization ',tensor-class) opt))
+ (defun ,func (num-from to)
+ (declare (type ,tensor-class to)
+ (type ,(getf opt :element-type) num-from))
+ ,(let
+ ((lisp-routine
+ `(let-typed
+ ((t-sto (store to) :type ,(linear-array-type (getf opt :store-type))))
+ (very-quickly
+ (mod-dotimes (idx (dimensions to))
+ with (linear-sums
+ (t-of (strides to) (head to)))
+ do (let-typed
+ ((val (,(getf opt :reader) t-sto t-of) :type ,(getf opt :element-type)))
+ (,(getf opt :value-writer) (,(getf opt :f+) num-from val) t-sto t-of)))))))
+ (if blas-func
+ `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
+ (min-strd (when call-fortran? (consecutive-store-p to))))
+ (cond
+ ((and call-fortran? min-strd)
+ (let ((num-array (,(getf opt :store-allocator) 1)))
+ (declare (type ,(linear-array-type (getf opt :store-type)) num-array))
+ (let-typed ((id (,(getf opt :fid+)) :type ,(getf opt :element-type)))
+ (,(getf opt :value-writer) id num-array 0))
+ (,blas-func (number-of-elements to) num-from
+ num-array 0
+ (store to) min-strd
+ 0 (head to))))
+ (t
+ ,lisp-routine)))
+ lisp-routine))
+ to))))
;;Real
(generate-typed-axpy! real-typed-axpy!
- (real-tensor daxpy *real-l1-fcall-lb*))
+ (real-tensor daxpy *real-l1-fcall-lb*))
(generate-typed-num-axpy! real-typed-num-axpy!
- (real-tensor daxpy *real-l1-fcall-lb*))
+ (real-tensor daxpy *real-l1-fcall-lb*))
;;Complex
(generate-typed-axpy! complex-typed-axpy!
- (complex-tensor zaxpy *complex-l1-fcall-lb*))
+ (complex-tensor zaxpy *complex-l1-fcall-lb*))
(generate-typed-num-axpy! complex-typed-num-axpy!
- (complex-tensor zaxpy *complex-l1-fcall-lb*))
+ (complex-tensor zaxpy *complex-l1-fcall-lb*))
;;Symbolic
#+maxima
(progn
(generate-typed-axpy! symbolic-typed-axpy!
- (symbolic-tensor nil 0))
+ (symbolic-tensor nil 0))
(generate-typed-num-axpy! symbolic-typed-num-axpy!
- (symbolic-tensor nil 0)))
+ (symbolic-tensor nil 0)))
;;---------------------------------------------------------------;;
@@ -155,8 +161,8 @@
is stored in Y and Y is returned.
")
(:method :before ((alpha number) (x standard-tensor) (y standard-tensor))
- (assert (lvec-eq (dimensions x) (dimensions y) #'=) nil
- 'tensor-dimension-mismatch))
+ (assert (lvec-eq (dimensions x) (dimensions y) #'=) nil
+ 'tensor-dimension-mismatch))
(:method ((alpha number) (x complex-tensor) (y real-tensor))
(error 'coercion-error :from 'complex-tensor :to 'real-tensor)))
@@ -209,8 +215,8 @@
X,Y must have the same dimensions.
")
(:method :before ((alpha number) (x standard-tensor) (y standard-tensor))
- (unless (lvec-eq (dimensions x) (dimensions y) #'=)
- (error 'tensor-dimension-mismatch))))
+ (unless (lvec-eq (dimensions x) (dimensions y) #'=)
+ (error 'tensor-dimension-mismatch))))
(defmethod axpy ((alpha number) (x real-tensor) (y real-tensor))
(let ((ret (if (complexp alpha)
diff --git a/src/level-1/copy.lisp b/src/level-1/copy.lisp
index bdb16fb..6680e8a 100644
--- a/src/level-1/copy.lisp
+++ b/src/level-1/copy.lisp
@@ -34,37 +34,40 @@
;;Use only after checking the arguments for compatibility.
(let* ((opt (get-tensor-class-optimization-hashtable tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
- (setf (getf opt :copy) func
- (get-tensor-class-optimization tensor-class) opt)
- `(defun ,func (from to)
- (declare (type ,tensor-class from to))
- ,(let
- ((lisp-routine
- `(let ((f-sto (store from))
- (t-sto (store to)))
- (declare (type ,(linear-array-type (getf opt :store-type)) f-sto t-sto))
- (very-quickly
- ;;Can possibly make this faster (x2) by using ,blas-func in one of
- ;;the inner loops, but this is to me messy and as of now unnecessary.
- ;;SBCL can already achieve Fortran-ish speed inside this loop.
- (mod-dotimes (idx (dimensions from))
- with (linear-sums
- (f-of (strides from) (head from))
- (t-of (strides to) (head to)))
- do (,(getf opt :reader-writer) f-sto f-of t-sto t-of))))))
- (if blas-func
- `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
- (strd-p (when call-fortran? (blas-copyable-p from to))))
- (cond
- ((and strd-p call-fortran?)
- (,blas-func (number-of-elements from)
- (store from) (first strd-p)
- (store to) (second strd-p)
- (head from) (head to)))
- (t
- ,lisp-routine)))
- lisp-routine))
- to)))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (let ((opt (get-tensor-class-optimization-hashtable ',tensor-class)))
+ (assert opt nil 'tensor-cannot-find-optimization :tensor-class ',tensor-class)
+ (setf (getf opt :copy) ',func
+ (get-tensor-class-optimization ',tensor-class) opt))
+ (defun ,func (from to)
+ (declare (type ,tensor-class from to))
+ ,(let
+ ((lisp-routine
+ `(let ((f-sto (store from))
+ (t-sto (store to)))
+ (declare (type ,(linear-array-type (getf opt :store-type)) f-sto t-sto))
+ (very-quickly
+ ;;Can possibly make this faster (x2) by using ,blas-func in one of
+ ;;the inner loops, but this is to me messy and as of now unnecessary.
+ ;;SBCL can already achieve Fortran-ish speed inside this loop.
+ (mod-dotimes (idx (dimensions from))
+ with (linear-sums
+ (f-of (strides from) (head from))
+ (t-of (strides to) (head to)))
+ do (,(getf opt :reader-writer) f-sto f-of t-sto t-of))))))
+ (if blas-func
+ `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
+ (strd-p (when call-fortran? (blas-copyable-p from to))))
+ (cond
+ ((and strd-p call-fortran?)
+ (,blas-func (number-of-elements from)
+ (store from) (first strd-p)
+ (store to) (second strd-p)
+ (head from) (head to)))
+ (t
+ ,lisp-routine)))
+ lisp-routine))
+ to))))
(defmacro generate-typed-num-copy! (func (tensor-class blas-func fortran-lb))
;;Be very careful when using functions generated by this macro.
@@ -73,59 +76,62 @@
;;Use only after checking the arguments for compatibility.
(let* ((opt (get-tensor-class-optimization-hashtable tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
- (setf (getf opt :num-copy) func
- (get-tensor-class-optimization tensor-class) opt)
- `(defun ,func (num-from to)
- (declare (type ,tensor-class to)
- (type ,(getf opt :element-type) num-from))
- ,(let
- ((lisp-routine
- `(let-typed
- ((t-sto (store to) :type ,(linear-array-type (getf opt :store-type))))
- (very-quickly
- (mod-dotimes (idx (dimensions to))
- with (linear-sums
- (t-of (strides to) (head to)))
- do (,(getf opt :value-writer) num-from t-sto t-of))))))
- (if blas-func
- `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
- (min-stride (when call-fortran? (consecutive-store-p to))))
- (cond
- ((and call-fortran? min-stride)
- (let ((num-array (,(getf opt :store-allocator) 1)))
- (declare (type ,(linear-array-type (getf opt :store-type)) num-array))
- (,(getf opt :value-writer) num-from num-array 0)
- (,blas-func (number-of-elements to)
- num-array 0
- (store to) min-stride
- 0 (head to))))
- (t
- ,lisp-routine)))
- lisp-routine))
- to)))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (let ((opt (get-tensor-class-optimization-hashtable ',tensor-class)))
+ (assert opt nil 'tensor-cannot-find-optimization :tensor-class ',tensor-class)
+ (setf (getf opt :num-copy) ',func
+ (get-tensor-class-optimization ',tensor-class) opt))
+ (defun ,func (num-from to)
+ (declare (type ,tensor-class to)
+ (type ,(getf opt :element-type) num-from))
+ ,(let
+ ((lisp-routine
+ `(let-typed
+ ((t-sto (store to) :type ,(linear-array-type (getf opt :store-type))))
+ (very-quickly
+ (mod-dotimes (idx (dimensions to))
+ with (linear-sums
+ (t-of (strides to) (head to)))
+ do (,(getf opt :value-writer) num-from t-sto t-of))))))
+ (if blas-func
+ `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
+ (min-stride (when call-fortran? (consecutive-store-p to))))
+ (cond
+ ((and call-fortran? min-stride)
+ (let ((num-array (,(getf opt :store-allocator) 1)))
+ (declare (type ,(linear-array-type (getf opt :store-type)) num-array))
+ (,(getf opt :value-writer) num-from num-array 0)
+ (,blas-func (number-of-elements to)
+ num-array 0
+ (store to) min-stride
+ 0 (head to))))
+ (t
+ ,lisp-routine)))
+ lisp-routine))
+ to))))
;;Real
(generate-typed-copy! real-typed-copy!
- (real-tensor dcopy *real-l1-fcall-lb*))
+ (real-tensor dcopy *real-l1-fcall-lb*))
(generate-typed-num-copy! real-typed-num-copy!
- (real-tensor dcopy *real-l1-fcall-lb*))
+ (real-tensor dcopy *real-l1-fcall-lb*))
;;Complex
(generate-typed-copy! complex-typed-copy!
- (complex-tensor zcopy *complex-l1-fcall-lb*))
+ (complex-tensor zcopy *complex-l1-fcall-lb*))
(generate-typed-num-copy! complex-typed-num-copy!
- (complex-tensor zcopy *complex-l1-fcall-lb*))
+ (complex-tensor zcopy *complex-l1-fcall-lb*))
;;Symbolic
#+maxima
(progn
-(generate-typed-copy! symbolic-typed-copy!
- (symbolic-tensor nil 0))
+ (generate-typed-copy! symbolic-typed-copy!
+ (symbolic-tensor nil 0))
-(generate-typed-num-copy! symbolic-typed-num-copy!
- (symbolic-tensor nil 0)))
+ (generate-typed-num-copy! symbolic-typed-num-copy!
+ (symbolic-tensor nil 0)))
;;---------------------------------------------------------------;;
;;Generic function defined in src;base;generic-copy.lisp
@@ -174,7 +180,7 @@
;; Copy between a Lisp array and a tensor
(defun convert-to-lisp-array (tensor)
-"
+ "
Syntax
======
(convert-to-lisp-array tensor)
@@ -189,11 +195,11 @@
(ret (make-array (lvec->list dims)
:element-type (or (getf (get-tensor-object-optimization tensor) :element-type)
(error 'tensor-cannot-find-optimization :tensor-class (class-name (class-of tensor)))))))
- (let ((lst (make-list (rank tensor))))
- (very-quickly
- (mod-dotimes (idx dims)
- do (setf (apply #'aref ret (lvec->list! idx lst)) (tensor-ref tensor idx))))
- ret)))
+ (let ((lst (make-list (rank tensor))))
+ (very-quickly
+ (mod-dotimes (idx dims)
+ do (setf (apply #'aref ret (lvec->list! idx lst)) (tensor-ref tensor idx))))
+ ret)))
(defmethod copy! :before ((x standard-tensor) (y array))
(assert (subtypep (getf (get-tensor-object-optimization x) :element-type)
@@ -210,21 +216,21 @@
(defmethod copy! ((x real-tensor) (y array))
(let-typed ((sto-x (store x) :type real-store-vector)
(lst (make-list (rank x)) :type cons))
- (mod-dotimes (idx (dimensions x))
- with (linear-sums
- (of-x (strides x) (head x)))
- do (setf (apply #'aref y (lvec->list! idx lst))
- (aref sto-x of-x))))
+ (mod-dotimes (idx (dimensions x))
+ with (linear-sums
+ (of-x (strides x) (head x)))
+ do (setf (apply #'aref y (lvec->list! idx lst))
+ (aref sto-x of-x))))
y)
(defmethod copy! ((x complex-tensor) (y array))
(let-typed ((sto-x (store x) :type complex-store-vector)
(lst (make-list (rank x)) :type cons))
- (mod-dotimes (idx (dimensions x))
- with (linear-sums
- (of-x (strides x) (head x)))
- do (setf (apply #'aref y (lvec->list! idx lst))
- (complex (aref sto-x (* 2 of-x)) (aref sto-x (1+ (* 2 of-x)))))))
+ (mod-dotimes (idx (dimensions x))
+ with (linear-sums
+ (of-x (strides x) (head x)))
+ do (setf (apply #'aref y (lvec->list! idx lst))
+ (complex (aref sto-x (* 2 of-x)) (aref sto-x (1+ (* 2 of-x)))))))
y)
;;
@@ -242,23 +248,23 @@
(defmethod copy! ((x array) (y real-tensor))
(let-typed ((sto-y (store y) :type real-store-vector)
(lst (make-list (array-rank x)) :type cons))
- (very-quickly
- (mod-dotimes (idx (dimensions y))
- with (linear-sums
- (of-y (strides y) (head y)))
- do (setf (aref sto-y of-y) (apply #'aref x (lvec->list! idx lst))))))
+ (very-quickly
+ (mod-dotimes (idx (dimensions y))
+ with (linear-sums
+ (of-y (strides y) (head y)))
+ do (setf (aref sto-y of-y) (apply #'aref x (lvec->list! idx lst))))))
y)
(defmethod copy! ((x array) (y complex-tensor))
(let-typed ((sto-y (store y) :type real-store-vector)
(lst (make-list (array-rank x)) :type cons))
- (very-quickly
- (mod-dotimes (idx (dimensions y))
- with (linear-sums
- (of-y (strides y) (head y)))
- do (let-typed ((ele (apply #'aref x (lvec->list! idx lst)) :type complex-type))
- (setf (aref sto-y (* 2 of-y)) (realpart ele)
- (aref sto-y (1+ (* 2 of-y))) (imagpart ele))))))
+ (very-quickly
+ (mod-dotimes (idx (dimensions y))
+ with (linear-sums
+ (of-y (strides y) (head y)))
+ do (let-typed ((ele (apply #'aref x (lvec->list! idx lst)) :type complex-type))
+ (setf (aref sto-y (* 2 of-y)) (realpart ele)
+ (aref sto-y (1+ (* 2 of-y))) (imagpart ele))))))
y)
;;
diff --git a/src/level-1/dot.lisp b/src/level-1/dot.lisp
index c3d571f..435cff1 100644
--- a/src/level-1/dot.lisp
+++ b/src/level-1/dot.lisp
@@ -34,22 +34,27 @@
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
(setf (getf opt :dot) func
(get-tensor-class-optimization tensor-class) opt)
- `(defun ,func (x y conjugate-p)
- (declare (type ,tensor-class x y)
- ,(if conj?
- `(type boolean conjugate-p)
- `(ignore conjugate-p)))
- ,(let
- ((lisp-routine
- `(let-typed
- ((stp-x (aref (strides x) 0) :type index-type)
- (sto-x (store x) :type ,(linear-array-type (getf opt :store-type)))
- (stp-y (aref (strides y) 0) :type index-type)
- (sto-y (store y) :type ,(linear-array-type (getf opt :store-type)))
- (nele (number-of-elements x) :type index-type))
- ,(labels ((main-loop (conjp)
- `(very-quickly
- (loop :repeat nele
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (let ((opt (get-tensor-class-optimization-hashtable ',tensor-class)))
+ (assert opt nil 'tensor-cannot-find-optimization :tensor-class ',tensor-class)
+ (setf (getf opt :axpy) ',func
+ (get-tensor-class-optimization ',tensor-class) opt))
+ (defun ,func (x y conjugate-p)
+ (declare (type ,tensor-class x y)
+ ,(if conj?
+ `(type boolean conjugate-p)
+ `(ignore conjugate-p)))
+ ,(let
+ ((lisp-routine
+ `(let-typed
+ ((stp-x (aref (strides x) 0) :type index-type)
+ (sto-x (store x) :type ,(linear-array-type (getf opt :store-type)))
+ (stp-y (aref (strides y) 0) :type index-type)
+ (sto-y (store y) :type ,(linear-array-type (getf opt :store-type)))
+ (nele (number-of-elements x) :type index-type))
+ ,(labels ((main-loop (conjp)
+ `(very-quickly
+ (loop :repeat nele
:for of-x :of-type index-type = (head x) :then (+ of-x stp-x)
:for of-y :of-type index-type = (head y) :then (+ of-y stp-y)
:with dot :of-type ,(getf opt :element-type) = (,(getf opt :fid+))
@@ -64,42 +69,42 @@
,(main-loop t)
,(main-loop nil))
(main-loop nil))))))
- (if blas?
- `(let ((call-fortran? (> (number-of-elements x)
- ,fortran-lb)))
- (cond
- (call-fortran?
- ,(recursive-append
- (when conj?
- `(if conjugate-p
- (,blasc-func (number-of-elements x)
- (store x) (aref (strides x) 0)
- (store y) (aref (strides y) 0)
- (head x) (head y))))
- `(,blas-func (number-of-elements x)
- (store x) (aref (strides x) 0)
- (store y) (aref (strides y) 0)
- (head x) (head y))))
- (t
- ,lisp-routine)))
- lisp-routine)))))
+ (if blas?
+ `(let ((call-fortran? (> (number-of-elements x)
+ ,fortran-lb)))
+ (cond
+ (call-fortran?
+ ,(recursive-append
+ (when conj?
+ `(if conjugate-p
+ (,blasc-func (number-of-elements x)
+ (store x) (aref (strides x) 0)
+ (store y) (aref (strides y) 0)
+ (head x) (head y))))
+ `(,blas-func (number-of-elements x)
+ (store x) (aref (strides x) 0)
+ (store y) (aref (strides y) 0)
+ (head x) (head y))))
+ (t
+ ,lisp-routine)))
+ lisp-routine))))))
(generate-typed-dot real-typed-dot
- (real-tensor ddot nil *real-l1-fcall-lb*))
+ (real-tensor ddot nil *real-l1-fcall-lb*))
(generate-typed-dot complex-typed-dot
- (complex-tensor zdotu zdotc *complex-l1-fcall-lb*))
+ (complex-tensor zdotu zdotc *complex-l1-fcall-lb*))
#+maxima
(generate-typed-dot symbolic-typed-dot
- (symbolic-tensor nil nil 0))
+ (symbolic-tensor nil nil 0))
;;---------------------------------------------------------------;;
-
-
+
+
(defgeneric dot (x y &optional conjugate-p)
(:documentation
-"
+ "
Sytnax
======
(DOT x y [conjugate-p])
@@ -130,9 +135,9 @@
otherwise.
")
(:method :before ((x standard-vector) (y standard-vector) &optional (conjugate-p t))
- (declare (ignore conjugate-p))
- (unless (lvec-eq (dimensions x) (dimensions y) #'=)
- (error 'tensor-dimension-mismatch))))
+ (declare (ignore conjugate-p))
+ (unless (lvec-eq (dimensions x) (dimensions y) #'=)
+ (error 'tensor-dimension-mismatch))))
(defmethod dot ((x number) (y number) &optional (conjugate-p t))
(if conjugate-p
@@ -181,16 +186,16 @@
(let ((dot-name (gensym (string+ (symbol-name classn) "-dot-"))))
(compile-and-eval
`(generate-typed-dot ,dot-name
- (,classn nil nil 0)))
+ (,classn nil nil 0)))
dot-name))))
(compile-and-eval
`(defmethod dot ((x ,classn) (y ,classn) &optional (conjugate-p t))
,@(unless (get classn :fconj)
- `((declare (ignore conjugate-p))))
+ `((declare (ignore conjugate-p))))
,(if (get classn :fconj)
`(,dot-func x y conjugate-p)
`(,dot-func x y t))))
- ;;Call method
+ ;;Call method
(dot x y conjugate-p)))
((coercable? (class-name xcl) (class-name ycl))
...)
diff --git a/src/level-1/realimag.lisp b/src/level-1/realimag.lisp
index 52cea96..b38569c 100644
--- a/src/level-1/realimag.lisp
+++ b/src/level-1/realimag.lisp
@@ -29,7 +29,7 @@
(in-package #:matlisp)
(definline tensor-realpart~ (tensor)
-"
+ "
Syntax
======
(tensor-realpart~ tensor)
@@ -51,7 +51,7 @@
(number (realpart tensor))))
(definline tensor-imagpart~ (tensor)
-"
+ "
Syntax
======
(tensor-imagpart~ tensor)
@@ -73,7 +73,7 @@
(number (imagpart tensor))))
(definline tensor-realpart (tensor)
-"
+ "
Syntax
======
(tensor-realpart tensor)
@@ -89,7 +89,7 @@
(copy (tensor-realpart~ tensor)))
(definline tensor-imagpart (tensor)
-"
+ "
Syntax
======
(tensor-imagpart matrix)
diff --git a/src/level-1/scal.lisp b/src/level-1/scal.lisp
index 6013a9c..ad2749d 100644
--- a/src/level-1/scal.lisp
+++ b/src/level-1/scal.lisp
@@ -31,147 +31,159 @@
(defmacro generate-typed-scal! (func (tensor-class fortran-func fortran-lb))
(let* ((opt (get-tensor-class-optimization-hashtable tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
- (setf (getf opt :scal) func
- (get-tensor-class-optimization tensor-class) opt)
- `(defun ,func (from to)
- (declare (type ,tensor-class from to))
- ,(let
- ((lisp-routine
- `(let ((f-sto (store from))
- (t-sto (store to)))
- (declare (type ,(linear-array-type (getf opt :store-type)) f-sto t-sto))
- (very-quickly
- (mod-dotimes (idx (dimensions from))
- with (linear-sums
- (f-of (strides from) (head from))
- (t-of (strides to) (head to)))
- do (let*-typed ((val-f (,(getf opt :reader) f-sto f-of) :type ,(getf opt :element-type))
- (val-t (,(getf opt :reader) t-sto t-of) :type ,(getf opt :element-type))
- (mul (,(getf opt :f*) val-f val-t) :type ,(getf opt :element-type)))
- (,(getf opt :value-writer) mul t-sto t-of)))))))
- (if fortran-func
- `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
- (strd-p (when call-fortran? (blas-copyable-p from to))))
- (cond
- ((and strd-p call-fortran?)
- (,fortran-func (number-of-elements from)
- (store from) (first strd-p)
- (store to) (second strd-p)
- (head from) (head to)))
- (t
- ,lisp-routine)))
- lisp-routine))
- to)))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (let ((opt (get-tensor-class-optimization-hashtable ',tensor-class)))
+ (assert opt nil 'tensor-cannot-find-optimization :tensor-class ',tensor-class)
+ (setf (getf opt :scal) ',func
+ (get-tensor-class-optimization ',tensor-class) opt))
+ (defun ,func (from to)
+ (declare (type ,tensor-class from to))
+ ,(let
+ ((lisp-routine
+ `(let ((f-sto (store from))
+ (t-sto (store to)))
+ (declare (type ,(linear-array-type (getf opt :store-type)) f-sto t-sto))
+ (very-quickly
+ (mod-dotimes (idx (dimensions from))
+ with (linear-sums
+ (f-of (strides from) (head from))
+ (t-of (strides to) (head to)))
+ do (let*-typed ((val-f (,(getf opt :reader) f-sto f-of) :type ,(getf opt :element-type))
+ (val-t (,(getf opt :reader) t-sto t-of) :type ,(getf opt :element-type))
+ (mul (,(getf opt :f*) val-f val-t) :type ,(getf opt :element-type)))
+ (,(getf opt :value-writer) mul t-sto t-of)))))))
+ (if fortran-func
+ `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
+ (strd-p (when call-fortran? (blas-copyable-p from to))))
+ (cond
+ ((and strd-p call-fortran?)
+ (,fortran-func (number-of-elements from)
+ (store from) (first strd-p)
+ (store to) (second strd-p)
+ (head from) (head to)))
+ (t
+ ,lisp-routine)))
+ lisp-routine))
+ to))))
(defmacro generate-typed-num-scal! (func (tensor-class blas-func fortran-lb))
(let ((opt (get-tensor-class-optimization-hashtable tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
- (setf (getf opt :num-scal) func
- (get-tensor-class-optimization tensor-class) opt)
- `(defun ,func (alpha to)
- (declare (type ,tensor-class to)
- (type ,(getf opt :element-type) alpha))
- ,(let
- ((lisp-routine
- `(let ((t-sto (store to)))
- (declare (type ,(linear-array-type (getf opt :store-type)) t-sto))
- (very-quickly
- (mod-dotimes (idx (dimensions to))
- with (linear-sums
- (t-of (strides to) (head to)))
- do (let ((scal-val (,(getf opt :f*) (,(getf opt :reader) t-sto t-of) alpha)))
- (,(getf opt :value-writer) scal-val t-sto t-of)))))))
- (if blas-func
- `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
- (min-stride (when call-fortran? (consecutive-store-p to))))
- (cond
- ((and call-fortran? min-stride)
- (,blas-func (number-of-elements to) alpha (store to) min-stride (head to)))
- (t
- ,lisp-routine)))
- lisp-routine))
- to)))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (let ((opt (get-tensor-class-optimization-hashtable ',tensor-class)))
+ (assert opt nil 'tensor-cannot-find-optimization :tensor-class ',tensor-class)
+ (setf (getf opt :num-scal) ',func
+ (get-tensor-class-optimization ',tensor-class) opt))
+ (defun ,func (alpha to)
+ (declare (type ,tensor-class to)
+ (type ,(getf opt :element-type) alpha))
+ ,(let
+ ((lisp-routine
+ `(let ((t-sto (store to)))
+ (declare (type ,(linear-array-type (getf opt :store-type)) t-sto))
+ (very-quickly
+ (mod-dotimes (idx (dimensions to))
+ with (linear-sums
+ (t-of (strides to) (head to)))
+ do (let ((scal-val (,(getf opt :f*) (,(getf opt :reader) t-sto t-of) alpha)))
+ (,(getf opt :value-writer) scal-val t-sto t-of)))))))
+ (if blas-func
+ `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
+ (min-stride (when call-fortran? (consecutive-store-p to))))
+ (cond
+ ((and call-fortran? min-stride)
+ (,blas-func (number-of-elements to) alpha (store to) min-stride (head to)))
+ (t
+ ,lisp-routine)))
+ lisp-routine))
+ to))))
(defmacro generate-typed-div! (func (tensor-class fortran-func fortran-lb))
(let* ((opt (get-tensor-class-optimization-hashtable tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
- (setf (getf opt :div) func
- (get-tensor-class-optimization tensor-class) opt)
- `(defun ,func (from to)
- (declare (type ,tensor-class from to))
- ,(let
- ((lisp-routine
- `(let ((f-sto (store from))
- (t-sto (store to)))
- (declare (type ,(linear-array-type (getf opt :store-type)) f-sto t-sto))
- (very-quickly
- (mod-dotimes (idx (dimensions from))
- with (linear-sums
- (f-of (strides from) (head from))
- (t-of (strides to) (head to)))
- do (let*-typed ((val-f (,(getf opt :reader) f-sto f-of) :type ,(getf opt :element-type))
- (val-t (,(getf opt :reader) t-sto t-of) :type ,(getf opt :element-type))
- (mul (,(getf opt :f/) val-f val-t) :type ,(getf opt :element-type)))
- (,(getf opt :value-writer) mul t-sto t-of)))))))
- (if fortran-func
- `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
- (strd-p (when call-fortran? (blas-copyable-p from to))))
- (cond
- ((and strd-p call-fortran?)
- (,fortran-func (number-of-elements from)
- (store from) (first strd-p)
- (store to) (second strd-p)
- (head from) (head to)))
- (t
- ,lisp-routine)))
- lisp-routine))
- to)))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (let ((opt (get-tensor-class-optimization-hashtable ',tensor-class)))
+ (assert opt nil 'tensor-cannot-find-optimization :tensor-class ',tensor-class)
+ (setf (getf opt :div) ',func
+ (get-tensor-class-optimization ',tensor-class) opt))
+ (defun ,func (from to)
+ (declare (type ,tensor-class from to))
+ ,(let
+ ((lisp-routine
+ `(let ((f-sto (store from))
+ (t-sto (store to)))
+ (declare (type ,(linear-array-type (getf opt :store-type)) f-sto t-sto))
+ (very-quickly
+ (mod-dotimes (idx (dimensions from))
+ with (linear-sums
+ (f-of (strides from) (head from))
+ (t-of (strides to) (head to)))
+ do (let*-typed ((val-f (,(getf opt :reader) f-sto f-of) :type ,(getf opt :element-type))
+ (val-t (,(getf opt :reader) t-sto t-of) :type ,(getf opt :element-type))
+ (mul (,(getf opt :f/) val-f val-t) :type ,(getf opt :element-type)))
+ (,(getf opt :value-writer) mul t-sto t-of)))))))
+ (if fortran-func
+ `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
+ (strd-p (when call-fortran? (blas-copyable-p from to))))
+ (cond
+ ((and strd-p call-fortran?)
+ (,fortran-func (number-of-elements from)
+ (store from) (first strd-p)
+ (store to) (second strd-p)
+ (head from) (head to)))
+ (t
+ ,lisp-routine)))
+ lisp-routine))
+ to))))
(defmacro generate-typed-num-div! (func (tensor-class fortran-func fortran-lb))
(let ((opt (get-tensor-class-optimization tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
- (setf (getf opt :num-div) func
- (get-tensor-class-optimization tensor-class) opt)
- `(defun ,func (alpha to)
- (declare (type ,tensor-class to)
- (type ,(getf opt :element-type) alpha))
- ,(let
- ((lisp-routine
- `(let ((t-sto (store to)))
- (declare (type ,(linear-array-type (getf opt :store-type)) t-sto))
- (very-quickly
- (mod-dotimes (idx (dimensions to))
- with (linear-sums
- (t-of (strides to) (head to)))
- do (let-typed ((scal-val (,(getf opt :f/) alpha (,(getf opt :reader) t-sto t-of)) :type ,(getf opt :element-type)))
- (,(getf opt :value-writer) scal-val t-sto t-of)))))))
- (if fortran-func
- `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
- (min-stride (when call-fortran? (consecutive-store-p to))))
- (cond
- ((and call-fortran? min-stride)
- (let ((num-array (,(getf opt :store-allocator) 1)))
- (declare (type ,(linear-array-type (getf opt :store-type)) num-array))
- (let-typed ((id (,(getf opt :fid*)) :type ,(getf opt :element-type)))
- (,(getf opt :value-writer) id num-array 0))
- (,fortran-func (number-of-elements to) num-array 0 (store to) min-stride (head to))))
- (t
- ,lisp-routine)))
- lisp-routine))
- to)))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (let ((opt (get-tensor-class-optimization-hashtable ',tensor-class)))
+ (assert opt nil 'tensor-cannot-find-optimization :tensor-class ',tensor-class)
+ (setf (getf opt :num-div) ',func
+ (get-tensor-class-optimization ',tensor-class) opt))
+ (defun ,func (alpha to)
+ (declare (type ,tensor-class to)
+ (type ,(getf opt :element-type) alpha))
+ ,(let
+ ((lisp-routine
+ `(let ((t-sto (store to)))
+ (declare (type ,(linear-array-type (getf opt :store-type)) t-sto))
+ (very-quickly
+ (mod-dotimes (idx (dimensions to))
+ with (linear-sums
+ (t-of (strides to) (head to)))
+ do (let-typed ((scal-val (,(getf opt :f/) alpha (,(getf opt :reader) t-sto t-of)) :type ,(getf opt :element-type)))
+ (,(getf opt :value-writer) scal-val t-sto t-of)))))))
+ (if fortran-func
+ `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
+ (min-stride (when call-fortran? (consecutive-store-p to))))
+ (cond
+ ((and call-fortran? min-stride)
+ (let ((num-array (,(getf opt :store-allocator) 1)))
+ (declare (type ,(linear-array-type (getf opt :store-type)) num-array))
+ (let-typed ((id (,(getf opt :fid*)) :type ,(getf opt :element-type)))
+ (,(getf opt :value-writer) id num-array 0))
+ (,fortran-func (number-of-elements to) num-array 0 (store to) min-stride (head to))))
+ (t
+ ,lisp-routine)))
+ lisp-routine))
+ to))))
;;Real
(generate-typed-num-scal! real-typed-num-scal!
- (real-tensor dscal *real-l1-fcall-lb*))
+ (real-tensor dscal *real-l1-fcall-lb*))
(generate-typed-scal! real-typed-scal!
- (real-tensor descal *real-l1-fcall-lb*))
+ (real-tensor descal *real-l1-fcall-lb*))
(generate-typed-div! real-typed-div!
- (real-tensor dediv *real-l1-fcall-lb*))
+ (real-tensor dediv *real-l1-fcall-lb*))
(generate-typed-num-div! real-typed-num-div!
- (real-tensor dediv *real-l1-fcall-lb*))
+ (real-tensor dediv *real-l1-fcall-lb*))
;;Complex
(definline zordscal (nele alpha x incx &optional hd-x)
@@ -180,36 +192,36 @@
(zscal nele alpha x incx hd-x)))
(generate-typed-num-scal! complex-typed-num-scal!
- (complex-tensor zordscal *complex-l1-fcall-lb*))
+ (complex-tensor zordscal *complex-l1-fcall-lb*))
(generate-typed-scal! complex-typed-scal!
- (complex-tensor zescal *complex-l1-fcall-lb*))
+ (complex-tensor zescal *complex-l1-fcall-lb*))
(generate-typed-div! complex-typed-div!
- (complex-tensor zediv *complex-l1-fcall-lb*))
+ (complex-tensor zediv *complex-l1-fcall-lb*))
(generate-typed-num-div! complex-typed-num-div!
- (complex-tensor zediv *complex-l1-fcall-lb*))
+ (complex-tensor zediv *complex-l1-fcall-lb*))
;;Symbolic
#+maxima
(progn
(generate-typed-num-scal! symbolic-typed-num-scal!
- (symbolic-tensor nil 0))
+ (symbolic-tensor nil 0))
(generate-typed-scal! symbolic-typed-scal!
- (symbolic-tensor nil 0))
+ (symbolic-tensor nil 0))
(generate-typed-div! symbolic-typed-div!
- (symbolic-tensor nil 0))
+ (symbolic-tensor nil 0))
(generate-typed-num-div! symbolic-typed-num-div!
- (symbolic-tensor nil 0)))
+ (symbolic-tensor nil 0)))
;;---------------------------------------------------------------;;
(defgeneric scal! (alpha x)
(:documentation
-"
+ "
Syntax
======
(SCAL! alpha x)
@@ -219,8 +231,8 @@
X <- alpha .* X
")
(:method :before ((x standard-tensor) (y standard-tensor))
- (assert (lvec-eq (dimensions x) (dimensions y) #'=) nil
- 'tensor-dimension-mismatch)))
+ (assert (lvec-eq (dimensions x) (dimensions y) #'=) nil
+ 'tensor-dimension-mismatch)))
(defmethod scal! ((alpha number) (x real-tensor))
(real-typed-num-scal! (coerce-real alpha) x))
@@ -253,8 +265,8 @@
X <- alpha ./ X
")
(:method :before ((x standard-tensor) (y standard-tensor))
- (assert (lvec-eq (dimensions x) (dimensions y) #'=) nil
- 'tensor-dimension-mismatch)))
+ (assert (lvec-eq (dimensions x) (dimensions y) #'=) nil
+ 'tensor-dimension-mismatch)))
(defmethod div! ((alpha number) (x real-tensor))
(real-typed-num-div! (coerce-real alpha) x))
@@ -276,7 +288,7 @@
;;
(defgeneric scal (alpha x)
(:documentation
-"
+ "
Syntax
======
(SCAL alpha x)
diff --git a/src/level-1/swap.lisp b/src/level-1/swap.lisp
index dd8b05d..9464bc8 100644
--- a/src/level-1/swap.lisp
+++ b/src/level-1/swap.lisp
@@ -34,41 +34,44 @@
;;Use only after checking the arguments for compatibility.
(let* ((opt (get-tensor-class-optimization-hashtable tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
- (setf (getf opt :swap) func
- (get-tensor-class-optimization tensor-class) opt)
- `(defun ,func (x y)
- (declare (type ,tensor-class x y))
- ,(let
- ((lisp-routine
- `(let ((f-sto (store x))
- (t-sto (store y)))
- (declare (type ,(linear-array-type (getf opt :store-type)) f-sto t-sto))
- (very-quickly
- (mod-dotimes (idx (dimensions x))
- with (linear-sums
- (f-of (strides x) (head x))
- (t-of (strides y) (head y)))
- do (,(getf opt :swapper) f-sto f-of t-sto t-of))))))
- (if blas-func
- `(let* ((call-fortran? (> (number-of-elements x) ,fortran-lb))
- (strd-p (when call-fortran? (blas-copyable-p x y))))
- (cond
- ((and strd-p call-fortran?)
- (,blas-func (number-of-elements x) (store x) (first strd-p) (store y) (second strd-p) (head x) (head y)))
- (t
- ,lisp-routine)))
- lisp-routine))
- y)))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (let ((opt (get-tensor-class-optimization-hashtable ',tensor-class)))
+ (assert opt nil 'tensor-cannot-find-optimization :tensor-class ',tensor-class)
+ (setf (getf opt :swap) ',func
+ (get-tensor-class-optimization ',tensor-class) opt))
+ (defun ,func (x y)
+ (declare (type ,tensor-class x y))
+ ,(let
+ ((lisp-routine
+ `(let ((f-sto (store x))
+ (t-sto (store y)))
+ (declare (type ,(linear-array-type (getf opt :store-type)) f-sto t-sto))
+ (very-quickly
+ (mod-dotimes (idx (dimensions x))
+ with (linear-sums
+ (f-of (strides x) (head x))
+ (t-of (strides y) (head y)))
+ do (,(getf opt :swapper) f-sto f-of t-sto t-of))))))
+ (if blas-func
+ `(let* ((call-fortran? (> (number-of-elements x) ,fortran-lb))
+ (strd-p (when call-fortran? (blas-copyable-p x y))))
+ (cond
+ ((and strd-p call-fortran?)
+ (,blas-func (number-of-elements x) (store x) (first strd-p) (store y) (second strd-p) (head x) (head y)))
+ (t
+ ,lisp-routine)))
+ lisp-routine))
+ y))))
(generate-typed-swap! real-typed-swap!
- (real-tensor dswap *real-l1-fcall-lb*))
+ (real-tensor dswap *real-l1-fcall-lb*))
(generate-typed-swap! complex-typed-swap!
- (complex-tensor zswap *complex-l1-fcall-lb*))
+ (complex-tensor zswap *complex-l1-fcall-lb*))
#+maxima
(generate-typed-swap! symbolic-typed-swap!
- (symbolic-tensor nil 0))
+ (symbolic-tensor nil 0))
;;---------------------------------------------------------------;;
;;Generic function in src;base;generic-swap.lisp
diff --git a/src/level-1/tensor-maker.lisp b/src/level-1/tensor-maker.lisp
index a6fa87b..5961798 100644
--- a/src/level-1/tensor-maker.lisp
+++ b/src/level-1/tensor-maker.lisp
@@ -3,50 +3,53 @@
(defmacro make-tensor-maker (func-name (tensor-class))
(let ((opt (get-tensor-class-optimization-hashtable tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
- (setf (getf opt :maker) func-name
- (get-tensor-class-optimization tensor-class) opt)
- `(defun ,func-name (&rest args)
- (labels ((make-dims (dims)
- (declare (type cons dims))
- (let*-typed ((vdim (make-index-store dims) :type index-store-vector)
- (ss (very-quickly (lvec-foldl #'(lambda (x y) (the index-type (* x y))) vdim)))
- (store (,(getf opt :store-allocator) ss))
- (rnk (length vdim)))
- (make-instance (case rnk (2 ',(getf opt :matrix)) (1 ',(getf opt :vector)) (t ',tensor-class))
- :store store :store-size ss :dimensions vdim)))
- (make-from-array (arr)
- (declare (type (array * *) arr))
- (let* ((ret (make-dims (array-dimensions arr)))
- (st-r (store ret))
- (lst (make-list (rank ret))))
- (declare (type ,tensor-class ret)
- (type ,(linear-array-type (getf opt :store-type)) st-r))
- (mod-dotimes (idx (dimensions ret))
- with (linear-sums
- (of-r (strides ret) (head ret)))
- do (,(getf opt :value-writer) (,(getf opt :coercer) (apply #'aref arr (lvec->list! idx lst))) st-r of-r))
- ret))
- (make-from-list (lst)
- (let* ((ret (make-dims (list-dimensions lst)))
- (st-r (store ret)))
- (declare (type ,tensor-class ret)
- (type ,(linear-array-type (getf opt :store-type)) st-r))
- (list-loop (idx ele lst)
- with (linear-sums
- (of-r (strides ret) (head ret)))
- do (,(getf opt :value-writer) (,(getf opt :coercer) ele) st-r of-r))
- ret)))
- (let ((largs (length args)))
- (if (= largs 1)
- (etypecase (first args)
- (array
- (make-from-array (first args)))
- (cons
- (make-from-list (first args)))
- (integer
- (make-dims (list (first args)))))
- (make-dims args)))))))
-
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (let ((opt (get-tensor-class-optimization-hashtable ',tensor-class)))
+ (assert opt nil 'tensor-cannot-find-optimization :tensor-class ',tensor-class)
+ (setf (getf opt :maker) ',func-name
+ (get-tensor-class-optimization ',tensor-class) opt))
+ (defun ,func-name (&rest args)
+ (labels ((make-dims (dims)
+ (declare (type cons dims))
+ (let*-typed ((vdim (make-index-store dims) :type index-store-vector)
+ (ss (very-quickly (lvec-foldl #'(lambda (x y) (the index-type (* x y))) vdim)))
+ (store (,(getf opt :store-allocator) ss))
+ (rnk (length vdim)))
+ (make-instance (case rnk (2 ',(getf opt :matrix)) (1 ',(getf opt :vector)) (t ',tensor-class))
+ :store store :store-size ss :dimensions vdim)))
+ (make-from-array (arr)
+ (declare (type (array * *) arr))
+ (let* ((ret (make-dims (array-dimensions arr)))
+ (st-r (store ret))
+ (lst (make-list (rank ret))))
+ (declare (type ,tensor-class ret)
+ (type ,(linear-array-type (getf opt :store-type)) st-r))
+ (mod-dotimes (idx (dimensions ret))
+ with (linear-sums
+ (of-r (strides ret) (head ret)))
+ do (,(getf opt :value-writer) (,(getf opt :coercer) (apply #'aref arr (lvec->list! idx lst))) st-r of-r))
+ ret))
+ (make-from-list (lst)
+ (let* ((ret (make-dims (list-dimensions lst)))
+ (st-r (store ret)))
+ (declare (type ,tensor-class ret)
+ (type ,(linear-array-type (getf opt :store-type)) st-r))
+ (list-loop (idx ele lst)
+ with (linear-sums
+ (of-r (strides ret) (head ret)))
+ do (,(getf opt :value-writer) (,(getf opt :coercer) ele) st-r of-r))
+ ret)))
+ (let ((largs (length args)))
+ (if (= largs 1)
+ (etypecase (first args)
+ (array
+ (make-from-array (first args)))
+ (cons
+ (make-from-list (first args)))
+ (integer
+ (make-dims (list (first args)))))
+ (make-dims args))))))))
+
(make-tensor-maker make-real-tensor (real-tensor))
(make-tensor-maker make-complex-tensor (complex-tensor))
diff --git a/src/level-1/trans.lisp b/src/level-1/trans.lisp
index b0de83a..b1c0e00 100644
--- a/src/level-1/trans.lisp
+++ b/src/level-1/trans.lisp
@@ -54,8 +54,8 @@
(let-typed ((rnk (rank A) :type index-type)
(dim-A (dimensions A) :type index-store-vector)
(strd-A (strides A) :type index-store-vector))
- (rotatef (aref dim-A (1- rnk)) (aref dim-A 0))
- (rotatef (aref strd-A (1- rnk)) (aref strd-A 0))))
+ (rotatef (aref dim-A (1- rnk)) (aref dim-A 0))
+ (rotatef (aref strd-A (1- rnk)) (aref strd-A 0))))
A)
(definline (setf transpose!) (value A &optional permutation)
@@ -81,9 +81,9 @@
(copy! value (TRANSPOSE~ tensor permutation))"
(declare (type standard-tensor A))
(let ((displaced (make-instance (class-of A) :store (store A)
- :dimensions (copy-seq (dimensions A))
- :strides (copy-seq (strides A))
- :parent-tensor A)))
+ :dimensions (copy-seq (dimensions A))
+ :strides (copy-seq (strides A))
+ :parent-tensor A)))
(transpose! displaced permutation)))
(definline (setf transpose~) (value A &optional permutation)
@@ -158,7 +158,7 @@
;;
(defun htranspose! (A &optional permutation)
-"
+ "
Syntax
======
(HTRANSPOSE! A [permutation])
@@ -186,7 +186,7 @@
(htranspose! A permutation))
(definline htranspose (A &optional permutation)
-"
+ "
Syntax
======
(HTRANSPOSE A [permutation])
diff --git a/src/level-2/gemv.lisp b/src/level-2/gemv.lisp
index 07631af..727e89b 100644
--- a/src/level-2/gemv.lisp
+++ b/src/level-2/gemv.lisp
@@ -10,74 +10,77 @@
(error 'tensor-cannot-find-optimization :tensor-class tensor-class)))
(matrix-class (getf opt :matrix))
(vector-class (getf opt :vector)))
- (setf (getf opt :gemv) func
- (get-tensor-class-optimization tensor-class) opt)
- `(defun ,func (alpha A x beta y job)
- (declare (type ,(getf opt :element-type) alpha beta)
- (type ,matrix-class A)
- (type ,vector-class x y)
- (type symbol job))
- ,(let
- ((lisp-routine
- `(let-typed ((nr-A (nrows A) :type index-type)
- (nc-A (ncols A) :type index-type)
- (rs-A (row-stride A) :type index-type)
- (cs-A (col-stride A) :type index-type)
- (sto-A (store A) :type ,(linear-array-type (getf opt :store-type)))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (let ((opt (get-tensor-class-optimization-hashtable ',tensor-class)))
+ (assert opt nil 'tensor-cannot-find-optimization :tensor-class ',tensor-class)
+ (setf (getf opt :gemv) ',func
+ (get-tensor-class-optimization ',tensor-class) opt))
+ (defun ,func (alpha A x beta y job)
+ (declare (type ,(getf opt :element-type) alpha beta)
+ (type ,matrix-class A)
+ (type ,vector-class x y)
+ (type symbol job))
+ ,(let
+ ((lisp-routine
+ `(let-typed ((nr-A (nrows A) :type index-type)
+ (nc-A (ncols A) :type index-type)
+ (rs-A (row-stride A) :type index-type)
+ (cs-A (col-stride A) :type index-type)
+ (sto-A (store A) :type ,(linear-array-type (getf opt :store-type)))
;
- (stp-x (aref (strides x) 0) :type index-type)
- (sto-x (store x) :type ,(linear-array-type (getf opt :store-type)))
- (hd-x (head x) :type index-type)
+ (stp-x (aref (strides x) 0) :type index-type)
+ (sto-x (store x) :type ,(linear-array-type (getf opt :store-type)))
+ (hd-x (head x) :type index-type)
;
- (stp-y (aref (strides y) 0) :type index-type)
- (sto-y (store y) :type ,(linear-array-type (getf opt :store-type))))
- (when (eq job :t)
- (rotatef nr-A nc-A)
- (rotatef rs-A cs-A))
- (very-quickly
- (loop :repeat nr-A
- :for of-y :of-type index-type := (head y) :then (+ of-y stp-y)
- :for rof-A :of-type index-type := (head A) :then (+ rof-A rs-A)
- :do (let-typed ((val (,(getf opt :f*) beta (,(getf opt :reader) sto-y of-y)) :type ,(getf opt :element-type)))
- (loop :repeat nc-A
- :for of-x :of-type index-type := hd-x :then (+ of-x stp-x)
- :for of-A :of-type index-type := rof-A :then (+ of-A cs-A)
- :with dot :of-type ,(getf opt :element-type) = (,(getf opt :fid+))
- :do (let-typed ((xval (,(getf opt :reader) sto-x of-x) :type ,(getf opt :element-type))
- (Aval (,(getf opt :reader) sto-A of-A) :type ,(getf opt :element-type)))
- (setf dot (,(getf opt :f+) dot (,(getf opt :f*) xval Aval))))
- :finally (,(getf opt :value-writer) (,(getf opt :f+) (,(getf opt :f*) alpha dot) val) sto-y of-y))))))))
- (if blas-gemv-func
- `(mlet*
- ((call-fortran? (> (max (nrows A) (ncols A)) ,fortran-call-lb))
- ((maj-A ld-A fop-A) (if call-fortran? (blas-matrix-compatible-p A job) (values nil 0 "?")) :type (symbol index-type (string 1))))
- (cond
- ((and maj-a call-fortran?)
- (let-typed ((nr-A (nrows A) :type index-type)
- (nc-A (ncols A) :type index-type))
- (when (eq maj-A :row-major)
- (rotatef nr-A nc-A))
- (,blas-gemv-func fop-a nr-A nc-A
- alpha (store A) ld-A
- (store x) (aref (strides x) 0)
- beta
- (store y) (aref (strides y) 0)
- (head A) (head x) (head y))))
- (t
- ,lisp-routine)))
- lisp-routine))
- y)))
+ (stp-y (aref (strides y) 0) :type index-type)
+ (sto-y (store y) :type ,(linear-array-type (getf opt :store-type))))
+ (when (eq job :t)
+ (rotatef nr-A nc-A)
+ (rotatef rs-A cs-A))
+ (very-quickly
+ (loop :repeat nr-A
+ :for of-y :of-type index-type := (head y) :then (+ of-y stp-y)
+ :for rof-A :of-type index-type := (head A) :then (+ rof-A rs-A)
+ :do (let-typed ((val (,(getf opt :f*) beta (,(getf opt :reader) sto-y of-y)) :type ,(getf opt :element-type)))
+ (loop :repeat nc-A
+ :for of-x :of-type index-type := hd-x :then (+ of-x stp-x)
+ :for of-A :of-type index-type := rof-A :then (+ of-A cs-A)
+ :with dot :of-type ,(getf opt :element-type) = (,(getf opt :fid+))
+ :do (let-typed ((xval (,(getf opt :reader) sto-x of-x) :type ,(getf opt :element-type))
+ (Aval (,(getf opt :reader) sto-A of-A) :type ,(getf opt :element-type)))
+ (setf dot (,(getf opt :f+) dot (,(getf opt :f*) xval Aval))))
+ :finally (,(getf opt :value-writer) (,(getf opt :f+) (,(getf opt :f*) alpha dot) val) sto-y of-y))))))))
+ (if blas-gemv-func
+ `(mlet*
+ ((call-fortran? (> (max (nrows A) (ncols A)) ,fortran-call-lb))
+ ((maj-A ld-A fop-A) (if call-fortran? (blas-matrix-compatible-p A job) (values nil 0 "?")) :type (symbol index-type (string 1))))
+ (cond
+ ((and maj-a call-fortran?)
+ (let-typed ((nr-A (nrows A) :type index-type)
+ (nc-A (ncols A) :type index-type))
+ (when (eq maj-A :row-major)
+ (rotatef nr-A nc-A))
+ (,blas-gemv-func fop-a nr-A nc-A
+ alpha (store A) ld-A
+ (store x) (aref (strides x) 0)
+ beta
+ (store y) (aref (strides y) 0)
+ (head A) (head x) (head y))))
+ (t
+ ,lisp-routine)))
+ lisp-routine))
+ y))))
;;Real
(generate-typed-gemv! real-base-typed-gemv!
- (real-tensor dgemv *real-l2-fcall-lb*))
+ (real-tensor dgemv *real-l2-fcall-lb*))
(definline real-typed-gemv! (alpha A x beta y job)
(real-base-typed-gemv! alpha A x beta y (ecase job ((:n :t) job) (:h :t) (:c :n))))
;;Complex
(generate-typed-gemv! complex-base-typed-gemv!
- (complex-tensor zgemv *complex-l2-fcall-lb*))
+ (complex-tensor zgemv *complex-l2-fcall-lb*))
(definline complex-typed-gemv! (alpha A x beta y job)
(declare (type complex-matrix A)
@@ -90,22 +93,22 @@
(let-typed ((cx (let-typed ((ret (apply #'make-real-tensor (lvec->list (dimensions x))) :type complex-vector))
(complex-typed-axpy! #c(-1d0 0d0) x ret))
:type complex-vector))
- (complex-typed-num-scal! #c(-1d0 0d0) (tensor-realpart~ y))
- (complex-base-typed-gemv! (cl:conjugate alpha) A cx
- (cl:conjugate beta) y (ecase job (:h :t) (:c :n)))
- (complex-typed-num-scal! #c(-1d0 0d0) (tensor-realpart~ y))
- y)))
+ (complex-typed-num-scal! #c(-1d0 0d0) (tensor-realpart~ y))
+ (complex-base-typed-gemv! (cl:conjugate alpha) A cx
+ (cl:conjugate beta) y (ecase job (:h :t) (:c :n)))
+ (complex-typed-num-scal! #c(-1d0 0d0) (tensor-realpart~ y))
+ y)))
;;Symbolic
#+maxima
(generate-typed-gemv! symbolic-base-typed-gemv!
- (symbolic-tensor nil 0))
+ (symbolic-tensor nil 0))
;;---------------------------------------------------------------;;
(defgeneric gemv! (alpha A x beta y &optional job)
(:documentation
-"
+ "
Syntax
======
(GEMV! alpha A x beta y [job])
@@ -134,17 +137,17 @@
(:method :before ((alpha number) (A standard-matrix) (x standard-vector)
(beta number) (y standard-vector)
&optional (job :n))
- (assert (member job '(:n :t :c :h)) nil 'invalid-value
- :given job :expected `(member job '(:n :t :c :h))
- :message "Inside gemv!")
- (assert (not (eq x y)) nil 'invalid-arguments
- :message "GEMV!: x and y cannot be the same vector")
- (assert (and
- (= (aref (dimensions x) 0)
- (aref (dimensions A) (if (eq job :t) 0 1)))
- (= (aref (dimensions y) 0)
- (aref (dimensions A) (if (eq job :t) 1 0))))
- nil 'tensor-dimension-mismatch)))
+ (assert (member job '(:n :t :c :h)) nil 'invalid-value
+ :given job :expected `(member job '(:n :t :c :h))
+ :message "Inside gemv!")
+ (assert (not (eq x y)) nil 'invalid-arguments
+ :message "GEMV!: x and y cannot be the same vector")
+ (assert (and
+ (= (aref (dimensions x) 0)
+ (aref (dimensions A) (if (eq job :t) 0 1)))
+ (= (aref (dimensions y) 0)
+ (aref (dimensions A) (if (eq job :t) 1 0))))
+ nil 'tensor-dimension-mismatch)))
(defmethod gemv! ((alpha number) (A real-matrix) (x real-vector)
(beta number) (y real-vector) &optional (job :n))
@@ -202,7 +205,7 @@
;;---------------------------------------------------------------;;
(defgeneric gemv (alpha A x beta y &optional job)
(:documentation
-"
+ "
Syntax
======
(GEMV alpha A x beta y [job])
diff --git a/src/level-3/gemm.lisp b/src/level-3/gemm.lisp
index 32a879a..24a7519 100644
--- a/src/level-3/gemm.lisp
+++ b/src/level-3/gemm.lisp
@@ -33,156 +33,160 @@
(error 'tensor-cannot-find-optimization :tensor-class tensor-class)))
(matrix-class (getf opt :matrix))
(blas? (and blas-gemm-func blas-gemv-func)))
- (setf (getf opt :gemm) func
- (get-tensor-class-optimization tensor-class) opt)
- `(defun ,func (alpha A B beta C job)
- (declare (type ,(getf opt :element-type) alpha beta)
- (type ,matrix-class A B C)
- (type symbol job))
- ;;The big done-in-lisp-gemm, loop-ordering was inspired by the BLAS dgemm reference implementation.
- ,(let
- ((lisp-routine
- `(let-typed ((nr-C (nrows C) :type index-type)
- (nc-C (ncols C) :type index-type)
- (dotl (ecase job-A (:n (ncols A)) (:t (nrows A))) :type index-type)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (let ((opt (get-tensor-class-optimization-hashtable ',tensor-class)))
+ (assert opt nil 'tensor-cannot-find-optimization :tensor-class ',tensor-class)
+ (setf (getf opt :gemm) ',func
+ (get-tensor-class-optimization ',tensor-class) opt))
+ (defun ,func (alpha A B beta C job)
+ (declare (type ,(getf opt :element-type) alpha beta)
+ (type ,matrix-class A B C)
+ (type symbol job))
+ ;;The big done-in-lisp-gemm, loop-ordering was inspired by the BLAS dgemm reference implementation.
+ ,(let
+ ((lisp-routine
+ `(let-typed ((nr-C (nrows C) :type index-type)
+ (nc-C (ncols C) :type index-type)
+ (dotl (ecase job-A (:n (ncols A)) (:t (nrows A))) :type index-type)
;
- (rstp-A (row-stride A) :type index-type)
- (cstp-A (col-stride A) :type index-type)
- (hd-A (head A) :type index-type)
- (sto-A (store A) :type ,(linear-array-type (getf opt :store-type)))
+ (rstp-A (row-stride A) :type index-type)
+ (cstp-A (col-stride A) :type index-type)
+ (hd-A (head A) :type index-type)
+ (sto-A (store A) :type ,(linear-array-type (getf opt :store-type)))
;
- (rstp-B (row-stride B) :type index-type)
- (cstp-B (col-stride B) :type index-type)
- (hd-B (head B) :type index-type)
- (sto-B (store B) :type ,(linear-array-type (getf opt :store-type)))
+ (rstp-B (row-stride B) :type index-type)
+ (cstp-B (col-stride B) :type index-type)
+ (hd-B (head B) :type index-type)
+ (sto-B (store B) :type ,(linear-array-type (getf opt :store-type)))
;
- (rstp-C (row-stride C) :type index-type)
- (cstp-C (col-stride C) :type index-type)
- (hd-C (head C) :type index-type)
- (sto-C (store C) :type ,(linear-array-type (getf opt :store-type))))
- ;;Replace with separate loops to maximize Row-ordered MM performance
- (when (eq job-A :t)
- (rotatef rstp-A cstp-A))
- (when (eq job-B :t)
- (rotatef rstp-B cstp-B))
- ;;
- (unless (,(getf opt :f=) beta (,(getf opt :fid*)))
- (,(getf opt :num-scal) beta C))
- ;;
- (let-typed ((of-A hd-A :type index-type)
- (of-B hd-B :type index-type)
- ...
[truncated message content] |
×
Want the latest updates on software, tech news, and AI?
Get latest updates about software, tech news, and AI from SourceForge directly in your inbox once a month.
Thanks for helping keep SourceForge clean.
X