Menu
▾
▴
[Matlisp-commit] [matlisp-git]matlisp branch extensible created. 2012-02-23-174-g376399e
|
From: Akshay S. <ak...@us...> - 2012-12-25 20:48:00
|
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, extensible has been created
at 376399e23fbbb868c8eb3ef80ee8bc9c65c5d98e (commit)
- Log -----------------------------------------------------------------
commit 376399e23fbbb868c8eb3ef80ee8bc9c65c5d98e
Author: Akshay Srinivasan <aks...@gm...>
Date: Tue Dec 25 14:39:13 2012 -0600
o Got rid of the "counterclass" hashtable. Everything now resides in
*tensor-class-optimization*, and in the symbol-plist associated with
tensor class name.
o Ported some L-1 routines to the new architecture.
diff --git a/matlisp.asd b/matlisp.asd
index 61cf5b1..d573c09 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -133,20 +133,22 @@
(:file "swap")
(:file "copy"
:depends-on ("tensor-maker"))
- (:file "scal"
+ #+nil(:file "scal"
:depends-on ("copy" "tensor-maker"))
- (:file "realimag"
+ #+nil(:file "realimag"
:depends-on ("copy"))
- (:file "dot"
+ #+nil(:file "dot"
:depends-on ("realimag"))
- (:file "axpy"
+ #+nil(:file "axpy"
:depends-on ("copy" "scal"))
- (:file "trans"
+ #+nil(:file "trans"
:depends-on ("scal" "copy"))))
+ #+nil
(:module "matlisp-level-2"
:pathname "level-2"
:depends-on ("matlisp-base" "matlisp-classes" "foreign-core" "matlisp-level-1")
:components ((:file "gemv")))
+ #+nil
(:module "matlisp-level-3"
:pathname "level-3"
:depends-on ("matlisp-base" "matlisp-classes" "foreign-core" "matlisp-level-1")
@@ -155,11 +157,13 @@
:pathname "lapack"
:depends-on ("matlisp-base" "matlisp-classes" "matlisp-level-1" "matlisp-level-2" "matlisp-level-3")
:components ((:file "gesv")))
+ #+nil
(:module "matlisp-sugar"
:pathname "sugar"
:depends-on ("matlisp-base" "matlisp-classes" "matlisp-level-1" "matlisp-level-2" "matlisp-level-3")
:components ((:file "mplusminus")
(:file "mtimesdivide")))
+ #+nil
(:module "matlisp-reader"
:pathname "reader"
:components ((:file "infix")))))
diff --git a/src/base/blas-helpers.lisp b/src/base/blas-helpers.lisp
index 86391ca..0092bf9 100644
--- a/src/base/blas-helpers.lisp
+++ b/src/base/blas-helpers.lisp
@@ -28,8 +28,7 @@
(defun consecutive-store-p (tensor)
(declare (type standard-tensor tensor))
- (mlet* (((sort-std std-perm) (let-typed ((strd (strides tensor) :type index-store-vector))
- (very-quickly (sort-permute (copy-seq (strides tensor)) #'<)))
+ (mlet* (((sort-std std-perm) (very-quickly (sort-permute (copy-seq (strides tensor)) #'<))
:type (index-store-vector permutation))
(perm-dims (permute (dimensions tensor) std-perm) :type index-store-vector))
(very-quickly
diff --git a/src/base/standard-tensor.lisp b/src/base/standard-tensor.lisp
index 0691120..e27d9d8 100644
--- a/src/base/standard-tensor.lisp
+++ b/src/base/standard-tensor.lisp
@@ -121,29 +121,6 @@
(error 'tensor-not-vector :rank (rank old))))
;;
-(defvar *tensor-counterclass* (make-hash-table)
- "
- Contains the CLOS counterpart classes of every tensor class.
- This is used to change the tensor class automatically to a matrix
- and vector")
-
-(defun get-tensor-counterclass (clname)
- (declare (type symbol clname))
- (let ((opt (gethash clname *tensor-counterclass*)))
- (cond
- ((null opt) nil)
- ((symbolp opt)
- (get-tensor-counterclass opt))
- (t (values opt clname)))))
-
-(defun (setf get-tensor-counterclass) (value clname)
- (setf (gethash clname *tensor-counterclass*) value))
-
-(setf (get-tensor-counterclass 'standard-tensor)
- '(:matrix standard-matrix
- :vector standard-vector))
-
-;;
(defvar *tensor-class-optimizations* (make-hash-table)
"
Contains a either:
@@ -170,8 +147,14 @@
o class-name (symbol) of the superclass whose optimizations
are to be made use of.")
-(defun get-tensor-class-optimization (clname)
+(definline get-tensor-class-optimization (clname)
(declare (type symbol clname))
+ (symbol-plist clname))
+
+(definline get-tensor-object-optimization (obj)
+ (symbol-plist (class-name (class-of obj))))
+
+(defun get-tensor-class-optimization-hashtable (clname)
(let ((opt (gethash clname *tensor-class-optimizations*)))
(cond
((null opt) nil)
@@ -180,7 +163,10 @@
(t (values opt clname)))))
(defun (setf get-tensor-class-optimization) (value clname)
- (setf (gethash clname *tensor-class-optimizations*) value))
+ (setf (gethash clname *tensor-class-optimizations*) value
+ (symbol-plist clname) (if (symbolp value)
+ (get-tensor-class-optimization-hashtable clname)
+ value)))
;; Akshay: I have no idea what this does, or why we want it
;; (inherited from standard-matrix.lisp
@@ -366,9 +352,6 @@
())
(defclass ,vector (standard-vector ,tensor-class)
())
- (setf (get-tensor-counterclass ',tensor-class) (list :matrix ',matrix :vector ',vector)
- (get-tensor-counterclass ',matrix) ',tensor-class
- (get-tensor-counterclass ',vector) ',tensor-class)
;;Store refs
(defmethod tensor-store-ref ((tensor ,tensor-class) idx)
(declare (type index-type idx))
@@ -381,7 +364,10 @@
(,value-writer value store idx)))
;;
(let ((hst (list
- :field-type ',element-type
+ :tensor ',tensor-class
+ :matrix ',matrix
+ :vector ',vector
+ :element-type ',element-type
:f+ ',f+
:f- ',f-
:finv+ ',finv+
@@ -397,9 +383,11 @@
:store-allocator ',store-allocator
:coercer ',coercer
:coercer-unforgiving ',coercer-unforgiving
- :element-type ',element-type
:store-type ',store-element-type)))
- (setf (get-tensor-class-optimization ',tensor-class) hst))))
+ (setf (get-tensor-class-optimization ',tensor-class) hst
+ (get-tensor-class-optimization ',matrix) ',tensor-class
+ (get-tensor-class-optimization ',vector) ',tensor-class)
+ (setf (symbol-plist ',tensor-class) hst))))
;;
(defgeneric tensor-ref (tensor subscripts)
@@ -499,11 +487,9 @@
(declare (type standard-tensor ten))
(= (slot-value ten 'rank) 1))
-(defun square-p (tensor)
- (let* ((rank (rank tensor))
- (sym (gensym))
- (lst (make-list rank :initial-element sym)))
- (apply #'tensor-type-p (list tensor lst))))
+(definline square-p (tensor)
+ (let-typed ((dims (dimensions tensor) :type index-store-vector))
+ (lvec-foldr #'(lambda (a b) (if (eq a b) a nil)) dims)))
;;---------------------------------------------------------------;;
@@ -585,8 +571,9 @@
(make-instance
(let ((nrnk (length ndim)))
(if (> nrnk 2) (class-name (class-of tensor))
- (let ((cocl (get-tensor-counterclass (class-name (class-of tensor)))))
- (assert cocl nil 'tensor-cannot-find-counter-class :tensor-class (class-name (class-of tensor)))
- (ecase nrnk (2 (getf cocl :matrix)) (1 (getf cocl :vector))))))
+ (let ((cocl (getf (symbol-plist (class-name (class-of tensor))) (ecase nrnk (2 :matrix) (1 :vector)))))
+ (assert cocl nil 'tensor-cannot-find-optimization :tensor-class (class-name (class-of tensor)))
+ cocl)))
:parent-tensor tensor :store (store tensor) :head nhd
:dimensions (make-index-store ndim) :strides (make-index-store nstd)))))))
+
diff --git a/src/classes/complex-tensor.lisp b/src/classes/complex-tensor.lisp
index 3bb2f58..97e6656 100644
--- a/src/classes/complex-tensor.lisp
+++ b/src/classes/complex-tensor.lisp
@@ -12,8 +12,39 @@
(deftype complex-type ()
"Complex number with Re, Im parts in complex-base-type."
'(cl:complex complex-base-type))
-;;
+;;Field operations
+(definline complex-type.f+ (a b)
+ (declare (type complex-type a b))
+ (+ a b))
+
+(definline complex-type.f- (a b)
+ (declare (type complex-type a b))
+ (- a b))
+
+(definline complex-type.finv+ (a)
+ (declare (type complex-type a))
+ (- a))
+
+(definline complex-type.fid+ ()
+ #c(0.0d0 0.0d0))
+
+(definline complex-type.f* (a b)
+ (declare (type complex-type a b))
+ (* a b))
+
+(definline complex-type.f/ (a b)
+ (declare (type complex-type a b))
+ (/ a b))
+
+(definline complex-type.finv* (a)
+ (declare (type complex-type a))
+ (/ a))
+
+(definline complex-type.fid* ()
+ #c(1.0d0 0.0d0))
+
+;;Store operations
(definline allocate-complex-store (size)
"
(allocate-complex-store size)
@@ -36,24 +67,56 @@
(defun coerce-complex-base (x)
(restart-case (coerce-complex-base-unforgiving x)
(use-value (value) (coerce-complex-base value))))
-
;;
-(defclass complex-tensor (standard-tensor)
- ((store :type complex-store-vector)
- (element-type :initform 'complex-type))
- (:documentation "Tensor class with complex elements."))
-
-(defclass complex-matrix (standard-matrix complex-tensor)
- ()
- (:documentation "Matrix class with complex elements."))
-
-(defclass complex-vector (standard-vector complex-tensor)
- ()
- (:documentation "Vector class with complex elements."))
+(definline complex-type.reader (tstore idx)
+ (declare (type complex-store-vector tstore)
+ (type index-type idx))
+ (complex (aref tstore (* 2 idx))
+ (aref tstore (1+ (* 2 idx)))))
+
+(definline complex-type.value-writer (value store idx)
+ (declare (type complex-store-vector store)
+ (type index-type idx)
+ (type complex-type value))
+ (setf (aref store (* 2 idx)) (realpart value)
+ (aref store (1+ (* 2 idx))) (imagpart value)))
+
+(definline complex-type.reader-writer (fstore fidx tstore tidx)
+ (declare (type complex-store-vector fstore tstore)
+ (type index-type fidx tidx))
+ (setf (aref tstore (* 2 tidx)) (aref fstore (* 2 fidx))
+ (aref tstore (1+ (* 2 tidx))) (aref fstore (1+ (* 2 fidx)))))
+
+(definline complex-type.swapper (fstore fidx tstore tidx)
+ (declare (type complex-store-vector fstore tstore)
+ (type index-type fidx tidx))
+ (rotatef (aref tstore (* 2 tidx)) (aref fstore (* 2 fidx)))
+ (rotatef (aref tstore (1+ (* 2 tidx))) (aref fstore (1+ (* 2 fidx)))))
+;;
-(setf (get-tensor-counterclass 'complex-tensor) '(:matrix complex-matrix :vector complex-vector)
- (get-tensor-counterclass 'complex-matrix) 'complex-tensor
- (get-tensor-counterclass 'complex-vector) 'complex-tensor)
+(define-tensor (complex-tensor complex-type complex-base-type complex-store-vector
+ (:documentation "Tensor class with complex elements."))
+ :matrix complex-matrix :vector complex-vector
+ ;;
+ :f+ complex-type.f+
+ :f- complex-type.f-
+ :finv+ complex-type.finv+
+ :fid+ complex-type.fid+
+ :f* complex-type.f*
+ :f/ complex-type.f/
+ :finv* complex-type.finv*
+ :fid* complex-type.fid*
+ ;;
+ :store-allocator allocate-complex-store
+ :coercer coerce-complex
+ :coercer-unforgiving coerce-complex-unforgiving
+ ;;
+ :matrix complex-matrix :vector complex-vector
+ ;;
+ :reader complex-type.reader
+ :value-writer complex-type.value-writer
+ :reader-writer complex-type.reader-writer
+ :swapper complex-type.swapper)
;;
(defmethod initialize-instance ((tensor complex-tensor) &rest initargs)
@@ -64,31 +127,7 @@
(setf (store tensor) (allocate-complex-store size)
(store-size tensor) size)))
(call-next-method))
-;;
-(tensor-store-defs (complex-tensor complex-type complex-base-type)
- :store-allocator allocate-complex-store
- :coercer coerce-complex-unforgiving
- :reader
- (lambda (tstore idx)
- (complex (aref tstore (* 2 idx))
- (aref tstore (1+ (* 2 idx)))))
- :value-writer
- (lambda (value store idx)
- (setf (aref store (* 2 idx)) (realpart value)
- (aref store (1+ (* 2 idx))) (imagpart value)))
- :reader-writer
- (lambda (fstore fidx tstore tidx)
- (setf (aref tstore (* 2 tidx)) (aref fstore (* 2 fidx))
- (aref tstore (1+ (* 2 tidx))) (aref fstore (1+ (* 2 fidx)))))
- :swapper
- (lambda (fstore fidx tstore tidx)
- (progn
- (rotatef (aref tstore (* 2 tidx)) (aref fstore (* 2 fidx)))
- (rotatef (aref tstore (1+ (* 2 tidx))) (aref fstore (1+ (* 2 fidx)))))))
-
-(setf (get-tensor-class-optimization 'complex-matrix) 'complex-tensor
- (get-tensor-class-optimization 'complex-vector) 'complex-tensor)
;;
(defmethod print-element ((tensor complex-tensor)
element stream)
diff --git a/src/classes/matrix.lisp b/src/classes/matrix.lisp
index dc7999c..78ea722 100644
--- a/src/classes/matrix.lisp
+++ b/src/classes/matrix.lisp
@@ -32,7 +32,7 @@
Purpose
=======
Return T if X is a row matrix (number of columns is 1)"
- (tensor-type-p matrix '(1 *)))
+ (tensor-typep matrix '(1 *)))
(definline col-matrix-p (matrix)
"
@@ -43,7 +43,7 @@
Purpose
=======
Return T if X is a column matrix (number of rows is 1)"
- (tensor-type-p matrix '(* 1)))
+ (tensor-typep matrix '(* 1)))
(definline row-or-col-matrix-p (matrix)
"
diff --git a/src/classes/real-tensor.lisp b/src/classes/real-tensor.lisp
index 7e22544..8b0a9ec 100644
--- a/src/classes/real-tensor.lisp
+++ b/src/classes/real-tensor.lisp
@@ -74,7 +74,8 @@ Allocates real storage. Default initial-element = 0d0.")
(use-value (value) (coerce-real value))))
;;
-(define-tensor (real-tensor real-type real-type real-store-vector)
+(define-tensor (real-tensor real-type real-type real-store-vector
+ (:documentation "Tensor class with real double elements."))
:matrix real-matrix :vector real-vector
;;
:f+ real-type.f+
@@ -106,9 +107,6 @@ Allocates real storage. Default initial-element = 0d0.")
(slot-value tensor 'store-size) size)))
(call-next-method))
-(setf (get-tensor-class-optimization 'real-matrix) 'real-tensor
- (get-tensor-class-optimization 'real-vector) 'real-tensor)
-
;;
(defmethod (setf tensor-ref) ((value number) (tensor real-tensor) subscripts)
(let ((sto-idx (store-indexing subscripts tensor)))
diff --git a/src/conditions.lisp b/src/conditions.lisp
index 5fdbfed..87a526a 100644
--- a/src/conditions.lisp
+++ b/src/conditions.lisp
@@ -204,13 +204,6 @@
(when (slots-boundp c 'argument 'argument-stride)
(format stream "Stride of argument ~A must be >= 0, initialized with ~A." (argument c) (stride c))))))
-(define-condition tensor-cannot-find-counter-class (tensor-error)
- ((tensor-class :reader tensor-class :initarg :tensor-class))
- (:documentation "Cannot find the counter-class list of the given tensor class")
- (:report (lambda (c stream)
- (when (slots-boundp c 'tensor-class)
- (format stream "Cannot find the counter-class list of the given tensor class: ~a." (tensor-class c))))))
-
(define-condition tensor-cannot-find-optimization (tensor-error)
((tensor-class :reader tensor-class :initarg :tensor-class))
(:documentation "Cannot find optimization information for the given tensor class")
diff --git a/src/level-1/copy.lisp b/src/level-1/copy.lisp
index 96f2786..4e5b665 100644
--- a/src/level-1/copy.lisp
+++ b/src/level-1/copy.lisp
@@ -32,20 +32,13 @@
;;Be very careful when using functions generated by this macro.
;;Indexes can be tricky and this has no safety net
;;Use only after checking the arguments for compatibility.
- (let* ((opt (get-tensor-class-optimization tensor-class)))
+ (let* ((opt (get-tensor-class-optimization-hashtable tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
`(definline ,func (from to)
(declare (type ,tensor-class from to))
- (let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
- (strd-p (when call-fortran? (blas-copyable-p from to))))
- (cond
- ((and strd-p call-fortran?)
- (,blas-func (number-of-elements from)
- (store from) (first strd-p)
- (store to) (second strd-p)
- (head from) (head to)))
- (t
- (let ((f-sto (store from))
+ ,(let
+ ((lisp-routine
+ `(let ((f-sto (store from))
(t-sto (store to)))
(declare (type ,(linear-array-type (getf opt :store-type)) f-sto t-sto))
(very-quickly
@@ -56,7 +49,19 @@
with (linear-sums
(f-of (strides from) (head from))
(t-of (strides to) (head to)))
- do ,(funcall (getf opt :reader-writer) 'f-sto 'f-of 't-sto 't-of)))))))
+ do (,(getf opt :reader-writer) f-sto f-of t-sto t-of))))))
+ (if blas-func
+ `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
+ (strd-p (when call-fortran? (blas-copyable-p from to))))
+ (cond
+ ((and strd-p call-fortran?)
+ (,blas-func (number-of-elements from)
+ (store from) (first strd-p)
+ (store to) (second strd-p)
+ (head from) (head to)))
+ (t
+ ,lisp-routine)))
+ lisp-routine))
to)))
(defmacro generate-typed-num-copy! (func (tensor-class blas-func fortran-lb))
@@ -64,32 +69,36 @@
;;Indexes can be tricky and this has no safety net
;;(you don't see a matrix-ref do you ?)
;;Use only after checking the arguments for compatibility.
- (let* ((opt (get-tensor-class-optimization tensor-class)))
+ (let* ((opt (get-tensor-class-optimization-hashtable tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
`(definline ,func (num-from to)
(declare (type ,tensor-class to)
(type ,(getf opt :element-type) num-from))
- (let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
- (min-stride (when call-fortran? (consecutive-store-p to))))
- (cond
- ((and call-fortran? min-stride)
- (let ((num-array (,(getf opt :store-allocator) 1)))
- (declare (type ,(linear-array-type (getf opt :store-type)) num-array))
- ,(funcall (getf opt :value-writer) 'num-from 'num-array 0)
- (,blas-func (number-of-elements to)
- num-array 0
- (store to) min-stride
- 0 (head to))))
- (t
- (let-typed
+ ,(let
+ ((lisp-routine
+ `(let-typed
((t-sto (store to) :type ,(linear-array-type (getf opt :store-type))))
(very-quickly
(mod-dotimes (idx (dimensions to))
with (linear-sums
(t-of (strides to) (head to)))
- do ,(funcall (getf opt :value-writer) 'num-from 't-sto 't-of)))))))
- to)))
-
+ do (,(getf opt :value-writer) num-from t-sto t-of))))))
+ (if blas-func
+ `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
+ (min-stride (when call-fortran? (consecutive-store-p to))))
+ (cond
+ ((and call-fortran? min-stride)
+ (let ((num-array (,(getf opt :store-allocator) 1)))
+ (declare (type ,(linear-array-type (getf opt :store-type)) num-array))
+ (,(getf opt :value-writer) num-from num-array 0)
+ (,blas-func (number-of-elements to)
+ num-array 0
+ (store to) min-stride
+ 0 (head to))))
+ (t
+ ,lisp-routine)))
+ lisp-routine))
+ to)))
;;Real
(generate-typed-copy! real-typed-copy!
@@ -163,11 +172,10 @@
with the same elements. This is a copy of the tensor.
"
(declare (type standard-tensor tensor))
- (let* ((dims (dimensions tensor))
- (ret (make-array (lvec->list dims)
- :element-type (if-ret (getf (get-tensor-class-optimization (class-name (class-of tensor))) :element-type)
- (error 'tensor-cannot-find-optimization :tensor-class (class-name (class-of tensor)))))))
- (declare (type index-store-vector dims))
+ (let*-typed ((dims (dimensions tensor) :type index-store-vector)
+ (ret (make-array (lvec->list dims)
+ :element-type (or (getf (get-tensor-object-optimization tensor) :element-type)
+ (error 'tensor-cannot-find-optimization :tensor-class (class-name (class-of tensor)))))))
(let ((lst (make-list (rank tensor))))
(very-quickly
(mod-dotimes (idx dims)
@@ -175,10 +183,10 @@
ret)))
(defmethod copy! :before ((x standard-tensor) (y array))
- (assert (subtypep (element-type x)
+ (assert (subtypep (getf (get-tensor-object-optimization x) :element-type)
(array-element-type y))
nil 'invalid-type
- :given (element-type x)
+ :given (getf (get-tensor-object-optimization x) :element-type)
:expected (array-element-type y))
(assert (and
(= (rank x) (array-rank y))
@@ -211,9 +219,9 @@
;;
(defmethod copy! :before ((x array) (y standard-tensor))
(assert (subtypep (array-element-type x)
- (element-type y))
+ (getf (get-tensor-object-optimization y) :element-type))
nil 'invalid-type
- :given (array-element-type x) :expected (element-type y))
+ :given (array-element-type x) :expected (getf (get-tensor-object-optimization y) :element-type))
(assert (and
(= (array-rank x) (rank y))
(dolist (ele (mapcar #'= (array-dimensions x) (lvec->list (dimensions y))) t)
diff --git a/src/level-1/scal.lisp b/src/level-1/scal.lisp
index 0aea8b7..223f78a 100644
--- a/src/level-1/scal.lisp
+++ b/src/level-1/scal.lisp
@@ -29,20 +29,13 @@
(in-package #:matlisp)
(defmacro generate-typed-scal! (func (tensor-class fortran-func fortran-lb))
- (let* ((opt (get-tensor-class-optimization tensor-class)))
+ (let* ((opt (get-tensor-class-optimization-hashtable tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
`(definline ,func (from to)
(declare (type ,tensor-class from to))
- (let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
- (strd-p (when call-fortran? (blas-copyable-p from to))))
- (cond
- ((and strd-p call-fortran?)
- (,fortran-func (number-of-elements from)
- (store from) (first strd-p)
- (store to) (second strd-p)
- (head from) (head to)))
- (t
- (let ((f-sto (store from))
+ ,(let
+ ((lisp-routine
+ `(let ((f-sto (store from))
(t-sto (store to)))
(declare (type ,(linear-array-type (getf opt :store-type)) f-sto t-sto))
(very-quickly
@@ -50,49 +43,59 @@
with (linear-sums
(f-of (strides from) (head from))
(t-of (strides to) (head to)))
- do (let*-typed ((val-f ,(funcall (getf opt :reader) 'f-sto 'f-of) :type ,(getf opt :element-type))
- (val-t ,(funcall (getf opt :reader) 't-sto 't-of) :type ,(getf opt :element-type))
+ do (let*-typed ((val-f (,(getf opt :reader) f-sto f-of) :type ,(getf opt :element-type))
+ (val-t (,(getf opt :reader) t-sto t-of) :type ,(getf opt :element-type))
(mul (* val-f val-t) :type ,(getf opt :element-type)))
- ,(funcall (getf opt :value-writer) 'mul 't-sto 't-of))))))))
+ (,(getf opt :value-writer) mul t-sto t-of)))))))
+ (if fortran-func
+ `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
+ (strd-p (when call-fortran? (blas-copyable-p from to))))
+ (cond
+ ((and strd-p call-fortran?)
+ (,fortran-func (number-of-elements from)
+ (store from) (first strd-p)
+ (store to) (second strd-p)
+ (head from) (head to)))
+ (t
+ ,lisp-routine)))
+ lisp-routine))
to)))
(defmacro generate-typed-num-scal! (func (tensor-class blas-func fortran-lb))
- (let ((opt (get-tensor-class-optimization tensor-class)))
+ (let ((opt (get-tensor-class-optimization-hashtable tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
`(definline ,func (alpha to)
(declare (type ,tensor-class to)
(type ,(getf opt :element-type) alpha))
- (let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
- (min-stride (when call-fortran? (consecutive-store-p to))))
- (cond
- ((and call-fortran? min-stride)
- (,blas-func (number-of-elements to) alpha (store to) min-stride (head to)))
- (t
- (let ((t-sto (store to)))
+ ,(let
+ ((lisp-routine
+ `(let ((t-sto (store to)))
(declare (type ,(linear-array-type (getf opt :store-type)) t-sto))
(very-quickly
(mod-dotimes (idx (dimensions to))
with (linear-sums
(t-of (strides to) (head to)))
- do (let ((scal-val (* ,(funcall (getf opt :reader) 't-sto 't-of) alpha)))
- ,(funcall (getf opt :value-writer) 'scal-val 't-sto 't-of))))))))
+ do (let ((scal-val (* (,(getf opt :reader) t-sto t-of) alpha)))
+ (,(getf opt :value-writer) scal-val t-sto t-of)))))))
+ (if blas-func
+ `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
+ (min-stride (when call-fortran? (consecutive-store-p to))))
+ (cond
+ ((and call-fortran? min-stride)
+ (,blas-func (number-of-elements to) alpha (store to) min-stride (head to)))
+ (t
+ ,lisp-routine)))
+ lisp-routine))
to)))
(defmacro generate-typed-div! (func (tensor-class fortran-func fortran-lb))
- (let* ((opt (get-tensor-class-optimization tensor-class)))
+ (let* ((opt (get-tensor-class-optimization-hashtable tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
`(definline ,func (from to)
(declare (type ,tensor-class from to))
- (let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
- (strd-p (when call-fortran? (blas-copyable-p from to))))
- (cond
- ((and strd-p call-fortran?)
- (,fortran-func (number-of-elements from)
- (store from) (first strd-p)
- (store to) (second strd-p)
- (head from) (head to)))
- (t
- (let ((f-sto (store from))
+ ,(let
+ ((lisp-routine
+ `(let ((f-sto (store from))
(t-sto (store to)))
(declare (type ,(linear-array-type (getf opt :store-type)) f-sto t-sto))
(very-quickly
@@ -100,10 +103,22 @@
with (linear-sums
(f-of (strides from) (head from))
(t-of (strides to) (head to)))
- do (let*-typed ((val-f ,(funcall (getf opt :reader) 'f-sto 'f-of) :type ,(getf opt :element-type))
- (val-t ,(funcall (getf opt :reader) 't-sto 't-of) :type ,(getf opt :element-type))
+ do (let*-typed ((val-f (,(getf opt :reader) f-sto f-of) :type ,(getf opt :element-type))
+ (val-t (,(getf opt :reader) t-sto t-of) :type ,(getf opt :element-type))
(mul (/ val-f val-t) :type ,(getf opt :element-type)))
- ,(funcall (getf opt :value-writer) 'mul 't-sto 't-of))))))))
+ (,(getf opt :value-writer) mul t-sto t-of)))))))
+ (if fortran-func
+ `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
+ (strd-p (when call-fortran? (blas-copyable-p from to))))
+ (cond
+ ((and strd-p call-fortran?)
+ (,fortran-func (number-of-elements from)
+ (store from) (first strd-p)
+ (store to) (second strd-p)
+ (head from) (head to)))
+ (t
+ ,lisp-routine)))
+ lisp-routine))
to)))
(defmacro generate-typed-num-div! (func (tensor-class fortran-func fortran-lb))
@@ -112,24 +127,29 @@
`(definline ,func (alpha to)
(declare (type ,tensor-class to)
(type ,(getf opt :element-type) alpha))
- (let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
- (min-stride (when call-fortran? (consecutive-store-p to))))
- (cond
- ((and call-fortran? min-stride)
- (let ((num-array (,(getf opt :store-allocator) 1)))
- (declare (type ,(linear-array-type (getf opt :store-type)) num-array))
- (let-typed ((id (,(getf opt :coercer) 1) :type ,(getf opt :element-type)))
- ,(funcall (getf opt :value-writer) `id 'num-array 0))
- (,fortran-func (number-of-elements to) num-array 0 (store to) min-stride (head to))))
- (t
- (let ((t-sto (store to)))
+ ,(let
+ ((lisp-routine
+ `(let ((t-sto (store to)))
(declare (type ,(linear-array-type (getf opt :store-type)) t-sto))
(very-quickly
(mod-dotimes (idx (dimensions to))
with (linear-sums
(t-of (strides to) (head to)))
- do (let-typed ((scal-val (/ alpha ,(funcall (getf opt :reader) 't-sto 't-of)) :type ,(getf opt :element-type)))
- ,(funcall (getf opt :value-writer) 'scal-val 't-sto 't-of))))))))
+ do (let-typed ((scal-val (/ alpha (,(getf opt :reader) t-sto t-of)) :type ,(getf opt :element-type)))
+ (,(getf opt :value-writer) scal-val t-sto t-of)))))))
+ (if fortran-func
+ `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb))
+ (min-stride (when call-fortran? (consecutive-store-p to))))
+ (cond
+ ((and call-fortran? min-stride)
+ (let ((num-array (,(getf opt :store-allocator) 1)))
+ (declare (type ,(linear-array-type (getf opt :store-type)) num-array))
+ (let-typed ((id (,(getf opt :coercer) 1) :type ,(getf opt :element-type)))
+ (,(getf opt :value-writer) id num-array 0))
+ (,fortran-func (number-of-elements to) num-array 0 (store to) min-stride (head to))))
+ (t
+ ,lisp-routine)))
+ lisp-routine))
to)))
;;Real
diff --git a/src/level-1/swap.lisp b/src/level-1/swap.lisp
index f2eb094..9de6966 100644
--- a/src/level-1/swap.lisp
+++ b/src/level-1/swap.lisp
@@ -32,25 +32,30 @@
;;Be very careful when using functions generated by this macro.
;;Indexes can be tricky and this has no safety net
;;Use only after checking the arguments for compatibility.
- (let* ((opt (get-tensor-class-optimization tensor-class)))
+ (let* ((opt (get-tensor-class-optimization-hashtable tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
`(definline ,func (x y)
(declare (type ,tensor-class x y))
- (let* ((call-fortran? (> (number-of-elements x) ,fortran-lb))
- (strd-p (when call-fortran? (blas-copyable-p x y))))
- (cond
- ((and strd-p call-fortran?)
- (,blas-func (number-of-elements x) (store x) (first strd-p) (store y) (second strd-p) (head x) (head y)))
- (t
- (let ((f-sto (store x))
+ ,(let
+ ((lisp-routine
+ `(let ((f-sto (store x))
(t-sto (store y)))
- (declare (type ,(linear-array-type (getf opt :store-type)) f-sto t-sto))
- (very-quickly
- (mod-dotimes (idx (dimensions x))
- with (linear-sums
- (f-of (strides x) (head x))
- (t-of (strides y) (head y)))
- do ,(funcall (getf opt :swapper) 'f-sto 'f-of 't-sto 't-of)))))))
+ (declare (type ,(linear-array-type (getf opt :store-type)) f-sto t-sto))
+ (very-quickly
+ (mod-dotimes (idx (dimensions x))
+ with (linear-sums
+ (f-of (strides x) (head x))
+ (t-of (strides y) (head y)))
+ do (,(getf opt :swapper) f-sto f-of t-sto t-of))))))
+ (if blas-func
+ `(let* ((call-fortran? (> (number-of-elements x) ,fortran-lb))
+ (strd-p (when call-fortran? (blas-copyable-p x y))))
+ (cond
+ ((and strd-p call-fortran?)
+ (,blas-func (number-of-elements x) (store x) (first strd-p) (store y) (second strd-p) (head x) (head y)))
+ (t
+ ,lisp-routine)))
+ lisp-routine))
y)))
(generate-typed-swap! real-typed-swap!
diff --git a/src/level-1/tensor-maker.lisp b/src/level-1/tensor-maker.lisp
index 6f7cb3b..4ce8f18 100644
--- a/src/level-1/tensor-maker.lisp
+++ b/src/level-1/tensor-maker.lisp
@@ -1,10 +1,8 @@
(in-package #:matlisp)
(defmacro make-tensor-maker (func-name (tensor-class))
- (let ((opt (get-tensor-class-optimization tensor-class))
- (cocl (get-tensor-counterclass tensor-class)))
+ (let ((opt (get-tensor-class-optimization-hashtable tensor-class)))
(assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
- (assert cocl nil 'tensor-cannot-find-counter-class :tensor-class tensor-class)
`(progn
(declaim (ftype (function (&rest t) ,tensor-class) ,func-name))
(defun ,func-name (&rest args)
@@ -14,7 +12,7 @@
(ss (very-quickly (lvec-foldl #'(lambda (x y) (the index-type (* x y))) vdim)))
(store (,(getf opt :store-allocator) ss))
(rnk (length vdim)))
- (make-instance (case rnk (2 ',(getf cocl :matrix)) (1 ',(getf cocl :vector)) (t ',tensor-class))
+ (make-instance (case rnk (2 ',(getf opt :matrix)) (1 ',(getf opt :vector)) (t ',tensor-class))
:store store :dimensions vdim)))
(make-from-array (arr)
(declare (type (array * *) arr))
@@ -26,7 +24,7 @@
(mod-dotimes (idx (dimensions ret))
with (linear-sums
(of-r (strides ret) (head ret)))
- do ,(funcall (getf opt :value-writer) `(,(getf opt :coercer) (apply #'aref arr (lvec->list! idx lst))) 'st-r 'of-r))
+ do (,(getf opt :value-writer) (,(getf opt :coercer) (apply #'aref arr (lvec->list! idx lst))) st-r of-r))
ret))
(make-from-list (lst)
(let* ((ret (make-dims (list-dimensions lst)))
@@ -36,7 +34,7 @@
(list-loop (idx ele lst)
with (linear-sums
(of-r (strides ret) (head ret)))
- do ,(funcall (getf opt :value-writer) `(,(getf opt :coercer) ele) 'st-r 'of-r))
+ do (,(getf opt :value-writer) (,(getf opt :coercer) ele) st-r of-r))
ret)))
(let ((largs (length args)))
(if (= largs 1)
commit ff3082257b6f984b30131dd170f011eacd78f7e6
Author: Akshay Srinivasan <aks...@gm...>
Date: Sun Dec 23 17:16:26 2012 -0600
o Extended tensor-class-optimization with slots for underlying Field properties.
o Moved lots of stuff to define-tensor macro
diff --git a/src/base/standard-tensor.lisp b/src/base/standard-tensor.lisp
index 9899186..0691120 100644
--- a/src/base/standard-tensor.lisp
+++ b/src/base/standard-tensor.lisp
@@ -48,10 +48,6 @@
:accessor number-of-elements
:type index-type
:documentation "Total number of elements in the tensor.")
- (element-type
- :accessor element-type
- :type symbol
- :documentation "Element type of the tensor")
;;
(parent-tensor
:accessor parent-tensor
@@ -83,6 +79,7 @@
(defclass standard-matrix (standard-tensor)
((rank
:accessor rank
+ :allocation :class
:type index-type
:initform 2
:documentation "For a matrix, rank = 2."))
@@ -91,7 +88,7 @@
;;
(defmethod initialize-instance :after ((matrix standard-matrix) &rest initargs)
(declare (ignore initargs))
- (mlet*
+ (let-typed
((rank (rank matrix) :type index-type))
(unless (= rank 2)
(error 'tensor-not-matrix :rank rank :tensor matrix))))
@@ -105,6 +102,7 @@
(defclass standard-vector (standard-tensor)
((rank
:accessor rank
+ :allocation :class
:type index-type
:initform 1
:documentation "For a vector, rank = 1."))
@@ -149,10 +147,21 @@
(defvar *tensor-class-optimizations* (make-hash-table)
"
Contains a either:
- o A property list containing:
+ o A property list containing:
+ :field-type -> Field type
+ :f+ (a b) -> a + b
+ :f- (a b) -> a + (- b)
+ :finv+ (a) -> -a
+ :fid+ () -> + identity
+ :f* (a b) -> a * b
+ :f/ (a b) -> a * b^{-1}
+ :finv* (a) -> 1/a
+ :fid* () -> * identity
+
+ :coercer (ele) -> Coerced to store-type, with error checking
+ :coercer-unforgiving (ele) -> Coerced to store-type, no error checking
+
:store-allocator (n) -> Allocates a store of size n
- :coercer (ele) -> Coerced to store-type
- :element-type
:store-type
:reader (store idx) => result
:value-writer (value store idx) => (store idx) <- value
@@ -340,40 +349,57 @@
(unless (< -1 idx (store-size tensor))
(error 'tensor-store-index-out-of-bounds :index idx :store-size (store-size tensor) :tensor tensor))))
-(defmacro tensor-store-defs ((tensor-class element-type store-element-type) &key store-allocator coercer reader value-writer reader-writer swapper)
- (let ((tensym (gensym "tensor")))
- (assert store-allocator)
- (assert coercer)
- (assert (eq (first reader-writer) 'lambda))
- (assert swapper)
- `(progn
- ,(destructuring-bind (lbd args &rest body) reader
- (assert (eq lbd 'lambda))
- (destructuring-bind (tstore idx) args
- `(defmethod tensor-store-ref ((,tensym ,tensor-class) ,idx)
- (declare (type index-type ,idx))
- (let ((,tstore (store ,tensym)))
- (declare (type ,(linear-array-type store-element-type) ,tstore))
- ,@body))))
- ,(destructuring-bind (lbd args &rest body) value-writer
- (assert (eq lbd 'lambda))
- (destructuring-bind (value tstore tidx) args
- `(defmethod (setf tensor-store-ref) (,value (,tensym ,tensor-class) ,tidx)
- (declare (type index-type ,tidx)
- (type ,element-type ,value))
- (let ((,tstore (store ,tensym)))
- (declare (type ,(linear-array-type store-element-type) ,tstore))
- ,@body))))
- (let ((hst (list
- :reader (macrofy ,reader)
- :value-writer (macrofy ,value-writer)
- :reader-writer (macrofy ,reader-writer)
- :swapper (macrofy ,swapper)
- :store-allocator ',store-allocator
- :coercer ',coercer
- :element-type ',element-type
- :store-type ',store-element-type)))
- (setf (get-tensor-class-optimization ',tensor-class) hst)))))
+(defmacro define-tensor
+ ((tensor-class element-type store-element-type store-type &rest class-decls) &key
+ f+ f- finv+ fid+ f* f/ finv* fid*
+ matrix vector
+ store-allocator coercer coercer-unforgiving reader value-writer reader-writer swapper)
+ ;;Error checking
+ (assert (and f+ f- finv+ fid+ f* f/ finv* fid* store-allocator coercer coercer-unforgiving matrix vector reader value-writer reader-writer swapper))
+ ;;
+ `(progn
+ ;;Class definitions
+ (defclass ,tensor-class (standard-tensor)
+ ((store :type ,store-type))
+ ,@class-decls)
+ (defclass ,matrix (standard-matrix ,tensor-class)
+ ())
+ (defclass ,vector (standard-vector ,tensor-class)
+ ())
+ (setf (get-tensor-counterclass ',tensor-class) (list :matrix ',matrix :vector ',vector)
+ (get-tensor-counterclass ',matrix) ',tensor-class
+ (get-tensor-counterclass ',vector) ',tensor-class)
+ ;;Store refs
+ (defmethod tensor-store-ref ((tensor ,tensor-class) idx)
+ (declare (type index-type idx))
+ (let-typed ((store (store tensor) :type ,store-type))
+ (,reader store idx)))
+ (defmethod (setf tensor-store-ref) (value (tensor ,tensor-class) idx)
+ (declare (type index-type idx)
+ (type ,element-type value))
+ (let-typed ((store (store tensor) :type ,store-type))
+ (,value-writer value store idx)))
+ ;;
+ (let ((hst (list
+ :field-type ',element-type
+ :f+ ',f+
+ :f- ',f-
+ :finv+ ',finv+
+ :fid+ ',fid+
+ :f* ',f*
+ :f/ ',f/
+ :finv* ',finv*
+ :fid* ',fid*
+ :reader ',reader
+ :value-writer ',value-writer
+ :reader-writer ',reader-writer
+ :swapper ',swapper
+ :store-allocator ',store-allocator
+ :coercer ',coercer
+ :coercer-unforgiving ',coercer-unforgiving
+ :element-type ',element-type
+ :store-type ',store-element-type)))
+ (setf (get-tensor-class-optimization ',tensor-class) hst))))
;;
(defgeneric tensor-ref (tensor subscripts)
@@ -420,11 +446,11 @@
;;
-(defun tensor-type-p (tensor subscripts)
+(defun tensor-typep (tensor subscripts)
"
Syntax
======
- (tensor-type-p tensor subscripts)
+ (tensor-typep tensor subscripts)
Purpose
=======
@@ -434,14 +460,14 @@
Examples
========
Checking for a vector:
- > (tensor-type-p ten '(*))
+ > (tensor-typep ten '(*))
Checking for a matrix with 2 columns:
- > (tensor-type-p ten '(* 2))
+ > (tensor-typep ten '(* 2))
Also does symbolic association; checking for
a square matrix:
- > (tensor-type-p ten '(a a))
+ > (tensor-typep ten '(a a))
"
(declare (type standard-tensor tensor))
(mlet* (((rank dims) (slot-values tensor '(rank dimensions))
diff --git a/src/classes/real-tensor.lisp b/src/classes/real-tensor.lisp
index e7b8602..7e22544 100644
--- a/src/classes/real-tensor.lisp
+++ b/src/classes/real-tensor.lisp
@@ -7,8 +7,61 @@
(deftype real-store-vector (&optional (size '*))
"The type of the storage structure for a REAL-MATRIX"
`(simple-array real-type (,size)))
-;;
+;;Field definitions
+(definline real-type.f+ (a b)
+ (declare (type real-type a b))
+ (+ a b))
+
+(definline real-type.f- (a b)
+ (declare (type real-type a b))
+ (- a b))
+
+(definline real-type.finv+ (a)
+ (declare (type real-type a))
+ (- a))
+
+(definline real-type.fid+ ()
+ 0.0d0)
+
+(definline real-type.f* (a b)
+ (declare (type real-type a b))
+ (* a b))
+
+(definline real-type.f/ (a b)
+ (declare (type real-type a b))
+ (/ a b))
+
+(definline real-type.finv* (a)
+ (declare (type real-type a))
+ (/ a))
+
+(definline real-type.fid* ()
+ 1.0d0)
+
+;;Store definitions
+(definline real-type.reader (tstore idx)
+ (declare (type index-type idx)
+ (type real-store-vector tstore))
+ (aref tstore idx))
+
+(definline real-type.value-writer (value store idx)
+ (declare (type index-type idx)
+ (type real-store-vector store)
+ (type real-type value))
+ (setf (aref store idx) value))
+
+(definline real-type.reader-writer (fstore fidx tstore tidx)
+ (declare (type index-type fidx tidx)
+ (type real-store-vector fstore tstore))
+ (setf (aref tstore tidx) (aref fstore fidx)))
+
+(definline real-type.swapper (fstore fidx tstore tidx)
+ (declare (type index-type fidx tidx)
+ (type real-store-vector fstore tstore))
+ (rotatef (aref tstore tidx) (aref fstore fidx)))
+
+;;
(make-array-allocator allocate-real-store 'real-type 0d0
"(allocate-real-store size [initial-element])
Allocates real storage. Default initial-element = 0d0.")
@@ -21,22 +74,28 @@ Allocates real storage. Default initial-element = 0d0.")
(use-value (value) (coerce-real value))))
;;
-(defclass real-tensor (standard-tensor)
- ((store :type real-store-vector)
- (element-type :initform 'real-type))
- (:documentation "Tensor class with real elements."))
-
-(defclass real-matrix (standard-matrix real-tensor)
- ()
- (:documentation "A class of matrices with real elements."))
-
-(defclass real-vector (standard-vector real-tensor)
- ()
- (:documentation "A class of vector with real elements."))
-
-(setf (get-tensor-counterclass 'real-tensor) '(:matrix real-matrix :vector real-vector)
- (get-tensor-counterclass 'real-matrix) 'real-tensor
- (get-tensor-counterclass 'real-vector) 'real-tensor)
+(define-tensor (real-tensor real-type real-type real-store-vector)
+ :matrix real-matrix :vector real-vector
+ ;;
+ :f+ real-type.f+
+ :f- real-type.f-
+ :finv+ real-type.finv+
+ :fid+ real-type.fid+
+ :f* real-type.f*
+ :f/ real-type.f/
+ :finv* real-type.finv*
+ :fid* real-type.fid*
+ ;;
+ :store-allocator allocate-real-store
+ :coercer coerce-real
+ :coercer-unforgiving coerce-real-unforgiving
+ ;;
+ :matrix real-matrix :vector real-vector
+ ;;
+ :reader real-type.reader
+ :value-writer real-type.value-writer
+ :reader-writer real-type.reader-writer
+ :swapper real-type.swapper)
;;
(defmethod initialize-instance ((tensor real-tensor) &rest initargs)
@@ -47,23 +106,6 @@ Allocates real storage. Default initial-element = 0d0.")
(slot-value tensor 'store-size) size)))
(call-next-method))
-;;
-(tensor-store-defs (real-tensor real-type real-type)
- :store-allocator allocate-real-store
- :coercer coerce-real-unforgiving
- :reader
- (lambda (tstore idx)
- (aref tstore idx))
- :value-writer
- (lambda (value store idx)
- (setf (aref store idx) value))
- :reader-writer
- (lambda (fstore fidx tstore tidx)
- (setf (aref tstore tidx) (aref fstore fidx)))
- :swapper
- (lambda (fstore fidx tstore tidx)
- (rotatef (aref tstore tidx) (aref fstore fidx))))
-
(setf (get-tensor-class-optimization 'real-matrix) 'real-tensor
(get-tensor-class-optimization 'real-vector) 'real-tensor)
-----------------------------------------------------------------------
hooks/post-receive
--
matlisp
|
