;;;; 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-operation-%synch)

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

;;; 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-for-syntax (%synch-wrapper-name sym) (suffix-symbol sym '%synch))

;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