movitz-cvs

movitz-cvs@common-lisp.net

2595 discussions

[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

[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-serv10562 Modified Files: textmode.lisp Log Message: Added the idea that condition "newline" is signalled whenever the console scrolls down. This can be used e.g. to implement :more in los0.lisp. Date: Mon Jul 12 00:57:52 2004 Author: ffjeld Index: movitz/losp/x86-pc/textmode.lisp diff -u movitz/losp/x86-pc/textmode.lisp:1.6 movitz/losp/x86-pc/textmode.lisp:1.7 --- movitz/losp/x86-pc/textmode.lisp:1.6 Wed Apr 21 09:24:10 2004 +++ movitz/losp/x86-pc/textmode.lisp Mon Jul 12 00:57:52 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.6 2004/04/21 16:24:10 ffjeld Exp $ +;;;; $Id: textmode.lisp,v 1.7 2004/07/12 07:57:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -69,12 +69,12 @@ (defun textmode-write-char (c) (case c (#\newline - (setf *cursor-x* 0) (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*)) (#\backspace (if (/= 0 *cursor-x*) @@ -125,6 +125,7 @@ (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*

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/scavenge.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-serv6681 Modified Files: scavenge.lisp Log Message: Tweaks to map-heap-words, added some invariant assertions. Date: Mon Jul 12 00:56:45 2004 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.13 movitz/losp/muerte/scavenge.lisp:1.14 --- movitz/losp/muerte/scavenge.lisp:1.13 Wed Jul 7 10:37:25 2004 +++ movitz/losp/muerte/scavenge.lisp Mon Jul 12 00:56:45 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.13 2004/07/07 17:37:25 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.14 2004/07/12 07:56:45 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -27,6 +27,7 @@ ;; circumstances, i.e. when you know there is no outside GC ;; etc. involved. +(defvar *scan*) (defun map-heap-words (function start-location end-location) "Map function over each potential pointer word between @@ -49,11 +50,13 @@ (:compile-form (:result-mode :eax) ,x) (:andl #xffff0000 :eax) (:shrl ,(- 16 movitz:+movitz-fixnum-shift+) :eax)))) - (do ((scan start-location (1+ scan))) + (do ((*scan-last* nil) ; Last scanned object, for debugging. + (scan start-location (1+ scan))) ((>= scan end-location)) - (let (;; (*i* i) + (declare (special *scan-last*)) + (let ((*scan* scan) (x (memref scan 0 0 :lisp))) - ;; (declare (special *i*)) + (declare (special *scan*)) (cond ((typep x '(or null fixnum character))) ((scavenge-typep x :illegal) @@ -64,10 +67,12 @@ ;; Just skip the bigits (let* ((bigits (word-upper16 x)) (delta (1+ (logand bigits -2)))) + (setf *scan-last* (%word-offset scan #.(movitz:tag :other))) (incf scan delta))) ((scavenge-typep x :funobj) (assert (evenp scan) () "Scanned #x~Z at odd address #x~X." x scan) + (setf *scan-last* (%word-offset scan #.(movitz:tag :other))) ;; Process code-vector pointer specially.. (let* ((funobj (%word-offset scan #.(movitz:tag :other))) (code-vector (funobj-code-vector funobj)) @@ -86,8 +91,6 @@ (assert (evenp scan) () "Scanned #x~Z at odd address #x~X." x scan) (error "Scanning an infant object ~Z at ~S (end ~S)." x scan end-location)) - ((scavenge-typep x :old-vector) - (error "Scanned old-vector #x~Z at odd address #x~X." x scan)) ((or (scavenge-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u8)) (scavenge-wide-typep x :basic-vector @@ -97,18 +100,29 @@ (assert (evenp scan) () "Scanned #x~Z at odd address #x~X." x scan) (let ((len (memref scan 0 1 :lisp))) - ;; (warn "scavenge at #x~X u8 vector len ~D." scan len) + (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) (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) (let ((len (memref scan 0 1 :lisp))) + (check-type len positive-fixnum) + (setf *scan-last* (%word-offset scan #.(movitz:tag :other))) (incf scan (1+ (logand (1+ len) -2))))) + ((and (scavenge-typep x :basic-vector) + (not (scavenge-wide-typep x :basic-vector + #.(bt:enum-value 'movitz:movitz-vector-element-type :any-t)))) + (error "Scanned unknown basic-vector #x~Z at address #x~X." x scan)) + ((scavenge-typep x :old-vector) + (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)))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/conditions.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-serv20175 Modified Files: conditions.lisp Log Message: Added condition "newline". Date: Mon Jul 12 00:54:30 2004 Author: ffjeld Index: movitz/losp/muerte/conditions.lisp diff -u movitz/losp/muerte/conditions.lisp:1.7 movitz/losp/muerte/conditions.lisp:1.8 --- movitz/losp/muerte/conditions.lisp:1.7 Thu Jun 10 05:07:02 2004 +++ movitz/losp/muerte/conditions.lisp Mon Jul 12 00:54:30 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.7 2004/06/10 12:07:02 ffjeld Exp $ +;;;; $Id: conditions.lisp,v 1.8 2004/07/12 07:54:30 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -303,3 +303,5 @@ (or format-control "Break was invoked.") format-arguments))) nil) + +(define-condition newline () ())

1 0

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

11 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv5941 Modified Files: integers.lisp Log Message: Fixed logand and logior for bignums. Date: Sun Jul 11 16:05:24 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.42 movitz/losp/muerte/integers.lisp:1.43 --- movitz/losp/muerte/integers.lisp:1.42 Sat Jul 10 07:39:28 2004 +++ movitz/losp/muerte/integers.lisp Sun Jul 11 16:05:24 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.42 2004/07/10 14:39:28 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.43 2004/07/11 23:05:24 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1469,35 +1469,29 @@ (:btl ,(+ index movitz::+movitz-fixnum-shift+) :eax))))) -(defun logand%2op (x y) - (with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) x) - (:compile-form (:result-mode :ebx) y) - (:testb #.movitz::+movitz-fixnum-zmask+ :al) - (:jnz '(:sub-program () (:int 107))) - (:testb #.movitz::+movitz-fixnum-zmask+ :bl) - (:jnz '(:sub-program () (:movl :ebx :eax) (:int 107))) - (:andl :ebx :eax))) - -(define-compiler-macro logand%2op (&whole form x y) - (cond - ((and (movitz:movitz-constantp x) (movitz:movitz-constantp y)) - (logand (movitz::movitz-eval x) (movitz::movitz-eval y))) - (t form))) - -(defun logand (&rest integers) - (declare (dynamic-extent integers)) - (if (null integers) - -1 - (reduce #'logand%2op integers))) +;;;(defun logand%2op (x y) +;;; (with-inline-assembly (:returns :eax) +;;; (:compile-form (:result-mode :eax) x) +;;; (:compile-form (:result-mode :ebx) y) +;;; (:testb #.movitz::+movitz-fixnum-zmask+ :al) +;;; (:jnz '(:sub-program () (:int 107))) +;;; (:testb #.movitz::+movitz-fixnum-zmask+ :bl) +;;; (:jnz '(:sub-program () (:movl :ebx :eax) (:int 107))) +;;; (:andl :ebx :eax))) +;;; +;;;(define-compiler-macro logand%2op (&whole form x y) +;;; (cond +;;; ((and (movitz:movitz-constantp x) (movitz:movitz-constantp y)) +;;; (logand (movitz::movitz-eval x) (movitz::movitz-eval y))) +;;; (t form))) -(define-compiler-macro logand (&whole form &rest integers) +(define-compiler-macro logand (&whole form &rest integers &environment env) (let ((constant-folded-integers (loop for x in integers with folded-constant = -1 - if (and (movitz:movitz-constantp x) - (not (= -1 (movitz::movitz-eval x)))) + if (and (movitz:movitz-constantp x env) + (not (= -1 (movitz:movitz-eval x env)))) do (setf folded-constant - (logand folded-constant (movitz::movitz-eval x))) + (logand folded-constant (movitz:movitz-eval x env))) else collect x into non-constants finally (return (if (= -1 folded-constant) non-constants @@ -1505,10 +1499,59 @@ (case (length constant-folded-integers) (0 0) (1 (first constant-folded-integers)) - (2 `(logand%2op ,(first constant-folded-integers) ,(second constant-folded-integers))) - (t `(logand (logand%2op ,(first constant-folded-integers) ,(second constant-folded-integers)) + (2 `(no-macro-call logand ,(first constant-folded-integers) ,(second constant-folded-integers))) + (t `(logand (logand ,(first constant-folded-integers) ,(second constant-folded-integers)) ,@(cddr constant-folded-integers)))))) +(defun logand (&rest integers) + (numargs-case + (1 (x) x) + (2 (x y) + (macrolet + ((do-it () + `(number-double-dispatch (x y) + ((fixnum fixnum) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) x y) + (:andl :ebx :eax))) + ((positive-bignum positive-fixnum) + (with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :eax) x) + (:call-global-constant unbox-u32) + (:compile-form (:result-mode :eax) y) + (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :ecx) + (:andl :ecx :eax))) + ((positive-fixnum positive-bignum) + (with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :eax) y) + (:call-global-constant unbox-u32) + (:compile-form (:result-mode :eax) x) + (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :ecx) + (:andl :ecx :eax))) + ((positive-bignum positive-bignum) + (if (< (%bignum-bigits y) (%bignum-bigits x)) + (logand y x) + (%bignum-canonicalize + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) (copy-bignum x) y) + (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) + :ecx) + (:leal ((:ecx 4) -4) :edx) + pb-pb-and-loop + (:movl (:ebx :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) + :ecx) + (:andl :ecx + (:eax :edx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) + (:subl 4 :edx) + (:jnc 'pb-pb-and-loop))))) + ))) + (do-it))) + (t (&rest integers) + (declare (dynamic-extent integers)) + (if (null integers) + -1 + (reduce #'logand integers))))) + (defun logandc1 (integer1 integer2) (number-double-dispatch (integer1 integer2) ((t positive-fixnum) @@ -1518,34 +1561,10 @@ (:shll #.movitz:+movitz-fixnum-shift+ :ecx) (:compile-form (:result-mode :eax) integer2) (:notl :ecx) - (:andl :ecx :eax))) - ((positive-fixnum t) - (with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) integer2) - (:call-global-constant unbox-u32) - (:leal ((:ecx #.movitz:+movitz-fixnum-factor+)) :eax) - (:compile-form (:result-mode :ecx) integer1) - (:notl :ecx) (:andl :ecx :eax))))) (defun logandc2 (integer1 integer2) - (number-double-dispatch (integer1 integer2) - ((positive-fixnum t) - (with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) integer2) - (:call-global-constant unbox-u32) - (:shll #.movitz:+movitz-fixnum-shift+ :ecx) - (:compile-form (:result-mode :eax) integer1) - (:notl :ecx) - (:andl :ecx :eax))) - ((t positive-fixnum) - (with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) integer1) - (:call-global-constant unbox-u32) - (:leal ((:ecx #.movitz:+movitz-fixnum-factor+)) :eax) - (:compile-form (:result-mode :ecx) integer2) - (:notl :ecx) - (:andl :ecx :eax))))) + (logandc1 integer2 integer1)) (defun logior (&rest integers) (numargs-case @@ -1633,20 +1652,20 @@ ((positive-fixnum positive-bignum) (macrolet ((do-it () - `(let ((r (copy-bignum y))) - (with-inline-assembly (:returns :eax) - (:compile-two-forms (:eax :ecx) r x) - (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) - (:xorl (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)) :ecx))))) + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ecx) (copy-bignum y) x) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:xorl :ecx + (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))))) (do-it))) ((positive-bignum positive-fixnum) (macrolet ((do-it () - `(let ((r (copy-bignum x))) - (with-inline-assembly (:returns :eax) - (:compile-two-forms (:eax :ecx) r y) - (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) - (:xorl :ecx (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))))))) + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ecx) (copy-bignum x) y) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:xorl :ecx + (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))))) (do-it))) ((positive-bignum positive-bignum) (if (< (%bignum-bigits x) (%bignum-bigits y))

1 0

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

11 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv29472 Modified Files: basic-macros.lisp Log Message: Include the :label argumet for with-inline-assembly. Date: Sun Jul 11 16:04:14 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.25 movitz/losp/muerte/basic-macros.lisp:1.26 --- movitz/losp/muerte/basic-macros.lisp:1.25 Wed Jul 7 10:37:30 2004 +++ movitz/losp/muerte/basic-macros.lisp Sun Jul 11 16:04:14 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.25 2004/07/07 17:37:30 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.26 2004/07/11 23:04:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -966,9 +966,9 @@ `(progn ,@body)) -(defmacro with-inline-assembly ((&key returns (side-effects t) (type t)) &body program) +(defmacro with-inline-assembly ((&key returns (side-effects t) (type t) labels) &body program) `(with-inline-assembly-case (:side-effects ,side-effects :type ,type) - (do-case (t ,returns) + (do-case (t ,returns :labels ,labels) ,@program))) (defmacro numargs-case (&rest args)

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

movitz-cvs