Menu
▾
▴
matlisp-commit
|
From: Akshay S. <ak...@us...> - 2012-06-24 15:41:51
|
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "matlisp".
The branch, tensor has been updated
via 8bb55ab5b53aa70785619511fcd6457b3bb79401 (commit)
from 8232b005b14d4aced35d7ce07afe9a9c35233b7e (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 8bb55ab5b53aa70785619511fcd6457b3bb79401
Author: Akshay Srinivasan <aks...@gm...>
Date: Sun Jun 24 21:06:39 2012 +0530
Added infrastructure to make the tensor-aware "compiler" macros
for working with mod-loops.
diff --git a/AUTHORS b/AUTHORS
index 8ca39ab..c400f4e 100644
--- a/AUTHORS
+++ b/AUTHORS
@@ -3,6 +3,6 @@ based on an initial prototype by Raymond Toy.
It is now being refactored by Akshay Srinivasan.
-Some code has been either been directly obtained from,
-or modified from Femlisp (www.femlisp.org), written by
-Nicholas Neuss.
+Some of code was originally written by Nicholas Neuss for
+Femlisp (www.femlisp.org); it has used here (with modification)
+with the author's consent.
diff --git a/matlisp.asd b/matlisp.asd
index 4de9217..1a5eecc 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -91,7 +91,13 @@
(:file "complex-tensor"
:depends-on ("standard-tensor"))
(:file "standard-matrix"
- :depends-on ("standard-tensor"))))))
+ :depends-on ("standard-tensor"))
+ ;; (:file "real-matrix"
+ ;; :depends-on ("standard-matrix"))
+ ;; (:file "complex-matrix"
+ ;; :depends-on ("standard-matrix"))
+ (:file "print"
+ :depends-on ("standard-tensor" "standard-matrix"))))))
;; (defclass f2cl-cl-source-file (asdf:cl-source-file)
diff --git a/packages.lisp b/packages.lisp
index 49d63b1..cbe1052 100644
--- a/packages.lisp
+++ b/packages.lisp
@@ -159,11 +159,14 @@
#:zip #:zip-eq
#:cut-cons-chain!
#:slot-values
- #:recursive-append
+ #:recursive-append #:unquote-args #:flatten
+ #:format-to-string #:string+
+ #:linear-array-type
;;Macros
#:when-let #:if-let #:if-ret #:with-gensyms #:let-rec
#:mlet* #:make-array-allocator
#:nconsc #:define-constant
+ #:macrofy
;;
#:inlining #:definline
#:with-optimization #:quickly #:very-quickly #:slowly #:quickly-if
@@ -173,10 +176,13 @@
(defpackage :fortran-ffi-accessors
(:nicknames :ffi)
- #+:cmu (:use :common-lisp :c-call :cffi :utilities)
- #+:sbcl (:use :common-lisp :sb-alien :sb-c :cffi :utilities)
- #+:allegro (:use :common-lisp :cffi :utilities)
- #+(not (or sbcl cmu allegro)) (:use :common-lisp :cffi :utilities)
+ (:use :common-lisp :cffi :utilities)
+ ;; TODO: Check if this is implementation-agnostic.
+ ;; #+:cmu (:use :common-lisp :c-call :cffi :utilities)
+ ;; #+:sbcl (:use :common-lisp :cffi :utilities)
+
+ ;; #+:allegro (:use :common-lisp :cffi :utilities)
+ ;; #+(not (or sbcl cmu allegro)) (:use :common-lisp :cffi :utilities)
(:export
;; interface functions
#:def-fortran-routine
diff --git a/src/complex-tensor.lisp b/src/complex-tensor.lisp
index 530aff9..b7abc41 100644
--- a/src/complex-tensor.lisp
+++ b/src/complex-tensor.lisp
@@ -7,11 +7,11 @@
(deftype complex-base-array (size)
"The type of the storage structure for a COMPLEX-MATRIX"
- `(simple-array real-type (,size)))
+ `(simple-array complex-base-type (,size)))
(deftype complex-type ()
"Complex number with Re, Im parts in complex-base-type."
- '(cl:complex (complex-base-type * *)))
+ '(cl:complex complex-base-type))
)
;;
@@ -25,6 +25,9 @@ Default initial-element = 0d0."
(definline coerce-complex (x)
(coerce x 'complex-type))
+(definline coerce-complex-base (x)
+ (coerce x 'complex-base-type))
+
;;
(defclass complex-tensor (standard-tensor)
((store
@@ -53,13 +56,21 @@ Cannot hold complex numbers."))
(call-next-method))
;;
-(defmethod tensor-store-ref ((tensor complex-tensor) (idx fixnum))
- (complex (aref (store tensor) (* 2 idx))
- (aref (store tensor) (+ (* 2 idx) 1))))
+(tensor-store-defs (complex-tensor complex-type complex-base-type)
+ :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 fstore (* 2 fidx)) (aref tstore (* 2 tidx))
+ (aref fstore (1+ (* 2 fidx))) (aref tstore (1+ (* 2 tidx))))))
-(defmethod (setf tensor-store-ref) ((value number) (tensor complex-tensor) (idx fixnum))
- (setf (aref (store tensor) (* 2 idx)) (coerce (realpart value) 'complex-base-type)
- (aref (store tensor) (+ (* 2 idx) 1)) (coerce (imagpart value) 'complex-base-type)))
+(setf (gethash 'complex-sub-tensor *tensor-class-optimizations*) 'complex-tensor)
;;
(defmethod print-element ((tensor complex-tensor)
@@ -77,4 +88,3 @@ Cannot hold complex numbers."))
(ss (reduce #'* dims))
(store (allocate-complex-store ss)))
(make-instance 'complex-tensor :store store :dimensions dims)))
-
diff --git a/src/conditions.lisp b/src/conditions.lisp
index 9b5586b..7935cf3 100644
--- a/src/conditions.lisp
+++ b/src/conditions.lisp
@@ -39,7 +39,9 @@
(defmethod print-object ((c invalid-value) stream)
(format stream "Given object ~A, expected ~A.~%" (given c) (expected c))
(call-next-method))
-
+;;---------------------------------------------------------------;;
+
+
;;---------------------------------------------------------------;;
(define-condition matlisp-error (error)
;;Optional argument for error-handling.
diff --git a/src/ffi-cffi-interpreter-specific.lisp b/src/ffi-cffi-interpreter-specific.lisp
index c80216d..4d51dc0 100644
--- a/src/ffi-cffi-interpreter-specific.lisp
+++ b/src/ffi-cffi-interpreter-specific.lisp
@@ -1,7 +1,9 @@
;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Package: :fortran-ffi-accessors; Base: 10 -*-
;; Yes the file name is an oxymoron.
-(in-package "FORTRAN-FFI-ACCESSORS")
+(in-package :ffi)
+
+;;TODO: Add support for {Allegro CL, Lispworks, ECL, clisp}
(defmacro with-fortran-float-modes (&body body)
"Execute the body with the IEEE FP modes appropriately set for Fortran"
@@ -40,18 +42,17 @@
#+ccl `(ccl::without-gcing)
body))
-(defmacro vector-sap-interpreter-specific (vec)
- #+sbcl `(sb-sys:vector-sap ,vec)
- #+cmu `(system:vector-sap ,vec)
- #+ccl (let ((addr-vec (gensym)))
- `(let ((,addr-vec (ccl:%null-ptr)))
- (declare (type ccl:macptr ,addr-vec))
- (ccl::%vect-data-to-macptr ,vec ,addr-vec))))
+(definline vector-sap-interpreter-specific (vec)
+ #+sbcl (sb-sys:vector-sap vec)
+ #+cmu (system:vector-sap vec)
+ #+ccl (let ((addr-vec (ccl:%null-ptr)))
+ (declare (type ccl:macptr addr-vec))
+ (ccl::%vect-data-to-macptr vec addr-vec)))
-(defmacro vector-data-address (vec)
-"
-Creates lisp code to return the physical address of where the actual
-data of the object VEC is stored.
+#+(or sbcl cmu ccl)
+(defun vector-data-address (vec)
+ "
+Returns the pointer address of where the actual data store of the object VEC.
VEC - must be a either a (complex double-float), (complex single-float)
or a specialized array type in CMU Lisp. This currently means
@@ -65,45 +66,18 @@ VEC is a simple-array of one dimension of one of the following types:
Returns
1 - system area pointer to the actual data
"
- `(progn
- (with-optimization (:speed 1 :safety 3)
- ;; It's quite important that the arrays have the right type.
- ;; Otherwise, we will probably get the address of the data wrong,
- ;; and then foreign function could be scribbling over who knows
- ;; where!
- (check-type ,vec matlisp-specialized-array))
- (with-optimization (:speed 3 :safety 0 :space 0)
- ;;vec is either a simple-array or a system-area-pointer itself.
- (declare (type matlisp-specialized-array ,vec))
- (if (typep ,vec '(simple-array * (*)))
- (vector-sap-interpreter-specific ,vec)
- vec))))
-
-;; #+(or sbcl cmu ccl)
-;; (progn
-;; (declaim (inline vector-data-address))
-
-;; (defun vector-data-address (vec)
-
-;; (locally
-;; (declare (optimize (speed 1) (safety 3)))
-;; ;; It's quite important that the arrays have the write type.
-;; ;; Otherwise, we will probably get the address of the data wrong,
-;; ;; and then foreign function could be scribbling over who knows
-;; ;; where!
-;; ;;
-;; (check-type vec matlisp-specialized-array))
-;; (locally
-;; (declare (type matlisp-specialized-array vec)
-;; (optimize (speed 3) (safety 0) (space 0)))
-;; ;;vec is either a simple-array or a system-area-pointer itself.
-;; (if (typep vec '(simple-array * (*)))
-;; #+sbcl (sb-sys:vector-sap vec)
-;; #+cmu (system:vector-sap vec)
-;; #+ccl (let ((addr-vec (ccl:%null-ptr)))
-;; (declare (type ccl:macptr addr-vec))
-;; (ccl::%vect-data-to-macptr vec addr-vec))
-;; vec))))
+ (with-optimization (:speed 1 :safety 3)
+ ;; It's quite important that the arrays have the right type.
+ ;; Otherwise, we will probably get the address of the data wrong,
+ ;; and then foreign function could be scribbling over who knows
+ ;; where!
+ (check-type vec matlisp-specialized-array))
+ (with-optimization (:speed 3 :safety 0 :space 0)
+ ;;vec is either a simple-array or a system-area-pointer itself.
+ (declare (type matlisp-specialized-array vec))
+ (if (typep vec '(simple-array * (*)))
+ (vector-sap-interpreter-specific vec)
+ vec)))
#+(or sbcl cmu ccl)
(defmacro with-vector-data-addresses (vlist &body body)
diff --git a/src/ffi-cffi.lisp b/src/ffi-cffi.lisp
index 3311dc6..deabaaa 100644
--- a/src/ffi-cffi.lisp
+++ b/src/ffi-cffi.lisp
@@ -413,16 +413,15 @@
,@pars))
(setq hack-return-type :void)))
- `(eval-when (load eval compile)
- (progn
- ;; Removing 'inlines' It seems that CMUCL has a problem with
- ;; inlines of FFI's when a lisp image is saved. Until the
- ;; matter is clarified we leave out 'inline's
-
- ;; (declaim (inline ,lisp-name)) ;sbcl 0.8.5 has problems with
- (cffi:defcfun (,fortran-name ,lisp-name) ,@(get-return-type hack-return-type)
- ,@(parse-fortran-parameters hack-body))
- ,@(def-fortran-interface name hack-return-type hack-body hidden-var-name))))))
+ `(progn
+ ;; Removing 'inlines' It seems that CMUCL has a problem with
+ ;; inlines of FFI's when a lisp image is saved. Until the
+ ;; matter is clarified we leave out 'inline's
+
+ ;; (declaim (inline ,lisp-name)) ;sbcl 0.8.5 has problems with
+ (cffi:defcfun (,fortran-name ,lisp-name) ,@(get-return-type hack-return-type)
+ ,@(parse-fortran-parameters hack-body))
+ ,@(def-fortran-interface name hack-return-type hack-body hidden-var-name)))))
;; Create a form specifying a simple Lisp function that calls the
;; underlying Fortran routine of the same name.
diff --git a/src/print.lisp b/src/print.lisp
index 06d2d4d..816b2f1 100644
--- a/src/print.lisp
+++ b/src/print.lisp
@@ -81,148 +81,84 @@
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Routines for printing a matrix nicely.
+;;; Routines for printing a tensors/matrices nicely.
-(in-package "MATLISP")
+(in-package :matlisp)
-(defvar *print-max-len*
- 5
- "Maximum number of elements in any particular argument to print.
- Set this to NIL to print no elements. Set this to T
- to print all elements.")
+(defparameter *print-max-len* 5
+"
+Maximum number of elements in any particular argument to print.
+Set this to T to print all the elements.
+")
-(defvar *print-max-args* 5
- "Maximum number of arguments of the tensor to print.
- Set this to NIL to print none; to T to print all of them.")
+(defparameter *print-max-args* 5
+"
+Maximum number of arguments of the tensor to print.
+Set this to T to print all the arguments.
+")
-(defun set-print-limits-for-matrix (n m)
- (declare (type fixnum n m))
- (if (eq *print-matrix* t)
- (values n m)
- (if (eq *print-matrix* nil)
- (values 0 0)
- (if (and (integerp *print-matrix*)
- (> *print-matrix* 0))
- (values (min n *print-matrix*)
- (min m *print-matrix*))
- (error "Cannot set the print limits for matrix.
-Required that *PRINT-MATRIX* be T,NIL or a positive INTEGER,
-but got *PRINT-MATRIX* of type ~a"
- (type-of *print-matrix*))))))
-
-(defvar *print-indent* 0
- "Determines how many spaces will be printed before each row
- of a matrix (default 0)")
+(defparameter *print-indent* 0
+"
+Determines how many spaces will be printed before each row
+of a matrix (default 0)
+")
(defun print-tensor (tensor stream)
(let ((rank (rank tensor))
- (dims (dimensions tensor)))
+ (dims (dimensions tensor))
+ (two-print-calls 0))
(labels ((two-print (tensor subs)
- (dotimes (i (aref dims 0))
- (dotimes (j (aref dims 1))
- (format stream "~A~,4T" (apply #'tensor-ref (list tensor (append (list i j) subs)))))
- (format stream "~%")))
- (rec-print (tensor idx subs)
- (if (> idx 1)
- (dotimes (i (aref dims idx))
- (rec-print tensor (1- idx) (cons i subs)))
+ (dotimes (i (aref dims (- rank 2)))
+ (format stream (format-to-string "~~~AT" *print-indent*))
+ (if (or (eq *print-max-len* t) (< i *print-max-len*))
+ (progn
+ (dotimes (j (aref dims (- rank 1)))
+ (if (or (eq *print-max-len* t) (< j *print-max-len*))
+ (progn
+ (print-element tensor (tensor-ref tensor (append subs `(,i ,j))) stream)
+ (format stream "~,4T"))
+ (progn
+ (format stream "...")
+ (return nil))))
+ (format stream "~%"))
(progn
- (format stream "~A~%" (append (list '\: '\:) subs))
- (two-print tensor subs)
- (format stream "~%")))))
- (format stream "~A ~A~%" rank dims)
+ (format stream (format-to-string ".~~%~~~AT:~~%" *print-indent*))
+ (return nil)))))
+ (rec-print (tensor idx subs)
+ (if (< idx (- rank 2))
+ (dotimes (i (aref dims idx) t)
+ (unless (rec-print tensor (1+ idx) (append subs `(,i)))
+ (return nil)))
+ (progn
+ (if (or (eq *print-max-args* t) (< two-print-calls *print-max-args*))
+ (progn
+ (format stream "~A~%" (append subs '(\: \:)))
+ (two-print tensor subs)
+ (format stream "~%")
+ (incf two-print-calls)
+ t)
+ (progn
+ (format stream "~A~%" (make-list rank :initial-element '\:))
+ (format stream (format-to-string "~~~AT..~~%~~~AT::~~%" *print-indent* *print-indent*))
+ nil))))))
+
(case rank
(1
(dotimes (i (aref dims 0))
- (format stream "~A~,4T" (tensor-ref tensor `(,i))))
+ (print-element tensor (tensor-ref tensor `(,i)) stream)
+ (format stream "~,4T"))
(format stream "~%"))
(2
(two-print tensor nil))
(t
- (rec-print tensor (- rank 1) nil))))))
-
-(defun print-matrix (matrix stream)
- (with-slots (number-of-rows number-of-cols)
- matrix
- (multiple-value-bind (max-n max-m)
- (set-print-limits-for-matrix number-of-rows number-of-cols)
- (declare (type fixnum max-n max-m))
- (format stream " ~d x ~d" number-of-rows number-of-cols)
-
- ;; Early exit if the total number of elements is zero.
- (when (zerop (number-of-elements matrix))
- (return-from print-matrix))
- (decf max-n)
- (decf max-m)
- (flet ((print-row (i)
- (when (minusp i)
- (return-from print-row))
- (format stream "~% ")
-
- (dotimes (k *matrix-indent*)
- (format stream " "))
- (dotimes (j max-m)
- (declare (type fixnum j))
- (print-element matrix
- (matrix-ref matrix i j)
- stream)
- (format stream " "))
- (if (< max-m (1- number-of-cols))
- (progn
- (format stream "... ")
- (print-element matrix
- (matrix-ref matrix i (1- number-of-cols))
- stream)
- (format stream " "))
- (if (< max-m number-of-cols)
- (progn
- (print-element matrix
- (matrix-ref matrix i (1- number-of-cols))
- stream)
- (format stream " "))))))
-
- (dotimes (i max-n)
- (declare (type fixnum i))
- (print-row i))
-
- (if (< max-n (1- number-of-rows))
- (progn
- (format stream "~% :")
- (print-row (1- number-of-rows)))
- (if (< max-n number-of-rows)
- (print-row (1- number-of-rows))))))))
-
-
-(defmethod print-object ((matrix standard-matrix) stream)
- (print-unreadable-object (matrix stream :type t :identity (not *print-matrix*))
- (when *print-max*
- (print-matrix matrix stream))))
-
+ (rec-print tensor 0 nil))))))
(defmethod print-object ((tensor standard-tensor) stream)
(print-unreadable-object (tensor stream :type t)
- (let ((rank (rank tensor))
- (dims (dimensions tensor)))
- (labels ((two-print (tensor subs)
- (dotimes (i (aref dims 0))
- (dotimes (j (aref dims 1))
- (format stream "~A~,4T" (apply #'tensor-ref (list tensor (append (list i j) subs)))))
- (format stream "~%")))
- (rec-print (tensor idx subs)
- (if (> idx 1)
- (dotimes (i (aref dims idx))
- (rec-print tensor (1- idx) (cons i subs)))
- (progn
- (format stream "~A~%" (append (list '\: '\:) subs))
- (two-print tensor subs)
- (format stream "~%")))))
- (format stream "~A ~A~%" rank dims)
- (case rank
- (1
- (dotimes (i (aref dims 0))
- (format stream "~A~,4T" (tensor-ref tensor `(,i))))
- (format stream "~%"))
- (2
- (two-print tensor nil))
- (t
- (rec-print tensor (- rank 1) nil)))))))
\ No newline at end of file
+ (format stream "~A~%" (dimensions tensor))
+ (print-tensor tensor stream)))
+
+(defmethod print-object ((tensor standard-matrix) stream)
+ (print-unreadable-object (tensor stream :type t)
+ (format stream "~A x ~A~%" (nrows tensor) (ncols tensor))
+ (print-tensor tensor stream)))
diff --git a/src/real-matrix.lisp b/src/real-matrix.lisp
index ec9199b..38ad1f4 100644
--- a/src/real-matrix.lisp
+++ b/src/real-matrix.lisp
@@ -1,34 +1,3 @@
-;;; Definitions of REAL-MATRIX.
-
-(in-package :matlisp)
-
-(eval-when (load eval compile)
- (deftype real-matrix-element-type ()
- "The type of the elements stored in a REAL-MATRIX"
- 'double-float)
-
- (deftype real-matrix-store-type (size)
- "The type of the storage structure for a REAL-MATRIX"
- `(simple-array double-float (,size)))
- )
-;;
-(defclass real-matrix (standard-matrix)
- ((store
- :initform nil
- :type (real-matrix-store-type *)))
- (:documentation "A class of matrices with real elements."))
-
-(defclass sub-real-matrix (real-matrix)
- ((parent-matrix
- :initarg :parent
- :accessor parent
- :type real-matrix))
- (:documentation "A class of matrices with real elements."))
-
-;;
-(defmethod initialize-instance ((matrix real-matrix) &rest initargs)
- (setf (store-size matrix) (length (getf :store initargs)))
- (call-next-method))
;;
(defmethod matrix-ref-1d ((matrix real-matrix) (idx fixnum))
diff --git a/src/real-tensor.lisp b/src/real-tensor.lisp
index ff36e54..9408e85 100644
--- a/src/real-tensor.lisp
+++ b/src/real-tensor.lisp
@@ -40,11 +40,18 @@ Allocates real storage. Default initial-element = 0d0.")
(call-next-method))
;;
-(defmethod tensor-store-ref ((tensor real-tensor) (idx fixnum))
- (aref (store tensor) idx))
+(tensor-store-defs (real-tensor real-type real-type)
+ :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 fstore fidx) (aref tstore tidx))))
-(defmethod (setf tensor-store-ref) ((value number) (tensor real-tensor) (idx fixnum))
- (setf (aref (store tensor) idx) (coerce-real value)))
+(setf (gethash 'real-sub-tensor *tensor-class-optimizations*) 'real-tensor)
;;
(defmethod print-element ((tensor real-tensor)
@@ -53,8 +60,12 @@ Allocates real storage. Default initial-element = 0d0.")
;;
-(defun make-real-tensor (&rest subs)
+(defun make-real-tensor-dims (&rest subs)
(let* ((dims (make-index-store subs))
(ss (reduce #'* dims))
(store (allocate-real-store ss)))
(make-instance 'real-tensor :store store :dimensions dims)))
+
+#+nil(defun make-real-tensor-array (arr)
+ (let* ((dims (array-dimensions arr))
+ (ret (apply #'make-real-tensor-dims dims)))))
diff --git a/src/standard-matrix.lisp b/src/standard-matrix.lisp
index ce2afb3..6357c1c 100644
--- a/src/standard-matrix.lisp
+++ b/src/standard-matrix.lisp
@@ -9,37 +9,29 @@
:documentation "For a matrix, rank = 2."))
(:documentation "Basic matrix class."))
-(defun nrows (matrix)
+(definline nrows (matrix)
(declare (type standard-matrix matrix))
- (let ((dims (dimensions matrix)))
- (declare (type (index-array 2) dims))
- (aref dims 0)))
+ (aref (dimensions matrix) 0))
-(defun ncols (matrix)
+(definline ncols (matrix)
(declare (type standard-matrix matrix))
- (let ((dims (dimensions matrix)))
- (declare (type (index-array 2) dims))
- (aref dims 1)))
+ (aref (dimensions matrix) 1))
-(defun row-stride (matrix)
+(definline row-stride (matrix)
(declare (type standard-matrix matrix))
- (let ((stds (strides matrix)))
- (declare (type (index-array 2) stds))
- (aref stds 0)))
+ (aref (strides matrix) 0))
-(defun col-stride (matrix)
+(definline col-stride (matrix)
(declare (type standard-matrix matrix))
- (let ((stds (strides matrix)))
- (declare (type (index-array 2) stds))
- (aref stds 1)))
+ (aref (strides matrix) 1))
-(defun size (matrix)
+(definline size (matrix)
(declare (type standard-matrix matrix))
(let ((dims (dimensions matrix)))
(declare (type (index-array 2) dims))
(list (aref dims 0) (aref dims 1))))
-;;
+;;
(defmethod initialize-instance :after ((matrix standard-matrix) &rest initargs)
(declare (ignore initargs))
(mlet*
@@ -48,43 +40,37 @@
(error 'tensor-not-matrix :rank rank :tensor matrix))))
;;
-(defmacro matrix-ref (matrix row &optional col)
- (if col
- `(matrix-ref-2d ,matrix ,row ,col)
- `(matrix-ref-1d ,matrix ,row)))
-
-;;
-(defun row-vector-p (matrix)
+(definline row-matrix-p (matrix)
"
Syntax
======
- (ROW-VECTOR-P x)
+ (ROW-MATRIX-P x)
Purpose
=======
- Return T if X is a row vector (number of columns is 1)"
- (tensor-type-p '(1 t)))
+ Return T if X is a row matrix (number of columns is 1)"
+ (tensor-type-p matrix '(1 *)))
-(defun col-vector-p (matrix)
+(definline col-matrix-p (matrix)
"
Syntax
======
- (COL-VECTOR-P x)
+ (COL-MATRIX-P x)
Purpose
=======
- Return T if X is a column vector (number of rows is 1)"
- (tensor-type-p '(t 1)))
+ Return T if X is a column matrix (number of rows is 1)"
+ (tensor-type-p matrix '(* 1)))
-(defun row-or-col-vector-p (matrix)
+(definline row-or-col-matrix-p (matrix)
"
Syntax
======
- (ROW-OR-COL-VECTOR-P x)
+ (ROW-OR-COL-matrix-P x)
Purpose
=======
- Return T if X is either a row or a column vector"
+ Return T if X is either a row or a column matrix."
(or (row-vector-p matrix) (col-vector-p matrix)))
(defun square-matrix-p (matrix)
@@ -105,4 +91,41 @@
(defmethod fill-matrix ((matrix t) (fill t))
(error "arguments MATRIX and FILL to FILL-MATRIX must be a
-matrix and a number"))
\ No newline at end of file
+matrix and a number"))
+
+;;
+(defclass real-matrix (standard-matrix real-tensor)
+ ()
+ (:documentation "A class of matrices with real elements."))
+
+(defclass real-sub-matrix (real-matrix standard-sub-tensor)
+ ()
+ (:documentation "Sub-matrix class with real elements."))
+
+(setf (gethash 'real-matrix *sub-tensor-counterclass*) 'real-sub-matrix
+ (gethash 'real-sub-matrix *sub-tensor-counterclass*) 'real-sub-matrix
+ ;;
+ (gethash 'real-matrix *tensor-class-optimizations*) 'real-tensor
+ (gethash 'real-sub-matrix *tensor-class-optimizations*) 'real-tensor)
+;;
+
+(defclass complex-matrix (standard-matrix complex-tensor)
+ ()
+ (:documentation "A class of matrices with complex elements."))
+
+(defclass complex-sub-matrix (complex-matrix standard-sub-tensor)
+ ()
+ (:documentation "Sub-matrix class with complex elements."))
+
+(setf (gethash 'complex-matrix *sub-tensor-counterclass*) 'complex-sub-matrix
+ (gethash 'complex-sub-matrix *sub-tensor-counterclass*) 'complex-sub-matrix
+ ;;
+ (gethash 'complex-matrix *tensor-class-optimizations*) 'complex-tensor
+ (gethash 'complex-sub-matrix *tensor-class-optimizations*) 'complex-tensor)
+
+;;
+
+(definline matrix-ref (matrix row &optional col)
+ (declare (type standard-matrix matrix))
+ (tensor-ref matrix `(,row ,col)))
+
diff --git a/src/standard-tensor.lisp b/src/standard-tensor.lisp
index d431c32..bbbb419 100644
--- a/src/standard-tensor.lisp
+++ b/src/standard-tensor.lisp
@@ -8,8 +8,9 @@
`(simple-array integer4-type (,size)))
;;
- (deftype index-type ()
- '(signed-byte 64))
+ (deftype index-type ()
+ #+cmu '(signed-byte 32)
+ #-cmu '(signed-byte 64))
(deftype index-array (size)
`(simple-array index-type (,size)))
)
@@ -17,120 +18,38 @@
(declaim (inline allocate-integer4-store))
(make-array-allocator allocate-integer4-store 'integer4-type 0
"
-(allocate-int32-store size [initial-element])
-Allocates integer-32 storage. Default initial-element = 0.
-")
+ Syntax
+ ======
+ (ALLOCATE-INT32-STORE SIZE [INITIAL-ELEMENT 0])
+
+ Purpose
+ =======
+ Allocates integer-32 storage.")
(make-array-allocator allocate-index-store 'index-type 0
"
-(allocate-index-store size [initial-element])
-Allocates index storage. Default initial-element = 0.
-")
+ Syntax
+ ======
+ (ALLOCATE-INDEX-STORE SIZE [INITIAL-ELEMENT 0])
+ Purpose
+ =======
+ Allocates index storage.")
(defun make-index-store (contents)
+"
+ Syntax
+ ======
+ (MAKE-INDEX-STORE CONTENTS)
+
+ Purpose
+ =======
+ Allocates index storage with initial elements from the list CONTENTS."
(let ((size (length contents)))
(make-array size :element-type 'index-type
:initial-contents contents)))
;;
-(defun store-indexing-internal (idx hd strides)
-"
-No explicit error checking, meant to be used internally.
-Returns the sum:
-
- length(strides)
- __
-hd + \ stride * idx
- /_ i i
- i = 0
-
-"
- (declare (optimize (safety 0) (speed 3))
- (type index-type hd)
- (type (index-array *) idx strides))
- (let ((rank (length strides)))
- (declare (type index-type rank))
- (the index-type
- (do ((i 0 (+ i 1))
- (sto-idx (the index-type hd) (the index-type
- (+ sto-idx
- (the index-type
- (* (the index-type
- (aref idx i))
- (the index-type
- (aref strides i))))))))
- ((= i rank) sto-idx)
- (declare (type index-type i sto-idx))))))
-
-(defun store-indexing-vec (idx hd strides dims)
-"
-Returns the sum:
-
- length(strides)
- __
-hd + \ stride * idx
- /_ i i
- i = 0
-
-"
- (declare (type index-type hd)
- (type (index-array *) idx strides dims))
- (let ((rank (length strides)))
- (declare (type index-type rank))
- (if (not (= rank (length idx)))
- (error 'tensor-index-rank-mismatch :index-rank (length idx) :rank rank)
- (the index-type
- (do ((i 0 (+ i 1))
- (sto-idx (the index-type hd)
- (the index-type
- (+ sto-idx
- (the index-type
- (* (the index-type
- (aref strides i))
- ;;
- (the index-type
- (let ((cidx (aref idx i)))
- (declare (type index-type cidx))
- (if (< -1 cidx (aref dims i))
- cidx
- (error 'tensor-index-out-of-bounds :argument i :index cidx :dimension (aref dims i)))))))))))
- ((= i rank) sto-idx)
- (declare (type index-type i sto-idx)))))))
-
-(defun store-indexing-lst (idx hd strides dims)
-"
-Returns the sum
-
- length(strides)
- __
-hd + \ stride * idx
- /_ i i
- i = 0
-
-idx here is a list.
-"
- (declare (type index-type hd)
- (type (index-array *) strides dims)
- (type cons idx))
- (let ((rank (length strides)))
- (declare (type index-type rank))
- (labels ((rec-sum (sum i lst)
- (cond
- ((and (null lst) (= i rank)) (the index-type sum))
- ((or (null lst) (= i rank)) (error 'tensor-index-rank-mismatch :index-rank (length idx) :rank rank))
- (t
- (let ((cidx (car lst)))
- (declare (type index-type cidx))
- (rec-sum (the index-type (+ sum
- (* (aref strides i)
- (if (< -1 cidx (aref dims i))
- cidx
- (error 'tensor-index-out-of-bounds :argument i :index cidx :dimension (aref dims i))))))
- (+ i 1) (cdr lst)))))))
- (rec-sum (the index-type hd) 0 idx))))
-
-;;
(defclass standard-tensor ()
((rank
:accessor rank
@@ -173,6 +92,38 @@ idx here is a list.
:accessor parent-tensor))
(:documentation "Basic sub-tensor class."))
+
+;;
+(defparameter *sub-tensor-counterclass* (make-hash-table)
+ "
+Contains the sub-tensor CLOS counterpart classes of every
+tensor class. This is used by sub-tensor~ and other in-place
+slicing functions to construct new objects.")
+
+(setf (gethash 'standard-tensor *sub-tensor-counterclass*) 'standard-sub-tensor)
+
+;;
+(defparameter *tensor-class-optimizations* (make-hash-table)
+ "
+Contains a either:
+o A property list containing:
+:element-type
+:store-type
+:reader (store idx) => result
+:value-writer (value store idx) => (store idx) <- value
+:reader-writer (fstore fidx tstore tidx) => (tstore tidx) <- (fstore fidx)
+o class-name (symbol) of the superclass whose optimizations
+ are to be made use of.")
+
+(defun get-tensor-class-optimization (clname)
+ (declare (type symbol clname))
+ (let ((opt (gethash clname *tensor-class-optimizations*)))
+ (cond
+ ((symbolp opt)
+ (get-tensor-class-opti...
[truncated message content] |
Thanks for helping keep SourceForge clean.
X