Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory common-lisp.net:/tmp/cvs-serv28449
Modified Files:
memref.lisp
Log Message:
Clevered up (setf memref) quite a bit.
Date: Wed Mar 31 11:49:23 2004
Author: ffjeld
Index: movitz/losp/muerte/memref.lisp
diff -u movitz/losp/muerte/memref.lisp:1.5 movitz/losp/muerte/memref.lisp:1.6
--- movitz/losp/muerte/memref.lisp:1.5 Tue Mar 30 04:36:50 2004
+++ movitz/losp/muerte/memref.lisp Wed Mar 31 11:49:23 2004
@@ -10,7 +10,7 @@
;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org>
;;;; Created at: Tue Mar 6 21:25:49 2001
;;;;
-;;;; $Id: memref.lisp,v 1.5 2004/03/30 09:36:50 ffjeld Exp $
+;;;; $Id: memref.lisp,v 1.6 2004/03/31 16:49:23 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -184,67 +184,252 @@
(: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 value object offset index type)
- (if (not (movitz:movitz-constantp type))
+(define-compiler-macro (setf memref) (&whole form &environment env value object offset index type)
+ (if (not (movitz:movitz-constantp type env))
form
(case (movitz::eval-form type)
(:character
- `(with-inline-assembly (:returns :eax)
- (:compile-form (:result-mode :push) ,object)
- (:compile-form (:result-mode :push) ,offset)
- (:compile-two-forms (:ebx :eax) ,index ,value)
- (:popl :ecx) ; offset
- (:addl :ecx :ebx) ; index += offset
- (:sarl #.movitz::+movitz-fixnum-shift+ :ebx)
- (:popl :ecx) ; object
- (:movb :ah (:ebx :ecx))))
+ (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-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
(assert (= 4 movitz::+movitz-fixnum-factor+))
- `(with-inline-assembly (:returns :untagged-fixnum-eax)
- (:compile-form (:result-mode :push) ,object)
- (:compile-form (:result-mode :push) ,offset)
- (:compile-two-forms (:ebx :eax) ,index ,value)
- (:popl :ecx) ; offset
- (:shrl #.movitz::+movitz-fixnum-shift+ :eax)
- (:sarl #.movitz::+movitz-fixnum-shift+ :ecx)
- (:addl :ebx :ecx) ; index += offset
- (:popl :ebx) ; object
- (:movl :eax (:ebx :ecx))))
+ (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 32))
+ `(progn
+ (with-inline-assembly (:returns :nothing)
+ (:compile-form (:result-mode :ebx) ,object)
+ (:movl ,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 (:ecx :ebx) ,value ,object)
+ (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+ (:movl :ecx (:ebx ,(+ (movitz:movitz-eval offset env)
+ (* 4 (movitz:movitz-eval index env)))))))
+ ((and (movitz:movitz-constantp offset env)
+ (movitz:movitz-constantp value env))
+ (let ((value (movitz:movitz-eval value env)))
+ (check-type value (unsigned-byte 32))
+ `(progn
+ (with-inline-assembly (:returns :nothing)
+ (:compile-two-forms (:ecx :ebx) ,index ,object)
+ (:movl ,value (:ebx :ecx ,(movitz:movitz-eval offset env))))
+ ,value)))
+ ((movitz:movitz-constantp offset env)
+ (let ((value-var (gensym "memref-value-")))
+ `(let ((,value-var ,value))
+ (with-inline-assembly (:returns :untagged-fixnum-ecx)
+ (:compile-two-forms (:ebx :eax) ,object ,index)
+ (:load-lexical (:lexical-binding ,value-var) :ecx)
+ (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+ (:movl :ecx (:eax :ebx ,(movitz:movitz-eval offset env)))))))
+ (t (warn "Compiling unsafely: ~A" form)
+ `(with-inline-assembly (:returns :untagged-fixnum-eax)
+ (:compile-form (:result-mode :push) ,object)
+ (:compile-form (:result-mode :push) ,offset)
+ (:compile-two-forms (:ebx :eax) ,index ,value)
+ (:popl :ecx) ; offset
+ (:shrl #.movitz::+movitz-fixnum-shift+ :eax)
+ (:sarl #.movitz::+movitz-fixnum-shift+ :ecx)
+ (:addl :ebx :ecx) ; index += offset
+ (:popl :ebx) ; object
+ (:movl :eax (:ebx :ecx))))))
(:unsigned-byte16
- `(with-inline-assembly (:returns :untagged-fixnum-eax)
- (:compile-form (:result-mode :push) ,object)
- (:compile-form (:result-mode :push) ,offset)
- (:compile-two-forms (:ebx :eax) ,index ,value)
- (:sarl #.(cl:1- movitz::+movitz-fixnum-shift+) :ebx)
- (:popl :ecx) ; offset
- (:shrl #.movitz::+movitz-fixnum-shift+ :eax)
- (:sarl #.movitz::+movitz-fixnum-shift+ :ecx)
- (:addl :ebx :ecx) ; index += offset
- (:popl :ebx) ; object
- (:movw :ax (:ebx :ecx))))
+ (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 (:ecx :ebx) ,value ,object)
+ (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+ (: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)))
+ (check-type value (unsigned-byte 16))
+ `(progn
+ (with-inline-assembly (:returns :nothing)
+ (:compile-two-forms (:ecx :ebx) ,index ,object)
+ (:shrl ,(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-")))
+ (if (<= 16 movitz:*compiler-allow-untagged-word-bits*)
+ `(let ((,value-var ,value))
+ (with-inline-assembly (:returns :untagged-fixnum-eax)
+ (:compile-two-forms (:ebx :ecx) ,object ,index)
+ (:load-lexical (:lexical-binding ,value-var) :untagged-fixnum-eax)
+ (:shrl ,(1- movitz:+movitz-fixnum-shift+) :ecx)
+ (:movw :ax (:ebx :ecx ,(movitz:movitz-eval offset env)))))
+ `(let ((,value-var ,value))
+ (with-inline-assembly (:returns :nothing)
+ (:compile-two-forms (:ebx :ecx) ,object ,index)
+ (:load-lexical (:lexical-binding ,value-var) :eax)
+ (:shrl ,(1- movitz:+movitz-fixnum-shift+) :ecx)
+ (:shll ,(- 8 movitz:+movitz-fixnum-shift+) :eax)
+ (:movb :ah (:ebx :ecx ,(movitz:movitz-eval offset env)))
+ (:andl #xff0000 :eax)
+ (:shrl 8 :eax)
+ (:movb :ah (:ebx :ecx ,(1+ (movitz:movitz-eval offset env)))))
+ ,value-var))))
+ (t (let ((value-var (gensym "memref-value-"))
+ (object-var (gensym "memref-object-")))
+ (if (<= 16 movitz:*compiler-allow-untagged-word-bits*)
+ `(let ((,value-var ,offset) (,object-var ,object))
+ (with-inline-assembly (:returns :untagged-fixnum-eax)
+ (:compile-two-forms (:ebx :ecx) ,offset ,index)
+ (: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))
+ (with-inline-assembly (:returns :nothing)
+ (:compile-two-forms (:ebx :ecx) ,offset ,index)
+ (: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))))))
(:unsigned-byte8
- `(with-inline-assembly (:returns :untagged-fixnum-eax)
- (:compile-form (:result-mode :push) ,object)
- (:compile-form (:result-mode :push) ,offset)
- (:compile-two-forms (:ebx :eax) ,index ,value)
- (:shrl #.movitz::+movitz-fixnum-shift+ :eax)
- (:popl :ecx) ; offset
- (:addl :ecx :ebx) ; index += offset
- (:sarl #.movitz::+movitz-fixnum-shift+ :ebx)
- (:popl :ecx) ; object
- (:movb :al (:ebx :ecx))))
+ (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 8))
+ `(progn
+ (with-inline-assembly (:returns :nothing)
+ (:compile-form (:result-mode :ebx) ,object)
+ (:movb ,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 :untagged-fixnum-ecx)
+ (:compile-two-forms (:ecx :ebx) ,value ,object)
+ (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+ (:movb :cl (:ebx ,(+ (movitz:movitz-eval offset env)
+ (* 1 (movitz:movitz-eval index env)))))))
+ ((and (movitz:movitz-constantp offset env)
+ (movitz:movitz-constantp value env))
+ (let ((value (movitz:movitz-eval value env)))
+ (check-type value (unsigned-byte 8))
+ `(progn
+ (with-inline-assembly (:returns :untagged-fixnum-ecx)
+ (:compile-two-forms (:eax :ecx) ,object ,index)
+ (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+ (:movb ,value (:eax :ecx ,(movitz:movitz-eval offset env))))
+ value)))
+ ((movitz:movitz-constantp offset env)
+ (let ((value-var (gensym "memref-value-")))
+ `(let ((,value-var ,value))
+ (with-inline-assembly (:returns :nothing)
+ (:compile-two-forms (:ebx :ecx) ,object ,index)
+ (:load-lexical (:lexical-binding ,value-var) :eax)
+ (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+ (:shll ,(- 8 movitz:+movitz-fixnum-shift+) :eax) ; value into :AH
+ (:movb :ah (:ebx :ecx ,(movitz:movitz-eval offset env))))
+ ,value-var)))
+ (t (let ((value-var (gensym "memref-value-"))
+ (object-var (gensym "memref-object-")))
+ `(let ((,value-var ,value) (,object-var ,object))
+ (with-inline-assembly (:returns :nothing)
+ (:compile-two-forms (:ebx :ecx) ,offset ,index)
+ (:load-lexical (:lexical-binding ,value-var) :eax)
+ (:addl :ebx :ecx)
+ (:load-lexical (:lexical-binding ,object-var) :ebx) ; value into :AH
+ (:shll ,(- 8 movitz:+movitz-fixnum-shift+) :eax)
+ (:sarl ,movitz::+movitz-fixnum-shift+ :ecx)
+ (:movb :ah (:ebx :ecx)))
+ ,value-var)))))
(:lisp
- `(with-inline-assembly (:returns :eax)
- (:compile-form (:result-mode :push) ,object)
- (:compile-form (:result-mode :push) ,offset)
- (:compile-two-forms (:ebx :eax) ,index ,value)
- (:popl :ecx) ; offset
- (:sarl #.movitz::+movitz-fixnum-shift+ :ecx)
- ,@(when (cl:plusp (cl:- movitz::+movitz-fixnum-shift+ 2))
- `((:sarl ,(cl:- movitz::+movitz-fixnum-shift+ 2)) :ebx))
- (:addl :ecx :ebx) ; index += offset
- (:popl :ecx) ; value
- (:movl :eax (:ebx :ecx))))
+ (cond
+ ((and (movitz:movitz-constantp offset env)
+ (movitz:movitz-constantp index env))
+ `(with-inline-assembly (:returns :eax)
+ (:compile-two-forms (:eax :ebx) ,value ,object)
+ (:movl :eax (:ebx ,(+ (movitz:movitz-eval offset env)
+ (* 4 (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 :ecx) ,object ,index)
+ (:load-lexical (:lexical-binding ,value-var) :eax)
+ ,@(when (plusp (- movitz:+movitz-fixnum-shift+ 2))
+ `((:sarl ,(- movitz:+movitz-fixnum-shift+ 2)) :ecx))
+ (:movl :eax (:ebx :ecx ,(movitz:movitz-eval offset env)))))))
+ (t (let ((value-var (gensym "memref-value-"))
+ (object-var (gensym "memref-object-")))
+ `(let ((,value-var ,value) (,object-var ,object))
+ (with-inline-assembly (:returns :eax)
+ (:compile-two-forms (:untagged-fixnum-ecx :ebx) ,offset ,index)
+ (:load-lexical (:lexical-binding ,value-var) :eax)
+ ,@(when (cl:plusp (cl:- movitz::+movitz-fixnum-shift+ 2))
+ `((:sarl ,(cl:- movitz::+movitz-fixnum-shift+ 2)) :ebx))
+ (:addl :ebx :ecx) ; index += offset
+ (:load-lexical (:lexical-binding ,object-var) :ebx)
+ (:movl :eax (:ebx :ecx))))))))
(t ;; (warn "Can't handle inline MEMREF: ~S" form)
form))))
