July 2004 - movitz-cvs@common-lisp.net - mailman3.common-lisp.net

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

15 Jul '04

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv30689 Modified Files: los0-gc.lisp Log Message: Some pieces of los0-gc were (because of laziness) set up as part of the default system. This factors out los0-gc from the default system properly. Also, changed the signature and implementation of install-los0-consing a bit: It now takes the run-time-context object to install onto as an explicit (keyword) argument. Date: Thu Jul 15 04:22:08 2004 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.26 movitz/losp/los0-gc.lisp:1.27 --- movitz/losp/los0-gc.lisp:1.26 Wed Jul 14 17:27:13 2004 +++ movitz/losp/los0-gc.lisp Thu Jul 15 04:22:08 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.26 2004/07/15 00:27:13 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.27 2004/07/15 11:22:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -99,7 +99,7 @@ (:ret)))) (do-it))) -(define-primitive-function muerte::get-cons-pointer () +(define-primitive-function los0-get-cons-pointer () "Return in EAX the next object location with space for EAX words, with tag 6. Preserve ECX." (macrolet @@ -123,7 +123,7 @@ (:ret)))) (do-it))) -(define-primitive-function muerte::cons-commit () +(define-primitive-function los0-cons-commit () "Commit allocation of ECX/fixnum words. Preserve EAX and EBX." (macrolet @@ -240,42 +240,44 @@ (:leal (:edx :ecx 8) :eax)))) (do-it))) -(defun install-los0-consing (&optional (space-kilobytes 1024)) - (let ((size (* space-kilobytes #x100))) - (setf (%run-time-context-slot 'nursery-space) - (allocate-duo-space size)) - (setf (exception-handler 113) - (lambda (exception interrupt-frame) - (declare (ignore exception interrupt-frame)) - (unless *gc-quiet* - (format t "~&;; GC.. ")) - (stop-and-copy) - ;; This is a nice opportunity to poll the keyboard.. - (loop - (case (muerte.x86-pc.keyboard:poll-char) - ((#\esc) - (break "Los0 GC keyboard poll.")) - ((nil) - (return)))))) - (let ((conser (symbol-value 'los0-fast-cons))) - (check-type conser vector) - (setf (%run-time-context-slot 'muerte::fast-cons) - conser)) - (let ((conser (symbol-value 'los0-box-u32-ecx))) - (check-type conser vector) - (setf (%run-time-context-slot 'muerte::box-u32-ecx) - conser)) - (let ((old-malloc (symbol-function 'muerte:malloc-clumps))) - (setf (symbol-function 'muerte:malloc-clumps) - (symbol-function 'los0-malloc-clumps)) - (setf (symbol-function 'los0-malloc-clumps) - old-malloc)) - (let ((old-malloc-data (symbol-function 'muerte:malloc-data-clumps))) - (setf (symbol-function 'muerte:malloc-data-clumps) - (symbol-function 'los0-malloc-data-clumps)) - (setf (symbol-function 'los0-malloc-data-clumps) - old-malloc-data)) - (values))) +(defun install-los0-consing (&key (run-time-context (current-run-time-context)) + (kb-size 1024) + duo-space) + "Install the 'Los0' GC architecture on run-time-context." + (setf (%run-time-context-slot 'nursery-space run-time-context) + (or duo-space + (allocate-duo-space (* kb-size #x100)))) + (setf (exception-handler 113) + (lambda (exception interrupt-frame) + (declare (ignore exception interrupt-frame)) + (unless *gc-quiet* + (format t "~&;; GC.. ")) + (stop-and-copy) + (loop ; This is a nice opportunity to poll the keyboard.. + (case (muerte.x86-pc.keyboard:poll-char) + ((#\esc) + (break "Los0 GC keyboard poll.")) + ((nil) + (return)))))) + (flet ((install-primitive (name slot) + (let ((code-vector (symbol-value name))) + (check-type code-vector code-vector) + (setf (%run-time-context-slot slot run-time-context) code-vector)))) + (install-primitive 'los0-fast-cons 'muerte::fast-cons) + (install-primitive 'los0-box-u32-ecx 'muerte::box-u32-ecx) + (install-primitive 'los0-get-cons-pointer 'muerte::get-cons-pointer) + (install-primitive 'los0-cons-commit 'muerte::cons-commit)) + (let ((old-malloc (symbol-function 'muerte:malloc-clumps))) + (setf (symbol-function 'muerte:malloc-clumps) + (symbol-function 'los0-malloc-clumps)) + (setf (symbol-function 'los0-malloc-clumps) + old-malloc)) + (let ((old-malloc-data (symbol-function 'muerte:malloc-data-clumps))) + (setf (symbol-function 'muerte:malloc-data-clumps) + (symbol-function 'los0-malloc-data-clumps)) + (setf (symbol-function 'los0-malloc-data-clumps) + old-malloc-data)) + (values)) (defun install-old-consing () (let ((conser (symbol-value 'muerte::fast-cons)))

1 0

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

15 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv25701 Modified Files: primitive-functions.lisp Log Message: For the default, 'dummy' GC architecture, provide some operators that were missing before (ie. only implemented in los0-gc) so that e.g. bignum-consing will work without los0-gc. Date: Thu Jul 15 04:18:49 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.27 movitz/losp/muerte/primitive-functions.lisp:1.28 --- movitz/losp/muerte/primitive-functions.lisp:1.27 Mon Jul 12 19:26:28 2004 +++ movitz/losp/muerte/primitive-functions.lisp Thu Jul 15 04:18:49 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.27 2004/07/13 02:26:28 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.28 2004/07/15 11:18:49 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -443,6 +443,48 @@ (:leal (:eax :ecx) :eax) (:ret))) +(define-primitive-function muerte::get-cons-pointer () + "Return in EAX the next object location with space for EAX words, with tag 6. +Preserve ECX." + (macrolet + ((do-it () + ;; Here we just call malloc, and don't care if the allocation + ;; is never comitted. + `(with-inline-assembly (:returns :multiple-values) + (:locally (:movl :ecx (:edi (:edi-offset scratch0)))) + (:movl :eax :ebx) + (:call-global-constant malloc) + (:locally (:movl (:edi (:edi-offset scratch0)) :ecx)) + (:leal (:eax 6) :eax) + (:ret)) + #+ignore + `(with-inline-assembly (:returns :multiple-values) + (:locally (:movl (:edi (:edi-offset malloc-buffer)) :eax)) + (:movl (:eax 4) :ecx) ; cons pointer to ECX + (:leal (:eax :ecx 6) :eax) + (:ret)))) + (do-it))) + +(define-primitive-function muerte::cons-commit () + "Commit allocation of ECX/fixnum words. +Preserve EAX and EBX." + (macrolet + ((do-it () + ;; Since get-cons-pointer is implemented as an (already committed) + ;; malloc, this is a NOP + `(with-inline-assembly (:returns :multiple-values) + (:ret)) + #+ignore + `(with-inline-assembly (:returns :multiple-values) + (:pushl :eax) + (:pushl :ebx) + (:movl :ecx :ebx) + (:call-global-constant malloc) + (:popl :ebx) + (:popl :eax) + (:ret)))) + (do-it))) + (defun malloc-initialize (buffer-start buffer-size) "BUFFER-START: the (fixnum) 4K address. BUFFER-SIZE: The size in 4K units." (check-type buffer-start fixnum) @@ -494,7 +536,7 @@ (:leal (:eax :edx) :eax) (:movl :ecx (:eax)) (:movl :ebx (:eax 4)) - (:incl :eax) + (:addl 1 :eax) (:ret))) (define-primitive-function ensure-heap-cons-variable () @@ -517,16 +559,28 @@ return-ok (:ret))) - (define-primitive-function box-u32-ecx () "Make u32 in ECX into a fixnum or bignum in EAX." - (with-inline-assembly (:returns :multiple-values) - (:cmpl #.movitz:+movitz-most-positive-fixnum+ :ecx) - (:ja 'not-fixnum) - (:leal ((:ecx #.movitz:+movitz-fixnum-factor+)) :eax) - (:ret) - not-fixnum - (:int 107))) ; not implemented by default! + (macrolet + ((do-it () + `(with-inline-assembly (:returns :multiple-values) + (:cmpl ,movitz:+movitz-most-positive-fixnum+ :ecx) + (:ja 'not-fixnum) + (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :eax) + (:ret) + not-fixnum + (:locally (:movl :ecx (:edi (:edi-offset scratch0)))) ; Save value for later + (:call-global-constant malloc) + (:movl ,(dpb movitz:+movitz-fixnum-factor+ + (byte 16 16) + (movitz:tag :bignum 0)) + (:eax)) + (:locally (:movl (:edi (:edi-offset scratch0)) :ecx)) ; Restore value + (:movl :ecx (:eax 4)) + (:leal (:eax 6) :eax) + (:ret)))) + (do-it))) + (define-primitive-function unbox-u32 () "Load (ldb (byte 32 0) EAX) into ECX." @@ -550,6 +604,8 @@ fail (:int 107)))) (do-it))) + + ;;;;

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/run-time-context.lisp
by Frode Vatvedt Fjeld 15 Jul '04

15 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv16448 Modified Files: run-time-context.lisp Log Message: Fixed bug in (setf %run-time-context-slot) for slots of type code-vector-word. Date: Thu Jul 15 04:17:02 2004 Author: ffjeld Index: movitz/losp/muerte/run-time-context.lisp diff -u movitz/losp/muerte/run-time-context.lisp:1.7 movitz/losp/muerte/run-time-context.lisp:1.8 --- movitz/losp/muerte/run-time-context.lisp:1.7 Thu Jul 8 11:53:57 2004 +++ movitz/losp/muerte/run-time-context.lisp Thu Jul 15 04:17:02 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Nov 12 18:33:02 2003 ;;;; -;;;; $Id: run-time-context.lisp,v 1.7 2004/07/08 18:53:57 ffjeld Exp $ +;;;; $Id: run-time-context.lisp,v 1.8 2004/07/15 11:17:02 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -90,7 +90,7 @@ (lu32 (setf (memref context -6 (third slot) :unsigned-byte32) value)) (code-vector-word - (setf (memref context -6 (third slot) :unsigned-byte32) value))))) + (setf (memref context -6 (third slot) :code-vector) value))))) (defun %run-time-context-segment-base (slot-name &optional (context (current-run-time-context)))

1 0

[movitz-cvs] CVS update: movitz/packages.lisp
by Frode Vatvedt Fjeld 15 Jul '04

15 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv12770 Modified Files: packages.lisp Log Message: Added a symbol to muerte. Date: Thu Jul 15 04:16:14 2004 Author: ffjeld Index: movitz/packages.lisp diff -u movitz/packages.lisp:1.30 movitz/packages.lisp:1.31 --- movitz/packages.lisp:1.30 Sun Jul 11 15:59:26 2004 +++ movitz/packages.lisp Thu Jul 15 04:16:14 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.30 2004/07/11 22:59:26 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.31 2004/07/15 11:16:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1189,6 +1189,7 @@ map-active-restarts with-basic-restart + #:code-vector #:vector-u8 #:vector-u16 #:vector-u32

1 0

[movitz-cvs] CVS update: movitz/bochsrc.txt
by Frode Vatvedt Fjeld 15 Jul '04

15 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv23723 Modified Files: bochsrc.txt Log Message: Added keyboard_mapping config line. Date: Wed Jul 14 17:29:39 2004 Author: ffjeld Index: movitz/bochsrc.txt diff -u movitz/bochsrc.txt:1.3 movitz/bochsrc.txt:1.4 --- movitz/bochsrc.txt:1.3 Tue Jul 13 06:00:10 2004 +++ movitz/bochsrc.txt Wed Jul 14 17:29:39 2004 @@ -18,6 +18,9 @@ #diskc: file=hd10meg.img, cyl=306, heads=4, spt=17 #newharddrivesupport: enabled=1 +# This is just to make X11 clipboard pasting into bochs work. +keyboard_mapping: enabled=1, map=../../tmp/bochs-cvs/gui/keymaps/x11-pc-us.map + # choose the boot disk. boot: a

1 0

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

15 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv20672 Modified Files: special-operators.lisp Log Message: Removed dead code. Date: Wed Jul 14 17:29:19 2004 Author: ffjeld Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.26 movitz/special-operators.lisp:1.27 --- movitz/special-operators.lisp:1.26 Mon Jul 12 19:26:14 2004 +++ movitz/special-operators.lisp Wed Jul 14 17:29:19 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.26 2004/07/13 02:26:14 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.27 2004/07/15 00:29:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1012,120 +1012,6 @@ (compiler-values () :returns returns :code `((:add ,(movitz-binding term1 env) ,(movitz-binding term2 env) ,returns)))))) - - -(define-special-operator muerte::+%2op (&all all &form form &env env &result-mode result-mode) - (assert (not (eq :boolean result-mode)) () - "Boolean result-mode for +%2op makes no sense.") - (destructuring-bind (term1 term2) - (cdr form) - (flet ((compile-constant-add (constant-term term-form) - (compiler-values-bind (&code term2-code &returns term2-returns &type term2-type - &functional-p term2-functional-p &modifies term2-modifies) - (compiler-call #'compile-form-unprotected - :result-mode (case result-mode - ((:eax :ebx :ecx :edx) - result-mode) - (t :eax)) - :defaults all - :form term-form) - (assert term2-type) - (let ((term2-type (type-specifier-primary term2-type))) -;;; (declare (ignore term2-type)) -;;; (warn "t2-type: ~S, t2-ret: ~S, rm: ~S" -;;; term2-type term2-returns result-mode) - (cond - ((and (eq 'binding-type (operator term2-type)) - (eq (second term2-type) result-mode)) - (let ((binding result-mode)) - (check-type binding lexical-binding) - (compiler-values () - :returns binding - :type (binding-type-specifier binding) - :code (append - (compiler-call #'compile-form-unprotected - :result-mode :ignore - :defaults all - :form term-form) - `((:incf-lexvar ,binding ,constant-term)))))) - ((eq :untagged-fixnum-eax term2-returns) - (case result-mode - (:untagged-fixnum-eax - (compiler-values () - :returns :untagged-fixnum-eax - :type 'integer - :functional-p term2-functional-p - :modifies term2-modifies - :code (append term2-code - `((:addl ,constant-term :eax)) - (unless (< #x-10000 constant-term #x10000) - '((:into)))))) - (t (let ((result-register (accept-register-mode result-mode))) - ;; (warn "XX") - (compiler-values () - :returns result-register - :modifies term2-modifies - :functional-p term2-functional-p - :code (append term2-code - `((:leal ((:eax ,+movitz-fixnum-factor+) - ,(* +movitz-fixnum-factor+ constant-term)) - ,result-register)))))))) - (t (multiple-value-bind (new-load-term-code add-result-mode) - (make-result-and-returns-glue (accept-register-mode term2-returns) - term2-returns - term2-code) - (let ((add-register (single-value-register add-result-mode)) - (label (gensym "not-integer-"))) - (compiler-values () - :returns add-register - :functional-p term2-functional-p - :modifies term2-modifies - :type 'integer - :code (append - new-load-term-code - (unless nil - #+ignore (subtypep (translate-program term2-type :muerte.cl :cl) - `(integer ,+movitz-most-negative-fixnum+ - ,+movitz-most-positive-fixnum+)) - `((:testb ,+movitz-fixnum-zmask+ - ,(register32-to-low8 add-register)) - (:jnz '(:sub-program (,label) (:int 107) (:jmp (:pc+ -4)))))) - `((:addl ,(* constant-term +movitz-fixnum-factor+) ,add-register)) - (unless nil - #+ignore (subtypep (translate-program term2-type :muerte.cl :cl) - `(integer ,(+ +movitz-most-negative-fixnum+ - constant-term) - ,(+ +movitz-most-positive-fixnum+ - constant-term))) - '((:into))))))))))))) - (cond - ((and (movitz-constantp term1 env) - (movitz-constantp term2 env)) - (compiler-call #'compile-self-evaluating - :forward all - :form (+ (eval-form term1 env) - (eval-form term2 env)))) - ((and (movitz-constantp term1 env) ; first operand zero? - (zerop (eval-form term1 env))) - (compiler-call #'compile-form-unprotected - :forward all - :form term2)) ; (+ 0 x) => x - ((and (movitz-constantp term2 env) ; second operand zero? - (zerop (eval-form term2 env))) - (compiler-call #'compile-form-unprotected - :forward all - :form term1)) ; (+ x 0) => x - ((movitz-constantp term1 env) - (let ((constant-term1 (eval-form term1 env))) - (check-type constant-term1 (signed-byte 30)) - (compile-constant-add constant-term1 term2))) - ((movitz-constantp term2 env) - (let ((constant-term2 (eval-form term2 env))) - (check-type constant-term2 (signed-byte 30)) - (compile-constant-add constant-term2 term1))) - (t (compiler-call #'compile-apply-symbol - :forward all - :form `(muerte.cl:+ ,term1 ,term2))))))) (define-special-operator muerte::include (&form form) (let ((*require-dependency-chain*

1 0

[movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp
by Frode Vatvedt Fjeld 15 Jul '04

15 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv9312 Modified Files: debugger.lisp Log Message: Have the debugger accept bigger pointer-sizes as "reasonable". Date: Wed Jul 14 17:28:30 2004 Author: ffjeld Index: movitz/losp/x86-pc/debugger.lisp diff -u movitz/losp/x86-pc/debugger.lisp:1.15 movitz/losp/x86-pc/debugger.lisp:1.16 --- movitz/losp/x86-pc/debugger.lisp:1.15 Mon Jul 12 04:10:40 2004 +++ movitz/losp/x86-pc/debugger.lisp Wed Jul 14 17:28:30 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Nov 22 10:09:18 2002 ;;;; -;;;; $Id: debugger.lisp,v 1.15 2004/07/12 11:10:40 ffjeld Exp $ +;;;; $Id: debugger.lisp,v 1.16 2004/07/15 00:28:30 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -58,8 +58,7 @@ (defun pointer-in-range (x) (with-inline-assembly (:returns :boolean-cf=1) (:compile-form (:result-mode :eax) x) - ;; (:subl #x100000 :eax) - (:cmpl #x1000000 :eax))) + (:cmpl #x10000000 :eax))) (defun code-vector-offset (code-vector address)

1 0

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

15 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv28640 Modified Files: scavenge.lisp Log Message: Minor edit. Date: Wed Jul 14 17:27:34 2004 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.18 movitz/losp/muerte/scavenge.lisp:1.19 --- movitz/losp/muerte/scavenge.lisp:1.18 Tue Jul 13 15:44:37 2004 +++ movitz/losp/muerte/scavenge.lisp Wed Jul 14 17:27:34 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.18 2004/07/13 22:44:37 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.19 2004/07/15 00:27:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -181,7 +181,7 @@ (map-heap-words function (1+ interrupted-esp) frame) (error "Don't know how to scavenge across interrupt frame at ~S." interrupt-frame))))))) - (t (error "Don't know how to scavenge across a frame of kind ~S." funobj))))) + (t (error "Don't know how to scavenge across frame ~S of kind ~S." frame funobj))))) (values)) (defparameter *primitive-funcall-patterns*

1 0

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

15 Jul '04

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv20577 Modified Files: los0-gc.lisp Log Message: Some tweaking of GC messages etc. Date: Wed Jul 14 17:27:13 2004 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.25 movitz/losp/los0-gc.lisp:1.26 --- movitz/losp/los0-gc.lisp:1.25 Tue Jul 13 06:02:45 2004 +++ movitz/losp/los0-gc.lisp Wed Jul 14 17:27:13 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.25 2004/07/13 13:02:45 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.26 2004/07/15 00:27:13 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -18,14 +18,14 @@ (in-package muerte.init) -(defconstant +space-size+ #xfffd) - -(defun make-space (location) +(defvar *gc-quiet* nil) + +(defun make-space (location size) "Make a space vector at a fixed location." (assert (evenp location)) (macrolet ((x (index) `(memref location 0 ,index :unsigned-byte32))) - (setf (x 1) (* #.movitz:+movitz-fixnum-factor+ +space-size+) + (setf (x 1) (* #.movitz:+movitz-fixnum-factor+ size) (x 0) #.(cl:dpb (bt:enum-value 'movitz:movitz-vector-element-type :u32) (cl:byte 8 8) (bt:enum-value 'movitz:other-type-byte :basic-vector)))) @@ -247,12 +247,16 @@ (setf (exception-handler 113) (lambda (exception interrupt-frame) (declare (ignore exception interrupt-frame)) - (format t "~&;; GC.. ") + (unless *gc-quiet* + (format t "~&;; GC.. ")) (stop-and-copy) ;; This is a nice opportunity to poll the keyboard.. - (case (muerte.x86-pc.keyboard:poll-char) - ((#\esc) - (break "Los0 GC keyboard poll."))))) + (loop + (case (muerte.x86-pc.keyboard:poll-char) + ((#\esc) + (break "Los0 GC keyboard poll.")) + ((nil) + (return)))))) (let ((conser (symbol-value 'los0-fast-cons))) (check-type conser vector) (setf (%run-time-context-slot 'muerte::fast-cons) @@ -406,10 +410,11 @@ "Fail: i=~D, x: ~S/~Z, y: ~S/~Z, o: ~Z, n: ~Z" i x x y y oldspace newspace))) ;; GC completed, oldspace is evacuated. - (let ((old-size (truncate (- (space-fresh-pointer oldspace) 2) 2)) - (new-size (truncate (- (space-fresh-pointer newspace) 2) 2))) - (format t "Old space: ~/muerte:pprint-clumps/, new space: ~ + (unless *gc-quiet* + (let ((old-size (truncate (- (space-fresh-pointer oldspace) 2) 2)) + (new-size (truncate (- (space-fresh-pointer newspace) 2) 2))) + (format t "Old space: ~/muerte:pprint-clumps/, new space: ~ ~/muerte:pprint-clumps/, freed: ~/muerte:pprint-clumps/.~%" - old-size new-size (- old-size new-size))) + old-size new-size (- old-size new-size)))) (initialize-space oldspace)))) (values))

1 0

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

15 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv12672 Modified Files: integers.lisp Log Message: Added %negatef, in an effort to reduce bignum consing a bit. Date: Wed Jul 14 17:26:26 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.64 movitz/losp/muerte/integers.lisp:1.65 --- movitz/losp/muerte/integers.lisp:1.64 Wed Jul 14 16:45:12 2004 +++ movitz/losp/muerte/integers.lisp Wed Jul 14 17:26:26 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.64 2004/07/14 23:45:12 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.65 2004/07/15 00:26:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -87,6 +87,19 @@ (define-simple-typep (bit bitp) (x) (or (eq x 0) (eq x 1))) +;;; + +(defun %negatef (x p0 p1) + "Negate x. If x is not eq to p0 or p1, negate x destructively." + (etypecase x + (fixnum (- x)) + (bignum + (if (or (eq x p0) (eq x p1)) + (- x) + (with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :eax) x) + (:xorl #xff00 (:eax #.movitz:+other-type-offset+))))))) + ;;; Addition (define-compiler-macro + (&whole form &rest operands &environment env) @@ -364,7 +377,6 @@ (:call-global-constant cons-commit) (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) (:edi (:edi-offset atomically-status)))) - pfix-pbig-done) )) (((integer * -1) (integer 0 *)) @@ -372,7 +384,7 @@ (((integer 0 *) (integer * -1)) (- x (- y))) (((integer * -1) (integer * -1)) - (+ (- x) (- y))) + (%negatef (+ (- x) (- y)) x y)) ))) (do-it))) (t (&rest terms) @@ -511,7 +523,7 @@ (((integer 0 *) (integer * -1)) (+ minuend (- subtrahend))) (((integer * -1) (integer 0 *)) - (- (+ (- minuend) subtrahend))) + (%negatef (+ (- minuend) subtrahend) minuend subtrahend)) (((integer * -1) (integer * -1)) (+ minuend (- subtrahend))) ))) @@ -520,7 +532,7 @@ (declare (dynamic-extent subtrahends)) (if subtrahends (reduce #'- subtrahends :initial-value minuend) - (- 0 minuend))))) + (- minuend))))) (define-modify-macro decf (&optional (delta-form 1)) -) @@ -1469,15 +1481,17 @@ (((integer * -1) (integer 0 *)) (multiple-value-bind (q r) (truncate (- number) divisor) - (values (- q) (- r)))) + (values (%negatef q number divisor) + (%negatef r number divisor)))) (((integer 0 *) (integer * -1)) (multiple-value-bind (q r) (truncate (- number) divisor) - (values (- q) r))) + (values (%negatef q number divisor) + r))) (((integer * -1) (integer * -1)) (multiple-value-bind (q r) (truncate (- number) divisor) - (values q (- r)))) + (values q (%negatef r number divisor)))) )))) (defun / (number &rest denominators)

1 0