Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv28449

Modified Files: memref.lisp Log Message: Clevered up (setf memref) quite a bit.

Date: Wed Mar 31 11:49:23 2004 Author: ffjeld

Index: movitz/losp/muerte/memref.lisp diff -u movitz/losp/muerte/memref.lisp:1.5 movitz/losp/muerte/memref.lisp:1.6 --- movitz/losp/muerte/memref.lisp:1.5 Tue Mar 30 04:36:50 2004 +++ movitz/losp/muerte/memref.lisp Wed Mar 31 11:49:23 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld frodef@acm.org ;;;; Created at: Tue Mar 6 21:25:49 2001 ;;;; -;;;; $Id: memref.lisp,v 1.5 2004/03/30 09:36:50 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.6 2004/03/31 16:49:23 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------

@@ -184,67 +184,252 @@ (:signed-byte30+2 (memref object offset index :signed-byte30+2)) (:unsigned-byte29+3 (memref object offset index :unsigned-byte29+3))))

-(define-compiler-macro (setf memref) (&whole form value object offset index type) - (if (not (movitz:movitz-constantp type)) +(define-compiler-macro (setf memref) (&whole form &environment env value object offset index type) + (if (not (movitz:movitz-constantp type env)) form (case (movitz::eval-form type) (:character - `(with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :push) ,object) - (:compile-form (:result-mode :push) ,offset) - (:compile-two-forms (:ebx :eax) ,index ,value) - (:popl :ecx) ; offset - (:addl :ecx :ebx) ; index += offset - (:sarl #.movitz::+movitz-fixnum-shift+ :ebx) - (:popl :ecx) ; object - (:movb :ah (:ebx :ecx)))) + (cond + ((and (movitz:movitz-constantp value env) + (movitz:movitz-constantp offset env) + (movitz:movitz-constantp index env)) + (let ((value (movitz:movitz-eval value env))) + (check-type value movitz-character) + `(progn + (with-inline-assembly (:returns :nothing) + (:compile-form (:result-mode :ebx) ,object) + (:movb ,(movitz:movitz-intern value) + (:ebx ,(+ (movitz:movitz-eval offset env) + (* 1 (movitz:movitz-eval index env)))))) + ,value))) + ((and (movitz:movitz-constantp offset env) + (movitz:movitz-constantp index env)) + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) ,value ,object) + (:movb :ah (:ebx ,(+ (movitz:movitz-eval offset env) + (* 1 (movitz:movitz-eval index env))))))) + ((movitz:movitz-constantp offset env) + (let ((value-var (gensym "memref-value-"))) + `(let ((,value-var ,value)) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:ebx :untagged-fixnum-ecx) ,object ,index) + (:load-lexical (:lexical-binding ,value-var) :eax) + (:movb :ah (:ebx :ecx ,(+ (movitz:movitz-eval offset env)))))))) + (t (let ((object-var (gensym "memref-object-")) + (offset-var (gensym "memref-offset-"))) + `(let ((,object-var ,object) (,offset-var ,offset)) + (with-inline-assembly (:returns :nothing) + (:compile-two-forms (:ecx :eax) ,index ,value) + (:load-lexical (:lexical-binding ,offset-var) :ebx) + (:addl :ebx :ecx) + (:sarl #.movitz::+movitz-fixnum-shift+ :ecx) + (:load-lexical (:lexical-binding ,object-var) :ebx) + (:movb :ah (:ebx :ecx)))))))) (:unsigned-byte32 (assert (= 4 movitz::+movitz-fixnum-factor+)) - `(with-inline-assembly (:returns :untagged-fixnum-eax) - (:compile-form (:result-mode :push) ,object) - (:compile-form (:result-mode :push) ,offset) - (:compile-two-forms (:ebx :eax) ,index ,value) - (:popl :ecx) ; offset - (:shrl #.movitz::+movitz-fixnum-shift+ :eax) - (:sarl #.movitz::+movitz-fixnum-shift+ :ecx) - (:addl :ebx :ecx) ; index += offset - (:popl :ebx) ; object - (:movl :eax (:ebx :ecx)))) + (cond + ((and (movitz:movitz-constantp value env) + (movitz:movitz-constantp offset env) + (movitz:movitz-constantp index env)) + (let ((value (movitz:movitz-eval value env))) + (check-type value (unsigned-byte 32)) + `(progn + (with-inline-assembly (:returns :nothing) + (:compile-form (:result-mode :ebx) ,object) + (:movl ,value (:ebx ,(+ (movitz:movitz-eval offset env) + (* 2 (movitz:movitz-eval index env)))))) + ,value))) + ((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) + (:movl :ecx (:ebx ,(+ (movitz:movitz-eval offset env) + (* 4 (movitz:movitz-eval index env))))))) + ((and (movitz:movitz-constantp offset env) + (movitz:movitz-constantp value env)) + (let ((value (movitz:movitz-eval value env))) + (check-type value (unsigned-byte 32)) + `(progn + (with-inline-assembly (:returns :nothing) + (:compile-two-forms (:ecx :ebx) ,index ,object) + (:movl ,value (:ebx :ecx ,(movitz:movitz-eval offset env)))) + ,value))) + ((movitz:movitz-constantp offset env) + (let ((value-var (gensym "memref-value-"))) + `(let ((,value-var ,value)) + (with-inline-assembly (:returns :untagged-fixnum-ecx) + (:compile-two-forms (:ebx :eax) ,object ,index) + (:load-lexical (:lexical-binding ,value-var) :ecx) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:movl :ecx (:eax :ebx ,(movitz:movitz-eval offset env))))))) + (t (warn "Compiling unsafely: ~A" form) + `(with-inline-assembly (:returns :untagged-fixnum-eax) + (:compile-form (:result-mode :push) ,object) + (:compile-form (:result-mode :push) ,offset) + (:compile-two-forms (:ebx :eax) ,index ,value) + (:popl :ecx) ; offset + (:shrl #.movitz::+movitz-fixnum-shift+ :eax) + (:sarl #.movitz::+movitz-fixnum-shift+ :ecx) + (:addl :ebx :ecx) ; index += offset + (:popl :ebx) ; object + (:movl :eax (:ebx :ecx)))))) (:unsigned-byte16 - `(with-inline-assembly (:returns :untagged-fixnum-eax) - (:compile-form (:result-mode :push) ,object) - (:compile-form (:result-mode :push) ,offset) - (:compile-two-forms (:ebx :eax) ,index ,value) - (:sarl #.(cl:1- movitz::+movitz-fixnum-shift+) :ebx) - (:popl :ecx) ; offset - (:shrl #.movitz::+movitz-fixnum-shift+ :eax) - (:sarl #.movitz::+movitz-fixnum-shift+ :ecx) - (:addl :ebx :ecx) ; index += offset - (:popl :ebx) ; object - (:movw :ax (:ebx :ecx)))) + (cond + ((and (movitz:movitz-constantp value env) + (movitz:movitz-constantp offset env) + (movitz:movitz-constantp index env)) + (let ((value (movitz:movitz-eval value env))) + (check-type value (unsigned-byte 16)) + `(progn + (with-inline-assembly (:returns :nothing) + (:compile-form (:result-mode :ebx) ,object) + (:movw ,value (:ebx ,(+ (movitz:movitz-eval offset env) + (* 2 (movitz:movitz-eval index env)))))) + ,value))) + ((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) + (:movw :cx (:ebx ,(+ (movitz:movitz-eval offset env) + (* 2 (movitz:movitz-eval index env))))))) + ((and (movitz:movitz-constantp offset env) + (movitz:movitz-constantp value env)) + (let ((value (movitz:movitz-eval value env))) + (check-type value (unsigned-byte 16)) + `(progn + (with-inline-assembly (:returns :nothing) + (:compile-two-forms (:ecx :ebx) ,index ,object) + (:shrl ,(1- movitz:+movitz-fixnum-shift+) :ecx) + (:movw ,value (:ebx :ecx ,(movitz:movitz-eval offset env)))) + ,value))) + ((movitz:movitz-constantp offset env) + (let ((value-var (gensym "memref-value-"))) + (if (<= 16 movitz:*compiler-allow-untagged-word-bits*) + `(let ((,value-var ,value)) + (with-inline-assembly (:returns :untagged-fixnum-eax) + (:compile-two-forms (:ebx :ecx) ,object ,index) + (:load-lexical (:lexical-binding ,value-var) :untagged-fixnum-eax) + (:shrl ,(1- movitz:+movitz-fixnum-shift+) :ecx) + (:movw :ax (:ebx :ecx ,(movitz:movitz-eval offset env))))) + `(let ((,value-var ,value)) + (with-inline-assembly (:returns :nothing) + (:compile-two-forms (:ebx :ecx) ,object ,index) + (:load-lexical (:lexical-binding ,value-var) :eax) + (:shrl ,(1- movitz:+movitz-fixnum-shift+) :ecx) + (:shll ,(- 8 movitz:+movitz-fixnum-shift+) :eax) + (:movb :ah (:ebx :ecx ,(movitz:movitz-eval offset env))) + (:andl #xff0000 :eax) + (:shrl 8 :eax) + (:movb :ah (:ebx :ecx ,(1+ (movitz:movitz-eval offset env))))) + ,value-var)))) + (t (let ((value-var (gensym "memref-value-")) + (object-var (gensym "memref-object-"))) + (if (<= 16 movitz:*compiler-allow-untagged-word-bits*) + `(let ((,value-var ,offset) (,object-var ,object)) + (with-inline-assembly (:returns :untagged-fixnum-eax) + (:compile-two-forms (:ebx :ecx) ,offset ,index) + (:load-lexical (:lexical-binding ,value-var) :eax) + (:andl ,(* movitz:+movitz-fixnum-factor+ #xffff) :eax) + (:leal (:ebx (:ecx 2)) :ecx) + (:shrl ,movitz:+movitz-fixnum-shift+ :eax) + (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) + (:load-lexical (:lexical-binding ,object-var) :ebx) + (:movw :ax (:ebx :ecx)))) + `(let ((,value-var ,value) (,object-var ,object)) + (with-inline-assembly (:returns :nothing) + (:compile-two-forms (:ebx :ecx) ,offset ,index) + (:load-lexical (:lexical-binding ,value-var) :eax) + (:leal (:ebx (:ecx 2)) :ecx) + (:shll ,(- 8 movitz:+movitz-fixnum-shift+) :eax) + (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) + (:load-lexical (:lexical-binding ,object-var) :ebx) + (:movb :ah (:ebx :ecx)) + (:andl #xff0000 :eax) + (:shrl 8 :eax) + (:movb :ah (:ebx :ecx 1))) + ,value-var)))))) (:unsigned-byte8 - `(with-inline-assembly (:returns :untagged-fixnum-eax) - (:compile-form (:result-mode :push) ,object) - (:compile-form (:result-mode :push) ,offset) - (:compile-two-forms (:ebx :eax) ,index ,value) - (:shrl #.movitz::+movitz-fixnum-shift+ :eax) - (:popl :ecx) ; offset - (:addl :ecx :ebx) ; index += offset - (:sarl #.movitz::+movitz-fixnum-shift+ :ebx) - (:popl :ecx) ; object - (:movb :al (:ebx :ecx)))) + (cond + ((and (movitz:movitz-constantp value env) + (movitz:movitz-constantp offset env) + (movitz:movitz-constantp index env)) + (let ((value (movitz:movitz-eval value env))) + (check-type value (unsigned-byte 8)) + `(progn + (with-inline-assembly (:returns :nothing) + (:compile-form (:result-mode :ebx) ,object) + (:movb ,value (:ebx ,(+ (movitz:movitz-eval offset env) + (* 1 (movitz:movitz-eval index env)))))) + ,value))) + ((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) + (:movb :cl (:ebx ,(+ (movitz:movitz-eval offset env) + (* 1 (movitz:movitz-eval index env))))))) + ((and (movitz:movitz-constantp offset env) + (movitz:movitz-constantp value env)) + (let ((value (movitz:movitz-eval value env))) + (check-type value (unsigned-byte 8)) + `(progn + (with-inline-assembly (:returns :untagged-fixnum-ecx) + (:compile-two-forms (:eax :ecx) ,object ,index) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:movb ,value (:eax :ecx ,(movitz:movitz-eval offset env)))) + value))) + ((movitz:movitz-constantp offset env) + (let ((value-var (gensym "memref-value-"))) + `(let ((,value-var ,value)) + (with-inline-assembly (:returns :nothing) + (:compile-two-forms (:ebx :ecx) ,object ,index) + (:load-lexical (:lexical-binding ,value-var) :eax) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:shll ,(- 8 movitz:+movitz-fixnum-shift+) :eax) ; value into :AH + (:movb :ah (:ebx :ecx ,(movitz:movitz-eval offset env)))) + ,value-var))) + (t (let ((value-var (gensym "memref-value-")) + (object-var (gensym "memref-object-"))) + `(let ((,value-var ,value) (,object-var ,object)) + (with-inline-assembly (:returns :nothing) + (:compile-two-forms (:ebx :ecx) ,offset ,index) + (:load-lexical (:lexical-binding ,value-var) :eax) + (:addl :ebx :ecx) + (:load-lexical (:lexical-binding ,object-var) :ebx) ; value into :AH + (:shll ,(- 8 movitz:+movitz-fixnum-shift+) :eax) + (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) + (:movb :ah (:ebx :ecx))) + ,value-var))))) (:lisp - `(with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :push) ,object) - (:compile-form (:result-mode :push) ,offset) - (:compile-two-forms (:ebx :eax) ,index ,value) - (:popl :ecx) ; offset - (:sarl #.movitz::+movitz-fixnum-shift+ :ecx) - ,@(when (cl:plusp (cl:- movitz::+movitz-fixnum-shift+ 2)) - `((:sarl ,(cl:- movitz::+movitz-fixnum-shift+ 2)) :ebx)) - (:addl :ecx :ebx) ; index += offset - (:popl :ecx) ; value - (:movl :eax (:ebx :ecx)))) + (cond + ((and (movitz:movitz-constantp offset env) + (movitz:movitz-constantp index env)) + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) ,value ,object) + (:movl :eax (:ebx ,(+ (movitz:movitz-eval offset env) + (* 4 (movitz:movitz-eval index env))))))) + ((movitz:movitz-constantp offset env) + (let ((value-var (gensym "memref-value-"))) + `(let ((,value-var ,value)) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:ebx :ecx) ,object ,index) + (:load-lexical (:lexical-binding ,value-var) :eax) + ,@(when (plusp (- movitz:+movitz-fixnum-shift+ 2)) + `((:sarl ,(- movitz:+movitz-fixnum-shift+ 2)) :ecx)) + (:movl :eax (:ebx :ecx ,(movitz:movitz-eval offset env))))))) + (t (let ((value-var (gensym "memref-value-")) + (object-var (gensym "memref-object-"))) + `(let ((,value-var ,value) (,object-var ,object)) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:untagged-fixnum-ecx :ebx) ,offset ,index) + (:load-lexical (:lexical-binding ,value-var) :eax) + ,@(when (cl:plusp (cl:- movitz::+movitz-fixnum-shift+ 2)) + `((:sarl ,(cl:- movitz::+movitz-fixnum-shift+ 2)) :ebx)) + (:addl :ebx :ecx) ; index += offset + (:load-lexical (:lexical-binding ,object-var) :ebx) + (:movl :eax (:ebx :ecx)))))))) (t ;; (warn "Can't handle inline MEMREF: ~S" form) form))))