Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv24640

Modified Files: compiler.lisp Log Message: Fixed a bug in resolve-borrowed-bindings wrt function-bindings: Sometimes we would generate a forwarding-binding to a function-binding, but the forwarding-binding-target would be nil because this function returned nil for function-bindings.

Also, started to use a new strategy with thunks in analyze-bindings.

Date: Fri Jul 23 08:31:19 2004 Author: ffjeld

Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.82 movitz/compiler.lisp:1.83 --- movitz/compiler.lisp:1.82 Wed Jul 21 17:27:11 2004 +++ movitz/compiler.lisp Fri Jul 23 08:31:19 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.82 2004/07/22 00:27:11 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.83 2004/07/23 15:31:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------

@@ -344,6 +344,7 @@ (resolve-sub-functions toplevel-funobj function-binding-usage)))))))

(defstruct (type-analysis (:type list)) + (thunks) (binding-types) (encoded-type (multiple-value-list (type-specifier-encode nil)))) @@ -354,12 +355,28 @@ (when *compiler-do-type-inference* (let ((more-binding-references-p nil) (binding-usage (make-hash-table :test 'eq))) - (labels ((type-is-t (type-specifier) + (labels ((binding-resolved-p (binding) + (let ((analysis (gethash binding binding-usage))) + (and analysis + (null (type-analysis-binding-types analysis)) + (null (type-analysis-thunks analysis))))) + (binding-resolve (binding) + (if (not (bindingp binding)) + binding + (let ((analysis (gethash binding binding-usage))) + (assert (and (and analysis + (null (type-analysis-binding-types analysis)) + (null (type-analysis-thunks analysis)))) + (binding) + "Can't resolve unresolved binding ~S." binding) + (apply #'encoded-type-decode + (type-analysis-encoded-type analysis))))) + (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) + (analyze-store (binding type thunk thunk-args) (assert (not (null type)) () "store-lexical with empty type.") (assert (or (typep type 'binding) @@ -369,6 +386,10 @@ (setf (gethash binding binding-usage) (make-type-analysis))))) (cond + (thunk + (assert (some #'bindingp thunk-args)) + ;; (warn "got a thunk for ~S" thunk-args) + (push (cons thunk thunk-args) (type-analysis-thunks analysis))) ((typep binding 'function-argument) (setf (type-analysis-encoded-type analysis) (multiple-value-list @@ -401,10 +422,10 @@ (analyze-code (code) (dolist (instruction code) (when (listp instruction) - (multiple-value-bind (store-binding store-type) + (multiple-value-bind (store-binding store-type thunk thunk-args) (find-written-binding-and-type instruction) (when store-binding - (analyze-store (binding-target store-binding) store-type))) + (analyze-store (binding-target store-binding) store-type thunk thunk-args))) (analyze-code (instruction-sub-program instruction))))) (analyze-funobj (funobj) (loop for (nil . function-env) in (function-envs funobj) @@ -419,6 +440,24 @@ doing (setf more-binding-references-p nil) (maphash (lambda (binding analysis) + (setf (type-analysis-thunks analysis) + (remove-if (lambda (x) + (destructuring-bind (thunk . thunk-args) x + (when (every (lambda (arg) + (or (not (bindingp arg)) + (binding-resolved-p arg))) + thunk-args) + (setf more-binding-references-p 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 + (apply thunk (mapcar #'binding-resolve + thunk-args))))))))) + (type-analysis-thunks analysis))) (dolist (target-binding (type-analysis-binding-types analysis)) (let* ((target-analysis (or (gethash target-binding binding-usage) @@ -451,6 +490,8 @@ (warn "Unable to remove all binding-references during lexical type analysis.")) ;; 3. (maphash (lambda (binding analysis) +;;; (loop for (nil . thunk-args) in (type-analysis-thunks analysis) +;;; do (warn "Unable to thunk ~S with args ~S." binding thunk-args)) (assert (null (type-analysis-binding-types analysis)) () "binding ~S type ~S still refers to ~S" binding @@ -516,7 +557,8 @@ (pushnew usage (getf (sub-function-binding-usage (function-binding-parent binding)) binding)) - (pushnew usage (getf function-binding-usage binding)))) + (pushnew usage (getf function-binding-usage binding))) + binding) (t binding)))) (resolve-sub-funobj (funobj sub-funobj) (dolist (binding-we-lend (borrowed-bindings (resolve-funobj-borrowing sub-funobj))) @@ -2193,8 +2235,10 @@ (print-unreadable-object (object stream :type t :identity t) (when (slot-boundp object 'name) (format stream "name: ~S~@[->~S~]~@[ %~A~]" - (binding-name object) - (unless (eq object (binding-target object)) + (and (slot-boundp object 'name) + (binding-name object)) + (when (and (binding-target object) + (not (eq object (binding-target object)))) (binding-name (binding-target object))) (when (and #+ignore (slot-exists-p object 'store-type) #+ignore (slot-boundp object 'store-type) @@ -6107,9 +6151,18 @@ (define-find-write-binding-and-type :add (instruction) (destructuring-bind (term0 term1 destination) (cdr instruction) - (declare (ignore term0 term1)) (when (typep destination 'binding) - (values destination 'integer)))) + (assert (and (bindingp term0) (bindingp term1))) + (values destination + t + (lambda (type0 type1) + (let ((x (multiple-value-call #'encoded-integer-types-add + (type-specifier-encode type0) + (type-specifier-encode type1)))) + (warn "thunked: ~S ~S -> ~S" term0 term1) + x)) + (list term0 term1) + ))))

(define-find-read-bindings :add (term0 term1 destination) (declare (ignore destination)) @@ -6156,10 +6209,12 @@ `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0))) (:ebp ,(stack-frame-offset loc1))))))) (t -;;; (warn "ADD: ~S = ~A + ~A, ~A ~A, ~A ~A" -;;; destination loc0 loc1 type0 type1 -;;; (type-specifier-singleton type0) -;;; (eq loc1 destination)) +;;; (warn "ADD: ~S = ~A/~S + ~A/~S,~%~A ~A" +;;; destination +;;; loc0 term0 +;;; loc1 term1 +;;; (type-specifier-singleton type0) +;;; (eq loc1 destination)) ;;; (warn "ADDI: ~S" instruction) (append (cond ((and (eq :eax loc0) (eq :ebx loc1))