Menu
▾
▴
matlisp-commit — Commit log
You can subscribe to this list here.
| 2012 |
Jan
|
Feb
|
Mar
(34) |
Apr
(4) |
May
(2) |
Jun
(11) |
Jul
(22) |
Aug
(9) |
Sep
|
Oct
|
Nov
|
Dec
(4) |
|---|---|---|---|---|---|---|---|---|---|---|---|---|
| 2013 |
Jan
(15) |
Feb
(17) |
Mar
(3) |
Apr
|
May
|
Jun
(3) |
Jul
(1) |
Aug
(5) |
Sep
(5) |
Oct
(2) |
Nov
(1) |
Dec
(1) |
| 2014 |
Jan
|
Feb
(1) |
Mar
(1) |
Apr
|
May
(1) |
Jun
|
Jul
|
Aug
|
Sep
|
Oct
|
Nov
|
Dec
|
| 2016 |
Jan
|
Feb
|
Mar
|
Apr
|
May
|
Jun
|
Jul
|
Aug
(1) |
Sep
|
Oct
|
Nov
|
Dec
|
|
From: Akshay S. <ak...@us...> - 2012-07-13 13:48:36
|
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 2b87e86f1392efee853a1807d7c9299fee1f7958 (commit)
from 04ac7f795b17225ad7f942b85bad9508a885ee1e (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 2b87e86f1392efee853a1807d7c9299fee1f7958
Author: Akshay Srinivasan <aks...@gm...>
Date: Fri Jul 13 11:36:34 2012 +0530
o Added fortran-call-lower-bound parameters to scal, dot and swap.
diff --git a/matlisp.asd b/matlisp.asd
index 6858f31..f5cb98e 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -109,13 +109,14 @@
:depends-on ("matlisp-base" "matlisp-classes" "foreign-core")
:components ((:file "tensor-maker")
(:file "swap")
- (:file "dot")
(:file "copy"
:depends-on ("tensor-maker"))
(:file "scal"
:depends-on ("copy" "tensor-maker"))
(:file "realimag"
:depends-on ("copy"))
+ (:file "dot"
+ :depends-on ("realimag"))
(:file "axpy"
:depends-on ("copy"))))
(:module "matlisp-level-2"
diff --git a/src/classes/complex-tensor.lisp b/src/classes/complex-tensor.lisp
index 828af4b..7eca0b9 100644
--- a/src/classes/complex-tensor.lisp
+++ b/src/classes/complex-tensor.lisp
@@ -1,5 +1,6 @@
(in-package #:matlisp)
+;;Complex-base-type must always equal real-type.
(deftype complex-base-type ()
"The type of the elements stored in a COMPLEX-MATRIX"
'double-float)
diff --git a/src/level-1/copy.lisp b/src/level-1/copy.lisp
index 24bb2d3..cf626f6 100644
--- a/src/level-1/copy.lisp
+++ b/src/level-1/copy.lisp
@@ -96,7 +96,7 @@
"
If the dimension of the arguments is less than this parameter,
then the Lisp version of copy is used. Default set with SBCL running
- on x86-64 linux. A reasonable value would be something about 1000.")
+ on x86-64 linux. A reasonable value would be something above 1000.")
(generate-typed-copy! real-typed-copy! (real-tensor
dcopy
*real-copy-fortran-call-lower-bound*))
diff --git a/src/level-1/dot.lisp b/src/level-1/dot.lisp
index 59d00ab..09a4728 100644
--- a/src/level-1/dot.lisp
+++ b/src/level-1/dot.lisp
@@ -27,6 +27,87 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(in-package #:matlisp)
+(defparameter *real-dot-fortran-call-lower-bound* 20000
+ "
+ If the dimension of the arguments is less than this parameter,
+ then the Lisp version of copy is used. Default set with SBCL running
+ on x86-64 linux. A reasonable value would be something above 1000.")
+(defun real-typed-dot (x y conjugate-p)
+ (declare (type real-vector x y)
+ (ignore conjugate-p))
+ (let ((call-fortran? (> (number-of-elements x)
+ *real-dot-fortran-call-lower-bound*)))
+ (cond
+ (call-fortran?
+ (ddot (number-of-elements x)
+ (store x) (aref (strides x) 0)
+ (store y) (aref (strides y) 0)
+ (head x) (head y)))
+ (t
+ (let-typed
+ ((stp-x (aref (strides x) 0) :type index-type)
+ (sto-x (store x) :type (real-array *))
+ (stp-y (aref (strides y) 0) :type index-type)
+ (sto-y (store y) :type (real-array *))
+ (nele (number-of-elements x) :type index-type))
+ (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)
+ summing (* (aref sto-x of-x) (aref sto-y of-y)) into dot of-type real-type
+ finally (return dot))))))))
+
+
+(defparameter *complex-dot-fortran-call-lower-bound* 10000
+ "
+ If the dimension of the arguments is less than this parameter,
+ then the Lisp version of copy is used. Default set with SBCL running
+ on x86-64 linux. A reasonable value would be something above 1000.")
+(defun complex-typed-dot (x y conjugate-p)
+ (declare (type complex-vector x y))
+ (let ((call-fortran? (> (number-of-elements x)
+ *complex-dot-fortran-call-lower-bound*)))
+ (cond
+ (call-fortran?
+ (if conjugate-p
+ (zdotc (number-of-elements x)
+ (store x) (aref (strides x) 0)
+ (store y) (aref (strides y) 0)
+ (head x) (head y))
+ (zdotu (number-of-elements x)
+ (store x) (aref (strides x) 0)
+ (store y) (aref (strides y) 0)
+ (head x) (head y))))
+ (t
+ (let-typed
+ ((stp-x (aref (strides x) 0) :type index-type)
+ (sto-x (store x) :type (complex-base-array *))
+ (stp-y (aref (strides y) 0) :type index-type)
+ (sto-y (store y) :type (complex-base-array *))
+ (nele (number-of-elements x) :type index-type))
+ (if conjugate-p
+ (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)
+ summing (let-typed ((xval (complex (aref sto-x (* 2 of-x)) (- (aref sto-x (1+ (* 2 of-x))))) :type complex-type)
+ (yval (complex (aref sto-y (* 2 of-y)) (aref sto-y (1+ (* 2 of-y)))) :type complex-type))
+ (* xval yval))
+ into dot of-type complex-type
+ finally (return dot)))
+ (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)
+ summing (let-typed ((xval (complex (aref sto-x (* 2 of-x)) (aref sto-x (1+ (* 2 of-x)))) :type complex-type)
+ (yval (complex (aref sto-y (* 2 of-y)) (aref sto-y (1+ (* 2 of-y)))) :type complex-type))
+ (* xval yval))
+ into dot of-type complex-type
+ finally (return dot)))))))))
+
+;;---------------------------------------------------------------;;
+
+
(defgeneric dot (x y &optional conjugate-p)
(:documentation
"
@@ -71,21 +152,16 @@
(defmethod dot ((x real-vector) (y real-vector) &optional (conjugate-p t))
(declare (ignore conjugate-p))
- (ddot (number-of-elements x)
- (store x) (aref (strides x) 0)
- (store y) (aref (strides y) 0)
- (head x) (head y)))
+ (real-typed-dot x y nil))
(defmethod dot ((x real-vector) (y complex-vector) &optional (conjugate-p t))
(declare (ignore conjugate-p))
- (let ((nele (number-of-elements x))
- (std-x (aref (strides x) 0))
- (hd-x (head x))
- (std-y (aref (strides y) 0))
- (hd-y (head y)))
- (declare (type index-type nele std-x std-y hd-x hd-y))
- (let ((rpart (ddot nele (store x) std-x (store y) (* 2 std-y) hd-x (* 2 hd-y)))
- (ipart (ddot nele (store x) std-x (store y) (* 2 std-y) hd-x (1+ (* 2 hd-y)))))
+ (let ((vw.y (tensor-realpart~ y)))
+ (declare (type real-vector vw.y))
+ (let ((rpart (prog1 (real-typed-dot x vw.y nil)
+ ;;Move view to complex-part
+ (incf (head vw.y))))
+ (ipart (real-typed-dot x vw.y nil)))
(declare (type complex-base-type rpart ipart))
(if (zerop ipart)
rpart
@@ -98,21 +174,4 @@
cres)))
(defmethod dot ((x complex-vector) (y complex-vector) &optional (conjugate-p t))
- (let ((nele (number-of-elements x))
- (std-x (aref (strides x) 0))
- (hd-x (head x))
- (std-y (aref (strides y) 0))
- (hd-y (head y)))
- (declare (type index-type nele std-x hd-x std-y hd-y))
- (let ((ret (if conjugate-p
- (zdotc nele
- (store x) std-x
- (store y) std-y
- hd-x hd-y)
- (zdotu nele
- (store x) std-x
- (store y) std-y
- hd-x hd-y))))
- (if (zerop (imagpart ret))
- (realpart ret)
- ret))))
+ (complex-typed-dot x y conjugate-p))
diff --git a/src/level-1/scal.lisp b/src/level-1/scal.lisp
index 6d12a0e..c7604b1 100644
--- a/src/level-1/scal.lisp
+++ b/src/level-1/scal.lisp
@@ -28,31 +28,43 @@
(in-package #:matlisp)
-(defmacro generate-typed-scal! (func (tensor-class blas-func))
+(defmacro generate-typed-scal! (func (tensor-class blas-func fortran-lb))
(let ((opt (get-tensor-class-optimization tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
`(defun ,func (alpha to)
(declare (type ,tensor-class to)
(type ,(getf opt :element-type) alpha))
- (if-let (min-stride (consecutive-store-p to))
- (,blas-func (number-of-elements to) alpha (store to) min-stride (head to))
- (let ((t-sto (store to)))
- (declare (type ,(linear-array-type (getf opt :store-type)) 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 to))
- with (linear-sums
- (t-of (strides to) (head to)))
- do (let ((scal-val (* ,(funcall (getf opt :reader) 't-sto 't-of) alpha)))
- ,(funcall (getf opt :value-writer) 'scal-val 't-sto 't-of))))))
+ (let ((min-stride (consecutive-store-p to))
+ (call-fortran? (> (number-of-elements to) ,fortran-lb)))
+ (cond
+ ((and min-stride call-fortran?)
+ (,blas-func (number-of-elements to) alpha (store to) min-stride (head to)))
+ (t
+ (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 (* ,(funcall (getf opt :reader) 't-sto 't-of) alpha)))
+ ,(funcall (getf opt :value-writer) 'scal-val 't-sto 't-of))))))))
to)))
;; TODO: Maybe add zdscal support ? Don't think the difference between
;; zdscal and zscal is significant, except for very large arrays.
-(generate-typed-scal! real-typed-scal! (real-tensor dscal))
-(generate-typed-scal! complex-typed-scal! (complex-tensor zscal))
+(defparameter *real-scal-fortran-call-lower-bound* 20000
+ "
+ If the dimension of the arguments is less than this parameter,
+ then the Lisp version of copy is used. Default set with SBCL running
+ on x86-64 linux. A reasonable value would be something above 1000.")
+(generate-typed-scal! real-typed-scal! (real-tensor dscal *real-scal-fortran-call-lower-bound*))
+
+(defparameter *complex-scal-fortran-call-lower-bound* 10000
+ "
+ If the dimension of the arguments is less than this parameter,
+ then the Lisp version of copy is used. Default set with SBCL running
+ on x86-64 linux. A reasonable value would be something above 1000.")
+(generate-typed-scal! complex-typed-scal! (complex-tensor zscal *complex-scal-fortran-call-lower-bound*))
;;---------------------------------------------------------------;;
(defgeneric scal! (alpha x)
diff --git a/src/level-1/swap.lisp b/src/level-1/swap.lisp
index 849c62b..7f80c78 100644
--- a/src/level-1/swap.lisp
+++ b/src/level-1/swap.lisp
@@ -28,7 +28,7 @@
(in-package #:matlisp)
-(defmacro generate-typed-swap! (func (tensor-class blas-func))
+(defmacro generate-typed-swap! (func (tensor-class blas-func fortran-lb))
;;Be very careful when using functions generated by this macro.
;;Indexes can be tricky and this has no safety net
;;Use only after checking the arguments for compatibility.
@@ -36,24 +36,36 @@
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
`(defun ,func (x y)
(declare (type ,tensor-class x y))
- (if-let (strd-p (blas-copyable-p x y))
- (,blas-func (number-of-elements x) (store x) (first strd-p) (store y) (second strd-p) (head x) (head y))
- (let ((f-sto (store x))
- (t-sto (store y)))
- (declare (type ,(linear-array-type (getf opt :store-type)) f-sto t-sto))
- (very-quickly
- ;;One would question the wisdom in calling the Fortran method here.
- ;;Simple benchmarks proved that SBCL is as quick as or better than
- ;;OpenBLAS's methods
- (mod-dotimes (idx (dimensions x))
- with (linear-sums
- (f-of (strides x) (head x))
- (t-of (strides y) (head y)))
- do ,(funcall (getf opt :swapper) 'f-sto 'f-of 't-sto 't-of)))))
+ (let ((strd-p (blas-copyable-p x y))
+ (call-fortran? (> (number-of-elements x) ,fortran-lb)))
+ (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
+ (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 ,(funcall (getf opt :swapper) 'f-sto 'f-of 't-sto 't-of)))))))
y)))
-(generate-typed-swap! real-typed-swap! (real-tensor dswap))
-(generate-typed-swap! complex-typed-swap! (complex-tensor zswap))
+(defparameter *real-swap-fortran-call-lower-bound* 20000
+ "
+ If the dimension of the arguments is less than this parameter,
+ then the Lisp version of copy is used. Default set with SBCL running
+ on x86-64 linux. A reasonable value would be something above 1000.")
+(generate-typed-swap! real-typed-swap! (real-tensor dswap *real-swap-fortran-call-lower-bound*))
+
+(defparameter *complex-scal-fortran-call-lower-bound* 10000
+ "
+ If the dimension of the arguments is less than this parameter,
+ then the Lisp version of copy is used. Default set with SBCL running
+ on x86-64 linux. A reasonable value would be something above 1000.")
+(generate-typed-swap! complex-typed-swap! (complex-tensor zswap *complex-scal-fortran-call-lower-bound*))
;;---------------------------------------------------------------;;
(defgeneric swap! (x y)
-----------------------------------------------------------------------
Summary of changes:
matlisp.asd | 3 +-
src/classes/complex-tensor.lisp | 1 +
src/level-1/copy.lisp | 2 +-
src/level-1/dot.lisp | 119 +++++++++++++++++++++++++++++----------
src/level-1/scal.lisp | 44 +++++++++-----
src/level-1/swap.lisp | 46 ++++++++++------
6 files changed, 150 insertions(+), 65 deletions(-)
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2012-07-12 16:37:29
|
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 04ac7f795b17225ad7f942b85bad9508a885ee1e (commit)
from cbb7c2bfaa2dedc65e56be04c1469e46be975801 (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 04ac7f795b17225ad7f942b85bad9508a885ee1e
Author: Akshay Srinivasan <aks...@gm...>
Date: Thu Jul 12 21:15:12 2012 +0530
o Tweaks to methods in gemm, gemv and axpy.
diff --git a/src/level-1/axpy.lisp b/src/level-1/axpy.lisp
index 2de1898..0a3b9cc 100644
--- a/src/level-1/axpy.lisp
+++ b/src/level-1/axpy.lisp
@@ -145,10 +145,10 @@
(:method ((alpha number) (x complex-tensor) (y real-tensor))
(error 'coercion-error :from 'complex-tensor :to 'real-tensor)))
-(defmethod axpy! ((alpha number) (x (eql t)) (y real-tensor))
+(defmethod axpy! ((alpha number) (x (eql nil)) (y real-tensor))
(real-typed-num-axpy! (coerce-real alpha) y))
-(defmethod axpy! ((alpha number) (x (eql t)) (y complex-tensor))
+(defmethod axpy! ((alpha number) (x (eql nil)) (y complex-tensor))
(complex-typed-num-axpy! (coerce-complex alpha) y))
(defmethod axpy! ((alpha number) (x real-tensor) (y real-tensor))
diff --git a/src/level-2/gemv.lisp b/src/level-2/gemv.lisp
index 911759e..43b9e10 100644
--- a/src/level-2/gemv.lisp
+++ b/src/level-2/gemv.lisp
@@ -220,3 +220,12 @@
(scal! y result)
(gemv! alpha A x beta result job)))
+(defmethod gemv ((alpha number) (A standard-matrix) (x standard-vector)
+ (beta (eql nil)) (y (eql nil)) &optional (job :n))
+ (let ((result (apply
+ (if (or (complexp alpha) (complexp beta)
+ (typep A 'complex-matrix) (typep x 'complex-vector))
+ #'make-complex-tensor
+ #'make-real-tensor)
+ (list (ecase job (:n (nrows A)) (:t (ncols A)))))))
+ (gemv! alpha A x beta result job)))
diff --git a/src/level-3/gemm.lisp b/src/level-3/gemm.lisp
index 4cae6f3..f5172b7 100644
--- a/src/level-3/gemm.lisp
+++ b/src/level-3/gemm.lisp
@@ -304,7 +304,7 @@
"))
(defmethod gemm ((alpha number) (a standard-matrix) (b standard-matrix)
- (beta number) (c real-matrix)
+ (beta number) (c complex-matrix)
&optional (job :nn))
(let ((result (copy C)))
(gemm! alpha A B beta result job)))
@@ -312,7 +312,7 @@
;; if all args are not real then at least one of them
;; is complex, so we need to call GEMM! with a complex C
(defmethod gemm ((alpha number) (a standard-matrix) (b standard-matrix)
- (beta number) (c standard-matrix)
+ (beta number) (c real-matrix)
&optional (job :nn))
(let ((result (if (or (complexp alpha) (complexp beta)
(typep a 'complex-matrix) (typep b 'complex-matrix))
@@ -320,3 +320,20 @@
(make-real-tensor (nrows C) (ncols C)))))
(copy! C result)
(gemm! alpha A B beta result job)))
+
+(defmethod gemm ((alpha number) (a standard-matrix) (b standard-matrix)
+ (beta (eql nil)) (c (eql nil))
+ &optional (job :nn))
+ (multiple-value-bind (job-A job-B) (ecase job
+ (:nn (values :n :n))
+ (:nt (values :n :t))
+ (:tn (values :t :n))
+ (:tt (values :t :t)))
+ (let ((result (apply
+ (if (or (complexp alpha) (complexp beta)
+ (typep a 'complex-matrix) (typep b 'complex-matrix))
+ #'make-complex-tensor
+ #'make-real-tensor)
+ (list (if (eq job-A :n) (nrows A) (ncols A))
+ (if (eq job-B :n) (ncols B) (nrows B))))))
+ (gemm! alpha A B 0 result job))))
-----------------------------------------------------------------------
Summary of changes:
src/level-1/axpy.lisp | 4 ++--
src/level-2/gemv.lisp | 9 +++++++++
src/level-3/gemm.lisp | 21 +++++++++++++++++++--
3 files changed, 30 insertions(+), 4 deletions(-)
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2012-07-12 10:48:23
|
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 cbb7c2bfaa2dedc65e56be04c1469e46be975801 (commit)
from 63d6b10a662cb7b8ad0b3dfd288db7a5f921abff (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 cbb7c2bfaa2dedc65e56be04c1469e46be975801
Author: Akshay Srinivasan <aks...@gm...>
Date: Thu Jul 12 16:13:06 2012 +0530
o Added a fortran-call-lower-bound to axpy and copy.
o Added a new num-axpy! function generating macro, added methods to axpy!
diff --git a/src/level-1/axpy.lisp b/src/level-1/axpy.lisp
index edef2d3..2de1898 100644
--- a/src/level-1/axpy.lisp
+++ b/src/level-1/axpy.lisp
@@ -28,7 +28,7 @@
(in-package #:matlisp)
-(defmacro generate-typed-axpy! (func (tensor-class blas-func))
+(defmacro generate-typed-axpy! (func (tensor-class blas-func fortran-lb))
;;Be very careful when using functions generated by this macro.
;;Indexes can be tricky and this has no safety net
;;Use only after checking the arguments for compatibility.
@@ -37,29 +37,88 @@
`(defun ,func (alpha from to)
(declare (type ,tensor-class from to)
(type ,(getf opt :element-type) alpha))
- (if-let (strd-p (blas-copyable-p from to))
- (,blas-func (number-of-elements from) alpha (store from) (first strd-p) (store to) (second strd-p) (head from) (head to))
- (let ((f-sto (store from))
- (t-sto (store to)))
- (declare (type ,(linear-array-type (getf opt :store-type)) f-sto t-sto))
- (very-quickly
- ;;One would question the wisdom in calling the Fortran method here.
- ;;Simple benchmarks proved that SBCL is as quick as or better than
- ;;OpenBLAS's methods
- (mod-dotimes (idx (dimensions from))
- with (linear-sums
- (f-of (strides from) (head from))
- (t-of (strides to) (head to)))
- do (let ((f-val ,(funcall (getf opt :reader) 'f-sto 'f-of))
- (t-val ,(funcall (getf opt :reader) 't-sto 't-of)))
- (declare (type ,(getf opt :element-type) f-val t-val))
- (let ((t-new (+ (* f-val alpha) t-val)))
- (declare (type ,(getf opt :element-type) t-new))
- ,(funcall (getf opt :value-writer) 't-new 't-sto 't-of)))))))
+ (let ((strd-p (blas-copyable-p from to))
+ (call-fortran? (> (number-of-elements to)
+ ,fortran-lb)))
+ (cond
+ ((and strd-p call-fortran?)
+ (,blas-func (number-of-elements from) alpha
+ (store from) (first strd-p)
+ (store to) (second strd-p)
+ (head from) (head to)))
+ (t
+ (let ((f-sto (store from))
+ (t-sto (store to)))
+ (declare (type ,(linear-array-type (getf opt :store-type)) f-sto t-sto))
+ (very-quickly
+ ;;One would question the wisdom in calling the Fortran method here.
+ ;;Simple benchmarks proved that SBCL is as quick as or better than
+ ;;OpenBLAS's methods
+ (mod-dotimes (idx (dimensions from))
+ with (linear-sums
+ (f-of (strides from) (head from))
+ (t-of (strides to) (head to)))
+ do (let ((f-val ,(funcall (getf opt :reader) 'f-sto 'f-of))
+ (t-val ,(funcall (getf opt :reader) 't-sto 't-of)))
+ (declare (type ,(getf opt :element-type) f-val t-val))
+ (let ((t-new (+ (* f-val alpha) t-val)))
+ (declare (type ,(getf opt :element-type) t-new))
+ ,(funcall (getf opt :value-writer) 't-new 't-sto 't-of)))))))))
to)))
-(generate-typed-axpy! real-typed-axpy! (real-tensor daxpy))
-(generate-typed-axpy! complex-typed-axpy! (complex-tensor zaxpy))
+(defmacro generate-typed-num-axpy! (func (tensor-class blas-func fortran-lb))
+ ;;Be very careful when using functions generated by this macro.
+ ;;Indexes can be tricky and this has no safety net
+ ;;(you don't see a matrix-ref do you ?)
+ ;;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)
+ `(defun ,func (num-from to)
+ (declare (type ,tensor-class to)
+ (type ,(getf opt :element-type) num-from))
+ (let ((min-strd (consecutive-store-p to))
+ (call-fortran? (> (number-of-elements to) ,fortran-lb)))
+ (cond
+ ((and min-strd call-fortran?)
+ (let ((num-array (,(getf opt :store-allocator) 1)))
+ (declare (type ,(linear-array-type (getf opt :store-type)) num-array))
+ ,(funcall (getf opt :value-writer) `(,(getf opt :coercer) 1) 'num-array 0)
+ (,blas-func (number-of-elements to) num-from
+ num-array 0
+ (store to) min-strd
+ 0 (head to))))
+ (t
+ (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 ,(funcall (getf opt :reader) 't-sto 't-of) :type ,(getf opt :element-type)))
+ ,(funcall (getf opt :value-writer) '(+ num-from val) 't-sto 't-of))))))))
+ to)))
+
+;;Tweakable
+(defparameter *real-axpy-fortran-call-lower-bound* 20000
+ "If the size of the array is less than this parameter, the
+ lisp version of axpy is called in order to avoid FFI overheads")
+(generate-typed-axpy! real-typed-axpy! (real-tensor
+ daxpy
+ *real-axpy-fortran-call-lower-bound*))
+(generate-typed-num-axpy! real-typed-num-axpy! (real-tensor
+ daxpy
+ *real-axpy-fortran-call-lower-bound*))
+;;Tweakable
+(defparameter *complex-axpy-fortran-call-lower-bound* 10000
+ "If the size of the array is less than this parameter, the
+ lisp version of axpy is called in order to avoid FFI overheads")
+(generate-typed-axpy! complex-typed-axpy! (complex-tensor
+ zaxpy
+ *complex-axpy-fortran-call-lower-bound*))
+(generate-typed-num-axpy! complex-typed-num-axpy! (complex-tensor
+ zaxpy
+ *complex-axpy-fortran-call-lower-bound*))
;;---------------------------------------------------------------;;
(defgeneric axpy! (alpha x y)
@@ -71,6 +130,10 @@
Y <- alpha * x + y
+ If x is T, then
+
+ Y <- alpha + y
+
Purpose
=======
Same as AXPY except that the result
@@ -82,6 +145,12 @@
(:method ((alpha number) (x complex-tensor) (y real-tensor))
(error 'coercion-error :from 'complex-tensor :to 'real-tensor)))
+(defmethod axpy! ((alpha number) (x (eql t)) (y real-tensor))
+ (real-typed-num-axpy! (coerce-real alpha) y))
+
+(defmethod axpy! ((alpha number) (x (eql t)) (y complex-tensor))
+ (complex-typed-num-axpy! (coerce-complex alpha) y))
+
(defmethod axpy! ((alpha number) (x real-tensor) (y real-tensor))
(real-typed-axpy! (coerce-real alpha) x y))
diff --git a/src/level-1/copy.lisp b/src/level-1/copy.lisp
index 317c011..24bb2d3 100644
--- a/src/level-1/copy.lisp
+++ b/src/level-1/copy.lisp
@@ -28,7 +28,7 @@
(in-package #:matlisp)
-(defmacro generate-typed-copy! (func (tensor-class blas-func))
+(defmacro generate-typed-copy! (func (tensor-class blas-func fortran-lb))
;;Be very careful when using functions generated by this macro.
;;Indexes can be tricky and this has no safety net
;;Use only after checking the arguments for compatibility.
@@ -36,23 +36,30 @@
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
`(defun ,func (from to)
(declare (type ,tensor-class from to))
- (if-let (strd-p (blas-copyable-p from to))
- (,blas-func (number-of-elements from) (store from) (first strd-p) (store to) (second strd-p) (head from) (head to))
- (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 ,(funcall (getf opt :reader-writer) 'f-sto 'f-of 't-sto 't-of)))))
+ (let ((strd-p (blas-copyable-p from to))
+ (call-fortran? (> (number-of-elements to) ,fortran-lb)))
+ (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
+ (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 ,(funcall (getf opt :reader-writer) 'f-sto 'f-of 't-sto 't-of)))))))
to)))
-(defmacro generate-typed-num-copy! (func (tensor-class blas-func))
+(defmacro generate-typed-num-copy! (func (tensor-class blas-func fortran-lb))
;;Be very careful when using functions generated by this macro.
;;Indexes can be tricky and this has no safety net
;;(you don't see a matrix-ref do you ?)
@@ -62,35 +69,63 @@
`(defun ,func (num-from to)
(declare (type ,tensor-class to)
(type ,(getf opt :element-type) num-from))
- (let ((t-dims (dimensions to))
- (t-stds (strides to))
- (t-sto (store to))
- (t-hd (head to)))
- (declare (type (index-array *) t-dims t-stds)
- (type index-type t-hd)
- (type ,(linear-array-type (getf opt :store-type)) t-sto))
- (if-let (min-stride (consecutive-store-p to))
- (let ((num-array (,(getf opt :store-allocator) 1)))
- (declare (type ,(linear-array-type (getf opt :store-type)) num-array))
- ,(funcall (getf opt :value-writer) 'num-from 'num-array 0)
- (,blas-func (number-of-elements to) num-array 0 t-sto min-stride 0 t-hd))
- (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 t-dims)
- with (linear-sums
- (t-of t-stds t-hd))
- do ,(funcall (getf opt :value-writer) 'num-from 't-sto 't-of))))
- to))))
-
-(generate-typed-copy! real-typed-copy! (real-tensor dcopy))
-(generate-typed-num-copy! real-typed-num-copy! (real-tensor dcopy))
-
-(generate-typed-copy! complex-typed-copy! (complex-tensor zcopy))
-(generate-typed-num-copy! complex-typed-num-copy! (complex-tensor zcopy))
+ (let ((min-stride (consecutive-store-p to))
+ (call-fortran? (> (number-of-elements to) ,fortran-lb)))
+ (cond
+ ((and min-stride call-fortran?)
+ (let ((num-array (,(getf opt :store-allocator) 1)))
+ (declare (type ,(linear-array-type (getf opt :store-type)) num-array))
+ ,(funcall (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
+ (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 ,(funcall (getf opt :value-writer) 'num-from 't-sto 't-of)))))))
+ to)))
+
+
+;;Tweakable
+(defparameter *real-copy-fortran-call-lower-bound* 20000
+ "
+ If the dimension of the arguments is less than this parameter,
+ then the Lisp version of copy is used. Default set with SBCL running
+ on x86-64 linux. A reasonable value would be something about 1000.")
+(generate-typed-copy! real-typed-copy! (real-tensor
+ dcopy
+ *real-copy-fortran-call-lower-bound*))
+(generate-typed-num-copy! real-typed-num-copy! (real-tensor
+ dcopy
+ *real-copy-fortran-call-lower-bound*))
+
+;;Tweakable
+(defparameter *complex-copy-fortran-call-lower-bound* 10000
+ "
+ If the dimension of the arguments is less than this parameter,
+ then the Lisp version of copy is used. Default set with SBCL
+ running on x86-64 linux. A reasonable value would be something
+ above 1000.")
+
+(generate-typed-copy! complex-typed-copy! (complex-tensor
+ zcopy
+ *complex-copy-fortran-call-lower-bound*))
+(generate-typed-num-copy! complex-typed-num-copy! (complex-tensor
+ zcopy
+ *complex-copy-fortran-call-lower-bound*))
;;---------------------------------------------------------------;;
+(defun test-copy (n r)
+ (let ((x (make-real-tensor n)))
+ (time (dotimes (i r)
+ (copy! pi x)))
+ t))
+
(defgeneric copy! (from-tensor to-tensor)
(:documentation
"
diff --git a/src/level-2/gemv.lisp b/src/level-2/gemv.lisp
index c67af94..911759e 100644
--- a/src/level-2/gemv.lisp
+++ b/src/level-2/gemv.lisp
@@ -1,9 +1,9 @@
(in-package #:matlisp)
(defmacro generate-typed-gemv! (func
- (matrix-class vector-class)
- blas-gemv-func
- fortran-call-lb)
+ (matrix-class vector-class
+ blas-gemv-func
+ fortran-call-lb))
;;Be very careful when using functions generated by this macro.
;;Indexes can be tricky and this has no safety net.
;;Use only after checking the arguments for compatibility.
@@ -68,9 +68,9 @@
MM with small matrices.
Default set with SBCL on x86-64 linux. A reasonable value
is something between 800 and 2000.")
-(generate-typed-gemv! real-typed-gemv!
- (real-matrix real-vector) dgemv
- *real-gemv-fortran-call-lower-bound*)
+(generate-typed-gemv! real-typed-gemv! (real-matrix real-vector
+ dgemv
+ *real-gemv-fortran-call-lower-bound*))
;;Tweakable
(defparameter *complex-gemv-fortran-call-lower-bound* 600
@@ -81,9 +81,9 @@
MM with small matrices.
Default set with SBCL on x86-64 linux. A reasonable value
is something between 400 and 1000.")
-(generate-typed-gemv! complex-typed-gemv!
- (complex-matrix complex-vector) zgemv
- *complex-gemv-fortran-call-lower-bound*)
+(generate-typed-gemv! complex-typed-gemv! (complex-matrix complex-vector
+ zgemv
+ *complex-gemv-fortran-call-lower-bound*))
;;---------------------------------------------------------------;;
;;Can't support "C" because the dual isn't supported by BLAS.
diff --git a/src/level-3/gemm.lisp b/src/level-3/gemm.lisp
index d56732e..4cae6f3 100644
--- a/src/level-3/gemm.lisp
+++ b/src/level-3/gemm.lisp
@@ -28,7 +28,7 @@
(in-package #:matlisp)
-(defmacro generate-typed-gemm! (func (matrix-class) (blas-gemm-func blas-gemv-func) fortran-lb-parameter)
+(defmacro generate-typed-gemm! (func (matrix-class blas-gemm-func blas-gemv-func fortran-lb-parameter))
(let* ((opt (get-tensor-class-optimization matrix-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class matrix-class)
`(defun ,func (alpha A B beta C job)
@@ -161,8 +161,9 @@
MM with small matrices.
Default set with SBCL on x86-64 linux. A reasonable value
is something between 20 and 200.")
-(generate-typed-gemm! real-typed-gemm! (real-matrix) (dgemm dgemv)
- *real-gemm-fortran-call-lower-bound*)
+(generate-typed-gemm! real-typed-gemm! (real-matrix
+ dgemm dgemv
+ *real-gemm-fortran-call-lower-bound*))
;;Tweakable
(defparameter *complex-gemm-fortran-call-lower-bound* 60
@@ -173,8 +174,9 @@
MM with small matrices.
Default set with SBCL on x86-64 linux. A reasonable value
is something between 20 and 200.")
-(generate-typed-gemm! complex-typed-gemm! (complex-matrix) (zgemm zgemv)
- *complex-gemm-fortran-call-lower-bound*)
+(generate-typed-gemm! complex-typed-gemm! (complex-matrix
+ zgemm zgemv
+ *complex-gemm-fortran-call-lower-bound*))
;;---------------------------------------------------------------;;
(defgeneric gemm! (alpha A B beta C &optional job)
diff --git a/src/old/complex-matrix.lisp b/src/old/complex-matrix.lisp
deleted file mode 100644
index a7bc004..0000000
--- a/src/old/complex-matrix.lisp
+++ /dev/null
@@ -1,290 +0,0 @@
-;;; Definitions of COMPLEX-MATRIX.
-
-(in-package :matlisp)
-
-(eval-when (load eval compile)
-(deftype complex-matrix-element-type ()
- "The type of the elements stored in a COMPLEX-MATRIX"
- 'double-float)
-
-(deftype complex-matrix-store-type (size)
- "The type of the storage structure for a COMPLEX-MATRIX"
- `(simple-array double-float (,size)))
-
-(deftype complex-double-float ()
- '(cl:complex (double-float * *)))
-)
-
-;;
-(declaim (inline complex-coerce)
- (ftype (function (number) (complex complex-matrix-element-type))
- complex-coerce))
-(defun complex-coerce (val)
- "
- Syntax
- ======
- (COMPLEX-COERCE number)
-
- Purpose
- =======
- Coerce NUMBER to a complex number.
-"
- (declare (type number val))
- (typecase val
- ((complex complex-matrix-element-type) val)
- (complex (complex (coerce (realpart val) 'complex-matrix-element-type)
- (coerce (imagpart val) 'complex-matrix-element-type)))
- (t (complex (coerce val 'complex-matrix-element-type) 0.0d0))))
-
-;;
-(defclass complex-matrix (standard-matrix)
- ((store
- :initform nil
- :type (complex-matrix-store-type *)))
- (:documentation "A class of matrices with complex elements."))
-
-(defclass sub-complex-matrix (complex-matrix)
- ((parent-matrix
- :initarg :parent
- :accessor parent
- :type complex-matrix))
- (:documentation "A class of matrices with complex elements."))
-
-;;
-(defmethod initialize-instance ((matrix complex-matrix) &rest initargs)
- (setf (store-size matrix) (/ (length (getf :store initargs)) 2))
- (call-next-method))
-
-;;
-(defmethod matrix-ref-1d ((matrix complex-matrix) (idx fixnum))
- (let ((store (store matrix)))
- (declare (type (complex-matrix-store-type *) store))
- (complex (aref store (* 2 idx)) (aref store (+ 1 (* 2 idx))))))
-
-(defmethod (setf matrix-ref-1d) ((value number) (matrix complex-matrix) (idx fixnum))
- (let ((store (store matrix))
- (coerced-value (complex-coerce value)))
- (declare (type (complex-matrix-store-type *) store))
- (setf (aref store (* 2 idx)) (realpart coerced-value)
- (aref store (+ 1 (* 2 idx))) (imagpart coerced-value))))
-
-;;
-(declaim (inline allocate-complex-store))
-(defun allocate-complex-store (size)
- (make-array (* 2 size) :element-type 'complex-matrix-element-type
- :initial-element (coerce 0 'complex-matrix-element-type)))
-
-;;
-(defmethod fill-matrix ((matrix complex-matrix) (fill number))
- (copy! fill matrix))
-
-;;
-(defun make-complex-matrix-dim (n m &key (fill #c(0.0d0 0.0d0)) (order :row-major))
- "
- Syntax
- ======
- (MAKE-COMPLEX-MATRIX-DIM n m {fill-element #C(0d0 0d0)} {order :row-major})
-
- Purpose
- =======
- Creates an NxM COMPLEX-MATRIX with initial contents FILL-ELEMENT,
- the default #c(0.0d0 0.0d0), in the row-major order by default.
-
- See MAKE-COMPLEX-MATRIX.
-"
- (declare (type fixnum n m))
- (let* ((size (* n m))
- (store (allocate-complex-store size)))
- (multiple-value-bind (row-stride col-stride)
- (ecase order
- (:row-major (values m 1))
- (:col-major (values 1 n)))
- (let ((matrix
- (make-instance 'complex-matrix
- :nrows n :ncols m
- :row-stride row-stride :col-stride col-stride
- :store store)))
- (fill-matrix matrix fill)
- matrix))))
-
-;;
-(defun make-complex-matrix-array (array &key (order :row-major))
- "
- Syntax
- ======
- (MAKE-COMPLEX-MATRIX-ARRAY array {order :row-major})
-
- Purpose
- =======
- Creates a COMPLEX-MATRIX with the same contents as ARRAY,
- in row-major order by default.
-"
- (let* ((n (array-dimension array 0))
- (m (array-dimension array 1))
- (size (* n m))
- (store (allocate-complex-store size)))
- (declare (type fixnum n m size)
- (type (complex-matrix-store-type *) store))
- (multiple-value-bind (row-stride col-stride)
- (ecase order
- (:row-major (values m 1))
- (:col-major (values 1 n)))
- (dotimes (i n)
- (declare (type fixnum i))
- (dotimes (j m)
- (declare (type fixnum j))
- (let* ((val (complex-coerce (aref array i j)))
- (realpart (realpart val))
- (imagpart (imagpart val))
- (index (* 2 (store-indexing i j 0 row-stride col-stride))))
- (declare (type complex-matrix-element-type realpart imagpart)
- (type (complex complex-matrix-element-type) val)
- (type fixnum index))
- (setf (aref store index) realpart)
- (setf (aref store (1+ index)) imagpart))))
- (make-instance 'complex-matrix
- :nrows n :ncols m
- :row-stride row-stride :col-stride col-stride
- :store store))))
-
-;;
-(defun make-complex-matrix-seq-of-seq (seq &key (order :row-major))
- (let* ((n (length seq))
- (m (length (elt seq 0)))
- (size (* n m))
- (store (allocate-complex-store size)))
- (declare (type fixnum n m size)
- (type (complex-matrix-store-type *) store))
- (multiple-value-bind (row-stride col-stride)
- (ecase order
- (:row-major (values m 1))
- (:col-major (values 1 n)))
- (dotimes (i n)
- (declare (type fixnum i))
- (let ((this-row (elt seq i)))
- (unless (= (length this-row) m)
- (error "Number of columns is not the same for all rows!"))
- (dotimes (j m)
- (declare (type fixnum j))
- (let* ((val (complex-coerce (elt this-row j)))
- (realpart (realpart val))
- (imagpart (imagpart val))
- (index (* 2 (store-indexing i j 0 row-stride col-stride))))
- (declare (type complex-matrix-element-type realpart imagpart)
- (type (complex complex-matrix-element-type) val)
- (type fixnum index))
- (setf (aref store index) realpart)
- (setf (aref store (1+ index)) imagpart)))))
- (make-instance 'complex-matrix
- :nrows n :ncols m
- :row-stride row-stride :col-stride col-stride
- :store store))))
-
-;;
-(defun make-complex-matrix-seq (seq &key (order :row-major))
- (let* ((n (length seq))
- (store (allocate-complex-store n)))
- (declare (type fixnum n)
- (type (complex-matrix-store-type *) store))
- (dotimes (k n)
- (declare (type fixnum k))
- (let* ((val (complex-coerce (elt seq k)))
- (realpart (realpart val))
- (imagpart (imagpart val))
- (index (* 2 k)))
- (declare (type complex-matrix-element-type realpart imagpart)
- (type (complex complex-matrix-element-type) val)
- (type fixnum index))
- (setf (aref store index) realpart)
- (setf (aref store (1+ index)) imagpart)))
-
- (ecase order
- (:row-major (make-instance 'complex-matrix
- :nrows 1 :ncols n
- :row-stride n :col-stride 1
- :store store))
- (:col-major (make-instance 'complex-matrix
- :nrows n :ncols 1
- :row-stride 1 :col-stride n
- :store store)))))
-
-;;
-(defun make-complex-matrix-sequence (seq &key (order :row-major))
- (cond ((or (listp seq) (vectorp seq))
- (let ((peek (elt seq 0)))
- (cond ((or (listp peek) (vectorp peek))
- ;; We have a seq of seqs
- (make-complex-matrix-seq-of-seq seq :order order))
- (t
- ;; Assume a simple sequence
- (make-complex-matrix-seq seq :order order)))))
- ((arrayp seq)
- (make-complex-matrix-array seq :order order))))
-
-;;
-(defun make-complex-matrix (&rest args)
- "
- Syntax
- ======
- (MAKE-COMPLEX-MATRIX {arg}*)
-
- Purpose
- =======
- Create a FLOAT-MATRIX.
-
- Examples
- ========
-
- (make-complex-matrix n)
- square NxN matrix
- (make-complex-matrix n m)
- NxM matrix
- (make-complex-matrix '((1 2 3) (4 5 6)))
- 2x3 matrix:
-
- 1 2 3
- 4 5 6
-
- (make-complex-matrix #((1 2 3) (4 5 6)))
- 2x3 matrix:
-
- 1 2 3
- 4 5 6
-
- (make-complex-matrix #((1 2 3) #(4 5 6)))
- 2x3 matrix:
-
- 1 2 3
- 4 5 6
-
- (make-complex-matrix #2a((1 2 3) (4 5 6)))
- 2x3 matrix:
-
- 1 2 3
- 4 5 6
-
-"
- (let ((nargs (length args)))
- (case nargs
- (1
- (let ((arg (first args)))
- (typecase arg
- (integer
- (assert (not (minusp arg)) nil
- "matrix dimension must be non-negative, not ~A" arg)
- (make-complex-matrix-dim arg arg))
- (sequence
- (make-complex-matrix-sequence arg))
- ((array * (* *))
- (make-complex-matrix-array arg))
- (t (error "don't know how to make matrix from ~a" arg)))))
- (2
- (destructuring-bind (n m)
- args
- (assert (and (typep n '(integer 0))
- (typep n '(integer 0)))
- nil
- "cannot make a ~A x ~A matrix" n m)
- (make-complex-matrix-dim n m)))
- (t
- (error "require 1 or 2 arguments to make a matrix")))))
diff --git a/src/old/mplus.lisp b/src/old/mplus.lisp
index 3e916f7..bbe1229 100644
--- a/src/old/mplus.lisp
+++ b/src/old/mplus.lisp
@@ -25,52 +25,7 @@
;;; ENHANCEMENTS, OR MODIFICATIONS.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; Originally written by Raymond Toy.
-;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; $Id: mplus.lisp,v 1.7 2011/01/25 18:36:56 rtoy Exp $
-;;;
-;;; $Log: mplus.lisp,v $
-;;; Revision 1.7 2011/01/25 18:36:56 rtoy
-;;; Merge changes from automake-snapshot-2011-01-25-1327 to get the new
-;;; automake build infrastructure.
-;;;
-;;; Revision 1.6.2.1 2011/01/25 18:16:53 rtoy
-;;; Use cl:real instead of real.
-;;;
-;;; Revision 1.6 2004/05/24 16:34:22 rtoy
-;;; More SBCL support from Robert Sedgewick. The previous SBCL support
-;;; was incomplete.
-;;;
-;;; Revision 1.5 2002/07/29 01:06:59 rtoy
-;;; Don't use *1x1-real-array*.
-;;;
-;;; Revision 1.4 2000/07/11 18:02:03 simsek
-;;; o Added credits
-;;;
-;;; Revision 1.3 2000/07/11 02:11:56 simsek
-;;; o Added support for Allegro CL
-;;;
-;;; Revision 1.2 2000/05/08 17:19:18 rtoy
-;;; Changes to the STANDARD-MATRIX class:
-;;; o The slots N, M, and NXM have changed names.
-;;; o The accessors of these slots have changed:
-;;; NROWS, NCOLS, NUMBER-OF-ELEMENTS
-;;; The old names aren't available anymore.
-;;; o The initargs of these slots have changed:
-;;; :nrows, :ncols, :nels
-;;;
-;;; Revision 1.1 2000/04/14 00:11:12 simsek
-;;; o This file is adapted from obsolete files 'matrix-float.lisp'
-;;; 'matrix-complex.lisp' and 'matrix-extra.lisp'
-;;; o Initial revision.
-;;;
-;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(in-package "MATLISP")
+(in-package #:matlisp)
(defgeneric m+ (a b)
(:documentation
@@ -84,50 +39,51 @@
Create a new matrix which is the sum of A and B.
A or B (but not both) may be a scalar, in which
case the addition is element-wise.
-"))
-
-(defgeneric m+! (a b)
- (:documentation
- "
+")
+ (:method ((a number) (b number))
+ (+ a b))
+ (:method ((a standard-tensor) (b standard-tensor))
+ (axpy 1 a b))
+ (:method (
+
+(definline m.+ (a b)
+ "
Syntax
======
- (M+! a b)
+ (M.+ a b)
Purpose
=======
- Desctructive version of M+:
-
- B <- A + B
-"))
+ Same as M+
+"
+ (m+ a b))
-(defgeneric m.+ (a b)
+(defgeneric m+! (a b)
(:documentation
"
Syntax
======
- (M.+ a b)
+ (M+! a b)
Purpose
=======
- Same as M+
-"))
+ Desctructive version of M+:
-(defmethod m.+ (a b)
- (m+ a b))
+ B <- A + B
+")
+ (:method ((a number) (b number))
+ (+ a b)))
-(defgeneric m.+! (a b)
- (:documentation
- "
+(definline m.+! (a b)
+ "
Syntax
======
(M.+! a b)
Purpose
=======
- Same as M.+!
-"))
-
-(defmethod m.+! (a b)
+ Same as M+!
+"
(m+! a b))
(defmethod m+ :before ((a standard-matrix) (b standard-matrix))
diff --git a/src/old/real-matrix.lisp b/src/old/real-matrix.lisp
deleted file mode 100644
index 38ad1f4..0000000
--- a/src/old/real-matrix.lisp
+++ /dev/null
@@ -1,228 +0,0 @@
-
-;;
-(defmethod matrix-ref-1d ((matrix real-matrix) (idx fixnum))
- (let ((store (store matrix)))
- (declare (type (real-matrix-store-type *) store))
- (aref store idx)))
-
-(defmethod (setf matrix-ref-1d) ((value cl:real) (matrix real-matrix) (idx fixnum))
- (let ((store (store matrix)))
- (declare (type (real-matrix-store-type *) store))
- (setf (aref store idx) (coerce value 'double-float))))
-
-;;
-(declaim (inline allocate-real-store))
-(defun allocate-real-store (size &optional (initial-element 0d0))
- (make-array size :element-type 'real-matrix-element-type
- :initial-element (coerce initial-element 'real-matrix-element-type)))
-
-;;
-(defmethod fill-matrix ((matrix real-matrix) (fill cl:real))
- (copy! fill matrix))
-
-(defmethod fill-matrix ((matrix real-matrix) (fill complex))
- (error "cannot fill a real matrix with a complex number,
-don't know how to coerce COMPLEX to REAL"))
-
-;;
-
-;;
-
-;;
-(defun make-real-matrix-dim (n m &key (fill 0.0d0) (order :row-major))
- "
- Syntax
- ======
- (MAKE-REAL-MATRIX-DIM n m [fill-element])
-
- Purpose
- =======
- Creates an NxM REAL-MATRIX with initial contents FILL-ELEMENT,
- the default 0.0d0
-
- See MAKE-REAL-MATRIX.
-"
- (declare (type fixnum n m))
- (let ((casted-fill
- (typecase fill
- (real-matrix-element-type fill)
- (cl:real (coerce fill 'real-matrix-element-type))
- (t (error "argument FILL-ELEMENT to MAKE-REAL-MATRIX-DIM must be a REAL")))))
- (declare (type real-matrix-element-type casted-fill))
- (multiple-value-bind (row-stride col-stride)
- (ecase order
- (:row-major (values m 1))
- (:col-major (values 1 n)))
- (make-instance 'real-matrix
- :nrows n :ncols m
- :row-stride row-stride :col-stride col-stride
- :store (allocate-real-store (* n m) casted-fill)))))
-
-;;; Make a matrix from a 2-D Lisp array
-(defun make-real-matrix-array (array &key (order :row-major))
- "
- Syntax
- ======
- (MAKE-REAL-MATRIX-ARRAY array)
-
- Purpose
- =======
- Creates a REAL-MATRIX with the same contents as ARRAY.
-"
- (let* ((n (array-dimension array 0))
- (m (array-dimension array 1))
- (size (* n m))
- (store (allocate-real-store size)))
- (declare (type fixnum n m size)
- (type (real-matrix-store-type *) store))
- (multiple-value-bind (row-stride col-stride)
- (ecase order
- (:row-major (values m 1))
- (:col-major (values 1 n)))
- (dotimes (i n)
- (declare (type fixnum i))
- (dotimes (j m)
- (declare (type fixnum j))
- (setf (aref store (store-indexing i j 0 row-stride col-stride))
- (coerce (aref array i j) 'real-matrix-element-type))))
- (make-instance 'real-matrix
- :nrows n :ncols m
- :row-stride row-stride :col-stride col-stride
- :store store))))
-
-;;
-(defun make-real-matrix-seq-of-seq (seq &key (order :row-major))
- (let* ((n (length seq))
- (m (length (elt seq 0)))
- (size (* n m))
- (store (allocate-real-store size)))
- (declare (type fixnum n m size)
- (type (real-matrix-store-type *) store))
- (multiple-value-bind (row-stride col-stride)
- (ecase order
- (:row-major (values m 1))
- (:col-major (values 1 n)))
- (dotimes (i n)
- (declare (type fixnum i))
- (let ((this-row (elt seq i)))
- (unless (= (length this-row) m)
- (error "Number of columns is not the same for all rows!"))
- (dotimes (j m)
- (declare (type fixnum j))
- (setf (aref store (store-indexing i j 0 row-stride col-stride))
- (coerce (elt this-row j) 'real-matrix-element-type)))))
- (make-instance 'real-matrix
- :nrows n :ncols m
- :row-stride row-stride :col-stride col-stride
- :store store))))
-
-;;
-(defun make-real-matrix-seq (seq &key (order :row-major))
- (let* ((n (length seq))
- (store (allocate-real-store n)))
- (declare (type fixnum n))
- (dotimes (k n)
- (declare (type fixnum k))
- (setf (aref store k) (coerce (elt seq k) 'real-matrix-element-type)))
- (ecase order
- (:row-major (make-instance 'real-matrix
- :nrows 1 :ncols n
- :row-stride n :col-stride 1
- :store store))
- (:col-major (make-instance 'real-matrix
- :nrows n :ncols 1
- :row-stride 1 :col-stride n
- :store store)))))
-
-
-;;
-(defun make-real-matrix-sequence (seq &key (order :row-major))
- (cond ((or (listp seq) (vectorp seq))
- (let ((peek (elt seq 0)))
- (cond ((or (listp peek) (vectorp peek))
- ;; We have a seq of seqs
- (make-real-matrix-seq-of-seq seq :order order))
- (t
- ;; Assume a simple sequence
- (make-real-matrix-seq seq :order order)))))
- ((arrayp seq)
- (make-real-matrix-array seq :order order))))
-
-;;
-(defun make-real-matrix (&rest args)
- "
- Syntax
- ======
- (MAKE-REAL-MATRIX {arg}*)
-
- Purpose
- =======
- Create a REAL-MATRIX.
-
- Examples
- ========
-
- (make-real-matrix n)
- square NxN matrix
- (make-real-matrix n m)
- NxM matrix
- (make-real-matrix '((1 2 3) (4 5 6)))
- 2x3 matrix:
-
- 1 2 3
- 4 5 6
-
- (make-real-matrix #((1 2 3) (4 5 6)))
- 2x3 matrix:
-
- 1 2 3
- 4 5 6
-
- (make-real-matrix #((1 2 3) #(4 5 6)))
- 2x3 matrix:
-
- 1 2 3
- 4 5 6
-
- (make-real-matrix #2a((1 2 3) (4 5 6)))
- 2x3 matrix:
-
- 1 2 3
- 4 5 6
- (make-real-matrix #(1 2 3 4))
- 4x1 matrix (column vector)
-
- 1
- 2
- 3
- 4
-
- (make-real-matrix #((1 2 3 4))
- 1x4 matrix (row vector)
-
- 1 2 3 4
-"
- (let ((nargs (length args)))
- (case nargs
- (1
- (let ((arg (first args)))
- (typecase arg
- (integer
- (assert (not (minusp arg)) nil
- "matrix dimension must be positive, not ~A" arg)
- (make-real-matrix-dim arg arg))
- (sequence
- (make-real-matrix-sequence arg))
- ((array * (* *))
- (make-real-matrix-array arg))
- (t (error "don't know how to make matrix from ~a" arg)))))
- (2
- (destructuring-bind (n m)
- args
- (assert (and (typep n '(integer 0))
- (typep n '(integer 0)))
- nil
- "cannot make a ~A x ~A matrix" n m)
- (make-real-matrix-dim n m)))
- (t
- (error "require 1 or 2 arguments to make a matrix")))))
-----------------------------------------------------------------------
Summary of changes:
src/level-1/axpy.lisp | 113 ++++++++++++++----
src/level-1/copy.lisp | 117 +++++++++++------
src/level-2/gemv.lisp | 18 ++--
src/level-3/gemm.lisp | 12 +-
src/old/complex-matrix.lisp | 290 -------------------------------------------
src/old/mplus.lisp | 92 ++++----------
src/old/real-matrix.lisp | 228 ---------------------------------
7 files changed, 207 insertions(+), 663 deletions(-)
delete mode 100644 src/old/complex-matrix.lisp
delete mode 100644 src/old/real-matrix.lisp
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2012-07-12 07:55:05
|
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 63d6b10a662cb7b8ad0b3dfd288db7a5f921abff (commit)
from c30fe6989eac02b31688733a8268ba0f4cc04891 (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 63d6b10a662cb7b8ad0b3dfd288db7a5f921abff
Author: Akshay Srinivasan <aks...@gm...>
Date: Thu Jul 12 13:18:06 2012 +0530
o More tweaks to matrix-multiplication.
Native lisp GEMM is now just about 30% slower than C on SBCL.
o Removed axpy, ddot versions from gemv.lisp. Lisp(SBCL) version is
sufficiently fast as it is anyway.
diff --git a/matlisp.asd b/matlisp.asd
index 26df9c3..6858f31 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -121,7 +121,11 @@
(:module "matlisp-level-2"
:pathname "level-2"
:depends-on ("matlisp-base" "matlisp-classes" "foreign-core" "matlisp-level-1")
- :components ((:file "gemv")))))
+ :components ((:file "gemv")))
+ (:module "matlisp-level-3"
+ :pathname "level-3"
+ :depends-on ("matlisp-base" "matlisp-classes" "foreign-core" "matlisp-level-1")
+ :components ((:file "gemm")))))
;; (defclass f2cl-cl-source-file (asdf:cl-source-file)
diff --git a/src/classes/matrix.lisp b/src/classes/matrix.lisp
index df19960..4ad783b 100644
--- a/src/classes/matrix.lisp
+++ b/src/classes/matrix.lisp
@@ -54,7 +54,7 @@
Purpose
=======
Return T if X is either a row or a column matrix."
- (or (row-vector-p matrix) (col-vector-p matrix)))
+ (or (row-matrix-p matrix) (col-matrix-p matrix)))
(definline square-matrix-p (matrix)
(and (square-p matrix) (matrix-p matrix)))
diff --git a/src/level-2/gemv.lisp b/src/level-2/gemv.lisp
index 392461c..c67af94 100644
--- a/src/level-2/gemv.lisp
+++ b/src/level-2/gemv.lisp
@@ -2,7 +2,8 @@
(defmacro generate-typed-gemv! (func
(matrix-class vector-class)
- (blas-gemv-func blas-axpy-func blas-dot-func blas-scal-func))
+ blas-gemv-func
+ fortran-call-lb)
;;Be very careful when using functions generated by this macro.
;;Indexes can be tricky and this has no safety net.
;;Use only after checking the arguments for compatibility.
@@ -14,71 +15,75 @@
(type ,vector-class x y)
(type symbol job))
(mlet*
- (((maj-a ld-a fop-a) (blas-matrix-compatible-p A job) :type (symbol index-type (string 1))))
- (if maj-a
- (let ((nr-a (aref (dimensions A) 0))
- (nc-a (aref (dimensions A) 1)))
- (declare (type index-type nr-a nc-a))
- (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)))
- (let ((nr-a (aref (dimensions A) 0))
- (nc-a (aref (dimensions A) 1))
- (rs-a (aref (strides A) 0))
- (cs-a (aref (strides A) 1)))
- (declare (type index-type nr-a nc-a rs-a cs-a))
- (when (eq job :t)
- (rotatef nr-a nc-a)
- (rotatef rs-a cs-a))
- (let ((sto-a (store a))
- (sto-x (store x))
- (std-x (aref (strides x) 0))
- (hd-x (head x))
- (sto-y (store y))
- (std-y (aref (strides y) 0))
- (hd-y (head y)))
- (declare (type ,(linear-array-type (getf opt :store-type)) sto-a sto-x sto-y)
- (type index-type std-y std-x hd-x hd-y))
- (if (> nr-a nc-a)
- (progn
- (unless (= beta 1d0)
- (,blas-scal-func nr-a beta
- sto-y std-y hd-y))
- (very-quickly
- (mod-dotimes (idx (idxv nc-a))
- with (linear-sums
- (of-x (strides x) (head x))
- (of-a (idxv cs-a) (head A)))
- do (,blas-axpy-func nr-a (* alpha ,(funcall (getf opt :reader) 'sto-x 'of-x))
- sto-a rs-a sto-y std-y
- of-a hd-y))))
- (very-quickly
- (mod-dotimes (idx (idxv nr-a))
- with (linear-sums
- (of-y (strides y) (head y))
- (of-a (idxv rs-a) (head A)))
- do (let ((val (* beta ,(funcall (getf opt :reader) 'sto-y 'of-y)))
- (dotp (,blas-dot-func nc-a
- sto-a cs-a sto-x std-x
- of-a hd-x)))
- (declare (type ,(getf opt :element-type) val dotp))
- ,(funcall (getf opt :value-writer)
- `(+ val (* alpha dotp)) 'sto-y 'of-y)))))))))
+ (((maj-A ld-A fop-A) (blas-matrix-compatible-p A job) :type (symbol index-type (string 1))))
+ (let ((call-fortran? (> (max (nrows A) (ncols A)) ,fortran-call-lb)))
+ (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
+ (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-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 (* beta ,(funcall (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)
+ summing (* ,(funcall (getf opt :reader) 'sto-x 'of-x)
+ ,(funcall (getf opt :reader) 'sto-A 'of-A)) into dotp of-type ,(getf opt :element-type)
+ finally ,(funcall (getf opt :value-writer)
+ `(+ (* alpha dotp) val) 'sto-y 'of-y))))))))))
y)))
+;;Tweakable
+(defparameter *real-gemv-fortran-call-lower-bound* 1000
+ "
+ If the maximum dimension in the MV is lower than this
+ parameter, then the lisp code is used by default, instead of
+ calling BLAS. Used to avoid the FFI overhead when calling
+ MM with small matrices.
+ Default set with SBCL on x86-64 linux. A reasonable value
+ is something between 800 and 2000.")
(generate-typed-gemv! real-typed-gemv!
- (real-matrix real-vector)
- (dgemv daxpy ddot dscal))
-
+ (real-matrix real-vector) dgemv
+ *real-gemv-fortran-call-lower-bound*)
+
+;;Tweakable
+(defparameter *complex-gemv-fortran-call-lower-bound* 600
+ "
+ If the maximum dimension in the MV is lower than this
+ parameter, then the lisp code is used by default, instead of
+ calling BLAS. Used to avoid the FFI overhead when calling
+ MM with small matrices.
+ Default set with SBCL on x86-64 linux. A reasonable value
+ is something between 400 and 1000.")
(generate-typed-gemv! complex-typed-gemv!
- (complex-matrix complex-vector)
- (zgemv zaxpy zdotu zscal))
-
+ (complex-matrix complex-vector) zgemv
+ *complex-gemv-fortran-call-lower-bound*)
;;---------------------------------------------------------------;;
;;Can't support "C" because the dual isn't supported by BLAS.
diff --git a/src/level-3/gemm.lisp b/src/level-3/gemm.lisp
index ae6fb35..d56732e 100644
--- a/src/level-3/gemm.lisp
+++ b/src/level-3/gemm.lisp
@@ -28,130 +28,153 @@
(in-package #:matlisp)
-;;Tweakable
-(defparameter *gemm-fortran-call-lower-bound* 50
- "
- If the maximum dimension in the MM is lower than this
- parameter, then the lisp code is used by default, instead of
- calling BLAS. Used to avoid the FFI overhead when calling
- MM with small matrices.
- Default set with SBCL on x86-64 linux. A reasonable value
- is something between 20 and 200.")
-
-(defmacro generate-typed-gemm! (func (matrix-class) (blas-gemm-func blas-gemv-func))
+(defmacro generate-typed-gemm! (func (matrix-class) (blas-gemm-func blas-gemv-func) fortran-lb-parameter)
(let* ((opt (get-tensor-class-optimization matrix-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class matrix-class)
`(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))
- (mlet* (((job-a job-b) (ecase job
+ (mlet* (((job-A job-B) (ecase job
(:nn (values :n :n))
(:nt (values :n :t))
(:tn (values :t :n))
(:tt (values :t :t)))
:type (symbol symbol))
- ((maj-a ld-a fop-a) (blas-matrix-compatible-p A job-a) :type (symbol index-type (string 1)))
- ((maj-b ld-b fop-b) (blas-matrix-compatible-p B job-b) :type (symbol index-type (string 1)))
- ((maj-c ld-c fop-c) (blas-matrix-compatible-p C :n) :type (symbol index-type nil)))
- (let ((call-fortran? (> (max (nrows C) (ncols C) (if (eq job-a :n) (ncols A) (nrows A)))
- *gemm-fortran-call-lower-bound*)))
+ ((maj-A ld-A fop-A) (blas-matrix-compatible-p A job-A) :type (symbol index-type (string 1)))
+ ((maj-B ld-B fop-B) (blas-matrix-compatible-p B job-B) :type (symbol index-type (string 1)))
+ ((maj-C ld-C fop-C) (blas-matrix-compatible-p C :n) :type (symbol index-type nil)))
+ (let ((call-fortran? (> (max (nrows C) (ncols C) (if (eq job-A :n) (ncols A) (nrows A)))
+ ,fortran-lb-parameter)))
(cond
- ((and maj-a maj-b maj-c call-fortran?)
- (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))
- (when (eq maj-c :row-major)
+ ((and maj-A maj-B maj-C call-fortran?)
+ (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))
+ (when (eq maj-C :row-major)
(rotatef A B)
- (rotatef ld-a ld-b)
- (rotatef maj-a maj-b)
- (rotatef nr-c nc-c)
- (setf (values fop-a fop-b)
- (values (fortran-snop fop-b) (fortran-snop fop-a))))
- (,blas-gemm-func fop-a fop-b nr-c nc-c dotl
- alpha (store A) ld-a (store B) ld-b
- beta (store C) ld-c
+ (rotatef ld-A ld-B)
+ (rotatef maj-A maj-B)
+ (rotatef nr-C nc-C)
+ (setf (values fop-A fop-B)
+ (values (fortran-snop fop-B) (fortran-snop fop-A))))
+ (,blas-gemm-func fop-A fop-B nr-C nc-C dotl
+ alpha (store A) ld-A (store B) ld-B
+ beta (store C) ld-C
(head A) (head B) (head C))))
- ((and maj-a call-fortran?)
- (let-typed ((nc-c (ncols C) :type index-type)
- (sto-c (store C) :type ,(linear-array-type (getf opt :store-type)))
- (stp-c (row-stride C) :type index-type)
- (nr-a (nrows A) :type index-type)
- (nc-a (ncols A) :type index-type)
- (sto-a (store A) :type ,(linear-array-type (getf opt :store-type)))
- (hd-a (head A) :type index-type)
- (stp-b (if (eq job-b :n) (row-stride B) (col-stride B)) :type index-type)
- (sto-b (store B) :type ,(linear-array-type (getf opt :store-type)))
- (strd-b (if (eq job-b :n) (col-stride B) (row-stride B)) :type index-type)
- (strd-c (col-stride C) :type index-type))
- (when (eq maj-a :row-major)
- (rotatef nr-a nc-a))
+ ((and maj-A call-fortran?)
+ (let-typed ((nc-C (ncols C) :type index-type)
+ (strd-C (col-stride C) :type index-type)
+ (stp-C (row-stride C) :type index-type)
+ (sto-C (store C) :type ,(linear-array-type (getf opt :store-type)))
+ ;
+ (nr-A (nrows A) :type index-type)
+ (nc-A (ncols A) :type index-type)
+ (sto-A (store A) :type ,(linear-array-type (getf opt :store-type)))
+ (hd-A (head A) :type index-type)
+ ;
+ (stp-B (if (eq job-B :n) (row-stride B) (col-stride B)) :type index-type)
+ (sto-B (store B) :type ,(linear-array-type (getf opt :store-type)))
+ (strd-B (if (eq job-B :n) (col-stride B) (row-stride B)) :type index-type))
+ (when (eq maj-A :row-major)
+ (rotatef nr-A nc-A))
(very-quickly
- (mod-dotimes (idx (idxv nc-c))
- with (linear-sums
- (of-b (idxv strd-b) (head B))
- (of-c (idxv strd-c) (head C)))
- do (,blas-gemv-func fop-a nr-a nc-a
- alpha sto-a ld-a
- sto-b stp-b
- beta sto-c stp-c
- hd-a of-b of-c)))))
- ((and maj-b call-fortran?)
- (let-typed ((nr-c (nrows C) :type index-type)
- (stp-c (col-stride C) :type index-type)
- (sto-c (store c) :type ,(linear-array-type (getf opt :store-type)))
- (stp-a (if (eq job-a :n) (col-stride A) (row-stride A)) :type index-type)
- (sto-a (store A) :type ,(linear-array-type (getf opt :store-type)))
- (nr-b (nrows B) :type index-type)
- (nc-b (ncols B) :type index-type)
- (hd-b (head B) :type index-type)
- (fop-b (fortran-snop fop-b) :type (string 1))
- (sto-b (store B) :type ,(linear-array-type (getf opt :store-type)))
- (strd-a (if (eq job-A :n) (row-stride A) (col-stride A)) :type index-type)
- (strd-c (row-stride C) :type index-type))
- (when (eq maj-b :row-major)
- (rotatef nr-b nc-b))
+ (loop repeat nc-C
+ for of-B of-type index-type = (head B) then (+ of-B strd-B)
+ for of-C of-type index-type = (head C) then (+ of-C strd-C)
+ do (,blas-gemv-func fop-A nr-A nc-A
+ alpha sto-A ld-A
+ sto-B stp-B
+ beta sto-C stp-C
+ hd-A of-B of-C)))))
+ ((and maj-B call-fortran?)
+ (let-typed ((nr-C (nrows C) :type index-type)
+ (stp-C (col-stride C) :type index-type)
+ (strd-C (row-stride C) :type index-type)
+ (sto-C (store c) :type ,(linear-array-type (getf opt :store-type)))
+ ;
+ (stp-A (if (eq job-A :n) (col-stride A) (row-stride A)) :type index-type)
+ (strd-A (if (eq job-A :n) (row-stride A) (col-stride A)) :type index-type)
+ (sto-A (store A) :type ,(linear-array-type (getf opt :store-type)))
+ ;
+ (nr-B (nrows B) :type index-type)
+ (nc-B (ncols B) :type index-type)
+ (hd-B (head B) :type index-type)
+ (fop-B (fortran-snop fop-B) :type (string 1))
+ (sto-B (store B) :type ,(linear-array-type (getf opt :store-type))))
+ (when (eq maj-B :row-major)
+ (rotatef nr-B nc-B))
(very-quickly
- (mod-dotimes (idx (idxv nr-c))
- with (linear-sums
- (of-A (idxv strd-a) (head A))
- (of-c (idxv strd-c) (head C)))
- do (,blas-gemv-func fop-b nr-b nc-b
- alpha sto-b ld-b
- sto-a stp-a
- beta sto-c stp-c
- hd-b of-a of-c)))))
+ (loop repeat nr-C
+ for of-A of-type index-type = (head A) then (+ of-A strd-A)
+ for of-C of-type index-type = (head C) then (+ of-C strd-C)
+ do (,blas-gemv-func fop-B nr-B nc-B
+ alpha sto-B ld-B
+ sto-A stp-A
+ beta sto-C stp-C
+ hd-B of-A of-C)))))
(t
- (let-typed ((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)
- (rstp-b (row-stride A) :type index-type)
- (cstp-b (col-stride A) :type index-type)
- (sto-a (store A) :type ,(linear-array-type (getf opt :store-type)))
- (sto-b (store B) :type ,(linear-array-type (getf opt :store-type)))
- (sto-c (store C) :type ,(linear-array-type (getf opt :store-type))))
- (when (eq job-a :t)
- (rotatef rstp-a cstp-a))
- (when (eq job-b :t)
- (rotatef rstp-b cstp-b))
+ (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-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))))
+ (when (eq job-A :t)
+ (rotatef rstp-A cstp-A))
+ (when (eq job-B :t)
+ (rotatef rstp-B cstp-B))
(very-quickly
- (mod-dotimes (idx (dimensions C))
- with (loop-order :row-major)
- with (linear-sums
- (of-a (idxv rstp-a 0) (head A))
- (of-b (idxv 0 cstp-b) (head B))
- (of-c (strides C) (head C)))
- do (let-typed ((val (* beta ,(funcall (getf opt :reader) 'sto-c 'of-c)) :type ,(getf opt :element-type)))
- (loop repeat dotl
- for dof-a of-type index-type = of-a then (+ dof-a cstp-a)
- for dof-b of-type index-type = of-b then (+ dof-b rstp-b)
- summing (* ,(funcall (getf opt :reader) 'sto-a 'dof-a)
- ,(funcall (getf opt :reader) 'sto-b 'dof-b)) into tmp of-type ,(getf opt :element-type)
- finally ,(funcall (getf opt :value-writer) '(+ (* alpha tmp) val) 'sto-c 'of-c))))))))))
+ (loop repeat nr-C
+ for rof-A of-type index-type = hd-A then (+ rof-A rstp-A)
+ for rof-C of-type index-type = hd-C then (+ rof-C rstp-C)
+ do (loop repeat nc-C
+ for cof-B of-type index-type = hd-B then (+ cof-B cstp-B)
+ for of-C of-type index-type = rof-C then (+ of-C cstp-C)
+ do (let-typed ((val (* beta ,(funcall (getf opt :reader) 'sto-C 'of-C)) :type ,(getf opt :element-type)))
+ (loop repeat dotl
+ for of-A of-type index-type = rof-A then (+ of-A cstp-A)
+ for of-B of-type index-type = cof-B then (+ of-B rstp-B)
+ summing (* ,(funcall (getf opt :reader) 'sto-A 'of-A)
+ ,(funcall (getf opt :reader) 'sto-B 'of-B)) into sum of-type ,(getf opt :element-type)
+ finally ,(funcall (getf opt :value-writer) '(+ (* alpha sum) val) 'sto-C 'of-C)))))))))))
C)))
-(generate-typed-gemm! real-typed-gemm! (real-matrix) (dgemm dgemv))
-(generate-typed-gemm! complex-typed-gemm! (complex-matrix) (zgemm zgemv))
+;;Tweakable
+(defparameter *real-gemm-fortran-call-lower-bound* 100
+ "
+ If the maximum dimension in the MM is lower than this
+ parameter, then the lisp code is used by default, instead of
+ calling BLAS. Used to avoid the FFI overhead when calling
+ MM with small matrices.
+ Default set with SBCL on x86-64 linux. A reasonable value
+ is something between 20 and 200.")
+(generate-typed-gemm! real-typed-gemm! (real-matrix) (dgemm dgemv)
+ *real-gemm-fortran-call-lower-bound*)
+
+;;Tweakable
+(defparameter *complex-gemm-fortran-call-lower-bound* 60
+ "
+ If the maximum dimension in the MM is lower than this
+ parameter, then the lisp code is used by default, instead of
+ calling BLAS. Used to avoid the FFI overhead when calling
+ MM with small matrices.
+ Default set with SBCL on x86-64 linux. A reasonable value
+ is something between 20 and 200.")
+(generate-typed-gemm! complex-typed-gemm! (complex-matrix) (zgemm zgemv)
+ *complex-gemm-fortran-call-lower-bound*)
;;---------------------------------------------------------------;;
(defgeneric gemm! (alpha A B beta C &optional job)
diff --git a/tests/loopy-tests.lisp b/tests/loopy-tests.lisp
index de334ec..e17a747 100644
--- a/tests/loopy-tests.lisp
+++ b/tests/loopy-tests.lisp
@@ -39,27 +39,108 @@
(declare (type real-tensor t-a t-b t-c))
(let ((st-a (store t-a))
(st-b (store t-b))
- (st-c (store t-c)))
- (declare (type (real-array *) st-a st-b st-c))
- (very-quickly
- (mod-dotimes (idx (dimensions t-a))
- with (linear-sums
- (of-a (strides t-a))
- (of-b (strides t-b))
- (of-c (strides t-c)))
- do (setf (aref st-a of-a) (random 1d0)
- (aref st-b of-b) (random 1d0)
- (aref st-c of-c) 0d0)))
- (time
+ (st-c (store t-c))
+ (rstrd-a (row-stride t-a))
+ (cstrd-a (col-stride t-a))
+ (rstrd-b (row-stride t-b))
+ (cstrd-b (col-stride t-b))
+ (rstrd-c (row-stride t-c))
+ (cstrd-c (col-stride t-c))
+ (nr-c (nrows t-c))
+ (nc-c (ncols t-c))
+ (nc-a (ncols t-a))
+ (hd-a (head t-a))
+ (hd-b (head t-b))
+ (hd-c (head t-c)))
+ (declare (type (real-array *) st-a st-b st-c)
+ (type index-type rstrd-a cstrd-a rstrd-b cstrd-b rstrd-c cstrd-c nr-c
+ nc-c nc-a hd-a hd-b hd-c))
+ (mod-dotimes (idx (dimensions t-a))
+ with (linear-sums
+ (of-a (strides t-a))
+ (of-b (strides t-b))
+ (of-c (strides t-c)))
+ do (setf (aref st-a of-a) (random 1d0)
+ (aref st-b of-b) (random 1d0)
+ (aref st-c of-c) 0d0))
+ (time
(very-quickly
- (mod-dotimes (idx (idxv n n n))
+ (loop repeat nr-c
+ for rof-a of-type index-type = hd-a then (+ rof-a rstrd-a)
+ for rof-c of-type index-type = hd-c then (+ rof-c rstrd-c)
+ do (loop repeat nc-c
+ for cof-b of-type index-type = hd-b then (+ cof-b cstrd-b)
+ for of-c of-type index-type = rof-c then (+ of-c cstrd-c)
+ do (loop repeat nc-a
+ for of-a of-type index-type = rof-a then (+ of-a cstrd-a)
+ for of-b of-type index-type = cof-b then (+ of-b rstrd-b)
+ summing (* (aref st-a of-a) (aref st-b of-b)) into sum of-type real-type
+ finally (setf (aref st-c of-c) sum))))
+ #+nil(mod-dotimes (idx (dimensions t-c))
with (loop-order :row-major)
with (linear-sums
- (of-a (idxv n 1 0))
- (of-b (idxv 0 n 1))
- (of-c (idxv n 0 1)))
+ (of-a (idxv (row-stride t-a) 0) (head t-a))
+ (of-b (idxv 0 (col-stride t-b)) (head t-b))
+ (of-c (strides t-c) (head t-c)))
do (incf (aref st-c of-c) (* (aref st-a of-a) (aref st-b of-b)))))))))
+
+
+(defun test-mm-ddot (n)
+ (let ((t-a (make-real-tensor n n))
+ (t-b (make-real-tensor n n))
+ (t-c (make-real-tensor n n)))
+ (declare (type real-tensor t-a t-b t-c))
+ (let ((st-a (store t-a))
+ (st-b (store t-b))
+ (st-c (store t-c))
+ (rstrd-a (row-stride t-a))
+ (cstrd-a (col-stride t-a))
+ (rstrd-b (row-stride t-b))
+ (cstrd-b (col-stride t-b))
+ (rstrd-c (row-stride t-c))
+ (cstrd-c (col-stride t-c))
+ (nr-c (nrows t-c))
+ (nc-c (ncols t-c))
+ (nc-a (ncols t-a))
+ (hd-a (head t-a))
+ (hd-b (head t-b))
+ (hd-c (head t-c)))
+ (declare (type (real-array *) st-a st-b st-c)
+ (type index-type rstrd-a cstrd-a rstrd-b cstrd-b rstrd-c cstrd-c nr-c
+ nc-c nc-a hd-a hd-b hd-c))
+ (mod-dotimes (idx (dimensions t-a))
+ with (linear-sums
+ (of-a (strides t-a))
+ (of-b (strides t-b))
+ (of-c (strides t-c)))
+ do (setf (aref st-a of-a) (random 1d0)
+ (aref st-b of-b) (random 1d0)
+ (aref st-c of-c) 0d0))
+ (time
+ (very-quickly
+ (loop repeat nr-c
+ for rof-a of-type index-type = hd-a then (+ rof-a rstrd-a)
+ for rof-c of-type index-type = hd-c then (+ rof-c rstrd-c)
+ do (loop repeat nc-c
+ for cof-b of-type index-type = hd-b then (+ cof-b cstrd-b)
+ for of-c of-type index-type = rof-c then (+ of-c cstrd-c)
+ do (let ((dotp (ddot nc-a
+ st-a cstrd-a
+ st-b rstrd-b
+ rof-a cof-b)))
+ (declare (type real-type dotp))
+ (setf (aref st-c of-c) dotp))))
+
+ #+nil(mod-dotimes (idx (dimensions t-c))
+ with (loop-order :row-major)
+ with (linear-sums
+ (of-a (idxv (row-stride t-a) 0) (head t-a))
+ (of-b (idxv 0 (col-stride t-b)) (head t-b))
+ (of-c (strides t-c) (head t-c)))
+ do (incf (aref st-c of-c) (* (aref st-a of-a) (aref st-b of-b)))))))))
+
+
(defun test-mm-daxpy (n)
(let* ((t-a (make-real-tensor n n))
(t-b (make-real-tensor n n))
-----------------------------------------------------------------------
Summary of changes:
matlisp.asd | 6 +-
src/classes/matrix.lisp | 2 +-
src/level-2/gemv.lisp | 127 ++++++++++++++-------------
src/level-3/gemm.lisp | 231 ++++++++++++++++++++++++++---------------------
tests/loopy-tests.lisp | 113 ++++++++++++++++++++----
5 files changed, 296 insertions(+), 183 deletions(-)
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2012-07-10 11:45:42
|
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 c30fe6989eac02b31688733a8268ba0f4cc04891 (commit)
from 83d461878939dc99bbe82269d113041fdbdc9e52 (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 c30fe6989eac02b31688733a8268ba0f4cc04891
Author: Akshay Srinivasan <aks...@gm...>
Date: Tue Jul 10 16:41:01 2012 +0530
o Gemm! now works
diff --git a/src/level-2/gemv.lisp b/src/level-2/gemv.lisp
index 29a4d64..392461c 100644
--- a/src/level-2/gemv.lisp
+++ b/src/level-2/gemv.lisp
@@ -209,9 +209,9 @@
(defmethod gemv ((alpha number) (A standard-matrix) (x standard-vector)
(beta number) (y real-vector) &optional (job :n))
(let ((result (if (or (complexp alpha) (complexp beta)
- (typep A 'complex-matrix) (typep x'complex-matrix))
+ (typep A 'complex-matrix) (typep x 'complex-vector))
(make-complex-tensor (aref (dimensions y) 0))
(make-real-tensor (aref (dimensions y) 0)))))
- (copy! y result)
+ (scal! y result)
(gemv! alpha A x beta result job)))
diff --git a/src/level-3/gemm.lisp b/src/level-3/gemm.lisp
index c7d2e00..ae6fb35 100644
--- a/src/level-3/gemm.lisp
+++ b/src/level-3/gemm.lisp
@@ -28,6 +28,16 @@
(in-package #:matlisp)
+;;Tweakable
+(defparameter *gemm-fortran-call-lower-bound* 50
+ "
+ If the maximum dimension in the MM is lower than this
+ parameter, then the lisp code is used by default, instead of
+ calling BLAS. Used to avoid the FFI overhead when calling
+ MM with small matrices.
+ Default set with SBCL on x86-64 linux. A reasonable value
+ is something between 20 and 200.")
+
(defmacro generate-typed-gemm! (func (matrix-class) (blas-gemm-func blas-gemv-func))
(let* ((opt (get-tensor-class-optimization matrix-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class matrix-class)
@@ -44,113 +54,107 @@
((maj-a ld-a fop-a) (blas-matrix-compatible-p A job-a) :type (symbol index-type (string 1)))
((maj-b ld-b fop-b) (blas-matrix-compatible-p B job-b) :type (symbol index-type (string 1)))
((maj-c ld-c fop-c) (blas-matrix-compatible-p C :n) :type (symbol index-type nil)))
- (if (and maj-a maj-b maj-c)
- (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))
- (when (eq maj-c :row-major)
- (rotatef A B)
- (rotatef ld-a ld-b)
- (rotatef maj-a maj-b)
- (rotatef nr-c nc-c)
- (setf (values fop-a fop-b)
- (values (fortran-snop fop-b) (fortran-snop fop-a))))
- (,blas-gemm-func fop-a fop-b nr-c nc-c dotl
- alpha (store A) ld-a (store B) ld-b
- beta (store C) ld-c
- (head A) (head B) (head C)))
- (cond
- (maj-a
- (let-typed ((nc-c (ncols C) :type index-type)
- (sto-c (store C) :type ,(linear-array-type (getf opt :store-type)))
- (stp-c (row-stride C) :type index-type)
- (nr-a (nrows A) :type index-type)
- (nc-a (ncols A) :type index-type)
- (sto-a (store A) :type ,(linear-array-type (getf opt :store-type)))
- (hd-a (head A) :type index-type)
- (stp-b (if (eq job-b :n) (row-stride B) (col-stride B)) :type index-type)
- (sto-b (store B) :type ,(linear-array-type (getf opt :store-type)))
- (strd-b (if (eq job-b :n) (col-stride B) (row-stride B)) :type index-type)
- (strd-c (col-stride C) :type index-type))
- (when (eq maj-a :row-major)
- (rotatef nr-a nc-a))
- (very-quickly
- (mod-dotimes (idx (idxv nc-c))
- with (linear-sums
- (of-b (idxv strd-b) (head B))
- (of-c (idxv strd-c) (head C)))
- do (,blas-gemv-func fop-a nr-a nc-a
- alpha sto-a ld-a
- sto-b stp-b
- beta sto-c stp-c
- hd-a of-b of-c)))))
- (maj-b
- (let-typed ((nr-c (nrows C) :type index-type)
- (stp-c (col-stride C) :type index-type)
- (sto-c (store c) :type ,(linear-array-type (getf opt :store-type)))
- (stp-a (if (eq job-a :n) (col-stride B) (row-stride B)) :type index-type)
- (sto-a (store A) :type ,(linear-array-type (getf opt :store-type)))
- (nr-b (nrows B) :type index-type)
- (nc-b (ncols B) :type index-type)
- (hd-b (head B) :type index-type)
- (fop-b (fortran-snop fop-b) :type (string 1))
- (sto-b (store B) :type ,(linear-array-type (getf opt :store-type)))
- (strd-a (if (eq job-A :n) (row-stride A) (col-stride A)) :type index-type)
- (strd-c (row-stride C) :type index-type))
- (when (eq maj-b :row-major)
- (rotatef nr-b nc-b))
- (very-quickly
- (mod-dotimes (idx (idxv nr-c))
- with (linear-sums
- (of-A (idxv strd-a) (head A))
- (of-c (idxv strd-c) (head C)))
- do (,blas-gemv-func fop-b nr-b nc-b
- alpha sto-b ld-b
- sto-a stp-a
- beta sto-c stp-c
- hd-b of-a of-c)))))
- (t
- (let-typed ((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)
- (rstp-b (row-stride A) :type index-type)
- (cstp-b (col-stride A) :type index-type)
- (sto-a (store A) :type ,(linear-array-type (getf opt :store-type)))
- (sto-b (store B) :type ,(linear-array-type (getf opt :store-type)))
- (sto-c (store C) :type ,(linear-array-type (getf opt :store-type))))
- (when (eq job-a :t)
- (rotatef rstp-a cstp-a))
- (when (eq job-b :t)
- (rotatef rstp-b cstp-b))
- (very-quickly
- (mod-dotimes (idx (dimensions C))
- with (loop-order :row-major)
- with (linear-sums
- (of-a (idxv rstp-a 0) (head A)) ; cstp-a))
- (of-b (idxv 0 cstp-b) (head B)) ; rstp-b))
- (of-c (strides C) (head C))) ; 0)))
- do (let-typed ((tmp (,(getf opt :coercer) 0) :type ,(getf opt :element-type))
- (val (* beta ,(funcall (getf opt :reader) 'sto-c 'of-c)) :type ,(getf opt :element-type)))
- (loop repeat dotl
- for dof-a of-type index-type = of-a then (+ dof-a cstp-a)
- for dof-b of-type index-type = of-b then (+ dof-b rstp-b)
- do (incf tmp (* ,(funcall (getf opt :reader) 'sto-a 'dof-a)
- ,(funcall (getf opt :reader) 'sto-b 'dof-b))))
- ,(funcall (getf opt :value-writer) '(+ (* alpha tmp) (* beta val)) 'sto-c 'of-c)))))))))
+ (let ((call-fortran? (> (max (nrows C) (ncols C) (if (eq job-a :n) (ncols A) (nrows A)))
+ *gemm-fortran-call-lower-bound*)))
+ (cond
+ ((and maj-a maj-b maj-c call-fortran?)
+ (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))
+ (when (eq maj-c :row-major)
+ (rotatef A B)
+ (rotatef ld-a ld-b)
+ (rotatef maj-a maj-b)
+ (rotatef nr-c nc-c)
+ (setf (values fop-a fop-b)
+ (values (fortran-snop fop-b) (fortran-snop fop-a))))
+ (,blas-gemm-func fop-a fop-b nr-c nc-c dotl
+ alpha (store A) ld-a (store B) ld-b
+ beta (store C) ld-c
+ (head A) (head B) (head C))))
+ ((and maj-a call-fortran?)
+ (let-typed ((nc-c (ncols C) :type index-type)
+ (sto-c (store C) :type ,(linear-array-type (getf opt :store-type)))
+ (stp-c (row-stride C) :type index-type)
+ (nr-a (nrows A) :type index-type)
+ (nc-a (ncols A) :type index-type)
+ (sto-a (store A) :type ,(linear-array-type (getf opt :store-type)))
+ (hd-a (head A) :type index-type)
+ (stp-b (if (eq job-b :n) (row-stride B) (col-stride B)) :type index-type)
+ (sto-b (store B) :type ,(linear-array-type (getf opt :store-type)))
+ (strd-b (if (eq job-b :n) (col-stride B) (row-stride B)) :type index-type)
+ (strd-c (col-stride C) :type index-type))
+ (when (eq maj-a :row-major)
+ (rotatef nr-a nc-a))
+ (very-quickly
+ (mod-dotimes (idx (idxv nc-c))
+ with (linear-sums
+ (of-b (idxv strd-b) (head B))
+ (of-c (idxv strd-c) (head C)))
+ do (,blas-gemv-func fop-a nr-a nc-a
+ alpha sto-a ld-a
+ sto-b stp-b
+ beta sto-c stp-c
+ hd-a of-b of-c)))))
+ ((and maj-b call-fortran?)
+ (let-typed ((nr-c (nrows C) :type index-type)
+ (stp-c (col-stride C) :type index-type)
+ (sto-c (store c) :type ,(linear-array-type (getf opt :store-type)))
+ (stp-a (if (eq job-a :n) (col-stride A) (row-stride A)) :type index-type)
+ (sto-a (store A) :type ,(linear-array-type (getf opt :store-type)))
+ (nr-b (nrows B) :type index-type)
+ (nc-b (ncols B) :type index-type)
+ (hd-b (head B) :type index-type)
+ (fop-b (fortran-snop fop-b) :type (string 1))
+ (sto-b (store B) :type ,(linear-array-type (getf opt :store-type)))
+ (strd-a (if (eq job-A :n) (row-stride A) (col-stride A)) :type index-type)
+ (strd-c (row-stride C) :type index-type))
+ (when (eq maj-b :row-major)
+ (rotatef nr-b nc-b))
+ (very-quickly
+ (mod-dotimes (idx (idxv nr-c))
+ with (linear-sums
+ (of-A (idxv strd-a) (head A))
+ (of-c (idxv strd-c) (head C)))
+ do (,blas-gemv-func fop-b nr-b nc-b
+ alpha sto-b ld-b
+ sto-a stp-a
+ beta sto-c stp-c
+ hd-b of-a of-c)))))
+ (t
+ (let-typed ((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)
+ (rstp-b (row-stride A) :type index-type)
+ (cstp-b (col-stride A) :type index-type)
+ (sto-a (store A) :type ,(linear-array-type (getf opt :store-type)))
+ (sto-b (store B) :type ,(linear-array-type (getf opt :store-type)))
+ (sto-c (store C) :type ,(linear-array-type (getf opt :store-type))))
+ (when (eq job-a :t)
+ (rotatef rstp-a cstp-a))
+ (when (eq job-b :t)
+ (rotatef rstp-b cstp-b))
+ (very-quickly
+ (mod-dotimes (idx (dimensions C))
+ with (loop-order :row-major)
+ with (linear-sums
+ (of-a (idxv rstp-a 0) (head A))
+ (of-b (idxv 0 cstp-b) (head B))
+ (of-c (strides C) (head C)))
+ do (let-typed ((val (* beta ,(funcall (getf opt :reader) 'sto-c 'of-c)) :type ,(getf opt :element-type)))
+ (loop repeat dotl
+ for dof-a of-type index-type = of-a then (+ dof-a cstp-a)
+ for dof-b of-type index-type = of-b then (+ dof-b rstp-b)
+ summing (* ,(funcall (getf opt :reader) 'sto-a 'dof-a)
+ ,(funcall (getf opt :reader) 'sto-b 'dof-b)) into tmp of-type ,(getf opt :element-type)
+ finally ,(funcall (getf opt :value-writer) '(+ (* alpha tmp) val) 'sto-c 'of-c))))))))))
C)))
(generate-typed-gemm! real-typed-gemm! (real-matrix) (dgemm dgemv))
(generate-typed-gemm! complex-typed-gemm! (complex-matrix) (zgemm zgemv))
+;;---------------------------------------------------------------;;
-(let ((A (tensor-realpart~
- (make-complex-tensor '((1 2 3)
- (4 5 6)
- (7 8 9)))))
- (C (make-real-tensor 3 3)))
- (real-typed-gemm! 1d0 A A 0d0 C :nn))
-
-;;;;
-(defgeneric gemm! (alpha a b beta c &optional job)
+(defgeneric gemm! (alpha A B beta C &optional job)
(:documentation
"
Syntax
@@ -174,169 +178,79 @@
:NN (default) alpha * A * B + beta * C
:TN alpha * A'* B + beta * C
:NT alpha * A * B'+ beta * C
- :TT alpha * A'* B'+ beta * C
-
- Note
- ====
- Take caution when using GEMM! as follows:
-
- (GEMM! alpha a b beta b)
-
- or
-
- (GEMM! alpha a b beta a)
-
- The results may be unpredictable depending
- on the underlying DGEMM, ZGEMM routines
- from BLAS, ATLAS or LIBCRUFT.
-"))
-
-(defmethod gemm! :before ((alpha number) (a standard-matrix) (b standard-matrix)
- (beta number) (c standard-matrix)
- &optional (job :nn))
- (let ((n-a (nrows a))
- (m-a (ncols a))
- (n-b (nrows b))
- (m-b (ncols b))
- (n-c (nrows c))
- (m-c (ncols c)))
- (declare (type fixnum n-a m-a n-b m-b n-c m-c))
+ :TT alpha * A'* B'+ beta * C
+")
+ (:method :before ((alpha number) (A standard-matrix) (B standard-matrix)
+ (beta number) (C standard-matrix)
+ &optional (job :nn))
+ (let ((nr-a (nrows A))
+ (nc-a (ncols A))
+ (nr-b (nrows B))
+ (nc-b (ncols B))
+ (nr-c (nrows C))
+ (nc-c (ncols C)))
+ (declare (type index-type nr-a nc-a nr-b nc-b nr-c nc-c))
(case job
(:nn t)
- (:tn (rotatef n-a m-a))
- (:nt (rotatef n-b m-b))
- (:tt (rotatef n-a m-a) (rotatef n-b m-b))
- (t (error "argument JOB to GEMM! is not recognized")))
+ (:tn (rotatef nr-a nc-a))
+ (:nt (rotatef nr-b nc-b))
+ (:tt (rotatef nr-a nc-a) (rotatef nr-b nc-b))
+ (t (error 'invalid-value :given job :expected '(member job '(:nn :tn :nt :tt)))))
+ (assert (not (or (eq A C) (eq B C))) nil 'invalid-arguments
+ :message "GEMM!: C = {A or B} is not allowed.")
+ (assert (and (= nr-c nr-a)
+ (= nc-a nr-b)
+ (= nc-b nc-c)) nil 'tensor-dimension-mismatch))))
- (if (not (and (= m-a n-b)
- (= n-a n-c)
- (= m-b m-c)))
- (error "dimensions of A,B,C given to GEMM! do not match"))))
-
-;;
-(generate-typed-gemm!-func real-double-gemm!-typed
- double-float real-matrix-store-type real-matrix
- blas:dgemm real-double-gemv!-typed)
-
-(defmethod gemm! ((alpha cl:real) (a real-matrix) (b real-matrix)
- (beta cl:real) (c real-matrix)
+(defmethod gemm! ((alpha number) (a real-matrix) (b real-matrix)
+ (beta number) (c real-matrix)
&optional (job :nn))
- (real-double-gemm!-typed (coerce alpha 'double-float) a b
- (coerce beta 'double-float) c
- job))
-
-;;
-(generate-typed-gemm!-func complex-double-gemm!-typed
- complex-double-float complex-matrix-store-type complex-matrix
- blas:zgemm complex-double-gemv!-typed)
+ (real-typed-gemm! (coerce-real alpha) a b
+ (coerce-real beta) c job))
(defmethod gemm! ((alpha number) (a complex-matrix) (b complex-matrix)
(beta number) (c complex-matrix)
&optional (job :nn))
- (complex-double-gemm!-typed (complex-coerce alpha) a b
- (complex-coerce beta) c job))
+ (complex-typed-gemm! (coerce-complex alpha) a b
+ (coerce-complex beta) c job))
-;
(defmethod gemm! ((alpha number) (a real-matrix) (b real-matrix)
- (beta cl:real) (c complex-matrix)
- &optional (job :nn))
- (let ((r-c (mrealpart~ c)))
- (declare (type real-matrix c))
- (gemm! alpha a b 0d0 r-c job))
- c)
-
-(defmethod gemm! ((alpha number) (a real-matrix) (b real-matrix)
- (beta complex) (c complex-matrix)
+ (beta number) (c complex-matrix)
&optional (job :nn))
- (let ((r-c (mrealpart~ c))
- (c-be (complex-coerce beta)))
- (declare (type real-matrix c)
- (type complex-double-float c-al))
- (scal! c-be c)
- (gemm! alpha a b 1d0 r-c job))
- c)
+ (unless (= beta 1)
+ (scal! beta c))
+ (unless (= alpha 0)
+ (if (complexp alpha)
+ (let ((A.x (make-real-tensor (nrows c) (ncols c)))
+ (vw.c (tensor-realpart~ c)))
+ (real-typed-gemm! (coerce-real 1) A B (coerce-real 0) A.x job)
+ ;;Re
+ (axpy! (realpart alpha) A.x vw.c)
+ ;;Im
+ (incf (head vw.c))
+ (axpy! (imagpart alpha) A.x vw.c))
+ (let ((vw.c (tensor-realpart~ c)))
+ (real-typed-gemm! (coerce-real alpha) A B
+ (coerce-real 1) vw.c job))))
+ C)
-;
(defmethod gemm! ((alpha number) (a real-matrix) (b complex-matrix)
- (beta complex) (c complex-matrix)
- &optional (job :nn))
- (scal! (complex-coerce beta) c)
- (gemm! alpha a b 1d0 c job))
-
-(defmethod gemm! ((alpha cl:real) (a real-matrix) (b complex-matrix)
- (beta cl:real) (c complex-matrix)
- &optional (job :nn))
- (let ((r-b (mrealpart~ b))
- (i-b (mimagpart~ b))
- (r-c (mrealpart~ c))
- (i-c (mimagpart~ c))
- (r-al (coerce alpha 'double-float))
- (r-be (coerce beta 'double-float)))
- (declare (type real-matrix r-b i-b r-c i-c)
- (type double-float r-al r-be))
- (real-double-gemm!-typed r-al a r-b r-be r-c job)
- (real-double-gemm!-typed r-al a i-b r-be i-c job)))
-
-(defmethod gemm! ((alpha complex) (a real-matrix) (b complex-matrix)
- (beta cl:real) (c complex-matrix)
+ (beta number) (c complex-matrix)
&optional (job :nn))
- (let ((r-b (mrealpart~ b))
- (i-b (mimagpart~ b))
- (r-c (mrealpart~ c))
- (i-c (mimagpart~ c))
- (r-al (coerce (realpart alpha) 'double-float))
- (i-al (coerce (imagpart alpha) 'double-float))
- (r-be (coerce beta 'double-float)))
- (declare (type real-matrix r-b i-b r-c i-c)
- (type double-float r-al r-be))
- ;;
- (real-double-gemm!-typed r-al a r-b r-be r-c job)
- (real-double-gemm!-typed (- i-al) a i-b 1d0 r-c job)
- ;;
- (real-double-gemm!-typed r-al a i-b r-be i-c job)
- (real-double-gemm!-typed i-al a r-b 1d0 i-c job)))
+ (let ((A.cplx (copy! A (make-complex-tensor (nrows a) (ncols a)))))
+ (complex-typed-gemm! (coerce-complex alpha) A.cplx B
+ (coerce-complex beta) C job))
+ C)
-;
(defmethod gemm! ((alpha number) (a complex-matrix) (b real-matrix)
- (beta complex) (c complex-matrix)
- &optional (job :nn))
- (scal! (complex-coerce beta) c)
- (gemm! alpha a b 1d0 c job))
-
-(defmethod gemm! ((alpha cl:real) (a complex-matrix) (b real-matrix)
- (beta cl:real) (c complex-matrix)
- &optional (job :nn))
- (let ((r-a (mrealpart~ a))
- (i-a (mimagpart~ a))
- (r-c (mrealpart~ c))
- (i-c (mimagpart~ c))
- (r-al (coerce alpha 'double-float))
- (r-be (coerce beta 'double-float)))
- (declare (type real-matrix r-a i-a r-c i-c)
- (type double-float r-al r-be))
- (real-double-gemm!-typed r-al r-a b r-be r-c job)
- (real-double-gemm!-typed r-al i-a b r-be i-c job)))
-
-(defmethod gemm! ((alpha complex) (a complex-matrix) (b real-matrix)
- (beta cl:real) (c complex-matrix)
+ (beta number) (c complex-matrix)
&optional (job :nn))
- (let ((r-a (mrealpart~ a))
- (i-a (mimagpart~ a))
- (r-c (mrealpart~ c))
- (i-c (mimagpart~ c))
- (r-al (coerce (realpart alpha) 'double-float))
- (i-al (coerce (imagpart alpha) 'double-float))
- (r-be (coerce beta 'double-float)))
- (declare (type real-matrix r-a i-a r-c i-c)
- (type double-float r-al r-be))
- ;;
- (real-double-gemm!-typed r-al r-a b r-be r-c job)
- (real-double-gemm!-typed (- i-al) i-a b 1d0 r-c job)
- ;;
- (real-double-gemm!-typed r-al i-a b r-be i-c job)
- (real-double-gemm!-typed i-al r-a b 1d0 i-c job)))
+ (let ((B.cplx (copy! B (make-complex-tensor (nrows B) (ncols B)))))
+ (complex-typed-gemm! (coerce-complex alpha) A B.cplx
+ (coerce-complex beta) C job))
+ C)
-;;;;
+;;---------------------------------------------------------------;;
(defgeneric gemm (alpha a b beta c &optional job)
(:documentation
"
@@ -364,38 +278,20 @@
:TT alpha * A'* B'+ beta * C
"))
-;;
-(defmethod gemm :before ((alpha number) (a standard-matrix) (b standard-matrix)
- (beta number) (c standard-matrix)
- &optional (job :nn))
- (let ((n-a (nrows a))
- (m-a (ncols a))
- (n-b (nrows b))
- (m-b (ncols b))
- (n-c (nrows c))
- (m-c (ncols c)))
- (declare (type fixnum n-a m-a n-b m-b n-c m-c))
-
- (case job
- (:nn t)
- (:tn (rotatef n-a m-a))
- (:nt (rotatef n-b m-b))
- (:tt (rotatef n-a m-a) (rotatef n-b m-b))
- (t (error "argument JOB to GEMM! is not recognized")))
-
- (if (not (and (= m-a n-b)
- (= n-a n-c)
- (= m-b m-c)))
- (error "dimensions of A,B,C given to GEMM! do not match"))))
+(defmethod gemm ((alpha number) (a standard-matrix) (b standard-matrix)
+ (beta number) (c real-matrix)
+ &optional (job :nn))
+ (let ((result (copy C)))
+ (gemm! alpha A B beta result job)))
;; if all args are not real then at least one of them
;; is complex, so we need to call GEMM! with a complex C
(defmethod gemm ((alpha number) (a standard-matrix) (b standard-matrix)
(beta number) (c standard-matrix)
&optional (job :nn))
- (let ((result (scal (if (or (typep alpha 'complex) (typep a 'complex-matrix)
- (typep b 'complex-matrix) (typep beta 'complex))
- (complex-coerce beta)
- beta)
- c)))
- (gemm! alpha a b 1d0 result job)))
+ (let ((result (if (or (complexp alpha) (complexp beta)
+ (typep a 'complex-matrix) (typep b 'complex-matrix))
+ (make-complex-tensor (nrows C) (ncols C))
+ (make-real-tensor (nrows C) (ncols C)))))
+ (copy! C result)
+ (gemm! alpha A B beta result job)))
-----------------------------------------------------------------------
Summary of changes:
src/level-2/gemv.lisp | 4 +-
src/level-3/gemm.lisp | 448 +++++++++++++++++++------------------------------
2 files changed, 174 insertions(+), 278 deletions(-)
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2012-07-10 07:38:56
|
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 83d461878939dc99bbe82269d113041fdbdc9e52 (commit)
from 6770dbf44302c7d981ea50386827106748b8f3cc (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 83d461878939dc99bbe82269d113041fdbdc9e52
Author: Akshay Srinivasan <aks...@gm...>
Date: Tue Jul 10 13:04:32 2012 +0530
o Added gemm generating macro.
diff --git a/README b/README
index 029550d..3bec6c9 100644
--- a/README
+++ b/README
@@ -29,6 +29,7 @@ This is the development branch of Matlisp.
* QUADPACK: Move from f2cl-ed version to the Fortran one.
* MINPACK: Move from f2cl-ed version to the Fortran one.
* ODEPACK: Add abstraction for DLSODE, and DLSODAR may others too.
+ * Add a Lisp generic wrapper for every BLAS func {low priority}.
*** Syntactic sugar
* Add array slicing macros
diff --git a/packages.lisp b/packages.lisp
index b90e858..190bca9 100644
--- a/packages.lisp
+++ b/packages.lisp
@@ -74,7 +74,7 @@
#:list-dimensions
;;Macros
#:when-let #:if-let #:if-ret #:with-gensyms #:let-rec
- #:mlet* #:make-array-allocator
+ #:mlet* #:make-array-allocator #:let-typed
#:nconsc #:define-constant
#:macrofy
;;
diff --git a/src/classes/matrix.lisp b/src/classes/matrix.lisp
index ad059aa..df19960 100644
--- a/src/classes/matrix.lisp
+++ b/src/classes/matrix.lisp
@@ -1,8 +1,5 @@
(in-package #:matlisp)
-;;
-
-
(definline nrows (matrix)
(declare (type standard-matrix matrix))
(aref (dimensions matrix) 0))
@@ -26,9 +23,6 @@
(list (aref dims 0) (aref dims 1))))
;;
-
-
-;;
(definline row-matrix-p (matrix)
"
Syntax
@@ -62,32 +56,32 @@
Return T if X is either a row or a column matrix."
(or (row-vector-p matrix) (col-vector-p matrix)))
-(defun square-matrix-p (matrix)
+(definline square-matrix-p (matrix)
(and (square-p matrix) (matrix-p matrix)))
-;;
-(defgeneric fill-matrix (matrix fill-element)
- (:documentation
- "
- Syntax
- ======
- (FILL-MATRIX matrix fill-element)
+;; ;;
+;; (defgeneric fill-matrix (matrix fill-element)
+;; (:documentation
+;; "
+;; Syntax
+;; ======
+;; (FILL-MATRIX matrix fill-element)
- Purpose
- =======
- Fill MATRIX with FILL-ELEMENT.
-"))
+;; Purpose
+;; =======
+;; Fill MATRIX with FILL-ELEMENT.
+;; "))
-(defmethod fill-matrix ((matrix t) (fill t))
- (error "arguments MATRIX and FILL to FILL-MATRIX must be a
-matrix and a number"))
+;; (defmethod fill-matrix ((matrix t) (fill t))
+;; (error "arguments MATRIX and FILL to FILL-MATRIX must be a
+;; matrix and a number"))
-;;
-;;
+;; ;;
+;; ;;
-;;
+;; ;;
-(definline matrix-ref (matrix row &optional col)
- (declare (type standard-matrix matrix))
- (tensor-ref matrix `(,row ,col)))
+;; (definline matrix-ref (matrix row &optional col)
+;; (declare (type standard-matrix matrix))
+;; (tensor-ref matrix `(,row ,col)))
diff --git a/src/level-2/gemv.lisp b/src/level-2/gemv.lisp
index fb708f0..29a4d64 100644
--- a/src/level-2/gemv.lisp
+++ b/src/level-2/gemv.lisp
@@ -80,6 +80,8 @@
(zgemv zaxpy zdotu zscal))
;;---------------------------------------------------------------;;
+
+;;Can't support "C" because the dual isn't supported by BLAS.
(defgeneric gemv! (alpha A x beta y &optional job)
(:documentation
"
diff --git a/src/old/gemm.lisp b/src/level-3/gemm.lisp
similarity index 62%
rename from src/old/gemm.lisp
rename to src/level-3/gemm.lisp
index 5ca6f21..c7d2e00 100644
--- a/src/old/gemm.lisp
+++ b/src/level-3/gemm.lisp
@@ -25,138 +25,130 @@
;;; ENHANCEMENTS, OR MODIFICATIONS.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; Originally written by Raymond Toy.
-;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; $Id: gemm.lisp,v 1.8 2011/01/25 18:36:56 rtoy Exp $
-;;;
-;;; $Log: gemm.lisp,v $
-;;; Revision 1.8 2011/01/25 18:36:56 rtoy
-;;; Merge changes from automake-snapshot-2011-01-25-1327 to get the new
-;;; automake build infrastructure.
-;;;
-;;; Revision 1.7.2.1 2011/01/25 18:16:53 rtoy
-;;; Use cl:real instead of real.
-;;;
-;;; Revision 1.7 2004/05/24 16:34:22 rtoy
-;;; More SBCL support from Robert Sedgewick. The previous SBCL support
-;;; was incomplete.
-;;;
-;;; Revision 1.6 2001/06/22 12:52:41 rtoy
-;;; Use ALLOCATE-REAL-STORE and ALLOCATE-COMPLEX-STORE to allocate space
-;;; instead of using the error-prone make-array.
-;;;
-;;; Revision 1.5 2001/02/26 17:44:54 rtoy
-;;; Remove the complex-alpha,beta special variables. (Make a closure out
-;;; of them.)
-;;;
-;;; Revision 1.4 2000/07/11 18:02:03 simsek
-;;; o Added credits
-;;;
-;;; Revision 1.3 2000/07/11 02:11:56 simsek
-;;; o Added support for Allegro CL
-;;;
-;;; Revision 1.2 2000/05/08 17:19:18 rtoy
-;;; Changes to the STANDARD-MATRIX class:
-;;; o The slots N, M, and NXM have changed names.
-;;; o The accessors of these slots have changed:
-;;; NROWS, NCOLS, NUMBER-OF-ELEMENTS
-;;; The old names aren't available anymore.
-;;; o The initargs of these slots have changed:
-;;; :nrows, :ncols, :nels
-;;;
-;;; Revision 1.1 2000/04/14 00:11:12 simsek
-;;; o This file is adapted from obsolete files 'matrix-float.lisp'
-;;; 'matrix-complex.lisp' and 'matrix-extra.lisp'
-;;; o Initial revision.
-;;;
-;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(in-package "MATLISP")
-
-(defmacro generate-typed-gemm!-func (func element-type store-type matrix-type blas-gemm-func lisp-gemv-func)
- `(defun ,func (alpha a b beta c job)
- (declare (optimize (safety 0) (speed 3))
- (type ,element-type alpha beta)
- (type ,matrix-type a b c)
- (type symbol job))
- (mlet* ((job-a (ecase job ((:nn :nt) :n) ((:tn :tt) :t)) :type symbol)
- (job-b (ecase job ((:nn :tn) :n) ((:nt :tt) :t)) :type symbol)
- ((hd-c nr-c nc-c st-c) (slot-values c '(head number-of-rows number-of-cols store))
- :type (fixnum fixnum fixnum (,store-type *)))
- ((hd-a st-a) (slot-values a '(head store))
- :type (fixnum (,store-type *)))
- ((hd-b st-b) (slot-values b '(head store))
- :type (fixnum (,store-type *)))
- (k (if (eq job-a :n)
- (ncols a)
- (nrows a))
- :type fixnum)
- ((order-a lda fort-job-a) (blas-matrix-compatible-p a job-a)
- :type (symbol fixnum (string 1)))
- ((order-b ldb fort-job-b) (blas-matrix-compatible-p b job-b)
- :type (symbol fixnum (string 1)))
- ((order-c ldc fort-job-c) (blas-matrix-compatible-p c :n)
- :type (nil fixnum (string 1))))
- ;;
- (if (and (> lda 0) (> ldb 0) (> ldc 0))
- (progn
- (when (string= fort-job-c "T")
- (rotatef a b)
- (rotatef lda ldb)
- (rotatef fort-job-a fort-job-b)
- (rotatef hd-a hd-b)
- (rotatef st-a st-b)
- (rotatef nr-c nc-c)
- ;;
- (setf fort-job-a (fortran-snop fort-job-a))
- (setf fort-job-b (fortran-snop fort-job-b)))
- (,blas-gemm-func fort-job-a fort-job-b
- nr-c nc-c k
- alpha
- st-a lda
- st-b ldb
- beta
- st-c ldc
- :head-a hd-a :head-b hd-b :head-c hd-c))
- (progn
- (when (eq job-a :t) (transpose! a))
- (when (eq job-b :t) (transpose! b))
- ;;
- (symbol-macrolet
- ((loop-col
- (mlet* ((cs-b (col-stride b) :type fixnum)
- (cs-c (col-stride c) :type fixnum)
- (col-b (col~ b 0) :type ,matrix-type)
- (col-c (col~ c 0) :type ,matrix-type))
- (dotimes (j nc-c)
- (when (> j 0)
- (setf (head col-b) (+ (head col-b) cs-b))
- (setf (head col-c) (+ (head col-c) cs-c)))
- (,lisp-gemv-func alpha a col-b beta col-c :n))))
- (loop-row
- (mlet* ((rs-a (row-stride a) :type fixnum)
- (rs-c (row-stride c) :type fixnum)
- (row-a (transpose! (row~ a 0)) :type ,matrix-type)
- (row-c (transpose! (row~ c 0)) :type ,matrix-type))
- (dotimes (i nr-c)
- (when (> i 0)
- (setf (head row-a) (+ (head row-a) rs-a))
- (setf (head row-c) (+ (head row-c) rs-c)))
- (,lisp-gemv-func alpha b row-a beta row-c :t)))))
- (cond
- (order-a loop-col)
- (order-b loop-row)
- ((< nr-c nc-c) loop-row)
- (t loop-col)))
- ;;
- (when (eq job-a :t) (transpose! a))
- (when (eq job-b :t) (transpose! b))
- )))
- c))
+(in-package #:matlisp)
+
+(defmacro generate-typed-gemm! (func (matrix-class) (blas-gemm-func blas-gemv-func))
+ (let* ((opt (get-tensor-class-optimization matrix-class)))
+ (assert opt nil 'tensor-cannot-find-optimization :tensor-class matrix-class)
+ `(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))
+ (mlet* (((job-a job-b) (ecase job
+ (:nn (values :n :n))
+ (:nt (values :n :t))
+ (:tn (values :t :n))
+ (:tt (values :t :t)))
+ :type (symbol symbol))
+ ((maj-a ld-a fop-a) (blas-matrix-compatible-p A job-a) :type (symbol index-type (string 1)))
+ ((maj-b ld-b fop-b) (blas-matrix-compatible-p B job-b) :type (symbol index-type (string 1)))
+ ((maj-c ld-c fop-c) (blas-matrix-compatible-p C :n) :type (symbol index-type nil)))
+ (if (and maj-a maj-b maj-c)
+ (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))
+ (when (eq maj-c :row-major)
+ (rotatef A B)
+ (rotatef ld-a ld-b)
+ (rotatef maj-a maj-b)
+ (rotatef nr-c nc-c)
+ (setf (values fop-a fop-b)
+ (values (fortran-snop fop-b) (fortran-snop fop-a))))
+ (,blas-gemm-func fop-a fop-b nr-c nc-c dotl
+ alpha (store A) ld-a (store B) ld-b
+ beta (store C) ld-c
+ (head A) (head B) (head C)))
+ (cond
+ (maj-a
+ (let-typed ((nc-c (ncols C) :type index-type)
+ (sto-c (store C) :type ,(linear-array-type (getf opt :store-type)))
+ (stp-c (row-stride C) :type index-type)
+ (nr-a (nrows A) :type index-type)
+ (nc-a (ncols A) :type index-type)
+ (sto-a (store A) :type ,(linear-array-type (getf opt :store-type)))
+ (hd-a (head A) :type index-type)
+ (stp-b (if (eq job-b :n) (row-stride B) (col-stride B)) :type index-type)
+ (sto-b (store B) :type ,(linear-array-type (getf opt :store-type)))
+ (strd-b (if (eq job-b :n) (col-stride B) (row-stride B)) :type index-type)
+ (strd-c (col-stride C) :type index-type))
+ (when (eq maj-a :row-major)
+ (rotatef nr-a nc-a))
+ (very-quickly
+ (mod-dotimes (idx (idxv nc-c))
+ with (linear-sums
+ (of-b (idxv strd-b) (head B))
+ (of-c (idxv strd-c) (head C)))
+ do (,blas-gemv-func fop-a nr-a nc-a
+ alpha sto-a ld-a
+ sto-b stp-b
+ beta sto-c stp-c
+ hd-a of-b of-c)))))
+ (maj-b
+ (let-typed ((nr-c (nrows C) :type index-type)
+ (stp-c (col-stride C) :type index-type)
+ (sto-c (store c) :type ,(linear-array-type (getf opt :store-type)))
+ (stp-a (if (eq job-a :n) (col-stride B) (row-stride B)) :type index-type)
+ (sto-a (store A) :type ,(linear-array-type (getf opt :store-type)))
+ (nr-b (nrows B) :type index-type)
+ (nc-b (ncols B) :type index-type)
+ (hd-b (head B) :type index-type)
+ (fop-b (fortran-snop fop-b) :type (string 1))
+ (sto-b (store B) :type ,(linear-array-type (getf opt :store-type)))
+ (strd-a (if (eq job-A :n) (row-stride A) (col-stride A)) :type index-type)
+ (strd-c (row-stride C) :type index-type))
+ (when (eq maj-b :row-major)
+ (rotatef nr-b nc-b))
+ (very-quickly
+ (mod-dotimes (idx (idxv nr-c))
+ with (linear-sums
+ (of-A (idxv strd-a) (head A))
+ (of-c (idxv strd-c) (head C)))
+ do (,blas-gemv-func fop-b nr-b nc-b
+ alpha sto-b ld-b
+ sto-a stp-a
+ beta sto-c stp-c
+ hd-b of-a of-c)))))
+ (t
+ (let-typed ((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)
+ (rstp-b (row-stride A) :type index-type)
+ (cstp-b (col-stride A) :type index-type)
+ (sto-a (store A) :type ,(linear-array-type (getf opt :store-type)))
+ (sto-b (store B) :type ,(linear-array-type (getf opt :store-type)))
+ (sto-c (store C) :type ,(linear-array-type (getf opt :store-type))))
+ (when (eq job-a :t)
+ (rotatef rstp-a cstp-a))
+ (when (eq job-b :t)
+ (rotatef rstp-b cstp-b))
+ (very-quickly
+ (mod-dotimes (idx (dimensions C))
+ with (loop-order :row-major)
+ with (linear-sums
+ (of-a (idxv rstp-a 0) (head A)) ; cstp-a))
+ (of-b (idxv 0 cstp-b) (head B)) ; rstp-b))
+ (of-c (strides C) (head C))) ; 0)))
+ do (let-typed ((tmp (,(getf opt :coercer) 0) :type ,(getf opt :element-type))
+ (val (* beta ,(funcall (getf opt :reader) 'sto-c 'of-c)) :type ,(getf opt :element-type)))
+ (loop repeat dotl
+ for dof-a of-type index-type = of-a then (+ dof-a cstp-a)
+ for dof-b of-type index-type = of-b then (+ dof-b rstp-b)
+ do (incf tmp (* ,(funcall (getf opt :reader) 'sto-a 'dof-a)
+ ,(funcall (getf opt :reader) 'sto-b 'dof-b))))
+ ,(funcall (getf opt :value-writer) '(+ (* alpha tmp) (* beta val)) 'sto-c 'of-c)))))))))
+ C)))
+
+(generate-typed-gemm! real-typed-gemm! (real-matrix) (dgemm dgemv))
+(generate-typed-gemm! complex-typed-gemm! (complex-matrix) (zgemm zgemv))
+
+(let ((A (tensor-realpart~
+ (make-complex-tensor '((1 2 3)
+ (4 5 6)
+ (7 8 9)))))
+ (C (make-real-tensor 3 3)))
+ (real-typed-gemm! 1d0 A A 0d0 C :nn))
+
;;;;
(defgeneric gemm! (alpha a b beta c &optional job)
(:documentation
@@ -406,4 +398,4 @@
(complex-coerce beta)
beta)
c)))
- (gemm! alpha a b 1d0 result job)))
\ No newline at end of file
+ (gemm! alpha a b 1d0 result job)))
diff --git a/src/utilities.lisp b/src/utilities.lisp
index 4fbdeab..e2e74c4 100644
--- a/src/utilities.lisp
+++ b/src/utilities.lisp
@@ -1,5 +1,6 @@
(in-package #:matlisp-utilities)
+;;TODO: cleanup!
(defmacro mlet* (decls &rest body)
"
mlet* ({ {(var*) | var} values-form &keyform declare type}*) form*
@@ -55,6 +56,49 @@
`(progn
,@body))))
+(defmacro let-typed (bindings &rest body)
+"
+ let-typed ({var form &key type}*) form*
+
+ This macro also handles type declarations.
+
+ Example:
+ > (let-typed ((x 1 :type fixnum))
+ (+ 1 x))
+
+ expands into:
+
+ > (let ((x 1))
+ (declare (type fixnum x))
+ (+ 1 x))
+"
+ (labels ((parse-bindings (bdng let-decl type-decl)
+ (if (null bdng) (values (reverse let-decl) (reverse type-decl))
+ ;;Unless the user gives a initialisation form, no point declaring type
+ ;; {var is bound to nil}.
+ (destructuring-bind (var &optional form &key (type nil)) (ensure-list (car bdng))
+ (parse-bindings (cdr bdng)
+ (cons (if form `(,var ,form) var) let-decl)
+ (if type
+ (cons `(type ,type ,var) type-decl)
+ type-decl))))))
+ (multiple-value-bind (let-bdng type-decl) (parse-bindings bindings nil nil)
+ (let ((decl-code (recursive-append
+ (cond
+ ((and (consp (first body))
+ (eq (caar body) 'declare))
+ (first body))
+ ((consp type-decl)
+ '(declare ))
+ (t nil))
+ type-decl)))
+ `(let (,@let-bdng)
+ ,@(if (null decl-code) nil `(,decl-code))
+ ,@(if (and (consp (first body))
+ (eq (caar body) 'declare))
+ (cdr body)
+ body))))))
+
(defmacro let-rec (name arglist &rest code)
"
(let-rec name ({var [init-form]}*) declaration* form*) => result*
diff --git a/tests/loopy-tests.lisp b/tests/loopy-tests.lisp
index 9f63e62..de334ec 100644
--- a/tests/loopy-tests.lisp
+++ b/tests/loopy-tests.lisp
@@ -58,7 +58,36 @@
(of-a (idxv n 1 0))
(of-b (idxv 0 n 1))
(of-c (idxv n 0 1)))
- do (incf (aref st-c of-c) (* (aref st-a of-a) (aref st-b of-b)))))))))
+ do (incf (aref st-c of-c) (* (aref st-a of-a) (aref st-b of-b)))))))))
+
+(defun test-mm-daxpy (n)
+ (let* ((t-a (make-real-tensor n n))
+ (t-b (make-real-tensor n n))
+ (t-c (make-real-tensor n n))
+ (st-a (store t-a))
+ (st-b (store t-b))
+ (st-c (store t-c)))
+ (declare (type real-tensor t-a t-b t-c)
+ (type (real-array *) st-a st-b st-c))
+ (mod-dotimes (idx (dimensions t-a))
+ with (linear-sums
+ (of-a (strides t-a))
+ (of-b (strides t-b))
+ (of-c (strides t-c)))
+ do (setf (aref st-a of-a) (random 1d0)
+ (aref st-b of-b) (random 1d0)
+ (aref st-c of-c) 0d0))
+ (time
+ (very-quickly
+ (mod-dotimes (idx (idxv n n))
+ with (loop-order :row-major)
+ with (linear-sums
+ (of-a (idxv 1 0))
+ (of-b (idxv n 1))
+ (of-c (idxv 1 0)))
+ do (daxpy n (aref st-b of-b) st-a n st-c n
+ of-a of-c))))))
+
(defun test-mm-ddot (n)
(let* ((t-a (make-real-tensor n n))
-----------------------------------------------------------------------
Summary of changes:
README | 1 +
packages.lisp | 2 +-
src/classes/matrix.lisp | 48 ++++----
src/level-2/gemv.lisp | 2 +
src/{old => level-3}/gemm.lisp | 256 +++++++++++++++++++---------------------
src/utilities.lisp | 44 +++++++
tests/loopy-tests.lisp | 31 +++++-
7 files changed, 223 insertions(+), 161 deletions(-)
rename src/{old => level-3}/gemm.lisp (62%)
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2012-07-09 15:15:25
|
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 6770dbf44302c7d981ea50386827106748b8f3cc (commit)
via 38da10cc73eaa514e7bcacc1f996eeefda503078 (commit)
from cfd1ff7fa12112dcb0df038f9ecd60a5d637aa18 (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 6770dbf44302c7d981ea50386827106748b8f3cc
Author: Akshay Srinivasan <aks...@gm...>
Date: Mon Jul 9 20:40:26 2012 +0530
o Added gemv!
diff --git a/matlisp.asd b/matlisp.asd
index 0644b0e..26df9c3 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -117,7 +117,11 @@
(:file "realimag"
:depends-on ("copy"))
(:file "axpy"
- :depends-on ("copy"))))))
+ :depends-on ("copy"))))
+ (:module "matlisp-level-2"
+ :pathname "level-2"
+ :depends-on ("matlisp-base" "matlisp-classes" "foreign-core" "matlisp-level-1")
+ :components ((:file "gemv")))))
;; (defclass f2cl-cl-source-file (asdf:cl-source-file)
diff --git a/packages.lisp b/packages.lisp
index 4ce172e..b90e858 100644
--- a/packages.lisp
+++ b/packages.lisp
@@ -34,6 +34,7 @@
;;Generic errors
#:generic-error #:message
#:invalid-type #:given #:expected
+ #:invalid-arguments
#:invalid-value #:given #:expected
#:unknown-token #:token
#:parser-error
diff --git a/src/base/blas-helpers.lisp b/src/base/blas-helpers.lisp
index 39de052..8e5ed08 100644
--- a/src/base/blas-helpers.lisp
+++ b/src/base/blas-helpers.lisp
@@ -36,18 +36,15 @@
unless (= so-st accumulated-off) do (return nil)
finally (return (aref sort-std 0))))))
-
-(defun blas-matrix-compatible-p (matrix &optional (op :n))
- (declare (type standard-tensor matrix))
- (let ((stds (strides matrix)))
- (declare (type (index-array *) stds))
- (if (not (= (array-dimension stds 0) 2)) nil
- (let ((rs (aref stds 0))
- (cs (aref stds 1)))
- (declare (type index-type rs cs))
- (cond
- ((= cs 1) (values :row-major rs (fortran-nop op)))
- ((= rs 1) (values :col-major cs (fortran-op op))))))))
+(defun blas-matrix-compatible-p (matrix op)
+ (declare (type standard-matrix matrix))
+ (let ((rs (aref (strides matrix) 0))
+ (cs (aref (strides matrix) 1)))
+ (declare (type index-type rs cs))
+ (cond
+ ((= cs 1) (values :row-major rs (fortran-nop op)))
+ ((= rs 1) (values :col-major cs (fortran-op op)))
+ (t (values nil 0 "?")))))
(definline fortran-op (op)
(ecase op (:n "N") (:t "T")))
diff --git a/src/conditions.lisp b/src/conditions.lisp
index a4e17a3..88c991f 100644
--- a/src/conditions.lisp
+++ b/src/conditions.lisp
@@ -32,6 +32,10 @@
(format stream "Given object of type ~A, expected ~A.~%" (given c) (expected c))
(call-next-method)))
+(defcondition invalid-arguments (generic-error)
+ ()
+ (:documentation "Given invalid arguments to the function."))
+
(defcondition invalid-value (generic-error)
((given-value :reader given :initarg :given)
(expected-value :reader expected :initarg :expected))
diff --git a/src/ffi/ffi-cffi.lisp b/src/ffi/ffi-cffi.lisp
index 344c8ec..8f57fa9 100644
--- a/src/ffi/ffi-cffi.lisp
+++ b/src/ffi/ffi-cffi.lisp
@@ -6,6 +6,8 @@
;; Callbacks : (:function <output-type> {(params)})
+;;TODO add declarations to generated wrappers.
+
(in-package #:matlisp-ffi)
(define-constant +ffi-types+ '(:single-float :double-float
diff --git a/src/level-1/axpy.lisp b/src/level-1/axpy.lisp
index 53be2cd..edef2d3 100644
--- a/src/level-1/axpy.lisp
+++ b/src/level-1/axpy.lisp
@@ -77,8 +77,8 @@
is stored in Y and Y is returned.
")
(:method :before ((alpha number) (x standard-tensor) (y standard-tensor))
- (unless (idx= (dimensions x) (dimensions y))
- (error 'tensor-dimension-mismatch)))
+ (assert (idx= (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)))
diff --git a/src/level-2/gemv.lisp b/src/level-2/gemv.lisp
index 8651f95..fb708f0 100644
--- a/src/level-2/gemv.lisp
+++ b/src/level-2/gemv.lisp
@@ -1,80 +1,85 @@
-(in-package :matlisp)
+(in-package #:matlisp)
-(defmacro generate-typed-copy! (func (tensor-class blas-func))
+(defmacro generate-typed-gemv! (func
+ (matrix-class vector-class)
+ (blas-gemv-func blas-axpy-func blas-dot-func blas-scal-func))
;;Be very careful when using functions generated by this macro.
- ;;Indexes can be tricky and this has no safety net
+ ;;Indexes can be tricky and this has no safety net.
;;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)
- `(defun ,func (from to)
- (declare (type ,tensor-class from to))
- (if-let (strd-p (blas-copyable-p from to))
- (,blas-func (number-of-elements from) (store from) (first strd-p) (store to) (second strd-p) (head from) (head to))
- (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 ,(funcall (getf opt :reader-writer) 'f-sto 'f-of 't-sto 't-of)))))
- to)))
-
-
-(defmacro generate-typed-gemv! (func (tensor-class blas-func))
- (let* ((opt (get-tensor-class-optimization tensor-class)))
- (assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
+ (let* ((opt (get-tensor-class-optimization matrix-class)))
+ (assert opt nil 'tensor-cannot-find-optimization :tensor-class matrix-class)
`(defun ,func (alpha A x beta y job)
- (declare (type (getf opt :element-type) alpha beta)
- (type ,tensor-class A x y)
- (type boolean job))
- (tensor-t
-
-
-;;There's no support for ":c", because there is no
-;;equivalent of ":n" with complex conjugation.
-(defmacro generate-typed-gemv!-func (func element-type store-type matrix-type blas-gemv-func blas-axpy-func blas-dot-func)
- ;;Be very careful when you use functions generated by this macro!
- ;;Indexes can be tricky and this has no safety net
- ;;Use only after checking the arguments for compatibility.
- `(defun ,func (alpha A x beta y job)
- (declare (tyep
- (declare (type ,element-type alpha beta)
- (type ,matrix-type A x y)
- (type symbol job))
- (mlet* (((st-a hd-a nr-a nc-a rs-a cs-a) (slot-values A '(store head number-of-rows number-of-cols row-stride col-stride))
- :type ((,store-type *) fixnum fixnum fixnum fixnum fixnum))
- ((st-x hd-x rs-x) (slot-values x '(store head row-stride))
- :type ((,store-type *) fixnum fixnum))
- ((st-y hd-y rs-y) (slot-values y '(store head row-stride))
- :type ((,store-type *) fixnum fixnum))
- ((sym lda tf-op) (blas-matrix-compatible-p A job) :type (symbol fixnum (string 1))))
- (if (not (string= tf-op "?"))
- (progn
- (when (eq sym :row-major)
- (rotatef nr-a nc-a)
- (rotatef rs-a cs-a))
- (,blas-gemv-func tf-op nr-a nc-a alpha st-a lda st-x rs-x beta st-y rs-y :head-a hd-a :head-x hd-x :head-y hd-y))
- (progn
- (when (eq job :t)
- (rotatef nr-a nc-a)
- (rotatef rs-a cs-a))
- ;;Use the smaller of the loops.
- (if (> nr-a nc-a)
- (progn
- (scal! beta y)
- (dotimes (i nc-a)
- (,blas-axpy-func nr-a (* alpha (matrix-ref-2d x i 0)) st-a rs-a st-y rs-y :head-x (+ hd-a (* i cs-a)) :head-y hd-y)))
- (dotimes (i nr-a)
- (setf (matrix-ref-2d y i 0) (+ (* alpha (,blas-dot-func nc-a st-a cs-a st-x rs-x :head-x (+ hd-a (* i rs-a)) :head-y hd-x))
- (* beta (matrix-ref-2d y i 0)))))))))
- y))
-
-;;
+ (declare (type ,(getf opt :element-type) alpha beta)
+ (type ,matrix-class A)
+ (type ,vector-class x y)
+ (type symbol job))
+ (mlet*
+ (((maj-a ld-a fop-a) (blas-matrix-compatible-p A job) :type (symbol index-type (string 1))))
+ (if maj-a
+ (let ((nr-a (aref (dimensions A) 0))
+ (nc-a (aref (dimensions A) 1)))
+ (declare (type index-type nr-a nc-a))
+ (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)))
+ (let ((nr-a (aref (dimensions A) 0))
+ (nc-a (aref (dimensions A) 1))
+ (rs-a (aref (strides A) 0))
+ (cs-a (aref (strides A) 1)))
+ (declare (type index-type nr-a nc-a rs-a cs-a))
+ (when (eq job :t)
+ (rotatef nr-a nc-a)
+ (rotatef rs-a cs-a))
+ (let ((sto-a (store a))
+ (sto-x (store x))
+ (std-x (aref (strides x) 0))
+ (hd-x (head x))
+ (sto-y (store y))
+ (std-y (aref (strides y) 0))
+ (hd-y (head y)))
+ (declare (type ,(linear-array-type (getf opt :store-type)) sto-a sto-x sto-y)
+ (type index-type std-y std-x hd-x hd-y))
+ (if (> nr-a nc-a)
+ (progn
+ (unless (= beta 1d0)
+ (,blas-scal-func nr-a beta
+ sto-y std-y hd-y))
+ (very-quickly
+ (mod-dotimes (idx (idxv nc-a))
+ with (linear-sums
+ (of-x (strides x) (head x))
+ (of-a (idxv cs-a) (head A)))
+ do (,blas-axpy-func nr-a (* alpha ,(funcall (getf opt :reader) 'sto-x 'of-x))
+ sto-a rs-a sto-y std-y
+ of-a hd-y))))
+ (very-quickly
+ (mod-dotimes (idx (idxv nr-a))
+ with (linear-sums
+ (of-y (strides y) (head y))
+ (of-a (idxv rs-a) (head A)))
+ do (let ((val (* beta ,(funcall (getf opt :reader) 'sto-y 'of-y)))
+ (dotp (,blas-dot-func nc-a
+ sto-a cs-a sto-x std-x
+ of-a hd-x)))
+ (declare (type ,(getf opt :element-type) val dotp))
+ ,(funcall (getf opt :value-writer)
+ `(+ val (* alpha dotp)) 'sto-y 'of-y)))))))))
+ y)))
+
+(generate-typed-gemv! real-typed-gemv!
+ (real-matrix real-vector)
+ (dgemv daxpy ddot dscal))
+
+(generate-typed-gemv! complex-typed-gemv!
+ (complex-matrix complex-vector)
+ (zgemv zaxpy zdotu zscal))
+
+;;---------------------------------------------------------------;;
(defgeneric gemv! (alpha A x beta y &optional job)
(:documentation
"
@@ -100,184 +105,76 @@
---------------------------------------------------
:N (default) alpha * A * x + beta * y
:T alpha * A'* x + beta * y
-
- Note
- ====
- Take caution when using GEMM! as follows:
-
- (GEMV! alpha a x beta x)
-
- The results may be unpredictable depending
- on the underlying DGEMM, ZGEMM routines
- from BLAS, ATLAS or LIBCRUFT.
-"))
-
-(defmethod gemv! :before ((alpha number) (A standard-matrix) (x standard-matrix)
- (beta number) (y standard-matrix)
- &optional (job :n))
- (mlet* (((nr-a nc-a) (slot-values A '(number-of-rows number-of-cols)) :type (fixnum fixnum))
- ((nr-x nc-x) (slot-values x '(number-of-rows number-of-cols)) :type (fixnum fixnum))
- ((nr-y nc-y) (slot-values y '(number-of-rows number-of-cols)) :type (fixnum fixnum)))
- (unless (member job '(:n :t))
- (error "Argument JOB to GEMV! is not recognized"))
- (when (eq job :t)
- (rotatef nr-a nc-a))
- (unless (and (= nc-x 1) (= nc-y 1)
- (= nc-a nr-x) (= nr-a nr-y))
- (error "Dimensions of A,x,y given to GEMV! do not match"))))
-
-;;
-(generate-typed-gemv!-func real-double-gemv!-typed
- double-float real-matrix-store-type real-matrix
- blas:dgemv blas:daxpy blas:ddot)
-
-(defmethod gemv! ((alpha cl:real) (A real-matrix) (x real-matrix)
- (beta cl:real) (y real-matrix) &optional (job :n))
- ;; y <- \beta . y + \alpha . A o x
- (real-double-gemv!-typed (coerce alpha 'double-float) A x
- (coerce beta 'double-float) y job))
-
-;;
-(generate-typed-gemv!-func complex-double-gemv!-typed
- complex-double-float complex-matrix-store-type complex-matrix
- blas:zgemv blas:zaxpy blas:zdotu)
-
-(defmethod gemv! ((alpha number) (A complex-matrix) (x complex-matrix)
- (beta number) (y complex-matrix) &optional (job :n))
- ;; y <- \beta . y + \alpha . A o x
- (complex-double-gemv!-typed (complex-coerce alpha) A x
- (complex-coerce beta) y job))
-
-;
-(defmethod gemv! ((alpha cl:real) (A real-matrix) (x real-matrix)
- (beta complex) (y complex-matrix) &optional (job :n))
- (let ((r-y (mrealpart~ y)))
- (declare (type real-matrix r-y))
- ;; y <- \beta * y
- (scal! (complex-coerce beta) y)
- ;; y <- y + \alpha * A o x
- (real-double-gemv!-typed (coerce alpha 'double-float) A x 1d0 r-y job)))
-
-(defmethod gemv! ((alpha complex) (A real-matrix) (x real-matrix)
- (beta complex) (y complex-matrix) &optional (job :n))
- ;; y <- \beta * y
- (scal! (complex-coerce beta) y)
- ;; y <- y + \alpha * A o x
- (gemv! alpha A x 1d0 y job))
-
-(defmethod gemv! ((alpha cl:real) (A real-matrix) (x real-matrix)
- (beta cl:real) (y complex-matrix) &optional (job :n))
- (let ((r-be (coerce beta 'double-float))
- (r-al (coerce alpha 'double-float))
- (r-y (mrealpart~ y)))
- (declare (type double-float r-be r-al)
- (type real-matrix r-y))
- ;; y <- \beta * y
- (scal! r-be y)
- ;; (mrealpart~ y) <- (mrealpart~ y) + \alpha * A o x
- (real-double-gemv!-typed r-al A x 1d0 r-y job))
+")
+ (:method :before ((alpha number) (A standard-matrix) (x standard-vector)
+ (beta number) (y standard-vector)
+ &optional (job :n))
+ (assert (member job '(:n :t)) nil 'invalid-value
+ :given job :expected `(member job '(:n :t))
+ :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))
+ (real-typed-gemv! (coerce-real alpha) A x
+ (coerce-real beta) y job))
+
+(defmethod gemv! ((alpha number) (A complex-matrix) (x complex-vector)
+ (beta number) (y complex-vector) &optional (job :n))
+ (complex-typed-gemv! (coerce-complex alpha) A x
+ (coerce-complex beta) y job))
+
+(defmethod gemv! ((alpha number) (A real-matrix) (x real-vector)
+ (beta number) (y complex-vector) &optional (job :n))
+ (unless (= beta 1)
+ (complex-typed-scal! (coerce-complex beta) y))
+ (unless (= alpha 0)
+ (if (complexp alpha)
+ (let ((A.x (make-real-tensor (aref (dimensions y) 0)))
+ (vw-y (tensor-realpart~ y)))
+ (real-typed-gemv! (coerce-real 1) A x (coerce-real 0) A.x job)
+ ;;
+ (real-typed-axpy! (coerce-real (realpart alpha)) A.x vw-y)
+ ;;Move view to the imaginary part
+ (incf (head vw-y))
+ (real-typed-axpy! (coerce-real (imagpart alpha)) A.x vw-y))
+ (real-typed-gemv! (coerce-real alpha) A x
+ (coerce-real 1) (tensor-realpart~ y) job)))
y)
-(defmethod gemv! ((alpha complex) (A real-matrix) (x real-matrix)
- (beta cl:real) (y complex-matrix) &optional (job :n))
- (let ((r-al (coerce (realpart alpha) 'double-float))
- (i-al (coerce (imagpart alpha) 'double-float))
- (r-be (coerce beta 'double-float))
- (r-y (mrealpart~ y))
- (i-y (mimagpart~ y)))
- (declare (type double-float r-al i-al r-be)
- (type real-matrix r-y i-y))
- ;; (mrealpart~ y) <- \beta * (mrealpart~ y) + (realpart \alpha) . A o x
- (real-double-gemv!-typed r-al A x r-be r-y job)
- ;; (mimagpart~ y) <- \beta * (mimagpart~ y) + (imagpart \alpha) . A o x
- (real-double-gemv!-typed i-al A x r-be i-y job))
- y)
-
-;
-(defmethod gemv! ((alpha number) (A real-matrix) (x complex-matrix)
- (beta complex) (y complex-matrix) &optional (job :n))
- ;; y <- \beta y
- (scal! beta y)
- ;; y <- y + \alpha . A o x
- (gemv! alpha A x 1d0 y job))
-
-(defmethod gemv! ((alpha cl:real) (A real-matrix) (x complex-matrix)
- (beta cl:real) (y complex-matrix) &optional (job :n))
- (let ((r-x (mrealpart~ x))
- (i-x (mimagpart~ x))
- (r-y (mrealpart~ y))
- (i-y (mimagpart~ y))
- (r-al (coerce (realpart alpha) 'double-float))
- (r-be (coerce beta 'double-float)))
- (declare (type double-float r-al r-be)
- (type real-matrix r-x i-x r-y i-y))
- ;; (mrealpart~ y) <- \beta * (mrealpart~ y) + \alpha . A o (mrealpart~ x)
- (real-double-gemv!-typed r-al A r-x r-be r-y job)
- ;; (mimagpart~ y) <- \beta * (mimagpart~ y) + \alpha . A o (mrealpart~ x)
- (real-double-gemv!-typed r-al A i-x r-be i-y job))
- y)
-
-(defmethod gemv! ((alpha complex) (A real-matrix) (x complex-matrix)
- (beta cl:real) (y complex-matrix) &optional (job :n))
- (let ((r-x (mrealpart~ x))
- (i-x (mimagpart~ x))
- (r-y (mrealpart~ y))
- (i-y (mimagpart~ y))
- (r-al (coerce (realpart alpha) 'double-float))
- (i-al (coerce (imagpart alpha) 'double-float))
- (r-be (coerce beta 'double-float)))
- (declare (type double-float r-al r-be i-al)
- (type real-matrix r-x i-x r-y i-y))
- (real-double-gemv!-typed r-al A r-x r-be r-y job)
- (real-double-gemv!-typed (- i-al) A i-x 1d0 r-y job)
- ;;
- (real-double-gemv!-typed i-al A r-x r-be i-y job)
- (real-double-gemv!-typed r-al A i-x 1d0 i-y job))
- y)
-
-;
-(defmethod gemv! ((alpha number) (A complex-matrix) (x real-matrix)
- (beta complex) (y complex-matrix) &optional (job :n))
- ;; y <- \beta y
- (scal! beta y)
- ;; y <- y + \alpha . A o x
- (gemv! alpha A x 1d0 y job))
-
-(defmethod gemv! ((alpha cl:real) (A complex-matrix) (x real-matrix)
- (beta cl:real) (y complex-matrix) &optional (job :n))
- (let ((r-A (mrealpart~ A))
- (i-A (mimagpart~ A))
- (r-y (mrealpart~ y))
- (i-y (mimagpart~ y))
- (r-al (coerce (realpart alpha) 'double-float))
- (r-be (coerce beta 'double-float)))
- (declare (type double-float r-al r-be)
- (type real-matrix r-A i-A r-y i-y))
- ;; (mrealpart~ y) <- \beta * (mrealpart~ y) + \alpha . A o (mrealpart~ x)
- (real-double-gemv!-typed r-al r-A x r-be r-y job)
- ;; (mimagpart~ y) <- \beta * (mimagpart~ y) + \alpha . A o (mrealpart~ x)
- (real-double-gemv!-typed r-al i-A x r-be i-y job))
+(defmethod gemv! ((alpha number) (A real-matrix) (x complex-vector)
+ (beta number) (y complex-matrix) &optional (job :n))
+ (unless (= beta 1)
+ (complex-typed-scal! (coerce-complex beta) y))
+ (unless (= alpha 0)
+ (let ((A.x (make-complex-tensor (aref (dimensions y) 0))))
+ (let ((vw-x (tensor-realpart~ x))
+ (vw-A.x (tensor-realpart~ x)))
+ ;;Re
+ (real-typed-gemv! (coerce-real 1) A vw-x (coerce-real 0) vw-A.x job)
+ ;;Im
+ (incf (head vw-x))
+ (incf (head vw-A.x))
+ (real-typed-gemv! (coerce-real 1) A vw-x (coerce-real 0) vw-A.x job))
+ (complex-typed-axpy! (coerce-complex alpha) A.x y)))
y)
-(defmethod gemv! ((alpha complex) (A complex-matrix) (x real-matrix)
- (beta cl:real) (y complex-matrix) &optional (job :n))
- (let ((r-A (mrealpart~ A))
- (i-A (mimagpart~ A))
- (r-y (mrealpart~ y))
- (i-y (mimagpart~ y))
- (r-al (coerce (realpart alpha) 'double-float))
- (i-al (coerce (imagpart alpha) 'double-float))
- (r-be (coerce beta 'double-float)))
- (declare (type double-float r-al r-be i-al)
- (type real-matrix r-A i-A r-y i-y))
- (real-double-gemv!-typed r-al r-A x r-be r-y job)
- (real-double-gemv!-typed (- i-al) i-A x 1d0 r-y job)
- ;;
- (real-double-gemv!-typed i-al r-A x r-be i-y job)
- (real-double-gemv!-typed r-al i-A x 1d0 i-y job))
+(defmethod gemv! ((alpha number) (A complex-matrix) (x real-vector)
+ (beta number) (y complex-vector) &optional (job :n))
+ (let ((cplx-x (make-complex-tensor (aref (dimensions x) 0))))
+ (real-typed-copy! x (tensor-realpart~ cplx-x))
+ (complex-typed-gemv! (coerce-complex alpha) A cplx-x
+ (coerce-complex beta) y job))
y)
-;;;;
+;;---------------------------------------------------------------;;
(defgeneric gemv (alpha A x beta y &optional job)
(:documentation
"
@@ -302,12 +199,17 @@
:T alpha * A'* x + beta * y
"))
-(defmethod gemv ((alpha number) (A standard-matrix) (x standard-matrix)
- (beta number) (y standard-matrix) &optional (job :n))
- (let ((result (scal (if (or (typep alpha 'complex) (typep beta 'complex)
- (typep A 'complex-matrix) (typep x 'complex-matrix))
- (complex-coerce beta)
- beta)
- y)))
- (declare (type standard-matrix y))
+(defmethod gemv ((alpha number) (A standard-matrix) (x standard-vector)
+ (beta number) (y complex-vector) &optional (job :n))
+ (let ((result (copy y)))
(gemv! alpha A x 1d0 result job)))
+
+(defmethod gemv ((alpha number) (A standard-matrix) (x standard-vector)
+ (beta number) (y real-vector) &optional (job :n))
+ (let ((result (if (or (complexp alpha) (complexp beta)
+ (typep A 'complex-matrix) (typep x'complex-matrix))
+ (make-complex-tensor (aref (dimensions y) 0))
+ (make-real-tensor (aref (dimensions y) 0)))))
+ (copy! y result)
+ (gemv! alpha A x beta result job)))
+
commit 38da10cc73eaa514e7bcacc1f996eeefda503078
Author: Akshay Srinivasan <aks...@gm...>
Date: Mon Jul 9 12:44:34 2012 +0530
o Added optimization for matrix, vector classes {follows to <>-tensor}.
o All methods in dot are now defined for <>-vector classes.
diff --git a/src/classes/complex-tensor.lisp b/src/classes/complex-tensor.lisp
index 3ba3f1e..828af4b 100644
--- a/src/classes/complex-tensor.lisp
+++ b/src/classes/complex-tensor.lisp
@@ -80,6 +80,8 @@ Cannot hold complex numbers."))
(rotatef (aref tstore (* 2 tidx)) (aref fstore (* 2 fidx)))
(rotatef (aref tstore (1+ (* 2 tidx))) (aref fstore (1+ (* 2 fidx)))))))
+(setf (get-tensor-class-optimization 'complex-matrix) 'complex-tensor
+ (get-tensor-class-optimization 'complex-vector) 'complex-tensor)
;;
(defmethod print-element ((tensor complex-tensor)
element stream)
diff --git a/src/classes/real-tensor.lisp b/src/classes/real-tensor.lisp
index 89bfefc..d896616 100644
--- a/src/classes/real-tensor.lisp
+++ b/src/classes/real-tensor.lisp
@@ -57,6 +57,9 @@ Allocates real storage. Default initial-element = 0d0.")
(lambda (fstore fidx tstore tidx)
(rotatef (aref tstore tidx) (aref fstore fidx))))
+(setf (get-tensor-class-optimization 'real-matrix) 'real-tensor
+ (get-tensor-class-optimization 'real-vector) 'real-tensor)
+
;;
(defmethod (setf tensor-ref) ((value number) (tensor real-tensor) subscripts)
(let ((sto-idx (store-indexing subscripts tensor)))
diff --git a/src/level-1/dot.lisp b/src/level-1/dot.lisp
index 6e7a18a..59d00ab 100644
--- a/src/level-1/dot.lisp
+++ b/src/level-1/dot.lisp
@@ -58,33 +58,25 @@
If X and Y are both scalars then this is the same
as (* (CONJUGATE X) Y) if CONJUAGTE-P and (* X Y)
otherwise.
-"))
+")
+ (:method :before ((x standard-vector) (y standard-vector) &optional (conjugate-p t))
+ (declare (ignore conjugate-p))
+ (unless (idx= (dimensions x) (dimensions y))
+ (error 'tensor-dimension-mismatch))))
(defmethod dot ((x number) (y number) &optional (conjugate-p t))
(if conjugate-p
(* (conjugate x) y)
(* x y)))
-(defmethod dot :before ((x standard-tensor) (y standard-tensor) &optional (conjugate-p t))
- (declare (ignore conjugate-p))
- (unless (and (vector-p x) (vector-p y))
- (error 'tensor-not-vector
- :rank (cond
- ((not (vector-p x))
- (rank x))
- ((not (vector-p y))
- (rank y)))))
- (unless (idx= (dimensions x) (dimensions y))
- (error 'tensor-dimension-mismatch)))
-
-(defmethod dot ((x real-tensor) (y real-tensor) &optional (conjugate-p t))
+(defmethod dot ((x real-vector) (y real-vector) &optional (conjugate-p t))
(declare (ignore conjugate-p))
(ddot (number-of-elements x)
(store x) (aref (strides x) 0)
(store y) (aref (strides y) 0)
(head x) (head y)))
-(defmethod dot ((x real-tensor) (y complex-tensor) &optional (conjugate-p t))
+(defmethod dot ((x real-vector) (y complex-vector) &optional (conjugate-p t))
(declare (ignore conjugate-p))
(let ((nele (number-of-elements x))
(std-x (aref (strides x) 0))
@@ -99,13 +91,13 @@
rpart
(complex rpart ipart)))))
-(defmethod dot ((x complex-tensor) (y real-tensor) &optional (conjugate-p t))
+(defmethod dot ((x complex-vector) (y real-vector) &optional (conjugate-p t))
(let ((cres (dot y x)))
(if conjugate-p
(conjugate cres)
cres)))
-(defmethod dot ((x complex-tensor) (y complex-tensor) &optional (conjugate-p t))
+(defmethod dot ((x complex-vector) (y complex-vector) &optional (conjugate-p t))
(let ((nele (number-of-elements x))
(std-x (aref (strides x) 0))
(hd-x (head x))
-----------------------------------------------------------------------
Summary of changes:
matlisp.asd | 6 +-
packages.lisp | 1 +
src/base/blas-helpers.lisp | 21 +--
src/classes/complex-tensor.lisp | 2 +
src/classes/real-tensor.lisp | 3 +
src/conditions.lisp | 4 +
src/ffi/ffi-cffi.lisp | 2 +
src/level-1/axpy.lisp | 4 +-
src/level-1/dot.lisp | 26 +--
src/level-2/gemv.lisp | 408 +++++++++++++++------------------------
10 files changed, 192 insertions(+), 285 deletions(-)
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2012-07-07 16:01:08
|
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 cfd1ff7fa12112dcb0df038f9ecd60a5d637aa18 (commit)
from 6876d4167f165dbd6b9326251171d94020c99d64 (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 cfd1ff7fa12112dcb0df038f9ecd60a5d637aa18
Author: Akshay Srinivasan <aks...@gm...>
Date: Sat Jul 7 21:25:06 2012 +0530
o Moved reader.lisp, and Mark Kantrowitz' "infix" to srcdir;src;reader
diff --git a/src/old/reader.lisp b/src/old/reader.lisp
index 6a92ee1..db81edb 100644
--- a/src/old/reader.lisp
+++ b/src/old/reader.lisp
@@ -279,7 +279,6 @@
(peek-ahead-no-hang stream nil nil t)
(return val))))))
-
(with-input-from-string (ostr "[1 2; 3 4]")
(parse-matrix-expression ostr #\[))
diff --git a/lib-src/infix/infix.asd b/src/reader/infix/infix.asd
similarity index 100%
rename from lib-src/infix/infix.asd
rename to src/reader/infix/infix.asd
diff --git a/lib-src/infix/src.lisp b/src/reader/infix/src.lisp
similarity index 100%
rename from lib-src/infix/src.lisp
rename to src/reader/infix/src.lisp
diff --git a/src/reader.lisp b/src/reader/reader.lisp
similarity index 96%
rename from src/reader.lisp
rename to src/reader/reader.lisp
index dd39176..97eaaa2 100644
--- a/src/reader.lisp
+++ b/src/reader/reader.lisp
@@ -1,10 +1,10 @@
(in-package #:matlisp)
-
;;TODO move things from old/reader.lisp; must adapt things to reading tensors.
(define-constant +parser-ignored-characters+ '(#\^m #\space #\tab #\return #\newline))
(define-constant +newline-characters+ '(#\newline #\^m #\linefeed #\return))
+;;General stuff--------------------------------------------------;;
(defun peek-ahead-no-hang (&optional (stream *standard-input*) (eof-error t) eof-value recursive-p)
(symbol-macrolet ((pop-char (read-char-no-hang stream eof-error eof-value recursive-p)))
(loop
@@ -35,7 +35,9 @@
((member char +parser-ignored-characters+) nil)
(t t))
finally (return char))))
-;;---------------------------------------------------------------;;
+
+
+;;Array slicer---------------------------------------------------;;
(defun get-slicing-subscript (lst)
(flet ((idxp (x)
(or (consp x)
@@ -171,3 +173,5 @@
#+nil(with-input-from-string (ostr "x[0:5, 0, 0]$ ")
(parse-indexing-expression ostr #\$))
+
+;;Tensor reader--------------------------------------------------;;
-----------------------------------------------------------------------
Summary of changes:
src/old/reader.lisp | 1 -
{lib-src => src/reader}/infix/infix.asd | 0
{lib-src => src/reader}/infix/src.lisp | 0
src/{ => reader}/reader.lisp | 8 ++++++--
4 files changed, 6 insertions(+), 3 deletions(-)
rename {lib-src => src/reader}/infix/infix.asd (100%)
rename {lib-src => src/reader}/infix/src.lisp (100%)
rename src/{ => reader}/reader.lisp (96%)
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2012-07-07 07:30:58
|
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 6876d4167f165dbd6b9326251171d94020c99d64 (commit)
via 5b9abacfd46513064abdbc7f8ebe75c23d66b030 (commit)
via 1acff5176bfbef93576185057fe527cc70b9bb5a (commit)
from 9c1d88d3e0101d6764260ba190f852435335a5e2 (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 6876d4167f165dbd6b9326251171d94020c99d64
Author: Akshay Srinivasan <aks...@gm...>
Date: Sat Jul 7 12:54:41 2012 +0530
o Comments to reader.lisp
Using $x{..}$ instead of $x[..]$ does a copy instead of the
in-place-displaced slicing (ala MATLAB vs Numpy).
diff --git a/src/reader.lisp b/src/reader.lisp
index 3de78aa..dd39176 100644
--- a/src/reader.lisp
+++ b/src/reader.lisp
@@ -96,8 +96,11 @@
(t
(error 'parser-error)))))
-(defun parse-indexing-expression (stream char)
- (declare (ignore char))
+(defun parse-indexing-expression (stream macro-char)
+ (declare (ignore macro-char))
+ ;;macro-char is assumed to be #\$
+ ;;#\[...#\] uses sub-tensor~ (displaced)
+ ;;#\{...#\} uses sub-tensor (copied)
(labels ((pop-char () (read-char stream t nil t))
(pop-ichar () (read-interesting-char stream t nil t))
(peek () (peek-ahead-no-hang stream t nil t))
commit 5b9abacfd46513064abdbc7f8ebe75c23d66b030
Author: Akshay Srinivasan <aks...@gm...>
Date: Sat Jul 7 12:50:06 2012 +0530
o More tweaks to the reader.
This now works (x like previous log):
? $x[::2, 0:2]$
#<REAL-MATRIX #(2 2) :DISPLACED
1.0000 2.0000
7.0000 8.0000
>
?
diff --git a/src/reader.lisp b/src/reader.lisp
index dd45aca..3de78aa 100644
--- a/src/reader.lisp
+++ b/src/reader.lisp
@@ -52,7 +52,7 @@
((null (cddr lst)) ; '(\: \:)
'(quote \:))
((idxp (third lst)) ; '(\: \: num)
- `(list (list '\: ,(third lst)) 0 *))
+ `(list (list '\: ,(third lst)) 0))
(t
(error 'parser-error))))
((idxp (second lst)) ; '(\: num *)
@@ -71,14 +71,14 @@
(first lst))
((and (eq (second lst) #\:) ; '(num \:)
(null (cddr lst)))
- `(list '\: ,(first lst) '*))
+ `(list '\: ,(first lst)))
((and (eq (second lst) #\:) ; '(num \: \: *)
(eq (third lst) #\:))
(cond
((null (cdddr lst)) ; '(num \: \:)
- `(list '\: ,(first lst) '*))
+ `(list '\: ,(first lst)))
((idxp (fourth lst)) ; '(num \: \: num)
- `(list (list '\: ,(fourth lst)) ,(first lst) '*))
+ `(list (list '\: ,(fourth lst)) ,(first lst)))
(t
(error 'parser-error))))
((and (eq (second lst) #\:) ; '(num \: num *)
commit 1acff5176bfbef93576185057fe527cc70b9bb5a
Author: Akshay Srinivasan <aks...@gm...>
Date: Sat Jul 7 12:40:42 2012 +0530
o Added a python-like reader macro for array slicing.
This now works (after loading reader.lisp):
? (defvar x (make-real-tensor '((1 2 3) (4 5 6) (7 8 9))))
X
? $x[:, 0:2]$
#<REAL-MATRIX #(3 2) :DISPLACED
1.0000 2.0000
4.0000 5.0000
7.0000 8.0000
?
P.S: Reader macros are annoying to write.
o Added lots of checks to sub-tensor~, and an option to preserve rank.
diff --git a/README b/README
index 8863d66..029550d 100644
--- a/README
+++ b/README
@@ -20,6 +20,7 @@ This is the development branch of Matlisp.
** TODO : What remains ? (Help!)
*** Functionality
* Make everything in src/old/ compatible with new datastrutures.
+ * Add negative stride support, ala Python.
* Tensor contraction: Hard to do very quickly.
Might have to copy stuff into a contiguous array; like Femlisp.
* BLAS level-2 and level-3: most importantly Matrix multiplication.
diff --git a/packages.lisp b/packages.lisp
index 781846a..4ce172e 100644
--- a/packages.lisp
+++ b/packages.lisp
@@ -36,6 +36,7 @@
#:invalid-type #:given #:expected
#:invalid-value #:given #:expected
#:unknown-token #:token
+ #:parser-error
#:coercion-error #:from #:to
#:out-of-bounds-error #:requested #:bound
#:non-uniform-bounds-error #:assumed #:found
diff --git a/src/base/standard-tensor.lisp b/src/base/standard-tensor.lisp
index 3b5c8e1..37e7cd8 100644
--- a/src/base/standard-tensor.lisp
+++ b/src/base/standard-tensor.lisp
@@ -482,7 +482,7 @@
"
Symbols which are used to refer to slicing operations.")
-(defun sub-tensor~ (tensor subscripts)
+(defun sub-tensor~ (tensor subscripts &optional (preserve-rank nil))
"
Syntax
======
@@ -508,7 +508,9 @@
;; Get [:, :, 0:10:2] (0:10:2 = [i : 0 <= i < 10, i % 2 = 0])
> (sub-tensor~ X '(\: \: ((\: 2) 0 *)))
"
- (declare (type standard-tensor tensor))
+ (declare (type standard-tensor tensor)
+ (type list subscripts)
+ (type boolean preserve-rank))
(let ((rank (rank tensor))
(dims (dimensions tensor))
(stds (strides tensor))
@@ -522,23 +524,33 @@
:index-rank i :rank rank)
(values nhd (nreverse ndims) (nreverse nstds)))
(let ((csub (car subs)))
- (if (or (consp csub) (symbolp csub))
- (destructuring-bind (op &optional (ori 0) (end '*)) (ensure-list csub)
- (assert (or (typep end 'index-type) (eq end '*)) nil 'invalid-type
- :message "END must either be an integer or '*"
- :given (type-of end) :expected '(or (typep end 'index-type) (eq end '*)))
- (let ((op-val (if (consp op) (first op) op)))
- (assert (member op-val +array-slicing-symbols+) nil 'invalid-value
- :message "Cannot find OP in +array-slicing-symbols+"
- :given op-val :expected `(member op ,+array-slicing-symbols+)))
- (let* ((mul (if (consp op) (second op) 1))
- (dim (floor (- (if (eq end '*) (aref dims i) end) ori) mul)))
- (sub-tread (1+ i) (cdr subs) (+ nhd (* ori (aref stds i))) (cons dim ndims) (cons (* mul (aref stds i)) nstds))))
- (progn
- (assert (typep csub 'index-type) nil 'invalid-type
- :message "OP must be of type index-type"
- :given (type-of csub) :expected 'index-type)
- (sub-tread (1+ i) (cdr subs) (+ nhd (* csub (aref stds i))) ndims nstds)))))))
+ (cond
+ ((or (consp csub)
+ (and (symbolp csub) (member csub +array-slicing-symbols+)))
+ (destructuring-bind ((op &optional (step 1)) &optional (ori 0) (end (aref dims i))) (if (consp csub)
+ (cons (ensure-list (car csub)) (cdr csub))
+ (list (ensure-list csub)))
+ (assert (and (typep ori 'index-type) (< -1 ori (aref dims i))) nil 'tensor-index-out-of-bounds
+ :argument i :index ori :dimension (aref dims i))
+ (assert (and (typep ori 'index-type) (< ori end (1+ (aref dims i)))) nil 'invalid-value
+ :given end :expected `(> ,ori end ,(1+ (aref dims i))) :message "END is outside allowed bounds.")
+ (assert (and (typep step 'index-type) (< 0 step)) nil 'invalid-value
+ :given step :expected '(< 0 step) :message "STEP cannot be <= 0.")
+ (assert (member op +array-slicing-symbols+) nil 'invalid-value
+ :message "Cannot find OP in +array-slicing-symbols+"
+ :given op :expected `(member op ,+array-slicing-symbols+))
+ (let ((dim (ceiling (- end ori) step)))
+ (sub-tread (1+ i) (cdr subs) (+ nhd (* ori (aref stds i)))
+ (if (and (= dim 1) (not preserve-rank)) ndims (cons dim ndims))
+ (if (and (= dim 1) (not preserve-rank)) nstds (cons (* step (aref stds i)) nstds))))))
+ ((typep csub 'index-type)
+ (assert (< -1 csub (aref dims i)) nil 'tensor-index-out-of-bounds
+ :argument i :index csub :dimension (aref dims i))
+ (sub-tread (1+ i) (cdr subs) (+ nhd (* csub (aref stds i)))
+ (if (not preserve-rank) ndims (cons 1 ndims))
+ (if (not preserve-rank) nstds (cons (aref stds i) nstds))))
+ (t
+ (error 'parser-error :message "Error parsing subscript-list.")))))))
(multiple-value-bind (nhd ndim nstd) (sub-tread 0 subscripts hd nil nil)
(let ((nrnk (length ndim)))
(declare (type index-type nrnk))
diff --git a/src/conditions.lisp b/src/conditions.lisp
index 0a91466..a4e17a3 100644
--- a/src/conditions.lisp
+++ b/src/conditions.lisp
@@ -47,6 +47,10 @@
(format stream "Given unknown token: ~A.~%" (token c))
(call-next-method)))
+(defcondition parser-error (generic-error)
+ ()
+ (:documentation "Macro reader encountered an error while parsing the stream."))
+
(defcondition coercion-error (generic-error)
((from :reader from :initarg :from)
(to :reader to :initarg :to))
diff --git a/src/level-1/tensor-maker.lisp b/src/level-1/tensor-maker.lisp
index 029ba28..df44ae0 100644
--- a/src/level-1/tensor-maker.lisp
+++ b/src/level-1/tensor-maker.lisp
@@ -46,3 +46,7 @@
(make-tensor-maker make-real-tensor (real-tensor))
(make-tensor-maker make-complex-tensor (complex-tensor))
+
+;;Had to move it here in the wait for copy!
+(definline sub-tensor (tensor subscripts)
+ (copy (sub-tensor~ tensor subscripts)))
diff --git a/src/level-2/gemv.lisp b/src/level-2/gemv.lisp
index d793da8..8651f95 100644
--- a/src/level-2/gemv.lisp
+++ b/src/level-2/gemv.lisp
@@ -31,8 +31,8 @@
`(defun ,func (alpha A x beta y job)
(declare (type (getf opt :element-type) alpha beta)
(type ,tensor-class A x y)
- (type boolean job))
-
+ (type boolean job))
+ (tensor-t
;;There's no support for ":c", because there is no
diff --git a/src/old/reader.lisp b/src/old/reader.lisp
index 7893105..6a92ee1 100644
--- a/src/old/reader.lisp
+++ b/src/old/reader.lisp
@@ -280,11 +280,13 @@
(return val))))))
+(with-input-from-string (ostr "[1 2; 3 4]")
+ (parse-matrix-expression ostr #\[))
-(set-macro-character #\] (get-macro-character #\)))
-(set-macro-character #\[ #'parse-matrix-expression)
+;;(set-macro-character #\] (get-macro-character #\)))
+;;(set-macro-character #\[ #'parse-matrix-expression)
#|
(read-from-string "[ [1 2 ; 3 4] [5 ; 6] ; [7 8 9] ] 1000")
(read-from-string " 1 2 [2]
diff --git a/src/reader.lisp b/src/reader.lisp
new file mode 100644
index 0000000..dd45aca
--- /dev/null
+++ b/src/reader.lisp
@@ -0,0 +1,170 @@
+(in-package #:matlisp)
+
+;;TODO move things from old/reader.lisp; must adapt things to reading tensors.
+
+(define-constant +parser-ignored-characters+ '(#\^m #\space #\tab #\return #\newline))
+(define-constant +newline-characters+ '(#\newline #\^m #\linefeed #\return))
+
+(defun peek-ahead-no-hang (&optional (stream *standard-input*) (eof-error t) eof-value recursive-p)
+ (symbol-macrolet ((pop-char (read-char-no-hang stream eof-error eof-value recursive-p)))
+ (loop
+ for char = pop-char then pop-char
+ and c-prev = nil then char
+ until (cond
+ ((member char +parser-ignored-characters+) nil)
+ (t t))
+ finally (progn
+ (if char
+ (unread-char char stream)
+ (when (member c-prev +newline-characters+)
+ (unread-char c-prev stream)))
+ (return char)))))
+
+(defun peek-char-no-hang (&optional (stream *standard-input*) (eof-error t) eof-value recursive-p)
+ (let ((char (read-char-no-hang stream eof-error eof-value recursive-p)))
+ (when char
+ (unread-char char stream))
+ char))
+
+(defun read-interesting-char (&optional (stream *standard-input*) (eof-error t) eof-value recursive-p)
+ (symbol-macrolet ((pop-char (read-char-no-hang stream eof-error eof-value recursive-p)))
+ (loop
+ for char = pop-char then pop-char
+ and c-prev = nil then char
+ until (cond
+ ((member char +parser-ignored-characters+) nil)
+ (t t))
+ finally (return char))))
+;;---------------------------------------------------------------;;
+(defun get-slicing-subscript (lst)
+ (flet ((idxp (x)
+ (or (consp x)
+ (and (symbolp x)
+ (not (member x '(t nil))))
+ (numberp x))))
+ (cond
+ ((eq (first lst) #\:) ; '(\: * *)
+ (cond
+ ((null (cdr lst)) ; '(\:)
+ '(quote \:))
+ ((eq (second lst) #\:) ; '(\: \: *)
+ (cond
+ ((null (cddr lst)) ; '(\: \:)
+ '(quote \:))
+ ((idxp (third lst)) ; '(\: \: num)
+ `(list (list '\: ,(third lst)) 0 *))
+ (t
+ (error 'parser-error))))
+ ((idxp (second lst)) ; '(\: num *)
+ (cond
+ ((or (null (cddr lst))
+ (null (cdddr lst))) ; '(\: num) or '(\: num \:)
+ `(list '\: 0 ,(second lst)))
+ ((and (eq (third lst) #\:) ; '(\: num \: num)
+ (idxp (fourth lst)))
+ `(list (list '\: ,(third lst)) 0 ,(second lst)))
+ (t
+ (error 'parser-error))))))
+ ((idxp (first lst)) ; '(num *)
+ (cond
+ ((null (cdr lst)) ; '(num)
+ (first lst))
+ ((and (eq (second lst) #\:) ; '(num \:)
+ (null (cddr lst)))
+ `(list '\: ,(first lst) '*))
+ ((and (eq (second lst) #\:) ; '(num \: \: *)
+ (eq (third lst) #\:))
+ (cond
+ ((null (cdddr lst)) ; '(num \: \:)
+ `(list '\: ,(first lst) '*))
+ ((idxp (fourth lst)) ; '(num \: \: num)
+ `(list (list '\: ,(fourth lst)) ,(first lst) '*))
+ (t
+ (error 'parser-error))))
+ ((and (eq (second lst) #\:) ; '(num \: num *)
+ (idxp (third lst)))
+ (cond
+ ((or (null (cdddr lst)) ; '(num \: num) or '(num \: num \:)
+ (and (eq (fourth lst) #\:)
+ (null (cddddr lst))))
+ `(list '\: ,(first lst) ,(third lst)))
+ ((and (eq (fourth lst) #\:) ; '(num \: num \: num)
+ (idxp (fifth lst)))
+ `(list (list '\: ,(fifth lst)) ,(first lst) ,(third lst)))
+ (t
+ (error 'parser-error))))))
+ (t
+ (error 'parser-error)))))
+
+(defun parse-indexing-expression (stream char)
+ (declare (ignore char))
+ (labels ((pop-char () (read-char stream t nil t))
+ (pop-ichar () (read-interesting-char stream t nil t))
+ (peek () (peek-ahead-no-hang stream t nil t))
+ (idxp (x) (or (consp x)
+ (and (symbolp x)
+ (not (member x '(t nil))))
+ (numberp x)))
+ (get-idx-expr (limlst)
+ (loop
+ for char = (pop-char) then (pop-char)
+ counting t into n
+ if (not (member char limlst))
+ collect char into ret
+ else
+ do (progn
+ (unread-char char stream)
+ (return (read-from-string (make-array (1- n) :element-type 'character :initial-contents ret) nil nil)))
+ end)))
+ (let* ((tensor (get-idx-expr `(#\[ #\{ #\$)))
+ (idx-char (pop-ichar))
+ (sub-func (ecase idx-char
+ (#\[ 'sub-tensor~)
+ (#\{ 'sub-tensor)
+ (#\$ nil)))
+ (cidx-char (case idx-char
+ (#\[ #\])
+ (#\{ #\}))))
+ #+nil(format t "~a ~a ~a~%" tensor idx-char sub-func)
+ (labels ((get-index-list (cur-idx ret)
+ ;;#\, is the delimiting character
+ ;;#\: is the slicing character
+ (let ((pchar (peek)))
+ #+nil(format t "pchar: ~a ~%" pchar)
+ (cond
+ ((or (eq pchar cidx-char)
+ (eq pchar #\,))
+ (pop-char)
+ (let ((idx-lst (reverse cur-idx)))
+ (when (null idx-lst)
+ (error 'parser-error :message "No slicing argument given."))
+ (loop
+ for cur in idx-lst
+ and pcur = nil then cur
+ counting (eq cur #\:) into cnt
+ unless (<= cnt 2)
+ do (error 'parser-error :message "Too many slicing characters.")
+ when (and (idxp pcur) (idxp cur))
+ do (error 'parser-error :message "Invalid syntax specify slicing operation."))
+ (push (get-slicing-subscript idx-lst) ret))
+ (if (eq pchar #\,)
+ (get-index-list nil ret)
+ (progn
+ (unless (eq (pop-ichar) #\$)
+ (error 'parser-error :message "Invalid syntax: cannot find closing #\$."))
+ ;;And finally!
+ (cons 'list (reverse ret)))))
+ ((eq pchar #\:)
+ (pop-char)
+ (get-index-list (cons #\: cur-idx) ret))
+ (t
+ (let ((idxe (get-idx-expr (append +parser-ignored-characters+ `(#\: #\, ,cidx-char #\$)))))
+ (get-index-list (cons idxe cur-idx) ret)))))))
+ (if (null sub-func)
+ tensor
+ `(,sub-func ,tensor ,(get-index-list nil nil)))))))
+
+(set-macro-character #\$ #'parse-indexing-expression)
+
+#+nil(with-input-from-string (ostr "x[0:5, 0, 0]$ ")
+ (parse-indexing-expression ostr #\$))
-----------------------------------------------------------------------
Summary of changes:
README | 1 +
packages.lisp | 1 +
src/base/standard-tensor.lisp | 50 +++++++-----
src/conditions.lisp | 4 +
src/level-1/tensor-maker.lisp | 4 +
src/level-2/gemv.lisp | 4 +-
src/old/reader.lisp | 6 +-
src/reader.lisp | 173 +++++++++++++++++++++++++++++++++++++++++
8 files changed, 220 insertions(+), 23 deletions(-)
create mode 100644 src/reader.lisp
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2012-07-06 15:31:25
|
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 9c1d88d3e0101d6764260ba190f852435335a5e2 (commit)
via e09abd6390492ec30a362f91a286558388cd7bec (commit)
from 9bb4a65ad72358711bb82ff45cded5462e739def (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 9c1d88d3e0101d6764260ba190f852435335a5e2
Author: Akshay Srinivasan <aks...@gm...>
Date: Fri Jul 6 20:56:47 2012 +0530
Added a redundant clause to convert rank-2 tensors into matrices.
diff --git a/src/base/standard-tensor.lisp b/src/base/standard-tensor.lisp
index 0adb655..3b5c8e1 100644
--- a/src/base/standard-tensor.lisp
+++ b/src/base/standard-tensor.lisp
@@ -540,13 +540,20 @@
:given (type-of csub) :expected 'index-type)
(sub-tread (1+ i) (cdr subs) (+ nhd (* csub (aref stds i))) ndims nstds)))))))
(multiple-value-bind (nhd ndim nstd) (sub-tread 0 subscripts hd nil nil)
- (cond
- ((null ndim) (tensor-store-ref tensor nhd))
- ((= (length ndim) 1) (let ((cocl (getf (get-tensor-counterclass (class-name (class-of tensor))) :vector)))
- (assert cocl nil 'tensor-cannot-find-counter-class :tensor-class (class-name (class-of tensor)))
- (make-instance cocl
- :parent-tensor tensor :store (store tensor) :head nhd
- :dimensions (make-index-store ndim) :strides (make-index-store nstd))))
- (t (make-instance (class-name (class-of tensor))
- :parent-tensor tensor :store (store tensor) :head nhd
- :dimensions (make-index-store ndim) :strides (make-index-store nstd))))))))
+ (let ((nrnk (length ndim)))
+ (declare (type index-type nrnk))
+ (cond
+ ((null ndim) (tensor-store-ref tensor nhd))
+ ((= nrnk 1) (let ((cocl (getf (get-tensor-counterclass (class-name (class-of tensor))) :vector)))
+ (assert cocl nil 'tensor-cannot-find-counter-class :tensor-class (class-name (class-of tensor)))
+ (make-instance cocl
+ :parent-tensor tensor :store (store tensor) :head nhd
+ :dimensions (make-index-store ndim) :strides (make-index-store nstd))))
+ ((= nrnk 2) (let ((cocl (getf (get-tensor-counterclass (class-name (class-of tensor))) :matrix)))
+ (assert cocl nil 'tensor-cannot-find-counter-class :tensor-class (class-name (class-of tensor)))
+ (make-instance cocl
+ :parent-tensor tensor :store (store tensor) :head nhd
+ :dimensions (make-index-store ndim) :strides (make-index-store nstd))))
+ (t (make-instance (class-name (class-of tensor))
+ :parent-tensor tensor :store (store tensor) :head nhd
+ :dimensions (make-index-store ndim) :strides (make-index-store nstd)))))))))
commit e09abd6390492ec30a362f91a286558388cd7bec
Author: Akshay Srinivasan <aks...@gm...>
Date: Fri Jul 6 20:51:41 2012 +0530
o Got rid of the tensor-sub-classes.
Checking whether 'parent-tensor slot is bound
is much more easier.
o Added vector subclass
o Classes is now automatically changed after initialization.
If rank = 2 {matrix} or rank = 1 {vector}.
diff --git a/packages.lisp b/packages.lisp
index 264a6da..781846a 100644
--- a/packages.lisp
+++ b/packages.lisp
@@ -54,7 +54,7 @@
#:tensor-invalid-head-value #:head
#:tensor-invalid-dimension-value #:argument #:dimension
#:tensor-invalid-stride-value #:argument #:stride
- #:tensor-cannot-find-sub-class #:tensor-class
+ #:tensor-cannot-find-counter-class #:tensor-class
#:tensor-cannot-find-optimization #:tensor-class
#:tensor-dimension-mismatch
))
diff --git a/src/base/blas-helpers.lisp b/src/base/blas-helpers.lisp
index ce40b7f..39de052 100644
--- a/src/base/blas-helpers.lisp
+++ b/src/base/blas-helpers.lisp
@@ -37,25 +37,26 @@
finally (return (aref sort-std 0))))))
-;; (defun blas-matrix-compatible-p (matrix &optional (op :n))
-;; (declare (optimize (safety 0) (speed 3))
-;; (type (or real-matrix complex-matrix) matrix))
-;; (mlet* (((rs cs) (slot-values matrix '(row-stride col-stride))
-;; :type (fixnum fixnum)))
-;; (cond
-;; ((= cs 1) (values :row-major rs (fortran-nop op)))
-;; ((= rs 1) (values :col-major cs (fortran-op op)))
-;; ;;Lets not confound lisp's type declaration.
-;; (t (values nil -1 "?")))))
+(defun blas-matrix-compatible-p (matrix &optional (op :n))
+ (declare (type standard-tensor matrix))
+ (let ((stds (strides matrix)))
+ (declare (type (index-array *) stds))
+ (if (not (= (array-dimension stds 0) 2)) nil
+ (let ((rs (aref stds 0))
+ (cs (aref stds 1)))
+ (declare (type index-type rs cs))
+ (cond
+ ((= cs 1) (values :row-major rs (fortran-nop op)))
+ ((= rs 1) (values :col-major cs (fortran-op op))))))))
-;; (definline fortran-op (op)
-;; (ecase op (:n "N") (:t "T")))
+(definline fortran-op (op)
+ (ecase op (:n "N") (:t "T")))
-;; (definline fortran-nop (op)
-;; (ecase op (:t "N") (:n "T")))
+(definline fortran-nop (op)
+ (ecase op (:t "N") (:n "T")))
-;; (defun fortran-snop (sop)
-;; (cond
-;; ((string= sop "N") "T")
-;; ((string= sop "T") "N")
-;; (t (error "Unrecognised fortran-op."))))
+(defun fortran-snop (sop)
+ (cond
+ ((string= sop "N") "T")
+ ((string= sop "T") "N")
+ (t (error "Unrecognised fortran-op."))))
diff --git a/src/base/loopy.lisp b/src/base/loopy.lisp
index 0948662..62254fe 100644
--- a/src/base/loopy.lisp
+++ b/src/base/loopy.lisp
@@ -212,7 +212,7 @@
;;list-dimensions does not parse the entire list, just goes through caaa..r's to find out the
;;dimensions if it is uniform.
(unless (< -1 (aref ,idx ,lst-rec-count-sym) (aref ,dims-sym ,lst-rec-count-sym))
- (error 'out-of-bounds-error :requested ,lst-rec-count-sym :bound (aref ,dims-sym ,lst-rec-count-sym)
+ (error 'out-of-bounds-error :requested (aref ,idx ,lst-rec-count-sym) :bound (aref ,dims-sym ,lst-rec-count-sym)
:message "Error in list-loop, given list is not uniform in dimensions."))
(if (consp (car ,lst-rec-lst-sym))
(,lst-rec-sym (1+ ,lst-rec-count-sym) (car ,lst-rec-lst-sym))
diff --git a/src/base/print.lisp b/src/base/print.lisp
index bcd5b19..7200306 100644
--- a/src/base/print.lisp
+++ b/src/base/print.lisp
@@ -105,5 +105,8 @@ of a matrix (default 0)
(defmethod print-object ((tensor standard-tensor) stream)
(print-unreadable-object (tensor stream :type t)
- (format stream "~A~%" (dimensions tensor))
+ (if (slot-boundp tensor 'parent-tensor)
+ (format stream "~A~,4T:DISPLACED~%" (dimensions tensor))
+ (format stream "~A~%" (dimensions tensor)))
(print-tensor tensor stream)))
+
diff --git a/src/base/standard-tensor.lisp b/src/base/standard-tensor.lisp
index 2bd89c4..0adb655 100644
--- a/src/base/standard-tensor.lisp
+++ b/src/base/standard-tensor.lisp
@@ -48,6 +48,12 @@
:type index-type
:documentation "Total number of elements in the tensor.")
;;
+ (parent-tensor
+ :accessor parent-tensor
+ :initarg :parent-tensor
+ :type standard-tensor
+ :documentation "If the tensor is a view of another tensor, then this slot is bound.")
+ ;;
(head
:initarg :head
:initform 0
@@ -69,20 +75,70 @@
:documentation "The actual storage for the tensor."))
(:documentation "Basic tensor class."))
-(defclass standard-sub-tensor (standard-tensor)
- ((parent-tensor
- :initarg :parent-tensor
- :accessor parent-tensor))
- (:documentation "Basic sub-tensor class."))
+;;
+(defclass standard-matrix (standard-tensor)
+ ((rank
+ :accessor rank
+ :type index-type
+ :initform 2
+ :documentation "For a matrix, rank = 2."))
+ (:documentation "Basic matrix class."))
+
+(defmethod initialize-instance :after ((matrix standard-matrix) &rest initargs)
+ (declare (ignore initargs))
+ (mlet*
+ ((rank (rank matrix) :type index-type))
+ (unless (= rank 2)
+ (error 'tensor-not-matrix :rank rank :tensor matrix))))
+
+(defmethod update-instance-for-different-class :before ((old standard-tensor) (new standard-matrix) &rest initargs)
+ (declare (ignore initargs))
+ (unless (= (rank old) 2)
+ (error 'tensor-not-matrix :rank (rank old))))
;;
-(defparameter *sub-tensor-counterclass* (make-hash-table)
+(defclass standard-vector (standard-tensor)
+ ((rank
+ :accessor rank
+ :type index-type
+ :initform 1
+ :documentation "For a vector, rank = 1."))
+ (:documentation "Basic vector class."))
+
+(defmethod initialize-instance :after ((vector standard-vector) &rest initargs)
+ (declare (ignore initargs))
+ (mlet*
+ ((rank (rank vector) :type index-type))
+ (unless (= rank 1)
+ (error 'tensor-not-vector :rank rank :tensor vector))))
+
+(defmethod update-instance-for-different-class :before ((old standard-tensor) (new standard-vector) &rest initargs)
+ (declare (ignore initargs))
+ (unless (= (rank old) 1)
+ (error 'tensor-not-vector :rank (rank old))))
+
+;;
+(defparameter *tensor-counterclass* (make-hash-table)
"
- Contains the sub-tensor CLOS counterpart classes of every
- tensor class. This is used by sub-tensor~ and other in-place
- slicing functions to construct new objects.")
+ Contains the CLOS counterpart classes of every tensor class.
+ This is used to change the tensor class automatically to a matrix
+ and vector")
-(setf (gethash 'standard-tensor *sub-tensor-counterclass*) 'standard-sub-tensor)
+(defun get-tensor-counterclass (clname)
+ (declare (type symbol clname))
+ (let ((opt (gethash clname *tensor-counterclass*)))
+ (cond
+ ((null opt) nil)
+ ((symbolp opt)
+ (get-tensor-counterclass opt))
+ (t (values opt clname)))))
+
+(defun (setf get-tensor-counterclass) (value clname)
+ (setf (gethash clname *tensor-counterclass*) value))
+
+(setf (get-tensor-counterclass 'standard-tensor)
+ '(:matrix standard-matrix
+ :vector standard-vector))
;;
(defparameter *tensor-class-optimizations* (make-hash-table)
@@ -109,6 +165,9 @@
(get-tensor-class-optimization opt))
(t (values opt clname)))))
+(defun (setf get-tensor-class-optimization) (value clname)
+ (setf (gethash clname *tensor-class-optimizations*) value))
+
;; Akshay: I have no idea what this does, or why we want it
;; (inherited from standard-matrix.lisp
(defmethod make-load-form ((tensor standard-tensor) &optional env)
@@ -246,7 +305,16 @@
(cond
((<= ns 0) (error 'tensor-invalid-dimension-value :argument i :dimension ns :tensor tensor))
((< st 0) (error 'tensor-invalid-stride-value :argument i :stride st :tensor tensor))))))
- (setf (number-of-elements tensor) (reduce #'* dims))))
+ (setf (number-of-elements tensor) (reduce #'* dims))
+ (cond
+ ((= rank 2)
+ (let ((cocl (getf (get-tensor-counterclass (class-name (class-of tensor))) :matrix)))
+ (assert cocl nil 'tensor-cannot-find-counter-class :tensor-class (class-name (class-of tensor)))
+ (change-class tensor cocl)))
+ ((= rank 1)
+ (let ((cocl (getf (get-tensor-counterclass (class-name (class-of tensor))) :vector)))
+ (assert cocl nil 'tensor-cannot-find-counter-class :tensor-class (class-name (class-of tensor)))
+ (change-class tensor cocl))))))
;;
(defgeneric tensor-store-ref (tensor store-idx)
@@ -302,7 +370,7 @@
:coercer ',coercer
:element-type ',element-type
:store-type ',store-element-type)))
- (setf (gethash ',tensor-class *tensor-class-optimizations*) hst)))))
+ (setf (get-tensor-class-optimization ',tensor-class) hst)))))
;;
(defgeneric tensor-ref (tensor subscripts)
@@ -445,6 +513,8 @@
(dims (dimensions tensor))
(stds (strides tensor))
(hd (head tensor)))
+ (declare (type index-type rank hd)
+ (type (index-array *) dims stds))
(labels ((sub-tread (i subs nhd ndims nstds)
(if (null subs)
(progn
@@ -470,10 +540,13 @@
:given (type-of csub) :expected 'index-type)
(sub-tread (1+ i) (cdr subs) (+ nhd (* csub (aref stds i))) ndims nstds)))))))
(multiple-value-bind (nhd ndim nstd) (sub-tread 0 subscripts hd nil nil)
- (if (null ndim)
- (tensor-store-ref tensor nhd)
- (make-instance (if-ret (gethash (class-name (class-of tensor)) *sub-tensor-counterclass*)
- (error 'tensor-cannot-find-sub-class :tensor-class (class-of tensor)))
- :parent-tensor tensor :store (store tensor) :head nhd
- :dimensions (make-index-store ndim) :strides (make-index-store nstd)))))))
-
+ (cond
+ ((null ndim) (tensor-store-ref tensor nhd))
+ ((= (length ndim) 1) (let ((cocl (getf (get-tensor-counterclass (class-name (class-of tensor))) :vector)))
+ (assert cocl nil 'tensor-cannot-find-counter-class :tensor-class (class-name (class-of tensor)))
+ (make-instance cocl
+ :parent-tensor tensor :store (store tensor) :head nhd
+ :dimensions (make-index-store ndim) :strides (make-index-store nstd))))
+ (t (make-instance (class-name (class-of tensor))
+ :parent-tensor tensor :store (store tensor) :head nhd
+ :dimensions (make-index-store ndim) :strides (make-index-store nstd))))))))
diff --git a/src/classes/complex-tensor.lisp b/src/classes/complex-tensor.lisp
index c876f90..3ba3f1e 100644
--- a/src/classes/complex-tensor.lisp
+++ b/src/classes/complex-tensor.lisp
@@ -35,14 +35,17 @@
:type (complex-base-array *)))
(:documentation "Tensor class with complex elements."))
-(defclass complex-sub-tensor (complex-tensor standard-sub-tensor)
+(defclass complex-matrix (standard-matrix complex-tensor)
()
- (:documentation "Sub-tensor class with complex elements."))
+ (:documentation "Matrix class with complex elements."))
-;;Push the counter sub-class name into a hash-table so that we can
-;;refer to it later from class-ignorant functions.
-(setf (gethash 'complex-tensor *sub-tensor-counterclass*) 'complex-sub-tensor
- (gethash 'complex-sub-tensor *sub-tensor-counterclass*) 'complex-sub-tensor)
+(defclass complex-vector (standard-vector complex-tensor)
+ ()
+ (:documentation "Vector class with complex elements."))
+
+(setf (get-tensor-counterclass 'complex-tensor) '(:matrix complex-matrix :vector complex-vector)
+ (get-tensor-counterclass 'complex-matrix) 'complex-tensor
+ (get-tensor-counterclass 'complex-vector) 'complex-tensor)
;;
(defmethod initialize-instance ((tensor complex-tensor) &rest initargs)
@@ -77,12 +80,6 @@ Cannot hold complex numbers."))
(rotatef (aref tstore (* 2 tidx)) (aref fstore (* 2 fidx)))
(rotatef (aref tstore (1+ (* 2 tidx))) (aref fstore (1+ (* 2 fidx)))))))
-(setf (gethash 'complex-sub-tensor *tensor-class-optimizations*) 'complex-tensor)
-
-(defmethod (setf tensor-ref) ((value number) (tensor complex-tensor) subscripts)
- (let ((sto-idx (store-indexing subscripts tensor)))
- (setf (tensor-store-ref tensor sto-idx) (coerce-complex value))))
-
;;
(defmethod print-element ((tensor complex-tensor)
element stream)
@@ -92,3 +89,7 @@ Cannot hold complex numbers."))
"~11,5,,,,,'Eg"
"#C(~11,4,,,,,'Ee ~11,4,,,,,'Ee)")
realpart imagpart)))
+
+(defmethod (setf tensor-ref) ((value number) (tensor complex-tensor) subscripts)
+ (let ((sto-idx (store-indexing subscripts tensor)))
+ (setf (tensor-store-ref tensor sto-idx) (coerce-complex value))))
diff --git a/src/classes/matrix.lisp b/src/classes/matrix.lisp
index 49948e1..ad059aa 100644
--- a/src/classes/matrix.lisp
+++ b/src/classes/matrix.lisp
@@ -1,18 +1,7 @@
(in-package #:matlisp)
;;
-(defclass standard-matrix (standard-tensor)
- ((rank
- :accessor rank
- :type index-type
- :initform 2
- :documentation "For a matrix, rank = 2."))
- (:documentation "Basic matrix class."))
-
-(defmethod print-object ((tensor standard-matrix) stream)
- (print-unreadable-object (tensor stream :type t)
- (format stream "~A x ~A~%" (nrows tensor) (ncols tensor))
- (print-tensor tensor stream)))
+
(definline nrows (matrix)
(declare (type standard-matrix matrix))
@@ -37,12 +26,7 @@
(list (aref dims 0) (aref dims 1))))
;;
-(defmethod initialize-instance :after ((matrix standard-matrix) &rest initargs)
- (declare (ignore initargs))
- (mlet*
- ((rank (rank matrix) :type index-type))
- (unless (= rank 2)
- (error 'tensor-not-matrix :rank rank :tensor matrix))))
+
;;
(definline row-matrix-p (matrix)
@@ -99,35 +83,8 @@
matrix and a number"))
;;
-(defclass real-matrix (standard-matrix real-tensor)
- ()
- (:documentation "A class of matrices with real elements."))
-
-(defclass real-sub-matrix (real-matrix standard-sub-tensor)
- ()
- (:documentation "Sub-matrix class with real elements."))
-
-(setf (gethash 'real-matrix *sub-tensor-counterclass*) 'real-sub-matrix
- (gethash 'real-sub-matrix *sub-tensor-counterclass*) 'real-sub-matrix
- ;;
- (gethash 'real-matrix *tensor-class-optimizations*) 'real-tensor
- (gethash 'real-sub-matrix *tensor-class-optimizations*) 'real-tensor)
;;
-(defclass complex-matrix (standard-matrix complex-tensor)
- ()
- (:documentation "A class of matrices with complex elements."))
-
-(defclass complex-sub-matrix (complex-matrix standard-sub-tensor)
- ()
- (:documentation "Sub-matrix class with complex elements."))
-
-(setf (gethash 'complex-matrix *sub-tensor-counterclass*) 'complex-sub-matrix
- (gethash 'complex-sub-matrix *sub-tensor-counterclass*) 'complex-sub-matrix
- ;;
- (gethash 'complex-matrix *tensor-class-optimizations*) 'complex-tensor
- (gethash 'complex-sub-matrix *tensor-class-optimizations*) 'complex-tensor)
-
;;
(definline matrix-ref (matrix row &optional col)
diff --git a/src/classes/real-tensor.lisp b/src/classes/real-tensor.lisp
index 0db3b8f..89bfefc 100644
--- a/src/classes/real-tensor.lisp
+++ b/src/classes/real-tensor.lisp
@@ -23,21 +23,24 @@ Allocates real storage. Default initial-element = 0d0.")
:type (real-array *)))
(:documentation "Tensor class with real elements."))
-(defclass real-sub-tensor (real-tensor standard-sub-tensor)
+(defclass real-matrix (standard-matrix real-tensor)
()
- (:documentation "Sub-tensor class with real elements."))
+ (:documentation "A class of matrices with real elements."))
-;;Push the counter sub-class name into a hash-table so that we can
-;;refer to it later from class-ignorant functions.
-(setf (gethash 'real-tensor *sub-tensor-counterclass*) 'real-sub-tensor
- (gethash 'real-sub-tensor *sub-tensor-counterclass*) 'real-sub-tensor)
+(defclass real-vector (standard-vector real-tensor)
+ ()
+ (:documentation "A class of vector with real elements."))
+
+(setf (get-tensor-counterclass 'real-tensor) '(:matrix real-matrix :vector real-vector)
+ (get-tensor-counterclass 'real-matrix) 'real-tensor
+ (get-tensor-counterclass 'real-vector) 'real-tensor)
;;
(defmethod initialize-instance ((tensor real-tensor) &rest initargs)
(setf (store-size tensor) (length (getf initargs :store)))
(call-next-method))
-;;
+;;
(tensor-store-defs (real-tensor real-type real-type)
:store-allocator allocate-real-store
:coercer coerce-real
@@ -54,13 +57,11 @@ Allocates real storage. Default initial-element = 0d0.")
(lambda (fstore fidx tstore tidx)
(rotatef (aref tstore tidx) (aref fstore fidx))))
-(setf (gethash 'real-sub-tensor *tensor-class-optimizations*) 'real-tensor)
-
+;;
(defmethod (setf tensor-ref) ((value number) (tensor real-tensor) subscripts)
(let ((sto-idx (store-indexing subscripts tensor)))
(setf (tensor-store-ref tensor sto-idx) (coerce-real value))))
-;;
(defmethod print-element ((tensor real-tensor)
element stream)
(format stream "~11,5,,,,,'Eg" element))
diff --git a/src/conditions.lisp b/src/conditions.lisp
index 9864362..0a91466 100644
--- a/src/conditions.lisp
+++ b/src/conditions.lisp
@@ -67,7 +67,7 @@
((assumed :reader assumed :initarg :assumed)
(found :reader found :initarg :found))
(:documentation "Bounds are not uniform")
- (:method print-object ((c out-of-bounds-error) stream)
+ (:method print-object ((c non-uniform-bounds-error) stream)
(format stream "The bounds are not uniform, assumed bound : ~a, now found to be : ~a.~%" (assumed c) (found c))
(call-next-method)))
@@ -157,11 +157,11 @@ group-rank: ~a" (seq-len c) (group-rank c)))))
(:report (lambda (c stream)
(format stream "Stride of argument ~A must be >= 0, initialized with ~A." (argument c) (stride c)))))
-(define-condition tensor-cannot-find-sub-class (tensor-error)
+(define-condition tensor-cannot-find-counter-class (tensor-error)
((tensor-class :reader tensor-class :initarg :tensor-class))
- (:documentation "Cannot find sub-class of the given tensor class")
+ (:documentation "Cannot find the counter-class list of the given tensor class")
(:report (lambda (c stream)
- (format stream "Cannot find sub-class of the given tensor class: ~a." (tensor-class c)))))
+ (format stream "Cannot find the counter-class list of the given tensor class: ~a." (tensor-class c)))))
(define-condition tensor-cannot-find-optimization (tensor-error)
((tensor-class :reader tensor-class :initarg :tensor-class))
diff --git a/src/level-1/axpy.lisp b/src/level-1/axpy.lisp
index 35fa404..53be2cd 100644
--- a/src/level-1/axpy.lisp
+++ b/src/level-1/axpy.lisp
@@ -87,7 +87,7 @@
(defmethod axpy! ((alpha number) (x real-tensor) (y complex-tensor))
(let ((tmp (tensor-realpart~ y)))
- (declare (type real-sub-tensor tmp))
+ (declare (type real-tensor tmp))
(etypecase alpha
(cl:real (real-typed-axpy! (coerce-real alpha) x tmp))
(cl:complex
diff --git a/src/level-1/copy.lisp b/src/level-1/copy.lisp
index 76fc081..317c011 100644
--- a/src/level-1/copy.lisp
+++ b/src/level-1/copy.lisp
@@ -135,12 +135,12 @@
(defmethod copy! ((x real-tensor) (y complex-tensor))
;;Borrowed from realimag.lisp
- (let ((tmp (make-instance 'real-sub-tensor
+ (let ((tmp (make-instance 'real-tensor
:parent-tensor y :store (store y)
:dimensions (dimensions y)
:strides (map '(index-array *) #'(lambda (n) (* 2 n)) (strides y))
:head (the index-type (* 2 (head y))))))
- (declare (type real-sub-tensor tmp))
+ (declare (type real-tensor tmp))
(real-typed-copy! x tmp)
;;Increasing the head by 1 points us to the imaginary part.
(incf (head tmp))
diff --git a/src/level-1/realimag.lisp b/src/level-1/realimag.lisp
index 3a0bd0a..a042b94 100644
--- a/src/level-1/realimag.lisp
+++ b/src/level-1/realimag.lisp
@@ -43,7 +43,7 @@
"
(etypecase tensor
(real-tensor tensor)
- (complex-tensor (make-instance 'real-sub-tensor
+ (complex-tensor (make-instance 'real-tensor
:parent-tensor tensor :store (store tensor)
:dimensions (dimensions tensor)
:strides (map '(index-array *) #'(lambda (x) (* 2 x)) (strides tensor))
@@ -65,7 +65,7 @@
"
(etypecase tensor
(real-tensor tensor)
- (complex-tensor (make-instance 'real-sub-tensor
+ (complex-tensor (make-instance 'real-tensor
:parent-tensor tensor :store (store tensor)
:dimensions (dimensions tensor)
:strides (map '(index-array *) #'(lambda (x) (* 2 x)) (strides tensor))
diff --git a/src/old/gemv.lisp b/src/level-2/gemv.lisp
similarity index 85%
rename from src/old/gemv.lisp
rename to src/level-2/gemv.lisp
index 4ce561b..d793da8 100644
--- a/src/old/gemv.lisp
+++ b/src/level-2/gemv.lisp
@@ -1,5 +1,40 @@
(in-package :matlisp)
+(defmacro generate-typed-copy! (func (tensor-class blas-func))
+ ;;Be very careful when using functions generated by this macro.
+ ;;Indexes can be tricky and this has no safety net
+ ;;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)
+ `(defun ,func (from to)
+ (declare (type ,tensor-class from to))
+ (if-let (strd-p (blas-copyable-p from to))
+ (,blas-func (number-of-elements from) (store from) (first strd-p) (store to) (second strd-p) (head from) (head to))
+ (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 ,(funcall (getf opt :reader-writer) 'f-sto 'f-of 't-sto 't-of)))))
+ to)))
+
+
+(defmacro generate-typed-gemv! (func (tensor-class blas-func))
+ (let* ((opt (get-tensor-class-optimization tensor-class)))
+ (assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
+ `(defun ,func (alpha A x beta y job)
+ (declare (type (getf opt :element-type) alpha beta)
+ (type ,tensor-class A x y)
+ (type boolean job))
+
+
+
;;There's no support for ":c", because there is no
;;equivalent of ":n" with complex conjugation.
(defmacro generate-typed-gemv!-func (func element-type store-type matrix-type blas-gemv-func blas-axpy-func blas-dot-func)
@@ -7,6 +42,7 @@
;;Indexes can be tricky and this has no safety net
;;Use only after checking the arguments for compatibility.
`(defun ,func (alpha A x beta y job)
+ (declare (tyep
(declare (type ,element-type alpha beta)
(type ,matrix-type A x y)
(type symbol job))
@@ -274,4 +310,4 @@
beta)
y)))
(declare (type standard-matrix y))
- (gemv! alpha A x 1d0 result job)))
\ No newline at end of file
+ (gemv! alpha A x 1d0 result job)))
diff --git a/tests/loopy-tests.lisp b/tests/loopy-tests.lisp
index 8998588..9f63e62 100644
--- a/tests/loopy-tests.lisp
+++ b/tests/loopy-tests.lisp
@@ -26,10 +26,16 @@
(if (null (cdr dims)) t
(modidx rem (cdr dims)))))
+(defun test-axpy ()
+ (let ((x (copy! pi (make-real-tensor 1000 1000)))
+ (y (make-real-tensor 1000 1000)))
+ (time (axpy! 1d0 x y))
+ t))
+
(defun test-mm-lisp (n)
- (let ((t-a (make-real-tensor-dims n n))
- (t-b (make-real-tensor-dims n n))
- (t-c (make-real-tensor-dims n n)))
+ (let ((t-a (make-real-tensor n n))
+ (t-b (make-real-tensor n n))
+ (t-c (make-real-tensor n n)))
(declare (type real-tensor t-a t-b t-c))
(let ((st-a (store t-a))
(st-b (store t-b))
@@ -55,9 +61,9 @@
do (incf (aref st-c of-c) (* (aref st-a of-a) (aref st-b of-b)))))))))
(defun test-mm-ddot (n)
- (let* ((t-a (make-real-tensor-dims n n))
- (t-b (make-real-tensor-dims n n))
- (t-c (make-real-tensor-dims n n))
+ (let* ((t-a (make-real-tensor n n))
+ (t-b (make-real-tensor n n))
+ (t-c (make-real-tensor n n))
(st-a (store t-a))
(st-b (store t-b))
(st-c (store t-c)))
-----------------------------------------------------------------------
Summary of changes:
packages.lisp | 2 +-
src/base/blas-helpers.lisp | 39 +++++++------
src/base/loopy.lisp | 2 +-
src/base/print.lisp | 5 +-
src/base/standard-tensor.lisp | 118 ++++++++++++++++++++++++++++++++------
src/classes/complex-tensor.lisp | 25 ++++----
src/classes/matrix.lisp | 47 +---------------
src/classes/real-tensor.lisp | 21 ++++---
src/conditions.lisp | 8 +-
src/level-1/axpy.lisp | 2 +-
src/level-1/copy.lisp | 4 +-
src/level-1/realimag.lisp | 4 +-
src/{old => level-2}/gemv.lisp | 38 ++++++++++++-
tests/loopy-tests.lisp | 18 ++++--
14 files changed, 209 insertions(+), 124 deletions(-)
rename src/{old => level-2}/gemv.lisp (85%)
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2012-07-06 11:28:01
|
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 9bb4a65ad72358711bb82ff45cded5462e739def (commit)
via e1fc53ef3b80bbe7de9d2cd8177f465e20d78fe5 (commit)
from 2ea68617e269a162c2e722fe7b3314bec1c49a60 (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 9bb4a65ad72358711bb82ff45cded5462e739def
Author: Akshay Srinivasan <aks...@gm...>
Date: Fri Jul 6 16:49:04 2012 +0530
More tweaks to matlisp.asd
diff --git a/matlisp.asd b/matlisp.asd
index 31cbe92..0644b0e 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -61,7 +61,7 @@
)))
(asdf:defsystem fortran-names
- :pathname #.(translate-logical-pathname "matlisp:src;")
+ :pathname #.(translate-logical-pathname "matlisp:src;ffi;")
:depends-on ("matlisp-packages" "matlisp-conditions")
:components
((:file "f77-mangling")))
commit e1fc53ef3b80bbe7de9d2cd8177f465e20d78fe5
Author: Akshay Srinivasan <aks...@gm...>
Date: Fri Jul 6 16:36:41 2012 +0530
Moved README back; autoconf complained about a missing README file.
diff --git a/README.org b/README
similarity index 99%
rename from README.org
rename to README
index 8bdcd0a..8863d66 100644
--- a/README.org
+++ b/README
@@ -1,3 +1,5 @@
+# -*- Mode: org -*-
+
MatLisp - a base for scientific computation in Lisp.
This is the development branch of Matlisp.
diff --git a/configure b/configure
index d6d18d8..43c778f 100755
--- a/configure
+++ b/configure
@@ -1,13 +1,11 @@
#! /bin/sh
# Guess values for system-dependent variables and create Makefiles.
-# Generated by GNU Autoconf 2.68 for matlisp 2.9.
+# Generated by GNU Autoconf 2.69 for matlisp 2.9.
#
# Report bugs to <mat...@li...>.
#
#
-# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001,
-# 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software
-# Foundation, Inc.
+# Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc.
#
#
# This configure script is free software; the Free Software Foundation
@@ -136,6 +134,31 @@ export LANGUAGE
# CDPATH.
(unset CDPATH) >/dev/null 2>&1 && unset CDPATH
+# Use a proper internal environment variable to ensure we don't fall
+ # into an infinite loop, continuously re-executing ourselves.
+ if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then
+ _as_can_reexec=no; export _as_can_reexec;
+ # We cannot yet assume a decent shell, so we have to provide a
+# neutralization value for shells without unset; and this also
+# works around shells that cannot unset nonexistent variables.
+# Preserve -v and -x to the replacement shell.
+BASH_ENV=/dev/null
+ENV=/dev/null
+(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV
+case $- in # ((((
+ *v*x* | *x*v* ) as_opts=-vx ;;
+ *v* ) as_opts=-v ;;
+ *x* ) as_opts=-x ;;
+ * ) as_opts= ;;
+esac
+exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"}
+# Admittedly, this is quite paranoid, since all the known shells bail
+# out after a failed `exec'.
+$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2
+as_fn_exit 255
+ fi
+ # We don't want this to propagate to other subprocesses.
+ { _as_can_reexec=; unset _as_can_reexec;}
if test "x$CONFIG_SHELL" = x; then
as_bourne_compatible="if test -n \"\${ZSH_VERSION+set}\" && (emulate sh) >/dev/null 2>&1; then :
emulate sh
@@ -169,7 +192,8 @@ if ( set x; as_fn_ret_success y && test x = \"\$1\" ); then :
else
exitcode=1; echo positional parameters were not saved.
fi
-test x\$exitcode = x0 || exit 1"
+test x\$exitcode = x0 || exit 1
+test -x / || exit 1"
as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO
as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO
eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" &&
@@ -222,21 +246,25 @@ IFS=$as_save_IFS
if test "x$CONFIG_SHELL" != x; then :
- # We cannot yet assume a decent shell, so we have to provide a
- # neutralization value for shells without unset; and this also
- # works around shells that cannot unset nonexistent variables.
- # Preserve -v and -x to the replacement shell.
- BASH_ENV=/dev/null
- ENV=/dev/null
- (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV
- export CONFIG_SHELL
- case $- in # ((((
- *v*x* | *x*v* ) as_opts=-vx ;;
- *v* ) as_opts=-v ;;
- *x* ) as_opts=-x ;;
- * ) as_opts= ;;
- esac
- exec "$CONFIG_SHELL" $as_opts "$as_myself" ${1+"$@"}
+ export CONFIG_SHELL
+ # We cannot yet assume a decent shell, so we have to provide a
+# neutralization value for shells without unset; and this also
+# works around shells that cannot unset nonexistent variables.
+# Preserve -v and -x to the replacement shell.
+BASH_ENV=/dev/null
+ENV=/dev/null
+(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV
+case $- in # ((((
+ *v*x* | *x*v* ) as_opts=-vx ;;
+ *v* ) as_opts=-v ;;
+ *x* ) as_opts=-x ;;
+ * ) as_opts= ;;
+esac
+exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"}
+# Admittedly, this is quite paranoid, since all the known shells bail
+# out after a failed `exec'.
+$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2
+exit 255
fi
if test x$as_have_required = xno; then :
@@ -339,6 +367,14 @@ $as_echo X"$as_dir" |
} # as_fn_mkdir_p
+
+# as_fn_executable_p FILE
+# -----------------------
+# Test if FILE is an executable regular file.
+as_fn_executable_p ()
+{
+ test -f "$1" && test -x "$1"
+} # as_fn_executable_p
# as_fn_append VAR VALUE
# ----------------------
# Append the text in VALUE to the end of the definition contained in VAR. Take
@@ -460,6 +496,10 @@ as_cr_alnum=$as_cr_Letters$as_cr_digits
chmod +x "$as_me.lineno" ||
{ $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; }
+ # If we had to re-execute with $CONFIG_SHELL, we're ensured to have
+ # already done that, so ensure we don't try to do so again and fall
+ # in an infinite loop. This has already happened in practice.
+ _as_can_reexec=no; export _as_can_reexec
# Don't try to exec as it changes $[0], causing all sort of problems
# (the dirname of $[0] is not the place where we might find the
# original and so on. Autoconf is especially sensitive to this).
@@ -494,16 +534,16 @@ if (echo >conf$$.file) 2>/dev/null; then
# ... but there are two gotchas:
# 1) On MSYS, both `ln -s file dir' and `ln file dir' fail.
# 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable.
- # In both cases, we have to default to `cp -p'.
+ # In both cases, we have to default to `cp -pR'.
ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe ||
- as_ln_s='cp -p'
+ as_ln_s='cp -pR'
elif ln conf$$.file conf$$ 2>/dev/null; then
as_ln_s=ln
else
- as_ln_s='cp -p'
+ as_ln_s='cp -pR'
fi
else
- as_ln_s='cp -p'
+ as_ln_s='cp -pR'
fi
rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file
rmdir conf$$.dir 2>/dev/null
@@ -515,28 +555,8 @@ else
as_mkdir_p=false
fi
-if test -x / >/dev/null 2>&1; then
- as_test_x='test -x'
-else
- if ls -dL / >/dev/null 2>&1; then
- as_ls_L_option=L
- else
- as_ls_L_option=
- fi
- as_test_x='
- eval sh -c '\''
- if test -d "$1"; then
- test -d "$1/.";
- else
- case $1 in #(
- -*)set "./$1";;
- esac;
- case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in #((
- ???[sx]*):;;*)false;;esac;fi
- '\'' sh
- '
-fi
-as_executable_p=$as_test_x
+as_test_x='test -x'
+as_executable_p=as_fn_executable_p
# Sed expression to map a string onto a valid CPP name.
as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'"
@@ -656,14 +676,6 @@ LD
FGREP
EGREP
SED
-host_os
-host_vendor
-host_cpu
-host
-build_os
-build_vendor
-build_cpu
-build
LIBTOOL
ECL_FALSE
ECL_TRUE
@@ -672,12 +684,21 @@ CCL_TRUE
CMUCL_FALSE
CMUCL_TRUE
FLIBS
+host_os
+host_vendor
+host_cpu
+host
+build_os
+build_vendor
+build_cpu
+build
ac_ct_F77
FFLAGS
F77
am__fastdepCC_FALSE
am__fastdepCC_TRUE
CCDEPMODE
+am__nodep
AMDEPBACKSLASH
AMDEP_FALSE
AMDEP_TRUE
@@ -698,7 +719,6 @@ AMTAR
am__leading_dot
SET_MAKE
AWK
-mkdir_p
MKDIR_P
INSTALL_STRIP_PROGRAM
STRIP
@@ -1238,8 +1258,6 @@ target=$target_alias
if test "x$host_alias" != x; then
if test "x$build_alias" = x; then
cross_compiling=maybe
- $as_echo "$as_me: WARNING: if you wanted to set the --build type, don't use --host.
- If a cross compiler is detected then cross compile mode will be used" >&2
elif test "x$build_alias" != "x$host_alias"; then
cross_compiling=yes
fi
@@ -1403,8 +1421,10 @@ Optional Features:
--disable-option-checking ignore unrecognized --enable/--with options
--disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no)
--enable-FEATURE[=ARG] include FEATURE [ARG=yes]
- --disable-dependency-tracking speeds up one-time build
- --enable-dependency-tracking do not reject slow dependency extractors
+ --enable-dependency-tracking
+ do not reject slow dependency extractors
+ --disable-dependency-tracking
+ speeds up one-time build
--enable-cmucl Enable cmucl
--enable-sbcl Enable sbcl
--enable-acl Enable acl
@@ -1507,9 +1527,9 @@ test -n "$ac_init_help" && exit $ac_status
if $ac_init_version; then
cat <<\_ACEOF
matlisp configure 2.9
-generated by GNU Autoconf 2.68
+generated by GNU Autoconf 2.69
-Copyright (C) 2010 Free Software Foundation, Inc.
+Copyright (C) 2012 Free Software Foundation, Inc.
This configure script is free software; the Free Software Foundation
gives unlimited permission to copy, distribute and modify it.
_ACEOF
@@ -1623,7 +1643,7 @@ $as_echo "$ac_try_echo"; } >&5
test ! -s conftest.err
} && test -s conftest$ac_exeext && {
test "$cross_compiling" = yes ||
- $as_test_x conftest$ac_exeext
+ test -x conftest$ac_exeext
}; then :
ac_retval=0
else
@@ -1854,7 +1874,7 @@ $as_echo "$ac_try_echo"; } >&5
test ! -s conftest.err
} && test -s conftest$ac_exeext && {
test "$cross_compiling" = yes ||
- $as_test_x conftest$ac_exeext
+ test -x conftest$ac_exeext
}; then :
ac_retval=0
else
@@ -1877,7 +1897,7 @@ This file contains any messages produced by compilers while
running configure, to aid debugging if configure makes a mistake.
It was created by matlisp $as_me 2.9, which was
-generated by GNU Autoconf 2.68. Invocation command line was
+generated by GNU Autoconf 2.69. Invocation command line was
$ $0 $@
@@ -2224,7 +2244,7 @@ ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $
ac_compiler_gnu=$ac_cv_c_compiler_gnu
-am__api_version='1.11'
+am__api_version='1.12'
ac_aux_dir=
for ac_dir in "$srcdir" "$srcdir/.." "$srcdir/../.."; do
@@ -2292,7 +2312,7 @@ case $as_dir/ in #((
# by default.
for ac_prog in ginstall scoinst install; do
for ac_exec_ext in '' $ac_executable_extensions; do
- if { test -f "$as_dir/$ac_prog$ac_exec_ext" && $as_test_x "$as_dir/$ac_prog$ac_exec_ext"; }; then
+ if as_fn_executable_p "$as_dir/$ac_prog$ac_exec_ext"; then
if test $ac_prog = install &&
grep dspmsg "$as_dir/$ac_prog$ac_exec_ext" >/dev/null 2>&1; then
# AIX install. It has an incompatible calling convention.
@@ -2350,9 +2370,6 @@ test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644'
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether build environment is sane" >&5
$as_echo_n "checking whether build environment is sane... " >&6; }
-# Just in case
-sleep 1
-echo timestamp > conftest.file
# Reject unsafe characters in $srcdir or the absolute working directory
# name. Accept space and tab only in the latter.
am_lf='
@@ -2363,32 +2380,40 @@ case `pwd` in
esac
case $srcdir in
*[\\\"\#\$\&\'\`$am_lf\ \ ]*)
- as_fn_error $? "unsafe srcdir value: \`$srcdir'" "$LINENO" 5;;
+ as_fn_error $? "unsafe srcdir value: '$srcdir'" "$LINENO" 5;;
esac
-# Do `set' in a subshell so we don't clobber the current shell's
+# Do 'set' in a subshell so we don't clobber the current shell's
# arguments. Must try -L first in case configure is actually a
# symlink; some systems play weird games with the mod time of symlinks
# (eg FreeBSD returns the mod time of the symlink's containing
# directory).
if (
- set X `ls -Lt "$srcdir/configure" conftest.file 2> /dev/null`
- if test "$*" = "X"; then
- # -L didn't work.
- set X `ls -t "$srcdir/configure" conftest.file`
- fi
- rm -f conftest.file
- if test "$*" != "X $srcdir/configure conftest.file" \
- && test "$*" != "X conftest.file $srcdir/configure"; then
-
- # If neither matched, then we have a broken ls. This can happen
- # if, for instance, CONFIG_SHELL is bash and it inherits a
- # broken ls alias from the environment. This has actually
- # happened. Such a system could not be considered "sane".
- as_fn_error $? "ls -t appears to fail. Make sure there is not a broken
-alias in your environment" "$LINENO" 5
- fi
-
+ am_has_slept=no
+ for am_try in 1 2; do
+ echo "timestamp, slept: $am_has_slept" > conftest.file
+ set X `ls -Lt "$srcdir/configure" conftest.file 2> /dev/null`
+ if test "$*" = "X"; then
+ # -L didn't work.
+ set X `ls -t "$srcdir/configure" conftest.file`
+ fi
+ if test "$*" != "X $srcdir/configure conftest.file" \
+ && test "$*" != "X conftest.file $srcdir/configure"; then
+
+ # If neither matched, then we have a broken ls. This can happen
+ # if, for instance, CONFIG_SHELL is bash and it inherits a
+ # broken ls alias from the environment. This has actually
+ # happened. Such a system could not be considered "sane".
+ as_fn_error $? "ls -t appears to fail. Make sure there is not a broken
+ alias in your environment" "$LINENO" 5
+ fi
+ if test "$2" = conftest.file || test $am_try -eq 2; then
+ break
+ fi
+ # Just in case.
+ sleep 1
+ am_has_slept=yes
+ done
test "$2" = conftest.file
)
then
@@ -2400,6 +2425,16 @@ Check your system clock" "$LINENO" 5
fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5
$as_echo "yes" >&6; }
+# If we didn't sleep, we still need to ensure time stamps of config.status and
+# generated files are strictly newer.
+am_sleep_pid=
+if grep 'slept: no' conftest.file >/dev/null 2>&1; then
+ ( sleep 1 ) &
+ am_sleep_pid=$!
+fi
+
+rm -f conftest.file
+
test "$program_prefix" != NONE &&
program_transform_name="s&^&$program_prefix&;$program_transform_name"
# Use a double $ so make ignores it.
@@ -2426,8 +2461,8 @@ if eval "$MISSING --run true"; then
am_missing_run="$MISSING --run "
else
am_missing_run=
- { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: \`missing' script is too old or missing" >&5
-$as_echo "$as_me: WARNING: \`missing' script is too old or missing" >&2;}
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: 'missing' script is too old or missing" >&5
+$as_echo "$as_me: WARNING: 'missing' script is too old or missing" >&2;}
fi
if test x"${install_sh}" != xset; then
@@ -2439,10 +2474,10 @@ if test x"${install_sh}" != xset; then
esac
fi
-# Installed binaries are usually stripped using `strip' when the user
-# run `make install-strip'. However `strip' might not be the right
+# Installed binaries are usually stripped using 'strip' when the user
+# run "make install-strip". However 'strip' might not be the right
# tool to use in cross-compilation environments, therefore Automake
-# will honor the `STRIP' environment variable to overrule this program.
+# will honor the 'STRIP' environment variable to overrule this program.
if test "$cross_compiling" != no; then
if test -n "$ac_tool_prefix"; then
# Extract the first word of "${ac_tool_prefix}strip", so it can be a program name with args.
@@ -2461,7 +2496,7 @@ do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
- if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
ac_cv_prog_STRIP="${ac_tool_prefix}strip"
$as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
break 2
@@ -2501,7 +2536,7 @@ do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
- if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
ac_cv_prog_ac_ct_STRIP="strip"
$as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
break 2
@@ -2552,7 +2587,7 @@ do
test -z "$as_dir" && as_dir=.
for ac_prog in mkdir gmkdir; do
for ac_exec_ext in '' $ac_executable_extensions; do
- { test -f "$as_dir/$ac_prog$ac_exec_ext" && $as_test_x "$as_dir/$ac_prog$ac_exec_ext"; } || continue
+ as_fn_executable_p "$as_dir/$ac_prog$ac_exec_ext" || continue
case `"$as_dir/$ac_prog$ac_exec_ext" --version 2>&1` in #(
'mkdir (GNU coreutils) '* | \
'mkdir (coreutils) '* | \
@@ -2581,12 +2616,6 @@ fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $MKDIR_P" >&5
$as_echo "$MKDIR_P" >&6; }
-mkdir_p="$MKDIR_P"
-case $mkdir_p in
- [\\/$]* | ?:[\\/]*) ;;
- */*) mkdir_p="\$(top_builddir)/$mkdir_p" ;;
-esac
-
for ac_prog in gawk mawk nawk awk
do
# Extract the first word of "$ac_prog", so it can be a program name with args.
@@ -2605,7 +2634,7 @@ do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
- if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
ac_cv_prog_AWK="$ac_prog"
$as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
break 2
@@ -2721,11 +2750,11 @@ MAKEINFO=${MAKEINFO-"${am_missing_run}makeinfo"}
# We need awk for the "check" target. The system "awk" is bad on
# some platforms.
-# Always define AMTAR for backward compatibility.
+# Always define AMTAR for backward compatibility. Yes, it's still used
+# in the wild :-( We should find a proper way to deprecate it ...
+AMTAR='$${TAR-tar}'
-AMTAR=${AMTAR-"${am_missing_run}tar"}
-
-am__tar='${AMTAR} chof - "$$tardir"'; am__untar='${AMTAR} xf -'
+am__tar='$${TAR-tar} chof - "$$tardir"' am__untar='$${TAR-tar} xf -'
@@ -2749,7 +2778,7 @@ do
for ac_prog in grep ggrep; do
for ac_exec_ext in '' $ac_executable_extensions; do
ac_path_GREP="$as_dir/$ac_prog$ac_exec_ext"
- { test -f "$ac_path_GREP" && $as_test_x "$ac_path_GREP"; } || continue
+ as_fn_executable_p "$ac_path_GREP" || continue
# Check for GNU ac_path_GREP and select it if it is found.
# Check for GNU $ac_path_GREP
case `"$ac_path_GREP" --version 2>&1` in
@@ -2819,7 +2848,7 @@ do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
- if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
ac_cv_prog_CC="${ac_tool_prefix}gcc"
$as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
break 2
@@ -2859,7 +2888,7 @@ do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
- if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
ac_cv_prog_ac_ct_CC="gcc"
$as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
break 2
@@ -2912,7 +2941,7 @@ do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
- if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
ac_cv_prog_CC="${ac_tool_prefix}cc"
$as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
break 2
@@ -2953,7 +2982,7 @@ do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
- if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
if test "$as_dir/$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then
ac_prog_rejected=yes
continue
@@ -3011,7 +3040,7 @@ do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
- if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
ac_cv_prog_CC="$ac_tool_prefix$ac_prog"
$as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
break 2
@@ -3055,7 +3084,7 @@ do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
- if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
ac_cv_prog_ac_ct_CC="$ac_prog"
$as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
break 2
@@ -3501,8 +3530,7 @@ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <stdarg.h>
#include <stdio.h>
-#include <sys/types.h>
-#include <sys/stat.h>
+struct stat;
/* Most of the following tests are stolen from RCS 5.7's src/conf.sh. */
struct buf { int x; };
FILE * (*rcsopen) (struct buf *, struct stat *, int);
@@ -3605,7 +3633,7 @@ am__quote=
_am_result=none
# First try GNU make style include.
echo "include confinc" > confmf
-# Ignore all kinds of additional output from `make'.
+# Ignore all kinds of additional output from 'make'.
case `$am_make -s -f confmf 2> /dev/null` in #(
*the\ am__doit\ target*)
am__include=include
@@ -3638,6 +3666,7 @@ fi
if test "x$enable_dependency_tracking" != xno; then
am_depcomp="$ac_aux_dir/depcomp"
AMDEPBACKSLASH='\'
+ am__nodep='_no'
fi
if test "x$enable_dependency_tracking" != xno; then
AMDEP_TRUE=
@@ -3660,8 +3689,9 @@ else
# We make a subdir and do the tests there. Otherwise we can end up
# making bogus files that we don't know about and never remove. For
# instance it was reported that on HP-UX the gcc test will end up
- # making a dummy file named `D' -- because `-MD' means `put the output
- # in D'.
+ # making a dummy file named 'D' -- because '-MD' means "put the output
+ # in D".
+ rm -rf conftest.dir
mkdir conftest.dir
# Copy depcomp to subdir because otherwise we won't find it if we're
# using a relative directory.
@@ -3695,16 +3725,16 @@ else
: > sub/conftest.c
for i in 1 2 3 4 5 6; do
echo '#include "conftst'$i'.h"' >> sub/conftest.c
- # Using `: > sub/conftst$i.h' creates only sub/conftst1.h with
- # Solaris 8's {/usr,}/bin/sh.
- touch sub/conftst$i.h
+ # Using ": > sub/conftst$i.h" creates only sub/conftst1.h with
+ # Solaris 10 /bin/sh.
+ echo '/* dummy */' > sub/conftst$i.h
done
echo "${am__include} ${am__quote}sub/conftest.Po${am__quote}" > confmf
- # We check with `-c' and `-o' for the sake of the "dashmstdout"
+ # We check with '-c' and '-o' for the sake of the "dashmstdout"
# mode. It turns out that the SunPro C++ compiler does not properly
- # handle `-M -o', and we need to detect this. Also, some Intel
- # versions had trouble with output in subdirs
+ # handle '-M -o', and we need to detect this. Also, some Intel
+ # versions had trouble with output in subdirs.
am__obj=sub/conftest.${OBJEXT-o}
am__minus_obj="-o $am__obj"
case $depmode in
@@ -3713,16 +3743,16 @@ else
test "$am__universal" = false || continue
;;
nosideeffect)
- # after this tag, mechanisms are not by side-effect, so they'll
- # only be used when explicitly requested
+ # After this tag, mechanisms are not by side-effect, so they'll
+ # only be used when explicitly requested.
if test "x$enable_dependency_tracking" = xyes; then
continue
else
break
fi
;;
- msvisualcpp | msvcmsys)
- # This compiler won't grok `-c -o', but also, the minuso test has
+ msvc7 | msvc7msys | msvisualcpp | msvcmsys)
+ # This compiler won't grok '-c -o', but also, the minuso test has
# not run yet. These depmodes are late enough in the game, and
# so weak that their functioning should not be impacted.
am__obj=conftest.${OBJEXT-o}
@@ -3788,7 +3818,7 @@ ac_compile='$F77 -c $FFLAGS conftest.$ac_ext >&5'
ac_link='$F77 -o conftest$ac_exeext $FFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
ac_compiler_gnu=$ac_cv_f77_compiler_gnu
if test -n "$ac_tool_prefix"; then
- for ac_prog in g77 xlf f77 frt pgf77 cf77 fort77 fl32 af77 xlf90 f90 pgf90 pghpf epcf90 gfortran g95 xlf95 f95 fort ifort ifc efc pgfortran pgf95 lf95 ftn
+ for ac_prog in g77 xlf f77 frt pgf77 cf77 fort77 fl32 af77 xlf90 f90 pgf90 pghpf epcf90 gfortran g95 xlf95 f95 fort ifort ifc efc pgfortran pgf95 lf95 ftn nagfor
do
# Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args.
set dummy $ac_tool_prefix$ac_prog; ac_word=$2
@@ -3806,7 +3836,7 @@ do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
- if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
ac_cv_prog_F77="$ac_tool_prefix$ac_prog"
$as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
break 2
@@ -3832,7 +3862,7 @@ fi
fi
if test -z "$F77"; then
ac_ct_F77=$F77
- for ac_prog in g77 xlf f77 frt pgf77 cf77 fort77 fl32 af77 xlf90 f90 pgf90 pghpf epcf90 gfortran g95 xlf95 f95 fort ifort ifc efc pgfortran pgf95 lf95 ftn
+ for ac_prog in g77 xlf f77 frt pgf77 cf77 fort77 fl32 af77 xlf90 f90 pgf90 pghpf epcf90 gfortran g95 xlf95 f95 fort ifort ifc efc pgfortran pgf95 lf95 ftn nagfor
do
# Extract the first word of "$ac_prog", so it can be a program name with args.
set dummy $ac_prog; ac_word=$2
@@ -3850,7 +3880,7 @@ do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
- if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
ac_cv_prog_ac_ct_F77="$ac_prog"
$as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
break 2
@@ -4053,6 +4083,77 @@ ac_link='$F77 -o conftest$ac_exeext $FFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
ac_compiler_gnu=$ac_cv_f77_compiler_gnu
+# Make sure we can run config.sub.
+$SHELL "$ac_aux_dir/config.sub" sun4 >/dev/null 2>&1 ||
+ as_fn_error $? "cannot run $SHELL $ac_aux_dir/config.sub" "$LINENO" 5
+
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking build system type" >&5
+$as_echo_n "checking build system type... " >&6; }
+if ${ac_cv_build+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ ac_build_alias=$build_alias
+test "x$ac_build_alias" = x &&
+ ac_build_alias=`$SHELL "$ac_aux_dir/config.guess"`
+test "x$ac_build_alias" = x &&
+ as_fn_error $? "cannot guess build type; you must specify one" "$LINENO" 5
+ac_cv_build=`$SHELL "$ac_aux_dir/config.sub" $ac_build_alias` ||
+ as_fn_error $? "$SHELL $ac_aux_dir/config.sub $ac_build_alias failed" "$LINENO" 5
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_build" >&5
+$as_echo "$ac_cv_build" >&6; }
+case $ac_cv_build in
+*-*-*) ;;
+*) as_fn_error $? "invalid value of canonical build" "$LINENO" 5;;
+esac
+build=$ac_cv_build
+ac_save_IFS=$IFS; IFS='-'
+set x $ac_cv_build
+shift
+build_cpu=$1
+build_vendor=$2
+shift; shift
+# Remember, the first character of IFS is used to create $*,
+# except with old shells:
+build_os=$*
+IFS=$ac_save_IFS
+case $build_os in *\ *) build_os=`echo "$build_os" | sed 's/ /-/g'`;; esac
+
+
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking host system type" >&5
+$as_echo_n "checking host system type... " >&6; }
+if ${ac_cv_host+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if test "x$host_alias" = x; then
+ ac_cv_host=$ac_cv_build
+else
+ ac_cv_host=`$SHELL "$ac_aux_dir/config.sub" $host_alias` ||
+ as_fn_error $? "$SHELL $ac_aux_dir/config.sub $host_alias failed" "$LINENO" 5
+fi
+
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_host" >&5
+$as_echo "$ac_cv_host" >&6; }
+case $ac_cv_host in
+*-*-*) ;;
+*) as_fn_error $? "invalid value of canonical host" "$LINENO" 5;;
+esac
+host=$ac_cv_host
+ac_save_IFS=$IFS; IFS='-'
+set x $ac_cv_host
+shift
+host_cpu=$1
+host_vendor=$2
+shift; shift
+# Remember, the first character of IFS is used to create $*,
+# except with old shells:
+host_os=$*
+IFS=$ac_save_IFS
+case $host_os in *\ *) host_os=`echo "$host_os" | sed 's/ /-/g'`;; esac
+
+
ac_ext=f
ac_compile='$F77 -c $FFLAGS conftest.$ac_ext >&5'
@@ -4108,9 +4209,16 @@ ac_f77_v_output="`echo $ac_f77_v_output |
# that detects unbalanced quotes in FLIBS should be implemented
# and (ugh) tested at some point.
case $ac_f77_v_output in
- # If we are using xlf then replace all the commas with spaces.
+ # With xlf replace commas with spaces,
+ # and remove "-link" and closing parenthesis.
*xlfentry*)
- ac_f77_v_output=`echo $ac_f77_v_output | sed 's/,/ /g'` ;;
+ ac_f77_v_output=`echo $ac_f77_v_output |
+ sed '
+ s/,/ /g
+ s/ -link / /g
+ s/) *$//
+ '
+ ` ;;
# With Intel ifc, ignore the quoted -mGLOB_options_string stuff (quoted
# $LIBS confuse us, and the libraries appear later in the output anyway).
@@ -4126,6 +4234,16 @@ case $ac_f77_v_output in
s/-ignore *'[^']*'/ /g; s/-ignore *\"[^\"]*\"/ /g
s/-def *'[^']*'/ /g; s/-def *\"[^\"]*\"/ /g"` ;;
+ # If we are using fort77 (the f2c wrapper) then filter output and delete quotes.
+ *fort77*f2c*gcc*)
+ ac_f77_v_output=`echo "$ac_f77_v_output" | sed -n '
+ /:[ ]\+Running[ ]\{1,\}"gcc"/{
+ /"-c"/d
+ /[.]c"*/d
+ s/^.*"gcc"/"gcc"/
+ s/"//gp
+ }'` ;;
+
# If we are using Cray Fortran then delete quotes.
*cft90*)
ac_f77_v_output=`echo $ac_f77_v_output | sed 's/"//g'` ;;
@@ -4199,9 +4317,16 @@ ac_f77_v_output="`echo $ac_f77_v_output |
# that detects unbalanced quotes in FLIBS should be implemented
# and (ugh) tested at some point.
case $ac_f77_v_output in
- # If we are using xlf then replace all the commas with spaces.
+ # With xlf replace commas with spaces,
+ # and remove "-link" and closing parenthesis.
*xlfentry*)
- ac_f77_v_output=`echo $ac_f77_v_output | sed 's/,/ /g'` ;;
+ ac_f77_v_output=`echo $ac_f77_v_output |
+ sed '
+ s/,/ /g
+ s/ -link / /g
+ s/) *$//
+ '
+ ` ;;
# With Intel ifc, ignore the quoted -mGLOB_options_string stuff (quoted
# $LIBS confuse us, and the libraries appear later in the output anyway).
@@ -4217,6 +4342,16 @@ case $ac_f77_v_output in
s/-ignore *'[^']*'/ /g; s/-ignore *\"[^\"]*\"/ /g
s/-def *'[^']*'/ /g; s/-def *\"[^\"]*\"/ /g"` ;;
+ # If we are using fort77 (the f2c wrapper) then filter output and delete quotes.
+ *fort77*f2c*gcc*)
+ ac_f77_v_output=`echo "$ac_f77_v_output" | sed -n '
+ /:[ ]\+Running[ ]\{1,\}"gcc"/{
+ /"-c"/d
+ /[.]c"*/d
+ s/^.*"gcc"/"gcc"/
+ s/"//gp
+ }'` ;;
+
# If we are using Cray Fortran then delete quotes.
*cft90*)
ac_f77_v_output=`echo $ac_f77_v_output | sed 's/"//g'` ;;
@@ -4275,7 +4410,11 @@ fi
|-LANG:=* | -LIST:* | -LNO:* | -link)
;;
-lkernel32)
- test x"$CYGWIN" != xyes && ac_cv_f77_libs="$ac_cv_f77_libs $ac_arg"
+ case $host_os in
+ *cygwin*) ;;
+ *) ac_cv_f77_libs="$ac_cv_f77_libs $ac_arg"
+ ;;
+ esac
;;
-[LRuYz])
# These flags, when seen by themselves, take an argument.
@@ -4865,77 +5004,6 @@ macro_revision='1.3337'
ltmain="$ac_aux_dir/ltmain.sh"
-# Make sure we can run config.sub.
-$SHELL "$ac_aux_dir/config.sub" sun4 >/dev/null 2>&1 ||
- as_fn_error $? "cannot run $SHELL $ac_aux_dir/config.sub" "$LINENO" 5
-
-{ $as_echo "$as_me:${as_lineno-$LINENO}: checking build system type" >&5
-$as_echo_n "checking build system type... " >&6; }
-if ${ac_cv_build+:} false; then :
- $as_echo_n "(cached) " >&6
-else
- ac_build_alias=$build_alias
-test "x$ac_build_alias" = x &&
- ac_build_alias=`$SHELL "$ac_aux_dir/config.guess"`
-test "x$ac_build_alias" = x &&
- as_fn_error $? "cannot guess build type; you must specify one" "$LINENO" 5
-ac_cv_build=`$SHELL "$ac_aux_dir/config.sub" $ac_build_alias` ||
- as_fn_error $? "$SHELL $ac_aux_dir/config.sub $ac_build_alias failed" "$LINENO" 5
-
-fi
-{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_build" >&5
-$as_echo "$ac_cv_build" >&6; }
-case $ac_cv_build in
-*-*-*) ;;
-*) as_fn_error $? "invalid value of canonical build" "$LINENO" 5;;
-esac
-build=$ac_cv_build
-ac_save_IFS=$IFS; IFS='-'
-set x $ac_cv_build
-shift
-build_cpu=$1
-build_vendor=$2
-shift; shift
-# Remember, the first character of IFS is used to create $*,
-# except with old shells:
-build_os=$*
-IFS=$ac_save_IFS
-case $build_os in *\ *) build_os=`echo "$build_os" | sed 's/ /-/g'`;; esac
-
-
-{ $as_echo "$as_me:${as_lineno-$LINENO}: checking host system type" >&5
-$as_echo_n "checking host system type... " >&6; }
-if ${ac_cv_host+:} false; then :
- $as_echo_n "(cached) " >&6
-else
- if test "x$host_alias" = x; then
- ac_cv_host=$ac_cv_build
-else
- ac_cv_host=`$SHELL "$ac_aux_dir/config.sub" $host_alias` ||
- as_fn_error $? "$SHELL $ac_aux_dir/config.sub $host_alias failed" "$LINENO" 5
-fi
-
-fi
-{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_host" >&5
-$as_echo "$ac_cv_host" >&6; }
-case $ac_cv_host in
-*-*-*) ;;
-*) as_fn_error $? "invalid value of canonical host" "$LINENO" 5;;
-esac
-host=$ac_cv_host
-ac_save_IFS=$IFS; IFS='-'
-set x $ac_cv_host
-shift
-host_cpu=$1
-host_vendor=$2
-shift; shift
-# Remember, the first character of IFS is used to create $*,
-# except with old shells:
-host_os=$*
-IFS=$ac_save_IFS
-case $host_os in *\ *) host_os=`echo "$host_os" | sed 's/ /-/g'`;; esac
-
-
# Backslashify metacharacters that are still active within
# double-quoted strings.
sed_quote_subst='s/\(["`$\\]\)/\\\1/g'
@@ -5027,7 +5095,7 @@ do
for ac_prog in sed gsed; do
for ac_exec_ext in '' $ac_executable_extensions; do
ac_path_SED="$as_dir/$ac_prog$ac_exec_ext"
- { test -f "$ac_path_SED" && $as_test_x "$ac_path_SED"; } || continue
+ as_fn_executable_p "$ac_path_SED" || continue
# Check for GNU ac_path_SED and select it if it is found.
# Check for GNU $ac_path_SED
case `"$ac_path_SED" --version 2>&1` in
@@ -5106,7 +5174,7 @@ do
for ac_prog in egrep; do
for ac_exec_ext in '' $ac_executable_extensions; do
ac_path_EGREP="$as_dir/$ac_prog$ac_exec_ext"
- { test -f "$ac_path_EGREP" && $as_test_x "$ac_path_EGREP"; } || continue
+ as_fn_executable_p "$ac_path_EGREP" || continue
# Check for GNU ac_path_EGREP and select it if it is found.
# Check for GNU $ac_path_EGREP
case `"$ac_path_EGREP" --version 2>&1` in
@@ -5173,7 +5241,7 @@ do
for ac_prog in fgrep; do
for ac_exec_ext in '' $ac_executable_extensions; do
ac_path_FGREP="$as_dir/$ac_prog$ac_exec_ext"
- { test -f "$ac_path_FGREP" && $as_test_x "$ac_path_FGREP"; } || continue
+ as_fn_executable_p "$ac_path_FGREP" || continue
# Check for GNU ac_path_FGREP and select it if it is found.
# Check for GNU $ac_path_FGREP
case `"$ac_path_FGREP" --version 2>&1` in
@@ -5429,7 +5497,7 @@ do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
- if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
ac_cv_prog_DUMPBIN="$ac_tool_prefix$ac_prog"
$as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
break 2
@@ -5473,7 +5541,7 @@ do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
- if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
ac_cv_prog_ac_ct_DUMPBIN="$ac_prog"
$as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
break 2
@@ -5897,7 +5965,7 @@ do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
- if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
ac_cv_prog_OBJDUMP="${ac_tool_prefix}objdump"
$as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
break 2
@@ -5937,7 +6005,7 @@ do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
- if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
ac_cv_prog_ac_ct_OBJDUMP="objdump"
$as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
break 2
@@ -6243,7 +6311,7 @@ do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
- if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
ac_cv_prog_DLLTOOL="${ac_tool_prefix}dlltool"
$as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
break 2
@@ -6283,7 +6351,7 @@ do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
- if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
ac_cv_prog_ac_ct_DLLTOOL="dlltool"
$as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
break 2
@@ -6386,7 +6454,7 @@ do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
- if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
ac_cv_prog_AR="$ac_tool_prefix$ac_prog"
$as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
break 2
@@ -6430,7 +6498,7 @@ do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
- if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
ac_cv_prog_ac_ct_AR="$ac_prog"
$as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
break 2
@@ -6549,7 +6617,7 @@ do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
- if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
ac_cv_prog_STRIP="${ac_tool_prefix}strip"
$as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
break 2
@@ -6589,7 +6657,7 @@ do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
- if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
ac_cv_prog_ac_ct_STRIP="strip"
$as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
break 2
@@ -6648,7 +6716,7 @@ do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
- if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
ac_cv_prog_RANLIB="${ac_tool_prefix}ranlib"
$as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
break 2
@@ -6688,7 +6756,7 @@ do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
- if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
ac_cv_prog_ac_ct_RANLIB="ranlib"
$as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
break 2
@@ -7345,7 +7413,7 @@ do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
- if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
ac_cv_prog_MANIFEST_TOOL="${ac_tool_prefix}mt"
$as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
break 2
@@ -7385,7 +7453,7 @@ do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
- if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
ac_cv_prog_ac_ct_MANIFEST_TOOL="mt"
$as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
break 2
@@ -7465,7 +7533,7 @@ do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
- if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
ac_cv_prog_DSYMUTIL="${ac_tool_prefix}dsymutil"
$as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
break 2
@@ -7505,7 +7573,7 @@ do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
- if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
ac_cv_prog_ac_ct_DSYMUTIL="dsymutil"
$as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
break 2
@@ -7557,7 +7625,7 @@ do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
- if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
ac_cv_prog_NMEDIT="${ac_tool_prefix}nmedit"
$as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
break 2
@@ -7597,7 +7665,7 @@ do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
- if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
ac_cv_prog_ac_ct_NMEDIT="nmedit"
$as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
break 2
@@ -7649,7 +7717,7 @@ do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
- if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
ac_cv_prog_LIPO="${ac_tool_prefix}lipo"
$as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
break 2
@@ -7689,7 +7757,7 @@ do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
- if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
ac_cv_prog_ac_ct_LIPO="lipo"
$as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
break 2
@@ -7741,7 +7809,7 @@ do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
- if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
ac_cv_prog_OTOOL="${ac_tool_prefix}otool"
$as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
break 2
@@ -7781,7 +7849,7 @@ do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
- if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
ac_cv_prog_ac_ct_OTOOL="otool"
$as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
break 2
@@ -7833,7 +7901,7 @@ do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
- if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
ac_cv_prog_OTOOL64="${ac_tool_prefix}otool64"
$as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
break 2
@@ -7873,7 +7941,7 @@ do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
- if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
ac_cv_prog_ac_ct_OTOOL64="otool64"
$as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
break 2
@@ -15340,7 +15408,7 @@ case $host in
*) share_ext=so ;;
esac
-ac_config_files="$ac_config_files matlisp.mk Makefile start.lisp config.lisp lib/lazy-loader.lisp src/f77-mangling.lisp LAPACK/SRC/Makefile LAPACK/BLAS/SRC/Makefile dfftpack/Makefile lib-src/toms715/Makefile lib-src/compat/Makefile lib-src/odepack/Makefile lib-src/colnew/Makefile"
+ac_config_files="$ac_config_files matlisp.mk Makefile start.lisp config.lisp lib/lazy-loader.lisp src/ffi/f77-mangling.lisp LAPACK/SRC/Makefile LAPACK/BLAS/SRC/Makefile dfftpack/Makefile lib-src/toms715/Makefile lib-src/compat/Makefile lib-src/odepack/Makefile lib-src/colnew/Makefile"
echo FLIBS = $FLIBS
@@ -15490,6 +15558,14 @@ LIBOBJS=$ac_libobjs
LTLIBOBJS=$ac_ltlibobjs
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking that generated files are newer than configure" >&5
+$as_echo_n "checking that generated files are newer than configure... " >&6; }
+ if test -n "$am_sleep_pid"; then
+ # Hide warnings about reused PIDs.
+ wait $am_sleep_pid 2>/dev/null
+ fi
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: done" >&5
+$as_echo "done" >&6; }
if test -n "$EXEEXT"; then
am__EXEEXT_TRUE=
am__EXEEXT_FALSE='#'
@@ -15824,16 +15900,16 @@ if (echo >conf$$.file) 2>/dev/null; then
# ... but there are two gotchas:
# 1) On MSYS, both `ln -s file dir' and `ln file dir' fail.
# 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable.
- # In both cases, we have to default to `cp -p'.
+ # In both cases, we have to default to `cp -pR'.
ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe ||
- as_ln_s='cp -p'
+ as_ln_s='cp -pR'
elif ln conf$$.file conf$$ 2>/dev/null; then
as_ln_s=ln
else
- as_ln_s='cp -p'
+ as_ln_s='cp -pR'
fi
else
- as_ln_s='cp -p'
+ as_ln_s='cp -pR'
fi
rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file
rmdir conf$$.dir 2>/dev/null
@@ -15893,28 +15969,16 @@ else
as_mkdir_p=false
fi
-if test -x / >/dev/null 2>&1; then
- as_test_x='test -x'
-else
- if ls -dL / >/dev/null 2>&1; then
- as_ls_L_option=L
- else
- as_ls_L_option=
- fi
- as_test_x='
- eval sh -c '\''
- if test -d "$1"; then
- test -d "$1/.";
- else
- case $1 in #(
- -*)set "./$1";;
- esac;
- case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in #((
- ???[sx]*):;;*)false;;esac;fi
- '\'' sh
- '
-fi
-as_executable_p=$as_test_x
+
+# as_fn_executable_p FILE
+# -----------------------
+# Test if FILE is an executable regular file.
+as_fn_executable_p ()
+{
+ test -f "$1" && test -x "$1"
+} # as_fn_executable_p
+as_test_x='test -x'
+as_executable_p=as_fn_executable_p
# Sed expression to map a string onto a valid CPP name.
as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'"
@@ -15936,7 +16000,7 @@ cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
# values after options handling.
ac_log="
This file was extended by matlisp $as_me 2.9, which was
-generated by GNU Autoconf 2.68. Invocation command line was
+generated by GNU Autoconf 2.69. Invocation command line was
CONFIG_FILES = $CONFIG_FILES
CONFIG_HEADERS = $CONFIG_HEADERS
@@ -15994,10 +16058,10 @@ cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`"
ac_cs_version="\\
matlisp config.status 2.9
-configured by $0, generated by GNU Autoconf 2.68,
+configured by $0, generated by GNU Autoconf 2.69,
with options \\"\$ac_cs_config\\"
-Copyright (C) 2010 Free Software Foundation, Inc.
+Copyright (C) 2012 Free Software Foundation, Inc.
This config.status script is free software; the Free Software Foundation
gives unlimited permission to copy, distribute and modify it."
@@ -16077,7 +16141,7 @@ fi
_ACEOF
cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
if \$ac_cs_recheck; then
- set X '$SHELL' '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion
+ set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion
shift
\$as_echo "running CONFIG_SHELL=$SHELL \$*" >&6
CONFIG_SHELL='$SHELL'
@@ -16469,7 +16533,7 @@ do
"start.lisp") CONFIG_FILES="$CONFIG_FILES start.lisp" ;;
"config.lisp") CONFIG_FILES="$CONFIG_FILES config.lisp" ;;
"lib/lazy-loader.lisp") CONFIG_FILES="$CONFIG_FILES lib/lazy-loader.lisp" ;;
- "src/f77-mangling.lisp") CONFIG_FILES="$CONFIG_FILES src/f77-mangling.lisp" ;;
+ "src/ffi/f77-mangling.lisp") CONFIG_FILES="$CONFIG_FILES src/ffi/f77-mangling.lisp" ;;
"LAPACK/SRC/Makefile") CONFIG_FILES="$CONFIG_FILES LAPACK/SRC/Makefile" ;;
"LAPACK/BLAS/SRC/Makefile") CONFIG_FILES="$CONFIG_FILES LAPACK/BLAS/SRC/Makefile" ;;
"dfftpack/Makefile") CONFIG_FILES="$CONFIG_FILES dfftpack/Makefile" ;;
@@ -16920,7 +16984,7 @@ $as_echo "$as_me: executing $ac_file commands" >&6;}
# Strip MF so we end up with the name of the file.
mf=`echo "$mf" | sed -e 's/:.*$//'`
# Check whether this is an Automake generated Makefile or not.
- # We used to match only the files named `Makefile.in', but
+ # We used to match only the files named 'Makefile.in', but
# some people rename them; so instead we look at the file content.
# Grep'ing the first line is not enough: some people post-process
# each Makefile.in and add a new line on top of each file to say so.
@@ -16954,21 +17018,19 @@ $as_echo X"$mf" |
continue
fi
# Extract the definition of DEPDIR, am__include, and am__quote
- # from the Makefile without running `make'.
+ # from the Makefile without running 'make'.
DEPDIR=`sed -n 's/^DEPDIR = //p' < "$mf"`
test -z "$DEPDIR" && continue
am__include=`sed -n 's/^am__include = //p' < "$mf"`
test -z "am__include" && continue
am__quote=`sed -n 's/^am__quote = //p' < "$mf"`
- # When using ansi2knr, U may be empty or an underscore; expand it
- U=`sed -n 's/^U = //p' < "$mf"`
# Find all dependency output files, they are included files with
# $(DEPDIR) in their names. We invoke sed twice because it is the
# simplest approach to changing $(DEPDIR) to its actual value in the
# expansion.
for file in `sed -n "
s/^$am__include $am__quote\(.*(DEPDIR).*\)$am__quote"'$/\1/p' <"$mf" | \
- sed -e 's/\$(DEPDIR)/'"$DEPDIR"'/g' -e 's/\$U/'"$U"'/g'`; do
+ sed -e 's/\$(DEPDIR)/'"$DEPDIR"'/g'`; do
# Make sure the directory exists.
test -f "$dirpart/$file" && continue
fdir=`$as_dirname -- "$file" ||
diff --git a/configure.ac b/configure.ac
index 89f0f1b..f9d2884 100644
--- a/configure.ac
+++ b/configure.ac
@@ -421,7 +421,7 @@ AC_CONFIG_FILES([
start.lisp
config.lisp
lib/lazy-loader.lisp
- src/f77-mangling.lisp
+ src/ffi/f77-mangling.lisp
LAPACK/SRC/Makefile
LAPACK/BLAS/SRC/Makefile
dfftpack/Makefile
-----------------------------------------------------------------------
Summary of changes:
README.org => README | 2 +
configure | 608 +++++++++++++++++++++++++++----------------------
configure.ac | 2 +-
matlisp.asd | 2 +-
4 files changed, 339 insertions(+), 275 deletions(-)
rename README.org => README (99%)
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2012-07-06 09:49:42
|
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 2ea68617e269a162c2e722fe7b3314bec1c49a60 (commit)
via 391e3cfc964a8038324bcbe654d45c763082986d (commit)
via e3a4c5986e5e511c7ffbb1db7a96555bb24f31b7 (commit)
via d5182e428a4c3a261f307a55f3f4bee5b23791d6 (commit)
from 8bd064bd60e799c45ed248e17ea9dac42960a631 (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 2ea68617e269a162c2e722fe7b3314bec1c49a60
Author: Akshay Srinivasan <aks...@gm...>
Date: Fri Jul 6 15:14:25 2012 +0530
Organised files better in directories.
diff --git a/matlisp.asd b/matlisp.asd
index 8ab5196..31cbe92 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -41,17 +41,13 @@
(asdf:defsystem matlisp-conditions
:depends-on ("matlisp-packages")
- :pathname #.(translate-logical-pathname "matlisp:srcdir;")
- :components ((:module "conditions"
- :pathname "src/"
- :components ((:file "conditions")))))
+ :pathname #.(translate-logical-pathname "matlisp:srcdir;src;")
+ :components ((:file "conditions")))
(asdf:defsystem matlisp-utilities
- :pathname #.(translate-logical-pathname "matlisp:srcdir;")
+ :pathname #.(translate-logical-pathname "matlisp:srcdir;src;")
:depends-on ("matlisp-packages" "matlisp-conditions")
- :components ((:module "utilities"
- :pathname "src/"
- :components ((:file "utilities")))))
+ :components ((:file "utilities")))
(asdf:defsystem lazy-loader
:pathname #.(translate-logical-pathname "matlisp:lib;")
@@ -71,29 +67,27 @@
((:file "f77-mangling")))
(asdf:defsystem matlisp
- :pathname #.(translate-logical-pathname "matlisp:srcdir;")
+ :pathname #.(translate-logical-pathname "matlisp:srcdir;src;")
:depends-on (#:cffi "lazy-loader"
"matlisp-packages" "matlisp-conditions"
"matlisp-utilities" "fortran-names")
:components
((:module "foreign-interface"
- :pathname "src/"
+ :pathname "ffi"
:components ((:file "ffi-cffi")
- (:file "ffi-cffi-interpreter-specific")
+ (:file "ffi-cffi-implementation-specific")
(:file "foreign-vector")
))
- (:module "foreign-functions"
- :pathname "src/"
+ (:module "foreign-core"
+ :pathname "foreign-core"
:depends-on ("foreign-interface")
:components ((:file "blas")
(:file "lapack")
(:file "dfftpack")))
(:module "matlisp-base"
- :pathname "src/"
- :depends-on ("foreign-functions")
- :components ((:file "conditions")
- (:file "standard-tensor"
- :depends-on ("conditions"))
+ :depends-on ("foreign-core")
+ :pathname "base"
+ :components ((:file "standard-tensor")
;;
(:file "loopy"
:depends-on ("standard-tensor"))
@@ -104,15 +98,15 @@
(:file "print"
:depends-on ("standard-tensor"))))
(:module "matlisp-classes"
- :pathname "src/"
+ :pathname "classes"
:depends-on ("matlisp-base")
:components ((:file "real-tensor")
(:file "complex-tensor")
(:file "matrix"
:depends-on ("real-tensor" "complex-tensor"))))
(:module "matlisp-level-1"
- :pathname "src/"
- :depends-on ("matlisp-base" "matlisp-classes" "foreign-functions")
+ :pathname "level-1"
+ :depends-on ("matlisp-base" "matlisp-classes" "foreign-core")
:components ((:file "tensor-maker")
(:file "swap")
(:file "dot")
diff --git a/src/blas-helpers.lisp b/src/base/blas-helpers.lisp
similarity index 100%
rename from src/blas-helpers.lisp
rename to src/base/blas-helpers.lisp
diff --git a/src/loopy.lisp b/src/base/loopy.lisp
similarity index 100%
rename from src/loopy.lisp
rename to src/base/loopy.lisp
diff --git a/src/permutation.lisp b/src/base/permutation.lisp
similarity index 100%
rename from src/permutation.lisp
rename to src/base/permutation.lisp
diff --git a/src/print.lisp b/src/base/print.lisp
similarity index 100%
rename from src/print.lisp
rename to src/base/print.lisp
diff --git a/src/standard-tensor.lisp b/src/base/standard-tensor.lisp
similarity index 100%
rename from src/standard-tensor.lisp
rename to src/base/standard-tensor.lisp
diff --git a/src/complex-tensor.lisp b/src/classes/complex-tensor.lisp
similarity index 100%
rename from src/complex-tensor.lisp
rename to src/classes/complex-tensor.lisp
diff --git a/src/matrix.lisp b/src/classes/matrix.lisp
similarity index 100%
rename from src/matrix.lisp
rename to src/classes/matrix.lisp
diff --git a/src/real-tensor.lisp b/src/classes/real-tensor.lisp
similarity index 100%
rename from src/real-tensor.lisp
rename to src/classes/real-tensor.lisp
diff --git a/src/ffi/foreign-vector.lisp b/src/ffi/foreign-vector.lisp
index 03ca115..ed036c3 100644
--- a/src/ffi/foreign-vector.lisp
+++ b/src/ffi/foreign-vector.lisp
@@ -1,4 +1,4 @@
-(in-packge :matlisp-ffi)
+(in-package #:matlisp-ffi)
(defstruct (foreign-vector
(:conc-name fv-)
diff --git a/src/foreign/blas.lisp b/src/foreign-core/blas.lisp
similarity index 100%
rename from src/foreign/blas.lisp
rename to src/foreign-core/blas.lisp
diff --git a/src/foreign/dfftpack.lisp b/src/foreign-core/dfftpack.lisp
similarity index 100%
rename from src/foreign/dfftpack.lisp
rename to src/foreign-core/dfftpack.lisp
diff --git a/src/foreign/lapack.lisp b/src/foreign-core/lapack.lisp
similarity index 100%
rename from src/foreign/lapack.lisp
rename to src/foreign-core/lapack.lisp
diff --git a/src/axpy.lisp b/src/level-1/axpy.lisp
similarity index 100%
rename from src/axpy.lisp
rename to src/level-1/axpy.lisp
diff --git a/src/copy.lisp b/src/level-1/copy.lisp
similarity index 100%
rename from src/copy.lisp
rename to src/level-1/copy.lisp
diff --git a/src/dot.lisp b/src/level-1/dot.lisp
similarity index 100%
rename from src/dot.lisp
rename to src/level-1/dot.lisp
diff --git a/src/realimag.lisp b/src/level-1/realimag.lisp
similarity index 100%
rename from src/realimag.lisp
rename to src/level-1/realimag.lisp
diff --git a/src/scal.lisp b/src/level-1/scal.lisp
similarity index 100%
rename from src/scal.lisp
rename to src/level-1/scal.lisp
diff --git a/src/swap.lisp b/src/level-1/swap.lisp
similarity index 100%
rename from src/swap.lisp
rename to src/level-1/swap.lisp
diff --git a/src/tensor-maker.lisp b/src/level-1/tensor-maker.lisp
similarity index 100%
rename from src/tensor-maker.lisp
rename to src/level-1/tensor-maker.lisp
commit 391e3cfc964a8038324bcbe654d45c763082986d
Author: Akshay Srinivasan <aks...@gm...>
Date: Fri Jul 6 12:55:09 2012 +0530
Moved untransitioned things to the "old" folder.
Removed commit logs from some files.
diff --git a/README.org b/README.org
index 6e10d85..8bdcd0a 100644
--- a/README.org
+++ b/README.org
@@ -7,8 +7,7 @@ This is the development branch of Matlisp.
* Added a specialisation agnostic macros {copy, scal} which generate
functions by getting special method producing macros - produced
by another macro {tensor-store-defs}.
- * copy, scal, dot, swap work
- * axpy works
+ * copy, scal, dot, swap, axpy work
* tensor-{real, imag}part(~) work
* sub-tensor~ works
* print methods work
@@ -18,17 +17,19 @@ This is the development branch of Matlisp.
** TODO : What remains ? (Help!)
*** Functionality
+ * Make everything in src/old/ compatible with new datastrutures.
+ * Tensor contraction: Hard to do very quickly.
+ Might have to copy stuff into a contiguous array; like Femlisp.
* BLAS level-2 and level-3: most importantly Matrix multiplication.
* LAPACK: solving Linear equations, Eigenvalue decomposition.
* DFFTPACK: computing FFTs
* QUADPACK: Move from f2cl-ed version to the Fortran one.
* MINPACK: Move from f2cl-ed version to the Fortran one.
- * ODEPACK: Add abstraction for DLSODE, and DLSODAR.
- * Tensor contraction: Hard to do very quickly.
- Might have to copy stuff into a contiguous array; like Femlisp.
+ * ODEPACK: Add abstraction for DLSODE, and DLSODAR may others too.
+
*** Syntactic sugar
* Add array slicing macros
-
+ * Might have to add something to make it compatible with old Matlisp.
*** Python-bridge
(C)Python has far too many things, that we cannot even begin to hope to replicate.
Burgled-batteries has a lot of things which could be useful in talking to CPython.
diff --git a/matlisp.asd b/matlisp.asd
index 27dfc0a..8ab5196 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -36,12 +36,19 @@
(asdf:defsystem matlisp-packages
:depends-on (#:cffi)
:pathname #.(translate-logical-pathname "matlisp:srcdir;")
- :components
+ :components
((:file "packages")))
+(asdf:defsystem matlisp-conditions
+ :depends-on ("matlisp-packages")
+ :pathname #.(translate-logical-pathname "matlisp:srcdir;")
+ :components ((:module "conditions"
+ :pathname "src/"
+ :components ((:file "conditions")))))
+
(asdf:defsystem matlisp-utilities
:pathname #.(translate-logical-pathname "matlisp:srcdir;")
- :depends-on ("matlisp-packages")
+ :depends-on ("matlisp-packages" "matlisp-conditions")
:components ((:module "utilities"
:pathname "src/"
:components ((:file "utilities")))))
@@ -59,20 +66,21 @@
(asdf:defsystem fortran-names
:pathname #.(translate-logical-pathname "matlisp:src;")
- :depends-on ("matlisp-packages")
+ :depends-on ("matlisp-packages" "matlisp-conditions")
:components
((:file "f77-mangling")))
(asdf:defsystem matlisp
:pathname #.(translate-logical-pathname "matlisp:srcdir;")
:depends-on (#:cffi "lazy-loader"
- "matlisp-packages" "matlisp-utilities"
- "fortran-names")
+ "matlisp-packages" "matlisp-conditions"
+ "matlisp-utilities" "fortran-names")
:components
((:module "foreign-interface"
:pathname "src/"
:components ((:file "ffi-cffi")
(:file "ffi-cffi-interpreter-specific")
+ (:file "foreign-vector")
))
(:module "foreign-functions"
:pathname "src/"
@@ -113,11 +121,9 @@
(:file "scal"
:depends-on ("copy" "tensor-maker"))
(:file "realimag"
- :depends-on ("copy"))))
- (:module "matlisp-level-2"
- :pathname "src/"
- :depends-on ("matlisp-base" "matlisp-classes" "foreign-functions" "matlisp-level-1")
- :components ((:file "axpy")))))
+ :depends-on ("copy"))
+ (:file "axpy"
+ :depends-on ("copy"))))))
;; (defclass f2cl-cl-source-file (asdf:cl-source-file)
diff --git a/packages.lisp b/packages.lisp
index d202ce8..264a6da 100644
--- a/packages.lisp
+++ b/packages.lisp
@@ -25,136 +25,43 @@
;;; ENHANCEMENTS, OR MODIFICATIONS.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; $Id: packages.lisp,v 1.23 2011/01/25 18:36:56 rtoy Exp $
-;;;
-;;; $Log: packages.lisp,v $
-;;; Revision 1.23 2011/01/25 18:36:56 rtoy
-;;; Merge changes from automake-snapshot-2011-01-25-1327 to get the new
-;;; automake build infrastructure.
-;;;
-;;; Revision 1.22.2.1 2011/01/25 18:16:10 rtoy
-;;; config.lisp.in:
-;;; o New file to setup some configuration. Mostly taken from
-;;; packages.lisp.
-;;;
-;;; configure.ac:
-;;; o Add mailing list and URL
-;;; o Build config.lisp from config.lisp.in
-;;;
-;;; packages.lisp:
-;;; o Move the non-package stuff to config.lisp.in.
-;;;
-;;; Revision 1.22 2009/08/19 16:01:34 rtoy
-;;; Add support for interfacing to potrf and potrs. Submitted by Knut
-;;; Gjerden.
-;;;
-;;; src/potrf.lisp:
-;;; o New file for matlisp interface to potrf. Modeled after getrf.
-;;;
-;;; src/potrs.lisp:
-;;; o New file for matlisp interface to potrs. Modeled after getrs.
-;;;
-;;; src/lapack.lisp:
-;;; o Add Fortran interface to dpotrf, zpotrf, dpotrs, and zpotrs.
-;;;
-;;; matlisp.mk.in:
-;;; o Add dpotrf.o, dpotf2.o dpotrs.o zpotrs.o to list of LAPACK files we
-;;; need to compile.
-;;;
-;;; packages.lisp:
-;;; o Export DPOTRS, ZPOTRS, DPOTRF, and ZPOTRF
-;;; o Export POTRF! and POTRS!.
-;;;
-;;; start.lisp:
-;;; o Don't use verbose output from mk:oos.
-;;;
-;;; system.dcl:
-;;; o Add potrf and potrs to system.
-;;;
-;;; Revision 1.21 2004/05/20 21:43:00 rtoy
-;;; Add some docstrings to the packages, remove some unused stuff.
-;;;
-;;; Revision 1.20 2004/02/20 17:34:31 rtoy
-;;; Update to latest f2cl code, so
-;;; o Fix defpackage stuff for f2cl
-;;; o Update macros.l.
-;;;
-;;; Revision 1.19 2003/12/07 15:03:44 rtoy
-;;; Add support for SBCL. I did not test if SBCL works, but CMUCL still
-;;; works.
-;;;
-;;; From Robbie Sedgewick on matlisp-users, 2003-11-13.
-;;;
-;;; Revision 1.18 2003/10/25 17:01:49 rtoy
-;;; o Remove the nicknames "MATRIX" and "M".
-;;; o Minor indentation changes.
-;;;
-;;; Revision 1.17 2003/07/25 16:20:08 rtoy
-;;; Use PCL:FIND-CLASS for CMUCL so all versions of CMUCL will still work.
-;;;
-;;; Revision 1.16 2003/05/31 03:41:43 rtoy
-;;; Our REAL function was colliding with CL's REAL. Shadow this
-;;; appropriately.
-;;;
-;;; Revision 1.15 2002/09/30 18:28:52 simsek
-;;; o Added changes by N.Neuss for getrs functions
-;;;
-;;; Revision 1.14 2002/01/20 00:41:52 simsek
-;;; o exporting some forgotton symbols from LAPACK
-;;;
-;;; Revision 1.13 2002/01/08 00:32:52 rtoy
-;;; Add defpackage for the new MINPACK package.
-;;;
-;;; Revision 1.12 2001/10/25 21:52:57 rtoy
-;;; Export QR, QR!, and GEQR!.
-;;;
-;;; Revision 1.11 2001/07/26 15:47:15 rtoy
-;;; Updated version number to "Pre 2.0" since this isn't 1.0b anymore!
-;;;
-;;; Revision 1.10 2001/05/01 13:11:06 rtoy
-;;; o Export I1MACH, R1MACH, D1MACH from the F2CL package.
-;;; o Export POLYROOTS.
-;;;
-;;; Revision 1.9 2001/04/29 15:52:19 rtoy
-;;; Add the external symbols from TOMS 715.
-;;;
-;;; Revision 1.8 2001/04/26 21:49:15 rtoy
-;;; Add MATLISP-LIB package.
-;;;
-;;; Revision 1.7 2001/02/23 18:00:11 rtoy
-;;; Add defpackages for FORTRAN-TO-LISP and QUADPACK for quadpack
-;;; routines. Update MATLISP package accordingly.
-;;;
-;;; Revision 1.6 2000/10/04 23:54:47 simsek
-;;; o Importing EXCL (EXT) for CMUCL (Allegro) in Matlisp-user package
-;;;
-;;; Revision 1.5 2000/10/04 22:49:52 simsek
-;;; o Added matlisp-user package
-;;;
-;;; Revision 1.4 2000/10/04 15:40:46 simsek
-;;; o Added unload-blas-&-lapack-binaries
-;;; to symbols exported from matlisp
-;;;
-;;; Revision 1.3 2000/10/04 01:20:44 simsek
-;;; o Moved version related code from system.dcl
-;;; to here. This code should be the first bit of code loaded
-;;; but only after the system is defined (furthermore, in this
-;;; way we avoid interning symbols in packages other than the
-;;; matlisp package
-;;;
-;;; Revision 1.2 2000/07/11 02:03:51 simsek
-;;; o Added support for Allegro CL
-;;;
-;;; Revision 1.1 2000/06/19 22:19:33 rtoy
-;;; Initial revision.
-;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
;;; Define the packages and symbols for Matlisp.
-(defpackage "UTILITIES"
+(defpackage "MATLISP-CONDITIONS"
(:use #:common-lisp)
+ (:export
+ ;;<conditon {accessors*}>
+ ;;Generic errors
+ #:generic-error #:message
+ #:invalid-type #:given #:expected
+ #:invalid-value #:given #:expected
+ #:unknown-token #:token
+ #:coercion-error #:from #:to
+ #:out-of-bounds-error #:requested #:bound
+ #:non-uniform-bounds-error #:assumed #:found
+ ;;Permutation conditions
+ #:permutation #:permutation
+ #:permutation-invalid-error
+ #:permutation-permute-error #:seq-len #:group-rank
+ ;;Tensor conditions
+ #:tensor-error #:tensor
+ #:tensor-store-index-out-of-bounds #:index #:store-size
+ #:tensor-insufficient-store #:store-size #:max-idx
+ #:tensor-not-matrix #:rank
+ #:tensor-not-vector #:rank
+ #:tensor-index-out-of-bounds #:argument #:index #:dimension
+ #:tensor-index-rank-mismatch #:index-rank #:rank
+ #:tensor-invalid-head-value #:head
+ #:tensor-invalid-dimension-value #:argument #:dimension
+ #:tensor-invalid-stride-value #:argument #:stride
+ #:tensor-cannot-find-sub-class #:tensor-class
+ #:tensor-cannot-find-optimization #:tensor-class
+ #:tensor-dimension-mismatch
+))
+
+;;foreign-vector stuff must go to ffi-...
+(defpackage "MATLISP-UTILITIES"
+ (:use #:common-lisp #:matlisp-conditions)
(:export #:ensure-list
#:zip #:zip-eq
#:cut-cons-chain!
@@ -170,29 +77,28 @@
#:macrofy
;;
#:inlining #:definline
- #:with-optimization #:quickly #:very-quickly #:slowly #:quickly-if
- ;;Structure-specific
- #:foreign-vector #:make-foreign-vector #:foreign-vector-p
- #:fv-ref #:fv-pointer #:fv-size #:fv-type))
+ #:with-optimization #:quickly #:very-quickly #:slowly #:quickly-if))
-(defpackage "FORTRAN-FFI-ACCESSORS"
- (:nicknames #:ffi)
- (:use #:common-lisp #:cffi #:utilities)
+(defpackage "MATLISP-FFI"
+ (:use #:common-lisp #:cffi #:matlisp-utilities #:matlisp-conditions)
;; TODO: Check if this is implementation-agnostic.
;; #+:cmu (:use :common-lisp :c-call :cffi :utilities)
;; #+:sbcl (:use :common-lisp :cffi :utilities)
-
+ ;; Works with ccl.
;; #+:allegro (:use :common-lisp :cffi :utilities)
;; #+(not (or sbcl cmu allegro)) (:use :common-lisp :cffi :utilities)
(:export
- ;; interface functions
+ ;;Foreign-pointer enclosing structure.
+ #:foreign-vector #:make-foreign-vector #:foreign-vector-p
+ #:fv-ref #:fv-pointer #:fv-size #:fv-type
+ ;;Interface functions
#:def-fortran-routine
#:with-vector-data-addresses
)
(:documentation "Fortran foreign function interface"))
-(defpackage "BLAS"
- (:use #:common-lisp #:ffi)
+(defpackage "MATLISP-BLAS"
+ (:use #:common-lisp #:matlisp-ffi)
(:export
;;BLAS Level 1
;;------------
@@ -216,8 +122,8 @@
#:zgemm #:ztrmm #:ztrsm #:zherk #:zher2k)
(:documentation "BLAS routines"))
-(defpackage "LAPACK"
- (:use #:common-lisp #:ffi)
+(defpackage "MATLISP-LAPACK"
+ (:use #:common-lisp #:matlisp-ffi)
(:export
#:dgesv #:dgeev #:dgetrf #:dgetrs #:dgesvd
#:zgesv #:zgeev #:zgetrf #:zgetrs #:zgesvd
@@ -227,15 +133,16 @@
#:dgelsy)
(:documentation "LAPACK routines"))
-(defpackage "DFFTPACK"
- (:use #:common-lisp #:fortran-ffi-accessors)
+(defpackage "MATLISP-DFFTPACK"
+ (:use #:common-lisp #:matlisp-ffi)
(:export #:zffti #:zfftf #:zfftb #:zffti #:zfftf #:zfftb)
(:documentation "FFT routines"))
(defpackage "MATLISP"
- (:use #:common-lisp #:fortran-ffi-accessors #:blas #:lapack #:dfftpack #:utilities)
- (:export #:integer4-type #:integer4-array #:allocate-integer4-store
- #:index-type #:index-array #:allocate-index-store #:make-index-store
+ (:use #:common-lisp
+ #:matlisp-conditions #:matlisp-utilities #:matlisp-ffi
+ #:matlisp-blas #:matlisp-lapack #:matlisp-dfftpack)
+ (:export #:index-type #:index-array #:allocate-index-store #:make-index-store
;;Standard-tensor
#:standard-tensor
#:rank #:dimensions #:number-of-elements
diff --git a/src/axpy.lisp b/src/axpy.lisp
index bffe87a..35fa404 100644
--- a/src/axpy.lisp
+++ b/src/axpy.lisp
@@ -25,54 +25,8 @@
;;; ENHANCEMENTS, OR MODIFICATIONS.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; Originally written by Raymond Toy
-;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; $Id: axpy.lisp,v 1.8 2011/01/25 18:36:56 rtoy Exp $
-;;;
-;;; $Log: axpy.lisp,v $
-;;; Revision 1.8 2011/01/25 18:36:56 rtoy
-;;; Merge changes from automake-snapshot-2011-01-25-1327 to get the new
-;;; automake build infrastructure.
-;;;
-;;; Revision 1.7.2.1 2011/01/25 18:16:53 rtoy
-;;; Use cl:real instead of real.
-;;;
-;;; Revision 1.7 2004/05/24 16:34:22 rtoy
-;;; More SBCL support from Robert Sedgewick. The previous SBCL support
-;;; was incomplete.
-;;;
-;;; Revision 1.6 2003/02/14 05:42:11 rtoy
-;;; Undo previous change. We really need the 1x1-complex-array for
-;;; Allegro because we don't (currently) pass in complex double-floats as
-;;; an array. (Not needed for CMUCL which handles this correctly.)
-;;;
-;;; Revision 1.4 2000/07/11 18:02:03 simsek
-;;; o Added credits
-;;;
-;;; Revision 1.3 2000/07/11 02:11:56 simsek
-;;; o Added support for Allegro CL
-;;;
-;;; Revision 1.2 2000/05/08 17:19:18 rtoy
-;;; Changes to the STANDARD-MATRIX class:
-;;; o The slots N, M, and NXM have changed names.
-;;; o The accessors of these slots have changed:
-;;; NROWS, NCOLS, NUMBER-OF-ELEMENTS
-;;; The old names aren't available anymore.
-;;; o The initargs of these slots have changed:
-;;; :nrows, :ncols, :nels
-;;;
-;;; Revision 1.1 2000/04/14 00:11:12 simsek
-;;; o This file is adapted from obsolete files 'matrix-float.lisp'
-;;; 'matrix-complex.lisp' and 'matrix-extra.lisp'
-;;; o Initial revision.
-;;;
-;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(in-package :matlisp)
+(in-package #:matlisp)
(defmacro generate-typed-axpy! (func (tensor-class blas-func))
;;Be very careful when using functions generated by this macro.
diff --git a/src/blas-helpers.lisp b/src/blas-helpers.lisp
index 04209bb..ce40b7f 100644
--- a/src/blas-helpers.lisp
+++ b/src/blas-helpers.lisp
@@ -1,4 +1,4 @@
-(in-package :matlisp)
+(in-package #:matlisp)
;;Check dimensions of the tensors before passing the argument here!
(defun blas-copyable-p (ten-a ten-b)
diff --git a/src/complex-tensor.lisp b/src/complex-tensor.lisp
index 967ad68..c876f90 100644
--- a/src/complex-tensor.lisp
+++ b/src/complex-tensor.lisp
@@ -1,4 +1,4 @@
-(in-package :matlisp)
+(in-package #:matlisp)
(deftype complex-base-type ()
"The type of the elements stored in a COMPLEX-MATRIX"
diff --git a/src/conditions.lisp b/src/conditions.lisp
index 842624e..9864362 100644
--- a/src/conditions.lisp
+++ b/src/conditions.lisp
@@ -1,17 +1,5 @@
;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Package: :matlisp; Base: 10 -*-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; $Id: conditions.lisp,v 1.1 2003/06/01 15:21:41 rtoy Exp $
-;;;
-;;; $Log: conditions.lisp,v $
-;;; Revision 1.1 2003/06/01 15:21:41 rtoy
-;;; Some conditions for matlisp matrix errors.
-;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;;; Error conditions for matlisp
-
-(in-package :matlisp)
+(in-package #:matlisp-conditions)
(defmacro defcondition (name (&rest parent-types) (&rest slot-specs) &body options)
"Like define-condition except that you can define
@@ -82,7 +70,27 @@
(:method print-object ((c out-of-bounds-error) stream)
(format stream "The bounds are not uniform, assumed bound : ~a, now found to be : ~a.~%" (assumed c) (found c))
(call-next-method)))
-
+
+;;Permutation conditions-----------------------------------------;;
+(define-condition permutation-error (error)
+ ((permutation :reader permutation : |
|
From: Akshay S. <ak...@us...> - 2012-07-05 13:08:37
|
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 8bd064bd60e799c45ed248e17ea9dac42960a631 (commit)
from 71aca48b041b5be2cd4c6ab8d514b260bdc02b19 (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 8bd064bd60e799c45ed248e17ea9dac42960a631
Author: Akshay Srinivasan <aks...@gm...>
Date: Thu Jul 5 18:33:43 2012 +0530
Added swap!, added a :swapper field into tensor-class-optimization.
diff --git a/README.org b/README.org
index 05bc347..6dcc041 100644
--- a/README.org
+++ b/README.org
@@ -7,7 +7,7 @@ This is the development branch of Matlisp.
* Added a specialisation agnostic macros {copy, scal} which generate
functions by getting special method producing macros - produced
by another macro {tensor-store-defs}.
- * copy, scal work
+ * copy, scal, dot, swap work
* tensor-{real, imag}part(~) work
* sub-tensor~ works
* print methods work
@@ -17,7 +17,6 @@ This is the development branch of Matlisp.
** TODO : What remains ? (Help!)
*** Functionality
- * Some stuff from BLAS level-1 is not yet abstracted.
* BLAS level-2 and level-3: most importantly Matrix multiplication.
* LAPACK: solving Linear equations, Eigenvalue decomposition.
* DFFTPACK: computing FFTs
diff --git a/matlisp.asd b/matlisp.asd
index ec882aa..4278e36 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -107,6 +107,7 @@
:depends-on ("matlisp-base" "matlisp-classes" "foreign-functions")
:components ((:file "tensor-maker")
(:file "copy")
+ (:file "swap")
(:file "dot")
(:file "scal"
:depends-on ("copy"))
diff --git a/src/blas-helpers.lisp b/src/blas-helpers.lisp
index 1d7f147..04209bb 100644
--- a/src/blas-helpers.lisp
+++ b/src/blas-helpers.lisp
@@ -1,5 +1,6 @@
(in-package :matlisp)
+;;Check dimensions of the tensors before passing the argument here!
(defun blas-copyable-p (ten-a ten-b)
(declare (type standard-tensor ten-a ten-b))
(mlet*
@@ -10,18 +11,17 @@
(perm-b-dims (permute (dimensions ten-b) std-a-perm) :type (index-array *)))
(very-quickly
(loop
+ for i of-type index-type from 0 below (rank ten-a)
for sost-a across sort-std-a
- for sodi-a across perm-a-dims
- for a-aoff of-type index-type = (aref sort-std-a 0) then (the index-type (* a-aoff sodi-a))
+ for a-aoff of-type index-type = (aref sort-std-a 0) then (the index-type (* a-aoff (aref perm-a-dims (1- i))))
;;
for sost-b across sort-std-b
- for sodi-b across perm-b-dims
- for b-aoff of-type index-type = (aref sort-std-b 0) then (the index-type (* b-aoff sodi-b))
+ for b-aoff of-type index-type = (aref sort-std-b 0) then (the index-type (* b-aoff (aref perm-b-dims (1- i))))
;;
- do (unless (and (= sost-a a-aoff)
- (= sost-b b-aoff)
- (= sodi-a sodi-b))
- (return nil))
+ do (progn
+ (unless (and (= sost-a a-aoff)
+ (= sost-b b-aoff))
+ (return nil)))
finally (return (list (aref sort-std-a 0) (aref sort-std-b 0)))))))
(defun consecutive-store-p (tensor)
diff --git a/src/blas.lisp b/src/blas.lisp
index 3222da9..2c081f1 100644
--- a/src/blas.lisp
+++ b/src/blas.lisp
@@ -229,9 +229,9 @@
Y(0),Y(INCY), ... , Y((N-1)*INCY)
"
(n :integer :input)
- (dx (* :double-float) :output)
+ (dx (* :double-float :inc head-x) :output)
(incx :integer :input)
- (dy (* :double-float))
+ (dy (* :double-float :inc head-y))
(incy :integer :input)
)
@@ -431,9 +431,9 @@
Y(0),Y(2*INCY), ... , Y(2*(N-1)*INCY)
"
(n :integer :input)
- (zx (* :complex-double-float) :output)
+ (zx (* :complex-double-float :inc head-x) :output)
(incx :integer :input)
- (zy (* :complex-double-float))
+ (zy (* :complex-double-float :inc head-y))
(incy :integer :input)
)
diff --git a/src/complex-tensor.lisp b/src/complex-tensor.lisp
index aecac89..967ad68 100644
--- a/src/complex-tensor.lisp
+++ b/src/complex-tensor.lisp
@@ -70,7 +70,12 @@ Cannot hold complex numbers."))
:reader-writer
(lambda (fstore fidx tstore tidx)
(setf (aref tstore (* 2 tidx)) (aref fstore (* 2 fidx))
- (aref tstore (1+ (* 2 tidx))) (aref fstore (1+ (* 2 fidx))))))
+ (aref tstore (1+ (* 2 tidx))) (aref fstore (1+ (* 2 fidx)))))
+ :swapper
+ (lambda (fstore fidx tstore tidx)
+ (progn
+ (rotatef (aref tstore (* 2 tidx)) (aref fstore (* 2 fidx)))
+ (rotatef (aref tstore (1+ (* 2 tidx))) (aref fstore (1+ (* 2 fidx)))))))
(setf (gethash 'complex-sub-tensor *tensor-class-optimizations*) 'complex-tensor)
diff --git a/src/real-tensor.lisp b/src/real-tensor.lisp
index c6c252c..0566539 100644
--- a/src/real-tensor.lisp
+++ b/src/real-tensor.lisp
@@ -49,7 +49,10 @@ Allocates real storage. Default initial-element = 0d0.")
(setf (aref store idx) value))
:reader-writer
(lambda (fstore fidx tstore tidx)
- (setf (aref tstore tidx) (aref fstore fidx))))
+ (setf (aref tstore tidx) (aref fstore fidx)))
+ :swapper
+ (lambda (fstore fidx tstore tidx)
+ (rotatef (aref tstore tidx) (aref fstore fidx))))
(setf (gethash 'real-sub-tensor *tensor-class-optimizations*) 'real-tensor)
diff --git a/src/standard-tensor.lisp b/src/standard-tensor.lisp
index 94db9a7..dc47457 100644
--- a/src/standard-tensor.lisp
+++ b/src/standard-tensor.lisp
@@ -96,6 +96,7 @@
:reader (store idx) => result
:value-writer (value store idx) => (store idx) <- value
:reader-writer (fstore fidx tstore tidx) => (tstore tidx) <- (fstore fidx)
+ :swapper (fstore fidx tstore tidx) => (tstore tidx) <-> (fstore fidx)
o class-name (symbol) of the superclass whose optimizations
are to be made use of.")
@@ -268,11 +269,12 @@
(unless (< -1 idx (store-size tensor))
(error 'tensor-store-index-out-of-bounds :index idx :store-size (store-size tensor) :tensor tensor))))
-(defmacro tensor-store-defs ((tensor-class element-type store-element-type) &key store-allocator coercer reader value-writer reader-writer)
+(defmacro tensor-store-defs ((tensor-class element-type store-element-type) &key store-allocator coercer reader value-writer reader-writer swapper)
(let ((tensym (gensym "tensor")))
(assert store-allocator)
(assert coercer)
(assert (eq (first reader-writer) 'lambda))
+ (assert swapper)
`(progn
,(destructuring-bind (lbd args &rest body) reader
(assert (eq lbd 'lambda))
@@ -295,6 +297,7 @@
:reader (macrofy ,reader)
:value-writer (macrofy ,value-writer)
:reader-writer (macrofy ,reader-writer)
+ :swapper (macrofy ,swapper)
:store-allocator ',store-allocator
:coercer ',coercer
:element-type ',element-type
diff --git a/src/swap.lisp b/src/swap.lisp
index 889576e..d0e334a 100644
--- a/src/swap.lisp
+++ b/src/swap.lisp
@@ -56,13 +56,35 @@
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(in-package "MATLISP")
+(in-package :matlisp)
-#+nil (use-package "BLAS")
-#+nil (use-package "LAPACK")
-#+nil (use-package "FORTRAN-FFI-ACCESSORS")
+(defmacro generate-typed-swap! (func (tensor-class blas-func))
+ ;;Be very careful when using functions generated by this macro.
+ ;;Indexes can be tricky and this has no safety net
+ ;;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)
+ `(defun ,func (x y)
+ (declare (type ,tensor-class x y))
+ (if-let (strd-p (blas-copyable-p x y))
+ (,blas-func (number-of-elements x) (store x) (first strd-p) (store y) (second strd-p) (head x) (head y))
+ (let ((f-sto (store x))
+ (t-sto (store y)))
+ (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 x))
+ with (linear-sums
+ (f-of (strides x) (head x))
+ (t-of (strides y) (head y)))
+ do ,(funcall (getf opt :swapper) 'f-sto 'f-of 't-sto 't-of)))))
+ y)))
-#+nil (export '(swap!))
+(generate-typed-swap! real-typed-swap! (real-tensor dswap))
+(generate-typed-swap! complex-typed-swap! (complex-tensor zswap))
+;;---------------------------------------------------------------;;
(defgeneric swap! (x y)
(:documentation
@@ -73,40 +95,24 @@
Purpose
=======
- Given matrices X,Y, performs:
+ Given tensors X,Y, performs:
X <-> Y
and returns Y.
- X,Y need not have the same dimensions,
- but must have the same total number of
- elements. Practically, this is useful
- for adding a row and column vector of
- the same size etc ...
-"))
+ X, Y must have the same dimensions.
+")
+ (:method :before ((x standard-tensor) (y standard-tensor))
+ (unless (idx= (dimensions x) (dimensions y))
+ (error 'tensor-dimension-mismatch)))
+ (:method ((x complex-tensor) (y real-tensor))
+ (error 'coercion-error :from 'complex-tensor :to 'real-tensor))
+ (:method ((x real-tensor) (y complex-tensor))
+ (error 'coercion-error :from 'complex-tensor :to 'real-tensor)))
-(defmethod swap! :before ((x standard-matrix) (y standard-matrix))
- (let ((nxm-x (number-of-elements x))
- (nxm-y (number-of-elements y)))
- (declare (type fixnum nxm-x nxm-y))
- (if (not (= nxm-x nxm-y))
- (error "arguments X,Y to SWAP! not the same size"))))
+(defmethod swap! ((x real-tensor) (y real-tensor))
+ (real-typed-swap! x y))
-(defmethod swap! ((x real-matrix) (y real-matrix))
- (let ((nxm (number-of-elements x)))
- (dswap nxm (store x) 1 (store y) 1)
- y))
-
-(defmethod swap! ((x complex-matrix) (y complex-matrix))
- (let ((nxm (number-of-elements x)))
- (zswap nxm (store x) 1 (store y) 1)
- y))
-
-(defmethod swap! ((x real-matrix) (y complex-matrix))
- (error "cannot SWAP! a real matrix with a complex one,
-don't know how to coerce COMPLEX to REAL"))
-
-(defmethod swap! ((x complex-matrix) (y real-matrix))
- (error "cannot SWAP! a real matrix with a complex one,
-don't know how to coerce COMPLEX to REAL"))
+(defmethod swap! ((x complex-tensor) (y complex-tensor))
+ (complex-typed-swap! x y))
-----------------------------------------------------------------------
Summary of changes:
README.org | 3 +-
matlisp.asd | 1 +
src/blas-helpers.lisp | 16 +++++-----
src/blas.lisp | 8 ++--
src/complex-tensor.lisp | 7 ++++-
src/real-tensor.lisp | 5 ++-
src/standard-tensor.lisp | 5 ++-
src/swap.lisp | 76 +++++++++++++++++++++++++---------------------
8 files changed, 69 insertions(+), 52 deletions(-)
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2012-07-05 11:51:51
|
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 71aca48b041b5be2cd4c6ab8d514b260bdc02b19 (commit)
via 174d27300595c21a466a330fa34ab66fa7131bdf (commit)
via f25a68740987eeac4539d48b7a58d189da5b28e7 (commit)
via 536e528120dcf8631dbb9a8d4efd9af5541e55e0 (commit)
from d5f7ad309ca59d41c6e405c512f9a3544be01ea2 (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 71aca48b041b5be2cd4c6ab8d514b260bdc02b19
Author: Akshay Srinivasan <aks...@gm...>
Date: Thu Jul 5 17:16:14 2012 +0530
o Loopy has a new macro to recurse through lists of lists of lists ...
o Added a tensor-maker macro.
o dot now works.
diff --git a/README.org b/README.org
index 071d4fc..05bc347 100644
--- a/README.org
+++ b/README.org
@@ -26,6 +26,8 @@ This is the development branch of Matlisp.
* ODEPACK: Add abstraction for DLSODE, and DLSODAR.
* Tensor contraction: Hard to do very quickly.
Might have to copy stuff into a contiguous array; like Femlisp.
+*** Syntactic sugar
+ * Add array slicing macros
*** Python-bridge
(C)Python has far too many things, that we cannot even begin to hope to replicate.
diff --git a/matlisp.asd b/matlisp.asd
index 5db4d00..ec882aa 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -80,12 +80,10 @@
:components ((:file "blas")
(:file "lapack")
(:file "dfftpack")))
- (:module "matlisp-essentials"
+ (:module "matlisp-base"
:pathname "src/"
- :depends-on ("foreign-interface"
- "foreign-functions")
+ :depends-on ("foreign-functions")
:components ((:file "conditions")
- ;;
(:file "standard-tensor"
:depends-on ("conditions"))
;;
@@ -94,28 +92,26 @@
(:file "permutation"
:depends-on ("standard-tensor"))
(:file "blas-helpers"
- :depends-on ("standard-tensor" "permutation"))
- ;;
- (:file "real-tensor"
- :depends-on ("standard-tensor"))
- (:file "complex-tensor"
- :depends-on ("standard-tensor"))
- (:file "standard-matrix"
- :depends-on ("standard-tensor" "real-tensor" "complex-tensor"))
- ;; (:file "real-matrix"
- ;; :depends-on ("standard-matrix"))
- ;; (:file "complex-matrix"
- ;; :depends-on ("standard-matrix"))
+ :depends-on ("standard-tensor" "permutation"))
(:file "print"
- :depends-on ("standard-tensor" "standard-matrix"))
- ;;Copy, Scal
- (:file "copy"
- :depends-on ("real-tensor" "complex-tensor" "loopy"))
+ :depends-on ("standard-tensor"))))
+ (:module "matlisp-classes"
+ :pathname "src/"
+ :depends-on ("matlisp-base")
+ :components ((:file "real-tensor")
+ (:file "complex-tensor")
+ (:file "matrix"
+ :depends-on ("real-tensor" "complex-tensor"))))
+ (:module "matlisp-level-1"
+ :pathname "src/"
+ :depends-on ("matlisp-base" "matlisp-classes" "foreign-functions")
+ :components ((:file "tensor-maker")
+ (:file "copy")
+ (:file "dot")
(:file "scal"
- :depends-on ("copy" "loopy"))
+ :depends-on ("copy"))
(:file "realimag"
- :depends-on ("real-tensor" "complex-tensor" "copy"))
- ))))
+ :depends-on ("copy"))))))
;; (defclass f2cl-cl-source-file (asdf:cl-source-file)
diff --git a/packages.lisp b/packages.lisp
index 5226d68..d202ce8 100644
--- a/packages.lisp
+++ b/packages.lisp
@@ -162,7 +162,7 @@
#:recursive-append #:unquote-args #:flatten
#:format-to-string #:string+
#:linear-array-type
- #:seq-max #:seq-min
+ #:list-dimensions
;;Macros
#:when-let #:if-let #:if-ret #:with-gensyms #:let-rec
#:mlet* #:make-array-allocator
diff --git a/src/complex-tensor.lisp b/src/complex-tensor.lisp
index 4a636cf..aecac89 100644
--- a/src/complex-tensor.lisp
+++ b/src/complex-tensor.lisp
@@ -1,24 +1,24 @@
(in-package :matlisp)
-(eval-when (load eval compile)
- (deftype complex-base-type ()
- "The type of the elements stored in a COMPLEX-MATRIX"
- 'double-float)
-
- (deftype complex-base-array (size)
- "The type of the storage structure for a COMPLEX-MATRIX"
- `(simple-array complex-base-type (,size)))
-
- (deftype complex-type ()
- "Complex number with Re, Im parts in complex-base-type."
- '(cl:complex complex-base-type))
- )
+(deftype complex-base-type ()
+ "The type of the elements stored in a COMPLEX-MATRIX"
+ 'double-float)
+
+(deftype complex-base-array (size)
+ "The type of the storage structure for a COMPLEX-MATRIX"
+ `(simple-array complex-base-type (,size)))
+
+(deftype complex-type ()
+ "Complex number with Re, Im parts in complex-base-type."
+ '(cl:complex complex-base-type))
;;
(definline allocate-complex-store (size)
-"(allocate-complex-store size)
-Allocates real storage of size (* SIZE 2).
-Default initial-element = 0d0."
+ "
+ (allocate-complex-store size)
+ Allocates real storage of size (* SIZE 2).
+ Default initial-element = 0d0.
+"
(make-array (* 2 size) :element-type 'complex-base-type
:initial-element (coerce 0 'complex-base-type)))
@@ -87,11 +87,3 @@ Cannot hold complex numbers."))
"~11,5,,,,,'Eg"
"#C(~11,4,,,,,'Ee ~11,4,,,,,'Ee)")
realpart imagpart)))
-
-;;
-(defun make-complex-tensor-dims (&rest subs)
- (let* ((dims (make-index-store subs))
- (ss (reduce #'* dims))
- (store (allocate-complex-store ss)))
- (make-instance 'complex-tensor :store store :dimensions dims)))
-
diff --git a/src/conditions.lisp b/src/conditions.lisp
index 27986e0..842624e 100644
--- a/src/conditions.lisp
+++ b/src/conditions.lisp
@@ -33,7 +33,7 @@
;;Generic conditions---------------------------------------------;;
(defcondition generic-error (error)
((message :reader message :initarg :message :initform ""))
- (:method print-method ((c generic-error) stream)
+ (:method print-object ((c generic-error) stream)
(format stream (message c))))
(defcondition invalid-type (generic-error)
@@ -64,9 +64,25 @@
(to :reader to :initarg :to))
(:documentation "Cannot coerce one type into another.")
(:method print-object ((c coercion-error) stream)
- (format stream "Cannot coerce ~a into ~a." (from c) (to c))
+ (format stream "Cannot coerce ~a into ~a.~%" (from c) (to c))
(call-next-method)))
+(defcondition out-of-bounds-error (generic-error)
+ ((requested :reader requested :initarg :requested)
+ (bound :reader bound :initarg :bound))
+ (:documentation "General out-of-bounds error")
+ (:method print-object ((c out-of-bounds-error) stream)
+ (format stream "Out-of-bounds error, requested index : ~a, bound : ~a.~%" (requested c) (bound c))
+ (call-next-method)))
+
+(defcondition non-uniform-bounds-error (generic-error)
+ ((assumed :reader assumed :initarg :assumed)
+ (found :reader found :initarg :found))
+ (:documentation "Bounds are not uniform")
+ (:method print-object ((c out-of-bounds-error) stream)
+ (format stream "The bounds are not uniform, assumed bound : ~a, now found to be : ~a.~%" (assumed c) (found c))
+ (call-next-method)))
+
;;Tensor conditions----------------------------------------------;;
(define-condition tensor-error (error)
;;Optional argument for error-handling.
@@ -92,6 +108,12 @@
(:report (lambda (c stream)
(format stream "Given tensor with rank ~A, is not a matrix." (rank c)))))
+(define-condition tensor-not-vector (tensor-error)
+ ((tensor-rank :reader rank :initarg :rank))
+ (:documentation "Given tensor is not a vector.")
+ (:report (lambda (c stream)
+ (format stream "Given tensor with rank ~A, is not a vector." (rank c)))))
+
(define-condition tensor-index-out-of-bounds (tensor-error)
((argument :reader argument :initarg :argument)
(index :reader index :initarg :index)
diff --git a/src/dot.lisp b/src/dot.lisp
index 8983caa..1affebc 100644
--- a/src/dot.lisp
+++ b/src/dot.lisp
@@ -97,149 +97,67 @@
otherwise.
"))
-(defmethod dot ((x number) (y number) &optional (conjugate-p nil))
+(defmethod dot ((x number) (y number) &optional (conjugate-p t))
(if conjugate-p
(* (conjugate x) y)
(* x y)))
-(defmethod dot :before ((x standard-matrix) (y standard-matrix) &optional conjugate-p)
+(defmethod dot :before ((x standard-tensor) (y standard-tensor) &optional (conjugate-p t))
(declare (ignore conjugate-p))
- (if (not (row-or-col-vector-p x))
- (error "argument X to DOT is not a row or column vector")
- (if (not (row-or-col-vector-p y))
- (error "argument Y to DOT is not a row or column vector")
- (let ((nxm-x (number-of-elements x))
- (nxm-y (number-of-elements y)))
- (declare (type fixnum nxm-x nxm-y))
- (if (not (= nxm-x nxm-y))
- (error "arguments X,Y to DOT are not of the same size"))))))
-
-(defmethod dot ((x real-matrix) (y real-matrix) &optional conjugate-p)
+ (unless (and (vector-p x) (vector-p y))
+ (error 'tensor-not-vector
+ :rank (cond
+ ((not (vector-p x))
+ (rank x))
+ ((not (vector-p y))
+ (rank y)))))
+ (unless (idx= (dimensions x) (dimensions y))
+ (error 'tensor-dimension-mismatch)))
+
+(defmethod dot ((x real-tensor) (y real-tensor) &optional (conjugate-p t))
(declare (ignore conjugate-p))
- (let ((nxm (number-of-elements x)))
- (declare (type fixnum nxm))
- (ddot nxm (store x) 1 (store y) 1)))
+ (ddot (number-of-elements x)
+ (store x) (aref (strides x) 0)
+ (store y) (aref (strides y) 0)
+ (head x) (head y)))
-;;#+(or :cmu :sbcl)
-(defmethod dot ((x real-matrix) (y complex-matrix) &optional conjugate-p)
+(defmethod dot ((x real-tensor) (y complex-tensor) &optional (conjugate-p t))
(declare (ignore conjugate-p))
- (let ((nxm (number-of-elements x))
- (store-x (store x))
- (store-y (store y)))
- (declare (type fixnum nxm)
- (type (real-matrix-store-type *) store-x)
- (type (complex-matrix-store-type *) store-y))
-
- (let ((realpart (ddot nxm store-x 1 store-y 2))
- (imagpart (with-vector-data-addresses ((addr-x store-x)
- (addr-y store-y))
- (incf-sap addr-y :double-float)
- (ddot nxm addr-x 1 addr-y 2))))
-
- (declare (type complex-matrix-element-type realpart imagpart))
-
- #+:complex-arg-implies-complex-result
- (complex realpart imagpart)
- #-:complex-arg-implies-comples-result
- (if (zerop imagpart)
- realpart
- (complex realpart imagpart))
- )))
-
-
-;;#+:allegro
-#+nil
-(defmethod dot ((x real-matrix) (y complex-matrix) &optional conjugate-p)
- (declare (ignore conjugate-p))
- (let ((nxm (number-of-elements x)))
- (declare (type fixnum nxm))
-
- (let ((realpart 0.0d0)
- (imagpart 0.0d0))
- (declare (type complex-matrix-element-type realpart imagpart))
-
- (dotimes (i nxm)
- (declare (type fixnum i))
- (let ((x-elt (matrix-ref x i))
- (y-elt (matrix-ref y i)))
- (incf realpart (+ x-elt (realpart y-elt)))
- (incf imagpart (+ x-elt (imagpart y-elt)))))
-
-
- #+:complex-arg-implies-complex-result
- (complex realpart imagpart)
- #-:complex-arg-implies-comples-result
- (if (zerop imagpart)
- realpart
- (complex realpart imagpart))
- )))
-
-;;#+(or :cmu :sbcl)
-(defmethod dot ((x complex-matrix) (y real-matrix) &optional (conjugate-p t))
- (let ((nxm (number-of-elements x))
- (store-x (store x))
- (store-y (store y)))
- (declare (type fixnum nxm)
- (type (real-matrix-store-type *) store-y)
- (type (complex-matrix-store-type *) store-x))
-
- (let ((realpart (ddot nxm store-x 2 store-y 1))
- (imagpart (with-vector-data-addresses ((addr-x store-x)
- (addr-y store-y))
- (incf-sap addr-x :double-float)
- (ddot nxm addr-x 2 addr-y 1))))
-
- (declare (type complex-matrix-element-type realpart imagpart))
-
- (if conjugate-p
- (setq imagpart (- imagpart)))
-
- #+:complex-arg-implies-complex-result
- (complex realpart imagpart)
- #-:complex-arg-implies-comples-result
- (if (zerop imagpart)
- realpart
- (complex realpart imagpart))
- )))
-
-#+nil
-(defmethod dot ((x complex-matrix) (y real-matrix) &optional (conjugate-p t))
- (let ((nxm (number-of-elements x)))
- (declare (type fixnum nxm))
-
- (let ((realpart 0.0d0)
- (imagpart 0.0d0))
- (declare (type complex-matrix-element-type realpart imagpart))
-
- (dotimes (i nxm)
- (declare (type fixnum i))
- (let ((x-elt (matrix-ref x i))
- (y-elt (matrix-ref y i)))
- (incf realpart (+ y-elt (realpart x-elt)))
- (incf imagpart (+ y-elt (imagpart x-elt)))))
-
- (if conjugate-p
- (setq imagpart (- imagpart)))
-
- #+:complex-arg-implies-complex-result
- (complex realpart imagpart)
- #-:complex-arg-implies-comples-result
- (if (zerop imagpart)
- realpart
- (complex realpart imagpart))
- )))
-
-(defmethod dot ((x complex-matrix) (y complex-matrix) &optional (conjugate-p t))
- (let* ((nxm (number-of-elements x))
- (store-x (store x))
- (store-y (store y))
- (dot (if conjugate-p
- (zdotc nxm store-x 1 store-y 1)
- (zdotu nxm store-x 1 store-y 1))))
-
- #-:complex-arg-implies-complex-result
- (if (zerop (imagpart dot))
- (realpart dot)
- dot)
- #+:complex-arg-implies-complex-result
- dot))
+ (let ((nele (number-of-elements x))
+ (std-x (aref (strides x) 0))
+ (hd-x (head x))
+ (std-y (aref (strides y) 0))
+ (hd-y (head y)))
+ (declare (type index-type nele std-x std-y hd-x hd-y))
+ (let ((rpart (ddot nele (store x) std-x (store y) (* 2 std-y) hd-x (* 2 hd-y)))
+ (ipart (ddot nele (store x) std-x (store y) (* 2 std-y) hd-x (1+ (* 2 hd-y)))))
+ (declare (type complex-base-type rpart ipart))
+ (if (zerop ipart)
+ rpart
+ (complex rpart ipart)))))
+
+(defmethod dot ((x complex-tensor) (y real-tensor) &optional (conjugate-p t))
+ (let ((cres (dot y x)))
+ (if conjugate-p
+ (conjugate cres)
+ cres)))
+
+(defmethod dot ((x complex-tensor) (y complex-tensor) &optional (conjugate-p t))
+ (let ((nele (number-of-elements x))
+ (std-x (aref (strides x) 0))
+ (hd-x (head x))
+ (std-y (aref (strides y) 0))
+ (hd-y (head y)))
+ (declare (type index-type nele std-x hd-x std-y hd-y))
+ (let ((ret (if conjugate-p
+ (zdotc nele
+ (store x) std-x
+ (store y) std-y
+ hd-x hd-y)
+ (zdotu nele
+ (store x) std-x
+ (store y) std-y
+ hd-x hd-y))))
+ (if (zerop (imagpart ret))
+ (realpart ret)
+ ret))))
diff --git a/src/loopy.lisp b/src/loopy.lisp
index 32037bc..1828f66 100644
--- a/src/loopy.lisp
+++ b/src/loopy.lisp
@@ -8,38 +8,28 @@
{with (loop-order {:row-major :col-major})}
{with (linear-sums
{(offsets {stride-seq})}*)}
- {with (variables
- {(vars init &key type)}*)}
{do ({code}*)})
Examples:
- > (mod-dotimes (idx (vidx 2 2))
- with (linear-sums (of (vidx 2 1)))
+ > (mod-dotimes (idx (idxv 2 2))
+ with (linear-sums (of (idxv 2 1)))
do (format t \"~a ~a~%\" idx of))
#(0 0) 0
#(0 1) 1
#(1 0) 2
#(1 1) 3
- > (mod-dotimes (idx (vidx 2 2))
+ > (mod-dotimes (idx (idxv 2 2))
with (loop-order :col-major)
- with (linear-sums (of (vidx 2 1)))
+ with (linear-sums (of (idxv 2 1)))
do (format t \"~a ~a~%\" idx of))
#(0 0) 0
#(1 0) 2
#(0 1) 1
#(1 1) 3
- > (mod-dotimes (idx (vidx 2 2))
- with (variables (tmp 1d0 :type double-float))
- with (linear-sums (of (vidx 2 1)))
- do (progn
- (format t \"~a ~a ~a~%\" idx of tmp)
- (incf tmp)))
- #(0 0) 0 0d0
- #(0 1) 1 1d0
- #(1 0) 2 2d0
- #(1 1) 3 3d0
+ Make sure that \"do\" is specified at the end. Parser stops
+ at the first 'do it finds.
"
(check-type idx symbol)
(labels ((parse-code (body ret)
@@ -50,6 +40,11 @@
(multiple-value-bind (indic decl) (parse-with (cadr body))
(setf (getf ret indic) decl))
(parse-code (cddr body) ret))
+ ;;Let's not do too much
+ #+nil
+ ((eq (car body) 'finally)
+ (setf (getf ret :finally) (second body))
+ (parse-code (cddr body) ret))
((eq (car body) 'do)
(values (cadr body) ret))
(t (error 'unknown-token :token (car body) :message "Error in macro: mod-dotimes -> parse-code.~%"))))
@@ -66,6 +61,8 @@
((and (eq (car code) 'loop-order)
(member (cadr code) '(:row-major :col-major)))
(values :loop-order (second code)))
+ ;;Useless without a finally clause
+ #+nil
((eq (car code) 'variables)
(values :variables
(loop for decl in (cdr code)
@@ -119,4 +116,111 @@
(unless (= ,cstrd 0)
(incf ,(getf decl :offset-sym) ,cstrd)))))
(return t)))
- finally (return nil))))))))))))
+ finally (return nil))))
+ ,@(unless (null (getf sdecl :finally))
+ `(finally (,@(getf sdecl :finally))))))))))))
+
+(defmacro list-loop ((idx ele lst) &rest body)
+ "
+ (list-loop (idx ele {list}) compound-form*)
+
+ Examples:
+ > (list-loop (idx ele '((1 2) (4 5)))
+ with (linear-sums (of (idxv 2 1)))
+ do (format t \"~a ~a ~a~%\" idx of ele))
+ #(0 0) 0 1
+ #(0 1) 1 2
+ #(1 0) 2 4
+ #(1 1) 3 5
+"
+ (check-type idx symbol)
+ (check-type ele symbol)
+ (labels ((parse-code (body ret)
+ (cond
+ ((null body)
+ (values nil ret))
+ ((eq (car body) 'with)
+ (multiple-value-bind (indic decl) (parse-with (cadr body))
+ (setf (getf ret indic) decl))
+ (parse-code (cddr body) ret))
+ ;;Let's not do too much.
+ #+nil
+ ((eq (car body) 'finally)
+ (setf (getf ret :finally) (second body))
+ (parse-code (cddr body) ret))
+ ((eq (car body) 'do)
+ (values (cadr body) ret))
+ (t (error 'unknown-token :token (car body) :message "Error in macro: mod-dotimes -> parse-code.~%"))))
+ (parse-with (code)
+ (cond
+ ((eq (car code) 'linear-sums)
+ (values :linear-sums
+ (loop for decl in (cdr code)
+ collect (destructuring-bind (offst strds &optional (init 0)) decl
+ (list :offset-sym offst
+ :offset-init init
+ :stride-sym (gensym (string+ (symbol-name offst) "-stride"))
+ :stride-expr strds)))))
+ ;;Traversing the list the other way is far too inefficient and/or too hard to do.
+ #+nil
+ ((and (eq (car code) 'loop-order)
+ (member (cadr code) '(:row-major :col-major)))
+ (values :loop-order (second code)))
+ ;;Useless without a finally clause.
+ #+nil
+ ((eq (car code) 'variables)
+ (values :variables
+ (loop for decl in (cdr code)
+ collect (destructuring-bind (sym init &key type) decl
+ (list :variable sym
+ :init init
+ :type type)))))
+ (t (error 'unknown-token :token (car code) :message "Error in macro: mod-dotimes -> parse-with.~%")))))
+ (multiple-value-bind (code sdecl) (parse-code body nil)
+ (with-gensyms (lst-sym dims-sym rank-sym lst-rec-sym lst-rec-count-sym lst-rec-lst-sym)
+ `(let ((,lst-sym ,lst))
+ (declare (type list ,lst-sym))
+ (let ((,dims-sym (make-index-store (list-dimensions ,lst-sym))))
+ (declare (type (index-array *) ,dims-sym))
+ (let ((,rank-sym (array-dimension ,dims-sym 0)))
+ (declare (type index-type ,rank-sym))
+ (let ((,idx (allocate-index-store ,rank-sym))
+ ,@(mapcar #'(lambda (x) `(,(getf x :offset-sym) ,(getf x :offset-init))) (getf sdecl :linear-sums))
+ ,@(mapcar #'(lambda (x) `(,(getf x :stride-sym) ,(getf x :stride-expr))) (getf sdecl :linear-sums))
+ ,@(mapcar #'(lambda (x) `(,(getf x :variable) ,(getf x :init))) (getf sdecl :variables)))
+ (declare (type (index-array *) ,idx)
+ ,@(when (getf sdecl :linear-sums)
+ `((type (index-array *) ,@(mapcar #'(lambda (x) (getf x :stride-sym)) (getf sdecl :linear-sums)))
+ (type index-type ,@(mapcar #'(lambda (x) (getf x :offset-sym)) (getf sdecl :linear-sums)))))
+ ,@(loop for x in (getf sdecl :variables)
+ unless (null (getf x :type))
+ collect `(type ,(getf x :type) ,(getf x :variable))))
+ (labels ((,lst-rec-sym (,lst-rec-count-sym ,lst-rec-lst-sym)
+ (if (null ,lst-rec-lst-sym)
+ (progn
+ (unless (= (aref ,idx ,lst-rec-count-sym) (aref ,dims-sym ,lst-rec-count-sym))
+ (error 'non-uniform-bounds-error :assumed (aref ,dims-sym ,lst-rec-count-sym) :found ,lst-rec-count-sym
+ :message "Error in list-loop, given list is not uniform in dimensions."))
+ (setf (aref ,idx ,lst-rec-count-sym) 0)
+ ,@(loop
+ for decl in (getf sdecl :linear-sums)
+ collect `(decf ,(getf decl :offset-sym) (* (aref ,(getf decl :stride-sym) ,lst-rec-count-sym) (aref ,dims-sym ,lst-rec-count-sym))))
+ ,@(if (null (getf sdecl :finally))`(nil)
+ `((when (= ,lst-rec-count-sym 0)
+ ,(getf sdecl :finally)))))
+ (progn
+ ;;list-dimensions does not parse the entire list, just goes through caaa..r's to find out the
+ ;;dimensions if it is uniform.
+ (unless (< -1 (aref ,idx ,lst-rec-count-sym) (aref ,dims-sym ,lst-rec-count-sym))
+ (error 'out-of-bounds-error :requested ,lst-rec-count-sym :bound (aref ,dims-sym ,lst-rec-count-sym)
+ :message "Error in list-loop, given list is not uniform in dimensions."))
+ (if (consp (car ,lst-rec-lst-sym))
+ (,lst-rec-sym (1+ ,lst-rec-count-sym) (car ,lst-rec-lst-sym))
+ (let ((,ele (car ,lst-rec-lst-sym)))
+ ,code))
+ (incf (aref ,idx ,lst-rec-count-sym))
+ ,@(loop
+ for decl in (getf sdecl :linear-sums)
+ collect `(incf ,(getf decl :offset-sym) (aref ,(getf decl :stride-sym) ,lst-rec-count-sym)))
+ (,lst-rec-sym ,lst-rec-count-sym (cdr ,lst-rec-lst-sym))))))
+ (,lst-rec-sym 0 ,lst-sym))))))))))
diff --git a/src/matrix.lisp b/src/matrix.lisp
index 4454c6f..e8fa449 100644
--- a/src/matrix.lisp
+++ b/src/matrix.lisp
@@ -1,511 +1,87 @@
-;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Package: :matlisp; Base: 10 -*-
-;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; Copyright (c) 2000 The Regents of the University of California.
-;;; All rights reserved.
-;;;
-;;; Permission is hereby granted, without written agreement and without
-;;; license or royalty fees, to use, copy, modify, and distribute this
-;;; software and its documentation for any purpose, provided that the
-;;; above copyright notice and the following two paragraphs appear in all
-;;; copies of this software.
-;;;
-;;; IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY
-;;; FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
-;;; ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF
-;;; THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF
-;;; SUCH DAMAGE.
-;;;
-;;; THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
-;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
-;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE
-;;; PROVIDED HEREUNDER IS ON AN "AS IS" BASIS, AND THE UNIVERSITY OF
-;;; CALIFORNIA HAS NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES,
-;;; ENHANCEMENTS, OR MODIFICATIONS.
-;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; Originally written by Raymond Toy
-;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; $Id: matrix.lisp,v 1.16 2011/01/25 18:36:56 rtoy Exp $
-;;;
-;;; $Log: matrix.lisp,v $
-;;; Revision 1.16 2011/01/25 18:36:56 rtoy
-;;; Merge changes from automake-snapshot-2011-01-25-1327 to get the new
-;;; automake build infrastructure.
-;;;
-;;; Revision 1.15.2.1 2011/01/25 18:16:53 rtoy
-;;; Use cl:real instead of real.
-;;;
-;;; Revision 1.15 2010/12/12 02:07:31 rtoy
-;;; matrix.lisp:
-;;;
-;;; o Apply patch from Nicolas Neuss for matrices with 0 dimensions. (See
-;;; <http://sourceforge.net/mailarchive/message.php?msg_id=1124576>)
-;;;
-;;; print.lisp:
-;;; o Apparently the above patch to print was also applied previously. We
-;;; just fix a bug in printing 0xm matrices. Just exit early if the
-;;; matrix has no dimensions.
-;;;
-;;; Revision 1.14 2004/05/24 16:34:22 rtoy
-;;; More SBCL support from Robert Sedgewick. The previous SBCL support
-;;; was incomplete.
-;;;
-;;; Revision 1.13 2003/05/31 22:20:26 rtoy
-;;; o Add some support for CMUCL with Gerd's PCL so we can inline
-;;; accessors and such for the matrix classes.
-;;; o Only use one, system-independent, standard-matrix class.
-;;; o Try to declare the types of the slots of the matrix classes
-;;; o FORTRAN-MATRIX-INDEXING changed to use fixnum arithmetic.
-;;;
-;;; Revision 1.12 2003/03/09 14:26:30 rtoy
-;;; Forgot one more :type 'fixnum bug. From Gerd Moellmann.
-;;;
-;;; Revision 1.11 2003/02/19 21:59:52 rtoy
-;;; Correct the slot type declarations.
-;;;
-;;; Revision 1.10 2001/10/29 18:00:28 rtoy
-;;; Updates from M. Koerber to support QR routines with column pivoting:
-;;;
-;;; o Add an integer4 type and allocate-integer4-store routine.
-;;; o Add the necessary Fortran routines
-;;; o Add Lisp interface to the Fortran routines
-;;; o Update geqr for the new routines.
-;;;
-;;; Revision 1.9 2001/06/22 12:51:49 rtoy
-;;; o Added ALLOCATE-REAL-STORE and ALLOCATE-COMPLEX-STORE functions to
-;;; allocate appropriately sized arrays for holding real and complex
-;;; matrix elements.
-;;; o Use it to allocate space.
-;;;
-;;; Revision 1.8 2000/10/04 15:56:50 simsek
-;;; o Fixed bug in (MAKE-COMPLEX-MATRIX n)
-;;;
-;;; Revision 1.7 2000/07/11 18:02:03 simsek
-;;; o Added credits
-;;;
-;;; Revision 1.6 2000/07/11 02:11:56 simsek
-;;; o Added support for Allegro CL
-;;;
-;;; Revision 1.5 2000/05/11 18:28:10 rtoy
-;;; After the great standard-matrix renaming, row-vector-p and
-;;; col-vector-p were swapped.
-;;;
-;;; Revision 1.4 2000/05/11 18:02:55 rtoy
-;;; o After the great standard-matrix renaming, I forgot a few initargs
-;;; that needed to be changed
-;;; o MAKE-REAL-MATRIX and MAKE-COMPLEX-MATRIX didn't properly handle
-;;; things like #(1 2 3 4) and #((1 2 3 4)). Make them accept these.
-;;;
-;;; Revision 1.3 2000/05/08 17:19:18 rtoy
-;;; Changes to the STANDARD-MATRIX class:
-;;; o The slots N, M, and NXM have changed names.
-;;; o The accessors of these slots have changed:
-;;; NROWS, NCOLS, NUMBER-OF-ELEMENTS
-;;; The old names aren't available anymore.
-;;; o The initargs of these slots have changed:
-;;; :nrows, :ncols, :nels
-;;;
-;;; Revision 1.2 2000/05/05 21:35:16 simsek
-;;; o Fixed row-vector-p and col-vector-p
-;;;
-;;; Revision 1.1 2000/04/14 00:11:12 simsek
-;;; o This file is adapted from obsolete files 'matrix-float.lisp'
-;;; 'matrix-complex.lisp' and 'matrix-extra.lisp'
-;;; o Initial revision.
-;;;
-;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(in-package :matlisp)
-;;; Definitions of STANDARD-MATRIX, REAL-MATRIX, COMPLEX-MATRIX.
-
-(in-package "MATLISP")
-
-#+nil (export '(real-matrix
- complex-matrix
- standard-matrix
- real-matrix-element-type
- real-matrix-store-type
- complex-matrix-element-type
- complex-matrix-store-type
- #|
- n
- m
- nxm
- |#
- nrows
- ncols
- number-of-elements
- row-vector-p
- col-vector-p
- row-or-col-vector-p
- square-matrix-p
- size
- fortran-matrix-indexing
- fortran-complex-matrix-indexing
- complex-coerce
- fill-matrix
- make-real-matrix-dim
- make-real-matrix
- make-complex-matrix-dim
- make-complex-matrix))
-
-(eval-when (load eval compile)
-(deftype integer4-matrix-element-type ()
- '(signed-byte 32))
-
-(deftype real-matrix-element-type ()
- "The type of the elements stored in a REAL-MATRIX"
- 'double-float)
-
-(deftype real-matrix-store-type (size)
- "The type of the storage structure for a REAL-MATRIX"
- `(simple-array double-float ,size))
-
-(deftype complex-matrix-element-type ()
- "The type of the elements stored in a COMPLEX-MATRIX"
- 'double-float)
-
-(deftype complex-matrix-store-type (size)
- "The type of the storage structure for a COMPLEX-MATRIX"
- `(simple-array double-float ,size))
-)
-
-(declaim (ftype (function (standard-matrix) fixnum)
- n
- m
- nxm
- store-size)
- (ftype (function (real-matrix) fixnum)
- n
- m
- nxm
- store-size)
- (ftype (function (complex-matrix) fixnum)
- n
- m
- nxm
- store-size)
- (ftype (function (real-matrix) (simple-array double-float (*)))
- store)
- (ftype (function (complex-matrix) (simple-array double-float (*)))
- store))
-
-
-#|
-(defgeneric n (matrix)
- (:documentation
-"
- Syntax
- ======
- (N matrix)
-
- Purpose
- =======
- Returns the number of rows of MATRIX.
-"))
-
-(defgeneric m (matrix)
- (:documentation
-"
- Syntax
- ======
- (M matrix)
-
- Purpose
- =======
- Returns the number of columns of MATRIX.
-"))
-
-(defgeneric nxm (matrix)
- (:documentation
-"
- Syntax
- ======
- (NxM matrix)
-
- Purpose
- =======
- Returns the number of elements of MATRIX;
- which is number of rows * number of columns.
-"))
-|#
-
-(defgeneric store-size (matrix)
- (:documentation
-"
- Syntax
- ======
- (STORE-SIZE matrix)
-
- Purpose
- =======
- Total number of elements needed to store the matrix. (Usually
- the same as (NxM matrix), but not necessarily so!
-"))
-
-(defgeneric store (matrix)
- (:documentation
-"
- Syntax
- ======
- (STORE matrix)
-
- Purpose
- =======
-The actual storage for the matrix. It is typically a one dimensional
-array but not necessarily so. The float and complex matrices do use
-1-D arrays. The complex matrix actually stores the real and imaginary
-parts in successive elements of the matrix because Fortran stores them
-that way.
-"))
+;;
+(defclass standard-matrix (standard-tensor)
+ ((rank
+ :accessor rank
+ :type index-type
+ :initform 2
+ :documentation "For a matrix, rank = 2."))
+ (:documentation "Basic matrix class."))
-#+(and (or cmu sbcl) gerds-pcl)
-(declaim (ext:slots (slot-boundp real-matrix complex-matrix)
- (inline standard-matrix real-matrix complex-matrix)))
+(defmethod print-object ((tensor standard-matrix) stream)
+ (print-unreadable-object (tensor stream :type t)
+ (format stream "~A x ~A~%" (nrows tensor) (ncols tensor))
+ (print-tensor tensor stream)))
-(defclass standard-matrix ()
- ((number-of-rows
- :initarg :nrows
- :initform 0
- :accessor nrows
- :type fixnum
- :documentation "Number of rows in the matrix")
- (number-of-cols
- :initarg :ncols
- :initform 0
- :accessor ncols
- :type fixnum
- :documentation "Number of columns in the matrix")
- (number-of-elements
- :initarg :nels
- :initform 0
- :accessor number-of-elements
- :type fixnum
- :documentation "Total number of elements in the matrix (nrows * ncols)")
- (store-size
- :initarg :store-size
- :initform 0
- :accessor store-size
- :type fixnum
- :documentation "Total number of elements needed to store the matrix. (Usually
-the same as nels, but not necessarily so!")
- (store
- :initarg :store
- :accessor store
- :documentation "The actual storage for the matrix. It is typically a one dimensional
-array but not necessarily so. The float and complex matrices do use
-1-D arrays. The complex matrix actually stores the real and imaginary
-parts in successive elements of the matrix because Fortran stores them
-that way."))
- (:documentation "Basic matrix class."))
+(definline nrows (matrix)
+ (declare (type standard-matrix matrix))
+ (aref (dimensions matrix) 0))
+(definline ncols (matrix)
+ (declare (type standard-matrix matrix))
+ (aref (dimensions matrix) 1))
-#+(and nil :allegro)
-(defclass standard-matrix ()
- ((number-of-rows
- :initarg :nrows
- :initform 0
- :accessor nrows
- :documentation "Number of rows in the matrix")
- (number-of-cols
- :initarg :ncols
- :initform 0
- :accessor ncols
- :documentation "Number of columns in the matrix")
- (number-of-elements
- :initarg :nels
- :initform 0
- :accessor number-of-elements
- :documentation "Total number of elements in the matrix (nrows * ncols)")
- (store-size
- :initarg :store-size
- :initform 0
- :accessor store-size
- :documentation "Total number of elements needed to store the matrix. (Usually
-the same as nels, but not necessarily so!")
- (store
- :initarg :store
- :accessor store
- :documentation "The actual storage for the matrix. It is typically a one dimensional
-array but not necessarily so. The float and complex matrices do use
-1-D arrays. The complex matrix actually stores the real and imaginary
-parts in successive elements of the matrix because Fortran stores them
-that way."))
- (:documentation "Basic matrix class."))
+(definline row-stride (matrix)
+ (declare (type standard-matrix matrix))
+ (aref (strides matrix) 0))
-(defclass real-matrix (standard-matrix)
- ((store
- :type (simple-array real-matrix-element-type (*))))
- (:documentation "A class of matrices with real elements."))
+(definline col-stride (matrix)
+ (declare (type standard-matrix matrix))
+ (aref (strides matrix) 1))
-(defclass complex-matrix (standard-matrix)
- ((store
- :type (simple-array complex-matrix-element-type (*))))
- (:documentation "A class of matrices with complex elements."))
+(definline size (matrix)
+ (declare (type standard-matrix matrix))
+ (let ((dims (dimensions matrix)))
+ (declare (type (index-array 2) dims))
+ (list (aref dims 0) (aref dims 1))))
+;;
(defmethod initialize-instance :after ((matrix standard-matrix) &rest initargs)
(declare (ignore initargs))
- (let* ((n (nrows matrix))
- (m (ncols matrix))
- (nxm (* n m)))
- (declare (type fixnum n m nxm))
- (setf (number-of-elements matrix) nxm)
- (setf (store-size matrix) nxm)))
-
-(defmethod make-load-form ((matrix standard-matrix) &optional env)
- "MAKE-LOAD-FORM allows us to determine a load time value for
- matrices, for example #.(make-matrix ...)"
- (make-load-form-saving-slots matrix :environment env))
+ (mlet*
+ ((rank (rank matrix) :type index-type))
+ (unless (= rank 2)
+ (error 'tensor-not-matrix :rank rank :tensor matrix))))
-(defgeneric row-vector-p (matrix)
- (:documentation "
+;;
+(definline row-matrix-p (matrix)
+ "
Syntax
======
- (ROW-VECTOR-P x)
+ (ROW-MATRIX-P x)
Purpose
=======
- Return T if X is a row vector (number of columns is 1)"))
+ Return T if X is a row matrix (number of columns is 1)"
+ (tensor-type-p matrix '(1 *)))
-(defgeneric col-vector-p (matrix)
- (:documentation "
+(definline col-matrix-p (matrix)
+ "
Syntax
======
- (COL-VECTOR-P x)
+ (COL-MATRIX-P x)
Purpose
=======
- Return T if X is a column vector (number of rows is 1)"))
+ Return T if X is a column matrix (number of rows is 1)"
+ (tensor-type-p matrix '(* 1)))
-(defgeneric row-or-col-vector-p (matrix)
- (:documentation "
- Syntax
- ======
- (ROW-OR-COL-VECTOR-P x)
-
- Purpose
- =======
- Return T if X is either a row or a column vector"))
-
-(defgeneric square-matrix-p (matrix)
- (:documentation "
- Syntax
- ======
- (SQUARE-MATRIX-P x)
-
- Purpose
- =======
- Return T if X is square matrix"))
-
-(defgeneric size (matrix)
- (:documentation "
+(definline row-or-col-matrix-p (matrix)
+"
Syntax
======
- (SIZE x)
+ (ROW-OR-COL-matrix-P x)
Purpose
=======
- Return the number of rows and columns of the matrix X as a list"))
-
-(declaim (inline row-vector-p))
-(defmethod row-vector-p ((matrix standard-matrix))
- (= (nrows matrix) 1))
-
-(declaim (inline col-vector-p))
-(defmethod col-vector-p ((matrix standard-matrix))
- (= (ncols matrix) 1))
-
-(declaim (inline row-or-col-vector-p))
-(defmethod row-or-col-vector-p ((matrix standard-matrix))
+ Return T if X is either a row or a column matrix."
(or (row-vector-p matrix) (col-vector-p matrix)))
-(declaim (inline square-matrix-p))
-(defmethod square-matrix-p ((matrix standard-matrix))
- (= (nrows matrix) (ncols matrix)))
+(defun square-matrix-p (matrix)
+ (and (square-p matrix) (matrix-p matrix)))
-(defmethod size ((matrix standard-matrix))
- (list (nrows matrix) (ncols matrix)))
-
-;; For compatibility with Fortran, matrices are stored in column major
-;; order instead of row major order. Also, we store the matrix as a
-;; one-dimensional array instead of a two-dimensional array. This
-;; makes it easy to interface to LAPACK routines.
;;
-;; furthermore, this next macro should really be left as a macro
-;; to avoid integer to pointer coercions, since FORTRAN-MATRIX-INDEXING
-;; will be called too many times.
-
-#+nil
-(defmacro fortran-matrix-indexing (i j l)
- `(let ((i ,i)
- (j ,j)
- (l ,l))
- (declare (optimize (speed 3) (safety 0))
- (type fixnum i j l))
- (let* ((q (* j l))
- (p (+ i q)))
- (declare (type fixnum q p))
- p)))
-
-(declaim (inline fortran-matrix-indexing))
-(defun fortran-matrix-indexing (row col nrows)
- (declare (type (and fixnum (integer 0)) row col nrows))
- (the fixnum (+ row (the fixnum (* col nrows)))))
-
-;; For matrices with complex-valued elements, we store the array as a
-;; double-length double-precision floating-point vector, as Fortran
-;; does too. The first element is the real part; the second, the
-;; imaginary part.
-
-#+nil
-(defmacro fortran-complex-matrix-indexing (i j l)
- `(let ((i ,i)
- (j ,j)
- (l ,l))
- (declare (optimize (speed 3) (safety 0))
- (type fixnum i j l))
- (let* ((q (* j l))
- (p (+ i q))
- (r (* 2 p)))
- (declare (type fixnum q p r))
- r)))
-
-(declaim (inline fortran-complex-matrix-indexing))
-(defun fortran-complex-matrix-indexing (row col nrows)
- (declare (type (and fixnum (integer 0)) row col nrows))
- (the fixnum (* 2 (the fixnum (+ row (the fixnum (* col nrows)))))))
-
-
-
-;;; coerce is broken in CMUCL. Here is a function
-;;; that implements coerce correctly for what we want.
-
-(declaim (inline complex-coerce)
- (ftype (function (number) (complex complex-matrix-element-type))
- complex-coerce))
-
-(defun complex-coerce (val)
- "
- Syntax
- ======
- (COMPLEX-COERCE number)
-
- Purpose
- =======
- Coerce NUMBER to a complex number.
-"
- (declare (type number val))
- (typecase val
- ((complex complex-matrix-element-type) val)
- (complex (complex (coerce (realpart val) 'complex-matrix-element-type)
- (coerce (imagpart val) 'complex-matrix-element-type)))
- (t (complex (coerce val 'complex-matrix-element-type) 0.0d0))))
-
(defgeneric fill-matrix (matrix fill-element)
(:documentation
"
@@ -518,390 +94,43 @@ that way."))
Fill MATRIX with FILL-ELEMENT.
"))
-(defmethod fill-matrix ((matrix real-matrix) (fill cl:real))
- (copy! fill matrix))
-
-(defmethod fill-matrix ((matrix real-matrix) (fill complex))
- (error "cannot fill a real matrix with a complex number,
-don't know how to coerce COMPLEX to REAL"))
-
-(defmethod fill-matrix ((matrix complex-matrix) (fill number))
- (copy! fill matrix))
-
(defmethod fill-matrix ((matrix t) (fill t))
(error "arguments MATRIX and FILL to FILL-MATRIX must be a
matrix and a number"))
-;; Allocate an array suitable for the store part of a real matrix.
-
-(declaim (inline allocate-integer4-store))
-(defun allocate-integer4-store (size &optional (initial-element 0))
- "(ALLOCATE-INTEGER-STORE SIZE [INITIAL-ELEMENT]). Allocates
-integer storage. Default INITIAL-ELEMENT = 0."
- (make-array size
- :element-type 'integer4-matrix-element-type
- :initial-element initial-element))
-
-(declaim (inline allocate-real-store))
-(defun allocate-real-store (size &optional (initial-element 0))
- (make-array size :element-type 'real-matrix-element-type
- :initial-element (coerce initial-element 'real-matrix-element-type)))
-
-(declaim (inline allocate-complex-store))
-(defun allocate-complex-store (size)
- (make-array (* 2 size) :element-type 'complex-matrix-element-type
- :initial-element (coerce 0 'complex-matrix-element-type)))
-
-(defun make-real-matrix-dim (n m &optional (fill 0.0d0))
- "
- Syntax
- ======
- (MAKE-REAL-MATRIX-DIM n m [fill-element])
-
- Purpose
- =======
- Creates an NxM REAL-MATRIX with initial contents FILL-ELEMENT,
- the default 0.0d0
-
- See MAKE-REAL-MATRIX.
-"
- (declare (type fixnum n m))
-
- (let ((casted-fill
- (typecase fill
- (real-matrix-element-type fill)
- (cl:real (coerce fill 'real-matrix-element-type))
- (t (error "argument FILL-ELEMENT to MAKE-REAL-MATRIX-DIM must be a REAL")))))
-
- (declare (type real-matrix-element-type casted-fill))
- (make-instance 'real-matrix :nrows n :ncols m
- :store (allocate-real-store (* n m) casted-fill))))
-
-
-;;; Make a matrix from a 2-D Lisp array
-(defun make-real-matrix-array (array)
- "
- Syntax
- ======
- (MAKE-REAL-MATRIX-ARRAY array)
-
- Purpose
- =======
- Creates a REAL-MATRIX with the same contents as ARRAY.
-"
- (let* ((n (array-dimension array 0))
- (m (array-dimension array 1))
- (size (* n m))
- (store (allocate-real-store size)))
- (declare (type fixnum n m size)
- (type (real-matrix-store-type (*)) store))
- (dotimes (i n)
- (declare (type fixnum i))
- (dotimes (j m)
- (declare (type fixnum j))
- (setf (aref store (fortran-matrix-indexing i j n))
- (coerce (aref array i j) 'real-matrix-element-type))))
- (make-instance 'real-matrix :nrows n :ncols m :store store)))
-
-(defun make-real-matrix-seq-of-seq (seq)
- (let* ((n (length seq))
- (m (length (elt seq 0)))
- (size (* n m))
- (store (allocate-real-store size)))
- (declare (type fixnum n m size)
- (type (real-matrix-store-type (*)) store))
- (dotimes (i n)
- (declare (type fixnum i))
- (let ((this-row (elt seq i)))
- (unless (= (length this-row) m)
- (error "Number of columns is not the same for all rows!"))
- (dotimes (j m)
- (declare (type fixnum j))
- (setf (aref store (fortran-matrix-indexing i j n))
- (coerce (elt this-row j) 'real-matrix-element-type)))))
- (make-instance 'real-matrix :nrows n :ncols m :store store)))
-
-(defun make-real-matrix-seq (seq)
- (let* ((n (length seq))
- (store (allocate-real-store n)))
- (declare (type fixnum n))
- (dotimes (k n)
- (declare (type fixnum k))
- (setf (aref store k) (coerce (elt seq k) 'real-matrix-element-type)))
- (make-instance 'real-matrix :nrows n :ncols 1 :store store)))
-
-(defun make-real-matrix-sequence (seq)
- (cond ((or (listp seq) (vectorp seq))
- (let ((peek (elt seq 0)))
- (cond ((or (listp peek) (vectorp peek))
- ;; We have a seq of seqs
- (make-real-matrix-seq-of-seq seq))
- (t
- ;; Assume a simple sequence
- (make-real-matrix-seq seq)))))
- ((arrayp seq)
- (make-real-matrix-array seq))))
-
-(defun make-real-matrix (&rest args)
- "
- Syntax
- ======
- (MAKE-REAL-MATRIX {arg}*)
-
- Purpose
- =======
- Create a REAL-MATRIX.
-
- Examples
- ========
-
- (make-real-matrix n)
- square NxN matrix
- (make-real-matrix n m)
- NxM matrix
- (make-real-matrix '((1 2 3) (4 5 6)))
- 2x3 matrix:
-
- 1 2 3
- 4 5 6
-
- (make-real-matrix #((1 2 3) (4 5 6)))
- 2x3 matrix:
-
- 1 2 3
- 4 5 6
-
- (make-real-matrix #((1 2 3) #(4 5 6)))
- 2x3 matrix:
-
- 1 2 3
- 4 5 6
-
- (make-real-matrix #2a((1 2 3) (4 5 6)))
- 2x3 matrix:
-
- 1 2 3
- 4 5 6
- (make-real-matrix #(1 2 3 4))
- 4x1 matrix (column vector)
-
- 1
- 2
- 3
- 4
-
- (make-real-matrix #((1 2 3 4))
- 1x4 matrix (row vector)
-
- 1 2 3 4
-"
-
- (let ((nargs (length args)))
- (case nargs
- (1
- (let ((arg (first args)))
- (typecase arg
- (integer
- (assert (not (minusp arg)) nil
- "matrix dimension must be positive, not ~A" arg)
- (make-real-matrix-dim arg arg))
- (sequence
- (make-real-matrix-sequence arg))
- ((array * (* *))
- (make-real-matrix-array arg))
- (t (error "don't know how to make matrix from ~a" arg)))))
- (2
- (destructuring-bind (n m)
- args
- (assert (and (typep n '(integer 0))
- (typep n '(integer 0)))
- nil
- "cannot make a ~A x ~A matrix" n m)
- (make-real-matrix-dim n m)))
- (t
- (error "require 1 or 2 arguments to make a matrix")))))
-
-
-
-(defun make-complex-matrix-dim (n m &optional (fill #c(0.0d0 0.0d0)))
- "
- Syntax
- ======
- (MAKE-COMPLEX-MATRIX-DIM n m [fill-element])
-
- Purpose
- =======
- Creates an NxM COMPLEX-MATRIX with initial contents FILL-ELEMENT,
- the default #c(0.0d0 0.0d0)
-
- See MAKE-COMPLEX-MATRIX.
-"
- (declare (type fixnum n m))
- (let* ((size (* n m))
- (store (allocate-complex-store size))
- (matrix (make-instance 'complex-matrix :nrows n :ncols m :store store)))
-
- (fill-matrix matrix fill)
- matrix))
-
-(defun make-complex-matrix-array (array)
- "
- Syntax
- ======
- (MAKE-COMPLEX-MATRIX-ARRAY array)
-
- Purpose
- =======
- Creates a COMPLEX-MATRIX with the same contents as ARRAY.
-"
- (let* ((n (array-dimension array 0))
- (m (array-dimension array 1))
- (size (* n m))
- (store (allocate-complex-store size)))
- (declare (type fixnum n m size)
- (type (complex-matrix-store-type (*)) store))
- (dotimes (i n)
- (declare (type fixnum i))
- (dotimes (j m)
- (declare (type fixnum j))
- (let* ((val (complex-coerce (aref array i j)))
- (realpart (realpart val))
- (imagpart (imagpart val))
- (index (fortran-complex-matrix-indexing i j n)))
- (declare (type complex-matrix-element-type realpart imagpart)
- (type (complex complex-matrix-element-type) val)
- (type fixnum index))
- (setf (aref store index) realpart)
- (setf (aref store (1+ index)) imagpart))))
-
- (make-instance 'complex-matrix :nrows n :ncols m :store store)))
-
-
-(defun make-complex-matrix-seq-of-seq (seq)
- (let* ((n (length seq))
- (m (length (elt seq 0)))
- (size (* n m))
- (store (allocate-complex-store size)))
- (declare (type fixnum n m size)
- (type (complex-matrix-store-type (*)) store))
-
- (dotimes (i n)
- (declare (type fixnum i))
- (let ((this-row (elt seq i)))
- (unless (= (length this-row) m)
- (error "Number of columns is not the same for all rows!"))
- (dotimes (j m)
- (declare (type fixnum j))
- (let* ((val (complex-coerce (elt this-row j)))
- (realpart (realpart val))
- (imagpart (imagpart val))
- (index (fortran-complex-matrix-indexing i j n)))
- (declare (type complex-matrix-element-type realpart imagpart)
- (type (complex complex-matrix-element-type) val)
- (type fixnum index))
- (setf (aref store index) realpart)
- (setf (aref store (1+ index)) imagpart)))))
-
- (make-instance 'complex-matrix :nrows n :ncols m :store store)))
-
-
-(defun make-complex-matrix-seq (seq)
- (let* ((n (length seq))
- (store (allocate-complex-store n)))
- (declare (type fixnum n)
- (type (complex-matrix-store-type (*)) store))
-
- (dotimes (k n)
- (declare (type fixnum k))
- (let* ((val (complex-coerce (elt seq k)))
- (realpart (realpart val))
- (imagpart (imagpart val))
- (index (* 2 k)))
- (declare (type complex-matrix-element-type realpart imagpart)
- (type (complex complex-matrix-element-type) val)
- (type fixnum index))
- (setf (aref store index) realpart)
- (setf (aref store (1+ index)) imagpart)))
-
- (make-instance 'complex-matrix :nrows n :ncols 1 :store store)))
-
-
-(defun make-complex-matrix-sequence (seq)
- (cond ((or (listp seq) (vectorp seq))
- (let ((peek (elt seq 0)))
- (cond ((or (listp peek) (vectorp peek))
- ;; We have a seq of seqs
- (make-complex-matrix-seq-of-seq seq))
- (t
- ;; Assume a simple sequence
- (make-complex-matrix-seq seq)))))
- ((arrayp seq)
- (make-complex-matrix-array seq))))
-
-
-(defun make-complex-matrix (&rest args)
- "
- Syntax
- ======
- (MAKE-COMPLEX-MATRIX {arg}*)
-
- Purpose
- =======
- Create a FLOAT-MATRIX.
-
- Examples
- ========
-
- (make-complex-matrix n)
- square NxN matrix
- (make-complex-matrix n m)
- NxM matrix
- (make-complex-matrix '((1 2 3) (4 5 6)))
- 2x3 matrix:
+;;
+(defclass real-matrix (standard-matrix real-tensor)
+ ()
+ (:documentation "A class of matrices with real elements."))
- 1 2 3
- 4 5 6
+(defclass real-sub-matrix (real-matrix standard-sub-tensor)
+ ()
+ (:documentation "Sub-matrix class with real elements."))
- (make-complex-matrix #((1 2 3) (4 5 6)))
- 2x3 matrix:
+(setf (gethash 'real-matrix *sub-tensor-counterclass*) 'real-sub-matrix
+ (gethash 'real-sub-matrix *sub-tensor-counterclass*) 'real-sub-matrix
+ ;;
+ (gethash 'real-matrix *tensor-class-optimizations*) 'real-tensor
+ (gethash 'real-sub-matrix *tensor-class-optimizations*) 'real-tensor)
+;;
- 1 2 3
- 4 5 6
+(defclass complex-matrix (standard-matrix complex-tensor)
+ ()
+ (:documentation "A class of matrices with complex elements."))
- (make-complex-matrix #((1 2 3) #(4 5 6)))
- 2x3 matrix:
+(defclass complex-sub-matrix (complex-matrix standard-sub-tensor)
+ ()
+ (:documentation "Sub-matrix class with complex elements."))
- 1 2 3
- 4 5 6
+(setf (gethash 'complex-matrix *sub-tensor-counterclass*) 'complex-sub-matrix
+ (gethash 'complex-sub-matrix *sub-tensor-counterclass*) 'complex-sub-matrix
+ ;;
+ (gethash 'complex-matrix *tensor-class-optimizations*) 'complex-tensor
+ (gethash 'complex-sub-matrix *tensor-class-optimizations*) 'complex-tensor)
- (make-complex-matrix #2a((1 2 3) (4 5 6)))
- 2x3 matrix:
+;;
- 1 2 3
- 4 5 6
+(definline matrix-ref (matrix row &optional col)
+ (declare (type standard-matrix matrix))
+ (tensor-ref matrix `(,row ,col)))
-"
- (let ((nargs (length args)))
- (case nargs
- (1
- (let ((arg (first args)))
- (typecase arg
- (integer
- (assert (not (minusp arg)) nil
- "matrix dimension must be non-negative, not ~A" arg)
- (make-complex-matrix-dim arg arg))
- (sequence
- (make-complex-matrix-sequence arg))
- ((array * (* *))
- (make-complex-matrix-array arg))
- (t (error "don't know how to make matrix from ~a" arg)))))
- (2
- (destructuring-bind (n m)
- args
- (assert (and (typep n '(integer 0))
- (typep n '(integer 0)))
- nil
- "cannot make a ~A x ~A matrix" n m)
- (make-complex-matrix-dim n m)))
- (t
- (error "require 1 or 2 arguments to make a matrix")))))
diff --git a/src/print.lisp b/src/print.lisp
index 6b555a7..c05478b 100644
--- a/src/print.lisp
+++ b/src/print.lisp
@@ -163,8 +163,3 @@ of a matrix (default 0)
(print-unreadable-object (tensor stream :type t)
(format stream "~A~%" (dimensions tensor))
(print-tensor tensor stream)))
-
-(defmethod print-object ((tensor standard-matrix) stream)
- (print-unreadable-object (tensor stream :type t)
- (format stream "~A x ~A~%" (nrows tensor) (ncols tensor))
- (print-tensor tensor stream)))
diff --git a/src/real-tensor.lisp b/src/real-tensor.lisp
index 8016330..c6c252c 100644
--- a/src/real-tensor.lisp
+++ b/src/real-tensor.lisp
@@ -1,14 +1,12 @@
(in-package :matlisp)
-(eval-when (load eval compile)
- (deftype real-type ()
- "The type of the elements stored in a REAL-MATRIX"
- 'double-float)
-
- (deftype real-array (size)
- "The type of the storage structure for a REAL-MATRIX"
- `(simple-array real-type (,size)))
- )
+(deftype real-type ()
+ "The type of the elements stored in a REAL-MATRIX"
+ 'double-float)
+
+(deftype real-array (size)
+ "The type of the storage structure for a REAL-MATRIX"
+ `(simple-array real-type (,size)))
;;
(make-array-allocator allocate-real-store 'real-type 0d0
@@ -64,14 +62,4 @@ Allocates real storage. Default initial-element = 0d0.")
element stream)
(format stream "~11,5,,,,,'Eg" element))
-;;
-
-(defun make-real-tensor-dims (&rest subs)
- (let* ((dims (make-index-store subs))
- (ss (reduce #'* dims))
- (store (allocate-real-store ss)))
- (make-instance 'real-tensor :store store :dimensions dims)))
-#+nil(defun make-real-tensor-array (arr)
- (let* ((dims (array-dimensions arr))
- (ret (apply #'make-real-tensor-dims dims)))))
diff --git a/src/standard-matrix.lisp b/src/standard-matrix.lisp
deleted file mode 100644
index 192a23a..0000000
--- a/src/standard-matrix.lisp
+++ /dev/null
@@ -1,131 +0,0 @@
-(in-package :matlisp)
-
-;;
-(defclass standard-matrix (standard-tensor)
- ((rank
- :accessor rank
- :type index-type
- :initform 2
- :documentation "For a matrix, rank = 2."))
- (:documentation "Basic matrix class."))
-
-(definline nrows (matrix)
- (declare (type standard-matrix matrix))
- (aref (dimensions matrix) 0))
-
-(definline ncols (matrix)
- (declare (type standard-matrix matrix))
- (aref (dimensions matrix) 1))
-
-(definline row-stride (matrix)
- (declare (type standard-matrix matrix))
- (aref (strides matrix) 0))
-
-(definline col-stride (matrix)
- (declare (type standard-matrix matrix))
- (aref (strides matrix) 1))
-
-(definline size (matrix)
- (declare (type standard-matrix matrix))
- (let ((dims (dimensions matrix)))
- (declare (type (index-array 2) dims))
- (list (aref dims 0) (aref dims 1))))
-
-;;
-(defmethod initialize-instance :after ((matrix standard-matrix) &rest initargs)
- (declare (ignore initargs))
- (mlet*
- ((rank (rank matrix) :type index-type))
- (unless (= rank 2)
- (error 'tensor-not-matrix :rank rank :tensor matrix))))
-
-;;
-(definline row-matrix-p (matrix)
- "
- Syntax
- ======
- (ROW-MATRIX-P x)
-
- Purpose
- =======
- Return T if X is a row matrix (number of columns is 1)"
- (tensor-type-p matrix '(1 *)))
-
-(definline col-matrix-p (matrix)
- "
- Syntax
- ======
- (COL-MATRIX-P x)
-
- Purpose
- =======
- Return T if X is a column matrix (number of rows is 1)"
- (tensor-type-p matrix '(* 1)))
-
-(definline row-or-col-matrix-p (matrix)
-"
- Syntax
- ======
- (ROW-OR-COL-matrix-P x)
-
- Purpose
- =======
- Return T if X is either a row or a column matrix."
- (or (row-vector-p matrix) (col-vector-p matrix)))
-
-(defun square-matrix-p (matrix)
- (and (square-p matrix) (matrix-p matrix)))
-
-;;
-(defgeneric fill-matrix (matrix fill-element)
- (:documentation
- "
- Syntax
- ======
- (FILL-MATRIX matrix fill-element)
-
- Purpose
- =======
- Fill MATRIX with FILL-ELEMENT.
-"))
-
-(defmethod fill-matrix ((matrix t) (fill t))
- (error "arguments MATRIX and FILL to FILL-MATRIX must be a
-matrix and a number"))
-
-;;
-(defclass real-matrix (standard-matrix real-tensor)
- ()
- (:documentation "A class of matrices with real elements."))
-
-(defclass real-sub-matrix (real-matrix standard-sub-tensor)
- ()
- (:documentation "Sub-matrix class with real elements."))
-
-(setf (gethash 'real-matrix *sub-tensor-counterclass*) 'real-sub-matrix
- (gethash 'real-sub-matrix *sub-tensor-counterclass*) 'real-sub-matrix
- ;;
- (gethash 'real-matrix *tensor-class-optimizations*) 'real-tensor
- (gethash 'real-sub-matrix *tensor-class-optimizations*) 'real-tensor)
-;;
-
-(defclass complex-matrix (standard-matrix complex-tensor)
- ()
- (:documentation "A class of matrices with complex elements."))
-
-(defclass complex-sub-matrix (complex-matrix standard-sub-tensor)
- ()
- (:documentation "Sub-matrix class with complex elements."))
-
-(setf (gethash 'complex-matrix *sub-tensor-counterclass*) 'complex-sub-matrix
- (gethash 'complex-sub-matrix *sub-tensor-counterclass*) 'complex-sub-matrix
- ;;
- (gethash 'complex-matrix *tensor-class-optimizations*) 'complex-tensor
- (gethash 'complex-sub-matrix *tensor-class-optimizations*) 'complex-tensor)
-
-;;
-
-(definline matrix-ref (matrix row &optional col)
- (declare (type standard-matrix matrix))
- (tensor-ref matrix `(,row ,col)))
-
diff --git a/src/standard-tensor.lisp b/src/standard-tensor.lisp
index a780560..94db9a7 100644
--- a/src/standard-tensor.lisp
+++ b/src/standard-tensor.lisp
@@ -89,6 +89,8 @@
"
Contains a either:
o A property list containing:
+ :store-allocator (n) -> Allocates a store of size n
+ :coercer (ele) -> Coerced to store-type
:element-type
:store-type
:reader (store idx) => result
@@ -101,9 +103,9 @@
(declare (type symbol clname))
(let ((opt (gethash clname *tensor-class-optimizations*)))
(cond
+ ((null opt) nil)
((symbolp opt)
(get-tensor-class-optimization opt))
- ((null opt) nil)
(t (values opt clname)))))
;; Akshay: I have no idea what this does, or why we want it
@@ -471,3 +473,4 @@
(error 'tensor-cannot-find-sub-class :tensor-class (class-of tensor)))
:parent-tensor tensor :store (store tensor) :head nhd
:dimensions (make-index-store ndim) :strides (make-index-store nstd)))))))
+
diff --git a/src/tensor-maker.lisp b/src/tensor-maker.lisp
new file mode 100644
index 0000000..da9fdd8
--- /dev/null
+++ b/src/tensor-maker.lisp
@@ -0,0 +1,48 @@
+(in-package :matlisp)
+
+(defmacro make-tensor-maker (func-name (tensor-class))
+ (let ((opt (get-tensor-class-optimization tensor-class)))
+ (assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
+ `(defun ,func-name (&rest args)
+ (labels ((make-dims (dims)
+ (declare (type cons dims))
+ (let* ((vdim (make-index-store dims))
+ (ss (reduce #'* vdim))
+ (store (,(getf opt :store-allocator) ss)))
+ (make-instance ',tensor-class :store store :dimensions vdim)))
+ (make-from-array (arr)
+ (declare (type (array * *) arr))
+ (let* ((ret (make-dims (array-dimensions arr)))
+ (st-r (store ret)))
+ (declare (type ,tensor-class ret)
+ (type ,(linear-array-type (getf opt :store-type)) st-r))
+ (very-quickly
+ (mod-dotimes (idx (dimensions ret))
+ with (linear-sums
+ (of-r (strides ret) (head ret)))
+ do ,(funcall (getf opt :value-writer) `(,(getf opt :coercer) (apply #'aref arr (idx->list idx))) '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))
+ (very-quickly
+ (list-loop (idx ele lst)
+ with (linear-sums
+ (of-r (strides ret)))
+ do ,(funcall (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/utilities.lisp b/src/utilities.lisp
index fec194e..a35196c 100644
--- a/src/utilities.lisp
+++ b/src/utilities.lisp
@@ -231,6 +231,17 @@
(with-output-to-string (ostr ret)
(apply #'format (append `(,ostr ,fmt) args)))
ret))
+
+(defun list-dimensions (lst)
+ (declare (type list lst))
+ (labels ((lst-tread (idx lst)
+ (if (null lst) (reverse idx)
+ (progn
+ (setf (car idx) (length lst))
+ (if (consp (car lst))
+ (lst-tread (cons 0 idx) (car lst))
+ (reverse idx))))))
+ (lst-tread (list 0) lst)))
;;---------------------------------------------------------------;;
(defstruct (foreign-vector
(:conc-name fv-)
commit 174d27300595c21a466a330fa34ab66fa7131bdf
Author: Akshay Srinivasan <aks...@gm...>
Date: Wed Jul 4 22:19:51 2012 +0530
More changes to README
diff --git a/README.org b/README.org
index 46ed60f..071d4fc 100644
--- a/README.org
+++ b/README.org
@@ -1,20 +1,20 @@
MatLisp - a base for scientific computation in Lisp.
-
This is the development branch of Matlisp.
* Progress Tracker
** What works ?
* Basic {real, complex} tensor structure in place.
- * Added a specialisation agnostic macro which generate...
[truncated message content] |
|
From: Akshay S. <ak...@us...> - 2012-07-04 14:18:51
|
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 d5f7ad309ca59d41c6e405c512f9a3544be01ea2 (commit)
from a005336f729ed3ce87bb327a6fa6441612fa20f9 (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 d5f7ad309ca59d41c6e405c512f9a3544be01ea2
Author: Akshay Srinivasan <aks...@gm...>
Date: Wed Jul 4 19:43:59 2012 +0530
Optimised blas-copyable-p with the permutation sorter.
diff --git a/matlisp.asd b/matlisp.asd
index cbdbae3..5db4d00 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -91,10 +91,10 @@
;;
(:file "loopy"
:depends-on ("standard-tensor"))
- (:file "blas-helpers"
- :depends-on ("standard-tensor"))
(:file "permutation"
:depends-on ("standard-tensor"))
+ (:file "blas-helpers"
+ :depends-on ("standard-tensor" "permutation"))
;;
(:file "real-tensor"
:depends-on ("standard-tensor"))
@@ -115,7 +115,7 @@
:depends-on ("copy" "loopy"))
(:file "realimag"
:depends-on ("real-tensor" "complex-tensor" "copy"))
- ))))
+ ))))
;; (defclass f2cl-cl-source-file (asdf:cl-source-file)
diff --git a/src/blas-helpers.lisp b/src/blas-helpers.lisp
index 3817137..1d7f147 100644
--- a/src/blas-helpers.lisp
+++ b/src/blas-helpers.lisp
@@ -1,100 +1,40 @@
(in-package :matlisp)
-(definline idx-max (seq)
- (declare (type (index-array *) seq))
- (reduce #'max seq))
-
-(definline idx-min (seq)
- (declare (type (index-array *) seq))
- (reduce #'min seq))
-
-(defun idx= (a b)
- (declare (type (index-array *) a b))
- (when (= (length a) (length b))
- (very-quickly
- (loop
- for ele-a across a
- for ele-b across b
- unless (= ele-a ele-b)
- do (return nil)
- finally (return t)))))
-
-(definline idx->list (a)
- (declare (type (index-array *) a))
- (loop for ele across a
- collect ele))
-
(defun blas-copyable-p (ten-a ten-b)
- ;; (declare (type standard-tensor ten-a ten-b))
- ;; (let ((stdi-a (very-quickly
- ;; (sort (apply #'vector
- ;; (loop
- ;; for std across (strides ten-a)
- ;; and dim across (dimensions ten-a)
- ;; collect `(,std ,dim)))
- ;; #'< :key #'first))))
- ;; t))
-
-
- (let ((stdi-list (very-quickly
- (loop
- for ten of-type standard-tensor in tensors
- and pten = nil then ten
- for i of-type index-type = 0 then (1+ i)
- when (> i 0)
- do (unless (idx= (dimensions ten) (dimensions pten))
- (return nil))
- collect (progn
- (assert (typep ten 'standard-tensor) nil
- 'invalid-type :given (type-of ten) :expected 'standard-tensor)
- (very-quickly
- (sort (apply #'vector
- (loop
- for std of-type index-type across (strides ten)
- and dim of-type index-type across (dimensions ten)
- collect `(,std ,dim)))
- #'< :key #'car)))))))
- (if (null stdi-list) (values nil nil)
- (very-quickly
- (loop
- for stdi in stdi-list
- and p-stdi = (first stdi-list) then stdi
- for i of-type index-type = 0 then (1+ i)
- when (> i 0)
- do (unless (loop
- for a-stdi across stdi
- and a-aoff = (first (aref stdi 0)) then (* a-aoff (second a-stdi))
- for b-stdi across p-stdi
- and b-aoff = (first (aref p-stdi 0)) then (* b-aoff (second b-stdi))
- do (unless (and (= (first a-stdi) a-aoff)
- (= (first b-stdi) b-aoff)
- (= (second a-stdi) (second b-stdi)))
- (return nil))
- finally (return t))
- (return (values t nil)))
- finally (return (values t (mapcar #'(lambda (x) (first (aref x 0))) stdi-list))))))))
+ (declare (type standard-tensor ten-a ten-b))
+ (mlet*
+ (((sort-std-a std-a-perm) (idx-sort-permute (copy-seq (strides ten-a)) #'<) :type ((index-array *) permutation))
+ (perm-a-dims (permute (dimensions ten-a) std-a-perm) :type (index-array *))
+ ;;If blas-copyable then the strides must have the same sorting permutation.
+ (sort-std-b (permute (strides ten-b) std-a-perm) :type (index-array *))
+ (perm-b-dims (permute (dimensions ten-b) std-a-perm) :type (index-array *)))
+ (very-quickly
+ (loop
+ for sost-a across sort-std-a
+ for sodi-a across perm-a-dims
+ for a-aoff of-type index-type = (aref sort-std-a 0) then (the index-type (* a-aoff sodi-a))
+ ;;
+ for sost-b across sort-std-b
+ for sodi-b across perm-b-dims
+ for b-aoff of-type index-type = (aref sort-std-b 0) then (the index-type (* b-aoff sodi-b))
+ ;;
+ do (unless (and (= sost-a a-aoff)
+ (= sost-b b-aoff)
+ (= sodi-a sodi-b))
+ (return nil))
+ finally (return (list (aref sort-std-a 0) (aref sort-std-b 0)))))))
(defun consecutive-store-p (tensor)
(declare (type standard-tensor tensor))
- (let ((strides (strides tensor))
- (dims (dimensions tensor)))
- (declare (type (index-array *) strides dims))
- (let* ((stride-dims (very-quickly
- (sort (apply #'vector
- (loop
- for std across strides
- and dim across dims
- collect `(,std ,dim)))
- #'< :key #'car)))
- (stride-min (first (aref stride-dims 0))))
- (declare (type index-type stride-min)
- (type (simple-vector *) stride-dims))
+ (mlet* (((sort-std std-perm) (idx-sort-permute (copy-seq (strides tensor)) #'<) :type ((index-array *) permutation))
+ (perm-dims (permute (dimensions tensor) std-perm) :type (index-array *)))
(very-quickly
(loop
- for st-di across stride-dims
- and accumulated-off = stride-min then (* accumulated-off (second st-di))
- unless (= (first st-di) accumulated-off) do (return nil)
- finally (return stride-min))))))
+ for so-st across sort-std
+ for so-di across perm-dims
+ and accumulated-off = (aref sort-std 0) then (the index-type (* accumulated-off so-di))
+ unless (= so-st accumulated-off) do (return nil)
+ finally (return (aref sort-std 0))))))
;; (defun blas-matrix-compatible-p (matrix &optional (op :n))
diff --git a/src/copy.lisp b/src/copy.lisp
index 95bcaf2..56866f8 100644
--- a/src/copy.lisp
+++ b/src/copy.lisp
@@ -86,23 +86,20 @@
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
`(defun ,func (from to)
(declare (type ,tensor-class from to))
- (multiple-value-bind (dims-p strd-p) (blas-copyable-p from to)
- (unless dims-p
- (error 'tensor-dimension-mismatch))
- (if strd-p
- (,blas-func (number-of-elements from) (store from) (first strd-p) (store to) (second strd-p) (head from) (head to))
- (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 ,(funcall (getf opt :reader-writer) 'f-sto 'f-of 't-sto 't-of))))))
+ (if-let (strd-p (blas-copyable-p from to))
+ (,blas-func (number-of-elements from) (store from) (first strd-p) (store to) (second strd-p) (head from) (head to))
+ (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 ,(funcall (getf opt :reader-writer) 'f-sto 'f-of 't-sto 't-of)))))
to)))
(defmacro generate-typed-num-copy! (func (tensor-class blas-func))
diff --git a/src/permutation.lisp b/src/permutation.lisp
index 40e0af2..d00653e 100644
--- a/src/permutation.lisp
+++ b/src/permutation.lisp
@@ -10,9 +10,35 @@
do (setf (aref ret i) i)))
ret))
+(definline idx-max (seq)
+ (declare (type (index-array *) seq))
+ (reduce #'max seq))
+
+(definline idx-min (seq)
+ (declare (type (index-array *) seq))
+ (reduce #'min seq))
+
+(defun idx= (a b)
+ (declare (type (index-array *) a b))
+ (when (= (length a) (length b))
+ (very-quickly
+ (loop
+ for ele-a across a
+ for ele-b across b
+ unless (= ele-a ele-b)
+ do (return nil)
+ finally (return t)))))
+
+(definline idx->list (a)
+ (declare (type (index-array *) a))
+ (loop for ele across a
+ collect ele))
+
+;;Write a uniform randomiser
(defun seqrnd (seq)
"Randomize the elements of a sequence. Destructive on SEQ."
- (sort seq #'> :key #'(lambda (x) (random 1.0))))
+ (sort seq #'> :key #'(lambda (x) (declare (ignore x))
+ (random 1.0))))
;;Class definitions----------------------------------------------;;
(defclass permutation ()
diff --git a/src/realimag.lisp b/src/realimag.lisp
index 4dbc7c3..1b9a00e 100644
--- a/src/realimag.lisp
+++ b/src/realimag.lisp
@@ -140,4 +140,4 @@
See IMAG, REALPART, IMAGPART
"
- (copy (tensor-imagpart tensor)))
+ (copy (tensor-imagpart~ tensor)))
-----------------------------------------------------------------------
Summary of changes:
matlisp.asd | 6 +-
src/blas-helpers.lisp | 118 ++++++++++++-------------------------------------
src/copy.lisp | 31 ++++++-------
src/permutation.lisp | 28 +++++++++++-
src/realimag.lisp | 2 +-
5 files changed, 74 insertions(+), 111 deletions(-)
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2012-07-04 11:17:54
|
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 a005336f729ed3ce87bb327a6fa6441612fa20f9 (commit)
from d8e8b94a89920c6c741031b0a525fec2c62a9d2d (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 a005336f729ed3ce87bb327a6fa6441612fa20f9
Author: Akshay Srinivasan <aks...@gm...>
Date: Wed Jul 4 16:43:19 2012 +0530
Moved README to an org-file
diff --git a/README.org b/README.org
new file mode 100644
index 0000000..2120bb9
--- /dev/null
+++ b/README.org
@@ -0,0 +1,135 @@
+MatLisp - a base for scientific computation in Lisp
+
+* What is MatLisp?
+
+MatLisp is a set of CLOS classes for handling multidimensional
+arrays with real-valued or complex-valued elements.
+
+However, a implementation of the matrix operations entirely in Lisp
+could have been done, but such an approach completely ignores the
+excellent packages available for matrices. In particular, LAPACK is
+used to handle the matrix operations.
+
+Thus, MatLisp supplies a set of wrapper classes and functions around
+the core LAPACK routines.
+
+
+* Why MatLisp?
+
+While MatLisp essentially supplies a wrapper around the LAPACK
+routines, it is more than that. You have at your disposable the
+complete Lisp language and CLOS.
+
+This allows you to write clean, object-oriented code that can utilize
+the LAPACK matrix routines. Thus, you can think about your problem in
+the natural way instead of trying to force-fit your problem in
+matrices, like some other packages do.
+
+* What About Matlab, Rlab, Octave, etc?
+
+While all of these are good at what they do, they all have a
+fundamental limitation: Everything is a matrix. You have no
+alternative. Either you make your problem fit into a matrix, or you
+can't use these languages. The exception is Rlab, which does have
+simple lists in addition to matrices. However, that's as far as it goes.
+
+MatLisp frees you from this limitation---you have at your disposal,
+the complete functionality of Common Lisp, including structures, hash
+tables, lists, arrays, and the Common Lisp Object System (CLOS).
+MatLisp adds to this richness by giving you a matrix fast class based
+on the well-known and well-tested LAPACK library.
+
+Thus, you can think about your problem in the most natura
+l way,
+without having to force everything into a matrix. If the natural way,
+you can then use a matrix, and achieve performance close to Matlab and
+the other languages.
+
+
+* How to Install
+
+See the file INSTALL.
+
+* Usage
+
+This is very short. Here is a list of available routines
+
+make-float-matrix
+ create a float matrix
+ (make-float-matrix n m)
+ creates an n x m matrix initialize to zero.
+ (make-float-matrix #2a(...))
+ creates a matrix with the same dimensions as the array and
+ initializes the matrix with those elements.
+ (make-float-matrix '((...) (...) ...))
+ creats a matrix of the appropriate dimensions and initializes
+ it to the elements in the list.
+
+make-complex-matrix
+ create a complex matrix
+ (make-complex-matrix n m)
+ creates an n x m matrix initialize to zero.
+ (make-complex-matrix #2a(...))
+ creates a matrix with the same dimensions as the array and
+ initializes the matrix with those elements.
+ (make-complex-matrix '((...) (...) ...))
+ creats a matrix of the appropriate dimensions and initializes
+ it to the elements in the list.
+
+
+[]
+ create a float or complex matrix
+ [1 2 ; 3 4]
+ creates a 2x2 matrix
+ [[1 3]' [2 4]']
+ creates the same 2x2 matrix
+ [[1 2] ; [3 4]]
+ creates the same 2x2 matrix
+
+matrix-ref
+ access the elements of the matrix. Indices are 0-based.
+ (matrix-ref mat r)
+ access the array as if it were really 1-dimensional. Matrix
+ is stored in column-major order.
+ (matrix-ref mat r c)
+ access element r,c
+ (matrix-ref mat ridx)
+ if ridx is a matrix or a sequence, ridx is used as the indices
+ to extract the corresponding elements from the matrix.
+
+m+
+ add two matrices
+
+m-
+ subtract two matrices. If only one matrix is given, return
+ the negative of the matrix.
+
+m*
+ multiply two matrices
+
+m/
+ divide two matrices. (m/ a b) means the same as inv(B)*A.
+ (m/ a) is the same as inv(A).
+
+
+* TODO
+** Python-bridge
+ (C)Python has far too many things, that we cannot even begin to hope to replicate.
+ Burgled-batteries has a lot of things which could be useful in talking to CPython.
+
+ Getting standard-tensor <-> numpy tranlation should be enough. Mostly care about
+ matplotlib at the moment.
+
+** Add infix to Matlisp
+ Added Mark Kantrowicz' infix package into lib-src. Should be straight forward to use it,
+ although changes are not strictly local.
+
+** Support linking to libraries ?
+ Might have to parse header files with cffi-grovel.
+
+** Documentation, tests
+ Write documentation.
+ Fix the formatting for docstrings. Maybe move to TeXinfo (like femlisp).
+
+** Write tests
+ Use cl-rt stuff to write more tests. Probably even add benchmarks.
-----------------------------------------------------------------------
Summary of changes:
README.old => README.org | 50 ++++++++++++++++++++++++++++++---------------
1 files changed, 33 insertions(+), 17 deletions(-)
copy README.old => README.org (74%)
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2012-07-04 11:10:35
|
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 d8e8b94a89920c6c741031b0a525fec2c62a9d2d (commit)
via 3727a088ffe014773472fd37a7d45346917a73a0 (commit)
from 695636685fd91ce1602b135d0c0e782ca06d47e7 (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 d8e8b94a89920c6c741031b0a525fec2c62a9d2d
Author: Akshay Srinivasan <aks...@gm...>
Date: Wed Jul 4 16:36:01 2012 +0530
Cleaned up permutation.lisp
diff --git a/matlisp.asd b/matlisp.asd
index e300c13..cbdbae3 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -93,6 +93,8 @@
:depends-on ("standard-tensor"))
(:file "blas-helpers"
:depends-on ("standard-tensor"))
+ (:file "permutation"
+ :depends-on ("standard-tensor"))
;;
(:file "real-tensor"
:depends-on ("standard-tensor"))
diff --git a/src/conditions.lisp b/src/conditions.lisp
index ad16f1e..27986e0 100644
--- a/src/conditions.lisp
+++ b/src/conditions.lisp
@@ -13,78 +13,86 @@
(in-package :matlisp)
-;;---------------------------------------------------------------;;
-(define-condition generic-error (error)
- ((message :reader message :initarg :message :initform "")))
-
-(defmethod print-object ((c generic-error) stream)
- (format stream (message c)))
-
-;;---------------------------------------------------------------;;
-(define-condition invalid-type (generic-error)
+(defmacro defcondition (name (&rest parent-types) (&rest slot-specs) &body options)
+ "Like define-condition except that you can define
+ methods inside the condition definition with:
+ (:method {generic-function-name} {args*} &rest code*)
+"
+ (labels ((get-methods (opts mth rst)
+ (if (null opts) (values (reverse mth) (reverse rst))
+ (if (and (consp (car opts)) (eq (caar opts) :method))
+ (get-methods (cdr opts) (cons (car opts) mth) rst)
+ (get-methods (cdr opts) mth (cons (car opts) rst))))))
+ (multiple-value-bind (methods rest) (get-methods options nil nil)
+ `(progn
+ (define-condition ,name ,parent-types
+ ,slot-specs
+ ,@rest)
+ ,@(loop for mth in methods
+ collect `(defmethod ,@(cdr mth)))))))
+;;Generic conditions---------------------------------------------;;
+(defcondition generic-error (error)
+ ((message :reader message :initarg :message :initform ""))
+ (:method print-method ((c generic-error) stream)
+ (format stream (message c))))
+
+(defcondition invalid-type (generic-error)
((given-type :reader given :initarg :given)
(expected-type :reader expected :initarg :expected))
- (:documentation "Given an unexpected type."))
-
-(defmethod print-object ((c invalid-type) stream)
- (format stream "Given object of type ~A, expected ~A.~%" (given c) (expected c))
- (call-next-method))
+ (:documentation "Given an unexpected type.")
+ (:method print-object ((c invalid-type) stream)
+ (format stream "Given object of type ~A, expected ~A.~%" (given c) (expected c))
+ (call-next-method)))
-;;---------------------------------------------------------------;;
-(define-condition invalid-value (generic-error)
+(defcondition invalid-value (generic-error)
((given-value :reader given :initarg :given)
(expected-value :reader expected :initarg :expected))
- (:documentation "Given an unexpected value."))
+ (:documentation "Given an unexpected value.")
+ (:method print-object ((c invalid-value) stream)
+ (format stream "Given object ~A, expected ~A.~%" (given c) (expected c))
+ (call-next-method)))
-(defmethod print-object ((c invalid-value) stream)
- (format stream "Given object ~A, expected ~A.~%" (given c) (expected c))
- (call-next-method))
-
-;;---------------------------------------------------------------;;
-(define-condition unknown-token (generic-error)
+(defcondition unknown-token (generic-error)
((token :reader token :initarg :token))
- (:documentation "Given an unknown token."))
-
-(defmethod print-object ((c unknown-token) stream)
- (format stream "Given unknown token: ~A.~%" (token c))
- (call-next-method))
+ (:documentation "Given an unknown token.")
+ (:method print-object ((c unknown-token) stream)
+ (format stream "Given unknown token: ~A.~%" (token c))
+ (call-next-method)))
-;;---------------------------------------------------------------;;
-(define-condition coercion-error (generic-error)
+(defcondition coercion-error (generic-error)
((from :reader from :initarg :from)
(to :reader to :initarg :to))
- (:documentation "Cannot coerce one type into another."))
-
-(defmethod print-object ((c coercion-error) stream)
- (format stream "Cannot coerce ~a into ~a." (from c) (to c))
- (call-next-method))
+ (:documentation "Cannot coerce one type into another.")
+ (:method print-object ((c coercion-error) stream)
+ (format stream "Cannot coerce ~a into ~a." (from c) (to c))
+ (call-next-method)))
-;;---------------------------------------------------------------;;
-(define-condition matlisp-error (error)
+;;Tensor conditions----------------------------------------------;;
+(define-condition tensor-error (error)
;;Optional argument for error-handling.
((tensor :reader tensor :initarg :tensor)))
-(define-condition store-index-out-of-bounds (matlisp-error)
+(define-condition tensor-store-index-out-of-bounds (tensor-error)
((index :reader index :initarg :index)
(store-size :reader store-size :initarg :store-size))
(:documentation "An out of bounds index error for the one-dimensional store.")
(:report (lambda (c stream)
(format stream "Requested index ~A, but store is only of size ~A." (index c) (store-size c)))))
-(define-condition tensor-not-matrix (matlisp-error)
- ((tensor-rank :reader rank :initarg :rank))
- (:documentation "Given tensor is not a matrix.")
- (:report (lambda (c stream)
- (format stream "Given tensor with rank ~A, is not a matrix." (rank c)))))
-
-(define-condition insufficient-store (matlisp-error)
+(define-condition tensor-insufficient-store (tensor-error)
((store-size :reader store-size :initarg :store-size)
(max-idx :reader max-idx :initarg :max-idx))
(:documentation "Store is too small for the tensor with given dimensions.")
(:report (lambda (c stream)
(format stream "Store size is ~A, but maximum possible index is ~A." (store-size c) (max-idx c)))))
-(define-condition tensor-index-out-of-bounds (matlisp-error)
+(define-condition tensor-not-matrix (tensor-error)
+ ((tensor-rank :reader rank :initarg :rank))
+ (:documentation "Given tensor is not a matrix.")
+ (:report (lambda (c stream)
+ (format stream "Given tensor with rank ~A, is not a matrix." (rank c)))))
+
+(define-condition tensor-index-out-of-bounds (tensor-error)
((argument :reader argument :initarg :argument)
(index :reader index :initarg :index)
(argument-space-dimension :reader dimension :initarg :dimension))
@@ -92,48 +100,68 @@
(:report (lambda (c stream)
(format stream "~&Out of bounds for argument ~A: requested ~A, but dimension is only ~A." (argument c) (index c) (dimension c)))))
-(define-condition tensor-index-rank-mismatch (matlisp-error)
+(define-condition tensor-index-rank-mismatch (tensor-error)
((index-rank :reader index-rank :initarg :index-rank)
(rank :reader rank :initarg :rank))
(:documentation "Incorrect number of subscripts for the tensor.")
(:report (lambda (c stream)
(format stream "Index is of size ~A, whereas the tensor is of rank ~A." (index-rank c) (rank c)))))
-(define-condition tensor-invalid-head-value (matlisp-error)
+(define-condition tensor-invalid-head-value (tensor-error)
((head :reader head :initarg :head))
(:documentation "Incorrect value for the head of the tensor storage.")
(:report (lambda (c stream)
(format stream "Head of the store must be >= 0, initialized with ~A." (head c)))))
-(define-condition tensor-invalid-dimension-value (matlisp-error)
+(define-condition tensor-invalid-dimension-value (tensor-error)
((argument :reader argument :initarg :argument)
(argument-dimension :reader dimension :initarg :dimension))
(:documentation "Incorrect value for one of the dimensions of the tensor.")
(:report (lambda (c stream)
(format stream "Dimension of argument ~A must be > 0, initialized with ~A." (argument c) (dimension c)))))
-(define-condition tensor-invalid-stride-value (matlisp-error)
+(define-condition tensor-invalid-stride-value (tensor-error)
((argument :reader argument :initarg :argument)
(argument-stride :reader stride :initarg :stride))
(:documentation "Incorrect value for one of the strides of the tensor storage.")
(:report (lambda (c stream)
(format stream "Stride of argument ~A must be >= 0, initialized with ~A." (argument c) (stride c)))))
-(define-condition tensor-cannot-find-sub-class (matlisp-error)
+(define-condition tensor-cannot-find-sub-class (tensor-error)
((tensor-class :reader tensor-class :initarg :tensor-class))
(:documentation "Cannot find sub-class of the given tensor class")
(:report (lambda (c stream)
(format stream "Cannot find sub-class of the given tensor class: ~a." (tensor-class c)))))
-(define-condition tensor-cannot-find-optimization (matlisp-error)
+(define-condition tensor-cannot-find-optimization (tensor-error)
((tensor-class :reader tensor-class :initarg :tensor-class))
(:documentation "Cannot find optimization information for the given tensor class")
(:report (lambda (c stream)
(format stream "Cannot find optimization information for the given tensor class: ~a." (tensor-class c)))))
-(define-condition tensor-dimension-mismatch (matlisp-error)
+(define-condition tensor-dimension-mismatch (tensor-error)
()
(:documentation "The dimensions of the given tensors are not suitable for continuing with the operation.")
(:report (lambda (c stream)
(declare (ignore c))
(format stream "The dimensions of the given tensors are not suitable for continuing with the operation."))))
+
+;;Permutation conditions-----------------------------------------;;
+(define-condition permutation-error (error)
+ ((permutation :reader permutation :initarg :permutation)))
+
+(define-condition permutation-invalid-error (permutation-error)
+ ()
+ (:documentation "Object is not a permutation.")
+ (:report (lambda (c stream)
+ (declare (ignore c))
+ (format stream "Object is not a permutation."))))
+
+(define-condition permutation-permute-error (permutation-error)
+ ((sequence-length :reader seq-len :initarg :seq-len)
+ (group-rank :reader group-rank :initarg :group-rank))
+ (:documentation "Cannot permute sequence.")
+ (:report (lambda (c stream)
+ (format stream "Cannot permute sequence.
+sequence-length : ~a
+group-rank: ~a" (seq-len c) (group-rank c)))))
diff --git a/src/loopy-tests.lisp b/src/loopy-tests.lisp
index fbaafe0..8998588 100644
--- a/src/loopy-tests.lisp
+++ b/src/loopy-tests.lisp
@@ -44,7 +44,7 @@
do (setf (aref st-a of-a) (random 1d0)
(aref st-b of-b) (random 1d0)
(aref st-c of-c) 0d0)))
- (time
+ (time
(very-quickly
(mod-dotimes (idx (idxv n n n))
with (loop-order :row-major)
@@ -52,7 +52,7 @@
(of-a (idxv n 1 0))
(of-b (idxv 0 n 1))
(of-c (idxv n 0 1)))
- do (incf (aref st-c of-c) (* (aref st-a of-a) (aref st-b of-b)))))))))
+ do (incf (aref st-c of-c) (* (aref st-a of-a) (aref st-b of-b)))))))))
(defun test-mm-ddot (n)
(let* ((t-a (make-real-tensor-dims n n))
diff --git a/src/permutation.lisp b/src/permutation.lisp
new file mode 100644
index 0000000..40e0af2
--- /dev/null
+++ b/src/permutation.lisp
@@ -0,0 +1,317 @@
+(in-package :matlisp)
+
+(defun id-action-repr (n)
+ (declare (type fixnum n))
+ (let ((ret (allocate-index-store n)))
+ (declare (type (index-array *) ret))
+ (very-quickly
+ (loop
+ for i of-type index-type from 0 below n
+ do (setf (aref ret i) i)))
+ ret))
+
+(defun seqrnd (seq)
+ "Randomize the elements of a sequence. Destructive on SEQ."
+ (sort seq #'> :key #'(lambda (x) (random 1.0))))
+
+;;Class definitions----------------------------------------------;;
+(defclass permutation ()
+ ((representation :accessor repr
+ :initarg :repr)
+ (group-rank :accessor group-rank
+ :type index-type)))
+
+(defparameter +permutation-identity+
+ (let ((ret (make-instance 'permutation :repr :id)))
+ (setf (group-rank ret) 0)
+ ret))
+
+(defmethod print-object ((per permutation) stream)
+ (print-unreadable-object (per stream :type t)
+ (format stream "S_~a~%~a~%" (group-rank per) (repr per))))
+;;
+(defclass permutation-cycle (permutation)
+ ((representation :type cons)))
+
+(defun cycle-repr-p (perm)
+ "
+ Does a sorting operation to check for duplicate elements in
+ the cycle representation of a permutation.
+"
+ (if (not (typep perm '(index-array *))) nil
+ (locally
+ (declare (type (index-array *) perm))
+ (let ((len (length perm)))
+ (declare (type index-type len))
+ (if (<= len 1) nil
+ (let ((sort (very-quickly (sort (copy-seq perm) #'<))))
+ (declare (type (index-array *) sort))
+ (very-quickly
+ (loop for i of-type index-type from 1 below len
+ when (= (aref sort i) (aref sort (1- i)))
+ do (return nil)
+ finally (return t)))))))))
+
+(defmethod initialize-instance :after ((per permutation-cycle) &rest initargs)
+ (declare (ignore initargs))
+ (very-quickly
+ (loop
+ for cyc of-type (index-array *) in (repr per)
+ unless (cycle-repr-p cyc)
+ do (error 'permutation-invalid-error)
+ maximizing (idx-max cyc) into g-rnk of-type index-type
+ finally (setf (group-rank per) (the index-type (1+ g-rnk))))))
+
+(definline make-pcycle (&rest args)
+ (make-instance 'permutation-cycle :repr args))
+
+;;
+(defclass permutation-action (permutation)
+ ((representation :type (index-array *))))
+
+(defun action-repr-p (act)
+ "
+ Checks if ARR is a possible permutation vector. A permutation pi
+ is characterized by a vector containing the indices from 0,...,
+ @function{length}(@arg{perm})-1 in some order.
+"
+ (if (not (typep act '(index-array *))) nil
+ (locally
+ (declare (type (index-array *) act))
+ (let* ((len (length act))
+ (sort (very-quickly (sort (copy-seq act) #'<))))
+ (declare (type (index-array *) sort)
+ (type index-type len))
+ (very-quickly
+ (loop for i of-type index-type from 0 below len
+ unless (= (aref sort i) i)
+ do (return nil)
+ finally (return t)))))))
+
+(defmethod initialize-instance :after ((per permutation-action) &rest initargs)
+ (declare (ignore initargs))
+ (let ((act (repr per)))
+ (declare (type (index-array *) act))
+ (unless (action-repr-p act)
+ (error 'permutation-invalid-error))
+ (setf (group-rank per) (1+ (idx-max act)))))
+
+(definline make-paction (pact)
+ (make-instance 'permutation-action :repr pact))
+
+;;Conversions and validation-------------------------------------;;
+(defun action->cycle (act)
+ "
+ (action->cycle act)
+
+ This function obtains the canonical cycle representation
+ of a permutation. The first argument \"act\" is the action of the
+ permutation on the array #(0 1 2 3 ..): an object of the class
+ permutation-action.
+
+ \"Canonical\" may be a bit of an overstatement; this is the way
+ S_n was presented in Van der Waerden's book.
+"
+ (declare (type permutation-action act))
+ (mlet*
+ ((arr (repr act) :type (index-array *)))
+ (labels ((find-cycle (x0)
+ ;; This function obtains the cycle starting from x_0.
+ (declare (type index-type x0))
+ (if (= (aref arr x0) x0) (values 0 nil)
+ (very-quickly
+ (loop
+ for x of-type index-type = (aref arr x0) then (aref arr x)
+ and ret of-type cons = (list x0) then (cons x ret)
+ counting t into i of-type index-type
+ when (= x x0)
+ do (return (values i ret))))))
+ (cycle-walk (cyc ignore)
+ ;; Finds all cycles
+ (let ((x0 (find-if-not #'(lambda (x) (member x ignore)) arr)))
+ (if (null x0)
+ cyc
+ (multiple-value-bind (clen clst) (find-cycle x0)
+ (declare (type index-type clen)
+ (type list clst))
+ (cycle-walk
+ (if (= clen 0) cyc
+ (cons (make-array clen :element-type 'index-type :initial-contents clst) cyc))
+ (nconc ignore (if (= clen 0) (list x0) clst))))))))
+ (let ((cyc-lst (cycle-walk nil nil)))
+ (if (null cyc-lst)
+ +permutation-identity+
+ (make-instance 'permutation-cycle
+ :repr cyc-lst))))))
+
+(defun cycle->action (cyc)
+ "
+ (cycle->action cyc)
+
+ This function obtains the action representation of a permutation
+ from the cyclic one. The first argument \"cyc\" is the cyclic
+ representation of the permutation: an object of the class
+ permutation-cycle.
+"
+ (declare (type permutation-cycle cyc))
+ (let ((act-repr (id-action-repr (group-rank cyc)))
+ (cycs-repr (repr cyc)))
+ (declare (type (index-array *) act-repr))
+ (dolist (cyc cycs-repr)
+ (declare (type (index-array *) cyc))
+ (let ((xl (aref act-repr (aref cyc (1- (length cyc))))))
+ (very-quickly
+ (loop
+ for i of-type index-type downfrom (1- (length cyc)) to 0
+ do (setf (aref act-repr (aref cyc i))
+ (if (= i 0) xl
+ (aref act-repr (aref cyc (1- i)))))))))
+ (make-instance 'permutation-action :repr act-repr)))
+
+;;
+(defgeneric permute! (seq perm)
+ (:documentation "
+ (permute! seq perm)
+
+ Applies the permutation on the sequence.
+")
+ (:method ((seq sequence) (perm (eql +permutation-identity+)))
+ seq))
+
+(defmethod permute! ((seq sequence) (perm permutation-cycle))
+ (labels ((apply-cycle! (seq pcyc)
+ (declare (type (index-array *) pcyc))
+ (very-quickly
+ (let ((xl (aref seq (aref pcyc (1- (length pcyc))))))
+ (loop for i of-type index-type downfrom (1- (length pcyc)) to 0
+ do (setf (aref seq (aref pcyc i))
+ (if (= i 0) xl
+ (aref seq (aref pcyc (1- i))))))))))
+ (let ((len (length seq))
+ (glen (group-rank perm))
+ (cycs-lst (repr perm)))
+ (declare (type index-type len glen))
+ (if (< len glen) (error 'permutation-permute-error :seq-len len :group-rank glen)
+ (etypecase seq
+ (vector
+ (dolist (cyc cycs-lst seq)
+ (declare (type (index-array *) cyc))
+ (apply-cycle! seq cyc)))
+ (cons
+ (let ((cseq (make-array len :initial-contents seq)))
+ (declare (type (simple-vector *) cseq))
+ (dolist (cyc cycs-lst)
+ (declare (type (index-array *) cyc))
+ (apply-cycle! cseq cyc))
+ (mapl
+ (let ((i 0))
+ (declare (type fixnum i))
+ (lambda (x)
+ (when (< i glen)
+ (rplaca x (aref cseq i))
+ (incf i))))
+ seq))))))))
+
+(defmethod permute! ((seq sequence) (perm permutation-action))
+ (let ((len (length seq))
+ (glen (group-rank perm)))
+ (declare (type index-type len glen))
+ (if (< len glen) (error 'permutation-permute-error :seq-len len :group-rank glen)
+ (let ((cseq (make-array len :initial-contents seq))
+ (act (repr perm)))
+ (declare (type (simple-vector *) cseq)
+ (type (index-array *) act))
+ (etypecase seq
+ (vector
+ (very-quickly
+ (loop
+ for i of-type index-type from 0 below glen
+ do (unless (= i (aref act i))
+ (setf (aref seq i) (aref cseq (aref act i))))
+ finally (return seq))))
+ (cons
+ (mapl
+ (let ((i 0))
+ (declare (type fixnum i))
+ (lambda (x)
+ (when (< i glen)
+ (rplaca x (aref cseq (aref act i)))
+ (incf i))))
+ seq)))))))
+
+(defun permute (seq perm)
+ (declare (type sequence seq)
+ (type permutation perm))
+ (let ((cseq (copy-seq seq)))
+ (permute! cseq perm)))
+;;
+#+nil
+(defun permute-argument (func-symbol perm)
+ (declare (type symbol func-symbol)
+ (type permutation perm))
+ (let* ((glen (group-rank perm))
+ (args (loop for i from 0 below glen
+ collect (gensym))))
+ (eval `(lambda (,@args &rest rest)
+ (apply ',func-symbol (append (list ,@(permute! args perm)) rest))))))
+
+(defun argument-permute (func perm)
+ (declare (type function func)
+ (type permutation perm))
+ (lambda (&rest args)
+ (apply func (permute! args perm))))
+
+(defun curry (func perm &rest curried-args)
+ (declare (type function func)
+ (type permutation perm))
+ (lambda (&rest args)
+ (apply func (permute! (append curried-args args) perm))))
+
+(defun compose (func-a func-b perm)
+ (declare (type function func-a func-b)
+ (type permutation perm))
+ (lambda (&rest args)
+ (apply func-a (permute! (multiple-value-list (funcall func-b args)) perm))))
+;;
+
+(defun idx-sort-permute (seq predicate)
+ "
+ (sort-permute seq predicate)
+
+ Sorts a index-array and also returns
+ the permutation-action required to move
+ from the given sequence to the sorted form.
+
+ Takes about 10x the running time which can be
+ achieved with cl:sort.
+ "
+ (declare (type (index-array *) seq)
+ (type function predicate))
+ (let* ((len (length seq))
+ (perm (id-action-repr len)))
+ (declare (type index-type len)
+ (type (index-array *) perm))
+ (labels ((qsort-bounds (lb ub)
+ (declare (type index-type lb ub))
+ #+nil(format t "~a lb:~a ub:~a ~%" seq lb ub)
+ (if (= ub (1+ lb)) t
+ (let* ((ele (aref seq lb))
+ (ele-idx (very-quickly
+ (loop
+ for i of-type index-type from (1+ lb) below ub
+ with ele-idx of-type index-type = lb
+ do (unless (funcall predicate ele (aref seq i))
+ (when (> i (1+ ele-idx))
+ (rotatef (aref seq ele-idx) (aref seq (1+ ele-idx)))
+ (rotatef (aref perm ele-idx) (aref perm (1+ ele-idx))))
+ (rotatef (aref seq ele-idx) (aref seq i))
+ (rotatef (aref perm ele-idx) (aref perm i))
+ (incf ele-idx)
+ #+nil(format t " ~a ~%" seq))
+ finally (return ele-idx)))))
+ (when (> (- ub ele-idx) 2)
+ (qsort-bounds (1+ ele-idx) ub))
+ (when (> (- ele-idx lb) 1)
+ (qsort-bounds lb ele-idx))))))
+ (qsort-bounds 0 len)
+ (values seq (action->cycle (make-paction perm))))))
diff --git a/src/permutations.lisp b/src/permutations.lisp
deleted file mode 100644
index c68d97d..0000000
--- a/src/permutations.lisp
+++ /dev/null
@@ -1,230 +0,0 @@
-(in-package :matlisp)
-
-(define-condition permutation-error (generic-error)
- ((message :reader message :initform "Object is not a permutation."))
- (:documentation "Object is not a permutation."))
-
-;;Class definitions----------------------------------------------;;
-(defclass permutation ()
- ((representation :accessor repr
- :initarg :repr)
- (group-rank :accessor group-rank
- :type index-type)))
-;;
-(defclass permutation-cycle (permutation)
- ((representation :type cons)))
-
-(defmethod initialize-instance :after ((per permutation-cycle) &rest initargs)
- (declare (ignore initargs))
- (let ((cls 0))
- (declare (type index-type cls))
- (unless (very-quickly
- (dolist (cyc (r-value per) t)
- (unless (cycle-p cyc)
- (return nil))
- (setf cls (max cls (idx-max cyc)))))
- (error 'permutation-error))
- (setf (group-rank per) (the index-type (1+ cls)))))
-;;
-(defclass permutation-action (permutation)
- ((representation :type (index-array *))))
-
-(defmethod initialize-instance :after ((per permutation-action) &rest initargs)
- (declare (ignore initargs))
- (let ((act (r-value per)))
- (declare (type (index-array *) act))
- (unless (action-p act)
- (error 'permutation-error))
- (setf (group-rank per) (idx-max act))))
-
-;;Conversions and validation-------------------------------------;;
-(defun insert-element (x sort l-b u-b)
- "Does a binary-esque sort to keep track of elements in
- a permutation, in descending order. If there are duplicates
- of X in sort between L-B and U-B (both inclusive), or if X < 0,
- then throws a PERMUTATION-ERROR."
- (declare (type index-type x l-b u-b)
- (type (index-array *) sort))
- (let* ((len u-b))
- (labels ((insert-ele (l-b u-b)
- (declare (type index-type l-b u-b))
- (let* ((midx (+ l-b (floor (- u-b l-b) 2)))
- (mid (aref sort midx)))
- (declare (type index-type midx mid))
- (cond
- ((or (< x 0) (member x `(,(aref sort u-b) ,(aref sort l-b) ,mid)))
- (error 'permutation-error))
- ((= midx l-b)
- (when (> x (aref sort u-b))
- (very-quickly
- (loop
- with sidx of-type index-type = (+ midx (if (> x mid) 0 1))
- for i of-type index-type downfrom (1- len) to sidx
- do (setf (aref sort (+ i 1)) (aref sort i))
- finally (setf (aref sort sidx) x)))))
- ((< x mid) (insert-ele midx u-b))
- ((> x mid) (insert-ele l-b midx)))
- sort)))
- (insert-ele l-b u-b))))
-
-(defun cycle-new-p (perm)
- "Does a sorting operation to check for duplicate elements in
- the cycle representation of a permutation."
- (declare (type (index-array *) perm))
- (let* ((len (length perm))
- (sort (very-quickly (sort (copy-seq perm) #'<))))
- (declare (type (index-array *) sort)
- (type index-type len))
- (very-quickly
- (loop for i of-type index-type from 1 below len
- when (= (aref sort i) (aref sort (1- i)))
- do (return nil)
- finally (return t)))))
-
-(defun action-p (act)
- "Checks if ARR is a possible permutation vector. A permutation pi
- is characterized by a vector containing the indices from 0,...,
- @function{length}(@arg{perm})-1 in some order."
- (declare (type (index-array *) act))
- (let* ((len (length act))
- (sort (very-quickly (sort (copy-seq act) #'<))))
- (declare (type (index-array *) sort)
- (type index-type len))
- (very-quickly
- (loop for i of-type index-type from 0 below len
- unless (= (aref sort i) i)
- do (return nil)
- finally (return t)))))
-
-(defun action->cycle (act)
- ;;Caution: will go into an infinite loop if object is not proper.
- "
- This function obtains the canonical cycle representation
- of a permutation. The first argument is the action of the
- permutation on the array #(0 1 2 3 ..).
- \"Canonical\" may be a bit of an overstatement; this is the way
- S_n was presented by Van der Waerden.
-"
- (declare (type permutation-action per))
- (mlet*
- ((arr (r-value per) :type (index-array *)))
- (labels ((find-cycle (arr x0)
- "This function obtains a permutation cycle starting from x_0.
- The first argument is the action of the permutation on the
- array #(0 1 2 ..)"
- (declare (type (index-array *) arr)
- (type index-type x0))
- (if (= (aref arr x0) x0) (values #() nil)
- (destructuring-bind (n lst)
- (do ((i 0 (+ i 1))
- (x x0 (aref arr x))
- (ret nil (cons x ret))
- (count 0 (+ count (if (= x x0) 1 0))))
- ((and (= count 1) (= x x0)) (list i ret)))
- (values (make-array n :element-type 'index-type :initial-contents lst) lst))))
- (cycle-walk (cyc ignore)
- (declare (optimize (speed 3) (safety 0)))
- (let ((x0 (find-if-not #'(lambda (x) (member x ignore)) arr)))
- (if (null x0) cyc
- (multiple-value-bind (cnew clst) (find-cycle arr x0)
- (cycle-walk (if (null clst) cyc (cons cnew cyc))
- (nconc ignore (if (null clst) (list x0) clst))))))))
- (cycle-walk nil nil))))
-;;---------------------------------------------------------------;;
-
-
-(defun cycles->action (cyc)
- )
-
-;;
-(defun apply-cycle! (seq cyc)
- (declare (type (index-array *) cyc)
- (type (vector * *) seq))
- (unless (cycle-p cyc)
- (error 'permutation-error))
- (when (> (length cyc) 1)
- (let ((xl (aref seq (aref cyc (- (length cyc) 1)))))
- (loop for i downfrom (- (length cyc) 1) to 0
- do (setf (aref seq (aref cyc i))
- (if (= i 0) xl
- (aref seq (aref cyc (- i 1))))))))
- seq)
-
-(defun permute! (seq cycs)
- (unless (or (null cycs) (= (length seq) 0))
- (dolist (cyc cycs)
- (apply-cycle! seq cyc)))
- seq)
-
-(defun arg-perm (func cycs)
- (if (null cycs)
- func
- (lambda (&rest args)
- (let ((argvec (permute! (apply #'vector args) cycs)))
- (apply func (loop for i from 0 below (length argvec)
- collect (aref argvec i)))))))
-
-(defun compose (func func)
-
-;; (defun compose (..)
-;; )
-
-(defun seqrnd (seq)
- "Randomize the elements of a sequence. Destructive on SEQ."
- (sort seq #'> :key #'(lambda (x) (random 1.0))))
-
-;;
-
-(defun allocate-unit-permutation (n)
- (declare (type fixnum n))
- (let ((ret (allocate-index-store n)))
- (declare (type (index-array *) ret))
- (very-quickly
- (loop
- for i of-type index-type from 0 below n
- do (setf (aref ret i) i)))
- ret))
-
-(defun sort-permute (seq predicate)
- "
- (sort-permute seq predicate)
-
- Sorts a index-array and also returns
- the permutation-action required to move
- from the given sequence to the sorted form.
-
- Takes about 10x the running time which can be
- achieved with cl:sort.
- "
- (declare (type (index-array *) seq)
- (type function predicate))
- (let* ((len (length seq))
- (perm (allocate-unit-permutation len)))
- (declare (type index-type len)
- (type (index-array *) perm))
- (labels ((qsort-bounds (lb ub)
- (declare (type index-type lb ub))
- #+nil(format t "~a lb:~a ub:~a ~%" seq lb ub)
- (if (= ub (1+ lb)) t
- (let* ((ele (aref seq lb))
- (ele-idx (very-quickly
- (loop
- for i of-type index-type from (1+ lb) below ub
- with ele-idx of-type index-type = lb
- do (unless (funcall predicate ele (aref seq i))
- (when (> i (1+ ele-idx))
- (rotatef (aref seq ele-idx) (aref seq (1+ ele-idx)))
- (rotatef (aref perm ele-idx) (aref perm (1+ ele-idx))))
- (rotatef (aref seq ele-idx) (aref seq i))
- (rotatef (aref perm ele-idx) (aref perm i))
- (incf ele-idx)
- #+nil(format t " ~a ~%" seq))
- finally (return ele-idx)))))
- (when (> (- ub ele-idx) 2)
- (qsort-bounds (1+ ele-idx) ub))
- (when (> (- ele-idx lb) 1)
- (qsort-bounds lb ele-idx))))))
- (qsort-bounds 0 len)
- (values seq perm))))
-
-(quicksort-with-action (idxv 10 9 8 7 6 5 4 3 2 1) #'<)
diff --git a/src/standard-tensor.lisp b/src/standard-tensor.lisp
index 905fe8e..a780560 100644
--- a/src/standard-tensor.lisp
+++ b/src/standard-tensor.lisp
@@ -147,7 +147,7 @@
(incf sto-idx (the index-type (* (aref strides i) cidx)))
(error 'tensor-index-out-of-bounds :argument i :index cidx :dimension (aref dims i)))
finally (return sto-idx))))))
-x
+
(defun store-indexing-lst (idx hd strides dims)
"
Syntax
@@ -232,7 +232,7 @@ x
;;Error checking is good if we use foreign-pointers as store types.
(cond
((< hd 0) (error 'tensor-invalid-head-value :head hd :tensor tensor))
- ((<= ss L-idx) (error 'insufficient-store :store-size ss :max-idx L-idx :tensor tensor)))
+ ((<= ss L-idx) (error 'tensor-insufficient-store :store-size ss :max-idx L-idx :tensor tensor)))
;;
;;--*TODO: Add checks to see if there is index-collision.*--
;; This is a hard (NP ?) search problem
@@ -258,13 +258,13 @@ x
(:method :before ((tensor standard-tensor) idx)
(declare (type index-type idx))
(unless (< -1 idx (store-size tensor))
- (error 'store-index-out-of-bounds :index idx :store-size (store-size tensor) :tensor tensor))))
+ (error 'tensor-store-index-out-of-bounds :index idx :store-size (store-size tensor) :tensor tensor))))
(defgeneric (setf tensor-store-ref) (value tensor idx)
(:method :before (value (tensor standard-tensor) idx)
(declare (type index-type idx))
(unless (< -1 idx (store-size tensor))
- (error 'store-index-out-of-bounds :index idx :store-size (store-size tensor) :tensor tensor))))
+ (error 'tensor-store-index-out-of-bounds :index idx :store-size (store-size tensor) :tensor tensor))))
(defmacro tensor-store-defs ((tensor-class element-type store-element-type) &key store-allocator coercer reader value-writer reader-writer)
(let ((tensym (gensym "tensor")))
diff --git a/src/utilities.lisp b/src/utilities.lisp
index 63fef05..fec194e 100644
--- a/src/utilities.lisp
+++ b/src/utilities.lisp
@@ -90,19 +90,17 @@
(nconc ,var ,@(cdr args)))
(nconc ,var ,@args))))
-(defun pop-arg! (sym arglist)
+(defun pop-arg! (arglist sym)
(check-type sym symbol)
- (locally
- (declare (optimize (speed 3) (safety 0)))
- (labels ((get-sym (sym arglist prev)
- (cond
- ((null arglist) nil)
- ((eq (car arglist) sym) (prog1
+ (labels ((get-sym (sym arglist prev)
+ (cond
+ ((null arglist) nil)
+ ((eq (car arglist) sym) (prog1
(cadr arglist)
- (if prev
- (rplacd prev (cddr arglist)))))
- (t (get-sym sym (cdr arglist) arglist)))))
- (get-sym sym arglist nil))))
+ (if prev
+ (rplacd prev (cddr arglist)))))
+ (t (get-sym sym (cdr arglist) arglist)))))
+ (get-sym sym arglist nil)))
(defun slot-values (obj slots)
(values-list (mapcar #'(lambda (slt) (slot-value obj slt))
@@ -138,7 +136,7 @@
(defmacro if-let ((var . form) &rest body)
(check-type var symbol)
- `(let ((,var ,@form))
+ `(let ((,var ,@form))
(if ,var
,@body)))
commit 3727a088ffe014773472fd37a7d45346917a73a0
Author: Akshay Srinivasan <aks...@gm...>
Date: Mon Jul 2 12:56:22 2012 +0530
Added loopy-test into the repo.
diff --git a/TODO b/TODO
deleted file mode 100644
index 8be2f0a..0000000
--- a/TODO
+++ /dev/null
@@ -1,8 +0,0 @@
-* Write documentation. Maybe move to TeXinfo (like femlisp).
- Fix the formatting for docstrings.
-* Write tests
-* Get the python-bridge working with burgled-batteries, nothing beats
- matplotlib for plotting.
-* Add infix to Matlisp
-* Support linking to libraries ? Might have to parse function declarations
- with cffi-grovel.
\ No newline at end of file
diff --git a/src/loopy-tests.lisp b/src/loopy-tests.lisp
new file mode 100644
index 0000000..fbaafe0
--- /dev/null
+++ b/src/loopy-tests.lisp
@@ -0,0 +1,83 @@
+
+(defun tdcopy (n)
+ (let* ((t-a (make-real-tensor-dims n n n))
+ (st-a (store t-a))
+ (t-b (make-real-tensor-dims n n n))
+ (st-b (store t-b)))
+ (with-optimization (:speed 3 :safety 0 :space 0)
+ (mod-dotimes (idx (idxv n n))
+ with (linear-sums
+ (of (idxv (* n n) n)))
+ do (dcopy n st-a 1 st-b 1 of of)))))
+
+(defun tcopy (n)
+ (let* ((t-a (make-real-tensor-dims n n n))
+ (t-b (make-real-tensor-dims n n n)))
+ (time (real-tensor-copy t-a t-b))))
+
+(defun modidx (n dims)
+ (declare (optimize (speed 3) (safety 0))
+ (type index-type n)
+ (type cons dims))
+ (multiple-value-bind (div rem) (let ((div (car dims)))
+ (declare (type index-type div))
+ (floor n div))
+ (declare (ignore div))
+ (if (null (cdr dims)) t
+ (modidx rem (cdr dims)))))
+
+(defun test-mm-lisp (n)
+ (let ((t-a (make-real-tensor-dims n n))
+ (t-b (make-real-tensor-dims n n))
+ (t-c (make-real-tensor-dims n n)))
+ (declare (type real-tensor t-a t-b t-c))
+ (let ((st-a (store t-a))
+ (st-b (store t-b))
+ (st-c (store t-c)))
+ (declare (type (real-array *) st-a st-b st-c))
+ (very-quickly
+ (mod-dotimes (idx (dimensions t-a))
+ with (linear-sums
+ (of-a (strides t-a))
+ (of-b (strides t-b))
+ (of-c (strides t-c)))
+ do (setf (aref st-a of-a) (random 1d0)
+ (aref st-b of-b) (random 1d0)
+ (aref st-c of-c) 0d0)))
+ (time
+ (very-quickly
+ (mod-dotimes (idx (idxv n n n))
+ with (loop-order :row-major)
+ with (linear-sums
+ (of-a (idxv n 1 0))
+ (of-b (idxv 0 n 1))
+ (of-c (idxv n 0 1)))
+ do (incf (aref st-c of-c) (* (aref st-a of-a) (aref st-b of-b)))))))))
+
+(defun test-mm-ddot (n)
+ (let* ((t-a (make-real-tensor-dims n n))
+ (t-b (make-real-tensor-dims n n))
+ (t-c (make-real-tensor-dims n n))
+ (st-a (store t-a))
+ (st-b (store t-b))
+ (st-c (store t-c)))
+ (declare (type real-tensor t-a t-b t-c)
+ (type (real-array *) st-a st-b st-c))
+ (mod-dotimes (idx (dimensions t-a))
+ with (linear-sums
+ (of-a (strides t-a))
+ (of-b (strides t-b))
+ (of-c (strides t-c)))
+ do (setf (aref st-a of-a) (random 1d0)
+ (aref st-b of-b) (random 1d0)
+ (aref st-c of-c) 0d0))
+ (time
+ (very-quickly
+ (mod-dotimes (idx (idxv n n))
+ with (loop-order :row-major)
+ with (linear-sums
+ (of-a (idxv n 0))
+ (of-b (idxv 0 1))
+ (of-c (idxv n 1)))
+ do (setf (aref st-c of-c)
+ (ddot n st-a 1 st-b n of-a of-b)))))))
-----------------------------------------------------------------------
Summary of changes:
TODO | 8 -
matlisp.asd | 2 +
src/conditions.lisp | 134 ++++++++++++--------
src/loopy-tests.lisp | 83 ++++++++++++
src/permutation.lisp | 317 ++++++++++++++++++++++++++++++++++++++++++++++
src/permutations.lisp | 230 ---------------------------------
src/standard-tensor.lisp | 8 +-
src/utilities.lisp | 22 ++--
8 files changed, 497 insertions(+), 307 deletions(-)
delete mode 100644 TODO
create mode 100644 src/loopy-tests.lisp
create mode 100644 src/permutation.lisp
delete mode 100644 src/permutations.lisp
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2012-06-30 19:05:56
|
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 695636685fd91ce1602b135d0c0e782ca06d47e7 (commit)
via adf78b01d61996d75fda7ce045e3f3f11aa3f9ed (commit)
from 1231d97cfa4e89109805a7a5284d939bbd65f5f9 (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 695636685fd91ce1602b135d0c0e782ca06d47e7
Author: Akshay Srinivasan <aks...@gm...>
Date: Sat Jun 30 23:35:35 2012 +0530
o Optimised mod-dotimes (finally!).
A 1000x1000 matrix multiplication is now a mere 2 times slower than fully optimized(-Ofast) C code
using incremental index-offsets (like mod-dotimes), but about 5 times slower than naive-3-loops in
Fortran. OpenBLAS is still much much faster. This more than justifies jumping from Python to Lisp
(as if the language itself was not enough!).
Timings
=======
SBCL: 12.5 s
C: 6.0 s
Fortran: 2.5 s
OpenBLAS: 0.3 s
o realimag, copy and scal are now in a usable form.
o Tweaks to permutations. Added sort-permute function.
diff --git a/README b/README.old
similarity index 100%
rename from README
rename to README.old
diff --git a/matlisp.asd b/matlisp.asd
index 787e4ca..e300c13 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -85,23 +85,35 @@
:depends-on ("foreign-interface"
"foreign-functions")
:components ((:file "conditions")
- (:file "standard-tensor")
+ ;;
+ (:file "standard-tensor"
+ :depends-on ("conditions"))
+ ;;
(:file "loopy"
:depends-on ("standard-tensor"))
(:file "blas-helpers"
:depends-on ("standard-tensor"))
+ ;;
(:file "real-tensor"
:depends-on ("standard-tensor"))
(:file "complex-tensor"
:depends-on ("standard-tensor"))
(:file "standard-matrix"
- :depends-on ("standard-tensor"))
+ :depends-on ("standard-tensor" "real-tensor" "complex-tensor"))
;; (:file "real-matrix"
;; :depends-on ("standard-matrix"))
;; (:file "complex-matrix"
;; :depends-on ("standard-matrix"))
(:file "print"
- :depends-on ("standard-tensor" "standard-matrix"))))))
+ :depends-on ("standard-tensor" "standard-matrix"))
+ ;;Copy, Scal
+ (:file "copy"
+ :depends-on ("real-tensor" "complex-tensor" "loopy"))
+ (:file "scal"
+ :depends-on ("copy" "loopy"))
+ (:file "realimag"
+ :depends-on ("real-tensor" "complex-tensor" "copy"))
+ ))))
;; (defclass f2cl-cl-source-file (asdf:cl-source-file)
diff --git a/src/blas-helpers.lisp b/src/blas-helpers.lisp
index 10dc90b..3817137 100644
--- a/src/blas-helpers.lisp
+++ b/src/blas-helpers.lisp
@@ -1,9 +1,11 @@
(in-package :matlisp)
(definline idx-max (seq)
+ (declare (type (index-array *) seq))
(reduce #'max seq))
(definline idx-min (seq)
+ (declare (type (index-array *) seq))
(reduce #'min seq))
(defun idx= (a b)
@@ -22,12 +24,23 @@
(loop for ele across a
collect ele))
-(defun blas-copyable-p (&rest tensors)
- (let ((stdi-list (very-quickly
+(defun blas-copyable-p (ten-a ten-b)
+ ;; (declare (type standard-tensor ten-a ten-b))
+ ;; (let ((stdi-a (very-quickly
+ ;; (sort (apply #'vector
+ ;; (loop
+ ;; for std across (strides ten-a)
+ ;; and dim across (dimensions ten-a)
+ ;; collect `(,std ,dim)))
+ ;; #'< :key #'first))))
+ ;; t))
+
+
+ (let ((stdi-list (very-quickly
(loop
- for ten in tensors
+ for ten of-type standard-tensor in tensors
and pten = nil then ten
- for i = 0 then (1+ i)
+ for i of-type index-type = 0 then (1+ i)
when (> i 0)
do (unless (idx= (dimensions ten) (dimensions pten))
(return nil))
@@ -37,8 +50,8 @@
(very-quickly
(sort (apply #'vector
(loop
- for std across (strides ten)
- and dim across (dimensions ten)
+ for std of-type index-type across (strides ten)
+ and dim of-type index-type across (dimensions ten)
collect `(,std ,dim)))
#'< :key #'car)))))))
(if (null stdi-list) (values nil nil)
@@ -46,7 +59,7 @@
(loop
for stdi in stdi-list
and p-stdi = (first stdi-list) then stdi
- for i = 0 then (1+ i)
+ for i of-type index-type = 0 then (1+ i)
when (> i 0)
do (unless (loop
for a-stdi across stdi
diff --git a/src/copy.lisp b/src/copy.lisp
index e620330..95bcaf2 100644
--- a/src/copy.lisp
+++ b/src/copy.lisp
@@ -143,6 +143,7 @@
(generate-typed-copy! complex-typed-copy! (complex-tensor zcopy))
(generate-typed-num-copy! complex-typed-num-copy! (complex-tensor zcopy))
;;---------------------------------------------------------------;;
+
(defgeneric copy! (from-tensor to-tensor)
(:documentation
"
@@ -182,18 +183,27 @@
(defmethod copy! ((x number) (y real-tensor))
(real-typed-num-copy! (coerce-real x) y))
-(defmethod copy! ((x complex-matrix) (y complex-tensor))
+(defmethod copy! ((x complex-tensor) (y complex-tensor))
(complex-typed-copy! x y))
-(defmethod copy! ((x real-matrix) (y complex-tensor))
- (real-double-copy!-typed x (mrealpart~ y))
- (scal! 0d0 (mimagpart~ y))
+(defmethod copy! ((x real-tensor) (y complex-tensor))
+ ;;Borrowed from realimag.lisp
+ (let ((tmp (make-instance 'real-sub-tensor
+ :parent-tensor y :store (store y)
+ :dimensions (dimensions y)
+ :strides (map '(index-array *) #'(lambda (n) (* 2 n)) (strides y))
+ :head (the index-type (* 2 (head y))))))
+ (declare (type real-sub-tensor tmp))
+ (real-typed-copy! x tmp)
+ ;;Increasing the head by 1 points us to the imaginary part.
+ (incf (head tmp))
+ (real-typed-num-copy! 0d0 tmp))
y)
(defmethod copy! ((x number) (y complex-tensor))
(complex-typed-num-copy! (coerce-complex x) y))
-;;;;
+;;
(defgeneric copy (tensor)
(:documentation
"
@@ -206,16 +216,12 @@
Return a copy of the tensor X"))
(defmethod copy ((tensor real-tensor))
- (let* ((ret (apply #'make-real-tensor-dims
- (loop for dim across (dimensions tensor)
- collect dim))))
+ (let* ((ret (apply #'make-real-tensor-dims (idx->list (dimensions tensor)))))
(declare (type real-tensor ret))
(copy! tensor ret)))
(defmethod copy ((tensor complex-tensor))
- (let* ((ret (apply #'make-complex-tensor-dims
- (loop for dim across (dimensions tensor)
- collect dim))))
+ (let* ((ret (apply #'make-complex-tensor-dims (idx->list (dimensions tensor)))))
(declare (type complex-tensor ret))
(copy! tensor ret)))
diff --git a/src/loopy.lisp b/src/loopy.lisp
index 9b27ad1..32037bc 100644
--- a/src/loopy.lisp
+++ b/src/loopy.lisp
@@ -76,18 +76,19 @@
(t (error 'unknown-token :token (car code) :message "Error in macro: mod-dotimes -> parse-with.~%")))))
(multiple-value-bind (code sdecl) (parse-code body nil)
(with-gensyms (dims-sym rank-sym count-sym)
- `(let* ((,dims-sym ,dims)
- (,rank-sym (length ,dims-sym))
- (,idx (allocate-index-store ,rank-sym))
- ,@(mapcar #'(lambda (x) `(,(getf x :stride-sym) ,(getf x :stride-expr))) (getf sdecl :linear-sums))
- ,@(mapcar #'(lambda (x) `(,(getf x :variable) ,(getf x :init))) (getf sdecl :variables)))
- ,@(let ((decl `(,@(when (getf sdecl :linear-sums)
- `((type (index-array *) ,@(mapcar #'(lambda (x) (getf x :stride-sym)) (getf sdecl :linear-sums)))))
- ,@(loop for x in (getf sdecl :variables)
+ `(let ((,dims-sym ,dims))
+ (declare (type (index-array *) ,dims-sym))
+ (let ((,rank-sym (length ,dims-sym)))
+ (declare (type index-type ,rank-sym))
+ (let ((,idx (allocate-index-store ,rank-sym))
+ ,@(mapcar #'(lambda (x) `(,(getf x :stride-sym) ,(getf x :stride-expr))) (getf sdecl :linear-sums))
+ ,@(mapcar #'(lambda (x) `(,(getf x :variable) ,(getf x :init))) (getf sdecl :variables)))
+ (declare (type (index-array *) ,idx)
+ ,@(when (getf sdecl :linear-sums)
+ `((type (index-array *) ,@(mapcar #'(lambda (x) (getf x :stride-sym)) (getf sdecl :linear-sums)))))
+ ,@(loop for x in (getf sdecl :variables)
unless (null (getf x :type))
- collect `(type ,(getf x :type) ,(getf x :variable))))))
- (unless (null decl)
- `((declare ,@decl))))
+ collect `(type ,(getf x :type) ,(getf x :variable))))
(loop ,@(loop for decl in (getf sdecl :linear-sums)
append `(with ,(getf decl :offset-sym) of-type index-type = ,(getf decl :offset-init)))
,@(unless (null code)
@@ -107,7 +108,7 @@
`(let ((,cstrd (aref ,(getf decl :stride-sym) ,count-sym)))
(declare (type index-type ,cstrd))
(unless (= ,cstrd 0)
- (decf ,(getf decl :offset-sym) (* ,cstrd (1- (aref ,dims-sym ,count-sym)))))))))
+ (decf ,(getf decl :offset-sym) (the index-type (* ,cstrd (1- (aref ,dims-sym ,count-sym))))))))))
(progn
(incf (aref ,idx ,count-sym))
,@(loop
@@ -118,4 +119,4 @@
(unless (= ,cstrd 0)
(incf ,(getf decl :offset-sym) ,cstrd)))))
(return t)))
- finally (return nil))))))))))
+ finally (return nil))))))))))))
diff --git a/src/permutations.lisp b/src/permutations.lisp
index 797e198..c68d97d 100644
--- a/src/permutations.lisp
+++ b/src/permutations.lisp
@@ -4,7 +4,40 @@
((message :reader message :initform "Object is not a permutation."))
(:documentation "Object is not a permutation."))
-;;---------------------------------------------------------------;;
+;;Class definitions----------------------------------------------;;
+(defclass permutation ()
+ ((representation :accessor repr
+ :initarg :repr)
+ (group-rank :accessor group-rank
+ :type index-type)))
+;;
+(defclass permutation-cycle (permutation)
+ ((representation :type cons)))
+
+(defmethod initialize-instance :after ((per permutation-cycle) &rest initargs)
+ (declare (ignore initargs))
+ (let ((cls 0))
+ (declare (type index-type cls))
+ (unless (very-quickly
+ (dolist (cyc (r-value per) t)
+ (unless (cycle-p cyc)
+ (return nil))
+ (setf cls (max cls (idx-max cyc)))))
+ (error 'permutation-error))
+ (setf (group-rank per) (the index-type (1+ cls)))))
+;;
+(defclass permutation-action (permutation)
+ ((representation :type (index-array *))))
+
+(defmethod initialize-instance :after ((per permutation-action) &rest initargs)
+ (declare (ignore initargs))
+ (let ((act (r-value per)))
+ (declare (type (index-array *) act))
+ (unless (action-p act)
+ (error 'permutation-error))
+ (setf (group-rank per) (idx-max act))))
+
+;;Conversions and validation-------------------------------------;;
(defun insert-element (x sort l-b u-b)
"Does a binary-esque sort to keep track of elements in
a permutation, in descending order. If there are duplicates
@@ -17,47 +50,61 @@
(declare (type index-type l-b u-b))
(let* ((midx (+ l-b (floor (- u-b l-b) 2)))
(mid (aref sort midx)))
+ (declare (type index-type midx mid))
(cond
((or (< x 0) (member x `(,(aref sort u-b) ,(aref sort l-b) ,mid)))
(error 'permutation-error))
((= midx l-b)
(when (> x (aref sort u-b))
- (loop
- with sidx = (+ midx (if (> x mid) 0 1))
- for i downfrom (- len 1) to sidx
- do (setf (aref sort (+ i 1)) (aref sort i))
- finally (setf (aref sort sidx) x))))
+ (very-quickly
+ (loop
+ with sidx of-type index-type = (+ midx (if (> x mid) 0 1))
+ for i of-type index-type downfrom (1- len) to sidx
+ do (setf (aref sort (+ i 1)) (aref sort i))
+ finally (setf (aref sort sidx) x)))))
((< x mid) (insert-ele midx u-b))
((> x mid) (insert-ele l-b midx)))
sort)))
(insert-ele l-b u-b))))
-(defun cycle-p (perm)
+(defun cycle-new-p (perm)
"Does a sorting operation to check for duplicate elements in
the cycle representation of a permutation."
+ (declare (type (index-array *) perm))
(let* ((len (length perm))
- (sort (allocate-index-store len -1)))
- (dotimes (i len t)
- (handler-case (insert-element (aref perm i) sort 0 i)
- (permutation-error () (return nil))))))
-
-(defun action-p (arr)
+ (sort (very-quickly (sort (copy-seq perm) #'<))))
+ (declare (type (index-array *) sort)
+ (type index-type len))
+ (very-quickly
+ (loop for i of-type index-type from 1 below len
+ when (= (aref sort i) (aref sort (1- i)))
+ do (return nil)
+ finally (return t)))))
+
+(defun action-p (act)
"Checks if ARR is a possible permutation vector. A permutation pi
is characterized by a vector containing the indices from 0,...,
@function{length}(@arg{perm})-1 in some order."
- (declare (type (index-array *) arr))
- (let ((s-arr (sort (copy-seq arr) #'<)))
- (dotimes (i (length s-arr) t)
- (unless (= i (aref s-arr i))
- (return nil)))))
-
-(defun action->cycle (per)
+ (declare (type (index-array *) act))
+ (let* ((len (length act))
+ (sort (very-quickly (sort (copy-seq act) #'<))))
+ (declare (type (index-array *) sort)
+ (type index-type len))
+ (very-quickly
+ (loop for i of-type index-type from 0 below len
+ unless (= (aref sort i) i)
+ do (return nil)
+ finally (return t)))))
+
+(defun action->cycle (act)
;;Caution: will go into an infinite loop if object is not proper.
- "This function obtains the canonical cycle representation
+ "
+ This function obtains the canonical cycle representation
of a permutation. The first argument is the action of the
permutation on the array #(0 1 2 3 ..).
\"Canonical\" may be a bit of an overstatement; this is the way
- S_n was presented by Van der Waerden."
+ S_n was presented by Van der Waerden.
+"
(declare (type permutation-action per))
(mlet*
((arr (r-value per) :type (index-array *)))
@@ -85,37 +132,9 @@
(cycle-walk nil nil))))
;;---------------------------------------------------------------;;
-(defclass permutation ()
- ((representation :accessor r-value
- :initarg :r-value)
- (group-rank :accessor group-rank
- :type index-type)))
-
-(defclass permutation-cycle (permutation)
- ((representation :type cons)))
-
-(defmethod initialize-instance :after ((per permutation-cycle) &rest initargs)
- (declare (ignore initargs))
- (let ((cls 0))
- (unless (dolist (cyc (r-value per) t)
- (unless (cycle-p cyc)
- (return nil))
- (setf cls (max cls (reduce #'max cyc))))
- (error 'permutation-error))
- (setf (group-rank per) (1+ cls))))
-
-(defclass permutation-action (permutation)
- ((:representation :type (index-array *))))
-
-(defmethod initialize-instance :after ((per permutation-action) &rest initargs)
- (declare (ignore initargs))
- (unless (action-p (r-value per))
- (error 'permutation-error)))
(defun cycles->action (cyc)
)
-
-
;;
(defun apply-cycle! (seq cyc)
@@ -152,4 +171,60 @@
(defun seqrnd (seq)
"Randomize the elements of a sequence. Destructive on SEQ."
- (sort seq #'> :key #'(lambda (x) (random 1.0))))
\ No newline at end of file
+ (sort seq #'> :key #'(lambda (x) (random 1.0))))
+
+;;
+
+(defun allocate-unit-permutation (n)
+ (declare (type fixnum n))
+ (let ((ret (allocate-index-store n)))
+ (declare (type (index-array *) ret))
+ (very-quickly
+ (loop
+ for i of-type index-type from 0 below n
+ do (setf (aref ret i) i)))
+ ret))
+
+(defun sort-permute (seq predicate)
+ "
+ (sort-permute seq predicate)
+
+ Sorts a index-array and also returns
+ the permutation-action required to move
+ from the given sequence to the sorted form.
+
+ Takes about 10x the running time which can be
+ achieved with cl:sort.
+ "
+ (declare (type (index-array *) seq)
+ (type function predicate))
+ (let* ((len (length seq))
+ (perm (allocate-unit-permutation len)))
+ (declare (type index-type len)
+ (type (index-array *) perm))
+ (labels ((qsort-bounds (lb ub)
+ (declare (type index-type lb ub))
+ #+nil(format t "~a lb:~a ub:~a ~%" seq lb ub)
+ (if (= ub (1+ lb)) t
+ (let* ((ele (aref seq lb))
+ (ele-idx (very-quickly
+ (loop
+ for i of-type index-type from (1+ lb) below ub
+ with ele-idx of-type index-type = lb
+ do (unless (funcall predicate ele (aref seq i))
+ (when (> i (1+ ele-idx))
+ (rotatef (aref seq ele-idx) (aref seq (1+ ele-idx)))
+ (rotatef (aref perm ele-idx) (aref perm (1+ ele-idx))))
+ (rotatef (aref seq ele-idx) (aref seq i))
+ (rotatef (aref perm ele-idx) (aref perm i))
+ (incf ele-idx)
+ #+nil(format t " ~a ~%" seq))
+ finally (return ele-idx)))))
+ (when (> (- ub ele-idx) 2)
+ (qsort-bounds (1+ ele-idx) ub))
+ (when (> (- ele-idx lb) 1)
+ (qsort-bounds lb ele-idx))))))
+ (qsort-bounds 0 len)
+ (values seq perm))))
+
+(quicksort-with-action (idxv 10 9 8 7 6 5 4 3 2 1) #'<)
diff --git a/src/realimag.lisp b/src/realimag.lisp
index 015ae12..4dbc7c3 100644
--- a/src/realimag.lisp
+++ b/src/realimag.lisp
@@ -84,7 +84,7 @@
(complex-tensor (make-instance 'real-sub-tensor
:parent-tensor tensor :store (store tensor)
:dimensions (dimensions tensor)
- :strides (map '(index-array *) #'(lambda (x) (* 2 x)) (strides xten))
+ :strides (map '(index-array *) #'(lambda (x) (* 2 x)) (strides tensor))
:head (the index-type (* 2 (head tensor)))))
(number (realpart tensor))))
@@ -106,38 +106,31 @@
(complex-tensor (make-instance 'real-sub-tensor
:parent-tensor tensor :store (store tensor)
:dimensions (dimensions tensor)
- :strides (map '(index-array *) #'(lambda (x) (* 2 x)) (strides xten))
+ :strides (map '(index-array *) #'(lambda (x) (* 2 x)) (strides tensor))
:head (the index-type (+ 1 (* 2 (head tensor))))))
(number (imagpart tensor))))
-(defun tensor-realpart (mat)
+(definline tensor-realpart (tensor)
"
Syntax
======
- (MREALPART matrix)
+ (tensor-realpart tensor)
Purpose
=======
- Returns a copy of the real part of \"matrix\".
+ Returns a copy of the real part of tensor.
- If \"matrix\" is a scalar, returns its real part.
+ If \"tensor\" is a scalar, returns its real part.
See IMAG, REALPART, IMAGPART
"
- (typecase mat
- (real-matrix (copy mat))
- (complex-matrix (copy (make-instance 'sub-real-matrix
- :parent mat :store (store mat)
- :nrows (nrows mat) :ncols (ncols mat)
- :row-stride (* 2 (row-stride mat)) :col-stride (* 2 (col-stride mat))
- :head (* 2 (head mat)))))
- (number (cl:realpart mat))))
+ (copy (tensor-realpart~ tensor)))
-(defun tensor-imagpart (mat)
+(definline tensor-imagpart (tensor)
"
Syntax
======
- (MIMAGPART~ matrix)
+ (tensor-imagpart matrix)
Purpose
=======
@@ -147,45 +140,4 @@
See IMAG, REALPART, IMAGPART
"
-
- (typecase mat
- (real-matrix (make-real-matrix-dim (nrows mat) (ncols mat)))
- (complex-matrix (copy (make-instance 'sub-real-matrix
- :parent mat :store (store mat)
- :nrows (nrows mat) :ncols (ncols mat)
- :row-stride (* 2 (row-stride mat)) :col-stride (* 2 (col-stride mat))
- :head (+ 1 (* 2 (head mat))))))
- (number (cl:imagpart mat))))
-
-
-(declaim (inline real))
-(defun real (matrix)
-"
- Syntax
- ======
- (REAL matrix)
-
- Purpose
- =======
- Returns a new REAL-MATRIX which is the real part of MATRIX.
- If MATRIX is a scalar, returns its real part.
-
- See IMAG, REALPART, IMAGPART
-"
- (mrealpart matrix))
-
-
-(defun imag (matrix)
-"
- Syntax
- ======
- (IMAG matrix)
-
- Purpose
- =======
- Returns a new REAL-MATRIX which is the imaginary part of MATRIX.
- If MATRIX is a scalar, returns its imaginary part.
-
- See REAL, REALPART, IMAGPART
-"
- (mimagpart matrix))
+ (copy (tensor-imagpart tensor)))
diff --git a/src/scal.lisp b/src/scal.lisp
index 15c6ea6..134d168 100644
--- a/src/scal.lisp
+++ b/src/scal.lisp
@@ -75,22 +75,17 @@
`(defun ,func (alpha to)
(declare (type ,tensor-class to)
(type ,(getf opt :element-type) alpha))
- (let ((t-dims (dimensions to))
- (t-stds (strides to))
- (t-sto (store to))
- (t-hd (head to)))
- (declare (type (index-array *) t-dims t-stds)
- (type index-type t-hd)
- (type ,(linear-array-type (getf opt :store-type)) t-sto))
- (if-let (min-stride (consecutive-store-p t-stds t-dims))
- (,blas-func (number-of-elements to) alpha t-sto min-stride t-hd)
+ (if-let (min-stride (consecutive-store-p to))
+ (,blas-func (number-of-elements to) alpha (store to) min-stride (head to))
+ (let ((t-sto (store to)))
+ (declare (type ,(linear-array-type (getf opt :store-type)) 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 t-dims)
+ (mod-dotimes (idx (dimensions to))
with (linear-sums
- (t-of t-stds t-hd))
+ (t-of (strides to) (head to)))
do (let ((scal-val (* ,(funcall (getf opt :reader) 't-sto 't-of) alpha)))
,(funcall (getf opt :value-writer) 'scal-val 't-sto 't-of))))))
to)))
@@ -99,8 +94,8 @@
;; zdscal and zscal is significant, except for very large arrays.
(generate-typed-scal! real-typed-scal! (real-tensor dscal))
(generate-typed-scal! complex-typed-scal! (complex-tensor zscal))
-
;;---------------------------------------------------------------;;
+
(defgeneric scal! (alpha x)
(:documentation
"
@@ -144,14 +139,12 @@
(let ((result (copy x)))
(scal! alpha result)))
-(defmethod scal ((alpha complex) (x real-matrix))
- (let* ((n (nrows x))
- (m (ncols x))
- (result (make-complex-matrix-dim n m)))
- (declare (type fixnum n m))
+(defmethod scal ((alpha complex) (x real-tensor))
+ (let* ((result (apply #'make-complex-tensor-dims (idx->list (dimensions x)))))
+ (declare (type complex-tensor result))
(copy! x result)
(scal! alpha result)))
-(defmethod scal ((alpha number) (x complex-matrix))
+(defmethod scal ((alpha number) (x complex-tensor))
(let ((result (copy x)))
(scal! alpha result)))
diff --git a/src/standard-tensor.lisp b/src/standard-tensor.lisp
index ae18f0b..905fe8e 100644
--- a/src/standard-tensor.lisp
+++ b/src/standard-tensor.lisp
@@ -1,30 +1,10 @@
(in-package :matlisp)
-;;
-(eval-when (load eval compile)
- (deftype integer4-type ()
- '(signed-byte 32))
- (deftype integer4-array (size)
- `(simple-array integer4-type (,size)))
-
- ;;
- (deftype index-type ()
- #+cmu '(signed-byte 32)
- #-cmu '(signed-byte 64))
- (deftype index-array (size)
- `(simple-array index-type (,size)))
- )
-
-(declaim (inline allocate-integer4-store))
-(make-array-allocator allocate-integer4-store 'integer4-type 0
-"
- Syntax
- ======
- (ALLOCATE-INT32-STORE SIZE [INITIAL-ELEMENT 0])
+(deftype index-type ()
+ 'fixnum)
- Purpose
- =======
- Allocates integer-32 storage.")
+(deftype index-array (size)
+ `(simple-array index-type (,size)))
(make-array-allocator allocate-index-store 'index-type 0
"
@@ -51,8 +31,8 @@
(definline idxv (&rest contents)
(make-index-store contents))
-
;;
+
(defclass standard-tensor ()
((rank
:accessor rank
@@ -161,12 +141,13 @@
(very-quickly
(loop
for i of-type index-type from 0 below rank
- and sto-idx of-type index-type = hd then (+ sto-idx (* cidx (aref strides i)))
- for cidx of-type index-type = (aref idx i)
- do (unless (< -1 cidx (aref dims i))
- (error 'tensor-index-out-of-bounds :argument i :index cidx :dimension (aref dims i)))
+ for cidx across idx
+ with sto-idx of-type index-type = hd
+ do (if (< -1 cidx (aref dims i))
+ (incf sto-idx (the index-type (* (aref strides i) cidx)))
+ (error 'tensor-index-out-of-bounds :argument i :index cidx :dimension (aref dims i)))
finally (return sto-idx))))))
-
+x
(defun store-indexing-lst (idx hd strides dims)
"
Syntax
diff --git a/src/utilities.lisp b/src/utilities.lisp
index 6441673..63fef05 100644
--- a/src/utilities.lisp
+++ b/src/utilities.lisp
@@ -237,6 +237,7 @@
(defstruct (foreign-vector
(:conc-name fv-)
(:print-function (lambda (obj stream depth)
+ (declare (ignore depth))
(format stream "#F(")
(let ((sz (fv-size obj)))
(dotimes (i sz)
commit adf78b01d61996d75fda7ce045e3f3f11aa3f9ed
Author: Akshay Srinivasan <aks...@gm...>
Date: Fri Jun 29 21:34:48 2012 +0530
More tweaks to "copy"
diff --git a/matlisp.asd b/matlisp.asd
index 3ff85aa..787e4ca 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -88,6 +88,8 @@
(:file "standard-tensor")
(:file "loopy"
:depends-on ("standard-tensor"))
+ (:file "blas-helpers"
+ :depends-on ("standard-tensor"))
(:file "real-tensor"
:depends-on ("standard-tensor"))
(:file "complex-tensor"
diff --git a/src/blas-helpers.lisp b/src/blas-helpers.lisp
index 78c33cb..10dc90b 100644
--- a/src/blas-helpers.lisp
+++ b/src/blas-helpers.lisp
@@ -1,89 +1,108 @@
(in-package :matlisp)
-(definline fortran-op (op)
- (ecase op (:n "N") (:t "T")))
+(definline idx-max (seq)
+ (reduce #'max seq))
-(definline fortran-nop (op)
- (ecase op (:t "N") (:n "T")))
+(definline idx-min (seq)
+ (reduce #'min seq))
-(defun fortran-snop (sop)
- (cond
- ((string= sop "N") "T")
- ((string= sop "T") "N")
- (t (error "Unrecognised fortran-op."))))
+(defun idx= (a b)
+ (declare (type (index-array *) a b))
+ (when (= (length a) (length b))
+ (very-quickly
+ (loop
+ for ele-a across a
+ for ele-b across b
+ unless (= ele-a ele-b)
+ do (return nil)
+ finally (return t)))))
-(defun blas-copyable-p (matrix)
- (declare (type (or real-matrix complex-matrix) matrix))
- (mlet* ((nr (nrows matrix) :type fixnum)
- (nc (ncols matrix) :type fixnum)
- (rs (row-stride matrix) :type fixnum)
- (cs (col-stride matrix) :type fixnum)
- (ne (number-of-elements matrix) :type fixnum))
- (very-quickly
- (cond
- ((or (= nc 1) (= cs (* nr rs))) (values t rs ne))
- ((or (= nr 1) (= rs (* nc cs))) (values t cs ne))
- (t (values nil -1 -1))))))
+(definline idx->list (a)
+ (declare (type (index-array *) a))
+ (loop for ele across a
+ collect ele))
-(defun blas-matrix-compatible-p (matrix &optional (op :n))
- (declare (optimize (safety 0) (speed 3))
- (type (or real-matrix complex-matrix) matrix))
- (mlet* (((rs cs) (slot-values matrix '(row-stride col-stride))
- :type (fixnum fixnum)))
- (cond
- ((= cs 1) (values :row-major rs (fortran-nop op)))
- ((= rs 1) (values :col-major cs (fortran-op op)))
- ;;Lets not confound lisp's type declaration.
- (t (values nil -1 "?")))))
+(defun blas-copyable-p (&rest tensors)
+ (let ((stdi-list (very-quickly
+ (loop
+ for ten in tensors
+ and pten = nil then ten
+ for i = 0 then (1+ i)
+ when (> i 0)
+ do (unless (idx= (dimensions ten) (dimensions pten))
+ (return nil))
+ collect (progn
+ (assert (typep ten 'standard-tensor) nil
+ 'invalid-type :given (type-of ten) :expected 'standard-tensor)
+ (very-quickly
+ (sort (apply #'vector
+ (loop
+ for std across (strides ten)
+ and dim across (dimensions ten)
+ collect `(,std ,dim)))
+ #'< :key #'car)))))))
+ (if (null stdi-list) (values nil nil)
+ (very-quickly
+ (loop
+ for stdi in stdi-list
+ and p-stdi = (first stdi-list) then stdi
+ for i = 0 then (1+ i)
+ when (> i 0)
+ do (unless (loop
+ for a-stdi across stdi
+ and a-aoff = (first (aref stdi 0)) then (* a-aoff (second a-stdi))
+ for b-stdi across p-stdi
+ and b-aoff = (first (aref p-stdi 0)) then (* b-aoff (second b-stdi))
+ do (unless (and (= (first a-stdi) a-aoff)
+ (= (first b-stdi) b-aoff)
+ (= (second a-stdi) (second b-stdi)))
+ (return nil))
+ finally (return t))
+ (return (values t nil)))
+ finally (return (values t (mapcar #'(lambda (x) (first (aref x 0))) stdi-list))))))))
+(defun consecutive-store-p (tensor)
+ (declare (type standard-tensor tensor))
+ (let ((strides (strides tensor))
+ (dims (dimensions tensor)))
+ (declare (type (index-array *) strides dims))
+ (let* ((stride-dims (very-quickly
+ (sort (apply #'vector
+ (loop
+ for std across strides
+ and dim across dims
+ collect `(,std ,dim)))
+ #'< :key #'car)))
+ (stride-min (first (aref stride-dims 0))))
+ (declare (type index-type stride-min)
+ (type (simple-vector *) stride-dims))
+ (very-quickly
+ (loop
+ for st-di across stride-dims
+ and accumulated-off = stride-min then (* accumulated-off (second st-di))
+ unless (= (first st-di) accumulated-off) do (return nil)
+ finally (return stride-min))))))
-(defun col-major-p (strides dims)
- (declare (type (index-array *) strides dims))
- (very-quickly
- (loop
- for off across strides
- and dim across dims
- and accumulated-off = 1 then (* accumulated-off dim)
- unless (= off accumulated-off) do (return nil)
- finally (return t))))
-(defun row-major-p (strides dims)
- (declare (type (index-array *) strides dims))
- (very-quickly
- (loop
- for idx of-type index-type from (1- (length dims)) downto 0
- for dim of-type index-type = (aref dims idx)
- for off of-type index-type = (aref strides idx)
- and accumulated-off of-type index-type = 1 then (* accumulated-off dim)
- unless (= off accumulated-off) do (return nil)
- finally (return t))))
+;; (defun blas-matrix-compatible-p (matrix &optional (op :n))
+;; (declare (optimize (safety 0) (speed 3))
+;; (type (or real-matrix complex-matrix) matrix))
+;; (mlet* (((rs cs) (slot-values matrix '(row-stride col-stride))
+;; :type (fixnum fixnum)))
+;; (cond
+;; ((= cs 1) (values :row-major rs (fortran-nop op)))
+;; ((= rs 1) (values :col-major cs (fortran-op op)))
+;; ;;Lets not confound lisp's type declaration.
+;; (t (values nil -1 "?")))))
-(defun same-dimension-p (a b)
- (declare (type (index-array *) a b))
- (let ((l-a (length a)))
- (when (= l-a (length b))
- (very-quickly
- (loop
- for i from 0 below l-a
- unless (= (aref a i) (aref b i))
- do (return nil)
- finally (return t))))))
+;; (definline fortran-op (op)
+;; (ecase op (:n "N") (:t "T")))
-(defun consecutive-store-p (strides dims)
- (declare (type (index-array *) strides dims))
- (let* ((stride-dims (very-quickly
- (sort (apply #'vector
- (loop
- for std across strides
- and dim across dims
- collect `(,std ,dim)))
- #'< :key #'car)))
- (stride-min (first (aref stride-dims 0))))
- (declare (type index-type stride-min)
- (type (simple-vector *) stride-dims))
- (very-quickly
- (loop
- for st-di across stride-dims
- and accumulated-off = stride-min then (* accumulated-off (second st-di))
- unless (= (first st-di) accumulated-off) do (return nil)
- finally (return stride-min)))))
+;; (definline fortran-nop (op)
+;; (ecase op (:t "N") (:n "T")))
+
+;; (defun fortran-snop (sop)
+;; (cond
+;; ((string= sop "N") "T")
+;; ((string= sop "T") "N")
+;; (t (error "Unrecognised fortran-op."))))
diff --git a/src/conditions.lisp b/src/conditions.lisp
index 781f435..ad16f1e 100644
--- a/src/conditions.lisp
+++ b/src/conditions.lisp
@@ -55,11 +55,10 @@
(to :reader to :initarg :to))
(:documentation "Cannot coerce one type into another."))
-(defmethod print-object ((c coercion) stream)
+(defmethod print-object ((c coercion-error) stream)
(format stream "Cannot coerce ~a into ~a." (from c) (to c))
(call-next-method))
-
;;---------------------------------------------------------------;;
(define-condition matlisp-error (error)
;;Optional argument for error-handling.
diff --git a/src/copy.lisp b/src/copy.lisp
index 4c21264..e620330 100644
--- a/src/copy.lisp
+++ b/src/copy.lisp
@@ -86,30 +86,24 @@
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
`(defun ,func (from to)
(declare (type ,tensor-class from to))
- (let ((f-dims (dimensions from))
- (f-stds (strides from))
- (f-sto (store from))
- (f-hd (head from))
- (t-dims (dimensions to))
- (t-stds (strides to))
- (t-sto (store to))
- (t-hd (head to)))
- (declare (type (index-array *) f-dims f-stds t-dims t-stds)
- (type index-type f-hd t-hd)
- (type ,(linear-array-type (getf opt :store-type)) f-sto t-sto))
- (if (or (and (row-major-p t-stds t-dims) (row-major-p f-stds f-dims))
- (and (col-major-p t-stds t-dims) (col-major-p f-stds f-dims)))
- (,blas-func (number-of-elements from) f-sto 1 t-sto 1 f-hd t-hd)
- (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 f-dims)
- with (linear-sums
- (f-of f-stds f-hd)
- (t-of t-stds t-hd))
- do ,(funcall (getf opt :reader-writer) 'f-sto 'f-of 't-sto 't-of))))
- to))))
+ (multiple-value-bind (dims-p strd-p) (blas-copyable-p from to)
+ (unless dims-p
+ (error 'tensor-dimension-mismatch))
+ (if strd-p
+ (,blas-func (number-of-elements from) (store from) (first strd-p) (store to) (second strd-p) (head from) (head to))
+ (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 ,(funcall (getf opt :reader-writer) 'f-sto 'f-of 't-sto 't-of))))))
+ to)))
(defmacro generate-typed-num-copy! (func (tensor-class blas-func))
;;Be very careful when using functions generated by this macro.
@@ -128,19 +122,19 @@
(declare (type (index-array *) t-dims t-stds)
(type index-type t-hd)
(type ,(linear-array-type (getf opt :store-type)) t-sto))
- (if (consecutive-p t-stds t-dims)
- (let ((num-array (,(getf opt :store-allocator) 1)))
- (declare (type ,(linear-array-type (getf opt :store-type)) num-array))
- ,(funcall (getf opt :value-writer) 'num-from 'num-array 0)
- (,blas-func (number-of-elements to) num-array 0 t-sto 1 0 t-hd))
- (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 t-dims)
- with (linear-sums
- (t-of t-stds t-hd))
- do ,(funcall (getf opt :value-writer) 'num-from 't-sto 't-of))))
+ (if-let (min-stride (consecutive-store-p to))
+ (let ((num-array (,(getf opt :store-allocator) 1)))
+ (declare (type ,(linear-array-type (getf opt :store-type)) num-array))
+ ,(funcall (getf opt :value-writer) 'num-from 'num-array 0)
+ (,blas-func (number-of-elements to) num-array 0 t-sto min-stride 0 t-hd))
+ (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 t-dims)
+ with (linear-sums
+ (t-of t-stds t-hd))
+ do ,(funcall (getf opt :value-writer) 'num-from 't-sto 't-of))))
to))))
(generate-typed-copy! real-typed-copy! (real-tensor dcopy))
@@ -173,7 +167,7 @@
REAL-MATRIX but the converse is possible.
")
(:method :before ((x standard-tensor) (y standard-tensor))
- (unless (same-dimension-p (dimensions x) (dimensions y))
+ (unless (idx= (dimensions x) (dimensions y))
(error 'tensor-dimension-mismatch)))
(:method ((x standard-tensor) (y standard-tensor))
(mod-dotimes (idx (dimensions x))
@@ -191,16 +185,16 @@
(defmethod copy! ((x complex-matrix) (y complex-tensor))
(complex-typed-copy! x y))
-;; (defmethod copy! ((x real-matrix) (y complex-tensor))
-;; (real-double-copy!-typed x (mrealpart~ y))
-;; (scal! 0d0 (mimagpart~ y))
-;; y)
+(defmethod copy! ((x real-matrix) (y complex-tensor))
+ (real-double-copy!-typed x (mrealpart~ y))
+ (scal! 0d0 (mimagpart~ y))
+ y)
(defmethod copy! ((x number) (y complex-tensor))
(complex-typed-num-copy! (coerce-complex x) y))
;;;;
-(defgeneric copy (matrix)
+(defgeneric copy (tensor)
(:documentation
"
Syntax
@@ -209,72 +203,44 @@
Purpose
=======
- Return a copy of the matrix X"))
+ Return a copy of the tensor X"))
-(defmethod copy ((matrix real-matrix))
- (let* ((n (nrows matrix))
- (m (ncols matrix))
- (result (make-real-matrix-dim n m)))
- (declare (type fixnum n m))
- (copy! matrix result)))
+(defmethod copy ((tensor real-tensor))
+ (let* ((ret (apply #'make-real-tensor-dims
+ (loop for dim across (dimensions tensor)
+ collect dim))))
+ (declare (type real-tensor ret))
+ (copy! tensor ret)))
-(defmethod copy ((matrix complex-matrix))
- (let* ((n (nrows matrix))
- (m (ncols matrix))
- (result (make-complex-matrix-dim n m)))
- (declare (type fixnum n m))
- (copy! matrix result)))
+(defmethod copy ((tensor complex-tensor))
+ (let* ((ret (apply #'make-complex-tensor-dims
+ (loop for dim across (dimensions tensor)
+ collect dim))))
+ (declare (type complex-tensor ret))
+ (copy! tensor ret)))
-(defmethod copy ((matrix number))
- matrix)
+(defmethod copy ((tensor number))
+ tensor)
;;
-(defgeneric convert-to-lisp-array (matrix)
- (:documentation
- "
+(defun convert-to-lisp-array (tensor)
+"
Syntax
======
- (CONVERT-TO-LISP-ARRAY matrix)
+ (convert-to-lisp-array tensor)
Purpose
=======
- Create a new Lisp array with the same dimensions as the matrix and
- with the same elements. This is a copy of the matrix.
-
- Row and column vectors are converted to a 1D lisp vector. Other
- matrices are converted a 2D lisp array.
-"))
-
-(defun convert-1d-array (m eltype)
- (let ((array (make-array (* (number-of-rows m)
- (number-of-cols m))
- :element-type eltype)))
- ;; We could do this faster by accessing the storage directly, but
- ;; this is easy.
- (dotimes (k (length array))
- (setf (aref array k) (matrix-ref m k)))
- array))
-
-(defun convert-2d-array (m eltype)
- (let* ((nrows (number-of-rows m))
- (ncols (number-of-cols m))
- (array (make-array (list (number-of-rows m)
- (number-of-cols m))
- :element-type eltype)))
- ;; We could do this faster by accessing the storage directly, but
- ;; this is easy.
- (dotimes (r nrows)
- (dotimes (c ncols)
- (setf (aref array r c)
- (matrix-ref m r c))))
- array))
-
-(defmethod convert-to-lisp-array ((m real-matrix))
- (if (or (row-vector-p m) (col-vector-p m))
- (convert-1d-array m 'double-float)
- (convert-2d-array m 'double-float)))
-
-(defmethod convert-to-lisp-array ((m complex-matrix))
- (if (or (row-vector-p m) (col-vector-p m))
- (convert-1d-array m '(complex double-float))
- (convert-2d-array m '(complex double-float))))
+ Create a new Lisp array with the same dimensions as the tensor and
+ with the same elements. This is a copy of the tensor.
+"
+ (declare (type standard-tensor tensor))
+ (let* ((dims (dimensions tensor))
+ (ret (make-array (idx->list dims)
+ :element-type (if-ret (getf (get-tensor-class-optimization (class-name (class-of tensor))) :element-type)
+ (error 'tensor-cannot-find-optimization :tensor-class (class-name (class-of tensor)))))))
+ (declare (type (index-array *) dims))
+ (very-quickly
+ (mod-dotimes (idx dims)
+ do (setf (apply #'aref ret (idx->list idx)) (tensor-ref tensor idx))))
+ ret))
diff --git a/src/realimag.lisp b/src/realimag.lisp
index 2036121..015ae12 100644
--- a/src/realimag.lisp
+++ b/src/realimag.lisp
@@ -133,7 +133,7 @@
:head (* 2 (head mat)))))
(number (cl:realpart mat))))
-(defun mimagpart (mat)
+(defun tensor-imagpart (mat)
"
Syntax
======
diff --git a/src/scal.lisp b/src/scal.lisp
index e0de476..15c6ea6 100644
--- a/src/scal.lisp
+++ b/src/scal.lisp
@@ -140,8 +140,7 @@
(defmethod scal ((alpha number) (x number))
(* alpha x))
-;;
-(defmethod scal ((alpha cl:real) (x real-matrix))
+(defmethod scal ((alpha number) (x real-tensor))
(let ((result (copy x)))
(scal! alpha result)))
@@ -153,7 +152,6 @@
(copy! x result)
(scal! alpha result)))
-;;
(defmethod scal ((alpha number) (x complex-matrix))
(let ((result (copy x)))
(scal! alpha result)))
diff --git a/src/standard-tensor.lisp b/src/standard-tensor.lisp
index 9e9bcd5..ae18f0b 100644
--- a/src/standard-tensor.lisp
+++ b/src/standard-tensor.lisp
@@ -8,9 +8,9 @@
`(simple-array integer4-type (,size)))
;;
- (deftype index-type ()
+ (deftype index-type ()
#+cmu '(signed-byte 32)
- #-cmu '(signed-byte 64))
+ #-cmu '(signed-byte 64))
(deftype index-array (size)
`(simple-array index-type (,size)))
)
@@ -189,7 +189,7 @@
(type cons idx))
(let ((rank (length strides)))
(declare (type index-type rank))
- (labels ((rec-sum (sum i lst)
+ (labels ((rec-sum (sum i lst)
(cond
((consp lst)
(let ((cidx (car lst)))
@@ -219,7 +219,7 @@
HD + \ STRIDES * IDX
/_ i i
i = 0
-"
+"
(declare (type standard-tensor tensor)
(type (or (index-array *) cons) idx))
(typecase idx
@@ -308,7 +308,7 @@
(let ((,tstore (store ,tensym)))
(declare (type ,(linear-array-type store-element-type) ,tstore))
,@body))))
- (let ((hst (list
+ (let ((hst (list
:reader (macrofy ,reader)
:value-writer (macrofy ,value-writer)
:reader-writer (macrofy ,reader-writer)
@@ -408,7 +408,7 @@
nil)))))))
(parse-sub subscripts 0)))))
-(definline vector-p (tensor)
+(definline vector-p (tensor)
(declare (type standard-tensor tensor))
(tensor-type-p tensor '(*)))
@@ -425,7 +425,7 @@
;;---------------------------------------------------------------;;
(define-constant +array-slicing-symbols+ '(\:)
-"
+"
Symbols which are used to refer to slicing operations.")
(defun sub-tensor~ (tensor subscripts)
@@ -453,7 +453,7 @@
;; Get [:, :, 0:10:2] (0:10:2 = [i : 0 <= i < 10, i % 2 = 0])
> (sub-tensor~ X '(\: \: ((\: 2) 0 *)))
-"
+"
(declare (type standard-tensor tensor))
(let ((rank (rank tensor))
(dims (dimensions tensor))
diff --git a/src/utilities.lisp b/src/utilities.lisp
index 3a26d44..6441673 100644
--- a/src/utilities.lisp
+++ b/src/utilities.lisp
@@ -233,15 +233,6 @@
(with-output-to-string (ostr ret)
(apply #'format (append `(,ostr ,fmt) args)))
ret))
-
-(declaim (inline seq-max))
-(defun seq-max (seq)
- (reduce #'max seq))
-
-(declaim (inline seq-max))
-(defun seq-min (seq)
- (reduce #'min seq))
-
;;---------------------------------------------------------------;;
(defstruct (foreign-vector
(:conc-name fv-)
-----------------------------------------------------------------------
Summary of changes:
README => README.old | 0
matlisp.asd | 20 ++++-
src/blas-helpers.lisp | 186 +++++++++++++++++++++++++++-------------------
src/conditions.lisp | 3 +-
src/copy.lisp | 180 +++++++++++++++++++--------------------------
src/loopy.lisp | 27 ++++---
src/permutations.lisp | 177 +++++++++++++++++++++++++++++++-------------
src/realimag.lisp | 68 +++--------------
src/scal.lisp | 33 +++-----
src/standard-tensor.lisp | 53 ++++---------
src/utilities.lisp | 10 +--
11 files changed, 383 insertions(+), 374 deletions(-)
rename README => README.old (100%)
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2012-06-29 03:24:36
|
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 1231d97cfa4e89109805a7a5284d939bbd65f5f9 (commit)
from 848eaaca232c394753e19a057fa732c9937a8a39 (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 1231d97cfa4e89109805a7a5284d939bbd65f5f9
Author: Akshay Srinivasan <aks...@gm...>
Date: Fri Jun 29 08:50:00 2012 +0530
Added scal!-generating macro and scal! methods.
diff --git a/TODO b/TODO
new file mode 100644
index 0000000..8be2f0a
--- /dev/null
+++ b/TODO
@@ -0,0 +1,8 @@
+* Write documentation. Maybe move to TeXinfo (like femlisp).
+ Fix the formatting for docstrings.
+* Write tests
+* Get the python-bridge working with burgled-batteries, nothing beats
+ matplotlib for plotting.
+* Add infix to Matlisp
+* Support linking to libraries ? Might have to parse function declarations
+ with cffi-grovel.
\ No newline at end of file
diff --git a/matlisp.asd b/matlisp.asd
index 371e5a9..3ff85aa 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -3,14 +3,14 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Copyright (c) 2000 The Regents of the University of California.
-;;; All rights reserved.
-;;;
+;;; All rights reserved.
+;;;
;;; Permission is hereby granted, without written agreement and without
;;; license or royalty fees, to use, copy, modify, and distribute this
;;; software and its documentation for any purpose, provided that the
;;; above copyright notice and the following two paragraphs appear in all
;;; copies of this software.
-;;;
+;;;
;;; IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY
;;; FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
;;; ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF
@@ -34,184 +34,184 @@
(in-package #:matlisp-system)
(asdf:defsystem matlisp-packages
- :pathname #.(translate-logical-pathname "matlisp:srcdir;")
- :components
- ((:file "packages")))
+ :depends-on (#:cffi)
+ :pathname #.(translate-logical-pathname "matlisp:srcdir;")
+ :components
+ ((:file "packages")))
(asdf:defsystem matlisp-utilities
- :pathname #.(translate-logical-pathname "matlisp:srcdir;")
- :depends-on ("matlisp-packages")
- :components ((:module "utilities"
- :pathname "src/"
- :components ((:file "utilities")))))
+ :pathname #.(translate-logical-pathname "matlisp:srcdir;")
+ :depends-on ("matlisp-packages")
+ :components ((:module "utilities"
+ :pathname "src/"
+ :components ((:file "utilities")))))
(asdf:defsystem lazy-loader
- :pathname #.(translate-logical-pathname "matlisp:lib;")
- :depends-on ("matlisp-packages")
- :components
- ((:file "lazy-loader"
- ;; you need the load-only here,
- ;; otherwise, Allegro tries to
- ;; load the DLL (SO)'s twice
- ;; and fails.
- )))
+ :pathname #.(translate-logical-pathname "matlisp:lib;")
+ :depends-on (#:cffi #:matlisp-packages)
+ :components
+ ((:file "lazy-loader"
+ ;; you need the load-only here,
+ ;; otherwise, Allegro tries to
+ ;; load the DLL (SO)'s twice
+ ;; and fails.
+ )))
(asdf:defsystem fortran-names
- :pathname #.(translate-logical-pathname "matlisp:src;")
- :depends-on ("matlisp-packages")
- :components
- ((:file "f77-mangling")))
+ :pathname #.(translate-logical-pathname "matlisp:src;")
+ :depends-on ("matlisp-packages")
+ :components
+ ((:file "f77-mangling")))
(asdf:defsystem matlisp
- :pathname #.(translate-logical-pathname "matlisp:srcdir;")
- :depends-on ("lazy-loader"
- "matlisp-packages"
- "matlisp-utilities"
- "fortran-names")
- :components
- ((:module "foreign-interface"
- :pathname "src/"
- :components ((:file "ffi-cffi")
- (:file "ffi-cffi-interpreter-specific")
- ))
- (:module "foreign-functions"
- :pathname "src/"
- :depends-on ("foreign-interface")
- :components ((:file "blas")
- (:file "lapack")
- (:file "dfftpack")))
- (:module "matlisp-essentials"
- :pathname "src/"
- :depends-on ("foreign-interface"
- "foreign-functions")
- :components ((:file "conditions")
- (:file "standard-tensor")
- (:file "loopy"
- :depends-on ("standard-tensor"))
- (:file "real-tensor"
- :depends-on ("standard-tensor"))
- (:file "complex-tensor"
- :depends-on ("standard-tensor"))
- (:file "standard-matrix"
- :depends-on ("standard-tensor"))
- ;; (:file "real-matrix"
- ;; :depends-on ("standard-matrix"))
- ;; (:file "complex-matrix"
- ;; :depends-on ("standard-matrix"))
- (:file "print"
- :depends-on ("standard-tensor" "standard-matrix"))))))
+ :pathname #.(translate-logical-pathname "matlisp:srcdir;")
+ :depends-on (#:cffi "lazy-loader"
+ "matlisp-packages" "matlisp-utilities"
+ "fortran-names")
+ :components
+ ((:module "foreign-interface"
+ :pathname "src/"
+ :components ((:file "ffi-cffi")
+ (:file "ffi-cffi-interpreter-specific")
+ ))
+ (:module "foreign-functions"
+ :pathname "src/"
+ :depends-on ("foreign-interface")
+ :components ((:file "blas")
+ (:file "lapack")
+ (:file "dfftpack")))
+ (:module "matlisp-essentials"
+ :pathname "src/"
+ :depends-on ("foreign-interface"
+ "foreign-functions")
+ :components ((:file "conditions")
+ (:file "standard-tensor")
+ (:file "loopy"
+ :depends-on ("standard-tensor"))
+ (:file "real-tensor"
+ :depends-on ("standard-tensor"))
+ (:file "complex-tensor"
+ :depends-on ("standard-tensor"))
+ (:file "standard-matrix"
+ :depends-on ("standard-tensor"))
+ ;; (:file "real-matrix"
+ ;; :depends-on ("standard-matrix"))
+ ;; (:file "complex-matrix"
+ ;; :depends-on ("standard-matrix"))
+ (:file "print"
+ :depends-on ("standard-tensor" "standard-matrix"))))))
;; (defclass f2cl-cl-source-file (asdf:cl-source-file)
;; ())
-
+
;; (defmethod asdf:source-file-type ((f f2cl-cl-source-file) (m asdf:module))
;; "l")
;; (asdf:defsystem matlisp-f2cl-macros
;; :pathname #.(translate-logical-pathname "matlisp:srcdir;lib-src;")
;; :depends-on ("matlisp-packages")
-;; :default-component-class f2cl-cl-source-file
+;; :default-component-class f2cl-cl-source-file
;; :components
;; ((:file "macros")))
;; (asdf:defsystem matlisp
;; :pathname #.(translate-logical-pathname "matlisp:srcdir;")
;; :depends-on ("lazy-loader"
-;; "matlisp-packages"
-;; "matlisp-utilities"
-;; "fortran-names"
-;; "matlisp-f2cl-macros")
+;; "matlisp-packages"
+;; "matlisp-utilities"
+;; "fortran-names"
+;; "matlisp-f2cl-macros")
;; :components
;; ((:module "foreign-interface"
-;; :pathname "src/"
-;; :components ((:file "ffi-cffi")
-;; (:file "ffi-cffi-interpreter-specific")
-;; ))
+;; :pathname "src/"
+;; :components ((:file "ffi-cffi")
+;; (:file "ffi-cffi-interpreter-specific")
+;; ))
;; (:module "foreign-functions"
-;; :pathname "src/"
-;; :depends-on ("foreign-interface")
-;; :components ((:file "blas")
-;; (:file "lapack")
-;; (:file "dfftpack")
-;; #+nil (:file "ranlib")))
+;; :pathname "src/"
+;; :depends-on ("foreign-interface")
+;; :components ((:file "blas")
+;; (:file "lapack")
+;; (:file "dfftpack")
+;; #+nil (:file "ranlib")))
;; (:module "matlisp-essentials"
-;; :pathname "src/"
-;; :depends-on ("foreign-interface"
-;; "foreign-functions")
-;; :components ((:file "conditions")
-;; (:file "standard-matrix")
-;; (:file "real-matrix"
-;; :depends-on ("standard-matrix"))
-;; (:file "complex-matrix"
-;; :depends-on ("standard-matrix"))
-;; ;; (:file "ref"
-;; ;; :depends-on ("matrix"))
-;; (:file "copy"
-;; :depends-on ("standard-matrix"))
-;; (:file "print"
-;; :depends-on ("standard-matrix"))))
-
+;; :pathname "src/"
+;; :depends-on ("foreign-interface"
+;; "foreign-functions")
+;; :components ((:file "conditions")
+;; (:file "standard-matrix")
+;; (:file "real-matrix"
+;; :depends-on ("standard-matrix"))
+;; (:file "complex-matrix"
+;; :depends-on ("standard-matrix"))
+;; ;; (:file "ref"
+;; ;; :depends-on ("matrix"))
+;; (:file "copy"
+;; :depends-on ("standard-matrix"))
+;; (:file "print"
+;; :depends-on ("standard-matrix"))))
+
;; (:module "matlisp-blas-wrappers"
-;; :pathname "src/"
-;; :depends-on ("foreign-interface"
-;; "foreign-functions"
-;; "matlisp-essentials")
-;; :components ((:file "axpy")
-;; (:file "scal")
-;; (:file "swap")
-;; (:file "gemv")
-;; (:file "gemm")))
+;; :pathname "src/"
+;; :depends-on ("foreign-interface"
+;; "foreign-functions"
+;; "matlisp-essentials")
+;; :components ((:file "axpy")
+;; (:file "scal")
+;; (:file "swap")
+;; (:file "gemv")
+;; (:file "gemm")))
;; (:module "matlisp-lapack-wrappers"
-;; :pathname "src/"
-;; :depends-on ("foreign-interface"
-;; "foreign-functions"
-;; "matlisp-essentials")
-;; :components ((:file "gels")
-;; (:file "gesv")
-;; (:file "geev")
-;; (:file "getrf")
-;; (:file "getrs")
-;; (:file "potrf")
-;; (:file "potrs")))
+;; :pathname "src/"
+;; :depends-on ("foreign-interface"
+;; "foreign-functions"
+;; "matlisp-essentials")
+;; :components ((:file "gels")
+;; (:file "gesv")
+;; (:file "geev")
+;; (:file "getrf")
+;; (:file "getrs")
+;; (:file "potrf")
+;; (:file "potrs")))
;; (:module "matlisp-functions"
;; :pathname "src/"
-;; :depends-on ("foreign-interface"
-;; "foreign-functions"
-;; "matlisp-essentials"
-;; "matlisp-blas-wrappers"
-;; "matlisp-lapack-wrappers")
-;; :components ((:file "compat")
-;; (:file "help")
-;; (:file "special")
-;; (:file "reader")
-;; (:file "trans")
-;; (:file "realimag")
-;; (:file "submat")
-;; (:file "reshape")
-;; (:file "join")
-;; (:file "svd")
-;; (:file "sum")
-;; (:file "norm")
-;; (:file "dot")
-;; (:file "trace")
-;; (:file "seq")
-;; (:file "vec")
-;; (:file "map")
-;; (:file "mplus")
-;; (:file "mminus")
-;; (:file "mtimes")
-;; (:file "mdivide")
-;; (:file "msqrt")
-;; (:file "fft")
-;; (:file "geqr")))
+;; :depends-on ("foreign-interface"
+;; "foreign-functions"
+;; "matlisp-essentials"
+;; "matlisp-blas-wrappers"
+;; "matlisp-lapack-wrappers")
+;; :components ((:file "compat")
+;; (:file "help")
+;; (:file "special")
+;; (:file "reader")
+;; (:file "trans")
+;; (:file "realimag")
+;; (:file "submat")
+;; (:file "reshape")
+;; (:file "join")
+;; (:file "svd")
+;; (:file "sum")
+;; (:file "norm")
+;; (:file "dot")
+;; (:file "trace")
+;; (:file "seq")
+;; (:file "vec")
+;; (:file "map")
+;; (:file "mplus")
+;; (:file "mminus")
+;; (:file "mtimes")
+;; (:file "mdivide")
+;; (:file "msqrt")
+;; (:file "fft")
+;; (:file "geqr")))
;; (:module "special-functions"
-;; :pathname "src/"
-;; :depends-on ("matlisp-functions")
-;; :components
-;; ((:file "specfun")))))
+;; :pathname "src/"
+;; :depends-on ("matlisp-functions")
+;; :components
+;; ((:file "specfun")))))
;; Add-on packages
;; (asdf:defsystem matlisp-quadpack
@@ -219,131 +219,131 @@
;; :depends-on ("matlisp-f2cl-macros")
;; :components
;; ((:module "quadpack-interface"
-;; :pathname "src/"
-;; :components
-;; ((:file "quadpack")))
+;; :pathname "src/"
+;; :components
+;; ((:file "quadpack")))
;; (:module "lib-src"
-;; :components
-;; ((:module "quadpack"
-;; :components
-;; (
-;; ;; Support
-;; (:file "dqwgtf")
-;; (:file "dqcheb")
-;; (:file "dqk15w")
-;; (:file "dqwgts")
-;; (:file "dqwgtc")
-;; (:file "dgtsl")
-;; (:file "xerror")
-
-;; ;; Core integration routines
-;; (:file "dqk15")
-;; (:file "dqk31")
-;; (:file "dqk41")
-;; (:file "dqk51")
-;; (:file "dqk61")
-;; (:file "dqk21")
-;; (:file "dqk15i")
-;; (:file "dqelg")
-;; (:file "dqpsrt")
-;; (:file "dqc25s"
-;; :depends-on ("dqcheb" "dqk15w"))
-;; (:file "dqmomo")
-;; (:file "dqc25c"
-;; :depends-on ("dqcheb"
-;; "dqk15w"))
-;; (:file "dqc25f"
-;; :depends-on ("dgtsl"
-;; "dqcheb"
-;; "dqk15w"
-;; "dqwgtf"))
-;; ;; Basic integrators
-;; (:file "dqage"
-;; :depends-on ("dqk15"
-;; "dqk31"
-;; "dqk41"
-;; "dqk51"
-;; "dqk61"
-;; "dqk21"
-;; "dqpsrt"))
-;; (:file "dqagie"
-;; :depends-on ("dqelg"
-;; "dqk15i"
-;; "dqpsrt"))
-;; (:file "dqagpe"
-;; :depends-on ("dqelg"
-;; "dqpsrt"
-;; "dqk21"
-;; ))
-;; (:file "dqagse"
-;; :depends-on ("dqk21"
-;; "dqelg"
-;; "dqpsrt"))
-;; (:file "dqawfe"
-;; :depends-on ("dqagie"
-;; "dqawoe"
-;; "dqelg"))
-;; (:file "dqawoe"
-;; :depends-on ("dqc25f"
-;; "dqpsrt"
-;; "dqelg"))
-;; (:file "dqawse"
-;; :depends-on ("dqc25s"
-;; "dqmomo"
-;; "dqpsrt"))
-;; (:file "dqawce"
-;; :depends-on ("dqc25c"
-;; "dqpsrt"))
-;; ;; Simplified interface routines
-;; (:file "dqng"
-;; :depends-on ("xerror"))
-;; (:file "dqag"
-;; :depends-on ("dqage"
-;; "xerror"))
-;; (:file "dqags"
-;; :depends-on ("dqagse"
-;; "xerror"))
-;; (:file "dqagi"
-;; :depends-on ("dqagie"
-;; "xerror"))
-;; (:file "dqawf"
-;; :depends-on ("dqawfe"
-;; "xerror"))
-;; (:file "dqawo"
-;; :depends-on ("dqawoe"
-;; "xerror"))
-;; (:file "dqaws"
-;; :depends-on ("dqawse"
-;; "xerror"))
-;; (:file "dqawc"
-;; :depends-on ("dqawce"
-;; "xerror"))))))))
+;; :components
+;; ((:module "quadpack"
+;; :components
+;; (
+;; ;; Support
+;; (:file "dqwgtf")
+;; (:file "dqcheb")
+;; (:file "dqk15w")
+;; (:file "dqwgts")
+;; (:file "dqwgtc")
+;; (:file "dgtsl")
+;; (:file "xerror")
+
+;; ;; Core integration routines
+;; (:file "dqk15")
+;; (:file "dqk31")
+;; (:file "dqk41")
+;; (:file "dqk51")
+;; (:file "dqk61")
+;; (:file "dqk21")
+;; (:file "dqk15i")
+;; (:file "dqelg")
+;; (:file "dqpsrt")
+;; (:file "dqc25s"
+;; :depends-on ("dqcheb" "dqk15w"))
+;; (:file "dqmomo")
+;; (:file "dqc25c"
+;; :depends-on ("dqcheb"
+;; "dqk15w"))
+;; (:file "dqc25f"
+;; :depends-on ("dgtsl"
+;; "dqcheb"
+;; "dqk15w"
+;; "dqwgtf"))
+;; ;; Basic integrators
+;; (:file "dqage"
+;; :depends-on ("dqk15"
+;; "dqk31"
+;; "dqk41"
+;; "dqk51"
+;; "dqk61"
+;; "dqk21"
+;; "dqpsrt"))
+;; (:file "dqagie"
+;; :depends-on ("dqelg"
+;; "dqk15i"
+;; "dqpsrt"))
+;; (:file "dqagpe"
+;; :depends-on ("dqelg"
+;; "dqpsrt"
+;; "dqk21"
+;; ))
+;; (:file "dqagse"
+;; :depends-on ("dqk21"
+;; "dqelg"
+;; "dqpsrt"))
+;; (:file "dqawfe"
+;; :depends-on ("dqagie"
+;; "dqawoe"
+;; "dqelg"))
+;; (:file "dqawoe"
+;; :depends-on ("dqc25f"
+;; "dqpsrt"
+;; "dqelg"))
+;; (:file "dqawse"
+;; :depends-on ("dqc25s"
+;; "dqmomo"
+;; "dqpsrt"))
+;; (:file "dqawce"
+;; :depends-on ("dqc25c"
+;; "dqpsrt"))
+;; ;; Simplified interface routines
+;; (:file "dqng"
+;; :depends-on ("xerror"))
+;; (:file "dqag"
+;; :depends-on ("dqage"
+;; "xerror"))
+;; (:file "dqags"
+;; :depends-on ("dqagse"
+;; "xerror"))
+;; (:file "dqagi"
+;; :depends-on ("dqagie"
+;; "xerror"))
+;; (:file "dqawf"
+;; :depends-on ("dqawfe"
+;; "xerror"))
+;; (:file "dqawo"
+;; :depends-on ("dqawoe"
+;; "xerror"))
+;; (:file "dqaws"
+;; :depends-on ("dqawse"
+;; "xerror"))
+;; (:file "dqawc"
+;; :depends-on ("dqawce"
+;; "xerror"))))))))
;; (asdf:defsystem matlisp-minpack
;; :pathname #.(translate-logical-pathname "matlisp:srcdir;")
;; :depends-on ("matlisp-f2cl-macros")
;; :components
;; ((:module "lib-src"
-;; :components
-;; ((:module "minpack"
-;; :components
-;; ((:file "dpmpar")
-;; (:file "enorm")
-;; (:file "fdjac2")
-;; (:file "qrsolv")
-;; (:file "lmpar")
-;; (:file "qrfac")
-;; (:file "lmdif")
-;; (:file "lmdif1")
-;; (:file "lmder")
-;; (:file "lmder1")
-;; (:file "dogleg")
-;; (:file "qform")
-;; (:file "r1mpyq")
-;; (:file "r1updt")
-;; (:file "hybrj" :depends-on ("dogleg" "qform" "r1mpyq" "r1updt"))
-;; (:file "hybrj1" :depends-on ("hybrj"))
-;; ))))))
+;; :components
+;; ((:module "minpack"
+;; :components
+;; ((:file "dpmpar")
+;; (:file "enorm")
+;; (:file "fdjac2")
+;; (:file "qrsolv")
+;; (:file "lmpar")
+;; (:file "qrfac")
+;; (:file "lmdif")
+;; (:file "lmdif1")
+;; (:file "lmder")
+;; (:file "lmder1")
+;; (:file "dogleg")
+;; (:file "qform")
+;; (:file "r1mpyq")
+;; (:file "r1updt")
+;; (:file "hybrj" :depends-on ("dogleg" "qform" "r1mpyq" "r1updt"))
+;; (:file "hybrj1" :depends-on ("hybrj"))
+;; ))))))
;; (asdf:defsystem matlisp-odepack
;; :pathname #.(translate-logical-pathname "matlisp:srcdir;")
@@ -351,7 +351,7 @@
;; :components
;; ((:module "src"
;; :components
-;; ((:file "dlsode")))))
+;; ((:file "dlsode")))))
;; (asdf:defsystem matlisp-colnew
;; :pathname #.(translate-logical-pathname "matlisp:srcdir;")
diff --git a/packages.lisp b/packages.lisp
index ee8fbf4..5226d68 100644
--- a/packages.lisp
+++ b/packages.lisp
@@ -153,8 +153,8 @@
;;; Define the packages and symbols for Matlisp.
-(defpackage :utilities
- (:use :common-lisp)
+(defpackage "UTILITIES"
+ (:use #:common-lisp)
(:export #:ensure-list
#:zip #:zip-eq
#:cut-cons-chain!
@@ -175,9 +175,9 @@
#:foreign-vector #:make-foreign-vector #:foreign-vector-p
#:fv-ref #:fv-pointer #:fv-size #:fv-type))
-(defpackage :fortran-ffi-accessors
- (:nicknames :ffi)
- (:use :common-lisp :cffi :utilities)
+(defpackage "FORTRAN-FFI-ACCESSORS"
+ (:nicknames #:ffi)
+ (:use #:common-lisp #:cffi #:utilities)
;; TODO: Check if this is implementation-agnostic.
;; #+:cmu (:use :common-lisp :c-call :cffi :utilities)
;; #+:sbcl (:use :common-lisp :cffi :utilities)
@@ -191,8 +191,8 @@
)
(:documentation "Fortran foreign function interface"))
-(defpackage :blas
- (:use :common-lisp :fortran-ffi-accessors)
+(defpackage "BLAS"
+ (:use #:common-lisp #:ffi)
(:export
;;BLAS Level 1
;;------------
@@ -216,8 +216,8 @@
#:zgemm #:ztrmm #:ztrsm #:zherk #:zher2k)
(:documentation "BLAS routines"))
-(defpackage :lapack
- (:use :common-lisp :fortran-ffi-accessors)
+(defpackage "LAPACK"
+ (:use #:common-lisp #:ffi)
(:export
#:dgesv #:dgeev #:dgetrf #:dgetrs #:dgesvd
#:zgesv #:zgeev #:zgetrf #:zgetrs #:zgesvd
@@ -227,11 +227,32 @@
#:dgelsy)
(:documentation "LAPACK routines"))
-(defpackage :dfftpack
- (:use :common-lisp :fortran-ffi-accessors)
+(defpackage "DFFTPACK"
+ (:use #:common-lisp #:fortran-ffi-accessors)
(:export #:zffti #:zfftf #:zfftb #:zffti #:zfftf #:zfftb)
(:documentation "FFT routines"))
+(defpackage "MATLISP"
+ (:use #:common-lisp #:fortran-ffi-accessors #:blas #:lapack #:dfftpack #:utilities)
+ (:export #:integer4-type #:integer4-array #:allocate-integer4-store
+ #:index-type #:index-array #:allocate-index-store #:make-index-store
+ ;;Standard-tensor
+ #:standard-tensor
+ #:rank #:dimensions #:number-of-elements
+ #:head #:strides #:store-size #:store
+ ;;Sub-tensor
+ #:sub-tensor
+ #:parent-tensor
+ ;;Store indexers
+ #:store-indexing
+ #:store-indexing-internal #:store-indexing-vec #:store-indexing-lst
+ ;;Store accessors
+ #:tensor-store-ref
+ #:tensor-ref
+ ;;Type checking
+ #:tensor-type-p #:vector-p #:matrix-p #:square-p)
+ (:documentation "MATLISP routines"))
+
;;Transitioning to using the tensor-datastructures; eventually move things back to :matlisp
;; Stolen from f2cl.
@@ -309,26 +330,6 @@
;; "ZEROIN")
;; (:documentation "Other useful routines"))
-(defpackage :matlisp
- (:use :common-lisp :fortran-ffi-accessors :blas :lapack :dfftpack :utilities)
- (:export #:integer4-type #:integer4-array #:allocate-integer4-store
- #:index-type #:index-array #:allocate-index-store #:make-index-store
- ;;Standard-tensor
- #:standard-tensor
- #:rank #:dimensions #:number-of-elements
- #:head #:strides #:store-size #:store
- ;;Sub-tensor
- #:sub-tensor
- #:parent-tensor
- ;;Store indexers
- #:store-indexing
- #:store-indexing-internal #:store-indexing-vec #:store-indexing-lst
- ;;Store accessors
- #:tensor-store-ref
- #:tensor-ref
- ;;Type checking
- #:tensor-type-p #:vector-p #:matrix-p #:square-p)
- (:documentation "MATLISP routines"))
;; (defpackage :matlisp
;; (:use :common-lisp :fortran-ffi-accessors :blas :lapack :dfftpack :quadpack :matlisp-lib :utilities)
diff --git a/src/blas-helpers.lisp b/src/blas-helpers.lisp
index 29f2813..78c33cb 100644
--- a/src/blas-helpers.lisp
+++ b/src/blas-helpers.lisp
@@ -19,7 +19,7 @@
(rs (row-stride matrix) :type fixnum)
(cs (col-stride matrix) :type fixnum)
(ne (number-of-elements matrix) :type fixnum))
- (very-quickly
+ (very-quickly
(cond
((or (= nc 1) (= cs (* nr rs))) (values t rs ne))
((or (= nr 1) (= rs (* nc cs))) (values t cs ne))
@@ -35,3 +35,55 @@
((= rs 1) (values :col-major cs (fortran-op op)))
;;Lets not confound lisp's type declaration.
(t (values nil -1 "?")))))
+
+
+(defun col-major-p (strides dims)
+ (declare (type (index-array *) strides dims))
+ (very-quickly
+ (loop
+ for off across strides
+ and dim across dims
+ and accumulated-off = 1 then (* accumulated-off dim)
+ unless (= off accumulated-off) do (return nil)
+ finally (return t))))
+
+(defun row-major-p (strides dims)
+ (declare (type (index-array *) strides dims))
+ (very-quickly
+ (loop
+ for idx of-type index-type from (1- (length dims)) downto 0
+ for dim of-type index-type = (aref dims idx)
+ for off of-type index-type = (aref strides idx)
+ and accumulated-off of-type index-type = 1 then (* accumulated-off dim)
+ unless (= off accumulated-off) do (return nil)
+ finally (return t))))
+
+(defun same-dimension-p (a b)
+ (declare (type (index-array *) a b))
+ (let ((l-a (length a)))
+ (when (= l-a (length b))
+ (very-quickly
+ (loop
+ for i from 0 below l-a
+ unless (= (aref a i) (aref b i))
+ do (return nil)
+ finally (return t))))))
+
+(defun consecutive-store-p (strides dims)
+ (declare (type (index-array *) strides dims))
+ (let* ((stride-dims (very-quickly
+ (sort (apply #'vector
+ (loop
+ for std across strides
+ and dim across dims
+ collect `(,std ,dim)))
+ #'< :key #'car)))
+ (stride-min (first (aref stride-dims 0))))
+ (declare (type index-type stride-min)
+ (type (simple-vector *) stride-dims))
+ (very-quickly
+ (loop
+ for st-di across stride-dims
+ and accumulated-off = stride-min then (* accumulated-off (second st-di))
+ unless (= (first st-di) accumulated-off) do (return nil)
+ finally (return stride-min)))))
diff --git a/src/complex-tensor.lisp b/src/complex-tensor.lisp
index 35bbd13..4a636cf 100644
--- a/src/complex-tensor.lisp
+++ b/src/complex-tensor.lisp
@@ -35,7 +35,7 @@ Default initial-element = 0d0."
:type (complex-base-array *)))
(:documentation "Tensor class with complex elements."))
-(defclass complex-sub-tensor (complex-tensor sub-tensor)
+(defclass complex-sub-tensor (complex-tensor standard-sub-tensor)
()
(:documentation "Sub-tensor class with complex elements."))
@@ -84,13 +84,14 @@ Cannot hold complex numbers."))
(let ((realpart (realpart element))
(imagpart (imagpart element)))
(format stream (if (zerop imagpart)
- " ~11,4,,,,,'Eg "
+ "~11,5,,,,,'Eg"
"#C(~11,4,,,,,'Ee ~11,4,,,,,'Ee)")
realpart imagpart)))
;;
-(defun make-complex-tensor (&rest subs)
+(defun make-complex-tensor-dims (&rest subs)
(let* ((dims (make-index-store subs))
(ss (reduce #'* dims))
(store (allocate-complex-store ss)))
(make-instance 'complex-tensor :store store :dimensions dims)))
+
diff --git a/src/conditions.lisp b/src/conditions.lisp
index e58b119..781f435 100644
--- a/src/conditions.lisp
+++ b/src/conditions.lisp
@@ -39,6 +39,7 @@
(defmethod print-object ((c invalid-value) stream)
(format stream "Given object ~A, expected ~A.~%" (given c) (expected c))
(call-next-method))
+
;;---------------------------------------------------------------;;
(define-condition unknown-token (generic-error)
((token :reader token :initarg :token))
@@ -49,6 +50,17 @@
(call-next-method))
;;---------------------------------------------------------------;;
+(define-condition coercion-error (generic-error)
+ ((from :reader from :initarg :from)
+ (to :reader to :initarg :to))
+ (:documentation "Cannot coerce one type into another."))
+
+(defmethod print-object ((c coercion) stream)
+ (format stream "Cannot coerce ~a into ~a." (from c) (to c))
+ (call-next-method))
+
+
+;;---------------------------------------------------------------;;
(define-condition matlisp-error (error)
;;Optional argument for error-handling.
((tensor :reader tensor :initarg :tensor)))
@@ -119,3 +131,10 @@
(:documentation "Cannot find optimization information for the given tensor class")
(:report (lambda (c stream)
(format stream "Cannot find optimization information for the given tensor class: ~a." (tensor-class c)))))
+
+(define-condition tensor-dimension-mismatch (matlisp-error)
+ ()
+ (:documentation "The dimensions of the given tensors are not suitable for continuing with the operation.")
+ (:report (lambda (c stream)
+ (declare (ignore c))
+ (format stream "The dimensions of the given tensors are not suitable for continuing with the operation."))))
diff --git a/src/copy.lisp b/src/copy.lisp
index 91c1031..4c21264 100644
--- a/src/copy.lisp
+++ b/src/copy.lisp
@@ -76,9 +76,9 @@
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(in-package :matlisp)
+(in-package #:matlisp)
-(defmacro generate-typed-copy!-func (func (tensor-class blas-func))
+(defmacro generate-typed-copy! (func (tensor-class blas-func))
;;Be very careful when using functions generated by this macro.
;;Indexes can be tricky and this has no safety net
;;Use only after checking the arguments for compatibility.
@@ -111,7 +111,7 @@
do ,(funcall (getf opt :reader-writer) 'f-sto 'f-of 't-sto 't-of))))
to))))
-(defmacro generate-typed-num-copy!-func (func (tensor-class blas-func))
+(defmacro generate-typed-num-copy! (func (tensor-class blas-func))
;;Be very careful when using functions generated by this macro.
;;Indexes can be tricky and this has no safety net
;;(you don't see a matrix-ref do you ?)
@@ -143,13 +143,12 @@
do ,(funcall (getf opt :value-writer) 'num-from 't-sto 't-of))))
to))))
-(generate-typed-copy!-func real-typed-copy! (real-tensor dcopy))
-(generate-typed-num-copy!-func real-typed-num-copy! (real-tensor dcopy))
+(generate-typed-copy! real-typed-copy! (real-tensor dcopy))
+(generate-typed-num-copy! real-typed-num-copy! (real-tensor dcopy))
-(generate-typed-copy!-func complex-typed-copy! (complex-tensor zcopy))
-(generate-typed-num-copy!-func complex-typed-num-copy! (complex-tensor zcopy))
+(generate-typed-copy! complex-typed-copy! (complex-tensor zcopy))
+(generate-typed-num-copy! complex-typed-num-copy! (complex-tensor zcopy))
;;---------------------------------------------------------------;;
-
(defgeneric copy! (from-tensor to-tensor)
(:documentation
"
@@ -172,75 +171,33 @@
the type of Y. For example,
a COMPLEX-MATRIX cannot be copied to a
REAL-MATRIX but the converse is possible.
-"))
-
-(defmethod copy! :before ((x standard-matrix) (y standard-matrix))
- (mlet* (((nr-x nc-x) (slot-values x '(number-of-rows number-of-cols)) :type (fixnum fixnum))
- ((nr-y nc-y) (slot-values y '(number-of-rows number-of-cols)) :type (fixnum fixnum)))
- (unless (and (= nr-x nr-y) (= nc-x nc-y))
- (error "Arguments X,Y to COPY! are of different dimensions."))))
-
-;;
-(defmethod copy! ((x standard-matrix) (y standard-matrix))
- (mlet* (((nr-x nc-x) (slot-values x '(number-of-rows number-of-cols))
- :type (fixnum fixnum)))
- (dotimes (i nr-x)
- (dotimes (j nc-x)
- (declare (type fixnum i j))
- (setf (matrix-ref-2d y i j) (matrix-ref-2d x i j))))
- y))
-
-;;
-(generate-typed-copy!-func real-tensor-copy! (real-tensor dcopy))
-
-(generate-typed-copy!-func real-double-copy!-typed real-matrix-store-type real-matrix blas:dcopy)
-
-(generate-typed-num-copy!-func real-double-num-copy!-typed
- double-float real-matrix-store-type real-matrix
- blas:dcopy
- (num
- (1x1-array
- (allocate-real-store 1)
- (setf (aref 1x1-array 0) num)
- :type (real-matrix-store-type 1))))
-
-(defmethod copy! ((x complex-matrix) (y real-matrix))
- (error "Cannot copy a COMPLEX-MATRIX into a REAL-MATRIX,
-don't know how to coerce a COMPLEX to a REAL"))
-
-(defmethod copy! ((x complex) (y real-matrix))
- (error "Cannot copy ~a to ~a, don't know how to coerce COMPLEX to REAL"
- x y))
-
-(defmethod copy! ((x real-matrix) (y real-matrix))
- (real-double-copy!-typed x y))
-
-(defmethod copy! ((x cl:real) (y real-matrix))
- (real-double-num-copy!-typed (coerce x 'double-float) y))
-
-;;
-(generate-typed-copy!-func complex-double-copy!-typed complex-matrix-store-type complex-matrix blas:zcopy)
-
-(generate-typed-num-copy!-func complex-double-num-copy!-typed
- complex-double-float complex-matrix-store-type complex-matrix
- blas:zcopy
- (num
- (1x1-z-array
- (allocate-complex-store 1)
- (setf (aref 1x1-z-array 0) (realpart num)
- (aref 1x1-z-array 1) (imagpart num))
- :type (complex-matrix-store-type 2))))
-
-(defmethod copy! ((x complex-matrix) (y complex-matrix))
- (complex-double-copy!-typed x y))
-
-(defmethod copy! ((x real-matrix) (y complex-matrix))
- (real-double-copy!-typed x (mrealpart~ y))
- (scal! 0d0 (mimagpart~ y))
- y)
-
-(defmethod copy! ((x number) (y complex-matrix))
- (complex-double-num-copy!-typed (complex-coerce x) y))
+")
+ (:method :before ((x standard-tensor) (y standard-tensor))
+ (unless (same-dimension-p (dimensions x) (dimensions y))
+ (error 'tensor-dimension-mismatch)))
+ (:method ((x standard-tensor) (y standard-tensor))
+ (mod-dotimes (idx (dimensions x))
+ do (setf (tensor-ref y idx) (tensor-ref x idx)))
+ y)
+ (:method ((x complex-tensor) (y real-tensor))
+ (error 'coercion-error :from 'complex-tensor :to 'real-tensor)))
+
+(defmethod copy! ((x real-tensor) (y real-tensor))
+ (real-typed-copy! x y))
+
+(defmethod copy! ((x number) (y real-tensor))
+ (real-typed-num-copy! (coerce-real x) y))
+
+(defmethod copy! ((x complex-matrix) (y complex-tensor))
+ (complex-typed-copy! x y))
+
+;; (defmethod copy! ((x real-matrix) (y complex-tensor))
+;; (real-double-copy!-typed x (mrealpart~ y))
+;; (scal! 0d0 (mimagpart~ y))
+;; y)
+
+(defmethod copy! ((x number) (y complex-tensor))
+ (complex-typed-num-copy! (coerce-complex x) y))
;;;;
(defgeneric copy (matrix)
diff --git a/src/loopy.lisp b/src/loopy.lisp
index 61c218f..9b27ad1 100644
--- a/src/loopy.lisp
+++ b/src/loopy.lisp
@@ -1,23 +1,5 @@
(in-package :matlisp)
-(defun column-major-p (offsets dims)
- (loop
- for off across offsets
- and dim across dims
- and accumulated-off = 1 then (* accumulated-off dim)
- unless (= off accumulated-off) do (return nil)
- finally (return t)))
-
-(defun row-major-p (offsets dims)
- (very-quickly
- (loop
- for idx of-type index-type from (1- (length dims)) downto 0
- for dim of-type index-type = (aref dims idx)
- for off of-type index-type = (aref offsets idx)
- and accumulated-off of-type index-type = 1 then (* accumulated-off dim)
- unless (= off accumulated-off) do (return nil)
- finally (return t))))
-
(defmacro mod-dotimes ((idx dims) &body body)
"
(mod-dotimes (idx {seq}) compound-form*)
diff --git a/src/realimag.lisp b/src/realimag.lisp
index 7f59e78..2036121 100644
--- a/src/realimag.lisp
+++ b/src/realimag.lisp
@@ -64,35 +64,53 @@
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(in-package "MATLISP")
+(in-package #:matlisp)
-(defun mrealpart~ (mat)
+(defun tensor-realpart~ (tensor)
"
Syntax
======
- (MREALPART~ matrix)
+ (tensor-realpart~ tensor)
Purpose
=======
- Returns a new SUB-REAL-MATRIX which is the real part of \"matrix\".
+ Returns a new tensor object which points to the real part of TENSOR.
+ Store is shared with TENSOR.
- Store is shared with \"matrix\".
-
- If \"matrix\" is a scalar, returns its real part.
-
- See IMAG, REALPART, IMAGPART
+ If TENSOR is a scalar, returns its real part.
"
+ (etypecase tensor
+ (real-tensor tensor)
+ (complex-tensor (make-instance 'real-sub-tensor
+ :parent-tensor tensor :store (store tensor)
+ :dimensions (dimensions tensor)
+ :strides (map '(index-array *) #'(lambda (x) (* 2 x)) (strides xten))
+ :head (the index-type (* 2 (head tensor)))))
+ (number (realpart tensor))))
+
+(defun tensor-imagpart~ (tensor)
+"
+ Syntax
+ ======
+ (tensor-imagpart~ tensor)
+
+ Purpose
+ =======
+ Returns a new tensor object which points to the \"imaginary\" part of TENSOR.
+ Store is shared with TENSOR.
- (typecase mat
- (real-matrix mat)
- (complex-matrix (make-instance 'sub-real-matrix
- :parent mat :store (store mat)
- :nrows (nrows mat) :ncols (ncols mat)
- :row-stride (* 2 (row-stride mat)) :col-stride (* 2 (col-stride mat))
- :head (* 2 (head mat))))
- (number (cl:realpart mat))))
-
-(defun mrealpart (mat)
+ If TENSOR is a scalar, returns its imaginary part.
+"
+ (etypecase tensor
+ (real-tensor tensor)
+ (complex-tensor (make-instance 'real-sub-tensor
+ :parent-tensor tensor :store (store tensor)
+ :dimensions (dimensions tensor)
+ :strides (map '(index-array *) #'(lambda (x) (* 2 x)) (strides xten))
+ :head (the index-type (+ 1 (* 2 (head tensor))))))
+ (number (imagpart tensor))))
+
+(defun tensor-realpart (mat)
"
Syntax
======
@@ -115,34 +133,6 @@
:head (* 2 (head mat)))))
(number (cl:realpart mat))))
-(defun mimagpart~ (mat)
-"
- Syntax
- ======
- (MIMAGPART~ matrix)
-
- Purpose
- =======
- Returns a new SUB-REAL-MATRIX which is the imaginary part of \"matrix\".
-
- Store is shared with \"matrix\".
-
- If \"matrix\" is a real-matrix, returns nil.
-
- If \"matrix\" is a scalar, returns its imaginary part.
-
- See IMAG, REALPART, IMAGPART
-"
- (typecase mat
- (real-matrix nil)
- (complex-matrix (make-instance 'sub-real-matrix
- :parent mat :store (store mat)
- :nrows (nrows mat) :ncols (ncols mat)
- :row-stride (* 2 (row-stride mat)) :col-stride (* 2 (col-stride mat))
- :head (+ 1 (* 2 (head mat)))))
- (number (cl:imagpart mat))))
-
-
(defun mimagpart (mat)
"
Syntax
@@ -198,4 +188,4 @@
See REAL, REALPART, IMAGPART
"
- (mimagpart matrix))
\ No newline at end of file
+ (mimagpart matrix))
diff --git a/src/scal.lisp b/src/scal.lisp
index a81af20..e0de476 100644
--- a/src/scal.lisp
+++ b/src/scal.lisp
@@ -67,34 +67,40 @@
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(in-package "MATLISP")
-
-(defmacro generate-typed-scal!-func (func element-type store-type matrix-type blas-func)
- ;;Be very careful when using functions generated by this macro.
- ;;Indexes can be tricky and this has no safety net
- ;;(you don't see a matrix-ref do you ?)
- ;;Use only after checking the arguments for compatibility.
- `(defun ,func (alpha mat-x)
- (declare (type ,matrix-type mat-x)
- (type ,element-type alpha)
- (optimize (safety 0) (speed 3)))
- (mlet* (((cp-x inc-x sz-x) (blas-copyable-p mat-x)
- :type (boolean fixnum fixnum))
- ((hd-x st-x) (slot-values mat-x '(head store))
- :type (fixnum (,store-type *))))
- (if cp-x
- (,blas-func sz-x alpha st-x inc-x :head-x hd-x)
- (mlet* (((nr-x nc-x rs-x cs-x) (slot-values mat-x '(number-of-rows number-of-cols row-stride col-stride))
- :type (fixnum fixnum fixnum fixnum)))
- ;;Choose the smaller of the loops.
- (when (> (nrows mat-x) (ncols mat-x))
- (rotatef nr-x nc-x)
- (rotatef rs-x cs-x))
- (loop for i from 0 below nr-x
- do (,blas-func nc-x alpha st-x cs-x :head-x (+ hd-x (* i rs-x)))))))
- mat-x))
-
-;;
+(in-package #:matlisp)
+
+(defmacro generate-typed-scal! (func (tensor-class blas-func))
+ (let ((opt (get-tensor-class-optimization tensor-class)))
+ (assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
+ `(defun ,func (alpha to)
+ (declare (type ,tensor-class to)
+ (type ,(getf opt :element-type) alpha))
+ (let ((t-dims (dimensions to))
+ (t-stds (strides to))
+ (t-sto (store to))
+ (t-hd (head to)))
+ (declare (type (index-array *) t-dims t-stds)
+ (type index-type t-hd)
+ (type ,(linear-array-type (getf opt :store-type)) t-sto))
+ (if-let (min-stride (consecutive-store-p t-stds t-dims))
+ (,blas-func (number-of-elements to) alpha t-sto min-stride t-hd)
+ (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 t-dims)
+ with (linear-sums
+ (t-of t-stds t-hd))
+ do (let ((scal-val (* ,(funcall (getf opt :reader) 't-sto 't-of) alpha)))
+ ,(funcall (getf opt :value-writer) 'scal-val 't-sto 't-of))))))
+ to)))
+
+;; TODO: Maybe add zdscal support ? Don't think the difference between
+;; zdscal and zscal is significant, except for very large arrays.
+(generate-typed-scal! real-typed-scal! (real-tensor dscal))
+(generate-typed-scal! complex-typed-scal! (complex-tensor zscal))
+
+;;---------------------------------------------------------------;;
(defgeneric scal! (alpha x)
(:documentation
"
@@ -104,36 +110,16 @@
Purpose
=======
- Same as SCAL except that the result is
- stored in X.
+ X <- alpha .* X
"))
-;;
-(generate-typed-scal!-func real-double-dscal!-typed double-float real-matrix-store-type real-matrix blas:dscal)
-
-(defmethod scal! ((alpha number) (x number))
- (error "Cannot SCAL! two scalars, arg X must
-be a matrix to SCAL!"))
-
-(defmethod scal! ((alpha complex) (x real-matrix))
- (error "Cannot SCAL! a REAL-MATRIX by a COMPLEX, don't know
-how to coerce COMPLEX to REAL"))
+(defmethod scal! ((alpha number) (x real-tensor))
+ (real-typed-scal! (coerce-real alpha) x))
-(defmethod scal! ((alpha cl:real) (x real-matrix))
- (real-double-dscal!-typed (coerce alpha 'double-float) x))
+(defmethod scal! ((alpha number) (x complex-tensor))
+ (complex-typed-scal! (coerce-complex alpha) x))
;;
-(generate-typed-scal!-func complex-double-dscal!-typed double-float complex-matrix-store-type complex-matrix blas:zdscal)
-
-(generate-typed-scal!-func complex-double-zscal!-typed complex-double-float complex-matrix-store-type complex-matrix blas:zscal)
-
-(defmethod scal! ((alpha cl:real) (x complex-matrix))
- (complex-double-dscal!-typed (coerce alpha 'double-float) x))
-
-(defmethod scal! ((alpha complex) (x complex-matrix))
- (complex-double-zscal!-typed (complex-coerce alpha) x))
-
-;;;;
(defgeneric scal (alpha x)
(:documentation
"
@@ -143,11 +129,11 @@ how to coerce COMPLEX to REAL"))
Purpose
=======
- Computes and returns a new matrix equal to
+ Computes and returns a new tensor equal to
- alpha * X
+ alpha .* X
- where alpha is a scalar and X is a matrix.
+ where alpha is a scalar and X is a tensor.
"))
@@ -170,4 +156,4 @@ how to coerce COMPLEX to REAL"))
;;
(defmethod scal ((alpha number) (x complex-matrix))
(let ((result (copy x)))
- (scal! alpha result)))
\ No newline at end of file
+ (scal! alpha result)))
diff --git a/src/tensor-copy.lisp b/src/tensor-copy.lisp
deleted file mode 100644
index 9550fb6..0000000
--- a/src/tensor-copy.lisp
+++ /dev/null
@@ -1,60 +0,0 @@
-(in-package :matlisp)
-
-;;TODO-> use macrofied setf-ers and old {d, z} copy code to automate code-generation.
-(defun tensor-copy (from to)
- (declare (type real-tensor to from))
- (let ((st-f (store from))
- (st-t (store to)))
- (declare (type (real-array *) st-f st-t))
- (very-quickly
- (mod-dotimes (idx (dimensions from))
- with (linear-sums
- (of-t (strides to) (head to))
- (of-f (strides from) (head from)))
- do (setf (aref st-t of-t) (aref st-f of-f))))))
-
-(defun dimensions-check (a b)
- (declare (type (index-array *) a b))
- (let ((l-a (length a)))
- (when (= l-a (length b))
- (very-quickly
- (loop
- for i from 0 below l-a
- unless (= (aref a i) (aref b i))
- do (return nil)
- finally (return t))))))
-
-
-(defmacro generate-typed-copy!-func (func (tensor-class blas-func))
- ;;Be very careful when using functions generated by this macro.
- ;;Indexes can be tricky and this has no safety net
- ;;Use only after checking the arguments for compatibility.
- (let* ((opt (get-tensor-class-optimization tensor-class)))
- `(defun ,func (from to)
- (declare (type tensor-type from to))
- (let ((f-dims (dimensions from))
- (f-stds (strides from))
- (f-sto (store from))
- (f-hd (head from))
- (t-dims (dimensions to))
- (t-stds (strides to))
- (t-sto (store to))
- (t-hd (head to)))
- (declare (type (index-array *) f-dims f-stds t-dims t-stds)
- (type index-type f-hd t-hd)
- (type ,(linear-array-type (getf opt :store-type)) f-sto t-sto))
- (if (or (and (row-major-p t-stds t-dims) (row-major-p f-stds f-dims))
- (and (col-major-p t-stds t-dims) (col-major-p f-stds f-dims)))
- (,blas-func (number-of-elements from) f-sto 1 t-sto 1 f-hd t-hd)
- (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 f-dims)
- with (linear-sums
- (f-of f-stds f-hd)
- (t-of t-stds t-hd))
- do ,(funcall (getf opt :reader-writer) 'f-sto 'f-of 't-sto 't-of))))
- to))))
-
-(generate-typed-copy!-func real-tensor-copy! (real-tensor dcopy))
diff --git a/src/utilities.lisp b/src/utilities.lisp
index a475531..3a26d44 100644
--- a/src/utilities.lisp
+++ b/src/utilities.lisp
@@ -234,6 +234,14 @@
(apply #'format (append `(,ostr ,fmt) args)))
ret))
+(declaim (inline seq-max))
+(defun seq-max (seq)
+ (reduce #'max seq))
+
+(declaim (inline seq-max))
+(defun seq-min (seq)
+ (reduce #'min seq))
+
;;---------------------------------------------------------------;;
(defstruct (foreign-vector
(:conc-name fv-)
-----------------------------------------------------------------------
Summary of changes:
TODO | 8 +
matlisp.asd | 530 +++++++++++++++++++++++-----------------------
packages.lisp | 63 +++---
src/blas-helpers.lisp | 54 +++++-
src/complex-tensor.lisp | 7 +-
src/conditions.lisp | 19 ++
src/copy.lisp | 111 +++-------
src/loopy.lisp | 18 --
src/realimag.lisp | 86 ++++-----
src/scal.lisp | 100 ++++-----
src/tensor-copy.lisp | 60 ------
src/utilities.lisp | 8 +
12 files changed, 504 insertions(+), 560 deletions(-)
create mode 100644 TODO
delete mode 100644 src/tensor-copy.lisp
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2012-06-28 09:40:39
|
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 848eaaca232c394753e19a057fa732c9937a8a39 (commit)
from 8aff3fd16623c50df552430e3734fc65d11a55b1 (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 848eaaca232c394753e19a057fa732c9937a8a39
Author: Akshay Srinivasan <aks...@gm...>
Date: Thu Jun 28 15:05:39 2012 +0530
Added premature support for permutations.
Need this for generalised currying, composition
and transposes.
diff --git a/src/copy.lisp b/src/copy.lisp
index f9fd7ef..91c1031 100644
--- a/src/copy.lisp
+++ b/src/copy.lisp
@@ -144,10 +144,11 @@
to))))
(generate-typed-copy!-func real-typed-copy! (real-tensor dcopy))
-(generate-typed-copy!-func real-typed-num-copy! (real-tensor dcopy))
+(generate-typed-num-copy!-func real-typed-num-copy! (real-tensor dcopy))
(generate-typed-copy!-func complex-typed-copy! (complex-tensor zcopy))
-(generate-typed-copy!-func complex-typed-num-copy! (complex-tensor zcopy))
+(generate-typed-num-copy!-func complex-typed-num-copy! (complex-tensor zcopy))
+;;---------------------------------------------------------------;;
(defgeneric copy! (from-tensor to-tensor)
(:documentation
diff --git a/src/permutations.lisp b/src/permutations.lisp
new file mode 100644
index 0000000..797e198
--- /dev/null
+++ b/src/permutations.lisp
@@ -0,0 +1,155 @@
+(in-package :matlisp)
+
+(define-condition permutation-error (generic-error)
+ ((message :reader message :initform "Object is not a permutation."))
+ (:documentation "Object is not a permutation."))
+
+;;---------------------------------------------------------------;;
+(defun insert-element (x sort l-b u-b)
+ "Does a binary-esque sort to keep track of elements in
+ a permutation, in descending order. If there are duplicates
+ of X in sort between L-B and U-B (both inclusive), or if X < 0,
+ then throws a PERMUTATION-ERROR."
+ (declare (type index-type x l-b u-b)
+ (type (index-array *) sort))
+ (let* ((len u-b))
+ (labels ((insert-ele (l-b u-b)
+ (declare (type index-type l-b u-b))
+ (let* ((midx (+ l-b (floor (- u-b l-b) 2)))
+ (mid (aref sort midx)))
+ (cond
+ ((or (< x 0) (member x `(,(aref sort u-b) ,(aref sort l-b) ,mid)))
+ (error 'permutation-error))
+ ((= midx l-b)
+ (when (> x (aref sort u-b))
+ (loop
+ with sidx = (+ midx (if (> x mid) 0 1))
+ for i downfrom (- len 1) to sidx
+ do (setf (aref sort (+ i 1)) (aref sort i))
+ finally (setf (aref sort sidx) x))))
+ ((< x mid) (insert-ele midx u-b))
+ ((> x mid) (insert-ele l-b midx)))
+ sort)))
+ (insert-ele l-b u-b))))
+
+(defun cycle-p (perm)
+ "Does a sorting operation to check for duplicate elements in
+ the cycle representation of a permutation."
+ (let* ((len (length perm))
+ (sort (allocate-index-store len -1)))
+ (dotimes (i len t)
+ (handler-case (insert-element (aref perm i) sort 0 i)
+ (permutation-error () (return nil))))))
+
+(defun action-p (arr)
+ "Checks if ARR is a possible permutation vector. A permutation pi
+ is characterized by a vector containing the indices from 0,...,
+ @function{length}(@arg{perm})-1 in some order."
+ (declare (type (index-array *) arr))
+ (let ((s-arr (sort (copy-seq arr) #'<)))
+ (dotimes (i (length s-arr) t)
+ (unless (= i (aref s-arr i))
+ (return nil)))))
+
+(defun action->cycle (per)
+ ;;Caution: will go into an infinite loop if object is not proper.
+ "This function obtains the canonical cycle representation
+ of a permutation. The first argument is the action of the
+ permutation on the array #(0 1 2 3 ..).
+ \"Canonical\" may be a bit of an overstatement; this is the way
+ S_n was presented by Van der Waerden."
+ (declare (type permutation-action per))
+ (mlet*
+ ((arr (r-value per) :type (index-array *)))
+ (labels ((find-cycle (arr x0)
+ "This function obtains a permutation cycle starting from x_0.
+ The first argument is the action of the permutation on the
+ array #(0 1 2 ..)"
+ (declare (type (index-array *) arr)
+ (type index-type x0))
+ (if (= (aref arr x0) x0) (values #() nil)
+ (destructuring-bind (n lst)
+ (do ((i 0 (+ i 1))
+ (x x0 (aref arr x))
+ (ret nil (cons x ret))
+ (count 0 (+ count (if (= x x0) 1 0))))
+ ((and (= count 1) (= x x0)) (list i ret)))
+ (values (make-array n :element-type 'index-type :initial-contents lst) lst))))
+ (cycle-walk (cyc ignore)
+ (declare (optimize (speed 3) (safety 0)))
+ (let ((x0 (find-if-not #'(lambda (x) (member x ignore)) arr)))
+ (if (null x0) cyc
+ (multiple-value-bind (cnew clst) (find-cycle arr x0)
+ (cycle-walk (if (null clst) cyc (cons cnew cyc))
+ (nconc ignore (if (null clst) (list x0) clst))))))))
+ (cycle-walk nil nil))))
+;;---------------------------------------------------------------;;
+
+(defclass permutation ()
+ ((representation :accessor r-value
+ :initarg :r-value)
+ (group-rank :accessor group-rank
+ :type index-type)))
+
+(defclass permutation-cycle (permutation)
+ ((representation :type cons)))
+
+(defmethod initialize-instance :after ((per permutation-cycle) &rest initargs)
+ (declare (ignore initargs))
+ (let ((cls 0))
+ (unless (dolist (cyc (r-value per) t)
+ (unless (cycle-p cyc)
+ (return nil))
+ (setf cls (max cls (reduce #'max cyc))))
+ (error 'permutation-error))
+ (setf (group-rank per) (1+ cls))))
+
+(defclass permutation-action (permutation)
+ ((:representation :type (index-array *))))
+
+(defmethod initialize-instance :after ((per permutation-action) &rest initargs)
+ (declare (ignore initargs))
+ (unless (action-p (r-value per))
+ (error 'permutation-error)))
+
+(defun cycles->action (cyc)
+ )
+
+
+
+;;
+(defun apply-cycle! (seq cyc)
+ (declare (type (index-array *) cyc)
+ (type (vector * *) seq))
+ (unless (cycle-p cyc)
+ (error 'permutation-error))
+ (when (> (length cyc) 1)
+ (let ((xl (aref seq (aref cyc (- (length cyc) 1)))))
+ (loop for i downfrom (- (length cyc) 1) to 0
+ do (setf (aref seq (aref cyc i))
+ (if (= i 0) xl
+ (aref seq (aref cyc (- i 1))))))))
+ seq)
+
+(defun permute! (seq cycs)
+ (unless (or (null cycs) (= (length seq) 0))
+ (dolist (cyc cycs)
+ (apply-cycle! seq cyc)))
+ seq)
+
+(defun arg-perm (func cycs)
+ (if (null cycs)
+ func
+ (lambda (&rest args)
+ (let ((argvec (permute! (apply #'vector args) cycs)))
+ (apply func (loop for i from 0 below (length argvec)
+ collect (aref argvec i)))))))
+
+(defun compose (func func)
+
+;; (defun compose (..)
+;; )
+
+(defun seqrnd (seq)
+ "Randomize the elements of a sequence. Destructive on SEQ."
+ (sort seq #'> :key #'(lambda (x) (random 1.0))))
\ No newline at end of file
-----------------------------------------------------------------------
Summary of changes:
src/copy.lisp | 5 +-
src/permutations.lisp | 155 +++++++++++++++++++++++++++++++++++++++++++++++++
2 files changed, 158 insertions(+), 2 deletions(-)
create mode 100644 src/permutations.lisp
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2012-06-28 09:14:25
|
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 8aff3fd16623c50df552430e3734fc65d11a55b1 (commit)
via 8df10fb5dce5cc4da3e196d0ae94494857a53f50 (commit)
from 82125cbf389c2f1bc43a5c661067400efcec64c3 (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 8aff3fd16623c50df552430e3734fc65d11a55b1
Author: Akshay Srinivasan <aks...@gm...>
Date: Thu Jun 28 14:39:23 2012 +0530
Added basic copy-generation macros.
diff --git a/matlisp.asd b/matlisp.asd
index 1a5eecc..371e5a9 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -86,6 +86,8 @@
"foreign-functions")
:components ((:file "conditions")
(:file "standard-tensor")
+ (:file "loopy"
+ :depends-on ("standard-tensor"))
(:file "real-tensor"
:depends-on ("standard-tensor"))
(:file "complex-tensor"
diff --git a/packages.lisp b/packages.lisp
index cbe1052..ee8fbf4 100644
--- a/packages.lisp
+++ b/packages.lisp
@@ -161,7 +161,8 @@
#:slot-values
#:recursive-append #:unquote-args #:flatten
#:format-to-string #:string+
- #:linear-array-type
+ #:linear-array-type
+ #:seq-max #:seq-min
;;Macros
#:when-let #:if-let #:if-ret #:with-gensyms #:let-rec
#:mlet* #:make-array-allocator
diff --git a/src/blas.lisp b/src/blas.lisp
index 8f3e25b..3222da9 100644
--- a/src/blas.lisp
+++ b/src/blas.lisp
@@ -3,14 +3,14 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Copyright (c) 2000 The Regents of the University of California.
-;;; All rights reserved.
-;;;
+;;; All rights reserved.
+;;;
;;; Permission is hereby granted, without written agreement and without
;;; license or royalty fees, to use, copy, modify, and distribute this
;;; software and its documentation for any purpose, provided that the
;;; above copyright notice and the following two paragraphs appear in all
;;; copies of this software.
-;;;
+;;;
;;; IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY
;;; FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
;;; ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF
@@ -63,37 +63,37 @@
"
Syntax
======
-
+
(DAXPY n a x incx y incy)
Purpose
=======
Y <- A*X + Y
-
+
Arguments
=========
N (input) FIXNUM
- Number of elements of X,Y to be operated on.
-
+ Number of elements of X,Y to be operated on.
+
A (input) DOUBLE-FLOAT
- X (input) (SIMPLE-ARRAY DOUBLE-FLOAT (*))
- INCX (input) FIXNUM
- Determines the position of the elements in X. Usually
- INCX is 1. If INCX is bigger than 1 then the elements
- considered in the operations are:
+ X (input) (SIMPLE-ARRAY DOUBLE-FLOAT (*))
+ INCX (input) FIXNUM
+ Determines the position of the elements in X. Usually
+ INCX is 1. If INCX is bigger than 1 then the elements
+ considered in the operations are:
- X(0),X(INCX), ... , X((N-1)*INCX)
+ X(0),X(INCX), ... , X((N-1)*INCX)
Y (input/output) (SIMPLE-ARRAY DOUBLE-FLOAT (*))
- INCY (input) FIXNUM
- Determines the position of the elements in Y. Usually
- INCY is 1. If INCY is bigger than 1 then the elements
- considered in the operations are:
+ INCY (input) FIXNUM
+ Determines the position of the elements in Y. Usually
+ INCY is 1. If INCY is bigger than 1 then the elements
+ considered in the operations are:
- Y(0),Y(INCY), ... , Y((N-1)*INCY)
-"
+ Y(0),Y(INCY), ... , Y((N-1)*INCY)
+"
(n :integer :input)
(da :double-float :input)
(dx (* :double-float :inc head-x))
@@ -106,36 +106,36 @@
"
Syntax
======
-
+
(DCOPY n x incx y incy)
Purpose
=======
Y <- X
-
+
Arguments
=========
N (input) FIXNUM
- Number of elements of X,Y to be operated on.
-
- X (input) (SIMPLE-ARRAY DOUBLE-FLOAT (*))
- INCX (input) FIXNUM
- Determines the position of the elements in X. Usually
- INCX is 1. If INCX is bigger than 1 then the elements
- considered in the operations are:
+ Number of elements of X,Y to be operated on.
+
+ X (input) (SIMPLE-ARRAY DOUBLE-FLOAT (*))
+ INCX (input) FIXNUM
+ Determines the position of the elements in X. Usually
+ INCX is 1. If INCX is bigger than 1 then the elements
+ considered in the operations are:
- X(0),X(INCX), ... , X((N-1)*INCX)
+ X(0),X(INCX), ... , X((N-1)*INCX)
Y (input/output) (SIMPLE-ARRAY DOUBLE-FLOAT (*))
- INCY (input) FIXNUM
- Determines the position of the elements in Y. Usually
- INCY is 1. If INCY is bigger than 1 then the elements
- considered in the operations are:
+ INCY (input) FIXNUM
+ Determines the position of the elements in Y. Usually
+ INCY is 1. If INCY is bigger than 1 then the elements
+ considered in the operations are:
- Y(0),Y(INCY), ... , Y((N-1)*INCY)
-"
+ Y(0),Y(INCY), ... , Y((N-1)*INCY)
+"
(n :integer :input)
(dx (* :double-float :inc head-x))
(incx :integer :input)
@@ -166,28 +166,28 @@
"
Syntax
======
-
+
(DSCAL n a x incx)
Purpose
=======
X <- A*X
-
+
Arguments
=========
N (input) FIXNUM
- Number of elements of X to be operated on.
-
- X (input) (SIMPLE-ARRAY DOUBLE-FLOAT (*))
- INCX (input) FIXNUM
- Determines the position of the elements in X. Usually
- INCX is 1. If INCX is bigger than 1 then the elements
- considered in the operations are:
-
- X(0),X(INCX), ... , X((N-1)*INCX)
-"
+ Number of elements of X to be operated on.
+
+ X (input) (SIMPLE-ARRAY DOUBLE-FLOAT (*))
+ INCX (input) FIXNUM
+ Determines the position of the elements in X. Usually
+ INCX is 1. If INCX is bigger than 1 then the elements
+ considered in the operations are:
+
+ X(0),X(INCX), ... , X((N-1)*INCX)
+"
(n :integer :input)
(da :double-float :input)
(dx (* :double-float :inc head-x) :output)
@@ -198,36 +198,36 @@
"
Syntax
======
-
+
(DSWAP n x incx y incy)
Purpose
=======
Y <-> X
-
+
Arguments
=========
N (input) FIXNUM
- Number of elements of X,Y to be operated on.
-
- X (input) (SIMPLE-ARRAY DOUBLE-FLOAT (*))
- INCX (input) FIXNUM
- Determines the position of the elements in X. Usually
- INCX is 1. If INCX is bigger than 1 then the elements
- considered in the operations are:
+ Number of elements of X,Y to be operated on.
+
+ X (input) (SIMPLE-ARRAY DOUBLE-FLOAT (*))
+ INCX (input) FIXNUM
+ Determines the position of the elements in X. Usually
+ INCX is 1. If INCX is bigger than 1 then the elements
+ considered in the operations are:
- X(0),X(INCX), ... , X((N-1)*INCX)
+ X(0),X(INCX), ... , X((N-1)*INCX)
Y (input/output) (SIMPLE-ARRAY DOUBLE-FLOAT (*))
- INCY (input) FIXNUM
- Determines the position of the elements in Y. Usually
- INCY is 1. If INCY is bigger than 1 then the elements
- considered in the operations are:
+ INCY (input) FIXNUM
+ Determines the position of the elements in Y. Usually
+ INCY is 1. If INCY is bigger than 1 then the elements
+ considered in the operations are:
- Y(0),Y(INCY), ... , Y((N-1)*INCY)
-"
+ Y(0),Y(INCY), ... , Y((N-1)*INCY)
+"
(n :integer :input)
(dx (* :double-float) :output)
(incx :integer :input)
@@ -239,37 +239,37 @@
"
Syntax
======
-
+
(ZAXPY n a x incx y incy)
Purpose
=======
Y <- A*X + Y
-
+
Arguments
=========
N (input) FIXNUM
- Number of elements of X,Y to be operated on.
-
+ Number of elements of X,Y to be operated on.
+
A (input) (COMPLEX DOUBLE-FLOAT)
- X (input) (SIMPLE-ARRAY (COMPLEX DOUBLE-FLOAT) (*)) represented as (SIMPLE-ARRAY DOUBLE-FLOAT (*))
- INCX (input) FIXNUM
- Determines the position of the elements in X. Usually
- INCX is 1. If INCX is bigger than 1 then the elements
- considered in the operations are:
+ X (input) (SIMPLE-ARRAY (COMPLEX DOUBLE-FLOAT) (*)) represented as (SIMPLE-ARRAY DOUBLE-FLOAT (*))
+ INCX (input) FIXNUM
+ Determines the position of the elements in X. Usually
+ INCX is 1. If INCX is bigger than 1 then the elements
+ considered in the operations are:
- X(0),X(2*INCX), ... , X(2*(N-1)*INCX)
+ X(0),X(2*INCX), ... , X(2*(N-1)*INCX)
- Y (input/output) (SIMPLE-ARRAY (COMPLEX DOUBLE-FLOAT) (*)) represented as (SIMPLE-ARRAY DOUBLE-FLOAT (*))
+ Y (input/output) (SIMPLE-ARRAY (COMPLEX DOUBLE-FLOAT) (*)) represented as (SIMPLE-ARRAY DOUBLE-FLOAT (*))
INCY (input) FIXNUM
- Determines the position of the elements in Y. Usually
- INCY is 1. If INCY is bigger than 1 then the elements
- considered in the operations are:
+ Determines the position of the elements in Y. Usually
+ INCY is 1. If INCY is bigger than 1 then the elements
+ considered in the operations are:
- Y(0),Y(2*INCY), ... , Y(2*(N-1)*INCY)
-"
+ Y(0),Y(2*INCY), ... , Y(2*(N-1)*INCY)
+"
(n :integer :input)
(za :complex-double-float)
(zx (* :complex-double-float :inc head-x))
@@ -282,37 +282,37 @@
"
Syntax
======
-
+
(ZCOPY n x incx y incy)
Purpose
=======
Y <- X
-
+
Arguments
=========
N (input) FIXNUM
- Number of elements of X,Y to be operated on.
-
+ Number of elements of X,Y to be operated on.
+
A (input) (COMPLEX DOUBLE-FLOAT)
- X (input) (SIMPLE-ARRAY (COMPLEX DOUBLE-FLOAT) (*)) represented as (SIMPLE-ARRAY DOUBLE-FLOAT (*))
- INCX (input) FIXNUM
- Determines the position of the elements in X. Usually
- INCX is 1. If INCX is bigger than 1 then the elements
- considered in the operations are:
+ X (input) (SIMPLE-ARRAY (COMPLEX DOUBLE-FLOAT) (*)) represented as (SIMPLE-ARRAY DOUBLE-FLOAT (*))
+ INCX (input) FIXNUM
+ Determines the position of the elements in X. Usually
+ INCX is 1. If INCX is bigger than 1 then the elements
+ considered in the operations are:
- X(0),X(2*INCX), ... , X(2*(N-1)*INCX)
+ X(0),X(2*INCX), ... , X(2*(N-1)*INCX)
- Y (input/output) (SIMPLE-ARRAY (COMPLEX DOUBLE-FLOAT) (*)) represented as (SIMPLE-ARRAY DOUBLE-FLOAT (*))
+ Y (input/output) (SIMPLE-ARRAY (COMPLEX DOUBLE-FLOAT) (*)) represented as (SIMPLE-ARRAY DOUBLE-FLOAT (*))
INCY (input) FIXNUM
- Determines the position of the elements in Y. Usually
- INCY is 1. If INCY is bigger than 1 then the elements
- considered in the operations are:
+ Determines the position of the elements in Y. Usually
+ INCY is 1. If INCY is bigger than 1 then the elements
+ considered in the operations are:
- Y(0),Y(2*INCY), ... , Y(2*(N-1)*INCY)
-"
+ Y(0),Y(2*INCY), ... , Y(2*(N-1)*INCY)
+"
(n :integer :input)
(zx (* :complex-double-float :inc head-x))
(incx :integer :input)
@@ -324,29 +324,29 @@
"
Syntax
======
-
+
(ZDSCAL n a x incx)
Purpose
=======
X <- A*X
-
+
Arguments
=========
N (input) FIXNUM
- Number of elements of X to be operated on.
-
+ Number of elements of X to be operated on.
+
A (input) DOUBLE-FLOAT
- X (input) (SIMPLE-ARRAY (COMPLEX DOUBLE-FLOAT) (*)) represented as (SIMPLE-ARRAY DOUBLE-FLOAT (*))
- INCX (input) FIXNUM
- Determines the position of the elements in X. Usually
- INCX is 1. If INCX is bigger than 1 then the elements
- considered in the operations are:
-
- X(0),X(2*INCX), ... , X(2*(N-1)*INCX)
-"
+ X (input) (SIMPLE-ARRAY (COMPLEX DOUBLE-FLOAT) (*)) represented as (SIMPLE-ARRAY DOUBLE-FLOAT (*))
+ INCX (input) FIXNUM
+ Determines the position of the elements in X. Usually
+ INCX is 1. If INCX is bigger than 1 then the elements
+ considered in the operations are:
+
+ X(0),X(2*INCX), ... , X(2*(N-1)*INCX)
+"
(n :integer :input)
(da :double-float :input)
(zx (* :complex-double-float :inc head-x) :output)
@@ -366,29 +366,29 @@
"
Syntax
======
-
+
(ZSCAL n a x incx)
Purpose
=======
X <- A*X
-
+
Arguments
=========
N (input) FIXNUM
- Number of elements of X to be operated on.
-
+ Number of elements of X to be operated on.
+
A (input) (COMPLEX DOUBLE-FLOAT)
- X (input) (SIMPLE-ARRAY (COMPLEX DOUBLE-FLOAT) (*)) represented as (SIMPLE-ARRAY DOUBLE-FLOAT (*))
- INCX (input) FIXNUM
- Determines the position of the elements in X. Usually
- INCX is 1. If INCX is bigger than 1 then the elements
- considered in the operations are:
-
- X(0),X(2*INCX), ... , X(2*(N-1)*INCX)
-"
+ X (input) (SIMPLE-ARRAY (COMPLEX DOUBLE-FLOAT) (*)) represented as (SIMPLE-ARRAY DOUBLE-FLOAT (*))
+ INCX (input) FIXNUM
+ Determines the position of the elements in X. Usually
+ INCX is 1. If INCX is bigger than 1 then the elements
+ considered in the operations are:
+
+ X(0),X(2*INCX), ... , X(2*(N-1)*INCX)
+"
(n :integer :input)
(za :complex-double-float)
(zx (* :complex-double-float :inc head-x) :output)
@@ -399,37 +399,37 @@
"
Syntax
======
-
+
(ZSWAP n x incx y incy)
Purpose
=======
Y <-> X
-
+
Arguments
=========
N (input) FIXNUM
- Number of elements of X,Y to be operated on.
-
+ Number of elements of X,Y to be operated on.
+
A (input) (COMPLEX DOUBLE-FLOAT)
- X (input) (SIMPLE-ARRAY (COMPLEX DOUBLE-FLOAT) (*)) represented as (SIMPLE-ARRAY DOUBLE-FLOAT (*))
- INCX (input) FIXNUM
- Determines the position of the elements in X. Usually
- INCX is 1. If INCX is bigger than 1 then the elements
- considered in the operations are:
+ X (input) (SIMPLE-ARRAY (COMPLEX DOUBLE-FLOAT) (*)) represented as (SIMPLE-ARRAY DOUBLE-FLOAT (*))
+ INCX (input) FIXNUM
+ Determines the position of the elements in X. Usually
+ INCX is 1. If INCX is bigger than 1 then the elements
+ considered in the operations are:
- X(0),X(2*INCX), ... , X(2*(N-1)*INCX)
+ X(0),X(2*INCX), ... , X(2*(N-1)*INCX)
- Y (input/output) (SIMPLE-ARRAY (COMPLEX DOUBLE-FLOAT) (*)) represented as (SIMPLE-ARRAY DOUBLE-FLOAT (*))
+ Y (input/output) (SIMPLE-ARRAY (COMPLEX DOUBLE-FLOAT) (*)) represented as (SIMPLE-ARRAY DOUBLE-FLOAT (*))
INCY (input) FIXNUM
- Determines the position of the elements in Y. Usually
- INCY is 1. If INCY is bigger than 1 then the elements
- considered in the operations are:
+ Determines the position of the elements in Y. Usually
+ INCY is 1. If INCY is bigger than 1 then the elements
+ considered in the operations are:
- Y(0),Y(2*INCY), ... , Y(2*(N-1)*INCY)
-"
+ Y(0),Y(2*INCY), ... , Y(2*(N-1)*INCY)
+"
(n :integer :input)
(zx (* :complex-double-float) :output)
(incx :integer :input)
@@ -442,7 +442,7 @@
"
Syntax
======
-
+
(ZDOTU n x incx y incy)
Purpose
@@ -451,28 +451,28 @@
ZDOTU <- X^T Y
Complex precision inner product of X,Y.
-
+
Arguments
=========
N (input) FIXNUM
- Number of elements of X,Y to be operated on.
-
- X (input) (SIMPLE-ARRAY (COMPLEX DOUBLE-FLOAT) (*)) represented as (SIMPLE-ARRAY DOUBLE-FLOAT (*))
- INCX (input) FIXNUM
- Determines the position of the elements in X. Usually
- INCX is 1. If INCX is bigger than 1 then the elements
- considered in the operations are:
+ Number of elements of X,Y to be operated on.
- X(0),X(2*INCX), ... , X(2*(N-1)*INCX)
+ X (input) (SIMPLE-ARRAY (COMPLEX DOUBLE-FLOAT) (*)) represented as (SIMPLE-ARRAY DOUBLE-FLOAT (*))
+ INCX (input) FIXNUM
+ Determines the position of the elements in X. Usually
+ INCX is 1. If INCX is bigger than 1 then the elements
+ considered in the operations are:
- Y (input) (SIMPLE-ARRAY (COMPLEX DOUBLE-FLOAT) (*)) represented as (SIMPLE-ARRAY DOUBLE-FLOAT (*))
+ X(0),X(2*INCX), ... , X(2*(N-1)*INCX)
+
+ Y (input) (SIMPLE-ARRAY (COMPLEX DOUBLE-FLOAT) (*)) represented as (SIMPLE-ARRAY DOUBLE-FLOAT (*))
INCY (input) FIXNUM
- Determines the position of the elements in Y. Usually
- INCY is 1. If INCY is bigger than 1 then the elements
- considered in the operations are:
+ Determines the position of the elements in Y. Usually
+ INCY is 1. If INCY is bigger than 1 then the elements
+ considered in the operations are:
- Y(0),Y(2*INCY), ... , Y(2*(N-1)*INCY)
+ Y(0),Y(2*INCY), ... , Y(2*(N-1)*INCY)
"
(n :integer :input)
(zx (* :complex-double-float) :input)
@@ -490,9 +490,10 @@
(incy :integer :input)
)
-(let ((result (make-array 2 :element-type 'double-float)))
- (defun zdotu (n zx incx zy incy &key (head-x 0) (head-y 0))
- (mzdotu result n zx incx zy incy :head-x head-x :head-y head-y)
+(defun zdotu (n zx incx zy incy &optional (head-x 0) (head-y 0))
+ (let ((result (make-array 2 :element-type 'double-float)))
+ (declare (type (simple-array double-float (2)) result))
+ (mzdotu result n zx incx zy incy head-x head-y)
(complex (aref result 0) (aref result 1))))
#-(and)
@@ -500,7 +501,7 @@
"
Syntax
======
-
+
(ZDOTC n x incx y incy)
Purpose
@@ -509,28 +510,28 @@
ZDOTC <- X^H Y
Complex precision inner product of X conjugate and Y.
-
+
Arguments
=========
N (input) FIXNUM
- Number of elements of X,Y to be operated on.
-
- X (input) (SIMPLE-ARRAY (COMPLEX DOUBLE-FLOAT) (*)) represented as (SIMPLE-ARRAY DOUBLE-FLOAT (*))
- INCX (input) FIXNUM
- Determines the position of the elements in X. Usually
- INCX is 1. If INCX is bigger than 1 then the elements
- considered in the operations are:
+ Number of elements of X,Y to be operated on.
+
+ X (input) (SIMPLE-ARRAY (COMPLEX DOUBLE-FLOAT) (*)) represented as (SIMPLE-ARRAY DOUBLE-FLOAT (*))
+ INCX (input) FIXNUM
+ Determines the position of the elements in X. Usually
+ INCX is 1. If INCX is bigger than 1 then the elements
+ considered in the operations are:
- X(0),X(2*INCX), ... , X(2*(N-1)*INCX)
+ X(0),X(2*INCX), ... , X(2*(N-1)*INCX)
- Y (input) (SIMPLE-ARRAY (COMPLEX DOUBLE-FLOAT) (*)) represented as (SIMPLE-ARRAY DOUBLE-FLOAT (*))
+ Y (input) (SIMPLE-ARRAY (COMPLEX DOUBLE-FLOAT) (*)) represented as (SIMPLE-ARRAY DOUBLE-FLOAT (*))
INCY (input) FIXNUM
- Determines the position of the elements in Y. Usually
- INCY is 1. If INCY is bigger than 1 then the elements
- considered in the operations are:
+ Determines the position of the elements in Y. Usually
+ INCY is 1. If INCY is bigger than 1 then the elements
+ considered in the operations are:
- Y(0),Y(2*INCY), ... , Y(2*(N-1)*INCY)
+ Y(0),Y(2*INCY), ... , Y(2*(N-1)*INCY)
"
(n :integer :input)
(zx (* :complex-double-float) :input)
@@ -548,9 +549,11 @@
(incy :integer :input)
)
-(let ((result (make-array 2 :element-type 'double-float)))
- (defun zdotc (n zx incx zy incy &key (head-x 0) (head-y 0))
- (mzdotc result n zx incx zy incy :head-x head-x :head-y head-y)
+
+(defun zdotc (n zx incx zy incy &optional (head-x 0) (head-y 0))
+ (let ((result (make-array 2 :element-type 'double-float)))
+ (declare (type (simple-array double-float (*)) result))
+ (mzdotc result n zx incx zy incy head-x head-y)
(complex (aref result 0) (aref result 1))))
@@ -579,7 +582,7 @@
"
Syntax
======
-
+
(DDOT n x incx y incy)
Purpose
@@ -588,29 +591,29 @@
DDOT <- X^T Y
Double precision inner product of X,Y.
-
+
Arguments
=========
N (input) FIXNUM
- Number of elements of X,Y to be operated on.
-
+ Number of elements of X,Y to be operated on.
+
X (input) (SIMPLE-ARRAY DOUBLE-FLOAT (*))
- INCX (input) FIXNUM
- Determines the position of the elements in X. Usually
- INCX is 1. If INCX is bigger than 1 then the elements
- considered in the operations are:
+ INCX (input) FIXNUM
+ Determines the position of the elements in X. Usually
+ INCX is 1. If INCX is bigger than 1 then the elements
+ considered in the operations are:
- X(0),X(2*INCX), ... , X(2*(N-1)*INCX)
+ X(0),X(2*INCX), ... , X(2*(N-1)*INCX)
Y (input) (SIMPLE-ARRAY DOUBLE-FLOAT (*))
INCY (input) FIXNUM
- Determines the position of the elements in Y. Usually
- INCY is 1. If INCY is bigger than 1 then the elements
- considered in the operations are:
+ Determines the position of the elements in Y. Usually
+ INCY is 1. If INCY is bigger than 1 then the elements
+ considered in the operations are:
- Y(0),Y(2*INCY), ... , Y(2*(N-1)*INCY)
- "
+ Y(0),Y(2*INCY), ... , Y(2*(N-1)*INCY)
+ "
(n :integer :input)
(dx (* :double-float :inc head-x) :input)
(incx :integer :input)
@@ -630,95 +633,95 @@
"
Purpose
=======
-
+
DGEMV performs one of the matrix-vector operations
-
+
y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y,
-
+
where alpha and beta are scalars, x and y are vectors and A is an
m by n matrix.
-
+
Parameters
==========
-
+
TRANS - CHARACTER*1.
- On entry, TRANS specifies the operation to be performed as
- follows:
-
- TRANS = 'N' or 'n' y := alpha*A*x + beta*y.
-
- TRANS = 'T' or 't' y := alpha*A'*x + beta*y.
-
- TRANS = 'C' or 'c' y := alpha*A'*x + beta*y.
-
- Unchanged on exit.
-
+ On entry, TRANS specifies the operation to be performed as
+ follows:
+
+ TRANS = 'N' or 'n' y := alpha*A*x + beta*y.
+
+ TRANS = 'T' or 't' y := alpha*A'*x + beta*y.
+
+ TRANS = 'C' or 'c' y := alpha*A'*x + beta*y.
+
+ Unchanged on exit.
+
M - INTEGER.
- On entry, M specifies the number of rows of the matrix A.
- M must be at least zero.
- Unchanged on exit.
-
+ On entry, M specifies the number of rows of the matrix A.
+ M must be at least zero.
+ Unchanged on exit.
+
N - INTEGER.
- On entry, N specifies the number of columns of the matrix A.
- N must be at least zero.
- Unchanged on exit.
-
+ On entry, N specifies the number of columns of the matrix A.
+ N must be at least zero.
+ Unchanged on exit.
+
ALPHA - DOUBLE PRECISION.
- On entry, ALPHA specifies the scalar alpha.
- Unchanged on exit.
-
+ On entry, ALPHA specifies the scalar alpha.
+ Unchanged on exit.
+
A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
- Before entry, the leading m by n part of the array A must
- contain the matrix of coefficients.
- Unchanged on exit.
-
+ Before entry, the leading m by n part of the array A must
+ contain the matrix of coefficients.
+ Unchanged on exit.
+
LDA - INTEGER.
- On entry, LDA specifies the first dimension of A as declared
- in the calling (sub) program. LDA must be at least
- max( 1, m ).
- Unchanged on exit.
-
+ On entry, LDA specifies the first dimension of A as declared
+ in the calling (sub) program. LDA must be at least
+ max( 1, m ).
+ Unchanged on exit.
+
X - DOUBLE PRECISION array of DIMENSION at least
- ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
- and at least
- ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
- Before entry, the incremented array X must contain the
- vector x.
- Unchanged on exit.
-
+ ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
+ and at least
+ ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
+ Before entry, the incremented array X must contain the
+ vector x.
+ Unchanged on exit.
+
INCX - INTEGER.
- On entry, INCX specifies the increment for the elements of
- X. INCX must not be zero.
- Unchanged on exit.
-
+ On entry, INCX specifies the increment for the elements of
+ X. INCX must not be zero.
+ Unchanged on exit.
+
BETA - DOUBLE PRECISION.
- On entry, BETA specifies the scalar beta. When BETA is
- supplied as zero then Y need not be set on input.
- Unchanged on exit.
-
+ On entry, BETA specifies the scalar beta. When BETA is
+ supplied as zero then Y need not be set on input.
+ Unchanged on exit.
+
Y - DOUBLE PRECISION array of DIMENSION at least
- ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
- and at least
- ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
- Before entry with BETA non-zero, the incremented array Y
- must contain the vector y. On exit, Y is overwritten by the
- updated vector y.
-
+ ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
+ and at least
+ ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
+ Before entry with BETA non-zero, the incremented array Y
+ must contain the vector y. On exit, Y is overwritten by the
+ updated vector y.
+
INCY - INTEGER.
- On entry, INCY specifies the increment for the elements of
- Y. INCY must not be zero.
- Unchanged on exit.
-
-
+ On entry, INCY specifies the increment for the elements of
+ Y. INCY must not be zero.
+ Unchanged on exit.
+
+
Level 2 Blas routine.
-
+
-- Written on 22-October-1986.
Jack Dongarra, Argonne National Lab.
Jeremy Du Croz, Nag Central Office.
Sven Hammarling, Nag Central Office.
Richard Hanson, Sandia National Labs.
-
-
+
+
"
(trans :string :input)
(m :integer )
@@ -737,93 +740,93 @@
"
Purpose
=======
-
+
DSYMV performs the matrix-vector operation
-
+
y := alpha*A*x + beta*y,
-
+
where alpha and beta are scalars, x and y are n element vectors and
A is an n by n symmetric matrix.
-
+
Parameters
==========
-
+
UPLO - CHARACTER*1.
- On entry, UPLO specifies whether the upper or lower
- triangular part of the array A is to be referenced as
- follows:
-
- UPLO = 'U' or 'u' Only the upper triangular part of A
- is to be referenced.
-
- UPLO = 'L' or 'l' Only the lower triangular part of A
- is to be referenced.
-
- Unchanged on exit.
-
+ On entry, UPLO specifies whether the upper or lower
+ triangular part of the array A is to be referenced as
+ follows:
+
+ UPLO = 'U' or 'u' Only the upper triangular part of A
+ is to be referenced.
+
+ UPLO = 'L' or 'l' Only the lower triangular part of A
+ is to be referenced.
+
+ Unchanged on exit.
+
N - INTEGER.
- On entry, N specifies the order of the matrix A.
- N must be at least zero.
- Unchanged on exit.
-
+ On entry, N specifies the order of the matrix A.
+ N must be at least zero.
+ Unchanged on exit.
+
ALPHA - DOUBLE PRECISION.
- On entry, ALPHA specifies the scalar alpha.
- Unchanged on exit.
-
+ On entry, ALPHA specifies the scalar alpha.
+ Unchanged on exit.
+
A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
- Before entry with UPLO = 'U' or 'u', the leading n by n
- upper triangular part of the array A must contain the upper
- triangular part of the symmetric matrix and the strictly
- lower triangular part of A is not referenced.
- Before entry with UPLO = 'L' or 'l', the leading n by n
- lower triangular part of the array A must contain the lower
- triangular part of the symmetric matrix and the strictly
- upper triangular part of A is not referenced.
- Unchanged on exit.
-
+ Before entry with UPLO = 'U' or 'u', the leading n by n
+ upper triangular part of the array A must contain the upper
+ triangular part of the symmetric matrix and the strictly
+ lower triangular part of A is not referenced.
+ Before entry with UPLO = 'L' or 'l', the leading n by n
+ lower triangular part of the array A must contain the lower
+ triangular part of the symmetric matrix and the strictly
+ upper triangular part of A is not referenced.
+ Unchanged on exit.
+
LDA - INTEGER.
- On entry, LDA specifies the first dimension of A as declared
- in the calling (sub) program. LDA must be at least
- max( 1, n ).
- Unchanged on exit.
-
+ On entry, LDA specifies the first dimension of A as declared
+ in the calling (sub) program. LDA must be at least
+ max( 1, n ).
+ Unchanged on exit.
+
X - DOUBLE PRECISION array of dimension at least
- ( 1 + ( n - 1 )*abs( INCX ) ).
- Before entry, the incremented array X must contain the n
- element vector x.
- Unchanged on exit.
-
+ ( 1 + ( n - 1 )*abs( INCX ) ).
+ Before entry, the incremented array X must contain the n
+ element vector x.
+ Unchanged on exit.
+
INCX - INTEGER.
- On entry, INCX specifies the increment for the elements of
- X. INCX must not be zero.
- Unchanged on exit.
-
+ On entry, INCX specifies the increment for the elements of
+ X. INCX must not be zero.
+ Unchanged on exit.
+
BETA - DOUBLE PRECISION.
- On entry, BETA specifies the scalar beta. When BETA is
- supplied as zero then Y need not be set on input.
- Unchanged on exit.
-
+ On entry, BETA specifies the scalar beta. When BETA is
+ supplied as zero then Y need not be set on input.
+ Unchanged on exit.
+
Y - DOUBLE PRECISION array of dimension at least
- ( 1 + ( n - 1 )*abs( INCY ) ).
- Before entry, the incremented array Y must contain the n
- element vector y. On exit, Y is overwritten by the updated
- vector y.
-
+ ( 1 + ( n - 1 )*abs( INCY ) ).
+ Before entry, the incremented array Y must contain the n
+ element vector y. On exit, Y is overwritten by the updated
+ vector y.
+
INCY - INTEGER.
- On entry, INCY specifies the increment for the elements of
- Y. INCY must not be zero.
- Unchanged on exit.
-
-
+ On entry, INCY specifies the increment for the elements of
+ Y. INCY must not be zero.
+ Unchanged on exit.
+
+
Level 2 Blas routine.
-
+
-- Written on 22-October-1986.
Jack Dongarra, Argonne National Lab.
Jeremy Du Croz, Nag Central Office.
Sven Hammarling, Nag Central Office.
Richard Hanson, Sandia National Labs.
-
-
+
+
"
(uplo :string :input)
(n :integer )
@@ -841,95 +844,95 @@
"
Purpose
=======
-
+
DTRMV performs one of the matrix-vector operations
-
+
x := A*x, or x := A'*x,
-
+
where x is an n element vector and A is an n by n unit, or non-unit,
upper or lower triangular matrix.
-
+
Parameters
==========
-
+
UPLO - CHARACTER*1.
- On entry, UPLO specifies whether the matrix is an upper or
- lower triangular matrix as follows:
-
- UPLO = 'U' or 'u' A is an upper triangular matrix.
-
- UPLO = 'L' or 'l' A is a lower triangular matrix.
-
- Unchanged on exit.
-
+ On entry, UPLO specifies whether the matrix is an upper or
+ lower triangular matrix as follows:
+
+ UPLO = 'U' or 'u' A is an upper triangular matrix.
+
+ UPLO = 'L' or 'l' A is a lower triangular matrix.
+
+ Unchanged on exit.
+
TRANS - CHARACTER*1.
- On entry, TRANS specifies the operation to be performed as
- follows:
-
- TRANS = 'N' or 'n' x := A*x.
-
- TRANS = 'T' or 't' x := A'*x.
-
- TRANS = 'C' or 'c' x := A'*x.
-
- Unchanged on exit.
-
+ On entry, TRANS specifies the operation to be performed as
+ follows:
+
+ TRANS = 'N' or 'n' x := A*x.
+
+ TRANS = 'T' or 't' x := A'*x.
+
+ TRANS = 'C' or 'c' x := A'*x.
+
+ Unchanged on exit.
+
DIAG - CHARACTER*1.
- On entry, DIAG specifies whether or not A is unit
- triangular as follows:
-
- DIAG = 'U' or 'u' A is assumed to be unit triangular.
-
- DIAG = 'N' or 'n' A is not assumed to be unit
- triangular.
-
- Unchanged on exit.
-
+ On entry, DIAG specifies whether or not A is unit
+ triangular as follows:
+
+ DIAG = 'U' or 'u' A is assumed to be unit triangular.
+
+ DIAG = 'N' or 'n' A is not assumed to be unit
+ triangular.
+
+ Unchanged on exit.
+
N - INTEGER.
- On entry, N specifies the order of the matrix A.
- N must be at least zero.
- Unchanged on exit.
-
+ On entry, N specifies the order of the matrix A.
+ N must be at least zero.
+ Unchanged on exit.
+
A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
- Before entry with UPLO = 'U' or 'u', the leading n by n
- upper triangular part of the array A must contain the upper
- triangular matrix and the strictly lower triangular part of
- A is not referenced.
- Before entry with UPLO = 'L' or 'l', the leading n by n
- lower triangular part of the array A must contain the lower
- triangular matrix and the strictly upper triangular part of
- A is not referenced.
- Note that when DIAG = 'U' or 'u', the diagonal elements of
- A are not referenced either, but are assumed to be unity.
- Unchanged on exit.
-
+ Before entry with UPLO = 'U' or 'u', the leading n by n
+ upper triangular part of the array A must contain the upper
+ triangular matrix and the strictly lower triangular part of
+ A is not referenced.
+ Before entry with UPLO = 'L' or 'l', the leading n by n
+ lower triangular part of the array A must contain the lower
+ triangular matrix and the strictly upper triangular part of
+ A is not referenced.
+ Note that when DIAG = 'U' or 'u', the diagonal elements of
+ A are not referenced either, but are assumed to be unity.
+ Unchanged on exit.
+
LDA - INTEGER.
- On entry, LDA specifies the first dimension of A as declared
- in the calling (sub) program. LDA must be at least
- max( 1, n ).
- Unchanged on exit.
-
+ On entry, LDA specifies the first dimension of A as declared
+ in the calling (sub) program. LDA must be at least
+ max( 1, n ).
+ Unchanged on exit.
+
X - DOUBLE PRECISION array of dimension at least
- ( 1 + ( n - 1 )*abs( INCX ) ).
- Before entry, the incremented array X must contain the n
- element vector x. On exit, X is overwritten with the
- tranformed vector x.
-
+ ( 1 + ( n - 1 )*abs( INCX ) ).
+ Before entry, the incremented array X must contain the n
+ element vector x. On exit, X is overwritten with the
+ tranformed vector x.
+
INCX - INTEGER.
- On entry, INCX specifies the increment for the elements of
- X. INCX must not be zero.
- Unchanged on exit.
-
-
+ On entry, INCX specifies the increment for the elements of
+ X. INCX must not be zero.
+ Unchanged on exit.
+
+
Level 2 Blas routine.
-
+
-- Written on 22-October-1986.
Jack Dongarra, Argonne National Lab.
Jeremy Du Croz, Nag Central Office.
Sven Hammarling, Nag Central Office.
Richard Hanson, Sandia National Labs.
-
-
+
+
"
(uplo :string :input)
(trans :string :input)
@@ -945,98 +948,98 @@
"
Purpose
=======
-
+
DTRSV solves one of the systems of equations
-
+
A*x = b, or A'*x = b,
-
+
where b and x are n element vectors and A is an n by n unit, or
non-unit, upper or lower triangular matrix.
-
+
No test for singularity or near-singularity is included in this
routine. Such tests must be performed before calling this routine.
-
+
Parameters
==========
-
+
UPLO - CHARACTER*1.
- On entry, UPLO specifies whether the matrix is an upper or
- lower triangular matrix as follows:
-
- UPLO = 'U' or 'u' A is an upper triangular matrix.
-
- UPLO = 'L' or 'l' A is a lower triangular matrix.
-
- Unchanged on exit.
-
+ On entry, UPLO specifies whether the matrix is an upper or
+ lower triangular matrix as follows:
+
+ UPLO = 'U' or 'u' A is an upper triangular matrix.
+
+ UPLO = 'L' or 'l' A is a lower triangular matrix.
+
+ Unchanged on exit.
+
TRANS - CHARACTER*1.
- On entry, TRANS specifies the equations to be solved as
- follows:
-
- TRANS = 'N' or 'n' A*x = b.
-
- TRANS = 'T' or 't' A'*x = b.
-
- TRANS = 'C' or 'c' A'*x = b.
-
- Unchanged on exit.
-
+ On entry, TRANS specifies the equations to be solved as
+ follows:
+
+ TRANS = 'N' or 'n' A*x = b.
+
+ TRANS = 'T' or 't' A'*x = b.
+
+ TRANS = 'C' or 'c' A'*x = b.
+
+ Unchanged on exit.
+
DIAG - CHARACTER*1.
- On entry, DIAG specifies whether or not A is unit
- triangular as follows:
-
- DIAG = 'U' or 'u' A is assumed to be unit triangular.
-
- DIAG = 'N' or 'n' A is not assumed to be unit
- triangular.
-
- Unchanged on exit.
-
+ On entry, DIAG specifies whether or not A is unit
+ triangular as follows:
+
+ DIAG = 'U' or 'u' A is assumed to be unit triangular.
+
+ DIAG = 'N' or 'n' A is not assumed to be unit
+ triangular.
+
+ Unchanged on exit.
+
N - INTEGER.
- On entry, N specifies the order of the matrix A.
- N must be at least zero.
- Unchanged on exit.
-
+ On entry, N specifies the order of the matrix A.
+ N must be at least zero.
+ Unchanged on exit.
+
A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
- Before entry with UPLO = 'U' or 'u', the leading n by n
- upper triangular part of the array A must contain the upper
- triangular matrix and the strictly lower triangular part of
- A is not referenced.
- Before entry with UPLO = 'L' or 'l', the leading n by n
- lower triangular part of the array A must contain the lower
- triangular matrix and the strictly upper triangular part of
- A is not referenced.
- Note that when DIAG = 'U' or 'u', the diagonal elements of
- A are not referenced either, but are assumed to be unity.
- Unchanged on exit.
-
+ Before entry with UPLO = 'U' or 'u', the leading n by n
+ upper triangular part of the array A must contain the upper
+ triangular matrix and the strictly lower triangular part of
+ A is not referenced.
+ Before entry with UPLO = 'L' or 'l', the leading n by n
+ lower triangular part of the array A must contain the lower
+ triangular matrix and the strictly upper triangular part of
+ A is not referenced.
+ Note that when DIAG = 'U' or 'u', the diagonal elements of
+ A are not referenced either, but are assumed to be unity.
+ Unchanged on exit.
+
LDA - INTEGER.
- On entry, LDA specifies the first dimension of A as declared
- in the calling (sub) program. LDA must be at least
- max( 1, n ).
- Unchanged on exit.
-
+ On entry, LDA specifies the first dimension of A as declared
+ in the calling (sub) program. LDA must be at least
+ max( 1, n ).
+ Unchanged on exit.
+
X - DOUBLE PRECISION array of dimension at least
- ( 1 + ( n - 1 )*abs( INCX ) ).
- Before entry, the incremented array X must contain the n
- element right-hand side vector b. On exit, X is overwritten
- with the solution vector x.
-
+ ( 1 + ( n - 1 )*abs( INCX ) ).
+ Before entry, the incremented array X must contain the n
+ element right-hand side vector b. On exit, X is overwritten
+ with the solution vector x.
+
INCX - INTEGER.
- On entry, INCX specifies the increment for the elements of
- X. INCX must not be zero.
- Unchanged on exit.
-
-
+ On entry, INCX specifies the increment for the elements of
+ X. INCX must not be zero.
+ Unchanged on exit.
+
+
Level 2 Blas routine.
-
+
-- Written on 22-October-1986.
Jack Dongarra, Argonne National Lab.
Jeremy Du Croz, Nag Central Office.
Sven Hammarling, Nag Central Office.
Richard Hanson, Sandia National Labs.
-
-
+
+
"
(uplo :string :input)
(trans :string :input)
@@ -1052,74 +1055,74 @@
"
Purpose
=======
-
+
DGER performs the rank 1 operation
-
+
A := alpha*x*y' + A,
-
+
where alpha is a scalar, x is an m element vector, y is an n element
vector and A is an m by n matrix.
-
+
Parameters
==========
-
+
M - INTEGER.
- On entry, M specifies the number of rows of the matrix A.
- M must be at least zero.
- Unchanged on exit.
-
+ On entry, M specifies the number of rows of the matrix A.
+ M must be at least zero.
+ Unchanged on exit.
+
N - INTEGER.
- On entry, N specifies the number of columns of the matrix A.
- N must be at least zero.
- Unchanged on exit.
-
+ On entry, N specifies the number of columns of the matrix A.
+ N must be at least zero.
+ Unchanged on exit.
+
ALPHA - DOUBLE PRECISION.
- On entry, ALPHA specifies the scalar alpha.
- Unchanged on exit.
-
+ On entry, ALPHA specifies the scalar alpha.
+ Unchanged on exit.
+
X - DOUBLE PRECISION array of dimension at least
- ( 1 + ( m - 1 )*abs( INCX ) ).
- Before entry, the incremented array X must contain the m
- element vector x.
- Unchanged on exit.
-
+ ( 1 + ( m - 1 )*abs( INCX ) ).
+ Before entry, the incremented array X must contain the m
+ element vector x.
+ Unchanged on exit.
+
INCX - INTEGER.
- On entry, INCX specifies the increment for the elements of
- X. INCX must not be zero.
- Unchanged on exit.
-
+ On entry, INCX specifies the increment for the elements of
+ X. INCX must not be zero.
+ Unchanged on exit.
+
Y - DOUBLE PRECISION array of dimension at least
- ( 1 + ( n - 1 )*abs( INCY ) ).
- Before entry, the incremented array Y must contain the n
- element vector y.
- Unchanged on exit.
-
+ ( 1 + ( n - 1 )*abs( INCY ) ).
+ Before entry, the incremented array Y must contain the n
+ element vector y.
+ Unchanged on exit.
+
INCY - INTEGER.
- On entry, INCY specifies the increment for the elements of
- Y. INCY must not be zero.
- Unchanged on exit.
-
+ On entry, INCY specifies the increment for the elements of
+ Y. INCY must not be zero.
+ Unchanged on exit.
+
A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
- Before entry, the leading m by n part of the array A must
- contain the matrix of coefficients. On exit, A is
- overwritten by the updated matrix.
-
+ Before entry, the leading m by n part of the array A must
+ contain the matrix of coefficients. On exit, A is
+ overwritten by the updated matrix.
+
LDA - INTEGER.
- On entry, LDA specifies the first dimension of A as declared
- in the calling (sub) program. LDA must be at least
- max( 1, m ).
- Unchanged on exit.
-
-
+ On entry, LDA specifies the first dimension of A as declared
+ in the calling (sub) program. LDA must be at least
+ max( 1, m ).
+ Unchanged on exit.
+
+
Level 2 Blas routine.
-
+
-- Written on 22-October-1986.
Jack Dongarra, Argonne National Lab.
Jeremy Du Croz, Nag Central Office.
Sven Hammarling, Nag Central Office.
Richard Hanson, Sandia National Labs.
-
-
+
+
"
(m :integer )
(n :integer )
@@ -1136,80 +1139,80 @@
"
Purpose
=======
-
+
DSYR performs the symmetric rank 1 operation
-
+
A := alpha*x*x' + A,
-
+
where alpha is a real scalar, x is an n element vector and A is an
n by n symmetric matrix.
-
+
Parameters
==========
-
+
UPLO - CHARACTER*1.
- On entry, UPLO specifies whether the upper or lower
- triangular part of the array A is to be referenced as
- follows:
-
- UPLO = 'U' or 'u' Only the upper triangular part of A
- is to be referenced.
-
- UPLO = 'L' or 'l' Only the lower triangular part of A
- is to be referenced.
-
- Unchanged on exit.
-
+ On entry, UPLO specifies whether the upper or lower
+ triangular part of the array A is to be referenced as
+ follows:
+
+ UPLO = 'U' or 'u' Only the upper triangular part of A
+ is to be referenced.
+
+ UPLO = 'L' or 'l' Only the lower triangular part of A
+ is to be referenced.
+
+ Unchanged on exit.
+
N - INTEGER.
- On entry, N specifies the order of the matrix A.
- N must be at least zero.
- Unchanged on exit.
-
+ On entry, N specifies the order of the matrix A.
+ N must be at least zero.
+ Unchanged on exit.
+
ALPHA - DOUBLE PRECISION.
- On entry, ALPHA specifies the scalar alpha.
- Unchanged on exit.
-
+ On entry, ALPHA specifies the scalar alpha.
+ Unchanged on exit.
+
X - DOUBLE PRECISION array of dimension at least
- ( 1 + ( n - 1 )*abs( INCX ) ).
- Before entry, the incremented array X must contain the n
- element vector x.
- Unchanged on exit.
-
+ ( 1 + ( n - 1 )*abs( INCX ) ).
+ Before entry, the incremented array X must contain the n
+ element vector x.
+ Unchanged on exit.
+
INCX - INTEGER.
- On entry, INCX specifies the increment for the elements of
- X. INCX must not be zero.
- Unchanged on exit.
-
+ On entry, INCX specifies the increment for the elements of
+ X. INCX must not be zero.
+ Unchanged on exit.
+
A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
- Before entry with UPLO = 'U' or 'u', the leading n by n
- upper triangular part of the array A must contain the upper
- triangular part of the symmetric matrix and the strictly
- lower triangular part of A is not referenced. On exit, the
- upper triangular part of the array A is overwritten by the
- upper triangular part of the updated matrix.
- Before entry with UPLO = 'L' or 'l', the leading n by n
- lower triangular part of the array A must contain the lower
- triangular part of the symmetric matrix and the strictly
- upper triangular part of A is not referenced. On exit, the
- lower triangular part of the array A is overwritten by the
- lower triangular part of the updated matrix.
-
+ Before entry with UPLO = 'U' or 'u', the leading n by n
+ upper triangular part of the array A must contain the upper
+ triangular part of the symmetric matrix and the strictly
+ lower triangular part of A is not referenced. On exit, the
+ upper triangular part of the array A is overwritten by the
+ upper triangular part of the updated matrix.
+ Before entry with UPLO = 'L' or 'l', the leading n by n
+ lower triangular part of the array A must contain the lower
+ triangular part of the symmetric matrix and the strictly
+ upper triangular part of A is not referenced. On exit, the
+ lower triangular part of the array A is overwritten by the
+ lower triangular part of the updated matrix.
+
LDA - INTEGER.
- On entry, LDA specifies the first dimension of A as declared
- in the calling (sub) program. LDA must be at least
- max( 1, n ).
- Unchanged on exit.
-
-
+ On entry, LDA specifies the first dimension of A as declared
+ in the calling (sub) program. LDA must be at least
+ max( 1, n ).
+ Unchanged on exit.
+
+
Level 2 Blas routine.
-
+
-- Written on 22-October-1986.
Jack Dongarra, Argonne National Lab.
Jeremy Du Croz, Nag Central Office.
Sven Hammarling, Nag Central Office.
Richard Hanson, Sandia National Labs.
-
-
+
+
"
(uplo :string :input)
(n :integer )
@@ -1224,91 +1227,91 @@
"
Purpose
=======
-
+
DSYR2 performs the symmetric rank 2 operation
-
+
A := alpha*x*y' + alpha*y*x' + A,
-
+
where alpha is a scalar, x and y are n element vectors and A is an n
by n symmetric matrix.
-
+
Parameters
==========
-
+
UPLO - CHARACTER*1.
- On entry, UPLO specifies whether the upper or lower
- triangular part of the array A is to be referenced as
- follows:
-
- UPLO = 'U' or 'u' Only the upper triangular part of A
- is to be referenced.
-
- UPLO = 'L' or 'l' Only the lower triangular part of A
- is to be referenced.
-
- Unchanged on exit.
-
+ On entry, UPLO specifies whether the upper or lower
+ triangular part of the array A is to be referenced as
+ follows:
+
+ UPLO = 'U' or 'u' Only the upper triangular part of A
+ is to be referenced.
+
+ UPLO = 'L' or 'l' Only the lower triangular part of A
+ is to be referenced.
+
+ Unchanged on exit.
+
N - INTEGER.
- On entry, N specifies the order of the matrix A.
- N must be at least zero.
- Unchanged on exit.
-
+ On entry, N specifies the order of the matrix A.
+ N must be at least zero.
+ Unchanged on exit.
+
ALPHA - DOUBLE PRECISION.
- On entry, ALPHA specifies the scalar alpha.
- Unchanged on exit.
-
+ On entry, ALPHA specifies the scalar alpha.
+ Unchanged on exit.
+
X - DOUBLE PRECISION array of dimension at least
- ( 1 + ( n - 1 )*abs( INCX ) ).
- Before entry, the incremented array X must contain the n
- element vector x.
- Unchanged on exit.
-
+ ( 1 + ( n - 1 )*abs( INCX ) ).
+ Before entry, the incremented array X must contain the n
+ element vector x.
+ Unchanged on exit.
+
INCX - INTEGER.
- On entry, INCX specifies the increment for the elements of
- X. INCX must not be zero.
- Unchanged on exit.
-
+ On entry, INCX specifies the increment for the elements of
+ X. INCX must not be zero.
+ Unchanged on exit.
+
Y - DOUBLE PRECISION array of dimension at least
- ( 1 + ( n - 1 )*abs( INCY ) ).
- Before entry, the incremented array Y must contain the n
- element vector y.
- Unchanged on exit.
-
+ ( 1 + ( n - 1 )*abs( INCY ) ).
+ Before entry, the incremented array Y must contain the n
+ element vector y.
+ Unchanged on exit.
+
INCY - INTEGER.
- On entry, INCY specifies the increment for the elements of
- Y. INCY must not be zero.
- Unchanged on exit.
-
+ On entry, INCY specifies the increment for the elements of
+ Y. INCY must not be zero.
+ Unchanged on exit.
+
A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
- Before entry with UPLO = 'U' or 'u', the leading n by n
- upper triangular part of the array A must contain the upper
- triangular part of the symmetric matrix and the strictly
- lower triangular part of A is not referenced. On exit, the
- upper triangular part of the array A is overwritten by the
- upper triangular part of the updated matrix.
- Before entry with UPLO = 'L' or 'l', the leading n by n
- lower triangular part of the array A must contain the lower
- triangular part of the symmetric matrix and the strictly
- upper triangular part of A is not referenced. On exit, the
- lower triangular part of the array A is overwritten by the
- lower triangular part of the updated matrix.
-
+ Before entry with UPLO = 'U' or 'u', the leading n by n
+ upper triangular part of the array A must contain the upper
+ triangular part of the symmetric matrix and the strictly
+ lower triangular part of A is not referenced. On exit, the
+ upper triangular part of the array A is overwritten by the
+ upper triangular part of the updated matrix.
+ Before entry with UPLO = 'L' or 'l', the leading n by n
+ lower triangular part of the array A must contain the lower
+ triangular part of the symmetric matrix and the strictly
+ upper triangular part of A is not referenced. On exit, the
+ lower triangular part of the array A is overwritten by the
+ lower triangular part of the updated matrix.
+
LDA - INTEGER.
- On entry, LDA specifies the first dimension of A as declared
- in the calling (sub) program. LDA must be at least
- max( 1, n ).
- Unchanged on exit.
-
-
+ On entry, LDA specifies the first dimension of A as declared
+ in the calling (sub) program. LDA must be at least
+ max( 1, n ).
+ Unchanged on exit.
+
+
Level 2 Blas routine.
-
+
-- Written on 22-October-1986.
Jack Dongarra, Argonne National Lab.
Jeremy Du Croz, Nag Central Office.
Sven Hammarling, Nag Central Office.
Richard Hanson, Sandia National Labs.
-
-
+
+
"
(uplo :string :input)
(n :integer )
@@ -1325,124 +1328,124 @@
"
Purpose
=======
-
+
DGEMM performs one of the matrix-matrix operations
-
+
C := alpha*op( A )*op( B ) + beta*C,
-
+
where op( X ) is one of
-
+
op( X ) = X or op( X ) = X',
-
+
alpha and beta are scalars, and A, B and C are matrices, with op( A )
an m by k matrix, op( B ) a k by n matrix and C an m by n matrix.
-
+
Parameters
==========
-
+
TRANSA - CHARACTER*1.
- On entry, TRANSA specifies the form of op( A ) to be used in
- the matrix multiplication as follows:
-
- TRANSA = 'N' or 'n', op( A ) = A.
-
- TRANSA = 'T' or 't', op( A ) = A'.
-
- TRANSA = 'C' or 'c', op( A ) = A'.
-
- Unchanged on exit.
-
+ On entry, TRANSA specifies the form of op( A ) to be used in
+ the matrix multiplication as follows:
+
+ TRANSA = 'N' or 'n', op( A ) = A.
+
+ TRANSA = 'T' or 't', op( A ) = A'.
+
+ TRANSA = 'C' or 'c', op( A ) = A'.
+
+ Unchanged on exit.
+
TRANSB - CHARACTER*1.
- On entry, TRANSB specifies the form of op( B ) to be used in
- the matrix multiplication as follows:
-
- TRANSB = 'N' or 'n', op( B ) = B.
-
- TRANSB = 'T' or 't', op( B ) = B'.
-
- TRANSB = 'C' or 'c', op( B ) = B'.
-
- Unchanged on exit.
-
+ On entry, TRANSB specifies the form of op( B ) to be used in
+ the matrix multiplication as follows:
+
+ TRANSB = 'N' or 'n', op( B ) = B.
+
+ TRANSB = 'T' or 't', op( B ) = B'.
+
+ TRANSB = 'C' or 'c', op( B ) = B'.
+
+ Unchanged on exit.
+
M - INTEGER.
- On entry, M specifies the number of rows of the matrix
- op( A ) and of the matrix C. M must be at least zero.
- Unchanged on exit.
-
+ On entry, M specifies the number of rows of the matrix
+ op( A ) and of the matrix C. M must be at least zero.
+ Unchanged on exit.
+
N - INTEGER.
- On entry, N specifies the number of columns of the matrix
- op( B ) and the number of columns of the matrix C. N must be
- at least zero.
- Unchanged on exit.
-
+ On entry, N specifies the number of columns of the matrix
+ op( B ) and the number of columns of the matrix C. N must be
+ at least zero.
+ Unchanged on exit.
+
K - INTEGER.
- On entry, K specifies the number of columns of the matrix
- op( A ) and the number of rows of the matrix op( B ). K must
- be at least zero.
- Unchanged on exit.
-
+ On entry, K specifies the number of columns of the matrix
+ op( A ) and the number of rows of the matrix op( B ). K must
+ be at least zero.
+ Unchanged on exit.
+
ALPHA - DOUBLE PRECISION.
- On entry, ALPHA specifies the scalar alpha.
- Unchanged on exit.
-
+ On entry, ALPHA specifies the scalar alpha.
+ Unchanged on exit.
+
A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is
- k when TRANSA = 'N' or 'n', and is m otherwise.
- Before entry with TRANSA = 'N' or 'n', the leading m by k
- part of the array A must contain the matrix A, otherwise
- the leading k by m part of the array A must contain the
- matrix A.
- Unchanged on exit.
-
+ k when TRANSA = 'N' or 'n', and is m otherwise.
+ Before entry with TRANSA = 'N' or 'n', the leading m by k
+ part of the array A must contain the matrix A, otherwise
+ the leading k by m part of the array A must contain the
+ matrix A.
+ Unchanged on exit.
+
LDA - INTEGER.
- On entry, LDA specifies the first dimension of A as declared
- in the calling (sub) program. When TRANSA = 'N' or 'n' then
- LDA must be at least max( 1, m ), otherwise LDA must be at
- least max( 1, k ).
- Unchanged on exit.
-
+ On entry, LDA specifies the first dimension of A as declared
+ in the calling (sub) program. When TRANSA = 'N' or 'n' then
+ LDA must be at least max( 1, m ), otherwise LDA must be at
+ least max( 1, k ).
+ Unchanged on exit.
+
B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is
- n when TRANSB = 'N' or 'n', and is k otherwise.
- Before entry with TRANSB = 'N' or 'n', the leading k by n
- part of the array B must contain the matrix B, otherwise
- the leading n by k part of the array B must contain the
- matrix B.
- Unchanged on exit.
-
+ n when TRANSB = 'N' or 'n', and is k otherwise.
+ Before entry with TRANSB = 'N' or 'n', the leading k by n
+ part of the array B must contain the matrix B, otherwise
+ the leading n by k part of the array B must contain the
+ matrix B.
+ Unchanged on exit.
+
LDB - INTEGER.
- On entry, LDB specifies the first dimension of B as declared
- in the calling (sub) program. When TRANSB = 'N' or 'n' then
- LDB must be at l...
[truncated message content] |
|
From: Akshay S. <aks...@gm...> - 2012-06-26 14:55:50
|
On 06/26/2012 08:24 PM, Akshay Srinivasan wrote:
> 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 82125cbf389c2f1bc43a5c661067400efcec64c3 (commit)
> from 578dc43e356575b8c860f46f157c07d773843af8 (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 82125cbf389c2f1bc43a5c661067400efcec64c3
> Author: Akshay Srinivasan <aks...@gm...>
> Date: Tue Jun 26 20:17:02 2012 +0530
>
> Wrote a mid-way solution "mod-dotimes" to allow for very effective
> representation of matrix multiplication. Naive matrix multiplication
> on SBCL is about 200x than dgemm in OpenBLAS, but only about 2x slower
That should be 200x slower (obviously).
> compared to using naive nested loops in C.
>
> diff --git a/src/ffi-cffi-interpreter-specific.lisp b/src/ffi-cffi-interpreter-specific.lisp
> index 4d51dc0..92c285f 100644
> --- a/src/ffi-cffi-interpreter-specific.lisp
> +++ b/src/ffi-cffi-interpreter-specific.lisp
> @@ -3,7 +3,7 @@
>
> (in-package :ffi)
>
> -;;TODO: Add support for {Allegro CL, Lispworks, ECL, clisp}
> +;;TODO: Add support for {ECL, clisp, Allegro CL, Lispworks}
>
> (defmacro with-fortran-float-modes (&body body)
> "Execute the body with the IEEE FP modes appropriately set for Fortran"
> diff --git a/src/loopy.lisp b/src/loopy.lisp
> index d0cb80b..9d2e587 100644
> --- a/src/loopy.lisp
> +++ b/src/loopy.lisp
> @@ -23,7 +23,71 @@ is used, else the fortran routine is called instead.
> unless (= off accumulated-off) do (return nil)
> finally (return t))))
>
> -(defmacro mod-loop ((idx dims) &body body)
> +
> +(linloop (idx #(2 2))
> + with (loop-order row-order)
> + with (linear-sums
> + (of-t #(..))
> + (of-a #(..)))
> + do (..))
> +
> +(defmacro mod-dotimes ((idx dims) &body body)
> + (check-type idx symbol)
> + (labels ((parse-code (body ret)
> + (cond
> + ((null body)
> + (values nil ret))
> + ((eq (car body) 'with)
> + (multiple-value-bind (indic decl) (parse-with (cadr body))
> + (setf (getf ret indic) decl))
> + (parse-code (cddr body) ret))
> + ((eq (car body) 'do)
> + (values (cadr body) ret))
> + (t (error "unknown word passed to linloop: ~a" (car body)))))
> + (parse-with (code)
> + (cond
> + ((eq (car code) 'linear-sums)
> + (values :linear-sums
> + (loop for decl in (cdr code)
> + collect (destructuring-bind (offst strds &optional (init 0)) decl
> + (list :offset-sym offst
> + :offset-init init
> + :stride-sym (gensym (string+ (symbol-name offst) "-stride"))
> + :stride-expr strds)))))
> + ((and (eq (car code) 'loop-order)
> + (member (cadr code) '(:row-major :col-major)))
> + (values :loop-order (second code)))
> + (t (error "unknown word passed to linloop: ~a" (car code))))))
> + (multiple-value-bind (code sdecl) (parse-code body nil)
> + (with-gensyms (dims-sym rank-sym count-sym)
> + `(let* ((,dims-sym ,dims)
> + (,rank-sym (length ,dims-sym))
> + (,idx (allocate-index-store ,rank-sym))
> + ,@(mapcar #'(lambda (x) `(,(getf x :stride-sym) ,(getf x :stride-expr))) (getf sdecl :linear-sums)))
> + ,@(when (getf sdecl :linear-sums)
> + `((declare (type (index-array *) ,@(mapcar #'(lambda (x) (getf x :stride-sym)) (getf sdecl :linear-sums))))))
> + (loop ,@(loop for decl in (getf sdecl :linear-sums)
> + append `(with ,(getf decl :offset-sym) of-type index-type = ,(getf decl :offset-init)))
> + do (,@code)
> + while ,(append
> + (if (member (getf sdecl :loop-order) '(nil :row-major))
> + `(loop for ,count-sym of-type index-type from (1- ,rank-sym) downto 0)
> + `(loop for ,count-sym of-type index-type from 0 below ,rank-sym))
> + `(do (if (= (aref ,idx ,count-sym) (1- (aref ,dims-sym ,count-sym)))
> + (progn
> + (setf (aref ,idx ,count-sym) 0)
> + ,@(loop for decl in (getf sdecl :linear-sums)
> + collect `(decf ,(getf decl :offset-sym) (* (aref ,(getf decl :stride-sym) ,count-sym) (1- (aref ,dims-sym ,count-sym))))))
> + (progn
> + (incf (aref ,idx ,count-sym))
> + ,@(loop for decl in (getf sdecl :linear-sums)
> + collect `(incf ,(getf decl :offset-sym) (aref ,(getf decl :stride-sym) ,count-sym)))
> + (return t)))
> + finally (return nil)))))))))
> +
> +
> +;;Very ugly inflexible code; get rid of this in some time or make use of mod-dotimes.
> +#+nil(defmacro mod-loop ((idx dims) &body body)
> (check-type idx symbol)
> (let ((tensor-table (make-hash-table)))
> (labels ((get-tensors (decl)
> @@ -71,12 +135,7 @@ is used, else the fortran routine is called instead.
> (let ((to-opt (gethash (second to) tensor-table)))
> ;;Add type checking here!
> (cdr (funcall (getf (get-tensor-class-optimization (getf to-opt :class)) :value-writer)
> - from (getf to-opt :store-sym) (getf to-opt :offset-sym)))))
> - (fr-t?
> - (incref (second from))
> - (let ((fr-opt (gethash (second from) tensor-table)))
> - (cons to (funcall (getf (get-tensor-class-optimization (getf fr-opt :class)) :reader)
> - (getf fr-opt :store-sym) (getf fr-opt :offset-sym)))))
> + (find-tensor-refs from nil) (getf to-opt :store-sym) (getf to-opt :offset-sym)))))
> (t
> (list to (find-tensor-refs from nil))))))))))
> (transform-tensor-ref (snippet)
> diff --git a/src/standard-tensor.lisp b/src/standard-tensor.lisp
> index f4c257b..84d796c 100644
> --- a/src/standard-tensor.lisp
> +++ b/src/standard-tensor.lisp
> @@ -49,6 +49,9 @@
> (make-array size :element-type 'index-type
> :initial-contents contents)))
>
> +(definline idxv (&rest contents)
> + (make-index-store contents))
> +
> ;;
> (defclass standard-tensor ()
> ((rank
> @@ -121,7 +124,7 @@
> ((symbolp opt)
> (get-tensor-class-optimization opt))
> ((null opt) nil)
> - (t (value opt clname)))))
> + (t (values opt clname)))))
>
> ;; Akshay: I have no idea what this does, or why we want it
> ;; (inherited from standard-matrix.lisp
> @@ -153,7 +156,7 @@
> (type (index-array *) idx strides dims))
> (let ((rank (length strides)))
> (declare (type index-type rank))
> - (if (not (= rank (length idx)))
> + (if (not (= rank (length idx) (length dims)))
> (error 'tensor-index-rank-mismatch :index-rank (length idx) :rank rank)
> (very-quickly
> (loop
> diff --git a/src/tensor-copy.lisp b/src/tensor-copy.lisp
> index 2a1a2a3..3074106 100644
> --- a/src/tensor-copy.lisp
> +++ b/src/tensor-copy.lisp
> @@ -16,6 +16,70 @@
> (setf (tensor-ref x idx) (random 1d0)))
> (time (tensor-copy x y)))
>
> +(defun test-mm (n)
> + (let ((t-a (make-real-tensor-dims n n))
> + (t-b (make-real-tensor-dims n n))
> + (t-c (make-real-tensor-dims n n)))
> + (declare (type real-tensor t-a t-b t-c))
> + (with-optimization (:speed 3 :safety 0 :space 0)
> + (let ((st-a (store t-a))
> + (st-b (store t-b))
> + (st-c (store t-c)))
> + (declare (type (real-array *) st-a st-b st-c))
> + (mod-dotimes (idx (dimensions t-a))
> + with (linear-sums
> + (of-a (strides t-a))
> + (of-b (strides t-b))
> + (of-c (strides t-c)))
> + do (setf (aref st-a of-a) (random 1d0)
> + (aref st-b of-b) (random 1d0)
> + (aref st-c of-c) 0d0))
> + (time (mod-dotimes (idx (idxv n n n))
> + with (loop-order :row-major)
> + with (linear-sums
> + (of-a (idxv n 1 0))
> + (of-b (idxv 0 n 1))
> + (of-c (idxv n 0 1)))
> + do (incf (aref st-c of-c) (* (aref st-a of-a) (aref st-b of-b)))))))))
> +
> +
> +(defun test-mm ()
> + (let ((t-a (make-real-tensor-dims 1000 1000))
> + (t-b (make-real-tensor-dims 1000 1000))
> + (t-c (make-real-tensor-dims 1000 1000)))
> + (declare (type real-tensor t-a t-b t-c))
> + (mod-loop (idx #(1000 1000))
> + (declare (type real-tensor t-a t-b))
> + (setf (tensor-ref t-a idx) (random 1d0)
> + (tensor-ref t-b idx) (random 1d0)))
> + (let* ((sr-a (strides t-a))
> + (st-a (store t-a))
> + (sr-b (strides t-b))
> + (st-b (store t-b))
> + (sr-c (strides t-c))
> + (st-c (store t-c))
> + (dims (dimensions t-a))
> + (rank 2)
> + (idx (allocate-index-store rank)))
> + (declare (type (index-array *) sr-a sr-b sr-c dims idx)
> + (type (real-array *) st-a st-b st-c))
> + (time (very-quickly
> + (loop
> + with of-a of-type index-type = (head t-a)
> + with of-b of-type index-type = (head t-b)
> + with of-c of-type index-type = (head t-c)
> + do (incf (aref st-c of-c) (* (aref st-a of-a) (aref st-b of-b)))
> + while (loop
> + for i of-type index-type from (1- rank) downto 0
> + do (if (= (aref idx i) (1- (aref dims i)))
> + (progn
> + (setf (aref idx i) 0)
> + (decf of-a (* (1- (aref dims i))
> +
> +
> + (loop for k from 0 below 1000
> + summing (* (tensor-ref t-a `(,(aref idx 0) ,k)) (tensor-ref t-b `(,k ,(aref idx 1)))))))))
> +
> (defmacro generate-typed-copy!-func (func store-type matrix-type blas-func)
> ;;Be very careful when using functions generated by this macro.
> ;;Indexes can be tricky and this has no safety net
> @@ -41,23 +105,13 @@
> (loop for i from 0 below nr-a
> do (,blas-func nc-a st-a cs-a st-b cs-b :head-x (+ hd-a (* i rs-a)) :head-y (+ hd-b (* i rs-b)))))))
> mat-b))
> -
> -(defun test-mm ()
> - (let ((t-a (make-real-tensor 1000 1000))
> - (t-b (make-real-tensor 1000 1000))
> - (t-c (make-real-tensor 1000 1000)))
> - (declare (type real-tensor t-a t-b t-c))
> - (mod-loop (idx #(1000 1000))
> - (setf (tensor-ref t-c idx)
> - (loop for k from 0 below 1000
> - summing (* (tensor-ref t-a `(,(aref idx 0) ,k)) (tensor-ref t-b `(,k ,(aref idx 1)))))))))
> ;;
> -#+nil
> +
> (defun test-tensor-1k-dot ()
> (declare (optimize (speed 3) (safety 0)))
> - (let ((t-a (make-real-tensor 1000 1000))
> - (t-b (make-real-tensor 1000 1000))
> - (t-c (make-real-tensor 1000 1000)))
> + (let ((t-a (make-real-tensor-dims 1000 1000))
> + (t-b (make-real-tensor-dims 1000 1000))
> + (t-c (make-real-tensor-dims 1000 1000)))
> (declare (type real-tensor t-a t-b t-c))
> (let ((s-a (store t-a))
> (s-b (store t-b))
> @@ -71,5 +125,6 @@
> (multiple-value-bind (i j) (floor n 1000)
> (declare (type index-type i j))
> (setf (aref s-c (+ (* i 1000) j))
> - (ddot 1000 (vector-data-address s-a) 1 (vector-data-address s-b) 1000 :head-x (* i 1000) :head-y j))))))))
> + (loop for k from 0 below 1000
> + summing (* (aref s-a (+ (* i 1000) k)) (aref s-b (+ (* k 1000) j)))))))))))
>
>
> -----------------------------------------------------------------------
>
> Summary of changes:
> src/ffi-cffi-interpreter-specific.lisp | 2 +-
> src/loopy.lisp | 73 ++++++++++++++++++++++++---
> src/standard-tensor.lisp | 7 ++-
> src/tensor-copy.lisp | 85 ++++++++++++++++++++++++++------
> 4 files changed, 142 insertions(+), 25 deletions(-)
>
>
> hooks/post-receive
>
|
|
From: Akshay S. <ak...@us...> - 2012-06-26 14:54:21
|
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 82125cbf389c2f1bc43a5c661067400efcec64c3 (commit)
from 578dc43e356575b8c860f46f157c07d773843af8 (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 82125cbf389c2f1bc43a5c661067400efcec64c3
Author: Akshay Srinivasan <aks...@gm...>
Date: Tue Jun 26 20:17:02 2012 +0530
Wrote a mid-way solution "mod-dotimes" to allow for very effective
representation of matrix multiplication. Naive matrix multiplication
on SBCL is about 200x than dgemm in OpenBLAS, but only about 2x slower
compared to using naive nested loops in C.
diff --git a/src/ffi-cffi-interpreter-specific.lisp b/src/ffi-cffi-interpreter-specific.lisp
index 4d51dc0..92c285f 100644
--- a/src/ffi-cffi-interpreter-specific.lisp
+++ b/src/ffi-cffi-interpreter-specific.lisp
@@ -3,7 +3,7 @@
(in-package :ffi)
-;;TODO: Add support for {Allegro CL, Lispworks, ECL, clisp}
+;;TODO: Add support for {ECL, clisp, Allegro CL, Lispworks}
(defmacro with-fortran-float-modes (&body body)
"Execute the body with the IEEE FP modes appropriately set for Fortran"
diff --git a/src/loopy.lisp b/src/loopy.lisp
index d0cb80b..9d2e587 100644
--- a/src/loopy.lisp
+++ b/src/loopy.lisp
@@ -23,7 +23,71 @@ is used, else the fortran routine is called instead.
unless (= off accumulated-off) do (return nil)
finally (return t))))
-(defmacro mod-loop ((idx dims) &body body)
+
+(linloop (idx #(2 2))
+ with (loop-order row-order)
+ with (linear-sums
+ (of-t #(..))
+ (of-a #(..)))
+ do (..))
+
+(defmacro mod-dotimes ((idx dims) &body body)
+ (check-type idx symbol)
+ (labels ((parse-code (body ret)
+ (cond
+ ((null body)
+ (values nil ret))
+ ((eq (car body) 'with)
+ (multiple-value-bind (indic decl) (parse-with (cadr body))
+ (setf (getf ret indic) decl))
+ (parse-code (cddr body) ret))
+ ((eq (car body) 'do)
+ (values (cadr body) ret))
+ (t (error "unknown word passed to linloop: ~a" (car body)))))
+ (parse-with (code)
+ (cond
+ ((eq (car code) 'linear-sums)
+ (values :linear-sums
+ (loop for decl in (cdr code)
+ collect (destructuring-bind (offst strds &optional (init 0)) decl
+ (list :offset-sym offst
+ :offset-init init
+ :stride-sym (gensym (string+ (symbol-name offst) "-stride"))
+ :stride-expr strds)))))
+ ((and (eq (car code) 'loop-order)
+ (member (cadr code) '(:row-major :col-major)))
+ (values :loop-order (second code)))
+ (t (error "unknown word passed to linloop: ~a" (car code))))))
+ (multiple-value-bind (code sdecl) (parse-code body nil)
+ (with-gensyms (dims-sym rank-sym count-sym)
+ `(let* ((,dims-sym ,dims)
+ (,rank-sym (length ,dims-sym))
+ (,idx (allocate-index-store ,rank-sym))
+ ,@(mapcar #'(lambda (x) `(,(getf x :stride-sym) ,(getf x :stride-expr))) (getf sdecl :linear-sums)))
+ ,@(when (getf sdecl :linear-sums)
+ `((declare (type (index-array *) ,@(mapcar #'(lambda (x) (getf x :stride-sym)) (getf sdecl :linear-sums))))))
+ (loop ,@(loop for decl in (getf sdecl :linear-sums)
+ append `(with ,(getf decl :offset-sym) of-type index-type = ,(getf decl :offset-init)))
+ do (,@code)
+ while ,(append
+ (if (member (getf sdecl :loop-order) '(nil :row-major))
+ `(loop for ,count-sym of-type index-type from (1- ,rank-sym) downto 0)
+ `(loop for ,count-sym of-type index-type from 0 below ,rank-sym))
+ `(do (if (= (aref ,idx ,count-sym) (1- (aref ,dims-sym ,count-sym)))
+ (progn
+ (setf (aref ,idx ,count-sym) 0)
+ ,@(loop for decl in (getf sdecl :linear-sums)
+ collect `(decf ,(getf decl :offset-sym) (* (aref ,(getf decl :stride-sym) ,count-sym) (1- (aref ,dims-sym ,count-sym))))))
+ (progn
+ (incf (aref ,idx ,count-sym))
+ ,@(loop for decl in (getf sdecl :linear-sums)
+ collect `(incf ,(getf decl :offset-sym) (aref ,(getf decl :stride-sym) ,count-sym)))
+ (return t)))
+ finally (return nil)))))))))
+
+
+;;Very ugly inflexible code; get rid of this in some time or make use of mod-dotimes.
+#+nil(defmacro mod-loop ((idx dims) &body body)
(check-type idx symbol)
(let ((tensor-table (make-hash-table)))
(labels ((get-tensors (decl)
@@ -71,12 +135,7 @@ is used, else the fortran routine is called instead.
(let ((to-opt (gethash (second to) tensor-table)))
;;Add type checking here!
(cdr (funcall (getf (get-tensor-class-optimization (getf to-opt :class)) :value-writer)
- from (getf to-opt :store-sym) (getf to-opt :offset-sym)))))
- (fr-t?
- (incref (second from))
- (let ((fr-opt (gethash (second from) tensor-table)))
- (cons to (funcall (getf (get-tensor-class-optimization (getf fr-opt :class)) :reader)
- (getf fr-opt :store-sym) (getf fr-opt :offset-sym)))))
+ (find-tensor-refs from nil) (getf to-opt :store-sym) (getf to-opt :offset-sym)))))
(t
(list to (find-tensor-refs from nil))))))))))
(transform-tensor-ref (snippet)
diff --git a/src/standard-tensor.lisp b/src/standard-tensor.lisp
index f4c257b..84d796c 100644
--- a/src/standard-tensor.lisp
+++ b/src/standard-tensor.lisp
@@ -49,6 +49,9 @@
(make-array size :element-type 'index-type
:initial-contents contents)))
+(definline idxv (&rest contents)
+ (make-index-store contents))
+
;;
(defclass standard-tensor ()
((rank
@@ -121,7 +124,7 @@
((symbolp opt)
(get-tensor-class-optimization opt))
((null opt) nil)
- (t (value opt clname)))))
+ (t (values opt clname)))))
;; Akshay: I have no idea what this does, or why we want it
;; (inherited from standard-matrix.lisp
@@ -153,7 +156,7 @@
(type (index-array *) idx strides dims))
(let ((rank (length strides)))
(declare (type index-type rank))
- (if (not (= rank (length idx)))
+ (if (not (= rank (length idx) (length dims)))
(error 'tensor-index-rank-mismatch :index-rank (length idx) :rank rank)
(very-quickly
(loop
diff --git a/src/tensor-copy.lisp b/src/tensor-copy.lisp
index 2a1a2a3..3074106 100644
--- a/src/tensor-copy.lisp
+++ b/src/tensor-copy.lisp
@@ -16,6 +16,70 @@
(setf (tensor-ref x idx) (random 1d0)))
(time (tensor-copy x y)))
+(defun test-mm (n)
+ (let ((t-a (make-real-tensor-dims n n))
+ (t-b (make-real-tensor-dims n n))
+ (t-c (make-real-tensor-dims n n)))
+ (declare (type real-tensor t-a t-b t-c))
+ (with-optimization (:speed 3 :safety 0 :space 0)
+ (let ((st-a (store t-a))
+ (st-b (store t-b))
+ (st-c (store t-c)))
+ (declare (type (real-array *) st-a st-b st-c))
+ (mod-dotimes (idx (dimensions t-a))
+ with (linear-sums
+ (of-a (strides t-a))
+ (of-b (strides t-b))
+ (of-c (strides t-c)))
+ do (setf (aref st-a of-a) (random 1d0)
+ (aref st-b of-b) (random 1d0)
+ (aref st-c of-c) 0d0))
+ (time (mod-dotimes (idx (idxv n n n))
+ with (loop-order :row-major)
+ with (linear-sums
+ (of-a (idxv n 1 0))
+ (of-b (idxv 0 n 1))
+ (of-c (idxv n 0 1)))
+ do (incf (aref st-c of-c) (* (aref st-a of-a) (aref st-b of-b)))))))))
+
+
+(defun test-mm ()
+ (let ((t-a (make-real-tensor-dims 1000 1000))
+ (t-b (make-real-tensor-dims 1000 1000))
+ (t-c (make-real-tensor-dims 1000 1000)))
+ (declare (type real-tensor t-a t-b t-c))
+ (mod-loop (idx #(1000 1000))
+ (declare (type real-tensor t-a t-b))
+ (setf (tensor-ref t-a idx) (random 1d0)
+ (tensor-ref t-b idx) (random 1d0)))
+ (let* ((sr-a (strides t-a))
+ (st-a (store t-a))
+ (sr-b (strides t-b))
+ (st-b (store t-b))
+ (sr-c (strides t-c))
+ (st-c (store t-c))
+ (dims (dimensions t-a))
+ (rank 2)
+ (idx (allocate-index-store rank)))
+ (declare (type (index-array *) sr-a sr-b sr-c dims idx)
+ (type (real-array *) st-a st-b st-c))
+ (time (very-quickly
+ (loop
+ with of-a of-type index-type = (head t-a)
+ with of-b of-type index-type = (head t-b)
+ with of-c of-type index-type = (head t-c)
+ do (incf (aref st-c of-c) (* (aref st-a of-a) (aref st-b of-b)))
+ while (loop
+ for i of-type index-type from (1- rank) downto 0
+ do (if (= (aref idx i) (1- (aref dims i)))
+ (progn
+ (setf (aref idx i) 0)
+ (decf of-a (* (1- (aref dims i))
+
+
+ (loop for k from 0 below 1000
+ summing (* (tensor-ref t-a `(,(aref idx 0) ,k)) (tensor-ref t-b `(,k ,(aref idx 1)))))))))
+
(defmacro generate-typed-copy!-func (func store-type matrix-type blas-func)
;;Be very careful when using functions generated by this macro.
;;Indexes can be tricky and this has no safety net
@@ -41,23 +105,13 @@
(loop for i from 0 below nr-a
do (,blas-func nc-a st-a cs-a st-b cs-b :head-x (+ hd-a (* i rs-a)) :head-y (+ hd-b (* i rs-b)))))))
mat-b))
-
-(defun test-mm ()
- (let ((t-a (make-real-tensor 1000 1000))
- (t-b (make-real-tensor 1000 1000))
- (t-c (make-real-tensor 1000 1000)))
- (declare (type real-tensor t-a t-b t-c))
- (mod-loop (idx #(1000 1000))
- (setf (tensor-ref t-c idx)
- (loop for k from 0 below 1000
- summing (* (tensor-ref t-a `(,(aref idx 0) ,k)) (tensor-ref t-b `(,k ,(aref idx 1)))))))))
;;
-#+nil
+
(defun test-tensor-1k-dot ()
(declare (optimize (speed 3) (safety 0)))
- (let ((t-a (make-real-tensor 1000 1000))
- (t-b (make-real-tensor 1000 1000))
- (t-c (make-real-tensor 1000 1000)))
+ (let ((t-a (make-real-tensor-dims 1000 1000))
+ (t-b (make-real-tensor-dims 1000 1000))
+ (t-c (make-real-tensor-dims 1000 1000)))
(declare (type real-tensor t-a t-b t-c))
(let ((s-a (store t-a))
(s-b (store t-b))
@@ -71,5 +125,6 @@
(multiple-value-bind (i j) (floor n 1000)
(declare (type index-type i j))
(setf (aref s-c (+ (* i 1000) j))
- (ddot 1000 (vector-data-address s-a) 1 (vector-data-address s-b) 1000 :head-x (* i 1000) :head-y j))))))))
+ (loop for k from 0 below 1000
+ summing (* (aref s-a (+ (* i 1000) k)) (aref s-b (+ (* k 1000) j)))))))))))
-----------------------------------------------------------------------
Summary of changes:
src/ffi-cffi-interpreter-specific.lisp | 2 +-
src/loopy.lisp | 73 ++++++++++++++++++++++++---
src/standard-tensor.lisp | 7 ++-
src/tensor-copy.lisp | 85 ++++++++++++++++++++++++++------
4 files changed, 142 insertions(+), 25 deletions(-)
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2012-06-25 15:45:03
|
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 578dc43e356575b8c860f46f157c07d773843af8 (commit)
from 0f1b57f2c90f00aac4aa5ea6e7240ae69690409f (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 578dc43e356575b8c860f46f157c07d773843af8
Author: Akshay Srinivasan <aks...@gm...>
Date: Mon Jun 25 19:47:10 2012 +0530
More tweaks to mod-loop
diff --git a/src/complex-tensor.lisp b/src/complex-tensor.lisp
index 9ae6fbe..ebcdf7f 100644
--- a/src/complex-tensor.lisp
+++ b/src/complex-tensor.lisp
@@ -67,8 +67,8 @@ Cannot hold complex numbers."))
(aref store (1+ (* 2 idx))) (imagpart value)))
:reader-writer
(lambda (fstore fidx tstore tidx)
- (setf (aref fstore (* 2 fidx)) (aref tstore (* 2 tidx))
- (aref fstore (1+ (* 2 fidx))) (aref tstore (1+ (* 2 tidx))))))
+ (setf (aref tstore (* 2 tidx)) (aref fstore (* 2 fidx))
+ (aref tstore (1+ (* 2 tidx))) (aref fstore (1+ (* 2 fidx))))))
(setf (gethash 'complex-sub-tensor *tensor-class-optimizations*) 'complex-tensor)
diff --git a/src/loopy.lisp b/src/loopy.lisp
new file mode 100644
index 0000000..d0cb80b
--- /dev/null
+++ b/src/loopy.lisp
@@ -0,0 +1,147 @@
+(in-package :matlisp)
+
+(defparameter *lisp-copy-upper-bound* 1000
+ "When (< (store-size te) *LISP-COPY-UPPER-BOUND*) the method defined in Lisp
+is used, else the fortran routine is called instead.
+")
+
+(defun column-major-p (offsets dims)
+ (loop
+ for off across offsets
+ and dim across dims
+ and accumulated-off = 1 then (* accumulated-off dim)
+ unless (= off accumulated-off) do (return nil)
+ finally (return t)))
+
+(defun row-major-p (offsets dims)
+ (very-quickly
+ (loop
+ for idx of-type index-type from (1- (length dims)) downto 0
+ for dim of-type index-type = (aref dims idx)
+ for off of-type index-type = (aref offsets idx)
+ and accumulated-off of-type index-type = 1 then (* accumulated-off dim)
+ unless (= off accumulated-off) do (return nil)
+ finally (return t))))
+
+(defmacro mod-loop ((idx dims) &body body)
+ (check-type idx symbol)
+ (let ((tensor-table (make-hash-table)))
+ (labels ((get-tensors (decl)
+ (if (null decl) t
+ (let ((cdecl (car decl)))
+ (when (and (eq (first cdecl) 'type)
+ (get-tensor-class-optimization (second cdecl)))
+ (dolist (sym (cddr cdecl))
+ (let ((hsh (list
+ :class (second cdecl)
+ :stride-sym (gensym (string+ (symbol-name sym) "-stride"))
+ :store-sym (gensym (string+ (symbol-name sym) "-store"))
+ :offset-sym (gensym (string+ (symbol-name sym) "-offset"))
+ :ref-count 0)))
+ (setf (gethash sym tensor-table) hsh))))
+ (get-tensors (cdr decl)))))
+ (ttrans-p (code)
+ (and (consp code) (eq (first code) 'tensor-ref)
+ (gethash (second code) tensor-table)
+ (eq (third code) idx)))
+ (incref (ten)
+ (incf (getf (gethash ten tensor-table) :ref-count)))
+ (transform-setf-tensor-ref (snippet ret)
+ (if (null snippet) ret
+ (transform-setf-tensor-ref
+ (cddr snippet)
+ (append ret
+ (destructuring-bind (to from &rest rest) snippet
+ (declare (ignore rest))
+ (let ((to-t? (ttrans-p to))
+ (fr-t? (ttrans-p from)))
+ (cond
+ ((and to-t? fr-t?)
+ (let ((to-opt (gethash (second to) tensor-table))
+ (fr-opt (gethash (second from) tensor-table)))
+ (if (eq (second (multiple-value-list (get-tensor-class-optimization (getf to-opt :class))))
+ (second (multiple-value-list (get-tensor-class-optimization (getf fr-opt :class)))))
+ (progn
+ (incref (second to)) (incref (second from))
+ (cdr (funcall (getf (get-tensor-class-optimization (getf to-opt :class)) :reader-writer)
+ (getf fr-opt :store-sym) (getf fr-opt :offset-sym) (getf to-opt :store-sym) (getf to-opt :offset-sym))))
+ (list to (find-tensor-refs from nil)))))
+ (to-t?
+ (incref (second to))
+ (let ((to-opt (gethash (second to) tensor-table)))
+ ;;Add type checking here!
+ (cdr (funcall (getf (get-tensor-class-optimization (getf to-opt :class)) :value-writer)
+ from (getf to-opt :store-sym) (getf to-opt :offset-sym)))))
+ (fr-t?
+ (incref (second from))
+ (let ((fr-opt (gethash (second from) tensor-table)))
+ (cons to (funcall (getf (get-tensor-class-optimization (getf fr-opt :class)) :reader)
+ (getf fr-opt :store-sym) (getf fr-opt :offset-sym)))))
+ (t
+ (list to (find-tensor-refs from nil))))))))))
+ (transform-tensor-ref (snippet)
+ (if (eq (first snippet) 'setf)
+ (cons 'setf (transform-setf-tensor-ref (cdr snippet) nil))
+ (destructuring-bind (tref ten index) snippet
+ (assert (eq tref 'tensor-ref))
+ (let ((topt (gethash ten tensor-table)))
+ (if (not (and (eq index idx) topt)) snippet
+ (progn
+ (incref ten)
+ (funcall (getf (get-tensor-class-optimization (getf topt :class)) :reader) (getf topt :store-sym) (getf topt :offset-sym))))))))
+ (find-tensor-refs (code ret)
+ (if (null code) (reverse ret)
+ (cond
+ ((consp code)
+ (if (member (first code) '(tensor-ref setf))
+ (transform-tensor-ref code)
+ (find-tensor-refs (cdr code) (cons (find-tensor-refs (car code) nil) ret))))
+ (t code)))))
+ ;;
+ (when (eq (caar body) 'declare)
+ (get-tensors (cdar body)))
+ (let ((tr-body (find-tensor-refs body nil)))
+ (with-gensyms (dims-sym rank-sym count-sym)
+ `(let* ((,dims-sym ,dims)
+ (,rank-sym (length ,dims-sym))
+ (,idx (allocate-index-store ,rank-sym))
+ ,@(loop for key being the hash-keys of tensor-table
+ when (> (getf (gethash key tensor-table) :ref-count) 0)
+ collect (let ((hsh (gethash key tensor-table)))
+ `(,(getf hsh :stride-sym) (strides ,key))))
+ ,@(loop for key being the hash-keys of tensor-table
+ when (> (getf (gethash key tensor-table) :ref-count) 0)
+ collect (let ((hsh (gethash key tensor-table)))
+ `(,(getf hsh :store-sym) (store ,key)))))
+ (declare (type (index-array *) ,idx ,@(loop for key being the hash-keys of tensor-table
+ when (> (getf (gethash key tensor-table) :ref-count) 0)
+ collect (getf (gethash key tensor-table) :stride-sym)))
+ ,@(loop for key being the hash-keys of tensor-table
+ when (> (getf (gethash key tensor-table) :ref-count) 0)
+ collect (let* ((hsh (gethash key tensor-table))
+ (opt (get-tensor-class-optimization (getf hsh :class))))
+ `(type ,(linear-array-type (getf opt :store-type)) ,(getf hsh :store-sym)))))
+ (loop
+ ,@(loop for key being the hash-keys of tensor-table
+ when (> (getf (gethash key tensor-table) :ref-count) 0)
+ append (let ((hsh (gethash key tensor-table)))
+ `(with ,(getf hsh :offset-sym) of-type index-type = (head ,key))))
+ do (locally
+ ,@tr-body)
+ ;;Optimized for row-order
+ while (loop for ,count-sym of-type index-type from (1- ,rank-sym) downto 0
+ do (if (= (aref ,idx ,count-sym) (1- (aref ,dims-sym ,count-sym)))
+ (progn
+ (setf (aref ,idx ,count-sym) 0)
+ ,@(loop for key being the hash-keys of tensor-table
+ when (> (getf (gethash key tensor-table) :ref-count) 0)
+ collect (let ((hsh (gethash key tensor-table)))
+ `(decf ,(getf hsh :offset-sym) (* (aref ,(getf hsh :stride-sym) ,count-sym) (1- (aref ,dims-sym ,count-sym)))))))
+ (progn
+ (incf (aref ,idx ,count-sym))
+ ,@(loop for key being the hash-keys of tensor-table
+ when (> (getf (gethash key tensor-table) :ref-count) 0)
+ collect (let ((hsh (gethash key tensor-table)))
+ `(incf ,(getf hsh :offset-sym) (aref ,(getf hsh :stride-sym) ,count-sym))))
+ (return t)))
+ finally (return nil)))))))))
diff --git a/src/real-tensor.lisp b/src/real-tensor.lisp
index b47f5be..9855a0c 100644
--- a/src/real-tensor.lisp
+++ b/src/real-tensor.lisp
@@ -49,7 +49,7 @@ Allocates real storage. Default initial-element = 0d0.")
(setf (aref store idx) value))
:reader-writer
(lambda (fstore fidx tstore tidx)
- (setf (aref fstore fidx) (aref tstore tidx))))
+ (setf (aref tstore tidx) (aref fstore fidx))))
(setf (gethash 'real-sub-tensor *tensor-class-optimizations*) 'real-tensor)
diff --git a/src/standard-tensor.lisp b/src/standard-tensor.lisp
index 3ef4919..f4c257b 100644
--- a/src/standard-tensor.lisp
+++ b/src/standard-tensor.lisp
@@ -92,7 +92,6 @@
:accessor parent-tensor))
(:documentation "Basic sub-tensor class."))
-
;;
(defparameter *sub-tensor-counterclass* (make-hash-table)
"
@@ -122,7 +121,7 @@
((symbolp opt)
(get-tensor-class-optimization opt))
((null opt) nil)
- (t opt))))
+ (t (value opt clname)))))
;; Akshay: I have no idea what this does, or why we want it
;; (inherited from standard-matrix.lisp
@@ -219,10 +218,10 @@
i = 0
"
(declare (type standard-tensor tensor)
- (type (or cons (index-array *)) idx))
+ (type (or (index-array *) cons) idx))
(typecase idx
(cons (store-indexing-lst idx (head tensor) (strides tensor) (dimensions tensor)))
- (vector (store-indexing-lst idx (head tensor) (strides tensor) (dimensions tensor)))))
+ (vector (store-indexing-vec idx (head tensor) (strides tensor) (dimensions tensor)))))
;;
(defmethod initialize-instance :after ((tensor standard-tensor) &rest initargs)
diff --git a/src/tensor-copy.lisp b/src/tensor-copy.lisp
index 3400bc3..2a1a2a3 100644
--- a/src/tensor-copy.lisp
+++ b/src/tensor-copy.lisp
@@ -1,140 +1,15 @@
(in-package :matlisp)
-(defparameter *lisp-copy-upper-bound* 1000
- "When (< (store-size te) *LISP-COPY-UPPER-BOUND*) the method defined in Lisp
-is used, else the fortran routine is called instead.
-")
-
-(defun column-major-p (offsets dims)
- (loop
- for off across offsets
- and dim across dims
- and accumulated-off = 1 then (* accumulated-off dim)
- unless (= off accumulated-off) do (return nil)
- finally (return t)))
-
-(defun row-major-p (offsets dims)
- (very-quickly
- (loop
- for idx of-type index-type from (1- (length dims)) downto 0
- for dim of-type index-type = (aref dims idx)
- for off of-type index-type = (aref offsets idx)
- and accumulated-off of-type index-type = 1 then (* accumulated-off dim)
- unless (= off accumulated-off) do (return nil)
- finally (return t))))
-
-(defmacro mod-loop ((idx dims) &body body)
- (check-type idx symbol)
- (let ((tensor-table (make-hash-table)))
- (labels ((get-tensors (decl)
- (if (null decl) t
- (let ((cdecl (car decl)))
- (when (and (eq (first cdecl) 'type)
- (get-tensor-class-optimization (second cdecl)))
- (dolist (sym (cddr cdecl))
- (let ((hsh (list
- :class (second cdecl)
- :stride-sym (gensym (string+ (symbol-name sym) "-stride"))
- :store-sym (gensym (string+ (symbol-name sym) "-store"))
- :offset-sym (gensym (string+ (symbol-name sym) "-offset")))))
- (setf (gethash sym tensor-table) hsh))))
- (get-tensors (cdr decl)))))
- (ttrans-p (code)
- (and (eq (first code) 'tensor-ref)
- (gethash (second code) tensor-table)
- (eq (third code) idx)))
- (transform-setf-tensor-ref (snippet ret)
- (if (null snippet) ret
- (transform-setf-tensor-ref
- (cddr snippet)
- (append ret
- (destructuring-bind (to from &rest rest) snippet
- (declare (ignore rest))
- (let ((to-t? (ttrans-p to))
- (fr-t? (ttrans-p from)))
- (cond
- ((and to-t? fr-t?)
- (let ((to-opt (gethash (second to) tensor-table))
- (fr-opt (gethash (second from) tensor-table)))
- ;;Add type checking here!
- (cdr (funcall (getf (get-tensor-class-optimization (getf to-opt :class)) :reader-writer)
- (getf fr-opt :store-sym) (getf fr-opt :offset-sym) (getf to-opt :store-sym) (getf to-opt :offset-sym)))))
- (to-t?
- (let ((to-opt (gethash (second to) tensor-table)))
- ;;Add type checking here!
- (cdr (funcall (getf (get-tensor-class-optimization (getf to-opt :class)) :value-writer)
- from (getf to-opt :store-sym) (getf to-opt :offset-sym)))))
- (fr-t?
- (let ((fr-opt (gethash (second from) tensor-table)))
- (cons to (funcall (getf (get-tensor-class-optimization (getf fr-opt :class)) :reader)
- (getf fr-opt :store-sym) (getf fr-opt :offset-sym)))))
- (t
- (list to from)))))))))
- (transform-tensor-ref (snippet)
- (if (eq (first snippet) 'setf)
- (cons 'setf (transform-setf-tensor-ref (cdr snippet) nil))
- (destructuring-bind (tref ten index) snippet
- (assert (eq tref 'tensor-ref))
- (let ((topt (gethash ten tensor-table)))
- (if (not (and (eq index idx) topt)) snippet
- (funcall (getf (get-tensor-class-optimization (getf topt :class)) :reader) (getf topt :store-sym) (getf topt :offset-sym)))))))
- (find-tensor-refs (code ret)
- (if (null code) (reverse ret)
- (cond
- ((consp code)
- (if (member (first code) '(tensor-ref setf))
- (transform-tensor-ref code)
- (find-tensor-refs (cdr code) (cons (find-tensor-refs (car code) nil) ret))))
- (t code)))))
- (when (eq (caar body) 'declare)
- (get-tensors (cdar body)))
- (with-gensyms (dims-sym rank-sym count-sym)
- `(let* ((,dims-sym ,dims)
- (,rank-sym (length ,dims-sym))
- (,idx (allocate-index-store ,rank-sym))
- ,@(loop for key being the hash-keys of tensor-table
- collect (let ((hsh (gethash key tensor-table)))
- `(,(getf hsh :stride-sym) (strides ,key))))
- ,@(loop for key being the hash-keys of tensor-table
- collect (let ((hsh (gethash key tensor-table)))
- `(,(getf hsh :store-sym) (store ,key)))))
- (declare (type (index-array *) ,idx ,@(loop for key being the hash-keys of tensor-table
- collect (getf (gethash key tensor-table) :stride-sym)))
- ,@(loop for key being the hash-keys of tensor-table
- collect (let* ((hsh (gethash key tensor-table))
- (opt (get-tensor-class-optimization (getf hsh :class))))
- `(type ,(linear-array-type (getf opt :store-type)) ,(getf hsh :store-sym)))))
- (loop
- ,@(loop for key being the hash-keys of tensor-table
- append (let ((hsh (gethash key tensor-table)))
- `(with ,(getf hsh :offset-sym) of-type index-type = (head ,key))))
- do (locally
- ,@(find-tensor-refs body nil))
- while (dotimes (,count-sym ,rank-sym nil)
- (declare (type index-type ,count-sym))
- (if (= (aref ,idx ,count-sym) (1- (aref ,dims-sym ,count-sym)))
- (progn
- (setf (aref ,idx ,count-sym) 0)
- ,@(loop for key being the hash-keys of tensor-table
- collect (let ((hsh (gethash key tensor-table)))
- `(decf ,(getf hsh :offset-sym) (* (aref ,(getf hsh :stride-sym) ,count-sym) (1- (aref ,dims-sym ,count-sym)))))))
- (progn
- (incf (aref ,idx ,count-sym))
- ,@(loop for key being the hash-keys of tensor-table
- collect (let ((hsh (gethash key tensor-table)))
- `(incf ,(getf hsh :offset-sym) (aref ,(getf hsh :stride-sym) ,count-sym))))
- (return t))))))))))
-
(defun tensor-copy (from to)
- (declare (optimize (speed 3) (safety 0))
+ (declare (optimize (speed 3) (safety 0) (space 0))
(type real-tensor to from))
(let ((dims (dimensions from)))
(mod-loop (idx dims)
- (declare (type real-tensor to from))
+ (declare (type real-tensor to from)
+ (optimize (speed 3) (safety 0) (space 0)))
(setf (tensor-ref to idx) (tensor-ref from idx)))))
-
-(let ((x (make-real-tensor-dims 100 100 100))
+#+nil(let ((x (make-real-tensor-dims 100 100 100))
(y (make-real-tensor-dims 100 100 100)))
(mod-loop (idx #(100 100 100))
(declare (type real-tensor x y))
@@ -167,72 +42,15 @@ is used, else the fortran routine is called instead.
do (,blas-func nc-a st-a cs-a st-b cs-b :head-x (+ hd-a (* i rs-a)) :head-y (+ hd-b (* i rs-b)))))))
mat-b))
-
-(defun real-typed-copy!-func (ten-a ten-b)
-
-
-
-(defun find-longest-chain (stds dims))
-
-;; (defun tensor-copy (to from)
-;; (declare (optimize (speed 3) (safety 0))
-;; (type real-tensor to from))
-;; (let* ((rank (rank to))
-;; (dims (dimensions to))
-;; (t-strides (strides to))
-;; (f-strides (strides from))
-;; (t-store (store to))
-;; (f-store (store from))
-;; (idx (allocate-index-store rank)))
-;; (declare (type (index-array *) dims t-strides f-strides idx)
-;; (type (real-array *) t-store f-store))
-;; (loop
-;; with of-t of-type index-type = (head to)
-;; with of-f of-type index-type = (head from)
-;; do (setf (aref t-store of-f) (aref f-store of-f))
-;; while (dotimes (i rank nil)
-;; (incf (aref idx i))
-;; (incf of-t (aref t-strides i))
-;; (incf of-f (aref f-strides i))
-;; (when (< (aref idx i) (aref dims i)) (return t))
-;; (setf (aref idx i) 0)
-;; (decf of-t (* (aref t-strides i) (aref dims i)))
-;; (decf of-f (* (aref f-strides i) (aref dims i)))))))
-
-;; (cffi:define-foreign-library strided-copy
-;; (t (:default "/home/neptune/devel/matlisp/csrc/libtcopy")))
-
-;; (cffi:use-foreign-library strided-copy)
-
-;; (cffi:defcfun ("tcopy_" fortran-tcopy) :void
-;; (rank :pointer :int64) (dims :pointer :int64)
-;; (head-t :pointer :int64) (strides-t :pointer :int64) (data-t :pointer :double)
-;; (head-f :pointer :int64) (strides-f :pointer :int64) (data-f :pointer :double)
-;; (idx-work :pointer :int64))
-
-;; (defun tcopy (rank dims head-t strides-t data-t head-f strides-f data-f idx-work)
-;; (with-foreign-objects-stacked ((r :int64 :initial-element rank)
-;; (ht :int64 :initial-element head-t)
-;; (hf :int64 :initial-element head-f))
-;; (fortran-tcopy r (sb-sys:vector-sap dims)
-;; ht (sb-sys:vector-sap strides-t) (sb-sys:vector-sap data-t)
-;; hf (sb-sys:vector-sap strides-f) (sb-sys:vector-sap data-f)
-;; (sb-sys:vector-sap idx-work))))
-
-;; (cffi:defcfun ("strided_copy" strided-copy) :void
-;; (rank :int64) (dims :pointer :int64)
-;; (head-t :int64) (strides-t :pointer :int64) (data-t :pointer :double)
-;; (head-f :int64) (strides-f :pointer :int64) (data-f :pointer :double)
-;; (idx-work :pointer :int64))
-
-;; (let* ((idx (allocate-index-store (rank x))))
-;; (time (strided-copy (rank x) (sb-sys:vector-sap (dimensions x))
-;; (head x) (sb-sys:vector-sap (strides x)) (vector-data-address (store x))
-;; (head y) (sb-sys:vector-sap (strides y)) (vector-data-address (store y))
-;; (sb-sys:vector-sap idx))))
-
-
-
+(defun test-mm ()
+ (let ((t-a (make-real-tensor 1000 1000))
+ (t-b (make-real-tensor 1000 1000))
+ (t-c (make-real-tensor 1000 1000)))
+ (declare (type real-tensor t-a t-b t-c))
+ (mod-loop (idx #(1000 1000))
+ (setf (tensor-ref t-c idx)
+ (loop for k from 0 below 1000
+ summing (* (tensor-ref t-a `(,(aref idx 0) ,k)) (tensor-ref t-b `(,k ,(aref idx 1)))))))))
;;
#+nil
(defun test-tensor-1k-dot ()
-----------------------------------------------------------------------
Summary of changes:
src/complex-tensor.lisp | 4 +-
src/loopy.lisp | 147 ++++++++++++++++++++++++++++++++
src/real-tensor.lisp | 2 +-
src/standard-tensor.lisp | 7 +-
src/tensor-copy.lisp | 208 +++-------------------------------------------
5 files changed, 166 insertions(+), 202 deletions(-)
create mode 100644 src/loopy.lisp
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <aks...@gm...> - 2012-06-25 10:33:53
|
On 06/25/2012 03:51 PM, Akshay Srinivasan wrote: > 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 0f1b57f2c90f00aac4aa5ea6e7240ae69690409f (commit) > from 8bb55ab5b53aa70785619511fcd6457b3bb79401 (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 0f1b57f2c90f00aac4aa5ea6e7240ae69690409f > Author: Akshay Srinivasan <aks...@gm...> > Date: Mon Jun 25 15:46:15 2012 +0530 > > Added mod-loop for doing multi-index loops seemlessly. Must add more checks. > Added tensor-copy; can run things at about 3x BLAS (dcopy) speed (!) :) Sorry the point about 3x BLAS speed is plainly wrong. It is about 3-4 times faster running on SBCL compared to fortran/C, when working with *strided* tensors. Basically, I mean that multi-index loops in C are much slower than on SBCL. BLAS-dcopy is only useful for copying linearly ordered tensors, and is about 10 times faster than using a multi-index loop in lisp; which is hardly surprising. Akshay |
