[PATCH] Avoid GOOPS in (system foreign-object)?

[PATCH] Avoid GOOPS in (system foreign-object)?

[Ludovic Courtès]

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

Hello!

I would like to have foreign object types based on structs rather than
GOOPS classes.

The rationale is that GOOPS is normally not loaded unless the user
explicitly asks for it; having (system foreign-objects) load it would
add overhead even for users who just want SMOB-like functionality.

WDYT?

The preliminary patch attached is an attempt to do that.  Somehow, the
creation of GOOPS classes for vtables doesn’t work as I thought, which
means that ‘test-foreign-object-scm’ cannot define methods and so on
(which I agree is useful functionality.)  What am I missing?

Thanks!

Ludo’.

PS: The reason I’m looking at it is that I would really want us to
    release 2.0.12 ASAP, so any changes to this API must be settled.


[-- Attachment #2: Type: text/x-patch, Size: 10994 bytes --]

6fb47e8e1977e6aed9a3f636c463365a8e7cf7b9 HEAD wip-foreign-objects
Author: Ludovic Courtès <ludo@gnu.org>
Date:   Thu May 21 17:03:40 2015 +0200

    foreign-object: Rebase on top of structs instead of GOOPS.

3 files changed, 75 insertions(+), 92 deletions(-)
 libguile/foreign-object.c                     |  6 +-
 module/system/foreign-object.scm              | 99 +++++++++++++++------------
 test-suite/standalone/test-foreign-object-scm | 62 +++++------------

	Modified   libguile/foreign-object.c
diff --git a/libguile/foreign-object.c b/libguile/foreign-object.c
index 830f73f..e631f17 100644
--- a/libguile/foreign-object.c
+++ b/libguile/foreign-object.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2014 Free Software Foundation, Inc.
+/* Copyright (C) 2014, 2015 Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -23,7 +23,6 @@
 #endif
 
 #include "libguile/_scm.h"
-#include "libguile/goops.h"
 #include "libguile/foreign-object.h"
 
 
@@ -58,7 +57,8 @@ scm_make_foreign_object_type (SCM name, SCM slot_names,
 void
 scm_assert_foreign_object_type (SCM type, SCM val)
 {
-  if (!SCM_IS_A_P (val, type))
+  if (!SCM_STRUCTP (val)
+      || !scm_is_eq (SCM_STRUCT_VTABLE (val), type))
     scm_error (scm_arg_type_key, NULL, "Wrong type (expecting ~A): ~S",
                scm_list_2 (scm_class_name (type), val), scm_list_1 (val));
 }
	Modified   module/system/foreign-object.scm
diff --git a/module/system/foreign-object.scm b/module/system/foreign-object.scm
index f7bfc94..cde9664 100644
--- a/module/system/foreign-object.scm
+++ b/module/system/foreign-object.scm
@@ -23,7 +23,7 @@
 ;;; Code:
 
 (define-module (system foreign-object)
-  #:use-module (oop goops)
+  #:use-module (system foreign)
   #:export     (make-foreign-object-type
                 define-foreign-object-type))
 
@@ -31,59 +31,70 @@
   (load-extension (string-append "libguile-" (effective-version))
                   "scm_init_foreign_object"))
 
-(define-class <foreign-class> (<class>))
+;; Constant from struct.h.
+(define vtable-index-finalizer 3)
 
-(define-class <foreign-class-with-finalizer> (<foreign-class>)
-  (finalizer #:init-keyword #:finalizer #:init-value #f
-             #:getter finalizer))
+(define <foreign-vtable>
+  ;; The meta-vtable for foreign structs.
+  (make-struct/no-tail <standard-vtable>
+                       (make-struct-layout standard-vtable-fields)
+                       (lambda (obj port)
+                         (format port "#<foreign-vtable ~a ~a>"
+                                 (struct-vtable-name obj)
+                                 (number->string (object-address obj) 16)))))
+
+(define* (make-foreign-vtable name layout
+                              #:key finalizer printer)
+  "Return a vtable called NAME for foreign objects with the given
+LAYOUT, PRINTER, and FINALIZER."
+  (let ((vtable (make-struct/no-tail <foreign-vtable>
+                                     (make-struct-layout layout)
+                                     printer)))
+    ;; Note: as a side-effect, this defines a GOOPS class for VTABLE.
+    (set-struct-vtable-name! vtable name)
 
-(define-method (allocate-instance (class <foreign-class-with-finalizer>)
-                                  initargs)
-  (let ((instance (next-method))
-        (finalizer (finalizer class)))
     (when finalizer
-      (%add-finalizer! instance finalizer))
-    instance))
+      (let ((c-finalizer (procedure->pointer void
+                                             (compose finalizer pointer->scm)
+                                             '(*))))
+        (struct-set! vtable vtable-index-finalizer
+                     (pointer-address c-finalizer))))
+    vtable))
 
-(define* (make-foreign-object-type name slots #:key finalizer
-                                   (getters (map (const #f) slots)))
+(define* (make-foreign-object-type name slots #:key finalizer printer)
   (unless (symbol? name)
     (error "type name should be a symbol" name))
   (unless (or (not finalizer) (procedure? finalizer))
     (error "finalizer should be a procedure" finalizer))
-  (let ((dslots (map (lambda (slot getter)
-                       (unless (symbol? slot)
-                         (error "slot name should be a symbol" slot))
-                       (cons* slot #:class <foreign-slot>
-                              #:init-keyword (symbol->keyword slot)
-                              #:init-value 0
-                              (if getter (list #:getter getter) '())))
-                     slots
-                     getters)))
-    (if finalizer
-        (make-class '() dslots #:name name
-                    #:finalizer finalizer
-                    #:metaclass <foreign-class-with-finalizer>)
-        (make-class '() dslots #:name name
-                    #:metaclass <foreign-class>))))
+  (unless (or (not printer) (procedure? printer))
+    (error "printer should be a procedure" printer))
+  (make-foreign-vtable name
+                       (string-concatenate (map (const "uw") slots))
+                       #:finalizer finalizer
+                       #:printer printer))
+
+(define (wrong-type-error s who)
+  (throw 'wrong-type-arg who
+         "Wrong type argument: ~S" (list s)
+         (list s)))
+
+(define-syntax-rule (assert-valid-struct type obj proc)
+  (unless (eq? type (struct-vtable obj))
+    (wrong-type-error obj proc)))
 
 (define-syntax define-foreign-object-type
   (lambda (x)
-    (define (kw-apply slots)
-      (syntax-case slots ()
-        (() #'())
-        ((slot . slots)
-         (let ((kw (symbol->keyword (syntax->datum #'slot))))
-           #`(#,kw slot . #,(kw-apply #'slots))))))
-
     (syntax-case x ()
       ((_ name constructor (slot ...) kwarg ...)
-       #`(begin
-           (define slot (ensure-generic 'slot (and (defined? 'slot) slot)))
-           ...
-           (define name
-             (make-foreign-object-type 'name '(slot ...) kwarg ...
-                                       #:getters (list slot ...)))
-           (define constructor
-             (lambda (slot ...)
-               (make name #,@(kw-apply #'(slot ...))))))))))
+       (with-syntax (((index ...) (iota (length #'(slot ...)))))
+         #`(begin
+             (define-inlinable (slot obj)
+               (assert-valid-struct name obj 'slot)
+               (struct-ref obj index))
+             ...
+             (define name
+               (make-foreign-object-type 'name '(slot ...) kwarg ...))
+             (define constructor
+               (lambda (slot ...)
+                 (make-struct/no-tail name slot ...)))))))))
+
	Modified   test-suite/standalone/test-foreign-object-scm
diff --git a/test-suite/standalone/test-foreign-object-scm b/test-suite/standalone/test-foreign-object-scm
index 7e4bd85..8e6de39 100755
--- a/test-suite/standalone/test-foreign-object-scm
+++ b/test-suite/standalone/test-foreign-object-scm
@@ -3,7 +3,7 @@ exec guile -q -s "$0" "$@"
 !#
 ;;; test-foreign-object-scm --- Foreign object interface.     -*- Scheme -*-
 ;;;
-;;; Copyright (C) 2014 Free Software Foundation, Inc.
+;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc.
 ;;;
 ;;; This library is free software; you can redistribute it and/or
 ;;; modify it under the terms of the GNU Lesser General Public
@@ -21,8 +21,7 @@ exec guile -q -s "$0" "$@"
 
 (use-modules (system foreign)
              (system foreign-object)
-             (rnrs bytevectors)
-             (oop goops))
+             (rnrs bytevectors))
 
 (define (libc-ptr name)
   (catch #t
@@ -36,14 +35,18 @@ exec guile -q -s "$0" "$@"
 (define memcpy (pointer->procedure void (libc-ptr "memcpy") (list '* '* size_t)))
 (define free (pointer->procedure void (libc-ptr "free") '(*)))
 
-(define (finalize-cstr cstr)
-  (free (make-pointer (addr cstr))))
-
-(define-foreign-object-type <cstr> make-cstr (addr len)
-  #:finalizer finalize-cstr)
+(define-foreign-object-type <cstr>
+  make-cstr
+  (cstr-addr cstr-len)
+  #:finalizer (lambda (cstr)
+                (free (make-pointer (cstr-addr cstr))))
+  #:printer (lambda (cstr port)
+              (format port "<<cstr> ~s>" (cstr->string cstr))))
 
 (define (cstr->string cstr)
-  (pointer->string (make-pointer (addr cstr)) (len cstr) "UTF-8"))
+  (pointer->string (make-pointer (cstr-addr cstr))
+                   (cstr-len cstr)
+                   "UTF-8"))
 
 (define* (string->cstr str #:optional (k make-cstr))
   (let* ((bv (string->utf8 str))
@@ -54,18 +57,9 @@ exec guile -q -s "$0" "$@"
     (memcpy mem (bytevector->pointer bv) len)
     (k (pointer-address mem) len)))
 
-(define-method (write (cstr <cstr>) port)
-  (format port "<<cstr> ~s>" (cstr->string cstr)))
-
-(define-method (display (cstr <cstr>) port)
-  (display (cstr->string cstr) port))
-
-(define-method (+ (a <cstr>) (b <cstr>))
+(define (cstr-append a b)
   (string->cstr (string-append (cstr->string a) (cstr->string b))))
 
-(define-method (equal? (a <cstr>) (b <cstr>))
-  (equal? (cstr->string a) (cstr->string b)))
-
 (define failed? #f)
 (define-syntax test
   (syntax-rules ()
@@ -76,34 +70,12 @@ exec guile -q -s "$0" "$@"
            (begin
              (set! failed? #t)
              (format (current-error-port)
-                     "bad return from expression `~a': expected ~A; got ~A~%"
+                     "bad return from expression `~a': expected ~s; got ~s~%"
                      'exp expected actual)))))))
 
-(test (string->cstr "Hello, world!")
-      (+ (string->cstr "Hello, ") (string->cstr "world!")))
-
-;; GOOPS construction syntax instead of make-cstr.
-(test (string->cstr "Hello, world!")
-      (string->cstr "Hello, world!"
-                    (lambda (addr len)
-                      (make <cstr> #:addr addr #:len len))))
-
-;; Subclassing.
-(define-class <wrapped-cstr> (<cstr>)
-  (wrapped-string #:init-keyword #:wrapped-string
-                  #:getter wrapped-string
-                  #:init-form (error "missing #:wrapped-string")))
-
-(define (string->wrapped-cstr string)
-  (string->cstr string (lambda (addr len)
-                         (make <wrapped-cstr> #:addr addr #:len len
-                               #:wrapped-string string))))
-
-(let ((wrapped-cstr (string->wrapped-cstr "Hello, world!")))
-  ;; Tests that <cst> methods work on <wrapped-cstr>.
-  (test "Hello, world!" (cstr->string wrapped-cstr))
-  ;; Test the additional #:wrapped-string slot.
-  (test "Hello, world!" (wrapped-string wrapped-cstr)))
+(test "Hello, world!"
+      (cstr->string
+       (cstr-append (string->cstr "Hello, ") (string->cstr "world!"))))
 
 (gc) (gc) (gc)

Re: [PATCH] Avoid GOOPS in (system foreign-object)?

[Mikael Djurfeldt]

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

Hi Ludovic,

Sadly, I nowadays only have time to look at guile-devel briefly now and
then.  I did this now and happened to see this.

Just wanted to say that I think that we (or at least I) at some point in
time had the goal to replace structs with pure GOOPS data structures. In
the context of FFI, this would allow you to be more flexible than what
structs allow, ultimately being able to access arbitrary C structs and C++
structs/classes directly from Scheme.  I find that a proper MOP (which
maybe still is not fully developed) is a nicer way to handle non-standard
access than the strange character strings in struct vtables...

Happy hacking!

Mikael

On Thu, May 21, 2015 at 5:28 PM, Ludovic Courtès <ludo@gnu.org> wrote:

> Hello!
>
> I would like to have foreign object types based on structs rather than
> GOOPS classes.
>
> The rationale is that GOOPS is normally not loaded unless the user
> explicitly asks for it; having (system foreign-objects) load it would
> add overhead even for users who just want SMOB-like functionality.
>
> WDYT?
>
> The preliminary patch attached is an attempt to do that.  Somehow, the
> creation of GOOPS classes for vtables doesn’t work as I thought, which
> means that ‘test-foreign-object-scm’ cannot define methods and so on
> (which I agree is useful functionality.)  What am I missing?
>
> Thanks!
>
> Ludo’.
>
> PS: The reason I’m looking at it is that I would really want us to
>     release 2.0.12 ASAP, so any changes to this API must be settled.
>
>

[-- Attachment #2: Type: text/html, Size: 1956 bytes --]

Re: [PATCH] Avoid GOOPS in (system foreign-object)?

[Ludovic Courtès]

Hi Mikael,

Mikael Djurfeldt <mikael@djurfeldt.com> skribis:

> Sadly, I nowadays only have time to look at guile-devel briefly now and
> then.  I did this now and happened to see this.

Good to read you here!  :-)

> Just wanted to say that I think that we (or at least I) at some point in
> time had the goal to replace structs with pure GOOPS data structures. In
> the context of FFI, this would allow you to be more flexible than what
> structs allow, ultimately being able to access arbitrary C structs and C++
> structs/classes directly from Scheme.  I find that a proper MOP (which
> maybe still is not fully developed) is a nicer way to handle non-standard
> access than the strange character strings in struct vtables...

The struct layout strings are a bit clunky, indeed.  ;-)  I like the
flexibility that GOOPS provide, especially when it comes to extending
things like ‘equal?’, ‘write’, and so on.

I think it’s better if GOOPS is not a requirement for basic interfaces
like this SMOB replacement, though.  One of the concerns is performance.
For instance, in 2.0, start-up time with GOOPS is on the order of 3
times higher than without it, as measured with:

  time for i in `seq 1 30` ; do guile -c '(use-modules (oop goops))' ; done

Thanks for your feedback!

Ludo’.

Re: [PATCH] Avoid GOOPS in (system foreign-object)?

[Mikael Djurfeldt]

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

On Fri, May 22, 2015 at 10:42 AM, Ludovic Courtès <ludo@gnu.org> wrote:

> > Just wanted to say that I think that we (or at least I) at some point in
> > time had the goal to replace structs with pure GOOPS data structures. In
> > the context of FFI, this would allow you to be more flexible than what
> > structs allow, ultimately being able to access arbitrary C structs and
> C++
> > structs/classes directly from Scheme.  I find that a proper MOP (which
> > maybe still is not fully developed) is a nicer way to handle non-standard
> > access than the strange character strings in struct vtables...
>
> The struct layout strings are a bit clunky, indeed.  ;-)  I like the
> flexibility that GOOPS provide, especially when it comes to extending
> things like ‘equal?’, ‘write’, and so on.
>
> I think it’s better if GOOPS is not a requirement for basic interfaces
> like this SMOB replacement, though.  One of the concerns is performance.
> For instance, in 2.0, start-up time with GOOPS is on the order of 3
> times higher than without it
>

Right, but it's probably possible to re-organize things such that it's not
necessary to load all of GOOPS to use basic interfaces, even if everything
is based on a common non-struct data type...  Just meant as input---do what
you think is best!

[-- Attachment #2: Type: text/html, Size: 1712 bytes --]

Re: [PATCH] Avoid GOOPS in (system foreign-object)?

[Jan Nieuwenhuizen]

Ludovic Courtès writes:

>   time for i in `seq 1 30` ; do guile -c '(use-modules (oop goops))' ; done

Have you looked at --and tried this with-- Wingo's wip-goops-refactor
branch?  I just did and although I found some minor problems,
performance is amazing.

Greetings, Jan

-- 
Jan Nieuwenhuizen <janneke@gnu.org> | GNU LilyPond http://lilypond.org
Freelance IT http://JoyofSource.com | Avatar®  http://AvatarAcademy.nl  

Re: [PATCH] Avoid GOOPS in (system foreign-object)?

[Ludovic Courtès]

Jan Nieuwenhuizen <janneke@gnu.org> skribis:

> Ludovic Courtès writes:
>
>>   time for i in `seq 1 30` ; do guile -c '(use-modules (oop goops))' ; done
>
> Have you looked at --and tried this with-- Wingo's wip-goops-refactor
> branch?  I just did and although I found some minor problems,
> performance is amazing.

This is good news, but the new API is currently scheduled for 2.0.12.

Ludo’.