[movitz-cvs] CVS movitz/losp/muerte
ffjeld
ffjeld at common-lisp.net
Tue Jan 15 23:01:09 UTC 2008
Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv14571
Modified Files:
memref.lisp
Log Message:
Fix several (more) bugs in (memref-int :type :unsigned-byte32) reader and writer.
--- /project/movitz/cvsroot/movitz/losp/muerte/memref.lisp 2008/01/13 22:27:10 1.50
+++ /project/movitz/cvsroot/movitz/losp/muerte/memref.lisp 2008/01/15 23:01:09 1.51
@@ -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.50 2008/01/13 22:27:10 ffjeld Exp $
+;;;; $Id: memref.lisp,v 1.51 2008/01/15 23:01:09 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -432,24 +432,39 @@
(t (error "Unknown memref type: ~S" (movitz:movitz-eval type nil nil))
form))))))))
-(defun memref (object offset &key (index 0) (type :lisp) localp (endian :host))
- (ecase type
- (:lisp (if localp
- (memref object offset :index index :localp t)
- (memref object offset :index index :localp nil)))
- (:unsigned-byte32 (memref object offset :index index :type :unsigned-byte32))
- (:character (memref object offset :index index :type :character))
- (:unsigned-byte8 (memref object offset :index index :type :unsigned-byte8))
- (:location (memref object offset :index index :type :location))
- (:unsigned-byte16 (ecase endian
- ((:host :little)
- (memref object offset :index index :type :unsigned-byte16 :endian :little))
- ((:big)
- (memref object offset :index index :type :unsigned-byte16 :endian :big))))
- (:code-vector (memref object offset :index index :type :code-vector))
- (:unsigned-byte14 (memref object offset :index index :type :unsigned-byte14))
- (:signed-byte30+2 (memref object offset :index index :type :signed-byte30+2))
- (:unsigned-byte29+3 (memref object offset :index index :type :unsigned-byte29+3))))
+(defun memref (object offset &key (index 0) (type :lisp) localp (endian :host) physicalp)
+ (macrolet
+ ((do-memref (physicalp)
+ `(ecase type
+ (:lisp
+ (if localp
+ (memref object offset :index index :localp t :physicalp ,physicalp)
+ (memref object offset :index index :localp nil :physicalp ,physicalp)))
+ (:unsigned-byte32
+ (memref object offset :index index :type :unsigned-byte32 :physicalp ,physicalp))
+ (:character
+ (memref object offset :index index :type :character :physicalp ,physicalp))
+ (:unsigned-byte8
+ (memref object offset :index index :type :unsigned-byte8 :physicalp ,physicalp))
+ (:location
+ (memref object offset :index index :type :location :physicalp ,physicalp))
+ (:unsigned-byte16
+ (ecase endian
+ ((:host :little)
+ (memref object offset :index index :type :unsigned-byte16 :endian :little :physicalp ,physicalp))
+ ((:big)
+ (memref object offset :index index :type :unsigned-byte16 :endian :big :physicalp ,physicalp))))
+ (:code-vector
+ (memref object offset :index index :type :code-vector :physicalp ,physicalp))
+ (:unsigned-byte14
+ (memref object offset :index index :type :unsigned-byte14 :physicalp ,physicalp))
+ (:signed-byte30+2
+ (memref object offset :index index :type :signed-byte30+2 :physicalp ,physicalp))
+ (:unsigned-byte29+3
+ (memref object offset :index index :type :unsigned-byte29+3 :physicalp ,physicalp)))))
+ (if physicalp
+ (do-memref t)
+ (do-memref nil))))
(define-compiler-macro (setf memref) (&whole form &environment env value object offset
&key (index 0) (type :lisp) (localp nil) (endian :host))
@@ -885,14 +900,14 @@
(define-compiler-macro memref-int
(&whole form address &key (offset 0) (index 0) (type :unsigned-byte32) (physicalp t)
&environment env)
- (if (or (not (movitz:movitz-constantp type physicalp))
+ (if (or (not (movitz:movitz-constantp type env))
(not (movitz:movitz-constantp physicalp env)))
form
(let* ((physicalp (movitz::eval-form physicalp env))
(prefixes (if (not physicalp)
()
movitz:*compiler-physical-segment-prefix*)))
- (ecase (movitz::eval-form type)
+ (ecase (movitz::movitz-eval type env)
(:lisp
(let ((address-var (gensym "memref-int-address-")))
`(let ((,address-var ,address))
@@ -909,17 +924,22 @@
(:shrl ,movitz::+movitz-fixnum-shift+ :ecx) ; scale down address
(,prefixes :movl (:ecx) :eax)))))
(:unsigned-byte32
- (let ((address-var (gensym "memref-int-address-")))
- `(let ((,address-var ,address))
- (with-inline-assembly (:returns :untagged-fixnum-ecx)
- (:compile-two-forms (:eax :ecx) ,offset ,index)
- (:load-lexical (:lexical-binding ,address-var) :ebx)
- (:shll 2 :ecx)
- (:addl :ebx :eax)
- (:into)
- (:addl :eax :ecx)
- (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) ; scale down address
- (,prefixes :movl (:ecx) :ecx)))))
+ (cond
+ ((integerp index)
+ (let ((address-var (gensym "memref-int-address-")))
+ `(let ((,address-var (+ ,address ,offset)))
+ (with-inline-assembly (:returns :untagged-fixnum-ecx)
+ (:compile-form (:result-mode :untagged-fixnum-ecx) ,address-var)
+ (,prefixes :movl (:ecx ,index) :ecx)))))
+ (t (let ((address-var (gensym "memref-int-address-"))
+ (index-var (gensym "memref-int-index-")))
+ `(let ((,address-var (+ ,address ,offset))
+ (,index-var ,index))
+ (with-inline-assembly (:returns :untagged-fixnum-ecx)
+ (:compile-two-forms (:eax :untagged-fixnum-ecx) ,index-var ,address-var)
+ (:testb ,movitz:+movitz-fixnum-zmask+ :al)
+ (:jnz '(:sub-program () (:int 64)))
+ (,prefixes :movl (:ecx :eax) :ecx)))))))
(:unsigned-byte8
(cond
((and (eq 0 offset) (eq 0 index))
@@ -1026,7 +1046,7 @@
(:pushl :ecx) ; an untagged integer (zerop (mod x 4)) is still GC-safe.
(:compile-form (:result-mode :untagged-fixnum-ecx) ,value-var)
(:popl :eax)
- (:movl :ecx (:eax ,offset))))))
+ (,prefixes :movl :ecx (:eax ,offset))))))
(t (let ((offset-var (gensym "memref-int-offset-"))
(addr-var (gensym "memref-int-address-"))
(value-var (gensym "memref-int-value-")))
@@ -1044,7 +1064,7 @@
(:compile-form (:result-mode :edx) ,offset-var)
(:std)
(:shrl ,movitz:+movitz-fixnum-shift+ :edx)
- (:movl :ecx (:eax :edx))
+ (,prefixes :movl :ecx (:eax :edx))
(:movl :edi :edx) ; make EDX GC-safe
(:cld)))))))
(:lisp
More information about the Movitz-cvs
mailing list