Menu
▾
▴
matlisp-commit
|
From: Akshay S. <ak...@us...> - 2014-02-19 05:11:46
|
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 f38e6dde50fbe1552793f8146fa42734d522e9c9 (commit)
via 4ae0303bba3df2d7d9b3470181947a0056d72e1b (commit)
via 2222db6683c9dbf031cd4db8db5214efe60b6d66 (commit)
via 6c30013f4baa53a1b9fba64854c5c1e5cae44809 (commit)
via c248fe3323b34374070cb9df9a6d765a85e73b01 (commit)
via 17a8a5233aa62740a17e8049835976f7a18e3d26 (commit)
via 2e87492c26e3e9f0705efda698f6183d9c1425ea (commit)
via 4d63cc7ebed68cf20b1b4e83cbfb6b8815706a4e (commit)
via b6f729d172193ff03cf1ba88d1deb1c7634ee11f (commit)
via 1c59134bdfcda89a91ce78f8d69836fd3a2628ec (commit)
via 7cd35fab7aa468327b733ab1d5037a5e98c55e08 (commit)
via e51ecd915cbd2a9222b653d70bda556411616999 (commit)
via 983fa49410b5ff5805ef9f63776884fc72015f49 (commit)
via 673b1af27a8d2ef318dc02b9b73aa9ce2f758fcc (commit)
via ad1dd99286b8c8f0ec1323aaca6911f7f3fd4c99 (commit)
via 8a5ade0a47e01bd93e19f72fcfe9691ed00f71cf (commit)
via 57618ec426afa04b6553dec19c4c96971c98f5ad (commit)
from 7ddfe787e54e485108ff96839495e7a6f0d490c2 (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 f38e6dde50fbe1552793f8146fa42734d522e9c9
Author: Akshay Srinivasan <aks...@gm...>
Date: Tue Feb 18 21:12:52 2014 -0800
Moved all the BLAS things into one folder. Moved gemv, gemm to use define-tensor-method.
diff --git a/matlisp.asd b/matlisp.asd
index 71c0a25..719f4f8 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -136,8 +136,8 @@
(:file "symbolic-tensor")
(:file "matrix"
:depends-on ("numeric"))))
- (:module "matlisp-level-1"
- :pathname "level-1"
+ (:module "matlisp-blas"
+ :pathname "blas"
:depends-on ("matlisp-base" "matlisp-classes" "foreign-core")
:components ((:file "maker")
(:file "copy"
@@ -154,31 +154,27 @@
(:file "trans"
:depends-on ("scal" "copy"))
(:file "sum"
- :depends-on ("dot" "copy"))))
- (:module "matlisp-level-2"
- :pathname "level-2"
- :depends-on ("matlisp-base" "matlisp-classes" "foreign-core" "matlisp-level-1")
- :components ((:file "gemv")))
- (:module "matlisp-level-3"
- :pathname "level-3"
- :depends-on ("matlisp-base" "matlisp-classes" "foreign-core" "matlisp-level-1" "matlisp-level-2")
- :components ((:file "gemm")))
+ :depends-on ("dot" "copy"))
+ (:file "gemv"
+ :depends-on ("copy"))
+ (:file "gemm"
+ :depends-on ("copy"))))
(:module "matlisp-lapack"
:pathname "lapack"
- :depends-on ("matlisp-base" "matlisp-classes" "matlisp-level-1" "matlisp-level-2" "matlisp-level-3")
+ :depends-on ("matlisp-base" "matlisp-classes" "matlisp-blas")
:components ((:file "lu")
(:file "chol")
(:file "eig")
(:file "least-squares")))
(:module "matlisp-special"
:pathname "special"
- :depends-on ("matlisp-base" "matlisp-classes" "matlisp-level-1" "matlisp-level-2" "matlisp-level-3")
+ :depends-on ("matlisp-base" "matlisp-classes" "matlisp-blas")
:components ((:file "random")
(:file "map")
(:file "seq")))
(:module "matlisp-sugar"
:pathname "sugar"
- :depends-on ("matlisp-base" "matlisp-classes" "matlisp-level-1" "matlisp-level-2" "matlisp-level-3")
+ :depends-on ("matlisp-base" "matlisp-classes" "matlisp-blas")
:components (#+nil
(:file "mplusminus")
#+nil
diff --git a/src/level-1/axpy.lisp b/src/blas/axpy.lisp
similarity index 100%
rename from src/level-1/axpy.lisp
rename to src/blas/axpy.lisp
diff --git a/src/level-1/copy.lisp b/src/blas/copy.lisp
similarity index 100%
rename from src/level-1/copy.lisp
rename to src/blas/copy.lisp
diff --git a/src/level-1/dot.lisp b/src/blas/dot.lisp
similarity index 100%
rename from src/level-1/dot.lisp
rename to src/blas/dot.lisp
diff --git a/src/level-3/gemm.lisp b/src/blas/gemm.lisp
similarity index 80%
rename from src/level-3/gemm.lisp
rename to src/blas/gemm.lisp
index aadb836..960b03a 100644
--- a/src/level-3/gemm.lisp
+++ b/src/blas/gemm.lisp
@@ -117,35 +117,21 @@
(= nc-a nr-b)
(= nc-b nc-c)) nil 'tensor-dimension-mismatch))))
-(defmethod gemm! (alpha (A standard-tensor) (B standard-tensor) beta (C standard-tensor) &optional (job :nn))
- (let ((cla (class-name (class-of A)))
- (clb (class-name (class-of B)))
- (clc (class-name (class-of C))))
- (assert (and (member cla *tensor-type-leaves*)
- (member clb *tensor-type-leaves*)
- (member clc *tensor-type-leaves*))
- nil 'tensor-abstract-class :tensor-class (list cla clb clc))
- (cond
- ((ieql cla clb clc)
- (compile-and-eval
- `(defmethod gemm! (alpha (A ,cla) (B ,clb) beta (C ,clc) &optional (job :nn))
- (let ((alpha (t/coerce ,(field-type cla) alpha))
- (beta (t/coerce ,(field-type cla) beta)))
- (declare (type ,(field-type cla) alpha beta))
- (destructuring-bind (joba jobb) (split-job job)
- (declare (type character joba jobb))
- ,(recursive-append
- (when (subtypep clc 'blas-numeric-tensor)
- `(if (call-fortran? C (t/l3-lb ,clc))
- (with-columnification (,cla ((a joba) (b jobb)) (c))
- (multiple-value-bind (lda opa) (blas-matrix-compatiblep a joba)
- (multiple-value-bind (ldb opb) (blas-matrix-compatiblep b jobb)
- (t/blas-gemm! ,cla alpha A lda B ldb beta C (or (blas-matrix-compatiblep c #\N) 0) opa opb))))))
- `(t/gemm! ,cla alpha A B beta C joba jobb))))
- C))
- (gemm! alpha A B beta C job))
- (t
- (error "Don't know how to apply gemm! to classes ~a." (list cla clb clc))))))
+(define-tensor-method gemm! (alpha (A standard-tensor :input) (B standard-tensor :input) beta (C standard-tensor :output) &optional (job :nn))
+ `(let ((alpha (t/coerce ,(field-type (cl a)) alpha))
+ (beta (t/coerce ,(field-type (cl a)) beta)))
+ (declare (type ,(field-type (cl a)) alpha beta))
+ (destructuring-bind (joba jobb) (split-job job)
+ (declare (type character joba jobb))
+ ,(recursive-append
+ (when (subtypep (cl c) 'blas-numeric-tensor)
+ `(if (call-fortran? C (t/l3-lb ,(cl c)))
+ (with-columnification (,(cl a) ((a joba) (b jobb)) (c))
+ (multiple-value-bind (lda opa) (blas-matrix-compatiblep a joba)
+ (multiple-value-bind (ldb opb) (blas-matrix-compatiblep b jobb)
+ (t/blas-gemm! ,(cl a) alpha A lda B ldb beta C (or (blas-matrix-compatiblep c #\N) 0) opa opb))))))
+ `(t/gemm! ,(cl a) alpha A B beta C joba jobb))))
+ 'C)
;;---------------------------------------------------------------;;
(defgeneric gemm (alpha a b beta c &optional job)
(:documentation
diff --git a/src/level-2/gemv.lisp b/src/blas/gemv.lisp
similarity index 75%
rename from src/level-2/gemv.lisp
rename to src/blas/gemv.lisp
index c305481..e468a76 100644
--- a/src/level-2/gemv.lisp
+++ b/src/blas/gemv.lisp
@@ -93,41 +93,27 @@
(aref (the index-store-vector (dimensions A)) (if (member job '(:t :c)) 1 0))))
nil 'tensor-dimension-mismatch)))
-(defmethod gemv! (alpha (A standard-tensor) (x standard-tensor) beta (y standard-tensor) &optional (job :n))
- (let ((clx (class-name (class-of x)))
- (cly (class-name (class-of y)))
- (cla (class-name (class-of A))))
- (assert (and (member cla *tensor-type-leaves*)
- (member clx *tensor-type-leaves*)
- (member cly *tensor-type-leaves*))
- nil 'tensor-abstract-class :tensor-class (list cla clx cly))
- (cond
- ((ieql clx cly cla)
- (compile-and-eval
- `(defmethod gemv! (alpha (A ,cla) (x ,clx) beta (y ,cly) &optional (job :n))
- (let ((alpha (t/coerce ,(field-type clx) alpha))
- (beta (t/coerce ,(field-type clx) beta))
- (cjob (aref (symbol-name job) 0)))
- (declare (type ,(field-type clx) alpha beta)
- (type character cjob))
- ,(recursive-append
- (when (subtypep clx 'blas-numeric-tensor)
- `(if (call-fortran? A (t/l2-lb ,cla))
- (let ((A-copy (if (blas-matrix-compatiblep A cjob) A
- (let ((*default-stride-ordering* :col-major))
- (t/copy! (,cla ,cla) A (t/zeros ,clx (dimensions A)))))))
- (multiple-value-bind (lda op maj) (blas-matrix-compatiblep A-copy cjob)
- (declare (ignore maj))
- (t/blas-gemv! ,cla alpha A-copy lda
- x (aref (the index-store-vector (strides x)) 0)
- beta
- y (aref (the index-store-vector (strides y)) 0)
- op)))))
- `(t/gemv! ,cla alpha A x beta y cjob)))
- y))
- (gemv! alpha A x beta y job))
- (t
- (error "Don't know how to apply gemv! to classes ~a." (list cla clx cly))))))
+(define-tensor-method gemv! (alpha (A standard-tensor :input) (x standard-tensor :input) beta (y standard-tensor :output) &optional (job :n))
+ `(let ((alpha (t/coerce ,(field-type (cl x)) alpha))
+ (beta (t/coerce ,(field-type (cl x)) beta))
+ (cjob (aref (symbol-name job) 0)))
+ (declare (type ,(field-type (cl x)) alpha beta)
+ (type character cjob))
+ ,(recursive-append
+ (when (subtypep (cl x) 'blas-numeric-tensor)
+ `(if (call-fortran? A (t/l2-lb ,(cl a)))
+ (let ((A-copy (if (blas-matrix-compatiblep A cjob) A
+ (let ((*default-stride-ordering* :col-major))
+ (t/copy! (,(cl a) ,(cl a)) A (t/zeros ,(cl x) (dimensions A)))))))
+ (multiple-value-bind (lda op maj) (blas-matrix-compatiblep A-copy cjob)
+ (declare (ignore maj))
+ (t/blas-gemv! ,(cl a) alpha A-copy lda
+ x (aref (the index-store-vector (strides x)) 0)
+ beta
+ y (aref (the index-store-vector (strides y)) 0)
+ op)))))
+ `(t/gemv! ,(cl a) alpha A x beta y cjob)))
+ 'y)
;;---------------------------------------------------------------;;
(defgeneric gemv (alpha A x beta y &optional job)
(:documentation
diff --git a/src/level-1/maker.lisp b/src/blas/maker.lisp
similarity index 100%
rename from src/level-1/maker.lisp
rename to src/blas/maker.lisp
diff --git a/src/level-1/realimag.lisp b/src/blas/realimag.lisp
similarity index 100%
rename from src/level-1/realimag.lisp
rename to src/blas/realimag.lisp
diff --git a/src/level-1/scal.lisp b/src/blas/scal.lisp
similarity index 100%
rename from src/level-1/scal.lisp
rename to src/blas/scal.lisp
diff --git a/src/level-1/sum.lisp b/src/blas/sum.lisp
similarity index 100%
rename from src/level-1/sum.lisp
rename to src/blas/sum.lisp
diff --git a/src/level-1/swap.lisp b/src/blas/swap.lisp
similarity index 100%
rename from src/level-1/swap.lisp
rename to src/blas/swap.lisp
diff --git a/src/level-1/trans.lisp b/src/blas/trans.lisp
similarity index 100%
rename from src/level-1/trans.lisp
rename to src/blas/trans.lisp
diff --git a/src/classes/numeric.lisp b/src/classes/numeric.lisp
index 018fdc4..2f5c97a 100644
--- a/src/classes/numeric.lisp
+++ b/src/classes/numeric.lisp
@@ -100,7 +100,7 @@
(imagpart (imagpart element)))
(format stream (if (zerop imagpart)
"~11,5,,,,,'Eg"
- "#C(~0,4,,,,,'Ee, ~0,4,,,,,'Ee)")
+ "#C(~11,5,,,,,'Eg, ~11,5,,,,,'Eg)")
realpart imagpart)))
;;
(defleaf complex-tensor (complex-numeric-tensor) ())
diff --git a/src/foreign-core/blas.lisp b/src/foreign-core/blas.lisp
index 2e1f57c..202f555 100644
--- a/src/foreign-core/blas.lisp
+++ b/src/foreign-core/blas.lisp
@@ -28,6 +28,24 @@
(in-package #:matlisp-blas)
+;; (defparameter *f77-floats* '(:single-float :double-float :complex-single-float :complex-double-float))
+
+;; (defmacro generate-bindings (fname)
+;; (let ((defs (parse-fortran-file fname)))
+;; `(eval-every
+;; ,@(mapcar #'(lambda (x)
+;; `(def-fortran-routine ,(first x) ,(second x)
+;; ,@(mapcar #'(lambda (y)
+;; (let ((type (cadr y))
+;; (var (car y)))
+;; (if (and (consp type) (eql (first type) '*) (member (second type) *f77-floats*))
+;; (list var (append type (list :inc (intern (string+ "HEAD-" (symbol-name var))))))
+;; y)))
+;; (third x))))
+;; defs))))
+
+;; (generate-bindings "/home/neptune/devel/matlisp/blas/blas.f")
+
(def-fortran-routine daxpy :void
"
Syntax
commit 4ae0303bba3df2d7d9b3470181947a0056d72e1b
Author: Akshay Srinivasan <aks...@gm...>
Date: Tue Feb 18 20:51:23 2014 -0800
Moved L1 functions to use define-tensor-method.
diff --git a/src/base/tensor-template.lisp b/src/base/tensor-template.lisp
index 7c22736..ad93e54 100644
--- a/src/base/tensor-template.lisp
+++ b/src/base/tensor-template.lisp
@@ -147,11 +147,30 @@
(lst (assoc ',(mapcar #'(lambda (x) (if (consp x) (cadr x) t)) args) (cdr (gethash ',name *generated-methods*)) :test #'list-eq)))
(assert lst nil "Method table missing from *generated-methods* !")
(setf (cdr lst) (list* method (cdr lst))))
- (,name ,@(mapcar #'(lambda (x) (if (consp x) (car x) x)) args)))
+ (,name ,@(mapcar #'(lambda (x) (if (consp x) (car x) x)) (remove-if #'(lambda (x) (and (not (consp x)) (char= (aref (symbol-name x) 0) #\&))) args))))
((and (every #'(lambda (,x) (eql ,x (car ,oclasses))) ,oclasses)
(or (null ,oclasses) (coerceable? (cclass-max ,iclasses) (car ,oclasses))))
(let* ((clm (or (car ,oclasses) (cclass-max ,iclasses)))
,@(mapcar #'(lambda (x) `(,x (lazy-coerce ,x clm))) inputs))
- (,name ,@(mapcar #'(lambda (x) (if (consp x) (car x) x)) args))))
+ (,name ,@(mapcar #'(lambda (x) (if (consp x) (car x) x)) (remove-if #'(lambda (x) (and (not (consp x)) (char= (aref (symbol-name x) 0) #\&))) args)))))
(t
(error "Don't know how to apply ~a to classes ~a, ~a." ',name ,iclasses ,oclasses)))))))))
+
+
+;;
+
+;; (defgeneric testg (a))
+;; (define-tensor-method testg ((x standard-tensor :output))
+;; `(t/copy! (t ,(cl x)) 1 x)
+;; 'x)
+
+;; (defgeneric axpy-test (alpha x y))
+
+;; (define-tensor-method axpy-test (alpha (x standard-tensor :input) (y standard-tensor :output))
+;; `(let ((alpha (t/coerce ,(field-type (cl x)) alpha)))
+;; (declare (type ,(field-type (cl x)) alpha))
+;; ,(recursive-append
+;; (when (subtypep (cl x) 'blas-numeric-tensor)
+;; `(if-let (strd (and (call-fortran? x (t/l1-lb ,(cl x))) (blas-copyablep x y)))
+;; (t/blas-axpy! ,(cl x) alpha x (first strd) y (second strd))))
+;; `(t/axpy! ,(cl x) alpha x y))))
diff --git a/src/level-1/axpy.lisp b/src/level-1/axpy.lisp
index ee782f7..2e28522 100644
--- a/src/level-1/axpy.lisp
+++ b/src/level-1/axpy.lisp
@@ -104,62 +104,25 @@
(assert (lvec-eq (dimensions x) (dimensions y) #'=) nil
'tensor-dimension-mismatch)))
-;;
-
-;; (defgeneric testg (a))
-;; (define-tensor-method testg ((x standard-tensor :output))
-;; `(t/copy! (t ,(cl x)) 1 x)
-;; 'x)
-
-;; (defgeneric axpy-test (alpha x y))
-
-;; (define-tensor-method axpy-test (alpha (x standard-tensor :input) (y standard-tensor :output))
-;; `(let ((alpha (t/coerce ,(field-type (cl x)) alpha)))
-;; (declare (type ,(field-type (cl x)) alpha))
-;; ,(recursive-append
-;; (when (subtypep (cl x) 'blas-numeric-tensor)
-;; `(if-let (strd (and (call-fortran? x (t/l1-lb ,(cl x))) (blas-copyablep x y)))
-;; (t/blas-axpy! ,(cl x) alpha x (first strd) y (second strd))))
-;; `(t/axpy! ,(cl x) alpha x y))))
-
-(defmethod axpy! (alpha (x standard-tensor) (y standard-tensor))
- (let ((clx (class-name (class-of x)))
- (cly (class-name (class-of y))))
- (assert (and (member clx *tensor-type-leaves*)
- (member cly *tensor-type-leaves*))
- nil 'tensor-abstract-class :tensor-class (list clx cly))
- (cond
- ((eq clx cly)
- (compile-and-eval
- `(defmethod axpy! ((alpha t) (x ,clx) (y ,cly))
- (let ((alpha (t/coerce ,(field-type clx) alpha)))
- (declare (type ,(field-type clx) alpha))
- ,(recursive-append
- (when (subtypep clx 'blas-numeric-tensor)
- `(if-let (strd (and (call-fortran? x (t/l1-lb ,clx)) (blas-copyablep x y)))
- (t/blas-axpy! ,clx alpha x (first strd) y (second strd))))
- `(t/axpy! ,clx alpha x y))
- y)))
- (axpy! alpha x y))
- (t
- (error "Don't know how to apply axpy! to classes ~a, ~a." clx cly)))))
-
-(defmethod axpy! (alpha (x (eql nil)) (y standard-tensor))
- (let ((cly (class-name (class-of y))))
- (assert (member cly *tensor-type-leaves*)
- nil 'tensor-abstract-class :tensor-class cly)
- (compile-and-eval
- `(defmethod axpy! ((alpha t) (x (eql nil)) (y ,cly))
- (let ((alpha (t/coerce ,(field-type cly) alpha)))
- (declare (type ,(field-type cly) alpha))
- ,(recursive-append
- (when (subtypep cly 'blas-numeric-tensor)
- `(if-let (strd (and (call-fortran? y (t/l1-lb ,cly)) (consecutive-storep y)))
- (t/blas-axpy! ,cly alpha nil nil y strd)))
- `(t/axpy! ,cly alpha nil y))
- y)))
- (axpy! alpha nil y)))
-
+(define-tensor-method axpy! (alpha (x standard-tensor :input) (y standard-tensor :output))
+ `(let ((alpha (t/coerce ,(field-type (cl x)) alpha)))
+ (declare (type ,(field-type (cl x)) alpha))
+ ,(recursive-append
+ (when (subtypep (cl x) 'blas-numeric-tensor)
+ `(if-let (strd (and (call-fortran? x (t/l1-lb ,(cl x))) (blas-copyablep x y)))
+ (t/blas-axpy! ,(cl x) alpha x (first strd) y (second strd))))
+ `(t/axpy! ,(cl x) alpha x y))
+ y))
+
+(define-tensor-method axpy! (alpha (x (eql nil)) (y standard-tensor :output))
+ `(let ((alpha (t/coerce ,(field-type (cl y)) alpha)))
+ (declare (type ,(field-type (cl y)) alpha))
+ ,(recursive-append
+ (when (subtypep (cl y) 'blas-numeric-tensor)
+ `(if-let (strd (and (call-fortran? y (t/l1-lb ,(cl y))) (consecutive-storep y)))
+ (t/blas-axpy! ,(cl y) alpha nil nil y strd)))
+ `(t/axpy! ,(cl y) alpha nil y))
+ y))
;;
(defgeneric axpy (alpha x y)
(:documentation
@@ -186,5 +149,7 @@
(axpy! alpha x (copy y))))
(defmethod axpy (alpha (x standard-tensor) (y (eql nil)))
- (let ((tmp (zeros (dimensions x) (class-of x))))
- (axpy! alpha x tmp)))
+ (axpy! alpha x (zeros (dimensions x) (class-of x))))
+
+(defmethod axpy ((alpha complex) (x real-numeric-tensor) (y (eql nil)))
+ (axpy! alpha x (zeros (dimensions x) 'complex-tensor)))
diff --git a/src/level-1/dot.lisp b/src/level-1/dot.lisp
index f3d136a..9de26de 100644
--- a/src/level-1/dot.lisp
+++ b/src/level-1/dot.lisp
@@ -117,46 +117,28 @@
(* (conjugate x) y)
(* x y)))
-(defmethod dot ((x standard-tensor) (y standard-tensor) &optional (conjugate-p t))
- (let ((clx (class-name (class-of x)))
- (cly (class-name (class-of y))))
- (assert (and (member clx *tensor-type-leaves*)
- (member cly *tensor-type-leaves*))
- nil 'tensor-abstract-class :tensor-class (list clx cly))
- (cond
- ((eq clx cly)
- (compile-and-eval
- `(defmethod dot ((x ,clx) (y ,cly) &optional (conjugate-p t))
- ,(recursive-append
- (when (subtypep clx 'blas-numeric-tensor)
- `(if (call-fortran? x (t/l1-lb ,clx))
- (if conjugate-p
- (t/blas-dot ,clx x y t)
- (t/blas-dot ,clx x y nil))))
- `(if conjugate-p
- ;;Please do your checks before coming here.
- (t/dot ,clx x y t)
- (t/dot ,clx x y nil)))))
- (dot x y conjugate-p))
- (t
- (error "Don't know how to compute the dot product of ~a , ~a." clx cly)))))
+(define-tensor-method dot ((x standard-tensor :input) (y standard-tensor :input) &optional (conjugate-p t))
+ (recursive-append
+ (when (subtypep (cl x) 'blas-numeric-tensor)
+ `(if (call-fortran? x (t/l1-lb ,(cl x)))
+ (if conjugate-p
+ (t/blas-dot ,(cl x) x y t)
+ (t/blas-dot ,(cl x) x y nil))))
+ `(if conjugate-p
+ ;;Please do your checks before coming here.
+ (t/dot ,(cl x) x y t)
+ (t/dot ,(cl x) x y nil))))
-(defmethod dot ((x standard-tensor) (y t) &optional (conjugate-p t))
- (let ((clx (class-name (class-of x))))
- (assert (member clx *tensor-type-leaves*)
- nil 'tensor-abstract-class :tensor-class (list clx))
- (compile-and-eval
- `(defmethod dot ((x ,clx) (y t) &optional (conjugate-p t))
- (let ((y (t/coerce ,(field-type clx) y)))
- (declare (type ,(field-type clx) y))
- ,(recursive-append
- (when (subtypep clx 'blas-numeric-tensor)
- `(if (call-fortran? x (t/l1-lb ,clx))
- (if conjugate-p
- (t/blas-dot ,clx x y t t)
- (t/blas-dot ,clx x y nil t))))
- `(if conjugate-p
- ;;Please do your checks before coming here.
- (t/dot ,clx x y t t)
- (t/dot ,clx x y nil t))))))
- (dot x y conjugate-p)))
+(define-tensor-method dot ((x standard-tensor :input) (y t) &optional (conjugate-p t))
+ `(let ((y (t/coerce ,(field-type (cl x)) y)))
+ (declare (type ,(field-type (cl x)) y))
+ ,(recursive-append
+ (when (subtypep (cl x) 'blas-numeric-tensor)
+ `(if (call-fortran? x (t/l1-lb ,(cl x)))
+ (if conjugate-p
+ (t/blas-dot ,(cl x) x y t t)
+ (t/blas-dot ,(cl x) x y nil t))))
+ `(if conjugate-p
+ ;;Please do your checks before coming here.
+ (t/dot ,(cl x) x y t t)
+ (t/dot ,(cl x) x y nil t)))))
diff --git a/src/level-1/realimag.lisp b/src/level-1/realimag.lisp
index 498f93d..c7a7a67 100644
--- a/src/level-1/realimag.lisp
+++ b/src/level-1/realimag.lisp
@@ -42,14 +42,14 @@
If TENSOR is a scalar, returns its real part.
"
(etypecase tensor
- (real-tensor tensor)
- (complex-tensor (let ((*check-after-initializing?* nil))
- (make-instance 'real-tensor
- :parent-tensor tensor :store (store tensor)
- :dimensions (dimensions tensor)
- :strides (map 'index-store-vector #'(lambda (x) (* 2 x)) (the index-store-vector (strides tensor)))
- :head (the index-type (* 2 (head tensor))))))
- (number (realpart tensor))))
+ ((or real-tensor sreal-tensor) tensor)
+ ((or complex-tensor scomplex-tensor) (let ((*check-after-initializing?* nil))
+ (make-instance (if (typep tensor 'complex-tensor) 'real-tensor 'sreal-tensor)
+ :parent-tensor tensor :store (store tensor)
+ :dimensions (dimensions tensor)
+ :strides (map 'index-store-vector #'(lambda (x) (* 2 x)) (the index-store-vector (strides tensor)))
+ :head (the index-type (* 2 (head tensor))))))
+ (number (cl:realpart tensor))))
(definline tensor-imagpart~ (tensor)
"
@@ -65,13 +65,13 @@
If TENSOR is a scalar, returns its real part.
"
(etypecase tensor
- (real-tensor tensor)
- (complex-tensor (let ((*check-after-initializing?* nil))
- (make-instance 'real-tensor
- :parent-tensor tensor :store (store tensor)
- :dimensions (dimensions tensor)
- :strides (map 'index-store-vector #'(lambda (x) (* 2 x)) (the index-store-vector (strides tensor)))
- :head (the index-type (1+ (* 2 (head tensor)))))))
+ ((or real-tensor sreal-tensor) tensor)
+ ((or complex-tensor scomplex-tensor) (let ((*check-after-initializing?* nil))
+ (make-instance (if (typep tensor 'complex-tensor) 'real-tensor 'sreal-tensor)
+ :parent-tensor tensor :store (store tensor)
+ :dimensions (dimensions tensor)
+ :strides (map 'index-store-vector #'(lambda (x) (* 2 x)) (the index-store-vector (strides tensor)))
+ :head (the index-type (1+ (* 2 (head tensor)))))))
(number (realpart tensor))))
(definline tensor-realpart (tensor)
diff --git a/src/level-1/scal.lisp b/src/level-1/scal.lisp
index eb89d74..5ef3288 100644
--- a/src/level-1/scal.lisp
+++ b/src/level-1/scal.lisp
@@ -93,97 +93,24 @@
(assert (very-quickly (lvec-eq (the index-store-vector (dimensions x)) (the index-store-vector (dimensions y)) #'=)) nil
'tensor-dimension-mismatch)))
-(defmethod scal! ((x standard-tensor) (y standard-tensor))
- (let ((clx (class-name (class-of x)))
- (cly (class-name (class-of y))))
- (assert (and (member clx *tensor-type-leaves*)
- (member cly *tensor-type-leaves*))
- nil 'tensor-abstract-class :tensor-class (list clx cly))
- (cond
- ((eq clx cly)
- (compile-and-eval
- `(defmethod scal! ((x ,clx) (y ,cly))
- ,(recursive-append
- (when (subtypep clx 'blas-numeric-tensor)
- `(if-let (strd (and (call-fortran? x (t/l1-lb ,clx)) (blas-copyablep x y)))
- (t/blas-scdi! ,clx x (first strd) y (second strd) t)))
- `(t/scdi! ,clx x y :scal? t :numx? nil))
- y))
- (scal! x y))
- (t
- (error "Don't know how to apply scal! to classes ~a, ~a." clx cly)))))
-
-(defmethod scal! ((x t) (y standard-tensor))
- (let ((cly (class-name (class-of y))))
- (assert (member cly *tensor-type-leaves*)
- nil 'tensor-abstract-class :tensor-class cly)
- (compile-and-eval
- `(defmethod scal! ((x t) (y ,cly))
- (let ((x (t/coerce ,(field-type cly) x)))
- (declare (type ,(field-type cly) x))
- ,(recursive-append
- (when (subtypep cly 'blas-numeric-tensor)
- `(if-let (strd (and (call-fortran? y (t/l1-lb ,cly)) (consecutive-storep y)))
- (t/blas-scdi! ,cly x nil y strd t)))
- `(t/scdi! ,cly x y :scal? t :numx? t))
- y)))
- (scal! x y)))
-
-;;These should've auto-generated.
-(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 (very-quickly (lvec-eq (the index-store-vector (dimensions x)) (the index-store-vector (dimensions y)) #'=)) nil
- 'tensor-dimension-mismatch)))
-
-(defmethod div! ((x standard-tensor) (y standard-tensor))
- (let ((clx (class-name (class-of x)))
- (cly (class-name (class-of y))))
- (assert (and (member clx *tensor-type-leaves*)
- (member cly *tensor-type-leaves*))
- nil 'tensor-abstract-class :tensor-class (list clx cly))
- (cond
- ((eq clx cly)
- (compile-and-eval
- `(defmethod div! ((x ,clx) (y ,cly))
- ,(recursive-append
- (when (subtypep clx 'blas-numeric-tensor)
- `(if-let (strd (and (call-fortran? x (t/l1-lb ,clx)) (blas-copyablep x y)))
- (t/blas-scdi! ,clx x (first strd) y (second strd) nil)))
- `(t/scdi! ,clx x y :scal? nil :numx? nil))
- y))
- (div! x y))
- (t
- (error "Don't know how to apply div! to classes ~a, ~a." clx cly)))))
-
-(defmethod div! ((x t) (y standard-tensor))
- (let ((cly (class-name (class-of y))))
- (assert (member cly *tensor-type-leaves*)
- nil 'tensor-abstract-class :tensor-class cly)
- (compile-and-eval
- `(defmethod div! ((x t) (y ,cly))
- (let ((x (t/coerce ,(field-type cly) x)))
- (declare (type ,(field-type cly) x))
- ,(recursive-append
- (when (subtypep cly 'blas-numeric-tensor)
- `(if-let (strd (and (call-fortran? y (t/l1-lb ,cly)) (consecutive-storep y)))
- (t/blas-scdi! ,cly x nil y strd nil)))
- `(t/scdi! ,cly x y :scal? nil :numx? t))
- y)))
- (div! x y)))
+(define-tensor-method scal! ((x standard-tensor :input) (y standard-tensor :output))
+ (recursive-append
+ (when (subtypep (cl x) 'blas-numeric-tensor)
+ `(if-let (strd (and (call-fortran? x (t/l1-lb ,(cl x))) (blas-copyablep x y)))
+ (t/blas-scdi! ,(cl x) x (first strd) y (second strd) t)))
+ `(t/scdi! ,(cl x) x y :scal? t :numx? nil))
+ 'y)
+
+(define-tensor-method scal! ((x t) (y standard-tensor :output))
+ `(let ((x (t/coerce ,(field-type (cl y)) x)))
+ (declare (type ,(field-type (cl y)) x))
+ ,(recursive-append
+ (when (subtypep (cl y) 'blas-numeric-tensor)
+ `(if-let (strd (and (call-fortran? y (t/l1-lb ,(cl y))) (consecutive-storep y)))
+ (t/blas-scdi! ,(cl y) x nil y strd t)))
+ `(t/scdi! ,(cl y) x y :scal? t :numx? t))
+ y))
-;;
(defgeneric scal (alpha x)
(:documentation
"
@@ -204,7 +131,44 @@
(scal! alpha (copy x)))
;;TODO: There is an issue here when x is not coerceable into the tensor class of alpha
(:method ((alpha standard-tensor) (x t))
- (scal! alpha (copy! x (zeros (dimensions alpha) (class-of alpha))))))
+ ;;We assume commutation of course.
+ (scal! x (copy alpha))))
+
+;;These should've been auto-generated.
+(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 (very-quickly (lvec-eq (the index-store-vector (dimensions x)) (the index-store-vector (dimensions y)) #'=)) nil
+ 'tensor-dimension-mismatch)))
+
+(define-tensor-method div! ((x standard-tensor :input) (y standard-tensor :output))
+ (recursive-append
+ (when (subtypep (cl x) 'blas-numeric-tensor)
+ `(if-let (strd (and (call-fortran? x (t/l1-lb ,(cl x))) (blas-copyablep x y)))
+ (t/blas-scdi! ,(cl x) x (first strd) y (second strd) nil)))
+ `(t/scdi! ,(cl x) x y :scal? nil :numx? nil))
+ 'y)
+
+(define-tensor-method div! ((x t) (y standard-tensor :output))
+ `(let ((x (t/coerce ,(field-type (cl y)) x)))
+ (declare (type ,(field-type (cl y)) x))
+ ,(recursive-append
+ (when (subtypep (cl y) 'blas-numeric-tensor)
+ `(if-let (strd (and (call-fortran? y (t/l1-lb ,(cl y))) (consecutive-storep y)))
+ (t/blas-scdi! ,(cl y) x nil y strd nil)))
+ `(t/scdi! ,(cl y) x y :scal? nil :numx? t))
+ y))
(defgeneric div (x y)
(:documentation "
diff --git a/src/level-1/sum.lisp b/src/level-1/sum.lisp
index 7da2868..9e08752 100644
--- a/src/level-1/sum.lisp
+++ b/src/level-1/sum.lisp
@@ -60,4 +60,3 @@
(declare (ignore axis))
(t/sum ,clx x nil))))
(sum! x y axis)))
-
diff --git a/src/utilities/string.lisp b/src/utilities/string.lisp
index aede8fb..3cb393a 100644
--- a/src/utilities/string.lisp
+++ b/src/utilities/string.lisp
@@ -30,7 +30,8 @@ returning two values: the string and the number of bytes read."
(sb-posix:close fd))
(values data fsize)))
- (definline split-seq (test seq &key max-cuts)
+ (declaim (inline split-seq))
+ (defun split-seq (test seq &key max-cuts)
"Split a sequence, wherever the given character occurs."
(let ((split-list nil) (split-count 0) (deletes nil))
(labels ((left-split (prev i)
commit 22...
[truncated message content] |
Thanks for helping keep SourceForge clean.
X