[movitz-cvs] CVS update: movitz/special-operators.lisp
Frode Vatvedt Fjeld
ffjeld at common-lisp.net
Tue Apr 13 13:07:47 UTC 2004
Update of /project/movitz/cvsroot/movitz
In directory common-lisp.net:/tmp/cvs-serv10494
Modified Files:
special-operators.lisp
Log Message:
Changed the mechanism of dynamic control transfer so as to avoid
having instruction-pointers present on the stack. Rather, we keep an
index to the jumper-table of the target function. A jumper-table is a
table of instruction-pointers pointing somewhere inside the function's
code-vector, and is the first n elements of the function-objects
constants.
The purpose of all this is to reduce the complexity of scavenging the
control-stack. Almost all the problems associated with this seems to
be rooted in the presence of (potential) untagged
instruction-pointers.
Date: Tue Apr 13 09:07:47 2004
Author: ffjeld
Index: movitz/special-operators.lisp
diff -u movitz/special-operators.lisp:1.18 movitz/special-operators.lisp:1.19
--- movitz/special-operators.lisp:1.18 Tue Apr 6 20:21:28 2004
+++ movitz/special-operators.lisp Tue Apr 13 09:07:46 2004
@@ -8,7 +8,7 @@
;;;; Author: Frode Vatvedt Fjeld <frodef at acm.org>
;;;; Created at: Fri Nov 24 16:22:59 2000
;;;;
-;;;; $Id: special-operators.lisp,v 1.18 2004/04/07 00:21:28 ffjeld Exp $
+;;;; $Id: special-operators.lisp,v 1.19 2004/04/13 13:07:46 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -1243,33 +1243,41 @@
:forward all)
finally (error "No compiler-typecase clause matched compile-time type ~S." keyform-type)))))
-(define-special-operator muerte::exact-throw (&all all-throw &form form)
+(define-special-operator muerte::exact-throw (&all all-throw &form form &env env &funobj funobj)
(destructuring-bind (tag context value-form)
(cdr form)
- (with-labels (throw (save-tag-variable save-context-var tag-not-found-label))
- (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-variable ,tag)
- (,save-context-var ,context))
- (muerte.cl:multiple-value-prog1
- ,value-form
- (muerte::with-inline-assembly (:returns :nothing)
- (:compile-form (:result-mode :eax) ,save-tag-variable)
- (:compile-form (:result-mode :ebx) ,save-context-var)
- (:globally (:call (:edi (:edi-offset dynamic-locate-catch-tag))))
- (:jnc '(:sub-program (,tag-not-found-label) (:int 108)))
- (:movl :eax :ebp))))) ; save dynamic-slot in EBP
- ;; now outside of m-v-prog1's cloak, with final dynamic-slot in ESP..
- ;; ..unwind it and transfer control.
- `((:movl :ebp :esp)
- (:popl :ebp)
- (:movl (:ebp -4) :esi)
- (:leal (:esp 8) :esp) ; skip tag and eip
- (:locally (:popl (:edi (:edi-offset dynamic-env)))) ; unwind dynamic env
- (:jmp (:esp -8))))))))
+ (let* ((local-env (make-local-movitz-environment env funobj :type 'let-env))
+ (dynamic-slot-binding (movitz-env-add-binding local-env
+ (make-instance 'located-binding
+ :name (gensym "dynamic-slot-")))))
+ (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)
+ )))) ; save dynamic-slot in EBP
+ ;; now outside of m-v-prog1's cloak, with final dynamic-slot in ESP..
+ ;; ..unwind it and transfer control.
+ `((:load-lexical ,dynamic-slot-binding :ebp)
+ (:leave)
+ (:movl (:ebp -4) :esi)
+ (:movl (:esp 4) :edx)
+ ;; (:halt)
+ (:jmp (:esi :edx ,(slot-offset 'movitz-funobj 'constant0))))))))))
+
+;;; (:leal (:esp 8) :esp) ; skip tag and eip
+;;; (:locally (:popl (:edi (:edi-offset dynamic-env)))) ; unwind dynamic env
+;;; (:jmp (:esp -8))))))))
(define-special-operator muerte::with-basic-restart (&all defaults &form form &env env)
(destructuring-bind ((name function interactive test format-control
@@ -1278,16 +1286,28 @@
(cdr form)
(check-type name symbol "a restart name")
(let* ((entry-size (+ 10 (* 2 (length format-arguments)))))
- (with-labels (basic-restart-catch (exit-point-offset exit-point))
+ (with-labels (basic-restart-catch (label-set exit-point))
(compiler-values ()
:returns :multiple-values
- :code (append `((:locally (:pushl (:edi (:edi-offset dynamic-env))))
- (:call (:pc+ 0))
- ,exit-point-offset
- (:addl '(:funcall - ',exit-point ',exit-point-offset) (:esp))
- (:globally (:pushl (:edi (:edi-offset restart-tag))))
- (:pushl :ebp)
- (:load-constant ,name :push))
+;;; Basic-restart entry:
+;;; 12: parent
+;;; 8: jumper index (=> eip)
+;;; 4: tag = #:basic-restart-tag
+;;; 0: ebp/stack-frame
+;;; -4: name
+;;; -8: function
+;;; -12: interactive function
+;;; -16: test
+;;; -20: format-control
+;;; -24: (on-stack) list of format-arguments
+;;; -28: cdr
+;;; -32: car ...
+ :code (append `((:locally (:pushl (:edi (:edi-offset dynamic-env)))) ; parent
+ (:declare-label-set ,label-set (,exit-point))
+ (:pushl ',label-set) ; jumper index
+ (:globally (:pushl (:edi (:edi-offset restart-tag)))) ; tag
+ (:pushl :ebp) ; ebp
+ (:load-constant ,name :push)) ; name
(compiler-call #'compile-form
:defaults defaults
:form function
@@ -1333,6 +1353,8 @@
:result-mode :multiple-values
:with-stack-used entry-size
:form body)
- `((:leal (:esp ,(+ -4 (* 4 entry-size))) :esp)
+ `((:leal (:esp ,(+ -12 (* 4 entry-size))) :esp)
+ ,exit-point
+ (:leal (:esp ,(+ -8 16)) :esp)
(:locally (:popl (:edi (:edi-offset dynamic-env))))
- ,exit-point)))))))
+ )))))))
More information about the Movitz-cvs
mailing list