;;;; synch-open.scm
;;;; Kon Lovett, Dec '18

;; Issues
;;
;; - syntax checking is minimal so expansion errors are cryptic

(module synch-open

(;export
  ;;
  %synch
  %synch-lock
  %synch-unlock
  ;;
  %synch-with
  %call-synch
  %call-synch-with
  %apply-synch
  %apply-synch-with
  %let-synch-with
  %set!-synch-with
  ;;
  %object-synch-cut-with
  %record-synch
  %record-synch-lock
  %record-synch-unlock
  ;
  define-constructor-%synch
  define-predicate-%synch
  define-operation-%synch
  ;
  %synchronized-procedure)

(import scheme
  (chicken base)
  (chicken syntax)
  (only (srfi 18)
    thread?
    make-mutex mutex?
    mutex-specific mutex-specific-set!
    mutex-lock! mutex-unlock!
    mutex-state)
  synch-object)

;;; Unprotected

;;

(define-for-syntax (suffix-symbol sym suf)
  (import-for-syntax (only (chicken base) symbol-append))
  (symbol-append sym '- suf) )

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

;;

(define-syntax %synch-with
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (##sys#check-syntax '%synch-with frm '(_ _ variable . _))
      (let ((_call-with-values (rnm 'call-with-values))
            (_mutex-specific (rnm 'mutex-specific))
            (_mutex-lock! (rnm 'mutex-lock!))
            (_mutex-unlock! (rnm 'mutex-unlock!))
            (_let (rnm 'let))
            (_apply (rnm 'apply))
            (_values (rnm 'values))
            (_lambda (rnm 'lambda))
            (_when (rnm 'when))
            (_ret (rnm 'ret))
            (mtxvar (rnm (gensym))) )
        (let ((?mtx (cadr frm))
              (?var (caddr frm))
              (?body (cdddr frm)) )
          (call-with-values
            (lambda ()
              (if (not (pair? ?mtx))
                (values ?mtx '() '())
                (let ((mtx (car ?mtx))
                      (lock-args (if (<= 2 (length ?mtx)) (cadr ?mtx) '()))
                      (unlock-args (if (= 3 (length ?mtx)) (caddr ?mtx) '())) )
                  (values mtx lock-args unlock-args) ) ) )
            (lambda (?mtx ?lock-args ?unlock-args)
              `(,_let ((,mtxvar ,?mtx))
                (,_let ((,?var (,_mutex-specific ,mtxvar)))
                  (,_when (,_mutex-lock! ,mtxvar ,@?lock-args)
                    (,_call-with-values
                      (,_lambda ()
                        ,@?body)
                      (,_lambda ,_ret
                        (,_mutex-unlock! ,mtxvar ,@?unlock-args)
                        (,_apply ,_values ,_ret))) ) ) ) ) ) ) ) ) ) )

;;

(define-syntax %call-synch
  (syntax-rules ()
    ((%call-synch ?mtx ?proc ?arg0 ...)
      (%synch ?mtx (?proc ?arg0 ...)) ) ) )

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

(define-syntax %apply-synch
  (syntax-rules ()
    ((%apply-synch ?mtx ?proc ?arg0 ...)
      (%synch ?mtx (apply ?proc ?arg0 ...)) ) ) )

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

(define-syntax %let-synch-with
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (##sys#check-syntax '%let-synch-with frm '(_ list . _))
      (let ((_%synch-with (rnm '%synch-with)))
        (let ((?body (cddr frm)))
          (car
            (let loop ((?bnds (cadr frm)))
              (if (null? ?bnds)
                ?body
                (let ((bnd (car ?bnds)))
                  (##sys#check-syntax '%let-synch-with bnd '(variable _))
                  `((,_%synch-with ,(cadr bnd) ,(car bnd) ,@(loop (cdr ?bnds)))) ) ) ) ) ) ) ) ) )

(define-syntax %set!-synch-with
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (##sys#check-syntax 'set!-synch-with frm '(_ _ variable . #(_ 0)))
      (let ((_%synch-with (rnm '%synch-with) )
            (_mutex-specific (rnm 'mutex-specific) )
            (_mutex-specific-set! (rnm 'mutex-specific-set!) )
            (_let (rnm 'let) )
            (_begin (rnm 'begin) )
            (mtxvar (rnm (gensym)) ) )
        (let ((?mtx (cadr frm) )
              (?var (caddr frm) )
              (?body (cdddr frm) ) )
          `(,_let ((,mtxvar ,?mtx))
             (,_%synch-with ,mtxvar ,?var
               (,_mutex-specific-set! ,mtxvar (,_begin ,@?body))
               (,_mutex-specific ,mtxvar) ) ) ) ) ) ) )

;;

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

(define-syntax %synch-unlock
  (syntax-rules ()
    ;
    ((%synch-unlock (?mtx (?unlock-arg0 ...)) ?body ...)
      (let ((mtx ?mtx))
        (let ((st (mutex-state mtx)))
          (if (or (eq 'abandoned st) (eq 'not-abandoned st))
            (error '%synch-unlock "mutex unlocked" mtx)
            (call-with-values
              (lambda ()
                ?body ...)
              (lambda ret
                (mutex-unlock! mtx ?unlock-arg0 ...)
                (apply values ret)) ) ) ) ) )
    ;
    ((%synch-unlock ?mtx ?body ...)
      (%synch-unlock (?mtx ()) ?body ...) ) ) )

;;

(define-syntax %object-synch-cut-with
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (##sys#check-syntax '%object-synch-cut-with frm '(_ _ . _))
      (let ((_%synch-with (rnm '%synch-with))
            (_>< (rnm '><))
            (var (rnm (gensym)))
            (mtx (cadr frm)) )
        (let body-loop ((unparsed (cddr frm)) (parsed '()))
          (if (null? unparsed)
            ;code walked
            `(,_%synch-with ,mtx ,var ,@(reverse parsed))
            ;walk code
            (let ((expr (car unparsed))
                  (next (cdr unparsed)) )
              (let expr-loop ((rest expr) (parsed-expr '()))
                (cond
                  ((null? rest)
                    (body-loop next (cons (reverse parsed-expr) parsed)))
                  ((pair? rest)
                    (let ((arg (car rest))
                          (next (cdr rest)))
                      (if (cmp _>< arg)
                        (expr-loop next (cons var parsed-expr))
                        (expr-loop next (cons arg parsed-expr)) ) ))
                  ((cmp _>< rest)
                    (body-loop next (cons var parsed)))
                  (else
                    (body-loop next (cons rest parsed))) ) ) ) ) ) ) ) ) )

;;

(define-for-syntax (record-mutex-name sym) (suffix-symbol sym 'mutex))

;;

(define-syntax %record-synch
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (##sys#check-syntax '%record-synch frm '(_ _ symbol . _))
      (let ((_let (rnm 'let))
            (_recvar (rnm 'recvar))
            (_%synch (rnm '%synch)) )
        (let ((?rec (cadr frm))
              (?sym (caddr frm))
              (?body (cdddr frm)) )
          `(,_let ((,_recvar ,?rec))
            (,_%synch (,(record-mutex-name ?sym) ,_recvar) ,@?body) ) ) ) ) ) )

(define-syntax %record-synch-lock
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (##sys#check-syntax '%record-synch-lock frm '(_ _ symbol . _))
      (let ((_let (rnm 'let))
            (_recvar (rnm 'recvar))
            (_%synch-lock (rnm '%synch-lock)) )
        (let ((?rec (cadr frm))
              (?sym (caddr frm))
              (?body (cdddr frm)) )
          `(,_let ((,_recvar ,?rec))
            (,_%synch-lock (,(record-mutex-name ?sym) ,_recvar) ,@?body) ) ) ) ) ) )

(define-syntax %record-synch-unlock
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (##sys#check-syntax '%record-synch-unlock frm '(_ _ symbol . _))
      (let ((_let (rnm 'let))
            (_recvar (rnm 'recvar))
            (_%synch-unlock (rnm '%synch-unlock)) )
        (let ((?rec (cadr frm))
              (?sym (caddr frm))
              (?body (cdddr frm)) )
          `(,_let ((,_recvar ,?rec))
            (,_%synch-unlock (,(record-mutex-name ?sym) ,_recvar) ,@?body) ) ) ) ) ) )

;;; Synch Object

;;

(define (%synchronized-procedure proc)
  (let ((mtx (make-synch-with-object proc '(synchproc))))
    (lambda args (%synch-with mtx proc (apply proc args))) ) )

;;

(define-for-syntax (%synch-wrapper-name sym) (suffix-symbol sym '%synch))

(define-syntax define-constructor-%synch
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (##sys#check-syntax 'define-constructor-%synch frm '(_ symbol . _))
      (let ((_define (rnm 'define) )
            (_apply (rnm 'apply) )
            (_args (rnm (gensym 'args)) )
            (_make-synch-with-object (rnm 'make-synch-with-object) ) )
        (let* ((prcnam (cadr frm) )
               (id (if (not (null? (cddr frm))) `('(,(caddr frm))) `('(,prcnam))) )
               (newnam (%synch-wrapper-name prcnam) ) )
          `(,_define (,newnam . ,_args)
            (,_make-synch-with-object (,_apply ,prcnam ,_args) ,@id)) ) ) ) ) )

(define-syntax define-predicate-%synch
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (##sys#check-syntax 'define-predicate-%synch frm '(_ symbol))
      (let ((_define (rnm 'define))
            (_obj (rnm (gensym 'obj)))
            (_synch-with-object? (rnm 'synch-with-object?)) )
        (let* ((prcnam (cadr frm))
               (newnam (%synch-wrapper-name prcnam)) )
          `(,_define (,newnam ,_obj)
            (,_synch-with-object? ,_obj ,prcnam)) ) ) ) ) )

;operand must be the 1st argument
(define-syntax define-operation-%synch
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (##sys#check-syntax 'define-operation-%synch frm '(_ symbol))
      (let ((_define (rnm 'define))
            (_apply (rnm 'apply))
            (_let (rnm 'let))
            (_car (rnm 'car))
            (_cdr (rnm 'cdr))
            (_if (rnm 'if))
            (_pair? (rnm 'pair?))
            (_%synch-with (rnm '%synch-with))
            (_mtx-w-obj (rnm (gensym 'mtx-w-obj)))
            (_args (rnm (gensym 'args)))
            (_obj (rnm (gensym 'obj))) )
        (let* ((prcnam (cadr frm))
               (newnam (%synch-wrapper-name prcnam)) )
          `(,_define (,newnam ,_mtx-w-obj . ,_args)
            (,_%synch-with ,_mtx-w-obj ,_obj (,_apply ,prcnam ,_obj ,_args)) ) ) ) ) ) )

) ;module synch-open