Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv10917

Modified Files: memref.lisp Log Message: Various improvements to memref and (setf memref).

Date: Tue Apr 6 10:25:44 2004 Author: ffjeld

Index: movitz/losp/muerte/memref.lisp diff -u movitz/losp/muerte/memref.lisp:1.9 movitz/losp/muerte/memref.lisp:1.10 --- movitz/losp/muerte/memref.lisp:1.9 Wed Mar 31 21:13:27 2004 +++ movitz/losp/muerte/memref.lisp Tue Apr 6 10:25:44 2004 @@ -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.9 2004/04/01 02:13:27 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.10 2004/04/06 14:25:44 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------

@@ -21,30 +21,40 @@ (define-compiler-macro memref (&whole form object offset index type &environment env) (if (not (movitz:movitz-constantp type env)) form - (labels ((extract-constant-delta (form) - "Try to extract at compile-time an integer offset from form." - (cond - ((movitz:movitz-constantp form env) - (let ((x (movitz:movitz-eval form env))) - (check-type x integer) - (values x 0))) - ((not (consp form)) - (values 0 form)) - (t (case (car form) - (1+ (values 1 (second form))) - (1- (values -1 (second form))) - (+ (case (length form) - (1 (values 0 0)) - (2 (values 0 (second form))) - (t (loop with x = 0 and f = nil for sub-form in (cdr form) - as sub-value = (when (movitz:movitz-constantp sub-form env) - (movitz:movitz-eval sub-form env)) - do (if (integerp sub-value) - (incf x sub-value) - (push sub-form f)) - finally (return (values x (cons '+ (nreverse f)))))))) - (t #+ignore (warn "extract from: ~S" form) - (values 0 form))))))) + (labels ((sub-extract-constant-delta (form) + "Try to extract at compile-time an integer offset from form." + (cond + ((movitz:movitz-constantp form env) + (let ((x (movitz:movitz-eval form env))) + (check-type x integer) + (values x 0))) + ((not (consp form)) + (values 0 form)) + (t (case (car form) + (1+ (values 1 (second form))) + (1- (values -1 (second form))) + (+ (case (length form) + (1 (values 0 0)) + (2 (values 0 (second form))) + (t (loop with x = 0 and f = nil for sub-form in (cdr form) + as sub-value = (when (movitz:movitz-constantp sub-form env) + (movitz:movitz-eval sub-form env)) + do (if (integerp sub-value) + (incf x sub-value) + (push sub-form f)) + finally (return (values x (cons '+ (nreverse f)))))))) + (t #+ignore (warn "extract from: ~S" form) + (values 0 form)))))) + (extract-constant-delta (form) + "Try to extract at compile-time an integer offset from form, repeatedly." + (multiple-value-bind (constant-term variable-term) + (sub-extract-constant-delta form) + (if (= 0 constant-term) + (values 0 variable-term) + (multiple-value-bind (sub-constant-term sub-variable-term) + (extract-constant-delta variable-term) + (values (+ constant-term sub-constant-term) + sub-variable-term)))))) (multiple-value-bind (constant-index index) (extract-constant-delta index) (multiple-value-bind (constant-offset offset) @@ -189,7 +199,7 @@ `(let ((,object-var ,object)) (with-inline-assembly (:returns :eax) (:compile-two-forms (:ecx :ebx) ,offset ,index) - (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) (:load-lexical (:lexical-binding ,object-var) :eax) (:addl :ebx :ecx) (:movl (:eax :ecx ,(offset-by 4)) :eax))))))) @@ -259,7 +269,7 @@ (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)))))) + (* 4 (movitz:movitz-eval index env)))))) ,value))) ((and (movitz:movitz-constantp offset env) (movitz:movitz-constantp index env)) @@ -321,7 +331,7 @@ `(progn (with-inline-assembly (:returns :nothing) (:compile-two-forms (:ecx :ebx) ,index ,object) - (:shrl ,(1- movitz:+movitz-fixnum-shift+) :ecx) + (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx) (:movw ,value (:ebx :ecx ,(movitz:movitz-eval offset env)))) ,value))) ((movitz:movitz-constantp offset env) @@ -331,13 +341,13 @@ (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) + (:sarl ,(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) + (:sarl ,(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) @@ -397,7 +407,7 @@ `(progn (with-inline-assembly (:returns :untagged-fixnum-ecx) (:compile-two-forms (:eax :ecx) ,object ,index) - (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) (:movb ,value (:eax :ecx ,(movitz:movitz-eval offset env)))) value))) ((movitz:movitz-constantp offset env) @@ -406,7 +416,7 @@ (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) + (:sarl ,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)))