(declare
 ;; (unsafe)
 ;;
 ;; This code MUST be compiled with interrupts disabled for atomicity.
 (disable-interrupts)

 (no-argc-checks)
 (no-bound-checks)
 (no-procedure-checks)
 (safe-globals)
 (specialize)
)

;; Helper procedures which are atomic wrt. srfi-18 threads and (if so
;; documented) signal handlers.

(use srfi-18 srfi-69)

(module
 hopefully-intern-atomics
 *
 (import scheme chicken srfi-18 srfi-69)
 (import (only data-structures identity))
 
 (define new-transaction-identifier
   (let ((n 1))
     (lambda ()
       (let ((r n))
	 (set! n (fx+ n 2))
	 (assert (not (eq? n 1)))	; overflow not yet handled
	 r))))

 (define-record stmtnx id refs ht owner)

 (: %stmtnx-id ((struct stmtnx) --> fixnum))
 (: %stmtnx-id-set! ((struct stmtnx) fixnum --> *))
 (: %stmtnx-refs ((struct stmtnx) --> (list-of (struct stmref))))
 (: %stmtnx-refs-set! ((struct stmtnx) (list-of (struct stmref)) --> *))
 (: %stmtnx-ht ((struct stmtnx) --> *))
 (: %stmtnx-ht-set! ((struct stmtnx) * --> *))
 (: %stmtnx-owner ((struct stmtnx) --> (struct thread)))
 (cond-expand
  (chicken
   (define-inline (%stmtnx-id cell) (##sys#slot cell 1))
   (define-inline (%stmtnx-id-set! cell v) (##sys#setislot cell 1 v))
   (define-inline (%stmtnx-refs cell) (##sys#slot cell 2))
   (define-inline (%stmtnx-refs-set! cell v) (##sys#setislot cell 2 v))
   (define-inline (%stmtnx-ht cell) (##sys#slot cell 3))
   (define-inline (%stmtnx-ht-set! cell v) (##sys#setislot cell 3 v))
   (define-inline (%stmtnx-owner cell) (##sys#slot cell 4))
   )
  (else
   (define-inline (%stmtnx-id cell) (stmtnx-id cell))
   (define-inline (%stmtnx-id-set! cell v) (stmtnx-id-set! cell v))
   (define-inline (%stmtnx-refs cell) (stmtnx-refs cell))
   (define-inline (%stmtnx-refs-set! cell v) (stmtnx-refs-set! cell v))
   (define-inline (%stmtnx-ht cell) (stmtnx-ht cell))
   (define-inline (%stmtnx-ht-set! cell v) (stmtnx-ht-set! cell v))
   (define-inline (%stmtnx-owner cell) (stmtnx-owner cell))
   ))


 (define %current-transaction
   (make-parameter #f))

 (define (current-transaction)
   (and-let*
    ((ct (%current-transaction))
     ((eq? (%stmtnx-owner ct) (current-thread))))
    ct))

 ;; #### Work around Chicken hash tables not supporting arbitrary
 ;; objects as keys.
 (cond-expand
  ;; This would be the code to use if we could use mutable objects as
  ;; table keys.  BEWARE: Using the chicken specific extension to
  ;; srfi-69 where hash-table-update! returns the new value (instead
  ;; of an undefined value.)
  (hash-table-hash-mutable-keys
   (define (make-object-table) (make-hash-table eq?))
   (define object-table-update! hash-table-update!)
   )
  ;; Objects (atomic records are the only type of objects allowed here
  ;; anyway) MUST be known to comply with the convention that the
  ;; first slot hold the hash key.
  (notyet)
  ;; Fallback using hash tables.
  (else
   (define (make-object-table)
     (make-hash-table eq? (lambda (x bound) (fxmod (##sys#slot x 1) bound))))
   (define object-table-update! hash-table-update!)
   ))

 (define (obj+slot-table-update! t obj slot default)
   (let ((st (object-table-update!
	      ;; maybe we should use llrb (faster, less memory hungry)
	      t obj identity (lambda () (make-hash-table eq?)))))
     (hash-table-update! st slot identity default)))
 
 (define (new-transaction . x)
   (make-stmtnx
    (new-transaction-identifier)
    '()
    (and (pair? x) (car x) (make-object-table))
    (current-thread)))

 (define (transaction-extend! t r)
   (if (even? (%stmtnx-id t))
       (error "transaction already closed"))
   (if (eq? (%stmtnx-owner t) (current-thread))
       (%stmtnx-refs-set! t (cons r (%stmtnx-refs t)))
       (error "transaction owned by thread" (%stmtnx-owner t))))

 (define (transaction-reset! t)
   (stmtnx-refs-set! t '())
   (%stmtnx-ht-set! t (and (%stmtnx-ht t) #t)))
 (define (transaction-close! t)
   (%stmtnx-id-set! t (add1 (stmtnx-id t)))
   (transaction-reset! t))

 (define (transaction-reopen! t)
   (assert (even? (stmtnx-id t)))
   (%stmtnx-id-set! t (sub1 (%stmtnx-id t)))
   (if (%stmtnx-ht t)
       (%stmtnx-ht-set! t (make-object-table))))

 ;;(define (slot-ref obj n) ...)

 ;; Named after the Clojure equivalent for atoms.
 (: compare-and-set-slot! (* fixnum * * -> *))
 (define (compare-and-set-slot! obj n old new)
   (assert (not (eq? old new)))		; contract
   (let ((current (##sys#slot obj n)))
     (if (eq? old current)
	 (begin
	   (##sys#setslot obj n new)
	   new)
	 current)))

 (: compare-and-set-islot! (* fixnum * * -> *))
 (define (compare-and-set-islot! obj n old new)
   (assert (not (eq? old new)))		; contract
   (let ((current (##sys#slot obj n)))
     (if (eq? old current)
	 (begin
	   (##sys#setislot obj n new)
	   new)
	 current)))
 
 )