Commit 0146b1d4 authored by  Hayley Patton's avatar Hayley Patton 🐢

Spill interpreter registers into lexical variables to make Clozure happy

parent 1c4df956
(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)
(required-capabilities :initarg :required-capabilities
:reader no-capability-capabilities)
(cause :initarg :cause :reader no-capability-cause)))
(in-package :netfarm-scripts)
(declaim (inline call-function))
(defun call-function (interpreter function argument-count &key (save-current t))
(check-type function procedure)
(assert (= argument-count (procedure-arguments function)) ()
"wanted ~d argument~:p but got ~d"
(procedure-arguments function) argument-count)
(when save-current
(push (list (interpreter-environment interpreter)
(interpreter-program-counter interpreter))
(interpreter-call-stack interpreter)))
(setf (interpreter-environment interpreter)
(cons (make-frame interpreter argument-count)
(procedure-environment function))
(interpreter-program-counter interpreter)
(procedure-entry-point function)))
;;; Control flow
;;; 08: (return) --
(define-opcode* 8 return ((:call-stack call-stack :environment environment
:program-counter program-counter)) ()
(when (null call-stack)
(error "(return) with nowhere to return to"))
(destructuring-bind (old-environment old-pc)
(pop call-stack)
(setf environment old-environment
program-counter old-pc))
(when (null call-stack)
(signal 'done)))
(declaim (inline make-frame))
(defun make-frame (interpreter frame-size)
(let ((frame (make-array frame-size)))
(dotimes (n frame-size)
(when (null (interpreter-data-stack interpreter))
(error "out of data when creating frame"))
(setf (aref frame n)
(pop (interpreter-data-stack interpreter))))
frame))
;;; 09: (call n) arg-1 ... arg-n function --
(define-opcode* 9 call ((:cons-count cons-count :data-stack data-stack
:call-stack call-stack
:program-counter program-counter
:environment environment)
function)
(argument-count)
(incf cons-count argument-count)
(check-type function procedure)
(assert (= argument-count (procedure-arguments function)) ()
"wanted ~d argument~:p but got ~d"
(procedure-arguments function) argument-count)
(push (list environment program-counter) call-stack)
(let ((new-frame (make-array argument-count)))
(dotimes (n argument-count)
(when (null data-stack)
(error "out of data when creating frame"))
(setf (aref new-frame n) (pop data-stack)))
(setf environment
(cons new-frame environment)
program-counter (procedure-entry-point function))))
;;; 0A: (tail-call n) arg-1 ... arg-n function --
;;; Similar to CALL, but doesn't back up the last state on the stack. This is
;;; therefore only good for tail-calls. It's really good at those though.
(define-opcode* 10 tail-call ((:cons-count cons-count :data-stack data-stack
:call-stack call-stack
:program-counter program-counter
:environment environment)
function)
(argument-count)
(pop environment)
(check-type function procedure)
(assert (= argument-count (procedure-arguments function)) ()
"wanted ~d argument~:p but got ~d"
(procedure-arguments function) argument-count)
(let ((new-frame (make-array argument-count)))
(dotimes (n argument-count)
(when (null data-stack)
(error "out of data when creating frame"))
(setf (aref new-frame n) (pop data-stack)))
(setf environment
(cons new-frame environment)
program-counter (procedure-entry-point function))))
(declaim (inline u8-pair->u16))
(defun u8-pair->u16 (high low)
(logior (ash high 8)
low))
;;; 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 ((:program-counter program-counter) 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)
(incf program-counter else)
(incf program-counter then))))
(define-opcode* 17 jump ((:program-counter program-counter))
(high low)
(incf program-counter (u8-pair->u16 high low)))
;;; 18: (error) message cause --
(define-opcode* 24 error (() message cause) ()
(error 'script-machine-error :message message :cause cause))
(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 and memory accesses 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))))
(defmacro with-interpreter-parts-renamed ((&rest parts) &body body)
`(symbol-macrolet ,(loop for (name variable) on parts by #'cddr
for new-name = (intern (string name) :netfarm-scripts)
unless (eql variable new-name)
collect `(,variable ,new-name))
,@body))
(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 ((parts inputs bytes) declarations body)
(aref *opcode-code* start)
`(with-interpreter-parts-renamed (data-stack %%data-stack
program-counter %%program-counter
program %%program
. ,parts)
(let (,@(loop for input in (reverse inputs)
collect `(,input (pop* %%data-stack)))
,@(loop for byte in bytes
for position from 0
collect `(,byte (aref %%program (+ ,position %%program-counter)))))
,@declarations
(incf %%program-counter ,(length bytes))
,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)))))))
(defmacro let-interpreter-parts ((&rest names) &body body)
`(let ,(loop for name in names
collect `(,name (,(alexandria:format-symbol :netfarm-scripts
"INTERPRETER-~a"
name)
interpreter)))
,@body))
(defmacro put-back-interpreter-parts (&rest names)
`(setf ,@(loop for name in names
appending `((,(alexandria:format-symbol :netfarm-scripts
"INTERPRETER-~a"
name)
interpreter)
,name))))
(defun make-discriminator-function (&key (top 256))
(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))
(let-interpreter-parts (program-counter variables program
call-stack data-stack
environment
entry-points side-effects capabilities
instruction-count cons-count)
(declare (reasonably-sized-natural program-counter)
((unsigned-byte 30) instruction-count cons-count)
(list environment side-effects capabilities
call-stack data-stack)
((simple-array (unsigned-byte 8) (*)) program))
(unwind-protect
(loop
(let ((opcode (aref program program-counter)))
(declare ((unsigned-byte 8) opcode))
(incf instruction-count)
(incf program-counter)
(tagbody
,(make-discriminator-parts *operators* 0 top)
lose
(error "illegal opcode ~d on ~s"
opcode interpreter)
out
(when (and (not (null cons-limit))
(> cons-count cons-limit))
(error "exceeded cons limit"))
(when (and (not (null cycle-limit))
(> instruction-count cycle-limit))
(error "exceeded cycle limit")))))
(put-back-interpreter-parts program-counter
call-stack data-stack
environment
side-effects
instruction-count cons-count))))))
(in-package :netfarm-scripts)
;;; Global state manipulation
;;; 01: (get-proc n) -- proc
(define-opcode 1 get-proc ((:entry-points entry-points :environment environment))
(n)
(let ((description (aref entry-points n)))
(make-procedure :entry-point (procedure-description-entry-point description)
:arguments (procedure-description-arguments description)
:environment environment)))
;;; 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* ((:entry-points entry-points)) (n)
(let ((description (aref entry-points 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 ((:variables variables)) (n)
(aref variables n))
;;; 03: (set-value! n) new-value --
(define-opcode* 3 set-value! ((:variables variables) new-value) (n)
(setf (aref variables n) new-value))
;;; Environments
;;; 04: (get-env variable frame) -- value
(define-opcode 4 get-env ((:environment environment)) (variable frame)
(aref (nth frame environment) variable))
;;; 05: (set-env! variable frame) new-value --
(define-opcode* 5 set-env! ((:environment environment) new-value)
(variable frame)
(setf (aref (nth frame environment) variable) new-value))
;;; 0B: (byte x) -- x
(define-opcode 11 byte (()) (byte) byte)
(in-package :netfarm-scripts)
;; 22: drop x --
(define-opcode* 34 drop (() x) ()
(declare (ignore x))
(values))
;; 23: dup x -- x x
(define-opcode* 35 dup ((:data-stack data-stack) x) ()
(push x data-stack)
(push x data-stack))
;; 24: swap x y -- y x
(define-opcode* 36 swap ((:data-stack data-stack) x y) ()
(push y data-stack)
(push x data-stack))
(in-package :netfarm-scripts)
;;; Manipulating Netfarm objects
;;; (get-object) name -- object
(define-opcode 128 get-object (() name) ()
(check-type name string)
(error 'get-object :name name))
(define-opcode 129 schema (() object) ()
(if (typep object 'netfarm:object)
(class->schema (class-of object))
(error "~s does not have a schema" object)))
;;; (add-computed-value) name value --
(define-opcode* 130 add-computed-value ((:capabilities capabilities
:side-effects side-effects)
name value)
()
(check-type name string)
(if (member :add-computed-value capabilities)
(push (list 'add-computed-value :name name
:value value)
side-effects)
(error 'no-capability
:operation 'add-computed-value
:required-capabilities '(:add-computed-value)
:cause value)))
(define-function-opcode 131 object-value 2)
(define-opcode 132 object-computed-values ((:capabilities capabilities)
object slot-name)
()
(if (member :computed-values capabilities)
(netfarm:object-computed-values object slot-name)
(error 'no-capability
:operation 'object-computed-values
:required-capabilities '(:required-capabilities)
:cause object)))
(define-function-opcode 133 (boolean-wrap object-boundp 2) 2
:opcode-name object-boundp)
(define-opcode 134 object-signatures ((:cons-count cons-count)
object)
()
(let ((signatures (object-signatures object)))
(incf cons-count (length signatures))
(mapcar #'car signatures)))
(define-opcode 135 send ((:capabilities capabilities
:side-effects side-effects)
target message)
()
(if (member :send capabilities)
(push (list 'send :target target
:message message)
side-effects)
(error 'no-capability
:operation 'send
:required-capabilities '(:send)
:cause message)))
(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))
(defmacro with-interpreter-parts ((&key . #1=(program-counter variables program
call-stack data-stack
environment
entry-points side-effects capabilities
cons-count))
interpreter &body body)
`(with-accessors*
((%%data-stack interpreter-data-stack)
(%%program-counter interpreter-program-counter)
(%%program interpreter-program)
. ,(loop for variable in (list . #1#)
for accessor in (mapcar (lambda (symbol)
(alexandria:format-symbol :netfarm-scripts
"INTERPRETER-~A"
symbol))
'#1#)
for variable-name in '#1#
unless (null variable)
collect (list variable accessor)))
,interpreter
,@body))
(defun make-opcode-lambda (parts inputs bytes declarations body)
(let ((opcode!g (gensym "OPCODE"))
(interpreter!g (gensym "INTERPRETER")))
`(lambda (,interpreter!g ,opcode!g)
(declare (interpreter ,interpreter!g)
(ignore ,opcode!g))
(with-interpreter-parts ,parts ,interpreter!g
(let (,@(loop for input in (reverse inputs)
collect `(,input (pop* (interpreter-data-stack ,interpreter!g))))
,@(loop for byte in bytes
collect `(,byte (interpreter-read-byte ,interpreter!g))))
,@declarations
,body)))))
(defmacro with-accessors* ((&rest accessor-bindings) subject &body body)
"Basically WITH-ACCESSORS but you're allowed to use it for any object."
(if (null accessor-bindings)
`(progn ,subject ,@body)
(alexandria:once-only (subject)
`(symbol-macrolet
,(loop for binding in accessor-bindings
collect (destructuring-bind (variable accessor) binding
`(,variable (,accessor ,subject))))
(declare (ignorable . ,(mapcar #'first accessor-bindings)))
,@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 (parts &rest inputs) (&rest bytes)
&body body &environment environment)
"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 (loop for part in body
collect (macroexpand part environment)))
`(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 ,parts ,inputs ,bytes
,declarations
,(make-opcode-lambda parts inputs bytes declarations
`(push (progn ,@body) %%data-stack))
(push (progn ,@body) %%data-stack)))))
(defmacro define-opcode* (number name (parts &rest inputs) (&rest bytes)
&body body &environment environment)
"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 (loop for part in body
collect (macroexpand part environment)))
`(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 ,parts ,inputs ,bytes
,declarations
,(make-opcode-lambda parts inputs bytes declarations `(progn ,@body))
(progn ,@body)))))
(defmacro define-function-opcode (number function argument-count &key (opcode-name function))
(let ((arguments!g (loop repeat argument-count collect (gensym "ARGUMENT"))))
(check-type opcode-name symbol)
(if (symbolp function)
`(define-opcode ,number ,opcode-name (() . ,arguments!g) ()
(values (,function . ,arguments!g)))
`(define-opcode ,number ,opcode-name (() . ,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 ((:cons-count cons-count) first rest) ()
(incf cons-count)
(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)