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

Modified Files: compiler.lisp Log Message: Various rearrangements. No code produced by the compiler should change due to these changes.

Date: Tue Feb 3 13:02:59 2004 Author: ffjeld

Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.8 movitz/compiler.lisp:1.9 --- movitz/compiler.lisp:1.8 Tue Feb 3 05:36:06 2004 +++ movitz/compiler.lisp Tue Feb 3 13:02:59 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.8 2004/02/03 10:36:06 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.9 2004/02/03 18:02:59 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------

@@ -207,22 +207,29 @@ (function-env (add-bindings-from-lambda-list lambda-list (make-local-movitz-environment funobj-env funobj - :type 'function-env - :declaration-context :funobj - :declarations declarations)))) + :type 'function-env + :declaration-context :funobj + :declarations declarations)))) (setf (movitz-funobj-name funobj) name (movitz-funobj-lambda-list funobj) (movitz-read (lambda-list-simplify lambda-list)) (funobj-env funobj) funobj-env (function-envs funobj) (list (cons 'muerte.cl::t function-env))) - (make-compiled-body-pass1 funobj function-env form top-level-p))) + (cond + #+ignore + ((and (= 1 (length (required-vars function-env))) + (= 1 (length (optional-vars function-env))) + (null (key-vars function-env)) + (null (rest-var function-env))) + (make-compiled-body-pass1-1req1opt funobj function-env form top-level-p)) + (t (make-compiled-body-pass1 funobj function-env form top-level-p)))))

(defun make-compiled-body-pass1 (funobj function-env form top-level-p) "Returns compiler-values, with the pass1 funobj as &final-form." - (multiple-value-bind (arg-init-code body-form need-normalized-ecx-p) - (make-function-arguments-init funobj function-env form) + (multiple-value-bind (arg-init-code need-normalized-ecx-p) + (make-function-arguments-init funobj function-env) (compiler-values-bind (&code body-code) (compiler-call #'compile-form - :form body-form + :form (make-special-funarg-shadowing function-env form) :funobj funobj :env function-env :top-level-p top-level-p @@ -475,6 +482,7 @@ (code3 (cdr (assoc 3 code-specs))) (codet (cdr (assoc 'muerte.cl::t code-specs)))) (assert codet () "A default numargs-case is required.") + ;; (format t "codet:~{~&~A~}" codet) (let ((combined-code (delete 'start-stack-frame-setup (append @@ -499,67 +507,74 @@ '(entry%3op (:movb 3 :cl))) ,@code3 not-three-args)) - codet)))) + (delete-if (lambda (x) + (or (and code1 (eq x 'entry%1op)) + (and code2 (eq x 'entry%2op)) + (and code3 (eq x 'entry%3op)))) + codet))))) ;; (warn "opt code: ~{~&~A~}" optimized-function-code) - (multiple-value-bind (code-vector code-symtab) - (ia-x86:proglist-encode :octet-vector :32-bit #x00000000 - (ia-x86:read-proglist (append combined-code - `((% bytes 8 0 0 0)))) - :symtab-lookup - (lambda (label) - (case label - (:nil-value (image-nil-word *image*)) - (t (let ((set (cdr (assoc label - (movitz-funobj-jumpers-map funobj))))) - (when set - (let ((pos (search set (movitz-funobj-const-list funobj) - :end2 (movitz-funobj-num-jumpers funobj)))) - (assert pos () - "Couldn't find for ~s set ~S in ~S." - label set (subseq (movitz-funobj-const-list funobj) - 0 (movitz-funobj-num-jumpers funobj))) - (* 4 pos)))))))) - (setf (movitz-funobj-symtab funobj) code-symtab) - (let ((code-length (- (length code-vector) 3))) - (assert (not (mismatch #(0 0 0) code-vector :start2 code-length)) () - "No space in code-vector was allocated for entry-points.") - (setf (fill-pointer code-vector) code-length) - ;; debug info - (setf (ldb (byte 1 5) (slot-value funobj 'debug-info)) - 1 #+ignore (if use-stack-frame-p 1 0)) - (let ((x (cdr (assoc 'start-stack-frame-setup code-symtab)))) - (cond - ((not x) - #+ignore (warn "No start-stack-frame-setup label for ~S." name)) - ((<= 0 x 30) - (setf (ldb (byte 5 0) (slot-value funobj 'debug-info)) x)) - (t (warn "Can't encode start-stack-frame-setup label ~D into debug-info for ~S." - x (movitz-funobj-name funobj))))) - (loop for ((entry-label slot-name) . rest) on '((entry%1op code-vector%1op) - (entry%2op code-vector%2op) - (entry%3op code-vector%3op)) - do (cond - ((assoc entry-label code-symtab) - (let ((offset (cdr (assoc entry-label code-symtab)))) - (setf (slot-value funobj slot-name) - (cons offset funobj)) - (vector-push offset code-vector))) - ((some (lambda (label) (assoc label code-symtab)) - (mapcar #'car rest)) - (vector-push 0 code-vector)))) - (setf (movitz-funobj-code-vector funobj) - (make-movitz-vector (length code-vector) - :fill-pointer code-length - :element-type 'movitz-code - :initial-contents code-vector - :flags '(:code-vector-p) - :alignment 16 - :alignment-offset 8))))))) + (assemble-funobj funobj combined-code)))) (loop for (sub-function-binding) on (sub-function-binding-usage funobj) by #'cddr do (complete-funobj (function-binding-funobj sub-function-binding))) funobj)

+(defun assemble-funobj (funobj combined-code) + (multiple-value-bind (code-vector code-symtab) + (ia-x86:proglist-encode :octet-vector :32-bit #x00000000 + (ia-x86:read-proglist (append combined-code + `((% bytes 8 0 0 0)))) + :symtab-lookup + (lambda (label) + (case label + (:nil-value (image-nil-word *image*)) + (t (let ((set (cdr (assoc label + (movitz-funobj-jumpers-map funobj))))) + (when set + (let ((pos (search set (movitz-funobj-const-list funobj) + :end2 (movitz-funobj-num-jumpers funobj)))) + (assert pos () + "Couldn't find for ~s set ~S in ~S." + label set (subseq (movitz-funobj-const-list funobj) + 0 (movitz-funobj-num-jumpers funobj))) + (* 4 pos)))))))) + (setf (movitz-funobj-symtab funobj) code-symtab) + (let ((code-length (- (length code-vector) 3))) + (assert (not (mismatch #(0 0 0) code-vector :start2 code-length)) () + "No space in code-vector was allocated for entry-points.") + (setf (fill-pointer code-vector) code-length) + ;; debug info + (setf (ldb (byte 1 5) (slot-value funobj 'debug-info)) + 1 #+ignore (if use-stack-frame-p 1 0)) + (let ((x (cdr (assoc 'start-stack-frame-setup code-symtab)))) + (cond + ((not x) + #+ignore (warn "No start-stack-frame-setup label for ~S." name)) + ((<= 0 x 30) + (setf (ldb (byte 5 0) (slot-value funobj 'debug-info)) x)) + (t (warn "Can't encode start-stack-frame-setup label ~D into debug-info for ~S." + x (movitz-funobj-name funobj))))) + (loop for ((entry-label slot-name) . rest) on '((entry%1op code-vector%1op) + (entry%2op code-vector%2op) + (entry%3op code-vector%3op)) + do (cond + ((assoc entry-label code-symtab) + (let ((offset (cdr (assoc entry-label code-symtab)))) + (setf (slot-value funobj slot-name) + (cons offset funobj)) + (vector-push offset code-vector))) + ((some (lambda (label) (assoc label code-symtab)) + (mapcar #'car rest)) + (vector-push 0 code-vector)))) + (setf (movitz-funobj-code-vector funobj) + (make-movitz-vector (length code-vector) + :fill-pointer code-length + :element-type 'movitz-code + :initial-contents code-vector + :flags '(:code-vector-p) + :alignment 16 + :alignment-offset 8))))) + #+ignore (defun make-compiled-function-body-default (form funobj env top-level-p) (make-compiled-body-pass2 (make-compiled-function-pass1 form funobj env top-level-p) @@ -915,6 +930,7 @@ :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 () @@ -3358,12 +3374,12 @@ `(:cmpb ,arg-count :cl)) (t `(:cmpl ,(dpb arg-count (byte 24 8) #x80) :ecx)))))))

-(defun make-function-arguments-init (funobj env function-body) +(defun make-function-arguments-init (funobj env) "The arugments-init is compiled before the function's body is. -Return arg-init-code, new function-body, need-normalized-ecx-p." +Return arg-init-code, need-normalized-ecx-p." (when (without-function-prelude-p env) (return-from make-function-arguments-init - (values nil function-body nil))) + (values nil nil))) (let ((need-normalized-ecx-p nil) (required-vars (required-vars env)) (optional-vars (optional-vars env)) @@ -3455,47 +3471,47 @@ ,not-present-label)) (t #+ignore (when (= 0 (function-argument-argnum binding)) (setf eax-optional-destructive-p t)) - `((:arg-cmp ,(function-argument-argnum binding)) - (:jbe ',not-present-label) - ,@(when supplied-p-var - `((:movl (:edi ,(global-constant-offset 't-symbol)) :eax) - (:store-lexical ,supplied-p-binding :eax - :type (eql ,(image-t-symbol *image*))))) - ,@(case (function-argument-argnum binding) - (0 `((:store-lexical ,binding :eax :type t))) - (1 `((:store-lexical ,binding :ebx :type t))) - (t (cond - (last-optional-p - `((:movl (:ebp ,(* 4 (- (1+ (function-argument-argnum binding)) - -1 (function-argument-argnum binding)))) - :eax) - (:store-lexical ,binding :eax :type t))) - (t (setq need-normalized-ecx-p t) - `((:movl (:ebp (:ecx 4) ,(* -4 (1- (function-argument-argnum binding)))) - :eax) - (:store-lexical ,binding :eax :type t)))))) - (:jmp ',optional-ok-label) - ,not-present-label - ,@(when supplied-p-var - `((:store-lexical ,supplied-p-binding :edi :type null))) - ,@(when (and (= 0 (function-argument-argnum binding)) - (not last-optional-p)) - `((:pushl :ebx))) ; protect ebx - ,@(if (optional-function-argument-init-form binding) - (append '((:pushl :ecx)) - (when (= 0 (function-argument-argnum binding)) - `((:pushl :ebx))) - init-code-edx - `((:store-lexical ,binding :edx :type t)) - (when (= 0 (function-argument-argnum binding)) - `((:popl :ebx))) - `((:popl :ecx))) - (progn (error "WEgewgew") - `((:store-lexical ,binding :edi :type null)))) - ,@(when (and (= 0 (function-argument-argnum binding)) - (not last-optional-p)) - `((:popl :ebx))) ; protect ebx - ,optional-ok-label))))) + `((:arg-cmp ,(function-argument-argnum binding)) + (:jbe ',not-present-label) + ,@(when supplied-p-var + `((:movl (:edi ,(global-constant-offset 't-symbol)) :eax) + (:store-lexical ,supplied-p-binding :eax + :type (eql ,(image-t-symbol *image*))))) + ,@(case (function-argument-argnum binding) + (0 `((:store-lexical ,binding :eax :type t))) + (1 `((:store-lexical ,binding :ebx :type t))) + (t (cond + (last-optional-p + `((:movl (:ebp ,(* 4 (- (1+ (function-argument-argnum binding)) + -1 (function-argument-argnum binding)))) + :eax) + (:store-lexical ,binding :eax :type t))) + (t (setq need-normalized-ecx-p t) + `((:movl (:ebp (:ecx 4) ,(* -4 (1- (function-argument-argnum binding)))) + :eax) + (:store-lexical ,binding :eax :type t)))))) + (:jmp ',optional-ok-label) + ,not-present-label + ,@(when supplied-p-var + `((:store-lexical ,supplied-p-binding :edi :type null))) + ,@(when (and (= 0 (function-argument-argnum binding)) + (not last-optional-p)) + `((:pushl :ebx))) ; protect ebx + ,@(if (optional-function-argument-init-form binding) + (append '((:pushl :ecx)) + (when (= 0 (function-argument-argnum binding)) + `((:pushl :ebx))) + init-code-edx + `((:store-lexical ,binding :edx :type t)) + (when (= 0 (function-argument-argnum binding)) + `((:popl :ebx))) + `((:popl :ecx))) + (progn (error "WEgewgew") + `((:store-lexical ,binding :edi :type null)))) + ,@(when (and (= 0 (function-argument-argnum binding)) + (not last-optional-p)) + `((:popl :ebx))) ; protect ebx + ,optional-ok-label))))) (when rest-var (let* ((rest-binding (movitz-binding rest-var env)) (rest-position (function-argument-argnum rest-binding))) @@ -3649,11 +3665,16 @@ `((:init-lexvar ,binding :init-with-register :eax :init-with-type t))))))) - ;; shadowing variables.. - (if (special-variable-shadows env) - `(muerte.cl::let ,(special-variable-shadows env) ,function-body) - function-body) need-normalized-ecx-p))) + +(defun make-special-funarg-shadowing (env function-body) + "" + (cond + ((without-function-prelude-p env) + function-body) + ((special-variable-shadows env) + `(muerte.cl::let ,(special-variable-shadows env) ,function-body)) + (t function-body)))

(defun make-compiled-function-postlude (funobj env use-stack-frame-p) (declare (ignore funobj env))