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

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

13 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv13793 Modified Files: image.lisp Log Message: Correct the calculation of protect-non-pointer-count in run-time-context. This bug broke GC severely. Date: Tue Jul 13 05:59:33 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.45 movitz/image.lisp:1.46 --- movitz/image.lisp:1.45 Mon Jul 12 19:24:36 2004 +++ movitz/image.lisp Tue Jul 13 05:59:33 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.45 2004/07/13 02:24:36 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.46 2004/07/13 12:59:33 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -398,8 +398,11 @@ :initform 3) (protect-non-pointer-count :binary-type lu32 - :initform (* 4 (- (bt:slot-offset 'movitz-constant-block 'non-pointers-end) - (bt:slot-offset 'movitz-constant-block 'non-pointers-start)))) + :initform nil + :map-binary-write (lambda (x type) + (declare (ignore x type)) + (- (bt:slot-offset 'movitz-constant-block 'non-pointers-end) + (bt:slot-offset 'movitz-constant-block 'non-pointers-start)))) (non-pointers-start :binary-type :label) ; ========= NON-POINTER-START ======= ;; (align-segment-descriptors :binary-type 4) (segment-descriptor-table :binary-type :label)

1 0

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

13 Jul '04

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv22689 Modified Files: los0.lisp Log Message: Minor edits. Added a rather bad implementation of random. Date: Mon Jul 12 19:39:13 2004 Author: ffjeld Index: movitz/losp/los0.lisp diff -u movitz/losp/los0.lisp:1.18 movitz/losp/los0.lisp:1.19 --- movitz/losp/los0.lisp:1.18 Mon Jul 12 01:41:23 2004 +++ movitz/losp/los0.lisp Mon Jul 12 19:39:13 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.18 2004/07/12 08:41:23 ffjeld Exp $ +;;;; $Id: los0.lisp,v 1.19 2004/07/13 02:39:13 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -114,9 +114,6 @@ ;;; (:leal (:edi -4) :eax) ;;; (:rorb :cl :al))) -(defun foo (x) - (foo x x)) - #+ignore (defun test-block (x) @@ -299,13 +296,6 @@ (- (object-location bar) (object-location result)))) (values foo result bar))) -(defun foo (number &rest more-numbers) - (declare (dynamic-extent more-numbers)) - (do ((p more-numbers (cdr p))) - ((not (cdr p)) number) - (unless (< (car p) (cadr p)) - (return nil)))) - (defun modx (x) (lambda () (print x))) @@ -693,12 +683,6 @@ (defun test-nano-sleep (x) (time (nano-sleep x))) -(defun mvtest () - (multiple-value-call #'list (round 5 2)) - (list (memref-int #x1000000 0 0 :unsigned-byte8) - (memref-int #x1000004 0 0 :unsigned-byte8))) - - ;;;;; ;;;;;;;;;;;;;;; CL @@ -974,6 +958,20 @@ (loop (with-simple-restart (abort "Abort to command level ~D." (1+ *repl-level*)) (read-eval-print))))) + +(defun random (limit) + (etypecase limit + (fixnum + (rem (read-time-stamp-counter) limit)) + (muerte::positive-bignum + (let ((x (muerte::copy-bignum limit))) + (dotimes (i (1- (muerte::%bignum-bigits x))) + (setf (memref x 2 i :unsigned-byte32) + (muerte::read-time-stamp-counter))) + (setf x (muerte::%bignum-canonicalize x)) + (loop while (>= x limit) + do (setf x (truncate x 2))) + x)))) (defun genesis () #+ignore

1 0

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

13 Jul '04

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv12721 Modified Files: los0-gc.lisp Log Message: Commented out some debugging code that shouldn't be running. Date: Mon Jul 12 19:38:27 2004 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.23 movitz/losp/los0-gc.lisp:1.24 --- movitz/losp/los0-gc.lisp:1.23 Mon Jul 12 04:11:15 2004 +++ movitz/losp/los0-gc.lisp Mon Jul 12 19:38:27 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.23 2004/07/12 11:11:15 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.24 2004/07/13 02:38:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -390,6 +390,7 @@ (+ newspace-location (space-fresh-pointer newspace))) (setf scan-pointer fresh-pointer)) + #+ignore (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)))

1 0

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

13 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv31488 Modified Files: scavenge.lisp Log Message: Some debugging tweaks to map-heap-words. Date: Mon Jul 12 19:37:36 2004 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.15 movitz/losp/muerte/scavenge.lisp:1.16 --- movitz/losp/muerte/scavenge.lisp:1.15 Mon Jul 12 04:09:34 2004 +++ movitz/losp/muerte/scavenge.lisp Mon Jul 12 19:37:36 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.15 2004/07/12 11:09:34 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.16 2004/07/13 02:37:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -63,7 +63,7 @@ (error "Illegal word ~Z at ~S." x scan)) ((scavenge-typep x :bignum) (assert (evenp scan) () - "Scanned #x~Z at odd address #x~X." x scan) + "Scanned ~Z at odd address #x~X." x scan) ;; Just skip the bigits (let* ((bigits (word-bigits x)) (delta (1+ (logand bigits -2)))) @@ -71,9 +71,9 @@ (incf scan delta))) ((scavenge-typep x :funobj) (assert (evenp scan) () - "Scanned #x~Z at odd address #x~X." x scan) + "Scanned ~Z at odd address #x~X." x scan) (setf *scan-last* (%word-offset scan #.(movitz:tag :other))) - ;; Process code-vector pointer specially.. + ;; Process code-vector pointers specially.. (let* ((funobj (%word-offset scan #.(movitz:tag :other))) (code-vector (funobj-code-vector funobj)) (num-jumpers (funobj-num-jumpers funobj))) @@ -98,21 +98,21 @@ (scavenge-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type :code))) (assert (evenp scan) () - "Scanned #x~Z at odd address #x~X." x scan) + "Scanned ~Z at odd address #x~X." x scan) (let ((len (memref scan 0 1 :lisp))) (check-type len positive-fixnum) (setf *scan-last* (%word-offset scan #.(movitz:tag :other))) (incf scan (1+ (* 2 (truncate (+ 7 len) 8)))))) ((scavenge-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u16)) (assert (evenp scan) () - "Scanned #x~Z at odd address #x~X." x scan) + "Scanned ~Z at odd address #x~X." x scan) (let ((len (memref scan 0 1 :lisp))) (check-type len positive-fixnum) (setf *scan-last* (%word-offset scan #.(movitz:tag :other))) (incf scan (1+ (* 2 (truncate (+ 3 len) 4)))))) ((scavenge-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u32)) (assert (evenp scan) () - "Scanned #x~Z at odd address #x~X." x scan) + "Scanned ~Z at odd address #x~X." x scan) (let ((len (memref scan 0 1 :lisp))) (check-type len positive-fixnum) (setf *scan-last* (%word-offset scan #.(movitz:tag :other))) @@ -125,7 +125,9 @@ (error "Scanned old-vector #x~Z at address #x~X." x scan)) ((eq x (fixnum-word 3)) (incf scan) - (incf scan (memref scan 0 0 :lisp))) + (let ((delta (memref scan 0 0 :lisp))) + (check-type delta positive-fixnum) + (incf scan delta))) ((typep x 'pointer) (let ((new (funcall function x scan))) (unless (eq new x)

1 0

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

13 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv23041 Modified Files: los-closette.lisp Log Message: Don't use funcall%unsafe (yet). Date: Mon Jul 12 19:31:24 2004 Author: ffjeld Index: movitz/losp/muerte/los-closette.lisp diff -u movitz/losp/muerte/los-closette.lisp:1.12 movitz/losp/muerte/los-closette.lisp:1.13 --- movitz/losp/muerte/los-closette.lisp:1.12 Thu Jul 8 11:53:52 2004 +++ movitz/losp/muerte/los-closette.lisp Mon Jul 12 19:31:24 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Jul 23 14:29:10 2002 ;;;; -;;;; $Id: los-closette.lisp,v 1.12 2004/07/08 18:53:52 ffjeld Exp $ +;;;; $Id: los-closette.lisp,v 1.13 2004/07/13 02:31:24 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -577,9 +577,6 @@ (third active-specializers) emfun) (std-gf-classes-to-emf-table gf)) -;;; (when (< 4 (length (std-gf-classes-to-emf-table gf))) -;;; (warn "method cache size for ~S: ~D" -;;; gf (length (std-gf-classes-to-emf-table gf)))) (apply emfun args))) (defun cached-lookup-failed-map1111 (gf &rest args) @@ -592,9 +589,6 @@ (fourth active-specializers) emfun) (std-gf-classes-to-emf-table gf)) -;;; (when (< 4 (length (std-gf-classes-to-emf-table gf))) -;;; (warn "method cache size for ~S: ~D" -;;; gf (length (std-gf-classes-to-emf-table gf)))) (apply emfun args))) (defun discriminating-function-map1-no-eqls (&edx gf arg0 &rest optional-args) @@ -604,19 +598,19 @@ (dolist (entry (std-gf-classes-to-emf-table gf) (cached-lookup-failed-map1 gf arg0 class)) (when (eq class (car entry)) - (return (funcall%unsafe (cdr entry) arg0)))))) + (return (funcall (cdr entry) arg0)))))) (2 (&edx gf arg0 optional1) (let ((class (class-of arg0))) (dolist (entry (std-gf-classes-to-emf-table gf) (cached-lookup-failed-map1 gf arg0 class optional1)) (when (eq class (car entry)) - (return (funcall%unsafe (cdr entry) arg0 optional1)))))) + (return (funcall (cdr entry) arg0 optional1)))))) (3 (&edx gf arg0 optional1 optional2) (let ((class (class-of arg0))) (dolist (entry (std-gf-classes-to-emf-table gf) (cached-lookup-failed-map1 gf arg0 class optional1 optional2)) (when (eq class (car entry)) - (return (funcall%unsafe (cdr entry) arg0 optional1 optional2)))))) + (return (funcall (cdr entry) arg0 optional1 optional2)))))) (t (&edx gf arg0 &rest optional-args) (declare (dynamic-extent optional-args)) (let ((class (class-of arg0))) @@ -634,7 +628,7 @@ (dolist (entry (std-gf-classes-to-emf-table gf) (cached-lookup-failed-map1 gf arg0 specializer)) (when (eq specializer (car entry)) - (return (funcall%unsafe (cdr entry) arg0)))))) + (return (funcall (cdr entry) arg0)))))) (2 (&edx gf arg0 optional1) (let* ((es-table (car (std-gf-eql-specializer-table gf))) (specializer (or (and es-table (gethash arg0 es-table)) @@ -642,7 +636,7 @@ (dolist (entry (std-gf-classes-to-emf-table gf) (cached-lookup-failed-map1 gf arg0 specializer optional1)) (when (eq specializer (car entry)) - (return (funcall%unsafe (cdr entry) arg0 optional1)))))) + (return (funcall (cdr entry) arg0 optional1)))))) (t (&edx gf arg0 &rest optional-args) (declare (dynamic-extent optional-args)) (let* ((es-table (car (std-gf-eql-specializer-table gf))) @@ -661,13 +655,13 @@ (dolist (entry (std-gf-classes-to-emf-table gf) (cached-lookup-failed-map10 gf arg0 arg1 (class-of arg0) class)) (when (eq class (car entry)) - (return (funcall%unsafe (cdr entry) arg0 arg1)))))) + (return (funcall (cdr entry) arg0 arg1)))))) (3 (&edx gf arg0 arg1 optional2) (let ((class (class-of arg1))) (dolist (entry (std-gf-classes-to-emf-table gf) (cached-lookup-failed-map10 gf arg0 arg1 (class-of arg0) class optional2)) (when (eq class (car entry)) - (return (funcall%unsafe (cdr entry) arg0 arg1 optional2)))))) + (return (funcall (cdr entry) arg0 arg1 optional2)))))) (t (&edx gf arg0 arg1 &rest optional-args) (declare (dynamic-extent optional-args)) (let ((class (class-of arg1))) @@ -688,7 +682,7 @@ (let ((e entry)) (when (and (eq class0 (pop e)) (eq class1 (pop e))) - (return (funcall%unsafe e arg0 arg1))))))) + (return (funcall e arg0 arg1))))))) (3 (&edx gf arg0 arg1 optional2) (let ((class0 (class-of arg0)) (class1 (class-of arg1))) @@ -697,7 +691,7 @@ (let ((e entry)) (when (and (eq class0 (pop e)) (eq class1 (pop e))) - (return (funcall%unsafe e arg0 arg1 optional2))))))) + (return (funcall e arg0 arg1 optional2))))))) (t (&edx gf arg0 arg1 &rest optional-args) (declare (dynamic-extent optional-args)) (let ((class0 (class-of arg0)) @@ -720,7 +714,7 @@ (let ((e entry)) (when (and (eq class0 (pop e)) (eq class2 (pop e))) - (return (funcall%unsafe e arg0 arg1 arg2))))))) + (return (funcall e arg0 arg1 arg2))))))) (t (&edx gf arg0 arg1 arg2 &rest optional-args) (declare (dynamic-extent optional-args)) (let ((class0 (class-of arg0))

1 0

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

13 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv29249 Modified Files: integers.lisp Log Message: More bignum fixes. Added some slow-but-working implementations of * and truncate for bignums. Date: Mon Jul 12 19:29:15 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.47 movitz/losp/muerte/integers.lisp:1.48 --- movitz/losp/muerte/integers.lisp:1.47 Mon Jul 12 07:17:14 2004 +++ movitz/losp/muerte/integers.lisp Mon Jul 12 19:29:15 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.47 2004/07/12 14:17:14 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.48 2004/07/13 02:29:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -68,6 +68,36 @@ (defun oddp (x) (not (evenp x))) + + +;;; Types + +(define-typep integer (x &optional (min '*) (max '*)) + (and (typep x 'integer) + (or (eq min '*) (<= min x)) + (or (eq max '*) (<= x max)))) + +(deftype signed-byte (&optional (size '*)) + (cond + ((eq size '*) + 'integer) + ((typep size '(integer 1 *)) + (list 'integer + (- (ash 1 (1- size))) + (1- (ash 1 (1- size))))) + (t (error "Illegal size for signed-byte.")))) + +(deftype unsigned-byte (&optional (size '*)) + (cond + ((eq size '*) + '(integer 0)) + ((typep size '(integer 1 *)) + (list 'integer 0 (1- (ash 1 size)))) + (t (error "Illegal size for unsigned-byte.")))) + +(define-simple-typep (bit bitp) (x) + (or (eq x 0) (eq x 1))) + ;;; Addition (define-compiler-macro + (&whole form &rest operands &environment env) @@ -400,7 +430,7 @@ (:movl (:eax ,movitz:+other-type-offset+) :ecx) (:cmpb ,(movitz:tag :bignum) :cl) (:jne 'not-a-number) - (:cmpl ,(dpb 1 (byte 16 16) (movitz:tag :bignum 0)) :ecx) + (:cmpl ,(dpb 4 (byte 16 16) (movitz:tag :bignum 0)) :ecx) (:jne 'not-most-negative-fixnum) (:cmpl ,(- most-negative-fixnum) (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) @@ -423,15 +453,50 @@ ))) (do-it))) (2 (minuend subtrahend) - (cond - ((eq 0 minuend) - (- subtrahend)) - (t (check-type minuend fixnum) - (check-type subtrahend fixnum) - (with-inline-assembly (:returns :eax :side-effects nil) - (:compile-two-forms (:eax :ebx) minuend subtrahend) - (:subl :ebx :eax) - (:into))))) + (macrolet + ((do-it () + `(number-double-dispatch (minuend subtrahend) + ((t (eql 0)) + minuend) + (((eql 0) t) + (- subtrahend)) + ((fixnum fixnum) + (with-inline-assembly (:returns :eax :side-effects nil) + (:compile-two-forms (:eax :ebx) minuend subtrahend) + (:subl :ebx :eax) + (:into))) + ((bignum fixnum) + (+ (- subtrahend) minuend)) + ((fixnum bignum) + (- (+ (- minuend) subtrahend))) + ((positive-bignum positive-bignum) + (cond + ((= minuend subtrahend) + 0) + ((< minuend subtrahend) + (- (- subtrahend minuend))) + (t (%bignum-canonicalize + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) (copy-bignum minuend) subtrahend) + (:xorl :edx :edx) ; counter + (:xorl :ecx :ecx) ; carry + sub-loop + (:addl (:ebx :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) + :ecx) + (:sbbl :ecx + (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) + (:sbbl :ecx :ecx) + (:negl :ecx) + (:addl 4 :edx) + (:cmpw :dx (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length))) + (:jne 'sub-loop) + (:subl :ecx + (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) + (:jc '(:sub-program (should-not-happen) + (:int 107))) + ))))) + ))) + (do-it))) (t (minuend &rest subtrahends) (declare (dynamic-extent subtrahends)) (if subtrahends @@ -1025,34 +1090,6 @@ ;;; (:andb #.(cl:logxor #xff movitz::+movitz-fixnum-zmask+) :al))) ;;; (t (if (= 0 integer) 0 (error "Illegal ash count: ~D" count))))) -;;; Types - -(define-typep integer (x &optional (min '*) (max '*)) - (and (typep x 'integer) - (or (eq min '*) (<= min x)) - (or (eq max '*) (<= x max)))) - -(deftype signed-byte (&optional (size '*)) - (cond - ((eq size '*) - 'integer) - ((typep size '(integer 1 *)) - (list 'integer - (- (ash 1 (1- size))) - (1- (ash 1 (1- size))))) - (t (error "Illegal size for signed-byte.")))) - -(deftype unsigned-byte (&optional (size '*)) - (cond - ((eq size '*) - '(integer 0)) - ((typep size '(integer 1 *)) - (list 'integer 0 (1- (ash 1 size)))) - (t (error "Illegal size for unsigned-byte.")))) - -(define-simple-typep (bit bitp) (x) - (or (eq x 0) (eq x 1))) - ;;;; (defun integer-length (integer) @@ -1267,10 +1304,11 @@ positive-result ))) ((positive-bignum positive-bignum) - (do ((f y) + (do ((mx (* most-positive-fixnum x)) + (f y) (r 0)) ((typep f 'fixnum) (+ r (* f x))) - (setf r (+ r (* most-positive-fixnum x))) + (setf r (+ r mx)) (setf f (- f most-positive-fixnum)))) ))) (do-it))) @@ -1402,7 +1440,9 @@ (cond ((= number divisor) (values 1 0)) ((< number divisor) (values 0 number)) - (t (error "Don't know how to divide ~S with ~S." number divisor)))) + (t (do ((q 0 (1+ q)) + (r number (- r divisor))) + ((< r divisor) (values q r)))))) )))) (defun / (number &rest denominators)

1 0

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

13 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv12896 Modified Files: cpu-id.lisp Log Message: Removed some dead code. Date: Mon Jul 12 19:27:20 2004 Author: ffjeld Index: movitz/losp/muerte/cpu-id.lisp diff -u movitz/losp/muerte/cpu-id.lisp:1.5 movitz/losp/muerte/cpu-id.lisp:1.6 --- movitz/losp/muerte/cpu-id.lisp:1.5 Wed Jun 2 16:49:27 2004 +++ movitz/losp/muerte/cpu-id.lisp Mon Jul 12 19:27:20 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Apr 15 22:47:13 2002 ;;;; -;;;; $Id: cpu-id.lisp,v 1.5 2004/06/02 23:49:27 ffjeld Exp $ +;;;; $Id: cpu-id.lisp,v 1.6 2004/07/13 02:27:20 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -216,31 +216,6 @@ (do-case (t :multiple-values) (:compile-form (:result-mode :multiple-values) (no-macro-call read-time-stamp-counter))))) - -;;;(defun read-time-stamp-counter () -;;; "Read the 64-bit i686 time-stamp counter. -;;;Returned as three values: low 24 bits, mid 24 bits, high 16 bits. -;;;This is an illegal instruction on lesser CPUs." -;;; (with-inline-assembly (:returns :multiple-values) -;;; (:std) -;;; (:rdtsc) ; Read Time-Stamp Counter into EDX:EAX -;;; ;; Load upper 16 bits (of EDX) as ternary value. -;;; (:movl :edx :ecx) -;;; (:andl #xffff0000 :edx) -;;; (:shll #.(cl:- 16 movitz::+movitz-fixnum-shift+) :edx) -;;; ((:fs-override) :movl :edx (:edi #.(movitz::global-constant-offset 'values))) -;;; ;; Bits 24-47 as fixnum into EBX -;;; (:shldl #.(cl:+ 8 movitz::+movitz-fixnum-shift+) :eax :ebx) -;;; (:andl #.(cl:* #x00ffffff movitz::+movitz-fixnum-factor+) :ebx) -;;; ;; Bits 0-23 as fixnum into EAX -;;; (:andl #x00ffffff :eax) -;;; (:shll #.movitz::+movitz-fixnum-shift+ :eax) -;;; (:cld) -;;; ;; Return 3 values -;;; ((:fs-override) :movl 1 (:edi #.(movitz::global-constant-offset 'num-values))) -;;; (:movl 3 :ecx) -;;; (:stc))) - (defun clear-time-stamp-counter () "Reset the i686 time-stamp-counter. This is an illegal instruction on lesser CPUs, and a no-op on some, such as bochs." @@ -256,9 +231,6 @@ (:popl (:result-register)) (:movl (:result-register) (#x1000)) (:shll 2 (:result-register)))) -;;; (:popl :ecx) -;;; (:leal ((:ecx ,movitz::+movitz-fixnum-factor+) :edi ,(movitz::edi-offset)) -;;; (:result-register)))) (defun eflags () (eflags))

1 0

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

13 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv10528 Modified Files: primitive-functions.lisp Log Message: Changed the run-time-context slot num-values from being lu32 to being a word (i.e. a fixnum). Date: Mon Jul 12 19:26:28 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.26 movitz/losp/muerte/primitive-functions.lisp:1.27 --- movitz/losp/muerte/primitive-functions.lisp:1.26 Thu Jul 8 08:28:57 2004 +++ movitz/losp/muerte/primitive-functions.lisp Mon Jul 12 19:26:28 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.26 2004/07/08 15:28:57 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.27 2004/07/13 02:26:28 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -713,6 +713,9 @@ (:jnz 'push-loop) push-done (:locally (:movl (:edi (:edi-offset num-values)) :ecx)) + (:testb 3 :cl) + (:jnz '(:sub-program () (:int 62))) + (:shrl #.movitz:+movitz-fixnum-shift+ :ecx) (:addl 2 :ecx) done (:jmp :edx))) @@ -736,13 +739,15 @@ (:jmp :edx))) ;; three or more values (:subl 2 :ecx) + (:shll #.movitz:+movitz-fixnum-shift+ :ecx) (:locally (:movl :ecx (:edi (:edi-offset num-values)))) - (:subl 1 :ecx) + (:subl #.movitz:+movitz-fixnum-factor+ :ecx) pop-loop - (:locally (:popl (:edi (:ecx 4) (:edi-offset values)))) - (:subl 1 :ecx) + (:locally (:popl (:edi (:ecx 1) (:edi-offset values)))) + (:subl #.movitz:+movitz-fixnum-factor+ :ecx) (:jnc 'pop-loop) (:locally (:movl (:edi (:edi-offset num-values)) :ecx)) + (:shrl #.movitz:+movitz-fixnum-shift+ :ecx) (:popl :ebx) (:popl :eax) (:addl 2 :ecx)

1 0

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

13 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv10109 Modified Files: basic-functions.lisp Log Message: Changed the run-time-context slot num-values from being lu32 to being a word (i.e. a fixnum). Date: Mon Jul 12 19:26:24 2004 Author: ffjeld Index: movitz/losp/muerte/basic-functions.lisp diff -u movitz/losp/muerte/basic-functions.lisp:1.12 movitz/losp/muerte/basic-functions.lisp:1.13 --- movitz/losp/muerte/basic-functions.lisp:1.12 Sun Jul 11 16:03:18 2004 +++ movitz/losp/muerte/basic-functions.lisp Mon Jul 12 19:26:24 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 4 18:41:57 2001 ;;;; -;;;; $Id: basic-functions.lisp,v 1.12 2004/07/11 23:03:18 ffjeld Exp $ +;;;; $Id: basic-functions.lisp,v 1.13 2004/07/13 02:26:24 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -279,9 +279,10 @@ (3 (x y z) (with-inline-assembly (:returns :multiple-values) (:compile-two-forms (:eax :ebx) x y) - ((:fs-override) :movl 1 (:edi #.(movitz::global-constant-offset 'num-values))) - (:compile-form (:result-mode :ecx) z) - ((:fs-override) :movl :ecx (:edi #.(movitz::global-constant-offset 'values))) + ((:fs-override) :movl #.movitz:+movitz-fixnum-factor+ + (:edi #.(movitz::global-constant-offset 'num-values))) + (:compile-form (:result-mode :edx) z) + ((:fs-override) :movl :edx (:edi #.(movitz::global-constant-offset 'values))) (:movl 3 :ecx) (:stc))) (t (&rest objects) @@ -298,18 +299,19 @@ (:jz 'done) (:subl 2 :ecx) (:jc 'copy-done) - ((:fs-override) :movl :ecx (:edi #.(movitz::global-constant-offset 'num-values))) + (:leal ((:ecx #.movitz::+movitz-fixnum-factor+)) :edx) + ((:fs-override) :movl :edx (:edi #.(movitz::global-constant-offset 'num-values))) (:pushl :eax) (:xorl :eax :eax) copy-loop (:movl (:ebp (:ecx 4) 4) :edx) - ((:fs-override) :movl :edx (:edi (:eax 4) #.(movitz::global-constant-offset 'values))) - (:addl 1 :eax) + ((:fs-override) :movl :edx (:edi (:eax 1) #.(movitz::global-constant-offset 'values))) + (:addl 4 :eax) (:subl 1 :ecx) (:jnc 'copy-loop) + (:leal (:eax #.(cl:- movitz:+movitz-fixnum-factor+)) :ecx) (:popl :eax) - ((:fs-override) :movl (:edi #.(movitz::global-constant-offset 'num-values)) - :ecx) + (:shrl #.movitz:+movitz-fixnum-shift+ :ecx) copy-done (:addl 2 :ecx) (:jnz 'done) @@ -333,7 +335,7 @@ (define-compiler-macro object-location (object) "The location is the object's address divided by fixnum-factor." - `(with-inline-assembly (:returns :register) + `(with-inline-assembly (:returns :register :type fixnum) (:compile-form (:result-mode :register) ,object) (:andl ,(* -2 movitz::+movitz-fixnum-factor+) (:result-register))))

1 0

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

13 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv9952 Modified Files: storage-types.lisp Log Message: Changed the run-time-context slot num-values from being lu32 to being a word (i.e. a fixnum). Date: Mon Jul 12 19:26:19 2004 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.27 movitz/storage-types.lisp:1.28 --- movitz/storage-types.lisp:1.27 Mon Jul 12 04:09:12 2004 +++ movitz/storage-types.lisp Mon Jul 12 19:26:19 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.27 2004/07/12 11:09:12 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.28 2004/07/13 02:26:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -891,10 +891,12 @@ :initform 0 :accessor movitz-funobj-num-jumpers :map-binary-write (lambda (x &optional type) - (declare (ignore typE)) - (* x +movitz-fixnum-factor+)) + (declare (ignore type)) + (check-type x (unsigned-byte 14)) + (* x +movitz-fixnum-factor+)) :map-binary-read (lambda (x &optional type) - (declare (ignore typE)) + (declare (ignore type)) + (assert (zerop (ldb (byte 2 0) x))) (/ x +movitz-fixnum-factor+))) (num-constants :binary-type lu16

1 0