unofficial mirror of guile-user@gnu.org 
 help / color / mirror / Atom feed
* using GSL with cblas via FFI
@ 2011-03-24 14:54 Johan Hidding
  2011-03-25 20:31 ` Ludovic Courtès
  0 siblings, 1 reply; 8+ messages in thread
From: Johan Hidding @ 2011-03-24 14:54 UTC (permalink / raw)
  To: guile-user

[-- Attachment #1: Type: text/plain, Size: 165 bytes --]

Hi,
I'm trying to use GSL through the FFI, but the program is not linked
to libgslcblas, so it cannot find some functions. Attached a minimal
example.
Cheers, Johan

[-- Attachment #2: minex.scm --]
[-- Type: text/x-scheme, Size: 4945 bytes --]


(use-modules (system foreign) 
	     (rnrs bytevectors))

(define libgsl (dynamic-link "libgsl"))
(define libgslcblas (dynamic-link "libgslcblas"))

;=== Misc. utility functions ========================================
; (make-guard) creates a guard closure that collects objects
; that have memory stored outside the garbage collector with their
; destructors. if the guard is called without arguments, all
; objects in this guard are destroyed.

(define (apply-list l)
  (if (null? l)
    '()
    (begin (apply (caar l) (cdar l))
	   (apply-list (cdr l)))))

(define (make-guard)
  (let ((collection '()))
    (case-lambda 
      (() (apply-list collection))
      ((destructor obj) (set! collection 
			  (cons (list destructor obj) collection))))))
;====================================================================

;=== matrices =======================================================
(define gsl-matrix-alloc
  (pointer->procedure '*
		      (dynamic-func "gsl_matrix_alloc" libgsl)
		      (list size_t size_t)))

(define gsl-matrix-free
  (pointer->procedure void
		      (dynamic-func "gsl_matrix_free" libgsl)
		      (list '*)))

(define (make-gsl-matrix n m guard)
  (let ((m (gsl-matrix-alloc n m)))
    (guard gsl-matrix-free m)
    m))

(define (gsl-matrix->array M)
  (let* ((raw (parse-c-struct M (list size_t size_t size_t '* '* int)))
	 (n   (car raw))
	 (m   (cadr raw))
	 (tda (caddr raw))
	 (ptr (cadddr raw)))
    (make-shared-array
      (pointer->bytevector ptr (* tda n) 0 'f64)
      (lambda x (list (+ (* tda (car x)) (cadr x))))
      n m)))
;====================================================================

;=== vectors ========================================================
(define gsl-vector-alloc
  (pointer->procedure '*
		      (dynamic-func "gsl_vector_alloc" libgsl)
		      (list size_t)))

(define gsl-vector-free
  (pointer->procedure void
		      (dynamic-func "gsl_vector_free" libgsl)
		      (list '*)))

(define (gsl-vector->array v)
  (let* ((raw    (parse-c-struct v (list size_t size_t '* '* int)))
	 (size   (car raw))
	 (stride (cadr raw))
	 (ptr    (caddr raw)))
    (pointer->bytevector ptr size 0 'f64)))

(define (make-gsl-vector n guard)
  (let ((v (gsl-vector-alloc n)))
    (guard gsl-vector-free v)
    v))
;====================================================================

;=== permutations ===================================================
(define permutation-alloc
  (pointer->procedure '*
		      (dynamic-func "gsl_permutation_alloc" libgsl)
		      (list size_t)))

(define permutation-free
  (pointer->procedure void
		      (dynamic-func "gsl_permutation_free" libgsl)
		      (list '*)))

(define (make-permutation n guard)
  (let ((p (permutation-alloc n)))
    (guard permutation-free p)
    p))
;====================================================================

;=== linear algebra =================================================

;=== this could be easier, need a c-pointer to a single int ===
(define (dynamic-int) 
  (make-bytevector (sizeof int)))
(define (dynamic-int->pointer di) 
  (bytevector->pointer di))
(define (dynamic-int->int di) 
  (bytevector-sint-ref di 0 (native-endianness) (sizeof int)))
;======

(define linalg-LU-decomp
  (pointer->procedure int
		      (dynamic-func "gsl_linalg_LU_decomp" libgsl)
		      (list '* '* '*)))

(define linalg-LU-solve
  (pointer->procedure int
		      (dynamic-func "gsl_linalg_LU_solve" libgsl)
		      (list '* '* '* '*)))

(define linalg-LU-det
  (pointer->procedure double
		      (dynamic-func "gsl_linalg_LU_det" libgsl)
		      (list '* int)))

(define (make-linalg-det n guard)
  (let ((perm (make-permutation n guard))
	(sgn (dynamic-int)))
    (lambda (m)
      (linalg-LU-decomp m perm (dynamic-int->pointer sgn))
      (linalg-LU-det m (dynamic-int->int sgn)))))

(define (make-linalg-solve n guard)
  (let ((perm (make-permutation n guard))
	(sgn (dynamic-int)))
    (lambda (A b x)
      (linalg-LU-decomp A perm (dynamic-int->pointer sgn))
      (linalg-LU-solve A perm b x))))

;====================================================================
(define (randomize-timer)
  (let ((time (gettimeofday)))
    (set! *random-state*
      (seed->random-state (+ (car time)	
			     (cdr time))))))
(let* ((guard (make-guard))
       (b (make-gsl-vector 5 guard))
       (b-vec (gsl-vector->array b))
       (x (make-gsl-vector 5 guard))
       (x-vec (gsl-vector->array b))
       (A (make-gsl-matrix 5 5 guard))
       (A-vec (gsl-matrix->array A))
       (det (make-linalg-det 5 guard))
       (solve (make-linalg-solve 5 guard)))

  (randomize-timer)
  (array-index-map! (array-contents A-vec) (lambda X (random:normal)))
  (array-index-map! (array-contents b-vec) (lambda X (random:normal)))

  (display A-vec) (newline)
  (display b-vec) (newline)
  (display "=================") (newline)
  (display (det A)) (newline)

  (solve A b x)
  (display x-vec) (newline)

  (guard))


^ permalink raw reply	[flat|nested] 8+ messages in thread
* Re: using GSL with cblas via FFI
@ 2012-06-03 22:04 cong gu
  2012-06-04  4:15 ` Thien-Thi Nguyen
  2012-06-04  4:22 ` Thien-Thi Nguyen
  0 siblings, 2 replies; 8+ messages in thread
From: cong gu @ 2012-06-03 22:04 UTC (permalink / raw)
  To: wingo, guile-user

[-- Attachment #1: Type: text/plain, Size: 358 bytes --]

I found libtool offers a way to make a shared library globally
available.  So I wrote a patch that provides `dynamic-link-global'.
A call like `(dynamic-link-global "libgslcblas")' should make things work.

I don't know whether it is portable, though.  Documentation of libtool
mentioned that not all loaders are able to act upon this `advice'.

-- 
Cong Gu

[-- Attachment #2: guile-2.0.5-dl-global.patch --]
[-- Type: application/octet-stream, Size: 3160 bytes --]

diff -ru guile-2.0.5-orig/libguile/dynl.c guile-2.0.5/libguile/dynl.c
--- guile-2.0.5-orig/libguile/dynl.c	2011-07-06 17:49:59.000000000 -0500
+++ guile-2.0.5/libguile/dynl.c	2012-06-03 15:38:22.867277245 -0500
@@ -99,6 +99,34 @@
   return (void *) handle;
 }
 
+static void *
+sysdep_dynl_link_global (const char *fname, const char *subr)
+{
+  lt_dlhandle handle;
+  lt_dladvise advise;
+
+  if (fname != NULL && !lt_dladvise_init (&advise) &&
+      !lt_dladvise_ext (&advise) && !lt_dladvise_global (&advise))
+    handle = lt_dlopenadvise (fname, advise);
+  else 
+    /* Return a handle for the program as a whole.  */
+    handle = lt_dlopen (NULL);
+
+  lt_dladvise_destroy (&advise);
+
+  if (NULL == handle || 0 == (lt_dlgetinfo(handle)->is_symglobal))
+    {
+      SCM fn;
+      SCM msg;
+
+      fn = fname != NULL ? scm_from_locale_string (fname) : SCM_BOOL_F;
+      msg = scm_from_locale_string (lt_dlerror ());
+      scm_misc_error (subr, "file: ~S, message: ~S", scm_list_2 (fn, msg));
+    }
+
+  return (void *) handle;
+}
+
 static void
 sysdep_dynl_unlink (void *handle, const char *subr)
 {
@@ -234,6 +262,45 @@
 }
 #undef FUNC_NAME
 
+SCM_DEFINE (scm_dynamic_link_global, "dynamic-link-global", 0, 1, 0,
+            (SCM filename),
+	    "Find the shared object (shared library) denoted by\n"
+	    "@var{filename} and link it into the running Guile\n"
+	    "application.  The returned\n"
+	    "scheme object is a ``handle'' for the library which can\n"
+	    "be passed to @code{dynamic-func}, @code{dynamic-call} etc.\n\n"
+	    "Searching for object files is system dependent.  Normally,\n"
+	    "if @var{filename} does have an explicit directory it will\n"
+	    "be searched for in locations\n"
+	    "such as @file{/usr/lib} and @file{/usr/local/lib}.\n\n"
+	    "When @var{filename} is omitted, a @dfn{global symbol handle} is\n"
+	    "returned.  This handle provides access to the symbols\n"
+	    "available to the program at run-time, including those exported\n"
+	    "by the program itself and the shared libraries already loaded.\n")
+#define FUNC_NAME s_scm_dynamic_link_global
+{
+  void *handle;
+  char *file;
+
+  scm_dynwind_begin (0);
+
+  if (SCM_UNBNDP (filename))
+    file = NULL;
+  else
+    {
+      file = scm_to_locale_string (filename);
+      scm_dynwind_free (file);
+    }
+
+  handle = sysdep_dynl_link_global (file, FUNC_NAME);
+  scm_dynwind_end ();
+
+  SCM_RETURN_NEWSMOB2 (scm_tc16_dynamic_obj,
+		       SCM_UNBNDP (filename)
+		       ? SCM_UNPACK (SCM_BOOL_F) : SCM_UNPACK (filename),
+		       handle);
+}
+#undef FUNC_NAME
 
 SCM_DEFINE (scm_dynamic_object_p, "dynamic-object?", 1, 0, 0, 
             (SCM obj),
diff -ru guile-2.0.5-orig/libguile/dynl.h guile-2.0.5/libguile/dynl.h
--- guile-2.0.5-orig/libguile/dynl.h	2010-12-14 12:15:17.000000000 -0600
+++ guile-2.0.5/libguile/dynl.h	2012-06-03 15:38:42.974081191 -0500
@@ -28,6 +28,7 @@
 \f
 
 SCM_API SCM scm_dynamic_link (SCM fname);
+SCM_API SCM scm_dynamic_link_global (SCM fname);
 SCM_API SCM scm_dynamic_unlink (SCM dobj);
 SCM_API SCM scm_dynamic_object_p (SCM obj);
 SCM_API SCM scm_dynamic_pointer (SCM name, SCM dobj);

^ permalink raw reply	[flat|nested] 8+ messages in thread
end of thread, other threads:[~2012-06-04  6:11 UTC | newest]

Thread overview: 8+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2011-03-24 14:54 using GSL with cblas via FFI Johan Hidding
2011-03-25 20:31 ` Ludovic Courtès
2011-03-26  9:53   ` Johan Hidding
2011-03-31 15:18     ` Andy Wingo
  -- strict thread matches above, loose matches on Subject: below --
2012-06-03 22:04 cong gu
2012-06-04  4:15 ` Thien-Thi Nguyen
2012-06-04  6:11   ` cong gu
2012-06-04  4:22 ` Thien-Thi Nguyen

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).