diff --git a/FASL.md b/FASL.md index fc2114e..d1fe79d 100644 --- a/FASL.md +++ b/FASL.md @@ -20,7 +20,11 @@ After the last instruction is executed, the FASL has been fully loaded. Any rema # Changelog -## 0.14 (pending) +## 0.15 (pending) + +* `listify-rest-args` pushes to the stack again. `bind-optional-args` and `parse-key-args` do as well. (This makes compilation a little easier and cleaner.) + +## 0.14 * `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. diff --git a/MACHINE.md b/MACHINE.md index 49e0b30..8cd2eeb 100644 --- a/MACHINE.md +++ b/MACHINE.md @@ -235,28 +235,28 @@ Set the first `nreq` locals to be the first `nreq` arguments. ### bind-optional-args #x10 (nreq misc) (nopt misc) -Set the `nopt` locals beginning at `nreq` to be the arguments beginning at `nreq`. If there are not enough arguments, the remaining locals are set to an "unsupplied" value with no meaning except to `jump-if-supplied`. +Push the `nopt` arguments beginning at `nreq` to the stack. If there are not enough arguments, an "unsupplied" value with no meaning except to `jump-if-supplied` is pushed instead. ```lisp -(loop for i from nreq - do (setf (aref LOCALS i) - (if (< (length ARGUMENTS) i) +(loop for i from nreq below (+ nreq nopt) + do (push (if (< (length ARGUMENTS) i) (aref ARGUMENTS i) - +UNSUPPLIED+))) + +UNSUPPLIED+) + STACK)) ``` ### listify-rest-args #x11 (nfixed misc) -Construct a list out of all the arguments beginning at `nfixed`, and assign it to the `nfixed`th local. +Construct a list out of all the arguments beginning at `nfixed`, and push it to the stack. ```lisp -(setf (aref LOCALS nfixed) (nthcdr nfixed ARGUMENTS)) +(push (nthcdr nfixed ARGUMENTS) STACK) ``` -## parse-key-args #x13 (nfixed misc) (key-count-info misc) (keys keys) (base misc) +## parse-key-args #x13 (nfixed misc) (key-count-info misc) (keys keys) -The low 7 (or 15, for `long parse-key-args`) bits of `key-count-info` are a count of keywords, call it `nkeys`. There are `nkeys` literals beginning at `keys` that are keys. Interpret the arguments beginning with `nfixed` as a keyword plist, and assign the locals beginning at `base` to the corresponding keywords. If any of these locals do not have an entry in the arguments plist, they are set to an "unsupplied" value with no meaning except to `jump-if-supplied`. +The low 7 (or 15, for `long parse-key-args`) bits of `key-count-info` are a count of keywords, call it `nkeys`. There are `nkeys` literals beginning at `keys` that are keys. Interpret the arguments beginning with `nfixed` as a keyword plist, and push them to the stack in the order of the corresponding keywords. If any of these do not have an entry in the arguments plist, an "unsupplied" value with no meaning except to `jump-if-supplied` is pushed instead. If the length of the argument plist is odd, signal a program error. If the high bit of `key-count-info` is unset, and there are keywords in the argument plist that are not part of `keys`, signal a program error. @@ -267,7 +267,7 @@ If the length of the argument plist is odd, signal a program error. If the high (keywords (subseq LITERALS keys (+ keys nkeys)))) (unless (evenp (length plist)) (error 'program-error ...)) (loop for i from base for kw in keywords - do (setf (aref LOCALS i) (getf plist kw +UNSUPPLIED+))) + do (push (getf plist kw +UNSUPPLIED+) STACK)) (unless (or aokp (all-known-keywords-p plist keywords)) (error 'program-error ...))) ``` @@ -288,12 +288,13 @@ Pop a value from the stack. If it is not `cl:nil`, jump to the label. (when (pop STACK) (incf IP label)) ``` -### jump-if-supplied-{8,16} #x1a #x1b (base misc) (dest label) +### jump-if-supplied-{8,16} #x1a #x1b (dest label) -If the `base`th local is anything but the distinguished unsupplied value, jump to the label. +Pop a value. If it is anything but the distinguished unsupplied value, push it back, then jump to the label. ```lisp -(unless (eq (pop STACK) +UNSUPPLIED+) (incf IP label)) +(let ((value (pop STACK))) + (unless (eq value +UNSUPPLIED+) (push value STACK) (incf IP label))) ``` ### check-arg-count-<= #x1c (nargs misc) diff --git a/compile-file/preliminaries.lisp b/compile-file/preliminaries.lisp index 4496e9a..3ea6e51 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* 14) +(defparameter *minor-version* 15) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; diff --git a/compile/compile.lisp b/compile/compile.lisp index 286ccef..7b048d2 100644 --- a/compile/compile.lisp +++ b/compile/compile.lisp @@ -342,60 +342,42 @@ (defun emit-catch (context label) (emit-control+label context m:catch-8 m:catch-16 nil label)) -(defun emit-jump-if-supplied (context index label) +(defun emit-jump-if-supplied (context label) (flet ((emitter (fixup position code) (let* ((size (fixup-size fixup)) + (addrlongp (ecase size (2 nil) (3 t))) (offset (unsigned (fixup-delta fixup) - (* 8 (if (evenp size) 2 1))))) - (ecase size - (3 - (setf (aref code position) m:jump-if-supplied-8 - (aref code (1+ position)) index - position (+ 2 position))) - (4 - (setf (aref code position) m:jump-if-supplied-16 - (aref code (1+ position)) index - position (+ 2 position))) - (5 - (setf (aref code position) m:long - (aref code (+ 1 position)) m:jump-if-supplied-8 - (aref code (+ 2 position)) (ldb (byte 8 0) index) - (aref code (+ 3 position)) (ldb (byte 8 8) index) - position (+ 4 position))) - (6 - (setf (aref code position) m:long - (aref code (+ 1 position)) m:jump-if-supplied-16 - (aref code (+ 2 position)) (ldb (byte 8 0) index) - (aref code (+ 3 position)) (ldb (byte 8 8) index) - position (+ 4 position)))) - (write-le-unsigned code offset (if (evenp size) 2 1) position))) + (* 8 (if addrlongp 2 1))))) + (setf (aref code position) + (if addrlongp m:jump-if-supplied-16 m:jump-if-supplied-8)) + (incf position) + (write-le-unsigned code offset (if addrlongp 2 1) position))) (resizer (fixup) (typecase (fixup-delta fixup) - ((signed-byte 8) (if (< index #.(ash 1 8)) 3 5)) - ((signed-byte 16) (if (< index #.(ash 1 8)) 4 6)) + ((signed-byte 8) 2) + ((signed-byte 16) 3) (t (error "???? PC offset too big ????"))))) - (emit-fixup context (make-fixup label 3 #'emitter #'resizer)))) + (emit-fixup context (make-fixup label 2 #'emitter #'resizer)))) (defun emit-const (context index) (assemble context m:const index)) (defun emit-fdefinition (context index) (assemble context m:fdefinition index)) (defun emit-parse-key-args (context max-count key-count key-literal-start aok-p) ;; Because of the key-count encoding, we have to special case long a bit. - (let ((frame-end (context-frame-end context)) - (lit (if (zerop key-count) ; don't need a literal then + (let ((lit (if (zerop key-count) ; don't need a literal then 0 key-literal-start))) (cond ((and (< max-count #.(ash 1 8)) (< key-count #.(ash 1 7)) - (< lit #.(ash 1 8)) (< frame-end #.(ash 1 8))) + (< lit #.(ash 1 8))) (assemble context m:parse-key-args max-count (if aok-p (logior #.(ash 1 7) key-count) key-count) - lit frame-end)) + lit)) (t (assemble context m:parse-key-args max-count (if aok-p (logior #.(ash 1 15) key-count) key-count) - lit frame-end))))) + lit))))) (defun emit-bind (context count offset) (cond ((= count 1) (assemble context m:set offset)) @@ -1601,6 +1583,36 @@ (declare (ignore type)) (compile-form form env context))) +;;; Generate code to default an &optional or &key variable. +(defun gen-1-default (defaultf -p env context) + (let ((vcontext (new-context context :receiving 1)) + (slabel (make-label)) + (alabel (when -p (make-label)))) + (emit-jump-if-supplied vcontext slabel) + (compile-form defaultf env vcontext) + (when -p + (assemble vcontext m:nil) + (emit-jump vcontext alabel)) + (emit-label vcontext slabel) + (when -p + (compile-literal 't env vcontext) + (emit-label vcontext alabel)))) + +;;; Generate code to bind one variable. +;;; Returns (values new-env new-context) +(defun gen-1-bind (var specialp env context decls) + (cond (specialp + (emit-special-bind context var) + (values (add-specials (list var) env) + (new-context context :dynenv '(:special)))) + (t + (setf (values env context) + (bind-vars (list var) env context decls)) + (let ((info (var-info var env))) + (maybe-emit-make-cell info context) + (assemble context m:set (frame-offset info))) + (values env context)))) + ;;; Deal with lambda lists. Compile the body with the lambda vars bound. ;;; Optional/key handling is done in two steps: ;;; @@ -1620,15 +1632,9 @@ (key-count (length keys)) (more-p (or rest key-p)) new-env ; will be the body environment - default-env ; environment for compiling default forms (context context) (specials (extract-specials decls)) (special-binding-count 0) - ;; An alist from optional and key variables to their local indices. - ;; This is needed so that we can properly mark any that are special as - ;; such while leaving them temporarily "lexically" bound during - ;; argument parsing. - (opt-key-indices nil) ;; A list of lexical infos to check for ignoredness. (igninfos nil)) (setf (values new-env context) (bind-vars required env context decls)) @@ -1657,40 +1663,39 @@ (push info igninfos) (maybe-emit-encell info 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). - (setq default-env new-env) (unless (zerop optional-count) - ;; Generate code to bind the provided optional args; unprovided args will - ;; be initialized with the unbound marker. (assemble context m:bind-optional-args min-count optional-count) - (let ((optvars (mapcar #'first optionals))) - ;; Mark the location of each optional. Note that we do this even if - ;; the variable will be specially bound. - (setf (values new-env context) - (bind-vars optvars new-env context decls)) - ;; Add everything to opt-key-indices. - (dolist (var optvars) - (let ((info (var-info var new-env))) - (push info igninfos) - (push (cons var (frame-offset info)) opt-key-indices))))) + (loop for (opt default -p) in optionals + for ospecialp = (or (member opt specials) + (globally-special-p opt env)) + for pspecialp = (and -p + (or (member -p specials) + (globally-special-p -p env))) + do (gen-1-default default -p new-env context) + ;; Values are on the stack. Do the binding(s). + (when -p + (setf (values new-env context) + (gen-1-bind -p pspecialp new-env context decls))) + (setf (values new-env context) + (gen-1-bind opt ospecialp new-env context decls)) + ;; Bookkeeping + (if ospecialp + (incf special-binding-count) + (push (var-info opt new-env) igninfos)) + (cond ((not -p)) + (pspecialp (incf special-binding-count)) + (t (push (var-info -p new-env) igninfos))))) (when rest (assemble context m:listify-rest-args max-count) - (setf (values new-env context) - (bind-vars (list rest) new-env context decls)) - (cond ((or (member rest specials) - (globally-special-p rest env)) - (assemble context m:ref (frame-offset (var-info rest new-env))) - (emit-special-bind context rest) - (incf special-binding-count 1) - (setq new-env (add-specials (list rest) new-env))) - (t - (let ((info (var-info rest new-env))) - (push info igninfos) - (maybe-emit-encell info context))))) + (let ((rspecialp (or (member rest specials) + (globally-special-p rest env)))) + (setf (values new-env context) + (gen-1-bind rest rspecialp new-env context decls)) + (if rspecialp + (incf special-binding-count) + (push (var-info rest new-env) igninfos)))) (when key-p - ;; Generate code to parse the key args. As with optionals, we don't do - ;; defaulting yet. + ;; Generate code to parse the key args. (let ((key-literal-start nil)) ;; Generate fresh indices for each keyword, to ensure they're ;; contiguous. @@ -1699,100 +1704,27 @@ (unless key-literal-start (setf key-literal-start i)))) (emit-parse-key-args context max-count key-count key-literal-start aok-p)) - (let ((keyvars (mapcar #'cadar keys))) - (setf (values new-env context) - (bind-vars keyvars new-env context decls)) - (dolist (var keyvars) - (let ((info (var-info var new-env))) - (push info igninfos) - (push (cons var (frame-offset info)) opt-key-indices))))) - ;; Generate defaulting code for optional args, and special-bind them - ;; if necessary. - (unless (zerop optional-count) - (do ((optionals optionals (rest optionals)) - (optional-label (make-label) next-optional-label) - (next-optional-label (make-label) (make-label))) - ((endp optionals) - (emit-label context optional-label)) - (emit-label context optional-label) - (destructuring-bind (optional-var defaulting-form supplied-var) - (first optionals) - (let ((optional-special-p (or (member optional-var specials) - (globally-special-p optional-var env))) - (index (cdr (assoc optional-var opt-key-indices))) - (supplied-special-p - (and supplied-var - (or (member supplied-var specials) - (globally-special-p supplied-var env))))) - (setf (values new-env context) - (compile-optional/key-item optional-var defaulting-form - index - supplied-var next-optional-label - optional-special-p supplied-special-p - context new-env - default-env decls)) - ;; set the default env for later bindings. - (let* ((ovar (cons optional-var - (var-info optional-var new-env))) - (svar (when supplied-var - (cons supplied-var - (var-info supplied-var new-env)))) - (newvars - (if svar (list svar ovar) (list ovar)))) - (when supplied-var - (push (cdr svar) igninfos)) - (setf default-env - (make-lexical-environment - default-env - :vars (append newvars (vars default-env))))) - (when optional-special-p (incf special-binding-count)) - (when supplied-special-p (incf special-binding-count)))))) - ;; Generate defaulting code for key args, and special-bind them if necessary. - (when key-p - ;; Bind the rest parameter in the default env, if existent. - (when rest - (let ((rvar (cons rest (var-info rest new-env))) - (old (vars default-env))) - (setf default-env - (make-lexical-environment - default-env :vars (cons rvar old))))) - (do ((keys keys (rest keys)) - (key-label (make-label) next-key-label) - (next-key-label (make-label) (make-label))) - ((endp keys) (emit-label context key-label)) - (emit-label context key-label) - (destructuring-bind ((key-name key-var) defaulting-form supplied-var) - (first keys) - (declare (ignore key-name)) - (let ((index (cdr (assoc key-var opt-key-indices))) - (key-special-p (or (member key-var specials) - (globally-special-p key-var env))) - (supplied-special-p - (and supplied-var - (or (member supplied-var specials) - (globally-special-p supplied-var env))))) - (setf (values new-env context) - (compile-optional/key-item key-var defaulting-form index - supplied-var next-key-label - key-special-p supplied-special-p - context new-env - default-env decls)) - ;; set the default env for later bindings. - (let* ((ovar (cons key-var - (var-info key-var new-env))) - (svar (when supplied-var - (cons supplied-var - (var-info supplied-var new-env)))) - (newvars - (if svar (list svar ovar) (list ovar)))) - (when supplied-var - (push (cdr svar) igninfos)) - (setf default-env - (make-lexical-environment - default-env - :vars (append newvars (vars default-env))))) - (when key-special-p (incf special-binding-count)) - (when supplied-special-p (incf special-binding-count)))))) + ;; Do defaulting and bind the key args. + (loop for ((key var) default -p) in keys + for vspecialp = (or (member var specials) + (globally-special-p var env)) + for pspecialp = (and -p + (or (member -p specials) + (globally-special-p -p env))) + do (gen-1-default default -p new-env context) + ;; Values are on the stack. Do the binding(s). + (when -p + (setf (values new-env context) + (gen-1-bind -p pspecialp new-env context decls))) + (setf (values new-env context) + (gen-1-bind var vspecialp new-env context decls)) + ;; Bookkeeping + (if vspecialp + (incf special-binding-count) + (push (var-info var new-env) igninfos)) + (cond ((not -p)) + (pspecialp (incf special-binding-count)) + (t (push (var-info -p new-env) igninfos))))) ;; Generate aux and the body as a let*. ;; We repeat the special declarations so that let* will know the auxs ;; are special, and so that any free special declarations are processed. @@ -1804,60 +1736,6 @@ (emit-unbind context special-binding-count) (warn-ignorance igninfos (context-source context))))) -;;; Compile an optional/key item and return the resulting environment -;;; and context. -(defun compile-optional/key-item (var defaulting-form var-index supplied-var next-label - var-specialp supplied-specialp context env default-env decls) - (flet ((default (suppliedp specialp var info) - (cond (suppliedp - (cond (specialp - (assemble context m:ref var-index) - (emit-special-bind context var)) - (t - (maybe-emit-encell info context)))) - (t - ;; We compile in default-env but also context. - ;; The context already has space allocated for all - ;; the later lexical parameters, which have already - ;; been bound. Thus, we ensure that no bindings - ;; in the default form clobber later parameters. - (compile-form defaulting-form default-env - (new-context context :receiving 1)) - (cond (specialp - (emit-special-bind context var)) - (t - (maybe-emit-make-cell info context) - (assemble context m:set var-index)))))) - (supply (suppliedp specialp var info) - (if suppliedp - (compile-literal t env (new-context context :receiving 1)) - (assemble context m:nil)) - (cond (specialp - (emit-special-bind context var)) - (t - (maybe-emit-make-cell info context) - (assemble context m:set (frame-offset info)))))) - (let ((supplied-label (make-label)) - (var-info (var-info var env))) - (when supplied-var - (setf (values env context) - (bind-vars (list supplied-var) env context decls))) - (let ((supplied-info (var-info supplied-var env))) - (emit-jump-if-supplied context var-index supplied-label) - (default nil var-specialp var var-info) - (when supplied-var - (supply nil supplied-specialp supplied-var supplied-info)) - (emit-jump context next-label) - (emit-label context supplied-label) - (default t var-specialp var var-info) - (when supplied-var - (supply t supplied-specialp supplied-var supplied-info)) - (when var-specialp - (setq env (add-specials (list var) env))) - (when supplied-specialp - (setq env (add-specials (list supplied-var) env))) - (values env context))))) - ;;; Given a lambda list, compute a suitable name for an otherwise ;;; anonymous function. The name will be (lambda lambda-list), but with ;;; extraneous parts of the lambda list removed (default parameters, etc.) diff --git a/loadltv.lisp b/loadltv.lisp index 173ecde..64523c3 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 14)) -(defparameter *max-version* '(0 14)) +(defparameter *min-version* '(0 15)) +(defparameter *max-version* '(0 15)) (defun loadable-version-p (major minor) (and diff --git a/machine.lisp b/machine.lisp index 9a59629..7606ca6 100644 --- a/machine.lisp +++ b/machine.lisp @@ -102,15 +102,15 @@ (bind-optional-args 16 (1 1) (2 2)) (listify-rest-args 17 (1) (2)) (vaslistify-rest-args 18 (1)) - (parse-key-args 19 (1 1 (keys-arg 1) 1) (2 2 (keys-arg 2) 2)) + (parse-key-args 19 (1 1 (keys-arg 1)) (2 2 (keys-arg 2))) (jump-8 20 ((label-arg 1))) (jump-16 21 ((label-arg 2))) (jump-24 22 ((label-arg 3))) (jump-if-8 23 ((label-arg 1))) (jump-if-16 24 ((label-arg 2))) (jump-if-24 25 ((label-arg 3))) - (jump-if-supplied-8 26 (1 (label-arg 1)) (2 (label-arg 1))) - (jump-if-supplied-16 27 (1 (label-arg 2)) (2 (label-arg 2))) + (jump-if-supplied-8 26 ((label-arg 1)) ((label-arg 1))) + (jump-if-supplied-16 27 ((label-arg 2)) ((label-arg 2))) (check-arg-count-<= 28 (1) (2)) (check-arg-count->= 29 (1) (2)) (check-arg-count-= 30 (1) (2)) diff --git a/vm-cross.lisp b/vm-cross.lisp index d4f9c9d..5354e64 100644 --- a/vm-cross.lisp +++ b/vm-cross.lisp @@ -435,33 +435,39 @@ (vm:check-arg-count-= (vm-arg-count vm) (next-code)) (incf ip)) ((#.m:jump-if-supplied-8) - (incf ip (if (typep (local (next-code)) 'vm:unbound-marker) - 2 - (1- (next-code-signed))))) + (let ((arg (spop))) + (incf ip + (cond ((typep arg 'vm:unbound-marker) 2) + (t (spush arg) (next-code-signed)))))) ((#.m:jump-if-supplied-16) - (incf ip (if (typep (local (next-code)) 'vm:unbound-marker) - 3 - (1- (next-code-signed-16))))) + (let ((arg (spop))) + (incf ip + (cond ((typep arg 'vm:unbound-marker) 3) + (t (spush arg) (next-code-signed-16)))))) ((#.m:bind-required-args) (vm:bind-required-args (next-code) stack bp (vm-args vm)) (incf ip)) ((#.m:bind-optional-args) - (vm:bind-optional-args (next-code) (next-code) - stack bp (vm-args vm) (vm-arg-count vm)) + (setf sp (vm:bind-optional-args (next-code) (next-code) + stack sp + (vm-args vm) + (vm-arg-count vm))) (incf ip)) ((#.m:listify-rest-args) - (vm:listify-rest-args - (next-code) stack bp (vm-args vm) (vm-arg-count vm)) + (spush + (vm:listify-rest-args + (next-code) stack (vm-args vm) (vm-arg-count vm))) (incf ip)) ((#.m:parse-key-args) (let ((nfixed (next-code)) (key-count-info (next-code)) - (key-literal-start (next-code)) - (key-frame-start (next-code))) - (vm:parse-key-args - nfixed - (logand key-count-info #x7f) (logbitp 7 key-count-info) - key-literal-start key-frame-start - stack bp (vm-arg-count vm) (vm-args vm) constants)) + (key-literal-start (next-code))) + (setf sp + (vm:parse-key-args + nfixed + (logand key-count-info #x7f) + (logbitp 7 key-count-info) + key-literal-start stack sp + (vm-arg-count vm) (vm-args vm) constants))) (incf ip)) ((#.m:save-sp) (setf (local (next-code)) sp) @@ -620,24 +626,25 @@ stack bp (vm-args vm)) (incf ip)) (#.m:bind-optional-args - (vm:bind-optional-args - (next-long) (next-long) - stack bp (vm-args vm) (vm-arg-count vm)) + (setf sp (vm:bind-optional-args + (next-long) (next-long) + stack sp (vm-args vm) (vm-arg-count vm))) (incf ip)) (#.m:listify-rest-args - (vm:listify-rest-args - (next-long) stack bp (vm-args vm) (vm-arg-count vm)) + (spush + (vm:listify-rest-args + (next-long) stack (vm-args vm) (vm-arg-count vm))) (incf ip)) (#.m:parse-key-args (let ((nfixed (next-long)) (key-count-info (next-long)) - (key-literal-start (next-long)) - (key-frame-start (next-long))) - (vm:parse-key-args - nfixed - (logand key-count-info #x7fff) - (logbitp 15 key-count-info) - key-literal-start key-frame-start - stack bp (vm-arg-count vm) (vm-args vm) constants)) + (key-literal-start (next-long))) + (setf sp + (vm:parse-key-args + nfixed + (logand key-count-info #x7fff) + (logbitp 15 key-count-info) + key-literal-start stack sp + (vm-arg-count vm) (vm-args vm) constants))) (incf ip)) (#.m:check-arg-count-<= (vm:check-arg-count-<= (vm-arg-count vm) (next-long)) @@ -648,14 +655,6 @@ (#.m:check-arg-count-= (vm:check-arg-count-= (vm-arg-count vm) (next-long)) (incf ip)) - (#.m:jump-if-supplied-8 - (incf ip (if (typep (local (next-long)) 'vm:unbound-marker) - 2 - (- (next-code-signed) 3)))) - (#.m:jump-if-supplied-16 - (incf ip (if (typep (local (next-long)) 'vm:unbound-marker) - 3 - (- (next-code-signed-16) 3)))) (otherwise (error "Unknown long opcode #x~x" (code))))) (otherwise diff --git a/vm-native.lisp b/vm-native.lisp index 4afacc0..54e331e 100644 --- a/vm-native.lisp +++ b/vm-native.lisp @@ -78,7 +78,7 @@ (fresh-line *trace-output*) (let ((*standard-output* *trace-output*)) (maclina.machine:display-instruction bytecode literals ip)) - #+(or) + ;;#+(or) (let ((frame-end (+ bp frame-size))) (format *trace-output* " ; bp ~d sp ~d locals ~s stack ~s~%" bp sp (subseq stack bp frame-end) @@ -239,33 +239,37 @@ (vm:check-arg-count-= (vm-arg-count vm) (next-code)) (incf ip)) ((#.m:jump-if-supplied-8) - (incf ip (if (typep (local (next-code)) 'vm:unbound-marker) - 2 - (1- (next-code-signed))))) + (let ((arg (spop))) + (incf ip (cond ((typep arg 'vm:unbound-marker) 2) + (t (spush arg) (next-code-signed)))))) ((#.m:jump-if-supplied-16) - (incf ip (if (typep (local (next-code)) 'vm:unbound-marker) - 3 - (1- (next-code-signed-16))))) + (let ((arg (spop))) + (incf ip (cond ((typep arg 'vm:unbound-marker) 3) + (t (spush arg) (next-code-signed-16)))))) ((#.m:bind-required-args) (vm:bind-required-args (next-code) stack bp (vm-args vm)) (incf ip)) ((#.m:bind-optional-args) - (vm:bind-optional-args (next-code) (next-code) - stack bp (vm-args vm) (vm-arg-count vm)) + (setf sp + (vm:bind-optional-args (next-code) (next-code) + stack sp (vm-args vm) + (vm-arg-count vm))) (incf ip)) ((#.m:listify-rest-args) - (vm:listify-rest-args - (next-code) stack bp (vm-args vm) (vm-arg-count vm)) + (spush + (vm:listify-rest-args + (next-code) stack (vm-args vm) (vm-arg-count vm))) (incf ip)) ((#.m:parse-key-args) (let ((nfixed (next-code)) (key-count-info (next-code)) - (key-literal-start (next-code)) - (key-frame-start (next-code))) - (vm:parse-key-args - nfixed - (logand key-count-info #x7f) (logbitp 7 key-count-info) - key-literal-start key-frame-start - stack bp (vm-arg-count vm) (vm-args vm) constants)) + (key-literal-start (next-code))) + (setf sp + (vm:parse-key-args + nfixed + (logand key-count-info #x7f) + (logbitp 7 key-count-info) + key-literal-start stack sp + (vm-arg-count vm) (vm-args vm) constants))) (incf ip)) ((#.m:save-sp) (setf (local (next-code)) sp) @@ -443,24 +447,25 @@ stack bp (vm-args vm)) (incf ip)) (#.m:bind-optional-args - (vm:bind-optional-args - (next-long) (next-long) - stack bp (vm-args vm) (vm-arg-count vm)) + (setf sp + (vm:bind-optional-args + (next-long) (next-long) + stack sp (vm-args vm) (vm-arg-count vm))) (incf ip)) (#.m:listify-rest-args - (vm:listify-rest-args - (next-long) stack bp (vm-args vm) (vm-arg-count vm)) + (spush + (vm:listify-rest-args + (next-long) stack (vm-args vm) (vm-arg-count vm))) (incf ip)) (#.m:parse-key-args (let ((nfixed (next-long)) (key-count-info (next-long)) - (key-literal-start (next-long)) - (key-frame-start (next-long))) - (vm:parse-key-args - nfixed - (logand key-count-info #x7fff) - (logbitp 15 key-count-info) - key-literal-start key-frame-start - stack bp (vm-arg-count vm) (vm-args vm) constants)) + (key-literal-start (next-long))) + (setf sp (vm:parse-key-args + nfixed + (logand key-count-info #x7fff) + (logbitp 15 key-count-info) + key-literal-start stack sp + (vm-arg-count vm) (vm-args vm) constants))) (incf ip)) (#.m:check-arg-count-<= (vm:check-arg-count-<= (vm-arg-count vm) (next-long)) @@ -471,14 +476,6 @@ (#.m:check-arg-count-= (vm:check-arg-count-= (vm-arg-count vm) (next-long)) (incf ip)) - (#.m:jump-if-supplied-8 - (incf ip (if (typep (local (next-long)) 'vm:unbound-marker) - 2 - (- (next-code-signed) 3)))) - (#.m:jump-if-supplied-16 - (incf ip (if (typep (local (next-long)) 'vm:unbound-marker) - 3 - (- (next-code-signed-16) 3)))) (otherwise (error "Unknown long opcode #x~x" (code))))) (otherwise diff --git a/vm-shared.lisp b/vm-shared.lisp index 99eb68f..d39e913 100644 --- a/vm-shared.lisp +++ b/vm-shared.lisp @@ -9,6 +9,7 @@ (in-package #:maclina.vm-shared) (defstruct (unbound-marker (:constructor make-unbound-marker ()))) +(defvar *unbound* (make-unbound-marker)) (declaim (inline stack (setf stack))) (defun stack (stack index) @@ -58,74 +59,70 @@ ((>= arg-index args-end)) (setf (local stack bp frame-slot) (stack stack arg-index))))) +;;; super overkill, but might as well get it right just in case +;;; this is like C's x++ +(defmacro dincf (place &optional (delta 1) &environment env) + (multiple-value-bind (vars vals stores write read) + (get-setf-expansion place env) + (let ((temp (gensym "TEMP"))) + `(let* (,@(mapcar #'list vars vals) + (,temp ,read) + (,(first stores) (+ ,temp ,delta))) + ,write + ,temp)))) + +(defmacro spush (obj stack sp) + `(setf (svref ,stack (dincf ,sp)) ,obj)) + (declaim (inline bind-optional-args)) -(defun bind-optional-args (required-count optional-count stack bp argsi nargs) - (let* ((optional-start (+ argsi required-count)) - (args-end (+ argsi nargs)) - (end (+ optional-start optional-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. - (do ((arg-index optional-start (1+ arg-index)) - (frame-slot optional-frame-offset (1+ frame-slot))) - ((>= arg-index args-end) - ;; memcpy or similar. (blit bit - ;; pattern?) - (do ((frame-slot frame-slot (1+ frame-slot))) - ((>= frame-slot optional-frame-end)) - (setf (local stack bp frame-slot) (make-unbound-marker)))) - (setf (local stack bp frame-slot) (stack 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 (local stack bp frame-slot) (stack stack arg-index)))))) +(defun bind-optional-args (required-count optional-count stack sp argsi nargs) + (let ((nfixed (+ required-count optional-count))) + (loop for i from nfixed above nargs + do (spush *unbound* stack sp)) + (loop for i from (1- (min nfixed nargs)) downto required-count + do (spush (stack stack (+ argsi i)) stack sp))) + sp) (declaim (inline parse-key-args)) -(defun listify-rest-args (nfixed stack bp argsi nargs) - (setf (local stack bp nfixed) - (loop for index from nfixed below nargs - collect (stack stack (+ argsi index))))) +(defun listify-rest-args (nfixed stack argsi nargs) + (loop for index from nfixed below nargs + collect (stack stack (+ argsi index)))) (declaim (inline parse-key-args)) -(defun parse-key-args (nfixed key-count ll-aok-p key-literal-start key-frame-start - stack bp nargs argsi constants) +(defun parse-key-args (nfixed key-count ll-aok-p key-literal-start + stack sp nargs argsi constants) (declare (type (unsigned-byte 16) nfixed key-count - key-literal-start key-frame-start nargs) + key-literal-start nargs) (type (simple-array t (*)) stack) - (type (and unsigned-byte fixnum) bp argsi)) + (type (and unsigned-byte fixnum) sp argsi)) + (when (and (> nargs nfixed) (oddp (- nargs nfixed))) + (error 'arg:odd-keywords)) (let* ((end (+ argsi nargs)) (more-start (+ argsi nfixed)) (key-literal-end (+ key-literal-start key-count)) (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 (local stack bp index) (make-unbound-marker))) - (when (> end more-start) - (do ((arg-index (- end 1) (- arg-index 2))) - ((< arg-index more-start) - (cond ((= arg-index (1- more-start))) - ((= arg-index (- more-start 2)) - (error 'arg:odd-keywords)) - (t - (error "BUG! This can't happen!")))) - (let ((key (stack stack (1- arg-index)))) - (when (eq key :allow-other-keys) - (setf allow-other-keys-p (stack stack arg-index))) - (loop for key-index from key-literal-start - below key-literal-end - for offset of-type (unsigned-byte 16) - from key-frame-start - do (when (eq (constant constants key-index) key) - (setf (local stack bp offset) (stack stack arg-index)) - (return)) - finally (unless (or allow-other-keys-p - ;; aok is always allowed - (eq key :allow-other-keys)) - (push key unknown-keys)))))) + (allow-other-keys-p nil) + (argstemp (make-array key-count :initial-element *unbound*))) + (declare (dynamic-extent argstemp)) + (loop for arg-aindex from (- end 1) above more-start by 2 + for key-aindex = (- arg-aindex 1) + do (let ((akey (stack stack key-aindex)) + (arg (stack stack arg-aindex))) + (when (eq akey :allow-other-keys) + (setf allow-other-keys-p arg)) + (loop for key-index from key-literal-start + below key-literal-end + for key = (constant constants key-index) + for offset of-type (unsigned-byte 16) from 0 + do (when (eq akey key) + (setf (aref argstemp offset) arg) + (return)) + finally (unless (eq akey :allow-other-keys) + (push akey unknown-keys))))) (when (and (not (or ll-aok-p allow-other-keys-p)) unknown-keys) (error 'arg:unrecognized-keyword-argument - :unrecognized-keywords unknown-keys)))) + :unrecognized-keywords unknown-keys)) + (loop for i from (1- key-count) downto 0 + do (spush (aref argstemp i) stack sp)) + sp))