Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv25179
Modified Files: memref.lisp Log Message: Added an :endian keyword parameter to memref. It's not completely implemented yet.
Date: Thu Oct 7 14:43:29 2004 Author: ffjeld
Index: movitz/losp/muerte/memref.lisp diff -u movitz/losp/muerte/memref.lisp:1.30 movitz/losp/muerte/memref.lisp:1.31 --- movitz/losp/muerte/memref.lisp:1.30 Fri Sep 17 13:06:47 2004 +++ movitz/losp/muerte/memref.lisp Thu Oct 7 14:43:29 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.30 2004/09/17 11:06:47 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.31 2004/10/07 12:43:29 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------
@@ -18,10 +18,11 @@
(in-package muerte)
-(define-compiler-macro memref (&whole form object offset index type &key (localp nil) +(define-compiler-macro memref (&whole form object offset index type &key (localp nil) (endian :host) &environment env) (if (or (not (movitz:movitz-constantp type env)) - (not (movitz:movitz-constantp localp env))) + (not (movitz:movitz-constantp localp env)) + (not (movitz:movitz-constantp endian env))) form (labels ((sub-extract-constant-delta (form) "Try to extract at compile-time an integer offset from form." @@ -88,32 +89,41 @@ (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) (:movzxb (:eax :ecx ,(offset-by 1)) :ecx))))))) (:unsigned-byte16 - (cond - ((and (eq 0 offset) (eq 0 index)) - `(with-inline-assembly (:returns :untagged-fixnum-ecx) - (:compile-form (:result-mode :eax) ,object) - (:movzxw (:eax ,(offset-by 2)) :ecx))) - ((eq 0 offset) - (let ((object-var (gensym "memref-object-")) - (index-var (gensym "memref-index-"))) - `(let ((,object-var ,object) - (,index-var ,index)) - (with-inline-assembly (:returns :untagged-fixnum-ecx) - (:compile-two-forms (:eax :ecx) ,object-var ,index-var) - (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx) - (:movzxw (:eax :ecx ,(offset-by 2)) :ecx))))) - (t (let ((object-var (gensym "memref-object-")) - (offset-var (gensym "memref-offset-")) + (let* ((endian (ecase (movitz:movitz-eval endian env) + ((:host :little) :little) + (:big :big))) + (endian-fix-ecx (ecase endian + (:little nil) + (:big `((:xchgb :cl :ch)))))) + (cond + ((and (eq 0 offset) (eq 0 index)) + `(with-inline-assembly (:returns :untagged-fixnum-ecx) + (:compile-form (:result-mode :eax) ,object) + (:movzxw (:eax ,(offset-by 2)) :ecx) + ,@endian-fix-ecx)) + ((eq 0 offset) + (let ((object-var (gensym "memref-object-")) (index-var (gensym "memref-index-"))) `(let ((,object-var ,object) - (,offset-var ,offset) (,index-var ,index)) (with-inline-assembly (:returns :untagged-fixnum-ecx) - (:compile-two-forms (:ecx :ebx) ,offset-var ,index-var) - (:leal (:ecx (:ebx 2)) :ecx) - (:load-lexical (:lexical-binding ,object-var) :eax) - (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) - (:movzxw (:eax :ecx ,(offset-by 2)) :ecx))))))) + (:compile-two-forms (:eax :ecx) ,object-var ,index-var) + (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx) + (:movzxw (:eax :ecx ,(offset-by 2)) :ecx) + ,@endian-fix-ecx)))) + (t (let ((object-var (gensym "memref-object-")) + (offset-var (gensym "memref-offset-")) + (index-var (gensym "memref-index-"))) + `(let ((,object-var ,object) + (,offset-var ,offset) + (,index-var ,index)) + (with-inline-assembly (:returns :untagged-fixnum-ecx) + (:compile-two-forms (:ecx :ebx) ,offset-var ,index-var) + (:leal (:ecx (:ebx 2)) :ecx) + (:load-lexical (:lexical-binding ,object-var) :eax) + (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) + (:movzxw (:eax :ecx ,(offset-by 2)) :ecx) + ,@endian-fix-ecx))))))) (:unsigned-byte14 (cond ((and (eq 0 offset) (eq 0 index)) @@ -225,6 +235,8 @@ (:movl (:eax :ecx ,(offset-by 4)) :ecx) (:andl -4 :ecx))))))) (:unsigned-byte32 + (let ((endian (movitz:movitz-eval endian env))) + (assert (member endian '(:host :little)))) (assert (= 4 movitz::+movitz-fixnum-factor+)) (cond ((and (eq 0 offset) (eq 0 index)) @@ -314,22 +326,29 @@ (t (error "Unknown memref type: ~S" (movitz::eval-form type nil nil)) form)))))))))
-(defun memref (object offset index type) +(defun memref (object offset index type &key localp (endian :host)) (ecase type - (:lisp (memref object offset index :lisp)) + (:lisp (if localp + (memref object offset index :lisp :localp t) + (memref object offset index :lisp :localp nil))) (:unsigned-byte32 (memref object offset index :unsigned-byte32)) (:character (memref object offset index :character)) (:unsigned-byte8 (memref object offset index :unsigned-byte8)) (:location (memref object offset index :location)) (:unsigned-byte14 (memref object offset index :unsigned-byte14)) - (:unsigned-byte16 (memref object offset index :unsigned-byte16)) + (:unsigned-byte16 (ecase endian + ((:host :little) + (memref object offset index :unsigned-byte16 :endian :little)) + ((:big) + (memref object offset index :unsigned-byte16 :endian :big)))) (: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 &environment env value object offset index type - &key (localp nil)) + &key (localp nil) (endian :host)) (if (or (not (movitz:movitz-constantp type env)) - (not (movitz:movitz-constantp localp env))) + (not (movitz:movitz-constantp localp env)) + (not (movitz:movitz-constantp endian env))) form (case (movitz::eval-form type) (:character @@ -370,6 +389,8 @@ (:load-lexical (:lexical-binding ,object-var) :ebx) (:movb :ah (:ebx :ecx)))))))) (:unsigned-byte32 + (let ((endian (movitz:movitz-eval endian env))) + (assert (member endian '(:host :little)))) (assert (= 4 movitz::+movitz-fixnum-factor+)) (cond ((and (movitz:movitz-constantp value env) @@ -430,98 +451,116 @@ (:movl :edi :edx) (:cld))))))) (:unsigned-byte16 - (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 (: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) - (movitz:movitz-constantp value env)) - (let ((value (movitz:movitz-eval value env)) - (index-var (gensym "memref-index-")) - (object-var (gensym "memref-object-"))) - (check-type value (unsigned-byte 16)) - `(let ((,object-var ,object) - (,index-var ,index)) - (with-inline-assembly (:returns :nothing) - (:compile-two-forms (:ecx :ebx) ,index-var ,object-var) - (:sarl ,(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-")) - (index-var (gensym "memref-index-")) - (object-var (gensym "memref-object-"))) - (if (<= 16 movitz:*compiler-allow-untagged-word-bits*) + (let ((endian (ecase (movitz:movitz-eval endian env) + ((:host :little) :little) + (:big :big)))) + (cond + ((and (movitz:movitz-constantp value env) + (movitz:movitz-constantp offset env) + (movitz:movitz-constantp index env)) + (let* ((host-value (movitz:movitz-eval value env)) + (value (ecase endian + (:little host-value) + (:big (dpb (ldb (byte 8 0) host-value) + (byte 8 8) + (ldb (byte 8 8) host-value)))))) + (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 (:untagged-fixnum-ecx :ebx) ,value ,object) + ,@(ecase endian + (:little nil) + (:big `((:xchg :cl :ch)))) + (: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)) + (index-var (gensym "memref-index-")) + (object-var (gensym "memref-object-"))) + (check-type value (unsigned-byte 16)) + `(let ((,object-var ,object) + (,index-var ,index)) + (with-inline-assembly (:returns :nothing) + (:compile-two-forms (:ecx :ebx) ,index-var ,object-var) + (:sarl ,(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-")) + (index-var (gensym "memref-index-")) + (object-var (gensym "memref-object-"))) + (if (<= 16 movitz:*compiler-allow-untagged-word-bits*) + `(let ((,value-var ,value) + (,object-var ,object) + (,index-var ,index)) + (with-inline-assembly (:returns :untagged-fixnum-eax) + (:compile-two-forms (:ebx :ecx) ,object-var ,index-var) + (:load-lexical (:lexical-binding ,value-var) :untagged-fixnum-eax) + (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx) + (:movw :ax (:ebx :ecx ,(movitz:movitz-eval offset env))))) `(let ((,value-var ,value) (,object-var ,object) (,index-var ,index)) - (with-inline-assembly (:returns :untagged-fixnum-eax) + (with-inline-assembly (:returns :nothing) (:compile-two-forms (:ebx :ecx) ,object-var ,index-var) - (:load-lexical (:lexical-binding ,value-var) :untagged-fixnum-eax) + (:load-lexical (:lexical-binding ,value-var) :eax) (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx) - (:movw :ax (:ebx :ecx ,(movitz:movitz-eval offset env))))) - `(let ((,value-var ,value) - (,object-var ,object) - (,index-var ,index)) - (with-inline-assembly (:returns :nothing) - (:compile-two-forms (:ebx :ecx) ,object-var ,index-var) - (:load-lexical (:lexical-binding ,value-var) :eax) - (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx) - (:movl :edi :edx) - (:std) - (:shrl ,movitz:+movitz-fixnum-shift+ :eax) - (:movw :ax (:ebx :ecx ,(movitz:movitz-eval offset env))) - (:movl :edi :eax) - (:cld)) - ,value-var)))) - (t (let ((value-var (gensym "memref-value-")) - (object-var (gensym "memref-object-")) - (offset-var (gensym "memref-offset-")) - (index-var (gensym "memref-index-"))) - (if (<= 16 movitz:*compiler-allow-untagged-word-bits*) + (:movl :edi :edx) + (:std) + (:shrl ,movitz:+movitz-fixnum-shift+ :eax) + ,@(ecase endian + (:little nil) + (:big `((:xchgb :al :ah)))) + (:movw :ax (:ebx :ecx ,(movitz:movitz-eval offset env))) + (:movl :edi :eax) + (:cld)) + ,value-var)))) + (t (let ((value-var (gensym "memref-value-")) + (object-var (gensym "memref-object-")) + (offset-var (gensym "memref-offset-")) + (index-var (gensym "memref-index-"))) + (if (<= 16 movitz:*compiler-allow-untagged-word-bits*) + `(let ((,value-var ,value) + (,object-var ,object) + (,offset-var ,offset) + (,index-var ,index)) + (with-inline-assembly (:returns :untagged-fixnum-eax) + (:compile-two-forms (:ebx :ecx) ,offset-var ,index-var) + (: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) (,offset-var ,offset) (,index-var ,index)) - (with-inline-assembly (:returns :untagged-fixnum-eax) + (with-inline-assembly (:returns :nothing) (:compile-two-forms (:ebx :ecx) ,offset-var ,index-var) (: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) - (,offset-var ,offset) - (,index-var ,index)) - (with-inline-assembly (:returns :nothing) - (:compile-two-forms (:ebx :ecx) ,offset-var ,index-var) - (: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)))))) + (:std) + (:shrl ,movitz:+movitz-fixnum-shift+ :eax) + ,@(ecase endian + (:little nil) + (:big `((:xchgb :al :ah)))) + (:movw :ax (:ebx :ecx)) + (:shll ,movitz:+movitz-fixnum-shift+ :eax) + (:movl :edi :edx) + (:cld)) + ,value-var))))))) (:unsigned-byte8 (cond ((and (movitz:movitz-constantp value env) @@ -644,18 +683,24 @@ (t ;; (warn "Can't handle inline MEMREF: ~S" form) form))))
-(defun (setf memref) (value object offset index type) +(defun (setf memref) (value object offset index type &key localp (endian :host)) (ecase type (:character (setf (memref object offset index :character) value)) (:unsigned-byte8 (setf (memref object offset index :unsigned-byte8) value)) (:unsigned-byte16 - (setf (memref object offset index :unsigned-byte16) value)) + (ecase endian + ((:host :little) + (setf (memref object offset index :unsigned-byte16 :endian :little) value)) + ((:big) + (setf (memref object offset index :unsigned-byte16 :endian :big) value)))) (:unsigned-byte32 (setf (memref object offset index :unsigned-byte32) value)) (:lisp - (setf (memref object offset index :lisp) value)))) + (if localp + (setf (memref object offset index :lisp :localp t) value) + (setf (memref object offset index :lisp :localp nil) value)))))
(define-compiler-macro memref-int (&whole form &environment env address offset index type &optional physicalp)