Menu
▾
▴
[Matlisp-commit] [matlisp-git]matlisp branch classy updated. 2012-02-23-242-g03eedb3
|
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-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*)
diff --git a/src/classes/matrix.lisp b/src/classes/matrix.lisp
index 9544477..81c4034 100644
--- a/src/classes/matrix.lisp
+++ b/src/classes/matrix.lisp
@@ -47,7 +47,7 @@
(or (row-matrix-p matrix) (col-matrix-p matrix)))
(definline square-matrix-p (matrix)
- (and (square-p matrix) (matrix-p matrix)))
+ (and (tensor-matrixp matrix) (tensor-squarep matrix)))
;; ;;
;; (defgeneric fill-matrix (matrix fill-element)
diff --git a/src/ffi/f77-ffi.lisp b/src/ffi/f77-ffi.lisp
index 3fad009..e3a9843 100644
--- a/src/ffi/f77-ffi.lisp
+++ b/src/ffi/f77-ffi.lisp
@@ -11,341 +11,342 @@
(in-package #:matlisp-ffi)
(eval-when (:compile-toplevel :load-toplevel :execute)
- (definline %f77.string-p (type)
- "
+
+(definline %f77.string-p (type)
+ "
Checks if the given type is a string."
- (eq type :string))
+ (eq type :string))
- (definline %f77.array-p (type)
- "
+(definline %f77.array-p (type)
+ "
Checks if the given type is an array."
- (and (listp type) (eq (car type) '*)))
+ (and (listp type) (eq (car type) '*)))
- (definline %f77.cast-as-array-p (type)
- "
+(definline %f77.cast-as-array-p (type)
+ "
Checks if the given type is - or has to be passed as - an array."
- (or (when (listp type)
- (eq (car type) '*))
- (eq type :complex-single-float)
- (eq type :complex-double-float)))
-
- ;; Check if the given type is a callback.
- (definline %f77.callback-type-p (type)
- "
+ (or (when (listp type)
+ (eq (car type) '*))
+ (eq type :complex-single-float)
+ (eq type :complex-double-float)))
+
+;; Check if the given type is a callback.
+(definline %f77.callback-type-p (type)
+ "
Checks if the given type is a callback"
- (and (listp type) (eq (first type) :callback)))
-
- ;; Get the equivalent CFFI type.
- ;; If the type is an array, get the type of the array element type.
- (defun %f77.cffi-type (type)
- "Convert the given matlisp-ffi type into one understood by CFFI."
- (cond
- ((and (listp type) (eq (first type) '*))
- `(:pointer ,(%f77.cffi-type (second type))))
- ((%f77.callback-type-p type)
- `(:pointer ,(%f77.cffi-type :callback)))
- ((eq type :complex-single-float)
- `(:pointer ,(%f77.cffi-type :single-float)))
- ((eq type :complex-double-float)
- `(:pointer ,(%f77.cffi-type :double-float)))
- (t (case type
- (:void :void)
- (:integer :int32)
- (:character :char)
- (:long :int64)
- (:single-float :float)
- (:double-float :double)
- (:string :string)
- ;; Pass a pointer to the function.
- (:callback :void)
- (t (error 'unknown-token :token type
- :message "Don't know the given Fortran type."))))))
-
- (defun %f77.get-return-type (type)
- "
+ (and (listp type) (eq (first type) :callback)))
+
+;; Get the equivalent CFFI type.
+;; If the type is an array, get the type of the array element type.
+(defun %f77.cffi-type (type)
+ "Convert the given matlisp-ffi type into one understood by CFFI."
+ (cond
+ ((and (listp type) (eq (first type) '*))
+ `(:pointer ,(%f77.cffi-type (second type))))
+ ((%f77.callback-type-p type)
+ `(:pointer ,(%f77.cffi-type :callback)))
+ ((eq type :complex-single-float)
+ `(:pointer ,(%f77.cffi-type :single-float)))
+ ((eq type :complex-double-float)
+ `(:pointer ,(%f77.cffi-type :double-float)))
+ (t (case type
+ (:void :void)
+ (:integer :int32)
+ (:character :char)
+ (:long :int64)
+ (:single-float :float)
+ (:double-float :double)
+ (:string :string)
+ ;; Pass a pointer to the function.
+ (:callback :void)
+ (t (error 'unknown-token :token type
+ :message "Don't know the given Fortran type."))))))
+
+(defun %f77.get-return-type (type)
+ "
Return type understood by CFFI. Note that unlike arguments fortran
functions return-by-value."
- (if (or (%f77.cast-as-array-p type) (%f77.callback-type-p type))
- (error 'invalid-type :given type :expected '(not (or (%f77.cast-as-array-p type)
- (%f77.callback-type-p type)))
- :message "A Fortran function cannot return the given type.")
- (%f77.cffi-type type)))
-
- (definline %f77.output-p (style)
- "
+ (if (or (%f77.cast-as-array-p type) (%f77.callback-type-p type))
+ (error 'invalid-type :given type :expected '(not (or (%f77.cast-as-array-p type)
+ (%f77.callback-type-p type)))
+ :message "A Fortran function cannot return the given type.")
+ (%f77.cffi-type type)))
+
+(definline %f77.output-p (style)
+ "
Checks if style implies output."
- (member style '(:output :input-output :workspace-output)))
+ (member style '(:output :input-output :workspace-output)))
- (definline %f77.input-p (style)
- "
+(definline %f77.input-p (style)
+ "
Checks if style implies input."
- (member style '(:input :input-value :input-reference :workspace)))
+ (member style '(:input :input-value :input-reference :workspace)))
- (defun %f77.get-read-in-type (type &optional (style :input))
- "
+(defun %f77.get-read-in-type (type &optional (style :input))
+ "
Get the input type to be passed to CFFI."
- (assert (member style +ffi-styles+) nil 'unknown-token :token style
- :message "Don't know how to handle style.")
- (cond
- ;; Can't do much else if type is an array/complex or input is passed-by-value.
- ((or (%f77.callback-type-p type)
- (%f77.cast-as-array-p type)
- (eq style :input-value))
- (%f77.cffi-type type))
- ;; else pass-by-reference
- (t
- `(:pointer ,(%f77.cffi-type type)))))
-
- (defun %f77.parse-fortran-parameters (body)
- "
+ (assert (member style +ffi-styles+) nil 'unknown-token :token style
+ :message "Don't know how to handle style.")
+ (cond
+ ;; Can't do much else if type is an array/complex or input is passed-by-value.
+ ((or (%f77.callback-type-p type)
+ (%f77.cast-as-array-p type)
+ (eq style :input-value))
+ (%f77.cffi-type type))
+ ;; else pass-by-reference
+ (t
+ `(:pointer ,(%f77.cffi-type type)))))
+
+(defun %f77.parse-fortran-parameters (body)
+ "
Parse fortran parameters and convert parameters to native C90 types (and
add additional function parameters)."
- (multiple-value-bind (doc pars)
- (parse-doc-&-parameters body)
- (declare (ignore doc))
-
- (let* ((aux-pars nil)
- (new-pars
- (mapcar #'(lambda (decl)
- (destructuring-bind (name type &optional (style :input-reference)) decl
- (case type
- (:string
- ;; String lengths are appended to the function arguments,
- ;; passed by value.
- (nconsc aux-pars `((,(scat "LEN-" name) ,(%f77.cffi-type :integer))))
- `(,name ,(%f77.cffi-type :string)))
- (t
- `(,name ,(%f77.get-read-in-type type style))))))
- pars)))
- `( ;; don't want documentation for direct interface, not useful
- ;; ,@doc
- ,@new-pars ,@aux-pars))))
-
- ;; Create a form specifying a simple Lisp function that calls the
- ;; underlying Fortran routine of the same name.
- (defun %f77.def-fortran-interface (name return-type body hidden-var-name)
- (multiple-value-bind (doc pars)
- (parse-doc-&-parameters body)
- (let ((ffi-fn (make-fortran-ffi-name name))
- (return-vars nil)
- (array-vars nil)
- (ref-vars nil)
- (callback-code nil)
- ;;
- (defun-args nil)
- (defun-keyword-args nil)
- ;;
- (aux-args nil)
+ (multiple-value-bind (doc pars)
+ (parse-doc-&-parameters body)
+ (declare (ignore doc))
+
+ (let* ((aux-pars nil)
+ (new-pars
+ (mapcar #'(lambda (decl)
+ (destructuring-bind (name type &optional (style :input-reference)) decl
+ (case type
+ (:string
+ ;; String lengths are appended to the function arguments,
+ ;; passed by value.
+ (nconsc aux-pars `((,(scat "LEN-" name) ,(%f77.cffi-type :integer))))
+ `(,name ,(%f77.cffi-type :string)))
+ (t
+ `(,name ,(%f77.get-read-in-type type style))))))
+ pars)))
+ `( ;; don't want documentation for direct interface, not useful
+ ;; ,@doc
+ ,@new-pars ,@aux-pars))))
+
+;; Create a form specifying a simple Lisp function that calls the
+;; underlying Fortran routine of the same name.
+(defun %f77.def-fortran-interface (name return-type body hidden-var-name)
+ (multiple-value-bind (doc pars)
+ (parse-doc-&-parameters body)
+ (let ((ffi-fn (make-fortran-ffi-name name))
+ (return-vars nil)
+ (array-vars nil)
+ (ref-vars nil)
+ (callback-code nil)
+ ;;
+ (defun-args nil)
+ (defun-keyword-args nil)
+ ;;
+ (aux-args nil)
+ ;;
+ (ffi-args nil)
+ (aux-ffi-args nil)
+ (callback-args nil))
+ (dolist (decl pars)
+ (destructuring-bind (var type &optional style) decl
+ (let ((ffi-var nil)
+ (aux-var nil))
+ (cond
+ ;; Callbacks are tricky.
+ ((%f77.callback-type-p type)
+ (let* ((callback-name (second type))
+ (field-gvar (intern (string+ "*" (symbol-name (gensym (symbol-name var))) "*")))
+ (c-callback-code (%f77.def-fortran-callback field-gvar callback-name (third type) (cdddr type))))
+ (nconsc callback-code `((defvar ,field-gvar nil) ,@c-callback-code))
+ (nconsc callback-args `((,field-gvar ,var)))
+ (setq ffi-var `(cffi:callback ,callback-name))))
+ ;; Can't really enforce "style" when given an array.
+ ;; Complex numbers do not latch onto this case, they
+ ;; are passed by value.
+ ((%f77.array-p type)
+ (setq ffi-var (scat "ADDR-" var))
+ (nconsc array-vars `((,ffi-var ,var)))
+ ;;
+ (when-let (arg (getf type :inc))
+ (nconsc defun-keyword-args
+ `((,arg 0)))
+ (nconc (car (last array-vars)) `(:inc-type ,(cadr type) :inc ,arg))))
+ ;; Strings
+ ((%f77.string-p type)
+ (setq ffi-var var)
+ (setq aux-var (scat "LEN-" var))
+ (nconsc aux-args `((,aux-var (length (the string ,var))))))
+ ;; Pass-by-value variables
+ ((eq style :input-value)
+ (setq ffi-var var))
+ ;; Pass-by-reference variables
+ (t
+ (cond
+ ;; Makes more sense to copy complex numbers into
+ ;; arrays, rather than twiddling around with lisp
+ ;; memory internals.
+ ((member type '(:complex-single-float :complex-double-float))
+ (setq ffi-var (scat "ADDR-REAL-CAST-" var))
+ (nconsc ref-vars
+ `((,ffi-var ,(second (%f77.cffi-type type)) :count 2 :initial-contents (list (realpart ,var) (imagpart ,var))))))
+ (t
+ (setq ffi-var (scat "REF-" var))
+ (nconsc ref-vars
+ `((,ffi-var ,(%f77.cffi-type type) :initial-element ,@(if (eq type :character) `((char-code ,var)) `(,var) ))))))))
+ ;; Output variables
+ (when (and (%f77.output-p style) (not (eq type :string)))
+ (nconsc return-vars
+ `((,ffi-var ,var ,type))))
+ ;; Arguments for the lisp wrapper
+ (unless (eq var hidden-var-name)
+ (nconsc defun-args
+ `(,var)))
+ ;; Arguments for the FFI function
+ (nconsc ffi-args
+ `(,ffi-var))
+ ;; Auxillary arguments for FFI
+ (unless (null aux-var)
+ (nconsc aux-ffi-args
+ `(,aux-var))))))
+ ;;Complex returns through hidden variable.
+ (unless (null hidden-var-name)
+ (nconsc aux-args `((,hidden-var-name ,(ecase (second (first pars))
+ (:complex-single-float #c(0e0 0e0))
+ (:complex-double-float #c(0d0 0d0)))))))
+ ;;Keyword argument list
+ (unless (null defun-keyword-args)
+ (setq defun-keyword-args (cons '&optional defun-keyword-args)))
+ ;;Return the function definition
+ (let ((retvar (gensym)))
+ `(
+ ;;Declare callbacks
+ ,@callback-code
+ ,(recursive-append
+ `(defun ,name ,(append defun-args defun-keyword-args)
+ ,@doc)
;;
- (ffi-args nil)
- (aux-ffi-args nil)
- (callback-args nil))
- (dolist (decl pars)
- (destructuring-bind (var type &optional style) decl
- (let ((ffi-var nil)
- (aux-var nil))
- (cond
- ;; Callbacks are tricky.
- ((%f77.callback-type-p type)
- (let* ((callback-name (second type))
- (field-gvar (intern (string+ "*" (symbol-name (gensym (symbol-name var))) "*")))
- (c-callback-code (%f77.def-fortran-callback field-gvar callback-name (third type) (cdddr type))))
- (nconsc callback-code `((defvar ,field-gvar nil) ,@c-callback-code))
- (nconsc callback-args `((,field-gvar ,var)))
- (setq ffi-var `(cffi:callback ,callback-name))))
- ;; Can't really enforce "style" when given an array.
- ;; Complex numbers do not latch onto this case, they
- ;; are passed by value.
- ((%f77.array-p type)
- (setq ffi-var (scat "ADDR-" var))
- (nconsc array-vars `((,ffi-var ,var)))
- ;;
- (when-let (arg (getf type :inc))
- (nconsc defun-keyword-args
- `((,arg 0)))
- (nconc (car (last array-vars)) `(:inc-type ,(cadr type) :inc ,arg))))
- ;; Strings
- ((%f77.string-p type)
- (setq ffi-var var)
- (setq aux-var (scat "LEN-" var))
- (nconsc aux-args `((,aux-var (length (the string ,var))))))
- ;; Pass-by-value variables
- ((eq style :input-value)
- (setq ffi-var var))
- ;; Pass-by-reference variables
- (t
- (cond
- ;; Makes more sense to copy complex numbers into
- ;; arrays, rather than twiddling around with lisp
- ;; memory internals.
- ((member type '(:complex-single-float :complex-double-float))
- (setq ffi-var (scat "ADDR-REAL-CAST-" var))
- (nconsc ref-vars
- `((,ffi-var ,(second (%f77.cffi-type type)) :count 2 :initial-contents (list (realpart ,var) (imagpart ,var))))))
- (t
- (setq ffi-var (scat "REF-" var))
- (nconsc ref-vars
- `((,ffi-var ,(%f77.cffi-type type) :initial-element ,var)))))))
- ;; Output variables
- (when (and (%f77.output-p style) (not (eq type :string)))
- (nconsc return-vars
- `((,ffi-var ,var ,type))))
- ;; Arguments for the lisp wrapper
- (unless (eq var hidden-var-name)
- (nconsc defun-args
- `(,var)))
- ;; Arguments for the FFI function
- (nconsc ffi-args
- `(,ffi-var))
- ;; Auxillary arguments for FFI
- (unless (null aux-var)
- (nconsc aux-ffi-args
- `(,aux-var))))))
- ;;Complex returns through hidden variable.
- (unless (null hidden-var-name)
- (nconsc aux-args `((,hidden-var-name ,(ecase (second (first pars))
- (:complex-single-float #c(0e0 0e0))
- (:complex-double-float #c(0d0 0d0)))))))
- ;;Keyword argument list
- (unless (null defun-keyword-args)
- (setq defun-keyword-args (cons '&optional defun-keyword-args)))
- ;;Return the function definition
- (let ((retvar (gensym)))
- `(
- ;;Declare callbacks
- ,@callback-code
- ,(recursive-append
- `(defun ,name ,(append defun-args defun-keyword-args)
- ,@doc)
- ;;
- (unless (null aux-args)
- `(let (,@aux-args)))
- ;;Don't use with-foreign.. if ref-vars is nil
- (unless (null ref-vars)
- `(with-foreign-objects-stacked (,@ref-vars)))
- ;;Don't use with-vector-dat.. if array-vars is nil
- (unless (null array-vars)
- `(with-vector-data-addresses (,@array-vars)))
- ;;Point the the dummy global variables to the proper functions
- (unless (null callback-args)
- `(let (,@callback-args)))
- ;;Call the foreign-function
- `(let ((,retvar (,ffi-fn ,@ffi-args ,@aux-ffi-args)))
- ;;Ignore return if type is :void
- ,@(when (eq return-type :void)
- `((declare (ignore ,retvar))))
- ;; Copy values in reference pointers back to local
- ;; variables. Lisp has local scope; its safe to
- ;; modify variables in parameter lists.
- ,@(mapcar #'(lambda (decl)
- (destructuring-bind (ffi-var var type) decl
- (if (member type '(:complex-single-float :complex-double-float))
- `(setq ,var (complex (cffi:mem-aref ,ffi-var ,(second (%f77.cffi-type type)) 0)
- (cffi:mem-aref ,ffi-var ,(second (%f77.cffi-type type)) 1)))
- `(setq ,var (cffi:mem-aref ,ffi-var ,(%f77.cffi-type type))))))
- (remove-if-not #'(lambda (x)
- (member (first x) ref-vars :key #'car))
- return-vars))
- (values
- ,@(unless (eq return-type :void)
- `(,retvar))
- ,@(mapcar #'second return-vars)))))))))
-
- ;;TODO: Outputs are messed up inside the callback
- (defun %f77.def-fortran-callback (func callback-name return-type parm)
- (let* ((hack-return-type `,return-type)
- (hack-parm `(,@parm))
- (hidden-var-name nil))
- ;;
- (when (member hack-return-type '(:complex-single-float :complex-double-float))
- (setq hidden-var-name (gensym "HIDDEN-COMPLEX-RETURN-"))
- (setq hack-parm `((,hidden-var-name ,hack-return-type :output)
- ,@parm))
- (setq hack-return-type :void))
- ;;
- (let* ((new-pars nil)
- (aux-pars nil)
- (func-pars nil)
- (array-vars nil)
- (return-vars nil)
- (ref-vars nil))
- (dolist (decl hack-parm)
- (destructuring-bind (var type &optional (style :input)) decl
- (let ((ffi-var nil)
- (func-var nil))
- (cond
- ;; Callbacks are tricky.
- ((%f77.callback-type-p type)
- (setq ffi-var var)
- (setq func-var var))
- ;;
- ((%f77.array-p type)
- (setq ffi-var (scat "ADDR-" var))
- (setq func-var var)
- (nconsc array-vars `((,func-var (make-foreign-vector :pointer ,ffi-var :type ,(second (%f77.cffi-type type))
- :size ,(if-let (size (getf type :size))
- size
- 1))))))
- ;;
- ((%f77.string-p type)
- (setq ffi-var var)
- (setq func-var var)
- (nconsc aux-pars
- `((,(scat "LEN-" var) ,(%f77.cffi-type :integer)))))
- ;;
- ((eq style :input-value)
- (setq ffi-var var)
- (setq func-var var))
- ;; Pass-by-reference variables
- (t
- (cond
- ((member type '(:complex-single-float :complex-double-float))
- (setq ffi-var (scat "ADDR-REAL-CAST-" var))
- (setq func-var var)
- (nconsc ref-vars
- `((,func-var (complex (cffi:mem-aref ,ffi-var ,(second (%f77.cffi-type type)) 0)
- (cffi:mem-aref ,ffi-var ,(second (%f77.cffi-type type)) 1))))))
- (t
- (setq ffi-var (scat "REF-" var))
- (setq func-var var)
- (nconsc ref-vars
- `((,func-var (cffi:mem-aref ,ffi-var ,(%f77.cffi-type type)))))))))
- ;;
- (nconsc new-pars `((,ffi-var ,(%f77.get-read-in-type type style))))
- (nconsc func-pars `(,func-var))
- (when (and (%f77.output-p style) (not (eq type :string)))
- (nconsc return-vars
- `((,func-var ,ffi-var ,type)))))))
-
- (let ((retvar (gensym)))
- `(
- ,(recursive-append
- `(cffi:defcallback ,callback-name ,(%f77.get-return-type hack-return-type)
- (,@new-pars ,@aux-pars))
+ (unless (null aux-args)
+ `(let (,@aux-args)))
+ ;;Don't use with-foreign.. if ref-vars is nil
+ (unless (null ref-vars)
+ `(with-foreign-objects-stacked (,@ref-vars)))
+ ;;Don't use with-vector-dat.. if array-vars is nil
+ (unless (null array-vars)
+ `(with-vector-data-addresses (,@array-vars)))
+ ;;Point the the dummy global variables to the proper functions
+ (unless (null callback-args)
+ `(let (,@callback-args)))
+ ;;Call the foreign-function
+ `(let ((,retvar (,ffi-fn ,@ffi-args ,@aux-ffi-args)))
+ ;;Ignore return if type is :void
+ ,@(when (eq return-type :void)
+ `((declare (ignore ,retvar))))
+ ;; Copy values in reference pointers back to local
+ ;; variables. Lisp has local scope; its safe to
+ ;; modify variables in parameter lists.
+ ,@(mapcar #'(lambda (decl)
+ (destructuring-bind (ffi-var var type) decl
+ (if (member type '(:complex-single-float :complex-double-float))
+ `(setq ,var (complex (cffi:mem-aref ,ffi-var ,(second (%f77.cffi-type type)) 0)
+ (cffi:mem-aref ,ffi-var ,(second (%f77.cffi-type type)) 1)))
+ `(setq ,var (cffi:mem-aref ,ffi-var ,(%f77.cffi-type type))))))
+ (remove-if-not #'(lambda (x)
+ (member (first x) ref-vars :key #'car))
+ return-vars))
+ (values
+ ,@(unless (eq return-type :void)
+ `(,retvar))
+ ,@(mapcar #'second return-vars)))))))))
+
+;;TODO: Outputs are messed up inside the callback
+(defun %f77.def-fortran-callback (func callback-name return-type parm)
+ (let* ((hack-return-type `,return-type)
+ (hack-parm `(,@parm))
+ (hidden-var-name nil))
+ ;;
+ (when (member hack-return-type '(:complex-single-float :complex-double-float))
+ (setq hidden-var-name (gensym "HIDDEN-COMPLEX-RETURN-"))
+ (setq hack-parm `((,hidden-var-name ,hack-return-type :output)
+ ,@parm))
+ (setq hack-return-type :void))
+ ;;
+ (let* ((new-pars nil)
+ (aux-pars nil)
+ (func-pars nil)
+ (array-vars nil)
+ (return-vars nil)
+ (ref-vars nil))
+ (dolist (decl hack-parm)
+ (destructuring-bind (var type &optional (style :input)) decl
+ (let ((ffi-var nil)
+ (func-var nil))
+ (cond
+ ;; Callbacks are tricky.
+ ((%f77.callback-type-p type)
+ (setq ffi-var var)
+ (setq func-var var))
;;
- (when ref-vars
- `(let (,@ref-vars)))
+ ((%f77.array-p type)
+ (setq ffi-var (scat "ADDR-" var))
+ (setq func-var var)
+ (nconsc array-vars `((,func-var (make-foreign-vector :pointer ,ffi-var :type ,(second (%f77.cffi-type type))
+ :size ,(if-let (size (getf type :size))
+ size
+ 1))))))
;;
- (when array-vars
- `(let (,@array-vars)))
+ ((%f77.string-p type)
+ (setq ffi-var var)
+ (setq func-var var)
+ (nconsc aux-pars
+ `((,(scat "LEN-" var) ,(%f77.cffi-type :integer)))))
;;
- `(multiple-value-bind (,retvar ,@(mapcar #'car return-vars)) (funcall ,func ,@func-pars)
- (declare (ignore ,@(mapcar #'car return-vars)
- ,@(when (eq hack-return-type :void)
- `(,retvar))))
- ,@(mapcar #'(lambda (decl)
- (destructuring-bind (func-var ffi-var type) decl
- (if (member type '(:complex-single-float :complex-double-float))
- `(setf (cffi:mem-aref ,ffi-var ,(second (%f77.cffi-type type)) 0) (realpart ,func-var)
- (cffi:mem-aref ,ffi-var ,(second (%f77.cffi-type type)) 1) (imagpart ,func-var))
- `(setf (cffi:mem-aref ,ffi-var ,(%f77.cffi-type type)) ,func-var))))
- (remove-if-not #'(lambda (x)
- (member (first x) ref-vars :key #'car))
- return-vars))
- ,(if (eq hack-return-type :void)
- nil
- retvar))))))))
- )
+ ((eq style :input-value)
+ (setq ffi-var var)
+ (setq func-var var))
+ ;; Pass-by-reference variables
+ (t
+ (cond
+ ((member type '(:complex-single-float :complex-double-float))
+ (setq ffi-var (scat "ADDR-REAL-CAST-" var))
+ (setq func-var var)
+ (nconsc ref-vars
+ `((,func-var (complex (cffi:mem-aref ,ffi-var ,(second (%f77.cffi-type type)) 0)
+ (cffi:mem-aref ,ffi-var ,(second (%f77.cffi-type type)) 1))))))
+ (t
+ (setq ffi-var (scat "REF-" var))
+ (setq func-var var)
+ (nconsc ref-vars
+ `((,func-var (cffi:mem-aref ,ffi-var ,(%f77.cffi-type type)))))))))
+ ;;
+ (nconsc new-pars `((,ffi-var ,(%f77.get-read-in-type type style))))
+ (nconsc func-pars `(,func-var))
+ (when (and (%f77.output-p style) (not (eq type :string)))
+ (nconsc return-vars
+ `((,func-var ,ffi-var ,type)))))))
+
+ (let ((retvar (gensym)))
+ `(
+ ,(recursive-append
+ `(cffi:defcallback ,callback-name ,(%f77.get-return-type hack-return-type)
+ (,@new-pars ,@aux-pars))
+ ;;
+ (when ref-vars
+ `(let (,@ref-vars)))
+ ;;
+ (when array-vars
+ `(let (,@array-vars)))
+ ;;
+ `(multiple-value-bind (,retvar ,@(mapcar #'car return-vars)) (funcall ,func ,@func-pars)
+ (declare (ignore ,@(mapcar #'car return-vars)
+ ,@(when (eq hack-return-type :void)
+ `(,retvar))))
+ ,@(mapcar #'(lambda (decl)
+ (destructuring-bind (func-var ffi-var type) decl
+ (if (member type '(:complex-single-float :complex-double-float))
+ `(setf (cffi:mem-aref ,ffi-var ,(second (%f77.cffi-type type)) 0) (realpart ,func-var)
+ (cffi:mem-aref ,ffi-var ,(second (%f77.cffi-type type)) 1) (imagpart ,func-var))
+ `(setf (cffi:mem-aref ,ffi-var ,(%f77.cffi-type type)) ,func-var))))
+ (remove-if-not #'(lambda (x)
+ (member (first x) ref-vars :key #'car))
+ return-vars))
+ ,(if (eq hack-return-type :void)
+ nil
+ retvar))))))))
+)
(defmacro def-fortran-routine (name-and-options return-type &rest body)
"
diff --git a/src/foreign-core/blas.lisp b/src/foreign-core/blas.lisp
index 622fa21..d7dd57b 100644
--- a/src/foreign-core/blas.lisp
+++ b/src/foreign-core/blas.lisp
@@ -695,7 +695,7 @@
"
- (trans :string :input)
+ (trans :character :input)
(m :integer )
(n :integer )
(alpha :double-float )
@@ -800,7 +800,7 @@
"
- (uplo :string :input)
+ (uplo :character :input)
(n :integer )
(alpha :double-float )
(a (* :double-float) )
@@ -906,9 +906,9 @@
"
- (uplo :string :input)
- (trans :string :input)
- (diag :string :input)
+ (uplo :character :input)
+ (trans :character :input)
+ (diag :character :input)
(n :integer )
(a (* :double-float) )
(lda :integer )
@@ -1013,9 +1013,9 @@
"
- (uplo :string :input)
- (trans :string :input)
- (diag :string :input)
+ (uplo :character :input)
+ (trans :character :input)
+ (diag :character :input)
(n :integer )
(a (* :double-float) )
(lda :integer )
@@ -1186,7 +1186,7 @@
"
- (uplo :string :input)
+ (uplo :character :input)
(n :integer )
(alpha :double-float )
(x (* :double-float) )
@@ -1285,7 +1285,7 @@
"
- (uplo :string :input)
+ (uplo :character :input)
(n :integer )
(alpha :double-float )
(x (* :double-float) )
@@ -1419,8 +1419,8 @@
"
- (transa :string :input)
- (transb :string :input)
+ (transa :character :input)
+ (transb :character :input)
(m :integer )
(n :integer )
(k :integer )
@@ -1545,8 +1545,8 @@
"
- (uplo :string :input)
- (trans :string :input)
+ (uplo :character :input)
+ (trans :character :input)
(n :integer )
(k :integer )
(alpha :double-float )
@@ -1687,8 +1687,8 @@
"
- (uplo :string :input)
- (trans :string :input)
+ (uplo :character :input)
+ (trans :character :input)
(n :integer )
(k :integer )
(alpha :double-float )
@@ -1820,10 +1820,10 @@
"
- (side :string :input)
- (uplo :string :input)
- (transa :string :input)
- (diag :string :input)
+ (side :character :input)
+ (uplo :character :input)
+ (transa :character :input)
+ (diag :character :input)
(m :integer )
(n :integer )
(alpha :double-float )
@@ -1955,10 +1955,10 @@
"
- (side :string :input)
- (uplo :string :input)
- (transa :string :input)
- (diag :string :input)
+ (side :character :input)
+ (uplo :character :input)
+ (transa :character :input)
+ (diag :character :input)
(m :integer )
(n :integer )
(alpha :double-float )
@@ -2101,7 +2101,7 @@
"
- (trans :string :input)
+ (trans :character :input)
(m :integer )
(n :integer )
(alpha :complex-double-float )
@@ -2208,7 +2208,7 @@
"
- (uplo :string :input)
+ (uplo :character :input)
(n :integer )
(alpha :complex-double-float )
(a (* :complex-double-float) )
@@ -2314,9 +2314,9 @@
"
- (uplo :string :input)
- (trans :string :input)
- (diag :string :input)
+ (uplo :character :input)
+ (trans :character :input)
+ (diag :character :input)
(n :integer )
(a (* :complex-double-float) )
(lda :integer )
@@ -2421,9 +2421,9 @@
"
- (uplo :string :input)
- (trans :string :input)
- (diag :string :input)
+ (uplo :character :input)
+ (trans :character :input)
+ (diag :character :input)
(n :integer )
(a (* :complex-double-float) )
(lda :integer )
@@ -2692,7 +2692,7 @@
"
- (uplo :string :input)
+ (uplo :character :input)
(n :integer )
(alpha :complex-double-float )
(x (* :complex-double-float) )
@@ -2826,8 +2826,8 @@
"
- (transa :string :input)
- (transb :string :input)
+ (transa :character :input)
+ (transb :character :input)
(m :integer )
(n :integer )
(k :integer )
@@ -2960,10 +2960,10 @@
"
- (side :string :input)
- (uplo :string :input)
- (transa :string :input)
- (diag :string :input)
+ (side :character :input)
+ (uplo :character :input)
+ (transa :character :input)
+ (diag :character :input)
(m :integer )
(n :integer )
(alpha :complex-double-float )
@@ -3094,10 +3094,10 @@
"
- (side :string :input)
- (uplo :string :input)
- (transa :string :input)
- (diag :string :input)
+ (side :character :input)
+ (uplo :character :input)
+ (transa :character :input)
+ (diag :character :input)
(m :integer )
(n :integer )
(alpha :complex-double-float )
@@ -3222,8 +3222,8 @@
"
- (uplo :string :input)
- (trans :string :input)
+ (uplo :character :input)
+ (trans :character :input)
(n :integer )
(k :integer )
(alpha :double-float )
@@ -3368,8 +3368,8 @@
"
- (uplo :string :input)
- (trans :string :input)
+ (uplo :character :input)
+ (trans :character :input)
(n :integer )
(k :integer )
(alpha :complex-double-float )
diff --git a/src/foreign-core/lap...
[truncated message content] |
