[movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp
Frode Vatvedt Fjeld
ffjeld at common-lisp.net
Tue Apr 6 14:25:44 UTC 2004
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 at 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)))
More information about the Movitz-cvs
mailing list