Menu
▾
▴
[Matlisp-commit] [matlisp-git]matlisp branch classy updated. 2012-02-23-237-g8273423
|
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
index a190f46..bdf0d06 100644
--- a/src/base/template.lisp
+++ b/src/base/template.lisp
@@ -50,7 +50,7 @@
(compile-and-eval
`(defmethod fconj ((x ,clname))
(t/fc ,clname x)))
- (fconj x))))
+ (fc x))))
(deft/generic (t/f= #'subtypep) ty (&rest nums))
(deft/method t/f= (ty number) (&rest nums)
diff --git a/src/level-1/axpy.lisp b/src/level-1/axpy.lisp
index 25966de..a604af8 100644
--- a/src/level-1/axpy.lisp
+++ b/src/level-1/axpy.lisp
@@ -25,123 +25,81 @@
;;; ENHANCEMENTS, OR MODIFICATIONS.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
(in-package #:matlisp)
-(defmacro generate-typed-axpy! (func (tensor-class blas-func fortran-lb))
- ;;Be very careful when using functions generated by this macro.
- ;;Indexes can be tricky and this has no safety net
- ;;Use only after checking the arguments for compatibility.
- (let* ((opt (get-tensor-class-optimization-hashtable tensor-class)))
- (assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
- `(progn
- (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.
- ;;Indexes can be tricky and this has no safety net
- ;;(you don't see a matrix-ref do you ?)
- ;;Use only after checking the arguments for compatibility.
- (let* ((opt (get-tensor-class-optimization tensor-class)))
- (assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
- `(progn
- (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*))
-
-(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*))
-
-;;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)))
-
+(deft/generic (t/blas-axpy-func #'subtypep) sym ())
+(deft/method t/blas-axpy-func (sym real-tensor) ()
+ '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)
+ (,(macroexpand-1 `(t/blas-axpy-func ,sym))
+ (the index-type ,sz)
+ (t/fid* ,(field-type sym))
+ (the ,(store-type sym) sto-a) 0
+ (the ,(store-type sym) (store ,y)) (the index-type ,st-y)
+ 0 (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))
+ (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)))
;;---------------------------------------------------------------;;
(defgeneric axpy! (alpha x y)
diff --git a/src/utilities/macros.lisp b/src/utilities/macros.lisp
index 259fb95..a0230d0 100644
--- a/src/utilities/macros.lisp
+++ b/src/utilities/macros.lisp
@@ -203,6 +203,11 @@
symlist)
,@body))
+(defmacro using-gensyms ((decl (&rest syms)) &rest body)
+ `(let ((,decl (zipsym (list ,@syms))))
+ (destructuring-bind (,@syms) (mapcar #'car ,decl)
+ ,@body)))
+
(defmacro nconsc (var &rest args)
"
Macro to do setf and nconc for destructive list updates. If @arg{var}
diff --git a/src/utilities/template.lisp b/src/utilities/template.lisp
index 0392817..99f029c 100644
--- a/src/utilities/template.lisp
+++ b/src/utilities/template.lisp
@@ -64,7 +64,7 @@
`(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (gethash ',name *template-table*) (list :lambda-list (list ',disp ',args) :predicate ,predicate :sorter ,(or sorter predicate) :methods nil))
(defmacro ,name (&whole ,warg-sym ,disp-arg ,@args)
- (declare (ignore ,@(remove-if #'(lambda (x) (member x cl:lambda-list-keywords)) args)))
+ (declare (ignore ,@(remove-if #'(lambda (x) (member x cl:lambda-list-keywords)) args) ,@(when (consp disp) disp)))
(let* ((,pred-sym (preprocess-t/dispatch ',name ,disp-far))
(,meth-sym (compute-t/dispatch ',name ,pred-sym)))
(apply ,meth-sym (cons ,pred-sym (cddr ,warg-sym)))))))))
commit 1407d41f3f3150a905e8cf33e07db5042651f8ae
Author: Akshay Srinivasan <aks...@gm...>
Date: Fri Jun 21 03:38:54 2013 -0700
Cleaned up mod-dotimes.
diff --git a/src/base/loopy.lisp b/src/base/loopy.lisp
index f68a66d..2e3300c 100644
--- a/src/base/loopy.lisp
+++ b/src/base/loopy.lisp
@@ -1,6 +1,6 @@
(in-package #:matlisp)
-(defmacro mod-dotimes ((idx dims) &body body)
+(defmacro mod-dotimes ((idx dims &key (loop-order *default-stride-ordering*)) &body body)
"
(mod-dotimes (idx {seq}) compound-form*)
@@ -31,19 +31,14 @@
Make sure that \"do\" is specified at the end. Parser stops
at the first 'do it finds.
"
- (check-type idx symbol)
+ (check-type idx symbol)
(labels ((parse-code (body ret)
(cond
((null body)
(values nil ret))
((member (car body) '(with :with))
(multiple-value-bind (indic decl) (parse-with (cadr body))
- (setf (getf ret indic) decl))
- (parse-code (cddr body) ret))
- ;;Let's not do too much
- #+nil
- ((eq (car body) 'finally)
- (setf (getf ret :finally) (second body))
+ (setf (getf ret indic) (append (getf ret indic) decl)))
(parse-code (cddr body) ret))
((member (car body) '(do :do))
(values (cadr body) ret))
@@ -52,74 +47,77 @@
(cond
((member (car code) '(linear-sums :linear-sums))
(values :linear-sums
- (loop for decl in (cdr code)
- collect (destructuring-bind (offst strds &optional (init 0)) decl
- (list :offset-sym offst
- :offset-init init
- :stride-sym (gensym (string+ (symbol-name offst) "-stride"))
- :stride-expr strds)))))
- ((and (member (car code) '(loop-order :loop-order))
- (member (cadr code) '(:row-major :col-major)))
- (values :loop-order (second code)))
- ;;Useless without a finally clause
- #+nil
- ((eq (car code) 'variables)
- (values :variables
- (loop for decl in (cdr code)
- collect (destructuring-bind (sym init &key type) decl
- (list :variable sym
- :init init
- :type type)))))
+ (loop :for decl :in (cdr code)
+ :collect (destructuring-bind (offst strds &optional (init 0)) decl
+ (list :offset-sym offst
+ :offset-init init
+ :stride-sym (gensym (string+ (symbol-name offst) "-stride"))
+ :stride-expr strds)))))
(t (error 'unknown-token :token (car code) :message "Error in macro: mod-dotimes -> parse-with.~%")))))
(multiple-value-bind (code sdecl) (parse-code body nil)
- (with-gensyms (dims-sym rank-sym count-sym)
- `(let ((,dims-sym ,dims))
- (declare (type index-store-vector ,dims-sym))
- (let ((,rank-sym (length ,dims-sym)))
- (declare (type index-type ,rank-sym))
- (let ((,idx (allocate-index-store ,rank-sym))
- ,@(mapcar #'(lambda (x) `(,(getf x :stride-sym) ,(getf x :stride-expr))) (getf sdecl :linear-sums))
- ,@(mapcar #'(lambda (x) `(,(getf x :variable) ,(getf x :init))) (getf sdecl :variables)))
- (declare (type index-store-vector ,idx)
- ,@(when (getf sdecl :linear-sums)
- `((type index-store-vector ,@(mapcar #'(lambda (x) (getf x :stride-sym)) (getf sdecl :linear-sums)))))
- ,@(loop for x in (getf sdecl :variables)
- unless (null (getf x :type))
- collect `(type ,(getf x :type) ,(getf x :variable))))
- (loop ,@(loop for decl in (getf sdecl :linear-sums)
- append `(with ,(getf decl :offset-sym) of-type index-type = ,(getf decl :offset-init)))
- ,@(unless (null code)
- `(do (,@code)))
- while (very-quickly
- ,(append
- (if (member (getf sdecl :loop-order) '(nil :row-major))
- `(loop for ,count-sym of-type index-type from (1- ,rank-sym) downto 0)
- `(loop for ,count-sym of-type index-type from 0 below ,rank-sym))
- `(do
- (if (= (aref ,idx ,count-sym) (1- (aref ,dims-sym ,count-sym)))
- (progn
- (setf (aref ,idx ,count-sym) 0)
- ,@(loop
- for decl in (getf sdecl :linear-sums)
- collect (let ((cstrd (gensym (string+ "cur-" (symbol-name (getf decl :stride-sym))))))
- `(let ((,cstrd (aref ,(getf decl :stride-sym) ,count-sym)))
- (declare (type index-type ,cstrd))
- (unless (= ,cstrd 0)
- (decf ,(getf decl :offset-sym) (the index-type (* ,cstrd (1- (aref ,dims-sym ,count-sym))))))))))
- (progn
- (incf (aref ,idx ,count-sym))
- ,@(loop
- for decl in (getf sdecl :linear-sums)
- collect (let ((cstrd (gensym (string+ "cur-" (symbol-name (getf decl :stride-sym))))))
- `(let ((,cstrd (aref ,(getf decl :stride-sym) ,count-sym)))
- (declare (type index-type ,cstrd))
- (unless (= ,cstrd 0)
- (incf ,(getf decl :offset-sym) ,cstrd)))))
- (return t)))
- finally (return nil))))
- ,@(unless (null (getf sdecl :finally))
- `(finally (,@(getf sdecl :finally))))))))))))
-
+ (let ((loop-perm (unless (member loop-order '(:row-major :col-major))
+ ;;Assumed to be a permutation action store
+ (prog1 loop-order
+ (setq loop-order nil)))))
+ (with-gensyms (perm-sym loopi-sym dims-sym rank-sym count-sym)
+ `(let ((,dims-sym ,dims))
+ (declare (type index-store-vector ,dims-sym))
+ (let ((,rank-sym (length ,dims-sym))
+ ,@(when loop-perm
+ `((,perm-sym ,loop-perm))))
+ (declare (type index-type ,rank-sym)
+ ,@(when loop-perm
+ `((type pindex-store-vector ,perm-sym))))
+ ,@(when loop-perm
+ `((assert (<= (length ,perm-sym) ,rank-sym) nil 'permutation-permute-error)))
+ (let ((,idx (allocate-index-store ,rank-sym))
+ ,@(when loop-perm `((,loopi-sym (allocate-index-store ,rank-sym))))
+ ,@(mapcar #'(lambda (x) `(,(getf x :stride-sym) ,(getf x :stride-expr))) (getf sdecl :linear-sums))
+ ,@(mapcar #'(lambda (x) `(,(getf x :variable) ,(getf x :init))) (getf sdecl :variables)))
+ (declare (type index-store-vector ,idx ,@(when loop-perm `(,loopi-sym)))
+ ,@(when (getf sdecl :linear-sums)
+ `((type index-store-vector ,@(mapcar #'(lambda (x) (getf x :stride-sym)) (getf sdecl :linear-sums)))))
+ ,@(loop :for x :in (getf sdecl :variables)
+ :unless (null (getf x :type))
+ :collect `(type ,(getf x :type) ,(getf x :variable))))
+ ,@(when loop-perm
+ `((very-quickly
+ (loop :for i :of-type index-type :from 0 :below ,rank-sym :do (setf (aref ,loopi-sym i) i))
+ (apply-action! ,loopi-sym ,perm-sym))))
+ (loop ,@(loop :for decl :in (getf sdecl :linear-sums)
+ :append `(:with ,(getf decl :offset-sym) :of-type index-type := ,(getf decl :offset-init)))
+ ,@(unless (null code)
+ `(:do (,@code)))
+ :while (very-quickly
+ ,(append
+ (if loop-perm
+ `(loop :for ,count-sym :of-type index-type :across ,loopi-sym)
+ (ecase loop-order
+ (:row-major `(loop :for ,count-sym :of-type index-type :from (1- ,rank-sym) :downto 0))
+ (:col-major `(loop :for ,count-sym :of-type index-type :from 0 :below ,rank-sym))))
+ `(:do
+ (if (= (aref ,idx ,count-sym) (1- (aref ,dims-sym ,count-sym)))
+ (progn
+ (setf (aref ,idx ,count-sym) 0)
+ ,@(loop
+ :for decl :in (getf sdecl :linear-sums)
+ :collect (let ((cstrd (gensym (string+ "cur-" (symbol-name (getf decl :stride-sym))))))
+ `(let ((,cstrd (aref ,(getf decl :stride-sym) ,count-sym)))
+ (declare (type index-type ,cstrd))
+ (unless (= ,cstrd 0)
+ (decf ,(getf decl :offset-sym) (the index-type (* ,cstrd (1- (aref ,dims-sym ,count-sym))))))))))
+ (progn
+ (incf (aref ,idx ,count-sym))
+ ,@(loop
+ :for decl :in (getf sdecl :linear-sums)
+ :collect (let ((cstrd (gensym (string+ "cur-" (symbol-name (getf decl :stride-sym))))))
+ `(let ((,cstrd (aref ,(getf decl :stride-sym) ,count-sym)))
+ (declare (type index-type ,cstrd))
+ (unless (= ,cstrd 0)
+ (incf ,(getf decl :offset-sym) ,cstrd)))))
+ (return t)))
+ :finally (return nil)))))))))))))
+
(defmacro list-loop ((idx ele lst) &rest body)
"
(list-loop (idx ele {list}) compound-form*)
commit 4248b0bfbfb4fda8e99fee6edad8383f2afcf606
Author: Akshay Srinivasan <aks...@gm...>
Date: Wed Jun 19 02:40:59 2013 -0700
Migrated swap.
diff --git a/matlisp.asd b/matlisp.asd
index 1526b85..832ab71 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -139,9 +139,10 @@
:depends-on ("maker"))
(:file "dot"
:depends-on ("maker"))
+ (:file "swap")
#+nil
(
- (:file "swap")
+
(:file "realimag"
:depends-on ("copy"))
(:file "scal"
diff --git a/src/level-1/swap.lisp b/src/level-1/swap.lisp
index d9febc0..c6c5321 100644
--- a/src/level-1/swap.lisp
+++ b/src/level-1/swap.lisp
@@ -25,70 +25,70 @@
;;; ENHANCEMENTS, OR MODIFICATIONS.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
(in-package #:matlisp)
-(defmacro generate-typed-swap! (func (tensor-class blas-func fortran-lb))
- ;;Be very careful when using functions generated by this macro.
- ;;Indexes can be tricky and this has no safety net
- ;;Use only after checking the arguments for compatibility.
- (let* ((opt (get-tensor-class-optimization-hashtable tensor-class)))
- (assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
- `(progn
- (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*))
-
-(generate-typed-swap! complex-typed-swap!
- (complex-tensor zswap *complex-l1-fcall-lb*))
-
-#+maxima
-(generate-typed-swap! symbolic-typed-swap!
- (symbolic-tensor nil 0))
-
+(deft/generic (t/blas-swap-func #'subtypep) sym ())
+(deft/method t/blas-swap-func (sym real-tensor) ()
+ 'dswap)
+(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/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)
+ (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))))
;;---------------------------------------------------------------;;
-;;Generic function in src;base;generic-swap.lisp
-
(defmethod swap! :before ((x standard-tensor) (y standard-tensor))
- (assert (lvec-eq (dimensions x) (dimensions y) #'=) nil
+ (assert (very-quickly (lvec-eq (the index-store-vector (dimensions x)) (the index-store-vector (dimensions y)) #'=)) nil
'tensor-dimension-mismatch))
-(defmethod swap! ((x complex-tensor) (y real-tensor))
- (error 'coercion-error :from 'complex-tensor :to 'real-tensor))
-
-(defmethod swap! ((x real-tensor) (y complex-tensor))
- (error 'coercion-error :from 'complex-tensor :to 'real-tensor))
-
-(defmethod swap! ((x real-tensor) (y real-tensor))
- (real-typed-swap! x y))
-
-(defmethod swap! ((x complex-tensor) (y complex-tensor))
- (complex-typed-swap! x y))
+(defmethod swap! ((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))
+ (if (eq clx cly)
+ (progn
+ (compile-and-eval
+ `(defmethod swap! ((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-swap! ,clx sz x (first strd) y (second strd)))))
+ `(very-quickly (t/swap! ,clx x y)))
+ y))
+ (swap! x y))
+ ;;It is silly to swap a real vector with a complex one, no?
+ (error "Don't know how to swap ~a and ~a." clx cly))))
commit ecbc68d2926eb4dc1299401beb741e3551a3941d
Author: Akshay Srinivasan <aks...@gm...>
Date: Wed Jun 19 02:17:31 2013 -0700
Pushed all the templates definitions inside a eval-when form.
diff --git a/src/utilities/template.lisp b/src/utilities/template.lisp
index 24818e7..0392817 100644
--- a/src/utilities/template.lisp
+++ b/src/utilities/template.lisp
@@ -3,7 +3,8 @@
;;Suck on that C++ :)
(eval-when (:compile-toplevel :load-toplevel :execute)
- (defvar *template-table* (make-hash-table)))
+
+(defvar *template-table* (make-hash-table))
(defun match-lambda-lists (lsta lstb)
(let ((optional? nil))
@@ -100,3 +101,4 @@
(setf (getf data :methods) (setrem meth spls #'(lambda (a b) (list-eq (second a) b))))
nil))
+)
-----------------------------------------------------------------------
Summary of changes:
matlisp.asd | 8 +-
packages.lisp | 2 +-
src/base/loopy.lisp | 146 +++++++++++-----------
src/base/print.lisp | 2 +-
src/base/standard-tensor.lisp | 20 ++-
src/base/template.lisp | 2 +-
src/level-1/axpy.lisp | 273 ++++++++++++++---------------------------
src/level-1/copy.lisp | 152 +++++++++++-------------
src/level-1/dot.lisp | 67 +++++------
src/level-1/maker.lisp | 15 ++-
src/level-1/scal.lisp | 48 +++++++-
src/level-1/swap.lisp | 118 +++++++++---------
src/utilities/macros.lisp | 5 +
src/utilities/template.lisp | 6 +-
14 files changed, 403 insertions(+), 461 deletions(-)
hooks/post-receive
--
matlisp
|
