Menu
▾
▴
matlisp-commit
|
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? (...
[truncated message content] |
Thanks for helping keep SourceForge clean.
X