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

[movitz-cvs] CVS update: movitz/compiler-types.lisp
by Frode Vatvedt Fjeld 06 Apr '04

06 Apr '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv17668 Modified Files: compiler-types.lisp Log Message: A hack to teach the compiler that fixnum == integer (for now). Date: Tue Apr 6 09:35:41 2004 Author: ffjeld Index: movitz/compiler-types.lisp diff -u movitz/compiler-types.lisp:1.9 movitz/compiler-types.lisp:1.10 --- movitz/compiler-types.lisp:1.9 Thu Apr 1 12:26:04 2004 +++ movitz/compiler-types.lisp Tue Apr 6 09:35:41 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Sep 10 00:40:07 2003 ;;;; -;;;; $Id: compiler-types.lisp,v 1.9 2004/04/01 17:26:04 ffjeld Exp $ +;;;; $Id: compiler-types.lisp,v 1.10 2004/04/06 13:35:41 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -423,6 +423,8 @@ (cond ((atom type-specifier) (case type-specifier + (fixnum + (type-values 'integer)) ((t nil cons symbol keyword function array vector integer hash-table character) (type-values type-specifier)) (null

1 0

[movitz-cvs] CVS update: movitz/losp/x86-pc/interrupt.lisp
by Frode Vatvedt Fjeld 06 Apr '04

06 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv8009 Modified Files: interrupt.lisp Log Message: Added functions cli and sti, and minor edits. Date: Tue Apr 6 06:37:52 2004 Author: ffjeld Index: movitz/losp/x86-pc/interrupt.lisp diff -u movitz/losp/x86-pc/interrupt.lisp:1.6 movitz/losp/x86-pc/interrupt.lisp:1.7 --- movitz/losp/x86-pc/interrupt.lisp:1.6 Sun Mar 28 08:35:45 2004 +++ movitz/losp/x86-pc/interrupt.lisp Tue Apr 6 06:37:52 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri May 4 18:08:50 2001 ;;;; -;;;; $Id: interrupt.lisp,v 1.6 2004/03/28 13:35:45 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.7 2004/04/06 10:37:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -53,7 +53,7 @@ (setf (memref frame (* 4 (int-frame-index reg)) 0 type) x)) (define-primitive-function muerte::default-interrupt-trampoline () - "Default interrupt handler." + "Default first-stage interrupt handler." #.(cl:list* 'with-inline-assembly '(:returns :nothing) (cl:loop :for i :from 0 :to movitz::+idt-size+ :append (cl:if (cl:member i '(8 10 11 12 13 14 17)) @@ -80,7 +80,7 @@ ;; 8: ebp ;; 4: esi ;; 0: edi - + (:pushl (:esp 48)) ; EFLAGS (:pushl :cs) ; push CS (:call (:pc+ 0)) ; push EIP. @@ -241,6 +241,8 @@ ;; (print-dynamic-context); what's this? (throw :debugger nil)) (112 + (setf (%run-time-context-slot 'nursery-space) + (memref (%run-time-context-slot 'nursery-space) -6 3 :lisp)) (error "Out of memory. Please take out the garbage.")) (t (funcall (if (< 16 number 50) #'warn #'error) "Exception occurred: ~D, EIP: ~@Z, EAX: ~@Z, ECX: ~@Z, ESI: ~@Z" @@ -267,6 +269,13 @@ (setf (pic8259-irq-mask) #xfffe) (with-inline-assembly (:returns :nothing) (:sti))) +(defun cli () + (with-inline-assembly (:returns :nothing) + (:cli))) + +(defun sti () + (with-inline-assembly (:returns :nothing) + (:sti))) (defun interrupt-handler (n) (let ((vector (load-global-constant interrupt-handlers)))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/eval.lisp
by Frode Vatvedt Fjeld 01 Apr '04

01 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv20384 Modified Files: eval.lisp Log Message: Added defvar as a special-operator. ..Why not? Date: Thu Apr 1 15:25:07 2004 Author: ffjeld Index: movitz/losp/muerte/eval.lisp diff -u movitz/losp/muerte/eval.lisp:1.4 movitz/losp/muerte/eval.lisp:1.5 --- movitz/losp/muerte/eval.lisp:1.4 Thu Apr 1 11:07:37 2004 +++ movitz/losp/muerte/eval.lisp Thu Apr 1 15:25:07 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Oct 19 21:15:12 2001 ;;;; -;;;; $Id: eval.lisp,v 1.4 2004/04/01 16:07:37 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.5 2004/04/01 20:25:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -54,6 +54,19 @@ (or (and binding (cdr binding)) (symbol-value form))))) +;;; block let* return-from +;;; catch load-time-value setq +;;; eval-when locally symbol-macrolet +;;; flet macrolet tagbody +;;; function multiple-value-call the +;;; go multiple-value-prog1 throw +;;; if progn unwind-protect +;;; labels progv +;;; let quote +;;; +;;;Figure 3-2. Common Lisp Special Operators + + (defun eval-cons (form env) "3.1.2.1.2 Conses as Forms" (case (car form) @@ -69,6 +82,7 @@ (go (eval-go form env)) (setq (eval-setq form env)) (setf (eval-setf form env)) + ((defvar) (eval-defvar form env)) (let (eval-let (cadr form) (cddr form) env)) (time (eval-time (cadr form) env)) ((defun) (eval-defun (cadr form) (caddr form) (cdddr form) env)) @@ -389,6 +403,15 @@ (eval-form value-form env) place-subvalues))))))) +(defun eval-defvar (form env) + (let ((name (second form))) + (check-type name symbol "variable name") + (setf (symbol-special-variable-p name) t) + (when (and (cddr form) (not (boundp name))) + (setf (symbol-value name) + (eval-form (third form) env))) + name)) + (defun compile (name &optional definition) "=> function, warnings-p, failure-p" (let ((function (eval (or definition (symbol-function name))))) @@ -397,4 +420,5 @@ (values (if (not name) function (setf (symbol-function name) function)) - t nil))) \ No newline at end of file + t nil))) +

1 0

[movitz-cvs] CVS update: movitz/losp/lib/net/ip4.lisp
by Frode Vatvedt Fjeld 01 Apr '04

01 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/lib/net In directory common-lisp.net:/tmp/cvs-serv17687 Modified Files: ip4.lisp Log Message: Minor edits. Date: Thu Apr 1 12:29:44 2004 Author: ffjeld Index: movitz/losp/lib/net/ip4.lisp diff -u movitz/losp/lib/net/ip4.lisp:1.5 movitz/losp/lib/net/ip4.lisp:1.6 --- movitz/losp/lib/net/ip4.lisp:1.5 Thu Feb 26 06:26:24 2004 +++ movitz/losp/lib/net/ip4.lisp Thu Apr 1 12:29:44 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Apr 30 13:52:57 2003 ;;;; -;;;; $Id: ip4.lisp,v 1.5 2004/02/26 11:26:24 ffjeld Exp $ +;;;; $Id: ip4.lisp,v 1.6 2004/04/01 17:29:44 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -91,8 +91,12 @@ (loop for x from y below (min (length packet) (+ y 16)) as c = (code-char (aref packet x)) do (write-char (if (alphanumericp c) c #\.))))) - ((mismatch packet (address stack) :start1 (+ start +ip-header-destination+) :end1 (+ start +ip-header-destination+ 4)) - #+ignore (warn "IPv4 Packet from ~@/ip4:pprint-ip4/ not for me, but for ~:/ip4:pprint-ip4/." packet packet)) + ((mismatch packet (address stack) + :start1 (+ start +ip-header-destination+) + :end1 (+ start +ip-header-destination+ 4)) + #+ignore + (warn "IPv4 Packet from ~@/ip4:pprint-ip4/ not for me, but for ~:/ip4:pprint-ip4/." + packet packet)) (t (named-integer-case ip-protocol (ip-protocol packet start) (icmp (icmp-input stack packet start (+ start header-size))) @@ -244,7 +248,7 @@ (+ (ldb (byte 16 0) new-checksum) (ash new-checksum -16)))) (transmit (interface stack) packet) - (write-char #\.))))) + #+ignore (write-char #\.))))) ;;;; UDP

1 0

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

01 Apr '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv20224 Modified Files: compiler.lisp Log Message: More stuff about using ECX only as a scratch register (i.e. it can't be used to hold pointer values that might be moved by GC). Date: Thu Apr 1 12:27:03 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.40 movitz/compiler.lisp:1.41 --- movitz/compiler.lisp:1.40 Wed Mar 31 21:09:26 2004 +++ movitz/compiler.lisp Thu Apr 1 12:27:03 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.40 2004/04/01 02:09:26 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.41 2004/04/01 17:27:03 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -2433,7 +2433,7 @@ pos))))) (defun compute-free-registers (pc distance funobj frame-map - &key (free-registers '(:eax :ebx :ecx :edx))) + &key (free-registers '(:ecx :eax :ebx :edx))) "Return set of free register, and whether there may be more registers free later, with a more specified frame-map." (loop with free-so-far = free-registers @@ -2518,22 +2518,35 @@ (distance (position load-instruction (cdr init-pc)))) (multiple-value-bind (free-registers more-later-p) (and distance (compute-free-registers (cdr init-pc) distance funobj frame-map)) - (if (and (member :ecx free-registers) + (let ((free-registers-no-ecx (remove :ecx free-registers))) + (cond + ((member binding-destination free-registers-no-ecx) + binding-destination) + ((and (not (typep binding '(or fixed-required-function-argument + register-required-function-argument))) + (member binding-destination free-registers)) + binding-destination) + ((member init-with-register free-registers) + init-with-register) + ((and (member :ecx free-registers) (not (typep binding 'function-argument)) (or (eq :untagged-fixnum-ecx binding-destination) (eq :untagged-fixnum-ecx init-with-register))) - :untagged-fixnum-ecx - (let ((free-registers (remove :ecx free-registers))) - (cond - ((member binding-destination free-registers) - binding-destination) - ((member init-with-register free-registers) - init-with-register) - ((not (null free-registers)) - (first free-registers)) - (more-later-p - (values nil :not-now)) - (t (values nil :never))))))))) + :untagged-fixnum-ecx) + ((and (binding-store-type binding) + (member :ecx free-registers) + (not (typep binding '(or fixed-required-function-argument + register-required-function-argument))) + (multiple-value-call #'encoded-subtypep + (values-list (binding-store-type binding)) + (type-specifier-encode '(or integer character)))) + (warn "for ecX: ~S" binding) + :ecx) + ((not (null free-registers-no-ecx)) + (first free-registers-no-ecx)) + (more-later-p + (values nil :not-now)) + (t (values nil :never)))))))) (t (values nil :never))))) (defun discover-variables (code function-env) @@ -3050,7 +3063,7 @@ ((:eax :single-value) nil) (:untagged-fixnum-ecx `((:movl :eax :ecx) - (:sarl ,movitz:+movitz-fixnum-factor+ :ecx))))) + (:sarl ,movitz:+movitz-fixnum-shift+ :ecx))))) ((:ebx :ecx :edx) (assert (not indirect-p)) (unless (eq result-mode lexb-location) @@ -3059,7 +3072,7 @@ ((:ebx :ecx :edx :esi) `((:movl ,lexb-location ,result-mode))) (:untagged-fixnum-ecx `((:movl ,lexb-location :ecx) - (:sarl ,movitz:+movitz-fixnum-factor+ :ecx)))))) + (:sarl ,movitz:+movitz-fixnum-shift+ :ecx)))))) (:argument-stack (assert (<= 2 (function-argument-argnum lexb)) () "lexical :argument-stack argnum can't be ~A." (function-argument-argnum lexb)) @@ -3132,8 +3145,6 @@ `((:movl (:ebp ,(stack-frame-offset binding-location)) :eax) (:pushl (:eax -1))) (ecase binding-location -;;; (:eax '((:pushl :eax))) -;;; (:ebx '((:pushl :ebx))) (:argument-stack (assert (<= 2 (function-argument-argnum binding)) () ":load-lexical argnum can't be ~A." (function-argument-argnum binding)) @@ -3150,8 +3161,8 @@ (if (integerp binding-location) `((:pushl (:ebp ,(stack-frame-offset binding-location)))) (ecase binding-location - (:eax '((:pushl :eax))) - (:ebx '((:pushl :ebx))) + ((:eax :ebx :ecx :edx) + `((:pushl ,binding-location))) (:argument-stack (assert (<= 2 (function-argument-argnum binding)) () ":load-lexical argnum can't be ~A." (function-argument-argnum binding)) @@ -3254,7 +3265,7 @@ (if (integerp location) `((:movl ,source (:ebp ,(stack-frame-offset location)))) (ecase location - ((:eax :ebx :edx) + ((:eax :ebx :ecx :edx) (unless (eq source location) `((:movl ,source ,location)))) (:argument-stack

1 0

[movitz-cvs] CVS update: movitz/compiler-types.lisp
by Frode Vatvedt Fjeld 01 Apr '04

01 Apr '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv17689 Modified Files: compiler-types.lisp Log Message: Don't forget the character type. Date: Thu Apr 1 12:26:04 2004 Author: ffjeld Index: movitz/compiler-types.lisp diff -u movitz/compiler-types.lisp:1.8 movitz/compiler-types.lisp:1.9 --- movitz/compiler-types.lisp:1.8 Sat Feb 14 17:47:25 2004 +++ movitz/compiler-types.lisp Thu Apr 1 12:26:04 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Sep 10 00:40:07 2003 ;;;; -;;;; $Id: compiler-types.lisp,v 1.8 2004/02/14 22:47:25 ffjeld Exp $ +;;;; $Id: compiler-types.lisp,v 1.9 2004/04/01 17:26:04 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -423,7 +423,7 @@ (cond ((atom type-specifier) (case type-specifier - ((t nil cons symbol keyword function array vector integer hash-table) + ((t nil cons symbol keyword function array vector integer hash-table character) (type-values type-specifier)) (null (type-values () :members '(nil)))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/eval.lisp
by Frode Vatvedt Fjeld 01 Apr '04

01 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv2560 Modified Files: eval.lisp Log Message: Added a mock compile function. Date: Thu Apr 1 11:07:37 2004 Author: ffjeld Index: movitz/losp/muerte/eval.lisp diff -u movitz/losp/muerte/eval.lisp:1.3 movitz/losp/muerte/eval.lisp:1.4 --- movitz/losp/muerte/eval.lisp:1.3 Sun Mar 28 08:23:57 2004 +++ movitz/losp/muerte/eval.lisp Thu Apr 1 11:07:37 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Oct 19 21:15:12 2001 ;;;; -;;;; $Id: eval.lisp,v 1.3 2004/03/28 13:23:57 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.4 2004/04/01 16:07:37 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -388,3 +388,13 @@ (apply (lookup-setf-function (caar p)) (eval-form value-form env) place-subvalues))))))) + +(defun compile (name &optional definition) + "=> function, warnings-p, failure-p" + (let ((function (eval (or definition (symbol-function name))))) + (check-type function function) + (warn ";; There is no real compiler here.") + (values (if (not name) + function + (setf (symbol-function name) function)) + t nil))) \ No newline at end of file

1 0

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

01 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv4971 Modified Files: textmode.lisp Log Message: Some minor code tuneups. Date: Wed Mar 31 21:15:22 2004 Author: ffjeld Index: movitz/losp/x86-pc/textmode.lisp diff -u movitz/losp/x86-pc/textmode.lisp:1.3 movitz/losp/x86-pc/textmode.lisp:1.4 --- movitz/losp/x86-pc/textmode.lisp:1.3 Mon Jan 19 06:23:52 2004 +++ movitz/losp/x86-pc/textmode.lisp Wed Mar 31 21:15:21 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.3 2004/01/19 11:23:52 ffjeld Exp $ +;;;; $Id: textmode.lisp,v 1.4 2004/04/01 02:15:21 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -45,7 +45,7 @@ (defun (setf cursor-row) (value &optional device) (declare (ignore device)) (setf *cursor-y* value) - (move-vga-cursor *cursor-x* *cursor-y*) + (move-vga-cursor *cursor-x* value) value) (defun cursor-column (&optional device) @@ -55,7 +55,7 @@ (defun (setf cursor-column) (value &optional device) (declare (ignore device)) (setf *cursor-x* value) - (move-vga-cursor *cursor-x* *cursor-y*) + (move-vga-cursor value *cursor-y*) value) (defun textmode-write-char (c) @@ -80,9 +80,9 @@ (cond ((= *screen-height* *cursor-y*) (textmode-scroll-down) - (move-vga-cursor *cursor-x* *cursor-y*)) + (move-vga-cursor 0 *cursor-y*)) (t (incf *cursor-y*) - (move-vga-cursor *cursor-x* *cursor-y*)))) + (move-vga-cursor 0 *cursor-y*)))) (#\backspace (if (/= 0 *cursor-x*) (decf *cursor-x*) @@ -92,18 +92,20 @@ (move-vga-cursor *cursor-x* *cursor-y*)) (#\return (setf *cursor-x* 0) - (move-vga-cursor *cursor-x* *cursor-y*)) + (move-vga-cursor 0 *cursor-y*)) (#\tab (textmode-write-char #\space) (do () ((zerop (rem *cursor-x* 8))) (textmode-write-char #\space))) - (t (when (>= *cursor-x* *screen-width*) - (textmode-write-char #\newline)) - (let ((index (+ *cursor-x* (* *cursor-y* *screen-stride*)))) - (setf (memref-int *screen* 0 index :unsigned-byte16 t) - (logior #x0700 (char-code c))) - (incf *cursor-x*) - (move-vga-cursor *cursor-x* *cursor-y*)))))) + (t (let ((x *cursor-x*) + (y *cursor-y*)) + (when (>= x *screen-width*) + (textmode-write-char #\newline) + (setf x *cursor-x* y *cursor-y*)) + (let ((index (+ x (* y *screen-stride*)))) + (setf (memref-int *screen* 0 index :unsigned-byte16 t) + (logior #x0700 (char-code c))) + (move-vga-cursor (setf *cursor-x* (1+ x)) y))))))) nil) (defun textmode-scroll-down () @@ -128,7 +130,6 @@ (:subl 1 :ecx) (:jnz 'clear-loop))) - (defun textmode-clear-line (from-column line) (let ((dest (+ *screen* (* line 80 2) (* from-column 2)))) (dotimes (i (- 80 from-column))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp
by Frode Vatvedt Fjeld 01 Apr '04

01 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv14478 Modified Files: memref.lisp Log Message: Some tuning of memref. Date: Wed Mar 31 21:13:30 2004 Author: ffjeld Index: movitz/losp/muerte/memref.lisp diff -u movitz/losp/muerte/memref.lisp:1.8 movitz/losp/muerte/memref.lisp:1.9 --- movitz/losp/muerte/memref.lisp:1.8 Wed Mar 31 16:35:27 2004 +++ movitz/losp/muerte/memref.lisp Wed Mar 31 21:13:27 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Mar 6 21:25:49 2001 ;;;; -;;;; $Id: memref.lisp,v 1.8 2004/03/31 21:35:27 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.9 2004/04/01 02:13:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -65,8 +65,7 @@ (:movzxb (:eax ,(offset-by 1)) :ecx))) ((eq 0 offset) `(with-inline-assembly (:returns :untagged-fixnum-ecx) - (:compile-two-forms (:eax :ecx) ,object ,index) - (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) + (:compile-two-forms (:eax :untagged-fixnum-ecx) ,object ,index) (:movzxb (:eax :ecx ,(offset-by 1)) :ecx))) (t (let ((object-var (gensym "memref-object-"))) `(let ((,object-var ,object)) @@ -156,15 +155,11 @@ ((and (eq 0 offset) (eq 0 index)) `(with-inline-assembly (:returns :untagged-fixnum-ecx) (:compile-form (:result-mode :eax) ,object) - (:movl (:eax ,(offset-by 4)) :ecx) - (:cmpl ,movitz::+movitz-most-positive-fixnum+ :ecx) - (:jg '(:sub-program () (:int 4))))) + (:movl (:eax ,(offset-by 4)) :ecx))) ((eq 0 offset) `(with-inline-assembly (:returns :untagged-fixnum-ecx) (:compile-two-forms (:eax :ecx) ,object ,index) - (:movl (:eax :ecx ,(offset-by 4)) :ecx) - (:cmpl ,movitz::+movitz-most-positive-fixnum+ :ecx) - (:jg '(:sub-program () (:int 4))))) + (:movl (:eax :ecx ,(offset-by 4)) :ecx))) (t (let ((object-var (gensym "memref-object-"))) `(let ((,object-var ,object)) (with-inline-assembly (:returns :untagged-fixnum-ecx) @@ -269,8 +264,7 @@ ((and (movitz:movitz-constantp offset env) (movitz:movitz-constantp index env)) `(with-inline-assembly (:returns :untagged-fixnum-ecx) - (:compile-two-forms (:ecx :ebx) ,value ,object) - (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:compile-two-forms (:untagged-fixnum-ecx :ebx) ,value ,object) (:movl :ecx (:ebx ,(+ (movitz:movitz-eval offset env) (* 4 (movitz:movitz-eval index env))))))) ((and (movitz:movitz-constantp offset env) @@ -317,8 +311,7 @@ ((and (movitz:movitz-constantp offset env) (movitz:movitz-constantp index env)) `(with-inline-assembly (:returns :untagged-fixnum-ecx) - (:compile-two-forms (:ecx :ebx) ,value ,object) - (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:compile-two-forms (:untagged-fixnum-ecx :ebx) ,value ,object) (:movw :cx (:ebx ,(+ (movitz:movitz-eval offset env) (* 2 (movitz:movitz-eval index env))))))) ((and (movitz:movitz-constantp offset env)

1 0

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

01 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv10081 Modified Files: integers.lisp Log Message: Changed logbitp somewhat. Date: Wed Mar 31 21:12:22 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.3 movitz/losp/muerte/integers.lisp:1.4 --- movitz/losp/muerte/integers.lisp:1.3 Thu Feb 26 08:46:36 2004 +++ movitz/losp/muerte/integers.lisp Wed Mar 31 21:12:22 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.3 2004/02/26 13:46:36 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.4 2004/04/01 02:12:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -846,10 +846,14 @@ (defun logbitp (index integer) (check-type integer fixnum) (with-inline-assembly (:returns :boolean-cf=1) - (:compile-form (:result-mode :eax) integer) - (:compile-form (:result-mode :untagged-fixnum-ecx) index) + (:compile-two-forms (:eax :ebx) index integer) + (:testl #x80000003 :eax) + (:jnz '(:sub-program () + (:int 66))) + (:movl :eax :ecx) + (:shrl #.movitz::+movitz-fixnum-shift+ :ecx) (:addl #.movitz::+movitz-fixnum-shift+ :ecx) - (:btl :ecx :eax))) + (:btl :ecx :ebx))) (define-compiler-macro logbitp (&whole form index integer &environment env) (if (not (movitz:movitz-constantp index env))

1 0