Changeset 14625 in project


Ignore:
Timestamp:
05/14/09 07:37:36 (10 years ago)
Author:
Ivan Raikov
Message:

atlas-lapack ported to Chicken 4

Location:
release/4/atlas-lapack
Files:
4 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/4/atlas-lapack/trunk/atlas-lapack-eggdoc.scm

    r13043 r14625  
    1010     (name "atlas-lapack")
    1111     (description "An interface to the LAPACK routines implemented in ATLAS.")
    12      (author (url "http://chicken.wiki.br/ivan raikov" "Ivan Raikov"))
     12     (author (url "http://chicken.wiki.br/users/ivan-raikov" "Ivan Raikov"))
    1313
    1414     (history
     15      (version "1.11" "Ported to Chicken 4")
    1516      (version "1.10" "Bug fix in the detection of ATLAS library")
    1617      (version "1.9" "Added build system support for libraries linked with f2c")
  • release/4/atlas-lapack/trunk/atlas-lapack.meta

    r9201 r14625  
     1;; -*- Hen -*-
     2
    13((egg "atlas-lapack.egg") ; This should never change
    24
     
    1618 ; A list of eggs mat5-lib depends on.
    1719
    18  (needs eggdoc blas)
     20 (needs eggdoc easyffi blas)
    1921
    2022 (eggdoc "atlas-lapack-eggdoc.scm")
  • release/4/atlas-lapack/trunk/atlas-lapack.scm

    r13043 r14625  
    1919;;
    2020
    21 (require-extension blas)
    22 (require-extension srfi-4)
    23 
    24 (define-extension atlas-lapack)
    25 
    26 (declare (export atlas-lapack:sgesv
     21(module atlas-lapack
     22
     23         (atlas-lapack:sgesv
    2724                 atlas-lapack:dgesv
    2825                 atlas-lapack:cgesv
     
    143140                 unsafe-atlas-lapack:dlauum!
    144141                 unsafe-atlas-lapack:clauum!
    145                  unsafe-atlas-lapack:zlauum!))
     142                 unsafe-atlas-lapack:zlauum!)
     143         
     144    (import scheme chicken data-structures foreign)
     145    (require-extension srfi-4 blas easyffi)
     146
    146147
    147148#>!
     
    351352
    352353
    353 (define-macro (lapack-wrap fn ret errs vsize copy)
    354   (let ((fname (string->symbol (conc (if vsize "atlas-" "unsafe-atlas-")
    355                                      (symbol->string (car fn))
    356                                      (if copy "" "!"))))
    357         (args  (reverse (cdr fn))))
    358     `(define ,(let loop ((args args) (sig 'rest))
    359                 (if (null? args) (cons fname sig)
    360                     (let ((x (car args)))
    361                       (let ((sig (case x
    362                                    ((opiv) sig)
    363                                    ((lda)  sig)
    364                                    ((ldb)  sig)
    365                                    (else   (cons x sig)))))
    366                         (loop (cdr args) sig)))))
    367      (let-optionals rest ,(if (memq 'ldb fn)
    368                               `((lda ,(if (memq 'm fn) 'm 'n)) (ldb ,(if (memq 'm fn) 'm 'n)))
    369                               `((lda ,(if (memq 'm fn) 'm 'n))))
     354(letrec-syntax
     355    (
     356     (lapack-wrap
     357      (lambda (x r c)
     358        (let* ((fn      (cadr x))
     359               (ret     (caddr x))
     360               (errs    (cadddr x))
     361               (vsize   (car (cddddr x)))
     362               (copy    (cadr (cddddr x)))
     363               (fname (string->symbol (conc (if vsize "atlas-" "unsafe-atlas-")
     364                                            (symbol->string (car fn))
     365                                            (if copy "" "!"))))
     366               (args  (reverse (cdr fn)))
     367
     368               (asize           (r 'asize))
     369               (bsize           (r 'bsize))
     370
     371               (%define         (r 'define))
     372               (%begin          (r 'begin))
     373               (%let            (r 'let))
     374               (%cond           (r 'cond))
     375               (%or             (r 'or))
     376               (%if             (r 'if))
     377               (%let-optionals  (r 'let-optionals)))
     378    `(,%define
     379      ,(let loop ((args args) (sig 'rest))
     380         (if (null? args) (cons fname sig)
     381             (let ((x (car args)))
     382               (let ((sig (case x
     383                            ((opiv) sig)
     384                            ((lda)  sig)
     385                            ((ldb)  sig)
     386                            (else   (cons x sig)))))
     387                 (loop (cdr args) sig)))))
     388      (,%let-optionals rest ,(if (memq 'ldb fn)
     389                                 `((lda ,(if (memq 'm fn) 'm 'n)) (ldb ,(if (memq 'm fn) 'm 'n)))
     390                                 `((lda ,(if (memq 'm fn) 'm 'n))))
    370391     ,(if vsize
    371           `(begin
    372              (let ((asize (,vsize a)))
     392          `(,%begin
     393             (let ((,asize (,vsize a)))
    373394               ,(if (memq 'm fn)
    374                     `(if (< asize (fx* m n))
    375                          (atlas-lapack:error ',fname (conc "matrix A is allocated " asize " elements "
     395                    `(if (< ,asize (fx* m n))
     396                         (atlas-lapack:error ',fname (conc "matrix A is allocated " ,asize " elements "
    376397                                                           "but given dimensions are " m " by " n)))
    377                     `(if (< asize (fx* n n))
    378                          (atlas-lapack:error ',fname (conc "matrix A is allocated " asize " elements "
     398                    `(if (< ,asize (fx* n n))
     399                         (atlas-lapack:error ',fname (conc "matrix A is allocated " ,asize " elements "
    379400                                                           "but given dimensions are " n " by " n)))))
    380401            ,(if (memq 'b fn)
    381                  `(let ((bsize (,vsize b)))
     402                 `(let ((,bsize (,vsize b)))
    382403                    ,(if (memq 'nrhs fn)
    383                          `(if (< bsize (fx* nrhs n))
    384                               (atlas-lapack:error ',fname (conc "matrix B is allocated " bsize " elements "
     404                         `(if (< ,bsize (fx* nrhs n))
     405                              (atlas-lapack:error ',fname (conc "matrix B is allocated " ,bsize " elements "
    385406                                                                "but given dimensions are " n " by " nrhs)))
    386                          `(if (< bsize (fx* n 1))
    387                               (atlas-lapack:error ,fname (conc "matrix B is allocated " bsize " elements "
     407                         `(if (< ,bsize (fx* n 1))
     408                              (atlas-lapack:error ,fname (conc "matrix B is allocated " ,bsize " elements "
    388409                                                               "but given dimensions are " n " by " 1)))))
    389410                 `(noop)))
     
    401422           (cond ((= info 0) (values . ,ret))
    402423                 ((< info 0) (atlas-lapack:error ',fname (,(car errs) info)))
    403                  ((> info 0) (atlas-lapack:error ',fname (,(cadr errs) info))))))))))
    404 
    405 
    406 (define-macro (lapack-wrapx fn ret errs)
    407   `(begin
    408      (lapack-wrap ,(cons (string->symbol (conc "lapack:s" (symbol->string (car fn)))) (cdr fn))
    409                    ,ret ,errs #f #f)
    410      (lapack-wrap ,(cons (string->symbol (conc "lapack:d" (symbol->string (car fn)))) (cdr fn))
    411                    ,ret ,errs #f #f)
    412      (lapack-wrap ,(cons (string->symbol (conc "lapack:c" (symbol->string (car fn)))) (cdr fn))
    413                    ,ret ,errs #f #f)
    414      (lapack-wrap ,(cons (string->symbol (conc "lapack:z" (symbol->string (car fn)))) (cdr fn))
    415                    ,ret ,errs #f #f)
    416 
    417      (lapack-wrap ,(cons (string->symbol (conc "lapack:s" (symbol->string (car fn)))) (cdr fn))
    418                    ,ret ,errs f32vector-length #f)
    419      (lapack-wrap ,(cons (string->symbol (conc "lapack:d" (symbol->string (car fn)))) (cdr fn))
    420                    ,ret ,errs f64vector-length #f)
    421      (lapack-wrap ,(cons (string->symbol (conc "lapack:c" (symbol->string (car fn)))) (cdr fn))
    422                    ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v))) #f)
    423      (lapack-wrap ,(cons (string->symbol (conc "lapack:z" (symbol->string (car fn)))) (cdr fn))
    424                     ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v))) #f)
    425 
    426      (lapack-wrap ,(cons (string->symbol (conc "lapack:s" (symbol->string (car fn)))) (cdr fn))
    427                    ,ret ,errs f32vector-length  blas:scopy)
    428      (lapack-wrap ,(cons (string->symbol (conc "lapack:d" (symbol->string (car fn)))) (cdr fn))
    429                    ,ret ,errs f64vector-length  blas:dcopy)
    430      (lapack-wrap ,(cons (string->symbol (conc "lapack:c" (symbol->string (car fn)))) (cdr fn))
    431                   ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v))) blas:ccopy)
    432      (lapack-wrap ,(cons (string->symbol (conc "lapack:z" (symbol->string (car fn)))) (cdr fn))
    433                   ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v))) blas:zcopy)))
    434 
    435 
    436 
    437 (lapack-wrapx (gesv order n nrhs a lda opiv b ldb)
    438                (a b opiv)
    439                ((lambda (i) (conc i "-th argument had an illegal value"))
    440                 (lambda (i) "upper triangular matrix is singular")))
    441      
    442 
    443 (lapack-wrapx (posv order uplo n nrhs a lda b ldb)
    444                (a b)
    445                ((lambda (i) (conc i "-th argument had an illegal value"))
    446                 (lambda (i) (conc "leading minor of order " i
    447                                   " of A is not positive definite"))))
    448 
    449 (lapack-wrapx (getrf order m n a lda opiv)
    450                (a opiv)
    451                ((lambda (i) (conc i "-th argument had an illegal value"))
    452                 (lambda (i) "factor U is singular")))
    453      
    454 (lapack-wrapx (getrs order trans n nrhs a lda ipiv b ldb)
    455                (b)
    456                ((lambda (i) (conc i "-th argument had an illegal value"))
    457                 (lambda (i) "unknown error")))
    458 
    459 (lapack-wrapx (getri order n a lda ipiv)
    460                (a)
    461                ((lambda (i) (conc i "-th argument had an illegal value"))
    462                 (lambda (i) "factor U is singular")))
    463 
    464 (lapack-wrapx (potrf order uplo n a lda)
    465                (a)
    466                ((lambda (i) (conc i "-th argument had an illegal value"))
    467                 (lambda (i) (conc "leading minor of order " i " is not positive definite"))))
    468 
    469 (lapack-wrapx (potrs order uplo n nrhs a lda b ldb)
    470                (b)
    471                ((lambda (i) (conc i "-th argument had an illegal value"))
    472                 (lambda (i) "unknown error")))
    473                
    474 (lapack-wrapx (potri order uplo n  a lda)
    475                (a)
    476                ((lambda (i) (conc i "-th argument had an illegal value"))
    477                 (lambda (i) (conc "element " "(" i "," i")" " of factor U or L is zero"))))
    478                
    479 (lapack-wrapx (trtri order uplo diag n a lda)
    480                (a)
    481                ((lambda (i) (conc i "-th argument had an illegal value"))
    482                 (lambda (i) "the triangular matrix is singular")))
    483 
    484 (lapack-wrapx (lauum order uplo n a lda)
    485                (a)
    486                ((lambda (i) (conc i "-th argument had an illegal value"))
    487                 (lambda (i) "unknown error")))
    488 
     424                 ((> info 0) (atlas-lapack:error ',fname (,(cadr errs) info)))))))))
     425        ))
     426   
     427     (lapack-wrapx
     428      (lambda (x r c)
     429        (let* ((fn     (cadr x))
     430               (ret    (caddr x))
     431               (errs   (cadddr x)))
     432          `(begin
     433             (lapack-wrap ,(cons (string->symbol (conc "lapack:s" (symbol->string (car fn)))) (cdr fn))
     434                          ,ret ,errs #f #f)
     435             (lapack-wrap ,(cons (string->symbol (conc "lapack:d" (symbol->string (car fn)))) (cdr fn))
     436                          ,ret ,errs #f #f)
     437             (lapack-wrap ,(cons (string->symbol (conc "lapack:c" (symbol->string (car fn)))) (cdr fn))
     438                          ,ret ,errs #f #f)
     439             (lapack-wrap ,(cons (string->symbol (conc "lapack:z" (symbol->string (car fn)))) (cdr fn))
     440                          ,ret ,errs #f #f)
     441             
     442             (lapack-wrap ,(cons (string->symbol (conc "lapack:s" (symbol->string (car fn)))) (cdr fn))
     443                          ,ret ,errs f32vector-length #f)
     444             (lapack-wrap ,(cons (string->symbol (conc "lapack:d" (symbol->string (car fn)))) (cdr fn))
     445                          ,ret ,errs f64vector-length #f)
     446             (lapack-wrap ,(cons (string->symbol (conc "lapack:c" (symbol->string (car fn)))) (cdr fn))
     447                          ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v))) #f)
     448             (lapack-wrap ,(cons (string->symbol (conc "lapack:z" (symbol->string (car fn)))) (cdr fn))
     449                          ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v))) #f)
     450             
     451             (lapack-wrap ,(cons (string->symbol (conc "lapack:s" (symbol->string (car fn)))) (cdr fn))
     452                          ,ret ,errs f32vector-length  blas:scopy)
     453             (lapack-wrap ,(cons (string->symbol (conc "lapack:d" (symbol->string (car fn)))) (cdr fn))
     454                          ,ret ,errs f64vector-length  blas:dcopy)
     455             (lapack-wrap ,(cons (string->symbol (conc "lapack:c" (symbol->string (car fn)))) (cdr fn))
     456                          ,ret ,errs (lambda (v) (fx/ 2 (f32vector-length v))) blas:ccopy)
     457             (lapack-wrap ,(cons (string->symbol (conc "lapack:z" (symbol->string (car fn)))) (cdr fn))
     458                          ,ret ,errs (lambda (v) (fx/ 2 (f64vector-length v))) blas:zcopy)))))
     459     )
     460
     461  (lapack-wrapx (gesv order n nrhs a lda opiv b ldb)
     462                (a b opiv)
     463                ((lambda (i) (conc i "-th argument had an illegal value"))
     464                 (lambda (i) "upper triangular matrix is singular")))
     465 
     466 
     467  (lapack-wrapx (posv order uplo n nrhs a lda b ldb)
     468                (a b)
     469                ((lambda (i) (conc i "-th argument had an illegal value"))
     470                 (lambda (i) (conc "leading minor of order " i
     471                                   " of A is not positive definite"))))
     472 
     473  (lapack-wrapx (getrf order m n a lda opiv)
     474                (a opiv)
     475                ((lambda (i) (conc i "-th argument had an illegal value"))
     476                 (lambda (i) "factor U is singular")))
     477 
     478  (lapack-wrapx (getrs order trans n nrhs a lda ipiv b ldb)
     479                (b)
     480                ((lambda (i) (conc i "-th argument had an illegal value"))
     481                 (lambda (i) "unknown error")))
     482 
     483  (lapack-wrapx (getri order n a lda ipiv)
     484                (a)
     485                ((lambda (i) (conc i "-th argument had an illegal value"))
     486                 (lambda (i) "factor U is singular")))
     487 
     488  (lapack-wrapx (potrf order uplo n a lda)
     489                (a)
     490                ((lambda (i) (conc i "-th argument had an illegal value"))
     491                 (lambda (i) (conc "leading minor of order " i " is not positive definite"))))
     492 
     493  (lapack-wrapx (potrs order uplo n nrhs a lda b ldb)
     494                (b)
     495                ((lambda (i) (conc i "-th argument had an illegal value"))
     496                 (lambda (i) "unknown error")))
     497 
     498  (lapack-wrapx (potri order uplo n  a lda)
     499                (a)
     500                ((lambda (i) (conc i "-th argument had an illegal value"))
     501                 (lambda (i) (conc "element " "(" i "," i")" " of factor U or L is zero"))))
     502 
     503  (lapack-wrapx (trtri order uplo diag n a lda)
     504                (a)
     505                ((lambda (i) (conc i "-th argument had an illegal value"))
     506                 (lambda (i) "the triangular matrix is singular")))
     507 
     508  (lapack-wrapx (lauum order uplo n a lda)
     509                (a)
     510                ((lambda (i) (conc i "-th argument had an illegal value"))
     511                 (lambda (i) "unknown error")))
     512 
     513  )
     514)
  • release/4/atlas-lapack/trunk/atlas-lapack.setup

    r13043 r14625  
    1 ;;;; atlas-lapack.setup
    2 
    3 (define has-exports? (string>=? (chicken-version) "2.310"))
     1;; -*- Hen -*-
    42
    53(define (dynld-name fn)         
    64  (make-pathname #f fn ##sys#load-dynamic-extension))   
    7 
    8 (required-extension-version 'blas "1.8")
    95
    106
     
    1713       ldflags ))
    1814
    19 (define-macro (atlas-test rest)
    20   `(define ld-options
    21      (or (any identity (map (lambda (p) (atlas-try-compile (car p) (cadr p))) ,rest))
    22          (error "unable to find ATLAS library"))))
     15
     16(define-syntax atlas-test
     17  (syntax-rules ()
     18    ((_ (flags ...))
     19     (condition-case (atlas-try-compile flags ...)
     20                     (t ()    #f)))))
     21
     22(define ld-options
     23  (or (atlas-test ("<atlas/clapack.h>"   " -llapack_atlas -latlas -lm"))
     24      (atlas-test ("<clapack.h>"         " -llapack_atlas -latlas -lm"))
     25   
     26      (atlas-test ("<atlas/clapack.h>"   " -latlas -lm"))
     27      (atlas-test ("<clapack.h>"         " -latlas -lm"))
     28   
     29      (atlas-test ("<atlas/clapack.h>"   " -llapack_atlas -latlas -lm -lg2c"))
     30      (atlas-test ("<clapack.h>"         " -llapack_atlas -latlas -lm -lg2c"))
     31   
     32      (atlas-test ("<atlas/clapack.h>"   " -latlas -lm -lg2c"))
     33      (atlas-test ("<clapack.h>"         " -latlas -lm -lg2c"))
     34
     35      (error "unable to figure out location of ATLAS library")
     36      ))
    2337
    2438
    25 (define atlas-flags
    26   `(
    27     ("<atlas/clapack.h>"   " -llapack_atlas -latlas -lm")
    28     ("<clapack.h>"         " -llapack_atlas -latlas -lm")
    29    
    30     ("<atlas/clapack.h>"   " -latlas -lm")
    31     ("<clapack.h>"         " -latlas -lm")
    32    
    33     ("<atlas/clapack.h>"   " -llapack_atlas -latlas -lm -lg2c")
    34     ("<clapack.h>"         " -llapack_atlas -latlas -lm -lg2c")
    35    
    36     ("<atlas/clapack.h>"   " -latlas -lm -lg2c")
    37     ("<clapack.h>"         " -latlas -lm -lg2c")
    38     ))
    39 
    40 
    41 (atlas-test atlas-flags)
    42 
    43 
    44 (compile -O2 -d0 -s
    45          ,@(if has-exports? '(-check-imports -emit-exports atlas-lapack.exports) '())
    46          atlas-lapack.scm -L "\"" ,ld-options "\"" -X easyffi)
     39(compile -O2 -d0 -s atlas-lapack.scm -j atlas-lapack -L "\"" ,ld-options "\"" -X easyffi)
     40(compile -O2 -d0 -s atlas-lapack.import.scm)
    4741
    4842(run (csi -qbs atlas-lapack-eggdoc.scm > atlas-lapack.html))
     
    5044(install-extension
    5145 'atlas-lapack
    52  `(,(dynld-name "atlas-lapack")
    53    ,@(if has-exports? '("atlas-lapack.exports") (list)) )
    54  `((version 1.10)
     46 `(,(dynld-name "atlas-lapack") ,(dynld-name "atlas-lapack.import") )
     47 `((version 1.11)
    5548   (documentation "atlas-lapack.html")
    56    ,@(if has-exports? `((exports "atlas-lapack.exports")) (list)) ))
     49   ))
     50
Note: See TracChangeset for help on using the changeset viewer.