[movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp
Frode Vatvedt Fjeld
ffjeld at common-lisp.net
Thu Oct 7 12:43:30 UTC 2004
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 at 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)
+ , at 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)
+ , at 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)
+ , at 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)
More information about the Movitz-cvs
mailing list