Menu
▾
▴
[Matlisp-commit] [matlisp-git]matlisp branch classy updated. 2012-02-23-238-g95d41ce
|
From: Akshay S. <ak...@us...> - 2013-06-26 06:44:38
|
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "matlisp".
The branch, classy has been updated
via 95d41cef90f67e4d0b50ca7679ce5b5bffdd7532 (commit)
from 8273423d3f82d599972086c6263975bfebe6c3a2 (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 95d41cef90f67e4d0b50ca7679ce5b5bffdd7532
Author: Akshay Srinivasan <aks...@gm...>
Date: Tue Jun 25 23:44:21 2013 -0700
Migrated scal.
diff --git a/configure b/configure
index c26fb60..4beb819 100755
--- a/configure
+++ b/configure
@@ -711,6 +711,10 @@ LDFLAGS
CFLAGS
CC
GREP
+AM_BACKSLASH
+AM_DEFAULT_VERBOSITY
+AM_DEFAULT_V
+AM_V
am__untar
am__tar
AMTAR
@@ -775,6 +779,7 @@ SHELL'
ac_subst_files=''
ac_user_opts='
enable_option_checking
+enable_silent_rules
enable_dependency_tracking
enable_cmucl
enable_sbcl
@@ -1420,6 +1425,8 @@ Optional Features:
--disable-option-checking ignore unrecognized --enable/--with options
--disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no)
--enable-FEATURE[=ARG] include FEATURE [ARG=yes]
+ --enable-silent-rules less verbose build output (undo: "make V=1")
+ --disable-silent-rules verbose build output (undo: "make V=0")
--enable-dependency-tracking
do not reject slow dependency extractors
--disable-dependency-tracking
@@ -2244,7 +2251,7 @@ ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $
ac_compiler_gnu=$ac_cv_c_compiler_gnu
-am__api_version='1.12'
+am__api_version='1.13'
ac_aux_dir=
for ac_dir in "$srcdir" "$srcdir/.." "$srcdir/../.."; do
@@ -2457,8 +2464,8 @@ if test x"${MISSING+set}" != xset; then
esac
fi
# Use eval to expand $SHELL
-if eval "$MISSING --run true"; then
- am_missing_run="$MISSING --run "
+if eval "$MISSING --is-lightweight"; then
+ am_missing_run="$MISSING "
else
am_missing_run=
{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: 'missing' script is too old or missing" >&5
@@ -2698,6 +2705,45 @@ else
fi
rmdir .tst 2>/dev/null
+# Check whether --enable-silent-rules was given.
+if test "${enable_silent_rules+set}" = set; then :
+ enableval=$enable_silent_rules;
+fi
+
+case $enable_silent_rules in # (((
+ yes) AM_DEFAULT_VERBOSITY=0;;
+ no) AM_DEFAULT_VERBOSITY=1;;
+ *) AM_DEFAULT_VERBOSITY=1;;
+esac
+am_make=${MAKE-make}
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $am_make supports nested variables" >&5
+$as_echo_n "checking whether $am_make supports nested variables... " >&6; }
+if ${am_cv_make_support_nested_variables+:} false; then :
+ $as_echo_n "(cached) " >&6
+else
+ if $as_echo 'TRUE=$(BAR$(V))
+BAR0=false
+BAR1=true
+V=1
+am__doit:
+ @$(TRUE)
+.PHONY: am__doit' | $am_make -f - >/dev/null 2>&1; then
+ am_cv_make_support_nested_variables=yes
+else
+ am_cv_make_support_nested_variables=no
+fi
+fi
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $am_cv_make_support_nested_variables" >&5
+$as_echo "$am_cv_make_support_nested_variables" >&6; }
+if test $am_cv_make_support_nested_variables = yes; then
+ AM_V='$(V)'
+ AM_DEFAULT_V='$(AM_DEFAULT_VERBOSITY)'
+else
+ AM_V=$AM_DEFAULT_VERBOSITY
+ AM_DEFAULT_V=$AM_DEFAULT_VERBOSITY
+fi
+AM_BACKSLASH='\'
+
if test "`cd $srcdir && pwd`" != "`pwd`"; then
# Use -I$(srcdir) only when $(srcdir) != ., so that make's output
# is not polluted with repeated "-I."
@@ -2760,6 +2806,10 @@ mkdir_p='$(MKDIR_P)'
# in the wild :-( We should find a proper way to deprecate it ...
AMTAR='$${TAR-tar}'
+
+# We'll loop over all known methods to create a tar archive until one works.
+_am_tools='gnutar pax cpio none'
+
am__tar='$${TAR-tar} chof - "$$tardir"' am__untar='$${TAR-tar} xf -'
@@ -2768,6 +2818,7 @@ am__tar='$${TAR-tar} chof - "$$tardir"' am__untar='$${TAR-tar} xf -'
+
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for grep that handles long lines and -e" >&5
$as_echo_n "checking for grep that handles long lines and -e... " >&6; }
if ${ac_cv_path_GREP+:} false; then :
@@ -8907,6 +8958,10 @@ _lt_linker_boilerplate=`cat conftest.err`
$RM -r conftest*
+## CAVEAT EMPTOR:
+## There is no encapsulation within the following macros, do not change
+## the running order or otherwise move them around unless you know exactly
+## what you are doing...
if test -n "$compiler"; then
lt_prog_compiler_no_builtin_flag=
@@ -15373,7 +15428,7 @@ int main()
EOF
$CC $CFLAGS -c conftest.c
$F77 $FFLAGS -o a.out conftest.o -L${BLAS_LAPACK_DIR} -lblas -llapack
- if a.out; then
+ if ./a.out; then
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5
$as_echo "yes" >&6; }
F2C=-ff2c
@@ -16973,7 +17028,7 @@ $as_echo "$as_me: executing $ac_file commands" >&6;}
case $ac_file$ac_mode in
"depfiles":C) test x"$AMDEP_TRUE" != x"" || {
- # Autoconf 2.62 quotes --file arguments for eval, but not when files
+ # Older Autoconf quotes --file arguments for eval, but not when files
# are listed without --file. Let's play safe and only enable the eval
# if we detect the quoting.
case $CONFIG_FILES in
@@ -17024,7 +17079,7 @@ $as_echo X"$mf" |
DEPDIR=`sed -n 's/^DEPDIR = //p' < "$mf"`
test -z "$DEPDIR" && continue
am__include=`sed -n 's/^am__include = //p' < "$mf"`
- test -z "am__include" && continue
+ test -z "$am__include" && continue
am__quote=`sed -n 's/^am__quote = //p' < "$mf"`
# Find all dependency output files, they are included files with
# $(DEPDIR) in their names. We invoke sed twice because it is the
diff --git a/lib-src/matlisp/dediv.f b/lib-src/matlisp/dediv.f
index 6b51547..9afc4e8 100644
--- a/lib-src/matlisp/dediv.f
+++ b/lib-src/matlisp/dediv.f
@@ -1,7 +1,7 @@
subroutine dediv (n,dx,incx,dy,incy)
double precision dx(*),dy(*)
integer incx,incy,n
-* Multiplies the vector X and Y element-wise.
+* Divides the vector Y by X element-wise.
*
integer i,ix,iy
* ..
@@ -16,7 +16,7 @@
if (incx.lt.0) ix = (-n+1)*incx + 1
if (incy.lt.0) iy = (-n+1)*incy + 1
do 10 i = 1,n
- dy(iy) = dx(ix) * dy(iy)
+ dy(iy) = dy(iy) / dx(ix)
ix = ix + incx
iy = iy + incy
10 continue
@@ -26,7 +26,7 @@
* code for both increments equal to 1
*
20 do 30 i = 1,n
- dy(i) = dx(i) / dy(i)
+ dy(i) = dy(i) / dx(i)
30 continue
diff --git a/lib-src/matlisp/descal.f b/lib-src/matlisp/descal.f
index 41cfafb..9286393 100644
--- a/lib-src/matlisp/descal.f
+++ b/lib-src/matlisp/descal.f
@@ -1,7 +1,7 @@
subroutine descal (n,dx,incx,dy,incy)
double precision dx(*),dy(*)
integer incx,incy,n
-* Multiplies the vector X and Y element-wise.
+* Multiplies the vector Y by X element-wise.
*
integer i,ix,iy
* ..
@@ -16,7 +16,7 @@
if (incx.lt.0) ix = (-n+1)*incx + 1
if (incy.lt.0) iy = (-n+1)*incy + 1
do 10 i = 1,n
- dy(iy) = dx(ix) * dy(iy)
+ dy(iy) = dy(iy) * dx(ix)
ix = ix + incx
iy = iy + incy
10 continue
diff --git a/lib-src/matlisp/zediv.f b/lib-src/matlisp/zediv.f
index b0e8b21..bdf3e58 100644
--- a/lib-src/matlisp/zediv.f
+++ b/lib-src/matlisp/zediv.f
@@ -1,7 +1,7 @@
subroutine zediv (n,dx,incx,dy,incy)
- double precision dx(*),dy(*)
+ double complex dx(*),dy(*)
integer incx,incy,n
-* Multiplies the vector X and Y element-wise.
+* Divides the vector Y by X element-wise.
*
integer i,ix,iy
* ..
@@ -16,7 +16,7 @@
if (incx.lt.0) ix = (-n+1)*incx + 1
if (incy.lt.0) iy = (-n+1)*incy + 1
do 10 i = 1,n
- dy(iy) = dx(ix) * dy(iy)
+ dy(iy) = dy(iy) / dx(ix)
ix = ix + incx
iy = iy + incy
10 continue
@@ -26,9 +26,10 @@
* code for both increments equal to 1
*
20 do 30 i = 1,n
- dy(i) = dx(i) / dy(i)
+ dy(i) = dy(i) / dx(i)
30 continue
return
end
+
diff --git a/lib-src/matlisp/zescal.f b/lib-src/matlisp/zescal.f
index d5beafb..d2a8d34 100644
--- a/lib-src/matlisp/zescal.f
+++ b/lib-src/matlisp/zescal.f
@@ -1,7 +1,7 @@
subroutine zescal (n,dx,incx,dy,incy)
double complex dx(*),dy(*)
integer incx,incy,n
-* Multiplies the vector X and Y element-wise.
+* Multiplies the vector Y by X element-wise.
*
integer i,ix,iy
* ..
@@ -16,7 +16,7 @@
if (incx.lt.0) ix = (-n+1)*incx + 1
if (incy.lt.0) iy = (-n+1)*incy + 1
do 10 i = 1,n
- dy(iy) = dx(ix) * dy(iy)
+ dy(iy) = dy(iy) * dx(ix)
ix = ix + incx
iy = iy + incy
10 continue
diff --git a/matlisp.asd b/matlisp.asd
index 4962725..c28a1f4 100644
--- a/matlisp.asd
+++ b/matlisp.asd
@@ -142,12 +142,12 @@
(:file "swap")
(:file "axpy"
:depends-on ("maker" "copy"))
- #+nil
- (
+ (:file "scal"
+ :depends-on ("copy" "maker"))
(:file "realimag"
:depends-on ("copy"))
- (:file "scal"
- :depends-on ("copy" "tensor-maker" "realimag"))
+ #+nil
+ (
(:file "trans"
:depends-on ("scal" "copy")))))
diff --git a/src/base/tweakable.lisp b/src/base/tweakable.lisp
index 3ad44fc..6f8b0bb 100644
--- a/src/base/tweakable.lisp
+++ b/src/base/tweakable.lisp
@@ -27,13 +27,13 @@
")
;;Level 1--------------------------------------------------------;;
-(defparameter *real-l1-fcall-lb* 50000
+(defparameter *real-l1-fcall-lb* 5000
"If the size of the array is less than this parameter, the
lisp version of axpy is called in order to avoid FFI overheads.
The Fortran function is not called if the tensor does not have
a consecutive store (see blas-helpers.lisp/consecutive-store-p).")
-(defparameter *complex-l1-fcall-lb* 20000
+(defparameter *complex-l1-fcall-lb* 2500
"If the size of the array is less than this parameter, the
lisp version of axpy is called in order to avoid FFI overheads.
The Fortran function is not called if the tensor does not have
diff --git a/src/level-1/axpy.lisp b/src/level-1/axpy.lisp
index dea371b..52aae00 100644
--- a/src/level-1/axpy.lisp
+++ b/src/level-1/axpy.lisp
@@ -37,47 +37,49 @@
(deft/method t/blas-axpy! (sym blas-numeric-tensor) (a x st-x y st-y)
(let ((apy? (null x)))
(using-gensyms (decl (a x y))
- `(let (,@decl)
- (declare (type ,sym ,@(unless apy? `(,x)) ,y)
- ,@(when apy? `((ignore ,x))))
- (let ((sto-x ,(if apy? `(t/store-allocator ,sym 1) `(store ,x)))
- (st-x ,(if apy? 0 st-x)))
- (declare (type ,(store-type sym) sto-x)
- (type index-type st-x))
- ,@(when apy?
- `((t/store-set real-tensor (t/fid* ,(field-type sym)) sto-x 0)))
- (,(macroexpand-1 `(t/blas-axpy-func ,sym))
- (the index-type (size ,y))
- (the ,(field-type sym) ,a)
- sto-x st-x
- (the ,(store-type sym) (store ,y)) (the index-type ,st-y)
- ,(if apy? 0 `(head ,x)) (head ,y))
- ,y)))))
+ (with-gensyms (sto-x stp-x)
+ `(let (,@decl)
+ (declare (type ,sym ,@(unless apy? `(,x)) ,y)
+ ,@(when apy? `((ignore ,x))))
+ (let ((,sto-x ,(if apy? `(t/store-allocator ,sym 1) `(store ,x)))
+ (,stp-x ,(if apy? 0 st-x)))
+ (declare (type ,(store-type sym) ,sto-x)
+ (type index-type ,stp-x))
+ ,@(when apy?
+ `((t/store-set ,sym (t/fid* ,(field-type sym)) ,sto-x 0)))
+ (,(macroexpand-1 `(t/blas-axpy-func ,sym))
+ (the index-type (size ,y))
+ (the ,(field-type sym) ,a)
+ ,sto-x ,stp-x
+ (the ,(store-type sym) (store ,y)) (the index-type ,st-y)
+ ,(if apy? 0 `(head ,x)) (head ,y))
+ ,y))))))
(deft/generic (t/axpy! #'subtypep) sym (a x y))
(deft/method t/axpy! (sym standard-tensor) (a x y)
(let ((apy? (null x)))
(using-gensyms (decl (a x y))
- `(let (,@decl)
- (declare (type ,sym ,@(unless apy? `(,x)) ,y)
- (type ,(field-type sym) ,a)
- ,@(when apy? `((ignore ,x))))
- (let (,@(unless apy? `((sto-x (store ,x))))
- (sto-y (store ,y)))
- (declare (type ,(store-type sym) ,@(unless apy? `(sto-x)) sto-y))
- (very-quickly
- (mod-dotimes (idx (dimensions ,y))
- :with (linear-sums
- ,@(unless apy? `((of-x (strides ,x) (head ,x))))
- (of-y (strides ,y) (head ,y)))
- :do (t/store-set ,sym (t/f+ ,(field-type sym)
- ,@(if apy?
- `(,a)
- `((t/f* ,(field-type sym)
- ,a (t/store-ref ,sym sto-x of-x))))
- (t/store-ref ,sym sto-y of-y))
- sto-y of-y)))
- ,y)))))
+ (with-gensyms (idx sto-x sto-y of-x of-y)
+ `(let (,@decl)
+ (declare (type ,sym ,@(unless apy? `(,x)) ,y)
+ (type ,(field-type sym) ,a)
+ ,@(when apy? `((ignore ,x))))
+ (let (,@(unless apy? `((,sto-x (store ,x))))
+ (,sto-y (store ,y)))
+ (declare (type ,(store-type sym) ,@(unless apy? `(,sto-x)) ,sto-y))
+ (very-quickly
+ (mod-dotimes (,idx (dimensions ,y))
+ :with (linear-sums
+ ,@(unless apy? `((,of-x (strides ,x) (head ,x))))
+ (,of-y (strides ,y) (head ,y)))
+ :do (t/store-set ,sym (t/f+ ,(field-type sym)
+ ,@(if apy?
+ `(,a)
+ `((t/f* ,(field-type sym)
+ ,a (t/store-ref ,sym ,sto-x ,of-x))))
+ (t/store-ref ,sym ,sto-y ,of-y))
+ ,sto-y ,of-y)))
+ ,y))))))
;;---------------------------------------------------------------;;
(defgeneric axpy! (alpha x y)
(:documentation
diff --git a/src/level-1/copy.lisp b/src/level-1/copy.lisp
index 257bd3e..0d71f6d 100644
--- a/src/level-1/copy.lisp
+++ b/src/level-1/copy.lisp
@@ -37,82 +37,86 @@
(deft/method t/blas-copy! (sym blas-numeric-tensor) (x st-x y st-y)
(let ((ncp? (null st-x)))
(using-gensyms (decl (x y))
- `(let (,@decl)
- (declare (type ,sym ,@(unless ncp? `(,x)) ,y)
- ,@(when ncp? `((type ,(field-type sym) ,x))))
- (let ((sto-x ,(if ncp? `(t/store-allocator ,sym 1) `(store ,x)))
- (st-x ,(if ncp? 0 st-x)))
- (declare (type ,(store-type sym) sto-x)
- (type index-type st-x))
- ,@(when ncp?
- `((t/store-set real-tensor ,x sto-x 0)))
+ (with-gensyms (sto-x stp-x)
+ `(let (,@decl)
+ (declare (type ,sym ,@(unless ncp? `(,x)) ,y)
+ ,@(when ncp? `((type ,(field-type sym) ,x))))
+ (let ((,sto-x ,(if ncp? `(t/store-allocator ,sym 1) `(store ,x)))
+ (,stp-x ,(if ncp? 0 st-x)))
+ (declare (type ,(store-type sym) ,sto-x)
+ (type index-type ,stp-x))
+ ,@(when ncp?
+ `((t/store-set ,sym ,x ,sto-x 0)))
(,(macroexpand-1 `(t/blas-copy-func ,sym))
(the index-type (size ,y))
- (the ,(store-type sym) sto-x) (the index-type st-x)
+ (the ,(store-type sym) ,sto-x) (the index-type ,stp-x)
(the ,(store-type sym) (store ,y)) (the index-type ,st-y)
,(if ncp? 0 `(head ,x)) (head ,y)))
- ,y))))
-
+ ,y)))))
+
;;
(deft/generic (t/copy! #'(lambda (a b) (strict-compare (list #'subtypep #'subtypep) a b))) (clx cly) (x y))
(deft/method t/copy! ((clx standard-tensor) (cly standard-tensor)) (x y)
(using-gensyms (decl (x y))
- `(let* (,@decl
- (sto-x (store ,x))
- (sto-y (store ,y)))
- (declare (type ,clx ,x)
- (type ,cly ,y)
- (type ,(store-type clx) sto-x)
- (type ,(store-type cly) sto-y))
- (very-quickly
- (mod-dotimes (idx (dimensions ,x))
- :with (linear-sums
- (of-x (strides ,x) (head ,x))
- (of-y (strides ,y) (head ,y)))
- :do (t/store-set ,cly
- ,(recursive-append
- (unless (eq clx cly)
- `(t/strict-coerce (,(field-type clx) ,(field-type cly)) ))
- `(t/store-ref ,clx sto-x of-x))
- sto-y of-y)))
- ,y)))
+ (with-gensyms (sto-x sto-y of-x of-y idx)
+ `(let* (,@decl
+ (,sto-x (store ,x))
+ (,sto-y (store ,y)))
+ (declare (type ,clx ,x)
+ (type ,cly ,y)
+ (type ,(store-type clx) ,sto-x)
+ (type ,(store-type cly) ,sto-y))
+ (very-quickly
+ (mod-dotimes (,idx (dimensions ,x))
+ :with (linear-sums
+ (,of-x (strides ,x) (head ,x))
+ (,of-y (strides ,y) (head ,y)))
+ :do (t/store-set ,cly
+ ,(recursive-append
+ (unless (eq clx cly)
+ `(t/strict-coerce (,(field-type clx) ,(field-type cly)) ))
+ `(t/store-ref ,clx ,sto-x ,of-x))
+ ,sto-y ,of-y)))
+ ,y))))
;;Coercion messes up optimization in SBCL, so we specialize.
(deft/method t/copy! ((clx real-numeric-tensor) (cly complex-numeric-tensor)) (x y)
(using-gensyms (decl (x y))
- `(let* (,@decl
- (sto-x (store ,x))
- (sto-y (store ,y)))
- (declare (type ,clx ,x)
- (type ,cly ,y)
- (type ,(store-type clx) sto-x)
- (type ,(store-type cly) sto-y))
- (very-quickly
- (mod-dotimes (idx (dimensions ,x))
- :with (linear-sums
- (of-x (strides ,x) (head ,x))
- (of-y (strides ,y) (head ,y)))
- :do (t/store-set ,cly
- (the ,(field-type cly) (complex (t/coerce ,(store-element-type cly) (t/store-ref ,clx sto-x of-x)) (t/fid+ ,(store-element-type cly))))
- sto-y of-y)))
- ,y)))
+ (with-gensyms (sto-x sto-y of-x of-y idx)
+ `(let* (,@decl
+ (,sto-x (store ,x))
+ (,sto-y (store ,y)))
+ (declare (type ,clx ,x)
+ (type ,cly ,y)
+ (type ,(store-type clx) ,sto-x)
+ (type ,(store-type cly) ,sto-y))
+ (very-quickly
+ (mod-dotimes (,idx (dimensions ,x))
+ :with (linear-sums
+ (,of-x (strides ,x) (head ,x))
+ (,of-y (strides ,y) (head ,y)))
+ :do (t/store-set ,cly
+ (the ,(field-type cly) (complex (t/coerce ,(store-element-type cly) (t/store-ref ,clx ,sto-x ,of-x)) (t/fid+ ,(store-element-type cly))))
+ ,sto-y ,of-y)))
+ ,y))))
;;
(deft/method t/copy! ((clx t) (cly standard-tensor)) (x y)
(using-gensyms (decl (x y))
- `(let* (,@decl
- (sto-y (store ,y))
- (cx (t/coerce ,(field-type cly) ,x)))
- (declare (type ,cly ,y)
- (type ,(field-type cly) cx)
- (type ,(store-type cly) sto-y))
- ;;This should be safe
- (very-quickly
- (mod-dotimes (idx (dimensions ,y))
- :with (linear-sums
- (of-y (strides ,y) (head ,y)))
- :do (t/store-set ,cly cx sto-y of-y)))
- ,y)))
+ (with-gensyms (sto-y of-y idx cx)
+ `(let* (,@decl
+ (,sto-y (store ,y))
+ (,cx (t/coerce ,(field-type cly) ,x)))
+ (declare (type ,cly ,y)
+ (type ,(field-type cly) ,cx)
+ (type ,(store-type cly) ,sto-y))
+ ;;This should be safe
+ (very-quickly
+ (mod-dotimes (,idx (dimensions ,y))
+ :with (linear-sums
+ (,of-y (strides ,y) (head ,y)))
+ :do (t/store-set ,cly ,cx ,sto-y ,of-y)))
+ ,y))))
;;
(defmethod copy! :before ((x standard-tensor) (y standard-tensor))
@@ -133,7 +137,7 @@
(when (subtypep clx 'blas-numeric-tensor)
`(if-let (strd (and (call-fortran? x (t/l1-lb ,clx)) (blas-copyablep x y)))
(t/blas-copy! ,clx x (first strd) y (second strd))))
- `(very-quickly (t/copy! (,clx ,cly) x y)))
+ `(t/copy! (,clx ,cly) x y))
y)))
((coerceable? clx cly)
(compile-and-eval
@@ -154,7 +158,7 @@
(when (subtypep cly 'blas-numeric-tensor)
`(if-let (strd (and (call-fortran? y (t/l1-lb ,cly)) (consecutive-storep y)))
(t/blas-copy! ,cly x nil y strd)))
- `(very-quickly (t/copy! (t ,cly) x y)))))
+ `(t/copy! (t ,cly) x y))))
(copy! x y)))
;;Generic function defined in src;base;generic-copy.lisp
diff --git a/src/level-1/dot.lisp b/src/level-1/dot.lisp
index 3aa4a2f..1866473 100644
--- a/src/level-1/dot.lisp
+++ b/src/level-1/dot.lisp
@@ -48,26 +48,28 @@
(deft/generic (t/dot #'subtypep) sym (x y &optional conjp))
(deft/method t/dot (sym standard-tensor) (x y &optional (conjp t))
(using-gensyms (decl (x y))
- `(let (,@decl)
- (declare (type ,sym ,x ,y))
- (let ((sto-x (store ,x))
- (stp-x (aref (the index-store-vector (strides ,x)) 0))
- (of-x (head ,x))
- (sto-y (store ,y))
- (stp-y (aref (the index-store-vector (strides ,y)) 0))
- (of-y (head ,y))
- (dot (t/fid+ ,(field-type sym))))
- (declare (type ,(store-type sym) sto-x sto-y)
- (type index-type stp-x stp-y of-x of-y)
- (type ,(field-type sym) dot))
- (loop :repeat (aref (the index-store-vector (dimensions ,x)) 0)
- :do (setf dot (t/f+ ,(field-type sym) dot
- (t/f* ,(field-type sym)
- ,(recursive-append (when conjp `(t/fc ,(field-type sym))) `(t/store-ref ,sym sto-x of-x))
- (t/store-ref ,sym sto-y of-y)))
- of-x (+ of-x stp-x)
- of-y (+ of-y stp-y)))
- dot))))
+ (with-gensyms (sto-x sto-y of-x of-y stp-x stp-y dot)
+ `(let (,@decl)
+ (declare (type ,sym ,x ,y))
+ (let ((,sto-x (store ,x))
+ (,stp-x (aref (the index-store-vector (strides ,x)) 0))
+ (,of-x (head ,x))
+ (,sto-y (store ,y))
+ (,stp-y (aref (the index-store-vector (strides ,y)) 0))
+ (,of-y (head ,y))
+ (,dot (t/fid+ ,(field-type sym))))
+ (declare (type ,(store-type sym) ,sto-x ,sto-y)
+ (type index-type ,stp-x ,stp-y ,of-x ,of-y)
+ (type ,(field-type sym) ,dot))
+ (very-quickly
+ (loop :repeat (aref (the index-store-vector (dimensions ,x)) 0)
+ :do (setf ,dot (t/f+ ,(field-type sym) ,dot
+ (t/f* ,(field-type sym)
+ ,(recursive-append (when conjp `(t/fc ,(field-type sym))) `(t/store-ref ,sym ,sto-x ,of-x))
+ (t/store-ref ,sym ,sto-y ,of-y)))
+ ,of-x (+ ,of-x ,stp-x)
+ ,of-y (+ ,of-y ,stp-y))))
+ ,dot)))))
;;---------------------------------------------------------------;;
(defgeneric dot (x y &optional conjugate-p)
(:documentation
@@ -126,8 +128,8 @@
(t/blas-dot ,clx x y nil))))
`(if conjugate-p
;;Please do your checks before coming here.
- (very-quickly (t/dot ,clx x y t))
- (very-quickly (t/dot ,clx x y nil))))))
+ (t/dot ,clx x y t)
+ (t/dot ,clx x y nil)))))
(dot x y conjugate-p))
;;You pay the piper if you like mixing types.
;;This is (or should be) a rare enough to not matter.
diff --git a/src/level-1/realimag.lisp b/src/level-1/realimag.lisp
index c09d67a..498f93d 100644
--- a/src/level-1/realimag.lisp
+++ b/src/level-1/realimag.lisp
@@ -43,40 +43,36 @@
"
(etypecase tensor
(real-tensor tensor)
- (complex-tensor (make-instance (case (rank tensor)
- (2 'real-matrix)
- (1 'real-vector)
- (t 'real-tensor))
- :parent-tensor tensor :store (store tensor) :store-size (length (store tensor))
- :dimensions (dimensions tensor)
- :strides (map 'index-store-vector #'(lambda (x) (* 2 x)) (strides tensor))
- :head (the index-type (* 2 (head tensor)))))
+ (complex-tensor (let ((*check-after-initializing?* nil))
+ (make-instance 'real-tensor
+ :parent-tensor tensor :store (store tensor)
+ :dimensions (dimensions tensor)
+ :strides (map 'index-store-vector #'(lambda (x) (* 2 x)) (the index-store-vector (strides tensor)))
+ :head (the index-type (* 2 (head tensor))))))
(number (realpart tensor))))
(definline tensor-imagpart~ (tensor)
"
Syntax
======
- (tensor-imagpart~ tensor)
+ (tensor-realpart~ tensor)
Purpose
=======
- Returns a new tensor object which points to the \"imaginary\" part of TENSOR.
+ Returns a new tensor object which points to the real part of TENSOR.
Store is shared with TENSOR.
- If TENSOR is a scalar, returns its imaginary part.
+ If TENSOR is a scalar, returns its real part.
"
(etypecase tensor
(real-tensor tensor)
- (complex-tensor (make-instance (case (rank tensor)
- (2 'real-matrix)
- (1 'real-vector)
- (t 'real-tensor))
- :parent-tensor tensor :store (store tensor) :store-size (length (store tensor))
- :dimensions (dimensions tensor)
- :strides (map 'index-store-vector #'(lambda (x) (* 2 x)) (strides tensor))
- :head (the index-type (+ 1 (* 2 (head tensor))))))
- (number (imagpart tensor))))
+ (complex-tensor (let ((*check-after-initializing?* nil))
+ (make-instance 'real-tensor
+ :parent-tensor tensor :store (store tensor)
+ :dimensions (dimensions tensor)
+ :strides (map 'index-store-vector #'(lambda (x) (* 2 x)) (the index-store-vector (strides tensor)))
+ :head (the index-type (1+ (* 2 (head tensor)))))))
+ (number (realpart tensor))))
(definline tensor-realpart (tensor)
"
diff --git a/src/level-1/scal.lisp b/src/level-1/scal.lisp
index 85be999..6a06b36 100644
--- a/src/level-1/scal.lisp
+++ b/src/level-1/scal.lisp
@@ -27,240 +27,61 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(in-package #:matlisp)
-(deft/generic (t/blas-scal-func #'subtypep) sym ())
-(deft/method t/blas-scal-func (sym real-tensor) ()
- 'descal)
+(deft/generic (t/blas-scdi-func #'subtypep) sym (&optional scal?))
-(deft/method t/blas-scal-func (sym complex-tensor) ()
- 'zescal)
-;;
-(deft/generic (t/blas-scal! #'subtypep) sym (sz alpha x st-x))
+(deft/method t/blas-scdi-func (sym real-tensor) (&optional (scal? t))
+ (if scal?
+ 'descal
+ 'dediv))
-(deft/generic (t/blas-axpy! #'subtypep) sym (a x st-x y st-y))
-(deft/method t/blas-axpy! (sym blas-numeric-tensor) (a x st-x y st-y)
- (let ((apy? (null x)))
- (using-gensyms (decl (a x y))
+(deft/method t/blas-scdi-func (sym complex-tensor) (&optional (scal? t))
+ (if scal?
+ 'zescal
+ 'zediv))
+;;
+(deft/generic (t/blas-scdi! #'subtypep) sym (x st-x y st-y &optional scal?))
+(deft/generic (t/scdi! #'subtypep) sym (x y &key scal? numx?))
+
+(deft/method t/blas-scdi! (sym blas-numeric-tensor) (x st-x y st-y &optional (scal? t))
+ (let ((numx? (null st-x)))
+ (using-gensyms (decl (x y))
+ (with-gensyms (sto-x stp-x)
+ `(let (,@decl)
+ (declare (type ,sym ,@(unless numx? `(,x)) ,y)
+ ,@(when numx? `((type ,(field-type sym) ,x))))
+ (let ((,sto-x ,(if numx? `(t/store-allocator ,sym 1) `(store ,x)))
+ (,stp-x ,(if numx? 0 st-x)))
+ (declare (type ,(store-type sym) ,sto-x)
+ (type index-type ,stp-x))
+ ,@(when numx?
+ `((t/store-set ,sym ,x ,sto-x 0)))
+ (,(macroexpand-1 `(t/blas-scdi-func ,sym ,scal?))
+ (the index-type (size ,y))
+ ,sto-x ,stp-x
+ (the ,(store-type sym) (store ,y)) (the index-type ,st-y)
+ ,(if numx? 0 `(head ,x)) (head ,y))
+ ,y))))))
+
+(deft/method t/scdi! (sym standard-tensor) (x y &key (scal? t) (numx? nil))
+ (using-gensyms (decl (x y))
+ (with-gensyms (sto-x sto-y of-x of-y idx)
`(let (,@decl)
- (declare (type ,sym ,@(unless apy? `(,x)) ,y)
- ,@(when apy? `((ignore ,x))))
- (let ((sto-x ,(if apy? `(t/store-allocator ,sym 1) `(store ,x)))
- (st-x ,(if apy? 0 st-x)))
- (declare (type ,(store-type sym) sto-x)
- (type index-type st-x))
- ,@(when apy?
- `((t/store-set real-tensor (t/fid* ,(field-type sym)) sto-x 0)))
- (,(macroexpand-1 `(t/blas-axpy-func ,sym))
- (the index-type (size ,y))
- (the ,(field-type sym) ,a)
- sto-x st-x
- (the ,(store-type sym) (store ,y)) (the index-type ,st-y)
- ,(if apy? 0 `(head ,x)) (head ,y))
- ,y)))))
-
-(deft/method t/blas-scal! (sym blas-numeric-tensor) (sz a x st-x)
- (using-gensyms (decl (x))
- `(let (,@decl)
- (declare (type ,sym ,x))
- (,(macroexpand-1 `(t/blas-scal-func ,sym))
- (the index-type ,sz)
- (the ,(field-type sym) ,a)
- (the ,(store-type sym) (store ,x)) (the index-type ,st-x)
- (head ,x))
- ,x)))
-
-
-
-(defmacro generate-typed-scal! (func (tensor-class fortran-func fortran-lb))
- (let* ((opt (get-tensor-class-optimization-hashtable tensor-class)))
- (assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
- `(progn
- (eval-when (:compile-toplevel :load-toplevel :execute)
- (let ((opt (get-tensor-class-optimization-hashtable ',tensor-class)))
- (assert opt nil 'tensor-cannot-find-optimization :tensor-class ',tensor-class)
- (setf (getf opt :scal) ',func
- (get-tensor-class-optimization ',tensor-class) opt)))
- (defun ,func (from to)
- (declare (type ,tensor-class from to))
- ,(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
- (mod-dotimes (idx (dimensions from))
- with (linear-sums
- (f-of (strides from) (head from))
- (t-of (strides to) (head to)))
- 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 (,(getf opt :f*) val-f val-t) :type ,(getf opt :element-type)))
- (,(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-hashtable tensor-class)))
- (assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
- `(progn
- (eval-when (:compile-toplevel :load-toplevel :execute)
- (let ((opt (get-tensor-class-optimization-hashtable ',tensor-class)))
- (assert opt nil 'tensor-cannot-find-optimization :tensor-class ',tensor-class)
- (setf (getf opt :num-scal) ',func
- (get-tensor-class-optimization ',tensor-class) opt)))
- (defun ,func (alpha to)
- (declare (type ,tensor-class to)
- (type ,(getf opt :element-type) alpha))
- ,(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 (,(getf opt :f*) (,(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-hashtable tensor-class)))
- (assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
- `(progn
- (eval-when (:compile-toplevel :load-toplevel :execute)
- (let ((opt (get-tensor-class-optimization-hashtable ',tensor-class)))
- (assert opt nil 'tensor-cannot-find-optimization :tensor-class ',tensor-class)
- (setf (getf opt :div) ',func
- (get-tensor-class-optimization ',tensor-class) opt)))
- (defun ,func (from to)
- (declare (type ,tensor-class from to))
- ,(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
- (mod-dotimes (idx (dimensions from))
- with (linear-sums
- (f-of (strides from) (head from))
- (t-of (strides to) (head to)))
- 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 (,(getf opt :f/) val-f val-t) :type ,(getf opt :element-type)))
- (,(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))
- (let ((opt (get-tensor-class-optimization tensor-class)))
- (assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class)
- `(progn
- (eval-when (:compile-toplevel :load-toplevel :execute)
- (let ((opt (get-tensor-class-optimization-hashtable ',tensor-class)))
- (assert opt nil 'tensor-cannot-find-optimization :tensor-class ',tensor-class)
- (setf (getf opt :num-div) ',func
- (get-tensor-class-optimization ',tensor-class) opt)))
- (defun ,func (alpha to)
- (declare (type ,tensor-class to)
- (type ,(getf opt :element-type) alpha))
- ,(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 (,(getf opt :f/) 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 :fid*)) :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
-(generate-typed-num-scal! real-typed-num-scal!
- (real-tensor dscal *real-l1-fcall-lb*))
-
-(generate-typed-scal! real-typed-scal!
- (real-tensor descal *real-l1-fcall-lb*))
-
-(generate-typed-div! real-typed-div!
- (real-tensor dediv *real-l1-fcall-lb*))
-
-(generate-typed-num-div! real-typed-num-div!
- (real-tensor dediv *real-l1-fcall-lb*))
-
-;;Complex
-
-(generate-typed-num-scal! complex-typed-num-scal!
- (complex-tensor zordscal *complex-l1-fcall-lb*))
-
-(generate-typed-scal! complex-typed-scal!
- (complex-tensor zescal *complex-l1-fcall-lb*))
-
-(generate-typed-div! complex-typed-div!
- (complex-tensor zediv *complex-l1-fcall-lb*))
-
-(generate-typed-num-div! complex-typed-num-div!
- (complex-tensor zediv *complex-l1-fcall-lb*))
-
-;;Symbolic
-#+maxima
-(progn
- (generate-typed-num-scal! symbolic-typed-num-scal!
- (symbolic-tensor nil 0))
-
- (generate-typed-scal! symbolic-typed-scal!
- (symbolic-tensor nil 0))
-
- (generate-typed-div! symbolic-typed-div!
- (symbolic-tensor nil 0))
-
- (generate-typed-num-div! symbolic-typed-num-div!
- (symbolic-tensor nil 0)))
-;;---------------------------------------------------------------;;
-
+ (declare (type ,sym ,@(unless numx? `(,x)) ,y)
+ ,@(when numx? `((type ,(field-type sym) ,x))))
+ (let (,@(unless numx? `((,sto-x (store ,x))))
+ (,sto-y (store ,y)))
+ (declare (type ,(store-type sym) ,@(unless numx? `(,sto-x)) ,sto-y))
+ (very-quickly
+ (mod-dotimes (,idx (dimensions ,y))
+ :with (linear-sums
+ ,@(unless numx? `((,of-x (strides ,x) (head ,x))))
+ (,of-y (strides ,y) (head ,y)))
+ :do (t/store-set ,sym (,(if scal? 't/f* 't/f/) ,(field-type sym)
+ (t/store-ref ,sym ,sto-y ,of-y)
+ ,@(if numx? `(,x) `((t/store-ref ,sym ,sto-x ,of-x))))
+ ,sto-y ,of-y))))
+ ,y))))
+;;
(defgeneric scal! (alpha x)
(:documentation
"
@@ -273,59 +94,102 @@
X <- alpha .* X
")
(:method :before ((x standard-tensor) (y standard-tensor))
- (assert (lvec-eq (dimensions x) (dimensions y) #'=) nil
- 'tensor-dimension-mismatch)))
-
-(defmethod scal! ((alpha number) (x real-tensor))
- (real-typed-num-scal! (coerce-real alpha) x))
-
-(defmethod scal! ((x real-tensor) (y real-tensor))
- (real-typed-scal! x y))
-
-(defmethod scal! ((alpha number) (x complex-tensor))
- (complex-typed-num-scal! (coerce-complex alpha) x))
-
-(defmethod scal! ((x complex-tensor) (y complex-tensor))
- (complex-typed-scal! x y))
-
-(defmethod scal! ((x real-tensor) (y complex-tensor))
- (let ((tmp (tensor-realpart~ y)))
- (real-typed-scal! x tmp)
- ;;Move view to the imaginary part
- (incf (head tmp))
- (real-typed-scal! x tmp)))
-
-;;
+ (assert (very-quickly (lvec-eq (the index-store-vector (dimensions x)) (the index-store-vector (dimensions y)) #'=)) nil
+ 'tensor-dimension-mismatch)))
+
+(defmethod scal! ((x standard-tensor) (y standard-tensor))
+ (let ((clx (class-name (class-of x)))
+ (cly (class-name (class-of y))))
+ (assert (and (member clx *tensor-type-leaves*)
+ (member cly *tensor-type-leaves*))
+ nil 'tensor-abstract-class :tensor-class (list clx cly))
+ (cond
+ ((eq clx cly)
+ (compile-and-eval
+ `(defmethod scal! ((x ,clx) (y ,cly))
+ ,(recursive-append
+ (when (subtypep clx 'blas-numeric-tensor)
+ `(if-let (strd (and (call-fortran? x (t/l1-lb ,clx)) (blas-copyablep x y)))
+ (t/blas-scdi! ,clx x (first strd) y (second strd) t)))
+ `(t/scdi! ,clx x y :scal? t :numx? nil))
+ y))
+ (scal! x y))
+ ((coerceable? clx cly)
+ (scal! (coerce-tensor x cly) y))
+ (t
+ (error "Don't know how to apply scal! to classes ~a, ~a." clx cly)))))
+
+(defmethod scal! ((x t) (y standard-tensor))
+ (let ((cly (class-name (class-of y))))
+ (assert (member cly *tensor-type-leaves*)
+ nil 'tensor-abstract-class :tensor-class cly)
+ (compile-and-eval
+ `(defmethod scal! ((x t) (y ,cly))
+ (let ((x (t/coerce ,(field-type cly) x)))
+ (declare (type ,(field-type cly) x))
+ ,(recursive-append
+ (when (subtypep cly 'blas-numeric-tensor)
+ `(if-let (strd (and (call-fortran? y (t/l1-lb ,cly)) (consecutive-storep y)))
+ (t/blas-scdi! ,cly x nil y strd t)))
+ `(t/scdi! ,cly x y :scal? t :numx? t))
+ y)))
+ (scal! x y)))
+
+;;These should've auto-generated.
(defgeneric div! (alpha x)
- (:documentation "
+ (:documentation
+ "
Syntax
======
- (div! alpha x)
+ (DIV! alpha x)
Purpose
=======
- X <- alpha ./ X
+ X <- X ./ alpha
+
+ Yes the calling order is twisted.
")
(:method :before ((x standard-tensor) (y standard-tensor))
- (assert (lvec-eq (dimensions x) (dimensions y) #'=) nil
- 'tensor-dimension-mismatch)))
-
-(defmethod div! ((alpha number) (x real-tensor))
- (real-typed-num-div! (coerce-real alpha) x))
-
-(defmethod div! ((x real-tensor) (y real-tensor))
- (real-typed-div! x y))
-
-(defmethod div! ((alpha number) (x complex-tensor))
- (complex-typed-num-div! (coerce-complex alpha) x))
-
-(defmethod div! ((x complex-tensor) (y complex-tensor))
- (complex-typed-div! x y))
-
-(defmethod div! ((x real-tensor) (y complex-tensor))
- ;;The alternative is worse!
- (let ((tmp (copy! x (apply #'make-complex-tensor (lvec->list (dimensions x))))))
- (complex-typed-div! tmp y)))
+ (assert (very-quickly (lvec-eq (the index-store-vector (dimensions x)) (the index-store-vector (dimensions y)) #'=)) nil
+ 'tensor-dimension-mismatch)))
+
+(defmethod div! ((x standard-tensor) (y standard-tensor))
+ (let ((clx (class-name (class-of x)))
+ (cly (class-name (class-of y))))
+ (assert (and (member clx *tensor-type-leaves*)
+ (member cly *tensor-type-leaves*))
+ nil 'tensor-abstract-class :tensor-class (list clx cly))
+ (cond
+ ((eq clx cly)
+ (compile-and-eval
+ `(defmethod div! ((x ,clx) (y ,cly))
+ ,(recursive-append
+ (when (subtypep clx 'blas-numeric-tensor)
+ `(if-let (strd (and (call-fortran? x (t/l1-lb ,clx)) (blas-copyablep x y)))
+ (t/blas-scdi! ,clx x (first strd) y (second strd) nil)))
+ `(t/scdi! ,clx x y :scal? nil :numx? nil))
+ y))
+ (div! x y))
+ ((coerceable? clx cly)
+ (div! (coerce-tensor x cly) y))
+ (t
+ (error "Don't know how to apply div! to classes ~a, ~a." clx cly)))))
+
+(defmethod div! ((x t) (y standard-tensor))
+ (let ((cly (class-name (class-of y))))
+ (assert (member cly *tensor-type-leaves*)
+ nil 'tensor-abstract-class :tensor-class cly)
+ (compile-and-eval
+ `(defmethod div! ((x t) (y ,cly))
+ (let ((x (t/coerce ,(field-type cly) x)))
+ (declare (type ,(field-type cly) x))
+ ,(recursive-append
+ (when (subtypep cly 'blas-numeric-tensor)
+ `(if-let (strd (and (call-fortran? y (t/l1-lb ,cly)) (consecutive-storep y)))
+ (t/blas-scdi! ,cly x nil y strd nil)))
+ `(t/scdi! ,cly x y :scal? nil :numx? t))
+ y)))
+ (div! x y)))
;;
(defgeneric scal (alpha x)
@@ -343,40 +207,13 @@
where alpha is a scalar and X is a tensor.
-"))
-
-(defmethod scal ((alpha number) (x number))
- (* alpha x))
-
-(defmethod scal ((x standard-tensor) (alpha number))
- (scal alpha x))
-
-(defmethod scal ((alpha number) (x real-tensor))
- (let ((result (if (complexp alpha)
- (copy! x (apply #'make-complex-tensor (lvec->list (dimensions x))))
- (copy x))))
- (scal! alpha result)))
-
-(defmethod scal ((x real-tensor) (y real-tensor))
- (scal! x (copy y)))
-
-(defmethod scal ((x complex-tensor) (y real-tensor))
- (let ((result (copy! y (apply #'make-complex-tensor (lvec->list (dimensions x))))))
- (scal! x result)))
-
-(defmethod scal ((alpha number) (x complex-tensor))
- (let ((result (copy x)))
- (scal! alpha result)))
-
-(defmethod scal ((x real-tensor) (y complex-tensor))
- (let ((result (copy y)))
- (scal! x result)))
-
-(defmethod scal ((x complex-tensor) (y complex-tensor))
- (let ((result (copy y)))
- (scal! x result)))
+")
+ (:method (alpha x)
+ (scal! alpha (copy x)))
+ ;;TODO: There is an issue here when x is not coerceable into the tensor class of alpha
+ (:method ((alpha standard-tensor) (x t))
+ (scal! alpha (copy! x (zeros (dimensions alpha) (class-of alpha))))))
-;;
(defgeneric div (x y)
(:documentation "
Syntax
@@ -385,43 +222,12 @@
Purpose
=======
- alpha ./ X
+ X ./ alpha
Yes the calling order is twisted.
-"))
-
-(defmethod div ((alpha number) (x number))
- (/ x alpha))
-
-(defmethod div ((x standard-tensor) (y number))
- (let ((result (copy x)))
- (scal! (/ 1 y) result)))
-
-(defmethod div ((x (eql nil)) (y standard-tensor))
- (let ((result (copy y)))
- (div! 1 result)))
-
-(defmethod div ((x real-tensor) (y real-tensor))
- (div! x (copy y)))
-
-(defmethod div ((alpha number) (x real-tensor))
- (let ((result (if (complexp alpha)
- (copy! x (apply #'make-complex-tensor (lvec->list (dimensions x))))
- (copy x))))
- (div! alpha result)))
-
-(defmethod div ((x complex-tensor) (y real-tensor))
- (let ((result (copy! y (apply #'make-complex-tensor (lvec->list (dimensions x))))))
- (div! x result)))
-
-(defmethod div ((alpha number) (x complex-tensor))
- (let ((result (copy x)))
- (div! alpha result)))
-
-(defmethod div ((x real-tensor) (y complex-tensor))
- (let ((result (copy y)))
- (div! x result)))
-
-(defmethod div ((x complex-tensor) (y complex-tensor))
- (let ((result (copy y)))
- (div! x result)))
+")
+ (:method (alpha x)
+ (div! alpha (copy x)))
+ ;;TODO: There is an issue here when x is not coerceable into the tensor class of alpha
+ (:method ((alpha standard-tensor) (x t))
+ (div! alpha (copy! x (zeros (dimensions alpha) (class-of alpha))))))
diff --git a/src/level-1/swap.lisp b/src/level-1/swap.lisp
index a177a03..2d0245b 100644
--- a/src/level-1/swap.lisp
+++ b/src/level-1/swap.lisp
@@ -48,22 +48,23 @@
(deft/generic (t/swap! #'subtypep) sym (x y))
(deft/method t/swap! (sym standard-tensor) (x y)
(using-gensyms (decl (x y))
- `(let (,@decl
- (sto-x (store ,x))
- (sto-y (store ,y)))
+ (with-gensyms (idx sto-x sto-y of-x of-y y-val)
+ `(let* (,@decl
+ (,sto-x (store ,x))
+ (,sto-y (store ,y)))
(declare (type ,sym ,x ,y)
- (type ,(store-type sym) sto-x sto-y))
+ (type ,(store-type sym) ,sto-x ,sto-y))
(very-quickly
- (mod-dotimes (idx (dimensions ,x))
+ (mod-dotimes (,idx (dimensions ,x))
:with (linear-sums
- (of-x (strides ,x) (head ,x))
- (of-y (strides ,y) (head ,y)))
- :do (let-typed ((y-val (t/store-ref ,sym sto-y of-y) :type ,(field-type sym)))
+ (,of-x (strides ,x) (head ,x))
+ (,of-y (strides ,y) (head ,y)))
+ :do (let-typed ((,y-val (t/store-ref ,sym ,sto-y ,of-y) :type ,(field-type sym)))
(t/store-set ,sym
- (t/store-ref ,sym sto-x of-x) sto-y of-y)
+ (t/store-ref ,sym ,sto-x ,of-x) ,sto-y ,of-y)
(t/store-set ,sym
- y-val sto-x of-x)))
- ,y))))
+ ,y-val ,sto-x ,of-x)))
+ ,y)))))
;;---------------------------------------------------------------;;
(defmethod swap! :before ((x standard-tensor) (y standard-tensor))
(assert (very-quickly (lvec-eq (the index-store-vector (dimensions x)) (the index-store-vector (dimensions y)) #'=)) nil
diff --git a/src/level-1/trans.lisp b/src/level-1/trans.lisp
index 2f7ab5b..b2b8154 100644
--- a/src/level-1/trans.lisp
+++ b/src/level-1/trans.lisp
@@ -80,11 +80,11 @@
is basically the same as
(copy! value (TRANSPOSE~ tensor permutation))"
(declare (type standard-tensor A))
- (let ((displaced (make-instance (class-of A) :store (store A)
- :store-size (store-size A)
- :dimensions (copy-seq (dimensions A))
- :strides (copy-seq (strides A))
- :parent-tensor A)))
+ (let ((displaced (let ((*check-after-initializing?* nil))
+ (make-instance (class-of A) :store (store A)
+ :dimensions (copy-seq (dimensions A))
+ :strides (copy-seq (strides A))
+ :parent-tensor A))))
(transpose! displaced permutation)))
(definline (setf transpose~) (value A &optional permutation)
@@ -140,7 +140,7 @@
(etypecase A
(real-tensor A)
(complex-tensor
- (real-typed-num-scal! -1d0 (tensor-imagpart~ A))
+ (scal! -1d0 (tensor-imagpart~ A))
A)
(number (conjugate A))))
diff --git a/src/utilities/macros.lisp b/src/utilities/macros.lisp
index a0230d0..738ab74 100644
--- a/src/utilities/macros.lisp
+++ b/src/utilities/macros.lisp
@@ -204,7 +204,7 @@
,@body))
(defmacro using-gensyms ((decl (&rest syms)) &rest body)
- `(let ((,decl (zipsym (list ,@syms))))
+ `(let ((,decl (zip ',(mapcar #'(lambda (x) (gensym (symbol-name x))) syms) (list ,@syms))))
(destructuring-bind (,@syms) (mapcar #'car ,decl)
,@body)))
-----------------------------------------------------------------------
Summary of changes:
configure | 67 ++++++-
lib-src/matlisp/dediv.f | 6 +-
lib-src/matlisp/descal.f | 4 +-
lib-src/matlisp/zediv.f | 9 +-
lib-src/matlisp/zescal.f | 4 +-
matlisp.asd | 8 +-
src/base/tweakable.lisp | 4 +-
src/level-1/axpy.lisp | 74 ++++----
src/level-1/copy.lisp | 128 ++++++------
src/level-1/dot.lisp | 46 +++--
src/level-1/realimag.lisp | 36 ++--
src/level-1/scal.lisp | 500 ++++++++++++++-------------------------------
src/level-1/swap.lisp | 23 +-
src/level-1/trans.lisp | 12 +-
src/utilities/macros.lisp | 2 +-
15 files changed, 395 insertions(+), 528 deletions(-)
hooks/post-receive
--
matlisp
|