[movitz-cvs] CVS update: movitz/compiler.lisp
Frode Vatvedt Fjeld
ffjeld at common-lisp.net
Wed Aug 18 22:30:55 UTC 2004
Update of /project/movitz/cvsroot/movitz
In directory common-lisp.net:/tmp/cvs-serv31712
Modified Files:
compiler.lisp
Log Message:
Two things: No more barf on unused local functions (flets or labels),
just emit a warning. Also, fix initialization of lended &optionals.
Date: Wed Aug 18 15:30:52 2004
Author: ffjeld
Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.95 movitz/compiler.lisp:1.96
--- movitz/compiler.lisp:1.95 Mon Aug 16 01:24:56 2004
+++ movitz/compiler.lisp Wed Aug 18 15:30:51 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.95 2004/08/16 08:24:56 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.96 2004/08/18 22:30:51 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -653,6 +653,8 @@
(cond
((or (null usage)
(null (borrowed-bindings sub-funobj)))
+ (when (null usage)
+ (warn "null usage for ~S" sub-funobj))
(change-class function-binding 'funobj-binding)
(setf (movitz-funobj-extent sub-funobj)
:indefinite-extent))
@@ -2555,9 +2557,10 @@
((:local-function-init :load-lambda)
(let* ((binding (second instruction))
(funobj (function-binding-funobj binding)))
- (incf (getf constants funobj 0))
- (dolist (binding (borrowed-bindings funobj))
- (process-binding binding))))
+ (unless (eq :unused (movitz-funobj-extent funobj))
+ (incf (getf constants funobj 0))
+ (dolist (binding (borrowed-bindings funobj))
+ (process-binding binding)))))
((:load-lexical :lend-lexical :call-lexical)
(process-binding (second instruction)))
(:load-constant
@@ -3621,26 +3624,34 @@
(:local-function-init
(destructuring-bind (function-binding)
(operands instruction)
- #+ignore (warn "local-function-init: init ~S at ~S"
- function-binding
- (new-binding-location function-binding frame-map))
+ #+ignore
+ (warn "local-function-init: init ~S at ~S"
+ function-binding
+ (new-binding-location function-binding frame-map))
(finalize-code
- (let* ((sub-funobj (function-binding-funobj function-binding))
- (lend-code (loop for bb in (borrowed-bindings sub-funobj)
- append (make-lend-lexical bb :edx nil))))
+ (let* ((sub-funobj (function-binding-funobj function-binding)))
(cond
+ ((eq (movitz-funobj-extent sub-funobj) :unused)
+ (unless (or (movitz-env-get (binding-name function-binding)
+ 'ignore nil
+ (binding-env function-binding) nil)
+ (movitz-env-get (binding-name function-binding)
+ 'ignorable nil
+ (binding-env function-binding) nil))
+ (warn "Unused local function: ~S"
+ (binding-name function-binding)))
+ nil)
((typep function-binding 'funobj-binding)
nil)
- ((null lend-code)
- (warn "null lending")
- (append (make-load-constant sub-funobj :eax funobj frame-map)
- (make-store-lexical function-binding :eax nil frame-map)))
- (t (append (make-load-constant sub-funobj :eax funobj frame-map)
+ (t (when (null (borrowed-bindings sub-funobj))
+ (warn "null lending for ~S" sub-funobj))
+ (append (make-load-constant sub-funobj :eax funobj frame-map)
`((:movl (:edi ,(global-constant-offset 'copy-funobj)) :esi)
(:call (:esi ,(bt:slot-offset 'movitz-funobj 'code-vector%1op)))
(:movl :eax :edx))
(make-store-lexical function-binding :eax nil frame-map)
- lend-code))))
+ (loop for bb in (borrowed-bindings sub-funobj)
+ append (make-lend-lexical bb :edx nil))))))
funobj frame-map)))
(:load-lambda
(destructuring-bind (function-binding register)
@@ -4284,9 +4295,14 @@
(function-argument-argnum binding)))
and optional-ok-label = (make-symbol (format nil "optional-~D-ok"
(function-argument-argnum binding)))
- unless (movitz-env-get optional-var 'ignore nil env nil)
+ unless (movitz-env-get optional-var 'ignore nil env nil) ; XXX
append
- `((:init-lexvar ,binding))
+ (cond
+ ((= 0 (function-argument-argnum binding))
+ `((:init-lexvar ,binding :init-with-register :eax :init-with-type t)))
+ ((= 1 (function-argument-argnum binding))
+ `((:init-lexvar ,binding :init-with-register :ebx :init-with-type t)))
+ (t `((:init-lexvar ,binding))))
when supplied-p-binding
append `((:init-lexvar ,supplied-p-binding))
append
@@ -4297,33 +4313,24 @@
:env env
:result-mode :edx)
(cond
- #+ignore
((and (eq 'compile-self-evaluating producer)
- (= 0 (function-argument-argnum binding))
- (not supplied-p-var))
- (append `((:store-lexical ,binding :eax)
- (:arg-cmp 1)
- (:jge ',optional-ok-label))
- (compiler-call #'compile-form
- :form (optional-function-argument-init-form binding)
- :funobj funobj
- :env env
- :result-mode binding)
- (list optional-ok-label)))
- #+ignore
- ((and (eq 'compile-self-evaluating producer)
- (= 1 (function-argument-argnum binding))
- (not eax-optional-destructive-p)
- (not supplied-p-var))
- (append `((:store-lexical ,binding :ebx)
- (:arg-cmp 2)
- (:jge ',optional-ok-label))
- (compiler-call #'compile-form
- :form (optional-function-argument-init-form binding)
- :funobj funobj
- :env env
- :result-mode binding)
- (list optional-ok-label)))
+ (member (function-argument-argnum binding) '(0 1)))
+ ;; The binding is already preset with EAX or EBX.
+ (check-type binding lexical-binding)
+ (append
+ (when supplied-p-var
+ `((:load-constant ,(movitz-read t) :edx)
+ (:store-lexical ,supplied-p-binding :edx :type (member t))))
+ `((:arg-cmp ,(function-argument-argnum binding))
+ (:ja ',optional-ok-label))
+ (compiler-call #'compile-form
+ :form (optional-function-argument-init-form binding)
+ :funobj funobj
+ :env env
+ :result-mode binding)
+ (when supplied-p-var
+ `((:store-lexical ,supplied-p-binding :edi :type null)))
+ `(,optional-ok-label)))
((eq 'compile-self-evaluating producer)
`(,@(when supplied-p-var
`((:store-lexical ,supplied-p-binding :edi :type null)))
@@ -4342,7 +4349,8 @@
:eax)
(:store-lexical ,binding :eax :type t)))
(t (setq need-normalized-ecx-p t)
- `((:movl (:ebp (:ecx 4) ,(* -4 (1- (function-argument-argnum binding))))
+ `((:movl (:ebp (:ecx 4)
+ ,(* -4 (1- (function-argument-argnum binding))))
:eax)
(:store-lexical ,binding :eax :type t))))))
,@(when supplied-p-var
@@ -4350,49 +4358,48 @@
(:store-lexical ,supplied-p-binding :eax
:type (eql ,(image-t-symbol *image*)))))
,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 "Unsupported situation.")
- #+ignore `((:store-lexical ,binding :edi :type null))))
- ,@(when (and (= 0 (function-argument-argnum binding))
- (not last-optional-p))
- `((:popl :ebx))) ; protect ebx
- ,optional-ok-label)))))
+ (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 "Unsupported situation.")
+ #+ignore `((: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))
#+ignore (rest-position (function-argument-argnum rest-binding)))
@@ -6265,6 +6272,13 @@
(result-type (multiple-value-call #'encoded-integer-types-add
(values-list (binding-store-type term0))
(values-list (binding-store-type term1)))))
+ (when (binding-lended-p term0)
+ (warn "Add for lend0: ~S" term0))
+ (when (binding-lended-p term1)
+ (warn "Add for lend0: ~S" term1))
+ (when (and (bindingp destination)
+ (binding-lended-p destination))
+ (warn "Add for lend0: ~S" destination))
(let ((loc0 (new-binding-location term0 frame-map :default nil))
(loc1 (new-binding-location term1 frame-map :default nil)))
;;; (warn "add: ~A" instruction)
More information about the Movitz-cvs
mailing list