[movitz-cvs] CVS movitz/losp/muerte
ffjeld
ffjeld at common-lisp.net
Thu Jan 17 20:20:34 UTC 2008
Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv24499
Modified Files:
memref.lisp
Log Message:
Add/improve support for physicalp for memref and (setf memref).
--- /project/movitz/cvsroot/movitz/losp/muerte/memref.lisp 2008/01/15 23:01:09 1.51
+++ /project/movitz/cvsroot/movitz/losp/muerte/memref.lisp 2008/01/17 20:20:33 1.52
@@ -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.51 2008/01/15 23:01:09 ffjeld Exp $
+;;;; $Id: memref.lisp,v 1.52 2008/01/17 20:20:33 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -74,8 +74,11 @@
offset constant-offset
index constant-index)
(let ((type (movitz:movitz-eval type env))
- (physicalp (movitz:movitz-eval physicalp env)))
- (when (and physicalp (not (eq type :unsigned-byte32)))
+ (physicalp (movitz:movitz-eval physicalp env))
+ (prefixes (if (not physicalp)
+ ()
+ movitz:*compiler-physical-segment-prefix*)))
+ (when (and physicalp (member type '(:lisp :code-vector)))
(warn "(memref physicalp) unsupported for type ~S." type))
(case type
(:unsigned-byte8
@@ -83,7 +86,7 @@
((and (eql 0 offset) (eql 0 index))
`(with-inline-assembly (:returns :untagged-fixnum-ecx :type (unsigned-byte 8))
(:compile-form (:result-mode :eax) ,object)
- (:movzxb (:eax ,(offset-by 1)) :ecx)))
+ (,prefixes :movzxb (:eax ,(offset-by 1)) :ecx)))
((eql 0 index)
(let ((object-var (gensym "memref-object-"))
(offset-var (gensym "memref-offset-")))
@@ -93,12 +96,11 @@
:type (unsigned-byte 8))
(:compile-two-forms (:eax :untagged-fixnum-ecx) ,object-var ,offset-var)
;; (:sarl ,movitz:+movitz-fixnum-shift+ :ecx)
- (:movzxb (:eax :ecx ,(offset-by 1)) :ecx)
- ))))
+ (,prefixes :movzxb (:eax :ecx ,(offset-by 1)) :ecx)))))
((eql 0 offset)
`(with-inline-assembly (:returns :untagged-fixnum-ecx :type (unsigned-byte 8))
(:compile-two-forms (:eax :untagged-fixnum-ecx) ,object ,index)
- (:movzxb (:eax :ecx ,(offset-by 1)) :ecx)))
+ (,prefixes :movzxb (:eax :ecx ,(offset-by 1)) :ecx)))
(t (let ((object-var (gensym "memref-object-")))
`(let ((,object-var ,object))
(with-inline-assembly (:returns :untagged-fixnum-ecx :type (unsigned-byte 8))
@@ -106,7 +108,7 @@
(:load-lexical (:lexical-binding ,object-var) :eax)
(:addl :ebx :ecx) ; index += offset
(:sarl ,movitz::+movitz-fixnum-shift+ :ecx)
- (:movzxb (:eax :ecx ,(offset-by 1)) :ecx)))))))
+ (,prefixes :movzxb (:eax :ecx ,(offset-by 1)) :ecx)))))))
(:unsigned-byte16
(let* ((endian (ecase (movitz:movitz-eval endian env)
((:host :little) :little)
@@ -119,7 +121,7 @@
`(with-inline-assembly (:returns :untagged-fixnum-ecx
:type (unsigned-byte 16))
(:compile-form (:result-mode :eax) ,object)
- (:movzxw (:eax ,(offset-by 2)) :ecx)
+ (,prefixes :movzxw (:eax ,(offset-by 2)) :ecx)
, at endian-fix-ecx))
((eql 0 index)
(let ((object-var (gensym "memref-object-"))
@@ -130,7 +132,7 @@
:type (unsigned-byte 16))
(:compile-two-forms (:eax :ecx) ,object-var ,offset-var)
(:sarl ,movitz:+movitz-fixnum-shift+ :ecx)
- (:movzxw (:eax :ecx ,(offset-by 2)) :ecx)
+ (,prefixes :movzxw (:eax :ecx ,(offset-by 2)) :ecx)
, at endian-fix-ecx))))
((eql 0 offset)
(let ((object-var (gensym "memref-object-"))
@@ -141,7 +143,7 @@
:type (unsigned-byte 16))
(:compile-two-forms (:eax :ecx) ,object-var ,index-var)
(:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx)
- (:movzxw (:eax :ecx ,(offset-by 2)) :ecx)
+ (,prefixes :movzxw (:eax :ecx ,(offset-by 2)) :ecx)
, at endian-fix-ecx))))
(t (let ((object-var (gensym "memref-object-"))
(offset-var (gensym "memref-offset-"))
@@ -155,14 +157,14 @@
(: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)
+ (,prefixes :movzxw (:eax :ecx ,(offset-by 2)) :ecx)
, at endian-fix-ecx)))))))
(:unsigned-byte14
(cond
((and (eq 0 offset) (eq 0 index))
`(with-inline-assembly (:returns :ecx :type (unsigned-byte 14))
(:compile-form (:result-mode :eax) ,object)
- (:movzxw (:eax ,(offset-by 2)) :ecx)
+ (,prefixes :movzxw (:eax ,(offset-by 2)) :ecx)
(:testb ,movitz:+movitz-fixnum-zmask+ :cl)
(:jnz '(:sub-program () (:int 63)))))
((eq 0 offset)
@@ -173,7 +175,7 @@
(with-inline-assembly (:returns :ecx)
(:compile-two-forms (:eax :ecx) ,object-var ,index-var)
(:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx)
- (:movzxw (:eax :ecx ,(offset-by 2)) :ecx)
+ (,prefixes :movzxw (:eax :ecx ,(offset-by 2)) :ecx)
(:testb ,movitz:+movitz-fixnum-zmask+ :cl)
(:jnz '(:sub-program () (:int 63)))))))
(t (let ((object-var (gensym "memref-object-"))
@@ -187,7 +189,7 @@
(: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)
+ (,prefixes :movzxw (:eax :ecx ,(offset-by 2)) :ecx)
(:testb ,movitz:+movitz-fixnum-shift+ :cl)
(:jnz '(:sub-program () (:int 63)))))))))
(:unsigned-byte29+3
@@ -200,7 +202,7 @@
(:sarl ,movitz::+movitz-fixnum-shift+ :ecx)
(:addl :ebx :ecx)
(:popl :eax) ; object
- (:movl (:eax :ecx ,(offset-by 4)) :ecx)
+ (,prefixes :movl (:eax :ecx ,(offset-by 4)) :ecx)
(:leal ((:ecx 4)) :ebx)
(:shrl 1 :ecx)
(:andl #b11100 :ebx)
@@ -222,12 +224,12 @@
((and (eq 0 offset) (eq 0 index))
`(with-inline-assembly (:returns :multiple-values)
(:compile-form (:result-mode :eax) ,object)
- (:movl (:eax ,(offset-by 4)) :ecx)
+ (,prefixes :movl (:eax ,(offset-by 4)) :ecx)
, at fix-ecx))
((eq 0 offset)
`(with-inline-assembly (:returns :multiple-values)
(:compile-two-forms (:eax :ecx) ,object ,index)
- (:movl (:eax :ecx ,(offset-by 4)) :ecx)
+ (,prefixes :movl (:eax :ecx ,(offset-by 4)) :ecx)
, at fix-ecx))
(t (let ((object-var (gensym "memref-object-")))
`(let ((,object-var ,object))
@@ -261,7 +263,7 @@
(:xorl :eax :eax)
(:movb ,(movitz:tag :character) :al)
(:sarl ,movitz::+movitz-fixnum-shift+ :ecx) ; scale index
- (:movb (:ebx :ecx ,(offset-by 1)) :ah)))
+ (,prefixes :movb (:ebx :ecx ,(offset-by 1)) :ah)))
(t (let ((object-var (gensym "memref-object-")))
`(let ((,object-var ,object))
(with-inline-assembly (:returns :eax)
@@ -271,19 +273,19 @@
(:movb ,(movitz:tag :character) :al)
(:load-lexical (:lexical-binding ,object-var) :ebx)
(:sarl ,movitz::+movitz-fixnum-shift+ :ecx) ; scale offset+index
- (:movb (:ebx :ecx ,(offset-by 1)) :ah)))))))
+ (,prefixes :movb (:ebx :ecx ,(offset-by 1)) :ah)))))))
(:location
(assert (= 4 movitz::+movitz-fixnum-factor+))
(cond
((and (eq 0 offset) (eq 0 index))
`(with-inline-assembly (:returns :ecx :type (signed-byte 30))
(:compile-form (:result-mode :eax) ,object)
- (:movl (:eax ,(offset-by 4)) :ecx)
+ (,prefixes :movl (:eax ,(offset-by 4)) :ecx)
(:andl -4 :ecx)))
((eq 0 offset)
`(with-inline-assembly (:returns :ecx :type (signed-byte 30))
(:compile-two-forms (:eax :ecx) ,object ,index)
- (:movl (:eax :ecx ,(offset-by 4)) :ecx)
+ (,prefixes :movl (:eax :ecx ,(offset-by 4)) :ecx)
(:andl -4 :ecx)))
(t (let ((object-var (gensym "memref-object-")))
`(let ((,object-var ,object))
@@ -292,7 +294,7 @@
(:sarl ,movitz::+movitz-fixnum-shift+ :ecx)
(:load-lexical (:lexical-binding ,object-var) :eax)
(:addl :ebx :ecx)
- (:movl (:eax :ecx ,(offset-by 4)) :ecx)
+ (,prefixes :movl (:eax :ecx ,(offset-by 4)) :ecx)
(:andl -4 :ecx)))))))
(:tag
(assert (= 4 movitz::+movitz-fixnum-factor+))
@@ -300,12 +302,12 @@
((and (eq 0 offset) (eq 0 index))
`(with-inline-assembly (:returns :untagged-fixnum-ecx :type (unsigned-byte 3))
(:compile-form (:result-mode :eax) ,object)
- (:movl (:eax ,(offset-by 4)) :ecx)
+ (,prefixes :movl (:eax ,(offset-by 4)) :ecx)
(:andl 7 :ecx)))
((eq 0 offset)
`(with-inline-assembly (:returns :untagged-fixnum-ecx :type (unsigned-byte 3))
(:compile-two-forms (:eax :ecx) ,object ,index)
- (:movl (:eax :ecx ,(offset-by 4)) :ecx)
+ (,prefixes :movl (:eax :ecx ,(offset-by 4)) :ecx)
(:andl 7 :ecx)))
(t (let ((object-var (gensym "memref-object-")))
`(let ((,object-var ,object))
@@ -314,39 +316,36 @@
(:sarl ,movitz::+movitz-fixnum-shift+ :ecx)
(:load-lexical (:lexical-binding ,object-var) :eax)
(:addl :ebx :ecx)
- (:movl (:eax :ecx ,(offset-by 4)) :ecx)
+ (,prefixes :movl (:eax :ecx ,(offset-by 4)) :ecx)
(:andl 7 :ecx)))))))
(:unsigned-byte32
- (let ((prefixes (if (not physicalp)
- ()
- movitz:*compiler-physical-segment-prefix*))
- (fix-endian (ecase (movitz:movitz-eval endian env)
+ (let ((fix-endian (ecase (movitz:movitz-eval endian env)
((:host :little) ())
(:big `((:bswap :ecx))))))
(assert (= 4 movitz::+movitz-fixnum-factor+))
(cond
- ((and (eq 0 offset) (eq 0 index))
- `(with-inline-assembly (:returns :untagged-fixnum-ecx
- :type (unsigned-byte 32))
- (:compile-form (:result-mode :eax) ,object)
- (,prefixes :movl (:eax ,(offset-by 4)) :ecx)
- , at fix-endian))
- ((eq 0 offset)
- `(with-inline-assembly (:returns :untagged-fixnum-ecx
- :type (unsigned-byte 32))
- (:compile-two-forms (:eax :ecx) ,object ,index)
- (,prefixes :movl (:eax :ecx ,(offset-by 4)) :ecx)
- , at fix-endian))
- (t (let ((object-var (gensym "memref-object-")))
- `(let ((,object-var ,object))
- (with-inline-assembly (:returns :untagged-fixnum-ecx
- :type (unsigned-byte 32))
- (:compile-two-forms (:ecx :ebx) ,offset ,index)
- (:sarl ,movitz::+movitz-fixnum-shift+ :ecx)
- (:load-lexical (:lexical-binding ,object-var) :eax)
- (:addl :ebx :ecx)
- (,prefixes :movl (:eax :ecx ,(offset-by 4)) :ecx)
- , at fix-endian)))))))
+ ((and (eq 0 offset) (eq 0 index))
+ `(with-inline-assembly (:returns :untagged-fixnum-ecx
+ :type (unsigned-byte 32))
+ (:compile-form (:result-mode :eax) ,object)
+ (,prefixes :movl (:eax ,(offset-by 4)) :ecx)
+ , at fix-endian))
+ ((eq 0 offset)
+ `(with-inline-assembly (:returns :untagged-fixnum-ecx
+ :type (unsigned-byte 32))
+ (:compile-two-forms (:eax :ecx) ,object ,index)
+ (,prefixes :movl (:eax :ecx ,(offset-by 4)) :ecx)
+ , at fix-endian))
+ (t (let ((object-var (gensym "memref-object-")))
+ `(let ((,object-var ,object))
+ (with-inline-assembly (:returns :untagged-fixnum-ecx
+ :type (unsigned-byte 32))
+ (:compile-two-forms (:ecx :ebx) ,offset ,index)
+ (:sarl ,movitz::+movitz-fixnum-shift+ :ecx)
+ (:load-lexical (:lexical-binding ,object-var) :eax)
+ (:addl :ebx :ecx)
+ (,prefixes :movl (:eax :ecx ,(offset-by 4)) :ecx)
+ , at fix-endian)))))))
(:lisp
(let* ((localp (movitz:movitz-eval localp env))
(prefixes (if localp
@@ -433,469 +432,488 @@
form))))))))
(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))))
+ (case type
+ (:lisp
+ (if localp
+ (memref object offset :index index :localp t)
+ (memref object offset :index index :localp nil)))
+ (:code-vector
+ (memref object offset :index index :type :code-vector))
+ (t (macrolet
+ ((do-memref (physicalp)
+ `(ecase type
+
+ (: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))))
+
+ (: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))
+(define-compiler-macro (setf memref)
+ (&whole form &environment env value object offset
+ &key (index 0) (type :lisp) (localp nil) (endian :host) (physicalp nil))
(if (or (not (movitz:movitz-constantp type env))
(not (movitz:movitz-constantp localp env))
- (not (movitz:movitz-constantp endian env)))
+ (not (movitz:movitz-constantp endian env))
+ (not (movitz:movitz-constantp physicalp env)))
form
- (multiple-value-bind (constant-index xindex)
- (extract-constant-delta index env)
- (multiple-value-bind (constant-offset xoffset)
- (extract-constant-delta offset env)
- (flet ((offset-by (element-size)
- (+ constant-offset (* constant-index element-size))))
- (case (movitz::movitz-eval type env)
- (:character
- (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::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
- (let ((endian (ecase (movitz:movitz-eval endian env)
- ((:host :little) :little)
- (:big :big))))
- (assert (= 4 movitz::+movitz-fixnum-factor+))
- (cond
- ((and (movitz:movitz-constantp value env)
- (movitz:movitz-constantp offset env)
- (movitz:movitz-constantp index env))
[805 lines skipped]
More information about the Movitz-cvs
mailing list