[Chicken-users] the (##sys#call-host) FFI trick

[Daniel B. Faken]

Hello,

  I've been trying out the trick we discussed 
(http://lists.gnu.org/archive/html/chicken-users/2005-07/msg00077.html), 
but having confusing issues.  I just thought I would report on these..

I've attached a "torture test" for this method, below, which resembles my 
code pretty well (sans massive infrastructure).  "Unfortunately", this torture 
code works fine, whereas my program crashes...

The only hint I've been able to find is that my version of 'cb1' (in 
x.scm) crashes when calling its continuation ..
..except when I do (require-extension debug), in which case it crashes 
just before 'foo-fn' (AKA rootsvals[300]) returns from C_callback() (i.e. 
the final message is never printed by do_chicken_callack()).

OTOH, if I remove the "1||" from do_chicken_callback(), and remove the 
(##sys#call-host) (and use an entry-pt for evalcode() too)  -- i.e. if I 
use an entry-point instead of a callback -- my code works fine.

Any thoughts?  :)

Oh, one more thing I tried: setting chicken_is_running=1, made no 
difference.

cheers,
Daniel
------------------------------------
;;;; x.scm
;
; to test the (##sys#call-host) always-use-callbacks method.

;; all these declarations/inclusions are just to mimic my setup
;; - in my testing, their absence makes no difference.

(declare (uses eval extras srfi-1 srfi-4 srfi-13)
                  (run-time-macros)
                  (usual-integrations))

(include "chicken-more-macros")

(include "chicken-default-entry-points")

(require-extension debug)

#>
extern C_word rootvals[602];
<#

(define set-foo-fn
  (foreign-lambda* void
                        ([scheme-object x])
                        "C_mutate(rootvals+300,x);"))

(define cb1
  (foreign-safe-lambda* double
                        ([double x]) "return((double)x + 100.0*(double)x);") )

(define-external (sscriptedSPU_testCallback (c-string msg)) void
  (print "The SScriptedSPU says: " msg))
(define dbf#safe-execute
  (let ([open-output-string open-output-string]
        [get-output-string get-output-string] 
        [print-error-message print-error-message]
        [exn? (condition-predicate 'exn)]
        [exn-message (condition-property-accessor 'exn 'message)] )
       (lambda (thunk)
      (set! sscriptedSPU_eval_status #t)
      (handle-exceptions exn
          (let ([o (if (exn? exn) (exn-message exn) exn)])
            (print "dbf#safe-execute ---> error: " o)
            (set! sscriptedSPU_eval_error o)
            (set! sscriptedSPU_eval_status #f) 
            #f)
        (thunk) ) ) ) )

(define (dbf#safe-eval x)
  ;; this fn-body copied from the chicken_eval_string_to_string() fn
  ;; todo: correct?
  (dbf#safe-execute
   (lambda ()
     (let ([o (open-output-string)]
           [i (open-input-string x)])
       (write (eval (read i)) o)
       (get-output-string o) ) ) )
  )
(define-external
  (evalcode (nonnull-c-string x)) c-string
  (dbf#safe-eval x) )

(##sys#call-host)

--------------------------------
/* y.c */
#include <stdio.h>
#include <stdlib.h>

#include "chicken.h"

#define crDebug printf
#define crWarning printf

static C_word do_chicken_callback(C_word sfn, int argc, C_word *argv)
{
  int i;
  C_word result;

  crDebug("%s ==> scheme (argc=%d)..",
          (CHICKEN_is_running() ?"calling-back":"entering"), argc);
 fflush(stdout);
  if(1||CHICKEN_is_running()) {
    for(i=0; i<argc; i++) C_save(argv[i]);
    result = C_callback(sfn, argc);
  } else {
    C_word first, last, current, *list;
    int status;
    char errbuf[512];

    /* equiv. to C_list(&list, argc, argv[0], argv[1], ...) */
    list = C_alloc(C_SIZEOF_LIST(argc));
    first = C_SCHEME_END_OF_LIST;
    last = C_SCHEME_UNDEFINED;
    for(i=0; i<argc; i++) {
      current = C_pair(&list, argv[i], C_SCHEME_END_OF_LIST);
      if(last != C_SCHEME_UNDEFINED)
        C_set_block_item(last, 1, current);
      else
        first = current;
      last = current;
    }
    CHICKEN_apply(sfn, first, &result, &status);
    if(status != 1) {
      CHICKEN_get_error_message(errbuf, 511);
      crWarning("in do_chicken_callback(), after CHICKEN_apply(), 
status=%d ===> %s.",
                status, errbuf);
 fflush(stdout);
    }
  }
  crDebug("..done calling back into scheme..");
 fflush(stdout);
  return result;
}

C_word rootvals[602];

extern void sscriptedSPU_testCallback(char *);

static void part1(void)
{
 CHICKEN_run(NULL, NULL, NULL, C_toplevel);
 /* pop continuation, unless we call an entry-point this should be ok, */
 C_restore;
}
static void part2(void)
{
  C_word *roots[602];
  int i;

  for(i=0; i<602; i++) {
    rootvals[i] = C_SCHEME_FALSE;
    roots[i] = rootvals + i;
  }
 C_gc_protect(roots, 602);
}
static void part3(void)
{
  extern char *evalcode(char *);

  evalcode("(set-foo-fn  (lambda (x y)   (print \"---->\" x \",\" y)   
(print \"cb1 -> \" (cb1 x))   (+ y (cb1 x))) )");

  crWarning("..done - foo=%sa function.. ",
            (C_header_bits(rootvals[300])==C_CLOSURE_TYPE ?"":"NOT "));
  fflush(stdout);
  sscriptedSPU_testCallback("Hello");
}
static void part5(void)
{
  extern char *evalcode(char *);

  evalcode("(load \"loadme.scm\")");

  crWarning("..done - foo=%sa function.. ",
            (C_header_bits(rootvals[300])==C_CLOSURE_TYPE ?"":"NOT "));
  fflush(stdout);
}
static void part4(void)
{
  C_word *mem = C_alloc(2*C_SIZEOF_FLONUM);
  C_word argv[10];

  argv[0] = C_flonum(&mem, 42);
  argv[1] = C_flonum(&mem, 10000);
  do_chicken_callback(rootvals[300], 2, argv);
}

int main()
{
  part1();
  part2();
  part3();
  part4();
  part4();
  part5();
  part4();
  part3();
  part4();
  printf("\nFinished.\n");
  return 0;
}

-------------------------------
;;;; loadme.scm
(set-foo-fn
 (lambda (x y)
   (print "---->" y "," x)
   (print "cb1 -> " (cb1 x))
   (+ x (cb1 x))) )

---------------------------------
# compiling & running:
dskfaken:~/tst%csc -e x.scm y.c -kv && ./x
/home/dbfaken/lib/chicken/bin/chicken x.scm -output-file x.c -quiet
Warning: local assignment to unused variable `sscriptedSPU_eval_error' may 
be unintended
Warning: local assignment to unused variable `sscriptedSPU_eval_status' 
may be unintended
gcc y.c -o y.o -g -DHAVE_CHICKEN_CONFIG_H -DC_EMBEDDED -c 
-DC_NO_PIC_NO_DLL -I /home/dbfaken/lib/chicken/include
gcc x.c -o x.o -g -DHAVE_CHICKEN_CONFIG_H -DC_EMBEDDED -c 
-DC_NO_PIC_NO_DLL -I /home/dbfaken/lib/chicken/include
gcc -o x y.o x.o -lchicken -L/home/dbfaken/lib/chicken/lib 
-Wl,-R/home/dbfaken/lib/chicken/lib -ldl -lpcre -lm  -ldl -lpcre
..done - foo=a function.. The SScriptedSPU says: Hello
entering ==> scheme (argc=2)..---->42.0,10000.0
cb1 -> 4242.0
..done calling back into scheme..entering ==> scheme 
(argc=2)..---->42.0,10000.0
cb1 -> 4242.0
..done calling back into scheme....done - foo=a function.. entering ==> 
scheme (argc=2)..---->10000.0,42.0
cb1 -> 4242.0
..done calling back into scheme....done - foo=a function.. The 
SScriptedSPU says: Hello
entering ==> scheme (argc=2)..---->42.0,10000.0
cb1 -> 4242.0
..done calling back into scheme..
Finished.