;;;
;;; lh-guid.lisp
;;;
;;; GUID representation and parsing.
;;;

;;; A GUID is a 128-bit integer used as a unique identifier.  It is
;;; broken up into several bitfields and has defined textual and data
;;; representations.  Our GUID objects are CLOS instances (thus
;;; discriminable), EQ-comparable (any two GUIDs with the same text
;;; representation are the same object), externalizable (can be
;;; printed readably, have a make-load-form method defined) and
;;; integrate with SB-ALIEN (can be struct members, are passed to
;;; functions as pointers to their encoded representation).

;;; One feature that is not implemented is custom reader syntax for
;;; GUID parsing, such as #G{xxxxxxxx-xxxx-xxxx-xxxx-xxxxxxxxxxxx} =>
;;; #<a GUID>.

;;; If an alien function takes a pointer to a GUID for reading,
;;; declare it as taking an lh-guid:guid and pass a GUID object
;;; directly.  If an alien function takes a pointer to a GUID for
;;; writing, declare it as taking an (* lh-guid:guid), use WITH-ALIEN
;;; to allocate an alien variable of type lh-guid:guid, pass it to the
;;; function with ADDR, then DEREF the alien variable to get the lisp
;;; GUID object.
;;;
;;; That is, for reading:
;;;
;;;    (alien-funcall (extern-alien (function ... lh-guid:guid ...))
;;;                   ... guid ...)
;;;
;;; for writing:
;;;
;;;    (with-alien ((foo lh-guid:guid)
;;;                 (bar (function ... (* lh-guid:guid) ...)
;;;                      :extern "bar"))
;;;       (alien-funcall bar ... (addr foo) ...)
;;;       (deref foo))
;;;
;;; This is important to prevent the alien function from destructively
;;; modifying an interned GUID, which would be bad.

;;; Callback functions taking or returning a GUID are untested, and
;;; may well need to use an explicit pointer (that is, arguments would
;;; need to be of type (* lh-guid:guid) rather than lh-guid:guid, and
;;; need explicit dereferencing).


;;;; Package definition.

(cl:defpackage :lh-guid
  (:use :cl :sb-alien)
  (:import-from "SB-ALIEN-INTERNALS"
		"DEFINE-ALIEN-TYPE-TRANSLATOR"
		"DEFINE-ALIEN-TYPE-METHOD")
  (:export
   "GUID" "PARSE-GUID" "UNPARSE-GUID"))

(cl:in-package :lh-guid)


;;;; Storage representation.

;;; We represent a GUID as a wrapper class and an underlying octet
;;; vector containing the machine encoded form of the GUID.

(defclass guid ()
  ((data-bits :initarg data-bits
	      :type (simple-array (unsigned-byte 8) (16)))))


;;;; "Interning".

;;; To provide EQ-level GUID comparability, we "intern" GUIDs in a
;;; weak-valued hash table keyed based on a 128-bit unsigned integer
;;; representation of the underlying data bits.  This gives us the
;;; EQ-comparability we want while still allowing GUID objects to be
;;; garbage collected.

(defvar *known-guids* (make-hash-table :weakness :value))

(defun intern-guid (data-bits)
  "Given DATA-BITS, the underlying (simple-array (unsigned-byte 8)
(16)) storage representation of a GUID, return the unique GUID object
that represents it.  If the GUID object needs to be created then
DATA-BITS must not be modified after calling INTERN-GUID."
  ;; FIXME: Possibly should pin SAP.
  (let* ((sap (sb-sys:vector-sap data-bits))
	 (qw0 (sb-sys:sap-ref-64 sap 0))
	 (qw1 (sb-sys:sap-ref-64 sap 8))
	 (key (dpb qw1 (byte 64 64) qw0)))
    (or (gethash key *known-guids*)
	(setf (gethash key *known-guids*)
	      (make-instance 'guid 'data-bits data-bits)))))


;;;; Parsing and unparsing.

(defun parse-guid (string)
  "Return the GUID described by STRING."
  ;; A GUID looks like "{xxxxxxxx-xxxx-xxxx-xxxx-xxxxxxxxxxxx}", where
  ;; each x is a hexadecimal digit.  That's 38 characters, with some
  ;; elements having a fixed content and the rest being digit-char-p
  ;; true for radix 16 (hexadecimal).
  (unless (and (= (length string) 38)
	       (eql #\{ (char string 0))
	       (eql #\- (char string 9))
	       (eql #\- (char string 14))
	       (eql #\- (char string 19))
	       (eql #\- (char string 24))
	       (eql #\} (char string 37)))
    (error "~S is not a valid GUID" string))
  (let ((data-bits (make-array 16 :element-type '(unsigned-byte 8))))
    (loop for offset in '(7 5 3 1 12 10 17 15 20 22 25 27 29 31 33 35)
	  for index from 0
	  do (setf (aref data-bits index)
		   (parse-integer string :radix 16
				  :start offset :end (+ offset 2))))
    (intern-guid data-bits)))

(defun unparse-guid (guid)
  "Return the textual form of GUID as a string."
  (apply #'format nil
	 "~({~4@{~2,'0X~}-~2@{~2,'0X~}-~2@{~2,'0X~}-~2@{~2,'0X~}-~6@{~2,'0X~}}~)"
	 (loop with data-bits = (slot-value guid 'data-bits)
	       for index in '(3 2 1 0 5 4 7 6 8 9 10 11 12 13 14 15)
	       collect (aref data-bits index))))


;;;; Serialization.

;;; Print-read consistency.

(defmethod print-object ((guid guid) stream)
  ;; FIXME: Make sure this behaves right wrt *read-eval*.
  (format stream "#.(~S ~S)" 'parse-guid (unparse-guid guid)))

;;; Externalizability in FASLs.

(defmethod make-load-form ((guid guid) &optional environment)
  (declare (ignore environment))
  `(intern-guid ,(slot-value guid 'data-bits)))


;;;; Alien type definition.

;;; The following is a heavily-commented example of defining a
;;; translated alien type in SBCL.  The mechanisms for doing this are,
;;; of course, undocumented and internal to SBCL and are likey easy to
;;; break with a type-name collision.

;;; KLUDGE: define-alien-type-class is not package-safe, so we need to
;;; do our damage in the sb-alien package in order to make it work.

(cl:in-package :sb-alien)

;;; First, we define our alien-type-class.  We inherit from
;;; system-area-pointer because we would like to be passed to alien
;;; functions as a pointer type.

(define-alien-type-class (lh-guid:guid :include system-area-pointer))

;;; KLUDGE: Now that we've defined our alien-type-class, switch back
;;; to our package.

(cl:in-package :lh-guid)

;;; Next, we define a type translator.  This is used for when someone
;;; creates a struct or union with a GUID as a member or when someone
;;; uses WITH-ALIEN to create a GUID on the heap.

(define-alien-type-translator guid ()
  (sb-alien::make-alien-guid-type :bits 128))

;;; Next, we need an unparse method to be able to convert back from an
;;; alien-type object to a type specifier that will recreate it
;;; (essentially similar to print-read consistency).

(define-alien-type-method (guid :unparse) (type)
  (declare (ignore type))
  'guid)

;;; Next, we define a lisp-rep method to inform the system what lisp
;;; type to check for when deporting a value from lisp to alien form.

(define-alien-type-method (guid :lisp-rep) (type)
  (declare (ignore type))
  'guid)

;;; We don't need a type= method because the wrapper that calls it
;;; will only do so if the two types are of the same type class, and
;;; the default implementation (inherited from root) is to just return
;;; T.  This means that it only makes sense to define a type= method
;;; for parameterized type classes, which GUID is not.

;;; We don't need a subtypep method because the default implementation
;;; (inherited from root) is to just call alien-type-= on its
;;; arguments, which does the right thing for non-parameterized type
;;; classes.

;;; That's the basic type-system integration done.  All that remains
;;; is to tell the system how to convert guids to and from alien form.

;;; First, we define a naturalize-gen method to create a lisp guid
;;; from a pointer to an alien guid structure.

(define-alien-type-method (guid :naturalize-gen) (type alien)
  (declare (ignore type))
  ;; FIXME: This should be doable without consing up a fresh array if
  ;; the GUID has already been interned.  Probably by using SAP-REF-64
  ;; to obtain the key for the hash table just as INTERN-GIUD does.
  (let ((data-bits (gensym)))
    `(let ((,data-bits (make-array 16 :element-type '(unsigned-byte 8))))
      (sb-kernel:copy-ub8-from-system-area ,alien 0 ,data-bits 0 16)
      (intern-guid ,data-bits))))

;;; Next, we define the deport-gen, deport-alloc-gen and deport-pin-p
;;; methods.  The deport-alloc-gen method retrieves the object that
;;; needs to be pinned if there is one, or it can return the actual
;;; value to use or the original object.  The deport-gen method is
;;; passed the value returned by the deport-alloc-gen method and must
;;; return the actual value to use.  The deport-pin-p method tells the
;;; system that the value returned from deport-alloc-gen must be
;;; pinned.

(define-alien-type-method (guid :deport-gen) (type object)
  (declare (ignore type))
  ;; deport-gen is the only method that can reasonably return multiple
  ;; values.  The (optional) second value is to be the type of the
  ;; value returned by the expression computed in the deport-alloc-gen
  ;; method, defaulting to the return of the lisp-rep method or (in
  ;; the case of alien-value types, for which lisp-rep returns NIL) an
  ;; ALIEN type specifier.
  (values `(sb-sys:vector-sap ,object)
	  '(simple-array (unsigned-byte 8) (16))))

(define-alien-type-method (guid :deport-alloc-gen) (type value)
  (declare (ignore type))
  `(slot-value ,value 'data-bits))

(define-alien-type-method (guid :deport-pin-p) (type)
  (declare (ignore type))
  t)

;;; Next, the extract-gen and deposit-gen methods are used to access
;;; structure slots and such that are GUIDs.  The default deposit-gen
;;; method passes the buck to setf, but as we're doing an area-copy,
;;; we can't let it do that.  The result of extract-gen is passed to
;;; naturalize, so in our case it should "just" do a SAP+.

(define-alien-type-method (guid :extract-gen) (type sap offset)
  (declare (ignore type))
  `(sb-sys:sap+ ,sap (truncate ,offset sb-vm:n-byte-bits)))

(define-alien-type-method (guid :deposit-gen) (type sap offset value)
  (declare (ignore type))
  `(sb-kernel:copy-ub8-to-system-area ,value
    0 ,sap (truncate ,offset sb-vm:n-byte-bits) 16))


;;; EOF