Menu
▾
▴
matlisp-commit
|
From: Akshay S. <ak...@us...> - 2013-06-25 09:07:30
|
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, classy has been updated
via 8273423d3f82d599972086c6263975bfebe6c3a2 (commit)
via d7210a4b81356e32907afde8bcd13d4cbf97dd00 (commit)
via 1407d41f3f3150a905e8cf33e07db5042651f8ae (commit)
via 4248b0bfbfb4fda8e99fee6edad8383f2afcf606 (commit)
via ecbc68d2926eb4dc1299401beb741e3551a3941d (commit)
from 50fcc688d2f72e751722b74e994808ad90f4c1ce (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 8273423d3f82d599972086c6263975bfebe6c3a2
Author: Akshay Srinivasan <aks...@gm...>
Date: Tue Jun 25 02:05:01 2013 -0700
Tweaked the templates. Migrated axpy.
diff --git a/matlisp.asd b/matlisp.asd
index 832ab71..4962725 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -139,16 +139,15 @@
:depends-on ("maker"))
(:file "dot"
:depends-on ("maker"))
- (:file "swap")
+ (:file "swap")
+ (:file "axpy"
+ :depends-on ("maker" "copy"))
#+nil
- (
-
+ (
(:file "realimag"
:depends-on ("copy"))
(:file "scal"
:depends-on ("copy" "tensor-maker" "realimag"))
- (:file "axpy"
- :depends-on ("copy" "scal"))
(:file "trans"
:depends-on ("scal" "copy")))))
diff --git a/src/base/print.lisp b/src/base/print.lisp
index 0d76da4..d058298 100644
--- a/src/base/print.lisp
+++ b/src/base/print.lisp
@@ -105,7 +105,7 @@ of a matrix (default 0)
(defmethod print-object ((tensor standard-tensor) stream)
(print-unreadable-object (tensor stream :type t)
- (if (slot-boundp tensor 'parent-tensor)
+ (if (slot-value tensor 'parent-tensor)
(format stream "~A~,4T:DISPLACED~%" (dimensions tensor))
(format stream "~A~%" (dimensions tensor)))
(print-tensor tensor stream)))
diff --git a/src/base/standard-tensor.lisp b/src/base/standard-tensor.lisp
index 0544757..fb762a3 100644
--- a/src/base/standard-tensor.lisp
+++ b/src/base/standard-tensor.lisp
@@ -48,7 +48,7 @@
((dimensions :reader dimensions :initarg :dimensions :type index-store-vector
:documentation "Dimensions of the vector spaces in which the tensor's arguments reside.")
;;
- (parent-tensor :reader parent-tensor :initarg :parent-tensor :type standard-tensor
+ (parent-tensor :reader parent-tensor :initform nil :initarg :parent-tensor :type standard-tensor
:documentation "If the tensor is a view of another tensor, then this slot is bound.")
;;
(head :initarg :head :initform 0 :reader head :type index-type
@@ -81,6 +81,11 @@
tensor, for example #.(make-tensors ...)"
(make-load-form-saving-slots tensor :environment env))
+;;
+(definline coerce-tensor (x cly)
+ (declare (type standard-tensor x))
+ (copy! x (zeros (the index-store-vector (dimensions x)) cly)))
+
;;These should ideally be memoised (or not)
(definline rank (tensor)
(declare (type standard-tensor tensor))
@@ -417,9 +422,10 @@
(incf nhd (the index-type (* start (aref stds i)))))))
:finally (return
(if (= nrank 0) (store-ref tensor nhd)
- (make-instance (class-of tensor)
- :head nhd
- :dimensions (prune-index-vector! ndims nrank)
- :strides (prune-index-vector! nstds nrank)
- :store (store tensor)
- :parent-tensor tensor)))))))
+ (let ((*check-after-initializing?* nil))
+ (make-instance (class-of tensor)
+ :head nhd
+ :dimensions (prune-index-vector! ndims nrank)
+ :strides (prune-index-vector! nstds nrank)
+ :store (store tensor)
+ :parent-tensor tensor))))))))
diff --git a/src/level-1/axpy.lisp b/src/level-1/axpy.lisp
index a604af8..dea371b 100644
--- a/src/level-1/axpy.lisp
+++ b/src/level-1/axpy.lisp
@@ -32,76 +32,53 @@
'daxpy)
(deft/method t/blas-axpy-func (sym complex-tensor) ()
'zaxpy)
-;;
-
-(deft/generic (t/blas-axpy! #'subtypep) sym (sz a x st-x y st-y))
-(deft/method t/blas-axpy! (sym blas-numeric-tensor) (sz a x st-x y st-y)
- (using-gensyms (decl (x y))
- `(let (,@decl)
- (declare (type ,sym ,x ,y))
- (,(macroexpand-1 `(t/blas-axpy-func ,sym))
- (the index-type ,sz)
- (the ,(field-type sym) ,a)
- (the ,(store-type sym) (store ,x)) (the index-type ,st-x)
- (the ,(store-type sym) (store ,y)) (the index-type ,st-y)
- (head ,x) (head ,y))
- ,y)))
-
-(deft/generic (t/blas-apy! #'subtypep) sym (sz a y st-y))
-(deft/method t/blas-apy! (sym blas-numeric-tensor) (sz a y st-y)
- (using-gensyms (decl (a y))
- `(let (,@decl)
- (declare (type ,sym ,y)
- (type ,(field-type sym) ,a))
- (let ((sto-a (t/store-allocator ,sym 1)))
- (declare (type ,(store-type sym) sto-a))
- (t/store-set ,sym ,a sto-a 0)
+;;
+(deft/generic (t/blas-axpy! #'subtypep) sym (a x st-x y st-y))
+(deft/method t/blas-axpy! (sym blas-numeric-tensor) (a x st-x y st-y)
+ (let ((apy? (null x)))
+ (using-gensyms (decl (a x y))
+ `(let (,@decl)
+ (declare (type ,sym ,@(unless apy? `(,x)) ,y)
+ ,@(when apy? `((ignore ,x))))
+ (let ((sto-x ,(if apy? `(t/store-allocator ,sym 1) `(store ,x)))
+ (st-x ,(if apy? 0 st-x)))
+ (declare (type ,(store-type sym) sto-x)
+ (type index-type st-x))
+ ,@(when apy?
+ `((t/store-set real-tensor (t/fid* ,(field-type sym)) sto-x 0)))
(,(macroexpand-1 `(t/blas-axpy-func ,sym))
- (the index-type ,sz)
- (t/fid* ,(field-type sym))
- (the ,(store-type sym) sto-a) 0
+ (the index-type (size ,y))
+ (the ,(field-type sym) ,a)
+ sto-x st-x
(the ,(store-type sym) (store ,y)) (the index-type ,st-y)
- 0 (head ,y)))
- ,y)))
+ ,(if apy? 0 `(head ,x)) (head ,y))
+ ,y)))))
(deft/generic (t/axpy! #'subtypep) sym (a x y))
(deft/method t/axpy! (sym standard-tensor) (a x y)
- (using-gensyms (decl (a x y))
- `(let (,@decl)
- (declare (type ,sym ,x ,y)
- (type ,(field-type sym) ,a))
- (let ((sto-x (store ,x))
+ (let ((apy? (null x)))
+ (using-gensyms (decl (a x y))
+ `(let (,@decl)
+ (declare (type ,sym ,@(unless apy? `(,x)) ,y)
+ (type ,(field-type sym) ,a)
+ ,@(when apy? `((ignore ,x))))
+ (let (,@(unless apy? `((sto-x (store ,x))))
(sto-y (store ,y)))
- (declare (type ,(store-type sym) sto-x sto-y))
- (mod-dotimes (idx (dimensions ,x))
- :with (linear-sums
- (of-x (strides ,x) (head ,x))
- (of-y (strides ,y) (head ,y)))
- :do (t/store-set ,sym (t/f+ ,(field-type sym)
- (t/f* ,(field-type sym)
- ,a (t/store-ref ,sym sto-x of-x))
- (t/store-ref ,sym sto-y of-y))
- sto-y of-y)))
- ,y)))
-
-(deft/generic (t/apy! #'subtypep) sym (a y))
-(deft/method t/apy! (sym standard-tensor) (a y)
- (using-gensyms (decl (a y))
- `(let (,@decl)
- (declare (type ,sym ,y)
- (type ,(field-type sym) ,a))
- (let ((sto-y (store ,y)))
- (declare (type ,(store-type sym) sto-y))
- (mod-dotimes (idx (dimensions ,y))
- :with (linear-sums
- (of-y (strides ,y) (head ,y)))
- :do (t/store-set ,sym (t/f+ ,(field-type sym)
- ,a
- (t/store-ref ,sym sto-y of-y))
- sto-y of-y)))
- ,y)))
+ (declare (type ,(store-type sym) ,@(unless apy? `(sto-x)) sto-y))
+ (very-quickly
+ (mod-dotimes (idx (dimensions ,y))
+ :with (linear-sums
+ ,@(unless apy? `((of-x (strides ,x) (head ,x))))
+ (of-y (strides ,y) (head ,y)))
+ :do (t/store-set ,sym (t/f+ ,(field-type sym)
+ ,@(if apy?
+ `(,a)
+ `((t/f* ,(field-type sym)
+ ,a (t/store-ref ,sym sto-x of-x))))
+ (t/store-ref ,sym sto-y of-y))
+ sto-y of-y)))
+ ,y)))))
;;---------------------------------------------------------------;;
-
(defgeneric axpy! (alpha x y)
(:documentation
"
@@ -122,35 +99,47 @@
")
(:method :before ((alpha number) (x standard-tensor) (y standard-tensor))
(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)))
-
-(defmethod axpy! ((alpha number) (x (eql nil)) (y real-tensor))
- (real-typed-num-axpy! (coerce-real alpha) y))
-
-(defmethod axpy! ((alpha number) (x (eql nil)) (y complex-tensor))
- (complex-typed-num-axpy! (coerce-complex alpha) y))
-
-(defmethod axpy! ((alpha number) (x real-tensor) (y real-tensor))
- (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
- (cl:real (real-typed-axpy! (coerce-real alpha) x tmp))
- (cl:complex
- (real-typed-axpy! (coerce-real (realpart alpha)) x tmp)
- ;;Move tensor to the imagpart.
- (incf (head tmp))
- (real-typed-axpy! (coerce-real (realpart alpha)) x tmp))))
- y)
-
-(defmethod axpy! ((alpha number) (x complex-tensor) (y complex-tensor))
- (complex-typed-axpy! (coerce-complex alpha) x y))
+ 'tensor-dimension-mismatch)))
+
+(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))
+ ((coerceable? clx cly)
+ (axpy! alpha (coerce-tensor x cly) 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)))
;;
(defgeneric axpy (alpha x y)
@@ -174,37 +163,5 @@
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))))
-
-(defmethod axpy ((alpha number) (x real-tensor) (y real-tensor))
- (let ((ret (if (complexp alpha)
- (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 (lvec->list (dimensions y))))))
- (axpy! alpha y ret)))
-
-(defmethod axpy ((alpha number) (x real-tensor) (y complex-tensor))
- (let ((ret (copy y)))
- (axpy! alpha x ret)))
-
-(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 (lvec->list (dimensions y))))
- (copy y))))
- (axpy! alpha nil ret)))
-
-(defmethod axpy ((alpha number) (x standard-tensor) (y (eql nil)))
- (scal alpha x))
+ (:method (alpha x (y standard-tensor))
+ (axpy! alpha x (copy y))))
diff --git a/src/level-1/copy.lisp b/src/level-1/copy.lisp
index 0800470..257bd3e 100644
--- a/src/level-1/copy.lisp
+++ b/src/level-1/copy.lisp
@@ -33,53 +33,38 @@
(deft/method t/blas-copy-func (sym complex-tensor) ()
'zcopy)
;;
-(deft/generic (t/blas-copy! #'subtypep) sym (sz x st-x y st-y))
-(deft/method t/blas-copy! (sym blas-numeric-tensor) (sz x st-x y st-y)
- (let* ((decl (zipsym (list x y)))
- (args (mapcar #'car decl))
- (func (macroexpand-1 `(t/blas-copy-func ,sym))))
- (let ((x (first args)) (y (second args)))
+(deft/generic (t/blas-copy! #'subtypep) sym (x st-x y st-y))
+(deft/method t/blas-copy! (sym blas-numeric-tensor) (x st-x y st-y)
+ (let ((ncp? (null st-x)))
+ (using-gensyms (decl (x y))
`(let (,@decl)
- (declare (type ,sym ,@args))
- (,func
- (the index-type ,sz)
- (the ,(store-type sym) (store ,x)) (the index-type ,st-x)
- (the ,(store-type sym) (store ,y)) (the index-type ,st-y)
- (head ,x) (head ,y))
+ (declare (type ,sym ,@(unless ncp? `(,x)) ,y)
+ ,@(when ncp? `((type ,(field-type sym) ,x))))
+ (let ((sto-x ,(if ncp? `(t/store-allocator ,sym 1) `(store ,x)))
+ (st-x ,(if ncp? 0 st-x)))
+ (declare (type ,(store-type sym) sto-x)
+ (type index-type st-x))
+ ,@(when ncp?
+ `((t/store-set real-tensor ,x sto-x 0)))
+ (,(macroexpand-1 `(t/blas-copy-func ,sym))
+ (the index-type (size ,y))
+ (the ,(store-type sym) sto-x) (the index-type st-x)
+ (the ,(store-type sym) (store ,y)) (the index-type ,st-y)
+ ,(if ncp? 0 `(head ,x)) (head ,y)))
,y))))
-(deft/generic (t/blas-num-copy! #'subtypep) sym (sz x y st-y))
-(deft/method t/blas-num-copy! (sym blas-numeric-tensor) (sz x y st-y)
- (let* ((decl (zipsym (list x y)))
- (args (mapcar #'car decl))
- (func (macroexpand-1 `(t/blas-copy-func ,sym))))
- (let ((x (first args)) (y (second args)))
- `(let (,@decl)
- (declare (type ,sym ,y)
- (type ,(field-type sym) ,x))
- (let ((sto-x (t/store-allocator ,sym 1)))
- (declare (type ,(store-type sym) sto-x))
- (t/store-set ,sym ,x sto-x 0)
- (,func
- (the index-type ,sz)
- (the ,(store-type sym) sto-x) 0
- (the ,(store-type sym) (store ,y)) (the index-type ,st-y)
- 0 (head ,y)))
- ,y))))
-
;;
(deft/generic (t/copy! #'(lambda (a b) (strict-compare (list #'subtypep #'subtypep) a b))) (clx cly) (x y))
(deft/method t/copy! ((clx standard-tensor) (cly standard-tensor)) (x y)
- (let* ((decl (zipsym (list x y)))
- (args (mapcar #'car decl)))
- (let ((x (first args)) (y (second args)))
- `(let* (,@decl
- (sto-x (store ,x))
- (sto-y (store ,y)))
- (declare (type ,clx ,(first args))
- (type ,cly ,(second args))
- (type ,(store-type clx) sto-x)
- (type ,(store-type cly) sto-y))
+ (using-gensyms (decl (x y))
+ `(let* (,@decl
+ (sto-x (store ,x))
+ (sto-y (store ,y)))
+ (declare (type ,clx ,x)
+ (type ,cly ,y)
+ (type ,(store-type clx) sto-x)
+ (type ,(store-type cly) sto-y))
+ (very-quickly
(mod-dotimes (idx (dimensions ,x))
:with (linear-sums
(of-x (strides ,x) (head ,x))
@@ -89,47 +74,45 @@
(unless (eq clx cly)
`(t/strict-coerce (,(field-type clx) ,(field-type cly)) ))
`(t/store-ref ,clx sto-x of-x))
- sto-y of-y))
- ,y))))
+ sto-y of-y)))
+ ,y)))
;;Coercion messes up optimization in SBCL, so we specialize.
(deft/method t/copy! ((clx real-numeric-tensor) (cly complex-numeric-tensor)) (x y)
- (let* ((decl (zipsym (list x y)))
- (args (mapcar #'car decl)))
- (let ((x (first args)) (y (second args)))
- `(let* (,@decl
- (sto-x (store ,x))
- (sto-y (store ,y)))
- (declare (type ,clx ,(first args))
- (type ,cly ,(second args))
- (type ,(store-type clx) sto-x)
- (type ,(store-type cly) sto-y))
+ (using-gensyms (decl (x y))
+ `(let* (,@decl
+ (sto-x (store ,x))
+ (sto-y (store ,y)))
+ (declare (type ,clx ,x)
+ (type ,cly ,y)
+ (type ,(store-type clx) sto-x)
+ (type ,(store-type cly) sto-y))
+ (very-quickly
(mod-dotimes (idx (dimensions ,x))
:with (linear-sums
(of-x (strides ,x) (head ,x))
(of-y (strides ,y) (head ,y)))
:do (t/store-set ,cly
(the ,(field-type cly) (complex (t/coerce ,(store-element-type cly) (t/store-ref ,clx sto-x of-x)) (t/fid+ ,(store-element-type cly))))
- sto-y of-y))
- ,y))))
+ sto-y of-y)))
+ ,y)))
;;
(deft/method t/copy! ((clx t) (cly standard-tensor)) (x y)
- (let* ((decl (zipsym (list x y)))
- (args (mapcar #'car decl)))
- (let ((x (first args)) (y (second args)))
- `(let* (,@decl
- (sto-y (store ,y))
- (cx (t/coerce ,(field-type cly) ,x)))
- (declare (type ,cly ,(second args))
- (type ,(field-type cly) cx)
- (type ,(store-type cly) sto-y))
- ;;This should be safe
+ (using-gensyms (decl (x y))
+ `(let* (,@decl
+ (sto-y (store ,y))
+ (cx (t/coerce ,(field-type cly) ,x)))
+ (declare (type ,cly ,y)
+ (type ,(field-type cly) cx)
+ (type ,(store-type cly) sto-y))
+ ;;This should be safe
+ (very-quickly
(mod-dotimes (idx (dimensions ,y))
:with (linear-sums
(of-y (strides ,y) (head ,y)))
- :do (t/store-set ,cly cx sto-y of-y))
- ,y))))
+ :do (t/store-set ,cly cx sto-y of-y)))
+ ,y)))
;;
(defmethod copy! :before ((x standard-tensor) (y standard-tensor))
@@ -142,21 +125,24 @@
(assert (and (member clx *tensor-type-leaves*)
(member cly *tensor-type-leaves*))
nil 'tensor-abstract-class :tensor-class (list clx cly))
- (if (eq clx cly)
- (progn
- (compile-and-eval
- `(defmethod copy! ((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)))
- (let ((sz (size x))) (t/blas-copy! ,clx sz x (first strd) y (second strd)))))
- `(very-quickly (t/copy! (,clx ,cly) x y)))
- y)))
- (compile-and-eval
- `(defmethod copy! ((x ,clx) (y ,cly))
- (t/copy! (,clx ,cly) x y)
- y)))
- (copy! x y)))
+ (cond
+ ((eq clx cly)
+ (compile-and-eval
+ `(defmethod copy! ((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-copy! ,clx x (first strd) y (second strd))))
+ `(very-quickly (t/copy! (,clx ,cly) x y)))
+ y)))
+ ((coerceable? clx cly)
+ (compile-and-eval
+ `(defmethod copy! ((x ,clx) (y ,cly))
+ (t/copy! (,clx ,cly) x y)
+ y)))
+ (t
+ (error "Don't know how to copy from ~a to ~a" clx cly))))
+ (copy! x y))
(defmethod copy! ((x t) (y standard-tensor))
(let ((cly (class-name (class-of y))))
@@ -167,7 +153,7 @@
,(recursive-append
(when (subtypep cly 'blas-numeric-tensor)
`(if-let (strd (and (call-fortran? y (t/l1-lb ,cly)) (consecutive-storep y)))
- (let ((sz (size y))) (t/blas-num-copy! ,cly sz x y strd))))
+ (t/blas-copy! ,cly x nil y strd)))
`(very-quickly (t/copy! (t ,cly) x y)))))
(copy! x y)))
diff --git a/src/level-1/dot.lisp b/src/level-1/dot.lisp
index a7ac53e..3aa4a2f 100644
--- a/src/level-1/dot.lisp
+++ b/src/level-1/dot.lisp
@@ -36,43 +36,38 @@
(deft/generic (t/blas-dot #'subtypep) sym (x y &optional conjp))
(deft/method t/blas-dot (sym blas-numeric-tensor) (x y &optional (conjp t))
- (let* ((decl (zipsym (list x y)))
- (args (mapcar #'car decl))
- (func (macroexpand-1 `(t/blas-dot-func ,sym ,conjp))))
- (let ((x (first args)) (y (second args)))
- `(let (,@decl)
- (declare (type ,sym ,@args))
- (,func
- (aref (the index-store-vector (dimensions ,x)) 0)
- (the ,(store-type sym) (store ,x)) (aref (the index-store-vector (strides ,x)) 0)
- (the ,(store-type sym) (store ,y)) (aref (the index-store-vector (strides ,y)) 0)
- (head ,x) (head ,y))))))
+ (using-gensyms (decl (x y))
+ `(let (,@decl)
+ (declare (type ,sym ,x ,y))
+ (,(macroexpand-1 `(t/blas-dot-func ,sym ,conjp))
+ (aref (the index-store-vector (dimensions ,x)) 0)
+ (the ,(store-type sym) (store ,x)) (aref (the index-store-vector (strides ,x)) 0)
+ (the ,(store-type sym) (store ,y)) (aref (the index-store-vector (strides ,y)) 0)
+ (head ,x) (head ,y)))))
(deft/generic (t/dot #'subtypep) sym (x y &optional conjp))
(deft/method t/dot (sym standard-tensor) (x y &optional (conjp t))
- (let* ((decl (zipsym (list x y)))
- (args (mapcar #'car decl)))
- (let ((x (first args)) (y (second args)))
- `(let (,@decl)
- (declare (type ,sym ,@args))
- (let ((sto-x (store ,x))
- (stp-x (aref (the index-store-vector (strides ,x)) 0))
- (of-x (head ,x))
- (sto-y (store ,y))
- (stp-y (aref (the index-store-vector (strides ,y)) 0))
- (of-y (head ,y))
- (dot (t/fid+ ,(field-type sym))))
- (declare (type ,(store-type sym) sto-x sto-y)
- (type index-type stp-x stp-y of-x of-y)
- (type ,(field-type sym) dot))
- (loop :repeat (aref (the index-store-vector (dimensions ,x)) 0)
- :do (setf dot (t/f+ ,(field-type sym) dot
- (t/f* ,(field-type sym)
- ,(recursive-append (when conjp `(t/fc ,(field-type sym))) `(t/store-ref ,sym sto-x of-x))
- (t/store-ref ,sym sto-y of-y)))
- of-x (+ of-x stp-x)
- of-y (+ of-y stp-y)))
- dot)))))
+ (using-gensyms (decl (x y))
+ `(let (,@decl)
+ (declare (type ,sym ,x ,y))
+ (let ((sto-x (store ,x))
+ (stp-x (aref (the index-store-vector (strides ,x)) 0))
+ (of-x (head ,x))
+ (sto-y (store ,y))
+ (stp-y (aref (the index-store-vector (strides ,y)) 0))
+ (of-y (head ,y))
+ (dot (t/fid+ ,(field-type sym))))
+ (declare (type ,(store-type sym) sto-x sto-y)
+ (type index-type stp-x stp-y of-x of-y)
+ (type ,(field-type sym) dot))
+ (loop :repeat (aref (the index-store-vector (dimensions ,x)) 0)
+ :do (setf dot (t/f+ ,(field-type sym) dot
+ (t/f* ,(field-type sym)
+ ,(recursive-append (when conjp `(t/fc ,(field-type sym))) `(t/store-ref ,sym sto-x of-x))
+ (t/store-ref ,sym sto-y of-y)))
+ of-x (+ of-x stp-x)
+ of-y (+ of-y stp-y)))
+ dot))))
;;---------------------------------------------------------------;;
(defgeneric dot (x y &optional conjugate-p)
(:documentation
@@ -137,8 +132,8 @@
;;You pay the piper if you like mixing types.
;;This is (or should be) a rare enough to not matter.
((coerceable? clx cly)
- (dot (copy! x (zeros (dimensions x) cly)) y conjugate-p))
+ (dot (coerce-tensor x cly) y conjugate-p))
((coerceable? cly clx)
- (dot x (copy! y (zeros (dimensions y) clx)) conjugate-p))
+ (dot x (coerce-tensor y clx) conjugate-p))
(t
(error "Don't know how to compute the dot product of ~a , ~a." clx cly)))))
diff --git a/src/level-1/maker.lisp b/src/level-1/maker.lisp
index 21959a8..46a3f76 100644
--- a/src/level-1/maker.lisp
+++ b/src/level-1/maker.lisp
@@ -22,10 +22,11 @@
(definline zeros (dims &optional (type 'real-tensor))
(let ((*check-after-initializing?* nil))
- (etypecase dims
- (vector
- (zeros-generic (lvec->list dims) type))
- (cons
- (zeros-generic dims type))
- (fixnum
- (zeros-generic (list dims) type)))))
+ (let ((type (etypecase type (standard-class (class-name type)) (symbol type))))
+ (etypecase dims
+ (vector
+ (zeros-generic (lvec->list dims) type))
+ (cons
+ (zeros-generic dims type))
+ (fixnum
+ (zeros-generic (list dims) type))))))
diff --git a/src/level-1/scal.lisp b/src/level-1/scal.lisp
index 72a7962..85be999 100644
--- a/src/level-1/scal.lisp
+++ b/src/level-1/scal.lisp
@@ -25,9 +25,51 @@
;;; ENHANCEMENTS, OR MODIFICATIONS.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
(in-package #:matlisp)
+(deft/generic (t/blas-scal-func #'subtypep) sym ())
+(deft/method t/blas-scal-func (sym real-tensor) ()
+ 'descal)
+
+(deft/method t/blas-scal-func (sym complex-tensor) ()
+ 'zescal)
+;;
+(deft/generic (t/blas-scal! #'subtypep) sym (sz alpha x st-x))
+
+(deft/generic (t/blas-axpy! #'subtypep) sym (a x st-x y st-y))
+(deft/method t/blas-axpy! (sym blas-numeric-tensor) (a x st-x y st-y)
+ (let ((apy? (null x)))
+ (using-gensyms (decl (a x y))
+ `(let (,@decl)
+ (declare (type ,sym ,@(unless apy? `(,x)) ,y)
+ ,@(when apy? `((ignore ,x))))
+ (let ((sto-x ,(if apy? `(t/store-allocator ,sym 1) `(store ,x)))
+ (st-x ,(if apy? 0 st-x)))
+ (declare (type ,(store-type sym) sto-x)
+ (type index-type st-x))
+ ,@(when apy?
+ `((t/store-set real-tensor (t/fid* ,(field-type sym)) sto-x 0)))
+ (,(macroexpand-1 `(t/blas-axpy-func ,sym))
+ (the index-type (size ,y))
+ (the ,(field-type sym) ,a)
+ sto-x st-x
+ (the ,(store-type sym) (store ,y)) (the index-type ,st-y)
+ ,(if apy? 0 `(head ,x)) (head ,y))
+ ,y)))))
+
+(deft/method t/blas-scal! (sym blas-numeric-tensor) (sz a x st-x)
+ (using-gensyms (decl (x))
+ `(let (,@decl)
+ (declare (type ,sym ,x))
+ (,(macroexpand-1 `(t/blas-scal-func ,sym))
+ (the index-type ,sz)
+ (the ,(field-type sym) ,a)
+ (the ,(store-type sym) (store ,x)) (the index-type ,st-x)
+ (head ,x))
+ ,x)))
+
+
+
(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)
@@ -190,10 +232,6 @@
(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-num-scal! complex-typed-num-scal!
(complex-tensor zordscal *complex-l1-fcall-lb*))
diff --git a/src/level-1/swap.lisp b/src/level-1/swap.lisp
index c6c5321..a177a03 100644
--- a/src/level-1/swap.lisp
+++ b/src/level-1/swap.lisp
@@ -33,41 +33,37 @@
(deft/method t/blas-swap-func (sym complex-tensor) ()
'zswap)
;;
-(deft/generic (t/blas-swap! #'subtypep) sym (sz x st-x y st-y))
-(deft/method t/blas-swap! (sym blas-numeric-tensor) (sz x st-x y st-y)
- (let* ((decl (zipsym (list x y)))
- (args (mapcar #'car decl))
- (func (macroexpand-1 `(t/blas-swap-func ,sym))))
- (let ((x (first args)) (y (second args)))
- `(let (,@decl)
- (declare (type ,sym ,@args))
- (,func
- (the index-type ,sz)
- (the ,(store-type sym) (store ,x)) (the index-type ,st-x)
- (the ,(store-type sym) (store ,y)) (the index-type ,st-y)
- (head ,x) (head ,y))
- ,y))))
+(deft/generic (t/blas-swap! #'subtypep) sym (x st-x y st-y))
+(deft/method t/blas-swap! (sym blas-numeric-tensor) (x st-x y st-y)
+ (using-gensyms (decl (x y))
+ `(let (,@decl)
+ (declare (type ,sym ,x ,y))
+ (,(macroexpand-1 `(t/blas-swap-func ,sym))
+ (the index-type (size ,y))
+ (the ,(store-type sym) (store ,x)) (the index-type ,st-x)
+ (the ,(store-type sym) (store ,y)) (the index-type ,st-y)
+ (head ,x) (head ,y))
+ ,y)))
(deft/generic (t/swap! #'subtypep) sym (x y))
(deft/method t/swap! (sym standard-tensor) (x y)
- (let* ((decl (zipsym (list x y)))
- (args (mapcar #'car decl)))
- (let ((x (first args)) (y (second args)))
- `(let* (,@decl
- (sto-x (store ,x))
- (sto-y (store ,y)))
- (declare (type ,sym ,@args)
+ (using-gensyms (decl (x y))
+ `(let (,@decl
+ (sto-x (store ,x))
+ (sto-y (store ,y)))
+ (declare (type ,sym ,x ,y)
(type ,(store-type sym) sto-x sto-y))
- (mod-dotimes (idx (dimensions ,x))
- :with (linear-sums
- (of-x (strides ,x) (head ,x))
- (of-y (strides ,y) (head ,y)))
- :do (let-typed ((y-val (t/store-ref ,sym sto-y of-y) :type ,(field-type sym)))
- (t/store-set ,sym
- (t/store-ref ,sym sto-x of-x) sto-y of-y)
- (t/store-set ,sym
- y-val sto-x of-x)))
- ,y))))
+ (very-quickly
+ (mod-dotimes (idx (dimensions ,x))
+ :with (linear-sums
+ (of-x (strides ,x) (head ,x))
+ (of-y (strides ,y) (head ,y)))
+ :do (let-typed ((y-val (t/store-ref ,sym sto-y of-y) :type ,(field-type sym)))
+ (t/store-set ,sym
+ (t/store-ref ,sym sto-x of-x) sto-y of-y)
+ (t/store-set ,sym
+ y-val sto-x of-x)))
+ ,y))))
;;---------------------------------------------------------------;;
(defmethod swap! :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
@@ -86,8 +82,8 @@
,(recursive-append
(when (subtypep clx 'blas-numeric-tensor)
`(if-let (strd (and (call-fortran? x (t/l1-lb ,clx)) (blas-copyablep x y)))
- (let ((sz (size x))) (t/blas-swap! ,clx sz x (first strd) y (second strd)))))
- `(very-quickly (t/swap! ,clx x y)))
+ (t/blas-swap! ,clx x (first strd) y (second strd))))
+ `(t/swap! ,clx x y))
y))
(swap! x y))
;;It is silly to swap a real vector with a complex one, no?
commit d7210a4b81356e32907afde8bcd13d4cbf97dd00
Author: Akshay Srinivasan <aks...@gm...>
Date: Fri Jun 21 03:54:09 2013 -0700
Added axpy! template.
diff --git a/packages.lisp b/packages.lisp
index 4168ed9..5c7413f 100644
--- a/packages.lisp
+++ b/packages.lisp
@@ -84,7 +84,7 @@
#:lvec->list #:lvec->list!
#:compile-and-eval
;;Macros
- #:when-let #:if-let #:if-ret #:with-gensyms #:let-rec
+ #:when-let #:if-let #:if-ret #:with-gensyms #:let-rec #:using-gensyms
#:mlet* #:make-array-allocator #:let-typed #:let*-typed
#:nconsc #:define-constant
#:macrofy #:looped-mapcar #:defun-compiler-macro
diff --git a/src/base/template.lisp b/src/base/template.lisp
in...
[truncated message content] |
Thanks for helping keep SourceForge clean.
X