Commit e094f484 authored by  Hayley Patton's avatar Hayley Patton 🐢

Bind interpreter registers instead of an interpreter structure in...

Bind interpreter registers instead of an interpreter structure in DEFINE-OPCODEs, use lexical variables for registers
parent 0146b1d4
(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)))
......
(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))))
(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"))
......
......@@ -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)
......
......@@ -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)
......
(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))
(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"))))))))
(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)))
......@@ -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)
......
(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)))
(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 <http://metamodular.com/SICL/generic-dispatch.pdf>
;;; 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"))))))))
(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)
(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)))
(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)))
(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))))))
(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 >=)
(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)