Experimental Scheme2C

bench.scm

(import (rnrs) (core base) (sagittarius dynamic-module) (time)
	(sagittarius control))

(define ht
  (let ((ht (make-eqv-hashtable)))
    (dotimes (i 1000 ht)
      (hashtable-set! ht i (number->string i 16)))))

(print "Scheme implementation")
(time (dotimes (i 1000)
	(hashtable-map (lambda (k v) (cons k v)) ht)))

(load-dynamic-module "hashtable-map")

(print "C implementation")
(time (dotimes (i 1000)
	(hashtable-map (lambda (k v) (cons k v)) ht)))

#|
Scheme implementation

;;  (dotimes (i 1000) (hashtable-map kons ht))
;;  0.220276 real    0.220165 user    0.000000 sys
C implementation

;;  (dotimes (i 1000) (hashtable-map kons ht))
;;  0.207873 real    0.207748 user    0.000000 sys

Hmmm, not really useful
|#

hashtable-map.c

#include <sagittarius.h>
#define LIBSAGITTARIUS_BODY
#include <sagittarius/extend.h>

static SgObject find_binding(SgObject lib, SgObject name)
{
  SgObject o = Sg_FindBinding(lib, name, SG_UNBOUND);
  if (SG_UNBOUNDP(o)) {
    o = Sg_Apply3(&Sg_GenericUnboundVariable, name, lib, name);
    if (Sg_ConditionP(o)) {
      Sg_Raise(o, FALSE);
    }
  }
  return SG_GLOC_GET(SG_GLOC(o));
}

static SgObject vm_apply1(SgObject proc, SgObject arg1)
{
  if (SG_SUBRP(proc)) {
    /* TODO argument adjust */
    SgObject r;
    SG_CALL_SUBR1(r, proc, arg1);
    return r;
  } else {
    return Sg_VMApply1(proc, arg1);
  }
}


static SgObject vm_apply2(SgObject proc, SgObject arg1, SgObject arg2)
{
  if (SG_SUBRP(proc)) {
    /* TODO argument adjust */
    SgObject r;
    SG_CALL_SUBR2(r, proc, arg1, arg2);
    return r;
  } else {
    return Sg_VMApply2(proc, arg1, arg2);
  }
}

static SgObject sym_user = SG_UNDEF;

static SgObject procedureP = SG_UNBOUND;
static SgObject hashtableP = SG_UNBOUND;
static SgObject hashtable_iter = SG_UNBOUND;

static SgObject embed_1(SgObject result, void **SG_FP);
static SgObject jump_1(SgObject result, void **SG_FP);

static SgObject jump_1(SgObject result, void **SG_FP)
{
  SG_FP[4] = Sg_Cons(result, SG_FP[4]);
  Sg_VMPushCC(embed_1, SG_FP, 5);
  return vm_apply1(SG_FP[2], SG_FP[3]);
}

static SgObject embed_1(SgObject result, void **SG_FP)
{
  SgVM *vm = Sg_VM();
  SgObject k, v;
  k = result;
  if (vm->valuesCount != 2) {
    SgObject assertion_violation =      
      find_binding(sym_user, SG_INTERN("assertion-violation"));
    Sg_Apply3(assertion_violation, SG_INTERN("hashtable-map"),
	      SG_MAKE_STRING("unexpected values count"),
	      result);
  }
  v = SG_VALUES_REF(vm, 0);
  if (SG_EQ(k, SG_FP[3])) {
    return SG_FP[4];
  } else {
    Sg_VMPushCC(jump_1, SG_FP, 5);
    return vm_apply2(SG_FP[0], k, v);
  }
}

static SgObject let_1(SgObject result, void **SG_FP)
{
  SgObject itr = result;
  SgObject eof = Sg_Cons(SG_TRUE, SG_TRUE);
  void *data[5];
  data[0] = SG_FP[0];
  data[1] = SG_FP[1];
  data[2] = itr;
  data[3] = eof;
  data[4] = SG_NIL;
  Sg_VMPushCC(embed_1, data, 5);
  return vm_apply1(itr, eof);
}

static SgObject if_2(SgObject result, void **SG_FP)
{
  if (SG_FALSEP(result)) {
    SgObject assertion_violation =      
      find_binding(sym_user, SG_INTERN("assertion-violation"));
    SgObject wrong_type_argument_message =
      find_binding(sym_user, SG_INTERN("wrong-type-argument-message"));
    Sg_Apply2(assertion_violation, SG_INTERN("hashtable-map"),
	      Sg_Apply3(wrong_type_argument_message, 
			SG_MAKE_STRING("hashtable"),
			SG_FP[1], SG_MAKE_INT(2)));
  }
  Sg_VMPushCC(let_1, SG_FP, 2);
  return vm_apply1(hashtable_iter, SG_FP[1]);
}

static SgObject if_1(SgObject result, void **SG_FP)
{
  if (SG_FALSEP(result)) {
    SgObject assertion_violation =      
      find_binding(sym_user, SG_INTERN("assertion-violation"));
    SgObject wrong_type_argument_message =
      find_binding(sym_user, SG_INTERN("wrong-type-argument-message"));
    Sg_Apply2(assertion_violation, SG_INTERN("hashtable-map"),
	      Sg_Apply3(wrong_type_argument_message,
			SG_MAKE_STRING("procedure"),
			SG_FP[0], SG_MAKE_INT(1)));
  }
 /* next k */
  Sg_VMPushCC(if_2, SG_FP, 2);
  return vm_apply1(hashtableP, SG_FP[1]);
}

static SgObject hashtable_map(SgObject *SG_FP, int SG_ARGC, void *data_)
{
  Sg_VMPushCC(if_1, SG_FP, SG_ARGC);
  return vm_apply1(procedureP, SG_FP[0]);
}

static SG_DEFINE_SUBR(hashtable_map__STUB, 2, 0, hashtable_map, SG_FALSE, NULL);


static SgObject kons(SgObject *SG_FP, int SG_ARGC, void *data_)
{
  return Sg_Cons(SG_FP[0], SG_FP[1]);
}

static SG_DEFINE_SUBR(kons__STUB, 2, 0, kons, SG_FALSE, NULL);

SG_EXTENSION_ENTRY void CDECL Sg_Init_hashtable_map()
{
  SgLibrary *lib = SG_LIBRARY(Sg_FindLibrary(SG_INTERN("user"), FALSE));
  SG_INIT_EXTENSION(hashtable_map);
  Sg_InsertBinding(lib, SG_INTERN("hashtable-map"), &hashtable_map__STUB);
  SG_PROCEDURE_NAME(&hashtable_map__STUB) = SG_INTERN("hashtable-map");

  Sg_InsertBinding(lib, SG_INTERN("kons"), &kons__STUB);
  SG_PROCEDURE_NAME(&hashtable_map__STUB) = SG_INTERN("kons");

  sym_user = SG_INTERN("user");
  procedureP = find_binding(sym_user, SG_INTERN("procedure?"));
  hashtableP = find_binding(sym_user, SG_INTERN("hashtable?"));
  hashtable_iter = find_binding(sym_user, SG_INTERN("%hashtable-iter"));
}

/*
gcc -O3 --share -fPIC -o hashtable-map.so hashtable-map.c `sagittarius-config -I -L -l`   
 */