add new Lisp_Module type (misc subtype)feature/aptel/dynamic-modules-rc3

Lisp_Module is a new subtype of Misc objects. As other Misc types, it
re-uses the marker free list.

A module must have a custom destructor, which is automatically called
by the GC.

Previous module object using the Save_Value type still work and they
still have to be free explicitely from Lisp. Their use is now
discouraged in modules.

A simple module example + tests are available in modules/memtest.

11 files changed, 366 insertions, 4 deletions

diff --git a/modules/fmod/test.el b/modules/fmod/test.el
index e1478d88b97..040c5f04595 100644
--- a/modules/fmod/test.el
+++ b/modules/fmod/test.el
@@ -2,6 +2,10 @@
 
 ;; basic module test should go here
 
+(ert-deftest fmod-module-available ()
+  "Tests if `module-available-p' is t"
+  (should (module-available-p)))
+
 (ert-deftest fmod-require ()
   "Tests bindings after require"
   (skip-unless (not (fboundp 'fmod)))
diff --git a/modules/memtest/Makefile b/modules/memtest/Makefile
new file mode 100644
index 00000000000..2492af1deff
--- /dev/null
+++ b/modules/memtest/Makefile
@@ -0,0 +1,12 @@
+ROOT = ../..
+
+all: memtest.so memtest.doc
+
+%.so: %.o
+	gcc -shared -o $@ $<
+
+%.o: %.c
+	gcc -ggdb3 -Wall -I$(ROOT)/src -I$(ROOT)/lib -fPIC -c $<
+
+%.doc: %.c
+	$(ROOT)/lib-src/make-docfile $< > $@
diff --git a/modules/memtest/memtest.c b/modules/memtest/memtest.c
new file mode 100644
index 00000000000..f2dbf4a8225
--- /dev/null
+++ b/modules/memtest/memtest.c
@@ -0,0 +1,116 @@
+#include <config.h>
+#include <lisp.h>
+
+int plugin_is_GPL_compatible;
+
+static module_id_t module_id;
+static Lisp_Object MQmemtest;
+
+static int free_count = 0;
+
+struct int_buffer
+{
+  int size;
+  int capacity;
+  int *buf;
+};
+
+#define MXBUF(x) ((struct int_buffer*)(XMODULE (x)->p))
+
+static void buf_init (struct int_buffer *b, int size)
+{
+  b->size = size;
+  b->capacity = (size == 0 ? 1 : size);
+  b->buf = malloc (sizeof (*b->buf) * b->capacity);
+}
+
+static void buf_add (struct int_buffer *b, int val)
+{
+  if (b->size >= b->capacity)
+    {
+      b->capacity *= 2;
+      b->buf = realloc (b->buf, sizeof (*b->buf) * b->capacity);
+    }
+
+  b->buf[b->size++] = val;
+}
+
+static void memtest_destructor (void *p)
+{
+  struct int_buffer *b = p;
+  free (b->buf);
+  free (b);
+  free_count++;
+}
+
+EXFUN (Fmemtest_make, 1);
+DEFUN ("memtest-make", Fmemtest_make, Smemtest_make, 0, 1, 0,
+       doc: "Return an int buffer in the form of a Lisp_Module object.")
+  (Lisp_Object size)
+{
+  struct int_buffer *b;
+
+  b = malloc (sizeof (*b));
+  buf_init (b, NILP (size) ? 0 : XINT (size));
+
+  return module_make_object (module_id, memtest_destructor, (void*)b);
+}
+
+EXFUN (Fmemtest_get, 2);
+DEFUN ("memtest-get", Fmemtest_get, Smemtest_get, 2, 2, 0,
+       doc: "Get value at index N of a memtest buffer.")
+  (Lisp_Object buf, Lisp_Object n)
+{
+  return make_number (MXBUF (buf)->buf[XINT (n)]);
+}
+
+EXFUN (Fmemtest_set, 3);
+DEFUN ("memtest-set", Fmemtest_set, Smemtest_set, 3, 3, 0,
+       doc: "Doc")
+  (Lisp_Object buf, Lisp_Object n, Lisp_Object value)
+{
+  MXBUF (buf)->buf[XINT (n)] = XINT (value);
+  return value;
+}
+
+EXFUN (Fmemtest_size, 1);
+DEFUN ("memtest-size", Fmemtest_size, Smemtest_size, 1, 1, 0,
+       doc: "Doc")
+  (Lisp_Object buf)
+{
+  return make_number (MXBUF (buf)->size);
+}
+
+EXFUN (Fmemtest_add, 2);
+DEFUN ("memtest-add", Fmemtest_add, Smemtest_add, 2, 2, 0,
+       doc: "Doc")
+  (Lisp_Object buf, Lisp_Object value)
+{
+  buf_add (MXBUF (buf), XINT (value));
+  return Qnil;
+}
+
+
+EXFUN (Fmemtest_free_count, 0);
+DEFUN ("memtest-free-count", Fmemtest_free_count, Smemtest_free_count, 0, 0, 0,
+       doc: "Doc")
+  (void)
+{
+  return make_number (free_count);
+}
+
+
+void init ()
+{
+  module_id = module_make_id ();
+  MQmemtest = intern ("memtest");
+
+  defsubr (&Smemtest_make);
+  defsubr (&Smemtest_set);
+  defsubr (&Smemtest_get);
+  defsubr (&Smemtest_add);
+  defsubr (&Smemtest_size);
+  defsubr (&Smemtest_free_count);
+
+  Fprovide (MQmemtest, Qnil);
+}
diff --git a/modules/memtest/test.el b/modules/memtest/test.el
new file mode 100644
index 00000000000..d7bf2bfa47c
--- /dev/null
+++ b/modules/memtest/test.el
@@ -0,0 +1,20 @@
+(require 'ert)
+(require 'memtest)
+
+(ert-deftest memtest-basic ()
+  "Tests creation/access/release of module objects"
+  (let* ((fc (memtest-free-count))
+         (n 100))
+
+    (let ((b (memtest-make)))
+      (dotimes (i n)
+        (should (= (memtest-size b) i))
+        (memtest-add b i)
+        (should (= (memtest-size b) (1+ i)))))
+
+    ;; force GC
+    (garbage-collect)
+    (sleep-for 1)
+    (garbage-collect)
+
+    (should (= (memtest-free-count) (1+ fc)))))
diff --git a/src/Makefile.in b/src/Makefile.in
index b2bfbfc0312..30abe036edd 100644
--- a/src/Makefile.in
+++ b/src/Makefile.in
@@ -366,7 +366,7 @@ base_obj = dispnew.o frame.o scroll.o xdisp.o menu.o $(XMENU_OBJ) window.o \
 	$(CM_OBJ) term.o terminal.o xfaces.o $(XOBJ) $(GTK_OBJ) $(DBUS_OBJ) \
 	emacs.o keyboard.o macros.o keymap.o sysdep.o \
 	buffer.o filelock.o insdel.o marker.o \
-	minibuf.o fileio.o dired.o \
+	minibuf.o fileio.o dired.o module.o \
 	cmds.o casetab.o casefiddle.o indent.o search.o regex.o undo.o \
 	alloc.o data.o doc.o editfns.o callint.o \
 	eval.o floatfns.o fns.o font.o print.o lread.o \
diff --git a/src/alloc.c b/src/alloc.c
index 4daa60ca0f1..5a0b2641b10 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -3657,6 +3657,38 @@ free_marker (Lisp_Object marker)
   free_misc (marker);
 }
 
+#ifdef HAVE_LTDL
+/* Create a new module object. */
+Lisp_Object
+module_make_object (module_id_t id, void (*dtor) (void*), void *userptr)
+{
+  Lisp_Object obj;
+  struct Lisp_Module *m;
+
+  eassert (id < MODULE_ID_MAX);
+
+  obj = allocate_misc (Lisp_Misc_Module);
+  m = XMODULE (obj);
+  m->id = id;
+  m->dtor = dtor;
+  m->p = userptr;
+  return obj;
+}
+
+/* Free a module using its own destructor.  */
+void
+module_free_object (Lisp_Object obj)
+{
+  /* every change made here probably needs to be done in
+     sweep_marker() */
+
+  struct Lisp_Module *m = XMODULE (obj);
+  m->dtor (m->p);
+
+  free_misc (obj);
+}
+#endif
+
 
 /* Return a newly created vector or string with specified arguments as
    elements.  If all the arguments are characters that can fit
@@ -6367,6 +6399,12 @@ mark_object (Lisp_Object arg)
 	  mark_overlay (XOVERLAY (obj));
 	  break;
 
+#ifdef HAVE_LTDL
+	case Lisp_Misc_Module:
+	  XMISCANY (obj)->gcmarkbit = 1;
+	  break;
+#endif
+
 	default:
 	  emacs_abort ();
 	}
@@ -6744,9 +6782,23 @@ sweep_misc (void)
       for (i = 0; i < lim; i++)
         {
           if (!mblk->markers[i].m.u_any.gcmarkbit)
-            {
-              if (mblk->markers[i].m.u_any.type == Lisp_Misc_Marker)
-                unchain_marker (&mblk->markers[i].m.u_marker);
+              {
+                switch (mblk->markers[i].m.u_any.type)
+                  {
+                  case Lisp_Misc_Marker:
+                    unchain_marker (&mblk->markers[i].m.u_marker);
+                    break;
+#ifdef HAVE_LTDL
+                  case Lisp_Misc_Module:
+                    /* Module dtor need to be called */
+                    {
+                      /* see module_free_object() */
+                      struct Lisp_Module *m = &mblk->markers[i].m.u_module;
+                      m->dtor (m->p);
+                    }
+                    break;
+#endif
+                  }
               /* Set the type of the freed object to Lisp_Misc_Free.
                  We could leave the type alone, since nobody checks it,
                  but this might catch bugs faster.  */
diff --git a/src/data.c b/src/data.c
index d06b9916b3a..ece0a324f30 100644
--- a/src/data.c
+++ b/src/data.c
@@ -224,6 +224,10 @@ for example, (type-of 1) returns `integer'.  */)
 	  return Qoverlay;
 	case Lisp_Misc_Float:
 	  return Qfloat;
+#ifdef HAVE_LTDL
+	case Lisp_Misc_Module:
+	  return Qmodule;
+#endif
 	}
       emacs_abort ();
 
@@ -424,6 +428,17 @@ DEFUN ("markerp", Fmarkerp, Smarkerp, 1, 1, 0,
   return Qnil;
 }
 
+#ifdef HAVE_LTDL
+DEFUN ("modulep", Fmodulep, Smodulep, 1, 1, 0,
+       doc: /* Return t if OBJECT is a module object.  */)
+  (Lisp_Object object)
+{
+  if (MODULEP (object))
+    return Qt;
+  return Qnil;
+}
+#endif
+
 DEFUN ("subrp", Fsubrp, Ssubrp, 1, 1, 0,
        doc: /* Return t if OBJECT is a built-in function.  */)
   (Lisp_Object object)
@@ -3457,6 +3472,9 @@ syms_of_data (void)
   DEFSYM (Qbool_vector_p, "bool-vector-p");
   DEFSYM (Qchar_or_string_p, "char-or-string-p");
   DEFSYM (Qmarkerp, "markerp");
+#ifdef HAVE_LTDL
+  DEFSYM (Qmodulep, "modulep");
+#endif
   DEFSYM (Qbuffer_or_string_p, "buffer-or-string-p");
   DEFSYM (Qinteger_or_marker_p, "integer-or-marker-p");
   DEFSYM (Qboundp, "boundp");
@@ -3552,6 +3570,9 @@ syms_of_data (void)
   DEFSYM (Qcons, "cons");
   DEFSYM (Qmarker, "marker");
   DEFSYM (Qoverlay, "overlay");
+#ifdef HAVE_LTDL
+  DEFSYM (Qmodule, "module");
+#endif
   DEFSYM (Qfloat, "float");
   DEFSYM (Qwindow_configuration, "window-configuration");
   DEFSYM (Qprocess, "process");
@@ -3601,6 +3622,9 @@ syms_of_data (void)
   defsubr (&Ssequencep);
   defsubr (&Sbufferp);
   defsubr (&Smarkerp);
+#ifdef HAVE_LTDL
+  defsubr (&Smodulep);
+#endif
   defsubr (&Ssubrp);
   defsubr (&Sbyte_code_function_p);
   defsubr (&Schar_or_string_p);
diff --git a/src/emacs.c b/src/emacs.c
index fdd17d1e062..a329afdcf33 100644
--- a/src/emacs.c
+++ b/src/emacs.c
@@ -1403,6 +1403,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
       /* syms_of_keymap (); */
       syms_of_macros ();
       syms_of_marker ();
+      syms_of_module ();
       syms_of_minibuf ();
       syms_of_process ();
       syms_of_search ();
diff --git a/src/lisp.h b/src/lisp.h
index e3ae3960832..d606e9c7b06 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -491,6 +491,9 @@ enum Lisp_Misc_Type
     /* Currently floats are not a misc type,
        but let's define this in case we want to change that.  */
     Lisp_Misc_Float,
+#ifdef HAVE_LTDL
+    Lisp_Misc_Module,
+#endif
     /* This is not a type code.  It is for range checking.  */
     Lisp_Misc_Limit
   };
@@ -600,6 +603,9 @@ INLINE bool OVERLAYP (Lisp_Object);
 INLINE bool PROCESSP (Lisp_Object);
 INLINE bool PSEUDOVECTORP (Lisp_Object, int);
 INLINE bool SAVE_VALUEP (Lisp_Object);
+#ifdef HAVE_LTDL
+INLINE bool MODULEP (Lisp_Object);
+#endif
 INLINE void set_sub_char_table_contents (Lisp_Object, ptrdiff_t,
 					      Lisp_Object);
 INLINE bool STRINGP (Lisp_Object);
@@ -2176,6 +2182,24 @@ XSAVE_OBJECT (Lisp_Object obj, int n)
   return XSAVE_VALUE (obj)->data[n].object;
 }
 
+#ifdef HAVE_LTDL
+
+#define MODULE_ID_BITS 5
+#define MODULE_ID_MAX ((1 << MODULE_ID_BITS) - 1)
+typedef unsigned module_id_t;
+struct Lisp_Module
+  {
+    ENUM_BF (Lisp_Misc_Type) type : 16;	/* = Lisp_Misc_Module */
+    bool_bf gcmarkbit : 1;
+    unsigned spacer : 15 - MODULE_ID_BITS;
+    unsigned id : MODULE_ID_BITS;
+
+    void (*dtor) (void*);
+    void *p;
+  };
+
+#endif
+
 /* A miscellaneous object, when it's on the free list.  */
 struct Lisp_Free
   {
@@ -2195,6 +2219,9 @@ union Lisp_Misc
     struct Lisp_Marker u_marker;
     struct Lisp_Overlay u_overlay;
     struct Lisp_Save_Value u_save_value;
+#ifdef HAVE_LTDL
+    struct Lisp_Module u_module;
+#endif
   };
 
 INLINE union Lisp_Misc *
@@ -2236,6 +2263,17 @@ XSAVE_VALUE (Lisp_Object a)
   eassert (SAVE_VALUEP (a));
   return & XMISC (a)->u_save_value;
 }
+
+#ifdef HAVE_LTDL
+
+INLINE struct Lisp_Module *
+XMODULE (Lisp_Object a)
+{
+  eassert (MODULEP (a));
+  return & XMISC (a)->u_module;
+}
+
+#endif
 
 /* Forwarding pointer to an int variable.
    This is allowed only in the value cell of a symbol,
@@ -2482,6 +2520,14 @@ SAVE_VALUEP (Lisp_Object x)
   return MISCP (x) && XMISCTYPE (x) == Lisp_Misc_Save_Value;
 }
 
+#ifdef HAVE_LTDL
+INLINE bool
+MODULEP (Lisp_Object x)
+{
+  return MISCP (x) && XMISCTYPE (x) == Lisp_Misc_Module;
+}
+#endif
+
 INLINE bool
 AUTOLOADP (Lisp_Object x)
 {
@@ -3839,6 +3885,10 @@ extern Lisp_Object make_save_funcptr_ptr_obj (void (*) (void), void *,
 					      Lisp_Object);
 extern Lisp_Object make_save_memory (Lisp_Object *, ptrdiff_t);
 extern void free_save_value (Lisp_Object);
+#ifdef HAVE_LTDL
+extern Lisp_Object module_make_object (module_id_t id, void (*dtor) (void*), void *userptr);
+extern void module_free_object (Lisp_Object);
+#endif
 extern Lisp_Object build_overlay (Lisp_Object, Lisp_Object, Lisp_Object);
 extern void free_marker (Lisp_Object);
 extern void free_cons (struct Lisp_Cons *);
@@ -4060,6 +4110,13 @@ extern Lisp_Object set_marker_restricted_both (Lisp_Object, Lisp_Object,
 extern Lisp_Object build_marker (struct buffer *, ptrdiff_t, ptrdiff_t);
 extern void syms_of_marker (void);
 
+/* Defined in module.c.  */
+
+#ifdef HAVE_LTDL
+extern module_id_t module_make_id (void);
+#endif
+extern void syms_of_module (void);
+
 /* Defined in fileio.c.  */
 
 extern Lisp_Object expand_and_dir_to_file (Lisp_Object, Lisp_Object);
diff --git a/src/module.c b/src/module.c
new file mode 100644
index 00000000000..b1aca0fb255
--- /dev/null
+++ b/src/module.c
@@ -0,0 +1,59 @@
+/* Dynamic modules related functions for GNU Emacs
+
+   Copyright (C) 2015 Free Software Foundation, Inc.
+
+   This file is part of GNU Emacs.
+
+   GNU Emacs is free software: you can redistribute it and/or modify
+   it under the terms of the GNU General Public License as published by
+   the Free Software Foundation, either version 3 of the License, or
+   (at your option) any later version.
+
+   GNU Emacs is distributed in the hope that it will be useful,
+   but WITHOUT ANY WARRANTY; without even the implied warranty of
+   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+   GNU General Public License for more details.
+
+   You should have received a copy of the GNU General Public License
+   along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.  */
+
+
+#include <config.h>
+#include <limits.h>
+#include "lisp.h"
+
+EXFUN (Fmodule_available_p, 0);
+DEFUN ("module-available-p", Fmodule_available_p, Smodule_available_p, 0, 0, 0,
+       doc: "Doc")
+  (void)
+{
+#ifdef HAVE_LTDL
+  return Qt;
+#else
+  return Qnil;
+#endif
+}
+
+/* Module functions */
+#ifdef HAVE_LTDL
+
+/* Return a unique id for a new module opaque type. */
+module_id_t
+module_make_id (void)
+{
+  static module_id_t module_count = 0;
+
+  eassert (module_count < MODULE_ID_MAX);
+  return module_count++;
+}
+
+#endif
+
+void syms_of_module (void)
+{
+#ifdef HAVE_LTDL
+  /* Nothing yet! */
+#endif
+
+  defsubr(&Smodule_available_p);
+}
diff --git a/src/print.c b/src/print.c
index 1a0aebbeba7..db41adc8add 100644
--- a/src/print.c
+++ b/src/print.c
@@ -2045,6 +2045,23 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
 	  PRINTCHAR ('>');
 	  break;
 
+#ifdef HAVE_LTDL
+        case Lisp_Misc_Module:
+          strout ("#<module id = ", -1, -1, printcharfun);
+          {
+            int len = sprintf (buf, "%u", XMODULE (obj)->id);
+            strout (buf, len, len, printcharfun);
+            strout (", dtor = ", -1, -1, printcharfun);
+            len = sprintf (buf, "%p", XMODULE (obj)->dtor);
+            strout (buf, len, len, printcharfun);
+            strout (", p = ", -1, -1, printcharfun);
+            len = sprintf (buf, "%p", XMODULE (obj)->p);
+            strout (buf, len, len, printcharfun);
+            strout (">", -1, -1, printcharfun);
+          }
+          break;
+#endif
+
 	  /* Remaining cases shouldn't happen in normal usage, but let's
 	     print them anyway for the benefit of the debugger.  */