;;;; synch.scm
;;;; Kon Lovett, Mar '06

(module synch (;export
  ;;
  make-object/synch
  object?/synch
  ;;
  synch
  synch-with
  call/synch
  call-with/synch
  apply/synch
  apply-with/synch
  let/synch
  set!/synch
  synch/lock
  synch/unlock
  object/synch
  record/synch
  record-synch/lock
  record-synch/unlock
  ;;
  %synch
  %synch-with
  %call/synch
  %call-with/synch
  %apply/synch
  %apply-with/synch
  %let/synch
  %set!/synch
  %synch/lock
  %synch/unlock
  %object/synch
  %record/synch
  %record-synch/lock
  %record-synch/unlock)

  (import scheme
          (only chicken define-for-syntax optional
                        void unless warning gensym dynamic-wind)
          (only data-structures conc constantly)
          (only srfi-18 thread? make-mutex mutex? mutex-specific mutex-specific-set!
                        mutex-lock! mutex-unlock! mutex-state) )

  (require-library data-structures srfi-18)

;;;

(define-for-syntax (recmuxnam nam)
  (string->symbol (conc nam #\- 'mutex)) )

;;;

(define (make-object/synch obj #!optional (name '(synchobj)))
  (let ((mutex (make-mutex (if (pair? name) (gensym (car name)) name))))
    (mutex-specific-set! mutex obj)
    mutex ) )

(define object?/synch
  (let ((tpred (constantly #t)))
    (lambda (obj #!optional (pred tpred))
      (and (mutex? obj)
           (let ((ms (mutex-specific obj)))
             (and (not (eq? (void) ms))
                  (pred ms)) ) ) ) ) )

;;; Protected

(define-syntax synch
	(syntax-rules ()
		((_ ?mtx ?body ...)
    	(let ((mtx ?mtx))
        (dynamic-wind
          (lambda () (mutex-lock! mtx))
          (lambda () ?body ...)
          (lambda () (mutex-unlock! mtx)) ) ) ) ) )

(define-syntax synch-with
  (lambda (form r c)
    (##sys#check-syntax 'synch-with form '(_ _ variable . #(_ 0)))
    (let (($dynamic-wind (r 'dynamic-wind))
          ($let (r 'let))
          ($lambda (r 'lambda))
          ($mutex-unlock! (r 'mutex-unlock!))
          ($mutex-specific (r 'mutex-specific))
          ($mutex-lock! (r 'mutex-lock!))
          (mtxvar (r (gensym))))
      (let ((?mtx (cadr form)) (?var (caddr form)) (?body (cdddr form)))
		    `(,$let ((,mtxvar ,?mtx))
           (,$let ((,?var (,$mutex-specific ,mtxvar)))
             (,$dynamic-wind
               (,$lambda () (,$mutex-lock! ,mtxvar))
					     (,$lambda () ,@?body)
					     (,$lambda () (,$mutex-unlock! ,mtxvar)) ) ) ) ) ) ) )

(define-syntax call/synch
	(syntax-rules ()
		((_ ?mtx ?proc ?arg0 ...)
		  (let ((mtx ?mtx))
			  (dynamic-wind
				  (lambda () (mutex-lock! mtx))
				  (lambda () (?proc ?arg0 ...))
				  (lambda () (mutex-unlock! mtx)) ) ) ) ) )

(define-syntax call-with/synch
	(syntax-rules ()
		((_ ?mtx ?proc ?arg0 ...)
		  (let ((mtx ?mtx))
			  (dynamic-wind
				  (lambda () (mutex-lock! mtx))
				  (lambda () (?proc (mutex-specific mtx) ?arg0 ...))
				  (lambda () (mutex-unlock! mtx)) ) ) ) ) )

(define-syntax apply/synch
	(syntax-rules ()
		((_ ?mtx ?proc ?arg0 ...)
		  (let ((mtx ?mtx))
			  (dynamic-wind
				  (lambda () (mutex-lock! mtx))
				  (lambda () (apply ?proc ?arg0 ...))
				  (lambda () (mutex-unlock! mtx)) ) ) ) ) )

(define-syntax apply-with/synch
	(syntax-rules ()
		((_ ?mtx ?proc ?arg0 ...)
		  (let ((mtx ?mtx))
			  (dynamic-wind
				  (lambda () (mutex-lock! mtx))
				  (lambda () (apply ?proc (mutex-specific mtx) ?arg0 ...))
				  (lambda () (mutex-unlock! mtx)) ) ) ) ) )

(define-syntax let/synch
  (lambda (form r c)
    (##sys#check-syntax 'let/synch form '(_ list . _))
    (let (($synch-with (r 'synch-with)))
      (let ((?body (cddr form)))
        (car
          (let loop ((?bnds (cadr form)))
            (if (not (null? ?bnds))
                (let ((bnd (car ?bnds)))
                  (##sys#check-syntax 'let/synch bnd '(variable _))
                  `((,$synch-with ,(cadr bnd) ,(car bnd) ,@(loop (cdr ?bnds)))) )
                ?body ) ) ) ) ) ) )

(define-syntax set!/synch
  (lambda (form r c)
    (##sys#check-syntax 'set!/synch form '(_ pair . _))
    (let (($synch-with (r 'synch-with))
          ($mutex-specific (r 'mutex-specific))
          ($mutex-specific-set! (r 'mutex-specific-set!))
          ($begin (r 'begin)))
      (let ((?bnd (cadr form)) (?body (cddr form)))
        (let ((?var (car ?bnd)) (?mtx (cadr ?bnd)))
          `(,$synch-with ,?mtx ,?var
             (,$mutex-specific-set! ,?mtx (,$begin ,@?body))
             (,$mutex-specific ,?mtx) ) ) ) ) ) )

(define-syntax synch/lock
	(syntax-rules ()
		((_ ?mtx ?body ...)
		  (let ((mtx ?mtx) (ok? #f))
				(mutex-lock! mtx)
				(dynamic-wind
				  (lambda () (mutex-lock! mtx))
					(lambda () (let ((res (begin ?body ...))) (set! ok? #t) res))
					(lambda () (unless ok? (mutex-unlock! mtx)))) ) ) ) )

(define-syntax synch/unlock
	(syntax-rules ()
		((_ ?mtx ?body ...)
		  (let ((mtx ?mtx))
			  (dynamic-wind
				  (lambda ()
					  (unless (thread? (mutex-state mtx))
						  (warning 'synch/unlock "mutex is not locked - locking")
						  (mutex-lock! mtx)))
				  (lambda () ?body ...)
				  (lambda () (mutex-unlock! mtx)) ) ) ) ) )

(define-syntax object/synch
  (lambda (form r c)
    (##sys#check-syntax 'object/synch form '(_ _ . _))
    (let (($synch-with (r 'synch-with))
          ($>< (r '><))
          (var (r (gensym)))
          (mtx (cadr form)))
      (let body-loop ((unparsed (cddr form)) (parsed '()))
        (if (not (null? unparsed))
            (let ((expr (car unparsed))
                  (next (cdr unparsed)))
              (let expr-loop ((rest expr) (parsedexpr '()))
                (cond ((null? rest)
                        (body-loop next (cons (reverse parsedexpr) parsed)))
                      ((pair? rest)
                        (let ((arg (car rest))
                              (next (cdr rest)))
                          (if (c $>< arg)
                              (expr-loop next (cons var parsedexpr))
                              (expr-loop next (cons arg parsedexpr)) ) ))
                      ((c $>< rest)
                        (body-loop next (cons var parsed)))
                      (else
                        (body-loop next (cons rest parsed))) ) ) )
            `(,$synch-with ,mtx ,var ,@(reverse parsed)) ) ) ) ) )

(define-syntax record/synch
  (lambda (form r c)
    (##sys#check-syntax 'record/synch form '(_ symbol _ . _))
    (let (($synch (r 'synch)))
      (let ((?sym (cadr form)) (?rec (caddr form)) (?body (cdddr form)))
        `(,$synch (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) )

(define-syntax record-synch/lock
  (lambda (form r c)
    (##sys#check-syntax 'record-synch/lock form '(_ symbol _ . _))
    (let (($synch/lock (r 'synch/lock)))
      (let ((?sym (cadr form)) (?rec (caddr form)) (?body (cdddr form)))
        `(,$synch/lock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) )

(define-syntax record-synch/unlock
  (lambda (form r c)
    (##sys#check-syntax 'record-synch/unlock form '(_ symbol _ . _))
    (let (($synch/unlock (r 'synch/unlock)))
      (let ((?sym (cadr form)) (?rec (caddr form)) (?body (cdddr form)))
        `(,$synch/unlock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) )

;;; Unprotected

(define-syntax %synch-mutex*
	(syntax-rules ()
		((_ ?mtx ?body ...)
		  (let ((mtx ?mtx))
        (mutex-lock! mtx)
				(call-with-values
					(lambda () ?body ...)
					(lambda ret
						(mutex-unlock! mtx)
						(apply values ret))) ) ) ) )

(define-syntax %synch-mutex-with*
  (lambda (form r c)
    (##sys#check-syntax '%synch-mutex-with* form '(_ _ variable . _))
    (let (($call-with-values (r 'call-with-values))
          ($mutex-specific (r 'mutex-specific))
          ($mutex-lock! (r 'mutex-lock!))
          ($mutex-unlock! (r 'mutex-unlock!))
          ($let (r 'let))
          ($apply (r 'apply))
          ($values (r 'values))
          ($lambda (r 'lambda))
          ($ret (r 'ret))
          (mtxvar (r (gensym))))
      (let ((?mtx (cadr form)) (?var (caddr form)) (?body (cdddr form)))
        `(,$let ((,mtxvar ,?mtx))
           (,$let ((,?var (,$mutex-specific ,mtxvar)))
             (,$mutex-lock! ,mtxvar)
             (,$call-with-values
               (,$lambda () ,@?body)
               (,$lambda ,$ret
                 (,$mutex-unlock! ,mtxvar)
                 (,$apply ,$values ,$ret)) ) ) ) ) ) ) )

(define-syntax %synch
	(syntax-rules ()
		((_ ?mtx ?body ...) (%synch-mutex* ?mtx ?body ...) ) ) )

(define-syntax %synch-with
	(syntax-rules ()
		((_ ?mtx ?var ?body ...) (%synch-mutex-with* ?mtx ?var ?body ...) ) ) )

(define-syntax %call/synch
	(syntax-rules ()
		((_ ?mtx ?proc ?arg0 ...) (%synch-mutex* ?mtx (?proc ?arg0 ...)) ) ) )

(define-syntax %call-with/synch
	(syntax-rules ()
		((_ ?mtx ?proc ?arg0 ...) (%synch-mutex-with* ?mtx var (?proc var ?arg0 ...)) ) ) )

(define-syntax %apply/synch
	(syntax-rules ()
		((_ ?mtx ?proc ?arg0 ...) (%synch-mutex* ?mtx (apply ?proc ?arg0 ...)) ) ) )

(define-syntax %apply-with/synch
	(syntax-rules ()
		((_ ?mtx ?proc ?arg0 ...) (%synch-mutex-with* ?mtx var (apply ?proc var ?arg0 ...)) ) ) )

(define-syntax %let/synch
  (lambda (form r c)
    (##sys#check-syntax '%let/synch form '(_ list . _))
    (let (($%synch-with (r '%synch-with)))
      (let ((?body (cddr form)))
        (car
          (let loop ((?bnds (cadr form)))
            (if (not (null? ?bnds))
                (let ((bnd (car ?bnds)))
                  (##sys#check-syntax '%let/synch bnd '(variable _))
                  `((,$%synch-with ,(cadr bnd) ,(car bnd) ,@(loop (cdr ?bnds)))) )
                ?body ) ) ) ) ) ) )

(define-syntax %set!/synch
  (lambda (form r c)
    (##sys#check-syntax '%set!/synch form '(_ pair . _))
    (let (($%synch-with (r '%synch-with))
          ($mutex-specific (r 'mutex-specific))
          ($mutex-specific-set! (r 'mutex-specific-set!))
          ($let (r 'let))
          ($begin (r 'begin))
          (mtxvar (r (gensym))))
      (let ((?bnd (cadr form)) (?body (cddr form)))
        (let ((?var (car ?bnd)) (?mtx (cadr ?bnd)))
          `(,$let ((,mtxvar ,?mtx))
             (,$%synch-with ,mtxvar ,?var
               (,$mutex-specific-set! ,mtxvar (,$begin ,@?body))
               (,$mutex-specific ,mtxvar) ) ) ) ) ) ) )

(define-syntax %synch/lock
	(syntax-rules ()
		((_ ?mtx ?body ...)
		  (let ((mtx ?mtx) (ok? #f))
				(mutex-lock! mtx)
				(call-with-values
					(lambda () (let ((res (begin ?body ...))) (set! ok? #t) res))
					(lambda ret
						(unless ok? (mutex-unlock! mtx))
						(apply values ret))) ) ) ) )

(define-syntax %synch/unlock
	(syntax-rules ()
		((_ ?mtx ?body ...)
      (let ((mtx ?mtx))
        (unless (thread? (mutex-state mtx))
          (warning '%synch/unlock "mutex is not locked - locking")
          (mutex-lock! mtx))
        (call-with-values
          (lambda () ?body ...)
          (lambda ret
            (mutex-unlock! mtx)
            (apply values ret)) ) ) ) ) )

(define-syntax %object/synch
  (lambda (form r c)
    (##sys#check-syntax '%object/synch form '(_ _ . _))
    (let (($%synch-with (r '%synch-with))
          ($>< (r '><))
          (var (r (gensym)))
          (mtx (cadr form)))
      (let body-loop ((unparsed (cddr form)) (parsed '()))
        (if (not (null? unparsed))
            (let ((expr (car unparsed))
                  (next (cdr unparsed)))
              (let expr-loop ((rest expr) (parsedexpr '()))
                (cond ((null? rest)
                        (body-loop next (cons (reverse parsedexpr) parsed)))
                      ((pair? rest)
                        (let ((arg (car rest))
                              (next (cdr rest)))
                          (if (c $>< arg)
                              (expr-loop next (cons var parsedexpr))
                              (expr-loop next (cons arg parsedexpr)) ) ))
                      ((c $>< rest)
                        (body-loop next (cons var parsed)))
                      (else
                        (body-loop next (cons rest parsed))) ) ) )
            `(,$%synch-with ,mtx ,var ,@(reverse parsed)) ) ) ) ) )

(define-syntax %record/synch
  (lambda (form r c)
    (##sys#check-syntax '%record/synch form '(_ symbol _ . _))
    (let (($%synch (r '%synch)))
      (let ((?sym (cadr form)) (?rec (caddr form)) (?body (cdddr form)))
        `(,$%synch (,(recmuxnam ?sym) ,?rec) ?body ...) ) ) ) )

(define-syntax %record-synch/lock
  (lambda (form r c)
    (##sys#check-syntax '%record-synch/lock form '(_ symbol _ . _))
    (let (($%synch/lock (r '%synch/lock)))
      (let ((?sym (cadr form)) (?rec (caddr form)) (?body (cdddr form)))
        `(,$%synch/lock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) )

(define-syntax %record-synch/unlock
  (lambda (form r c)
    (##sys#check-syntax '%record-synch/unlock form '(_ symbol _ . _))
    (let (($%synch/unlock (r '%synch/unlock)))
      (let ((?sym (cadr form)) (?rec (caddr form)) (?body (cdddr form)))
        `(,$%synch/unlock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) )

) ;module synch