Commit 6d614997 authored by  Hayley Patton's avatar Hayley Patton 🐢

Rewrite the inbuilt object and class hashing mechanisms

parent 2e74e84e
...@@ -15,11 +15,14 @@ ...@@ -15,11 +15,14 @@
(setf (aref vector n) (funcall function))) (setf (aref vector n) (funcall function)))
vector)) vector))
(defun read-string (function)
(babel:octets-to-string (read-byte-vector function
(read-integer function))
:encoding :utf-8))
(defgeneric binary-parse-from-type-tag (type-tag function) (defgeneric binary-parse-from-type-tag (type-tag function)
(:method ((tag (eql 1)) function) (:method ((tag (eql 1)) function)
(babel:octets-to-string (read-byte-vector function (read-string function))
(read-integer function))
:encoding :utf-8))
(:method ((tag (eql 2)) function) (:method ((tag (eql 2)) function)
(read-byte-vector function (read-integer function))) (read-byte-vector function (read-integer function)))
(:method ((tag (eql 3)) function) (:method ((tag (eql 3)) function)
...@@ -35,10 +38,8 @@ ...@@ -35,10 +38,8 @@
(loop repeat length (loop repeat length
collect (binary-parse-from-function function)))) collect (binary-parse-from-function function))))
(:method ((tag (eql 6)) function) (:method ((tag (eql 6)) function)
(let ((hash (make-array 32 :element-type '(unsigned-byte 8)))) (make-instance 'reference
(dotimes (n 32) :hash (read-string function)))
(setf (aref hash n) (funcall function)))
(make-instance 'reference :hash hash)))
(:method ((tag (eql 7)) function) (:method ((tag (eql 7)) function)
(declare (ignore function)) (declare (ignore function))
:true) :true)
......
...@@ -40,11 +40,17 @@ ...@@ -40,11 +40,17 @@
(dolist (element l) (dolist (element l)
(binary-render-to-function element function))) (binary-render-to-function element function)))
(:method ((r reference) function) (:method ((r reference) function)
(write-type-tag 6 function) (let ((bytes (babel:string-to-octets (reference-hash r)
(funcall function (reference-hash r))) :encoding :utf-8)))
(write-type-tag 6 function)
(write-integer (length bytes) function)
(funcall function bytes)))
(:method ((o object) function) (:method ((o object) function)
(write-type-tag 6 function) (let ((bytes (babel:string-to-octets (hash-object* o)
(funcall function (hash-object o))) :encoding :utf-8)))
(write-type-tag 6 function)
(write-integer (length bytes) function)
(funcall function bytes)))
(:method ((x (eql ':true)) function) (:method ((x (eql ':true)) function)
(write-type-tag 7 function)) (write-type-tag 7 function))
(:method ((x (eql ':false)) function) (:method ((x (eql ':false)) function)
......
...@@ -49,11 +49,9 @@ ...@@ -49,11 +49,9 @@
(define-codec ref (define-codec ref
(lambda (reference) (lambda (reference)
(check-type reference reference) (check-type reference reference)
(bytes->base64 (reference-hash reference))) (reference-hash reference))
(lambda (string) (lambda (string)
(make-instance 'reference (make-instance 'reference :hash string)))
:hash (coerce (subseq (base64->bytes string) 0 32)
'(vector (unsigned-byte 8))))))
(defun find-codec (name type) (defun find-codec (name type)
(let ((codec-definition (gethash name *codecs*))) (let ((codec-definition (gethash name *codecs*)))
......
...@@ -23,7 +23,7 @@ ...@@ -23,7 +23,7 @@
(:method ((vague-object vague-object)) (:method ((vague-object vague-object))
(base-hash-object vague-object)) (base-hash-object vague-object))
(:method ((reference reference)) (:method ((reference reference))
(reference-hash reference))) (base64->bytes (reference-hash reference))))
(defun hash-object* (object) (defun hash-object* (object)
"Generate a hash for an object using HASH-OBJECT, but then base64-encode it. This seems common enough to deserve a function." "Generate a hash for an object using HASH-OBJECT, but then base64-encode it. This seems common enough to deserve a function."
......
...@@ -61,11 +61,8 @@ Providing the class option (:scripts script ...) will attach the initialisation ...@@ -61,11 +61,8 @@ Providing the class option (:scripts script ...) will attach the initialisation
appending (netfarm-class-scripts class)))))) appending (netfarm-class-scripts class))))))
(defmethod initialize-instance :after ((class netfarm-class) &key) (defmethod initialize-instance :after ((class netfarm-class) &key)
;; This variable is introduced after the MOP stuff is loaded.
(declare (special *netfarm-classes*))
(force-script-data-evaluation class) (force-script-data-evaluation class)
(setf (gethash (netfarm-class-name class) *netfarm-classes*) (intern-class class))
class))
(defmethod reinitialize-instance :after ((class netfarm-class) &key) (defmethod reinitialize-instance :after ((class netfarm-class) &key)
(force-script-data-evaluation class)) (force-script-data-evaluation class))
......
...@@ -20,6 +20,16 @@ ...@@ -20,6 +20,16 @@
(closer-mop:slot-value-using-class source-class source slot)))) (closer-mop:slot-value-using-class source-class source slot))))
(initialize-instance target))) (initialize-instance target)))
(defun find-schema-in-table (hash table)
(alexandria:if-let ((class (gethash hash table)))
(class->schema class)))
(defun reference-replacement (hash function)
"Find an object with a given hash, possibly calling the function if the object is not known internally."
(or (gethash hash *inbuilt-objects*)
(find-schema-in-table hash *inbuilt-classes*)
(find-schema-in-table hash *classes*)
(funcall function hash)))
(defun rewrite-graph (graph object-source-function) (defun rewrite-graph (graph object-source-function)
(let ((visited (make-hash-table)) (let ((visited (make-hash-table))
(to-visit (list graph))) (to-visit (list graph)))
...@@ -31,9 +41,10 @@ ...@@ -31,9 +41,10 @@
(push (car object) to-visit) (push (car object) to-visit)
(push (cdr object) to-visit)) (push (cdr object) to-visit))
(reference (reference
(assert (stringp (reference-hash object)))
(overwrite-instance object (overwrite-instance object
(funcall object-source-function (reference-replacement (reference-hash object)
(reference-hash object))) object-source-function))
(initialize-instance object)) (initialize-instance object))
(hash-table (hash-table
(maphash (lambda (key value) (maphash (lambda (key value)
......
(in-package :netfarm)
;;; Hash consing schema->class
(defvar *classes*
(trivial-garbage:make-weak-hash-table :test 'equal
:weakness :value
:weakness-matters nil)
"A table that maps schema hashes to Netfarm classes.")
;;; Hash consing class->schema
(defvar *schemas*
(trivial-garbage:make-weak-hash-table :test 'eq
:weakness :value
:weakness-matters nil)
"A table that maps Netfarm classes to schemas.")
(defgeneric intern-class (class)
(:method ((class netfarm-class))
(let ((schema (class->schema class)))
(setf (gethash (hash-object* schema) *classes*) class
(gethash class *schemas*) schema))))
(in-package :netfarm) (in-package :netfarm)
;;; Inbuilt objects (not classes) ;;; Inbuilt objects (not classes)
(defvar *objects* (defclass named-mixin ()
(trivial-garbage:make-weak-hash-table :test 'equal ((inbuilt-name :initarg :inbuilt-name :type string :reader named-mixin-name)))
:weakness :value
:weakness-matters t) (defun make-named-instance (class name &rest initargs)
"A table that maps hashes to inbuilt objects.") (apply #'make-instance
(make-instance 'standard-class
(defun pin-object (object) :direct-superclasses (list class (find-class 'named-mixin)))
"Mark an object as \"inbuilt\", allowing it to be retrieved via INBUILT-OBJECT." :inbuilt-name name
(setf (gethash (hash-object* object) *objects*) initargs))
(defvar *inbuilt-objects*
(trivial-garbage:make-weak-hash-table :test 'equal)
"A table that maps names to inbuilt objects.")
(defmethod initialize-instance :after ((object named-mixin) &key)
(setf (gethash (named-mixin-name object) *inbuilt-objects*)
object)) object))
(defun inbuilt-object (hash) (defun inbuilt-object (hash)
"Returns the inbuilt object with given hash, or returns NIL if there isn't such an object." "Returns the inbuilt object with given hash, or returns NIL if there isn't such an object."
(values (gethash hash *objects*))) (values (gethash hash *inbuilt-objects* nil)))
;;; Inbuilt classes ;;; Inbuilt classes
(defvar *netfarm-classes* (defvar *inbuilt-classes* (make-hash-table :test 'equal)
(trivial-garbage:make-weak-hash-table :test 'equal "A table that maps names to inbuilt classes.")
:weakness :value
:weakness-matters nil)
"A table that maps schema hashes to Netfarm classes.")
(defclass inbuilt-netfarm-class (netfarm-class) (defclass inbuilt-netfarm-class (netfarm-class)
((names :initarg :schema-names :reader netfarm-class-schema-names)) ((schema-names :initarg :schema-name :reader inbuilt-netfarm-class-schema-names))
(:documentation "A class for definining inbuilt Netfarm classes (which have names that are not hash names). (:documentation "A class for definining inbuilt Netfarm classes (which have names that are not hash names).
Don't ever ever ever use this outside of the Netfarm system definition, or you will create inconsistent state w.r.t the rest of the world and no one will like you.")) Don't ever ever ever use this outside of the Netfarm system, or you will create inconsistent state w.r.t the rest of the world and no one will like you."))
(defmethod initialize-instance :after ((class inbuilt-netfarm-class) &key) (defmethod initialize-instance :after ((class inbuilt-netfarm-class) &key)
(dolist (name (netfarm-class-schema-names class)) (assert (= (length (inbuilt-netfarm-class-schema-names class)) 1)))
(setf (gethash name *netfarm-classes*) class)))
(defmethod netfarm-class-name ((class inbuilt-netfarm-class))
(first (netfarm-class-schema-names class)))
;;; Hash consing class->schema (defmethod intern-class ((class inbuilt-netfarm-class))
(setf (gethash (netfarm-class-name class) *inbuilt-classes*) class)
(unless (eql (class-name class) 'schema)
;; We can't create the schema of the schema until the class has been bound.
(let ((schema (class->schema class)))
(setf (gethash class *schemas*) schema))))
(defvar *schemas* (defmethod netfarm-class-name ((class inbuilt-netfarm-class))
(trivial-garbage:make-weak-hash-table :test 'eq (first (inbuilt-netfarm-class-schema-names class)))
:weakness :value
:weakness-matters nil)
"A table that maps Netfarm classes to schemas.")
(in-package :netfarm) (in-package :netfarm)
;;; Some inbuilt classes. ;;; Some inbuilt classes.
(defclass schema () (defclass schema ()
((slots :initarg :slots :reader schema-slots) ((slots :initarg :slots :reader schema-slots)
(computed-slots :initarg :computed-slots :reader schema-computed-slots) (computed-slots :initarg :computed-slots :reader schema-computed-slots)
...@@ -10,15 +9,17 @@ ...@@ -10,15 +9,17 @@
(scripts :initarg :scripts :reader schema-scripts) (scripts :initarg :scripts :reader schema-scripts)
(message-script :initarg :message-script (message-script :initarg :message-script
:reader schema-message-script :reader schema-message-script
:documentation "The script that is run when an instance of this schema receives a message. The first procedure in the script is called with the subject object, the object that sent the message, and the message itself as arguments.")) :documentation "The script that is run when an instance of this schema receives a message. The first procedure in the script is called with the subject object, the object that sent the message, and the message itself as arguments."))
(:metaclass inbuilt-netfarm-class) (:metaclass inbuilt-netfarm-class)
(:schema-names "inbuilt@schema")) (:schema-name "inbuilt@schema"))
(let ((schema-schema (class->schema (find-class 'schema))))
(setf (gethash (find-class 'schema) *schemas*) schema-schema))
(defclass user () (defclass user ()
((sign-key :initarg :sign-key :reader user-sign-key) ((sign-key :initarg :sign-key :reader user-sign-key)
(ecdh-key :initarg :ecdh-key :reader user-ecdh-key)) (ecdh-key :initarg :ecdh-key :reader user-ecdh-key))
(:metaclass inbuilt-netfarm-class) (:metaclass inbuilt-netfarm-class)
(:schema-names "inbuilt@user")) (:schema-name "inbuilt@user"))
(defclass user-map () (defclass user-map ()
((antitriples :initarg :antitriples ((antitriples :initarg :antitriples
...@@ -31,4 +32,4 @@ ...@@ -31,4 +32,4 @@
:initform '() :initform '()
:reader user-map-delegates)) :reader user-map-delegates))
(:metaclass inbuilt-netfarm-class) (:metaclass inbuilt-netfarm-class)
(:schema-names "inbuilt@map")) (:schema-name "inbuilt@map"))
...@@ -10,7 +10,7 @@ ...@@ -10,7 +10,7 @@
(define-tuple reference () (define-tuple reference ()
((hash :read-only t)) ((hash :read-only t))
"A reference to a hash-named object from a source.") "A reference to an object.")
(macrolet ((mht () '(make-hash-table :test 'equal))) (macrolet ((mht () '(make-hash-table :test 'equal)))
(define-tuple vague-object () (define-tuple vague-object ()
...@@ -74,7 +74,7 @@ ...@@ -74,7 +74,7 @@
(list (vague-object-schema-name vague-object)) (list (vague-object-schema-name vague-object))
(let ((reference-hashes '())) (let ((reference-hashes '()))
(map-references (lambda (reference) (map-references (lambda (reference)
(push (bytes->base64 (reference-hash reference)) (push (reference-hash reference)
reference-hashes)) reference-hashes))
vague-object) vague-object)
reference-hashes) reference-hashes)
......
(in-package :netfarm) (in-package :netfarm)
(defvar *netfarm-classes*
(trivial-garbage:make-weak-hash-table :test 'equal
:weakness :value
:weakness-matters nil))
(defvar *schemas*
(trivial-garbage:make-weak-hash-table :test 'eq
:weakness :value
:weakness-matters nil))
(defun apply-class (vague-object class) (defun apply-class (vague-object class)
"Apply the class CLASS to a VAGUE-OBJECT, matching slot names and types with "Apply the class CLASS to a VAGUE-OBJECT, matching slot names and types with
keys in the vague-object's values table." keys in the vague-object's values table."
...@@ -44,12 +35,11 @@ keys in the vague-object's values table." ...@@ -44,12 +35,11 @@ keys in the vague-object's values table."
(defun find-netfarm-class (name &optional (error? t)) (defun find-netfarm-class (name &optional (error? t))
"Find a Netfarm class with the provided name. If no such class exists and ERROR? is true, a NETFARM-CLASS-NOT-FOUND error will be signalled. If no such class exists and ERROR? is false, NIL will be returned." "Find a Netfarm class with the provided name. If no such class exists and ERROR? is true, a NETFARM-CLASS-NOT-FOUND error will be signalled. If no such class exists and ERROR? is false, NIL will be returned."
(multiple-value-bind (class present?) (or (gethash name *classes*)
(gethash name *netfarm-classes*) (gethash name *inbuilt-classes*)
(cond (if error?
(present? class) (error 'netfarm-class-not-found :class-name name)
(error? (error 'netfarm-class-not-found :class-name name)) nil)))
(t nil))))
;;; Convert schemas to classes and back. ;;; Convert schemas to classes and back.
...@@ -85,7 +75,7 @@ keys in the vague-object's values table." ...@@ -85,7 +75,7 @@ keys in the vague-object's values table."
(defun schema->class (schema &key slot-names) (defun schema->class (schema &key slot-names)
"Convert a schema into a NETFARM-CLASS. If a class already exists that corresponds to the schema, it is returned. Otherwise, a new schema is returned. If the association list SLOT-NAMES is provided, each slot name will be looked up in the association list, and the values will be used as slot names instead of creating uninterned symbols." "Convert a schema into a NETFARM-CLASS. If a class already exists that corresponds to the schema, it is returned. Otherwise, a new schema is returned. If the association list SLOT-NAMES is provided, each slot name will be looked up in the association list, and the values will be used as slot names instead of creating uninterned symbols."
(with-cache ((hash-object* schema) *netfarm-classes* :write-back nil) (with-cache ((hash-object* schema) *classes* :write-back nil)
(make-instance 'netfarm-class (make-instance 'netfarm-class
:name (make-symbol (hash-object* schema)) :name (make-symbol (hash-object* schema))
:documentation (schema-documentation schema) :documentation (schema-documentation schema)
...@@ -102,7 +92,6 @@ keys in the vague-object's values table." ...@@ -102,7 +92,6 @@ keys in the vague-object's values table."
(loop for (name . slot-definition) (loop for (name . slot-definition)
in (string-hash-table->alist slot-definition-table) in (string-hash-table->alist slot-definition-table)
collect (slot-definition->netfarm-slot name slot-definition))) collect (slot-definition->netfarm-slot name slot-definition)))
(defun class->schema (class) (defun class->schema (class)
"Convert a NETFARM-CLASS into a schema. If a schema for this class already exists, it is returned." "Convert a NETFARM-CLASS into a schema. If a schema for this class already exists, it is returned."
......
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
(program :initarg :program :reader script-program) (program :initarg :program :reader script-program)
(variables :initarg :variables :reader script-variables)) (variables :initarg :variables :reader script-variables))
(:metaclass netfarm::inbuilt-netfarm-class) (:metaclass netfarm::inbuilt-netfarm-class)
(:schema-names "inbuilt@script")) (:schema-name "inbuilt@script"))
(deftype reasonably-sized-natural () (deftype reasonably-sized-natural ()
"Well, I hope this is a subset of the implementation's FIXNUM type. But still." "Well, I hope this is a subset of the implementation's FIXNUM type. But still."
......
...@@ -135,10 +135,10 @@ string; but RENDER-OBJECT will emit Netfarm standard format text.")) ...@@ -135,10 +135,10 @@ string; but RENDER-OBJECT will emit Netfarm standard format text."))
(defgeneric render-to-stream (object stream) (defgeneric render-to-stream (object stream)
(:documentation "Render a Netfarm value to a stream.") (:documentation "Render a Netfarm value to a stream.")
(:method ((ref reference) stream) (:method ((ref reference) stream)
(format stream "ref:~a" (assert (stringp (reference-hash ref)))
(bytes->base64 (reference-hash ref)))) (format stream "ref:~a" (reference-hash ref)))
(:method ((object object) stream) (:method ((object object) stream)
(format stream "ref:~a" (bytes->base64 (hash-object object)))) (format stream "ref:~a" (hash-object* object)))
(:method ((string integer) stream) (:method ((string integer) stream)
(format stream "integer:~d" string)) (format stream "integer:~d" string))
(:method ((true (eql :true)) stream) (:method ((true (eql :true)) stream)
......
...@@ -21,11 +21,13 @@ ...@@ -21,11 +21,13 @@
(:file "netfarm-class") (:file "netfarm-class")
(:file "netfarm-slot"))) (:file "netfarm-slot")))
(:file "objects") (:file "objects")
(:file "schema")
(:file "type-specifiers") (:file "type-specifiers")
(:file "hash-classes")
(:file "inbuilt-objects") (:file "inbuilt-objects")
(:file "schema")
(:file "computed-values") (:file "computed-values")
(:file "deep-copy"))) (:file "deep-copy")
(:file "inbuilt-schemas")))
(:module "Scripts" (:module "Scripts"
:depends-on ("Objects") :depends-on ("Objects")
:serial t :serial t
...@@ -45,7 +47,6 @@ ...@@ -45,7 +47,6 @@
(:module "Reference-side-effects" (:module "Reference-side-effects"
:components ((:file "apply-side-effect") :components ((:file "apply-side-effect")
(:file "run-scripts"))))) (:file "run-scripts")))))
(:file "Objects/inbuilt-schemas" :depends-on ("Objects"))
(:module "Text-format" (:module "Text-format"
:depends-on ("Codecs" "Objects") :depends-on ("Codecs" "Objects")
:components ((:file "new-parser") :components ((:file "new-parser")
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment