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

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

11 Nov '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv19321 Modified Files: primitive-functions.lisp Log Message: Replaced primitive-function dynamic-find-binding with dynamic-load-unprotected, which has somewhat clearer semantics. Date: Thu Nov 11 12:09:37 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.49 movitz/losp/muerte/primitive-functions.lisp:1.50 --- movitz/losp/muerte/primitive-functions.lisp:1.49 Thu Nov 11 11:48:27 2004 +++ movitz/losp/muerte/primitive-functions.lisp Thu Nov 11 12:09:37 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.49 2004/11/11 10:48:27 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.50 2004/11/11 11:09:37 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -213,37 +213,41 @@ (:jnz 'loop) done (:ret))) - -(define-primitive-function dynamic-find-binding (symbol) - "Search the stack for a dynamic binding of SYMBOL. - On success, return Carry=1, and the address of the - binding in EAX. On failure, return Carry=0 and EAX unmodified. - Preserves EBX." - (with-inline-assembly (:returns :eax) + +(define-primitive-function dynamic-load (symbol) + "Load the dynamic value of SYMBOL into EAX." + (with-inline-assembly (:returns :multiple-values) (:locally (:movl (:edi (:edi-offset dynamic-env)) :ecx)) - (:jecxz 'fail) + (:jecxz 'no-stack-binding) + ;; Be defensive: Verify that ECX is within stack. + (:locally (:bound (:edi (:edi-offset stack-bottom)) :ecx)) (:cmpl :eax (:ecx)) (:je 'success) - (:locally (:movl (:edi (:edi-offset stack-top)) :edx)) search-loop - (:cmpl :edx (:ecx 12)) - (:jnc '(:sub-program () (:int 97))) (:movl (:ecx 12) :ecx) ; parent - (:jecxz 'fail) + (:jecxz 'no-stack-binding) + ;; Be defensive: Verify that ECX is within stack. + (:locally (:bound (:edi (:edi-offset stack-bottom)) :ecx)) (:cmpl :eax (:ecx)) ; compare name (:jne 'search-loop) ;; fall through on success success - (:leal (:ecx 8) :eax) ; location of binding value cell - (:stc) + (:movl :eax :edx) ; Keep symbol in case it's unbound. + (:movl (:ecx 8) :eax) + (:globally (:cmpl (:edi (:edi-offset unbound-value)) :eax)) + (:je '(:sub-program (unbound) (:int 99))) (:ret) - - fail - (:clc) + no-stack-binding + ;; take the global value of SYMBOL, compare it against unbond-value + (:movl :eax :edx) ; Keep symbol in case it's unbound. + (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix* + :movl (:eax (:offset movitz-symbol value)) :eax) + (:globally (:cmpl (:edi (:edi-offset unbound-value)) :eax)) + (:je '(:sub-program (unbound) (:int 99))) (:ret))) - -(define-primitive-function dynamic-load (symbol) - "Load the dynamic value of SYMBOL into EAX." + +(define-primitive-function dynamic-load-unprotected (symbol) + "Load the dynamic value of SYMBOL into EAX. If unbound, return unbound-value." (with-inline-assembly (:returns :multiple-values) (:locally (:movl (:edi (:edi-offset dynamic-env)) :ecx)) (:jecxz 'no-stack-binding) @@ -260,17 +264,12 @@ (:jne 'search-loop) ;; fall through on success success - (:movl :eax :edx) ; Keep symbol in case it's unbound. (:movl (:ecx 8) :eax) - (:globally (:cmpl (:edi (:edi-offset unbound-value)) :eax)) - (:je '(:sub-program (unbound) (:int 99))) (:ret) no-stack-binding ;; take the global value of SYMBOL, compare it against unbond-value - (:movl :eax :edx) ; Keep symbol in case it's unbound. - (:movl (:eax #.(bt:slot-offset 'movitz:movitz-symbol 'movitz::value)) :eax) - (:globally (:cmpl (:edi (:edi-offset unbound-value)) :eax)) - (:je '(:sub-program (unbound) (:int 99))) + (#.movitz:*compiler-nonlocal-lispval-read-segment-prefix* + :movl (:eax (:offset movitz-symbol value)) :eax) (:ret))) (define-primitive-function dynamic-store (symbol value)

1 0

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

11 Nov '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv18241 Modified Files: primitive-functions.lisp Log Message: More about dynamic binding protocol: also call dynamic-variable-install at binding time. Date: Thu Nov 11 11:48:27 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.48 movitz/losp/muerte/primitive-functions.lisp:1.49 --- movitz/losp/muerte/primitive-functions.lisp:1.48 Wed Nov 10 18:34:51 2004 +++ movitz/losp/muerte/primitive-functions.lisp Thu Nov 11 11:48:27 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.48 2004/11/10 17:34:51 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.49 2004/11/11 10:48:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -147,7 +147,8 @@ (:ret))) (define-primitive-function dynamic-variable-install () - "" + "Install each dynamic binding entry between that in ESP and current dynamic-env. +Preserve EDX." (with-inline-assembly (:returns :nothing) (:ret))) @@ -169,10 +170,6 @@ When the tag is not found, no cleanup-forms are executed, and carry is cleared upon return, with EAX still holding the tag." (with-inline-assembly (:returns :multiple-values) -;;; (:pushl :ebp) -;;; (:movl :esp :ebp) ; set up a pseudo stack-frame -;;; (:pushl :edi) - (:globally (:movl (:edi (:edi-offset unwind-protect-tag)) :edx)) (:locally (:movl (:edi (:edi-offset dynamic-env)) :ecx)) @@ -188,52 +185,18 @@ (:jz 'success) mismatch -;;; (:cmpl :edx (:ecx 4)) ; is env-slot in ECX == unwind-protect? -;;; (:jne 'not-unwind-protect) -;;; (:pushl :ecx) ; ..then save env-slot (in pseudo stack-frame) not-unwind-protect (:movl (:ecx 12) :ecx) ; get parent (:jmp 'search-loop) success - -;;; (:pushl 0) ; mark, meaning next slot is ``the'' target slot. -;;; (:pushl :ecx) ; save the found env-slot -;;; -;;; ;; Now execute any unwind-protect cleanup-forms we encountered. -;;; ;; We are still inside the pseudo stack-frame. -;;; (:leal (:ebp -8) :edx) ; EDX points to the current dynamic-slot-slot -;;; -;;; unwind-loop -;;; (:movl (:edx) :eax) ; next dynamic-slot to unwind -;;; (:testl :eax :eax) ; is this the last entry? -;;; (:jz 'unwind-done) -;;; (:pushl :ebp) ; save EBP -;;; (:pushl :edx) ; and EDX -;;; (:movl (:eax 12) :ebx) ; unwind dynamic-env.. -;;; (:locally (:movl :ebx (:edi (:edi-offset dynamic-env)))) -;;; (:movl (:eax 0) :ebp) ; install clean-up's stack-frame (but keep our ESP) -;;; (:movl (:ebp -4) :esi) ; ..and install clean-up's funobj in ESI -;;; (:movl (:eax 8) :edx) -;;; (:call (:esi :edx (:offset movitz-funobj constant0))) -;;; (:popl :edx) ; restoure our EDX -;;; (:popl :ebp) ; restore our EBP -;;; (:subl 4 :edx) ; ..slide EDX to next position inside stack-frame. -;;; (:jmp 'unwind-loop) -;;; -;;; unwind-done -;;; (:movl (:edx -4) :eax) ; the final dyamic-slot target. -;;; (:leave) ; exit pseudo stack-frame -;;; (:movl (:ebp -4) :esi) (:movl :ecx :eax) (:stc) ; signal success (:ret) ; return search-failed (:clc) ; signal failure -;;; (:leave) ; exit pseudo stack-frame -;;; (:movl (:ebp -4) :esi) (:ret))) ; return. (define-primitive-function dynamic-unwind ()

1 0

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

11 Nov '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv18222 Modified Files: special-operators-cl.lisp Log Message: More about dynamic binding protocol: also call dynamic-variable-install at binding time. Date: Thu Nov 11 11:48:22 2004 Author: ffjeld Index: movitz/special-operators-cl.lisp diff -u movitz/special-operators-cl.lisp:1.29 movitz/special-operators-cl.lisp:1.30 --- movitz/special-operators-cl.lisp:1.29 Wed Nov 10 18:34:47 2004 +++ movitz/special-operators-cl.lisp Thu Nov 11 11:48:22 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.29 2004/11/10 17:34:47 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.30 2004/11/11 10:48:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -285,7 +285,9 @@ :init-with-type ,(type-specifier-primary type)))))))) (t init-code))) (when (plusp (num-specials local-env)) - `((:locally (:movl :esp (:edi (:edi-offset dynamic-env)))))) + `((:locally (:call (:edi ,(bt:slot-offset 'movitz-run-time-context + 'dynamic-variable-install)))) + (:locally (:movl :esp (:edi (:edi-offset dynamic-env)))))) (if (not recompile-body-p) body-code (progn #+ignore (warn "recompile..") ; XXX @@ -1106,11 +1108,14 @@ (:jmp ',loop) ,no-more-symbols (:popl :eax) ; remove extra pre-pushed tail + (:movl :ecx :edx) + (:locally (:call (:edi ,(bt:slot-offset 'movitz-run-time-context + 'dynamic-variable-install)))) (:locally (:movl :esp (:edi (:edi-offset dynamic-env)))) ; install env ;; ecx = N/fixnum ;; (:shll 4 :ecx) ; ecx = 16*N ;; (:leal (:esp :ecx -4) :eax) ; eax = esp + 16*N - 4 - (:pushl :ecx) ; Save number of bindings. + (:pushl :edx) ; Save number of bindings. #+ignore (:pushl :eax))) ; push address of first binding's tail body-code (when (eq body-returns :push)

1 0

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

11 Nov '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv15709 Modified Files: interrupt.lisp Log Message: *** empty log message *** Date: Thu Nov 11 11:08:45 2004 Author: ffjeld Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.29 movitz/losp/muerte/interrupt.lisp:1.30 --- movitz/losp/muerte/interrupt.lisp:1.29 Mon Oct 11 15:52:54 2004 +++ movitz/losp/muerte/interrupt.lisp Thu Nov 11 11:08:44 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.29 2004/10/11 13:52:54 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.30 2004/11/11 10:08:44 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -62,6 +62,14 @@ (defun dit-frame-ref (stack frame reg &optional (type :lisp)) (stack-frame-ref stack frame (dit-frame-index reg) type)) +(define-compiler-macro (setf dit-frame-ref) (&whole form value stack frame reg + &optional (type :lisp) + &environment env) + (if (not (and (movitz:movitz-constantp stack env) + (eq nil (movitz:movitz-eval stack env)))) + form + `(setf (memref ,frame (dit-frame-offset ,reg) :type ,type) ,value))) + ;;;(defun (setf dit-frame-ref) (x reg type &optional (frame *last-dit-frame*)) ;;; (setf (memref frame (dit-frame-offset reg) 0 type) x)) @@ -117,7 +125,7 @@ :key #'dit-frame-index) collect `(:pushl ,reg)) (:locally (:pushl (:edi (:edi-offset scratch1)))) - + (:locally (:movl (:edi (:edi-offset nursery-space)) :eax)) (:pushl :eax) ; debug0: nursery-space (:pushl (:eax 2)) ; debug1: nursery-space's fresh-pointer @@ -126,9 +134,9 @@ ;; Do RET atomicification (:movl (:ebp ,(dit-frame-offset :eip)) :ecx) - (:cmpb ,(realpart (ia-x86:asm :ret)) (:ecx)) + ((:cs-override) :cmpb ,(realpart (ia-x86:asm :ret)) (:ecx)) (:jne 'not-at-ret-instruction) - (:locally (:movl (:edi (:edi-offset ret-trampoline)) :ecx)) + (:globally (:movl (:edi (:edi-offset ret-trampoline)) :ecx)) (:movl :ecx (:ebp ,(dit-frame-offset :eip))) not-at-ret-instruction @@ -259,6 +267,9 @@ ))) (do-it))) + + + (defun interrupt-default-handler (vector dit-frame) (declare (without-check-stack-limit)) (macrolet ((dereference (fixnum-address &optional (type :lisp)) @@ -277,7 +288,7 @@ (3 (break "Break instruction at ~@Z." $eip)) (4 (error "Primitive overflow assertion failed.")) (6 (error "Illegal instruction at ~@Z." $eip)) - (13 (error "General protection error. EIP=~@Z, error-code: #x~X, EAX: ~@Z, EBX: ~@Z, ECX: ~@Z" + (13 (error "General protection error. EIP=~@Z, error-code: #x~X, EAX: ~@Z, EBX: ~@Z, ECX: ~@Z" $eip (dit-frame-ref nil dit-frame :error-code :unsigned-byte32) $eax $ebx $ecx)) @@ -309,6 +320,7 @@ (stack (%run-time-context-slot 'movitz::stack-vector)) (real-bottom (- (object-location stack) 2)) (stack-left (- old-bottom real-bottom)) + (old-es (segment-register :es)) (old-dynamic-env (%run-time-context-slot 'dynamic-env)) (new-bottom (cond ((< stack-left 50) @@ -325,8 +337,9 @@ (unwind-protect (progn (setf (%run-time-context-slot 'stack-bottom) new-bottom - (%run-time-context-slot 'dynamic-env) 0) - (format *debug-io* "~&Stack-warning: Bumped stack-bottom by ~D to #x~X. Reset ENV.~%" + (%run-time-context-slot 'dynamic-env) 0 + (segment-register :es) (segment-register :ds)) + (format *debug-io* "~&Stack-warning: Bumped stack-bottom by ~D to #x~X. Reset ENV and ES.~%" (- old-bottom new-bottom) new-bottom) (break "Stack overload exception ~D at EIP=~@Z, ESP=~@Z, bottom=#x~X, ENV=#x~X." @@ -337,7 +350,8 @@ (format *debug-io* "~&Stack-warning: Resetting stack-bottom to #x~X.~%" old-bottom) (setf (%run-time-context-slot 'stack-bottom) old-bottom - (%run-time-context-slot 'dynamic-env) old-dynamic-env)))) + (%run-time-context-slot 'dynamic-env) old-dynamic-env + (segment-register :es) old-es)))) (69 (error "Not a function: ~S" (dereference $edx))) (70

1 0

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

10 Nov '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv29348 Modified Files: compiler.lisp Log Message: *** empty log message *** Date: Wed Nov 10 18:37:21 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.103 movitz/compiler.lisp:1.104 --- movitz/compiler.lisp:1.103 Wed Nov 10 16:31:58 2004 +++ movitz/compiler.lisp Wed Nov 10 18:37:20 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.103 2004/11/10 15:31:58 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.104 2004/11/10 17:37:20 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -5742,7 +5742,9 @@ (stack-delta from-env to-env) (assert stack-distance) (assert (null unwind-protects) () - "Lexical unwind-protect not implemented.") + "Lexical unwind-protect not implemented, to-env: ~S." to-env) + (when (plusp num-dynamic-slots) + (warn "Lexical jump across ~D specials." num-dynamic-slots)) (cond ((and (eq t stack-distance) (zerop num-dynamic-slots))

1 0

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

10 Nov '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv29290 Modified Files: primitive-functions.lisp Log Message: Added support for pliant protocol for dynamic binding. Date: Wed Nov 10 18:34:51 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.47 movitz/losp/muerte/primitive-functions.lisp:1.48 --- movitz/losp/muerte/primitive-functions.lisp:1.47 Thu Oct 21 22:34:09 2004 +++ movitz/losp/muerte/primitive-functions.lisp Wed Nov 10 18:34:51 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.47 2004/10/21 20:34:09 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.48 2004/11/10 17:34:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -111,16 +111,22 @@ ;;; -32: car ... (define-primitive-function dynamic-unwind-next (dynamic-env) - "Locate the next unwind-protect entry between here and 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." +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)) (:globally (:movl (:edi (:edi-offset unwind-protect-tag)) :ebx)) (:locally (:movl (:edi (:edi-offset dynamic-env)) :ecx)) search-loop - (:jecxz '(:sub-program () (:halt) (:int 63))) ; XXX don't halt + (:jecxz '(:sub-program () (:int 63))) (:locally (:bound (:edi (:edi-offset stack-bottom)) :ecx)) (:cmpl :ecx :eax) @@ -129,6 +135,9 @@ (:cmpl :ebx (:ecx 4)) ; unwind-protect entry? (:je 'found-unwind-protect) + ;; We don't need to check for and uninstall dynamic binding entries, + ;; because uninstall is a NOP under naive deep binding. + (:movl (:ecx 12) :ecx) ; proceed search (:jmp 'search-loop) found-unwind-protect @@ -136,7 +145,20 @@ (:stc) found-dynamic-env (:ret))) - + +(define-primitive-function dynamic-variable-install () + "" + (with-inline-assembly (:returns :nothing) + (:ret))) + +(define-primitive-function dynamic-variable-uninstall (dynamic-env) + "Uninstall each dynamic binding between 'here' (i.e. the current +dynamic environment pointer) and the dynamic-env pointer provided in EDX. +This must be done without affecting 'current values'! (i.e. eax, ebx, ecx, or CF), +and also EDX must not be affected." + (with-inline-assembly (:returns :nothing) + ;; Default binding strategy is naive deep binding, so this is a NOP. + (:ret))) (define-primitive-function dynamic-locate-catch-tag (tag) "Search the dynamic environment for a catch slot matching <tag> in EAX.

1 0

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

10 Nov '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv29269 Modified Files: special-operators-cl.lisp Log Message: Added support for pliant protocol for dynamic binding. Date: Wed Nov 10 18:34:47 2004 Author: ffjeld Index: movitz/special-operators-cl.lisp diff -u movitz/special-operators-cl.lisp:1.28 movitz/special-operators-cl.lisp:1.29 --- movitz/special-operators-cl.lisp:1.28 Thu Oct 21 22:44:52 2004 +++ movitz/special-operators-cl.lisp Wed Nov 10 18:34: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.28 2004/10/21 20:44:52 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.29 2004/11/10 17:34:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -288,15 +288,14 @@ `((:locally (:movl :esp (:edi (:edi-offset dynamic-env)))))) (if (not recompile-body-p) body-code - (progn #+ignore (warn "recompile..") + (progn #+ignore (warn "recompile..") ; XXX (compile-body))) (when (plusp (num-specials local-env)) `((:movl (:esp ,(+ -4 (* 16 (num-specials local-env)))) :edx) + (:locally (:call (:edi ,(bt:slot-offset 'movitz-run-time-context + 'dynamic-variable-uninstall)))) (:locally (:movl :edx (:edi (:edi-offset dynamic-env)))) - (:leal (:esp ,(* 16 (num-specials local-env))) :esp)) - #+ignore - `((:leal (:esp ,(+ -4 (* 16 (num-specials local-env)))) :esp) - (:locally (:popl (:edi (:edi-offset dynamic-env))))))))) + (:leal (:esp ,(* 16 (num-specials local-env))) :esp)))))) (compiler-values (body-values) :returns body-returns :producer (default-compiler-values-producer) @@ -1077,7 +1076,7 @@ values-form :eax funobj env) (with-labels (progv (no-more-symbols no-more-values loop zero-specials)) - `((:xorl :ecx :ecx) ; count number of bindings + `((:xorl :ecx :ecx) ; count number of bindings (fixnum) (:locally (:pushl (:edi (:edi-offset dynamic-env)))) ; first tail (:cmpl :edi :ebx) (:je '(:sub-program (,zero-specials) @@ -1086,7 +1085,7 @@ (:globally (:pushl (:edi (:edi-offset unbound-value)))) ; [[ binding tag ]] (:pushl :edi) ; binding name (:pushl :esp) - (:incl :ecx) + (:addl 4 :ecx) (:jmp ',no-more-symbols))) ,loop (:cmpl :edi :ebx) ; (endp symbols) @@ -1101,21 +1100,30 @@ (:globally (:pushl (:edi (:edi-offset unbound-value)))) ; [[ binding tag ]] (:pushl (:ebx -1)) ; push (car symbols) [[ binding name ]] (:movl (:ebx 3) :ebx) ; (pop symbols) - (:incw :cx) - (:jc '(:sub-program (too-many-symbols) (:int 71))) + (:addl 4 :ecx) + ;; (:jc '(:sub-program (too-many-symbols) (:int 71))) (:pushl :esp) ; push next tail (:jmp ',loop) ,no-more-symbols (:popl :eax) ; remove extra pre-pushed tail (:locally (:movl :esp (:edi (:edi-offset dynamic-env)))) ; install env - ;; ecx = N - (:shll 4 :ecx) ; ecx = 16*N - (:leal (:esp :ecx -4) :eax) ; eax = esp + 16*N - 4 - (:pushl :eax))) ; push address of first binding's tail + ;; ecx = N/fixnum + ;; (:shll 4 :ecx) ; ecx = 16*N + ;; (:leal (:esp :ecx -4) :eax) ; eax = esp + 16*N - 4 + (:pushl :ecx) ; Save number of bindings. + #+ignore (:pushl :eax))) ; push address of first binding's tail body-code (when (eq body-returns :push) `((:popl :eax))) ; glue :push => :eax - `((:popl :esp) ; pop address of first binding's tail + `((:movl (:esp) :edx) ; number of bindings + (:movl (:esp (:edx 4)) :edx) ; previous dynamic-env + (:locally (:call (:edi ,(bt:slot-offset 'movitz-run-time-context + 'dynamic-variable-uninstall)))) + (:locally (:movl :edx (:edi (:edi-offset dynamic-env)))) + (:popl :edx) ; number of bindings + (:leal (:esp (:edx 4)) :esp)) + #+ignore + `((:popl :edx) ; pop address of first binding's tail (:locally (:popl (:edi (:edi-offset dynamic-env)))))))))) (define-special-operator labels (&all forward &form form &env env &funobj funobj)

1 0

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

10 Nov '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv29251 Modified Files: image.lisp Log Message: Added support for pliant protocol for dynamic binding. Date: Wed Nov 10 18:34:40 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.73 movitz/image.lisp:1.74 --- movitz/image.lisp:1.73 Tue Nov 2 16:53:30 2004 +++ movitz/image.lisp Wed Nov 10 18:34:40 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.73 2004/11/02 15:53:30 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.74 2004/11/10 17:34:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -191,6 +191,16 @@ :binary-tag :primitive-function :map-binary-read-delayed 'movitz-word-code-vector :binary-type code-vector-word) + (dynamic-variable-install + :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-variable-uninstall + :map-binary-write 'movitz-intern-code-vector + :binary-tag :primitive-function + :map-binary-read-delayed 'movitz-word-code-vector + :binary-type code-vector-word) (assert-1arg :map-binary-write 'movitz-intern-code-vector :binary-tag :primitive-function @@ -435,7 +445,7 @@ (segment-descriptor-shifted-code ; 3: 1 MB shifted flat code segment :binary-type segment-descriptor :initform (make-segment-descriptor :base (image-cs-segment-base *image*) - :limit #xfff00 :type 10 :dpl 0 + :limit #xfff00 :type 14 :dpl 0 :flags '(s p d/b g))) (segment-descriptor-shifted-data ; 4: 1 MB shifted flat data segment :binary-type segment-descriptor

1 0

[movitz-cvs] CVS update: ia-x86/read.lisp
by Frode Vatvedt Fjeld 10 Nov '04

10 Nov '04

Update of /project/movitz/cvsroot/ia-x86 In directory common-lisp.net:/tmp/cvs-serv22981 Modified Files: read.lisp Log Message: *** empty log message *** Date: Wed Nov 10 16:36:15 2004 Author: ffjeld Index: ia-x86/read.lisp diff -u ia-x86/read.lisp:1.7 ia-x86/read.lisp:1.8 --- ia-x86/read.lisp:1.7 Thu Sep 2 11:02:58 2004 +++ ia-x86/read.lisp Wed Nov 10 16:36:15 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Mon Jul 31 13:54:27 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: read.lisp,v 1.7 2004/09/02 09:02:58 ffjeld Exp $ +;;;; $Id: read.lisp,v 1.8 2004/11/10 15:36:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -304,7 +304,7 @@ (list* i (read-proglist-internal sub-programs :do-append-programs do-append-programs))) ;; nothing to insert other than i itself.. - (list i))) + (when i (list i)))) finally (assert (= (length *programs-to-append*) *already-appended*) () "Dangling sub-programs to append: ~S"

1 0

[movitz-cvs] CVS update: movitz/storage-types.lisp
by Frode Vatvedt Fjeld 10 Nov '04

10 Nov '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv22939 Modified Files: storage-types.lisp Log Message: *** empty log message *** Date: Wed Nov 10 16:35:32 2004 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.43 movitz/storage-types.lisp:1.44 --- movitz/storage-types.lisp:1.43 Thu Oct 21 22:42:51 2004 +++ movitz/storage-types.lisp Wed Nov 10 16:35:32 2004 @@ -9,14 +9,12 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: storage-types.lisp,v 1.43 2004/10/21 20:42:51 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.44 2004/11/10 15:35:32 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ (in-package movitz) -;; (defconstant +tag-other+ 6) - (define-unsigned lu64 8 :little-endian) (define-bitfield segment-descriptor (lu64) @@ -171,14 +169,15 @@ ;;; Fixnums (eval-when (:compile-toplevel :execute :load-toplevel) - (defconstant +movitz-fixnum-bits+ 30) - (defconstant +movitz-fixnum-shift+ (- 32 +movitz-fixnum-bits+)) - (defconstant +movitz-fixnum-factor+ (expt 2 +movitz-fixnum-shift+)) - (defconstant +movitz-fixnum-zmask+ (1- +movitz-fixnum-factor+)) - (defconstant +movitz-most-positive-fixnum+ (1- (expt 2 (1- +movitz-fixnum-bits+)))) - (defconstant +movitz-most-negative-fixnum+ (- (expt 2 (1- +movitz-fixnum-bits+)))) + (defparameter +movitz-fixnum-bits+ 30) + (defparameter +movitz-fixnum-shift+ (- 32 +movitz-fixnum-bits+)) + (defparameter +movitz-fixnum-factor+ (expt 2 +movitz-fixnum-shift+)) + (defparameter +movitz-fixnum-zmask+ (1- +movitz-fixnum-factor+)) + (defparameter +movitz-most-positive-fixnum+ (1- (expt 2 (1- +movitz-fixnum-bits+)))) + (defparameter +movitz-most-negative-fixnum+ (- (expt 2 (1- +movitz-fixnum-bits+)))) - (defparameter +other-type-offset+ -6)) + (defparameter +object-pointer-shift+ 0) + (defparameter +other-type-offset+ (- -6 +object-pointer-shift+))) (defun fixnum-integer (word) "For a Movitz word, that must be a fixnum, return the corresponding @@ -266,7 +265,7 @@ :map-binary-read-delayed 'movitz-word :initarg :cdr :accessor movitz-cdr)) - (:slot-align car -1)) + (:slot-align car #.(- -1 +object-pointer-shift+))) (defmethod movitz-object-offset ((obj movitz-cons)) 1)

1 0