[movitz-cvs] CVS update: movitz/special-operators-cl.lisp
Frode Vatvedt Fjeld
ffjeld at common-lisp.net
Thu Oct 7 12:52:48 UTC 2004
Update of /project/movitz/cvsroot/movitz
In directory common-lisp.net:/tmp/cvs-serv26284
Modified Files:
special-operators-cl.lisp
Log Message:
Fixed tagbody/go for stack discipline.
Date: Thu Oct 7 14:52:48 2004
Author: ffjeld
Index: movitz/special-operators-cl.lisp
diff -u movitz/special-operators-cl.lisp:1.24 movitz/special-operators-cl.lisp:1.25
--- movitz/special-operators-cl.lisp:1.24 Fri Sep 17 13:12:47 2004
+++ movitz/special-operators-cl.lisp Thu Oct 7 14:52:47 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.24 2004/09/17 11:12:47 ffjeld Exp $
+;;;; $Id: special-operators-cl.lisp,v 1.25 2004/10/07 12:52:47 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -624,10 +624,13 @@
:returns last-returns
:functional-p nil))))
-(define-special-operator tagbody (&all forward &funobj funobj &form form &env env &result-mode result-mode)
+(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-"))
- (tagbody-env (make-instance 'lexical-exit-point-env
+ (label-set-name (gensym "label-set-"))
+ (tagbody-env (make-instance 'tagbody-env
+ :label-set-name label-set-name
:uplink env
:funobj funobj
:save-esp-variable save-esp-variable
@@ -642,8 +645,7 @@
(movitz-env-load-declarations `((muerte.cl::ignorable ,save-esp-variable ,lexical-catch-tag-variable))
tagbody-env nil)
;; First generate an assembly-level label for each tag.
- (let* ((label-set-name (gensym "label-set-"))
- (label-set (loop with label-id = 0
+ (let* ((label-set (loop with label-id = 0
for tag-or-statement in (cdr form)
as label = (when (or (symbolp tag-or-statement)
(integerp tag-or-statement))
@@ -654,59 +656,60 @@
(setf (movitz-env-get tag-or-statement 'go-tag-label-id nil tagbody-env)
(post-incf label-id))
and collect label))
- (tagbody-functional-p t)
- (tagbody-code
+ (tagbody-codes
(loop for tag-or-statement in (cdr form)
-;;; when (and (symbolp tag-or-statement)
-;;; (movitz-env-get tag-or-statement 'muerte::loop-tag nil tagbody-env))
-;;; collect '(:align :code :loop)
if (or (symbolp tag-or-statement) ; Tagbody tags are "compiled" into..
(integerp tag-or-statement)) ; ..their assembly-level labels.
collect (movitz-env-get tag-or-statement 'go-tag nil tagbody-env)
- else append
- (compiler-values-bind (&code code &functional-p functional-p)
- (compiler-call #'compile-form
- :defaults forward
- :form tag-or-statement
- :env tagbody-env
- :result-mode :ignore)
- (unless functional-p
- (setf tagbody-functional-p nil))
- code))))
- (let ((maybe-store-esp-code
- (when (and (not (eq result-mode :function))
- (operators-present-in-code-p tagbody-code '(:lexical-control-transfer) nil
- :test (lambda (x) (eq tagbody-env (fifth x)))))
- `((:init-lexvar ,save-esp-binding
- :init-with-register :esp
- :init-with-type t)))))
- (if (not (code-uses-binding-p tagbody-code lexical-catch-tag-binding))
+ else collect
+ (compiler-call #'compile-form
+ :defaults forward
+ :form tag-or-statement
+ :env tagbody-env
+ :result-mode :ignore))))
+ (let* ((unlexical-target-p (some (lambda (code)
+ (when (listp code)
+ (code-uses-binding-p code save-esp-binding)))
+ tagbody-codes))
+ (maybe-store-esp-code
+ (when (or unlexical-target-p
+ (some (lambda (code)
+ (when (listp code)
+ (operators-present-in-code-p code '(:lexical-control-transfer) nil
+ :test (lambda (x)
+ (eq tagbody-env (fifth x))))))
+ tagbody-codes))
+ `((:init-lexvar ,save-esp-binding
+ :init-with-register :esp
+ :init-with-type t)))))
+ (if (not unlexical-target-p)
(compiler-values ()
- :code (append maybe-store-esp-code tagbody-code)
- :functional-p tagbody-functional-p
+ :code (append maybe-store-esp-code
+ (loop for code in tagbody-codes
+ if (listp code)
+ append code
+ else append (list code)))
:returns :nothing)
- (let ((code (append maybe-store-esp-code
- `((:declare-label-set ,label-set-name ,label-set)
- (:leal ((:esi 8) :esp) :eax) ; generate some semi-unique value
- (:leal ((:eax 2) :edi) :eax) ; with tag5.
- (:init-lexvar ,lexical-catch-tag-binding
- :init-with-register :eax
- :init-with-type t))
- ;; catcher
- `((:locally (:pushl (:edi (:edi-offset dynamic-env))))
+ (let ((code (append `((:declare-label-set ,label-set-name ,label-set)
+ ;; catcher
+ (:locally (:pushl (:edi (:edi-offset dynamic-env))))
(:pushl ',label-set-name)
(:pushl :eax)
(:pushl :ebp)
(:locally (:movl :esp (:edi (:edi-offset dynamic-env)))))
- tagbody-code
- `((:leal (:esp ,(+ -4 16)) :esp)
- (:locally (:popl (:edi (:edi-offset dynamic-env)))))
+ maybe-store-esp-code
+ (loop for code in tagbody-codes
+ if (listp code)
+ append code
+ else append (list code '(:movl (:esp) :ebp)))
+ `((:movl (:esp 12) :edx)
+ (:locally (:movl :edx (:edi (:edi-offset dynamic-env))))
+ (:leal (:esp 16) :esp))
)))
(setf (num-specials tagbody-env) 1
(stack-used tagbody-env) 4)
(compiler-values ()
:code code
- :functional-p tagbody-functional-p
:returns :nothing)))))))
@@ -724,8 +727,31 @@
:code `((:lexical-control-transfer nil :nothing ,env ,tagbody-env ,label)))
;; Perform a lexical "throw" to the tag. Much like a regular throw, except
;; no values are transferred, and we step _into_ that dynamic env, not outside it.
- (let ((label-id (movitz-env-get tag 'go-tag-label-id nil tagbody-env nil)))
+ (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)
+ #+ignore
+ (compiler-call #'compile-form-unprotected
+ :forward all
+ :form `(muerte::exact-throw ,(movitz-env-lexical-catch-tag-variable tagbody-env)
+ 0 nil))
+ (compiler-values ()
+ :returns :non-local-exit
+ :code `((:load-lexical ,save-esp-binding :edx)
+ (:movl :edx :eax)
+ (:globally (:call (:edi (:edi-offset dynamic-unwind-next))))
+ (:jnc '(:sub-program () (:int 63)))
+ ;; 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
+ (:jmp (:esi :eax
+ ,(* 4 label-id) ,(slot-offset 'movitz-funobj 'constant0)))))
+ #+ignore
(compiler-values ()
:returns :non-local-exit
:code (append (compiler-call #'compile-form
More information about the Movitz-cvs
mailing list