Commit 57f59f99 authored by  Hayley Patton's avatar Hayley Patton 🐢

optimise the crap out of script machine, export opcode information

parent b7be57cf
Pipeline #989 passed with stage
in 3 minutes and 2 seconds
......@@ -16,10 +16,12 @@
(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 (cdr (aref *opcode-data* opcode)))))
(assert (= (length (cdr instruction)) argument-count) ()
"Wanted ~d argument~:p, got ~d"
argument-count (length (cdr 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)))))))
......
......@@ -5,6 +5,8 @@
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."))
......@@ -14,3 +16,7 @@ it can either answer the signal or stash the machine's state if it cannot answer
(value :initarg :value :reader add-computed-value-value)
(object :initarg :object :reader add-computed-value-object))
(:documentation "Add a computed value VALUE by NAME to the OBJECT."))
(define-condition overflow (error)
((operation :initarg :operation :reader overflow-operation)
(operands :initarg :operands :reader overflow-operands)))
......@@ -2,14 +2,15 @@
;;; Control flow
;;; 08: (return) --
(define-opcode 8 return (interpreter) ()
(define-opcode* 8 return (interpreter) ()
(when (null (interpreter-call-stack interpreter))
(error "(return) with nowhere to return to"))
(destructuring-bind (old-environment old-pc)
(pop (interpreter-call-stack interpreter))
(setf (interpreter-environment interpreter) old-environment
(interpreter-program-counter interpreter) old-pc))
(values))
(when (null (interpreter-call-stack interpreter))
(signal 'done)))
(defun make-frame (interpreter frame-size)
(let ((frame (make-array frame-size)))
......@@ -32,36 +33,36 @@
(setf (interpreter-environment interpreter)
(cons (make-frame interpreter argument-count)
(procedure-environment function))
(interpreter-program-counter interpreter) (procedure-entry-point function))
(values))
(interpreter-program-counter interpreter) (procedure-entry-point function)))
;;; 09: (call n) arg-1 ... arg-n function --
(define-opcode 9 call (interpreter function) (n)
(define-opcode* 9 call (interpreter function) (n)
(incf (interpreter-cons-count interpreter) n)
(call-function interpreter function n))
;;; 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 (interpreter function) (n)
(define-opcode* 10 tail-call (interpreter function) (n)
(pop (interpreter-environment interpreter))
(call-function interpreter function n :save-current nil))
(declaim (inline u8-pair->u16))
(defun u8-pair->u16 (high low)
(logior (ash high 8)
low))
;;; 10: (if then-high then-low else-high else-low) test-value --
;;; 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 if (interpreter test-value) (then-high then-low else-high else-low)
(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)
(setf (interpreter-program-counter interpreter) else)
(setf (interpreter-program-counter interpreter) then)))
(values))
(incf (interpreter-program-counter interpreter) else)
(incf (interpreter-program-counter interpreter) then))))
;;; 18: (error) message cause --
(define-opcode 24 error (interpreter message cause) ()
(define-opcode* 24 error (interpreter message cause) ()
(error 'script-machine-error :message message :cause cause))
......@@ -5,7 +5,7 @@
(defmacro define-script (variable-name script-name (&rest variables) &body body)
`(defparameter ,variable-name
(setf (gethash ',(string-downcase script-name) *scripts*)
(make-object *script-schema*
:entry-points (get-entry-points ',body)
:program (assemble ',body)
:variables ',variables))))
(make-instance (find-class 'script)
:entry-points (get-entry-points ',body)
:program (assemble ',body)
:variables ',variables))))
......@@ -22,19 +22,20 @@
(define-opcode 2 get-value (interpreter) (n)
(elt (interpreter-variables interpreter) n))
;;; 03: (set-value! n) new-value --
(define-opcode 3 set-value! (interpreter new-value) (n)
(define-opcode* 3 set-value! (interpreter new-value) (n)
(setf (elt (interpreter-variables interpreter) n)
new-value)
(values))
new-value))
;;; Environments
;;; 04: (get-env variable frame) -- value
(define-opcode 4 get-env (interpreter) (variable frame)
(aref (elt (interpreter-environment interpreter) 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 (elt (interpreter-environment interpreter) frame)
(define-opcode* 5 set-env! (interpreter new-value) (variable frame)
(setf (aref (nth frame (interpreter-environment interpreter))
variable)
new-value)
(values))
new-value))
;;; 0B: (byte x) -- x
(define-opcode 11 byte (interpreter) (byte) byte)
(in-package :netfarm-scripts)
;; 20: dup x -- x x
(define-opcode 32 dup (interpreter x) ()
(values x x))
;; 21: swap x y -- y x
(define-opcode 33 swap (interpreter x y) ()
(values y x))
;; 22: drop x --
(define-opcode 34 drop (interpreter x) ()
(define-opcode* 34 drop (interpreter x) ()
(declare (ignore x))
(values))
(in-package :netfarm-scripts)
(declaim ((simple-array function (*)) *operators*))
(defvar *operators* (make-array 256
:initial-element (lambda (interpreter opcode)
(error "illegal opcode ~d on ~s" opcode interpreter))
:element-type 'function))
(defvar *opcode-data* (make-array 256 :initial-element nil :element-type 'list))
(defun opcode-information (opcode-number)
(aref *opcode-data* opcode-number))
......@@ -41,11 +41,22 @@
;;; Number processing
(define-function-opcode 96 + 2 :type (signed-byte 1024))
(define-function-opcode 97 - 2 :type (signed-byte 1024))
(define-function-opcode 98 * 2 :type (signed-byte 1024))
(define-function-opcode 99 floor 2 :opcode-name /)
(define-function-opcode 100 abs 1 :type (signed-byte 1024))
;; log2(a + b) > 512 if 1+ log2(max(a,b)) > 512
(define-opcode 96 + (interpreter a b) ()
(when (> (integer-length (max a b)) 511)
(error 'overflow :operands (list a b) :operation '+))
(+ a b))
(define-opcode 97 - (interpreter a b) ()
(when (> (integer-length (max a b)) 512)
(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)) 512)
(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 :opcode-name =)
(define-function-opcode 113 (boolean-wrap #'<) 2 :opcode-name <)
......
(defpackage :netfarm-scripts
(:use :cl :netfarm)
(:export #:assemble #:define-script #:*script-schema*
(:export #:assemble #:define-script #:script #:opcode-information
#:run-interpreter
#:continue-interpreting))
(in-package :netfarm-scripts)
(defclass script ()
(entry-points program variables)
((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"))
(defstruct procedure entry-point arguments environment)
(defstruct procedure
(entry-point 0 :type fixnum)
(arguments 0 :type fixnum)
environment)
(defstruct interpreter
(program-counter 0)
variables program
(program-counter 0 :type fixnum)
variables
(program (make-array 0 :element-type '(unsigned-byte 8))
:type (simple-array (unsigned-byte 8) (*)))
call-stack data-stack
environment entry-points
(instruction-count 0)
(cons-count 0))
(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))))
(defvar *operators* (make-array 256 :initial-element (lambda (interpreter opcode)
(error "illegal opcode ~d on ~s" opcode interpreter))))
(defvar *opcode-data* (make-array 256 :initial-element nil))
(defun step-interpreter (interpreter)
(declare (interpreter interpreter))
(let* ((opcode (interpreter-read-byte interpreter))
(function (aref *operators* opcode)))
(incf (interpreter-instruction-count interpreter))
(funcall function interpreter opcode)
(values)))
(funcall function interpreter opcode)))
(defmacro pop* (place)
`(if (null ,place)
......@@ -46,75 +51,100 @@
(multiple-value-bind (body declarations)
(alexandria:parse-body body)
`(setf (aref *opcode-data* ,number)
'(,name . ,bytes)
'(,name ,inputs ,bytes)
(aref *operators* ,number)
(lambda (,interpreter ,opcode!g)
(declare (interpreter ,interpreter))
;; opcode is in the function to trap illegal opcodes, and for future use
(declare (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
(setf (interpreter-data-stack ,interpreter)
(revappend (multiple-value-list (progn ,@body)) ; Finally a use for revappend!
(interpreter-data-stack ,interpreter)))))))))
,@declarations
(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*."
(let ((opcode!g (gensym "OPCODE")))
`(setf (aref *opcode-data* ,number)
'(,name ,inputs ,bytes)
(aref *operators* ,number)
(lambda (,interpreter ,opcode!g)
(declare (interpreter ,interpreter))
;; opcode is in the function to trap illegal opcodes, and for future use
(declare (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))))
,@body)))))
(defmacro define-function-opcode (number function argument-count &key (type 't) (opcode-name function))
(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)
(when (symbolp function)
(setf function (list 'quote function)))
`(define-opcode ,number ,opcode-name (,interpreter!g . ,arguments!g) ()
(let ((values (multiple-value-list (funcall ,function . ,arguments!g))))
,(if (and (consp type)
(eql (car type) 'values))
`(loop for value in values
for type in ',(rest type)
unless (typep value type)
do (error 'type-error
:context ',opcode-name
:expected-type type
:datum value))
`(check-type (first values) ,type))
(values-list values)))))
(if (symbolp function)
`(define-opcode ,number ,opcode-name (,interpreter!g . ,arguments!g) ()
(values (,function . ,arguments!g)))
(alexandria:once-only (function)
`(define-opcode ,number ,opcode-name (,interpreter!g . ,arguments!g) ()
(values (funcall ,function . ,arguments!g)))))))
(defun run-interpreter (script arguments &key cons-limit cycle-limit print-cycles step)
(let* ((interpreter (make-interpreter :program (object-value script 'program)
(defun make-byte-array (array)
(alexandria:copy-array array :element-type '(unsigned-byte 8)))
(defun setup-interpreter (script arguments)
(declare (script script)
(list arguments))
(let* ((interpreter (make-interpreter :program (make-byte-array (script-program script))
:variables (copy-list
(object-value script 'variables))
:entry-points (object-value script 'entry-points)))
(description (elt (object-value script 'entry-points) 0)))
(setf (interpreter-data-stack interpreter) arguments)
(script-variables script))
:data-stack (reverse arguments)
:entry-points (coerce (script-entry-points script) 'vector)))
(description (aref (interpreter-entry-points interpreter) 0)))
(call-function interpreter
(make-procedure :entry-point (first description)
:arguments (second description)
:environment '())
(length arguments))
(loop
(when print-cycles
(format t "PC=~6d Stack=~:s Env=~:s~%"
(interpreter-program-counter interpreter)
(interpreter-data-stack interpreter)
(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 (rest opcode-info)
for offset from 1
for value = (interpreter-read-byte* interpreter offset)
do (format t " :~a ~d" byte-name value))
(format t ")~%"))))
(with-simple-restart (continue-interpreting "Continue interpreting")
(step-interpreter interpreter))
(when (and cons-limit
(> (interpreter-cons-count interpreter) cons-limit))
(error "exceeded cons limit"))
(when (and cycle-limit
(> (interpreter-instruction-count interpreter) cycle-limit))
(error "exceeded cycle limit"))
(when step
(read-line))
(when (null (interpreter-call-stack interpreter))
(return (interpreter-data-stack interpreter))))))
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))
(let (#+netfarm-profiling
(opcode-count-table (make-hash-table)))
(handler-case
(loop
#+netfarm-profiling
(incf (gethash (first (aref *opcode-data* (interpreter-read-byte* interpreter))) opcode-count-table 0))
(when print-cycles
(format t "PC=~6d Stack=~:s Env=~:s~%"
(interpreter-program-counter interpreter)
(interpreter-data-stack interpreter)
(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)
(when (and cons-limit
(> (interpreter-cons-count interpreter) cons-limit))
(error "exceeded cons limit"))
(when (and 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))))))
......@@ -20,6 +20,7 @@
(:module "Scripts"
:components ((:file "package")
(:file "conditions")
(:file "opcode-information")
(:file "script-machine")
(:file "environments")
(:file "control-flow")
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment