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...> - 2013-01-27 02:41: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 8230a46f93849cdb60ce09173ab31687f998d07d (commit)
from a9eca9b0cc4287b81b325360972175771d7f6c71 (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 8230a46f93849cdb60ce09173ab31687f998d07d
Author: Akshay Srinivasan <aks...@gm...>
Date: Sat Jan 26 18:37:12 2013 -0800
o Added more loops to GEMM.
o Fixed bugs in :h :c handling inside complex-typed-gemm!
diff --git a/src/level-1/trans.lisp b/src/level-1/trans.lisp
index b1c0e00..2f7ab5b 100644
--- a/src/level-1/trans.lisp
+++ b/src/level-1/trans.lisp
@@ -81,9 +81,10 @@
(copy! value (TRANSPOSE~ tensor permutation))"
(declare (type standard-tensor A))
(let ((displaced (make-instance (class-of A) :store (store A)
- :dimensions (copy-seq (dimensions A))
- :strides (copy-seq (strides A))
- :parent-tensor A)))
+ :store-size (store-size A)
+ :dimensions (copy-seq (dimensions A))
+ :strides (copy-seq (strides A))
+ :parent-tensor A)))
(transpose! displaced permutation)))
(definline (setf transpose~) (value A &optional permutation)
@@ -139,7 +140,7 @@
(etypecase A
(real-tensor A)
(complex-tensor
- (scal! -1 (tensor-imagpart~ A))
+ (real-typed-num-scal! -1d0 (tensor-imagpart~ A))
A)
(number (conjugate A))))
diff --git a/src/level-3/gemm.lisp b/src/level-3/gemm.lisp
index 48831ee..9ed038c 100644
--- a/src/level-3/gemm.lisp
+++ b/src/level-3/gemm.lisp
@@ -52,18 +52,15 @@
(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))))
- ;;Replace with separate loops to maximize Row-ordered MM performance
+ (hd-C (head C) :type index-type))
+ ;;Replace with separate loops to maximize Row-ordered MM performance
(when (eq job-A :t)
(rotatef rstp-A cstp-A))
(when (eq job-B :t)
@@ -71,14 +68,18 @@
;;
(unless (,(getf opt :f=) beta (,(getf opt :fid*)))
(,(getf opt :num-scal) beta C))
- ;;
+ ;;Most of these loop orderings are borrowed from the Fortran reference
+ ;;implementation of BLAS.
(cond
- ((and (= cstp-C 1) (= cstp-B 1) nil)
+ ((and (= cstp-C 1) (= cstp-B 1))
(let-typed ((of-A hd-A :type index-type)
(of-B hd-B :type index-type)
(of-C hd-C :type index-type)
(d.rstp-B (- rstp-B nc-C) :type index-type)
- (d.rstp-A (- rstp-A (* cstp-A dotl)) :type index-type))
+ (d.rstp-A (- rstp-A (* cstp-A dotl)) :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))))
(very-quickly
(loop :repeat nr-C
:do (progn
@@ -97,13 +98,99 @@
(incf of-C rstp-C)
(incf of-A d.rstp-A)
(setf of-B hd-B))))))
+ ((and (= cstp-A 1) (= rstp-B 1))
+ (let-typed ((of-A hd-A :type index-type)
+ (of-B hd-B :type index-type)
+ (of-C hd-C :type index-type)
+ (d.cstp-B (- cstp-B dotl) :type index-type)
+ (d.rstp-C (- rstp-C (* nc-C cstp-C)) :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)))
+ (dot (,(getf opt :fid+)) :type ,(getf opt :element-type)))
+ (very-quickly
+ (loop :repeat nr-C
+ :do (progn
+ (loop :repeat nc-C
+ :do (progn
+ (setf dot (,(getf opt :fid+)))
+ (loop :repeat dotl
+ :do (progn
+ (setf dot (,(getf opt :f+) dot (,(getf opt :f*) (,(getf opt :reader) sto-A of-A) (,(getf opt :reader) sto-B of-B))))
+ (incf of-A)
+ (incf of-B)))
+ (,(getf opt :value-incfer) dot sto-C of-C)
+ (incf of-C cstp-C)
+ (decf of-A dotl)
+ (incf of-B d.cstp-B)))
+ (incf of-C d.rstp-C)
+ (incf of-A rstp-A)
+ (setf of-B hd-B))))))
+ ((and (= cstp-A 1) (= rstp-B 1))
+ (let-typed ((of-A hd-A :type index-type)
+ (of-B hd-B :type index-type)
+ (of-C hd-C :type index-type)
+ (d.cstp-B (- cstp-B dotl) :type index-type)
+ (d.rstp-C (- rstp-C (* nc-C cstp-C)) :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)))
+ (dot (,(getf opt :fid+)) :type ,(getf opt :element-type)))
+ (very-quickly
+ (loop :repeat nr-C
+ :do (progn
+ (loop :repeat nc-C
+ :do (progn
+ (setf dot (,(getf opt :fid+)))
+ (loop :repeat dotl
+ :do (progn
+ (setf dot (,(getf opt :f+) dot (,(getf opt :f*) (,(getf opt :reader) sto-A of-A) (,(getf opt :reader) sto-B of-B))))
+ (incf of-A)
+ (incf of-B)))
+ (,(getf opt :value-incfer) dot sto-C of-C)
+ (incf of-C cstp-C)
+ (decf of-A dotl)
+ (incf of-B d.cstp-B)))
+ (incf of-C d.rstp-C)
+ (incf of-A rstp-A)
+ (setf of-B hd-B))))))
+ ((and (= rstp-A 1) (= rstp-C 1))
+ (let-typed ((of-A hd-A :type index-type)
+ (of-B hd-B :type index-type)
+ (of-C hd-C :type index-type)
+ (d.cstp-B (- cstp-B (* rstp-B dotl)) :type index-type)
+ (d.cstp-A (- cstp-A nr-C) :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))))
+ (very-quickly
+ (loop :repeat nc-C
+ :do (progn
+ (loop :repeat dotl
+ :do (let-typed
+ ((ele-B (,(getf opt :f*) alpha (,(getf opt :reader) sto-B of-B)) :type ,(getf opt :element-type)))
+ (loop :repeat nr-C
+ :do (progn
+ (,(getf opt :value-incfer) (,(getf opt :f*) ele-B (,(getf opt :reader) sto-A of-A))
+ sto-C of-C)
+ (incf of-C)
+ (incf of-A)))
+ (decf of-C nr-C)
+ (incf of-A d.cstp-A)
+ (incf of-B rstp-B)))
+ (incf of-C cstp-C)
+ (setf of-A hd-A)
+ (incf of-B d.cstp-B))))))
(t
(let-typed ((of-A hd-A :type index-type)
(of-B hd-B :type index-type)
(of-C hd-C :type index-type)
(r.cstp-C (* cstp-C nc-C) :type index-type)
(d.rstp-B (- rstp-B (* cstp-B nc-C)) :type index-type)
- (d.rstp-A (- rstp-A (* cstp-A dotl)) :type index-type))
+ (d.rstp-A (- rstp-A (* cstp-A dotl)) :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))))
(very-quickly
(loop :repeat nr-C
:do (progn
@@ -193,18 +280,14 @@
(complex-base-typed-gemm! alpha A B beta C job)
(let ((A (ecase job-A
((:n :t) A)
- ((:h :c)
- ;;BUG!
- ;;Multiplication does not yield the complex conjugate!
- (let ((ret (apply #'make-complex-tensor (lvec->list (dimensions A)))))
- (complex-typed-axpy! #c(-1d0 0d0) A ret)))))
+ ((:h :c) (let ((ret (complex-typed-copy! A (complex-typed-zeros (dimensions A)))))
+ (real-typed-num-scal! -1d0 (tensor-imagpart~ ret))
+ ret))))
(B (ecase job-B
((:n :t) B)
- ((:h :c)
- ;;BUG!
- ;;Multiplication does not yield the complex conjugate!
- (let ((ret (apply #'make-complex-tensor (lvec->list (dimensions B)))))
- (complex-typed-axpy! #c(-1d0 0d0) B ret)))))
+ ((:h :c) (let ((ret (complex-typed-copy! A (complex-typed-zeros (dimensions A)))))
+ (real-typed-num-scal! -1d0 (tensor-imagpart~ ret))
+ ret))))
(tjob (combine-jobs (ecase job-A ((:n :t) job-A) (:h :t) (:c :n))
(ecase job-B ((:n :t) job-B) (:h :t) (:c :n)))))
(complex-base-typed-gemm! alpha A B
-----------------------------------------------------------------------
Summary of changes:
src/level-1/trans.lisp | 9 ++--
src/level-3/gemm.lisp | 121 ++++++++++++++++++++++++++++++++++++++++--------
2 files changed, 107 insertions(+), 23 deletions(-)
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2013-01-26 19:07: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 a9eca9b0cc4287b81b325360972175771d7f6c71 (commit)
from 4862a338530bb1b435f2d6535913abe9947931b6 (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 a9eca9b0cc4287b81b325360972175771d7f6c71
Author: Akshay Srinivasan <aks...@gm...>
Date: Sat Jan 26 11:00:46 2013 -0800
o gemm! now copies matrices and then calls gemm if they have weird
incompatible strides (replacing the elaborate scheme from before
of using gemv).
o define-tensor now takes a new field "value-incfer".
diff --git a/src/base/standard-tensor.lisp b/src/base/standard-tensor.lisp
index 101c7cb..60b3d8d 100644
--- a/src/base/standard-tensor.lisp
+++ b/src/base/standard-tensor.lisp
@@ -351,9 +351,9 @@
((tensor-class element-type store-element-type store-type &rest class-decls) &key
f+ f- finv+ fid+ f* f/ finv* fid* fconj f=
matrix vector
- store-allocator coercer coercer-unforgiving reader value-writer reader-writer swapper)
+ store-allocator coercer coercer-unforgiving reader value-writer value-incfer reader-writer swapper)
;;Error checking
- (assert (and f+ f- finv+ fid+ f* f/ finv* fid* f= store-allocator coercer coercer-unforgiving matrix vector reader value-writer reader-writer swapper))
+ (assert (and f+ f- finv+ fid+ f* f/ finv* fid* f= store-allocator coercer coercer-unforgiving matrix vector reader value-writer value-incfer reader-writer swapper))
;;
`(eval-when (:compile-toplevel :load-toplevel :execute)
;;Class definitions
@@ -399,6 +399,7 @@
:fconj ',fconj
:reader ',reader
:value-writer ',value-writer
+ :value-incfer ',value-incfer
:reader-writer ',reader-writer
:swapper ',swapper
:store-allocator ',store-allocator
diff --git a/src/classes/complex-tensor.lisp b/src/classes/complex-tensor.lisp
index 276e9f5..382641a 100644
--- a/src/classes/complex-tensor.lisp
+++ b/src/classes/complex-tensor.lisp
@@ -89,6 +89,13 @@
(setf (aref store (* 2 idx)) (realpart value)
(aref store (1+ (* 2 idx))) (imagpart value)))
+(definline complex-type.value-incfer (value store idx)
+ (declare (type complex-store-vector store)
+ (type index-type idx)
+ (type complex-type value))
+ (incf (aref store (* 2 idx)) (realpart value))
+ (incf (aref store (1+ (* 2 idx))) (imagpart value)))
+
(definline complex-type.reader-writer (fstore fidx tstore tidx)
(declare (type complex-store-vector fstore tstore)
(type index-type fidx tidx))
@@ -125,6 +132,7 @@
;;
:reader complex-type.reader
:value-writer complex-type.value-writer
+ :value-incfer complex-type.value-incfer
:reader-writer complex-type.reader-writer
:swapper complex-type.swapper)
diff --git a/src/classes/real-tensor.lisp b/src/classes/real-tensor.lisp
index 4924b69..ac5d144 100644
--- a/src/classes/real-tensor.lisp
+++ b/src/classes/real-tensor.lisp
@@ -55,6 +55,12 @@
(type real-type value))
(setf (aref store idx) value))
+(definline real-type.value-incfer (value store idx)
+ (declare (type index-type idx)
+ (type real-store-vector store)
+ (type real-type value))
+ (incf (aref store idx) value))
+
(definline real-type.reader-writer (fstore fidx tstore tidx)
(declare (type index-type fidx tidx)
(type real-store-vector fstore tstore))
@@ -99,6 +105,7 @@ Allocates real storage. Default initial-element = 0d0.")
;;
:reader real-type.reader
:value-writer real-type.value-writer
+ :value-incfer real-type.value-incfer
:reader-writer real-type.reader-writer
:swapper real-type.swapper)
diff --git a/src/classes/symbolic-tensor.lisp b/src/classes/symbolic-tensor.lisp
index d837051..0365929 100644
--- a/src/classes/symbolic-tensor.lisp
+++ b/src/classes/symbolic-tensor.lisp
@@ -67,6 +67,12 @@
(type symbolic-type value))
(setf (aref store idx) value))
+(definline symbolic-type.value-incfer (value store idx)
+ (declare (type index-type idx)
+ (type symbolic-store-vector store)
+ (type symbolic-type value))
+ (setf (aref store idx) (symbolic-type.f+ (aref store idx) value)))
+
(definline symbolic-type.reader-writer (fstore fidx tstore tidx)
(declare (type index-type fidx tidx)
(type symbolic-store-vector fstore tstore))
@@ -110,6 +116,7 @@ Allocates symbolic storage. Default initial-element = 0.")
;;
:reader symbolic-type.reader
:value-writer symbolic-type.value-writer
+ :value-incfer symbolic-type.value-incfer
:reader-writer symbolic-type.reader-writer
:swapper symbolic-type.swapper)
diff --git a/src/level-1/realimag.lisp b/src/level-1/realimag.lisp
index b38569c..db9566a 100644
--- a/src/level-1/realimag.lisp
+++ b/src/level-1/realimag.lisp
@@ -44,7 +44,7 @@
(etypecase tensor
(real-tensor tensor)
(complex-tensor (make-instance (ecase (rank tensor) (2 'real-matrix) (1 'real-vector) (t 'real-tensor))
- :parent-tensor tensor :store (store tensor) :store-size (store-size tensor)
+ :parent-tensor tensor :store (store tensor) :store-size (length (store tensor))
:dimensions (dimensions tensor)
:strides (map 'index-store-vector #'(lambda (x) (* 2 x)) (strides tensor))
:head (the index-type (* 2 (head tensor)))))
@@ -66,7 +66,7 @@
(etypecase tensor
(real-tensor tensor)
(complex-tensor (make-instance (ecase (rank tensor) (2 'real-matrix) (1 'real-vector) (t 'real-tensor))
- :parent-tensor tensor :store (store tensor) :store-size (store-size tensor)
+ :parent-tensor tensor :store (store tensor) :store-size (length (store tensor))
:dimensions (dimensions tensor)
:strides (map 'index-store-vector #'(lambda (x) (* 2 x)) (strides tensor))
:head (the index-type (+ 1 (* 2 (head tensor))))))
diff --git a/src/level-1/tensor-maker.lisp b/src/level-1/tensor-maker.lisp
index 5961798..37c0b20 100644
--- a/src/level-1/tensor-maker.lisp
+++ b/src/level-1/tensor-maker.lisp
@@ -59,3 +59,24 @@
;;Had to move it here in the wait for copy!
(definline sub-tensor (tensor subscripts &optional (preserve-rank nil))
(copy (sub-tensor~ tensor subscripts preserve-rank)))
+
+(defmacro make-zeros-dims (func-name (tensor-class))
+ (let ((opt (get-tensor-class-optimization-hashtable tensor-class)))
+ (assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (let ((opt (get-tensor-class-optimization-hashtable ',tensor-class)))
+ (assert opt nil 'tensor-cannot-find-optimization :tensor-class ',tensor-class)
+ (setf (getf opt :zero-maker) ',func-name
+ (get-tensor-class-optimization ',tensor-class) opt))
+ (defun ,func-name (dims)
+ (declare (type index-store-vector dims))
+ (let-typed ((rnk (length dims) :type index-type)
+ (size (very-quickly (lvec-foldl #'(lambda (a b) (declare (type index-type a b)) (the index-type (* a b))) dims))))
+ (make-instance (case rnk (2 ',(getf opt :matrix)) (1 ',(getf opt :vector)) (t ',tensor-class))
+ :dimensions (copy-seq dims) :store (,(getf opt :store-allocator) size) :store-size size))))))
+
+(make-zeros-dims real-typed-zeros (real-tensor))
+(make-zeros-dims complex-typed-zeros (complex-tensor))
+
+#+maxima
+(make-zeros-dims symbolc-typed-tensor (symbolic-tensor))
diff --git a/src/level-2/gemv.lisp b/src/level-2/gemv.lisp
index 727e89b..c7ad77a 100644
--- a/src/level-2/gemv.lisp
+++ b/src/level-2/gemv.lisp
@@ -50,23 +50,25 @@
(Aval (,(getf opt :reader) sto-A of-A) :type ,(getf opt :element-type)))
(setf dot (,(getf opt :f+) dot (,(getf opt :f*) xval Aval))))
:finally (,(getf opt :value-writer) (,(getf opt :f+) (,(getf opt :f*) alpha dot) val) sto-y of-y))))))))
- (if blas-gemv-func
+ (if blas-gemv-func
`(mlet*
((call-fortran? (> (max (nrows A) (ncols A)) ,fortran-call-lb))
- ((maj-A ld-A fop-A) (if call-fortran? (blas-matrix-compatible-p A job) (values nil 0 "?")) :type (symbol index-type (string 1))))
+ ((maj-A ld-A fop-A) (blas-matrix-compatible-p A job) :type (symbol index-type (string 1))))
(cond
- ((and maj-a call-fortran?)
- (let-typed ((nr-A (nrows A) :type index-type)
- (nc-A (ncols A) :type index-type))
- (when (eq maj-A :row-major)
- (rotatef nr-A nc-A))
- (,blas-gemv-func fop-a nr-A nc-A
- alpha (store A) ld-A
- (store x) (aref (strides x) 0)
- beta
- (store y) (aref (strides y) 0)
- (head A) (head x) (head y))))
- (t
+ (call-fortran?
+ (if maj-A
+ (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)))
+ (,func alpha (,(getf opt :copy) A (,(getf opt :zero-maker) (dimensions A))) x beta y job)))
+ (t
,lisp-routine)))
lisp-routine))
y))))
diff --git a/src/level-3/gemm.lisp b/src/level-3/gemm.lisp
index 24a7519..48831ee 100644
--- a/src/level-3/gemm.lisp
+++ b/src/level-3/gemm.lisp
@@ -28,11 +28,11 @@
(in-package #:matlisp)
-(defmacro generate-typed-gemm! (func (tensor-class blas-gemm-func blas-gemv-func fortran-lb-parameter))
+(defmacro generate-typed-gemm! (func (tensor-class blas-gemm-func fortran-lb-parameter))
(let* ((opt (if-ret (get-tensor-class-optimization-hashtable tensor-class)
(error 'tensor-cannot-find-optimization :tensor-class tensor-class)))
(matrix-class (getf opt :matrix))
- (blas? (and blas-gemm-func blas-gemv-func)))
+ (blas? blas-gemm-func))
`(eval-when (:compile-toplevel :load-toplevel :execute)
(let ((opt (get-tensor-class-optimization-hashtable ',tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class ',tensor-class)
@@ -72,40 +72,66 @@
(unless (,(getf opt :f=) beta (,(getf opt :fid*)))
(,(getf opt :num-scal) beta C))
;;
- (let-typed ((of-A hd-A :type index-type)
- (of-B hd-B :type index-type)
- (of-C hd-C :type index-type)
- (r.cstp-C (* cstp-C nc-C) :type index-type)
- (d.rstp-B (- rstp-B (* cstp-B nc-C)) :type index-type)
- (d.rstp-A (- rstp-A (* cstp-A dotl)) :type index-type))
- (very-quickly
- (loop :repeat nr-C
+ (cond
+ ((and (= cstp-C 1) (= cstp-B 1) nil)
+ (let-typed ((of-A hd-A :type index-type)
+ (of-B hd-B :type index-type)
+ (of-C hd-C :type index-type)
+ (d.rstp-B (- rstp-B nc-C) :type index-type)
+ (d.rstp-A (- rstp-A (* cstp-A dotl)) :type index-type))
+ (very-quickly
+ (loop :repeat nr-C
:do (progn
(loop :repeat dotl
- :do (let-typed
- ((ele-A (,(getf opt :f*) alpha (,(getf opt :reader) sto-A of-A)) :type ,(getf opt :element-type)))
- (loop :repeat nc-C
- :do (progn
- (,(getf opt :value-writer)
- (,(getf opt :f+)
- (,(getf opt :reader) sto-C of-C)
- (,(getf opt :f*) ele-A (,(getf opt :reader) sto-B of-B)))
- sto-C of-C)
- (incf of-C cstp-C)
- (incf of-B cstp-B)))
- (decf of-C r.cstp-C)
- (incf of-A cstp-A)
- (incf of-B d.rstp-B)))
+ :do (let-typed
+ ((ele-A (,(getf opt :f*) alpha (,(getf opt :reader) sto-A of-A)) :type ,(getf opt :element-type)))
+ (loop :repeat nc-C
+ :do (progn
+ (,(getf opt :value-incfer) (,(getf opt :f*) ele-A (,(getf opt :reader) sto-B of-B))
+ sto-C of-C)
+ (incf of-C)
+ (incf of-B)))
+ (decf of-C nc-C)
+ (incf of-A cstp-A)
+ (incf of-B d.rstp-B)))
(incf of-C rstp-C)
(incf of-A d.rstp-A)
- (setf of-B hd-B))))))))
+ (setf of-B hd-B))))))
+ (t
+ (let-typed ((of-A hd-A :type index-type)
+ (of-B hd-B :type index-type)
+ (of-C hd-C :type index-type)
+ (r.cstp-C (* cstp-C nc-C) :type index-type)
+ (d.rstp-B (- rstp-B (* cstp-B nc-C)) :type index-type)
+ (d.rstp-A (- rstp-A (* cstp-A dotl)) :type index-type))
+ (very-quickly
+ (loop :repeat nr-C
+ :do (progn
+ (loop :repeat dotl
+ :do (let-typed
+ ((ele-A (,(getf opt :f*) alpha (,(getf opt :reader) sto-A of-A)) :type ,(getf opt :element-type)))
+ (loop :repeat nc-C
+ :do (progn
+ (,(getf opt :value-writer)
+ (,(getf opt :f+)
+ (,(getf opt :reader) sto-C of-C)
+ (,(getf opt :f*) ele-A (,(getf opt :reader) sto-B of-B)))
+ sto-C of-C)
+ (incf of-C cstp-C)
+ (incf of-B cstp-B)))
+ (decf of-C r.cstp-C)
+ (incf of-A cstp-A)
+ (incf of-B d.rstp-B)))
+ (incf of-C rstp-C)
+ (incf of-A d.rstp-A)
+ (setf of-B hd-B))))))))))
;;Tie together Fortran and lisp-routines.
`(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))
+ :type (symbol symbol))
,@(when blas?
`((call-fortran? (> (max (nrows C) (ncols C) (if (eq job-A :n) (ncols A) (nrows A)))
,fortran-lb-parameter))
@@ -114,79 +140,37 @@
((maj-C ld-C fop-C) (blas-matrix-compatible-p C :n) :type (symbol index-type nil)))))
,(if blas?
`(cond
- ((and call-fortran? 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))))
- ((and call-fortran? maj-A)
- (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
- (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 call-fortran? maj-B)
- (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
- (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)))))
+ (call-fortran?
+ (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)))
+ (let ((ret (,func alpha
+ (if maj-A A (,(getf opt :copy) A (,(getf opt :zero-maker) (dimensions A))))
+ (if maj-B B (,(getf opt :copy) B (,(getf opt :zero-maker) (dimensions B))))
+ beta
+ (if maj-C C (,(getf opt :copy) C (,(getf opt :zero-maker) (dimensions C))))
+ job)))
+ (unless maj-C
+ (,(getf opt :copy) ret C)))))
(t
,lisp-routine))
lisp-routine)))
C))))
;;Real
(generate-typed-gemm! real-base-typed-gemm!
- (real-tensor dgemm dgemv *real-l3-fcall-lb*))
+ (real-tensor dgemm *real-l3-fcall-lb*))
(definline real-typed-gemm! (alpha A B beta C job)
(real-base-typed-gemm! alpha A B beta C
@@ -197,7 +181,7 @@
;;Complex
(generate-typed-gemm! complex-base-typed-gemm!
- (complex-tensor zgemm zgemv *complex-l3-fcall-lb*))
+ (complex-tensor zgemm *complex-l3-fcall-lb*))
(definline complex-typed-gemm! (alpha A B beta C job)
(declare (type complex-matrix A B C)
@@ -229,7 +213,7 @@
;;Symbolic
#+maxima
(generate-typed-gemm! symbolic-base-typed-gemm!
- (symbolic-tensor nil nil 0))
+ (symbolic-tensor nil 0))
;;---------------------------------------------------------------;;
-----------------------------------------------------------------------
Summary of changes:
src/base/standard-tensor.lisp | 5 +-
src/classes/complex-tensor.lisp | 8 ++
src/classes/real-tensor.lisp | 7 ++
src/classes/symbolic-tensor.lisp | 7 ++
src/level-1/realimag.lisp | 4 +-
src/level-1/tensor-maker.lisp | 21 +++++
src/level-2/gemv.lisp | 30 ++++---
src/level-3/gemm.lisp | 174 +++++++++++++++++---------------------
8 files changed, 143 insertions(+), 113 deletions(-)
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2013-01-20 07:41:49
|
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 4862a338530bb1b435f2d6535913abe9947931b6 (commit)
from 657120d7a8bc0b0e26bbb522697e75c9f5b92ec1 (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 4862a338530bb1b435f2d6535913abe9947931b6
Author: Akshay Srinivasan <aks...@gm...>
Date: Sat Jan 19 23:36:28 2013 -0800
o Wrapped some functions inside (eval-when ..).
diff --git a/src/ffi/f77-ffi.lisp b/src/ffi/f77-ffi.lisp
index 177f431..301520e 100644
--- a/src/ffi/f77-ffi.lisp
+++ b/src/ffi/f77-ffi.lisp
@@ -10,322 +10,118 @@
(in-package #:matlisp-ffi)
-
-(definline %f77.string-p (type)
- "
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (definline %f77.string-p (type)
+ "
Checks if the given type is a string."
- (eq type :string))
+ (eq type :string))
-(definline %f77.array-p (type)
- "
+ (definline %f77.array-p (type)
+ "
Checks if the given type is an array."
- (and (listp type) (eq (car type) '*)))
+ (and (listp type) (eq (car type) '*)))
-(definline %f77.cast-as-array-p (type)
- "
+ (definline %f77.cast-as-array-p (type)
+ "
Checks if the given type is - or has to be passed as - an array."
- (or (when (listp type)
- (eq (car type) '*))
- (eq type :complex-single-float)
- (eq type :complex-double-float)))
-
-;; Check if the given type is a callback.
-(definline %f77.callback-type-p (type)
- "
+ (or (when (listp type)
+ (eq (car type) '*))
+ (eq type :complex-single-float)
+ (eq type :complex-double-float)))
+
+ ;; Check if the given type is a callback.
+ (definline %f77.callback-type-p (type)
+ "
Checks if the given type is a callback"
- (and (listp type) (eq (first type) :callback)))
-
-;; Get the equivalent CFFI type.
-;; If the type is an array, get the type of the array element type.
-(defun %f77.cffi-type (type)
- "Convert the given matlisp-ffi type into one understood by CFFI."
- (cond
- ((and (listp type) (eq (first type) '*))
- `(:pointer ,(%f77.cffi-type (second type))))
- ((%f77.callback-type-p type)
- `(:pointer ,(%f77.cffi-type :callback)))
- ((eq type :complex-single-float)
- `(:pointer ,(%f77.cffi-type :single-float)))
- ((eq type :complex-double-float)
- `(:pointer ,(%f77.cffi-type :double-float)))
- (t (ecase type
- (:void :void)
- (:integer :int32)
- (:character :char)
- (:long :int64)
- (:single-float :float)
- (:double-float :double)
- (:string :string)
- ;; Pass a pointer to the function.
- (:callback :void)
- (t (error 'unknown-token :token type
- :message "Don't know the given Fortran type."))))))
-
-(defun %f77.get-return-type (type)
- "
+ (and (listp type) (eq (first type) :callback)))
+
+ ;; Get the equivalent CFFI type.
+ ;; If the type is an array, get the type of the array element type.
+ (defun %f77.cffi-type (type)
+ "Convert the given matlisp-ffi type into one understood by CFFI."
+ (cond
+ ((and (listp type) (eq (first type) '*))
+ `(:pointer ,(%f77.cffi-type (second type))))
+ ((%f77.callback-type-p type)
+ `(:pointer ,(%f77.cffi-type :callback)))
+ ((eq type :complex-single-float)
+ `(:pointer ,(%f77.cffi-type :single-float)))
+ ((eq type :complex-double-float)
+ `(:pointer ,(%f77.cffi-type :double-float)))
+ (t (ecase type
+ (:void :void)
+ (:integer :int32)
+ (:character :char)
+ (:long :int64)
+ (:single-float :float)
+ (:double-float :double)
+ (:string :string)
+ ;; Pass a pointer to the function.
+ (:callback :void)
+ (t (error 'unknown-token :token type
+ :message "Don't know the given Fortran type."))))))
+
+ (defun %f77.get-return-type (type)
+ "
Return type understood by CFFI. Note that unlike arguments fortran
functions return-by-value."
- (if (or (%f77.cast-as-array-p type) (%f77.callback-type-p type))
- (error 'invalid-type :given type :expected '(not (or (%f77.cast-as-array-p type)
- (%f77.callback-type-p type)))
- :message "A Fortran function cannot return the given type.")
- (%f77.cffi-type type)))
-
-(definline %f77.output-p (style)
- "
+ (if (or (%f77.cast-as-array-p type) (%f77.callback-type-p type))
+ (error 'invalid-type :given type :expected '(not (or (%f77.cast-as-array-p type)
+ (%f77.callback-type-p type)))
+ :message "A Fortran function cannot return the given type.")
+ (%f77.cffi-type type)))
+
+ (definline %f77.output-p (style)
+ "
Checks if style implies output."
- (member style '(:output :input-output :workspace-output)))
+ (member style '(:output :input-output :workspace-output)))
-(definline %f77.input-p (style)
- "
+ (definline %f77.input-p (style)
+ "
Checks if style implies input."
- (member style '(:input :input-value :input-reference :workspace)))
+ (member style '(:input :input-value :input-reference :workspace)))
-(defun %f77.get-read-in-type (type &optional (style :input))
- "
+ (defun %f77.get-read-in-type (type &optional (style :input))
+ "
Get the input type to be passed to CFFI."
- (assert (member style +ffi-styles+) nil 'unknown-token :token style
- :message "Don't know how to handle style.")
- (cond
- ;; Can't do much else if type is an array/complex or input is passed-by-value.
- ((or (%f77.callback-type-p type)
- (%f77.cast-as-array-p type)
- (eq style :input-value))
- (%f77.cffi-type type))
- ;; else pass-by-reference
- (t
- `(:pointer ,(%f77.cffi-type type)))))
-
-(defun %f77.parse-fortran-parameters (body)
- "
+ (assert (member style +ffi-styles+) nil 'unknown-token :token style
+ :message "Don't know how to handle style.")
+ (cond
+ ;; Can't do much else if type is an array/complex or input is passed-by-value.
+ ((or (%f77.callback-type-p type)
+ (%f77.cast-as-array-p type)
+ (eq style :input-value))
+ (%f77.cffi-type type))
+ ;; else pass-by-reference
+ (t
+ `(:pointer ,(%f77.cffi-type type)))))
+
+ (defun %f77.parse-fortran-parameters (body)
+ "
Parse fortran parameters and convert parameters to native C90 types (and
add additional function parameters)."
- (multiple-value-bind (doc pars)
- (parse-doc-&-parameters body)
- (declare (ignore doc))
-
- (let* ((aux-pars nil)
- (new-pars
- (mapcar #'(lambda (decl)
- (destructuring-bind (name type &optional (style :input-reference)) decl
- (case type
- (:string
- ;; String lengths are appended to the function arguments,
- ;; passed by value.
- (nconsc aux-pars `((,(scat "LEN-" name) ,(%f77.cffi-type :integer))))
- `(,name ,(%f77.cffi-type :string)))
- (t
- `(,name ,(%f77.get-read-in-type type style))))))
- pars)))
- `( ;; don't want documentation for direct interface, not useful
- ;; ,@doc
- ,@new-pars ,@aux-pars))))
-
-(defmacro def-fortran-routine (name-and-options return-type &rest body)
- "
- DEF-FORTRAN-ROUTINE
-
- An external Fortran routine definition form (DEF-FORTRAN-ROUTINE
- MY-FUN ...) creates two functions:
-
- 1. a raw FFI (foreign function interface),
- 2. an easier to use lisp interface to the raw interface.
-
- The documentation given here relates in the most part to the
- simplified lisp interface.
-
- Example:
- ========
- libblas.a contains the fortran subroutine DCOPY(N,X,INCX,Y,INCY)
- which copies the vector Y of N double-float's to the vector X.
- The function name in libblas.a is \"dcopy_\" (by Fortran convention).
-
- (DEF-FORTRAN-ROUTINE DCOPY :void
- (N :integer :input)
- (X (* :double-float) :output)
- (INCX :integer :input)
- (Y (* :double-float) :input)
- (INCY :integer :input))
-
- will expand into:
-
- (CFFI:DEFCFUN (\"dcopy_\" FORTRAN-DCOPY) :VOID
- (N :POINTER :INT)
- (DX :POINTER :DOUBLE)
- (INCX :POINTER :INT)
- (DY :POINTER :DOUBLE)
- (INCY :POINTER :INT))
-
- and
-
- (DEFUN DCOPY (N,X,INCX,Y,INCY)
- ...
-
- In turn, the lisp function DCOPY calls FORTRAN-DCOPY which calls
- the Fortran function \"dcopy_\" in libblas.a.
-
- Arguments:
- ==========
-
-
- NAME Name of the lisp interface function that will be created.
- The name of the raw FFI will be derived from NAME via
- the function MAKE-FFI-NAME. The name of foreign function
- (presumable a Fortran Function in an external library)
- will be derived from NAME via MAKE-FORTRAN-NAME.
-
- RETURN-TYPE
- The type of data that will be returned by the external
- (presumably Fortran) function.
-
- (MEMBER RETURN-TYPE '(:VOID :INTEGER :SINGLE-FLOAT :DOUBLE-FLOAT
- :COMPLEX-SINGLE-FLOAT :COMPLEX-DOUBLE-FLOAT))
-
- See GET-READ-OUT-TYPE.
-
- BODY A list of parameter forms. A parameter form is:
-
- (VARIABLE TYPE &optional (STYLE :INPUT))
-
- The VARIABLE is the name of a parameter accepted by the
- external (presumably Fortran) routine. TYPE is the type of
- VARIABLE. The recognized TYPE's are:
-
- TYPE Corresponds to Fortran Declaration
- ---- ----------------------------------
- :STRING CHARACTER*(*)
- :INTEGER INTEGER
- :SINGLE-FLOAT REAL
- :DOUBLE-FLOAT DOUBLE PRECISION
- :COMPLEX-SINGLE-FLOAT COMPLEX
- :COMPLEX-DOUBLE-FLOAT COMPLEX*16
- (* X) An array of type X.
- (:CALLBACK args) A description of a function or subroutine
-
- (MEMBER X '(:INTEGER :SINGLE-FLOAT :DOUBLE-FLOAT
- :COMPLEX-SINGLE-FLOAT :COMPLEX-DOUBLE-FLOAT)
-
-
- The STYLE (default :INPUT) defines how VARIABLE is treated.
- This is by far the most difficult quantity to learn. To
- begin with:
-
-
- (OR (MEMBER STYLE '(:INPUT :OUTPUT :INPUT-OUTPUT))
- (MEMBER STYLE '(:IN :COPY :IN-OUT :OUT)))
-
- TYPE STYLE Description
- ---- ----- -----------
- X :INPUT Value will be used but not modified.
-
- :OUTPUT Input value not used (but some value must be given),
- a value is returned as one of the values lisp
- function NAME. Similar to the :IN-OUT style
- of DEF-ALIEN-ROUTINE.
- :INPUT-OUTPUT Input value may be used, a value is returned
- as one of the values from the lisp function
- NAME.
-
- ** Note: In all 3 cases above the input VARIABLE will not be destroyed
- or modified directly, a copy is taken and a pointer of that
- copy is passed to the (presumably Fortran) external routine.
-
- (OR (* X) :INPUT Array entries are used but not modified.
- :STRING) :OUTPUT Array entries need not be initialized on input,
- but will be *modified*. In addition, the array
- will be returned via the Lisp command VALUES
- from the lisp function NAME.
-
- :INPUT-OUTPUT Like :OUTPUT but initial values on entry may be used.
-
- The keyword :WORKSPACE is a nickname for :INPUT. The
- keywords :INPUT-OR-OUTPUT, :WORKSPACE-OUTPUT,
- :WORKSPACE-OR-OUTPUT are nicknames for :OUTPUT.
-
- This is complicated. Suggestions are encouraged to
- interface a *functional language* to a *pass-by-reference
- language*.
-
- CALLBACKS
-
- A callback here means a function (or subroutine) that is passed into the Fortran
- routine which calls it as needed to compute something.
-
- The syntax of :CALLBACK is similar to the DEF-FORTRAN-ROUTINE:
-
- (name (:CALLBACK return-type
- {arg-description}))
-
- The RETURN-TYPE is the same as for DEF-FORTRAN-ROUTINE. The arg description is the
- same syntax as list of parameter forms for DEF-FORTRAN-ROUTINE. However, if the type
- is a pointer type (like (* :double-float)), then a required keyword option must be
- specified:
-
- (name (* type :size size) &optional style)
-
- The size specifies the total length of the Fortran array. This array is treated as a
- one dimentionsal vector and should be accessed using the function FV-REF, which is
- analogous to AREF. The SIZE parameter can be any Lisp form and can refer to any of the
- arguments to the Fortran routine.
-
- For example, a fortran routine can have the callback
-
- (def-fortran-routine foo :void
- (m (* :integer) :input)
- (fsub (:callback :void
- (x :double-float :input)
- (z (* :double-float :size (aref m 0)) :input)
- (f (* :double-float :size (aref m 0)) :output)))))
-
- This means that the arrays Z and F in FSUB have a dimension of (AREF M 0), the first
- element of the vector M. The function FSUB can be written in Lisp as
-
- (defun fsub (x z f)
- (setf (fv-ref f 0) (* x x (fv-ref z 3))))
-
- Further Notes:
- ===============
-
- Some Fortran routines use Fortran character strings in the
- parameter list. The definition here is suitable for Solaris
- where the Fortran character string is converted to a C-style null
- terminated string, AND an extra hidden parameter that is appended
- to the parameter list to hold the length of the string.
-
- If your Fortran does this differently, you'll have to change this
- definition accordingly!
-
- Call defcfun to define the foreign function.
- Also creates a nice lisp helper function."
- (multiple-value-bind (fortran-name name) (if (listp name-and-options)
- (values (car name-and-options) (cadr name-and-options))
- (values (make-fortran-name name-and-options) name-and-options))
- (let* ((lisp-name (make-fortran-ffi-name `,name))
- (hack-return-type `,return-type)
- (hack-body `(,@body))
- (hidden-var-name nil))
- ;;
- (multiple-value-bind (doc pars)
- (parse-doc-&-parameters `(,@body))
- (when (member hack-return-type '(:complex-single-float :complex-double-float))
- ;; The return type is complex. Since this is a "structure",
- ;; Fortran inserts a "hidden" first parameter before all
- ;; others. This is used to store the resulting complex
- ;; number. Then there is no "return" value, so set the return
- ;; type to :void.
- ;;
- (setq hidden-var-name (gensym "HIDDEN-COMPLEX-RETURN-"))
- (setq hack-body `(,@doc
- (,hidden-var-name ,hack-return-type :output)
- ,@pars))
- (setq hack-return-type :void)))
-
- `(progn
- (cffi:defcfun (,fortran-name ,lisp-name) ,(%f77.get-return-type hack-return-type)
- ,@(%f77.parse-fortran-parameters hack-body))
- ,@(%f77.def-fortran-interface name hack-return-type hack-body hidden-var-name)))))
-
-;; Create a form specifying a simple Lisp function that calls the
+ (multiple-value-bind (doc pars)
+ (parse-doc-&-parameters body)
+ (declare (ignore doc))
+
+ (let* ((aux-pars nil)
+ (new-pars
+ (mapcar #'(lambda (decl)
+ (destructuring-bind (name type &optional (style :input-reference)) decl
+ (case type
+ (:string
+ ;; String lengths are appended to the function arguments,
+ ;; passed by value.
+ (nconsc aux-pars `((,(scat "LEN-" name) ,(%f77.cffi-type :integer))))
+ `(,name ,(%f77.cffi-type :string)))
+ (t
+ `(,name ,(%f77.get-read-in-type type style))))))
+ pars)))
+ `( ;; don't want documentation for direct interface, not useful
+ ;; ,@doc
+ ,@new-pars ,@aux-pars))))
+
+ ;; Create a form specifying a simple Lisp function that calls the
;; underlying Fortran routine of the same name.
(defun %f77.def-fortran-interface (name return-type body hidden-var-name)
(multiple-value-bind (doc pars)
@@ -450,6 +246,9 @@
,@(mapcar #'second return-vars)))))))))
;;TODO: Outputs are messed up inside the callback
+;;TODO: Define callbacks outside the function call and lexically bind functions inside the
+;; call. Callbacks allocate memory in some non-GC'ed part of the heap. Runs out of memory
+;; quite quickly.
(defun %f77.def-fortran-callback (func callback-name return-type parm)
(let* ((hack-return-type `,return-type)
(hack-parm `(,@parm))
@@ -542,3 +341,208 @@
,(if (eq hack-return-type :void)
nil
retvar))))))))
+)
+
+(defmacro def-fortran-routine (name-and-options return-type &rest body)
+ "
+ DEF-FORTRAN-ROUTINE
+
+ An external Fortran routine definition form (DEF-FORTRAN-ROUTINE
+ MY-FUN ...) creates two functions:
+
+ 1. a raw FFI (foreign function interface),
+ 2. an easier to use lisp interface to the raw interface.
+
+ The documentation given here relates in the most part to the
+ simplified lisp interface.
+
+ Example:
+ ========
+ libblas.a contains the fortran subroutine DCOPY(N,X,INCX,Y,INCY)
+ which copies the vector Y of N double-float's to the vector X.
+ The function name in libblas.a is \"dcopy_\" (by Fortran convention).
+
+ (DEF-FORTRAN-ROUTINE DCOPY :void
+ (N :integer :input)
+ (X (* :double-float) :output)
+ (INCX :integer :input)
+ (Y (* :double-float) :input)
+ (INCY :integer :input))
+
+ will expand into:
+
+ (CFFI:DEFCFUN (\"dcopy_\" FORTRAN-DCOPY) :VOID
+ (N :POINTER :INT)
+ (DX :POINTER :DOUBLE)
+ (INCX :POINTER :INT)
+ (DY :POINTER :DOUBLE)
+ (INCY :POINTER :INT))
+
+ and
+
+ (DEFUN DCOPY (N,X,INCX,Y,INCY)
+ ...
+
+ In turn, the lisp function DCOPY calls FORTRAN-DCOPY which calls
+ the Fortran function \"dcopy_\" in libblas.a.
+
+ Arguments:
+ ==========
+
+
+ NAME Name of the lisp interface function that will be created.
+ The name of the raw FFI will be derived from NAME via
+ the function MAKE-FFI-NAME. The name of foreign function
+ (presumable a Fortran Function in an external library)
+ will be derived from NAME via MAKE-FORTRAN-NAME.
+
+ RETURN-TYPE
+ The type of data that will be returned by the external
+ (presumably Fortran) function.
+
+ (MEMBER RETURN-TYPE '(:VOID :INTEGER :SINGLE-FLOAT :DOUBLE-FLOAT
+ :COMPLEX-SINGLE-FLOAT :COMPLEX-DOUBLE-FLOAT))
+
+ See GET-READ-OUT-TYPE.
+
+ BODY A list of parameter forms. A parameter form is:
+
+ (VARIABLE TYPE &optional (STYLE :INPUT))
+
+ The VARIABLE is the name of a parameter accepted by the
+ external (presumably Fortran) routine. TYPE is the type of
+ VARIABLE. The recognized TYPE's are:
+
+ TYPE Corresponds to Fortran Declaration
+ ---- ----------------------------------
+ :STRING CHARACTER*(*)
+ :INTEGER INTEGER
+ :SINGLE-FLOAT REAL
+ :DOUBLE-FLOAT DOUBLE PRECISION
+ :COMPLEX-SINGLE-FLOAT COMPLEX
+ :COMPLEX-DOUBLE-FLOAT COMPLEX*16
+ (* X) An array of type X.
+ (:CALLBACK args) A description of a function or subroutine
+
+ (MEMBER X '(:INTEGER :SINGLE-FLOAT :DOUBLE-FLOAT
+ :COMPLEX-SINGLE-FLOAT :COMPLEX-DOUBLE-FLOAT)
+
+
+ The STYLE (default :INPUT) defines how VARIABLE is treated.
+ This is by far the most difficult quantity to learn. To
+ begin with:
+
+
+ (OR (MEMBER STYLE '(:INPUT :OUTPUT :INPUT-OUTPUT))
+ (MEMBER STYLE '(:IN :COPY :IN-OUT :OUT)))
+
+ TYPE STYLE Description
+ ---- ----- -----------
+ X :INPUT Value will be used but not modified.
+
+ :OUTPUT Input value not used (but some value must be given),
+ a value is returned as one of the values lisp
+ function NAME. Similar to the :IN-OUT style
+ of DEF-ALIEN-ROUTINE.
+ :INPUT-OUTPUT Input value may be used, a value is returned
+ as one of the values from the lisp function
+ NAME.
+
+ ** Note: In all 3 cases above the input VARIABLE will not be destroyed
+ or modified directly, a copy is taken and a pointer of that
+ copy is passed to the (presumably Fortran) external routine.
+
+ (OR (* X) :INPUT Array entries are used but not modified.
+ :STRING) :OUTPUT Array entries need not be initialized on input,
+ but will be *modified*. In addition, the array
+ will be returned via the Lisp command VALUES
+ from the lisp function NAME.
+
+ :INPUT-OUTPUT Like :OUTPUT but initial values on entry may be used.
+
+ The keyword :WORKSPACE is a nickname for :INPUT. The
+ keywords :INPUT-OR-OUTPUT, :WORKSPACE-OUTPUT,
+ :WORKSPACE-OR-OUTPUT are nicknames for :OUTPUT.
+
+ This is complicated. Suggestions are encouraged to
+ interface a *functional language* to a *pass-by-reference
+ language*.
+
+ CALLBACKS
+
+ A callback here means a function (or subroutine) that is passed into the Fortran
+ routine which calls it as needed to compute something.
+
+ The syntax of :CALLBACK is similar to the DEF-FORTRAN-ROUTINE:
+
+ (name (:CALLBACK return-type
+ {arg-description}))
+
+ The RETURN-TYPE is the same as for DEF-FORTRAN-ROUTINE. The arg description is the
+ same syntax as list of parameter forms for DEF-FORTRAN-ROUTINE. However, if the type
+ is a pointer type (like (* :double-float)), then a required keyword option must be
+ specified:
+
+ (name (* type :size size) &optional style)
+
+ The size specifies the total length of the Fortran array. This array is treated as a
+ one dimentionsal vector and should be accessed using the function FV-REF, which is
+ analogous to AREF. The SIZE parameter can be any Lisp form and can refer to any of the
+ arguments to the Fortran routine.
+
+ For example, a fortran routine can have the callback
+
+ (def-fortran-routine foo :void
+ (m (* :integer) :input)
+ (fsub (:callback :void
+ (x :double-float :input)
+ (z (* :double-float :size (aref m 0)) :input)
+ (f (* :double-float :size (aref m 0)) :output)))))
+
+ This means that the arrays Z and F in FSUB have a dimension of (AREF M 0), the first
+ element of the vector M. The function FSUB can be written in Lisp as
+
+ (defun fsub (x z f)
+ (setf (fv-ref f 0) (* x x (fv-ref z 3))))
+
+ Further Notes:
+ ===============
+
+ Some Fortran routines use Fortran character strings in the
+ parameter list. The definition here is suitable for Solaris
+ where the Fortran character string is converted to a C-style null
+ terminated string, AND an extra hidden parameter that is appended
+ to the parameter list to hold the length of the string.
+
+ If your Fortran does this differently, you'll have to change this
+ definition accordingly!
+
+ Call defcfun to define the foreign function.
+ Also creates a nice lisp helper function."
+ (multiple-value-bind (fortran-name name) (if (listp name-and-options)
+ (values (car name-and-options) (cadr name-and-options))
+ (values (make-fortran-name name-and-options) name-and-options))
+ (let* ((lisp-name (make-fortran-ffi-name `,name))
+ (hack-return-type `,return-type)
+ (hack-body `(,@body))
+ (hidden-var-name nil))
+ ;;
+ (multiple-value-bind (doc pars)
+ (parse-doc-&-parameters `(,@body))
+ (when (member hack-return-type '(:complex-single-float :complex-double-float))
+ ;; The return type is complex. Since this is a "structure",
+ ;; Fortran inserts a "hidden" first parameter before all
+ ;; others. This is used to store the resulting complex
+ ;; number. Then there is no "return" value, so set the return
+ ;; type to :void.
+ ;;
+ (setq hidden-var-name (gensym "HIDDEN-COMPLEX-RETURN-"))
+ (setq hack-body `(,@doc
+ (,hidden-var-name ,hack-return-type :output)
+ ,@pars))
+ (setq hack-return-type :void)))
+
+ `(progn
+ (cffi:defcfun (,fortran-name ,lisp-name) ,(%f77.get-return-type hack-return-type)
+ ,@(%f77.parse-fortran-parameters hack-body))
+ ,@(%f77.def-fortran-interface name hack-return-type hack-body hidden-var-name)))))
diff --git a/src/ffi/f77-mangling.lisp.in b/src/ffi/f77-mangling.lisp.in
index df051f0..a7cf0da 100644
--- a/src/ffi/f77-mangling.lisp.in
+++ b/src/ffi/f77-mangling.lisp.in
@@ -3,42 +3,42 @@
(in-package #:matlisp-ffi)
(eval-when (:compile-toplevel :load-toplevel :execute)
-(defconstant +f77-lower-case+ @F77_LOWER_CASE@
- "Fortran names are lower case if non-NIL")
-(defconstant +f77-underscore+ @F77_UNDERSCORE@
- "Fortran names have a trailing underscore if non-NIL")
-(defconstant +f77-extra-underscore+ @F77_EXTRA_UNDERSCORE@
- "Fortran names containing an underscore have an extra underscore appended if non-NIL")
-)
+ (defconstant +f77-lower-case+ @F77_LOWER_CASE@
+ "Fortran names are lower case if non-NIL")
+ (defconstant +f77-underscore+ @F77_UNDERSCORE@
+ "Fortran names have a trailing underscore if non-NIL")
+ (defconstant +f77-extra-underscore+ @F77_EXTRA_UNDERSCORE@
+ "Fortran names containing an underscore have an extra underscore appended if non-NIL")
-(defun %cat% (prefix-string s &optional suffix-string)
- (concatenate 'string
- prefix-string
- (string s)
- suffix-string))
+ (defun %cat% (prefix-string s &optional suffix-string)
+ (concatenate 'string
+ prefix-string
+ (string s)
+ suffix-string))
-(defun scat (prefix-string s &optional suffix-string)
- (intern (%cat% prefix-string s suffix-string)))
+ (defun scat (prefix-string s &optional suffix-string)
+ (intern (%cat% prefix-string s suffix-string)))
-;; If the Fortran function name is NAME, the Lisp FFI name prepends
-;; "FORTRAN-"
-(defun make-fortran-ffi-name (name)
- (scat "FORTRAN-" name))
+ ;; If the Fortran function name is NAME, the Lisp FFI name prepends
+ ;; "FORTRAN-"
+ (defun make-fortran-ffi-name (name)
+ (scat "FORTRAN-" name))
-(defun make-fortran-name (name)
- ;; Given the Fortran routine name NAME, this returns the real
- ;; underlying name. This depends on the compiler conventions being
- ;; used. Some Fortran compilers take the Fortran name NAME and
- ;; produce "name_" as the real routine name. Others will prepend
- ;; the underscore. Yet others might convert the name to all upper
- ;; case.
- (let* ((internal-underscore-p (position #\_ (symbol-name name)))
- (name (concatenate 'string
- (symbol-name name)
- (if +f77-underscore+ "_" "")
- (if (and +f77-extra-underscore+ internal-underscore-p)
- "_" ""))))
- (declare (ignorable internal-underscore-p))
- (if +f77-lower-case+
- (string-downcase name)
- name)))
+ (defun make-fortran-name (name)
+ ;; Given the Fortran routine name NAME, this returns the real
+ ;; underlying name. This depends on the compiler conventions being
+ ;; used. Some Fortran compilers take the Fortran name NAME and
+ ;; produce "name_" as the real routine name. Others will prepend
+ ;; the underscore. Yet others might convert the name to all upper
+ ;; case.
+ (let* ((internal-underscore-p (position #\_ (symbol-name name)))
+ (name (concatenate 'string
+ (symbol-name name)
+ (if +f77-underscore+ "_" "")
+ (if (and +f77-extra-underscore+ internal-underscore-p)
+ "_" ""))))
+ (declare (ignorable internal-underscore-p))
+ (if +f77-lower-case+
+ (string-downcase name)
+ name)))
+)
diff --git a/src/ffi/ffi-cffi.lisp b/src/ffi/ffi-cffi.lisp
index 8429984..5698605 100644
--- a/src/ffi/ffi-cffi.lisp
+++ b/src/ffi/ffi-cffi.lisp
@@ -10,30 +10,31 @@
(in-package #:matlisp-ffi)
-(define-constant +ffi-styles+
- '(:input :input-reference :input-value
- :input-output :output :workspace-output
- :workspace))
-
-(define-constant +ffi-types+
- '(:single-float :double-float
- :complex-single-float :complex-double-float
- :integer :long
- :string :character
- :callback))
-
-(define-constant +ffi-array-types+
- '(:single-float :double-float
- :integer :long))
-
-;; Separte the body of code into documentation and parameter lists.
-(defun parse-doc-&-parameters (body &optional header footer)
- (if (stringp (first body))
- (values `(,(%cat% header (first body) footer)) (rest body))
- (values (if (or header footer)
- (%cat% header "" footer)
- nil)
- body)))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (define-constant +ffi-styles+
+ '(:input :input-reference :input-value
+ :input-output :output :workspace-output
+ :workspace))
+
+ (define-constant +ffi-types+
+ '(:single-float :double-float
+ :complex-single-float :complex-double-float
+ :integer :long
+ :string :character
+ :callback))
+
+ (define-constant +ffi-array-types+
+ '(:single-float :double-float
+ :integer :long))
+
+ ;; Separte the body of code into documentation and parameter lists.
+ (defun parse-doc-&-parameters (body &optional header footer)
+ (if (stringp (first body))
+ (values `(,(%cat% header (first body) footer)) (rest body))
+ (values (if (or header footer)
+ (%cat% header "" footer)
+ nil)
+ body))))
;; Create objects on the heap and run some stuff.
(defmacro with-foreign-objects-heaped (declarations &rest body)
@@ -122,8 +123,8 @@
,@body))))
;; Increment the pointer.
-(defun inc-sap (sap type &optional (n 1))
-"
+(definline inc-sap (sap type &optional (n 1))
+ "
Increment the pointer address by one \"slot\"
depending on the type:
:double-float 8 bytes
@@ -131,12 +132,12 @@
:complex-double-float 8x2 bytes
:complex-single-float 4x2 bytes
"
- (cffi:inc-pointer sap
- (ecase type
- (:double-float (* n 8))
- (:single-float (* n 4))
- (:complex-double-float (* n 16))
- (:complex-single-float (* n 8)))))
+ (cffi:inc-pointer sap
+ (ecase type
+ (:double-float (* n 8))
+ (:single-float (* n 4))
+ (:complex-double-float (* n 16))
+ (:complex-single-float (* n 8)))))
(define-modify-macro incf-sap (type &optional (n 1)) inc-sap)
diff --git a/src/utilities/functions.lisp b/src/utilities/functions.lisp
index c0570e8..079c6ba 100644
--- a/src/utilities/functions.lisp
+++ b/src/utilities/functions.lisp
@@ -1,8 +1,11 @@
(in-package #:matlisp-utilities)
-(declaim (inline slot-values))
-(defun slot-values (obj slots)
- "
+;;These functions are used all over the place inside Matlisp's macros.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+ (declaim (inline slot-values))
+ (defun slot-values (obj slots)
+ "
Returns the slots of the @arg{obj} corresponding to symbols in the list @arg{slots}.
Example:
@@ -15,13 +18,13 @@
=> 1 2
@end lisp
"
- (values-list
- (loop :for slt :in slots
- :collect (slot-value obj slt))))
+ (values-list
+ (loop :for slt :in slots
+ :collect (slot-value obj slt))))
-(declaim (inline linear-array-type))
-(defun linear-array-type (type-sym &optional (size '*))
- "
+ (declaim (inline linear-array-type))
+ (defun linear-array-type (type-sym &optional (size '*))
+ "
Creates the list representing simple-array with type @arg{type-sym}.
Example:
@@ -30,11 +33,11 @@
=> (simple-array double-float (10))
@end lisp
"
- `(simple-array ,type-sym (,size)))
+ `(simple-array ,type-sym (,size)))
-(declaim (inline ensure-list))
-(defun ensure-list (lst)
- "
+ (declaim (inline ensure-list))
+ (defun ensure-list (lst)
+ "
Ensconses @arg{lst} inside a list if it is an atom.
Example:
@@ -43,10 +46,10 @@
=> (a)
@end lisp
"
- (if (listp lst) lst `(,lst)))
+ (if (listp lst) lst `(,lst)))
-(defun cut-cons-chain! (lst test)
- "
+ (defun cut-cons-chain! (lst test)
+ "
Destructively cuts @arg{lst} into two parts, at the element where the function
@arg{test} returns a non-nil value.
@@ -57,20 +60,20 @@
=> (3 5) (3 5) (2 1 7 9)
@end lisp
"
- (declare (type list lst))
- (labels ((cut-cons-chain-tin (lst test parent-lst)
- (cond
- ((null lst) nil)
- ((funcall test (cadr lst))
- (let ((keys (cdr lst)))
- (setf (cdr lst) nil)
- (values parent-lst keys)))
- (t (cut-cons-chain-tin (cdr lst) test parent-lst)))))
- (cut-cons-chain-tin lst test lst)))
-
-(declaim (inline zip))
-(defun zip (&rest args)
- "
+ (declare (type list lst))
+ (labels ((cut-cons-chain-tin (lst test parent-lst)
+ (cond
+ ((null lst) nil)
+ ((funcall test (cadr lst))
+ (let ((keys (cdr lst)))
+ (setf (cdr lst) nil)
+ (values parent-lst keys)))
+ (t (cut-cons-chain-tin (cdr lst) test parent-lst)))))
+ (cut-cons-chain-tin lst test lst)))
+
+ (declaim (inline zip))
+ (defun zip (&rest args)
+ "
Zips the elements of @arg{args}.
Example:
@@ -79,10 +82,10 @@
=> ((2 A J) (3 B H) (4 C C))
@end lisp
"
- (apply #'map 'list #'list args))
+ (apply #'map 'list #'list args))
-(defun recursive-append (&rest lsts)
- "
+ (defun recursive-append (&rest lsts)
+ "
Appends lists in a nested manner, mostly used to bring in the charm of
non-lispy languages into macros.
@@ -129,15 +132,15 @@
X)
@end lisp
"
- (labels ((bin-append (x y)
- (if (null x)
- (if (typep (car y) 'symbol) y (car y))
- (append x (if (null y) nil
- (if (typep (car y) 'symbol) `(,y) y))))))
- (reduce #'bin-append lsts :from-end t)))
-
-(defun unquote-args (lst args)
- "
+ (labels ((bin-append (x y)
+ (if (null x)
+ (if (typep (car y) 'symbol) y (car y))
+ (append x (if (null y) nil
+ (if (typep (car y) 'symbol) `(,y) y))))))
+ (reduce #'bin-append lsts :from-end t)))
+
+ (defun unquote-args (lst args)
+ "
Makes a list suitable for use inside macros (sort-of), by building a
new list quoting every symbol in @arg{lst} other than those in @arg{args}.
CAUTION: DO NOT use backquotes!
@@ -151,34 +154,34 @@
=> (LIST 'LET (LIST (LIST X '1)) (LIST '+ X '1))
@end lisp
"
- (labels ((replace-atoms (lst ret)
- (cond
- ((null lst) (reverse ret))
- ((atom lst)
- (let ((ret (reverse ret)))
- (rplacd (last ret) lst)
- ret))
- ((consp lst)
- (replace-atoms (cdr lst) (let ((fst (car lst)))
- (cond
- ((atom fst)
- (if (member fst args)
- (cons fst ret)
- (append `(',fst) ret)))
- ((consp fst)
- (cons (replace-lst fst nil) ret))))))))
- (replace-lst (lst acc)
- (cond
- ((null lst) acc)
- ((consp lst)
- (if (eq (car lst) 'quote)
- lst
- (cons 'list (replace-atoms lst nil))))
- ((atom lst) lst))))
- (replace-lst lst nil)))
-
-(defun flatten (x)
- "
+ (labels ((replace-atoms (lst ret)
+ (cond
+ ((null lst) (reverse ret))
+ ((atom lst)
+ (let ((ret (reverse ret)))
+ (rplacd (last ret) lst)
+ ret))
+ ((consp lst)
+ (replace-atoms (cdr lst) (let ((fst (car lst)))
+ (cond
+ ((atom fst)
+ (if (member fst args)
+ (cons fst ret)
+ (append `(',fst) ret)))
+ ((consp fst)
+ (cons (replace-lst fst nil) ret))))))))
+ (replace-lst (lst acc)
+ (cond
+ ((null lst) acc)
+ ((consp lst)
+ (if (eq (car lst) 'quote)
+ lst
+ (cons 'list (replace-atoms lst nil))))
+ ((atom lst) lst))))
+ (replace-lst lst nil)))
+
+ (defun flatten (x)
+ "
Returns a new list by collecting all the symbols found in @arg{x}.
Borrowed from Onlisp.
@@ -188,16 +191,16 @@
=> (LET X 1 + X 2)
@end lisp
"
- (labels ((rec (x acc)
- (cond ((null x) acc)
- ((atom x) (cons x acc))
- (t (rec
- (car x)
- (rec (cdr x) acc))))))
- (rec x nil)))
-
-(defun list-dimensions (lst)
- "
+ (labels ((rec (x acc)
+ (cond ((null x) acc)
+ ((atom x) (cons x acc))
+ (t (rec
+ (car x)
+ (rec (cdr x) acc))))))
+ (rec x nil)))
+
+ (defun list-dimensions (lst)
+ "
Returns the dimensions of the nested list @arg{lst}, by finding the length
of the immediate list, recursively. This does not ensure the uniformity of
lengths of the lists.
@@ -208,19 +211,21 @@
=> (2 3)
@end lisp
"
- (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)))
-
-(defun compile-and-eval (source)
- "
+ (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)))
+
+ (defun compile-and-eval (source)
+ "
Compiles and evaluates the given @arg{source}. This should be
an ANSI compatible way of ensuring method compilation."
- (funcall (compile nil `(lambda () ,source))))
+ (funcall (compile nil `(lambda () ,source))))
+
+ )
diff --git a/src/utilities/lvec.lisp b/src/utilities/lvec.lisp
index 2891b36..3ab1918 100644
--- a/src/utilities/lvec.lisp
+++ b/src/utilities/lvec.lisp
@@ -1,79 +1,81 @@
(in-package #:matlisp-utilities)
-(definline lvec-foldl (func vec)
- (declare (type vector))
- (loop
- :for i :of-type fixnum :from 0 :below (length vec)
- :for ret = (aref vec 0) :then (funcall func (aref vec i) ret)
- :finally (return ret)))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (definline lvec-foldl (func vec)
+ (declare (type vector))
+ (loop
+ :for i :of-type fixnum :from 0 :below (length vec)
+ :for ret = (aref vec 0) :then (funcall func (aref vec i) ret)
+ :finally (return ret)))
-(definline lvec-foldr (func vec)
- (declare (type vector))
- (loop
- :for i :of-type fixnum :downfrom (1- (length vec)) :to 0
- :for ret = (aref vec (1- (length vec))) :then (funcall func (aref vec i) ret)
- :finally (return ret)))
+ (definline lvec-foldr (func vec)
+ (declare (type vector))
+ (loop
+ :for i :of-type fixnum :downfrom (1- (length vec)) :to 0
+ :for ret = (aref vec (1- (length vec))) :then (funcall func (aref vec i) ret)
+ :finally (return ret)))
-(definline lvec-map-foldl! (func vec)
- (declare (type vector))
- (loop
- :for i :of-type fixnum :from 0 :below (length vec)
- :for ret = (aref vec 0) :then (funcall func (aref vec i) ret)
- :do (setf (aref vec i) ret)
- :finally (return (values ret vec))))
+ (definline lvec-map-foldl! (func vec)
+ (declare (type vector))
+ (loop
+ :for i :of-type fixnum :from 0 :below (length vec)
+ :for ret = (aref vec 0) :then (funcall func (aref vec i) ret)
+ :do (setf (aref vec i) ret)
+ :finally (return (values ret vec))))
-(definline lvec-map-foldr! (func vec)
- (declare (type vector))
- (loop
- :for i :of-type fixnum :downfrom (1- (length vec)) :to 0
- :for ret = (aref vec (1- (length vec))) :then (funcall func (aref vec i) ret)
- :do (setf (aref vec i) ret)
- :finally (return (values ret vec))))
+ (definline lvec-map-foldr! (func vec)
+ (declare (type vector))
+ (loop
+ :for i :of-type fixnum :downfrom (1- (length vec)) :to 0
+ :for ret = (aref vec (1- (length vec))) :then (funcall func (aref vec i) ret)
+ :do (setf (aref vec i) ret)
+ :finally (return (values ret vec))))
-(definline lvec-max (vec)
- (declare (type vector vec))
- (loop :for ele :across vec
- :for idx :of-type fixnum = 0 :then (+ idx 1)
- :with max :of-type fixnum = (aref vec 0)
- :with max-idx :of-type fixnum = 0
- :do (when (> ele max)
- (setf max ele
- max-idx idx))
- :finally (return (values max max-idx))))
+ (definline lvec-max (vec)
+ (declare (type vector vec))
+ (loop :for ele :across vec
+ :for idx :of-type fixnum = 0 :then (+ idx 1)
+ :with max :of-type fixnum = (aref vec 0)
+ :with max-idx :of-type fixnum = 0
+ :do (when (> ele max)
+ (setf max ele
+ max-idx idx))
+ :finally (return (values max max-idx))))
-(definline lvec-min (vec)
- (declare (type vector vec))
- (loop :for ele :across vec
- :for idx :of-type fixnum = 0 :then (+ idx 1)
- :with min :of-type fixnum = (aref vec 0)
- :with min-idx :of-type fixnum = 0
- :do (when (< ele min)
- (setf min ele
- min-idx idx))
- :finally (return (values min min-idx))))
+ (definline lvec-min (vec)
+ (declare (type vector vec))
+ (loop :for ele :across vec
+ :for idx :of-type fixnum = 0 :then (+ idx 1)
+ :with min :of-type fixnum = (aref vec 0)
+ :with min-idx :of-type fixnum = 0
+ :do (when (< ele min)
+ (setf min ele
+ min-idx idx))
+ :finally (return (values min min-idx))))
-(definline lvec-eq (va vb &optional (test #'eq))
- (declare (type vector va vb))
- (let ((la (length va))
- (lb (length vb)))
- (if (/= la lb) nil
- (loop
- :for ele-a :across va
- :for ele-b :across vb
- :unless (funcall test ele-a ele-b)
- :do (return nil)
- :finally (return t)))))
+ (definline lvec-eq (va vb &optional (test #'eq))
+ (declare (type vector va vb))
+ (let ((la (length va))
+ (lb (length vb)))
+ (if (/= la lb) nil
+ (loop
+ :for ele-a :across va
+ :for ele-b :across vb
+ :unless (funcall test ele-a ele-b)
+ :do (return nil)
+ :finally (return t)))))
-(definline lvec->list (va)
- (declare (type vector va))
- (loop :for ele :across va
- :collect ele))
+ (definline lvec->list (va)
+ (declare (type vector va))
+ (loop :for ele :across va
+ :collect ele))
-(definline lvec->list! (va la)
- (declare (type vector va)
- (type list la))
- (loop
- :for ele :across va
- :for lst = la :then (cdr lst)
- :do (setf (car lst) ele))
- la)
+ (definline lvec->list! (va la)
+ (declare (type vector va)
+ (type list la))
+ (loop
+ :for ele :across va
+ :for lst = la :then (cdr lst)
+ :do (setf (car lst) ele))
+ la)
+)
diff --git a/src/utilities/string.lisp b/src/utilities/string.lisp
index c15fd01..1833467 100644
--- a/src/utilities/string.lisp
+++ b/src/utilities/string.lisp
@@ -1,8 +1,10 @@
(in-package #:matlisp-utilities)
-(declaim (inline string+))
-(defun string+ (&rest strings)
- (apply #'concatenate (cons 'string strings)))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (declaim (inline string+))
+ (defun string+ (&rest strings)
+ (apply #'concatenate (cons 'string strings)))
-(defun format-to-string (fmt &rest args)
- (apply #'format (append (list nil fmt) args)))
+ (defun format-to-string (fmt &rest args)
+ (apply #'format (append (list nil fmt) args)))
+)
-----------------------------------------------------------------------
Summary of changes:
src/ffi/f77-ffi.lisp | 606 +++++++++++++++++++++---------------------
src/ffi/f77-mangling.lisp.in | 70 +++---
src/ffi/ffi-cffi.lisp | 65 +++---
src/utilities/functions.lisp | 191 +++++++-------
src/utilities/lvec.lisp | 140 +++++-----
src/utilities/string.lisp | 12 +-
6 files changed, 549 insertions(+), 535 deletions(-)
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2013-01-20 06:49:48
|
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "matlisp".
The branch, tensor has been updated
via 657120d7a8bc0b0e26bbb522697e75c9f5b92ec1 (commit)
from c8fdfac6f7cd8e4dd91f49bf7794a579cb8a5ffc (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 657120d7a8bc0b0e26bbb522697e75c9f5b92ec1
Author: Akshay Srinivasan <aks...@gm...>
Date: Sat Jan 19 22:44:18 2013 -0800
o Enclosed function generated functions inside eval-when.
diff --git a/src/base/standard-tensor.lisp b/src/base/standard-tensor.lisp
index 68301b2..101c7cb 100644
--- a/src/base/standard-tensor.lisp
+++ b/src/base/standard-tensor.lisp
@@ -355,7 +355,7 @@
;;Error checking
(assert (and f+ f- finv+ fid+ f* f/ finv* fid* f= store-allocator coercer coercer-unforgiving matrix vector reader value-writer reader-writer swapper))
;;
- `(progn
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
;;Class definitions
(defclass ,tensor-class (standard-tensor)
((store :type ,store-type))
diff --git a/src/level-1/axpy.lisp b/src/level-1/axpy.lisp
index b59480a..d161d97 100644
--- a/src/level-1/axpy.lisp
+++ b/src/level-1/axpy.lisp
@@ -34,41 +34,44 @@
;;Use only after checking the arguments for compatibility.
(let* ((opt (get-tensor-class-optimization-hashtable tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
- (setf (getf opt :axpy) func
- (get-tensor-class-optimization tensor-class) opt)
- `(defun ,func (alpha from to)
- (declare (type ,tensor-class from to)
- (type ,(getf opt :element-type) alpha))
- ,(let
- ((lisp-routine
- `(let ((f-sto (store from))
- (t-sto (store to)))
- (declare (type ,(linear-array-type (getf opt :store-type)) f-sto t-sto))
- (very-quickly
- (mod-dotimes (idx (dimensions from))
- with (linear-sums
- (f-of (strides from) (head from))
- (t-of (strides to) (head to)))
- do (let ((f-val (,(getf opt :reader) f-sto f-of))
- (t-val (,(getf opt :reader) t-sto t-of)))
- (declare (type ,(getf opt :element-type) f-val t-val))
- (let ((t-new (,(getf opt :f+) (,(getf opt :f*) f-val alpha) t-val)))
- (declare (type ,(getf opt :element-type) t-new))
- (,(getf opt :value-writer) t-new t-sto t-of))))))))
- (if blas-func
- `(let* ((call-fortran? (> (number-of-elements to)
- ,fortran-lb))
- (strd-p (when call-fortran? (blas-copyable-p from to))))
- (cond
- ((and call-fortran? strd-p)
- (,blas-func (number-of-elements from) alpha
- (store from) (first strd-p)
- (store to) (second strd-p)
- (head from) (head to)))
- (t
- ,lisp-routine)))
- lisp-routine))
- to)))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (let ((opt (get-tensor-class-optimization-hashtable ',tensor-class)))
+ (assert opt nil 'tensor-cannot-find-optimization :tensor-class ',tensor-class)
+ (setf (getf opt :axpy) ',func
+ (get-tensor-class-optimization ',tensor-class) opt))
+ (defun ,func (alpha from to)
+ (declare (type ,tensor-class from to)
+ (type ,(getf opt :element-type) alpha))
+ ,(let
+ ((lisp-routine
+ `(let ((f-sto (store from))
+ (t-sto (store to)))
+ (declare (type ,(linear-array-type (getf opt :store-type)) f-sto t-sto))
+ (very-quickly
+ (mod-dotimes (idx (dimensions from))
+ with (linear-sums
+ (f-of (strides from) (head from))
+ (t-of (strides to) (head to)))
+ do (let ((f-val (,(getf opt :reader) f-sto f-of))
+ (t-val (,(getf opt :reader) t-sto t-of)))
+ (declare (type ,(getf opt :element-type) f-val t-val))
+ (let ((t-new (,(getf opt :f+) (,(getf opt :f*) f-val alpha) t-val)))
+ (declare (type ,(getf opt :element-type) t-new))
+ (,(getf opt :value-writer) t-new t-sto t-of))))))))
+ (if blas-func
+ `(let* ((call-fortran? (> (number-of-elements to)
+ ,fortran-lb))
+ (strd-p (when call-fortran? (blas-copyable-p from to))))
+ (cond
+ ((and call-fortran? strd-p)
+ (,blas-func (number-of-elements from) alpha
+ (store from) (first strd-p)
+ (store to) (second strd-p)
+ (head from) (head to)))
+ (t
+ ,lisp-routine)))
+ lisp-routine))
+ to))))
(defmacro generate-typed-num-axpy! (func (tensor-class blas-func fortran-lb))
;;Be very careful when using functions generated by this macro.
@@ -77,62 +80,65 @@
;;Use only after checking the arguments for compatibility.
(let* ((opt (get-tensor-class-optimization tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
- (setf (getf opt :num-axpy) func
- (get-tensor-class-optimization tensor-class) opt)
- `(defun ,func (num-from to)
- (declare (type ,tensor-class to)
- (type ,(getf opt :element-type) num-from))
- ,(let
- ((lisp-routine
- `(let-typed
- ((t-sto (store to) :type ,(linear-array-type (getf opt :store-type))))
- (very-quickly
- (mod-dotimes (idx (dimensions to))
- with (linear-sums
- (t-of (strides to) (head to)))
- do (let-typed
- ((val (,(getf opt :reader) t-sto t-of) :type ,(getf opt :element-type)))
- (,(getf opt :value-writer) (,(getf opt :f+) num-from val) t-sto t-of)))))))
- (if blas-func
- `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
- (min-strd (when call-fortran? (consecutive-store-p to))))
- (cond
- ((and call-fortran? min-strd)
- (let ((num-array (,(getf opt :store-allocator) 1)))
- (declare (type ,(linear-array-type (getf opt :store-type)) num-array))
- (let-typed ((id (,(getf opt :fid+)) :type ,(getf opt :element-type)))
- (,(getf opt :value-writer) id num-array 0))
- (,blas-func (number-of-elements to) num-from
- num-array 0
- (store to) min-strd
- 0 (head to))))
- (t
- ,lisp-routine)))
- lisp-routine))
- to)))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (let ((opt (get-tensor-class-optimization-hashtable ',tensor-class)))
+ (assert opt nil 'tensor-cannot-find-optimization :tensor-class ',tensor-class)
+ (setf (getf opt :num-axpy) ',func
+ (get-tensor-class-optimization ',tensor-class) opt))
+ (defun ,func (num-from to)
+ (declare (type ,tensor-class to)
+ (type ,(getf opt :element-type) num-from))
+ ,(let
+ ((lisp-routine
+ `(let-typed
+ ((t-sto (store to) :type ,(linear-array-type (getf opt :store-type))))
+ (very-quickly
+ (mod-dotimes (idx (dimensions to))
+ with (linear-sums
+ (t-of (strides to) (head to)))
+ do (let-typed
+ ((val (,(getf opt :reader) t-sto t-of) :type ,(getf opt :element-type)))
+ (,(getf opt :value-writer) (,(getf opt :f+) num-from val) t-sto t-of)))))))
+ (if blas-func
+ `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
+ (min-strd (when call-fortran? (consecutive-store-p to))))
+ (cond
+ ((and call-fortran? min-strd)
+ (let ((num-array (,(getf opt :store-allocator) 1)))
+ (declare (type ,(linear-array-type (getf opt :store-type)) num-array))
+ (let-typed ((id (,(getf opt :fid+)) :type ,(getf opt :element-type)))
+ (,(getf opt :value-writer) id num-array 0))
+ (,blas-func (number-of-elements to) num-from
+ num-array 0
+ (store to) min-strd
+ 0 (head to))))
+ (t
+ ,lisp-routine)))
+ lisp-routine))
+ to))))
;;Real
(generate-typed-axpy! real-typed-axpy!
- (real-tensor daxpy *real-l1-fcall-lb*))
+ (real-tensor daxpy *real-l1-fcall-lb*))
(generate-typed-num-axpy! real-typed-num-axpy!
- (real-tensor daxpy *real-l1-fcall-lb*))
+ (real-tensor daxpy *real-l1-fcall-lb*))
;;Complex
(generate-typed-axpy! complex-typed-axpy!
- (complex-tensor zaxpy *complex-l1-fcall-lb*))
+ (complex-tensor zaxpy *complex-l1-fcall-lb*))
(generate-typed-num-axpy! complex-typed-num-axpy!
- (complex-tensor zaxpy *complex-l1-fcall-lb*))
+ (complex-tensor zaxpy *complex-l1-fcall-lb*))
;;Symbolic
#+maxima
(progn
(generate-typed-axpy! symbolic-typed-axpy!
- (symbolic-tensor nil 0))
+ (symbolic-tensor nil 0))
(generate-typed-num-axpy! symbolic-typed-num-axpy!
- (symbolic-tensor nil 0)))
+ (symbolic-tensor nil 0)))
;;---------------------------------------------------------------;;
@@ -155,8 +161,8 @@
is stored in Y and Y is returned.
")
(:method :before ((alpha number) (x standard-tensor) (y standard-tensor))
- (assert (lvec-eq (dimensions x) (dimensions y) #'=) nil
- 'tensor-dimension-mismatch))
+ (assert (lvec-eq (dimensions x) (dimensions y) #'=) nil
+ 'tensor-dimension-mismatch))
(:method ((alpha number) (x complex-tensor) (y real-tensor))
(error 'coercion-error :from 'complex-tensor :to 'real-tensor)))
@@ -209,8 +215,8 @@
X,Y must have the same dimensions.
")
(:method :before ((alpha number) (x standard-tensor) (y standard-tensor))
- (unless (lvec-eq (dimensions x) (dimensions y) #'=)
- (error 'tensor-dimension-mismatch))))
+ (unless (lvec-eq (dimensions x) (dimensions y) #'=)
+ (error 'tensor-dimension-mismatch))))
(defmethod axpy ((alpha number) (x real-tensor) (y real-tensor))
(let ((ret (if (complexp alpha)
diff --git a/src/level-1/copy.lisp b/src/level-1/copy.lisp
index bdb16fb..6680e8a 100644
--- a/src/level-1/copy.lisp
+++ b/src/level-1/copy.lisp
@@ -34,37 +34,40 @@
;;Use only after checking the arguments for compatibility.
(let* ((opt (get-tensor-class-optimization-hashtable tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
- (setf (getf opt :copy) func
- (get-tensor-class-optimization tensor-class) opt)
- `(defun ,func (from to)
- (declare (type ,tensor-class from to))
- ,(let
- ((lisp-routine
- `(let ((f-sto (store from))
- (t-sto (store to)))
- (declare (type ,(linear-array-type (getf opt :store-type)) f-sto t-sto))
- (very-quickly
- ;;Can possibly make this faster (x2) by using ,blas-func in one of
- ;;the inner loops, but this is to me messy and as of now unnecessary.
- ;;SBCL can already achieve Fortran-ish speed inside this loop.
- (mod-dotimes (idx (dimensions from))
- with (linear-sums
- (f-of (strides from) (head from))
- (t-of (strides to) (head to)))
- do (,(getf opt :reader-writer) f-sto f-of t-sto t-of))))))
- (if blas-func
- `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
- (strd-p (when call-fortran? (blas-copyable-p from to))))
- (cond
- ((and strd-p call-fortran?)
- (,blas-func (number-of-elements from)
- (store from) (first strd-p)
- (store to) (second strd-p)
- (head from) (head to)))
- (t
- ,lisp-routine)))
- lisp-routine))
- to)))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (let ((opt (get-tensor-class-optimization-hashtable ',tensor-class)))
+ (assert opt nil 'tensor-cannot-find-optimization :tensor-class ',tensor-class)
+ (setf (getf opt :copy) ',func
+ (get-tensor-class-optimization ',tensor-class) opt))
+ (defun ,func (from to)
+ (declare (type ,tensor-class from to))
+ ,(let
+ ((lisp-routine
+ `(let ((f-sto (store from))
+ (t-sto (store to)))
+ (declare (type ,(linear-array-type (getf opt :store-type)) f-sto t-sto))
+ (very-quickly
+ ;;Can possibly make this faster (x2) by using ,blas-func in one of
+ ;;the inner loops, but this is to me messy and as of now unnecessary.
+ ;;SBCL can already achieve Fortran-ish speed inside this loop.
+ (mod-dotimes (idx (dimensions from))
+ with (linear-sums
+ (f-of (strides from) (head from))
+ (t-of (strides to) (head to)))
+ do (,(getf opt :reader-writer) f-sto f-of t-sto t-of))))))
+ (if blas-func
+ `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
+ (strd-p (when call-fortran? (blas-copyable-p from to))))
+ (cond
+ ((and strd-p call-fortran?)
+ (,blas-func (number-of-elements from)
+ (store from) (first strd-p)
+ (store to) (second strd-p)
+ (head from) (head to)))
+ (t
+ ,lisp-routine)))
+ lisp-routine))
+ to))))
(defmacro generate-typed-num-copy! (func (tensor-class blas-func fortran-lb))
;;Be very careful when using functions generated by this macro.
@@ -73,59 +76,62 @@
;;Use only after checking the arguments for compatibility.
(let* ((opt (get-tensor-class-optimization-hashtable tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
- (setf (getf opt :num-copy) func
- (get-tensor-class-optimization tensor-class) opt)
- `(defun ,func (num-from to)
- (declare (type ,tensor-class to)
- (type ,(getf opt :element-type) num-from))
- ,(let
- ((lisp-routine
- `(let-typed
- ((t-sto (store to) :type ,(linear-array-type (getf opt :store-type))))
- (very-quickly
- (mod-dotimes (idx (dimensions to))
- with (linear-sums
- (t-of (strides to) (head to)))
- do (,(getf opt :value-writer) num-from t-sto t-of))))))
- (if blas-func
- `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
- (min-stride (when call-fortran? (consecutive-store-p to))))
- (cond
- ((and call-fortran? min-stride)
- (let ((num-array (,(getf opt :store-allocator) 1)))
- (declare (type ,(linear-array-type (getf opt :store-type)) num-array))
- (,(getf opt :value-writer) num-from num-array 0)
- (,blas-func (number-of-elements to)
- num-array 0
- (store to) min-stride
- 0 (head to))))
- (t
- ,lisp-routine)))
- lisp-routine))
- to)))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (let ((opt (get-tensor-class-optimization-hashtable ',tensor-class)))
+ (assert opt nil 'tensor-cannot-find-optimization :tensor-class ',tensor-class)
+ (setf (getf opt :num-copy) ',func
+ (get-tensor-class-optimization ',tensor-class) opt))
+ (defun ,func (num-from to)
+ (declare (type ,tensor-class to)
+ (type ,(getf opt :element-type) num-from))
+ ,(let
+ ((lisp-routine
+ `(let-typed
+ ((t-sto (store to) :type ,(linear-array-type (getf opt :store-type))))
+ (very-quickly
+ (mod-dotimes (idx (dimensions to))
+ with (linear-sums
+ (t-of (strides to) (head to)))
+ do (,(getf opt :value-writer) num-from t-sto t-of))))))
+ (if blas-func
+ `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
+ (min-stride (when call-fortran? (consecutive-store-p to))))
+ (cond
+ ((and call-fortran? min-stride)
+ (let ((num-array (,(getf opt :store-allocator) 1)))
+ (declare (type ,(linear-array-type (getf opt :store-type)) num-array))
+ (,(getf opt :value-writer) num-from num-array 0)
+ (,blas-func (number-of-elements to)
+ num-array 0
+ (store to) min-stride
+ 0 (head to))))
+ (t
+ ,lisp-routine)))
+ lisp-routine))
+ to))))
;;Real
(generate-typed-copy! real-typed-copy!
- (real-tensor dcopy *real-l1-fcall-lb*))
+ (real-tensor dcopy *real-l1-fcall-lb*))
(generate-typed-num-copy! real-typed-num-copy!
- (real-tensor dcopy *real-l1-fcall-lb*))
+ (real-tensor dcopy *real-l1-fcall-lb*))
;;Complex
(generate-typed-copy! complex-typed-copy!
- (complex-tensor zcopy *complex-l1-fcall-lb*))
+ (complex-tensor zcopy *complex-l1-fcall-lb*))
(generate-typed-num-copy! complex-typed-num-copy!
- (complex-tensor zcopy *complex-l1-fcall-lb*))
+ (complex-tensor zcopy *complex-l1-fcall-lb*))
;;Symbolic
#+maxima
(progn
-(generate-typed-copy! symbolic-typed-copy!
- (symbolic-tensor nil 0))
+ (generate-typed-copy! symbolic-typed-copy!
+ (symbolic-tensor nil 0))
-(generate-typed-num-copy! symbolic-typed-num-copy!
- (symbolic-tensor nil 0)))
+ (generate-typed-num-copy! symbolic-typed-num-copy!
+ (symbolic-tensor nil 0)))
;;---------------------------------------------------------------;;
;;Generic function defined in src;base;generic-copy.lisp
@@ -174,7 +180,7 @@
;; Copy between a Lisp array and a tensor
(defun convert-to-lisp-array (tensor)
-"
+ "
Syntax
======
(convert-to-lisp-array tensor)
@@ -189,11 +195,11 @@
(ret (make-array (lvec->list dims)
:element-type (or (getf (get-tensor-object-optimization tensor) :element-type)
(error 'tensor-cannot-find-optimization :tensor-class (class-name (class-of tensor)))))))
- (let ((lst (make-list (rank tensor))))
- (very-quickly
- (mod-dotimes (idx dims)
- do (setf (apply #'aref ret (lvec->list! idx lst)) (tensor-ref tensor idx))))
- ret)))
+ (let ((lst (make-list (rank tensor))))
+ (very-quickly
+ (mod-dotimes (idx dims)
+ do (setf (apply #'aref ret (lvec->list! idx lst)) (tensor-ref tensor idx))))
+ ret)))
(defmethod copy! :before ((x standard-tensor) (y array))
(assert (subtypep (getf (get-tensor-object-optimization x) :element-type)
@@ -210,21 +216,21 @@
(defmethod copy! ((x real-tensor) (y array))
(let-typed ((sto-x (store x) :type real-store-vector)
(lst (make-list (rank x)) :type cons))
- (mod-dotimes (idx (dimensions x))
- with (linear-sums
- (of-x (strides x) (head x)))
- do (setf (apply #'aref y (lvec->list! idx lst))
- (aref sto-x of-x))))
+ (mod-dotimes (idx (dimensions x))
+ with (linear-sums
+ (of-x (strides x) (head x)))
+ do (setf (apply #'aref y (lvec->list! idx lst))
+ (aref sto-x of-x))))
y)
(defmethod copy! ((x complex-tensor) (y array))
(let-typed ((sto-x (store x) :type complex-store-vector)
(lst (make-list (rank x)) :type cons))
- (mod-dotimes (idx (dimensions x))
- with (linear-sums
- (of-x (strides x) (head x)))
- do (setf (apply #'aref y (lvec->list! idx lst))
- (complex (aref sto-x (* 2 of-x)) (aref sto-x (1+ (* 2 of-x)))))))
+ (mod-dotimes (idx (dimensions x))
+ with (linear-sums
+ (of-x (strides x) (head x)))
+ do (setf (apply #'aref y (lvec->list! idx lst))
+ (complex (aref sto-x (* 2 of-x)) (aref sto-x (1+ (* 2 of-x)))))))
y)
;;
@@ -242,23 +248,23 @@
(defmethod copy! ((x array) (y real-tensor))
(let-typed ((sto-y (store y) :type real-store-vector)
(lst (make-list (array-rank x)) :type cons))
- (very-quickly
- (mod-dotimes (idx (dimensions y))
- with (linear-sums
- (of-y (strides y) (head y)))
- do (setf (aref sto-y of-y) (apply #'aref x (lvec->list! idx lst))))))
+ (very-quickly
+ (mod-dotimes (idx (dimensions y))
+ with (linear-sums
+ (of-y (strides y) (head y)))
+ do (setf (aref sto-y of-y) (apply #'aref x (lvec->list! idx lst))))))
y)
(defmethod copy! ((x array) (y complex-tensor))
(let-typed ((sto-y (store y) :type real-store-vector)
(lst (make-list (array-rank x)) :type cons))
- (very-quickly
- (mod-dotimes (idx (dimensions y))
- with (linear-sums
- (of-y (strides y) (head y)))
- do (let-typed ((ele (apply #'aref x (lvec->list! idx lst)) :type complex-type))
- (setf (aref sto-y (* 2 of-y)) (realpart ele)
- (aref sto-y (1+ (* 2 of-y))) (imagpart ele))))))
+ (very-quickly
+ (mod-dotimes (idx (dimensions y))
+ with (linear-sums
+ (of-y (strides y) (head y)))
+ do (let-typed ((ele (apply #'aref x (lvec->list! idx lst)) :type complex-type))
+ (setf (aref sto-y (* 2 of-y)) (realpart ele)
+ (aref sto-y (1+ (* 2 of-y))) (imagpart ele))))))
y)
;;
diff --git a/src/level-1/dot.lisp b/src/level-1/dot.lisp
index c3d571f..435cff1 100644
--- a/src/level-1/dot.lisp
+++ b/src/level-1/dot.lisp
@@ -34,22 +34,27 @@
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
(setf (getf opt :dot) func
(get-tensor-class-optimization tensor-class) opt)
- `(defun ,func (x y conjugate-p)
- (declare (type ,tensor-class x y)
- ,(if conj?
- `(type boolean conjugate-p)
- `(ignore conjugate-p)))
- ,(let
- ((lisp-routine
- `(let-typed
- ((stp-x (aref (strides x) 0) :type index-type)
- (sto-x (store x) :type ,(linear-array-type (getf opt :store-type)))
- (stp-y (aref (strides y) 0) :type index-type)
- (sto-y (store y) :type ,(linear-array-type (getf opt :store-type)))
- (nele (number-of-elements x) :type index-type))
- ,(labels ((main-loop (conjp)
- `(very-quickly
- (loop :repeat nele
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (let ((opt (get-tensor-class-optimization-hashtable ',tensor-class)))
+ (assert opt nil 'tensor-cannot-find-optimization :tensor-class ',tensor-class)
+ (setf (getf opt :axpy) ',func
+ (get-tensor-class-optimization ',tensor-class) opt))
+ (defun ,func (x y conjugate-p)
+ (declare (type ,tensor-class x y)
+ ,(if conj?
+ `(type boolean conjugate-p)
+ `(ignore conjugate-p)))
+ ,(let
+ ((lisp-routine
+ `(let-typed
+ ((stp-x (aref (strides x) 0) :type index-type)
+ (sto-x (store x) :type ,(linear-array-type (getf opt :store-type)))
+ (stp-y (aref (strides y) 0) :type index-type)
+ (sto-y (store y) :type ,(linear-array-type (getf opt :store-type)))
+ (nele (number-of-elements x) :type index-type))
+ ,(labels ((main-loop (conjp)
+ `(very-quickly
+ (loop :repeat nele
:for of-x :of-type index-type = (head x) :then (+ of-x stp-x)
:for of-y :of-type index-type = (head y) :then (+ of-y stp-y)
:with dot :of-type ,(getf opt :element-type) = (,(getf opt :fid+))
@@ -64,42 +69,42 @@
,(main-loop t)
,(main-loop nil))
(main-loop nil))))))
- (if blas?
- `(let ((call-fortran? (> (number-of-elements x)
- ,fortran-lb)))
- (cond
- (call-fortran?
- ,(recursive-append
- (when conj?
- `(if conjugate-p
- (,blasc-func (number-of-elements x)
- (store x) (aref (strides x) 0)
- (store y) (aref (strides y) 0)
- (head x) (head y))))
- `(,blas-func (number-of-elements x)
- (store x) (aref (strides x) 0)
- (store y) (aref (strides y) 0)
- (head x) (head y))))
- (t
- ,lisp-routine)))
- lisp-routine)))))
+ (if blas?
+ `(let ((call-fortran? (> (number-of-elements x)
+ ,fortran-lb)))
+ (cond
+ (call-fortran?
+ ,(recursive-append
+ (when conj?
+ `(if conjugate-p
+ (,blasc-func (number-of-elements x)
+ (store x) (aref (strides x) 0)
+ (store y) (aref (strides y) 0)
+ (head x) (head y))))
+ `(,blas-func (number-of-elements x)
+ (store x) (aref (strides x) 0)
+ (store y) (aref (strides y) 0)
+ (head x) (head y))))
+ (t
+ ,lisp-routine)))
+ lisp-routine))))))
(generate-typed-dot real-typed-dot
- (real-tensor ddot nil *real-l1-fcall-lb*))
+ (real-tensor ddot nil *real-l1-fcall-lb*))
(generate-typed-dot complex-typed-dot
- (complex-tensor zdotu zdotc *complex-l1-fcall-lb*))
+ (complex-tensor zdotu zdotc *complex-l1-fcall-lb*))
#+maxima
(generate-typed-dot symbolic-typed-dot
- (symbolic-tensor nil nil 0))
+ (symbolic-tensor nil nil 0))
;;---------------------------------------------------------------;;
-
-
+
+
(defgeneric dot (x y &optional conjugate-p)
(:documentation
-"
+ "
Sytnax
======
(DOT x y [conjugate-p])
@@ -130,9 +135,9 @@
otherwise.
")
(:method :before ((x standard-vector) (y standard-vector) &optional (conjugate-p t))
- (declare (ignore conjugate-p))
- (unless (lvec-eq (dimensions x) (dimensions y) #'=)
- (error 'tensor-dimension-mismatch))))
+ (declare (ignore conjugate-p))
+ (unless (lvec-eq (dimensions x) (dimensions y) #'=)
+ (error 'tensor-dimension-mismatch))))
(defmethod dot ((x number) (y number) &optional (conjugate-p t))
(if conjugate-p
@@ -181,16 +186,16 @@
(let ((dot-name (gensym (string+ (symbol-name classn) "-dot-"))))
(compile-and-eval
`(generate-typed-dot ,dot-name
- (,classn nil nil 0)))
+ (,classn nil nil 0)))
dot-name))))
(compile-and-eval
`(defmethod dot ((x ,classn) (y ,classn) &optional (conjugate-p t))
,@(unless (get classn :fconj)
- `((declare (ignore conjugate-p))))
+ `((declare (ignore conjugate-p))))
,(if (get classn :fconj)
`(,dot-func x y conjugate-p)
`(,dot-func x y t))))
- ;;Call method
+ ;;Call method
(dot x y conjugate-p)))
((coercable? (class-name xcl) (class-name ycl))
...)
diff --git a/src/level-1/realimag.lisp b/src/level-1/realimag.lisp
index 52cea96..b38569c 100644
--- a/src/level-1/realimag.lisp
+++ b/src/level-1/realimag.lisp
@@ -29,7 +29,7 @@
(in-package #:matlisp)
(definline tensor-realpart~ (tensor)
-"
+ "
Syntax
======
(tensor-realpart~ tensor)
@@ -51,7 +51,7 @@
(number (realpart tensor))))
(definline tensor-imagpart~ (tensor)
-"
+ "
Syntax
======
(tensor-imagpart~ tensor)
@@ -73,7 +73,7 @@
(number (imagpart tensor))))
(definline tensor-realpart (tensor)
-"
+ "
Syntax
======
(tensor-realpart tensor)
@@ -89,7 +89,7 @@
(copy (tensor-realpart~ tensor)))
(definline tensor-imagpart (tensor)
-"
+ "
Syntax
======
(tensor-imagpart matrix)
diff --git a/src/level-1/scal.lisp b/src/level-1/scal.lisp
index 6013a9c..ad2749d 100644
--- a/src/level-1/scal.lisp
+++ b/src/level-1/scal.lisp
@@ -31,147 +31,159 @@
(defmacro generate-typed-scal! (func (tensor-class fortran-func fortran-lb))
(let* ((opt (get-tensor-class-optimization-hashtable tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
- (setf (getf opt :scal) func
- (get-tensor-class-optimization tensor-class) opt)
- `(defun ,func (from to)
- (declare (type ,tensor-class from to))
- ,(let
- ((lisp-routine
- `(let ((f-sto (store from))
- (t-sto (store to)))
- (declare (type ,(linear-array-type (getf opt :store-type)) f-sto t-sto))
- (very-quickly
- (mod-dotimes (idx (dimensions from))
- with (linear-sums
- (f-of (strides from) (head from))
- (t-of (strides to) (head to)))
- do (let*-typed ((val-f (,(getf opt :reader) f-sto f-of) :type ,(getf opt :element-type))
- (val-t (,(getf opt :reader) t-sto t-of) :type ,(getf opt :element-type))
- (mul (,(getf opt :f*) val-f val-t) :type ,(getf opt :element-type)))
- (,(getf opt :value-writer) mul t-sto t-of)))))))
- (if fortran-func
- `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
- (strd-p (when call-fortran? (blas-copyable-p from to))))
- (cond
- ((and strd-p call-fortran?)
- (,fortran-func (number-of-elements from)
- (store from) (first strd-p)
- (store to) (second strd-p)
- (head from) (head to)))
- (t
- ,lisp-routine)))
- lisp-routine))
- to)))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (let ((opt (get-tensor-class-optimization-hashtable ',tensor-class)))
+ (assert opt nil 'tensor-cannot-find-optimization :tensor-class ',tensor-class)
+ (setf (getf opt :scal) ',func
+ (get-tensor-class-optimization ',tensor-class) opt))
+ (defun ,func (from to)
+ (declare (type ,tensor-class from to))
+ ,(let
+ ((lisp-routine
+ `(let ((f-sto (store from))
+ (t-sto (store to)))
+ (declare (type ,(linear-array-type (getf opt :store-type)) f-sto t-sto))
+ (very-quickly
+ (mod-dotimes (idx (dimensions from))
+ with (linear-sums
+ (f-of (strides from) (head from))
+ (t-of (strides to) (head to)))
+ do (let*-typed ((val-f (,(getf opt :reader) f-sto f-of) :type ,(getf opt :element-type))
+ (val-t (,(getf opt :reader) t-sto t-of) :type ,(getf opt :element-type))
+ (mul (,(getf opt :f*) val-f val-t) :type ,(getf opt :element-type)))
+ (,(getf opt :value-writer) mul t-sto t-of)))))))
+ (if fortran-func
+ `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
+ (strd-p (when call-fortran? (blas-copyable-p from to))))
+ (cond
+ ((and strd-p call-fortran?)
+ (,fortran-func (number-of-elements from)
+ (store from) (first strd-p)
+ (store to) (second strd-p)
+ (head from) (head to)))
+ (t
+ ,lisp-routine)))
+ lisp-routine))
+ to))))
(defmacro generate-typed-num-scal! (func (tensor-class blas-func fortran-lb))
(let ((opt (get-tensor-class-optimization-hashtable tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
- (setf (getf opt :num-scal) func
- (get-tensor-class-optimization tensor-class) opt)
- `(defun ,func (alpha to)
- (declare (type ,tensor-class to)
- (type ,(getf opt :element-type) alpha))
- ,(let
- ((lisp-routine
- `(let ((t-sto (store to)))
- (declare (type ,(linear-array-type (getf opt :store-type)) t-sto))
- (very-quickly
- (mod-dotimes (idx (dimensions to))
- with (linear-sums
- (t-of (strides to) (head to)))
- do (let ((scal-val (,(getf opt :f*) (,(getf opt :reader) t-sto t-of) alpha)))
- (,(getf opt :value-writer) scal-val t-sto t-of)))))))
- (if blas-func
- `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
- (min-stride (when call-fortran? (consecutive-store-p to))))
- (cond
- ((and call-fortran? min-stride)
- (,blas-func (number-of-elements to) alpha (store to) min-stride (head to)))
- (t
- ,lisp-routine)))
- lisp-routine))
- to)))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (let ((opt (get-tensor-class-optimization-hashtable ',tensor-class)))
+ (assert opt nil 'tensor-cannot-find-optimization :tensor-class ',tensor-class)
+ (setf (getf opt :num-scal) ',func
+ (get-tensor-class-optimization ',tensor-class) opt))
+ (defun ,func (alpha to)
+ (declare (type ,tensor-class to)
+ (type ,(getf opt :element-type) alpha))
+ ,(let
+ ((lisp-routine
+ `(let ((t-sto (store to)))
+ (declare (type ,(linear-array-type (getf opt :store-type)) t-sto))
+ (very-quickly
+ (mod-dotimes (idx (dimensions to))
+ with (linear-sums
+ (t-of (strides to) (head to)))
+ do (let ((scal-val (,(getf opt :f*) (,(getf opt :reader) t-sto t-of) alpha)))
+ (,(getf opt :value-writer) scal-val t-sto t-of)))))))
+ (if blas-func
+ `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
+ (min-stride (when call-fortran? (consecutive-store-p to))))
+ (cond
+ ((and call-fortran? min-stride)
+ (,blas-func (number-of-elements to) alpha (store to) min-stride (head to)))
+ (t
+ ,lisp-routine)))
+ lisp-routine))
+ to))))
(defmacro generate-typed-div! (func (tensor-class fortran-func fortran-lb))
(let* ((opt (get-tensor-class-optimization-hashtable tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
- (setf (getf opt :div) func
- (get-tensor-class-optimization tensor-class) opt)
- `(defun ,func (from to)
- (declare (type ,tensor-class from to))
- ,(let
- ((lisp-routine
- `(let ((f-sto (store from))
- (t-sto (store to)))
- (declare (type ,(linear-array-type (getf opt :store-type)) f-sto t-sto))
- (very-quickly
- (mod-dotimes (idx (dimensions from))
- with (linear-sums
- (f-of (strides from) (head from))
- (t-of (strides to) (head to)))
- do (let*-typed ((val-f (,(getf opt :reader) f-sto f-of) :type ,(getf opt :element-type))
- (val-t (,(getf opt :reader) t-sto t-of) :type ,(getf opt :element-type))
- (mul (,(getf opt :f/) val-f val-t) :type ,(getf opt :element-type)))
- (,(getf opt :value-writer) mul t-sto t-of)))))))
- (if fortran-func
- `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
- (strd-p (when call-fortran? (blas-copyable-p from to))))
- (cond
- ((and strd-p call-fortran?)
- (,fortran-func (number-of-elements from)
- (store from) (first strd-p)
- (store to) (second strd-p)
- (head from) (head to)))
- (t
- ,lisp-routine)))
- lisp-routine))
- to)))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (let ((opt (get-tensor-class-optimization-hashtable ',tensor-class)))
+ (assert opt nil 'tensor-cannot-find-optimization :tensor-class ',tensor-class)
+ (setf (getf opt :div) ',func
+ (get-tensor-class-optimization ',tensor-class) opt))
+ (defun ,func (from to)
+ (declare (type ,tensor-class from to))
+ ,(let
+ ((lisp-routine
+ `(let ((f-sto (store from))
+ (t-sto (store to)))
+ (declare (type ,(linear-array-type (getf opt :store-type)) f-sto t-sto))
+ (very-quickly
+ (mod-dotimes (idx (dimensions from))
+ with (linear-sums
+ (f-of (strides from) (head from))
+ (t-of (strides to) (head to)))
+ do (let*-typed ((val-f (,(getf opt :reader) f-sto f-of) :type ,(getf opt :element-type))
+ (val-t (,(getf opt :reader) t-sto t-of) :type ,(getf opt :element-type))
+ (mul (,(getf opt :f/) val-f val-t) :type ,(getf opt :element-type)))
+ (,(getf opt :value-writer) mul t-sto t-of)))))))
+ (if fortran-func
+ `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
+ (strd-p (when call-fortran? (blas-copyable-p from to))))
+ (cond
+ ((and strd-p call-fortran?)
+ (,fortran-func (number-of-elements from)
+ (store from) (first strd-p)
+ (store to) (second strd-p)
+ (head from) (head to)))
+ (t
+ ,lisp-routine)))
+ lisp-routine))
+ to))))
(defmacro generate-typed-num-div! (func (tensor-class fortran-func fortran-lb))
(let ((opt (get-tensor-class-optimization tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
- (setf (getf opt :num-div) func
- (get-tensor-class-optimization tensor-class) opt)
- `(defun ,func (alpha to)
- (declare (type ,tensor-class to)
- (type ,(getf opt :element-type) alpha))
- ,(let
- ((lisp-routine
- `(let ((t-sto (store to)))
- (declare (type ,(linear-array-type (getf opt :store-type)) t-sto))
- (very-quickly
- (mod-dotimes (idx (dimensions to))
- with (linear-sums
- (t-of (strides to) (head to)))
- do (let-typed ((scal-val (,(getf opt :f/) alpha (,(getf opt :reader) t-sto t-of)) :type ,(getf opt :element-type)))
- (,(getf opt :value-writer) scal-val t-sto t-of)))))))
- (if fortran-func
- `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
- (min-stride (when call-fortran? (consecutive-store-p to))))
- (cond
- ((and call-fortran? min-stride)
- (let ((num-array (,(getf opt :store-allocator) 1)))
- (declare (type ,(linear-array-type (getf opt :store-type)) num-array))
- (let-typed ((id (,(getf opt :fid*)) :type ,(getf opt :element-type)))
- (,(getf opt :value-writer) id num-array 0))
- (,fortran-func (number-of-elements to) num-array 0 (store to) min-stride (head to))))
- (t
- ,lisp-routine)))
- lisp-routine))
- to)))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (let ((opt (get-tensor-class-optimization-hashtable ',tensor-class)))
+ (assert opt nil 'tensor-cannot-find-optimization :tensor-class ',tensor-class)
+ (setf (getf opt :num-div) ',func
+ (get-tensor-class-optimization ',tensor-class) opt))
+ (defun ,func (alpha to)
+ (declare (type ,tensor-class to)
+ (type ,(getf opt :element-type) alpha))
+ ,(let
+ ((lisp-routine
+ `(let ((t-sto (store to)))
+ (declare (type ,(linear-array-type (getf opt :store-type)) t-sto))
+ (very-quickly
+ (mod-dotimes (idx (dimensions to))
+ with (linear-sums
+ (t-of (strides to) (head to)))
+ do (let-typed ((scal-val (,(getf opt :f/) alpha (,(getf opt :reader) t-sto t-of)) :type ,(getf opt :element-type)))
+ (,(getf opt :value-writer) scal-val t-sto t-of)))))))
+ (if fortran-func
+ `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
+ (min-stride (when call-fortran? (consecutive-store-p to))))
+ (cond
+ ((and call-fortran? min-stride)
+ (let ((num-array (,(getf opt :store-allocator) 1)))
+ (declare (type ,(linear-array-type (getf opt :store-type)) num-array))
+ (let-typed ((id (,(getf opt :fid*)) :type ,(getf opt :element-type)))
+ (,(getf opt :value-writer) id num-array 0))
+ (,fortran-func (number-of-elements to) num-array 0 (store to) min-stride (head to))))
+ (t
+ ,lisp-routine)))
+ lisp-routine))
+ to))))
;;Real
(generate-typed-num-scal! real-typed-num-scal!
- (real-tensor dscal *real-l1-fcall-lb*))
+ (real-tensor dscal *real-l1-fcall-lb*))
(generate-typed-scal! real-typed-scal!
- (real-tensor descal *real-l1-fcall-lb*))
+ (real-tensor descal *real-l1-fcall-lb*))
(generate-typed-div! real-typed-div!
- (real-tensor dediv *real-l1-fcall-lb*))
+ (real-tensor dediv *real-l1-fcall-lb*))
(generate-typed-num-div! real-typed-num-div!
- (real-tensor dediv *real-l1-fcall-lb*))
+ (real-tensor dediv *real-l1-fcall-lb*))
;;Complex
(definline zordscal (nele alpha x incx &optional hd-x)
@@ -180,36 +192,36 @@
(zscal nele alpha x incx hd-x)))
(generate-typed-num-scal! complex-typed-num-scal!
- (complex-tensor zordscal *complex-l1-fcall-lb*))
+ (complex-tensor zordscal *complex-l1-fcall-lb*))
(generate-typed-scal! complex-typed-scal!
- (complex-tensor zescal *complex-l1-fcall-lb*))
+ (complex-tensor zescal *complex-l1-fcall-lb*))
(generate-typed-div! complex-typed-div!
- (complex-tensor zediv *complex-l1-fcall-lb*))
+ (complex-tensor zediv *complex-l1-fcall-lb*))
(generate-typed-num-div! complex-typed-num-div!
- (complex-tensor zediv *complex-l1-fcall-lb*))
+ (complex-tensor zediv *complex-l1-fcall-lb*))
;;Symbolic
#+maxima
(progn
(generate-typed-num-scal! symbolic-typed-num-scal!
- (symbolic-tensor nil 0))
+ (symbolic-tensor nil 0))
(generate-typed-scal! symbolic-typed-scal!
- (symbolic-tensor nil 0))
+ (symbolic-tensor nil 0))
(generate-typed-div! symbolic-typed-div!
- (symbolic-tensor nil 0))
+ (symbolic-tensor nil 0))
(generate-typed-num-div! symbolic-typed-num-div!
- (symbolic-tensor nil 0)))
+ (symbolic-tensor nil 0)))
;;---------------------------------------------------------------;;
(defgeneric scal! (alpha x)
(:documentation
-"
+ "
Syntax
======
(SCAL! alpha x)
@@ -219,8 +231,8 @@
X <- alpha .* X
")
(:method :before ((x standard-tensor) (y standard-tensor))
- (assert (lvec-eq (dimensions x) (dimensions y) #'=) nil
- 'tensor-dimension-mismatch)))
+ (assert (lvec-eq (dimensions x) (dimensions y) #'=) nil
+ 'tensor-dimension-mismatch)))
(defmethod scal! ((alpha number) (x real-tensor))
(real-typed-num-scal! (coerce-real alpha) x))
@@ -253,8 +265,8 @@
X <- alpha ./ X
")
(:method :before ((x standard-tensor) (y standard-tensor))
- (assert (lvec-eq (dimensions x) (dimensions y) #'=) nil
- 'tensor-dimension-mismatch)))
+ (assert (lvec-eq (dimensions x) (dimensions y) #'=) nil
+ 'tensor-dimension-mismatch)))
(defmethod div! ((alpha number) (x real-tensor))
(real-typed-num-div! (coerce-real alpha) x))
@@ -276,7 +288,7 @@
;;
(defgeneric scal (alpha x)
(:documentation
-"
+ "
Syntax
======
(SCAL alpha x)
diff --git a/src/level-1/swap.lisp b/src/level-1/swap.lisp
index dd8b05d..9464bc8 100644
--- a/src/level-1/swap.lisp
+++ b/src/level-1/swap.lisp
@@ -34,41 +34,44 @@
;;Use only after checking the arguments for compatibility.
(let* ((opt (get-tensor-class-optimization-hashtable tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
- (setf (getf opt :swap) func
- (get-tensor-class-optimization tensor-class) opt)
- `(defun ,func (x y)
- (declare (type ,tensor-class x y))
- ,(let
- ((lisp-routine
- `(let ((f-sto (store x))
- (t-sto (store y)))
- (declare (type ,(linear-array-type (getf opt :store-type)) f-sto t-sto))
- (very-quickly
- (mod-dotimes (idx (dimensions x))
- with (linear-sums
- (f-of (strides x) (head x))
- (t-of (strides y) (head y)))
- do (,(getf opt :swapper) f-sto f-of t-sto t-of))))))
- (if blas-func
- `(let* ((call-fortran? (> (number-of-elements x) ,fortran-lb))
- (strd-p (when call-fortran? (blas-copyable-p x y))))
- (cond
- ((and strd-p call-fortran?)
- (,blas-func (number-of-elements x) (store x) (first strd-p) (store y) (second strd-p) (head x) (head y)))
- (t
- ,lisp-routine)))
- lisp-routine))
- y)))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (let ((opt (get-tensor-class-optimization-hashtable ',tensor-class)))
+ (assert opt nil 'tensor-cannot-find-optimization :tensor-class ',tensor-class)
+ (setf (getf opt :swap) ',func
+ (get-tensor-class-optimization ',tensor-class) opt))
+ (defun ,func (x y)
+ (declare (type ,tensor-class x y))
+ ,(let
+ ((lisp-routine
+ `(let ((f-sto (store x))
+ (t-sto (store y)))
+ (declare (type ,(linear-array-type (getf opt :store-type)) f-sto t-sto))
+ (very-quickly
+ (mod-dotimes (idx (dimensions x))
+ with (linear-sums
+ (f-of (strides x) (head x))
+ (t-of (strides y) (head y)))
+ do (,(getf opt :swapper) f-sto f-of t-sto t-of))))))
+ (if blas-func
+ `(let* ((call-fortran? (> (number-of-elements x) ,fortran-lb))
+ (strd-p (when call-fortran? (blas-copyable-p x y))))
+ (cond
+ ((and strd-p call-fortran?)
+ (,blas-func (number-of-elements x) (store x) (first strd-p) (store y) (second strd-p) (head x) (head y)))
+ (t
+ ,lisp-routine)))
+ lisp-routine))
+ y))))
(generate-typed-swap! real-typed-swap!
- (real-tensor dswap *real-l1-fcall-lb*))
+ (real-tensor dswap *real-l1-fcall-lb*))
(generate-typed-swap! complex-typed-swap!
- (complex-tensor zswap *complex-l1-fcall-lb*))
+ (complex-tensor zswap *complex-l1-fcall-lb*))
#+maxima
(generate-typed-swap! symbolic-typed-swap!
- (symbolic-tensor nil 0))
+ (symbolic-tensor nil 0))
;;---------------------------------------------------------------;;
;;Generic function in src;base;generic-swap.lisp
diff --git a/src/level-1/tensor-maker.lisp b/src/level-1/tensor-maker.lisp
index a6fa87b..5961798 100644
--- a/src/level-1/tensor-maker.lisp
+++ b/src/level-1/tensor-maker.lisp
@@ -3,50 +3,53 @@
(defmacro make-tensor-maker (func-name (tensor-class))
(let ((opt (get-tensor-class-optimization-hashtable tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
- (setf (getf opt :maker) func-name
- (get-tensor-class-optimization tensor-class) opt)
- `(defun ,func-name (&rest args)
- (labels ((make-dims (dims)
- (declare (type cons dims))
- (let*-typed ((vdim (make-index-store dims) :type index-store-vector)
- (ss (very-quickly (lvec-foldl #'(lambda (x y) (the index-type (* x y))) vdim)))
- (store (,(getf opt :store-allocator) ss))
- (rnk (length vdim)))
- (make-instance (case rnk (2 ',(getf opt :matrix)) (1 ',(getf opt :vector)) (t ',tensor-class))
- :store store :store-size ss :dimensions vdim)))
- (make-from-array (arr)
- (declare (type (array * *) arr))
- (let* ((ret (make-dims (array-dimensions arr)))
- (st-r (store ret))
- (lst (make-list (rank ret))))
- (declare (type ,tensor-class ret)
- (type ,(linear-array-type (getf opt :store-type)) st-r))
- (mod-dotimes (idx (dimensions ret))
- with (linear-sums
- (of-r (strides ret) (head ret)))
- do (,(getf opt :value-writer) (,(getf opt :coercer) (apply #'aref arr (lvec->list! idx lst))) st-r of-r))
- ret))
- (make-from-list (lst)
- (let* ((ret (make-dims (list-dimensions lst)))
- (st-r (store ret)))
- (declare (type ,tensor-class ret)
- (type ,(linear-array-type (getf opt :store-type)) st-r))
- (list-loop (idx ele lst)
- with (linear-sums
- (of-r (strides ret) (head ret)))
- do (,(getf opt :value-writer) (,(getf opt :coercer) ele) st-r of-r))
- ret)))
- (let ((largs (length args)))
- (if (= largs 1)
- (etypecase (first args)
- (array
- (make-from-array (first args)))
- (cons
- (make-from-list (first args)))
- (integer
- (make-dims (list (first args)))))
- (make-dims args)))))))
-
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (let ((opt (get-tensor-class-optimization-hashtable ',tensor-class)))
+ (assert opt nil 'tensor-cannot-find-optimization :tensor-class ',tensor-class)
+ (setf (getf opt :maker) ',func-name
+ (get-tensor-class-optimization ',tensor-class) opt))
+ (defun ,func-name (&rest args)
+ (labels ((make-dims (dims)
+ (declare (type cons dims))
+ (let*-typed ((vdim (make-index-store dims) :type index-store-vector)
+ (ss (very-quickly (lvec-foldl #'(lambda (x y) (the index-type (* x y))) vdim)))
+ (store (,(getf opt :store-allocator) ss))
+ (rnk (length vdim)))
+ (make-instance (case rnk (2 ',(getf opt :matrix)) (1 ',(getf opt :vector)) (t ',tensor-class))
+ :store store :store-size ss :dimensions vdim)))
+ (make-from-array (arr)
+ (declare (type (array * *) arr))
+ (let* ((ret (make-dims (array-dimensions arr)))
+ (st-r (store ret))
+ (lst (make-list (rank ret))))
+ (declare (type ,tensor-class ret)
+ (type ,(linear-array-type (getf opt :store-type)) st-r))
+ (mod-dotimes (idx (dimensions ret))
+ with (linear-sums
+ (of-r (strides ret) (head ret)))
+ do (,(getf opt :value-writer) (,(getf opt :coercer) (apply #'aref arr (lvec->list! idx lst))) st-r of-r))
+ ret))
+ (make-from-list (lst)
+ (let* ((ret (make-dims (list-dimensions lst)))
+ (st-r (store ret)))
+ (declare (type ,tensor-class ret)
+ (type ,(linear-array-type (getf opt :store-type)) st-r))
+ (list-loop (idx ele lst)
+ with (linear-sums
+ (of-r (strides ret) (head ret)))
+ do (,(getf opt :value-writer) (,(getf opt :coercer) ele) st-r of-r))
+ ret)))
+ (let ((largs (length args)))
+ (if (= largs 1)
+ (etypecase (first args)
+ (array
+ (make-from-array (first args)))
+ (cons
+ (make-from-list (first args)))
+ (integer
+ (make-dims (list (first args)))))
+ (make-dims args))))))))
+
(make-tensor-maker make-real-tensor (real-tensor))
(make-tensor-maker make-complex-tensor (complex-tensor))
diff --git a/src/level-1/trans.lisp b/src/level-1/trans.lisp
index b0de83a..b1c0e00 100644
--- a/src/level-1/trans.lisp
+++ b/src/level-1/trans.lisp
@@ -54,8 +54,8 @@
(let-typed ((rnk (rank A) :type index-type)
(dim-A (dimensions A) :type index-store-vector)
(strd-A (strides A) :type index-store-vector))
- (rotatef (aref dim-A (1- rnk)) (aref dim-A 0))
- (rotatef (aref strd-A (1- rnk)) (aref strd-A 0))))
+ (rotatef (aref dim-A (1- rnk)) (aref dim-A 0))
+ (rotatef (aref strd-A (1- rnk)) (aref strd-A 0))))
A)
(definline (setf transpose!) (value A &optional permutation)
@@ -81,9 +81,9 @@
(copy! value (TRANSPOSE~ tensor permutation))"
(declare (type standard-tensor A))
(let ((displaced (make-instance (class-of A) :store (store A)
- :dimensions (copy-seq (dimensions A))
- :strides (copy-seq (strides A))
- :parent-tensor A)))
+ :dimensions (copy-seq (dimensions A))
+ :strides (copy-seq (strides A))
+ :parent-tensor A)))
(transpose! displaced permutation)))
(definline (setf transpose~) (value A &optional permutation)
@@ -158,7 +158,7 @@
;;
(defun htranspose! (A &optional permutation)
-"
+ "
Syntax
======
(HTRANSPOSE! A [permutation])
@@ -186,7 +186,7 @@
(htranspose! A permutation))
(definline htranspose (A &optional permutation)
-"
+ "
Syntax
======
(HTRANSPOSE A [permutation])
diff --git a/src/level-2/gemv.lisp b/src/level-2/gemv.lisp
index 07631af..727e89b 100644
--- a/src/level-2/gemv.lisp
+++ b/src/level-2/gemv.lisp
@@ -10,74 +10,77 @@
(error 'tensor-cannot-find-optimization :tensor-class tensor-class)))
(matrix-class (getf opt :matrix))
(vector-class (getf opt :vector)))
- (setf (getf opt :gemv) func
- (get-tensor-class-optimization tensor-class) opt)
- `(defun ,func (alpha A x beta y job)
- (declare (type ,(getf opt :element-type) alpha beta)
- (type ,matrix-class A)
- (type ,vector-class x y)
- (type symbol job))
- ,(let
- ((lisp-routine
- `(let-typed ((nr-A (nrows A) :type index-type)
- (nc-A (ncols A) :type index-type)
- (rs-A (row-stride A) :type index-type)
- (cs-A (col-stride A) :type index-type)
- (sto-A (store A) :type ,(linear-array-type (getf opt :store-type)))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (let ((opt (get-tensor-class-optimization-hashtable ',tensor-class)))
+ (assert opt nil 'tensor-cannot-find-optimization :tensor-class ',tensor-class)
+ (setf (getf opt :gemv) ',func
+ (get-tensor-class-optimization ',tensor-class) opt))
+ (defun ,func (alpha A x beta y job)
+ (declare (type ,(getf opt :element-type) alpha beta)
+ (type ,matrix-class A)
+ (type ,vector-class x y)
+ (type symbol job))
+ ,(let
+ ((lisp-routine
+ `(let-typed ((nr-A (nrows A) :type index-type)
+ (nc-A (ncols A) :type index-type)
+ (rs-A (row-stride A) :type index-type)
+ (cs-A (col-stride A) :type index-type)
+ (sto-A (store A) :type ,(linear-array-type (getf opt :store-type)))
;
- (stp-x (aref (strides x) 0) :type index-type)
- (sto-x (store x) :type ,(linear-array-type (getf opt :store-type)))
- (hd-x (head x) :type index-type)
+ (stp-x (aref (strides x) 0) :type index-type)
+ (sto-x (store x) :type ,(linear-array-type (getf opt :store-type)))
+ (hd-x (head x) :type index-type)
;
- (stp-y (aref (strides y) 0) :type index-type)
- (sto-y (store y) :type ,(linear-array-type (getf opt :store-type))))
- (when (eq job :t)
- (rotatef nr-A nc-A)
- (rotatef rs-A cs-A))
- (very-quickly
- (loop :repeat nr-A
- :for of-y :of-type index-type := (head y) :then (+ of-y stp-y)
- :for rof-A :of-type index-type := (head A) :then (+ rof-A rs-A)
- :do (let-typed ((val (,(getf opt :f*) beta (,(getf opt :reader) sto-y of-y)) :type ,(getf opt :element-type)))
- (loop :repeat nc-A
- :for of-x :of-type index-type := hd-x :then (+ of-x stp-x)
- :for of-A :of-type index-type := rof-A :then (+ of-A cs-A)
- :with dot :of-type ,(getf opt :element-type) = (,(getf opt :fid+))
- :do (let-typed ((xval (,(getf opt :reader) sto-x of-x) :type ,(getf opt :element-type))
- (Aval (,(getf opt :reader) sto-A of-A) :type ,(getf opt :element-type)))
- (setf dot (,(getf opt :f+) dot (,(getf opt :f*) xval Aval))))
- :finally (,(getf opt :value-writer) (,(getf opt :f+) (,(getf opt :f*) alpha dot) val) sto-y of-y))))))))
- (if blas-gemv-func
- `(mlet*
- ((call-fortran? (> (max (nrows A) (ncols A)) ,fortran-call-lb))
- ((maj-A ld-A fop-A) (if call-fortran? (blas-matrix-compatible-p A job) (values nil 0 "?")) :type (symbol index-type (string 1))))
- (cond
- ((and maj-a call-fortran?)
- (let-typed ((nr-A (nrows A) :type index-type)
- (nc-A (ncols A) :type index-type))
- (when (eq maj-A :row-major)
- (rotatef nr-A nc-A))
- (,blas-gemv-func fop-a nr-A nc-A
- alpha (store A) ld-A
- (store x) (aref (strides x) 0)
- beta
- (store y) (aref (strides y) 0)
- (head A) (head x) (head y))))
- (t
- ,lisp-routine)))
- lisp-routine))
- y)))
+ (stp-y (aref (strides y) 0) :type index-type)
+ (sto-y (store y) :type ,(linear-array-type (getf opt :store-type))))
+ (when (eq job :t)
+ (rotatef nr-A nc-A)
+ (rotatef rs-A cs-A))
+ (very-quickly
+ (loop :repeat nr-A
+ :for of-y :of-type index-type := (head y) :then (+ of-y stp-y)
+ :for rof-A :of-type index-type := (head A) :then (+ rof-A rs-A)
+ :do (let-typed ((val (,(getf opt :f*) beta (,(getf opt :reader) sto-y of-y)) :type ,(getf opt :element-type)))
+ (loop :repeat nc-A
+ :for of-x :of-type index-type := hd-x :then (+ of-x stp-x)
+ :for of-A :of-type index-type := rof-A :then (+ of-A cs-A)
+ :with dot :of-type ,(getf opt :element-type) = (,(getf opt :fid+))
+ :do (let-typed ((xval (,(getf opt :reader) sto-x of-x) :type ,(getf opt :element-type))
+ (Aval (,(getf opt :reader) sto-A of-A) :type ,(getf opt :element-type)))
+ (setf dot (,(getf opt :f+) dot (,(getf opt :f*) xval Aval))))
+ :finally (,(getf opt :value-writer) (,(getf opt :f+) (,(getf opt :f*) alpha dot) val) sto-y of-y))))))))
+ (if blas-gemv-func
+ `(mlet*
+ ((call-fortran? (> (max (nrows A) (ncols A)) ,fortran-call-lb))
+ ((maj-A ld-A fop-A) (if call-fortran? (blas-matrix-compatible-p A job) (values nil 0 "?")) :type (symbol index-type (string 1))))
+ (cond
+ ((and maj-a call-fortran?)
+ (let-typed ((nr-A (nrows A) :type index-type)
+ (nc-A (ncols A) :type index-type))
+ (when (eq maj-A :row-major)
+ (rotatef nr-A nc-A))
+ (,blas-gemv-func fop-a nr-A nc-A
+ alpha (store A) ld-A
+ (store x) (aref (strides x) 0)
+ beta
+ (store y) (aref (strides y) 0)
+ (head A) (head x) (head y))))
+ (t
+ ,lisp-routine)))
+ lisp-routine))
+ y))))
;;Real
(generate-typed-gemv! real-base-typed-gemv!
- (real-tensor dgemv *real-l2-fcall-lb*))
+ (real-tensor dgemv *real-l2-fcall-lb*))
(definline real-typed-gemv! (alpha A x beta y job)
(real-base-typed-gemv! alpha A x beta y (ecase job ((:n :t) job) (:h :t) (:c :n))))
;;Complex
(generate-typed-gemv! complex-base-typed-gemv!
- (complex-tensor zgemv *complex-l2-fcall-lb*))
+ (complex-tensor zgemv *complex-l2-fcall-lb*))
(definline complex-typed-gemv! (alpha A x beta y job)
(declare (type complex-matrix A)
@@ -90,22 +93,22 @@
(let-typed ((cx (let-typed ((ret (apply #'make-real-tensor (lvec->list (dimensions x))) :type complex-vector))
(complex-typed-axpy! #c(-1d0 0d0) x ret))
:type complex-vector))
- (complex-typed-num-scal! #c(-1d0 0d0) (tensor-realpart~ y))
- (complex-base-typed-gemv! (cl:conjugate alpha) A cx
- (cl:conjugate beta) y (ecase job (:h :t) (:c :n)))
- (complex-typed-num-scal! #c(-1d0 0d0) (tensor-realpart~ y))
- y)))
+ (complex-typed-num-scal! #c(-1d0 0d0) (tensor-realpart~ y))
+ (complex-base-typed-gemv! (cl:conjugate alpha) A cx
+ (cl:conjugate beta) y (ecase job (:h :t) (:c :n)))
+ (complex-typed-num-scal! #c(-1d0 0d0) (tensor-realpart~ y))
+ y)))
;;Symbolic
#+maxima
(generate-typed-gemv! symbolic-base-typed-gemv!
- (symbolic-tensor nil 0))
+ (symbolic-tensor nil 0))
;;---------------------------------------------------------------;;
(defgeneric gemv! (alpha A x beta y &optional job)
(:documentation
-"
+ "
Syntax
======
(GEMV! alpha A x beta y [job])
@@ -134,17 +137,17 @@
(:method :before ((alpha number) (A standard-matrix) (x standard-vector)
(beta number) (y standard-vector)
&optional (job :n))
- (assert (member job '(:n :t :c :h)) nil 'invalid-value
- :given job :expected `(member job '(:n :t :c :h))
- :message "Inside gemv!")
- (assert (not (eq x y)) nil 'invalid-arguments
- :message "GEMV!: x and y cannot be the same vector")
- (assert (and
- (= (aref (dimensions x) 0)
- (aref (dimensions A) (if (eq job :t) 0 1)))
- (= (aref (dimensions y) 0)
- (aref (dimensions A) (if (eq job :t) 1 0))))
- nil 'tensor-dimension-mismatch)))
+ (assert (member job '(:n :t :c :h)) nil 'invalid-value
+ :given job :expected `(member job '(:n :t :c :h))
+ :message "Inside gemv!")
+ (assert (not (eq x y)) nil 'invalid-arguments
+ :message "GEMV!: x and y cannot be the same vector")
+ (assert (and
+ (= (aref (dimensions x) 0)
+ (aref (dimensions A) (if (eq job :t) 0 1)))
+ (= (aref (dimensions y) 0)
+ (aref (dimensions A) (if (eq job :t) 1 0))))
+ nil 'tensor-dimension-mismatch)))
(defmethod gemv! ((alpha number) (A real-matrix) (x real-vector)
(beta number) (y real-vector) &optional (job :n))
@@ -202,7 +205,7 @@
;;---------------------------------------------------------------;;
(defgeneric gemv (alpha A x beta y &optional job)
(:documentation
-"
+ "
Syntax
======
(GEMV alpha A x beta y [job])
diff --git a/src/level-3/gemm.lisp b/src/level-3/gemm.lisp
index 32a879a..24a7519 100644
--- a/src/level-3/gemm.lisp
+++ b/src/level-3/gemm.lisp
@@ -33,156 +33,160 @@
(error 'tensor-cannot-find-optimization :tensor-class tensor-class)))
(matrix-class (getf opt :matrix))
(blas? (and blas-gemm-func blas-gemv-func)))
- (setf (getf opt :gemm) func
- (get-tensor-class-optimization tensor-class) opt)
- `(defun ,func (alpha A B beta C job)
- (declare (type ,(getf opt :element-type) alpha beta)
- (type ,matrix-class A B C)
- (type symbol job))
- ;;The big done-in-lisp-gemm, loop-ordering was inspired by the BLAS dgemm reference implementation.
- ,(let
- ((lisp-routine
- `(let-typed ((nr-C (nrows C) :type index-type)
- (nc-C (ncols C) :type index-type)
- (dotl (ecase job-A (:n (ncols A)) (:t (nrows A))) :type index-type)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (let ((opt (get-tensor-class-optimization-hashtable ',tensor-class)))
+ (assert opt nil 'tensor-cannot-find-optimization :tensor-class ',tensor-class)
+ (setf (getf opt :gemm) ',func
+ (get-tensor-class-optimization ',tensor-class) opt))
+ (defun ,func (alpha A B beta C job)
+ (declare (type ,(getf opt :element-type) alpha beta)
+ (type ,matrix-class A B C)
+ (type symbol job))
+ ;;The big done-in-lisp-gemm, loop-ordering was inspired by the BLAS dgemm reference implementation.
+ ,(let
+ ((lisp-routine
+ `(let-typed ((nr-C (nrows C) :type index-type)
+ (nc-C (ncols C) :type index-type)
+ (dotl (ecase job-A (:n (ncols A)) (:t (nrows A))) :type index-type)
;
- (rstp-A (row-stride A) :type index-type)
- (cstp-A (col-stride A) :type index-type)
- (hd-A (head A) :type index-type)
- (sto-A (store A) :type ,(linear-array-type (getf opt :store-type)))
+ (rstp-A (row-stride A) :type index-type)
+ (cstp-A (col-stride A) :type index-type)
+ (hd-A (head A) :type index-type)
+ (sto-A (store A) :type ,(linear-array-type (getf opt :store-type)))
;
- (rstp-B (row-stride B) :type index-type)
- (cstp-B (col-stride B) :type index-type)
- (hd-B (head B) :type index-type)
- (sto-B (store B) :type ,(linear-array-type (getf opt :store-type)))
+ (rstp-B (row-stride B) :type index-type)
+ (cstp-B (col-stride B) :type index-type)
+ (hd-B (head B) :type index-type)
+ (sto-B (store B) :type ,(linear-array-type (getf opt :store-type)))
;
- (rstp-C (row-stride C) :type index-type)
- (cstp-C (col-stride C) :type index-type)
- (hd-C (head C) :type index-type)
- (sto-C (store C) :type ,(linear-array-type (getf opt :store-type))))
- ;;Replace with separate loops to maximize Row-ordered MM performance
- (when (eq job-A :t)
- (rotatef rstp-A cstp-A))
- (when (eq job-B :t)
- (rotatef rstp-B cstp-B))
- ;;
- (unless (,(getf opt :f=) beta (,(getf opt :fid*)))
- (,(getf opt :num-scal) beta C))
- ;;
- (let-typed ((of-A hd-A :type index-type)
- (of-B hd-B :type index-type)
- ...
[truncated message content] |
|
From: Akshay S. <ak...@us...> - 2013-01-19 23:40: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 c8fdfac6f7cd8e4dd91f49bf7794a579cb8a5ffc (commit)
from fb2502032f279c0981185f2380ae3e4abf9d04a7 (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 c8fdfac6f7cd8e4dd91f49bf7794a579cb8a5ffc
Author: Akshay Srinivasan <aks...@gm...>
Date: Sat Jan 19 15:35:34 2013 -0800
o Committing some changes on dlsode. Callback macro is sort-of broken.
Callbacks apparently allocate some memory in a non-gc'ed portion heap.
Runs out of memory after ~600 calls to dlsode.
diff --git a/matlisp.asd b/matlisp.asd
index cbb1979..287657f 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -151,7 +151,7 @@
:components ((:file "gemv")))
(:module "matlisp-level-3"
:pathname "level-3"
- :depends-on ("matlisp-base" "matlisp-classes" "foreign-core" "matlisp-level-1")
+ :depends-on ("matlisp-base" "matlisp-classes" "foreign-core" "matlisp-level-1" "matlisp-level-2")
:components ((:file "gemm")))
#+nil(:module "matlisp-lapack"
:pathname "lapack"
diff --git a/packages.lisp b/packages.lisp
index 01f0df8..6e70c2a 100644
--- a/packages.lisp
+++ b/packages.lisp
@@ -75,6 +75,7 @@
#:linear-array-type
#:list-dimensions
#:lvec-foldl #:lvec-foldr #:lvec-max #:lvec-min #:lvec-eq
+ #:lvec-map-foldl! #:lvec-map-foldr!
#:lvec->list #:lvec->list!
#:compile-and-eval
;;Macros
diff --git a/src/level-3/gemm.lisp b/src/level-3/gemm.lisp
index f0b9523..32a879a 100644
--- a/src/level-3/gemm.lisp
+++ b/src/level-3/gemm.lisp
@@ -60,12 +60,15 @@
(cstp-C (col-stride C) :type index-type)
(hd-C (head C) :type index-type)
(sto-C (store C) :type ,(linear-array-type (getf opt :store-type))))
- ;;Replace with separate loops to maximize Row-ordered MM performance
+ ;;Replace with separate loops to maximize Row-ordered MM performance
(when (eq job-A :t)
(rotatef rstp-A cstp-A))
(when (eq job-B :t)
(rotatef rstp-B cstp-B))
;;
+ (unless (,(getf opt :f=) beta (,(getf opt :fid*)))
+ (,(getf opt :num-scal) beta C))
+ ;;
(let-typed ((of-A hd-A :type index-type)
(of-B hd-B :type index-type)
(of-C hd-C :type index-type)
diff --git a/src/packages/odepack/dlsode.lisp b/src/packages/odepack/dlsode.lisp
index 7728cd9..323c76e 100644
--- a/src/packages/odepack/dlsode.lisp
+++ b/src/packages/odepack/dlsode.lisp
@@ -9,7 +9,8 @@
(cffi:use-foreign-library libodepack)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-#+nil(def-fortran-routine testde :void
+#+nil
+(def-fortran-routine testde :void
(field (:callback :void
(c-neq :integer :input)
(c-t :double-float :input)
@@ -72,7 +73,7 @@
do (progn
(setq tout (aref t-array i))
(multiple-value-bind (y-out ts-out istate-out rwork-out iwork-out)
- (dlsode field neq y ts tout itol rtol atol itask istate iopt rwork lrw iwork liw (cffi:null-pointer) mf)
+ (dlsode field neq y ts tout itol rtol atol itask istate iopt rwork lrw iwork liw #'(lambda (&rest th) (declare (ignore th))) mf)
(setq ts ts-out)
(setq istate istate-out))
(funcall report ts y)))))
diff --git a/src/utilities/lvec.lisp b/src/utilities/lvec.lisp
index a46edf0..2891b36 100644
--- a/src/utilities/lvec.lisp
+++ b/src/utilities/lvec.lisp
@@ -14,6 +14,22 @@
:for ret = (aref vec (1- (length vec))) :then (funcall func (aref vec i) ret)
:finally (return ret)))
+(definline lvec-map-foldl! (func vec)
+ (declare (type vector))
+ (loop
+ :for i :of-type fixnum :from 0 :below (length vec)
+ :for ret = (aref vec 0) :then (funcall func (aref vec i) ret)
+ :do (setf (aref vec i) ret)
+ :finally (return (values ret vec))))
+
+(definline lvec-map-foldr! (func vec)
+ (declare (type vector))
+ (loop
+ :for i :of-type fixnum :downfrom (1- (length vec)) :to 0
+ :for ret = (aref vec (1- (length vec))) :then (funcall func (aref vec i) ret)
+ :do (setf (aref vec i) ret)
+ :finally (return (values ret vec))))
+
(definline lvec-max (vec)
(declare (type vector vec))
(loop :for ele :across vec
diff --git a/tests/loopy-tests.lisp b/tests/loopy-tests.lisp
index 29e4245..ece1513 100644
--- a/tests/loopy-tests.lisp
+++ b/tests/loopy-tests.lisp
@@ -152,31 +152,38 @@
(defun test-mm-lisp-lin (n)
(declare (type fixnum n))
- (let*-typed ((A (make-real-tensor n n))
- (B (make-real-tensor n n))
- (C (make-real-tensor n n))
- (sto-A (store A) :type real-store-vector)
- (sto-B (store B) :type real-store-vector)
- (sto-C (store C) :type real-store-vector))
- (time
- (let-typed ((of-A 0 :type index-type)
- (of-B 0 :type index-type)
- (of-C 0 :type index-type))
+ (let ((A (make-real-tensor n n))
+ (B (make-real-tensor n n))
+ (C (make-real-tensor n n)))
+ (let*-typed ((sto-A (store A) :type real-store-vector)
+ (sto-B (store B) :type real-store-vector)
+ (sto-C (store C) :type real-store-vector))
(very-quickly
- (loop :repeat n
- :do (progn
- (loop :repeat n
- :do (let-typed ((ele-A (aref sto-A of-A) :type real-type))
- (loop :repeat n
- :do (progn
- (incf (aref sto-C of-C) (* ele-A (aref sto-B of-B)))
- (incf of-C)
- (incf of-B)))
- (decf of-C n)
- (incf of-A)))
- (incf of-C n)
- (setf of-B 0))))))
- t))
+ (mod-dotimes (idx (dimensions A))
+ with (linear-sums (of-A (strides A))
+ (of-B (strides B)))
+ do (progn
+ (real-type.value-writer (random 1d0) sto-A of-A)
+ (real-type.value-writer (random 1d0) sto-B of-B))))
+ (time
+ (let-typed ((of-A 0 :type index-type)
+ (of-B 0 :type index-type)
+ (of-C 0 :type index-type))
+ (very-quickly
+ (loop :repeat n
+ :do (progn
+ (loop :repeat n
+ :do (let-typed ((ele-A (aref sto-A of-A) :type real-type))
+ (loop :repeat n
+ :do (progn
+ (incf (aref sto-C of-C) (* ele-A (aref sto-B of-B)))
+ (incf of-C)
+ (incf of-B)))
+ (decf of-C n)
+ (incf of-A)))
+ (incf of-C n)
+ (setf of-B 0))))))
+ t)))
(defun test-mm-ddot (n)
(let ((t-a (make-real-tensor n n))
-----------------------------------------------------------------------
Summary of changes:
matlisp.asd | 2 +-
packages.lisp | 1 +
src/level-3/gemm.lisp | 5 +++-
src/packages/odepack/dlsode.lisp | 5 ++-
src/utilities/lvec.lisp | 16 +++++++++++
tests/loopy-tests.lisp | 55 +++++++++++++++++++++----------------
6 files changed, 56 insertions(+), 28 deletions(-)
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2013-01-07 02:46:43
|
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 a5e3a50f5fbe85eb2b44d11ff2a6ba385011e979 (commit)
from 32fd23120cff0e68ba1b02290f19e0dd48185944 (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 a5e3a50f5fbe85eb2b44d11ff2a6ba385011e979
Author: Akshay Srinivasan <aks...@gm...>
Date: Sun Jan 6 18:33:15 2013 -0800
o Changed loop order in the lisp GEMM function generator, to work
better on row-ordered matrices. About twice as fast as the old one
(for row ordered matrices).
o Added new tests to loopy-tests.lisp ; (test-mm-lisp-lin <n>) is
now as fast as the reference F77 BLAS implementation (!). Still too
slow compared to ATLAS & GOTOBlas (not surprisingly). Might have
to add different loops for different ordering, in the GEMM generator
macro.
diff --git a/configure.ac b/configure.ac
index d2ec52f..6b0aeba 100644
--- a/configure.ac
+++ b/configure.ac
@@ -376,7 +376,7 @@ int main()
EOF
$CC $CFLAGS -c conftest.c
$F77 $FFLAGS -o a.out conftest.o -L${BLAS_LAPACK_DIR} -lblas -llapack
- if a.out; then
+ if ./a.out; then
AC_MSG_RESULT([yes])
F2C=-ff2c
else
diff --git a/src/base/blas-helpers.lisp b/src/base/blas-helpers.lisp
index 0092bf9..f9ad967 100644
--- a/src/base/blas-helpers.lisp
+++ b/src/base/blas-helpers.lisp
@@ -41,9 +41,10 @@
(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))
+ (let*-typed ((stds (strides matrix) :type index-store-vector)
+ (rs (aref stds 0) :type index-type)
+ (cs (aref stds 1) :type index-type))
+ ;;Note that it is not required that (rs = nc * cs) or (cs = nr * rs)
(cond
((= cs 1) (values :row-major rs (fortran-nop op)))
((= rs 1) (values :col-major cs (fortran-op op)))
@@ -68,3 +69,9 @@
(defun combine-jobs (&rest jobs)
(let ((job (intern (apply #'concatenate 'string (mapcar #'symbol-name jobs)) "KEYWORD")))
job))
+
+(definline flip-major (job)
+ (declare (type symbol job))
+ (case job
+ (:row-major :col-major)
+ (:col-major :row-major)))
diff --git a/src/base/standard-tensor.lisp b/src/base/standard-tensor.lisp
index 1c0397d..2f6a153 100644
--- a/src/base/standard-tensor.lisp
+++ b/src/base/standard-tensor.lisp
@@ -134,6 +134,8 @@
:f/ (a b) -> a * b^{-1}
:finv* (a) -> 1/a
:fid* () -> * identity
+ :f= (a b) -> (= a b)
+ :fconj (a) -> a^* {if nil, Field does not have a conjugation op}
:coercer (ele) -> Coerced to store-type, with error checking
:coercer-unforgiving (ele) -> Coerced to store-type, no error checking
@@ -340,11 +342,11 @@
(defmacro define-tensor
((tensor-class element-type store-element-type store-type &rest class-decls) &key
- f+ f- finv+ fid+ f* f/ finv* fid* fconj
+ f+ f- finv+ fid+ f* f/ finv* fid* fconj f=
matrix vector
store-allocator coercer coercer-unforgiving reader value-writer reader-writer swapper)
;;Error checking
- (assert (and f+ f- finv+ fid+ f* f/ finv* fid* store-allocator coercer coercer-unforgiving matrix vector reader value-writer reader-writer swapper))
+ (assert (and f+ f- finv+ fid+ f* f/ finv* fid* f= store-allocator coercer coercer-unforgiving matrix vector reader value-writer reader-writer swapper))
;;
`(progn
;;Class definitions
@@ -379,6 +381,7 @@
:f/ ',f/
:finv* ',finv*
:fid* ',fid*
+ :f= ',f=
:fconj ',fconj
:reader ',reader
:value-writer ',value-writer
diff --git a/src/classes/complex-tensor.lisp b/src/classes/complex-tensor.lisp
index 73e624a..d2d8c04 100644
--- a/src/classes/complex-tensor.lisp
+++ b/src/classes/complex-tensor.lisp
@@ -48,6 +48,10 @@
(declare (type complex-type a))
(conjugate a))
+(definline complex-type.f= (a b)
+ (declare (type complex-type a b))
+ (= a b))
+
;;Store operations
(definline allocate-complex-store (size)
"
@@ -110,7 +114,8 @@
:f/ complex-type.f/
:finv* complex-type.finv*
:fid* complex-type.fid*
- :fconj complex-type.fconj
+ :f= complex-type.f=
+ :fconj complex-type.fconj
;;
:store-allocator allocate-complex-store
:coercer coerce-complex
diff --git a/src/classes/real-tensor.lisp b/src/classes/real-tensor.lisp
index 44239aa..aa9f293 100644
--- a/src/classes/real-tensor.lisp
+++ b/src/classes/real-tensor.lisp
@@ -39,6 +39,10 @@
(definline real-type.fid* ()
1.0d0)
+(definline real-type.fid= (a b)
+ (declare (type real-type a b))
+ (= a b))
+
;;Store definitions
(definline real-type.reader (tstore idx)
(declare (type index-type idx)
@@ -86,6 +90,7 @@ Allocates real storage. Default initial-element = 0d0.")
:f/ real-type.f/
:finv* real-type.finv*
:fid* real-type.fid*
+ :f= real-type.fid=
:fconj nil
;;
:store-allocator allocate-real-store
diff --git a/src/classes/symbolic-tensor.lisp b/src/classes/symbolic-tensor.lisp
index be7986c..e77f692 100644
--- a/src/classes/symbolic-tensor.lisp
+++ b/src/classes/symbolic-tensor.lisp
@@ -39,6 +39,10 @@
(definline symbolic-type.fid* ()
1)
+(definline symbolic-type.f= (a b)
+ (declare (type symbolic-type a b))
+ (maxima::equal a b))
+
(definline symbolic-type.fconj (a)
(maxima::meval `((maxima::$conjugate maxima::simp) ,a)))
@@ -97,6 +101,7 @@ Allocates symbolic storage. Default initial-element = 0.")
:f/ symbolic-type.f/
:finv* symbolic-type.finv*
:fid* symbolic-type.fid*
+ :f= symbolic-type.f=
:fconj symbolic-type.fconj
;;
:store-allocator allocate-symbolic-store
diff --git a/src/level-1/scal.lisp b/src/level-1/scal.lisp
index 517167c..6817cf8 100644
--- a/src/level-1/scal.lisp
+++ b/src/level-1/scal.lisp
@@ -195,16 +195,16 @@
#+maxima
(progn
(generate-typed-num-scal! symbolic-typed-num-scal!
- (real-tensor nil 0))
+ (symbolic-tensor nil 0))
(generate-typed-scal! symbolic-typed-scal!
- (real-tensor nil 0))
+ (symbolic-tensor nil 0))
(generate-typed-div! symbolic-typed-div!
- (real-tensor nil 0))
+ (symbolic-tensor nil 0))
(generate-typed-num-div! symbolic-typed-num-div!
- (real-tensor nil 0)))
+ (symbolic-tensor nil 0)))
;;---------------------------------------------------------------;;
(defgeneric scal! (alpha x)
diff --git a/src/level-3/gemm.lisp b/src/level-3/gemm.lisp
index 22b445b..172be3d 100644
--- a/src/level-3/gemm.lisp
+++ b/src/level-3/gemm.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
@@ -39,6 +39,7 @@
(declare (type ,(getf opt :element-type) alpha beta)
(type ,matrix-class A B C)
(type symbol job))
+ ;;The big done-in-lisp-gemm, loop-ordering was inspired by the BLAS dgemm reference implementation.
,(let
((lisp-routine
`(let-typed ((nr-C (nrows C) :type index-type)
@@ -59,39 +60,51 @@
(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
- (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 (,(getf opt :f*) beta (,(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)
- :with sum :of-type ,(getf opt :element-type) := (,(getf opt :fid+))
- :do (let-typed ((A-val (,(getf opt :reader) sto-A of-A) :type ,(getf opt :element-type))
- (B-val (,(getf opt :reader) sto-B of-B) :type ,(getf opt :element-type)))
- (setf sum (,(getf opt :f+) sum (,(getf opt :f*) A-val B-val))))
- :finally (,(getf opt :value-writer) (,(getf opt :f+) (,(getf opt :f*) alpha sum) val) sto-C of-C)))))))))
- `(mlet* ,(recursive-append
- '(((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)))
- (when blas?
- `((call-fortran? (> (max (nrows C) (ncols C) (if (eq job-A :n) (ncols A) (nrows A)))
- ,fortran-lb-parameter))
- ((maj-A ld-A fop-A) (if call-fortran? (blas-matrix-compatible-p A job-A) (values nil 0 "?")) :type (symbol index-type (string 1)))
- ((maj-B ld-B fop-B) (if call-fortran? (blas-matrix-compatible-p B job-B) (values nil 0 "?")) :type (symbol index-type (string 1)))
- ((maj-C ld-C fop-C) (if call-fortran? (blas-matrix-compatible-p C :n) (values nil 0 "?")) :type (symbol index-type nil)))))
+ ;;Replace with separate loops to maximize Row-ordered MM performance
+ (when (eq job-A :t)
+ (rotatef rstp-A cstp-A))
+ (when (eq job-B :t)
+ (rotatef rstp-B cstp-B))
+ ;;
+ (let-typed ((of-A hd-A :type index-type)
+ (of-B hd-B :type index-type)
+ (of-C hd-C :type index-type)
+ (r.cstp-C (* cstp-C nc-C) :type index-type)
+ (d.rstp-B (- rstp-B (* cstp-B nc-C)) :type index-type)
+ (d.rstp-A (- rstp-A (* cstp-A dotl)) :type index-type))
+ (very-quickly
+ (loop :repeat nr-C
+ :do (progn
+ (loop :repeat dotl
+ :do (let-typed ((ele-A (,(getf opt :f*) alpha (,(getf opt :reader) sto-A of-A)) :type ,(getf opt :element-type)))
+ (loop :repeat nc-C
+ :do (progn
+ (,(getf opt :value-writer)
+ (,(getf opt :f+)
+ (,(getf opt :reader) sto-C of-C)
+ (,(getf opt :f*) ele-A (,(getf opt :reader) sto-B of-B)))
+ sto-C of-C)
+ (incf of-C cstp-C)
+ (incf of-B cstp-B)))
+ (decf of-C r.cstp-C)
+ (incf of-A cstp-A)
+ (incf of-B d.rstp-B)))
+ (incf of-C rstp-C)
+ (incf of-A d.rstp-A)
+ (setf of-B hd-B))))))))
+ ;;Tie together Fortran and lisp-routines.
+ `(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))
+ ,@(when blas?
+ `((call-fortran? (> (max (nrows C) (ncols C) (if (eq job-A :n) (ncols A) (nrows A)))
+ ,fortran-lb-parameter))
+ ((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 blas?
`(cond
((and call-fortran? maj-A maj-B maj-C)
@@ -164,7 +177,6 @@
,lisp-routine))
lisp-routine)))
C)))
-
;;Real
(generate-typed-gemm! real-base-typed-gemm!
(real-tensor dgemm dgemv *real-l3-fcall-lb*))
@@ -191,11 +203,15 @@
(let ((A (ecase job-A
((:n :t) A)
((:h :c)
+ ;;BUG!
+ ;;Multiplication does not yield the complex conjugate!
(let ((ret (apply #'make-complex-tensor (lvec->list (dimensions A)))))
(complex-typed-axpy! #c(-1d0 0d0) A ret)))))
(B (ecase job-B
((:n :t) B)
((:h :c)
+ ;;BUG!
+ ;;Multiplication does not yield the complex conjugate!
(let ((ret (apply #'make-complex-tensor (lvec->list (dimensions B)))))
(complex-typed-axpy! #c(-1d0 0d0) B ret)))))
(tjob (combine-jobs (ecase job-A ((:n :t) job-A) (:h :t) (:c :n))
@@ -206,7 +222,7 @@
;;Symbolic
#+maxima
(generate-typed-gemm! symbolic-base-typed-gemm!
- (symbolic-tensor nil nil 0))
+ (symbolic-tensor nil nil 0))
;;---------------------------------------------------------------;;
@@ -220,10 +236,10 @@
Purpose
=======
Performs the GEneral Matrix Multiplication given by
- -- - -
+ -- - -
+
+ C <- alpha * op(A) * op(B) + beta * C
- C <- alpha * op(A) * op(B) + beta * C
-
and returns C.
alpha,beta are scalars and A,B,C are matrices.
@@ -288,7 +304,7 @@
(real-typed-gemm! (coerce-real 1) A B (coerce-real 0) A.x job)
;;Re
(axpy! (realpart alpha) A.x vw.c)
- ;;Im
+ ;;Im
(incf (head vw.c))
(axpy! (imagpart alpha) A.x vw.c))
(let ((vw.c (tensor-realpart~ c)))
@@ -323,10 +339,10 @@
Purpose
=======
Performs the GEneral Matrix Multiplication given by
- -- - -
+ -- - -
+
+ alpha * op(A) * op(B) + beta * C
- alpha * op(A) * op(B) + beta * C
-
and returns the result in a new matrix.
alpha,beta are scalars and A,B,C are matrices.
diff --git a/tests/loopy-tests.lisp b/tests/loopy-tests.lisp
index 67db2be..9dee685 100644
--- a/tests/loopy-tests.lisp
+++ b/tests/loopy-tests.lisp
@@ -102,6 +102,82 @@
(values t-a t-b t-c))))
+(defun test-mm-lisp (n)
+ (declare (type fixnum n))
+ (let ((A (make-real-tensor n n))
+ (B (make-real-tensor n n))
+ (C (make-real-tensor n n)))
+ (let-typed ((nr-C (nrows C) :type index-type)
+ (nc-C (ncols C) :type index-type)
+ (dotl (ncols 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 real-store-vector)
+ ;
+ (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 real-store-vector)
+ ;
+ (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 real-store-vector))
+ (time
+ (let-typed ((of-A hd-A :type index-type)
+ (of-B hd-B :type index-type)
+ (of-C hd-C :type index-type)
+ (r.cstp-C (* cstp-C nc-C) :type index-type)
+ (d.rstp-B (- rstp-B (* cstp-B nc-C)) :type index-type)
+ (d.rstp-A (- rstp-A (* cstp-A dotl)) :type index-type))
+ (very-quickly
+ (loop :repeat nr-C
+ :do (progn
+ (loop :repeat dotl
+ :do (let-typed ((ele-A (aref sto-A of-A) :type real-type))
+ (loop :repeat nc-C
+ :do (progn
+ (incf (aref sto-C of-C) (* ele-A (aref sto-B of-B)))
+ (incf of-C cstp-C)
+ (incf of-B cstp-B)))
+ (decf of-C r.cstp-C)
+ (incf of-A cstp-A)
+ (incf of-B d.rstp-B)))
+ (incf of-C rstp-C)
+ (incf of-A d.rstp-A)
+ (setf of-B hd-B))))))
+ t)))
+
+(defun test-mm-lisp-lin (n)
+ (declare (type fixnum n))
+ (let ((A (make-real-tensor n n))
+ (B (make-real-tensor n n))
+ (C (make-real-tensor n n)))
+ (let*-typed ((sto-A (store A) :type real-store-vector)
+ (sto-B (store B) :type real-store-vector)
+ (sto-C (store C) :type real-store-vector))
+ (time
+ (let-typed ((of-A 0 :type index-type)
+ (of-B 0 :type index-type)
+ (of-C 0 :type index-type))
+ (very-quickly
+ (loop :repeat n
+ :do (progn
+ (loop :repeat n
+ :do (let-typed ((ele-A (aref sto-A of-A) :type real-type))
+ (loop :repeat n
+ :do (progn
+ (incf (aref sto-C of-C) (* ele-A (aref sto-B of-B)))
+ (incf of-C)
+ (incf of-B)))
+ (decf of-C n)
+ (incf of-A)))
+ (incf of-C n)
+ (setf of-B 0))))))
+ t)))
+
(defun test-mm-ddot (n)
(let ((t-a (make-real-tensor n n))
(t-b (make-real-tensor n n))
-----------------------------------------------------------------------
Summary of changes:
configure.ac | 2 +-
src/base/blas-helpers.lisp | 13 ++++-
src/base/standard-tensor.lisp | 7 ++-
src/classes/complex-tensor.lisp | 7 ++-
src/classes/real-tensor.lisp | 5 ++
src/classes/symbolic-tensor.lisp | 5 ++
src/level-1/scal.lisp | 8 ++--
src/level-3/gemm.lisp | 106 ++++++++++++++++++++++----------------
tests/loopy-tests.lisp | 76 +++++++++++++++++++++++++++
9 files changed, 173 insertions(+), 56 deletions(-)
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2013-01-05 19:20: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 32fd23120cff0e68ba1b02290f19e0dd48185944 (commit)
via 2595c1c4e1a710d38b0c56c83921206d2473e8ae (commit)
from e916823ab6bd97795ad7eaea63ad778a423b0919 (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 32fd23120cff0e68ba1b02290f19e0dd48185944
Author: Akshay Srinivasan <aks...@gm...>
Date: Sat Jan 5 11:14:54 2013 -0800
GETRF wrapper function works.
diff --git a/packages.lisp b/packages.lisp
index 276480c..f46d776 100644
--- a/packages.lisp
+++ b/packages.lisp
@@ -76,6 +76,7 @@
#:list-dimensions
#:lvec-foldl #:lvec-foldr #:lvec-max #:lvec-min #:lvec-eq
#:lvec->list #:lvec->list!
+ #:compile-and-eval
;;Macros
#:when-let #:if-let #:if-ret #:with-gensyms #:let-rec
#:mlet* #:make-array-allocator #:let-typed #:let*-typed
diff --git a/src/base/standard-tensor.lisp b/src/base/standard-tensor.lisp
index 8f08284..1c0397d 100644
--- a/src/base/standard-tensor.lisp
+++ b/src/base/standard-tensor.lisp
@@ -167,7 +167,7 @@
(let ((opt (if (symbolp value)
(get-tensor-class-optimization-hashtable clname)
value)))
- (setf (symbol-plist clname) opt
+ (setf (symbol-plist (getf opt :tensor)) opt
(symbol-plist (getf opt :matrix)) opt
(symbol-plist (getf opt :vector)) opt)))
diff --git a/src/lapack/getrf.lisp b/src/lapack/getrf.lisp
index f28098e..7e5f0eb 100644
--- a/src/lapack/getrf.lisp
+++ b/src/lapack/getrf.lisp
@@ -25,46 +25,51 @@
;;; ENHANCEMENTS, OR MODIFICATIONS.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(in-package #:matlisp)
-(in-package #:matlisp)
-
-(defmacro generate-typed-getrf! (func-name (matrix-class lapack-func))
- (let* ((opt (get-tensor-class-optimization matrix-class)))
- (assert opt nil 'tensor-cannot-find-optimization :tensor-class matrix-class)
+(defmacro generate-typed-getrf! (func-name (tensor-class lapack-func))
+ (let* ((opt (if-ret (get-tensor-class-optimization-hashtable tensor-class)
+ (error 'tensor-cannot-find-optimization :tensor-class tensor-class)))
+ (matrix-class (getf opt :matrix)))
`(defun ,func-name (A ipiv)
(declare (type ,matrix-class A)
(type permutation-pivot-flip ipiv))
(mlet* (((maj-A ld-A fop-A) (blas-matrix-compatible-p A :n) :type (symbol index-type nil)))
- (assert maj-A nil 'tensor-store-not-consecutive)
- (multiple-value-bind (new-A new-ipiv info)
- (,lapack-func
- (nrows A) (ncols A) (store A)
- ld-A (repr ipiv) 0)
- (declare (ignore new-A new-ipiv))
- ;;Convert from 1-based indexing to 0-based indexing, and fix
- ;;other Fortran-ic quirks
- (assert (= info 0) nil 'invalid-arguments :argnum (1- (- info)) :message (format-to-string "GETRF returned INFO: ~a." info))
- (let-typed ((pidv (repr ipiv) :type perrepr-vector))
- (very-quickly
- (loop for i from 0 below (length pidv)
- do (decf (aref pidv i)))))
- (if (eq maj-A :row-major)
- ;;Crout's decomposition
- (values A (list :decomposition-type :|U_ii=1| :column-permutation ipiv))
- ;;Dolittle's decomposition
- (values A (list :decomposition-type :|L_ii=1| :row-permutation ipiv))))))))
-
-(generate-typed-getrf! real-typed-getrf! (real-matrix dgetrf))
-(generate-typed-getrf! complex-typed-getrf! (complex-matrix zgetrf))
-
-#+nil
-(let ((A (make-real-tensor '((1 2)
- (3 4))))
- (idiv (make-pidx (perv 0 1))))
- (real-typed-getrf! A idiv))
-
-
-(defgeneric getrf! (A ipiv)
+ (if (not (eq maj-A :col-major))
+ (let*-typed ((dims (dimensions A) :type index-store-vector)
+ ;;Column major
+ (stds (let*-typed ((rank (rank A) :type fixnum)
+ (stds (allocate-index-store rank) :type index-store-vector))
+ (very-quickly
+ (loop
+ :for i :from 0 :below rank
+ :and st = 1 :then (the index-type (* st (aref dims i)))
+ :do (setf (aref stds i) st)))
+ stds)
+ :type index-store-vector)
+ (tmp (,(get tensor-class :copy) A (make-instance (class-of A) :dimensions dims :strides stds :store (,(get tensor-class :store-allocator) (lvec-foldr #'* dims))))))
+ (mlet* (((maj-tmp ld-tmp fop-tmp) (blas-matrix-compatible-p tmp :n) :type (nil index-type nil))
+ ((new-tmp new-ipiv info) (,lapack-func
+ (nrows tmp) (ncols tmp) (store tmp)
+ ld-tmp (repr ipiv) 0) :type (nil nil integer)))
+ (assert (= info 0) nil 'invalid-arguments :argnum (1- (- info)) :message (format-to-string "GETRF returned INFO: ~a." info))
+ (,(get tensor-class :copy) tmp A)))
+ (mlet* (((new-A new-ipiv info) (,lapack-func
+ (nrows A) (ncols A) (store A)
+ ld-A (repr ipiv) 0) :type (nil nil integer)))
+ (assert (= info 0) nil 'invalid-arguments :argnum (1- (- info)) :message (format-to-string "GETRF returned INFO: ~a." info))))
+ ;;Convert from 1-based indexing to 0-based indexing, and fix
+ ;;other Fortran-ic quirks
+ (let-typed ((pidv (repr ipiv) :type perrepr-vector))
+ (very-quickly
+ (loop for i from 0 below (length pidv)
+ do (decf (aref pidv i)))))
+ (values A ipiv)))))
+
+(generate-typed-getrf! real-typed-getrf! (real-tensor dgetrf))
+(generate-typed-getrf! complex-typed-getrf! (complex-tensor zgetrf))
+
+(defgeneric getrf! (A)
(:documentation
"
Syntax
@@ -92,9 +97,9 @@
IPIV is filled with the pivot indices that define the permutation
matrix P:
-
+
row i of the matrix was interchanged with row IPIV(i).
-
+
If IPIV is not provided, it is allocated by GESV.
Return Values
diff --git a/src/level-1/dot.lisp b/src/level-1/dot.lisp
index d945d7b..6301a0c 100644
--- a/src/level-1/dot.lisp
+++ b/src/level-1/dot.lisp
@@ -165,3 +165,34 @@
(defmethod dot ((x complex-vector) (y complex-vector) &optional (conjugate-p t))
(complex-typed-dot x y conjugate-p))
+
+#+nil
+(defmethod dot ((x standard-vector) (y standard-vector) &optional (conjugate-p t))
+ (let ((xcl (class-of x))
+ (ycl (class-of y)))
+ (unless (and (eq xcl (find-class (get (class-name xcl) :vector)))
+ (eq ycl (find-class (get (class-name ycl) :vector))))
+ (error "Arguments are not vectors!"))
+ (cond
+ ((eq (class-of x) (class-of y))
+ ;;Generate method
+ (let* ((classn (get (class-name xcl) :vector))
+ (dot-func (if-ret (get classn :dot)
+ (let ((dot-name (gensym (string+ (symbol-name classn) "-dot-"))))
+ (compile-and-eval
+ `(generate-typed-dot ,dot-name
+ (,classn nil nil 0)))
+ dot-name))))
+ (compile-and-eval
+ `(defmethod dot ((x ,classn) (y ,classn) &optional (conjugate-p t))
+ ,@(unless (get classn :fconj)
+ `((declare (ignore conjugate-p))))
+ ,(if (get classn :fconj)
+ `(,dot-func x y conjugate-p)
+ `(,dot-func x y t))))
+ ;;Call method
+ (dot x y conjugate-p)))
+ ((coercable? (class-name xcl) (class-name ycl))
+ ...)
+ ((coercable? (class-name xcl) (class-name ycl))
+ ...))))
diff --git a/src/level-1/tensor-maker.lisp b/src/level-1/tensor-maker.lisp
index eda04c5..cd2dd14 100644
--- a/src/level-1/tensor-maker.lisp
+++ b/src/level-1/tensor-maker.lisp
@@ -51,6 +51,7 @@
(make-tensor-maker make-real-tensor (real-tensor))
(make-tensor-maker make-complex-tensor (complex-tensor))
+
#+maxima
(make-tensor-maker make-symbolic-tensor (symbolic-tensor))
diff --git a/src/utilities/functions.lisp b/src/utilities/functions.lisp
index fb9d9fa..c0570e8 100644
--- a/src/utilities/functions.lisp
+++ b/src/utilities/functions.lisp
@@ -217,3 +217,10 @@
(lst-tread (cons 0 idx) (car lst))
(reverse idx))))))
(lst-tread (list 0) lst)))
+
+(defun compile-and-eval (source)
+ "
+ Compiles and evaluates the given @arg{source}. This should be
+ an ANSI compatible way of ensuring method compilation."
+ (funcall (compile nil `(lambda () ,source))))
+
commit 2595c1c4e1a710d38b0c56c83921206d2473e8ae
Author: Akshay Srinivasan <aks...@gm...>
Date: Fri Dec 28 11:43:27 2012 -0600
o Now the generation macros push BLAS function names into the tensor
class optimization plist.
diff --git a/src/base/standard-tensor.lisp b/src/base/standard-tensor.lisp
index a0bbef8..8f08284 100644
--- a/src/base/standard-tensor.lisp
+++ b/src/base/standard-tensor.lisp
@@ -163,10 +163,13 @@
(t (values opt clname)))))
(defun (setf get-tensor-class-optimization) (value clname)
- (setf (gethash clname *tensor-class-optimizations*) value
- (symbol-plist clname) (if (symbolp value)
- (get-tensor-class-optimization-hashtable clname)
- value)))
+ (setf (gethash clname *tensor-class-optimizations*) value)
+ (let ((opt (if (symbolp value)
+ (get-tensor-class-optimization-hashtable clname)
+ value)))
+ (setf (symbol-plist clname) opt
+ (symbol-plist (getf opt :matrix)) opt
+ (symbol-plist (getf opt :vector)) opt)))
;; Akshay: I have no idea what this does, or why we want it
;; (inherited from standard-matrix.lisp
diff --git a/src/level-1/axpy.lisp b/src/level-1/axpy.lisp
index 6fc9eb5..ee75e32 100644
--- a/src/level-1/axpy.lisp
+++ b/src/level-1/axpy.lisp
@@ -34,6 +34,8 @@
;;Use only after checking the arguments for compatibility.
(let* ((opt (get-tensor-class-optimization-hashtable tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
+ (setf (getf opt :axpy) func
+ (get-tensor-class-optimization tensor-class) opt)
`(definline ,func (alpha from to)
(declare (type ,tensor-class from to)
(type ,(getf opt :element-type) alpha))
@@ -78,6 +80,8 @@
;;Use only after checking the arguments for compatibility.
(let* ((opt (get-tensor-class-optimization tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
+ (setf (getf opt :num-axpy) func
+ (get-tensor-class-optimization tensor-class) opt)
`(definline ,func (num-from to)
(declare (type ,tensor-class to)
(type ,(getf opt :element-type) num-from))
diff --git a/src/level-1/copy.lisp b/src/level-1/copy.lisp
index 9a42abf..75a72c1 100644
--- a/src/level-1/copy.lisp
+++ b/src/level-1/copy.lisp
@@ -34,6 +34,8 @@
;;Use only after checking the arguments for compatibility.
(let* ((opt (get-tensor-class-optimization-hashtable tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
+ (setf (getf opt :copy) func
+ (get-tensor-class-optimization tensor-class) opt)
`(definline ,func (from to)
(declare (type ,tensor-class from to))
,(let
@@ -71,6 +73,8 @@
;;Use only after checking the arguments for compatibility.
(let* ((opt (get-tensor-class-optimization-hashtable tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
+ (setf (getf opt :num-copy) func
+ (get-tensor-class-optimization tensor-class) opt)
`(definline ,func (num-from to)
(declare (type ,tensor-class to)
(type ,(getf opt :element-type) num-from))
diff --git a/src/level-1/dot.lisp b/src/level-1/dot.lisp
index 7302d70..d945d7b 100644
--- a/src/level-1/dot.lisp
+++ b/src/level-1/dot.lisp
@@ -32,6 +32,8 @@
(conj? (getf opt :fconj))
(blas? (and blas-func (if conj? blasc-func t))))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
+ (setf (getf opt :dot) func
+ (get-tensor-class-optimization tensor-class) opt)
`(definline ,func (x y conjugate-p)
(declare (type ,tensor-class x y)
,(if conj?
diff --git a/src/level-1/scal.lisp b/src/level-1/scal.lisp
index 472a186..517167c 100644
--- a/src/level-1/scal.lisp
+++ b/src/level-1/scal.lisp
@@ -31,6 +31,8 @@
(defmacro generate-typed-scal! (func (tensor-class fortran-func fortran-lb))
(let* ((opt (get-tensor-class-optimization-hashtable tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
+ (setf (getf opt :scal) func
+ (get-tensor-class-optimization tensor-class) opt)
`(definline ,func (from to)
(declare (type ,tensor-class from to))
,(let
@@ -64,6 +66,8 @@
(defmacro generate-typed-num-scal! (func (tensor-class blas-func fortran-lb))
(let ((opt (get-tensor-class-optimization-hashtable tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
+ (setf (getf opt :num-scal) func
+ (get-tensor-class-optimization tensor-class) opt)
`(definline ,func (alpha to)
(declare (type ,tensor-class to)
(type ,(getf opt :element-type) alpha))
@@ -91,6 +95,8 @@
(defmacro generate-typed-div! (func (tensor-class fortran-func fortran-lb))
(let* ((opt (get-tensor-class-optimization-hashtable tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
+ (setf (getf opt :div) func
+ (get-tensor-class-optimization tensor-class) opt)
`(definline ,func (from to)
(declare (type ,tensor-class from to))
,(let
@@ -124,6 +130,8 @@
(defmacro generate-typed-num-div! (func (tensor-class fortran-func fortran-lb))
(let ((opt (get-tensor-class-optimization tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
+ (setf (getf opt :num-div) func
+ (get-tensor-class-optimization tensor-class) opt)
`(definline ,func (alpha to)
(declare (type ,tensor-class to)
(type ,(getf opt :element-type) alpha))
diff --git a/src/level-1/swap.lisp b/src/level-1/swap.lisp
index 6df8506..4c7650e 100644
--- a/src/level-1/swap.lisp
+++ b/src/level-1/swap.lisp
@@ -34,6 +34,8 @@
;;Use only after checking the arguments for compatibility.
(let* ((opt (get-tensor-class-optimization-hashtable tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
+ (setf (getf opt :swap) func
+ (get-tensor-class-optimization tensor-class) opt)
`(definline ,func (x y)
(declare (type ,tensor-class x y))
,(let
diff --git a/src/level-1/tensor-maker.lisp b/src/level-1/tensor-maker.lisp
index ba233ae..eda04c5 100644
--- a/src/level-1/tensor-maker.lisp
+++ b/src/level-1/tensor-maker.lisp
@@ -3,6 +3,8 @@
(defmacro make-tensor-maker (func-name (tensor-class))
(let ((opt (get-tensor-class-optimization-hashtable tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
+ (setf (getf opt :maker) func-name
+ (get-tensor-class-optimization tensor-class) opt)
`(progn
(declaim (ftype (function (&rest t) ,tensor-class) ,func-name))
(defun ,func-name (&rest args)
diff --git a/src/level-2/gemv.lisp b/src/level-2/gemv.lisp
index 2dba31a..8ef7481 100644
--- a/src/level-2/gemv.lisp
+++ b/src/level-2/gemv.lisp
@@ -10,6 +10,8 @@
(error 'tensor-cannot-find-optimization :tensor-class tensor-class)))
(matrix-class (getf opt :matrix))
(vector-class (getf opt :vector)))
+ (setf (getf opt :gemv) func
+ (get-tensor-class-optimization tensor-class) opt)
`(definline ,func (alpha A x beta y job)
(declare (type ,(getf opt :element-type) alpha beta)
(type ,matrix-class A)
diff --git a/src/level-3/gemm.lisp b/src/level-3/gemm.lisp
index ecf1756..22b445b 100644
--- a/src/level-3/gemm.lisp
+++ b/src/level-3/gemm.lisp
@@ -33,6 +33,8 @@
(error 'tensor-cannot-find-optimization :tensor-class tensor-class)))
(matrix-class (getf opt :matrix))
(blas? (and blas-gemm-func blas-gemv-func)))
+ (setf (getf opt :gemm) func
+ (get-tensor-class-optimization tensor-class) opt)
`(definline ,func (alpha A B beta C job)
(declare (type ,(getf opt :element-type) alpha beta)
(type ,matrix-class A B C)
-----------------------------------------------------------------------
Summary of changes:
packages.lisp | 1 +
src/base/standard-tensor.lisp | 11 ++++--
src/lapack/getrf.lisp | 75 ++++++++++++++++++++++-------------------
src/level-1/axpy.lisp | 4 ++
src/level-1/copy.lisp | 4 ++
src/level-1/dot.lisp | 33 ++++++++++++++++++
src/level-1/scal.lisp | 8 ++++
src/level-1/swap.lisp | 2 +
src/level-1/tensor-maker.lisp | 3 ++
src/level-2/gemv.lisp | 2 +
src/level-3/gemm.lisp | 2 +
src/utilities/functions.lisp | 7 ++++
12 files changed, 113 insertions(+), 39 deletions(-)
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2012-12-28 16:47:27
|
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 e916823ab6bd97795ad7eaea63ad778a423b0919 (commit)
via 856c60140465482aaa72f021360c4c795073ad6f (commit)
via 0166ce8014b662aca4a91484eb2458e7e87be8ac (commit)
via 1c74913ff22ddc869220e6ee124bcf272b188d12 (commit)
via 376399e23fbbb868c8eb3ef80ee8bc9c65c5d98e (commit)
via ff3082257b6f984b30131dd170f011eacd78f7e6 (commit)
from c0ba7e46b390f6e744e6865192b6eb57eb95c585 (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 e916823ab6bd97795ad7eaea63ad778a423b0919
Author: Akshay Srinivasan <aks...@gm...>
Date: Fri Dec 28 10:41:02 2012 -0600
o Ported GEMM. Should get to work on automatic method generation.
diff --git a/matlisp.asd b/matlisp.asd
index 17f0086..cbb1979 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -145,12 +145,10 @@
:depends-on ("copy" "scal"))
(:file "trans"
:depends-on ("scal" "copy"))))
- #+nil
(:module "matlisp-level-2"
:pathname "level-2"
:depends-on ("matlisp-base" "matlisp-classes" "foreign-core" "matlisp-level-1")
:components ((:file "gemv")))
- #+nil
(:module "matlisp-level-3"
:pathname "level-3"
:depends-on ("matlisp-base" "matlisp-classes" "foreign-core" "matlisp-level-1")
diff --git a/src/level-3/gemm.lisp b/src/level-3/gemm.lisp
index e6ba5ab..ecf1756 100644
--- a/src/level-3/gemm.lisp
+++ b/src/level-3/gemm.lisp
@@ -28,133 +28,144 @@
(in-package #:matlisp)
-(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)
+(defmacro generate-typed-gemm! (func (tensor-class blas-gemm-func blas-gemv-func fortran-lb-parameter))
+ (let* ((opt (if-ret (get-tensor-class-optimization-hashtable tensor-class)
+ (error 'tensor-cannot-find-optimization :tensor-class tensor-class)))
+ (matrix-class (getf opt :matrix))
+ (blas? (and blas-gemm-func blas-gemv-func)))
`(definline ,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))
- (call-fortran? (> (max (nrows C) (ncols C) (if (eq job-A :n) (ncols A) (nrows A)))
- ,fortran-lb-parameter))
- ((maj-A ld-A fop-A) (if call-fortran? (blas-matrix-compatible-p A job-A) (values nil 0 "?")) :type (symbol index-type (string 1)))
- ((maj-B ld-B fop-B) (if call-fortran? (blas-matrix-compatible-p B job-B) (values nil 0 "?")) :type (symbol index-type (string 1)))
- ((maj-C ld-C fop-C) (if call-fortran? (blas-matrix-compatible-p C :n) (values nil 0 "?")) :type (symbol index-type nil)))
- (cond
- ((and call-fortran? 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))))
- ((and call-fortran? maj-A)
- (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
- (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 call-fortran? maj-B)
- (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)))
+ ,(let
+ ((lisp-routine
+ `(let-typed ((nr-C (nrows C) :type index-type)
+ (nc-C (ncols C) :type index-type)
+ (dotl (ecase job-A (:n (ncols A)) (:t (nrows A))) :type index-type)
;
- (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)))
+ (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)))
;
- (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
- (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 ((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-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-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-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
+ (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 (,(getf opt :f*) beta (,(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)
+ :with sum :of-type ,(getf opt :element-type) := (,(getf opt :fid+))
+ :do (let-typed ((A-val (,(getf opt :reader) sto-A of-A) :type ,(getf opt :element-type))
+ (B-val (,(getf opt :reader) sto-B of-B) :type ,(getf opt :element-type)))
+ (setf sum (,(getf opt :f+) sum (,(getf opt :f*) A-val B-val))))
+ :finally (,(getf opt :value-writer) (,(getf opt :f+) (,(getf opt :f*) alpha sum) val) sto-C of-C)))))))))
+ `(mlet* ,(recursive-append
+ '(((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)))
+ (when blas?
+ `((call-fortran? (> (max (nrows C) (ncols C) (if (eq job-A :n) (ncols A) (nrows A)))
+ ,fortran-lb-parameter))
+ ((maj-A ld-A fop-A) (if call-fortran? (blas-matrix-compatible-p A job-A) (values nil 0 "?")) :type (symbol index-type (string 1)))
+ ((maj-B ld-B fop-B) (if call-fortran? (blas-matrix-compatible-p B job-B) (values nil 0 "?")) :type (symbol index-type (string 1)))
+ ((maj-C ld-C fop-C) (if call-fortran? (blas-matrix-compatible-p C :n) (values nil 0 "?")) :type (symbol index-type nil)))))
+ ,(if blas?
+ `(cond
+ ((and call-fortran? 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))))
+ ((and call-fortran? maj-A)
+ (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)))
;
- (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)))
+ (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)
;
- (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
- (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))))))))))
+ (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
+ (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 call-fortran? maj-B)
+ (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
+ (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
+ ,lisp-routine))
+ lisp-routine)))
C)))
;;Real
(generate-typed-gemm! real-base-typed-gemm!
- (real-matrix dgemm dgemv *real-l3-fcall-lb*))
+ (real-tensor dgemm dgemv *real-l3-fcall-lb*))
(definline real-typed-gemm! (alpha A B beta C job)
(real-base-typed-gemm! alpha A B beta C
@@ -165,7 +176,7 @@
;;Complex
(generate-typed-gemm! complex-base-typed-gemm!
- (complex-matrix zgemm zgemv *complex-l3-fcall-lb*))
+ (complex-tensor zgemm zgemv *complex-l3-fcall-lb*))
(definline complex-typed-gemm! (alpha A B beta C job)
(declare (type complex-matrix A B C)
@@ -190,6 +201,11 @@
(complex-base-typed-gemm! alpha A B
beta C tjob)))))
+;;Symbolic
+#+maxima
+(generate-typed-gemm! symbolic-base-typed-gemm!
+ (symbolic-tensor nil nil 0))
+
;;---------------------------------------------------------------;;
(defgeneric gemm! (alpha A B beta C &optional job)
-----------------------------------------------------------------------
Summary of changes:
matlisp.asd | 8 +-
src/base/blas-helpers.lisp | 3 +-
src/base/standard-tensor.lisp | 174 +++++++++++++++------------
src/classes/complex-tensor.lisp | 126 +++++++++++++-------
src/classes/matrix.lisp | 4 +-
src/classes/real-tensor.lisp | 113 ++++++++++++------
src/classes/symbolic-tensor.lisp | 126 +++++++++++++++++++
src/conditions.lisp | 7 -
src/level-1/axpy.lisp | 82 ++++++++-----
src/level-1/copy.lisp | 93 +++++++++------
src/level-1/dot.lisp | 128 ++++++++++----------
src/level-1/scal.lisp | 141 ++++++++++++++--------
src/level-1/swap.lisp | 40 ++++---
src/level-1/tensor-maker.lisp | 12 +-
src/level-2/gemv.lisp | 106 +++++++++-------
src/level-3/gemm.lisp | 246 ++++++++++++++++++++------------------
16 files changed, 868 insertions(+), 541 deletions(-)
create mode 100644 src/classes/symbolic-tensor.lisp
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2012-12-28 01:47:49
|
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, extensible has been updated
via 856c60140465482aaa72f021360c4c795073ad6f (commit)
via 0166ce8014b662aca4a91484eb2458e7e87be8ac (commit)
from 1c74913ff22ddc869220e6ee124bcf272b188d12 (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 856c60140465482aaa72f021360c4c795073ad6f
Author: Akshay Srinivasan <aks...@gm...>
Date: Thu Dec 27 19:41:16 2012 -0600
o Ported level-2 BLAS.
diff --git a/matlisp.asd b/matlisp.asd
index de18f1a..17f0086 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -124,6 +124,8 @@
:depends-on ("matlisp-base")
:components ((:file "real-tensor")
(:file "complex-tensor")
+ #+maxima
+ (:file "symbolic-tensor")
(:file "matrix"
:depends-on ("real-tensor" "complex-tensor"))))
(:module "matlisp-level-1"
diff --git a/src/level-1/axpy.lisp b/src/level-1/axpy.lisp
index ab9554d..6fc9eb5 100644
--- a/src/level-1/axpy.lisp
+++ b/src/level-1/axpy.lisp
@@ -123,6 +123,16 @@
(generate-typed-num-axpy! complex-typed-num-axpy!
(complex-tensor zaxpy *complex-l1-fcall-lb*))
+
+;;Symbolic
+#+maxima
+(progn
+ (generate-typed-axpy! symbolic-typed-axpy!
+ (symbolic-tensor nil 0))
+
+ (generate-typed-num-axpy! symbolic-typed-num-axpy!
+ (symbolic-tensor nil 0)))
+
;;---------------------------------------------------------------;;
(defgeneric axpy! (alpha x y)
diff --git a/src/level-1/copy.lisp b/src/level-1/copy.lisp
index 4e5b665..9a42abf 100644
--- a/src/level-1/copy.lisp
+++ b/src/level-1/copy.lisp
@@ -113,6 +113,15 @@
(generate-typed-num-copy! complex-typed-num-copy!
(complex-tensor zcopy *complex-l1-fcall-lb*))
+
+;;Symbolic
+#+maxima
+(progn
+(generate-typed-copy! symbolic-typed-copy!
+ (symbolic-tensor nil 0))
+
+(generate-typed-num-copy! symbolic-typed-num-copy!
+ (symbolic-tensor nil 0)))
;;---------------------------------------------------------------;;
;;Generic function defined in src;base;generic-copy.lisp
diff --git a/src/level-1/dot.lisp b/src/level-1/dot.lisp
index fb85d4e..7302d70 100644
--- a/src/level-1/dot.lisp
+++ b/src/level-1/dot.lisp
@@ -88,6 +88,7 @@
(generate-typed-dot complex-typed-dot
(complex-tensor zdotu zdotc *complex-l1-fcall-lb*))
+#+maxima
(generate-typed-dot symbolic-typed-dot
(symbolic-tensor nil nil 0))
diff --git a/src/level-1/scal.lisp b/src/level-1/scal.lisp
index d55de3c..472a186 100644
--- a/src/level-1/scal.lisp
+++ b/src/level-1/scal.lisp
@@ -182,6 +182,21 @@
(generate-typed-num-div! complex-typed-num-div!
(complex-tensor zediv *complex-l1-fcall-lb*))
+
+;;Symbolic
+#+maxima
+(progn
+ (generate-typed-num-scal! symbolic-typed-num-scal!
+ (real-tensor nil 0))
+
+ (generate-typed-scal! symbolic-typed-scal!
+ (real-tensor nil 0))
+
+ (generate-typed-div! symbolic-typed-div!
+ (real-tensor nil 0))
+
+ (generate-typed-num-div! symbolic-typed-num-div!
+ (real-tensor nil 0)))
;;---------------------------------------------------------------;;
(defgeneric scal! (alpha x)
diff --git a/src/level-1/swap.lisp b/src/level-1/swap.lisp
index 9de6966..6df8506 100644
--- a/src/level-1/swap.lisp
+++ b/src/level-1/swap.lisp
@@ -63,6 +63,11 @@
(generate-typed-swap! complex-typed-swap!
(complex-tensor zswap *complex-l1-fcall-lb*))
+
+#+maxima
+(generate-typed-swap! symbolic-typed-swap!
+ (symbolic-tensor nil 0))
+
;;---------------------------------------------------------------;;
;;Generic function in src;base;generic-swap.lisp
diff --git a/src/level-1/tensor-maker.lisp b/src/level-1/tensor-maker.lisp
index f8b8885..ba233ae 100644
--- a/src/level-1/tensor-maker.lisp
+++ b/src/level-1/tensor-maker.lisp
@@ -49,7 +49,7 @@
(make-tensor-maker make-real-tensor (real-tensor))
(make-tensor-maker make-complex-tensor (complex-tensor))
-
+#+maxima
(make-tensor-maker make-symbolic-tensor (symbolic-tensor))
;;Had to move it here in the wait for copy!
diff --git a/src/level-2/gemv.lisp b/src/level-2/gemv.lisp
index c483454..2dba31a 100644
--- a/src/level-2/gemv.lisp
+++ b/src/level-2/gemv.lisp
@@ -1,74 +1,81 @@
(in-package #:matlisp)
(defmacro generate-typed-gemv! (func
- (matrix-class vector-class
- blas-gemv-func
+ (tensor-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.
- (let* ((opt (get-tensor-class-optimization matrix-class)))
- (assert opt nil 'tensor-cannot-find-optimization :tensor-class matrix-class)
+ (let* ((opt (if-ret (get-tensor-class-optimization-hashtable tensor-class)
+ (error 'tensor-cannot-find-optimization :tensor-class tensor-class)))
+ (matrix-class (getf opt :matrix))
+ (vector-class (getf opt :vector)))
`(definline ,func (alpha A x beta y job)
(declare (type ,(getf opt :element-type) alpha beta)
(type ,matrix-class A)
(type ,vector-class x y)
(type symbol job))
- (mlet*
- ((call-fortran? (> (max (nrows A) (ncols A)) ,fortran-call-lb))
- ((maj-A ld-A fop-A) (if call-fortran? (blas-matrix-compatible-p A job) (values nil 0 "?")) :type (symbol index-type (string 1))))
- (cond
- ((and maj-a call-fortran?)
- (let-typed ((nr-A (nrows A) :type index-type)
- (nc-A (ncols A) :type index-type))
- (when (eq maj-A :row-major)
- (rotatef nr-A nc-A))
- (,blas-gemv-func fop-a nr-A nc-A
- alpha (store A) ld-A
- (store x) (aref (strides x) 0)
- beta
- (store y) (aref (strides y) 0)
- (head A) (head x) (head y))))
- (t
- (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)))
+ ,(let
+ ((lisp-routine
+ `(let-typed ((nr-A (nrows A) :type index-type)
+ (nc-A (ncols A) :type index-type)
+ (rs-A (row-stride A) :type index-type)
+ (cs-A (col-stride A) :type index-type)
+ (sto-A (store A) :type ,(linear-array-type (getf opt :store-type)))
;
- (stp-x (aref (strides x) 0) :type index-type)
- (sto-x (store x) :type ,(linear-array-type (getf opt :store-type)))
- (hd-x (head x) :type index-type)
+ (stp-x (aref (strides x) 0) :type index-type)
+ (sto-x (store x) :type ,(linear-array-type (getf opt :store-type)))
+ (hd-x (head x) :type index-type)
;
- (stp-y (aref (strides y) 0) :type index-type)
- (sto-y (store y) :type ,(linear-array-type (getf opt :store-type))))
- (when (eq job :t)
- (rotatef nr-A nc-A)
- (rotatef rs-A cs-A))
- (very-quickly
- (loop repeat nr-A
- for of-y of-type index-type = (head y) then (+ of-y stp-y)
- for rof-A of-type index-type = (head A) then (+ rof-A rs-A)
- do (let-typed ((val (* 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)))))))))
+ (stp-y (aref (strides y) 0) :type index-type)
+ (sto-y (store y) :type ,(linear-array-type (getf opt :store-type))))
+ (when (eq job :t)
+ (rotatef nr-A nc-A)
+ (rotatef rs-A cs-A))
+ (very-quickly
+ (loop :repeat nr-A
+ :for of-y :of-type index-type := (head y) :then (+ of-y stp-y)
+ :for rof-A :of-type index-type := (head A) :then (+ rof-A rs-A)
+ :do (let-typed ((val (,(getf opt :f*) beta (,(getf opt :reader) sto-y of-y)) :type ,(getf opt :element-type)))
+ (loop :repeat nc-A
+ :for of-x :of-type index-type := hd-x :then (+ of-x stp-x)
+ :for of-A :of-type index-type := rof-A :then (+ of-A cs-A)
+ :with dot :of-type ,(getf opt :element-type) = (,(getf opt :fid+))
+ :do (let-typed ((xval (,(getf opt :reader) sto-x of-x) :type ,(getf opt :element-type))
+ (Aval (,(getf opt :reader) sto-A of-A) :type ,(getf opt :element-type)))
+ (setf dot (,(getf opt :f+) dot (,(getf opt :f*) xval Aval))))
+ :finally (,(getf opt :value-writer) (,(getf opt :f+) (,(getf opt :f*) alpha dot) val) sto-y of-y))))))))
+ (if blas-gemv-func
+ `(mlet*
+ ((call-fortran? (> (max (nrows A) (ncols A)) ,fortran-call-lb))
+ ((maj-A ld-A fop-A) (if call-fortran? (blas-matrix-compatible-p A job) (values nil 0 "?")) :type (symbol index-type (string 1))))
+ (cond
+ ((and maj-a call-fortran?)
+ (let-typed ((nr-A (nrows A) :type index-type)
+ (nc-A (ncols A) :type index-type))
+ (when (eq maj-A :row-major)
+ (rotatef nr-A nc-A))
+ (,blas-gemv-func fop-a nr-A nc-A
+ alpha (store A) ld-A
+ (store x) (aref (strides x) 0)
+ beta
+ (store y) (aref (strides y) 0)
+ (head A) (head x) (head y))))
+ (t
+ ,lisp-routine)))
+ lisp-routine))
y)))
;;Real
(generate-typed-gemv! real-base-typed-gemv!
- (real-matrix real-vector dgemv *real-l2-fcall-lb*))
+ (real-tensor dgemv *real-l2-fcall-lb*))
(definline real-typed-gemv! (alpha A x beta y job)
(real-base-typed-gemv! alpha A x beta y (ecase job ((:n :t) job) (:h :t) (:c :n))))
;;Complex
(generate-typed-gemv! complex-base-typed-gemv!
- (complex-matrix complex-vector zgemv *complex-l2-fcall-lb*))
+ (complex-tensor zgemv *complex-l2-fcall-lb*))
(definline complex-typed-gemv! (alpha A x beta y job)
(declare (type complex-matrix A)
@@ -87,6 +94,11 @@
(complex-typed-num-scal! #c(-1d0 0d0) (tensor-realpart~ y))
y)))
+;;Symbolic
+#+maxima
+(generate-typed-gemv! symbolic-base-typed-gemv!
+ (symbolic-tensor nil 0))
+
;;---------------------------------------------------------------;;
(defgeneric gemv! (alpha A x beta y &optional job)
commit 0166ce8014b662aca4a91484eb2458e7e87be8ac
Author: Akshay Srinivasan <aks...@gm...>
Date: Thu Dec 27 17:01:44 2012 -0600
o Added "symbolic-tensor", sort of works with Maxima.
o Ported all level-1 stuff.
diff --git a/matlisp.asd b/matlisp.asd
index 61a7721..de18f1a 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -139,9 +139,9 @@
:depends-on ("copy" "tensor-maker" "realimag"))
(:file "dot"
:depends-on ("realimag"))
- #+nil(:file "axpy"
+ (:file "axpy"
:depends-on ("copy" "scal"))
- #+nil(:file "trans"
+ (:file "trans"
:depends-on ("scal" "copy"))))
#+nil
(:module "matlisp-level-2"
diff --git a/src/base/standard-tensor.lisp b/src/base/standard-tensor.lisp
index e27d9d8..a0bbef8 100644
--- a/src/base/standard-tensor.lisp
+++ b/src/base/standard-tensor.lisp
@@ -337,7 +337,7 @@
(defmacro define-tensor
((tensor-class element-type store-element-type store-type &rest class-decls) &key
- f+ f- finv+ fid+ f* f/ finv* fid*
+ f+ f- finv+ fid+ f* f/ finv* fid* fconj
matrix vector
store-allocator coercer coercer-unforgiving reader value-writer reader-writer swapper)
;;Error checking
@@ -376,6 +376,7 @@
:f/ ',f/
:finv* ',finv*
:fid* ',fid*
+ :fconj ',fconj
:reader ',reader
:value-writer ',value-writer
:reader-writer ',reader-writer
diff --git a/src/classes/complex-tensor.lisp b/src/classes/complex-tensor.lisp
index 03a8fab..73e624a 100644
--- a/src/classes/complex-tensor.lisp
+++ b/src/classes/complex-tensor.lisp
@@ -110,6 +110,7 @@
:f/ complex-type.f/
:finv* complex-type.finv*
:fid* complex-type.fid*
+ :fconj complex-type.fconj
;;
:store-allocator allocate-complex-store
:coercer coerce-complex
diff --git a/src/classes/real-tensor.lisp b/src/classes/real-tensor.lisp
index 8b0a9ec..44239aa 100644
--- a/src/classes/real-tensor.lisp
+++ b/src/classes/real-tensor.lisp
@@ -86,13 +86,12 @@ Allocates real storage. Default initial-element = 0d0.")
:f/ real-type.f/
:finv* real-type.finv*
:fid* real-type.fid*
+ :fconj nil
;;
:store-allocator allocate-real-store
:coercer coerce-real
:coercer-unforgiving coerce-real-unforgiving
;;
- :matrix real-matrix :vector real-vector
- ;;
:reader real-type.reader
:value-writer real-type.value-writer
:reader-writer real-type.reader-writer
diff --git a/src/classes/symbolic-tensor.lisp b/src/classes/symbolic-tensor.lisp
new file mode 100644
index 0000000..be7986c
--- /dev/null
+++ b/src/classes/symbolic-tensor.lisp
@@ -0,0 +1,126 @@
+(in-package #:matlisp)
+
+(deftype symbolic-type ()
+ "Symbolic type associated with Maxima"
+ '(or number symbol list))
+
+(deftype symbolic-store-vector (&optional (size '*))
+ "The type of the storage structure for a REAL-MATRIX"
+ `(simple-array symbolic-type (,size)))
+
+;;Field definitions
+(definline symbolic-type.f+ (a b)
+ (declare (type symbolic-type a b))
+ (maxima::add a b))
+
+(definline symbolic-type.f- (a b)
+ (declare (type symbolic-type a b))
+ (maxima::sub a b))
+
+(definline symbolic-type.finv+ (a)
+ (declare (type symbolic-type a))
+ (maxima::mul -1 a))
+
+(definline symbolic-type.fid+ ()
+ 0)
+
+(definline symbolic-type.f* (a b)
+ (declare (type symbolic-type a b))
+ (maxima::mul a b))
+
+(definline symbolic-type.f/ (a b)
+ (declare (type symbolic-type a b))
+ (maxima::div a b))
+
+(definline symbolic-type.finv* (a)
+ (declare (type symbolic-type a))
+ (maxima::div 1 a))
+
+(definline symbolic-type.fid* ()
+ 1)
+
+(definline symbolic-type.fconj (a)
+ (maxima::meval `((maxima::$conjugate maxima::simp) ,a)))
+
+(definline symbolic-type.diff (a x)
+ (etypecase a
+ (symbolic-type
+ (maxima::$diff a x))
+ (symbolic-tensor
+ (make-instance 'symbolic-tensor
+ :dimensions (copy-seq (dimensions a))
+ :store (map 'symbolic-store-vector #'(lambda (f) (maxima::$diff f x)) (store a))))))
+;;
+;;Store definitions
+(definline symbolic-type.reader (tstore idx)
+ (declare (type index-type idx)
+ (type symbolic-store-vector tstore))
+ (aref tstore idx))
+
+(definline symbolic-type.value-writer (value store idx)
+ (declare (type index-type idx)
+ (type symbolic-store-vector store)
+ (type symbolic-type value))
+ (setf (aref store idx) value))
+
+(definline symbolic-type.reader-writer (fstore fidx tstore tidx)
+ (declare (type index-type fidx tidx)
+ (type symbolic-store-vector fstore tstore))
+ (setf (aref tstore tidx) (aref fstore fidx)))
+
+(definline symbolic-type.swapper (fstore fidx tstore tidx)
+ (declare (type index-type fidx tidx)
+ (type symbolic-store-vector fstore tstore))
+ (rotatef (aref tstore tidx) (aref fstore fidx)))
+
+;;
+(make-array-allocator allocate-symbolic-store 'symbolic-type 0
+"(allocate-symbolic-store size [initial-element])
+Allocates symbolic storage. Default initial-element = 0.")
+
+(definline coerce-symbolic-unforgiving (x)
+ (coerce x 'symbolic-type))
+
+(defun coerce-symbolic (x)
+ (restart-case (coerce-symbolic-unforgiving x)
+ (use-value (value) (coerce-symbolic value))))
+
+(define-tensor (symbolic-tensor symbolic-type symbolic-type symbolic-store-vector
+ (:documentation "Tensor class with symbolic double elements."))
+ :matrix symbolic-matrix :vector symbolic-vector
+ ;;
+ :f+ symbolic-type.f+
+ :f- symbolic-type.f-
+ :finv+ symbolic-type.finv+
+ :fid+ symbolic-type.fid+
+ :f* symbolic-type.f*
+ :f/ symbolic-type.f/
+ :finv* symbolic-type.finv*
+ :fid* symbolic-type.fid*
+ :fconj symbolic-type.fconj
+ ;;
+ :store-allocator allocate-symbolic-store
+ :coercer coerce-symbolic
+ :coercer-unforgiving coerce-symbolic-unforgiving
+ ;;
+ :reader symbolic-type.reader
+ :value-writer symbolic-type.value-writer
+ :reader-writer symbolic-type.reader-writer
+ :swapper symbolic-type.swapper)
+
+(defmethod initialize-instance ((tensor symbolic-tensor) &rest initargs)
+ (if (getf initargs :store)
+ (setf (slot-value tensor 'store-size) (length (getf initargs :store)))
+ (let ((size (reduce #'* (getf initargs :dimensions))))
+ (setf (slot-value tensor 'store) (allocate-symbolic-store size)
+ (slot-value tensor 'store-size) size)))
+ (call-next-method))
+
+;;
+(defmethod (setf tensor-ref) ((value number) (tensor symbolic-tensor) subscripts)
+ (let ((sto-idx (store-indexing subscripts tensor)))
+ (setf (tensor-store-ref tensor sto-idx) (coerce-symbolic value))))
+
+(defmethod print-element ((tensor symbolic-tensor)
+ element stream)
+ (format stream "~a" element))
diff --git a/src/level-1/axpy.lisp b/src/level-1/axpy.lisp
index df29906..ab9554d 100644
--- a/src/level-1/axpy.lisp
+++ b/src/level-1/axpy.lisp
@@ -32,22 +32,14 @@
;;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)))
+ (let* ((opt (get-tensor-class-optimization-hashtable tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
`(definline ,func (alpha from to)
(declare (type ,tensor-class from to)
(type ,(getf opt :element-type) alpha))
- (let* ((call-fortran? (> (number-of-elements to)
- ,fortran-lb))
- (strd-p (when call-fortran? (blas-copyable-p from to))))
- (cond
- ((and call-fortran? strd-p)
- (,blas-func (number-of-elements from) alpha
- (store from) (first strd-p)
- (store to) (second strd-p)
- (head from) (head to)))
- (t
- (let ((f-sto (store from))
+ ,(let
+ ((lisp-routine
+ `(let ((f-sto (store from))
(t-sto (store to)))
(declare (type ,(linear-array-type (getf opt :store-type)) f-sto t-sto))
(very-quickly
@@ -58,12 +50,25 @@
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)))
+ do (let ((f-val (,(getf opt :reader) f-sto f-of))
+ (t-val (,(getf opt :reader) t-sto t-of)))
(declare (type ,(getf opt :element-type) f-val t-val))
(let ((t-new (+ (* f-val alpha) t-val)))
(declare (type ,(getf opt :element-type) t-new))
- ,(funcall (getf opt :value-writer) 't-new 't-sto 't-of)))))))))
+ (,(getf opt :value-writer) t-new t-sto t-of))))))))
+ (if blas-func
+ `(let* ((call-fortran? (> (number-of-elements to)
+ ,fortran-lb))
+ (strd-p (when call-fortran? (blas-copyable-p from to))))
+ (cond
+ ((and call-fortran? strd-p)
+ (,blas-func (number-of-elements from) alpha
+ (store from) (first strd-p)
+ (store to) (second strd-p)
+ (head from) (head to)))
+ (t
+ ,lisp-routine)))
+ lisp-routine))
to)))
(defmacro generate-typed-num-axpy! (func (tensor-class blas-func fortran-lb))
@@ -76,28 +81,33 @@
`(definline ,func (num-from to)
(declare (type ,tensor-class to)
(type ,(getf opt :element-type) num-from))
- (let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
- (min-strd (when call-fortran? (consecutive-store-p to))))
- (cond
- ((and call-fortran? min-strd)
- (let ((num-array (,(getf opt :store-allocator) 1)))
- (declare (type ,(linear-array-type (getf opt :store-type)) num-array))
- (let-typed ((id (,(getf opt :coercer) 1) :type ,(getf opt :element-type)))
- ,(funcall (getf opt :value-writer) `id 'num-array 0))
- (,blas-func (number-of-elements to) num-from
- num-array 0
- (store to) min-strd
- 0 (head to))))
- (t
- (let-typed
+ ,(let
+ ((lisp-routine
+ `(let-typed
((t-sto (store to) :type ,(linear-array-type (getf opt :store-type))))
(very-quickly
(mod-dotimes (idx (dimensions to))
with (linear-sums
(t-of (strides to) (head to)))
do (let-typed
- ((val ,(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))))))))
+ ((val (,(getf opt :reader) t-sto t-of) :type ,(getf opt :element-type)))
+ (,(getf opt :value-writer) (,(getf opt :f+) num-from val) t-sto t-of)))))))
+ (if blas-func
+ `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
+ (min-strd (when call-fortran? (consecutive-store-p to))))
+ (cond
+ ((and call-fortran? min-strd)
+ (let ((num-array (,(getf opt :store-allocator) 1)))
+ (declare (type ,(linear-array-type (getf opt :store-type)) num-array))
+ (let-typed ((id (,(getf opt :fid+)) :type ,(getf opt :element-type)))
+ (,(getf opt :value-writer) id num-array 0))
+ (,blas-func (number-of-elements to) num-from
+ num-array 0
+ (store to) min-strd
+ 0 (head to))))
+ (t
+ ,lisp-routine)))
+ lisp-routine))
to)))
;;Real
diff --git a/src/level-1/dot.lisp b/src/level-1/dot.lisp
index fd92ddf..fb85d4e 100644
--- a/src/level-1/dot.lisp
+++ b/src/level-1/dot.lisp
@@ -27,10 +27,10 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(in-package #:matlisp)
-(defmacro generate-typed-dot (func (tensor-class blas-func blasc-func conj-func fortran-lb))
+(defmacro generate-typed-dot (func (tensor-class blas-func blasc-func fortran-lb))
(let* ((opt (get-tensor-class-optimization-hashtable tensor-class))
- (conj? (and blasc-func conj-func))
- (blas? (or blas-func blasc-func)))
+ (conj? (getf opt :fconj))
+ (blas? (and blas-func (if conj? blasc-func t))))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
`(definline ,func (x y conjugate-p)
(declare (type ,tensor-class x y)
@@ -41,9 +41,9 @@
((lisp-routine
`(let-typed
((stp-x (aref (strides x) 0) :type index-type)
- (sto-x (store x) :type complex-store-vector)
+ (sto-x (store x) :type ,(linear-array-type (getf opt :store-type)))
(stp-y (aref (strides y) 0) :type index-type)
- (sto-y (store y) :type complex-store-vector)
+ (sto-y (store y) :type ,(linear-array-type (getf opt :store-type)))
(nele (number-of-elements x) :type index-type))
,(labels ((main-loop (conjp)
`(very-quickly
@@ -52,7 +52,7 @@
:for of-y :of-type index-type = (head y) :then (+ of-y stp-y)
:with dot :of-type ,(getf opt :element-type) = (,(getf opt :fid+))
:do (let-typed ((xval ,(recursive-append
- (when conjp `(,conj-func))
+ (when conjp `(,conj?))
`(,(getf opt :reader) sto-x of-x)) :type ,(getf opt :element-type))
(yval (,(getf opt :reader) sto-y of-y) :type ,(getf opt :element-type)))
(setf dot (,(getf opt :f+) dot (,(getf opt :f*) xval yval))))
@@ -83,10 +83,13 @@
lisp-routine)))))
(generate-typed-dot real-typed-dot
- (real-tensor ddot nil nil *real-l1-fcall-lb*))
+ (real-tensor ddot nil *real-l1-fcall-lb*))
(generate-typed-dot complex-typed-dot
- (complex-tensor zdotu zdotc complex-type.fconj *complex-l1-fcall-lb*))
+ (complex-tensor zdotu zdotc *complex-l1-fcall-lb*))
+
+(generate-typed-dot symbolic-typed-dot
+ (symbolic-tensor nil nil 0))
;;---------------------------------------------------------------;;
diff --git a/src/level-1/tensor-maker.lisp b/src/level-1/tensor-maker.lisp
index 4ce8f18..f8b8885 100644
--- a/src/level-1/tensor-maker.lisp
+++ b/src/level-1/tensor-maker.lisp
@@ -50,6 +50,8 @@
(make-tensor-maker make-real-tensor (real-tensor))
(make-tensor-maker make-complex-tensor (complex-tensor))
+(make-tensor-maker make-symbolic-tensor (symbolic-tensor))
+
;;Had to move it here in the wait for copy!
(definline sub-tensor (tensor subscripts)
(copy (sub-tensor~ tensor subscripts)))
-----------------------------------------------------------------------
Summary of changes:
matlisp.asd | 6 +-
src/base/standard-tensor.lisp | 3 +-
src/classes/complex-tensor.lisp | 1 +
src/classes/real-tensor.lisp | 3 +-
src/classes/symbolic-tensor.lisp | 126 ++++++++++++++++++++++++++++++++++++++
src/level-1/axpy.lisp | 82 +++++++++++++++---------
src/level-1/copy.lisp | 9 +++
src/level-1/dot.lisp | 20 ++++---
src/level-1/scal.lisp | 15 +++++
src/level-1/swap.lisp | 5 ++
src/level-1/tensor-maker.lisp | 2 +
src/level-2/gemv.lisp | 106 ++++++++++++++++++--------------
12 files changed, 287 insertions(+), 91 deletions(-)
create mode 100644 src/classes/symbolic-tensor.lisp
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2012-12-26 03:47:27
|
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, extensible has been updated
via 1c74913ff22ddc869220e6ee124bcf272b188d12 (commit)
from 376399e23fbbb868c8eb3ef80ee8bc9c65c5d98e (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 1c74913ff22ddc869220e6ee124bcf272b188d12
Author: Akshay Srinivasan <aks...@gm...>
Date: Tue Dec 25 21:41:55 2012 -0600
o Ported scal.lisp
diff --git a/matlisp.asd b/matlisp.asd
index d573c09..61a7721 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -133,11 +133,11 @@
(:file "swap")
(:file "copy"
:depends-on ("tensor-maker"))
- #+nil(:file "scal"
- :depends-on ("copy" "tensor-maker"))
- #+nil(:file "realimag"
+ (:file "realimag"
:depends-on ("copy"))
- #+nil(:file "dot"
+ (:file "scal"
+ :depends-on ("copy" "tensor-maker" "realimag"))
+ (:file "dot"
:depends-on ("realimag"))
#+nil(:file "axpy"
:depends-on ("copy" "scal"))
diff --git a/src/classes/complex-tensor.lisp b/src/classes/complex-tensor.lisp
index 97e6656..03a8fab 100644
--- a/src/classes/complex-tensor.lisp
+++ b/src/classes/complex-tensor.lisp
@@ -44,6 +44,10 @@
(definline complex-type.fid* ()
#c(1.0d0 0.0d0))
+(definline complex-type.fconj (a)
+ (declare (type complex-type a))
+ (conjugate a))
+
;;Store operations
(definline allocate-complex-store (size)
"
diff --git a/src/level-1/dot.lisp b/src/level-1/dot.lisp
index dfb7d42..fd92ddf 100644
--- a/src/level-1/dot.lisp
+++ b/src/level-1/dot.lisp
@@ -27,72 +27,66 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(in-package #:matlisp)
-(definline real-typed-dot (x y conjugate-p)
- (declare (type real-vector x y)
- (ignore conjugate-p))
- (let ((call-fortran? (> (number-of-elements x)
- *real-l1-fcall-lb*)))
- (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-store-vector)
- (stp-y (aref (strides y) 0) :type index-type)
- (sto-y (store y) :type real-store-vector)
- (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))))))))
-
-(definline complex-typed-dot (x y conjugate-p)
- (declare (type complex-vector x y))
- (let ((call-fortran? (> (number-of-elements x)
- *complex-l1-fcall-lb*)))
- (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-store-vector)
- (stp-y (aref (strides y) 0) :type index-type)
- (sto-y (store y) :type complex-store-vector)
- (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)))))))))
+(defmacro generate-typed-dot (func (tensor-class blas-func blasc-func conj-func fortran-lb))
+ (let* ((opt (get-tensor-class-optimization-hashtable tensor-class))
+ (conj? (and blasc-func conj-func))
+ (blas? (or blas-func blasc-func)))
+ (assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
+ `(definline ,func (x y conjugate-p)
+ (declare (type ,tensor-class x y)
+ ,(if conj?
+ `(type boolean conjugate-p)
+ `(ignore conjugate-p)))
+ ,(let
+ ((lisp-routine
+ `(let-typed
+ ((stp-x (aref (strides x) 0) :type index-type)
+ (sto-x (store x) :type complex-store-vector)
+ (stp-y (aref (strides y) 0) :type index-type)
+ (sto-y (store y) :type complex-store-vector)
+ (nele (number-of-elements x) :type index-type))
+ ,(labels ((main-loop (conjp)
+ `(very-quickly
+ (loop :repeat nele
+ :for of-x :of-type index-type = (head x) :then (+ of-x stp-x)
+ :for of-y :of-type index-type = (head y) :then (+ of-y stp-y)
+ :with dot :of-type ,(getf opt :element-type) = (,(getf opt :fid+))
+ :do (let-typed ((xval ,(recursive-append
+ (when conjp `(,conj-func))
+ `(,(getf opt :reader) sto-x of-x)) :type ,(getf opt :element-type))
+ (yval (,(getf opt :reader) sto-y of-y) :type ,(getf opt :element-type)))
+ (setf dot (,(getf opt :f+) dot (,(getf opt :f*) xval yval))))
+ :finally (return dot)))))
+ (if conj?
+ `(if conjugate-p
+ ,(main-loop t)
+ ,(main-loop nil))
+ (main-loop nil))))))
+ (if blas?
+ `(let ((call-fortran? (> (number-of-elements x)
+ ,fortran-lb)))
+ (cond
+ (call-fortran?
+ ,(recursive-append
+ (when conj?
+ `(if conjugate-p
+ (,blasc-func (number-of-elements x)
+ (store x) (aref (strides x) 0)
+ (store y) (aref (strides y) 0)
+ (head x) (head y))))
+ `(,blas-func (number-of-elements x)
+ (store x) (aref (strides x) 0)
+ (store y) (aref (strides y) 0)
+ (head x) (head y))))
+ (t
+ ,lisp-routine)))
+ lisp-routine)))))
+
+(generate-typed-dot real-typed-dot
+ (real-tensor ddot nil nil *real-l1-fcall-lb*))
+
+(generate-typed-dot complex-typed-dot
+ (complex-tensor zdotu zdotc complex-type.fconj *complex-l1-fcall-lb*))
;;---------------------------------------------------------------;;
diff --git a/src/level-1/scal.lisp b/src/level-1/scal.lisp
index 223f78a..d55de3c 100644
--- a/src/level-1/scal.lisp
+++ b/src/level-1/scal.lisp
@@ -45,7 +45,7 @@
(t-of (strides to) (head to)))
do (let*-typed ((val-f (,(getf opt :reader) f-sto f-of) :type ,(getf opt :element-type))
(val-t (,(getf opt :reader) t-sto t-of) :type ,(getf opt :element-type))
- (mul (* val-f val-t) :type ,(getf opt :element-type)))
+ (mul (,(getf opt :f*) val-f val-t) :type ,(getf opt :element-type)))
(,(getf opt :value-writer) mul t-sto t-of)))))))
(if fortran-func
`(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
@@ -75,7 +75,7 @@
(mod-dotimes (idx (dimensions to))
with (linear-sums
(t-of (strides to) (head to)))
- do (let ((scal-val (* (,(getf opt :reader) t-sto t-of) alpha)))
+ do (let ((scal-val (,(getf opt :f*) (,(getf opt :reader) t-sto t-of) alpha)))
(,(getf opt :value-writer) scal-val t-sto t-of)))))))
(if blas-func
`(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
@@ -105,7 +105,7 @@
(t-of (strides to) (head to)))
do (let*-typed ((val-f (,(getf opt :reader) f-sto f-of) :type ,(getf opt :element-type))
(val-t (,(getf opt :reader) t-sto t-of) :type ,(getf opt :element-type))
- (mul (/ val-f val-t) :type ,(getf opt :element-type)))
+ (mul (,(getf opt :f/) val-f val-t) :type ,(getf opt :element-type)))
(,(getf opt :value-writer) mul t-sto t-of)))))))
(if fortran-func
`(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
@@ -135,7 +135,7 @@
(mod-dotimes (idx (dimensions to))
with (linear-sums
(t-of (strides to) (head to)))
- do (let-typed ((scal-val (/ alpha (,(getf opt :reader) t-sto t-of)) :type ,(getf opt :element-type)))
+ do (let-typed ((scal-val (,(getf opt :f/) alpha (,(getf opt :reader) t-sto t-of)) :type ,(getf opt :element-type)))
(,(getf opt :value-writer) scal-val t-sto t-of)))))))
(if fortran-func
`(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
@@ -144,7 +144,7 @@
((and call-fortran? min-stride)
(let ((num-array (,(getf opt :store-allocator) 1)))
(declare (type ,(linear-array-type (getf opt :store-type)) num-array))
- (let-typed ((id (,(getf opt :coercer) 1) :type ,(getf opt :element-type)))
+ (let-typed ((id (,(getf opt :fid*)) :type ,(getf opt :element-type)))
(,(getf opt :value-writer) id num-array 0))
(,fortran-func (number-of-elements to) num-array 0 (store to) min-stride (head to))))
(t
-----------------------------------------------------------------------
Summary of changes:
matlisp.asd | 8 +-
src/classes/complex-tensor.lisp | 4 +
src/level-1/dot.lisp | 124 ++++++++++++++++++--------------------
src/level-1/scal.lisp | 10 ++--
4 files changed, 72 insertions(+), 74 deletions(-)
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2012-12-25 20:48:00
|
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, extensible has been created
at 376399e23fbbb868c8eb3ef80ee8bc9c65c5d98e (commit)
- Log -----------------------------------------------------------------
commit 376399e23fbbb868c8eb3ef80ee8bc9c65c5d98e
Author: Akshay Srinivasan <aks...@gm...>
Date: Tue Dec 25 14:39:13 2012 -0600
o Got rid of the "counterclass" hashtable. Everything now resides in
*tensor-class-optimization*, and in the symbol-plist associated with
tensor class name.
o Ported some L-1 routines to the new architecture.
diff --git a/matlisp.asd b/matlisp.asd
index 61cf5b1..d573c09 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -133,20 +133,22 @@
(:file "swap")
(:file "copy"
:depends-on ("tensor-maker"))
- (:file "scal"
+ #+nil(:file "scal"
:depends-on ("copy" "tensor-maker"))
- (:file "realimag"
+ #+nil(:file "realimag"
:depends-on ("copy"))
- (:file "dot"
+ #+nil(:file "dot"
:depends-on ("realimag"))
- (:file "axpy"
+ #+nil(:file "axpy"
:depends-on ("copy" "scal"))
- (:file "trans"
+ #+nil(:file "trans"
:depends-on ("scal" "copy"))))
+ #+nil
(:module "matlisp-level-2"
:pathname "level-2"
:depends-on ("matlisp-base" "matlisp-classes" "foreign-core" "matlisp-level-1")
:components ((:file "gemv")))
+ #+nil
(:module "matlisp-level-3"
:pathname "level-3"
:depends-on ("matlisp-base" "matlisp-classes" "foreign-core" "matlisp-level-1")
@@ -155,11 +157,13 @@
:pathname "lapack"
:depends-on ("matlisp-base" "matlisp-classes" "matlisp-level-1" "matlisp-level-2" "matlisp-level-3")
:components ((:file "gesv")))
+ #+nil
(:module "matlisp-sugar"
:pathname "sugar"
:depends-on ("matlisp-base" "matlisp-classes" "matlisp-level-1" "matlisp-level-2" "matlisp-level-3")
:components ((:file "mplusminus")
(:file "mtimesdivide")))
+ #+nil
(:module "matlisp-reader"
:pathname "reader"
:components ((:file "infix")))))
diff --git a/src/base/blas-helpers.lisp b/src/base/blas-helpers.lisp
index 86391ca..0092bf9 100644
--- a/src/base/blas-helpers.lisp
+++ b/src/base/blas-helpers.lisp
@@ -28,8 +28,7 @@
(defun consecutive-store-p (tensor)
(declare (type standard-tensor tensor))
- (mlet* (((sort-std std-perm) (let-typed ((strd (strides tensor) :type index-store-vector))
- (very-quickly (sort-permute (copy-seq (strides tensor)) #'<)))
+ (mlet* (((sort-std std-perm) (very-quickly (sort-permute (copy-seq (strides tensor)) #'<))
:type (index-store-vector permutation))
(perm-dims (permute (dimensions tensor) std-perm) :type index-store-vector))
(very-quickly
diff --git a/src/base/standard-tensor.lisp b/src/base/standard-tensor.lisp
index 0691120..e27d9d8 100644
--- a/src/base/standard-tensor.lisp
+++ b/src/base/standard-tensor.lisp
@@ -121,29 +121,6 @@
(error 'tensor-not-vector :rank (rank old))))
;;
-(defvar *tensor-counterclass* (make-hash-table)
- "
- Contains the CLOS counterpart classes of every tensor class.
- This is used to change the tensor class automatically to a matrix
- and vector")
-
-(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))
-
-;;
(defvar *tensor-class-optimizations* (make-hash-table)
"
Contains a either:
@@ -170,8 +147,14 @@
o class-name (symbol) of the superclass whose optimizations
are to be made use of.")
-(defun get-tensor-class-optimization (clname)
+(definline get-tensor-class-optimization (clname)
(declare (type symbol clname))
+ (symbol-plist clname))
+
+(definline get-tensor-object-optimization (obj)
+ (symbol-plist (class-name (class-of obj))))
+
+(defun get-tensor-class-optimization-hashtable (clname)
(let ((opt (gethash clname *tensor-class-optimizations*)))
(cond
((null opt) nil)
@@ -180,7 +163,10 @@
(t (values opt clname)))))
(defun (setf get-tensor-class-optimization) (value clname)
- (setf (gethash clname *tensor-class-optimizations*) value))
+ (setf (gethash clname *tensor-class-optimizations*) value
+ (symbol-plist clname) (if (symbolp value)
+ (get-tensor-class-optimization-hashtable clname)
+ value)))
;; Akshay: I have no idea what this does, or why we want it
;; (inherited from standard-matrix.lisp
@@ -366,9 +352,6 @@
())
(defclass ,vector (standard-vector ,tensor-class)
())
- (setf (get-tensor-counterclass ',tensor-class) (list :matrix ',matrix :vector ',vector)
- (get-tensor-counterclass ',matrix) ',tensor-class
- (get-tensor-counterclass ',vector) ',tensor-class)
;;Store refs
(defmethod tensor-store-ref ((tensor ,tensor-class) idx)
(declare (type index-type idx))
@@ -381,7 +364,10 @@
(,value-writer value store idx)))
;;
(let ((hst (list
- :field-type ',element-type
+ :tensor ',tensor-class
+ :matrix ',matrix
+ :vector ',vector
+ :element-type ',element-type
:f+ ',f+
:f- ',f-
:finv+ ',finv+
@@ -397,9 +383,11 @@
:store-allocator ',store-allocator
:coercer ',coercer
:coercer-unforgiving ',coercer-unforgiving
- :element-type ',element-type
:store-type ',store-element-type)))
- (setf (get-tensor-class-optimization ',tensor-class) hst))))
+ (setf (get-tensor-class-optimization ',tensor-class) hst
+ (get-tensor-class-optimization ',matrix) ',tensor-class
+ (get-tensor-class-optimization ',vector) ',tensor-class)
+ (setf (symbol-plist ',tensor-class) hst))))
;;
(defgeneric tensor-ref (tensor subscripts)
@@ -499,11 +487,9 @@
(declare (type standard-tensor ten))
(= (slot-value ten 'rank) 1))
-(defun square-p (tensor)
- (let* ((rank (rank tensor))
- (sym (gensym))
- (lst (make-list rank :initial-element sym)))
- (apply #'tensor-type-p (list tensor lst))))
+(definline square-p (tensor)
+ (let-typed ((dims (dimensions tensor) :type index-store-vector))
+ (lvec-foldr #'(lambda (a b) (if (eq a b) a nil)) dims)))
;;---------------------------------------------------------------;;
@@ -585,8 +571,9 @@
(make-instance
(let ((nrnk (length ndim)))
(if (> nrnk 2) (class-name (class-of tensor))
- (let ((cocl (get-tensor-counterclass (class-name (class-of tensor)))))
- (assert cocl nil 'tensor-cannot-find-counter-class :tensor-class (class-name (class-of tensor)))
- (ecase nrnk (2 (getf cocl :matrix)) (1 (getf cocl :vector))))))
+ (let ((cocl (getf (symbol-plist (class-name (class-of tensor))) (ecase nrnk (2 :matrix) (1 :vector)))))
+ (assert cocl nil 'tensor-cannot-find-optimization :tensor-class (class-name (class-of tensor)))
+ cocl)))
: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 3bb2f58..97e6656 100644
--- a/src/classes/complex-tensor.lisp
+++ b/src/classes/complex-tensor.lisp
@@ -12,8 +12,39 @@
(deftype complex-type ()
"Complex number with Re, Im parts in complex-base-type."
'(cl:complex complex-base-type))
-;;
+;;Field operations
+(definline complex-type.f+ (a b)
+ (declare (type complex-type a b))
+ (+ a b))
+
+(definline complex-type.f- (a b)
+ (declare (type complex-type a b))
+ (- a b))
+
+(definline complex-type.finv+ (a)
+ (declare (type complex-type a))
+ (- a))
+
+(definline complex-type.fid+ ()
+ #c(0.0d0 0.0d0))
+
+(definline complex-type.f* (a b)
+ (declare (type complex-type a b))
+ (* a b))
+
+(definline complex-type.f/ (a b)
+ (declare (type complex-type a b))
+ (/ a b))
+
+(definline complex-type.finv* (a)
+ (declare (type complex-type a))
+ (/ a))
+
+(definline complex-type.fid* ()
+ #c(1.0d0 0.0d0))
+
+;;Store operations
(definline allocate-complex-store (size)
"
(allocate-complex-store size)
@@ -36,24 +67,56 @@
(defun coerce-complex-base (x)
(restart-case (coerce-complex-base-unforgiving x)
(use-value (value) (coerce-complex-base value))))
-
;;
-(defclass complex-tensor (standard-tensor)
- ((store :type complex-store-vector)
- (element-type :initform 'complex-type))
- (:documentation "Tensor class with complex elements."))
-
-(defclass complex-matrix (standard-matrix complex-tensor)
- ()
- (:documentation "Matrix class with complex elements."))
-
-(defclass complex-vector (standard-vector complex-tensor)
- ()
- (:documentation "Vector class with complex elements."))
+(definline complex-type.reader (tstore idx)
+ (declare (type complex-store-vector tstore)
+ (type index-type idx))
+ (complex (aref tstore (* 2 idx))
+ (aref tstore (1+ (* 2 idx)))))
+
+(definline complex-type.value-writer (value store idx)
+ (declare (type complex-store-vector store)
+ (type index-type idx)
+ (type complex-type value))
+ (setf (aref store (* 2 idx)) (realpart value)
+ (aref store (1+ (* 2 idx))) (imagpart value)))
+
+(definline complex-type.reader-writer (fstore fidx tstore tidx)
+ (declare (type complex-store-vector fstore tstore)
+ (type index-type fidx tidx))
+ (setf (aref tstore (* 2 tidx)) (aref fstore (* 2 fidx))
+ (aref tstore (1+ (* 2 tidx))) (aref fstore (1+ (* 2 fidx)))))
+
+(definline complex-type.swapper (fstore fidx tstore tidx)
+ (declare (type complex-store-vector fstore tstore)
+ (type index-type fidx tidx))
+ (rotatef (aref tstore (* 2 tidx)) (aref fstore (* 2 fidx)))
+ (rotatef (aref tstore (1+ (* 2 tidx))) (aref fstore (1+ (* 2 fidx)))))
+;;
-(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)
+(define-tensor (complex-tensor complex-type complex-base-type complex-store-vector
+ (:documentation "Tensor class with complex elements."))
+ :matrix complex-matrix :vector complex-vector
+ ;;
+ :f+ complex-type.f+
+ :f- complex-type.f-
+ :finv+ complex-type.finv+
+ :fid+ complex-type.fid+
+ :f* complex-type.f*
+ :f/ complex-type.f/
+ :finv* complex-type.finv*
+ :fid* complex-type.fid*
+ ;;
+ :store-allocator allocate-complex-store
+ :coercer coerce-complex
+ :coercer-unforgiving coerce-complex-unforgiving
+ ;;
+ :matrix complex-matrix :vector complex-vector
+ ;;
+ :reader complex-type.reader
+ :value-writer complex-type.value-writer
+ :reader-writer complex-type.reader-writer
+ :swapper complex-type.swapper)
;;
(defmethod initialize-instance ((tensor complex-tensor) &rest initargs)
@@ -64,31 +127,7 @@
(setf (store tensor) (allocate-complex-store size)
(store-size tensor) size)))
(call-next-method))
-;;
-(tensor-store-defs (complex-tensor complex-type complex-base-type)
- :store-allocator allocate-complex-store
- :coercer coerce-complex-unforgiving
- :reader
- (lambda (tstore idx)
- (complex (aref tstore (* 2 idx))
- (aref tstore (1+ (* 2 idx)))))
- :value-writer
- (lambda (value store idx)
- (setf (aref store (* 2 idx)) (realpart value)
- (aref store (1+ (* 2 idx))) (imagpart value)))
- :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)))))
- :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 (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/matrix.lisp b/src/classes/matrix.lisp
index dc7999c..78ea722 100644
--- a/src/classes/matrix.lisp
+++ b/src/classes/matrix.lisp
@@ -32,7 +32,7 @@
Purpose
=======
Return T if X is a row matrix (number of columns is 1)"
- (tensor-type-p matrix '(1 *)))
+ (tensor-typep matrix '(1 *)))
(definline col-matrix-p (matrix)
"
@@ -43,7 +43,7 @@
Purpose
=======
Return T if X is a column matrix (number of rows is 1)"
- (tensor-type-p matrix '(* 1)))
+ (tensor-typep matrix '(* 1)))
(definline row-or-col-matrix-p (matrix)
"
diff --git a/src/classes/real-tensor.lisp b/src/classes/real-tensor.lisp
index 7e22544..8b0a9ec 100644
--- a/src/classes/real-tensor.lisp
+++ b/src/classes/real-tensor.lisp
@@ -74,7 +74,8 @@ Allocates real storage. Default initial-element = 0d0.")
(use-value (value) (coerce-real value))))
;;
-(define-tensor (real-tensor real-type real-type real-store-vector)
+(define-tensor (real-tensor real-type real-type real-store-vector
+ (:documentation "Tensor class with real double elements."))
:matrix real-matrix :vector real-vector
;;
:f+ real-type.f+
@@ -106,9 +107,6 @@ Allocates real storage. Default initial-element = 0d0.")
(slot-value tensor 'store-size) size)))
(call-next-method))
-(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/conditions.lisp b/src/conditions.lisp
index 5fdbfed..87a526a 100644
--- a/src/conditions.lisp
+++ b/src/conditions.lisp
@@ -204,13 +204,6 @@
(when (slots-boundp c 'argument 'argument-stride)
(format stream "Stride of argument ~A must be >= 0, initialized with ~A." (argument c) (stride c))))))
-(define-condition tensor-cannot-find-counter-class (tensor-error)
- ((tensor-class :reader tensor-class :initarg :tensor-class))
- (:documentation "Cannot find the counter-class list of the given tensor class")
- (:report (lambda (c stream)
- (when (slots-boundp c 'tensor-class)
- (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))
(:documentation "Cannot find optimization information for the given tensor class")
diff --git a/src/level-1/copy.lisp b/src/level-1/copy.lisp
index 96f2786..4e5b665 100644
--- a/src/level-1/copy.lisp
+++ b/src/level-1/copy.lisp
@@ -32,20 +32,13 @@
;;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)))
+ (let* ((opt (get-tensor-class-optimization-hashtable tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
`(definline ,func (from to)
(declare (type ,tensor-class from to))
- (let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
- (strd-p (when call-fortran? (blas-copyable-p from to))))
- (cond
- ((and strd-p call-fortran?)
- (,blas-func (number-of-elements from)
- (store from) (first strd-p)
- (store to) (second strd-p)
- (head from) (head to)))
- (t
- (let ((f-sto (store from))
+ ,(let
+ ((lisp-routine
+ `(let ((f-sto (store from))
(t-sto (store to)))
(declare (type ,(linear-array-type (getf opt :store-type)) f-sto t-sto))
(very-quickly
@@ -56,7 +49,19 @@
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)))))))
+ do (,(getf opt :reader-writer) f-sto f-of t-sto t-of))))))
+ (if blas-func
+ `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
+ (strd-p (when call-fortran? (blas-copyable-p from to))))
+ (cond
+ ((and strd-p call-fortran?)
+ (,blas-func (number-of-elements from)
+ (store from) (first strd-p)
+ (store to) (second strd-p)
+ (head from) (head to)))
+ (t
+ ,lisp-routine)))
+ lisp-routine))
to)))
(defmacro generate-typed-num-copy! (func (tensor-class blas-func fortran-lb))
@@ -64,32 +69,36 @@
;;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)))
+ (let* ((opt (get-tensor-class-optimization-hashtable tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
`(definline ,func (num-from to)
(declare (type ,tensor-class to)
(type ,(getf opt :element-type) num-from))
- (let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
- (min-stride (when call-fortran? (consecutive-store-p to))))
- (cond
- ((and call-fortran? min-stride)
- (let ((num-array (,(getf opt :store-allocator) 1)))
- (declare (type ,(linear-array-type (getf opt :store-type)) num-array))
- ,(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
+ ,(let
+ ((lisp-routine
+ `(let-typed
((t-sto (store to) :type ,(linear-array-type (getf opt :store-type))))
(very-quickly
(mod-dotimes (idx (dimensions to))
with (linear-sums
(t-of (strides to) (head to)))
- do ,(funcall (getf opt :value-writer) 'num-from 't-sto 't-of)))))))
- to)))
-
+ do (,(getf opt :value-writer) num-from t-sto t-of))))))
+ (if blas-func
+ `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
+ (min-stride (when call-fortran? (consecutive-store-p to))))
+ (cond
+ ((and call-fortran? min-stride)
+ (let ((num-array (,(getf opt :store-allocator) 1)))
+ (declare (type ,(linear-array-type (getf opt :store-type)) num-array))
+ (,(getf opt :value-writer) num-from num-array 0)
+ (,blas-func (number-of-elements to)
+ num-array 0
+ (store to) min-stride
+ 0 (head to))))
+ (t
+ ,lisp-routine)))
+ lisp-routine))
+ to)))
;;Real
(generate-typed-copy! real-typed-copy!
@@ -163,11 +172,10 @@
with the same elements. This is a copy of the tensor.
"
(declare (type standard-tensor tensor))
- (let* ((dims (dimensions tensor))
- (ret (make-array (lvec->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-store-vector dims))
+ (let*-typed ((dims (dimensions tensor) :type index-store-vector)
+ (ret (make-array (lvec->list dims)
+ :element-type (or (getf (get-tensor-object-optimization tensor) :element-type)
+ (error 'tensor-cannot-find-optimization :tensor-class (class-name (class-of tensor)))))))
(let ((lst (make-list (rank tensor))))
(very-quickly
(mod-dotimes (idx dims)
@@ -175,10 +183,10 @@
ret)))
(defmethod copy! :before ((x standard-tensor) (y array))
- (assert (subtypep (element-type x)
+ (assert (subtypep (getf (get-tensor-object-optimization x) :element-type)
(array-element-type y))
nil 'invalid-type
- :given (element-type x)
+ :given (getf (get-tensor-object-optimization x) :element-type)
:expected (array-element-type y))
(assert (and
(= (rank x) (array-rank y))
@@ -211,9 +219,9 @@
;;
(defmethod copy! :before ((x array) (y standard-tensor))
(assert (subtypep (array-element-type x)
- (element-type y))
+ (getf (get-tensor-object-optimization y) :element-type))
nil 'invalid-type
- :given (array-element-type x) :expected (element-type y))
+ :given (array-element-type x) :expected (getf (get-tensor-object-optimization y) :element-type))
(assert (and
(= (array-rank x) (rank y))
(dolist (ele (mapcar #'= (array-dimensions x) (lvec->list (dimensions y))) t)
diff --git a/src/level-1/scal.lisp b/src/level-1/scal.lisp
index 0aea8b7..223f78a 100644
--- a/src/level-1/scal.lisp
+++ b/src/level-1/scal.lisp
@@ -29,20 +29,13 @@
(in-package #:matlisp)
(defmacro generate-typed-scal! (func (tensor-class fortran-func fortran-lb))
- (let* ((opt (get-tensor-class-optimization tensor-class)))
+ (let* ((opt (get-tensor-class-optimization-hashtable tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
`(definline ,func (from to)
(declare (type ,tensor-class from to))
- (let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
- (strd-p (when call-fortran? (blas-copyable-p from to))))
- (cond
- ((and strd-p call-fortran?)
- (,fortran-func (number-of-elements from)
- (store from) (first strd-p)
- (store to) (second strd-p)
- (head from) (head to)))
- (t
- (let ((f-sto (store from))
+ ,(let
+ ((lisp-routine
+ `(let ((f-sto (store from))
(t-sto (store to)))
(declare (type ,(linear-array-type (getf opt :store-type)) f-sto t-sto))
(very-quickly
@@ -50,49 +43,59 @@
with (linear-sums
(f-of (strides from) (head from))
(t-of (strides to) (head to)))
- do (let*-typed ((val-f ,(funcall (getf opt :reader) 'f-sto 'f-of) :type ,(getf opt :element-type))
- (val-t ,(funcall (getf opt :reader) 't-sto 't-of) :type ,(getf opt :element-type))
+ do (let*-typed ((val-f (,(getf opt :reader) f-sto f-of) :type ,(getf opt :element-type))
+ (val-t (,(getf opt :reader) t-sto t-of) :type ,(getf opt :element-type))
(mul (* val-f val-t) :type ,(getf opt :element-type)))
- ,(funcall (getf opt :value-writer) 'mul 't-sto 't-of))))))))
+ (,(getf opt :value-writer) mul t-sto t-of)))))))
+ (if fortran-func
+ `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
+ (strd-p (when call-fortran? (blas-copyable-p from to))))
+ (cond
+ ((and strd-p call-fortran?)
+ (,fortran-func (number-of-elements from)
+ (store from) (first strd-p)
+ (store to) (second strd-p)
+ (head from) (head to)))
+ (t
+ ,lisp-routine)))
+ lisp-routine))
to)))
(defmacro generate-typed-num-scal! (func (tensor-class blas-func fortran-lb))
- (let ((opt (get-tensor-class-optimization tensor-class)))
+ (let ((opt (get-tensor-class-optimization-hashtable tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
`(definline ,func (alpha to)
(declare (type ,tensor-class to)
(type ,(getf opt :element-type) alpha))
- (let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
- (min-stride (when call-fortran? (consecutive-store-p to))))
- (cond
- ((and call-fortran? min-stride)
- (,blas-func (number-of-elements to) alpha (store to) min-stride (head to)))
- (t
- (let ((t-sto (store to)))
+ ,(let
+ ((lisp-routine
+ `(let ((t-sto (store to)))
(declare (type ,(linear-array-type (getf opt :store-type)) t-sto))
(very-quickly
(mod-dotimes (idx (dimensions to))
with (linear-sums
(t-of (strides to) (head to)))
- do (let ((scal-val (* ,(funcall (getf opt :reader) 't-sto 't-of) alpha)))
- ,(funcall (getf opt :value-writer) 'scal-val 't-sto 't-of))))))))
+ do (let ((scal-val (* (,(getf opt :reader) t-sto t-of) alpha)))
+ (,(getf opt :value-writer) scal-val t-sto t-of)))))))
+ (if blas-func
+ `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
+ (min-stride (when call-fortran? (consecutive-store-p to))))
+ (cond
+ ((and call-fortran? min-stride)
+ (,blas-func (number-of-elements to) alpha (store to) min-stride (head to)))
+ (t
+ ,lisp-routine)))
+ lisp-routine))
to)))
(defmacro generate-typed-div! (func (tensor-class fortran-func fortran-lb))
- (let* ((opt (get-tensor-class-optimization tensor-class)))
+ (let* ((opt (get-tensor-class-optimization-hashtable tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
`(definline ,func (from to)
(declare (type ,tensor-class from to))
- (let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
- (strd-p (when call-fortran? (blas-copyable-p from to))))
- (cond
- ((and strd-p call-fortran?)
- (,fortran-func (number-of-elements from)
- (store from) (first strd-p)
- (store to) (second strd-p)
- (head from) (head to)))
- (t
- (let ((f-sto (store from))
+ ,(let
+ ((lisp-routine
+ `(let ((f-sto (store from))
(t-sto (store to)))
(declare (type ,(linear-array-type (getf opt :store-type)) f-sto t-sto))
(very-quickly
@@ -100,10 +103,22 @@
with (linear-sums
(f-of (strides from) (head from))
(t-of (strides to) (head to)))
- do (let*-typed ((val-f ,(funcall (getf opt :reader) 'f-sto 'f-of) :type ,(getf opt :element-type))
- (val-t ,(funcall (getf opt :reader) 't-sto 't-of) :type ,(getf opt :element-type))
+ do (let*-typed ((val-f (,(getf opt :reader) f-sto f-of) :type ,(getf opt :element-type))
+ (val-t (,(getf opt :reader) t-sto t-of) :type ,(getf opt :element-type))
(mul (/ val-f val-t) :type ,(getf opt :element-type)))
- ,(funcall (getf opt :value-writer) 'mul 't-sto 't-of))))))))
+ (,(getf opt :value-writer) mul t-sto t-of)))))))
+ (if fortran-func
+ `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
+ (strd-p (when call-fortran? (blas-copyable-p from to))))
+ (cond
+ ((and strd-p call-fortran?)
+ (,fortran-func (number-of-elements from)
+ (store from) (first strd-p)
+ (store to) (second strd-p)
+ (head from) (head to)))
+ (t
+ ,lisp-routine)))
+ lisp-routine))
to)))
(defmacro generate-typed-num-div! (func (tensor-class fortran-func fortran-lb))
@@ -112,24 +127,29 @@
`(definline ,func (alpha to)
(declare (type ,tensor-class to)
(type ,(getf opt :element-type) alpha))
- (let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
- (min-stride (when call-fortran? (consecutive-store-p to))))
- (cond
- ((and call-fortran? min-stride)
- (let ((num-array (,(getf opt :store-allocator) 1)))
- (declare (type ,(linear-array-type (getf opt :store-type)) num-array))
- (let-typed ((id (,(getf opt :coercer) 1) :type ,(getf opt :element-type)))
- ,(funcall (getf opt :value-writer) `id 'num-array 0))
- (,fortran-func (number-of-elements to) num-array 0 (store to) min-stride (head to))))
- (t
- (let ((t-sto (store to)))
+ ,(let
+ ((lisp-routine
+ `(let ((t-sto (store to)))
(declare (type ,(linear-array-type (getf opt :store-type)) t-sto))
(very-quickly
(mod-dotimes (idx (dimensions to))
with (linear-sums
(t-of (strides to) (head to)))
- do (let-typed ((scal-val (/ alpha ,(funcall (getf opt :reader) 't-sto 't-of)) :type ,(getf opt :element-type)))
- ,(funcall (getf opt :value-writer) 'scal-val 't-sto 't-of))))))))
+ do (let-typed ((scal-val (/ alpha (,(getf opt :reader) t-sto t-of)) :type ,(getf opt :element-type)))
+ (,(getf opt :value-writer) scal-val t-sto t-of)))))))
+ (if fortran-func
+ `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
+ (min-stride (when call-fortran? (consecutive-store-p to))))
+ (cond
+ ((and call-fortran? min-stride)
+ (let ((num-array (,(getf opt :store-allocator) 1)))
+ (declare (type ,(linear-array-type (getf opt :store-type)) num-array))
+ (let-typed ((id (,(getf opt :coercer) 1) :type ,(getf opt :element-type)))
+ (,(getf opt :value-writer) id num-array 0))
+ (,fortran-func (number-of-elements to) num-array 0 (store to) min-stride (head to))))
+ (t
+ ,lisp-routine)))
+ lisp-routine))
to)))
;;Real
diff --git a/src/level-1/swap.lisp b/src/level-1/swap.lisp
index f2eb094..9de6966 100644
--- a/src/level-1/swap.lisp
+++ b/src/level-1/swap.lisp
@@ -32,25 +32,30 @@
;;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)))
+ (let* ((opt (get-tensor-class-optimization-hashtable tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
`(definline ,func (x y)
(declare (type ,tensor-class x y))
- (let* ((call-fortran? (> (number-of-elements x) ,fortran-lb))
- (strd-p (when call-fortran? (blas-copyable-p x y))))
- (cond
- ((and strd-p call-fortran?)
- (,blas-func (number-of-elements x) (store x) (first strd-p) (store y) (second strd-p) (head x) (head y)))
- (t
- (let ((f-sto (store x))
+ ,(let
+ ((lisp-routine
+ `(let ((f-sto (store x))
(t-sto (store y)))
- (declare (type ,(linear-array-type (getf opt :store-type)) f-sto t-sto))
- (very-quickly
- (mod-dotimes (idx (dimensions x))
- with (linear-sums
- (f-of (strides x) (head x))
- (t-of (strides y) (head y)))
- do ,(funcall (getf opt :swapper) 'f-sto 'f-of 't-sto 't-of)))))))
+ (declare (type ,(linear-array-type (getf opt :store-type)) f-sto t-sto))
+ (very-quickly
+ (mod-dotimes (idx (dimensions x))
+ with (linear-sums
+ (f-of (strides x) (head x))
+ (t-of (strides y) (head y)))
+ do (,(getf opt :swapper) f-sto f-of t-sto t-of))))))
+ (if blas-func
+ `(let* ((call-fortran? (> (number-of-elements x) ,fortran-lb))
+ (strd-p (when call-fortran? (blas-copyable-p x y))))
+ (cond
+ ((and strd-p call-fortran?)
+ (,blas-func (number-of-elements x) (store x) (first strd-p) (store y) (second strd-p) (head x) (head y)))
+ (t
+ ,lisp-routine)))
+ lisp-routine))
y)))
(generate-typed-swap! real-typed-swap!
diff --git a/src/level-1/tensor-maker.lisp b/src/level-1/tensor-maker.lisp
index 6f7cb3b..4ce8f18 100644
--- a/src/level-1/tensor-maker.lisp
+++ b/src/level-1/tensor-maker.lisp
@@ -1,10 +1,8 @@
(in-package #:matlisp)
(defmacro make-tensor-maker (func-name (tensor-class))
- (let ((opt (get-tensor-class-optimization tensor-class))
- (cocl (get-tensor-counterclass tensor-class)))
+ (let ((opt (get-tensor-class-optimization-hashtable tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
- (assert cocl nil 'tensor-cannot-find-counter-class :tensor-class tensor-class)
`(progn
(declaim (ftype (function (&rest t) ,tensor-class) ,func-name))
(defun ,func-name (&rest args)
@@ -14,7 +12,7 @@
(ss (very-quickly (lvec-foldl #'(lambda (x y) (the index-type (* x y))) vdim)))
(store (,(getf opt :store-allocator) ss))
(rnk (length vdim)))
- (make-instance (case rnk (2 ',(getf cocl :matrix)) (1 ',(getf cocl :vector)) (t ',tensor-class))
+ (make-instance (case rnk (2 ',(getf opt :matrix)) (1 ',(getf opt :vector)) (t ',tensor-class))
:store store :dimensions vdim)))
(make-from-array (arr)
(declare (type (array * *) arr))
@@ -26,7 +24,7 @@
(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 (lvec->list! idx lst))) 'st-r 'of-r))
+ do (,(getf opt :value-writer) (,(getf opt :coercer) (apply #'aref arr (lvec->list! idx lst))) st-r of-r))
ret))
(make-from-list (lst)
(let* ((ret (make-dims (list-dimensions lst)))
@@ -36,7 +34,7 @@
(list-loop (idx ele lst)
with (linear-sums
(of-r (strides ret) (head ret)))
- do ,(funcall (getf opt :value-writer) `(,(getf opt :coercer) ele) 'st-r 'of-r))
+ do (,(getf opt :value-writer) (,(getf opt :coercer) ele) st-r of-r))
ret)))
(let ((largs (length args)))
(if (= largs 1)
commit ff3082257b6f984b30131dd170f011eacd78f7e6
Author: Akshay Srinivasan <aks...@gm...>
Date: Sun Dec 23 17:16:26 2012 -0600
o Extended tensor-class-optimization with slots for underlying Field properties.
o Moved lots of stuff to define-tensor macro
diff --git a/src/base/standard-tensor.lisp b/src/base/standard-tensor.lisp
index 9899186..0691120 100644
--- a/src/base/standard-tensor.lisp
+++ b/src/base/standard-tensor.lisp
@@ -48,10 +48,6 @@
:accessor number-of-elements
:type index-type
:documentation "Total number of elements in the tensor.")
- (element-type
- :accessor element-type
- :type symbol
- :documentation "Element type of the tensor")
;;
(parent-tensor
:accessor parent-tensor
@@ -83,6 +79,7 @@
(defclass standard-matrix (standard-tensor)
((rank
:accessor rank
+ :allocation :class
:type index-type
:initform 2
:documentation "For a matrix, rank = 2."))
@@ -91,7 +88,7 @@
;;
(defmethod initialize-instance :after ((matrix standard-matrix) &rest initargs)
(declare (ignore initargs))
- (mlet*
+ (let-typed
((rank (rank matrix) :type index-type))
(unless (= rank 2)
(error 'tensor-not-matrix :rank rank :tensor matrix))))
@@ -105,6 +102,7 @@
(defclass standard-vector (standard-tensor)
((rank
:accessor rank
+ :allocation :class
:type index-type
:initform 1
:documentation "For a vector, rank = 1."))
@@ -149,10 +147,21 @@
(defvar *tensor-class-optimizations* (make-hash-table)
"
Contains a either:
- o A property list containing:
+ o A property list containing:
+ :field-type -> Field type
+ :f+ (a b) -> a + b
+ :f- (a b) -> a + (- b)
+ :finv+ (a) -> -a
+ :fid+ () -> + identity
+ :f* (a b) -> a * b
+ :f/ (a b) -> a * b^{-1}
+ :finv* (a) -> 1/a
+ :fid* () -> * identity
+
+ :coercer (ele) -> Coerced to store-type, with error checking
+ :coercer-unforgiving (ele) -> Coerced to store-type, no error checking
+
:store-allocator (n) -> Allocates a store of size n
- :coercer (ele) -> Coerced to store-type
- :element-type
:store-type
:reader (store idx) => result
:value-writer (value store idx) => (store idx) <- value
@@ -340,40 +349,57 @@
(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 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))
- (destructuring-bind (tstore idx) args
- `(defmethod tensor-store-ref ((,tensym ,tensor-class) ,idx)
- (declare (type index-type ,idx))
- (let ((,tstore (store ,tensym)))
- (declare (type ,(linear-array-type store-element-type) ,tstore))
- ,@body))))
- ,(destructuring-bind (lbd args &rest body) value-writer
- (assert (eq lbd 'lambda))
- (destructuring-bind (value tstore tidx) args
- `(defmethod (setf tensor-store-ref) (,value (,tensym ,tensor-class) ,tidx)
- (declare (type index-type ,tidx)
- (type ,element-type ,value))
- (let ((,tstore (store ,tensym)))
- (declare (type ,(linear-array-type store-element-type) ,tstore))
- ,@body))))
- (let ((hst (list
- :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
- :store-type ',store-element-type)))
- (setf (get-tensor-class-optimization ',tensor-class) hst)))))
+(defmacro define-tensor
+ ((tensor-class element-type store-element-type store-type &rest class-decls) &key
+ f+ f- finv+ fid+ f* f/ finv* fid*
+ matrix vector
+ store-allocator coercer coercer-unforgiving reader value-writer reader-writer swapper)
+ ;;Error checking
+ (assert (and f+ f- finv+ fid+ f* f/ finv* fid* store-allocator coercer coercer-unforgiving matrix vector reader value-writer reader-writer swapper))
+ ;;
+ `(progn
+ ;;Class definitions
+ (defclass ,tensor-class (standard-tensor)
+ ((store :type ,store-type))
+ ,@class-decls)
+ (defclass ,matrix (standard-matrix ,tensor-class)
+ ())
+ (defclass ,vector (standard-vector ,tensor-class)
+ ())
+ (setf (get-tensor-counterclass ',tensor-class) (list :matrix ',matrix :vector ',vector)
+ (get-tensor-counterclass ',matrix) ',tensor-class
+ (get-tensor-counterclass ',vector) ',tensor-class)
+ ;;Store refs
+ (defmethod tensor-store-ref ((tensor ,tensor-class) idx)
+ (declare (type index-type idx))
+ (let-typed ((store (store tensor) :type ,store-type))
+ (,reader store idx)))
+ (defmethod (setf tensor-store-ref) (value (tensor ,tensor-class) idx)
+ (declare (type index-type idx)
+ (type ,element-type value))
+ (let-typed ((store (store tensor) :type ,store-type))
+ (,value-writer value store idx)))
+ ;;
+ (let ((hst (list
+ :field-type ',element-type
+ :f+ ',f+
+ :f- ',f-
+ :finv+ ',finv+
+ :fid+ ',fid+
+ :f* ',f*
+ :f/ ',f/
+ :finv* ',finv*
+ :fid* ',fid*
+ :reader ',reader
+ :value-writer ',value-writer
+ :reader-writer ',reader-writer
+ :swapper ',swapper
+ :store-allocator ',store-allocator
+ :coercer ',coercer
+ :coercer-unforgiving ',coercer-unforgiving
+ :element-type ',element-type
+ :store-type ',store-element-type)))
+ (setf (get-tensor-class-optimization ',tensor-class) hst))))
;;
(defgeneric tensor-ref (tensor subscripts)
@@ -420,11 +446,11 @@
;;
-(defun tensor-type-p (tensor subscripts)
+(defun tensor-typep (tensor subscripts)
"
Syntax
======
- (tensor-type-p tensor subscripts)
+ (tensor-typep tensor subscripts)
Purpose
=======
@@ -434,14 +460,14 @@
Examples
========
Checking for a vector:
- > (tensor-type-p ten '(*))
+ > (tensor-typep ten '(*))
Checking for a matrix with 2 columns:
- > (tensor-type-p ten '(* 2))
+ > (tensor-typep ten '(* 2))
Also does symbolic association; checking for
a square matrix:
- > (tensor-type-p ten '(a a))
+ > (tensor-typep ten '(a a))
"
(declare (type standard-tensor tensor))
(mlet* (((rank dims) (slot-values tensor '(rank dimensions))
diff --git a/src/classes/real-tensor.lisp b/src/classes/real-tensor.lisp
index e7b8602..7e22544 100644
--- a/src/classes/real-tensor.lisp
+++ b/src/classes/real-tensor.lisp
@@ -7,8 +7,61 @@
(deftype real-store-vector (&optional (size '*))
"The type of the storage structure for a REAL-MATRIX"
`(simple-array real-type (,size)))
-;;
+;;Field definitions
+(definline real-type.f+ (a b)
+ (declare (type real-type a b))
+ (+ a b))
+
+(definline real-type.f- (a b)
+ (declare (type real-type a b))
+ (- a b))
+
+(definline real-type.finv+ (a)
+ (declare (type real-type a))
+ (- a))
+
+(definline real-type.fid+ ()
+ 0.0d0)
+
+(definline real-type.f* (a b)
+ (declare (type real-type a b))
+ (* a b))
+
+(definline real-type.f/ (a b)
+ (declare (type real-type a b))
+ (/ a b))
+
+(definline real-type.finv* (a)
+ (declare (type real-type a))
+ (/ a))
+
+(definline real-type.fid* ()
+ 1.0d0)
+
+;;Store definitions
+(definline real-type.reader (tstore idx)
+ (declare (type index-type idx)
+ (type real-store-vector tstore))
+ (aref tstore idx))
+
+(definline real-type.value-writer (value store idx)
+ (declare (type index-type idx)
+ (type real-store-vector store)
+ (type real-type value))
+ (setf (aref store idx) value))
+
+(definline real-type.reader-writer (fstore fidx tstore tidx)
+ (declare (type index-type fidx tidx)
+ (type real-store-vector fstore tstore))
+ (setf (aref tstore tidx) (aref fstore fidx)))
+
+(definline real-type.swapper (fstore fidx tstore tidx)
+ (declare (type index-type fidx tidx)
+ (type real-store-vector fstore tstore))
+ (rotatef (aref tstore tidx) (aref fstore fidx)))
+
+;;
(make-array-allocator allocate-real-store 'real-type 0d0
"(allocate-real-store size [initial-element])
Allocates real storage. Default initial-element = 0d0.")
@@ -21,22 +74,28 @@ Allocates real storage. Default initial-element = 0d0.")
(use-value (value) (coerce-real value))))
;;
-(defclass real-tensor (standard-tensor)
- ((store :type real-store-vector)
- (element-type :initform 'real-type))
- (:documentation "Tensor class with real elements."))
-
-(defclass real-matrix (standard-matrix real-tensor)
- ()
- (:documentation "A class of matrices with real elements."))
-
-(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)
+(define-tensor (real-tensor real-type real-type real-store-vector)
+ :matrix real-matrix :vector real-vector
+ ;;
+ :f+ real-type.f+
+ :f- real-type.f-
+ :finv+ real-type.finv+
+ :fid+ real-type.fid+
+ :f* real-type.f*
+ :f/ real-type.f/
+ :finv* real-type.finv*
+ :fid* real-type.fid*
+ ;;
+ :store-allocator allocate-real-store
+ :coercer coerce-real
+ :coercer-unforgiving coerce-real-unforgiving
+ ;;
+ :matrix real-matrix :vector real-vector
+ ;;
+ :reader real-type.reader
+ :value-writer real-type.value-writer
+ :reader-writer real-type.reader-writer
+ :swapper real-type.swapper)
;;
(defmethod initialize-instance ((tensor real-tensor) &rest initargs)
@@ -47,23 +106,6 @@ Allocates real storage. Default initial-element = 0d0.")
(slot-value tensor 'store-size) size)))
(call-next-method))
-;;
-(tensor-store-defs (real-tensor real-type real-type)
- :store-allocator allocate-real-store
- :coercer coerce-real-unforgiving
- :reader
- (lambda (tstore idx)
- (aref tstore idx))
- :value-writer
- (lambda (value store idx)
- (setf (aref store idx) value))
- :reader-writer
- (lambda (fstore fidx tstore tidx)
- (setf (aref tstore tidx) (aref fstore fidx)))
- :swapper
- (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)
-----------------------------------------------------------------------
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2012-08-13 18:44:40
|
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 c0ba7e46b390f6e744e6865192b6eb57eb95c585 (commit)
from 4c6e88337126ac9344c8735b98f54aaa69daa99e (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 c0ba7e46b390f6e744e6865192b6eb57eb95c585
Author: Akshay Srinivasan <aks...@gm...>
Date: Tue Aug 14 00:07:52 2012 +0530
o Added a very quick sort-permute function.
o Added conditions to avoid BLAS checks, when it is known that the fortran function
is not going to be called (removes overhead).
diff --git a/src/base/blas-helpers.lisp b/src/base/blas-helpers.lisp
index 00f8bc6..86391ca 100644
--- a/src/base/blas-helpers.lisp
+++ b/src/base/blas-helpers.lisp
@@ -4,7 +4,9 @@
(defun blas-copyable-p (ten-a ten-b)
(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-store-vector permutation))
+ (((sort-std-a std-a-perm) (let-typed ((std-a (strides ten-a) :type index-store-vector))
+ (very-quickly (sort-permute (copy-seq std-a) #'<)))
+ :type (index-store-vector permutation-action))
(perm-a-dims (permute (dimensions ten-a) std-a-perm) :type index-store-vector)
;;If blas-copyable then the strides must have the same sorting permutation.
(sort-std-b (permute (strides ten-b) std-a-perm) :type index-store-vector)
@@ -26,7 +28,9 @@
(defun consecutive-store-p (tensor)
(declare (type standard-tensor tensor))
- (mlet* (((sort-std std-perm) (idx-sort-permute (copy-seq (strides tensor)) #'<) :type (index-store-vector permutation))
+ (mlet* (((sort-std std-perm) (let-typed ((strd (strides tensor) :type index-store-vector))
+ (very-quickly (sort-permute (copy-seq (strides tensor)) #'<)))
+ :type (index-store-vector permutation))
(perm-dims (permute (dimensions tensor) std-perm) :type index-store-vector))
(very-quickly
(loop
diff --git a/src/base/permutation.lisp b/src/base/permutation.lisp
index e43cad1..81a5281 100644
--- a/src/base/permutation.lisp
+++ b/src/base/permutation.lisp
@@ -28,30 +28,6 @@
do (setf (aref ret i) i)))
ret))
-(defun perrepr-max (seq)
- (declare (type perrepr-vector seq))
- (very-quickly
- (loop for ele of-type perrepr-type across seq
- for idx of-type index-type = 0 then (+ idx 1)
- with max of-type perrepr-type = (aref seq 0)
- with max-idx of-type index-type = 0
- do (when (> ele max)
- (setf max ele
- max-idx idx))
- finally (return (values max max-idx)))))
-
-(defun perrepr-min (seq)
- (declare (type perrepr-vector seq))
- (very-quickly
- (loop for ele of-type perrepr-type across seq
- for idx of-type index-type = 0 then (+ idx 1)
- with min of-type perrepr-type = (aref seq 0)
- with min-idx of-type index-type = 0
- do (when (< ele min)
- (setf min ele
- min-idx idx))
- finally (return (values min min-idx)))))
-
(definline perv (&rest contents)
(make-array (length contents) :element-type 'perrepr-type :initial-contents contents))
@@ -133,7 +109,7 @@
for cyc of-type perrepr-vector in (repr per)
unless (cycle-repr-p cyc)
do (error 'permutation-invalid-error)
- maximizing (perrepr-max cyc) into g-rnk of-type index-type
+ maximizing (lvec-max cyc) into g-rnk of-type index-type
finally (setf (group-rank per) (the index-type (1+ g-rnk))))))))
;;
@@ -392,7 +368,7 @@
do (let ((val (aref idiv i)))
(unless (= val i)
(rotatef (aref act i) (aref act val))))))
- (make-instance 'permutation-action :repr act))))
+ (make-instance 'permutation-action :repr act))))
(defun mod-max (seq lidx uidx)
(declare (type perrepr-vector seq))
@@ -460,62 +436,67 @@
(lambda (&rest args)
(apply func-a (permute! (multiple-value-list (funcall func-b args)) perm))))
;;
-
-;;Optimize: pick different pivot.
-(defgeneric sort-permute (seq predicate)
- (:documentation "
- (sort-permute seq predicate)
-
- Sorts the given sequence and return
- the permutation required to move
- from the given sequence to the sorted form.
- "))
-
-(defun idx-sort-permute (seq predicate)
+
+(definline 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.
+ Sorts a lisp-vector in-place, by using the function @arg{predicate} as the
+ order. Also computes the permutation which would sort the original sequence
+ @arg{seq}.
"
- (declare (type index-store-vector seq)
- (type function predicate))
- (let* ((len (length seq))
- (perm (perrepr-id-action len)))
- (declare (type index-type len)
- (type perrepr-vector perm))
- (labels ((qsort-bounds (todo)
- (declare (type list todo))
- (if (null todo) t
- (destructuring-bind (lb ub) (pop todo)
- (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)))))
- ;;The things we do for tail recursion!
- (when (> (- ub ele-idx) 2)
- (push (list (1+ ele-idx) ub) todo))
- (when (> (- ele-idx lb) 1)
- (push (list lb ele-idx) todo))
- (qsort-bounds todo)))))))
- (qsort-bounds `((0 ,len)))
- (values seq (action->cycle (make-paction perm))))))
-;;Add a general sorter, this is a very useful thing to have.
-;;Add a function to apply permutations to a matrices, tensors.
+ (declare (type vector seq))
+ ;;This function is ugly of-course, but is also very very quick!
+ (let*-typed ((len (length seq) :type fixnum)
+ (perm (perrepr-id-action len) :type perrepr-vector)
+ (jobs (list `(0 ,len))))
+ (loop ;;:repeat 10
+ :for bounds := (pop jobs) :then (pop jobs)
+ :until (null bounds)
+ :finally (return (values seq (make-instance 'permutation-action :repr perm)))
+ :do (let*-typed ((below-idx (first bounds) :type fixnum)
+ (above-idx (second bounds) :type fixnum)
+ (piv (+ below-idx (floor (- above-idx below-idx) 2)) :type fixnum))
+ (loop ;;:repeat 10
+ :with ele := (aref seq piv)
+ :with lbound :of-type fixnum := below-idx
+ :with ubound :of-type fixnum := (1- above-idx)
+ :until (progn
+ ;;(format t "~%~a ~%" (list lbound piv ubound))
+ (loop :for i :of-type fixnum :from lbound :to piv
+ :until (or (= i piv) (funcall predicate ele (aref seq i)))
+ :finally (setq lbound i))
+ (loop :for i :of-type fixnum :downfrom ubound :to piv
+ :until (or (= i piv) (funcall predicate (aref seq i) ele))
+ :finally (setq ubound i))
+ ;;(format t "~a ~%" (list lbound piv ubound))
+ (cond
+ ((= ubound lbound piv)
+ (when (> (- piv below-idx) 1)
+ (push `(,below-idx ,piv) jobs))
+ (when (> (- above-idx (1+ piv)) 1)
+ (push `(,(1+ piv) ,above-idx) jobs))
+ ;;(format t "~a~%" jobs)
+ t)
+ ((< lbound piv ubound)
+ (rotatef (aref seq lbound) (aref seq ubound))
+ (rotatef (aref perm lbound) (aref perm ubound))
+ (incf lbound)
+ (decf ubound)
+ nil)
+ ((= lbound piv)
+ (rotatef (aref seq piv) (aref seq (1+ piv)))
+ (rotatef (aref perm piv) (aref perm (1+ piv)))
+ (unless (= ubound (1+ piv))
+ (rotatef (aref seq piv) (aref seq ubound))
+ (rotatef (aref perm piv) (aref perm ubound)))
+ (incf piv)
+ (incf lbound)
+ nil)
+ ((= ubound piv)
+ (rotatef (aref seq (1- piv)) (aref seq piv))
+ (rotatef (aref perm (1- piv)) (aref perm piv))
+ (unless (= lbound (1- piv))
+ (rotatef (aref seq lbound) (aref seq piv))
+ (rotatef (aref perm lbound) (aref perm piv)))
+ (decf piv)
+ (decf ubound)
+ nil))))))))
diff --git a/src/level-1/axpy.lisp b/src/level-1/axpy.lisp
index ec77357..df29906 100644
--- a/src/level-1/axpy.lisp
+++ b/src/level-1/axpy.lisp
@@ -37,11 +37,11 @@
`(definline ,func (alpha from to)
(declare (type ,tensor-class from to)
(type ,(getf opt :element-type) alpha))
- (let ((strd-p (blas-copyable-p from to))
- (call-fortran? (> (number-of-elements to)
- ,fortran-lb)))
+ (let* ((call-fortran? (> (number-of-elements to)
+ ,fortran-lb))
+ (strd-p (when call-fortran? (blas-copyable-p from to))))
(cond
- ((and strd-p call-fortran?)
+ ((and call-fortran? strd-p)
(,blas-func (number-of-elements from) alpha
(store from) (first strd-p)
(store to) (second strd-p)
@@ -76,10 +76,10 @@
`(definline ,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)))
+ (let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
+ (min-strd (when call-fortran? (consecutive-store-p to))))
(cond
- ((and min-strd call-fortran?)
+ ((and call-fortran? min-strd)
(let ((num-array (,(getf opt :store-allocator) 1)))
(declare (type ,(linear-array-type (getf opt :store-type)) num-array))
(let-typed ((id (,(getf opt :coercer) 1) :type ,(getf opt :element-type)))
diff --git a/src/level-1/copy.lisp b/src/level-1/copy.lisp
index a9ee5ee..96f2786 100644
--- a/src/level-1/copy.lisp
+++ b/src/level-1/copy.lisp
@@ -36,8 +36,8 @@
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
`(definline ,func (from to)
(declare (type ,tensor-class from to))
- (let ((strd-p (blas-copyable-p from to))
- (call-fortran? (> (number-of-elements to) ,fortran-lb)))
+ (let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
+ (strd-p (when call-fortran? (blas-copyable-p from to))))
(cond
((and strd-p call-fortran?)
(,blas-func (number-of-elements from)
@@ -69,10 +69,10 @@
`(definline ,func (num-from to)
(declare (type ,tensor-class to)
(type ,(getf opt :element-type) num-from))
- (let ((min-stride (consecutive-store-p to))
- (call-fortran? (> (number-of-elements to) ,fortran-lb)))
+ (let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
+ (min-stride (when call-fortran? (consecutive-store-p to))))
(cond
- ((and min-stride call-fortran?)
+ ((and call-fortran? min-stride)
(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)
diff --git a/src/level-1/scal.lisp b/src/level-1/scal.lisp
index 2a573d7..0aea8b7 100644
--- a/src/level-1/scal.lisp
+++ b/src/level-1/scal.lisp
@@ -33,8 +33,8 @@
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
`(definline ,func (from to)
(declare (type ,tensor-class from to))
- (let ((strd-p (blas-copyable-p from to))
- (call-fortran? (> (number-of-elements to) ,fortran-lb)))
+ (let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
+ (strd-p (when call-fortran? (blas-copyable-p from to))))
(cond
((and strd-p call-fortran?)
(,fortran-func (number-of-elements from)
@@ -62,10 +62,10 @@
`(definline ,func (alpha to)
(declare (type ,tensor-class to)
(type ,(getf opt :element-type) alpha))
- (let ((min-stride (consecutive-store-p to))
- (call-fortran? (> (number-of-elements to) ,fortran-lb)))
+ (let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
+ (min-stride (when call-fortran? (consecutive-store-p to))))
(cond
- ((and min-stride call-fortran?)
+ ((and call-fortran? min-stride)
(,blas-func (number-of-elements to) alpha (store to) min-stride (head to)))
(t
(let ((t-sto (store to)))
@@ -83,8 +83,8 @@
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
`(definline ,func (from to)
(declare (type ,tensor-class from to))
- (let ((strd-p (blas-copyable-p from to))
- (call-fortran? (> (number-of-elements to) ,fortran-lb)))
+ (let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
+ (strd-p (when call-fortran? (blas-copyable-p from to))))
(cond
((and strd-p call-fortran?)
(,fortran-func (number-of-elements from)
@@ -112,10 +112,10 @@
`(definline ,func (alpha to)
(declare (type ,tensor-class to)
(type ,(getf opt :element-type) alpha))
- (let ((min-stride (consecutive-store-p to))
- (call-fortran? (> (number-of-elements to) ,fortran-lb)))
+ (let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
+ (min-stride (when call-fortran? (consecutive-store-p to))))
(cond
- ((and min-stride call-fortran?)
+ ((and call-fortran? min-stride)
(let ((num-array (,(getf opt :store-allocator) 1)))
(declare (type ,(linear-array-type (getf opt :store-type)) num-array))
(let-typed ((id (,(getf opt :coercer) 1) :type ,(getf opt :element-type)))
diff --git a/src/level-1/swap.lisp b/src/level-1/swap.lisp
index 8c4a790..f2eb094 100644
--- a/src/level-1/swap.lisp
+++ b/src/level-1/swap.lisp
@@ -36,8 +36,8 @@
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
`(definline ,func (x y)
(declare (type ,tensor-class x y))
- (let ((strd-p (blas-copyable-p x y))
- (call-fortran? (> (number-of-elements x) ,fortran-lb)))
+ (let* ((call-fortran? (> (number-of-elements x) ,fortran-lb))
+ (strd-p (when call-fortran? (blas-copyable-p x y))))
(cond
((and strd-p call-fortran?)
(,blas-func (number-of-elements x) (store x) (first strd-p) (store y) (second strd-p) (head x) (head y)))
diff --git a/src/level-2/gemv.lisp b/src/level-2/gemv.lisp
index 8891d33..c483454 100644
--- a/src/level-2/gemv.lisp
+++ b/src/level-2/gemv.lisp
@@ -15,49 +15,49 @@
(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))))
- (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)))
+ ((call-fortran? (> (max (nrows A) (ncols A)) ,fortran-call-lb))
+ ((maj-A ld-A fop-A) (if call-fortran? (blas-matrix-compatible-p A job) (values nil 0 "?")) :type (symbol index-type (string 1))))
+ (cond
+ ((and maj-a call-fortran?)
+ (let-typed ((nr-A (nrows A) :type index-type)
+ (nc-A (ncols A) :type index-type))
+ (when (eq maj-A :row-major)
+ (rotatef nr-A nc-A))
+ (,blas-gemv-func fop-a nr-A nc-A
+ alpha (store A) ld-A
+ (store x) (aref (strides x) 0)
+ beta
+ (store y) (aref (strides y) 0)
+ (head A) (head x) (head y))))
+ (t
+ (let-typed ((nr-A (nrows A) :type index-type)
+ (nc-A (ncols A) :type index-type)
+ (rs-A (row-stride A) :type index-type)
+ (cs-A (col-stride A) :type index-type)
+ (sto-A (store A) :type ,(linear-array-type (getf opt :store-type)))
;
- (stp-x (aref (strides x) 0) :type index-type)
- (sto-x (store x) :type ,(linear-array-type (getf opt :store-type)))
- (hd-x (head x) :type index-type)
+ (stp-x (aref (strides x) 0) :type index-type)
+ (sto-x (store x) :type ,(linear-array-type (getf opt :store-type)))
+ (hd-x (head x) :type index-type)
;
- (stp-y (aref (strides y) 0) :type index-type)
- (sto-y (store y) :type ,(linear-array-type (getf opt :store-type))))
- (when (eq job :t)
- (rotatef nr-A nc-A)
- (rotatef rs-A cs-A))
- (very-quickly
- (loop repeat nr-A
- for of-y of-type index-type = (head y) then (+ of-y stp-y)
- for rof-A of-type index-type = (head A) then (+ rof-A rs-A)
- do (let-typed ((val (* 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)))
+ (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)))
;;Real
(generate-typed-gemv! real-base-typed-gemv!
diff --git a/src/level-3/gemm.lisp b/src/level-3/gemm.lisp
index 386c193..e6ba5ab 100644
--- a/src/level-3/gemm.lisp
+++ b/src/level-3/gemm.lisp
@@ -41,115 +41,115 @@
(: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)))
- ,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)
- (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)
- (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
- (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
- (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 ((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
- (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)))))))))))
+ (call-fortran? (> (max (nrows C) (ncols C) (if (eq job-A :n) (ncols A) (nrows A)))
+ ,fortran-lb-parameter))
+ ((maj-A ld-A fop-A) (if call-fortran? (blas-matrix-compatible-p A job-A) (values nil 0 "?")) :type (symbol index-type (string 1)))
+ ((maj-B ld-B fop-B) (if call-fortran? (blas-matrix-compatible-p B job-B) (values nil 0 "?")) :type (symbol index-type (string 1)))
+ ((maj-C ld-C fop-C) (if call-fortran? (blas-matrix-compatible-p C :n) (values nil 0 "?")) :type (symbol index-type nil)))
+ (cond
+ ((and call-fortran? 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))))
+ ((and call-fortran? maj-A)
+ (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
+ (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 call-fortran? maj-B)
+ (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
+ (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 ((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
+ (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)))
;;Real
-----------------------------------------------------------------------
Summary of changes:
src/base/blas-helpers.lisp | 8 +-
src/base/permutation.lisp | 147 +++++++++++++-----------------
src/level-1/axpy.lisp | 14 ++--
src/level-1/copy.lisp | 10 +-
src/level-1/scal.lisp | 20 ++--
src/level-1/swap.lisp | 4 +-
src/level-2/gemv.lisp | 82 ++++++++--------
src/level-3/gemm.lisp | 218 ++++++++++++++++++++++----------------------
8 files changed, 244 insertions(+), 259 deletions(-)
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2012-08-13 04:28:10
|
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 4c6e88337126ac9344c8735b98f54aaa69daa99e (commit)
from 375d3a119c4645b92fcc78767c0dba0a97c7450b (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 4c6e88337126ac9344c8735b98f54aaa69daa99e
Author: Akshay Srinivasan <aks...@gm...>
Date: Mon Aug 13 09:53:01 2012 +0530
Inserted copyright herald in infix.lisp. Added mtimesdivide.lisp to the repository.
diff --git a/src/reader/infix.lisp b/src/reader/infix.lisp
index 841b1ce..adaeabb 100644
--- a/src/reader/infix.lisp
+++ b/src/reader/infix.lisp
@@ -253,6 +253,33 @@
(in-package #:matlisp-infix)
(pushnew :matlisp-infix *features*)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defparameter *version* "1.3 28-JUN-96")
+ (defparameter *print-infix-copyright* nil
+ "If non-NIL, prints a copyright notice upon loading this file.")
+
+ (defun infix-copyright (&optional (stream *standard-output*))
+ "Prints an INFIX copyright notice and header upon startup."
+ (format stream "~%;;; ~V,,,'*A" 73 "*")
+ (format stream "~%;;; Infix notation for Common Lisp.")
+ (format stream "~%;;; Version ~A." *version*)
+ (format stream "~%;;; Written by Mark Kantrowitz, ~
+ CMU School of Computer Science.")
+ (format stream "~%;;; Copyright (c) 1993-95. All rights reserved.")
+ (format stream "~%;;; May be freely redistributed, provided this ~
+ notice is left intact.")
+ (format stream "~%;;; This software is made available AS IS, without ~
+ any warranty.")
+ (format stream "~%;;; ~V,,,'*A~%" 73 "*")
+ (force-output stream))
+
+ ;; What this means is you can either turn off the copyright notice
+ ;; by setting the parameter, or you can turn it off by including
+ ;; (setf (get :infix :dont-print-copyright) t) in your lisp init file.
+ (when (and *print-infix-copyright*
+ (not (get :infix :dont-print-copyright)))
+ (infix-copyright)))
+
;;; ********************************
;;; Readtable **********************
;;; ********************************
@@ -714,7 +741,7 @@
'newline))
(define-token-operator newline
- :infix (let* ((ign (ignore-characters +parser-ignored-characters+ stream))
+ :infix (let* ((ign (ignore-characters +blank-characters+ stream))
(pchar (peek-char nil stream t nil t)))
(case pchar
(#\)
diff --git a/src/sugar/mtimesdivide.lisp b/src/sugar/mtimesdivide.lisp
new file mode 100644
index 0000000..de87e4e
--- /dev/null
+++ b/src/sugar/mtimesdivide.lisp
@@ -0,0 +1,7 @@
+(in-package #:matlisp)
+
+(definline m./! (a b)
+ (div! a b))
+
+(definline m./ (a b)
+ (div a b))
-----------------------------------------------------------------------
Summary of changes:
src/reader/infix.lisp | 29 ++++++++++++++++++++++++++++-
src/sugar/mtimesdivide.lisp | 7 +++++++
2 files changed, 35 insertions(+), 1 deletions(-)
create mode 100644 src/sugar/mtimesdivide.lisp
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2012-08-11 04:54:28
|
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 375d3a119c4645b92fcc78767c0dba0a97c7450b (commit)
from 4f3bb155a516c02c49dd085b37283ca431f4d24b (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 375d3a119c4645b92fcc78767c0dba0a97c7450b
Author: Akshay Srinivasan <aks...@gm...>
Date: Fri Aug 10 15:13:16 2012 +0530
o Added support for #I .. I# inline syntax
diff --git a/src/reader/infix.lisp b/src/reader/infix.lisp
index dd48ac0..841b1ce 100644
--- a/src/reader/infix.lisp
+++ b/src/reader/infix.lisp
@@ -253,33 +253,6 @@
(in-package #:matlisp-infix)
(pushnew :matlisp-infix *features*)
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defparameter *version* "1.3 28-JUN-96")
- (defparameter *print-infix-copyright* t
- "If non-NIL, prints a copyright notice upon loading this file.")
-
- (defun infix-copyright (&optional (stream *standard-output*))
- "Prints an INFIX copyright notice and header upon startup."
- (format stream "~%;;; ~V,,,'*A" 73 "*")
- (format stream "~%;;; Infix notation for Common Lisp.")
- (format stream "~%;;; Version ~A." *version*)
- (format stream "~%;;; Written by Mark Kantrowitz, ~
- CMU School of Computer Science.")
- (format stream "~%;;; Copyright (c) 1993-95. All rights reserved.")
- (format stream "~%;;; May be freely redistributed, provided this ~
- notice is left intact.")
- (format stream "~%;;; This software is made available AS IS, without ~
- any warranty.")
- (format stream "~%;;; ~V,,,'*A~%" 73 "*")
- (force-output stream))
-
- ;; What this means is you can either turn off the copyright notice
- ;; by setting the parameter, or you can turn it off by including
- ;; (setf (get :infix :dont-print-copyright) t) in your lisp init file.
- (when (and *print-infix-copyright*
- (not (get :infix :dont-print-copyright)))
- (infix-copyright)))
-
;;; ********************************
;;; Readtable **********************
;;; ********************************
@@ -291,23 +264,30 @@
`(let ((*readtable* *normal-readtable*))
(error 'parser-error :message (format-to-string ,format-string ,@args))))
+
+(define-constant +blank-characters+ '(#\^m #\space #\tab #\return #\newline))
+(define-constant +newline-characters+ '(#\newline #\^m #\linefeed #\return))
+
+(defun ignore-characters (ignore stream)
+ (let ((ret nil))
+ (do ((char (peek-char nil stream t nil t)
+ (peek-char nil stream t nil t)))
+ ((not (member char ignore :test #'char=)))
+ (push (read-char stream t nil t) ret))
+ ret))
+
+(defun unread-characters (chars stream)
+ (mapcar #'(lambda (x) (unread-char x stream)) chars))
+
(defun infix-reader (stream subchar arg)
;; Read either #I(...) or #I"..."
(declare (ignore arg subchar))
- (let ((first-char (peek-char nil stream t nil t)))
- (cond ((char= first-char #\space)
- (read-char stream) ; skip over whitespace
- (infix-reader stream nil nil))
- ((char= first-char #\")
- ;; Read double-quote-delimited infix expressions.
- (string->prefix (read stream t nil t)))
- ((char= first-char #\()
- (read-char stream) ; get rid of opening left parenthesis
- (let ((*readtable* *infix-readtable*)
- (*normal-readtable* *readtable*))
- (read-infix stream)))
- (t
- (infix-error "Infix expression starts with ~A" first-char)))))
+ (ignore-characters +blank-characters+ stream)
+ (when (char= (peek-char nil stream t nil t) #\()
+ (read-char stream))
+ (let ((*readtable* *infix-readtable*)
+ (*normal-readtable* *readtable*))
+ (read-infix stream)))
(set-dispatch-macro-character #\# #\I #'infix-reader *readtable*) ; was #\# #\$
@@ -319,6 +299,12 @@
(read stream))
string))
+(defun infix-expand (string)
+ (if (stringp string)
+ (with-input-from-string (stream string)
+ (read stream))
+ string))
+
(defun read-infix (stream)
(let* ((result (gather-superiors '\) stream)) ; %infix-end-token%
(next-token (read-token stream)))
@@ -343,8 +329,7 @@
(symbolp y)
(string-equal (symbol-name x) (symbol-name y))))
-;;; Peeking Token Reader
-
+;;; Peeking Token Reade
(defvar *peeked-token* nil)
(defun read-token (stream)
(if *peeked-token*
@@ -479,7 +464,7 @@
( or )
;; Where should setf and friends go in the precedence?
( = |:=| += -= *= /= )
- ( \, ) ; progn (statement delimiter)
+ ( \, newline ) ; progn (statement delimiter)
( if )
( then else )
( \] \) )
@@ -616,7 +601,7 @@
;;*--------------------------------------------------------------;;
(define-character-tokenization #\*
#'(lambda (stream char)
- (declare (ignore char))
+ (declare (ignore char))
(let ((pchar (peek-char nil stream t nil t)))
(case pchar
(#\=
@@ -719,9 +704,41 @@
(declare (ignore stream char))
'\,))
+;;Get rid of this
(define-token-operator \,
:infix `(progn ,left ,(gather-superiors '\, stream)))
+(define-character-tokenization #\Newline
+ #'(lambda (stream char)
+ (declare (ignore char stream))
+ 'newline))
+
+(define-token-operator newline
+ :infix (let* ((ign (ignore-characters +parser-ignored-characters+ stream))
+ (pchar (peek-char nil stream t nil t)))
+ (case pchar
+ (#\)
+ left)
+ (#\I
+ (read-char stream t nil t)
+ (if (char= (peek-char nil stream t nil t) #\#)
+ (progn
+ (unread-char #\I stream)
+ left)
+ (progn
+ (unread-characters (cons #\I ign) stream)
+ `(progn ,left ,(gather-superiors 'newline stream)))))
+ (t
+ `(progn ,left ,(gather-superiors 'newline stream))))))
+
+(define-character-tokenization #\I
+ #'(lambda (stream char)
+ (let ((pchar (peek-char nil stream t nil t)))
+ (if (char= pchar #\#)
+ (progn
+ (read-char stream t nil t)
+ (funcall (get-macro-character #\)) stream char))
+ 'i))))
;;---------------------------------------------------------------;;
(define-character-tokenization #\=
@@ -749,7 +766,7 @@
'|:=|)
(t
'|:|))))
-(define-token-operator |:=|
+(define-token-operator |:=|
:infix `(,(if (symbolp left)
'setq
'setf)
@@ -843,17 +860,6 @@
(define-token-operator \)
:infix (infix-error "Extra close paren \")\" in infix expression"))
-#|
-;;; Commented out because no longer using $ as the macro character.
-(define-character-tokenization #\$
- #'(lambda (stream char)
- (declare (ignore stream char))
- '%infix-end-token%))
-(define-token-operator %infix-end-token%
- :infix (infix-error "Prematurely terminated infix expression")
- :prefix (infix-error "Prematurely terminated infix expression"))
-|#
-
(define-character-tokenization #\;
#'(lambda (stream char)
(declare (ignore char))
@@ -1112,10 +1118,10 @@
((not (equal value result))
(format t "~&Test #I(~A) failed. ~
~& Expected ~A ~
- ~& but got ~A."
+ ~& but got ~A."
string result value)
nil)
(t
- t))))
+ t))))
;;; *EOF*
-----------------------------------------------------------------------
Summary of changes:
src/reader/infix.lisp | 124 +++++++++++++++++++++++++-----------------------
1 files changed, 65 insertions(+), 59 deletions(-)
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2012-08-09 10:16: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 4f3bb155a516c02c49dd085b37283ca431f4d24b (commit)
via b68ae3c41607d5c2efb16bb20e0b5398183bc0a1 (commit)
via 5a902f797e8dfef15f1d8d048c5f9ad156f1c192 (commit)
from 529111481665902bb1459b434d8d6607c2467ca4 (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 4f3bb155a516c02c49dd085b37283ca431f4d24b
Author: Akshay Srinivasan <aks...@gm...>
Date: Thu Aug 9 15:42:13 2012 +0530
Changed exponentiation operator from ^^ to **
diff --git a/src/reader/infix.lisp b/src/reader/infix.lisp
index 7bf947e..dd48ac0 100644
--- a/src/reader/infix.lisp
+++ b/src/reader/infix.lisp
@@ -289,7 +289,7 @@
(defmacro infix-error (format-string &rest args)
`(let ((*readtable* *normal-readtable*))
- (error 'parser-error (format-to-string ,format-string ,@args))))
+ (error 'parser-error :message (format-to-string ,format-string ,@args))))
(defun infix-reader (stream subchar arg)
;; Read either #I(...) or #I"..."
@@ -427,7 +427,7 @@
(let ((operator (get-token-prefix-operator token)))
(if operator
(funcall operator stream)
- (infix-error "~A is not a prefix operator" token))))
+ (infix-error "\"~A\" is not a prefix operator" token))))
(defun get-next-token (stream left)
(let ((token (read-token stream)))
@@ -437,14 +437,15 @@
(let ((operator (get-token-infix-operator token)))
(if operator
(funcall operator stream left)
- (infix-error "~A is not an infix operator" token))))
+ (infix-error "\"~A\" is not an infix operator" token))))
;;; Fix to read-delimited-list so that it works with tokens, not
;;; characters.
(defun infix-read-delimited-list (end-token delimiter-token stream)
(do ((next-token (peek-token stream) (peek-token stream))
- (list nil))
+ (list nil)
+ (count 0 (1+ count)))
((same-token-p next-token end-token)
;; We've hit the end. Remove the end-token from the stream.
(read-token stream)
@@ -452,7 +453,7 @@
;; Note that this does the right thing with [] and ().
(nreverse list))
;; Ignore the delimiters.
- (when (same-token-p next-token delimiter-token)
+ (when (and (same-token-p next-token delimiter-token) (> count 0))
(read-token stream))
;; Gather the expression until the next delimiter.
(push (gather-superiors delimiter-token stream) list)))
@@ -464,7 +465,7 @@
(defparameter *operator-ordering*
'(( \[ \( \! ) ; \[ is array reference
- ( ^^ ) ; exponentiation
+ ( ** ) ; exponentiation
( ~ ) ; lognot
( * / % ) ; % is mod
( + - )
@@ -492,7 +493,7 @@
((find op2 ops :test #'same-token-p)
(return t)))))
-(defparameter *right-associative-operators* '(^^ =))
+(defparameter *right-associative-operators* '(** =))
(defun operator-right-associative-p (operator)
(find operator *right-associative-operators*))
@@ -582,6 +583,7 @@
(define-token-operator else
:prefix (infix-error "ELSE clause without an IF."))
+;;---------------------------------------------------------------;;
(define-character-tokenization #\+
#'(lambda (stream char)
(declare (ignore char))
@@ -596,6 +598,7 @@
(define-token-operator +=
:infix `(incf ,left ,(gather-superiors '+= stream)))
+;;---------------------------------------------------------------;;
(define-character-tokenization #\-
#'(lambda (stream char)
(declare (ignore char))
@@ -610,16 +613,24 @@
(define-token-operator -=
:infix `(decf ,left ,(gather-superiors '-= stream)))
+;;*--------------------------------------------------------------;;
(define-character-tokenization #\*
#'(lambda (stream char)
- (declare (ignore char))
- (cond ((char= (peek-char nil stream t nil t) #\=)
- (read-char stream t nil t)
- '*=)
- (t
- '*))))
+ (declare (ignore char))
+ (let ((pchar (peek-char nil stream t nil t)))
+ (case pchar
+ (#\=
+ (read-char stream t nil t)
+ '*=)
+ (#\*
+ (read-char stream t nil t)
+ '**)
+ (t
+ '*)))))
+
(define-token-operator *
:infix `(* ,left ,(gather-superiors '* stream)))
+
(define-token-operator *=
:infix `(,(if (symbolp left)
'setq
@@ -627,6 +638,10 @@
,left
(* ,left ,(gather-superiors '*= stream))))
+(define-token-operator **
+ :infix `(expt ,left ,(gather-superiors '** stream)))
+
+;;---------------------------------------------------------------;;
(define-character-tokenization #\/
#'(lambda (stream char)
(declare (ignore char))
@@ -635,9 +650,11 @@
'/=)
(t
'/))))
+
(define-token-operator /
:infix `(/ ,left ,(gather-superiors '/ stream))
:prefix `(/ ,(gather-superiors '/ stream)))
+
(define-token-operator /=
:infix `(,(if (symbolp left)
'setq
@@ -645,19 +662,16 @@
,left
(/ ,left ,(gather-superiors '/= stream))))
+;;---------------------------------------------------------------;;
(define-character-tokenization #\^
#'(lambda (stream char)
- (declare (ignore char))
- (cond ((char= (peek-char nil stream t nil t) #\^)
- (read-char stream t nil t)
- '^^)
- (t
- '^))))
-(define-token-operator ^^
- :infix `(expt ,left ,(gather-superiors '^^ stream)))
+ (declare (ignore stream char))
+ '^))
+
(define-token-operator ^
:infix `(logxor ,left ,(gather-superiors '^ stream)))
+;;---------------------------------------------------------------;;
(define-character-tokenization #\|
#'(lambda (stream char)
(declare (ignore char))
@@ -669,6 +683,7 @@
(define-token-operator \|
:infix `(logior ,left ,(gather-superiors '\| stream)))
+;;---------------------------------------------------------------;;
(define-character-tokenization #\&
#'(lambda (stream char)
(declare (ignore char))
@@ -680,27 +695,35 @@
(define-token-operator \&
:infix `(logand ,left ,(gather-superiors '\& stream)))
+;;---------------------------------------------------------------;;
(define-character-tokenization #\%
#'(lambda (stream char)
(declare (ignore stream char))
'\%))
+
(define-token-operator \%
:infix `(mod ,left ,(gather-superiors '\% stream)))
+;;---------------------------------------------------------------;;
(define-character-tokenization #\~
#'(lambda (stream char)
(declare (ignore stream char))
'\~))
+
(define-token-operator \~
:prefix `(lognot ,(gather-superiors '\~ stream)))
+;;---------------------------------------------------------------;;
(define-character-tokenization #\,
#'(lambda (stream char)
(declare (ignore stream char))
'\,))
+
(define-token-operator \,
:infix `(progn ,left ,(gather-superiors '\, stream)))
+;;---------------------------------------------------------------;;
+
(define-character-tokenization #\=
#'(lambda (stream char)
(declare (ignore char))
@@ -816,6 +839,7 @@
#'(lambda (stream char)
(declare (ignore stream char))
'\)))
+
(define-token-operator \)
:infix (infix-error "Extra close paren \")\" in infix expression"))
@@ -931,14 +955,14 @@
("a*b*c" (* a b c))
("a*b+c" (+ (* a b) c))
("a/b" (/ a b))
- ("a^^b" (expt a b))
+ ("a**b" (expt a b))
("foo/-bar" (/ foo (- bar)))
- ("1+2*3^^4" (+ 1 (* 2 (expt 3 4))))
- ("1+2*3^^4+5" (+ 1 (* 2 (expt 3 4)) 5))
- ("2*3^^4+1" (+ (* 2 (expt 3 4)) 1))
- ("2+3^^4*5" (+ 2 (* (expt 3 4) 5)))
- ("2^^3^^4" (expt 2 (expt 3 4)))
- ("x^^2 + y^^2" (+ (expt x 2) (expt y 2)))
+ ("1+2*3**4" (+ 1 (* 2 (expt 3 4))))
+ ("1+2*3**4+5" (+ 1 (* 2 (expt 3 4)) 5))
+ ("2*3**4+1" (+ (* 2 (expt 3 4)) 1))
+ ("2+3**4*5" (+ 2 (* (expt 3 4) 5)))
+ ("2**3**4" (expt 2 (expt 3 4)))
+ ("x**2 + y**2" (+ (expt x 2) (expt y 2)))
("(1+2)/3" (/ (+ 1 2) 3))
("(a=b)" (setq a b))
("(a=b,b=c)" (progn (setq a b) (setq b c)))
@@ -1014,8 +1038,8 @@
("a/b*c" (* (/ a b) c))
("a/b/c" (/ a b c))
("/a/b" (/ (* a b)))
- ("a^^b^^c" (expt a (expt b c)))
- ("a(d)^^b^^c" (expt (a d) (expt b c)))
+ ("a**b**c" (expt a (expt b c)))
+ ("a(d)**b**c" (expt (a d) (expt b c)))
("a<b+c<d" (< a (+ b c) d))
("1*~2+3" (+ (* 1 (lognot 2)) 3))
("1+~2*3" (+ 1 (* (lognot 2) 3)))
@@ -1035,10 +1059,10 @@
("a%b" (mod a b))
;; Comment character -- must have carriage return after semicolon.
- ("x^^2 ; the x coordinate
- + y^^2 ; the y coordinate" :error)
- ("x^^2 ; the x coordinate
- + y^^2 ; the y coordinate
+ ("x**2 ; the x coordinate
+ + y**2 ; the y coordinate" :error)
+ ("x**2 ; the x coordinate
+ + y**2 ; the y coordinate
" (+ (expt x 2) (expt y 2)))
;; Errors
commit b68ae3c41607d5c2efb16bb20e0b5398183bc0a1
Author: Akshay Srinivasan <aks...@gm...>
Date: Thu Aug 9 15:39:54 2012 +0530
Tweaked error messages
diff --git a/src/conditions.lisp b/src/conditions.lisp
index 52f4673..5fdbfed 100644
--- a/src/conditions.lisp
+++ b/src/conditions.lisp
@@ -31,14 +31,14 @@
(defcondition dimension-mismatch (generic-error)
()
- (:method print-object ((c generic-error) stream)
- (format stream "Dimension mismatch.")
+ (:method print-object ((c dimension-mismatch) stream)
+ (format stream "Dimension mismatch.~%")
(call-next-method)))
(defcondition assumption-violated (generic-error)
()
(:method print-object ((c assumption-violated) stream)
- (format stream "An assumption assumed when writing the software has been violated. Proceed with caution.")
+ (format stream "An assumption assumed when writing the software has been violated. Proceed with caution.~%")
(call-next-method)))
(defcondition invalid-type (generic-error)
@@ -55,7 +55,7 @@
(:documentation "Given invalid arguments to the function.")
(:method print-object ((c invalid-arguments) stream)
(when (slot-boundp c 'argument-number)
- (format stream "The argument ~a, given to the function is invalid (or has not been given)." (argnum c)))
+ (format stream "The argument ~a, given to the function is invalid (or has not been given).~%" (argnum c)))
(call-next-method)))
(defcondition invalid-value (generic-error)
@@ -77,7 +77,10 @@
(defcondition parser-error (generic-error)
()
- (:documentation "Macro reader encountered an error while parsing the stream."))
+ (:documentation "Macro reader encountered an error while parsing the stream.")
+ (:method print-object ((c parser-error) stream)
+ (format stream "Macro reader encountered an error while parsing the stream.~%")
+ (call-next-method)))
(defcondition coercion-error (generic-error)
((from :reader from :initarg :from)
@@ -115,14 +118,14 @@
(:documentation "Object is not a permutation.")
(:report (lambda (c stream)
(declare (ignore c))
- (format stream "Object is not a permutation."))))
+ (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.")
+ (format stream "Cannot permute sequence.~%")
(when (slots-boundp c 'sequence-length 'group-rank)
(format stream "~%sequence-length : ~a group-rank: ~a" (seq-len c) (group-rank c))))))
commit 5a902f797e8dfef15f1d8d048c5f9ad156f1c192
Author: Akshay Srinivasan <aks...@gm...>
Date: Thu Aug 9 14:29:31 2012 +0530
Moved infix into a new package
diff --git a/AUTHORS b/AUTHORS
index 2617a30..5f68edf 100644
--- a/AUTHORS
+++ b/AUTHORS
@@ -6,3 +6,6 @@ It is now being refactored by Akshay Srinivasan.
Some of code was originally written by Nicholas Neuss for
Femlisp (www.femlisp.org); it has been used here
(with modification or otherwise) with the author's consent.
+
+The infix reader is modified and included here with the
+permission of its original author Mark Kantrowitz.
diff --git a/matlisp.asd b/matlisp.asd
index db5f43a..61cf5b1 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -160,10 +160,9 @@
:depends-on ("matlisp-base" "matlisp-classes" "matlisp-level-1" "matlisp-level-2" "matlisp-level-3")
:components ((:file "mplusminus")
(:file "mtimesdivide")))
- #+nil
(:module "matlisp-reader"
:pathname "reader"
- :components ((:file "slicing")))))
+ :components ((:file "infix")))))
;; (defclass f2cl-cl-source-file (asdf:cl-source-file)
diff --git a/packages.lisp b/packages.lisp
index 8d71112..276480c 100644
--- a/packages.lisp
+++ b/packages.lisp
@@ -64,7 +64,6 @@
#:tensor-store-not-consecutive
))
-;;foreign-vector stuff must go to ffi-...
(defpackage "MATLISP-UTILITIES"
(:use #:common-lisp #:matlisp-conditions)
(:export #:ensure-list
@@ -86,6 +85,11 @@
#:inlining #:definline
#:with-optimization #:quickly #:very-quickly #:slowly #:quickly-if))
+;;Modified version of Mark Kantrowitz' infix package.
+(defpackage "MATLISP-INFIX"
+ (:use #:common-lisp #:matlisp-conditions #:matlisp-utilities)
+ (:export #:test-infix #:string->prefix))
+
(defpackage "MATLISP-FFI"
(:use #:common-lisp #:cffi #:matlisp-utilities #:matlisp-conditions)
;; TODO: Check if this is implementation-agnostic.
diff --git a/src/reader/infix.lisp b/src/reader/infix.lisp
index c545434..7bf947e 100644
--- a/src/reader/infix.lisp
+++ b/src/reader/infix.lisp
@@ -250,13 +250,8 @@
;;; Package Cruft ******************
;;; ********************************
-(defpackage #:infix (:use #-:lucid #:common-lisp
- #+:lucid "LISP" #+:lucid "LUCID-COMMON-LISP")
- (:export #:test-infix #:string->prefix))
-
-(in-package #:infix)
-
-(pushnew :infix *features*)
+(in-package #:matlisp-infix)
+(pushnew :matlisp-infix *features*)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *version* "1.3 28-JUN-96")
@@ -294,7 +289,7 @@
(defmacro infix-error (format-string &rest args)
`(let ((*readtable* *normal-readtable*))
- (error ,format-string ,@args)))
+ (error 'parser-error (format-to-string ,format-string ,@args))))
(defun infix-reader (stream subchar arg)
;; Read either #I(...) or #I"..."
diff --git a/src/reader/slicing.lisp b/src/reader/slicing.lisp
index 692081e..63a2efb 100644
--- a/src/reader/slicing.lisp
+++ b/src/reader/slicing.lisp
@@ -59,138 +59,7 @@
(not (member x '(t nil))))
(numberp x)))
-(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 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))
- (idxp (x) (or (consp x)
- (and (symbolp x)
- (not (member x '(t nil))))
- (numberp x)))
- (get-idx-expr (limlst)
- (format t "~a~%" 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)
- (format t "~a ~%" ret)
- (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
- (#\[ 'matlisp:sub-tensor~)
- (#\{ 'matlisp: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)
diff --git a/src/utilities/macros.lisp b/src/utilities/macros.lisp
index 6871843..de09899 100644
--- a/src/utilities/macros.lisp
+++ b/src/utilities/macros.lisp
@@ -1,5 +1,8 @@
(in-package #:matlisp-utilities)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+;;Note to self: do not indent!
+
(defmacro define-constant (name value &optional doc)
"
Keeps the lisp implementation from defining constants twice.
@@ -464,4 +467,4 @@
`(with-optimization (:speed 1)
,@forms))
-
+)
diff --git a/src/utilities/string.lisp b/src/utilities/string.lisp
index 388bf1e..c15fd01 100644
--- a/src/utilities/string.lisp
+++ b/src/utilities/string.lisp
@@ -5,7 +5,4 @@
(apply #'concatenate (cons 'string strings)))
(defun format-to-string (fmt &rest args)
- (let ((ret (make-array 0 :element-type 'character :adjustable t :fill-pointer t)))
- (with-output-to-string (ostr ret)
- (apply #'format (append `(,ostr ,fmt) args)))
- ret))
+ (apply #'format (append (list nil fmt) args)))
-----------------------------------------------------------------------
Summary of changes:
AUTHORS | 3 +
matlisp.asd | 3 +-
packages.lisp | 6 ++-
src/conditions.lisp | 17 ++++---
src/reader/infix.lisp | 101 ++++++++++++++++++++--------------
src/reader/slicing.lisp | 131 ---------------------------------------------
src/utilities/macros.lisp | 5 ++-
src/utilities/string.lisp | 5 +--
8 files changed, 84 insertions(+), 187 deletions(-)
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2012-08-05 05:10:41
|
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 529111481665902bb1459b434d8d6607c2467ca4 (commit)
via 8fb9110abc5dac35858285c1b10a1cddc2e35024 (commit)
from 938bc521fe3431d9a4cbcc0c7bab9c4bb616aaf4 (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 529111481665902bb1459b434d8d6607c2467ca4
Author: Akshay Srinivasan <aks...@gm...>
Date: Sun Aug 5 09:53:58 2012 +0530
o Moved everything back to /lib-src
diff --git a/Makefile.am b/Makefile.am
index bc5d88f..075c2c5 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -1,6 +1,6 @@
-SUBDIRS = lib/matlisp lib/dfftpack lib/toms715 lib/odepack lib/colnew
+SUBDIRS = lib-src/matlisp lib-src/dfftpack lib-src/toms715 lib-src/odepack lib-src/colnew
if !EXT_BLAPACK
-SUBDIRS += lib/blas lib/lapack
+SUBDIRS += lib-src/blas lib-src/lapack
endif
#ACLOCAL_AMFLAGS = -I m4
@@ -12,14 +12,14 @@ F2C = @F2C@
# This should build all the libraries we need. Then we need to
# install them before we can build the lisp code.
all :
- (cd lib/matlisp; $(MAKE) install)
- (cd lib/dfftpack; $(MAKE) install)
- (cd lib/toms715; $(MAKE) install)
- (cd lib/odepack; $(MAKE) install)
- (cd lib/colnew; $(MAKE) install)
+ (cd lib-src/matlisp; $(MAKE) install)
+ (cd lib-src/dfftpack; $(MAKE) install)
+ (cd lib-src/toms715; $(MAKE) install)
+ (cd lib-src/odepack; $(MAKE) install)
+ (cd lib-src/colnew; $(MAKE) install)
if !EXT_BLAPACK
- (cd lib/blas; $(MAKE) install)
- (cd lib/lapack; $(MAKE) install)
+ (cd lib-src/blas; $(MAKE) install)
+ (cd lib-src/lapack; $(MAKE) install)
endif
$(MAKE) lisp
diff --git a/configure b/configure
index 42c2db1..c26fb60 100755
--- a/configure
+++ b/configure
@@ -789,7 +789,7 @@ enable_fast_install
with_gnu_ld
with_sysroot
enable_libtool_lock
-with_blas_lapack
+with_external_blas_lapack
'
ac_precious_vars='build_alias
host_alias
@@ -1444,7 +1444,7 @@ Optional Packages:
--with-gnu-ld assume the C compiler uses GNU ld [default=no]
--with-sysroot=DIR Search for dependent libraries within DIR
(or the compiler's sysroot if not specified).
- --with-blas-lapack=libpath
+ --with-external-blas-lapack=libpath
Location of the BLAS/LAPACK libraries
Some influential environment variables:
@@ -8907,10 +8907,6 @@ _lt_linker_boilerplate=`cat conftest.err`
$RM -r conftest*
-## CAVEAT EMPTOR:
-## There is no encapsulation within the following macros, do not change
-## the running order or otherwise move them around unless you know exactly
-## what you are doing...
if test -n "$compiler"; then
lt_prog_compiler_no_builtin_flag=
@@ -15287,9 +15283,9 @@ fi
# Allow user to use external BLAS/LAPACK library if available.
# We assume the standard names for the libraries: lib{blas, lapack}
-# Check whether --with-blas-lapack was given.
-if test "${with_blas_lapack+set}" = set; then :
- withval=$with_blas_lapack;
+# Check whether --with-external-blas-lapack was given.
+if test "${with_external_blas_lapack+set}" = set; then :
+ withval=$with_external_blas_lapack;
# Building with external BLAS
ext_blapack=true
BLAS_LAPACK_DIR="$withval/"
@@ -15415,7 +15411,7 @@ case $host in
*) share_ext=so ;;
esac
-ac_config_files="$ac_config_files Makefile start.lisp config.lisp lib/lazy-loader.lisp src/ffi/f77-mangling.lisp lib/blas/Makefile lib/lapack/Makefile lib/dfftpack/Makefile lib/toms715/Makefile lib/matlisp/Makefile lib/odepack/Makefile lib/colnew/Makefile"
+ac_config_files="$ac_config_files Makefile start.lisp config.lisp src/foreign-core/lazy-loader.lisp src/ffi/f77-mangling.lisp lib-src/blas/Makefile lib-src/lapack/Makefile lib-src/dfftpack/Makefile lib-src/toms715/Makefile lib-src/matlisp/Makefile lib-src/odepack/Makefile lib-src/colnew/Makefile"
echo FLIBS = $FLIBS
@@ -16538,15 +16534,15 @@ do
"Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;;
"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/foreign-core/lazy-loader.lisp") CONFIG_FILES="$CONFIG_FILES src/foreign-core/lazy-loader.lisp" ;;
"src/ffi/f77-mangling.lisp") CONFIG_FILES="$CONFIG_FILES src/ffi/f77-mangling.lisp" ;;
- "lib/blas/Makefile") CONFIG_FILES="$CONFIG_FILES lib/blas/Makefile" ;;
- "lib/lapack/Makefile") CONFIG_FILES="$CONFIG_FILES lib/lapack/Makefile" ;;
- "lib/dfftpack/Makefile") CONFIG_FILES="$CONFIG_FILES lib/dfftpack/Makefile" ;;
- "lib/toms715/Makefile") CONFIG_FILES="$CONFIG_FILES lib/toms715/Makefile" ;;
- "lib/matlisp/Makefile") CONFIG_FILES="$CONFIG_FILES lib/matlisp/Makefile" ;;
- "lib/odepack/Makefile") CONFIG_FILES="$CONFIG_FILES lib/odepack/Makefile" ;;
- "lib/colnew/Makefile") CONFIG_FILES="$CONFIG_FILES lib/colnew/Makefile" ;;
+ "lib-src/blas/Makefile") CONFIG_FILES="$CONFIG_FILES lib-src/blas/Makefile" ;;
+ "lib-src/lapack/Makefile") CONFIG_FILES="$CONFIG_FILES lib-src/lapack/Makefile" ;;
+ "lib-src/dfftpack/Makefile") CONFIG_FILES="$CONFIG_FILES lib-src/dfftpack/Makefile" ;;
+ "lib-src/toms715/Makefile") CONFIG_FILES="$CONFIG_FILES lib-src/toms715/Makefile" ;;
+ "lib-src/matlisp/Makefile") CONFIG_FILES="$CONFIG_FILES lib-src/matlisp/Makefile" ;;
+ "lib-src/odepack/Makefile") CONFIG_FILES="$CONFIG_FILES lib-src/odepack/Makefile" ;;
+ "lib-src/colnew/Makefile") CONFIG_FILES="$CONFIG_FILES lib-src/colnew/Makefile" ;;
*) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;;
esac
diff --git a/configure.ac b/configure.ac
index 330e6ba..d2ec52f 100644
--- a/configure.ac
+++ b/configure.ac
@@ -297,8 +297,8 @@ dnl fi
dnl
# Allow user to use external BLAS/LAPACK library if available.
# We assume the standard names for the libraries: lib{blas, lapack}
-AC_ARG_WITH([blas-lapack],
-AC_HELP_STRING([--with-blas-lapack=libpath], [Location of the BLAS/LAPACK libraries]),
+AC_ARG_WITH([external-blas-lapack],
+AC_HELP_STRING([--with-external-blas-lapack=libpath], [Location of the BLAS/LAPACK libraries]),
[
# Building with external BLAS
ext_blapack=true
@@ -416,15 +416,15 @@ AC_CONFIG_FILES([
Makefile
start.lisp
config.lisp
- lib/lazy-loader.lisp
+ src/foreign-core/lazy-loader.lisp
src/ffi/f77-mangling.lisp
- lib/blas/Makefile
- lib/lapack/Makefile
- lib/dfftpack/Makefile
- lib/toms715/Makefile
- lib/matlisp/Makefile
- lib/odepack/Makefile
- lib/colnew/Makefile
+ lib-src/blas/Makefile
+ lib-src/lapack/Makefile
+ lib-src/dfftpack/Makefile
+ lib-src/toms715/Makefile
+ lib-src/matlisp/Makefile
+ lib-src/odepack/Makefile
+ lib-src/colnew/Makefile
])
echo FLIBS = $FLIBS
diff --git a/lib/blas/.cvsignore b/lib-src/blas/.cvsignore
similarity index 100%
rename from lib/blas/.cvsignore
rename to lib-src/blas/.cvsignore
diff --git a/lib/blas/Makefile.am b/lib-src/blas/Makefile.am
similarity index 100%
rename from lib/blas/Makefile.am
rename to lib-src/blas/Makefile.am
diff --git a/lib/blas/dasum.f b/lib-src/blas/dasum.f
similarity index 100%
rename from lib/blas/dasum.f
rename to lib-src/blas/dasum.f
diff --git a/lib/blas/daxpy.f b/lib-src/blas/daxpy.f
similarity index 100%
rename from lib/blas/daxpy.f
rename to lib-src/blas/daxpy.f
diff --git a/lib/blas/dcabs1.f b/lib-src/blas/dcabs1.f
similarity index 100%
rename from lib/blas/dcabs1.f
rename to lib-src/blas/dcabs1.f
diff --git a/lib/blas/dcopy.f b/lib-src/blas/dcopy.f
similarity index 100%
rename from lib/blas/dcopy.f
rename to lib-src/blas/dcopy.f
diff --git a/lib/blas/ddot.f b/lib-src/blas/ddot.f
similarity index 100%
rename from lib/blas/ddot.f
rename to lib-src/blas/ddot.f
diff --git a/lib/blas/dgbmv.f b/lib-src/blas/dgbmv.f
similarity index 100%
rename from lib/blas/dgbmv.f
rename to lib-src/blas/dgbmv.f
diff --git a/lib/blas/dgemm.f b/lib-src/blas/dgemm.f
similarity index 100%
rename from lib/blas/dgemm.f
rename to lib-src/blas/dgemm.f
diff --git a/lib/blas/dgemv.f b/lib-src/blas/dgemv.f
similarity index 100%
rename from lib/blas/dgemv.f
rename to lib-src/blas/dgemv.f
diff --git a/lib/blas/dger.f b/lib-src/blas/dger.f
similarity index 100%
rename from lib/blas/dger.f
rename to lib-src/blas/dger.f
diff --git a/lib/blas/dnrm2.f b/lib-src/blas/dnrm2.f
similarity index 100%
rename from lib/blas/dnrm2.f
rename to lib-src/blas/dnrm2.f
diff --git a/lib/blas/drot.f b/lib-src/blas/drot.f
similarity index 100%
rename from lib/blas/drot.f
rename to lib-src/blas/drot.f
diff --git a/lib/blas/drotg.f b/lib-src/blas/drotg.f
similarity index 100%
rename from lib/blas/drotg.f
rename to lib-src/blas/drotg.f
diff --git a/lib/blas/dsbmv.f b/lib-src/blas/dsbmv.f
similarity index 100%
rename from lib/blas/dsbmv.f
rename to lib-src/blas/dsbmv.f
diff --git a/lib/blas/dscal.f b/lib-src/blas/dscal.f
similarity index 100%
rename from lib/blas/dscal.f
rename to lib-src/blas/dscal.f
diff --git a/lib/blas/dspmv.f b/lib-src/blas/dspmv.f
similarity index 100%
rename from lib/blas/dspmv.f
rename to lib-src/blas/dspmv.f
diff --git a/lib/blas/dspr.f b/lib-src/blas/dspr.f
similarity index 100%
rename from lib/blas/dspr.f
rename to lib-src/blas/dspr.f
diff --git a/lib/blas/dspr2.f b/lib-src/blas/dspr2.f
similarity index 100%
rename from lib/blas/dspr2.f
rename to lib-src/blas/dspr2.f
diff --git a/lib/blas/dswap.f b/lib-src/blas/dswap.f
similarity index 100%
rename from lib/blas/dswap.f
rename to lib-src/blas/dswap.f
diff --git a/lib/blas/dsymm.f b/lib-src/blas/dsymm.f
similarity index 100%
rename from lib/blas/dsymm.f
rename to lib-src/blas/dsymm.f
diff --git a/lib/blas/dsymv.f b/lib-src/blas/dsymv.f
similarity index 100%
rename from lib/blas/dsymv.f
rename to lib-src/blas/dsymv.f
diff --git a/lib/blas/dsyr.f b/lib-src/blas/dsyr.f
similarity index 100%
rename from lib/blas/dsyr.f
rename to lib-src/blas/dsyr.f
diff --git a/lib/blas/dsyr2.f b/lib-src/blas/dsyr2.f
similarity index 100%
rename from lib/blas/dsyr2.f
rename to lib-src/blas/dsyr2.f
diff --git a/lib/blas/dsyr2k.f b/lib-src/blas/dsyr2k.f
similarity index 100%
rename from lib/blas/dsyr2k.f
rename to lib-src/blas/dsyr2k.f
diff --git a/lib/blas/dsyrk.f b/lib-src/blas/dsyrk.f
similarity index 100%
rename from lib/blas/dsyrk.f
rename to lib-src/blas/dsyrk.f
diff --git a/lib/blas/dtbmv.f b/lib-src/blas/dtbmv.f
similarity index 100%
rename from lib/blas/dtbmv.f
rename to lib-src/blas/dtbmv.f
diff --git a/lib/blas/dtbsv.f b/lib-src/blas/dtbsv.f
similarity index 100%
rename from lib/blas/dtbsv.f
rename to lib-src/blas/dtbsv.f
diff --git a/lib/blas/dtpmv.f b/lib-src/blas/dtpmv.f
similarity index 100%
rename from lib/blas/dtpmv.f
rename to lib-src/blas/dtpmv.f
diff --git a/lib/blas/dtpsv.f b/lib-src/blas/dtpsv.f
similarity index 100%
rename from lib/blas/dtpsv.f
rename to lib-src/blas/dtpsv.f
diff --git a/lib/blas/dtrmm.f b/lib-src/blas/dtrmm.f
similarity index 100%
rename from lib/blas/dtrmm.f
rename to lib-src/blas/dtrmm.f
diff --git a/lib/blas/dtrmv.f b/lib-src/blas/dtrmv.f
similarity index 100%
rename from lib/blas/dtrmv.f
rename to lib-src/blas/dtrmv.f
diff --git a/lib/blas/dtrsm.f b/lib-src/blas/dtrsm.f
similarity index 100%
rename from lib/blas/dtrsm.f
rename to lib-src/blas/dtrsm.f
diff --git a/lib/blas/dtrsv.f b/lib-src/blas/dtrsv.f
similarity index 100%
rename from lib/blas/dtrsv.f
rename to lib-src/blas/dtrsv.f
diff --git a/lib/blas/dzasum.f b/lib-src/blas/dzasum.f
similarity index 100%
rename from lib/blas/dzasum.f
rename to lib-src/blas/dzasum.f
diff --git a/lib/blas/dznrm2.f b/lib-src/blas/dznrm2.f
similarity index 100%
rename from lib/blas/dznrm2.f
rename to lib-src/blas/dznrm2.f
diff --git a/lib/blas/icamax.f b/lib-src/blas/icamax.f
similarity index 100%
rename from lib/blas/icamax.f
rename to lib-src/blas/icamax.f
diff --git a/lib/blas/idamax.f b/lib-src/blas/idamax.f
similarity index 100%
rename from lib/blas/idamax.f
rename to lib-src/blas/idamax.f
diff --git a/lib/blas/isamax.f b/lib-src/blas/isamax.f
similarity index 100%
rename from lib/blas/isamax.f
rename to lib-src/blas/isamax.f
diff --git a/lib/blas/izamax.f b/lib-src/blas/izamax.f
similarity index 100%
rename from lib/blas/izamax.f
rename to lib-src/blas/izamax.f
diff --git a/lib/blas/lsame.f b/lib-src/blas/lsame.f
similarity index 100%
rename from lib/blas/lsame.f
rename to lib-src/blas/lsame.f
diff --git a/lib/blas/scabs1.f b/lib-src/blas/scabs1.f
similarity index 100%
rename from lib/blas/scabs1.f
rename to lib-src/blas/scabs1.f
diff --git a/lib/blas/xerbla.f b/lib-src/blas/xerbla.f
similarity index 100%
rename from lib/blas/xerbla.f
rename to lib-src/blas/xerbla.f
diff --git a/lib/blas/zaxpy.f b/lib-src/blas/zaxpy.f
similarity index 100%
rename from lib/blas/zaxpy.f
rename to lib-src/blas/zaxpy.f
diff --git a/lib/blas/zcopy.f b/lib-src/blas/zcopy.f
similarity index 100%
rename from lib/blas/zcopy.f
rename to lib-src/blas/zcopy.f
diff --git a/lib/blas/zdotc.f b/lib-src/blas/zdotc.f
similarity index 100%
rename from lib/blas/zdotc.f
rename to lib-src/blas/zdotc.f
diff --git a/lib/blas/zdotu.f b/lib-src/blas/zdotu.f
similarity index 100%
rename from lib/blas/zdotu.f
rename to lib-src/blas/zdotu.f
diff --git a/lib/blas/zdscal.f b/lib-src/blas/zdscal.f
similarity index 100%
rename from lib/blas/zdscal.f
rename to lib-src/blas/zdscal.f
diff --git a/lib/blas/zgbmv.f b/lib-src/blas/zgbmv.f
similarity index 100%
rename from lib/blas/zgbmv.f
rename to lib-src/blas/zgbmv.f
diff --git a/lib/blas/zgemm.f b/lib-src/blas/zgemm.f
similarity index 100%
rename from lib/blas/zgemm.f
rename to lib-src/blas/zgemm.f
diff --git a/lib/blas/zgemv.f b/lib-src/blas/zgemv.f
similarity index 100%
rename from lib/blas/zgemv.f
rename to lib-src/blas/zgemv.f
diff --git a/lib/blas/zgerc.f b/lib-src/blas/zgerc.f
similarity index 100%
rename from lib/blas/zgerc.f
rename to lib-src/blas/zgerc.f
diff --git a/lib/blas/zgeru.f b/lib-src/blas/zgeru.f
similarity index 100%
rename from lib/blas/zgeru.f
rename to lib-src/blas/zgeru.f
diff --git a/lib/blas/zhbmv.f b/lib-src/blas/zhbmv.f
similarity index 100%
rename from lib/blas/zhbmv.f
rename to lib-src/blas/zhbmv.f
diff --git a/lib/blas/zhemm.f b/lib-src/blas/zhemm.f
similarity index 100%
rename from lib/blas/zhemm.f
rename to lib-src/blas/zhemm.f
diff --git a/lib/blas/zhemv.f b/lib-src/blas/zhemv.f
similarity index 100%
rename from lib/blas/zhemv.f
rename to lib-src/blas/zhemv.f
diff --git a/lib/blas/zher.f b/lib-src/blas/zher.f
similarity index 100%
rename from lib/blas/zher.f
rename to lib-src/blas/zher.f
diff --git a/lib/blas/zher2.f b/lib-src/blas/zher2.f
similarity index 100%
rename from lib/blas/zher2.f
rename to lib-src/blas/zher2.f
diff --git a/lib/blas/zher2k.f b/lib-src/blas/zher2k.f
similarity index 100%
rename from lib/blas/zher2k.f
rename to lib-src/blas/zher2k.f
diff --git a/lib/blas/zherk.f b/lib-src/blas/zherk.f
similarity index 100%
rename from lib/blas/zherk.f
rename to lib-src/blas/zherk.f
diff --git a/lib/blas/zhpmv.f b/lib-src/blas/zhpmv.f
similarity index 100%
rename from lib/blas/zhpmv.f
rename to lib-src/blas/zhpmv.f
diff --git a/lib/blas/zhpr.f b/lib-src/blas/zhpr.f
similarity index 100%
rename from lib/blas/zhpr.f
rename to lib-src/blas/zhpr.f
diff --git a/lib/blas/zhpr2.f b/lib-src/blas/zhpr2.f
similarity index 100%
rename from lib/blas/zhpr2.f
rename to lib-src/blas/zhpr2.f
diff --git a/lib/blas/zrotg.f b/lib-src/blas/zrotg.f
similarity index 100%
rename from lib/blas/zrotg.f
rename to lib-src/blas/zrotg.f
diff --git a/lib/blas/zscal.f b/lib-src/blas/zscal.f
similarity index 100%
rename from lib/blas/zscal.f
rename to lib-src/blas/zscal.f
diff --git a/lib/blas/zswap.f b/lib-src/blas/zswap.f
similarity index 100%
rename from lib/blas/zswap.f
rename to lib-src/blas/zswap.f
diff --git a/lib/blas/zsymm.f b/lib-src/blas/zsymm.f
similarity index 100%
rename from lib/blas/zsymm.f
rename to lib-src/blas/zsymm.f
diff --git a/lib/blas/zsyr2k.f b/lib-src/blas/zsyr2k.f
similarity index 100%
rename from lib/blas/zsyr2k.f
rename to lib-src/blas/zsyr2k.f
diff --git a/lib/blas/zsyrk.f b/lib-src/blas/zsyrk.f
similarity index 100%
rename from lib/blas/zsyrk.f
rename to lib-src/blas/zsyrk.f
diff --git a/lib/blas/ztbmv.f b/lib-src/blas/ztbmv.f
similarity index 100%
rename from lib/blas/ztbmv.f
rename to lib-src/blas/ztbmv.f
diff --git a/lib/blas/ztbsv.f b/lib-src/blas/ztbsv.f
similarity index 100%
rename from lib/blas/ztbsv.f
rename to lib-src/blas/ztbsv.f
diff --git a/lib/blas/ztpmv.f b/lib-src/blas/ztpmv.f
similarity index 100%
rename from lib/blas/ztpmv.f
rename to lib-src/blas/ztpmv.f
diff --git a/lib/blas/ztpsv.f b/lib-src/blas/ztpsv.f
similarity index 100%
rename from lib/blas/ztpsv.f
rename to lib-src/blas/ztpsv.f
diff --git a/lib/blas/ztrmm.f |
|
From: Akshay S. <ak...@us...> - 2012-08-04 15:15:33
|
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 938bc521fe3431d9a4cbcc0c7bab9c4bb616aaf4 (commit)
via 9b50685d6952b3be9ff29473595b2694ea234b08 (commit)
via 0b4fcdfe7d12f45c1d46f3b42589a5f2ff54e8dc (commit)
from 7424dca3c956b58d494e938ed7acf90abc79d086 (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 938bc521fe3431d9a4cbcc0c7bab9c4bb616aaf4
Author: Akshay Srinivasan <aks...@gm...>
Date: Sat Aug 4 20:38:14 2012 +0530
o Changed the order of application in the ediv functions.
o Made most of the generated functions inline.
diff --git a/lib/matlisp/dediv.f b/lib/matlisp/dediv.f
index 8151b5f..6b51547 100644
--- a/lib/matlisp/dediv.f
+++ b/lib/matlisp/dediv.f
@@ -26,7 +26,7 @@
* code for both increments equal to 1
*
20 do 30 i = 1,n
- dy(i) = dy(i) / dx(i)
+ dy(i) = dx(i) / dy(i)
30 continue
diff --git a/lib/matlisp/zediv.f b/lib/matlisp/zediv.f
index c1308d9..b0e8b21 100644
--- a/lib/matlisp/zediv.f
+++ b/lib/matlisp/zediv.f
@@ -26,7 +26,7 @@
* code for both increments equal to 1
*
20 do 30 i = 1,n
- dy(i) = dy(i) / dx(i)
+ dy(i) = dx(i) / dy(i)
30 continue
diff --git a/src/foreign-core/libmatlisp.lisp b/src/foreign-core/libmatlisp.lisp
index 8e15a2f..4aceebf 100644
--- a/src/foreign-core/libmatlisp.lisp
+++ b/src/foreign-core/libmatlisp.lisp
@@ -5,7 +5,7 @@
(DESCAL n dx incx dy incy)
Multiplies the vector X and Y element-wise.
- Y <- Y .* E
+ Y <- Y .* X
"
(n :integer :input)
(dx (* :double-float :inc head-x) :input)
@@ -18,7 +18,7 @@
(ZESCAL n dx incx dy incy)
Multiplies the vector X and Y element-wise.
- Y <- Y .* E
+ Y <- Y .* X
"
(n :integer :input)
(dx (* :complex-double-float :inc head-x) :input)
@@ -31,7 +31,7 @@
(DEDIV n dx incx dy incy)
Divides the vector Y by X element-wise.
- Y <- Y .* E
+ Y <- X ./ Y
"
(n :integer :input)
(dx (* :double-float :inc head-x) :input)
@@ -44,7 +44,7 @@
(ZEDIV n dx incx dy incy)
Divide the vector Y by X element-wise.
- Y <- Y .* E
+ Y <- X ./ Y
"
(n :integer :input)
(dx (* :complex-double-float :inc head-x) :input)
diff --git a/src/level-1/axpy.lisp b/src/level-1/axpy.lisp
index 3e13987..ec77357 100644
--- a/src/level-1/axpy.lisp
+++ b/src/level-1/axpy.lisp
@@ -34,7 +34,7 @@
;;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 (alpha from to)
+ `(definline ,func (alpha from to)
(declare (type ,tensor-class from to)
(type ,(getf opt :element-type) alpha))
(let ((strd-p (blas-copyable-p from to))
@@ -73,7 +73,7 @@
;;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)
+ `(definline ,func (num-from to)
(declare (type ,tensor-class to)
(type ,(getf opt :element-type) num-from))
(let ((min-strd (consecutive-store-p to))
@@ -82,7 +82,8 @@
((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)
+ (let-typed ((id (,(getf opt :coercer) 1) :type ,(getf opt :element-type)))
+ ,(funcall (getf opt :value-writer) `id 'num-array 0))
(,blas-func (number-of-elements to) num-from
num-array 0
(store to) min-strd
@@ -148,6 +149,8 @@
(real-typed-axpy! (coerce-real alpha) x y))
(defmethod axpy! ((alpha number) (x real-tensor) (y complex-tensor))
+ ;;Weird, shouldn't SBCL know this already ?
+ (declare (type complex-tensor y))
(let ((tmp (tensor-realpart~ y)))
(declare (type real-tensor tmp))
(etypecase alpha
diff --git a/src/level-1/copy.lisp b/src/level-1/copy.lisp
index a981a66..a9ee5ee 100644
--- a/src/level-1/copy.lisp
+++ b/src/level-1/copy.lisp
@@ -34,7 +34,7 @@
;;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)
+ `(definline ,func (from to)
(declare (type ,tensor-class from to))
(let ((strd-p (blas-copyable-p from to))
(call-fortran? (> (number-of-elements to) ,fortran-lb)))
@@ -66,7 +66,7 @@
;;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)
+ `(definline ,func (num-from to)
(declare (type ,tensor-class to)
(type ,(getf opt :element-type) num-from))
(let ((min-stride (consecutive-store-p to))
diff --git a/src/level-1/dot.lisp b/src/level-1/dot.lisp
index 8b777ee..dfb7d42 100644
--- a/src/level-1/dot.lisp
+++ b/src/level-1/dot.lisp
@@ -27,7 +27,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(in-package #:matlisp)
-(defun real-typed-dot (x y conjugate-p)
+(definline real-typed-dot (x y conjugate-p)
(declare (type real-vector x y)
(ignore conjugate-p))
(let ((call-fortran? (> (number-of-elements x)
@@ -52,7 +52,7 @@
summing (* (aref sto-x of-x) (aref sto-y of-y)) into dot of-type real-type
finally (return dot))))))))
-(defun complex-typed-dot (x y conjugate-p)
+(definline complex-typed-dot (x y conjugate-p)
(declare (type complex-vector x y))
(let ((call-fortran? (> (number-of-elements x)
*complex-l1-fcall-lb*)))
@@ -144,7 +144,8 @@
(real-typed-dot x y nil))
(defmethod dot ((x real-vector) (y complex-vector) &optional (conjugate-p t))
- (declare (ignore conjugate-p))
+ (declare (ignore conjugate-p)
+ (type complex-vector y))
(let ((vw.y (tensor-realpart~ y)))
(declare (type real-vector vw.y))
(let ((rpart (prog1 (real-typed-dot x vw.y nil)
diff --git a/src/level-1/realimag.lisp b/src/level-1/realimag.lisp
index ec51f8a..adbe4e2 100644
--- a/src/level-1/realimag.lisp
+++ b/src/level-1/realimag.lisp
@@ -28,7 +28,7 @@
(in-package #:matlisp)
-(defun tensor-realpart~ (tensor)
+(definline tensor-realpart~ (tensor)
"
Syntax
======
@@ -50,7 +50,7 @@
:head (the index-type (* 2 (head tensor)))))
(number (realpart tensor))))
-(defun tensor-imagpart~ (tensor)
+(definline tensor-imagpart~ (tensor)
"
Syntax
======
diff --git a/src/level-1/scal.lisp b/src/level-1/scal.lisp
index 2687144..49e1cbc 100644
--- a/src/level-1/scal.lisp
+++ b/src/level-1/scal.lisp
@@ -31,7 +31,7 @@
(defmacro generate-typed-scal! (func (tensor-class fortran-func fortran-lb))
(let* ((opt (get-tensor-class-optimization tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
- `(defun ,func (from to)
+ `(definline ,func (from to)
(declare (type ,tensor-class from to))
(let ((strd-p (blas-copyable-p from to))
(call-fortran? (> (number-of-elements to) ,fortran-lb)))
@@ -56,10 +56,32 @@
,(funcall (getf opt :value-writer) 'mul 't-sto 't-of))))))))
to)))
+(defmacro generate-typed-num-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)
+ `(definline ,func (alpha to)
+ (declare (type ,tensor-class to)
+ (type ,(getf opt :element-type) alpha))
+ (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)))
+
(defmacro generate-typed-div! (func (tensor-class fortran-func fortran-lb))
(let* ((opt (get-tensor-class-optimization tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
- `(defun ,func (from to)
+ `(definline ,func (from to)
(declare (type ,tensor-class from to))
(let ((strd-p (blas-copyable-p from to))
(call-fortran? (> (number-of-elements to) ,fortran-lb)))
@@ -80,21 +102,25 @@
(t-of (strides to) (head to)))
do (let*-typed ((val-f ,(funcall (getf opt :reader) 'f-sto 'f-of) :type ,(getf opt :element-type))
(val-t ,(funcall (getf opt :reader) 't-sto 't-of) :type ,(getf opt :element-type))
- (mul (/ val-t val-f) :type ,(getf opt :element-type)))
+ (mul (/ val-f val-t) :type ,(getf opt :element-type)))
,(funcall (getf opt :value-writer) 'mul 't-sto 't-of))))))))
to)))
-(defmacro generate-typed-num-scal! (func (tensor-class blas-func fortran-lb))
+(defmacro generate-typed-num-div! (func (tensor-class fortran-func fortran-lb))
(let ((opt (get-tensor-class-optimization tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
- `(defun ,func (alpha to)
+ `(definline ,func (alpha to)
(declare (type ,tensor-class to)
(type ,(getf opt :element-type) alpha))
(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)))
+ (let ((num-array (,(getf opt :store-allocator) 1)))
+ (declare (type ,(linear-array-type (getf opt :store-type)) num-array))
+ (let-typed ((id (,(getf opt :coercer) 1) :type ,(getf opt :element-type)))
+ ,(funcall (getf opt :value-writer) `id 'num-array 0))
+ (,fortran-func (number-of-elements to) num-array 0 (store to) min-stride (head to))))
(t
(let ((t-sto (store to)))
(declare (type ,(linear-array-type (getf opt :store-type)) t-sto))
@@ -102,7 +128,7 @@
(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)))
+ do (let-typed ((scal-val (/ alpha ,(funcall (getf opt :reader) 't-sto 't-of)) :type ,(getf opt :element-type)))
,(funcall (getf opt :value-writer) 'scal-val 't-sto 't-of))))))))
to)))
@@ -116,6 +142,9 @@
(generate-typed-div! real-typed-div!
(real-tensor dediv *real-l1-fcall-lb*))
+(generate-typed-num-div! real-typed-num-div!
+ (real-tensor dediv *real-l1-fcall-lb*))
+
;;Complex
(definline zordscal (nele alpha x incx &optional hd-x)
(if (zerop (imagpart alpha))
@@ -128,7 +157,10 @@
(generate-typed-scal! complex-typed-scal!
(complex-tensor zescal *complex-l1-fcall-lb*))
-(generate-typed-scal! complex-typed-div!
+(generate-typed-div! complex-typed-div!
+ (complex-tensor zediv *complex-l1-fcall-lb*))
+
+(generate-typed-num-div! complex-typed-num-div!
(complex-tensor zediv *complex-l1-fcall-lb*))
;;---------------------------------------------------------------;;
@@ -175,32 +207,28 @@
Purpose
=======
- X <- X ./ alpha
-
- Yes the calling order is twisted.
+ X <- alpha ./ X
")
(:method :before ((x standard-tensor) (y standard-tensor))
(assert (lvec-eq (dimensions x) (dimensions y) #'=) nil
'tensor-dimension-mismatch)))
(defmethod div! ((alpha number) (x real-tensor))
- (real-typed-num-scal! (coerce-real (/ 1 alpha)) x))
+ (real-typed-num-div! (coerce-real alpha) x))
(defmethod div! ((x real-tensor) (y real-tensor))
(real-typed-div! x y))
(defmethod div! ((alpha number) (x complex-tensor))
- (complex-typed-num-scal! (coerce-complex (/ 1 alpha)) x))
+ (complex-typed-num-div! (coerce-complex alpha) x))
(defmethod div! ((x complex-tensor) (y complex-tensor))
(complex-typed-div! x y))
(defmethod div! ((x real-tensor) (y complex-tensor))
- (let ((tmp (tensor-realpart~ y)))
- (real-typed-div! x tmp)
- ;;Move view to the imaginary part
- (incf (head tmp))
- (real-typed-div! x tmp)))
+ ;;The alternative is worse!
+ (let ((tmp (copy! x (apply #'make-complex-tensor (lvec->list (dimensions x))))))
+ (complex-typed-div! tmp y)))
;;
(defgeneric scal (alpha x)
@@ -223,6 +251,9 @@
(defmethod scal ((alpha number) (x number))
(* alpha x))
+(defmethod scal ((x standard-tensor) (alpha number))
+ (scal alpha x))
+
(defmethod scal ((alpha number) (x real-tensor))
(let ((result (if (complexp alpha)
(copy! x (apply #'make-complex-tensor (lvec->list (dimensions x))))
@@ -240,7 +271,11 @@
(let ((result (copy x)))
(scal! alpha result)))
-(defmethod scal ((x standard-tensor) (y complex-tensor))
+(defmethod scal ((x real-tensor) (y complex-tensor))
+ (let ((result (copy y)))
+ (scal! x result)))
+
+(defmethod scal ((x complex-tensor) (y complex-tensor))
(let ((result (copy y)))
(scal! x result)))
@@ -253,7 +288,7 @@
Purpose
=======
- X <- X ./ alpha
+ alpha ./ X
Yes the calling order is twisted.
"))
@@ -261,15 +296,23 @@
(defmethod div ((alpha number) (x number))
(/ x alpha))
+(defmethod div ((x standard-tensor) (y number))
+ (let ((result (copy x)))
+ (scal! (/ 1 y) result)))
+
+(defmethod div ((x (eql nil)) (y standard-tensor))
+ (let ((result (copy y)))
+ (div! 1 result)))
+
+(defmethod div ((x real-tensor) (y real-tensor))
+ (div! x (copy y)))
+
(defmethod div ((alpha number) (x real-tensor))
(let ((result (if (complexp alpha)
(copy! x (apply #'make-complex-tensor (lvec->list (dimensions x))))
(copy x))))
(div! alpha result)))
-(defmethod div ((x real-tensor) (y real-tensor))
- (div! x (copy y)))
-
(defmethod div ((x complex-tensor) (y real-tensor))
(let ((result (copy! y (apply #'make-complex-tensor (lvec->list (dimensions x))))))
(div! x result)))
@@ -278,14 +321,11 @@
(let ((result (copy x)))
(div! alpha result)))
-(defmethod div ((x standard-tensor) (y complex-tensor))
+(defmethod div ((x real-tensor) (y complex-tensor))
(let ((result (copy y)))
(div! x result)))
-(defmethod div ((x real-tensor) (y (eql nil)))
- (let ((result (copy! 1 (apply #'make-real-tensor (lvec->list (dimensions x))))))
+(defmethod div ((x complex-tensor) (y complex-tensor))
+ (let ((result (copy y)))
(div! x result)))
-(defmethod div ((x complex-tensor) (y (eql nil)))
- (let ((result (copy! 1 (apply #'make-complex-tensor (lvec->list (dimensions x))))))
- (div! x result)))
diff --git a/src/level-1/swap.lisp b/src/level-1/swap.lisp
index 081f8c3..8c4a790 100644
--- a/src/level-1/swap.lisp
+++ b/src/level-1/swap.lisp
@@ -34,7 +34,7 @@
;;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)
+ `(definline ,func (x y)
(declare (type ,tensor-class x y))
(let ((strd-p (blas-copyable-p x y))
(call-fortran? (> (number-of-elements x) ,fortran-lb)))
diff --git a/src/level-1/tensor-maker.lisp b/src/level-1/tensor-maker.lisp
index 541d1d2..6f7cb3b 100644
--- a/src/level-1/tensor-maker.lisp
+++ b/src/level-1/tensor-maker.lisp
@@ -5,48 +5,50 @@
(cocl (get-tensor-counterclass tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
(assert cocl nil 'tensor-cannot-find-counter-class :tensor-class tensor-class)
- `(defun ,func-name (&rest args)
- (labels ((make-dims (dims)
- (declare (type cons dims))
- (let*-typed ((vdim (make-index-store dims) :type index-store-vector)
- (ss (very-quickly (lvec-foldl #'(lambda (x y) (the index-type (* x y))) vdim)))
- (store (,(getf opt :store-allocator) ss))
- (rnk (length vdim)))
- (make-instance (case rnk (2 ',(getf cocl :matrix)) (1 ',(getf cocl :vector)) (t ',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))
- (lst (make-list (rank ret))))
- (declare (type ,tensor-class ret)
- (type ,(linear-array-type (getf opt :store-type)) st-r))
- (mod-dotimes (idx (dimensions ret))
- with (linear-sums
- (of-r (strides ret) (head ret)))
- do ,(funcall (getf opt :value-writer) `(,(getf opt :coercer) (apply #'aref arr (lvec->list! idx lst))) 'st-r 'of-r))
- ret))
- (make-from-list (lst)
- (let* ((ret (make-dims (list-dimensions lst)))
- (st-r (store ret)))
- (declare (type ,tensor-class ret)
- (type ,(linear-array-type (getf opt :store-type)) st-r))
- (list-loop (idx ele lst)
- with (linear-sums
- (of-r (strides ret) (head ret)))
- do ,(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)))))))
-
+ `(progn
+ (declaim (ftype (function (&rest t) ,tensor-class) ,func-name))
+ (defun ,func-name (&rest args)
+ (labels ((make-dims (dims)
+ (declare (type cons dims))
+ (let*-typed ((vdim (make-index-store dims) :type index-store-vector)
+ (ss (very-quickly (lvec-foldl #'(lambda (x y) (the index-type (* x y))) vdim)))
+ (store (,(getf opt :store-allocator) ss))
+ (rnk (length vdim)))
+ (make-instance (case rnk (2 ',(getf cocl :matrix)) (1 ',(getf cocl :vector)) (t ',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))
+ (lst (make-list (rank ret))))
+ (declare (type ,tensor-class ret)
+ (type ,(linear-array-type (getf opt :store-type)) st-r))
+ (mod-dotimes (idx (dimensions ret))
+ with (linear-sums
+ (of-r (strides ret) (head ret)))
+ do ,(funcall (getf opt :value-writer) `(,(getf opt :coercer) (apply #'aref arr (lvec->list! idx lst))) 'st-r 'of-r))
+ ret))
+ (make-from-list (lst)
+ (let* ((ret (make-dims (list-dimensions lst)))
+ (st-r (store ret)))
+ (declare (type ,tensor-class ret)
+ (type ,(linear-array-type (getf opt :store-type)) st-r))
+ (list-loop (idx ele lst)
+ with (linear-sums
+ (of-r (strides ret) (head ret)))
+ do ,(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/level-1/trans.lisp b/src/level-1/trans.lisp
index d5c0087..b0de83a 100644
--- a/src/level-1/trans.lisp
+++ b/src/level-1/trans.lisp
@@ -27,7 +27,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(in-package #:matlisp)
-(defun transpose! (A &optional permutation)
+(definline transpose! (A &optional permutation)
"
Syntax
======
@@ -58,10 +58,10 @@
(rotatef (aref strd-A (1- rnk)) (aref strd-A 0))))
A)
-(defun (setf transpose!) (value A &optional permutation)
+(definline (setf transpose!) (value A &optional permutation)
(copy! value (transpose! A permutation)))
-(defun transpose~ (A &optional permutation)
+(definline transpose~ (A &optional permutation)
"
Syntax
======
@@ -86,7 +86,7 @@
:parent-tensor A)))
(transpose! displaced permutation)))
-(defun (setf transpose~) (value A &optional permutation)
+(definline (setf transpose~) (value A &optional permutation)
(declare (type standard-tensor A))
(copy! value (transpose~ A permutation)))
@@ -109,7 +109,7 @@
(declare (type standard-tensor A))
(copy (transpose~ A permutation)))
-(defun (setf transpose) (value A &optional permutation)
+(definline (setf transpose) (value A &optional permutation)
(declare (type standard-tensor A))
(copy! value (transpose~ A permutation)))
@@ -125,7 +125,7 @@
;;
-(defun mconjugate! (A)
+(definline mconjugate! (A)
"
Syntax
======
@@ -154,7 +154,7 @@
Like mconjugate!, but non-destructive."
(etypecase A
(standard-tensor (mconjugate! (copy A)))
- (number (conjugate A))))
+ (number (cl:conjugate A))))
;;
(defun htranspose! (A &optional permutation)
diff --git a/src/level-2/gemv.lisp b/src/level-2/gemv.lisp
index 78004a5..8891d33 100644
--- a/src/level-2/gemv.lisp
+++ b/src/level-2/gemv.lisp
@@ -9,7 +9,7 @@
;;Use only after checking the arguments for compatibility.
(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)
+ `(definline ,func (alpha A x beta y job)
(declare (type ,(getf opt :element-type) alpha beta)
(type ,matrix-class A)
(type ,vector-class x y)
@@ -70,7 +70,7 @@
(generate-typed-gemv! complex-base-typed-gemv!
(complex-matrix complex-vector zgemv *complex-l2-fcall-lb*))
-(defun complex-typed-gemv! (alpha A x beta y job)
+(definline complex-typed-gemv! (alpha A x beta y job)
(declare (type complex-matrix A)
(type complex-vector x y)
(type complex-type alpha beta)
@@ -78,10 +78,14 @@
(if (member job '(:n :t))
(complex-base-typed-gemv! alpha A x beta y job)
;;The CBLAS way.
- (let ((cx (mconjugate x)))
+ (let-typed ((cx (let-typed ((ret (apply #'make-real-tensor (lvec->list (dimensions x))) :type complex-vector))
+ (complex-typed-axpy! #c(-1d0 0d0) x ret))
+ :type complex-vector))
+ (complex-typed-num-scal! #c(-1d0 0d0) (tensor-realpart~ y))
(complex-base-typed-gemv! (cl:conjugate alpha) A cx
- (cl:conjugate beta) (mconjugate! y) (ecase job (:h :t) (:c :n)))
- (mconjugate! y))))
+ (cl:conjugate beta) y (ecase job (:h :t) (:c :n)))
+ (complex-typed-num-scal! #c(-1d0 0d0) (tensor-realpart~ y))
+ y)))
;;---------------------------------------------------------------;;
diff --git a/src/level-3/gemm.lisp b/src/level-3/gemm.lisp
index b8124c3..386c193 100644
--- a/src/level-3/gemm.lisp
+++ b/src/level-3/gemm.lisp
@@ -31,7 +31,7 @@
(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)
+ `(definline ,func (alpha A B beta C job)
(declare (type ,(getf opt :element-type) alpha beta)
(type ,matrix-class A B C)
(type symbol job))
@@ -167,7 +167,7 @@
(generate-typed-gemm! complex-base-typed-gemm!
(complex-matrix zgemm zgemv *complex-l3-fcall-lb*))
-(defun complex-typed-gemm! (alpha A B beta C job)
+(definline complex-typed-gemm! (alpha A B beta C job)
(declare (type complex-matrix A B C)
(type complex-type alpha beta)
(type symbol job))
@@ -175,8 +175,16 @@
(if (and (member job-A '(:n :t))
(member job-B '(:n :t)))
(complex-base-typed-gemm! alpha A B beta C job)
- (let ((A (ecase job-A ((:h :c) (mconjugate A)) ((:n :t) A)))
- (B (ecase job-B ((:h :c) (mconjugate B)) ((:n :t) B)))
+ (let ((A (ecase job-A
+ ((:n :t) A)
+ ((:h :c)
+ (let ((ret (apply #'make-complex-tensor (lvec->list (dimensions A)))))
+ (complex-typed-axpy! #c(-1d0 0d0) A ret)))))
+ (B (ecase job-B
+ ((:n :t) B)
+ ((:h :c)
+ (let ((ret (apply #'make-complex-tensor (lvec->list (dimensions B)))))
+ (complex-typed-axpy! #c(-1d0 0d0) B ret)))))
(tjob (combine-jobs (ecase job-A ((:n :t) job-A) (:h :t) (:c :n))
(ecase job-B ((:n :t) job-B) (:h :t) (:c :n)))))
(complex-base-typed-gemm! alpha A B
commit 9b50685d6952b3be9ff29473595b2694ea234b08
Author: Akshay Srinivasan <aks...@gm...>
Date: Sat Aug 4 18:18:30 2012 +0530
o Added element-wise scal and div methods.
diff --git a/src/level-1/scal.lisp b/src/level-1/scal.lisp
index 15dfde7..2687144 100644
--- a/src/level-1/scal.lisp
+++ b/src/level-1/scal.lisp
@@ -28,7 +28,63 @@
(in-package #:matlisp)
-(defmacro generate-typed-scal! (func (tensor-class blas-func fortran-lb))
+(defmacro generate-typed-scal! (func (tensor-class fortran-func fortran-lb))
+ (let* ((opt (get-tensor-class-optimization tensor-class)))
+ (assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
+ `(defun ,func (from to)
+ (declare (type ,tensor-class from to))
+ (let ((strd-p (blas-copyable-p from to))
+ (call-fortran? (> (number-of-elements to) ,fortran-lb)))
+ (cond
+ ((and strd-p call-fortran?)
+ (,fortran-func (number-of-elements from)
+ (store from) (first strd-p)
+ (store to) (second strd-p)
+ (head from) (head to)))
+ (t
+ (let ((f-sto (store from))
+ (t-sto (store to)))
+ (declare (type ,(linear-array-type (getf opt :store-type)) f-sto t-sto))
+ (very-quickly
+ (mod-dotimes (idx (dimensions from))
+ with (linear-sums
+ (f-of (strides from) (head from))
+ (t-of (strides to) (head to)))
+ do (let*-typed ((val-f ,(funcall (getf opt :reader) 'f-sto 'f-of) :type ,(getf opt :element-type))
+ (val-t ,(funcall (getf opt :reader) 't-sto 't-of) :type ,(getf opt :element-type))
+ (mul (* val-f val-t) :type ,(getf opt :element-type)))
+ ,(funcall (getf opt :value-writer) 'mul 't-sto 't-of))))))))
+ to)))
+
+(defmacro generate-typed-div! (func (tensor-class fortran-func fortran-lb))
+ (let* ((opt (get-tensor-class-optimization tensor-class)))
+ (assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
+ `(defun ,func (from to)
+ (declare (type ,tensor-class from to))
+ (let ((strd-p (blas-copyable-p from to))
+ (call-fortran? (> (number-of-elements to) ,fortran-lb)))
+ (cond
+ ((and strd-p call-fortran?)
+ (,fortran-func (number-of-elements from)
+ (store from) (first strd-p)
+ (store to) (second strd-p)
+ (head from) (head to)))
+ (t
+ (let ((f-sto (store from))
+ (t-sto (store to)))
+ (declare (type ,(linear-array-type (getf opt :store-type)) f-sto t-sto))
+ (very-quickly
+ (mod-dotimes (idx (dimensions from))
+ with (linear-sums
+ (f-of (strides from) (head from))
+ (t-of (strides to) (head to)))
+ do (let*-typed ((val-f ,(funcall (getf opt :reader) 'f-sto 'f-of) :type ,(getf opt :element-type))
+ (val-t ,(funcall (getf opt :reader) 't-sto 't-of) :type ,(getf opt :element-type))
+ (mul (/ val-t val-f) :type ,(getf opt :element-type)))
+ ,(funcall (getf opt :value-writer) 'mul 't-sto 't-of))))))))
+ to)))
+
+(defmacro generate-typed-num-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)
@@ -51,17 +107,29 @@
to)))
;;Real
-(generate-typed-scal! real-typed-scal!
+(generate-typed-num-scal! real-typed-num-scal!
(real-tensor dscal *real-l1-fcall-lb*))
+(generate-typed-scal! real-typed-scal!
+ (real-tensor descal *real-l1-fcall-lb*))
+
+(generate-typed-div! real-typed-div!
+ (real-tensor dediv *real-l1-fcall-lb*))
+
;;Complex
(definline zordscal (nele alpha x incx &optional hd-x)
(if (zerop (imagpart alpha))
(zdscal nele (realpart alpha) x incx hd-x)
(zscal nele alpha x incx hd-x)))
-(generate-typed-scal! complex-typed-scal!
+(generate-typed-num-scal! complex-typed-num-scal!
(complex-tensor zordscal *complex-l1-fcall-lb*))
+
+(generate-typed-scal! complex-typed-scal!
+ (complex-tensor zescal *complex-l1-fcall-lb*))
+
+(generate-typed-scal! complex-typed-div!
+ (complex-tensor zediv *complex-l1-fcall-lb*))
;;---------------------------------------------------------------;;
(defgeneric scal! (alpha x)
@@ -74,13 +142,65 @@
Purpose
=======
X <- alpha .* X
-"))
+")
+ (:method :before ((x standard-tensor) (y standard-tensor))
+ (assert (lvec-eq (dimensions x) (dimensions y) #'=) nil
+ 'tensor-dimension-mismatch)))
(defmethod scal! ((alpha number) (x real-tensor))
- (real-typed-scal! (coerce-real alpha) x))
+ (real-typed-num-scal! (coerce-real alpha) x))
+
+(defmethod scal! ((x real-tensor) (y real-tensor))
+ (real-typed-scal! x y))
(defmethod scal! ((alpha number) (x complex-tensor))
- (complex-typed-scal! (coerce-complex alpha) x))
+ (complex-typed-num-scal! (coerce-complex alpha) x))
+
+(defmethod scal! ((x complex-tensor) (y complex-tensor))
+ (complex-typed-scal! x y))
+
+(defmethod scal! ((x real-tensor) (y complex-tensor))
+ (let ((tmp (tensor-realpart~ y)))
+ (real-typed-scal! x tmp)
+ ;;Move view to the imaginary part
+ (incf (head tmp))
+ (real-typed-scal! x tmp)))
+
+;;
+(defgeneric div! (alpha x)
+ (:documentation "
+ Syntax
+ ======
+ (div! alpha x)
+
+ Purpose
+ =======
+ X <- X ./ alpha
+
+ Yes the calling order is twisted.
+")
+ (:method :before ((x standard-tensor) (y standard-tensor))
+ (assert (lvec-eq (dimensions x) (dimensions y) #'=) nil
+ 'tensor-dimension-mismatch)))
+
+(defmethod div! ((alpha number) (x real-tensor))
+ (real-typed-num-scal! (coerce-real (/ 1 alpha)) x))
+
+(defmethod div! ((x real-tensor) (y real-tensor))
+ (real-typed-div! x y))
+
+(defmethod div! ((alpha number) (x complex-tensor))
+ (complex-typed-num-scal! (coerce-complex (/ 1 alpha)) x))
+
+(defmethod div! ((x complex-tensor) (y complex-tensor))
+ (complex-typed-div! x y))
+
+(defmethod div! ((x real-tensor) (y complex-tensor))
+ (let ((tmp (tensor-realpart~ y)))
+ (real-typed-div! x tmp)
+ ;;Move view to the imaginary part
+ (incf (head tmp))
+ (real-typed-div! x tmp)))
;;
(defgeneric scal (alpha x)
@@ -104,15 +224,68 @@
(* alpha x))
(defmethod scal ((alpha number) (x real-tensor))
- (let ((result (copy x)))
+ (let ((result (if (complexp alpha)
+ (copy! x (apply #'make-complex-tensor (lvec->list (dimensions x))))
+ (copy x))))
(scal! alpha result)))
-(defmethod scal ((alpha complex) (x real-tensor))
- (let* ((result (apply #'make-complex-tensor (lvec->list (dimensions x)))))
- (declare (type complex-tensor result))
- (copy! x result)
- (scal! alpha result)))
+(defmethod scal ((x real-tensor) (y real-tensor))
+ (scal! x (copy y)))
+
+(defmethod scal ((x complex-tensor) (y real-tensor))
+ (let ((result (copy! y (apply #'make-complex-tensor (lvec->list (dimensions x))))))
+ (scal! x result)))
(defmethod scal ((alpha number) (x complex-tensor))
(let ((result (copy x)))
(scal! alpha result)))
+
+(defmethod scal ((x standard-tensor) (y complex-tensor))
+ (let ((result (copy y)))
+ (scal! x result)))
+
+;;
+(defgeneric div (x y)
+ (:documentation "
+ Syntax
+ ======
+ (div! alpha x)
+
+ Purpose
+ =======
+ X <- X ./ alpha
+
+ Yes the calling order is twisted.
+"))
+
+(defmethod div ((alpha number) (x number))
+ (/ x alpha))
+
+(defmethod div ((alpha number) (x real-tensor))
+ (let ((result (if (complexp alpha)
+ (copy! x (apply #'make-complex-tensor (lvec->list (dimensions x))))
+ (copy x))))
+ (div! alpha result)))
+
+(defmethod div ((x real-tensor) (y real-tensor))
+ (div! x (copy y)))
+
+(defmethod div ((x complex-tensor) (y real-tensor))
+ (let ((result (copy! y (apply #'make-complex-tensor (lvec->list (dimensions x))))))
+ (div! x result)))
+
+(defmethod div ((alpha number) (x complex-tensor))
+ (let ((result (copy x)))
+ (div! alpha result)))
+
+(defmethod div ((x standard-tensor) (y complex-tensor))
+ (let ((result (copy y)))
+ (div! x result)))
+
+(defmethod div ((x real-tensor) (y (eql nil)))
+ (let ((result (copy! 1 (apply #'make-real-tensor (lvec->list (dimensions x))))))
+ (div! x result)))
+
+(defmethod div ((x complex-tensor) (y (eql nil)))
+ (let ((result (copy! 1 (apply #'make-complex-tensor (lvec->list (dimensions x))))))
+ (div! x result)))
commit 0b4fcdfe7d12f45c1d46f3b42589a5f2ff54e8dc
Author: Akshay Srinivasan <aks...@gm...>
Date: Sat Aug 4 16:22:25 2012 +0530
o Added escal ediv Fortran declarations.
diff --git a/matlisp.asd b/matlisp.asd
index 43f09d1..da36f7a 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -98,7 +98,8 @@
:depends-on ("foreign-interface")
:components ((:file "blas")
(:file "lapack")
- (:file "dfftpack")))
+ (:file "dfftpack")
+ (:file "libmatlisp")))
(:module "matlisp-base"
:depends-on ("foreign-core")
:pathname "base"
diff --git a/packages.lisp b/packages.lisp
index 1693289..8d71112 100644
--- a/packages.lisp
+++ b/packages.lisp
@@ -145,10 +145,17 @@
(:export #:zffti #:zfftf #:zfftb #:zffti #:zfftf #:zfftb)
(:documentation "FFT routines"))
+(defpackage "MATLISP-LIBMATLISP"
+ (:use #:common-lisp #:matlisp-ffi)
+ (:export
+ #:descal #:dediv
+ #:zescal #:zediv)
+ (:documentation "BLAS routines"))
+
(defpackage "MATLISP"
(:use #:common-lisp
#:matlisp-conditions #:matlisp-utilities #:matlisp-ffi
- #:matlisp-blas #:matlisp-lapack #:matlisp-dfftpack)
+ #:matlisp-blas #:matlisp-lapack #:matlisp-dfftpack #:matlisp-libmatlisp)
(:export #:index-type #:index-array #:allocate-index-store #:make-index-store
;;Standard-tensor
#:standard-tensor
diff --git a/src/foreign-core/libmatlisp.lisp b/src/foreign-core/libmatlisp.lisp
new file mode 100644
index 0000000..8e15a2f
--- /dev/null
+++ b/src/foreign-core/libmatlisp.lisp
@@ -0,0 +1,53 @@
+(in-package #:matlisp-libmatlisp)
+
+(def-fortran-routine descal :void
+ "
+ (DESCAL n dx incx dy incy)
+
+ Multiplies the vector X and Y element-wise.
+ Y <- Y .* E
+ "
+ (n :integer :input)
+ (dx (* :double-float :inc head-x) :input)
+ (incx :integer :input)
+ (dy (* :double-float :inc head-y) :output)
+ (incy :integer :output))
+
+(def-fortran-routine zescal :void
+ "
+ (ZESCAL n dx incx dy incy)
+
+ Multiplies the vector X and Y element-wise.
+ Y <- Y .* E
+ "
+ (n :integer :input)
+ (dx (* :complex-double-float :inc head-x) :input)
+ (incx :integer :input)
+ (dy (* :complex-double-float :inc head-y) :output)
+ (incy :integer :output))
+
+(def-fortran-routine dediv :void
+ "
+ (DEDIV n dx incx dy incy)
+
+ Divides the vector Y by X element-wise.
+ Y <- Y .* E
+ "
+ (n :integer :input)
+ (dx (* :double-float :inc head-x) :input)
+ (incx :integer :input)
+ (dy (* :double-float :inc head-y) :output)
+ (incy :integer :output))
+
+(def-fortran-routine zediv :void
+ "
+ (ZEDIV n dx incx dy incy)
+
+ Divide the vector Y by X element-wise.
+ Y <- Y .* E
+ "
+ (n :integer :input)
+ (dx (* :complex-double-float :inc head-x) :input)
+ (incx :integer :input)
+ (dy (* :complex-double-float :inc head-y) :output)
+ (incy :integer :output))
diff --git a/tests/loopy-tests.lisp b/tests/loopy-tests.lisp
index 2ed4ed1..67db2be 100644
--- a/tests/loopy-tests.lisp
+++ b/tests/loopy-tests.lisp
@@ -122,7 +122,7 @@
(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)
+ (declare (type real-store-vector 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))
-----------------------------------------------------------------------
Summary of changes:
lib/matlisp/dediv.f | 2 +-
lib/matlisp/zediv.f | 2 +-
matlisp.asd | 3 +-
packages.lisp | 9 ++-
src/foreign-core/libmatlisp.lisp | 53 +++++++++
src/level-1/axpy.lisp | 9 +-
src/level-1/copy.lisp | 4 +-
src/level-1/dot.lisp | 7 +-
src/level-1/realimag.lisp | 4 +-
src/level-1/scal.lisp | 239 +++++++++++++++++++++++++++++++++++--
src/level-1/swap.lisp | 2 +-
src/level-1/tensor-maker.lisp | 86 +++++++-------
src/level-1/trans.lisp | 14 +-
src/level-2/gemv.lisp | 14 ++-
src/level-3/gemm.lisp | 16 ++-
tests/loopy-tests.lisp | 2 +-
16 files changed, 379 insertions(+), 87 deletions(-)
create mode 100644 src/foreign-core/libmatlisp.lisp
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2012-08-04 10:12: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 7424dca3c956b58d494e938ed7acf90abc79d086 (commit)
via ccfaa98ec85543e56211e9781267becf93ac4b9e (commit)
via 8740b36ec8cfd52498f7a47d96eb0d65277e5b7a (commit)
via 8bd622f7d1ff8f64cc977e17a35e8e6bc29183a8 (commit)
via 3fbeec55d702bde591b5d06abe6dbe2334d4735d (commit)
from f27e7165a4d1127a21c7cdb9148b986d92b401d7 (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 7424dca3c956b58d494e938ed7acf90abc79d086
Author: Akshay Srinivasan <aks...@gm...>
Date: Sat Aug 4 15:34:55 2012 +0530
o Removed "commented" code, CCL checks for lisp-syntax within code starting with
#+nil reader-conditional.
diff --git a/src/ffi/f77-ffi.lisp b/src/ffi/f77-ffi.lisp
index 602eba0..177f431 100644
--- a/src/ffi/f77-ffi.lisp
+++ b/src/ffi/f77-ffi.lisp
@@ -449,131 +449,6 @@
`(,retvar))
,@(mapcar #'second return-vars)))))))))
-#+nil
-(defun def-fortran-interface-func (name return-type body hidden-var-name)
- (multiple-value-bind (doc pars)
- (parse-doc-&-parameters body)
- (let ((ffi-fn (make-fortran-ffi-name name))
- (return-vars nil)
- (array-vars nil)
- (ref-vars nil)
- (callback-code nil)
- ;;
- (defun-args nil)
- (defun-keyword-args nil)
- ;;
- (aux-args nil)
- ;;
- (ffi-args nil)
- (aux-ffi-args nil))
- (dolist (decl pars)
- (destructuring-bind (var type &optional style) decl
- (let ((ffi-var nil)
- (aux-var nil))
- (cond
- ;; Callbacks are tricky.
- ((%f77.callback-type-p type)
- (let* ((callback-name (gensym (symbol-name var)))
- (c-callback-code (def-fortran-callback var callback-name (second type) (cddr type))))
- (nconsc callback-code c-callback-code)
- (setq ffi-var `(cffi:callback ,callback-name))))
- ;; Can't really enforce "style" when given an array.
- ;; Complex numbers do not latch onto this case, they
- ;; are passed by value.
- ((%f77.array-p type)
- (setq ffi-var (scat "ADDR-" var))
- (nconsc array-vars `((,ffi-var ,var)))
- ;;
- (when-let (arg (getf type :inc))
- (nconsc defun-keyword-args
- `((,arg 0)))
- (nconc (car (last array-vars)) `(:inc-type ,(cadr type) :inc ,arg))))
- ;; Strings
- ((%f77.string-p type)
- (setq ffi-var var)
- (setq aux-var (scat "LEN-" var))
- (nconsc aux-args `((,aux-var (length (the string ,var))))))
- ;; Pass-by-value variables
- ((eq style :input-value)
- (setq ffi-var var))
- ;; Pass-by-reference variables
- (t
- (cond
- ;; Makes more sense to copy complex numbers into
- ;; arrays, rather than twiddling around with lisp
- ;; memory internals.
- ((member type '(:complex-single-float :complex-double-float))
- (setq ffi-var (scat "ADDR-REAL-CAST-" var))
- (nconsc ref-vars
- `((,ffi-var ,(second (%f77.cffi-type type)) :count 2 :initial-contents (list (realpart ,var) (imagpart ,var))))))
- (t
- (setq ffi-var (scat "REF-" var))
- (nconsc ref-vars
- `((,ffi-var ,@(%f77.cffi-type type) :initial-element ,var)))))))
- ;; Output variables
- (when (and (output-p style) (not (eq type :string)))
- (nconsc return-vars
- `((,ffi-var ,var ,type))))
- ;; Arguments for the lisp wrapper
- (unless (eq var hidden-var-name)
- (nconsc defun-args
- `(,var)))
- ;; Arguments for the FFI function
- (nconsc ffi-args
- `(,ffi-var))
- ;; Auxillary arguments for FFI
- (unless (null aux-var)
- (nconsc aux-ffi-args
- `(,aux-var))))))
- ;;Complex returns through hidden variable.
- (unless (null hidden-var-name)
- (nconsc aux-args `((,hidden-var-name ,(ecase (second (first pars))
- (:complex-single-float #c(0e0 0e0))
- (:complex-double-float #c(0d0 0d0)))))))
- ;;Keyword argument list
- (unless (null defun-keyword-args)
- (setq defun-keyword-args (cons '&optional defun-keyword-args)))
- ;;Return the function definition
- (let ((retvar (gensym)))
- `(
- ,(recursive-append
- `(defun ,name ,(append defun-args (mapcar #'(lambda (decl)
- ())
- defun-keyword-args)
- ,@doc)
- ;;
- (unless (null aux-args)
- `(let (,@aux-args)))
- ;;Don't use with-foreign.. if ref-vars is nil
- (unless (null ref-vars)
- `(with-foreign-objects-stacked (,@ref-vars)))
- ;;Don't use with-vector-dat.. if array-vars is nil
- (unless (null array-vars)
- `(with-vector-data-addresses (,@array-vars)))
- ;;Declare callbacks
- callback-code
- ;;Call the foreign-function
- `(let ((,retvar (,ffi-fn ,@ffi-args ,@aux-ffi-args)))
- ;;Ignore return if type is :void
- ,@(when (eq return-type :void)
- `((declare (ignore ,retvar))))
- ;; Copy values in reference pointers back to local
- ;; variables. Lisp has local scope; its safe to
- ;; modify variables in parameter lists.
- ,@(mapcar #'(lambda (decl)
- (destructuring-bind (ffi-var var type) decl
- (if (member type '(:complex-single-float :complex-double-float))
- `(setq ,var (complex (cffi:mem-aref ,ffi-var ,(second (%f77.cffi-type type)) 0)
- (cffi:mem-aref ,ffi-var ,(second (%f77.cffi-type type)) 1)))
- `(setq ,var (cffi:mem-aref ,ffi-var ,@(%f77.cffi-type type))))))
- (remove-if-not #'(lambda (x)
- (member (first x) ref-vars :key #'car))
- return-vars))
- (values
- ,@(unless (eq return-type :void)
- `(,retvar))
- ,@(mapcar #'second return-vars))))))))))
-
;;TODO: Outputs are messed up inside the callback
(defun %f77.def-fortran-callback (func callback-name return-type parm)
(let* ((hack-return-type `,return-type)
commit ccfaa98ec85543e56211e9781267becf93ac4b9e
Author: Akshay Srinivasan <aks...@gm...>
Date: Sat Aug 4 15:23:47 2012 +0530
o Removed -I m4 from AC_LOCAL_AMFLAGS, build complains about missing folder.
diff --git a/Makefile.am b/Makefile.am
index 92a7a18..bc5d88f 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -3,7 +3,7 @@ if !EXT_BLAPACK
SUBDIRS += lib/blas lib/lapack
endif
-ACLOCAL_AMFLAGS = -I m4
+#ACLOCAL_AMFLAGS = -I m4
#AM_FFLAGS=
commit 8740b36ec8cfd52498f7a47d96eb0d65277e5b7a
Author: Akshay Srinivasan <aks...@gm...>
Date: Sat Aug 4 15:18:36 2012 +0530
o Changed order, compile BLAS before LAPACK
diff --git a/Makefile.am b/Makefile.am
index 2302f7e..92a7a18 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -1,6 +1,6 @@
SUBDIRS = lib/matlisp lib/dfftpack lib/toms715 lib/odepack lib/colnew
if !EXT_BLAPACK
-SUBDIRS += lib/lapack lib/blas
+SUBDIRS += lib/blas lib/lapack
endif
ACLOCAL_AMFLAGS = -I m4
commit 8bd622f7d1ff8f64cc977e17a35e8e6bc29183a8
Author: Akshay Srinivasan <aks...@gm...>
Date: Sat Aug 4 15:06:44 2012 +0530
o Moved all the fortran files(including BLAS LAPACK) into lib/
Changed the --with-atlas switch into the more general --with-blas-lapack
diff --git a/Makefile.am b/Makefile.am
index 7a58318..2302f7e 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -1,9 +1,9 @@
-SUBDIRS = dfftpack lib-src/toms715 lib-src/odepack
-if !ATLAS
-SUBDIRS += LAPACK/BLAS/SRC LAPACK/SRC
+SUBDIRS = lib/matlisp lib/dfftpack lib/toms715 lib/odepack lib/colnew
+if !EXT_BLAPACK
+SUBDIRS += lib/lapack lib/blas
endif
-#ACLOCAL_AMFLAGS = -I m4
+ACLOCAL_AMFLAGS = -I m4
#AM_FFLAGS=
@@ -12,15 +12,14 @@ F2C = @F2C@
# This should build all the libraries we need. Then we need to
# install them before we can build the lisp code.
all :
- (cd dfftpack; $(MAKE) install)
- (cd lib-src/toms715; $(MAKE) install)
- (cd lib-src/odepack; $(MAKE) install)
- (cd lib-src/compat; $(MAKE) install)
- (cd lib-src/colnew; $(MAKE) install)
- (cd lib-src/scaldiv; $(MAKE) install)
-if !ATLAS
- (cd LAPACK/BLAS/SRC; $(MAKE) install)
- (cd LAPACK/SRC; $(MAKE) install)
+ (cd lib/matlisp; $(MAKE) install)
+ (cd lib/dfftpack; $(MAKE) install)
+ (cd lib/toms715; $(MAKE) install)
+ (cd lib/odepack; $(MAKE) install)
+ (cd lib/colnew; $(MAKE) install)
+if !EXT_BLAPACK
+ (cd lib/blas; $(MAKE) install)
+ (cd lib/lapack; $(MAKE) install)
endif
$(MAKE) lisp
diff --git a/config.lisp b/config.lisp
deleted file mode 100644
index fafbfec..0000000
--- a/config.lisp
+++ /dev/null
@@ -1,41 +0,0 @@
-;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Package: cl-user; 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.
-;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; This is the configuration file for the MATLISP workspace.
-;;;
-;;; Matlisp is a package and should really not set any environment
-;;; configuration. Eventually, this file should disappear.
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; $Id: config.lisp,v 1.4 2003/06/27 03:41:39 rtoy Exp $
-;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(in-package "COMMON-LISP-USER")
-
-#+:allegro (setq comp:*cltl1-compile-file-toplevel-compatibility-p* t)
-#+:allegro (setq excl:*enable-package-locked-errors* nil)
-
diff --git a/configure b/configure
index 61b86e8..42c2db1 100755
--- a/configure
+++ b/configure
@@ -646,14 +646,12 @@ LISPEVAL
F77_EXTRA_UNDERSCORE
F77_UNDERSCORE
F77_LOWER_CASE
-ATLAS_P
-ATLAS_LIBS
-ATLAS_DIR
-NO_ATLAS_LAPACK_OBJS
+BLAS_LAPACK_DIR
+EXTERNAL_BLAS_LAPACK_P
BLAS_OBJS
LISPEXEC
-ATLAS_FALSE
-ATLAS_TRUE
+EXT_BLAPACK_FALSE
+EXT_BLAPACK_TRUE
LIB32_FALSE
LIB32_TRUE
CPP
@@ -791,7 +789,7 @@ enable_fast_install
with_gnu_ld
with_sysroot
enable_libtool_lock
-with_atlas
+with_blas_lapack
'
ac_precious_vars='build_alias
host_alias
@@ -1446,7 +1444,8 @@ Optional Packages:
--with-gnu-ld assume the C compiler uses GNU ld [default=no]
--with-sysroot=DIR Search for dependent libraries within DIR
(or the compiler's sysroot if not specified).
- --with-atlas=libpath Location of the ATLAS libraries
+ --with-blas-lapack=libpath
+ Location of the BLAS/LAPACK libraries
Some influential environment variables:
CC C compiler command
@@ -8908,6 +8907,10 @@ _lt_linker_boilerplate=`cat conftest.err`
$RM -r conftest*
+## CAVEAT EMPTOR:
+## There is no encapsulation within the following macros, do not change
+## the running order or otherwise move them around unless you know exactly
+## what you are doing...
if test -n "$compiler"; then
lt_prog_compiler_no_builtin_flag=
@@ -15281,46 +15284,45 @@ $as_echo "no" >&6; }
fi
-# Allow user to use ATLAS if available.
-# We assume the standard names for the ATLAS libraries.
+# Allow user to use external BLAS/LAPACK library if available.
+# We assume the standard names for the libraries: lib{blas, lapack}
-# Check whether --with-atlas was given.
-if test "${with_atlas+set}" = set; then :
- withval=$with_atlas;
- # Building with ATLAS
- ATLAS_DIR="$withval/"
- ATLAS_LIBS="libatlas libcblas libf77blas liblapack"
- atlas=true
- ATLAS_P=t
+# Check whether --with-blas-lapack was given.
+if test "${with_blas_lapack+set}" = set; then :
+ withval=$with_blas_lapack;
+ # Building with external BLAS
+ ext_blapack=true
+ BLAS_LAPACK_DIR="$withval/"
+ EXTERNAL_BLAS_LAPACK_P=t
else
- # Building without ATLAS. Need these objects from our own copy of
+ # Building without external BLAS. Need these objects from our own copy of
# LAPACK.
- atlas=false
- ATLAS_P=nil
+ ext_blapack=false
+ EXTERNAL_BLAS_LAPACK_P=nil
fi
- if test x$atlas = xtrue; then
- ATLAS_TRUE=
- ATLAS_FALSE='#'
+ if test x$ext_blapack = xtrue; then
+ EXT_BLAPACK_TRUE=
+ EXT_BLAPACK_FALSE='#'
else
- ATLAS_TRUE='#'
- ATLAS_FALSE=
+ EXT_BLAPACK_TRUE='#'
+ EXT_BLAPACK_FALSE=
fi
-# Check to see if the ATLAS libraries are compatible with matlisp's
+# Check to see if the BLAS library is compatible with matlisp's
# ffi. Basically the same test as above that checks to see if -ff2c
# is needed. We call zdotu which is a Fortran function returning a
# complex number. Matlisp assumes such functions return the result by
# storing the answer at address given by a hidden first parameter to
# the function.
-if test x"$atlas" = xtrue; then
- { $as_echo "$as_me:${as_lineno-$LINENO}: checking if ATLAS is compatible with f2c calling conventions" >&5
-$as_echo_n "checking if ATLAS is compatible with f2c calling conventions... " >&6; }
+if test x"$ext_blapack" = xtrue; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking if BLAS is compatible with f2c calling conventions" >&5
+$as_echo_n "checking if BLAS is compatible with f2c calling conventions... " >&6; }
# From the value of f77_name, figure out the actual name for
# Fortran's zdotu.
case $f77_name in
@@ -15374,7 +15376,7 @@ int main()
EOF
$CC $CFLAGS -c conftest.c
- $F77 $FFLAGS -o a.out conftest.o -L${ATLAS_DIR} -latlas -lcblas -lf77blas -llapack
+ $F77 $FFLAGS -o a.out conftest.o -L${BLAS_LAPACK_DIR} -lblas -llapack
if a.out; then
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5
$as_echo "yes" >&6; }
@@ -15405,8 +15407,6 @@ fi
-
-
echo host = $host
# Set the extension for shared libraries. This is not very robust.
@@ -15415,7 +15415,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/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 lib-src/scaldiv/Makefile"
+ac_config_files="$ac_config_files Makefile start.lisp config.lisp lib/lazy-loader.lisp src/ffi/f77-mangling.lisp lib/blas/Makefile lib/lapack/Makefile lib/dfftpack/Makefile lib/toms715/Makefile lib/matlisp/Makefile lib/odepack/Makefile lib/colnew/Makefile"
echo FLIBS = $FLIBS
@@ -15605,8 +15605,8 @@ if test -z "${LIB32_TRUE}" && test -z "${LIB32_FALSE}"; then
as_fn_error $? "conditional \"LIB32\" was never defined.
Usually this means the macro was only invoked conditionally." "$LINENO" 5
fi
-if test -z "${ATLAS_TRUE}" && test -z "${ATLAS_FALSE}"; then
- as_fn_error $? "conditional \"ATLAS\" was never defined.
+if test -z "${EXT_BLAPACK_TRUE}" && test -z "${EXT_BLAPACK_FALSE}"; then
+ as_fn_error $? "conditional \"EXT_BLAPACK\" was never defined.
Usually this means the macro was only invoked conditionally." "$LINENO" 5
fi
@@ -16535,20 +16535,18 @@ do
case $ac_config_target in
"depfiles") CONFIG_COMMANDS="$CONFIG_COMMANDS depfiles" ;;
"libtool") CONFIG_COMMANDS="$CONFIG_COMMANDS libtool" ;;
- "matlisp.mk") CONFIG_FILES="$CONFIG_FILES matlisp.mk" ;;
"Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;;
"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/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" ;;
- "lib-src/toms715/Makefile") CONFIG_FILES="$CONFIG_FILES lib-src/toms715/Makefile" ;;
- "lib-src/compat/Makefile") CONFIG_FILES="$CONFIG_FILES lib-src/compat/Makefile" ;;
- "lib-src/odepack/Makefile") CONFIG_FILES="$CONFIG_FILES lib-src/odepack/Makefile" ;;
- "lib-src/colnew/Makefile") CONFIG_FILES="$CONFIG_FILES lib-src/colnew/Makefile" ;;
- "lib-src/scaldiv/Makefile") CONFIG_FILES="$CONFIG_FILES lib-src/scaldiv/Makefile" ;;
+ "lib/blas/Makefile") CONFIG_FILES="$CONFIG_FILES lib/blas/Makefile" ;;
+ "lib/lapack/Makefile") CONFIG_FILES="$CONFIG_FILES lib/lapack/Makefile" ;;
+ "lib/dfftpack/Makefile") CONFIG_FILES="$CONFIG_FILES lib/dfftpack/Makefile" ;;
+ "lib/toms715/Makefile") CONFIG_FILES="$CONFIG_FILES lib/toms715/Makefile" ;;
+ "lib/matlisp/Makefile") CONFIG_FILES="$CONFIG_FILES lib/matlisp/Makefile" ;;
+ "lib/odepack/Makefile") CONFIG_FILES="$CONFIG_FILES lib/odepack/Makefile" ;;
+ "lib/colnew/Makefile") CONFIG_FILES="$CONFIG_FILES lib/colnew/Makefile" ;;
*) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;;
esac
diff --git a/configure.ac b/configure.ac
index a687e41..330e6ba 100644
--- a/configure.ac
+++ b/configure.ac
@@ -295,34 +295,33 @@ dnl rm -f ctest.c a.out
dnl AC_MSG_RESULT([$NEED_FF2C])
dnl fi
dnl
-# Allow user to use ATLAS if available.
-# We assume the standard names for the ATLAS libraries.
-AC_ARG_WITH([atlas],
-AC_HELP_STRING([--with-atlas=libpath], [Location of the ATLAS libraries]),
+# Allow user to use external BLAS/LAPACK library if available.
+# We assume the standard names for the libraries: lib{blas, lapack}
+AC_ARG_WITH([blas-lapack],
+AC_HELP_STRING([--with-blas-lapack=libpath], [Location of the BLAS/LAPACK libraries]),
[
- # Building with ATLAS
- ATLAS_DIR="$withval/"
- ATLAS_LIBS="libatlas libcblas libf77blas liblapack"
- atlas=true
- ATLAS_P=t
+ # Building with external BLAS
+ ext_blapack=true
+ BLAS_LAPACK_DIR="$withval/"
+ EXTERNAL_BLAS_LAPACK_P=t
],
[
- # Building without ATLAS. Need these objects from our own copy of
+ # Building without external BLAS. Need these objects from our own copy of
# LAPACK.
- atlas=false
- ATLAS_P=nil
+ ext_blapack=false
+ EXTERNAL_BLAS_LAPACK_P=nil
])
-AM_CONDITIONAL([ATLAS], [test x$atlas = xtrue])
+AM_CONDITIONAL([EXT_BLAPACK], [test x$ext_blapack = xtrue])
-# Check to see if the ATLAS libraries are compatible with matlisp's
+# Check to see if the BLAS library is compatible with matlisp's
# ffi. Basi |
|
From: Akshay S. <ak...@us...> - 2012-08-03 07:07:33
|
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 f27e7165a4d1127a21c7cdb9148b986d92b401d7 (commit)
via 381148cb7fe30e07d45ce8a49d87be081ba795ab (commit)
from b9bf26aaa85df12dec80c1c5b822d8821ed6e9df (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 f27e7165a4d1127a21c7cdb9148b986d92b401d7
Author: Akshay Srinivasan <aks...@gm...>
Date: Fri Aug 3 12:31:59 2012 +0530
o Added file tweakable.lisp to the repo. This file contains the fortran call
lower bounds for every BLAS level.
diff --git a/src/base/tweakable.lisp b/src/base/tweakable.lisp
new file mode 100644
index 0000000..a8cc8cf
--- /dev/null
+++ b/src/base/tweakable.lisp
@@ -0,0 +1,47 @@
+(in-package #:matlisp)
+
+;;Level 1--------------------------------------------------------;;
+(defparameter *real-l1-fcall-lb* 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")
+
+(defparameter *complex-l1-fcall-lb* 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")
+
+;;Level 2--------------------------------------------------------;;
+(defparameter *real-l2-fcall-lb* 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.")
+
+(defparameter *complex-l2-fcall-lb* 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.")
+;;Level 3--------------------------------------------------------;;
+(defparameter *real-l3-fcall-lb* 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.")
+
+(defparameter *complex-l3-fcall-lb* 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.")
commit 381148cb7fe30e07d45ce8a49d87be081ba795ab
Author: Akshay Srinivasan <aks...@gm...>
Date: Fri Aug 3 10:20:24 2012 +0530
o Changed from defparameter to defvar to create hash-tables in standard-tensor.lisp
o Tweaks to :before copy! methods
diff --git a/packages.lisp b/packages.lisp
index 2d65f54..1693289 100644
--- a/packages.lisp
+++ b/packages.lisp
@@ -79,7 +79,7 @@
#:lvec->list #:lvec->list!
;;Macros
#:when-let #:if-let #:if-ret #:with-gensyms #:let-rec
- #:mlet* #:make-array-allocator #:let-typed
+ #:mlet* #:make-array-allocator #:let-typed #:let*-typed
#:nconsc #:define-constant
#:macrofy #:looped-mapcar #:defun-compiler-macro
;;
diff --git a/src/base/generic-copy.lisp b/src/base/generic-copy.lisp
index d560d93..71431fa 100644
--- a/src/base/generic-copy.lisp
+++ b/src/base/generic-copy.lisp
@@ -27,11 +27,7 @@
(= (array-rank x) (array-rank y))
(reduce #'(lambda (x y) (and x y))
(mapcar #'= (array-dimensions x) (array-dimensions y))))
- nil 'dimension-mismatch))
- (:method :before (x (y array))
- (assert (subtypep (type-of x) (array-element-type y))
- nil 'invalid-type
- :given (type-of x) :expected (array-element-type x))))
+ nil 'dimension-mismatch)))
(defmethod copy! ((from cons) (to cons))
(let-rec cdr-writer ((flst from) (tlst to))
@@ -40,7 +36,7 @@
(rplaca tlst (car flst))
(cdr-writer (cdr flst) (cdr tlst))))))
-(defmethod copy! ((from t) (to cons))
+(defmethod copy! (from (to cons))
(mapl #'(lambda (lst) (rplaca lst from)) to)
to)
@@ -52,6 +48,14 @@
(setf (apply #'aref to lst) (apply #'aref from lst)))))
to)
+(defmethod copy! (from (to array))
+ (let ((lst (make-list (array-rank to))))
+ (mod-dotimes (idx (make-index-store (array-dimensions to)))
+ do (progn
+ (lvec->list! idx lst)
+ (setf (apply #'aref to lst) from)))
+ to))
+
;;
(defgeneric copy (object)
(:documentation
diff --git a/src/base/standard-tensor.lisp b/src/base/standard-tensor.lisp
index a1898e7..9899186 100644
--- a/src/base/standard-tensor.lisp
+++ b/src/base/standard-tensor.lisp
@@ -31,7 +31,7 @@
:initial-contents contents))
(definline idxv (&rest contents)
- (apply #'make-index-store contents))
+ (make-index-store contents))
;;
(defclass standard-tensor ()
@@ -123,7 +123,7 @@
(error 'tensor-not-vector :rank (rank old))))
;;
-(defparameter *tensor-counterclass* (make-hash-table)
+(defvar *tensor-counterclass* (make-hash-table)
"
Contains the CLOS counterpart classes of every tensor class.
This is used to change the tensor class automatically to a matrix
@@ -146,7 +146,7 @@
:vector standard-vector))
;;
-(defparameter *tensor-class-optimizations* (make-hash-table)
+(defvar *tensor-class-optimizations* (make-hash-table)
"
Contains a either:
o A property list containing:
diff --git a/src/level-1/copy.lisp b/src/level-1/copy.lisp
index 1afffce..a981a66 100644
--- a/src/level-1/copy.lisp
+++ b/src/level-1/copy.lisp
@@ -182,8 +182,8 @@
:expected (array-element-type y))
(assert (and
(= (rank x) (array-rank y))
- (reduce #'(lambda (x y) (and x y))
- (mapcar #'= (lvec->list (dimensions x)) (array-dimensions y))))
+ (dolist (ele (mapcar #'= (lvec->list (dimensions x)) (array-dimensions y)) t)
+ (unless ele (return nil))))
nil 'dimension-mismatch))
(defmethod copy! ((x real-tensor) (y array))
@@ -216,8 +216,8 @@
:given (array-element-type x) :expected (element-type y))
(assert (and
(= (array-rank x) (rank y))
- (reduce #'(lambda (x y) (= x y))
- (mapcar #'= (array-dimensions x) (lvec->list (dimensions y)))))
+ (dolist (ele (mapcar #'= (array-dimensions x) (lvec->list (dimensions y))) t)
+ (unless ele (return nil))))
nil 'dimension-mismatch))
(defmethod copy! ((x array) (y real-tensor))
diff --git a/src/level-1/tensor-maker.lisp b/src/level-1/tensor-maker.lisp
index 3933496..541d1d2 100644
--- a/src/level-1/tensor-maker.lisp
+++ b/src/level-1/tensor-maker.lisp
@@ -8,10 +8,10 @@
`(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))
- (rnk (length vdim)))
+ (let*-typed ((vdim (make-index-store dims) :type index-store-vector)
+ (ss (very-quickly (lvec-foldl #'(lambda (x y) (the index-type (* x y))) vdim)))
+ (store (,(getf opt :store-allocator) ss))
+ (rnk (length vdim)))
(make-instance (case rnk (2 ',(getf cocl :matrix)) (1 ',(getf cocl :vector)) (t ',tensor-class))
:store store :dimensions vdim)))
(make-from-array (arr)
@@ -21,22 +21,20 @@
(lst (make-list (rank 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 (lvec->list! idx lst))) 'st-r 'of-r)))
+ (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 (lvec->list! idx lst))) 'st-r 'of-r))
ret))
(make-from-list (lst)
(let* ((ret (make-dims (list-dimensions lst)))
(st-r (store ret)))
(declare (type ,tensor-class ret)
(type ,(linear-array-type (getf opt :store-type)) st-r))
- (very-quickly
- (list-loop (idx ele lst)
- with (linear-sums
- (of-r (strides ret) (head ret)))
- do ,(funcall (getf opt :value-writer) `(,(getf opt :coercer) ele) 'st-r 'of-r)))
+ (list-loop (idx ele lst)
+ with (linear-sums
+ (of-r (strides ret) (head ret)))
+ do ,(funcall (getf opt :value-writer) `(,(getf opt :coercer) ele) 'st-r 'of-r))
ret)))
(let ((largs (length args)))
(if (= largs 1)
@@ -55,4 +53,3 @@
;;Had to move it here in the wait for copy!
(definline sub-tensor (tensor subscripts)
(copy (sub-tensor~ tensor subscripts)))
-
-----------------------------------------------------------------------
Summary of changes:
packages.lisp | 2 +-
src/base/generic-copy.lisp | 16 ++++++++-----
src/base/standard-tensor.lisp | 6 ++--
src/base/tweakable.lisp | 47 +++++++++++++++++++++++++++++++++++++++++
src/level-1/copy.lisp | 8 +++---
src/level-1/tensor-maker.lisp | 27 ++++++++++-------------
6 files changed, 77 insertions(+), 29 deletions(-)
create mode 100644 src/base/tweakable.lisp
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2012-08-03 03:51:57
|
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 b9bf26aaa85df12dec80c1c5b822d8821ed6e9df (commit)
via fbb318b4ac5ed7192722ad350298173c4d391a6b (commit)
via 5649455cf8b1d1c0f073d52bda626d393dab67c3 (commit)
via a640a37462d29cefa33c54e9e08c89ded77f29d3 (commit)
via 05cac9e6e247823c2fc6f058da9b3904983e1edb (commit)
via a4355472b2268ce43bafae38350d0e76f186c953 (commit)
via a922933e28c83cbbc1bf9a2dc7ae3341b76fb2cc (commit)
from 8ccded8d5db3d1918b7af875f4dbddd16dc75f28 (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 b9bf26aaa85df12dec80c1c5b822d8821ed6e9df
Author: Akshay Srinivasan <aks...@gm...>
Date: Fri Aug 3 09:16:59 2012 +0530
o Added idxv back.
diff --git a/src/base/standard-tensor.lisp b/src/base/standard-tensor.lisp
index 784d858..a1898e7 100644
--- a/src/base/standard-tensor.lisp
+++ b/src/base/standard-tensor.lisp
@@ -30,6 +30,9 @@
(make-array (length contents) :element-type 'index-type
:initial-contents contents))
+(definline idxv (&rest contents)
+ (apply #'make-index-store contents))
+
;;
(defclass standard-tensor ()
((rank
commit fbb318b4ac5ed7192722ad350298173c4d391a6b
Author: Akshay Srinivasan <aks...@gm...>
Date: Fri Aug 3 09:14:24 2012 +0530
o Added test conditions in make-tensor-maker to create a matrix instance
when rank = 2, and a vector when rank = 1. "change-class" inside the initilize
instance of standard-tensor, in the earlier scheme was too slow.
diff --git a/src/base/standard-tensor.lisp b/src/base/standard-tensor.lisp
index 2fbe3f8..784d858 100644
--- a/src/base/standard-tensor.lisp
+++ b/src/base/standard-tensor.lisp
@@ -77,7 +77,6 @@
:documentation "The actual storage for the tensor."))
(:documentation "Basic tensor class."))
-;;
(defclass standard-matrix (standard-tensor)
((rank
:accessor rank
@@ -86,6 +85,7 @@
:documentation "For a matrix, rank = 2."))
(:documentation "Basic matrix class."))
+;;
(defmethod initialize-instance :after ((matrix standard-matrix) &rest initargs)
(declare (ignore initargs))
(mlet*
@@ -293,8 +293,9 @@
(let-typed ((stds (allocate-index-store rank) :type index-store-vector))
(setf (strides tensor) stds)
(very-quickly
- (loop :for i :downfrom (1- rank) :to 0
- :for st = 1 :then (the index-type (* st (aref dims i)))
+ (loop
+ :for i :downfrom (1- rank) :to 0
+ :and st = 1 :then (the index-type (* st (aref dims i)))
:do (setf (aref stds i) st)))))
;;
(mlet* ((stds (strides tensor) :type index-store-vector)
@@ -313,16 +314,7 @@
(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))
- (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))))))
+ (setf (number-of-elements tensor) (reduce #'* dims))))
;;
(defgeneric tensor-store-ref (tensor store-idx)
@@ -426,7 +418,7 @@
;;
(defun tensor-type-p (tensor subscripts)
-"
+ "
Syntax
======
(tensor-type-p tensor subscripts)
@@ -447,7 +439,7 @@
Also does symbolic association; checking for
a square matrix:
> (tensor-type-p ten '(a a))
-"
+ "
(declare (type standard-tensor tensor))
(mlet* (((rank dims) (slot-values tensor '(rank dimensions))
:type (index-type index-store-vector)))
@@ -470,13 +462,13 @@
nil)))))))
(parse-sub subscripts 0)))))
-(definline vector-p (tensor)
- (declare (type standard-tensor tensor))
- (tensor-type-p tensor '(*)))
+(definline matrix-p (ten)
+ (declare (type standard-tensor ten))
+ (= (slot-value ten 'rank) 2))
-(definline matrix-p (tensor)
- (declare (type standard-tensor tensor))
- (tensor-type-p tensor '(* *)))
+(definline vector-p (ten)
+ (declare (type standard-tensor ten))
+ (= (slot-value ten 'rank) 1))
(defun square-p (tensor)
(let* ((rank (rank tensor))
@@ -560,20 +552,12 @@
(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))
- (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)))))))))
+ (if (null ndim) (tensor-store-ref tensor nhd)
+ (make-instance
+ (let ((nrnk (length ndim)))
+ (if (> nrnk 2) (class-name (class-of tensor))
+ (let ((cocl (get-tensor-counterclass (class-name (class-of tensor)))))
+ (assert cocl nil 'tensor-cannot-find-counter-class :tensor-class (class-name (class-of tensor)))
+ (ecase nrnk (2 (getf cocl :matrix)) (1 (getf cocl :vector))))))
+ :parent-tensor tensor :store (store tensor) :head nhd
+ :dimensions (make-index-store ndim) :strides (make-index-store nstd)))))))
diff --git a/src/level-1/realimag.lisp b/src/level-1/realimag.lisp
index 266bb95..ec51f8a 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-tensor
+ (complex-tensor (make-instance (ecase (rank tensor) (2 'real-matrix) (1 'real-vector) (t 'real-tensor))
:parent-tensor tensor :store (store tensor)
:dimensions (dimensions tensor)
:strides (map 'index-store-vector #'(lambda (x) (* 2 x)) (strides tensor))
@@ -65,7 +65,7 @@
"
(etypecase tensor
(real-tensor tensor)
- (complex-tensor (make-instance 'real-tensor
+ (complex-tensor (make-instance (ecase (rank tensor) (2 'real-matrix) (1 'real-vector) (t 'real-tensor))
:parent-tensor tensor :store (store tensor)
:dimensions (dimensions tensor)
:strides (map 'index-store-vector #'(lambda (x) (* 2 x)) (strides tensor))
diff --git a/src/level-1/tensor-maker.lisp b/src/level-1/tensor-maker.lisp
index 51fa64b..3933496 100644
--- a/src/level-1/tensor-maker.lisp
+++ b/src/level-1/tensor-maker.lisp
@@ -1,15 +1,19 @@
(in-package #:matlisp)
(defmacro make-tensor-maker (func-name (tensor-class))
- (let ((opt (get-tensor-class-optimization tensor-class)))
+ (let ((opt (get-tensor-class-optimization tensor-class))
+ (cocl (get-tensor-counterclass tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
+ (assert cocl nil 'tensor-cannot-find-counter-class :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)))
+ (store (,(getf opt :store-allocator) ss))
+ (rnk (length vdim)))
+ (make-instance (case rnk (2 ',(getf cocl :matrix)) (1 ',(getf cocl :vector)) (t ',tensor-class))
+ :store store :dimensions vdim)))
(make-from-array (arr)
(declare (type (array * *) arr))
(let* ((ret (make-dims (array-dimensions arr)))
commit 5649455cf8b1d1c0f073d52bda626d393dab67c3
Author: Akshay Srinivasan <aks...@gm...>
Date: Thu Aug 2 20:06:20 2012 +0530
o Replaced reference to row-stride in blas-helpers.lisp
diff --git a/src/base/blas-helpers.lisp b/src/base/blas-helpers.lisp
index 94d5e21..00f8bc6 100644
--- a/src/base/blas-helpers.lisp
+++ b/src/base/blas-helpers.lisp
@@ -38,8 +38,8 @@
(defun blas-matrix-compatible-p (matrix op)
(declare (type standard-matrix matrix))
- (let ((rs (row-stride matrix))
- (cs (col-stride 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)))
commit a640a37462d29cefa33c54e9e08c89ded77f29d3
Author: Akshay Srinivasan <aks...@gm...>
Date: Thu Aug 2 00:16:03 2012 +0530
o Saving changes. Inline functions.
diff --git a/packages.lisp b/packages.lisp
index 1bded66..2d65f54 100644
--- a/packages.lisp
+++ b/packages.lisp
@@ -75,6 +75,8 @@
#:format-to-string #:string+
#:linear-array-type
#:list-dimensions
+ #:lvec-foldl #:lvec-foldr #:lvec-max #:lvec-min #:lvec-eq
+ #:lvec->list #:lvec->list!
;;Macros
#:when-let #:if-let #:if-ret #:with-gensyms #:let-rec
#:mlet* #:make-array-allocator #:let-typed
diff --git a/src/base/generic-copy.lisp b/src/base/generic-copy.lisp
index 4445153..d560d93 100644
--- a/src/base/generic-copy.lisp
+++ b/src/base/generic-copy.lisp
@@ -48,7 +48,7 @@
(let ((lst (make-list (array-rank to))))
(mod-dotimes (idx (make-index-store (array-dimensions to)))
do (progn
- (idx->list! idx lst)
+ (lvec->list! idx lst)
(setf (apply #'aref to lst) (apply #'aref from lst)))))
to)
diff --git a/src/base/standard-tensor.lisp b/src/base/standard-tensor.lisp
index d7e9d02..2fbe3f8 100644
--- a/src/base/standard-tensor.lisp
+++ b/src/base/standard-tensor.lisp
@@ -17,18 +17,18 @@
=======
Allocates index storage.")
-(defun make-index-store (&rest contents)
-"
+(definline make-index-store (contents)
+ "
Syntax
======
(MAKE-INDEX-STORE &rest CONTENTS)
Purpose
=======
- Allocates index storage with initial elements from the list CONTENTS."
- (let ((size (length contents)))
- (make-array size :element-type 'index-type
- :initial-contents contents)))
+ Allocates index storage with initial elements from the list CONTENTS.
+ "
+ (make-array (length contents) :element-type 'index-type
+ :initial-contents contents))
;;
(defclass standard-tensor ()
@@ -273,14 +273,14 @@
;;
(defmethod initialize-instance :before ((tensor standard-tensor) &rest initargs)
- (let ((dims (getf initargs :dimensions)))
- (assert (getf initargs :dimensions) nil 'invalid-arguments :argnum :dimensions
- :message "Dimensions are necessary for creating the tensor object.")
- (when (consp dims)
- (setf (getf initargs :dimensions) (apply #'make-index-store dims)))))
+ (assert (getf initargs :dimensions) nil 'invalid-arguments :argnum :dimensions
+ :message "Dimensions are necessary for creating the tensor object."))
(defmethod initialize-instance :after ((tensor standard-tensor) &rest initargs)
(declare (ignore initargs))
+ (let ((dims (dimensions tensor)))
+ (when (consp dims)
+ (setf (slot-value tensor 'dimensions) (make-index-store dims))))
(mlet*
(((dims hd ss) (slot-values tensor '(dimensions head store-size))
:type (index-store-vector index-type index-type))
@@ -290,13 +290,12 @@
;;Row-ordered by default.
(unless (and (slot-boundp tensor 'strides)
(= (length (strides tensor)) rank))
- (mlet* ((stds (allocate-index-store rank)
- :type index-store-vector))
- (setf (strides tensor) stds)
- (do ((i (1- rank) (1- i))
- (st 1 (* st (aref dims i))))
- ((< i 0))
- (setf (aref stds i) st))))
+ (let-typed ((stds (allocate-index-store rank) :type index-store-vector))
+ (setf (strides tensor) stds)
+ (very-quickly
+ (loop :for i :downfrom (1- rank) :to 0
+ :for st = 1 :then (the index-type (* st (aref dims i)))
+ :do (setf (aref stds i) st)))))
;;
(mlet* ((stds (strides tensor) :type index-store-vector)
(L-idx (store-indexing-vec (map `index-store-vector #'1- dims) hd stds dims) :type index-type))
@@ -569,12 +568,12 @@
(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 (apply #'make-index-store ndim) :strides (apply #'make-index-store nstd))))
+ :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 (apply #'make-index-store ndim) :strides (apply #'make-index-store nstd))))
+ :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 (apply #'make-index-store ndim) :strides (apply #'make-index-store nstd)))))))))
+ :dimensions (make-index-store ndim) :strides (make-index-store nstd)))))))))
diff --git a/src/classes/real-tensor.lisp b/src/classes/real-tensor.lisp
index f2c13a8..e7b8602 100644
--- a/src/classes/real-tensor.lisp
+++ b/src/classes/real-tensor.lisp
@@ -41,10 +41,10 @@ Allocates real storage. Default initial-element = 0d0.")
;;
(defmethod initialize-instance ((tensor real-tensor) &rest initargs)
(if (getf initargs :store)
- (setf (store-size tensor) (length (getf initargs :store)))
+ (setf (slot-value tensor 'store-size) (length (getf initargs :store)))
(let ((size (reduce #'* (getf initargs :dimensions))))
- (setf (store tensor) (allocate-real-store size)
- (store-size tensor) size)))
+ (setf (slot-value tensor 'store) (allocate-real-store size)
+ (slot-value tensor 'store-size) size)))
(call-next-method))
;;
diff --git a/src/ffi/foreign-vector.lisp b/src/ffi/foreign-vector.lisp
index ed036c3..f70c459 100644
--- a/src/ffi/foreign-vector.lisp
+++ b/src/ffi/foreign-vector.lisp
@@ -112,10 +112,3 @@
,@body))
`(with-fortran-matrix ,(car array-list)
,@body)))
-
-(defmacro make-array-allocator (allocator-name type init &optional (doc ""))
- `(definline ,allocator-name (size &optional (initial-element ,init))
- ,@(unless (string= doc "")
- `(,doc))
- (make-array size
- :element-type ,type :initial-element initial-element)))
diff --git a/src/level-1/axpy.lisp b/src/level-1/axpy.lisp
index ce870da..3e13987 100644
--- a/src/level-1/axpy.lisp
+++ b/src/level-1/axpy.lisp
@@ -133,7 +133,7 @@
is stored in Y and Y is returned.
")
(:method :before ((alpha number) (x standard-tensor) (y standard-tensor))
- (assert (idx= (dimensions x) (dimensions y)) nil
+ (assert (lvec-eq (dimensions x) (dimensions y) #'=) nil
'tensor-dimension-mismatch))
(:method ((alpha number) (x complex-tensor) (y real-tensor))
(error 'coercion-error :from 'complex-tensor :to 'real-tensor)))
@@ -185,17 +185,17 @@
X,Y must have the same dimensions.
")
(:method :before ((alpha number) (x standard-tensor) (y standard-tensor))
- (unless (idx= (dimensions x) (dimensions y))
+ (unless (lvec-eq (dimensions x) (dimensions y) #'=)
(error 'tensor-dimension-mismatch))))
(defmethod axpy ((alpha number) (x real-tensor) (y real-tensor))
(let ((ret (if (complexp alpha)
- (copy! y (apply #'make-complex-tensor (idx->list (dimensions y))))
+ (copy! y (apply #'make-complex-tensor (lvec->list (dimensions y))))
(copy y))))
(axpy! alpha x ret)))
(defmethod axpy ((alpha number) (x complex-tensor) (y real-tensor))
- (let ((ret (copy! y (apply #'make-complex-tensor (idx->list (dimensions y))))))
+ (let ((ret (copy! y (apply #'make-complex-tensor (lvec->list (dimensions y))))))
(axpy! alpha y ret)))
(defmethod axpy ((alpha number) (x real-tensor) (y complex-tensor))
@@ -212,7 +212,7 @@
(defmethod axpy ((alpha number) (x (eql nil)) (y real-tensor))
(let ((ret (if (complexp alpha)
- (copy! y (apply #'make-complex-tensor (idx->list (dimensions y))))
+ (copy! y (apply #'make-complex-tensor (lvec->list (dimensions y))))
(copy y))))
(axpy! alpha nil ret)))
diff --git a/src/level-1/copy.lisp b/src/level-1/copy.lisp
index 24e087f..1afffce 100644
--- a/src/level-1/copy.lisp
+++ b/src/level-1/copy.lisp
@@ -113,7 +113,7 @@
the type of Y. For example,
a COMPLEX-MATRIX cannot be copied to a
REAL-MATRIX but the converse is possible."
- (assert (idx= (dimensions x) (dimensions y)) nil
+ (assert (lvec-eq (dimensions x) (dimensions y) #'=) nil
'tensor-dimension-mismatch))
(defmethod copy! ((x standard-tensor) (y standard-tensor))
@@ -164,14 +164,14 @@
"
(declare (type standard-tensor tensor))
(let* ((dims (dimensions tensor))
- (ret (make-array (idx->list dims)
+ (ret (make-array (lvec->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-store-vector dims))
(let ((lst (make-list (rank tensor))))
(very-quickly
(mod-dotimes (idx dims)
- do (setf (apply #'aref ret (idx->list! idx lst)) (tensor-ref tensor idx))))
+ do (setf (apply #'aref ret (lvec->list! idx lst)) (tensor-ref tensor idx))))
ret)))
(defmethod copy! :before ((x standard-tensor) (y array))
@@ -183,7 +183,7 @@
(assert (and
(= (rank x) (array-rank y))
(reduce #'(lambda (x y) (and x y))
- (mapcar #'= (idx->list (dimensions x)) (array-dimensions y))))
+ (mapcar #'= (lvec->list (dimensions x)) (array-dimensions y))))
nil 'dimension-mismatch))
(defmethod copy! ((x real-tensor) (y array))
@@ -193,7 +193,7 @@
(mod-dotimes (idx (dimensions x))
with (linear-sums
(of-x (strides x) (head x)))
- do (setf (apply #'aref y (idx->list! idx lst))
+ do (setf (apply #'aref y (lvec->list! idx lst))
(aref sto-x of-x)))))
y)
@@ -204,7 +204,7 @@
(mod-dotimes (idx (dimensions x))
with (linear-sums
(of-x (strides x) (head x)))
- do (setf (apply #'aref y (idx->list! idx lst))
+ do (setf (apply #'aref y (lvec->list! idx lst))
(complex (aref sto-x (* 2 of-x)) (aref sto-x (1+ (* 2 of-x))))))))
y)
@@ -216,8 +216,8 @@
:given (array-element-type x) :expected (element-type y))
(assert (and
(= (array-rank x) (rank y))
- (reduce #'(lambda (x y) (and x y))
- (mapcar #'= (array-dimensions x) (idx->list (dimensions y)))))
+ (reduce #'(lambda (x y) (= x y))
+ (mapcar #'= (array-dimensions x) (lvec->list (dimensions y)))))
nil 'dimension-mismatch))
(defmethod copy! ((x array) (y real-tensor))
@@ -227,7 +227,7 @@
(mod-dotimes (idx (dimensions y))
with (linear-sums
(of-y (strides y) (head y)))
- do (setf (aref sto-y of-y) (apply #'aref x (idx->list! idx lst))))))
+ do (setf (aref sto-y of-y) (apply #'aref x (lvec->list! idx lst))))))
y)
(defmethod copy! ((x array) (y complex-tensor))
@@ -237,7 +237,7 @@
(mod-dotimes (idx (dimensions y))
with (linear-sums
(of-y (strides y) (head y)))
- do (let-typed ((ele (apply #'aref x (idx->list! idx lst)) :type complex-type))
+ do (let-typed ((ele (apply #'aref x (lvec->list! idx lst)) :type complex-type))
(setf (aref sto-y (* 2 of-y)) (realpart ele)
(aref sto-y (1+ (* 2 of-y))) (imagpart ele))))))
y)
@@ -246,12 +246,12 @@
;;Generic function defined in src;base;generic-copy.lisp
(defmethod copy ((tensor real-tensor))
- (let* ((ret (apply #'make-real-tensor (idx->list (dimensions tensor)))))
+ (let* ((ret (apply #'make-real-tensor (lvec->list (dimensions tensor)))))
(declare (type real-tensor ret))
(copy! tensor ret)))
(defmethod copy ((tensor complex-tensor))
- (let* ((ret (apply #'make-complex-tensor (idx->list (dimensions tensor)))))
+ (let* ((ret (apply #'make-complex-tensor (lvec->list (dimensions tensor)))))
(declare (type complex-tensor ret))
(copy! tensor ret)))
diff --git a/src/level-1/dot.lisp b/src/level-1/dot.lisp
index 15bf751..8b777ee 100644
--- a/src/level-1/dot.lisp
+++ b/src/level-1/dot.lisp
@@ -131,7 +131,7 @@
")
(:method :before ((x standard-vector) (y standard-vector) &optional (conjugate-p t))
(declare (ignore conjugate-p))
- (unless (idx= (dimensions x) (dimensions y))
+ (unless (lvec-eq (dimensions x) (dimensions y) #'=)
(error 'tensor-dimension-mismatch))))
(defmethod dot ((x number) (y number) &optional (conjugate-p t))
diff --git a/src/level-1/scal.lisp b/src/level-1/scal.lisp
index 5bdb664..15dfde7 100644
--- a/src/level-1/scal.lisp
+++ b/src/level-1/scal.lisp
@@ -108,7 +108,7 @@
(scal! alpha result)))
(defmethod scal ((alpha complex) (x real-tensor))
- (let* ((result (apply #'make-complex-tensor (idx->list (dimensions x)))))
+ (let* ((result (apply #'make-complex-tensor (lvec->list (dimensions x)))))
(declare (type complex-tensor result))
(copy! x result)
(scal! alpha result)))
diff --git a/src/level-1/swap.lisp b/src/level-1/swap.lisp
index 3d5fa31..081f8c3 100644
--- a/src/level-1/swap.lisp
+++ b/src/level-1/swap.lisp
@@ -62,7 +62,7 @@
;;Generic function in src;base;generic-swap.lisp
(defmethod swap! :before ((x standard-tensor) (y standard-tensor))
- (assert (idx= (dimensions x) (dimensions y)) nil
+ (assert (lvec-eq (dimensions x) (dimensions y) #'=) nil
'tensor-dimension-mismatch))
(defmethod swap! ((x complex-tensor) (y real-tensor))
diff --git a/src/level-1/tensor-maker.lisp b/src/level-1/tensor-maker.lisp
index e06b632..51fa64b 100644
--- a/src/level-1/tensor-maker.lisp
+++ b/src/level-1/tensor-maker.lisp
@@ -13,14 +13,15 @@
(make-from-array (arr)
(declare (type (array * *) arr))
(let* ((ret (make-dims (array-dimensions arr)))
- (st-r (store ret)))
+ (st-r (store ret))
+ (lst (make-list (rank 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)))
+ do ,(funcall (getf opt :value-writer) `(,(getf opt :coercer) (apply #'aref arr (lvec->list! idx lst))) 'st-r 'of-r)))
ret))
(make-from-list (lst)
(let* ((ret (make-dims (list-dimensions lst)))
@@ -50,3 +51,4 @@
;;Had to move it here in the wait for copy!
(definline sub-tensor (tensor subscripts)
(copy (sub-tensor~ tensor subscripts)))
+
diff --git a/src/utilities/lvec.lisp b/src/utilities/lvec.lisp
index 4620d9a..a46edf0 100644
--- a/src/utilities/lvec.lisp
+++ b/src/utilities/lvec.lisp
@@ -1,42 +1,42 @@
(in-package #:matlisp-utilities)
-(defun-compiler-macro lvec-foldl (func vec)
+(definline lvec-foldl (func vec)
(declare (type vector))
(loop
:for i :of-type fixnum :from 0 :below (length vec)
:for ret = (aref vec 0) :then (funcall func (aref vec i) ret)
:finally (return ret)))
-(defun-compiler-macro lvec-foldr (func vec)
+(definline lvec-foldr (func vec)
(declare (type vector))
(loop
:for i :of-type fixnum :downfrom (1- (length vec)) :to 0
:for ret = (aref vec (1- (length vec))) :then (funcall func (aref vec i) ret)
:finally (return ret)))
-(defun-compiler-macro lvec-max (vec)
+(definline lvec-max (vec)
(declare (type vector vec))
(loop :for ele :across vec
:for idx :of-type fixnum = 0 :then (+ idx 1)
:with max :of-type fixnum = (aref vec 0)
- :with max-idx :of-type index-type = 0
+ :with max-idx :of-type fixnum = 0
:do (when (> ele max)
(setf max ele
max-idx idx))
:finally (return (values max max-idx))))
-(defun-compiler-macro lvec-min (vec)
+(definline lvec-min (vec)
(declare (type vector vec))
(loop :for ele :across vec
:for idx :of-type fixnum = 0 :then (+ idx 1)
:with min :of-type fixnum = (aref vec 0)
- :with min-idx :of-type index-type = 0
+ :with min-idx :of-type fixnum = 0
:do (when (< ele min)
(setf min ele
min-idx idx))
:finally (return (values min min-idx))))
-(defun-compiler-macro lvec-eq (va vb &optional (test #'eq))
+(definline lvec-eq (va vb &optional (test #'eq))
(declare (type vector va vb))
(let ((la (length va))
(lb (length vb)))
@@ -48,12 +48,12 @@
:do (return nil)
:finally (return t)))))
-(defun-compiler-macro lvec->list (va)
+(definline lvec->list (va)
(declare (type vector va))
(loop :for ele :across va
:collect ele))
-(defun-compiler-macro lvec->list! (va la)
+(definline lvec->list! (va la)
(declare (type vector va)
(type list la))
(loop
diff --git a/src/utilities/macros.lisp b/src/utilities/macros.lisp
index 9eef3f4..6871843 100644
--- a/src/utilities/macros.lisp
+++ b/src/utilities/macros.lisp
@@ -59,6 +59,13 @@
`(progn
,@body))))
+(defmacro make-array-allocator (allocator-name type init &optional doc)
+ `(definline ,allocator-name (size &optional (initial-element ,init))
+ ,@(unless (null doc)
+ `(,doc))
+ (make-array size
+ :element-type ,type :initial-element initial-element)))
+
(defmacro let-typed (bindings &rest body)
"
This macro works basically like let, but also allows type-declarations
@@ -182,7 +189,7 @@
`(with-gensyms (a b c)
`(let ((,a 1) (,b 2) (,c 3))
(+ ,a ,b ,c))))
- => (LET ((A (GENSYM "A")) (B (GENSYM "B")) (C (GENSYM "C")))
+ => (LET ((A (GENSYM \"A\")) (B (GENSYM \"B\")) (C (GENSYM \"C\")))
`(LET ((,A 1) (,B 2) (,C 3))
(+ ,A ,B ,C)))
@end lisp
@@ -318,42 +325,7 @@
(destructuring-bind (labd args &rest body) lambda-func
(assert (eq labd 'lambda))
`(lambda ,args ,@(cdr (unquote-args body args)))))
-
-(defmacro defun-compiler-macro (func-name (&rest args) &body body)
- "
- Creates a compiler macro mirroring the function definition, this helps
- the compiler produce leaner code when argument types are better known in the
- local environment during compile time.
- DO NOT USE backquotes in the function definition, it will likely be mucked up.
-
- Example:
- @lisp
- > (macroexpand-1
- `(defun-compiler-macro lvec->list (va)
- (declare (type vector va))
- (loop :for ele :across va
- :collect ele)))
- => (PROGN
- (DEFUN LVEC->LIST (VA)
- (DECLARE (TYPE VECTOR VA))
- (LOOP :FOR ELE :ACROSS VA
- :COLLECT ELE))
- (DEFINE-COMPILER-MACRO LVEC->LIST (VA)
- (LIST 'LOCALLY (LIST 'DECLARE (LIST 'TYPE 'VECTOR VA))
- (LIST 'LOOP ':FOR 'ELE ':ACROSS VA ':COLLECT 'ELE))))
- T
- @end lisp
- "
- `(progn
- (defun ,func-name (,@args)
- ,@body)
- (define-compiler-macro ,func-name (,@args)
- (list 'locally
- ,@(cdr (unquote-args body (loop
- :for arg :in args
- :unless (and (symbolp arg) (string= (aref (symbol-name arg) 0) #\&))
- :collect (if (consp arg) (first arg) arg))))))))
-
+
(defmacro looped-mapcar ((func lst) &rest body)
"
A macro to use when caught between the efficiency of imperative looping, and
@@ -491,3 +463,5 @@
"
`(with-optimization (:speed 1)
,@forms))
+
+
diff --git a/tests/loopy-tests.lisp b/tests/loopy-tests.lisp
index e17a747..2ed4ed1 100644
--- a/tests/loopy-tests.lisp
+++ b/tests/loopy-tests.lisp
@@ -32,6 +32,9 @@
(time (axpy! 1d0 x y))
t))
+(definline idxv (&rest dims)
+ (make-array (length dims) :element-type 'index-type :initial-contents dims))
+
(defun test-mm-lisp (n)
(let ((t-a (make-real-tensor n n))
(t-b (make-real-tensor n n))
@@ -52,7 +55,7 @@
(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)
+ (declare (type real-store-vector 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))
@@ -63,7 +66,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
(loop repeat nr-c
for rof-a of-type index-type = hd-a then (+ rof-a rstrd-a)
@@ -76,14 +79,27 @@
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))
+ #+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))
+ (rof-a (idxv rstrd-a 0) (head t-a))
+ (cof-b (idxv 0 cstrd-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)))))))))
-
+ 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 (idxv n n n))
+ with (loop-order :row-major)
+ with (linear-sums
+ (of-a (idxv n 0 1))
+ (of-b (idxv 0 1 n))
+ (of-c (idxv n 1 0)))
+ do (incf (aref st-c of-c) (* (aref st-a of-a) (aref st-b of-b))))))
+ (values t-a t-b t-c))))
(defun test-mm-ddot (n)
commit 05cac9e6e247823c2fc6f058da9b3904983e1edb
Author: Akshay Srinivasan <aks...@gm...>
Date: Wed Aug 1 09:19:21 2012 +0530
Moved utilities.lisp into a new file.
diff --git a/doc/matlisp.texinfo b/doc/matlisp.texinfo
new file mode 100644
index 0000000..1ee0b5c
--- /dev/null
+++ b/doc/matlisp.texinfo
@@ -0,0 +1,91 @@
+\input texinfo
+
+@setfilename matlisp.info
+@settitle Matlisp: User manual
+
+@copying
+blasblasd
+
+@quotation
+asdasd
+
+@end quotation
+@end copying
+
+@titlepage
+@title Matlisp: User manual
+@vskip 0pt plus 1filll
+July, 2012
+@page
+@vskip 0pt plus 1fill
+@insertcopying
+@end titlepage
+
+
+@macro femlisp{}
+@sc{Femlisp}
+@end macro
+
+@macro CL{}
+Common Lisp
+@end macro
+
+@alias module = code
+@alias package = code
+@alias arg = var
+@alias function = code
+@alias macro = code
+@alias symbol = code
+@alias class = symbol
+@alias type = symbol
+@alias slot = symbol
+@alias path = file
+@alias program = file
+
+@macro slisp{code}
+@lisp
+\code\
+@end lisp
+@end macro
+
+
+@c===================================================================================
+@contents
+
+@ifnottex
+@node Top
+
+@end ifnottex
+
+@menu
+* Introduction::
+* Index::
+@end menu
+
+@node Introduction
+@chapter Introduction
+@cindex chapter, Introduction
+
+Matlisp is a asjdhkasd
+
+@deffn Macro CHECK-PROPERTIES @var{PLACE} @var{PROPERTIES}
+@findex CHECK-PROPERTIES
+check-properties place properties
+
+Checks if all of the @arg{properties} are in the property list
+@arg{place}.
+
+@lisp
+(let ((x (make-real-tensor '((1 2 3) (4 5 6)))))
+ (scal! pi x))
+@end lisp
+
+@end deffn
+
+
+@node Index
+@unnumbered Index
+
+@printindex cp
+
+@bye
diff --git a/matlisp.asd b/matlisp.asd
index fb30b24..43f09d1 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -51,9 +51,14 @@
:components ((:file "conditions")))
(asdf:defsystem matlisp-utilities
- :pathname #.(translate-logical-pathname "matlisp:srcdir;src;")
+ :pathname #.(translate-logical-pathname "matlisp:srcdir;src;utilities;")
:depends-on ("matlisp-packages" "matlisp-conditions")
- :components ((:file "utilities")))
+ :components ((:file "functions")
+ (:file "string")
+ (:file "macros"
+ :depends-on ("functions"))
+ (:file "lvec"
+ :depends-on ("macros" "functions"))))
(asdf:defsystem lazy-loader
:pathname #.(translate-logical-pathname "matlisp:lib;")
diff --git a/packages.lisp b/packages.lisp
index e71bae6..1bded66 100644
--- a/packages.lisp
+++ b/packages.lisp
@@ -79,7 +79,7 @@
#:when-let #:if-let #:if-ret #:with-gensyms #:let-rec
#:mlet* #:make-array-allocator #:let-typed
#:nconsc #:define-constant
- #:macrofy #:looped-mapcar
+ #:macrofy #:looped-mapcar #:defun-compiler-macro
;;
#:inlining #:definline
#:with-optimization #:quickly #:very-quickly #:slowly #:quickly-if))
diff --git a/src/base/blas-helpers.lisp b/src/base/blas-helpers.lisp
index 969c3ea..94d5e21 100644
--- a/src/base/blas-helpers.lisp
+++ b/src/base/blas-helpers.lisp
@@ -65,4 +65,3 @@
(defun combine-jobs (&rest jobs)
(let ((job (intern (apply #'concatenate 'string (mapcar #'symbol-name jobs)) "KEYWORD")))
job))
-
diff --git a/src/base/standard-tensor.lisp b/src/base/standard-tensor.lisp
index 6782ccc..d7e9d02 100644
--- a/src/base/standard-tensor.lisp
+++ b/src/base/standard-tensor.lisp
@@ -1,5 +1,6 @@
(in-package #:matlisp)
+;;Alias for fixnum.
(deftype index-type ()
'fixnum)
@@ -16,11 +17,11 @@
=======
Allocates index storage.")
-(defun make-index-store (contents)
+(defun make-index-store (&rest contents)
"
Syntax
======
- (MAKE-INDEX-STORE CONTENTS)
+ (MAKE-INDEX-STORE &rest CONTENTS)
Purpose
=======
@@ -29,41 +30,6 @@
(make-array size :element-type 'index-type
:initial-contents contents)))
-(definline idxv (&rest contents)
- (make-index-store contents))
-
-;;
-(definline idx-max (seq)
- (declare (type index-store-vector seq))
- (very-quickly (reduce #'max seq)))
-
-(definline idx-min (seq)
- (declare (type index-store-vector seq))
- (very-quickly (reduce #'min seq)))
-
-(defun idx= (a b)
- (declare (type index-store-vector 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-store-vector a))
- (loop for ele across a
- collect ele))
-
-(definline idx->list! (a lst)
- ;;No error checking!
- (mapl (let ((i 0))
- #'(lambda (lst)
- (rplaca lst (aref a i))
- (incf i)))
- lst))
;;
(defclass standard-tensor ()
((rank
@@ -311,7 +277,7 @@
(assert (getf initargs :dimensions) nil 'invalid-arguments :argnum :dimensions
:message "Dimensions are necessary for creating the tensor object.")
(when (consp dims)
- (setf (getf initargs :dimensions) (make-index-store dims)))))
+ (setf (getf initargs :dimensions) (apply #'make-index-store dims)))))
(defmethod initialize-instance :after ((tensor standard-tensor) &rest initargs)
(declare (ignore initargs))
@@ -603,12 +569,12 @@
(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))))
+ :dimensions (apply #'make-index-store ndim) :strides (apply #'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))))
+ :dimensions (apply #'make-index-store ndim) :strides (apply #'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)))))))))
+ :dimensions (apply #'make-index-store ndim) :strides (apply #'make-index-store nstd)))))))))
diff --git a/src/utilities.lisp b/src/utilities.lisp
deleted file mode 100644
index 157b98e..0000000
--- a/src/utilities.lisp
+++ /dev/null
@@ -1,441 +0,0 @@
-(in-package #:matlisp-utilities)
-
-;;TODO: cleanup!
-(defmacro mlet* (decls &rest body)
-"
- mlet* ({ {(var*) | var} values-form &keyform declare type}*) form*
-
- o var is just one symbol -> expands into let
- o var is a list -> expands into multiple-value-bind
-
- This macro also handles type declarations.
-
- Example:
- > (mlet* ((x 2 :type fixnum :declare ((optimize (safety 0) (speed 3))))
- ((a b) (floor 3) :type (nil fixnum)))
- (+ x b))
-
- expands into:
-
- > (let ((x 2))
- (declare (optimize (safety 0) (speed 3))
- (type fixnum x))
- (multiple-value-bind (a b)
- (floor 3)
- (declare (ignore a)
- (type fixnum b))
- (+ x b)))
-"
- (labels ((mlet-decl (vars type decls)
- (when (or type decls)
- `((declare ,@decls
- ,@(when type
- (mapcar #'(lambda (tv) (if (null (first tv))
- `(ignore ,(second tv))
- `(type ,(first tv) ,(second tv))))
- (map 'list #'list type vars)))))))
- (mlet-transform (elst nest-code)
- (destructuring-bind (vars form &key declare type) elst
- `(,(append (cond
- ;;If there is only one element use let
- ;;instead of multiple-value-bind
- ((or (symbolp vars))
- `(let ((,vars ,form))))
- (t
- `(multiple-value-bind (,@vars) ,form)))
- (if (symbolp vars)
- (mlet-decl (list vars) (list type) declare)
- (mlet-decl vars type declare))
- nest-code))))
- (mlet-walk (elst body)
- (if (null elst)
- `(,@body)
- (mlet-transform (car elst) (mlet-walk (cdr elst) body)))))
- (if decls
- (car (mlet-walk decls body))
- `(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*
- Works similar to \"let\" in Scheme.
-
- Example:
- > (let-rec rev ((x '(1 2 3 4)) (ret nil))
- (if (null x) ret
- (rev (cdr x) (cons (car x) ret))))
-"
- (let ((init (mapcar #'second arglist))
- (args (mapcar #'first arglist)))
- `(labels ((,name (,@args)
- ,@code))
- (,name ,@init))))
-
-(defmacro with-gensyms (symlist &body body)
-"
- (with-gensyms (var *) form*)
- Binds every variable in SYMLIST to a gensym."
- `(let ,(mapcar #'(lambda (sym)
- `(,sym (gensym ,(symbol-name sym))))
- symlist)
- ,@body))
-
-;; Helper macro to do setf and nconc
-;; for destructive list updates.
-(defmacro nconsc (var &rest args)
- (if (null args) var
- `(if (null ,var)
- (progn
- (setf ,var ,(car args))
- (nconc ,var ,@(cdr args)))
- (nconc ,var ,@args))))
-
-(defun pop-arg! (arglist sym)
- (check-type sym symbol)
- (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)))
-
-(defun slot-values (obj slots)
- (values-list (mapcar #'(lambda (slt) (slot-value obj slt))
- slots)))
-
-(declaim (inline linear-array-type))
-(defun linear-array-type (type-sym &optional (size '*))
- `(simple-array ,type-sym (,size)))
-
-(declaim (inline ensure-list))
-(defun ensure-list (lst)
- (if (listp lst)
- lst
- `(,lst)))
-
-(defmacro if-ret (form &rest else-body)
-"
- if-ret (form &rest else-body)
- Evaluate form, and if the form is not nil, then return it,
- else run else-body"
- (let ((ret (gensym)))
- `(let ((,ret ,form))
- (or ,ret
- (progn
- ,@else-body)))))
-
-;;
-(defmacro when-let ((var . form) &rest body)
- (check-type var symbol)
- `(let ((,var ,@form))
- (when ,var
- ,@body)))
-
-(defmacro if-let ((var . form) &rest body)
- (check-type var symbol)
- `(let ((,var ,@form))
- (if ,var
- ,@body)))
-
-;;
-(defun cut-cons-chain! (lst test)
- (check-type lst cons)
- (labels ((cut-cons-chain-tin (lst test parent-lst)
- (cond
- ((null lst) nil)
- ((funcall test (cadr lst))
- (let ((keys (cdr lst)))
- (setf (cdr lst) nil)
- (values parent-lst keys)))
- (t (cut-cons-chain-tin (cdr lst) test parent-lst)))))
- (cut-cons-chain-tin lst test lst)))
-
-;;
-(defun zip (&rest args)
- (apply #'map 'list #'list args))
-
-;;
-(defmacro mcase (keyform &rest body)
- (labels ((app-equal (lst)
- (if (null lst)
- nil
- `(((and ,@(mapcar (lambda (pair) (cons 'eq pair))
- (zip keyform (caar lst))))
- ,@(cdar lst))
- ,@(app-equal (cdr lst))))))
- `(cond
- ,@(app-equal body))))
-
-(defmacro zip-eq (a b)
- `(and ,@(mapcar (lambda (pair) (cons 'eq pair))
- (zip (ensure-list a) (ensure-list b)))))
-
-(defun recursive-append (&rest lsts)
- (labels ((bin-append (x y)
- (if (null x)
- (if (typep (car y) 'symbol)
- y
- (car y))
- (append x (if (null y)
- nil
- (if (typep (car y) 'symbol)
- `(,y)
- y))))))
- (if (null lsts)
- nil
- (bin-append (car lsts) (apply #'recursive-append (cdr lsts))))))
-
-(defun unquote-args (lst args)
- "
- Makes list suitable for use inside macros (sort-of).
- Example:
- > (unquote-args '(+ x y z) '(x y))
- (LIST '+ X Y 'Z)
-
- DO NOT use backquotes!
- "
- (labels ((replace-atoms (lst ret)
- (cond
- ((null lst) (reverse ret))
- ((atom lst)
- (let ((ret (reverse ret)))
- (rplacd (last ret) lst)
- ret))
- ((consp lst)
- (replace-atoms (cdr lst) (let ((fst (car lst)))
- (cond
- ((atom fst)
- (if (member fst args)
- (cons fst ret)
- (append `(',fst) ret)))
- ((consp fst)
- (cons (replace-lst fst nil) ret))))))))
- (replace-lst (lst acc)
- (cond
- ((null lst) acc)
- ((consp lst)
- (if (eq (car lst) 'quote)
- lst
- (cons 'list (replace-atoms lst nil))))
- ((atom lst) lst))))
- (replace-lst lst nil)))
-
-(defun flatten (x)
- (labels ((rec (x acc)
- (cond ((null x) acc)
- ((atom x) (cons x acc))
- (t (rec
- (car x)
- (rec (cdr x) acc))))))
- (rec x nil)))
-
-(defmacro macrofy (lambda-func)
- "
- Macrofies a lambda function, for use later inside macros (or for symbolic math ?).
- Example:
- > (macroexpand-1 `(macrofy (lambda (x y z) (+ (sin x) y (apply #'cos (list z))))))
- (LAMBDA (X Y Z)
- (LIST '+ (LIST 'SIN X) Y (LIST 'APPLY (LIST 'FUNCTION 'COS) (LIST 'LIST Z))))
- T
- > (funcall (macrofy (lambda (x y z) (+ (sin x) y (apply #'cos (list z))))) 'a 'b 'c)
- (+ (SIN A) B (APPLY #'COS (LIST C)))
-
- DO NOT USE backquotes in the lambda function!
- "
- (destructuring-bind (labd args &rest body) lambda-func
- (assert (eq labd 'lambda))
- `(lambda ,args ,@(cdr (unquote-args body args)))))
-
-(defmacro looped-mapcar ((func lst) &rest body)
- "
- A macro to use when caught between the efficiency of imperative looping, and
- the elegance of mapcar (in a dozen places).
-
- Collects references to func and replaces them with a varible inside a loop.
- Note that although we traverse through the list only once, the collected lists
- aren't freed until the macro is closed.
-
- Example:
- > (macroexpand-1
- `(looped-mapcar (lmap '(1 2 3 4 5 6 7 8 9 10))
- (cons (lmap #'even) (lmap #'(lambda (x) (+ x 1))))))
- (LET ((#:|lst1118| '(1 2 3 4 5 6 7 8 9 10)))
- (LOOP FOR #:|ele1117| IN #:|lst1118|
- COLLECT (FUNCALL #'(LAMBDA (X) (+ X 1))
- #:|ele1117|) INTO #:|collect1116|
- COLLECT (FUNCALL #'EVEN #:|ele1117|) INTO #:|collect1115|
- FINALLY (RETURN (PROGN (CONS #:|collect1115| #:|collect1116|)))))
- "
- (let ((ret nil))
- (labels ((collect-funcs (code tf-code)
- (cond
- ((null code)
- (reverse tf-code))
- ((atom code)
- (let ((ret (reverse tf-code)))
- (rplacd (last ret) code)
- ret))
- ((consp code)
- (let ((carcode (car code)))
- (cond
- ((and (consp carcode)
- (eq (first carcode) func))
- (assert (null (cddr carcode)) nil 'invalid-arguments
- :message "The mapper only takes one argument.")
- (let ((col-sym (gensym "collect")))
- (push `(,col-sym ,(second carcode)) ret)
- (collect-funcs (cdr code) (cons col-sym tf-code))))
- ((consp carcode)
- (collect-funcs (cdr code) (cons (collect-funcs carcode nil) tf-code)))
- (t
- (collect-funcs (cdr code) (cons carcode tf-code)))))))))
- (let ((tf-code (collect-funcs body nil))
- (ele-sym (gensym "ele"))
- (lst-sym (gensym "lst")))
- (if (null ret)
- `(progn
- ,@tf-code)
- `(let ((,lst-sym ,lst))
- (loop for ,ele-sym in ,lst-sym
- ,@(loop for decl in ret
- append `(collect (funcall ,(second decl) ,ele-sym) into ,(first decl)))
- finally (return
- (progn
- ,@tf-code)))))))))
-
-(declaim (inline string+))
-(defun string+ (&rest strings)
- (apply #'concatenate (cons 'string strings)))
-
-(defun format-to-string (fmt &rest args)
- (let ((ret (make-array 0 :element-type 'character :adjustable t :fill-pointer t)))
- (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)))
-
-(defmacro define-constant (name value &optional doc)
- "
- Keeps the lisp implementation from defining constants twice.
- "
- `(defconstant ,name (if (boundp ',name) (symbol-value ',name) ,value)
- ,@(when doc (list doc))))
-
-(defmacro inlining (&rest definitions)
- "Declaims the following definitions inline together with executing them."
- `(progn ,@(loop for def in definitions when (eq (first def) 'defun) collect
- `(declaim (inline ,(second def))) collect def)))
-
-(defmacro definline (name &rest rest)
- "Short form for defining an inlined function. It should probably be
-deprecated, because it won't be recognized by default by some IDEs. Better
-use the inlining macro directly."
- `(inlining (defun ,name ,@rest)))
-
-;;TODO: Add general permutation support for currying, and composition.
-(inlining
- (defun curry (func &rest args)
- "Supplies @arg{args} to @arg{func} from the left."
- #'(lambda (&rest after-args)
- (apply func (append args after-args)))))
-
-;;---------------------------------------------------------------;;
-;; Optimization
-;;---------------------------------------------------------------;;
-;;TODO: Figure out a way of adding \"#+lispworks (float 0)\"
-(defmacro with-optimization ((&key speed safety space debug) &body forms)
- "with-optimization (&key speed safety space debug) declaration* form*
- Macro creates a local environment with optimization declarations, and
- executes form*"
- (mapcar #'(lambda (x) (assert (member x '(nil 0 1 2 3))))
- (list speed safety space debug))
- `(locally
- ,(recursive-append
- `(declare ,(append `(optimize)
- (when speed
- `((speed ,speed)))
- (when safety
- `((safety ,safety)))
- (when space
- `((space ,space)))
- (when debug
- `((debug ,debug)))))
- (when (eq (caar forms) 'declare)
- (cdar forms)))
- ,@(if (eq (caar forms) 'declare) (cdr forms) forms)))
-
-(defmacro quickly (&body forms)
- `(with-optimization (:speed 3)
- ,@forms))
-
-(defmacro very-quickly (&body forms)
- `(with-optimization (:safety 0 :space 0 :speed 3)
- ,@forms))
-
-(defmacro slowly (&body forms)
- `(with-optimization (:speed 1)
- ,@forms))
-
-(defmacro quickly-if (test &body forms)
- `(if ,test ;runtime test
- (quickly ,@forms)
- (progn ,@forms)))
-;;---------------------------------------------------------------;;
-
diff --git a/src/utilities/functions.lisp b/src/utilities/functions.lisp
new file mode 100644
index 0000000..fb9d9fa
--- /dev/null
+++ b/src/utilities/functions.lisp
@@ -0,0 +1,219 @@
+(in-package #:matlisp-utilities)
+
+(declaim (inline slot-values))
+(defun slot-values (obj slots)
+ "
+ Returns the slots of the @arg{obj} corresponding to symbols in the list @arg{slots}.
+
+ Example:
+ @lisp
+ > (defstruct obj a b)
+ => OBJ
+
+ > (let ((thing (make-obj :a 1 :b 2)))
+ (slot-values thing '(a b)))
+ => 1 2
+ @end lisp
+ "
+ (values-list
+ (loop :for slt :in slots
+ :collect (slot-value obj slt))))
+
+(declaim (inline linear-array-type))
+(defun linear-array-type (type-sym &optional (size '*))
+ "
+ Creates the list representing simple-array with type @arg{type-sym}.
+
+ Example:
+ @lisp
+ > (linear-array-type 'double-float 10)
+ => (simple-array double-float (10))
+ @end lisp
+ "
+ `(simple-array ,type-sym (,size)))
+
+(declaim (inline ensure-list))
+(defun ensure-list (lst)
+ "
+ Ensconses @arg{lst} inside a list if it is an atom.
+
+ Example:
+ @lisp
+ > (ensure-list 'a)
+ => (a)
+ @end lisp
+ "
+ (if (listp lst) lst `(,lst)))
+
+(defun cut-cons-chain! (lst test)
+ "
+ Destructively cuts @arg{lst} into two parts, at the element where the function
+ @arg{test} returns a non-nil value.
+
+ Example:
+ @lisp
+ > (let ((x (list 3 5 2 1 7 9)))
+ (values-list (cons x (multiple-value-list (cut-cons-chain! x #'evenp)))))
+ => (3 5) (3 5) (2 1 7 9)
+ @end lisp
+ "
+ (declare (type list lst))
+ (labels ((cut-cons-chain-tin (lst test parent-lst)
+ (cond
+ ((null lst) nil)
+ ((funcall test (cadr lst))
+ (let ((keys (cdr lst)))
+ (setf (cdr lst) nil)
+ (values parent-lst keys)))
+ (t (cut-cons-chain-tin (cdr lst) test parent-lst)))))
+ (cut-cons-chain-tin lst test lst)))
+
+(declaim (inline zip))
+(defun zip (&rest args)
+ "
+ Zips the elements of @arg{args}.
+
+ Example:
+ @lisp
+ > (zip '(2 3 4) '(a b c) '(j h c s))
+ => ((2 A J) (3 B H) (4 C C))
+ @end lisp
+ "
+ (apply #'map 'list #'list args))
+
+(defun recursive-append (&rest lsts)
+ "
+ Appends lists in a nested manner, mostly used to bring in the charm of
+ non-lispy languages into macros.
+
+ Basically does
+ @lisp
+ (reduce
+ #'(lambda (x y)
+ (if (null x)
+ (if (typep (car y) 'symbol) y (car y))
+ (append x (if (null y) nil
+ (if (typep (car y) 'symbol) `(,y) y)))))
+ lsts :from-end t)
+ @end lisp
+
+ Examples:
+ @lisp
+ > (recursive-append
+ '(let ((x 1)))
+ '(+ x 2))
+ => (LET ((X 1))
+ (+ X 2))
+
+ > (recursive-append
+ '(let ((x 1)))
+ '((let ((y 2))
+ (setq y 3))
+ (let ((z 2))
+ z)))
+ => (LET ((X 1))
+ (LET ((Y 2))
+ (SETQ Y 3))
+ (LET ((Z 2))
+ Z))
+
+ > (recursive-append
+ nil
+ '((let ((x 1)) x)
+ (progn (+ 1 2))))
+ => (LET ((X 1))
+ X)
+
+ > (recursive-append nil '(let ((x 1)) x))
+ => (LET ((X 1))
+ X)
+ @end lisp
+ "
+ (labels ((bin-append (x y)
+ (if (null x)
+ (if (typep (car y) 'symbol) y (car y))
+ (append x (if (null y) nil
+ (if (typep (car y) 'symbol) `(,y) y))))))
+ (reduce #'bin-append lsts :from-end t)))
+
+(defun unquote-args (lst args)
+ "
+ Makes a list suitable for use inside macros (sort-of), by building a
+ new list quoting every symbol in @arg{lst} other than those in @arg{args}.
+ CAUTION: DO NOT use backquotes!
+
+ @lisp
+ Example:
+ > (unquote-args '(+ x y z) '(x y))
+ => (LIST '+ X Y 'Z)
+
+ > (unquote-args '(let ((x 1)) (+ x 1)) '(x))
+ => (LIST 'LET (LIST (LIST X '1)) (LIST '+ X '1))
+ @end lisp
+ "
+ (labels ((replace-atoms (lst ret)
+ (cond
+ ((null lst) (reverse ret))
+ ((atom lst)
+ (let ((ret (reverse ret)))
+ (rplacd (last ret) lst)
+ ret))
+ ((consp lst)
+ (replace-atoms (cdr lst) (let ((fst (car lst)))
+ (cond
+ ((atom fst)
+ (if (member fst args)
+ (cons fst ret)
+ (append `(',fst) ret)))
+ ((consp fst)
+ (cons (replace-lst fst nil) ret))))))))
+ (replace-lst (lst acc)
+ (cond
+ ((null lst) acc)
+ ((consp lst)
+ (if (eq (car lst) 'quote)
+ lst
+ (cons 'list (replace-atoms lst nil))))
+ ((atom lst) lst))))
+ (replace-lst lst nil)))
+
+(defun flatten (x)
+ "
+ Returns a new list by collecting all the symbols found in @arg{x}.
+ Borrowed from Onlisp.
+
+ Example:
+ @lisp
+ > (flatten '(let ((x 1)) (+ x 2)))
+ => (LET X 1 + X 2)
+ @end lisp
+ "
+ (labels ((rec (x acc)
+ (cond ((null x) acc)
+ ((atom x) (cons x acc))
+ (t (rec
+ (car x)
+ (rec (cdr x) acc))))))
+ (rec x nil)))
+
+(defun list-dimensions (lst)
+ "
+ Returns the dimensions of the nested list @arg{lst}, by finding the length
+ of the immediate list, recursively. This does not ensure the uniformity of
+ lengths of the lists.
+
+ Example:
+ @lisp
+ > (list-dimensions '((1 2 3) (4 5 6)))
+ => (2 3)
+ @end lisp
+ "
+ (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)))
diff --git a/src/utilities/lvec.lisp b/src/utilities/lvec.lisp
new file mode 100644
index 0000000..4620d9a
--- /dev/null
+++ b/src/utilities/lvec.lisp
@@ -0,0 +1,63 @@
+(in-package #:matlisp-utilities)
+
+(defun-compiler-macro lvec-foldl (func vec)
+ (declare (type vector))
+ (loop
+ :for i :of-type fixnum :from 0 :below (length vec)
+ :for ret = (aref vec 0) :then (funcall func (aref vec i) ret)
+ :finally (return ret)))
+
+(defun-compiler-macro lvec-foldr (func vec)
+ (declare (type vector))
+ (loop
+ :for i :of-type fixnum :downfrom (1- (length vec)) :to 0
+ :for ret = (aref vec (1- (length vec))) :then (funcall func (aref vec i) ret)
+ :finally (return ret)))
+
+(defun-compiler-macro lvec-max (vec)
+ (declare (type vector vec))
+ (loop :for ele :across vec
+ :for idx :of-type fixnum = 0 :then (+ idx 1)
+ :with max :of-type fixnum = (aref vec 0)
+ :with max-idx :of-type index-type = 0
+ :do (when (> ele max)
+ (setf max ele
+ max-idx idx))
+ :finally (return (values max max-idx))))
+
+(defun-compiler-macro lvec-min (vec)
+ (declare (type vector vec))
+ (loop :for ele :across vec
+ :for idx :of-type fixnum = 0 :then (+ idx 1)
+ :with min :of-type fixnum = (aref vec 0)
+ :with min-idx :of-type index-type = 0
+ :do (when (< ele min)
+ (setf min ele
+ min-idx idx))
+ :finally (return (values min min-idx))))
+
+(defun-compiler-macro lvec-eq (va vb &optional (test #'eq))
+ (declare (type vector va vb))
+ (let ((la (length va))
+ (lb (length vb)))
+ (if (/= la lb) nil
+ (loop
+ :for ele-a :across va
+ :for ele-b :across vb
+ :unless (funcall test ele-a ele-b)
+ :do (return nil)
+ :finally (return t)))))
+
+(defun-compiler-macro lvec->list (va)
+ (declare (type vector va))
+ (loop :for ele :across va
+ :collect ele))
+
+(defun-compiler-macro lvec->list! (va la)
+ (declare (type vector va)
+ (type list la))
+ (loop
+ :for ele :across va
+ :for lst = la :then (cdr lst)
+ :do (setf (car lst) ele))
+ la)
diff --git a/src/utilities/macros.lisp b/src/utilities/macros.lisp
new file mode 100644
index 0000000..9eef3f4
--- /dev/null
+++ b/src/utilities/macros.lisp
@@ -0,0 +1,493 @@
+(in-package #:matlisp-utilities)
+
+(defmacro define-constant (name value &optional doc)
+ "
+ Keeps the lisp implementation from defining constants twice.
+ "
+ `(defconstant ,name (if (boundp ',name) (symbol-value ',name) ,value)
+ ,@(when doc (list doc))))
+
+(defmacro mlet* (vars &rest body)
+ "
+ This macro extends the syntax of let* to handle multiple values, it also handles
+ type declarations. The declarations list @arg{vars} is similar to that in let: look
+ at the below examples.
+
+ Examples:
+ @lisp
+ > (macroexpand-1
+ `(mlet* ((x 2 :type fixnum :declare ((optimize (safety 0) (speed 3))))
+ ((a b) (floor 3) :type (nil fixnum)))
+ (+ x b)))
+ => (LET ((X 2))
+ (DECLARE (OPTIMIZE (SAFETY 0) (SPEED 3))
+ (TYPE FIXNUM X))
+ (MULTIPLE-VALUE-BIND (A B)
+ (FLOOR 3)
+ (DECLARE (IGNORE A)
+ (TYPE FIXNUM B))
+ (+ X B)))
+ @end lisp
+ "
+ (labels ((mlet-decl (vars type decls)
+ (when (or type decls)
+ `((declare ,@decls
+ ,@(when type
+ (mapcar #'(lambda (tv) (if (null (first tv))
+ `(ignore ,(second tv))
+ `(type ,(first tv) ,(second tv))))
+ (map 'list #'list type vars)))))))
+ (mlet-transform (elst nest-code)
+ (destructuring-bind (vars form &key declare type) elst
+ `(,(append (cond
+ ;;If there is only one element use let
+ ;;instead of multiple-value-bind
+ ((or (symbolp vars))
+ `(let ((,vars ,form))))
+ (t
+ `(multiple-value-bind (,@vars) ,form)))
+ (if (symbolp vars)
+ (mlet-decl (list vars) (when type (list type)) declare)
+ (mlet-decl vars type declare))
+ nest-code))))
+ (mlet-walk (elst body)
+ (if (null elst)
+ `(,@body)
+ (mlet-transform (car elst) (mlet-walk (cdr elst) body)))))
+ (if vars
+ (car (mlet-walk vars body))
+ `(progn
+ ,@body))))
+
+(defmacro let-typed (bindings &rest body)
+ "
+ This macro works basically like let, but also allows type-declarations
+ with the key :type.
+
+ Example:
+ @lisp
+ > (macroexpand-1
+ `(let-typed ((x 1 :type fixnum))
+ ...
[truncated message content] |
|
From: Akshay S. <ak...@us...> - 2012-07-26 13:31: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 8ccded8d5db3d1918b7af875f4dbddd16dc75f28 (commit)
via 284a1e7bcb18ff7bc25e53d2b636d4fe5c963205 (commit)
via 855c687f17ce0468bd189e8c6f9942ad5cec2999 (commit)
via 9980ae3686cf6361c2e8d8dec95d85f355b3a5d8 (commit)
via 0fc0b662754ddb98367d6add3aeb42f71a9301aa (commit)
via 83ad581a242f7fd2c6416dc115192692a7447c35 (commit)
from 9a94775cd4eb5593fea88f5cf665bcadc198fb6f (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 8ccded8d5db3d1918b7af875f4dbddd16dc75f28
Author: Akshay Srinivasan <aks...@gm...>
Date: Thu Jul 26 18:56:33 2012 +0530
o Made copy and swap a generic method. Added support for permute! to handle tensors.
diff --git a/matlisp.asd b/matlisp.asd
index 3bbf437..d0e7c0f 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -40,10 +40,10 @@
((:file "packages")))
(asdf:defsystem matlisp-config
- :pathname #.(translate-logical-pathname "matlisp:builddir;")
- :depends-on ("matlisp-packages")
- :components
- ((:file "config")))
+ :pathname #.(translate-logical-pathname "matlisp:builddir;")
+ :depends-on ("matlisp-packages")
+ :components
+ ((:file "config")))
(asdf:defsystem matlisp-conditions
:depends-on ("matlisp-packages" "matlisp-config")
@@ -101,8 +101,12 @@
;;
(:file "loopy"
:depends-on ("standard-tensor"))
+ (:file "generic-copy"
+ :depends-on ("standard-tensor" "loopy"))
+ (:file "generic-swap"
+ :depends-on ("standard-tensor" "loopy"))
(:file "permutation"
- :depends-on ("standard-tensor"))
+ :depends-on ("standard-tensor" "generic-copy" "generic-swap"))
(:file "blas-helpers"
:depends-on ("standard-tensor" "permutation"))
(:file "print"
diff --git a/packages.lisp b/packages.lisp
index ca65b2c..e71bae6 100644
--- a/packages.lisp
+++ b/packages.lisp
@@ -33,9 +33,10 @@
;;<conditon {accessors*}>
;;Generic errors
#:generic-error #:message
+ #:dimension-mismatch
#:assumption-violated
#:invalid-type #:given #:expected
- #:invalid-arguments
+ #:invalid-arguments #:argnum
#:invalid-value #:given #:expected
#:unknown-token #:token
#:parser-error
diff --git a/src/base/blas-helpers.lisp b/src/base/blas-helpers.lisp
index 1e3fcb6..969c3ea 100644
--- a/src/base/blas-helpers.lisp
+++ b/src/base/blas-helpers.lisp
@@ -38,8 +38,8 @@
(defun blas-matrix-compatible-p (matrix op)
(declare (type standard-matrix matrix))
- (let ((rs (aref (strides matrix) 0))
- (cs (aref (strides matrix) 1)))
+ (let ((rs (row-stride matrix))
+ (cs (col-stride matrix)))
(declare (type index-type rs cs))
(cond
((= cs 1) (values :row-major rs (fortran-nop op)))
diff --git a/src/base/generic-copy.lisp b/src/base/generic-copy.lisp
new file mode 100644
index 0000000..4445153
--- /dev/null
+++ b/src/base/generic-copy.lisp
@@ -0,0 +1,72 @@
+(in-package #:matlisp)
+
+(defgeneric copy! (from-tensor to-tensor)
+ (:documentation
+ "
+ Syntax
+ ======
+ (COPY! x y)
+
+ Purpose
+ =======
+ Copies the contents of X into Y. Returns Y.
+
+ X,Y must have the same dimensions, and
+ ergo the same number of elements.
+
+ Furthermore, X may be a scalar, in which
+ case Y is filled with X.
+")
+ (:method :before ((x cons) (y cons))
+ (assert (= (length x) (length y))))
+ (:method :before ((x array) (y array))
+ (assert (subtypep (array-element-type x) (array-element-type y))
+ nil 'invalid-type
+ :given (array-element-type y) :expected (array-element-type x))
+ (assert (and
+ (= (array-rank x) (array-rank y))
+ (reduce #'(lambda (x y) (and x y))
+ (mapcar #'= (array-dimensions x) (array-dimensions y))))
+ nil 'dimension-mismatch))
+ (:method :before (x (y array))
+ (assert (subtypep (type-of x) (array-element-type y))
+ nil 'invalid-type
+ :given (type-of x) :expected (array-element-type x))))
+
+(defmethod copy! ((from cons) (to cons))
+ (let-rec cdr-writer ((flst from) (tlst to))
+ (if (null flst) to
+ (progn
+ (rplaca tlst (car flst))
+ (cdr-writer (cdr flst) (cdr tlst))))))
+
+(defmethod copy! ((from t) (to cons))
+ (mapl #'(lambda (lst) (rplaca lst from)) to)
+ to)
+
+(defmethod copy! ((from array) (to array))
+ (let ((lst (make-list (array-rank to))))
+ (mod-dotimes (idx (make-index-store (array-dimensions to)))
+ do (progn
+ (idx->list! idx lst)
+ (setf (apply #'aref to lst) (apply #'aref from lst)))))
+ to)
+
+;;
+(defgeneric copy (object)
+ (:documentation
+ "
+ Syntax
+ ======
+ (COPY x)
+
+ Purpose
+ =======
+ Return a copy of X"))
+
+(defmethod copy ((lst cons))
+ (copy-list lst))
+
+(defmethod copy ((arr array))
+ (let ((ret (make-array (array-dimensions arr) :element-type (array-element-type arr))))
+ (copy! arr ret)))
diff --git a/src/base/generic-swap.lisp b/src/base/generic-swap.lisp
new file mode 100644
index 0000000..058f3c1
--- /dev/null
+++ b/src/base/generic-swap.lisp
@@ -0,0 +1,19 @@
+(in-package #:matlisp)
+
+(defgeneric swap! (x y)
+ (:documentation
+"
+ Sytnax
+ ======
+ (SWAP! x y)
+
+ Purpose
+ =======
+ Given tensors X,Y, performs:
+
+ X <-> Y
+
+ and returns Y.
+
+ X, Y must have the same dimensions.
+"))
diff --git a/src/base/permutation.lisp b/src/base/permutation.lisp
index 2e866ec..51a405f 100644
--- a/src/base/permutation.lisp
+++ b/src/base/permutation.lisp
@@ -158,22 +158,28 @@
(make-instance 'permutation-pivot-flip :repr pact))
;;Generic permute! method.
-(defgeneric permute! (seq perm)
+(defgeneric permute! (thing permutation &optional argument)
(:documentation "
- (permute! seq perm)
+ (permute! thing permutation [argument 0])
- Applies the permutation on the sequence.
-")
- (:method :before ((seq sequence) (perm permutation))
+ Permutes the ARGUMENT index of the the array-like object THING, by
+ applying PERMUTATION on it.")
+ (:method :before ((seq sequence) (perm permutation) &optional (arg 0))
+ (declare (ignore arg))
(let ((len (length seq)))
(assert (>= len (group-rank perm)) nil
+ 'permutation-permute-error :seq-len len :group-rank (group-rank perm))))
+ (:method :before ((ten standard-tensor) (perm permutation) &optional (arg 0))
+ (let ((len (aref (dimensions ten) arg)))
+ (assert (>= len (group-rank perm)) nil
'permutation-permute-error :seq-len len :group-rank (group-rank perm)))))
-
-(definline permute (seq perm)
- (permute! (copy-seq seq) perm))
+
+(definline permute (thing perm &optional (arg 0))
+ (permute! (copy thing) perm arg))
;;Action
-(defmethod permute! ((seq cons) (perm permutation-action))
+(defmethod permute! ((seq cons) (perm permutation-action) &optional arg)
+ (declare (ignore arg))
(let ((cseq (make-array (length seq) :initial-contents seq))
(act (repr perm))
(glen (group-rank perm)))
@@ -185,7 +191,8 @@
(rplaca x (aref cseq (aref act i)))
(incf i)))) seq)))
-(defmethod permute! ((seq vector) (perm permutation-action))
+(defmethod permute! ((seq vector) (perm permutation-action) &optional arg)
+ (declare (ignore arg))
(let ((cseq (make-array (length seq) :initial-contents seq))
(act (repr perm)))
(loop
@@ -205,7 +212,8 @@
(if (= i 0) xl
(aref seq (aref pcyc (1- i))))))))
-(defmethod permute! ((seq cons) (perm permutation-cycle))
+(defmethod permute! ((seq cons) (perm permutation-cycle) &optional arg)
+ (declare (ignore arg))
(let ((cseq (make-array (length seq) :initial-contents seq))
(glen (group-rank perm)))
(dolist (cyc (repr perm))
@@ -218,20 +226,23 @@
(rplaca x (aref cseq i))
(incf i)))) seq)))
-(defmethod permute! ((seq vector) (perm permutation-cycle))
+(defmethod permute! ((seq vector) (perm permutation-cycle) &optional arg)
+ (declare (ignore arg))
(dolist (cyc (repr perm) seq)
(declare (type perrepr-vector cyc))
(apply-cycle! seq cyc)))
;;Pivot idx
-(defmethod permute! ((seq vector) (perm permutation-pivot-flip))
+(defmethod permute! ((seq vector) (perm permutation-pivot-flip) &optional arg)
+ (declare (ignore arg))
(let-typed ((pidx (repr perm) :type perrepr-vector))
(loop for i of-type index-type from 0 below (group-rank perm)
unless (= i (aref pidx i))
do (rotatef (aref seq i) (aref seq (aref pidx i)))
finally (return seq))))
-(defmethod permute! ((seq cons) (perm permutation-pivot-flip))
+(defmethod permute! ((seq cons) (perm permutation-pivot-flip) &optional arg)
+ (declare (ignore arg))
(let ((cseq (make-array (length seq) :initial-contents seq))
(glen (group-rank perm)))
(permute! cseq perm)
@@ -242,6 +253,20 @@
(rplaca x (aref cseq i))
(incf i)))) seq)))
+(defmethod permute! ((A standard-tensor) (perm permutation-pivot-flip) &optional (arg 0))
+ (let ((idiv (repr perm)))
+ (multiple-value-bind (tone ttwo) (let ((slst (make-list (rank A) :initial-element '\:)))
+ (rplaca (nthcdr arg slst) 0)
+ (values (sub-tensor~ A slst nil) (sub-tensor~ A slst nil)))
+ (let ((argstd (aref (strides A) arg)))
+ (loop for i from 0 below (length idiv)
+ do (progn
+ (unless (= i (aref idiv i))
+ (setf (head ttwo) (* (aref idiv i) argstd))
+ (swap! tone ttwo))
+ (incf (head tone) argstd))))))
+ A)
+
;;Conversions----------------------------------------------------;;
(defun action->cycle (act)
"
@@ -412,6 +437,5 @@
(qsort-bounds todo)))))))
(qsort-bounds `((0 ,len)))
(values seq (action->cycle (make-paction perm))))))
-
;;Add a general sorter, this is a very useful thing to have.
;;Add a function to apply permutations to a matrices, tensors.
diff --git a/src/base/standard-tensor.lisp b/src/base/standard-tensor.lisp
index c27af81..3ff61e3 100644
--- a/src/base/standard-tensor.lisp
+++ b/src/base/standard-tensor.lisp
@@ -57,6 +57,13 @@
(loop for ele across a
collect ele))
+(definline idx->list! (a lst)
+ ;;No error checking!
+ (mapl (let ((i 0))
+ #'(lambda (lst)
+ (rplaca lst (aref a i))
+ (incf i)))
+ lst))
;;
(defclass standard-tensor ()
((rank
@@ -72,6 +79,10 @@
:accessor number-of-elements
:type index-type
:documentation "Total number of elements in the tensor.")
+ (element-type
+ :accessor element-type
+ :type symbol
+ :documentation "Element type of the tensor")
;;
(parent-tensor
:accessor parent-tensor
diff --git a/src/classes/complex-tensor.lisp b/src/classes/complex-tensor.lisp
index 9692b49..5e689f0 100644
--- a/src/classes/complex-tensor.lisp
+++ b/src/classes/complex-tensor.lisp
@@ -39,9 +39,8 @@
;;
(defclass complex-tensor (standard-tensor)
- ((store
- :initform nil
- :type complex-store-vector))
+ ((store :type complex-store-vector)
+ (element-type :initform 'complex-type))
(:documentation "Tensor class with complex elements."))
(defclass complex-matrix (standard-matrix complex-tensor)
diff --git a/src/classes/real-tensor.lisp b/src/classes/real-tensor.lisp
index 6ece4df..77c850b 100644
--- a/src/classes/real-tensor.lisp
+++ b/src/classes/real-tensor.lisp
@@ -22,9 +22,8 @@ Allocates real storage. Default initial-element = 0d0.")
;;
(defclass real-tensor (standard-tensor)
- ((store
- :initform nil
- :type real-store-vector))
+ ((store :type real-store-vector)
+ (element-type :initform 'real-type))
(:documentation "Tensor class with real elements."))
(defclass real-matrix (standard-matrix real-tensor)
diff --git a/src/conditions.lisp b/src/conditions.lisp
index 0cbcb67..8a05062 100644
--- a/src/conditions.lisp
+++ b/src/conditions.lisp
@@ -18,12 +18,23 @@
,@rest)
,@(loop for mth in methods
collect `(defmethod ,@(cdr mth)))))))
+
+(defun slots-boundp (obj &rest slots)
+ (dolist (slot slots t)
+ (unless (slot-boundp obj slot)
+ (return nil))))
;;Generic conditions---------------------------------------------;;
(defcondition generic-error (error)
((message :reader message :initarg :message :initform ""))
(:method print-object ((c generic-error) stream)
(format stream (message c))))
+(defcondition dimension-mismatch (generic-error)
+ ()
+ (:method print-object ((c generic-error) stream)
+ (format stream "Dimension mismatch.")
+ (call-next-method)))
+
(defcondition assumption-violated (generic-error)
()
(:method print-object ((c assumption-violated) stream)
@@ -35,26 +46,33 @@
(expected-type :reader expected :initarg :expected))
(: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))
+ (when (slots-boundp c 'given-type 'expected-type)
+ (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."))
+ ((argument-number :reader argnum :initarg :argnum))
+ (:documentation "Given invalid arguments to the function.")
+ (:method print-object ((c invalid-arguments) stream)
+ (when (slot-boundp c 'argument-number)
+ (format stream "The ~a'th argument given to the function is invalid." (argnum c)))
+ (call-next-method)))
(defcondition invalid-value (generic-error)
((given-value :reader given :initarg :given)
(expected-value :reader expected :initarg :expected))
(:documentation "Given an unexpected value.")
(:method print-object ((c invalid-value) stream)
- (format stream "Given object ~A, expected ~A.~%" (given c) (expected c))
+ (when (slots-boundp c 'given-value 'expected-value)
+ (format stream "Given object ~A, expected ~A.~%" (given c) (expected c)))
(call-next-method)))
(defcondition unknown-token (generic-error)
((token :reader token :initarg :token))
(:documentation "Given an unknown token.")
(:method print-object ((c unknown-token) stream)
- (format stream "Given unknown token: ~A.~%" (token c))
+ (when (slot-boundp c 'token)
+ (format stream "Given unknown token: ~A.~%" (token c)))
(call-next-method)))
(defcondition parser-error (generic-error)
@@ -66,7 +84,8 @@
(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))
+ (when (slots-boundp c 'from 'to)
+ (format stream "Cannot coerce ~a into ~a.~%" (from c) (to c)))
(call-next-method)))
(defcondition out-of-bounds-error (generic-error)
@@ -74,7 +93,8 @@
(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))
+ (when (slots-boundp c 'requested 'bound)
+ (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)
@@ -82,7 +102,8 @@
(found :reader found :initarg :found))
(:documentation "Bounds are not uniform")
(: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))
+ (when (slots-boundp c 'assumed 'found)
+ (format stream "The bounds are not uniform, assumed bound : ~a, now found to be : ~a.~%" (assumed c) (found c)))
(call-next-method)))
;;Permutation conditions-----------------------------------------;;
@@ -100,10 +121,10 @@
((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)))))
+ (:report (lambda (c stream)
+ (format stream "Cannot permute sequence.")
+ (when (slots-boundp c 'sequence-length 'group-rank)
+ (format stream "~%sequence-length : ~a group-rank: ~a" (seq-len c) (group-rank c))))))
;;Tensor conditions----------------------------------------------;;
(define-condition tensor-error (error)
@@ -115,26 +136,30 @@ group-rank: ~a" (seq-len c) (group-rank c)))))
(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)))))
+ (when (slots-boundp c 'index 'store-size)
+ (format stream "Requested index ~A, but store is only of size ~A." (index c) (store-size c))))))
(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)))))
+ (when (slots-boundp c 'max-idx 'store-size)
+ (format stream "Store size is ~A, but maximum possible index is ~A." (store-size c) (max-idx c))))))
(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)))))
+ (when (slots-boundp c 'tensor-rank)
+ (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)))))
+ (when (slots-boundp c 'tensor-rank)
+ (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)
@@ -142,46 +167,53 @@ group-rank: ~a" (seq-len c) (group-rank c)))))
(argument-space-dimension :reader dimension :initarg :dimension))
(:documentation "An out of bounds index error")
(: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)))))
+ (when (slots-boundp c 'argument 'index 'argument-space-dimension)
+ (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 (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)))))
+ (when (slots-boundp c 'index-rank 'rank)
+ (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 (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)))))
+ (when (slots-boundp c 'head)
+ (format stream "Head of the store must be >= 0, initialized with ~A." (head c))))))
(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)))))
+ (when (slots-boundp c 'argument 'argument-dimension)
+ (format stream "Dimension of argument ~A must be > 0, initialized with ~A." (argument c) (dimension c))))))
(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)))))
+ (when (slots-boundp c 'argument 'argument-stride)
+ (format stream "Stride of argument ~A must be >= 0, initialized with ~A." (argument c) (stride c))))))
(define-condition tensor-cannot-find-counter-class (tensor-error)
((tensor-class :reader tensor-class :initarg :tensor-class))
(:documentation "Cannot find the counter-class list of the given tensor class")
(:report (lambda (c stream)
- (format stream "Cannot find the counter-class list of the given tensor class: ~a." (tensor-class c)))))
+ (when (slots-boundp c 'tensor-class)
+ (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))
(: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)))))
+ (when (slots-boundp c 'tensor-class)
+ (format stream "Cannot find optimization information for the given tensor class: ~a." (tensor-class c))))))
(define-condition tensor-dimension-mismatch (tensor-error)
()
diff --git a/src/ffi/c-ffi.lisp b/src/ffi/c-ffi.lisp
index 109a756..a7fd066 100644
--- a/src/ffi/c-ffi.lisp
+++ b/src/ffi/c-ffi.lisp
@@ -7,7 +7,7 @@
(real ,base-type)
(imag ,base-type)))
-(defccomplex %c.complex-double :double)R
+(defccomplex %c.complex-double :double)
(defccomplex %c.complex-float :float)
;; Get the equivalent CFFI type.
diff --git a/src/foreign-core/lapack.lisp b/src/foreign-core/lapack.lisp
index 9ce7a66..ad75f1b 100644
--- a/src/foreign-core/lapack.lisp
+++ b/src/foreign-core/lapack.lisp
@@ -1588,7 +1588,7 @@
(work (* :double-float) :workspace-output)
(lwork :integer :input)
(info :integer :output))
-
+
(def-fortran-routine dpotrf :void
"
SUBROUTINE DPOTRF( UPLO, N, A, LDA, INFO )
diff --git a/src/lapack/getrf.lisp b/src/lapack/getrf.lisp
index 0875520..d82ede5 100644
--- a/src/lapack/getrf.lisp
+++ b/src/lapack/getrf.lisp
@@ -33,43 +33,51 @@
(assert opt nil 'tensor-cannot-find-optimization :tensor-class matrix-class)
`(defun ,func-name (A ipiv)
(declare (type ,matrix-class A)
- (type permutation-action ipiv))
- (mlet*
- (((maj-A ld-A fop-A) (blas-matrix-compatible-p A :n) :type (symbol index-type nil)))
- (assert maj-A nil 'tensor-not-consecutive-store)
- (multiple-value-bind (new-a new-ipiv info)
+ (type permutation-pivot-flip ipiv))
+ (mlet* (((maj-A ld-A fop-A) (blas-matrix-compatible-p A :n) :type (symbol index-type nil)))
+ (assert maj-A nil 'tensor-store-not-consecutive)
+ (multiple-value-bind (new-A new-ipiv info)
(,lapack-func
(nrows A) (ncols A) (store A)
ld-A (repr ipiv) 0)
- (declare (ignore new-a new-ipiv))
+ (declare (ignore new-A new-ipiv))
;;Convert from 1-based indexing to 0-based indexing, and fix
;;other Fortran-ic quirks
- (assert (= info 0) nil 'invalid-arguments)
- (format t "~a~%" ipiv)
- (let-typed ((ipiv-repr (repr ipiv) :type perrepr-vector))
- (loop for i of-type fixnum from 0 below (length ipiv-repr)
- do (decf (aref ipiv-repr i)))
- (loop for i of-type fixnum from 0 below (length ipiv-repr)
- do (let ((val (aref ipiv-repr i)))
- (setf (aref ipiv-repr val) i))))
- (values A ipiv info))))))
+ (assert (= info 0) nil 'invalid-arguments :argnum (1- (- info)) :message (format-to-string "GETRF returned INFO: ~a." info))
+ (let-typed ((pidv (repr ipiv) :type perrepr-vector))
+ (very-quickly
+ (loop for i from 0 below (length pidv)
+ do (decf (aref pidv i)))))
+ (if (eq maj-A :row-major)
+ ;;Crout's decomposition
+ (values A (list :decomposition-type :|U_ii=1| :column-permutation ipiv))
+ ;;Dolittle's decomposition
+ (values A (list :decomposition-type :|L_ii=1| :row-permutation ipiv))))))))
(generate-typed-getrf! real-typed-getrf! (real-matrix dgetrf))
-
-
+(generate-typed-getrf! complex-typed-getrf! (complex-matrix zgetrf))
+
+#+nil
+(let ((A (make-real-tensor '((1 2)
+ (3 4))))
+ (idiv (make-pidx (perv 0 1))))
+ (real-typed-getrf! A idiv))
+
+
(defgeneric getrf! (A ipiv)
(:documentation
"
Syntax
======
- (GETRF a)
+ (GETRF! a)
Purpose
=======
Given an NxM matrix A, compute its LU factorization using
- partial pivoting, row interchanges:
+ partial pivoting, row or column interchanges:
- A = P * L * U
+ A = P * L * U (if A is row-major ordered)
+ A = L * U * P' (if A is col-major ordered)
where:
@@ -97,33 +105,50 @@
[3] INFO = T: successful
i: U(i,i) is exactly zero.
")
- (:method :before ((A standard-matrix) (ipiv permutation-action))
+ (:method :before ((A standard-matrix) (ipiv permutation-pivot-flip))
(assert (>= (group-rank ipiv) (idx-min (dimensions A))) nil 'invalid-value
:given (group-rank ipiv) :expected '(>= (group-rank ipiv) (idx-min (dimensions A))))))
-(defmethod getrf! ((a real-matrix) (ipiv permutation-action))
- (let* ((n (nrows a))
- (m (ncols a))
- (ipiv #+:pre-allocate-workspaces
- (or ipiv *ipiv*)
- #-:pre-allocate-workspaces
- (or ipiv (make-array (min n m) :element-type '(unsigned-byte 32)))))
-
- (declare (type fixnum n m))
- (multiple-value-bind (new-a new-ipiv info)
- (dgetrf n ;; M
- m ;; N
- (store a) ;; A
- n ;; LDA
- ipiv ;; IPIV
- 0) ;; INFO
- (declare (ignore new-a new-ipiv))
- (values a ipiv (if (zerop info)
- t
- info)))))
-
-
-
+(defmethod getrf! ((A real-matrix) (ipiv permutation-pivot-flip))
+ (let* ((copy? (not (consecutive-store-p A)))
+ (cp-A (if copy? (copy A) A))
+ (ret (multiple-value-list (real-typed-getrf! cp-A ipiv))))
+ (when copy?
+ (copy! (first ret) A)
+ (rplaca ret A))
+ (values-list ret)))
+
+(defmethod getrf! ((A complex-matrix) (ipiv permutation-pivot-flip))
+ (let* ((copy? (not (consecutive-store-p A)))
+ (cp-A (if copy? (copy A) A))
+ (ret (multiple-value-list (complex-typed-getrf! cp-A ipiv))))
+ (when copy?
+ (copy! (first ret) A)
+ (rplaca ret A))
+ (values-list ret)))
+
+(defun permute-idx (A arg perm)
+ (declare (type standard-matrix A)
+ (type permutation-pivot-flip perm))
+ (let* ((idiv (repr perm)))
+ (multiple-value-bind (tone ttwo) (let ((slst (make-list (rank A) :initial-element '\:)))
+ (rplaca (nthcdr arg slst) 0)
+ (values (sub-tensor~ A slst nil) (sub-tensor~ A slst nil)))
+ (let ((argstd (aref (strides A) arg)))
+ (loop for i from 0 below (length idiv)
+ do (progn
+ (unless (= i (aref idiv i))
+ (setf (head ttwo) (* (aref idiv i) argstd))
+ (swap! tone ttwo))
+ (incf (head tone) argstd))))))
+ A)
+
+(defun split-lu (A op-info)
+ (declare (type standard-matrix A))
+ (destructuring-bind (&key decomposition-type row-permutation col-permutation) op-info
+ (assert (member decomposition-type '(:|U_ii=1| :|L_ii=1|)) nil 'invalid-arguments :message "Bad decomposition-type")
+
+;;
(defgeneric lu (a &key with-l with-u with-p)
(:documentation
"
@@ -147,31 +172,7 @@
"))
-
-(defmethod getrf! ((a complex-matrix) &optional ipiv)
- (let* ((n (nrows a))
- (m (ncols a))
- (ipiv #+:pre-allocate-workspaces
- (or ipiv *ipiv*)
- #-:pre-allocate-workspaces
- (or ipiv (make-array (min n m) :element-type '(unsigned-byte 32)))))
-
- (declare (type fixnum n m))
- (multiple-value-bind (new-a new-ipiv info)
- (zgetrf n ;; M
- m ;; N
- (store a) ;; A
- n ;; LDA
- ipiv ;; IPIV
- 0) ;; INFO
- (declare (ignore new-a new-ipiv))
- (values a ipiv (if (zerop info)
- t
- info)))))
-
-
(defmethod lu ((a standard-matrix) &key (with-l t) (with-u t) (with-p t))
-
(multiple-value-bind (lu ipiv info)
(getrf! (copy a))
(declare (ignore info))
diff --git a/src/level-1/copy.lisp b/src/level-1/copy.lisp
index 8cdb3d0..24e087f 100644
--- a/src/level-1/copy.lisp
+++ b/src/level-1/copy.lisp
@@ -105,39 +105,24 @@
(generate-typed-num-copy! complex-typed-num-copy!
(complex-tensor zcopy *complex-l1-fcall-lb*))
;;---------------------------------------------------------------;;
+;;Generic function defined in src;base;generic-copy.lisp
-(defgeneric copy! (from-tensor to-tensor)
- (:documentation
- "
- Syntax
- ======
- (COPY! x y)
-
- Purpose
- =======
- Copies the contents of the tensor X to
- the tensor Y, returns Y.
-
- X,Y must have the same dimensions, and
- ergo the same number of elements.
-
- Furthermore, X may be a scalar, in which
- case Y is filled with X.
-
+(defmethod copy! :before ((x standard-tensor) (y standard-tensor))
+ "
The contents of X must be coercable to
the type of Y. For example,
a COMPLEX-MATRIX cannot be copied to a
- REAL-MATRIX but the converse is possible.
-")
- (:method :before ((x standard-tensor) (y standard-tensor))
- (unless (idx= (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)))
+ REAL-MATRIX but the converse is possible."
+ (assert (idx= (dimensions x) (dimensions y)) nil
+ 'tensor-dimension-mismatch))
+
+(defmethod copy! ((x standard-tensor) (y standard-tensor))
+ (mod-dotimes (idx (dimensions x))
+ do (setf (tensor-ref y idx) (tensor-ref x idx)))
+ y)
+
+(defmethod copy! ((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))
@@ -165,32 +150,7 @@
(defmethod copy! ((x number) (y complex-tensor))
(complex-typed-num-copy! (coerce-complex x) y))
-;;
-(defgeneric copy (tensor)
- (:documentation
- "
- Syntax
- ======
- (COPY x)
-
- Purpose
- =======
- Return a copy of the tensor X"))
-
-(defmethod copy ((tensor real-tensor))
- (let* ((ret (apply #'make-real-tensor (idx->list (dimensions tensor)))))
- (declare (type real-tensor ret))
- (copy! tensor ret)))
-
-(defmethod copy ((tensor complex-tensor))
- (let* ((ret (apply #'make-complex-tensor (idx->list (dimensions tensor)))))
- (declare (type complex-tensor ret))
- (copy! tensor ret)))
-
-(defmethod copy ((tensor number))
- tensor)
-
-;;
+;; Copy between a Lisp array and a tensor
(defun convert-to-lisp-array (tensor)
"
Syntax
@@ -208,7 +168,92 @@
: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-store-vector dims))
+ (let ((lst (make-list (rank tensor))))
+ (very-quickly
+ (mod-dotimes (idx dims)
+ do (setf (apply #'aref ret (idx->list! idx lst)) (tensor-ref tensor idx))))
+ ret)))
+
+(defmethod copy! :before ((x standard-tensor) (y array))
+ (assert (subtypep (element-type x)
+ (array-element-type y))
+ nil 'invalid-type
+ :given (element-type x)
+ :expected (array-element-type y))
+ (assert (and
+ (= (rank x) (array-rank y))
+ (reduce #'(lambda (x y) (and x y))
+ (mapcar #'= (idx->list (dimensions x)) (array-dimensions y))))
+ nil 'dimension-mismatch))
+
+(defmethod copy! ((x real-tensor) (y array))
+ (let-typed ((sto-x (store x) :type real-store-vector)
+ (lst (make-list (rank x)) :type cons))
+ (very-quickly
+ (mod-dotimes (idx (dimensions x))
+ with (linear-sums
+ (of-x (strides x) (head x)))
+ do (setf (apply #'aref y (idx->list! idx lst))
+ (aref sto-x of-x)))))
+ y)
+
+(defmethod copy! ((x complex-tensor) (y array))
+ (let-typed ((sto-x (store x) :type complex-store-vector)
+ (lst (make-list (rank x)) :type cons))
(very-quickly
- (mod-dotimes (idx dims)
- do (setf (apply #'aref ret (idx->list idx)) (tensor-ref tensor idx))))
- ret))
+ (mod-dotimes (idx (dimensions x))
+ with (linear-sums
+ |
|
From: Akshay S. <ak...@us...> - 2012-07-24 08:31:45
|
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 9a94775cd4eb5593fea88f5cf665bcadc198fb6f (commit)
from cd30ca81e687388cf532e30e08f79b68cf56c325 (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 9a94775cd4eb5593fea88f5cf665bcadc198fb6f
Author: Akshay Srinivasan <aks...@gm...>
Date: Tue Jul 24 13:56:44 2012 +0530
o Added (:h, :c) job handling ability to gemm!
diff --git a/src/base/blas-helpers.lisp b/src/base/blas-helpers.lisp
index 339f417..1e3fcb6 100644
--- a/src/base/blas-helpers.lisp
+++ b/src/base/blas-helpers.lisp
@@ -57,3 +57,12 @@
((string= sop "N") "T")
((string= sop "T") "N")
(t (error "Unrecognised fortran-op."))))
+
+(defun split-job (job)
+ (values-list
+ (map 'list #'(lambda (x) (intern (string x) "KEYWORD")) (symbol-name job))))
+
+(defun combine-jobs (&rest jobs)
+ (let ((job (intern (apply #'concatenate 'string (mapcar #'symbol-name jobs)) "KEYWORD")))
+ job))
+
diff --git a/src/level-1/trans.lisp b/src/level-1/trans.lisp
index 56bad3e..d5c0087 100644
--- a/src/level-1/trans.lisp
+++ b/src/level-1/trans.lisp
@@ -153,7 +153,7 @@
=======
Like mconjugate!, but non-destructive."
(etypecase A
- (standard-tensor (copy (mconjugate! A)))
+ (standard-tensor (mconjugate! (copy A)))
(number (conjugate A))))
;;
diff --git a/src/level-2/gemv.lisp b/src/level-2/gemv.lisp
index d4dfadd..78004a5 100644
--- a/src/level-2/gemv.lisp
+++ b/src/level-2/gemv.lisp
@@ -72,7 +72,9 @@
(defun complex-typed-gemv! (alpha A x beta y job)
(declare (type complex-matrix A)
- (type complex-vector x y))
+ (type complex-vector x y)
+ (type complex-type alpha beta)
+ (type symbol job))
(if (member job '(:n :t))
(complex-base-typed-gemv! alpha A x beta y job)
;;The CBLAS way.
@@ -83,8 +85,6 @@
;;---------------------------------------------------------------;;
-;;Can't support "C" because its dual (complex-conjugate without transpose)
-;;isn't supported by BLAS (which'd be needed for row-major matrices).
(defgeneric gemv! (alpha A x beta y &optional job)
(:documentation
"
diff --git a/src/level-3/gemm.lisp b/src/level-3/gemm.lisp
index f5172b7..325378c 100644
--- a/src/level-3/gemm.lisp
+++ b/src/level-3/gemm.lisp
@@ -152,31 +152,36 @@
finally ,(funcall (getf opt :value-writer) '(+ (* alpha sum) val) 'sto-C 'of-C)))))))))))
C)))
-;;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*))
+;;Real
+(generate-typed-gemm! real-base-typed-gemm!
+ (real-matrix dgemm dgemv *real-l3-fcall-lb*))
+
+(definline real-typed-gemm! (alpha A B beta C job)
+ (real-base-typed-gemv! alpha A B beta C
+ (apply #'combine-jobs
+ (mapcar #'(lambda (x)
+ (ecase x ((:n :t) x) (:h :t) (:c :n)))
+ (multiple-value-list (split-job job))))))
+
+;;Complex
+(generate-typed-gemm! complex-base-typed-gemm!
+ (complex-matrix zgemm zgemv *complex-l3-fcall-lb*))
+
+(defun complex-typed-gemm! (alpha A B beta C job)
+ (declare (type complex-matrix A B C)
+ (type complex-type alpha beta)
+ (type symbol job))
+ (multiple-value-bind (job-A job-B) (split-job job)
+ (if (and (member job-A '(:n :t))
+ (member job-B '(:n :t)))
+ (complex-base-typed-gemm! alpha A B beta C job)
+ (let ((A (ecase job-A ((:h :c) (mconjugate A)) ((:n :t) A)))
+ (B (ecase job-B ((:h :c) (mconjugate B)) ((:n :t) B)))
+ (tjob (combine-jobs (ecase job-A ((:n :t) job-A) (:h :t) (:c :n))
+ (ecase job-B ((:n :t) job-B) (:h :t) (:c :n)))))
+ (complex-base-typed-gemm! alpha A B
+ beta C tjob)))))
-;;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)
@@ -198,12 +203,20 @@
alpha,beta are scalars and A,B,C are matrices.
op(A) means either A or A'.
+ JOB must be a keyword with two of these alphabets
+ N Identity
+ T Transpose
+ C Complex conjugate
+ H Hermitian transpose {conjugate transpose}
+
+ so that (there are 4x4 operations in total).
+
JOB Operation
---------------------------------------------------
: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
+ :TN alpha * transpose(A) * B + beta * C
+ :NH alpha * A * transpose o conjugate(B) + beta * C
+ :HC alpha * transpose o conjugate(A) * conjugate(B) + beta * C
")
(:method :before ((alpha number) (A standard-matrix) (B standard-matrix)
(beta number) (C standard-matrix)
@@ -215,12 +228,10 @@
(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 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)))))
+ (let ((sjobs (multiple-value-list (split-job job))))
+ (assert (= (length sjobs) 2) nil 'invalid-arguments :message "Ill formed job")
+ (ecase (first sjobs) ((:n :c) t) ((:t :h) (rotatef nr-a nc-a)))
+ (ecase (second sjobs) ((:n :c) t) ((:t :h) (rotatef nr-b nc-b))))
(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)
@@ -295,12 +306,20 @@
alpha,beta are scalars and A,B,C are matrices.
op(A) means either A or A'.
+ JOB must be a keyword with two of these alphabets
+ N Identity
+ T Transpose
+ C Complex conjugate
+ H Hermitian transpose {conjugate transpose}
+
+ so that (there are 4x4 operations in total).
+
JOB Operation
---------------------------------------------------
: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
+ :TN alpha * transpose(A) * B + beta * C
+ :NH alpha * A * transpose o conjugate(B) + beta * C
+ :HC alpha * transpose o conjugate(A) * conjugate(B) + beta * C
"))
(defmethod gemm ((alpha number) (a standard-matrix) (b standard-matrix)
@@ -324,16 +343,12 @@
(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)))
+ (multiple-value-bind (job-A job-B) (split-job job)
(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))))))
+ (list (if (member job-A '(:n :c)) (nrows A) (ncols A))
+ (if (member job-B '(:n :c)) (ncols B) (nrows B))))))
(gemm! alpha A B 0 result job))))
-----------------------------------------------------------------------
Summary of changes:
src/base/blas-helpers.lisp | 9 ++++
src/level-1/trans.lisp | 2 +-
src/level-2/gemv.lisp | 6 +-
src/level-3/gemm.lisp | 101 +++++++++++++++++++++++++-------------------
4 files changed, 71 insertions(+), 47 deletions(-)
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2012-07-24 05:48: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 cd30ca81e687388cf532e30e08f79b68cf56c325 (commit)
from 3d2b1c49901f857eff0b30ebecaeb251d35e1755 (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 cd30ca81e687388cf532e30e08f79b68cf56c325
Author: Akshay Srinivasan <aks...@gm...>
Date: Tue Jul 24 11:13:16 2012 +0530
o Added (:c, :h) to gemv!
o Moved all the BLAS tweakable parameters to a file
diff --git a/matlisp.asd b/matlisp.asd
index be38acc..fefa76d 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -100,7 +100,9 @@
(:file "blas-helpers"
:depends-on ("standard-tensor" "permutation"))
(:file "print"
- :depends-on ("standard-tensor"))))
+ :depends-on ("standard-tensor"))
+ ;;Probably not the right place, but should do.
+ (:file "tweakable")))
(:module "matlisp-classes"
:pathname "classes"
:depends-on ("matlisp-base")
@@ -122,7 +124,9 @@
(:file "dot"
:depends-on ("realimag"))
(:file "axpy"
- :depends-on ("copy" "scal"))))
+ :depends-on ("copy" "scal"))
+ (:file "trans"
+ :depends-on ("scal" "copy"))))
(:module "matlisp-level-2"
:pathname "level-2"
:depends-on ("matlisp-base" "matlisp-classes" "foreign-core" "matlisp-level-1")
diff --git a/packages.lisp b/packages.lisp
index b295a79..ca65b2c 100644
--- a/packages.lisp
+++ b/packages.lisp
@@ -33,6 +33,7 @@
;;<conditon {accessors*}>
;;Generic errors
#:generic-error #:message
+ #:assumption-violated
#:invalid-type #:given #:expected
#:invalid-arguments
#:invalid-value #:given #:expected
diff --git a/src/classes/complex-tensor.lisp b/src/classes/complex-tensor.lisp
index ee4dd08..9692b49 100644
--- a/src/classes/complex-tensor.lisp
+++ b/src/classes/complex-tensor.lisp
@@ -23,12 +23,20 @@
(make-array (* 2 size) :element-type 'complex-base-type
:initial-element (coerce 0 'complex-base-type)))
-(definline coerce-complex (x)
+(definline coerce-complex-unforgiving (x)
(coerce x 'complex-type))
-(definline coerce-complex-base (x)
+(defun coerce-complex (x)
+ (restart-case (coerce-complex-unforgiving x)
+ (use-value (value) (coerce-complex value))))
+
+(definline coerce-complex-base-unforgiving (x)
(coerce x 'complex-base-type))
+(defun coerce-complex-base (x)
+ (restart-case (coerce-complex-base-unforgiving x)
+ (use-value (value) (coerce-complex-base value))))
+
;;
(defclass complex-tensor (standard-tensor)
((store
@@ -62,7 +70,7 @@ Cannot hold complex numbers."))
(tensor-store-defs (complex-tensor complex-type complex-base-type)
:store-allocator allocate-complex-store
- :coercer coerce-complex
+ :coercer coerce-complex-unforgiving
:reader
(lambda (tstore idx)
(complex (aref tstore (* 2 idx))
diff --git a/src/classes/real-tensor.lisp b/src/classes/real-tensor.lisp
index 7d360a6..6ece4df 100644
--- a/src/classes/real-tensor.lisp
+++ b/src/classes/real-tensor.lisp
@@ -13,9 +13,13 @@
"(allocate-real-store size [initial-element])
Allocates real storage. Default initial-element = 0d0.")
-(definline coerce-real (x)
+(definline coerce-real-unforgiving (x)
(coerce x 'real-type))
+(defun coerce-real (x)
+ (restart-case (coerce-real-unforgiving x)
+ (use-value (value) (coerce-real value))))
+
;;
(defclass real-tensor (standard-tensor)
((store
@@ -43,7 +47,7 @@ Allocates real storage. Default initial-element = 0d0.")
;;
(tensor-store-defs (real-tensor real-type real-type)
:store-allocator allocate-real-store
- :coercer coerce-real
+ :coercer coerce-real-unforgiving
:reader
(lambda (tstore idx)
(aref tstore idx))
@@ -68,5 +72,3 @@ Allocates real storage. Default initial-element = 0d0.")
(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 b384847..0cbcb67 100644
--- a/src/conditions.lisp
+++ b/src/conditions.lisp
@@ -24,6 +24,12 @@
(:method print-object ((c generic-error) stream)
(format stream (message c))))
+(defcondition assumption-violated (generic-error)
+ ()
+ (:method print-object ((c assumption-violated) stream)
+ (format stream "An assumption assumed when writing the software has been violated. Proceed with caution.")
+ (call-next-method)))
+
(defcondition invalid-type (generic-error)
((given-type :reader given :initarg :given)
(expected-type :reader expected :initarg :expected))
diff --git a/src/ffi/c-ffi.lisp b/src/ffi/c-ffi.lisp
index 7a6fba9..109a756 100644
--- a/src/ffi/c-ffi.lisp
+++ b/src/ffi/c-ffi.lisp
@@ -7,37 +7,47 @@
(real ,base-type)
(imag ,base-type)))
-(defccomplex c-complex-double :double)
-(defccomplex c-complex-float :float)
+(defccomplex %c.complex-double :double)R
+(defccomplex %c.complex-float :float)
;; Get the equivalent CFFI type.
;; If the type is an array, get the type of the array element type.
-(defun c->cffi-type (type)
+(defun %c.cffi-type (type)
"Convert the given Fortran FFI type into a type understood by CFFI."
(cond
- ((and (listp type) (eq (first type) '*))
- `(:pointer ,(c->cffi-type
- (case (second type)
- ;;CDR coding ?
- (:complex-single-float :single-float)
- (:complex-double-float :double-float)
- (t (second type))))))
+ ;; '* means arrays of a type, which isn't necessarily the same as pointer-to-type
+ ;; (* :complex-single-float) expands to (:pointer :float)
+ ;; (:pointer :complex-single-float) expands to (:pointer (:struct %c.complex-float))
+ ((consp type)
+ (cond
+ ((eq (first type) '*)
+ `(:pointer ,(%c.cffi-type
+ (case (second type)
+ ;;CDR coding ?
+ (:complex-single-float :single-float)
+ (:complex-double-float :double-float)
+ (t (second type))))))
+ ;;We assume you what you're doing, and
+ ;;CFFI knows the type.
+ ((eq (first type) :pointer)
+ type)
((callback-type-p type)
- `(:pointer ,(c->cffi-type :callback)))
+ `(:pointer ,(%c.cffi-type :callback)))
((eq type :complex-single-float)
- `(:struct c-complex-float))
+ `(:struct %c.complex-float))
((eq type :complex-double-float)
- `(:struct c-complex-double))
+ `(:struct %c.complex-double))
(t (case type
(:void :void)
(:integer :int)
(:long :long)
- (:single-float 'c-complex-float)
- (:double-float 'c-complex-double)
+ (:single-float :float)
+ (:double-float :double)
(:string :string)
+ (:character :char)
;; Pass a pointer to the function.
(:callback :void)
- ;;We assume the type is known to CFFI.
+ ;;We assume that the type is known to CFFI.
(t type)))))
;; Check if given type is a string
diff --git a/src/ffi/f77-ffi.lisp b/src/ffi/f77-ffi.lisp
index d68b04b..602eba0 100644
--- a/src/ffi/f77-ffi.lisp
+++ b/src/ffi/f77-ffi.lisp
@@ -50,9 +50,9 @@
`(:pointer ,(%f77.cffi-type :double-float)))
(t (ecase type
(:void :void)
- (:integer :int)
+ (:integer :int32)
(:character :char)
- (:long :long)
+ (:long :int64)
(:single-float :float)
(:double-float :double)
(:string :string)
diff --git a/src/ffi/ffi-cffi.lisp b/src/ffi/ffi-cffi.lisp
index 9597bc2..8429984 100644
--- a/src/ffi/ffi-cffi.lisp
+++ b/src/ffi/ffi-cffi.lisp
@@ -22,6 +22,10 @@
:string :character
:callback))
+(define-constant +ffi-array-types+
+ '(:single-float :double-float
+ :integer :long))
+
;; Separte the body of code into documentation and parameter lists.
(defun parse-doc-&-parameters (body &optional header footer)
(if (stringp (first body))
@@ -144,13 +148,9 @@
;;
(simple-array (signed-byte 64) *)
(simple-array (signed-byte 32) *)
- (simple-array (signed-byte 16) *)
- (simple-array (signed-byte 8) *)
;;
(simple-array (unsigned-byte 64) *)
(simple-array (unsigned-byte 32) *)
- (simple-array (unsigned-byte 16) *)
- (simple-array (unsigned-byte 8) *)
;;
cffi:foreign-pointer))
diff --git a/src/level-1/axpy.lisp b/src/level-1/axpy.lisp
index e789d7a..ce870da 100644
--- a/src/level-1/axpy.lisp
+++ b/src/level-1/axpy.lisp
@@ -99,26 +99,19 @@
,(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*))
+;;Real
+(generate-typed-axpy! real-typed-axpy!
+ (real-tensor daxpy *real-l1-fcall-lb*))
+
+(generate-typed-num-axpy! real-typed-num-axpy!
+ (real-tensor daxpy *real-l1-fcall-lb*))
+
+;;Complex
+(generate-typed-axpy! complex-typed-axpy!
+ (complex-tensor zaxpy *complex-l1-fcall-lb*))
+
+(generate-typed-num-axpy! complex-typed-num-axpy!
+ (complex-tensor zaxpy *complex-l1-fcall-lb*))
;;---------------------------------------------------------------;;
(defgeneric axpy! (alpha x y)
diff --git a/src/level-1/copy.lisp b/src/level-1/copy.lisp
index ba062de..8cdb3d0 100644
--- a/src/level-1/copy.lisp
+++ b/src/level-1/copy.lisp
@@ -91,40 +91,20 @@
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 above 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*))
-;;---------------------------------------------------------------;;
+;;Real
+(generate-typed-copy! real-typed-copy!
+ (real-tensor dcopy *real-l1-fcall-lb*))
+
+(generate-typed-num-copy! real-typed-num-copy!
+ (real-tensor dcopy *real-l1-fcall-lb*))
-(defun test-copy (n r)
- (let ((x (make-real-tensor n)))
- (time (dotimes (i r)
- (copy! pi x)))
- t))
+;;Complex
+(generate-typed-copy! complex-typed-copy!
+ (complex-tensor zcopy *complex-l1-fcall-lb*))
+
+(generate-typed-num-copy! complex-typed-num-copy!
+ (complex-tensor zcopy *complex-l1-fcall-lb*))
+;;---------------------------------------------------------------;;
(defgeneric copy! (from-tensor to-tensor)
(:documentation
diff --git a/src/level-1/dot.lisp b/src/level-1/dot.lisp
index 60ad32a..15bf751 100644
--- a/src/level-1/dot.lisp
+++ b/src/level-1/dot.lisp
@@ -27,16 +27,11 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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*)))
+ *real-l1-fcall-lb*)))
(cond
(call-fortran?
(ddot (number-of-elements x)
@@ -57,16 +52,10 @@
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*)))
+ *complex-l1-fcall-lb*)))
(cond
(call-fortran?
(if conjugate-p
diff --git a/src/level-1/scal.lisp b/src/level-1/scal.lisp
index c7604b1..5bdb664 100644
--- a/src/level-1/scal.lisp
+++ b/src/level-1/scal.lisp
@@ -50,21 +50,18 @@
,(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.
-(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*))
+;;Real
+(generate-typed-scal! real-typed-scal!
+ (real-tensor dscal *real-l1-fcall-lb*))
+
+;;Complex
+(definline zordscal (nele alpha x incx &optional hd-x)
+ (if (zerop (imagpart alpha))
+ (zdscal nele (realpart alpha) x incx hd-x)
+ (zscal nele alpha x incx hd-x)))
+
+(generate-typed-scal! complex-typed-scal!
+ (complex-tensor zordscal *complex-l1-fcall-lb*))
;;---------------------------------------------------------------;;
(defgeneric scal! (alpha x)
diff --git a/src/level-1/swap.lisp b/src/level-1/swap.lisp
index 7f80c78..7204214 100644
--- a/src/level-1/swap.lisp
+++ b/src/level-1/swap.lisp
@@ -53,19 +53,11 @@
do ,(funcall (getf opt :swapper) 'f-sto 'f-of 't-sto 't-of)))))))
y)))
-(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*))
+(generate-typed-swap! real-typed-swap!
+ (real-tensor dswap *real-l1-fcall-lb*))
-(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*))
+(generate-typed-swap! complex-typed-swap!
+ (complex-tensor zswap *complex-l1-fcall-lb*))
;;---------------------------------------------------------------;;
(defgeneric swap! (x y)
diff --git a/src/level-1/trans.lisp b/src/level-1/trans.lisp
new file mode 100644
index 0000000..56bad3e
--- /dev/null
+++ b/src/level-1/trans.lisp
@@ -0,0 +1,210 @@
+;;; -*- 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.
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(in-package #:matlisp)
+
+(defun transpose! (A &optional permutation)
+ "
+ Syntax
+ ======
+ (TRANSPOSE! a [permutation])
+
+ Purpose
+ =======
+ Exchange the arguments of the tensor in place. The default
+ is to swap the first and last arguments of the tensor.
+
+ Settable
+ ========
+ (setf (TRANSPOSE! tensor permutation) value)
+
+ is basically the same as
+ (copy! value (TRANSPOSE! tensor permutation)).
+
+ NOTE: This will have side-effects even if copy! doesn't succeed."
+ (declare (type standard-tensor a))
+ (if permutation
+ (progn
+ (permute! (strides A) permutation)
+ (permute! (dimensions A) permutation))
+ (let-typed ((rnk (rank A) :type index-type)
+ (dim-A (dimensions A) :type index-store-vector)
+ (strd-A (strides A) :type index-store-vector))
+ (rotatef (aref dim-A (1- rnk)) (aref dim-A 0))
+ (rotatef (aref strd-A (1- rnk)) (aref strd-A 0))))
+ A)
+
+(defun (setf transpose!) (value A &optional permutation)
+ (copy! value (transpose! A permutation)))
+
+(defun transpose~ (A &optional permutation)
+ "
+ Syntax
+ ======
+ (TRANSPOSE~ a permutation)
+
+ Purpose
+ =======
+ Like TRANSPOSE!, but the permuted strides and dimensions are part of
+ a new tensor object instead, the store being shared with the given
+ tensor.
+
+ Settable
+ ========
+ (setf (TRANSPOSE~ tensor permutation) value)
+
+ is basically the same as
+ (copy! value (TRANSPOSE~ tensor permutation))"
+ (declare (type standard-tensor A))
+ (let ((displaced (make-instance (class-of A) :store (store A)
+ :dimensions (copy-seq (dimensions A))
+ :strides (copy-seq (strides A))
+ :parent-tensor A)))
+ (transpose! displaced permutation)))
+
+(defun (setf transpose~) (value A &optional permutation)
+ (declare (type standard-tensor A))
+ (copy! value (transpose~ A permutation)))
+
+(definline transpose (A &optional permutation)
+ "
+ Syntax
+ ======
+ (TRANSPOSE~ a permutation)
+
+ Purpose
+ =======
+ Like TRANSPOSE!, but the permutation is applied on a copy of
+ the given tensor.
+
+ Settable
+ ========
+ (setf (TRANSPOSE tensor permutation) value)
+
+ is the same as (setf (transpose~ ..) ..)"
+ (declare (type standard-tensor A))
+ (copy (transpose~ A permutation)))
+
+(defun (setf transpose) (value A &optional permutation)
+ (declare (type standard-tensor A))
+ (copy! value (transpose~ A permutation)))
+
+;;This is a bit more complicated, now that we are no longer in S_2
+;;Computing the inverse permutation is trivial in the cyclic representation,
+;;but probably not worth the trouble for this ugly macro.
+#+nil
+(defmacro with-transpose! (matlst &rest body)
+ `(progn
+ ,@(mapcar #'(lambda (mat) `(transpose! ,mat)) matlst)
+ ,@body
+ ,@(mapcar #'(lambda (mat) `(transpose! ,mat)) matlst)))
+
+
+;;
+(defun mconjugate! (A)
+ "
+ Syntax
+ ======
+ (mconjugate! A)
+
+ Purpose
+ =======
+ Destructively modifies A into its complex conjugate (not hermitian conjugate).
+
+ (tensor-imagpart~ A) <- (- (tensor-imagpart~ A)) "
+ (etypecase A
+ (real-tensor A)
+ (complex-tensor
+ (scal! -1 (tensor-imagpart~ A))
+ A)
+ (number (conjugate A))))
+
+(definline mconjugate (A)
+ "
+ Syntax
+ ======
+ (mconjugate A)
+
+ Purpose
+ =======
+ Like mconjugate!, but non-destructive."
+ (etypecase A
+ (standard-tensor (copy (mconjugate! A)))
+ (number (conjugate A))))
+
+;;
+(defun htranspose! (A &optional permutation)
+"
+ Syntax
+ ======
+ (HTRANSPOSE! A [permutation])
+
+ Purpose
+ =======
+ Hermitian transpose of A (destructive).
+"
+ (declare (type standard-tensor A))
+ (transpose! A permutation)
+ (when (typep A 'complex-tensor)
+ (mconjugate! A))
+ A)
+
+(definline ctranspose! (A &optional permutation)
+ "
+ Syntax
+ ======
+ (CTRANSPOSE! A [permutation])
+
+ Purpose
+ =======
+ Conjugate transpose of A (destructive).
+"
+ (htranspose! A permutation))
+
+(definline htranspose (A &optional permutation)
+"
+ Syntax
+ ======
+ (HTRANSPOSE A [permutation])
+
+ Purpose
+ =======
+ Like HTRANSPOSE!, but non-destructive."
+ (declare (type standard-tensor A))
+ (let ((result (copy A)))
+ (htranspose! result permutation)))
+
+(definline ctranspose (A &optional permutation)
+ "
+ Syntax
+ ======
+ (CTRANSPOSE A [permutation])
+
+ Purpose
+ =======
+ Like CTRANSPOSE!, but non-destructive."
+ (htranspose A permutation))
diff --git a/src/level-2/gemv.lisp b/src/level-2/gemv.lisp
index 7fffe5e..d4dfadd 100644
--- a/src/level-2/gemv.lisp
+++ b/src/level-2/gemv.lisp
@@ -59,34 +59,32 @@
`(+ (* 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
- *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
- *complex-gemv-fortran-call-lower-bound*))
+;;Real
+(generate-typed-gemv! real-base-typed-gemv!
+ (real-matrix real-vector dgemv *real-l2-fcall-lb*))
+
+(definline real-typed-gemv! (alpha A x beta y job)
+ (real-base-typed-gemv! alpha A x beta y (ecase job ((:n :t) job) (:h :t) (:c :n))))
+
+;;Complex
+(generate-typed-gemv! complex-base-typed-gemv!
+ (complex-matrix complex-vector zgemv *complex-l2-fcall-lb*))
+
+(defun complex-typed-gemv! (alpha A x beta y job)
+ (declare (type complex-matrix A)
+ (type complex-vector x y))
+ (if (member job '(:n :t))
+ (complex-base-typed-gemv! alpha A x beta y job)
+ ;;The CBLAS way.
+ (let ((cx (mconjugate x)))
+ (complex-base-typed-gemv! (cl:conjugate alpha) A cx
+ (cl:conjugate beta) (mconjugate! y) (ecase job (:h :t) (:c :n)))
+ (mconjugate! y))))
+
;;---------------------------------------------------------------;;
-;;Can't support "C" because the dual isn't supported by BLAS.
+;;Can't support "C" because its dual (complex-conjugate without transpose)
+;;isn't supported by BLAS (which'd be needed for row-major matrices).
(defgeneric gemv! (alpha A x beta y &optional job)
(:documentation
"
@@ -111,13 +109,15 @@
JOB Operation
---------------------------------------------------
:N (default) alpha * A * x + beta * y
- :T alpha * A'* x + beta * y
+ :T alpha * transpose(A)* x + beta * y
+ :C alpha * conjugate(A) * x + beta * y
+ :H alpha * transpose o conjugate(A) + beta * y
")
(: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))
+ (assert (member job '(:n :t :c :h)) nil 'invalid-value
+ :given job :expected `(member job '(:n :t :c :h))
:message "Inside gemv!")
(assert (not (eq x y)) nil 'invalid-arguments
:message "GEMV!: x and y cannot be the same vector")
@@ -143,7 +143,7 @@
(unless (= beta 1)
(complex-typed-scal! (coerce-complex beta) y))
(unless (= alpha 0)
- (if (complexp alpha)
+ (if (not (zerop (imagpart 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)
@@ -204,6 +204,8 @@
---------------------------------------------------
:N (default) alpha * A * x + beta * y
:T alpha * A'* x + beta * y
+ :C alpha * conjugate(A) * x + beta * y
+ :H alpha * transpose o conjugate(A) + beta * y
"))
(defmethod gemv ((alpha number) (A standard-matrix) (x standard-vector)
@@ -227,5 +229,5 @@
(typep A 'complex-matrix) (typep x 'complex-vector))
#'make-complex-tensor
#'make-real-tensor)
- (list (ecase job (:n (nrows A)) (:t (ncols A)))))))
+ (list (ecase job ((:n :c) (nrows A)) ((:t :h) (ncols A)))))))
(gemv! alpha A x 0 result job)))
diff --git a/src/old/trans.lisp b/src/old/trans.lisp
deleted file mode 100644
index f20b2de..0000000
--- a/src/old/trans.lisp
+++ /dev/null
@@ -1,208 +0,0 @@
-;;; -*- 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: trans.lisp,v 1.6 2011/01/25 18:36:56 rtoy Exp $
-;;;
-;;; $Log: trans.lisp,v $
-;;; Revision 1.6 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.5.2.1 2011/01/25 18:16:53 rtoy
-;;; Use cl:real instead of real.
-;;;
-;;; Revision 1.5 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.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.
-;;;
-;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; notes
-;; =====
-;; transposition is usually a redundant operation. For example, all BLAS/LAPACK
-;; operators take an extra argument asking whether the matrix is transposed,
-;; for small operations transposition doesn't make a difference, for repeated
-;; small operations -- it may, so you need to use this feature of the
-;; interfaced BLAS/LAPACK functions.
-;;
-;; also, the intent that TRANSPOSE creates a new matrix should be made clear,
-;; for example, taking the transpose of a row/column vector is easy, due to
-;; representation, but this will not create a new matrix.
-
-(in-package #:matlisp)
-
-(defun transpose! (matrix)
-"
- Syntax
- ======
- (TRANSPOSE! matrix)
-
- Purpose
- =======
- Exchange row and column strides so that effectively
- the matrix is destructively transposed in place
- (without much effort).
-"
- (typecase matrix
- (standard-matrix
- (progn
- (rotatef (nrows matrix) (ncols matrix))
- (rotatef (row-stride matrix) (col-stride matrix))
- matrix))
- (number matrix)
- (t (error "Don't know how to take the transpose of ~A." matrix))))
-
-(defmacro with-transpose! (matlst &rest body)
- `(progn
- ,@(mapcar #'(lambda (mat) `(transpose! ,mat)) matlst)
- ,@body
- ,@(mapcar #'(lambda (mat) `(transpose! ,mat)) matlst)))
-
-;;
-(defgeneric transpose~ (matrix)
- (:documentation
-"
- Syntax
- ======
- (TRANSPOSE~ matrix)
-
- Purpose
- =======
- Create a new matrix object which represents the transpose of the
- the given matrix.
-
- Store is shared with \"matrix\".
-
- Settable
- ========
- (setf (TRANSPOSE~ matrix) value)
-
- is basically the same as
-
- (copy! value (TRANSPOSE~ matrix))
-"))
-
-(defun (setf transpose~) (value matrix)
- (copy! value (transpose~ matrix)))
-
-;;
-(defmethod transpose~ ((matrix number))
- matrix)
-
-(defmethod transpose~ ((matrix real-matrix))
- (mlet* (((hd nr nc rs cs st) (slot-values matrix '(head number-of-rows number-of-cols row-stride col-stride store))
- :type (fixnum fixnum fixnum fixnum fixnum (real-matrix-store-type *))))
- (make-instance 'sub-real-matrix
- :nrows nc :ncols nr
- :store st
- :head hd
- :row-stride cs :col-stride rs
- :parent matrix)))
-
-(defmethod transpose~ ((matrix complex-matrix))
- (mlet* (((hd nr nc rs cs st) (slot-values matrix '(head number-of-rows number-of-cols row-stride col-stride store))
- :type (fixnum fixnum fixnum fixnum fixnum (complex-matrix-store-type *))))
- (make-instance 'sub-complex-matrix
- :nrows nc :ncols nr
- :store st
- :head hd
- :row-stride cs :col-stride rs
- :parent matrix)))
-
-;;
-(declaim (inline transpose))
-(defun transpose (matrix)
-"
- Syntax
- ======
- (TRANSPOSE matrix)
-
- Purpose
- =======
- Creates a new matrix which is the transpose of MATRIX.
-"
- (copy (transpose~ matrix)))
-
-;;
-(defun ctranspose! (matrix)
-"
- Syntax
- ======
- (CTRANSPOSE! matrix)
-
- Purpose
- =======
- Exchange row and column strides so that effectively
- the matrix is destructively transposed in place
- (without much effort). Also scale the imagpart with -1,
- so that the end result is the Hermitian conjugate.
-"
- (transpose! matrix)
- (when (typep matrix 'complex-matrix)
- (scal! -1d0 (mimagpart~ matrix)))
- matrix)
-
-;;
-(defun ctranspose (matrix)
-"
- Syntax
- ======
- (CTRANSPOSE matrix)
-
- Purpose
- =======
- Returns a new matrix which is the conjugate transpose
- of MATRIX.
-"
- (let ((result (copy matrix)))
- (ctranspose! result)))
\ No newline at end of file
-----------------------------------------------------------------------
Summary of changes:
matlisp.asd | 8 +-
packages.lisp | 1 +
src/classes/complex-tensor.lisp | 14 ++-
src/classes/real-tensor.lisp | 10 +-
src/conditions.lisp | 6 +
src/ffi/c-ffi.lisp | 42 +++++---
src/ffi/f77-ffi.lisp | 4 +-
src/ffi/ffi-cffi.lisp | 8 +-
src/level-1/axpy.lisp | 33 +++----
src/level-1/copy.lisp | 44 +++------
src/level-1/dot.lisp | 15 +---
src/level-1/scal.lisp | 25 ++---
src/level-1/swap.lisp | 16 +---
src/level-1/trans.lisp | 210 +++++++++++++++++++++++++++++++++++++++
src/level-2/gemv.lisp | 64 ++++++------
src/old/trans.lisp | 208 --------------------------------------
16 files changed, 347 insertions(+), 361 deletions(-)
create mode 100644 src/level-1/trans.lisp
delete mode 100644 src/old/trans.lisp
hooks/post-receive
--
matlisp
|
|
From: Akshay S. <ak...@us...> - 2012-07-22 17:03:49
|
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 3d2b1c49901f857eff0b30ebecaeb251d35e1755 (commit)
via aa67585771f77454b95fa7b16767ef3a6ff03923 (commit)
via 00e53dd09b3cc988dcd4e6e82934ff78bcb83501 (commit)
via 1ab6cec8e17077b9533560c9a5bc010e95818a04 (commit)
via b6be337cd4bfc4e869cc13317e36244517fb95a8 (commit)
via 4022a66033df8820d07bb2abd81b9a355274bd71 (commit)
via 77cde81e39386e147ac35c488d1f7c581d7bd9b8 (commit)
via c73c3a034c2a655afb2edd38ed6f0dcef6050b3d (commit)
via c2b5936d4d517cf0a7ee3e8d4a5d9b683249076c (commit)
from d18665bf3b836e17d2ff75065b384b5ff07059e3 (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 3d2b1c49901f857eff0b30ebecaeb251d35e1755
Author: Akshay Srinivasan <aks...@gm...>
Date: Sun Jul 22 22:28:13 2012 +0530
o Renamed non-exported functions in f77-ffi.lisp to avoid name clobbering (working on the C-FFI, see).
o Added some documentation to some exotic macros in utilities.lisp
diff --git a/matlisp.asd b/matlisp.asd
index 9c6076b..be38acc 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -77,7 +77,7 @@
:components ((:file "ffi-cffi")
(:file "ffi-cffi-implementation-specific")
(:file "foreign-vector")
- (:file "fortran-ffi"
+ (:file "f77-ffi"
:depends-on ("ffi-cffi"
"ffi-cffi-implementation-specific"
"foreign-vector"))
diff --git a/packages.lisp b/packages.lisp
index 8767417..b295a79 100644
--- a/packages.lisp
+++ b/packages.lisp
@@ -77,7 +77,7 @@
#:when-let #:if-let #:if-ret #:with-gensyms #:let-rec
#:mlet* #:make-array-allocator #:let-typed
#:nconsc #:define-constant
- #:macrofy
+ #:macrofy #:looped-mapcar
;;
#:inlining #:definline
#:with-optimization #:quickly #:very-quickly #:slowly #:quickly-if))
diff --git a/src/ffi/f77-ffi.lisp b/src/ffi/c-ffi.lisp
similarity index 95%
copy from src/ffi/f77-ffi.lisp
copy to src/ffi/c-ffi.lisp
index 9c5491f..7a6fba9 100644
--- a/src/ffi/f77-ffi.lisp
+++ b/src/ffi/c-ffi.lisp
@@ -1,46 +1,44 @@
;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Package: :fortran-ffi-accessors; Base: 10 -*-
-;; Allowed types:
-;; :single-float :double-float
-;; :complex-single-float :complex-double-float
-;; :integer :long
-
-;; Callbacks : (:function <output-type> {(params)})
-
-;;TODO add declarations to generated wrappers.
(in-package #:matlisp-ffi)
-;: Don't blame us, a lot of useful code
-;; is written in that stilted language.
-(define-constant +f77-types+
- '(:single-float :double-float
- :complex-single-float :complex-double-float
- :integer :long
- :string
- :callback))
+(defmacro defccomplex (name base-type)
+ `(cffi:defcstruct ,name
+ (real ,base-type)
+ (imag ,base-type)))
+
+(defccomplex c-complex-double :double)
+(defccomplex c-complex-float :float)
;; Get the equivalent CFFI type.
;; If the type is an array, get the type of the array element type.
-(defun f77->cffi-type (type)
+(defun c->cffi-type (type)
"Convert the given Fortran FFI type into a type understood by CFFI."
(cond
((and (listp type) (eq (first type) '*))
- `(:pointer ,@(f77->cffi-type (second type))))
+ `(:pointer ,(c->cffi-type
+ (case (second type)
+ ;;CDR coding ?
+ (:complex-single-float :single-float)
+ (:complex-double-float :double-float)
+ (t (second type))))))
((callback-type-p type)
- `(:pointer ,@(f77->cffi-type :callback)))
+ `(:pointer ,(c->cffi-type :callback)))
((eq type :complex-single-float)
- `(:pointer ,@(f77->cffi-type :single-float)))
+ `(:struct c-complex-float))
((eq type :complex-double-float)
- `(:pointer ,@(f77->cffi-type :double-float)))
- (t `(,(ecase type
- (:void :void)
- (:integer :int)
- (:long :long)
- (:single-float :float)
- (:double-float :double)
- (:string :string)
- ;; Pass a pointer to the function.
- (:callback :void))))))
+ `(:struct c-complex-double))
+ (t (case type
+ (:void :void)
+ (:integer :int)
+ (:long :long)
+ (:single-float 'c-complex-float)
+ (:double-float 'c-complex-double)
+ (:string :string)
+ ;; Pass a pointer to the function.
+ (:callback :void)
+ ;;We assume the type is known to CFFI.
+ (t type)))))
;; Check if given type is a string
(declaim (inline string-p))
@@ -552,3 +550,4 @@
,(if (eq hack-return-type :void)
nil
retvar))))))))
+
diff --git a/src/ffi/f77-ffi.lisp b/src/ffi/f77-ffi.lisp
index 9c5491f..d68b04b 100644
--- a/src/ffi/f77-ffi.lisp
+++ b/src/ffi/f77-ffi.lisp
@@ -10,100 +10,96 @@
(in-package #:matlisp-ffi)
-;: Don't blame us, a lot of useful code
-;; is written in that stilted language.
-(define-constant +f77-types+
- '(:single-float :double-float
- :complex-single-float :complex-double-float
- :integer :long
- :string
- :callback))
-;; Get the equivalent CFFI type.
-;; If the type is an array, get the type of the array element type.
-(defun f77->cffi-type (type)
- "Convert the given Fortran FFI type into a type understood by CFFI."
- (cond
- ((and (listp type) (eq (first type) '*))
- `(:pointer ,@(f77->cffi-type (second type))))
- ((callback-type-p type)
- `(:pointer ,@(f77->cffi-type :callback)))
- ((eq type :complex-single-float)
- `(:pointer ,@(f77->cffi-type :single-float)))
- ((eq type :complex-double-float)
- `(:pointer ,@(f77->cffi-type :double-float)))
- (t `(,(ecase type
- (:void :void)
- (:integer :int)
- (:long :long)
- (:single-float :float)
- (:double-float :double)
- (:string :string)
- ;; Pass a pointer to the function.
- (:callback :void))))))
-
-;; Check if given type is a string
-(declaim (inline string-p))
-(defun string-p (type)
+(definline %f77.string-p (type)
+ "
+ Checks if the given type is a string."
(eq type :string))
-;; Check if given type is an array
-(declaim (inline array-p))
-(defun array-p (type)
+(definline %f77.array-p (type)
+ "
+ Checks if the given type is an array."
(and (listp type) (eq (car type) '*)))
-;; Check if the given type is - or has to be passed as - an array.
-(defun cast-as-array-p (type)
- (or (if (listp type)
- (eq (car type) '*))
+(definline %f77.cast-as-array-p (type)
+ "
+ Checks if the given type is - or has to be passed as - an array."
+ (or (when (listp type)
+ (eq (car type) '*))
(eq type :complex-single-float)
(eq type :complex-double-float)))
;; Check if the given type is a callback.
-(declaim (inline callback-type-p))
-(defun callback-type-p (type)
+(definline %f77.callback-type-p (type)
+ "
+ Checks if the given type is a callback"
(and (listp type) (eq (first type) :callback)))
-;; Fortran functions return-by-values.
-(defun get-return-type (type)
- (if (or (cast-as-array-p type) (callback-type-p type))
- (error "Cannot have a Fortran function output the type: ~S directly." type)
- (f77->cffi-type type)))
+;; Get the equivalent CFFI type.
+;; If the type is an array, get the type of the array element type.
+(defun %f77.cffi-type (type)
+ "Convert the given matlisp-ffi type into one understood by CFFI."
+ (cond
+ ((and (listp type) (eq (first type) '*))
+ `(:pointer ,(%f77.cffi-type (second type))))
+ ((%f77.callback-type-p type)
+ `(:pointer ,(%f77.cffi-type :callback)))
+ ((eq type :complex-single-float)
+ `(:pointer ,(%f77.cffi-type :single-float)))
+ ((eq type :complex-double-float)
+ `(:pointer ,(%f77.cffi-type :double-float)))
+ (t (ecase type
+ (:void :void)
+ (:integer :int)
+ (:character :char)
+ (:long :long)
+ (:single-float :float)
+ (:double-float :double)
+ (:string :string)
+ ;; Pass a pointer to the function.
+ (:callback :void)
+ (t (error 'unknown-token :token type
+ :message "Don't know the given Fortran type."))))))
+
+(defun %f77.get-return-type (type)
+ "
+ Return type understood by CFFI. Note that unlike arguments fortran
+ functions return-by-value."
+ (if (or (%f77.cast-as-array-p type) (%f77.callback-type-p type))
+ (error 'invalid-type :given type :expected '(not (or (%f77.cast-as-array-p type)
+ (%f77.callback-type-p type)))
+ :message "A Fortran function cannot return the given type.")
+ (%f77.cffi-type type)))
-;; If output
-(declaim (inline output-p))
-(defun output-p (style)
+(definline %f77.output-p (style)
+ "
+ Checks if style implies output."
(member style '(:output :input-output :workspace-output)))
-;; If input
-(declaim (inline input-p))
-(defun input-p (style)
- (member style '(:input :input-value :workspace)))
+(definline %f77.input-p (style)
+ "
+ Checks if style implies input."
+ (member style '(:input :input-value :input-reference :workspace)))
-;; CFFI doesn't nearly have as nice an FFI as SBCL/CMUCL.
-(defun get-read-in-type (type &optional (style :input))
- (unless (member style +ffi-styles+)
- (error "Don't know how to handle style ~A." style))
+(defun %f77.get-read-in-type (type &optional (style :input))
+ "
+ Get the input type to be passed to CFFI."
+ (assert (member style +ffi-styles+) nil 'unknown-token :token style
+ :message "Don't know how to handle style.")
(cond
;; Can't do much else if type is an array/complex or input is passed-by-value.
- ((or (callback-type-p type) (cast-as-array-p type) (eq style :input-value))
- (f77->cffi-type type))
+ ((or (%f77.callback-type-p type)
+ (%f77.cast-as-array-p type)
+ (eq style :input-value))
+ (%f77.cffi-type type))
;; else pass-by-reference
(t
- `(:pointer ,@(f77->cffi-type type)))))
-
-;; Separte the body of code into documentation and parameter lists.
-(defun parse-doc-&-parameters (body &optional header footer)
- (if (stringp (first body))
- (values `(,(%cat% header (first body) footer)) (rest body))
- (values (if (or header footer)
- (%cat% header "" footer)
- nil)
- body)))
-
-;; Parse fortran parameters and convert parameters to native C90 types (and
-;; add additional function parameters)
-(defun parse-fortran-parameters (body)
+ `(:pointer ,(%f77.cffi-type type)))))
+
+(defun %f77.parse-fortran-parameters (body)
+ "
+ Parse fortran parameters and convert parameters to native C90 types (and
+ add additional function parameters)."
(multiple-value-bind (doc pars)
(parse-doc-&-parameters body)
(declare (ignore doc))
@@ -111,200 +107,199 @@
(let* ((aux-pars nil)
(new-pars
(mapcar #'(lambda (decl)
- (destructuring-bind (name type &optional (style :input))
- decl
+ (destructuring-bind (name type &optional (style :input-reference)) decl
(case type
(:string
;; String lengths are appended to the function arguments,
;; passed by value.
- (nconsc aux-pars `((,(scat "LEN-" name) ,@(f77->cffi-type :integer))))
- `(,name ,@(f77->cffi-type :string)))
+ (nconsc aux-pars `((,(scat "LEN-" name) ,(%f77.cffi-type :integer))))
+ `(,name ,(%f77.cffi-type :string)))
(t
- `(,name ,@(get-read-in-type type style))))))
+ `(,name ,(%f77.get-read-in-type type style))))))
pars)))
`( ;; don't want documentation for direct interface, not useful
;; ,@doc
,@new-pars ,@aux-pars))))
-;;
-;; DEF-FORTRAN-ROUTINE
-;;
-;; An external Fortran routine definition form (DEF-FORTRAN-ROUTINE
-;; MY-FUN ...) creates two functions:
-;;
-;; 1. a raw FFI (foreign function interface),
-;; 2. an easier to use lisp interface to the raw interface.
-;;
-;; The documentation given here relates in the most part to the
-;; simplified lisp interface.
-;;
-;; Example:
-;; ========
-;; libblas.a contains the fortran subroutine DCOPY(N,X,INCX,Y,INCY)
-;; which copies the vector Y of N double-float's to the vector X.
-;; The function name in libblas.a is \"dcopy_\" (by Fortran convention).
-;;
-;; (DEF-FORTRAN-ROUTINE DCOPY :void
-;; (N :integer :input)
-;; (X (* :double-float) :output)
-;; (INCX :integer :input)
-;; (Y (* :double-float) :input)
-;; (INCY :integer :input))
-;;
-;; will expand into:
-;;
-;; (CFFI:DEFCFUN ("dcopy_" FORTRAN-DCOPY) :VOID
-;; (N :POINTER :INT)
-;; (DX :POINTER :DOUBLE)
-;; (INCX :POINTER :INT)
-;; (DY :POINTER :DOUBLE)
-;; (INCY :POINTER :INT))
-;;
-;; and
-;;
-;; (DEFUN DCOPY (N,X,INCX,Y,INCY)
-;; ...
-;;
-;; In turn, the lisp function DCOPY calls FORTRAN-DCOPY which calls
-;; the Fortran function "dcopy_" in libblas.a.
-;;
-;; Arguments:
-;; ==========
-;;
-;;
-;; NAME Name of the lisp interface function that will be created.
-;; The name of the raw FFI will be derived from NAME via
-;; the function MAKE-FFI-NAME. The name of foreign function
-;; (presumable a Fortran Function in an external library)
-;; will be derived from NAME via MAKE-FORTRAN-NAME.
-;;
-;; RETURN-TYPE
-;; The type of data that will be returned by the external
-;; (presumably Fortran) function.
-;;
-;; (MEMBER RETURN-TYPE '(:VOID :INTEGER :SINGLE-FLOAT :DOUBLE-FLOAT
-;; :COMPLEX-SINGLE-FLOAT :COMPLEX-DOUBLE-FLOAT))
-;;
-;; See GET-READ-OUT-TYPE.
-;;
-;; BODY A list of parameter forms. A parameter form is:
-;;
-;; (VARIABLE TYPE &optional (STYLE :INPUT))
-;;
-;; The VARIABLE is the name of a parameter accepted by the
-;; external (presumably Fortran) routine. TYPE is the type of
-;; VARIABLE. The recognized TYPE's are:
-;;
-;; TYPE Corresponds to Fortran Declaration
-;; ---- ----------------------------------
-;; :STRING CHARACTER*(*)
-;; :INTEGER INTEGER
-;; :SINGLE-FLOAT REAL
-;; :DOUBLE-FLOAT DOUBLE PRECISION
-;; :COMPLEX-SINGLE-FLOAT COMPLEX
-;; :COMPLEX-DOUBLE-FLOAT COMPLEX*16
-;; (* X) An array of type X.
-;; (:CALLBACK args) A description of a function or subroutine
-;;
-;; (MEMBER X '(:INTEGER :SINGLE-FLOAT :DOUBLE-FLOAT
-;; :COMPLEX-SINGLE-FLOAT :COMPLEX-DOUBLE-FLOAT)
-;;
-;;
-;; The STYLE (default :INPUT) defines how VARIABLE is treated.
-;; This is by far the most difficult quantity to learn. To
-;; begin with:
-;;
-;;
-;; (OR (MEMBER STYLE '(:INPUT :OUTPUT :INPUT-OUTPUT))
-;; (MEMBER STYLE '(:IN :COPY :IN-OUT :OUT)))
-;;
-;; TYPE STYLE Description
-;; ---- ----- -----------
-;; X :INPUT Value will be used but not modified.
-;;
-;; :OUTPUT Input value not used (but some value must be given),
-;; a value is returned as one of the values lisp
-;; function NAME. Similar to the :IN-OUT style
-;; of DEF-ALIEN-ROUTINE.
-;; :INPUT-OUTPUT Input value may be used, a value is returned
-;; as one of the values from the lisp function
-;; NAME.
-;;
-;; ** Note: In all 3 cases above the input VARIABLE will not be destroyed
-;; or modified directly, a copy is taken and a pointer of that
-;; copy is passed to the (presumably Fortran) external routine.
-;;
-;; (OR (* X) :INPUT Array entries are used but not modified.
-;; :STRING) :OUTPUT Array entries need not be initialized on input,
-;; but will be *modified*. In addition, the array
-;; will be returned via the Lisp command VALUES
-;; from the lisp function NAME.
-;;
-;; :INPUT-OUTPUT Like :OUTPUT but initial values on entry may be used.
-;;
-;; The keyword :WORKSPACE is a nickname for :INPUT. The
-;; keywords :INPUT-OR-OUTPUT, :WORKSPACE-OUTPUT,
-;; :WORKSPACE-OR-OUTPUT are nicknames for :OUTPUT.
-;;
-;; This is complicated. Suggestions are encouraged to
-;; interface a *functional language* to a *pass-by-reference
-;; language*.
-;;
-;; CALLBACKS
-;;
-;; A callback here means a function (or subroutine) that is passed into the Fortran
-;; routine which calls it as needed to compute something.
-;;
-;; The syntax of :CALLBACK is similar to the DEF-FORTRAN-ROUTINE:
-;;
-;; (name (:CALLBACK return-type
-;; {arg-description}))
-;;
-;; The RETURN-TYPE is the same as for DEF-FORTRAN-ROUTINE. The arg description is the
-;; same syntax as list of parameter forms for DEF-FORTRAN-ROUTINE. However, if the type
-;; is a pointer type (like (* :double-float)), then a required keyword option must be
-;; specified:
-;;
-;; (name (* type :size size) &optional style)
-;;
-;; The size specifies the total length of the Fortran array. This array is treated as a
-;; one dimentionsal vector and should be accessed using the function FV-REF, which is
-;; analogous to AREF. The SIZE parameter can be any Lisp form and can refer to any of the
-;; arguments to the Fortran routine.
-;;
-;; For example, a fortran routine can have the callback
-;;
-;; (def-fortran-routine foo :void
-;; (m (* :integer) :input)
-;; (fsub (:callback :void
-;; (x :double-float :input)
-;; (z (* :double-float :size (aref m 0)) :input)
-;; (f (* :double-float :size (aref m 0)) :output)))))
-;;
-;; This means that the arrays Z and F in FSUB have a dimension of (AREF M 0), the first
-;; element of the vector M. The function FSUB can be written in Lisp as
-;;
-;; (defun fsub (x z f)
-;; (setf (fv-ref f 0) (* x x (fv-ref z 3))))
-;;
-;; Further Notes:
-;; ===============
-;;
-;; Some Fortran routines use Fortran character strings in the
-;; parameter list. The definition here is suitable for Solaris
-;; where the Fortran character string is converted to a C-style null
-;; terminated string, AND an extra hidden parameter that is appended
-;; to the parameter list to hold the length of the string.
-;;
-;; If your Fortran does this differently, you'll have to change this
-;; definition accordingly!
-
-;; Call defcfun to define the foreign function.
-;; Also creates a nice lisp helper function.
-(defmacro def-fortran-routine (func-name return-type &rest body)
- (multiple-value-bind (fortran-name name) (if (listp func-name)
- (values (car func-name) (cadr func-name))
- (values (make-fortran-name func-name) func-name))
+(defmacro def-fortran-routine (name-and-options return-type &rest body)
+ "
+ DEF-FORTRAN-ROUTINE
+
+ An external Fortran routine definition form (DEF-FORTRAN-ROUTINE
+ MY-FUN ...) creates two functions:
+
+ 1. a raw FFI (foreign function interface),
+ 2. an easier to use lisp interface to the raw interface.
+
+ The documentation given here relates in the most part to the
+ simplified lisp interface.
+
+ Example:
+ ========
+ libblas.a contains the fortran subroutine DCOPY(N,X,INCX,Y,INCY)
+ which copies the vector Y of N double-float's to the vector X.
+ The function name in libblas.a is \"dcopy_\" (by Fortran convention).
+
+ (DEF-FORTRAN-ROUTINE DCOPY :void
+ (N :integer :input)
+ (X (* :double-float) :output)
+ (INCX :integer :input)
+ (Y (* :double-float) :input)
+ (INCY :integer :input))
+
+ will expand into:
+
+ (CFFI:DEFCFUN (\"dcopy_\" FORTRAN-DCOPY) :VOID
+ (N :POINTER :INT)
+ (DX :POINTER :DOUBLE)
+ (INCX :POINTER :INT)
+ (DY :POINTER :DOUBLE)
+ (INCY :POINTER :INT))
+
+ and
+
+ (DEFUN DCOPY (N,X,INCX,Y,INCY)
+ ...
+
+ In turn, the lisp function DCOPY calls FORTRAN-DCOPY which calls
+ the Fortran function \"dcopy_\" in libblas.a.
+
+ Arguments:
+ ==========
+
+
+ NAME Name of the lisp interface function that will be created.
+ The name of the raw FFI will be derived from NAME via
+ the function MAKE-FFI-NAME. The name of foreign function
+ (presumable a Fortran Function in an external library)
+ will be derived from NAME via MAKE-FORTRAN-NAME.
+
+ RETURN-TYPE
+ The type of data that will be returned by the external
+ (presumably Fortran) function.
+
+ (MEMBER RETURN-TYPE '(:VOID :INTEGER :SINGLE-FLOAT :DOUBLE-FLOAT
+ :COMPLEX-SINGLE-FLOAT :COMPLEX-DOUBLE-FLOAT))
+
+ See GET-READ-OUT-TYPE.
+
+ BODY A list of parameter forms. A parameter form is:
+
+ (VARIABLE TYPE &optional (STYLE :INPUT))
+
+ The VARIABLE is the name of a parameter accepted by the
+ external (presumably Fortran) routine. TYPE is the type of
+ VARIABLE. The recognized TYPE's are:
+
+ TYPE Corresponds to Fortran Declaration
+ ---- ----------------------------------
+ :STRING CHARACTER*(*)
+ :INTEGER INTEGER
+ :SINGLE-FLOAT REAL
+ :DOUBLE-FLOAT DOUBLE PRECISION
+ :COMPLEX-SINGLE-FLOAT COMPLEX
+ :COMPLEX-DOUBLE-FLOAT COMPLEX*16
+ (* X) An array of type X.
+ (:CALLBACK args) A description of a function or subroutine
+
+ (MEMBER X '(:INTEGER :SINGLE-FLOAT :DOUBLE-FLOAT
+ :COMPLEX-SINGLE-FLOAT :COMPLEX-DOUBLE-FLOAT)
+
+
+ The STYLE (default :INPUT) defines how VARIABLE is treated.
+ This is by far the most difficult quantity to learn. To
+ begin with:
+
+
+ (OR (MEMBER STYLE '(:INPUT :OUTPUT :INPUT-OUTPUT))
+ (MEMBER STYLE '(:IN :COPY :IN-OUT :OUT)))
+
+ TYPE STYLE Description
+ ---- ----- -----------
+ X :INPUT Value will be used but not modified.
+
+ :OUTPUT Input value not used (but some value must be given),
+ a value is returned as one of the values lisp
+ function NAME. Similar to the :IN-OUT style
+ of DEF-ALIEN-ROUTINE.
+ :INPUT-OUTPUT Input value may be used, a value is returned
+ as one of the values from the lisp function
+ NAME.
+
+ ** Note: In all 3 cases above the input VARIABLE will not be destroyed
+ or modified directly, a copy is taken and a pointer of that
+ copy is passed to the (presumably Fortran) external routine.
+
+ (OR (* X) :INPUT Array entries are used but not modified.
+ :STRING) :OUTPUT Array entries need not be initialized on input,
+ but will be *modified*. In addition, the array
+ will be returned via the Lisp command VALUES
+ from the lisp function NAME.
+
+ :INPUT-OUTPUT Like :OUTPUT but initial values on entry may be used.
+
+ The keyword :WORKSPACE is a nickname for :INPUT. The
+ keywords :INPUT-OR-OUTPUT, :WORKSPACE-OUTPUT,
+ :WORKSPACE-OR-OUTPUT are nicknames for :OUTPUT.
+
+ This is complicated. Suggestions are encouraged to
+ interface a *functional language* to a *pass-by-reference
+ language*.
+
+ CALLBACKS
+
+ A callback here means a function (or subroutine) that is passed into the Fortran
+ routine which calls it as needed to compute something.
+
+ The syntax of :CALLBACK is similar to the DEF-FORTRAN-ROUTINE:
+
+ (name (:CALLBACK return-type
+ {arg-description}))
+
+ The RETURN-TYPE is the same as for DEF-FORTRAN-ROUTINE. The arg description is the
+ same syntax as list of parameter forms for DEF-FORTRAN-ROUTINE. However, if the type
+ is a pointer type (like (* :double-float)), then a required keyword option must be
+ specified:
+
+ (name (* type :size size) &optional style)
+
+ The size specifies the total length of the Fortran array. This array is treated as a
+ one dimentionsal vector and should be accessed using the function FV-REF, which is
+ analogous to AREF. The SIZE parameter can be any Lisp form and can refer to any of the
+ arguments to the Fortran routine.
+
+ For example, a fortran routine can have the callback
+
+ (def-fortran-routine foo :void
+ (m (* :integer) :input)
+ (fsub (:callback :void
+ (x :double-float :input)
+ (z (* :double-float :size (aref m 0)) :input)
+ (f (* :double-float :size (aref m 0)) :output)))))
+
+ This means that the arrays Z and F in FSUB have a dimension of (AREF M 0), the first
+ element of the vector M. The function FSUB can be written in Lisp as
+
+ (defun fsub (x z f)
+ (setf (fv-ref f 0) (* x x (fv-ref z 3))))
+
+ Further Notes:
+ ===============
+
+ Some Fortran routines use Fortran character strings in the
+ parameter list. The definition here is suitable for Solaris
+ where the Fortran character string is converted to a C-style null
+ terminated string, AND an extra hidden parameter that is appended
+ to the parameter list to hold the length of the string.
+
+ If your Fortran does this differently, you'll have to change this
+ definition accordingly!
+
+ Call defcfun to define the foreign function.
+ Also creates a nice lisp helper function."
+ (multiple-value-bind (fortran-name name) (if (listp name-and-options)
+ (values (car name-and-options) (cadr name-and-options))
+ (values (make-fortran-name name-and-options) name-and-options))
(let* ((lisp-name (make-fortran-ffi-name `,name))
(hack-return-type `,return-type)
(hack-body `(,@body))
@@ -326,18 +321,13 @@
(setq hack-return-type :void)))
`(progn
- ;; Removing 'inlines' It seems that CMUCL has a problem with
- ;; inlines of FFI's when a lisp image is saved. Until the
- ;; matter is clarified we leave out 'inline's
-
- ;; (declaim (inline ,lisp-name)) ;sbcl 0.8.5 has problems with
- (cffi:defcfun (,fortran-name ,lisp-name) ,@(get-return-type hack-return-type)
- ,@(parse-fortran-parameters hack-body))
- ,@(def-fortran-interface name hack-return-type hack-body hidden-var-name)))))
+ (cffi:defcfun (,fortran-name ,lisp-name) ,(%f77.get-return-type hack-return-type)
+ ,@(%f77.parse-fortran-parameters hack-body))
+ ,@(%f77.def-fortran-interface name hack-return-type hack-body hidden-var-name)))))
;; Create a form specifying a simple Lisp function that calls the
;; underlying Fortran routine of the same name.
-(defun def-fortran-interface (name return-type body hidden-var-name)
+(defun %f77.def-fortran-interface (name return-type body hidden-var-name)
(multiple-value-bind (doc pars)
(parse-doc-&-parameters body)
(let ((ffi-fn (make-fortran-ffi-name name))
@@ -359,15 +349,15 @@
(aux-var nil))
(cond
;; Callbacks are tricky.
- ((callback-type-p type)
+ ((%f77.callback-type-p type)
(let* ((callback-name (gensym (symbol-name var)))
- (c-callback-code (def-fortran-callback var callback-name (second type) (cddr type))))
+ (c-callback-code (%f77.def-fortran-callback var callback-name (second type) (cddr type))))
(nconsc callback-code c-callback-code)
(setq ffi-var `(cffi:callback ,callback-name))))
;; Can't really enforce "style" when given an array.
;; Complex numbers do not latch onto this case, they
;; are passed by value.
- ((array-p type)
+ ((%f77.array-p type)
(setq ffi-var (scat "ADDR-" var))
(nconsc array-vars `((,ffi-var ,var)))
;;
@@ -376,7 +366,7 @@
`((,arg 0)))
(nconc (car (last array-vars)) `(:inc-type ,(cadr type) :inc ,arg))))
;; Strings
- ((string-p type)
+ ((%f77.string-p type)
(setq ffi-var var)
(setq aux-var (scat "LEN-" var))
(nconsc aux-args `((,aux-var (length (the string ,var))))))
@@ -392,13 +382,13 @@
((member type '(:complex-single-float :complex-double-float))
(setq ffi-var (scat "ADDR-REAL-CAST-" var))
(nconsc ref-vars
- `((,ffi-var ,(second (f77->cffi-type type)) :count 2 :initial-contents (list (realpart ,var) (imagpart ,var))))))
+ `((,ffi-var ,(second (%f77.cffi-type type)) :count 2 :initial-contents (list (realpart ,var) (imagpart ,var))))))
(t
(setq ffi-var (scat "REF-" var))
(nconsc ref-vars
- `((,ffi-var ,@(f77->cffi-type type) :initial-element ,var)))))))
+ `((,ffi-var ,(%f77.cffi-type type) :initial-element ,var)))))))
;; Output variables
- (when (and (output-p style) (not (eq type :string)))
+ (when (and (%f77.output-p style) (not (eq type :string)))
(nconsc return-vars
`((,ffi-var ,var ,type))))
;; Arguments for the lisp wrapper
@@ -448,9 +438,9 @@
,@(mapcar #'(lambda (decl)
(destructuring-bind (ffi-var var type) decl
(if (member type '(:complex-single-float :complex-double-float))
- `(setq ,var (complex (cffi:mem-aref ,ffi-var ,(second (f77->cffi-type type)) 0)
- (cffi:mem-aref ,ffi-var ,(second (f77->cffi-type type)) 1)))
- `(setq ,var (cffi:mem-aref ,ffi-var ,@(f77->cffi-type type))))))
+ `(setq ,var (complex (cffi:mem-aref ,ffi-var ,(second (%f77.cffi-type type)) 0)
+ (cffi:mem-aref ,ffi-var ,(second (%f77.cffi-type type)) 1)))
+ `(setq ,var (cffi:mem-aref ,ffi-var ,(%f77.cffi-type type))))))
(remove-if-not #'(lambda (x)
(member (first x) ref-vars :key #'car))
return-vars))
@@ -459,8 +449,133 @@
`(,retvar))
,@(mapcar #'second return-vars)))))))))
+#+nil
+(defun def-fortran-interface-func (name return-type body hidden-var-name)
+ (multiple-value-bind (doc pars)
+ (parse-doc-&-parameters body)
+ (let ((ffi-fn (make-fortran-ffi-name name))
+ (return-vars nil)
+ (array-vars nil)
+ (ref-vars nil)
+ (callback-code nil)
+ ;;
+ (defun-args nil)
+ (defun-keyword-args nil)
+ ;;
+ (aux-args nil)
+ ;;
+ (ffi-args nil)
+ (aux-ffi-args nil))
+ (dolist (decl pars)
+ (destructuring-bind (var type &optional style) decl
+ (let ((ffi-var nil)
+ (aux-var nil))
+ (cond
+ ;; Callbacks are tricky.
+ ((%f77.callback-type-p type)
+ (let* ((callback-name (gensym (symbol-name var)))
+ (c-callback-code (def-fortran-callback var callback-name (second type) (cddr type))))
+ (nconsc callback-code c-callback-code)
+ (setq ffi-var `(cffi:callback ,callback-name))))
+ ;; Can't really enforce "style" when given an array.
+ ;; Complex numbers do not latch onto this case, they
+ ;; are passed by value.
+ ((%f77.array-p type)
+ (setq ffi-var (scat "ADDR-" var))
+ (nconsc array-vars `((,ffi-var ,var)))
+ ;;
+ (when-let (arg (getf type :inc))
+ (nconsc defun-keyword-args
+ `((,arg 0)))
+ (nconc (car (last array-vars)) `(:inc-type ,(cadr type) :inc ,arg))))
+ ;; Strings
+ ((%f77.string-p type)
+ (setq ffi-var var)
+ (setq aux-var (scat "LEN-" var))
+ (nconsc aux-args `((,aux-var (length (the string ,var))))))
+ ;; Pass-by-value variables
+ ((eq style :input-value)
+ (setq ffi-var var))
+ ;; Pass-by-reference variables
+ (t
+ (cond
+ ;; Makes more sense to copy complex numbers into
+ ;; arrays, rather than twiddling around with lisp
+ ;; memory internals.
+ ((member type '(:complex-single-float :complex-double-float))
+ (setq ffi-var (scat "ADDR-REAL-CAST-" var))
+ (nconsc ref-vars
+ `((,ffi-var ,(second (%f77.cffi-type type)) :count 2 :initial-contents (list (realpart ,var) (imagpart ,var))))))
+ (t
+ (setq ffi-var (scat "REF-" var))
+ (nconsc ref-vars
+ `((,ffi-var ,@(%f77.cffi-type type) :initial-element ,var)))))))
+ ;; Output variables
+ (when (and (output-p style) (not (eq type :string)))
+ (nconsc return-vars
+ `((,ffi-var ,var ,type))))
+ ;; Arguments for the lisp wrapper
+ (unless (eq var hidden-var-name)
+ (nconsc defun-args
+ `(,var)))
+ ;; Arguments for the FFI function
+ (nconsc ffi-args
+ `(,ffi-var))
+ ;; Auxillary arguments for FFI
+ (unless (null aux-var)
+ (nconsc aux-ffi-args
+ `(,aux-var))))))
+ ;;Complex returns through hidden variable.
+ (unless (null hidden-var-name)
+ (nconsc aux-args `((,hidden-var-name ,(ecase (second (first pars))
+ (:complex-single-float #c(0e0 0e0))
+ (:complex-double-float #c(0d0 0d0)))))))
+ ;;Keyword argument list
+ (unless (null defun-keyword-args)
+ (setq defun-keyword-args (cons '&optional defun-keyword-args)))
+ ;;Return the function definition
+ (let ((retvar (gensym)))
+ `(
+ ,(recursive-append
+ `(defun ,name ,(append defun-args (mapcar #'(lambda (decl)
+ ())
+ defun-keyword-args)
+ ,@doc)
+ ;;
+ (unless (null aux-args)
+ `(let (,@aux-args)))
+ ;;Don't use with-foreign.. if ref-vars is nil
+ (unless (null ref-vars)
+ `(with-foreign-objects-stacked (,@ref-vars)))
+ ;;Don't use with-vector-dat.. if array-vars is nil
+ (unless (null array-vars)
+ `(with-vector-data-addresses (,@array-vars)))
+ ;;Declare callbacks
+ callback-code
+ ;;Call the foreign-function
+ `(let ((,retvar (,ffi-fn ,@ffi-args ,@aux-ffi-args)))
+ ;;Ignore return if type is :void
+ ,@(when (eq return-type :void)
+ `((declare (ignore ,retvar))))
+ ;; Copy values in reference pointers back to local
+ ;; variables. Lisp has local scope; its safe to
+ ;; modify variables in parameter lists.
+ ,@(mapcar #'(lambda (decl)
+ (destructuring-bind (ffi-var var type) decl
+ (if (member type '(:complex-single-float :complex-double-float))
+ `(setq ,var (complex (cffi:mem-aref ,ffi-var ,(second (%f77.cffi-type type)) 0)
+ (cffi:mem-aref ,ffi-var ,(second (%f77.cffi-type type)) 1)))
+ `(setq ,var (cffi:mem-aref ,ffi-var ,@(%f77.cffi-type type))))))
+ (remove-if-not #'(lambda (x)
+ (member (first x) ref-vars :key #'car))
+ return-vars))
+ (values
+ ,@(unless (eq return-type :void)
+ `(,retvar))
+ ,@(mapcar #'second return-vars))))))))))
-(defun def-fortran-callback (func callback-name return-type parm)
+;;TODO: Outputs are messed up inside the callback
+(defun %f77.def-fortran-callback (func callback-name return-type parm)
(let* ((hack-return-type `,return-type)
(hack-parm `(,@parm))
(hidden-var-name nil))
@@ -483,23 +598,23 @@
(func-var nil))
(cond
;; Callbacks are tricky.
- ((callback-type-p type)
+ ((%f77.callback-type-p type)
(setq ffi-var var)
(setq func-var var))
;;
- ((array-p type)
+ ((%f77.array-p type)
(setq ffi-var (scat "ADDR-" var))
(setq func-var var)
- (nconsc array-vars `((,func-var (make-foreign-vector :pointer ,ffi-var :type ,(second (f77->cffi-type type))
+ (nconsc array-vars `((,func-var (make-foreign-vector :pointer ,ffi-var :type ,(second (%f77.cffi-type type))
:size ,(if-let (size (getf type :size))
size
1))))))
;;
- ((string-p type)
+ ((%f77.string-p type)
(setq ffi-var var)
(setq func-var var)
(nconsc aux-pars
- `((,(scat "LEN-" var) ,@(f77->cffi-type :integer)))))
+ `((,(scat "LEN-" var) ,(%f77.cffi-type :integer)))))
;;
((eq style :input-value)
(setq ffi-var var)
@@ -511,24 +626,24 @@
(setq ffi-var (scat "ADDR-REAL-CAST-" var))
(setq func-var var)
(nconsc ref-vars
- `((,func-var (complex (cffi:mem-aref ,ffi-var ,(second (f77->cffi-type type)) 0)
- (cffi:mem-aref ,ffi-var ,(second (f77->cffi-type type)) 1))))))
+ `((,func-var (complex (cffi:mem-aref ,ffi-var ,(second (%f77.cffi-type type)) 0)
+ (cffi:mem-aref ,ffi-var ,(second (%f77.cffi-type type)) 1))))))
(t
(setq ffi-var (scat "REF-" var))
(setq func-var var)
(nconsc ref-vars
- `((,func-var (cffi:mem-aref ,ffi-var ,@(f77->cffi-type type)))))))))
+ `((,func-var (cffi:mem-aref ,ffi-var ,(%f77.cffi-type type)))))))))
;;
- (nconsc new-pars `((,ffi-var ,@(get-read-in-type type style))))
+ (nconsc new-pars `((,ffi-var ,(%f77.get-read-in-type type style))))
(nconsc func-pars `(,func-var))
- (when (and (output-p style) (not (eq type :string)))
+ (when (and (%f77.output-p style) (not (eq type :string)))
(nconsc return-vars
`((,func-var ,ffi-var ,type)))))))
(let ((retvar (gensym)))
`(
,(recursive-append
- `(cffi:defcallback ,callback-name ,@(get-return-type hack-return-type)
+ `(cffi:defcallback ,callback-name ,(%f77.get-return-type hack-return-type)
(,@new-pars ,@aux-pars))
;;
(when ref-vars
@@ -543,9 +658,9 @@
,@(mapcar #'(lambda (decl)
(destructuring-bind (func-var ffi-var type) decl
(if (member type '(:complex-single-float :complex-double-float))
- `(setf (cffi:mem-aref ,ffi-var ,(second (f77->cffi-type type)) 0) (realpart ,func-var)
- (cffi:mem-aref ,ffi-var ,(second (f77->cffi-type type)) 1) (imagpart ,func-var))
- `(setf (cffi:mem-aref ,ffi-var ,@(f77->cffi-type type)) ,func-var))))
+ `(setf (cffi:mem-aref ,ffi-var ,(second (%f77.cffi-type type)) 0) (realpart ,func-var)
+ (cffi:mem-aref ,ffi-var ,(second (%f77.cffi-type type)) 1) (imagpart ,func-var))
+ `(setf (cffi:mem-aref ,ffi-var ,(%f77.cffi-type type)) ,func-var))))
(remove-if-not #'(lambda (x)
(member (first x) ref-vars :key #'car))
return-vars))
diff --git a/src/ffi/ffi-cffi.lisp b/src/ffi/ffi-cffi.lisp
index da73d9c..9597bc2 100644
--- a/src/ffi/ffi-cffi.lisp
+++ b/src/ffi/ffi-cffi.lisp
@@ -11,8 +11,25 @@
(in-package #:matlisp-ffi)
(define-constant +ffi-styles+
- '(:input :input-reference :input-value :workspace
- :input-output :output :workspace-output))
+ '(:input :input-reference :input-value
+ :input-output :output :workspace-output
+ :workspace))
+
+(define-constant +ffi-types+
+ '(:single-float :double-float
+ :complex-single-float :complex-double-float
+ :integer :long
+ :string :character
+ :callback))
+
+;; Separte the body of code into documentation and parameter lists.
+(defun parse-doc-&-parameters (body &optional header footer)
+ (if (stringp (first body))
+ (values `(,(%cat% header (first body) footer)) (rest body))
+ (values (if (or header footer)
+ (%cat% header "" footer)
+ nil)
+ body)))
;; Create objects on the heap and run some stuff.
(defmacro with-foreign-objects-heaped (declarations &rest body)
diff --git a/src/level-2/gemv.lisp b/src/level-2/gemv.lisp
index 43b9e10..7fffe5e 100644
--- a/src/level-2/gemv.lisp
+++ b/src/level-2/gemv.lisp
@@ -228,4 +228,4 @@
#'make-complex-tensor
#'make-real-tensor)
(list (ecase job (:n (nrows A)) (:t (ncols A)))))))
- (gemv! alpha A x beta result job)))
+ (gemv! alpha A x 0 result job)))
diff --git a/src/packages/odepack/dlsode.lisp b/src/packages/odepack/dlsode.lisp
index a284d50..0d2c975 100644
--- a/src/packages/odepack/dlsode.lisp
+++ b/src/packages/odepack/dlsode.lisp
@@ -85,9 +85,10 @@
(defun pend-report (ts y)
(format t "~A ~A ~A ~%" ts (aref y 0) (aref y 1)))
-(defvar y (make-array 2 :element-type 'double-float :initial-contents `(,(/ pi 2) 0d0)))
+#+nil
+(let ((y (make-array 2 :element-type 'double-float :initial-contents `(,(/ pi 2) 0d0))))
+ (lsode-evolve #'pend-field y #(0d0 1d0 2d0) #'pend-report))
-;; (lsode-evolve #'pend-field y #(0d0 1d0 2d0) #'pend-report)
;; Should return
;; 1.0d0 1.074911802207049d0 -0.975509986605856d0
;; 2.0d0 -0.20563950412081608d0 -1.3992359518735706d0
diff --git a/src/utilities.lisp b/src/utilities.lisp
index e2e74c4..4a631aa 100644
--- a/src/utilities.lisp
+++ b/src/utilities.lisp
@@ -233,22 +233,37 @@
(bin-append (car lsts) (apply #'recursive-append (cdr lsts))))))
(defun unquote-args (lst args)
+ "
+ Makes list suitable for use inside macros (sort-of).
+ Example:
+ > (unquote-args '(+ x y z) '(x y))
+ (LIST '+ X Y 'Z)
+
+ DO NOT use backquotes!
+ "
(labels ((replace-atoms (lst ret)
- (if (null lst) (reverse ret)
- (let ((fst (car lst)))
- (replace-atoms (cdr lst)
- (cond
- ((atom fst)
- (if (member fst args)
- (cons fst ret)
- (append `(',fst) ret)))
- ((consp fst)
- (cons (replace-lst fst nil) ret)))))))
+ (cond
+ ((null lst) (reverse ret))
+ ((atom lst)
+ (let ((ret (reverse ret)))
+ (rplacd (last ret) lst)
+ ret))
+ ((consp lst)
+ (replace-atoms (cdr lst) (let ((fst (car lst)))
+ (cond
+ ((atom fst)
+ (if (member fst args)
+ (cons fst ret)
+ (append `(',fst) ret)))
+ ((consp fst)
+ (cons (replace-lst fst nil) ret))))))))
(replace-lst (lst acc)
(cond
((null lst) acc)
((consp lst)
- (cons 'list (replace-atoms lst nil)))
+ (if (eq (car lst) 'quote)
+ lst
+ (cons 'list (replace-atoms lst nil))))
((atom lst) lst))))
(replace-lst lst nil)))
@@ -262,10 +277,79 @@
(rec x nil)))
(defmacro macrofy (lambda-func)
+ "
+ Macrofies a lambda function, for use later inside macros (or for symbolic math ?).
+ Example:
+ > (macroexpand-1 `(macrofy (lambda (x y z) (+ (sin x) y (apply #'cos (list z))))))
+ (LAMBDA (X Y Z)
+ (LIST '+ (LIST 'SIN X) Y (LIST 'APPLY (LIST 'FUNCTION 'COS) (LIST 'LIST Z))))
+ T
+ > (funcall (macrofy (lambda (x y z) (+ (sin x) y (apply #'cos (list z))))) 'a 'b 'c)
+ (+ (SIN A) B (APPLY #'COS (LIST C)))
+
+ DO NOT USE backquotes in the lambda function!
+ "
(destructuring-bind (labd args &rest body) lambda-func
(assert (eq labd 'lambda))
`(lambda ,args ,@(cdr (unquote-args body args)))))
+(defmacro looped-mapcar ((func lst) &rest body)
+ "
+ A macro to use when caught between the efficiency of imperative looping, and
+ the elegance of mapcar (in a dozen places).
+
+ Collects references to func and replaces them with a varible inside a loop.
+ Note that although we traverse through the list only once, the collected lists
+ aren't freed until the macro is closed.
+
+ Example:
+ > (macroexpand-1
+ `(looped-mapcar (lmap '(1 2 3 4 5 6 7 8 9 10))
+ (cons (lmap #'even) (lmap #'(lambda (x) (+ x 1))))))
+ (LET ((#:|lst1118| '(1 2 3 4 5 6 7 8 9 10)))
+ (LOOP FOR #:|ele1117| IN #:|lst1118|
+ COLLECT (FUNCALL #'(LAMBDA (X) (+ X 1))
+ #:|ele1117|) INTO #:|collect1116|
+ COLLECT (FUNCALL #'EVEN #:|ele1117|) INTO #:|collect1115|
+ FINALLY (RETURN (PROGN (CONS #:|collect1115| #:|collect1116|)))))
+ "
+ (let ((ret nil))
+ (labels ((collect-funcs (code tf-code)
+ (cond
+ ((null code)
+ (reverse tf-code))
+ ((atom code)
+ (let ((ret (reverse tf-code)))
+ (rplacd (last ret) code)
+ ret))
+ ((consp code)
+ (let ((carcode (car code)))
+ (cond
+ ((and (consp carcode)
+ (eq (first carcode) func))
+ (assert (null (cddr carcode)) nil 'invalid-arguments
+ :message "The mapper only takes one argument.")
+ (let ((col-sym (gensym "collect")))
+ (push `(,col-sym ,(second carcode)) ret)
+ (collect-funcs (cdr code) (cons col-sym tf-code))))
+ ((consp carcode)
+ (collect-funcs (cdr code) (cons (collect-funcs carcode nil) tf-code)))
+ (t
+ (collect-funcs (cdr code) (cons carcode tf-code)))))))))
+ (let ((tf-code (collect-funcs body nil))
+ (ele-sym (gensym "ele"))
+ (lst-sym (gensym "lst")))
+ (if (null ret)
+ `(progn
+ ,@tf-code)
+ `(let ((,lst-sym ,lst))
+ (loop for ,ele-sym in ,lst-sym
+ ,@(loop for decl in ret
+ append `(collect (funcall ,(second decl) ,ele-sym) into ,(first decl)))
+ finally (return
+ (progn
+ ,@tf-code)))))))))
+
(declaim (inline string+))
(defun string+ (&rest strings)
(apply #'concatenate (cons 'string strings)))
commit aa67585771f77454b95fa7b16767ef3a6ff03923
Author: Akshay Srinivasan <aks...@gm...>
Date: Sun Jul 22 13:37:52 2012 +0530
o renamed: fortran-ffi.lisp -> f77-ffi.lisp
diff --git a/src/ffi/fortran-ffi.lisp b/src/ffi/f77-ffi.lisp
similarity index 99%
rename from src/ffi/fortran-ffi.lisp
rename to src/ffi/f77-ffi.lisp
index 7e048ca..9c5491f 100644
--- a/src/ffi/fortran-ffi.lisp
+++ b/src/ffi/f77-ffi.lisp
@@ -552,4 +552,3 @@
,(if (eq hack-return-type :void)
nil
retvar))))))))
-
commit 00e53dd09b3cc988dcd4e6e82934ff78bcb83501
Author: Akshay Srinivasan <aks...@gm...>
Date: Sun Jul 22 13:35:42 2012 +0530
o Moved Fortran-FFI macros into a separate file.
diff --git a/matlisp.asd b/matlisp.asd
index 8d442d0..9c6076b 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -77,6 +77,10 @@
:components ((:file "ffi-cffi")
(:file "ffi-cffi-implementation-specific")
(:file "foreign-vector")
+ (:file "fortran-ffi"
+ :depends-on ("ffi-cffi"
+ "ffi-cffi-implementation-specific"
+ "foreign-vector"))
))
(:module "foreign-core"
:pathname "foreign-core"
diff --git a/src/ffi/ffi-cffi.lisp b/src/ffi/ffi-cffi.lisp
index 8f57fa9..da73d9c 100644
--- a/src/ffi/ffi-cffi.lisp
+++ b/src/ffi/ffi-cffi.lisp
@@ -10,14 +10,9 @@
(in-package #:matlisp-ffi)
-(define-constant +ffi-types+ '(:single-float :double-float
- :complex-single-float :complex-double-float
- :integer :long
- :string
- :callback))
-
-(define-constant +ffi-styles+ '(:input :input-value :workspace
- :input-output :output :workspace-output))
+(define-constant +ffi-styles+
+ '(:input :input-reference :input-value :workspace
+ :input-output :output :workspace-output))
;; Create objects on the heap and run some stuff.
(defmacro with-foreign-objects-heaped (declarations &rest body)
@@ -105,540 +100,6 @@
`(,@wfo-body
,@body))))
-;; Get the equivalent CFFI type.
-;; If the type is an array, get the type of the array element type.
-(defun ->cffi-type (type)
- "Convert the given Fortran FFI type into a type understood by CFFI."
- (cond
- ((and (listp type) (eq (first type) '*))
- `(:pointer ,@(->cffi-type (second type))))
- ((callback-type-p type)
- `(:pointer ,@(->cffi-type :callback)))
- ((eq type :complex-single-float)
- `(:pointer ,@(->cffi-type :single-float)))
- ((eq type :complex-double-float)
- `(:pointer ,@(->cffi-type :double-float)))
- (t `(,(ecase type
- (:void :void)
- (:integer :int)
- (:long :long)
- (:single-float :float)
- (:double-float :double)
- (:string :string)
- ;; Pass a pointer to the function.
- (:callback :void))))))
-
-;; Check if given type is a string
-(declaim (inline string-p))
-(defun string-p (type)
- (eq type :string))
-
-;; Check if given type is an array
-(declaim (inline array-p))
-(defun array-p (type)
- (and (listp type) (eq (car type) '*)))
-
-;; Check if the given type is - or has to be passed as - an array.
-(defun cast-as-array-p (type)
- (or (if (listp type)
- (eq (car type) '*))
- (eq type :complex-single-float)
- (eq type :complex-double-float)))
-
-;; Check if the given type is a callback.
-(declaim (inline callback-type-p))
-(defun callback-type-p (type)
- (and (listp type) (eq (first type) :callback)))
-
-;; Fortran functions return-by-values.
-(defun get-return-type (type)
- (if (or (cast-as-array-p type) (callback-type-p type))
- (error "Cannot have a Fortran function output the type: ~S directly." type)
- (->cffi-type type)))
-
-;; If output
-(declaim (inline output-p))
-(defun output-p (style)
- (member style '(:output :input-output :workspace-output)))
-
-;; If input
-(declaim (inline input-p))
-(defun input-p (style)
- (member style '(:input :input-value :workspace)))
-
-;; CFFI doesn't nearly have as nice an FFI as SBCL/CMUCL.
-(defun get-read-in-type (type &optional (style :input))
- (unless (member style +ffi-styles+)
- (error "Don't know how to handle style ~A." style))
- (cond
- ;; Can't do much else if type is an array/complex or input is passed-by-value.
- ((or (callback-type-p type) (cast-as-array-p type) (eq style :input-value))
- (->cffi-type type))
- ;; else pass-by-reference
- (t
- `(:pointer ,@(->cffi-type type)))))
-
-;; Separte the body of code into documentation and parameter lists.
-(defun parse-doc-&-parameters (body &optional header footer)
- (if (stringp (first body))
- (values `(,(%cat% header (first body) footer)) (rest body))
- (values (if (or header footer)
- (%cat% header "" footer)
- nil)
- body)))
-
-;; Parse fortran parameters and convert parameters to native C90 types (and
-;; add additional function parameters)
-(defun parse-fortran-parameters (body)
- (multiple-value-bind (doc pars)
- (parse-doc-&-parameters body)
- (declare (ignore doc))
-
- (let* ((aux-pars nil)
- (new-pars
- (mapcar #'(lambda (decl)
- (destructuring-bind (name type &optional (style :input))
- decl
- (case type
- (:string
- ;; String lengths are appended to the function arguments,
- ;; passed by value.
- (nconsc aux-pars `((,(scat "LEN-" name) ,@(->cffi-type :integer))))
- `(,name ,@(->cffi-type :string)))
- (t
- `(,name ,@(get-read-in-type type style))))))
- pars)))
- `( ;; don't want documentation for direct interface, not useful
- ;; ,@doc
- ,@new-pars ,@aux-pars))))
-
-;;
-;; DEF-FORTRAN-ROUTINE
-;;
-;; An external Fortran routine definition form (DEF-FORTRAN-ROUTINE
-;; MY-FUN ...) creates two functions:
-;;
-;; 1. a raw FFI (foreign function interface),
-;; 2. an easier to use lisp interface to the raw interface.
-;;
-;; The documentation given here relates in the most part to the
-;; simplified lisp interface.
-;;
-;; Example:
-;; ========
-;; libblas.a contains the fortran subroutine DCOPY(N,X,INCX,Y,INCY)
-;; which copies the vector Y of N double-float's to the vector X.
-;; The function name in libblas.a is \"dcopy_\" (by Fortran convention).
-;;
-;; (DEF-FORTRAN-ROUTINE DCOPY :void
-;; (N :integer :input)
-;; (X (* :double-float) :output)
-;; (INCX :integer :input)
-;; (Y (* :double-float) :input)
-;; (INCY :integer :input))
-;;
-;; will expand into:
-;;
-;; (CFFI:DEFCFUN ("dcopy_" FORTRAN-DCOPY) :VOID
-;; (N :POINTER :INT)
-;; (DX :POINTER :DOUBLE)
-;; (INCX :POINTER :INT)
-;; (DY :POINTER :DOUBLE)
-;; (INCY :POINTER :INT))
-;;
-;; and
-;;
-;; (DEFUN DCOPY (N,X,INCX,Y,INCY)
-;; ...
-;;
-;; In turn, the lisp function DCOPY calls FORTRAN-DCOPY which calls
-;; the Fortran function "dcopy_" in libblas.a.
-;;
-;; Arguments:
-;; ==========
-;;
-;;
-;; NAME Name of the lisp interface function that will be created.
-;; The name of the raw FFI will be derived from NAME via
-;; the function MAKE-FFI-NAME. The name of foreign function
-;; (presumable a Fortran Function in an external library)
-;; will be derived from NAME via MAKE-FORTRAN-NAME.
-;;
-;; RETURN-TYPE
-;; The type of data that will be returned by the external
-;; (presumably Fortran) function.
-;;
-;; (MEMBER RETURN-TYPE '(:VOID :INTEGER :SINGLE-FLOAT :DOUBLE-FLOAT
-;; :COMPLEX-SINGLE-FLOAT :COMPLEX-DOUBLE-FLOAT))
-;;
-;; See GET-READ-OUT-TYPE.
-;;
-;; BODY A list of parameter forms. A parameter form is:
-;;
-;; (VARIABLE TYPE &optional (STYLE :INPUT))
-;;
-;; The VARIABLE is the name of a parameter accepted by the
-;; external (presumably Fortran) routine. TYPE is the type of
-;; VARIABLE. The recognized TYPE's are:
-;;
-;; TYPE Corresponds to Fortran Declaration
-;; ---- ----------------------------------
-;; :STRING CHARACTER*(*)
-;; :INTEGER INTEGER
-;; :SINGLE-FLOAT REAL
-;; :DOUBLE-FLOAT DOUBLE PRECISION
-;; :COMPLEX-SINGLE-FLOAT COMPLEX
-;; :COMPLEX-DOUBLE-FLOAT COMPLEX*16
-;; (* X) An array of type X.
-;; (:CALLBACK args) A description of a function or subroutine
-;;
-;; (MEMBER X '(:INTEGER :SINGLE-FLOAT :DOUBLE-FLOAT
-;; :COMPLEX-SINGLE-FLOAT :COMPLEX-DOUBLE-FLOAT)
-;;
-;;
-;; The STYLE (default :INPUT) defines how VARIABLE is treated.
-;; This is by far the most difficult quantity to learn. To
-;; begin with:
-;;
-;;
-;; (OR (MEMBER STYLE '(:INPUT :OUTPUT :INPUT-OUTPUT))
-;; (MEMBER STYLE '(:IN :COPY :IN-OUT :OUT)))
-;;
-;; TYPE STYLE Description
-;; ---- ----- -----------
-;; X :INPUT Value will be used but not modified.
-;;
-;; :OUTPUT Input value not used (but some value must be given),
-;; a value is returned as one of the values lisp
-;; function NAME. Similar to the :IN-OUT style
-;; of DEF-ALIEN-ROUTINE.
-;; :INPUT-OUTPUT Input value may be used, a value is returned
-;; as one of the values from the lisp function
-;; NAME.
-;;
-;; ** Note: In all 3 cases above the input VARIABLE will not be destroyed
-;; or modified directly, a copy is taken and a pointer of that
-;; copy is passed to the (presumably Fortran) external routine.
-;;
-;; (OR (* X) :INPUT Array entries are used but not modified.
-;; :STRING) :OUTPUT Array entries need not be initialized on input,
-;; but will be *modified*. In addition, the array
-;; will be returned via the Lisp command VALUES
-;; from the lisp function NAME.
-;;
-;; :INPUT-OUTPUT Like :OUTPUT but initial values on entry may be used.
-;;
-;; The keyword :WORKSPACE is a nickname for :INPUT. The
-;; keywords :INPUT-OR-OUTPUT, :WORKSPACE-OUTPUT,
-;; :WORKSPACE-OR-OUTPUT are nicknames for :OUTPUT.
-;;
-;; This is complicated. Suggestions are encouraged to
-;; interface a *functional language* to a *pass-by-reference
-;; language*.
-;;
-;; CALLBACKS
-;;
-;; A callback here means a function (or subroutine) that is passed into the Fortran
-;; routine which calls it as needed to compute something.
-;;
-;; The syntax of :CALLBACK is similar to the DEF-FORTRAN-ROUTINE:
-;;
-;; (name (:CALLBACK return-type
-;; {arg-description}))
-;;
-;; The RETURN-TYPE is the same as for DEF-FORTRAN-ROUTINE. The arg description is the
-;; same syntax as list of parameter forms for DEF-FORTRAN-ROUTINE. However, if the type
-;; is a pointer type (like (* :double-float)), then a required keyword option must be
-;; specified:
-;;
-;; (name (* type :size size) &optional style)
-;;
-;; The size specifies the total length of the Fortran array. This array is treated as a
-;; one dimentionsal vector and should be accessed using the function FV-REF, which is
-;; analogous to AREF. The SIZE parameter can be any Lisp form and can refer to any of the
-;; arguments to the Fortran routine.
-;;
-;; For example, a fortran routine can have the callback
-;;
-;; (def-fortran-routine foo :void
-;; (m (* :integer) :input)
-;; (fsub (:callback :void
-;; (x :double-float :input)
-;; (z (* :double-float :size (aref m 0)) :input)
-;; (f (* :double-float :size (aref m 0)) :output)))))
-;;
-;; This means that the arrays Z and F in FSUB have a dimension of (AREF M 0), the first
-;; element of the vector M. The function FSUB can be written in Lisp as
-;;
-;; (defun fsub (x z f)
-;; (setf (fv-ref f 0) (* x x (fv-ref z 3))))
-;;
-;; Further Notes:
-;; ===============
-;;
-;; Some Fortran routines use Fortran character strings in the
-;; parameter list. The definition here is suitable for Solaris
-;; where the Fortran character string is converted to a C-style null
-;; terminated string, AND an extra hidden parameter that is appended
-;; to the parameter list to hold the length of the string.
-;;
-;; If your Fortran does this differently, you'll have to change this
-;; definition accordingly!
-
-;; Call defcfun to define the foreign function.
-;; Also creates a nice lisp helper function.
-(defmacro def-fortran-routine (func-name return-type &rest body)
- (multiple-value-bind (fortran-name name) (if (listp func-name)
- (values (car func-name) (cadr func-name))
- (values (make-fortran-name func-name) func-name))
- (let* ((lisp-name (make-fortran-ffi-name `,name))
- (hack-return-type `,return-type)
- (hack-body `(,@body))
- (hidden-var-name nil))
- ;;
- (multiple-value-bind (doc pars)
- (parse-doc-&-parameters `(,@body))
- (when (member hack-return-type '(:complex-single-float :complex-double-float))
- ;; The return type is complex. Since this is a "structure",
- ;; Fortran inserts a "hidden" first parameter before all
- ;; others. This is used to store the resulting complex
- ;; number. Then there is no "return" value, so set the return
- ;; type to :void.
- ;;
- (setq hidden-var-name (gensym "HIDDEN-COMPLEX-RETURN-"))
- (setq hack-body `(,@doc
- (,hidden-var-name ,hack-return-type :output)
- ,@pars))
- (setq hack-return-type :void)))
-
- `(progn
- ;; Removing 'inlines' It seems that CMUCL has a problem with
- ;; inlines of FFI's when a lisp image is saved. Until the
- ;; matter is clarified we leave out 'inline's
-
- ;; (declaim (inline ,lisp-name)) ;sbcl 0.8.5 has problems with
- (cffi:defcfun (,fortran-name ,lisp-name) ,@(get-return-type hack-return-type)
- ,@(parse-fortran-parameters hack-body))
- ,@(def-fortran-interface name hack-return-type hack-body hidden-var-name)))))
-
-;; Create a form specifying a simple Lisp function that calls the
-;; underlying Fortran routine of the same name.
-(defun def-fortran-interface (name return-type body hidden-var-name)
- (multiple-value-bind (doc pars)
- (parse-doc-&-parameters body)
- (let ((ffi-fn (make-fortran-ffi-name name))
- (return-vars nil)
- (array-vars nil)
- (ref-vars nil)
- (callback-code nil)
- ;;
- (defun-args nil)
- (defun-keyword-args nil)
- ;;
- (aux-args nil)
- ;;
- (ffi-args nil)
- (aux-ffi-args nil))
- (dolist (decl pars)
- (destructuring-bind (var type &optional style) decl
- (let ((ffi-var nil)
- (aux-var nil))
- (cond
- ;; Callbacks are tricky.
- ((callback-type-p type)
- (let* ((callback-name (gensym (symbol-name var)))
- (c-callback-code (def-fortran-callback var callback-name (second type) (cddr type))))
- (nconsc callback-code c-callback-code)
- (setq ffi-var `(cffi:callback ,callback-name))))
- ;; Can't really enforce "style" when given an array.
- ;; Complex numbers do not latch onto this case, they
- ;; are passed by value.
- ((array-p type)
- (setq ffi-var (scat "ADDR-" var))
- (nconsc array-vars `((,ffi-var ,var)))
- ;;
- (when-let (arg (getf type :inc))
- (nconsc defun-keyword-args
- `((,arg 0)))
- (nconc (car (last array-vars)) `(:inc-type ,(cadr type) :inc ,arg))))
- ;; Strings
- ((s...
[truncated message content] |
|
From: Akshay S. <ak...@us...> - 2012-07-14 05:16:32
|
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 d18665bf3b836e17d2ff75065b384b5ff07059e3 (commit)
from 2b87e86f1392efee853a1807d7c9299fee1f7958 (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 d18665bf3b836e17d2ff75065b384b5ff07059e3
Author: Akshay Srinivasan <aks...@gm...>
Date: Sat Jul 14 10:41:46 2012 +0530
Started work on LAPACK wrappers.
diff --git a/matlisp.asd b/matlisp.asd
index f5cb98e..e0e8283 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -118,7 +118,7 @@
(:file "dot"
:depends-on ("realimag"))
(:file "axpy"
- :depends-on ("copy"))))
+ :depends-on ("copy" "scal"))))
(:module "matlisp-level-2"
:pathname "level-2"
:depends-on ("matlisp-base" "matlisp-classes" "foreign-core" "matlisp-level-1")
@@ -126,7 +126,15 @@
(:module "matlisp-level-3"
:pathname "level-3"
:depends-on ("matlisp-base" "matlisp-classes" "foreign-core" "matlisp-level-1")
- :components ((:file "gemm")))))
+ :components ((:file "gemm")))
+ (:module "matlisp-lapack"
+ :pathname "lapack"
+ :depends-on ("matlisp-base" "matlisp-classes" "matlisp-level-1" "matlisp-level-2" "matlisp-level-3")
+ :components ((:file "gesv")))
+ (:module "matlisp-sugar"
+ :pathname "sugar"
+ :depends-on ("matlisp-base" "matlisp-classes" "matlisp-level-1" "matlisp-level-2" "matlisp-level-3")
+ :components ((:file "mplusminus")))))
;; (defclass f2cl-cl-source-file (asdf:cl-source-file)
diff --git a/src/base/permutation.lisp b/src/base/permutation.lisp
index d5f18df..017072b 100644
--- a/src/base/permutation.lisp
+++ b/src/base/permutation.lisp
@@ -300,6 +300,7 @@
(apply func-a (permute! (multiple-value-list (funcall func-b args)) perm))))
;;
+;;Optimize: pick different pivot.
(defun idx-sort-permute (seq predicate)
"
(sort-permute seq predicate)
diff --git a/src/base/standard-tensor.lisp b/src/base/standard-tensor.lisp
index 37e7cd8..8dcf4d7 100644
--- a/src/base/standard-tensor.lisp
+++ b/src/base/standard-tensor.lisp
@@ -31,6 +31,24 @@
(definline idxv (&rest contents)
(make-index-store contents))
+
+;;
+(deftype integer4 ()
+ '(signed-byte 32))
+
+(deftype integer4-array (size)
+ `(simple-array integer4-array (,size)))
+
+(make-array-allocator allocate-integer4-store 'integer4 0
+ "
+ Syntax
+ ======
+ (ALLOCATE-INTEGER4-STORE SIZE [INITIAL-ELEMENT 0])
+
+ Purpose
+ =======
+ Allocates integer4 (32-bits) storage.")
+
;;
(defclass standard-tensor ()
diff --git a/src/foreign-core/lapack.lisp b/src/foreign-core/lapack.lisp
index 5d19674..9ce7a66 100644
--- a/src/foreign-core/lapack.lisp
+++ b/src/foreign-core/lapack.lisp
@@ -307,7 +307,7 @@
The number of right hand sides, i.e., the number of columns
of the matrix B. NRHS >= 0.
- A (input) DOUBLE PRECISION array, dimension (LDA,N)
+ A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
The factors L and U from the factorization A = P*L*U
as computed by DGETRF.
diff --git a/src/old/gesv.lisp b/src/lapack/gesv.lisp
similarity index 70%
rename from src/old/gesv.lisp
rename to src/lapack/gesv.lisp
index 732bfda..e31c7b1 100644
--- a/src/old/gesv.lisp
+++ b/src/lapack/gesv.lisp
@@ -25,51 +25,10 @@
;;; ENHANCEMENTS, OR MODIFICATIONS.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; Originally written by Raymond Toy
-;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; $Id: gesv.lisp,v 1.4 2000/07/11 18:02:03 simsek Exp $
-;;;
-;;; $Log: gesv.lisp,v $
-;;; 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")
-#+:nil (use-package "BLAS")
-#+:nil (use-package "LAPACK")
-#+:nil (use-package "FORTRAN-FFI-ACCESSORS")
+(in-package #:matlisp)
-#+:nil (export '(gesv!
- gesv))
-
-
-#+:pre-allocate-workspaces
-(defvar *ipiv* (make-array *ipiv-size* :element-type '(unsigned-byte 32)))
-
-(defgeneric gesv! (a b &key ipiv)
+(defgeneric gesv! (a b)
(:documentation
"
Syntax
@@ -108,50 +67,19 @@
used in the computation has been completed,
but the factor U is exactly singular.
Solution could not be computed.
-"))
-
-(defgeneric gesv (a b)
- (:documentation
- "
- Sytnax
- ======
- (GESV a b)
-
- Purpose
- =======
- Same as GESV! except that A,B are not overwritten.
-"))
-
-(defmethod gesv! :before ((a standard-matrix) (b standard-matrix) &key ipiv)
- (let ((n-a (nrows a))
- (m-a (ncols a))
- (n-b (nrows b)))
- (if (not (= n-a m-a n-b))
- (error "dimensions of A,B given to GESV do not match"))
- (if ipiv
- (progn
- (check-type ipiv (simple-array (unsigned-byte 32) (*)))
- (if (< (length ipiv) n-a)
- (error "argument IPIV given to GESV! must dimension >= N,
-where NxN is the dimension of argument A given to GESV!"))))))
-
-
-(defmethod gesv! ((a real-matrix) (b real-matrix) &key ipiv)
-
- (let* ((n (nrows a))
- (m (ncols b))
- (ipiv #+:pre-allocate-workspaces
- (or ipiv *ipiv*)
- #-:pre-allocate-workspaces
- (or ipiv (make-array n :element-type '(unsigned-byte 32)))))
-
- (declare (type fixnum n m)
- (type (simple-array (unsigned-byte 32) (*)) ipiv))
-
- (multiple-value-bind (factors
- ipiv
- x
- info)
+")
+ (:before ((a standard-matrix) (b standard-matrix) &key ipiv)
+ (assert (= (nrows a) (ncols a) (nrows b)) nil 'tensor-dimension-mismatch)))
+
+(defmethod gesv! ((a real-matrix) (b real-matrix))
+
+ (let* ((nrc-a (nrows a))
+ (nc-b (ncols b))
+ (ipiv (make-integer4-store nrc-a)))
+ (declare (type fixnum nrc-a nc-b)
+ (type (integer4-array *) ipiv))
+
+ (multiple-value-bind (lu ipiv x info)
(dgesv n
m
(store a)
@@ -214,6 +142,20 @@ where NxN is the dimension of argument A given to GESV!"))))))
(gesv! a b :ipiv ipiv)))
+
+(defgeneric gesv (a b)
+ (:documentation
+ "
+ Sytnax
+ ======
+ (GESV a b)
+
+ Purpose
+ =======
+ Same as GESV! except that A,B are not overwritten.
+"))
+
+
(defmethod gesv :before ((a standard-matrix) (b standard-matrix))
(let ((n-a (nrows a))
(m-a (ncols a))
diff --git a/src/old/getrf.lisp b/src/lapack/getrf.lisp
similarity index 100%
rename from src/old/getrf.lisp
rename to src/lapack/getrf.lisp
diff --git a/src/old/getrs.lisp b/src/lapack/getrs.lisp
similarity index 100%
rename from src/old/getrs.lisp
rename to src/lapack/getrs.lisp
diff --git a/src/level-1/axpy.lisp b/src/level-1/axpy.lisp
index 0a3b9cc..e789d7a 100644
--- a/src/level-1/axpy.lisp
+++ b/src/level-1/axpy.lisp
@@ -212,3 +212,16 @@
(defmethod axpy ((alpha number) (x complex-tensor) (y complex-tensor))
(let ((ret (copy y)))
(axpy! alpha x ret)))
+
+(defmethod axpy ((alpha number) (x (eql nil)) (y complex-tensor))
+ (let ((ret (copy y)))
+ (axpy! alpha nil ret)))
+
+(defmethod axpy ((alpha number) (x (eql nil)) (y real-tensor))
+ (let ((ret (if (complexp alpha)
+ (copy! y (apply #'make-complex-tensor (idx->list (dimensions y))))
+ (copy y))))
+ (axpy! alpha nil ret)))
+
+(defmethod axpy ((alpha number) (x standard-tensor) (y (eql nil)))
+ (scal alpha x))
diff --git a/src/old/mminus.lisp b/src/old/mminus.lisp
deleted file mode 100644
index c769c32..0000000
--- a/src/old/mminus.lisp
+++ /dev/null
@@ -1,118 +0,0 @@
-;;; -*- 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: mminus.lisp,v 1.4 2000/07/11 18:02:03 simsek Exp $
-;;;
-;;; $Log: mminus.lisp,v $
-;;; 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")
-
-#+nil (use-package "BLAS")
-#+nil (use-package "LAPACK")
-#+nil (use-package "FORTRAN-FFI-ACCESSORS")
-
-#+nil (export '(m-
- m.-))
-
-(defgeneric m- (a b)
- (:documentation
- "
- Syntax
- ======
- (M- a b)
-
- Purpose
- =======
- Create a new matrix which is the difference of A and B.
- B may be a scalar, in which case the subtraction
- is elementwise.
-"))
-
-(defgeneric m.- (a b)
- (:documentation
- "
- Syntax
- ======
- (M- a b)
-
- Purpose
- =======
- Same as M-
-"))
-
-(defmethod m.- (a b)
- (m- a b))
-
-(defmethod m- :before ((a standard-matrix) (b standard-matrix))
- (let ((n-a (nrows a))
- (m-a (ncols a))
- (n-b (nrows b))
- (m-b (ncols b)))
- (declare (type fixnum n-a m-a n-b m-b))
-
- (unless (and (= n-a n-b)
- (= m-a m-b))
- (error "Cannot subtract a ~d x ~d matrix from a ~d x ~d matrix"
- n-b m-b
- n-a m-a))))
-
-
-(defmethod m- ((a standard-matrix) (b standard-matrix))
- (axpy -1.0d0 b a))
-
-(defmethod m- ((a number) (b standard-matrix))
- (error "cannot M- a matrix from a scalar"))
-
-(defmethod m- ((a standard-matrix) (b number))
- (m+ a (- b)))
diff --git a/src/old/mplus.lisp b/src/old/mplus.lisp
deleted file mode 100644
index bbe1229..0000000
--- a/src/old/mplus.lisp
+++ /dev/null
@@ -1,293 +0,0 @@
-;;; -*- 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.
-;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(in-package #:matlisp)
-
-(defgeneric m+ (a b)
- (:documentation
- "
- Syntax
- ======
- (M+ a b)
-
- Purpose
- =======
- 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.
-")
- (: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)
-
- Purpose
- =======
- Same as M+
-"
- (m+ a b))
-
-(defgeneric m+! (a b)
- (:documentation
- "
- Syntax
- ======
- (M+! a b)
-
- Purpose
- =======
- Desctructive version of M+:
-
- B <- A + B
-")
- (:method ((a number) (b number))
- (+ a b)))
-
-(definline m.+! (a b)
- "
- Syntax
- ======
- (M.+! a b)
-
- Purpose
- =======
- Same as M+!
-"
- (m+! a b))
-
-(defmethod m+ :before ((a standard-matrix) (b standard-matrix))
- (let ((n-a (nrows a))
- (m-a (ncols a))
- (n-b (nrows b))
- (m-b (ncols b)))
- (declare (type fixnum n-a m-a n-b m-b))
-
- (unless (and (= n-a n-b)
- (= m-a m-b))
- (error "Cannot add a ~d x ~d matrix and a ~d x ~d matrix"
- n-a m-a
- n-b m-b))))
-
-
-(defmethod m+ ((a standard-matrix) (b standard-matrix))
- (axpy 1.0d0 a b))
-
-(let ((b-array (make-array 1 :element-type 'real-matrix-element-type)))
- (defmethod m+ ((a real-matrix) (b #+(or cmu sbcl) double-float #-(or cmu sbcl) float))
- (let ((nxm (number-of-elements a))
- (result (copy a)))
- (declare (type fixnum nxm))
-
- (setf (aref b-array 0) b)
- (daxpy nxm 1.0d0 b-array 0 (store result) 1)
- result)))
-
-(defmethod m+ ((a real-matrix) (b cl:real))
- (m+ a (coerce b 'real-matrix-element-type)))
-
-(defmethod m+ ((a #+(or cmu sbcl) double-float #-(or cmu sbcl) float) (b real-matrix))
- (m+ b a))
-
-(defmethod m+ ((a cl:real) (b real-matrix))
- (m+ b (coerce a 'real-matrix-element-type)))
-
-(defmethod m+ ((a real-matrix) (b #+:cmu kernel::complex-double-float
- #+:sbcl sb-kernel::complex-double-float
- #-(or cmu sbcl) complex))
- (let* ((n (nrows a))
- (m (ncols a))
- #-(or cmu sbcl) (b (complex-coerce b))
- (result (make-complex-matrix-dim n m b)))
- (declare (type fixnum n m))
-
- (axpy! 1.0d0 a result)))
-
-#+(or :cmu :sbcl)
-(defmethod m+ ((a real-matrix) (b complex))
- (m+ a (complex-coerce b)))
-
-(defmethod m+ ((a #+:cmu kernel::complex-double-float
- #+:sbcl sb-kernel::complex-double-float
- #-(or cmu sbcl) complex) (b real-matrix))
- (m+ b a))
-
-#+(or :cmu :sbcl)
-(defmethod m+ ((a complex) (b real-matrix))
- (m+ b (complex-coerce a)))
-
-;;;
-(let ((b-array (make-array 1 :element-type 'real-matrix-element-type)))
- (defmethod m+ ((a complex-matrix) (b #+(or cmu sbcl) double-float #-(or cmu sbcl) float))
- (let ((nxm (number-of-elements a))
- (result (copy a)))
- (declare (type fixnum nxm))
-
- (setf (aref b-array 0) b)
- (daxpy nxm 1.0d0 b-array 0 (store result) 2)
- result)))
-
-(defmethod m+ ((a complex-matrix) (b cl:real))
- (m+ a (coerce b 'complex-matrix-element-type)))
-
-(defmethod m+ ((a #+(or cmu sbcl) double-float #-(or cmu sbcl) float) (b complex-matrix))
- (m+ b a))
-
-(defmethod m+ ((a cl:real) (b complex-matrix))
- (m+ b (coerce a 'complex-matrix-element-type)))
-
-(defmethod m+ ((a complex-matrix) (b #+:cmu kernel::complex-double-float
- #+:sbcl sb-kernel::complex-double-float
- #-(or cmu sbcl) complex))
- (let* ((n (nrows a))
- (m (ncols a))
- #-(or cmu sbcl) (b (complex-coerce b))
- (result (make-complex-matrix-dim n m b)))
- (declare (type fixnum n m))
-
- (axpy! 1.0d0 a result)))
-
-#+(or :cmu :sbcl)
-(defmethod m+ ((a complex-matrix) (b complex))
- (m+ a (complex-coerce b)))
-
-(defmethod m+ ((a #+:cmu kernel::complex-double-float
- #+:sbcl sb-kernel::complex-double-float
- #-(or cmu sbcl) complex) (b complex-matrix))
- (m+ b a))
-
-#+(or :cmu :sbcl)
-(defmethod m+ ((a complex) (b complex-matrix))
- (m+ b (complex-coerce a)))
-
-
-(defmethod m+! :before ((a standard-matrix) (b standard-matrix))
- (let ((n-a (nrows a))
- (m-a (ncols a))
- (n-b (nrows b))
- (m-b (ncols b)))
- (declare (type fixnum n-a m-a n-b m-b))
- (unless (and (= n-a n-b)
- (= m-a m-b))
- (error "Cannot add a ~d x ~d matrix and a ~d x ~d matrix"
- n-a m-a
- n-b m-b))))
-
-(defmethod m+! ((a standard-matrix) (b standard-matrix))
- (axpy! 1.0d0 a b))
-
-(defmethod m+! ((a complex-matrix) (b real-matrix))
- (error "cannot M+! a COMPLEX-MATRIX A and a REAL-MATRIX B,
-don't know how to coerce COMPLEX to REAL."))
-
-;;;
-(let ((b-array (make-array 1 :element-type 'real-matrix-element-type)))
- (defmethod m+! ((a real-matrix) (b #+(or cmu sbcl) double-float #-(or cmu sbcl) float))
- (let ((nxm (number-of-elements a)))
- (declare (type fixnum nxm))
-
- (setf (aref b-array 0) b)
- (daxpy nxm 1.0d0 b-array 0 (store a) 1)
- a)))
-
-(defmethod m+! ((a real-matrix) (b cl:real))
- (m+! a (coerce b 'real-matrix-element-type)))
-
-(defmethod m+! ((a #+(or cmu sbcl) double-float #-(or cmu sbcl) float) (b real-matrix))
- (m+! b a))
-
-(defmethod m+! ((a cl:real) (b real-matrix))
- (m+! b (coerce a 'real-matrix-element-type)))
-
-(defmethod m+! ((a real-matrix) (b complex))
- (error "cannon M+! a REAL-MATRIX and a COMPLEX,
-don't know how to coerce COMPLEX to REAL"))
-
-(defmethod m+! ((a complex) (b real-matrix))
- (error "cannon M+! a REAL-MATRIX and a COMPLEX,
-don't know how to coerce COMPLEX to REAL"))
-
-(let ((b-array (make-array 1 :element-type 'real-matrix-element-type)))
- (defmethod m+! ((a complex-matrix) (b #+(or cmu sbcl) double-float #-(or cmu sbcl) float))
- (let ((nxm (number-of-elements a)))
- (declare (type fixnum nxm))
-
- (setf (aref b-array 0) b)
- (daxpy nxm 1.0d0 b-array 0 (store a) 2)
- a)))
-
-(defmethod m+! ((a complex-matrix) (b cl:real))
- (m+! a (coerce b 'complex-matrix-element-type)))
-
-(defmethod m+! ((a #+(or cmu sbcl) double-float #-(or cmu sbcl) float) (b complex-matrix))
- (m+! b a))
-
-(defmethod m+! ((a cl:real) (b complex-matrix))
- (m+! b (coerce a 'complex-matrix-element-type)))
-
-#-:sbcl ;; sbcl doesn't like constant arrays
-(defconstant *complex-unity-as-array*
- (make-array 2 :element-type 'complex-matrix-element-type
- :initial-contents '(1.0d0 0.0d0)))
-
-#+:sbcl
-(defvar *complex-unity-as-array*
- (make-array 2 :element-type 'complex-matrix-element-type
- :initial-contents '(1.0d0 0.0d0)))
-
-(defmethod m+! ((a complex-matrix) (b #+:cmu kernel::complex-double-float
- #+:sbcl sb-kernel::complex-double-float
- #-(or cmu sbcl) complex))
- (let* ((nxm (number-of-elements a)))
- (declare (type fixnum nxm))
-
- #-(or cmu sbcl) (setq b (complex-coerce b))
-
- (setf (aref *1x1-complex-array* 0) (realpart b))
- (setf (aref *1x1-complex-array* 1) (imagpart b))
- (zaxpy nxm #c(1d0 0) b 0 (store a) 1)
- a))
-
-#+(or :cmu :sbcl)
-(defmethod m+! ((a complex-matrix) (b complex))
- (m+! a (complex-coerce b)))
-
-(defmethod m+! ((a #+:cmu kernel::complex-double-float
- #+:sbcl sb-kernel::complex-double-float
- #-(or cmu sbcl) complex) (b complex-matrix))
- (m+! b a))
-
-#+(or :cmu :sbcl)
-(defmethod m+! ((a complex) (b complex-matrix))
- (m+! b (complex-coerce a)))
-
diff --git a/src/sugar/mplusminus.lisp b/src/sugar/mplusminus.lisp
new file mode 100644
index 0000000..1c65dff
--- /dev/null
+++ b/src/sugar/mplusminus.lisp
@@ -0,0 +1,164 @@
+;;; -*- 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.
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(in-package #:matlisp)
+
+(defgeneric m+ (a b)
+ (:documentation
+ "
+ Syntax
+ ======
+ (M+ a b)
+
+ Purpose
+ =======
+ 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.
+")
+ (:method ((a number) (b number))
+ (+ a b))
+ (:method ((a standard-tensor) (b standard-tensor))
+ (axpy 1 a b))
+ (:method ((a number) (b standard-tensor))
+ (axpy a nil b))
+ (:method ((a standard-tensor) (b number))
+ (axpy b nil a)))
+
+(definline m.+ (a b)
+ "
+ Syntax
+ ======
+ (M.+ a b)
+
+ Purpose
+ =======
+ Same as M+
+"
+ (m+ a b))
+;;---------------------------------------------------------------;;
+
+(defgeneric m+! (a b)
+ (:documentation
+ "
+ Syntax
+ ======
+ (M+! a b)
+
+ Purpose
+ =======
+ Desctructive version of M+:
+
+ B <- A + B
+")
+ (:method ((a number) (b number))
+ (+ a b))
+ (:method ((a standard-tensor) (b standard-tensor))
+ (axpy! 1 a b))
+ (:method ((a number) (b standard-tensor))
+ (axpy! a nil b)))
+
+(definline m.+! (a b)
+ "
+ Syntax
+ ======
+ (M.+! a b)
+
+ Purpose
+ =======
+ Same as M+!
+"
+ (m+! a b))
+;;---------------------------------------------------------------;;
+
+(defgeneric m- (a b)
+ (:documentation
+ "
+ Syntax
+ ======
+ (M- a b)
+
+ Purpose
+ =======
+ Create a new matrix which is the difference of A and B.
+ B may be a scalar, in which case the subtraction
+ is elementwise.
+")
+ (:method ((a number) (b number))
+ (- a b))
+ (:method ((a standard-tensor) (b standard-tensor))
+ (axpy -1 b a))
+ (:method ((a number) (b standard-tensor))
+ (scal! -1 (axpy (- a) nil b)))
+ (:method ((a standard-tensor) (b number))
+ (axpy (- b) nil a)))
+
+(definline m.- (a b)
+ "
+ Syntax
+ ======
+ (M.- a b)
+
+ Purpose
+ =======
+ Same as M-
+"
+ (m- a b))
+;;---------------------------------------------------------------;;
+
+(defgeneric m-! (a b)
+ (:documentation
+ "
+ Syntax
+ ======
+ (M-! a b)
+
+ Purpose
+ =======
+ Desctructive version of M-:
+
+ B <- A - B
+")
+ (:method ((a number) (b number))
+ (- a b))
+ (:method ((a standard-tensor) (b standard-tensor))
+ (scal! -1 (axpy! -1 a b)))
+ (:method ((a number) (b standard-tensor))
+ (scal! -1 (axpy! (- a) nil b))))
+
+(definline m.-! (a b)
+ "
+ Syntax
+ ======
+ (M.-! a b)
+
+ Purpose
+ =======
+ Same as M-!
+"
+ (m+! a b))
+;;---------------------------------------------------------------;;
-----------------------------------------------------------------------
Summary of changes:
matlisp.asd | 12 ++-
src/base/permutation.lisp | 1 +
src/base/standard-tensor.lisp | 18 +++
src/foreign-core/lapack.lisp | 2 +-
src/{old => lapack}/gesv.lisp | 116 ++++------------
src/{old => lapack}/getrf.lisp | 0
src/{old => lapack}/getrs.lisp | 0
src/level-1/axpy.lisp | 13 ++
src/old/mminus.lisp | 118 ----------------
src/old/mplus.lisp | 293 ----------------------------------------
src/sugar/mplusminus.lisp | 164 ++++++++++++++++++++++
11 files changed, 236 insertions(+), 501 deletions(-)
rename src/{old => lapack}/gesv.lisp (70%)
rename src/{old => lapack}/getrf.lisp (100%)
rename src/{old => lapack}/getrs.lisp (100%)
delete mode 100644 src/old/mminus.lisp
delete mode 100644 src/old/mplus.lisp
create mode 100644 src/sugar/mplusminus.lisp
hooks/post-receive
--
matlisp
|
