[movitz-cvs] CVS update: movitz/special-operators-cl.lisp
Frode Vatvedt Fjeld
ffjeld at common-lisp.net
Thu Feb 12 17:54:32 UTC 2004
Update of /project/movitz/cvsroot/movitz
In directory common-lisp.net:/tmp/cvs-serv19430
Modified Files:
special-operators-cl.lisp
Log Message:
Several changes regarding my working on some type-inference stuff in
the compiler. The only real change with this check-in is that the let
compiler special-cases the situation
(let ((foo init-form))
(setq bar foo))
And compiles it like (setq bar init-form).
Date: Thu Feb 12 12:54:32 2004
Author: ffjeld
Index: movitz/special-operators-cl.lisp
diff -u movitz/special-operators-cl.lisp:1.7 movitz/special-operators-cl.lisp:1.8
--- movitz/special-operators-cl.lisp:1.7 Tue Feb 10 13:06:38 2004
+++ movitz/special-operators-cl.lisp Thu Feb 12 12:54:31 2004
@@ -9,7 +9,7 @@
;;;; Created at: Fri Nov 24 16:31:11 2000
;;;; Distribution: See the accompanying file COPYING.
;;;;
-;;;; $Id: special-operators-cl.lisp,v 1.7 2004/02/10 18:06:38 ffjeld Exp $
+;;;; $Id: special-operators-cl.lisp,v 1.8 2004/02/12 17:54:31 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -51,7 +51,7 @@
(declare (ignore operator))
(multiple-value-bind (body declarations)
(parse-declarations-and-body forms)
- (if (and (null let-var-specs)
+ (if (and (null let-var-specs)
(null declarations))
(compiler-call #'compile-implicit-progn
:forward all
@@ -60,8 +60,8 @@
(let-modifies nil)
(let-vars (parse-let-var-specs let-var-specs))
(local-env (make-local-movitz-environment env funobj
- :type 'let-env
- :declarations declarations))
+ :type 'let-env
+ :declarations declarations))
(init-env (make-instance 'with-things-on-stack-env
:uplink env
:funobj funobj
@@ -93,7 +93,7 @@
(prog1 nil (incf (stack-used init-env))))
nil t)
and do (movitz-env-add-binding local-env (make-instance 'dynamic-binding
- :name var))
+ :name var))
and do (incf (num-specials local-env))
;; lexical...
else collect
@@ -117,7 +117,7 @@
(:non-local-exit :edi)
(t init-register))))
and do (movitz-env-add-binding local-env (make-instance 'located-binding
- :name var)))))
+ :name var)))))
(setf (stack-used local-env)
(stack-used init-env))
(flet ((compile-body ()
@@ -137,100 +137,121 @@
:env local-env))))
(compiler-values-bind (&all body-values &code body-code &returns body-returns)
(compile-body)
- (let ((code (append
- (loop
- for ((var init-form init-code functional-p type init-register) . rest-codes)
- on binding-var-codes
- as binding = (movitz-binding var local-env nil)
- ;; for bb in binding-var-codes
- ;; do (warn "bind: ~S" bb)
- do (assert type)
- appending
- (cond
- ((binding-lended-p binding)
- (error "Huh?")) ; remove this clause..
- ;; #+ignore
- ((and (typep binding 'located-binding)
- (not (binding-lended-p binding))
- (= 1 (length init-code))
- (eq :load-lexical (first (first init-code)))
- (let* ((target-binding (second (first init-code))))
- (and (typep target-binding 'lexical-binding)
- (eq (binding-funobj binding)
- (binding-funobj target-binding))
- (or (and (not (code-uses-binding-p body-code
- binding
- :load nil
- :store t))
- (not (code-uses-binding-p body-code
- target-binding
- :load nil
- :store t)))
- ;; This is the best we can do now to determine
- ;; if target-binding is ever used again.
- (and (eq result-mode :function)
- (not (code-uses-binding-p body-code
- target-binding
- :load t
- :store t))
- (notany (lambda (code)
- (code-uses-binding-p (third code)
- target-binding
- :load t
- :store t))
- rest-codes))))))
- ;; replace read-only lexical binding with the outer lexical binding
- ;; (warn "replace ~S with outer ~S" var (second (first init-code)))
- (change-class binding 'forwarding-binding
- :target-binding (second (first init-code)))
- nil)
- ((and (typep binding 'located-binding)
- (type-specifier-singleton type)
- (not (code-uses-binding-p body-code binding :load nil :store t)))
- ;; replace read-only lexical binding with
- ;; side-effect-free form
- #+ignore (warn "Constant binding: ~S => ~S => ~S"
- (binding-name binding)
- init-form
- (car (type-specifier-singleton type)))
- (when (code-uses-binding-p body-code binding :load t)
- (setf recompile-body-p t))
- (change-class binding 'constant-object-binding
- :object (car (type-specifier-singleton type)))
- (if functional-p
- nil ; only inject code if it's got side-effects.
- (compiler-call #'compile-form-unprotected
- :env init-env
- :defaults all
- :form init-form
- :result-mode :ignore
- :modify-accumulate let-modifies)))
- ((typep binding 'lexical-binding)
- (let ((init (type-specifier-singleton
- (type-specifier-primary type))))
- (if (and init (eq *movitz-nil* (car init)))
- `((:init-lexvar ,binding
- :init-with-register :edi
- :init-with-type null))
- (append `((:init-lexvar ,binding))
- init-code
- `((:store-lexical ,binding ,init-register
- :type ,(type-specifier-primary type)))))))
- (t init-code)))
- (when (plusp (num-specials local-env))
- `((:locally (:movl :esp (:edi (:edi-offset dynamic-env))))))
- (if (not recompile-body-p)
- body-code
- (progn #+ignore (warn "recompile..")
- (compile-body)))
- (when (plusp (num-specials local-env))
- `((:leal (:esp ,(+ -4 (* 16 (num-specials local-env)))) :esp)
- (:locally (:popl (:edi (:edi-offset dynamic-env)))))))))
- (compiler-values (body-values)
- :returns body-returns
- :producer (default-compiler-values-producer)
- :modifies let-modifies
- :code code)))))))))
+ (cond
+ ;; Is this (let ((#:foo <form>)) (setq bar #:foo)) ?
+ ;; If so, make it into (setq bar <form>)
+ ((and (= 1 (length binding-var-codes))
+ (typep (movitz-binding (caar binding-var-codes) local-env nil)
+ 'lexical-binding)
+ (instruction-is (first body-code) :load-lexical)
+ (instruction-is (second body-code) :store-lexical)
+ (null (cddr body-code))
+ (eq (movitz-binding (caar binding-var-codes) local-env nil) ; same binding?
+ (second (first body-code)))
+ (eq (third (first body-code)) ; same register?
+ (third (second body-code))))
+ (let ((tmp-binding (second (first body-code)))
+ (dest-binding (second (second body-code))))
+ (check-type dest-binding lexical-binding)
+;;; (warn "HIT: tmp: ~A, desT: ~A" tmp-binding dest-binding)
+ (compiler-call #'compile-form
+ :forward all
+ :result-mode dest-binding
+ :form (second (first binding-var-codes)))))
+ (t (let ((code (append
+ (loop
+ for ((var init-form init-code functional-p type init-register)
+ . rest-codes)
+ on binding-var-codes
+ as binding = (movitz-binding var local-env nil)
+ ;; for bb in binding-var-codes
+ ;; do (warn "bind: ~S" bb)
+ do (assert type)
+ (assert (not (binding-lended-p binding)))
+ appending
+ (cond
+ ;; #+ignore
+ ((and (typep binding 'located-binding)
+ (not (binding-lended-p binding))
+ (= 1 (length init-code))
+ (eq :load-lexical (first (first init-code)))
+ (let* ((target-binding (second (first init-code))))
+ (and (typep target-binding 'lexical-binding)
+ (eq (binding-funobj binding)
+ (binding-funobj target-binding))
+ (or (and (not (code-uses-binding-p body-code
+ binding
+ :load nil
+ :store t))
+ (not (code-uses-binding-p body-code
+ target-binding
+ :load nil
+ :store t)))
+ ;; This is the best we can do now to determine
+ ;; if target-binding is ever used again.
+ (and (eq result-mode :function)
+ (not (code-uses-binding-p body-code
+ target-binding
+ :load t
+ :store t))
+ (notany (lambda (code)
+ (code-uses-binding-p (third code)
+ target-binding
+ :load t
+ :store t))
+ rest-codes))))))
+ ;; replace read-only lexical binding with the outer lexical binding
+ ;; (warn "replace ~S with outer ~S" var (second (first init-code)))
+ (change-class binding 'forwarding-binding
+ :target-binding (second (first init-code)))
+ nil)
+ ((and (typep binding 'located-binding)
+ (type-specifier-singleton type)
+ (not (code-uses-binding-p body-code binding :load nil :store t)))
+ ;; replace read-only lexical binding with
+ ;; side-effect-free form
+ #+ignore (warn "Constant binding: ~S => ~S => ~S"
+ (binding-name binding)
+ init-form
+ (car (type-specifier-singleton type)))
+ (when (code-uses-binding-p body-code binding :load t)
+ (setf recompile-body-p t))
+ (change-class binding 'constant-object-binding
+ :object (car (type-specifier-singleton type)))
+ (if functional-p
+ nil ; only inject code if it's got side-effects.
+ (compiler-call #'compile-form-unprotected
+ :env init-env
+ :defaults all
+ :form init-form
+ :result-mode :ignore
+ :modify-accumulate let-modifies)))
+ ((typep binding 'lexical-binding)
+ (let ((init (type-specifier-singleton
+ (type-specifier-primary type))))
+ (if (and init (eq *movitz-nil* (car init)))
+ `((:init-lexvar ,binding
+ :init-with-register :edi
+ :init-with-type null))
+ (append `((:init-lexvar ,binding))
+ init-code
+ `((:store-lexical ,binding ,init-register
+ :type ,(type-specifier-primary type)))))))
+ (t init-code)))
+ (when (plusp (num-specials local-env))
+ `((:locally (:movl :esp (:edi (:edi-offset dynamic-env))))))
+ (if (not recompile-body-p)
+ body-code
+ (progn #+ignore (warn "recompile..")
+ (compile-body)))
+ (when (plusp (num-specials local-env))
+ `((:leal (:esp ,(+ -4 (* 16 (num-specials local-env)))) :esp)
+ (:locally (:popl (:edi (:edi-offset dynamic-env)))))))))
+ (compiler-values (body-values)
+ :returns body-returns
+ :producer (default-compiler-values-producer)
+ :modifies let-modifies
+ :code code)))))))))))
(define-special-operator symbol-macrolet (&all forward &form form &env env &funobj funobj)
(destructuring-bind (symbol-expansions &body declarations-and-body)
@@ -504,17 +525,22 @@
(compiler-call #'compile-form-unprotected
:defaults forward
:result-mode sub-result-mode
- :form `(muerte.cl::setf ,var ,value-form))
+ :form `(muerte.cl:setf ,var ,value-form))
(setf last-returns returns)
code))
(lexical-binding
(case (operator sub-result-mode)
- (:ignore
- (setf last-returns :nothing)
- (compiler-call #'compile-form
- :defaults forward
- :form value-form
- :result-mode binding))
+ (t ;; :ignore
+ ;; (setf last-returns :nothing)
+ (compiler-values-bind (&code sub-code &returns sub-returns)
+ (compiler-call #'compile-form
+ :defaults forward
+ :form value-form
+ :result-mode binding)
+ (setf last-returns sub-returns)
+ ;; (warn "sub-returns: ~S" sub-returns)
+ sub-code))
+ #+ignore
(t (let ((register (accept-register-mode sub-result-mode)))
(compiler-values-bind (&code code &type type)
(compiler-call #'compile-form
@@ -526,7 +552,8 @@
`((:store-lexical ,binding ,register
:type ,(type-specifier-primary type)))))))))
(t (unless (movitz-env-get var 'special nil env)
- (warn "Assuming undeclared variable ~S is special." var))
+ (warn "Assuming destination variable ~S with binding ~S is special."
+ var binding))
(setf last-returns :ebx)
(append (compiler-call #'compile-form
:defaults forward
More information about the Movitz-cvs
mailing list