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@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) ,@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) ,@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) ,@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) ,@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) ,@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) ,@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) - ,@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) - ,@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) - ,@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) + ,@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) + ,@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) + ,@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]