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

[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-serv24640 Modified Files: compiler.lisp Log Message: Fixed a bug in resolve-borrowed-bindings wrt function-bindings: Sometimes we would generate a forwarding-binding to a function-binding, but the forwarding-binding-target would be nil because this function returned nil for function-bindings. Also, started to use a new strategy with thunks in analyze-bindings. Date: Fri Jul 23 08:31:19 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.82 movitz/compiler.lisp:1.83 --- movitz/compiler.lisp:1.82 Wed Jul 21 17:27:11 2004 +++ movitz/compiler.lisp Fri Jul 23 08:31:19 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.82 2004/07/22 00:27:11 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.83 2004/07/23 15:31:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -344,6 +344,7 @@ (resolve-sub-functions toplevel-funobj function-binding-usage))))))) (defstruct (type-analysis (:type list)) + (thunks) (binding-types) (encoded-type (multiple-value-list (type-specifier-encode nil)))) @@ -354,12 +355,28 @@ (when *compiler-do-type-inference* (let ((more-binding-references-p nil) (binding-usage (make-hash-table :test 'eq))) - (labels ((type-is-t (type-specifier) + (labels ((binding-resolved-p (binding) + (let ((analysis (gethash binding binding-usage))) + (and analysis + (null (type-analysis-binding-types analysis)) + (null (type-analysis-thunks analysis))))) + (binding-resolve (binding) + (if (not (bindingp binding)) + binding + (let ((analysis (gethash binding binding-usage))) + (assert (and (and analysis + (null (type-analysis-binding-types analysis)) + (null (type-analysis-thunks analysis)))) + (binding) + "Can't resolve unresolved binding ~S." binding) + (apply #'encoded-type-decode + (type-analysis-encoded-type analysis))))) + (type-is-t (type-specifier) (or (eq type-specifier t) (and (listp type-specifier) (eq 'or (car type-specifier)) (some #'type-is-t (cdr type-specifier))))) - (analyze-store (binding type) + (analyze-store (binding type thunk thunk-args) (assert (not (null type)) () "store-lexical with empty type.") (assert (or (typep type 'binding) @@ -369,6 +386,10 @@ (setf (gethash binding binding-usage) (make-type-analysis))))) (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) (multiple-value-list @@ -401,10 +422,10 @@ (analyze-code (code) (dolist (instruction code) (when (listp instruction) - (multiple-value-bind (store-binding store-type) + (multiple-value-bind (store-binding store-type thunk thunk-args) (find-written-binding-and-type instruction) (when store-binding - (analyze-store (binding-target store-binding) store-type))) + (analyze-store (binding-target store-binding) store-type thunk thunk-args))) (analyze-code (instruction-sub-program instruction))))) (analyze-funobj (funobj) (loop for (nil . function-env) in (function-envs funobj) @@ -419,6 +440,24 @@ doing (setf more-binding-references-p nil) (maphash (lambda (binding analysis) + (setf (type-analysis-thunks analysis) + (remove-if (lambda (x) + (destructuring-bind (thunk . thunk-args) x + (when (every (lambda (arg) + (or (not (bindingp arg)) + (binding-resolved-p arg))) + thunk-args) + (setf more-binding-references-p t) + (setf (type-analysis-encoded-type analysis) + (multiple-value-list + (multiple-value-call + #'encoded-types-or + (values-list + (type-analysis-encoded-type analysis)) + (type-specifier-encode + (apply thunk (mapcar #'binding-resolve + thunk-args))))))))) + (type-analysis-thunks analysis))) (dolist (target-binding (type-analysis-binding-types analysis)) (let* ((target-analysis (or (gethash target-binding binding-usage) @@ -451,6 +490,8 @@ (warn "Unable to remove all binding-references during lexical type analysis.")) ;; 3. (maphash (lambda (binding analysis) +;;; (loop for (nil . thunk-args) in (type-analysis-thunks analysis) +;;; do (warn "Unable to thunk ~S with args ~S." binding thunk-args)) (assert (null (type-analysis-binding-types analysis)) () "binding ~S type ~S still refers to ~S" binding @@ -516,7 +557,8 @@ (pushnew usage (getf (sub-function-binding-usage (function-binding-parent binding)) binding)) - (pushnew usage (getf function-binding-usage binding)))) + (pushnew usage (getf function-binding-usage binding))) + binding) (t binding)))) (resolve-sub-funobj (funobj sub-funobj) (dolist (binding-we-lend (borrowed-bindings (resolve-funobj-borrowing sub-funobj))) @@ -2193,8 +2235,10 @@ (print-unreadable-object (object stream :type t :identity t) (when (slot-boundp object 'name) (format stream "name: ~S~@[->~S~]~@[ %~A~]" - (binding-name object) - (unless (eq object (binding-target object)) + (and (slot-boundp object 'name) + (binding-name object)) + (when (and (binding-target object) + (not (eq object (binding-target object)))) (binding-name (binding-target object))) (when (and #+ignore (slot-exists-p object 'store-type) #+ignore (slot-boundp object 'store-type) @@ -6107,9 +6151,18 @@ (define-find-write-binding-and-type :add (instruction) (destructuring-bind (term0 term1 destination) (cdr instruction) - (declare (ignore term0 term1)) (when (typep destination 'binding) - (values destination 'integer)))) + (assert (and (bindingp term0) (bindingp term1))) + (values destination + t + (lambda (type0 type1) + (let ((x (multiple-value-call #'encoded-integer-types-add + (type-specifier-encode type0) + (type-specifier-encode type1)))) + (warn "thunked: ~S ~S -> ~S" term0 term1) + x)) + (list term0 term1) + )))) (define-find-read-bindings :add (term0 term1 destination) (declare (ignore destination)) @@ -6156,10 +6209,12 @@ `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0))) (:ebp ,(stack-frame-offset loc1))))))) (t -;;; (warn "ADD: ~S = ~A + ~A, ~A ~A, ~A ~A" -;;; destination loc0 loc1 type0 type1 -;;; (type-specifier-singleton type0) -;;; (eq loc1 destination)) +;;; (warn "ADD: ~S = ~A/~S + ~A/~S,~%~A ~A" +;;; destination +;;; loc0 term0 +;;; loc1 term1 +;;; (type-specifier-singleton type0) +;;; (eq loc1 destination)) ;;; (warn "ADDI: ~S" instruction) (append (cond ((and (eq :eax loc0) (eq :ebx loc1))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/scavenge.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-serv4004 Modified Files: scavenge.lisp Log Message: Added *map-heap-words-verbose* variable. Date: Fri Jul 23 08:27:43 2004 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.24 movitz/losp/muerte/scavenge.lisp:1.25 --- movitz/losp/muerte/scavenge.lisp:1.24 Tue Jul 20 07:13:36 2004 +++ movitz/losp/muerte/scavenge.lisp Fri Jul 23 08:27:43 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.24 2004/07/20 14:13:36 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.25 2004/07/23 15:27:43 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -28,6 +28,7 @@ ;; etc. involved. (defvar *scan*) +(defvar *map-heap-words-verbose* nil) (defun map-heap-words (function start-location end-location) "Map function over each potential pointer word between @@ -51,13 +52,16 @@ (:shrl 16 :eax) (:testb ,movitz:+movitz-fixnum-zmask+ :al) (:jnz '(:sub-program () (:int 63)))))) - (do ((*scan-last* nil) ; Last scanned object, for debugging. + (do ((verbose *map-heap-words-verbose*) + (*scan-last* nil) ; Last scanned object, for debugging. (scan start-location (1+ scan))) ((>= scan end-location)) (declare (special *scan-last*)) (let ((*scan* scan) (x (memref scan 0 0 :lisp))) (declare (special *scan*)) + (when verbose + (format *terminal-io* "~&MHW scanning at ~S: ~Z" scan x)) (cond ((typep x '(or null fixnum character))) ((scavenge-typep x :illegal) @@ -132,6 +136,8 @@ (incf scan delta))) ((typep x 'pointer) (let ((new (funcall function x scan))) + (when verbose + (format *terminal-io* " [~Z => ~Z]" x new)) (unless (eq new x) (setf (memref scan 0 0 :lisp) new)))))))) (values)) @@ -203,6 +209,8 @@ "Is stack-frame in a primitive-function? If so, return the primitive-function's code-vector." (declare (ignore eip-location)) + ;; XXXX Really we should make comparisons against :call-local-pf + ;; such that we find the active set of local-pf's from the stack-location! (let ((return-address (memref stack-location 0 0 :unsigned-byte32)) (code-vector (funobj-code-vector funobj))) (multiple-value-bind (return-location return-delta)

1 0

[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-serv28449 Modified Files: los0-gc.lisp Log Message: Added and improved debugging instrumentation of this GC. Date: Fri Jul 23 08:26:51 2004 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.30 movitz/losp/los0-gc.lisp:1.31 --- movitz/losp/los0-gc.lisp:1.30 Tue Jul 20 16:47:50 2004 +++ movitz/losp/los0-gc.lisp Fri Jul 23 08:26:51 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.30 2004/07/20 23:47:50 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.31 2004/07/23 15:26:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -20,6 +20,10 @@ (defvar *gc-quiet* nil) (defvar *gc-running* nil) +(defvar *gc-break* nil) +(defvar *gc-trigger* nil) +(defvar *gc-consitency-check* t) + (defun make-space (location size) "Make a space vector at a fixed location." @@ -100,6 +104,39 @@ (:ret)))) (do-it))) + +(defun trigger-full-newspace (free-space) + "Make it so that there's only free-space words left before newspace is full." + (let ((trigger (if (consp *gc-trigger*) + (pop *gc-trigger*) + *gc-trigger*))) + (when trigger + (macrolet + ((do-it () + `(with-inline-assembly (:returns :nothing) + (:compile-form (:result-mode :eax) (+ free-space trigger)) + (:locally (:movl (:edi (:edi-offset nursery-space)) :edx)) + (:testl ,(logxor #xffffffff + (* #xfff movitz:+movitz-fixnum-factor+)) + :eax) + (:jnz '(:sub-program () (:int 64))) + (:addl 4 :eax) + (:andl -8 :eax) + (:movl (:edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)) + :ecx) + (:subl :eax :ecx) + (:movl (:edx 2) :ebx) + (:movl :ecx (:edx 2)) + (:addl 8 :ebx) + fill-loop + (:movl :edi (:edx :ebx -6)) + (:addl 4 :ebx) + (:cmpl :ebx :ecx) + (:ja 'fill-loop) + ))) + (do-it))))) + + (define-primitive-function los0-get-cons-pointer () "Return in EAX the next object location with space for EAX words, with tag 6. Preserve ECX." @@ -252,16 +289,18 @@ (when *gc-running* (let ((muerte::*error-no-condition-for-debugger* t)) (error "Recursive GC triggered."))) - (let ((*gc-running t)) + (let ((*gc-running* t)) (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)))))))) + (if *gc-break* + (break "GC break.") + (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))))))))) (let* ((actual-duo-space (or duo-space (allocate-duo-space (* kb-size #x100)))) (last-location (object-location (cons 1 2)))) @@ -289,12 +328,12 @@ (values)) (defun object-in-space-p (space object) - (check-type space vector-u32) + (check-type space (simple-array (unsigned-byte 32) 1)) (and (typep object 'pointer) - (< (object-location space) - (object-location object) - (+ (object-location space) - (array-dimension space 0))))) + (<= (+ 2 (object-location space)) + (object-location object) + (+ 1 (object-location space) + (array-dimension space 0))))) (defun tenure () (install-old-consing) @@ -359,14 +398,6 @@ (cond ((not (object-in-space-p oldspace x)) x) - #+ignore ((typep x 'bignum) - (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 0 :lisp))) (if (object-in-space-p newspace forwarded-x) (progn @@ -374,8 +405,9 @@ (object-tag x))) forwarded-x) (let ((forward-x (shallow-copy x))) - (let ((a *x*)) - (when (typep x 'muerte::pointer) + (when (and (typep x 'muerte::pointer) + *gc-consitency-check*) + (let ((a *x*)) (vector-push (%object-lispval x) a) (vector-push (memref (object-location x) 0 0 :unsigned-byte32) a) (assert (vector-push (%object-lispval forward-x) a)))) @@ -397,30 +429,32 @@ (setf scan-pointer fresh-pointer)) ;; Consistency check.. - (let ((a *x*)) - ;; First, restore the state of old-space - (do ((i 0 (+ i 3))) - ((>= i (length a))) - (let ((old (%lispval-object (aref a i))) - (old-class (aref a (+ i 1)))) - (setf (memref (object-location old) 0 0 :unsigned-byte32) old-class))) - ;; Then, check that each migrated object is equalp to its new self. - (do ((i 0 (+ i 3))) - ((>= i (length a))) - (let ((old (%lispval-object (aref a i))) - (new (%lispval-object (aref a (+ i 2))))) - (unless (and (object-in-space-p newspace new) - (object-in-space-p oldspace old) - (objects-equalp old new)) - (let ((*old* old) - (*new* new) - (*old-class* (aref a (+ i 1)))) - (declare (special *old* *new* *old-class*)) - (error "GC consistency check failed: + (when *gc-consitency-check* + (let ((a *x*)) + ;; First, restore the state of old-space + (do ((i 0 (+ i 3))) + ((>= i (length a))) + (let ((old (%lispval-object (aref a i))) + (old-class (aref a (+ i 1)))) + (setf (memref (object-location old) 0 0 :unsigned-byte32) old-class))) + ;; Then, check that each migrated object is equalp to its new self. + (do ((i 0 (+ i 3))) + ((>= i (length a))) + (let ((old (%lispval-object (aref a i))) + (new (%lispval-object (aref a (+ i 2))))) + (unless (and (object-in-space-p newspace new) + (object-in-space-p oldspace old) + (objects-equalp old new)) + (let ((*old* old) + (*new* new) + (*old-class* (aref a (+ i 1)))) + (declare (special *old* *new* *old-class*)) + (with-simple-restart (continue "Ignore failed GC consistency check.") + (error "GC consistency check failed: old object: ~Z: ~S new object: ~Z: ~S oldspace: ~Z, newspace: ~Z, i: ~D" - old old new new oldspace newspace i)))))) + old old new new oldspace newspace i)))))))) ;; GC completed, oldspace is evacuated. (unless *gc-quiet* @@ -429,5 +463,6 @@ (format t "Old space: ~/muerte:pprint-clumps/, new space: ~ ~/muerte:pprint-clumps/, freed: ~/muerte:pprint-clumps/.~%" old-size new-size (- old-size new-size)))) - (initialize-space oldspace)))) + (initialize-space oldspace) + (fill oldspace #x3 :start 2)))) (values))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/basic-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-serv22259 Modified Files: basic-macros.lisp Log Message: Two fixes: Changed some uses of "unspecified type error" to not-a-list-type-error, and the rather nasty bug in the compiler-macros for funcall%3ops that didn't restore the stack-pointer after the call. Date: Fri Jul 23 07:36:47 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.32 movitz/losp/muerte/basic-macros.lisp:1.33 --- movitz/losp/muerte/basic-macros.lisp:1.32 Wed Jul 21 18:00:47 2004 +++ movitz/losp/muerte/basic-macros.lisp Fri Jul 23 07:36:47 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.32 2004/07/22 01:00:47 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.33 2004/07/23 14:36:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -608,13 +608,15 @@ (:compile-form (:result-mode :eax) ,cell) (:leal (:eax -1) :ecx) (:testb 7 :cl) - (:jnz '(:sub-program () (:int 66))) + (:jnz '(:sub-program () (:int 61))) (:movl :edi (:eax -1))) `(with-inline-assembly (:returns :eax) (:compile-two-forms (:eax :ebx) ,value ,cell) (:leal (:ebx -1) :ecx) (:testb 7 :cl) - (:jnz '(:sub-program () (:int 66))) + (:jnz '(:sub-program () + (:movl :ebx :eax) + (:int 61))) (:movl :eax (:ebx -1))))) (define-compiler-macro (setf cdr) (value cell &environment env) @@ -624,13 +626,15 @@ (:compile-form (:result-mode :eax) ,cell) (:leal (:eax -1) :ecx) (:testb 7 :cl) - (:jnz '(:sub-program () (:int 66))) + (:jnz '(:sub-program () (:int 61))) (:movl :edi (:eax 3))) `(with-inline-assembly (:returns :eax) (:compile-two-forms (:eax :ebx) ,value ,cell) (:leal (:ebx -1) :ecx) (:testb 7 :cl) - (:jnz '(:sub-program () (:int 66))) + (:jnz '(:sub-program () + (:movl :ebx :eax) + (:int 61))) (:movl :eax (:ebx 3))))) (define-compiler-macro rplaca (cons object) @@ -638,7 +642,7 @@ (:compile-two-forms (:eax :ebx) ,cons ,object) (:leal (:eax -1) :ecx) (:testb 7 :cl) - (:jnz '(:sub-program () (:int 66))) + (:jnz '(:sub-program () (:int 61))) (:movl :ebx (:eax -1)))) (define-compiler-macro rplacd (cons object) @@ -646,7 +650,7 @@ (:compile-two-forms (:eax :ebx) ,cons ,object) (:leal (:eax -1) :ecx) (:testb 7 :cl) - (:jnz '(:sub-program () (:int 66))) + (:jnz '(:sub-program () (:int 61))) (:movl :ebx (:eax 3)))) (define-compiler-macro endp (x) @@ -795,7 +799,8 @@ (:jne 'not-funobj) (:movl :edx :esi) funobj-ok - (:call (:esi ,(bt:slot-offset 'movitz::movitz-funobj 'movitz::code-vector%3op)))))))) + (:call (:esi ,(bt:slot-offset 'movitz::movitz-funobj 'movitz::code-vector%3op))) + (:leal (:esp 4) :esp)))))) (define-compiler-macro funcall%unsafe%1ops (function arg0) `(with-inline-assembly (:returns :multiple-values) @@ -813,14 +818,9 @@ `(let ((fn ,function)) (with-inline-assembly (:returns :multiple-values) (:compile-arglist () ,arg0 ,arg1 ,arg2) -;;; (:compile-form (:result-mode :push) ,function) -;;; (:compile-form (:result-mode :push) ,arg0) -;;; (:compile-two-forms (:ebx :ecx) ,arg1 ,arg2) -;;; (:popl :eax) -;;; (:popl :esi) -;;; (:pushl :ecx) (:compile-form (:result-mode :esi) fn) - (:call (:esi ,(bt:slot-offset 'movitz::movitz-funobj 'movitz::code-vector%3op)))))) + (:call (:esi ,(bt:slot-offset 'movitz::movitz-funobj 'movitz::code-vector%3op))) + (:leal (:esp 4) :esp)))) (define-compiler-macro funcall%unsafe (function &rest args) (case (length args)

1 0

[movitz-cvs] CVS update: movitz/losp/tmp/packet.lisp
by Frode Vatvedt Fjeld 22 Jul '04

22 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/tmp In directory common-lisp.net:/tmp/cvs-serv11776 Modified Files: packet.lisp Log Message: Some minor tweaks. Seems to run OK. Date: Wed Jul 21 18:11:14 2004 Author: ffjeld Index: movitz/losp/tmp/packet.lisp diff -u movitz/losp/tmp/packet.lisp:1.3 movitz/losp/tmp/packet.lisp:1.4 --- movitz/losp/tmp/packet.lisp:1.3 Wed Jul 21 15:37:06 2004 +++ movitz/losp/tmp/packet.lisp Wed Jul 21 18:11:14 2004 @@ -171,13 +171,13 @@ (defvar *encode-bit-offset* 0 "The current accumulator bit-position.") (defmacro with-buffer-output (() &body body) - `(let ((*encode-buffer* (make-array '(0) :element-type 'octet + `(let ((*encode-buffer* (make-array '(1514) :element-type 'octet :adjustable t :fill-pointer 0)) (*encode-position* 0) (*encode-bit-bucket* 0) (*encode-bit-offset* 0)) - ,@body - (coerce *encode-buffer* 'buffer))) + ,@body + (coerce *encode-buffer* 'buffer))) (defun encoding-position () (length *encode-buffer*)) @@ -793,8 +793,8 @@ (defun encode-test () "Check that (encode (decode PACKET)) <=> identity." - (assert (and (equalp *udp-packet* (encode (decode *udp-packet*))) - (equalp *arp-packet* (encode (decode *arp-packet*)))))) + (assert (not (mismatch *udp-packet* (encode (decode *udp-packet*))))) + (assert (not (mismatch *arp-packet* (encode (decode *arp-packet*)))))) (defun bench (n) "Show how long it takes to decode and re-encode 10^N UDP packets."

1 0

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

22 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv23193 Modified Files: arrays.lisp Log Message: Improved array-element-type, make-array, and array typep. Date: Wed Jul 21 18:09:44 2004 Author: ffjeld Index: movitz/losp/muerte/arrays.lisp diff -u movitz/losp/muerte/arrays.lisp:1.39 movitz/losp/muerte/arrays.lisp:1.40 --- movitz/losp/muerte/arrays.lisp:1.39 Wed Jul 21 15:33:55 2004 +++ movitz/losp/muerte/arrays.lisp Wed Jul 21 18:09:44 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.39 2004/07/21 22:33:55 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.40 2004/07/22 01:09:44 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -60,7 +60,7 @@ (#.(bt:enum-value 'movitz::movitz-vector-element-type :character) 'character) (#.(bt:enum-value 'movitz::movitz-vector-element-type :u8) - 'muerte::u8) + '(unsigned-byte 8)) (#.(bt:enum-value 'movitz::movitz-vector-element-type :u16) '(unsigned-byte 16)) (#.(bt:enum-value 'movitz::movitz-vector-element-type :u32) @@ -737,19 +737,20 @@ (car dimensions)) (t (error "Multi-dimensional arrays not supported."))))) - (cond - ;; These should be replaced by subtypep sometime. - ((eq element-type 'character) - (make-basic-vector%character size fill-pointer initial-element initial-contents)) - ((member element-type '(bit (unsigned-byte 1)) :test #'equal) - (make-basic-vector%bit size fill-pointer initial-element initial-contents)) - ((member element-type '(u8 (unsigned-byte 8)) :test #'equal) - (make-basic-vector%u8 size fill-pointer initial-element initial-contents)) - ((member element-type '(u32 (unsigned-byte 32)) :test #'equal) - (make-basic-vector%u32 size fill-pointer initial-element initial-contents)) - ((eq element-type 'code) - (make-basic-vector%code size fill-pointer initial-element initial-contents)) - (t (make-basic-vector%t size fill-pointer initial-element initial-contents))))) + (let ((upgraded-element-type (upgraded-array-element-type element-type))) + (cond + ;; These should be replaced by subtypep sometime. + ((eq upgraded-element-type 'character) + (make-basic-vector%character size fill-pointer initial-element initial-contents)) + ((eq upgraded-element-type 'bit) + (make-basic-vector%bit size fill-pointer initial-element initial-contents)) + ((member upgraded-element-type '(u8 (unsigned-byte 8)) :test #'equal) + (make-basic-vector%u8 size fill-pointer initial-element initial-contents)) + ((member upgraded-element-type '(u32 (unsigned-byte 32)) :test #'equal) + (make-basic-vector%u32 size fill-pointer initial-element initial-contents)) + ((eq upgraded-element-type 'code) + (make-basic-vector%code size fill-pointer initial-element initial-contents)) + (t (make-basic-vector%t size fill-pointer initial-element initial-contents)))))) (defun vector (&rest objects) "=> vector" @@ -829,8 +830,14 @@ (and (integerp dimension-spec) (= dimension-spec (array-dimensions x))) (and (listp dimension-spec) - (do ((d 0 (1+ d)) + (do ((array-rank (array-dimensions x)) + (d 0 (1+ d)) (q dimension-spec)) - ((null q) t) - (unless (= (pop q) (array-dimension x d)) - (return nil))))))) + ((null q) (= d array-rank)) + (let ((dim (pop q))) + (cond + ((>= d array-rank) + (return nil)) + ((eq dim '*)) + ((= dim (array-dimension x d))) + (t (return nil)))))))))

1 0

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

22 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv2452 Modified Files: inspect.lisp Log Message: Try to avoid object-equalp going into infinite recursion. Date: Wed Jul 21 18:08:18 2004 Author: ffjeld Index: movitz/losp/muerte/inspect.lisp diff -u movitz/losp/muerte/inspect.lisp:1.29 movitz/losp/muerte/inspect.lisp:1.30 --- movitz/losp/muerte/inspect.lisp:1.29 Wed Jul 21 04:49:48 2004 +++ movitz/losp/muerte/inspect.lisp Wed Jul 21 18:08: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.29 2004/07/21 11:49:48 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.30 2004/07/22 01:08:18 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -229,12 +229,12 @@ (dotimes (i (funobj-num-constants x) t) (unless (test funobj-constant-ref i))))) (symbol - (and (test memref -7 0 :lisp) - (test memref -7 1 :lisp) - (test memref -7 2 :lisp) - (test memref -7 3 :lisp) - (test memref -7 4 :lisp) - (test memref -7 5 :lisp))) + (and ;; (test memref -7 0 :lisp) ; value + (test memref -7 1 :lisp) ; function-value + ;; (test memref -7 2 :lisp) ; plist + (test memref -7 3 :lisp) ; name + ;; (test memref -7 4 :lisp) ; package + (test memref -7 5 :lisp))) ; flags (vector (and (typep y 'vector) (test array-element-type)

1 0

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

22 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv30383 Modified Files: equalp.lisp Log Message: Minor edit. Date: Wed Jul 21 18:07:38 2004 Author: ffjeld Index: movitz/losp/muerte/equalp.lisp diff -u movitz/losp/muerte/equalp.lisp:1.5 movitz/losp/muerte/equalp.lisp:1.6 --- movitz/losp/muerte/equalp.lisp:1.5 Tue Jun 8 18:16:52 2004 +++ movitz/losp/muerte/equalp.lisp Wed Jul 21 18:07:38 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Mar 13 17:09:08 2001 ;;;; -;;;; $Id: equalp.lisp,v 1.5 2004/06/09 01:16:52 ffjeld Exp $ +;;;; $Id: equalp.lisp,v 1.6 2004/07/22 01:07:38 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -22,7 +22,7 @@ (in-package muerte) (defun eql (x y) - (eql x y)) + (compiler-macro-call eql x y)) (defun equal (x y) (typecase x

1 0

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

22 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv3521 Modified Files: interrupt.lisp Log Message: Use :int 61 for failing on typep list. Date: Wed Jul 21 18:02:22 2004 Author: ffjeld Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.17 movitz/losp/muerte/interrupt.lisp:1.18 --- movitz/losp/muerte/interrupt.lisp:1.17 Wed Jul 21 07:16:15 2004 +++ movitz/losp/muerte/interrupt.lisp Wed Jul 21 18:02:22 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.17 2004/07/21 14:16:15 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.18 2004/07/22 01:02:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -274,12 +274,13 @@ $eip (interrupt-frame-ref :error-code :unsigned-byte32 0 interrupt-frame) $eax $ebx $ecx)) - ((61) + ((60) ;; EAX failed type in EDX. May be restarted by returning with a new value in EAX. (with-simple-restart (continue "Retry with a different value.") (error 'type-error :datum (dereference $eax) :expected-type (dereference $edx))) (format *query-io* "Enter a new value: ") (setf (dereference $eax) (read *query-io*))) + (61 (error 'type-error :datum (dereference $eax) :expected-type 'list)) (62 (error "Trying to save too many values: ~@Z." $ecx)) (63 (error "Primitive assertion error. EIP=~@Z, ESI=~@Z." $eip $esi)) (64 (error 'type-error :datum (dereference $eax) :expected-type 'integer))

1 0

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

22 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv2748 Modified Files: cons.lisp Log Message: Use :int 61 for failing on typep list. Date: Wed Jul 21 18:02:15 2004 Author: ffjeld Index: movitz/losp/muerte/cons.lisp diff -u movitz/losp/muerte/cons.lisp:1.5 movitz/losp/muerte/cons.lisp:1.6 --- movitz/losp/muerte/cons.lisp:1.5 Thu Jul 15 14:06:51 2004 +++ movitz/losp/muerte/cons.lisp Wed Jul 21 18:02:15 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 15:25:45 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: cons.lisp,v 1.5 2004/07/15 21:06:51 ffjeld Exp $ +;;;; $Id: cons.lisp,v 1.6 2004/07/22 01:02:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -23,7 +23,7 @@ (with-inline-assembly (:returns :eax) (:leal (:eax -1) :ecx) (:testb 3 :cl) - (:jnz '(:sub-program () (:int 66))) + (:jnz '(:sub-program () (:int 61))) (:movl (:eax -1) :ebx) (:movl (:eax 3) :eax) (:ret))) @@ -33,7 +33,7 @@ (with-inline-assembly (:returns :eax) (:leal (:eax -1) :ecx) (:testb 3 :cl) - (:jnz '(:sub-program () (:int 66))) + (:jnz '(:sub-program () (:int 61))) (:movl (:eax -1) :eax) (:ret))) @@ -43,7 +43,9 @@ (with-inline-assembly (:returns :eax) (:leal (:ebx -1) :ecx) (:testb 3 :cl) - (:jnz '(:sub-program () (:int 66))) + (:jnz '(:sub-program () + (:movl :ebx :eax) + (:int 66))) (:movl (:ebx -1) :eax) (:ret))) @@ -52,7 +54,7 @@ (with-inline-assembly (:returns :eax) (:leal (:eax -1) :ecx) (:testb 3 :cl) - (:jnz '(:sub-program () (:int 66))) + (:jnz '(:sub-program () (:int 61))) (:movl (:eax 3) :eax) (:ret))) @@ -61,11 +63,11 @@ (with-inline-assembly (:returns :eax) (:leal (:eax -1) :ecx) (:testb 3 :cl) - (:jnz '(:sub-program () (:int 66))) + (:jnz '(:sub-program () (:int 61))) (:movl (:eax 3) :eax) (:leal (:eax -1) :ecx) (:testb 3 :cl) - (:jnz '(:sub-program () (:int 66))) + (:jnz '(:sub-program () (:int 61))) (:movl (:eax 3) :eax) (:ret))) @@ -74,15 +76,15 @@ (with-inline-assembly (:returns :eax) (:leal (:eax -1) :ecx) (:testb 3 :cl) - (:jnz '(:sub-program (not-cons) (:int 66))) + (:jnz '(:sub-program (not-cons) (:int 61))) (:movl (:eax 3) :eax) (:leal (:eax -1) :ecx) (:testb 3 :cl) - (:jnz '(:sub-program (not-cons) (:int 66))) + (:jnz '(:sub-program (not-cons) (:int 61))) (:movl (:eax 3) :eax) (:leal (:eax -1) :ecx) (:testb 3 :cl) - (:jnz '(:sub-program (not-cons) (:int 66))) + (:jnz '(:sub-program (not-cons) (:int 61))) (:movl (:eax 3) :eax) (:ret))) @@ -92,7 +94,9 @@ (with-inline-assembly (:returns :eax) (:leal (:ebx -1) :ecx) (:testb 3 :cl) - (:jnz '(:sub-program () (:int 66))) + (:jnz '(:sub-program () + (:movl :ebx :eax) + (:int 61))) (:movl (:ebx 3) :eax) (:ret))) @@ -104,7 +108,7 @@ (:prefetch-nta (:eax)) (:leal (:eax -1) :ecx) (:testb 3 :cl) - (:jnz '(:sub-program () (:int 66))) + (:jnz '(:sub-program () (:int 61))) (:movl (:eax -1) :ebx) (:movl (:eax 3) :eax) (:ret))) @@ -115,7 +119,7 @@ (:prefetch-nta (:eax)) (:leal (:eax -1) :ecx) (:testb 3 :cl) - (:jnz '(:sub-program () (:int 66))) + (:jnz '(:sub-program () (:int 61))) (:movl (:eax -1) :eax) (:ret))) @@ -126,7 +130,9 @@ (:prefetch-nta (:ebx)) (:leal (:ebx -1) :ecx) (:testb 3 :cl) - (:jnz '(:sub-program () (:int 66))) + (:jnz '(:sub-program () + (:movl :ebx :eax) + (:int 61))) (:movl (:ebx -1) :eax) (:ret))) @@ -136,7 +142,7 @@ (:prefetch-nta (:eax)) (:leal (:eax -1) :ecx) (:testb 3 :cl) - (:jnz '(:sub-program () (:int 66))) + (:jnz '(:sub-program () (:int 61))) (:movl (:eax 3) :eax) (:prefetch-nta (:eax)) (:ret))) @@ -148,7 +154,9 @@ (:prefetch-nta (:ebx)) (:leal (:ebx -1) :ecx) (:testb 3 :cl) - (:jnz '(:sub-program () (:int 66))) + (:jnz '(:sub-program () + (:movl :ebx :eax) + (:int 61))) (:movl (:ebx 3) :eax) (:prefetch-nta (:eax)) (:ret))) @@ -159,7 +167,9 @@ (:compile-form (:result-mode :eax) value) (:leal (:ebx -1) :ecx) (:testb 7 :cl) - (:jnz '(:sub-program () (:int 66))) + (:jnz '(:sub-program () + (:movl :ebx :eax) + (:int 61))) (:movl :eax (:ebx -1)))) (defun (setf cdr) (value cell) @@ -168,7 +178,9 @@ (:compile-form (:result-mode :eax) value) (:leal (:ebx -1) :ecx) (:testb 7 :cl) - (:jnz '(:sub-program () (:int 66))) + (:jnz '(:sub-program () + (:movl :ebx :eax) + (:int 61))) (:movl :eax (:ebx 3))))

1 0