movitz-cvs February 2004

movitz-cvs@common-lisp.net

1 participants
166 discussions

[movitz-cvs] CVS update: movitz/special-operators-cl.lisp
by Frode Vatvedt Fjeld 13 Feb '04

13 Feb '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv2112 Modified Files: special-operators-cl.lisp Log Message: Added usage of with-host-environment. Date: Fri Feb 13 17:08:33 2004 Author: ffjeld Index: movitz/special-operators-cl.lisp diff -u movitz/special-operators-cl.lisp:1.9 movitz/special-operators-cl.lisp:1.10 --- movitz/special-operators-cl.lisp:1.9 Thu Feb 12 16:57:12 2004 +++ movitz/special-operators-cl.lisp Fri Feb 13 17:08:33 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 24 16:31:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: special-operators-cl.lisp,v 1.9 2004/02/12 21:57:12 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.10 2004/02/13 22:08:33 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -839,7 +839,6 @@ (destructuring-bind (situations &body body) (cdr form) (when (member :compile-toplevel situations) -;;; (warn "EVAL-WHEN from ~S" body) ;;; (warn "EVAL-WHEN: ~S" `(progn ,@(movitz::translate-program body :muerte.cl :cl ;;; :when :eval ;;; :remove-double-quotes-p t))) @@ -847,9 +846,10 @@ (dolist (toplevel-form (translate-program body :muerte.cl :cl :when :eval :remove-double-quotes-p t)) - (if *compiler-compile-eval-whens* - (funcall (compile () `(lambda () ,toplevel-form))) - (eval toplevel-form))))) + (with-host-environment () + (if *compiler-compile-eval-whens* + (funcall (compile () `(lambda () ,toplevel-form))) + (eval toplevel-form)))))) (if (or (member :execute situations) (and (member :load-toplevel situations) top-level-p))

1 0

[movitz-cvs] CVS update: movitz/movitz.lisp
by Frode Vatvedt Fjeld 13 Feb '04

13 Feb '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv26720 Modified Files: movitz.lisp Log Message: Added macro with-host-environment. Date: Fri Feb 13 17:07:21 2004 Author: ffjeld Index: movitz/movitz.lisp diff -u movitz/movitz.lisp:1.4 movitz/movitz.lisp:1.5 --- movitz/movitz.lisp:1.4 Mon Feb 2 08:06:06 2004 +++ movitz/movitz.lisp Fri Feb 13 17:07:21 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Mon Oct 9 20:52:58 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: movitz.lisp,v 1.4 2004/02/02 13:06:06 ffjeld Exp $ +;;;; $Id: movitz.lisp,v 1.5 2004/02/13 22:07:21 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -29,6 +29,15 @@ (defvar *bq-level* 0) (defvar *default-image-init-file* #p"losp/los0.lisp") (defvar *default-image-file* #p"los0-image") + +(defvar *movitz-host-features* *features* + "The *features* of the host implementation.") + +(defmacro with-host-environment (options &body body) + "Execute body in a `normal' host environment." + (declare (ignore options)) + `(let ((*features* *movitz-host-features*)) + ,@body)) (defmacro print-unreadable-movitz-object ((object stream &rest key-args) &body body) "Just like print-unreadable-object, just adorn output so as to

1 0

[movitz-cvs] CVS update: movitz/compiler.lisp
by Frode Vatvedt Fjeld 13 Feb '04

13 Feb '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv20257 Modified Files: compiler.lisp Log Message: Added defvar *compiler-do-type-inference*. Also added code to restore the host's *features* when doing host-side stuff. Date: Fri Feb 13 17:05:04 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.24 movitz/compiler.lisp:1.25 --- movitz/compiler.lisp:1.24 Fri Feb 13 05:40:14 2004 +++ movitz/compiler.lisp Fri Feb 13 17:05:04 2004 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.24 2004/02/13 10:40:14 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.25 2004/02/13 22:05:04 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -51,6 +51,9 @@ (defvar *compiler-compile-macro-expanders* t "For macros of any kind, compile the macro-expanders using the host compiler.") +(defvar *compiler-do-type-inference* t + "Spend time and effort performing type inference and optimization.") + (defvar *compiling-function-name*) (defvar muerte.cl:*compile-file-pathname* nil) @@ -142,7 +145,8 @@ Gensym a name whose symbol-function is set to the macro-expander, and return that symbol." (let ((function-name (gensym (format nil "~A-expander-~@[~A-~]" type name)))) (if *compiler-compile-macro-expanders* - (compile function-name lambda-form) + (with-host-environment () + (compile function-name lambda-form)) (setf (symbol-function function-name) (coerce lambda-form 'function))) function-name)) @@ -331,113 +335,115 @@ (multiple-value-list (type-specifier-encode nil)))) (defun analyze-bindings (toplevel-funobj) - "Figure out usage of bindings in a toplevel funobj." - (let ((more-binding-references-p nil) - (binding-usage (make-hash-table :test 'eq))) - (labels ((type-is-t (type-specifier) - (or (eq type-specifier t) - (and (listp type-specifier) - (eq 'or (car type-specifier)) - (some #'type-is-t (cdr type-specifier))))) - (analyze-store (binding type) - (assert (not (null type)) () - "store-lexical with empty type.") - (assert (or (typep type 'binding) - (eql 1 (type-specifier-num-values type))) () - "store-lexical with multiple-valued type: ~S for ~S" type binding) - (let ((analysis (or (gethash binding binding-usage) - (setf (gethash binding binding-usage) - (make-type-analysis))))) - (cond - ((typep binding 'function-argument) - (setf (type-analysis-encoded-type analysis) - (multiple-value-list (type-specifier-encode t)))) - ((and (consp type) (eq 'binding-type (car type))) - (let ((target-binding (binding-target (cadr type)))) - (cond - ((eq binding target-binding)) - ((typep binding 'constant-object-binding) - (setf (type-analysis-encoded-type analysis) + "Figure out usage of bindings in a toplevel funobj. +Side-effects each binding's binding-store-type." + (when *compiler-do-type-inference* + (let ((more-binding-references-p nil) + (binding-usage (make-hash-table :test 'eq))) + (labels ((type-is-t (type-specifier) + (or (eq type-specifier t) + (and (listp type-specifier) + (eq 'or (car type-specifier)) + (some #'type-is-t (cdr type-specifier))))) + (analyze-store (binding type) + (assert (not (null type)) () + "store-lexical with empty type.") + (assert (or (typep type 'binding) + (eql 1 (type-specifier-num-values type))) () + "store-lexical with multiple-valued type: ~S for ~S" type binding) + (let ((analysis (or (gethash binding binding-usage) + (setf (gethash binding binding-usage) + (make-type-analysis))))) + (cond + ((typep binding 'function-argument) + (setf (type-analysis-encoded-type analysis) + (multiple-value-list (type-specifier-encode t)))) + ((and (consp type) (eq 'binding-type (car type))) + (let ((target-binding (binding-target (cadr type)))) + (cond + ((eq binding target-binding)) + ((typep binding 'constant-object-binding) + (setf (type-analysis-encoded-type analysis) + (multiple-value-list + (multiple-value-call + #'encoded-types-or + (values-list (type-analysis-encoded-type analysis)) + (member-type-encode (constant-object target-binding)))))) + (t (pushnew target-binding (type-analysis-binding-types analysis)) + (setf more-binding-references-p t))))) + (t (setf (type-analysis-encoded-type analysis) (multiple-value-list (multiple-value-call #'encoded-types-or (values-list (type-analysis-encoded-type analysis)) - (member-type-encode (constant-object target-binding)))))) - (t (pushnew target-binding (type-analysis-binding-types analysis)) - (setf more-binding-references-p t))))) - (t (setf (type-analysis-encoded-type analysis) - (multiple-value-list - (multiple-value-call - #'encoded-types-or - (values-list (type-analysis-encoded-type analysis)) - (type-specifier-encode type)))))))) - (analyze-code (code) - (dolist (instruction code) - (when (listp instruction) - (multiple-value-bind (store-binding store-type) - (find-written-binding-and-type instruction) - (when store-binding - (analyze-store (binding-target store-binding) store-type))) - (analyze-code (instruction-sub-program instruction))))) - (analyze-funobj (funobj) - (loop for (nil . function-env) in (function-envs funobj) - do (analyze-code (extended-code function-env))) - (loop for function-binding in (sub-function-binding-usage funobj) by #'cddr - do (analyze-funobj (function-binding-funobj function-binding))) - funobj)) - ;; 1. Examine each store to lexical bindings. - (analyze-funobj toplevel-funobj) - ;; 2. - (loop repeat 10 while more-binding-references-p - doing - (setf more-binding-references-p nil) - (maphash (lambda (binding analysis) - (dolist (target-binding (type-analysis-binding-types analysis)) - (let* ((target-analysis - (or (gethash target-binding binding-usage) - (and (typep target-binding 'function-argument) - (make-type-analysis - :encoded-type (multiple-value-list - (type-specifier-encode t)))) - (error "Type-reference by ~S to unknown binding ~S" - binding target-binding))) - (new-type (setf (type-analysis-encoded-type analysis) - (multiple-value-list - (multiple-value-call - #'encoded-types-or - (values-list - (type-analysis-encoded-type analysis)) - (values-list - (type-analysis-encoded-type target-analysis))))))) - (cond - ((apply #'encoded-allp new-type) - ;; If the type is already T, no need to look further. - (setf (type-analysis-binding-types analysis) nil)) - ((setf (type-analysis-binding-types analysis) - (remove target-binding - (remove binding - (union (type-analysis-binding-types analysis) - (type-analysis-binding-types target-analysis))))) - (setf more-binding-references-p t)))))) - binding-usage)) - (when more-binding-references-p - (warn "Unable to remove all binding-references duding lexical type analysis.")) - ;; 3. - (maphash (lambda (binding analysis) - (assert (null (type-analysis-binding-types analysis)) () - "binding ~S type ~S still refers to ~S" - binding - (apply #'encoded-type-decode (type-analysis-encoded-type analysis)) - (type-analysis-binding-types analysis)) - (setf (binding-store-type binding) - (type-analysis-encoded-type analysis)) - #+ignore - (unless (apply #'encoded-allp (type-analysis-encoded-type analysis)) - (warn "Type: ~A => ~A" - (binding-name binding) - (apply #'encoded-type-decode (type-analysis-encoded-type analysis))))) - binding-usage) - toplevel-funobj))) + (type-specifier-encode type)))))))) + (analyze-code (code) + (dolist (instruction code) + (when (listp instruction) + (multiple-value-bind (store-binding store-type) + (find-written-binding-and-type instruction) + (when store-binding + (analyze-store (binding-target store-binding) store-type))) + (analyze-code (instruction-sub-program instruction))))) + (analyze-funobj (funobj) + (loop for (nil . function-env) in (function-envs funobj) + do (analyze-code (extended-code function-env))) + (loop for function-binding in (sub-function-binding-usage funobj) by #'cddr + do (analyze-funobj (function-binding-funobj function-binding))) + funobj)) + ;; 1. Examine each store to lexical bindings. + (analyze-funobj toplevel-funobj) + ;; 2. + (loop repeat 10 while more-binding-references-p + doing + (setf more-binding-references-p nil) + (maphash (lambda (binding analysis) + (dolist (target-binding (type-analysis-binding-types analysis)) + (let* ((target-analysis + (or (gethash target-binding binding-usage) + (and (typep target-binding 'function-argument) + (make-type-analysis + :encoded-type (multiple-value-list + (type-specifier-encode t)))) + (error "Type-reference by ~S to unknown binding ~S" + binding target-binding))) + (new-type (setf (type-analysis-encoded-type analysis) + (multiple-value-list + (multiple-value-call + #'encoded-types-or + (values-list + (type-analysis-encoded-type analysis)) + (values-list + (type-analysis-encoded-type target-analysis))))))) + (cond + ((apply #'encoded-allp new-type) + ;; If the type is already T, no need to look further. + (setf (type-analysis-binding-types analysis) nil)) + ((setf (type-analysis-binding-types analysis) + (remove target-binding + (remove binding + (union (type-analysis-binding-types analysis) + (type-analysis-binding-types target-analysis))))) + (setf more-binding-references-p t)))))) + binding-usage)) + (when more-binding-references-p + (warn "Unable to remove all binding-references duding lexical type analysis.")) + ;; 3. + (maphash (lambda (binding analysis) + (assert (null (type-analysis-binding-types analysis)) () + "binding ~S type ~S still refers to ~S" + binding + (apply #'encoded-type-decode (type-analysis-encoded-type analysis)) + (type-analysis-binding-types analysis)) + (setf (binding-store-type binding) + (type-analysis-encoded-type analysis)) + #+ignore + (unless (apply #'encoded-allp (type-analysis-encoded-type analysis)) + (warn "Type: ~A => ~A" + (binding-name binding) + (apply #'encoded-type-decode (type-analysis-encoded-type analysis))))) + binding-usage)))) + toplevel-funobj) (defun resolve-borrowed-bindings (toplevel-funobj) "For <funobj>'s code, for every non-local binding used we create @@ -1128,11 +1134,18 @@ (delete-file-p nil)) (handler-bind (#+sbcl (sb-ext:defconstant-uneql #'continue) + #+lispworks-personal-edition + (conditions:stack-overflow (lambda (&optional c) + (declare (ignore c)) + (warn "Stack overflow. Skipping function ~S.~%" + *compiling-function-name*) + (invoke-restart 'skip-toplevel-form))) #+ignore ((or error warning) (lambda (c) (declare (ignore c)) (format *error-output* "~&;; In file ~S:" path)))) (unwind-protect - (let ((*features* (image-movitz-features *image*))) + (let ((*movitz-host-features* *features*) + (*features* (image-movitz-features *image*))) (multiple-value-prog1 (movitz-compile-file-internal path load-priority) (unless (equalp *features* (image-movitz-features *image*)) @@ -1152,45 +1165,51 @@ (symbol-value '*default-load-priority*) (1+ (symbol-value '*default-load-priority*))))) (declare (special *default-load-priority*)) - (with-retries-until-true (retry "Restart Movitz compilation of ~S." path) - (let* ((muerte.cl::*compile-file-pathname* path) - (*package* (find-package :muerte)) - (funobj (make-instance 'movitz-funobj-pass1 - :name (intern (format nil "file-~A" path) :muerte) - :lambda-list (movitz-read nil))) - (funobj-env (make-local-movitz-environment nil funobj - :type 'funobj-env - :declaration-context :funobj)) - (function-env (make-local-movitz-environment funobj-env funobj - :type 'function-env + (with-simple-restart (continue "Skip Movitz compilation of ~S." path) + (with-retries-until-true (retry "Restart Movitz compilation of ~S." path) + (warn "Compiling ~A.." path) + (let* ((muerte.cl::*compile-file-pathname* path) + (*package* (find-package :muerte)) + (funobj (make-instance 'movitz-funobj-pass1 + :name (intern (format nil "file-~A" path) :muerte) + :lambda-list (movitz-read nil))) + (funobj-env (make-local-movitz-environment nil funobj + :type 'funobj-env :declaration-context :funobj)) - (file-code - (with-compilation-unit () - (add-bindings-from-lambda-list () function-env) - (with-open-file (stream path :direction :input) - (setf (funobj-env funobj) funobj-env) - (loop for form = (with-movitz-syntax () - (read stream nil '#0=#:eof)) - until (eq form '#0#) - appending - (with-simple-restart (skip-toplevel-form - "Skip the compilation of this top-level form.") - (compiler-call #'compile-form - :form form - :funobj funobj - :env function-env - :top-level-p t - :result-mode :ignore))))))) - (cond - ((null file-code) - (setf (image-load-time-funobjs *image*) - (delete funobj (image-load-time-funobjs *image*) :key #'first))) - (t (setf (extended-code function-env) file-code - (need-normalized-ecx-p function-env) nil - (function-envs funobj) (list (cons 'muerte.cl::t function-env)) - (funobj-env funobj) funobj-env) - (make-compiled-funobj-pass2 funobj))) - t))) + (function-env (make-local-movitz-environment funobj-env funobj + :type 'function-env + :declaration-context :funobj)) + (file-code + (with-compilation-unit () + (add-bindings-from-lambda-list () function-env) + (with-open-file (stream path :direction :input) + (setf (funobj-env funobj) funobj-env) + (loop for form = (with-movitz-syntax () + (read stream nil '#0=#:eof)) + until (eq form '#0#) + appending + (with-simple-restart (skip-toplevel-form + "Skip the compilation of top-level form~@[ ~A~]." + (cond + ((symbolp form) form) + ((symbolp (car form)) (car form)))) + #+lispworks-personal-edition (hcl:mark-and-sweep 2) + (compiler-call #'compile-form + :form form + :funobj funobj + :env function-env + :top-level-p t + :result-mode :ignore))))))) + (cond + ((null file-code) + (setf (image-load-time-funobjs *image*) + (delete funobj (image-load-time-funobjs *image*) :key #'first))) + (t (setf (extended-code function-env) file-code + (need-normalized-ecx-p function-env) nil + (function-envs funobj) (list (cons 'muerte.cl::t function-env)) + (funobj-env funobj) funobj-env) + (make-compiled-funobj-pass2 funobj))) + t)))) ;;;; @@ -5352,7 +5371,7 @@ (define-find-read-bindings :incf-lexvar (binding delta &key protect-registers) (declare (ignore delta protect-registers)) - binding) + nil #+ignore binding) (define-extended-code-expander :incf-lexvar (instruction funobj frame-map) (destructuring-bind (binding delta &key protect-registers) @@ -5360,11 +5379,11 @@ (check-type binding binding) (check-type delta integer) (let* ((binding (binding-target binding)) - (location (new-binding-location binding frame-map :default nil))) - (assert (= 5 (length (binding-store-type binding))) () - "Weird encoded-type: ~S" (binding-store-type binding)) + (location (new-binding-location binding frame-map :default nil)) + (binding-type (binding-store-type binding))) (cond - ((and location + ((and binding-type + location (not (binding-lended-p binding)) (multiple-value-call #'encoded-subtypep (values-list (binding-store-type binding)) @@ -5374,9 +5393,10 @@ `((:addl ,(* delta +movitz-fixnum-factor+) (:ebp ,(stack-frame-offset location))) (:into))) - ((multiple-value-call #'encoded-subtypep - (values-list (binding-store-type binding)) - (type-specifier-encode 'integer)) + ((and binding-type + (multiple-value-call #'encoded-subtypep + (values-list (binding-store-type binding)) + (type-specifier-encode 'integer))) (let ((register (chose-free-register protect-registers))) `(,@(make-load-lexical (ensure-local-binding binding funobj) register funobj nil frame-map

1 0

[movitz-cvs] CVS update: movitz/image.lisp
by Frode Vatvedt Fjeld 13 Feb '04

13 Feb '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv5568 Modified Files: image.lisp Log Message: Changed find-primitive-function to signal a continuable error if the function is undefined. Date: Fri Feb 13 17:03:16 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.15 movitz/image.lisp:1.16 --- movitz/image.lisp:1.15 Thu Feb 12 06:30:20 2004 +++ movitz/image.lisp Fri Feb 13 17:03:16 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.15 2004/02/12 11:30:20 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.16 2004/02/13 22:03:16 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -683,10 +683,12 @@ that function's code-vector." (let ((code-vector (movitz-symbol-value (movitz-read name)))) - (assert (and code-vector - (not (eq 'muerte::unbound code-vector))) - () - "Global constant primitive function ~S is not defined!" name) + (unless (and code-vector (not (eq 'muerte::unbound code-vector))) + (cerror "Install an empty vector instead." + "Global constant primitive function ~S is not defined!" name) + (setf code-vector + (setf (movitz-symbol-value (movitz-read name)) + (movitz-read #())))) (check-type code-vector movitz-vector) code-vector))

1 0

[movitz-cvs] CVS update: movitz/storage-types.lisp
by Frode Vatvedt Fjeld 13 Feb '04

13 Feb '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv12737 Modified Files: storage-types.lisp Log Message: Removed some overly eager :binary-lisp-type declarations. Make them plain :binary-type instead. Date: Fri Feb 13 10:25:34 2004 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.8 movitz/storage-types.lisp:1.9 --- movitz/storage-types.lisp:1.8 Thu Feb 12 17:58:37 2004 +++ movitz/storage-types.lisp Fri Feb 13 10:25:34 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: storage-types.lisp,v 1.8 2004/02/12 22:58:37 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.9 2004/02/13 15:25:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -585,11 +585,11 @@ :reader movitz-symbol-hash-key :initarg :hash-key) (flags - :binary-lisp-type (define-bitfield movitz-symbol-flags (lu16) - (((:bits) - :special-variable 0 - :constant-variable 1 - :setf-placeholder 4))) + :binary-type (define-bitfield movitz-symbol-flags (lu16) + (((:bits) + :special-variable 0 + :constant-variable 1 + :setf-placeholder 4))) :accessor movitz-symbol-flags :initform nil) (lisp-symbol @@ -695,7 +695,7 @@ (hash-key :binary-lisp-type lu16) (flags - :binary-lisp-type movitz-symbol-flags + :binary-type movitz-symbol-flags :initform '(:constant-variable))) (:slot-align value 7)) @@ -1029,7 +1029,7 @@ :reader movitz-struct-name :initarg :name) (type - :binary-lisp-type other-type-byte + :binary-type other-type-byte :initform :defstruct) (pad :binary-lisp-type 1) (length @@ -1252,7 +1252,7 @@ :map-binary-write 'movitz-intern :map-binary-read-delayed 'movitz-word) (type - :binary-lisp-type other-type-byte + :binary-type other-type-byte :initform :std-instance) (pad :binary-lisp-type 3) (class

1 0

[movitz-cvs] CVS update: movitz/compiler.lisp
by Frode Vatvedt Fjeld 13 Feb '04

13 Feb '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv2870 Modified Files: compiler.lisp Log Message: Improved various aspects related to compiling :incf-lexvar. Date: Fri Feb 13 05:40:15 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.23 movitz/compiler.lisp:1.24 --- movitz/compiler.lisp:1.23 Thu Feb 12 16:57:05 2004 +++ movitz/compiler.lisp Fri Feb 13 05:40:14 2004 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.23 2004/02/12 21:57:05 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.24 2004/02/13 10:40:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -2709,6 +2709,14 @@ mode) (t default-mode))) +(defun chose-free-register (unfree-registers &optional (preferred-register :eax)) + (cond + ((not (member preferred-register unfree-registers)) + preferred-register) + ((find-if (lambda (r) (not (member r unfree-registers))) + '(:eax :ebx :ecx :edx))) + (t (error "Unable to find a free register.")))) + (defun make-indirect-reference (base-register offset) "Make the shortest possible assembly indirect reference, explointing the constant edi register." (if (<= #x-80 offset #x7f) @@ -2874,51 +2882,55 @@ (install-for-single-value binding binding-location :eax nil))) )))))))) -(defun make-store-lexical (binding source shared-reference-p frame-map) +(defun make-store-lexical (binding source shared-reference-p frame-map + &key protect-registers) (assert (not (and shared-reference-p (not (binding-lended-p binding)))) (binding) "funny binding: ~W" binding) - (cond - ((typep binding 'borrowed-binding) - (let ((slot (borrowed-binding-reference-slot binding))) - (if (not shared-reference-p) - (let ((tmp-reg (if (eq source :eax) :ebx :eax))) - `((:movl (:esi ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 slot))) - ,tmp-reg) - (:movl ,source (-1 ,tmp-reg)))) - `((:movl ,source (:esi ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 slot)))))))) - ((typep binding 'forwarding-binding) - (assert (not (binding-lended-p binding)) (binding)) - (make-store-lexical (forwarding-binding-target binding) - source shared-reference-p frame-map)) - ((not (new-binding-located-p binding frame-map)) - ;; (warn "Can't store to unlocated binding ~S." binding) - nil) - ((and (binding-lended-p binding) - (not shared-reference-p)) - (let ((tmp-reg (if (eq source :eax) :ebx :eax)) - (location (new-binding-location binding frame-map))) - (if (integerp location) - `((:movl (:ebp ,(stack-frame-offset location)) ,tmp-reg) - (:movl ,source (,tmp-reg -1))) - (ecase location - (:argument-stack - (assert (<= 2 (function-argument-argnum binding)) () - "store-lexical argnum can't be ~A." (function-argument-argnum binding)) - `((:movl (:ebp ,(argument-stack-offset binding)) ,tmp-reg) - (:movl ,source (,tmp-reg -1)))))))) - (t (let ((location (new-binding-location binding frame-map))) + (let ((protect-registers (cons source protect-registers))) + (cond + ((typep binding 'borrowed-binding) + (let ((slot (borrowed-binding-reference-slot binding))) + (if (not shared-reference-p) + (let ((tmp-reg (chose-free-register protect-registers) + #+ignore(if (eq source :eax) :ebx :eax))) + `((:movl (:esi ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 slot))) + ,tmp-reg) + (:movl ,source (-1 ,tmp-reg)))) + `((:movl ,source (:esi ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 slot)))))))) + ((typep binding 'forwarding-binding) + (assert (not (binding-lended-p binding)) (binding)) + (make-store-lexical (forwarding-binding-target binding) + source shared-reference-p frame-map)) + ((not (new-binding-located-p binding frame-map)) + ;; (warn "Can't store to unlocated binding ~S." binding) + nil) + ((and (binding-lended-p binding) + (not shared-reference-p)) + (let ((tmp-reg (chose-free-register protect-registers) + #+ignore (if (eq source :eax) :ebx :eax)) + (location (new-binding-location binding frame-map))) (if (integerp location) - `((:movl ,source (:ebp ,(stack-frame-offset location)))) + `((:movl (:ebp ,(stack-frame-offset location)) ,tmp-reg) + (:movl ,source (,tmp-reg -1))) (ecase location - ((:eax :ebx :edx) - (unless (eq source location) - `((:movl ,source ,location)))) (:argument-stack (assert (<= 2 (function-argument-argnum binding)) () "store-lexical argnum can't be ~A." (function-argument-argnum binding)) - `((:movl ,source (:ebp ,(argument-stack-offset binding))))))))))) + `((:movl (:ebp ,(argument-stack-offset binding)) ,tmp-reg) + (:movl ,source (,tmp-reg -1)))))))) + (t (let ((location (new-binding-location binding frame-map))) + (if (integerp location) + `((:movl ,source (:ebp ,(stack-frame-offset location)))) + (ecase location + ((:eax :ebx :edx) + (unless (eq source location) + `((:movl ,source ,location)))) + (:argument-stack + (assert (<= 2 (function-argument-argnum binding)) () + "store-lexical argnum can't be ~A." (function-argument-argnum binding)) + `((:movl ,source (:ebp ,(argument-stack-offset binding)))))))))))) (defun finalize-code (code funobj frame-map) (labels ((actual-binding (b) @@ -5333,17 +5345,17 @@ ;;;;;;;;;;;;;;;;;; incf-lexvar (define-find-write-binding-and-type :incf-lexvar (instruction) - (destructuring-bind (binding delta) + (destructuring-bind (binding delta &key protect-registers) (cdr instruction) - (declare (ignore delta)) + (declare (ignore delta protect-registers)) (values binding 'integer))) -(define-find-read-bindings :incf-lexvar (binding delta) - (declare (ignore delta)) +(define-find-read-bindings :incf-lexvar (binding delta &key protect-registers) + (declare (ignore delta protect-registers)) binding) (define-extended-code-expander :incf-lexvar (instruction funobj frame-map) - (destructuring-bind (binding delta) + (destructuring-bind (binding delta &key protect-registers) (cdr instruction) (check-type binding binding) (check-type delta integer) @@ -5353,32 +5365,38 @@ "Weird encoded-type: ~S" (binding-store-type binding)) (cond ((and location + (not (binding-lended-p binding)) (multiple-value-call #'encoded-subtypep (values-list (binding-store-type binding)) (type-specifier-encode 'integer))) - #+ignore - (warn "incf ~S type: ~S location: ~S" - binding - (apply #'encoded-type-decode (binding-store-type binding)) - location) + ;; This is an optimized incf that doesn't have to do type-checking. (check-type location (integer 1 *)) `((:addl ,(* delta +movitz-fixnum-factor+) (:ebp ,(stack-frame-offset location))) (:into))) ((multiple-value-call #'encoded-subtypep - (values-list (binding-store-type binding)) - (type-specifier-encode 'integer)) - `(,@(make-load-lexical (ensure-local-binding binding funobj) :eax funobj nil frame-map) - (:addl ,(* delta +movitz-fixnum-factor+) :eax) - (:into) - ,@(make-store-lexical (ensure-local-binding binding funobj) - :eax nil frame-map))) - (t `(,@(make-load-lexical (ensure-local-binding binding funobj) :eax funobj nil frame-map) - (:testb ,+movitz-fixnum-zmask+ :al) - (:jnz '(:sub-program (,(gensym "not-integer-")) - (:int 107) - (:jmp (:pc+ -4)))) + (values-list (binding-store-type binding)) + (type-specifier-encode 'integer)) + (let ((register (chose-free-register protect-registers))) + `(,@(make-load-lexical (ensure-local-binding binding funobj) + register funobj nil frame-map + :protect-registers protect-registers) (:addl ,(* delta +movitz-fixnum-factor+) :eax) (:into) - ,@(make-store-lexical (ensure-local-binding binding funobj) :eax nil frame-map))))))) + ,@(make-store-lexical (ensure-local-binding binding funobj) + register nil frame-map + :protect-registers protect-registers)))) + (t (let ((register (chose-free-register protect-registers))) + `(,@(make-load-lexical (ensure-local-binding binding funobj) + register funobj nil frame-map + :protect-registers protect-registers) + (:testb ,+movitz-fixnum-zmask+ ,(register32-to-low8 register)) + (:jnz '(:sub-program (,(gensym "not-integer-")) + (:int 107) + (:jmp (:pc+ -4)))) + (:addl ,(* delta +movitz-fixnum-factor+) ,register) + (:into) + ,@(make-store-lexical (ensure-local-binding binding funobj) + register nil frame-map + :protect-registers protect-registers))))))))

1 0

[movitz-cvs] CVS update: movitz/special-operators.lisp
by Frode Vatvedt Fjeld 13 Feb '04

13 Feb '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv30553 Modified Files: special-operators.lisp Log Message: Added a special case to muerte:with-cloak. Date: Fri Feb 13 05:39:37 2004 Author: ffjeld Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.10 movitz/special-operators.lisp:1.11 --- movitz/special-operators.lisp:1.10 Thu Feb 12 16:57:19 2004 +++ movitz/special-operators.lisp Fri Feb 13 05:39:37 2004 @@ -8,7 +8,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Nov 24 16:22:59 2000 ;;;; -;;;; $Id: special-operators.lisp,v 1.10 2004/02/12 21:57:19 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.11 2004/02/13 10:39:37 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -915,6 +915,24 @@ cloaked-code `((:popl :ecx) (:globally (:call (:edi (:edi-offset pop-current-values)))))))) + ((and (not (cdr cloaked-code)) + (instruction-is (car cloaked-code) :incf-lexvar)) + (destructuring-bind (binding delta &key protect-registers) + (cdar cloaked-code) + (let ((protected-register (case cover-returns + ((:eax :ebx :ecx :edx) cover-returns) + (t :edx)))) + (assert (not (member protected-register protect-registers)) () + "Can't protect ~S. Sorry, this opertor must be smartened up." + protected-register) + (compiler-values () + :returns protected-register + :type cover-type + :code (append cover-code + (make-result-and-returns-glue protected-register cover-returns) + `((:incf-lexvar ,binding ,delta + :protect-registers ,(cons protected-register + protect-registers)))))))) (t ;; just put the (singular) result of form1 on the stack.. (when (not (typep cover-returns 'keyword)) ;; if it's a (non-modified) lexical-binding, we can do better..

1 0

[movitz-cvs] CVS update: movitz/storage-types.lisp
by Frode Vatvedt Fjeld 12 Feb '04

12 Feb '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv4007 Modified Files: storage-types.lisp Log Message: Removed some dead code. Date: Thu Feb 12 17:58:37 2004 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.7 movitz/storage-types.lisp:1.8 --- movitz/storage-types.lisp:1.7 Thu Feb 12 17:58:02 2004 +++ movitz/storage-types.lisp Thu Feb 12 17:58:37 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: storage-types.lisp,v 1.7 2004/02/12 22:58:02 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.8 2004/02/12 22:58:37 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1166,19 +1166,6 @@ (third (movitz-struct-slot-values movitz-hash)) hash-sxhash) movitz-hash))) - - -;;;(define-binary-class movitz-dynamic-environment (movitz-heap-object-other) -;;; ((uplink :binary-type word -;;; :map-binary-write movitz-read-and-intern -;;; :initarg uplink -;;; :initform nil) -;;; (alist :binary-type word -;;; :map-binary-write movitz-read-and-intern -;;; :initarg alist -;;; :initform nil))) - - ;;; (unless (typep *movitz-nil* 'movitz-nil)

1 0

[movitz-cvs] CVS update: movitz/storage-types.lisp
by Frode Vatvedt Fjeld 12 Feb '04

12 Feb '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv649 Modified Files: storage-types.lisp Log Message: When converting a host-side hash-table to a movitz object, base the table's size on hash-table-count rather than hash-table-size, which is host-implementation-dependent. Date: Thu Feb 12 17:58:02 2004 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.6 movitz/storage-types.lisp:1.7 --- movitz/storage-types.lisp:1.6 Thu Feb 12 06:28:28 2004 +++ movitz/storage-types.lisp Thu Feb 12 17:58:02 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: storage-types.lisp,v 1.6 2004/02/12 11:28:28 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.7 2004/02/12 22:58:02 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1137,7 +1137,7 @@ (assert (= 3 (length (movitz-struct-slot-values movitz-hash)))) (let* ((undef (movitz-read +undefined-hash-key+)) (old-bucket (second (movitz-struct-slot-values movitz-hash))) - (hash-size (* 2 (hash-table-size lisp-hash))) + (hash-size (* 2 (truncate (hash-table-count lisp-hash) 2/3))) (bucket-data (or (and old-bucket (= (length (movitz-vector-symbolic-data old-bucket)) hash-size)

1 0

[movitz-cvs] CVS update: movitz/special-operators.lisp
by Frode Vatvedt Fjeld 12 Feb '04

12 Feb '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv31617 Modified Files: special-operators.lisp Log Message: These changes adds type-inference for incf-like operations. Many dynamic type-checks for integer type are removed from code, in dotimes loops etc. Date: Thu Feb 12 16:57:20 2004 Author: ffjeld Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.9 movitz/special-operators.lisp:1.10 --- movitz/special-operators.lisp:1.9 Thu Feb 12 12:54:37 2004 +++ movitz/special-operators.lisp Thu Feb 12 16:57:19 2004 @@ -8,7 +8,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Nov 24 16:22:59 2000 ;;;; -;;;; $Id: special-operators.lisp,v 1.9 2004/02/12 17:54:37 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.10 2004/02/12 21:57:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -979,12 +979,10 @@ ;;; (warn "t2-type: ~S, t2-ret: ~S, rm: ~S" ;;; term2-type term2-returns result-mode) (cond - #+ignore ((and (eq 'binding-type (operator term2-type)) (eq (second term2-type) result-mode)) (let ((binding result-mode)) (check-type binding lexical-binding) - (warn "yes, for ~S" binding) (compiler-values () :returns binding :type (binding-type-specifier binding)

1 0

← Newer
1
2
3
4
5
6
7
8
9
...
17
Older →

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

movitz-cvs February 2004