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

Speed up the script machine a bunch

parent 764f45ea
......@@ -3,48 +3,26 @@
;;; 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"))))))))
(defun make-discriminator-parts (operator-table start end)
`(case opcode
. ,(loop for position from start below end
for operator = (aref operator-table position)
collect
`(,position
,(if (null (aref *opcode-code* position))
`(go lose)
(destructuring-bind ((parts inputs bytes) declarations body)
(aref *opcode-code* position)
`(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)))))))))
(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))
(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))
(push (vector (interpreter-environment interpreter)
(interpreter-program-counter interpreter))
(interpreter-call-stack interpreter)))
(setf (interpreter-environment interpreter)
(cons (make-frame interpreter argument-count)
......@@ -16,20 +16,6 @@
(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)
......@@ -39,6 +25,20 @@
(pop (interpreter-data-stack interpreter))))
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 --
(define-opcode* 9 call ((:cons-count cons-count :data-stack data-stack
:call-stack call-stack
......@@ -51,7 +51,7 @@
(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)
(push (vector environment program-counter) call-stack)
(let ((new-frame (make-array argument-count)))
(dotimes (n argument-count)
(when (null data-stack)
......
......@@ -22,15 +22,16 @@
collect `(,variable ,new-name))
,@body))
(defun make-discriminator-parts (operator-table start end)
(declare (fixnum start end))
(defun make-discriminator-parts (opcodes)
(cond
((= start (1- end))
(let ((operator (aref operator-table start)))
(if (eq operator (aref operator-table 255))
`(go lose)
((null opcodes)
(error "no opcodes to dispatch on?"))
((null (rest opcodes))
(destructuring-bind (opcode) opcodes
(if (null (aref *opcode-code* opcode))
`(go lose)
(destructuring-bind ((parts inputs bytes) declarations body)
(aref *opcode-code* start)
(aref *opcode-code* opcode)
`(with-interpreter-parts-renamed (data-stack %%data-stack
program-counter %%program-counter
program %%program
......@@ -44,15 +45,29 @@
(incf %%program-counter ,(length bytes))
,body
(go out)))))))
((every (lambda (x) (eq x (aref operator-table 255)))
(subseq operator-table start end))
((every (lambda (opcode)
(null (aref *opcode-code* opcode)))
opcodes)
'(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)))))))
(let* ((middle (floor (length opcodes) 2))
(middle-element (nth middle opcodes)))
`(if (< opcode ,middle-element)
,(make-discriminator-parts (subseq opcodes 0 middle))
,(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)
`(let ,(loop for name in names
......@@ -70,10 +85,11 @@
interpreter)
,name))))
(defun make-discriminator-function (&key (top 256))
(defun make-discriminator-function ()
(compile nil
`(lambda (interpreter cons-limit cycle-limit)
(declare (optimize (speed 3) (safety 1))
(declare (optimize (speed 3) (safety 1)
(debug 0))
(interpreter interpreter)
((or null fixnum) cons-limit cycle-limit)
#+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note))
......@@ -82,11 +98,14 @@
environment
entry-points side-effects capabilities
instruction-count cons-count)
(declare (reasonably-sized-natural program-counter)
((unsigned-byte 30) instruction-count cons-count)
(declare (reasonably-sized-natural program-counter
instruction-count
cons-count)
(list environment side-effects capabilities
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
(loop
(let ((opcode (aref program program-counter)))
......@@ -94,7 +113,7 @@
(incf instruction-count)
(incf program-counter)
(tagbody
,(make-discriminator-parts *operators* 0 top)
,(make-discriminator-code)
lose
(error "illegal opcode ~d on ~s"
opcode interpreter)
......
......@@ -15,9 +15,7 @@
;;; 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 '())))
(procedure-description-static-procedure description)))
;;; 02: (get-value n) -- value
(define-opcode 2 get-value ((:variables variables)) (n)
......
......@@ -9,27 +9,32 @@
(deftype reasonably-sized-natural ()
"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))
(defstruct procedure
(entry-point 0 :type reasonably-sized-natural)
(arguments 0 :type reasonably-sized-natural)
environment)
(environment '() :type list))
(defstruct procedure-description
(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
;; Program state
(script '() :read-only t)
(script nil :read-only t)
(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))
:type (simple-array (unsigned-byte 8) (*)))
:type (simple-array (unsigned-byte 8) (*)))
(call-stack '() :type list)
(data-stack '() :type list)
;; Environment
(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)
(capabilities '() :read-only t)
;; Watchdog limits
......@@ -75,8 +80,13 @@
for n from 0
do (destructuring-bind (entry-point arguments) entry
(setf (aref vector n)
(make-procedure-description :entry-point entry-point
:arguments arguments))))
(make-procedure-description
:entry-point entry-point
:arguments arguments
:static-procedure (make-procedure
:entry-point entry-point
:arguments arguments
:environment '())))))
vector))
(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