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

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

12 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv23019 Modified Files: inspect.lisp Log Message: Changed the low-level formatting of bignums: Now the number of bigits is stored as factors of 4. This restricts the number of bigits to (1- (expt 2 14)), which is still plenty. Date: Mon Jul 12 04:09:18 2004 Author: ffjeld Index: movitz/losp/muerte/inspect.lisp diff -u movitz/losp/muerte/inspect.lisp:1.16 movitz/losp/muerte/inspect.lisp:1.17 --- movitz/losp/muerte/inspect.lisp:1.16 Thu Jul 8 14:48:58 2004 +++ movitz/losp/muerte/inspect.lisp Mon Jul 12 04:09:18 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.16 2004/07/08 21:48:58 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.17 2004/07/12 11:09:18 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -284,11 +284,11 @@ (:movl (:eax ,movitz:+other-type-offset+) :ecx) (:shrl 16 :ecx) shrink-loop - (:cmpl 1 :ecx) + (:cmpl ,movitz:+movitz-fixnum-factor+ :ecx) (:je 'shrink-no-more) - (:cmpl 0 (:eax (:ecx 4) ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))) + (:cmpl 0 (:eax :ecx ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))) (:jnz 'shrink-done) - (:subl 1 :ecx) + (:subl ,movitz:+movitz-fixnum-factor+ :ecx) (:jmp 'shrink-loop) shrink-no-more (:cmpl ,(1+ movitz:+movitz-most-positive-fixnum+) @@ -299,6 +299,8 @@ (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :eax) (:jmp 'done))) shrink-done + (:testb 3 :cl) + (:jnz '(:sub-program () (:int 59))) (:movw :cx (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::length))) done )))

1 0

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

12 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv22544 Modified Files: storage-types.lisp Log Message: Changed the low-level formatting of bignums: Now the number of bigits is stored as factors of 4. This restricts the number of bigits to (1- (expt 2 14)), which is still plenty. Date: Mon Jul 12 04:09:12 2004 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.26 movitz/storage-types.lisp:1.27 --- movitz/storage-types.lisp:1.26 Thu Jul 8 05:01:51 2004 +++ movitz/storage-types.lisp Mon Jul 12 04:09:12 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.26 2004/07/08 12:01:51 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.27 2004/07/12 11:09:12 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1243,7 +1243,15 @@ (length :binary-type lu16 :initarg :length - :accessor movitz-bignum-length) + :accessor movitz-bignum-length + :map-binary-write (lambda (x &optional type) + (declare (ignore type)) + (check-type x (unsigned-byte 14)) + (* x 4)) + :map-binary-read (lambda (x &optional type) + (declare (ignore type)) + (assert (zerop (mod x 4))) + (truncate x 4))) (bigit0 :binary-type :label) (value :initarg :value

1 0

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

12 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv16359 Modified Files: integers.lisp Log Message: Improved logandc1 on bignums. Date: Mon Jul 12 02:13:12 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.43 movitz/losp/muerte/integers.lisp:1.44 --- movitz/losp/muerte/integers.lisp:1.43 Sun Jul 11 16:05:24 2004 +++ movitz/losp/muerte/integers.lisp Mon Jul 12 02:13:12 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.43 2004/07/11 23:05:24 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.44 2004/07/12 09:13:12 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -88,7 +88,7 @@ finally (return (if (zerop constant-term) non-constant-operands (cons constant-term non-constant-operands)))))) - `(+ (+%2op ,(first operands) ,(second operands)) ,@(cddr operands)))))) + `(+ (+ ,(first operands) ,(second operands)) ,@(cddr operands)))))) (defun + (&rest terms) (declare (without-check-stack-limit)) @@ -1553,15 +1553,44 @@ (reduce #'logand integers))))) (defun logandc1 (integer1 integer2) - (number-double-dispatch (integer1 integer2) - ((t positive-fixnum) - (with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) integer1) - (:call-global-constant unbox-u32) - (:shll #.movitz:+movitz-fixnum-shift+ :ecx) - (:compile-form (:result-mode :eax) integer2) - (:notl :ecx) - (:andl :ecx :eax))))) + (macrolet + ((do-it () + `(number-double-dispatch (integer1 integer2) + ((t positive-fixnum) + (with-inline-assembly (:returns :eax :type fixnum) + (:compile-form (:result-mode :eax) integer1) + (:call-global-constant unbox-u32) + (:shll ,movitz:+movitz-fixnum-shift+ :ecx) + (:compile-form (:result-mode :eax) integer2) + (:notl :ecx) + (:andl :ecx :eax))) + (((eql 0) t) integer2) + (((eql -1) t) 0) + ((positive-fixnum positive-bignum) + (%bignum-canonicalize + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ecx) (copy-bignum integer2) integer1) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:notl :ecx) + (:andl :ecx + (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))))) + ((positive-bignum positive-bignum) + (%bignum-canonicalize + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) (copy-bignum integer2) integer1) + (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) + :ecx) + (:leal ((:ecx 4) -4) :edx) + pb-pb-andc1-loop + (:movl (:ebx :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) + :ecx) + (:notl :ecx) + (:andl :ecx + (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) + (:subl 4 :edx) + (:jnc 'pb-pb-andc1-loop))))))) + (do-it))) + (defun logandc2 (integer1 integer2) (logandc1 integer2 integer1))

1 0

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

12 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv13858 Modified Files: textmode.lisp Log Message: Tweaked when newline is signalled during scroll-down. Date: Mon Jul 12 02:12:40 2004 Author: ffjeld Index: movitz/losp/x86-pc/textmode.lisp diff -u movitz/losp/x86-pc/textmode.lisp:1.7 movitz/losp/x86-pc/textmode.lisp:1.8 --- movitz/losp/x86-pc/textmode.lisp:1.7 Mon Jul 12 00:57:52 2004 +++ movitz/losp/x86-pc/textmode.lisp Mon Jul 12 02:12:40 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Thu Nov 9 15:38:56 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: textmode.lisp,v 1.7 2004/07/12 07:57:52 ffjeld Exp $ +;;;; $Id: textmode.lisp,v 1.8 2004/07/12 09:12:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -69,13 +69,13 @@ (defun textmode-write-char (c) (case c (#\newline + (setf *cursor-x* 0) + (move-vga-cursor 0 *cursor-y*) (cond ((>= (1+ *cursor-y*) *screen-height*) (textmode-scroll-down) (setf *cursor-y* (1- *screen-height*))) - (t (incf *cursor-y*))) - (setf *cursor-x* 0) - (move-vga-cursor 0 *cursor-y*)) + (t (incf *cursor-y*)))) (#\backspace (if (/= 0 *cursor-x*) (decf *cursor-x*) @@ -125,13 +125,13 @@ (defun textmode-scroll-down () (declare (special muerte.lib::*scroll-offset*)) - (signal 'newline) (incf muerte.lib::*scroll-offset*) (loop with stride = (* 2 *screen-stride*) for y below *screen-height* as src from (+ *screen* stride) by stride as dst from *screen* by stride - do (textmode-copy-line dst src *screen-width*))) + do (textmode-copy-line dst src *screen-width*)) + (signal 'newline)) (defun textmode-clear-line (from-column line) (let ((dest (+ *screen* (* line *screen-width* 2) (* from-column 2))))

1 0

[movitz-cvs] CVS update: movitz/losp/lib/console.lisp
by Frode Vatvedt Fjeld 12 Jul '04

12 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/lib In directory common-lisp.net:/tmp/cvs-serv10976 Modified Files: console.lisp Log Message: Add newline signal to scroll-down. Date: Mon Jul 12 02:11:56 2004 Author: ffjeld Index: movitz/losp/lib/console.lisp diff -u movitz/losp/lib/console.lisp:1.4 movitz/losp/lib/console.lisp:1.5 --- movitz/losp/lib/console.lisp:1.4 Mon Jan 19 03:23:44 2004 +++ movitz/losp/lib/console.lisp Mon Jul 12 02:11:56 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu Aug 14 18:14:16 2003 ;;;; -;;;; $Id: console.lisp,v 1.4 2004/01/19 11:23:44 ffjeld Exp $ +;;;; $Id: console.lisp,v 1.5 2004/07/12 09:11:56 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -213,6 +213,7 @@ (setf (console-char console x y) (console-char console x (1+ y))))) (clear-line console 0 (1- (console-height console))) + (signal 'muerte::newline) nil) (defmethod scroll-down :after (console)

1 0

[movitz-cvs] CVS update: movitz/doc/ChangeLog
by Frode Vatvedt Fjeld 12 Jul '04

12 Jul '04

Update of /project/movitz/cvsroot/movitz/doc In directory common-lisp.net:/tmp/cvs-serv20192 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Mon Jul 12 02:11:24 2004 Author: ffjeld Index: movitz/doc/ChangeLog diff -u movitz/doc/ChangeLog:1.5 movitz/doc/ChangeLog:1.6 --- movitz/doc/ChangeLog:1.5 Wed Jul 7 17:16:36 2004 +++ movitz/doc/ChangeLog Mon Jul 12 02:11:24 2004 @@ -1,3 +1,9 @@ +2004-07-12 Frode Vatvedt Fjeld <frodef(a)cs.uit.no> + + * Added top-level-command :more, that will evaluate a form while + paging the console output. That is, prompt for a key-press after + each screenful. + 2004-07-08 Frode Vatvedt Fjeld <frodef(a)cs.uit.no> * Migration to the new basic-vector data-structure is completed

1 0

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

12 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv18466 Modified Files: compiler.lisp Log Message: Fixed new-binding-location, which didn't do the right thing with the default argument. Date: Mon Jul 12 02:11:08 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.73 movitz/compiler.lisp:1.74 --- movitz/compiler.lisp:1.73 Sun Jul 11 15:58:56 2004 +++ movitz/compiler.lisp Mon Jul 12 02:11:07 2004 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.73 2004/07/11 22:58:56 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.74 2004/07/12 09:11:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -2375,10 +2375,11 @@ (defun new-binding-location (binding map &key (default nil default-p)) (check-type binding (or binding (cons keyword binding))) - (cdr (or (assoc binding map) - (if default-p - default - (error "No location for ~S." binding))))) + (let ((x (assoc binding map))) + (cond + (x (cdr x)) + (default-p default) + (t (error "No location for ~S." binding))))) (defun make-binding-map () nil)

1 0

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

12 Jul '04

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv24325 Modified Files: los0.lisp Log Message: Tweaked the implementation of :more. Date: Mon Jul 12 01:41:23 2004 Author: ffjeld Index: movitz/losp/los0.lisp diff -u movitz/losp/los0.lisp:1.17 movitz/losp/los0.lisp:1.18 --- movitz/losp/los0.lisp:1.17 Mon Jul 12 01:00:06 2004 +++ movitz/losp/los0.lisp Mon Jul 12 01:41:23 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.17 2004/07/12 08:00:06 ffjeld Exp $ +;;;; $Id: los0.lisp,v 1.18 2004/07/12 08:41:23 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -808,20 +808,32 @@ (defmacro with-paging (options &body body) (declare (ignore options)) `(block paging - (let ((*paging-offset* 2)) + (let ((paging-offset 2)) (handler-bind ((newline (lambda (condition) (declare (ignore condition)) - (when (>= (incf *paging-offset*) - muerte.x86-pc::*screen-height*) - (format t "~&more? ") - (loop + (when (and paging-offset + (>= (incf paging-offset) + muerte.x86-pc::*screen-height*)) + (format t "~&more? (y/n/a) ") + (prog () + loop (case (muerte.x86-pc.keyboard:poll-char) - ((#\esc #\n #\N) + ((#\esc) + (break "Console pager")) + ((#\n #\N) ; No more (return-from paging (values))) - ((#\y #\Y #\space #\newline) - (setf *paging-offset* 1) - (return)))))))) + ((#\a #\A) ; Quit paging + (setf paging-offset nil)) + ((#\newline #\x) + (setf paging-offset + (1- muerte.x86-pc::*screen-height*))) + ((#\y #\Y #\space) ; One more page + (setf paging-offset 1)) + (t (go loop)))) + (write-char #\return) + (clear-line *standard-output* 0 (cursor-y *standard-output*)) + )))) ,@body)))) (defun tp (x) (dotimes (i x) (print i)))

1 0

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

12 Jul '04

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv11008 Modified Files: los0.lisp Log Message: Added with-paging macro (should be in lib?) and :more top-level-command. Try :more <form> in REPL. Date: Mon Jul 12 01:00:06 2004 Author: ffjeld Index: movitz/losp/los0.lisp diff -u movitz/losp/los0.lisp:1.16 movitz/losp/los0.lisp:1.17 --- movitz/losp/los0.lisp:1.16 Thu Jul 8 14:52:29 2004 +++ movitz/losp/los0.lisp Mon Jul 12 01:00:06 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.16 2004/07/08 21:52:29 ffjeld Exp $ +;;;; $Id: los0.lisp,v 1.17 2004/07/12 08:00:06 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -805,6 +805,32 @@ (dolist (x cl:/ (values-list cl:/)) (do-print x))))) +(defmacro with-paging (options &body body) + (declare (ignore options)) + `(block paging + (let ((*paging-offset* 2)) + (handler-bind + ((newline (lambda (condition) + (declare (ignore condition)) + (when (>= (incf *paging-offset*) + muerte.x86-pc::*screen-height*) + (format t "~&more? ") + (loop + (case (muerte.x86-pc.keyboard:poll-char) + ((#\esc #\n #\N) + (return-from paging (values))) + ((#\y #\Y #\space #\newline) + (setf *paging-offset* 1) + (return)))))))) + ,@body)))) + +(defun tp (x) (dotimes (i x) (print i))) + +(define-toplevel-command :more (form) + (with-paging () + (multiple-value-call #'format t "~@{~&~W~}" + (eval form)))) + (define-toplevel-command :pop () (when *debugger-dynamic-context* (let ((r (find-restart-from-context 'abort *debugger-dynamic-context*)))

1 0

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

12 Jul '04

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv23424 Modified Files: los0-gc.lisp Log Message: Added some (commented out) debugging code to stop-and-copy. Date: Mon Jul 12 00:59:04 2004 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.21 movitz/losp/los0-gc.lisp:1.22 --- movitz/losp/los0-gc.lisp:1.21 Thu Jul 8 11:59:51 2004 +++ movitz/losp/los0-gc.lisp Mon Jul 12 00:59:04 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.21 2004/07/08 18:59:51 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.22 2004/07/12 07:59:04 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -54,8 +54,8 @@ (setf (space-other space1) space2) space1)) -(defun space-cons-pointer () - (aref (%run-time-context-slot 'nursery-space) 0)) +;;;(defun space-cons-pointer () +;;; (aref (%run-time-context-slot 'nursery-space) 0)) (defun test () (warn "install..") @@ -329,8 +329,11 @@ (map-stack-words #'zap-oldspace (current-stack-frame)) (initialize-space oldspace) (values)))) - + +(defparameter *x* #500()) + (defun stop-and-copy (&optional evacuator) + (setf (fill-pointer *x*) 0) (let* ((space0 (%run-time-context-slot 'nursery-space)) (space1 (space-other space0))) (check-type space0 vector-u32) @@ -349,14 +352,29 @@ (lambda (x location) "If x is in oldspace, migrate it to newspace." (declare (ignore location)) - (if (not (object-in-space-p oldspace x)) - x - (let ((forwarded-x (memref (object-location x) 0 1 :lisp))) - (if (object-in-space-p newspace forwarded-x) - forwarded-x - (let ((forward-x (shallow-copy x))) - (setf (memref (object-location x) 0 1 :lisp) forward-x) - forward-x)))))))) + (cond + ((not (object-in-space-p oldspace x)) + x) + #+ignore + ((typep x 'muerte::tag6) + (let ((fwi (position (object-location x) *x* :test #'eq))) + (if fwi + (muerte::%word-offset (aref *x* (1+ fwi)) 6) + (let ((fw (shallow-copy x))) + (vector-push (object-location x) *x*) + (vector-push (object-location fw) *x*) + fw)))) + (t (let ((forwarded-x (memref (object-location x) 0 1 :lisp))) + (if (object-in-space-p newspace forwarded-x) + (progn + (assert (eq (object-tag forwarded-x) + (object-tag x))) + forwarded-x) + (let ((forward-x (shallow-copy x))) + (when (typep x 'muerte::bignum) + (assert (= x forward-x))) + (setf (memref (object-location x) 0 1 :lisp) forward-x) + forward-x))))))))) ;; Scavenge roots (map-heap-words evacuator 0 (+ (malloc-buffer-start) (* 2 (malloc-cons-pointer)))) @@ -370,6 +388,17 @@ (+ newspace-location scan-pointer) (+ newspace-location (space-fresh-pointer newspace))) (setf scan-pointer fresh-pointer)) + + (dotimes (i (truncate (length *x*) 2)) + (let ((x (muerte::%word-offset (aref *x* (* i 2)) 6)) + (y (muerte::%word-offset (aref *x* (1+ (* i 2))) 6))) + (assert (and (object-in-space-p newspace y) + (object-in-space-p oldspace x) + (or (typep x 'muerte::std-instance) + (equalp x y))) + () + "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)))

1 0