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

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

22 Sep '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv9133 Modified Files: basic-macros.lisp Log Message: Added compiler-macros cli and sti. Date: Wed Sep 22 18:26:15 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.40 movitz/losp/muerte/basic-macros.lisp:1.41 --- movitz/losp/muerte/basic-macros.lisp:1.40 Tue Sep 21 15:06:27 2004 +++ movitz/losp/muerte/basic-macros.lisp Wed Sep 22 18:26:14 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.40 2004/09/21 13:06:27 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.41 2004/09/22 16:26:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1122,6 +1122,12 @@ (:call-local-pf cons-commit) (:locally (:movl 0 (:edi (:edi-offset atomically-continuation)))) (:leal (:esp 16) :esp))))) + +(define-compiler-macro cli () + `(with-inline-assembly (:returns :nothing) (:cli))) + +(define-compiler-macro sti () + `(with-inline-assembly (:returns :nothing) (:sti))) (require :muerte/setf)

1 0

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

22 Sep '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv6775 Modified Files: bignums.lisp Log Message: Various fixes for stack discipline. Date: Wed Sep 22 18:22:45 2004 Author: ffjeld Index: movitz/losp/muerte/bignums.lisp diff -u movitz/losp/muerte/bignums.lisp:1.9 movitz/losp/muerte/bignums.lisp:1.10 --- movitz/losp/muerte/bignums.lisp:1.9 Tue Sep 21 16:24:03 2004 +++ movitz/losp/muerte/bignums.lisp Wed Sep 22 18:22: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.9 2004/09/21 14:24:03 ffjeld Exp $ +;;;; $Id: bignums.lisp,v 1.10 2004/09/22 16:22:45 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -64,18 +64,7 @@ (defun copy-bignum (old) (check-type old bignum) - (%shallow-copy-object old (1+ (%bignum-bigits old))) - #+ignore - (let* ((length (%bignum-bigits old)) - (new (malloc-non-pointer-words (1+ length)))) - (with-inline-assembly (:returns :eax) - (:compile-two-forms (:eax :ebx) new old) - (:compile-form (:result-mode :edx) length) - copy-bignum-loop - (:movl (:ebx :edx (:offset movitz-bignum type)) :ecx) - (:movl :ecx (:eax :edx (:offset movitz-bignum type))) - (:subl 4 :edx) - (:jnc 'copy-bignum-loop)))) + (%shallow-copy-object old (1+ (%bignum-bigits old)))) (defun %make-bignum (bigits) (assert (plusp bigits)) @@ -381,27 +370,29 @@ (:compile-form (:result-mode :ecx) short-shift) (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) (:jz 'done) - (:xorl :edx :edx) ; counter - (:movw (:ebx (:offset movitz-bignum length)) :dx) - (:subl 4 :edx) + (:xorl :esi :esi) ; counter + (:movw (:ebx (:offset movitz-bignum length)) :si) + (:subl 4 :esi) (:jz 'shift-short-lsb) (:xorl :eax :eax) (:std) ;; Overflow check - (:movl (:ebx :edx (:offset movitz-bignum bigit0)) + (:movl (:ebx :esi (:offset movitz-bignum bigit0)) :eax) - (:xorl :esi :esi) - (:shldl :cl :eax :esi) + (:xorl :edx :edx) + (:shldl :cl :eax :edx) (jnz 'overflow) shift-short-loop - (:movl (:ebx :edx (:offset movitz-bignum bigit0 -4)) + (:int 32) + (:movl (:ebx :esi (:offset movitz-bignum bigit0 -4)) :eax) - (:shldl :cl :eax (:ebx :edx (:offset movitz-bignum bigit0))) - (:subl 4 :edx) + (:shldl :cl :eax (:ebx :esi (:offset movitz-bignum bigit0))) + (:subl 4 :esi) (:jnz 'shift-short-loop) - (:movl (:ebp -4) :esi) + (:movl :edi :edx) (:movl :edi :eax) ; Safe EAX (:cld) + (:movl (:ebp -4) :esi) shift-short-lsb (:shll :cl (:ebx (:offset movitz-bignum bigit0))) done @@ -428,7 +419,6 @@ (:xorl :edx :edx) ; Initial carry (:std) ; Make EAX, EDX non-GC-roots. multiply-loop - (:movl :esi (#x1000000)) (:movl (:ebx :esi (:offset movitz-bignum bigit0)) :eax) (:movl :edx :ecx) ; Save carry in ECX @@ -459,9 +449,9 @@ (:compile-two-forms (:ebx :ecx) bignum divisor) (:xorl :edx :edx) ; hi-digit (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) - (:std) - (:xorl :esi :esi) + (:xorl :esi :esi) ; ESI is counter by 4 (:movw (:ebx (:offset movitz-bignum length)) :si) + (:std) divide-loop (:movl (:ebx :esi (:offset movitz-bignum bigit0 -4)) :eax) ; lo-digit

1 0

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

22 Sep '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv6545 Modified Files: error.lisp Log Message: Added variable *disable-interrupts-on-error*. Date: Wed Sep 22 18:15:41 2004 Author: ffjeld Index: movitz/losp/muerte/error.lisp diff -u movitz/losp/muerte/error.lisp:1.2 movitz/losp/muerte/error.lisp:1.3 --- movitz/losp/muerte/error.lisp:1.2 Mon Jan 19 12:23:46 2004 +++ movitz/losp/muerte/error.lisp Wed Sep 22 18:15:41 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Sep 1 00:49:11 2001 ;;;; -;;;; $Id: error.lisp,v 1.2 2004/01/19 11:23:46 ffjeld Exp $ +;;;; $Id: error.lisp,v 1.3 2004/09/22 16:15:41 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -25,10 +25,12 @@ (defvar *error-no-condition-for-debugger* nil "If true, don't create a simple-error object just for the debugger, (presumably) since this might trigger another bug.") - +(defvar *disable-interrupts-on-error* t) (defun error (&rest arguments) (declare (dynamic-extent arguments)) + (when *disable-interrupts-on-error* + (cli)) (unless arguments (error 'wrong-argument-count :function #'error

1 0

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

22 Sep '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv17386 Modified Files: primitive-functions.lisp Log Message: Removed some dead code. Date: Wed Sep 22 16:48:27 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.43 movitz/losp/muerte/primitive-functions.lisp:1.44 --- movitz/losp/muerte/primitive-functions.lisp:1.43 Fri Sep 17 13:12:57 2004 +++ movitz/losp/muerte/primitive-functions.lisp Wed Sep 22 16: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.43 2004/09/17 11:12:57 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.44 2004/09/22 14:48:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -325,55 +325,6 @@ (:testl :edi :edi) ; clear ZF search-failed (:ret))) ; success: ZF=0, eax=value - - -(define-primitive-function malloc-pointer-words () - "Stupid allocator.. Number of words in EAX/fixnum. -Result in EAX, with tag :other." - (with-inline-assembly (:returns :multiple-values) - (:movl :eax :ebx) - (:locally (:movl (:edi (:edi-offset nursery-space)) :eax)) - (:testb #xff :al) - (:jnz '(:sub-program (not-initialized) - (:int 110) - (:halt) - (:jmp 'not-initialized))) - (:addl 4 :ebx) - (:andb #xf8 :bl) - (:movl (:eax 4) :ecx) ; cons pointer to ECX - (:leal (:ebx :ecx) :edx) ; new roof to EDX - (:cmpl :edx (:eax)) ; end of buffer? - (:jl '(:sub-program (failed) - (:int 112) - (:halt) - (:jmp 'failed))) - (:movl :edx (:eax 4)) ; new cons pointer - (:leal (:eax :ecx 6) :eax) - (:ret))) - -;;;(define-primitive-function malloc-non-pointer-words () -;;; "Stupid allocator.. Number of words in EAX/fixnum. -;;;Result in EAX, with tag 6." -;;; (with-inline-assembly (:returns :multiple-values) -;;; (:movl :eax :ebx) -;;; (:locally (:movl (:edi (:edi-offset nursery-space)) :eax)) -;;; (:testb #xff :al) -;;; (:jnz '(:sub-program (not-initialized) -;;; (:int 110) -;;; (:halt) -;;; (:jmp 'not-initialized))) -;;; (:addl 7 :ebx) -;;; (:andb #xf8 :bl) -;;; (:movl (:eax 4) :ecx) ; cons pointer to ECX -;;; (:leal (:ebx :ecx) :edx) ; new roof to EDX -;;; (:cmpl :edx (:eax)) ; end of buffer? -;;; (:jl '(:sub-program (failed) -;;; (:int 112) -;;; (:halt) -;;; (:jmp 'failed))) -;;; (:movl :edx (:eax 4)) ; new cons pointer -;;; (:leal (:eax :ecx 6) :eax) -;;; (:ret))) (define-primitive-function get-cons-pointer () "Return in EAX the next object location with space for EAX words, with tag 6.

1 0

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

22 Sep '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv17236 Modified Files: arrays.lisp Log Message: Made each of the basic-vector contstructor functions allocate arrays properly, using the with-allocation-assembly macros. Date: Wed Sep 22 16:46:39 2004 Author: ffjeld Index: movitz/losp/muerte/arrays.lisp diff -u movitz/losp/muerte/arrays.lisp:1.42 movitz/losp/muerte/arrays.lisp:1.43 --- movitz/losp/muerte/arrays.lisp:1.42 Tue Aug 10 14:58:22 2004 +++ movitz/losp/muerte/arrays.lisp Wed Sep 22 16:46:38 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sun Feb 11 23:14:04 2001 ;;;; -;;;; $Id: arrays.lisp,v 1.42 2004/08/10 12:58:22 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.43 2004/09/22 14:46:38 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -604,136 +604,167 @@ `(funcall%unsafe ,writer ,store-var ,@args) `(funcall%unsafe ,reader ,@args)))) -(defun make-basic-vector%character (dimensions fill-pointer initial-element initial-contents) - (let ((array (malloc-non-pointer-words (+ 2 (truncate (+ dimensions 3) 4))))) - (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements) - 0 :lisp) - dimensions) - (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::type) - 0 :unsigned-byte32) - #.(movitz:basic-vector-type-tag :character)) - (check-type array string) +(defun make-basic-vector%character (dimension fill-pointer initial-element initial-contents) + (check-type dimension (and fixnum (integer 0 *))) + (let* ((words (+ 2 (truncate (+ dimension 3) 4))) + (array (macrolet + ((do-it () + `(with-non-pointer-allocation-assembly (words :fixed-size-p t + :object-register :eax) + (:load-lexical (:lexical-binding dimension) :ecx) + (:movl ,(movitz:basic-vector-type-tag :character) + (:eax (:offset movitz-basic-vector type))) + (:movl :ecx (:eax (:offset movitz-basic-vector num-elements)))))) + (do-it)))) (cond (fill-pointer (setf (fill-pointer array) fill-pointer)) ((array-has-fill-pointer-p array) - (setf (fill-pointer array) dimensions))) + (setf (fill-pointer array) dimension))) (cond (initial-element (check-type initial-element character) - (dotimes (i dimensions) + (dotimes (i dimension) (setf (char array i) initial-element))) (initial-contents (replace array initial-contents))) array)) -(defun make-basic-vector%u32 (dimensions fill-pointer initial-element initial-contents) - (let ((array (malloc-non-pointer-words (+ 2 dimensions)))) - (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements) - 0 :lisp) - dimensions) - (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::type) - 0 :unsigned-byte32) - #.(movitz:basic-vector-type-tag :u32)) +(defun make-basic-vector%u32 (dimension fill-pointer initial-element initial-contents) + (check-type dimension (and fixnum (integer 0 *))) + (let* ((words (+ 2 dimension)) + (array (macrolet + ((do-it () + `(with-non-pointer-allocation-assembly (words :fixed-size-p t + :object-register :eax) + (:load-lexical (:lexical-binding dimension) :ecx) + (:movl ,(movitz:basic-vector-type-tag :u32) + (:eax (:offset movitz-basic-vector type))) + (:movl :ecx (:eax (:offset movitz-basic-vector num-elements)))))) + (do-it)))) (cond (fill-pointer (setf (fill-pointer array) fill-pointer)) ((array-has-fill-pointer-p array) - (setf (fill-pointer array) dimensions))) + (setf (fill-pointer array) dimension))) (cond (initial-element ;; (check-type initial-element (unsigned-byte 32)) - (dotimes (i dimensions) + (dotimes (i dimension) (setf (u32ref%unsafe array i) initial-element))) (initial-contents (replace array initial-contents))) array)) -(defun make-basic-vector%u8 (length fill-pointer initial-element initial-contents) - (let ((array (malloc-non-pointer-words (+ 2 (truncate (+ length 3) 4))))) - (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements) - 0 :lisp) - length) - (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::type) - 0 :unsigned-byte32) - #.(movitz:basic-vector-type-tag :u8)) +(defun make-basic-vector%u8 (dimension fill-pointer initial-element initial-contents) + (check-type dimension (and fixnum (integer 0 *))) + (let* ((words (+ 2 (truncate (+ dimension 3) 4))) + (array (macrolet + ((do-it () + `(with-non-pointer-allocation-assembly (words :fixed-size-p t + :object-register :eax) + (:load-lexical (:lexical-binding dimension) :ecx) + (:movl ,(movitz:basic-vector-type-tag :u8) + (:eax (:offset movitz-basic-vector type))) + (:movl :ecx (:eax (:offset movitz-basic-vector num-elements)))))) + (do-it)))) (cond (fill-pointer (setf (fill-pointer array) fill-pointer)) ((array-has-fill-pointer-p array) - (setf (fill-pointer array) length))) + (setf (fill-pointer array) dimension))) (cond (initial-element (check-type initial-element (unsigned-byte 8)) - (dotimes (i length) + (dotimes (i dimension) (setf (u8ref%unsafe array i) initial-element))) (initial-contents (replace array initial-contents))) array)) -(defun make-basic-vector%bit (length fill-pointer initial-element initial-contents) - (let ((array (malloc-non-pointer-words (+ 2 (truncate (+ length 31) 32))))) - (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements) - 0 :lisp) - length) - (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::type) - 0 :unsigned-byte32) - #.(movitz:basic-vector-type-tag :bit)) +(defun make-basic-vector%bit (dimension fill-pointer initial-element initial-contents) + (check-type dimension (and fixnum (integer 0 *))) + (let* ((words (+ 2 (truncate (+ dimension 31) 32))) + (array (macrolet + ((do-it () + `(with-non-pointer-allocation-assembly (words :fixed-size-p t + :object-register :eax) + (:load-lexical (:lexical-binding dimension) :ecx) + (:movl ,(movitz:basic-vector-type-tag :bit) + (:eax (:offset movitz-basic-vector type))) + (:movl :ecx (:eax (:offset movitz-basic-vector num-elements)))))) + (do-it)))) (cond (fill-pointer (setf (fill-pointer array) fill-pointer)) ((array-has-fill-pointer-p array) - (setf (fill-pointer array) length))) + (setf (fill-pointer array) dimension))) (cond (initial-element (check-type initial-element bit) - (dotimes (i length) + (dotimes (i dimension) (setf (aref array i) initial-element))) (initial-contents (replace array initial-contents))) array)) -(defun make-basic-vector%code (dimensions fill-pointer initial-element initial-contents) - (let ((array (malloc-non-pointer-words (+ 2 (truncate (+ dimensions 3) 4))))) - (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements) - 0 :lisp) - dimensions) - (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::type) - 0 :unsigned-byte32) - #.(movitz:basic-vector-type-tag :code)) +(defun make-basic-vector%code (dimension fill-pointer initial-element initial-contents) + (check-type dimension (and fixnum (integer 0 *))) + (let* ((words (+ 2 (truncate (+ dimension 3) 4))) + (array (macrolet + ((do-it () + `(with-non-pointer-allocation-assembly (words :fixed-size-p t + :object-register :eax) + (:load-lexical (:lexical-binding dimension) :ecx) + (:movl ,(movitz:basic-vector-type-tag :code) + (:eax (:offset movitz-basic-vector type))) + (:movl :ecx (:eax (:offset movitz-basic-vector num-elements)))))) + (do-it)))) (cond (fill-pointer (setf (fill-pointer array) fill-pointer)) ((array-has-fill-pointer-p array) - (setf (fill-pointer array) dimensions))) + (setf (fill-pointer array) dimension))) (cond (initial-element (check-type initial-element (unsigned-byte 8)) - (dotimes (i dimensions) + (dotimes (i dimension) (setf (u8ref%unsafe array i) initial-element))) (initial-contents (replace array initial-contents))) array)) -(defun make-basic-vector%t (dimensions fill-pointer initial-element initial-contents) - (check-type dimensions (and fixnum (integer 0 *))) - (let ((array (malloc-pointer-words (+ 2 dimensions)))) - (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements) - 0 :lisp) - dimensions) - (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::type) - 0 :unsigned-byte16) - #.(movitz:basic-vector-type-tag :any-t)) +(defun make-basic-vector%t (dimension fill-pointer initial-element initial-contents) + (check-type dimension (and fixnum (integer 0 *))) + (let* ((words (+ 2 dimension)) + (array (macrolet + ((do-it () + `(with-allocation-assembly (words :fixed-size-p t + :object-register :eax) + (:load-lexical (:lexical-binding dimension) :ecx) + (:movl ,(movitz:basic-vector-type-tag :any-t) + (:eax (:offset movitz-basic-vector type))) + (:movl :ecx (:eax (:offset movitz-basic-vector num-elements))) + (:addl 4 :ecx) + (:andl -8 :ecx) + (:jz 'init-done) + init-loop + (:movl :edi (:eax (:offset movitz-basic-vector data) :ecx -4)) + (:subl 4 :ecx) + (:jnz 'init-loop) + init-done + ))) + (do-it)))) (cond (fill-pointer (setf (fill-pointer array) fill-pointer)) ((array-has-fill-pointer-p array) - (setf (fill-pointer array) dimensions))) + (setf (fill-pointer array) dimension))) (cond (initial-contents (replace array initial-contents)) (initial-element - (dotimes (i dimensions) + (dotimes (i dimension) (setf (svref%unsafe array i) initial-element)))) array))

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-serv25115 Modified Files: interrupt.lisp Log Message: When the interrupt-trampoline restores the interruptee's register contents, we must first restore the contents of DF in EFLAGS. Because, if the interruptee had DF set, we'd otherwise restore illegal (non-pointer) values which would look like pointer values should we be interrupted. Date: Tue Sep 21 22:46:10 2004 Author: ffjeld Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.24 movitz/losp/muerte/interrupt.lisp:1.25 --- movitz/losp/muerte/interrupt.lisp:1.24 Tue Sep 21 15:06:02 2004 +++ movitz/losp/muerte/interrupt.lisp Tue Sep 21 22:46:06 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.24 2004/09/21 13:06:02 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.25 2004/09/21 20:46:06 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -124,20 +124,6 @@ (:locally (:movl 0 (:edi (:edi-offset atomically-continuation)))) -;;; ;; See if ESP/EBP signalled a throwing situation -;;; (:leal (:ebp 24) :edx) ; Interrupted ESP -;;; (:cmpl :edx (:ebp)) ; cmp ESP EBP -;;; (:jae 'not-throwing) -;;; (:movl (:edx) :edx) -;;; (:movl :edx (:ebp)) -;;; 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 - (:xorl :eax :eax) ; Ensure safe value (:xorl :edx :edx) ; Ensure safe value @@ -207,6 +193,14 @@ (:locally (:movl :ecx (:edi (:edi-offset raw-scratch0)))) (:movl (:ebp ,(dit-frame-offset :scratch1)) :eax) (:locally (:movl :eax (:edi (:edi-offset scratch1)))) + + ;; Load the DF flag from the interruptee before we restore + ;; its register contents. + (:testl #x400 (:ebp ,(dit-frame-offset :eflags))) ; was DF set? + (:jz 'df-not-set) + (:std) + df-not-set + (:movl (:ebp ,(dit-frame-offset :edi)) :edi) (:movl (:ebp ,(dit-frame-offset :esi)) :esi) (:movl (:ebp ,(dit-frame-offset :ebx)) :ebx)

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-serv10562 Modified Files: bignums.lisp Log Message: Have %make-bignum perform the allocation properly. The malloc-non-pointer-words operator is really deprecated. Date: Tue Sep 21 16:24:03 2004 Author: ffjeld Index: movitz/losp/muerte/bignums.lisp diff -u movitz/losp/muerte/bignums.lisp:1.8 movitz/losp/muerte/bignums.lisp:1.9 --- movitz/losp/muerte/bignums.lisp:1.8 Tue Sep 21 15:06:45 2004 +++ movitz/losp/muerte/bignums.lisp Tue Sep 21 16:24:03 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.8 2004/09/21 13:06:45 ffjeld Exp $ +;;;; $Id: bignums.lisp,v 1.9 2004/09/21 14:24:03 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -81,12 +81,13 @@ (assert (plusp bigits)) (macrolet ((do-it () - `(with-inline-assembly (:returns :eax) - (:compile-two-forms (:eax :ecx) (malloc-non-pointer-words (1+ bigits)) bigits) - (:shll 16 :ecx) - (:orl ,(movitz:tag :bignum 0) :ecx) - (:movl :ecx (:eax ,movitz:+other-type-offset+)) - ))) + `(let ((words (1+ bigits))) + (with-non-pointer-allocation-assembly (words :fixed-size-p t + :object-register :eax) + (:load-lexical (:lexical-binding bigits) :ecx) + (:shll 16 :ecx) + (:orl ,(movitz:tag :bignum 0) :ecx) + (:movl :ecx (:eax (:offset movitz-bignum type))))))) (do-it))) (defun print-bignum (x)

1 0

[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-serv31771 Modified Files: scavenge.lisp Log Message: Fixed map-stack-words in the case when a DIT (default-interrupt-trampoline) frame was interrupted while throwing to an atomically continuation target. Date: Tue Sep 21 15:56:33 2004 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.31 movitz/losp/muerte/scavenge.lisp:1.32 --- movitz/losp/muerte/scavenge.lisp:1.31 Tue Sep 21 15:01:33 2004 +++ movitz/losp/muerte/scavenge.lisp Tue Sep 21 15:56:32 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.31 2004/09/21 13:01:33 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.32 2004/09/21 13:56:32 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -155,132 +155,133 @@ (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))) - (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)) - (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!") - (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 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))) + do (flet ((scavenge-funobj-code-vector (funobj) + "Funobj 0 is assumed to be the DIT code-vector." + (if (eq 0 funobj) + (symbol-value 'default-interrupt-trampoline) + (funobj-code-vector funobj)))) + (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))) + (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 - #+ignore - ((eq nil casf-funobj) - (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: ~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) + ((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)) + (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!") + (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 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) + (warn "Scanning interrupt in PF: ~S" + (dit-frame-ref stack dit-frame :eip :unsigned-byte32))) + ((or (eq 0 casf-funobj) + (typep casf-funobj 'function)) + (let ((casf-code-vector (scavenge-funobj-code-vector casf-funobj))) + ;; 3. Scavenge the interrupted frame, according to one of i. ii. or iii. (cond + ((< interrupted-ebp interrupted-esp) + (cond + ((location-in-object-p casf-code-vector + (dit-frame-ref stack dit-frame :eip :location)) + (warn "DIT at throw situation, in target EIP=~S" + (dit-frame-ref stack dit-frame :eip :unsigned-byte32)) + (map-heap-words function interrupted-esp frame)) + ((location-in-object-p (scavenge-funobj-code-vector (dit-frame-ref stack + dit-frame + :scratch1)) + (dit-frame-ref stack dit-frame :eip :location)) + (warn "DIT at throw situation, in thrower EIP=~S" + (dit-frame-ref stack dit-frame :eip :unsigned-byte32)) + (map-heap-words function interrupted-esp frame)) + (t (error "DIT with EBP<ESP, EBP=~S, ESP=~S" + interrupted-ebp + interrupted-esp)))) ((location-in-object-p casf-code-vector (dit-frame-ref stack dit-frame :eip :location)) - (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)) - (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 - interrupted-esp)))) - ((location-in-object-p casf-code-vector - (dit-frame-ref stack dit-frame :eip :location)) - (cond - ((let ((x0-tag (ldb (byte 3 0) - (memref interrupted-esp 0 0 :unsigned-byte8)))) - (and (member x0-tag '(1 5 6 7)) - (location-in-object-p casf-code-vector - (memref interrupted-esp 0 0 :location)))) - ;; When code-vector migration is implemented... - (warn "Scanning at ~S X0 call ~S in ~S." - (dit-frame-ref stack dit-frame :eip :unsigned-byte32) - (memref interrupted-esp 0 0 :unsigned-byte32) - (funobj-name casf-funobj)) - #+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)) - (location-in-object-p casf-code-vector - (memref interrupted-esp 0 1 :location)))) - ;; When code-vector migration is implemented... - (warn "Scanning at ~S X1 call ~S in ~S." - (dit-frame-ref stack dit-frame :eip :unsigned-byte32) - (memref interrupted-esp 0 1 :unsigned-byte32) - (funobj-name casf-funobj)) - (when (eq 0 (stack-frame-ref stack frame -1)) - (break "X1 call in DIT-frame.")) + (cond + ((let ((x0-tag (ldb (byte 3 0) + (memref interrupted-esp 0 0 :unsigned-byte8)))) + (and (member x0-tag '(1 5 6 7)) + (location-in-object-p casf-code-vector + (memref interrupted-esp 0 0 :location)))) + ;; When code-vector migration is implemented... + (warn "Scanning at ~S X0 call ~S in ~S." + (dit-frame-ref stack dit-frame :eip :unsigned-byte32) + (memref interrupted-esp 0 0 :unsigned-byte32) + (funobj-name casf-funobj)) + #+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)) + (location-in-object-p casf-code-vector + (memref interrupted-esp 0 1 :location)))) + ;; When code-vector migration is implemented... + (warn "Scanning at ~S X1 call ~S in ~S." + (dit-frame-ref stack dit-frame :eip :unsigned-byte32) + (memref interrupted-esp 0 1 :unsigned-byte32) + (funobj-name casf-funobj)) + (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) + (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) #+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) + (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) + #+ignore (map-heap-words function (+ interrupted-esp 1) 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) - #+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) - #+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))))) + 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/losp/los0.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-serv21910 Modified Files: los0.lisp Log Message: Various fiddling with testing functions etc. Date: Tue Sep 21 15:11:08 2004 Author: ffjeld Index: movitz/losp/los0.lisp diff -u movitz/losp/los0.lisp:1.21 movitz/losp/los0.lisp:1.22 --- movitz/losp/los0.lisp:1.21 Wed Sep 15 12:22:57 2004 +++ movitz/losp/los0.lisp Tue Sep 21 15:11:08 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 1 18:08:32 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: los0.lisp,v 1.21 2004/09/15 10:22:57 ffjeld Exp $ +;;;; $Id: los0.lisp,v 1.22 2004/09/21 13:11:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -988,8 +988,9 @@ (muerte::with-bochs-tracing () (eval form))) -(muerte.toplevel:define-toplevel-command :mapkey (code-char) - (let ((char (etypecase code-char +(muerte.toplevel:define-toplevel-command :mapkey (code-char-form) + (let* ((code-char (eval code-char-form)) + (char (etypecase code-char (character code-char) (integer (code-char code-char))))) (format t "~&Hit the (single) key you want to map to ~S..." char) @@ -1083,7 +1084,7 @@ (defun test-clc (&optional timeout) (test-timer timeout) (loop - (clc::test-clc))) + (funcall (find-symbol (string :test-clc) :clc)))) (defun test-timer (&optional timeout) (setf (exception-handler 32) @@ -1128,7 +1129,7 @@ (current-stack-frame)) (setf *timer-stack* (muerte::copy-current-control-stack)) (setf (pit8253-timer-mode 0) +pit8253-mode-single-timeout+ - (pit8253-timer-count 0) (or timeout (+ 10 (random 4000)))) + (pit8253-timer-count 0) (or timeout (+ 5 (random 2000)))) (with-inline-assembly (:returns :nothing) (:compile-form (:result-mode :ecx) muerte.x86-pc::*screen*) (:shrl 2 :ecx) @@ -1140,7 +1141,7 @@ (:shrl 2 :ecx) ((:gs-override) :movw #x4646 (:ecx 158))) (setf (pit8253-timer-mode 0) +pit8253-mode-single-timeout+ - (pit8253-timer-count 0) (or timeout (+ 10 (random 4000)))) + (pit8253-timer-count 0) (or timeout (+ 10 (random 1000)))) (setf (pic8259-irq-mask) #xfffe) (pic8259-end-of-interrupt 0) (with-inline-assembly (:returns :nothing) (:sti)) @@ -1163,14 +1164,20 @@ )) (defun test-throwing (&optional (x #xffff)) - (test-timer x) + (when x + (test-timer x)) (loop (catch 'foo - (funcall (lambda () - (unless (logbitp 9 (eflags)) - (break "Someone switched off interrupts!")) - (incf (memref-int muerte.x86-pc::*screen* 0 0 :unsigned-byte16 t)) - (throw 'foo nil)))))) + (unwind-protect + (funcall (lambda () + (unwind-protect + (progn +;;; (unless (logbitp 9 (eflags)) +;;; (break "Someone switched off interrupts!")) + (incf (memref-int muerte.x86-pc::*screen* 0 0 :unsigned-byte16 t)) + (throw 'foo 'inner-peace)) + (incf (memref-int muerte.x86-pc::*screen* 0 80 :unsigned-byte16 t))))) + (incf (memref-int muerte.x86-pc::*screen* 0 160 :unsigned-byte16 t)))))) (defun genesis () @@ -1203,7 +1210,7 @@ (setf *package* (find-package "INIT")) (clos-bootstrap) (when muerte::*multiboot-data* - (set-textmode +vga-state-90x60+)) + (set-textmode +vga-state-90x30+)) (cond ((not (cpu-featurep :tsc))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/read.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-serv21878 Modified Files: read.lisp Log Message: Added #\' to the list of token terminators. Date: Tue Sep 21 15:10:40 2004 Author: ffjeld Index: movitz/losp/muerte/read.lisp diff -u movitz/losp/muerte/read.lisp:1.9 movitz/losp/muerte/read.lisp:1.10 --- movitz/losp/muerte/read.lisp:1.9 Wed Aug 11 11:34:30 2004 +++ movitz/losp/muerte/read.lisp Tue Sep 21 15:10:40 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Oct 17 21:50:42 2001 ;;;; -;;;; $Id: read.lisp,v 1.9 2004/08/11 09:34:30 ffjeld Exp $ +;;;; $Id: read.lisp,v 1.10 2004/09/21 13:10:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -75,7 +75,7 @@ (t (error "There is junk in the string ~S." (substring string start end)))))))) -(defconstant +simple-token-terminators+ '(#\space #\tab #\newline #\) #$)) +(defconstant +simple-token-terminators+ '(#\space #\tab #\newline #$ #\( #\')) (defun find-token-end (string &key (start 0) (end (length string))) (do ((i start (1+ i)))

1 0