Libraries for Vicare Scheme: posix sem examples

The following example shows how two processes can synchronise themselves to exchange a signed integer using a POSIX shared memory object and an unnamed POSIX semaphore allocated in such an object; the parent process sets up the shared memory and initialises the semaphore, then it waits for the semaphore and reads the integer; the child process writes an integer in the shared memory, then it posts the semaphore.

#!r6rs
(import (vicare)
  (prefix (vicare posix) px.)
  (vicare platform constants)
  (only (vicare language-extensions syntaxes)
        callet))

(define shm.pathname
  "/vicare.test")
(define shm.dim
  (px.sysconf _SC_PAGESIZE))

(define (parent child-pid)
  (let ((shm.fd (callet px.shm-open shm.pathname
                  (oflags   (fxior O_CREAT O_EXCL O_RDWR))
                  (mode     (fxior S_IRUSR S_IWUSR)))))
    (px.ftruncate shm.fd shm.dim)
    (unwind-protect
        (let ((shm.base (callet px.mmap
                          (address #f)
                          (size    shm.dim)
                          (prot    (fxior PROT_READ
                                          PROT_WRITE))
                          (flags   MAP_SHARED)
                          (fd      shm.fd)
                          (offset  0))))
          (unwind-protect
              (let* ((sem_t     shm.base)
                     (shm.start (pointer-add shm.base
                                  (px.sizeof-sem_t)))
                     (sem_t     (callet px.sem-init sem_t
                                  (pshared? #t)
                                  (value    0))))
                (define timeout
                  (let ((T (px.clock-gettime CLOCK_REALTIME
                             (px.make-struct-timespec 0 0))))
                    (px.set-struct-timespec-tv_sec! T
                      (+ 2 (px.struct-timespec-tv_sec T)))
                    T))
                (unwind-protect
                    (begin
                      (px.sem-timedwait sem_t timeout)
                      (pointer-ref-c-signed-int shm.start 0))
                  (px.sem-destroy sem_t)))
            (px.munmap shm.base shm.dim)))
      (px.close shm.fd)
      (px.shm-unlink shm.pathname))))

(define (child)
  ;; Give the parent some time to open the
  ;; shared memory object.
  (px.nanosleep 1 0)
  (let ((shm.fd (callet px.shm-open shm.pathname
                  (oflags   (fxior O_CREAT O_RDWR))
                  (mode     (fxior S_IRUSR S_IWUSR)))))
    (unwind-protect
        (let ((shm.base (callet px.mmap
                          (address #f)
                          (size    shm.dim)
                          (prot    (fxior PROT_READ
                                          PROT_WRITE))
                          (flags   MAP_SHARED)
                          (fd      shm.fd)
                          (offset  0))))
          (unwind-protect
              (let* ((sem_t     shm.base)
                     (shm.start (pointer-add shm.base
                                  (px.sizeof-sem_t))))
                (pointer-set-c-signed-int! shm.start 0 123)
                (px.sem-post sem_t))
            (px.munmap shm.base shm.dim)))
      (px.close shm.fd)))
  (exit 0))

(px.fork parent child)  ⇒ 123

The following example shows how two processes can synchronise themselves to exchange a signed integer using a POSIX shared memory object and a named POSIX semaphore; the parent process sets up the shared memory and the semaphore, then it waits for the semaphore and reads the integer; the child process writes an integer in the shared memory, then it posts the semaphore.

#!r6rs
(import (vicare)
  (prefix (vicare posix) px.)
  (vicare platform constants)
  (only (vicare language-extensions syntaxes)
        unwind-protect
        callet))

(define sem.pathname
  "/vicare-posix-sem.test")
(define shm.pathname
  "/vicare-posix-shm.test")
(define shm.dim
  (px.sysconf _SC_PAGESIZE))

(define (parent child-pid)
  (let ((sem_t  (callet px.sem-open sem.pathname
                  (oflags (fxior O_CREAT O_EXCL O_RDWR))
                  (mode   (fxior S_IRUSR S_IWUSR))))
        (shm.fd (callet px.shm-open shm.pathname
                  (oflags   (fxior O_CREAT O_EXCL O_RDWR))
                  (mode     (fxior S_IRUSR S_IWUSR)))))
    (px.ftruncate shm.fd shm.dim)
    (unwind-protect
        (let ((shm.base (callet px.mmap
                          (address #f)
                          (size    shm.dim)
                          (prot    (fxior PROT_READ
                                          PROT_WRITE))
                          (flags   MAP_SHARED)
                          (fd      shm.fd)
                          (offset  0))))
          (unwind-protect
              (begin
                (px.sem-wait sem_t)
                (pointer-ref-c-signed-int shm.base 0))
            (px.munmap shm.base shm.dim)))
      (px.close shm.fd)
      (px.shm-unlink shm.pathname)
      (px.sem-close sem_t)
      (px.sem-unlink sem.pathname))))

(define (child)
  ;; Give the parent some time to open the
  ;; shared memory object.
  (px.nanosleep 1 0)
  (let ((sem_t  (callet px.sem-open sem.pathname
                  (oflags (fxior O_CREAT O_RDWR))
                  (mode   (fxior S_IRUSR S_IWUSR))))
        (shm.fd (callet px.shm-open shm.pathname
                  (oflags (fxior O_CREAT O_RDWR))
                  (mode   (fxior S_IRUSR S_IWUSR)))))
    (unwind-protect
        (let ((shm.base (callet px.mmap
                          (address #f)
                          (size    shm.dim)
                          (prot    (fxior PROT_READ
                                          PROT_WRITE))
                          (flags   MAP_SHARED)
                          (fd      shm.fd)
                          (offset  0))))
          (unwind-protect
              (begin
                (pointer-set-c-signed-int! shm.base 0 123)
                (px.sem-post sem_t))
            (px.munmap shm.base shm.dim)))
      (px.close shm.fd)
      (px.sem-close sem_t)))
  (exit 0))

(px.fork parent child) ⇒ 123

4.24.2 Usage examples of semaphores