Menu
▾
▴
matlisp-commit
|
From: Akshay S. <ak...@us...> - 2013-07-22 17:17:11
|
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 03eedb3f3faa199ef9b76c30b95d4222d98dd9be (commit)
via 7e8e80cf438552059d8d05797da5a4f9320127d3 (commit)
via 222aee503ad0678516eaae1e638b016fb01efb09 (commit)
via 5f237cd125d3d50ae322fdeaf1db314f0562830e (commit)
from 95d41cef90f67e4d0b50ca7679ce5b5bffdd7532 (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 03eedb3f3faa199ef9b76c30b95d4222d98dd9be
Author: Akshay Srinivasan <aks...@gm...>
Date: Sun Jul 21 23:20:56 2013 -0700
Fixed the return in the incf computer.
diff --git a/src/base/einstein.lisp b/src/base/einstein.lisp
index cdadac9..648d4f8 100644
--- a/src/base/einstein.lisp
+++ b/src/base/einstein.lisp
@@ -86,9 +86,8 @@
:do (when (member ele idx-rem)
(return nil))
:finally (return t))
- (get-incs nil acc (cons nil decl)
- (cons `(setf ,(caar (cadr ofst)) ,(car (get-prop ten :head))) incs)
- ten ofst))
+ (values (append (make-list (length idxs)) decl)
+ (append (make-list (1- (length idxs))) (cons `(setf ,(caar (cadr ofst)) ,(car (get-prop ten :head))) incs))))
(t
(let* ((plst (get-prop ten))
(dsym (gensym (string+ "d-stp-" (symbol-name cidx) "-" (symbol-name ten))))
commit 7e8e80cf438552059d8d05797da5a4f9320127d3
Author: Akshay Srinivasan <aks...@gm...>
Date: Sun Jul 21 23:02:47 2013 -0700
Cleanups to einstein.lisp.
diff --git a/matlisp.asd b/matlisp.asd
index 08ce377..71aa515 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -112,6 +112,8 @@
;;
(:file "loopy"
:depends-on ("standard-tensor"))
+ (:file "einstein"
+ :depends-on ("standard-tensor"))
(:file "generic-copy"
:depends-on ("standard-tensor" "loopy"))
(:file "generic-swap"
diff --git a/src/base/tensor-comprehension.lisp b/src/base/einstein.lisp
similarity index 79%
rename from src/base/tensor-comprehension.lisp
rename to src/base/einstein.lisp
index f33a780..cdadac9 100644
--- a/src/base/tensor-comprehension.lisp
+++ b/src/base/einstein.lisp
@@ -1,12 +1,5 @@
(in-package :matlisp)
-(defparameter *contract-ops* '(sum))
-
-;;(defparameter *tgemv* '(contract (ref y i) (+ (* alpha (sum (k) (ref A i k) (ref x k))) (* beta (ref y i)))))
-
-(defparameter *tclause* '(einstein-sum (ref C i j) (* (ref A i k) (ref A j k))))
-(defparameter *mclause* '(einstein-sum (ref C i j) (* (ref A i k) (ref B k j))))
-
(defun get-cons (lst sym)
(if (atom lst) nil
(if (eq (car lst) sym)
@@ -17,17 +10,6 @@
(if (atom lst) (eql lst sym)
(or (has-sym (car lst) sym) (has-sym (cdr lst) sym))))
-(defun get-repeats (lst)
- (do ((tmp lst (cdr tmp))
- (ret nil (if (and (not (member (car tmp) ret)) (member (car tmp) (cdr tmp)))
- (cons (car tmp) ret)
- ret)))
- ((null tmp) ret)))
-
-(defun gensym-list (n)
- (loop :repeat n :collect (gensym)))
-
-
(defun mapcons (func lst keys)
(if (atom lst) lst
(let ((tlst (if (member (car lst) keys)
@@ -36,29 +18,20 @@
(if (atom tlst) tlst
(mapcar #'(lambda (x) (mapcons func x keys)) tlst)))))
-#+nil
-(mapcons #'(lambda (x) (let ((op (car x)))
- `(,(case op (* 't/f*) (+ 't/f+) (- 't/f-) (/ 't/f/))
- double-float
- ,@(cdr x))))
- '(* a (+ (ref a i j) c)) '(* + - /))
-#+nil
-(mapcons #'(lambda (x) t)
- '(* a (+ (ref a i j) c)) '(ref))
-
-
(defun loop-generator (type index-order place clause &key (testp t) (tight-iloop nil))
(let* ((refs (let ((tmp (get-cons (list place clause) 'ref))
(ret nil))
(loop :for ele :in tmp
- :do (setf ret (setadd ret ele #'equal)))
+ :do (setf ret (setadd ret ele #'equal)))
ret))
(tens (let ((ret nil))
(loop :for ele :in refs
- :do (setf ret (setadd ret (second ele))))
+ :do (setf ret (setadd ret (if (symbolp (second ele))
+ (second ele)
+ (error "error: tensor argument is not a symbol.")))))
ret))
(tlist (mapcar #'(lambda (sym)
- (let* ((gsym (gensym (symbol-name sym)))
+ (let* ((gsym sym)
(hsym (gensym (string+ "head-" (symbol-name sym)))))
`(:tensor (,gsym ,sym :type ,type)
:head (,hsym (head ,gsym) :type index-type)
@@ -196,37 +169,15 @@
,@(remove-if #'null (apply #'append
(mapcar #'(lambda (ten) (mapcar #'(lambda (x) (elt (fourth x) (position cidx index-order))) (get-prop ten :offsets))) tens))))))))))))
;;
- `(let-typed (,@(mapcar #'(lambda (ten) (get-prop ten :tensor)) tens))
+ `(locally
+ (declare (type ,type ,@tens))
(let-typed (,@(apply #'append (mapcar #'(lambda (ten) (mapcar #'(lambda (prop) (get-prop ten prop)) '(:head :store :strides :dimensions))) tens)))
(let-typed (,@(apply #'append (mapcar #'(lambda (ten) (mapcar #'(lambda (x) (car (second x))) (get-prop ten :offsets))) tens))
,@(remove-if #'null (apply #'append (mapcar #'(lambda (ten) (apply #'append (mapcar #'third (get-prop ten :offsets)))) tens))))
,@(when testp (testgen))
(very-quickly
- ,@(loopgen indices place clause)))))))))
-
-(loop-generator 'real-tensor '(k j i) (second *tclause*) (third *tclause*))
-(loop-generator 'real-tensor '(i j k) (second *mclause*) (third *mclause*) :tight-iloop t)
-
-
-(defmacro einstein-sum (type idx-order place clause)
- (loop-generator type idx-order place clause :tight-iloop t))
-
-(defun mm-test (a b c)
- (einstein-sum real-tensor (j k i) (ref c i j) (* (ref a i k) (ref b k j))))
-
-(let ((x (copy! #2a((1 2) (3 4)) (zeros '(2 2))))
- (y (copy! #2a((4 5) (6 5)) (zeros '(2 2))))
- (z (zeros '(2 2))))
- (mm-test x y z)
- z)
+ ,@(loopgen indices place clause))))
+ ,(cadr place))))))
-(let ((x (zeros '(1000 1000)))
- (y (zeros '(1000 1000)))
- (z (zeros '(1000 1000))))
- (let-typed ((sto-x (store x) :type (simple-array double-float))
- (sto-y (store y) :type (simple-array double-float)))
- (loop :for i :from 0 :below (* 1000 1000)
- :do (setf (aref sto-x i) (random 1d0)
- (aref sto-y i) (random 1d0))))
- (time (mm-test x y z))
- t)
+(defmacro einstein-sum (type idx-order place clause &optional (tightp nil))
+ (loop-generator type idx-order place clause :tight-iloop tightp))
commit 222aee503ad0678516eaae1e638b016fb01efb09
Author: Akshay Srinivasan <aks...@gm...>
Date: Sun Jul 21 17:52:33 2013 -0700
finished writing a very cool einstein summation macro :)
diff --git a/src/base/tensor-comprehension.lisp b/src/base/tensor-comprehension.lisp
index a0fdc73..f33a780 100644
--- a/src/base/tensor-comprehension.lisp
+++ b/src/base/tensor-comprehension.lisp
@@ -4,7 +4,8 @@
;;(defparameter *tgemv* '(contract (ref y i) (+ (* alpha (sum (k) (ref A i k) (ref x k))) (* beta (ref y i)))))
-(defparameter *tclause* '(einstein-sum (ref C i j) (* (ref A i k) (ref B k j))))
+(defparameter *tclause* '(einstein-sum (ref C i j) (* (ref A i k) (ref A j k))))
+(defparameter *mclause* '(einstein-sum (ref C i j) (* (ref A i k) (ref B k j))))
(defun get-cons (lst sym)
(if (atom lst) nil
@@ -12,6 +13,10 @@
(list lst)
(append (get-cons (car lst) sym) (get-cons (cdr lst) sym)))))
+(defun has-sym (lst sym)
+ (if (atom lst) (eql lst sym)
+ (or (has-sym (car lst) sym) (has-sym (cdr lst) sym))))
+
(defun get-repeats (lst)
(do ((tmp lst (cdr tmp))
(ret nil (if (and (not (member (car tmp) ret)) (member (car tmp) (cdr tmp)))
@@ -22,126 +27,206 @@
(defun gensym-list (n)
(loop :repeat n :collect (gensym)))
-#+nil
-(defun loop-gen (idx ret einx)
- (if (null idx) code
- (destructuring-bind (var repeat) (car idx)
- `(loop :for ,var :of-type index-type :from ,start :below ,end
- :do ,(loop-gen (cdr idx) code)))))
-
-(tensor-args (get-cons (cddr clause) 'ref))
- (code-idx (get-repeats (apply #'append (mapcar #'cddr tensor-args))))
- (arg-idx (let ((ret nil))
- (mapcar #'(lambda (x) (if (symbolp x) (setf ret (setadd ret x)))) (cddr arg))
- ret))
- (idxs (append arg-idx code-idx))
- (dims (apply #'append (mapcar #'(lambda (x) (loop :for idx :in (cddr x)
- :counting t :into i
- :when (member idx idxs)
- :collect `(,idx (aref (dimensions ,(cadr x)) ,(1- i))))) tensor-args)))
-
- (osyms (zipsym (mapcar #'(lambda (x) `(head ,(car x))) tsyms)))
- (stosyms (zipsym (mapcar #'(lambda (x) `(store ,(car x))) tsyms)))
- (stdsyms (zipsym (mapcar #'(lambda (x) `(strides ,(car x))) tsyms)))
- (dimsyms (zipsym (mapcar #'(lambda (x) `(dimensions ,(car x))) tsyms))))
-
(defun mapcons (func lst keys)
- (cond
- ((atom lst) lst)
- ((member (car lst) keys)
- (funcall func lst))
- (t
- (mapcar #'(lambda (x) (mapcons func x keys)) lst))))
-
-(mapcons #'(lambda (x) `(aref (store ,(cadr x)) ,@(cddr x)))
- *tclause* '(ref))
-
-
- (loopgen (idxs cclause place &optional (start? t))
- `(loop
- :with ... :of-type index-type := ...
- :with ... :of-type index-type := ...
- :for (car idxs) :of-type index-type :from 0 :below
-
- ))
-
-
-(defun loop-generator (type clause &optional (testp t))
- (let* ((ten-syms (mapcar #'(lambda (x)
- (let* ((sym (second x))
- (gsym (gensym (symbol-name sym))))
- `((,gsym ,sym)
- (,(gensym (string+ "head-" (symbol-name sym))) (head ,gsym))
- (,(gensym (string+ "store-" (symbol-name sym))) (store ,gsym))
- (,(gensym (string+ "strides-" (symbol-name sym))) (strides ,gsym))
- (,(gensym (string+ "dimensions-" (symbol-name sym))) (dimensions ,gsym)))))
- (get-cons (cdr clause) 'ref)))
- (offsets nil)
- (ranges nil))
- (labels ((get-plst (x)
- (find x ten-syms :key #'cadar :test #'eql))
+ (if (atom lst) lst
+ (let ((tlst (if (member (car lst) keys)
+ (funcall func lst)
+ lst)))
+ (if (atom tlst) tlst
+ (mapcar #'(lambda (x) (mapcons func x keys)) tlst)))))
+
+#+nil
+(mapcons #'(lambda (x) (let ((op (car x)))
+ `(,(case op (* 't/f*) (+ 't/f+) (- 't/f-) (/ 't/f/))
+ double-float
+ ,@(cdr x))))
+ '(* a (+ (ref a i j) c)) '(* + - /))
+#+nil
+(mapcons #'(lambda (x) t)
+ '(* a (+ (ref a i j) c)) '(ref))
+
+
+(defun loop-generator (type index-order place clause &key (testp t) (tight-iloop nil))
+ (let* ((refs (let ((tmp (get-cons (list place clause) 'ref))
+ (ret nil))
+ (loop :for ele :in tmp
+ :do (setf ret (setadd ret ele #'equal)))
+ ret))
+ (tens (let ((ret nil))
+ (loop :for ele :in refs
+ :do (setf ret (setadd ret (second ele))))
+ ret))
+ (tlist (mapcar #'(lambda (sym)
+ (let* ((gsym (gensym (symbol-name sym)))
+ (hsym (gensym (string+ "head-" (symbol-name sym)))))
+ `(:tensor (,gsym ,sym :type ,type)
+ :head (,hsym (head ,gsym) :type index-type)
+ :store (,(gensym (string+ "store-" (symbol-name sym))) (store ,gsym) :type ,(store-type type))
+ :strides (,(gensym (string+ "strides-" (symbol-name sym))) (strides ,gsym) :type index-store-vector)
+ :dimensions (,(gensym (string+ "dimensions-" (symbol-name sym))) (dimensions ,gsym) :type index-store-vector))))
+ tens))
+ (indices (let ((tmp nil)
+ (idx-pos (apply #'append (mapcar #'(lambda (x) (loop :for ele :in (cddr x)
+ :counting t :into i
+ :collect `(,ele (,(cadr x) ,(1- i))))) refs))))
+ (loop :for ipos :in idx-pos
+ :do (let ((cdim (find (car ipos) tmp :key #'car)))
+ (if cdim
+ (rplacd (last cdim) (cdr ipos))
+ (push ipos tmp))))
+ (loop :for idx :in tmp
+ :do (assert (member (car idx) index-order) nil "Error index ~a not found in the index-order." (car idx)))
+ (loop :for idx :in index-order
+ :collect (let ((cdim (find idx tmp :key #'car)))
+ (assert (not (null cdim)) nil "Error index ~a not found in the expression." idx)
+ cdim))))
+ (idx-d (let ((refrem (mapcons #'(lambda (x) (declare (ignore x)) t)
+ clause '(ref))))
+ (remove-if #'null (mapcar #'(lambda (x) (when (has-sym refrem x) x)) (mapcar #'car indices))))))
+ (labels ((get-prop (x &optional prop)
+ (let ((plst (find x tlist :key #'(lambda (x) (cadr (getf x :tensor))))))
+ (if prop
+ (getf plst prop)
+ plst)))
(get-offset (x)
- (let ((ofst (find x offsets :key #'cadr :test #'equal)))
- (if ofst
- (car ofst)
- (let ((ofsym (gensym (string+ "offset-" (symbol-name (car x))))))
- (push (list ofsym x) offsets)
- ofsym))))
- (testgen ()
- (let ((dims (apply #'append (mapcar #'(lambda (x) (loop :for ele :in (cdr (cadr x))
- :counting t :into i
- :collect (let ((plst (get-plst (car (cadr x)))))
- `(,ele (aref ,(car (elt plst 4)) ,(1- i)))))) offsets))))
- (loop :for ele :in dims
- :do (let ((cdim (find (car ele) ranges :key #'car :test #'eql)))
- (if cdim
- (rplacd (last cdim) (cdr ele))
- (push ele ranges))))
- (when testp
- `((assert (and ,@(mapcar #'(lambda (x) `(= ,@(cdr x))) ranges)) nil "error: arguments are not of appropriate sizes.")))))
- (loopgen (idxs place clause &optional (startp t))
- (let ((cidx (caar idxs)))
- `((let*-typed (,@(remove-if #'null
- (mapcar #'(lambda (x)
- (if (or (member cidx (cdr (cadr x))) startp)
- (let ((offset (gensym (string+ "of-" (symbol-name cidx) "-" (symbol-name (car (cadr x)))))))
- `(:with ,offset :of-type index-type := ...
- :for ,(car x) :of-type index-type := ,(if startp
- (let ((plst (get-plst (car (cadr x)))))
- (car (elt plst 1)))
- (car x))
- :then (the index-type (+ ,offset ,(car x))))
- nil))
- offsets)))
-
- (loop
- :for ,cidx :of-type index-type :from 0 :below ,(cadr (car idxs))
- ,@(apply #'append (remove-if #'null (mapcar #'(lambda (x)
- (if (or (member cidx (cdr (cadr x))) startp)
- (let ((offset (gensym (string+ "of-" (symbol-name cidx) "-" (symbol-name (car (cadr x)))))))
- `(:with ,offset :of-type index-type := ...
- :for ,(car x) :of-type index-type := ,(if startp
- (let ((plst (get-plst (car (cadr x)))))
- (car (elt plst 1)))
- (car x))
- :then (the index-type (+ ,offset ,(car x))))
- nil))
- offsets)))
- )))))
- (let* ((cclause (mapcons #'(lambda (x)
- (let* ((plst (get-plst (cadr x)))
- (ofset-sym (get-offset (cdr x))))
- `(t/store-ref ,type ,(caaddr plst) ,ofset-sym)))
- clause '(ref))))
- `(let (,@(mapcar #'car ten-syms))
- (declare (type ,type ,@(mapcar #'caar ten-syms)))
- (let (,@(apply #'append (mapcar #'cdr ten-syms)))
- (declare (type index-type ,@(mapcar #'caadr ten-syms))
- (type ,(store-type type) ,@(mapcar #'caaddr ten-syms))
- (type index-store-vector ,@(mapcar #'car (apply #'append (mapcar #'cdddr ten-syms)))))
- ,@(testgen)
- ,@(loopgen ranges (cadr cclause) (caddr cclause) t)))))))
-
-
-(loop-generator 'real-tensor *tclause*)
+ (caar (second (find (cdr x) (get-prop (car x) :offsets) :key #'car :test #'list-eq)))))
+ ;;Populate offsets
+ (loop :for ref :in refs
+ :do (let* ((plist (get-prop (second ref)))
+ (ofsym (gensym (string+ "offset-" (symbol-name (second (getf plist :tensor))))))
+ (ret `((,ofsym ,(car (getf plist :head)) :type index-type)
+ (,(gensym (string+ "ref-" (symbol-name (second (getf plist :tensor))))) (t/store-ref ,type ,(car (getf plist :store)) ,ofsym) :type ,(field-type type)))))
+ (if (getf plist :offsets)
+ (setf (getf plist :offsets) (append (getf plist :offsets) (list (list (cddr ref) ret))))
+ (rplacd (last plist) (list :offsets (list (list (cddr ref) ret)))))))
+ ;;Compute offset increments
+ (let ((rev (reverse indices)))
+ (labels ((get-incs (idxs acc decl incs ten ofst)
+ (if (null idxs) (values decl incs)
+ (let* ((clst (car idxs))
+ (cidx (car clst))
+ (idx-rem (mapcar #'car idxs))
+ (tloop (and tight-iloop (eql cidx (car (last index-order))))))
+ (cond
+ ((loop :for ele :in (car ofst)
+ :do (when (member ele idx-rem)
+ (return nil))
+ :finally (return t))
+ (get-incs nil acc (cons nil decl)
+ (cons `(setf ,(caar (cadr ofst)) ,(car (get-prop ten :head))) incs)
+ ten ofst))
+ (t
+ (let* ((plst (get-prop ten))
+ (dsym (gensym (string+ "d-stp-" (symbol-name cidx) "-" (symbol-name ten))))
+ (memp (member cidx (car ofst)))
+ (stp (when memp `(aref ,(car (getf plst :strides)) ,(position cidx (car ofst))))))
+ (get-incs (cdr idxs) (if memp (list `(the index-type (* ,(if tloop 1 stp) (aref ,(car (getf plst :dimensions)) ,(position cidx (car ofst)))))) nil)
+ (if (or tloop (and (null acc) (not memp))) (cons nil decl)
+ (cons
+ (if memp
+ `(,dsym ,(if (null acc) stp `(the index-type (- ,stp ,@acc))) :type index-type)
+ `(,dsym (the index-type (- ,@acc)) :type index-type))
+ decl))
+ (if (and (null acc) (not memp)) (cons nil incs)
+ (cons `(incf ,(caar (cadr ofst)) ,@(unless tloop `(,dsym))) incs))
+ ten ofst))))))))
+ (mapcar #'(lambda (ten)
+ (loop :for ofst :in (get-prop ten :offsets)
+ :do (rplacd (last ofst) (multiple-value-list (get-incs rev nil nil nil ten ofst)))))
+ tens)))
+ ;;
+ (labels ((testgen ()
+ `((assert (and ,@(mapcar #'(lambda (idx)
+ `(= ,@(mapcar #'(lambda (x) `(aref ,(car (get-prop (car x) :dimensions)) ,(cadr x))) (cdr idx)))) indices))
+ nil "error: arguments are not of appropriate sizes.")
+ ,@(when tight-iloop
+ `((assert (= 1 ,@(mapcar #'(lambda (x) `(aref ,(car (get-prop (car x) :strides)) ,(cadr x))) (cdar (last indices)))) nil "error: Inner loop strides are not 1.")))))
+ (t/compile (place clause)
+ (let* ((cclause (mapcons #'(lambda (x)
+ (let* ((plst (get-prop (cadr x)))
+ (ofset-sym (get-offset (cdr x))))
+ `(t/store-ref ,type ,(car (getf plst :store)) ,ofset-sym)))
+ clause '(ref)))
+ (ftype (field-type type)))
+ (setf cclause
+ (mapcons #'(lambda (x)
+ (let ((op (car x)))
+ `(,(case op (* 't/f*) (+ 't/f+) (- 't/f-) (/ 't/f/))
+ ,ftype
+ ,@(cdr x))))
+ cclause '(* + - /)))
+ (let ((plst (get-prop (cadr place)))
+ (valsym (gensym "value")))
+ `((let-typed ((,valsym (t/f+ ,ftype (t/store-ref ,type ,(car (getf plst :store)) ,(get-offset (cdr place)))
+ ,cclause ) :type ,ftype))
+ (t/store-set ,type ,valsym ,(car (getf plst :store)) ,(get-offset (cdr place))))))))
+ (loopgen (idxs place clause)
+ (if (null idxs) (t/compile place clause)
+ (let ((cidx (caar idxs))
+ (clst (car idxs)))
+ (let ((tdecl (let ((ilist (mapcar #'car idxs)))
+ (remove-if #'null
+ (apply #'append
+ (mapcar #'(lambda (ten)
+ (mapcar #'(lambda (ofs)
+ (when (loop :for idx :in (car ofs)
+ :do (when (member idx ilist)
+ (return nil))
+ :finally (return t))
+ (let ((decl (cadr (cadr ofs))))
+ (setf clause (mapcons #'(lambda (x)
+ (if (and (eql (cadr x) ten) (equal (cddr x) (car ofs)))
+ (car decl)
+ x))
+ clause '(ref)))
+ decl)))
+ (get-prop ten :offsets)))
+ (setrem tens (cadr place))))))))
+ (list
+ (recursive-append
+ (unless (null tdecl)
+ `(let-typed (,@tdecl)))
+ `(loop ,@(let ((repl `(aref ,(car (get-prop (car (cadr clst)) :dimensions)) ,(cadr (cadr clst)))))
+ (if (member cidx idx-d)
+ `(:for ,cidx :of-type index-type :from 0 :below ,repl)
+ `(:repeat ,repl)))
+ :do (progn
+ ,@(loopgen (cdr idxs) place clause)
+ ,@(remove-if #'null (apply #'append
+ (mapcar #'(lambda (ten) (mapcar #'(lambda (x) (elt (fourth x) (position cidx index-order))) (get-prop ten :offsets))) tens))))))))))))
+ ;;
+ `(let-typed (,@(mapcar #'(lambda (ten) (get-prop ten :tensor)) tens))
+ (let-typed (,@(apply #'append (mapcar #'(lambda (ten) (mapcar #'(lambda (prop) (get-prop ten prop)) '(:head :store :strides :dimensions))) tens)))
+ (let-typed (,@(apply #'append (mapcar #'(lambda (ten) (mapcar #'(lambda (x) (car (second x))) (get-prop ten :offsets))) tens))
+ ,@(remove-if #'null (apply #'append (mapcar #'(lambda (ten) (apply #'append (mapcar #'third (get-prop ten :offsets)))) tens))))
+ ,@(when testp (testgen))
+ (very-quickly
+ ,@(loopgen indices place clause)))))))))
+
+(loop-generator 'real-tensor '(k j i) (second *tclause*) (third *tclause*))
+(loop-generator 'real-tensor '(i j k) (second *mclause*) (third *mclause*) :tight-iloop t)
+
+
+(defmacro einstein-sum (type idx-order place clause)
+ (loop-generator type idx-order place clause :tight-iloop t))
+
+(defun mm-test (a b c)
+ (einstein-sum real-tensor (j k i) (ref c i j) (* (ref a i k) (ref b k j))))
+
+(let ((x (copy! #2a((1 2) (3 4)) (zeros '(2 2))))
+ (y (copy! #2a((4 5) (6 5)) (zeros '(2 2))))
+ (z (zeros '(2 2))))
+ (mm-test x y z)
+ z)
+
+(let ((x (zeros '(1000 1000)))
+ (y (zeros '(1000 1000)))
+ (z (zeros '(1000 1000))))
+ (let-typed ((sto-x (store x) :type (simple-array double-float))
+ (sto-y (store y) :type (simple-array double-float)))
+ (loop :for i :from 0 :below (* 1000 1000)
+ :do (setf (aref sto-x i) (random 1d0)
+ (aref sto-y i) (random 1d0))))
+ (time (mm-test x y z))
+ t)
diff --git a/tests/loopy-tests.lisp b/tests/loopy-tests.lisp
index ece1513..b7ad434 100644
--- a/tests/loopy-tests.lisp
+++ b/tests/loopy-tests.lisp
@@ -1,3 +1,4 @@
+(in-package :matlisp)
(defun tdcopy (n)
(let* ((t-a (make-real-tensor-dims n n n))
@@ -36,9 +37,9 @@
(make-array (length dims) :element-type 'index-type :initial-contents dims))
(defun test-mm-lisp (n)
- (let ((t-a (make-real-tensor n n))
- (t-b (make-real-tensor n n))
- (t-c (make-real-tensor n n)))
+ (let ((t-a (zeros (list n n)))
+ (t-b (zeros (list n n)))
+ (t-c (zeros (list n n))))
(declare (type real-tensor t-a t-b t-c))
(let ((st-a (store t-a))
(st-b (store t-b))
@@ -55,7 +56,7 @@
(hd-a (head t-a))
(hd-b (head t-b))
(hd-c (head t-c)))
- (declare (type real-store-vector st-a st-b st-c)
+ (declare (type (simple-array double-float (*)) st-a st-b st-c)
(type index-type rstrd-a cstrd-a rstrd-b cstrd-b rstrd-c cstrd-c nr-c
nc-c nc-a hd-a hd-b hd-c))
(mod-dotimes (idx (dimensions t-a))
@@ -77,7 +78,7 @@
do (loop repeat nc-a
for of-a of-type index-type = rof-a then (+ of-a cstrd-a)
for of-b of-type index-type = cof-b then (+ of-b rstrd-b)
- summing (* (aref st-a of-a) (aref st-b of-b)) into sum of-type real-type
+ summing (* (aref st-a of-a) (aref st-b of-b)) into sum of-type double
finally (setf (aref st-c of-c) sum))))
#+nil
(mod-dotimes (idx (dimensions t-c))
@@ -101,12 +102,17 @@
do (incf (aref st-c of-c) (* (aref st-a of-a) (aref st-b of-b))))))
(values t-a t-b t-c))))
+(deftype real-store-vector ()
+ '(simple-array double-float (*)))
+
+(deftype real-type ()
+ 'double-float)
(defun test-mm-lisp (n)
(declare (type fixnum n))
- (let ((A (make-real-tensor n n))
- (B (make-real-tensor n n))
- (C (make-real-tensor n n)))
+ (let ((A (zeros (list n n)))
+ (B (zeros (list n n)))
+ (C (zeros (list n n))))
(let-typed ((nr-C (nrows C) :type index-type)
(nc-C (ncols C) :type index-type)
(dotl (ncols A) :type index-type)
@@ -140,8 +146,8 @@
(loop :repeat nc-C
:do (progn
(incf (aref sto-C of-C) (* ele-A (aref sto-B of-B)))
- (incf of-C cstp-C)
- (incf of-B cstp-B)))
+ (incf of-C #+nil cstp-C)
+ (incf of-B #+nil cstp-B)))
(decf of-C r.cstp-C)
(incf of-A cstp-A)
(incf of-B d.rstp-B)))
@@ -150,6 +156,7 @@
(setf of-B hd-B))))))
t)))
+
(defun test-mm-lisp-lin (n)
(declare (type fixnum n))
(let ((A (make-real-tensor n n))
commit 5f237cd125d3d50ae322fdeaf1db314f0562830e
Author: Akshay Srinivasan <aks...@gm...>
Date: Thu Jul 18 13:45:43 2013 -0700
Saving work on the tensor-comprehension feature.
diff --git a/matlisp.asd b/matlisp.asd
index c28a1f4..08ce377 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -128,7 +128,6 @@
:components ((:file "numeric")
#+maxima
(:file "symbolic-tensor")
- #+nil
(:file "matrix"
:depends-on ("numeric"))))
(:module "matlisp-level-1"
@@ -150,7 +149,6 @@
(
(:file "trans"
:depends-on ("scal" "copy")))))
-
#+nil
(:module "matlisp-level-2"
:pathname "level-2"
diff --git a/src/base/tensor-comprehension.lisp b/src/base/tensor-comprehension.lisp
new file mode 100644
index 0000000..a0fdc73
--- /dev/null
+++ b/src/base/tensor-comprehension.lisp
@@ -0,0 +1,147 @@
+(in-package :matlisp)
+
+(defparameter *contract-ops* '(sum))
+
+;;(defparameter *tgemv* '(contract (ref y i) (+ (* alpha (sum (k) (ref A i k) (ref x k))) (* beta (ref y i)))))
+
+(defparameter *tclause* '(einstein-sum (ref C i j) (* (ref A i k) (ref B k j))))
+
+(defun get-cons (lst sym)
+ (if (atom lst) nil
+ (if (eq (car lst) sym)
+ (list lst)
+ (append (get-cons (car lst) sym) (get-cons (cdr lst) sym)))))
+
+(defun get-repeats (lst)
+ (do ((tmp lst (cdr tmp))
+ (ret nil (if (and (not (member (car tmp) ret)) (member (car tmp) (cdr tmp)))
+ (cons (car tmp) ret)
+ ret)))
+ ((null tmp) ret)))
+
+(defun gensym-list (n)
+ (loop :repeat n :collect (gensym)))
+
+#+nil
+(defun loop-gen (idx ret einx)
+ (if (null idx) code
+ (destructuring-bind (var repeat) (car idx)
+ `(loop :for ,var :of-type index-type :from ,start :below ,end
+ :do ,(loop-gen (cdr idx) code)))))
+
+(tensor-args (get-cons (cddr clause) 'ref))
+ (code-idx (get-repeats (apply #'append (mapcar #'cddr tensor-args))))
+ (arg-idx (let ((ret nil))
+ (mapcar #'(lambda (x) (if (symbolp x) (setf ret (setadd ret x)))) (cddr arg))
+ ret))
+ (idxs (append arg-idx code-idx))
+ (dims (apply #'append (mapcar #'(lambda (x) (loop :for idx :in (cddr x)
+ :counting t :into i
+ :when (member idx idxs)
+ :collect `(,idx (aref (dimensions ,(cadr x)) ,(1- i))))) tensor-args)))
+
+ (osyms (zipsym (mapcar #'(lambda (x) `(head ,(car x))) tsyms)))
+ (stosyms (zipsym (mapcar #'(lambda (x) `(store ,(car x))) tsyms)))
+ (stdsyms (zipsym (mapcar #'(lambda (x) `(strides ,(car x))) tsyms)))
+ (dimsyms (zipsym (mapcar #'(lambda (x) `(dimensions ,(car x))) tsyms))))
+
+
+(defun mapcons (func lst keys)
+ (cond
+ ((atom lst) lst)
+ ((member (car lst) keys)
+ (funcall func lst))
+ (t
+ (mapcar #'(lambda (x) (mapcons func x keys)) lst))))
+
+(mapcons #'(lambda (x) `(aref (store ,(cadr x)) ,@(cddr x)))
+ *tclause* '(ref))
+
+
+ (loopgen (idxs cclause place &optional (start? t))
+ `(loop
+ :with ... :of-type index-type := ...
+ :with ... :of-type index-type := ...
+ :for (car idxs) :of-type index-type :from 0 :below
+
+ ))
+
+
+(defun loop-generator (type clause &optional (testp t))
+ (let* ((ten-syms (mapcar #'(lambda (x)
+ (let* ((sym (second x))
+ (gsym (gensym (symbol-name sym))))
+ `((,gsym ,sym)
+ (,(gensym (string+ "head-" (symbol-name sym))) (head ,gsym))
+ (,(gensym (string+ "store-" (symbol-name sym))) (store ,gsym))
+ (,(gensym (string+ "strides-" (symbol-name sym))) (strides ,gsym))
+ (,(gensym (string+ "dimensions-" (symbol-name sym))) (dimensions ,gsym)))))
+ (get-cons (cdr clause) 'ref)))
+ (offsets nil)
+ (ranges nil))
+ (labels ((get-plst (x)
+ (find x ten-syms :key #'cadar :test #'eql))
+ (get-offset (x)
+ (let ((ofst (find x offsets :key #'cadr :test #'equal)))
+ (if ofst
+ (car ofst)
+ (let ((ofsym (gensym (string+ "offset-" (symbol-name (car x))))))
+ (push (list ofsym x) offsets)
+ ofsym))))
+ (testgen ()
+ (let ((dims (apply #'append (mapcar #'(lambda (x) (loop :for ele :in (cdr (cadr x))
+ :counting t :into i
+ :collect (let ((plst (get-plst (car (cadr x)))))
+ `(,ele (aref ,(car (elt plst 4)) ,(1- i)))))) offsets))))
+ (loop :for ele :in dims
+ :do (let ((cdim (find (car ele) ranges :key #'car :test #'eql)))
+ (if cdim
+ (rplacd (last cdim) (cdr ele))
+ (push ele ranges))))
+ (when testp
+ `((assert (and ,@(mapcar #'(lambda (x) `(= ,@(cdr x))) ranges)) nil "error: arguments are not of appropriate sizes.")))))
+ (loopgen (idxs place clause &optional (startp t))
+ (let ((cidx (caar idxs)))
+ `((let*-typed (,@(remove-if #'null
+ (mapcar #'(lambda (x)
+ (if (or (member cidx (cdr (cadr x))) startp)
+ (let ((offset (gensym (string+ "of-" (symbol-name cidx) "-" (symbol-name (car (cadr x)))))))
+ `(:with ,offset :of-type index-type := ...
+ :for ,(car x) :of-type index-type := ,(if startp
+ (let ((plst (get-plst (car (cadr x)))))
+ (car (elt plst 1)))
+ (car x))
+ :then (the index-type (+ ,offset ,(car x))))
+ nil))
+ offsets)))
+
+ (loop
+ :for ,cidx :of-type index-type :from 0 :below ,(cadr (car idxs))
+ ,@(apply #'append (remove-if #'null (mapcar #'(lambda (x)
+ (if (or (member cidx (cdr (cadr x))) startp)
+ (let ((offset (gensym (string+ "of-" (symbol-name cidx) "-" (symbol-name (car (cadr x)))))))
+ `(:with ,offset :of-type index-type := ...
+ :for ,(car x) :of-type index-ty...
[truncated message content] |
Thanks for helping keep SourceForge clean.
X