Memory management

src/qmckl_context.org

@@ -23,6 +23,7 @@ MunitResult test_<<filename()>>() {
 #include <pthread.h>
 
 #include "qmckl_error_private_type.h"
+#include "qmckl_memory_private_type.h"
 #include "qmckl_numprec_private_type.h"
   #+end_src
 
@@ -39,10 +40,9 @@ MunitResult test_<<filename()>>() {
 #include "qmckl_context_private_type.h"
 #include "qmckl_context_type.h"
 
-#include "qmckl_memory_func.h"
+#include "qmckl_memory_private_func.h"
 #include "qmckl_context_func.h"
 
-static void init_lock(pthread_mutex_t* mutex);
   #+end_src
 
 * Context handling
@@ -94,9 +94,7 @@ typedef struct qmckl_context_struct {
   qmckl_error_struct       error;
 
  /* Memory allocation */
-  /*
   qmckl_memory_struct      memory;
-  ,*/
 
  /* -- Molecular system -- */
   /* To be implemented:
@@ -173,11 +171,26 @@ qmckl_context qmckl_context_create() {
     return QMCKL_NULL_CONTEXT;
   }
 
- /* Set all pointers to NULL */
+ /* Set all pointers and values to NULL */
+  {
     memset(ctx, 0, sizeof(qmckl_context_struct));
+  }
 
  /* Initialize lock */
-  init_lock(&(ctx->mutex));
+  {
+    pthread_mutexattr_t attr;
+    int rc;
+    
+    rc = pthread_mutexattr_init(&attr); 
+    assert (rc == 0);
+    
+    (void) pthread_mutexattr_settype(&attr, PTHREAD_MUTEX_RECURSIVE);
+    
+    rc = pthread_mutex_init ( &(ctx->mutex), &attr);
+    assert (rc == 0);
+    
+    (void) pthread_mutexattr_destroy(&attr);
+  }  
 
  /* Initialize data */
   ctx->tag = VALID_TAG;
@@ -185,7 +198,21 @@ qmckl_context qmckl_context_create() {
   const qmckl_context context = (const qmckl_context) ctx;
   assert ( qmckl_context_check(context) != QMCKL_NULL_CONTEXT );
 
-  return context;
+ /* Allocate qmckl_memory_struct */
+  {
+    const size_t size = 128L;
+    qmckl_memory_info_struct * new_array = calloc(size, sizeof(qmckl_memory_info_struct));
+    if (new_array == NULL) {
+      return QMCKL_NULL_CONTEXT; 
+    }
+    memset( &(new_array[0]), 0, size * sizeof(qmckl_memory_info_struct) );
+    
+    ctx->memory.element = new_array;
+    ctx->memory.array_size = size;
+    ctx->memory.n_allocated = (size_t) 0;
+  }
+  
+  return (qmckl_context) ctx;
 }
    #+end_src
 
@@ -223,22 +250,7 @@ void qmckl_unlock(qmckl_context context);
 
    # Source
    #+begin_src c :tangle (eval c)
-static void init_lock(pthread_mutex_t* mutex) {
-  pthread_mutexattr_t attr;
-  int rc;
-  
-  rc = pthread_mutexattr_init(&attr); 
-  assert (rc == 0);
-  
-  (void) pthread_mutexattr_settype(&attr, PTHREAD_MUTEX_RECURSIVE);
-  
-  rc = pthread_mutex_init ( mutex, &attr);
-  assert (rc == 0);
-  
-  (void)pthread_mutexattr_destroy(&attr);
-}
-
-void qmckl_lock(const qmckl_context context) {
+void qmckl_lock(qmckl_context context) {
   if (context == QMCKL_NULL_CONTEXT)
     return ;
   qmckl_context_struct* const ctx = (qmckl_context_struct* const) context;
@@ -252,7 +264,7 @@ void qmckl_lock(const qmckl_context context) {
   ctx->lock_count += 1;
 /*
   printf("  lock : %d\n", ctx->lock_count);
-*/
+,*/
 }
 
 void qmckl_unlock(const qmckl_context context) {
@@ -266,13 +278,13 @@ void qmckl_unlock(const qmckl_context context) {
   ctx->lock_count -= 1;
 /*
   printf("unlock : %d\n", ctx->lock_count);
-*/
+,*/
 }
    #+end_src
 
 ** TODO Copy
 
- ~qmckl_context_copy~ makes a shallow copy of a context. It returns
+ ~qmckl_context_copy~ makes a deep copy of a context. It returns
  ~QMCKL_NULL_CONTEXT~ upon failure.
 
    # Header
@@ -285,36 +297,38 @@ qmckl_context qmckl_context_copy(const qmckl_context context);
    #+begin_src c :tangle (eval c)
 qmckl_context qmckl_context_copy(const qmckl_context context) {
 
-  qmckl_lock(context);
-
   const qmckl_context checked_context = qmckl_context_check(context);
 
   if (checked_context == QMCKL_NULL_CONTEXT) {
-    qmckl_unlock(context);
     return QMCKL_NULL_CONTEXT;
   }
 
+  /*
+  qmckl_lock(context);
+  {
     
     const qmckl_context_struct* const old_ctx =
       (qmckl_context_struct* const) checked_context;
     
     qmckl_context_struct* const new_ctx =
-    (qmckl_context_struct* const) qmckl_malloc (context, sizeof(qmckl_context_struct));
+      (qmckl_context_struct* const) malloc (context, sizeof(qmckl_context_struct));
     
     if (new_ctx == NULL) {
       qmckl_unlock(context);
       return QMCKL_NULL_CONTEXT;
     }
     
- /* Copy the old context on the new one */
- /* TODO Deep copies should be done here */
+     * Copy the old context on the new one * 
+     * TODO Deep copies should be done here * 
     memcpy(new_ctx, old_ctx, sizeof(qmckl_context_struct));
     
- /* As the lock was copied, both need to be unlocked */
     qmckl_unlock( (qmckl_context) new_ctx );
-  qmckl_unlock( (qmckl_context) old_ctx );
     
     return (qmckl_context) new_ctx;
+  }
+  qmckl_unlock(context);
+*/
+    return QMCKL_NULL_CONTEXT;
 }
 
    #+end_src
@@ -332,10 +346,12 @@ qmckl_context qmckl_context_copy(const qmckl_context context) {
 
    # Test
    #+begin_src c :comments link :tangle (eval c_test) :exports none
+/*
 qmckl_context new_context = qmckl_context_copy(context);
 munit_assert_int64(new_context, !=, QMCKL_NULL_CONTEXT);
 munit_assert_int64(new_context, !=, context);
 munit_assert_int64(qmckl_context_check(new_context), ==, new_context);
+*/
    #+end_src
 
 ** Destroy
@@ -355,28 +371,36 @@ qmckl_exit_code qmckl_context_destroy(const qmckl_context context) {
   const qmckl_context checked_context = qmckl_context_check(context);
   if (checked_context == QMCKL_NULL_CONTEXT) return QMCKL_INVALID_CONTEXT;
 
-  qmckl_lock(context);
-  
   qmckl_context_struct* const ctx = (qmckl_context_struct* const) context;
   assert (ctx != NULL); /* Shouldn't be possible because the context is valid */
 
- /* TODO Remove all allocated data */
-  /*
-  qmckl_memory_free_all(context);
-  ,*/
-  
+  qmckl_lock(context);
+  {
+ /* Memory: Remove all allocated data */
+    for (size_t pos = (size_t) 0 ; pos < ctx->memory.array_size ; ++pos) {
+      if (ctx->memory.element[pos].pointer != NULL) {
+        free(ctx->memory.element[pos].pointer);
+        memset( &(ctx->memory.element[pos]), 0, sizeof(qmckl_memory_info_struct) );
+        ctx->memory.n_allocated -= 1;
+      }
+    }
+    assert (ctx->memory.n_allocated == (size_t) 0);
+    free(ctx->memory.element);
+    ctx->memory.element = NULL;
+    ctx->memory.array_size = (size_t) 0;
+  }
   qmckl_unlock(context);
 
+  ctx->tag = INVALID_TAG;
+
   const int rc_destroy = pthread_mutex_destroy( &(ctx->mutex) );
   if (rc_destroy != 0) {
+/* DEBUG */
      fprintf(stderr, "qmckl_context_destroy: %s (count = %d)\n", strerror(rc_destroy), ctx->lock_count);
      abort();
   }
 
-  ctx->tag = INVALID_TAG;
-
-  const qmckl_exit_code rc = qmckl_free(context,ctx);
-  assert (rc == QMCKL_SUCCESS);
+  free(ctx);
 
   return QMCKL_SUCCESS;
 }
@@ -395,11 +419,15 @@ qmckl_exit_code qmckl_context_destroy(const qmckl_context context) {
 
     # Test
     #+begin_src c :tangle (eval c_test)  :exports none
-munit_assert_int64(qmckl_context_check(new_context), ==, new_context);
-munit_assert_int32(qmckl_context_destroy(new_context), ==, QMCKL_SUCCESS);
-munit_assert_int64(qmckl_context_check(new_context), !=, new_context);
-munit_assert_int64(qmckl_context_check(new_context), ==, QMCKL_NULL_CONTEXT);
+/* Destroy valid context */
+munit_assert_int64(qmckl_context_check(context), ==, context);
 munit_assert_int32(qmckl_context_destroy(context), ==, QMCKL_SUCCESS);
+
+/* Check that context is destroyed  */
+munit_assert_int64(qmckl_context_check(context), !=, context);
+munit_assert_int64(qmckl_context_check(context), ==, QMCKL_NULL_CONTEXT);
+
+/* Destroy invalid context */
 munit_assert_int32(qmckl_context_destroy(QMCKL_NULL_CONTEXT), ==, QMCKL_INVALID_CONTEXT);
     #+end_src
 

src/qmckl_error.org

@@ -154,16 +154,22 @@ return '\n'.join(result)
    #+end_src
    :end:
 
-   The ~qmckl_strerror~ converts an exit code into a string. The
+   The ~qmckl_string_of_error~ converts an exit code into a string. The
    string is assumed to be large enough to contain the error message
    (typically 128 characters).
 
+* Decoding errors
+
+   To decode the error messages, ~qmckl_string_of_error~ converts an
+   error code into a string.  
+
    #+NAME: MAX_STRING_LENGTH
    : 128
 
    #+begin_src c :comments org :tangle (eval h_func) :exports none :noweb yes
 const char* qmckl_string_of_error(const qmckl_exit_code error);
-void qmckl_string_of_error_f(const qmckl_exit_code error, char result[<<MAX_STRING_LENGTH()>>]);
+void qmckl_string_of_error_f(const qmckl_exit_code error,
+                             char result[<<MAX_STRING_LENGTH()>>]);
    #+end_src
    
    The text strings are extracted from the previous table.
@@ -231,8 +237,7 @@ typedef struct qmckl_error_struct {
 
 * Updating errors in the context
    
-   The error is updated in the context using
- ~qmckl_set_error~.
+   The error is updated in the context using ~qmckl_set_error~.
    When the error is set in the context, it is mandatory to specify
    from which function the error is triggered, and a message
    explaining the error. The exit code can't be ~QMCKL_SUCCESS~.
@@ -286,8 +291,11 @@ qmckl_set_error(qmckl_context context,
    To make a function fail, the ~qmckl_failwith~ function should be
    called, such that information about the failure is stored in
    the context. The desired exit code is given as an argument, as
-   well as the name of the function and an error message. The return
-   code of the function is the desired return code.
+   well as the name of the function and an error message. If the
+   message is ~NULL~, then the default message obtained by
+ ~qmckl_string_of_error~ is used. The return code of the function is
+   the desired return code.
+   Upon failure, a ~QMCKL_NULL_CONTEXT~ is returned.
 
    #+begin_src c :comments org :tangle (eval h_func) :exports none
 qmckl_exit_code qmckl_failwith(qmckl_context context,
@@ -305,17 +313,23 @@ qmckl_exit_code qmckl_failwith(qmckl_context context,
   assert (exit_code > 0);
   assert (exit_code < QMCKL_INVALID_EXIT_CODE);
   assert (function != NULL);
-  assert (message  != NULL);
   assert (strlen(function) < QMCKL_MAX_FUN_LEN);
+  if (message != NULL) {
     assert (strlen(message)  < QMCKL_MAX_MSG_LEN);
+  }
 
   if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT)
-    return QMCKL_NULL_CONTEXT;
-  
-  const qmckl_exit_code rc = 
-    qmckl_set_error(context, exit_code, function, message);
+    return QMCKL_INVALID_CONTEXT;
   
+  if (message == NULL) {
+    qmckl_exit_code rc = 
+      qmckl_set_error(context, exit_code, function, qmckl_string_of_error(exit_code));
     assert (rc == QMCKL_SUCCESS);
+  } else {
+    qmckl_exit_code rc = 
+      qmckl_set_error(context, exit_code, function, message);
+    assert (rc == QMCKL_SUCCESS);
+  }
 
   return exit_code;
 }
@@ -332,10 +346,6 @@ if (x < 0) {
  }
    #+end_src
     
-* TODO Decoding errors
-
-   To decode the error messages, ~qmckl_strerror~ converts an
-   error code into a string. 
 
 * End of files                                                    :noexport:
 

src/qmckl_memory.org

@@ -15,12 +15,15 @@ optimized libraries to fine-tune the memory allocation.
   #+begin_src c :tangle (eval c)
 #include <stdint.h>
 #include <stdlib.h>
+#include <string.h>
 #include <assert.h>
 
 #include "qmckl_error_type.h"
+#include "qmckl_memory_private_type.h"
 #include "qmckl_context_type.h"
 #include "qmckl_context_private_type.h"
 
+#include "qmckl_memory_private_func.h"
 #include "qmckl_memory_func.h"
 #include "qmckl_context_func.h"
 #include "qmckl_error_func.h"
@@ -29,13 +32,59 @@ optimized libraries to fine-tune the memory allocation.
   #+begin_src c :tangle (eval c_test) :noweb yes
 #include "qmckl.h"
 #include "munit.h"
+#include "qmckl_context_private_type.h"
+#include "qmckl_memory_private_func.h"
 MunitResult test_<<filename()>>() {
   #+end_src
 
-* 
-:PROPERTIES:
-:UNNUMBERED: t
-:END:
+
+  #+begin_src c :tangle (eval h_private_type) :noweb yes
+#ifndef QMCKL_MEMORY_HPT
+#define QMCKL_MEMORY_HPT
+
+#include <stdint.h>
+  #+end_src
+
+* Memory data structure for the context
+  
+  Every time a new block of memory is allocated, the information
+  relative to the allocation is stored in a new ~qmckl_memory_info_struct~.
+  A ~qmckl_memory_info_struct~ contains the pointer to the memory block, 
+  its size in bytes, and extra implementation-specific information such as
+  alignment, pinning, if the memory should be allocated on CPU or GPU
+ /etc/.
+
+  #+begin_src c :tangle (eval h_private_type) :noweb yes
+typedef struct qmckl_memory_info_struct {
+  size_t size;
+  void*  pointer;
+} qmckl_memory_info_struct;
+
+static const qmckl_memory_info_struct qmckl_memory_info_struct_zero =
+  {
+   .size = (size_t) 0,
+   .pointer = NULL
+  };
+  #+end_src
+  
+  The ~memory~ element of the context is a data structure which
+  contains an array of ~qmckl_memory_info_struct~, the size of the
+  array, and the number of allocated blocks.
+  
+  #+begin_src c :tangle (eval h_private_type) :noweb yes
+typedef struct qmckl_memory_struct {
+  size_t                    n_allocated;
+  size_t                    array_size;
+  qmckl_memory_info_struct* element;
+} qmckl_memory_struct;
+  #+end_src
+
+* Passing info to allocation routines
+
+  Passing information to the allocation routine should be done by
+  passing an instance of a ~qmckl_memory_info_struct~.
+  
+* Allocation/deallocation functions
 
   Memory allocation inside the library should be done with
  ~qmckl_malloc~. It lets the library choose how the memory will be
@@ -47,55 +96,88 @@ MunitResult test_<<filename()>>() {
   If the allocation failed, the ~NULL~ pointer is returned.
 
   # Header
-  #+begin_src c :tangle (eval h_func) :noexport
+  #+begin_src c :tangle (eval h_private_func) :noexport
 void* qmckl_malloc(qmckl_context context,
-                   const size_t size);
+                   const qmckl_memory_info_struct info);
   #+end_src
   
-  In this implementation, we use ~calloc~ because it initializes the
-  memory block to zero, so structs will have ~NULL~-initialized pointers.
-
   # Source
   #+begin_src c :tangle (eval c)
-void* qmckl_malloc(qmckl_context context, const size_t size) {
+void* qmckl_malloc(qmckl_context context, const qmckl_memory_info_struct info) {
 
   assert (qmckl_context_check(context) != QMCKL_NULL_CONTEXT);
-  void * pointer = calloc(size, (size_t) 1);
 
-  /*
-  if (qmckl_context_check(context) != QMCKL_NULL_CONTEXT) {
-    qmckl_exit_code rc;
-    rc = qmckl_context_append_memory(context, pointer, size);
-    assert (rc == QMCKL_SUCCESS);
+  qmckl_context_struct* const ctx = (qmckl_context_struct* const) context;
+
+ /* Allocate memory and zero it */
+  void * pointer = malloc(info.size);
+  if (pointer == NULL) {
+    return NULL;
   }
-  */
+  memset(pointer, 0, info.size);
+
+  qmckl_lock(context);
+  {
+ /* If qmckl_memory_struct is full, reallocate a larger one */
+    if (ctx->memory.n_allocated == ctx->memory.array_size) {
+      const size_t old_size = ctx->memory.array_size;
+      qmckl_memory_info_struct * new_array = reallocarray(ctx->memory.element,
+                                                          2L * old_size,
+                                                          sizeof(qmckl_memory_info_struct));
+      if (new_array == NULL) {
+        qmckl_unlock(context);
+        return NULL;
+      }
+      
+      memset( &(new_array[old_size]), 0, old_size * sizeof(qmckl_memory_info_struct) );
+      ctx->memory.element = new_array;
+      ctx->memory.array_size = 2L * old_size;
+    }
+    
+ /* Find first NULL entry */
+    size_t pos = (size_t) 0;
+    while ( pos < ctx->memory.array_size && ctx->memory.element[pos].size > (size_t) 0) {
+      pos += (size_t) 1;
+    }
+    assert (ctx->memory.element[pos].size == (size_t) 0);
+
+ /* Copy info at the new location */
+    ctx->memory.element[pos].size    = info.size;
+    ctx->memory.element[pos].pointer = pointer;
+    ctx->memory.n_allocated += (size_t) 1;
+  }
+  qmckl_unlock(context);
   
   return pointer;
 }
   #+end_src
 
-  # Fortran interface
-  #+begin_src f90 :tangle (eval fh_func) :noexport
-  interface
-     type (c_ptr) function qmckl_malloc (context, size) bind(C)
-       use, intrinsic :: iso_c_binding
-       import
-       integer (qmckl_context), intent(in), value :: context
-       integer (c_int64_t)    , intent(in), value :: size
-     end function qmckl_malloc
-  end interface
-  #+end_src
 
    # Test                                                            :noexport:
    #+begin_src c :tangle (eval c_test)
+/* Create a context */
 qmckl_context context = qmckl_context_create();    
 
-int *a = (int*) qmckl_malloc(context, 3*sizeof(int));
-munit_assert(a != NULL);
+qmckl_memory_info_struct info = qmckl_memory_info_struct_zero;
+info.size = (size_t) 3;
 
+/* Allocate an array of ints */
+int *a = (int*) qmckl_malloc(context, info);
+
+/* Check that array of ints is OK */
+munit_assert(a != NULL);
 a[0] = 1;  munit_assert_int(a[0], ==, 1);
 a[1] = 2;  munit_assert_int(a[1], ==, 2);
 a[2] = 3;  munit_assert_int(a[2], ==, 3);
+
+/* Allocate another array of ints */
+int *b = (int*) qmckl_malloc(context, info);
+
+/* Check that array of ints is OK */
+munit_assert(b != NULL);
+b[0] = 1;  munit_assert_int(b[0], ==, 1);
+b[1] = 2;  munit_assert_int(b[1], ==, 2);
+b[2] = 3;  munit_assert_int(b[2], ==, 3);
    #+end_src
 
   When freeing the memory with ~qmckl_free~, the context is passed, in
@@ -104,24 +186,19 @@ a[2] = 3;  munit_assert_int(a[2], ==, 3);
 
   #+begin_src c :tangle (eval h_func)
 qmckl_exit_code qmckl_free(qmckl_context context,
-                           void *ptr);
-  #+end_src
-
-  #+begin_src f90 :tangle (eval fh_func)
-  interface
-     integer (qmckl_exit_code) function qmckl_free (context, ptr) bind(C)
-       use, intrinsic :: iso_c_binding
-       import
-       integer (qmckl_context), intent(in), value :: context
-       type (c_ptr), intent(in), value :: ptr
-     end function qmckl_free
-  end interface
+                           void * const ptr);
   #+end_src
 
    # Source
    #+begin_src c :tangle (eval c)
-qmckl_exit_code qmckl_free(qmckl_context context, void *ptr) {
-  if (qmckl_context_check(context) != QMCKL_NULL_CONTEXT) {
+qmckl_exit_code qmckl_free(qmckl_context context, void * const ptr) {
+
+  if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT) {
+      return qmckl_failwith(context,
+                            QMCKL_INVALID_CONTEXT,
+                            "qmckl_free",
+                            NULL);
+  }
   
   if (ptr == NULL) {
     return qmckl_failwith(context,
@@ -130,14 +207,32 @@ qmckl_exit_code qmckl_free(qmckl_context context, void *ptr) {
                           "NULL pointer");
   }
   
-    /*
-    qmckl_exit_code rc;
-    rc = qmckl_context_remove_memory(context, ptr);
+  qmckl_context_struct* const ctx = (qmckl_context_struct* const) context;
 
-    assert (rc == QMCKL_SUCCESS);
-    */
+  qmckl_lock(context);
+  {
+ /* Find pointer in array of saved pointers */
+    size_t pos = (size_t) 0;
+    while ( pos < ctx->memory.array_size && ctx->memory.element[pos].pointer != ptr) {
+      pos += (size_t) 1;
     }
+    
+    if (pos >= ctx->memory.array_size) {
+ /* Not found */
+      qmckl_unlock(context);
+      return qmckl_failwith(context,
+                            QMCKL_FAILURE,
+                            "qmckl_free",
+                            "Pointer not found in context");
+    }
+
     free(ptr);
+
+    memset( &(ctx->memory.element[pos]), 0, sizeof(qmckl_memory_info_struct) );
+    ctx->memory.n_allocated -= (size_t) 1;
+  }
+  qmckl_unlock(context);
+
   return QMCKL_SUCCESS;
 }
    #+end_src
@@ -145,11 +240,27 @@ qmckl_exit_code qmckl_free(qmckl_context context, void *ptr) {
    # Test
    #+begin_src c :tangle (eval c_test) :exports none
 qmckl_exit_code rc;
-
+/* Assert that both arrays are allocated */
 munit_assert(a != NULL);
+munit_assert(b != NULL);
+
+/* Free in NULL context */
+rc = qmckl_free(QMCKL_NULL_CONTEXT, a);
+munit_assert(rc == QMCKL_INVALID_CONTEXT);
+
+/* Free NULL pointer */
+rc = qmckl_free(context, NULL);
+munit_assert(rc == QMCKL_INVALID_ARG_2);
+
+/* Free for the first time */
 rc = qmckl_free(context, a);
 munit_assert(rc == QMCKL_SUCCESS);
 
+/* Free again */
+rc = qmckl_free(context, a);
+munit_assert(rc == QMCKL_FAILURE);
+
+/* Clean up */
 rc = qmckl_context_destroy(context);
 munit_assert(rc == QMCKL_SUCCESS);
 
@@ -157,6 +268,10 @@ munit_assert(rc == QMCKL_SUCCESS);
 
 * End of files                                                     :noexport:
 
+  #+begin_src c :comments org :tangle (eval h_private_type)
+#endif
+
+  #+end_src
 ** Test
   #+begin_src c :comments org :tangle (eval c_test)
   return MUNIT_OK;