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

Modified Files: special-operators.lisp Log Message: Changed exact-throw, the basic operator for dynamic control transfer, quite a bit. The (ill-specified) primitive-function dynamic-locate-catch-tag is removed, its essential job is now performed by the normal function find-catch-tag.

Date: Fri Nov 12 15:51:45 2004 Author: ffjeld

Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.42 movitz/special-operators.lisp:1.43 --- movitz/special-operators.lisp:1.42 Thu Oct 21 22:41:56 2004 +++ movitz/special-operators.lisp Fri Nov 12 15:51:44 2004 @@ -8,7 +8,7 @@ ;;;; Author: Frode Vatvedt Fjeld frodef@acm.org ;;;; Created at: Fri Nov 24 16:22:59 2000 ;;;; -;;;; $Id: special-operators.lisp,v 1.42 2004/10/21 20:41:56 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.43 2004/11/12 14:51:44 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------

@@ -1175,7 +1175,10 @@ finally (error "No compiler-typecase clause matched compile-time type ~S." keyform-type)))))

(define-special-operator muerte::exact-throw (&all all-throw &form form &env env &funobj funobj) - (destructuring-bind (tag context value-form) + "Perform a dynamic control transfer to catch-env-slot context (evaluated), +with values from value-form. Error-form, if provided, is evaluated in case the context +is zero (i.e. not found)." + (destructuring-bind (context value-form &optional error-form) (cdr form) (let* ((local-env (make-local-movitz-environment env funobj :type 'let-env)) (dynamic-slot-binding @@ -1186,43 +1189,46 @@ (movitz-env-add-binding local-env (make-instance 'located-binding :name (gensym "continuation-step-"))))) - (with-labels (throw (save-tag-var save-context-var)) - (compiler-values () - :returns :non-local-exit - :code (append (compiler-call #'compile-form - :forward all-throw - :result-mode :multiple-values - :form `(muerte.cl:let ((,save-tag-var ,tag) - (,save-context-var ,context)) - (muerte.cl:multiple-value-prog1 - ,value-form - (muerte::with-inline-assembly (:returns :nothing) - (:compile-two-forms (:eax :ebx) ,save-tag-var ,save-context-var) - (:globally (:call (:edi (:edi-offset dynamic-locate-catch-tag)))) - (:jnc '(:sub-program () (:int 108))) - (:store-lexical ,dynamic-slot-binding :eax :type t) - (:globally (:call (:edi (:edi-offset dynamic-unwind-next)))) - (:store-lexical ,next-continuation-step-binding :eax :type t) - )))) - ;; now outside of m-v-prog1's cloak, with final dynamic-slot in .. - ;; ..unwind it and transfer control. - ;; - ;; * 12 dynamic-env uplink - ;; * 8 target jumper number - ;; * 4 target catch tag - ;; * 0 target EBP - `((:load-lexical ,dynamic-slot-binding :edx) - (:locally (:movl :edx (:edi (:edi-offset raw-scratch0)))) ; final continuation - (:load-lexical ,next-continuation-step-binding :edx) ; next continuation-step - (:locally (:movl :esi (:edi (:edi-offset scratch1)))) - (:locally (:movl :edx (:edi (:edi-offset dynamic-env)))) ; exit dynamic-env - (:movl :edx :esp) ; enter non-local jump stack mode. + (compiler-values () + :returns :non-local-exit + :code (append (compiler-call #'compile-form + :forward all-throw + :result-mode dynamic-slot-binding + :form context) + (compiler-call #'compile-form + :forward all-throw + :result-mode :multiple-values + :form `(muerte.cl:multiple-value-prog1 + ,value-form + (muerte::with-inline-assembly (:returns :nothing) + (:load-lexical ,dynamic-slot-binding :eax) + ,@(when error-form + `((:testl :eax :eax) + (:jz '(:sub-program () + (:compile-form (:result-mode :ignore) + ,error-form))))) + (:locally (:call (:edi (:edi-offset dynamic-unwind-next)))) + (:store-lexical ,next-continuation-step-binding :eax :type t) + ))) + ;; now outside of m-v-prog1's cloak, with final dynamic-slot in .. + ;; ..unwind it and transfer control. + ;; + ;; * 12 dynamic-env uplink + ;; * 8 target jumper number + ;; * 4 target catch tag + ;; * 0 target EBP + `((:load-lexical ,dynamic-slot-binding :edx) + (:locally (:movl :edx (:edi (:edi-offset raw-scratch0)))) ; final continuation + (:load-lexical ,next-continuation-step-binding :edx) ; next continuation-step + (:locally (:movl :esi (:edi (:edi-offset scratch1)))) + (:locally (:movl :edx (:edi (:edi-offset dynamic-env)))) ; exit dynamic-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) :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)))))))))) + (:movl (:esp 8) :edx) ; target jumper number + (:jmp (:esi :edx ,(slot-offset 'movitz-funobj 'constant0)))))))))

(define-special-operator muerte::with-basic-restart (&all defaults &form form &env env)