diff --git a/Code/Scripts/Script-machine/case-discriminator-function.lisp b/Code/Scripts/Script-machine/case-discriminator-function.lisp index a10ffde08aa080b8e77ab0894b3413cc27238867..5f2037c08814ceee71af311b80fdda4c777f489c 100644 --- a/Code/Scripts/Script-machine/case-discriminator-function.lisp +++ b/Code/Scripts/Script-machine/case-discriminator-function.lisp @@ -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))))))))) diff --git a/Code/Scripts/Script-machine/control-flow.lisp b/Code/Scripts/Script-machine/control-flow.lisp index 347dbe588ab60732a4922e2c456fcb64b8f1a9d6..bcb60694bb0b42fb51a77023ce232392e8903093 100644 --- a/Code/Scripts/Script-machine/control-flow.lisp +++ b/Code/Scripts/Script-machine/control-flow.lisp @@ -1,14 +1,14 @@ (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) diff --git a/Code/Scripts/Script-machine/discriminator-function.lisp b/Code/Scripts/Script-machine/discriminator-function.lisp index 587b300e98215a555a5aae317a371b48e78b5ce0..2a3e64db967dcb49943da05c2db7dc2bc83cc060 100644 --- a/Code/Scripts/Script-machine/discriminator-function.lisp +++ b/Code/Scripts/Script-machine/discriminator-function.lisp @@ -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) diff --git a/Code/Scripts/Script-machine/environments.lisp b/Code/Scripts/Script-machine/environments.lisp index bc39c5654de86092cc197dd9b7f8742d5917387c..81364d20ea0393d5566f6ccacd73ef809458f5d1 100644 --- a/Code/Scripts/Script-machine/environments.lisp +++ b/Code/Scripts/Script-machine/environments.lisp @@ -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) diff --git a/Code/Scripts/Script-machine/script-machine.lisp b/Code/Scripts/Script-machine/script-machine.lisp index 67304762cecd8675d19c9576b6fa038bcbcd821d..48b39963ecbc8c39d1911bd5b31087f6ff4b5e58 100644 --- a/Code/Scripts/Script-machine/script-machine.lisp +++ b/Code/Scripts/Script-machine/script-machine.lisp @@ -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)