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