Menu
▾
▴
[Matlisp-commit] [matlisp-git]matlisp branch tensor updated. 2012-02-23-92-g0f1b57f
|
From: Akshay S. <ak...@us...> - 2012-06-25 10:21:32
|
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "matlisp".
The branch, tensor has been updated
via 0f1b57f2c90f00aac4aa5ea6e7240ae69690409f (commit)
from 8bb55ab5b53aa70785619511fcd6457b3bb79401 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 0f1b57f2c90f00aac4aa5ea6e7240ae69690409f
Author: Akshay Srinivasan <aks...@gm...>
Date: Mon Jun 25 15:46:15 2012 +0530
Added mod-loop for doing multi-index loops seemlessly. Must add more checks.
Added tensor-copy; can run things at about 3x BLAS (dcopy) speed (!) :)
diff --git a/AUTHORS b/AUTHORS
index c400f4e..2617a30 100644
--- a/AUTHORS
+++ b/AUTHORS
@@ -4,5 +4,5 @@ based on an initial prototype by Raymond Toy.
It is now being refactored by Akshay Srinivasan.
Some of code was originally written by Nicholas Neuss for
-Femlisp (www.femlisp.org); it has used here (with modification)
-with the author's consent.
+Femlisp (www.femlisp.org); it has been used here
+(with modification or otherwise) with the author's consent.
diff --git a/src/complex-tensor.lisp b/src/complex-tensor.lisp
index b7abc41..9ae6fbe 100644
--- a/src/complex-tensor.lisp
+++ b/src/complex-tensor.lisp
@@ -72,6 +72,10 @@ Cannot hold complex numbers."))
(setf (gethash 'complex-sub-tensor *tensor-class-optimizations*) 'complex-tensor)
+(defmethod (setf tensor-ref) ((value number) (tensor complex-tensor) subscripts)
+ (let ((sto-idx (store-indexing subscripts tensor)))
+ (setf (tensor-store-ref tensor sto-idx) (coerce-complex value))))
+
;;
(defmethod print-element ((tensor complex-tensor)
element stream)
diff --git a/src/real-tensor.lisp b/src/real-tensor.lisp
index 9408e85..b47f5be 100644
--- a/src/real-tensor.lisp
+++ b/src/real-tensor.lisp
@@ -53,6 +53,10 @@ Allocates real storage. Default initial-element = 0d0.")
(setf (gethash 'real-sub-tensor *tensor-class-optimizations*) 'real-tensor)
+(defmethod (setf tensor-ref) ((value number) (tensor real-tensor) subscripts)
+ (let ((sto-idx (store-indexing subscripts tensor)))
+ (setf (tensor-store-ref tensor sto-idx) (coerce-real value))))
+
;;
(defmethod print-element ((tensor real-tensor)
element stream)
diff --git a/src/standard-matrix.lisp b/src/standard-matrix.lisp
index 6357c1c..192a23a 100644
--- a/src/standard-matrix.lisp
+++ b/src/standard-matrix.lisp
@@ -122,7 +122,7 @@ matrix and a number"))
;;
(gethash 'complex-matrix *tensor-class-optimizations*) 'complex-tensor
(gethash 'complex-sub-matrix *tensor-class-optimizations*) 'complex-tensor)
-
+
;;
(definline matrix-ref (matrix row &optional col)
diff --git a/src/standard-tensor.lisp b/src/standard-tensor.lisp
index bbbb419..3ef4919 100644
--- a/src/standard-tensor.lisp
+++ b/src/standard-tensor.lisp
@@ -96,23 +96,23 @@
;;
(defparameter *sub-tensor-counterclass* (make-hash-table)
"
-Contains the sub-tensor CLOS counterpart classes of every
-tensor class. This is used by sub-tensor~ and other in-place
-slicing functions to construct new objects.")
+ Contains the sub-tensor CLOS counterpart classes of every
+ tensor class. This is used by sub-tensor~ and other in-place
+ slicing functions to construct new objects.")
(setf (gethash 'standard-tensor *sub-tensor-counterclass*) 'standard-sub-tensor)
;;
(defparameter *tensor-class-optimizations* (make-hash-table)
"
-Contains a either:
-o A property list containing:
-:element-type
-:store-type
-:reader (store idx) => result
-:value-writer (value store idx) => (store idx) <- value
-:reader-writer (fstore fidx tstore tidx) => (tstore tidx) <- (fstore fidx)
-o class-name (symbol) of the superclass whose optimizations
+ Contains a either:
+ o A property list containing:
+ :element-type
+ :store-type
+ :reader (store idx) => result
+ :value-writer (value store idx) => (store idx) <- value
+ :reader-writer (fstore fidx tstore tidx) => (tstore tidx) <- (fstore fidx)
+ o class-name (symbol) of the superclass whose optimizations
are to be made use of.")
(defun get-tensor-class-optimization (clname)
@@ -127,8 +127,9 @@ o class-name (symbol) of the superclass whose optimizations
;; Akshay: I have no idea what this does, or why we want it
;; (inherited from standard-matrix.lisp
(defmethod make-load-form ((tensor standard-tensor) &optional env)
- "MAKE-LOAD-FORM allows us to determine a load time value for
- tensor, for example #.(make-tensors ...)"
+ "
+ MAKE-LOAD-FORM allows us to determine a load time value for
+ tensor, for example #.(make-tensors ...)"
(make-load-form-saving-slots tensor :environment env))
;;
diff --git a/src/tensor-copy.lisp b/src/tensor-copy.lisp
index c52907a..3400bc3 100644
--- a/src/tensor-copy.lisp
+++ b/src/tensor-copy.lisp
@@ -23,89 +23,123 @@ is used, else the fortran routine is called instead.
unless (= off accumulated-off) do (return nil)
finally (return t))))
-;;
-
-(defmacro mod-tensor-loop ((idx dims) &body body)
+(defmacro mod-loop ((idx dims) &body body)
(check-type idx symbol)
(let ((tensor-table (make-hash-table)))
- (labels ((get-tensors (decl ret)
- (if (null decl)
- ret
+ (labels ((get-tensors (decl)
+ (if (null decl) t
(let ((cdecl (car decl)))
- (if (and (eq (first cdecl) 'type)
- (gethash (second cdecl) *sub-tensor-counterclass*))
- (dolist sym
- (get-tensors (cdr decl) (append ret (cddr cdecl)))
- (get-tensors (cdr decl) ret)))))
+ (when (and (eq (first cdecl) 'type)
+ (get-tensor-class-optimization (second cdecl)))
+ (dolist (sym (cddr cdecl))
+ (let ((hsh (list
+ :class (second cdecl)
+ :stride-sym (gensym (string+ (symbol-name sym) "-stride"))
+ :store-sym (gensym (string+ (symbol-name sym) "-store"))
+ :offset-sym (gensym (string+ (symbol-name sym) "-offset")))))
+ (setf (gethash sym tensor-table) hsh))))
+ (get-tensors (cdr decl)))))
+ (ttrans-p (code)
+ (and (eq (first code) 'tensor-ref)
+ (gethash (second code) tensor-table)
+ (eq (third code) idx)))
+ (transform-setf-tensor-ref (snippet ret)
+ (if (null snippet) ret
+ (transform-setf-tensor-ref
+ (cddr snippet)
+ (append ret
+ (destructuring-bind (to from &rest rest) snippet
+ (declare (ignore rest))
+ (let ((to-t? (ttrans-p to))
+ (fr-t? (ttrans-p from)))
+ (cond
+ ((and to-t? fr-t?)
+ (let ((to-opt (gethash (second to) tensor-table))
+ (fr-opt (gethash (second from) tensor-table)))
+ ;;Add type checking here!
+ (cdr (funcall (getf (get-tensor-class-optimization (getf to-opt :class)) :reader-writer)
+ (getf fr-opt :store-sym) (getf fr-opt :offset-sym) (getf to-opt :store-sym) (getf to-opt :offset-sym)))))
+ (to-t?
+ (let ((to-opt (gethash (second to) tensor-table)))
+ ;;Add type checking here!
+ (cdr (funcall (getf (get-tensor-class-optimization (getf to-opt :class)) :value-writer)
+ from (getf to-opt :store-sym) (getf to-opt :offset-sym)))))
+ (fr-t?
+ (let ((fr-opt (gethash (second from) tensor-table)))
+ (cons to (funcall (getf (get-tensor-class-optimization (getf fr-opt :class)) :reader)
+ (getf fr-opt :store-sym) (getf fr-opt :offset-sym)))))
+ (t
+ (list to from)))))))))
(transform-tensor-ref (snippet)
- (let ((ten (second snippet))
- (index (third snippet)))
- (if (not (eq index idx)) snippet
- (destructuring-bind (tstride tstore toff)
- (if-ret (gethash ten tensor-table)
- (setf (gethash ten tensor-table)
- (mapcar #'(lambda (x)
- (gensym (string+ (symbol-name ten) (symbol-name x))))
- '(stride store off))))
- (let ((let-before-code `((,tstride (strides ,ten))
- (,tstore (store ,ten))))
- (loop-code `(with ,toff of-type index-type = (head ,ten)))
- (decl-code `(type
-
-
-
- (find-tensor-refs (code ret ten)
- (let ((ccode (car code)))
- (cond
- ((consp ccode)
- (find-tensor-refs (car ccode) ...))
- ((eq ccode 'tensor-ref)
- (transform-tensor-ref code)))
-
- (with-gensyms (dims-sym rank-sym)
- `(let* ((,dims-sym ,dims)
- (,rank-sym (length ,dims-sym))
- (,idx (allocate-index-store ,rank-sym)))
- (declare (type (index-array *) ,idx))
- (loop
- do (progn
- ,@body)
- while (dotimes (i ,rank-sym nil)
- (declare (type index-type i))
- (if (= (aref ,idx i) (1- (aref ,dims-sym i)))
- (progn
- (setf (aref ,idx i) 0))
- (progn
- (incf (aref ,idx i))
- (return t))))))))
+ (if (eq (first snippet) 'setf)
+ (cons 'setf (transform-setf-tensor-ref (cdr snippet) nil))
+ (destructuring-bind (tref ten index) snippet
+ (assert (eq tref 'tensor-ref))
+ (let ((topt (gethash ten tensor-table)))
+ (if (not (and (eq index idx) topt)) snippet
+ (funcall (getf (get-tensor-class-optimization (getf topt :class)) :reader) (getf topt :store-sym) (getf topt :offset-sym)))))))
+ (find-tensor-refs (code ret)
+ (if (null code) (reverse ret)
+ (cond
+ ((consp code)
+ (if (member (first code) '(tensor-ref setf))
+ (transform-tensor-ref code)
+ (find-tensor-refs (cdr code) (cons (find-tensor-refs (car code) nil) ret))))
+ (t code)))))
+ (when (eq (caar body) 'declare)
+ (get-tensors (cdar body)))
+ (with-gensyms (dims-sym rank-sym count-sym)
+ `(let* ((,dims-sym ,dims)
+ (,rank-sym (length ,dims-sym))
+ (,idx (allocate-index-store ,rank-sym))
+ ,@(loop for key being the hash-keys of tensor-table
+ collect (let ((hsh (gethash key tensor-table)))
+ `(,(getf hsh :stride-sym) (strides ,key))))
+ ,@(loop for key being the hash-keys of tensor-table
+ collect (let ((hsh (gethash key tensor-table)))
+ `(,(getf hsh :store-sym) (store ,key)))))
+ (declare (type (index-array *) ,idx ,@(loop for key being the hash-keys of tensor-table
+ collect (getf (gethash key tensor-table) :stride-sym)))
+ ,@(loop for key being the hash-keys of tensor-table
+ collect (let* ((hsh (gethash key tensor-table))
+ (opt (get-tensor-class-optimization (getf hsh :class))))
+ `(type ,(linear-array-type (getf opt :store-type)) ,(getf hsh :store-sym)))))
+ (loop
+ ,@(loop for key being the hash-keys of tensor-table
+ append (let ((hsh (gethash key tensor-table)))
+ `(with ,(getf hsh :offset-sym) of-type index-type = (head ,key))))
+ do (locally
+ ,@(find-tensor-refs body nil))
+ while (dotimes (,count-sym ,rank-sym nil)
+ (declare (type index-type ,count-sym))
+ (if (= (aref ,idx ,count-sym) (1- (aref ,dims-sym ,count-sym)))
+ (progn
+ (setf (aref ,idx ,count-sym) 0)
+ ,@(loop for key being the hash-keys of tensor-table
+ collect (let ((hsh (gethash key tensor-table)))
+ `(decf ,(getf hsh :offset-sym) (* (aref ,(getf hsh :stride-sym) ,count-sym) (1- (aref ,dims-sym ,count-sym)))))))
+ (progn
+ (incf (aref ,idx ,count-sym))
+ ,@(loop for key being the hash-keys of tensor-table
+ collect (let ((hsh (gethash key tensor-table)))
+ `(incf ,(getf hsh :offset-sym) (aref ,(getf hsh :stride-sym) ,count-sym))))
+ (return t))))))))))
(defun tensor-copy (from to)
(declare (optimize (speed 3) (safety 0))
(type real-tensor to from))
- (let* ((rank (rank to))
- (dims (dimensions to))
- (t-strides (strides to))
- (f-strides (strides from))
- (t-store (store to))
- (f-store (store from))
- (idx (allocate-index-store rank)))
- (declare (type (index-array *) dims t-strides f-strides idx))
- (declare (type (real-array *) t-store f-store))
- (loop
- with of-t of-type index-type = (head to)
- with of-f of-type index-type = (head from)
- do (setf (aref t-store of-t) (aref f-store of-f))
- while (dotimes (i rank nil)
- (if (= (aref idx i) (1- (aref dims i)))
- (progn
- (setf (aref idx i) 0)
- (decf of-t (* (aref t-strides i) (1- (aref dims i))))
- (decf of-f (* (aref f-strides i) (1- (aref dims i)))))
- (progn
- (incf (aref idx i))
- (incf of-t (aref t-strides i))
- (incf of-f (aref f-strides i))
- (return t)))))))
+ (let ((dims (dimensions from)))
+ (mod-loop (idx dims)
+ (declare (type real-tensor to from))
+ (setf (tensor-ref to idx) (tensor-ref from idx)))))
+
+
+(let ((x (make-real-tensor-dims 100 100 100))
+ (y (make-real-tensor-dims 100 100 100)))
+ (mod-loop (idx #(100 100 100))
+ (declare (type real-tensor x y))
+ (setf (tensor-ref x idx) (random 1d0)))
+ (time (tensor-copy x y)))
(defmacro generate-typed-copy!-func (func store-type matrix-type blas-func)
;;Be very careful when using functions generated by this macro.
diff --git a/src/utilities.lisp b/src/utilities.lisp
index 794e30b..a475531 100644
--- a/src/utilities.lisp
+++ b/src/utilities.lisp
@@ -2,28 +2,28 @@
(defmacro mlet* (decls &rest body)
"
-mlet* ({ {(var*) | var} values-form &keyform declare type}*) form*
+ mlet* ({ {(var*) | var} values-form &keyform declare type}*) form*
-o var is just one symbol -> expands into let
-o var is a list -> expands into multiple-value-bind
+ o var is just one symbol -> expands into let
+ o var is a list -> expands into multiple-value-bind
-This macro also handles type declarations.
+ This macro also handles type declarations.
-Example:
-> (mlet* ((x 2 :type fixnum :declare ((optimize (safety 0) (speed 3))))
- ((a b) (floor 3) :type (nil fixnum)))
- (+ x b))
+ Example:
+ > (mlet* ((x 2 :type fixnum :declare ((optimize (safety 0) (speed 3))))
+ ((a b) (floor 3) :type (nil fixnum)))
+ (+ x b))
-expands into:
+ expands into:
-> (let ((x 2))
- (declare (optimize (safety 0) (speed 3))
- (type fixnum x))
- (multiple-value-bind (a b)
- (floor 3)
- (declare (ignore a)
- (type fixnum b))
- (+ x b)))
+ > (let ((x 2))
+ (declare (optimize (safety 0) (speed 3))
+ (type fixnum x))
+ (multiple-value-bind (a b)
+ (floor 3)
+ (declare (ignore a)
+ (type fixnum b))
+ (+ x b)))
"
(labels ((mlet-decl (vars type decls)
(when (or type decls)
@@ -57,13 +57,13 @@ expands into:
(defmacro let-rec (name arglist &rest code)
"
-(let-rec name ({var [init-form]}*) declaration* form*) => result*
-Works similar to \"let\" in Scheme.
+ (let-rec name ({var [init-form]}*) declaration* form*) => result*
+ Works similar to \"let\" in Scheme.
-Example:
-> (let-rec rev ((x '(1 2 3 4)) (ret nil))
- (if (null x) ret
- (rev (cdr x) (cons (car x) ret))))
+ Example:
+ > (let-rec rev ((x '(1 2 3 4)) (ret nil))
+ (if (null x) ret
+ (rev (cdr x) (cons (car x) ret))))
"
(let ((init (mapcar #'second arglist))
(args (mapcar #'first arglist)))
@@ -73,8 +73,8 @@ Example:
(defmacro with-gensyms (symlist &body body)
"
-(with-gensyms (var *) form*)
-Binds every variable in SYMLIST to a gensym."
+ (with-gensyms (var *) form*)
+ Binds every variable in SYMLIST to a gensym."
`(let ,(mapcar #'(lambda (sym)
`(,sym (gensym ,(symbol-name sym))))
symlist)
@@ -120,9 +120,9 @@ Binds every variable in SYMLIST to a gensym."
(defmacro if-ret (form &rest else-body)
"
-if-ret (form &rest else-body)
-Evaluate form, and if the form is not nil, then return it,
-else run else-body"
+ if-ret (form &rest else-body)
+ Evaluate form, and if the form is not nil, then return it,
+ else run else-body"
(let ((ret (gensym)))
`(let ((,ret ,form))
(or ,ret
-----------------------------------------------------------------------
Summary of changes:
AUTHORS | 4 +-
src/complex-tensor.lisp | 4 +
src/real-tensor.lisp | 4 +
src/standard-matrix.lisp | 2 +-
src/standard-tensor.lisp | 27 ++++---
src/tensor-copy.lisp | 184 +++++++++++++++++++++++++++-------------------
src/utilities.lisp | 56 +++++++-------
7 files changed, 162 insertions(+), 119 deletions(-)
hooks/post-receive
--
matlisp
|
