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

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

23 Jul '04

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv14019 Modified Files: los0-gc.lisp Log Message: Minor edit. Date: Fri Jul 23 09:44:07 2004 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.31 movitz/losp/los0-gc.lisp:1.32 --- movitz/losp/los0-gc.lisp:1.31 Fri Jul 23 08:26:51 2004 +++ movitz/losp/los0-gc.lisp Fri Jul 23 09:44:07 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.31 2004/07/23 15:26:51 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.32 2004/07/23 16:44:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -464,5 +464,5 @@ ~/muerte:pprint-clumps/, freed: ~/muerte:pprint-clumps/.~%" old-size new-size (- old-size new-size)))) (initialize-space oldspace) - (fill oldspace #x3 :start 2)))) + (fill oldspace #x13 :start 2)))) (values))

1 0

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

23 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv15459 Modified Files: compiler.lisp Log Message: Made a slight mistake in the new thunking stuff. This all needs to be cleaned up. Date: Fri Jul 23 09:42:39 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.83 movitz/compiler.lisp:1.84 --- movitz/compiler.lisp:1.83 Fri Jul 23 08:31:19 2004 +++ movitz/compiler.lisp Fri Jul 23 09:42:38 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.83 2004/07/23 15:31:19 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.84 2004/07/23 16:42:38 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -388,7 +388,6 @@ (cond (thunk (assert (some #'bindingp thunk-args)) - ;; (warn "got a thunk for ~S" thunk-args) (push (cons thunk thunk-args) (type-analysis-thunks analysis))) ((typep binding 'function-argument) (setf (type-analysis-encoded-type analysis) @@ -498,7 +497,10 @@ (apply #'encoded-type-decode (type-analysis-encoded-type analysis)) (type-analysis-binding-types analysis)) (setf (binding-store-type binding) - (type-analysis-encoded-type analysis)) + (cond + ((not (null (type-analysis-thunks analysis))) + (multiple-value-list (type-specifier-encode t))) + (t (type-analysis-encoded-type analysis)))) #+ignore (when (apply #'encoded-type-singleton (type-analysis-encoded-type analysis)) (warn "Singleton: ~A" binding))

1 0

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

23 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv27435 Modified Files: typep.lisp Log Message: Teach typep compiler-macro about basic-restart. Date: Fri Jul 23 08:37:17 2004 Author: ffjeld Index: movitz/losp/muerte/typep.lisp diff -u movitz/losp/muerte/typep.lisp:1.31 movitz/losp/muerte/typep.lisp:1.32 --- movitz/losp/muerte/typep.lisp:1.31 Wed Jul 21 15:36:00 2004 +++ movitz/losp/muerte/typep.lisp Fri Jul 23 08:37:17 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.31 2004/07/21 22:36:00 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.32 2004/07/23 15:37:17 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -204,6 +204,7 @@ (tag4 (make-tag-typep :tag4)) (tag5 (make-tag-typep :null)) (tag6 (make-tag-typep :other)) + (basic-restart (make-tag-typep :basic-restart)) (pointer (assert (equal (mapcar 'movitz::tag '(:cons :other :symbol)) '(1 6 7)))

1 0

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

23 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv21215 Modified Files: inspect.lisp Log Message: Improved copy-control-stack: Take a parameter absolutep which means to make the stack-frame uplink pointers array indexes rather than locations. Date: Fri Jul 23 08:36:46 2004 Author: ffjeld Index: movitz/losp/muerte/inspect.lisp diff -u movitz/losp/muerte/inspect.lisp:1.30 movitz/losp/muerte/inspect.lisp:1.31 --- movitz/losp/muerte/inspect.lisp:1.30 Wed Jul 21 18:08:18 2004 +++ movitz/losp/muerte/inspect.lisp Fri Jul 23 08:36:46 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.30 2004/07/22 01:08:18 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.31 2004/07/23 15:36:46 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -340,8 +340,9 @@ (* 2 (truncate (+ (structure-object-length object) 1) 2)))))))) -(defun copy-control-stack (&optional (stack (%run-time-context-slot 'stack-vector)) - (frame (current-stack-frame))) +(defun copy-control-stack (&key (absolutep) + (stack (%run-time-context-slot 'stack-vector)) + (frame (current-stack-frame))) (assert (location-in-object-p stack frame)) (let* ((stack-start-location (+ 2 (object-location stack))) (frame-index (- frame stack-start-location)) @@ -357,7 +358,10 @@ (t (let ((uplink-index (- uplink-frame stack-start-location frame-index))) (assert (< -1 uplink-index (length copy)) () "Uplink-index outside copy: ~S, i: ~S" uplink-index i) - (let ((x (+ uplink-index copy-start-location))) - (assert (location-in-object-p copy x)) - (setf (svref%unsafe copy i) x) - (setf i uplink-index))))))))) + (setf (svref%unsafe copy i) + (if absolutep + uplink-index + (let ((x (+ uplink-index copy-start-location))) + (assert (location-in-object-p copy x)) + (setf (svref%unsafe copy i) x)))) + (setf i uplink-index))))))))

1 0

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

23 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv8742 Modified Files: conditions.lisp Log Message: Minor edit. Date: Fri Jul 23 08:35:45 2004 Author: ffjeld Index: movitz/losp/muerte/conditions.lisp diff -u movitz/losp/muerte/conditions.lisp:1.10 movitz/losp/muerte/conditions.lisp:1.11 --- movitz/losp/muerte/conditions.lisp:1.10 Wed Jul 21 18:01:31 2004 +++ movitz/losp/muerte/conditions.lisp Fri Jul 23 08:35:45 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Nov 20 15:47:04 2002 ;;;; -;;;; $Id: conditions.lisp,v 1.10 2004/07/22 01:01:31 ffjeld Exp $ +;;;; $Id: conditions.lisp,v 1.11 2004/07/23 15:35:45 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -105,7 +105,8 @@ :initarg :datum :reader type-error-datum)) (:report (lambda (c s) - (format s "The object `~S' is not of type ~S." + (format s "The object ~Z `~S' is not of type ~S." + (type-error-datum c) (type-error-datum c) (type-error-expected-type c)))))

1 0

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

23 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv7818 Modified Files: arithmetic-macros.lisp Log Message: Made + compiler-macro a bit smarter about constant sub-forms. Date: Fri Jul 23 08:35:23 2004 Author: ffjeld Index: movitz/losp/muerte/arithmetic-macros.lisp diff -u movitz/losp/muerte/arithmetic-macros.lisp:1.4 movitz/losp/muerte/arithmetic-macros.lisp:1.5 --- movitz/losp/muerte/arithmetic-macros.lisp:1.4 Tue Jul 20 01:53:50 2004 +++ movitz/losp/muerte/arithmetic-macros.lisp Fri Jul 23 08:35:23 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.4 2004/07/20 08:53:50 ffjeld Exp $ +;;;; $Id: arithmetic-macros.lisp,v 1.5 2004/07/23 15:35:23 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -57,7 +57,13 @@ finally (return (if (zerop constant-term) non-constant-operands (cons constant-term non-constant-operands)))))) - `(+ (+ ,(first operands) ,(second operands)) ,@(cddr operands)))))) + (cond + ((null operands) + 0) + ((not (cdr operands)) + (check-type (car operands) integer) + (car operands)) + (t `(+ (+ ,(first operands) ,(second operands)) ,@(cddr operands)))))))) (define-compiler-macro 1+ (number) `(+ 1 ,number))

1 0

[movitz-cvs] CVS update: movitz/stream-image.lisp
by Frode Vatvedt Fjeld 23 Jul '04

23 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv31520 Modified Files: stream-image.lisp Log Message: Added support for reading bignums back in from stream-images. Date: Fri Jul 23 08:34:36 2004 Author: ffjeld Index: movitz/stream-image.lisp diff -u movitz/stream-image.lisp:1.8 movitz/stream-image.lisp:1.9 --- movitz/stream-image.lisp:1.8 Thu Jul 8 11:53:38 2004 +++ movitz/stream-image.lisp Fri Jul 23 08:34:36 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Aug 27 14:46:50 2001 ;;;; -;;;; $Id: stream-image.lisp,v 1.8 2004/07/08 18:53:38 ffjeld Exp $ +;;;; $Id: stream-image.lisp,v 1.9 2004/07/23 15:34:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -93,6 +93,8 @@ (read-binary 'movitz-struct (image-stream image))) (:std-instance (read-binary 'movitz-std-instance (image-stream image))) + (:bignum + (read-binary 'movitz-bignum (image-stream image))) (t (warn "unknown other object: #x~X: ~S code #x~X." word type-tag type-code) (make-instance 'movitz-fixnum :value (truncate word 4))))))

1 0

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

23 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv29953 Modified Files: storage-types.lisp Log Message: Added support for reading bignums back in from stream-images. Date: Fri Jul 23 08:34:32 2004 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.30 movitz/storage-types.lisp:1.31 --- movitz/storage-types.lisp:1.30 Wed Jul 21 17:27:22 2004 +++ movitz/storage-types.lisp Fri Jul 23 08:34:32 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.30 2004/07/22 00:27:22 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.31 2004/07/23 15:34:32 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -77,9 +77,6 @@ :illegal #x13 :infant-object #x23 - ;; :simple-vector #x20 - ;; :character-vector - :basic-restart #x32 ) @@ -847,10 +844,8 @@ (+ x (movitz-intern-code-vector (movitz-funobj-code-vector obj))))))))) (defmethod print-object ((object movitz-funobj) stream) - (if (not (slot-boundp object 'name)) - (call-next-method) - (print-unreadable-object (object stream :type t :identity t) - (write (movitz-print (movitz-funobj-name object)) :stream stream)))) + (print-unreadable-object (object stream :type t :identity t) + (write (movitz-print (movitz-funobj-name object)) :stream stream))) (defmethod sizeof ((obj movitz-funobj)) (+ (sizeof (find-binary-type 'movitz-funobj)) @@ -1298,3 +1293,13 @@ (defmethod update-movitz-object ((object movitz-bignum) lisp-object) (assert (= (movitz-bignum-value object) lisp-object)) object) + +(defmethod read-binary-record ((type-name (eql 'movitz-bignum)) stream &key) + (let* ((header (call-next-method)) + (x (loop for i from 0 below (movitz-bignum-length header) + summing (ash (read-binary 'u32 stream) (* i 32))))) + (setf (movitz-bignum-value header) + (ecase (movitz-bignum-sign header) + (#x00 x) + (#xff (- x)))) + header))

1 0

[movitz-cvs] CVS update: movitz/procfs-image.lisp
by Frode Vatvedt Fjeld 23 Jul '04

23 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv6781 Modified Files: procfs-image.lisp Log Message: Improved backtrace a bit. Date: Fri Jul 23 08:32:55 2004 Author: ffjeld Index: movitz/procfs-image.lisp diff -u movitz/procfs-image.lisp:1.10 movitz/procfs-image.lisp:1.11 --- movitz/procfs-image.lisp:1.10 Wed Jul 21 17:28:06 2004 +++ movitz/procfs-image.lisp Fri Jul 23 08:32:55 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Aug 24 11:39:37 2001 ;;;; -;;;; $Id: procfs-image.lisp,v 1.10 2004/07/22 00:28:06 ffjeld Exp $ +;;;; $Id: procfs-image.lisp,v 1.11 2004/07/23 15:32:55 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -170,7 +170,18 @@ '(nil :eflags :eip :error-code :exception :ebp nil :ecx :eax :edx :ebx :esi :edi)))) -(defun backtrace (&key reqs) +(defun debug-get-object (word spartan) + (if spartan + word + (handler-case + (let ((object (movitz-word word))) + (typecase object + ((or movitz-funobj movitz-struct movitz-std-instance) + object) + (t (movitz-print object)))) + (t () (list :unknown-word word))))) + +(defun backtrace (&key (reqs t) print-frames print-returns spartan) (format t "~&Backtracing from EIP = #x~X: " (image-register32 *image* :eip)) ;; (search-image-funobj (image-register32 *image* :eip)) @@ -195,14 +206,17 @@ r eax ecx edi eip exception)))) (movitz-symbol (let ((name (movitz-print movitz-name))) - (write-string (symbol-name name)) + (when print-frames + (format t "~S " stack-frame)) (when (string= name 'toplevel-function) (loop-finish)) - (format t " (#x~X)" (stack-frame-return-address stack-frame)) (when reqs - (format t " req1: ~S, req2: ~S" - (movitz-word (get-word stack-frame -2)) - (movitz-word (get-word stack-frame -3)))))) + (format t "(~A ~S ~S)" + (symbol-name name) + (debug-get-object (get-word (+ stack-frame -8)) spartan) + (debug-get-object (get-word (+ stack-frame -12)) spartan))) + (when print-returns + (format t " (#x~X)" (stack-frame-return-address stack-frame))))) (t (write (movitz-print movitz-name))))) do (format t "~& => ")) (values)) @@ -276,13 +290,30 @@ (values))) +(defvar *previous-image*) + #+allegro (top-level:alias ("bochs" 0) (&optional form) - (with-bochs-image () - (with-simple-restart (continue "Exit this bochs session [pid=~D]" (image-pid *image*)) + (let ((*previous-image* *image*)) + (with-bochs-image () + (let ((image *image*)) + (with-simple-restart (continue "Exit this bochs session [pid=~D]" (image-pid image)) + (if form + (let ((x (eval form))) + (format t "~&~W" x) + x) + (invoke-debugger "Established Bochs session [pid=~D]. ~S is ~S" + (image-pid image) + '*previous-image* + *previous-image*))))))) + +#+allegro +(top-level:alias ("unbochs" 3) (&optional form) + (let ((*image* *previous-image*) + (image *image*)) + (with-simple-restart (continue "Exit this unbochs session") (if form (let ((x (eval form))) (format t "~&~W" x) x) - (invoke-debugger "Established connection to Bochs [pid=~D]." - (image-pid *image*)))))) + (invoke-debugger "Established connection to unBochs ~S" image)))))

1 0

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

23 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv4898 Modified Files: image.lisp Log Message: Make the initial stack-vector a bit shorted, so we don't get so extremely long backtraces. Date: Fri Jul 23 08:32:35 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.49 movitz/image.lisp:1.50 --- movitz/image.lisp:1.49 Wed Jul 21 17:27:17 2004 +++ movitz/image.lisp Fri Jul 23 08:32:35 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.49 2004/07/22 00:27:17 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.50 2004/07/23 15:32:35 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -937,7 +937,7 @@ (assert (file-position stream 512) () ; leave room for bootblock. "Couldn't set file-position for ~W." (pathname stream)) (let* ((stack-vector (make-instance 'movitz-basic-vector - :num-elements #xffff + :num-elements #x1ffe :fill-pointer 0 :symbolic-data nil :element-type :u32)) @@ -1311,9 +1311,10 @@ (code-position 0) (entry-points (map 'list #'identity (subseq code (movitz-vector-fill-pointer code-vector))))) (format t "~&;; Movitz Disassembly of ~A:~@[ -;; Constants: ~A~] +;; ~D Constants: ~A~] ~:{~4D: ~16<~{ ~2,'0X~}~;~> ~A~@[ ;~{ ~A~}~]~%~}" (movitz-print (or (movitz-funobj-name funobj) name)) + (length (movitz-funobj-const-list funobj)) (movitz-funobj-const-list funobj) (loop for pc = 0 then code-position

1 0