guile-hurd/mach/msg-type.scm

(define-module (mach msg-type)
  #:export (msg-type-name:unstructured
	    msg-type-name:bit
	    msg-type-name:boolean
	    msg-type-name:integer/16
	    msg-type-name:integer/32
	    msg-type-name:char
	    msg-type-name:integer/8
	    msg-type-name:real
	    msg-type-name:integer/64
	    msg-type-name:string
	    msg-type-name:move-receive
	    msg-type-name:move-send
	    msg-type-name:move-send-once
	    msg-type-name:copy-send
	    msg-type-name:make-send
	    msg-type-name:make-send-once
	    msg-type-port:receive
	    msg-type-port:send
	    msg-type-port:send-once
	    clear-type-name replace-type-name type-name
	    clear-type-size replace-type-size type-size
	    clear-type-number replace-type-number type-number
	    assign-inline-field assign-longform-field
	    assign-deallocate-field assign-unused-field
	    msg-type:inline? msg-type:longform?
	    msg-type:deallocate? msg-type:unused?)
  #:use-module (srfi srfi-60)
  #:use-module (srfi srfi-26)
  #:use-module (mach ffi)
  #:use-module ((rnrs base) #:select (assert))
  #:use-module ((system foreign) #:select (sizeof)))

;; This is documented at
;; <https://www.gnu.org/software/hurd/gnumach-doc/Message-Format.html>.

;; Different kinds of message field types.
;;
;; The message type consists of:
;;  * a type name (ffi:msg-type-name)
;;  * a type size (size of the datum, in bits)
;;  * a type number (number of data elements)
;;  * some bits (inline, longform, deallocate, unused)
(define ffi:msg-type ffi:unsigned-int)
(define %wrap-msg-type identity)
(define %unwrap-msg-type identity)

;; This specifies the data type.  The actual data
;; type can be disambiguated by looking at the type size,
;; and/or by prior knowledge of what the data looks like.
(define-ffi-enum (ffi:msg-type-name ffi:unsigned-int)
  (%wrap-msg-type %unwrap-msg-type)
  (msg-type-name:unstructured 0)
  (msg-type-name:bit 0)
  (msg-type-name:boolean 0)
  (msg-type-name:integer/16 1)
  (msg-type-name:integer/32 2)
  (msg-type-name:char 8)
  (msg-type-name:byte 9)
  (msg-type-name:integer/8 9)
  ;; really a float, IIUC
  (msg-type-name:real 10)
  (msg-type-name:integer/64 11)
  (msg-type-name:string 12)
  ;; Port rights.
  ;; They are documented at
  ;; <https://www.gnu.org/software/hurd/gnumach-doc/Exchanging-Port-Rights.html#fn-1>.
  ;; Note that send-once and receive-once rights always have a user reference
  ;; count of one.

  ;; Message carries a receive right.
  ;;
  ;; When sending, the sender supplies the receive right and loses the right.
  ;; (XXX shouldn't this be ‘loses a reference to the right’?).
  ;;
  ;; The receiver will see msg-type-name:receive.
  (msg-type-name:move-receive 16)
  ;; The message carries a send right.
  ;;
  ;; When sending, the sender supplies a send right and loses a reference
  ;; to the right. Alternatively, the sender can supply a dead name, which
  ;; likewise loses a reference and the receiver will get the dead port.
  ;;
  ;; The receiver will see msg-type-port:send
  ;; (an alias for msg-type-name:move-send).
  (msg-type-name:move-send 17)
  ;; The message carries a send-once right.
  ;;
  ;; When sending, the sender supplies a send-once right and the sender
  ;; loses that right.  Alternatively, the sender can supply a dead name
  ;; which loses a user reference and the receiver will get the dead port.
  ;;
  ;; When receiving, the receiver gains the send-once right
  ;; under a new name.
  ;;
  ;; The receiver will see msg-type-port:send-once
  ;; (an alias for msg-type-name:move-send-once).
  (msg-type-name:move-send-once 18)
  ;; Message carries a send-once right.
  ;;
  ;; When sending, the sender supplies a send right and the sender
  ;; won't lose that right.  Alternatively, the caller can supply
  ;; a dead name and the receiver will get the dead port.
  ;;
  ;; The receiver will see msg-type-port:send
  ;; (an alias for msg-type-name:move-send).
  (msg-type-name:copy-send 19)
  ;; The message carries a send right.
  ;;
  ;; When sending, the sender supplies a receive right,
  ;; and the message will hold a send right created from
  ;; the receive right.
  ;;
  ;; The receiver will see msg-type-port:send
  ;; (an alias for msg-type-name:move-send).
  (msg-type-name:make-send 20)
  ;; The message carries a send-once right.
  ;;
  ;; When sending, the sender supplies a receive right,
  ;; and the message will hold a send-once right created
  ;; from the receive right.
  ;;
  ;; The receiver will see msg-type-port:send-once
  ;; (an alias for msg-type-name:move-send-once).
  (msg-type-name:make-send-once 21))

;; Some aliases for the receiver.

;; The message carried a send right, and the receiver
;; now has the right.
;;
;; Unless that would cause overflow, if the receiver already
;; has a send or receive right to the port under some name, the
;; user reference count is incremented instead of allocating a
;; new name.
;;
;; In practice, that's just an implementation detail for efficiency,
;; however.  (TODO: spoken like someone who is writing this comment
;; on a Linux box, and never actually wrote a translator ...)
(define msg-type-port:send msg-type-name:move-send)
;; The message carried a send-once right, and the receiver
;; now has the right under a fresh name.
(define msg-type-port:send-once msg-type-name:move-send-once)
;; The message carried a receive right.
;;
;; TODO make-send count is set to zero? Other attributes remain?
;; TODO stuff about reusing names, seems to be different
;; than in msg-typ-name:send?
(define msg-type-port:receive msg-type-name:move-receive)

(define %wrap-msg-type-name identity)
(define %unwrap-msg-type-name identity)

;; The common lisp port has procedures for converting
;; between ffi:msg-type-name and their symbol representation.
;; These have been removed, as the mapping is ambigious.

;; Mask of type name field.
(define %msg-type-name-mask #xff)
;; Maximal value for type name.
;; Coincidentally, this is the same as
;; %msg-type-name-mask.
(define %max-msg-type-name #xff)

(define (clear-type-name value)
  "Clear the type name field in @var{value} (a message type)
and return the result."
  (%wrap-msg-type
   (bitwise-and (%unwrap-msg-type value)
		(bitwise-not %msg-type-name-mask))))

(define (replace-type-name value name)
  "Set the type name field in @var{value} (a message type) @var{name}
(a message type name) and return the result."
  (let ((n (%unwrap-msg-type-name name)))
    (assert (and (exact-integer? n) (<= 0 n) (<= n %max-msg-type-name))))
  (%wrap-msg-type
   (bitwise-ior (%unwrap-msg-type (clear-type-name value))
		(%unwrap-msg-type-name name))))

(define (type-name value)
  "Extract the type name in @var{value} (a @code{msg:type})."
  (%wrap-msg-type-name
   (bitwise-and (%unwrap-msg-type value) %msg-type-name-mask)))

;; Mask of the size field.
(define %msg-type-size-mask #xff00)
;; Maximal value of size field.
(define %max-msg-type-size #xff)
;; How many bits must a @code{ffi:msg-type} be shifted to the
;; right to extract the size field?
(define %msg-type-size-shift 8)

(define (clear-type-size value)
  "Clear the type size field of @var{value} (a @code{ffi:msg-type})
and return the result."
  (%wrap-msg-type (bitwise-and (%unwrap-msg-type value)
			       %msg-type-size-mask)))

(define (replace-type-size value size)
  "Set the type size field of @var{value} (a @code{ffi:msg-type})
to @var{size} (an exact integer).  @var{size} must be an integer
in the closed range [0,@code{%max-msg-type-size}]."
  (assert (and (exact-integer? size) (<= 0 size)
	       (<= size %max-msg-type-size)))
  (%wrap-msg-type
   (bitwise-ior (%unwrap-msg-type (clear-type-size value))
		(ash size %msg-type-size-shift))))

(define (type-size value)
  "Extract the size field from @var{value}, a @code{ffi:msg-type}."
  (ash (bitwise-and %msg-type-size-mask (%unwrap-msg-type value))
       (- %msg-type-size-shift)))

;; Mask for number field.
(define %msg-type-number-mask #xfff0000)
;; Maximal number.
(define %max-msg-type-number #xfff)
;; Shift for type number field.
;; That is, shift the value by this number of positions to the right
;; to extract the number field.
(define %msg-type-number-shift 16)

(define (clear-type-number value)
  "Clear the type number field of @var{value}, a @code{ffi:msg-type},
and return the result."
  (%wrap-msg-type
   (bitwise-and (%unwrap-msg-type value)
		(bitwise-not %msg-type-number-mask))))

(define (replace-type-number value number)
  "Set the type number field of @var{value} (a @code{ffi:msg-type})
to @var{number}, and return the result.  @var{number} must be an
exact integer in the closed range [0,@code{%max-msg-type-number}]."
  (assert (and (exact-integer? number) (<= 0 number)
	       (<= number %max-msg-type-number)))
  (%wrap-msg-type
   (bitwise-ior (%unwrap-msg-type (clear-type-number value))
		(ash number %msg-type-number-shift))))

(define (type-number value)
  "Return the type number of @var{value} (a @code{ffi:msg-type})."
  (ash (bitwise-and (%unwrap-msg-type value) %msg-type-number-mask)
       (- %msg-type-number-shift)))

;; When #f, the actual data resides in a ‘out-of-line region’.
;; In a message, the type descriptor is followed by the address.
(define %msg-field:inline 28)
;; The type descriptor is actually a ffi:msg-type-long.
(define %msg-field:longform 29)
;; When #t, deallocate the memory region fom the sender's address
;; space when the message is sent.
(define %msg-field:deallocate 30)
;; Should be zero.
(define %msg-field:unused 31)

(define (make-bit-assigner position)
  "Make a procedure accepting an exact integer and a boolean,
that sets the bit at @var{position} to the boolean and returns
the result."
  (cut copy-bit position <> <>))

(define (make-bit-tester position)
  "Make a procedure accepting an exact integer, that tests whether
the bit at position @var{position} is set."
  (cut bit-set? position <>))

(define assign-inline-field
  (make-bit-assigner %msg-field:inline))
(define assign-longform-field
  (make-bit-assigner %msg-field:longform))
(define assign-deallocate-field
  (make-bit-assigner %msg-field:deallocate))
(define assign-unused-field
  (make-bit-assigner %msg-field:unused))

(define msg-type:inline?
  (make-bit-tester %msg-field:inline))
(define msg-type:longform?
  (make-bit-tester %msg-field:longform))
(define msg-type:deallocate?
  (make-bit-tester %msg-field:deallocate))
(define msg-type:unused?
  (make-bit-tester %msg-field:unused))

(define %msg-type-size (sizeof ffi:msg-type))