Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv9220
Modified Files: memref.lisp Log Message: Fix (setf memref-int :type :unsigned-byte32), which was quite buggy, as reported by mxb.
--- /project/movitz/cvsroot/movitz/losp/muerte/memref.lisp 2007/04/13 23:19:57 1.49 +++ /project/movitz/cvsroot/movitz/losp/muerte/memref.lisp 2008/01/13 22:27:10 1.50 @@ -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.49 2007/04/13 23:19:57 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.50 2008/01/13 22:27:10 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------
@@ -998,109 +998,127 @@
(define-compiler-macro (setf memref-int) (&whole form value address &key (offset 0) (index 0) (type :type) (physicalp t) - &environment env) + &environment env) (if (or (not (movitz:movitz-constantp type env)) (not (movitz:movitz-constantp physicalp env))) (progn (warn "setf memref-int form: ~S, ~S ~S" form type physicalp) form) - (let* ((physicalp (movitz::eval-form physicalp env)) - (prefixes (if (not physicalp) - () - movitz:*compiler-physical-segment-prefix*))) - (ecase type - (:unsigned-byte32 - (assert (= 4 movitz:+movitz-fixnum-factor+)) - (if (not (movitz:movitz-constantp offset env)) - form - (let ((offset (movitz:movitz-eval offset env)) - (addr-var (gensym "memref-int-address-")) - (value-var (gensym "memref-int-value-"))) - `(let ((,value-var ,value) - (,addr-var (+ ,address ,index))) - (with-inline-assembly (:returns :untagged-fixnum-ecx) - (:compile-form (:result-mode :untagged-fixnum-ecx) ,addr-var) - (:testb ,(logior movitz:+movitz-fixnum-zmask+ - (* 3 movitz:+movitz-fixnum-factor+)) - :cl) - (:jnz '(:sub-program () (:int 70))) - (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) ; a fixnum (zerop (mod x 4)) shifted - (:pushl :ecx) ; ..twice left is still a fixnum! - (:compile-form (:result-mode :untagged-fixnum-ecx) ,value-var) - (:popl :eax) - (:movl :ecx (:eax ,offset))))))) - (:lisp - (assert (= 4 movitz:+movitz-fixnum-factor+)) - `(with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :push) ,address) - (:compile-form (:result-mode :push) ,index) - (:compile-form (:result-mode :push) ,offset) - (:compile-form (:result-mode :eax) ,value) - (:popl :edx) ; offset - (:popl :ebx) ; index - (:popl :ecx) ; address - (:addl :edx :ecx) - (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) - (,prefixes :movl :eax (:ecx :ebx)))) - (:unsigned-byte8 - (let ((address-var (gensym "memref-int-address-")) - (index-var (gensym "memref-int-index-var-")) - (offset-var (gensym "memref-int-offset-var-")) - (value-var (gensym "memref-int-value-var-"))) - `(let ((,value-var ,value) - (,address-var ,address) - (,offset-var (+ ,index ,offset))) - (with-inline-assembly (:returns :nothing) - (:load-lexical (:lexical-binding ,address-var) :ecx) - (:load-lexical (:lexical-binding ,offset-var) :edx) - (:load-lexical (:lexical-binding ,value-var) :eax) - (:shll ,(- 8 movitz::+movitz-fixnum-shift+) :eax) - (:addl :edx :ecx) - (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) - (,prefixes :movb :ah (:ecx))) - ,value-var))) - (:unsigned-byte16 - (cond - ((eq 0 offset) + (let* ((physicalp (movitz::eval-form physicalp env)) + (prefixes (if (not physicalp) + () + movitz:*compiler-physical-segment-prefix*))) + (ecase type + (:unsigned-byte32 + (assert (= 4 movitz:+movitz-fixnum-factor+)) + (cond + ((movitz:movitz-constantp offset env) + (let ((offset (movitz:movitz-eval offset env)) + (addr-var (gensym "memref-int-address-")) + (value-var (gensym "memref-int-value-"))) + `(let ((,value-var ,value) + (,addr-var (+ ,address ,index))) + (with-inline-assembly (:returns :untagged-fixnum-ecx) + (:compile-form (:result-mode :untagged-fixnum-ecx) ,addr-var) + (:testb ,movitz:+movitz-fixnum-zmask+ + :cl) + (:jnz '(:sub-program () (:int 70))) + (: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)))))) + (t (let ((offset-var (gensym "memref-int-offset-")) + (addr-var (gensym "memref-int-address-")) + (value-var (gensym "memref-int-value-"))) + `(let ((,offset-var ,offset) + (,value-var ,value) + (,addr-var (+ ,address ,offset ,index))) + (with-inline-assembly (:returns :untagged-fixnum-ecx) + (:compile-form (:result-mode :untagged-fixnum-ecx) ,addr-var) + (:testb ,movitz:+movitz-fixnum-zmask+ + :cl) + (:jnz '(:sub-program () (:int 70))) + (:pushl :ecx) ; an untagged integer (zerop (mod x 4)) is still GC-safe. + (:compile-form (:result-mode :untagged-fixnum-ecx) ,value-var) + (:popl :eax) + (:compile-form (:result-mode :edx) ,offset-var) + (:std) + (:shrl ,movitz:+movitz-fixnum-shift+ :edx) + (:movl :ecx (:eax :edx)) + (:movl :edi :edx) ; make EDX GC-safe + (:cld))))))) + (:lisp + (assert (= 4 movitz:+movitz-fixnum-factor+)) + `(with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :push) ,address) + (:compile-form (:result-mode :push) ,index) + (:compile-form (:result-mode :push) ,offset) + (:compile-form (:result-mode :eax) ,value) + (:popl :edx) ; offset + (:popl :ebx) ; index + (:popl :ecx) ; address + (:addl :edx :ecx) + (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) + (,prefixes :movl :eax (:ecx :ebx)))) + (:unsigned-byte8 (let ((address-var (gensym "memref-int-address-")) - (index-var (gensym "memref-index-var-")) - (value-var (gensym "memref-value-var-"))) + (index-var (gensym "memref-int-index-var-")) + (offset-var (gensym "memref-int-offset-var-")) + (value-var (gensym "memref-int-value-var-"))) `(let ((,value-var ,value) (,address-var ,address) - (,index-var ,index)) - (with-inline-assembly (:returns :eax) - (:load-lexical (:lexical-binding ,value-var) :eax) ; value - (:load-lexical (:lexical-binding ,index-var) :ebx) ; index - (:load-lexical (:lexical-binding ,address-var) :ecx) ; address - (:shll 1 :ebx) ; scale index - (:addl :ebx :ecx) - (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) ; scale address - (:std) - (:shrl ,movitz:+movitz-fixnum-shift+ :eax) ; scale value - (,prefixes :movw :ax (:ecx)) - (:leal ((:eax ,movitz:+movitz-fixnum-factor+)) :eax) - (:cld))))) - (t (let ((address-var (gensym "memref-int-address-")) - (offset-var (gensym "memref-offset-var-")) - (index-var (gensym "memref-index-var-")) - (value-var (gensym "memref-value-var-"))) - `(let ((,value-var ,value) - (,address-var ,address) - (,offset-var ,offset) - (,index-var ,index)) - (with-inline-assembly (:returns :eax) - (:load-lexical (:lexical-binding ,address-var) :ecx) - (:load-lexical (:lexical-binding ,index-var) :ebx) - (:load-lexical (:lexical-binding ,offset-var) :edx) - (:load-lexical (:lexical-binding ,value-var) :eax) - (:leal (:ecx (:ebx 2)) :ecx) - (:addl :edx :ecx) ; - (:shrl ,movitz::+movitz-fixnum-shift+ :eax) ; scale value - (:std) - (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) ; scale offset+address - (,prefixes :movw :ax (:ecx)) - (:leal ((:eax ,movitz:+movitz-fixnum-factor+)) :eax) - (:cld))))))))))) + (,offset-var (+ ,index ,offset))) + (with-inline-assembly (:returns :nothing) + (:load-lexical (:lexical-binding ,address-var) :ecx) + (:load-lexical (:lexical-binding ,offset-var) :edx) + (:load-lexical (:lexical-binding ,value-var) :eax) + (:shll ,(- 8 movitz::+movitz-fixnum-shift+) :eax) + (:addl :edx :ecx) + (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) + (,prefixes :movb :ah (:ecx))) + ,value-var))) + (:unsigned-byte16 + (cond + ((eq 0 offset) + (let ((address-var (gensym "memref-int-address-")) + (index-var (gensym "memref-index-var-")) + (value-var (gensym "memref-value-var-"))) + `(let ((,value-var ,value) + (,address-var ,address) + (,index-var ,index)) + (with-inline-assembly (:returns :eax) + (:load-lexical (:lexical-binding ,value-var) :eax) ; value + (:load-lexical (:lexical-binding ,index-var) :ebx) ; index + (:load-lexical (:lexical-binding ,address-var) :ecx) ; address + (:shll 1 :ebx) ; scale index + (:addl :ebx :ecx) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) ; scale address + (:std) + (:shrl ,movitz:+movitz-fixnum-shift+ :eax) ; scale value + (,prefixes :movw :ax (:ecx)) + (:leal ((:eax ,movitz:+movitz-fixnum-factor+)) :eax) + (:cld))))) + (t (let ((address-var (gensym "memref-int-address-")) + (offset-var (gensym "memref-offset-var-")) + (index-var (gensym "memref-index-var-")) + (value-var (gensym "memref-value-var-"))) + `(let ((,value-var ,value) + (,address-var ,address) + (,offset-var ,offset) + (,index-var ,index)) + (with-inline-assembly (:returns :eax) + (:load-lexical (:lexical-binding ,address-var) :ecx) + (:load-lexical (:lexical-binding ,index-var) :ebx) + (:load-lexical (:lexical-binding ,offset-var) :edx) + (:load-lexical (:lexical-binding ,value-var) :eax) + (:leal (:ecx (:ebx 2)) :ecx) + (:addl :edx :ecx) ; + (:shrl ,movitz::+movitz-fixnum-shift+ :eax) ; scale value + (:std) + (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) ; scale offset+address + (,prefixes :movw :ax (:ecx)) + (:leal ((:eax ,movitz:+movitz-fixnum-factor+)) :eax) + (:cld)))))))))))
(defun (setf memref-int) (value address &key (offset 0) (index 0) (type :unsigned-byte32) (physicalp t))