Update of /project/movitz/cvsroot/movitz
In directory common-lisp.net:/tmp/cvs-serv1757
Modified Files:
special-operators-cl.lisp
Log Message:
Fixing dynamic control transfers, primarily to handle the
stack-allocated funobjs, but there seems to be a number of (other)
bugs here too. It's not quite working yet, though.
Date: Tue Jan 4 17:54:03 2005
Author: ffjeld
Index: movitz/special-operators-cl.lisp
diff -u movitz/special-operators-cl.lisp:1.40 movitz/special-operators-cl.lisp:1.41
--- movitz/special-operators-cl.lisp:1.40 Mon Jan 3 12:55:27 2005
+++ movitz/special-operators-cl.lisp Tue Jan 4 17:54:02 2005
@@ -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.40 2005/01/03 11:55:27 ffjeld Exp $
+;;;; $Id: special-operators-cl.lisp,v 1.41 2005/01/04 16:54:02 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -749,35 +749,43 @@
(movitz-env-get tag 'go-tag nil env)
(assert (and label tagbody-env) ()
"Go-tag ~W is not visible." tag)
- (if (and (eq funobj (movitz-environment-funobj tagbody-env))
- ;; any unwind-protects between here and there?
- (null (nth-value 2 (stack-delta env tagbody-env))))
- (compiler-values ()
- :returns :non-local-exit
- :code `((:lexical-control-transfer nil :nothing ,env ,tagbody-env ,label)))
- ;; Perform a lexical "throw" to the tag. Just like a regular (dynamic) throw.
- (let ((save-esp-binding (movitz-binding (save-esp-variable tagbody-env) env))
- (label-id (movitz-env-get tag 'go-tag-label-id nil tagbody-env nil)))
- (assert label-id)
- (compiler-values ()
- :returns :non-local-exit
- :code `((:load-lexical ,save-esp-binding :edx)
- (:movl :edx :eax)
- ,@(when (plusp label-id)
- ;; The target jumper points to the tagbody's label-set.
- ;; Now, install correct jumper within tagbody as target.
- `((:addl ,(* 4 label-id) (:edx 8))))
- (: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))))
- (:locally (:movl :eax (:edi (:edi-offset dynamic-env)))) ; exit to next-env
- (:movl :eax :esp) ; enter non-local jump stack mode.
- (:movl (:esp) :eax) ; target stack-frame EBP
- (:movl (:eax -4) :esi) ; get target funobj into ESI
- (:movl (:esp 8) :eax) ; target jumper number
- (:clc)
- (:jmp (:esi :eax ,(slot-offset 'movitz-funobj 'constant0))))))))))
+ (multiple-value-bind (stack-distance num-dynamic-slots unwind-protects)
+ (stack-delta env tagbody-env)
+ (declare (ignore stack-distance))
+ (if (and (eq funobj (movitz-environment-funobj tagbody-env))
+ ;; A well-known number of dynamic-slots?
+ (not (eq t num-dynamic-slots))
+ ;; any unwind-protects between here and there?
+ (null unwind-protects))
+ (compiler-values ()
+ :returns :non-local-exit
+ :code `((:lexical-control-transfer nil :nothing ,env ,tagbody-env ,label)))
+ ;; Perform a lexical "throw" to the tag. Just like a regular (dynamic) throw.
+ (let ((save-esp-binding (movitz-binding (save-esp-variable tagbody-env) env))
+ (label-id (movitz-env-get tag 'go-tag-label-id nil tagbody-env nil)))
+ (assert label-id)
+ (compiler-values ()
+ :returns :non-local-exit
+ :code `((:load-lexical ,save-esp-binding :edx)
+ (:movl :edx :eax)
+ ,@(when (plusp label-id)
+ ;; The target jumper points to the tagbody's label-set.
+ ;; Now, install correct jumper within tagbody as target.
+ `((:addl ,(* 4 label-id) (:edx 8))))
+ (: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
+
+ (:movl :eax :edx)
+ (:clc)
+ (:locally (:call (:edi (:edi-offset dynamic-jump-next))))))))))))
+
+;;; (:locally (:movl :edx (:edi (:edi-offset dynamic-env)))) ; exit to next-env
+;;; (:movl :edx :esp) ; enter non-local jump stack mode.
+;;; (:movl (:esp) :edx) ; target stack-frame EBP
+;;; (:movl (:edx -4) :esi) ; get target funobj into ESI
+;;; (:movl (:esp 8) :edx) ; target jumper number
+;;; (:jmp (:esi :edx ,(slot-offset 'movitz-funobj 'constant0)))))))))))
(define-special-operator block (&all forward &funobj funobj &form form &env env
&result-mode result-mode)
@@ -849,10 +857,10 @@
new-code
;; wrapped-code
`(,exit-block-label
+ (:movl (:esp 0) :ebp)
(:movl (:esp 12) :edx)
(:locally (:movl :edx (:edi (:edi-offset dynamic-env))))
- (:popl :ebp)
- (:leal (:esp 12) :esp)))
+ (:leal (:esp 16) :esp)))
:returns :multiple-values
:functional-p block-no-side-effects-p))))))))
@@ -1225,92 +1233,98 @@
(:locally (:movl :esp (:edi (:edi-offset dynamic-env))))) ; install catch
body-code
`(,exit-point
+ (:movl (:esp) :ebp)
(:movl (:esp 12) :edx)
(:locally (:movl :edx (:edi (:edi-offset dynamic-env))))
- (:popl :ebp)
- (:leal (:esp 12) :esp)
+ (:leal (:esp 16) :esp)
)))))
(define-special-operator unwind-protect (&all all &form form &env env)
(destructuring-bind (protected-form &body cleanup-forms)
(cdr form)
- (let* ((continuation-env (make-instance 'let-env
- :uplink env
- :funobj (movitz-environment-funobj env)))
- (next-continuation-step-binding
- (movitz-env-add-binding continuation-env
- (make-instance 'located-binding
- :name (gensym "up-next-continuation-step-"))))
- (unwind-protect-env (make-instance 'unwind-protect-env
- :cleanup-form (cons 'muerte.cl:progn cleanup-forms)
- :uplink continuation-env
- :funobj (movitz-environment-funobj env))))
- (with-labels (unwind-protect (cleanup-label cleanup-entry continue continue-label))
- (compiler-values ()
- :returns :multiple-values
- :code (append
- ;; install default continuation dynamic-env..
- `((:locally (:pushl (:edi (:edi-offset dynamic-env))))
- (:declare-label-set ,cleanup-label (,cleanup-entry))
- (:declare-label-set ,continue-label (,continue))
- (:pushl ',cleanup-label) ; jumper index
- (:globally (:pushl (:edi (:edi-offset unwind-protect-tag)))) ; tag
- (:pushl :ebp) ; stack-frame
- (:locally (:movl :esp (:edi (:edi-offset dynamic-env))))) ; install up-env
- ;; Execute protected form..
- (compiler-call #'compile-form
- :env unwind-protect-env
- :with-stack-used t ;; XXX Not really true, is it?
- :forward all
- :result-mode :multiple-values
- :form protected-form)
- ;; From now on, take care not to touch current-values from protected-form.
- `((:locally (:movl :esp (:edi (:edi-offset raw-scratch0))))
- ,cleanup-entry
-
- ;; Now (?), modify unwind-protect dyn-env-entry to be normal continuation
- (:locally (:movl (:edi (:edi-offset unbound-function)) :edx))
- (:movl :edx (:esp 4)) ; not unwind-protect-tag
- (:movl ',continue-label (:esp 8)) ; new jumper index
-
- (:locally (:pushl (:edi (:edi-offset raw-scratch0))))) ; push final-continuation
- ;; Execute cleanup-forms.
- (compiler-call #'compile-form-unprotected
- :forward all
- :env continuation-env
- :with-stack-used t
- :result-mode :multiple-values
- :form `(muerte::with-cloak (:multiple-values)
- ;; Inside here we don't have to mind current-values.
- (muerte::with-inline-assembly (:returns :nothing)
- ;; First, find next-continuation-step..
- (:locally (:movl (:edi (:edi-offset raw-scratch0)) :eax)) ; final-cont..
- (:locally (:call (:edi (:edi-offset dynamic-unwind-next))))
- (:locally (:bound (:edi (:edi-offset stack-bottom)) :eax))
- (:store-lexical ,next-continuation-step-binding :eax :type t))
- ,@cleanup-forms))
- `((:locally (:popl (:edi (:edi-offset raw-scratch0)))) ; pop final continuation
+ (if (null cleanup-forms)
+ (compiler-call #'compile-form-unprotected
+ :forward all
+ :form protected-form)
+ (let* ((continuation-env (make-instance 'let-env
+ :uplink env
+ :funobj (movitz-environment-funobj env)))
+ (next-continuation-step-binding
+ (movitz-env-add-binding continuation-env
+ (make-instance 'located-binding
+ :name (gensym "up-next-continuation-step-"))))
+ (unwind-protect-env (make-instance 'unwind-protect-env
+ :cleanup-form (cons 'muerte.cl:progn cleanup-forms)
+ :uplink continuation-env
+ :funobj (movitz-environment-funobj env))))
+ (with-labels (unwind-protect (cleanup-label cleanup-entry continue continue-label))
+ (compiler-values ()
+ :returns :multiple-values
+ :code (append
+ ;; install default continuation dynamic-env..
+ `((:locally (:pushl (:edi (:edi-offset dynamic-env))))
+ (:declare-label-set ,cleanup-label (,cleanup-entry))
+ (:declare-label-set ,continue-label (,continue))
+ (:pushl ',cleanup-label) ; jumper index
+ (:globally (:pushl (:edi (:edi-offset unwind-protect-tag)))) ; tag
+ (:pushl :ebp) ; stack-frame
+ (:locally (:movl :esp (:edi (:edi-offset dynamic-env))))) ; install up-env
+ ;; Execute protected form..
+ (compiler-call #'compile-form
+ :env unwind-protect-env
+ :with-stack-used t ;; XXX Not really true, is it?
+ :forward all
+ :result-mode :multiple-values
+ :form protected-form)
+ ;; From now on, take care not to touch current-values from protected-form.
+ `((:locally (:movl :esp (:edi (:edi-offset raw-scratch0))))
+ ,cleanup-entry
+ ;; First, restore stack-frame in EBP
+ (:movl (:esp) :ebp)
+ ;; Now (?), modify unwind-protect dyn-env-entry to be normal continuation
+ (:locally (:movl (:edi (:edi-offset unbound-function)) :edx))
+ (:movl :edx (:esp 4)) ; not unwind-protect-tag
+ (:movl ',continue-label (:esp 8)) ; new jumper index
+
+ (:locally (:pushl (:edi (:edi-offset raw-scratch0))))) ; push final-continuation
+ ;; Execute cleanup-forms.
+ (compiler-call #'compile-form-unprotected
+ :forward all
+ :env continuation-env
+ :with-stack-used t
+ :result-mode :multiple-values
+ :form `(muerte::with-cloak (:multiple-values)
+ ;; Inside here we don't have to mind current-values.
+ (muerte::with-inline-assembly (:returns :nothing)
+ ;; First, find next-continuation-step..
+ (:locally (:movl (:edi (:edi-offset raw-scratch0)) :eax)) ; final-cont..
+ (:locally (:call (:edi (:edi-offset dynamic-unwind-next))))
+ (:locally (:bound (:edi (:edi-offset stack-bottom)) :eax))
+ (:store-lexical ,next-continuation-step-binding :eax :type t))
+ ,@cleanup-forms))
+ `((:locally (:popl (:edi (:edi-offset raw-scratch0)))) ; pop final continuation
;;; ;; Now (?), modify unwind-protect dyn-env-entry to be normal continuation
;;; (:locally (:movl (:edi (:edi-offset unbound-value)) :edx))
;;; (:movl :edx (:esp 4)) ; not unwind-protect-tag
;;; (:movl ',continue-label (:esp 8)) ; new jumper index
- (:load-lexical ,next-continuation-step-binding :edx)
- (:locally (:movl :esi (:edi (:edi-offset scratch1))))
- (:locally (:movl :edx (:edi (:edi-offset dynamic-env))))
- (:movl :edx :esp) ; enter non-local jump stack mode (possibly).
-
- (:movl (:esp) :edx) ; target stack-frame EBP
- (:movl (:edx -4) :esi) ; get target funobj into EDX
-
- (:movl (:esp 8) :edx) ; target jumper number
- (:jmp (:esi :edx ,(slot-offset 'movitz-funobj 'constant0))))
- `(,continue
- (:movl (:esp 12) :edx)
- (:locally (:movl :edx (:edi (:edi-offset dynamic-env))))
- (:popl :ebp)
- (:leal (:esp 12) :esp))))))))
+ (:load-lexical ,next-continuation-step-binding :edx)
+ (:locally (:call (:edi (:edi-offset dynamic-jump-next))))
+
+;;; (:locally (:movl :esi (:edi (:edi-offset scratch1))))
+;;; (:locally (:movl :edx (:edi (:edi-offset dynamic-env))))
+;;; (:movl :edx :esp) ; enter non-local jump stack mode (possibly).
+;;; (:movl (:esp) :edx) ; target stack-frame EBP
+;;; (:movl (:edx -4) :esi) ; get target funobj into EDX
+;;; (:movl (:esp 8) :edx) ; target jumper number
+;;; (:jmp (:esi :edx ,(slot-offset 'movitz-funobj 'constant0)))
+ )
+ `(,continue
+ (:movl (:esp) :ebp)
+ (:movl (:esp 12) :edx)
+ (:locally (:movl :edx (:edi (:edi-offset dynamic-env))))
+ (:leal (:esp 16) :esp)))))))))
(define-special-operator if (&all all &form form &env env &result-mode result-mode)
(destructuring-bind (test-form then-form &optional else-form)
