- movitz-cvs@common-lisp.net - mailman3.common-lisp.net

[movitz-cvs] CVS update: movitz/compiler.lisp
by ffjeld＠common-lisp.net 10 Jan '05

10 Jan '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv26009 Modified Files: compiler.lisp Log Message: Use copy-funobj-code-vector-slots to initialize stack-allocated funobjs. Date: Mon Jan 10 09:18:49 2005 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.127 movitz/compiler.lisp:1.128 --- movitz/compiler.lisp:1.127 Tue Jan 4 21:21:11 2005 +++ movitz/compiler.lisp Mon Jan 10 09:18:49 2005 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.127 2005/01/04 20:21:11 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.128 2005/01/10 08:18:49 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -84,6 +84,10 @@ (defvar *compiler-produce-defensive-code* t "Try to make code be extra cautious.") +(defvar *compiler-relink-recursive-funcall* t + "If true, also recursive function calls look up the function through the function name, +which enables tracing of recursive functions.") + (defvar *compiler-trust-user-type-declarations-p* t) (defvar *compiling-function-name* nil) @@ -5409,8 +5413,9 @@ :functional-p nil :modifies arguments-modifies :code (append arguments-code - (if (eq (movitz-read operator) - (movitz-read (movitz-funobj-name funobj))) ; recursive? + (if (and (not *compiler-relink-recursive-funcall*) + (eq (movitz-read operator) + (movitz-read (movitz-funobj-name funobj)))) ; recursive? (make-compiled-funcall-by-esi (length arg-forms)) (make-compiled-funcall-by-symbol operator (length arg-forms) funobj)) stack-restore-code)))))) @@ -6908,22 +6913,21 @@ collect `(:pushl (:eax ,(slot-offset 'movitz-funobj 'constant0) ,(* 4 i)))) (loop repeat (movitz-funobj-num-jumpers object) - do (error "Can't handle jumpers.") collect `(:pushl 0)) `((:pushl (:eax ,(slot-offset 'movitz-funobj 'num-jumpers))) (:pushl (:eax ,(slot-offset 'movitz-funobj 'name))) (:pushl (:eax ,(slot-offset 'movitz-funobj 'lambda-list))) -;;; (:pushl 0) ; %3op -;;; (:pushl 0) ; %2op -;;; (:pushl 0) ; %1op -;;; (:pushl 0) ; (default) - (:pushl (:eax ,(slot-offset 'movitz-funobj 'code-vector%3op))) - (:pushl (:eax ,(slot-offset 'movitz-funobj 'code-vector%2op))) - (:pushl (:eax ,(slot-offset 'movitz-funobj 'code-vector%1op))) - (:pushl (:eax ,(slot-offset 'movitz-funobj 'code-vector))) + (:pushl 0) ; %3op + (:pushl 0) ; %2op + (:pushl 0) ; %1op + (:pushl 0) ; (default) - (:pushl (:eax ,(slot-offset 'movitz-funobj 'type)))))))))))) + (:pushl (:eax ,(slot-offset 'movitz-funobj 'type))) + (:leal (:esp ,(tag :other)) :ebx) + (,*compiler-local-segment-prefix* + :call (:edi ,(global-constant-offset 'copy-funobj-code-vector-slots))) + ))))))))) ;;;(define-extended-code-expander :exit-dynamic-scope (instruction funobj frame-map) ;;; nil)

1 0

[movitz-cvs] CVS update: movitz/doc/ChangeLog
by ffjeld＠common-lisp.net 04 Jan '05

04 Jan '05

Update of /project/movitz/cvsroot/movitz/doc In directory common-lisp.net:/tmp/cvs-serv13336 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Tue Jan 4 21:33:17 2005 Author: ffjeld Index: movitz/doc/ChangeLog diff -u movitz/doc/ChangeLog:1.8 movitz/doc/ChangeLog:1.9 --- movitz/doc/ChangeLog:1.8 Tue Jul 20 11:17:38 2004 +++ movitz/doc/ChangeLog Tue Jan 4 21:33:17 2005 @@ -1,3 +1,10 @@ +2005-01-04 Frode Vatvedt Fjeld <frodef(a)cs.uit.no> + + * Fixed some support for stack-allocating funobjs and cons-cells + of dynamic extent. + + * New years resolution: Update this ChangeLog more often. + 2004-07-19 Frode Vatvedt Fjeld <frodef(a)cs.uit.no> * Bignums are now working to the extent that one can basically

1 0

[movitz-cvs] CVS update: movitz/losp/los0.lisp
by ffjeld＠common-lisp.net 04 Jan '05

04 Jan '05

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv12613 Modified Files: los0.lisp Log Message: *** empty log message *** Date: Tue Jan 4 21:24:00 2005 Author: ffjeld Index: movitz/losp/los0.lisp diff -u movitz/losp/los0.lisp:1.35 movitz/losp/los0.lisp:1.36 --- movitz/losp/los0.lisp:1.35 Wed Dec 15 14:58:26 2004 +++ movitz/losp/los0.lisp Tue Jan 4 21:24:00 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2000-2004, +;;;; Copyright (C) 2000-2005, ;;;; Department of Computer Science, University of Tromso, Norway ;;;; ;;;; Filename: los0.lisp @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 1 18:08:32 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: los0.lisp,v 1.35 2004/12/15 13:58:26 ffjeld Exp $ +;;;; $Id: los0.lisp,v 1.36 2005/01/04 20:24:00 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -108,6 +108,38 @@ ;;; (declare (dynamic-extent args)) ;;; (apply (constantly 'test-value) args)) +(defun test-closure (x z) + (flet ((closure (y) (= x (1+ y)))) + (declare (dynamic-extent (function closure))) + (closure z) + #+ignore (funcall (lambda (y) (= x (1+ y))) + z))) + +(defun test-stack-cons (x y) + (muerte::with-dynamic-extent-scope (zap) + (let ((foo (muerte::with-dynamic-extent-allocation (zap) + (cons x (lambda () y))))) + (format t "~Z: ~S, ~S" foo foo (funcall (cdr foo)))))) + +(defun test-handler (x) + (let ((foo x)) + (handler-bind + ((error (lambda (c) + (format t "error: ~S ~S" c x)))) + (error "This is an error. ~S" foo)))) + +(defun fooo (v w) + (tagbody + (print (block blurgh + (progv (list v) (list w) + (format t "Uh: ~S" (symbol-value v)) + (if (symbol-value v) + (return-from blurgh 1) + (go zap))))) + zap) + t) + + (defun test-break () (with-inline-assembly (:returns :multiple-values) (:movl 10 :ecx) @@ -544,14 +576,6 @@ (defun test-fixed (x y z) (warn "x: ~W, y: ~W, z: ~W" x y z)) -(defun test-closure (x) - (warn "lending x: ~W" x) - (values (lambda () - (warn "borrowed x: ~W" x) - (* x 2)) - (lambda (y) - (setq x y)))) - (defun test-let-closure () (tagbody (let ((*print-base* 10) @@ -1089,6 +1113,28 @@ (with-simple-restart (abort "Abort to command level ~D." (1+ *repl-level*)) (read-eval-print)))))) +(defun xwrite (object) + (with-inline-assembly (:returns :nothing) + (:locally (:movl (:edi (:edi-offset muerte::dynamic-env)) :eax)) + (:movl :eax (#x1000000)) + (:movl :ebp (#x1000004)) + (:movl :esi (#x1000008))) + (block handler-case-block-1431896 + (let (handler-case-var-1431897) + (tagbody + (handler-bind + ((serious-condition + (lambda (handler-case-temp-var-1431898) + (setq handler-case-var-1431897 handler-case-temp-var-1431898) + (go handler-case-clause-tag-1431899)))) + (return-from handler-case-block-1431896 + (muerte::internal-write object))) + handler-case-clause-tag-1431899 + (return-from handler-case-block-1431896 + (let ((c handler-case-var-1431897)) + (print-unreadable-object (c *standard-output* :type t :identity t) + (format t " while printing ~z" object)))))))) + (defun ub (x) `(hello world ,x or . what)) @@ -1185,7 +1231,7 @@ ;;; (vector-push funobj ts) ;;; (vector-push offset ts) ;;; (vector-push code-vector ts)))) - ;; (muerte::cli) + (muerte::cli) (pic8259-end-of-interrupt 0) (when (eql #\esc (muerte.x86-pc.keyboard:poll-char)) (break "Test-timer keyboard break.")) @@ -1219,8 +1265,7 @@ *timer-stack* (muerte::copy-current-control-stack)) (setf (pit8253-timer-mode 0) +pit8253-mode-single-timeout+ (pit8253-timer-count 0) (or timeout (+ base (random variation)))) - - #+ignore (muerte::sti))) + (muerte::sti))) (with-inline-assembly (:returns :nothing) (:compile-form (:result-mode :ecx) muerte.x86-pc::*screen*) (:shrl 2 :ecx) @@ -1259,7 +1304,7 @@ (progn ;;; (unless (logbitp 9 (eflags)) ;;; (break "Someone switched off interrupts!")) - (incf (memref-int muerte.x86-pc::*screen* :type :unsigned-byte16)) +;;; (incf (memref-int muerte.x86-pc::*screen* :type :unsigned-byte16)) (throw 'foo 'inner-peace)) (incf (memref-int muerte.x86-pc::*screen* :index 80 :type :unsigned-byte16))))) (incf (memref-int muerte.x86-pc::*screen* :index 160 :type :unsigned-byte16)))))) @@ -1305,8 +1350,8 @@ (format t "Extended memory: ~D KB~%" extended-memsize) (idt-init) - #+ignore (install-los0-consing :kb-size 500) + #+ignore (install-los0-consing :kb-size (max 100 (truncate (- extended-memsize 2048) 2)))) (setf *debugger-function* #'los0-debugger)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/los-closette.lisp
by ffjeld＠common-lisp.net 04 Jan '05

04 Jan '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv12597 Modified Files: los-closette.lisp Log Message: It's probably a good idea to signal an error when trying to print an illegal-value. Date: Tue Jan 4 21:23:17 2005 Author: ffjeld Index: movitz/losp/muerte/los-closette.lisp diff -u movitz/losp/muerte/los-closette.lisp:1.24 movitz/losp/muerte/los-closette.lisp:1.25 --- movitz/losp/muerte/los-closette.lisp:1.24 Mon Dec 20 14:42:51 2004 +++ movitz/losp/muerte/los-closette.lisp Tue Jan 4 21:23:16 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001-2004, +;;;; Copyright (C) 2001-2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Jul 23 14:29:10 2002 ;;;; -;;;; $Id: los-closette.lisp,v 1.24 2004/12/20 13:42:51 ffjeld Exp $ +;;;; $Id: los-closette.lisp,v 1.25 2005/01/04 20:23:16 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1723,7 +1723,8 @@ x) (defmethod print-object ((x illegal-object) stream) - (print-unreadable-object (x stream :type t :identity t)) + (error "Won't print illegal-object ~Z." x) + ;; (print-unreadable-object (x stream :type t :identity t)) x) ;;;

1 0

[movitz-cvs] CVS update: movitz/special-operators-cl.lisp
by ffjeld＠common-lisp.net 04 Jan '05

04 Jan '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv12579 Modified Files: special-operators-cl.lisp Log Message: Have tagbody set up a dynamic control transfer target properly. Date: Tue Jan 4 21:22:02 2005 Author: ffjeld Index: movitz/special-operators-cl.lisp diff -u movitz/special-operators-cl.lisp:1.41 movitz/special-operators-cl.lisp:1.42 --- movitz/special-operators-cl.lisp:1.41 Tue Jan 4 17:54:02 2005 +++ movitz/special-operators-cl.lisp Tue Jan 4 21:22:00 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.41 2005/01/04 16:54:02 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.42 2005/01/04 20:22:00 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -722,7 +722,7 @@ ;; catcher (:locally (:pushl (:edi (:edi-offset dynamic-env)))) (:pushl ',label-set-name) - (:pushl :eax) + (:locally (:pushl (:edi (:edi-offset unbound-function)))) (:pushl :ebp) (:locally (:movl :esp (:edi (:edi-offset dynamic-env))))) maybe-store-esp-code

1 0

[movitz-cvs] CVS update: movitz/compiler.lisp
by ffjeld＠common-lisp.net 04 Jan '05

04 Jan '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv12548 Modified Files: compiler.lisp Log Message: Fixed bug in make-compiled-lexical-control-transfer that would cause ESP not to be reset correctly in some situations. Date: Tue Jan 4 21:21:11 2005 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.126 movitz/compiler.lisp:1.127 --- movitz/compiler.lisp:1.126 Tue Jan 4 17:53:46 2005 +++ movitz/compiler.lisp Tue Jan 4 21:21:11 2005 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.126 2005/01/04 16:53:46 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.127 2005/01/04 20:21:11 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -5950,7 +5950,7 @@ return-mode) `((:jmp ',to-label))))) ((plusp num-dynamic-slots) - ;; (warn "num-dynamic-slots: ~S" num-dynamic-slots) + ;; (warn "num-dynamic-slots: ~S, distance: ~D" num-dynamic-slots stack-distance) (compiler-values () :returns :non-local-exit :code (append return-code @@ -5966,10 +5966,8 @@ (:locally (:call (:edi (:edi-offset dynamic-unwind-next)))) (:locally (:movl :eax (:edi (:edi-offset dynamic-env)))) (:jc '(:sub-program () (:int 63)))))) - (make-compiled-stack-restore stack-distance - (exit-result-mode to-env) - return-mode) - `((:jmp ',to-label))))) + `((:leal (:esp ,(* 4 stack-distance)) :esp) + (:jmp ',to-label))))) (t (error "unknown!"))))) (defun make-compiled-push-current-values ()

1 0

[movitz-cvs] CVS update: movitz/procfs-image.lisp
by ffjeld＠common-lisp.net 04 Jan '05

04 Jan '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv1885 Modified Files: procfs-image.lisp Log Message: We have bignums, too. Date: Tue Jan 4 17:56:45 2005 Author: ffjeld Index: movitz/procfs-image.lisp diff -u movitz/procfs-image.lisp:1.21 movitz/procfs-image.lisp:1.22 --- movitz/procfs-image.lisp:1.21 Tue Nov 23 17:11:31 2004 +++ movitz/procfs-image.lisp Tue Jan 4 17:56:44 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001-2004, +;;;; Copyright (C) 2001-2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Aug 24 11:39:37 2001 ;;;; -;;;; $Id: procfs-image.lisp,v 1.21 2004/11/23 16:11:31 ffjeld Exp $ +;;;; $Id: procfs-image.lisp,v 1.22 2005/01/04 16:56:44 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -124,6 +124,8 @@ (movitz-vector-symbolic-data expr))) (movitz-fixnum (movitz-fixnum-value expr)) + (movitz-bignum + (movitz-bignum-value expr)) (movitz-basic-vector (map 'vector #'movitz-print (movitz-vector-symbolic-data expr))) (movitz-cons

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/more-macros.lisp
by ffjeld＠common-lisp.net 04 Jan '05

04 Jan '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv1862 Modified Files: more-macros.lisp Log Message: Small fix for the %run-time-context-slot compiler-macro and :code-vector-word slots. Date: Tue Jan 4 17:56:19 2005 Author: ffjeld Index: movitz/losp/muerte/more-macros.lisp diff -u movitz/losp/muerte/more-macros.lisp:1.23 movitz/losp/muerte/more-macros.lisp:1.24 --- movitz/losp/muerte/more-macros.lisp:1.23 Mon Jan 3 12:56:14 2005 +++ movitz/losp/muerte/more-macros.lisp Tue Jan 4 17:56:19 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001-2004, +;;;; Copyright (C) 2001-2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.23 2005/01/03 11:56:14 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.24 2005/01/04 16:56:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -342,8 +342,8 @@ (:locally (:movl (:edi (:edi-offset ,slot-name)) :eax)))) (movitz::code-vector-word `(with-inline-assembly (:returns :eax) - (:locally (:movl (:edi (:edi-offset ,slot-name)) :eax)) - (:subl ,movitz::+code-vector-word-offset+ :eax))) + (:movl ,(ldb (byte 32 0) (- movitz::+code-vector-word-offset+)) :eax) + (:locally (:addl (:edi (:edi-offset ,slot-name)) :eax)))) (movitz::lu32 `(with-inline-assembly (:returns :untagged-fixnum-ecx) (:locally (:movl (:edi (:edi-offset ,slot-name)) :ecx))))))))

1 0

[movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp
by ffjeld＠common-lisp.net 04 Jan '05

04 Jan '05

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv1840 Modified Files: debugger.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:35 2005 Author: ffjeld Index: movitz/losp/x86-pc/debugger.lisp diff -u movitz/losp/x86-pc/debugger.lisp:1.27 movitz/losp/x86-pc/debugger.lisp:1.28 --- movitz/losp/x86-pc/debugger.lisp:1.27 Thu Oct 21 22:27:00 2004 +++ movitz/losp/x86-pc/debugger.lisp Tue Jan 4 17:54:34 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001-2004, +;;;; Copyright (C) 2001-2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Nov 22 10:09:18 2002 ;;;; -;;;; $Id: debugger.lisp,v 1.27 2004/10/21 20:27:00 ffjeld Exp $ +;;;; $Id: debugger.lisp,v 1.28 2005/01/04 16:54:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -470,6 +470,8 @@ for frame = initial-stack-frame-index then (or next-frame (let ((uplink (stack-frame-uplink stack frame))) + (assert (typep uplink 'fixnum) () + "Weird uplink ~S for frame ~S." uplink frame) (assert (> uplink frame) () "Backtracing uplink ~S from frame index ~S." uplink frame) uplink))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp
by ffjeld＠common-lisp.net 04 Jan '05

04 Jan '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv1825 Modified Files: scavenge.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:28 2005 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.38 movitz/losp/muerte/scavenge.lisp:1.39 --- movitz/losp/muerte/scavenge.lisp:1.38 Mon Jan 3 12:53:47 2005 +++ movitz/losp/muerte/scavenge.lisp Tue Jan 4 17:54:27 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2003-2004, +;;;; Copyright (C) 2003-2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Mar 29 14:54:08 2004 ;;;; -;;;; $Id: scavenge.lisp,v 1.38 2005/01/03 11:53:47 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.39 2005/01/04 16:54:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -204,10 +204,11 @@ (+ dit-frame (dit-frame-index :ecx))))) ;; 2. Pop to (dit-)frame's CASF (setf nether-frame dit-frame - frame (dit-frame-casf stack frame)) - (let ((casf-funobj (funcall function (stack-frame-funobj stack frame) frame)) + frame casf-frame #+ignore (dit-frame-casf stack frame)) + (let ((eip-location (dit-frame-ref stack dit-frame :eip :location)) + (interrupted-esp (dit-frame-esp stack dit-frame)) (interrupted-ebp (dit-frame-ref stack dit-frame :ebp)) - (interrupted-esp (dit-frame-esp stack dit-frame))) + (casf-funobj (funcall function (stack-frame-funobj stack frame) frame))) (cond #+ignore ((eq nil casf-funobj) @@ -218,23 +219,21 @@ (let ((casf-code-vector (scavenge-funobj-code-vector casf-funobj))) ;; 3. Scavenge the interrupted frame, according to one of i. ii. or iii. (cond - ((< interrupted-ebp interrupted-esp) + ((eq nil interrupted-ebp) (cond - ((location-in-object-p casf-code-vector - (dit-frame-ref stack dit-frame :eip :location)) - (warn "DIT at throw situation, in target EIP=~S" + ((location-in-object-p casf-code-vector eip-location) + (warn "DIT at throw situation, in target ~S at ~S" + casf-funobj (dit-frame-ref stack dit-frame :eip :unsigned-byte32)) (map-region function interrupted-esp frame)) - ((location-in-object-p (scavenge-funobj-code-vector (dit-frame-ref stack - dit-frame - :scratch1)) - (dit-frame-ref stack dit-frame :eip :location)) - (warn "DIT at throw situation, in thrower EIP=~S" - (dit-frame-ref stack dit-frame :eip :unsigned-byte32)) - (map-region function interrupted-esp frame)) - (t (error "DIT with EBP<ESP, EBP=~S, ESP=~S" - interrupted-ebp - interrupted-esp)))) + ((location-in-object-p (%run-time-context-slot 'dynamic-jump-next) + eip-location) + (warn "DIT at throw situation, in dynamic-jump-next.") + (let ((dynamic-env (dit-frame-ref stack dit-frame :dynamic-env))) + (assert (< dynamic-env frame)) + (map-region function dynamic-env frame))) + (t (error "Unknown throw situation with EBP=~S, ESP=~S" + interrupted-ebp interrupted-esp)))) ((location-in-object-p casf-code-vector (dit-frame-ref stack dit-frame :eip :location)) (cond @@ -295,7 +294,8 @@ (map-region function (+ interrupted-esp 1) frame) (setf next-frame frame next-nether-frame (+ interrupted-esp 1 -2)))))) - (t (error "DIT-frame interrupted unknown CASF funobj: ~S" casf-funobj)))))) + (t (error "DIT-frame interrupted unknown CASF funobj: ~Z, CASF ~S" + casf-funobj casf-frame)))))) (t (error "Don't know how to scavenge across frame ~S of kind ~S." frame funobj))))))) (values))

1 0