[movitz-cvs] CVS update: movitz/special-operators-cl.lisp
Frode Vatvedt Fjeld
ffjeld at common-lisp.net
Sat Nov 13 14:49:53 UTC 2004
Update of /project/movitz/cvsroot/movitz
In directory common-lisp.net:/tmp/cvs-serv22528
Modified Files:
special-operators-cl.lisp
Log Message:
Fixed the block and return-from special-operators to work better in
the non-trivial cases (across function-boundaries, unwind-protects etc.)
Date: Sat Nov 13 15:49:52 2004
Author: ffjeld
Index: movitz/special-operators-cl.lisp
diff -u movitz/special-operators-cl.lisp:1.33 movitz/special-operators-cl.lisp:1.34
--- movitz/special-operators-cl.lisp:1.33 Fri Nov 12 16:13:47 2004
+++ movitz/special-operators-cl.lisp Sat Nov 13 15:49:51 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.33 2004/11/12 15:13:47 ffjeld Exp $
+;;;; $Id: special-operators-cl.lisp,v 1.34 2004/11/13 14:49:51 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -629,8 +629,7 @@
:returns last-returns
:functional-p nil))))
-(define-special-operator tagbody
- (&all forward &funobj funobj &form form &env env)
+(define-special-operator tagbody (&all forward &funobj funobj &form form &env env)
(let* ((save-esp-variable (gensym "tagbody-save-esp"))
(lexical-catch-tag-variable (gensym "tagbody-lexical-catch-tag-"))
(label-set-name (gensym "label-set-"))
@@ -744,7 +743,7 @@
;; The target jumper points to the tagbody's label-set.
;; Now, install correct jumper within tagbody as target.
`((:addl ,(* 4 label-id) (:edx 8))))
- (:globally (:call (:edi (:edi-offset dynamic-unwind-next))))
+ (:locally (:call (:edi (:edi-offset dynamic-unwind-next))))
;; have next-continuation in EAX, final-continuation in EDX
(:locally (:movl :edx (:edi (:edi-offset raw-scratch0)))) ; final continuation
(:locally (:movl :esi (:edi (:edi-offset scratch1))))
@@ -767,9 +766,10 @@
((:eax :eax :multiple-values :function :ebx :ecx :ignore)
result-mode)
(t :eax)))
- (block-returns-mode (case block-result-mode
+ (block-returns-mode (case (result-mode-type block-result-mode)
(:function :multiple-values)
(:ignore :nothing)
+ ((:boolean-branch-on-true :boolean-branch-on-false) :eax)
(t block-result-mode)))
(block-env (make-instance 'lexical-exit-point-env
:uplink env
@@ -779,13 +779,10 @@
:exit-label exit-block-label
:exit-result-mode block-result-mode))
(save-esp-binding (make-instance 'located-binding
- :name save-esp-variable))
- (lexical-catch-tag-binding (make-instance 'located-binding
- :name lexical-catch-tag-variable)))
+ :name save-esp-variable)))
(movitz-env-add-binding block-env save-esp-binding)
- (movitz-env-add-binding block-env lexical-catch-tag-binding)
- (movitz-env-load-declarations `((muerte.cl::ignorable ,save-esp-variable ,lexical-catch-tag-variable))
- block-env nil)
+ (movitz-env-load-declarations `((muerte.cl::ignorable ,save-esp-variable))
+ block-env nil)
(setf (movitz-env-get block-name :block-name nil block-env)
block-env)
(compiler-values-bind (&code block-code &functional-p block-no-side-effects-p)
@@ -794,14 +791,15 @@
:result-mode block-result-mode
:form `(muerte.cl:progn , at body)
:env block-env)
- (let ((maybe-store-esp-code
- (when (and (not (eq block-result-mode :function))
+ (let ((label-set-name (gensym "block-label-set-"))
+ (maybe-store-esp-code
+ (when (and #+ignore (not (eq block-result-mode :function))
(operators-present-in-code-p block-code '(:lexical-control-transfer) nil
:test (lambda (x) (eq block-env (fifth x)))))
`((:init-lexvar ,save-esp-binding
:init-with-register :esp
:init-with-type t)))))
- (if (not (code-uses-binding-p block-code lexical-catch-tag-binding))
+ (if (not (code-uses-binding-p block-code save-esp-binding))
(compiler-values ()
:code (append maybe-store-esp-code
block-code
@@ -810,25 +808,29 @@
:functional-p block-no-side-effects-p)
(multiple-value-bind (new-code new-returns)
(make-result-and-returns-glue :multiple-values block-returns-mode block-code)
- (multiple-value-bind (stack-used wrapped-code)
- (make-compiled-catch-wrapper lexical-catch-tag-variable
- funobj block-env new-returns
- new-code)
- (incf (stack-used block-env) stack-used)
- (setf (num-specials block-env) 1) ; block-env now has one dynamic slot
- (compiler-values ()
- :code (append maybe-store-esp-code
- `((:movl :esp :eax)
- (:addl :eax :eax)
- (:xorl ,(ash (movitz-symbol-hash-key (movitz-read block-name)) 16) :eax)
- (:init-lexvar ,lexical-catch-tag-binding
- :init-with-register :eax
- :init-with-type t))
- wrapped-code
- (list exit-block-label))
- :returns block-returns-mode
- :functional-p block-no-side-effects-p)))))))))
-
+ (assert (eq :multiple-values new-returns))
+ (incf (stack-used block-env) 4)
+ (setf (num-specials block-env) 1) ; block-env now has one dynamic slot
+ (compiler-values ()
+ :code (append `((:declare-label-set ,label-set-name (,exit-block-label))
+ ;; catcher
+ (:locally (:pushl (:edi (:edi-offset dynamic-env))))
+ (:pushl ',label-set-name)
+ (:locally (:pushl (:edi (:edi-offset unbound-value))))
+ (:pushl :ebp)
+ (:locally (:movl :esp (:edi (:edi-offset dynamic-env)))))
+ `((:init-lexvar ,save-esp-binding
+ :init-with-register :esp
+ :init-with-type t))
+ new-code
+ ;; wrapped-code
+ `(,exit-block-label
+ (:movl (:esp 12) :edx)
+ (:locally (:movl :edx (:edi (:edi-offset dynamic-env))))
+ (:popl :ebp)
+ (:leal (:esp 12) :esp)))
+ :returns :multiple-values
+ :functional-p block-no-side-effects-p))))))))
(define-special-operator return-from (&all all &form form &env env &funobj funobj)
(destructuring-bind (block-name &optional result-form)
@@ -837,7 +839,8 @@
(assert block-env (block-name)
"Block-name not found for return-from: ~S." block-name)
(cond
- ((eq funobj (movitz-environment-funobj block-env))
+ ((and (eq funobj (movitz-environment-funobj block-env))
+ (null (nth-value 2 (stack-delta env block-env))))
(compiler-values-bind (&code return-code &returns return-mode)
(compiler-call #'compile-form
:forward all
@@ -847,12 +850,12 @@
:returns :non-local-exit
:code (append return-code
`((:lexical-control-transfer nil ,return-mode ,env ,block-env))))))
- ((not (eq funobj (movitz-environment-funobj block-env)))
+ ((not (and (eq funobj (movitz-environment-funobj block-env))
+ (null (nth-value 2 (stack-delta env block-env)))))
(compiler-call #'compile-form-unprotected
:forward all
- :form `(muerte.cl:throw
- ,(movitz-env-lexical-catch-tag-variable block-env)
- ,result-form)))))))
+ :form `(muerte::exact-throw ,(save-esp-variable block-env)
+ ,result-form)))))))
(define-special-operator require (&form form)
(let ((*require-dependency-chain*
More information about the Movitz-cvs
mailing list