qmckl/org/qmckl_context.org

#+TITLE: Context
#+SETUPFILE: ../tools/theme.setup
#+INCLUDE: ../tools/lib.org

* Headers                                                          :noexport:

  #+begin_src c :tangle (eval c_test) :noweb yes
#include "qmckl.h"
#include "assert.h"
#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
int main() {
  #+end_src

  #+begin_src c :tangle (eval h_private_type) :noweb yes
#ifndef QMCKL_CONTEXT_HPT
#define QMCKL_CONTEXT_HPT

#ifdef HAVE_STDINT_H
#include <stdint.h>
#elif HAVE_INTTYPES_H
#include <inttypes.h>
#endif

#include <pthread.h>

#include "qmckl_error_private_type.h"
#include "qmckl_memory_private_type.h"
#include "qmckl_numprec_private_type.h"
#include "qmckl_point_private_type.h"
#include "qmckl_nucleus_private_type.h"
#include "qmckl_electron_private_type.h"
#include "qmckl_ao_private_type.h"
#include "qmckl_mo_private_type.h"
#include "qmckl_jastrow_champ_private_type.h"
#include "qmckl_determinant_private_type.h"
#include "qmckl_local_energy_private_type.h"
#include "qmckl_point_private_func.h"
#include "qmckl_nucleus_private_func.h"
#include "qmckl_electron_private_func.h"
#include "qmckl_ao_private_func.h"
#include "qmckl_mo_private_func.h"
#include "qmckl_jastrow_champ_private_func.h"
#include "qmckl_determinant_private_func.h"
#include "qmckl_local_energy_private_func.h"
  #+end_src

  #+begin_src c :tangle (eval c)
#ifdef HAVE_CONFIG_H
#include "config.h"
#endif

#ifdef HAVE_STDINT_H
#include <stdint.h>
#elif HAVE_INTTYPES_H
#include <inttypes.h>
#endif

#include <assert.h>
#include <math.h>
#include <stdlib.h>
#include <stdio.h>
#include <string.h>
#include <errno.h>
#include <pthread.h>

#include "qmckl.h"
#include "qmckl_context_private_type.h"
#include "qmckl_memory_private_func.h"

  #+end_src



* Context handling

  The context variable is a handle for the state of the library,
  and is stored in a data structure which can't be seen outside of
  the library. To simplify compatibility with other languages, the
  pointer to the internal data structure is converted into a 64-bit
  signed integer, defined in the ~qmckl_context~ type.
  A value of ~QMCKL_NULL_CONTEXT~ for the context is equivalent to a
 ~NULL~ pointer.

  #+NAME: qmckl_context
  #+begin_src c :comments org :tangle (eval h_type)
typedef int64_t qmckl_context ;
#define QMCKL_NULL_CONTEXT (qmckl_context) 0
  #+end_src

  #+begin_src f90 :comments org :tangle (eval fh_type) :exports none
      integer  , parameter :: qmckl_context = c_int64_t
      integer*8, parameter :: QMCKL_NULL_CONTEXT = 0
  #+end_src

  An immutable context would have required to implement a garbage
  collector. To keep the library simple, we have chosen to implement
  the context as a mutable data structure, so it has to be handled
  with care.

  By convention, in this file ~context~ is a ~qmckl_context~ variable
  and ~ctx~ is a ~qmckl_context_struct*~ pointer.

** Data structure

   #+begin_src c :comments org :tangle (eval h_private_type) :noweb yes :exports none
typedef struct qmckl_context_struct {
 /* -- State of the library -- */

 /* Validity checking */
  uint64_t                 tag;

 /* Numerical precision */
  qmckl_numprec_struct     numprec;

 /* Thread lock */
  int                      lock_count;
  pthread_mutex_t          mutex;

 /* Error handling */
  qmckl_error_struct       error;

 /* Memory allocation */
  qmckl_memory_struct      memory;

 /* Current date */
  uint64_t                 date;

 /* Points */
  qmckl_point_struct         point;

 /* -- Molecular system -- */
  qmckl_nucleus_struct        nucleus;
  qmckl_electron_struct       electron;
  qmckl_ao_basis_struct       ao_basis;
  qmckl_mo_basis_struct       mo_basis;
  qmckl_jastrow_champ_struct  jastrow_champ;
  qmckl_determinant_struct    det;
  qmckl_local_energy_struct   local_energy;

  /* To be implemented:
  ,*/

 /* Pointer to implementation-specific data */

  void* qmckl_extra;

} qmckl_context_struct;
   #+end_src
    
   The qmckl_extra pointer lets the other implementation of the library
   add specific things to the context. For example a GPU implementation
   of QMCkl will need to store the device ID in the context, and this
   can be made by creating a private data structure containing all 
   GPU-specific data, including the device ID.

   A tag is used internally to check if the memory domain pointed
   by a pointer is a valid context. This allows to check that even if
   the pointer associated with a context is non-null, we can still
   verify that it points to the expected data structure.

   #+begin_src c :comments org :tangle (eval h_private_type) :noweb yes :exports none
#define VALID_TAG   0xBEEFFACE
#define INVALID_TAG 0xDEADBEEF
   #+end_src

   The ~qmckl_context_check~ function checks if the domain pointed by
   the pointer is a valid context. It returns the input ~qmckl_context~
   if the context is valid, ~QMCKL_NULL_CONTEXT~ otherwise.

   #+begin_src c :comments org :tangle (eval h_func) :noexport
qmckl_context
qmckl_context_check (const qmckl_context context) ;
   #+end_src

   #+begin_src c :tangle (eval c) :exports none
qmckl_context qmckl_context_check(const qmckl_context context) {

  if (context == QMCKL_NULL_CONTEXT)
    return QMCKL_NULL_CONTEXT;

  const qmckl_context_struct* const ctx = (qmckl_context_struct*) context;

 /* Try to access memory */
  if (ctx->tag != VALID_TAG) {
      return QMCKL_NULL_CONTEXT;
  }

  return context;
}
   #+end_src

   The context keeps a /date/ that allows to check which data needs
   to be recomputed. The date is incremented when the context is touched.

   When a new element is added to the context, the functions
   [[Creation][=qmckl_context_create=]] [[Destroy][=qmckl_context_destroy=]] and [[Copy][=qmckl_context_copy=]]
   should be updated in order to make deep copies.

   When the electron coordinates have changed, the context is touched
   using the following function.

   #+begin_src c :comments org :tangle (eval h_func)
qmckl_exit_code
qmckl_context_touch (const qmckl_context context);
   #+end_src

   This has the effect to increment the date of the context.

   #+begin_src c :tangle (eval c) :exports none
qmckl_exit_code
qmckl_context_touch(const qmckl_context context)
{

  if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT) {
    return qmckl_failwith( context,
                           QMCKL_INVALID_CONTEXT,
                           "qmckl_context_touch",
                           NULL);
  }

  qmckl_context_struct* const ctx = (qmckl_context_struct*) context;

  ctx->date += 1UL;
  ctx->point.date = ctx-> date;
  return QMCKL_SUCCESS;
}
   #+end_src

** Creation

   To create a new context, ~qmckl_context_create()~ should be used.
   - Upon success, it returns a pointer to a new context with the ~qmckl_context~ type
   - It returns ~QMCKL_NULL_CONTEXT~ upon failure to allocate the internal data structure
   - A new context always has all its members initialized with a NULL value

   # Header
   #+begin_src c :comments org :tangle (eval h_func)
qmckl_context qmckl_context_create();
   #+end_src

   # Source
   #+begin_src c :tangle (eval c) :exports none
qmckl_context qmckl_context_create() {

  qmckl_context_struct* const ctx =
    (qmckl_context_struct*) malloc (sizeof(qmckl_context_struct));

  if (ctx == NULL) {
    return QMCKL_NULL_CONTEXT;
  }

 /* Set all pointers and values to NULL */
  {
    memset(ctx, 0, sizeof(qmckl_context_struct));
  }

 /* Initialize lock */
  {
    pthread_mutexattr_t attr;
    int rc;

    rc = pthread_mutexattr_init(&attr);
    assert (rc == 0);

#ifdef PTHREAD_MUTEX_RECURSIVE
    (void) pthread_mutexattr_settype(&attr, PTHREAD_MUTEX_RECURSIVE);
#endif

    rc = pthread_mutex_init ( &(ctx->mutex), &attr);
    assert (rc == 0);

    (void) pthread_mutexattr_destroy(&attr);
  }

 /* Initialize data */
  {
    ctx->tag = VALID_TAG;

    const qmckl_context context = (qmckl_context) ctx;
    assert ( qmckl_context_check(context) != QMCKL_NULL_CONTEXT );

    qmckl_exit_code rc;

    ctx->numprec.precision = QMCKL_DEFAULT_PRECISION;
    ctx->numprec.range = QMCKL_DEFAULT_RANGE;

    rc = qmckl_init_point(context);
    assert (rc == QMCKL_SUCCESS);

    rc = qmckl_init_electron(context);
    assert (rc == QMCKL_SUCCESS);

    rc = qmckl_init_nucleus(context);
    assert (rc == QMCKL_SUCCESS);

    rc = qmckl_init_ao_basis(context);
    assert (rc == QMCKL_SUCCESS);

    rc = qmckl_init_mo_basis(context);
    assert (rc == QMCKL_SUCCESS);

    rc = qmckl_init_determinant(context);
    assert (rc == QMCKL_SUCCESS);

    rc = qmckl_init_jastrow_champ(context);
    assert (rc == QMCKL_SUCCESS);
  }

 /* 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) {
      free(ctx);
      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

   # Fortran interface
   #+begin_src f90 :tangle (eval fh_func) :exports none
  interface
     integer (qmckl_context) function qmckl_context_create() bind(C)
       use, intrinsic :: iso_c_binding
       import
     end function qmckl_context_create
  end interface
   #+end_src

   # Test
   #+begin_src c :comments link :tangle (eval c_test) :exports none
assert( qmckl_context_check(QMCKL_NULL_CONTEXT) ==  QMCKL_NULL_CONTEXT);

qmckl_context context = qmckl_context_create();
assert( context != QMCKL_NULL_CONTEXT );
assert( qmckl_context_check(context) ==  context );
   #+end_src

** Locking

   For thread safety, the context may be locked/unlocked. The lock is
   initialized with the ~PTHREAD_MUTEX_RECURSIVE~ attribute, and the
   number of times the thread has locked it is saved in the
 ~lock_count~ attribute.

   # Header
   #+begin_src c :comments org :tangle (eval h_func)
void qmckl_lock  (qmckl_context context);
void qmckl_unlock(qmckl_context context);
   #+end_src

   # Source
   #+begin_src c :tangle (eval c) :exports none
void qmckl_lock(qmckl_context context) {
  if (context == QMCKL_NULL_CONTEXT)
    return ;
  qmckl_context_struct* const ctx = (qmckl_context_struct*) context;
  errno = 0;
  int rc = pthread_mutex_lock( &(ctx->mutex) );
  if (rc != 0) {
    fprintf(stderr, "DEBUG qmckl_lock:%s\n", strerror(rc) );
    fflush(stderr);
  }
  assert (rc == 0);
  ctx->lock_count += 1;
}

void qmckl_unlock(const qmckl_context context) {
  qmckl_context_struct* const ctx = (qmckl_context_struct*) context;
  int rc = pthread_mutex_unlock( &(ctx->mutex) );
  if (rc != 0) {
    fprintf(stderr, "DEBUG qmckl_unlock:%s\n", strerror(rc) );
    fflush(stderr);
  }
  assert (rc == 0);
  ctx->lock_count -= 1;
}
   #+end_src

** TODO Copy

 ~qmckl_context_copy~ makes a deep copy of a context. It returns
 ~QMCKL_NULL_CONTEXT~ upon failure.

   # Header
   #+begin_src c :comments org :tangle (eval h_func) :exports none
/*
qmckl_context qmckl_context_copy(const qmckl_context context);
*/
   #+end_src


   # Source
   #+begin_src c :tangle (eval c) :exports none
qmckl_context qmckl_context_copy(const qmckl_context context) {

  const qmckl_context checked_context = qmckl_context_check(context);

  if (checked_context == QMCKL_NULL_CONTEXT) {
    return QMCKL_NULL_CONTEXT;
  }

  /*
  qmckl_lock(context);
  {

    const qmckl_context_struct* const old_ctx =
      (qmckl_context_struct*) checked_context;

    qmckl_context_struct* const new_ctx =
      (qmckl_context_struct*) 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 *
    memcpy(new_ctx, old_ctx, sizeof(qmckl_context_struct));

    qmckl_unlock( (qmckl_context) new_ctx );

    return (qmckl_context) new_ctx;
  }
  qmckl_unlock(context);
*/
    return QMCKL_NULL_CONTEXT;
}

   #+end_src

   # Fortran interface
   #+begin_src f90 :tangle (eval fh_func) :exports none
! interface
!    integer (qmckl_context) function qmckl_context_copy(context) bind(C)
!      use, intrinsic :: iso_c_binding
!      import
!      integer (qmckl_context), intent(in), value :: context
!    end function qmckl_context_copy
! end interface
   #+end_src

   # 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

   The context is destroyed with ~qmckl_context_destroy~, leaving the ancestors untouched.
   It frees the context, and returns the previous context.

   # Header
   #+begin_src c :comments org :tangle (eval h_func)
qmckl_exit_code
qmckl_context_destroy (const qmckl_context context);
   #+end_src

    # Source
    #+begin_src c :tangle (eval c) :exports none
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_context_struct* const ctx = (qmckl_context_struct*) context;
  assert (ctx != NULL); /* Shouldn't be possible because the context is valid */

  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();
  }

  free(ctx);

  return QMCKL_SUCCESS;
}
    #+end_src

    # Fortran interface
    #+begin_src f90 :tangle (eval fh_func)  :exports none
  interface
     integer (qmckl_exit_code) function qmckl_context_destroy(context) bind(C)
       use, intrinsic :: iso_c_binding
       import
       integer (qmckl_context), intent(in), value :: context
     end function qmckl_context_destroy
  end interface
    #+end_src

    # Test
    #+begin_src c :tangle (eval c_test)  :exports none
/* Destroy valid context */
assert(qmckl_context_check(context) == context);
assert(qmckl_context_destroy(context) == QMCKL_SUCCESS);

/* Check that context is destroyed  */
#ifndef DEBUG 
assert(qmckl_context_check(context) != context);
assert(qmckl_context_check(context) == QMCKL_NULL_CONTEXT);

/* Destroy invalid context */
assert(qmckl_context_destroy(QMCKL_NULL_CONTEXT) == QMCKL_INVALID_CONTEXT);
#endif
    #+end_src

* End of files                                                     :noexport:


  #+begin_src c :comments link :tangle (eval h_private_type)
#endif
  #+end_src

*** Test
     #+begin_src c :comments link :tangle (eval c_test)
return 0;
}
     #+end_src