qmckl/tools/lib.org

# -*- mode: org -*-

* Library of org-mode functions                                    :noexport:
** Defines the name of the current file

   #+NAME: filename
   #+begin_src elisp :tangle no
(file-name-nondirectory (substring buffer-file-name 0 -4))
   #+end_src

** Function to get the value of a property.
 #+NAME: get_value
 #+begin_src elisp :var key="Type"
(org-with-point-at org-babel-current-src-block-location
  (org-entry-get nil key t))
 #+end_src

** Table of function arguments

   #+NAME: test
     | Variable  | Type             | In/Out | Description                                   |
     |-----------+------------------+--------+-----------------------------------------------|
     | ~context~ | ~qmckl_context~  | in     | Global state                                  |
     | ~transa~  | ~char~           | in     | Array ~A~ is ~'N'~: Normal, ~'T'~: Transposed |
     | ~transb~  | ~char~           | in     | Array ~B~ is ~'N'~: Normal, ~'T'~: Transposed |
     | ~m~       | ~int64_t~        | in     | Number of points in the first set             |
     | ~n~       | ~int64_t~        | in     | Number of points in the second set            |
     | ~A~       | ~double[][lda]~  | in     | Array containing the $m \times 3$ matrix $A$  |
     | ~lda~     | ~int64_t~        | in     | Leading dimension of array ~A~                |
     | ~B~       | ~double[][ldb]~  | in     | Array containing the $n \times 3$ matrix $B$  |
     | ~ldb~     | ~int64_t~        | in     | Leading dimension of array ~B~                |
     | ~C~       | ~double[n][ldc]~ | out    | Array containing the $m \times n$ matrix $C$  |
     | ~ldc~     | ~int64_t~        | in     | Leading dimension of array ~C~                |


*** Fortran-C type conversions

    #+NAME:f_of_c
    #+BEGIN_SRC python :var table=test :var rettyp="integer" :var fname=[] :results value :noweb yes :wrap "src f90 :tangle (eval f) :comments org :exports none"
f_of_c_d = { '' : ''
     , 'qmckl_context'   : 'integer (c_int64_t)'
     , 'qmckl_exit_code' : 'integer (c_int32_t)'
     , 'bool'            : 'logical*8'
     , 'int32_t'         : 'integer (c_int32_t)'
     , 'int64_t'         : 'integer (c_int64_t)'
     , 'uint32_t'        : 'integer (c_int32_t)'
     , 'uint64_t'        : 'integer (c_int64_t)'
     , 'float'           : 'real    (c_float  )'
     , 'double'          : 'real    (c_double )'
     , 'char'            : 'character'
 }
    #+END_SRC

    #+NAME:c_of_f
    #+BEGIN_SRC python :var table=test :var rettyp="integer" :var fname=[] :results value :noweb yes :wrap "src f90 :tangle (eval f) :comments org :exports none"
ctypeid_d = { '' : ''
     , 'qmckl_context'   : 'integer(c_int64_t)'
     , 'qmckl_exit_code' : 'integer(c_int32_t)'
     , 'integer'         : 'integer(c_int32_t)'
     , 'integer*8'       : 'integer(c_int64_t)'
     , 'real'            : 'real(c_float)'
     , 'real*8'          : 'real(c_double)'
     , 'character'       : 'character(c_char)'
     , 'character'       : 'character(c_char)'
 }
    #+END_SRC

*** Parse the table

    #+NAME: parse_table
    #+BEGIN_SRC python :results none :noweb yes :exports none
def parse_table(table):
    result = []

    for line in [ [x.replace('~','') for x in y] for y in table]:
        d = { "name"    : line[0],
              "c_type"  : line[1],
              "inout"   : line[2].lower(),
              "comment" : line[3] }

        # Handle inout
        if d["inout"] in ["input", "in"]:
            d["inout"] == "in"
        elif d["inout"] in ["output", "out"]:
            d["inout"] == "out"
        elif d["inout"] in ["input/output", "inout"]:
            d["inout"] == "inout"

        # Find dimensions (replace [] by [*] to get * in Fortran dimensions)
        dims = d["c_type"].replace("[]","[*]").split('[')
        d["rank"] = len(dims) - 1
        if d["rank"] == 0:
            d["dims"] = []
        else:
            d["c_type"] = d["c_type"].split('[')[0].strip()
            d["dims"] = [ x.replace(']','').strip() for x in dims[1:] ]

        result.append(d)

    return result
    #+END_SRC

*** Generates a C header

    #+NAME: generate_c_header
    #+BEGIN_SRC python :var table=test :var rettyp="qmckl_exit_code" :var fname=[] :results drawer :noweb yes :wrap "src c :tangle (eval h_func) :comments org"
<<parse_table>>

results = []
for d in parse_table(table):
    name = d["name"]
    c_type = d["c_type"]

    # Add star for arrays
    if d["rank"] > 0 or d["inout"] in ["out", "inout"]:
        c_type += "*"

    if d["inout"] == "out":
        c_type += " const"

    # Only inputs are const
    if d["inout"] == "in":
        const = "const "
    else:
        const = ""

    results += [ f"      {const}{c_type} {name}" ]

results=',\n'.join(results)
template = f"""{rettyp} {fname} (\n{results} ); """
return template

    #+END_SRC

    #+RESULTS: generate_c_header
    #+begin_src c :tangle (eval h_func) :comments org
    qmckl_exit_code [] (
          const qmckl_context context,
          const char transa,
          const char transb,
          const int64_t m,
          const int64_t n,
          const double* A,
          const int64_t lda,
          const double* B,
          const int64_t ldb,
          double* const C,
          const int64_t ldc );
    #+end_src

*** Generates a C interface to the Fortran function

    #+NAME: generate_c_interface
    #+BEGIN_SRC python :var table=[]   :var rettyp="integer" :var fname=[] :results value :noweb yes :wrap "src f90 :tangle (eval f) :comments org :exports none"
<<c_of_f>>
<<f_of_c>>
<<parse_table>>
d = parse_table(table)

args = ", ".join([ x["name"] for x in d ])
if len(args) > 100:
    args = args.replace(",",""", &
    """)

rettyp_c = ctypeid_d[rettyp.lower()]

results = [ f"{rettyp_c} function {fname} &"
, f"    ({args}) &"
,  "    bind(C) result(info)"
,  ""
,  "  use, intrinsic :: iso_c_binding"
,  "  implicit none"
,  ""
]

for d in parse_table(table):
    f_type = f_of_c_d[d["c_type"]]
    inout  = "intent("+d["inout"]+")"
    name = d["name"]

    # Input scalars are passed by value
    if d["rank"] == 0 and d["inout"] == "in":
        value = ", value"
    else:
        value = "       "

    # Append dimensions to the name
    if d["rank"] == 0:
        dims = ""
    else:
        d["dims"].reverse()
        dims = "(" + ",".join(d["dims"]) + ")"

    results += [ f"  {f_type:20}, {inout:12}{value} :: {name}{dims}" ]

results += [ ""
, f"  {rettyp_c}, external :: {fname}_f"
, f"  info = {fname}_f &"
, f"         ({args})"
,  ""
, f"end function {fname}"
]
results='\n'.join(results)
return results
    #+END_SRC

*** Generates a Fortran interface to the C function

    #+NAME: generate_f_interface
    #+BEGIN_SRC python :var table=test :var rettyp="integer" :var fname=[] :results value :noweb yes :wrap "src f90 :tangle (eval fh_func) :comments org :exports none"
<<c_of_f>>
<<f_of_c>>
<<parse_table>>
d = parse_table(table)

args = ", ".join([ x["name"] for x in d ])

rettyp_c = ctypeid_d[rettyp.lower()]

results = [ f"interface"
, f"  {rettyp_c} function {fname} &"
, f"      ({args}) &"
,  "      bind(C)"
,  "    use, intrinsic :: iso_c_binding"
,  "    import"
,  "    implicit none"
,  ""
]

for d in parse_table(table):
    f_type = f_of_c_d[d["c_type"]]
    inout  = "intent("+d["inout"]+")"
    name = d["name"]

    # Input scalars are passed by value
    if d["rank"] == 0 and d["inout"] == "in":
        value = ", value"
    else:
        value = "       "

    # Append dimensions to the name
    if d["rank"] == 0:
        dims = ""
    else:
        d["dims"].reverse()
        dims = "(" + ",".join(d["dims"]) + ")"

    results += [ f"    {f_type:20}, {inout:12}{value} :: {name}{dims}" ]

results += [ ""
, f"  end function {fname}"
, f"end interface"
]
results='\n'.join(results)
return results
    #+END_SRC



** Creating provide functions

    #+NAME: write_provider_header
    #+BEGIN_SRC python :var group="GROUP" :var data="DATA" :results drawer :noweb yes :wrap "src c :comments org :tangle (eval h_private_func) :noweb yes :export none"
template = "qmckl_exit_code qmckl_provide_{{ group }}_{{ data }}(qmckl_context context);"

msg = template.replace("{{ group }}", group) \
              .replace("{{ data }}", data)
return msg
    #+END_SRC

    #+RESULTS: write_provider_header
    #+begin_src c :comments org :tangle (eval h_private_func) :noweb yes :export none
    qmckl_exit_code qmckl_provide_GROUP_DATA(qmckl_context context);
    #+end_src

    #+NAME: write_provider_pre
    #+BEGIN_SRC python :var group="GROUP" :var data="DATA" :var dimension="DIMENSION" :results drawer :noweb yes :wrap "src c :comments org :tangle (eval c) :noweb yes :export none"
template = """qmckl_exit_code qmckl_provide_{{ group }}_{{ data }}(qmckl_context context)
{

  qmckl_exit_code rc = QMCKL_SUCCESS;

  if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT) {
    return qmckl_failwith( context,
                           QMCKL_INVALID_CONTEXT,
                           "qmckl_provide_{{ group }}_{{ data }}",
                           NULL);
  }

  qmckl_context_struct* const ctx = (qmckl_context_struct*) context;
  assert (ctx != NULL);

  if (!ctx->{{ group }}.provided) {
    return qmckl_failwith( context,
                           QMCKL_NOT_PROVIDED,
                           "qmckl_provide_{{ group }}_{{ data }}",
                           NULL);
  }

 /* Compute if necessary */
  if (ctx->point.date > ctx->{{ group }}.{{ data }}_date) {

    qmckl_memory_info_struct mem_info = qmckl_memory_info_struct_zero;
    mem_info.size = {{ dimension }} * sizeof(double);

    if (ctx->{{ group }}.{{ data }} != NULL) {
      qmckl_memory_info_struct mem_info_test = qmckl_memory_info_struct_zero;
      rc = qmckl_get_malloc_info(context, ctx->{{ group }}.{{ data }}, &mem_info_test);

      /* if rc != QMCKL_SUCCESS, we are maybe in an _inplace function because the
         memory was not allocated with qmckl_malloc */

      if ((rc == QMCKL_SUCCESS) && (mem_info_test.size != mem_info.size)) {
        rc = qmckl_free(context, ctx->{{ group }}.{{ data }});
        assert (rc == QMCKL_SUCCESS);
        ctx->{{ group }}.{{ data }} = NULL;
      }
    }

 /* Allocate array */
    if (ctx->{{ group }}.{{ data }} == NULL) {

      double* {{ data }} = (double*) qmckl_malloc(context, mem_info);

      if ({{ data }} == NULL) {
        return qmckl_failwith( context,
                               QMCKL_ALLOCATION_FAILED,
                               "qmckl_{{ group }}_{{ data }}",
                               NULL);
      }
      ctx->{{ group }}.{{ data }} = {{ data }};
    }

"""

msg = template.replace("{{ group }}", group) \
              .replace("{{ data }}", data) \
              .replace("{{ dimension }}", dimension)
return msg
    #+END_SRC

    #+RESULTS: write_provider_pre
    #+begin_src c :comments org :tangle (eval c) :noweb yes :export none
    qmckl_exit_code qmckl_provide_GROUP_DATA(qmckl_context context)
    {

      qmckl_exit_code rc;

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

      qmckl_context_struct* const ctx = (qmckl_context_struct*) context;
      assert (ctx != NULL);

      if (!ctx->GROUP.provided) {
        return qmckl_failwith( context,
                               QMCKL_NOT_PROVIDED,
                               "qmckl_provide_GROUP_DATA",
                               NULL);
      }

 /* Compute if necessary */
      if (ctx->point.date > ctx->GROUP.DATA_date) {

        if (ctx->point.alloc_date > ctx->GROUP.DATA_date) {
          rc = qmckl_free(context, ctx->GROUP.DATA);
          assert (rc == QMCKL_SUCCESS);
          ctx->GROUP.DATA = NULL;
        }

 /* Allocate array */
        if (ctx->GROUP.DATA == NULL) {

          qmckl_memory_info_struct mem_info = qmckl_memory_info_struct_zero;
          mem_info.size = DIMENSION * sizeof(double);
          double* DATA = (double*) qmckl_malloc(context, mem_info);

          if (DATA == NULL) {
            return qmckl_failwith( context,
                                   QMCKL_ALLOCATION_FAILED,
                                   "qmckl_GROUP_DATA",
                                   NULL);
          }
          ctx->GROUP.DATA = DATA;
        }

    #+end_src

    #+NAME: write_provider_post
    #+BEGIN_SRC python :var group="BASIS" :var data="DATA" :results drawer :noweb yes :wrap "src c :comments org :tangle (eval c) :noweb yes :export none"
template = """    if (rc != QMCKL_SUCCESS) {
      return rc;
    }

    ctx->{{ group }}.{{ data }}_date = ctx->date;
  }

  return QMCKL_SUCCESS;
}
"""

msg = template.replace("{{ group }}", group) \
              .replace("{{ data }}", data)

return msg
    #+END_SRC

    #+RESULTS: write_provider_post
    #+begin_src c :comments org :tangle (eval c) :noweb yes :export none
        if (rc != QMCKL_SUCCESS) {
          return rc;
        }

        ctx->BASIS.DATA_date = ctx->date;
      }

      return QMCKL_SUCCESS;
    }
    #+end_src