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

Modified Files: compiler.lisp Log Message: Improved compilation of dynamic-extent &rest arguments a bit. Especially functions with unused &rest parameters should be improved.

Date: Fri Apr 23 10:58:53 2004 Author: ffjeld

Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.58 movitz/compiler.lisp:1.59 --- movitz/compiler.lisp:1.58 Wed Apr 21 11:06:16 2004 +++ movitz/compiler.lisp Fri Apr 23 10:58:52 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.58 2004/04/21 15:06:16 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.59 2004/04/23 14:58:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------

@@ -989,166 +989,163 @@ 1)) (t (error "make-2req confused by loc0: ~W, loc1: ~W" location-0 location-1)))))

-#+ignore -(defun make-compiled-function-body-1rest (form funobj env top-level-p) - (when (and (null (required-vars env)) - (null (optional-vars env)) - (null (key-vars env)) - (rest-var env)) - (multiple-value-bind (code stack-frame-size use-stack-frame-p frame-map) - (make-compiled-body form funobj env top-level-p) - (let* ((rest-binding (movitz-binding (rest-var env) env nil)) - (edx-location (and (edx-var env) - (new-binding-location (edx-var env) frame-map - :default nil))) - (edx-code (when edx-location - `((:movl :edx (:ebp ,(stack-frame-offset edx-location))))))) - (cond - ((not (new-binding-located-p rest-binding frame-map)) - (append '(entry%1op - entry%2op - entry%3op) - (when use-stack-frame-p - +enter-stack-frame-code+) - '(start-stack-frame-setup) - (make-compiled-stack-frame-init stack-frame-size) - edx-code - code - (make-compiled-function-postlude funobj env use-stack-frame-p))) - (t ;; (new-binding-located-p rest-binding frame-map) - (let ((rest-location (new-binding-location rest-binding frame-map))) - (values (append +enter-stack-frame-code+ - '(start-stack-frame-setup) - (make-compiled-stack-frame-init stack-frame-size) - `((:movl :edi (:ebp ,(stack-frame-offset rest-location)))) - edx-code - `((:testb :cl :cl) - (:jz 'end-stack-frame-setup) - (:js '(:sub-program (normalize-ecx) - (:shrl 8 :ecx) - (:jmp 'ecx-ok))) - (:andl #x7f :ecx) - ecx-ok - (:xorl :edx :edx) - (:call (:edi ,(global-constant-offset 'restify-dynamic-extent))) - (:movl :eax (:ebp ,(stack-frame-offset rest-location))) - (:jmp 'end-stack-frame-setup)) - `(entry%1op - ,@+enter-stack-frame-code+ - ,@(make-compiled-stack-frame-init stack-frame-size) - ,@edx-code - (:andl -8 :esp) - (:pushl :edi) - (:pushl :eax) - (:leal (:esp 1) :ecx) - (:movl :ecx (:ebp ,(stack-frame-offset rest-location))) - (:jmp 'end-stack-frame-setup)) - `(entry%2op - ,@+enter-stack-frame-code+ - ,@(make-compiled-stack-frame-init stack-frame-size) - ,@edx-code - (:andl -8 :esp) - (:pushl :edi) - (:pushl :ebx) - (:leal (:esp 1) :ecx) - (:pushl :ecx) - (:pushl :eax) - (:leal (:esp 1) :ecx) - (:movl :ecx (:ebp ,(stack-frame-offset rest-location))) - (:jmp 'end-stack-frame-setup)) - '(end-stack-frame-setup) - code - (make-compiled-function-postlude funobj env t)) - use-stack-frame-p)))))))) +;;;(defun make-compiled-function-body-1rest (form funobj env top-level-p) +;;; (when (and (null (required-vars env)) +;;; (null (optional-vars env)) +;;; (null (key-vars env)) +;;; (rest-var env)) +;;; (multiple-value-bind (code stack-frame-size use-stack-frame-p frame-map) +;;; (make-compiled-body form funobj env top-level-p) +;;; (let* ((rest-binding (movitz-binding (rest-var env) env nil)) +;;; (edx-location (and (edx-var env) +;;; (new-binding-location (edx-var env) frame-map +;;; :default nil))) +;;; (edx-code (when edx-location +;;; `((:movl :edx (:ebp ,(stack-frame-offset edx-location))))))) +;;; (cond +;;; ((not (new-binding-located-p rest-binding frame-map)) +;;; (append '(entry%1op +;;; entry%2op +;;; entry%3op) +;;; (when use-stack-frame-p +;;; +enter-stack-frame-code+) +;;; '(start-stack-frame-setup) +;;; (make-compiled-stack-frame-init stack-frame-size) +;;; edx-code +;;; code +;;; (make-compiled-function-postlude funobj env use-stack-frame-p))) +;;; (t ;; (new-binding-located-p rest-binding frame-map) +;;; (let ((rest-location (new-binding-location rest-binding frame-map))) +;;; (values (append +enter-stack-frame-code+ +;;; '(start-stack-frame-setup) +;;; (make-compiled-stack-frame-init stack-frame-size) +;;; `((:movl :edi (:ebp ,(stack-frame-offset rest-location)))) +;;; edx-code +;;; `((:testb :cl :cl) +;;; (:jz 'end-stack-frame-setup) +;;; (:js '(:sub-program (normalize-ecx) +;;; (:shrl 8 :ecx) +;;; (:jmp 'ecx-ok))) +;;; (:andl #x7f :ecx) +;;; ecx-ok +;;; (:xorl :edx :edx) +;;; (:call (:edi ,(global-constant-offset 'restify-dynamic-extent))) +;;; (:movl :eax (:ebp ,(stack-frame-offset rest-location))) +;;; (:jmp 'end-stack-frame-setup)) +;;; `(entry%1op +;;; ,@+enter-stack-frame-code+ +;;; ,@(make-compiled-stack-frame-init stack-frame-size) +;;; ,@edx-code +;;; (:andl -8 :esp) +;;; (:pushl :edi) +;;; (:pushl :eax) +;;; (:leal (:esp 1) :ecx) +;;; (:movl :ecx (:ebp ,(stack-frame-offset rest-location))) +;;; (:jmp 'end-stack-frame-setup)) +;;; `(entry%2op +;;; ,@+enter-stack-frame-code+ +;;; ,@(make-compiled-stack-frame-init stack-frame-size) +;;; ,@edx-code +;;; (:andl -8 :esp) +;;; (:pushl :edi) +;;; (:pushl :ebx) +;;; (:leal (:esp 1) :ecx) +;;; (:pushl :ecx) +;;; (:pushl :eax) +;;; (:leal (:esp 1) :ecx) +;;; (:movl :ecx (:ebp ,(stack-frame-offset rest-location))) +;;; (:jmp 'end-stack-frame-setup)) +;;; '(end-stack-frame-setup) +;;; code +;;; (make-compiled-function-postlude funobj env t)) +;;; use-stack-frame-p)))))))) - -#+ignore -(defun make-compiled-function-body-1req-1opt (form funobj env top-level-p) - (when (and (= 1 (length (required-vars env))) - (= 1 (length (optional-vars env))) - (= 0 (length (key-vars env))) - (null (rest-var env))) - (let* ((opt-var (first (optional-vars env))) - (opt-binding (movitz-binding opt-var env nil)) - (req-binding (movitz-binding (first (required-vars env)) env nil)) - (default-form (optional-function-argument-init-form opt-binding))) - (compiler-values-bind (&code opt-default-code &producer opt-default-producer) - (compiler-call #'compile-form - :form default-form - :result-mode :push - :env env - :funobj funobj) - (cond - ((eq 'compile-self-evaluating opt-default-producer) - (multiple-value-bind (code stack-frame-size use-stack-frame-p frame-map) - (make-compiled-body form funobj env top-level-p nil (list opt-default-code)) - (declare (ignore use-stack-frame-p)) - (let ((use-stack-frame-p t)) - (cond - ((and (new-binding-located-p req-binding frame-map) - (new-binding-located-p opt-binding frame-map)) - (multiple-value-bind (eax-ebx-code eax-ebx-stack-offset) - (ecase (new-binding-location req-binding frame-map) - ;; might well be more cases here, but let's wait till they show up.. - (:eax (values nil 0)) - (1 (values '((:pushl :eax)) 1))) - ;; (warn "defc: ~S" opt-default-code) - (let ((stack-init-size (- stack-frame-size eax-ebx-stack-offset)) - (installed-default-code (finalize-code opt-default-code funobj env frame-map))) - (values (append `((:call (:edi ,(global-constant-offset 'decode-args-1or2))) - entry%2op - (:pushl :ebp) - (:movl :esp :ebp) - (:pushl :esi) - start-stack-frame-setup - ,@eax-ebx-code - ,@(if (eql (1+ eax-ebx-stack-offset) - (new-binding-location opt-binding frame-map)) - (append `((:pushl :ebx)) - (make-compiled-stack-frame-init (1- stack-init-size))) - (append (make-compiled-stack-frame-init stack-init-size) - `((:movl :ebx (:ebp ,(stack-frame-offset - (new-binding-location opt-binding - frame-map))))))) - (:jmp 'arg-init-done) - entry%1op - (:pushl :ebp) - (:movl :esp :ebp) - (:pushl :esi) - ,@eax-ebx-code - ,@(if (eql (1+ eax-ebx-stack-offset) - (new-binding-location opt-binding frame-map)) - (append installed-default-code - (make-compiled-stack-frame-init (1- stack-init-size))) - (append (make-compiled-stack-frame-init stack-init-size) - installed-default-code - `((:popl (:ebp ,(stack-frame-offset - (new-binding-location opt-binding - frame-map))))))) - arg-init-done) - code - (make-compiled-function-postlude funobj env t)) - use-stack-frame-p)))) - ((and (new-binding-located-p req-binding frame-map) - (not (new-binding-located-p opt-binding frame-map))) - (multiple-value-bind (eax-code eax-stack-offset) - (ecase (new-binding-location req-binding frame-map) - (:eax (values nil 0)) - (1 (values '((:pushl :eax)) 1))) - (values (append `((:call (:edi ,(global-constant-offset 'decode-args-1or2))) - ;; (:jmp 'decode-numargs) - entry%1op - entry%2op - (:pushl :ebp) - (:movl :esp :ebp) - (:pushl :esi)) - eax-code - (make-compiled-stack-frame-init (- stack-frame-size eax-stack-offset)) - code - (make-compiled-function-postlude funobj env t)) - use-stack-frame-p))) - (t (warn "1-req-1-opt failed")))))) - (t nil)))))) +;;;(defun make-compiled-function-body-1req-1opt (form funobj env top-level-p) +;;; (when (and (= 1 (length (required-vars env))) +;;; (= 1 (length (optional-vars env))) +;;; (= 0 (length (key-vars env))) +;;; (null (rest-var env))) +;;; (let* ((opt-var (first (optional-vars env))) +;;; (opt-binding (movitz-binding opt-var env nil)) +;;; (req-binding (movitz-binding (first (required-vars env)) env nil)) +;;; (default-form (optional-function-argument-init-form opt-binding))) +;;; (compiler-values-bind (&code opt-default-code &producer opt-default-producer) +;;; (compiler-call #'compile-form +;;; :form default-form +;;; :result-mode :push +;;; :env env +;;; :funobj funobj) +;;; (cond +;;; ((eq 'compile-self-evaluating opt-default-producer) +;;; (multiple-value-bind (code stack-frame-size use-stack-frame-p frame-map) +;;; (make-compiled-body form funobj env top-level-p nil (list opt-default-code)) +;;; (declare (ignore use-stack-frame-p)) +;;; (let ((use-stack-frame-p t)) +;;; (cond +;;; ((and (new-binding-located-p req-binding frame-map) +;;; (new-binding-located-p opt-binding frame-map)) +;;; (multiple-value-bind (eax-ebx-code eax-ebx-stack-offset) +;;; (ecase (new-binding-location req-binding frame-map) +;;; ;; might well be more cases here, but let's wait till they show up.. +;;; (:eax (values nil 0)) +;;; (1 (values '((:pushl :eax)) 1))) +;;; ;; (warn "defc: ~S" opt-default-code) +;;; (let ((stack-init-size (- stack-frame-size eax-ebx-stack-offset)) +;;; (installed-default-code (finalize-code opt-default-code funobj env frame-map))) +;;; (values (append `((:call (:edi ,(global-constant-offset 'decode-args-1or2))) +;;; entry%2op +;;; (:pushl :ebp) +;;; (:movl :esp :ebp) +;;; (:pushl :esi) +;;; start-stack-frame-setup +;;; ,@eax-ebx-code +;;; ,@(if (eql (1+ eax-ebx-stack-offset) +;;; (new-binding-location opt-binding frame-map)) +;;; (append `((:pushl :ebx)) +;;; (make-compiled-stack-frame-init (1- stack-init-size))) +;;; (append (make-compiled-stack-frame-init stack-init-size) +;;; `((:movl :ebx (:ebp ,(stack-frame-offset +;;; (new-binding-location opt-binding +;;; frame-map))))))) +;;; (:jmp 'arg-init-done) +;;; entry%1op +;;; (:pushl :ebp) +;;; (:movl :esp :ebp) +;;; (:pushl :esi) +;;; ,@eax-ebx-code +;;; ,@(if (eql (1+ eax-ebx-stack-offset) +;;; (new-binding-location opt-binding frame-map)) +;;; (append installed-default-code +;;; (make-compiled-stack-frame-init (1- stack-init-size))) +;;; (append (make-compiled-stack-frame-init stack-init-size) +;;; installed-default-code +;;; `((:popl (:ebp ,(stack-frame-offset +;;; (new-binding-location opt-binding +;;; frame-map))))))) +;;; arg-init-done) +;;; code +;;; (make-compiled-function-postlude funobj env t)) +;;; use-stack-frame-p)))) +;;; ((and (new-binding-located-p req-binding frame-map) +;;; (not (new-binding-located-p opt-binding frame-map))) +;;; (multiple-value-bind (eax-code eax-stack-offset) +;;; (ecase (new-binding-location req-binding frame-map) +;;; (:eax (values nil 0)) +;;; (1 (values '((:pushl :eax)) 1))) +;;; (values (append `((:call (:edi ,(global-constant-offset 'decode-args-1or2))) +;;; ;; (:jmp 'decode-numargs) +;;; entry%1op +;;; entry%2op +;;; (:pushl :ebp) +;;; (:movl :esp :ebp) +;;; (:pushl :esi)) +;;; eax-code +;;; (make-compiled-stack-frame-init (- stack-frame-size eax-stack-offset)) +;;; code +;;; (make-compiled-function-postlude funobj env t)) +;;; use-stack-frame-p))) +;;; (t (warn "1-req-1-opt failed")))))) +;;; (t nil))))))

(defun make-compiled-stack-frame-init (stack-frame-init) @@ -4218,14 +4215,15 @@ (when rest-var (let* ((rest-binding (movitz-binding rest-var env)) (rest-position (function-argument-argnum rest-binding))) + #+ignore (assert (or (typep rest-binding 'hidden-rest-function-argument) - (movitz-env-get rest-var 'dynamic-extent nil env) - (movitz-env-get rest-var 'ignore nil env)) + (movitz-env-get rest-var 'dynamic-extent nil env)) () "&REST variable ~S must be dynamic-extent." rest-var) - (setq need-normalized-ecx-p t) - (append (make-immediate-move rest-position :edx) - `((:call (:edi ,(global-constant-offset 'restify-dynamic-extent))) + ;; (setq need-normalized-ecx-p t) + (append #+ignore (make-immediate-move rest-position :edx) + `(#+ignore + (:call (:edi ,(global-constant-offset 'restify-dynamic-extent))) (:init-lexvar ,rest-binding :init-with-register :eax :init-with-type list))))) @@ -5755,27 +5753,53 @@ (declare (ignore protect-carry)) ; nothing modifies carry anyway. (assert (eq binding (ensure-local-binding binding funobj))) (cond - ((binding-lended-p binding) - (let ((cons-position (getf (binding-lended-p binding) - :stack-cons-location)) - (tmp-register (find-if (lambda (r) - (and (not (member r protect-registers)) - (not (eq r init-with-register)))) - '(:edx :ecx :ebx :eax))) - (init-register (or init-with-register :edi))) - (when init-with-register - (assert (not (null init-with-type)))) - (assert tmp-register () ; solve this with push eax .. pop eax if ever needed. - "Unable to find a tmp-register for ~S." instruction) - `((:leal (:ebp ,(1+ (stack-frame-offset (1+ cons-position)))) - ,tmp-register) - (:movl :edi (,tmp-register 3)) ; cdr - (:movl ,init-register (,tmp-register -1)) ; car - (:movl ,tmp-register - (:ebp ,(stack-frame-offset - (new-binding-location binding frame-map))))))) - (init-with-register - (make-store-lexical binding init-with-register nil frame-map))))) + ((not (new-binding-located-p binding frame-map)) + (unless (or (movitz-env-get (binding-name binding) 'ignore nil (binding-env binding)) + (movitz-env-get (binding-name binding) 'ignorable nil (binding-env binding))) + (warn "Unused variable: ~S." (binding-name binding)))) + (t (when (movitz-env-get (binding-name binding) 'ignore nil (binding-env binding)) + (warn "Variable ~S used while declared ignored." (binding-name binding))) + (append + (cond + ((typep binding 'rest-function-argument) + (assert (eq :eax init-with-register)) + (assert (or (typep binding 'hidden-rest-function-argument) + (movitz-env-get (binding-name binding) + 'dynamic-extent nil (binding-env binding))) + () + "&REST variable ~S must be dynamic-extent." (binding-name binding)) + (setf (need-normalized-ecx-p (find-function-env (binding-env binding) + funobj)) + t) + (append (make-immediate-move (function-argument-argnum binding) :edx) + `((:call (:edi ,(global-constant-offset 'restify-dynamic-extent)))) + #+ignore + (unless (or (typep binding 'hidden-rest-function-argument) + (movitz-env-get (binding-name binding) + 'dynamic-extent nil (binding-env binding))) + (make-compiled-funcall-by-symbol 'muerte.cl:copy-list 1 funobj))))) + (cond + ((binding-lended-p binding) + (let ((cons-position (getf (binding-lended-p binding) + :stack-cons-location)) + (tmp-register (find-if (lambda (r) + (and (not (member r protect-registers)) + (not (eq r init-with-register)))) + '(:edx :ecx :ebx :eax))) + (init-register (or init-with-register :edi))) + (when init-with-register + (assert (not (null init-with-type)))) + (assert tmp-register () ; solve this with push eax .. pop eax if ever needed. + "Unable to find a tmp-register for ~S." instruction) + `((:leal (:ebp ,(1+ (stack-frame-offset (1+ cons-position)))) + ,tmp-register) + (:movl :edi (,tmp-register 3)) ; cdr + (:movl ,init-register (,tmp-register -1)) ; car + (:movl ,tmp-register + (:ebp ,(stack-frame-offset + (new-binding-location binding frame-map))))))) + (init-with-register + (make-store-lexical binding init-with-register nil frame-map))))))))

;;;;;;;;;;;;;;;;;; car