From e094f484b66b34b9b116c0bd7ebd822fdc082b57 Mon Sep 17 00:00:00 2001 From: theemacsshibe Date: Thu, 13 Feb 2020 13:15:29 +1100 Subject: [PATCH] Bind interpreter registers instead of an interpreter structure in DEFINE-OPCODEs, use lexical variables for registers --- Code/Crypto/hash.lisp | 1 + Code/Objects/inbuilt-netfarm-class.lisp | 16 ++ Code/Objects/inbuilt-schemas.lisp | 14 +- Code/Objects/mop.lisp | 17 +- Code/Objects/schema.lisp | 8 +- Code/Scripts/assemble.lisp | 32 ---- Code/Scripts/case-discriminator-function.lisp | 50 ------ Code/Scripts/conditions.lisp | 20 --- Code/Scripts/control-flow.lisp | 9 +- Code/Scripts/define-script.lisp | 8 - Code/Scripts/discriminator-function.lisp | 68 -------- Code/Scripts/environments.lisp | 41 ----- Code/Scripts/forthisms.lisp | 16 -- Code/Scripts/objects.lisp | 46 ------ Code/Scripts/opcode-information.lisp | 80 ---------- Code/Scripts/operators.lisp | 74 --------- Code/Scripts/script-machine.lisp | 147 ------------------ Code/Server/Protocol/decentralise2.lisp | 4 - Code/Server/Protocol/dependency-graph.lisp | 53 +------ Code/Server/Protocol/interpreters.lisp | 80 ++-------- Code/Server/Protocol/side-effects.lisp | 15 -- Code/Server/Protocol/system.lisp | 4 + Code/Server/Stages/decentralise2.lisp | 49 ++++++ Code/Server/Stages/dependency-resolution.lisp | 26 ++++ .../initialisation-script-machines.lisp | 26 ++++ Code/Server/netfarm-server.asd | 5 +- Code/netfarm.asd | 36 +++-- Tests/benchmark.lisp | 17 +- Tests/server-client.lisp | 2 +- 29 files changed, 194 insertions(+), 770 deletions(-) create mode 100644 Code/Objects/inbuilt-netfarm-class.lisp delete mode 100644 Code/Scripts/assemble.lisp delete mode 100644 Code/Scripts/case-discriminator-function.lisp delete mode 100644 Code/Scripts/conditions.lisp delete mode 100644 Code/Scripts/define-script.lisp delete mode 100644 Code/Scripts/discriminator-function.lisp delete mode 100644 Code/Scripts/environments.lisp delete mode 100644 Code/Scripts/forthisms.lisp delete mode 100644 Code/Scripts/objects.lisp delete mode 100644 Code/Scripts/opcode-information.lisp delete mode 100644 Code/Scripts/operators.lisp delete mode 100644 Code/Scripts/script-machine.lisp create mode 100644 Code/Server/Stages/decentralise2.lisp create mode 100644 Code/Server/Stages/dependency-resolution.lisp create mode 100644 Code/Server/Stages/initialisation-script-machines.lisp diff --git a/Code/Crypto/hash.lisp b/Code/Crypto/hash.lisp index 1962744..5484f30 100644 --- a/Code/Crypto/hash.lisp +++ b/Code/Crypto/hash.lisp @@ -1,5 +1,6 @@ (in-package :netfarm) +(declaim (inline hash-text)) (defun hash-text (text) (declare (string text)) (digest-sequence :sha256 (babel:string-to-octets text :encoding :utf-8))) diff --git a/Code/Objects/inbuilt-netfarm-class.lisp b/Code/Objects/inbuilt-netfarm-class.lisp new file mode 100644 index 0000000..874a84b --- /dev/null +++ b/Code/Objects/inbuilt-netfarm-class.lisp @@ -0,0 +1,16 @@ +(in-package :netfarm) + +;;; A class for definining inbuilt Netfarm classes (which have names that are +;;; not hash names). + +(defclass inbuilt-netfarm-class (netfarm-class) + ((names :initarg :schema-names :reader netfarm-class-schema-names))) + +(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)) + (if (null (netfarm-class-schema-names class)) + (call-next-method) + (first (netfarm-class-schema-names class)))) diff --git a/Code/Objects/inbuilt-schemas.lisp b/Code/Objects/inbuilt-schemas.lisp index 4ac4bdb..cf6eea2 100644 --- a/Code/Objects/inbuilt-schemas.lisp +++ b/Code/Objects/inbuilt-schemas.lisp @@ -1,17 +1,5 @@ (in-package :netfarm) -(defclass inbuilt-netfarm-class (netfarm-class) - ((names :initarg :schema-names :reader netfarm-class-schema-names))) - -(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)) - (if (null (netfarm-class-schema-names class)) - (call-next-method) - (first (netfarm-class-schema-names class)))) - ;;; Some inbuilt classes. (defclass schema () @@ -19,7 +7,7 @@ (documentation :initarg :documentation :accessor schema-documentation) (presentation-script :initarg :presentation-script :accessor schema-presentation-script) (scripts :initarg :scripts :accessor schema-scripts) - (allow-scripts :initarg :allowed-scripts :accessor schema-allowed-scripts)) + (message-script :initarg :message-script :accessor schema-message-script)) (:metaclass inbuilt-netfarm-class) (:schema-names "inbuilt@schema")) diff --git a/Code/Objects/mop.lisp b/Code/Objects/mop.lisp index d491a6c..6451cb5 100644 --- a/Code/Objects/mop.lisp +++ b/Code/Objects/mop.lisp @@ -3,10 +3,13 @@ ;;; The new, MOP-backed, Netfarm object implementation. (defclass netfarm-class (standard-class) - ((scripts :initform '() :initarg :scripts :reader netfarm-class-scripts) - (allowed-scripts :initform '() :initarg :allowed-scripts :reader netfarm-class-allowed-scripts) - (schema-names :initform '() :initarg :schema-names :reader netfarm-class-schema-names) - (presentation-script :initform nil :initarg :presentation-script :reader netfarm-class-presentation-script) + ((presentation-script :initform nil :initarg + :presentation-script + :reader netfarm-class-presentation-script) + (scripts :initform '() :initarg :scripts :reader netfarm-class-scripts) + (message-script :initform '() + :initarg :message-script + :reader netfarm-class-message-script) (slot-table :reader netfarm-class-slot-table))) (defmethod netfarm-class-slot-table :before ((class netfarm-class)) @@ -69,10 +72,10 @@ (defmethod closer-mop:finalize-inheritance :after ((class netfarm-class)) (let ((slot-table (make-string-hash-table))) (dolist (class (closer-mop:class-precedence-list class)) - (unless (eql class (find-class 'object)) + (when (typep class 'netfarm-class) (dolist (slot (closer-mop:class-direct-slots class)) - (when (typep slot 'netfarm-slot) - (let ((name (slot-netfarm-name slot))) + (let ((name (slot-netfarm-name slot))) + (unless (null name) (if (string-gethash slot-table name) (error "duplicate slot name: ~s" name) (setf (string-gethash slot-table name) diff --git a/Code/Objects/schema.lisp b/Code/Objects/schema.lisp index 0a657af..ae6221f 100644 --- a/Code/Objects/schema.lisp +++ b/Code/Objects/schema.lisp @@ -18,8 +18,8 @@ (not (slot-boundp class 'presentation-script))) nil (eval (first (netfarm-class-presentation-script class)))) - (slot-value class 'allowed-scripts) - (mapcar #'eval (netfarm-class-allowed-scripts class)))) + (slot-value class 'message-script) + (eval (netfarm-class-message-script class)))) (defmethod initialize-instance :after ((class netfarm-class) &key) @@ -91,7 +91,7 @@ keys in the vague-object's values table." :documentation ,(getf/string "documentation" properties))) :scripts (schema-scripts schema) :presentation-script (schema-presentation-script schema) - :allowed-scripts (schema-allowed-scripts schema))))) + :message-script (schema-message-script schema))))) (defun class->schema (class) "Convert a NETFARM-CLASS into a schema. If a schema for this class already exists, it is returned." (multiple-value-bind (known-schema present?) @@ -101,7 +101,7 @@ keys in the vague-object's values table." (setf (gethash class *schemas*) (make-instance 'schema :scripts (netfarm-class-scripts class) - :allowed-scripts (netfarm-class-allowed-scripts class) + :message-script (netfarm-class-message-script class) :presentation-script (netfarm-class-presentation-script class) :documentation (documentation class 'type) :slots (mapcar (alexandria:compose #'list #'car) diff --git a/Code/Scripts/assemble.lisp b/Code/Scripts/assemble.lisp deleted file mode 100644 index bf96d0a..0000000 --- a/Code/Scripts/assemble.lisp +++ /dev/null @@ -1,32 +0,0 @@ -(in-package :netfarm-scripts) - -(defun get-entry-points (code) - (loop with position = 0 - for item in code - for (name . args) = (alexandria:ensure-list item) - if (eql name :procedure) - collect (cons position args) - else - do (incf position (1+ (length args))))) - -(defun assemble-instruction (instruction) - (let ((instruction (alexandria:ensure-list instruction))) - (if (eql (car instruction) :procedure) - '() - (let ((opcode (position (car instruction) *opcode-data* - :key #'car :test #'string-equal))) - (assert (not (null opcode)) () "Unknown opcode ~a" (car instruction)) - (let ((argument-count (length (third (aref *opcode-data* opcode))))) - (assert (= (length (rest instruction)) argument-count) () - "Wanted ~d argument~:p for ~a, got ~d" - argument-count - (first instruction) - (length (third instruction))) - (cons opcode (cdr instruction))))))) - - -(defun assemble (code) - (coerce - (loop for instruction in code - append (assemble-instruction instruction)) - 'vector)) diff --git a/Code/Scripts/case-discriminator-function.lisp b/Code/Scripts/case-discriminator-function.lisp deleted file mode 100644 index 786498e..0000000 --- a/Code/Scripts/case-discriminator-function.lisp +++ /dev/null @@ -1,50 +0,0 @@ -(in-package :netfarm-scripts) - -;;; scymtym suggested SBCL's CASE might be faster now as it uses perfect -;;; hashing and a jump table to dispatch. - -;;; This is a hair slower than - -(defun make-discriminator-parts (operator-table) - (loop for operator across operator-table - for position from 0 - collect - `(,position - ,(if (eq operator (aref operator-table 255)) - `(go lose) - (destructuring-bind ((interpreter inputs bytes) declarations body) - (aref *opcode-code* position) - `(let ((,interpreter interpreter)) - (let (,@(loop for input in (reverse inputs) - collect `(,input (pop* (interpreter-data-stack ,interpreter)))) - ,@(loop for byte in bytes - collect `(,byte (interpreter-read-byte ,interpreter)))) - ,@declarations - ,body - (go out)))))))) - -(defun make-discriminator-function () - (compile nil - `(lambda (interpreter cons-limit cycle-limit) - (declare (optimize (speed 3) (safety 1)) - (interpreter interpreter) - ((or null fixnum) cons-limit cycle-limit) - #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note)) - (loop - (let ((opcode (aref (interpreter-program interpreter) - (interpreter-program-counter interpreter)))) - (declare ((unsigned-byte 8) opcode)) - (incf (interpreter-instruction-count interpreter)) - (incf (interpreter-program-counter interpreter)) - (tagbody - (case opcode . ,(make-discriminator-parts *operators*)) - lose - (error "illegal opcode ~d on ~s" - opcode interpreter) - out - (when (and (not (null cons-limit)) - (> (interpreter-cons-count interpreter) cons-limit)) - (error "exceeded cons limit")) - (when (and (not (null cycle-limit)) - (> (interpreter-instruction-count interpreter) cycle-limit)) - (error "exceeded cycle limit")))))))) diff --git a/Code/Scripts/conditions.lisp b/Code/Scripts/conditions.lisp deleted file mode 100644 index 198bcd6..0000000 --- a/Code/Scripts/conditions.lisp +++ /dev/null @@ -1,20 +0,0 @@ -(in-package :netfarm-scripts) - -(define-condition script-machine-signal () () - (:documentation "A signal created by the script machine when it wants to do something with the Netfarm universe. -The idea of this signal protocol is that some supervisor steps the script machine, and when it receives a signal, -it can either answer the signal or stash the machine's state if it cannot answer right away.")) - -(define-condition done (script-machine-signal) ()) - -(define-condition get-object (script-machine-signal) - ((name :initarg :name :reader get-object-name)) - (:documentation "Get the object by NAME and push it to the stack.")) - -(define-condition overflow (error) - ((operation :initarg :operation :reader overflow-operation) - (operands :initarg :operands :reader overflow-operands))) - -(define-condition no-capability (error) - ((operation :initarg :operation :reader no-capability-operation) - (cause :initarg :cause :reader no-capability-cause))) diff --git a/Code/Scripts/control-flow.lisp b/Code/Scripts/control-flow.lisp index d6650ae..13ef99f 100644 --- a/Code/Scripts/control-flow.lisp +++ b/Code/Scripts/control-flow.lisp @@ -34,7 +34,8 @@ (setf (interpreter-environment interpreter) (cons (make-frame interpreter argument-count) (procedure-environment function)) - (interpreter-program-counter interpreter) (procedure-entry-point function))) + (interpreter-program-counter interpreter) + (procedure-entry-point function))) ;;; 09: (call n) arg-1 ... arg-n function -- (define-opcode* 9 call (interpreter function) (n) @@ -56,8 +57,10 @@ ;;; 10: (cond-jump then-high then-low else-high else-low) test-value -- ;;; Let then = then-high * 256 + then-low, ;;; else = else-high * 256 + else-low -;;; Jump forwards `then` bytes if test-value is true, else jump forwards `else` bytes. -(define-opcode* 16 jump-cond (interpreter test-value) (then-high then-low else-high else-low) +;;; Jump forwards `then` bytes if test-value is true, else jump forwards `else` +;;; bytes. +(define-opcode* 16 jump-cond (interpreter test-value) + (then-high then-low else-high else-low) (let ((then (u8-pair->u16 then-high then-low)) (else (u8-pair->u16 else-high else-low))) (if (eql test-value :false) diff --git a/Code/Scripts/define-script.lisp b/Code/Scripts/define-script.lisp deleted file mode 100644 index cf80591..0000000 --- a/Code/Scripts/define-script.lisp +++ /dev/null @@ -1,8 +0,0 @@ -(in-package :netfarm-scripts) - -(defmacro define-script (variable-name (&rest variables) &body body) - `(defparameter ,variable-name - (make-instance (find-class 'script) - :entry-points (get-entry-points ',body) - :program (assemble ',body) - :variables ',variables))) diff --git a/Code/Scripts/discriminator-function.lisp b/Code/Scripts/discriminator-function.lisp deleted file mode 100644 index 1f68a34..0000000 --- a/Code/Scripts/discriminator-function.lisp +++ /dev/null @@ -1,68 +0,0 @@ -(in-package :netfarm-scripts) - -;;; This file implements another type of dispatch for the bytecode interpreter, -;;; which is similar to what is described in "Fast generic dispatch for Common -;;; Lisp" by Robert Strandh - -;;; This dispatch is expected to be faster on machines with slower memory than -;;; registers; as it replaces one table lookup with binary search that can be -;;; performed entirely in a register set. It also avoids a couple of function -;;; calls per cycle, which yields very impressive performance gains. - -(defvar *discriminator-function* nil) -(defun ensure-discriminator-function () - (when (null *discriminator-function*) - (setf *discriminator-function* (make-discriminator-function)))) - -(defun make-discriminator-parts (operator-table start end) - (declare (fixnum start end)) - (cond - ((= start (1- end)) - (let ((operator (aref operator-table start))) - (if (eq operator (aref operator-table 255)) - `(go lose) - (destructuring-bind ((interpreter inputs bytes) declarations body) - (aref *opcode-code* start) - `(let ((,interpreter interpreter)) - (let (,@(loop for input in (reverse inputs) - collect `(,input (pop* (interpreter-data-stack ,interpreter)))) - ,@(loop for byte in bytes - collect `(,byte (interpreter-read-byte ,interpreter)))) - ,@declarations - ,body - (go out))))))) - ((every (lambda (x) (eq x (aref operator-table 255))) - (subseq operator-table start end)) - '(go lose)) - (t - (let ((middle (floor (+ start end) 2))) - `(progn - (if (< opcode ,middle) - ,(make-discriminator-parts operator-table start middle) - ,(make-discriminator-parts operator-table middle end))))))) - -(defun make-discriminator-function () - (compile nil - `(lambda (interpreter cons-limit cycle-limit) - (declare (optimize (speed 3) (safety 1)) - (interpreter interpreter) - ((or null fixnum) cons-limit cycle-limit) - #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note)) - (loop - (let ((opcode (aref (interpreter-program interpreter) - (interpreter-program-counter interpreter)))) - (declare ((unsigned-byte 8) opcode)) - (incf (interpreter-instruction-count interpreter)) - (incf (interpreter-program-counter interpreter)) - (tagbody - ,(make-discriminator-parts *operators* 0 256) - lose - (error "illegal opcode ~d on ~s" - opcode interpreter) - out - (when (and (not (null cons-limit)) - (> (interpreter-cons-count interpreter) cons-limit)) - (error "exceeded cons limit")) - (when (and (not (null cycle-limit)) - (> (interpreter-instruction-count interpreter) cycle-limit)) - (error "exceeded cycle limit")))))))) diff --git a/Code/Scripts/environments.lisp b/Code/Scripts/environments.lisp deleted file mode 100644 index c33b313..0000000 --- a/Code/Scripts/environments.lisp +++ /dev/null @@ -1,41 +0,0 @@ -(in-package :netfarm-scripts) - -;;; Global state manipulation -;;; 01: (get-proc n) -- proc -(define-opcode 1 get-proc (interpreter) (n) - (let ((description (aref (interpreter-entry-points interpreter) n))) - (make-procedure :entry-point (procedure-description-entry-point description) - :arguments (procedure-description-arguments description) - :environment (interpreter-environment interpreter)))) - -;;; 06: (get-proc* n) -- proc -;;; Doesn't capture the lexical environment. Technically, top-level procedures -;;; will never access any lexical environment other than their arguments, but they -;;; still consume space. get-proc* in a way is to get-proc as tail-call is to call. -(define-opcode 6 get-proc* (interpreter) (n) - (let ((description (aref (interpreter-entry-points interpreter) n))) - (make-procedure :entry-point (procedure-description-entry-point description) - :arguments (procedure-description-arguments description) - :environment '()))) - -;;; 02: (get-value n) -- value -(define-opcode 2 get-value (interpreter) (n) - (aref (interpreter-variables interpreter) n)) -;;; 03: (set-value! n) new-value -- -(define-opcode* 3 set-value! (interpreter new-value) (n) - (setf (aref (interpreter-variables interpreter) n) - new-value)) - -;;; Environments -;;; 04: (get-env variable frame) -- value -(define-opcode 4 get-env (interpreter) (variable frame) - (aref (nth frame (interpreter-environment interpreter)) - variable)) -;;; 05: (set-env! variable frame) new-value -- -(define-opcode* 5 set-env! (interpreter new-value) (variable frame) - (setf (aref (nth frame (interpreter-environment interpreter)) - variable) - new-value)) - -;;; 0B: (byte x) -- x -(define-opcode 11 byte (interpreter) (byte) byte) diff --git a/Code/Scripts/forthisms.lisp b/Code/Scripts/forthisms.lisp deleted file mode 100644 index be61bd7..0000000 --- a/Code/Scripts/forthisms.lisp +++ /dev/null @@ -1,16 +0,0 @@ -(in-package :netfarm-scripts) - -;; 22: drop x -- -(define-opcode* 34 drop (interpreter x) () - (declare (ignore x)) - (values)) - -;; 23: dup x -- x x -(define-opcode* 35 dup (interpreter x) () - (push x (interpreter-data-stack interpreter)) - (push x (interpreter-data-stack interpreter))) - -;; 24: swap x y -- y x -(define-opcode* 36 swap (interpreter x y) () - (push y (interpreter-data-stack interpreter)) - (push x (interpreter-data-stack interpreter))) diff --git a/Code/Scripts/objects.lisp b/Code/Scripts/objects.lisp deleted file mode 100644 index 5acc44f..0000000 --- a/Code/Scripts/objects.lisp +++ /dev/null @@ -1,46 +0,0 @@ -(in-package :netfarm-scripts) - -;;; Manipulating Netfarm objects - -;;; (get-object) name -- object -(define-opcode 128 get-object (interpreter name) () - (check-type name string) - (error 'get-object :name name)) - -(define-opcode 129 schema (interpreter object) () - (if (typep object 'netfarm:object) - (class->schema (class-of object)) - (error "~s does not have a schema" object))) - -;;; (add-computed-value) object name value -- -(define-opcode* 130 add-computed-value (interpreter object name value) () - (check-type object object) - (check-type name string) - (if (find (interpreter-script interpreter) - (netfarm:netfarm-class-allowed-scripts - (class-of object))) - (push (list 'add-computed-value :object (hash-object* object) - :name name - :value value) - (interpreter-side-effects interpreter)) - (error 'no-capability - :operation 'add-computed-value - :cause object))) - -(define-function-opcode 131 object-value 2) - -(define-opcode 132 object-computed-values (interpreter object slot-name) () - (if (member :computed-values (interpreter-capabilities interpreter)) - (netfarm:object-computed-values object slot-name) - (error 'no-capability - :operation 'object-computed-values - :cause object))) - -(define-function-opcode 133 (boolean-wrap object-boundp 2) 2 - :opcode-name object-boundp) - -(define-opcode 134 object-signatures (interpreter object) () - (let ((signatures (object-signatures object))) - (incf (interpreter-cons-count interpreter) - (length signatures)) - (mapcar #'car signatures))) diff --git a/Code/Scripts/opcode-information.lisp b/Code/Scripts/opcode-information.lisp deleted file mode 100644 index 7eae592..0000000 --- a/Code/Scripts/opcode-information.lisp +++ /dev/null @@ -1,80 +0,0 @@ -(in-package :netfarm-scripts) - -(declaim ((simple-array function (*)) *operators*)) - -(defun interpreter-lose (interpreter opcode) - (error "illegal opcode ~d on ~s" opcode interpreter)) - -(defvar *operators* - (make-array 256 - :initial-element #'interpreter-lose - :element-type 'function)) -(defvar *opcode-data* (make-array 256 :initial-element nil :element-type 'list)) -(defvar *opcode-code* (make-array 256 :initial-element nil)) - -(defun opcode-information (opcode-number) - (aref *opcode-data* opcode-number)) - -(defun make-opcode-lambda (interpreter inputs bytes declarations body) - (let ((opcode!g (gensym "OPCODE"))) - `(lambda (,interpreter ,opcode!g) - (declare (interpreter ,interpreter) - (ignore ,opcode!g)) - (let (,@(loop for input in (reverse inputs) - collect `(,input (pop* (interpreter-data-stack ,interpreter)))) - ,@(loop for byte in bytes - collect `(,byte (interpreter-read-byte ,interpreter)))) - ,@declarations - ,body)))) - -(defmacro %define-opcode (number name interpreter inputs bytes declarations function body) - `(setf *discriminator-function* nil - (aref *opcode-data* ,number) '(,name ,inputs ,bytes) - (aref *opcode-code* ,number) (list (list ',interpreter ',inputs ',bytes) - ',declarations ',body) - (aref *operators* ,number) ,function)) - -(defmacro define-opcode (number name (interpreter &rest inputs) (&rest bytes) &body body) - "Define an opcode by creating a function that takes INPUTS variables from the INTERPRETER and appends the BODY's return values to the stack, and binding it to the NUMBERth operator in *OPERATORS*." - (multiple-value-bind (body declarations) - (alexandria:parse-body body) - `(progn - (let ((data (aref *opcode-data* ,number))) - (unless (or (null data) - (eql ',name (first data))) - (cerror "Redefine the opcode" - "The opcode ~d with name ~s is being redefined to ~s" - ,number ',name (first data)))) - (%define-opcode ,number ,name ,interpreter ,inputs ,bytes - ,declarations - ,(make-opcode-lambda interpreter inputs bytes declarations - `(push (progn ,@body) - (interpreter-data-stack ,interpreter))) - (push (progn ,@body) - (interpreter-data-stack ,interpreter)))))) - -(defmacro define-opcode* (number name (interpreter &rest inputs) (&rest bytes) &body body) - "Define an opcode by creating a function that takes INPUTS variables from the INTERPRETER pushing nothing to the stack, and binding it to the NUMBERth operator in *OPERATORS*." - (multiple-value-bind (body declarations) - (alexandria:parse-body body) - `(progn - (let ((data (aref *opcode-data* ,number))) - (unless (or (null data) - (eql ',name (first data))) - (cerror "Redefine the opcode" - "The opcode ~d with name ~s is being redefined to ~s" - ,number ',name (first data)))) - (%define-opcode ,number ,name ,interpreter ,inputs ,bytes - ,declarations - ,(make-opcode-lambda interpreter inputs bytes declarations `(progn ,@body)) - (progn ,@body))))) - -(defmacro define-function-opcode (number function argument-count &key (opcode-name function)) - (let ((interpreter!g (gensym "INTERPRETER")) - (arguments!g (loop repeat argument-count collect (gensym "ARGUMENT")))) - (check-type opcode-name symbol) - (if (symbolp function) - `(define-opcode ,number ,opcode-name (,interpreter!g . ,arguments!g) () - (values (,function . ,arguments!g))) - `(define-opcode ,number ,opcode-name (,interpreter!g . ,arguments!g) () - (values (funcall ,function . ,arguments!g)))))) diff --git a/Code/Scripts/operators.lisp b/Code/Scripts/operators.lisp deleted file mode 100644 index 47c19e2..0000000 --- a/Code/Scripts/operators.lisp +++ /dev/null @@ -1,74 +0,0 @@ -(in-package :netfarm-scripts) - -;;; List processing - -(defun kons (first rest) - "CONS that only makes proper lists" - (check-type rest list) - (cons first rest)) - -(defmacro boolean-wrap (function-name argument-count &key (type t)) - (let ((arguments (loop repeat argument-count collect (gensym "ARGUMENT")))) - `(lambda ,arguments - (declare (,type . ,arguments)) - (if (,function-name . ,arguments) - :true :false)))) - -(define-opcode 64 cons (interpreter first rest) () - (incf (interpreter-cons-count interpreter)) - (kons first rest)) -(define-function-opcode 65 car 1) -(define-function-opcode 66 cdr 1) -(define-function-opcode 67 (boolean-wrap null 1) 1 :opcode-name null) -(define-function-opcode 68 consp 1) -(define-opcode 69 append (interpreter list1 list2) () - (incf (interpreter-cons-count interpreter) - (+ (length list1) (length list2))) - (append list1 list2)) -(define-function-opcode 70 (boolean-wrap eql 2) 2 :opcode-name eql) - -;;; Generic equal that's slightly less picky than EQUAL because it recurses trees. -(defgeneric netfarm-equal (value1 value2) - (:method (v1 v2) (eql v1 v2)) - (:method ((v1 string) (v2 string)) (string= v1 v2)) - (:method ((v1 list) (v2 list)) - (= (length v1) (length v2)) - (every #'netfarm-equal v1 v2)) - (:method ((v1 vector) (v2 vector)) - (= (length v1) (length v2)) - (every #'= v1 v2))) -(define-function-opcode 71 netfarm-equal 2 :opcode-name equal) -(define-function-opcode 72 (boolean-wrap string= 2) 2 :opcode-name string=) - - -(define-opcode 73 list (interpreter) (count) - (incf (interpreter-cons-count interpreter) count) - (reverse - (loop repeat count - collect (pop* (interpreter-data-stack interpreter))))) - -;;; Number processing - -;; log2(a + b) > 512 if 1+ log2(max(a,b)) > 512 -(define-opcode 96 + (interpreter a b) () - (when (> (integer-length (max a b)) 255) - (error 'overflow :operands (list a b) :operation '+)) - (+ a b)) -(define-opcode 97 - (interpreter a b) () - (when (> (integer-length (max a b)) 255) - (error 'overflow :operands (list a b) :operation '-)) - (- a b)) -;; log2(ab) > 512 if log2(a) + log2(b) > 512 -(define-opcode 98 * (interpreter a b) () - (when (> (+ (integer-length a) (integer-length b)) 256) - (error 'overflow :operands (list a b) :operation '*)) - (* a b)) -(define-function-opcode 99 floor 2 :opcode-name /) -(define-function-opcode 100 abs 1) - -(define-function-opcode 112 (boolean-wrap = 2) 2 :opcode-name =) -(define-function-opcode 113 (boolean-wrap < 2) 2 :opcode-name <) -(define-function-opcode 114 (boolean-wrap > 2) 2 :opcode-name >) -(define-function-opcode 115 (boolean-wrap /= 2) 2 :opcode-name /=) -(define-function-opcode 116 (boolean-wrap <= 2) 2 :opcode-name <=) -(define-function-opcode 117 (boolean-wrap >= 2) 2 :opcode-name >=) diff --git a/Code/Scripts/script-machine.lisp b/Code/Scripts/script-machine.lisp deleted file mode 100644 index 129798a..0000000 --- a/Code/Scripts/script-machine.lisp +++ /dev/null @@ -1,147 +0,0 @@ -(in-package :netfarm-scripts) - -(defclass script () - ((entry-points :initarg :entry-points :reader script-entry-points) - (program :initarg :program :reader script-program) - (variables :initarg :variables :reader script-variables)) - (:metaclass netfarm:netfarm-class) - (:schema-names "inbuilt@script")) - -(deftype reasonably-sized-natural () - "Well, I hope this is a subset of the implementation's FIXNUM type. But still." - '(unsigned-byte 20)) -(declaim (inline make-procedure)) -(defstruct procedure - (entry-point 0 :type reasonably-sized-natural) - (arguments 0 :type reasonably-sized-natural) - environment) -(defstruct procedure-description - (entry-point 0 :type reasonably-sized-natural) - (arguments 0 :type reasonably-sized-natural)) -(defstruct interpreter - ;; Program state - (script '() :read-only t) - (program-counter 0 :type reasonably-sized-natural) - (variables #() :read-only t) - (program (make-array 0 :element-type '(unsigned-byte 8)) - :type (simple-array (unsigned-byte 8) (*))) - call-stack - data-stack - ;; Environment - environment - (entry-points #() :read-only t) - side-effects - (capabilities '() :read-only t) - ;; Watchdog limits - (instruction-count 0 :type fixnum) - (cons-count 0 :type fixnum)) - -(declaim (inline interpreter-read-byte interpreter-read-byte*)) -(defun interpreter-read-byte (interpreter) - (declare (interpreter interpreter)) - (prog1 (aref (interpreter-program interpreter) - (interpreter-program-counter interpreter)) - (incf (interpreter-program-counter interpreter)))) - -(defun interpreter-read-byte* (interpreter &optional (offset 0)) - (declare (interpreter interpreter) (fixnum offset)) - (aref (interpreter-program interpreter) - (+ offset (interpreter-program-counter interpreter)))) - -(declaim (inline step-interpreter)) -(defun step-interpreter (interpreter operators) - (declare (interpreter interpreter)) - (let* ((opcode (interpreter-read-byte interpreter)) - (function (aref operators opcode))) - (incf (interpreter-instruction-count interpreter)) - (funcall function interpreter opcode))) - -(defmacro pop* (place) - `(if (null ,place) - (error "stack underflow") - (pop ,place))) - -(defun make-byte-array (array) - (alexandria:copy-array array - :element-type '(unsigned-byte 8) - :fill-pointer nil - :adjustable nil)) - -(defun entry-point-vector (entry-point-list) - (let ((vector (make-array (length entry-point-list) - :element-type 'procedure-description - :initial-element (make-procedure-description)))) - (loop for entry in entry-point-list - for n from 0 - do (destructuring-bind (entry-point arguments) entry - (setf (aref vector n) - (make-procedure-description :entry-point entry-point - :arguments arguments)))) - vector)) - -(defun setup-interpreter (script arguments) - (declare (script script) - (list arguments)) - (let* ((interpreter - (make-interpreter :script script - :program (make-byte-array (script-program script)) - :variables (coerce (script-variables script) 'vector) - :data-stack (reverse arguments) - :entry-points (entry-point-vector (script-entry-points script)))) - (description (aref (interpreter-entry-points interpreter) 0))) - (call-function interpreter - (make-procedure :entry-point (procedure-description-entry-point description) - :arguments (procedure-description-arguments description) - :environment '()) - (length arguments)) - interpreter)) - -(defun run-interpreter (interpreter &key cons-limit cycle-limit print-cycles step) - (declare (interpreter interpreter) - ((or null fixnum) cons-limit cycle-limit) - (boolean print-cycles step)) - (ensure-discriminator-function) - (let (#+netfarm-profiling - (opcode-count-table (make-hash-table)) - (discriminator-function *discriminator-function*) - (operators *operators*)) - (declare ((function (interpreter t t) t) discriminator-function)) - (handler-case - (if (and (not print-cycles) (not step)) - (funcall discriminator-function interpreter cons-limit cycle-limit) - (loop - #+netfarm-profiling - (incf (gethash (first (aref *opcode-data* (interpreter-read-byte* interpreter))) - opcode-count-table 0)) - (when print-cycles - (let ((*print-circle* t)) - (print - `(:pc ,(interpreter-program-counter interpreter) - :data ,(interpreter-data-stack interpreter) - :env ,(interpreter-environment interpreter)))) - (let ((opcode-info (aref *opcode-data* (interpreter-read-byte* interpreter)))) - (unless (null opcode-info) - (format t "(~a" (first opcode-info)) - (loop for byte-name in (third opcode-info) - for offset from 1 - for value = (interpreter-read-byte* interpreter offset) - do (format t " :~a ~d" byte-name value)) - (format t ")~%")))) - (step-interpreter interpreter operators) - (when (and (not (null cons-limit)) - (> (interpreter-cons-count interpreter) cons-limit)) - (error "exceeded cons limit")) - (when (and (not (null cycle-limit)) - (> (interpreter-instruction-count interpreter) cycle-limit)) - (error "exceeded cycle limit")) - (when step - (read-line)))) - (done () - (return-from run-interpreter - (values (interpreter-data-stack interpreter) - interpreter - #+netfarm-profiling opcode-count-table)))))) - -(defun add-object-to-interpreter (interpreter object) - (push object (interpreter-data-stack interpreter)) - (values)) diff --git a/Code/Server/Protocol/decentralise2.lisp b/Code/Server/Protocol/decentralise2.lisp index 76cd5be..47090de 100644 --- a/Code/Server/Protocol/decentralise2.lisp +++ b/Code/Server/Protocol/decentralise2.lisp @@ -54,7 +54,3 @@ ((system netfarm-system) name version channels) (declare (ignore name version channels)) '|You can't see it, till it's finished|) - -(decentralise-system:define-special-block (netfarm-system "computed-value-creators") - :get (constantly nil) - :put (constantly nil)) diff --git a/Code/Server/Protocol/dependency-graph.lisp b/Code/Server/Protocol/dependency-graph.lisp index b310fe5..f25fa9c 100644 --- a/Code/Server/Protocol/dependency-graph.lisp +++ b/Code/Server/Protocol/dependency-graph.lisp @@ -9,6 +9,7 @@ (add-other-interesting-block system dependency)))) (decentralise-utilities:defexpectation add-dependency-vertex (system (dependent string) (dependency string))) + (defgeneric remove-dependents (system dependency) (:documentation "Remove all dependency vertices from the dependency graph of the system where the dependency is DEPENDENCY.") (:method :around ((system netfarm-system) dependency) @@ -36,54 +37,6 @@ A simple method is provided for this generic function, but it may be faster to p system name) t)) -;;; The dependency resolution thread -(defun mark-as-fulfilled (system name) +(defun mark-as-fulfilled (system vague-object) (safe-queue:mailbox-send-message (netfarm-system-fulfilled-objects system) - name)) - -(defun compute-interpreters (system object) - (loop with class = (class-of object) - for script in (netfarm:netfarm-class-scripts class) - for interpreter = (netfarm-scripts:setup-interpreter script (list object)) - for state = (make-interpreter-state system (netfarm:hash-object* object) - interpreter) - do (add-interpreter-state system state) - collect state)) - -(defun dependency-resolution-step (system) - "Take a fulfilled name from the queue, then remove any vertices where it is a dependency and add it to the new-interpreter queue." - (with-received-message (fulfilled-name - (netfarm-system-fulfilled-objects system)) - (remove-dependents system fulfilled-name) - (let ((object (get-object system fulfilled-name))) - (when (and (netfarm:verify-object-signatures object) - ;; Don't bother about presenting or computing values for - ;; other-interesting objects. - (not (other-interesting-block-p system fulfilled-name))) - (let ((interpreters (compute-interpreters system object))) - (if (null interpreters) - (setf (presentable-name-p system fulfilled-name) t) - (dolist (interpreter interpreters) - (safe-queue:mailbox-send-message - (netfarm-system-new-interpreters system) - interpreter)))))))) - -;;; Adding new vague objects to be processed -(defgeneric add-dependencies (system dependent dependencies) - (:method ((system netfarm-system) dependent dependencies) - (if (null dependencies) - (mark-as-fulfilled system dependent) - (dolist (dependency dependencies) - (add-dependency-vertex system dependent dependency))))) -(decentralise-utilities:defexpectation add-dependencies - (system (dependent string) ((every dependencies) string))) - -(defun add-new-vague-object (system vague-object) - (put-vague-object system vague-object) - (add-dependencies system - (netfarm:vague-object-name vague-object) - (remove-if (lambda (name) - (or - (netfarm:find-netfarm-class name nil) - (vague-object-stored-p system name))) - (netfarm:compute-dependencies vague-object)))) + vague-object)) diff --git a/Code/Server/Protocol/interpreters.lisp b/Code/Server/Protocol/interpreters.lisp index 0e6f116..7d38463 100644 --- a/Code/Server/Protocol/interpreters.lisp +++ b/Code/Server/Protocol/interpreters.lisp @@ -1,72 +1,18 @@ (in-package :netfarm-server) -(defclass interpreter-state () ()) -(defgeneric interpreter-state-interpreter (interpreter-state)) -(defgeneric interpreter-state-dependency (interpreter-state)) -(defgeneric interpreter-state-name (interpreter-state)) -(defgeneric (setf interpreter-state-dependency) (dependency interpreter-state) - (:method :before (dependency (interpreter-state interpreter-state)) - (check-type dependency (or string null)))) +(defclass object-status () + ((remaining-interpreter-count + :initarg :remaining-interpreter-count + :accessor object-status-remaining-interpreter-count) + (stage :initarg :stage :accessor object-status-stage))) -(defgeneric make-interpreter-state (system name interpreter &optional dependency)) -(defgeneric add-interpreter-state (system interpreter-state)) -(defgeneric remove-interpreter-state (system interpreter-state) - (:method :around ((system netfarm-system) interpreter-state) - (let ((name (interpreter-state-name interpreter-state))) - (call-next-method) - (when (and (no-interpreters-named-p system name) - (not (failed-interpreters-p system name))) - (setf (presentable-name-p system name) t) - (map-side-effects (lambda (effect) - (apply #'apply-side-effect system name effect)) - system name))))) - -(defgeneric update-interpreter-state (system interpreter-state)) +(defclass interpreter-state () + ((interpreter :initarg :interpreter :reader interpreter-state-interpreter) + (system :initarg :system :reader interpreter-state-system) + (subject :initarg :subject :reader interpreter-state-name))) -(defgeneric map-dependent-interpreter-states (system name)) -(defgeneric map-interpreter-states-named (function name system)) -(defgeneric no-interpreters-named-p (system name) - (:method ((system netfarm-system) name) - (map-interpreter-states-named - (lambda (state) - (declare (ignore state)) - (return-from no-interpreters-named-p nil)) - name system) - t)) +(defclass initialisation-interpreter-state (interpreter-state) + ()) -(defgeneric add-failed-interpreter (system name condition)) -(defgeneric failed-interpreters-p (system name)) - -(defun interpreter-step (system) - (with-received-message (interpreter-state - (netfarm-system-new-interpreters system)) - (prog ((interpreter (interpreter-state-interpreter interpreter-state))) - continue-evaluation - (handler-case (netfarm-scripts:run-interpreter interpreter - :cons-limit 100000 - :cycle-limit 100000) - (:no-error (stack interpreter) - (declare (ignore stack)) - (dolist (side-effect (netfarm-scripts:interpreter-side-effects interpreter)) - (add-side-effect system - (interpreter-state-name interpreter-state) - side-effect)) - (remove-interpreter-state system interpreter-state)) - (netfarm-scripts:get-object (request) - (let ((name (netfarm-scripts:get-object-name request))) - (if (and (vague-object-stored-p system name) - (presentable-name-p system name)) - (progn - (netfarm-scripts:add-object-to-interpreter - interpreter - (get-object system name)) - (go continue-evaluation)) - (progn - (update-interpreter-state system interpreter-state) - (setf (interpreter-state-dependency interpreter-state) - name))))) - (error (e) - (add-failed-interpreter system - (interpreter-state-name interpreter-state) - e) - (remove-interpreter-state system interpreter-state)))))) +(defclass message-interpreter-state (interpreter-state) + ((sender :initarg :sender :reader interpreter-state-sender))) diff --git a/Code/Server/Protocol/side-effects.lisp b/Code/Server/Protocol/side-effects.lisp index 989c337..6987a9c 100644 --- a/Code/Server/Protocol/side-effects.lisp +++ b/Code/Server/Protocol/side-effects.lisp @@ -1,16 +1 @@ (in-package :netfarm-server) - -(defgeneric add-side-effect (system name side-effect)) -(defgeneric map-side-effects (function system name)) -(defgeneric remove-side-effects (system name)) -(defgeneric map-computed-values-caused-by (function cause-name system)) - -(defgeneric apply-side-effect (system cause effect-name &key) - (:method ((system netfarm-system) cause - (effect-name (eql 'netfarm-scripts:add-computed-value)) - &key object name value) - (let ((object (get-vague-object system object))) - (push (list (make-instance 'netfarm:reference :hash cause) value) - (gethash name - (netfarm:vague-object-computed-values object))) - (put-vague-object system object)))) diff --git a/Code/Server/Protocol/system.lisp b/Code/Server/Protocol/system.lisp index ab58249..e104468 100644 --- a/Code/Server/Protocol/system.lisp +++ b/Code/Server/Protocol/system.lisp @@ -10,6 +10,10 @@ :reader netfarm-system-fulfilled-objects) (new-interpreter-mailbox :initform (safe-queue:make-mailbox) :reader netfarm-system-new-interpreters) + (object-statuses :initform (decentralise-utilities:make-locked-box + :value (make-hash-table :test 'equal) + :require-locked-read t) + :reader netfarm-system-object-statuses) (worker-threads :initform '() :accessor netfarm-system-worker-threads))) diff --git a/Code/Server/Stages/decentralise2.lisp b/Code/Server/Stages/decentralise2.lisp new file mode 100644 index 0000000..a2a8fd0 --- /dev/null +++ b/Code/Server/Stages/decentralise2.lisp @@ -0,0 +1,49 @@ +(in-package :netfarm-server) + +(decentralise-system:define-simple-error incorrect-hash) + +(defun decode-base64-string (string) + (with-input-from-string (s string) + (s-base64:decode-base64-bytes s))) + +(defmethod decentralise-system:put-block + ((system netfarm-system) name version channels data) + (declare (ignore version channels)) + (let* ((vague-object (netfarm:parse-block data :name name))) + (clrhash (netfarm:vague-object-computed-values vague-object)) + (if (netfarm:verify-object-hash vague-object + (decode-base64-string name)) + (add-new-vague-object system vague-object) + (error 'incorrect-hash)))) + +(defmethod decentralise-system:get-block + ((system netfarm-system) name) + (if (and (vague-object-stored-p system name) + (presentable-name-p system name)) + (values 0 + (objects-affected-by system name) + (netfarm:render-object + (get-vague-object system name))) + (error 'decentralise-system:not-found :name name))) + +(defmethod decentralise-system:map-blocks + (function (system netfarm-system)) + (map-vague-objects + (lambda (name signatures) + (declare (ignore signatures)) + (when (presentable-name-p system name) + (funcall function name 0 '()))) + system)) + +(defmethod decentralise-system:interesting-block-p + ((system netfarm-system) name version channels) + (declare (ignore version channels)) + (or (other-interesting-block-p system name) + (call-next-method))) + +;;; Only broadcast information about an object after it has gone through the +;;; server machinery +(defmethod decentralise-system:distribute-after-put-block + ((system netfarm-system) name version channels) + (declare (ignore name version channels)) + '|You can't see it, till it's finished|) diff --git a/Code/Server/Stages/dependency-resolution.lisp b/Code/Server/Stages/dependency-resolution.lisp new file mode 100644 index 0000000..6c83c1e --- /dev/null +++ b/Code/Server/Stages/dependency-resolution.lisp @@ -0,0 +1,26 @@ +(in-package :netfarm-server) + +(defgeneric add-new-vague-object (system vague-object) + (:method ((system netfarm-system) vague-object) + (let ((dependencies + (remove-if (lambda (name) + (vague-object-stored-p system name)) + (netfarm:compute-dependencies vague-object))) + (name (netfarm:vague-object-name vague-object))) + (if (null dependencies) + (mark-as-fulfilled system vague-object) + (dolist (dependency dependencies) + (add-dependency-vertex system name dependency)))))) + +(defgeneric dependency-resolution-loop (system) + (:method ((system netfarm-system)) + (with-received-message (fulfilled-object + (netfarm-system-fulfilled-objects system)) + (remove-dependents system fulfilled-object) + (let ((object + (netfarm:apply-class fulfilled-object + (get-schema system + (netfarm:vague-object-schema-name + fulfilled-object))))) + (when (netfarm:verify-object-signatures object) + (add-initialisation-scripts system object)))))) diff --git a/Code/Server/Stages/initialisation-script-machines.lisp b/Code/Server/Stages/initialisation-script-machines.lisp new file mode 100644 index 0000000..8484c02 --- /dev/null +++ b/Code/Server/Stages/initialisation-script-machines.lisp @@ -0,0 +1,26 @@ +(in-package :netfarm-server) + +(defun compute-initialisation-scripts (object) + (netfarm:netfarm-class-scripts (class-of object))) + +(defgeneric add-initialisation-scripts (system object) + (:method ((system netfarm-system) object) + (let* ((name (netfarm:hash-object* object)) + (scripts (compute-initialisation-scripts object)) + (states + (loop for script in scripts + collect (make-instance 'initialisation-interpreter-state + :subject name + :system system + :interpreter (netfarm-scripts:setup-interpreter + script + (list object) + '(:send)))))) + (decentralise-utilities:with-unlocked-box + (table (netfarm-system-object-statuses system)) + (setf (gethash name table) + (make-instance 'object-status + :stage :initialization + :remaining-interpreter-count (length states)))) + (dolist (state states) + (safe-queue:enqueue state (netfarm-system-new-interpreters system)))))) diff --git a/Code/Server/netfarm-server.asd b/Code/Server/netfarm-server.asd index adf11be..8056bcc 100644 --- a/Code/Server/netfarm-server.asd +++ b/Code/Server/netfarm-server.asd @@ -5,7 +5,10 @@ (:module "Protocol" :components ((:file "system") (:file "dependency-graph") - (:file "decentralise2") (:file "interpreters") (:file "side-effects"))) + (:module "Stages" + :components ((:file "decentralise2") + (:file "dependency-resolution") + (:file "initialisation-script-machines"))) (:file "memory-database"))) diff --git a/Code/netfarm.asd b/Code/netfarm.asd index fa521f3..9dfd657 100644 --- a/Code/netfarm.asd +++ b/Code/netfarm.asd @@ -17,24 +17,26 @@ (:file "objects") (:file "schema") (:file "type-specifiers") - (:file "inbuilt-schemas") - (:file "checkpointing"))) + (:file "inbuilt-netfarm-class"))) + (:module "Scripts" + :components ((:file "package") + (:module "Script-machine" + :components ((:file "conditions") + (:file "opcode-information") + (:file "discriminator-function") + (:file "script-machine") + (:file "environments") + (:file "control-flow") + (:file "operators") + (:file "forthisms") + (:file "objects") + (:file "assemble") + (:file "define-script"))))) + (:file "Objects/inbuilt-schemas") + (:file "Objects/checkpointing") (:module "Text-format" :components ((:file "new-parser") (:file "new-renderer"))) (:module "Crypto" - :components ((:file "keys") - (:file "hash"))) - (:module "Scripts" - :components ((:file "package") - (:file "conditions") - (:file "opcode-information") - (:file "discriminator-function") - (:file "script-machine") - (:file "environments") - (:file "control-flow") - (:file "operators") - (:file "forthisms") - (:file "objects") - (:file "assemble") - (:file "define-script"))))) + :components ((:file "hash") + (:file "keys" :depends-on ("hash")))))) diff --git a/Tests/benchmark.lisp b/Tests/benchmark.lisp index 4da7100..0807888 100644 --- a/Tests/benchmark.lisp +++ b/Tests/benchmark.lisp @@ -7,8 +7,7 @@ (bar :initarg :bar) (baz :initarg :baz) (quux :initarg :quux)) - (:metaclass netfarm-class) - (:schema-names "benchmark/benchmark-class")) + (:metaclass netfarm-class)) (defmacro announce-bench-group (name) `(format *trace-output* "~&Benchmarking ~a:" ,(format nil "~(~a~)" name))) @@ -24,8 +23,13 @@ (multiple-value-bind (results interpreter) ,run-script (declare (ignore results)) - (let ((operations (netfarm-scripts:interpreter-instruction-count interpreter)) - (time (the-cost-of-nothing:benchmark ,run-script))) + (let* ((setup-time (the-cost-of-nothing:benchmark + (netfarm-scripts:setup-interpreter ,script-name + (list ,@arguments)))) + (operations (netfarm-scripts:interpreter-instruction-count interpreter)) + (time (- (/ (the-cost-of-nothing:benchmark (dotimes (n 10) ,run-script)) + 10.0) + setup-time))) (the-cost-of-nothing:write-si-unit (float (/ operations time)) "operations/second" *trace-output*) @@ -98,7 +102,8 @@ (define-test script-machine-benchmark :parent benchmark + (netfarm-scripts::ensure-discriminator-function) (announce-bench-group script-machine) (named-bench/mips "fib(28)" *fib* 28) - (named-bench/mips "loop" *loop* 100000) - (named-bench/mips "cons-loop" *cons-loop* '() 10000)) + (named-bench/mips "loop" *loop* 1000000) + (named-bench/mips "cons-loop" *cons-loop* '() 1000000)) diff --git a/Tests/server-client.lisp b/Tests/server-client.lisp index e1c11f7..dfb33e1 100644 --- a/Tests/server-client.lisp +++ b/Tests/server-client.lisp @@ -93,7 +93,7 @@ (:metaclass netfarm:netfarm-class)) (defclass c () ((text :initarg :text :reader text)) - (:allowed-scripts *c-computed-value*) +; (:allowed-scripts *c-computed-value*) (:metaclass netfarm:netfarm-class)) (define-test server-script-machine -- GitLab