Merge pull request #6 from clasp-developers/clasp-catchup

Brings cvm up to the 0.12 format I already hacked up in Clasp, and then a little farther to pending 0.13 since I realized there was a problem with the fdesignator instruction.

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))

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)))))
 

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.

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