(use extras data-structures)
;; Make sure we "use" enough, as failing so lead to slow globals before.
(use srfi-1)
(use llrb-tree)
(import foreign)

(foreign-declare
 #<<EOF
void C_ccall C_make_vector(C_word c, C_word *av)
{
  C_word av2[2], *v=av+1;
  av2[0] = av[1];
  *v = C_VECTOR_TYPE | (c-2);
  av2[1] = (C_word) v;
  C_do_apply(2, av2);
}

void C_ccall C_apply_vector(C_word c, C_word *av)
{
  C_word *av2, k, f, *v, sz;

  k=av[1]; f=av[2], v=(C_word *)(av[3]); sz=C_header_size(v);
  if(!C_demand(2+sz))
    C_save_and_reclaim((void *)C_apply_vector, c, av);
  av2=C_alloc((2+sz) *sizeof(C_word));
  av2[0]=f;
  av2[1]=k;
  C_memcpy(av2+2, v+1, sz * sizeof(C_word));
  C_do_apply(2+sz, av2);
}

EOF
)

(cond-expand
 (compiling (define turns 1000000))
 (else (define turns 1000)))

(define rounds 4)

(module
 driver
 *
 (import scheme chicken extras)

 (define (run N message thunk)
    (gc #t)
   (let ((t0 (current-milliseconds)))
     (do ((i 0 (add1 i)))
	 ((eq? i N)
	  (format (current-error-port) "~a: ~a per ms\n" message (/ N (- (current-milliseconds) t0))))
       (thunk))))

 (define (rerun M N message thunk)
   (do ((i 0 (add1 i)))
       ((eq? i M))
     (run N message thunk)))

 (define (yes) #t)

 )

(module
 call-conv
 *
 (import (except scheme vector) chicken foreign)

 (define (callmv producer interception consumer)
   (let ((intercepted (producer)))
     (interception intercepted)
     (consumer intercepted)))

 (define (callmv-list producer interception consumer)
   (let ((intercepted (call-with-values producer list)))
     (interception intercepted)
     (apply consumer intercepted)))

 (define vector (##core#primitive "C_make_vector"))

 (define argvector vector)
 
 (define apply-vector/unsafe (##core#primitive "C_apply_vector"))

 (define (apply-vector proc v)
   (##sys#check-vector v 'apply-vector)
   (apply-vector/unsafe proc v))

 (define (callmv-argvector producer interception consumer)
   (let ((intercepted (call-with-values producer vector)))
     (interception intercepted)
     (apply-vector/unsafe consumer intercepted)))

 (define (callmv-lambda producer interception consumer)
   (let ((intercepted (producer)))
     (interception intercepted)
     (intercepted consumer)))

 (define (argv-dynamic-wind before thunk after)
   (before)
   (set! ##sys#dynamic-winds (cons (cons before after) ##sys#dynamic-winds))
   (let ((results (##sys#call-with-values thunk vector)))
     (set! ##sys#dynamic-winds (##sys#slot ##sys#dynamic-winds 1))
     (after)
     (apply-vector/unsafe ##sys#values results)))

 (define (say-yes) (lambda (whom) (whom #t)))
 
(define (ten-values)
  (values 0 1 2 3 4 5 6 7 8 9))

(define (send-ten-values)
  (lambda (whom)
    (whom 0 1 2 3 4 5 6 7 8 9)))

(define (take-ten-values v0 v1 v2 v3 v4 v5 v6 v7 v8 v9) #t)

 )

(import driver call-conv)

(define av argvector)

;;(repl) (exit 0)

(rerun rounds turns "pass single value"
       (lambda () (callmv yes identity identity)))

(rerun rounds turns "pass single value via list"
       (lambda () (callmv-list yes identity identity)))

(rerun
 rounds turns "pass single value via argvector"
 (lambda () (callmv-argvector yes identity identity)))

(rerun rounds turns "pass single value via lambda"
       (lambda () (callmv-lambda say-yes identity identity)))

(rerun rounds turns "pass ten values via list"
       (lambda () (callmv-list ten-values identity take-ten-values)))

(rerun
 rounds turns "pass ten values via argvector"
 (lambda () (callmv-argvector ten-values identity take-ten-values)))

(rerun rounds turns "pass ten values via lambda"
       (lambda () (callmv-lambda send-ten-values identity take-ten-values)))

(rerun rounds (/ turns 10) "dynamic-wind 10 values"
       (lambda () (call-with-values (lambda () (dynamic-wind yes ten-values yes)) take-ten-values)))

(rerun rounds (/ turns 10) "argv dynamic-wind 10 values"
       (lambda () (call-with-values (lambda () (argv-dynamic-wind yes ten-values yes)) take-ten-values)))