diff --git a/Cross/client.lisp b/Cross/client.lisp index 52b1eba..51d40ec 100644 --- a/Cross/client.lisp +++ b/Cross/client.lisp @@ -22,3 +22,7 @@ (clostrum-sys:variable-cell client (clostrum:evaluation-environment client env) name)))) + +(defmethod cmp:load-literal-info ((client client) (info cmp:env-info) + env) + (clostrum:evaluation-environment client env)) diff --git a/Cross/vm.lisp b/Cross/vm.lisp index a54d0cb..47a2643 100644 --- a/Cross/vm.lisp +++ b/Cross/vm.lisp @@ -16,7 +16,8 @@ (args 0 :type (and unsigned-byte fixnum)) (arg-count 0 :type (and unsigned-byte fixnum)) (pc 0 :type (and unsigned-byte fixnum)) - (dynenv-stack nil :type list)) + (dynenv-stack nil :type list) + (client (error "missing arg"))) (defvar *vm*) (declaim (type vm *vm*)) @@ -74,11 +75,12 @@ (setf (vm-pc vm) old-pc)) (values-list (vm-values vm))))) -(defun initialize-vm (stack-size) +(defun initialize-vm (stack-size &optional (client m:*client*)) (setf *vm* (make-vm :stack (make-array stack-size) :frame-pointer 0 - :stack-top 0)) + :stack-top 0 + :client client)) (values)) (declaim (inline signed)) @@ -184,9 +186,16 @@ (declare (type (unsigned-byte 16) n)) (let ((result nil)) ; put the most recent value on the end (loop repeat n do (push (spop) result)) - result))) + result)) + (call (nargs) + (let ((args (gather nargs)) (callee (spop))) + (declare (type function callee)) + (setf (vm-stack-top vm) sp) + (apply callee args))) + (mv-call () (call (spop)))) (declare (inline stack (setf stack) spush spop - code next-code constant closure)) + code next-code constant closure + call mv-call)) (prog ((end (length bytecode)) (trace *trace*) ;; KLUDGE: we can't use bp directly since catch uses eq. @@ -205,35 +214,23 @@ ;; CATCH will too generally. (setf ip (catch tag - (ecase (code) + (case (code) ((#.m:ref) (spush (stack (+ bp (next-code)))) (incf ip)) ((#.m:const) (spush (constant (next-code))) (incf ip)) ((#.m:closure) (spush (closure (next-code))) (incf ip)) ((#.m:call) (setf (vm-values vm) - (multiple-value-list - (let ((args (gather (next-code))) - (callee (spop))) - (declare (type function callee)) - (setf (vm-stack-top vm) sp) - (apply callee args)))) + (multiple-value-list (call (next-code)))) (incf ip)) ((#.m:call-receive-one) - (spush (let ((args (gather (next-code))) - (callee (spop))) - (declare (type function callee)) - (setf (vm-stack-top vm) sp) - (apply callee args))) + (spush (call (next-code))) (incf ip)) ((#.m:call-receive-fixed) - (let ((args (gather (next-code))) (mvals (next-code)) - (fun (spop))) - (declare (function fun)) - (setf (vm-stack-top vm) sp) + (let ((nargs (next-code)) (mvals (next-code))) (case mvals - ((0) (apply fun args)) - (t (mapcar #'spush (subseq (multiple-value-list (apply fun args)) + ((0) (call nargs)) + (t (mapcar #'spush (subseq (multiple-value-list (call nargs)) 0 mvals))))) (incf ip)) ((#.m:bind) @@ -254,7 +251,7 @@ ((#.m:make-closure) (spush (let ((template (constant (next-code)))) (m:make-bytecode-closure - m:*client* + (vm-client vm) template (coerce (gather (m:bytecode-function-environment-size template)) @@ -263,7 +260,7 @@ ((#.m:make-uninitialized-closure) (spush (let ((template (constant (next-code)))) (m:make-bytecode-closure - m:*client* + (vm-client vm) template (make-array (m:bytecode-function-environment-size template))))) @@ -491,37 +488,46 @@ (setf (vm-values vm) (gather (spop))) (incf ip)) ((#.m:mv-call) - (setf (vm-stack-top vm) sp - (vm-values vm) - (multiple-value-list - (apply (the function (spop)) (vm-values vm)))) + (setf (vm-values vm) + (multiple-value-list (mv-call))) (incf ip)) ((#.m:mv-call-receive-one) - (setf (vm-stack-top vm) sp) - (spush (apply (the function (spop)) (vm-values vm))) + (spush (mv-call)) (incf ip)) ((#.m:mv-call-receive-fixed) - (let ((args (vm-values vm)) - (mvals (next-code)) - (fun (spop))) - (declare (function fun)) - (setf (vm-stack-top vm) sp) + (let ((mvals (next-code))) (case mvals - ((0) (apply fun args)) - (t (mapcar #'spush (subseq (multiple-value-list (apply fun args)) + ((0) (mv-call)) + (t (mapcar #'spush (subseq (multiple-value-list (mv-call)) 0 mvals))))) (incf ip)) - ((#.m:fdefinition) + ((#.m:fdefinition #.m:called-fdefinition) (spush (car (constant (next-code)))) (incf ip)) ((#.m:nil) (spush nil) (incf ip)) ((#.m:eq) (spush (eq (spop) (spop))) (incf ip)) ((#.m:pop) (setf (vm-values vm) (list (spop))) (incf ip)) ((#.m:push) (spush (first (vm-values vm))) (incf ip)) + ((#.m:dup) + (let ((v (spop))) (spush v) (spush v)) (incf ip)) + ((#.m:fdesignator) + (let ((desig (spop))) + (spush + (etypecase desig + ;; have to advance the IP for the env + ;; when we don't use it. + (function (incf ip) desig) + (symbol + (clostrum:fdefinition + (vm-client vm) (constant (next-code)) + desig))))) + (incf ip)) ((#.m:long) (ecase (next-code) (#.m:const (spush (constant (+ (next-code) (ash (next-code) 8)))) - (incf ip))))) + (incf ip)))) + (otherwise + (error "Unknown opcode #x~x" (code)))) (go loop))) (go loop))))) diff --git a/FASL.md b/FASL.md index 9b07b08..aeba626 100644 --- a/FASL.md +++ b/FASL.md @@ -20,6 +20,17 @@ After the last instruction is executed, the FASL has been fully loaded. Any rema # Changelog +## 0.13 (pending) + +* `fdesignator` changed to have an environment parameter for first-class environment purposes. +* `environment` fasl op to get the loader environment for `fdesignator`. + +## 0.12 + +* `mv-call[-receive-{one,fixed}] semantics changed so that arguments are on stack rather than values vector. +* `called-fdefinition` instruction added for microoptimized function lookup. +* `fdesignator` instruction added so that `multiple-value-call` can be compiled without other environment support. (NOTE: The 0.12 version of this instruction does not have an environment parameter. The 0.12 version was only used in Clasp and is not represented in this repository's history.) + ## 0.11 * New `vcell` and `fcell` instructions can be used to look up variable and function cells at load time to speed execution, if the implementation supports it. They are also useful for first-class environments. diff --git a/cmpltv.lisp b/cmpltv.lisp index ff40670..1b1944c 100644 --- a/cmpltv.lisp +++ b/cmpltv.lisp @@ -161,7 +161,7 @@ ;;; Look up the "cell" for a function binding - something that the VM's ;;; FDEFINITION instruction can get an actual function out of. ;;; The nature of this cell is implementation-dependent. -;;; In a simple implementation, the "cell" can just be the function name, +;;; In a one-environment implementation, the "cell" can just be the function name, ;;; and the FDEFINITION instruction just does CL:FDEFINITION. (defclass fcell-lookup (creator) ((%name :initarg :name :reader name :type creator))) @@ -171,11 +171,17 @@ ;;; as a lookup key for the binding, as well as for establishing new ;;; local bindings. ;;; The nature of this cell is implementation-dependent. -;;; In a simple implementation, the "cell" can just be the symbol itself, +;;; In a one-environment implementation, the "cell" can just be the symbol itself, ;;; and the SYMBOL-VALUE instruction just does CL:SYMBOL-VALUE, etc. (defclass vcell-lookup (creator) ((%name :initarg :name :reader name :type creator))) +;;; Look up the global environment the FASL was loaded in. +;;; In a one-environment implementation this can just return NIL, +;;; as the VM won't need any references to other environments. +(defclass environment-lookup (creator) + ()) + (defclass general-creator (vcreator) (;; Reference to a function designator to call to allocate the object, ;; e.g. a function made of the first return value from make-load-form. @@ -273,6 +279,9 @@ (defvar *fcell-coalesce*) ;;; And variable cells. (defvar *vcell-coalesce*) +;;; Since there's only ever at most one environment cell, it's just +;;; stored directly in this variable rather than a table. +(defvar *environment-coalesce*) ;; Look up a value in the existing instructions. ;; On success returns the creator, otherwise NIL. @@ -290,6 +299,8 @@ (defun find-fcell (name) (values (gethash name *fcell-coalesce*))) (defun find-vcell (name) (values (gethash name *vcell-coalesce*))) +(defun find-environment () *environment-coalesce*) + ;;; List of instructions to be executed by the loader. ;;; In reverse. (defvar *instructions*) @@ -306,7 +317,8 @@ (*coalesce* (make-hash-table)) (*oob-coalesce* (make-hash-table)) (*fcell-coalesce* (make-hash-table :test #'equal)) - (*vcell-coalesce* (make-hash-table))) + (*vcell-coalesce* (make-hash-table)) + (*environment-coalesce* nil)) ,@body)) (defun find-constant (value) @@ -338,6 +350,9 @@ (setf (gethash key *vcell-coalesce*) instruction) (add-instruction instruction)) +(defun add-environment (instruction) + (setf *environment-coalesce* instruction)) + (defgeneric add-constant (value)) (defun ensure-constant (value &key permanent) @@ -662,7 +677,8 @@ (fcell 96 find nameind) (vcell 97 vind nameind) (find-class 98 sind cnind) - (init-object-array 99 ub64) + (init-object-array 99 ub64) + (environment 100) (attribute 255 name nbytes . data))) ;;; STREAM is a ub8 stream. @@ -688,7 +704,7 @@ (defun write-magic (stream) (write-b32 +magic+ stream)) (defparameter *major-version* 0) -(defparameter *minor-version* 11) +(defparameter *minor-version* 13) (defun write-version (stream) (write-b16 *major-version* stream) @@ -1024,6 +1040,10 @@ (write-index inst stream) (write-index (name inst) stream)) +(defmethod encode ((inst environment-lookup) stream) + (write-mnemonic 'environment stream) + (write-index inst stream)) + (defmethod encode ((inst general-creator) stream) (write-mnemonic 'funcall-create stream) (write-index inst stream) @@ -1168,6 +1188,10 @@ (defmethod ensure-module-literal ((info cmp:value-cell-info)) (ensure-vcell (cmp:value-cell-info-name info))) +(defmethod ensure-module-literal ((info cmp:env-info)) + (or (find-environment) + (add-environment (make-instance 'environment-lookup)))) + (defun add-module (value) ;; Add the module first to prevent recursion. (let ((mod diff --git a/compile.lisp b/compile.lisp index b5440c8..026f74c 100644 --- a/compile.lisp +++ b/compile.lisp @@ -15,6 +15,7 @@ (:export #:fdefinition-info #:fdefinition-info-name) (:export #:value-cell-info #:value-cell-info-name) (:export #:constant-info #:constant-info-value) + (:export #:env-info) (:export #:cmodule #:make-cmodule #:cmodule-literals #:link) (:export #:cfunction #:cfunction-cmodule #:cfunction-nlocals #:cfunction-closed #:cfunction-entry-point #:cfunction-name @@ -80,6 +81,12 @@ (defstruct (value-cell-info (:constructor make-value-cell-info (name))) name) +;;; This info represents the loader environment. It is used for a few +;;; instructions that need to perform runtime name lookups. +;;; Any constants vector has at most one of these, since everything is +;;; after all being loaded into the same environment. +(defstruct (env-info (:constructor make-env-info ()))) + ;;; The context contains information about what the current form needs ;;; to know about what it is enclosed by. (defstruct context @@ -157,6 +164,11 @@ (defun ltv-index (ltv-info context) (vector-push-extend ltv-info (cmodule-literals (context-module context)))) +(defun env-index (context) + (let ((literals (cmodule-literals (context-module context)))) + (or (position-if (lambda (lit) (typep lit 'env-info)) literals) + (vector-push-extend (make-env-info) literals)))) + (defun closure-index (info context) (let ((closed (cfunction-closed (context-function context)))) (or (position info closed) @@ -971,22 +983,16 @@ (defun compile-setq-1-special (var valf env context) (compile-form valf env (new-context context :receiving 1)) - ;; If we need to return the new value, stick it into a new local - ;; variable, do the set, then return the lexical variable. + ;; If we need to return the new value, dup on the stack. ;; We can't just read from the special, since some other thread may ;; alter it. (let ((index (context-frame-end context))) (unless (eql (context-receiving context) 0) - (assemble-maybe-long context m:set index) - (assemble-maybe-long context m:ref index) - ;; called for effect, i.e. to keep frame size correct - (bind-vars (list var) env context)) + (assemble context m:dup)) (assemble-maybe-long context m:symbol-value-set (value-cell-index var context)) - (unless (eql (context-receiving context) 0) - (assemble-maybe-long context m:ref index) - (when (eql (context-receiving context) t) - (assemble context m:pop))))) + (when (eql (context-receiving context) t) + (assemble context m:pop)))) (defmethod compile-setq-1 ((info trucler:special-variable-description) var valf env context) @@ -1006,9 +1012,7 @@ (compile-form valf env (new-context context :receiving 1)) ;; similar concerns to specials above. (unless (eql (context-receiving context) 0) - (assemble-maybe-long context m:set index) - (assemble-maybe-long context m:ref index) - (bind-vars (list var) env context)) + (assemble context m:dup)) (cond (localp (emit-lexical-set info context)) ;; Don't emit a fixup if we already know we need a cell. @@ -1016,10 +1020,8 @@ (assemble-maybe-long context m:closure (closure-index info context)) (assemble context m:cell-set))) - (unless (eql (context-receiving context) 0) - (assemble-maybe-long context m:ref index) - (when (eql (context-receiving context) t) - (assemble context m:pop))))) + (when (eql (context-receiving context) t) + (assemble context m:pop)))) (defmethod compile-special ((op (eql 'setq)) form env context) (let ((pairs (rest form))) @@ -1277,21 +1279,13 @@ ((cons (eql lambda)) (compile-lambda-expression form env context)) ((cons (eql quote) (cons symbol null)) ; 'foo - (compile-form `(fdefinition ,form) env (new-context context :receiving 1))) + ;; This is like compile-function-lookup but we ignore any local + ;; environments. We also don't signal any unknown function + ;; warnings as this is a very runtime sort of lookup. + (emit-fdefinition context (fdefinition-index (second form) context))) (t - (let* ((fsym (gensym "FUNCTION-DESIGNATOR")) - ;; Try to avoid using macros (etypecase) for the sake of - ;; compatibility with a native client. For example, SBCL's - ;; COND cannot be macroexpanded in our environments. - ;; TODO: Newer VM version makes this a VM operation. - (form `(let ((,fsym ,form)) - (if (functionp ,fsym) - ,fsym - (if (symbolp ,fsym) - (fdefinition ,fsym) - (error 'type-error :datum ,fsym - :expected-type '(or symbol function))))))) - (compile-form form env (new-context context :receiving 1)))))) + (compile-form form env (new-context context :receiving 1)) + (assemble-maybe-long context m:fdesignator (env-index context))))) (defmethod compile-special ((op (eql 'multiple-value-call)) form env context) (let ((function-form (second form)) (forms (cddr form))) @@ -1300,12 +1294,11 @@ (let ((first (first forms)) (rest (rest forms))) (compile-form first env (new-context context :receiving t)) + (assemble context m:push-values) (when rest - (assemble context m:push-values) (dolist (form rest) (compile-form form env (new-context context :receiving t)) - (assemble context m:append-values)) - (assemble context m:pop-values)) + (assemble context m:append-values))) (emit-mv-call context)) (emit-call context 0)))) @@ -1709,6 +1702,11 @@ (defmethod load-literal-info (client (info value-cell-info) env) (declare (ignore client env)) (value-cell-info-name info)) +;;; By default the VM just ignores the environment and uses the +;;; native global environment. +(defmethod load-literal-info (client (info env-info) env) + (declare (ignore client)) + env) ;;; Run down the hierarchy and link the compile time representations ;;; of modules and functions together into runtime objects. diff --git a/machine.lisp b/machine.lisp index 4d66ce9..d2fc52b 100644 --- a/machine.lisp +++ b/machine.lisp @@ -127,4 +127,7 @@ (eq 55) (push 56) (pop 57) - (long 58))) + (dup 58) + (fdesignator 59) + (called-fdefinition 60) + (long 255))) diff --git a/test/cross/packages.lisp b/test/cross/packages.lisp index 1f8b29d..da9c4c8 100644 --- a/test/cross/packages.lisp +++ b/test/cross/packages.lisp @@ -1,4 +1,4 @@ (defpackage #:cvm.test.cross (:use #:cl) (:local-nicknames (#:s #:cvm.test.sham)) - (:export #:fill-environment #:run #:run!)) + (:export #:*client* #:fill-environment #:run #:run!)) diff --git a/test/cross/script.lisp b/test/cross/script.lisp index b048097..efde856 100644 --- a/test/cross/script.lisp +++ b/test/cross/script.lisp @@ -26,7 +26,7 @@ #+sbcl (sb-ext:exit :code code)) (defun test () - (cvm.cross.vm:initialize-vm 20000) + (cvm.cross.vm:initialize-vm 20000 cvm.test.cross:*client*) (let* ((rte (make-instance 'clostrum-basic:run-time-environment)) (ce (make-instance 'clostrum-basic:compilation-environment :parent rte))) diff --git a/vm.lisp b/vm.lisp index c537571..f3400fa 100644 --- a/vm.lisp +++ b/vm.lisp @@ -126,9 +126,16 @@ (declare (type (unsigned-byte 16) n)) (let ((result nil)) ; put the most recent value on the end (loop repeat n do (push (spop) result)) - result))) + result)) + (call (nargs) + (let ((args (gather nargs)) (callee (spop))) + (declare (type function callee)) + (setf (vm-stack-top vm) sp) + (apply callee args))) + (mv-call () (call (spop)))) (declare (inline stack (setf stack) spush spop - code next-code constant closure)) + code next-code constant closure + call mv-call)) (loop with end = (length bytecode) with trace = *trace* until (eql ip end) @@ -144,27 +151,22 @@ ;; We take the max for partial frames. (subseq stack frame-end (max sp frame-end))) *trace-output*)) - do (ecase (code) + do (case (code) ((#.m:ref) (spush (stack (+ bp (next-code)))) (incf ip)) ((#.m:const) (spush (constant (next-code))) (incf ip)) ((#.m:closure) (spush (closure (next-code))) (incf ip)) ((#.m:call) (setf (vm-values vm) - (multiple-value-list - (let ((args (gather (next-code)))) - (apply (the function (spop)) args)))) + (multiple-value-list (call (next-code)))) (incf ip)) ((#.m:call-receive-one) - (spush (let ((args (gather (next-code)))) - (apply (the function (spop)) args))) + (spush (call (next-code))) (incf ip)) ((#.m:call-receive-fixed) - (let ((args (gather (next-code))) (mvals (next-code)) - (fun (spop))) - (declare (function fun)) + (let ((nargs (next-code)) (mvals (next-code))) (case mvals - ((0) (apply fun args)) - (t (mapcar #'spush (subseq (multiple-value-list (apply fun args)) + ((0) (call nargs)) + (t (mapcar #'spush (subseq (multiple-value-list (call nargs)) 0 mvals))))) (incf ip)) ((#.m:bind) @@ -424,33 +426,43 @@ (incf ip)) ((#.m:mv-call) (setf (vm-values vm) - (multiple-value-list - (apply (the function (spop)) (vm-values vm)))) + (multiple-value-list (mv-call))) (incf ip)) ((#.m:mv-call-receive-one) - (spush (apply (the function (spop)) (vm-values vm))) + (spush (mv-call)) (incf ip)) ((#.m:mv-call-receive-fixed) - (let ((args (vm-values vm)) - (mvals (next-code)) - (fun (spop))) - (declare (function fun)) + (let ((mvals (next-code))) (case mvals - ((0) (apply fun args)) - (t (mapcar #'spush (subseq (multiple-value-list (apply fun args)) + ((0) (mv-call)) + (t (mapcar #'spush (subseq (multiple-value-list (mv-call)) 0 mvals))))) (incf ip)) - ((#.m:fdefinition) + ((#.m:fdefinition #.m:called-fdefinition) (spush (fdefinition (constant (next-code)))) (incf ip)) ((#.m:nil) (spush nil) (incf ip)) ((#.m:eq) (spush (eq (spop) (spop))) (incf ip)) ((#.m:pop) (setf (vm-values vm) (list (spop))) (incf ip)) ((#.m:push) (spush (first (vm-values vm))) (incf ip)) + ((#.m:dup) + (let ((v (spop))) (spush v) (spush v)) (incf ip)) + ((#.m:fdesignator) + ;; we ignore the environment but still need to + ;; advance the IP. + (incf ip) + (let ((fdesig (spop))) + (spush + (etypecase fdesig + (function fdesig) + (symbol (fdefinition fdesig))))) + (incf ip)) ((#.m:long) (ecase (next-code) (#.m:const (spush (constant (+ (next-code) (ash (next-code) 8)))) - (incf ip)))))))))) + (incf ip)))) + (otherwise + (error "Unknown opcode #x~x" (code))))))))) (defmethod m:compute-instance-function ((client trucler-native:client) (closure m:bytecode-closure))