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

[movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp
by Frode Vatvedt Fjeld 21 Sep '04

21 Sep '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv16559 Modified Files: scavenge.lisp Log Message: Add a continue/ignore restart for the "won't defun a common-lisp symbol" error. Date: Tue Sep 21 15:01:33 2004 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.30 movitz/losp/muerte/scavenge.lisp:1.31 --- movitz/losp/muerte/scavenge.lisp:1.30 Fri Sep 17 13:13:05 2004 +++ movitz/losp/muerte/scavenge.lisp Tue Sep 21 15:01:33 2004 @@ -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.30 2004/09/17 11:13:05 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.31 2004/09/21 13:01:33 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -56,7 +56,8 @@ (cond ((let ((tag (ldb (byte 3 0) x))) (or (= tag #.(movitz:tag :null)) - (= tag #.(movitz:tag :fixnum)) + (= tag #.(movitz:tag :even-fixnum)) + (= tag #.(movitz:tag :odd-fixnum)) (scavenge-typep x :character)))) ((scavenge-typep x :illegal) (error "Illegal word ~S at ~S." x scan)) @@ -148,59 +149,63 @@ (defun map-stack-words (function stack start-frame) "Map function over the potential pointer words of a stack, starting at the start-stack-frame location." - (loop for nether-frame = start-frame then frame - and frame = (stack-frame-uplink stack start-frame) then (stack-frame-uplink stack frame) + (loop with next-frame with next-nether-frame + for nether-frame = start-frame then (or next-nether-frame frame) + and frame = (stack-frame-uplink stack start-frame) then (or next-frame + (stack-frame-uplink stack frame)) while (plusp frame) + do (setf next-frame nil next-nether-frame nil) do (let ((funobj (funcall function (stack-frame-funobj stack frame) frame))) + ;; If nether-frame is a DIT-frame, there are 4 more words to be skipped. + (when (eq 0 (stack-frame-ref stack nether-frame -1)) + (incf nether-frame 4)) (typecase funobj ((or function null) (assert (= 0 (funobj-frame-num-unboxed funobj))) - #+ignore - (assert (typep (stack-frame-ref stack frame 1 :lisp) '(or (eql 0) - (not (or fixnum character)))) - () "Malaligned CALL in function ~S at #x~X, frame ~S." - (and (plusp (stack-frame-uplink stack frame)) - (stack-frame-funobj stack (stack-frame-uplink stack frame))) - (stack-frame-ref stack frame 1 :unsigned-byte32) - frame) (map-heap-words function (+ nether-frame 2) frame)) ((eql 0) ; A dit interrupt-frame? (let* ((dit-frame frame) (casf-frame (dit-frame-casf stack dit-frame))) ;; 1. Scavenge the dit-frame (cond + ((let ((atomically (dit-frame-ref stack dit-frame :atomically-continuation + :unsigned-byte32))) + (and (not (= 0 atomically)) + (= 0 (ldb (byte 2 0) atomically)))) + ;; Interrupt occurred inside an (non-pf) atomically, so none of the + ;; registers are active. + (map-heap-words function (+ nether-frame 2) + (+ dit-frame 1 (dit-frame-index :tail-marker)))) ((logbitp 10 (dit-frame-ref stack dit-frame :eflags :unsigned-byte32)) ;; DF flag was 1, so EAX and EDX are not GC roots. - #+ignore - (warn "Interrupt in uncommon mode at ~S" - (dit-frame-ref stack dit-frame :eip :unsigned-byte32)) - #+ignore - (break "dit-frame: ~S, end: ~S" - dit-frame - (+ 1 dit-frame (dit-frame-index :ebx))) + #+ignore (warn "Interrupt in uncommon mode at ~S" + (dit-frame-ref stack dit-frame :eip :unsigned-byte32)) (map-heap-words function ; Assume nothing in the dit-frame above the location .. (+ nether-frame 2) ; ..of EDX holds pointers. (+ dit-frame (dit-frame-index :edx)))) - (t #+ignore - (warn "Interrupt in COMMON mode!") + (t #+ignore (warn "Interrupt in COMMON mode!") (map-heap-words function ; Assume nothing in the dit-frame above the location .. (+ nether-frame 2) ; ..of ECX holds pointers. (+ dit-frame (dit-frame-index :ecx))))) ;; 2. Pop to (dit-)frame's CASF - (setf nether-frame frame + (setf nether-frame dit-frame frame (dit-frame-casf stack frame)) (let ((casf-funobj (funcall function (stack-frame-funobj stack frame) frame)) (interrupted-ebp (dit-frame-ref stack dit-frame :ebp)) (interrupted-esp (dit-frame-esp stack dit-frame))) (cond + #+ignore ((eq nil casf-funobj) - #+ignore (warn "Scanning interrupt in PF: ~S" (dit-frame-ref stack dit-frame :eip :unsigned-byte32))) - ((eq 0 casf-funobj) - (warn "Interrupt (presumably) in interrupt trampoline.")) - ((typep casf-funobj 'function) - (let ((casf-code-vector (funobj-code-vector casf-funobj))) +;;; ((eq 0 casf-funobj) +;;; (warn "Interrupt (presumably) in interrupt trampoline: ~S" +;;; (dit-frame-ref stack dit-frame :eip :unsigned-byte32))) + ((or (eq 0 casf-funobj) + (typep casf-funobj 'function)) + (let ((casf-code-vector (if (eq 0 casf-funobj) + (symbol-value 'default-interrupt-trampoline) + (funobj-code-vector casf-funobj)))) ;; 3. Scavenge the interrupted frame, according to one of i. ii. or iii. (cond ((< interrupted-ebp interrupted-esp) @@ -232,7 +237,11 @@ (dit-frame-ref stack dit-frame :eip :unsigned-byte32) (memref interrupted-esp 0 0 :unsigned-byte32) (funobj-name casf-funobj)) - (map-heap-words function (+ interrupted-esp 1) frame)) + #+ignore (map-heap-words function (+ interrupted-esp 1) frame) + (when (eq 0 (stack-frame-ref stack frame -1)) + (break "X1 call in DIT-frame.")) + (setf next-frame frame + next-nether-frame (+ interrupted-esp 1 -2))) ((let ((x1-tag (ldb (byte 3 0) (memref interrupted-esp 4 0 :unsigned-byte8)))) (and (member x1-tag '(1 5 6 7)) @@ -243,22 +252,34 @@ (dit-frame-ref stack dit-frame :eip :unsigned-byte32) (memref interrupted-esp 0 1 :unsigned-byte32) (funobj-name casf-funobj)) - (map-heap-words function (+ interrupted-esp 2) frame)) + (when (eq 0 (stack-frame-ref stack frame -1)) + (break "X1 call in DIT-frame.")) + #+ignore (map-heap-words function (+ interrupted-esp 2) frame) + (setf next-frame frame + next-nether-frame (+ interrupted-esp 2 -2))) (t ;; Situation i. Nothing special on stack, scavenge frame normally. - (map-heap-words function interrupted-esp frame)))) + ;; (map-heap-words function interrupted-esp frame) + (setf next-frame frame + next-nether-frame (- interrupted-esp 2)) + ))) ((eq casf-frame (memref interrupted-esp 0 0 :location)) ;; Situation ii. esp(0)=CASF, esp(1)=code-vector (assert (location-in-object-p casf-code-vector (memref interrupted-esp 0 1 :location)) + () "Stack discipline situation ii. invariant broken. CASF=#x~X, ESP=~S, EBP=~S" casf-frame interrupted-esp interrupted-ebp) - (map-heap-words function (+ interrupted-esp 2) frame)) + #+ignore (map-heap-words function (+ interrupted-esp 2) frame) + (setf next-frame frame + next-nether-frame (+ interrupted-esp 2 -2))) (t ;; Situation iii. esp(0)=code-vector. (assert (location-in-object-p casf-code-vector (memref interrupted-esp 0 0 :location)) () "Stack discipline situation iii. invariant broken. CASF=#x~X" casf-frame) - (map-heap-words function (+ interrupted-esp 1) frame))))) + #+ignore (map-heap-words 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 "Don't know how to scavenge across frame ~S of kind ~S." frame funobj))))) (values))

1 0

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

21 Sep '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv16532 Modified Files: special-operators.lisp Log Message: Add a continue/ignore restart for the "won't defun a common-lisp symbol" error. Date: Tue Sep 21 15:01:27 2004 Author: ffjeld Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.39 movitz/special-operators.lisp:1.40 --- movitz/special-operators.lisp:1.39 Fri Sep 17 13:12:49 2004 +++ movitz/special-operators.lisp Tue Sep 21 15:01:23 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.39 2004/09/17 11:12:49 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.40 2004/09/21 13:01:23 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1211,8 +1211,6 @@ ;; * 8 target jumper number ;; * 4 target catch tag ;; * 0 target EBP -;;; `((:load-lexical ,dynamic-slot-binding :edx) -;;; ()) `((:load-lexical ,dynamic-slot-binding :edx) (:locally (:movl :edx (:edi (:edi-offset raw-scratch0)))) ; final continuation (:load-lexical ,next-continuation-step-binding :edx) ; next continuation-step

1 0

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

21 Sep '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv16495 Modified Files: image.lisp Log Message: Add a continue/ignore restart for the "won't defun a common-lisp symbol" error. Date: Tue Sep 21 15:01:03 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.69 movitz/image.lisp:1.70 --- movitz/image.lisp:1.69 Fri Sep 17 13:12:55 2004 +++ movitz/image.lisp Tue Sep 21 15:01:00 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.69 2004/09/17 11:12:55 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.70 2004/09/21 13:01:00 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -453,24 +453,13 @@ (raw-scratch0 ; A non-GC-root scratch register :binary-type lu32 :initform 0) + (atomically-continuation + :binary-type lu32 + :initform 0) (non-pointers-end :binary-type :label) ; ========= NON-POINTER-END ======= (scratch1 :binary-type word :initform 0) - (atomically-status - :binary-type (define-bitfield atomically-status (lu32) - (((:enum :byte (3 2)) - :inactive 0 - :restart-primitive-function 1 ; data = slot-offset of pf. - :restart-jumper 2) ; data = ESI-relative jumper number. - ((:bits) :reset-status-p 8 - :esp 9 - :ebp 10) - ((:numeric :data 16 16)))) - :initform '(:inactive)) - (atomically-esp - :binary-type lu32 - :initform 0) (dynamic-unwind-next :map-binary-write 'movitz-intern-code-vector :binary-tag :primitive-function @@ -478,7 +467,9 @@ :binary-type code-vector-word)) (:slot-align null-symbol -5)) -(defun atomically-status-simple-pf (pf-name reset-status-p &rest registers) +(defun atomically-continuation-simple-pf (pf-name) + (global-constant-offset pf-name) + #+ignore (bt:enum-value 'movitz::atomically-status (list* :restart-primitive-function (cons :reset-status-p @@ -494,6 +485,8 @@ registers))) (defun atomically-status-jumper-fn (reset-status-p &rest registers) + (assert (not reset-status-p)) + (assert (null registers)) (lambda (jumper) (assert (= 0 (mod jumper 4))) (bt:enum-value 'movitz::atomically-status

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp
by Frode Vatvedt Fjeld 20 Sep '04

20 Sep '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv21918 Modified Files: integers.lisp Log Message: Removed some dead code. Date: Mon Sep 20 10:06:54 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.94 movitz/losp/muerte/integers.lisp:1.95 --- movitz/losp/muerte/integers.lisp:1.94 Wed Sep 15 12:22:59 2004 +++ movitz/losp/muerte/integers.lisp Mon Sep 20 10:06:53 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.94 2004/09/15 10:22:59 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.95 2004/09/20 08:06:53 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -481,72 +481,7 @@ ((positive-bignum positive-fixnum) (+ y x)) ((positive-fixnum positive-bignum) - (bignum-add-fixnum y x) - #+ignore - (with-inline-assembly (:returns :eax :labels (retry-not-size1 - not-size1 - copy-bignum-loop - add-bignum-loop - add-bignum-done - no-expansion - pfix-pbig-done)) - (:compile-two-forms (:eax :ebx) y x) - (:testl :ebx :ebx) - (:jz 'pfix-pbig-done) - (:movzxw (:eax (:offset movitz-bignum length)) :ecx) - (:cmpl ,movitz:+movitz-fixnum-factor+ :ecx) - (:jne 'not-size1) - (:compile-form (:result-mode :ecx) x) - (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) - (:addl (:eax (:offset movitz-bignum bigit0)) :ecx) - (:jc 'retry-not-size1) - (:call-local-pf box-u32-ecx) - (:jmp 'pfix-pbig-done) - retry-not-size1 - (:compile-form (:result-mode :eax) y) - (:movzxw (:eax (:offset movitz-bignum length)) :ecx) - not-size1 - (:declare-label-set retry-jumper (retry-not-size1)) - (:locally (:movl :esp (:edi (:edi-offset atomically-esp)))) - (:locally (:movl '(:funcall ,(movitz::atomically-status-jumper-fn t :esp) - 'retry-jumper) - (:edi (:edi-offset atomically-status)))) - (:leal ((:ecx 1) ,(* 2 movitz:+movitz-fixnum-factor+)) - :eax) ; Number of words - (:call-local-pf get-cons-pointer) - (:load-lexical (:lexical-binding y) :ebx) ; bignum - (:movzxw (:ebx (:offset movitz-bignum length)) :ecx) - (:leal ((:ecx 1) ,movitz:+movitz-fixnum-factor+) - :edx) - (:movl 0 (:eax :edx ,movitz:+other-type-offset+)) ; MSB - copy-bignum-loop - (:subl ,movitz:+movitz-fixnum-factor+ :edx) - (:movl (:ebx :edx ,movitz:+other-type-offset+) :ecx) - (:movl :ecx (:eax :edx ,movitz:+other-type-offset+)) - (:jnz 'copy-bignum-loop) - - (:load-lexical (:lexical-binding x) :ecx) - (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) - (:xorl :ebx :ebx) - (:addl :ecx (:eax (:offset movitz-bignum bigit0))) - (:jnc 'add-bignum-done) - add-bignum-loop - (:addl 4 :ebx) - (:addl 1 (:eax :ebx (:offset movitz-bignum bigit0))) - (:jc 'add-bignum-loop) - add-bignum-done - (:movzxw (:eax (:offset movitz-bignum length)) :ecx) - (:leal ((:ecx 1) ,movitz:+movitz-fixnum-factor+) :ecx) - (:cmpl 0 (:eax :ecx (:offset movitz-bignum bigit0 -4))) - (:je 'no-expansion) - (:addl #x40000 (:eax ,movitz:+other-type-offset+)) - (:addl ,movitz:+movitz-fixnum-factor+ :ecx) - no-expansion - (:call-local-pf cons-commit) - (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) - (:edi (:edi-offset atomically-status)))) - - pfix-pbig-done)) + (bignum-add-fixnum y x)) ((positive-bignum negative-fixnum) (+ y x)) ((negative-fixnum positive-bignum)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp
by Frode Vatvedt Fjeld 17 Sep '04

17 Sep '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv6357 Modified Files: scavenge.lisp Log Message: Re-working of non-local control transfer so as to comply with the stack discipline. Date: Fri Sep 17 13:13:05 2004 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.29 movitz/losp/muerte/scavenge.lisp:1.30 --- movitz/losp/muerte/scavenge.lisp:1.29 Wed Sep 15 12:22:59 2004 +++ movitz/losp/muerte/scavenge.lisp Fri Sep 17 13:13:05 2004 @@ -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.29 2004/09/15 10:22:59 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.30 2004/09/17 11:13:05 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -130,6 +130,7 @@ ((scavenge-typep x :old-vector) (error "Scanned old-vector ~Z at address #x~X." x scan)) ((eq x 3) + (setf *scan-last* scan) (incf scan) (let ((delta (memref scan 0 0 :lisp))) (check-type delta positive-fixnum) @@ -206,16 +207,14 @@ (cond ((location-in-object-p casf-code-vector (dit-frame-ref stack dit-frame :eip :location)) - #+ignore - (break "DIT at throw situation, in target EIP=~S" - (dit-frame-ref stack dit-frame :eip :unsigned-byte32)) + (warn "DIT at throw situation, in target EIP=~S" + (dit-frame-ref stack dit-frame :eip :unsigned-byte32)) (map-heap-words function interrupted-esp frame)) ((location-in-object-p (funobj-code-vector (dit-frame-ref stack dit-frame :scratch1)) (dit-frame-ref stack dit-frame :eip :location)) - #+ignore - (break "DIT at throw situation, in thrower EIP=~S" - (dit-frame-ref stack dit-frame :eip :unsigned-byte32)) + (warn "DIT at throw situation, in thrower EIP=~S" + (dit-frame-ref stack dit-frame :eip :unsigned-byte32)) (map-heap-words function interrupted-esp frame)) (t (error "DIT with EBP<ESP, EBP=~S, ESP=~S" interrupted-ebp

1 0

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

17 Sep '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv6322 Modified Files: primitive-functions.lisp Log Message: Re-working of non-local control transfer so as to comply with the stack discipline. Date: Fri Sep 17 13:12:58 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.42 movitz/losp/muerte/primitive-functions.lisp:1.43 --- movitz/losp/muerte/primitive-functions.lisp:1.42 Wed Sep 15 12:22:59 2004 +++ movitz/losp/muerte/primitive-functions.lisp Fri Sep 17 13:12:57 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.42 2004/09/15 10:22:59 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.43 2004/09/17 11:12:57 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -110,6 +110,34 @@ ;;; -28: cdr ;;; -32: car ... +(define-primitive-function dynamic-unwind-next (dynamic-env) + "Locate the next unwind-protect entry between here and dynamic-env. +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." + (with-inline-assembly (:returns :nothing) + (:locally (:bound (:edi (:edi-offset stack-bottom)) :eax)) + + (:globally (:movl (:edi (:edi-offset unwind-protect-tag)) :edx)) + (:locally (:movl (:edi (:edi-offset dynamic-env)) :ecx)) + + search-loop + (:jecxz '(:sub-program () (:halt) (:int 63))) ; XXX don't halt + (:locally (:bound (:edi (:edi-offset stack-bottom)) :ecx)) + + (:cmpl :ecx :eax) + (:je 'found-dynamic-env) + + (:cmpl :edx (:ecx 4)) ; unwind-protect entry? + (:je 'found-unwind-protect) + + (:movl (:ecx 12) :ecx) ; proceed search + (:jmp 'search-loop) + found-unwind-protect + (:movl :ecx :eax) + (:stc) + found-dynamic-env + (:ret))) + (define-primitive-function dynamic-locate-catch-tag (tag) "Search the dynamic environment for a catch slot matching <tag> in EAX. @@ -119,10 +147,10 @@ this functions returns with EAX pointing to the dynamic-slot for tag, and with carry set. 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 :push) - (:pushl :ebp) - (:movl :esp :ebp) ; set up a pseudo stack-frame - (:pushl :edi) + (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)) @@ -139,50 +167,52 @@ (: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) +;;; (: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 #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::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) +;;; (: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) +;;; (:leave) ; exit pseudo stack-frame +;;; (:movl (:ebp -4) :esi) (:ret))) ; return. (define-primitive-function dynamic-unwind ()

1 0

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

17 Sep '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv6304 Modified Files: image.lisp Log Message: Re-working of non-local control transfer so as to comply with the stack discipline. Date: Fri Sep 17 13:12:55 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.68 movitz/image.lisp:1.69 --- movitz/image.lisp:1.68 Thu Sep 16 10:50:54 2004 +++ movitz/image.lisp Fri Sep 17 13:12:55 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.68 2004/09/16 08:50:54 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.69 2004/09/17 11:12:55 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -470,7 +470,12 @@ :initform '(:inactive)) (atomically-esp :binary-type lu32 - :initform 0)) + :initform 0) + (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)) (:slot-align null-symbol -5)) (defun atomically-status-simple-pf (pf-name reset-status-p &rest registers)

1 0

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

17 Sep '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv6279 Modified Files: special-operators.lisp Log Message: Re-working of non-local control transfer so as to comply with the stack discipline. Date: Fri Sep 17 13:12:49 2004 Author: ffjeld Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.38 movitz/special-operators.lisp:1.39 --- movitz/special-operators.lisp:1.38 Wed Sep 15 12:22:52 2004 +++ movitz/special-operators.lisp Fri Sep 17 13:12:49 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.38 2004/09/15 10:22:52 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.39 2004/09/17 11:12:49 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1178,9 +1178,14 @@ (destructuring-bind (tag context value-form) (cdr form) (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-"))))) + (dynamic-slot-binding + (movitz-env-add-binding local-env + (make-instance 'located-binding + :name (gensym "dynamic-slot-")))) + (next-continuation-step-binding + (movitz-env-add-binding local-env + (make-instance 'located-binding + :name (gensym "continuation-step-"))))) (with-labels (throw (save-tag-var save-context-var)) (compiler-values () :returns :non-local-exit @@ -1196,7 +1201,9 @@ (: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 + (:globally (:call (:edi (:edi-offset dynamic-unwind-next)))) + (:store-lexical ,next-continuation-step-binding :eax :type t) + )))) ;; now outside of m-v-prog1's cloak, with final dynamic-slot in ESP.. ;; ..unwind it and transfer control. ;; @@ -1207,11 +1214,14 @@ ;;; `((:load-lexical ,dynamic-slot-binding :edx) ;;; ()) `((:load-lexical ,dynamic-slot-binding :edx) + (:locally (:movl :edx (:edi (:edi-offset raw-scratch0)))) ; final continuation + (:load-lexical ,next-continuation-step-binding :edx) ; next continuation-step (:locally (:movl :esi (:edi (:edi-offset scratch1)))) + (:locally (:movl :edx (:edi (:edi-offset dynamic-env)))) ; exit dynamic-env (:movl :edx :esp) ; enter non-local jump stack mode. (:movl (:esp) :edx) ; target stack-frame EBP - (:movl (:edx -4) :esi) ; get target funobj into EDX + (:movl (:edx -4) :esi) ; get target funobj into ESI (:movl (:esp 8) :edx) ; target jumper number (:jmp (:esi :edx ,(slot-offset 'movitz-funobj 'constant0)))))))))) @@ -1293,7 +1303,8 @@ :form body) `((:leal (:esp ,(+ -12 -4 (* 4 entry-size))) :esp) ,exit-point + (:movl (:esp 12) :edx) + (:locally (:movl :edx (:edi (:edi-offset dynamic-env)))) (:popl :ebp) - (:leal (:esp 8) :esp) - (:locally (:popl (:edi (:edi-offset dynamic-env)))) + (:leal (:esp 12) :esp) )))))))

1 0

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

17 Sep '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv6262 Modified Files: special-operators-cl.lisp Log Message: Re-working of non-local control transfer so as to comply with the stack discipline. Date: Fri Sep 17 13:12:47 2004 Author: ffjeld Index: movitz/special-operators-cl.lisp diff -u movitz/special-operators-cl.lisp:1.23 movitz/special-operators-cl.lisp:1.24 --- movitz/special-operators-cl.lisp:1.23 Wed Sep 15 12:22:52 2004 +++ movitz/special-operators-cl.lisp Fri Sep 17 13:12: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.23 2004/09/15 10:22:52 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.24 2004/09/17 11:12:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -291,6 +291,10 @@ (progn #+ignore (warn "recompile..") (compile-body))) (when (plusp (num-specials local-env)) + `((:movl (:esp ,(+ -4 (* 16 (num-specials local-env)))) :edx) + (: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))))))))) (compiler-values (body-values) @@ -1183,48 +1187,90 @@ (:locally (:movl :esp (:edi (:edi-offset dynamic-env))))) ; install catch body-code `(,exit-point + (:movl (:esp 12) :edx) + (:locally (:movl :edx (:edi (:edi-offset dynamic-env)))) (:popl :ebp) - (:leal (:esp 8) :esp) ; Skip catch-tag and jumper - (:locally (:popl (:edi (:edi-offset dynamic-env))))))))) + (:leal (:esp 12) :esp) + ))))) (define-special-operator unwind-protect (&all all &form form &env env) (destructuring-bind (protected-form &body cleanup-forms) (cdr form) - (let ((up-env (make-instance 'unwind-protect-env - :uplink env - :funobj (movitz-environment-funobj env)))) - (with-labels (unwind-protect (cleanup-label cleanup-entry)) - (compiler-call #'compile-form - :result-mode :multiple-values - :forward all - :form `(muerte.cl::multiple-value-prog1 - (muerte::with-progn-results (:ignore :multiple-values) - (muerte::with-inline-assembly-case () - (do-case (t :multiple-values) - ;; install up dynamic-env.. - (:locally (:pushl (:edi (:edi-offset dynamic-env)))) - (:declare-label-set ,cleanup-label (,cleanup-entry)) - (:pushl ',cleanup-label) ; jumper index - (:globally (:pushl (:edi (:edi-offset unwind-protect-tag)))) ; tag - (:pushl :ebp) ; stack-frame - (:locally (:movl :esp (:edi (:edi-offset dynamic-env)))))) ; install up-env - (muerte::with-local-env (,up-env) - ,protected-form) - (muerte::with-inline-assembly-case () - (do-case (t :multiple-values) - ;; uninstall dynamic-env.. - (:leal (:esp ,(- 16 4)) :esp) - (:locally (:popl (:edi (:edi-offset dynamic-env))))))) - (muerte::with-inline-assembly-case () - (do-case (t :nothing) - ;; execute cleanup-forms - (:call '(:sub-program (,cleanup-entry) ; label - ,@(compiler-call #'compile-form - :with-stack-used t ; stack distance is _really_ unknown! - :defaults all - :result-mode :ignore - :form `(muerte.cl::progn ,@cleanup-forms)) - (:ret))))))))))) + (let* ((continuation-env (make-instance 'let-env + :uplink env + :funobj (movitz-environment-funobj env))) + (next-continuation-step-binding + (movitz-env-add-binding continuation-env + (make-instance 'located-binding + :name (gensym "up-next-continuation-step-")))) + (unwind-protect-env (make-instance 'unwind-protect-env + :uplink continuation-env + :funobj (movitz-environment-funobj env)))) + (with-labels (unwind-protect (cleanup-label cleanup-entry continue continue-label)) + (compiler-values () + :returns :multiple-values + :code (append + ;; install default continuation dynamic-env.. + `((:locally (:pushl (:edi (:edi-offset dynamic-env)))) ; uplink + (:declare-label-set ,continue-label (,continue)) + (:pushl ',continue-label) + (:locally (:pushl (:edi (:edi-offset unbound-value)))) + (:pushl :ebp) + (:locally (:movl :esp (:edi (:edi-offset dynamic-env))))) + ;; install unwind-protect dynamic-env.. + `((:locally (:pushl (:edi (:edi-offset dynamic-env)))) + (:declare-label-set ,cleanup-label (,cleanup-entry)) + (:pushl ',cleanup-label) ; jumper index + (:globally (:pushl (:edi (:edi-offset unwind-protect-tag)))) ; tag + (:pushl :ebp) ; stack-frame + (:locally (:movl :esp (:edi (:edi-offset dynamic-env))))) ; install up-env + ;; Execute protected form.. + (compiler-call #'compile-form + :env unwind-protect-env + :with-stack-used t + :forward all + :result-mode :multiple-values + :form protected-form) + ;; From now on, take care not to touch current-values from protected-form. + `((:leal (:esp 16) :edx) ; default final continuation + (:locally (:movl :edx (:edi (:edi-offset raw-scratch0)))) + ,cleanup-entry + (:movl (:esp 12) :edx) ; pop out of unwind-protect + (:locally (:movl :edx (:edi (:edi-offset dynamic-env)))) + (:popl :ebp) + (:leal (:esp 12) :esp) + (:locally (:pushl (:edi (:edi-offset raw-scratch0))))) ; push final-continuation + ;; Execute cleanup-forms. + (compiler-call #'compile-form-unprotected + :forward all + :env continuation-env + :with-stack-used t + :result-mode :multiple-values + :form `(muerte::with-cloak (:multiple-values) + ;; Inside here we don't have to mind current-values. + (muerte::with-inline-assembly (:returns :nothing) + ;; First, find next-continuation-step.. + (:locally (:movl (:edi (:edi-offset raw-scratch0)) :eax)) ; final-cont.. + (:locally (:call (:edi (:edi-offset dynamic-unwind-next)))) + (:locally (:bound (:edi (:edi-offset stack-bottom)) :eax)) + (:store-lexical ,next-continuation-step-binding :eax :type t)) + ,@cleanup-forms)) + `((:load-lexical ,next-continuation-step-binding :edx) + (:locally (:popl (:edi (:edi-offset raw-scratch0)))) ; pop final continuation + (:locally (:movl :esi (:edi (:edi-offset scratch1)))) + (:locally (:movl :edx (:edi (:edi-offset dynamic-env)))) + (:movl :edx :esp) ; enter non-local jump stack mode (possibly). + + (:movl (:esp) :edx) ; target stack-frame EBP + (:movl (:edx -4) :esi) ; get target funobj into EDX + + (:movl (:esp 8) :edx) ; target jumper number + (:jmp (:esi :edx ,(slot-offset 'movitz-funobj 'constant0)))) + `(,continue + (:movl (:esp 12) :edx) + (:locally (:movl :edx (:edi (:edi-offset dynamic-env)))) + (:popl :ebp) + (:leal (:esp 12) :esp)))))))) (define-special-operator if (&all all &form form &env env &result-mode result-mode)

1 0

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

17 Sep '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv5966 Modified Files: memref.lisp Log Message: Fixed the memref-int :unsigned-byte16 accessor wrt. register discipline. Date: Fri Sep 17 13:06:47 2004 Author: ffjeld Index: movitz/losp/muerte/memref.lisp diff -u movitz/losp/muerte/memref.lisp:1.29 movitz/losp/muerte/memref.lisp:1.30 --- movitz/losp/muerte/memref.lisp:1.29 Wed Sep 15 12:22:59 2004 +++ movitz/losp/muerte/memref.lisp Fri Sep 17 13:06:47 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.29 2004/09/15 10:22:59 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.30 2004/09/17 11:06:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -715,12 +715,14 @@ (:unsigned-byte16 (cond ((and (eq 0 offset) (eq 0 index)) - `(with-inline-assembly (:returns :untagged-fixnum-ecx) + `(with-inline-assembly (:returns :untagged-fixnum-ecx + :type (unsigned-byte 16)) (:compile-form (:result-mode :untagged-fixnum-ecx) ,address) (,prefixes :movzxw (:ecx) :ecx))) (t (let ((address-var (gensym "memref-int-address-"))) `(let ((,address-var ,address)) - (with-inline-assembly (:returns :untagged-fixnum-ecx) + (with-inline-assembly (:returns :untagged-fixnum-ecx + :type (unsigned-byte 16)) (:compile-two-forms (:eax :ecx) ,offset ,index) (:load-lexical (:lexical-binding ,address-var) :ebx) (:shll 1 :ecx) ; scale index @@ -820,7 +822,7 @@ `(let ((,value-var ,value) (,address-var ,address) (,index-var ,index)) - (with-inline-assembly (:returns :untagged-fixnum-eax) + (with-inline-assembly (:returns :eax) (:load-lexical (:lexical-binding ,value-var) :eax) ; value (:load-lexical (:lexical-binding ,index-var) :ebx) ; index (:load-lexical (:lexical-binding ,address-var) :ecx) ; address @@ -840,7 +842,7 @@ (,address-var ,address) (,offset-var ,offset) (,index-var ,index)) - (with-inline-assembly (:returns :untagged-fixnum-eax) + (with-inline-assembly (:returns :eax) (:load-lexical (:lexical-binding ,address-var) :ecx) (:load-lexical (:lexical-binding ,index-var) :ebx) (:load-lexical (:lexical-binding ,offset-var) :edx)

1 0