movitz-cvs September 2004

movitz-cvs@common-lisp.net

1 participants
91 discussions

[movitz-cvs] CVS update: movitz/losp/muerte/arithmetic-macros.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-serv21806 Modified Files: arithmetic-macros.lisp Log Message: Re-wrote the + compiler-macro. It actually failed before on some forms. Date: Tue Sep 21 15:09:40 2004 Author: ffjeld Index: movitz/losp/muerte/arithmetic-macros.lisp diff -u movitz/losp/muerte/arithmetic-macros.lisp:1.6 movitz/losp/muerte/arithmetic-macros.lisp:1.7 --- movitz/losp/muerte/arithmetic-macros.lisp:1.6 Wed Aug 4 14:59:18 2004 +++ movitz/losp/muerte/arithmetic-macros.lisp Tue Sep 21 15:09:40 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Jul 17 13:42:46 2004 ;;;; -;;;; $Id: arithmetic-macros.lisp,v 1.6 2004/08/04 12:59:18 ffjeld Exp $ +;;;; $Id: arithmetic-macros.lisp,v 1.7 2004/09/21 13:09:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -47,23 +47,21 @@ (2 `(let ((x ,(first operands)) (y ,(second operands))) (++%2op x y))) - (t (let ((operands - (loop for operand in operands - if (movitz:movitz-constantp operand env) - sum (movitz:movitz-eval operand env) - into constant-term - else collect operand - into non-constant-operands - finally (return (if (zerop constant-term) - non-constant-operands - (cons constant-term non-constant-operands)))))) + (t (multiple-value-bind (constant-term non-constants) + (loop for operand in operands + if (movitz:movitz-constantp operand env) + sum (movitz:movitz-eval operand env) into constant-term + else collect operand into non-constant-operands + finally (return (values constant-term non-constant-operands))) (cond - ((null operands) - 0) - ((not (cdr operands)) - (check-type (car operands) integer) - (car operands)) - (t `(+ (+ ,(first operands) ,(second operands)) ,@(cddr operands)))))))) + ((null non-constants) + constant-term) + ((and (= 0 constant-term) + (not (cdr non-constants))) + (car non-constants)) + ((= 0 constant-term) + `(+ (+ ,(first non-constants) ,(second non-constants)) ,@(cddr non-constants))) + (t `(+ (+ ,constant-term ,(first non-constants)) ,@(cdr non-constants)))))))) (define-compiler-macro 1+ (number) `(+ 1 ,number))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/bignums.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-serv17883 Modified Files: bignums.lisp Log Message: Re-worked the atomically protocol. There is now one run-time-context field, atomically-continuation, whose semantics is slightly different from the old atomically-status and atomically-esp. Date: Tue Sep 21 15:06:46 2004 Author: ffjeld Index: movitz/losp/muerte/bignums.lisp diff -u movitz/losp/muerte/bignums.lisp:1.7 movitz/losp/muerte/bignums.lisp:1.8 --- movitz/losp/muerte/bignums.lisp:1.7 Wed Sep 15 12:22:59 2004 +++ movitz/losp/muerte/bignums.lisp Tue Sep 21 15:06:45 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Jul 17 19:42:57 2004 ;;;; -;;;; $Id: bignums.lisp,v 1.7 2004/09/15 10:22:59 ffjeld Exp $ +;;;; $Id: bignums.lisp,v 1.8 2004/09/21 13:06:45 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -102,8 +102,7 @@ (check-type delta fixnum) (macrolet ((do-it () - `(with-inline-assembly (:returns :eax :labels (retry-not-size1 - not-size1 + `(with-inline-assembly (:returns :eax :labels (not-size1 copy-bignum-loop add-bignum-loop add-bignum-done @@ -111,25 +110,33 @@ pfix-pbig-done)) (:compile-two-forms (:eax :ebx) bignum delta) (:testl :ebx :ebx) - (:jz 'pfix-pbig-done) + (:jz 'pfix-pbig-done) ; EBX=0 => nothing to do. (:movzxw (:eax (:offset movitz-bignum length)) :ecx) (:cmpl ,movitz:+movitz-fixnum-factor+ :ecx) (:jne 'not-size1) (:compile-form (:result-mode :ecx) delta) (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) (:addl (:eax (:offset movitz-bignum bigit0)) :ecx) - (:jc 'retry-not-size1) + (:jc 'not-size1) (:call-local-pf box-u32-ecx) (:jmp 'pfix-pbig-done) - retry-not-size1 + + not-size1 + ;; Set up atomically continuation. + (:declare-label-set restart-jumper (restart-addition)) + (:locally (:pushl (:edi (:edi-offset :dynamic-env)))) + (:pushl 'restart-jumper) + ;; ..this allows us to detect recursive atomicallies. + (:locally (:pushl (:edi (:edi-offset :atomically-continuation)))) + (:pushl :ebp) + restart-addition + + (:movl (:esp) :ebp) (:compile-form (:result-mode :eax) bignum) (: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)))) + + (:locally (:movl :esp (:edi (:edi-offset :atomically-continuation)))) + ;; Now inside atomically section. (:leal ((:ecx 1) ,(* 2 movitz:+movitz-fixnum-factor+)) :eax) ; Number of words (:call-local-pf get-cons-pointer) @@ -162,9 +169,10 @@ (: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)))) - + ;; Exit atomically block. + (:locally (:movl 0 (:edi (:edi-offset atomically-continuation)))) + (:leal (:esp 16) :esp) + pfix-pbig-done))) (do-it)))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/functions.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-serv17683 Modified Files: functions.lisp Log Message: Re-worked the atomically protocol. There is now one run-time-context field, atomically-continuation, whose semantics is slightly different from the old atomically-status and atomically-esp. Date: Tue Sep 21 15:06:36 2004 Author: ffjeld Index: movitz/losp/muerte/functions.lisp diff -u movitz/losp/muerte/functions.lisp:1.19 movitz/losp/muerte/functions.lisp:1.20 --- movitz/losp/muerte/functions.lisp:1.19 Wed Sep 15 12:22:59 2004 +++ movitz/losp/muerte/functions.lisp Tue Sep 21 15:06:36 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Mar 12 22:58:54 2002 ;;;; -;;;; $Id: functions.lisp,v 1.19 2004/09/15 10:22:59 ffjeld Exp $ +;;;; $Id: functions.lisp,v 1.20 2004/09/21 13:06:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -111,17 +111,26 @@ (defun funobj-code-vector%1op (funobj) "This slot is not a lisp value, it is a direct address to code entry point. In practice it is either a pointer into the regular code-vector, or it points (with offset 2) to another vector entirely. -The former is represented as a lisp integer that is the index into the code-vector, the latter is represented -as that vector." +The former is represented as a lisp integer that is the index into the code-vector, the latter is +represented as that vector." (check-type funobj function) (with-inline-assembly (:returns :eax) + ;; Set up atomically continuation. + (:declare-label-set restart-jumper (retry)) + (:locally (:pushl (:edi (:edi-offset :dynamic-env)))) + (:pushl 'restart-jumper) + ;; ..this allows us to detect recursive atomicallies. + (:locally (:pushl (:edi (:edi-offset :atomically-continuation)))) + (:pushl :ebp) retry - (:declare-label-set retry-jumper (retry)) - (:locally (:movl '(:funcall #.(movitz::atomically-status-jumper-fn t) - 'retry-jumper) - (:edi (:edi-offset atomically-status)))) + + (:movl (:esp) :ebp) (:compile-form (:result-mode :ebx) funobj) (:movl (:ebx (:offset movitz-funobj code-vector)) :eax) ; EAX = code-vector + + (:locally (:movl :esp (:edi (:edi-offset :atomically-continuation)))) + ;; Now inside atomically section. + (:movl (:ebx (:offset movitz-funobj code-vector%1op)) :ecx) ;; determine if ECX is a pointer into EBX (:subl :eax :ecx) @@ -138,8 +147,8 @@ (:movl #xfffffffe :eax) (:addl (:ebx (:offset movitz-funobj code-vector%1op)) :eax) done - (:locally (:movl #.(bt:enum-value 'movitz::atomically-status :inactive) - (:edi (:edi-offset atomically-status)))))) ; this cell stores word+2 + (:locally (:movl 0 (:edi (:edi-offset atomically-continuation)))) + (:leal (:esp 16) :esp))) (defun (setf funobj-code-vector%1op) (code-vector funobj) (check-type funobj function) @@ -163,17 +172,26 @@ (defun funobj-code-vector%2op (funobj) "This slot is not a lisp value, it is a direct address to code entry point. In practice it is either a pointer into the regular code-vector, or it points (with offset 2) to another vector entirely. -The former is represented as a lisp integer that is the index into the code-vector, the latter is represented -as that vector." +The former is represented as a lisp integer that is the index into the code-vector, the latter is +represented as that vector." (check-type funobj function) (with-inline-assembly (:returns :eax) + ;; Set up atomically continuation. + (:declare-label-set restart-jumper (retry)) + (:locally (:pushl (:edi (:edi-offset :dynamic-env)))) + (:pushl 'restart-jumper) + ;; ..this allows us to detect recursive atomicallies. + (:locally (:pushl (:edi (:edi-offset :atomically-continuation)))) + (:pushl :ebp) retry - (:declare-label-set retry-jumper (retry)) - (:locally (:movl '(:funcall #.(movitz::atomically-status-jumper-fn t) - 'retry-jumper) - (:edi (:edi-offset atomically-status)))) + + (:movl (:esp) :ebp) (:compile-form (:result-mode :ebx) funobj) (:movl (:ebx (:offset movitz-funobj code-vector)) :eax) ; EAX = code-vector + + (:locally (:movl :esp (:edi (:edi-offset :atomically-continuation)))) + ;; Now inside atomically section. + (:movl (:ebx (:offset movitz-funobj code-vector%2op)) :ecx) ;; determine if ECX is a pointer into EBX (:subl :eax :ecx) @@ -190,8 +208,8 @@ (:movl #xfffffffe :eax) (:addl (:ebx (:offset movitz-funobj code-vector%2op)) :eax) done - (:locally (:movl #.(bt:enum-value 'movitz::atomically-status :inactive) - (:edi (:edi-offset atomically-status)))))) + (:locally (:movl 0 (:edi (:edi-offset atomically-continuation)))) + (:leal (:esp 16) :esp))) (defun (setf funobj-code-vector%2op) (code-vector funobj) (check-type funobj function) @@ -215,17 +233,26 @@ (defun funobj-code-vector%3op (funobj) "This slot is not a lisp value, it is a direct address to code entry point. In practice it is either a pointer into the regular code-vector, or it points (with offset 2) to another vector entirely. -The former is represented as a lisp integer that is the index into the code-vector, the latter is represented -as that vector." +The former is represented as a lisp integer that is the index into the code-vector, the latter is +represented as that vector." (check-type funobj function) (with-inline-assembly (:returns :eax) + ;; Set up atomically continuation. + (:declare-label-set restart-jumper (retry)) + (:locally (:pushl (:edi (:edi-offset :dynamic-env)))) + (:pushl 'restart-jumper) + ;; ..this allows us to detect recursive atomicallies. + (:locally (:pushl (:edi (:edi-offset :atomically-continuation)))) + (:pushl :ebp) retry - (:declare-label-set retry-jumper (retry)) - (:locally (:movl '(:funcall #.(movitz::atomically-status-jumper-fn t) - 'retry-jumper) - (:edi (:edi-offset atomically-status)))) + + (:movl (:esp) :ebp) (:compile-form (:result-mode :ebx) funobj) (:movl (:ebx (:offset movitz-funobj code-vector)) :eax) ; EAX = code-vector + + (:locally (:movl :esp (:edi (:edi-offset :atomically-continuation)))) + ;; Now inside atomically section. + (:movl (:ebx (:offset movitz-funobj code-vector%3op)) :ecx) ;; determine if ECX is a pointer into EBX (:subl :eax :ecx) @@ -242,8 +269,8 @@ (:movl #xfffffffe :eax) (:addl (:ebx (:offset movitz-funobj code-vector%3op)) :eax) done - (:locally (:movl #.(bt:enum-value 'movitz::atomically-status :inactive) - (:edi (:edi-offset atomically-status)))))) + (:locally (:movl 0 (:edi (:edi-offset atomically-continuation)))) + (:leal (:esp 16) :esp))) (defun (setf funobj-code-vector%3op) (code-vector funobj) (check-type funobj function) @@ -393,37 +420,7 @@ (:cmpl :ebx :edx) (:ja 'init-loop) init-done - (:leal (:edx ,(bt:sizeof 'movitz:movitz-funobj)) :ecx)) - #+ignore - `(with-inline-assembly (:returns :eax :labels (retry-alloc retry-jumper)) - (:declare-label-set retry-jumper (retry-alloc)) - retry-alloc - (:locally (:movl '(:funcall ,(movitz::atomically-status-jumper-fn t :esp) - 'retry-jumper) - (:edi (:edi-offset atomically-status)))) - (:compile-form (:result-mode :eax) - (+ num-constants - #.(cl:truncate (bt:sizeof 'movitz:movitz-funobj) 4))) - (:call-local-pf get-cons-pointer) - (:movl #.(movitz:tag :funobj) (:eax #.movitz:+other-type-offset+)) - (:load-lexical (:lexical-binding num-constants) :edx) - (:movl :edx :ecx) - (:shll #.(cl:- 16 movitz:+movitz-fixnum-shift+) :ecx) - (:movl :ecx (:eax (:offset movitz-funobj num-jumpers))) - (:xorl :ecx :ecx) - (:xorl :ebx :ebx) - (:testl :edx :edx) - (:jmp 'init-done) - init-loop - (:movl :ecx (:eax :ebx #.movitz:+other-type-offset+)) - (:addl 4 :ebx) - (:cmpl :ebx :edx) - (:ja 'init-loop) - init-done - (:leal (:edx #.(bt:sizeof 'movitz:movitz-funobj)) :ecx) - (:call-local-pf cons-commit) - (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) - (:edi (:edi-offset atomically-status))))))) + (:leal (:edx ,(bt:sizeof 'movitz:movitz-funobj)) :ecx)))) (do-it)))) (setf (funobj-name funobj) name (funobj-code-vector funobj) code-vector

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.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-serv17518 Modified Files: basic-macros.lisp Log Message: Re-worked the atomically protocol. There is now one run-time-context field, atomically-continuation, whose semantics is slightly different from the old atomically-status and atomically-esp. Date: Tue Sep 21 15:06:28 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.39 movitz/losp/muerte/basic-macros.lisp:1.40 --- movitz/losp/muerte/basic-macros.lisp:1.39 Wed Sep 15 12:22:59 2004 +++ movitz/losp/muerte/basic-macros.lisp Tue Sep 21 15:06:27 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: basic-macros.lisp,v 1.39 2004/09/15 10:22:59 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.40 2004/09/21 13:06:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1077,19 +1077,24 @@ `(let ((,size-var ,size-form)) (with-inline-assembly (:returns :eax :labels (retry-alloc retry-jumper ,@labels)) (:declare-label-set retry-jumper (retry-alloc)) + ;; Set up atomically continuation. + (:locally (:pushl (:edi (:edi-offset :dynamic-env)))) + (:pushl 'retry-jumper) + ;; ..this allows us to detect recursive atomicallies. + (:locally (:pushl (:edi (:edi-offset :atomically-continuation)))) + (:pushl :ebp) retry-alloc - (: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)))) + (:movl (:esp) :ebp) (:load-lexical (:lexical-binding ,size-var) :eax) + (:locally (:movl :esp (:edi (:edi-offset :atomically-continuation)))) + ;; Now inside atomically section. (:call-local-pf get-cons-pointer) ,@code ,@(when fixed-size-p `((:load-lexical (:lexical-binding ,size-var) :ecx))) (:call-local-pf cons-commit) - (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) - (:edi (:edi-offset atomically-status)))))))) + (:locally (:movl 0 (:edi (:edi-offset atomically-continuation)))) + (:leal (:esp 16) :esp))))) (defmacro with-non-pointer-allocation-assembly ((size-form &key object-register size-register fixed-size-p labels) &body code) @@ -1099,19 +1104,24 @@ `(let ((,size-var ,size-form)) (with-inline-assembly (:returns :eax :labels (retry-alloc retry-jumper ,@labels)) (:declare-label-set retry-jumper (retry-alloc)) + ;; Set up atomically continuation. + (:locally (:pushl (:edi (:edi-offset :dynamic-env)))) + (:pushl 'retry-jumper) + ;; ..this allows us to detect recursive atomicallies. + (:locally (:pushl (:edi (:edi-offset :atomically-continuation)))) + (:pushl :ebp) retry-alloc - (: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)))) + (:movl (:esp) :ebp) (:load-lexical (:lexical-binding ,size-var) :eax) + (:locally (:movl :esp (:edi (:edi-offset :atomically-continuation)))) + ;; Now inside atomically section. (:call-local-pf get-cons-pointer-non-pointer) ,@code ,@(when fixed-size-p `((:load-lexical (:lexical-binding ,size-var) :ecx))) - (:call-local-pf cons-commit-non-pointer) - (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) - (:edi (:edi-offset atomically-status)))))))) + (:call-local-pf cons-commit) + (:locally (:movl 0 (:edi (:edi-offset atomically-continuation)))) + (:leal (:esp 16) :esp))))) (require :muerte/setf)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/integers.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-serv17359 Modified Files: integers.lisp Log Message: Re-worked the atomically protocol. There is now one run-time-context field, atomically-continuation, whose semantics is slightly different from the old atomically-status and atomically-esp. Date: Tue Sep 21 15:06:21 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.95 movitz/losp/muerte/integers.lisp:1.96 --- movitz/losp/muerte/integers.lisp:1.95 Mon Sep 20 10:06:53 2004 +++ movitz/losp/muerte/integers.lisp Tue Sep 21 15:06:20 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.95 2004/09/20 08:06:53 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.96 2004/09/21 13:06:20 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -485,7 +485,7 @@ ((positive-bignum negative-fixnum) (+ y x)) ((negative-fixnum positive-bignum) - (with-inline-assembly (:returns :eax :labels (retry-not-size1 + (with-inline-assembly (:returns :eax :labels (restart-addition retry-jumper not-size1 copy-bignum-loop @@ -502,15 +502,23 @@ (:addl (:eax (:offset movitz-bignum bigit0)) :ecx) (:call-local-pf box-u32-ecx) (:jmp 'pfix-pbig-done) - retry-not-size1 + + not-size1 + (:declare-label-set retry-jumper (restart-addition)) + (:locally (:pushl (:edi (:edi-offset :dynamic-env)))) + (:pushl 'retry-jumper) + ;; ..this allows us to detect recursive atomicallies. + (:locally (:pushl (:edi (:edi-offset :atomically-continuation)))) + (:pushl :ebp) + + restart-addition + (:movl (:esp) :ebp) (: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)))) + + (:locally (:movl :esp (:edi (:edi-offset :atomically-continuation)))) + ;; Now inside atomically section. + (:leal ((:ecx 1) ,(* 1 movitz:+movitz-fixnum-factor+)) :eax) ; Number of words (:call-local-pf get-cons-pointer) @@ -545,15 +553,15 @@ (:subl ,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)))) + (:locally (:movl 0 (:edi (:edi-offset atomically-continuation)))) + (:leal (:esp 16) :esp) pfix-pbig-done)) ((positive-bignum positive-bignum) (if (< (%bignum-bigits y) (%bignum-bigits x)) (+ y x) ;; Assume x is smallest. - (with-inline-assembly (:returns :eax :labels (retry-not-size1 + (with-inline-assembly (:returns :eax :labels (restart-addition retry-jumper not-size1 copy-bignum-loop @@ -570,20 +578,30 @@ (:jne 'not-size1) (:movl (:ebx (:offset movitz-bignum bigit0)) :ecx) (:addl (:eax (:offset movitz-bignum bigit0)) :ecx) - (:jc 'retry-not-size1) + (:jc 'not-size1) (:call-local-pf box-u32-ecx) (:jmp 'pfix-pbig-done) - retry-not-size1 + + not-size1 + ;; Set up atomically continuation. + (:declare-label-set restart-jumper (restart-addition)) + (:locally (:pushl (:edi (:edi-offset :dynamic-env)))) + (:pushl 'restart-jumper) + ;; ..this allows us to detect recursive atomicallies. + (:locally (:pushl (:edi (:edi-offset :atomically-continuation)))) + (:pushl :ebp) + restart-addition + + (:movl (:esp) :ebp) (: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 + + (:locally (:movl :esp (:edi (:edi-offset :atomically-continuation)))) + ;; Now inside atomically section. + (:call-local-pf get-cons-pointer) (:load-lexical (:lexical-binding y) :ebx) ; bignum (:movzxw (:ebx (:offset movitz-bignum length)) :ecx) @@ -636,8 +654,8 @@ (: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)))) + (:locally (:movl 0 (:edi (:edi-offset atomically-continuation)))) + (:leal (:esp 16) :esp) pfix-pbig-done) )) (((integer * -1) (integer 0 *)) @@ -1055,14 +1073,23 @@ ((fixnum bignum) (let (r) (with-inline-assembly (:returns :eax) - retry - (:declare-label-set retry-jumper (retry)) + ;; Set up atomically continuation. + (:declare-label-set restart-jumper (restart-multiplication)) + (:locally (:pushl (:edi (:edi-offset :dynamic-env)))) + (:pushl 'restart-jumper) + ;; ..this allows us to detect recursive atomicallies: + (:locally (:pushl (:edi (:edi-offset :atomically-continuation)))) + (:pushl :ebp) + restart-multiplication + + (:movl (:esp) :ebp) (:compile-two-forms (:eax :ebx) (integer-length x) (integer-length y)) - (: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)))) + ;; Compute (1+ (ceiling (+ (len x) (len y)) 32)) .. + + (:locally (:movl :esp (:edi (:edi-offset :atomically-continuation)))) + ;; Now inside atomically section. + (:leal (:eax :ebx ,(* 4 (+ 31 32))) :eax) (:andl ,(logxor #xffffffff (* 31 4)) :eax) (:shrl 5 :eax) @@ -1108,8 +1135,8 @@ (:movl :edi :edx) (:cld) ; EAX, EDX, and ESI are GC roots again. (:call-local-pf cons-commit) - (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) - (:edi (:edi-offset atomically-status)))) + (:locally (:movl 0 (:edi (:edi-offset atomically-continuation)))) + (:leal (:esp 16) :esp) (:compile-form (:result-mode :ebx) x) (:testl :ebx :ebx) (:jns 'positive-result) @@ -1221,16 +1248,26 @@ (:call-local-pf box-u32-ecx) (:popl :ebx) (:jmp 'done) + not-size1 + ;; Set up atomically continuation. + (:declare-label-set restart-jumper (restart-truncation)) + (:locally (:pushl (:edi (:edi-offset :dynamic-env)))) + (:pushl 'restart-jumper) + ;; ..this allows us to detect recursive atomicallies. + (:locally (:pushl (:edi (:edi-offset :atomically-continuation)))) + (:pushl :ebp) + restart-truncation + + (:movl (:esp) :ebp) (:xorl :eax :eax) (:compile-form (:result-mode :ebx) number) (:movw (:ebx (:offset movitz-bignum length)) :ax) - (:declare-label-set retry-jumper (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)))) (:addl 4 :eax) + + (:locally (:movl :esp (:edi (:edi-offset :atomically-continuation)))) + ;; Now inside atomically section. + (:call-local-pf get-cons-pointer) ; New bignum into EAX (:store-lexical (:lexical-binding r) :eax :type bignum) ; XXX breaks GC invariant! @@ -1285,8 +1322,9 @@ no-more-shrinkage (:call-local-pf cons-commit) fixnum-result - (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) - (:edi (:edi-offset atomically-status)))) + ;; Exit atomically block. + (:locally (:movl 0 (:edi (:edi-offset atomically-continuation)))) + (:leal (:esp 16) :esp) done (:movl 2 :ecx) (:stc))))) @@ -1722,8 +1760,18 @@ ;; We need to generate a bignum.. ;; ..filling in 1-bits since the integer is negative. (:pushl :eax) ; This will become the LSB bigit. - retry-ones-expanded-bignum - (:declare-label-set retry-jumper-ones-expanded-bignum (retry-ones-expanded-bignum)) + + ;; Set up atomically continuation. + (:declare-label-set restart-jumper (restart-ones-expanded-bignum)) + (:locally (:pushl (:edi (:edi-offset :dynamic-env)))) + (:pushl 'restart-jumper) + ;; ..this allows us to detect recursive atomicallies. + (:locally (:pushl (:edi (:edi-offset :atomically-continuation)))) + (:pushl :ebp) + restart-ones-expanded-bignum + + (:movl (:esp) :ebp) +;;; (:declare-label-set retry-jumper-ones-expanded-bignum (retry-ones-expanded-bignum)) ;; Calculate word-size from bytespec-size. (:compile-form (:result-mode :ecx) size) (:addl ,(* 31 movitz:+movitz-fixnum-factor+) :ecx) ; Add 31 @@ -1731,10 +1779,10 @@ (:andl ,(- movitz:+movitz-fixnum-factor+) :ecx) (:leal (:ecx ,movitz:+movitz-fixnum-factor+) ; Add 1 for header. :eax) - (:locally (:movl :esp (:edi (:edi-offset atomically-esp)))) - (:locally (:movl '(:funcall ,(movitz::atomically-status-jumper-fn t :esp) - 'retry-jumper-ones-expanded-bignum) - (:edi (:edi-offset atomically-status)))) + + (:locally (:movl :esp (:edi (:edi-offset :atomically-continuation)))) + ;; Now inside atomically section. + (:call-local-pf get-cons-pointer) (:shll 16 :ecx) (:orl ,(movitz:tag :bignum 0) :ecx) @@ -1744,8 +1792,8 @@ ,(* 1 movitz:+movitz-fixnum-factor+)) ; add 1 for header. :ecx) (:call-local-pf cons-commit) - (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) - (:edi (:edi-offset atomically-status)))) + (:locally (:movl 0 (:edi (:edi-offset atomically-continuation)))) + (:leal (:esp 16) :esp) ;; Have fresh bignum in EAX, now fill it with ones. (:xorl :ecx :ecx) ; counter fill-ones-loop @@ -1858,7 +1906,7 @@ (do-it))) (t (macrolet ((do-it () - `(let () + `(let (new-size) (with-inline-assembly (:returns :eax) (:compile-form (:result-mode :ebx) integer) (:compile-form (:result-mode :ecx) position) @@ -1919,14 +1967,24 @@ (:jz 'ldb-done) ; New size was zero, so the result of ldb is zero. (:movl :ecx :eax) ; New size into EAX. size-ok - retry - (:declare-label-set retry-jumper (retry)) - (: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)))) + (:store-lexical (:lexical-binding new-size) :eax :type fixnum) + + ;; Set up atomically continuation. + (:declare-label-set restart-ldb-jumper (restart-ldb)) + (:locally (:pushl (:edi (:edi-offset :dynamic-env)))) + (:pushl 'restart-ldb-jumper) + ;; ..this allows us to detect recursive atomicallies. + (:locally (:pushl (:edi (:edi-offset :atomically-continuation)))) + (:pushl :ebp) + restart-ldb + + (:movl (:esp) :ebp) + (:load-lexical (:lexical-binding new-size) :eax) + + (:locally (:movl :esp (:edi (:edi-offset :atomically-continuation)))) + ;; Now inside atomically section. ;; (new) Size is in EAX. - (:pushl :eax) ; Save for later + (:subl ,movitz:+movitz-fixnum-factor+ :eax) (:andl ,(logxor #xffffffff (mask-field (byte (+ 5 movitz:+movitz-fixnum-shift+) 0) -1)) @@ -1997,7 +2055,6 @@ ;; Now we must mask MSB bigit. (:movzxw (:ebx (:offset movitz-bignum length)) :edx) - (:popl :ecx) ; (new) bytespec size (:load-lexical (:lexical-binding size) :ecx) (:shrl 5 :ecx) (:andl -4 :ecx) ; ECX = index of (conceptual) MSB @@ -2044,8 +2101,8 @@ :ecx) (:call-local-pf cons-commit) return-fixnum - (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) - (:edi (:edi-offset atomically-status)))) + (:locally (:movl 0 (:edi (:edi-offset atomically-continuation)))) + (:leal (:esp 16) :esp) ldb-done)))) (do-it)))))))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/interrupt.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-serv16937 Modified Files: interrupt.lisp Log Message: Re-worked the atomically protocol. There is now one run-time-context field, atomically-continuation, whose semantics is slightly different from the old atomically-status and atomically-esp. Date: Tue Sep 21 15:06:02 2004 Author: ffjeld Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.23 movitz/losp/muerte/interrupt.lisp:1.24 --- movitz/losp/muerte/interrupt.lisp:1.23 Wed Sep 15 12:22:59 2004 +++ movitz/losp/muerte/interrupt.lisp Tue Sep 21 15:06:02 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.23 2004/09/15 10:22:59 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.24 2004/09/21 13:06:02 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -21,16 +21,17 @@ (defvar *last-dit-frame* nil) (defconstant +dit-frame-map+ - '(nil :eflags :eip :error-code :exception-vector + '(:eflags :cs :eip :error-code :exception-vector :ebp :funobj :edi - :atomically-status - :atomically-esp + :atomically-continuation :raw-scratch0 :ecx :eax :edx :ebx :esi - :scratch1)) - + :scratch1 + :debug0 + :debug1 + :tail-marker)) (defun dit-frame-esp (stack dit-frame) "Return the frame ESP pointed to when interrupt at dit-frame occurred." @@ -109,16 +110,19 @@ (:pushl 0) ; 0 'funobj' means default-interrupt-trampoline frame (:pushl :edi) ; (:movl ':nil-value :edi) ; We want NIL! - (:locally (:pushl (:edi (:edi-offset atomically-status)))) - (:locally (:pushl (:edi (:edi-offset atomically-esp)))) + (:locally (:pushl (:edi (:edi-offset atomically-continuation)))) (:locally (:pushl (:edi (:edi-offset raw-scratch0)))) ,@(loop for reg in (sort (copy-list '(:eax :ebx :ecx :edx :esi)) #'> :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 - (:locally (:movl 0 (:edi (:edi-offset atomically-status)))) + (:locally (:movl 0 (:edi (:edi-offset atomically-continuation)))) ;;; ;; See if ESP/EBP signalled a throwing situation ;;; (:leal (:ebp 24) :edx) ; Interrupted ESP @@ -129,15 +133,15 @@ ;;; not-throwing ;; rearrange stack for return - (:movl (:ebp 12) :eax) ; load return address - (:movl (:ebp 20) :ebx) ; load EFLAGS - (:movl :ebx (:ebp 16)) ; EFLAGS at next-to-bottom of stack - (:movl :eax (:ebp 20)) ; return address at bottom of stack +;;; (:movl (:ebp 12) :eax) ; load return address +;;; (:movl (:ebp 20) :ebx) ; load EFLAGS +;;; (:movl :ebx (:ebp 16)) ; EFLAGS at next-to-bottom of stack +;;; (:movl :eax (:ebp 20)) ; return address at bottom of stack (:xorl :eax :eax) ; Ensure safe value (:xorl :edx :edx) ; Ensure safe value - (:pushl (:ebp 16)) ; EFLAGS + (:pushl (:ebp ,(dit-frame-offset :eflags))) ; EFLAGS (:pushl :cs) ; push CS (:call (:pc+ 0)) ; push EIP. ;; Now add a few bytes to the on-stack EIP so the iret goes to @@ -147,7 +151,7 @@ ;; *DEST* iret branches to here. ;; we're now in the context of the interruptee. - + (:cld) ;; Save/push thread-local values (:locally (:movl (:edi (:edi-offset num-values)) :ecx)) @@ -160,7 +164,19 @@ (:jnz 'push-values-loop) push-values-done (:locally (:pushl (:edi (:edi-offset num-values)))) - + + ;; Check the current atomically-continuation isn't a recursive one. + (:movl (:ebp ,(dit-frame-offset :atomically-continuation)) :ecx) + (:testl :ecx :ecx) + (:jz 'atomically-continuation-ok) + (:testb 3 :cl) + (:jnz 'atomically-continuation-ok) ; can't tell for pf-atomically. + (:movl (:ecx 4) :ecx) + (:testl :ecx :ecx) + (:jz 'atomically-continuation-ok) + (:int 63) ; not ok. + atomically-continuation-ok + ;; call handler (:movl (:ebp ,(dit-frame-offset :exception-vector)) :ecx) (:locally (:movl (:edi (:edi-offset exception-handlers)) :eax)) @@ -181,15 +197,12 @@ (:jnz 'pop-values-loop) pop-values-done - (:movl (:ebp ,(dit-frame-offset :atomically-status)) :ecx) - (:testb :cl :cl) + (:movl (:ebp ,(dit-frame-offset :atomically-continuation)) :ecx) + (:testl :ecx :ecx) (:jnz 'restart-atomical-block) ;; Interrupted code was non-atomical, the normal case. - normal-return ; With atomically-status-to-restore in ECX - (:locally (:movl :ecx (:edi (:edi-offset atomically-status)))) - (:movl (:ebp ,(dit-frame-offset :atomically-esp)) :ecx) - (:locally (:movl :ecx (:edi (:edi-offset atomically-esp)))) + normal-return (:movl (:ebp ,(dit-frame-offset :raw-scratch0)) :ecx) (:locally (:movl :ecx (:edi (:edi-offset raw-scratch0)))) (:movl (:ebp ,(dit-frame-offset :scratch1)) :eax) @@ -200,104 +213,48 @@ (:movl (:ebp ,(dit-frame-offset :edx)) :edx) (:movl (:ebp ,(dit-frame-offset :eax)) :eax) (:movl (:ebp ,(dit-frame-offset :ecx)) :ecx) - ;; Make stack safe before we exit dit-frame.. - (:movl :edi (:ebp 4)) - (:movl :edi (:ebp 8)) - (:movl :edi (:ebp 12)) (:cli) ; Clear IF in EFLAGS before leaving dit-frame. (:leave) - (:addl 12 :esp) - (:popfl) ; pop EFLAGS (also resets IF) - (:ret) ; pop EIP + (:addl 8 :esp) ; Skip exception-vector and error-code. + (:iretd) ; Pop EFLAGS, CS, and EIP. restart-atomical-block - (:cmpb ,(bt:enum-value 'movitz::atomically-status :restart-primitive-function) :cl) - (:jne 'not-simple-atomical-pf-restart) - (:testl #xfe00 :ecx) ; map of registers to restore - (:jnz 'not-simple-atomical-pf-restart) - (:sarl 16 :ecx) ; move atomically-status data into ECX - (:movl (:edi (:ecx 4) ,(- (movitz:tag :null))) - :ecx) ; This is the EIP to restart - (:movl :ecx (:ebp 20)) - (:movl (:ebp ,(dit-frame-offset :atomically-status)) :ecx) - (:testl ,(bt:enum-value 'movitz::atomically-status :reset-status-p) - :ecx) ; Should we reset status to zero? - (:jnz 'normal-return) - (:xorl :ecx :ecx) ; Do reset status to zero. - (:jmp 'normal-return) - not-simple-atomical-pf-restart - (:cmpb ,(bt:enum-value 'movitz::atomically-status :restart-jumper) :cl) - (:jne 'not-simple-restart-jumper) - (:testl ,(bt:enum-value 'movitz::atomically-status :esp) - :ecx) ; map of registers to restore - (:jnz 'atomically-esp-ok) - ;; Generate the correct ESP for interruptee's atomically-esp - (:leal (:ebp 24) :ecx) - (:movl :ecx (:ebp ,(dit-frame-offset :atomically-esp))) - atomically-esp-ok - (:movl (:ebp ,(dit-frame-offset :atomically-status)) :ecx) - (:testl ,(bt:enum-value 'movitz::atomically-status :reset-status-p) - :ecx) ; Should we reset status to zero? - (:jnz 'atomically-jumper-return) - (:xorl :ecx :ecx) ; Do reset status to zero. + ;; Atomically-continuation is in ECX - atomically-jumper-return - (:locally (:movl :ecx (:edi (:edi-offset atomically-status)))) - (:movl (:ebp ,(dit-frame-offset :atomically-esp)) :ecx) ; Load interruptee's atomically-esp.. - (:locally (:movl :ecx (:edi (:edi-offset atomically-esp)))) ; ..and restore it. - - (:testl #x40 (:ebp 16)) ; Test EFLAGS bit DF - (:jnz 'atomically-jumper-return-dirty-registers) - - (:movl (:ebp ,(dit-frame-offset :edi)) :edi) - (:movl (:ebp ,(dit-frame-offset :esi)) :esi) - (:movl (:ebp ,(dit-frame-offset :edx)) :edx) - (:movl (:ebp ,(dit-frame-offset :eax)) :eax) - (:movl (:ebp ,(dit-frame-offset :ecx)) :ecx) - - (:movl (:ebp ,(dit-frame-offset :atomically-status)) :ebx) ; atomically-status.. - (:shrl ,(- 16 movitz:+movitz-fixnum-shift+) :ebx) + (:testb 3 :cl) + (:jnz 'restart-simple-pf) - ;; Make stack safe before we exit dit-frame.. - (:movl :edi (:ebp 4)) - (:movl :edi (:ebp 8)) - (:movl :edi (:ebp 12)) - (:movl :edi (:ebp 16)) - (:movl :edi (:ebp 20)) - (:movl (:ebp 0) :ebp) ; pop stack-frame - (:movl (:ebp -4) :esi) ; reset funobj in ESI - (:locally (:movl (:edi (:edi-offset atomically-esp)) :esp)) ; restore ESP - ;; XXXX this state isn't covered in the stack discipline!?! - (:jmp (:esi :ebx (:offset movitz-funobj constant0))) - - atomically-jumper-return-dirty-registers - ;; If the interruptee had DF set, then initialize all GP registers with - ;; safe values, keep EBP, set ESI=(EBP -4), and EDI is known-good EDI. - ;; DF will be cleared. - (:movl :edi :edx) - (:movl :edi :eax) - (:movl :edi :ecx) - - (:movl (:ebp ,(dit-frame-offset :atomically-status)) :ebx) - (:shrl ,(- 16 movitz:+movitz-fixnum-shift+) :ebx) - - ;; Make stack safe before we exit dit-frame.. - (:movl :edi (:ebp 4)) - (:movl :edi (:ebp 8)) - (:movl :edi (:ebp 12)) - (:movl :edi (:ebp 16)) - (:movl :edi (:ebp 20)) - (:movl (:ebp 0) :ebp) ; pop dit-frame - (:movl (:ebp -4) :esi) - (:locally (:movl (:edi (:edi-offset atomically-esp)) :esp)) ; restore ESP - ;; XXXX this state isn't covered in the stack discipline!?! - (:jmp (:esi :ebx (:offset movitz-funobj constant0))) + ;; ECX is a throw target aka. next continuation step. + (:locally (:movl :esi (:edi (:edi-offset scratch1)))) + (:movl (:ecx 12) :edx) + (:locally (:movl :edx (:edi (:edi-offset dynamic-env)))) ; exit to target dynamic-env + (:movl :ecx :esp) ; enter non-local jump stack mode. + + (:movl (:esp) :ecx) ; target stack-frame EBP + (:movl (:ecx -4) :esi) ; get target funobj into ESI + + (:movl (:esp 8) :ecx) ; target jumper number + (:jmp (:esi :ecx (:offset movitz-funobj constant0))) + + restart-simple-pf + ;; ECX holds the run-time-context offset for us to load. + + (:movl ,movitz:+code-vector-transient-word+ :eax) + (:locally (:addl (:edi :ecx) :eax)) + (:leal (:eax ,movitz:+other-type-offset+) :ecx) + (:testb 7 :cl) + (:jnz '(:sub-program (pf-continuation-not-code-vector) + (:int 63))) + (:cmpw ,(movitz:basic-vector-type-tag :code) (:eax ,movitz:+other-type-offset+)) + (:jne 'pf-continuation-not-code-vector) + (:leal (:eax ,movitz:+code-vector-word-offset+) :ecx) + (:movl :ecx (:ebp ,(dit-frame-offset :eip))) + (:jmp 'normal-return) + - not-simple-restart-jumper + not-restart-continuation ;; Don't know what to do. - (:halt) - (:int 90) - (:jmp 'not-simple-atomical-pf-restart) + (:int 63) ))) (do-it)))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/inspect.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-serv16871 Modified Files: inspect.lisp Log Message: Re-worked the atomically protocol. There is now one run-time-context field, atomically-continuation, whose semantics is slightly different from the old atomically-status and atomically-esp. Date: Tue Sep 21 15:05:56 2004 Author: ffjeld Index: movitz/losp/muerte/inspect.lisp diff -u movitz/losp/muerte/inspect.lisp:1.38 movitz/losp/muerte/inspect.lisp:1.39 --- movitz/losp/muerte/inspect.lisp:1.38 Wed Sep 15 12:25:47 2004 +++ movitz/losp/muerte/inspect.lisp Tue Sep 21 15:05:55 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Oct 24 09:50:41 2003 ;;;; -;;;; $Id: inspect.lisp,v 1.38 2004/09/15 10:25:47 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.39 2004/09/21 13:05:55 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -237,6 +237,10 @@ (defun objects-equalp (x y) "Basically, this verifies whether x is a shallow-copy of y, or vice versa." + (assert (not (with-inline-assembly (:returns :boolean-zf=1) + (:load-lexical (:lexical-binding x) :eax) + (:cmpl #x13 :eax))) + (x) "Checking illegal ~S for object-equalp." x) (or (eql x y) (cond ((not (objects-equalp (class-of x) (class-of y)))

1 0

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

21 Sep '04

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv16838 Modified Files: los0-gc.lisp Log Message: Re-worked the atomically protocol. There is now one run-time-context field, atomically-continuation, whose semantics is slightly different from the old atomically-status and atomically-esp. Date: Tue Sep 21 15:05:50 2004 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.37 movitz/losp/los0-gc.lisp:1.38 --- movitz/losp/los0-gc.lisp:1.37 Thu Sep 16 10:55:00 2004 +++ movitz/losp/los0-gc.lisp Tue Sep 21 15:05:49 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Feb 21 17:48:32 2004 ;;;; -;;;; $Id: los0-gc.lisp,v 1.37 2004/09/16 08:55:00 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.38 2004/09/21 13:05:49 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -74,32 +74,26 @@ (values)) (define-primitive-function los0-fast-cons () - "Allocate a cons cell from nursery-space." + "Allocate a cons cell of EAX and EBX from nursery-space." (macrolet ((do-it () `(with-inline-assembly (:returns :eax) retry-cons ;; Set up thread-atomical execution - (:locally (:movl ,(movitz::atomically-status-simple-pf 'fast-cons t) - (:edi (:edi-offset atomically-status)))) + (:locally (:movl ,(movitz::atomically-continuation-simple-pf 'fast-cons) + (:edi (:edi-offset atomically-continuation)))) (:locally (:movl (:edi (:edi-offset nursery-space)) :edx)) (:movl (:edx 2) :ecx) (:cmpl (:edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)) :ecx) (:jae '(:sub-program (allocation-failed) - ;; Exit thread-atomical - (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) - (:edi (:edi-offset atomically-status)))) - (:int 113) - ;; This interrupt can be retried. - (:jmp 'retry-cons))) + (:int 113))) (:movl :eax (:edx :ecx 2)) (:movl :ebx (:edx :ecx 6)) (:addl 8 :ecx) (:movl :ecx (:edx 2)) ; Commit allocation ;; Exit thread-atomical - (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) - (:edi (:edi-offset atomically-status)))) + (:locally (:movl 0 (:edi (:edi-offset atomically-continuation)))) (:leal (:edx :ecx -5) :eax) (:ret)))) (do-it))) @@ -144,7 +138,7 @@ ((do-it () `(with-inline-assembly (:returns :multiple-values) retry - (:locally (:cmpl 0 (:edi (:edi-offset atomically-status)))) ; Atomically? + (:locally (:cmpl 0 (:edi (:edi-offset atomically-continuation)))) ; Atomically? (:je '(:sub-program () (:int 63))) ; This must be called inside atomically. (:locally (:movl (:edi (:edi-offset nursery-space)) :edx)) @@ -168,7 +162,7 @@ ((do-it () `(with-inline-assembly (:returns :multiple-values) retry - (:locally (:cmpl 0 (:edi (:edi-offset atomically-status)))) ; Atomically? + (:locally (:cmpl 0 (:edi (:edi-offset atomically-continuation)))) ; Atomically? (:je '(:sub-program () (:int 50))) ; This must be called inside atomically. (:addl ,movitz:+movitz-fixnum-factor+ :ecx) @@ -196,17 +190,14 @@ (:ret) not-fixnum retry-cons - (:locally (:movl ,(movitz::atomically-status-simple-pf 'box-u32-ecx t) - (:edi (:edi-offset atomically-status)))) + (:locally (:movl ,(movitz::atomically-continuation-simple-pf 'box-u32-ecx) + (:edi (:edi-offset atomically-continuation)))) (:locally (:movl (:edi (:edi-offset nursery-space)) :edx)) (:movl (:edx 2) :eax) (:cmpl (:edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)) :eax) (:jae '(:sub-program () - (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) - (:edi (:edi-offset atomically-status)))) - (:int 113) ; This interrupt can be retried. - (:jmp 'retry-cons))) + (:int 113))) (:movl ,(dpb movitz:+movitz-fixnum-factor+ (byte 16 16) (movitz:tag :bignum 0)) (:edx :eax 2)) @@ -214,70 +205,11 @@ (:addl 8 :eax) (:movl :eax (:edx 2)) ; Commit allocation ;; Exit thread-atomical - (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) - (:edi (:edi-offset atomically-status)))) + (:locally (:movl 0 (:edi (:edi-offset atomically-continuation)))) (:leal (:edx :eax) :eax) (:ret)))) (do-it))) -(define-primitive-function los0-malloc-pointer-words (words) - "Number of words in EAX/fixnum. Result in EAX with tag :other." - (macrolet - ((do-it () - `(with-inline-assembly (:returns :multiple-values) - (:addl 4 :eax) - (:andl -8 :eax) - (:movl :eax :ebx) ; Save count for later - retry - (:locally (:movl (:edi (:edi-offset nursery-space)) :edx)) - (:movl (:edx 2) :ecx) - (:leal (:ecx :eax) :eax) - (:cmpl (:edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)) - :eax) - (:ja '(:sub-program () - (:int 113) - (:movl :ebx :eax) ; Restore count in EAX before retry - (:jmp 'retry))) - (:movl :eax (:edx 2)) - (:movl ,(movitz:basic-vector-type-tag :any-t) - (:edx :ecx ,(+ 8 movitz:+other-type-offset+))) - (:subl 8 :ebx) - (:movl :ebx (:edx :ecx ,(+ 16 movitz:+other-type-offset+))) - (:leal (:edx :ecx 8) :eax) - (:xorl :ecx :ecx) - (:addl 8 :ecx) - init-loop ; Now init ebx number of words - (:movl :edi (:eax :ecx ,(- (movitz:tag :other)))) - (:addl 4 :ecx) - (:cmpl :ebx :ecx) - (:jb 'init-loop) - (:ret)))) - (do-it))) - -(define-primitive-function los0-malloc-non-pointer-words (words) - "Number of words in EAX/fixnum. Result in EAX with tag :other." - (macrolet - ((do-it () - `(with-inline-assembly (:returns :multiple-values) - (:addl 4 :eax) - (:andl -8 :eax) - (:movl :eax :ebx) ; Save count for later - retry - (:locally (:movl (:edi (:edi-offset nursery-space)) :edx)) - (:movl (:edx 2) :ecx) - (:leal (:ecx :eax) :eax) - (:cmpl (:edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)) - :eax) - (:ja '(:sub-program () - (:int 113) - (:movl :ebx :eax) ; Restore count in EAX before retry - (:jmp 'retry))) - (:movl :eax (:edx 2)) - (:movl ,(movitz:tag :infant-object) (:edx :ecx ,(+ 8 movitz:+other-type-offset+))) - (:leal (:edx :ecx 8) :eax) ; Now EAX is a valid pointer - (:ret)))) - (do-it))) - (defvar *gc-stack*) (defun install-los0-consing (&key (context (current-run-time-context)) @@ -466,7 +398,21 @@ old object: ~Z: ~S new object: ~Z: ~S oldspace: ~Z, newspace: ~Z, i: ~D" - old old new new oldspace newspace i)))))))) + old old new new oldspace newspace i)))))) + (map-heap-words (lambda (x y) + (declare (ignore y)) + (when (location-in-object-p (space-other (%run-time-context-slot 'nursery-space)) + (object-location x)) + (break "Seeing old object in values-vector: ~Z" x)) + x) + #x38 #xb8) + (let* ((stack (%run-time-context-slot 'muerte::nursery-space)) + (stack-start (- (length stack) (muerte::current-control-stack-depth)))) + (do ((i 0 (+ i 3))) + ((>= i (length a))) + (when (find (aref a i) stack :start stack-start) + (break "Seeing old object ~S in current stack!" + (aref a i))))))) ;; GC completed, oldspace is evacuated. (unless *gc-quiet*

1 0

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

21 Sep '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv16804 Modified Files: storage-types.lisp Log Message: Removed dead code. Date: Tue Sep 21 15:04:02 2004 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.41 movitz/storage-types.lisp:1.42 --- movitz/storage-types.lisp:1.41 Fri Sep 17 13:06:05 2004 +++ movitz/storage-types.lisp Tue Sep 21 15:04:02 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: storage-types.lisp,v 1.41 2004/09/17 11:06:05 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.42 2004/09/21 13:04:02 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -383,11 +383,6 @@ object) (t (call-next-method)))) -(defun vector-type-tag (element-type) - (dpb (enum-value 'movitz-vector-element-type element-type) - (byte 8 8) - (enum-value 'other-type-byte :vector))) - (defun basic-vector-type-tag (element-type) (dpb (enum-value 'movitz-vector-element-type element-type) (byte 8 8)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/eval.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-serv16766 Modified Files: eval.lisp Log Message: Argh! _This_ is the correct check-in for adding a continue/ignore restart to the "won't defun a common lisp symbol" error. Date: Tue Sep 21 15:02:57 2004 Author: ffjeld Index: movitz/losp/muerte/eval.lisp diff -u movitz/losp/muerte/eval.lisp:1.10 movitz/losp/muerte/eval.lisp:1.11 --- movitz/losp/muerte/eval.lisp:1.10 Wed Aug 18 22:16:26 2004 +++ movitz/losp/muerte/eval.lisp Tue Sep 21 15:02:57 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Oct 19 21:15:12 2001 ;;;; -;;;; $Id: eval.lisp,v 1.10 2004/08/18 20:16:26 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.11 2004/09/21 13:02:57 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -157,9 +157,10 @@ (return t)))) (defun eval-defun (name lambda-list body env) - (assert (not (eq (symbol-package name) - (find-package 'common-lisp))) - () "Won't allow defun of a common-lisp symbol.") + (with-simple-restart (continue "Defun ~S anyway." name) + (assert (not (eq (symbol-package name) + (find-package 'common-lisp))) + () "Won't allow defun of the Common Lisp symbol ~S." name)) (setf (symbol-function name) (install-funobj-name name (lambda (&rest args)

1 0

← Newer
1
2
3
4
5
6
7
8
9
10
Older →

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

movitz-cvs September 2004