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

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

23 Nov '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv6603 Modified Files: arithmetic-macros.lisp Log Message: *** empty log message *** Date: Tue Nov 23 17:00:21 2004 Author: ffjeld Index: movitz/losp/muerte/arithmetic-macros.lisp diff -u movitz/losp/muerte/arithmetic-macros.lisp:1.8 movitz/losp/muerte/arithmetic-macros.lisp:1.9 --- movitz/losp/muerte/arithmetic-macros.lisp:1.8 Mon Oct 11 15:52:04 2004 +++ movitz/losp/muerte/arithmetic-macros.lisp Tue Nov 23 17:00:20 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Jul 17 13:42:46 2004 ;;;; -;;;; $Id: arithmetic-macros.lisp,v 1.8 2004/10/11 13:52:04 ffjeld Exp $ +;;;; $Id: arithmetic-macros.lisp,v 1.9 2004/11/23 16:00:20 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -95,18 +95,21 @@ (movitz:movitz-constantp max env)) (let ((min (movitz:movitz-eval min env)) (max (movitz:movitz-eval max env))) - (check-type min fixnum) - (check-type max fixnum) (cond ((movitz:movitz-constantp x env) (<= min (movitz:movitz-eval x env) max)) ((< max min) - nil) + `(progn ,x nil)) ((= max min) `(= ,x ,min)) ((minusp min) `(let ((x ,x)) (and (<= ,min x) (<= x ,max)))) + ((or (not (typep min 'fixnum)) + (not (typep max 'fixnum))) + `(let ((x ,x)) + (and (<=%2op ,min x) + (<=%2op x ,max)))) ((= 0 min) `(with-inline-assembly (:returns :boolean-cf=1) (:compile-form (:result-mode :eax) ,x)

1 0

[movitz-cvs] CVS update: movitz/losp/x86-pc/pci.lisp
by Frode Vatvedt Fjeld 23 Nov '04

23 Nov '04

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv31374 Modified Files: pci.lisp Log Message: Some basic functions for interfacing the PCI bios32. Date: Tue Nov 23 14:45:53 2004 Author: ffjeld Index: movitz/losp/x86-pc/pci.lisp diff -u movitz/losp/x86-pc/pci.lisp:1.4 movitz/losp/x86-pc/pci.lisp:1.5 --- movitz/losp/x86-pc/pci.lisp:1.4 Sun Nov 14 23:58:02 2004 +++ movitz/losp/x86-pc/pci.lisp Tue Nov 23 14:45:51 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sun Dec 14 22:33:42 2003 ;;;; -;;;; $Id: pci.lisp,v 1.4 2004/11/14 22:58:02 ffjeld Exp $ +;;;; $Id: pci.lisp,v 1.5 2004/11/23 13:45:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -18,13 +18,65 @@ (provide :x86-pc/pci) -(defun find-bios32 () +(defun find-bios32-base () (loop for bios32 from #xe0000 to #xffff0 by 16 if (and (= (memref-int bios32) #x5f32335f) (loop with checksum = 0 - ;; initially (warn "PCI magic found at #x~X" bios32) as i from 0 below (* 16 (memref-int bios32 :offset 9 :type :unsigned-byte8)) do (incf checksum (memref-int bios32 :offset i :type :unsigned-byte8)) finally (return (= 0 (ldb (byte 8 0 ) checksum))))) return bios32)) + +(defvar *bios32-base* nil) + +(defun init-pci () + (setf *bios32-base* + (find-bios32-base)) + (if (not *bios32-base*) + (error "No PCI BIOS32 found.") + (let ((entry (memref-int *bios32-base* :offset 4)) + (revision (memref-int *bios32-base* :offset 8 :type :unsigned-byte8)) + (length (memref-int *bios32-base* :offset 9 :type :unsigned-byte8))) + (values entry revision length)))) + +(defun pci-far-call (address &key (eax 0) (ebx 0) (cs 8)) + "Make a 'far call' to cs:address with the provided values for eax and ebx. +Returns the values of registers AL, EBX, ECX, and EDX. (Well, for now only the +lower 30 bits are actually returned.) The stack discipline is broken during +this call, so we disable interrupts in a somewhat feeble attempt to avoid trouble." + (without-interrupts + (with-inline-assembly (:returns :multiple-values) + (:load-lexical (:lexical-binding cs) :untagged-fixnum-ecx) + (:pushl :ecx) ; Code segment + (:load-lexical (:lexical-binding address) :untagged-fixnum-ecx) + (:pushl :ecx) ; Code address + (:load-lexical (:lexical-binding ebx) :untagged-fixnum-ecx) + (:pushl :ecx) ; EBX + (:load-lexical (:lexical-binding eax) :untagged-fixnum-ecx) + (:movl :ecx :eax) + (:popl :ebx) + (:call-segment (:esp)) + (:leal (:esp 8) :esp) + (:andl #xff :eax) + (:shll 2 :eax) + (:shll 2 :ebx) + (:shll 2 :ecx) + (:shll 2 :edx) + (:locally (:movl :ecx (:edi (:edi-offset values) 0))) + (:locally (:movl :edx (:edi (:edi-offset values) 4))) + (:movl 4 :ecx) + (:stc)))) + +(defun pci-directory (eax &optional (ebx 0)) + "Calling with '$PCI' should find the PCI directory." + (unless *bios32-base* + (init-pci)) + (let ((eax (etypecase eax + ((unsigned-byte 32) + eax) + (string + (loop for c across eax as i upfrom 0 by 8 + summing (ash (char-code c) i)))))) + (pci-far-call (memref-int *bios32-base* :offset 4) + :eax eax :ebx ebx)))

1 0

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

21 Nov '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv20233 Modified Files: compiler.lisp Log Message: Changed the way the unbound value is checked for at dynamic lookup: If the unbound-value is #x7fffffff, we can make and unbound variable trigger an exception like this: (:cmpl -1 :eax) (:into). Date: Sun Nov 21 13:30:36 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.114 movitz/compiler.lisp:1.115 --- movitz/compiler.lisp:1.114 Sat Nov 20 18:43:13 2004 +++ movitz/compiler.lisp Sun Nov 21 13:30:35 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.114 2004/11/20 17:43:13 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.115 2004/11/21 12:30:35 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -65,6 +65,9 @@ the system ensures one way or another that there can be no pointers below this size.") +(defvar *compiler-use-into-unbound-protocol* t + "Use #x7fffffff as the <unbound-value> and thereby the INTO +instruction for checking whether a value is the unbound value.") (defvar *compiler-compile-eval-whens* t "When encountering (eval-when (:compile-toplevel) <code>), @@ -5614,24 +5617,42 @@ :functional-p t :modifies nil :final-form form - :code `((:load-constant ,form :eax) - (,*compiler-local-segment-prefix* - :call (:edi ,(global-constant-offset 'dynamic-variable-lookup))) - (,*compiler-local-segment-prefix* - :cmpl :eax (:edi ,(global-constant-offset 'unbound-value))) - (:je '(:sub-program () (:int 99)))))) + :code (if *compiler-use-into-unbound-protocol* + `((:load-constant ,form :ebx) + (,*compiler-local-segment-prefix* + :call (:edi ,(global-constant-offset 'dynamic-variable-lookup))) + (:cmpl -1 :eax) + (:into)) + (let ((not-unbound (gensym "not-unbound-"))) + `((:load-constant ,form :ebx) + (,*compiler-local-segment-prefix* + :call (:edi ,(global-constant-offset 'dynamic-variable-lookup))) + (,*compiler-local-segment-prefix* + :cmpl :eax (:edi ,(global-constant-offset 'unbound-value))) + (:jne ',not-unbound) + (:int 99) + ,not-unbound))))) (t (check-type binding dynamic-binding) (compiler-values () :returns :eax :functional-p t :modifies nil :final-form form - :code `((:load-constant ,form :eax) - (,*compiler-local-segment-prefix* - :call (:edi ,(global-constant-offset 'dynamic-variable-lookup))) - (,*compiler-local-segment-prefix* - :cmpl :eax (:edi ,(global-constant-offset 'unbound-value))) - (:je '(:sub-program () (:int 99)))))))))) + :code (if *compiler-use-into-unbound-protocol* + `((:load-constant ,form :ebx) + (,*compiler-local-segment-prefix* + :call (:edi ,(global-constant-offset 'dynamic-variable-lookup))) + (:cmpl -1 :eax) + (:into)) + (let ((not-unbound (gensym "not-unbound-"))) + `((:load-constant ,form :ebx) + (,*compiler-local-segment-prefix* + :call (:edi ,(global-constant-offset 'dynamic-variable-lookup))) + (,*compiler-local-segment-prefix* + :cmpl :eax (:edi ,(global-constant-offset 'unbound-value))) + (:jne ',not-unbound) + (:int 99) + ,not-unbound))))))))) (define-compiler compile-lambda-form (&form form) "3.1.2.2.4 Lambda Forms"

1 0

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

21 Nov '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv13043 Modified Files: integers.lisp Log Message: Minor tweaking of isqrt. Date: Sun Nov 21 01:10:11 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.100 movitz/losp/muerte/integers.lisp:1.101 --- movitz/losp/muerte/integers.lisp:1.100 Tue Oct 12 16:43:55 2004 +++ movitz/losp/muerte/integers.lisp Sun Nov 21 01:10:11 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.100 2004/10/12 14:43:55 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.101 2004/11/21 00:10:11 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -2192,18 +2192,18 @@ (defun isqrt (natural) "=> natural-root" - (etypecase natural - ((eql 0) 0) - ((integer 1 *) - (let ((r 1)) - (do ((next-r (truncate (+ r (truncate natural r)) 2) - (truncate (+ r (truncate natural r)) 2))) - ((typep (- next-r r) '(integer 0 1)) - (let ((r+1 (1+ r))) - (if (<= (* r+1 r+1) natural) - r+1 - r))) - (setf r next-r)))))) + (check-type natural (integer 0 *)) + (if (= 0 natural) + 0 + (let ((r 1)) + (do ((next-r (truncate (+ r (truncate natural r)) 2) + (truncate (+ r (truncate natural r)) 2))) + ((typep (- next-r r) '(integer 0 1)) + (let ((r+1 (1+ r))) + (if (<= (* r+1 r+1) natural) + r+1 + r))) + (setf r next-r))))) (defun expt (base-number power-number) "Take base-number to the power-number."

1 0

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

20 Nov '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv22974 Modified Files: compiler.lisp Log Message: Fixed some lisp-val to untagged-fixnum-ecx conversions. Date: Sat Nov 20 18:43:19 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.113 movitz/compiler.lisp:1.114 --- movitz/compiler.lisp:1.113 Sat Nov 20 02:29:52 2004 +++ movitz/compiler.lisp Sat Nov 20 18:43:13 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.113 2004/11/20 01:29:52 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.114 2004/11/20 17:43:13 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -3377,8 +3377,8 @@ ((:ebx :ecx :edx :esi) `((:movl :eax ,result-mode))) ((:eax :single-value) nil) (:untagged-fixnum-ecx - `((:movl :eax :ecx) - (:sarl ,movitz:+movitz-fixnum-shift+ :ecx))))) + `((,*compiler-global-segment-prefix* + :call (:edi ,(global-constant-offset 'unbox-u32))))))) ((:ebx :ecx :edx) (assert (not indirect-p)) (unless (eq result-mode lexb-location) @@ -4836,27 +4836,14 @@ (values (append code `((:load-lexical ,returns-provided ,desired-result))) desired-result)))) - #+ignore - (:untagged-fixnum-eax - (case returns-provided - (:untagged-fixnum-eax - (values code :untagged-fixnum-eax)) - ((:eax :single-value :multiple-values :function) - (values (append code - `((:testb ,+movitz-fixnum-zmask+ :al) - (:jnz '(:sub-program (not-an-integer) (:int 107))) ; - (:sarl ,+movitz-fixnum-shift+ :eax))) - :untagged-fixnum-eax)))) (:untagged-fixnum-ecx (case returns-provided (:untagged-fixnum-ecx (values code :untagged-fixnum-ecx)) ((:eax :single-value :multiple-values :function) (values (append code - `((:testb ,+movitz-fixnum-zmask+ :al) - (:jnz '(:sub-program (not-an-integer) (:int 107))) ; - (:movl :eax :ecx) - (:sarl ,+movitz-fixnum-shift+ :ecx))) + `((,*compiler-global-segment-prefix* + :call (:edi ,(global-constant-offset 'unbox-u32))))) :untagged-fixnum-ecx)) (:ecx (values (append code

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/more-macros.lisp
by Frode Vatvedt Fjeld 20 Nov '04

20 Nov '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv22773 Modified Files: more-macros.lisp Log Message: Added member compiler-macro. Date: Sat Nov 20 18:36:07 2004 Author: ffjeld Index: movitz/losp/muerte/more-macros.lisp diff -u movitz/losp/muerte/more-macros.lisp:1.20 movitz/losp/muerte/more-macros.lisp:1.21 --- movitz/losp/muerte/more-macros.lisp:1.20 Wed Sep 22 19:48:00 2004 +++ movitz/losp/muerte/more-macros.lisp Sat Nov 20 18:36:07 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.20 2004/09/22 17:48:00 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.21 2004/11/20 17:36:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -134,6 +134,32 @@ ((null ,cons-var) ,result-form) (let ((,var (pop ,cons-var))) ,@declarations-and-body)))) + +(define-compiler-macro member (&whole form item list &key (key ''identity) (test ''eql) + &environment env) + (let* ((test (or (and (movitz:movitz-constantp test env) + (translate-program (movitz:movitz-eval test env) :muerte.cl :cl)) + (and (consp test) (eq 'function (car test)) + (cadr test)))) + (key (or (and (movitz:movitz-constantp key env) + (translate-program (movitz:movitz-eval key env) :muerte.cl :cl)) + (and (consp key) (eq 'function (car key)) + (cadr key))))) + (cond + ((and test (symbolp test) (eq key 'identity)) + `(do ((item ,item) + (p ,list (cdr p))) + ((endp p) nil) + (when (,test (car p) item) + (return p)))) + ((and test (symbolp test) + key (symbolp key)) + `(do ((item ,item) + (p ,list (cdr p))) + ((endp p) nil) + (when (,test (car p) (,key item)) + (return p)))) + (t form)))) (defmacro letf* (bindings &body body &environment env) "Does what one might expect, saving the old values and setting the generalized

1 0

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

20 Nov '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv2421 Modified Files: compiler.lisp Log Message: Tweaked eql some more. Date: Sat Nov 20 02:29:54 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.112 movitz/compiler.lisp:1.113 --- movitz/compiler.lisp:1.112 Sat Nov 20 00:56:14 2004 +++ movitz/compiler.lisp Sat Nov 20 02:29:52 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.112 2004/11/19 23:56:14 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.113 2004/11/20 01:29:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -2575,8 +2575,11 @@ (defun instruction-uncontinues-p (instruction) "Is it impossible for control to return after instruction?" - (member (instruction-is instruction) - '(:jmp :ret))) + (or (member (instruction-is instruction) + '(:jmp :ret)) + (member instruction + '((:int 100)) + :test #'equalp))) (defun sub-environment-p (env1 env2) (cond @@ -6589,7 +6592,7 @@ (rotatef x y) (rotatef x-type y-type) (rotatef x-singleton y-singleton)) - (let (;;(x-loc (new-binding-location (binding-target x) frame-map :default nil)) + (let (;; (x-loc (new-binding-location (binding-target x) frame-map :default nil)) (y-loc (new-binding-location (binding-target y) frame-map :default nil))) #+ignore (warn "eql ~S/~S ~S/~S" @@ -6617,7 +6620,6 @@ (case (operator return-mode) (:boolean-branch-on-false (when (not eql) - (warn "constant eql ~S to ~S" instruction (operands return-mode)) `((:jmp ',(operands return-mode))))) (t (break "Constant EQL: ~S ~S" (car x-singleton) (car y-singleton)))))) ((and x-singleton @@ -6652,15 +6654,22 @@ (movitz-immediate-value (car x-singleton)) y-loc))) (make-branch)))) + ((and x-singleton + (typep (car x-singleton) 'movitz-symbol) + (member y-loc '(:eax :ebx :edx))) + (append (make-load-constant (car x-singleton) y-loc funobj frame-map :op :cmpl) + (make-branch))) (y-singleton (break "y-singleton")) - ((or (movitz-subtypep x-type 'fixnum) - (movitz-subtypep x-type 'character) - (movitz-subtypep y-type 'fixnum) - (movitz-subtypep y-type 'character)) + ((or (movitz-subtypep x-type '(or fixnum character symbol vector)) + (movitz-subtypep y-type '(or fixnum character symbol vector))) (append (make-load-eax-ebx) `((:cmpl :eax :ebx)) (make-branch))) + #+ignore + ((warn "eql ~S/~S ~S/~S" + x x-loc + y y-loc)) ((eq :boolean-branch-on-false (operator return-mode)) (let ((eql-done (gensym "eql-done-")) (on-false-label (operands return-mode)))

1 0

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

19 Nov '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv29209 Modified Files: compiler.lisp Log Message: Fixed bug in :cons-get expander. Date: Sat Nov 20 00:56:15 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.111 movitz/compiler.lisp:1.112 --- movitz/compiler.lisp:1.111 Sat Nov 20 00:06:58 2004 +++ movitz/compiler.lisp Sat Nov 20 00:56:14 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.111 2004/11/19 23:06:58 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.112 2004/11/19 23:56:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -6234,13 +6234,13 @@ (let* ((binding (binding-target (ensure-local-binding (binding-target cell) funobj))) (location (new-binding-location (binding-target binding) frame-map)) (binding-is-list-p (binding-store-subtypep binding 'list))) -;;; (warn "car of loc ~A bind ~A" -;;; location binding) + #+ignore (warn "car of loc ~A bind ~A" + location binding) (cond ((and binding-is-list-p (member location '(:eax :ebx :ecx :edx))) - `(,*compiler-nonlocal-lispval-read-segment-prefix* - (:movl (,location ,op-offset) ,dst))) + `((,*compiler-nonlocal-lispval-read-segment-prefix* + :movl (,location ,op-offset) ,dst))) (binding-is-list-p `(,@(make-load-lexical binding dst funobj nil frame-map) (,*compiler-nonlocal-lispval-read-segment-prefix*

1 0

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

19 Nov '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv26502 Modified Files: basic-macros.lisp Log Message: Compiler-macro eql => eql%b. Date: Sat Nov 20 00:07:50 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.48 movitz/losp/muerte/basic-macros.lisp:1.49 --- movitz/losp/muerte/basic-macros.lisp:1.48 Fri Nov 19 00:49:13 2004 +++ movitz/losp/muerte/basic-macros.lisp Sat Nov 20 00:07:49 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.48 2004/11/18 23:49:13 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.49 2004/11/19 23:07:49 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -446,50 +446,12 @@ (:compile-two-forms (:eax :ebx) ,x ,y) (:cmpl :eax :ebx))))) -#+ignore -(define-compiler-macro eql (&whole form x y &environment env) +(define-compiler-macro eql (x y) `(let ((x ,x) (y ,y)) - (with-inline-assembly (:returns :boolean-zf=1) - (:eql (:lexical-binding x) (:lexical-binding y))))) - -(define-compiler-macro eql (&whole form x y &environment env) - (cond - ((and (movitz:movitz-constantp x env) - (movitz:movitz-constantp y env)) - (eql (movitz:movitz-eval x env) - (movitz:movitz-eval y env))) - ((movitz:movitz-constantp y env) - `(eql ,y ,x)) - ((and (movitz:movitz-constantp x env) - (not (typep (movitz:movitz-eval x env) - '(and number (not fixnum))))) - `(eq ',(movitz:movitz-eval x env) ,y)) - (t `(with-inline-assembly (:returns :boolean-zf=1 :labels (eql-done)) - (:compile-two-forms (:eax :ebx) ,x ,y) - (:cmpl :eax :ebx) - (:je 'eql-done) - (:globally (:movl (:edi (:edi-offset complicated-eql)) :esi)) - (:call (:esi (:offset movitz-funobj code-vector%2op))) - eql-done)))) + (eql%b x y))) (define-compiler-macro values (&rest sub-forms) `(inline-values ,@sub-forms)) - -#+ignore -(define-compiler-macro values (&whole form &rest sub-forms) - (case (length sub-forms) - (0 `(with-inline-assembly (:returns :multiple-values :side-effects nil :type (values)) - (:movl :edi :eax) - (:xorl :ecx :ecx) - (:stc))) - (1 `(with-inline-assembly (:returns :eax :side-effects nil :type (values t)) - (:compile-form (:result-mode :eax) ,(first sub-forms)))) - (2 `(with-inline-assembly (:returns :multiple-values :side-effects nil :type (values t t)) - (:compile-two-forms (:eax :ebx) ,(first sub-forms) ,(second sub-forms)) - (:xorl :ecx :ecx) - (:movb 2 :cl) - (:stc))) - (t form))) (defmacro multiple-value-list (form) `(multiple-value-call #'list ,form))

1 0

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

19 Nov '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv26438 Modified Files: compiler.lisp Log Message: Fixed some bugs in compiler's type-inference. Added eql extended-operator. Date: Sat Nov 20 00:07:03 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.110 movitz/compiler.lisp:1.111 --- movitz/compiler.lisp:1.110 Fri Nov 19 21:12:26 2004 +++ movitz/compiler.lisp Sat Nov 20 00:06:58 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.110 2004/11/19 20:12:26 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.111 2004/11/19 23:06:58 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -431,6 +431,7 @@ (let ((binding-usage (make-hash-table :test 'eq))) (labels ((binding-resolved-p (binding) (or (typep binding 'constant-object-binding) + (typep binding 'function-argument) (let ((analysis (gethash binding binding-usage))) (and analysis (null (type-analysis-thunks analysis)))))) @@ -441,6 +442,8 @@ ((typep binding 'constant-object-binding) (apply #'encoded-type-decode (binding-store-type binding))) + ((typep binding 'function-argument) + t) (t (let ((analysis (gethash binding binding-usage))) (assert (and (and analysis (null (type-analysis-thunks analysis)))) @@ -6571,11 +6574,12 @@ ;;;;;;; -(define-find-read-bindings :eql (x y) +(define-find-read-bindings :eql (x y mode) + (declare (ignore mode)) (list x y)) (define-extended-code-expander :eql (instruction funobj frame-map) - (destructuring-bind (x y) + (destructuring-bind (x y return-mode) (cdr instruction) (let* ((x-type (apply #'encoded-type-decode (binding-store-type x))) (y-type (apply #'encoded-type-decode (binding-store-type y))) @@ -6585,25 +6589,105 @@ (rotatef x y) (rotatef x-type y-type) (rotatef x-singleton y-singleton)) - (let ((x-loc (new-binding-location (binding-target x) frame-map :default nil)) + (let (;;(x-loc (new-binding-location (binding-target x) frame-map :default nil)) (y-loc (new-binding-location (binding-target y) frame-map :default nil))) + #+ignore (warn "eql ~S/~S ~S/~S" x x-loc y y-loc) - (cond - ((and x-singleton y-singleton) - (break "Constant EQL: ~S ~S" (car x-singleton) (car y-singleton))) - ((or (movitz-subtypep x-type 'fixnum) - (movitz-subtypep x-type 'character) - (movitz-subtypep y-type 'fixnum) - (movitz-subtypep y-type 'character)) - (break "EQL that is EQ.")) - (t (append (make-load-lexical x :eax funobj nil frame-map) - (make-load-lexical y :ebx funobj nil frame-map) + (flet ((make-branch () + (ecase (operator return-mode) + (:boolean-branch-on-false + `((:jne ',(operands return-mode)))) + (:boolean-branch-on-true + `((:je ',(operands return-mode)))) + (:boolean-zf=1))) + (make-load-eax-ebx () + (if (eq :eax y-loc) + (make-load-lexical x :ebx funobj nil frame-map) + (append (make-load-lexical x :eax funobj nil frame-map) + (make-load-lexical y :ebx funobj nil frame-map))))) + (cond + ((and x-singleton y-singleton) + (let ((eql (etypecase (car x-singleton) + (movitz-immediate-object + (and (typep (car y-singleton) 'movitz-immediate-object) + (eql (movitz-immediate-value (car x-singleton)) + (movitz-immediate-value (car y-singleton)))))))) + (case (operator return-mode) + (:boolean-branch-on-false + (when (not eql) + (warn "constant eql ~S to ~S" instruction (operands return-mode)) + `((:jmp ',(operands return-mode))))) + (t (break "Constant EQL: ~S ~S" (car x-singleton) (car y-singleton)))))) + ((and x-singleton + (eq :untagged-fixnum-ecx y-loc)) + (let ((value (etypecase (car x-singleton) + (movitz-fixnum + (movitz-fixnum-value (car x-singleton))) + (movitz-bignum + (movitz-bignum-value (car x-singleton)))))) + (check-type value (unsigned-byte 32)) + `((:cmpl ,value :ecx) + ,@(make-branch)))) + ((and x-singleton + (typep (car x-singleton) '(or movitz-immediate-object movitz-null))) + (let ((value (if (typep (car x-singleton) 'movitz-null) + :edi + (movitz-immediate-value (car x-singleton))))) + (append (cond + ((and (eql value 0) + (member y-loc '(:eax :ebx :ecx :edx))) + `((:testl ,y-loc ,y-loc))) + ((and (member y-loc '(:eax :ebx :ecx :edx)) + (not (binding-lended-p y))) + `((:cmpl ,value ,y-loc))) + ((and (integerp y-loc) + (not (binding-lended-p y))) + `((:cmpl ,value (:ebp ,(stack-frame-offset y-loc))))) + ((and (eq :argument-stack (operator y-loc)) + (not (binding-lended-p y))) + `((:cmpl ,value (:ebp ,(argument-stack-offset (binding-target y)))))) + (t (break "x-singleton: ~S with loc ~S" + (movitz-immediate-value (car x-singleton)) + y-loc))) + (make-branch)))) + (y-singleton + (break "y-singleton")) + ((or (movitz-subtypep x-type 'fixnum) + (movitz-subtypep x-type 'character) + (movitz-subtypep y-type 'fixnum) + (movitz-subtypep y-type 'character)) + (append (make-load-eax-ebx) + `((:cmpl :eax :ebx)) + (make-branch))) + ((eq :boolean-branch-on-false (operator return-mode)) + (let ((eql-done (gensym "eql-done-")) + (on-false-label (operands return-mode))) + (append (make-load-eax-ebx) + `((:cmpl :eax :ebx) + (:je ',eql-done) + (,*compiler-global-segment-prefix* + :movl (:edi ,(global-constant-offset 'complicated-eql)) :esi) + (:call (:esi ,(bt:slot-offset 'movitz-funobj 'code-vector%2op))) + (:jne ',on-false-label) + ,eql-done)))) + ((eq :boolean-branch-on-true (operator return-mode)) + (let ((on-true-label (operands return-mode))) + (append (make-load-eax-ebx) + `((:cmpl :eax :ebx) + (:je ',on-true-label) + (,*compiler-global-segment-prefix* + :movl (:edi ,(global-constant-offset 'complicated-eql)) :esi) + (:call (:esi ,(bt:slot-offset 'movitz-funobj 'code-vector%2op))) + (:je ',on-true-label))))) + ((eq return-mode :boolean-zf=1) + (append (make-load-eax-ebx) (let ((eql-done (gensym "eql-done-"))) `((:cmpl :eax :ebx) (:je ',eql-done) (,*compiler-global-segment-prefix* :movl (:edi ,(global-constant-offset 'complicated-eql)) :esi) (:call (:esi ,(bt:slot-offset 'movitz-funobj 'code-vector%2op))) - ,eql-done))))))))) + ,eql-done)))) + (t (error "unknown eql: ~S" instruction))))))))

1 0