From 376eef6143d5f4bfc0cd2d556293ec32aaa1c1ec Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Sat, 31 May 2008 13:27:50 +0000 Subject: [PATCH 01/71] We need sys/time.h for struct timeval. --- contrib/sockets/sockets.lisp | 2 ++ 1 file changed, 2 insertions(+) diff --git a/contrib/sockets/sockets.lisp b/contrib/sockets/sockets.lisp index 6c113681e..140d7c4ac 100644 --- a/contrib/sockets/sockets.lisp +++ b/contrib/sockets/sockets.lisp @@ -37,6 +37,8 @@ "#include " "#include " "#include " + #-:win32 + "#include " "#include " "#include " "#include " From 7201e26e857196fc3f3de52301b4f06479b11a3f Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 5 Jun 2008 12:44:07 +0000 Subject: [PATCH 02/71] Import version 1.118 of ASDF --- contrib/asdf/asdf.lisp | 1002 +++++++++++++++++++++------------------- src/CHANGELOG | 2 + src/lsp/config.lsp.in | 2 +- 3 files changed, 528 insertions(+), 478 deletions(-) diff --git a/contrib/asdf/asdf.lisp b/contrib/asdf/asdf.lisp index f40e8cab9..9371063c6 100644 --- a/contrib/asdf/asdf.lisp +++ b/contrib/asdf/asdf.lisp @@ -39,90 +39,96 @@ (defpackage #:asdf (:export #:defsystem #:oos #:operate #:find-system #:run-shell-command - #:system-definition-pathname #:find-component ; miscellaneous - #:hyperdocumentation #:hyperdoc - - #:compile-op #:load-op #:load-source-op #:test-system-version - #:test-op - #:operation ; operations - #:feature ; sort-of operation - #:version ; metaphorically sort-of an operation - - #:input-files #:output-files #:perform ; operation methods - #:operation-done-p #:explain - - #:component #:source-file - #:c-source-file #:cl-source-file #:java-source-file - #:static-file - #:doc-file - #:html-file - #:text-file - #:source-file-type - #:module ; components - #:system - #:unix-dso - - #:module-components ; component accessors - #:component-pathname - #:component-relative-pathname - #:component-name - #:component-version - #:component-parent - #:component-property - #:component-system - - #:component-depends-on + #:system-definition-pathname #:find-component ; miscellaneous - #:system-description - #:system-long-description - #:system-author - #:system-maintainer - #:system-license - #:system-licence - #:system-source-file - #:system-relative-pathname + #:compile-op #:load-op #:load-source-op #:test-system-version + #:test-op + #:operation ; operations + #:feature ; sort-of operation + #:version ; metaphorically sort-of an operation - #:operation-on-warnings - #:operation-on-failure - - ;#:*component-parent-pathname* - #:*system-definition-search-functions* - #:*central-registry* ; variables - #:*compile-file-warnings-behaviour* - #:*compile-file-failure-behaviour* - #:*asdf-revision* - - #:operation-error #:compile-failed #:compile-warned #:compile-error - #:error-component #:error-operation - #:system-definition-error - #:missing-component - #:missing-dependency - #:circular-dependency ; errors - #:duplicate-names - - #:retry - #:accept ; restarts - - #:preference-file-for-system/operation - #:load-preferences + #:input-files #:output-files #:perform ; operation methods + #:operation-done-p #:explain + + #:component #:source-file + #:c-source-file #:cl-source-file #:java-source-file + #:static-file + #:doc-file + #:html-file + #:text-file + #:source-file-type + #:module ; components + #:system + #:unix-dso + + #:module-components ; component accessors + #:component-pathname + #:component-relative-pathname + #:component-name + #:component-version + #:component-parent + #:component-property + #:component-system + + #:component-depends-on + + #:system-description + #:system-long-description + #:system-author + #:system-maintainer + #:system-license + #:system-licence + #:system-source-file + #:system-relative-pathname + + #:operation-on-warnings + #:operation-on-failure + + ;#:*component-parent-pathname* + #:*system-definition-search-functions* + #:*central-registry* ; variables + #:*compile-file-warnings-behaviour* + #:*compile-file-failure-behaviour* + #:*asdf-revision* + + #:operation-error #:compile-failed #:compile-warned #:compile-error + #:error-component #:error-operation + #:system-definition-error + #:missing-component + #:missing-dependency + #:circular-dependency ; errors + #:duplicate-names + + #:retry + #:accept ; restarts ) + ;; preference loading - to be expunged + (:export + #:preference-file-for-system/operation + #:load-preferences) (:use :cl)) #+nil -(error "The author of this file habitually uses #+nil to comment out forms. But don't worry, it was unlikely to work in the New Implementation of Lisp anyway") - +(error "The author of this file habitually uses #+nil to comment out ~ + forms. But don't worry, it was unlikely to work in the New ~ + Implementation of Lisp anyway") (in-package #:asdf) (defvar *asdf-revision* (let* ((v "$Revision$") - (colon (or (position #\: v) -1)) - (dot (position #\. v))) - (and v colon dot - (list (parse-integer v :start (1+ colon) - :junk-allowed t) - (parse-integer v :start (1+ dot) - :junk-allowed t))))) + (colon (or (position #\: v) -1)) + (dot (position #\. v))) + (and v colon dot + (list (parse-integer v :start (1+ colon) + :junk-allowed t) + (parse-integer v :start (1+ dot) + :junk-allowed t))))) + +(defvar *load-preference-files* nil + "If true, then preference files will be loaded. + +This variable will be removed August 2008.") (defvar *compile-file-warnings-behaviour* :warn) @@ -144,8 +150,8 @@ and NIL NAME and TYPE components" (make-pathname :name nil :type nil :defaults pathname)) -(define-modify-macro appendf (&rest args) - append "Append onto list") +(define-modify-macro appendf (&rest args) + append "Append onto list") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; classes, condiitons @@ -163,7 +169,7 @@ and NIL NAME and TYPE components" ((format-control :initarg :format-control :reader format-control) (format-arguments :initarg :format-arguments :reader format-arguments)) (:report (lambda (c s) - (apply #'format s (format-control c) (format-arguments c))))) + (apply #'format s (format-control c) (format-arguments c))))) (define-condition circular-dependency (system-definition-error) ((components :initarg :components :reader circular-dependency-components))) @@ -183,19 +189,19 @@ and NIL NAME and TYPE components" ((component :reader error-component :initarg :component) (operation :reader error-operation :initarg :operation)) (:report (lambda (c s) - (format s "~@" - (error-operation c) (error-component c))))) + (format s "~@" + (error-operation c) (error-component c))))) (define-condition compile-error (operation-error) ()) (define-condition compile-failed (compile-error) ()) (define-condition compile-warned (compile-error) ()) (defclass component () ((name :accessor component-name :initarg :name :documentation - "Component name: designator for a string composed of portable pathname characters") + "Component name: designator for a string composed of portable pathname characters") (version :accessor component-version :initarg :version) (original-depends-on :accessor component-original-depends-on :initarg :original-depends-on :initform nil) (in-order-to :initform nil :initarg :in-order-to) - ;;; XXX crap name + ;; XXX crap name (do-first :initform nil :initarg :do-first) ;; methods defined using the "inline" style inside a defsystem form: ;; need to store them somewhere so we can delete them when the system @@ -206,17 +212,17 @@ and NIL NAME and TYPE components" ;; it to default in funky ways if not supplied (relative-pathname :initarg :pathname) (operation-times :initform (make-hash-table ) - :accessor component-operation-times) + :accessor component-operation-times) ;; XXX we should provide some atomic interface for updating the ;; component properties (properties :accessor component-properties :initarg :properties - :initform nil))) + :initform nil))) ;;;; methods: conditions (defmethod print-object ((c missing-dependency) s) (format s "~@<~A, required by ~A~@:>" - (call-next-method c nil) (missing-required-by c))) + (call-next-method c nil) (missing-required-by c))) (defun sysdef-error (format &rest arguments) (error 'formatted-system-definition-error :format-control format :format-arguments arguments)) @@ -227,14 +233,14 @@ and NIL NAME and TYPE components" (format s "~@" - (missing-requires c) - (missing-version c) - (when (missing-parent c) - (component-name (missing-parent c))))) + (missing-requires c) + (missing-version c) + (when (missing-parent c) + (component-name (missing-parent c))))) (defgeneric component-system (component) (:documentation "Find the top-level system containing COMPONENT")) - + (defmethod component-system ((component component)) (aif (component-parent component) (component-system it) @@ -250,8 +256,8 @@ and NIL NAME and TYPE components" ;; what to do if we can't satisfy a dependency of one of this module's ;; components. This allows a limited form of conditional processing (if-component-dep-fails :initform :fail - :accessor module-if-component-dep-fails - :initarg :if-component-dep-fails) + :accessor module-if-component-dep-fails + :initarg :if-component-dep-fails) (default-component-class :accessor module-default-component-class :initform 'cl-source-file :initarg :default-component-class))) @@ -265,7 +271,7 @@ and NIL NAME and TYPE components" (defgeneric component-relative-pathname (component) (:documentation "Extracts the relative pathname applicable for a particular component.")) - + (defmethod component-relative-pathname ((component module)) (or (slot-value component 'relative-pathname) (make-pathname @@ -286,9 +292,9 @@ and NIL NAME and TYPE components" (defmethod (setf component-property) (new-value (c component) property) (let ((a (assoc property (slot-value c 'properties) :test #'equal))) (if a - (setf (cdr a) new-value) - (setf (slot-value c 'properties) - (acons property new-value (slot-value c 'properties)))))) + (setf (cdr a) new-value) + (setf (slot-value c 'properties) + (acons property new-value (slot-value c 'properties)))))) (defclass system (module) ((description :accessor system-description :initarg :description) @@ -297,7 +303,7 @@ and NIL NAME and TYPE components" (author :accessor system-author :initarg :author) (maintainer :accessor system-maintainer :initarg :maintainer) (licence :accessor system-licence :initarg :licence - :accessor system-license :initarg :license))) + :accessor system-license :initarg :license))) ;;; version-satisfies @@ -307,13 +313,13 @@ and NIL NAME and TYPE components" (nreverse (let ((list nil) (start 0) (words 0) end) (loop - (when (and max (>= words (1- max))) - (return (cons (subseq string start) list))) - (setf end (position-if #'is-ws string :start start)) - (push (subseq string start end) list) - (incf words) - (unless end (return list)) - (setf start (1+ end))))))) + (when (and max (>= words (1- max))) + (return (cons (subseq string start) list))) + (setf end (position-if #'is-ws string :start start)) + (push (subseq string start end) list) + (incf words) + (unless end (return list)) + (setf start (1+ end))))))) (defgeneric version-satisfies (component version)) @@ -321,28 +327,28 @@ and NIL NAME and TYPE components" (unless (and version (slot-boundp c 'version)) (return-from version-satisfies t)) (let ((x (mapcar #'parse-integer - (split (component-version c) nil '(#\.)))) - (y (mapcar #'parse-integer - (split version nil '(#\.))))) + (split (component-version c) nil '(#\.)))) + (y (mapcar #'parse-integer + (split version nil '(#\.))))) (labels ((bigger (x y) - (cond ((not y) t) - ((not x) nil) - ((> (car x) (car y)) t) - ((= (car x) (car y)) - (bigger (cdr x) (cdr y)))))) + (cond ((not y) t) + ((not x) nil) + ((> (car x) (car y)) t) + ((= (car x) (car y)) + (bigger (cdr x) (cdr y)))))) (and (= (car x) (car y)) - (or (not (cdr y)) (bigger (cdr x) (cdr y))))))) + (or (not (cdr y)) (bigger (cdr x) (cdr y))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; finding systems (defvar *defined-systems* (make-hash-table :test 'equal)) (defun coerce-name (name) - (typecase name - (component (component-name name)) - (symbol (string-downcase (symbol-name name))) - (string name) - (t (sysdef-error "~@" name)))) + (typecase name + (component (component-name name)) + (symbol (string-downcase (symbol-name name))) + (string name) + (t (sysdef-error "~@" name)))) ;;; for the sake of keeping things reasonably neat, we adopt a ;;; convention that functions in this list are prefixed SYSDEF- @@ -352,8 +358,8 @@ and NIL NAME and TYPE components" (defun system-definition-pathname (system) (some (lambda (x) (funcall x system)) - *system-definition-search-functions*)) - + *system-definition-search-functions*)) + (defvar *central-registry* '(*default-pathname-defaults* #+nil "/home/dan/src/sourceforge/cclan/asdf/systems/" @@ -363,52 +369,52 @@ and NIL NAME and TYPE components" (let ((name (coerce-name system))) (block nil (dolist (dir *central-registry*) - (let* ((defaults (eval dir)) - (file (and defaults - (make-pathname - :defaults defaults :version :newest - :name name :type "asd" :case :local)))) - (if (and file (probe-file file)) - (return file))))))) + (let* ((defaults (eval dir)) + (file (and defaults + (make-pathname + :defaults defaults :version :newest + :name name :type "asd" :case :local)))) + (if (and file (probe-file file)) + (return file))))))) (defun make-temporary-package () (flet ((try (counter) (ignore-errors - (make-package (format nil "ASDF~D" counter) - :use '(:cl :asdf))))) + (make-package (format nil "ASDF~D" counter) + :use '(:cl :asdf))))) (do* ((counter 0 (+ counter 1)) (package (try counter) (try counter))) (package package)))) (defun find-system (name &optional (error-p t)) (let* ((name (coerce-name name)) - (in-memory (gethash name *defined-systems*)) - (on-disk (system-definition-pathname name))) + (in-memory (gethash name *defined-systems*)) + (on-disk (system-definition-pathname name))) (when (and on-disk - (or (not in-memory) - (< (car in-memory) (file-write-date on-disk)))) + (or (not in-memory) + (< (car in-memory) (file-write-date on-disk)))) (let ((package (make-temporary-package))) (unwind-protect (let ((*package* package)) - (format + (format *verbose-out* "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%" ;; FIXME: This wants to be (ENOUGH-NAMESTRING ;; ON-DISK), but CMUCL barfs on that. - on-disk - *package*) + on-disk + *package*) (load on-disk)) (delete-package package)))) (let ((in-memory (gethash name *defined-systems*))) (if in-memory - (progn (if on-disk (setf (car in-memory) (file-write-date on-disk))) - (cdr in-memory)) - (if error-p (error 'missing-component :requires name)))))) + (progn (if on-disk (setf (car in-memory) (file-write-date on-disk))) + (cdr in-memory)) + (if error-p (error 'missing-component :requires name)))))) (defun register-system (name system) (format *verbose-out* "~&~@<; ~@;registering ~A as ~A~@:>~%" system name) (setf (gethash (coerce-name name) *defined-systems*) - (cons (get-universal-time) system))) + (cons (get-universal-time) system))) (defun system-registered-p (name) (gethash (coerce-name name) *defined-systems*)) @@ -424,9 +430,9 @@ system.")) (defmethod find-component ((module module) name &optional version) (if (slot-boundp module 'components) (let ((m (find name (module-components module) - :test #'equal :key #'component-name))) - (if (and m (version-satisfies m version)) m)))) - + :test #'equal :key #'component-name))) + (if (and m (version-satisfies m version)) m)))) + ;;; a component with no parent is a system (defmethod find-component ((module (eql nil)) name &optional version) @@ -461,11 +467,11 @@ system.")) (defmethod component-relative-pathname ((component source-file)) (let ((relative-pathname (slot-value component 'relative-pathname))) (if relative-pathname - (merge-pathnames + (merge-pathnames relative-pathname - (make-pathname + (make-pathname :type (source-file-type component (component-system component)))) - (let* ((*default-pathname-defaults* + (let* ((*default-pathname-defaults* (component-parent-pathname component)) (name-type (make-pathname @@ -482,7 +488,7 @@ system.")) (defclass operation () ((forced :initform nil :initarg :force :accessor operation-forced) (original-initargs :initform nil :initarg :original-initargs - :accessor operation-original-initargs) + :accessor operation-original-initargs) (visited-nodes :initform nil :accessor operation-visited-nodes) (visiting-nodes :initform nil :accessor operation-visiting-nodes) (parent :initform nil :initarg :parent :accessor operation-parent))) @@ -493,8 +499,8 @@ system.")) (prin1 (operation-original-initargs o) stream)))) (defmethod shared-initialize :after ((operation operation) slot-names - &key force - &allow-other-keys) + &key force + &allow-other-keys) (declare (ignore slot-names force)) ;; empty method to disable initarg validity checking ) @@ -509,7 +515,9 @@ system.")) (cons (class-name (class-of o)) c)) (defgeneric operation-ancestor (operation) - (:documentation "Recursively chase the operation's parent pointer until we get to the head of the tree")) + (:documentation + "Recursively chase the operation's parent pointer until we get to +the head of the tree")) (defmethod operation-ancestor ((operation operation)) (aif (operation-parent operation) @@ -519,22 +527,22 @@ system.")) (defun make-sub-operation (c o dep-c dep-o) (let* ((args (copy-list (operation-original-initargs o))) - (force-p (getf args :force))) + (force-p (getf args :force))) ;; note explicit comparison with T: any other non-NIL force value ;; (e.g. :recursive) will pass through (cond ((and (null (component-parent c)) - (null (component-parent dep-c)) - (not (eql c dep-c))) - (when (eql force-p t) - (setf (getf args :force) nil)) - (apply #'make-instance dep-o - :parent o - :original-initargs args args)) - ((subtypep (type-of o) dep-o) - o) - (t - (apply #'make-instance dep-o - :parent o :original-initargs args args))))) + (null (component-parent dep-c)) + (not (eql c dep-c))) + (when (eql force-p t) + (setf (getf args :force) nil)) + (apply #'make-instance dep-o + :parent o + :original-initargs args args)) + ((subtypep (type-of o) dep-o) + o) + (t + (apply #'make-instance dep-o + :parent o :original-initargs args args))))) (defgeneric visit-component (operation component data)) @@ -542,14 +550,14 @@ system.")) (defmethod visit-component ((o operation) (c component) data) (unless (component-visited-p o c) (push (cons (node-for o c) data) - (operation-visited-nodes (operation-ancestor o))))) + (operation-visited-nodes (operation-ancestor o))))) (defgeneric component-visited-p (operation component)) (defmethod component-visited-p ((o operation) (c component)) (assoc (node-for o c) - (operation-visited-nodes (operation-ancestor o)) - :test 'equal)) + (operation-visited-nodes (operation-ancestor o)) + :test 'equal)) (defgeneric (setf visiting-component) (new-value operation component)) @@ -559,18 +567,18 @@ system.")) (defmethod (setf visiting-component) (new-value (o operation) (c component)) (let ((node (node-for o c)) - (a (operation-ancestor o))) + (a (operation-ancestor o))) (if new-value - (pushnew node (operation-visiting-nodes a) :test 'equal) - (setf (operation-visiting-nodes a) - (remove node (operation-visiting-nodes a) :test 'equal))))) + (pushnew node (operation-visiting-nodes a) :test 'equal) + (setf (operation-visiting-nodes a) + (remove node (operation-visiting-nodes a) :test 'equal))))) (defgeneric component-visiting-p (operation component)) (defmethod component-visiting-p ((o operation) (c component)) (let ((node (cons o c))) (member node (operation-visiting-nodes (operation-ancestor o)) - :test 'equal))) + :test 'equal))) (defgeneric component-depends-on (operation component) (:documentation @@ -594,28 +602,28 @@ system.")) (defmethod component-depends-on ((o operation) (c component)) (cdr (assoc (class-name (class-of o)) - (slot-value c 'in-order-to)))) + (slot-value c 'in-order-to)))) (defgeneric component-self-dependencies (operation component)) (defmethod component-self-dependencies ((o operation) (c component)) (let ((all-deps (component-depends-on o c))) (remove-if-not (lambda (x) - (member (component-name c) (cdr x) :test #'string=)) - all-deps))) - + (member (component-name c) (cdr x) :test #'string=)) + all-deps))) + (defmethod input-files ((operation operation) (c component)) (let ((parent (component-parent c)) - (self-deps (component-self-dependencies operation c))) + (self-deps (component-self-dependencies operation c))) (if self-deps - (mapcan (lambda (dep) - (destructuring-bind (op name) dep - (output-files (make-instance op) - (find-component parent name)))) - self-deps) - ;; no previous operations needed? I guess we work with the - ;; original source file, then - (list (component-pathname c))))) + (mapcan (lambda (dep) + (destructuring-bind (op name) dep + (output-files (make-instance op) + (find-component parent name)))) + self-deps) + ;; no previous operations needed? I guess we work with the + ;; original source file, then + (list (component-pathname c))))) (defmethod input-files ((operation operation) (c module)) nil) @@ -629,18 +637,18 @@ system.")) (let ((date (file-write-date file))) (cond (date) - (t + (t (warn "~@" + operation ~S on component ~S as done.~@:>" file o c) (return-from operation-done-p t)))))) (let ((out-files (output-files o c)) (in-files (input-files o c))) (cond ((and (not in-files) (not out-files)) ;; arbitrary decision: an operation that uses nothing to - ;; produce nothing probably isn't doing much + ;; produce nothing probably isn't doing much t) - ((not out-files) + ((not out-files) (let ((op-done (gethash (type-of o) (component-operation-times c)))) @@ -665,81 +673,84 @@ system.")) (defmethod traverse ((operation operation) (c component)) (let ((forced nil)) (labels ((do-one-dep (required-op required-c required-v) - (let* ((dep-c (or (find-component - (component-parent c) - ;; XXX tacky. really we should build the - ;; in-order-to slot with canonicalized - ;; names instead of coercing this late - (coerce-name required-c) required-v) - (error 'missing-dependency :required-by c - :version required-v - :requires required-c))) - (op (make-sub-operation c operation dep-c required-op))) - (traverse op dep-c))) - (do-dep (op dep) - (cond ((eq op 'feature) - (or (member (car dep) *features*) - (error 'missing-dependency :required-by c - :requires (car dep) :version nil))) - (t - (dolist (d dep) + (let* ((dep-c (or (find-component + (component-parent c) + ;; XXX tacky. really we should build the + ;; in-order-to slot with canonicalized + ;; names instead of coercing this late + (coerce-name required-c) required-v) + (error 'missing-dependency + :required-by c + :version required-v + :requires required-c))) + (op (make-sub-operation c operation dep-c required-op))) + (traverse op dep-c))) + (do-dep (op dep) + (cond ((eq op 'feature) + (or (member (car dep) *features*) + (error 'missing-dependency + :required-by c + :requires (car dep) + :version nil))) + (t + (dolist (d dep) (cond ((consp d) (assert (string-equal (symbol-name (first d)) "VERSION")) (appendf forced - (do-one-dep op (second d) (third d)))) + (do-one-dep op (second d) (third d)))) (t (appendf forced (do-one-dep op d nil))))))))) (aif (component-visited-p operation c) - (return-from traverse - (if (cdr it) (list (cons 'pruned-op c)) nil))) + (return-from traverse + (if (cdr it) (list (cons 'pruned-op c)) nil))) ;; dependencies (if (component-visiting-p operation c) - (error 'circular-dependency :components (list c))) + (error 'circular-dependency :components (list c))) (setf (visiting-component operation c) t) (loop for (required-op . deps) in (component-depends-on operation c) - do (do-dep required-op deps)) + do (do-dep required-op deps)) ;; constituent bits (let ((module-ops - (when (typep c 'module) - (let ((at-least-one nil) - (forced nil) - (error nil)) - (loop for kid in (module-components c) - do (handler-case - (appendf forced (traverse operation kid )) - (missing-dependency (condition) - (if (eq (module-if-component-dep-fails c) :fail) - (error condition)) - (setf error condition)) - (:no-error (c) - (declare (ignore c)) - (setf at-least-one t)))) - (when (and (eq (module-if-component-dep-fails c) :try-next) - (not at-least-one)) - (error error)) - forced)))) - ;; now the thing itself - (when (or forced module-ops - (not (operation-done-p operation c)) - (let ((f (operation-forced (operation-ancestor operation)))) - (and f (or (not (consp f)) - (member (component-name - (operation-ancestor operation)) - (mapcar #'coerce-name f) - :test #'string=))))) - (let ((do-first (cdr (assoc (class-name (class-of operation)) - (slot-value c 'do-first))))) - (loop for (required-op . deps) in do-first - do (do-dep required-op deps))) - (setf forced (append (delete 'pruned-op forced :key #'car) - (delete 'pruned-op module-ops :key #'car) - (list (cons operation c)))))) + (when (typep c 'module) + (let ((at-least-one nil) + (forced nil) + (error nil)) + (loop for kid in (module-components c) + do (handler-case + (appendf forced (traverse operation kid )) + (missing-dependency (condition) + (if (eq (module-if-component-dep-fails c) :fail) + (error condition)) + (setf error condition)) + (:no-error (c) + (declare (ignore c)) + (setf at-least-one t)))) + (when (and (eq (module-if-component-dep-fails c) :try-next) + (not at-least-one)) + (error error)) + forced)))) + ;; now the thing itself + (when (or forced module-ops + (not (operation-done-p operation c)) + (let ((f (operation-forced (operation-ancestor operation)))) + (and f (or (not (consp f)) + (member (component-name + (operation-ancestor operation)) + (mapcar #'coerce-name f) + :test #'string=))))) + (let ((do-first (cdr (assoc (class-name (class-of operation)) + (slot-value c 'do-first))))) + (loop for (required-op . deps) in do-first + do (do-dep required-op deps))) + (setf forced (append (delete 'pruned-op forced :key #'car) + (delete 'pruned-op module-ops :key #'car) + (list (cons operation c)))))) (setf (visiting-component operation c) nil) (visit-component operation c (and forced t)) forced))) - + (defmethod perform ((operation operation) (c source-file)) (sysdef-error @@ -759,17 +770,18 @@ system.")) ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil) (system-p :initarg :system-p :accessor compile-op-system-p :initform nil) (on-warnings :initarg :on-warnings :accessor operation-on-warnings - :initform *compile-file-warnings-behaviour*) + :initform *compile-file-warnings-behaviour*) (on-failure :initarg :on-failure :accessor operation-on-failure - :initform *compile-file-failure-behaviour*))) + :initform *compile-file-failure-behaviour*))) (defmethod perform :before ((operation compile-op) (c source-file)) (map nil #'ensure-directories-exist (output-files operation c))) (defmethod perform :after ((operation operation) (c component)) (setf (gethash (type-of operation) (component-operation-times c)) - (get-universal-time)) - (load-preferences c operation)) + (get-universal-time)) + (when *load-preference-files* + (load-preferences c operation))) ;;; perform is required to check output-files to find out where to put ;;; its answers, in case it has been overridden for site policy @@ -778,10 +790,7 @@ system.")) (let ((source-file (component-pathname c)) (output-file (car (output-files operation c)))) (multiple-value-bind (output warnings-p failure-p) - (compile-file source-file - :output-file output-file - :system-p (compile-op-system-p operation)) - ;(declare (ignore output)) + (compile-file source-file :output-file output-file :system-p (compile-op-system-p operation)) (when warnings-p (case (operation-on-warnings operation) (:warn (warn @@ -822,8 +831,49 @@ system.")) (defmethod perform ((o load-op) (c cl-source-file)) (mapcar #'load (input-files o c))) +(defmethod perform :around ((o load-op) (c cl-source-file)) + (let ((state :initial)) + (loop until (or (eq state :success) + (eq state :failure)) do + (case state + (:recompiled + (setf state :failure) + (call-next-method) + (setf state :success)) + (:failed-load + (setf state :recompiled) + (perform (make-instance 'asdf:compile-op) c)) + (t + (with-simple-restart + (:try-recompiling "Recompile ~a and try loading it again" + (component-name c)) + (setf state :failed-load) + (call-next-method) + (setf state :success))))))) + +(defmethod perform :around ((o compile-op) (c cl-source-file)) + (let ((state :initial)) + (loop until (or (eq state :success) + (eq state :failure)) do + (case state + (:recompiled + (setf state :failure) + (call-next-method) + (setf state :success)) + (:failed-compile + (setf state :recompiled) + (perform (make-instance 'asdf:compile-op) c)) + (t + (with-simple-restart + (:try-recompiling "Try recompiling ~a" + (component-name c)) + (setf state :failed-compile) + (call-next-method) + (setf state :success))))))) + (defmethod perform ((operation load-op) (c static-file)) nil) + (defmethod operation-done-p ((operation load-op) (c static-file)) t) @@ -862,8 +912,8 @@ system.")) (defmethod operation-done-p ((o load-source-op) (c source-file)) (if (or (not (component-property c 'last-loaded-as-source)) - (> (file-write-date (component-pathname c)) - (component-property c 'last-loaded-as-source))) + (> (file-write-date (component-pathname c)) + (component-property c 'last-loaded-as-source))) nil t)) (defclass test-op (operation) ()) @@ -872,10 +922,19 @@ system.")) nil) (defgeneric load-preferences (system operation) - (:documentation "Called to load system preferences after . Typical uses are to set parameters that don't exist until after the system has been loaded.")) + (:documentation + "Deprecated - will be removed August 2008 + +Called to load system preferences after . Typical uses are to set parameters that don't exist until +after the system has been loaded.")) (defgeneric preference-file-for-system/operation (system operation) - (:documentation "Returns the pathname of the preference file for this system. Called by 'load-preferences to determine what file to load.")) + (:documentation + "Deprecated - will be removed August 2008 + +Returns the pathname of the preference file for this system. +Called by 'load-preferences to determine what file to load.")) (defmethod load-preferences ((s t) (operation t)) ;; do nothing @@ -884,77 +943,76 @@ system.")) (defmethod load-preferences ((s system) (operation basic-load-op)) (let* ((*package* (find-package :common-lisp)) (file (probe-file (preference-file-for-system/operation s operation)))) - (when file + (when file (when *verbose-out* - (format *verbose-out* - "~&~@<; ~@;loading preferences for ~A/~(~A~) from ~A~@:>~%" - (component-name s) - (type-of operation) file)) + (format *verbose-out* + "~&~@<; ~@;loading preferences for ~A/~(~A~) from ~A~@:>~%" + (component-name s) + (type-of operation) file)) (load file)))) (defmethod preference-file-for-system/operation ((system t) (operation t)) - ;; cope with anything other than systems + ;; cope with anything other than systems (preference-file-for-system/operation (find-system system t) operation)) (defmethod preference-file-for-system/operation ((s system) (operation t)) - (let ((*default-pathname-defaults* - (make-pathname :name nil :type nil - :defaults *default-pathname-defaults*))) + (let ((*default-pathname-defaults* + (make-pathname :name nil :type nil + :defaults *default-pathname-defaults*))) (merge-pathnames (make-pathname :name (component-name s) - :type "lisp" - :directory '(:relative ".asdf")) + :type "lisp" + :directory '(:relative ".asdf")) (truename (user-homedir-pathname))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; invoking operations -(defvar *operate-docstring* +(defvar *operate-docstring* "Operate does three things: -1. It creates an instance of `operation-class` using any keyword parameters -as initargs. -2. It finds the asdf-system specified by `system` (possibly loading +1. It creates an instance of `operation-class` using any keyword parameters +as initargs. +2. It finds the asdf-system specified by `system` (possibly loading it from disk). 3. It then calls `traverse` with the operation and system as arguments -The traverse operation is wrapped in `with-compilation-unit` and error -handling code. If a `version` argument is supplied, then operate also +The traverse operation is wrapped in `with-compilation-unit` and error +handling code. If a `version` argument is supplied, then operate also ensures that the system found satisfies it using the `version-satisfies` method.") -(defun operate (operation-class system &rest args &key (verbose t) version - &allow-other-keys) +(defun operate (operation-class system &rest args &key (verbose t) version + &allow-other-keys) (let* ((op (apply #'make-instance operation-class - :original-initargs args - args)) - (*verbose-out* (if verbose *standard-output* (make-broadcast-stream))) - (system (if (typep system 'component) system (find-system system)))) + :original-initargs args + args)) + (*verbose-out* (if verbose *standard-output* (make-broadcast-stream))) + (system (if (typep system 'component) system (find-system system)))) (unless (version-satisfies system version) (error 'missing-component :requires system :version version)) (let ((steps (traverse op system))) (with-compilation-unit () - (loop for (op . component) in steps do - (loop - (restart-case - (progn (perform op component) - (return)) - (retry () - :report - (lambda (s) - (format s "~@" - op component))) - (accept () - :report - (lambda (s) - (format s - "~@" - op component)) - (setf (gethash (type-of op) - (component-operation-times component)) - (get-universal-time)) - (return))))))))) + (loop for (op . component) in steps do + (loop + (restart-case + (progn (perform op component) + (return)) + (retry () + :report + (lambda (s) + (format s "~@" + op component))) + (accept () + :report + (lambda (s) + (format s "~@" + op component)) + (setf (gethash (type-of op) + (component-operation-times component)) + (get-universal-time)) + (return))))))))) (setf (documentation 'operate 'function) *operate-docstring*) @@ -964,229 +1022,228 @@ method.") (apply #'operate operation-class system args)) (setf (documentation 'oos 'function) - (format nil - "Short for _operate on system_ and an alias for the `operate` function. ~&~&~a" - *operate-docstring*)) + (format nil + "Short for _operate on system_ and an alias for the `operate` function. ~&~&~a" + *operate-docstring*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; syntax (defun remove-keyword (key arglist) (labels ((aux (key arglist) - (cond ((null arglist) nil) - ((eq key (car arglist)) (cddr arglist)) - (t (cons (car arglist) (cons (cadr arglist) - (remove-keyword - key (cddr arglist)))))))) + (cond ((null arglist) nil) + ((eq key (car arglist)) (cddr arglist)) + (t (cons (car arglist) (cons (cadr arglist) + (remove-keyword + key (cddr arglist)))))))) (aux key arglist))) (defmacro defsystem (name &body options) (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system) - &allow-other-keys) + &allow-other-keys) options (let ((component-options (remove-keyword :class options))) `(progn - ;; system must be registered before we parse the body, otherwise - ;; we recur when trying to find an existing system of the same name - ;; to reuse options (e.g. pathname) from - (let ((s (system-registered-p ',name))) - (cond ((and s (eq (type-of (cdr s)) ',class)) - (setf (car s) (get-universal-time))) - (s - #+clisp - (sysdef-error "Cannot redefine the existing system ~A with a different class" s) - #-clisp - (change-class (cdr s) ',class)) - (t - (register-system (quote ,name) - (make-instance ',class :name ',name))))) - (parse-component-form nil (apply - #'list - :module (coerce-name ',name) - :pathname - ;; to avoid a note about unreachable code - ,(if pathname-arg-p - pathname - `(or (when *load-truename* - (pathname-sans-name+type - (resolve-symlinks - *load-truename*))) - *default-pathname-defaults*)) - ',component-options)))))) - + ;; system must be registered before we parse the body, otherwise + ;; we recur when trying to find an existing system of the same name + ;; to reuse options (e.g. pathname) from + (let ((s (system-registered-p ',name))) + (cond ((and s (eq (type-of (cdr s)) ',class)) + (setf (car s) (get-universal-time))) + (s + #+clisp + (sysdef-error "Cannot redefine the existing system ~A with a different class" s) + #-clisp + (change-class (cdr s) ',class)) + (t + (register-system (quote ,name) + (make-instance ',class :name ',name))))) + (parse-component-form nil (apply + #'list + :module (coerce-name ',name) + :pathname + ;; to avoid a note about unreachable code + ,(if pathname-arg-p + pathname + `(or (when *load-truename* + (pathname-sans-name+type + (resolve-symlinks + *load-truename*))) + *default-pathname-defaults*)) + ',component-options)))))) + (defun class-for-type (parent type) (let* ((extra-symbols (list (find-symbol (symbol-name type) *package*) - (find-symbol (symbol-name type) + (find-symbol (symbol-name type) (load-time-value - (package-name :asdf))))) + (package-name :asdf))))) (class (dolist (symbol (if (keywordp type) extra-symbols (cons type extra-symbols))) - (when (and symbol + (when (and symbol (find-class symbol nil) (subtypep symbol 'component)) (return (find-class symbol)))))) (or class - (and (eq type :file) - (or (module-default-component-class parent) - (find-class 'cl-source-file))) - (sysdef-error "~@" type)))) + (and (eq type :file) + (or (module-default-component-class parent) + (find-class 'cl-source-file))) + (sysdef-error "~@" type)))) (defun maybe-add-tree (tree op1 op2 c) "Add the node C at /OP1/OP2 in TREE, unless it's there already. Returns the new tree (which probably shares structure with the old one)" (let ((first-op-tree (assoc op1 tree))) (if first-op-tree - (progn - (aif (assoc op2 (cdr first-op-tree)) - (if (find c (cdr it)) - nil - (setf (cdr it) (cons c (cdr it)))) - (setf (cdr first-op-tree) - (acons op2 (list c) (cdr first-op-tree)))) - tree) - (acons op1 (list (list op2 c)) tree)))) - + (progn + (aif (assoc op2 (cdr first-op-tree)) + (if (find c (cdr it)) + nil + (setf (cdr it) (cons c (cdr it)))) + (setf (cdr first-op-tree) + (acons op2 (list c) (cdr first-op-tree)))) + tree) + (acons op1 (list (list op2 c)) tree)))) + (defun union-of-dependencies (&rest deps) (let ((new-tree nil)) (dolist (dep deps) (dolist (op-tree dep) - (dolist (op (cdr op-tree)) - (dolist (c (cdr op)) - (setf new-tree - (maybe-add-tree new-tree (car op-tree) (car op) c)))))) + (dolist (op (cdr op-tree)) + (dolist (c (cdr op)) + (setf new-tree + (maybe-add-tree new-tree (car op-tree) (car op) c)))))) new-tree)) (defun remove-keys (key-names args) (loop for ( name val ) on args by #'cddr - unless (member (symbol-name name) key-names - :key #'symbol-name :test 'equal) - append (list name val))) + unless (member (symbol-name name) key-names + :key #'symbol-name :test 'equal) + append (list name val))) (defvar *serial-depends-on*) (defun parse-component-form (parent options) (destructuring-bind - (type name &rest rest &key - ;; the following list of keywords is reproduced below in the - ;; remove-keys form. important to keep them in sync - components pathname default-component-class - perform explain output-files operation-done-p - weakly-depends-on - depends-on serial in-order-to - ;; list ends - &allow-other-keys) options - (declare (ignorable perform explain output-files operation-done-p)) + (type name &rest rest &key + ;; the following list of keywords is reproduced below in the + ;; remove-keys form. important to keep them in sync + components pathname default-component-class + perform explain output-files operation-done-p + weakly-depends-on + depends-on serial in-order-to + ;; list ends + &allow-other-keys) options + (declare (ignorable perform explain output-files operation-done-p)) (check-component-input type name weakly-depends-on depends-on components in-order-to) (when (and parent - (find-component parent name) - ;; ignore the same object when rereading the defsystem - (not - (typep (find-component parent name) - (class-for-type parent type)))) + (find-component parent name) + ;; ignore the same object when rereading the defsystem + (not + (typep (find-component parent name) + (class-for-type parent type)))) (error 'duplicate-names :name name)) - - (let* ((other-args (remove-keys - '(components pathname default-component-class - perform explain output-files operation-done-p - weakly-depends-on - depends-on serial in-order-to) - rest)) - (ret - (or (find-component parent name) - (make-instance (class-for-type parent type))))) - (when weakly-depends-on - (setf depends-on (append depends-on (remove-if (complement #'find-system) weakly-depends-on)))) - (when (boundp '*serial-depends-on*) - (setf depends-on - (concatenate 'list *serial-depends-on* depends-on))) - (apply #'reinitialize-instance - ret - :name (coerce-name name) - :pathname pathname - :parent parent - :original-depends-on depends-on - other-args) - (when (typep ret 'module) - (setf (module-default-component-class ret) - (or default-component-class - (and (typep parent 'module) - (module-default-component-class parent)))) - (let ((*serial-depends-on* nil)) - (setf (module-components ret) - (loop for c-form in components - for c = (parse-component-form ret c-form) - collect c - if serial - do (push (component-name c) *serial-depends-on*)))) - ;; check for duplicate names - (let ((name-hash (make-hash-table :test #'equal))) - (loop for c in (module-components ret) - do - (if (gethash (component-name c) - name-hash) - (error 'duplicate-names - :name (component-name c)) - (setf (gethash (component-name c) - name-hash) - t))))) - + (let* ((other-args (remove-keys + '(components pathname default-component-class + perform explain output-files operation-done-p + weakly-depends-on + depends-on serial in-order-to) + rest)) + (ret + (or (find-component parent name) + (make-instance (class-for-type parent type))))) + (when weakly-depends-on + (setf depends-on (append depends-on (remove-if (complement #'find-system) weakly-depends-on)))) + (when (boundp '*serial-depends-on*) + (setf depends-on + (concatenate 'list *serial-depends-on* depends-on))) + (apply #'reinitialize-instance ret + :name (coerce-name name) + :pathname pathname + :parent parent + :original-depends-on depends-on + other-args) + (when (typep ret 'module) + (setf (module-default-component-class ret) + (or default-component-class + (and (typep parent 'module) + (module-default-component-class parent)))) + (let ((*serial-depends-on* nil)) + (setf (module-components ret) + (loop for c-form in components + for c = (parse-component-form ret c-form) + collect c + if serial + do (push (component-name c) *serial-depends-on*)))) + + ;; check for duplicate names + (let ((name-hash (make-hash-table :test #'equal))) + (loop for c in (module-components ret) + do + (if (gethash (component-name c) + name-hash) + (error 'duplicate-names + :name (component-name c)) + (setf (gethash (component-name c) + name-hash) + t))))) + (setf (slot-value ret 'in-order-to) - (union-of-dependencies - in-order-to - `((compile-op (compile-op ,@depends-on)) - (load-op (load-op ,@depends-on)))) - (slot-value ret 'do-first) `((compile-op (load-op ,@depends-on)))) - + (union-of-dependencies + in-order-to + `((compile-op (compile-op ,@depends-on)) + (load-op (load-op ,@depends-on)))) + (slot-value ret 'do-first) `((compile-op (load-op ,@depends-on)))) + (%remove-component-inline-methods ret rest) ret))) (defun %remove-component-inline-methods (ret rest) (loop for name in +asdf-methods+ - do (map 'nil - ;; this is inefficient as most of the stored - ;; methods will not be for this particular gf n - ;; But this is hardly performance-critical - (lambda (m) - (remove-method (symbol-function name) m)) - (component-inline-methods ret))) + do (map 'nil + ;; this is inefficient as most of the stored + ;; methods will not be for this particular gf n + ;; But this is hardly performance-critical + (lambda (m) + (remove-method (symbol-function name) m)) + (component-inline-methods ret))) ;; clear methods, then add the new ones (setf (component-inline-methods ret) nil) (loop for name in +asdf-methods+ - for v = (getf rest (intern (symbol-name name) :keyword)) - when v do - (destructuring-bind (op qual (o c) &body body) v - (pushnew - (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret))) - ,@body)) - (component-inline-methods ret))))) + for v = (getf rest (intern (symbol-name name) :keyword)) + when v do + (destructuring-bind (op qual (o c) &body body) v + (pushnew + (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret))) + ,@body)) + (component-inline-methods ret))))) (defun check-component-input (type name weakly-depends-on depends-on components in-order-to) "A partial test of the values of a component." (when weakly-depends-on (warn "We got one! XXXXX")) (unless (listp depends-on) (sysdef-error-component ":depends-on must be a list." - type name depends-on)) + type name depends-on)) (unless (listp weakly-depends-on) (sysdef-error-component ":weakly-depends-on must be a list." - type name weakly-depends-on)) + type name weakly-depends-on)) (unless (listp components) (sysdef-error-component ":components must be NIL or a list of components." - type name components)) + type name components)) (unless (and (listp in-order-to) (listp (car in-order-to))) (sysdef-error-component ":in-order-to must be NIL or a list of components." - type name in-order-to))) + type name in-order-to))) (defun sysdef-error-component (msg type name value) (sysdef-error (concatenate 'string msg - "~&The value specified for ~(~A~) ~A is ~W") - type name value)) + "~&The value specified for ~(~A~) ~A is ~W") + type name value)) (defun resolve-symlinks (path) #-allegro (truename path) @@ -1207,54 +1264,46 @@ output to *VERBOSE-OUT*. Returns the shell's exit code." (format *verbose-out* "; $ ~A~%" command) #+sbcl (sb-ext:process-exit-code - (sb-ext:run-program + (sb-ext:run-program #+win32 "sh" #-win32 "/bin/sh" (list "-c" command) #+win32 #+win32 :search t :input nil :output *verbose-out*)) - + #+(or cmu scl) (ext:process-exit-code - (ext:run-program + (ext:run-program "/bin/sh" (list "-c" command) :input nil :output *verbose-out*)) #+allegro (excl:run-shell-command command :input nil :output *verbose-out*) - + #+lispworks (system:call-system-showing-output command :shell-type "/bin/sh" :output-stream *verbose-out*) - - #+clisp ;XXX not exactly *verbose-out*, I know + + #+clisp ;XXX not exactly *verbose-out*, I know (ext:run-shell-command command :output :terminal :wait t) #+openmcl (nth-value 1 - (ccl:external-process-status - (ccl:run-program "/bin/sh" (list "-c" command) - :input nil :output *verbose-out* - :wait t))) + (ccl:external-process-status + (ccl:run-program "/bin/sh" (list "-c" command) + :input nil :output *verbose-out* + :wait t))) #+ecl ;; courtesy of Juan Jose Garcia Ripoll (si:system command) #-(or openmcl clisp lispworks allegro scl cmu sbcl ecl) (error "RUN-SHELL-PROGRAM not implemented for this Lisp") )) - -(defgeneric hyperdocumentation (package name doc-type)) -(defmethod hyperdocumentation ((package symbol) name doc-type) - (hyperdocumentation (find-package package) name doc-type)) - -(defun hyperdoc (name doc-type) - (hyperdocumentation (symbol-package name) name doc-type)) - (defun system-source-file (system-name) (let ((system (asdf:find-system system-name))) - (make-pathname + (make-pathname :type "asd" :name (asdf:component-name system) :defaults (asdf:component-relative-pathname system)))) @@ -1287,14 +1336,14 @@ output to *VERBOSE-OUT*. Returns the shell's exit code." (defun module-provide-asdf (name) (handler-bind ((style-warning #'muffle-warning)) (let* ((*verbose-out* (make-broadcast-stream)) - (system (asdf:find-system name nil))) - (when system - (asdf:operate 'asdf:load-op name) - t)))) + (system (asdf:find-system name nil))) + (when system + (asdf:operate 'asdf:load-op name) + t)))) (defun contrib-sysdef-search (system) (let ((home (sb-ext:posix-getenv "SBCL_HOME"))) - (when home + (when (and home (not (string= home ""))) (let* ((name (coerce-name system)) (home (truename home)) (contrib (merge-pathnames @@ -1305,18 +1354,18 @@ output to *VERBOSE-OUT*. Returns the shell's exit code." :version :newest) home))) (probe-file contrib))))) - + (pushnew '(let ((home (sb-ext:posix-getenv "SBCL_HOME"))) - (when home + (when (and home (not (string= home ""))) (merge-pathnames "site-systems/" (truename home)))) *central-registry*) - + (pushnew '(merge-pathnames ".sbcl/systems/" (user-homedir-pathname)) *central-registry*) - + (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*) (pushnew 'contrib-sysdef-search *system-definition-search-functions*)) @@ -1336,4 +1385,3 @@ output to *VERBOSE-OUT*. Returns the shell's exit code." (pushnew 'module-provide-asdf ext:*module-provider-functions*)) (provide 'asdf) - diff --git a/src/CHANGELOG b/src/CHANGELOG index cc53b4b8b..66104ebca 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -161,6 +161,8 @@ ECL 0.9k: speed settings, this leads to inline access to such slots using the precomputed location. + - ECL now ships with version 1.118 of ASDF. + * Bugs fixed: - Intel/64bits running a 32 bits operating system caused a wrong choice of diff --git a/src/lsp/config.lsp.in b/src/lsp/config.lsp.in index 57599431c..d566c44ea 100644 --- a/src/lsp/config.lsp.in +++ b/src/lsp/config.lsp.in @@ -46,7 +46,7 @@ Returns, as a string, the location of the machine on which ECL runs." (defun lisp-implementation-version () "Args:() Returns the version of your ECL as a string." - "@PACKAGE_VERSION@ (CVS 2008-05-31 01:49)") + "@PACKAGE_VERSION@ (CVS 2008-06-04 22:12)") (defun machine-type () "Args: () From 9b050098f5c3d0dd1a3f87ef3310663fb1e1ad92 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 5 Jun 2008 12:44:31 +0000 Subject: [PATCH 03/71] In methods function's type declarations, the type and the name were swapped --- src/clos/method.lsp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/clos/method.lsp b/src/clos/method.lsp index f3c5a3f19..aca955b84 100644 --- a/src/clos/method.lsp +++ b/src/clos/method.lsp @@ -82,7 +82,7 @@ (nconc (loop for name in required-parameters for type in specializers when (and (not (eq type t)) (symbolp type)) - nconc `((type ,name ,type) + nconc `((type ,type ,name) (si::no-check-type ,name))) (cdar declarations))) (method-lambda From 9788340759adb2c37f18e86bcb485699ed82ee72 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 5 Jun 2008 12:45:02 +0000 Subject: [PATCH 04/71] Export a condition for detected user interrupts (SIGINT) --- src/CHANGELOG | 3 +++ src/c/symbols_list.h | 2 ++ src/c/symbols_list2.h | 2 ++ src/clos/conditions.lsp | 7 +++++++ src/lsp/config.lsp.in | 2 +- src/lsp/top.lsp | 2 +- 6 files changed, 16 insertions(+), 2 deletions(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index 66104ebca..41b8e4fc7 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -163,6 +163,9 @@ ECL 0.9k: - ECL now ships with version 1.118 of ASDF. + - ECL exports a condition EXT:INTERACTIVE-INTERRUPT, that is signaled when the + user interrupts ECL, typically using Ctrl-C, or sending the SIGINT signal. + * Bugs fixed: - Intel/64bits running a 32 bits operating system caused a wrong choice of diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 1c656428d..44ce2d16b 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1703,5 +1703,7 @@ cl_symbols[] = { {SYS_ "HASH-EQUAL", SI_ORDINARY, si_hash_equal, -1, OBJNULL}, {SYS_ "HASH-EQUALP", SI_ORDINARY, si_hash_equalp, -1, OBJNULL}, +{EXT_ "INTERACTIVE-INTERRUPT", SI_ORDINARY, NULL, -1, OBJNULL}, + /* Tag for end of list */ {NULL, CL_ORDINARY, NULL, -1, OBJNULL}}; diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index 50cd2ce46..704b96f57 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -1703,5 +1703,7 @@ cl_symbols[] = { {SYS_ "HASH-EQUAL","si_hash_equal"}, {SYS_ "HASH-EQUALP","si_hash_equalp"}, +{EXT_ "INTERACTIVE-INTERRUPT",NULL}, + /* Tag for end of list */ {NULL,NULL}}; diff --git a/src/clos/conditions.lsp b/src/clos/conditions.lsp index 39cc779fe..02179c3bc 100644 --- a/src/clos/conditions.lsp +++ b/src/clos/conditions.lsp @@ -653,6 +653,13 @@ returns with NIL." (simple-condition-format-arguments condition) (format-error-control-string condition) (format-error-offset condition))))) + +(define-condition ext:interactive-interrupt (serious-condition) + () + (:report (lambda (condition stream) + (declare (ignore condition)) + (format stream "~&~@")))) + ))) ); nehw-lave diff --git a/src/lsp/config.lsp.in b/src/lsp/config.lsp.in index d566c44ea..3482d51af 100644 --- a/src/lsp/config.lsp.in +++ b/src/lsp/config.lsp.in @@ -46,7 +46,7 @@ Returns, as a string, the location of the machine on which ECL runs." (defun lisp-implementation-version () "Args:() Returns the version of your ECL as a string." - "@PACKAGE_VERSION@ (CVS 2008-06-04 22:12)") + "@PACKAGE_VERSION@ (CVS 2008-06-04 23:07)") (defun machine-type () "Args: () diff --git a/src/lsp/top.lsp b/src/lsp/top.lsp index 60a0d9faf..c01bb3e8e 100644 --- a/src/lsp/top.lsp +++ b/src/lsp/top.lsp @@ -375,7 +375,7 @@ under certain conditions; see file 'Copyright' for details.") (defun terminal-interrupt (correctablep) (let ((*break-enable* t)) (if correctablep - (cerror "Continues execution." "Console interrupt.") + (cerror "Continues execution." 'ext:interactive-interrupt) (error "Console interrupt -- cannot continue.")))) (defun tpl (&key ((:commands *tpl-commands*) tpl-commands) From 980b6d68b47b19007a9197607d7a0cfccaa85f3a Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 14:56:24 +0000 Subject: [PATCH 05/71] The interpreter is rewritten using indirect threaded code --- src/CHANGELOG | 2 + src/c/interpreter.d | 290 +++++++++++++++++++++++--------------------- src/h/bytecodes.h | 109 +++++++++++++++++ 3 files changed, 262 insertions(+), 139 deletions(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index 41b8e4fc7..7ba19d149 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -247,6 +247,8 @@ ECL 0.9k: - TYPEP now can be optimized if the type argument is a constant. + - ECL's bytecode interpreter now uses indirect threading. + * System design: - We introduce a new kind of lisp objects, the stack frames. These are objects diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 2c8cf4668..5831c2820 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -630,93 +630,100 @@ interpret_progv(cl_object bytecodes, cl_opcode *vector) { } void * -ecl_interpret(cl_object bytecodes, void *pc) { +ecl_interpret(cl_object bytecodes, void *pc) +{ + ECL_OFFSET_TABLE; cl_opcode *vector = pc; cl_object reg0 = VALUES(0), reg1; static int i = 0; i++; BEGIN: - switch (GET_OPCODE(vector)) { + BEGIN_SWITCH { + CASE(OP_NOP); { + VALUES(0) = reg0 = Cnil; + NVALUES = 0; + NEXT; + } /* OP_QUOTE Sets REG0 to an immediate value. */ - case OP_QUOTE: + CASE(OP_QUOTE); { reg0 = GET_DATA(vector, bytecodes); - break; - + NEXT; + } /* OP_VAR n{arg}, var{symbol} Sets REG0 to the value of the n-th local. VAR is the name of the variable for readability purposes. */ - case OP_VAR: { + CASE(OP_VAR); { int lex_env_index = GET_OPARG(vector); reg0 = ecl_lex_env_get_var(lex_env_index); - break; + NEXT; } /* OP_VARS var{symbol} Sets REG0 to the value of the symbol VAR. VAR should be either a special variable or a constant. */ - case OP_VARS: { + CASE(OP_VARS); { cl_object var_name = GET_DATA(vector, bytecodes); reg0 = search_global(var_name); - break; + NEXT; } /* OP_PUSH Pushes the object in VALUES(0). */ - case OP_PUSH: + CASE(OP_PUSH); { cl_stack_push(reg0); - break; - + NEXT; + } /* OP_PUSHV n{arg} Pushes the value of the n-th local onto the stack. */ - case OP_PUSHV: { + CASE(OP_PUSHV); { int lex_env_index = GET_OPARG(vector); cl_stack_push(ecl_lex_env_get_var(lex_env_index)); - break; + NEXT; } /* OP_PUSHVS var{symbol} Pushes the value of the symbol VAR onto the stack. VAR should be either a special variable or a constant. */ - case OP_PUSHVS: { + CASE(OP_PUSHVS); { cl_object var_name = GET_DATA(vector, bytecodes); cl_stack_push(search_global(var_name)); - break; + NEXT; } /* OP_PUSHQ value{object} Pushes "value" onto the stack. */ - case OP_PUSHQ: + CASE(OP_PUSHQ); { cl_stack_push(GET_DATA(vector, bytecodes)); - break; - + NEXT; + } /* OP_CALL n{arg} Calls the function in REG0 with N arguments which have been deposited in the stack. The output values are left in VALUES(...) */ - case OP_CALL: { + CASE(OP_CALL); { cl_fixnum n = GET_OPARG(vector); VALUES(0) = reg0 = interpret_funcall(n, reg0); - break; + NEXT; } /* OP_CALLG n{arg}, name{arg} Calls the function NAME with N arguments which have been deposited in the stack. The output values are left in VALUES. */ - case OP_CALLG: { + CASE(OP_CALLG); { cl_fixnum n = GET_OPARG(vector); cl_object f = GET_DATA(vector, bytecodes); VALUES(0) = reg0 = interpret_funcall(n, f); - break; + NEXT; } /* OP_FCALL n{arg} @@ -724,24 +731,24 @@ ecl_interpret(cl_object bytecodes, void *pc) { have been also deposited in the stack. The output values are left in VALUES(...) */ - case OP_FCALL: { + CASE(OP_FCALL); { cl_fixnum n = GET_OPARG(vector); cl_object fun = cl_env.stack_top[-n-1]; VALUES(0) = reg0 = interpret_funcall(n, fun); cl_stack_pop(); - break; + NEXT; } /* OP_MCALL Similar to FCALL, but gets the number of arguments from the stack (They all have been deposited by OP_PUSHVALUES) */ - case OP_MCALL: { + CASE(OP_MCALL); { cl_fixnum n = fix(cl_stack_pop()); cl_object fun = cl_env.stack_top[-n-1]; VALUES(0) = reg0 = interpret_funcall(n, fun); cl_stack_pop(); - break; + NEXT; } /* OP_PCALL n{arg} @@ -749,10 +756,10 @@ ecl_interpret(cl_object bytecodes, void *pc) { have been deposited in the stack. The first output value is pushed on the stack. */ - case OP_PCALL: { + CASE(OP_PCALL); { cl_fixnum n = GET_OPARG(vector); cl_stack_push(interpret_funcall(n, reg0)); - break; + NEXT; } /* OP_PCALLG n{arg}, name{arg} @@ -760,11 +767,11 @@ ecl_interpret(cl_object bytecodes, void *pc) { deposited in the stack. The first output value is pushed on the stack. */ - case OP_PCALLG: { + CASE(OP_PCALLG); { cl_fixnum n = GET_OPARG(vector); cl_object f = GET_DATA(vector, bytecodes); cl_stack_push(interpret_funcall(n, f)); - break; + NEXT; } /* OP_PFCALL n{arg} @@ -772,37 +779,38 @@ ecl_interpret(cl_object bytecodes, void *pc) { have been also deposited in the stack. The first output value is pushed on the stack. */ - case OP_PFCALL: { + CASE(OP_PFCALL); { cl_fixnum n = GET_OPARG(vector); cl_object fun = cl_env.stack_top[-n-1]; cl_object reg0 = interpret_funcall(n, fun); cl_env.stack_top[-1] = reg0; - break; + NEXT; } /* OP_EXIT Marks the end of a high level construct (BLOCK, CATCH...) or a function. */ - case OP_EXIT: + CASE(OP_EXIT); { return (char *)vector; - - case OP_FLET: + } + CASE(OP_FLET); { vector = interpret_flet(bytecodes, vector); - break; - case OP_LABELS: + NEXT; + } + CASE(OP_LABELS); { vector = interpret_labels(bytecodes, vector); - break; - + NEXT; + } /* OP_LFUNCTION n{arg}, function-name{symbol} Calls the local or global function with N arguments which have been deposited in the stack. */ - case OP_LFUNCTION: { + CASE(OP_LFUNCTION); { int lex_env_index = GET_OPARG(vector); cl_object fun_record = ecl_lex_env_get_record(lex_env_index); reg0 = CAR(fun_record); - break; + NEXT; } /* OP_FUNCTION name{symbol} @@ -810,19 +818,19 @@ ecl_interpret(cl_object bytecodes, void *pc) { may be defined in the global environment or in the local environment. This last value takes precedence. */ - case OP_FUNCTION: + CASE(OP_FUNCTION); reg0 = ecl_fdefinition(GET_DATA(vector, bytecodes)); - break; + NEXT; /* OP_CLOSE name{symbol} Extracts the function associated to a symbol. The function may be defined in the global environment or in the local environment. This last value takes precedence. */ - case OP_CLOSE: { + CASE(OP_CLOSE); { cl_object function_object = GET_DATA(vector, bytecodes); reg0 = close_around(function_object, cl_env.lex_env); - break; + NEXT; } /* OP_GO n{arg} OP_QUOTE tag-name{symbol} @@ -830,33 +838,33 @@ ecl_interpret(cl_object bytecodes, void *pc) { the lexical environment. TAG-NAME is kept for debugging purposes. */ - case OP_GO: { + CASE(OP_GO); { cl_object id = ecl_lex_env_get_tag(GET_OPARG(vector)); cl_object tag_name = GET_DATA(vector, bytecodes); cl_go(id, tag_name); - break; + NEXT; } /* OP_RETURN n{arg} Returns from the block whose record in the lexical environment occuppies the n-th position. */ - case OP_RETURN: { + CASE(OP_RETURN); { int lex_env_index = GET_OPARG(vector); cl_object block_record = ecl_lex_env_get_record(lex_env_index); cl_object id = CAR(block_record); cl_object block_name = CDR(block_record); cl_return_from(id, block_name); - break; + NEXT; } /* OP_THROW Jumps to an enclosing CATCH form whose tag matches the one of the THROW. The tag is taken from the stack, while the output values are left in VALUES(...). */ - case OP_THROW: { + CASE(OP_THROW); { cl_object tag_name = cl_stack_pop(); cl_throw(tag_name); - break; + NEXT; } /* OP_JMP label{arg} OP_JNIL label{arg} @@ -866,58 +874,59 @@ ecl_interpret(cl_object bytecodes, void *pc) { Direct or conditional jumps. The conditional jumps are made comparing with the value of REG0. */ - case OP_JMP: { + CASE(OP_JMP); { cl_oparg jump = GET_OPARG(vector); vector += jump - OPARG_SIZE; - break; + NEXT; } - case OP_JNIL: { + CASE(OP_JNIL); { cl_oparg jump = GET_OPARG(vector); NVALUES = 1; if (Null(VALUES(0))) vector += jump - OPARG_SIZE; - break; + NEXT; } - case OP_JT: { + CASE(OP_JT); { cl_oparg jump = GET_OPARG(vector); NVALUES = 1; if (!Null(VALUES(0))) vector += jump - OPARG_SIZE; - break; + NEXT; } - case OP_JEQL: { + CASE(OP_JEQL); { cl_oparg value = GET_OPARG(vector); cl_oparg jump = GET_OPARG(vector); if (ecl_eql(reg0, bytecodes->bytecodes.data[value])) vector += jump - OPARG_SIZE; - break; + NEXT; } - case OP_JNEQL: { + CASE(OP_JNEQL); { cl_oparg value = GET_OPARG(vector); cl_oparg jump = GET_OPARG(vector); if (!ecl_eql(reg0, bytecodes->bytecodes.data[value])) vector += jump - OPARG_SIZE; - break; + NEXT; } - case OP_NOT: + CASE(OP_NOT); { reg0 = (reg0 == Cnil)? Ct : Cnil; - break; + NEXT; + } /* OP_UNBIND n{arg} Undo "n" local bindings. */ - case OP_UNBIND: { + CASE(OP_UNBIND); { cl_index n = GET_OPARG(vector); while (n--) cl_env.lex_env = CDR(cl_env.lex_env); - break; + NEXT; } /* OP_UNBINDS n{arg} Undo "n" bindings of special variables. */ - case OP_UNBINDS: { + CASE(OP_UNBINDS); { cl_index n = GET_OPARG(vector); bds_unwind_n(n); - break; + NEXT; } /* OP_BIND name{symbol} OP_PBIND name{symbol} @@ -926,41 +935,41 @@ ecl_interpret(cl_object bytecodes, void *pc) { Binds a lexical or special variable to the either the value of REG0 or the first value of the stack. */ - case OP_BIND: { + CASE(OP_BIND); { cl_object var_name = GET_DATA(vector, bytecodes); bind_var(var_name, reg0); - break; + NEXT; } - case OP_PBIND: { + CASE(OP_PBIND); { cl_object var_name = GET_DATA(vector, bytecodes); cl_object value = cl_stack_pop(); bind_var(var_name, value); - break; + NEXT; } - case OP_VBIND: { + CASE(OP_VBIND); { cl_index n = GET_OPARG(vector); cl_object var_name = GET_DATA(vector, bytecodes); cl_object value = (n < NVALUES) ? VALUES(n) : Cnil; bind_var(var_name, value); - break; + NEXT; } - case OP_BINDS: { + CASE(OP_BINDS); { cl_object var_name = GET_DATA(vector, bytecodes); bds_bind(var_name, reg0); - break; + NEXT; } - case OP_PBINDS: { + CASE(OP_PBINDS); { cl_object var_name = GET_DATA(vector, bytecodes); cl_object value = cl_stack_pop(); bds_bind(var_name, value); - break; + NEXT; } - case OP_VBINDS: { + CASE(OP_VBINDS); { cl_index n = GET_OPARG(vector); cl_object var_name = GET_DATA(vector, bytecodes); cl_object value = (n < NVALUES) ? VALUES(n) : Cnil; bds_bind(var_name, value); - break; + NEXT; } /* OP_SETQ n{arg} OP_PSETQ n{arg} @@ -970,31 +979,31 @@ ecl_interpret(cl_object bytecodes, void *pc) { to either the value in REG0 (OP_SETQ[S]) or to the first value on the stack (OP_PSETQ[S]). */ - case OP_SETQ: { + CASE(OP_SETQ); { int lex_env_index = GET_OPARG(vector); ecl_lex_env_set_var(lex_env_index, reg0); - break; + NEXT; } - case OP_SETQS: { + CASE(OP_SETQS); { cl_object var = GET_DATA(vector, bytecodes); /* INV: Not NIL, and of type t_symbol */ if (var->symbol.stype & stp_constant) FEassignment_to_constant(var); ECL_SETQ(var, reg0); - break; + NEXT; } - case OP_PSETQ: { + CASE(OP_PSETQ); { int lex_env_index = GET_OPARG(vector); ecl_lex_env_set_var(lex_env_index, cl_stack_pop()); - break; + NEXT; } - case OP_PSETQS: { + CASE(OP_PSETQS); { cl_object var = GET_DATA(vector, bytecodes); /* INV: Not NIL, and of type t_symbol */ if (var->symbol.stype & stp_constant) FEassignment_to_constant(var); ECL_SETQ(var, cl_stack_pop()); - break; + NEXT; } /* OP_BLOCK label{arg} @@ -1005,10 +1014,11 @@ ecl_interpret(cl_object bytecodes, void *pc) { Executes the enclosed code in a named block. LABEL points to the first instruction after OP_EXIT. */ - case OP_BLOCK: + CASE(OP_BLOCK); { reg0 = GET_DATA(vector, bytecodes); reg1 = new_frame_id(); goto DO_BLOCK; + } /* OP_CATCH label{arg} ... OP_EXIT_FRAME @@ -1017,9 +1027,10 @@ ecl_interpret(cl_object bytecodes, void *pc) { Sets a catch point using the tag in VALUES(0). LABEL points to the first instruction after the end (OP_EXIT) of the block */ - case OP_CATCH: + CASE(OP_CATCH); { reg1 = reg0; goto DO_BLOCK; + } /* OP_DO label ... ; code executed within a NIL block OP_EXIT_FRAME @@ -1027,9 +1038,10 @@ ecl_interpret(cl_object bytecodes, void *pc) { High level construct for the DO and BLOCK forms. */ - case OP_DO: + CASE(OP_DO); { reg0 = Cnil; reg1 = new_frame_id(); + } DO_BLOCK: { cl_opcode *exit; GET_LABEL(exit, vector); @@ -1042,14 +1054,15 @@ ecl_interpret(cl_object bytecodes, void *pc) { frs_pop(); vector = (cl_opcode *)cl_stack_pop(); /* FIXME! */ } - break; - } - case OP_EXIT_FRAME: + NEXT; + } + CASE(OP_EXIT_FRAME); { bds_unwind(cl_env.frs_top->frs_bds_top); cl_env.lex_env = cl_env.frs_top->frs_lex; frs_pop(); cl_stack_pop(); - break; + NEXT; + } /* OP_TAGBODY n{arg} label1 ... @@ -1062,7 +1075,7 @@ ecl_interpret(cl_object bytecodes, void *pc) { High level construct for the TAGBODY form. */ - case OP_TAGBODY: { + CASE(OP_TAGBODY); { cl_object id = new_frame_id(); int n = GET_OPARG(vector); /* Here we save the location of the jump table */ @@ -1083,67 +1096,70 @@ ecl_interpret(cl_object bytecodes, void *pc) { vector = table + *(cl_oparg *)table; cl_env.lex_env = cl_env.frs_top->frs_lex; } - break; + NEXT; } - case OP_EXIT_TAGBODY: + CASE(OP_EXIT_TAGBODY); { cl_env.lex_env = CDR(cl_env.frs_top->frs_lex); frs_pop(); cl_stack_pop(); - case OP_NIL: + } + CASE(OP_NIL); { reg0 = Cnil; - break; - case OP_PUSHNIL: + NEXT; + } + CASE(OP_PUSHNIL); { cl_stack_push(Cnil); - break; - case OP_VALUEREG0: + NEXT; + } + CASE(OP_VALUEREG0); { VALUES(0) = reg0; NVALUES = 1; - break; - case OP_NOP: - VALUES(0) = reg0 = Cnil; - NVALUES = 0; - break; - case OP_MSETQ: + NEXT; + } + CASE(OP_MSETQ); { vector = interpret_msetq(bytecodes, vector); reg0 = VALUES(0); - break; - case OP_PROGV: + NEXT; + } + CASE(OP_PROGV); { vector = interpret_progv(bytecodes, vector); reg0 = VALUES(0); - break; + NEXT; + } /* OP_PUSHVALUES Pushes the values output by the last form, plus the number of values. */ PUSH_VALUES: - case OP_PUSHVALUES: { + CASE(OP_PUSHVALUES); { cl_index i; for (i=0; ifrs_bds_top); cl_env.lex_env = cl_env.frs_top->frs_lex; frs_pop(); cl_stack_pop(); cl_stack_push(MAKE_FIXNUM(1)); goto PUSH_VALUES; - case OP_PROTECT_EXIT: { + } + CASE(OP_PROTECT_EXIT); { volatile cl_fixnum n = NVALUES = fix(cl_stack_pop()); while (n--) VALUES(n) = cl_stack_pop(); @@ -1221,9 +1238,9 @@ ecl_interpret(cl_object bytecodes, void *pc) { n = fix(cl_stack_pop()); if (n <= 0) ecl_unwind(cl_env.frs_top + n); - break; + NEXT; } - case OP_STEPIN: { + CASE(OP_STEPIN); { cl_object form = GET_DATA(vector, bytecodes); cl_object a = SYM_VAL(@'si::*step-action*'); cl_index n = cl_stack_push_values(); @@ -1244,9 +1261,9 @@ ecl_interpret(cl_object bytecodes, void *pc) { * actually never happen. */ } cl_stack_pop_values(n); - break; + NEXT; } - case OP_STEPCALL: { + CASE(OP_STEPCALL); { /* We are going to call a function. However, we would * like to step _in_ the function. STEPPER takes care of * that. */ @@ -1257,7 +1274,7 @@ ecl_interpret(cl_object bytecodes, void *pc) { } reg0 = interpret_funcall(n, reg0); } - case OP_STEPOUT: { + CASE(OP_STEPOUT); { cl_object a = SYM_VAL(@'si::*step-action*'); cl_index n = cl_stack_push_values(); if (a == Ct) { @@ -1274,14 +1291,9 @@ ecl_interpret(cl_object bytecodes, void *pc) { /* Not stepping, nothing to be done. */ } cl_stack_pop_values(n); - break; + NEXT; } - - default: - FEerror("Internal error: Unknown code ~S", - 1, MAKE_FIXNUM(*(vector-1))); } - goto BEGIN; } @(defun si::interpreter_stack () diff --git a/src/h/bytecodes.h b/src/h/bytecodes.h index 21e49ecda..853355123 100644 --- a/src/h/bytecodes.h +++ b/src/h/bytecodes.h @@ -1,4 +1,11 @@ /* -*- mode: c; c-basic-offset: 8 -*- */ +/********************************************************************** + *** + *** IMPORTANT: ANY CHANGE IN THIS FILE MUST BE MATCHED BY + *** APPROPRIATE CHANGES IN THE INTERPRETER AND COMPILER + *** IN PARTICULAR, IT MAY HURT THE THREADED INTERPRETER + *** CODE. + **********************************************************************/ /* OP_BLOCK block-name{obj} ... @@ -203,3 +210,105 @@ typedef int16_t cl_oparg; #define GET_OPARG(v) (*((cl_oparg *)(v)++)) #define GET_DATA(v,b) (b->bytecodes.data[GET_OPARG(v)]) #define GET_LABEL(pc,v) {pc = (v) + READ_OPARG(v); v += OPARG_SIZE;} + +/********************************************************************** + * THREADED INTERPRETER CODE + * + * By using labels as values, we can build a variant of the + * interpreter code that leads to better performance because (i) it + * saves a range check on the opcode size and (ii) each opcode has a + * dispatch instruction at the end, so that the processor may better + * predict jumps. + */ +#if (defined(__GNUC__) && !defined(__STRICT_ANSI__)) +#define ECL_THREADED_INTERPRETER +#endif + +#ifdef ECL_THREADED_INTERPRETER +#define BEGIN_SWITCH \ + NEXT; +#define CASE(name) \ + LBL_##name: +#define NEXT \ + goto *(&&LBL_OP_NOP + offsets[GET_OPCODE(vector)]) +#else +#define BEGIN_SWITCH \ + switch (GET_OPCODE(vector)) +#define NEXT \ + goto BEGIN +#define CASE(name) \ + case name: +#endif + +#if !defined(ECL_THREADED_INTERPRETER) +#define ECL_OFFSET_TABLE +#else +#define ECL_OFFSET_TABLE \ + static const int offsets[] = {\ + &&LBL_OP_NOP - &&LBL_OP_NOP,\ + &&LBL_OP_QUOTE - &&LBL_OP_NOP,\ + &&LBL_OP_VAR - &&LBL_OP_NOP,\ + &&LBL_OP_VARS - &&LBL_OP_NOP,\ + &&LBL_OP_PUSH - &&LBL_OP_NOP,\ + &&LBL_OP_PUSHV - &&LBL_OP_NOP,\ + &&LBL_OP_PUSHVS - &&LBL_OP_NOP,\ + &&LBL_OP_PUSHQ - &&LBL_OP_NOP,\ + &&LBL_OP_CALLG - &&LBL_OP_NOP,\ + &&LBL_OP_CALL - &&LBL_OP_NOP,\ + &&LBL_OP_FCALL - &&LBL_OP_NOP,\ + &&LBL_OP_PCALLG - &&LBL_OP_NOP,\ + &&LBL_OP_PCALL - &&LBL_OP_NOP,\ + &&LBL_OP_PFCALL - &&LBL_OP_NOP,\ + &&LBL_OP_MCALL - &&LBL_OP_NOP,\ + &&LBL_OP_EXIT - &&LBL_OP_NOP,\ + &&LBL_OP_FLET - &&LBL_OP_NOP,\ + &&LBL_OP_LABELS - &&LBL_OP_NOP,\ + &&LBL_OP_LFUNCTION - &&LBL_OP_NOP,\ + &&LBL_OP_FUNCTION - &&LBL_OP_NOP,\ + &&LBL_OP_CLOSE - &&LBL_OP_NOP,\ + &&LBL_OP_GO - &&LBL_OP_NOP,\ + &&LBL_OP_RETURN - &&LBL_OP_NOP,\ + &&LBL_OP_THROW - &&LBL_OP_NOP,\ + &&LBL_OP_JMP - &&LBL_OP_NOP,\ + &&LBL_OP_JNIL - &&LBL_OP_NOP,\ + &&LBL_OP_JT - &&LBL_OP_NOP,\ + &&LBL_OP_JEQL - &&LBL_OP_NOP,\ + &&LBL_OP_JNEQL - &&LBL_OP_NOP,\ + &&LBL_OP_UNBIND - &&LBL_OP_NOP,\ + &&LBL_OP_UNBINDS - &&LBL_OP_NOP,\ + &&LBL_OP_BIND - &&LBL_OP_NOP,\ + &&LBL_OP_PBIND - &&LBL_OP_NOP,\ + &&LBL_OP_VBIND - &&LBL_OP_NOP,\ + &&LBL_OP_BINDS - &&LBL_OP_NOP,\ + &&LBL_OP_PBINDS - &&LBL_OP_NOP,\ + &&LBL_OP_VBINDS - &&LBL_OP_NOP,\ + &&LBL_OP_SETQ - &&LBL_OP_NOP,\ + &&LBL_OP_SETQS - &&LBL_OP_NOP,\ + &&LBL_OP_PSETQ - &&LBL_OP_NOP,\ + &&LBL_OP_PSETQS - &&LBL_OP_NOP,\ + &&LBL_OP_BLOCK - &&LBL_OP_NOP,\ + &&LBL_OP_DO - &&LBL_OP_NOP,\ + &&LBL_OP_CATCH - &&LBL_OP_NOP,\ + &&LBL_OP_TAGBODY - &&LBL_OP_NOP,\ + &&LBL_OP_EXIT_TAGBODY - &&LBL_OP_NOP,\ + &&LBL_OP_EXIT_FRAME - &&LBL_OP_NOP,\ + &&LBL_OP_PROTECT - &&LBL_OP_NOP,\ + &&LBL_OP_PROTECT_NORMAL - &&LBL_OP_NOP,\ + &&LBL_OP_PROTECT_EXIT - &&LBL_OP_NOP,\ + &&LBL_OP_MSETQ - &&LBL_OP_NOP,\ + &&LBL_OP_PROGV - &&LBL_OP_NOP,\ + &&LBL_OP_PUSHVALUES - &&LBL_OP_NOP,\ + &&LBL_OP_POP - &&LBL_OP_NOP,\ + &&LBL_OP_POPVALUES - &&LBL_OP_NOP,\ + &&LBL_OP_PUSHMOREVALUES - &&LBL_OP_NOP,\ + &&LBL_OP_VALUES - &&LBL_OP_NOP,\ + &&LBL_OP_VALUEREG0 - &&LBL_OP_NOP,\ + &&LBL_OP_NTHVAL - &&LBL_OP_NOP,\ + &&LBL_OP_NIL - &&LBL_OP_NOP,\ + &&LBL_OP_NOT - &&LBL_OP_NOP,\ + &&LBL_OP_PUSHNIL - &&LBL_OP_NOP,\ + &&LBL_OP_STEPIN - &&LBL_OP_NOP,\ + &&LBL_OP_STEPCALL - &&LBL_OP_NOP,\ + &&LBL_OP_STEPOUT - &&LBL_OP_NOP\ + } +#endif From 734d3edadb0c9093457829d01a9ddf9f9f361adc Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 14:56:47 +0000 Subject: [PATCH 06/71] All functions that operate on the lexical environment take a generic environment as argument, not inspecting cl_env. --- src/c/interpreter.d | 253 ++++++++++++++++++++++---------------------- 1 file changed, 127 insertions(+), 126 deletions(-) diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 5831c2820..155868e5d 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -277,38 +277,38 @@ ecl_stack_frame_copy(cl_object dest, cl_object orig) /* ------------------------------ LEXICAL ENV. ------------------------------ */ -#define bind_var(var, val) \ - (cl_env.lex_env = CONS(CONS(var, val), cl_env.lex_env)) -#define bind_function(name, fun) \ - (cl_env.lex_env = CONS(CONS(fun, name), cl_env.lex_env)) -#define bind_block(name, id) \ - (cl_env.lex_env = CONS(CONS(id, name), cl_env.lex_env)) -#define bind_tagbody(id) \ - (cl_env.lex_env = CONS(CONS(id, MAKE_FIXNUM(0)), cl_env.lex_env)) +#define bind_var(env, var, val) CONS(CONS(var, val), (env)) +#define bind_function(env, name, fun) CONS(CONS(fun, name), (env)) +#define bind_tagbody(env, id) CONS(CONS(id, MAKE_FIXNUM(0)), (env)) -static cl_object -ecl_lex_env_get_record(register int s) { - cl_object x; - for (x = cl_env.lex_env; s-- > 0; x = CDR(x)); - if (Null(x)) - FEerror("Internal error: local not found.", 0); - return CAR(x); +static void +internal_lex_env_error() +{ + FEerror("Internal error: local not found.", 0); } -#define ecl_lex_env_get_var(x) ECL_CONS_CDR(ecl_lex_env_get_record(x)) -#define ecl_lex_env_set_var(x,v) ECL_RPLACD(ecl_lex_env_get_record(x),(v)) -#define ecl_lex_env_get_fun(x) ECL_CONS_CAR(ecl_lex_env_get_record(x)) -#define ecl_lex_env_get_tag(x) ECL_CONS_CAR(ecl_lex_env_get_record(x)) +static cl_object +ecl_lex_env_get_record(register cl_object env, register int s) { + for (; s-- > 0; env = CDR(env)); + if (Null(env)) internal_lex_env_error(); + return CAR(env); +} + +#define ecl_lex_env_get_var(env,x) ECL_CONS_CDR(ecl_lex_env_get_record(env,x)) +#define ecl_lex_env_set_var(env,x,v) ECL_RPLACD(ecl_lex_env_get_record(env,x),(v)) +#define ecl_lex_env_get_fun(env,x) ECL_CONS_CAR(ecl_lex_env_get_record(env,x)) +#define ecl_lex_env_get_tag(env,x) ECL_CONS_CAR(ecl_lex_env_get_record(env,x)) /* -------------------- LAMBDA FUNCTIONS -------------------- */ -static void -lambda_bind_var(cl_object var, cl_object val, cl_object specials) +static cl_object +lambda_bind_var(cl_object env, cl_object var, cl_object val, cl_object specials) { if (!ecl_member_eq(var, specials)) - bind_var(var, val); + env = bind_var(env, var, val); else bds_bind(var, val); + return env; } static void @@ -322,114 +322,115 @@ lambda_bind(cl_narg narg, cl_object lambda, cl_object *sp) /* 1) REQUIRED ARGUMENTS: N var1 ... varN */ n = fix(*(data++)); if (narg < n) - FEwrong_num_arguments(lambda->bytecodes.name); + FEwrong_num_arguments(lambda->bytecodes.name); for (; n; n--, narg--) - lambda_bind_var(*(data++), *(sp++), specials); + cl_env.lex_env = lambda_bind_var(cl_env.lex_env, *(data++), *(sp++), specials); /* 2) OPTIONAL ARGUMENTS: N var1 value1 flag1 ... varN valueN flagN */ for (n = fix(*(data++)); n; n--, data+=3) { - if (narg) { - lambda_bind_var(data[0], *sp, specials); - sp++; narg--; - if (!Null(data[2])) - lambda_bind_var(data[2], Ct, specials); - } else { - cl_object defaults = data[1]; - if (FIXNUMP(defaults)) { - ecl_interpret(lambda, (cl_opcode*)lambda->bytecodes.code + fix(defaults)); - defaults = VALUES(0); - } - lambda_bind_var(data[0], defaults, specials); - if (!Null(data[2])) - lambda_bind_var(data[2], Cnil, specials); - } + if (narg) { + cl_env.lex_env = lambda_bind_var(cl_env.lex_env, data[0], *sp, specials); + sp++; narg--; + if (!Null(data[2])) + cl_env.lex_env = lambda_bind_var(cl_env.lex_env, data[2], Ct, specials); + } else { + cl_object defaults = data[1]; + if (FIXNUMP(defaults)) { + ecl_interpret(lambda, (cl_opcode*)lambda->bytecodes.code + fix(defaults)); + defaults = VALUES(0); + } + cl_env.lex_env = lambda_bind_var(cl_env.lex_env, data[0], defaults, specials); + if (!Null(data[2])) + cl_env.lex_env = lambda_bind_var(cl_env.lex_env, data[2], Cnil, specials); + } } - + /* 3) REST ARGUMENT: {rest-var | NIL} */ if (!Null(data[0])) { - cl_object rest = Cnil; - check_remaining = FALSE; - for (i=narg; i; ) - rest = CONS(sp[--i], rest); - lambda_bind_var(data[0], rest, specials); + cl_object rest = Cnil; + check_remaining = FALSE; + for (i=narg; i; ) + rest = CONS(sp[--i], rest); + cl_env.lex_env = lambda_bind_var(cl_env.lex_env, data[0], rest, specials); } data++; /* 4) ALLOW-OTHER-KEYS: { T | NIL | 0} */ if (data[0] == MAKE_FIXNUM(0)) { - data++; - if (narg && check_remaining) - FEprogram_error("LAMBDA: Too many arguments to function ~S.", 1, - lambda->bytecodes.name); + data++; + if (narg && check_remaining) + FEprogram_error("LAMBDA: Too many arguments to function ~S.", 1, + lambda->bytecodes.name); } else { - /* - * Only when ALLOW-OTHER-KEYS /= 0, we process this: - * 5) KEYWORDS: N key1 var1 value1 flag1 ... keyN varN valueN flagN - */ - bool allow_other_keys = !Null(*(data++)); - bool allow_other_keys_found = allow_other_keys; - int n = fix(*(data++)); - cl_object *keys; + /* + * Only when ALLOW-OTHER-KEYS /= 0, we process this: + * 5) KEYWORDS: N key1 var1 value1 flag1 ... keyN varN valueN flagN + */ + bool allow_other_keys = !Null(*(data++)); + bool allow_other_keys_found = allow_other_keys; + int n = fix(*(data++)); + cl_object *keys; #ifdef __GNUC__ - cl_object spp[n]; + cl_object spp[n]; #else #define SPP_MAX 64 - cl_object spp[SPP_MAX]; + cl_object spp[SPP_MAX]; #endif - bool other_found = FALSE; - void *unbound = spp; /* not a valid lisp object */ - if ((narg & 1) != 0) - FEprogram_error("Function called with odd number of keyword arguments.", 0); - for (i=0; i= SPP_MAX) - FEerror("lambda_bind: Too many keyword arguments, limited to ~A.", 1, MAKE_FIXNUM(SPP_MAX)); - else - spp[i] = unbound; + if (i >= SPP_MAX) + FEerror("lambda_bind: Too many keyword arguments, limited to ~A.", 1, MAKE_FIXNUM(SPP_MAX)); + else + spp[i] = unbound; #endif - for (; narg; narg-=2) { - cl_object key = *(sp++); - cl_object value = *(sp++); - if (!SYMBOLP(key)) - FEprogram_error("LAMBDA: Keyword expected, got ~S.", 1, key); - keys = data; - if (key == @':allow-other-keys') { - if (!allow_other_keys_found) { - allow_other_keys_found = TRUE; - allow_other_keys = !Null(value); - } - } - for (i = 0; i < n; i++, keys += 4) { - if (key == keys[0]) { - if (spp[i] == unbound) - spp[i] = value; - goto FOUND; - } - } - if (key != @':allow-other-keys') - other_found = TRUE; - FOUND: - (void)0; - } - if (other_found && !allow_other_keys) - FEprogram_error("LAMBDA: Unknown keys found in function ~S.", - 1, lambda->bytecodes.name); - for (i=0; ibytecodes.code + fix(defaults)); - defaults = VALUES(0); - } - lambda_bind_var(data[1],defaults,specials); - } - if (!Null(data[3])) - lambda_bind_var(data[3],(spp[i] != unbound)? Ct : Cnil,specials); - } + for (; narg; narg-=2) { + cl_object key = *(sp++); + cl_object value = *(sp++); + if (!SYMBOLP(key)) + FEprogram_error("LAMBDA: Keyword expected, got ~S.", 1, key); + keys = data; + if (key == @':allow-other-keys') { + if (!allow_other_keys_found) { + allow_other_keys_found = TRUE; + allow_other_keys = !Null(value); + } + } + for (i = 0; i < n; i++, keys += 4) { + if (key == keys[0]) { + if (spp[i] == unbound) + spp[i] = value; + goto FOUND; + } + } + if (key != @':allow-other-keys') + other_found = TRUE; + FOUND: + (void)0; + } + if (other_found && !allow_other_keys) { + FEprogram_error("LAMBDA: Unknown keys found in function ~S.", + 1, lambda->bytecodes.name); + } + for (i=0; ibytecodes.code + fix(defaults)); + defaults = VALUES(0); + } + cl_env.lex_env = lambda_bind_var(cl_env.lex_env, data[1],defaults,specials); + } + if (!Null(data[3])) + cl_env.lex_env = lambda_bind_var(cl_env.lex_env, data[3],(spp[i] != unbound)? Ct : Cnil,specials); + } } } @@ -525,7 +526,7 @@ interpret_flet(cl_object bytecodes, cl_opcode *vector) { while (nfun--) { cl_object fun = GET_DATA(vector, bytecodes); cl_object f = close_around(fun,lex); - bind_function(f->bytecodes.name, f); + cl_env.lex_env = bind_function(cl_env.lex_env, f->bytecodes.name, f); } return vector; } @@ -548,7 +549,7 @@ interpret_labels(cl_object bytecodes, cl_opcode *vector) { /* 1) Build up a new environment with all functions */ for (i=0; ibytecodes.name, f); + cl_env.lex_env = bind_function(cl_env.lex_env, f->bytecodes.name, f); } /* 2) Update the closures so that all functions can call each other */ @@ -579,9 +580,9 @@ interpret_msetq(cl_object bytecodes, cl_opcode *vector) for (i=0; i= 0) - ecl_lex_env_set_var(var, value); - else { + if (var >= 0) { + ecl_lex_env_set_var(cl_env.lex_env, var, value); + } else { cl_object name = bytecodes->bytecodes.data[-1-var]; if (Null(name) || (name->symbol.stype & stp_constant)) FEassignment_to_constant(name); @@ -657,7 +658,7 @@ ecl_interpret(cl_object bytecodes, void *pc) */ CASE(OP_VAR); { int lex_env_index = GET_OPARG(vector); - reg0 = ecl_lex_env_get_var(lex_env_index); + reg0 = ecl_lex_env_get_var(cl_env.lex_env, lex_env_index); NEXT; } @@ -683,7 +684,7 @@ ecl_interpret(cl_object bytecodes, void *pc) */ CASE(OP_PUSHV); { int lex_env_index = GET_OPARG(vector); - cl_stack_push(ecl_lex_env_get_var(lex_env_index)); + cl_stack_push(ecl_lex_env_get_var(cl_env.lex_env, lex_env_index)); NEXT; } @@ -808,7 +809,7 @@ ecl_interpret(cl_object bytecodes, void *pc) */ CASE(OP_LFUNCTION); { int lex_env_index = GET_OPARG(vector); - cl_object fun_record = ecl_lex_env_get_record(lex_env_index); + cl_object fun_record = ecl_lex_env_get_record(cl_env.lex_env, lex_env_index); reg0 = CAR(fun_record); NEXT; } @@ -839,7 +840,7 @@ ecl_interpret(cl_object bytecodes, void *pc) purposes. */ CASE(OP_GO); { - cl_object id = ecl_lex_env_get_tag(GET_OPARG(vector)); + cl_object id = ecl_lex_env_get_tag(cl_env.lex_env, GET_OPARG(vector)); cl_object tag_name = GET_DATA(vector, bytecodes); cl_go(id, tag_name); NEXT; @@ -850,7 +851,7 @@ ecl_interpret(cl_object bytecodes, void *pc) */ CASE(OP_RETURN); { int lex_env_index = GET_OPARG(vector); - cl_object block_record = ecl_lex_env_get_record(lex_env_index); + cl_object block_record = ecl_lex_env_get_record(cl_env.lex_env, lex_env_index); cl_object id = CAR(block_record); cl_object block_name = CDR(block_record); cl_return_from(id, block_name); @@ -937,20 +938,20 @@ ecl_interpret(cl_object bytecodes, void *pc) */ CASE(OP_BIND); { cl_object var_name = GET_DATA(vector, bytecodes); - bind_var(var_name, reg0); + cl_env.lex_env = bind_var(cl_env.lex_env, var_name, reg0); NEXT; } CASE(OP_PBIND); { cl_object var_name = GET_DATA(vector, bytecodes); cl_object value = cl_stack_pop(); - bind_var(var_name, value); + cl_env.lex_env = bind_var(cl_env.lex_env, var_name, value); NEXT; } CASE(OP_VBIND); { cl_index n = GET_OPARG(vector); cl_object var_name = GET_DATA(vector, bytecodes); cl_object value = (n < NVALUES) ? VALUES(n) : Cnil; - bind_var(var_name, value); + cl_env.lex_env = bind_var(cl_env.lex_env, var_name, value); NEXT; } CASE(OP_BINDS); { @@ -981,7 +982,7 @@ ecl_interpret(cl_object bytecodes, void *pc) */ CASE(OP_SETQ); { int lex_env_index = GET_OPARG(vector); - ecl_lex_env_set_var(lex_env_index, reg0); + ecl_lex_env_set_var(cl_env.lex_env, lex_env_index, reg0); NEXT; } CASE(OP_SETQS); { @@ -994,7 +995,7 @@ ecl_interpret(cl_object bytecodes, void *pc) } CASE(OP_PSETQ); { int lex_env_index = GET_OPARG(vector); - ecl_lex_env_set_var(lex_env_index, cl_stack_pop()); + ecl_lex_env_set_var(cl_env.lex_env, lex_env_index, cl_stack_pop()); NEXT; } CASE(OP_PSETQS); { @@ -1080,7 +1081,7 @@ ecl_interpret(cl_object bytecodes, void *pc) int n = GET_OPARG(vector); /* Here we save the location of the jump table */ cl_stack_push((cl_object)vector); /* FIXME! */ - bind_tagbody(id); + cl_env.lex_env = bind_tagbody(cl_env.lex_env, id); if (frs_push(id) == 0) { /* The first time, we "name" the tagbody and * skip the jump table */ From 6833a3cf0a55dd9366bdde1ea82465e9aaa87dd4 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 14:56:59 +0000 Subject: [PATCH 07/71] lambda_bind_var() now takes also a generic environment as argument --- src/c/interpreter.d | 51 ++++++++++++++++++++++++++------------------- 1 file changed, 30 insertions(+), 21 deletions(-) diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 155868e5d..5a015e2fb 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -311,8 +311,8 @@ lambda_bind_var(cl_object env, cl_object var, cl_object val, cl_object specials) return env; } -static void -lambda_bind(cl_narg narg, cl_object lambda, cl_object *sp) +static cl_object +lambda_bind(cl_object env, cl_narg narg, cl_object lambda, cl_object *sp) { cl_object *data = lambda->bytecodes.data; cl_object specials = lambda->bytecodes.specials; @@ -324,24 +324,27 @@ lambda_bind(cl_narg narg, cl_object lambda, cl_object *sp) if (narg < n) FEwrong_num_arguments(lambda->bytecodes.name); for (; n; n--, narg--) - cl_env.lex_env = lambda_bind_var(cl_env.lex_env, *(data++), *(sp++), specials); + env = lambda_bind_var(env, *(data++), *(sp++), specials); /* 2) OPTIONAL ARGUMENTS: N var1 value1 flag1 ... varN valueN flagN */ for (n = fix(*(data++)); n; n--, data+=3) { if (narg) { - cl_env.lex_env = lambda_bind_var(cl_env.lex_env, data[0], *sp, specials); + env = lambda_bind_var(env, data[0], *sp, specials); sp++; narg--; - if (!Null(data[2])) - cl_env.lex_env = lambda_bind_var(cl_env.lex_env, data[2], Ct, specials); + if (!Null(data[2])) { + env = lambda_bind_var(env, data[2], Ct, specials); + } } else { cl_object defaults = data[1]; if (FIXNUMP(defaults)) { + cl_env.lex_env = env; ecl_interpret(lambda, (cl_opcode*)lambda->bytecodes.code + fix(defaults)); defaults = VALUES(0); } - cl_env.lex_env = lambda_bind_var(cl_env.lex_env, data[0], defaults, specials); - if (!Null(data[2])) - cl_env.lex_env = lambda_bind_var(cl_env.lex_env, data[2], Cnil, specials); + env = lambda_bind_var(env, data[0], defaults, specials); + if (!Null(data[2])) { + env = lambda_bind_var(env, data[2], Cnil, specials); + } } } @@ -349,18 +352,20 @@ lambda_bind(cl_narg narg, cl_object lambda, cl_object *sp) if (!Null(data[0])) { cl_object rest = Cnil; check_remaining = FALSE; - for (i=narg; i; ) + for (i=narg; i; ) { rest = CONS(sp[--i], rest); - cl_env.lex_env = lambda_bind_var(cl_env.lex_env, data[0], rest, specials); + } + env = lambda_bind_var(env, data[0], rest, specials); } data++; /* 4) ALLOW-OTHER-KEYS: { T | NIL | 0} */ if (data[0] == MAKE_FIXNUM(0)) { data++; - if (narg && check_remaining) + if (narg && check_remaining) { FEprogram_error("LAMBDA: Too many arguments to function ~S.", 1, lambda->bytecodes.name); + } } else { /* * Only when ALLOW-OTHER-KEYS /= 0, we process this: @@ -418,26 +423,29 @@ lambda_bind(cl_narg narg, cl_object lambda, cl_object *sp) 1, lambda->bytecodes.name); } for (i=0; ibytecodes.code + fix(defaults)); defaults = VALUES(0); } - cl_env.lex_env = lambda_bind_var(cl_env.lex_env, data[1],defaults,specials); + env = lambda_bind_var(env, data[1],defaults,specials); + } + if (!Null(data[3])) { + env = lambda_bind_var(env, data[3],(spp[i] != unbound)? Ct : Cnil,specials); } - if (!Null(data[3])) - cl_env.lex_env = lambda_bind_var(cl_env.lex_env, data[3],(spp[i] != unbound)? Ct : Cnil,specials); } } + return env; } cl_object ecl_apply_lambda(cl_object frame, cl_object fun) { - cl_object name; + cl_object name, env; bds_ptr old_bds_top; struct ihs_frame ihs; @@ -446,15 +454,16 @@ ecl_apply_lambda(cl_object frame, cl_object fun) /* Save the lexical environment and set up a new one */ ihs_push(&ihs, fun); - cl_env.lex_env = fun->bytecodes.lex; + env = fun->bytecodes.lex; old_bds_top = cl_env.bds_top; /* Establish bindings */ - lambda_bind(frame->frame.top - frame->frame.bottom, fun, frame->frame.bottom); + env = lambda_bind(env, frame->frame.top - frame->frame.bottom, fun, frame->frame.bottom); VALUES(0) = Cnil; NVALUES = 0; name = fun->bytecodes.name; + cl_env.lex_env = env; ecl_interpret(fun, fun->bytecodes.code); bds_unwind(old_bds_top); ihs_pop(); From 33a53695cfc8850c9c0cd3d008fef529f4b5f406 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 14:57:12 +0000 Subject: [PATCH 08/71] ecl_interpret() now takes an explicit lexical environment argument. --- src/c/compiler.d | 7 +-- src/c/interpreter.d | 142 +++++++++++++++++++++----------------------- src/h/bytecodes.h | 6 +- src/h/external.h | 2 +- src/h/internal.h | 1 + 5 files changed, 77 insertions(+), 81 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index bcf191fa3..3fe353015 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -2022,7 +2022,7 @@ compile_body(cl_object body, int flags) { VALUES(0) = Cnil; NVALUES = 0; bytecodes = asm_end(handle); - ecl_interpret(bytecodes, bytecodes->bytecodes.code); + ecl_interpret(ENV->lex_env, bytecodes, bytecodes->bytecodes.code); asm_clear(handle); ENV = old_c_env; #ifdef GBC_BOEHM @@ -2561,7 +2561,7 @@ si_make_lambda(cl_object name, cl_object rest) } c_new_env(&new_c_env, compiler_env); guess_environment(interpreter_env); - cl_env.lex_env = env; + ENV->lex_env = env; ENV->stepping = stepping != Cnil; handle = asm_begin(); CL_UNWIND_PROTECT_BEGIN { @@ -2580,10 +2580,9 @@ si_make_lambda(cl_object name, cl_object rest) * Interpret using the given lexical environment. */ ihs_push(&ihs, bytecodes); - cl_env.lex_env = interpreter_env; VALUES(0) = Cnil; NVALUES = 0; - ecl_interpret(bytecodes, bytecodes->bytecodes.code); + ecl_interpret(interpreter_env, bytecodes, bytecodes->bytecodes.code); #ifdef GBC_BOEHM GC_free(bytecodes->bytecodes.code); GC_free(bytecodes->bytecodes.data); diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 5a015e2fb..6455a1f26 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -337,8 +337,7 @@ lambda_bind(cl_object env, cl_narg narg, cl_object lambda, cl_object *sp) } else { cl_object defaults = data[1]; if (FIXNUMP(defaults)) { - cl_env.lex_env = env; - ecl_interpret(lambda, (cl_opcode*)lambda->bytecodes.code + fix(defaults)); + ecl_interpret(env, lambda, (cl_opcode*)lambda->bytecodes.code + fix(defaults)); defaults = VALUES(0); } env = lambda_bind_var(env, data[0], defaults, specials); @@ -428,8 +427,7 @@ lambda_bind(cl_object env, cl_narg narg, cl_object lambda, cl_object *sp) } else { cl_object defaults = data[2]; if (FIXNUMP(defaults)) { - cl_env.lex_env = env; - ecl_interpret(lambda, (cl_opcode*)lambda->bytecodes.code + fix(defaults)); + ecl_interpret(env, lambda, (cl_opcode*)lambda->bytecodes.code + fix(defaults)); defaults = VALUES(0); } env = lambda_bind_var(env, data[1],defaults,specials); @@ -463,8 +461,7 @@ ecl_apply_lambda(cl_object frame, cl_object fun) VALUES(0) = Cnil; NVALUES = 0; name = fun->bytecodes.name; - cl_env.lex_env = env; - ecl_interpret(fun, fun->bytecodes.code); + ecl_interpret(env, fun, fun->bytecodes.code); bds_unwind(old_bds_top); ihs_pop(); returnn(VALUES(0)); @@ -613,53 +610,52 @@ interpret_msetq(cl_object bytecodes, cl_opcode *vector) set to the values in the list which was passed in VALUES(0). */ static cl_opcode * -interpret_progv(cl_object bytecodes, cl_opcode *vector) { +interpret_progv(cl_object env, cl_object bytecodes, cl_opcode *vector) { cl_object values = VALUES(0); cl_object vars = cl_stack_pop(); /* 1) Save current environment */ bds_ptr old_bds_top = cl_env.bds_top; - cl_object old_lex_env = cl_env.lex_env; /* 2) Add new bindings */ while (!ecl_endp(vars)) { - if (values == Cnil) + if (values == Cnil) { bds_bind(CAR(vars), OBJNULL); - else { + } else { bds_bind(CAR(vars), cl_car(values)); values = CDR(values); } vars = CDR(vars); } - vector = ecl_interpret(bytecodes, vector); + vector = ecl_interpret(env, bytecodes, vector); /* 3) Restore environment */ - cl_env.lex_env = old_lex_env; bds_unwind(old_bds_top); return vector; } void * -ecl_interpret(cl_object bytecodes, void *pc) +ecl_interpret(cl_object env, cl_object bytecodes, void *pc) { ECL_OFFSET_TABLE; cl_opcode *vector = pc; cl_object reg0 = VALUES(0), reg1; static int i = 0; i++; + cl_env.lex_env = env; BEGIN: BEGIN_SWITCH { CASE(OP_NOP); { VALUES(0) = reg0 = Cnil; NVALUES = 0; - NEXT; + THREAD_NEXT; } /* OP_QUOTE Sets REG0 to an immediate value. */ CASE(OP_QUOTE); { reg0 = GET_DATA(vector, bytecodes); - NEXT; + THREAD_NEXT; } /* OP_VAR n{arg}, var{symbol} Sets REG0 to the value of the n-th local. @@ -668,7 +664,7 @@ ecl_interpret(cl_object bytecodes, void *pc) CASE(OP_VAR); { int lex_env_index = GET_OPARG(vector); reg0 = ecl_lex_env_get_var(cl_env.lex_env, lex_env_index); - NEXT; + THREAD_NEXT; } /* OP_VARS var{symbol} @@ -678,7 +674,7 @@ ecl_interpret(cl_object bytecodes, void *pc) CASE(OP_VARS); { cl_object var_name = GET_DATA(vector, bytecodes); reg0 = search_global(var_name); - NEXT; + THREAD_NEXT; } /* OP_PUSH @@ -686,7 +682,7 @@ ecl_interpret(cl_object bytecodes, void *pc) */ CASE(OP_PUSH); { cl_stack_push(reg0); - NEXT; + THREAD_NEXT; } /* OP_PUSHV n{arg} Pushes the value of the n-th local onto the stack. @@ -694,7 +690,7 @@ ecl_interpret(cl_object bytecodes, void *pc) CASE(OP_PUSHV); { int lex_env_index = GET_OPARG(vector); cl_stack_push(ecl_lex_env_get_var(cl_env.lex_env, lex_env_index)); - NEXT; + THREAD_NEXT; } /* OP_PUSHVS var{symbol} @@ -704,7 +700,7 @@ ecl_interpret(cl_object bytecodes, void *pc) CASE(OP_PUSHVS); { cl_object var_name = GET_DATA(vector, bytecodes); cl_stack_push(search_global(var_name)); - NEXT; + THREAD_NEXT; } /* OP_PUSHQ value{object} @@ -712,7 +708,7 @@ ecl_interpret(cl_object bytecodes, void *pc) */ CASE(OP_PUSHQ); { cl_stack_push(GET_DATA(vector, bytecodes)); - NEXT; + THREAD_NEXT; } /* OP_CALL n{arg} Calls the function in REG0 with N arguments which @@ -722,7 +718,7 @@ ecl_interpret(cl_object bytecodes, void *pc) CASE(OP_CALL); { cl_fixnum n = GET_OPARG(vector); VALUES(0) = reg0 = interpret_funcall(n, reg0); - NEXT; + THREAD_NEXT; } /* OP_CALLG n{arg}, name{arg} @@ -733,7 +729,7 @@ ecl_interpret(cl_object bytecodes, void *pc) cl_fixnum n = GET_OPARG(vector); cl_object f = GET_DATA(vector, bytecodes); VALUES(0) = reg0 = interpret_funcall(n, f); - NEXT; + THREAD_NEXT; } /* OP_FCALL n{arg} @@ -746,7 +742,7 @@ ecl_interpret(cl_object bytecodes, void *pc) cl_object fun = cl_env.stack_top[-n-1]; VALUES(0) = reg0 = interpret_funcall(n, fun); cl_stack_pop(); - NEXT; + THREAD_NEXT; } /* OP_MCALL @@ -758,7 +754,7 @@ ecl_interpret(cl_object bytecodes, void *pc) cl_object fun = cl_env.stack_top[-n-1]; VALUES(0) = reg0 = interpret_funcall(n, fun); cl_stack_pop(); - NEXT; + THREAD_NEXT; } /* OP_PCALL n{arg} @@ -769,7 +765,7 @@ ecl_interpret(cl_object bytecodes, void *pc) CASE(OP_PCALL); { cl_fixnum n = GET_OPARG(vector); cl_stack_push(interpret_funcall(n, reg0)); - NEXT; + THREAD_NEXT; } /* OP_PCALLG n{arg}, name{arg} @@ -781,7 +777,7 @@ ecl_interpret(cl_object bytecodes, void *pc) cl_fixnum n = GET_OPARG(vector); cl_object f = GET_DATA(vector, bytecodes); cl_stack_push(interpret_funcall(n, f)); - NEXT; + THREAD_NEXT; } /* OP_PFCALL n{arg} @@ -794,7 +790,7 @@ ecl_interpret(cl_object bytecodes, void *pc) cl_object fun = cl_env.stack_top[-n-1]; cl_object reg0 = interpret_funcall(n, fun); cl_env.stack_top[-1] = reg0; - NEXT; + THREAD_NEXT; } /* OP_EXIT @@ -806,11 +802,11 @@ ecl_interpret(cl_object bytecodes, void *pc) } CASE(OP_FLET); { vector = interpret_flet(bytecodes, vector); - NEXT; + THREAD_NEXT; } CASE(OP_LABELS); { vector = interpret_labels(bytecodes, vector); - NEXT; + THREAD_NEXT; } /* OP_LFUNCTION n{arg}, function-name{symbol} Calls the local or global function with N arguments @@ -820,7 +816,7 @@ ecl_interpret(cl_object bytecodes, void *pc) int lex_env_index = GET_OPARG(vector); cl_object fun_record = ecl_lex_env_get_record(cl_env.lex_env, lex_env_index); reg0 = CAR(fun_record); - NEXT; + THREAD_NEXT; } /* OP_FUNCTION name{symbol} @@ -830,7 +826,7 @@ ecl_interpret(cl_object bytecodes, void *pc) */ CASE(OP_FUNCTION); reg0 = ecl_fdefinition(GET_DATA(vector, bytecodes)); - NEXT; + THREAD_NEXT; /* OP_CLOSE name{symbol} Extracts the function associated to a symbol. The function @@ -840,7 +836,7 @@ ecl_interpret(cl_object bytecodes, void *pc) CASE(OP_CLOSE); { cl_object function_object = GET_DATA(vector, bytecodes); reg0 = close_around(function_object, cl_env.lex_env); - NEXT; + THREAD_NEXT; } /* OP_GO n{arg} OP_QUOTE tag-name{symbol} @@ -852,7 +848,7 @@ ecl_interpret(cl_object bytecodes, void *pc) cl_object id = ecl_lex_env_get_tag(cl_env.lex_env, GET_OPARG(vector)); cl_object tag_name = GET_DATA(vector, bytecodes); cl_go(id, tag_name); - NEXT; + THREAD_NEXT; } /* OP_RETURN n{arg} Returns from the block whose record in the lexical environment @@ -864,7 +860,7 @@ ecl_interpret(cl_object bytecodes, void *pc) cl_object id = CAR(block_record); cl_object block_name = CDR(block_record); cl_return_from(id, block_name); - NEXT; + THREAD_NEXT; } /* OP_THROW Jumps to an enclosing CATCH form whose tag matches the one @@ -874,7 +870,7 @@ ecl_interpret(cl_object bytecodes, void *pc) CASE(OP_THROW); { cl_object tag_name = cl_stack_pop(); cl_throw(tag_name); - NEXT; + THREAD_NEXT; } /* OP_JMP label{arg} OP_JNIL label{arg} @@ -887,39 +883,39 @@ ecl_interpret(cl_object bytecodes, void *pc) CASE(OP_JMP); { cl_oparg jump = GET_OPARG(vector); vector += jump - OPARG_SIZE; - NEXT; + THREAD_NEXT; } CASE(OP_JNIL); { cl_oparg jump = GET_OPARG(vector); NVALUES = 1; if (Null(VALUES(0))) vector += jump - OPARG_SIZE; - NEXT; + THREAD_NEXT; } CASE(OP_JT); { cl_oparg jump = GET_OPARG(vector); NVALUES = 1; if (!Null(VALUES(0))) vector += jump - OPARG_SIZE; - NEXT; + THREAD_NEXT; } CASE(OP_JEQL); { cl_oparg value = GET_OPARG(vector); cl_oparg jump = GET_OPARG(vector); if (ecl_eql(reg0, bytecodes->bytecodes.data[value])) vector += jump - OPARG_SIZE; - NEXT; + THREAD_NEXT; } CASE(OP_JNEQL); { cl_oparg value = GET_OPARG(vector); cl_oparg jump = GET_OPARG(vector); if (!ecl_eql(reg0, bytecodes->bytecodes.data[value])) vector += jump - OPARG_SIZE; - NEXT; + THREAD_NEXT; } CASE(OP_NOT); { reg0 = (reg0 == Cnil)? Ct : Cnil; - NEXT; + THREAD_NEXT; } /* OP_UNBIND n{arg} Undo "n" local bindings. @@ -928,7 +924,7 @@ ecl_interpret(cl_object bytecodes, void *pc) cl_index n = GET_OPARG(vector); while (n--) cl_env.lex_env = CDR(cl_env.lex_env); - NEXT; + THREAD_NEXT; } /* OP_UNBINDS n{arg} Undo "n" bindings of special variables. @@ -936,7 +932,7 @@ ecl_interpret(cl_object bytecodes, void *pc) CASE(OP_UNBINDS); { cl_index n = GET_OPARG(vector); bds_unwind_n(n); - NEXT; + THREAD_NEXT; } /* OP_BIND name{symbol} OP_PBIND name{symbol} @@ -948,38 +944,38 @@ ecl_interpret(cl_object bytecodes, void *pc) CASE(OP_BIND); { cl_object var_name = GET_DATA(vector, bytecodes); cl_env.lex_env = bind_var(cl_env.lex_env, var_name, reg0); - NEXT; + THREAD_NEXT; } CASE(OP_PBIND); { cl_object var_name = GET_DATA(vector, bytecodes); cl_object value = cl_stack_pop(); cl_env.lex_env = bind_var(cl_env.lex_env, var_name, value); - NEXT; + THREAD_NEXT; } CASE(OP_VBIND); { cl_index n = GET_OPARG(vector); cl_object var_name = GET_DATA(vector, bytecodes); cl_object value = (n < NVALUES) ? VALUES(n) : Cnil; cl_env.lex_env = bind_var(cl_env.lex_env, var_name, value); - NEXT; + THREAD_NEXT; } CASE(OP_BINDS); { cl_object var_name = GET_DATA(vector, bytecodes); bds_bind(var_name, reg0); - NEXT; + THREAD_NEXT; } CASE(OP_PBINDS); { cl_object var_name = GET_DATA(vector, bytecodes); cl_object value = cl_stack_pop(); bds_bind(var_name, value); - NEXT; + THREAD_NEXT; } CASE(OP_VBINDS); { cl_index n = GET_OPARG(vector); cl_object var_name = GET_DATA(vector, bytecodes); cl_object value = (n < NVALUES) ? VALUES(n) : Cnil; bds_bind(var_name, value); - NEXT; + THREAD_NEXT; } /* OP_SETQ n{arg} OP_PSETQ n{arg} @@ -992,7 +988,7 @@ ecl_interpret(cl_object bytecodes, void *pc) CASE(OP_SETQ); { int lex_env_index = GET_OPARG(vector); ecl_lex_env_set_var(cl_env.lex_env, lex_env_index, reg0); - NEXT; + THREAD_NEXT; } CASE(OP_SETQS); { cl_object var = GET_DATA(vector, bytecodes); @@ -1000,12 +996,12 @@ ecl_interpret(cl_object bytecodes, void *pc) if (var->symbol.stype & stp_constant) FEassignment_to_constant(var); ECL_SETQ(var, reg0); - NEXT; + THREAD_NEXT; } CASE(OP_PSETQ); { int lex_env_index = GET_OPARG(vector); ecl_lex_env_set_var(cl_env.lex_env, lex_env_index, cl_stack_pop()); - NEXT; + THREAD_NEXT; } CASE(OP_PSETQS); { cl_object var = GET_DATA(vector, bytecodes); @@ -1013,7 +1009,7 @@ ecl_interpret(cl_object bytecodes, void *pc) if (var->symbol.stype & stp_constant) FEassignment_to_constant(var); ECL_SETQ(var, cl_stack_pop()); - NEXT; + THREAD_NEXT; } /* OP_BLOCK label{arg} @@ -1064,14 +1060,14 @@ ecl_interpret(cl_object bytecodes, void *pc) frs_pop(); vector = (cl_opcode *)cl_stack_pop(); /* FIXME! */ } - NEXT; + THREAD_NEXT; } CASE(OP_EXIT_FRAME); { bds_unwind(cl_env.frs_top->frs_bds_top); cl_env.lex_env = cl_env.frs_top->frs_lex; frs_pop(); cl_stack_pop(); - NEXT; + THREAD_NEXT; } /* OP_TAGBODY n{arg} label1 @@ -1106,7 +1102,7 @@ ecl_interpret(cl_object bytecodes, void *pc) vector = table + *(cl_oparg *)table; cl_env.lex_env = cl_env.frs_top->frs_lex; } - NEXT; + THREAD_NEXT; } CASE(OP_EXIT_TAGBODY); { cl_env.lex_env = CDR(cl_env.frs_top->frs_lex); @@ -1115,26 +1111,26 @@ ecl_interpret(cl_object bytecodes, void *pc) } CASE(OP_NIL); { reg0 = Cnil; - NEXT; + THREAD_NEXT; } CASE(OP_PUSHNIL); { cl_stack_push(Cnil); - NEXT; + THREAD_NEXT; } CASE(OP_VALUEREG0); { VALUES(0) = reg0; NVALUES = 1; - NEXT; + THREAD_NEXT; } CASE(OP_MSETQ); { vector = interpret_msetq(bytecodes, vector); reg0 = VALUES(0); - NEXT; + THREAD_NEXT; } CASE(OP_PROGV); { - vector = interpret_progv(bytecodes, vector); + vector = interpret_progv(cl_env.lex_env, bytecodes, vector); reg0 = VALUES(0); - NEXT; + THREAD_NEXT; } /* OP_PUSHVALUES Pushes the values output by the last form, plus the number @@ -1146,7 +1142,7 @@ ecl_interpret(cl_object bytecodes, void *pc) for (i=0; ifrs_bds_top); @@ -1248,7 +1244,7 @@ ecl_interpret(cl_object bytecodes, void *pc) n = fix(cl_stack_pop()); if (n <= 0) ecl_unwind(cl_env.frs_top + n); - NEXT; + THREAD_NEXT; } CASE(OP_STEPIN); { cl_object form = GET_DATA(vector, bytecodes); @@ -1271,7 +1267,7 @@ ecl_interpret(cl_object bytecodes, void *pc) * actually never happen. */ } cl_stack_pop_values(n); - NEXT; + THREAD_NEXT; } CASE(OP_STEPCALL); { /* We are going to call a function. However, we would @@ -1301,7 +1297,7 @@ ecl_interpret(cl_object bytecodes, void *pc) /* Not stepping, nothing to be done. */ } cl_stack_pop_values(n); - NEXT; + THREAD_NEXT; } } } diff --git a/src/h/bytecodes.h b/src/h/bytecodes.h index 853355123..9b0194066 100644 --- a/src/h/bytecodes.h +++ b/src/h/bytecodes.h @@ -226,15 +226,15 @@ typedef int16_t cl_oparg; #ifdef ECL_THREADED_INTERPRETER #define BEGIN_SWITCH \ - NEXT; + THREAD_NEXT; #define CASE(name) \ LBL_##name: -#define NEXT \ +#define THREAD_NEXT \ goto *(&&LBL_OP_NOP + offsets[GET_OPCODE(vector)]) #else #define BEGIN_SWITCH \ switch (GET_OPCODE(vector)) -#define NEXT \ +#define THREAD_NEXT \ goto BEGIN #define CASE(name) \ case name: diff --git a/src/h/external.h b/src/h/external.h index df517310c..7a533f0d3 100644 --- a/src/h/external.h +++ b/src/h/external.h @@ -465,7 +465,7 @@ extern ECL_API cl_index cl_stack_push_values(void); extern ECL_API void cl_stack_pop_values(cl_index n); extern ECL_API cl_object ecl_apply_lambda(cl_object frame, cl_object fun); -extern ECL_API void *ecl_interpret(cl_object bytecodes, void *pc); +extern ECL_API void *ecl_interpret(cl_object env, cl_object bytecodes, void *pc); /* disassembler.c */ diff --git a/src/h/internal.h b/src/h/internal.h index b34a46d64..c513fb7b2 100644 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -59,6 +59,7 @@ struct cl_compiler_env { cl_object macros; cl_fixnum lexical_level; cl_object constants; + cl_object lex_env; bool coalesce; bool stepping; }; From 2c3a2f33a670ad3515899a19d9ca09b4c6c8f705 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 14:57:45 +0000 Subject: [PATCH 09/71] Avoid using field lex_env in frame stack records, at least for blocks --- src/c/interpreter.d | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 6455a1f26..dbec98dd6 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -1051,22 +1051,23 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) DO_BLOCK: { cl_opcode *exit; GET_LABEL(exit, vector); + cl_stack_push(cl_env.lex_env); cl_stack_push((cl_object)exit); if (frs_push(reg1) == 0) { cl_env.lex_env = CONS(CONS(reg1, reg0), cl_env.lex_env); } else { reg0 = VALUES(0); - cl_env.lex_env = cl_env.frs_top->frs_lex; frs_pop(); vector = (cl_opcode *)cl_stack_pop(); /* FIXME! */ + cl_env.lex_env = cl_stack_pop(); } THREAD_NEXT; } CASE(OP_EXIT_FRAME); { bds_unwind(cl_env.frs_top->frs_bds_top); - cl_env.lex_env = cl_env.frs_top->frs_lex; frs_pop(); cl_stack_pop(); + cl_env.lex_env = cl_stack_pop(); THREAD_NEXT; } /* OP_TAGBODY n{arg} From 45b24c328e8d88de30e6784885110f0344e848f1 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 14:58:07 +0000 Subject: [PATCH 10/71] OP_TAGBODY also pushes the environment to be saved --- src/c/interpreter.d | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/c/interpreter.d b/src/c/interpreter.d index dbec98dd6..4e44fe43b 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -1085,9 +1085,9 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) CASE(OP_TAGBODY); { cl_object id = new_frame_id(); int n = GET_OPARG(vector); - /* Here we save the location of the jump table */ + /* Here we save the location of the jump table and the env. */ + cl_stack_push(cl_env.lex_env = bind_tagbody(cl_env.lex_env, id)); cl_stack_push((cl_object)vector); /* FIXME! */ - cl_env.lex_env = bind_tagbody(cl_env.lex_env, id); if (frs_push(id) == 0) { /* The first time, we "name" the tagbody and * skip the jump table */ @@ -1101,14 +1101,14 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) cl_opcode *table = (cl_opcode *)cl_env.stack_top[-1]; table = table + fix(VALUES(0)) * OPARG_SIZE; vector = table + *(cl_oparg *)table; - cl_env.lex_env = cl_env.frs_top->frs_lex; + cl_env.lex_env = cl_env.stack_top[-2]; } THREAD_NEXT; } CASE(OP_EXIT_TAGBODY); { - cl_env.lex_env = CDR(cl_env.frs_top->frs_lex); frs_pop(); cl_stack_pop(); + cl_env.lex_env = ECL_CONS_CDR(cl_stack_pop()); } CASE(OP_NIL); { reg0 = Cnil; From ff083d351127864b291ee7c86369caec6e8a7081 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 14:58:20 +0000 Subject: [PATCH 11/71] OP_PROTECT also pushes the environment onto the stack. --- src/c/interpreter.d | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 4e44fe43b..473083b37 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -1219,11 +1219,12 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) CASE(OP_PROTECT); { cl_opcode *exit; GET_LABEL(exit, vector); + cl_stack_push(cl_env.lex_env); cl_stack_push((cl_object)exit); if (frs_push(ECL_PROTECT_TAG) != 0) { - cl_env.lex_env = cl_env.frs_top->frs_lex; frs_pop(); vector = (cl_opcode *)cl_stack_pop(); + cl_env.lex_env = cl_stack_pop(); cl_stack_push(MAKE_FIXNUM(cl_env.nlj_fr - cl_env.frs_top)); goto PUSH_VALUES; } @@ -1231,9 +1232,9 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) } CASE(OP_PROTECT_NORMAL); { bds_unwind(cl_env.frs_top->frs_bds_top); - cl_env.lex_env = cl_env.frs_top->frs_lex; frs_pop(); cl_stack_pop(); + cl_env.lex_env = cl_stack_pop(); cl_stack_push(MAKE_FIXNUM(1)); goto PUSH_VALUES; } From 327b6b96407929b29f3961f88a4f6f81ff215b74 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 14:58:32 +0000 Subject: [PATCH 12/71] Inline OP_FLET/LABELS and let them access cl_env.lex_env less often. --- src/c/interpreter.d | 105 +++++++++++++++++++------------------------- 1 file changed, 46 insertions(+), 59 deletions(-) diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 473083b37..9dcf4c1da 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -510,63 +510,6 @@ close_around(cl_object fun, cl_object lex) { return v; } -/* OP_FLET nfun{arg} - fun1{object} - ... - funn{object} - ... - OP_UNBIND n - - Executes the enclosed code in a lexical enviroment extended with - the functions "fun1" ... "funn". -*/ -static cl_opcode * -interpret_flet(cl_object bytecodes, cl_opcode *vector) { - cl_index nfun = GET_OPARG(vector); - - /* 1) Copy the environment so that functions get it without references - to themselves. */ - cl_object lex = cl_env.lex_env; - - /* 3) Add new closures to environment */ - while (nfun--) { - cl_object fun = GET_DATA(vector, bytecodes); - cl_object f = close_around(fun,lex); - cl_env.lex_env = bind_function(cl_env.lex_env, f->bytecodes.name, f); - } - return vector; -} - -/* OP_LABELS nfun{arg} - fun1{object} - ... - funn{object} - ... - OP_UNBIND n - - Executes the enclosed code in a lexical enviroment extended with - the functions "fun1" ... "funn". -*/ -static cl_opcode * -interpret_labels(cl_object bytecodes, cl_opcode *vector) { - cl_index i, nfun = GET_OPARG(vector); - cl_object l; - - /* 1) Build up a new environment with all functions */ - for (i=0; ibytecodes.name, f); - } - - /* 2) Update the closures so that all functions can call each other */ - for (i=0, l=cl_env.lex_env; ibytecodes.name, f); + } + cl_env.lex_env = new_lex; THREAD_NEXT; } + /* OP_LABELS nfun{arg} + fun1{object} + ... + funn{object} + ... + OP_UNBIND n + + Executes the enclosed code in a lexical enviroment extended with + the functions "fun1" ... "funn". + */ CASE(OP_LABELS); { - vector = interpret_labels(bytecodes, vector); + cl_index i, nfun = GET_OPARG(vector); + cl_object l, new_lex; + /* Build up a new environment with all functions */ + for (new_lex = cl_env.lex_env, i = nfun; i; i--) { + cl_object f = GET_DATA(vector, bytecodes); + new_lex = bind_function(new_lex, f->bytecodes.name, f); + } + /* Update the closures so that all functions can call each other */ + ; + for (l = new_lex, i = nfun; i; i--) { + cl_object record = ECL_CONS_CAR(l); + ECL_RPLACA(record, close_around(ECL_CONS_CAR(record), new_lex)); + l = ECL_CONS_CDR(l); + } + cl_env.lex_env = new_lex; THREAD_NEXT; } /* OP_LFUNCTION n{arg}, function-name{symbol} From 200ec27464edc6deae42617888bc7170544db473 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 14:58:44 +0000 Subject: [PATCH 13/71] Inline OP_MSETQ --- src/c/interpreter.d | 71 +++++++++++++++++++++------------------------ 1 file changed, 33 insertions(+), 38 deletions(-) diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 9dcf4c1da..1c6423fa7 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -510,42 +510,6 @@ close_around(cl_object fun, cl_object lex) { return v; } -/* OP_MSETQ n{arg} - {fixnumn} - ... - {fixnum1} - - Sets N variables to the N values in VALUES(), filling with - NIL when there are values missing. Local variables are denoted - with an integer which points a position in the lexical environment, - while special variables are denoted with a negative index X, which - denotes the value -1-X in the table of constants. -*/ -static cl_opcode * -interpret_msetq(cl_object bytecodes, cl_opcode *vector) -{ - cl_object value; - cl_index i, n = GET_OPARG(vector); - for (i=0; i= 0) { - ecl_lex_env_set_var(cl_env.lex_env, var, value); - } else { - cl_object name = bytecodes->bytecodes.data[-1-var]; - if (Null(name) || (name->symbol.stype & stp_constant)) - FEassignment_to_constant(name); - else - ECL_SETQ(name, value); - } - } - if (NVALUES == 0) { - VALUES(0) = Cnil; - } - NVALUES = 1; - return vector; -} - /* OP_PROGV bindings{list} ... OP_EXIT @@ -1110,9 +1074,40 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) NVALUES = 1; THREAD_NEXT; } + /* OP_MSETQ n{arg} + {fixnumn} + ... + {fixnum1} + + Sets N variables to the N values in VALUES(), filling with + NIL when there are values missing. Local variables are denoted + with an integer which points a position in the lexical environment, + while special variables are denoted with a negative index X, which + denotes the value -1-X in the table of constants. + */ CASE(OP_MSETQ); { - vector = interpret_msetq(bytecodes, vector); - reg0 = VALUES(0); + cl_object value; + cl_index i, n = GET_OPARG(vector), nv = NVALUES; + cl_object env = cl_env.lex_env; + for (i=0; i= 0) { + ecl_lex_env_set_var(env, var, value); + } else { + cl_object name = bytecodes->bytecodes.data[-1-var]; + if (Null(name) || (name->symbol.stype & stp_constant)) { + FEassignment_to_constant(name); + } + ECL_SETQ(name, value); + } + } + if (nv == 0) { + VALUES(0) = reg0 = Cnil; + } else { + reg0 = VALUES(0); + } + NVALUES = 1; THREAD_NEXT; } CASE(OP_PROGV); { From 8ae45ee30e9394511a113118f8484f3cfa87e98e Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 14:58:57 +0000 Subject: [PATCH 14/71] Remove useless field frs_lex from the frame stack records. --- src/c/stacks.d | 2 -- src/h/stacks.h | 1 - 2 files changed, 3 deletions(-) diff --git a/src/c/stacks.d b/src/c/stacks.d index eb6f4a7a5..663d6e606 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -262,7 +262,6 @@ _frs_push(register cl_object val) { ecl_frame_ptr output = ++cl_env.frs_top; if (output >= cl_env.frs_limit) frs_overflow(); - output->frs_lex = cl_env.lex_env; output->frs_bds_top = cl_env.bds_top; output->frs_val = val; output->frs_ihs = cl_env.ihs_top; @@ -276,7 +275,6 @@ ecl_unwind(ecl_frame_ptr fr) cl_env.nlj_fr = fr; while (cl_env.frs_top != fr && cl_env.frs_top->frs_val != ECL_PROTECT_TAG) --cl_env.frs_top; - cl_env.lex_env = cl_env.frs_top->frs_lex; cl_env.ihs_top = cl_env.frs_top->frs_ihs; bds_unwind(cl_env.frs_top->frs_bds_top); cl_stack_set_index(cl_env.frs_top->frs_sp); diff --git a/src/h/stacks.h b/src/h/stacks.h index 335b583c2..53636a2fb 100644 --- a/src/h/stacks.h +++ b/src/h/stacks.h @@ -116,7 +116,6 @@ extern ECL_API cl_object ihs_top_function_name(void); typedef struct ecl_frame { jmp_buf frs_jmpbuf; cl_object frs_val; - cl_object frs_lex; bds_ptr frs_bds_top; ihs_ptr frs_ihs; cl_index frs_sp; From c1f08a04e6fab819c952f7f4f971ea3f53e19c6a Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 14:59:11 +0000 Subject: [PATCH 15/71] Removed global environment field cl_env.lex_env --- src/c/compiler.d | 2 +- src/c/disassembler.d | 2 - src/c/interpreter.d | 91 ++++++++++++++++++++++---------------------- src/c/main.d | 2 - src/cmp/cmptop.lsp | 2 +- src/h/external.h | 6 --- src/h/stacks.h | 9 ++--- 7 files changed, 50 insertions(+), 64 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index 3fe353015..7e7e02750 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -2579,7 +2579,7 @@ si_make_lambda(cl_object name, cl_object rest) /* * Interpret using the given lexical environment. */ - ihs_push(&ihs, bytecodes); + ihs_push(&ihs, bytecodes, Cnil); VALUES(0) = Cnil; NVALUES = 0; ecl_interpret(interpreter_env, bytecodes, bytecodes->bytecodes.code); diff --git a/src/c/disassembler.d b/src/c/disassembler.d index 03380f7b2..fe71c9ad1 100644 --- a/src/c/disassembler.d +++ b/src/c/disassembler.d @@ -221,7 +221,6 @@ labeln: static cl_opcode * disassemble_tagbody(cl_object bytecodes, cl_opcode *vector) { cl_index i, ntags = GET_OPARG(vector); - cl_object lex_old = cl_env.lex_env; cl_opcode *destination; print_noarg("TAGBODY"); @@ -234,7 +233,6 @@ disassemble_tagbody(cl_object bytecodes, cl_opcode *vector) { vector = disassemble(bytecodes, vector); print_noarg("\t\t; tagbody"); - cl_env.lex_env = lex_old; return vector; } diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 1c6423fa7..7cff8bca8 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -451,7 +451,7 @@ ecl_apply_lambda(cl_object frame, cl_object fun) FEinvalid_function(fun); /* Save the lexical environment and set up a new one */ - ihs_push(&ihs, fun); + ihs_push(&ihs, fun, Cnil); env = fun->bytecodes.lex; old_bds_top = cl_env.bds_top; @@ -483,20 +483,21 @@ search_global(register cl_object s) { * environment and get into the C/lisp world. Since almost all data from the * interpreter is kept in local variables, and frame stacks, binding stacks, * etc, are already handled by the C core, only the lexical environment - * (cl_env.lex_env) needs to be saved. + * needs to be saved. */ static cl_object -interpret_funcall(cl_narg narg, cl_object fun) +interpret_funcall(cl_object lex_env, cl_narg narg, cl_object fun) { - cl_object lex_env = cl_env.lex_env; struct ecl_stack_frame frame_aux; + struct ihs_frame ihs; + ihs_push(&ihs, fun, lex_env); frame_aux.t = t_frame; frame_aux.stack = cl_env.stack; frame_aux.top = cl_env.stack_top; frame_aux.bottom = frame_aux.top - narg; fun = ecl_apply_from_stack_frame((cl_object)&frame_aux, fun); ecl_stack_frame_close((cl_object)&frame_aux); - cl_env.lex_env = lex_env; + ihs_pop(); return fun; } @@ -542,14 +543,13 @@ interpret_progv(cl_object env, cl_object bytecodes, cl_opcode *vector) { } void * -ecl_interpret(cl_object env, cl_object bytecodes, void *pc) +ecl_interpret(cl_object lex_env, cl_object bytecodes, void *pc) { ECL_OFFSET_TABLE; cl_opcode *vector = pc; cl_object reg0 = VALUES(0), reg1; static int i = 0; i++; - cl_env.lex_env = env; BEGIN: BEGIN_SWITCH { CASE(OP_NOP); { @@ -570,7 +570,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) */ CASE(OP_VAR); { int lex_env_index = GET_OPARG(vector); - reg0 = ecl_lex_env_get_var(cl_env.lex_env, lex_env_index); + reg0 = ecl_lex_env_get_var(lex_env, lex_env_index); THREAD_NEXT; } @@ -596,7 +596,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) */ CASE(OP_PUSHV); { int lex_env_index = GET_OPARG(vector); - cl_stack_push(ecl_lex_env_get_var(cl_env.lex_env, lex_env_index)); + cl_stack_push(ecl_lex_env_get_var(lex_env, lex_env_index)); THREAD_NEXT; } @@ -624,7 +624,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) */ CASE(OP_CALL); { cl_fixnum n = GET_OPARG(vector); - VALUES(0) = reg0 = interpret_funcall(n, reg0); + VALUES(0) = reg0 = interpret_funcall(lex_env, n, reg0); THREAD_NEXT; } @@ -635,7 +635,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) CASE(OP_CALLG); { cl_fixnum n = GET_OPARG(vector); cl_object f = GET_DATA(vector, bytecodes); - VALUES(0) = reg0 = interpret_funcall(n, f); + VALUES(0) = reg0 = interpret_funcall(lex_env, n, f); THREAD_NEXT; } @@ -647,7 +647,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) CASE(OP_FCALL); { cl_fixnum n = GET_OPARG(vector); cl_object fun = cl_env.stack_top[-n-1]; - VALUES(0) = reg0 = interpret_funcall(n, fun); + VALUES(0) = reg0 = interpret_funcall(lex_env, n, fun); cl_stack_pop(); THREAD_NEXT; } @@ -659,7 +659,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) CASE(OP_MCALL); { cl_fixnum n = fix(cl_stack_pop()); cl_object fun = cl_env.stack_top[-n-1]; - VALUES(0) = reg0 = interpret_funcall(n, fun); + VALUES(0) = reg0 = interpret_funcall(lex_env, n, fun); cl_stack_pop(); THREAD_NEXT; } @@ -671,7 +671,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) */ CASE(OP_PCALL); { cl_fixnum n = GET_OPARG(vector); - cl_stack_push(interpret_funcall(n, reg0)); + cl_stack_push(interpret_funcall(lex_env, n, reg0)); THREAD_NEXT; } @@ -683,7 +683,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) CASE(OP_PCALLG); { cl_fixnum n = GET_OPARG(vector); cl_object f = GET_DATA(vector, bytecodes); - cl_stack_push(interpret_funcall(n, f)); + cl_stack_push(interpret_funcall(lex_env, n, f)); THREAD_NEXT; } @@ -695,7 +695,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) CASE(OP_PFCALL); { cl_fixnum n = GET_OPARG(vector); cl_object fun = cl_env.stack_top[-n-1]; - cl_object reg0 = interpret_funcall(n, fun); + cl_object reg0 = interpret_funcall(lex_env, n, fun); cl_env.stack_top[-1] = reg0; THREAD_NEXT; } @@ -721,14 +721,14 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) cl_index nfun = GET_OPARG(vector); /* Copy the environment so that functions get it without references to themselves, and then add new closures to the environment. */ - cl_object old_lex = cl_env.lex_env; + cl_object old_lex = lex_env; cl_object new_lex = old_lex; while (nfun--) { cl_object fun = GET_DATA(vector, bytecodes); cl_object f = close_around(fun, old_lex); new_lex = bind_function(new_lex, f->bytecodes.name, f); } - cl_env.lex_env = new_lex; + lex_env = new_lex; THREAD_NEXT; } /* OP_LABELS nfun{arg} @@ -745,7 +745,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) cl_index i, nfun = GET_OPARG(vector); cl_object l, new_lex; /* Build up a new environment with all functions */ - for (new_lex = cl_env.lex_env, i = nfun; i; i--) { + for (new_lex = lex_env, i = nfun; i; i--) { cl_object f = GET_DATA(vector, bytecodes); new_lex = bind_function(new_lex, f->bytecodes.name, f); } @@ -756,7 +756,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) ECL_RPLACA(record, close_around(ECL_CONS_CAR(record), new_lex)); l = ECL_CONS_CDR(l); } - cl_env.lex_env = new_lex; + lex_env = new_lex; THREAD_NEXT; } /* OP_LFUNCTION n{arg}, function-name{symbol} @@ -765,7 +765,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) */ CASE(OP_LFUNCTION); { int lex_env_index = GET_OPARG(vector); - cl_object fun_record = ecl_lex_env_get_record(cl_env.lex_env, lex_env_index); + cl_object fun_record = ecl_lex_env_get_record(lex_env, lex_env_index); reg0 = CAR(fun_record); THREAD_NEXT; } @@ -786,7 +786,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) */ CASE(OP_CLOSE); { cl_object function_object = GET_DATA(vector, bytecodes); - reg0 = close_around(function_object, cl_env.lex_env); + reg0 = close_around(function_object, lex_env); THREAD_NEXT; } /* OP_GO n{arg} @@ -796,7 +796,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) purposes. */ CASE(OP_GO); { - cl_object id = ecl_lex_env_get_tag(cl_env.lex_env, GET_OPARG(vector)); + cl_object id = ecl_lex_env_get_tag(lex_env, GET_OPARG(vector)); cl_object tag_name = GET_DATA(vector, bytecodes); cl_go(id, tag_name); THREAD_NEXT; @@ -807,7 +807,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) */ CASE(OP_RETURN); { int lex_env_index = GET_OPARG(vector); - cl_object block_record = ecl_lex_env_get_record(cl_env.lex_env, lex_env_index); + cl_object block_record = ecl_lex_env_get_record(lex_env, lex_env_index); cl_object id = CAR(block_record); cl_object block_name = CDR(block_record); cl_return_from(id, block_name); @@ -874,7 +874,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) CASE(OP_UNBIND); { cl_index n = GET_OPARG(vector); while (n--) - cl_env.lex_env = CDR(cl_env.lex_env); + lex_env = ECL_CONS_CDR(lex_env); THREAD_NEXT; } /* OP_UNBINDS n{arg} @@ -894,20 +894,20 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) */ CASE(OP_BIND); { cl_object var_name = GET_DATA(vector, bytecodes); - cl_env.lex_env = bind_var(cl_env.lex_env, var_name, reg0); + lex_env = bind_var(lex_env, var_name, reg0); THREAD_NEXT; } CASE(OP_PBIND); { cl_object var_name = GET_DATA(vector, bytecodes); cl_object value = cl_stack_pop(); - cl_env.lex_env = bind_var(cl_env.lex_env, var_name, value); + lex_env = bind_var(lex_env, var_name, value); THREAD_NEXT; } CASE(OP_VBIND); { cl_index n = GET_OPARG(vector); cl_object var_name = GET_DATA(vector, bytecodes); cl_object value = (n < NVALUES) ? VALUES(n) : Cnil; - cl_env.lex_env = bind_var(cl_env.lex_env, var_name, value); + lex_env = bind_var(lex_env, var_name, value); THREAD_NEXT; } CASE(OP_BINDS); { @@ -938,7 +938,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) */ CASE(OP_SETQ); { int lex_env_index = GET_OPARG(vector); - ecl_lex_env_set_var(cl_env.lex_env, lex_env_index, reg0); + ecl_lex_env_set_var(lex_env, lex_env_index, reg0); THREAD_NEXT; } CASE(OP_SETQS); { @@ -951,7 +951,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) } CASE(OP_PSETQ); { int lex_env_index = GET_OPARG(vector); - ecl_lex_env_set_var(cl_env.lex_env, lex_env_index, cl_stack_pop()); + ecl_lex_env_set_var(lex_env, lex_env_index, cl_stack_pop()); THREAD_NEXT; } CASE(OP_PSETQS); { @@ -1002,15 +1002,15 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) DO_BLOCK: { cl_opcode *exit; GET_LABEL(exit, vector); - cl_stack_push(cl_env.lex_env); + cl_stack_push(lex_env); cl_stack_push((cl_object)exit); if (frs_push(reg1) == 0) { - cl_env.lex_env = CONS(CONS(reg1, reg0), cl_env.lex_env); + lex_env = CONS(CONS(reg1, reg0), lex_env); } else { reg0 = VALUES(0); frs_pop(); vector = (cl_opcode *)cl_stack_pop(); /* FIXME! */ - cl_env.lex_env = cl_stack_pop(); + lex_env = cl_stack_pop(); } THREAD_NEXT; } @@ -1018,7 +1018,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) bds_unwind(cl_env.frs_top->frs_bds_top); frs_pop(); cl_stack_pop(); - cl_env.lex_env = cl_stack_pop(); + lex_env = cl_stack_pop(); THREAD_NEXT; } /* OP_TAGBODY n{arg} @@ -1037,7 +1037,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) cl_object id = new_frame_id(); int n = GET_OPARG(vector); /* Here we save the location of the jump table and the env. */ - cl_stack_push(cl_env.lex_env = bind_tagbody(cl_env.lex_env, id)); + cl_stack_push(lex_env = bind_tagbody(lex_env, id)); cl_stack_push((cl_object)vector); /* FIXME! */ if (frs_push(id) == 0) { /* The first time, we "name" the tagbody and @@ -1052,14 +1052,14 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) cl_opcode *table = (cl_opcode *)cl_env.stack_top[-1]; table = table + fix(VALUES(0)) * OPARG_SIZE; vector = table + *(cl_oparg *)table; - cl_env.lex_env = cl_env.stack_top[-2]; + lex_env = cl_env.stack_top[-2]; } THREAD_NEXT; } CASE(OP_EXIT_TAGBODY); { frs_pop(); cl_stack_pop(); - cl_env.lex_env = ECL_CONS_CDR(cl_stack_pop()); + lex_env = ECL_CONS_CDR(cl_stack_pop()); } CASE(OP_NIL); { reg0 = Cnil; @@ -1088,12 +1088,11 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) CASE(OP_MSETQ); { cl_object value; cl_index i, n = GET_OPARG(vector), nv = NVALUES; - cl_object env = cl_env.lex_env; for (i=0; i= 0) { - ecl_lex_env_set_var(env, var, value); + ecl_lex_env_set_var(lex_env, var, value); } else { cl_object name = bytecodes->bytecodes.data[-1-var]; if (Null(name) || (name->symbol.stype & stp_constant)) { @@ -1111,7 +1110,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) THREAD_NEXT; } CASE(OP_PROGV); { - vector = interpret_progv(cl_env.lex_env, bytecodes, vector); + vector = interpret_progv(lex_env, bytecodes, vector); reg0 = VALUES(0); THREAD_NEXT; } @@ -1201,12 +1200,12 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) CASE(OP_PROTECT); { cl_opcode *exit; GET_LABEL(exit, vector); - cl_stack_push(cl_env.lex_env); + cl_stack_push(lex_env); cl_stack_push((cl_object)exit); if (frs_push(ECL_PROTECT_TAG) != 0) { frs_pop(); vector = (cl_opcode *)cl_stack_pop(); - cl_env.lex_env = cl_stack_pop(); + lex_env = cl_stack_pop(); cl_stack_push(MAKE_FIXNUM(cl_env.nlj_fr - cl_env.frs_top)); goto PUSH_VALUES; } @@ -1216,7 +1215,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) bds_unwind(cl_env.frs_top->frs_bds_top); frs_pop(); cl_stack_pop(); - cl_env.lex_env = cl_stack_pop(); + lex_env = cl_stack_pop(); cl_stack_push(MAKE_FIXNUM(1)); goto PUSH_VALUES; } @@ -1240,7 +1239,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) ECL_SETQ(@'si::*step-level*', cl_1P(SYM_VAL(@'si::*step-level*'))); cl_stack_push(form); - interpret_funcall(1, @'si::stepper'); + interpret_funcall(lex_env, 1, @'si::stepper'); } else if (a != Cnil) { /* The user told us to step over. *step-level* contains * an integer number that, when it becomes 0, means @@ -1260,9 +1259,9 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) cl_fixnum n = GET_OPARG(vector); if (SYM_VAL(@'si::*step-action*') == Ct) { cl_stack_push(reg0); - reg0 = interpret_funcall(1, @'si::stepper'); + reg0 = interpret_funcall(lex_env, 1, @'si::stepper'); } - reg0 = interpret_funcall(n, reg0); + reg0 = interpret_funcall(lex_env, n, reg0); } CASE(OP_STEPOUT); { cl_object a = SYM_VAL(@'si::*step-action*'); diff --git a/src/c/main.d b/src/c/main.d index f3071ee9b..efd968920 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -61,8 +61,6 @@ ecl_init_env(struct cl_env_struct *env) { int i; - env->lex_env = Cnil; - env->c_env = NULL; env->string_pool = Cnil; diff --git a/src/cmp/cmptop.lsp b/src/cmp/cmptop.lsp index 380f462eb..5d64c00e0 100644 --- a/src/cmp/cmptop.lsp +++ b/src/cmp/cmptop.lsp @@ -608,7 +608,7 @@ ;; name into the invocation stack (when (>= (fun-debug fun) 2) (push 'IHS *unwind-exit*) - (wt-nl "ihs_push(&ihs," (add-symbol (fun-name fun)) ");")) + (wt-nl "ihs_push(&ihs," (add-symbol (fun-name fun)) ",Cnil);")) (c2lambda-expr (c1form-arg 0 lambda-expr) (c1form-arg 2 lambda-expr) diff --git a/src/h/external.h b/src/h/external.h index 7a533f0d3..cb7dbe83e 100644 --- a/src/h/external.h +++ b/src/h/external.h @@ -12,12 +12,6 @@ extern "C" { struct cl_env_struct { /* The four stacks in ECL. */ - /* - * The lexical environment stack, where local bindings of - * variables are kept by interpreted functions. - */ - cl_object lex_env; - /* * The lisp stack, which is used mainly for keeping the arguments of a * function before it is invoked, and also by the compiler and by the diff --git a/src/h/stacks.h b/src/h/stacks.h index 53636a2fb..5629ab2ea 100644 --- a/src/h/stacks.h +++ b/src/h/stacks.h @@ -76,14 +76,13 @@ typedef struct ihs_frame { cl_index index; } *ihs_ptr; -#define ihs_push(r,f) do {\ - (r)->next=cl_env.ihs_top; (r)->function=(f); (r)->lex_env= cl_env.lex_env; \ +#define ihs_push(r,f,e) do { \ + (r)->next=cl_env.ihs_top; (r)->function=(f); (r)->lex_env= (e); \ (r)->index=cl_env.ihs_top->index+1;\ cl_env.ihs_top = (r); \ } while(0) #define ihs_pop() do {\ - cl_env.lex_env = cl_env.ihs_top->lex_env; \ if (cl_env.ihs_top->next == NULL) ecl_internal_error("Underflow in IHS stack"); \ cl_env.ihs_top = cl_env.ihs_top->next; \ } while(0) @@ -198,11 +197,9 @@ extern ECL_API ecl_frame_ptr _frs_push(register cl_object val); #define CL_NEWENV_BEGIN {\ cl_index __i = cl_stack_push_values(); \ - cl_object __env = cl_env.lex_env; #define CL_NEWENV_END \ - cl_stack_pop_values(__i); \ - cl_env.lex_env = __env; } + cl_stack_pop_values(__i); } #define CL_UNWIND_PROTECT_BEGIN {\ bool __unwinding; ecl_frame_ptr __next_fr; \ From 6870a9753f8b940e601d5eb7470b25b12e1b10c7 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 14:59:24 +0000 Subject: [PATCH 16/71] The lexical environment of a function is stored in the same IHS record as its name. --- src/c/interpreter.d | 4 +--- src/c/stacks.d | 2 +- src/h/stacks.h | 2 +- src/lsp/top.lsp | 2 +- 4 files changed, 4 insertions(+), 6 deletions(-) diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 7cff8bca8..4be097e1f 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -489,15 +489,13 @@ static cl_object interpret_funcall(cl_object lex_env, cl_narg narg, cl_object fun) { struct ecl_stack_frame frame_aux; - struct ihs_frame ihs; - ihs_push(&ihs, fun, lex_env); + cl_env.ihs_top->lex_env = lex_env; frame_aux.t = t_frame; frame_aux.stack = cl_env.stack; frame_aux.top = cl_env.stack_top; frame_aux.bottom = frame_aux.top - narg; fun = ecl_apply_from_stack_frame((cl_object)&frame_aux, fun); ecl_stack_frame_close((cl_object)&frame_aux); - ihs_pop(); return fun; } diff --git a/src/c/stacks.d b/src/c/stacks.d index 663d6e606..75df305c0 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -234,7 +234,7 @@ si_ihs_fun(cl_object arg) cl_object si_ihs_env(cl_object arg) { - @(return get_ihs_ptr(fixnnint(si_ihs_next(arg)))->lex_env) + @(return get_ihs_ptr(fixnnint(arg))->lex_env) } /********************** FRAME STACK *************************/ diff --git a/src/h/stacks.h b/src/h/stacks.h index 5629ab2ea..eabbd5742 100644 --- a/src/h/stacks.h +++ b/src/h/stacks.h @@ -77,7 +77,7 @@ typedef struct ihs_frame { } *ihs_ptr; #define ihs_push(r,f,e) do { \ - (r)->next=cl_env.ihs_top; (r)->function=(f); (r)->lex_env= (e); \ + (r)->next=cl_env.ihs_top; (r)->function=(f); (r)->lex_env=(e); \ (r)->index=cl_env.ihs_top->index+1;\ cl_env.ihs_top = (r); \ } while(0) diff --git a/src/lsp/top.lsp b/src/lsp/top.lsp index c01bb3e8e..8e794a3fa 100644 --- a/src/lsp/top.lsp +++ b/src/lsp/top.lsp @@ -781,7 +781,7 @@ under certain conditions; see file 'Copyright' for details.") (set-break-env)) (defun set-break-env () - (setq *break-env* (if (= *ihs-current* *ihs-top*) nil (ihs-env *ihs-current*)))) + (setq *break-env* (ihs-env *ihs-current*))) (defun ihs-search (string unrestricted &optional (start (si::ihs-top 'tpl))) (do ((ihs start (si::ihs-prev ihs))) From 9d3d2b34febfbce2c9c6075fe7783aa1cd57f582 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 14:59:37 +0000 Subject: [PATCH 17/71] The IHS record is not created in apply lambda but in ecl_interpret --- src/c/interpreter.d | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 4be097e1f..433193afb 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -445,13 +445,11 @@ ecl_apply_lambda(cl_object frame, cl_object fun) { cl_object name, env; bds_ptr old_bds_top; - struct ihs_frame ihs; if (type_of(fun) != t_bytecodes) FEinvalid_function(fun); /* Save the lexical environment and set up a new one */ - ihs_push(&ihs, fun, Cnil); env = fun->bytecodes.lex; old_bds_top = cl_env.bds_top; @@ -463,7 +461,6 @@ ecl_apply_lambda(cl_object frame, cl_object fun) name = fun->bytecodes.name; ecl_interpret(env, fun, fun->bytecodes.code); bds_unwind(old_bds_top); - ihs_pop(); returnn(VALUES(0)); } @@ -546,7 +543,9 @@ ecl_interpret(cl_object lex_env, cl_object bytecodes, void *pc) ECL_OFFSET_TABLE; cl_opcode *vector = pc; cl_object reg0 = VALUES(0), reg1; + struct ihs_frame ihs; static int i = 0; + ihs_push(&ihs, bytecodes, lex_env); i++; BEGIN: BEGIN_SWITCH { @@ -703,6 +702,7 @@ ecl_interpret(cl_object lex_env, cl_object bytecodes, void *pc) or a function. */ CASE(OP_EXIT); { + ihs_pop(); return (char *)vector; } /* OP_FLET nfun{arg} From 5668d23f2b849796964cafc87031dcef0c744b36 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 14:59:49 +0000 Subject: [PATCH 18/71] Inline OP_PROGV. --- src/c/compiler.d | 6 ++--- src/c/interpreter.d | 57 +++++++++++++++++++-------------------------- src/h/bytecodes.h | 2 ++ 3 files changed, 29 insertions(+), 36 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index 7e7e02750..fe3b90713 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -1601,8 +1601,8 @@ c_progv(cl_object args, int flags) { /* The list of variables is in the stack */ compile_form(vars, FLAG_PUSH); - /* The list of values is in VALUES(0) */ - compile_form(values, FLAG_VALUES); + /* The list of values is in reg0 */ + compile_form(values, FLAG_REG0); /* The body is interpreted within an extended lexical environment. However, as all the new variables are @@ -1610,7 +1610,7 @@ c_progv(cl_object args, int flags) { */ asm_op(OP_PROGV); flags = compile_body(args, FLAG_VALUES); - asm_op(OP_EXIT); + asm_op(OP_EXIT_PROGV); return flags; } diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 433193afb..895605f10 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -506,37 +506,6 @@ close_around(cl_object fun, cl_object lex) { return v; } -/* OP_PROGV bindings{list} - ... - OP_EXIT - Execute the code enclosed with the special variables in BINDINGS - set to the values in the list which was passed in VALUES(0). -*/ -static cl_opcode * -interpret_progv(cl_object env, cl_object bytecodes, cl_opcode *vector) { - cl_object values = VALUES(0); - cl_object vars = cl_stack_pop(); - - /* 1) Save current environment */ - bds_ptr old_bds_top = cl_env.bds_top; - - /* 2) Add new bindings */ - while (!ecl_endp(vars)) { - if (values == Cnil) { - bds_bind(CAR(vars), OBJNULL); - } else { - bds_bind(CAR(vars), cl_car(values)); - values = CDR(values); - } - vars = CDR(vars); - } - vector = ecl_interpret(env, bytecodes, vector); - - /* 3) Restore environment */ - bds_unwind(old_bds_top); - return vector; -} - void * ecl_interpret(cl_object lex_env, cl_object bytecodes, void *pc) { @@ -1107,9 +1076,31 @@ ecl_interpret(cl_object lex_env, cl_object bytecodes, void *pc) NVALUES = 1; THREAD_NEXT; } + /* OP_PROGV bindings{list} + ... + OP_EXIT + Execute the code enclosed with the special variables in BINDINGS + set to the values in the list which was passed in VALUES(0). + */ CASE(OP_PROGV); { - vector = interpret_progv(lex_env, bytecodes, vector); - reg0 = VALUES(0); + cl_object values = reg0; + cl_object vars = cl_stack_pop(); + cl_index n; + for (n = 0; !ecl_endp(vars); n++, vars = ECL_CONS_CDR(vars)) { + cl_object var = ECL_CONS_CAR(vars); + if (values == Cnil) { + bds_bind(var, OBJNULL); + } else { + bds_bind(var, cl_car(values)); + values = ECL_CONS_CDR(values); + } + } + cl_stack_push(MAKE_FIXNUM(n)); + THREAD_NEXT; + } + CASE(OP_EXIT_PROGV); { + cl_index n = fix(cl_stack_pop()); + bds_unwind_n(n); THREAD_NEXT; } /* OP_PUSHVALUES diff --git a/src/h/bytecodes.h b/src/h/bytecodes.h index 9b0194066..02d498cb5 100644 --- a/src/h/bytecodes.h +++ b/src/h/bytecodes.h @@ -176,6 +176,7 @@ enum { OP_PROTECT_EXIT, OP_MSETQ, OP_PROGV, + OP_EXIT_PROGV, OP_PUSHVALUES, OP_POP, OP_POPVALUES, @@ -297,6 +298,7 @@ typedef int16_t cl_oparg; &&LBL_OP_PROTECT_EXIT - &&LBL_OP_NOP,\ &&LBL_OP_MSETQ - &&LBL_OP_NOP,\ &&LBL_OP_PROGV - &&LBL_OP_NOP,\ + &&LBL_OP_EXIT_PROGV - &&LBL_OP_NOP,\ &&LBL_OP_PUSHVALUES - &&LBL_OP_NOP,\ &&LBL_OP_POP - &&LBL_OP_NOP,\ &&LBL_OP_POPVALUES - &&LBL_OP_NOP,\ From 8e2237108e9b200c1d630fac17b788eebc94bafc Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 15:00:01 +0000 Subject: [PATCH 19/71] Use the local IHS frame for storing the lexical environment. --- src/c/interpreter.d | 65 ++++++++++++++++++++++++--------------------- 1 file changed, 35 insertions(+), 30 deletions(-) diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 895605f10..bef47c055 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -507,14 +507,15 @@ close_around(cl_object fun, cl_object lex) { } void * -ecl_interpret(cl_object lex_env, cl_object bytecodes, void *pc) +ecl_interpret(cl_object env, cl_object bytecodes, void *pc) { ECL_OFFSET_TABLE; cl_opcode *vector = pc; cl_object reg0 = VALUES(0), reg1; struct ihs_frame ihs; static int i = 0; - ihs_push(&ihs, bytecodes, lex_env); + ihs_push(&ihs, bytecodes, env); +#define lex_env ihs.lex_env i++; BEGIN: BEGIN_SWITCH { @@ -1004,7 +1005,8 @@ ecl_interpret(cl_object lex_env, cl_object bytecodes, void *pc) cl_object id = new_frame_id(); int n = GET_OPARG(vector); /* Here we save the location of the jump table and the env. */ - cl_stack_push(lex_env = bind_tagbody(lex_env, id)); + lex_env = bind_tagbody(lex_env, id); + cl_stack_push(lex_env); cl_stack_push((cl_object)vector); /* FIXME! */ if (frs_push(id) == 0) { /* The first time, we "name" the tagbody and @@ -1076,33 +1078,7 @@ ecl_interpret(cl_object lex_env, cl_object bytecodes, void *pc) NVALUES = 1; THREAD_NEXT; } - /* OP_PROGV bindings{list} - ... - OP_EXIT - Execute the code enclosed with the special variables in BINDINGS - set to the values in the list which was passed in VALUES(0). - */ - CASE(OP_PROGV); { - cl_object values = reg0; - cl_object vars = cl_stack_pop(); - cl_index n; - for (n = 0; !ecl_endp(vars); n++, vars = ECL_CONS_CDR(vars)) { - cl_object var = ECL_CONS_CAR(vars); - if (values == Cnil) { - bds_bind(var, OBJNULL); - } else { - bds_bind(var, cl_car(values)); - values = ECL_CONS_CDR(values); - } - } - cl_stack_push(MAKE_FIXNUM(n)); - THREAD_NEXT; - } - CASE(OP_EXIT_PROGV); { - cl_index n = fix(cl_stack_pop()); - bds_unwind_n(n); - THREAD_NEXT; - } + /* OP_PUSHVALUES Pushes the values output by the last form, plus the number of values. @@ -1218,6 +1194,35 @@ ecl_interpret(cl_object lex_env, cl_object bytecodes, void *pc) ecl_unwind(cl_env.frs_top + n); THREAD_NEXT; } + + /* OP_PROGV bindings{list} + ... + OP_EXIT + Execute the code enclosed with the special variables in BINDINGS + set to the values in the list which was passed in VALUES(0). + */ + CASE(OP_PROGV); { + cl_object values = reg0; + cl_object vars = cl_stack_pop(); + cl_index n; + for (n = 0; !ecl_endp(vars); n++, vars = ECL_CONS_CDR(vars)) { + cl_object var = ECL_CONS_CAR(vars); + if (values == Cnil) { + bds_bind(var, OBJNULL); + } else { + bds_bind(var, cl_car(values)); + values = ECL_CONS_CDR(values); + } + } + cl_stack_push(MAKE_FIXNUM(n)); + THREAD_NEXT; + } + CASE(OP_EXIT_PROGV); { + cl_index n = fix(cl_stack_pop()); + bds_unwind_n(n); + THREAD_NEXT; + } + CASE(OP_STEPIN); { cl_object form = GET_DATA(vector, bytecodes); cl_object a = SYM_VAL(@'si::*step-action*'); From aa6b20fad12859d1adca6cae07f19137a559abfd Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 15:00:20 +0000 Subject: [PATCH 20/71] Simplify bytecodes compiler by rewriting IF as a COND. --- src/c/compiler.d | 40 ++++++++-------------------------------- 1 file changed, 8 insertions(+), 32 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index fe3b90713..7798eff77 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -1209,43 +1209,19 @@ c_go(cl_object args, int flags) { /* - To get an idea of what goes on - - ... ; test form - JNIL labeln - ... ; form for true case - JMP labelz - ... ; form for nil case - labelz: + (if a b) -> (cond (a b)) + (if a b c) -> (cond (a b) (t c)) */ static int c_if(cl_object form, int flags) { - cl_index label_nil, label_true; - - /* Compile test */ - compile_form(pop(&form), FLAG_VALUES); - label_nil = asm_jmp(OP_JNIL); - - /* Compile THEN ... */ - flags = maybe_values_or_reg0(flags); - compile_form(pop(&form), flags); - - /* ... and then ELSE */ - if (ecl_endp(form)) { - /* ... in case there is any! */ - asm_complete(OP_JNIL, label_nil); + cl_object test = pop(&form); + cl_object then = pop(&form); + then = cl_list(2, test, then); + if (Null(form)) { + return c_cond(ecl_list1(then), flags); } else { - label_true = asm_jmp(OP_JMP); - asm_complete(OP_JNIL, label_nil); - compile_form(pop(&form), flags); - asm_complete(OP_JMP, label_true); - - if (!Null(form)) - FEprogram_error("IF: Too many arguments.", 0); + return c_cond(cl_list(2, then, CONS(Ct, form)), flags); } - - - return flags; } From 64ca376393abf33922b53aef196cb00be8863774 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 15:00:50 +0000 Subject: [PATCH 21/71] Given that reg0 contains always VALUES(0), we can simplify OP_JT and OP_JNIL. --- src/c/interpreter.d | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/c/interpreter.d b/src/c/interpreter.d index bef47c055..e3c4c7af0 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -807,14 +807,14 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) CASE(OP_JNIL); { cl_oparg jump = GET_OPARG(vector); NVALUES = 1; - if (Null(VALUES(0))) + if (Null(reg0)) vector += jump - OPARG_SIZE; THREAD_NEXT; } CASE(OP_JT); { cl_oparg jump = GET_OPARG(vector); NVALUES = 1; - if (!Null(VALUES(0))) + if (!Null(reg0)) vector += jump - OPARG_SIZE; THREAD_NEXT; } From 37022df5d6e61290ebc95a4bc3c788f88cc6fb26 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 15:01:05 +0000 Subject: [PATCH 22/71] Since OP_JT/JNIL check reg0, we can simplify the bytecodes for WHILE --- src/c/compiler.d | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index 7798eff77..a3bf32d57 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -1046,7 +1046,7 @@ c_while_until(cl_object body, int flags, bool is_while) { /* Compile test */ asm_complete(OP_JMP, labelt); - compile_form(test, FLAG_VALUES); + compile_form(test, FLAG_REG0); asm_op(is_while? OP_JT : OP_JNIL); asm_arg(labelb - current_pc()); From ecd1053c2660ab8e804ef2c7361ff20c8a36d0cd Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 15:01:23 +0000 Subject: [PATCH 23/71] Allow COND forms to use REG0 to store computations, instead of forcing use of VALUES. --- src/c/compiler.d | 30 ++++++++++++++++-------------- 1 file changed, 16 insertions(+), 14 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index a3bf32d57..a6b4da9d1 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -985,28 +985,30 @@ c_cond(cl_object args, int flags) { compile_body(clause, flags); } else { /* Compile the test. If no more forms, just output - the first value (this is guaranteed by OP_JT) */ - if (Null(clause)) { - if (Null(args)) { + the first value (this is guaranteed by OP_JT), but make + sure it is stored in the appropriate place. */ + if (Null(args)) { + if (Null(clause)) { c_values(cl_list(1,test), flags); - return flags; + } else { + compile_form(test, (flags & FLAG_VALUES)? FLAG_VALUES: FLAG_REG0); + label_nil = asm_jmp(OP_JNIL); + compile_body(clause, flags); + asm_complete(OP_JNIL, label_nil); } - compile_form(test, FLAG_VALUES); + } else if (Null(clause)) { + compile_form(test, (flags & FLAG_VALUES)? FLAG_VALUES : FLAG_REG0); label_exit = asm_jmp(OP_JT); c_cond(args, flags); asm_complete(OP_JT, label_exit); } else { - compile_form(test, FLAG_VALUES); + compile_form(test, FLAG_REG0); label_nil = asm_jmp(OP_JNIL); compile_body(clause, flags); - if (Null(args)) - asm_complete(OP_JNIL, label_nil); - else { - label_exit = asm_jmp(OP_JMP); - asm_complete(OP_JNIL, label_nil); - c_cond(args, flags); - asm_complete(OP_JMP, label_exit); - } + label_exit = asm_jmp(OP_JMP); + asm_complete(OP_JNIL, label_nil); + c_cond(args, flags); + asm_complete(OP_JMP, label_exit); } } return flags; From 8fca58aec5788a6dbaa88bad7a9ba64181ec7d08 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 15:01:35 +0000 Subject: [PATCH 24/71] OP_JT/JNIL need not set NVALUES --- src/c/interpreter.d | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/c/interpreter.d b/src/c/interpreter.d index e3c4c7af0..7c65382b3 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -806,14 +806,12 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) } CASE(OP_JNIL); { cl_oparg jump = GET_OPARG(vector); - NVALUES = 1; if (Null(reg0)) vector += jump - OPARG_SIZE; THREAD_NEXT; } CASE(OP_JT); { cl_oparg jump = GET_OPARG(vector); - NVALUES = 1; if (!Null(reg0)) vector += jump - OPARG_SIZE; THREAD_NEXT; From f5b4ff25af21df94b1824221a10f5caea526ee77 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 15:01:47 +0000 Subject: [PATCH 25/71] COND and PROG1 now operate using only REG0 and the stack --- src/c/compiler.d | 8 +++++--- src/c/interpreter.d | 3 +-- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index a6b4da9d1..6865cde3f 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -991,13 +991,15 @@ c_cond(cl_object args, int flags) { if (Null(clause)) { c_values(cl_list(1,test), flags); } else { - compile_form(test, (flags & FLAG_VALUES)? FLAG_VALUES: FLAG_REG0); + compile_form(test, FLAG_REG0); + if (flags & FLAG_VALUES) asm_op(OP_VALUEREG0); label_nil = asm_jmp(OP_JNIL); compile_body(clause, flags); asm_complete(OP_JNIL, label_nil); } } else if (Null(clause)) { - compile_form(test, (flags & FLAG_VALUES)? FLAG_VALUES : FLAG_REG0); + compile_form(test, FLAG_REG0); + if (flags & FLAG_VALUES) asm_op(OP_VALUEREG0); label_exit = asm_jmp(OP_JT); c_cond(args, flags); asm_complete(OP_JT, label_exit); @@ -1549,7 +1551,7 @@ c_prog1(cl_object args, int flags) { flags = compile_form(form, flags); compile_body(args, FLAG_IGNORE); } else { - flags = FLAG_VALUES; + flags = FLAG_REG0; compile_form(form, FLAG_PUSH); compile_body(args, FLAG_IGNORE); asm_op(OP_POP); diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 7c65382b3..2d82b536f 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -1103,8 +1103,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) Pops a singe value pushed by a OP_PUSH* operator. */ CASE(OP_POP); { - VALUES(0) = reg0 = cl_stack_pop(); - NVALUES = 1; + reg0 = cl_stack_pop(); THREAD_NEXT; } /* OP_POPVALUES From 9dcff352d7c08337bf93b6ab8326e17b6834d87b Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 15:01:59 +0000 Subject: [PATCH 26/71] Save a pointer to the current environment in the interpreter. --- src/c/interpreter.d | 134 ++++++++++++++++++++++++-------------------- 1 file changed, 74 insertions(+), 60 deletions(-) diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 2d82b536f..9cff5fa99 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -21,9 +21,9 @@ #include #undef frs_pop -#define frs_pop() { \ - cl_env.stack_top = cl_env.stack + cl_env.frs_top->frs_sp; \ - cl_env.frs_top--; } +#define frs_pop(the_env) { \ + the_env->stack_top = the_env->stack + the_env->frs_top->frs_sp; \ + the_env->frs_top--; } /* -------------------- INTERPRETER STACK -------------------- */ @@ -510,8 +510,10 @@ void * ecl_interpret(cl_object env, cl_object bytecodes, void *pc) { ECL_OFFSET_TABLE; + typedef struct cl_env_struct *cl_env_ptr; + const cl_env_ptr the_env = &cl_env; cl_opcode *vector = pc; - cl_object reg0 = VALUES(0), reg1; + cl_object reg0 = the_env->values[0], reg1; struct ihs_frame ihs; static int i = 0; ihs_push(&ihs, bytecodes, env); @@ -520,8 +522,8 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) BEGIN: BEGIN_SWITCH { CASE(OP_NOP); { - VALUES(0) = reg0 = Cnil; - NVALUES = 0; + the_env->values[0] = reg0 = Cnil; + the_env->nvalues = 0; THREAD_NEXT; } /* OP_QUOTE @@ -591,7 +593,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) */ CASE(OP_CALL); { cl_fixnum n = GET_OPARG(vector); - VALUES(0) = reg0 = interpret_funcall(lex_env, n, reg0); + the_env->values[0] = reg0 = interpret_funcall(lex_env, n, reg0); THREAD_NEXT; } @@ -602,7 +604,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) CASE(OP_CALLG); { cl_fixnum n = GET_OPARG(vector); cl_object f = GET_DATA(vector, bytecodes); - VALUES(0) = reg0 = interpret_funcall(lex_env, n, f); + the_env->values[0] = reg0 = interpret_funcall(lex_env, n, f); THREAD_NEXT; } @@ -613,8 +615,8 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) */ CASE(OP_FCALL); { cl_fixnum n = GET_OPARG(vector); - cl_object fun = cl_env.stack_top[-n-1]; - VALUES(0) = reg0 = interpret_funcall(lex_env, n, fun); + cl_object fun = the_env->stack_top[-n-1]; + the_env->values[0] = reg0 = interpret_funcall(lex_env, n, fun); cl_stack_pop(); THREAD_NEXT; } @@ -625,8 +627,8 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) */ CASE(OP_MCALL); { cl_fixnum n = fix(cl_stack_pop()); - cl_object fun = cl_env.stack_top[-n-1]; - VALUES(0) = reg0 = interpret_funcall(lex_env, n, fun); + cl_object fun = the_env->stack_top[-n-1]; + the_env->values[0] = reg0 = interpret_funcall(lex_env, n, fun); cl_stack_pop(); THREAD_NEXT; } @@ -661,9 +663,9 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) */ CASE(OP_PFCALL); { cl_fixnum n = GET_OPARG(vector); - cl_object fun = cl_env.stack_top[-n-1]; + cl_object fun = the_env->stack_top[-n-1]; cl_object reg0 = interpret_funcall(lex_env, n, fun); - cl_env.stack_top[-1] = reg0; + the_env->stack_top[-1] = reg0; THREAD_NEXT; } @@ -872,7 +874,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) CASE(OP_VBIND); { cl_index n = GET_OPARG(vector); cl_object var_name = GET_DATA(vector, bytecodes); - cl_object value = (n < NVALUES) ? VALUES(n) : Cnil; + cl_object value = (n < the_env->nvalues) ? the_env->values[n] : Cnil; lex_env = bind_var(lex_env, var_name, value); THREAD_NEXT; } @@ -890,7 +892,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) CASE(OP_VBINDS); { cl_index n = GET_OPARG(vector); cl_object var_name = GET_DATA(vector, bytecodes); - cl_object value = (n < NVALUES) ? VALUES(n) : Cnil; + cl_object value = (n < the_env->nvalues) ? the_env->values[n] : Cnil; bds_bind(var_name, value); THREAD_NEXT; } @@ -973,16 +975,16 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) if (frs_push(reg1) == 0) { lex_env = CONS(CONS(reg1, reg0), lex_env); } else { - reg0 = VALUES(0); - frs_pop(); + reg0 = the_env->values[0]; + frs_pop(the_env); vector = (cl_opcode *)cl_stack_pop(); /* FIXME! */ lex_env = cl_stack_pop(); } THREAD_NEXT; } CASE(OP_EXIT_FRAME); { - bds_unwind(cl_env.frs_top->frs_bds_top); - frs_pop(); + bds_unwind(the_env->frs_top->frs_bds_top); + frs_pop(the_env); cl_stack_pop(); lex_env = cl_stack_pop(); THREAD_NEXT; @@ -1016,15 +1018,15 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) to ntags-1, depending on the tag. These numbers are indices into the jump table and are computed at compile time. */ - cl_opcode *table = (cl_opcode *)cl_env.stack_top[-1]; - table = table + fix(VALUES(0)) * OPARG_SIZE; + cl_opcode *table = (cl_opcode *)the_env->stack_top[-1]; + table = table + fix(the_env->values[0]) * OPARG_SIZE; vector = table + *(cl_oparg *)table; - lex_env = cl_env.stack_top[-2]; + lex_env = the_env->stack_top[-2]; } THREAD_NEXT; } CASE(OP_EXIT_TAGBODY); { - frs_pop(); + frs_pop(the_env); cl_stack_pop(); lex_env = ECL_CONS_CDR(cl_stack_pop()); } @@ -1037,8 +1039,8 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) THREAD_NEXT; } CASE(OP_VALUEREG0); { - VALUES(0) = reg0; - NVALUES = 1; + the_env->values[0] = reg0; + the_env->nvalues = 1; THREAD_NEXT; } /* OP_MSETQ n{arg} @@ -1054,10 +1056,10 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) */ CASE(OP_MSETQ); { cl_object value; - cl_index i, n = GET_OPARG(vector), nv = NVALUES; + cl_index i, n = GET_OPARG(vector), nv = the_env->nvalues; for (i=0; ivalues[i] : Cnil; if (var >= 0) { ecl_lex_env_set_var(lex_env, var, value); } else { @@ -1069,11 +1071,11 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) } } if (nv == 0) { - VALUES(0) = reg0 = Cnil; + the_env->values[0] = reg0 = Cnil; } else { - reg0 = VALUES(0); + reg0 = the_env->values[0]; } - NVALUES = 1; + the_env->nvalues = 1; THREAD_NEXT; } @@ -1084,9 +1086,9 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) PUSH_VALUES: CASE(OP_PUSHVALUES); { cl_index i; - for (i=0; invalues; i++) + cl_stack_push(the_env->values[i]); + cl_stack_push(MAKE_FIXNUM(the_env->nvalues)); THREAD_NEXT; } /* OP_PUSHMOREVALUES @@ -1094,9 +1096,9 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) */ CASE(OP_PUSHMOREVALUES); { cl_index i, n = fix(cl_stack_pop()); - for (i=0; invalues; i++) + cl_stack_push(the_env->values[i]); + cl_stack_push(MAKE_FIXNUM(n + the_env->nvalues)); THREAD_NEXT; } /* OP_POP @@ -1110,24 +1112,36 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) Pops all values pushed by a OP_PUSHVALUES operator. */ CASE(OP_POPVALUES); { - int n = NVALUES = fix(cl_stack_pop()); + cl_object *dest = the_env->values; + cl_object *sp = the_env->stack_top; + int n = the_env->nvalues = fix(*(--sp)); if (n == 0) { - VALUES(0) = Cnil; - } else do { - VALUES(--n) = cl_stack_pop(); - } while (n); - reg0 = VALUES(0); - THREAD_NEXT; + *dest = reg0 = Cnil; + THREAD_NEXT; + } else if (n == 1) { + *dest = reg0 = *(--sp); + the_env->stack_top = sp; + THREAD_NEXT; + } else { + sp -= n; + memcpy(dest, sp, n * sizeof(cl_object)); + reg0 = *dest; + the_env->stack_top = sp; + THREAD_NEXT; + } } /* OP_VALUES n{arg} Pop N values from the stack and store them in VALUES(...) + Note that N is strictly > 0. */ CASE(OP_VALUES); { cl_fixnum n = GET_OPARG(vector); - NVALUES = n; - while (--n) - VALUES(n) = cl_stack_pop(); - VALUES(0) = reg0 = cl_stack_pop(); + cl_object *sp = the_env->stack_top - n; + cl_object *dest = the_env->values; + the_env->nvalues = n; + memcpy(dest, sp, n * sizeof(cl_object)); + reg0 = *dest; + the_env->stack_top = sp; THREAD_NEXT; } /* OP_NTHVAL @@ -1138,12 +1152,12 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) cl_fixnum n = fix(cl_stack_pop()); if (n < 0) { FEerror("Wrong index passed to NTH-VAL", 1, MAKE_FIXNUM(n)); - } else if ((cl_index)n >= NVALUES) { - VALUES(0) = reg0 = Cnil; + } else if ((cl_index)n >= the_env->nvalues) { + the_env->values[0] = reg0 = Cnil; } else { - VALUES(0) = reg0 = VALUES(n); + the_env->values[0] = reg0 = the_env->values[n]; } - NVALUES = 1; + the_env->nvalues = 1; THREAD_NEXT; } /* OP_PROTECT label @@ -1165,30 +1179,30 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) cl_stack_push(lex_env); cl_stack_push((cl_object)exit); if (frs_push(ECL_PROTECT_TAG) != 0) { - frs_pop(); + frs_pop(the_env); vector = (cl_opcode *)cl_stack_pop(); lex_env = cl_stack_pop(); - cl_stack_push(MAKE_FIXNUM(cl_env.nlj_fr - cl_env.frs_top)); + cl_stack_push(MAKE_FIXNUM(the_env->nlj_fr - the_env->frs_top)); goto PUSH_VALUES; } THREAD_NEXT; } CASE(OP_PROTECT_NORMAL); { - bds_unwind(cl_env.frs_top->frs_bds_top); - frs_pop(); + bds_unwind(the_env->frs_top->frs_bds_top); + frs_pop(the_env); cl_stack_pop(); lex_env = cl_stack_pop(); cl_stack_push(MAKE_FIXNUM(1)); goto PUSH_VALUES; } CASE(OP_PROTECT_EXIT); { - volatile cl_fixnum n = NVALUES = fix(cl_stack_pop()); + volatile cl_fixnum n = the_env->nvalues = fix(cl_stack_pop()); while (n--) - VALUES(n) = cl_stack_pop(); - reg0 = VALUES(0); + the_env->values[n] = cl_stack_pop(); + reg0 = the_env->values[0]; n = fix(cl_stack_pop()); if (n <= 0) - ecl_unwind(cl_env.frs_top + n); + ecl_unwind(the_env->frs_top + n); THREAD_NEXT; } From 311995ae4f0e7a8c23ff8be923ad88a07880ec2d Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 15:02:12 +0000 Subject: [PATCH 27/71] Inline the stack push operation --- src/c/interpreter.d | 61 +++++++++++++++++++++++++-------------------- 1 file changed, 34 insertions(+), 27 deletions(-) diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 9cff5fa99..7986b4128 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -20,11 +20,6 @@ #include #include -#undef frs_pop -#define frs_pop(the_env) { \ - the_env->stack_top = the_env->stack + the_env->frs_top->frs_sp; \ - the_env->frs_top--; } - /* -------------------- INTERPRETER STACK -------------------- */ void @@ -506,6 +501,18 @@ close_around(cl_object fun, cl_object lex) { return v; } +#undef frs_pop +#define frs_pop(the_env) { \ + the_env->stack_top = the_env->stack + the_env->frs_top->frs_sp; \ + the_env->frs_top--; } + +#define ecl_stack_push(the_env,x) { \ + cl_object __aux = (x); \ + if (the_env->stack_top == the_env->stack_limit) { \ + cl_stack_grow(); \ + } \ + *(the_env->stack_top++) = __aux; } + void * ecl_interpret(cl_object env, cl_object bytecodes, void *pc) { @@ -557,7 +564,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) Pushes the object in VALUES(0). */ CASE(OP_PUSH); { - cl_stack_push(reg0); + ecl_stack_push(the_env, reg0); THREAD_NEXT; } /* OP_PUSHV n{arg} @@ -565,7 +572,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) */ CASE(OP_PUSHV); { int lex_env_index = GET_OPARG(vector); - cl_stack_push(ecl_lex_env_get_var(lex_env, lex_env_index)); + ecl_stack_push(the_env, ecl_lex_env_get_var(lex_env, lex_env_index)); THREAD_NEXT; } @@ -575,7 +582,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) */ CASE(OP_PUSHVS); { cl_object var_name = GET_DATA(vector, bytecodes); - cl_stack_push(search_global(var_name)); + ecl_stack_push(the_env, search_global(var_name)); THREAD_NEXT; } @@ -583,7 +590,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) Pushes "value" onto the stack. */ CASE(OP_PUSHQ); { - cl_stack_push(GET_DATA(vector, bytecodes)); + ecl_stack_push(the_env, GET_DATA(vector, bytecodes)); THREAD_NEXT; } /* OP_CALL n{arg} @@ -640,7 +647,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) */ CASE(OP_PCALL); { cl_fixnum n = GET_OPARG(vector); - cl_stack_push(interpret_funcall(lex_env, n, reg0)); + ecl_stack_push(the_env, interpret_funcall(lex_env, n, reg0)); THREAD_NEXT; } @@ -652,7 +659,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) CASE(OP_PCALLG); { cl_fixnum n = GET_OPARG(vector); cl_object f = GET_DATA(vector, bytecodes); - cl_stack_push(interpret_funcall(lex_env, n, f)); + ecl_stack_push(the_env, interpret_funcall(lex_env, n, f)); THREAD_NEXT; } @@ -970,8 +977,8 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) DO_BLOCK: { cl_opcode *exit; GET_LABEL(exit, vector); - cl_stack_push(lex_env); - cl_stack_push((cl_object)exit); + ecl_stack_push(the_env, lex_env); + ecl_stack_push(the_env, (cl_object)exit); if (frs_push(reg1) == 0) { lex_env = CONS(CONS(reg1, reg0), lex_env); } else { @@ -1006,8 +1013,8 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) int n = GET_OPARG(vector); /* Here we save the location of the jump table and the env. */ lex_env = bind_tagbody(lex_env, id); - cl_stack_push(lex_env); - cl_stack_push((cl_object)vector); /* FIXME! */ + ecl_stack_push(the_env, lex_env); + ecl_stack_push(the_env, (cl_object)vector); /* FIXME! */ if (frs_push(id) == 0) { /* The first time, we "name" the tagbody and * skip the jump table */ @@ -1035,7 +1042,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) THREAD_NEXT; } CASE(OP_PUSHNIL); { - cl_stack_push(Cnil); + ecl_stack_push(the_env, Cnil); THREAD_NEXT; } CASE(OP_VALUEREG0); { @@ -1087,8 +1094,8 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) CASE(OP_PUSHVALUES); { cl_index i; for (i=0; invalues; i++) - cl_stack_push(the_env->values[i]); - cl_stack_push(MAKE_FIXNUM(the_env->nvalues)); + ecl_stack_push(the_env, the_env->values[i]); + ecl_stack_push(the_env, MAKE_FIXNUM(the_env->nvalues)); THREAD_NEXT; } /* OP_PUSHMOREVALUES @@ -1097,8 +1104,8 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) CASE(OP_PUSHMOREVALUES); { cl_index i, n = fix(cl_stack_pop()); for (i=0; invalues; i++) - cl_stack_push(the_env->values[i]); - cl_stack_push(MAKE_FIXNUM(n + the_env->nvalues)); + ecl_stack_push(the_env, the_env->values[i]); + ecl_stack_push(the_env, MAKE_FIXNUM(n + the_env->nvalues)); THREAD_NEXT; } /* OP_POP @@ -1176,13 +1183,13 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) CASE(OP_PROTECT); { cl_opcode *exit; GET_LABEL(exit, vector); - cl_stack_push(lex_env); - cl_stack_push((cl_object)exit); + ecl_stack_push(the_env, lex_env); + ecl_stack_push(the_env, (cl_object)exit); if (frs_push(ECL_PROTECT_TAG) != 0) { frs_pop(the_env); vector = (cl_opcode *)cl_stack_pop(); lex_env = cl_stack_pop(); - cl_stack_push(MAKE_FIXNUM(the_env->nlj_fr - the_env->frs_top)); + ecl_stack_push(the_env, MAKE_FIXNUM(the_env->nlj_fr - the_env->frs_top)); goto PUSH_VALUES; } THREAD_NEXT; @@ -1192,7 +1199,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) frs_pop(the_env); cl_stack_pop(); lex_env = cl_stack_pop(); - cl_stack_push(MAKE_FIXNUM(1)); + ecl_stack_push(the_env, MAKE_FIXNUM(1)); goto PUSH_VALUES; } CASE(OP_PROTECT_EXIT); { @@ -1225,7 +1232,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) values = ECL_CONS_CDR(values); } } - cl_stack_push(MAKE_FIXNUM(n)); + ecl_stack_push(the_env, MAKE_FIXNUM(n)); THREAD_NEXT; } CASE(OP_EXIT_PROGV); { @@ -1243,7 +1250,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) * what to do. */ ECL_SETQ(@'si::*step-level*', cl_1P(SYM_VAL(@'si::*step-level*'))); - cl_stack_push(form); + ecl_stack_push(the_env, form); interpret_funcall(lex_env, 1, @'si::stepper'); } else if (a != Cnil) { /* The user told us to step over. *step-level* contains @@ -1263,7 +1270,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) * that. */ cl_fixnum n = GET_OPARG(vector); if (SYM_VAL(@'si::*step-action*') == Ct) { - cl_stack_push(reg0); + ecl_stack_push(the_env, reg0); reg0 = interpret_funcall(lex_env, 1, @'si::stepper'); } reg0 = interpret_funcall(lex_env, n, reg0); From 0c3af3fbc8e9a8c8f70116a15c1fb7d942671b16 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 15:02:27 +0000 Subject: [PATCH 28/71] ecl_interpret returns the first value --- src/c/compiler.d | 8 +++++--- src/c/interpreter.d | 19 ++++++++----------- src/h/external.h | 2 +- 3 files changed, 14 insertions(+), 15 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index 6865cde3f..0a1dfc26a 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -1540,7 +1540,7 @@ c_nth_value(cl_object args, int flags) { if (args != Cnil) FEprogram_error("NTH-VALUE: Too many arguments.",0); asm_op(OP_NTHVAL); - return FLAG_VALUES; + return FLAG_REG0; } @@ -2562,12 +2562,14 @@ si_make_lambda(cl_object name, cl_object rest) ihs_push(&ihs, bytecodes, Cnil); VALUES(0) = Cnil; NVALUES = 0; - ecl_interpret(interpreter_env, bytecodes, bytecodes->bytecodes.code); + { + cl_object output = ecl_interpret(interpreter_env, bytecodes, bytecodes->bytecodes.code); #ifdef GBC_BOEHM GC_free(bytecodes->bytecodes.code); GC_free(bytecodes->bytecodes.data); GC_free(bytecodes); #endif ihs_pop(); - return VALUES(0); + return output; + } @) diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 7986b4128..a21761030 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -332,8 +332,7 @@ lambda_bind(cl_object env, cl_narg narg, cl_object lambda, cl_object *sp) } else { cl_object defaults = data[1]; if (FIXNUMP(defaults)) { - ecl_interpret(env, lambda, (cl_opcode*)lambda->bytecodes.code + fix(defaults)); - defaults = VALUES(0); + defaults = ecl_interpret(env, lambda, (cl_opcode*)lambda->bytecodes.code + fix(defaults)); } env = lambda_bind_var(env, data[0], defaults, specials); if (!Null(data[2])) { @@ -422,8 +421,7 @@ lambda_bind(cl_object env, cl_narg narg, cl_object lambda, cl_object *sp) } else { cl_object defaults = data[2]; if (FIXNUMP(defaults)) { - ecl_interpret(env, lambda, (cl_opcode*)lambda->bytecodes.code + fix(defaults)); - defaults = VALUES(0); + defaults = ecl_interpret(env, lambda, (cl_opcode*)lambda->bytecodes.code + fix(defaults)); } env = lambda_bind_var(env, data[1],defaults,specials); } @@ -454,9 +452,9 @@ ecl_apply_lambda(cl_object frame, cl_object fun) VALUES(0) = Cnil; NVALUES = 0; name = fun->bytecodes.name; - ecl_interpret(env, fun, fun->bytecodes.code); + fun = ecl_interpret(env, fun, fun->bytecodes.code); bds_unwind(old_bds_top); - returnn(VALUES(0)); + return fun; } @@ -513,7 +511,7 @@ close_around(cl_object fun, cl_object lex) { } \ *(the_env->stack_top++) = __aux; } -void * +cl_object ecl_interpret(cl_object env, cl_object bytecodes, void *pc) { ECL_OFFSET_TABLE; @@ -682,7 +680,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) */ CASE(OP_EXIT); { ihs_pop(); - return (char *)vector; + return VALUES(0); } /* OP_FLET nfun{arg} fun1{object} @@ -1160,11 +1158,10 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) if (n < 0) { FEerror("Wrong index passed to NTH-VAL", 1, MAKE_FIXNUM(n)); } else if ((cl_index)n >= the_env->nvalues) { - the_env->values[0] = reg0 = Cnil; + reg0 = Cnil; } else { - the_env->values[0] = reg0 = the_env->values[n]; + reg0 = the_env->values[n]; } - the_env->nvalues = 1; THREAD_NEXT; } /* OP_PROTECT label diff --git a/src/h/external.h b/src/h/external.h index cb7dbe83e..86055e3f3 100644 --- a/src/h/external.h +++ b/src/h/external.h @@ -459,7 +459,7 @@ extern ECL_API cl_index cl_stack_push_values(void); extern ECL_API void cl_stack_pop_values(cl_index n); extern ECL_API cl_object ecl_apply_lambda(cl_object frame, cl_object fun); -extern ECL_API void *ecl_interpret(cl_object env, cl_object bytecodes, void *pc); +extern ECL_API cl_object ecl_interpret(cl_object env, cl_object bytecodes, void *pc); /* disassembler.c */ From 5aa07e402daa511c16b20b7b8d033ae1df754f8b Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 15:02:40 +0000 Subject: [PATCH 29/71] Only use OP_VBIND[S] for values other than 0-th --- src/c/compiler.d | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index 0a1dfc26a..cee4b4476 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -1402,10 +1402,18 @@ c_multiple_value_bind(cl_object args, int flags) FEillegal_variable_name(var); if (c_declared_special(var, specials)) { c_register_var(var, FLAG_PUSH, TRUE); - asm_op2(OP_VBINDS, n); + if (n) { + asm_op2(OP_VBINDS, n); + } else { + asm_op(OP_BINDS); + } } else { c_register_var(var, FALSE, TRUE); - asm_op2(OP_VBIND, n); + if (n) { + asm_op2(OP_VBIND, n); + } else { + asm_op(OP_BIND); + } } asm_c(var); } From ce724349c5f8bc20ff1adca103c799bc2ac3cb92 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 15:02:58 +0000 Subject: [PATCH 30/71] Split operator MSETQ into VSETQ and VSETQS. --- src/c/compiler.d | 27 +++++++++++++-------- src/c/disassembler.d | 48 ++++++------------------------------ src/c/interpreter.d | 58 +++++++++++++++----------------------------- src/h/bytecodes.h | 6 +++-- 4 files changed, 49 insertions(+), 90 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index cee4b4476..b680db959 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -1464,7 +1464,7 @@ c_multiple_value_setq(cl_object orig_args, int flags) { cl_object orig_vars; cl_object vars = Cnil, values; cl_object old_variables = ENV->variables; - cl_index nvars = 0; + cl_index i, nvars = 0; /* Look for symbol macros, building the list of variables and the list of late assignments. */ @@ -1498,22 +1498,29 @@ c_multiple_value_setq(cl_object orig_args, int flags) { compile_form(values, FLAG_VALUES); /* Compile variables */ - asm_op2(OP_MSETQ, nvars); vars = cl_nreverse(vars); - while (nvars--) { + for (i = 0; i < nvars; i++) { cl_object var = pop(&vars); - cl_fixnum ndx = c_var_ref(var,0,TRUE); - if (ndx < 0) { /* Global variable */ - if (ecl_symbol_type(var) & stp_constant) - FEassignment_to_constant(var); - ndx = -1-c_register_constant(var); + /* Note that we only use VSETQ[S] for values other than 0 */ + if (i == 0) { + compile_setq(OP_SETQ, var); + } else { + cl_fixnum ndx = c_var_ref(var,0,TRUE); + if (ndx < 0) { /* Global variable */ + if (ecl_symbol_type(var) & stp_constant) + FEassignment_to_constant(var); + asm_op2(OP_VSETQS, i); + asm_c(var); + } else { + asm_op2(OP_VSETQ, i); + asm_arg(ndx); + } } - asm_arg(ndx); } c_undo_bindings(old_variables); - return FLAG_VALUES; + return FLAG_REG0; } /* diff --git a/src/c/disassembler.d b/src/c/disassembler.d index fe71c9ad1..604148b86 100644 --- a/src/c/disassembler.d +++ b/src/c/disassembler.d @@ -154,44 +154,6 @@ disassemble_labels(cl_object bytecodes, cl_opcode *vector) { return vector; } -/* OP_MSETQ n{arg} - {fixnumn} - ... - {fixnum1} - - Sets N variables to the N values in VALUES(), filling with - NIL when there are values missing. Local variables are denoted - with an integer which points a position in the lexical environment, - while special variables are denoted with a negative index X, which - denotes the value -1-X in the table of constants. -*/ -static cl_opcode * -disassemble_msetq(cl_object bytecodes, cl_opcode *vector) -{ - int i, n = GET_OPARG(vector); - bool newline = FALSE; - - for (i=0; i= 0) { - cl_format(4, Ct, - make_constant_base_string("MSETQ\t~D,VALUES(~D)"), - MAKE_FIXNUM(var), MAKE_FIXNUM(i)); - } else { - cl_object name = bytecodes->bytecodes.data[-1-var]; - cl_format(4, Ct, - make_constant_base_string("MSETQS\t~A,VALUES(~D)"), - name, MAKE_FIXNUM(i)); - } - } - return vector; -} - - /* OP_PROGV bindings{list} ... OP_EXIT @@ -569,15 +531,21 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { case OP_PSETQ: string = "PSETQ\t"; n = GET_OPARG(vector); goto OPARG; + case OP_VSETQ: string = "VSETQ\t"; + n = GET_OPARG(vector); + o = MAKE_FIXNUM(GET_OPARG(vector)); + goto OPARG_ARG; case OP_SETQS: string = "SETQS\t"; o = GET_DATA(vector, bytecodes); goto ARG; case OP_PSETQS: string = "PSETQS\t"; o = GET_DATA(vector, bytecodes); goto ARG; + case OP_VSETQS: string = "VSETQS\t"; + n = GET_OPARG(vector); + o = GET_DATA(vector, bytecodes); + goto OPARG_ARG; - case OP_MSETQ: vector = disassemble_msetq(bytecodes, vector); - break; case OP_PROGV: vector = disassemble_progv(bytecodes, vector); break; diff --git a/src/c/interpreter.d b/src/c/interpreter.d index a21761030..1e373a93e 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -903,11 +903,14 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) } /* OP_SETQ n{arg} OP_PSETQ n{arg} + OP_VSETQ nval{arg}, n{arg} OP_SETQS var-name{symbol} OP_PSETQS var-name{symbol} + OP_VSETQS nval{arg}, var-name{symbol} Sets either the n-th local or a special variable VAR-NAME, - to either the value in REG0 (OP_SETQ[S]) or to the - first value on the stack (OP_PSETQ[S]). + to either the value in REG0 (OP_SETQ[S]), or to the + first value on the stack (OP_PSETQ[S]), or to the appropriate + value of the values list. */ CASE(OP_SETQ); { int lex_env_index = GET_OPARG(vector); @@ -935,6 +938,21 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) ECL_SETQ(var, cl_stack_pop()); THREAD_NEXT; } + CASE(OP_VSETQ); { + int nval = GET_OPARG(vector); + int lex_env_index = GET_OPARG(vector); + ecl_lex_env_set_var(lex_env, lex_env_index, the_env->values[nval]); + THREAD_NEXT; + } + CASE(OP_VSETQS); { + int nval = GET_OPARG(vector); + cl_object var = GET_DATA(vector, bytecodes); + /* INV: Not NIL, and of type t_symbol */ + if (var->symbol.stype & stp_constant) + FEassignment_to_constant(var); + ECL_SETQ(var, the_env->values[nval]); + THREAD_NEXT; + } /* OP_BLOCK label{arg} ... @@ -1048,42 +1066,6 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) the_env->nvalues = 1; THREAD_NEXT; } - /* OP_MSETQ n{arg} - {fixnumn} - ... - {fixnum1} - - Sets N variables to the N values in VALUES(), filling with - NIL when there are values missing. Local variables are denoted - with an integer which points a position in the lexical environment, - while special variables are denoted with a negative index X, which - denotes the value -1-X in the table of constants. - */ - CASE(OP_MSETQ); { - cl_object value; - cl_index i, n = GET_OPARG(vector), nv = the_env->nvalues; - for (i=0; ivalues[i] : Cnil; - if (var >= 0) { - ecl_lex_env_set_var(lex_env, var, value); - } else { - cl_object name = bytecodes->bytecodes.data[-1-var]; - if (Null(name) || (name->symbol.stype & stp_constant)) { - FEassignment_to_constant(name); - } - ECL_SETQ(name, value); - } - } - if (nv == 0) { - the_env->values[0] = reg0 = Cnil; - } else { - reg0 = the_env->values[0]; - } - the_env->nvalues = 1; - THREAD_NEXT; - } - /* OP_PUSHVALUES Pushes the values output by the last form, plus the number of values. diff --git a/src/h/bytecodes.h b/src/h/bytecodes.h index 02d498cb5..006571e1f 100644 --- a/src/h/bytecodes.h +++ b/src/h/bytecodes.h @@ -165,6 +165,8 @@ enum { OP_SETQS, OP_PSETQ, OP_PSETQS, + OP_VSETQ, + OP_VSETQS, OP_BLOCK, OP_DO, OP_CATCH, @@ -174,7 +176,6 @@ enum { OP_PROTECT, OP_PROTECT_NORMAL, OP_PROTECT_EXIT, - OP_MSETQ, OP_PROGV, OP_EXIT_PROGV, OP_PUSHVALUES, @@ -287,6 +288,8 @@ typedef int16_t cl_oparg; &&LBL_OP_SETQS - &&LBL_OP_NOP,\ &&LBL_OP_PSETQ - &&LBL_OP_NOP,\ &&LBL_OP_PSETQS - &&LBL_OP_NOP,\ + &&LBL_OP_VSETQ - &&LBL_OP_NOP,\ + &&LBL_OP_VSETQS - &&LBL_OP_NOP,\ &&LBL_OP_BLOCK - &&LBL_OP_NOP,\ &&LBL_OP_DO - &&LBL_OP_NOP,\ &&LBL_OP_CATCH - &&LBL_OP_NOP,\ @@ -296,7 +299,6 @@ typedef int16_t cl_oparg; &&LBL_OP_PROTECT - &&LBL_OP_NOP,\ &&LBL_OP_PROTECT_NORMAL - &&LBL_OP_NOP,\ &&LBL_OP_PROTECT_EXIT - &&LBL_OP_NOP,\ - &&LBL_OP_MSETQ - &&LBL_OP_NOP,\ &&LBL_OP_PROGV - &&LBL_OP_NOP,\ &&LBL_OP_EXIT_PROGV - &&LBL_OP_NOP,\ &&LBL_OP_PUSHVALUES - &&LBL_OP_NOP,\ From 83c35e01c25a3a45168a7a6953489b6d5d38c1a2 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 15:03:12 +0000 Subject: [PATCH 31/71] SETQS does not check whether argument is constant, just as in SBCL. --- src/c/interpreter.d | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 1e373a93e..3b0f69e5a 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -933,8 +933,6 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) CASE(OP_PSETQS); { cl_object var = GET_DATA(vector, bytecodes); /* INV: Not NIL, and of type t_symbol */ - if (var->symbol.stype & stp_constant) - FEassignment_to_constant(var); ECL_SETQ(var, cl_stack_pop()); THREAD_NEXT; } @@ -948,8 +946,6 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) int nval = GET_OPARG(vector); cl_object var = GET_DATA(vector, bytecodes); /* INV: Not NIL, and of type t_symbol */ - if (var->symbol.stype & stp_constant) - FEassignment_to_constant(var); ECL_SETQ(var, the_env->values[nval]); THREAD_NEXT; } From 271d33ee3f9967cf1c59331be02f4b45740b28bb Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 15:03:28 +0000 Subject: [PATCH 32/71] Slightly leaner code for searching environment --- src/c/interpreter.d | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 3b0f69e5a..827c5980f 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -283,10 +283,13 @@ internal_lex_env_error() } static cl_object -ecl_lex_env_get_record(register cl_object env, register int s) { - for (; s-- > 0; env = CDR(env)); - if (Null(env)) internal_lex_env_error(); - return CAR(env); +ecl_lex_env_get_record(register cl_object env, register int s) +{ + do { + if (Null(env)) internal_lex_env_error(); + if (s-- == 0) return ECL_CONS_CAR(env); + env = ECL_CONS_CDR(env); + } while(1); } #define ecl_lex_env_get_var(env,x) ECL_CONS_CDR(ecl_lex_env_get_record(env,x)) From 590129c767838b3ec438cc6f6468ad36da857ba8 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 15:03:40 +0000 Subject: [PATCH 33/71] No need to check when searching environments --- src/c/interpreter.d | 7 ------- 1 file changed, 7 deletions(-) diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 827c5980f..71385947e 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -276,17 +276,10 @@ ecl_stack_frame_copy(cl_object dest, cl_object orig) #define bind_function(env, name, fun) CONS(CONS(fun, name), (env)) #define bind_tagbody(env, id) CONS(CONS(id, MAKE_FIXNUM(0)), (env)) -static void -internal_lex_env_error() -{ - FEerror("Internal error: local not found.", 0); -} - static cl_object ecl_lex_env_get_record(register cl_object env, register int s) { do { - if (Null(env)) internal_lex_env_error(); if (s-- == 0) return ECL_CONS_CAR(env); env = ECL_CONS_CDR(env); } while(1); From b2d1a996b32ea5cb4647cdf93c67035f4f5367c2 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 15:03:56 +0000 Subject: [PATCH 34/71] More compact format for bytecodes OP_FLET/LABELS --- src/c/compiler.d | 20 +++++++++++++------- src/c/disassembler.d | 18 ++++++++---------- src/c/interpreter.d | 19 ++++++++++--------- 3 files changed, 31 insertions(+), 26 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index b680db959..9ce02b33f 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -1082,12 +1082,9 @@ c_eval_when(cl_object args, int flags) { The OP_FLET/OP_FLABELS operators change the lexical environment to add a few local functions. - [OP_FLET/OP_FLABELS + nfun] - fun1 + [OP_FLET/OP_FLABELS + nfun + fun1] ... - fun2 - ... - OP_UNBIND n + OP_UNBIND nfun labelz: */ static cl_index @@ -1106,7 +1103,11 @@ static int c_labels_flet(int op, cl_object args, int flags) { cl_object l, def_list = pop(&args); struct cl_compiler_env *old_c_env, new_c_env; - cl_index nfun; + cl_index nfun, first = 0; + + if (ecl_length(def_list) == 0) { + return c_locally(args, flags); + } old_c_env = ENV; new_c_env = *ENV; @@ -1129,7 +1130,12 @@ c_labels_flet(int op, cl_object args, int flags) { for (l = def_list; !ecl_endp(l); ) { cl_object definition = pop(&l); cl_object name = pop(&definition); - asm_c(ecl_make_lambda(name, definition)); + cl_object lambda = ecl_make_lambda(name, definition); + cl_index c = c_register_constant(lambda); + if (first == 0) { + asm_arg(c); + first = 1; + } } /* If compiling a FLET form, add the function names to the lexical diff --git a/src/c/disassembler.d b/src/c/disassembler.d index 604148b86..fb5f2cb26 100644 --- a/src/c/disassembler.d +++ b/src/c/disassembler.d @@ -114,10 +114,7 @@ NO_ARGS: /* -------------------- DISASSEMBLER CORE -------------------- */ -/* OP_FLET nfun{arg} - fun1{object} - ... - funn{object} +/* OP_FLET nfun{arg}, fun1{object} ... Executes the enclosed code in a lexical enviroment extended with @@ -126,18 +123,17 @@ NO_ARGS: static cl_opcode * disassemble_flet(cl_object bytecodes, cl_opcode *vector) { cl_index nfun = GET_OPARG(vector); + cl_index first = GET_OPARG(vector); + cl_object *data = bytecodes->bytecodes.data + first; print_noarg("FLET"); while (nfun--) { - cl_object fun = GET_DATA(vector, bytecodes); + cl_object fun = *(data++); print_arg("\n\tFLET\t", fun->bytecodes.name); } return vector; } -/* OP_LABELS nfun{arg} - fun1{object} - ... - funn{object} +/* OP_LABELS nfun{arg}, fun1{object} ... Executes the enclosed code in a lexical enviroment extended with @@ -146,9 +142,11 @@ disassemble_flet(cl_object bytecodes, cl_opcode *vector) { static cl_opcode * disassemble_labels(cl_object bytecodes, cl_opcode *vector) { cl_index nfun = GET_OPARG(vector); + cl_index first = GET_OPARG(vector); + cl_object *data = bytecodes->bytecodes.data + first; print_noarg("LABELS"); while (nfun--) { - cl_object fun = GET_DATA(vector, bytecodes); + cl_object fun = *(data++); print_arg("\n\tLABELS\t", fun->bytecodes.name); } return vector; diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 71385947e..89f5523f3 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -678,25 +678,24 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) ihs_pop(); return VALUES(0); } - /* OP_FLET nfun{arg} - fun1{object} + /* OP_FLET nfun{arg}, fun1{object} ... - funn{object} - ... - OP_UNBIND n + OP_UNBIND nfun Executes the enclosed code in a lexical enviroment extended with - the functions "fun1" ... "funn". + the functions "fun1" ... "funn". Note that we only record the + index of the first function: the others are after this one. */ CASE(OP_FLET); { cl_index nfun = GET_OPARG(vector); + cl_index first = GET_OPARG(vector); + cl_object *fun = bytecodes->bytecodes.data + first; /* Copy the environment so that functions get it without references to themselves, and then add new closures to the environment. */ cl_object old_lex = lex_env; cl_object new_lex = old_lex; while (nfun--) { - cl_object fun = GET_DATA(vector, bytecodes); - cl_object f = close_around(fun, old_lex); + cl_object f = close_around(*(fun++), old_lex); new_lex = bind_function(new_lex, f->bytecodes.name, f); } lex_env = new_lex; @@ -714,10 +713,12 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) */ CASE(OP_LABELS); { cl_index i, nfun = GET_OPARG(vector); + cl_index first = GET_OPARG(vector); + cl_object *fun = bytecodes->bytecodes.data + first; cl_object l, new_lex; /* Build up a new environment with all functions */ for (new_lex = lex_env, i = nfun; i; i--) { - cl_object f = GET_DATA(vector, bytecodes); + cl_object f = *(fun++); new_lex = bind_function(new_lex, f->bytecodes.name, f); } /* Update the closures so that all functions can call each other */ From 77d53061ebe1f374dd2c2ecc5702d963b5f14b58 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 15:04:12 +0000 Subject: [PATCH 35/71] Revert to the old code for multiple-value-setq --- src/c/compiler.d | 27 ++++++++------------- src/c/disassembler.d | 48 ++++++++++++++++++++++++++++++------- src/c/interpreter.d | 56 ++++++++++++++++++++++++++++++-------------- src/h/bytecodes.h | 6 ++--- 4 files changed, 90 insertions(+), 47 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index 9ce02b33f..30ff774cc 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -1470,7 +1470,7 @@ c_multiple_value_setq(cl_object orig_args, int flags) { cl_object orig_vars; cl_object vars = Cnil, values; cl_object old_variables = ENV->variables; - cl_index i, nvars = 0; + cl_index nvars = 0; /* Look for symbol macros, building the list of variables and the list of late assignments. */ @@ -1504,29 +1504,22 @@ c_multiple_value_setq(cl_object orig_args, int flags) { compile_form(values, FLAG_VALUES); /* Compile variables */ + asm_op2(OP_MSETQ, nvars); vars = cl_nreverse(vars); - for (i = 0; i < nvars; i++) { + while (nvars--) { cl_object var = pop(&vars); - /* Note that we only use VSETQ[S] for values other than 0 */ - if (i == 0) { - compile_setq(OP_SETQ, var); - } else { - cl_fixnum ndx = c_var_ref(var,0,TRUE); - if (ndx < 0) { /* Global variable */ - if (ecl_symbol_type(var) & stp_constant) - FEassignment_to_constant(var); - asm_op2(OP_VSETQS, i); - asm_c(var); - } else { - asm_op2(OP_VSETQ, i); - asm_arg(ndx); - } + cl_fixnum ndx = c_var_ref(var,0,TRUE); + if (ndx < 0) { /* Global variable */ + if (ecl_symbol_type(var) & stp_constant) + FEassignment_to_constant(var); + ndx = -1-c_register_constant(var); } + asm_arg(ndx); } c_undo_bindings(old_variables); - return FLAG_REG0; + return FLAG_VALUES; } /* diff --git a/src/c/disassembler.d b/src/c/disassembler.d index fb5f2cb26..b72441f85 100644 --- a/src/c/disassembler.d +++ b/src/c/disassembler.d @@ -152,6 +152,44 @@ disassemble_labels(cl_object bytecodes, cl_opcode *vector) { return vector; } +/* OP_MSETQ n{arg} + {fixnumn} + ... + {fixnum1} + + Sets N variables to the N values in VALUES(), filling with + NIL when there are values missing. Local variables are denoted + with an integer which points a position in the lexical environment, + while special variables are denoted with a negative index X, which + denotes the value -1-X in the table of constants. +*/ +static cl_opcode * +disassemble_msetq(cl_object bytecodes, cl_opcode *vector) +{ + int i, n = GET_OPARG(vector); + bool newline = FALSE; + + for (i=0; i= 0) { + cl_format(4, Ct, + make_constant_base_string("MSETQ\t~D,VALUES(~D)"), + MAKE_FIXNUM(var), MAKE_FIXNUM(i)); + } else { + cl_object name = bytecodes->bytecodes.data[-1-var]; + cl_format(4, Ct, + make_constant_base_string("MSETQS\t~A,VALUES(~D)"), + name, MAKE_FIXNUM(i)); + } + } + return vector; +} + + /* OP_PROGV bindings{list} ... OP_EXIT @@ -529,21 +567,15 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { case OP_PSETQ: string = "PSETQ\t"; n = GET_OPARG(vector); goto OPARG; - case OP_VSETQ: string = "VSETQ\t"; - n = GET_OPARG(vector); - o = MAKE_FIXNUM(GET_OPARG(vector)); - goto OPARG_ARG; case OP_SETQS: string = "SETQS\t"; o = GET_DATA(vector, bytecodes); goto ARG; case OP_PSETQS: string = "PSETQS\t"; o = GET_DATA(vector, bytecodes); goto ARG; - case OP_VSETQS: string = "VSETQS\t"; - n = GET_OPARG(vector); - o = GET_DATA(vector, bytecodes); - goto OPARG_ARG; + case OP_MSETQ: vector = disassemble_msetq(bytecodes, vector); + break; case OP_PROGV: vector = disassemble_progv(bytecodes, vector); break; diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 89f5523f3..bb3302fe4 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -900,14 +900,11 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) } /* OP_SETQ n{arg} OP_PSETQ n{arg} - OP_VSETQ nval{arg}, n{arg} OP_SETQS var-name{symbol} OP_PSETQS var-name{symbol} - OP_VSETQS nval{arg}, var-name{symbol} Sets either the n-th local or a special variable VAR-NAME, - to either the value in REG0 (OP_SETQ[S]), or to the - first value on the stack (OP_PSETQ[S]), or to the appropriate - value of the values list. + to either the value in REG0 (OP_SETQ[S]) or to the + first value on the stack (OP_PSETQ[S]). */ CASE(OP_SETQ); { int lex_env_index = GET_OPARG(vector); @@ -933,19 +930,6 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) ECL_SETQ(var, cl_stack_pop()); THREAD_NEXT; } - CASE(OP_VSETQ); { - int nval = GET_OPARG(vector); - int lex_env_index = GET_OPARG(vector); - ecl_lex_env_set_var(lex_env, lex_env_index, the_env->values[nval]); - THREAD_NEXT; - } - CASE(OP_VSETQS); { - int nval = GET_OPARG(vector); - cl_object var = GET_DATA(vector, bytecodes); - /* INV: Not NIL, and of type t_symbol */ - ECL_SETQ(var, the_env->values[nval]); - THREAD_NEXT; - } /* OP_BLOCK label{arg} ... @@ -1059,6 +1043,42 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) the_env->nvalues = 1; THREAD_NEXT; } + /* OP_MSETQ n{arg} + {fixnumn} + ... + {fixnum1} + + Sets N variables to the N values in VALUES(), filling with + NIL when there are values missing. Local variables are denoted + with an integer which points a position in the lexical environment, + while special variables are denoted with a negative index X, which + denotes the value -1-X in the table of constants. + */ + CASE(OP_MSETQ); { + cl_object value; + cl_index i, n = GET_OPARG(vector), nv = the_env->nvalues; + for (i=0; ivalues[i] : Cnil; + if (var >= 0) { + ecl_lex_env_set_var(lex_env, var, value); + } else { + cl_object name = bytecodes->bytecodes.data[-1-var]; + if (Null(name) || (name->symbol.stype & stp_constant)) { + FEassignment_to_constant(name); + } + ECL_SETQ(name, value); + } + } + if (nv == 0) { + the_env->values[0] = reg0 = Cnil; + } else { + reg0 = the_env->values[0]; + } + the_env->nvalues = 1; + THREAD_NEXT; + } + /* OP_PUSHVALUES Pushes the values output by the last form, plus the number of values. diff --git a/src/h/bytecodes.h b/src/h/bytecodes.h index 006571e1f..02d498cb5 100644 --- a/src/h/bytecodes.h +++ b/src/h/bytecodes.h @@ -165,8 +165,6 @@ enum { OP_SETQS, OP_PSETQ, OP_PSETQS, - OP_VSETQ, - OP_VSETQS, OP_BLOCK, OP_DO, OP_CATCH, @@ -176,6 +174,7 @@ enum { OP_PROTECT, OP_PROTECT_NORMAL, OP_PROTECT_EXIT, + OP_MSETQ, OP_PROGV, OP_EXIT_PROGV, OP_PUSHVALUES, @@ -288,8 +287,6 @@ typedef int16_t cl_oparg; &&LBL_OP_SETQS - &&LBL_OP_NOP,\ &&LBL_OP_PSETQ - &&LBL_OP_NOP,\ &&LBL_OP_PSETQS - &&LBL_OP_NOP,\ - &&LBL_OP_VSETQ - &&LBL_OP_NOP,\ - &&LBL_OP_VSETQS - &&LBL_OP_NOP,\ &&LBL_OP_BLOCK - &&LBL_OP_NOP,\ &&LBL_OP_DO - &&LBL_OP_NOP,\ &&LBL_OP_CATCH - &&LBL_OP_NOP,\ @@ -299,6 +296,7 @@ typedef int16_t cl_oparg; &&LBL_OP_PROTECT - &&LBL_OP_NOP,\ &&LBL_OP_PROTECT_NORMAL - &&LBL_OP_NOP,\ &&LBL_OP_PROTECT_EXIT - &&LBL_OP_NOP,\ + &&LBL_OP_MSETQ - &&LBL_OP_NOP,\ &&LBL_OP_PROGV - &&LBL_OP_NOP,\ &&LBL_OP_EXIT_PROGV - &&LBL_OP_NOP,\ &&LBL_OP_PUSHVALUES - &&LBL_OP_NOP,\ From 9a5f1a7751cbc63bf4ec99870931715441be9122 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 15:04:27 +0000 Subject: [PATCH 36/71] Introduce bytecode closure objects to save space in FLET/LABELS forms --- src/c/alloc.d | 5 +++++ src/c/alloc_2.d | 2 ++ src/c/cfun.d | 6 +++++- src/c/compiler.d | 1 - src/c/disassembler.d | 13 ++++++++++++- src/c/eval.d | 6 ++++++ src/c/gbc.d | 5 +++++ src/c/instance.d | 1 + src/c/interpreter.d | 33 +++++++++++++++++++++++++++++---- src/c/predicate.d | 4 ++-- src/c/print.d | 23 ++++++++++++++++++++++- src/c/read.d | 10 ++++++++-- src/c/reference.d | 2 +- src/c/stacks.d | 3 +++ src/c/typespec.d | 1 + src/h/external.h | 1 + src/h/object.h | 11 +++++++++-- 17 files changed, 112 insertions(+), 15 deletions(-) diff --git a/src/c/alloc.d b/src/c/alloc.d index 48c6f919b..fae1dd5b0 100644 --- a/src/c/alloc.d +++ b/src/c/alloc.d @@ -374,6 +374,10 @@ ONCE_MORE: obj->bytecodes.data_size = 0; obj->bytecodes.data = NULL; break; + case t_bclosure: + obj->bclosure.code = + obj->bclosure.lex = Cnil; + break; case t_cfun: obj->cfun.name = OBJNULL; obj->cfun.block = NULL; @@ -719,6 +723,7 @@ init_alloc(void) init_tm(t_doublefloat, "LDOUBLE-FLOAT", /* 16 */ sizeof(struct ecl_doublefloat), 1); init_tm(t_bytecodes, "bBYTECODES", sizeof(struct ecl_bytecodes), 64); + init_tm(t_bytecodes, "bBCLOSURE", sizeof(struct ecl_bclosure), 64); init_tm(t_base_string, "\"BASE-STRING", sizeof(struct ecl_base_string), 64); /* 20 */ #ifdef ECL_UNICODE init_tm(t_string, "\"STRING", sizeof(struct ecl_string), 64); diff --git a/src/c/alloc_2.d b/src/c/alloc_2.d index eb92547b1..503a70633 100644 --- a/src/c/alloc_2.d +++ b/src/c/alloc_2.d @@ -94,6 +94,7 @@ cl_alloc_object(cl_type t) case t_readtable: case t_pathname: case t_bytecodes: + case t_bclosure: case t_cfun: case t_cclosure: #ifdef CLOS @@ -223,6 +224,7 @@ init_alloc(void) init_tm(t_doublefloat, "DOUBLE-FLOAT", /* 16 */ sizeof(struct ecl_doublefloat)); init_tm(t_bytecodes, "BYTECODES", sizeof(struct ecl_bytecodes)); + init_tm(t_bclosure, "BCLOSURE", sizeof(struct ecl_bclosure)); init_tm(t_base_string, "BASE-STRING", sizeof(struct ecl_base_string)); /* 20 */ #ifdef ECL_UNICODE init_tm(t_string, "STRING", sizeof(struct ecl_string)); diff --git a/src/c/cfun.d b/src/c/cfun.d index 498a42a6c..6c2942a2b 100644 --- a/src/c/cfun.d +++ b/src/c/cfun.d @@ -88,6 +88,8 @@ si_compiled_function_name(cl_object fun) cl_object output; switch(type_of(fun)) { + case t_bclosure: + output = fun->bclosure.code; case t_bytecodes: output = fun->bytecodes.name; break; case t_cfun: @@ -106,8 +108,10 @@ cl_function_lambda_expression(cl_object fun) cl_object output, name = Cnil, lex = Cnil; switch(type_of(fun)) { + case t_bclosure: + lex = fun->bclosure.lex; + fun = fun->bclosure.code; case t_bytecodes: - lex = fun->bytecodes.lex; name = fun->bytecodes.name; output = fun->bytecodes.definition; if (!CONSP(output)) diff --git a/src/c/compiler.d b/src/c/compiler.d index 30ff774cc..79a1458a8 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -156,7 +156,6 @@ asm_end(cl_index beginning) { bytecodes->bytecodes.data_size = data_size; bytecodes->bytecodes.code = cl_alloc_atomic(code_size * sizeof(cl_opcode)); bytecodes->bytecodes.data = (cl_object*)cl_alloc(data_size * sizeof(cl_object)); - bytecodes->bytecodes.lex = Cnil; bytecodes->bytecodes.file = (file == OBJNULL)? Cnil : file; bytecodes->bytecodes.file_position = (position == OBJNULL)? Cnil : position; for (i = 0, code = (cl_opcode *)bytecodes->bytecodes.code; i < code_size; i++) { diff --git a/src/c/disassembler.d b/src/c/disassembler.d index b72441f85..8b19888d9 100644 --- a/src/c/disassembler.d +++ b/src/c/disassembler.d @@ -649,6 +649,9 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { cl_object si_bc_disassemble(cl_object v) { + if (type_of(v) == t_bclosure) { + v = v->bclosure.code; + } if (type_of(v) == t_bytecodes) { disassemble_lambda(v); @(return v) @@ -661,19 +664,27 @@ si_bc_split(cl_object b) { cl_object vector; cl_object data; + cl_object lex = Cnil; + if (type_of(b) == t_bclosure) { + b = b->bclosure.code; + lex = b->bclosure.lex; + } if (type_of(b) != t_bytecodes) @(return Cnil Cnil) vector = ecl_alloc_simple_vector(b->bytecodes.code_size, aet_b8); vector->vector.self.b8 = (uint8_t*)b->bytecodes.code; data = ecl_alloc_simple_vector(b->bytecodes.data_size, aet_object); data->vector.self.t = b->bytecodes.data; - @(return b->bytecodes.lex vector data) + @(return lex vector data) } cl_object si_bc_file(cl_object b) { + if (type_of(b) == t_bclosure) { + b = b->bclosure.code; + } if (type_of(b) != t_bytecodes) { @(return Cnil Cnil); } else { diff --git a/src/c/eval.d b/src/c/eval.d index b5964352c..cf8b6cea6 100644 --- a/src/c/eval.d +++ b/src/c/eval.d @@ -98,6 +98,8 @@ ecl_apply_from_stack_frame(cl_object frame, cl_object x) goto AGAIN; case t_bytecodes: return ecl_apply_lambda(frame, fun); + case t_bclosure: + return ecl_apply_bclosure(frame, fun); default: ERROR: FEinvalid_function(x); @@ -166,6 +168,10 @@ _ecl_link_call(cl_object sym, cl_objectfn *pLK, cl_object cblock, int narg, cl_v frame = build_funcall_frame((cl_object)&frame_aux, args); out = ecl_apply_lambda(frame, fun); break; + case t_bclosure: + frame = build_funcall_frame((cl_object)&frame_aux, args); + out = ecl_apply_bclosure(frame, fun); + break; default: ERROR: FEinvalid_function(fun); diff --git a/src/c/gbc.d b/src/c/gbc.d index 1da296b79..341cb6a6e 100644 --- a/src/c/gbc.d +++ b/src/c/gbc.d @@ -358,6 +358,11 @@ BEGIN: i = x->bytecodes.data_size; goto MARK_DATA; + case t_bclosure: + mark_object(x->bclosure.code); + mark_next(x->bclosure.lex); + break; + case t_cfun: mark_object(x->cfun.block); mark_next(x->cfun.name); diff --git a/src/c/instance.d b/src/c/instance.d index 7b8c38141..901cb9b34 100644 --- a/src/c/instance.d +++ b/src/c/instance.d @@ -334,6 +334,7 @@ cl_class_of(cl_object x) case t_random: index = ECL_BUILTIN_RANDOM_STATE; break; case t_bytecodes: + case t_bclosure: case t_cfun: case t_cclosure: index = ECL_BUILTIN_FUNCTION; break; diff --git a/src/c/interpreter.d b/src/c/interpreter.d index bb3302fe4..64063ac20 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -439,7 +439,32 @@ ecl_apply_lambda(cl_object frame, cl_object fun) FEinvalid_function(fun); /* Save the lexical environment and set up a new one */ - env = fun->bytecodes.lex; + old_bds_top = cl_env.bds_top; + + /* Establish bindings */ + env = lambda_bind(Cnil, frame->frame.top - frame->frame.bottom, fun, frame->frame.bottom); + + VALUES(0) = Cnil; + NVALUES = 0; + name = fun->bytecodes.name; + fun = ecl_interpret(env, fun, fun->bytecodes.code); + bds_unwind(old_bds_top); + return fun; +} + + +cl_object +ecl_apply_bclosure(cl_object frame, cl_object fun) +{ + cl_object name, env; + bds_ptr old_bds_top; + + if (type_of(fun) != t_bclosure) + FEinvalid_function(fun); + + /* Save the lexical environment and set up a new one */ + env = fun->bclosure.lex; + fun = fun->bclosure.code; old_bds_top = cl_env.bds_top; /* Establish bindings */ @@ -489,9 +514,9 @@ interpret_funcall(cl_object lex_env, cl_narg narg, cl_object fun) static cl_object close_around(cl_object fun, cl_object lex) { - cl_object v = cl_alloc_object(t_bytecodes); - v->bytecodes = fun->bytecodes; - v->bytecodes.lex = lex; + cl_object v = cl_alloc_object(t_bclosure); + v->bclosure.code = fun; + v->bclosure.lex = lex; return v; } diff --git a/src/c/predicate.d b/src/c/predicate.d index 5f14cbc26..123e65868 100644 --- a/src/c/predicate.d +++ b/src/c/predicate.d @@ -228,7 +228,7 @@ cl_functionp(cl_object x) cl_object output; t = type_of(x); - if (t == t_bytecodes || t == t_cfun || t == t_cclosure + if (t == t_bytecodes || t == t_bclosure || t == t_cfun || t == t_cclosure #ifdef CLOS || (t == t_instance && x->instance.isgf) #endif @@ -243,7 +243,7 @@ cl_object cl_compiled_function_p(cl_object x) { cl_type t = type_of(x); - @(return ((t == t_bytecodes || t == t_cfun || t == t_cclosure) ? Ct : Cnil)) + @(return ((t == t_bytecodes || t == t_bclosure || t == t_cfun || t == t_cclosure) ? Ct : Cnil)) } cl_object diff --git a/src/c/print.d b/src/c/print.d index 12eda67ef..33a0f366e 100644 --- a/src/c/print.d +++ b/src/c/print.d @@ -1474,9 +1474,29 @@ si_write_ugly_object(cl_object x, cl_object stream) si_write_ugly_object(namestring, stream); break; } + case t_bclosure: + if ( ecl_print_readably() ) { + cl_index i; + cl_object lex = x->bclosure.lex; + cl_object code_l=Cnil, data_l=Cnil; + x = x->bclosure.code; + for ( i=x->bytecodes.code_size-1 ; i<(cl_index)(-1l) ; i-- ) + code_l = ecl_cons(MAKE_FIXNUM(((cl_opcode*)(x->bytecodes.code))[i]), code_l); + for ( i=x->bytecodes.data_size-1 ; i<(cl_index)(-1l) ; i-- ) + data_l = ecl_cons(x->bytecodes.data[i], data_l); + + write_str("#Y", stream); + si_write_ugly_object( + cl_list(6, x->bytecodes.name, lex, + x->bytecodes.specials, Cnil /* x->bytecodes.definition */, + code_l, data_l), + stream); + break; + } case t_bytecodes: if ( ecl_print_readably() ) { cl_index i; + cl_object lex = Cnil; cl_object code_l=Cnil, data_l=Cnil; for ( i=x->bytecodes.code_size-1 ; i<(cl_index)(-1l) ; i-- ) code_l = ecl_cons(MAKE_FIXNUM(((cl_opcode*)(x->bytecodes.code))[i]), code_l); @@ -1485,10 +1505,11 @@ si_write_ugly_object(cl_object x, cl_object stream) write_str("#Y", stream); si_write_ugly_object( - cl_list(6, x->bytecodes.name, x->bytecodes.lex, + cl_list(6, x->bytecodes.name, lex, x->bytecodes.specials, Cnil /* x->bytecodes.definition */, code_l, data_l), stream); + break; } else { cl_object name = x->bytecodes.name; write_str("#bytecodes.name = CAR(x); x = CDR(x); - rv->bytecodes.lex = CAR(x); x = CDR(x); + lex = CAR(x); x = CDR(x); rv->bytecodes.specials = CAR(x); x = CDR(x); rv->bytecodes.definition = CAR(x); x = CDR(x); @@ -842,6 +842,12 @@ sharp_Y_reader(cl_object in, cl_object c, cl_object d) for ( i=0, nth=CAR(x) ; !ecl_endp(nth) ; i++, nth=CDR(nth) ) ((cl_object*)(rv->bytecodes.data))[i] = CAR(nth); + if (lex != Cnil) { + cl_object x = cl_alloc_object(t_bclosure); + x->bclosure.code = rv; + x->bclosure.lex = lex; + rv = x; + } @(return rv); } diff --git a/src/c/reference.d b/src/c/reference.d index f46addf21..5f79c897f 100644 --- a/src/c/reference.d +++ b/src/c/reference.d @@ -112,7 +112,7 @@ cl_object si_coerce_to_function(cl_object fun) { cl_type t = type_of(fun); - if (!(t == t_cfun || t == t_cclosure || t == t_bytecodes + if (!(t == t_cfun || t == t_cclosure || t == t_bytecodes || t == t_bclosure #ifdef CLOS || (t == t_instance && fun->instance.isgf) #endif diff --git a/src/c/stacks.d b/src/c/stacks.d index 75df305c0..f076cd45d 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -175,6 +175,9 @@ ihs_function_name(cl_object x) case t_symbol: return(x); + case t_bclosure: + x = x->bclosure.code; + case t_bytecodes: y = x->bytecodes.name; if (Null(y)) diff --git a/src/c/typespec.d b/src/c/typespec.d index 3c93e1d12..23dec4e0e 100644 --- a/src/c/typespec.d +++ b/src/c/typespec.d @@ -181,6 +181,7 @@ ecl_type_to_symbol(cl_type t) case t_random: return @'random-state'; case t_bytecodes: + case t_bclosure: case t_cfun: case t_cclosure: return @'compiled-function'; diff --git a/src/h/external.h b/src/h/external.h index 86055e3f3..36d3b64a2 100644 --- a/src/h/external.h +++ b/src/h/external.h @@ -459,6 +459,7 @@ extern ECL_API cl_index cl_stack_push_values(void); extern ECL_API void cl_stack_pop_values(cl_index n); extern ECL_API cl_object ecl_apply_lambda(cl_object frame, cl_object fun); +extern ECL_API cl_object ecl_apply_bclosure(cl_object frame, cl_object fun); extern ECL_API cl_object ecl_interpret(cl_object env, cl_object bytecodes, void *pc); /* disassembler.c */ diff --git a/src/h/object.h b/src/h/object.h index 727186cfb..80ed81e9b 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -71,6 +71,7 @@ typedef enum { t_readtable, t_pathname, t_bytecodes, + t_bclosure, t_cfun, t_cclosure, #ifdef CLOS @@ -559,7 +560,6 @@ struct ecl_codeblock { struct ecl_bytecodes { HEADER; cl_object name; /* function name */ - cl_object lex; /* lexical environment */ cl_object specials; /* list of special variables */ cl_object definition; /* function definition in list form */ cl_index code_size; /* number of bytecodes */ @@ -570,6 +570,12 @@ struct ecl_bytecodes { cl_index file_position; /* and where it was created */ }; +struct ecl_bclosure { + HEADER; + cl_object code; + cl_object lex; +}; + struct ecl_cfun { /* compiled function header */ HEADER1(narg); cl_object name; /* compiled function name */ @@ -724,7 +730,8 @@ union cl_lispunion { struct ecl_random random; /* random-states */ struct ecl_readtable readtable; /* read table */ struct ecl_pathname pathname; /* path name */ - struct ecl_bytecodes bytecodes; /* bytecompiled closure */ + struct ecl_bytecodes bytecodes; /* bytecompiled function / code */ + struct ecl_bclosure bclosure; /* bytecompiled closure */ struct ecl_cfun cfun; /* compiled function */ struct ecl_cclosure cclosure; /* compiled closure */ From 90370c96d0d7ec8ce3fc679817dcf595291bb16f Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 15:04:54 +0000 Subject: [PATCH 37/71] Fixed typo in COMPILED-FUNCTION-NAME. --- src/c/cfun.d | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/c/cfun.d b/src/c/cfun.d index 6c2942a2b..c111880a5 100644 --- a/src/c/cfun.d +++ b/src/c/cfun.d @@ -89,7 +89,7 @@ si_compiled_function_name(cl_object fun) switch(type_of(fun)) { case t_bclosure: - output = fun->bclosure.code; + fun = fun->bclosure.code; case t_bytecodes: output = fun->bytecodes.name; break; case t_cfun: From 71ed18e2dbf67df30fee7a971fda2ea40446704f Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 15:05:08 +0000 Subject: [PATCH 38/71] Inline funcalls and fix problem with multiple-value-prog1 and macrolet + declarations --- src/c/compiler.d | 5 +- src/c/interpreter.d | 124 ++++++++++++++++++++++++-------------------- 2 files changed, 69 insertions(+), 60 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index 79a1458a8..a14f39ab3 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -1375,8 +1375,7 @@ c_macrolet(cl_object args, int flags) cl_object env = funcall(3, @'si::cmp-env-register-macrolet', pop(&args), CONS(ENV->variables, ENV->macros)); ENV->macros = CDR(env); - args = c_process_declarations(args); - flags = compile_body(args, flags); + flags = c_locally(args, flags); ENV->macros = old_env; return flags; } @@ -1456,7 +1455,7 @@ c_multiple_value_prog1(cl_object args, int flags) { compile_form(pop(&args), FLAG_VALUES); if (!ecl_endp(args)) { asm_op(OP_PUSHVALUES); - compile_body(args, FLAG_VALUES); + compile_body(args, FLAG_IGNORE); asm_op(OP_POPVALUES); } return FLAG_VALUES; diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 64063ac20..50852a395 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -489,29 +489,6 @@ search_global(register cl_object s) { return x; } -/* - * INTERPRET-FUNCALL is one of the few ways to "exit" the interpreted - * environment and get into the C/lisp world. Since almost all data from the - * interpreter is kept in local variables, and frame stacks, binding stacks, - * etc, are already handled by the C core, only the lexical environment - * needs to be saved. - */ -static cl_object -interpret_funcall(cl_object lex_env, cl_narg narg, cl_object fun) -{ - struct ecl_stack_frame frame_aux; - cl_env.ihs_top->lex_env = lex_env; - frame_aux.t = t_frame; - frame_aux.stack = cl_env.stack; - frame_aux.top = cl_env.stack_top; - frame_aux.bottom = frame_aux.top - narg; - fun = ecl_apply_from_stack_frame((cl_object)&frame_aux, fun); - ecl_stack_frame_close((cl_object)&frame_aux); - return fun; -} - -/* -------------------- THE INTERPRETER -------------------- */ - static cl_object close_around(cl_object fun, cl_object lex) { cl_object v = cl_alloc_object(t_bclosure); @@ -525,13 +502,38 @@ close_around(cl_object fun, cl_object lex) { the_env->stack_top = the_env->stack + the_env->frs_top->frs_sp; \ the_env->frs_top--; } -#define ecl_stack_push(the_env,x) { \ +/* + * Manipulation of the interpreter stack. As shown here, we omit may + * security checks, assuming that the interpreted code is consistent. + * This is done for performance reasons, but could probably be undone + * using a configuration flag. + */ + +#define STACK_PUSH(the_env,x) { \ cl_object __aux = (x); \ if (the_env->stack_top == the_env->stack_limit) { \ cl_stack_grow(); \ } \ *(the_env->stack_top++) = __aux; } +/* + * INTERPRET-FUNCALL is one of the few ways to "exit" the interpreted + * environment and get into the C/lisp world. Since almost all data + * from the interpreter is kept in local variables, and frame stacks, + * binding stacks, etc, are already handled by the C core, only the + * lexical environment needs to be saved. + */ + +#define INTERPRET_FUNCALL(reg0, the_env, frame, narg, fun) { \ + cl_index __n = narg; \ + frame.stack = the_env->stack; \ + frame.top = the_env->stack_top; \ + frame.bottom = frame.top - __n; \ + reg0 = ecl_apply_from_stack_frame((cl_object)&frame, fun); \ + the_env->stack_top -= __n; } + +/* -------------------- THE INTERPRETER -------------------- */ + cl_object ecl_interpret(cl_object env, cl_object bytecodes, void *pc) { @@ -540,11 +542,12 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) const cl_env_ptr the_env = &cl_env; cl_opcode *vector = pc; cl_object reg0 = the_env->values[0], reg1; + struct ecl_stack_frame frame_aux; struct ihs_frame ihs; - static int i = 0; ihs_push(&ihs, bytecodes, env); #define lex_env ihs.lex_env - i++; + frame_aux.t = t_frame; + frame_aux.stack = frame_aux.top = frame_aux.bottom = 0; BEGIN: BEGIN_SWITCH { CASE(OP_NOP); { @@ -583,7 +586,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) Pushes the object in VALUES(0). */ CASE(OP_PUSH); { - ecl_stack_push(the_env, reg0); + STACK_PUSH(the_env, reg0); THREAD_NEXT; } /* OP_PUSHV n{arg} @@ -591,7 +594,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) */ CASE(OP_PUSHV); { int lex_env_index = GET_OPARG(vector); - ecl_stack_push(the_env, ecl_lex_env_get_var(lex_env, lex_env_index)); + STACK_PUSH(the_env, ecl_lex_env_get_var(lex_env, lex_env_index)); THREAD_NEXT; } @@ -601,7 +604,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) */ CASE(OP_PUSHVS); { cl_object var_name = GET_DATA(vector, bytecodes); - ecl_stack_push(the_env, search_global(var_name)); + STACK_PUSH(the_env, search_global(var_name)); THREAD_NEXT; } @@ -609,7 +612,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) Pushes "value" onto the stack. */ CASE(OP_PUSHQ); { - ecl_stack_push(the_env, GET_DATA(vector, bytecodes)); + STACK_PUSH(the_env, GET_DATA(vector, bytecodes)); THREAD_NEXT; } /* OP_CALL n{arg} @@ -619,7 +622,8 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) */ CASE(OP_CALL); { cl_fixnum n = GET_OPARG(vector); - the_env->values[0] = reg0 = interpret_funcall(lex_env, n, reg0); + INTERPRET_FUNCALL(reg0, the_env, frame_aux, n, reg0); + the_env->values[0] = reg0; THREAD_NEXT; } @@ -630,7 +634,8 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) CASE(OP_CALLG); { cl_fixnum n = GET_OPARG(vector); cl_object f = GET_DATA(vector, bytecodes); - the_env->values[0] = reg0 = interpret_funcall(lex_env, n, f); + INTERPRET_FUNCALL(reg0, the_env, frame_aux, n, f); + the_env->values[0] = reg0; THREAD_NEXT; } @@ -642,7 +647,8 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) CASE(OP_FCALL); { cl_fixnum n = GET_OPARG(vector); cl_object fun = the_env->stack_top[-n-1]; - the_env->values[0] = reg0 = interpret_funcall(lex_env, n, fun); + INTERPRET_FUNCALL(reg0, the_env, frame_aux, n, fun); + the_env->values[0] = reg0; cl_stack_pop(); THREAD_NEXT; } @@ -654,7 +660,8 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) CASE(OP_MCALL); { cl_fixnum n = fix(cl_stack_pop()); cl_object fun = the_env->stack_top[-n-1]; - the_env->values[0] = reg0 = interpret_funcall(lex_env, n, fun); + INTERPRET_FUNCALL(reg0, the_env, frame_aux, n, fun); + the_env->values[0] = reg0; cl_stack_pop(); THREAD_NEXT; } @@ -666,7 +673,8 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) */ CASE(OP_PCALL); { cl_fixnum n = GET_OPARG(vector); - ecl_stack_push(the_env, interpret_funcall(lex_env, n, reg0)); + INTERPRET_FUNCALL(reg0, the_env, frame_aux, n, reg0); + STACK_PUSH(the_env, reg0); THREAD_NEXT; } @@ -678,7 +686,8 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) CASE(OP_PCALLG); { cl_fixnum n = GET_OPARG(vector); cl_object f = GET_DATA(vector, bytecodes); - ecl_stack_push(the_env, interpret_funcall(lex_env, n, f)); + INTERPRET_FUNCALL(f, the_env, frame_aux, n, f); + STACK_PUSH(the_env, f); THREAD_NEXT; } @@ -690,8 +699,8 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) CASE(OP_PFCALL); { cl_fixnum n = GET_OPARG(vector); cl_object fun = the_env->stack_top[-n-1]; - cl_object reg0 = interpret_funcall(lex_env, n, fun); - the_env->stack_top[-1] = reg0; + INTERPRET_FUNCALL(fun, the_env, frame_aux, n, fun); + the_env->stack_top[-1] = fun; THREAD_NEXT; } @@ -995,8 +1004,8 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) DO_BLOCK: { cl_opcode *exit; GET_LABEL(exit, vector); - ecl_stack_push(the_env, lex_env); - ecl_stack_push(the_env, (cl_object)exit); + STACK_PUSH(the_env, lex_env); + STACK_PUSH(the_env, (cl_object)exit); if (frs_push(reg1) == 0) { lex_env = CONS(CONS(reg1, reg0), lex_env); } else { @@ -1031,8 +1040,8 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) int n = GET_OPARG(vector); /* Here we save the location of the jump table and the env. */ lex_env = bind_tagbody(lex_env, id); - ecl_stack_push(the_env, lex_env); - ecl_stack_push(the_env, (cl_object)vector); /* FIXME! */ + STACK_PUSH(the_env, lex_env); + STACK_PUSH(the_env, (cl_object)vector); /* FIXME! */ if (frs_push(id) == 0) { /* The first time, we "name" the tagbody and * skip the jump table */ @@ -1060,7 +1069,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) THREAD_NEXT; } CASE(OP_PUSHNIL); { - ecl_stack_push(the_env, Cnil); + STACK_PUSH(the_env, Cnil); THREAD_NEXT; } CASE(OP_VALUEREG0); { @@ -1112,8 +1121,8 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) CASE(OP_PUSHVALUES); { cl_index i; for (i=0; invalues; i++) - ecl_stack_push(the_env, the_env->values[i]); - ecl_stack_push(the_env, MAKE_FIXNUM(the_env->nvalues)); + STACK_PUSH(the_env, the_env->values[i]); + STACK_PUSH(the_env, MAKE_FIXNUM(the_env->nvalues)); THREAD_NEXT; } /* OP_PUSHMOREVALUES @@ -1122,8 +1131,8 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) CASE(OP_PUSHMOREVALUES); { cl_index i, n = fix(cl_stack_pop()); for (i=0; invalues; i++) - ecl_stack_push(the_env, the_env->values[i]); - ecl_stack_push(the_env, MAKE_FIXNUM(n + the_env->nvalues)); + STACK_PUSH(the_env, the_env->values[i]); + STACK_PUSH(the_env, MAKE_FIXNUM(n + the_env->nvalues)); THREAD_NEXT; } /* OP_POP @@ -1142,6 +1151,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) int n = the_env->nvalues = fix(*(--sp)); if (n == 0) { *dest = reg0 = Cnil; + the_env->stack_top = sp; THREAD_NEXT; } else if (n == 1) { *dest = reg0 = *(--sp); @@ -1200,13 +1210,13 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) CASE(OP_PROTECT); { cl_opcode *exit; GET_LABEL(exit, vector); - ecl_stack_push(the_env, lex_env); - ecl_stack_push(the_env, (cl_object)exit); + STACK_PUSH(the_env, lex_env); + STACK_PUSH(the_env, (cl_object)exit); if (frs_push(ECL_PROTECT_TAG) != 0) { frs_pop(the_env); vector = (cl_opcode *)cl_stack_pop(); lex_env = cl_stack_pop(); - ecl_stack_push(the_env, MAKE_FIXNUM(the_env->nlj_fr - the_env->frs_top)); + STACK_PUSH(the_env, MAKE_FIXNUM(the_env->nlj_fr - the_env->frs_top)); goto PUSH_VALUES; } THREAD_NEXT; @@ -1216,7 +1226,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) frs_pop(the_env); cl_stack_pop(); lex_env = cl_stack_pop(); - ecl_stack_push(the_env, MAKE_FIXNUM(1)); + STACK_PUSH(the_env, MAKE_FIXNUM(1)); goto PUSH_VALUES; } CASE(OP_PROTECT_EXIT); { @@ -1249,7 +1259,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) values = ECL_CONS_CDR(values); } } - ecl_stack_push(the_env, MAKE_FIXNUM(n)); + STACK_PUSH(the_env, MAKE_FIXNUM(n)); THREAD_NEXT; } CASE(OP_EXIT_PROGV); { @@ -1267,8 +1277,8 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) * what to do. */ ECL_SETQ(@'si::*step-level*', cl_1P(SYM_VAL(@'si::*step-level*'))); - ecl_stack_push(the_env, form); - interpret_funcall(lex_env, 1, @'si::stepper'); + STACK_PUSH(the_env, form); + INTERPRET_FUNCALL(form, the_env, frame_aux, 1, @'si::stepper'); } else if (a != Cnil) { /* The user told us to step over. *step-level* contains * an integer number that, when it becomes 0, means @@ -1287,10 +1297,10 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) * that. */ cl_fixnum n = GET_OPARG(vector); if (SYM_VAL(@'si::*step-action*') == Ct) { - ecl_stack_push(the_env, reg0); - reg0 = interpret_funcall(lex_env, 1, @'si::stepper'); + STACK_PUSH(the_env, reg0); + INTERPRET_FUNCALL(reg0, the_env, frame_aux, 1, @'si::stepper'); } - reg0 = interpret_funcall(lex_env, n, reg0); + INTERPRET_FUNCALL(reg0, the_env, frame_aux, n, reg0); } CASE(OP_STEPOUT); { cl_object a = SYM_VAL(@'si::*step-action*'); From 108a76ed1356b67000ae70fce1fae47fcaf370c4 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 15:05:21 +0000 Subject: [PATCH 39/71] OP_MSETQ does not use the VALUES register --- src/c/compiler.d | 2 +- src/c/interpreter.d | 3 +-- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index a14f39ab3..c9d590a2e 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -1517,7 +1517,7 @@ c_multiple_value_setq(cl_object orig_args, int flags) { c_undo_bindings(old_variables); - return FLAG_VALUES; + return FLAG_REG0; } /* diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 50852a395..99a4c24f5 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -1105,11 +1105,10 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) } } if (nv == 0) { - the_env->values[0] = reg0 = Cnil; + reg0 = Cnil; } else { reg0 = the_env->values[0]; } - the_env->nvalues = 1; THREAD_NEXT; } From 665505205e702bc91f394e3ab0c635cfc9fcefcb Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 15:05:36 +0000 Subject: [PATCH 40/71] Inline stack_pop operation --- src/c/interpreter.d | 56 ++++++++++++++++++++++++--------------------- 1 file changed, 30 insertions(+), 26 deletions(-) diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 99a4c24f5..aa06bcb6b 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -516,6 +516,10 @@ close_around(cl_object fun, cl_object lex) { } \ *(the_env->stack_top++) = __aux; } +#define STACK_POP(the_env) *(--(the_env->stack_top)) + +#define STACK_POP_N(the_env,n) (the_env->stack_top -= n) + /* * INTERPRET-FUNCALL is one of the few ways to "exit" the interpreted * environment and get into the C/lisp world. Since almost all data @@ -649,7 +653,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) cl_object fun = the_env->stack_top[-n-1]; INTERPRET_FUNCALL(reg0, the_env, frame_aux, n, fun); the_env->values[0] = reg0; - cl_stack_pop(); + STACK_POP(the_env); THREAD_NEXT; } @@ -658,11 +662,11 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) the stack (They all have been deposited by OP_PUSHVALUES) */ CASE(OP_MCALL); { - cl_fixnum n = fix(cl_stack_pop()); + cl_fixnum n = fix(STACK_POP(the_env)); cl_object fun = the_env->stack_top[-n-1]; INTERPRET_FUNCALL(reg0, the_env, frame_aux, n, fun); the_env->values[0] = reg0; - cl_stack_pop(); + STACK_POP(the_env); THREAD_NEXT; } @@ -825,7 +829,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) output values are left in VALUES(...). */ CASE(OP_THROW); { - cl_object tag_name = cl_stack_pop(); + cl_object tag_name = STACK_POP(the_env); cl_throw(tag_name); THREAD_NEXT; } @@ -903,7 +907,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) } CASE(OP_PBIND); { cl_object var_name = GET_DATA(vector, bytecodes); - cl_object value = cl_stack_pop(); + cl_object value = STACK_POP(the_env); lex_env = bind_var(lex_env, var_name, value); THREAD_NEXT; } @@ -921,7 +925,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) } CASE(OP_PBINDS); { cl_object var_name = GET_DATA(vector, bytecodes); - cl_object value = cl_stack_pop(); + cl_object value = STACK_POP(the_env); bds_bind(var_name, value); THREAD_NEXT; } @@ -955,13 +959,13 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) } CASE(OP_PSETQ); { int lex_env_index = GET_OPARG(vector); - ecl_lex_env_set_var(lex_env, lex_env_index, cl_stack_pop()); + ecl_lex_env_set_var(lex_env, lex_env_index, STACK_POP(the_env)); THREAD_NEXT; } CASE(OP_PSETQS); { cl_object var = GET_DATA(vector, bytecodes); /* INV: Not NIL, and of type t_symbol */ - ECL_SETQ(var, cl_stack_pop()); + ECL_SETQ(var, STACK_POP(the_env)); THREAD_NEXT; } @@ -1011,16 +1015,16 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) } else { reg0 = the_env->values[0]; frs_pop(the_env); - vector = (cl_opcode *)cl_stack_pop(); /* FIXME! */ - lex_env = cl_stack_pop(); + vector = (cl_opcode *)STACK_POP(the_env); /* FIXME! */ + lex_env = STACK_POP(the_env); } THREAD_NEXT; } CASE(OP_EXIT_FRAME); { bds_unwind(the_env->frs_top->frs_bds_top); frs_pop(the_env); - cl_stack_pop(); - lex_env = cl_stack_pop(); + STACK_POP(the_env); + lex_env = STACK_POP(the_env); THREAD_NEXT; } /* OP_TAGBODY n{arg} @@ -1061,8 +1065,8 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) } CASE(OP_EXIT_TAGBODY); { frs_pop(the_env); - cl_stack_pop(); - lex_env = ECL_CONS_CDR(cl_stack_pop()); + STACK_POP(the_env); + lex_env = ECL_CONS_CDR(STACK_POP(the_env)); } CASE(OP_NIL); { reg0 = Cnil; @@ -1128,7 +1132,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) Adds more values to the ones pushed by OP_PUSHVALUES. */ CASE(OP_PUSHMOREVALUES); { - cl_index i, n = fix(cl_stack_pop()); + cl_index i, n = fix(STACK_POP(the_env)); for (i=0; invalues; i++) STACK_PUSH(the_env, the_env->values[i]); STACK_PUSH(the_env, MAKE_FIXNUM(n + the_env->nvalues)); @@ -1138,7 +1142,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) Pops a singe value pushed by a OP_PUSH* operator. */ CASE(OP_POP); { - reg0 = cl_stack_pop(); + reg0 = STACK_POP(the_env); THREAD_NEXT; } /* OP_POPVALUES @@ -1183,7 +1187,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) The index N-th is extracted from the top of the stack. */ CASE(OP_NTHVAL); { - cl_fixnum n = fix(cl_stack_pop()); + cl_fixnum n = fix(STACK_POP(the_env)); if (n < 0) { FEerror("Wrong index passed to NTH-VAL", 1, MAKE_FIXNUM(n)); } else if ((cl_index)n >= the_env->nvalues) { @@ -1213,8 +1217,8 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) STACK_PUSH(the_env, (cl_object)exit); if (frs_push(ECL_PROTECT_TAG) != 0) { frs_pop(the_env); - vector = (cl_opcode *)cl_stack_pop(); - lex_env = cl_stack_pop(); + vector = (cl_opcode *)STACK_POP(the_env); + lex_env = STACK_POP(the_env); STACK_PUSH(the_env, MAKE_FIXNUM(the_env->nlj_fr - the_env->frs_top)); goto PUSH_VALUES; } @@ -1223,17 +1227,17 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) CASE(OP_PROTECT_NORMAL); { bds_unwind(the_env->frs_top->frs_bds_top); frs_pop(the_env); - cl_stack_pop(); - lex_env = cl_stack_pop(); + STACK_POP(the_env); + lex_env = STACK_POP(the_env); STACK_PUSH(the_env, MAKE_FIXNUM(1)); goto PUSH_VALUES; } CASE(OP_PROTECT_EXIT); { - volatile cl_fixnum n = the_env->nvalues = fix(cl_stack_pop()); + volatile cl_fixnum n = the_env->nvalues = fix(STACK_POP(the_env)); while (n--) - the_env->values[n] = cl_stack_pop(); + the_env->values[n] = STACK_POP(the_env); reg0 = the_env->values[0]; - n = fix(cl_stack_pop()); + n = fix(STACK_POP(the_env)); if (n <= 0) ecl_unwind(the_env->frs_top + n); THREAD_NEXT; @@ -1247,7 +1251,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) */ CASE(OP_PROGV); { cl_object values = reg0; - cl_object vars = cl_stack_pop(); + cl_object vars = STACK_POP(the_env); cl_index n; for (n = 0; !ecl_endp(vars); n++, vars = ECL_CONS_CDR(vars)) { cl_object var = ECL_CONS_CAR(vars); @@ -1262,7 +1266,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) THREAD_NEXT; } CASE(OP_EXIT_PROGV); { - cl_index n = fix(cl_stack_pop()); + cl_index n = fix(STACK_POP(the_env)); bds_unwind_n(n); THREAD_NEXT; } From 28eb316b884b6d1d5cff0fae15c1ae064dec8af8 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 15:05:51 +0000 Subject: [PATCH 41/71] Avoid using STACK_PUSH in loops --- src/c/interpreter.d | 26 ++++++++++++++++++-------- 1 file changed, 18 insertions(+), 8 deletions(-) diff --git a/src/c/interpreter.d b/src/c/interpreter.d index aa06bcb6b..ce574cf24 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -518,8 +518,17 @@ close_around(cl_object fun, cl_object lex) { #define STACK_POP(the_env) *(--(the_env->stack_top)) +#define STACK_PUSH_N(the_env,n) { \ + cl_index __aux = (n); \ + while ((the_env->stack_limit - the_env->stack_top) <= __aux) { \ + cl_stack_grow(); \ + } \ + the_env->stack_top += __aux; } + #define STACK_POP_N(the_env,n) (the_env->stack_top -= n) +#define STACK_REF(the_env,n) (the_env->stack_top[n]) + /* * INTERPRET-FUNCALL is one of the few ways to "exit" the interpreted * environment and get into the C/lisp world. Since almost all data @@ -1122,20 +1131,21 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) */ PUSH_VALUES: CASE(OP_PUSHVALUES); { - cl_index i; - for (i=0; invalues; i++) - STACK_PUSH(the_env, the_env->values[i]); - STACK_PUSH(the_env, MAKE_FIXNUM(the_env->nvalues)); + cl_index i = the_env->nvalues; + STACK_PUSH_N(the_env, i+1); + memcpy(&STACK_REF(the_env, -(i+1)), the_env->values, i * sizeof(cl_object)); + STACK_REF(the_env, -1) = MAKE_FIXNUM(the_env->nvalues); THREAD_NEXT; } /* OP_PUSHMOREVALUES Adds more values to the ones pushed by OP_PUSHVALUES. */ CASE(OP_PUSHMOREVALUES); { - cl_index i, n = fix(STACK_POP(the_env)); - for (i=0; invalues; i++) - STACK_PUSH(the_env, the_env->values[i]); - STACK_PUSH(the_env, MAKE_FIXNUM(n + the_env->nvalues)); + cl_index n = fix(STACK_REF(the_env,-1)); + cl_index i = the_env->nvalues; + STACK_PUSH_N(the_env, i); + memcpy(&STACK_REF(the_env, -(i+1)), the_env->values, i * sizeof(cl_object)); + STACK_REF(the_env, -1) = MAKE_FIXNUM(n + i); THREAD_NEXT; } /* OP_POP From 12986c134cac9bb48bae94cd098a27260ed2e78f Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 15:06:16 +0000 Subject: [PATCH 42/71] The interpreter now keeps VALUES(0) always in REG0 --- src/c/interpreter.d | 33 +++++++++++++++++++-------------- src/c/print.d | 3 +-- 2 files changed, 20 insertions(+), 16 deletions(-) diff --git a/src/c/interpreter.d b/src/c/interpreter.d index ce574cf24..610936201 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -564,7 +564,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) BEGIN: BEGIN_SWITCH { CASE(OP_NOP); { - the_env->values[0] = reg0 = Cnil; + reg0 = Cnil; the_env->nvalues = 0; THREAD_NEXT; } @@ -636,7 +636,6 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) CASE(OP_CALL); { cl_fixnum n = GET_OPARG(vector); INTERPRET_FUNCALL(reg0, the_env, frame_aux, n, reg0); - the_env->values[0] = reg0; THREAD_NEXT; } @@ -648,7 +647,6 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) cl_fixnum n = GET_OPARG(vector); cl_object f = GET_DATA(vector, bytecodes); INTERPRET_FUNCALL(reg0, the_env, frame_aux, n, f); - the_env->values[0] = reg0; THREAD_NEXT; } @@ -661,7 +659,6 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) cl_fixnum n = GET_OPARG(vector); cl_object fun = the_env->stack_top[-n-1]; INTERPRET_FUNCALL(reg0, the_env, frame_aux, n, fun); - the_env->values[0] = reg0; STACK_POP(the_env); THREAD_NEXT; } @@ -674,7 +671,6 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) cl_fixnum n = fix(STACK_POP(the_env)); cl_object fun = the_env->stack_top[-n-1]; INTERPRET_FUNCALL(reg0, the_env, frame_aux, n, fun); - the_env->values[0] = reg0; STACK_POP(the_env); THREAD_NEXT; } @@ -711,9 +707,9 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) */ CASE(OP_PFCALL); { cl_fixnum n = GET_OPARG(vector); - cl_object fun = the_env->stack_top[-n-1]; + cl_object fun = STACK_REF(the_env, -n-1); INTERPRET_FUNCALL(fun, the_env, frame_aux, n, fun); - the_env->stack_top[-1] = fun; + STACK_REF(the_env, -1) = fun; THREAD_NEXT; } @@ -723,7 +719,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) */ CASE(OP_EXIT); { ihs_pop(); - return VALUES(0); + return reg0; } /* OP_FLET nfun{arg}, fun1{object} ... @@ -829,6 +825,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) cl_object block_record = ecl_lex_env_get_record(lex_env, lex_env_index); cl_object id = CAR(block_record); cl_object block_name = CDR(block_record); + the_env->values[0] = reg0; cl_return_from(id, block_name); THREAD_NEXT; } @@ -839,6 +836,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) */ CASE(OP_THROW); { cl_object tag_name = STACK_POP(the_env); + the_env->values[0] = reg0; cl_throw(tag_name); THREAD_NEXT; } @@ -1086,7 +1084,6 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) THREAD_NEXT; } CASE(OP_VALUEREG0); { - the_env->values[0] = reg0; the_env->nvalues = 1; THREAD_NEXT; } @@ -1104,6 +1101,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) CASE(OP_MSETQ); { cl_object value; cl_index i, n = GET_OPARG(vector), nv = the_env->nvalues; + the_env->values[0] = reg0; for (i=0; ivalues[i] : Cnil; @@ -1119,8 +1117,6 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) } if (nv == 0) { reg0 = Cnil; - } else { - reg0 = the_env->values[0]; } THREAD_NEXT; } @@ -1133,6 +1129,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) CASE(OP_PUSHVALUES); { cl_index i = the_env->nvalues; STACK_PUSH_N(the_env, i+1); + the_env->values[0] = reg0; memcpy(&STACK_REF(the_env, -(i+1)), the_env->values, i * sizeof(cl_object)); STACK_REF(the_env, -1) = MAKE_FIXNUM(the_env->nvalues); THREAD_NEXT; @@ -1144,6 +1141,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) cl_index n = fix(STACK_REF(the_env,-1)); cl_index i = the_env->nvalues; STACK_PUSH_N(the_env, i); + the_env->values[0] = reg0; memcpy(&STACK_REF(the_env, -(i+1)), the_env->values, i * sizeof(cl_object)); STACK_REF(the_env, -1) = MAKE_FIXNUM(n + i); THREAD_NEXT; @@ -1202,7 +1200,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) FEerror("Wrong index passed to NTH-VAL", 1, MAKE_FIXNUM(n)); } else if ((cl_index)n >= the_env->nvalues) { reg0 = Cnil; - } else { + } else if (n) { reg0 = the_env->values[n]; } THREAD_NEXT; @@ -1229,6 +1227,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) frs_pop(the_env); vector = (cl_opcode *)STACK_POP(the_env); lex_env = STACK_POP(the_env); + reg0 = the_env->values[0]; STACK_PUSH(the_env, MAKE_FIXNUM(the_env->nlj_fr - the_env->frs_top)); goto PUSH_VALUES; } @@ -1284,7 +1283,9 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) CASE(OP_STEPIN); { cl_object form = GET_DATA(vector, bytecodes); cl_object a = SYM_VAL(@'si::*step-action*'); - cl_index n = cl_stack_push_values(); + cl_index n; + the_env->values[0] = reg0; + n = cl_stack_push_values(); if (a == Ct) { /* We are stepping in, but must first ask the user * what to do. */ @@ -1302,6 +1303,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) * actually never happen. */ } cl_stack_pop_values(n); + reg0 = the_env->values[0]; THREAD_NEXT; } CASE(OP_STEPCALL); { @@ -1317,7 +1319,9 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) } CASE(OP_STEPOUT); { cl_object a = SYM_VAL(@'si::*step-action*'); - cl_index n = cl_stack_push_values(); + cl_index n; + the_env->values[0] = reg0; + n = cl_stack_push_values(); if (a == Ct) { /* We exit one stepping level */ ECL_SETQ(@'si::*step-level*', @@ -1332,6 +1336,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) /* Not stepping, nothing to be done. */ } cl_stack_pop_values(n); + reg0 = the_env->values[0]; THREAD_NEXT; } } diff --git a/src/c/print.d b/src/c/print.d index 33a0f366e..1852c6120 100644 --- a/src/c/print.d +++ b/src/c/print.d @@ -661,8 +661,7 @@ do_write_integer(cl_object x, struct powers *powers, cl_index len, write_positive_fixnum(0, powers->base, len, stream); powers--; } - ecl_floor2(x, powers->number); - left = VALUES(0); + left = ecl_floor2(x, powers->number); x = VALUES(1); if (len) len -= powers->n_digits; do_write_integer(left, powers-1, len, stream); From d8122d6c618dc5fbd1a9131b864cd77b7f391d57 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 15:06:31 +0000 Subject: [PATCH 43/71] Eliminate all direct references to stack_top --- src/c/interpreter.d | 39 +++++++++++++++++++-------------------- 1 file changed, 19 insertions(+), 20 deletions(-) diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 610936201..fc8519ed1 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -529,6 +529,8 @@ close_around(cl_object fun, cl_object lex) { #define STACK_REF(the_env,n) (the_env->stack_top[n]) +#define SETUP_ENV(the_env) { ihs.lex_env = lex_env; } + /* * INTERPRET-FUNCALL is one of the few ways to "exit" the interpreted * environment and get into the C/lisp world. Since almost all data @@ -539,6 +541,7 @@ close_around(cl_object fun, cl_object lex) { #define INTERPRET_FUNCALL(reg0, the_env, frame, narg, fun) { \ cl_index __n = narg; \ + SETUP_ENV(the_env); \ frame.stack = the_env->stack; \ frame.top = the_env->stack_top; \ frame.bottom = frame.top - __n; \ @@ -554,11 +557,10 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) typedef struct cl_env_struct *cl_env_ptr; const cl_env_ptr the_env = &cl_env; cl_opcode *vector = pc; - cl_object reg0 = the_env->values[0], reg1; + cl_object reg0 = the_env->values[0], reg1, lex_env = env; struct ecl_stack_frame frame_aux; - struct ihs_frame ihs; + volatile struct ihs_frame ihs; ihs_push(&ihs, bytecodes, env); -#define lex_env ihs.lex_env frame_aux.t = t_frame; frame_aux.stack = frame_aux.top = frame_aux.bottom = 0; BEGIN: @@ -657,7 +659,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) */ CASE(OP_FCALL); { cl_fixnum n = GET_OPARG(vector); - cl_object fun = the_env->stack_top[-n-1]; + cl_object fun = STACK_REF(the_env,-n-1); INTERPRET_FUNCALL(reg0, the_env, frame_aux, n, fun); STACK_POP(the_env); THREAD_NEXT; @@ -669,7 +671,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) */ CASE(OP_MCALL); { cl_fixnum n = fix(STACK_POP(the_env)); - cl_object fun = the_env->stack_top[-n-1]; + cl_object fun = STACK_REF(the_env,-n-1); INTERPRET_FUNCALL(reg0, the_env, frame_aux, n, fun); STACK_POP(the_env); THREAD_NEXT; @@ -1063,10 +1065,10 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) to ntags-1, depending on the tag. These numbers are indices into the jump table and are computed at compile time. */ - cl_opcode *table = (cl_opcode *)the_env->stack_top[-1]; + cl_opcode *table = (cl_opcode *)STACK_REF(the_env,-1); + lex_env = STACK_REF(the_env,-2); table = table + fix(the_env->values[0]) * OPARG_SIZE; vector = table + *(cl_oparg *)table; - lex_env = the_env->stack_top[-2]; } THREAD_NEXT; } @@ -1158,21 +1160,17 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) */ CASE(OP_POPVALUES); { cl_object *dest = the_env->values; - cl_object *sp = the_env->stack_top; - int n = the_env->nvalues = fix(*(--sp)); + int n = the_env->nvalues = fix(STACK_POP(the_env)); if (n == 0) { *dest = reg0 = Cnil; - the_env->stack_top = sp; THREAD_NEXT; } else if (n == 1) { - *dest = reg0 = *(--sp); - the_env->stack_top = sp; + *dest = reg0 = STACK_POP(the_env); THREAD_NEXT; } else { - sp -= n; - memcpy(dest, sp, n * sizeof(cl_object)); + STACK_POP_N(the_env,n); + memcpy(dest, &STACK_REF(the_env,0), n * sizeof(cl_object)); reg0 = *dest; - the_env->stack_top = sp; THREAD_NEXT; } } @@ -1182,12 +1180,10 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) */ CASE(OP_VALUES); { cl_fixnum n = GET_OPARG(vector); - cl_object *sp = the_env->stack_top - n; - cl_object *dest = the_env->values; the_env->nvalues = n; - memcpy(dest, sp, n * sizeof(cl_object)); - reg0 = *dest; - the_env->stack_top = sp; + STACK_POP_N(the_env, n); + memcpy(the_env->values, &STACK_REF(the_env, 0), n * sizeof(cl_object)); + reg0 = the_env->values[0]; THREAD_NEXT; } /* OP_NTHVAL @@ -1284,6 +1280,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) cl_object form = GET_DATA(vector, bytecodes); cl_object a = SYM_VAL(@'si::*step-action*'); cl_index n; + SETUP_ENV(the_env); the_env->values[0] = reg0; n = cl_stack_push_values(); if (a == Ct) { @@ -1311,6 +1308,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) * like to step _in_ the function. STEPPER takes care of * that. */ cl_fixnum n = GET_OPARG(vector); + SETUP_ENV(the_env); if (SYM_VAL(@'si::*step-action*') == Ct) { STACK_PUSH(the_env, reg0); INTERPRET_FUNCALL(reg0, the_env, frame_aux, 1, @'si::stepper'); @@ -1320,6 +1318,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) CASE(OP_STEPOUT); { cl_object a = SYM_VAL(@'si::*step-action*'); cl_index n; + SETUP_ENV(the_env); the_env->values[0] = reg0; n = cl_stack_push_values(); if (a == Ct) { From a2b260c24daa05b7a5ffae4166589f82b26de4d4 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 15:06:43 +0000 Subject: [PATCH 44/71] Optimize some common lisp functions --- src/c/compiler.d | 99 ++++++++++++++++++++++++++++++++++++++++++++ src/c/disassembler.d | 12 ++++++ src/c/interpreter.d | 36 ++++++++++++++++ src/h/bytecodes.h | 12 ++++++ 4 files changed, 159 insertions(+) diff --git a/src/c/compiler.d b/src/c/compiler.d index c9d590a2e..fde127f2f 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -109,6 +109,13 @@ static int c_until(cl_object args, int flags); static int compile_body(cl_object args, int flags); static int compile_form(cl_object args, int push); +static int c_cons(cl_object args, int push); +static int c_endp(cl_object args, int push); +static int c_car(cl_object args, int push); +static int c_cdr(cl_object args, int push); +static int c_list(cl_object args, int push); +static int c_listA(cl_object args, int push); + static cl_object ecl_make_lambda(cl_object name, cl_object lambda); static void FEillegal_variable_name(cl_object) /*__attribute__((noreturn))*/; @@ -274,6 +281,17 @@ static compiler_record database[] = { {@'values', c_values, 1}, {@'si::while', c_while, 0}, {@'si::until', c_until, 0}, + + /* Extras */ + + {@'cons', c_cons, 0}, + {@'car', c_car, 0}, + {@'cdr', c_cdr, 0}, + {@'first', c_car, 0}, + {@'rest', c_cdr, 0}, + {@'list', c_list, 0}, + {@'list*', c_listA, 0}, + {@'endp', c_endp, 0}, {NULL, NULL, 1} }; @@ -2037,6 +2055,87 @@ compile_body(cl_object body, int flags) { } } +/* ------------------------ INLINED FUNCTIONS -------------------------------- */ + +static int +c_cons(cl_object args, int flags) +{ + cl_object car, cdr; + if (ecl_length(args) != 2) { + FEprogram_error("CONS: Wrong number of arguments", 0); + } + compile_form(cl_first(args), FLAG_PUSH); + compile_form(cl_second(args), FLAG_REG0); + asm_op(OP_CONS); + return FLAG_REG0; +} + +static int +c_endp(cl_object args, int flags) +{ + cl_object list = pop(&args); + if (args != Cnil) { + FEprogram_error("ENDP: Too many arguments", 0); + } + compile_form(list, FLAG_REG0); + asm_op(OP_ENDP); + return FLAG_REG0; +} + +static int +c_car(cl_object args, int flags) +{ + cl_object list = pop(&args); + if (args != Cnil) { + FEprogram_error("CAR: Too many arguments", 0); + } + compile_form(list, FLAG_REG0); + asm_op(OP_CAR); + return FLAG_REG0; +} + +static int +c_cdr(cl_object args, int flags) +{ + cl_object list = pop(&args); + if (args != Cnil) { + FEprogram_error("CDR: Too many arguments", 0); + } + compile_form(list, FLAG_REG0); + asm_op(OP_CDR); + return FLAG_REG0; +} + +static int +c_list_listA(cl_object args, int flags, int op) +{ + cl_index n = ecl_length(args); + if (n == 0) { + return compile_form(Cnil, flags); + } else { + while (ECL_CONS_CDR(args) != Cnil) { + compile_form(ECL_CONS_CAR(args), FLAG_PUSH); + args = ECL_CONS_CDR(args); + } + compile_form(ECL_CONS_CAR(args), FLAG_REG0); + asm_op2(op, n); + return FLAG_REG0; + } +} + +static int +c_list(cl_object args, int flags) +{ + return c_list_listA(args, flags, OP_LIST); +} + +static int +c_listA(cl_object args, int flags) +{ + return c_list_listA(args, flags, OP_LISTA); +} + + /* ----------------------------- PUBLIC INTERFACE ---------------------------- */ /* ------------------------------------------------------------ diff --git a/src/c/disassembler.d b/src/c/disassembler.d index 8b19888d9..57cc6ee48 100644 --- a/src/c/disassembler.d +++ b/src/c/disassembler.d @@ -630,6 +630,18 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { goto ARG; case OP_STEPOUT: string = "STEP\tOUT"; goto NOARG; + + case OP_CONS: string = "CONS"; goto NOARG; + case OP_ENDP: string = "ENDP\tREG0"; goto NOARG; + case OP_CAR: string = "CAR\tREG0"; goto NOARG; + case OP_CDR: string = "CDR\tREG0"; goto NOARG; + case OP_LIST: string = "LIST\t"; + n = GET_OPARG(bytecodes); + goto OPARG; + case OP_LISTA: string = "LIST*\t"; + n = GET_OPARG(bytecodes); + goto OPARG; + default: FEerror("Unknown code ~S", 1, MAKE_FIXNUM(*(vector-1))); return vector; diff --git a/src/c/interpreter.d b/src/c/interpreter.d index fc8519ed1..135944d34 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -597,6 +597,37 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) THREAD_NEXT; } + /* OP_CONS, OP_CAR, OP_CDR, etc act on reg0 and stack. */ + + CASE(OP_CONS); { + cl_object car = STACK_POP(the_env); + reg0 = CONS(car, reg0); + THREAD_NEXT; + } + + CASE(OP_CAR); { + if (!LISTP(reg0)) FEtype_error_cons(reg0); + reg0 = CAR(reg0); + THREAD_NEXT; + } + + CASE(OP_CDR); { + if (!LISTP(reg0)) FEtype_error_cons(reg0); + reg0 = CDR(reg0); + THREAD_NEXT; + } + + CASE(OP_LIST); + reg0 = ecl_list1(reg0); + + CASE(OP_LISTA); { + cl_index n = GET_OPARG(vector); + while (--n) { + reg0 = CONS(STACK_POP(the_env), reg0); + } + THREAD_NEXT; + } + /* OP_PUSH Pushes the object in VALUES(0). */ @@ -881,10 +912,15 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) vector += jump - OPARG_SIZE; THREAD_NEXT; } + + CASE(OP_ENDP); + if (!LISTP(reg0)) FEtype_error_list(reg0); + CASE(OP_NOT); { reg0 = (reg0 == Cnil)? Ct : Cnil; THREAD_NEXT; } + /* OP_UNBIND n{arg} Undo "n" local bindings. */ diff --git a/src/h/bytecodes.h b/src/h/bytecodes.h index 02d498cb5..cee6db284 100644 --- a/src/h/bytecodes.h +++ b/src/h/bytecodes.h @@ -126,6 +126,12 @@ enum { OP_NOP, OP_QUOTE, + OP_ENDP, + OP_CONS, + OP_CAR, + OP_CDR, + OP_LIST, + OP_LISTA, OP_VAR, OP_VARS, OP_PUSH, @@ -248,6 +254,12 @@ typedef int16_t cl_oparg; static const int offsets[] = {\ &&LBL_OP_NOP - &&LBL_OP_NOP,\ &&LBL_OP_QUOTE - &&LBL_OP_NOP,\ + &&LBL_OP_ENDP - &&LBL_OP_NOP,\ + &&LBL_OP_CONS - &&LBL_OP_NOP,\ + &&LBL_OP_CAR - &&LBL_OP_NOP,\ + &&LBL_OP_CDR - &&LBL_OP_NOP,\ + &&LBL_OP_LIST - &&LBL_OP_NOP,\ + &&LBL_OP_LISTA - &&LBL_OP_NOP,\ &&LBL_OP_VAR - &&LBL_OP_NOP,\ &&LBL_OP_VARS - &&LBL_OP_NOP,\ &&LBL_OP_PUSH - &&LBL_OP_NOP,\ From 8bdaba7f1176d319000c7f2e2982d565dc584180 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 15:06:57 +0000 Subject: [PATCH 45/71] Implement bytecodes for calling functions with 1 and 2 arguments. --- src/c/compiler.d | 22 ++++++++++++++++++++++ src/c/disassembler.d | 6 ++++++ src/c/interpreter.d | 12 ++++++++++++ src/h/bytecodes.h | 4 ++++ 4 files changed, 44 insertions(+) diff --git a/src/c/compiler.d b/src/c/compiler.d index fde127f2f..14c6a3355 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -1986,6 +1986,28 @@ for special form ~S.", 1, function); */ if (ENV->stepping) asm_op2c(OP_STEPIN, stmt); + if (function >= (cl_object)cl_symbols + && function < (cl_object)(cl_symbols + cl_num_symbols_in_core)) + { + cl_object f = SYM_FUN(function); + if (f != OBJNULL && type_of(f) == t_cfun) { + cl_object args = ECL_CONS_CDR(stmt); + cl_index n = ecl_length(args); + if (f->cfun.narg == 1 && n == 1) { + compile_form(ECL_CONS_CAR(args), FLAG_REG0); + asm_op2c(OP_CALLG1, function); + new_flags = FLAG_VALUES; + goto OUTPUT; + } else if (f->cfun.narg == 2 && n == 2) { + compile_form(ECL_CONS_CAR(args), FLAG_PUSH); + args = ECL_CONS_CDR(args); + compile_form(ECL_CONS_CAR(args), FLAG_REG0); + asm_op2c(OP_CALLG2, function); + new_flags = FLAG_VALUES; + goto OUTPUT; + } + } + } new_flags = c_call(stmt, flags); OUTPUT: /* diff --git a/src/c/disassembler.d b/src/c/disassembler.d index 57cc6ee48..bcb7f1895 100644 --- a/src/c/disassembler.d +++ b/src/c/disassembler.d @@ -641,6 +641,12 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { case OP_LISTA: string = "LIST*\t"; n = GET_OPARG(bytecodes); goto OPARG; + case OP_CALLG1: string = "CALLG1\t"; + o = GET_DATA(vector, bytecodes); + goto ARG; + case OP_CALLG2: string = "CALLG2\t"; + o = GET_DATA(vector, bytecodes); + goto ARG; default: FEerror("Unknown code ~S", 1, MAKE_FIXNUM(*(vector-1))); diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 135944d34..cebf6cb3e 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -683,6 +683,18 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) THREAD_NEXT; } + CASE(OP_CALLG1); { + cl_object s = GET_DATA(vector, bytecodes); + reg0 = SYM_FUN(s)->cfun.entry(reg0); + THREAD_NEXT; + } + + CASE(OP_CALLG2); { + cl_object s = GET_DATA(vector, bytecodes); + reg0 = SYM_FUN(s)->cfun.entry(STACK_POP(the_env), reg0); + THREAD_NEXT; + } + /* OP_FCALL n{arg} Calls a function in the stack with N arguments which have been also deposited in the stack. The output values diff --git a/src/h/bytecodes.h b/src/h/bytecodes.h index cee6db284..6bd6761a2 100644 --- a/src/h/bytecodes.h +++ b/src/h/bytecodes.h @@ -139,6 +139,8 @@ enum { OP_PUSHVS, OP_PUSHQ, OP_CALLG, + OP_CALLG1, + OP_CALLG2, OP_CALL, OP_FCALL, OP_PCALLG, @@ -267,6 +269,8 @@ typedef int16_t cl_oparg; &&LBL_OP_PUSHVS - &&LBL_OP_NOP,\ &&LBL_OP_PUSHQ - &&LBL_OP_NOP,\ &&LBL_OP_CALLG - &&LBL_OP_NOP,\ + &&LBL_OP_CALLG1 - &&LBL_OP_NOP,\ + &&LBL_OP_CALLG2 - &&LBL_OP_NOP,\ &&LBL_OP_CALL - &&LBL_OP_NOP,\ &&LBL_OP_FCALL - &&LBL_OP_NOP,\ &&LBL_OP_PCALLG - &&LBL_OP_NOP,\ From 8ad5c52f70634d12ae5708699ee6c83b3bbd6d1d Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 15:07:10 +0000 Subject: [PATCH 46/71] Split OP_MSETQ into OP_VSETQ and OP_VSETQS. --- src/c/compiler.d | 23 +++++++------- src/c/disassembler.d | 48 +++++------------------------- src/c/interpreter.d | 71 ++++++++++++++++++++------------------------ src/h/bytecodes.h | 6 ++-- 4 files changed, 56 insertions(+), 92 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index 14c6a3355..43d885ad0 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -654,7 +654,12 @@ compile_setq(int op, cl_object var) FEassignment_to_constant(var); } ndx = c_register_constant(var); - op = (op == OP_SETQ)? OP_SETQS : OP_PSETQS; + if (op == OP_SETQ) + op = OP_SETQS; + else if (op == OP_PSETQ) + op = OP_PSETQS; + else if (op == OP_VSETQ) + op = OP_VSETQS; } asm_op2(op, ndx); } @@ -1520,17 +1525,13 @@ c_multiple_value_setq(cl_object orig_args, int flags) { compile_form(values, FLAG_VALUES); /* Compile variables */ - asm_op2(OP_MSETQ, nvars); - vars = cl_nreverse(vars); - while (nvars--) { - cl_object var = pop(&vars); - cl_fixnum ndx = c_var_ref(var,0,TRUE); - if (ndx < 0) { /* Global variable */ - if (ecl_symbol_type(var) & stp_constant) - FEassignment_to_constant(var); - ndx = -1-c_register_constant(var); + for (nvars = 0, vars = cl_nreverse(vars); vars != Cnil; nvars++, vars = ECL_CONS_CDR(vars)) { + if (nvars) { + compile_setq(OP_VSETQ, ECL_CONS_CAR(vars)); + asm_arg(nvars); + } else { + compile_setq(OP_SETQ, ECL_CONS_CAR(vars)); } - asm_arg(ndx); } c_undo_bindings(old_variables); diff --git a/src/c/disassembler.d b/src/c/disassembler.d index bcb7f1895..649b221c3 100644 --- a/src/c/disassembler.d +++ b/src/c/disassembler.d @@ -152,44 +152,6 @@ disassemble_labels(cl_object bytecodes, cl_opcode *vector) { return vector; } -/* OP_MSETQ n{arg} - {fixnumn} - ... - {fixnum1} - - Sets N variables to the N values in VALUES(), filling with - NIL when there are values missing. Local variables are denoted - with an integer which points a position in the lexical environment, - while special variables are denoted with a negative index X, which - denotes the value -1-X in the table of constants. -*/ -static cl_opcode * -disassemble_msetq(cl_object bytecodes, cl_opcode *vector) -{ - int i, n = GET_OPARG(vector); - bool newline = FALSE; - - for (i=0; i= 0) { - cl_format(4, Ct, - make_constant_base_string("MSETQ\t~D,VALUES(~D)"), - MAKE_FIXNUM(var), MAKE_FIXNUM(i)); - } else { - cl_object name = bytecodes->bytecodes.data[-1-var]; - cl_format(4, Ct, - make_constant_base_string("MSETQS\t~A,VALUES(~D)"), - name, MAKE_FIXNUM(i)); - } - } - return vector; -} - - /* OP_PROGV bindings{list} ... OP_EXIT @@ -567,15 +529,21 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { case OP_PSETQ: string = "PSETQ\t"; n = GET_OPARG(vector); goto OPARG; + case OP_VSETQ: string = "VSETQ\t"; + o = MAKE_FIXNUM(GET_OPARG(vector)); + n = GET_OPARG(vector); + goto OPARG_ARG; case OP_SETQS: string = "SETQS\t"; o = GET_DATA(vector, bytecodes); goto ARG; case OP_PSETQS: string = "PSETQS\t"; o = GET_DATA(vector, bytecodes); goto ARG; + case OP_VSETQS: string = "VSETQS\t"; + o = GET_DATA(vector, bytecodes); + n = GET_OPARG(vector); + goto OPARG_ARG; - case OP_MSETQ: vector = disassemble_msetq(bytecodes, vector); - break; case OP_PROGV: vector = disassemble_progv(bytecodes, vector); break; diff --git a/src/c/interpreter.d b/src/c/interpreter.d index cebf6cb3e..dca86e32b 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -597,7 +597,9 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) THREAD_NEXT; } - /* OP_CONS, OP_CAR, OP_CDR, etc act on reg0 and stack. */ + /* OP_CONS, OP_CAR, OP_CDR, etc + Inlined forms for some functions which act on reg0 and stack. + */ CASE(OP_CONS); { cl_object car = STACK_POP(the_env); @@ -685,13 +687,15 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) CASE(OP_CALLG1); { cl_object s = GET_DATA(vector, bytecodes); - reg0 = SYM_FUN(s)->cfun.entry(reg0); + cl_objectfn_fixed f = (cl_objectfn_fixed)SYM_FUN(s)->cfun.entry; + reg0 = f(reg0); THREAD_NEXT; } CASE(OP_CALLG2); { cl_object s = GET_DATA(vector, bytecodes); - reg0 = SYM_FUN(s)->cfun.entry(STACK_POP(the_env), reg0); + cl_objectfn_fixed f = (cl_objectfn_fixed)SYM_FUN(s)->cfun.entry; + reg0 = f(STACK_POP(the_env), reg0); THREAD_NEXT; } @@ -952,10 +956,13 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) } /* OP_BIND name{symbol} OP_PBIND name{symbol} + OP_VBIND nvalue{arg}, name{symbol} OP_BINDS name{symbol} OP_PBINDS name{symbol} - Binds a lexical or special variable to the either the - value of REG0 or the first value of the stack. + OP_VBINDS nvalue{arg}, name{symbol} + Binds a lexical or special variable to the the + value of REG0, the first value of the stack (PBIND) or + to a given value in the values array. */ CASE(OP_BIND); { cl_object var_name = GET_DATA(vector, bytecodes); @@ -997,9 +1004,13 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) OP_PSETQ n{arg} OP_SETQS var-name{symbol} OP_PSETQS var-name{symbol} + OP_VSETQ n{arg}, nvalue{arg} + OP_VSETQS var-name{symbol}, nvalue{arg} Sets either the n-th local or a special variable VAR-NAME, to either the value in REG0 (OP_SETQ[S]) or to the - first value on the stack (OP_PSETQ[S]). + first value on the stack (OP_PSETQ[S]), or to a given + value from the multiple values array (OP_VSETQ[S]). Note + that NVALUE > 0 strictly. */ CASE(OP_SETQ); { int lex_env_index = GET_OPARG(vector); @@ -1025,6 +1036,21 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) ECL_SETQ(var, STACK_POP(the_env)); THREAD_NEXT; } + CASE(OP_VSETQ); { + int lex_env_index = GET_OPARG(vector); + int index = GET_OPARG(vector); + cl_object v = (index >= the_env->nvalues)? Cnil : the_env->values[index]; + ecl_lex_env_set_var(lex_env, lex_env_index, v); + THREAD_NEXT; + } + CASE(OP_VSETQS); { + cl_object var = GET_DATA(vector, bytecodes); + int index = GET_OPARG(vector); + cl_object v = (index >= the_env->nvalues)? Cnil : the_env->values[index]; + ECL_SETQ(var, v); + THREAD_NEXT; + } + /* OP_BLOCK label{arg} ... @@ -1137,39 +1163,6 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) the_env->nvalues = 1; THREAD_NEXT; } - /* OP_MSETQ n{arg} - {fixnumn} - ... - {fixnum1} - - Sets N variables to the N values in VALUES(), filling with - NIL when there are values missing. Local variables are denoted - with an integer which points a position in the lexical environment, - while special variables are denoted with a negative index X, which - denotes the value -1-X in the table of constants. - */ - CASE(OP_MSETQ); { - cl_object value; - cl_index i, n = GET_OPARG(vector), nv = the_env->nvalues; - the_env->values[0] = reg0; - for (i=0; ivalues[i] : Cnil; - if (var >= 0) { - ecl_lex_env_set_var(lex_env, var, value); - } else { - cl_object name = bytecodes->bytecodes.data[-1-var]; - if (Null(name) || (name->symbol.stype & stp_constant)) { - FEassignment_to_constant(name); - } - ECL_SETQ(name, value); - } - } - if (nv == 0) { - reg0 = Cnil; - } - THREAD_NEXT; - } /* OP_PUSHVALUES Pushes the values output by the last form, plus the number diff --git a/src/h/bytecodes.h b/src/h/bytecodes.h index 6bd6761a2..2b52596e5 100644 --- a/src/h/bytecodes.h +++ b/src/h/bytecodes.h @@ -173,6 +173,8 @@ enum { OP_SETQS, OP_PSETQ, OP_PSETQS, + OP_VSETQ, + OP_VSETQS, OP_BLOCK, OP_DO, OP_CATCH, @@ -182,7 +184,6 @@ enum { OP_PROTECT, OP_PROTECT_NORMAL, OP_PROTECT_EXIT, - OP_MSETQ, OP_PROGV, OP_EXIT_PROGV, OP_PUSHVALUES, @@ -303,6 +304,8 @@ typedef int16_t cl_oparg; &&LBL_OP_SETQS - &&LBL_OP_NOP,\ &&LBL_OP_PSETQ - &&LBL_OP_NOP,\ &&LBL_OP_PSETQS - &&LBL_OP_NOP,\ + &&LBL_OP_VSETQ - &&LBL_OP_NOP,\ + &&LBL_OP_VSETQS - &&LBL_OP_NOP,\ &&LBL_OP_BLOCK - &&LBL_OP_NOP,\ &&LBL_OP_DO - &&LBL_OP_NOP,\ &&LBL_OP_CATCH - &&LBL_OP_NOP,\ @@ -312,7 +315,6 @@ typedef int16_t cl_oparg; &&LBL_OP_PROTECT - &&LBL_OP_NOP,\ &&LBL_OP_PROTECT_NORMAL - &&LBL_OP_NOP,\ &&LBL_OP_PROTECT_EXIT - &&LBL_OP_NOP,\ - &&LBL_OP_MSETQ - &&LBL_OP_NOP,\ &&LBL_OP_PROGV - &&LBL_OP_NOP,\ &&LBL_OP_EXIT_PROGV - &&LBL_OP_NOP,\ &&LBL_OP_PUSHVALUES - &&LBL_OP_NOP,\ From aa920784b4e5e2291c186b8bf9932be6b8d72516 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 15:07:24 +0000 Subject: [PATCH 47/71] Turn the macros in bytecodes.h into standalone forms that output no value. This restriction allows us to have more complex code in them. --- src/c/disassembler.d | 122 +++++++++++----------- src/c/interpreter.d | 234 ++++++++++++++++++++++++++----------------- src/h/bytecodes.h | 131 +++--------------------- 3 files changed, 221 insertions(+), 266 deletions(-) diff --git a/src/c/disassembler.d b/src/c/disassembler.d index 649b221c3..8499f47ac 100644 --- a/src/c/disassembler.d +++ b/src/c/disassembler.d @@ -122,9 +122,11 @@ NO_ARGS: */ static cl_opcode * disassemble_flet(cl_object bytecodes, cl_opcode *vector) { - cl_index nfun = GET_OPARG(vector); - cl_index first = GET_OPARG(vector); - cl_object *data = bytecodes->bytecodes.data + first; + cl_index nfun, first; + cl_object *data; + GET_OPARG(nfun, vector); + GET_OPARG(first, vector); + data = bytecodes->bytecodes.data + first; print_noarg("FLET"); while (nfun--) { cl_object fun = *(data++); @@ -141,9 +143,11 @@ disassemble_flet(cl_object bytecodes, cl_opcode *vector) { */ static cl_opcode * disassemble_labels(cl_object bytecodes, cl_opcode *vector) { - cl_index nfun = GET_OPARG(vector); - cl_index first = GET_OPARG(vector); - cl_object *data = bytecodes->bytecodes.data + first; + cl_index nfun, first; + cl_object *data; + GET_OPARG(nfun, vector); + GET_OPARG(first, vector); + data = bytecodes->bytecodes.data + first; print_noarg("LABELS"); while (nfun--) { cl_object fun = *(data++); @@ -180,9 +184,9 @@ labeln: */ static cl_opcode * disassemble_tagbody(cl_object bytecodes, cl_opcode *vector) { - cl_index i, ntags = GET_OPARG(vector); + cl_index i, ntags; cl_opcode *destination; - + GET_OPARG(ntags, vector); print_noarg("TAGBODY"); for (i=0; ibytecodes.data; BEGIN: cl_format(3, Ct, line_format, MAKE_FIXNUM(vector-base)); @@ -216,14 +221,14 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { Sets VALUES(0) to an immediate value. */ case OP_QUOTE: string = "QUOTE\t"; - o = GET_DATA(vector, bytecodes); + GET_DATA(o, vector, data); goto ARG; /* OP_VAR n{arg} Sets NVALUES=1 and VALUES(0) to the value of the n-th local. */ case OP_VAR: string = "VAR\t"; - n = GET_OPARG(vector); + GET_OPARG(n, vector); goto OPARG; /* OP_VARS var{symbol} @@ -231,7 +236,7 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { VAR should be either a special variable or a constant. */ case OP_VARS: string = "VARS\t"; - o = GET_DATA(vector, bytecodes); + GET_DATA(o, vector, data); goto ARG; /* OP_PUSH @@ -247,7 +252,7 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { Pushes the value of the n-th local onto the stack. */ case OP_PUSHV: string = "PUSHV\t"; - n = GET_OPARG(vector); + GET_OPARG(n, vector); goto OPARG; /* OP_PUSHVS var{symbol} @@ -255,14 +260,14 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { VAR should be either a special variable or a constant. */ case OP_PUSHVS: string = "PUSHVS\t"; - o = GET_DATA(vector, bytecodes); + GET_DATA(o, vector, data); goto ARG; /* OP_PUSHQ value{object} Pushes "value" onto the stack. */ case OP_PUSHQ: string = "PUSH\t'"; - o = GET_DATA(vector, bytecodes); + GET_DATA(o, vector, data); goto ARG; /* OP_PUSHVALUES @@ -304,7 +309,7 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { are left in VALUES(...) */ case OP_CALL: string = "CALL\t"; - n = GET_OPARG(vector); + GET_OPARG(n, vector); goto OPARG; /* OP_CALLG n{arg}, name{arg} @@ -312,8 +317,8 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { deposited in the stack. The output values are left in VALUES. */ case OP_CALLG: string = "CALLG\t"; - n = GET_OPARG(vector); - o = GET_DATA(vector, bytecodes); + GET_OPARG(n, vector); + GET_DATA(o, vector, data); goto OPARG_ARG; /* OP_FCALL n{arg} @@ -323,7 +328,7 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { */ case OP_STEPCALL: case OP_FCALL: string = "FCALL\t"; - n = GET_OPARG(vector); + GET_OPARG(n, vector); goto OPARG; /* OP_PCALL n{arg} @@ -332,7 +337,7 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { is pushed on the stack. */ case OP_PCALL: string = "PCALL\t"; - n = GET_OPARG(vector); + GET_OPARG(n, vector); goto OPARG; /* OP_PCALLG n{arg}, name{arg} @@ -341,8 +346,8 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { the stack. */ case OP_PCALLG: string = "PCALLG\t"; - n = GET_OPARG(vector); - o = GET_DATA(vector, bytecodes); + GET_OPARG(n, vector); + GET_DATA(o, vector, data); goto OPARG_ARG; /* OP_PFCALL n{arg} @@ -351,7 +356,7 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { is pushed on the stack. */ case OP_PFCALL: string = "PFCALL\t"; - n = GET_OPARG(vector); + GET_OPARG(n, vector); goto OPARG; /* OP_MCALL @@ -398,7 +403,7 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { environment. This last value takes precedence. */ case OP_LFUNCTION: string = "LOCFUNC\t"; - n = GET_OPARG(vector); + GET_OPARG(n, vector); goto OPARG; /* OP_FUNCTION name{symbol} @@ -407,7 +412,7 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { environment. This last value takes precedence. */ case OP_FUNCTION: string = "SYMFUNC\t"; - o = GET_DATA(vector, bytecodes); + GET_DATA(o, vector, data); goto ARG; /* OP_CLOSE name{arg} @@ -416,7 +421,7 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { environment. This last value takes precedence. */ case OP_CLOSE: string = "CLOSE\t"; - o = GET_DATA(vector, bytecodes); + GET_DATA(o, vector, data); goto ARG; /* OP_GO n{arg} @@ -426,8 +431,8 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { purposes. */ case OP_GO: string = "GO\t"; - n = GET_OPARG(vector); - o = GET_DATA(vector, bytecodes); + GET_OPARG(n, vector); + GET_DATA(o, vector, data); goto OPARG_ARG; /* OP_RETURN n{arg} @@ -435,7 +440,7 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { occuppies the n-th position. */ case OP_RETURN: string = "RETFROM"; - n = GET_OPARG(vector); + GET_OPARG(n, vector); goto OPARG; /* OP_THROW @@ -459,17 +464,17 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { case OP_JNIL: string = "JNIL\t"; goto JMP; case OP_JT: string = "JT\t"; - JMP: { cl_oparg jmp = GET_OPARG(vector); - n = vector + jmp - OPARG_SIZE - base; + JMP: { GET_OPARG(m, vector); + n = vector + m - OPARG_SIZE - base; goto OPARG; } case OP_JEQL: string = "JEQL\t"; goto JEQL; case OP_JNEQL: string = "JNEQL\t"; JEQL: { cl_oparg jmp; - o = GET_DATA(vector, bytecodes); - jmp = GET_OPARG(vector); - n = vector + jmp - OPARG_SIZE - base; + GET_DATA(o, vector, data); + GET_OPARG(m, vector); + n = vector + m - OPARG_SIZE - base; goto OPARG_ARG; } case OP_NOT: string = "NOT"; @@ -479,13 +484,13 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { Undo "n" bindings of lexical variables. */ case OP_UNBIND: string = "UNBIND\t"; - n = GET_OPARG(vector); + GET_OPARG(n, vector); goto OPARG; /* OP_UNBINDS n{arg} Undo "n" bindings of special variables. */ case OP_UNBINDS: string = "UNBINDS\t"; - n = GET_OPARG(vector); + GET_OPARG(n, vector); goto OPARG; /* OP_BIND name{symbol} OP_PBIND name{symbol} @@ -496,24 +501,24 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { to the n-th value of VALUES(...). */ case OP_BIND: string = "BIND\t"; - o = GET_DATA(vector, bytecodes); + GET_DATA(o, vector, data); goto ARG; case OP_PBIND: string = "PBIND\t"; - o = GET_DATA(vector, bytecodes); + GET_DATA(o, vector, data); goto ARG; case OP_VBIND: string = "VBIND\t"; - n = GET_OPARG(vector); - o = GET_DATA(vector, bytecodes); + GET_OPARG(n, vector); + GET_DATA(o, vector, data); goto OPARG_ARG; case OP_BINDS: string = "BINDS\t"; - o = GET_DATA(vector, bytecodes); + GET_DATA(o, vector, data); goto ARG; case OP_PBINDS: string = "PBINDS\t"; - o = GET_DATA(vector, bytecodes); + GET_DATA(o, vector, data); goto ARG; case OP_VBINDS: string = "VBINDS\t"; - n = GET_OPARG(vector); - o = GET_DATA(vector, bytecodes); + GET_OPARG(n, vector); + GET_DATA(o, vector, data); goto OPARG_ARG; /* OP_SETQ n{arg} OP_PSETQ n{arg} @@ -524,24 +529,25 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { first value on the stack (OP_PSETQ[S]). */ case OP_SETQ: string = "SETQ\t"; - n = GET_OPARG(vector); + GET_OPARG(n, vector); goto OPARG; case OP_PSETQ: string = "PSETQ\t"; - n = GET_OPARG(vector); + GET_OPARG(n, vector); goto OPARG; case OP_VSETQ: string = "VSETQ\t"; - o = MAKE_FIXNUM(GET_OPARG(vector)); - n = GET_OPARG(vector); + GET_OPARG(m, vector); + o = MAKE_FIXNUM(m); + GET_OPARG(n, vector); goto OPARG_ARG; case OP_SETQS: string = "SETQS\t"; - o = GET_DATA(vector, bytecodes); + GET_DATA(o, vector, data); goto ARG; case OP_PSETQS: string = "PSETQS\t"; - o = GET_DATA(vector, bytecodes); + GET_DATA(o, vector, data); goto ARG; case OP_VSETQS: string = "VSETQS\t"; - o = GET_DATA(vector, bytecodes); - n = GET_OPARG(vector); + GET_DATA(o, vector, data); + GET_OPARG(n, vector); goto OPARG_ARG; case OP_PROGV: vector = disassemble_progv(bytecodes, vector); @@ -551,7 +557,7 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { Pop N values from the stack and store them in VALUES(...) */ case OP_VALUES: string = "VALUES\t"; - n = GET_OPARG(vector); + GET_OPARG(n, vector); goto OPARG; /* OP_NTHVAL Set VALUES(0) to the N-th value of the VALUES(...) list. @@ -594,7 +600,7 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { case OP_PUSHNIL: string = "PUSH\t'NIL"; goto NOARG; case OP_STEPIN: string = "STEP\tIN,"; - o = GET_DATA(vector, bytecodes); + GET_DATA(o, vector, data); goto ARG; case OP_STEPOUT: string = "STEP\tOUT"; goto NOARG; @@ -604,16 +610,16 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { case OP_CAR: string = "CAR\tREG0"; goto NOARG; case OP_CDR: string = "CDR\tREG0"; goto NOARG; case OP_LIST: string = "LIST\t"; - n = GET_OPARG(bytecodes); + GET_OPARG(n, bytecodes); goto OPARG; case OP_LISTA: string = "LIST*\t"; - n = GET_OPARG(bytecodes); + GET_OPARG(n, bytecodes); goto OPARG; case OP_CALLG1: string = "CALLG1\t"; - o = GET_DATA(vector, bytecodes); + GET_DATA(o, vector, data); goto ARG; case OP_CALLG2: string = "CALLG2\t"; - o = GET_DATA(vector, bytecodes); + GET_DATA(o, vector, data); goto ARG; default: diff --git a/src/c/interpreter.d b/src/c/interpreter.d index dca86e32b..1694f5333 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -557,6 +557,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) typedef struct cl_env_struct *cl_env_ptr; const cl_env_ptr the_env = &cl_env; cl_opcode *vector = pc; + cl_object *data = bytecodes->bytecodes.data; cl_object reg0 = the_env->values[0], reg1, lex_env = env; struct ecl_stack_frame frame_aux; volatile struct ihs_frame ihs; @@ -574,7 +575,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) Sets REG0 to an immediate value. */ CASE(OP_QUOTE); { - reg0 = GET_DATA(vector, bytecodes); + GET_DATA(reg0, vector, data); THREAD_NEXT; } /* OP_VAR n{arg}, var{symbol} @@ -582,7 +583,8 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) VAR is the name of the variable for readability purposes. */ CASE(OP_VAR); { - int lex_env_index = GET_OPARG(vector); + int lex_env_index; + GET_OPARG(lex_env_index, vector); reg0 = ecl_lex_env_get_var(lex_env, lex_env_index); THREAD_NEXT; } @@ -592,7 +594,8 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) VAR should be either a special variable or a constant. */ CASE(OP_VARS); { - cl_object var_name = GET_DATA(vector, bytecodes); + cl_object var_name; + GET_DATA(var_name, vector, data); reg0 = search_global(var_name); THREAD_NEXT; } @@ -623,7 +626,8 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) reg0 = ecl_list1(reg0); CASE(OP_LISTA); { - cl_index n = GET_OPARG(vector); + cl_index n; + GET_OPARG(n, vector); while (--n) { reg0 = CONS(STACK_POP(the_env), reg0); } @@ -641,7 +645,8 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) Pushes the value of the n-th local onto the stack. */ CASE(OP_PUSHV); { - int lex_env_index = GET_OPARG(vector); + int lex_env_index; + GET_OPARG(lex_env_index, vector); STACK_PUSH(the_env, ecl_lex_env_get_var(lex_env, lex_env_index)); THREAD_NEXT; } @@ -651,7 +656,8 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) VAR should be either a special variable or a constant. */ CASE(OP_PUSHVS); { - cl_object var_name = GET_DATA(vector, bytecodes); + cl_object var_name; + GET_DATA(var_name, vector, data); STACK_PUSH(the_env, search_global(var_name)); THREAD_NEXT; } @@ -660,7 +666,9 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) Pushes "value" onto the stack. */ CASE(OP_PUSHQ); { - STACK_PUSH(the_env, GET_DATA(vector, bytecodes)); + cl_object aux; + GET_DATA(aux, vector, data); + STACK_PUSH(the_env, aux); THREAD_NEXT; } /* OP_CALL n{arg} @@ -669,7 +677,8 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) are left in VALUES(...) */ CASE(OP_CALL); { - cl_fixnum n = GET_OPARG(vector); + cl_fixnum n; + GET_OPARG(n, vector); INTERPRET_FUNCALL(reg0, the_env, frame_aux, n, reg0); THREAD_NEXT; } @@ -679,22 +688,28 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) deposited in the stack. The output values are left in VALUES. */ CASE(OP_CALLG); { - cl_fixnum n = GET_OPARG(vector); - cl_object f = GET_DATA(vector, bytecodes); + cl_fixnum n; + cl_object f; + GET_OPARG(n, vector); + GET_DATA(f, vector, data); INTERPRET_FUNCALL(reg0, the_env, frame_aux, n, f); THREAD_NEXT; } CASE(OP_CALLG1); { - cl_object s = GET_DATA(vector, bytecodes); - cl_objectfn_fixed f = (cl_objectfn_fixed)SYM_FUN(s)->cfun.entry; + cl_object s; + cl_objectfn_fixed f; + GET_DATA(s, vector, data); + f = (cl_objectfn_fixed)SYM_FUN(s)->cfun.entry; reg0 = f(reg0); THREAD_NEXT; } CASE(OP_CALLG2); { - cl_object s = GET_DATA(vector, bytecodes); - cl_objectfn_fixed f = (cl_objectfn_fixed)SYM_FUN(s)->cfun.entry; + cl_object s; + cl_objectfn_fixed f; + GET_DATA(s, vector, data); + f = (cl_objectfn_fixed)SYM_FUN(s)->cfun.entry; reg0 = f(STACK_POP(the_env), reg0); THREAD_NEXT; } @@ -705,8 +720,10 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) are left in VALUES(...) */ CASE(OP_FCALL); { - cl_fixnum n = GET_OPARG(vector); - cl_object fun = STACK_REF(the_env,-n-1); + cl_fixnum n; + cl_object fun; + GET_OPARG(n, vector); + fun = STACK_REF(the_env,-n-1); INTERPRET_FUNCALL(reg0, the_env, frame_aux, n, fun); STACK_POP(the_env); THREAD_NEXT; @@ -730,7 +747,8 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) is pushed on the stack. */ CASE(OP_PCALL); { - cl_fixnum n = GET_OPARG(vector); + cl_fixnum n; + GET_OPARG(n, vector); INTERPRET_FUNCALL(reg0, the_env, frame_aux, n, reg0); STACK_PUSH(the_env, reg0); THREAD_NEXT; @@ -742,8 +760,10 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) the stack. */ CASE(OP_PCALLG); { - cl_fixnum n = GET_OPARG(vector); - cl_object f = GET_DATA(vector, bytecodes); + cl_fixnum n; + cl_object f; + GET_OPARG(n, vector); + GET_DATA(f, vector, data); INTERPRET_FUNCALL(f, the_env, frame_aux, n, f); STACK_PUSH(the_env, f); THREAD_NEXT; @@ -755,8 +775,10 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) is pushed on the stack. */ CASE(OP_PFCALL); { - cl_fixnum n = GET_OPARG(vector); - cl_object fun = STACK_REF(the_env, -n-1); + cl_fixnum n; + cl_object fun; + GET_OPARG(n, vector); + fun = STACK_REF(the_env, -n-1); INTERPRET_FUNCALL(fun, the_env, frame_aux, n, fun); STACK_REF(the_env, -1) = fun; THREAD_NEXT; @@ -779,18 +801,18 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) index of the first function: the others are after this one. */ CASE(OP_FLET); { - cl_index nfun = GET_OPARG(vector); - cl_index first = GET_OPARG(vector); - cl_object *fun = bytecodes->bytecodes.data + first; + cl_index nfun, first; + cl_object old_lex, *fun; + GET_OPARG(nfun, vector); + GET_OPARG(first, vector); + fun = data + first; /* Copy the environment so that functions get it without references to themselves, and then add new closures to the environment. */ - cl_object old_lex = lex_env; - cl_object new_lex = old_lex; + old_lex = lex_env; while (nfun--) { cl_object f = close_around(*(fun++), old_lex); - new_lex = bind_function(new_lex, f->bytecodes.name, f); + lex_env = bind_function(lex_env, f->bytecodes.name, f); } - lex_env = new_lex; THREAD_NEXT; } /* OP_LABELS nfun{arg} @@ -804,10 +826,11 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) the functions "fun1" ... "funn". */ CASE(OP_LABELS); { - cl_index i, nfun = GET_OPARG(vector); - cl_index first = GET_OPARG(vector); - cl_object *fun = bytecodes->bytecodes.data + first; - cl_object l, new_lex; + cl_index i, nfun, first; + cl_object *fun, l, new_lex; + GET_OPARG(nfun, vector); + GET_OPARG(first, vector); + fun = data + first; /* Build up a new environment with all functions */ for (new_lex = lex_env, i = nfun; i; i--) { cl_object f = *(fun++); @@ -828,9 +851,10 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) which have been deposited in the stack. */ CASE(OP_LFUNCTION); { - int lex_env_index = GET_OPARG(vector); - cl_object fun_record = ecl_lex_env_get_record(lex_env, lex_env_index); - reg0 = CAR(fun_record); + int lex_env_index; + cl_object fun_record; + GET_OPARG(lex_env_index, vector); + reg0 = ECL_CONS_CAR(ecl_lex_env_get_record(lex_env, lex_env_index)); THREAD_NEXT; } @@ -839,9 +863,11 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) may be defined in the global environment or in the local environment. This last value takes precedence. */ - CASE(OP_FUNCTION); - reg0 = ecl_fdefinition(GET_DATA(vector, bytecodes)); + CASE(OP_FUNCTION); { + GET_DATA(reg0, vector, data); + reg0 = ecl_fdefinition(reg0); THREAD_NEXT; + } /* OP_CLOSE name{symbol} Extracts the function associated to a symbol. The function @@ -849,8 +875,8 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) environment. This last value takes precedence. */ CASE(OP_CLOSE); { - cl_object function_object = GET_DATA(vector, bytecodes); - reg0 = close_around(function_object, lex_env); + GET_DATA(reg0, vector, data); + reg0 = close_around(reg0, lex_env); THREAD_NEXT; } /* OP_GO n{arg} @@ -860,9 +886,11 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) purposes. */ CASE(OP_GO); { - cl_object id = ecl_lex_env_get_tag(lex_env, GET_OPARG(vector)); - cl_object tag_name = GET_DATA(vector, bytecodes); - cl_go(id, tag_name); + cl_index lex_env_index; + cl_object tag_name; + GET_OPARG(lex_env_index, vector); + GET_DATA(tag_name, vector, data); + cl_go(ecl_lex_env_get_tag(lex_env, lex_env_index), tag_name); THREAD_NEXT; } /* OP_RETURN n{arg} @@ -870,12 +898,14 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) occuppies the n-th position. */ CASE(OP_RETURN); { - int lex_env_index = GET_OPARG(vector); - cl_object block_record = ecl_lex_env_get_record(lex_env, lex_env_index); - cl_object id = CAR(block_record); - cl_object block_name = CDR(block_record); + int lex_env_index; + cl_object block_record, id, block_name; + GET_OPARG(lex_env_index, vector); + /* record = (id . name) */ + block_record = ecl_lex_env_get_record(lex_env, lex_env_index); the_env->values[0] = reg0; - cl_return_from(id, block_name); + cl_return_from(ECL_CONS_CAR(block_record), + ECL_CONS_CDR(block_record)); THREAD_NEXT; } /* OP_THROW @@ -898,33 +928,38 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) comparing with the value of REG0. */ CASE(OP_JMP); { - cl_oparg jump = GET_OPARG(vector); + cl_oparg jump; + GET_OPARG(jump, vector); vector += jump - OPARG_SIZE; THREAD_NEXT; } CASE(OP_JNIL); { - cl_oparg jump = GET_OPARG(vector); + cl_oparg jump; + GET_OPARG(jump, vector); if (Null(reg0)) vector += jump - OPARG_SIZE; THREAD_NEXT; } CASE(OP_JT); { - cl_oparg jump = GET_OPARG(vector); + cl_oparg jump; + GET_OPARG(jump, vector); if (!Null(reg0)) vector += jump - OPARG_SIZE; THREAD_NEXT; } CASE(OP_JEQL); { - cl_oparg value = GET_OPARG(vector); - cl_oparg jump = GET_OPARG(vector); - if (ecl_eql(reg0, bytecodes->bytecodes.data[value])) + cl_oparg value, jump; + GET_OPARG(value, vector); + GET_OPARG(jump, vector); + if (ecl_eql(reg0, data[value])) vector += jump - OPARG_SIZE; THREAD_NEXT; } CASE(OP_JNEQL); { - cl_oparg value = GET_OPARG(vector); - cl_oparg jump = GET_OPARG(vector); - if (!ecl_eql(reg0, bytecodes->bytecodes.data[value])) + cl_oparg value, jump; + GET_OPARG(value, vector); + GET_OPARG(jump, vector); + if (!ecl_eql(reg0, data[value])) vector += jump - OPARG_SIZE; THREAD_NEXT; } @@ -941,7 +976,8 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) Undo "n" local bindings. */ CASE(OP_UNBIND); { - cl_index n = GET_OPARG(vector); + cl_oparg n; + GET_OPARG(n, vector); while (n--) lex_env = ECL_CONS_CDR(lex_env); THREAD_NEXT; @@ -950,7 +986,8 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) Undo "n" bindings of special variables. */ CASE(OP_UNBINDS); { - cl_index n = GET_OPARG(vector); + cl_oparg n; + GET_OPARG(n, vector); bds_unwind_n(n); THREAD_NEXT; } @@ -965,39 +1002,44 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) to a given value in the values array. */ CASE(OP_BIND); { - cl_object var_name = GET_DATA(vector, bytecodes); + cl_object var_name; + GET_DATA(var_name, vector, data); lex_env = bind_var(lex_env, var_name, reg0); THREAD_NEXT; } CASE(OP_PBIND); { - cl_object var_name = GET_DATA(vector, bytecodes); - cl_object value = STACK_POP(the_env); - lex_env = bind_var(lex_env, var_name, value); + cl_object var_name, value; + GET_DATA(var_name, vector, data); + lex_env = bind_var(lex_env, var_name, STACK_POP(the_env)); THREAD_NEXT; } CASE(OP_VBIND); { - cl_index n = GET_OPARG(vector); - cl_object var_name = GET_DATA(vector, bytecodes); - cl_object value = (n < the_env->nvalues) ? the_env->values[n] : Cnil; - lex_env = bind_var(lex_env, var_name, value); + cl_index n; + cl_object var_name; + GET_OPARG(n, vector); + GET_DATA(var_name, vector, data); + lex_env = bind_var(lex_env, var_name, + (n < the_env->nvalues) ? the_env->values[n] : Cnil); THREAD_NEXT; } CASE(OP_BINDS); { - cl_object var_name = GET_DATA(vector, bytecodes); + cl_object var_name; + GET_DATA(var_name, vector, data); bds_bind(var_name, reg0); THREAD_NEXT; } CASE(OP_PBINDS); { - cl_object var_name = GET_DATA(vector, bytecodes); - cl_object value = STACK_POP(the_env); - bds_bind(var_name, value); + cl_object var_name; + GET_DATA(var_name, vector, data); + bds_bind(var_name, STACK_POP(the_env)); THREAD_NEXT; } CASE(OP_VBINDS); { - cl_index n = GET_OPARG(vector); - cl_object var_name = GET_DATA(vector, bytecodes); - cl_object value = (n < the_env->nvalues) ? the_env->values[n] : Cnil; - bds_bind(var_name, value); + cl_index n; + cl_object var_name; + GET_OPARG(n, vector); + GET_DATA(var_name, vector, data); + bds_bind(var_name, (n < the_env->nvalues) ? the_env->values[n] : Cnil); THREAD_NEXT; } /* OP_SETQ n{arg} @@ -1013,12 +1055,14 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) that NVALUE > 0 strictly. */ CASE(OP_SETQ); { - int lex_env_index = GET_OPARG(vector); + int lex_env_index; + GET_OPARG(lex_env_index, vector); ecl_lex_env_set_var(lex_env, lex_env_index, reg0); THREAD_NEXT; } CASE(OP_SETQS); { - cl_object var = GET_DATA(vector, bytecodes); + cl_object var; + GET_DATA(var, vector, data); /* INV: Not NIL, and of type t_symbol */ if (var->symbol.stype & stp_constant) FEassignment_to_constant(var); @@ -1026,27 +1070,33 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) THREAD_NEXT; } CASE(OP_PSETQ); { - int lex_env_index = GET_OPARG(vector); + int lex_env_index; + GET_OPARG(lex_env_index, vector); ecl_lex_env_set_var(lex_env, lex_env_index, STACK_POP(the_env)); THREAD_NEXT; } CASE(OP_PSETQS); { - cl_object var = GET_DATA(vector, bytecodes); + cl_object var; + GET_DATA(var, vector, data); /* INV: Not NIL, and of type t_symbol */ ECL_SETQ(var, STACK_POP(the_env)); THREAD_NEXT; } CASE(OP_VSETQ); { - int lex_env_index = GET_OPARG(vector); - int index = GET_OPARG(vector); - cl_object v = (index >= the_env->nvalues)? Cnil : the_env->values[index]; - ecl_lex_env_set_var(lex_env, lex_env_index, v); + cl_index lex_env_index; + cl_oparg index; + GET_OPARG(lex_env_index, vector); + GET_OPARG(index, vector); + ecl_lex_env_set_var(lex_env, lex_env_index, + (index >= the_env->nvalues)? Cnil : the_env->values[index]); THREAD_NEXT; } CASE(OP_VSETQS); { - cl_object var = GET_DATA(vector, bytecodes); - int index = GET_OPARG(vector); - cl_object v = (index >= the_env->nvalues)? Cnil : the_env->values[index]; + cl_object var, v; + cl_oparg index; + GET_DATA(var, vector, data); + GET_OPARG(index, vector); + v = (index >= the_env->nvalues)? Cnil : the_env->values[index]; ECL_SETQ(var, v); THREAD_NEXT; } @@ -1061,7 +1111,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) LABEL points to the first instruction after OP_EXIT. */ CASE(OP_BLOCK); { - reg0 = GET_DATA(vector, bytecodes); + GET_DATA(reg0, vector, data); reg1 = new_frame_id(); goto DO_BLOCK; } @@ -1124,7 +1174,8 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) */ CASE(OP_TAGBODY); { cl_object id = new_frame_id(); - int n = GET_OPARG(vector); + int n; + GET_OPARG(n, vector); /* Here we save the location of the jump table and the env. */ lex_env = bind_tagbody(lex_env, id); STACK_PUSH(the_env, lex_env); @@ -1220,7 +1271,8 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) Note that N is strictly > 0. */ CASE(OP_VALUES); { - cl_fixnum n = GET_OPARG(vector); + cl_fixnum n; + GET_OPARG(n, vector); the_env->nvalues = n; STACK_POP_N(the_env, n); memcpy(the_env->values, &STACK_REF(the_env, 0), n * sizeof(cl_object)); @@ -1318,9 +1370,10 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) } CASE(OP_STEPIN); { - cl_object form = GET_DATA(vector, bytecodes); + cl_object form; cl_object a = SYM_VAL(@'si::*step-action*'); cl_index n; + GET_DATA(form, vector, data); SETUP_ENV(the_env); the_env->values[0] = reg0; n = cl_stack_push_values(); @@ -1348,7 +1401,8 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) /* We are going to call a function. However, we would * like to step _in_ the function. STEPPER takes care of * that. */ - cl_fixnum n = GET_OPARG(vector); + cl_fixnum n; + GET_OPARG(n, vector); SETUP_ENV(the_env); if (SYM_VAL(@'si::*step-action*') == Ct) { STACK_PUSH(the_env, reg0); diff --git a/src/h/bytecodes.h b/src/h/bytecodes.h index 2b52596e5..fbf48c745 100644 --- a/src/h/bytecodes.h +++ b/src/h/bytecodes.h @@ -7,122 +7,8 @@ *** CODE. **********************************************************************/ /* - OP_BLOCK block-name{obj} - ... - OP_EXIT_FRAME - Exits the innermost frame (created by OP_BLOCK, OP_DO, etc). - - OP_EXIT - Executes the enclosed forms in a named block - - OP_PUSH - Pushes the object in VALUES(0) - - OP_PUSHV n{arg}, var{symbol} - Pushes the value of the n-th local onto the stack. VAR is given - for readability purposes only. - - OP_PUSHVS var{symbol} - Pushes the value of the symbol VAR onto the stack. - - OP_VAR n{arg} - Returns the value of the n-th local. - - OP_VARS var{symbol} - Returns the value of the symbol VAR. - - OP_PUSHQ value{obj} - Pushes "value" onto the stack. - - OP_PUSHV n{arg}, var{symbol} - Pushes the value of the n-th local. The name of the variable is - kept for readability purposes. - - OP_PUSHVALUES - Pushes the values output by the last form. - - OP_MCALL - ... - OP_EXIT - Saves the stack pointer, executes several forms and - funcalls VALUES(0) using the content of the stack. - - OP_CALLG narg{arg}, function{symbol} - Calls global "function" using the last "narg" values in the stack. - OP_PCALLG narg{arg}, function{symbol} - Calls global "function" using the last "narg" values in the stack. - The first result of the call is also pushed. - - OP_CALL narg{arg} - Calls VALUES(0) using the last "narg" values in the stack. - OP_PCALL narg{arg} - Calls VALUES(0) using the last "narg" values in the stack. - The first result of the call is also pushed. - - OP_FCALL narg{arg} - Pops NARG arguments from the stack, plus a function object and - builds up a function call. - - OP_CATCH dest{label} - ... - OP_EXIT - Sets a catch point with the tag in VALUES(0). The end of - the block is marked by "dest". - - OP_FLET nfun{arg} - ... - OP_EXIT - - OP_LABELS nfun{arg} - ... - OP_EXIT - - OP_FUNCTION symbol{obj} - - OP_CLOSE interpreted-function{obj} - - OP_GO tag-name{obj} - - OP_THROW tag-name{obj} - - OP_RETURN tag-name{obj} - - OP_JMP dest{label} - OP_JNIL dest{label} - OP_JT dest{label} - - OP_CASE n{arg} - object1{obj} dest1{label} - object2{obj} dest2{label} - ... - objectn{obj} destn{label} - destx{label} - dest1: - ... - OP_EXIT - dest2: - ... - OP_EXIT - ... - destn: - ... - OP_EXIT - destx: - - OP_DO exit{label} - ... - OP_EXIT - - OP_PUSHENV - ... - OP_EXIT - - OP_DOLIST - OP_BIND var{obj} - OP_EXIT - + * See ecl/src/c/interpreter.d for a detailed explanation of all opcodes */ - enum { OP_NOP, OP_QUOTE, @@ -217,9 +103,18 @@ typedef int16_t cl_oparg; #define READ_OPCODE(v) (*(cl_opcode *)(v)) #define READ_OPARG(v) (*(cl_oparg *)(v)) #define GET_OPCODE(v) (*((cl_opcode *)(v)++)) -#define GET_OPARG(v) (*((cl_oparg *)(v)++)) -#define GET_DATA(v,b) (b->bytecodes.data[GET_OPARG(v)]) -#define GET_LABEL(pc,v) {pc = (v) + READ_OPARG(v); v += OPARG_SIZE;} +#define GET_OPARG(r,v) { \ + r = *((cl_oparg *)(v)++); \ +} +#define GET_DATA(r,v,data) { \ + cl_oparg ndx; \ + GET_OPARG(ndx, v); \ + r = data[ndx]; \ +} +#define GET_LABEL(pc,v) { \ + pc = (v) + READ_OPARG(v); \ + v += OPARG_SIZE; \ +} /********************************************************************** * THREADED INTERPRETER CODE From 7732ada63b777452398718adc4de6d7204a1cd41 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 15:07:37 +0000 Subject: [PATCH 48/71] Avoid using FORMAT when it has not been defined. --- src/c/disassembler.d | 31 ++++++++++++++++++++++++------- 1 file changed, 24 insertions(+), 7 deletions(-) diff --git a/src/c/disassembler.d b/src/c/disassembler.d index 8499f47ac..e64720357 100644 --- a/src/c/disassembler.d +++ b/src/c/disassembler.d @@ -190,9 +190,10 @@ disassemble_tagbody(cl_object bytecodes, cl_opcode *vector) { print_noarg("TAGBODY"); for (i=0; ibytecodes.data; + cl_object line_no; + if (cl_fboundp(@'si::formatter-aux') != Cnil) + line_format = make_constant_base_string("~%~4d\t"); + else + line_format = Cnil; BEGIN: - cl_format(3, Ct, line_format, MAKE_FIXNUM(vector-base)); + if (0) { + line_no = MAKE_FIXNUM(vector-base); + } else { + line_no = @'*'; + } + if (line_format != Cnil) { + cl_format(3, Ct, line_format, line_no); + } else { + ecl_princ_char('\n', Ct); + ecl_princ(line_no, Ct); + ecl_princ_char('\t', Ct); + } switch (GET_OPCODE(vector)) { /* OP_NOP @@ -610,10 +627,10 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { case OP_CAR: string = "CAR\tREG0"; goto NOARG; case OP_CDR: string = "CDR\tREG0"; goto NOARG; case OP_LIST: string = "LIST\t"; - GET_OPARG(n, bytecodes); + GET_OPARG(n, vector); goto OPARG; case OP_LISTA: string = "LIST*\t"; - GET_OPARG(n, bytecodes); + GET_OPARG(n, vector); goto OPARG; case OP_CALLG1: string = "CALLG1\t"; GET_DATA(o, vector, data); From 44757605974f67053b60269e0fcf5e178d0bd7cb Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 15:07:50 +0000 Subject: [PATCH 49/71] Fixed typo. --- src/c/compiler.d | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/c/compiler.d b/src/c/compiler.d index 43d885ad0..31c51fe07 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -226,8 +226,13 @@ asm_complete(register int op, register cl_index pc) { #ifdef ECL_SMALL_BYTECODES char low = delta & 0xFF; char high = delta >> 8; +# ifdef WORDS_BIGENDIAN + cl_env.stack[pc] = (cl_object)(cl_fixnum)high; + cl_env.stack[pc+1] = (cl_object)(cl_fixnum)low; +# else cl_env.stack[pc] = (cl_object)(cl_fixnum)low; cl_env.stack[pc+1] = (cl_object)(cl_fixnum)high; +# endif #else cl_env.stack[pc] = (cl_object)(cl_fixnum)delta; #endif From aa50e7ef4c98a9ae996253939a97a56d44a828d3 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 15:08:03 +0000 Subject: [PATCH 50/71] Separate lisp objects for functions with fixed and variable # arguments --- src/c/all_symbols.d | 15 +++++++++------ src/c/alloc.d | 2 ++ src/c/alloc_2.d | 2 ++ src/c/cfun.d | 21 ++++++++++++--------- src/c/compiler.d | 12 ++++++------ src/c/disassembler.d | 2 +- src/c/eval.d | 45 +++++++++++++++++++++----------------------- src/c/gbc.d | 1 + src/c/instance.d | 1 + src/c/interpreter.d | 5 +++-- src/c/predicate.d | 6 ++++-- src/c/print.d | 1 + src/c/reference.d | 3 ++- src/c/stacks.d | 1 + src/c/typespec.d | 1 + src/h/bytecodes.h | 45 +++++++++++++++++++++++++++++--------------- src/h/object.h | 1 + 17 files changed, 98 insertions(+), 66 deletions(-) diff --git a/src/c/all_symbols.d b/src/c/all_symbols.d index 1f82978fb..70cc5e96a 100644 --- a/src/c/all_symbols.d +++ b/src/c/all_symbols.d @@ -104,10 +104,9 @@ mangle_name(cl_object output, char *source, int l) @(return found output maxarg) } } else if (!Null(symbol)) { - cl_object fun; - fun = symbol->symbol.gfdef; - if (fun != OBJNULL && type_of(fun) == t_cfun && - fun->cfun.block == OBJNULL) { + cl_object fun = symbol->symbol.gfdef; + cl_type t = (fun == OBJNULL)? t_other : type_of(fun); + if ((t == t_cfun || t == t_cfunfixed) && fun->cfun.block == OBJNULL) { for (l = 0; l <= cl_num_symbols_in_core; l++) { cl_object s = (cl_object)(cl_symbols + l); if (fun == SYM_FUN(s)) { @@ -220,9 +219,13 @@ make_this_symbol(int i, cl_object s, int code, const char *name, if (form) { s->symbol.stype |= stp_special_form; } else if (fun) { - cl_object f = cl_make_cfun_va(fun, s, NULL); + cl_object f; + if (narg >= 0) { + f = cl_make_cfun(fun, s, NULL, narg); + } else { + f = cl_make_cfun_va(fun, s, NULL); + } SYM_FUN(s) = f; - f->cfun.narg = narg; } cl_num_symbols_in_core = i + 1; } diff --git a/src/c/alloc.d b/src/c/alloc.d index fae1dd5b0..0617c172b 100644 --- a/src/c/alloc.d +++ b/src/c/alloc.d @@ -379,6 +379,7 @@ ONCE_MORE: obj->bclosure.lex = Cnil; break; case t_cfun: + case t_cfunfixed: obj->cfun.name = OBJNULL; obj->cfun.block = NULL; break; @@ -743,6 +744,7 @@ init_alloc(void) init_tm(t_random, "$RANDOM-STATE", sizeof(struct ecl_random), 1); init_tm(t_readtable, "rREADTABLE", sizeof(struct ecl_readtable), 1); init_tm(t_cfun, "fCFUN", sizeof(struct ecl_cfun), 32); + init_tm(t_cfunfixed, "fCFUN", sizeof(struct ecl_cfun), 32); init_tm(t_cclosure, "cCCLOSURE", sizeof(struct ecl_cclosure), 1); #ifndef CLOS init_tm(t_structure, "SSTRUCTURE", sizeof(struct ecl_structure), 32); diff --git a/src/c/alloc_2.d b/src/c/alloc_2.d index 503a70633..4da6a0dc0 100644 --- a/src/c/alloc_2.d +++ b/src/c/alloc_2.d @@ -96,6 +96,7 @@ cl_alloc_object(cl_type t) case t_bytecodes: case t_bclosure: case t_cfun: + case t_cfunfixed: case t_cclosure: #ifdef CLOS case t_instance: @@ -244,6 +245,7 @@ init_alloc(void) init_tm(t_random, "RANDOM-STATE", sizeof(struct ecl_random)); init_tm(t_readtable, "READTABLE", sizeof(struct ecl_readtable)); init_tm(t_cfun, "CFUN", sizeof(struct ecl_cfun)); + init_tm(t_cfunfixed, "CFUN", sizeof(struct ecl_cfun)); init_tm(t_cclosure, "CCLOSURE", sizeof(struct ecl_cclosure)); #ifndef CLOS init_tm(t_structure, "STRUCTURE", sizeof(struct ecl_structure)); diff --git a/src/c/cfun.d b/src/c/cfun.d index c111880a5..abfbf9d0b 100644 --- a/src/c/cfun.d +++ b/src/c/cfun.d @@ -23,7 +23,7 @@ cl_make_cfun(void *c_function, cl_object name, cl_object cblock, int narg) { cl_object cf; - cf = cl_alloc_object(t_cfun); + cf = cl_alloc_object(t_cfunfixed); cf->cfun.entry = c_function; cf->cfun.name = name; cf->cfun.block = cblock; @@ -93,6 +93,7 @@ si_compiled_function_name(cl_object fun) case t_bytecodes: output = fun->bytecodes.name; break; case t_cfun: + case t_cfunfixed: output = fun->cfun.name; break; case t_cclosure: output = Cnil; break; @@ -122,6 +123,7 @@ cl_function_lambda_expression(cl_object fun) output = @list*(3, @'ext::lambda-block', name, output); break; case t_cfun: + case t_cfunfixed: name = fun->cfun.name; lex = Cnil; output = Cnil; @@ -152,12 +154,13 @@ si_compiled_function_block(cl_object fun) cl_object output; switch(type_of(fun)) { - case t_cfun: - output = fun->cfun.block; break; - case t_cclosure: - output = fun->cclosure.block; break; - default: - FEerror("~S is not a compiled-function.", 1, fun); - } - @(return output) + case t_cfun: + case t_cfunfixed: + output = fun->cfun.block; break; + case t_cclosure: + output = fun->cclosure.block; break; + default: + FEerror("~S is not a compiled-function.", 1, fun); + } + @(return output) } diff --git a/src/c/compiler.d b/src/c/compiler.d index 31c51fe07..e7f0d4b67 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -166,8 +166,7 @@ asm_end(cl_index beginning) { bytecodes->bytecodes.file = (file == OBJNULL)? Cnil : file; bytecodes->bytecodes.file_position = (position == OBJNULL)? Cnil : position; for (i = 0, code = (cl_opcode *)bytecodes->bytecodes.code; i < code_size; i++) { - code[i] = - (cl_fixnum)cl_env.stack[beginning+i]; + code[i] = (cl_opcode)(cl_fixnum)cl_env.stack[beginning+i]; } for (i=0; i < data_size; i++) { bytecodes->bytecodes.data[i] = CAR(ENV->constants); @@ -181,11 +180,11 @@ asm_end(cl_index beginning) { static void asm_arg(int n) { #ifdef WORDS_BIGENDIAN - asm_op((n >> 8)); + asm_op((n >> 8) & 0xFF); asm_op(n & 0xFF); #else asm_op(n & 0xFF); - asm_op((n >> 8)); + asm_op((n >> 8) & 0xFF); #endif } #else @@ -224,7 +223,7 @@ asm_complete(register int op, register cl_index pc) { FEprogram_error("Too large jump", 0); else { #ifdef ECL_SMALL_BYTECODES - char low = delta & 0xFF; + unsigned char low = delta & 0xFF; char high = delta >> 8; # ifdef WORDS_BIGENDIAN cl_env.stack[pc] = (cl_object)(cl_fixnum)high; @@ -1996,7 +1995,8 @@ for special form ~S.", 1, function); && function < (cl_object)(cl_symbols + cl_num_symbols_in_core)) { cl_object f = SYM_FUN(function); - if (f != OBJNULL && type_of(f) == t_cfun) { + cl_type t = (f == OBJNULL)? t_other : type_of(f); + if (t == t_cfunfixed) { cl_object args = ECL_CONS_CDR(stmt); cl_index n = ecl_length(args); if (f->cfun.narg == 1 && n == 1) { diff --git a/src/c/disassembler.d b/src/c/disassembler.d index e64720357..2abc91316 100644 --- a/src/c/disassembler.d +++ b/src/c/disassembler.d @@ -215,7 +215,7 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { else line_format = Cnil; BEGIN: - if (0) { + if (1) { line_no = MAKE_FIXNUM(vector-base); } else { line_no = @'*'; diff --git a/src/c/eval.d b/src/c/eval.d index cf8b6cea6..49e18bf1c 100644 --- a/src/c/eval.d +++ b/src/c/eval.d @@ -68,13 +68,11 @@ ecl_apply_from_stack_frame(cl_object frame, cl_object x) if (fun == OBJNULL || fun == Cnil) FEundefined_function(x); switch (type_of(fun)) { + case t_cfunfixed: + if (narg != (cl_index)fun->cfun.narg) + FEwrong_num_arguments(fun); + return APPLY_fixed(narg, (cl_objectfn_fixed)fun->cfun.entry, sp); case t_cfun: - if (fun->cfun.narg >= 0) { - if (narg != (cl_index)fun->cfun.narg) - FEwrong_num_arguments(fun); - return APPLY_fixed(narg, (cl_objectfn_fixed)fun->cfun.entry, - sp); - } return APPLY(narg, fun->cfun.entry, sp); case t_cclosure: return APPLY_closure(narg, fun->cclosure.entry, @@ -123,26 +121,25 @@ _ecl_link_call(cl_object sym, cl_objectfn *pLK, cl_object cblock, int narg, cl_v if (fun == OBJNULL) goto ERROR; switch (type_of(fun)) { + case t_cfunfixed: + if (narg != fun->cfun.narg) + FEwrong_num_arguments(fun); + frame = build_funcall_frame((cl_object)&frame_aux, args); + out = APPLY_fixed(narg, (cl_objectfn_fixed)fun->cfun.entry, + frame->frame.bottom); + break; case t_cfun: - if (fun->cfun.narg >= 0) { - if (narg != fun->cfun.narg) - FEwrong_num_arguments(fun); - frame = build_funcall_frame((cl_object)&frame_aux, args); - out = APPLY_fixed(narg, (cl_objectfn_fixed)fun->cfun.entry, - frame->frame.bottom); - } else { - if (pLK) { - si_put_sysprop(sym, @'si::link-from', - CONS(CONS(ecl_make_unsigned_integer((cl_index)pLK), - ecl_make_unsigned_integer((cl_index)*pLK)), - si_get_sysprop(sym, @'si::link-from'))); - *pLK = fun->cfun.entry; - cblock->cblock.links = - CONS(sym, cblock->cblock.links); - } - frame = build_funcall_frame((cl_object)&frame_aux, args); - out = APPLY(narg, fun->cfun.entry, frame->frame.bottom); + if (pLK) { + si_put_sysprop(sym, @'si::link-from', + CONS(CONS(ecl_make_unsigned_integer((cl_index)pLK), + ecl_make_unsigned_integer((cl_index)*pLK)), + si_get_sysprop(sym, @'si::link-from'))); + *pLK = fun->cfun.entry; + cblock->cblock.links = + CONS(sym, cblock->cblock.links); } + frame = build_funcall_frame((cl_object)&frame_aux, args); + out = APPLY(narg, fun->cfun.entry, frame->frame.bottom); break; #ifdef CLOS case t_instance: diff --git a/src/c/gbc.d b/src/c/gbc.d index 341cb6a6e..178250e28 100644 --- a/src/c/gbc.d +++ b/src/c/gbc.d @@ -364,6 +364,7 @@ BEGIN: break; case t_cfun: + case t_cfunfixed: mark_object(x->cfun.block); mark_next(x->cfun.name); break; diff --git a/src/c/instance.d b/src/c/instance.d index 901cb9b34..3969903f6 100644 --- a/src/c/instance.d +++ b/src/c/instance.d @@ -336,6 +336,7 @@ cl_class_of(cl_object x) case t_bytecodes: case t_bclosure: case t_cfun: + case t_cfunfixed: case t_cclosure: index = ECL_BUILTIN_FUNCTION; break; #ifdef ECL_THREADS diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 1694f5333..de4e3535b 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -556,9 +556,10 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) ECL_OFFSET_TABLE; typedef struct cl_env_struct *cl_env_ptr; const cl_env_ptr the_env = &cl_env; - cl_opcode *vector = pc; + register cl_opcode *vector = pc; cl_object *data = bytecodes->bytecodes.data; - cl_object reg0 = the_env->values[0], reg1, lex_env = env; + register cl_object reg0 = the_env->values[0]; + cl_object reg1, lex_env = env; struct ecl_stack_frame frame_aux; volatile struct ihs_frame ihs; ihs_push(&ihs, bytecodes, env); diff --git a/src/c/predicate.d b/src/c/predicate.d index 123e65868..0ba28b7ba 100644 --- a/src/c/predicate.d +++ b/src/c/predicate.d @@ -228,7 +228,8 @@ cl_functionp(cl_object x) cl_object output; t = type_of(x); - if (t == t_bytecodes || t == t_bclosure || t == t_cfun || t == t_cclosure + if (t == t_bytecodes || t == t_bclosure || t == t_cfun + || t == t_cfunfixed || t == t_cclosure #ifdef CLOS || (t == t_instance && x->instance.isgf) #endif @@ -243,7 +244,8 @@ cl_object cl_compiled_function_p(cl_object x) { cl_type t = type_of(x); - @(return ((t == t_bytecodes || t == t_bclosure || t == t_cfun || t == t_cclosure) ? Ct : Cnil)) + @(return ((t == t_bytecodes || t == t_bclosure || t == t_cfun + || t == t_cfunfixed || t == t_cclosure) ? Ct : Cnil)) } cl_object diff --git a/src/c/print.d b/src/c/print.d index 1852c6120..d0a9f48e6 100644 --- a/src/c/print.d +++ b/src/c/print.d @@ -1520,6 +1520,7 @@ si_write_ugly_object(cl_object x, cl_object stream) } break; case t_cfun: + case t_cfunfixed: if (ecl_print_readably()) FEprint_not_readable(x); write_str("#cfun.name != Cnil) diff --git a/src/c/reference.d b/src/c/reference.d index 5f79c897f..e00c5dbb4 100644 --- a/src/c/reference.d +++ b/src/c/reference.d @@ -112,7 +112,8 @@ cl_object si_coerce_to_function(cl_object fun) { cl_type t = type_of(fun); - if (!(t == t_cfun || t == t_cclosure || t == t_bytecodes || t == t_bclosure + if (!(t == t_cfun || t == t_cfunfixed || t == t_cclosure + || t == t_bytecodes || t == t_bclosure #ifdef CLOS || (t == t_instance && fun->instance.isgf) #endif diff --git a/src/c/stacks.d b/src/c/stacks.d index f076cd45d..a810ec51b 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -186,6 +186,7 @@ ihs_function_name(cl_object x) return y; case t_cfun: + case t_cfunfixed: return(x->cfun.name); default: diff --git a/src/c/typespec.d b/src/c/typespec.d index 23dec4e0e..62877da86 100644 --- a/src/c/typespec.d +++ b/src/c/typespec.d @@ -183,6 +183,7 @@ ecl_type_to_symbol(cl_type t) case t_bytecodes: case t_bclosure: case t_cfun: + case t_cfunfixed: case t_cclosure: return @'compiled-function'; #ifdef ECL_THREADS diff --git a/src/h/bytecodes.h b/src/h/bytecodes.h index fbf48c745..d4f429bfa 100644 --- a/src/h/bytecodes.h +++ b/src/h/bytecodes.h @@ -90,22 +90,37 @@ enum { }; #define MAX_OPARG 0x7FFF -#ifdef ECL_SMALL_BYTECODES -#define OPCODE_SIZE 1 -#define OPARG_SIZE sizeof(cl_oparg) -typedef char cl_opcode; -#else -#define OPCODE_SIZE 1 -#define OPARG_SIZE 1 -typedef int16_t cl_opcode; -#endif typedef int16_t cl_oparg; -#define READ_OPCODE(v) (*(cl_opcode *)(v)) -#define READ_OPARG(v) (*(cl_oparg *)(v)) -#define GET_OPCODE(v) (*((cl_opcode *)(v)++)) -#define GET_OPARG(r,v) { \ - r = *((cl_oparg *)(v)++); \ -} + +/* + * Note that in the small bytecodes case, we have to recompose a signed + * small integer out of its pieces. We have to be careful because the + * least significant byte has to be interpreted as unsigned, while the + * most significant byte carries a sign. + */ +#ifdef ECL_SMALL_BYTECODES + typedef signed char cl_opcode; +# define OPCODE_SIZE 1 +# define OPARG_SIZE 2 +# ifdef WORDS_BIGENDIAN +# define READ_OPARG(v) ((cl_fixnum)v[0] << 8) + (unsigned char)v[1] +# else +#if 0 +# define READ_OPARG(v) ((cl_fixnum)v[1] << 8) + (unsigned char)v[0] +#else +# define READ_OPARG(v) ((cl_oparg*)v)[0] +#endif +# endif +# define GET_OPARG(r,v) { r = READ_OPARG(v); v += 2; } +#else + typedef int16_t cl_opcode; +# define OPCODE_SIZE 1 +# define OPARG_SIZE 1 +# define READ_OPCODE(v) v[0] +# define READ_OPARG(v) v[0] +# define GET_OPARG(r,v) { r = READ_OPARG(v); v++; } +#endif +#define GET_OPCODE(v) *((v)++) #define GET_DATA(r,v,data) { \ cl_oparg ndx; \ GET_OPARG(ndx, v); \ diff --git a/src/h/object.h b/src/h/object.h index 80ed81e9b..b24bc882e 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -73,6 +73,7 @@ typedef enum { t_bytecodes, t_bclosure, t_cfun, + t_cfunfixed, t_cclosure, #ifdef CLOS t_instance, From e65ebd076c0555c2e1a1cff7f0bff39f540a9a4d Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 15:08:38 +0000 Subject: [PATCH 51/71] Simplify the interpreter code for calling functions --- src/c/compiler.d | 21 ++--- src/c/disassembler.d | 33 ++------ src/c/interpreter.d | 180 +++++++++++++++++++++++-------------------- src/h/bytecodes.h | 156 ++++++++++++++++++------------------- 4 files changed, 187 insertions(+), 203 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index e7f0d4b67..72ad1ac24 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -783,13 +783,8 @@ c_block(cl_object body, int old_flags) { [OP_CALL + nargs] function_name - [OP_PCALL + nargs] - function_name - [OP_FCALL + nargs] - [OP_PFCALL + nargs] - OP_CALL and OP_FCALL leave all arguments in the VALUES() array, while OP_PCALL and OP_PFCALL leave the first argument in the stack. @@ -822,16 +817,19 @@ c_call(cl_object args, int flags) { * calls: OP_STEPFCALL. */ asm_function(name, (flags & FLAG_GLOBAL) | FLAG_REG0); asm_op2(OP_STEPCALL, nargs); - flags = FLAG_REG0; + asm_op(OP_POP1); + flags = FLAG_VALUES; } else if (SYMBOLP(name) && ((flags & FLAG_GLOBAL) || Null(c_tag_ref(name, @':function')))) { - asm_op2(push? OP_PCALLG : OP_CALLG, nargs); + asm_op2(OP_CALLG, nargs); asm_c(name); + flags = FLAG_VALUES; } else { /* Fixme!! We can optimize the case of global functions! */ asm_function(name, (flags & FLAG_GLOBAL) | FLAG_REG0); - asm_op2(push? OP_PCALL : OP_CALL, nargs); + asm_op2(OP_CALL, nargs); + flags = FLAG_VALUES; } return flags; } @@ -860,10 +858,12 @@ c_funcall(cl_object args, int flags) { nargs = c_arguments(args); if (ENV->stepping) { asm_op2(OP_STEPCALL, nargs); - flags = FLAG_REG0; + flags = FLAG_VALUES; } else { - asm_op2((flags & FLAG_PUSH)? OP_PFCALL : OP_FCALL, nargs); + asm_op2(OP_FCALL, nargs); + flags = FLAG_VALUES; } + asm_op(OP_POP1); return flags; } @@ -1472,6 +1472,7 @@ c_multiple_value_call(cl_object args, int flags) { asm_op(op); } asm_op(OP_MCALL); + asm_op(OP_POP1); return FLAG_VALUES; } diff --git a/src/c/disassembler.d b/src/c/disassembler.d index 2abc91316..5f41adb53 100644 --- a/src/c/disassembler.d +++ b/src/c/disassembler.d @@ -303,6 +303,11 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { */ case OP_POP: string = "POP"; goto NOARG; + /* OP_POP1 + Pops a single value pushed by a OP_PUSH[V[S]] operator. + */ + case OP_POP1: string = "POP1"; + goto NOARG; /* OP_POPVALUES Pops all values pushed by a OP_PUSHVALUES operator. */ @@ -348,34 +353,6 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { GET_OPARG(n, vector); goto OPARG; - /* OP_PCALL n{arg} - Calls the function in VALUES(0) with N arguments which - have been deposited in the stack. The first output value - is pushed on the stack. - */ - case OP_PCALL: string = "PCALL\t"; - GET_OPARG(n, vector); - goto OPARG; - - /* OP_PCALLG n{arg}, name{arg} - Calls the function NAME with N arguments which have been - deposited in the stack. The first output value is pushed on - the stack. - */ - case OP_PCALLG: string = "PCALLG\t"; - GET_OPARG(n, vector); - GET_DATA(o, vector, data); - goto OPARG_ARG; - - /* OP_PFCALL n{arg} - Calls the function in the stack with N arguments which - have been deposited in the stack. The first output value - is pushed on the stack. - */ - case OP_PFCALL: string = "PFCALL\t"; - GET_OPARG(n, vector); - goto OPARG; - /* OP_MCALL Similar to FCALL, but gets the number of arguments from the stack (They all have been deposited by OP_PUSHVALUES) diff --git a/src/c/interpreter.d b/src/c/interpreter.d index de4e3535b..6b39f6727 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -561,6 +561,7 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) register cl_object reg0 = the_env->values[0]; cl_object reg1, lex_env = env; struct ecl_stack_frame frame_aux; + cl_index narg; volatile struct ihs_frame ihs; ihs_push(&ihs, bytecodes, env); frame_aux.t = t_frame; @@ -672,30 +673,6 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) STACK_PUSH(the_env, aux); THREAD_NEXT; } - /* OP_CALL n{arg} - Calls the function in REG0 with N arguments which - have been deposited in the stack. The output values - are left in VALUES(...) - */ - CASE(OP_CALL); { - cl_fixnum n; - GET_OPARG(n, vector); - INTERPRET_FUNCALL(reg0, the_env, frame_aux, n, reg0); - THREAD_NEXT; - } - - /* OP_CALLG n{arg}, name{arg} - Calls the function NAME with N arguments which have been - deposited in the stack. The output values are left in VALUES. - */ - CASE(OP_CALLG); { - cl_fixnum n; - cl_object f; - GET_OPARG(n, vector); - GET_DATA(f, vector, data); - INTERPRET_FUNCALL(reg0, the_env, frame_aux, n, f); - THREAD_NEXT; - } CASE(OP_CALLG1); { cl_object s; @@ -715,19 +692,36 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) THREAD_NEXT; } + /* OP_CALL n{arg} + Calls the function in REG0 with N arguments which + have been deposited in the stack. The first output value + is pushed on the stack. + */ + CASE(OP_CALL); { + GET_OPARG(narg, vector); + goto DO_CALL; + } + + /* OP_CALLG n{arg}, name{arg} + Calls the function NAME with N arguments which have been + deposited in the stack. The first output value is pushed on + the stack. + */ + CASE(OP_CALLG); { + GET_OPARG(narg, vector); + GET_DATA(reg0, vector, data); + goto DO_CALL; + } + /* OP_FCALL n{arg} Calls a function in the stack with N arguments which have been also deposited in the stack. The output values are left in VALUES(...) */ CASE(OP_FCALL); { - cl_fixnum n; - cl_object fun; - GET_OPARG(n, vector); - fun = STACK_REF(the_env,-n-1); - INTERPRET_FUNCALL(reg0, the_env, frame_aux, n, fun); - STACK_POP(the_env); - THREAD_NEXT; + GET_OPARG(narg, vector); + reg0 = STACK_REF(the_env,-narg-1); + goto DO_CALL; } /* OP_MCALL @@ -735,56 +729,79 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) the stack (They all have been deposited by OP_PUSHVALUES) */ CASE(OP_MCALL); { - cl_fixnum n = fix(STACK_POP(the_env)); - cl_object fun = STACK_REF(the_env,-n-1); - INTERPRET_FUNCALL(reg0, the_env, frame_aux, n, fun); + narg = fix(STACK_POP(the_env)); + reg0 = STACK_REF(the_env,-narg-1); + goto DO_CALL; + } + + DO_CALL: { + cl_object x = reg0; + cl_object frame = (cl_object)&frame_aux; + frame_aux.top = the_env->stack_top; + frame_aux.bottom = the_env->stack_top - narg; + AGAIN: + if (reg0 == OBJNULL || reg0 == Cnil) + FEundefined_function(x); + switch (type_of(reg0)) { + case t_cfunfixed: + if (narg != (cl_index)reg0->cfun.narg) + FEwrong_num_arguments(reg0); + reg0 = APPLY_fixed(narg, (cl_objectfn_fixed)reg0->cfun.entry, + frame_aux.bottom); + break; + case t_cfun: + reg0 = APPLY(narg, reg0->cfun.entry, frame_aux.bottom); + break; + case t_cclosure: + reg0 = APPLY_closure(narg, reg0->cclosure.entry, + reg0->cclosure.env, frame_aux.bottom); + break; +#ifdef CLOS + case t_instance: + switch (reg0->instance.isgf) { + case ECL_STANDARD_DISPATCH: + reg0 = _ecl_standard_dispatch(frame, reg0); + break; + case ECL_USER_DISPATCH: + reg0 = reg0->instance.slots[reg0->instance.length - 1]; + goto AGAIN; + default: + FEinvalid_function(reg0); + } + break; +#endif + case t_symbol: + if (reg0->symbol.stype & stp_macro) + FEundefined_function(x); + reg0 = SYM_FUN(reg0); + goto AGAIN; + case t_bytecodes: + reg0 = ecl_apply_lambda(frame, reg0); + break; + case t_bclosure: + reg0 = ecl_apply_bclosure(frame, reg0); + break; + default: + FEinvalid_function(reg0); + } + the_env->stack_top -= narg; + THREAD_NEXT; + } + + /* OP_POP + Pops a singe value pushed by a OP_PUSH* operator. + */ + CASE(OP_POP); { + reg0 = STACK_POP(the_env); + THREAD_NEXT; + } + /* OP_POP1 + Pops a singe value pushed by a OP_PUSH* operator, ignoring it. + */ + CASE(OP_POP1); { STACK_POP(the_env); THREAD_NEXT; } - - /* OP_PCALL n{arg} - Calls the function in REG0 with N arguments which - have been deposited in the stack. The first output value - is pushed on the stack. - */ - CASE(OP_PCALL); { - cl_fixnum n; - GET_OPARG(n, vector); - INTERPRET_FUNCALL(reg0, the_env, frame_aux, n, reg0); - STACK_PUSH(the_env, reg0); - THREAD_NEXT; - } - - /* OP_PCALLG n{arg}, name{arg} - Calls the function NAME with N arguments which have been - deposited in the stack. The first output value is pushed on - the stack. - */ - CASE(OP_PCALLG); { - cl_fixnum n; - cl_object f; - GET_OPARG(n, vector); - GET_DATA(f, vector, data); - INTERPRET_FUNCALL(f, the_env, frame_aux, n, f); - STACK_PUSH(the_env, f); - THREAD_NEXT; - } - - /* OP_PFCALL n{arg} - Calls the function in the stack with N arguments which - have been also deposited in the stack. The first output value - is pushed on the stack. - */ - CASE(OP_PFCALL); { - cl_fixnum n; - cl_object fun; - GET_OPARG(n, vector); - fun = STACK_REF(the_env, -n-1); - INTERPRET_FUNCALL(fun, the_env, frame_aux, n, fun); - STACK_REF(the_env, -1) = fun; - THREAD_NEXT; - } - /* OP_EXIT Marks the end of a high level construct (BLOCK, CATCH...) or a function. @@ -1241,13 +1258,6 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) STACK_REF(the_env, -1) = MAKE_FIXNUM(n + i); THREAD_NEXT; } - /* OP_POP - Pops a singe value pushed by a OP_PUSH* operator. - */ - CASE(OP_POP); { - reg0 = STACK_POP(the_env); - THREAD_NEXT; - } /* OP_POPVALUES Pops all values pushed by a OP_PUSHVALUES operator. */ diff --git a/src/h/bytecodes.h b/src/h/bytecodes.h index d4f429bfa..ad0b944a4 100644 --- a/src/h/bytecodes.h +++ b/src/h/bytecodes.h @@ -24,15 +24,14 @@ enum { OP_PUSHV, OP_PUSHVS, OP_PUSHQ, - OP_CALLG, OP_CALLG1, OP_CALLG2, OP_CALL, + OP_CALLG, OP_FCALL, - OP_PCALLG, - OP_PCALL, - OP_PFCALL, OP_MCALL, + OP_POP, + OP_POP1, OP_EXIT, OP_FLET, OP_LABELS, @@ -73,7 +72,6 @@ enum { OP_PROGV, OP_EXIT_PROGV, OP_PUSHVALUES, - OP_POP, OP_POPVALUES, OP_PUSHMOREVALUES, OP_VALUES, @@ -165,80 +163,78 @@ typedef int16_t cl_oparg; #else #define ECL_OFFSET_TABLE \ static const int offsets[] = {\ - &&LBL_OP_NOP - &&LBL_OP_NOP,\ - &&LBL_OP_QUOTE - &&LBL_OP_NOP,\ - &&LBL_OP_ENDP - &&LBL_OP_NOP,\ - &&LBL_OP_CONS - &&LBL_OP_NOP,\ - &&LBL_OP_CAR - &&LBL_OP_NOP,\ - &&LBL_OP_CDR - &&LBL_OP_NOP,\ - &&LBL_OP_LIST - &&LBL_OP_NOP,\ - &&LBL_OP_LISTA - &&LBL_OP_NOP,\ - &&LBL_OP_VAR - &&LBL_OP_NOP,\ - &&LBL_OP_VARS - &&LBL_OP_NOP,\ - &&LBL_OP_PUSH - &&LBL_OP_NOP,\ - &&LBL_OP_PUSHV - &&LBL_OP_NOP,\ - &&LBL_OP_PUSHVS - &&LBL_OP_NOP,\ - &&LBL_OP_PUSHQ - &&LBL_OP_NOP,\ - &&LBL_OP_CALLG - &&LBL_OP_NOP,\ - &&LBL_OP_CALLG1 - &&LBL_OP_NOP,\ - &&LBL_OP_CALLG2 - &&LBL_OP_NOP,\ - &&LBL_OP_CALL - &&LBL_OP_NOP,\ - &&LBL_OP_FCALL - &&LBL_OP_NOP,\ - &&LBL_OP_PCALLG - &&LBL_OP_NOP,\ - &&LBL_OP_PCALL - &&LBL_OP_NOP,\ - &&LBL_OP_PFCALL - &&LBL_OP_NOP,\ - &&LBL_OP_MCALL - &&LBL_OP_NOP,\ - &&LBL_OP_EXIT - &&LBL_OP_NOP,\ - &&LBL_OP_FLET - &&LBL_OP_NOP,\ - &&LBL_OP_LABELS - &&LBL_OP_NOP,\ - &&LBL_OP_LFUNCTION - &&LBL_OP_NOP,\ - &&LBL_OP_FUNCTION - &&LBL_OP_NOP,\ - &&LBL_OP_CLOSE - &&LBL_OP_NOP,\ - &&LBL_OP_GO - &&LBL_OP_NOP,\ - &&LBL_OP_RETURN - &&LBL_OP_NOP,\ - &&LBL_OP_THROW - &&LBL_OP_NOP,\ - &&LBL_OP_JMP - &&LBL_OP_NOP,\ - &&LBL_OP_JNIL - &&LBL_OP_NOP,\ - &&LBL_OP_JT - &&LBL_OP_NOP,\ - &&LBL_OP_JEQL - &&LBL_OP_NOP,\ - &&LBL_OP_JNEQL - &&LBL_OP_NOP,\ - &&LBL_OP_UNBIND - &&LBL_OP_NOP,\ - &&LBL_OP_UNBINDS - &&LBL_OP_NOP,\ - &&LBL_OP_BIND - &&LBL_OP_NOP,\ - &&LBL_OP_PBIND - &&LBL_OP_NOP,\ - &&LBL_OP_VBIND - &&LBL_OP_NOP,\ - &&LBL_OP_BINDS - &&LBL_OP_NOP,\ - &&LBL_OP_PBINDS - &&LBL_OP_NOP,\ - &&LBL_OP_VBINDS - &&LBL_OP_NOP,\ - &&LBL_OP_SETQ - &&LBL_OP_NOP,\ - &&LBL_OP_SETQS - &&LBL_OP_NOP,\ - &&LBL_OP_PSETQ - &&LBL_OP_NOP,\ - &&LBL_OP_PSETQS - &&LBL_OP_NOP,\ - &&LBL_OP_VSETQ - &&LBL_OP_NOP,\ - &&LBL_OP_VSETQS - &&LBL_OP_NOP,\ - &&LBL_OP_BLOCK - &&LBL_OP_NOP,\ - &&LBL_OP_DO - &&LBL_OP_NOP,\ - &&LBL_OP_CATCH - &&LBL_OP_NOP,\ - &&LBL_OP_TAGBODY - &&LBL_OP_NOP,\ - &&LBL_OP_EXIT_TAGBODY - &&LBL_OP_NOP,\ - &&LBL_OP_EXIT_FRAME - &&LBL_OP_NOP,\ - &&LBL_OP_PROTECT - &&LBL_OP_NOP,\ - &&LBL_OP_PROTECT_NORMAL - &&LBL_OP_NOP,\ - &&LBL_OP_PROTECT_EXIT - &&LBL_OP_NOP,\ - &&LBL_OP_PROGV - &&LBL_OP_NOP,\ - &&LBL_OP_EXIT_PROGV - &&LBL_OP_NOP,\ - &&LBL_OP_PUSHVALUES - &&LBL_OP_NOP,\ - &&LBL_OP_POP - &&LBL_OP_NOP,\ - &&LBL_OP_POPVALUES - &&LBL_OP_NOP,\ - &&LBL_OP_PUSHMOREVALUES - &&LBL_OP_NOP,\ - &&LBL_OP_VALUES - &&LBL_OP_NOP,\ - &&LBL_OP_VALUEREG0 - &&LBL_OP_NOP,\ - &&LBL_OP_NTHVAL - &&LBL_OP_NOP,\ - &&LBL_OP_NIL - &&LBL_OP_NOP,\ - &&LBL_OP_NOT - &&LBL_OP_NOP,\ - &&LBL_OP_PUSHNIL - &&LBL_OP_NOP,\ - &&LBL_OP_STEPIN - &&LBL_OP_NOP,\ - &&LBL_OP_STEPCALL - &&LBL_OP_NOP,\ - &&LBL_OP_STEPOUT - &&LBL_OP_NOP\ + 0,\ + &&LBL_OP_QUOTE - &&LBL_OP_NOP,\ + &&LBL_OP_ENDP - &&LBL_OP_NOP,\ + &&LBL_OP_CONS - &&LBL_OP_NOP,\ + &&LBL_OP_CAR - &&LBL_OP_NOP,\ + &&LBL_OP_CDR - &&LBL_OP_NOP,\ + &&LBL_OP_LIST - &&LBL_OP_NOP,\ + &&LBL_OP_LISTA - &&LBL_OP_NOP,\ + &&LBL_OP_VAR - &&LBL_OP_NOP,\ + &&LBL_OP_VARS - &&LBL_OP_NOP,\ + &&LBL_OP_PUSH - &&LBL_OP_NOP,\ + &&LBL_OP_PUSHV - &&LBL_OP_NOP,\ + &&LBL_OP_PUSHVS - &&LBL_OP_NOP,\ + &&LBL_OP_PUSHQ - &&LBL_OP_NOP,\ + &&LBL_OP_CALLG1 - &&LBL_OP_NOP,\ + &&LBL_OP_CALLG2 - &&LBL_OP_NOP,\ + &&LBL_OP_CALL - &&LBL_OP_NOP,\ + &&LBL_OP_CALLG - &&LBL_OP_NOP,\ + &&LBL_OP_FCALL - &&LBL_OP_NOP,\ + &&LBL_OP_MCALL - &&LBL_OP_NOP,\ + &&LBL_OP_POP - &&LBL_OP_NOP,\ + &&LBL_OP_POP1 - &&LBL_OP_NOP,\ + &&LBL_OP_EXIT - &&LBL_OP_NOP,\ + &&LBL_OP_FLET - &&LBL_OP_NOP,\ + &&LBL_OP_LABELS - &&LBL_OP_NOP,\ + &&LBL_OP_LFUNCTION - &&LBL_OP_NOP,\ + &&LBL_OP_FUNCTION - &&LBL_OP_NOP,\ + &&LBL_OP_CLOSE - &&LBL_OP_NOP,\ + &&LBL_OP_GO - &&LBL_OP_NOP,\ + &&LBL_OP_RETURN - &&LBL_OP_NOP,\ + &&LBL_OP_THROW - &&LBL_OP_NOP,\ + &&LBL_OP_JMP - &&LBL_OP_NOP,\ + &&LBL_OP_JNIL - &&LBL_OP_NOP,\ + &&LBL_OP_JT - &&LBL_OP_NOP,\ + &&LBL_OP_JEQL - &&LBL_OP_NOP,\ + &&LBL_OP_JNEQL - &&LBL_OP_NOP,\ + &&LBL_OP_UNBIND - &&LBL_OP_NOP,\ + &&LBL_OP_UNBINDS - &&LBL_OP_NOP,\ + &&LBL_OP_BIND - &&LBL_OP_NOP,\ + &&LBL_OP_PBIND - &&LBL_OP_NOP,\ + &&LBL_OP_VBIND - &&LBL_OP_NOP,\ + &&LBL_OP_BINDS - &&LBL_OP_NOP,\ + &&LBL_OP_PBINDS - &&LBL_OP_NOP,\ + &&LBL_OP_VBINDS - &&LBL_OP_NOP,\ + &&LBL_OP_SETQ - &&LBL_OP_NOP,\ + &&LBL_OP_SETQS - &&LBL_OP_NOP,\ + &&LBL_OP_PSETQ - &&LBL_OP_NOP,\ + &&LBL_OP_PSETQS - &&LBL_OP_NOP,\ + &&LBL_OP_VSETQ - &&LBL_OP_NOP,\ + &&LBL_OP_VSETQS - &&LBL_OP_NOP,\ + &&LBL_OP_BLOCK - &&LBL_OP_NOP,\ + &&LBL_OP_DO - &&LBL_OP_NOP,\ + &&LBL_OP_CATCH - &&LBL_OP_NOP,\ + &&LBL_OP_TAGBODY - &&LBL_OP_NOP,\ + &&LBL_OP_EXIT_TAGBODY - &&LBL_OP_NOP,\ + &&LBL_OP_EXIT_FRAME - &&LBL_OP_NOP,\ + &&LBL_OP_PROTECT - &&LBL_OP_NOP,\ + &&LBL_OP_PROTECT_NORMAL - &&LBL_OP_NOP,\ + &&LBL_OP_PROTECT_EXIT - &&LBL_OP_NOP,\ + &&LBL_OP_PROGV - &&LBL_OP_NOP,\ + &&LBL_OP_EXIT_PROGV - &&LBL_OP_NOP,\ + &&LBL_OP_PUSHVALUES - &&LBL_OP_NOP,\ + &&LBL_OP_POPVALUES - &&LBL_OP_NOP,\ + &&LBL_OP_PUSHMOREVALUES - &&LBL_OP_NOP,\ + &&LBL_OP_VALUES - &&LBL_OP_NOP,\ + &&LBL_OP_VALUEREG0 - &&LBL_OP_NOP,\ + &&LBL_OP_NTHVAL - &&LBL_OP_NOP,\ + &&LBL_OP_NIL - &&LBL_OP_NOP,\ + &&LBL_OP_NOT - &&LBL_OP_NOP,\ + &&LBL_OP_PUSHNIL - &&LBL_OP_NOP,\ + &&LBL_OP_STEPIN - &&LBL_OP_NOP,\ + &&LBL_OP_STEPCALL - &&LBL_OP_NOP,\ + &&LBL_OP_STEPOUT - &&LBL_OP_NOP,\ } #endif From 3654ccf8b47f55ad2f60a4de711e9e1f871b9897 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 15:08:52 +0000 Subject: [PATCH 52/71] Replace ecl_apply_{lambda|bclosure} with calls to ecl_interpret. --- src/c/compiler.d | 13 ++++--- src/c/eval.d | 8 ++--- src/c/interpreter.d | 84 ++++++++++++++------------------------------- src/h/bytecodes.h | 7 ++-- src/h/external.h | 5 +-- 5 files changed, 44 insertions(+), 73 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index 72ad1ac24..049aeef29 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -2061,7 +2061,7 @@ compile_body(cl_object body, int flags) { VALUES(0) = Cnil; NVALUES = 0; bytecodes = asm_end(handle); - ecl_interpret(ENV->lex_env, bytecodes, bytecodes->bytecodes.code); + ecl_interpret(Cnil, ENV->lex_env, bytecodes, 0); asm_clear(handle); ENV = old_c_env; #ifdef GBC_BOEHM @@ -2535,6 +2535,9 @@ ecl_make_lambda(cl_object name, cl_object lambda) { handle = asm_begin(); + /* Mark that we need to parse arguments */ + asm_op(OP_ENTRY); + /* Transform (SETF fname) => fname */ if (Null(si_valid_function_name_p(name))) FEprogram_error("LAMBDA: Not a valid function name ~S",1,name); @@ -2588,10 +2591,12 @@ ecl_make_lambda(cl_object name, cl_object lambda) { ENV->coalesce = TRUE; - if ((current_pc() - label) == OPARG_SIZE) + if ((current_pc() - label) == OPARG_SIZE) { set_pc(handle); - else + asm_op(OP_ENTRY); + } else { asm_complete(OP_JMP, label); + } while (!ecl_endp(auxs)) { /* Local bindings */ cl_object var = pop(&auxs); cl_object value = pop(&auxs); @@ -2703,7 +2708,7 @@ si_make_lambda(cl_object name, cl_object rest) VALUES(0) = Cnil; NVALUES = 0; { - cl_object output = ecl_interpret(interpreter_env, bytecodes, bytecodes->bytecodes.code); + cl_object output = ecl_interpret(Cnil, interpreter_env, bytecodes, 0); #ifdef GBC_BOEHM GC_free(bytecodes->bytecodes.code); GC_free(bytecodes->bytecodes.data); diff --git a/src/c/eval.d b/src/c/eval.d index 49e18bf1c..1b56a084c 100644 --- a/src/c/eval.d +++ b/src/c/eval.d @@ -95,9 +95,9 @@ ecl_apply_from_stack_frame(cl_object frame, cl_object x) fun = SYM_FUN(fun); goto AGAIN; case t_bytecodes: - return ecl_apply_lambda(frame, fun); + return ecl_interpret(frame, Cnil, fun, 0); case t_bclosure: - return ecl_apply_bclosure(frame, fun); + return ecl_interpret(frame, fun->bclosure.lex, fun->bclosure.code, 0); default: ERROR: FEinvalid_function(x); @@ -163,11 +163,11 @@ _ecl_link_call(cl_object sym, cl_objectfn *pLK, cl_object cblock, int narg, cl_v break; case t_bytecodes: frame = build_funcall_frame((cl_object)&frame_aux, args); - out = ecl_apply_lambda(frame, fun); + out = ecl_interpret(frame, Cnil, fun, 0); break; case t_bclosure: frame = build_funcall_frame((cl_object)&frame_aux, args); - out = ecl_apply_bclosure(frame, fun); + out = ecl_interpret(frame, fun->bclosure.lex, fun->bclosure.code, 0); break; default: ERROR: diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 6b39f6727..00be49bc8 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -328,7 +328,7 @@ lambda_bind(cl_object env, cl_narg narg, cl_object lambda, cl_object *sp) } else { cl_object defaults = data[1]; if (FIXNUMP(defaults)) { - defaults = ecl_interpret(env, lambda, (cl_opcode*)lambda->bytecodes.code + fix(defaults)); + defaults = ecl_interpret(Cnil, env, lambda, fix(defaults)); } env = lambda_bind_var(env, data[0], defaults, specials); if (!Null(data[2])) { @@ -417,7 +417,7 @@ lambda_bind(cl_object env, cl_narg narg, cl_object lambda, cl_object *sp) } else { cl_object defaults = data[2]; if (FIXNUMP(defaults)) { - defaults = ecl_interpret(env, lambda, (cl_opcode*)lambda->bytecodes.code + fix(defaults)); + defaults = ecl_interpret(Cnil, env, lambda, fix(defaults)); } env = lambda_bind_var(env, data[1],defaults,specials); } @@ -429,56 +429,6 @@ lambda_bind(cl_object env, cl_narg narg, cl_object lambda, cl_object *sp) return env; } -cl_object -ecl_apply_lambda(cl_object frame, cl_object fun) -{ - cl_object name, env; - bds_ptr old_bds_top; - - if (type_of(fun) != t_bytecodes) - FEinvalid_function(fun); - - /* Save the lexical environment and set up a new one */ - old_bds_top = cl_env.bds_top; - - /* Establish bindings */ - env = lambda_bind(Cnil, frame->frame.top - frame->frame.bottom, fun, frame->frame.bottom); - - VALUES(0) = Cnil; - NVALUES = 0; - name = fun->bytecodes.name; - fun = ecl_interpret(env, fun, fun->bytecodes.code); - bds_unwind(old_bds_top); - return fun; -} - - -cl_object -ecl_apply_bclosure(cl_object frame, cl_object fun) -{ - cl_object name, env; - bds_ptr old_bds_top; - - if (type_of(fun) != t_bclosure) - FEinvalid_function(fun); - - /* Save the lexical environment and set up a new one */ - env = fun->bclosure.lex; - fun = fun->bclosure.code; - old_bds_top = cl_env.bds_top; - - /* Establish bindings */ - env = lambda_bind(env, frame->frame.top - frame->frame.bottom, fun, frame->frame.bottom); - - VALUES(0) = Cnil; - NVALUES = 0; - name = fun->bytecodes.name; - fun = ecl_interpret(env, fun, fun->bytecodes.code); - bds_unwind(old_bds_top); - return fun; -} - - /* -------------------- AIDS TO THE INTERPRETER -------------------- */ static cl_object @@ -551,21 +501,28 @@ close_around(cl_object fun, cl_object lex) { /* -------------------- THE INTERPRETER -------------------- */ cl_object -ecl_interpret(cl_object env, cl_object bytecodes, void *pc) +ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offset) { ECL_OFFSET_TABLE; typedef struct cl_env_struct *cl_env_ptr; const cl_env_ptr the_env = &cl_env; - register cl_opcode *vector = pc; + volatile bds_ptr old_bds_top = cl_env.bds_top; + cl_opcode *vector = (cl_opcode*)bytecodes->bytecodes.code + offset; cl_object *data = bytecodes->bytecodes.data; - register cl_object reg0 = the_env->values[0]; + cl_object reg0; cl_object reg1, lex_env = env; struct ecl_stack_frame frame_aux; cl_index narg; volatile struct ihs_frame ihs; - ihs_push(&ihs, bytecodes, env); + + if (type_of(bytecodes) != t_bytecodes) + FEinvalid_function(bytecodes); + + ihs_push(&ihs, bytecodes, lex_env); frame_aux.t = t_frame; frame_aux.stack = frame_aux.top = frame_aux.bottom = 0; + reg0 = Cnil; + the_env->nvalues = 0; BEGIN: BEGIN_SWITCH { CASE(OP_NOP); { @@ -776,10 +733,10 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) reg0 = SYM_FUN(reg0); goto AGAIN; case t_bytecodes: - reg0 = ecl_apply_lambda(frame, reg0); + reg0 = ecl_interpret(frame, Cnil, reg0, 0); break; case t_bclosure: - reg0 = ecl_apply_bclosure(frame, reg0); + reg0 = ecl_interpret(frame, reg0->bclosure.lex, reg0->bclosure.code, 0); break; default: FEinvalid_function(reg0); @@ -802,12 +759,23 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc) STACK_POP(the_env); THREAD_NEXT; } + /* OP_ENTRY + Binds all the arguments of a function using the given frame. + */ + CASE(OP_ENTRY); { + if (frame == Cnil) + ecl_internal_error("Not enough arguments to bytecodes."); + lex_env = lambda_bind(lex_env, frame->frame.top - frame->frame.bottom, + bytecodes, frame->frame.bottom); + THREAD_NEXT; + } /* OP_EXIT Marks the end of a high level construct (BLOCK, CATCH...) or a function. */ CASE(OP_EXIT); { ihs_pop(); + bds_unwind(old_bds_top); return reg0; } /* OP_FLET nfun{arg}, fun1{object} diff --git a/src/h/bytecodes.h b/src/h/bytecodes.h index ad0b944a4..82b361a76 100644 --- a/src/h/bytecodes.h +++ b/src/h/bytecodes.h @@ -32,6 +32,7 @@ enum { OP_MCALL, OP_POP, OP_POP1, + OP_ENTRY, OP_EXIT, OP_FLET, OP_LABELS, @@ -163,7 +164,7 @@ typedef int16_t cl_oparg; #else #define ECL_OFFSET_TABLE \ static const int offsets[] = {\ - 0,\ + &&LBL_OP_NOP - &&LBL_OP_NOP,\ &&LBL_OP_QUOTE - &&LBL_OP_NOP,\ &&LBL_OP_ENDP - &&LBL_OP_NOP,\ &&LBL_OP_CONS - &&LBL_OP_NOP,\ @@ -185,6 +186,7 @@ typedef int16_t cl_oparg; &&LBL_OP_MCALL - &&LBL_OP_NOP,\ &&LBL_OP_POP - &&LBL_OP_NOP,\ &&LBL_OP_POP1 - &&LBL_OP_NOP,\ + &&LBL_OP_ENTRY - &&LBL_OP_NOP,\ &&LBL_OP_EXIT - &&LBL_OP_NOP,\ &&LBL_OP_FLET - &&LBL_OP_NOP,\ &&LBL_OP_LABELS - &&LBL_OP_NOP,\ @@ -235,6 +237,5 @@ typedef int16_t cl_oparg; &&LBL_OP_PUSHNIL - &&LBL_OP_NOP,\ &&LBL_OP_STEPIN - &&LBL_OP_NOP,\ &&LBL_OP_STEPCALL - &&LBL_OP_NOP,\ - &&LBL_OP_STEPOUT - &&LBL_OP_NOP,\ - } + &&LBL_OP_STEPOUT - &&LBL_OP_NOP } #endif diff --git a/src/h/external.h b/src/h/external.h index 36d3b64a2..c372053f3 100644 --- a/src/h/external.h +++ b/src/h/external.h @@ -457,10 +457,7 @@ extern ECL_API cl_index cl_stack_push_list(cl_object list); extern ECL_API void cl_stack_push_n(cl_index n, cl_object *args); extern ECL_API cl_index cl_stack_push_values(void); extern ECL_API void cl_stack_pop_values(cl_index n); - -extern ECL_API cl_object ecl_apply_lambda(cl_object frame, cl_object fun); -extern ECL_API cl_object ecl_apply_bclosure(cl_object frame, cl_object fun); -extern ECL_API cl_object ecl_interpret(cl_object env, cl_object bytecodes, void *pc); +extern ECL_API cl_object ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offset); /* disassembler.c */ From 38bbf4323715379caa4089a9abff280e69bbca6e Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 15:09:12 +0000 Subject: [PATCH 53/71] Opcodes for small integers --- src/c/compiler.d | 3 +++ src/c/interpreter.d | 14 ++++++++++++++ src/h/bytecodes.h | 4 ++++ 3 files changed, 21 insertions(+) diff --git a/src/c/compiler.d b/src/c/compiler.d index 049aeef29..211fed814 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -1933,8 +1933,11 @@ compile_form(cl_object stmt, int flags) { } else QUOTED: if ((flags & FLAG_USEFUL)) { + cl_fixnum n; if (stmt == Cnil) { asm_op(push? OP_PUSHNIL : OP_NIL); + } else if (FIXNUMP(stmt) && (n = fix(stmt), abs(n)) <= MAX_OPARG) { + asm_op2(push? OP_PINT : OP_INT, n); } else { asm_op2c(push? OP_PUSHQ : OP_QUOTE, stmt); } diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 00be49bc8..18de678b6 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -593,6 +593,20 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs THREAD_NEXT; } + CASE(OP_INT); { + cl_fixnum n; + GET_OPARG(n, vector); + reg0 = MAKE_FIXNUM(n); + THREAD_NEXT; + } + + CASE(OP_PINT); { + cl_fixnum n; + GET_OPARG(n, vector); + STACK_PUSH(the_env, MAKE_FIXNUM(n)); + THREAD_NEXT; + } + /* OP_PUSH Pushes the object in VALUES(0). */ diff --git a/src/h/bytecodes.h b/src/h/bytecodes.h index 82b361a76..6fa7532b1 100644 --- a/src/h/bytecodes.h +++ b/src/h/bytecodes.h @@ -18,6 +18,8 @@ enum { OP_CDR, OP_LIST, OP_LISTA, + OP_INT, + OP_PINT, OP_VAR, OP_VARS, OP_PUSH, @@ -172,6 +174,8 @@ typedef int16_t cl_oparg; &&LBL_OP_CDR - &&LBL_OP_NOP,\ &&LBL_OP_LIST - &&LBL_OP_NOP,\ &&LBL_OP_LISTA - &&LBL_OP_NOP,\ + &&LBL_OP_INT - &&LBL_OP_NOP,\ + &&LBL_OP_PINT - &&LBL_OP_NOP,\ &&LBL_OP_VAR - &&LBL_OP_NOP,\ &&LBL_OP_VARS - &&LBL_OP_NOP,\ &&LBL_OP_PUSH - &&LBL_OP_NOP,\ From d003cc91fca972c293a1e317927c16934c92f723 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 15:09:28 +0000 Subject: [PATCH 54/71] More consistent undoing of variable bindings in compiler. --- src/c/compiler.d | 18 +++++++++--------- src/c/interpreter.d | 3 +-- 2 files changed, 10 insertions(+), 11 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index 211fed814..718f64c18 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -621,13 +621,13 @@ c_undo_bindings(cl_object old_env) cl_index num_lexical = 0; cl_index num_special = 0; - for (env = ENV->variables; env != old_env && !Null(env); env = CDR(env)) + for (env = ENV->variables; env != old_env && !Null(env); env = ECL_CONS_CDR(env)) { - cl_object record = CAR(env); + cl_object record = ECL_CONS_CAR(env); cl_object name = CAR(record); cl_object special = CADR(record); if (name == @':block' || name == @':tag') { - FEerror("Internal error: cannot undo BLOCK/TAGBODY.",0); + (void)0; } else if (name == @':function' || Null(special)) { num_lexical++; } else if (name == @':declare') { @@ -771,7 +771,7 @@ c_block(cl_object body, int old_flags) { } else { asm_op(OP_EXIT_FRAME); asm_complete(Null(name)? OP_DO : 0, labelz); - ENV->variables = old_env.variables; + c_undo_bindings(old_env.variables); return flags; } } @@ -952,7 +952,7 @@ c_catch(cl_object args, int flags) { asm_op(OP_EXIT_FRAME); asm_complete(OP_CATCH, labelz); - ENV->variables = old_env; + c_undo_bindings(old_env); return FLAG_VALUES; } @@ -1383,7 +1383,7 @@ c_locally(cl_object args, int flags) { /* ...and then process body */ flags = compile_body(args, flags); - ENV->variables = old_env; + c_undo_bindings(old_env); return flags; } @@ -1424,7 +1424,7 @@ c_multiple_value_bind(cl_object args, int flags) if (n == 0) { c_declare_specials(specials); flags = compile_body(body, flags); - ENV->variables = old_env; + c_undo_bindings(old_env); } else { cl_object old_variables = ENV->variables; for (vars=cl_reverse(vars); n--; ) { @@ -1777,7 +1777,7 @@ declared special and appear in a symbol-macrolet.", 1, name); } c_declare_specials(specials); flags = compile_body(body, flags); - ENV->variables = old_variables; + c_undo_bindings(old_variables); return flags; } @@ -1822,7 +1822,7 @@ c_tagbody(cl_object args, int flags) } } asm_op(OP_EXIT_TAGBODY); - ENV->variables = old_env; + c_undo_bindings(old_env); return FLAG_REG0; } diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 18de678b6..e68a23296 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -879,8 +879,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs reg0 = close_around(reg0, lex_env); THREAD_NEXT; } - /* OP_GO n{arg} - OP_QUOTE tag-name{symbol} + /* OP_GO n{arg}, tag-name{symbol} Jumps to the tag which is defined at the n-th position in the lexical environment. TAG-NAME is kept for debugging purposes. From cea621fc7a3df0dd7ac20f08079d7c4ea7f54694 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 15:10:10 +0000 Subject: [PATCH 55/71] Tag changes to the interpreter --- src/lsp/config.lsp.in | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/lsp/config.lsp.in b/src/lsp/config.lsp.in index 3482d51af..d23bb1873 100644 --- a/src/lsp/config.lsp.in +++ b/src/lsp/config.lsp.in @@ -46,7 +46,7 @@ Returns, as a string, the location of the machine on which ECL runs." (defun lisp-implementation-version () "Args:() Returns the version of your ECL as a string." - "@PACKAGE_VERSION@ (CVS 2008-06-04 23:07)") + "@PACKAGE_VERSION@ (CVS 2008-06-19 17:09)") (defun machine-type () "Args: () From 7a1fd864e1dab4fcc75560ad3ab0e0cb640bdec6 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 16:26:48 +0000 Subject: [PATCH 56/71] Update IHS environment also when using optimized function calls in interpreter --- src/c/interpreter.d | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/c/interpreter.d b/src/c/interpreter.d index e68a23296..7489c1922 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -650,6 +650,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs cl_objectfn_fixed f; GET_DATA(s, vector, data); f = (cl_objectfn_fixed)SYM_FUN(s)->cfun.entry; + SETUP_ENV(the_env); reg0 = f(reg0); THREAD_NEXT; } @@ -659,6 +660,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs cl_objectfn_fixed f; GET_DATA(s, vector, data); f = (cl_objectfn_fixed)SYM_FUN(s)->cfun.entry; + SETUP_ENV(the_env); reg0 = f(STACK_POP(the_env), reg0); THREAD_NEXT; } From da0452752bbbd320d2bb293ea4c628f2f8d24b00 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 16:41:15 +0000 Subject: [PATCH 57/71] Failure in checking for integer constants. --- src/c/compiler.d | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index 718f64c18..fc70711b7 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -1936,7 +1936,7 @@ compile_form(cl_object stmt, int flags) { cl_fixnum n; if (stmt == Cnil) { asm_op(push? OP_PUSHNIL : OP_NIL); - } else if (FIXNUMP(stmt) && (n = fix(stmt), abs(n)) <= MAX_OPARG) { + } else if (FIXNUMP(stmt) && (n = fix(stmt)) <= MAX_OPARG && n >= -MAX_OPARG) { asm_op2(push? OP_PINT : OP_INT, n); } else { asm_op2c(push? OP_PUSHQ : OP_QUOTE, stmt); From 0953e125825b03ac8bc4deeea1ccbf63c1f1dc2a Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Mon, 23 Jun 2008 20:36:37 +0000 Subject: [PATCH 58/71] Extend c_new_env as a step towards changing the lexical environments. --- src/c/compiler.d | 69 +++++++++++++++++++++++--------------------- src/c/disassembler.d | 5 ++++ src/h/internal.h | 14 +++++---- 3 files changed, 50 insertions(+), 38 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index fc70711b7..24a9ec4e2 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -455,28 +455,37 @@ guess_environment(cl_object interpreter_env) } static void -c_new_env(struct cl_compiler_env *new_c_env, cl_object env) +c_new_env(cl_compiler_env_ptr new, cl_object env, cl_compiler_env_ptr old) { - ENV = new_c_env; - ENV->stepping = 0; - ENV->coalesce = TRUE; - ENV->macros = Cnil; - ENV->lexical_level = 0; - ENV->constants = Cnil; - if (Null(env)) { - ENV->macros = Cnil; - ENV->variables = Cnil; + ENV = new; + new->stepping = 0; + new->coalesce = TRUE; + new->lexical_level = 0; + new->constants = Cnil; + new->env_depth = 0; + new->env_size = 0; + if (old) { + if (!Null(env)) + ecl_internal_error("c_new_env with both ENV and OLD"); + new->variables = old->variables; + new->macros = old->macros; + new->lexical_level = old->lexical_level; + new->constants = old->constants; + new->lex_env = old->lex_env; + new->env_depth = old->env_depth + 1; + new->coalesce = old->coalesce; + new->stepping = old->stepping; } else { - ENV->variables = CAR(env); - ENV->macros = CDR(env); - for (env = ENV->variables; !Null(env); env = CDR(env)) { + new->variables = CAR(env); + new->macros = CDR(env); + for (env = new->variables; !Null(env); env = CDR(env)) { cl_object record = CAR(env); if (ATOM(record)) continue; if (SYMBOLP(CAR(record)) && CADR(record) != @'si::symbol-macro') { continue; } else { - ENV->lexical_level = 1; + new->lexical_level = 1; break; } } @@ -615,13 +624,13 @@ c_bind(cl_object var, cl_object specials) } static void -c_undo_bindings(cl_object old_env) +c_undo_bindings(cl_object old_vars) { cl_object env; cl_index num_lexical = 0; cl_index num_special = 0; - for (env = ENV->variables; env != old_env && !Null(env); env = ECL_CONS_CDR(env)) + for (env = ENV->variables; env != old_vars && !Null(env); env = ECL_CONS_CDR(env)) { cl_object record = ECL_CONS_CAR(env); cl_object name = CAR(record); @@ -640,9 +649,9 @@ c_undo_bindings(cl_object old_env) } } } + ENV->variables = env; if (num_lexical) asm_op2(OP_UNBIND, num_lexical); if (num_special) asm_op2(OP_UNBINDS, num_special); - ENV->variables = old_env; } static void @@ -1128,17 +1137,14 @@ c_register_functions(cl_object l) static int c_labels_flet(int op, cl_object args, int flags) { cl_object l, def_list = pop(&args); - struct cl_compiler_env *old_c_env, new_c_env; + cl_object old_vars = ENV->variables; + cl_object old_funs = ENV->macros; cl_index nfun, first = 0; if (ecl_length(def_list) == 0) { return c_locally(args, flags); } - old_c_env = ENV; - new_c_env = *ENV; - ENV = &new_c_env; - /* Remove declarations */ args = c_process_declarations(args); @@ -1174,9 +1180,8 @@ c_labels_flet(int op, cl_object args, int flags) { flags = compile_body(args, flags); /* Restore and return */ - c_undo_bindings(old_c_env->variables); - old_c_env->constants = ENV->constants; - ENV = old_c_env; + c_undo_bindings(old_vars); + ENV->macros = old_funs; return flags; } @@ -2518,8 +2523,7 @@ ecl_make_lambda(cl_object name, cl_object lambda) { @list*(3, @'ext::lambda-block', name, lambda)); old_c_env = ENV; - new_c_env = *ENV; - ENV = &new_c_env; + c_new_env(&new_c_env, Cnil, old_c_env); ENV->lexical_level++; ENV->coalesce = 0; @@ -2657,10 +2661,10 @@ cl_object si_make_lambda(cl_object name, cl_object rest) { cl_object lambda; - struct cl_compiler_env *old_c_env, new_c_env; + volatile cl_compiler_env_ptr old_c_env = ENV; + struct cl_compiler_env new_c_env; - old_c_env = ENV; - c_new_env(&new_c_env, Cnil); + c_new_env(&new_c_env, Cnil, 0); CL_UNWIND_PROTECT_BEGIN { lambda = ecl_make_lambda(name,rest); } CL_UNWIND_PROTECT_EXIT { @@ -2670,7 +2674,7 @@ si_make_lambda(cl_object name, cl_object rest) } @(defun si::eval-with-env (form &optional (env Cnil) (stepping Cnil) (compiler_env_p Cnil)) - struct cl_compiler_env *old_c_env = ENV; + volatile cl_compiler_env_ptr old_c_env = ENV; struct cl_compiler_env new_c_env; volatile cl_index handle; struct ihs_frame ihs; @@ -2679,7 +2683,6 @@ si_make_lambda(cl_object name, cl_object rest) /* * Compile to bytecodes. */ - ENV = &new_c_env; if (compiler_env_p == Cnil) { interpreter_env = env; compiler_env = Cnil; @@ -2687,7 +2690,7 @@ si_make_lambda(cl_object name, cl_object rest) interpreter_env = Cnil; compiler_env = env; } - c_new_env(&new_c_env, compiler_env); + c_new_env(&new_c_env, compiler_env, 0); guess_environment(interpreter_env); ENV->lex_env = env; ENV->stepping = stepping != Cnil; diff --git a/src/c/disassembler.d b/src/c/disassembler.d index 5f41adb53..f53e2a2ca 100644 --- a/src/c/disassembler.d +++ b/src/c/disassembler.d @@ -370,6 +370,11 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { */ case OP_CATCH: string = "CATCH\t"; goto JMP; + /* OP_ENTRY + Marks the entry of a lambda form + */ + case OP_ENTRY: string = "ENTRY"; + goto NOARG; /* OP_EXIT Marks the end of a high level construct */ diff --git a/src/h/internal.h b/src/h/internal.h index c513fb7b2..d81cd09ae 100644 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -55,15 +55,19 @@ extern cl_object ecl_alloc_bytecodes(cl_index data_size, cl_index code_size); /* compiler.d */ struct cl_compiler_env { - cl_object variables; - cl_object macros; - cl_fixnum lexical_level; - cl_object constants; - cl_object lex_env; + cl_object variables; /* Variables, tags, functions, etc: the env. */ + cl_object macros; /* Macros and function bindings */ + cl_fixnum lexical_level; /* =0 if toplevel form */ + cl_object constants; /* Constants for this form */ + cl_object lex_env; /* Lexical env. for eval-when */ + cl_index env_depth; + cl_index env_size; bool coalesce; bool stepping; }; +typedef struct cl_compiler_env *cl_compiler_env_ptr; + /* interpreter.d */ #define cl_stack_ref(n) cl_env.stack[n] From 3df72c1d304e70f560fe8d0a39a3446181198272 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Mon, 23 Jun 2008 20:36:50 +0000 Subject: [PATCH 59/71] Introduce location objects --- src/c/compiler.d | 45 +++++++++++++++++++++++++++++++++++---------- 1 file changed, 35 insertions(+), 10 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index 24a9ec4e2..c1e6d3fc2 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -351,14 +351,14 @@ asm_op2c(register int code, register cl_object o) { * The compiler environment consists of two lists, one stored in * env->variables, the other one stored in env->macros. * - * variable-record = (:block block-name) | - * (:tag ({tag-name}*)) | - * (:function function-name) | - * (var-name {:special | nil} bound-p) | + * variable-record = (:block block-name [used-p | block-object] location) | + * (:tag ({tag-name}*) [NIL | tag-object] location) | + * (:function function-name used-p [location]) | + * (var-name {:special | nil} bound-p [location]) | * (symbol si::symbol-macro macro-function) | * CB | LB | UNWIND-PROTECT | * (:declare declaration-arguments*) - * macro-record = (function-name function) | + * macro-record = (function-name FUNCTION [| function-object]) | * (macro-name si::macro macro-function) * CB | LB | UNWIND-PROTECT * @@ -370,28 +370,52 @@ asm_op2c(register int code, register cl_object o) { * CB, LB and UNWIND-PROTECT are only used by the C compiler and they * denote closure, lexical environment and unwind-protect boundaries. * + * The brackets [] denote differences between the bytecodes and C + * compiler environments, with the first option belonging to the + * interpreter and the second alternative to the compiler. + * + * A LOCATION object is proper to the bytecodes compiler and denotes + * the position of this variable, block, tag or function, in the + * lexical environment. Currently, it is a CONS with two integers + * (DEPTH . ORDER), denoting the depth of the nested environments and + * the position in the environment (from the beginning, not from the + * tail). + * + * The BLOCK-, TAG- and FUNCTION- objects are proper of the compiler + * and carry further information. + * * The last variable records are devoted to declarations and are only * used by the C compiler. Read cmpenv.lsp for more details on the * structure of these declaration forms, as they do not completely * match those of Common-Lisp. */ +static cl_object +new_location(cl_object name) +{ + cl_object loc = CONS(MAKE_FIXNUM(ENV->env_depth), MAKE_FIXNUM((ENV->env_size++))); + return loc; +} + static void c_register_block(cl_object name) { - ENV->variables = CONS(cl_list(3, @':block', name, Cnil), ENV->variables); + ENV->variables = CONS(cl_list(4, @':block', name, Cnil, new_location(name)), + ENV->variables); } static void c_register_tags(cl_object all_tags) { - ENV->variables = CONS(cl_list(2, @':tag', all_tags), ENV->variables); + ENV->variables = CONS(cl_list(4, @':tag', all_tags, Cnil, new_location(@':tag')), + ENV->variables); } static void c_register_function(cl_object name) { - ENV->variables = CONS(cl_list(3, @':function', name, Cnil), ENV->variables); + ENV->variables = CONS(cl_list(4, @':function', name, Cnil, new_location(name)), + ENV->variables); ENV->macros = CONS(cl_list(2, name, @'function'), ENV->macros); } @@ -420,9 +444,10 @@ c_register_var(register cl_object var, bool special, bool bound) /* If this is just a declaration, ensure that the variable was not * declared before as special, to save memory. */ if (bound || (c_var_ref(var, 0, FALSE) >= ECL_UNDEFINED_VAR_REF)) { - ENV->variables = CONS(cl_list(3, var, + ENV->variables = CONS(cl_list(4, var, special? @'special' : Cnil, - bound? Ct : Cnil), + bound? Ct : Cnil, + new_location(var)), ENV->variables); } } From 1a7041c0f585b45a15021ad921ef961af5e7ab8e Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Mon, 23 Jun 2008 20:37:04 +0000 Subject: [PATCH 60/71] More rigorous parsing of character names. --- src/c/character.d | 36 +++++++++++++++++++++++++++--------- 1 file changed, 27 insertions(+), 9 deletions(-) diff --git a/src/c/character.d b/src/c/character.d index 6b604d0c1..5e01a1eab 100644 --- a/src/c/character.d +++ b/src/c/character.d @@ -551,16 +551,34 @@ cl_char_name(cl_object c) cl_object cl_name_char(cl_object name) { - cl_object c = ecl_gethash_safe((name = cl_string(name)), cl_core.char_names, Cnil); - if (c == Cnil && type_of(name) == t_base_string && - ecl_length(name)) { + cl_object c; + cl_index l; + name = cl_string(name); + c = ecl_gethash_safe(name, cl_core.char_names, Cnil); + if (c == Cnil && ecl_stringp(name) && (l = ecl_length(name))) { c = cl_char(name, MAKE_FIXNUM(0)); - if (c == CODE_CHAR('u') || c == CODE_CHAR('U')) { - /* FIXME! This only works with base-strings */ - cl_index end = name->base_string.fillp; - cl_index real_end = end; - c = ecl_parse_integer(name, 1, end, &real_end, 16); - if ((real_end != end) || !FIXNUMP(c)) { + if (l == 1) { + (void)0; + } else if (c != CODE_CHAR('u') && c != CODE_CHAR('U')) { + c = Cnil; + } else { + cl_index used_l; + if (type_of(name) == t_base_string) { + cl_index end = name->base_string.fillp; + cl_index real_end = end; + c = ecl_parse_integer(name, 1, end, &real_end, 16); + used_l = real_end; + } else { + /* Unsafe code: what about read errors? + bds_bind(@'*read-base*', MAKE_FIXNUM(16)); + c = cl_funcall(6, @'read-from-string', name, + Cnil, Cnil, @':start', MAKE_FIXNUM(1)); + bds_unwind1(); + used_l = fix(VALUES(0)); + */ + c = Cnil; + } + if (!FIXNUMP(c) || (used_l == (l - 1))) { c = Cnil; } else { c = CODE_CHAR(fix(c)); From 719b6ecd9da50ea2fb14a76ac955281ece09e56f Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Mon, 23 Jun 2008 20:37:16 +0000 Subject: [PATCH 61/71] ECL_LONG_DOUBLE was not defined --- src/h/config.h.in | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/h/config.h.in b/src/h/config.h.in index 5f039fe74..8af2081b4 100644 --- a/src/h/config.h.in +++ b/src/h/config.h.in @@ -149,6 +149,9 @@ typedef unsigned @CL_FIXNUM_TYPE@ cl_hashkey; /* compiler understands long double */ #undef HAVE_LONG_DOUBLE +#ifdef HAVE_LONG_DOUBLE +# define ECL_LONG_FLOAT +#endif /* compiler understands complex */ #undef HAVE_DOUBLE_COMPLEX #undef HAVE_FLOAT_COMPLEX From fec1c3a8f2325eb994a02860f0bad6f7181d5828 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Mon, 23 Jun 2008 20:37:29 +0000 Subject: [PATCH 62/71] Fixed two typos --- src/configure | 2 +- src/configure.in | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/configure b/src/configure index 5524483a6..51c53dfa0 100755 --- a/src/configure +++ b/src/configure @@ -1334,7 +1334,7 @@ Optional Features: on Intel) --enable-unicode enable support for unicode (default=NO) --enable-longdouble include support for long double (default=NO) - --enable-c99-complex include support for C complex type (default=NO) + --enable-c99complex include support for C complex type (default=NO) --enable-hierarchical-packages hierarchical package names (default=YES) --enable-asmapply enable optimizations written in assembler diff --git a/src/configure.in b/src/configure.in index 3082b4c75..2f4c5fd73 100644 --- a/src/configure.in +++ b/src/configure.in @@ -177,7 +177,7 @@ AC_ARG_ENABLE(longdouble, [enable_longdouble=${enableval}], [enable_longdouble=no]) AC_ARG_ENABLE(c99complex, - AS_HELP_STRING( [--enable-c99-complex], + AS_HELP_STRING( [--enable-c99complex], [include support for C complex type] [(default=NO)]), [enable_c99complex=${enableval}], [enable_c99complex=no]) From fb59889206047654ea8804ae59e4c55dc73cfecc Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Mon, 23 Jun 2008 20:37:42 +0000 Subject: [PATCH 63/71] si::bc-disassemble did not know about OP_[P]INT --- src/c/disassembler.d | 68 +++++++++++++++++--------------------------- 1 file changed, 26 insertions(+), 42 deletions(-) diff --git a/src/c/disassembler.d b/src/c/disassembler.d index f53e2a2ca..de44f2626 100644 --- a/src/c/disassembler.d +++ b/src/c/disassembler.d @@ -205,7 +205,7 @@ static cl_opcode * disassemble(cl_object bytecodes, cl_opcode *vector) { const char *string; cl_object o; - cl_fixnum n, m; + cl_fixnum n, m, env_index; cl_object line_format; cl_object *data = bytecodes->bytecodes.data; cl_object line_no; @@ -234,6 +234,14 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { */ case OP_NOP: string = "NOP"; goto NOARG; + case OP_INT: string = "QUOTE\t"; + GET_OPARG(n, vector); + goto OPARG; + + case OP_PINT: string = "PUSH\t"; + GET_OPARG(n, vector); + goto OPARG; + /* OP_QUOTE Sets VALUES(0) to an immediate value. */ @@ -314,16 +322,24 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { case OP_POPVALUES: string = "POP\tVALUES"; goto NOARG; - /* OP_BLOCK label{arg}, block-name{symbol} - ... - OP_EXIT - label: - - Executes the enclosed code in a named block. LABEL points - to the first instruction after OP_EXIT. - */ case OP_BLOCK: string = "BLOCK\t"; - goto JEQL; + GET_DATA(o, vector, data); + goto DO_BLOCK; + case OP_CATCH: ecl_princ_str("CATCH\tREG0,", Cnil); + goto DO_CATCH; + case OP_DO: string = "DO\t"; + o = Cnil; + DO_BLOCK: ecl_princ_str(string, Cnil); + ecl_princ(o, Cnil); + ecl_princ_str(",", Cnil); + DO_CATCH: { GET_OPARG(env_index, vector); + GET_OPARG(m, vector); + n = vector + m - OPARG_SIZE - base; + ecl_princ(MAKE_FIXNUM(n), Cnil); + ecl_princ_str(",", Cnil); + ecl_princ(MAKE_FIXNUM(m), Cnil); + break; + } /* OP_CALL n{arg} Calls the function in VALUES(0) with N arguments which @@ -360,16 +376,6 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { case OP_MCALL: string = "MCALL"; goto NOARG; - /* OP_CATCH label{arg} - ... - OP_EXIT_FRAME - label: - - Sets a catch point using the tag in VALUES(0). LABEL points to the - first instruction after the end (OP_EXIT) of the block - */ - case OP_CATCH: string = "CATCH\t"; - goto JMP; /* OP_ENTRY Marks the entry of a lambda form */ @@ -564,30 +570,8 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { */ case OP_NTHVAL: string = "NTHVAL\t"; goto NOARG; - /* OP_DO label - ... ; code executed within a NIL block - OP_EXIT_FRAME - label: - - High level construct for the DO and BLOCK forms. - */ - case OP_DO: string = "DO\t"; - goto JMP; case OP_TAGBODY: vector = disassemble_tagbody(bytecodes, vector); break; - /* OP_PROTECT label - ... ; code to be protected and whose value is output - OP_PROTECT_NORMAL - label: - ... ; code executed at exit - OP_PROTECT_EXIT - - High level construct for UNWIND-PROTECT. The first piece of code is - executed and its output value is saved. Then the second piece of code - is executed and the output values restored. The second piece of code - is always executed, even if a THROW, RETURN or GO happen within the - first piece of code. - */ case OP_PROTECT: string = "PROTECT\t"; goto JMP; case OP_PROTECT_NORMAL: string = "PROTECT\tNORMAL"; From a427f1e0e5ec5b2441b665023c55198f304db0d5 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Mon, 23 Jun 2008 20:37:54 +0000 Subject: [PATCH 64/71] Remove useless bds_unwind statement from OP_EXIT_FRAME --- src/c/interpreter.d | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 7489c1922..6e3542cc5 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -1103,7 +1103,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs } - /* OP_BLOCK label{arg} + /* OP_BLOCK name{symbol}, env_index{arg}, label{arg} ... OP_EXIT_FRAME label: @@ -1116,7 +1116,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs reg1 = new_frame_id(); goto DO_BLOCK; } - /* OP_CATCH label{arg} + /* OP_CATCH env_index{arg}, label{arg} ... OP_EXIT_FRAME label: @@ -1128,7 +1128,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs reg1 = reg0; goto DO_BLOCK; } - /* OP_DO label + /* OP_DO env_index{arg}, label{arg} ... ; code executed within a NIL block OP_EXIT_FRAME label: @@ -1140,7 +1140,9 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs reg1 = new_frame_id(); } DO_BLOCK: { + cl_index lex_env_index; cl_opcode *exit; + GET_OPARG(lex_env_index, vector); GET_LABEL(exit, vector); STACK_PUSH(the_env, lex_env); STACK_PUSH(the_env, (cl_object)exit); @@ -1155,7 +1157,6 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs THREAD_NEXT; } CASE(OP_EXIT_FRAME); { - bds_unwind(the_env->frs_top->frs_bds_top); frs_pop(the_env); STACK_POP(the_env); lex_env = STACK_POP(the_env); From 5d98623c8a61a9eab1b8c92471c6e4697816583d Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Mon, 23 Jun 2008 20:38:05 +0000 Subject: [PATCH 65/71] Restructure code so that OP_DO admits a location --- src/c/compiler.d | 48 ++++++++++++++++++++++++++++----------------- src/c/interpreter.d | 2 -- 2 files changed, 30 insertions(+), 20 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index c1e6d3fc2..70cfe23fc 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -50,6 +50,8 @@ #define FLAG_IGNORE 0 #define FLAG_USEFUL (FLAG_PUSH | FLAG_VALUES | FLAG_REG0) +#define ENV_RECORD_LOCATION(r) CADDDR(r) + #define ECL_SPECIAL_VAR_REF -2 #define ECL_UNDEFINED_VAR_REF -1 @@ -397,18 +399,22 @@ new_location(cl_object name) return loc; } -static void +static cl_index c_register_block(cl_object name) { - ENV->variables = CONS(cl_list(4, @':block', name, Cnil, new_location(name)), + cl_object loc = new_location(name); + ENV->variables = CONS(cl_list(4, @':block', name, Cnil, loc), ENV->variables); + return fix(ECL_CONS_CDR(loc)); } -static void +static cl_index c_register_tags(cl_object all_tags) { - ENV->variables = CONS(cl_list(4, @':tag', all_tags, Cnil, new_location(@':tag')), + cl_object loc = new_location(@':tag'); + ENV->variables = CONS(cl_list(4, @':tag', all_tags, Cnil, loc), ENV->variables); + return fix(ECL_CONS_CDR(loc)); } static void @@ -529,9 +535,10 @@ c_tag_ref(cl_object the_tag, cl_object the_type) type = CAR(record); name = CADR(record); if (type == @':tag') { - if (type == the_type && !Null(ecl_assql(the_tag, name))) + if (type == the_type && !Null(ecl_assql(the_tag, name))) { return CONS(MAKE_FIXNUM(n), CDR(ecl_assql(the_tag, name))); + } n++; } else if (type == @':block' || type == @':function') { /* We compare with EQUAL, because of (SETF fname) */ @@ -576,8 +583,10 @@ c_var_ref(cl_object var, int allow_symbol_macro, bool ensure_defined) return -1; FEprogram_error("Internal error: symbol macro ~S used as variable", 1, var); + } else if (Null(special)) { + return n; } else { - return Null(special)? n : ECL_SPECIAL_VAR_REF; + return ECL_SPECIAL_VAR_REF; } } if (ensure_defined) { @@ -776,7 +785,7 @@ c_block(cl_object body, int old_flags) { struct cl_compiler_env old_env; cl_object name = pop(&body); cl_object block_record; - cl_index labelz, pc; + cl_index labelz, pc, loc; int flags; if (!SYMBOLP(name)) @@ -786,16 +795,16 @@ c_block(cl_object body, int old_flags) { pc = current_pc(); flags = maybe_values_or_reg0(old_flags); - c_register_block(name); + loc = c_register_block(name); block_record = CAR(ENV->variables); if (Null(name)) { - labelz = asm_jmp(OP_DO); + asm_op(OP_DO); } else { asm_op(OP_BLOCK); asm_c(name); - labelz = current_pc(); - asm_arg(0); } + labelz = current_pc(); + asm_arg(0); compile_body(body, flags); if (CADDR(block_record) == Cnil) { /* Block unused. We remove the enclosing OP_BLOCK/OP_DO */ @@ -803,9 +812,9 @@ c_block(cl_object body, int old_flags) { set_pc(pc); return compile_body(body, old_flags); } else { - asm_op(OP_EXIT_FRAME); - asm_complete(Null(name)? OP_DO : 0, labelz); c_undo_bindings(old_env.variables); + asm_op(OP_EXIT_FRAME); + asm_complete(0, labelz); return flags; } } @@ -969,24 +978,27 @@ c_case(cl_object clause, int flags) { static int c_catch(cl_object args, int flags) { - cl_index labelz; + cl_index labelz, loc; cl_object old_env; /* Compile evaluation of tag */ compile_form(pop(&args), FLAG_REG0); old_env = ENV->variables; - c_register_block(MAKE_FIXNUM(0)); + loc = c_register_block(MAKE_FIXNUM(0)); /* Compile jump point */ - labelz = asm_jmp(OP_CATCH); + asm_op(OP_CATCH); + labelz = current_pc(); + asm_arg(0); /* Compile body of CATCH */ compile_body(args, FLAG_VALUES); - asm_op(OP_EXIT_FRAME); - asm_complete(OP_CATCH, labelz); c_undo_bindings(old_env); + asm_op(OP_EXIT_FRAME); + asm_complete(0, labelz); + return FLAG_VALUES; } diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 6e3542cc5..2b6a9a425 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -1140,9 +1140,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs reg1 = new_frame_id(); } DO_BLOCK: { - cl_index lex_env_index; cl_opcode *exit; - GET_OPARG(lex_env_index, vector); GET_LABEL(exit, vector); STACK_PUSH(the_env, lex_env); STACK_PUSH(the_env, (cl_object)exit); From 7a43b9738f665e813e29dd0dc5d5b7c3ac57a899 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Mon, 23 Jun 2008 20:38:17 +0000 Subject: [PATCH 66/71] BLOCK and TAGBODY share exit code --- src/c/interpreter.d | 30 +++++++++++++++++------------- 1 file changed, 17 insertions(+), 13 deletions(-) diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 2b6a9a425..2517ad014 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -274,7 +274,6 @@ ecl_stack_frame_copy(cl_object dest, cl_object orig) #define bind_var(env, var, val) CONS(CONS(var, val), (env)) #define bind_function(env, name, fun) CONS(CONS(fun, name), (env)) -#define bind_tagbody(env, id) CONS(CONS(id, MAKE_FIXNUM(0)), (env)) static cl_object ecl_lex_env_get_record(register cl_object env, register int s) @@ -1142,24 +1141,17 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs DO_BLOCK: { cl_opcode *exit; GET_LABEL(exit, vector); + lex_env = CONS(CONS(reg1, reg0), lex_env); STACK_PUSH(the_env, lex_env); STACK_PUSH(the_env, (cl_object)exit); - if (frs_push(reg1) == 0) { - lex_env = CONS(CONS(reg1, reg0), lex_env); - } else { + if (frs_push(reg1) != 0) { reg0 = the_env->values[0]; frs_pop(the_env); vector = (cl_opcode *)STACK_POP(the_env); /* FIXME! */ - lex_env = STACK_POP(the_env); + lex_env = ECL_CONS_CDR(STACK_POP(the_env)); } THREAD_NEXT; } - CASE(OP_EXIT_FRAME); { - frs_pop(the_env); - STACK_POP(the_env); - lex_env = STACK_POP(the_env); - THREAD_NEXT; - } /* OP_TAGBODY n{arg} label1 ... @@ -1177,7 +1169,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs int n; GET_OPARG(n, vector); /* Here we save the location of the jump table and the env. */ - lex_env = bind_tagbody(lex_env, id); + lex_env = CONS(CONS(id, MAKE_FIXNUM(0)), lex_env); STACK_PUSH(the_env, lex_env); STACK_PUSH(the_env, (cl_object)vector); /* FIXME! */ if (frs_push(id) == 0) { @@ -1198,9 +1190,21 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs THREAD_NEXT; } CASE(OP_EXIT_TAGBODY); { + reg0 = Cnil; + } + CASE(OP_EXIT_FRAME); { frs_pop(the_env); +#if 0 STACK_POP(the_env); - lex_env = ECL_CONS_CDR(STACK_POP(the_env)); + if (lex_env != STACK_REF(the_env,-1)) + ecl_internal_error("ENV botch!"); + lex_env = STACK_POP(the_env); + lex_env = ECL_CONS_CDR(lex_env); +#else + STACK_POP_N(the_env, 2); + lex_env = ECL_CONS_CDR(lex_env); +#endif + THREAD_NEXT; } CASE(OP_NIL); { reg0 = Cnil; From df9aacf3db1a50d6f7784e190287d49430c9c99d Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Mon, 23 Jun 2008 20:38:32 +0000 Subject: [PATCH 67/71] Split an opcode for actual frame creation from those for frame identification. --- src/c/compiler.d | 13 +++--- src/c/disassembler.d | 22 ++++------ src/c/interpreter.d | 95 ++++++++++++++++---------------------------- src/h/bytecodes.h | 2 + 4 files changed, 50 insertions(+), 82 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index 70cfe23fc..49707ff81 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -800,11 +800,9 @@ c_block(cl_object body, int old_flags) { if (Null(name)) { asm_op(OP_DO); } else { - asm_op(OP_BLOCK); - asm_c(name); + asm_op2c(OP_BLOCK, name); } - labelz = current_pc(); - asm_arg(0); + labelz = asm_jmp(OP_FRAME); compile_body(body, flags); if (CADDR(block_record) == Cnil) { /* Block unused. We remove the enclosing OP_BLOCK/OP_DO */ @@ -984,13 +982,13 @@ c_catch(cl_object args, int flags) { /* Compile evaluation of tag */ compile_form(pop(&args), FLAG_REG0); + /* Compile binding of tag */ old_env = ENV->variables; loc = c_register_block(MAKE_FIXNUM(0)); + asm_op(OP_CATCH); /* Compile jump point */ - asm_op(OP_CATCH); - labelz = current_pc(); - asm_arg(0); + labelz = asm_jmp(OP_FRAME); /* Compile body of CATCH */ compile_body(args, FLAG_VALUES); @@ -1846,6 +1844,7 @@ c_tagbody(cl_object args, int flags) compile_body(args, 0); return compile_form(Cnil, flags); } + asm_op2c(OP_BLOCK, MAKE_FIXNUM(0)); c_register_tags(labels); asm_op2(OP_TAGBODY, nt); tag_base = current_pc(); diff --git a/src/c/disassembler.d b/src/c/disassembler.d index de44f2626..47c44e4e0 100644 --- a/src/c/disassembler.d +++ b/src/c/disassembler.d @@ -324,22 +324,14 @@ disassemble(cl_object bytecodes, cl_opcode *vector) { case OP_BLOCK: string = "BLOCK\t"; GET_DATA(o, vector, data); - goto DO_BLOCK; - case OP_CATCH: ecl_princ_str("CATCH\tREG0,", Cnil); - goto DO_CATCH; - case OP_DO: string = "DO\t"; + goto ARG; + case OP_CATCH: string = "CATCH\tREG0"; + goto NOARG; + case OP_DO: string = "BLOCK\t"; o = Cnil; - DO_BLOCK: ecl_princ_str(string, Cnil); - ecl_princ(o, Cnil); - ecl_princ_str(",", Cnil); - DO_CATCH: { GET_OPARG(env_index, vector); - GET_OPARG(m, vector); - n = vector + m - OPARG_SIZE - base; - ecl_princ(MAKE_FIXNUM(n), Cnil); - ecl_princ_str(",", Cnil); - ecl_princ(MAKE_FIXNUM(m), Cnil); - break; - } + goto ARG; + case OP_FRAME: string = "FRAME\t"; + goto JMP; /* OP_CALL n{arg} Calls the function in VALUES(0) with N arguments which diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 2517ad014..3efbc4de7 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -447,9 +447,7 @@ close_around(cl_object fun, cl_object lex) { } #undef frs_pop -#define frs_pop(the_env) { \ - the_env->stack_top = the_env->stack + the_env->frs_top->frs_sp; \ - the_env->frs_top--; } +#define frs_pop(the_env) { the_env->frs_top--; } /* * Manipulation of the interpreter stack. As shown here, we omit may @@ -508,10 +506,9 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs volatile bds_ptr old_bds_top = cl_env.bds_top; cl_opcode *vector = (cl_opcode*)bytecodes->bytecodes.code + offset; cl_object *data = bytecodes->bytecodes.data; - cl_object reg0; - cl_object reg1, lex_env = env; - struct ecl_stack_frame frame_aux; + cl_object reg0, reg1, lex_env = env; cl_index narg; + struct ecl_stack_frame frame_aux; volatile struct ihs_frame ihs; if (type_of(bytecodes) != t_bytecodes) @@ -1101,58 +1098,49 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs THREAD_NEXT; } + /* OP_BLOCK constant + OP_DO + OP_CATCH - /* OP_BLOCK name{symbol}, env_index{arg}, label{arg} - ... + OP_FRAME label{arg} + ... OP_EXIT_FRAME label: + */ - Executes the enclosed code in a named block. - LABEL points to the first instruction after OP_EXIT. - */ CASE(OP_BLOCK); { GET_DATA(reg0, vector, data); reg1 = new_frame_id(); - goto DO_BLOCK; + lex_env = CONS(CONS(reg1, reg0), lex_env); + THREAD_NEXT; } - /* OP_CATCH env_index{arg}, label{arg} - ... - OP_EXIT_FRAME - label: - - Sets a catch point using the tag in VALUES(0). LABEL points to the - first instruction after the end (OP_EXIT) of the block - */ - CASE(OP_CATCH); { - reg1 = reg0; - goto DO_BLOCK; - } - /* OP_DO env_index{arg}, label{arg} - ... ; code executed within a NIL block - OP_EXIT_FRAME - label: - - High level construct for the DO and BLOCK forms. - */ CASE(OP_DO); { reg0 = Cnil; reg1 = new_frame_id(); - } - DO_BLOCK: { - cl_opcode *exit; - GET_LABEL(exit, vector); lex_env = CONS(CONS(reg1, reg0), lex_env); - STACK_PUSH(the_env, lex_env); - STACK_PUSH(the_env, (cl_object)exit); - if (frs_push(reg1) != 0) { - reg0 = the_env->values[0]; - frs_pop(the_env); - vector = (cl_opcode *)STACK_POP(the_env); /* FIXME! */ - lex_env = ECL_CONS_CDR(STACK_POP(the_env)); - } THREAD_NEXT; } - /* OP_TAGBODY n{arg} + CASE(OP_CATCH); { + reg1 = reg0; + lex_env = CONS(CONS(reg1, reg0), lex_env); + THREAD_NEXT; + } + CASE(OP_FRAME); { + cl_opcode *exit; + GET_LABEL(exit, vector); + STACK_PUSH(the_env, lex_env); + STACK_PUSH(the_env, (cl_object)exit); + if (frs_push(reg1) == 0) { + THREAD_NEXT; + } else { + reg0 = the_env->values[0]; + vector = (cl_opcode *)STACK_REF(the_env,-1); /* FIXME! */ + lex_env = STACK_REF(the_env,-2); + goto DO_EXIT_FRAME; + } + } + /* OP_FRAMEID 0 + OP_TAGBODY n{arg} label1 ... labeln @@ -1165,18 +1153,12 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs High level construct for the TAGBODY form. */ CASE(OP_TAGBODY); { - cl_object id = new_frame_id(); int n; GET_OPARG(n, vector); - /* Here we save the location of the jump table and the env. */ - lex_env = CONS(CONS(id, MAKE_FIXNUM(0)), lex_env); STACK_PUSH(the_env, lex_env); STACK_PUSH(the_env, (cl_object)vector); /* FIXME! */ - if (frs_push(id) == 0) { - /* The first time, we "name" the tagbody and - * skip the jump table */ - vector += n * OPARG_SIZE; - } else { + vector += n * OPARG_SIZE; + if (frs_push(reg1) != 0) { /* Wait here for gotos. Each goto sets VALUES(0) to an integer which ranges from 0 to ntags-1, depending on the tag. These @@ -1193,17 +1175,10 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs reg0 = Cnil; } CASE(OP_EXIT_FRAME); { + DO_EXIT_FRAME: frs_pop(the_env); -#if 0 - STACK_POP(the_env); - if (lex_env != STACK_REF(the_env,-1)) - ecl_internal_error("ENV botch!"); - lex_env = STACK_POP(the_env); - lex_env = ECL_CONS_CDR(lex_env); -#else STACK_POP_N(the_env, 2); lex_env = ECL_CONS_CDR(lex_env); -#endif THREAD_NEXT; } CASE(OP_NIL); { diff --git a/src/h/bytecodes.h b/src/h/bytecodes.h index 6fa7532b1..26228ce25 100644 --- a/src/h/bytecodes.h +++ b/src/h/bytecodes.h @@ -66,6 +66,7 @@ enum { OP_BLOCK, OP_DO, OP_CATCH, + OP_FRAME, OP_TAGBODY, OP_EXIT_TAGBODY, OP_EXIT_FRAME, @@ -222,6 +223,7 @@ typedef int16_t cl_oparg; &&LBL_OP_BLOCK - &&LBL_OP_NOP,\ &&LBL_OP_DO - &&LBL_OP_NOP,\ &&LBL_OP_CATCH - &&LBL_OP_NOP,\ + &&LBL_OP_FRAME - &&LBL_OP_NOP,\ &&LBL_OP_TAGBODY - &&LBL_OP_NOP,\ &&LBL_OP_EXIT_TAGBODY - &&LBL_OP_NOP,\ &&LBL_OP_EXIT_FRAME - &&LBL_OP_NOP,\ From 9ef1a4b02622b3a49b0a035c5b38c2b442935328 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Mon, 23 Jun 2008 20:38:44 +0000 Subject: [PATCH 68/71] Introduce bind_frame() abstraction --- src/c/interpreter.d | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 3efbc4de7..3d4fa6d82 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -274,6 +274,7 @@ ecl_stack_frame_copy(cl_object dest, cl_object orig) #define bind_var(env, var, val) CONS(CONS(var, val), (env)) #define bind_function(env, name, fun) CONS(CONS(fun, name), (env)) +#define bind_frame(env, id, name) CONS(CONS(id, name), (env)) static cl_object ecl_lex_env_get_record(register cl_object env, register int s) @@ -1111,18 +1112,18 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs CASE(OP_BLOCK); { GET_DATA(reg0, vector, data); reg1 = new_frame_id(); - lex_env = CONS(CONS(reg1, reg0), lex_env); + lex_env = bind_frame(lex_env, reg1, reg0); THREAD_NEXT; } CASE(OP_DO); { reg0 = Cnil; reg1 = new_frame_id(); - lex_env = CONS(CONS(reg1, reg0), lex_env); + lex_env = bind_frame(lex_env, reg1, reg0); THREAD_NEXT; } CASE(OP_CATCH); { reg1 = reg0; - lex_env = CONS(CONS(reg1, reg0), lex_env); + lex_env = bind_frame(lex_env, reg1, reg0); THREAD_NEXT; } CASE(OP_FRAME); { From a49e3f7475f722860f426b993a64a260e262c1e4 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Mon, 23 Jun 2008 20:38:56 +0000 Subject: [PATCH 69/71] Simplify the lexical environment record for local functions --- src/c/interpreter.d | 9 ++++----- src/lsp/top.lsp | 25 ++++++++++++++----------- 2 files changed, 18 insertions(+), 16 deletions(-) diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 3d4fa6d82..0b7c0d008 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -273,7 +273,7 @@ ecl_stack_frame_copy(cl_object dest, cl_object orig) /* ------------------------------ LEXICAL ENV. ------------------------------ */ #define bind_var(env, var, val) CONS(CONS(var, val), (env)) -#define bind_function(env, name, fun) CONS(CONS(fun, name), (env)) +#define bind_function(env, name, fun) CONS(fun, (env)) #define bind_frame(env, id, name) CONS(CONS(id, name), (env)) static cl_object @@ -287,7 +287,7 @@ ecl_lex_env_get_record(register cl_object env, register int s) #define ecl_lex_env_get_var(env,x) ECL_CONS_CDR(ecl_lex_env_get_record(env,x)) #define ecl_lex_env_set_var(env,x,v) ECL_RPLACD(ecl_lex_env_get_record(env,x),(v)) -#define ecl_lex_env_get_fun(env,x) ECL_CONS_CAR(ecl_lex_env_get_record(env,x)) +#define ecl_lex_env_get_fun(env,x) ecl_lex_env_get_record(env,x) #define ecl_lex_env_get_tag(env,x) ECL_CONS_CAR(ecl_lex_env_get_record(env,x)) /* -------------------- LAMBDA FUNCTIONS -------------------- */ @@ -838,8 +838,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs /* Update the closures so that all functions can call each other */ ; for (l = new_lex, i = nfun; i; i--) { - cl_object record = ECL_CONS_CAR(l); - ECL_RPLACA(record, close_around(ECL_CONS_CAR(record), new_lex)); + ECL_RPLACA(l, close_around(ECL_CONS_CAR(l), new_lex)); l = ECL_CONS_CDR(l); } lex_env = new_lex; @@ -853,7 +852,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs int lex_env_index; cl_object fun_record; GET_OPARG(lex_env_index, vector); - reg0 = ECL_CONS_CAR(ecl_lex_env_get_record(lex_env, lex_env_index)); + reg0 = ecl_lex_env_get_fun(lex_env, lex_env_index); THREAD_NEXT; } diff --git a/src/lsp/top.lsp b/src/lsp/top.lsp index 8e794a3fa..dc88469d1 100644 --- a/src/lsp/top.lsp +++ b/src/lsp/top.lsp @@ -636,18 +636,21 @@ under certain conditions; see file 'Copyright' for details.") (*print-length* 4) (*print-pretty* t) (*print-readably* nil) - (functions) (blocks) (variables)) + (functions '()) + (blocks '()) + (variables '()) + record0 record1) (dolist (record *break-env*) - (let* ((record0 (car record)) - (record1 (cdr record))) - (cond ((symbolp record0) - (setq variables (list* record0 record1 variables))) - ((not (fixnump record0)) - (push record1 functions)) - ((symbolp record1) - (push record1 blocks)) - (t - )))) + (cond ((atom record) + (push (compiled-function-name record) functions)) + ((progn + (setf record0 (car record) record1 (cdr record)) + (symbolp record0)) + (setq variables (list* record0 record1 variables))) + ((symbolp record1) + (push record1 blocks)) + (t + ))) (format t "~:[~;Local functions: ~:*~{~s~^, ~}.~%~]" functions) (format t "~:[~;Block names: ~:*~{~s~^, ~}.~%~]" blocks) (format t "Local variables: ~:[~:[none~;~:*~{~s~1*~:@{, ~s~1*~}~}~]~;~ From 03c9c55e1c44bb9b6115a12dd9c22740231e7510 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Mon, 23 Jun 2008 20:39:12 +0000 Subject: [PATCH 70/71] Do not use constants for OP_GO labels --- src/c/compiler.d | 10 ++++++---- src/c/interpreter.d | 15 ++++++++------- 2 files changed, 14 insertions(+), 11 deletions(-) diff --git a/src/c/compiler.d b/src/c/compiler.d index 49707ff81..afa3e4496 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -535,9 +535,11 @@ c_tag_ref(cl_object the_tag, cl_object the_type) type = CAR(record); name = CADR(record); if (type == @':tag') { - if (type == the_type && !Null(ecl_assql(the_tag, name))) { - return CONS(MAKE_FIXNUM(n), - CDR(ecl_assql(the_tag, name))); + if (type == the_type) { + cl_object label = ecl_assql(the_tag, name); + if (!Null(label)) { + return CONS(MAKE_FIXNUM(n), ECL_CONS_CDR(label)); + } } n++; } else if (type == @':block' || type == @':function') { @@ -1279,7 +1281,7 @@ c_go(cl_object args, int flags) { if (!Null(args)) FEprogram_error("GO: Too many arguments.",0); asm_op2(OP_GO, fix(CAR(info))); - asm_c(CDR(info)); + asm_arg(fix(CDR(info))); return flags; } diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 0b7c0d008..65d246404 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -877,17 +877,18 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs reg0 = close_around(reg0, lex_env); THREAD_NEXT; } - /* OP_GO n{arg}, tag-name{symbol} - Jumps to the tag which is defined at the n-th position in - the lexical environment. TAG-NAME is kept for debugging - purposes. + /* OP_GO n{arg}, tag-ndx{arg} + Jumps to the tag which is defined for the tagbody + frame registered at the n-th position in the lexical + environment. TAG-NDX is the number of tag in the list. */ CASE(OP_GO); { cl_index lex_env_index; - cl_object tag_name; + cl_fixnum tag_ndx; GET_OPARG(lex_env_index, vector); - GET_DATA(tag_name, vector, data); - cl_go(ecl_lex_env_get_tag(lex_env, lex_env_index), tag_name); + GET_OPARG(tag_ndx, vector); + cl_go(ecl_lex_env_get_tag(lex_env, lex_env_index), + MAKE_FIXNUM(tag_ndx)); THREAD_NEXT; } /* OP_RETURN n{arg} From a7465e94badb78985f6da9b95e3e5b1346a41100 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Mon, 23 Jun 2008 20:39:26 +0000 Subject: [PATCH 71/71] Fixed optimization of MAPL and MAPC: output value was wrong. --- src/cmp/cmpmap.lsp | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/src/cmp/cmpmap.lsp b/src/cmp/cmpmap.lsp index a4ff45f2a..db8194cc9 100644 --- a/src/cmp/cmpmap.lsp +++ b/src/cmp/cmpmap.lsp @@ -31,7 +31,9 @@ (args (cddr whole)) iterators for-statements (in-or-on :IN) - (do-or-collect :COLLECT)) + (do-or-collect :COLLECT) + (list-1-form nil) + (finally-form nil)) (case which (MAPCAR) (MAPLIST (setf in-or-on :ON)) @@ -39,11 +41,19 @@ (MAPL (setf in-or-on :ON do-or-collect :DO)) (MAPCAN (setf do-or-collect 'NCONC)) (MAPCON (setf in-or-on :ON do-or-collect 'NCONC))) + (when (eq do-or-collect :DO) + (let ((var (gensym))) + (setf list-1-form `(with ,var = ,(first args)) + args (list* var (rest args)) + finally-form `(finally (return ,var))))) (loop for arg in (reverse args) do (let ((var (gensym))) (setf iterators (cons var iterators) for-statements (list* :for var in-or-on arg for-statements)))) - `(loop ,@for-statements ,do-or-collect (funcall ,function ,@iterators))))) + `(loop ,@list-1-form + ,@for-statements + ,do-or-collect (funcall ,function ,@iterators) + ,@finally-form)))) (define-compiler-macro mapcar (&whole whole &rest r) (expand-mapcar whole))