From 6d61499758d5fa732a4f34d7b768377787952dc6 Mon Sep 17 00:00:00 2001 From: theemacsshibe Date: Sat, 18 Apr 2020 18:02:05 +1000 Subject: [PATCH] Rewrite the inbuilt object and class hashing mechanisms --- Code/Binary-format/parser.lisp | 15 ++--- Code/Binary-format/renderer.lisp | 14 +++-- Code/Codecs/codecs.lisp | 6 +- Code/Crypto/hash.lisp | 2 +- Code/Objects/MOP/netfarm-class.lisp | 5 +- Code/Objects/MOP/rewrite-references.lisp | 15 ++++- Code/Objects/hash-classes.lisp | 21 +++++++ Code/Objects/inbuilt-objects.lisp | 59 ++++++++++--------- Code/Objects/inbuilt-schemas.lisp | 11 ++-- Code/Objects/objects.lisp | 4 +- Code/Objects/schema.lisp | 23 ++------ .../Script-machine/script-machine.lisp | 2 +- Code/Text-format/new-renderer.lisp | 6 +- Code/netfarm.asd | 7 ++- 14 files changed, 109 insertions(+), 81 deletions(-) create mode 100644 Code/Objects/hash-classes.lisp diff --git a/Code/Binary-format/parser.lisp b/Code/Binary-format/parser.lisp index f7d5099..e9aa037 100644 --- a/Code/Binary-format/parser.lisp +++ b/Code/Binary-format/parser.lisp @@ -15,11 +15,14 @@ (setf (aref vector n) (funcall function))) 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) (:method ((tag (eql 1)) function) - (babel:octets-to-string (read-byte-vector function - (read-integer function)) - :encoding :utf-8)) + (read-string function)) (:method ((tag (eql 2)) function) (read-byte-vector function (read-integer function))) (:method ((tag (eql 3)) function) @@ -35,10 +38,8 @@ (loop repeat length collect (binary-parse-from-function function)))) (:method ((tag (eql 6)) function) - (let ((hash (make-array 32 :element-type '(unsigned-byte 8)))) - (dotimes (n 32) - (setf (aref hash n) (funcall function))) - (make-instance 'reference :hash hash))) + (make-instance 'reference + :hash (read-string function))) (:method ((tag (eql 7)) function) (declare (ignore function)) :true) diff --git a/Code/Binary-format/renderer.lisp b/Code/Binary-format/renderer.lisp index 06d6fda..0376cc7 100644 --- a/Code/Binary-format/renderer.lisp +++ b/Code/Binary-format/renderer.lisp @@ -40,11 +40,17 @@ (dolist (element l) (binary-render-to-function element function))) (:method ((r reference) function) - (write-type-tag 6 function) - (funcall function (reference-hash r))) + (let ((bytes (babel:string-to-octets (reference-hash r) + :encoding :utf-8))) + (write-type-tag 6 function) + (write-integer (length bytes) function) + (funcall function bytes))) (:method ((o object) function) - (write-type-tag 6 function) - (funcall function (hash-object o))) + (let ((bytes (babel:string-to-octets (hash-object* o) + :encoding :utf-8))) + (write-type-tag 6 function) + (write-integer (length bytes) function) + (funcall function bytes))) (:method ((x (eql ':true)) function) (write-type-tag 7 function)) (:method ((x (eql ':false)) function) diff --git a/Code/Codecs/codecs.lisp b/Code/Codecs/codecs.lisp index 7263b23..552cf45 100644 --- a/Code/Codecs/codecs.lisp +++ b/Code/Codecs/codecs.lisp @@ -49,11 +49,9 @@ (define-codec ref (lambda (reference) (check-type reference reference) - (bytes->base64 (reference-hash reference))) + (reference-hash reference)) (lambda (string) - (make-instance 'reference - :hash (coerce (subseq (base64->bytes string) 0 32) - '(vector (unsigned-byte 8)))))) + (make-instance 'reference :hash string))) (defun find-codec (name type) (let ((codec-definition (gethash name *codecs*))) diff --git a/Code/Crypto/hash.lisp b/Code/Crypto/hash.lisp index cc55097..b685583 100644 --- a/Code/Crypto/hash.lisp +++ b/Code/Crypto/hash.lisp @@ -23,7 +23,7 @@ (:method ((vague-object vague-object)) (base-hash-object vague-object)) (:method ((reference reference)) - (reference-hash reference))) + (base64->bytes (reference-hash reference)))) (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." diff --git a/Code/Objects/MOP/netfarm-class.lisp b/Code/Objects/MOP/netfarm-class.lisp index 125ba1c..be40271 100644 --- a/Code/Objects/MOP/netfarm-class.lisp +++ b/Code/Objects/MOP/netfarm-class.lisp @@ -61,11 +61,8 @@ Providing the class option (:scripts script ...) will attach the initialisation appending (netfarm-class-scripts class)))))) (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) - (setf (gethash (netfarm-class-name class) *netfarm-classes*) - class)) + (intern-class class)) (defmethod reinitialize-instance :after ((class netfarm-class) &key) (force-script-data-evaluation class)) diff --git a/Code/Objects/MOP/rewrite-references.lisp b/Code/Objects/MOP/rewrite-references.lisp index ecbaf4e..0106655 100644 --- a/Code/Objects/MOP/rewrite-references.lisp +++ b/Code/Objects/MOP/rewrite-references.lisp @@ -20,6 +20,16 @@ (closer-mop:slot-value-using-class source-class source slot)))) (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) (let ((visited (make-hash-table)) (to-visit (list graph))) @@ -31,9 +41,10 @@ (push (car object) to-visit) (push (cdr object) to-visit)) (reference + (assert (stringp (reference-hash object))) (overwrite-instance object - (funcall object-source-function - (reference-hash object))) + (reference-replacement (reference-hash object) + object-source-function)) (initialize-instance object)) (hash-table (maphash (lambda (key value) diff --git a/Code/Objects/hash-classes.lisp b/Code/Objects/hash-classes.lisp new file mode 100644 index 0000000..fc8c206 --- /dev/null +++ b/Code/Objects/hash-classes.lisp @@ -0,0 +1,21 @@ +(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)))) diff --git a/Code/Objects/inbuilt-objects.lisp b/Code/Objects/inbuilt-objects.lisp index bd8154f..5d51f28 100644 --- a/Code/Objects/inbuilt-objects.lisp +++ b/Code/Objects/inbuilt-objects.lisp @@ -1,43 +1,46 @@ (in-package :netfarm) ;;; Inbuilt objects (not classes) -(defvar *objects* - (trivial-garbage:make-weak-hash-table :test 'equal - :weakness :value - :weakness-matters t) - "A table that maps hashes to inbuilt objects.") - -(defun pin-object (object) - "Mark an object as \"inbuilt\", allowing it to be retrieved via INBUILT-OBJECT." - (setf (gethash (hash-object* object) *objects*) +(defclass named-mixin () + ((inbuilt-name :initarg :inbuilt-name :type string :reader named-mixin-name))) + +(defun make-named-instance (class name &rest initargs) + (apply #'make-instance + (make-instance 'standard-class + :direct-superclasses (list class (find-class 'named-mixin))) + :inbuilt-name name + 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)) + (defun inbuilt-object (hash) "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 -(defvar *netfarm-classes* - (trivial-garbage:make-weak-hash-table :test 'equal - :weakness :value - :weakness-matters nil) - "A table that maps schema hashes to Netfarm classes.") +(defvar *inbuilt-classes* (make-hash-table :test 'equal) + "A table that maps names to inbuilt classes.") (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). -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) - (dolist (name (netfarm-class-schema-names class)) - (setf (gethash name *netfarm-classes*) class))) - -(defmethod netfarm-class-name ((class inbuilt-netfarm-class)) - (first (netfarm-class-schema-names class))) + (assert (= (length (inbuilt-netfarm-class-schema-names class)) 1))) -;;; 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* - (trivial-garbage:make-weak-hash-table :test 'eq - :weakness :value - :weakness-matters nil) - "A table that maps Netfarm classes to schemas.") +(defmethod netfarm-class-name ((class inbuilt-netfarm-class)) + (first (inbuilt-netfarm-class-schema-names class))) diff --git a/Code/Objects/inbuilt-schemas.lisp b/Code/Objects/inbuilt-schemas.lisp index d8b09a9..4abf789 100644 --- a/Code/Objects/inbuilt-schemas.lisp +++ b/Code/Objects/inbuilt-schemas.lisp @@ -1,7 +1,6 @@ (in-package :netfarm) ;;; Some inbuilt classes. - (defclass schema () ((slots :initarg :slots :reader schema-slots) (computed-slots :initarg :computed-slots :reader schema-computed-slots) @@ -10,15 +9,17 @@ (scripts :initarg :scripts :reader schema-scripts) (message-script :initarg :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) - (: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 () ((sign-key :initarg :sign-key :reader user-sign-key) (ecdh-key :initarg :ecdh-key :reader user-ecdh-key)) (:metaclass inbuilt-netfarm-class) - (:schema-names "inbuilt@user")) + (:schema-name "inbuilt@user")) (defclass user-map () ((antitriples :initarg :antitriples @@ -31,4 +32,4 @@ :initform '() :reader user-map-delegates)) (:metaclass inbuilt-netfarm-class) - (:schema-names "inbuilt@map")) + (:schema-name "inbuilt@map")) diff --git a/Code/Objects/objects.lisp b/Code/Objects/objects.lisp index fca4a46..f3ca0a7 100644 --- a/Code/Objects/objects.lisp +++ b/Code/Objects/objects.lisp @@ -10,7 +10,7 @@ (define-tuple reference () ((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))) (define-tuple vague-object () @@ -74,7 +74,7 @@ (list (vague-object-schema-name vague-object)) (let ((reference-hashes '())) (map-references (lambda (reference) - (push (bytes->base64 (reference-hash reference)) + (push (reference-hash reference) reference-hashes)) vague-object) reference-hashes) diff --git a/Code/Objects/schema.lisp b/Code/Objects/schema.lisp index 140408c..676e767 100644 --- a/Code/Objects/schema.lisp +++ b/Code/Objects/schema.lisp @@ -1,14 +1,5 @@ (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) "Apply the class CLASS to a VAGUE-OBJECT, matching slot names and types with 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)) "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?) - (gethash name *netfarm-classes*) - (cond - (present? class) - (error? (error 'netfarm-class-not-found :class-name name)) - (t nil)))) + (or (gethash name *classes*) + (gethash name *inbuilt-classes*) + (if error? + (error 'netfarm-class-not-found :class-name name) + nil))) ;;; Convert schemas to classes and back. @@ -85,7 +75,7 @@ keys in the vague-object's values table." (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." - (with-cache ((hash-object* schema) *netfarm-classes* :write-back nil) + (with-cache ((hash-object* schema) *classes* :write-back nil) (make-instance 'netfarm-class :name (make-symbol (hash-object* schema)) :documentation (schema-documentation schema) @@ -102,7 +92,6 @@ keys in the vague-object's values table." (loop for (name . slot-definition) in (string-hash-table->alist slot-definition-table) collect (slot-definition->netfarm-slot name slot-definition))) - (defun class->schema (class) "Convert a NETFARM-CLASS into a schema. If a schema for this class already exists, it is returned." diff --git a/Code/Scripts/Script-machine/script-machine.lisp b/Code/Scripts/Script-machine/script-machine.lisp index 48b3996..52cabf7 100644 --- a/Code/Scripts/Script-machine/script-machine.lisp +++ b/Code/Scripts/Script-machine/script-machine.lisp @@ -5,7 +5,7 @@ (program :initarg :program :reader script-program) (variables :initarg :variables :reader script-variables)) (:metaclass netfarm::inbuilt-netfarm-class) - (:schema-names "inbuilt@script")) + (:schema-name "inbuilt@script")) (deftype reasonably-sized-natural () "Well, I hope this is a subset of the implementation's FIXNUM type. But still." diff --git a/Code/Text-format/new-renderer.lisp b/Code/Text-format/new-renderer.lisp index 859588c..89252fd 100644 --- a/Code/Text-format/new-renderer.lisp +++ b/Code/Text-format/new-renderer.lisp @@ -135,10 +135,10 @@ string; but RENDER-OBJECT will emit Netfarm standard format text.")) (defgeneric render-to-stream (object stream) (:documentation "Render a Netfarm value to a stream.") (:method ((ref reference) stream) - (format stream "ref:~a" - (bytes->base64 (reference-hash ref)))) + (assert (stringp (reference-hash ref))) + (format stream "ref:~a" (reference-hash ref))) (:method ((object object) stream) - (format stream "ref:~a" (bytes->base64 (hash-object object)))) + (format stream "ref:~a" (hash-object* object))) (:method ((string integer) stream) (format stream "integer:~d" string)) (:method ((true (eql :true)) stream) diff --git a/Code/netfarm.asd b/Code/netfarm.asd index 4fcca7a..9f3013b 100644 --- a/Code/netfarm.asd +++ b/Code/netfarm.asd @@ -21,11 +21,13 @@ (:file "netfarm-class") (:file "netfarm-slot"))) (:file "objects") - (:file "schema") (:file "type-specifiers") + (:file "hash-classes") (:file "inbuilt-objects") + (:file "schema") (:file "computed-values") - (:file "deep-copy"))) + (:file "deep-copy") + (:file "inbuilt-schemas"))) (:module "Scripts" :depends-on ("Objects") :serial t @@ -45,7 +47,6 @@ (:module "Reference-side-effects" :components ((:file "apply-side-effect") (:file "run-scripts"))))) - (:file "Objects/inbuilt-schemas" :depends-on ("Objects")) (:module "Text-format" :depends-on ("Codecs" "Objects") :components ((:file "new-parser") -- GitLab