(declare
 ;;(unit mailbox)
 ;; requirements
 (disable-interrupts)
 ;; promises
 (strict-types)
 (usual-integrations)
 (no-procedure-checks-for-usual-bindings)
 (inline)
 (local)

 (no-bound-checks)
 (no-procedure-checks-for-usual-bindings)
 (bound-to-procedure
  ##sys#schedule
  ##sys#current-exception-handler)

  (always-bound
    ##sys#current-thread)
 )

(module
 mailbox3
 (
  make-mailbox
  mailbox?
  mailbox-empty?
  mailbox-send!
  mailbox-receive!
  )

(import scheme extras srfi-18)
(import (except chicken add1 sub1))

(: mailbox? (* --> boolean : (struct <mailbox>)))
(define-record-type <mailbox>
  (internal-make-mailbox condition head tail pred)
  mailbox?
  (condition %mailbox-condition)
  (head %mailbox-head %mailbox-head-set!)
  (tail %mailbox-tail %mailbox-tail-set!)
  (pred mailbox-predicate))

(cond-expand
 (never
  (define-inline (mailbox-condition mb) (%mailbox-condition mb))
  (define-inline (mailbox-head mb) (%mailbox-head mb))
  (define-inline (mailbox-head-set! mb v) (%mailbox-head-set! mb v))
  (define-inline (mailbox-tail mb) (%mailbox-tail mb))
  (define-inline (mailbox-tail-set! mb v) (%mailbox-tail-set! mb v)))
 (else
  (define-inline (mailbox-condition mb) (##sys#slot mb 1))
  (define-inline (mailbox-head mb) (##sys#slot mb 2))
  (define-inline (mailbox-head-set! mb v) (##sys#setslot mb 2 v))
  (define-inline (mailbox-tail mb) (##sys#slot mb 3))
  (define-inline (mailbox-tail-set! mb v) (##sys#setslot mb 3 v))
  ))

(: make-mailbox (* --> (struct <mailbox>)))
(define (make-mailbox name)
  (let ((x (cons #f '())))
    (internal-make-mailbox
     (make-condition-variable name) x x #f)))

(: mailbox-empty? ((struct <mailbox>) --> boolean))
(define (mailbox-empty? mb)
  (null? (cdr (mailbox-head mb))))

(: mailbox-number-of-items ((struct <mailbox>) -> fixnum))
(define (mailbox-number-of-items mb)
  (length (cdr (mailbox-head mb))))

(define-inline (%dequeue-message mb)
  (mailbox-head-set! mb (##sys#slot #;cdr (mailbox-head mb) 1))
  (##sys#slot #;car (mailbox-head mb) 0))

(: mailbox-send! ((struct <mailbox>) * -> undefined))
(define (mailbox-send! mailbox obj)
  (let ((p (cons obj '())))
    (##sys#setslot #;set-cdr! (mailbox-tail mailbox) 1 p)
    (mailbox-tail-set! mailbox p))
  #;(condition-variable-signal! (mailbox-condition mailbox))
  (let ((x (mailbox-condition mailbox))) (if (thread? x) (thread-resume! x)))
  )

(: mailbox-receive! ((struct <mailbox>) -> *))
(define (mailbox-receive! mailbox)
  ;;(dbg "receive-message! ~a ~a ~a" (current-thread) (mailbox-name mailbox) (##sys#slot (mailbox-condition mailbox) 2))
  (let loop ()
    (if (null? (##sys#slot (mailbox-head mailbox) 1))
	(begin
	  (##sys#setslot mailbox 1 ##sys#current-thread)
	  (thread-suspend! ##sys#current-thread)
	  
	  (##sys#setslot mailbox 1 #f)
	  (loop))
	(let ((obj (%dequeue-message mailbox)))
	  obj))))

) ;; module mailbox


(module
 test
 (test-run)
 (import scheme chicken srfi-18 extras)
 (import mailbox3)
 
;;(include "bench.scm")
;;----------

(define mb (make-mailbox 'm0))

(define turns 1000000)

(define tw
  (make-thread
   (lambda ()
     (do ((i 0 (add1 i)))
	 ((= i turns))
       (mailbox-send! mb i)
       ;; Must be active for my chicken 4.9.1 .
       ;; Otherwise will run into
       ;; "[panic] out of memory - heap full while resizing - execution terminated"
       ;;
       ;;(if (= (modulo i 1000) 999) (gc #t))
       (thread-yield!)
       ))
   'w))

(define tr
  (make-thread
   (lambda ()
     (do ((i 0 (add1 i)))
	 ((= i turns))
       (mailbox-receive! mb)
       (thread-yield!)
       ))
   'r))


(define (test-run)
(thread-start! tr)
(define t0 (current-milliseconds))
(thread-start! tw)

(thread-join! tr)

(define t1 (current-milliseconds))

(format #t "~a message passings in ~a (~a per ms)\n " turns (- t1 t0) (/ turns (- t1 t0)))
)

 
;;----------

)

;; !!!!!!!!!!!!!!!!
;;  THIS (use srfi-1) is the declaration which makes the effect.
;;  Comment out and it runs for me at about 

(use srfi-1)

(use srfi-18)
(use extras)

(import test)
(test-run)