% -*- mode: Noweb; noweb-code-mode: c-mode -*- %

\ifx\nointro\undefined
This document contains the interface and implementation of the mechanism that allows {\PAL} procedures to call C functions. 
\fi

% ----------------------------------------------------------------------------
\interface{[[ccall]] : Calling C Functions from {\PAL}}
% ----------------------------------------------------------------------------

This is the interface for the C calling mechanism, which is complicated by
its inability to completely subvert the C type system. 

Clients need only know this: they must register all C functions they wish
for {\PAL} code to be able to call, and that they may only register functions
that have C type signatures that have been properly registered with this
calling mechanism. 

<<ccall.h>>=
#ifndef _CCALL_H
#define _CCALL_H

#include "table.h"
#include "stack.h"

#define C_FUNC_CALLER   "caller"
#define C_FUNC_POINTER  "f"
#define C_FUNC_NAME     "name"

<<type definitions>>
<<global variable declarations>>
<<function prototypes>>

#endif /* _CCALL_H */
@ 

% ----------------------------------------------------------------------------
\subsection{Type Definitions}
% ----------------------------------------------------------------------------

We implement ``C callers'' to aid in the C calling mechanism. 

<<type definitions>>=
typedef vptr (*c_caller)(vptr, void (*) (void));
@

% ----------------------------------------------------------------------------
\subsection{Global Data Structures}
% ----------------------------------------------------------------------------

Registered signatures and functions are kept stored in global Lua tables. 

<<global variable declarations>>=
extern table c_sig_table;
extern table c_func_table;
@ 

<<global variable definitions>>=
table        c_sig_table;
table        c_func_table;
@ 

% ----------------------------------------------------------------------------
\subsection{C Function Registration}
% ----------------------------------------------------------------------------

In order to call C functions from {\PAL} code in the interpreter, the C 
functions must be registered with the interpreter. 
We export a function [[register_c_func]] that may be used by a client's
runtime system to register a C function with the interpreter. 
A signature ([[sig]]) of a C function is a string containing a comma-delimited
list of the C types of the function's arguments, followed by a colon and then
the function's return type. 
An explicit [[void]] should be used in the case of nullary functions, and
[[pointer]] should be used in place of any pointers. 
For example, the signature for a C function that takes two [[int]]s and
returns a [[double]] would be [["int,int:double"]]. 

<<function prototypes>>=
void register_c_func(const char *name, void (*f) (void), const char *sig);
@ 

Note that C functions may \emph{not} be registered with the interpreter as
varargs functions (although they could be restricted to a fixed number of 
arguments and thus registered)---with the exception of [[printf]]. 
Because of the extreme usefulness of [[printf]], we provide this one varargs
C function, but it must be specially registered. 
To register [[printf]], a call must be made to [[register_c_func]] with a
[[sig]] of simply [["printf"]]. 

Internally, we use separate helper functions for each type of C function
signature we are willing to call from a {\PAL} program. 
To register these callers, we use the [[register_c_sig]] helper function. 
 
<<internal function prototypes>>=
static void register_c_sig(const char *sig, c_caller caller);
@

To internally register all known C signatures, we provide [[init_c_sigs]]. 

<<function prototypes>>=
void init_c_sigs(void);
@ 

Note that C functions may only be registered with this calling mechanism if
their C type signatures have first been internally registered by this
module. 

% ----------------------------------------------------------------------------
\implementation{Calling C Functions from {\PAL}}
% ----------------------------------------------------------------------------

<<ccall.c>>=
#include "ccall.h"

#include <assert.h>
#include <lua.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <setjmp.h>
#include "label.h"
#include "lualink.h"
#include "interp.h"
#include "types.h"

<<macro definitions>>
<<macro-generated function prototypes>>

<<global variable definitions>>

<<internal function prototypes>>
<<function definitions>>
@

% ----------------------------------------------------------------------------
\subsection{C Function Registration}
% ----------------------------------------------------------------------------

We provide the exported function [[register_c_func]] to allow clients to
register C funtions with the interpreter for use in programs (with [[call]]s). 
Each time [[register_c_func]] is called, we make two entries in the global
table [[c_func_table]]. 
We associate the function's name (as a string) with a number in the global
exports table, and we associate the number with a table that contains the
function's signature and pointer in the C function table. 

<<function definitions>>=
void register_c_func(const char *name, void (*f) (void), const char *sig) {
  static unsigned int id = 1;

  void      *caller;
  lua_State *L = c_sig_table. L;
  assert(c_sig_table. L == c_func_table. L);

  lua_pushtable(L, c_func_table);

  /* create a new table for the C function */
  lua_newtable(L);

  lua_pushstring(L, C_FUNC_CALLER);
  <<push caller pointer atop Lua stack>>
  lua_settable(L, -3);

  lua_pushstring(L, C_FUNC_POINTER);
  lua_pushusertag(L, (void *) f, lua_c_func_tag);
  lua_settable(L, -3);

  lua_pushstring(L, C_FUNC_NAME);
  lua_pushstring(L, name);
  lua_settable(L, -3);

  /* associate C function's table with id in c_func_table */
  lua_rawseti(L, -2, id);

  /* associate id with name of function in c_func_table */
  /*
  lua_pushstring(L, name);
  lua_pushnumber(L, (double) id);
  lua_settable(L, -3);
  */
 
  lua_pop(L, 1);

  /* also get a CMM_label placeholder for this C function */
  {
    CMM_label *lbl;

    lua_pushtable(L, exports_table);
    lua_pushstring(L, name);
    lua_pushvalue(L, -1);
    lua_gettable(L, -3);
    if (! lua_isnil(L, -1)) {
       lua_pop(L, 3); /* pop nil, string copy, table */
       fprintf(stderr, "cannot register C function \"%s\"; "
                       "a label of that name already exists\n", name);
       exit(1);
    }
    lua_pop(L, 1); /* pop nil */

    lbl               = CMM_label_new();
    lbl->ty           = CMM_CFUNCTION;
    lbl->lbl.cfunc_id = id;

    lua_pushusertag(L, (void *) lbl, lua_CMM_label_tag);
    lua_settable(L, -3);
    lua_pop(L, 1); /* pop table */
  }

  id++;
}
@
<<push caller pointer atop Lua stack>>=
  lua_pushtable(L, c_sig_table);
  lua_pushstring(L, sig);
  lua_gettable(L, -2);
  if (! lua_isuserdata(L, -1) ||
      lua_tag(L, -1) ! = lua_c_sig_tag ||
      (caller = lua_touserdata(L, -1)) == NULL)
  {
    fprintf(stderr, "cannot register C function with unsupported type "
                    "signature; was given type signature [%s]\n", sig);
    exit(1);
  }
  lua_insert(L, -2); /* swap positions of caller pointer and sig table */
  lua_pop(L, 1);     /* pop the sig table */
@

% ----------------------------------------------------------------------------
\subsection{C Signature Registration}
% ----------------------------------------------------------------------------

Internally, we use the [[register_c_sig]] function to register C function
signatures (add a pointer to the signature's caller implementation to the Lua
signature table). 

<<function definitions>>=
static void register_c_sig(const char *sig, c_caller caller) {
  lua_State *L = c_sig_table. L;

  lua_pushtable(L, c_sig_table);
  lua_pushstring(L, sig);
  lua_pushusertag(L, (void *) caller, lua_c_sig_tag);
  lua_settable(L, -3);
  lua_pop(L, 1);  /* pop table */
}
@ 

We use a series of iterated macro calls to register the signatures we know
about. 

<<function definitions>>=
void init_c_sigs(void) {
  <<register C function signatures>>

  /* export c_sig_table to Lua */
  table_exporttolua(lua_interpreter, &c_sig_table , "c_sigs" );

  /* export c_func_table to Lua */
  table_exporttolua(lua_interpreter, &c_func_table, "c_funcs");
}
@ 
<<register C function signatures>>=
ITERATE_NULLARY_C_CALLERS(NULLARY_C_CALLER_REGISTRATION)
ITERATE_UNARY_C_CALLERS(UNARY_C_CALLER_REGISTRATION)
ITERATE_BINARY_C_CALLERS(BINARY_C_CALLER_REGISTRATION)
ITERATE_TERNARY_C_CALLERS(TERNARY_C_CALLER_REGISTRATION)
ITERATE_FOURARY_C_CALLERS(FOURARY_C_CALLER_REGISTRATION)
register_c_sig("printf" , c_caller_printf );
register_c_sig("fprintf", c_caller_fprintf);
@

We must also provide prototypes for the macro-generated functions that implement the registration of a C signature. 

<<macro-generated function prototypes>>=
ITERATE_NULLARY_C_CALLERS(NULLARY_C_CALLER_PROTOTYPE)
ITERATE_UNARY_C_CALLERS(UNARY_C_CALLER_PROTOTYPE)
ITERATE_BINARY_C_CALLERS(BINARY_C_CALLER_PROTOTYPE)
ITERATE_TERNARY_C_CALLERS(TERNARY_C_CALLER_PROTOTYPE)
ITERATE_FOURARY_C_CALLERS(FOURARY_C_CALLER_PROTOTYPE)
vptr c_caller_printf  (vptr arguments, void (*f) (void));
vptr c_caller_fprintf (vptr arguments, void (*f) (void));
@ 

% ----------------------------------------------------------------------------
\subsection{C Call Mechanism Implementation}
% ----------------------------------------------------------------------------

We use a number of macros to implement our C calling mechanism. 
Due to constraints of the C type system, we are required to specially handle C
functions with different numbers of arguments; for example, we define a family
of macros for unary C functions, a family of macros for binary C functions, 
etc. 
For each of these macro families, we define four macros: one to generate a C
function that implements a C caller, one to generate a function prototype for
this function, one to register the C caller function with the interpreter, and
finally one to call each of the previous three macros on all supported C
function signatures within the family. 
The idea here is this: for each different type of C function that we want to
be able to call from {\PAL}, we generate a C caller that will take a
[[void *]] function pointer, cast it to the correct signature, and call it
with the correct number of arguments. 
Note also that the C caller takes care of pushing and popping the correct
number of values from the argument-passing stack when calling the C function
and returning values from it. 
In order to deal with functions that return no value (are of return type 
[[void]]), we hack through with macros [[RETURNS_VAL]] and [[RETURNS_VOID]];
 they essentially allow conditional text replacement in the C preprocessor. 

The idea is that a macro is handed off either [[RETURNS_VAL]] or 
[[RETURNS_VOID]]. 
The macro may then pass 2 arguments to whichever of these two macros it
receives; this macro call will be replaced by the first of the 2 arguments if
[[RETURNS_VAL]] was the macro passed in, and it will be replaced by the second
of the 2 arguments if [[RETURNS_VOID]] was the macro passed in. 

<<macro definitions>>=
#define RETURNS_VAL(X, Y)  X
#define RETURNS_VOID(X, Y) Y
@ 

[[ITERATE_UNARY_C_CALLERS]], [[ITERATE_BINARY_C_CALLERS]], and company are the
iterator macros mentioned above; each takes a macro name as its only argument
and calls this macro with the C function signatures its family supports. 

This is where additional supported C signatures should be added, if desired. 

<<macro definitions>>=
typedef void *pointer;

#define ITERATE_NULLARY_C_CALLERS(F) \
F(void   , RETURNS_VOID) \
F(int    , RETURNS_VAL ) \
F(pointer, RETURNS_VAL )

#define ITERATE_UNARY_C_CALLERS(F) \
F(u_int16 , u_int16 , RETURNS_VAL ) \
F(u_int32 , u_int32 , RETURNS_VAL ) \
F(int     , int     , RETURNS_VAL ) \
F(int     , pointer , RETURNS_VAL ) \
F(unsigned, pointer , RETURNS_VAL ) \
F(pointer , unsigned, RETURNS_VAL ) \
F(pointer , int     , RETURNS_VAL ) \
F(pointer , pointer , RETURNS_VAL ) \
F(jmp_buf , int     , RETURNS_VAL ) \
\
F(int     , void    , RETURNS_VOID) \
F(char    , void    , RETURNS_VOID) \
F(unsigned, void    , RETURNS_VOID) \
F(pointer , void    , RETURNS_VOID)

#define ITERATE_BINARY_C_CALLERS(F) \
F(int     , int     , int    , RETURNS_VAL ) \
F(int     , pointer , pointer, RETURNS_VAL ) \
F(pointer , pointer , int    , RETURNS_VAL ) \
F(pointer , pointer , pointer, RETURNS_VAL ) \
\
F(int     , int     , void   , RETURNS_VOID) \
F(pointer , int     , void   , RETURNS_VOID) \
F(pointer , pointer , void   , RETURNS_VOID)

#define ITERATE_TERNARY_C_CALLERS(F) \
F(pointer , unsigned, unsigned, pointer, RETURNS_VAL  ) \
F(pointer , int     , int     , void   , RETURNS_VOID ) \
F(pointer , pointer , int     , void   , RETURNS_VOID )

#define ITERATE_FOURARY_C_CALLERS(F) \
F(pointer , pointer , unsigned, pointer, pointer, RETURNS_VAL)
@ 

All C callers take two arguments, an argument-passing stack and a [[void *]]
function pointer, and return a new pointer to the argument-passing stack. 

<<macro definitions>>=
#define NULLARY_C_CALLER_PROTOTYPE(RETTY, RETURNS) \
vptr c_caller_void_##RETTY (vptr arguments, void (*f) (void));

#define UNARY_C_CALLER_PROTOTYPE(A, RETTY, RETURNS) \
vptr c_caller_##A##_##RETTY (vptr arguments, void (*f) (void));

#define BINARY_C_CALLER_PROTOTYPE(A, B, RETTY, RETURNS) \
vptr c_caller_##A##_##B##_##RETTY (vptr arguments, void (*f) (void));

#define TERNARY_C_CALLER_PROTOTYPE(A, B, C, RETTY, RETURNS) \
vptr c_caller_##A##_##B##_##C##_##RETTY (vptr arguments, void (*f) (void));

#define FOURARY_C_CALLER_PROTOTYPE(A, B, C, D, RETTY, RETURNS) \
vptr c_caller_##A##_##B##_##C##_##D##_##RETTY (vptr arguments, void (*f) (void));
@ 

Registration of C callers involves a simple call to [[register_c_sig]]; this
associates a C function signature with a C caller implementation. 

<<macro definitions>>=
#define NULLARY_C_CALLER_REGISTRATION(RETTY, RETURNS) \
register_c_sig("void:" #RETTY, c_caller_void_##RETTY);

#define UNARY_C_CALLER_REGISTRATION(A, RETTY, RETURNS) \
register_c_sig(#A ":" #RETTY, c_caller_##A##_##RETTY);

#define BINARY_C_CALLER_REGISTRATION(A, B, RETTY, RETURNS) \
register_c_sig(#A "," #B ":" #RETTY, \
               c_caller_##A##_##B##_##RETTY);

#define TERNARY_C_CALLER_REGISTRATION(A, B, C, RETTY, RETURNS) \
register_c_sig(#A "," #B "," #C ":" #RETTY, \
               c_caller_##A##_##B##_##C##_##RETTY);

#define FOURARY_C_CALLER_REGISTRATION(A, B, C, D, RETTY, RETURNS) \
register_c_sig(#A "," #B "," #C "," #D ":" #RETTY, \
               c_caller_##A##_##B##_##C##_##D##_##RETTY);
@ 

The actual implementations of the C callers are simple functions that pop the
correct number of arguments from the argument-passing stack, call the
indicated C function with these arguments, push the C call's return values
atop the argument-passing stack, and return a new pointer to the
argument-passing stack. 

<<macro definitions>>=
#define NULLARY_C_CALLER(RETTY, RETURNS) \
vptr c_caller_void_##RETTY (vptr arguments, void (*f) (void)) { \
  { \
  RETTY (*f_ty) (void) = (RETTY (*) (void)) f; \
  RETURNS(RETTY retval =, (void)) f_ty(); \
  RETURNS(arguments[0] = to_CMM_value((unsigned) retval, 8*sizeof(RETTY));, ) \
  return arguments; \
} }
#define UNARY_C_CALLER(ARGTY, RETTY, RETURNS) \
vptr c_caller_##ARGTY##_##RETTY (vptr arguments, void (*f) (void)) { \
  { \
  RETTY (*f_ty) (ARGTY) = (RETTY (*) (ARGTY)) f; \
  RETURNS(RETTY retval =, (void)) f_ty(VIEW(arguments[0], ARGTY)); \
  RETURNS(arguments[0] = to_CMM_value((unsigned) retval, 8*sizeof(RETTY));, ) \
  return arguments; \
} }
#define BINARY_C_CALLER(ARGATY, ARGBTY, RETTY, RETURNS) \
vptr c_caller_##ARGATY##_##ARGBTY##_##RETTY (vptr arguments,void(*f)(void)) { \
  { \
  RETTY (*f_ty) (ARGATY, ARGBTY) = (RETTY (*) (ARGATY, ARGBTY)) f; \
  RETURNS(RETTY retval =, (void)) \
      f_ty(VIEW(arguments[0], ARGATY), \
           VIEW(arguments[1], ARGBTY)); \
  RETURNS(arguments[0] = to_CMM_value((unsigned) retval, 8*sizeof(RETTY));, ) \
  return arguments; \
} }
#define TERNARY_C_CALLER(ARGATY, ARGBTY, ARGCTY, RETTY, RETURNS) \
vptr c_caller_##ARGATY##_##ARGBTY##_##ARGCTY##_##RETTY \
     (vptr arguments, void (*f) (void)) \
{ \
  { \
  RETTY (*f_ty) (ARGATY, ARGBTY, ARGCTY) = \
                     (RETTY (*) (ARGATY, ARGBTY, ARGCTY)) f; \
  RETURNS(RETTY retval =, (void)) \
      f_ty(VIEW(arguments[0], ARGATY), \
           VIEW(arguments[1], ARGBTY), \
           VIEW(arguments[2], ARGCTY)); \
  RETURNS(arguments[0] = to_CMM_value((unsigned) retval, 8*sizeof(RETTY));, ) \
  return arguments; \
} }
#define FOURARY_C_CALLER(ARGATY, ARGBTY, ARGCTY, ARGDTY, RETTY, RETURNS) \
vptr c_caller_##ARGATY##_##ARGBTY##_##ARGCTY##_##ARGDTY##_##RETTY \
     (vptr arguments, void (*f) (void)) \
{ \
  { \
  RETTY (*f_ty) (ARGATY, ARGBTY, ARGCTY, ARGDTY) = \
                     (RETTY (*) (ARGATY, ARGBTY, ARGCTY, ARGDTY)) f; \
  RETURNS(RETTY retval =, (void)) \
      f_ty(VIEW(arguments[0], ARGATY), \
           VIEW(arguments[1], ARGBTY), \
           VIEW(arguments[2], ARGCTY), \
           VIEW(arguments[3], ARGDTY)); \
  RETURNS(arguments[0] = to_CMM_value((unsigned) retval, 8*sizeof(RETTY));, ) \
  return arguments; \
} }
@

Last but not least, we actually generate the implementations of the C callers
with a call to each of the iterators. 

<<function definitions>>=
ITERATE_NULLARY_C_CALLERS(NULLARY_C_CALLER)
ITERATE_UNARY_C_CALLERS(UNARY_C_CALLER)
ITERATE_BINARY_C_CALLERS(BINARY_C_CALLER)
ITERATE_TERNARY_C_CALLERS(TERNARY_C_CALLER)
ITERATE_FOURARY_C_CALLERS(FOURARY_C_CALLER)
@ 

Our ``[[printf]]'' caller is a hack to allow a varargs printing function. 
It breaks apart the format string and makes a number of successive calls
to the real [[printf]], as necessary. 

To register this [[printf]], a client would call [[register_c_func]]
with a user-picked name (likely [[printf]]) and the special signature
[["printf"]]. 

<<function definitions>>=
vptr c_caller_print  (FILE *fp, vptr arguments, void (*f) (void)) {
  char *fmt = (char *) arguments[0].ptr;
  int   nextarg = 1;

  for (;;) {
    while (*fmt ! = '%' && *fmt ! = '\0') { putchar(*(fmt++)); }
    if (*fmt == '\0') return arguments;

    {
      char   temp;
      int    offset;
      value *the_arg = arguments + (nextarg++);

      offset = (int) strcspn(fmt + 1, "diouxXeEfFgGaAcsCSpn%") + 2;
      temp   = fmt[offset];

      fmt[offset] = '\0';
      switch(fmt[offset - 1]) {
      case '%':
        putchar('%');
        nextarg--;
        break;
      case 'f':
        fprintf(fp, fmt, *(VIEW(the_arg, float *)));
        break;
      case 'x': case 'X':
      case 's':
        fprintf(fp, fmt, *(VIEW(the_arg, void **)));
        break;
      default:
        fprintf(fp, fmt, *(VIEW(the_arg, unsigned *)));
      }
      fmt[offset]  = temp;
      fmt         += offset;
    }
  }
}

vptr c_caller_printf (vptr arguments, void (*f) (void)) {
  return c_caller_print(stdout, arguments, f);
}

vptr c_caller_fprintf (vptr arguments, void (*f) (void)) {
  return c_caller_print((FILE *) arguments[0].ptr, arguments + 1, f);
}
@ 
