November 2004 - movitz-cvs@common-lisp.net

[movitz-cvs] CVS update: movitz/losp/x86-pc/pci.lisp
by Frode Vatvedt Fjeld 14 Nov '04

14 Nov '04

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv31766 Modified Files: pci.lisp Log Message: Changed the signature of memref-int. Date: Sun Nov 14 23:58:02 2004 Author: ffjeld Index: movitz/losp/x86-pc/pci.lisp diff -u movitz/losp/x86-pc/pci.lisp:1.3 movitz/losp/x86-pc/pci.lisp:1.4 --- movitz/losp/x86-pc/pci.lisp:1.3 Wed May 5 10:24:38 2004 +++ movitz/losp/x86-pc/pci.lisp Sun Nov 14 23:58:02 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sun Dec 14 22:33:42 2003 ;;;; -;;;; $Id: pci.lisp,v 1.3 2004/05/05 08:24:38 ffjeld Exp $ +;;;; $Id: pci.lisp,v 1.4 2004/11/14 22:58:02 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -20,12 +20,11 @@ (defun find-bios32 () (loop for bios32 from #xe0000 to #xffff0 by 16 - if (and (= (memref-int bios32 0 0 :unsigned-byte16 t) #x335f) - (= (memref-int bios32 0 1 :unsigned-byte16 t) #x5f32) + if (and (= (memref-int bios32) #x5f32335f) (loop with checksum = 0 - ;; initially (warn "PCI magic found at #x~X" bios32) - as i from 0 below (* 16 (memref-int bios32 0 9 :unsigned-byte8 t)) + ;; initially (warn "PCI magic found at #x~X" bios32) + as i from 0 below (* 16 (memref-int bios32 :offset 9 :type :unsigned-byte8)) do (incf checksum - (memref-int bios32 0 i :unsigned-byte8 t)) + (memref-int bios32 :offset i :type :unsigned-byte8)) finally (return (= 0 (ldb (byte 8 0 ) checksum))))) return bios32))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp
by Frode Vatvedt Fjeld 14 Nov '04

14 Nov '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv31743 Modified Files: memref.lisp Log Message: Changed the signature of memref-int. Date: Sun Nov 14 23:57:46 2004 Author: ffjeld Index: movitz/losp/muerte/memref.lisp diff -u movitz/losp/muerte/memref.lisp:1.37 movitz/losp/muerte/memref.lisp:1.38 --- movitz/losp/muerte/memref.lisp:1.37 Wed Nov 10 16:30:53 2004 +++ movitz/losp/muerte/memref.lisp Sun Nov 14 23:57:45 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Mar 6 21:25:49 2001 ;;;; -;;;; $Id: memref.lisp,v 1.37 2004/11/10 15:30:53 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.38 2004/11/14 22:57:45 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -759,8 +759,9 @@ (setf (memref object offset :index index :localp t) value) (setf (memref object offset :index index :localp nil) value))))) -(define-compiler-macro memref-int (&whole form &environment env address offset index type - &optional physicalp) +(define-compiler-macro memref-int + (&whole form address &key (offset 0) (index 0) (type :unsigned-byte32) (physicalp t) + &environment env) (if (or (not (movitz:movitz-constantp type physicalp)) (not (movitz:movitz-constantp physicalp env))) form @@ -793,9 +794,6 @@ (:shll 2 :ecx) (:addl :ebx :eax) (:into) -;;; (:testb ,(mask-field (byte (+ 2 movitz::+movitz-fixnum-shift+) 0) -1) -;;; :al) -;;; (:jnz '(:sub-program () (:int 63))) (:addl :eax :ecx) (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) ; scale down address (,prefixes :movl (:ecx) :ecx))))) @@ -852,31 +850,32 @@ (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) ; scale down address (,prefixes :movzxw (:ecx) :ecx))))))))))) -(defun memref-int (address offset index type &optional physicalp) +(defun memref-int (address &key (offset 0) (index 0) (type :unsigned-byte32) (physicalp t)) (cond - ((not physicalp) + (physicalp (ecase type (:lisp - (memref-int address offset index :lisp)) + (memref-int address :offset offset :index index)) (:unsigned-byte8 - (memref-int address offset index :unsigned-byte8)) + (memref-int address :offset offset :index index :type :unsigned-byte8)) (:unsigned-byte16 - (memref-int address offset index :unsigned-byte16)) + (memref-int address :offset offset :index index :type :unsigned-byte16)) (:unsigned-byte32 - (memref-int address offset index :unsigned-byte32)))) - (physicalp + (memref-int address :offset offset :index index)))) + ((not physicalp) (ecase type (:lisp - (memref-int address offset index :lisp t)) + (memref-int address :offset offset :index index :physicalp nil)) (:unsigned-byte8 - (memref-int address offset index :unsigned-byte8 t)) + (memref-int address :offset offset :index index :type :unsigned-byte8 :physicalp nil)) (:unsigned-byte16 - (memref-int address offset index :unsigned-byte16 t)) + (memref-int address :offset offset :index index :type :unsigned-byte16 :physicalp nil)) (:unsigned-byte32 - (memref-int address offset index :unsigned-byte32 t)))))) + (memref-int address :offset offset :index index :physicalp nil)))))) -(define-compiler-macro (setf memref-int) (&whole form &environment env value address offset index type - &optional physicalp) +(define-compiler-macro (setf memref-int) + (&whole form value address &key (offset 0) (index 0) (type :type) (physicalp t) + &environment env) (if (or (not (movitz:movitz-constantp type env)) (not (movitz:movitz-constantp physicalp env))) (progn @@ -977,20 +976,25 @@ (:leal ((:eax ,movitz:+movitz-fixnum-factor+)) :eax) (:cld))))))))))) -(defun (setf memref-int) (value address offset index type &optional physicalp) +(defun (setf memref-int) + (value address &key (offset 0) (index 0) (type :unsigned-byte32) (physicalp t)) (cond - ((not physicalp) + (physicalp (ecase type (:unsigned-byte8 - (setf (memref-int address offset index :unsigned-byte8) value)) + (setf (memref-int address :offset offset :index index :type :unsigned-byte8) + value)) (:unsigned-byte16 - (setf (memref-int address offset index :unsigned-byte16) value)))) - (physicalp + (setf (memref-int address :offset offset :index index :type :unsigned-byte16) + value)))) + ((not physicalp) (ecase type (:unsigned-byte8 - (setf (memref-int address offset index :unsigned-byte8 t) value)) + (setf (memref-int address :offset offset :index index :type :unsigned-byte8 :physicalp nil) + value)) (:unsigned-byte16 - (setf (memref-int address offset index :unsigned-byte16 t) value)))))) + (setf (memref-int address :offset offset :index index :type :unsigned-byte16 :physicalp nil) + value)))))) (defun memcopy (object-1 object-2 offset index-1 index-2 count type) (ecase type

1 0

[movitz-cvs] CVS update: movitz/losp/los0.lisp
by Frode Vatvedt Fjeld 14 Nov '04

14 Nov '04

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv31726 Modified Files: los0.lisp Log Message: Changed the signature of memref-int. Date: Sun Nov 14 23:57:39 2004 Author: ffjeld Index: movitz/losp/los0.lisp diff -u movitz/losp/los0.lisp:1.26 movitz/losp/los0.lisp:1.27 --- movitz/losp/los0.lisp:1.26 Fri Nov 12 21:55:49 2004 +++ movitz/losp/los0.lisp Sun Nov 14 23:57:39 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 1 18:08:32 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: los0.lisp,v 1.26 2004/11/12 20:55:49 ffjeld Exp $ +;;;; $Id: los0.lisp,v 1.27 2004/11/14 22:57:39 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -351,9 +351,17 @@ #+ignore (defun test-lexthrow (x) (apply (lambda (a b) - (if (plusp a) 0 (return-from test-lexthrow (+ a b)))) + (unwind-protect + (if (plusp a) 0 (return-from test-lexthrow (+ a b))) + (warn "To serve and protect!"))) x)) +#+ignore +(defun test-lexgo (x) + (let ((*print-base* 2)) + (return-from test-lexgo (print 123)))) + +#+ignore (defun test-xgo (c x) (tagbody loop @@ -1241,10 +1249,10 @@ (progn ;;; (unless (logbitp 9 (eflags)) ;;; (break "Someone switched off interrupts!")) - (incf (memref-int muerte.x86-pc::*screen* 0 0 :unsigned-byte16 t)) + (incf (memref-int muerte.x86-pc::*screen* :type :unsigned-byte16)) (throw 'foo 'inner-peace)) - (incf (memref-int muerte.x86-pc::*screen* 0 80 :unsigned-byte16 t))))) - (incf (memref-int muerte.x86-pc::*screen* 0 160 :unsigned-byte16 t)))))) + (incf (memref-int muerte.x86-pc::*screen* :index 80 :type :unsigned-byte16))))) + (incf (memref-int muerte.x86-pc::*screen* :index 160 :type :unsigned-byte16)))))) (defun mumbojumbo () (with-inline-assembly (:returns :multiple-values) @@ -1354,11 +1362,11 @@ #+ignore (defun ztstring (physical-address) (let ((s (make-string (loop for i upfrom 0 - until (= 0 (memref-int physical-address 0 i :unsigned-byte8 t)) + until (= 0 (memref-int physical-address :index i :type :unsigned-byte8)) finally (return i))))) (loop for i from 0 below (length s) do (setf (char s i) - (code-char (memref-int physical-address 0 i :unsigned-byte8 t)))) + (code-char (memref-int physical-address :index i :type :unsigned-byte8)))) s)) (defmacro do-default ((var &rest error-spec) &body init-forms) @@ -1416,9 +1424,9 @@ (defun general-protection-handler (vector dit-frame) (assert (= vector 13)) (let ((eip (dit-frame-ref nil dit-frame :eip :unsigned-byte32))) - (assert (= #x26 (memref-int eip 0 0 :unsigned-byte8))) ; ES override prefix? - (let ((opcode (memref-int eip 1 0 :unsigned-byte8)) - (mod/rm (memref-int eip 2 0 :unsigned-byte8))) + (assert (= #x26 (memref-int eip :offset 0 :type :unsigned-byte8 :physicalp nil))) ; ES override prefix? + (let ((opcode (memref-int eip :offset 1 :type :unsigned-byte8 :physicalp nil)) + (mod/rm (memref-int eip :offset 2 :type :unsigned-byte8 :physicalp nil))) (if (not (= #x89 opcode)) (interrupt-default-handler vector dit-frame) (let ((value (ecase (ldb (byte 3 3) mod/rm) @@ -1432,29 +1440,29 @@ (case (logand mod/rm #xc7) (#x40 ; (:movl <value> (:eax <disp8>)) (values (dit-frame-ref nil dit-frame :eax) - (memref-int eip 3 0 :signed-byte8))) + (memref-int eip :offset 3 :type :signed-byte8 :physicalp nil))) (#x43 ; (:movl <value> (:ebx <disp8>)) (values (dit-frame-ref nil dit-frame :ebx) - (memref-int eip 3 0 :signed-byte8))) + (memref-int eip :offset 3 :type :signed-byte8 :physicalp nil))) (#x44 ; the disp8/SIB case - (let ((sib (memref-int eip 3 0 :unsigned-byte8))) + (let ((sib (memref-int eip :offset 3 :type :unsigned-byte8 :physicalp nil))) (case sib ((#x19 #x0b) (values (dit-frame-ref nil dit-frame :ebx) (+ (dit-frame-ref nil dit-frame :ecx :unsigned-byte8) - (memref-int eip 4 0 :signed-byte8)))) + (memref-int eip :offset 4 :type :signed-byte8 :physicalp nil)))) ((#x1a) (values (dit-frame-ref nil dit-frame :ebx) (+ (dit-frame-ref nil dit-frame :edx :unsigned-byte8) - (memref-int eip 4 0 :signed-byte8)))))))) + (memref-int eip :offset 4 :type :signed-byte8 :physicalp nil)))))))) (when (not object) (setf (segment-register :es) (segment-register :ds)) (break "[~S] With value ~S, unknown movl at ~S: ~S ~S ~S ~S" dit-frame value eip - (memref-int eip 1 0 :unsigned-byte8) - (memref-int eip 2 0 :unsigned-byte8) - (memref-int eip 3 0 :unsigned-byte8) - (memref-int eip 4 0 :unsigned-byte8))) + (memref-int eip :offset 1 :type :unsigned-byte8 :physicalp nil) + (memref-int eip :offset 2 :type :unsigned-byte8 :physicalp nil) + (memref-int eip :offset 3 :type :unsigned-byte8 :physicalp nil) + (memref-int eip :offset 4 :type :unsigned-byte8 :physicalp nil))) (check-type object pointer) (check-type offset fixnum) (let ((write-barrier *write-barrier*)

1 0

[movitz-cvs] CVS update: movitz/compiler.lisp
by Frode Vatvedt Fjeld 13 Nov '04

13 Nov '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv26776 Modified Files: compiler.lisp Log Message: Fixed make-compiled-lexical-control-transfer to do the right thing when jumping across dynamic bindings, finally. Date: Sat Nov 13 17:13:02 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.104 movitz/compiler.lisp:1.105 --- movitz/compiler.lisp:1.104 Wed Nov 10 18:37:20 2004 +++ movitz/compiler.lisp Sat Nov 13 17:13:01 2004 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.104 2004/11/10 17:37:20 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.105 2004/11/13 16:13:01 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -5742,9 +5742,8 @@ (stack-delta from-env to-env) (assert stack-distance) (assert (null unwind-protects) () - "Lexical unwind-protect not implemented, to-env: ~S." to-env) - (when (plusp num-dynamic-slots) - (warn "Lexical jump across ~D specials." num-dynamic-slots)) + "Lexical unwind-protect not implemented, to-env: ~S. (this is not supposed to happen)" + to-env) (cond ((and (eq t stack-distance) (zerop num-dynamic-slots)) @@ -5762,7 +5761,14 @@ :env to-env :result-mode (exit-result-mode to-env) :form `(muerte::with-cloak (,return-mode) - (muerte::dynamic-unwind ,num-dynamic-slots))) + (muerte::with-inline-assembly (:returns :nothing) + ;; Compute target dynamic-env + (:locally (:movl (:edi (:edi-offset dynamic-env)) :eax)) + ,@(loop repeat num-dynamic-slots + collect `(:movl (:eax 12) :eax)) + (:locally (:call (:edi (:edi-offset dynamic-unwind-next)))) + (:locally (:movl :eax (:edi (:edi-offset dynamic-env)))) + (:jc '(:sub-program () (:int 63)))))) `((:load-lexical ,(save-esp-variable to-env) :esp) (:jmp ',to-label))))) ((zerop num-dynamic-slots) @@ -5782,7 +5788,14 @@ :env to-env :result-mode (exit-result-mode to-env) :form `(muerte::with-cloak (,return-mode) - (muerte::dynamic-unwind ,num-dynamic-slots))) + (muerte::with-inline-assembly (:returns :nothing) + ;; Compute target dynamic-env + (:locally (:movl (:edi (:edi-offset dynamic-env)) :eax)) + ,@(loop repeat num-dynamic-slots + collect `(:movl (:eax 12) :eax)) + (: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)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/primitive-functions.lisp
by Frode Vatvedt Fjeld 13 Nov '04

13 Nov '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv26678 Modified Files: primitive-functions.lisp Log Message: Removed the bogus dynamic-unwind primitive-function and special operator. Date: Sat Nov 13 17:10:22 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.52 movitz/losp/muerte/primitive-functions.lisp:1.53 --- movitz/losp/muerte/primitive-functions.lisp:1.52 Fri Nov 12 15:52:16 2004 +++ movitz/losp/muerte/primitive-functions.lisp Sat Nov 13 17:10:21 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.52 2004/11/12 14:52:16 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.53 2004/11/13 16:10:21 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -160,21 +160,6 @@ and also EDX must be preserved." (with-inline-assembly (:returns :nothing) ;; Default binding strategy is naive deep binding, so this is a NOP. - (:ret))) - -(define-primitive-function dynamic-unwind () - "Unwind ECX dynamic environment slots. Scratch EAX." - (with-inline-assembly (:returns :nothing) - (:jecxz 'done) - loop - (:locally (:movl (:edi (:edi-offset dynamic-env)) :eax)) - (:testl :eax :eax) - (:jz '(:sub-program () (:int 255))) ; end of dynamic environment??? - (:movl (:eax 12) :eax) ; get parent - (:locally (:movl :eax (:edi (:edi-offset dynamic-env)))) - (:decl :ecx) - (:jnz 'loop) - done (:ret))) (define-primitive-function dynamic-load (symbol)

1 0

[movitz-cvs] CVS update: movitz/special-operators.lisp
by Frode Vatvedt Fjeld 13 Nov '04

13 Nov '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv26654 Modified Files: special-operators.lisp Log Message: Removed the bogus dynamic-unwind primitive-function and special operator. Date: Sat Nov 13 17:10:15 2004 Author: ffjeld Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.43 movitz/special-operators.lisp:1.44 --- movitz/special-operators.lisp:1.43 Fri Nov 12 15:51:44 2004 +++ movitz/special-operators.lisp Sat Nov 13 17:10:14 2004 @@ -8,7 +8,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Nov 24 16:22:59 2000 ;;;; -;;;; $Id: special-operators.lisp,v 1.43 2004/11/12 14:51:44 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.44 2004/11/13 16:10:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -993,16 +993,6 @@ cloaked-code ;; pop the result back `((:popl ,protected-register))))))))))))) - -(define-special-operator muerte::dynamic-unwind (&form form) - (let ((unwind-count (second form))) - (check-type unwind-count (integer 0 *)) - (if (zerop unwind-count) - (compiler-values ()) - (compiler-values () - :returns :nothing - :code (append (make-immediate-move unwind-count :ecx) - `((:globally (:call (:edi (:edi-offset dynamic-unwind)))))))))) (define-special-operator muerte::with-local-env (&all all &form form) (destructuring-bind ((local-env) sub-form)

1 0

[movitz-cvs] CVS update: movitz/image.lisp
by Frode Vatvedt Fjeld 13 Nov '04

13 Nov '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv26635 Modified Files: image.lisp Log Message: Removed the bogus dynamic-unwind primitive-function and special operator. Date: Sat Nov 13 17:10:10 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.77 movitz/image.lisp:1.78 --- movitz/image.lisp:1.77 Fri Nov 12 17:24:51 2004 +++ movitz/image.lisp Sat Nov 13 17:10:09 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.77 2004/11/12 16:24:51 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.78 2004/11/13 16:10:09 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -177,11 +177,6 @@ :map-binary-read-delayed 'movitz-word-code-vector :binary-type code-vector-word) (dynamic-unwind-next - :map-binary-write 'movitz-intern-code-vector - :binary-tag :primitive-function - :map-binary-read-delayed 'movitz-word-code-vector - :binary-type code-vector-word) - (dynamic-unwind :map-binary-write 'movitz-intern-code-vector :binary-tag :primitive-function :map-binary-read-delayed 'movitz-word-code-vector

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/packages.lisp
by Frode Vatvedt Fjeld 13 Nov '04

13 Nov '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv22558/losp/muerte Modified Files: packages.lisp Log Message: *** empty log message *** Date: Sat Nov 13 15:50:13 2004 Author: ffjeld Index: movitz/losp/muerte/packages.lisp diff -u movitz/losp/muerte/packages.lisp:1.5 movitz/losp/muerte/packages.lisp:1.6 --- movitz/losp/muerte/packages.lisp:1.5 Thu Oct 21 22:50:19 2004 +++ movitz/losp/muerte/packages.lisp Sat Nov 13 15:50:13 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu Aug 30 15:19:43 2001 ;;;; -;;;; $Id: packages.lisp,v 1.5 2004/10/21 20:50:19 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.6 2004/11/13 14:50:13 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -172,10 +172,10 @@ ((keywordp symbol) (format t "~&~W == keyword~%" symbol)) ((fboundp symbol) - (format t "~&~W == function arglist: ~A~%" + (format t "~&~W == function ~:A~%" symbol (funobj-lambda-list (symbol-function symbol)))) ((boundp symbol) - (format t "~&~W == variable value: ~S~%" + (format t "~&~W == variable ~S~%" symbol (symbol-value symbol))) (t (format t "~&~W~%" symbol)))))) (let ((string (string string)))

1 0

[movitz-cvs] CVS update: movitz/special-operators-cl.lisp
by Frode Vatvedt Fjeld 13 Nov '04

13 Nov '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv22528 Modified Files: special-operators-cl.lisp Log Message: Fixed the block and return-from special-operators to work better in the non-trivial cases (across function-boundaries, unwind-protects etc.) Date: Sat Nov 13 15:49:52 2004 Author: ffjeld Index: movitz/special-operators-cl.lisp diff -u movitz/special-operators-cl.lisp:1.33 movitz/special-operators-cl.lisp:1.34 --- movitz/special-operators-cl.lisp:1.33 Fri Nov 12 16:13:47 2004 +++ movitz/special-operators-cl.lisp Sat Nov 13 15:49:51 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.33 2004/11/12 15:13:47 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.34 2004/11/13 14:49:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -629,8 +629,7 @@ :returns last-returns :functional-p nil)))) -(define-special-operator tagbody - (&all forward &funobj funobj &form form &env env) +(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-")) (label-set-name (gensym "label-set-")) @@ -744,7 +743,7 @@ ;; The target jumper points to the tagbody's label-set. ;; Now, install correct jumper within tagbody as target. `((:addl ,(* 4 label-id) (:edx 8)))) - (:globally (:call (:edi (:edi-offset dynamic-unwind-next)))) + (: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)))) @@ -767,9 +766,10 @@ ((:eax :eax :multiple-values :function :ebx :ecx :ignore) result-mode) (t :eax))) - (block-returns-mode (case block-result-mode + (block-returns-mode (case (result-mode-type block-result-mode) (:function :multiple-values) (:ignore :nothing) + ((:boolean-branch-on-true :boolean-branch-on-false) :eax) (t block-result-mode))) (block-env (make-instance 'lexical-exit-point-env :uplink env @@ -779,13 +779,10 @@ :exit-label exit-block-label :exit-result-mode block-result-mode)) (save-esp-binding (make-instance 'located-binding - :name save-esp-variable)) - (lexical-catch-tag-binding (make-instance 'located-binding - :name lexical-catch-tag-variable))) + :name save-esp-variable))) (movitz-env-add-binding block-env save-esp-binding) - (movitz-env-add-binding block-env lexical-catch-tag-binding) - (movitz-env-load-declarations `((muerte.cl::ignorable ,save-esp-variable ,lexical-catch-tag-variable)) - block-env nil) + (movitz-env-load-declarations `((muerte.cl::ignorable ,save-esp-variable)) + block-env nil) (setf (movitz-env-get block-name :block-name nil block-env) block-env) (compiler-values-bind (&code block-code &functional-p block-no-side-effects-p) @@ -794,14 +791,15 @@ :result-mode block-result-mode :form `(muerte.cl:progn ,@body) :env block-env) - (let ((maybe-store-esp-code - (when (and (not (eq block-result-mode :function)) + (let ((label-set-name (gensym "block-label-set-")) + (maybe-store-esp-code + (when (and #+ignore (not (eq block-result-mode :function)) (operators-present-in-code-p block-code '(:lexical-control-transfer) nil :test (lambda (x) (eq block-env (fifth x))))) `((:init-lexvar ,save-esp-binding :init-with-register :esp :init-with-type t))))) - (if (not (code-uses-binding-p block-code lexical-catch-tag-binding)) + (if (not (code-uses-binding-p block-code save-esp-binding)) (compiler-values () :code (append maybe-store-esp-code block-code @@ -810,25 +808,29 @@ :functional-p block-no-side-effects-p) (multiple-value-bind (new-code new-returns) (make-result-and-returns-glue :multiple-values block-returns-mode block-code) - (multiple-value-bind (stack-used wrapped-code) - (make-compiled-catch-wrapper lexical-catch-tag-variable - funobj block-env new-returns - new-code) - (incf (stack-used block-env) stack-used) - (setf (num-specials block-env) 1) ; block-env now has one dynamic slot - (compiler-values () - :code (append maybe-store-esp-code - `((:movl :esp :eax) - (:addl :eax :eax) - (:xorl ,(ash (movitz-symbol-hash-key (movitz-read block-name)) 16) :eax) - (:init-lexvar ,lexical-catch-tag-binding - :init-with-register :eax - :init-with-type t)) - wrapped-code - (list exit-block-label)) - :returns block-returns-mode - :functional-p block-no-side-effects-p))))))))) - + (assert (eq :multiple-values new-returns)) + (incf (stack-used block-env) 4) + (setf (num-specials block-env) 1) ; block-env now has one dynamic slot + (compiler-values () + :code (append `((:declare-label-set ,label-set-name (,exit-block-label)) + ;; catcher + (:locally (:pushl (:edi (:edi-offset dynamic-env)))) + (:pushl ',label-set-name) + (:locally (:pushl (:edi (:edi-offset unbound-value)))) + (:pushl :ebp) + (:locally (:movl :esp (:edi (:edi-offset dynamic-env))))) + `((:init-lexvar ,save-esp-binding + :init-with-register :esp + :init-with-type t)) + new-code + ;; wrapped-code + `(,exit-block-label + (:movl (:esp 12) :edx) + (:locally (:movl :edx (:edi (:edi-offset dynamic-env)))) + (:popl :ebp) + (:leal (:esp 12) :esp))) + :returns :multiple-values + :functional-p block-no-side-effects-p)))))))) (define-special-operator return-from (&all all &form form &env env &funobj funobj) (destructuring-bind (block-name &optional result-form) @@ -837,7 +839,8 @@ (assert block-env (block-name) "Block-name not found for return-from: ~S." block-name) (cond - ((eq funobj (movitz-environment-funobj block-env)) + ((and (eq funobj (movitz-environment-funobj block-env)) + (null (nth-value 2 (stack-delta env block-env)))) (compiler-values-bind (&code return-code &returns return-mode) (compiler-call #'compile-form :forward all @@ -847,12 +850,12 @@ :returns :non-local-exit :code (append return-code `((:lexical-control-transfer nil ,return-mode ,env ,block-env)))))) - ((not (eq funobj (movitz-environment-funobj block-env))) + ((not (and (eq funobj (movitz-environment-funobj block-env)) + (null (nth-value 2 (stack-delta env block-env))))) (compiler-call #'compile-form-unprotected :forward all - :form `(muerte.cl:throw - ,(movitz-env-lexical-catch-tag-variable block-env) - ,result-form))))))) + :form `(muerte::exact-throw ,(save-esp-variable block-env) + ,result-form))))))) (define-special-operator require (&form form) (let ((*require-dependency-chain*

1 0

[movitz-cvs] CVS update: movitz/losp/los0.lisp
by Frode Vatvedt Fjeld 12 Nov '04

12 Nov '04

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv29142 Modified Files: los0.lisp Log Message: Add dynamic-unwind-next-shallow. Date: Fri Nov 12 21:55:49 2004 Author: ffjeld Index: movitz/losp/los0.lisp diff -u movitz/losp/los0.lisp:1.25 movitz/losp/los0.lisp:1.26 --- movitz/losp/los0.lisp:1.25 Fri Nov 12 17:25:09 2004 +++ movitz/losp/los0.lisp Fri Nov 12 21:55:49 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 1 18:08:32 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: los0.lisp,v 1.25 2004/11/12 16:25:09 ffjeld Exp $ +;;;; $Id: los0.lisp,v 1.26 2004/11/12 20:55:49 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1530,6 +1530,47 @@ (:stc) (:ret))) +(define-primitive-function dynamic-unwind-next-shallow (dynamic-env) + "Locate the next unwind-protect entry between here and dynamic-env/EAX. +If no such entry is found, return (same) dynamic-env in EAX and CF=0. +Otherwise return the unwind-protect entry in EAX and CF=1. Preserve EDX. +Point is: Return the 'next step' in unwinding towards dynamic-env. +Note that it's an error if dynamic-env isn't in the current dynamic environment, +it's supposed to have been found by e.g. dynamic-locate-catch-tag." + ;; XXX: Not really sure if there's any point in the CF return value, + ;; because I don't think there's ever any need to know whether + ;; the returned entry is an unwind-protect or the actual target. + (with-inline-assembly (:returns :nothing) + (:locally (:bound (:edi (:edi-offset stack-bottom)) :eax)) + (:locally (:movl :eax (:edi (:edi-offset scratch2)))) ; Free up EAX + ;; (:globally (:movl (:edi (:edi-offset unwind-protect-tag)) :ebx)) + (:locally (:movl (:edi (:edi-offset dynamic-env)) :ecx)) + + search-loop + (:jecxz '(:sub-program () (:int 63))) + (:locally (:bound (:edi (:edi-offset stack-bottom)) :ecx)) + + (:locally (:cmpl :ecx (:edi (:edi-offset scratch2)))) + (:je 'found-dynamic-env) + + (:movl (:ecx 4) :ebx) + (:globally (:cmpl :ebx (:edi (:edi-offset unwind-protect-tag)))) + (:je 'found-unwind-protect) + + ;; If this entry is a dynamic variable binding, uninstall it. + (:movl (:ecx) :eax) ; symbol? + (:testb 3 :al) ; + (:jz 'not-variable-binding) ; not symbol? + (:movl :ebx (:eax (:offset movitz-symbol value))) ; uninstall. + not-variable-binding + (:movl (:ecx 12) :ecx) ; proceed search + (:jmp 'search-loop) + found-unwind-protect + (:stc) + found-dynamic-env + (:movl :ecx :eax) + (:ret))) + (define-primitive-function dynamic-load-shallow (symbol) "Load the dynamic value of SYMBOL into EAX." (with-inline-assembly (:returns :multiple-values) @@ -1560,6 +1601,7 @@ (setf (%run-time-context-slot ',slot) (symbol-value ',function))))) (list (install muerte:dynamic-variable-install dynamic-variable-install-shallow) (install muerte:dynamic-variable-uninstall dynamic-variable-uninstall-shallow) + (install muerte::dynamic-unwind-next dynamic-unwind-next-shallow) (install muerte::dynamic-store dynamic-store-shallow) (install muerte::dynamic-load-unprotected dynamic-load-unprotected-shallow) (prog1 (install muerte::dynamic-load dynamic-load-shallow)

1 0