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

Speed up the script machine a bunch

parent 764f45ea
...@@ -3,48 +3,26 @@ ...@@ -3,48 +3,26 @@
;;; scymtym suggested SBCL's CASE might be faster now as it uses perfect ;;; scymtym suggested SBCL's CASE might be faster now as it uses perfect
;;; hashing and a jump table to dispatch. ;;; hashing and a jump table to dispatch.
;;; This is a hair slower than (defun make-discriminator-parts (operator-table start end)
`(case opcode
(defun make-discriminator-parts (operator-table) . ,(loop for position from start below end
(loop for operator across operator-table for operator = (aref operator-table position)
for position from 0 collect
collect `(,position
`(,position ,(if (null (aref *opcode-code* position))
,(if (eq operator (aref operator-table 255)) `(go lose)
`(go lose) (destructuring-bind ((parts inputs bytes) declarations body)
(destructuring-bind ((interpreter inputs bytes) declarations body) (aref *opcode-code* position)
(aref *opcode-code* position) `(with-interpreter-parts-renamed (data-stack %%data-stack
`(let ((,interpreter interpreter)) program-counter %%program-counter
(let (,@(loop for input in (reverse inputs) program %%program
collect `(,input (pop* (interpreter-data-stack ,interpreter)))) . ,parts)
,@(loop for byte in bytes (let (,@(loop for input in (reverse inputs)
collect `(,byte (interpreter-read-byte ,interpreter)))) collect `(,input (pop* %%data-stack)))
,@declarations ,@(loop for byte in bytes
,body for position from 0
(go out)))))))) collect `(,byte (aref %%program (+ ,position %%program-counter)))))
,@declarations
(defun make-discriminator-function () (incf %%program-counter ,(length bytes))
; (compile nil ,body
`(lambda (interpreter cons-limit cycle-limit) (go out)))))))))
(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) (in-package :netfarm-scripts)
(declaim (inline call-function)) (declaim (inline call-function make-frame))
(defun call-function (interpreter function argument-count &key (save-current t)) (defun call-function (interpreter function argument-count &key (save-current t))
(check-type function procedure) (check-type function procedure)
(assert (= argument-count (procedure-arguments function)) () (assert (= argument-count (procedure-arguments function)) ()
"wanted ~d argument~:p but got ~d" "wanted ~d argument~:p but got ~d"
(procedure-arguments function) argument-count) (procedure-arguments function) argument-count)
(when save-current (when save-current
(push (list (interpreter-environment interpreter) (push (vector (interpreter-environment interpreter)
(interpreter-program-counter interpreter)) (interpreter-program-counter interpreter))
(interpreter-call-stack interpreter))) (interpreter-call-stack interpreter)))
(setf (interpreter-environment interpreter) (setf (interpreter-environment interpreter)
(cons (make-frame interpreter argument-count) (cons (make-frame interpreter argument-count)
...@@ -16,20 +16,6 @@ ...@@ -16,20 +16,6 @@
(interpreter-program-counter interpreter) (interpreter-program-counter interpreter)
(procedure-entry-point function))) (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) (defun make-frame (interpreter frame-size)
(let ((frame (make-array frame-size))) (let ((frame (make-array frame-size)))
(dotimes (n frame-size) (dotimes (n frame-size)
...@@ -39,6 +25,20 @@ ...@@ -39,6 +25,20 @@
(pop (interpreter-data-stack interpreter)))) (pop (interpreter-data-stack interpreter))))
frame)) frame))
;;; 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"))
(let ((last-frame (pop call-stack)))
(locally (declare (optimize (safety 0) (speed 3))))
(setf environment (svref last-frame 0)
program-counter (svref last-frame 1)))
(when (null call-stack)
(signal 'done)))
;;; 09: (call n) arg-1 ... arg-n function -- ;;; 09: (call n) arg-1 ... arg-n function --
(define-opcode* 9 call ((:cons-count cons-count :data-stack data-stack (define-opcode* 9 call ((:cons-count cons-count :data-stack data-stack
:call-stack call-stack :call-stack call-stack
...@@ -51,7 +51,7 @@ ...@@ -51,7 +51,7 @@
(assert (= argument-count (procedure-arguments function)) () (assert (= argument-count (procedure-arguments function)) ()
"wanted ~d argument~:p but got ~d" "wanted ~d argument~:p but got ~d"
(procedure-arguments function) argument-count) (procedure-arguments function) argument-count)
(push (list environment program-counter) call-stack) (push (vector environment program-counter) call-stack)
(let ((new-frame (make-array argument-count))) (let ((new-frame (make-array argument-count)))
(dotimes (n argument-count) (dotimes (n argument-count)
(when (null data-stack) (when (null data-stack)
......
...@@ -22,15 +22,16 @@ ...@@ -22,15 +22,16 @@
collect `(,variable ,new-name)) collect `(,variable ,new-name))
,@body)) ,@body))
(defun make-discriminator-parts (operator-table start end) (defun make-discriminator-parts (opcodes)
(declare (fixnum start end))
(cond (cond
((= start (1- end)) ((null opcodes)
(let ((operator (aref operator-table start))) (error "no opcodes to dispatch on?"))
(if (eq operator (aref operator-table 255)) ((null (rest opcodes))
`(go lose) (destructuring-bind (opcode) opcodes
(if (null (aref *opcode-code* opcode))
`(go lose)
(destructuring-bind ((parts inputs bytes) declarations body) (destructuring-bind ((parts inputs bytes) declarations body)
(aref *opcode-code* start) (aref *opcode-code* opcode)
`(with-interpreter-parts-renamed (data-stack %%data-stack `(with-interpreter-parts-renamed (data-stack %%data-stack
program-counter %%program-counter program-counter %%program-counter
program %%program program %%program
...@@ -44,15 +45,29 @@ ...@@ -44,15 +45,29 @@
(incf %%program-counter ,(length bytes)) (incf %%program-counter ,(length bytes))
,body ,body
(go out))))))) (go out)))))))
((every (lambda (x) (eq x (aref operator-table 255))) ((every (lambda (opcode)
(subseq operator-table start end)) (null (aref *opcode-code* opcode)))
opcodes)
'(go lose)) '(go lose))
(t (t
(let ((middle (floor (+ start end) 2))) (let* ((middle (floor (length opcodes) 2))
`(progn (middle-element (nth middle opcodes)))
(if (< opcode ,middle) `(if (< opcode ,middle-element)
,(make-discriminator-parts operator-table start middle) ,(make-discriminator-parts (subseq opcodes 0 middle))
,(make-discriminator-parts operator-table middle end))))))) ,(make-discriminator-parts (subseq opcodes middle)))))))
(defun make-discriminator-code ()
(labels ((in-bounds? (opcode)
(<= 0 opcode 255))
(exists? (opcode)
(and (in-bounds? opcode)
(not (null (aref *opcode-code* opcode)))))
(needed? (opcode)
(or (exists? opcode) (exists? (1+ opcode)) (exists? (1- opcode)))))
(make-discriminator-parts
(loop for opcode below 256
when (needed? opcode)
collect opcode))))
(defmacro let-interpreter-parts ((&rest names) &body body) (defmacro let-interpreter-parts ((&rest names) &body body)
`(let ,(loop for name in names `(let ,(loop for name in names
...@@ -70,10 +85,11 @@ ...@@ -70,10 +85,11 @@
interpreter) interpreter)
,name)))) ,name))))
(defun make-discriminator-function (&key (top 256)) (defun make-discriminator-function ()
(compile nil (compile nil
`(lambda (interpreter cons-limit cycle-limit) `(lambda (interpreter cons-limit cycle-limit)
(declare (optimize (speed 3) (safety 1)) (declare (optimize (speed 3) (safety 1)
(debug 0))
(interpreter interpreter) (interpreter interpreter)
((or null fixnum) cons-limit cycle-limit) ((or null fixnum) cons-limit cycle-limit)
#+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note)) #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note))
...@@ -82,11 +98,14 @@ ...@@ -82,11 +98,14 @@
environment environment
entry-points side-effects capabilities entry-points side-effects capabilities
instruction-count cons-count) instruction-count cons-count)
(declare (reasonably-sized-natural program-counter) (declare (reasonably-sized-natural program-counter
((unsigned-byte 30) instruction-count cons-count) instruction-count
cons-count)
(list environment side-effects capabilities (list environment side-effects capabilities
call-stack data-stack) call-stack data-stack)
((simple-array (unsigned-byte 8) (*)) program)) ((simple-array (unsigned-byte 8) (*)) program)
((simple-array t (*)) variables)
((simple-array procedure-description (*)) entry-points))
(unwind-protect (unwind-protect
(loop (loop
(let ((opcode (aref program program-counter))) (let ((opcode (aref program program-counter)))
...@@ -94,7 +113,7 @@ ...@@ -94,7 +113,7 @@
(incf instruction-count) (incf instruction-count)
(incf program-counter) (incf program-counter)
(tagbody (tagbody
,(make-discriminator-parts *operators* 0 top) ,(make-discriminator-code)
lose lose
(error "illegal opcode ~d on ~s" (error "illegal opcode ~d on ~s"
opcode interpreter) opcode interpreter)
......
...@@ -15,9 +15,7 @@ ...@@ -15,9 +15,7 @@
;;; still consume space. get-proc* in a way is to get-proc as tail-call is to call. ;;; 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) (define-opcode 6 get-proc* ((:entry-points entry-points)) (n)
(let ((description (aref entry-points n))) (let ((description (aref entry-points n)))
(make-procedure :entry-point (procedure-description-entry-point description) (procedure-description-static-procedure description)))
:arguments (procedure-description-arguments description)
:environment '())))
;;; 02: (get-value n) -- value ;;; 02: (get-value n) -- value
(define-opcode 2 get-value ((:variables variables)) (n) (define-opcode 2 get-value ((:variables variables)) (n)
......
...@@ -9,27 +9,32 @@ ...@@ -9,27 +9,32 @@
(deftype reasonably-sized-natural () (deftype reasonably-sized-natural ()
"Well, I hope this is a subset of the implementation's FIXNUM type. But still." "Well, I hope this is a subset of the implementation's FIXNUM type. But still."
'(unsigned-byte 20)) '(unsigned-byte 30))
(declaim (inline make-procedure)) (declaim (inline make-procedure))
(defstruct procedure (defstruct procedure
(entry-point 0 :type reasonably-sized-natural) (entry-point 0 :type reasonably-sized-natural)
(arguments 0 :type reasonably-sized-natural) (arguments 0 :type reasonably-sized-natural)
environment) (environment '() :type list))
(defstruct procedure-description (defstruct procedure-description
(entry-point 0 :type reasonably-sized-natural) (entry-point 0 :type reasonably-sized-natural)
(arguments 0 :type reasonably-sized-natural)) (arguments 0 :type reasonably-sized-natural)
(static-procedure (make-procedure :entry-point 0
:arguments 0
:environment '())
:type procedure))
(defstruct interpreter (defstruct interpreter
;; Program state ;; Program state
(script '() :read-only t) (script nil :read-only t)
(program-counter 0 :type reasonably-sized-natural) (program-counter 0 :type reasonably-sized-natural)
(variables #() :read-only t) (variables #() :type (simple-array t (*)) :read-only t)
(program (make-array 0 :element-type '(unsigned-byte 8)) (program (make-array 0 :element-type '(unsigned-byte 8))
:type (simple-array (unsigned-byte 8) (*))) :type (simple-array (unsigned-byte 8) (*)))
(call-stack '() :type list) (call-stack '() :type list)
(data-stack '() :type list) (data-stack '() :type list)
;; Environment ;; Environment
(environment '() :type list) (environment '() :type list)
(entry-points #() :read-only t) (entry-points (make-array 0 :element-type 'procedure-description)
:type (simple-array procedure-description (*)))
(side-effects '() :type list) (side-effects '() :type list)
(capabilities '() :read-only t) (capabilities '() :read-only t)
;; Watchdog limits ;; Watchdog limits
...@@ -75,8 +80,13 @@ ...@@ -75,8 +80,13 @@
for n from 0 for n from 0
do (destructuring-bind (entry-point arguments) entry do (destructuring-bind (entry-point arguments) entry
(setf (aref vector n) (setf (aref vector n)
(make-procedure-description :entry-point entry-point (make-procedure-description
:arguments arguments)))) :entry-point entry-point
:arguments arguments
:static-procedure (make-procedure
:entry-point entry-point
:arguments arguments
:environment '())))))
vector)) vector))
(defun setup-interpreter (script arguments &optional capabilities) (defun setup-interpreter (script arguments &optional capabilities)
......
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