Menu
▾
▴
[Matlisp-commit] [matlisp-git]matlisp branch classy created. 2012-02-23-225-gea15112
|
From: Akshay S. <ak...@us...> - 2013-03-26 04:12:31
|
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "matlisp".
The branch, classy has been created
at ea151122023fbd5d481a831645292fa3232b7b8b (commit)
- Log -----------------------------------------------------------------
commit ea151122023fbd5d481a831645292fa3232b7b8b
Author: Akshay Srinivasan <aks...@gm...>
Date: Mon Mar 25 21:11:46 2013 -0700
Saving changes.
diff --git a/matlisp.asd b/matlisp.asd
index 09ec278..5b8b043 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -119,6 +119,7 @@
:depends-on ("standard-tensor" "permutation"))
(:file "print"
:depends-on ("standard-tensor"))))
+ #+nil
(:module "matlisp-classes"
:pathname "classes"
:depends-on ("matlisp-base")
@@ -128,6 +129,7 @@
(:file "symbolic-tensor")
(:file "matrix"
:depends-on ("real-tensor" "complex-tensor"))))
+ #+nil
(:module "matlisp-level-1"
:pathname "level-1"
:depends-on ("matlisp-base" "matlisp-classes" "foreign-core")
@@ -145,18 +147,22 @@
:depends-on ("copy" "scal"))
(: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" "matlisp-level-2")
:components ((:file "gemm")))
+ #+nil
(:module "matlisp-lapack"
:pathname "lapack"
:depends-on ("matlisp-base" "matlisp-classes" "matlisp-level-1" "matlisp-level-2" "matlisp-level-3")
:components ((:file "getrf")))
+ #+nil
(:module "matlisp-sugar"
:pathname "sugar"
:depends-on ("matlisp-base" "matlisp-classes" "matlisp-level-1" "matlisp-level-2" "matlisp-level-3")
diff --git a/src/base/standard-tensor.lisp b/src/base/standard-tensor.lisp
index 5981619..5e84180 100644
--- a/src/base/standard-tensor.lisp
+++ b/src/base/standard-tensor.lisp
@@ -33,53 +33,36 @@
(make-index-store contents))
;;
-(defclass standard-tensor ()
- ((rank
- :reader rank
- :type index-type
- :documentation "Rank of the tensor: number of arguments for the tensor")
- (dimensions
+(defclass tensor ()
+ ((dimensions
:reader dimensions
:initarg :dimensions
:type index-store-vector
:documentation "Dimensions of the vector spaces in which the tensor's arguments reside.")
- (number-of-elements
- :reader number-of-elements
- :type index-type
- :documentation "Total number of elements in the tensor.")
;;
(parent-tensor
:reader parent-tensor
:initarg :parent-tensor
- :type standard-tensor
+ :type tensor
:documentation "If the tensor is a view of another tensor, then this slot is bound.")
;;
- (memos
- :reader memos
- :initform (make-hash-table)
- :type list
- :documentation "Cache for arbitrary (computable) attributes of the object.")
- (head
- :initarg :head
- :initform 0
- :reader head
- :type index-type
- :documentation "Head for the store's accessor.")
- (strides
- :initarg :strides
- :reader strides
- :type index-store-vector
- :documentation "Strides for accesing elements of the tensor.")
- (store-size
- :initarg :store-size
- :reader store-size
- :type index-type
- :documentation "Size of the store.")
(store
- :initarg :store
:reader store
- :documentation "The actual storage for the tensor."))
- (:documentation "Basic tensor class."))
+ :initarg :store)
+ ;;
+ (memos
+ :reader memos
+ :initarg :memos
+ :documentation "Cache for arbitrary (computable) attributes of the object.")))
+
+;;
+(defclass dense-tensor (tensor)
+ ((store :type dense-store)))
+
+(defclass dense-store ()
+ ((vector-store)
+ (head)
+ (strides))
;;
(defclass standard-matrix (standard-tensor)
@@ -113,7 +96,7 @@
(declare (ignore initargs))
(assert (= (rank old) 1) nil 'tensor-not-vector :rank (rank old)))
-;;
+;;Use
(defmacro defmemo (func-name (tensor) &rest body)
"
This macro defines a function taking a tensor argument @arg{tensor}, and memoizes the
@@ -302,16 +285,16 @@
;;
(defmethod initialize-instance :after ((tensor standard-tensor) &rest initargs)
(declare (ignore initargs))
- (let-typed ((dims (dimensions tensor) :type index-store-vector))
- (setf (rank tensor) (length dims))
- (when *check-after-initializing?*
+ (when *check-after-initializing?*
+ (let-typed ((dims (dimensions tensor) :type index-store-vector))
+ (setf (slot-value tensor 'rank) (length dims))
(assert (>= (head tensor) 0) nil 'tensor-invalid-head-value :head (head tensor) :tensor tensor)
(if (not (slot-boundp tensor 'strides))
(multiple-value-bind (stds size) (make-stride dims)
(declare (type index-store-vector stds)
(type index-type size))
- (setf (number-of-elements tensor) size
- (strides tensor) stds)
+ (setf (slot-value tensor 'number-of-elements) size
+ (slot-value tensor 'strides) stds)
(assert (<= (+ (head tensor) (1- (number-of-elements tensor))) (store-size tensor)) nil 'tensor-insufficient-store :store-size (store-size tensor) :max-idx (+ (head tensor) (1- (number-of-elements tensor))) :tensor tensor))
(very-quickly
(let-typed ((stds (strides tensor) :type index-store-vector))
@@ -321,9 +304,7 @@
:do (progn
(assert (> (aref stds i) 0) nil 'tensor-invalid-stride-value :argument i :stride (aref stds i) :tensor tensor)
(assert (> (aref dims i) 0) nil 'tensor-invalid-dimension-value :argument i :dimension (aref dims i) :tensor tensor))
- :finally (progn
- (assert (>= (the index-type (store-size tensor)) (the index-type (+ (the index-type (head tensor)) lidx))) nil 'tensor-insufficient-store :store-size (store-size tensor) :max-idx lidx :tensor tensor)
- (setf (number-of-elements tensor) sz)))))))))
+ :finally (assert (>= (the index-type (store-size tensor)) (the index-type (+ (the index-type (head tensor)) lidx))) nil 'tensor-insufficient-store :store-size (store-size tensor) :max-idx lidx :tensor tensor))))))))
;;
(defgeneric tensor-ref (tensor &rest subscripts)
@@ -360,8 +341,7 @@
(defgeneric (setf tensor-store-ref) (value tensor idx))
;;
-(defgeneric print-element (tensor
- element stream)
+(defgeneric print-element (tensor element stream)
(:documentation "
Syntax
======
diff --git a/src/ffi/c-ffi.lisp b/src/ffi/c-ffi.lisp
index a7fd066..924d9db 100644
--- a/src/ffi/c-ffi.lisp
+++ b/src/ffi/c-ffi.lisp
@@ -2,13 +2,12 @@
(in-package #:matlisp-ffi)
-(defmacro defccomplex (name base-type)
- `(cffi:defcstruct ,name
- (real ,base-type)
- (imag ,base-type)))
-
-(defccomplex %c.complex-double :double)
-(defccomplex %c.complex-float :float)
+(macrolet ((defccomplex (name base-type)
+ `(cffi:defcstruct ,name
+ (real ,base-type)
+ (imag ,base-type))))
+ (defccomplex %c.complex-double :double)
+ (defccomplex %c.complex-float :float))
;; Get the equivalent CFFI type.
;; If the type is an array, get the type of the array element type.
diff --git a/src/level-1/tensor-maker.lisp b/src/level-1/tensor-maker.lisp
index 1a9ec29..700f8a5 100644
--- a/src/level-1/tensor-maker.lisp
+++ b/src/level-1/tensor-maker.lisp
@@ -18,6 +18,7 @@
(rnk (length vdim))
(ret (let ((*check-after-initializing?* nil))
(make-instance (case rnk (2 ',(getf opt :matrix)) (1 ',(getf opt :vector)) (t ',tensor-class))
+ :rank rnk
:strides (make-stride vdim)
:store store :store-size ss :dimensions vdim))))
(setf (slot-value ret 'number-of-elements) ss)
@@ -78,11 +79,12 @@
(defun ,func-name (dims)
(declare (type (or cons index-store-vector) dims))
(let*-typed ((dims (if (consp dims) (make-index-store dims) (copy-seq dims)) :type index-store-vector)
- (rnk (length dims) :type index-type)
- (size (very-quickly (lvec-foldl #'(lambda (a b) (declare (type index-type a b)) (the index-type (* a b))) dims))))
- (let ((*check-after-initializing?* nil))
- (make-instance (case rnk (2 ',(getf opt :matrix)) (1 ',(getf opt :vector)) (t ',tensor-class))
- :dimensions dims :store (,(getf opt :store-allocator) size) :store-size size)))))))
+ (rnk (length dims) :type index-type))
+ (multiple-value-bind (strides size) (make-stride dims)
+ (let ((*check-after-initializing?* nil))
+ (make-instance (case rnk (2 ',(getf opt :matrix)) (1 ',(getf opt :vector)) (t ',tensor-class))
+ :strides strides :number-of-elements
+ :dimensions dims :store (,(getf opt :store-allocator) size) :store-size size)))))))
(make-zeros-dims real-typed-zeros (real-tensor))
(make-zeros-dims complex-typed-zeros (complex-tensor))
diff --git a/src/level-2/gemv.lisp b/src/level-2/gemv.lisp
index 9307caa..4aab067 100644
--- a/src/level-2/gemv.lisp
+++ b/src/level-2/gemv.lisp
@@ -17,7 +17,7 @@
(declare (type ,(getf opt :element-type) alpha beta)
(type ,matrix-class A)
(type ,vector-class x y)
- (type symbol job))
+ (type list job))
,(let
((lisp-routine
`(let-typed ((nr-A (nrows A) :type index-type)
@@ -31,8 +31,10 @@
(hd-x (head x) :type index-type)
;
(stp-y (aref (strides y) 0) :type index-type)
- (sto-y (store y) :type ,(linear-array-type (getf opt :store-type))))
- (when (eq job :t)
+ (sto-y (store y) :type ,(linear-array-type (getf opt :store-type)))
+ ;
+ (job (car job) :type character))
+ (when (char= job #\T)
(rotatef nr-A nc-A)
(rotatef rs-A cs-A))
(very-quickly
@@ -51,7 +53,7 @@
(if blas-gemv-func
`(mlet*
((call-fortran? (> (max (nrows A) (ncols A)) ,fortran-call-lb))
- ((maj-A ld-A fop-A) (blas-matrix-compatible-p A job) :type (symbol index-type (string 1))))
+ ((maj-A ld-A fop-A) (blas-matrix-compatible-p A job) :type (symbol index-type character)))
(cond
(call-fortran?
(if maj-A
commit e6de232ea94a34325a971da0355eecf472c7769c
Merge: f3d0633 23ed3d8
Author: Akshay Srinivasan <aks...@gm...>
Date: Sun Mar 24 13:21:45 2013 -0700
Merge branch 'tensor' from sourceforge.
commit f3d0633327f4ceba538ccb2657552b6069850bfe
Author: Akshay Srinivasan <aks...@gm...>
Date: Sun Mar 24 13:15:13 2013 -0700
Saving changes; this breaks a lot of things.
diff --git a/src/base/blas-helpers.lisp b/src/base/blas-helpers.lisp
index f30164e..f48901a 100644
--- a/src/base/blas-helpers.lisp
+++ b/src/base/blas-helpers.lisp
@@ -1,82 +1,69 @@
(in-package #:matlisp)
-;;Check dimensions of the tensors before passing the argument here!
+(definline fortran-nop (op)
+ (ecase op (#\T #\N) (#\N #\T)))
+
+(defun split-job (job)
+ (declare (type symbol job))
+ (let-typed ((name (symbol-name job) :type string))
+ (loop :for x :across name :collect x)))
+
+(definline flip-major (job)
+ (declare (type symbol job))
+ (case job
+ (:row-major :col-major)
+ (:col-major :row-major)))
+
(defun blas-copyable-p (ten-a ten-b)
(declare (type standard-tensor ten-a ten-b))
- (mlet*
- (((sort-std-a std-a-perm) (let-typed ((std-a (strides ten-a) :type index-store-vector))
- (very-quickly (sort-permute (copy-seq std-a) #'<)))
- :type (index-store-vector permutation-action))
- (perm-a-dims (permute (dimensions ten-a) std-a-perm) :type index-store-vector)
- ;;If blas-copyable then the strides must have the same sorting permutation.
- (sort-std-b (permute (strides ten-b) std-a-perm) :type index-store-vector)
- (perm-b-dims (permute (dimensions ten-b) std-a-perm) :type index-store-vector))
- (very-quickly
- (loop
- :for i :of-type index-type :from 0 :below (rank ten-a)
- :for sost-a :across sort-std-a
- :for a-aoff :of-type index-type := (aref sort-std-a 0) :then (the index-type (* a-aoff (aref perm-a-dims (1- i))))
- ;;
- :for sost-b :across sort-std-b
- :for b-aoff :of-type index-type := (aref sort-std-b 0) :then (the index-type (* b-aoff (aref perm-b-dims (1- i))))
- ;;
- :do (progn
- (unless (and (= sost-a a-aoff)
- (= sost-b b-aoff))
- (return nil)))
- :finally (return (list (aref sort-std-a 0) (aref sort-std-b 0)))))))
+ (when (= (rank ten-a) (rank ten-b))
+ (mlet*
+ (((sort-std-a std-a-perm) (very-quickly (sort-permute-base (copy-seq (the index-store-vector (strides ten-a))) #'<)) :type (index-store-vector pindex-store-vector))
+ (perm-a-dims (very-quickly (apply-action! (copy-seq (the index-store-vector (dimensions ten-a))) std-a-perm)) :type index-store-vector)
+ ;;If blas-copyable then the strides must have the same sorting permutation.
+ (sort-std-b (very-quickly (apply-action! (copy-seq (the index-store-vector (strides ten-b))) std-a-perm)) :type index-store-vector)
+ (perm-b-dims (very-quickly (apply-action! (copy-seq (the index-store-vector (dimensions ten-b))) std-a-perm)) :type index-store-vector))
+ (very-quickly
+ (loop
+ :for i :of-type index-type :from 0 :below (rank ten-a)
+ :for sost-a :across sort-std-a
+ :for a-aoff :of-type index-type := (aref sort-std-a 0) :then (the index-type (* a-aoff (aref perm-a-dims (1- i))))
+ ;;
+ :for sost-b :across sort-std-b
+ :for b-aoff :of-type index-type := (aref sort-std-b 0) :then (the index-type (* b-aoff (aref perm-b-dims (1- i))))
+ ;;
+ :do (unless (and (= sost-a a-aoff)
+ (= sost-b b-aoff)
+ (= (aref perm-a-dims i) (aref perm-b-dims i)))
+ (return nil))
+ :finally (return (list (aref sort-std-a 0) (aref sort-std-b 0))))))))
-(defun consecutive-store-p (tensor)
+(defmemo consecutive-store-p (tensor)
(declare (type standard-tensor tensor))
- (mlet* (((sort-std std-perm) (let-typed ((stds (strides tensor) :type index-store-vector))
- (very-quickly (sort-permute (copy-seq stds) #'<)))
- :type (index-store-vector permutation))
- (perm-dims (permute (dimensions tensor) std-perm) :type index-store-vector))
- (very-quickly
- (loop
- :for so-st :across sort-std
- :for so-di :across perm-dims
- :and accumulated-off := (aref sort-std 0) :then (the index-type (* accumulated-off so-di))
- :unless (= so-st accumulated-off) :do (return nil)
- :finally (return (aref sort-std 0))))))
+ (mlet* (((sort-std std-perm) (very-quickly (sort-permute-base (copy-seq (the index-store-vector (strides tensor))) #'<))
+ :type (index-store-vector pindex-store-vector))
+ (perm-dims (very-quickly (apply-action! (copy-seq (the index-store-vector (dimensions tensor))) std-perm)) :type index-store-vector))
+ (very-quickly
+ (loop
+ :for so-st :across sort-std
+ :for so-di :across perm-dims
+ :and accumulated-off := (aref sort-std 0) :then (the index-type (* accumulated-off so-di))
+ :unless (= so-st accumulated-off) :do (return nil)
+
+ :finally (return (values t (aref sort-std 0)))))))
-(defun blas-matrix-compatible-p (matrix op)
- (declare (type standard-matrix matrix))
+(definline blas-matrix-compatible-p (matrix op)
+ (declare (type standard-matrix matrix)
+ (type character op))
(let*-typed ((stds (strides matrix) :type index-store-vector)
(rs (aref stds 0) :type index-type)
(cs (aref stds 1) :type index-type))
;;Note that it is not required that (rs = nc * cs) or (cs = nr * rs)
(cond
((= cs 1) (values :row-major rs (fortran-nop op)))
- ((= rs 1) (values :col-major cs (fortran-op op)))
- (t (values nil 0 "?")))))
-
-(definline fortran-op (op)
- (ecase op (:n "N") (:t "T")))
-
-(definline fortran-nop (op)
- (ecase op (:t "N") (:n "T")))
-
-(defun fortran-snop (sop)
- (cond
- ((string= sop "N") "T")
- ((string= sop "T") "N")
- (t (error "Unrecognised fortran-op."))))
-
-(defun split-job (job)
- (values-list
- (map 'list #'(lambda (x) (intern (string x) "KEYWORD")) (symbol-name job))))
-
-(defun combine-jobs (&rest jobs)
- (let ((job (intern (apply #'concatenate 'string (mapcar #'symbol-name jobs)) "KEYWORD")))
- job))
-
-(definline flip-major (job)
- (declare (type symbol job))
- (case job
- (:row-major :col-major)
- (:col-major :row-major)))
+ ((= rs 1) (values :col-major cs op)))))
+;;Stride makers.
(definline make-stride-rmj (dims)
(declare (type index-store-vector dims))
(let-typed ((stds (allocate-index-store (length dims)) :type index-store-vector))
diff --git a/src/base/permutation.lisp b/src/base/permutation.lisp
index fd45591..db544ff 100644
--- a/src/base/permutation.lisp
+++ b/src/base/permutation.lisp
@@ -289,7 +289,7 @@
(make-instance 'permutation-action :store (very-quickly (apply-flips! ret idiv)))))
;;Uber-functional stuff
-;;None of these are ever useful (I've found), neat things for showing off though :]
+;;None of these are ever useful (I've found); neat things for showing off though :]
(defun permute-arguments-and-compile (func perm)
(declare (type function func)
(type permutation perm))
diff --git a/src/base/standard-tensor.lisp b/src/base/standard-tensor.lisp
index a5840e1..5981619 100644
--- a/src/base/standard-tensor.lisp
+++ b/src/base/standard-tensor.lisp
@@ -35,53 +35,56 @@
;;
(defclass standard-tensor ()
((rank
- :accessor rank
+ :reader rank
:type index-type
:documentation "Rank of the tensor: number of arguments for the tensor")
(dimensions
- :accessor dimensions
+ :reader dimensions
:initarg :dimensions
:type index-store-vector
:documentation "Dimensions of the vector spaces in which the tensor's arguments reside.")
(number-of-elements
- :accessor number-of-elements
+ :reader number-of-elements
:type index-type
:documentation "Total number of elements in the tensor.")
;;
(parent-tensor
- :accessor parent-tensor
+ :reader parent-tensor
:initarg :parent-tensor
:type standard-tensor
:documentation "If the tensor is a view of another tensor, then this slot is bound.")
;;
+ (memos
+ :reader memos
+ :initform (make-hash-table)
+ :type list
+ :documentation "Cache for arbitrary (computable) attributes of the object.")
(head
:initarg :head
:initform 0
- :accessor head
+ :reader head
:type index-type
:documentation "Head for the store's accessor.")
(strides
:initarg :strides
- :accessor strides
+ :reader strides
:type index-store-vector
:documentation "Strides for accesing elements of the tensor.")
(store-size
:initarg :store-size
- :accessor store-size
+ :reader store-size
:type index-type
:documentation "Size of the store.")
(store
:initarg :store
- :accessor store
+ :reader store
:documentation "The actual storage for the tensor."))
(:documentation "Basic tensor class."))
;;
(defclass standard-matrix (standard-tensor)
((rank
- :accessor rank
:allocation :class
- :type index-type
:initform 2
:documentation "For a matrix, rank = 2."))
(:documentation "Basic matrix class."))
@@ -97,9 +100,7 @@
;;
(defclass standard-vector (standard-tensor)
((rank
- :accessor rank
:allocation :class
- :type index-type
:initform 1
:documentation "For a vector, rank = 1."))
(:documentation "Basic vector class."))
@@ -113,6 +114,39 @@
(assert (= (rank old) 1) nil 'tensor-not-vector :rank (rank old)))
;;
+(defmacro defmemo (func-name (tensor) &rest body)
+ "
+ This macro defines a function taking a tensor argument @arg{tensor}, and memoizes the
+ results of the code @arg{body}. It is assumed that the function definition is functional
+ in character.
+
+ Examples:
+ @lisp
+ > (macroexpand-1 `(defmemo thing (x) (+ x (rank x))))
+ > (defun thing (x)
+ (declare (type standard-tensor x))
+ (let ((memo-hash (memos x)))
+ (multiple-value-bind (value present?) (gethash 'thing memo-hash)
+ (if present? value
+ (let ((value (progn (+ x (rank x)))))
+ (setf (gethash 'thing memo-hash) value)
+ value)))))
+ T
+ >
+ @end lisp
+"
+ (let ((decls (when (and (consp (car body)) (eql (caar body) 'declare)) (cdar body))))
+ `(defun ,func-name (,tensor)
+ (declare (type standard-tensor ,tensor)
+ ,@decls)
+ (let* ((memo-hash (memos ,tensor)))
+ (multiple-value-bind (value present?) (gethash ',func-name memo-hash)
+ (if present? (values-list value)
+ (let ((value (multiple-value-list (progn ,@(if decls (cdr body) body)))))
+ (values-list (setf (gethash ',func-name memo-hash) value)))))))))
+
+
+;;
(defvar *tensor-class-optimizations* (make-hash-table)
"
Contains a either:
diff --git a/src/level-1/tensor-maker.lisp b/src/level-1/tensor-maker.lisp
index 1620666..2f13d0d 100644
--- a/src/level-1/tensor-maker.lisp
+++ b/src/level-1/tensor-maker.lisp
@@ -20,7 +20,7 @@
(make-instance (case rnk (2 ',(getf opt :matrix)) (1 ',(getf opt :vector)) (t ',tensor-class))
:strides (make-stride vdim)
:store store :store-size ss :dimensions vdim))))
- (setf (number-of-elements ret) ss)
+ (setf (slot-value ret 'number-of-elements) ss)
ret))
(make-from-array (arr)
(declare (type (array * *) arr))
diff --git a/src/utilities/functions.lisp b/src/utilities/functions.lisp
index aefe273..4a618ec 100644
--- a/src/utilities/functions.lisp
+++ b/src/utilities/functions.lisp
@@ -3,39 +3,39 @@
;;These functions are used all over the place inside Matlisp's macros.
(eval-when (:compile-toplevel :load-toplevel :execute)
- (declaim (inline id))
- (defun id (x) x)
+(declaim (inline id))
+(defun id (x) x)
- (declaim (inline vectorify))
- (defun vectorify (seq n &optional (element-type t))
- (declare (type (or vector list) seq))
- (etypecase seq
- (cons
- (let ((ret (make-array n :element-type element-type)))
- (loop :for i :of-type fixnum :from 0 :below n
- :for lst := seq :then (cdr lst)
- :do (setf (aref ret i) (car lst))
- :finally (return ret))))
- (vector
- (let ((ret (make-array n :element-type element-type)))
- (loop :for i :of-type fixnum :from 0 :below n
- :for ele :across seq
- :do (setf (aref ret i) ele)
- :finally (return ret))))))
+(declaim (inline vectorify))
+(defun vectorify (seq n &optional (element-type t))
+ (declare (type (or vector list) seq))
+ (etypecase seq
+ (cons
+ (let ((ret (make-array n :element-type element-type)))
+ (loop :for i :of-type fixnum :from 0 :below n
+ :for lst := seq :then (cdr lst)
+ :do (setf (aref ret i) (car lst))
+ :finally (return ret))))
+ (vector
+ (let ((ret (make-array n :element-type element-type)))
+ (loop :for i :of-type fixnum :from 0 :below n
+ :for ele :across seq
+ :do (setf (aref ret i) ele)
+ :finally (return ret))))))
- (declaim (inline copy-n))
- (defun copy-n (vec lst n)
- (declare (type vector vec)
- (type list lst)
- (type fixnum n))
- (loop :for i :of-type fixnum :from 0 :below n
- :for vlst := lst :then (cdr vlst)
- :do (setf (car vlst) (aref vec i)))
- lst)
-
- (declaim (inline slot-values))
- (defun slot-values (obj slots)
- "
+(declaim (inline copy-n))
+(defun copy-n (vec lst n)
+ (declare (type vector vec)
+ (type list lst)
+ (type fixnum n))
+ (loop :for i :of-type fixnum :from 0 :below n
+ :for vlst := lst :then (cdr vlst)
+ :do (setf (car vlst) (aref vec i)))
+ lst)
+
+(declaim (inline slot-values))
+(defun slot-values (obj slots)
+ "
Returns the slots of the @arg{obj} corresponding to symbols in the list @arg{slots}.
Example:
@@ -48,13 +48,13 @@
=> 1 2
@end lisp
"
- (values-list
- (loop :for slt :in slots
- :collect (slot-value obj slt))))
+ (values-list
+ (loop :for slt :in slots
+ :collect (slot-value obj slt))))
- (declaim (inline linear-array-type))
- (defun linear-array-type (type-sym &optional (size '*))
- "
+(declaim (inline linear-array-type))
+(defun linear-array-type (type-sym &optional (size '*))
+ "
Creates the list representing simple-array with type @arg{type-sym}.
Example:
@@ -63,11 +63,11 @@
=> (simple-array double-float (10))
@end lisp
"
- `(simple-array ,type-sym (,size)))
+ `(simple-array ,type-sym (,size)))
- (declaim (inline ensure-list))
- (defun ensure-list (lst)
- "
+(declaim (inline ensure-list))
+(defun ensure-list (lst)
+ "
Ensconses @arg{lst} inside a list if it is an atom.
Example:
@@ -76,10 +76,10 @@
=> (a)
@end lisp
"
- (if (listp lst) lst `(,lst)))
+ (if (listp lst) lst `(,lst)))
- (defun cut-cons-chain! (lst test)
- "
+(defun cut-cons-chain! (lst test)
+ "
Destructively cuts @arg{lst} into two parts, at the element where the function
@arg{test} returns a non-nil value.
@@ -90,20 +90,20 @@
=> (3 5) (3 5) (2 1 7 9)
@end lisp
"
- (declare (type list lst))
- (labels ((cut-cons-chain-tin (lst test parent-lst)
- (cond
- ((null lst) nil)
- ((funcall test (cadr lst))
- (let ((keys (cdr lst)))
- (setf (cdr lst) nil)
- (values parent-lst keys)))
- (t (cut-cons-chain-tin (cdr lst) test parent-lst)))))
- (cut-cons-chain-tin lst test lst)))
+ (declare (type list lst))
+ (labels ((cut-cons-chain-tin (lst test parent-lst)
+ (cond
+ ((null lst) nil)
+ ((funcall test (cadr lst))
+ (let ((keys (cdr lst)))
+ (setf (cdr lst) nil)
+ (values parent-lst keys)))
+ (t (cut-cons-chain-tin (cdr lst) test parent-lst)))))
+ (cut-cons-chain-tin lst test lst)))
- (declaim (inline zip))
- (defun zip (&rest args)
- "
+(declaim (inline zip))
+(defun zip (&rest args)
+ "
Zips the elements of @arg{args}.
Example:
@@ -112,10 +112,10 @@
=> ((2 A J) (3 B H) (4 C C))
@end lisp
"
- (apply #'map 'list #'list args))
+ (apply #'map 'list #'list args))
- (defun recursive-append (&rest lsts)
- "
+(defun recursive-append (&rest lsts)
+ "
Appends lists in a nested manner, mostly used to bring in the charm of
non-lispy languages into macros.
@@ -162,15 +162,15 @@
X)
@end lisp
"
- (labels ((bin-append (x y)
- (if (null x)
- (if (typep (car y) 'symbol) y (car y))
- (append x (if (null y) nil
- (if (typep (car y) 'symbol) `(,y) y))))))
- (reduce #'bin-append lsts :from-end t)))
+ (labels ((bin-append (x y)
+ (if (null x)
+ (if (typep (car y) 'symbol) y (car y))
+ (append x (if (null y) nil
+ (if (typep (car y) 'symbol) `(,y) y))))))
+ (reduce #'bin-append lsts :from-end t)))
- (defun unquote-args (lst args)
- "
+(defun unquote-args (lst args)
+ "
Makes a list suitable for use inside macros (sort-of), by building a
new list quoting every symbol in @arg{lst} other than those in @arg{args}.
CAUTION: DO NOT use backquotes!
@@ -184,34 +184,34 @@
=> (LIST 'LET (LIST (LIST X '1)) (LIST '+ X '1))
@end lisp
"
- (labels ((replace-atoms (lst ret)
- (cond
- ((null lst) (reverse ret))
- ((atom lst)
- (let ((ret (reverse ret)))
- (rplacd (last ret) lst)
- ret))
- ((consp lst)
- (replace-atoms (cdr lst) (let ((fst (car lst)))
- (cond
- ((atom fst)
- (if (member fst args)
- (cons fst ret)
- (append `(',fst) ret)))
- ((consp fst)
- (cons (replace-lst fst nil) ret))))))))
- (replace-lst (lst acc)
- (cond
- ((null lst) acc)
- ((consp lst)
- (if (eq (car lst) 'quote)
- lst
- (cons 'list (replace-atoms lst nil))))
- ((atom lst) lst))))
- (replace-lst lst nil)))
+ (labels ((replace-atoms (lst ret)
+ (cond
+ ((null lst) (reverse ret))
+ ((atom lst)
+ (let ((ret (reverse ret)))
+ (rplacd (last ret) lst)
+ ret))
+ ((consp lst)
+ (replace-atoms (cdr lst) (let ((fst (car lst)))
+ (cond
+ ((atom fst)
+ (if (member fst args)
+ (cons fst ret)
+ (append `(',fst) ret)))
+ ((consp fst)
+ (cons (replace-lst fst nil) ret))))))))
+ (replace-lst (lst acc)
+ (cond
+ ((null lst) acc)
+ ((consp lst)
+ (if (eq (car lst) 'quote)
+ lst
+ (cons 'list (replace-atoms lst nil))))
+ ((atom lst) lst))))
+ (replace-lst lst nil)))
- (defun flatten (x)
- "
+(defun flatten (x)
+ "
Returns a new list by collecting all the symbols found in @arg{x}.
Borrowed from Onlisp.
@@ -221,16 +221,16 @@
=> (LET X 1 + X 2)
@end lisp
"
- (labels ((rec (x acc)
- (cond ((null x) acc)
- ((atom x) (cons x acc))
- (t (rec
- (car x)
- (rec (cdr x) acc))))))
- (rec x nil)))
+ (labels ((rec (x acc)
+ (cond ((null x) acc)
+ ((atom x) (cons x acc))
+ (t (rec
+ (car x)
+ (rec (cdr x) acc))))))
+ (rec x nil)))
- (defun list-dimensions (lst)
- "
+(defun list-dimensions (lst)
+ "
Returns the dimensions of the nested list @arg{lst}, by finding the length
of the immediate list, recursively. This does not ensure the uniformity of
lengths of the lists.
@@ -241,21 +241,21 @@
=> (2 3)
@end lisp
"
- (declare (type list lst))
- (labels ((lst-tread (idx lst)
- (if (null lst) (reverse idx)
- (progn
- (setf (car idx) (length lst))
- (if (consp (car lst))
- (lst-tread (cons 0 idx) (car lst))
- (reverse idx))))))
- (lst-tread (list 0) lst)))
+ (declare (type list lst))
+ (labels ((lst-tread (idx lst)
+ (if (null lst) (reverse idx)
+ (progn
+ (setf (car idx) (length lst))
+ (if (consp (car lst))
+ (lst-tread (cons 0 idx) (car lst))
+ (reverse idx))))))
+ (lst-tread (list 0) lst)))
- (defun compile-and-eval (source)
- "
+(defun compile-and-eval (source)
+ "
Compiles and evaluates the given @arg{source}. This should be
an ANSI compatible way of ensuring method compilation."
- (funcall (compile nil `(lambda () ,source))))
+ (funcall (compile nil `(lambda () ,source))))
- )
+)
commit 9f01a9f4f148c9a00ad80d5eacffd667db2cbbb7
Author: Akshay Srinivasan <aks...@gm...>
Date: Fri Mar 22 10:13:51 2013 -0700
Added a inline method for applying permutations (encoded as its action), useful in blas-helpers.
diff --git a/src/base/permutation.lisp b/src/base/permutation.lisp
index f3e2b93..fd45591 100644
--- a/src/base/permutation.lisp
+++ b/src/base/permutation.lisp
@@ -115,6 +115,15 @@
(permute! (copy thing) perm arg))
;;Action
+(definline apply-action! (seq perm)
+ (declare (type vector seq)
+ (type pindex-store-vector perm))
+ (let* ((size (length perm))
+ (cseq (vectorify seq size)))
+ (loop :for i :from 0 :below size
+ :do (setf (aref seq i) (aref cseq (aref perm i)))
+ :finally (return seq))))
+
(defmethod permute! ((seq cons) (perm permutation-action) &optional arg)
(declare (ignore arg))
(let* ((size (permutation-size perm))
@@ -127,12 +136,7 @@
(defmethod permute! ((seq vector) (perm permutation-action) &optional arg)
(declare (ignore arg))
- (let* ((size (permutation-size perm))
- (cseq (vectorify seq size))
- (act (store perm)))
- (loop :for i :from 0 :below size
- :do (setf (aref seq i) (aref cseq (aref act i)))
- :finally (return seq))))
+ (apply-action! seq (the pindex-store-vector (store perm))))
(defmethod permute! ((ten standard-tensor) (perm permutation-action) &optional (arg 0))
(permute! ten (action->pivot-flip perm) arg))
commit 83545ebc9021cad75969d41c803f5a4557c61e9a
Author: Akshay Srinivasan <aks...@gm...>
Date: Fri Mar 22 10:10:23 2013 -0700
Added a new sort function which does not return a permutation class on return.
diff --git a/src/base/permutation.lisp b/src/base/permutation.lisp
index 778ceba..f3e2b93 100644
--- a/src/base/permutation.lisp
+++ b/src/base/permutation.lisp
@@ -334,7 +334,7 @@
;;Back to practical matters.
;;This function is ugly of-course, but is also very very quick!
-(definline sort-permute (seq predicate &key (key #'matlisp-utilities:id))
+(definline sort-permute-base (seq predicate &key (key #'matlisp-utilities:id))
"
Sorts a lisp-vector in-place, by using the function @arg{predicate} as the
order. Also computes the permutation action which would sort the original
@@ -393,4 +393,8 @@
(decf piv)
(decf ubound)
nil)))))
- :finally (return (values seq (make-instance 'permutation-action :store perm))))))
+ :finally (return (values seq perm)))))
+
+(definline sort-permute (seq predicate &key (key #'matlisp-utilities:id))
+ (multiple-value-bind (seq perm) (sort-permute-base seq predicate :key key)
+ (values seq (make-instance 'permutation-action :store perm))))
-----------------------------------------------------------------------
hooks/post-receive
--
matlisp
|
