diff --git a/FASL.md b/FASL.md index b04b7cc..c2cbcee 100644 --- a/FASL.md +++ b/FASL.md @@ -20,6 +20,12 @@ After the last instruction is executed, the FASL has been fully loaded. Any rema # Changelog +## 0.14 (pending) + +* `listify-rest-args` now assigns directly to a local rather than pushing to the stack. +* New `encell` instruction for a common lexical variable cell making operation. +* `protect` now gets its function from the literals vector. + ## 0.13 * `fdesignator` and `progv` changed to have an environment parameter for first-class environment purposes. diff --git a/MACHINE.md b/MACHINE.md index 4d041ec..f90d625 100644 --- a/MACHINE.md +++ b/MACHINE.md @@ -10,7 +10,7 @@ Bytecode is organized into modules. A module contains the bytecode for one or mo Function cells and variable cells are implementation-defined objects that represent global bindings in some environment. A function or variable cell has an associated name; when the value bound to that environment's function or variable binding (respectively) of that name changes, or when the binding is made unbound, the cell reflects the change. When a bytecode module is loaded, the loader defines what environment it is loading into, and all function cells and variable cells are for bindings in this one environment. -A bytecode function is made of a "template" and a closure vector. CVM uses flat closures, so closures do not need to maintain a chain of environments. Each element of the closure vector is either a value or a _cell_ (distinct from function and variable cells). A cell is an object that holds a value and may have that value changed; cells are used when a function can mutate lexical variables within another closure. +Bytecode functions can be either closures or "templates". A closure is made up of a "template" and a closure vector. CVM uses flat closures, so closures do not need to maintain a chain of environments. Each element of the closure vector is either a value or a _cell_ (distinct from function and variable cells). A cell is an object that holds a value and may have that value changed; cells are used when a function can mutate lexical variables within another closure. All other information about a function is part of the template. Bytecode function templates contain the following information: @@ -19,6 +19,8 @@ All other information about a function is part of the template. Bytecode functio * A count of how many closure values and cells a function with this template has. * An entry point: the index, into the module's bytecode, of the function's first instruction. +If a template has a closure count of zero, it is itself callable as a function. This allows the machine to skip allocation in the common case of non-closure functions. Templates that do need closures are never directly accessible in normal operation; they are only used for making closures. + # Operation The virtual machine has the following state: @@ -91,7 +93,7 @@ The following operations are used in this pseudocode: * `(make-progv-dynenv vcells values)` creates a new dynamic environment entry representing a `progv` binding of the vcells to the values. * `(vcell-value vcell DESTACK)` accesses the binding of the variable cell in the given dynamic environment stack. When reading the value, if the vcell is unbound, an `unbound-variable` error is signaled. With the shallow binding used in this description, `vcell-value` would look through the `DESTACK` for any special binding or progv entries binding the variable, and if it didn't find any, would use the global binding. * `(make-protection-dynenv thunk)` creates a new dynamic environment entry representing a cleanup, from the `protect` instruction. `protection-dynenv-thunk` reads the thunk. -* `(cleanup entry)` executes any cleanup actions required when unwinding a given dynamic environment entry. With the presentation here, the only required action is that `cleanup` of a protection dynenv will call its thunk. +* `(cleanup entry)` executes any cleanup actions required when unwinding a given dynamic environment entry. With the presentation here, the only required action is that `cleanup` of a protection dynenv will call its thunk. Around calling this thunk, `VALUES` is saved. After any instruction that does not alter `ip`, `ip` is advanced to the next instruction (after the opcode and all of the parameters). @@ -245,10 +247,10 @@ Set the `nopt` locals beginning at `nreq` to be the arguments beginning at `nreq ### listify-rest-args #x11 (nfixed misc) -Construct a list out of all the arguments beginning at `nfixed`, and push it. [FIXME: This instruction should probably assign directly to a local.] +Construct a list out of all the arguments beginning at `nfixed`, and assign it to the `nfixed`th local. ```lisp -(push (nthcdr nfixed ARGUMENTS) STACK) +(setf (aref LOCALS nfixed) (nthcdr nfixed ARGUMENTS)) ``` @@ -594,12 +596,16 @@ This is identical to `fdefinition`, except that it is guaranteed that the functi (push (fcell-function (aref LITERALS fcell)) STACK) ``` -### protect #x3d +### protect #x3d (template literal) + +`template` is a bytecode function template from this module for a function that accepts zero arguments. Pop as many values from the stack as it needs and make a closure from the template. Create a new protection dynenv with the resulting function and push it to `destack`. Any exits through this dynenv will call the cleanup function, so this is used to implement `cl:unwind-protect`. -Pop a value from `stack`: it is a function accepting no arguments. Create a new protection dynenv with that function and push it to `destack`. Any exits through this dynenv will call the cleanup function, so this is used to implement `cl:unwind-protect`. +As the closure is only used for cleanups, it has dynamic extent. Implementations may choose to allocate it more efficiently, or to use the template as a "closure" when it doesn't close over anything. ```lisp -(push (make-protection-dynenv (pop STACK)) DESTACK) +(let* ((template (aref LITERALS template)) + (closure (make-closure template (gather (closure-size template))))) + (push (make-protection-dynenv closure DESTACK))) ``` ### cleanup #x3e @@ -607,8 +613,17 @@ Pop a value from `stack`: it is a function accepting no arguments. Create a new Pop a dynenv from `destack`: it is a protection dynenv. Call its thunk with no arguments. This ends a body protected by `cl:unwind-protect` when not performing a nonlocal exit. ```lisp -(funcall (protection-dynenv-thunk (pop DESTACK))) +(cleanup (pop DESTACK)) +``` + +### encell #x3f (index misc) +Grab the `index`th local value. Put it in a fresh cell. Put it back. + +This is equivalent to `ref index; make-cell; set index;` but is common enough to get its own instruction. And it makes analysis of bytecode a little simpler. + +```lisp +(setf (aref LOCALS index) (make-cell (aref LOCALS index))) ``` ### long #xff @@ -629,10 +644,10 @@ bytecode can be analyzed coherently, there are many constraints on valid program * `values` is in an invalid state when `mv-call[-etc]`, `call[-etc]`, or `pop` is executed. Additionally it invalid before `exit` instructions if the target of the exit needs an invalid state. * Dynamic environments are properly nested; so for example `entry-close` is never executed when the most recently pushed dynamic environment was not an `entry`. The nature of the dynamic environment stack at least back up to the call at any position is knowable statically. * Dynamic environments are properly closed before any `return`. -* `make-cell` never pops a cell (i.e. cells are not wrapped in cells). +* `make-cell` never pops a cell (i.e. cells are not wrapped in cells). `encell` similarly never reads a local that already holds a cell. * Cells on the stack are only ever popped by the following instructions: `cell-ref`, `cell-set`, `make-closure`, `initialize-closure`. * `cell-ref` and `cell-set` only pop cells. -* The literal referred to by `const` is not a function or variable cell. The literals referred to by `make-closure` and `make-uninitialized-closure` are function templates. The literals referred to by `parse-key-args` are symbols. The literals referred to by `special-bind`, `symbol-value`, and `symbol-value-set` are variable cells. The literal referred to by `fdefinition` is a function cell. The literals referred to by `progv` and `fdesignator` are the environment. +* The literal referred to by `const` is not a function cell, variable cell, the environment, or template that needs a closure. The literals referred to by `make-closure` and `make-uninitialized-closure` are function templates. The literals referred to by `parse-key-args` are symbols. The literals referred to by `special-bind`, `symbol-value`, and `symbol-value-set` are variable cells. The literal referred to by `fdefinition` is a function cell. The literals referred to by `progv` and `fdesignator` are the environment. * The object constructed by `make-uninitialized-closure` is not popped by any instructions besides `set`, `bind`, and `initialize-closure`. In particular, it is not called. * The object popped by `initialize-closure` was pushed by `make-uninitialized-closure`. * The argument parsing instructions are not used until the argument count has been checked. @@ -641,13 +656,13 @@ bytecode can be analyzed coherently, there are many constraints on valid program * The value put in `locals` by `save-sp` is not used by anything but `restore-sp`. * The dynamic environment created by `entry` is not accessed after the corresponding `entry-close`. * The value read by `restore-sp` was created by `save-sp`. -* The value popped by `protect` originates from `constant` or `make-closure`, and is a function accepting zero arguments. [this one might need a bit of work] +* The literal referred to by `protect` is a bytecode function template in the same module, that accepts zero arguments. ## Safety constraints A safe implementation may impose the following additional constraints. If they are violated, the implementation may reject the bytecode, or fix it for safety. -* `call` and `mv-call` instruction callees are only ever the result of `fdefinition` or `fdesignator`. (To fix, an `fdesignator` instruction can be imposed before any call.) +* `call` and `mv-call` instruction callees are only ever the result of `fdefinition` or `fdesignator`, or a `const` instruction pointing to a literal that is a bytecode function template in the same module that does not need a closure. (To fix, an `fdesignator` instruction can be imposed before any call.) # Versioning diff --git a/README.md b/README.md index 7d5dae0..9b84a8d 100644 --- a/README.md +++ b/README.md @@ -52,19 +52,20 @@ You can get a running trace of the machine state by binding `cvm.vm-native:*trac ```lisp (let ((cvm.vm-native:*trace* t)) (funcall *f* 3)) ; => -((CHECK-ARG-COUNT-= COMMON-LISP:NIL (:OPERAND 1)) 4 6 #(5 0) #()) -((BIND-REQUIRED-ARGS COMMON-LISP:NIL (:OPERAND 1)) 4 6 #(5 0) #()) -((CONST COMMON-LISP:NIL (:CONSTANT 0)) 4 6 #(3 0) #()) -((SET COMMON-LISP:NIL (:OPERAND 1)) 4 7 #(3 0) #(5)) -((FDEFINITION COMMON-LISP:NIL (:CONSTANT 1)) 4 6 #(3 5) #()) -((REF COMMON-LISP:NIL (:OPERAND 1)) 4 7 #(3 5) #(#)) -((CALL COMMON-LISP:NIL (:OPERAND 1)) 4 8 #(3 5) #(# 5)) + check-arg-count-= 1 ; bp 1 sp 3 locals #(0 0) stack #() + bind-required-args 1 ; bp 1 sp 3 locals #(0 0) stack #() + const '5 ; bp 1 sp 3 locals #(3 0) stack #() + set 1 ; bp 1 sp 4 locals #(3 0) stack #(5) + fdefinition 'PRINT ; bp 1 sp 3 locals #(3 5) stack #() + ref 1 ; bp 1 sp 4 locals #(3 5) stack #(#) + call 1 ; bp 1 sp 5 locals #(3 5) stack #(# 5) + 5 -((REF COMMON-LISP:NIL (:OPERAND 1)) 4 6 #(3 5) #()) -((REF COMMON-LISP:NIL (:OPERAND 0)) 4 7 #(3 5) #(5)) -((MAKE-CLOSURE COMMON-LISP:NIL (:CONSTANT 3)) 4 8 #(3 5) #(5 3)) -((POP COMMON-LISP:NIL) 4 7 #(3 5) #(#)) -((RETURN COMMON-LISP:NIL) 4 6 #(3 5) #()) + ref 1 ; bp 1 sp 3 locals #(3 5) stack #() + ref 0 ; bp 1 sp 4 locals #(3 5) stack #(5) + make-closure '# ; bp 1 sp 5 locals #(3 5) stack #(5 3) + pop ; bp 1 sp 4 locals #(3 5) stack #(#) + return ; bp 1 sp 3 locals #(3 5) stack #() # ``` diff --git a/access.lisp b/access.lisp index 3aacb87..cd25b7c 100644 --- a/access.lisp +++ b/access.lisp @@ -4,6 +4,8 @@ (defgeneric symbol-value (client environment symbol)) (defgeneric (setf symbol-value) (new client environment symbol)) +(defgeneric boundp (client environment symbol)) +(defgeneric makunbound (client environment symbol)) (defgeneric call-with-progv (client environment symbols values thunk)) (defmacro progv (client environment symbols values &body body) diff --git a/compile-file/preliminaries.lisp b/compile-file/preliminaries.lisp index 25e8109..d8c5dda 100644 --- a/compile-file/preliminaries.lisp +++ b/compile-file/preliminaries.lisp @@ -10,7 +10,7 @@ ;;; The versioning encompasses both the FASL format itself as well as the ;;; bytecode in modules. Changes to bytecode should get a version bump too. (defparameter *major-version* 0) -(defparameter *minor-version* 13) +(defparameter *minor-version* 14) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; diff --git a/compile/compile.lisp b/compile/compile.lisp index fdd4d8e..f71d4b4 100644 --- a/compile/compile.lisp +++ b/compile/compile.lisp @@ -174,12 +174,14 @@ (defun new-context (parent &key (receiving (context-receiving parent)) (dynenv nil) ; prepended - (frame-end nil fep) ; added + (frame-end (context-frame-end parent) fep) (function (context-function parent))) + (when fep + (setf (cfunction-%nlocals function) + (max (cfunction-%nlocals function) frame-end))) (make-context :receiving receiving :dynenv (append dynenv (context-dynenv parent)) - :frame-end (+ (if fep frame-end 0) - (context-frame-end parent)) + :frame-end frame-end :function function)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -408,17 +410,14 @@ (defun maybe-emit-cell-ref (lexical-var context) (maybe-emit lexical-var m:cell-ref context))) -;;; FIXME: This is probably a good candidate for a specialized -;;; instruction. -(defun maybe-emit-encage (lexical-var context) +(defun maybe-emit-encell (lexical-var context) (let ((index (frame-offset lexical-var))) (flet ((emitter (fixup position code) - (assert (= (fixup-size fixup) 5)) - (assemble-into code position - m:ref index m:make-cell m:set index)) + (assert (= (fixup-size fixup) 2)) + (assemble-into code position m:encell index)) (resizer (fixup) (declare (ignore fixup)) - (if (indirect-lexical-p lexical-var) 5 0))) + (if (indirect-lexical-p lexical-var) 2 0))) (emit-fixup context (make-fixup lexical-var 0 #'emitter #'resizer))))) (defun emit-lexical-set (lexical-var context) @@ -614,8 +613,6 @@ (var-count (length vars)) (frame-end (+ frame-start var-count)) (function (context-function context))) - (setf (cfunction-%nlocals function) - (max (cfunction-%nlocals function) frame-end)) (do ((index frame-start (1+ index)) (vars vars (rest vars)) (new-vars (vars env) @@ -624,7 +621,7 @@ new-vars))) ((>= index frame-end) (values (make-lexical-environment env :vars new-vars) - (new-context context :frame-end var-count))) + (new-context context :frame-end frame-end))) (when (constantp (first vars) env) (error 'bind-constant :name (first vars)))))) @@ -634,8 +631,6 @@ (fun-count (length funs)) (frame-end (+ frame-start fun-count)) (function (context-function context))) - (setf (cfunction-%nlocals function) - (max (cfunction-%nlocals function) frame-end)) (do ((index frame-start (1+ index)) (funs funs (rest funs)) (new-vars (funs env) @@ -644,7 +639,7 @@ new-vars))) ((>= index frame-end) (values (make-lexical-environment env :funs new-vars) - (new-context context :frame-end fun-count)))))) + (new-context context :frame-end frame-end)))))) (defun add-macros (env macros) (make-lexical-environment env :funs (append macros (funs env)))) @@ -836,27 +831,35 @@ (reference-lexical-variable info context) (compile-call (rest form) env context)) -;;; Given a lambda expression, generate code to push it to the stack -;;; as you would for #'(lambda ...). -;;; CONTEXT's number of return values is ignored. -(defun compile-lambda-expression (lexpr env context - &rest keys &key name block-name declarations) - (declare (ignore name block-name declarations)) - ;; TODO: check car is actually LAMBDA +;;; Given a lambda expression, compile it, and generate code to get the +;;; values it closes over. Return the cfunction. +;;; Used by both compile-lambda-expression and the unwind-protect compiler. +(defun %compile-lambda-expression (lexpr env context &rest keys) (destructure-syntax (lambda lambda-list . body) (lexpr) (let* ((cfunction (apply #'compile-lambda lambda-list body env (context-module context) keys)) (closed (cfunction-closed cfunction))) (loop for info across closed do (reference-lexical-variable info context)) - (if (zerop (length closed)) - (emit-const context (cfunction-literal-index cfunction context)) - (assemble context m:make-closure - (cfunction-literal-index cfunction context)))))) + cfunction))) + +;;; Given a lambda expression, generate code to push it to the stack +;;; as you would for #'(lambda ...). +;;; CONTEXT's number of return values is ignored. +(defun compile-lambda-expression (lexpr env context + &rest keys &key name block-name declarations) + (declare (ignore name block-name declarations)) + (let ((cfunction + (apply #'%compile-lambda-expression lexpr env context keys))) + (if (zerop (length (cfunction-closed cfunction))) + (emit-const context (cfunction-literal-index cfunction context)) + (assemble context m:make-closure + (cfunction-literal-index cfunction context))))) (defun compile-lambda-form (form env context) ;; FIXME: We can probably handle this more efficiently (without consing ;; a closure) by using compile-with-lambda-list instead. + ;; FIXME: Check lexpr is actually a lambda expression. (let ((lexpr (car form)) (args (rest form))) (compile-lambda-expression lexpr env context) (compile-call args env context))) @@ -942,38 +945,80 @@ (values binding nil))) (defmethod compile-special ((operator (eql 'let)) form env context) + ;; This is really long because we make an environment manually rather + ;; than use bind-vars, which would be even more awkward and cons more. (destructure-syntax (let bindings . body) (form) (unless (proper-list-p bindings) (error 'improper-bindings :bindings bindings)) (multiple-value-bind (body decls) (parse-body body :whole form) (let* ((specials (extract-specials decls)) - (lexical-binding-count 0) - (special-binding-count 0) - (post-binding-env (add-specials specials env)) (frame-start (context-frame-end context)) - ;; The values are compiled in a context with no extra - ;; frame slots used, since the BIND takes place after the - ;; values are evaluated. - (valf-context (new-context context :receiving 1))) + ;; This will be built up as we process the bindings, and then + ;; reduced as we generate the bind instructions. + (frame-end frame-start) + (cf (context-function context)) + (valc (new-context context :receiving 1)) + (special-binding-count 0) + new-bindings) + ;; First, go through the bindings. Compile all the value forms in order. + ;; This lets them be compiled in the same context with no extra locals, + ;; and more importantly computes the values in parallel as demanded + ;; by the standard. Anything bound to a lexical variable also gets a + ;; cell emission fixup. + ;; We collect conses (name . info). (dolist (binding bindings) - (multiple-value-bind (var valf) (canonicalize-binding binding) - (unless (symbolp var) (error 'variable-not-symbol :name var)) - (compile-form valf env valf-context) - (cond ((or (member var specials) - (globally-special-p var env)) - (incf special-binding-count) - (emit-special-bind context var) - (setf context - (new-context context :dynenv '(:special)))) - (t - (setf (values post-binding-env context) - (bind-vars (list var) post-binding-env context)) - (incf lexical-binding-count) - (maybe-emit-make-cell (var-info var post-binding-env) - context))))) - (emit-bind context lexical-binding-count frame-start) - (compile-progn body post-binding-env context) - (emit-unbind context special-binding-count))))) + (push (multiple-value-bind (var valf) + (canonicalize-binding binding) + (unless (symbolp var) + (error 'variable-not-symbol :name var)) + (compile-form valf env valc) + (cons var + (cond + ((or (member var specials) + (globally-special-p var env)) + (incf special-binding-count) + (make-instance 'trucler:local-special-variable-description + :name var)) + (t ; lexical + (let ((lex (make-lexical-variable + var frame-end cf))) + (incf frame-end) + (maybe-emit-make-cell lex context) + lex))))) + new-bindings)) + ;; That out of the way, we construct the environment and context + ;; for the body. + (let ((post-binding-env + (make-lexical-environment + env :vars (append new-bindings (vars env)))) + (post-binding-context + (new-context context + :frame-end frame-end + :dynenv (make-list special-binding-count + :initial-element :special)))) + ;; Generate the bind and special-bind instructions. + ;; We generate one bind for each block of contiguous lexicals. + ;; We bind the most recently pushed values first, so in reverse order, + ;; which of course isn't actually visible in Lisp. + (loop with nlex = 0 + for (name . info) in new-bindings + if (typep info 'trucler:lexical-variable-description) + do (incf nlex) + else ; special + do ; first finish any lexical binding. + (when (plusp nlex) + (let ((new-frame-end (- frame-end nlex))) + (emit-bind post-binding-context nlex new-frame-end) + (setf frame-end new-frame-end nlex 0))) + ;; now the special. + (emit-special-bind post-binding-context name) + finally ; and the last special binding. + (when (plusp nlex) + (emit-bind post-binding-context nlex + (- frame-end nlex)))) + ;; Finally, the actual body. + (compile-progn body post-binding-env post-binding-context) + (emit-unbind post-binding-context special-binding-count)))))) (defun compile-let* (bindings decls body env context &key (block-name nil block-name-p)) @@ -1312,18 +1357,14 @@ form env context) (destructure-syntax (unwind-protect protected . cleanup) (form) ;; Build a cleanup thunk. - ;; This will often/usually be a closure, which is why we - ;; can't just give M:PROTECT a constant argument. ;; The 0 is a dumb KLUDGE to let the cleanup forms be compiled in ;; non-values contexts, which might be more efficient. ;; (We use 0 instead of NIL because NIL may not be bound.) - ;; We use an ignored &rest parameter so as to avoid compiling - ;; an arg count check. - (let ((rest (gensym "IGNORED"))) - (compile-lambda-expression `(lambda (&rest ,rest) ,@cleanup 0) - env context - :declarations `((declare (ignore ,rest))))) - (assemble context m:protect) + (let ((cfunction + (%compile-lambda-expression `(lambda () ,@cleanup 0) + env context :declarations ()))) + (assemble context m:protect + (cfunction-literal-index cfunction context))) (compile-form protected env (new-context context :dynenv '(:protect))) (assemble context m:cleanup))) @@ -1534,7 +1575,7 @@ (emit-special-bind context var)) (incf special-binding-count)) (t - (maybe-emit-encage (var-info var new-env) context)))) + (maybe-emit-encell (var-info var new-env) context)))) (setq new-env (add-specials (intersection specials required) new-env))) ;; set the default env to have all the requireds bound, ;; but don't put in the optionals (yet). @@ -1555,7 +1596,6 @@ opt-key-indices)))) (when rest (assemble-maybe-long context m:listify-rest-args max-count) - (assemble-maybe-long context m:set (context-frame-end context)) (setf (values new-env context) (bind-vars (list rest) new-env context)) (cond ((or (member rest specials) @@ -1566,7 +1606,7 @@ (incf special-binding-count 1) (setq new-env (add-specials (list rest) new-env))) (t - (maybe-emit-encage (var-info rest new-env) context)))) + (maybe-emit-encell (var-info rest new-env) context)))) (when key-p ;; Generate code to parse the key args. As with optionals, we don't do ;; defaulting yet. @@ -1685,7 +1725,7 @@ (assemble-maybe-long context m:ref var-index) (emit-special-bind context var)) (t - (maybe-emit-encage info context)))) + (maybe-emit-encell info context)))) (t ;; We compile in default-env but also context. ;; The context already has space allocated for all diff --git a/cvm.asd b/cvm.asd index 4cbe74e..d26e77f 100644 --- a/cvm.asd +++ b/cvm.asd @@ -107,6 +107,7 @@ :components ((:file "similarity") (:file "externalize"))) (:file "cleanliness" :depends-on ("suites" "rt" "packages")) + (:file "cooperation" :depends-on ("suites" "rt" "packages")) (:module "compiler-conditions" :depends-on ("suites" "rt" "packages") :components ((:file "reference") diff --git a/disassemble.lisp b/disassemble.lisp index 486503b..4a144a0 100644 --- a/disassemble.lisp +++ b/disassemble.lisp @@ -68,6 +68,46 @@ do (incf ip nbytes) finally (cl:return (values (list* (first desc) longp args) ip))))) +(defun %display-instruction (name longp args textify-operand) + (if (string= name "parse-key-args") + ;; We special case this despite the keys-arg thing because it's + ;; just pretty weird all around. + (let* ((more-start (second (first args))) + (kci (second (second args))) + (aokp (logbitp (if longp 15 7) kci)) + (key-count (logand kci (if longp #x7fff #x7f))) + (keys (third args)) + (framestart (second (fourth args)))) + ;; Print + (format t "~& ~:[~;long ~]~(~a~)~:[~;-aok~] ~d ~d '~s ~d" + longp name aokp more-start key-count + (funcall textify-operand keys key-count) framestart)) + ;; Normal case + (format t "~& ~:[~;long ~]~(~a~)~{ ~a~}" + longp name (mapcar textify-operand args)))) + +(defun operand-textifier (literals) + (flet ((textify-operand (thing &optional key-count) + (destructuring-bind (kind value) thing + (cond ((cl:eq kind :constant) + (format () "'~s" (aref literals value))) + ((cl:eq kind :label) (format () "L~a" value)) + ((cl:eq kind :operand) (format () "~d" value)) + ((cl:eq kind :keys) + (let ((keys cl:nil) (keystart value)) + (do ((i 0 (1+ i))) + ((= i key-count) (setq keys (nreverse keys))) + (cl:push (aref literals (+ keystart i)) keys)) + (format () "'~s" keys))) + (t (error "Illegal kind ~a" kind)))))) + #'textify-operand)) + +;;; Used externally by tracers. +(defun display-instruction (bytecode literals ip) + (destructuring-bind (name longp . args) + (disassemble-instruction bytecode ip) + (%display-instruction name longp args (operand-textifier literals)))) + (defun %disassemble-bytecode (bytecode start end) (let* ((labels (gather-labels bytecode start end)) (ip start)) @@ -84,44 +124,19 @@ (defun disassemble-bytecode (bytecode literals &key (start 0) (end (length bytecode))) - (let ((dis (%disassemble-bytecode bytecode start end))) - (flet ((textify-operand (thing) - (destructuring-bind (kind value) thing - (cond ((cl:eq kind :constant) (format () "'~s" (aref literals value))) - ((cl:eq kind :label) (format () "L~a" value)) - ((cl:eq kind :operand) (format () "~d" value)) - ;; :keys special cased below - (t (error "Illegal kind ~a" kind)))))) - (format t "~&---module---~%") - (dolist (item dis) - (cond - ((consp item) - ;; instruction - (destructuring-bind (name longp . args) item - (if (string= name "parse-key-args") - ;; We special case this despite the keys-arg thing because it's - ;; just pretty weird all around. - (let* ((more-start (second (first args))) - (kci (second (second args))) - (aokp (logbitp (if longp 15 7) kci)) - (key-count (logand kci (if longp #x7fff #x7f))) - (keystart (second (third args))) - (keys cl:nil) - (framestart (second (fourth args)))) - ;; Gather the keys - (do ((i 0 (1+ i))) - ((= i key-count) (setq keys (nreverse keys))) - (cl:push (aref literals (+ keystart i)) keys)) - ;; Print - (format t "~& ~:[~;long ~]~(~a~)~:[~;-aok~] ~d ~d '~s ~d" - longp name aokp more-start key-count keys framestart)) - ;; Normal case - (format t "~& ~:[~;long ~]~(~a~)~{ ~a~}~%" - longp name (mapcar #'textify-operand args))))) - ((or (stringp item) (symbolp item)) - ;; label - (format t "~&L~a:~%" item)) - (t (error "Illegal item ~a" item)))))) + (let ((dis (%disassemble-bytecode bytecode start end)) + (textify-operand (operand-textifier literals))) + (format t "~&---module---~%") + (dolist (item dis) + (cond + ((consp item) + ;; instruction + (destructuring-bind (name longp . args) item + (%display-instruction name longp args textify-operand))) + ((or (stringp item) (symbolp item)) + ;; label + (format t "~&L~a:~%" item)) + (t (error "Illegal item ~a" item))))) (values)) (defgeneric disassemble (object)) diff --git a/loadltv.lisp b/loadltv.lisp index 8e23c6e..948afdf 100644 --- a/loadltv.lisp +++ b/loadltv.lisp @@ -89,8 +89,8 @@ (dbgprint "Magic number matches: ~x" magic))) ;; Bounds for major and minor version understood by this loader. -(defparameter *min-version* '(0 13)) -(defparameter *max-version* '(0 13)) +(defparameter *min-version* '(0 14)) +(defparameter *max-version* '(0 14)) (defun loadable-version-p (major minor) (and diff --git a/machine.lisp b/machine.lisp index a87348f..6f98569 100644 --- a/machine.lisp +++ b/machine.lisp @@ -3,7 +3,7 @@ (:shadow #:return #:throw #:symbol-value #:progv #:fdefinition #:nil #:eq #:set #:push #:pop) (:shadow #:disassemble) - (:shadow #:fboundp #:fmakunbound) + (:shadow #:boundp #:makunbound #:fboundp #:fmakunbound) ;; Additional opname exports are done below. (:export #:*client*) (:export #:bytecode-module #:make-bytecode-module @@ -17,9 +17,9 @@ #:bytecode-closure-template #:bytecode-closure-env) (:export #:compute-instance-function) (:export #:link-function #:link-variable #:link-environment) - (:export #:symbol-value #:call-with-progv #:progv + (:export #:boundp #:makunbound #:symbol-value #:call-with-progv #:progv #:fdefinition #:fmakunbound #:fboundp) - (:export #:disassemble #:disassemble-instruction)) + (:export #:disassemble #:display-instruction)) ;;;; Definition of the virtual machine, used by both the compiler and the VM. @@ -135,6 +135,7 @@ (dup 58) (fdesignator 59) (called-fdefinition 60 ((constant-arg 1)) ((constant-arg 2))) - (protect 61) + (protect 61 ((constant-arg 1)) ((constant-arg 2))) (cleanup 62) + (encell 63 (1) (2)) (long 255))) diff --git a/test/ansi/let.lisp b/test/ansi/let.lisp index 6ce7f57..9aa4e6b 100644 --- a/test/ansi/let.lisp +++ b/test/ansi/let.lisp @@ -171,3 +171,13 @@ (macrolet ((%m (z) z)) (let ((x (s:expand-in-current-env (%m 1)))) (+ x x x))) 3) + +;;; Apparently not in ANSI: Special bindings are in parallel + +(deftest let.parallel + (let ((x 1) (y 2)) + (declare (special x y)) + (let ((x (+ y 8)) (y (+ x 13))) + (declare (special x y)) + (values x y))) + 10 14) diff --git a/test/cooperation.lisp b/test/cooperation.lisp new file mode 100644 index 0000000..d97ed8c --- /dev/null +++ b/test/cooperation.lisp @@ -0,0 +1,30 @@ +(in-package #:cvm.test) + +;;;; Tests that the cross VM plays well with host code. + +(5am:def-suite cooperation :in cvm-cross) +(5am:in-suite cooperation) + +(5am:test return-through-unbind + (let ((rte (cvm.compile:run-time-environment m:*client* *environment*))) + (m:progv m:*client* rte '(x) '(:good) + ;; Return to a native block through a VM binding. + (flet ((outer (inner) + (block nil + (funcall inner (lambda () (return)))) + (m:symbol-value m:*client* rte 'x))) + (let ((inner (ceval '#'(lambda (f) + (let ((x :bad)) + (declare (special x)) + (funcall f)))))) + (5am:is (eql :good (outer inner))))) + ;; Return to a VM block through a native binding. + ;; This essentially tests M:PROGV's NLX behavior. + (flet ((inner (f) + (m:progv m:*client* rte '(x) '(:bad) (funcall f)))) + (5am:is (eql :good + (ceval `(progn + (block nil + (funcall ,#'inner + #'(lambda () (return)))) + (locally (declare (special x)) x))))))))) diff --git a/vm-cross.lisp b/vm-cross.lisp index 9ada639..57ebdec 100644 --- a/vm-cross.lisp +++ b/vm-cross.lisp @@ -236,18 +236,15 @@ (dest (catch-dynenv-dest de))) (unwind-to vm rtag dest (rest catch-de-stack)))))) -(defun instruction-trace (bytecode stack ip bp sp frame-size) +(defun instruction-trace (bytecode literals stack ip bp sp frame-size) (fresh-line *trace-output*) - (let ((frame-end (+ bp frame-size)) - ;; skip package prefixes on inst names. - (*package* (find-package "CVM.MACHINE"))) - (prin1 (list (m:disassemble-instruction bytecode ip) - bp - sp - (subseq stack bp frame-end) - ;; We take the max for partial frames. - (subseq stack frame-end (max sp frame-end))) - *trace-output*))) + (let ((*standard-output* *trace-output*)) + (cvm.machine:display-instruction bytecode literals ip)) + (let ((frame-end (+ bp frame-size))) + (format *trace-output* " ; bp ~d sp ~d locals ~s stack ~s~%" + bp sp (subseq stack bp frame-end) + ;; We take the max for partial frames. + (subseq stack frame-end (max sp frame-end))))) (defun vm (bytecode closure constants frame-size) (declare (type (simple-array (unsigned-byte 8) (*)) bytecode) @@ -270,6 +267,10 @@ #+sbcl (declare (sb-ext:muffle-conditions sb-ext:compiler-note)) (setf (svref stack index) object)) + (local (index) + (svref stack (+ bp index))) + ((setf local) (object index) + (setf (svref stack (+ bp index)) object)) (spush (object) (prog1 (setf (stack sp) object) (incf sp))) (spop () (stack (decf sp))) @@ -307,7 +308,7 @@ (setf (vm-stack-top vm) sp) (apply callee args))) (mv-call () (call (spop)))) - (declare (inline stack (setf stack) spush spop + (declare (inline stack (setf stack) local (setf local) spush spop code next-code constant closure call mv-call)) (prog ((end (length bytecode)) @@ -318,7 +319,7 @@ (when (>= ip end) (error "Invalid bytecode: Reached end")) (when trace - (instruction-trace bytecode stack ip bp sp frame-size)) + (instruction-trace bytecode constants stack ip bp sp frame-size)) ;; The catch is for NLX. Without NLX, a (go loop) at the ;; bottom skips back up to the loop without setting IP. ;; When something NLXs to this frame, we throw the new IP @@ -329,8 +330,7 @@ (setf ip (catch tag (case (code) - ((#.m:ref) (spush (stack (+ bp (next-code)))) - (incf ip)) + ((#.m:ref) (spush (local (next-code))) (incf ip)) ((#.m:const) (spush (constant (next-code))) (incf ip)) ((#.m:closure) (spush (closure (next-code))) (incf ip)) ((#.m:call) @@ -351,11 +351,11 @@ ;; Most recent push goes to the last local. (let ((nvars (next-code))) (loop repeat nvars - for bsp downfrom (+ bp (next-code) nvars -1) - do (setf (stack bsp) (spop)))) + for bsp downfrom (+ (next-code) nvars -1) + do (setf (local bsp) (spop)))) (incf ip)) ((#.m:set) - (setf (stack (+ bp (next-code))) (spop)) + (setf (local (next-code)) (spop)) (incf ip)) ((#.m:make-cell) (spush (make-cell (spop))) (incf ip)) ((#.m:cell-ref) (spush (cell-value (spop))) (incf ip)) @@ -380,7 +380,7 @@ (m:bytecode-function-environment-size template))))) (incf ip)) ((#.m:initialize-closure) - (let ((env (m:bytecode-closure-env (stack (+ bp (next-code)))))) + (let ((env (m:bytecode-closure-env (local (next-code))))) (declare (type simple-vector env)) (loop for i from (1- (length env)) downto 0 do (setf (aref env i) (spop)))) @@ -421,11 +421,11 @@ :min-nargs n :max-nargs n))) (incf ip)) ((#.m:jump-if-supplied-8) - (incf ip (if (typep (stack (+ bp (next-code))) 'unbound-marker) + (incf ip (if (typep (local (next-code)) 'unbound-marker) 2 (1- (next-code-signed))))) ((#.m:jump-if-supplied-16) - (incf ip (if (typep (stack (+ bp (next-code))) 'unbound-marker) + (incf ip (if (typep (local (next-code)) 'unbound-marker) 3 (1- (next-code-signed-16))))) ((#.m:bind-required-args) @@ -433,9 +433,9 @@ (let* ((args (vm-args vm)) (args-end (+ args (next-code)))) (do ((arg-index args (1+ arg-index)) - (frame-slot bp (1+ frame-slot))) + (frame-slot 0 (1+ frame-slot))) ((>= arg-index args-end)) - (setf (stack frame-slot) (stack arg-index)))) + (setf (local frame-slot) (stack arg-index)))) (incf ip)) ((#.m:bind-optional-args) (let* ((args (vm-args vm)) @@ -444,7 +444,7 @@ (optional-count (next-code)) (args-end (+ args (vm-arg-count vm))) (end (+ optional-start optional-count)) - (optional-frame-offset (+ bp required-count)) + (optional-frame-offset required-count) (optional-frame-end (+ optional-frame-offset optional-count))) (if (<= args-end end) ;; Could be coded as memcpy in C. @@ -455,17 +455,19 @@ ;; pattern?) (do ((frame-slot frame-slot (1+ frame-slot))) ((>= frame-slot optional-frame-end)) - (setf (stack frame-slot) (make-unbound-marker)))) - (setf (stack frame-slot) (stack arg-index))) + (setf (local frame-slot) (make-unbound-marker)))) + (setf (local frame-slot) (stack arg-index))) ;; Could also be coded as memcpy. (do ((arg-index optional-start (1+ arg-index)) (frame-slot optional-frame-offset (1+ frame-slot))) ((>= arg-index end)) - (setf (stack frame-slot) (stack arg-index)))) + (setf (local frame-slot) (stack arg-index)))) (incf ip))) ((#.m:listify-rest-args) - (spush (loop for index from (next-code) below (vm-arg-count vm) - collect (stack (+ (vm-args vm) index)))) + (let ((nfixed (next-code))) + (setf (local nfixed) + (loop for index from nfixed below (vm-arg-count vm) + collect (stack (+ (vm-args vm) index))))) (incf ip)) ((#.m:parse-key-args) (let* ((args (vm-args vm)) @@ -475,12 +477,12 @@ (key-count (logand key-count-info #x7f)) (key-literal-start (next-code)) (key-literal-end (+ key-literal-start key-count)) - (key-frame-start (+ bp (next-code))) + (key-frame-start (next-code)) (unknown-keys nil) (allow-other-keys-p nil)) ;; Initialize all key values to # (loop for index from key-frame-start below (+ key-frame-start key-count) - do (setf (stack index) (make-unbound-marker))) + do (setf (local index) (make-unbound-marker))) (when (> end more-start) (do ((arg-index (- end 1) (- arg-index 2))) ((< arg-index more-start) @@ -497,7 +499,7 @@ for offset of-type (unsigned-byte 16) from key-frame-start do (when (eq (constant key-index) key) - (setf (stack offset) (stack arg-index)) + (setf (local offset) (stack arg-index)) (return)) finally (unless (or allow-other-keys-p (eq key :allow-other-keys)) @@ -509,15 +511,15 @@ :unrecognized-keywords unknown-keys))) (incf ip)) ((#.m:save-sp) - (setf (stack (+ bp (next-code))) sp) + (setf (local (next-code)) sp) (incf ip)) ((#.m:restore-sp) - (setf sp (stack (+ bp (next-code)))) + (setf sp (local (next-code))) (incf ip)) ((#.m:entry) (let ((de (make-entry-dynenv tag))) (push de (vm-dynenv-stack vm)) - (setf (stack (+ bp (next-code))) de) + (setf (local (next-code)) de) (incf ip))) ((#.m:catch-8) (let* ((target (+ ip (next-code-signed))) @@ -622,7 +624,13 @@ desig))))) (incf ip)) ((#.m:protect) - (let* ((cleanup-thunk (spop)) + (let* ((template (constant (next-code))) + (envsize + (m:bytecode-function-environment-size template)) + (cleanup-thunk + (m:make-bytecode-closure + (vm-client vm) template + (coerce (gather envsize) 'simple-vector))) (de (make-protection-dynenv cleanup-thunk))) (push de (vm-dynenv-stack vm))) (incf ip)) @@ -635,6 +643,9 @@ (funcall (protection-dynenv-cleanup de)) (setf (vm-values vm) values)) (incf ip)) + ((#.m:encell) + (let ((index (next-code))) + (setf (local index) (make-cell (local index))))) ((#.m:long) (ecase (next-code) (#.m:const @@ -679,6 +690,10 @@ (defmethod (setf m:symbol-value) (new (client client) env symbol) (let ((cell (clostrum-sys:variable-cell client env symbol))) (setf (%symbol-value symbol cell) new))) +(defmethod m:boundp ((client client) env symbol) + (%boundp symbol (clostrum-sys:variable-cell client env symbol))) +(defmethod m:makunbound ((client client) env symbol) + (%makunbound symbol (clostrum-sys:variable-cell client env symbol))) (defmethod m:call-with-progv ((client client) env symbols values thunk) (%progv client env symbols values) diff --git a/vm-native.lisp b/vm-native.lisp index 266d81e..aec8e88 100644 --- a/vm-native.lisp +++ b/vm-native.lisp @@ -75,6 +75,16 @@ (defstruct (sbind-dynenv (:include dynenv) (:constructor make-sbind-dynenv ()))) +(defun instruction-trace (bytecode literals stack ip bp sp frame-size) + (fresh-line *trace-output*) + (let ((*standard-output* *trace-output*)) + (cvm.machine:display-instruction bytecode literals ip)) + (let ((frame-end (+ bp frame-size))) + (format *trace-output* " ; bp ~d sp ~d locals ~s stack ~s~%" + bp sp (subseq stack bp frame-end) + ;; We take the max for partial frames. + (subseq stack frame-end (max sp frame-end))))) + (defun vm (bytecode closure constants frame-size) (declare (type (simple-array (unsigned-byte 8) (*)) bytecode) (type (simple-array t (*)) closure constants) @@ -96,6 +106,10 @@ #+sbcl (declare (sb-ext:muffle-conditions sb-ext:compiler-note)) (setf (svref stack index) object)) + (local (index) + (svref stack (+ bp index))) + ((setf local) (object index) + (setf (svref stack (+ bp index)) object)) (spush (object) (prog1 (setf (stack sp) object) (incf sp))) (spop () (stack (decf sp))) @@ -140,19 +154,10 @@ with trace = *trace* until (eql ip end) when trace - do (fresh-line *trace-output*) - (let ((frame-end (+ bp frame-size)) - ; skip package prefixes on inst names. - (*package* (find-package "CVM.MACHINE"))) - (prin1 (list (m:disassemble-instruction bytecode ip) - bp - sp - (subseq stack bp frame-end) - ;; We take the max for partial frames. - (subseq stack frame-end (max sp frame-end))) - *trace-output*)) + do (instruction-trace bytecode constants stack + ip bp sp frame-size) do (case (code) - ((#.m:ref) (spush (stack (+ bp (next-code)))) (incf ip)) + ((#.m:ref) (spush (local (next-code))) (incf ip)) ((#.m:const) (spush (constant (next-code))) (incf ip)) ((#.m:closure) (spush (closure (next-code))) (incf ip)) ((#.m:call) @@ -173,11 +178,11 @@ ;; Most recent push goes to the last local. (let ((nvars (next-code))) (loop repeat nvars - for bsp downfrom (+ bp (next-code) nvars -1) - do (setf (stack bsp) (spop)))) + for bsp downfrom (+ (next-code) nvars -1) + do (setf (local bsp) (spop)))) (incf ip)) ((#.m:set) - (setf (stack (+ bp (next-code))) (spop)) + (setf (local (next-code)) (spop)) (incf ip)) ((#.m:make-cell) (spush (make-cell (spop))) (incf ip)) ((#.m:cell-ref) (spush (cell-value (spop))) (incf ip)) @@ -202,7 +207,7 @@ (m:bytecode-function-environment-size template))))) (incf ip)) ((#.m:initialize-closure) - (let ((env (m:bytecode-closure-env (stack (+ bp (next-code)))))) + (let ((env (m:bytecode-closure-env (local (next-code))))) (declare (type simple-vector env)) (loop for i from (1- (length env)) downto 0 do (setf (aref env i) (spop)))) @@ -243,11 +248,11 @@ :min-nargs n :max-nargs n))) (incf ip)) ((#.m:jump-if-supplied-8) - (incf ip (if (typep (stack (+ bp (next-code))) 'unbound-marker) + (incf ip (if (typep (local (next-code)) 'unbound-marker) 2 (1- (next-code-signed))))) ((#.m:jump-if-supplied-16) - (incf ip (if (typep (stack (+ bp (next-code))) 'unbound-marker) + (incf ip (if (typep (local (next-code)) 'unbound-marker) 3 (1- (next-code-signed-16))))) ((#.m:bind-required-args) @@ -255,9 +260,9 @@ (let* ((args (vm-args vm)) (args-end (+ args (next-code)))) (do ((arg-index args (1+ arg-index)) - (frame-slot bp (1+ frame-slot))) + (frame-slot 0 (1+ frame-slot))) ((>= arg-index args-end)) - (setf (stack frame-slot) (stack arg-index)))) + (setf (local frame-slot) (stack arg-index)))) (incf ip)) ((#.m:bind-optional-args) (let* ((args (vm-args vm)) @@ -266,7 +271,7 @@ (optional-count (next-code)) (args-end (+ args (vm-arg-count vm))) (end (+ optional-start optional-count)) - (optional-frame-offset (+ bp required-count)) + (optional-frame-offset required-count) (optional-frame-end (+ optional-frame-offset optional-count))) (if (<= args-end end) ;; Could be coded as memcpy in C. @@ -277,17 +282,19 @@ ;; pattern?) (do ((frame-slot frame-slot (1+ frame-slot))) ((>= frame-slot optional-frame-end)) - (setf (stack frame-slot) (make-unbound-marker)))) - (setf (stack frame-slot) (stack arg-index))) + (setf (local frame-slot) (make-unbound-marker)))) + (setf (local frame-slot) (stack arg-index))) ;; Could also be coded as memcpy. (do ((arg-index optional-start (1+ arg-index)) (frame-slot optional-frame-offset (1+ frame-slot))) ((>= arg-index end)) - (setf (stack frame-slot) (stack arg-index)))) + (setf (local frame-slot) (stack arg-index)))) (incf ip))) ((#.m:listify-rest-args) - (spush (loop for index from (next-code) below (vm-arg-count vm) - collect (stack (+ (vm-args vm) index)))) + (let ((nfixed (next-code))) + (setf (local nfixed) + (loop for index from nfixed below (vm-arg-count vm) + collect (stack (+ (vm-args vm) index))))) (incf ip)) ((#.m:parse-key-args) (let* ((args (vm-args vm)) @@ -297,12 +304,12 @@ (key-count (logand key-count-info #x7f)) (key-literal-start (next-code)) (key-literal-end (+ key-literal-start key-count)) - (key-frame-start (+ bp (next-code))) + (key-frame-start (next-code)) (unknown-keys nil) (allow-other-keys-p nil)) ;; Initialize all key values to # (loop for index from key-frame-start below (+ key-frame-start key-count) - do (setf (stack index) (make-unbound-marker))) + do (setf (local index) (make-unbound-marker))) (when (> end more-start) (do ((arg-index (- end 1) (- arg-index 2))) ((< arg-index more-start) @@ -319,7 +326,7 @@ for offset of-type (unsigned-byte 16) from key-frame-start do (when (eq (constant key-index) key) - (setf (stack offset) (stack arg-index)) + (setf (local offset) (stack arg-index)) (return)) finally (unless (or allow-other-keys-p ;; aok is always allowed @@ -332,14 +339,14 @@ :unrecognized-keywords unknown-keys))) (incf ip)) ((#.m:save-sp) - (setf (stack (+ bp (next-code))) sp) + (setf (local (next-code)) sp) (incf ip)) ((#.m:restore-sp) - (setf sp (stack (+ bp (next-code)))) + (setf sp (local (next-code))) (incf ip)) ((#.m:entry) (tagbody - (setf (stack (+ bp (next-code))) + (setf (local (next-code)) (make-entry-dynenv (let ((old-sp sp) (old-bp bp)) @@ -465,7 +472,15 @@ (symbol (fdefinition fdesig))))) (incf ip)) ((#.m:protect) - (let ((cleanup-thunk (spop))) + (let* ((template (constant (next-code))) + (envsize + (m:bytecode-function-environment-size template)) + (cleanup-thunk + (if (zerop envsize) + template + (m:make-bytecode-closure + m:*client* template + (coerce (gather envsize) 'simple-vector))))) (declare (type function cleanup-thunk)) (incf ip) (unwind-protect @@ -476,6 +491,9 @@ ((#.m:cleanup) (incf ip) (return)) + ((#.m:encell) + (let ((index (next-code))) + (setf (local index) (make-cell (local index))))) ((#.m:long) (ecase (next-code) (#.m:const @@ -502,6 +520,12 @@ (defmethod (setf m:symbol-value) (new (client trucler-native:client) env symbol) (declare (ignore env)) (setf (symbol-value symbol) new)) +(defmethod m:boundp ((client trucler-native:client) env symbol) + (declare (ignore env)) + (boundp symbol)) +(defmethod m:makunbound ((client trucler-native:client) env symbol) + (declare (ignore env)) + (makunbound symbol)) (defmethod m:call-with-progv ((client trucler-native:client) env symbols values thunk)