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

Modified Files: compiler.lisp Log Message: Re-worked several aspects of binding/environments: assignment, type-inference, etc.

Date: Sat Aug 20 22:30:44 2005 Author: ffjeld

Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.149 movitz/compiler.lisp:1.150 --- movitz/compiler.lisp:1.149 Mon Aug 15 23:44:23 2005 +++ movitz/compiler.lisp Sat Aug 20 22:30:40 2005 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.149 2005/08/15 21:44:23 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.150 2005/08/20 20:30:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------

@@ -473,7 +473,7 @@ (assert (or (typep type 'binding) (eql 1 (type-specifier-num-values type))) () "store-lexical with multiple-valued type: ~S for ~S" type binding) - ;; (warn "store ~S type ~S, thunk ~S" binding type thunk) + #+ignore (warn "store ~S type ~S, thunk ~S" binding type thunk) (let ((analysis (or (gethash binding binding-usage) (setf (gethash binding binding-usage) (make-type-analysis-with-declaration binding))))) @@ -492,14 +492,14 @@ (values-list (type-analysis-encoded-type analysis)) (type-specifier-encode type)))))))) (analyze-code (code) + #+ignore (print-code 'analyze code) (dolist (instruction code) (when (listp instruction) (multiple-value-bind (store-binding store-type thunk thunk-args) (find-written-binding-and-type instruction) (when store-binding - #+ignore - (warn "store: ~S binding ~S type ~S thunk ~S" - instruction store-binding store-type thunk) + #+ignore (warn "store: ~S binding ~S type ~S thunk ~S" + instruction store-binding store-type thunk) (analyze-store store-binding store-type thunk thunk-args))) (analyze-code (instruction-sub-program instruction))))) (analyze-funobj (funobj) @@ -617,6 +617,8 @@ ;; Binding is local to this funobj (typecase binding (forwarding-binding + (process-binding funobj (forwarding-binding-target binding) usages) + #+ignore (setf (forwarding-binding-target binding) (process-binding funobj (forwarding-binding-target binding) usages))) (function-binding @@ -2377,7 +2379,14 @@ :accessor binding-env) (declarations :initarg :declarations - :accessor binding-declarations))) + :accessor binding-declarations) + (extent-env + :accessor binding-extent-env + :initform nil))) + +(defmethod (setf binding-env) :after (env (binding binding)) + (unless (binding-extent-env binding) + (setf (binding-extent-env binding) env)))

(defmethod print-object ((object binding) stream) (print-unreadable-object (object stream :type t :identity t) @@ -2387,12 +2396,13 @@ (binding-name object)) (when (and (binding-target object) (not (eq object (binding-target object)))) - (binding-name (binding-target object))) + (binding-name (forwarding-binding-target object))) (when (and #+ignore (slot-exists-p object 'store-type) #+ignore (slot-boundp object 'store-type) (binding-store-type object)) - (apply #'encoded-type-decode - (binding-store-type object))))))) + (or (apply #'encoded-type-decode + (binding-store-type object)) + 'empty))))))

(defclass constant-object-binding (binding) ((object @@ -2653,11 +2663,11 @@ '((:int 100)) :test #'equalp)))

-(defun sub-environment-p (env1 env2) - (cond - ((eq env1 env2) t) - ((null env1) nil) - (t (sub-environment-p (movitz-environment-uplink env1) env2)))) +#+ignore (defun sub-environment-p (env1 env2) + (cond + ((eq env1 env2) t) + ((null env1) nil) + (t (sub-environment-p (movitz-environment-uplink env1) env2))))

(defun find-code-constants-and-jumpers (code &key include-programs) "Return code's constants (a plist of constants and their usage-counts) and jumper-sets." @@ -3006,7 +3016,7 @@ sub-environments found in CODE. A frame-map which is an assoc from bindings to stack-frame locations." ;; Then assign them to locations in the stack-frame. - ;; (warn "assigning code:~%~{~& ~A~}" code) + #+ignore (warn "assigning code:~%~{~& ~A~}" code) (check-type function-env function-env) (assert (= initial-stack-frame-position (1+ (frame-map-size frame-map)))) @@ -3022,10 +3032,42 @@ (error "SEFEW: ~S" function-env)) ;; The floor of this env is the roof of its extent-uplink. (t (assign-env-bindings (movitz-environment-extent-uplink env))))) + ;; PROMOTE FORW-BINDINGS TO UPPER ENV!! (assign-env-bindings (env) (or (getf env-roof-map env nil) (let* ((stack-frame-position (env-floor env)) (bindings-to-locate + (loop for binding being the hash-keys of var-counts + when (eq env (binding-extent-env binding)) + unless (let ((variable (binding-name binding))) + (cond + ((not (typep binding 'lexical-binding))) + ((typep binding 'lambda-binding)) + ((typep binding 'constant-object-binding)) + ((typep binding 'forwarding-binding) + ;; Immediately "assign" to target. + (when (plusp (or (car (gethash binding var-counts)) 0)) + (setf (new-binding-location binding frame-map) + (forwarding-binding-target binding))) + t) + ((typep binding 'borrowed-binding)) + ((typep binding 'funobj-binding)) + ((and (typep binding 'fixed-required-function-argument) + (plusp (or (car (gethash binding var-counts)) 0))) + (prog1 nil ; may need lending-cons + (setf (new-binding-location binding frame-map) + `(:argument-stack ,(function-argument-argnum binding))))) + ((unless (or (movitz-env-get variable 'ignore nil + (binding-env binding) nil) + (movitz-env-get variable 'ignorable nil + (binding-env binding) nil) + (typep binding 'hidden-rest-function-argument) + (third (gethash binding var-counts))) + (warn "Unused variable: ~S" + (binding-name binding)))) + ((not (plusp (or (car (gethash binding var-counts)) 0)))))) + collect binding) + #+ignore (loop for (variable . binding) in (movitz-environment-bindings env) unless (cond ((not (typep binding 'lexical-binding))) @@ -3087,6 +3129,22 @@ (cdr init-pc)) 15) count))))))))) + #+ignore (labels ((dox (env upper) + (if (or (not env) + (not (sub-env-p env function-env))) + 0 + (let ((level (dox (funcall upper env) upper))) + (format t "~%~v{ ~}~S" level t env) + (+ level 4))))) + (warn "At ~S binding ~S:~{ ~S~}: Extent: ~A~%Bind: ~A" + stack-frame-position + env bindings-to-locate + (with-output-to-string (*standard-output*) + (dox env #'movitz-environment-extent-uplink)) + (with-output-to-string (*standard-output*) + (when bindings-to-locate + (dox (binding-env (first bindings-to-locate)) + #'movitz-environment-uplink))))) ;; First, make several passes while trying to locate bindings ;; into registers. (loop repeat 100 with try-again = t and did-assign = t @@ -3181,6 +3239,8 @@ (setf (new-binding-location binding frame-map) `(:argument-stack ,(function-argument-argnum binding)))) (located-binding + #+ignore (warn "Assigning ~S at ~S" + binding stack-frame-position) (setf (new-binding-location binding frame-map) (post-incf stack-frame-position)))))) (setf (getf env-roof-map env) @@ -3190,7 +3250,7 @@ ;; do (warn "bind: ~S: ~S" binding (eq function-env (find-function-env env funobj))) when (sub-env-p env function-env) do (assign-env-bindings (binding-env binding))) - ;; (warn "Frame-map:~{ ~A~}" frame-map) + #+ignore (warn "Frame-map:~{ ~A~}" frame-map) frame-map)))

@@ -3269,7 +3329,7 @@ "Resolve a binding in terms of forwarding." (etypecase binding (forwarding-binding - (forwarding-binding-target binding)) + (binding-target (forwarding-binding-target binding))) (binding binding)))

@@ -3460,8 +3520,8 @@ ;;; :untagged-fixnum-ecx)) ((and binding-type (type-specifier-singleton decoded-type)) - (warn "Immloadlex: ~S" - (type-specifier-singleton decoded-type)) + #+ignore (warn "Immloadlex: ~S" + (type-specifier-singleton decoded-type)) (make-immediate-move (movitz-immediate-value (car (type-specifier-singleton decoded-type))) :ecx)) @@ -3571,6 +3631,7 @@ (located-binding (let ((binding-type (binding-store-type binding)) (binding-location (new-binding-location binding frame-map))) + #+ignore (warn "~S type: ~S" binding binding-type) (cond ((and (binding-lended-p binding) (not shared-reference-p)) @@ -5349,13 +5410,32 @@ :result-mode :eax :forward form-info)))))

-(define-compiler compile-form-unprotected (&all all &form form &result-mode result-mode) +(define-compiler compile-form-unprotected (&all downstream &form form &result-mode result-mode + &extent extent) "3.1.2.1 Form Evaluation. May not honor RESULT-MODE. That is, RESULT-MODE is taken to be a suggestion, not an imperative." - (typecase form - (symbol (compiler-call #'compile-symbol :forward all)) - (cons (compiler-call #'compile-cons :forward all)) - (t (compiler-call #'compile-self-evaluating :forward all)))) + (compiler-values-bind (&all upstream) + (typecase form + (symbol (compiler-call #'compile-symbol :forward downstream)) + (cons (compiler-call #'compile-cons :forward downstream)) + (t (compiler-call #'compile-self-evaluating :forward downstream))) + (when (typep (upstream :final-form) 'lexical-binding) + (labels ((fix-extent (binding) + (cond + ((sub-env-p extent (binding-extent-env binding)) + #+ignore (warn "Binding ~S OK in ~S wrt. ~S." + binding + (binding-extent-env binding) + (downstream :env))) + (t #+ignore (break "Binding ~S escapes from ~S to ~S" + binding (binding-extent-env binding) + extent) + (setf (binding-extent-env binding) extent))) + (when (typep binding 'forwarding-binding) + (fix-extent (forwarding-binding-target binding))))) + (when extent + (fix-extent (upstream :final-form))))) + (compiler-values (upstream))))

(defun lambda-form-p (form) (and (listp form) @@ -6092,17 +6172,20 @@ (:jne ',push-values-loop) ,push-values-done)))

+(defun stack-add (x y) + (if (and (integerp x) (integerp y)) + (+ x y) + t)) + +(define-modify-macro stack-incf (&optional (delta 1)) stack-add) + (defun stack-delta (inner-env outer-env) "Calculate the amount of stack-space used (in 32-bit stack slots) at the time of <inner-env> since <outer-env>, the number of intervening dynamic-slots (special bindings, unwind-protects, and catch-tags), and a list of any intervening unwind-protect environment-slots." (labels - ((stack-distance-add (x y) - (if (and (integerp x) (integerp y)) - (+ x y) - t)) - (find-stack-delta (env stack-distance num-dynamic-slots unwind-protects) + ((find-stack-delta (env stack-distance num-dynamic-slots unwind-protects) #+ignore (warn "find-stack-delta: ~S dist ~S, slots ~S" env (stack-used env) (num-dynamic-slots env)) (cond @@ -6116,8 +6199,8 @@ ((null env) (values nil 0 nil)) (t (find-stack-delta (movitz-environment-uplink env) - (stack-distance-add stack-distance (stack-used env)) - (stack-distance-add num-dynamic-slots (num-dynamic-slots env)) + (stack-add stack-distance (stack-used env)) + (stack-add num-dynamic-slots (num-dynamic-slots env)) (if (typep env 'unwind-protect-env) (cons env unwind-protects) unwind-protects)))))) @@ -6334,6 +6417,8 @@ ((not (typep init-with-register 'binding)) (assert init-with-type) (values binding init-with-type) ) + ((and init-with-type (not (bindingp init-with-type))) + (values binding init-with-type)) (t (values binding t (lambda (x) x) (list init-with-register))))) @@ -6701,12 +6786,18 @@ (warn "Add for lend0: ~S" destination)) (let ((loc0 (new-binding-location (binding-target term0) frame-map :default nil)) (loc1 (new-binding-location (binding-target term1) frame-map :default nil))) -;;; (warn "add: ~A" instruction) + #+ignore + (warn "add: ~A for ~A" instruction result-type) #+ignore (warn "add for: ~S is ~A, from ~A/~A and ~A/~A." destination result-type term0 loc0 term1 loc1) + #+ignore + (when (eql loc0 loc1) + (warn "add for:~%~A/~A in ~S~&~A/~A in ~S." + term0 loc0 (binding-extent-env (binding-target term0)) + term1 loc1 (binding-extent-env (binding-target term1)))) (cond ((type-specifier-singleton result-type) ;; (break "constant add: ~S" instruction) @@ -6744,7 +6835,7 @@ ((and (movitz-subtypep type0 'fixnum) (movitz-subtypep type1 'fixnum) (movitz-subtypep result-type 'fixnum)) - ;; (warn "ADDX: ~S" instruction) + #+ignore (warn "ADDX: ~S" instruction) (cond ((and (type-specifier-singleton type0) (eq loc1 destination-location)) @@ -6752,10 +6843,14 @@ ((member destination-location '(:eax :ebx :ecx :edx)) `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0))) ,destination))) - (t (assert (integerp loc1)) - (break "check that this is correct..") - `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0))) - (:ebp ,(stack-frame-offset loc1))))))) + ((integerp loc1) + ;; (break "check that this is correct..") + `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0))) + (:ebp ,(stack-frame-offset loc1))))) + ((eq :argument-stack (operator loc1)) + `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0))) + (:ebp ,(argument-stack-offset (binding-target term1)))))) + (t (error "Don't know how to add this for loc1 ~S" loc1)))) ((and (type-specifier-singleton type0) (eq term1 destination) (integerp destination-location)) @@ -6768,41 +6863,44 @@ (append `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0))) ,loc1)) (make-store-lexical destination loc1 nil funobj frame-map))) - (t #+ignore (warn "ADD: ~A/~S = ~A/~S + ~A/~S,~%~A ~A" - destination-location - destination - loc0 term0 - loc1 term1 - (type-specifier-singleton type0) - (eq loc1 destination)) + ((and (integerp loc0) (integerp loc1) + (member destination-location '(:eax :ebx :ecx :edx))) + (append `((:movl (:ebp ,(stack-frame-offset loc0)) ,destination-location) + (:addl (:ebp ,(stack-frame-offset loc1)) ,destination-location)))) + (t (warn "ADD: ~A/~S = ~A/~S + ~A/~S" + destination-location + destination + loc0 term0 + loc1 term1) + #+ignore (warn "map: ~A" frame-map) ;;; (warn "ADDI: ~S" instruction) - (append (cond - ((type-specifier-singleton type0) - (append (make-load-lexical term1 :eax funobj nil frame-map) - (make-load-constant (car (type-specifier-singleton type0)) - :ebx funobj frame-map))) - ((type-specifier-singleton type1) - (append (make-load-lexical term0 :eax funobj nil frame-map) - (make-load-constant (car (type-specifier-singleton type1)) - :ebx funobj frame-map))) - ((and (eq :eax loc0) (eq :ebx loc1)) - nil) - ((and (eq :ebx loc0) (eq :eax loc1)) - nil) ; terms order isn't important - ((eq :eax loc1) - (append - (make-load-lexical term0 :ebx funobj nil frame-map))) - (t (append - (make-load-lexical term0 :eax funobj nil frame-map) - (make-load-lexical term1 :ebx funobj nil frame-map)))) - `((:movl (:edi ,(global-constant-offset '+)) :esi)) - (make-compiled-funcall-by-esi 2) - (etypecase destination - (symbol - (unless (eq destination :eax) - `((:movl :eax ,destination)))) - (binding - (make-store-lexical destination :eax nil funobj frame-map))))))) + (append (cond + ((type-specifier-singleton type0) + (append (make-load-lexical term1 :eax funobj nil frame-map) + (make-load-constant (car (type-specifier-singleton type0)) + :ebx funobj frame-map))) + ((type-specifier-singleton type1) + (append (make-load-lexical term0 :eax funobj nil frame-map) + (make-load-constant (car (type-specifier-singleton type1)) + :ebx funobj frame-map))) + ((and (eq :eax loc0) (eq :ebx loc1)) + nil) + ((and (eq :ebx loc0) (eq :eax loc1)) + nil) ; terms order isn't important + ((eq :eax loc1) + (append + (make-load-lexical term0 :ebx funobj nil frame-map))) + (t (append + (make-load-lexical term0 :eax funobj nil frame-map) + (make-load-lexical term1 :ebx funobj nil frame-map)))) + `((:movl (:edi ,(global-constant-offset '+)) :esi)) + (make-compiled-funcall-by-esi 2) + (etypecase destination + (symbol + (unless (eq destination :eax) + `((:movl :eax ,destination)))) + (binding + (make-store-lexical destination :eax nil funobj frame-map))))))) (t (append (cond ((type-specifier-singleton type0) (append (make-load-lexical term1 :eax funobj nil frame-map) @@ -6848,12 +6946,13 @@ (rotatef x y) (rotatef x-type y-type) (rotatef x-singleton y-singleton)) - (let (;; (x-loc (new-binding-location (binding-target x) frame-map :default nil)) + (let (#+ignore (x-loc (new-binding-location (binding-target x) frame-map :default nil)) (y-loc (new-binding-location (binding-target y) frame-map :default nil))) #+ignore - (warn "eql ~S/~S ~S/~S" - x x-loc - y y-loc) + (warn "eql ~S/~S xx~Xxx ~S/~S: ~S" + x x-loc (binding-target y) + y y-loc + instruction) (flet ((make-branch () (ecase (operator return-mode) (:boolean-branch-on-false