(declare
 ;; (unsafe)
 ;;
 ;; This code should be able to run with interrupts enabled.  But
 ;; that's quite a slowdown. (And hardly fair when comparing
 ;; performance to srfi-18 primitives which are compiled with
 ;; interrupts disabled too.
 ;;
 ;; Note however: with interrupts disabled the commit code could omit
 ;; one traversal of the list.  FIXME: Is there a feature to test for
 ;; so we can conditionally skip these section?
 (disable-interrupts)

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

(include "hopefully-intern-atomics.scm")

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

(use srfi-1)
;; This use clause disturbs development
;;
;;(use hopefully-intern-atomics)

(module
 hopefully-intern
 *
 (import scheme chicken srfi-18)
 (import hopefully-intern-atomics)
 (import srfi-1)
 (import (only extras random format))

 (define (dbg l v)
   (format (current-error-port) "HD ~a: ~a\n" l v) v)

 (define-record atomic-box hash tag value)

 (define (box value) (make-atomic-box (random 16777216) 2 value))
 (define unbox atomic-box-value)
 (define (box-if/tag! obj old new) (compare-and-set-islot! obj 2 old new)) ; private

 (define-inline (past-txn-begin? txn tag)
   (> tag (stmtnx-id txn)))
 (define-syntax txnclosed? (syntax-rules () ((_ x) (even? x))))
 (define-syntax unhold! (syntax-rules () ((_ x i l) (##sys#setislot x i l))))
 (define-syntax onhold? (syntax-rules () ((_ x) (odd? x))))
 (define-syntax update!
   (syntax-rules ()
     ((_ x i l n)
      (begin
	(##sys#setslot x (add1 i) n)
	(unhold! x i l)))))
 
 (define (box-swap! success box proc . args) ; maybe make success optional
   (ensure atomic-box? box)
   (let ((lock-tag (new-transaction-identifier)))
     (let loop ((old-tag (##sys#slot box 2)))
       (if (onhold? old-tag)
	   (begin
	     (thread-yield!)
	     (loop (##sys#slot box 2)))
	   (let* ((old (##sys#slot box 3))
		  (new (cond
			((null? args) (proc old))
			(else (apply proc old args)))))
	     (if (eq? old new)
		 old
		 (let ((now (compare-and-set-islot! box 2 old-tag lock-tag)))
		   (if (eq? now lock-tag)
		       (begin
			 (update! box 2 (+ old-tag 2) new)
			 (success old new))
		       (loop now)))))))))

 (define-record stmref #;transaction source slot tag val)

;; (: %stmref-transaction ((struct stmref) --> (struct stmtnx)))
 (: %stmref-source ((struct stmref) --> *))
 (: %stmref-slot ((struct stmref) --> fixnum))
 (: %stmref-tag ((struct stmref) --> fixnum))
 (: %stmref-tag-set! ((struct stmref) fixnum --> *))
 (: %stmref-val ((struct stmref) --> *))
 (: %stmref-val-set! ((struct stmref) * --> *))
 (cond-expand
  (chicken
   ;;(define-inline (%stmref-transaction cell) (##sys#slot cell 1))
   (define-inline (%stmref-source cell) (##sys#slot cell #;2 1))
   (define-inline (%stmref-slot cell) (##sys#slot cell #;3 2))
   (define-inline (%stmref-tag cell) (##sys#slot cell #;4 3))
   (define-inline (%stmref-tag-set! cell v) (##sys#setislot cell #;4 3 v))
   (define-inline (%stmref-val cell) (##sys#slot cell #;5 4))
   (define-inline (%stmref-val-set! cell v) (##sys#setislot cell #;5 4 v))
   )
  (else
   ;;(define-inline (%stmref-transaction cell) (stmref-transaction cell))
   (define-inline (%stmref-source cell) (stmref-source cell))
   (define-inline (%stmref-slot cell) (stmref-slot cell))
   (define-inline (%stmref-tag cell) (stmref-tag cell))
   (define-inline (%stmref-tag-set! cell v) (stmref-tag-set! cell v))
   (define-inline (%stmref-val cell) (stmref-val cell))
   (define-inline (%stmref-val-set! cell v) (stmref-val-set! cell v))
   ))

 (: make-tslot-ref ((struct stmtnx) * fixnum --> (struct stmref)))
 (define (make-tslot-ref transaction source slot) ;; oddly named internal unsafe
   ;; (ensure fixnum? slot)
   (define (make-cell)
     (let* ((tag (##sys#slot source slot))
	    (cell (make-stmref #;transaction source slot tag (##sys#slot source (add1 slot)))))
       (transaction-extend! transaction cell)
       (assert (eq? (##sys#slot source slot) tag))
       cell))
   (let ((ht (stmtnx-ht transaction)))
     (if ht
	 (obj+slot-table-update! ht source slot make-cell)
	 (make-cell))))

 ;; Obsolete
 (define (make-box-ref transaction box)
   (make-tslot-ref transaction box 1))

 (: cell-ref ((struct stmref) -> *))	; Note: pure, since it may be mutated.
 (define (cell-ref cell)
   (ensure stmref? cell)
   #;(if (eq? (%stmref-tag cell) 0)
       (let ((source (%stmref-source cell)) (slot (%stmref-slot cell)))
	 (let loop ((tag (##sys#slot source slot)))
	   (cond
	    ((onhold? tag)
	     (thread-yield!)
	     (loop (##sys#slot source slot)))
	    ;; TBD?: check being overtaken?
	    (else
	     (let* ((val (##sys#slot source (add1 slot)))
		    (now (##sys#slot source slot)))
	       (if (eq? now tag)
		   (begin
		     (%stmref-val-set! cell val)
		     (transaction-extend! (%stmref-transaction cell) cell)
		     (%stmref-tag-set! cell tag)))))))))
   ;; Mabe check that the transaction is not yet completed.
   ;;
   ;; Questionable: also test that the value was not updated elsewhere?
   ;;
   ;; Finally return cell value.
   (%stmref-val cell))

 (: alter! ((struct stmref) * -> *))
 (define (alter! cell val)
   (ensure stmref? cell)
   (%stmref-val-set! cell val)
   #;(let ((source (%stmref-source cell)) (slot (%stmref-slot cell)))
     (%stmref-val-set! cell val)
     (let ((old (##sys#slot source (add1 slot))))
       (unless
	(eq? val old)
	#;(let ((transaction (%stmref-transaction cell)))
	  (if (not (stmtnx-ht transaction)) ;; handle duplicate refs
	      ;; Order list last write first.  Duplicates (even in
	      ;; different cells) ignored during commit.
	      (transaction-extend! transaction cell)))
	#;(if (eq? (%stmref-tag cell) 0)
	    (begin
	      (transaction-extend! (%stmref-transaction cell) cell)
	      (%stmref-tag-set! cell (##sys#slot source slot)))
	    (let ((transaction (%stmref-transaction cell)))
	      (if (not (stmtnx-ht transaction)) ;; handle duplicate refs
		  ;; Order list last write first.  Duplicates (even in
		  ;; different cells) ignored during commit.
		  (transaction-extend! transaction cell))))
	(%stmref-val-set! cell val)))))

 (: @ ((struct stmref) --> *))
 (define @ (getter-with-setter cell-ref alter!))

 (: transaction-commit! ((struct stmtnx) -> (or false (struct stmtnx))))
 (define (transaction-commit! transaction)
   #;(if (txnclosed? (%stmtnx-id transaction))
       (error "transaction already closed"))
   #;(if (not (eq? (stmtnx-owner transaction) (current-thread)))
       (error "transaction owned by thread" (stmtnx-owner transaction)))
   (let ((lock-tag (stmtnx-id transaction)))
     (let loop ((refs (stmtnx-refs transaction))
		(dirty '()))
       (if (null? refs)
	   (begin
	     (for-each
	      (lambda (x)
		(let ((source (%stmref-source x)) (slot (%stmref-slot x)))
		  (update! source slot (+ (%stmref-tag x) 2) (%stmref-val x))))
	      dirty)
	     (transaction-close! transaction)
	     transaction)
	   (let ((x (car refs)))
	     (let ((source (%stmref-source x)) (slot (%stmref-slot x)))
	       (let ((tag (##sys#slot source slot)))
		 (cond
		  ((eq? tag lock-tag)
		   ;; Referenced in this transaction later (list is
		   ;; reverse access order).  Ignore prior ref.
		   (loop (cdr refs) dirty))
		  ((not (eq? tag (%stmref-tag x)))
		   ;; Conflict. Undo dirty tagging.
		   (cond-expand
		    ((and (not debug) no-dirty-tagging))
		    (else
		     (for-each
		      (lambda (x) (##sys#setislot (%stmref-source x) (%stmref-slot x) (%stmref-tag x)))
		      dirty)))
		   (transaction-close! transaction) ;; or should this be done elsewhere?
		   #f)
		  ((eq? (##sys#slot source (add1 slot)) (%stmref-val x))
		   ;; Unchanged, no dirty tagging, no updates.
		   (loop (cdr refs) dirty))
		  (else
		   (cond-expand
		    ((and (not debug) no-dirty-tagging))
		    (else
		     (##sys#setislot source slot lock-tag)))
		   (loop (cdr refs) (cons x dirty)))))))))))

 (: with-current-transaction ((procedure () . *) -> . *))
 (define (with-current-transaction thunk)
   (apply
    values
    (if (current-transaction)
	(thunk)
	(let ((tnx (new-transaction #t)))
	  (parameterize
	   ((%current-transaction tnx))
	   (let loop ()
	     (receive
	      results (thunk)
	      (if (transaction-commit! tnx)
		  results
		  (begin
		    (transaction-reopen! tnx)
		    (loop))))))))))

 (: call-with-current-transaction/values ((procedure () . *) &rest boolean -> . *))
 (define (call-with-transaction/values proc . heavy?)
   (let ((tnx (new-transaction (and (pair? heavy?) (car heavy?)))))
     (let loop ()
       (receive
	results (proc tnx)
	(if (transaction-commit! tnx)
	    (apply values results)
	    (begin
	      (transaction-reopen! tnx)
	      (loop)))))))

 (: call-with-current-transaction ((procedure () . *) &rest boolean -> *))
 (define (call-with-transaction proc . heavy?)
   (let ((tnx (new-transaction (and (pair? heavy?) (car heavy?)))))
     (let loop ((x (proc tnx)))
       (if (transaction-commit! tnx)
	   x
	   (begin
	     (transaction-reopen! tnx)
	     (loop (proc tnx)))))))

 )

(module
 hopefully-good
 (cell-ref @ alter! call-with-transaction call-with-transaction/values
  (syntax: define-a-record))
 (import scheme chicken hopefully-intern srfi-1)
 (define-syntax define-a-record
   (##sys#er-transformer
    (lambda (x r c)
      (##sys#check-syntax 'define-a-record x '(_ symbol . _))
      (let* ((name (cadr x))
	     (slots (cddr x))
	     (prefix (symbol->string name))
	     (%define (r 'define))
	     (%setter (r 'setter))
	     (%getter-with-setter (r 'getter-with-setter))
	     (%fold-right (r 'fold-right))
	     (%current-transaction (r 'current-transaction))
	     (%make-cell (r 'make-tslot-ref))
	     (%cell-ref (r 'cell-ref))
	     (%random (r 'random))
	     (slotnames slots))
	`(##core#begin
	  (,%define ,name (##sys#make-structure 'atomic-record ',name))
	  (,%define 
	   ,(string->symbol (string-append "make-" prefix))
	   (##core#lambda
	    ,slotnames
	    (##sys#make-structure (##core#quote ,name) (random 16777216) ,@(fold-right (lambda (s i) (cons 2 (cons s i))) '() slotnames))))
	  (,%define
	   ,(string->symbol (string-append prefix "?"))
	   (##core#lambda (x) (##sys#structure? x (##core#quote ,name))) )
	  ,@(let mapslots ((slots slots) (i 2))
	      (if (eq? slots '())
		  slots
		  (let* ((slotname (symbol->string (car slots)))
			 (gett (string->symbol (string-append prefix "-" slotname "-tag")))
			 (getv (string->symbol (string-append prefix "-" slotname)))
			 (getr (string->symbol (string-append prefix "-" slotname "-ref"))))
		    (cons
		     `(##core#begin
		       (,%define
			,gett
			(##core#lambda 
			 (x)
			 (##core#check (##sys#check-structure x (##core#quote ,name)))
			 (##sys#block-ref x ,i) ))
		       (,%define
			,getr
			(##core#lambda
			 (x transaction)
			 (##core#check (##sys#check-structure x (##core#quote ,name)))
			 (,%make-cell transaction x ,i) ))
		       (,%define
			,getv
			(##core#lambda 
			 (x . transaction)
			 (##core#check (##sys#check-structure x (##core#quote ,name)))
			 (if transaction
			     (,%cell-ref (,%make-cell (##sys#slot transaction 0) x ,i))
			     (##sys#block-ref x ,(add1 i))) ) ) )
		     (mapslots (##sys#slot slots 1) (fx+ i 2)) ) ) ) ) ) ) ) ) )

 )

(module
 hopefully-current
 (with-current-transaction
  (syntax: define-ac-record current-transaction))
 (reexport (only hopefully-intern with-current-transaction))
 (reexport (only hopefully-intern-atomics current-transaction))
 (import scheme chicken hopefully-intern)

 ;;  Shamelessly stolen from chicken-syntax

 (define-syntax define-ac-record
 (##sys#er-transformer
  (lambda (x r c)
    (##sys#check-syntax 'define-a-record x '(_ symbol . _))
    (let* ((name (cadr x))
	   (slots (cddr x))
	   (prefix (symbol->string name))
	   (%define (r 'define))
	   (%setter (r 'setter))
	   (%getter-with-setter (r 'getter-with-setter))
	   (%fold-right (r 'fold-right))
	   (%current-transaction (r 'current-transaction))
	   (%make-cell (r 'make-tslot-ref))
	   (%cell-ref (r 'cell-ref))
	   (%alter! (r 'alter!))
	   (%random (r 'random))
	   (%fx+ (r 'fx+))
	   (slotnames slots))
      `(##core#begin
	(,%define ,name (##sys#make-structure 'atomic-record ',name))
	(,%define 
	 ,(string->symbol (string-append "make-" prefix))
	 (##core#lambda
	  ,slotnames
	  (##sys#make-structure (##core#quote ,name) (random 16777216) ,@(fold-right (lambda (s i) (cons 2 (cons s i))) '() slotnames))))
	(,%define
	 ,(string->symbol (string-append prefix "?"))
	 (##core#lambda (x) (##sys#structure? x (##core#quote ,name))) )
	,@(let mapslots ((slots slots) (i 2))
	    (if (eq? slots '())
		slots
		(let* ((slotname (symbol->string (car slots)))
		       (gett (string->symbol (string-append prefix "-" slotname "-tag")))
		       (getv (string->symbol (string-append prefix "-" slotname)))
		       (getr (string->symbol (string-append prefix "-" slotname "-ref")))
		       (setv (string->symbol (string-append prefix "-" slotname "-set!"))))
		  (cons
		   `(##core#begin
		     (,%define
		      ,gett
		      (##core#lambda 
		       (x)
		       (##core#check (##sys#check-structure x (##core#quote ,name)))
		       (##sys#block-ref x ,i) ))
		     (,%define
		      ,getr
		      (##core#lambda
		       (x transaction)
		       (##core#check (##sys#check-structure x (##core#quote ,name)))
		       (,%make-cell transaction x ,i) ))
		     (,%define
		      ,setv
		      (##core#lambda
		       (x val)
		       (##core#check (##sys#check-structure x (##core#quote ,name)))
		       (let ((transaction (,%current-transaction)))
			 (if transaction
			     (,%alter! (,%make-cell transaction x ,i) val)
			     (##core#begin
			      (##sys#block-set! x ,i (,%fx+ (##sys#block-ref x ,i) 2))
			      (##sys#block-set! x ,(add1 i) val))))))
		     (,%define
		      ,getv
		      (,%getter-with-setter
		       (##core#lambda 
			(x)
			(##core#check (##sys#check-structure x (##core#quote ,name)))
			(let ((transaction (,%current-transaction)))
			  (if transaction
			      (,%cell-ref (,%make-cell transaction x ,i))
			      (##sys#block-ref x ,(add1 i)))) )
		       ,setv) ) )
		   (mapslots (##sys#slot slots 1) (fx+ i 2)) ) ) ) ) ) ) ) ) )
 
 )

(module
 hopefully
 *
 (reexport hopefully-good)
 )