- movitz-cvs@common-lisp.net - mailman3.common-lisp.net

[movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp
by ffjeld＠common-lisp.net 21 May '05

21 May '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv4874 Modified Files: memref.lisp Log Message: *** empty log message *** Date: Sun May 22 00:37:32 2005 Author: ffjeld Index: movitz/losp/muerte/memref.lisp diff -u movitz/losp/muerte/memref.lisp:1.45 movitz/losp/muerte/memref.lisp:1.46 --- movitz/losp/muerte/memref.lisp:1.45 Fri Apr 15 09:03:47 2005 +++ movitz/losp/muerte/memref.lisp Sun May 22 00:37:32 2005 @@ -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.45 2005/04/15 07:03:47 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.46 2005/05/21 22:37:32 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -18,15 +18,9 @@ (in-package muerte) -(define-compiler-macro memref (&whole form object offset - &key (index 0) (type :lisp) (localp nil) (endian :host) - (physicalp nil) - &environment env) - (if (or (not (movitz:movitz-constantp type env)) - (not (movitz:movitz-constantp localp env)) - (not (movitz:movitz-constantp endian env)) - (not (movitz:movitz-constantp physicalp env))) - form +(eval-when (:compile-toplevel) + (defun extract-constant-delta (form env) + "Try to extract at compile-time an integer offset from form, repeatedly." (labels ((sub-extract-constant-delta (form) "Try to extract at compile-time an integer offset from form." (cond @@ -49,369 +43,329 @@ (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) - (extract-constant-delta offset) - (flet ((offset-by (element-size) - (+ constant-offset (* constant-index element-size)))) - #+ignore - (warn "o: ~S, co: ~S, i: ~S, ci: ~S" - 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))) - (warn "(memref physicalp) unsupported for type ~S." type)) - (case type - (:unsigned-byte8 + (t (values 0 form))))))) + (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 env) + (values (+ constant-term sub-constant-term) + sub-variable-term))))))) + +(define-compiler-macro memref (&whole form object offset + &key (index 0) (type :lisp) (localp nil) (endian :host) + (physicalp nil) + &environment env) + (if (or (not (movitz:movitz-constantp type env)) + (not (movitz:movitz-constantp localp env)) + (not (movitz:movitz-constantp endian env)) + (not (movitz:movitz-constantp physicalp env))) + form + (multiple-value-bind (constant-index index) + (extract-constant-delta index env) + (multiple-value-bind (constant-offset offset) + (extract-constant-delta offset env) + (flet ((offset-by (element-size) + (+ constant-offset (* constant-index element-size)))) + #+ignore + (warn "o: ~S, co: ~S, i: ~S, ci: ~S" + 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))) + (warn "(memref physicalp) unsupported for type ~S." type)) + (case type + (:unsigned-byte8 + (cond + ((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))) + ((eql 0 index) + (let ((object-var (gensym "memref-object-")) + (offset-var (gensym "memref-offset-"))) + `(let ((,object-var ,object) + (,offset-var ,offset)) + (with-inline-assembly (:returns :untagged-fixnum-ecx + :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) + )))) + ((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))) + (t (let ((object-var (gensym "memref-object-"))) + `(let ((,object-var ,object)) + (with-inline-assembly (:returns :untagged-fixnum-ecx :type (unsigned-byte 8)) + (:compile-two-forms (:ecx :ebx) ,offset ,index) + (: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))))))) + (:unsigned-byte16 + (let* ((endian (ecase (movitz:movitz-eval endian env) + ((:host :little) :little) + (:big :big))) + (endian-fix-ecx (ecase endian + (:little nil) + (:big `((:xchgb :cl :ch)))))) (cond ((and (eql 0 offset) (eql 0 index)) - `(with-inline-assembly (:returns :untagged-fixnum-ecx :type (unsigned-byte 8)) + `(with-inline-assembly (:returns :untagged-fixnum-ecx + :type (unsigned-byte 16)) (:compile-form (:result-mode :eax) ,object) - (:movzxb (:eax ,(offset-by 1)) :ecx))) + (:movzxw (:eax ,(offset-by 2)) :ecx) + ,@endian-fix-ecx)) ((eql 0 index) (let ((object-var (gensym "memref-object-")) (offset-var (gensym "memref-offset-"))) `(let ((,object-var ,object) (,offset-var ,offset)) (with-inline-assembly (:returns :untagged-fixnum-ecx - :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) - )))) + :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) + ,@endian-fix-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))) - (t (let ((object-var (gensym "memref-object-"))) - `(let ((,object-var ,object)) - (with-inline-assembly (:returns :untagged-fixnum-ecx :type (unsigned-byte 8)) - (:compile-two-forms (:ecx :ebx) ,offset ,index) - (: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))))))) - (:unsigned-byte16 - (let* ((endian (ecase (movitz:movitz-eval endian env) - ((:host :little) :little) - (:big :big))) - (endian-fix-ecx (ecase endian - (:little nil) - (:big `((:xchgb :cl :ch)))))) - (cond - ((and (eql 0 offset) (eql 0 index)) - `(with-inline-assembly (:returns :untagged-fixnum-ecx - :type (unsigned-byte 16)) - (:compile-form (:result-mode :eax) ,object) - (:movzxw (:eax ,(offset-by 2)) :ecx) - ,@endian-fix-ecx)) - ((eql 0 index) - (let ((object-var (gensym "memref-object-")) - (offset-var (gensym "memref-offset-"))) - `(let ((,object-var ,object) - (,offset-var ,offset)) - (with-inline-assembly (:returns :untagged-fixnum-ecx - :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) - ,@endian-fix-ecx)))) - ((eql 0 offset) - (let ((object-var (gensym "memref-object-")) - (index-var (gensym "memref-index-"))) - `(let ((,object-var ,object) - (,index-var ,index)) - (with-inline-assembly (:returns :untagged-fixnum-ecx - :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) - ,@endian-fix-ecx)))) - (t (let ((object-var (gensym "memref-object-")) - (offset-var (gensym "memref-offset-")) - (index-var (gensym "memref-index-"))) - `(let ((,object-var ,object) - (,offset-var ,offset) - (,index-var ,index)) - (with-inline-assembly (:returns :untagged-fixnum-ecx - :type (unsigned-byte 16)) - (:compile-two-forms (:ecx :ebx) ,offset-var ,index-var) - (: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) - ,@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) - (:testb ,movitz:+movitz-fixnum-zmask+ :cl) - (:jnz '(:sub-program () (:int 63))))) - ((eq 0 offset) (let ((object-var (gensym "memref-object-")) (index-var (gensym "memref-index-"))) `(let ((,object-var ,object) (,index-var ,index)) - (with-inline-assembly (:returns :ecx) + (with-inline-assembly (:returns :untagged-fixnum-ecx + :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) - (:testb ,movitz:+movitz-fixnum-zmask+ :cl) - (:jnz '(:sub-program () (:int 63))))))) + ,@endian-fix-ecx)))) (t (let ((object-var (gensym "memref-object-")) (offset-var (gensym "memref-offset-")) (index-var (gensym "memref-index-"))) `(let ((,object-var ,object) (,offset-var ,offset) (,index-var ,index)) - (with-inline-assembly (:returns :ecx) + (with-inline-assembly (:returns :untagged-fixnum-ecx + :type (unsigned-byte 16)) (:compile-two-forms (:ecx :ebx) ,offset-var ,index-var) (: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) - (:testb ,movitz:+movitz-fixnum-shift+ :cl) - (:jnz '(:sub-program () (:int 63))))))))) - (:unsigned-byte29+3 - ;; Two values: the 29 upper bits as unsigned integer, - ;; and secondly the lower 3 bits as unsigned. - (assert (= 2 movitz::+movitz-fixnum-shift+)) - `(with-inline-assembly (:returns :multiple-values) - (:compile-form (:result-mode :push) ,object) - (:compile-two-forms (:ecx :ebx) ,offset ,index) - (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) - (:addl :ebx :ecx) - (:popl :eax) ; object - (:movl (:eax :ecx ,(offset-by 4)) :ecx) - (:leal ((:ecx 4)) :ebx) - (:shrl 1 :ecx) - (:andl #b11100 :ebx) - (:andl -4 :ecx) - (:movl :ecx :eax) - (:movl 2 :ecx) - (:stc))) - (:signed-byte30+2 - ;; Two values: the 30 upper bits as signed integer, - ;; and secondly the lower 2 bits as unsigned. - (assert (= 2 movitz::+movitz-fixnum-shift+)) - (let ((fix-ecx `((:leal ((:ecx 4)) :ebx) - (:andl -4 :ecx) - (:andl #b1100 :ebx) - (:movl :ecx :eax) - (:movl 2 :ecx) - (:stc)))) - (cond - ((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) - ,@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) - ,@fix-ecx)) - (t (let ((object-var (gensym "memref-object-"))) - `(let ((,object-var ,object)) - (with-inline-assembly (:returns :multiple-values) - (:compile-two-forms (:ecx :ebx) ,offset ,index) - (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) - (:load-lexical (:lexical-binding ,object-var) :eax) - (:addl :ebx :ecx) - (:movl (:eax :ecx ,(offset-by 4)) :ecx) - ,@fix-ecx)))))) - #+ignore - `(with-inline-assembly (:returns :multiple-values) - (:compile-form (:result-mode :push) ,object) - (:compile-two-forms (:ecx :ebx) ,offset ,index) - (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) - (:addl :ebx :ecx) - (:popl :eax) ; object - (:movl (:eax :ecx ,(offset-by 4)) :ecx) - (:leal ((:ecx 4)) :ebx) - (:andl #b1100 :ebx) - (:andl -4 :ecx) - (:movl :ecx :eax) - (:movl 2 :ecx) - (:stc))) - (:character - (when (eq 0 index) (warn "memref zero char index!")) - (cond - ((eq 0 offset) - `(with-inline-assembly (:returns :eax) - (:compile-two-forms (:ebx :ecx) ,object ,index) - (:xorl :eax :eax) - (:movb ,(movitz:tag :character) :al) - (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) ; scale index - (:movb (:ebx :ecx ,(offset-by 1)) :ah))) - (t (let ((object-var (gensym "memref-object-"))) - `(let ((,object-var ,object)) - (with-inline-assembly (:returns :eax) - (:compile-two-forms (:ecx :ebx) ,offset ,index) - (:addl :ebx :ecx) - (:xorl :eax :eax) - (: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))))))) - (:location - (assert (= 4 movitz::+movitz-fixnum-factor+)) + ,@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) + (:testb ,movitz:+movitz-fixnum-zmask+ :cl) + (:jnz '(:sub-program () (:int 63))))) + ((eq 0 offset) + (let ((object-var (gensym "memref-object-")) + (index-var (gensym "memref-index-"))) + `(let ((,object-var ,object) + (,index-var ,index)) + (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) + (:testb ,movitz:+movitz-fixnum-zmask+ :cl) + (:jnz '(:sub-program () (:int 63))))))) + (t (let ((object-var (gensym "memref-object-")) + (offset-var (gensym "memref-offset-")) + (index-var (gensym "memref-index-"))) + `(let ((,object-var ,object) + (,offset-var ,offset) + (,index-var ,index)) + (with-inline-assembly (:returns :ecx) + (:compile-two-forms (:ecx :ebx) ,offset-var ,index-var) + (: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) + (:testb ,movitz:+movitz-fixnum-shift+ :cl) + (:jnz '(:sub-program () (:int 63))))))))) + (:unsigned-byte29+3 + ;; Two values: the 29 upper bits as unsigned integer, + ;; and secondly the lower 3 bits as unsigned. + (assert (= 2 movitz::+movitz-fixnum-shift+)) + `(with-inline-assembly (:returns :multiple-values) + (:compile-form (:result-mode :push) ,object) + (:compile-two-forms (:ecx :ebx) ,offset ,index) + (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) + (:addl :ebx :ecx) + (:popl :eax) ; object + (:movl (:eax :ecx ,(offset-by 4)) :ecx) + (:leal ((:ecx 4)) :ebx) + (:shrl 1 :ecx) + (:andl #b11100 :ebx) + (:andl -4 :ecx) + (:movl :ecx :eax) + (:movl 2 :ecx) + (:stc))) + (:signed-byte30+2 + ;; Two values: the 30 upper bits as signed integer, + ;; and secondly the lower 2 bits as unsigned. + (assert (= 2 movitz::+movitz-fixnum-shift+)) + (let ((fix-ecx `((:leal ((:ecx 4)) :ebx) + (:andl -4 :ecx) + (:andl #b1100 :ebx) + (:movl :ecx :eax) + (:movl 2 :ecx) + (:stc)))) (cond ((and (eq 0 offset) (eq 0 index)) - `(with-inline-assembly (:returns :ecx :type (signed-byte 30)) + `(with-inline-assembly (:returns :multiple-values) (:compile-form (:result-mode :eax) ,object) (:movl (:eax ,(offset-by 4)) :ecx) - (:andl -4 :ecx))) + ,@fix-ecx)) ((eq 0 offset) - `(with-inline-assembly (:returns :ecx :type (signed-byte 30)) + `(with-inline-assembly (:returns :multiple-values) (:compile-two-forms (:eax :ecx) ,object ,index) (:movl (:eax :ecx ,(offset-by 4)) :ecx) - (:andl -4 :ecx))) + ,@fix-ecx)) (t (let ((object-var (gensym "memref-object-"))) `(let ((,object-var ,object)) - (with-inline-assembly (:returns :ecx :type (signed-byte 30)) + (with-inline-assembly (:returns :multiple-values) (:compile-two-forms (:ecx :ebx) ,offset ,index) (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) (:load-lexical (:lexical-binding ,object-var) :eax) (:addl :ebx :ecx) (:movl (:eax :ecx ,(offset-by 4)) :ecx) - (:andl -4 :ecx))))))) - (:tag + ,@fix-ecx)))))) + #+ignore + `(with-inline-assembly (:returns :multiple-values) + (:compile-form (:result-mode :push) ,object) + (:compile-two-forms (:ecx :ebx) ,offset ,index) + (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) + (:addl :ebx :ecx) + (:popl :eax) ; object + (:movl (:eax :ecx ,(offset-by 4)) :ecx) + (:leal ((:ecx 4)) :ebx) + (:andl #b1100 :ebx) + (:andl -4 :ecx) + (:movl :ecx :eax) + (:movl 2 :ecx) + (:stc))) + (:character + (when (eq 0 index) (warn "memref zero char index!")) + (cond + ((eq 0 offset) + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:ebx :ecx) ,object ,index) + (:xorl :eax :eax) + (:movb ,(movitz:tag :character) :al) + (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) ; scale index + (:movb (:ebx :ecx ,(offset-by 1)) :ah))) + (t (let ((object-var (gensym "memref-object-"))) + `(let ((,object-var ,object)) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:ecx :ebx) ,offset ,index) + (:addl :ebx :ecx) + (:xorl :eax :eax) + (: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))))))) + (: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) + (: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) + (:andl -4 :ecx))) + (t (let ((object-var (gensym "memref-object-"))) + `(let ((,object-var ,object)) + (with-inline-assembly (:returns :ecx :type (signed-byte 30)) + (:compile-two-forms (:ecx :ebx) ,offset ,index) + (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) + (:load-lexical (:lexical-binding ,object-var) :eax) + (:addl :ebx :ecx) + (:movl (:eax :ecx ,(offset-by 4)) :ecx) + (:andl -4 :ecx))))))) + (:tag + (assert (= 4 movitz::+movitz-fixnum-factor+)) + (cond + ((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) + (: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) + (:andl 7 :ecx))) + (t (let ((object-var (gensym "memref-object-"))) + `(let ((,object-var ,object)) + (with-inline-assembly (:returns :untagged-fixnum-ecx :type (unsigned-byte 3)) + (:compile-two-forms (:ecx :ebx) ,offset ,index) + (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) + (:load-lexical (:lexical-binding ,object-var) :eax) + (:addl :ebx :ecx) + (: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) + ((: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 3)) + `(with-inline-assembly (:returns :untagged-fixnum-ecx + :type (unsigned-byte 32)) (:compile-form (:result-mode :eax) ,object) - (:movl (:eax ,(offset-by 4)) :ecx) - (:andl 7 :ecx))) + (,prefixes :movl (:eax ,(offset-by 4)) :ecx) + ,@fix-endian)) ((eq 0 offset) - `(with-inline-assembly (:returns :untagged-fixnum-ecx :type (unsigned-byte 3)) + `(with-inline-assembly (:returns :untagged-fixnum-ecx + :type (unsigned-byte 32)) (:compile-two-forms (:eax :ecx) ,object ,index) - (:movl (:eax :ecx ,(offset-by 4)) :ecx) - (:andl 7 :ecx))) + (,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 3)) + (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) - (:movl (:eax :ecx ,(offset-by 4)) :ecx) - (:andl 7 :ecx))))))) - (:unsigned-byte32 - (let ((endian (movitz:movitz-eval endian env)) - (prefixes (if (not physicalp) - () - movitz:*compiler-physical-segment-prefix*))) - (assert (member endian '(:host :little))) - (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))) - ((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))) - (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)))))))) - (:lisp - (let* ((localp (movitz:movitz-eval localp env)) - (prefixes (if localp - nil - movitz:*compiler-nonlocal-lispval-read-segment-prefix*))) - (cond - ((and (eql 0 index) (eql 0 offset)) - `(with-inline-assembly (:returns :register) - (:compile-form (:result-mode :register) ,object) - (,prefixes :movl ((:result-register) ,(offset-by 4)) (:result-register)))) - ((eql 0 offset) - `(with-inline-assembly (:returns :eax) - (:compile-two-forms (:eax :ecx) ,object ,index) - ,@(when (cl:plusp (cl:- movitz::+movitz-fixnum-shift+ 2)) - `((:sarl ,(cl:- movitz::+movitz-fixnum-shift+ 2)) :ecx)) - (,prefixes :movl (:eax :ecx ,(offset-by 4)) :eax))) - ((eql 0 index) - `(with-inline-assembly (:returns :eax) - (:compile-two-forms (:eax :untagged-fixnum-ecx) ,object ,offset) - (,prefixes :movl (:eax :ecx ,(offset-by 4)) :eax))) - (t (assert (not (movitz:movitz-constantp offset env))) - (assert (not (movitz:movitz-constantp index env))) - (let ((object-var (gensym "memref-object-"))) - (assert (= 4 movitz:+movitz-fixnum-factor+)) - `(let ((,object-var ,object)) - (with-inline-assembly (:returns :eax) - (: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)) :eax)))))))) - (:code-vector - ;; A code-vector is like a normal lisp word pointer, - ;; except it's known to point to a code-vector, and - ;; the pointer value is offset by 2. The trick is to - ;; perform this pointer arithmetics while never - ;; keeping a non-lisp-word pointer in a register. + (,prefixes :movl (:eax :ecx ,(offset-by 4)) :ecx) + ,@fix-endian))))))) + (:lisp + (let* ((localp (movitz:movitz-eval localp env)) + (prefixes (if localp + nil + movitz:*compiler-nonlocal-lispval-read-segment-prefix*))) (cond ((and (eql 0 index) (eql 0 offset)) - `(with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :ebx) ,object) - (:movl ,(ldb (byte 32 0) (- movitz:+code-vector-word-offset+)) :eax) - (:addl (:ebx ,(offset-by 4)) :eax))) + `(with-inline-assembly (:returns :register) + (:compile-form (:result-mode :register) ,object) + (,prefixes :movl ((:result-register) ,(offset-by 4)) (:result-register)))) ((eql 0 offset) `(with-inline-assembly (:returns :eax) - (:compile-two-forms (:ebx :ecx) ,object ,index) + (:compile-two-forms (:eax :ecx) ,object ,index) ,@(when (cl:plusp (cl:- movitz::+movitz-fixnum-shift+ 2)) `((:sarl ,(cl:- movitz::+movitz-fixnum-shift+ 2)) :ecx)) - (:movl ,(ldb (byte 32 0) (- movitz:+code-vector-word-offset+)) :eax) - (:addl (:ebx :ecx ,(offset-by 4)) :eax))) + (,prefixes :movl (:eax :ecx ,(offset-by 4)) :eax))) ((eql 0 index) `(with-inline-assembly (:returns :eax) - (:compile-two-forms (:ebx :untagged-fixnum-ecx) ,object ,offset) - (:movl ,(ldb (byte 32 0) (- movitz:+code-vector-word-offset+)) :eax) - (:addl (:ebx :ecx ,(offset-by 4)) :eax))) - (t (let ((object-var (gensym "memref-object-")) - (offset-var (gensym "memref-offset-")) - (index-var (gensym "memref-index-"))) - `(let ((,object-var ,object) - (,offset-var ,offset) - (,index-var ,index)) - (with-inline-assembly (:returns :eax) - (:load-lexical (:lexical-binding ,offset-var) :untagged-fixnum-ecx) - (:load-lexical (:lexical-binding ,object-var) :ebx) - (:load-lexical (:lexical-binding ,index-var) :edx) - (:addl :edx :ecx) - (:movl ,(ldb (byte 32 0) (- movitz:+code-vector-word-offset+)) :eax) - (:addl (:ebx :ecx ,(offset-by 4)) :eax))))) - #+ignore - (t (error "variable memref type :code-vector not implemented.")) - #+ignore + (:compile-two-forms (:eax :untagged-fixnum-ecx) ,object ,offset) + (,prefixes :movl (:eax :ecx ,(offset-by 4)) :eax))) (t (assert (not (movitz:movitz-constantp offset env))) (assert (not (movitz:movitz-constantp index env))) (let ((object-var (gensym "memref-object-"))) @@ -422,9 +376,60 @@ (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) (:load-lexical (:lexical-binding ,object-var) :eax) (:addl :ebx :ecx) - (:movl (:eax :ecx ,(offset-by 4)) :eax))))))) - (t (error "Unknown memref type: ~S" (movitz:movitz-eval type nil nil)) - form))))))))) + (,prefixes :movl (:eax :ecx ,(offset-by 4)) :eax)))))))) + (:code-vector + ;; A code-vector is like a normal lisp word pointer, + ;; except it's known to point to a code-vector, and + ;; the pointer value is offset by 2. The trick is to + ;; perform this pointer arithmetics while never + ;; keeping a non-lisp-word pointer in a register. + (cond + ((and (eql 0 index) (eql 0 offset)) + `(with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :ebx) ,object) + (:movl ,(ldb (byte 32 0) (- movitz:+code-vector-word-offset+)) :eax) + (:addl (:ebx ,(offset-by 4)) :eax))) + ((eql 0 offset) + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:ebx :ecx) ,object ,index) + ,@(when (cl:plusp (cl:- movitz::+movitz-fixnum-shift+ 2)) + `((:sarl ,(cl:- movitz::+movitz-fixnum-shift+ 2)) :ecx)) + (:movl ,(ldb (byte 32 0) (- movitz:+code-vector-word-offset+)) :eax) + (:addl (:ebx :ecx ,(offset-by 4)) :eax))) + ((eql 0 index) + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:ebx :untagged-fixnum-ecx) ,object ,offset) + (:movl ,(ldb (byte 32 0) (- movitz:+code-vector-word-offset+)) :eax) + (:addl (:ebx :ecx ,(offset-by 4)) :eax))) + (t (let ((object-var (gensym "memref-object-")) + (offset-var (gensym "memref-offset-")) + (index-var (gensym "memref-index-"))) + `(let ((,object-var ,object) + (,offset-var ,offset) + (,index-var ,index)) + (with-inline-assembly (:returns :eax) + (:load-lexical (:lexical-binding ,offset-var) :untagged-fixnum-ecx) + (:load-lexical (:lexical-binding ,object-var) :ebx) + (:load-lexical (:lexical-binding ,index-var) :edx) + (:addl :edx :ecx) + (:movl ,(ldb (byte 32 0) (- movitz:+code-vector-word-offset+)) :eax) + (:addl (:ebx :ecx ,(offset-by 4)) :eax))))) + #+ignore + (t (error "variable memref type :code-vector not implemented.")) + #+ignore + (t (assert (not (movitz:movitz-constantp offset env))) + (assert (not (movitz:movitz-constantp index env))) + (let ((object-var (gensym "memref-object-"))) + (assert (= 4 movitz:+movitz-fixnum-factor+)) + `(let ((,object-var ,object)) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:ecx :ebx) ,offset ,index) + (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) + (:load-lexical (:lexical-binding ,object-var) :eax) + (:addl :ebx :ecx) + (:movl (:eax :ecx ,(offset-by 4)) :eax))))))) + (t (error "Unknown memref type: ~S" (movitz:movitz-eval type nil nil)) + form)))))))) (defun memref (object offset &key (index 0) (type :lisp) localp (endian :host)) (ecase type @@ -451,374 +456,403 @@ (not (movitz:movitz-constantp localp env)) (not (movitz:movitz-constantp endian env))) form - (case (movitz::eval-form type) - (: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 (movitz:movitz-eval endian env))) - (assert (member endian '(:host :little)))) - (assert (= 4 movitz::+movitz-fixnum-factor+)) - (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) - (* 4 (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 (:untagged-fixnum-ecx :ebx) ,value ,object) - (: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-")) - (object-var (gensym "memref-object-")) - (index-var (gensym "memref-index-"))) - `(let ((,value-var ,value) - (,object-var ,object) - (,index-var ,index)) - (with-inline-assembly (:returns :untagged-fixnum-ecx) - (:load-lexical (:lexical-binding ,value-var) :untagged-fixnum-ecx) - (:compile-two-forms (:ebx :eax) ,object-var ,index-var) - (:movl :ecx (:eax :ebx ,(movitz:movitz-eval offset env))))))) - (t (let ((value-var (gensym "memref-value-")) - (object-var (gensym "memref-object-")) - (offset-var (gensym "memref-offset-")) - (index-var (gensym "memref-index-"))) - (assert (= 4 movitz:+movitz-fixnum-factor+)) - `(let ((,value-var ,value) - (,object-var ,object) - (,offset-var ,offset) - (,index-var ,index)) - (with-inline-assembly (:returns :untagged-fixnum-ecx) - (:load-lexical (:lexical-binding ,value-var) :eax) - (:call-global-pf unbox-u32) - (:compile-two-forms (:eax :edx) ,index-var ,offset-var) - (:load-lexical (:lexical-binding ,object-var) :ebx) - (:std) - (:sarl ,movitz::+movitz-fixnum-shift+ :edx) - (:addl :eax :edx) ; EDX = offset+index - (:movl :ecx (:ebx :edx)) - (:movl :edi :edx) - (:cld))))))) - (:unsigned-byte16 - (let ((endian (ecase (movitz:movitz-eval endian env) - ((:host :little) :little) - (:big :big)))) - (cond - ((and (movitz:movitz-constantp value env) - (movitz:movitz-constantp offset env) - (movitz:movitz-constantp index env)) - (let* ((host-value (movitz:movitz-eval value env)) - (value (ecase endian - (:little host-value) - (:big (dpb (ldb (byte 8 0) host-value) - (byte 8 8) - (ldb (byte 8 8) host-value)))))) - (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 (:untagged-fixnum-ecx :ebx) ,value ,object) - ,@(ecase endian - (:little nil) - (:big `((:xchg :cl :ch)))) - (: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)) - (index-var (gensym "memref-index-")) - (object-var (gensym "memref-object-"))) - (check-type value (unsigned-byte 16)) - `(let ((,object-var ,object) - (,index-var ,index)) - (with-inline-assembly (:returns :nothing) - (:compile-two-forms (:ecx :ebx) ,index-var ,object-var) - (:sarl ,(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-")) - (index-var (gensym "memref-index-")) - (object-var (gensym "memref-object-"))) - (if (<= 16 movitz:*compiler-allow-untagged-word-bits*) - `(let ((,value-var ,value) - (,object-var ,object) - (,index-var ,index)) - (with-inline-assembly (:returns :untagged-fixnum-eax) - (:compile-two-forms (:ebx :ecx) ,object-var ,index-var) - (:load-lexical (:lexical-binding ,value-var) :untagged-fixnum-eax) - (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx) - (:movw :ax (:ebx :ecx ,(movitz:movitz-eval offset env))))) - `(let ((,value-var ,value) - (,object-var ,object) - (,index-var ,index)) - (with-inline-assembly (:returns :nothing) - (:compile-two-forms (:ebx :ecx) ,object-var ,index-var) - (:load-lexical (:lexical-binding ,value-var) :eax) - (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx) - (:movl :edi :edx) - (:std) - (:shrl ,movitz:+movitz-fixnum-shift+ :eax) - ,@(ecase endian - (:little nil) - (:big `((:xchgb :al :ah)))) - (:movw :ax (:ebx :ecx ,(movitz:movitz-eval offset env))) - (:movl :edi :eax) - (:cld)) - ,value-var)))) - (t (let ((value-var (gensym "memref-value-")) - (object-var (gensym "memref-object-")) - (offset-var (gensym "memref-offset-")) - (index-var (gensym "memref-index-"))) - (if (<= 16 movitz:*compiler-allow-untagged-word-bits*) + (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)) + (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) + (* 4 (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 (:untagged-fixnum-ecx :ebx) ,value ,object) + ,@(when (eq endian :big) + `((:bswap :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)) + (let ((value (ecase endian + (:little value) + (:big (logior (ash (ldb (byte 8 0) value) 24) + (ash (ldb (byte 8 8) value) 16) + (ash (ldb (byte 8 16) value) 8) + (ash (ldb (byte 8 24) value) 0)))))) + `(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-")) + (object-var (gensym "memref-object-")) + (index-var (gensym "memref-index-"))) `(let ((,value-var ,value) (,object-var ,object) - (,offset-var ,offset) (,index-var ,index)) - (with-inline-assembly (:returns :untagged-fixnum-eax) - (:compile-two-forms (:ebx :ecx) ,offset-var ,index-var) - (: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)))) + (with-inline-assembly (:returns :untagged-fixnum-ecx) + (:load-lexical (:lexical-binding ,value-var) :untagged-fixnum-ecx) + (:compile-two-forms (:ebx :eax) ,object-var ,index-var) + ,@(when (eq endian :big) + `((:bswap :ecx))) + (:movl :ecx (:eax :ebx ,(movitz:movitz-eval offset env))))))) + (t (let ((value-var (gensym "memref-value-")) + (object-var (gensym "memref-object-")) + (offset-var (gensym "memref-offset-")) + (index-var (gensym "memref-index-"))) + (assert (= 4 movitz:+movitz-fixnum-factor+)) + `(let ((,value-var ,value) + (,object-var ,object) + (,offset-var ,offset) + (,index-var ,index)) + (with-inline-assembly (:returns :untagged-fixnum-ecx) + (:load-lexical (:lexical-binding ,value-var) :eax) + (:call-global-pf unbox-u32) + (:compile-two-forms (:eax :edx) ,index-var ,offset-var) + (:load-lexical (:lexical-binding ,object-var) :ebx) + ,@(when (eq endian :big) + `((:bswap :ecx))) + (:std) + (:sarl ,movitz::+movitz-fixnum-shift+ :edx) + (:addl :eax :edx) ; EDX = offset+index + (:movl :ecx (:ebx :edx)) + (:movl :edi :edx) + (:cld)))))))) + (:unsigned-byte16 + (let ((endian (ecase (movitz:movitz-eval endian env) + ((:host :little) :little) + (:big :big)))) + (cond + ((and (movitz:movitz-constantp value env) + (movitz:movitz-constantp offset env) + (movitz:movitz-constantp index env)) + (let* ((host-value (movitz:movitz-eval value env)) + (value (ecase endian + (:little host-value) + (:big (dpb (ldb (byte 8 0) host-value) + (byte 8 8) + (ldb (byte 8 8) host-value)))))) + (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 (:untagged-fixnum-ecx :ebx) ,value ,object) + ,@(ecase endian + (:little nil) + (:big `((:xchg :cl :ch)))) + (: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)) + (index-var (gensym "memref-index-")) + (object-var (gensym "memref-object-"))) + (check-type value (unsigned-byte 16)) + `(let ((,object-var ,object) + (,index-var ,index)) + (with-inline-assembly (:returns :nothing) + (:compile-two-forms (:ecx :ebx) ,index-var ,object-var) + (:sarl ,(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-")) + (index-var (gensym "memref-index-")) + (object-var (gensym "memref-object-"))) + (if (<= 16 movitz:*compiler-allow-untagged-word-bits*) + `(let ((,value-var ,value) + (,object-var ,object) + (,index-var ,index)) + (with-inline-assembly (:returns :untagged-fixnum-eax) + (:compile-two-forms (:ebx :ecx) ,object-var ,index-var) + (:load-lexical (:lexical-binding ,value-var) :untagged-fixnum-eax) + (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx) + (:movw :ax (:ebx :ecx ,(movitz:movitz-eval offset env))))) + `(let ((,value-var ,value) + (,object-var ,object) + (,index-var ,index)) + (with-inline-assembly (:returns :nothing) + (:compile-two-forms (:ebx :ecx) ,object-var ,index-var) + (:load-lexical (:lexical-binding ,value-var) :eax) + (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx) + (:movl :edi :edx) + (:std) + (:shrl ,movitz:+movitz-fixnum-shift+ :eax) + ,@(ecase endian + (:little nil) + (:big `((:xchgb :al :ah)))) + (:movw :ax (:ebx :ecx ,(movitz:movitz-eval offset env))) + (:movl :edi :eax) + (:cld)) + ,value-var)))) + (t (let ((value-var (gensym "memref-value-")) + (object-var (gensym "memref-object-")) + (offset-var (gensym "memref-offset-")) + (index-var (gensym "memref-index-"))) + (if (<= 16 movitz:*compiler-allow-untagged-word-bits*) + `(let ((,value-var ,value) + (,object-var ,object) + (,offset-var ,offset) + (,index-var ,index)) + (with-inline-assembly (:returns :untagged-fixnum-eax) + (:compile-two-forms (:ebx :ecx) ,offset-var ,index-var) + (: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) + (,offset-var ,offset) + (,index-var ,index)) + (with-inline-assembly (:returns :nothing) + (:compile-two-forms (:ebx :ecx) ,offset-var ,index-var) + (:load-lexical (:lexical-binding ,value-var) :eax) + (:leal (:ebx (:ecx 2)) :ecx) + (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) + (:load-lexical (:lexical-binding ,object-var) :ebx) + (:std) + (:shrl ,movitz:+movitz-fixnum-shift+ :eax) + ,@(ecase endian + (:little nil) + (:big `((:xchgb :al :ah)))) + (:movw :ax (:ebx :ecx)) + (:shll ,movitz:+movitz-fixnum-shift+ :eax) + (:movl :edi :edx) + (:cld)) + ,value-var))))))) + (:unsigned-byte8 + (cond + ((and (movitz:movitz-constantp value env) + (eql 0 xoffset) + (eql 0 xindex)) + (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 ,(offset-by 1)))) + ,value))) + ((eql 0 xindex) + (let ((value-var (gensym "memref-value-")) + (object-var (gensym "memref-object-")) + (offset-var (gensym "memref-offset-"))) `(let ((,value-var ,value) (,object-var ,object) - (,offset-var ,offset) - (,index-var ,index)) + (,offset-var ,xoffset)) (with-inline-assembly (:returns :nothing) - (:compile-two-forms (:ebx :ecx) ,offset-var ,index-var) + (:load-lexical (:lexical-binding ,offset-var) :untagged-fixnum-ecx) (:load-lexical (:lexical-binding ,value-var) :eax) - (:leal (:ebx (:ecx 2)) :ecx) - (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) (:load-lexical (:lexical-binding ,object-var) :ebx) - (:std) - (:shrl ,movitz:+movitz-fixnum-shift+ :eax) - ,@(ecase endian - (:little nil) - (:big `((:xchgb :al :ah)))) - (:movw :ax (:ebx :ecx)) - (:shll ,movitz:+movitz-fixnum-shift+ :eax) - (:movl :edi :edx) - (:cld)) - ,value-var))))))) - (:unsigned-byte8 - (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) - (:sarl ,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) - (: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))) - (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))))) - (:unsigned-byte14 - (cond - ((and (movitz:movitz-constantp offset env) - (movitz:movitz-constantp index env)) - `(with-inline-assembly (:returns :eax) - (:compile-two-forms (:eax :ebx) ,value ,object) - (:andl ,(mask-field (byte 14 2) -1) :eax) - (:movw :ax (: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)) - (:andl ,(mask-field (byte 14 2) -1) :eax) - (:movw :ax (: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) + (:shll ,(- 8 movitz:+movitz-fixnum-shift+) :eax) + (:movb :ah (:ebx :ecx ,(offset-by 1)))) + ,value-var))) + ((and (eql 0 xoffset) (eql 0 xindex)) + `(with-inline-assembly (:returns :untagged-fixnum-ecx) + (:compile-two-forms (:untagged-fixnum-ecx :ebx) ,value ,object) + (:movb :cl (:ebx ,(offset-by 1))))) + ((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) + (:sarl ,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) + (: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))) + (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))))) + (:unsigned-byte14 + (cond + ((and (movitz:movitz-constantp offset env) + (movitz:movitz-constantp index env)) + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) ,value ,object) (:andl ,(mask-field (byte 14 2) -1) :eax) - (:movl :ax (:ebx :ecx)))))))) - (:lisp - (let* ((localp (movitz:movitz-eval localp env)) - (prefixes (if localp - nil - movitz:*compiler-nonlocal-lispval-write-segment-prefix*))) - (cond - ((and (movitz:movitz-constantp offset env) - (movitz:movitz-constantp index env)) - `(with-inline-assembly (:returns :eax) - (:compile-two-forms (:eax :ebx) ,value ,object) - (,prefixes :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)) - (,prefixes :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) - (,prefixes :movl :eax (:ebx :ecx))))))))) - (:code-vector - (let ((prefixes (if localp - nil - movitz:*compiler-nonlocal-lispval-write-segment-prefix*))) - (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 ,movitz:+code-vector-word-offset+ - (:ebx ,(+ (movitz:movitz-eval offset env) - (* 4 (movitz:movitz-eval index env))))) - (,prefixes - :addl :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 ,movitz:+code-vector-word-offset+ - (:ebx :ecx ,(movitz:movitz-eval offset env))) - (,prefixes - :addl :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 ,movitz:+code-vector-word-offset+ (:ebx :ecx)) - (,prefixes :addl :eax (:ebx :ecx))))))))) - (t ;; (warn "Can't handle inline MEMREF: ~S" form) - form)))) + (:movw :ax (: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)) + (:andl ,(mask-field (byte 14 2) -1) :eax) + (:movw :ax (: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) + (:andl ,(mask-field (byte 14 2) -1) :eax) + (:movl :ax (:ebx :ecx)))))))) + (:lisp + (let* ((localp (movitz:movitz-eval localp env)) + (prefixes (if localp + nil + movitz:*compiler-nonlocal-lispval-write-segment-prefix*))) + (cond + ((and (movitz:movitz-constantp offset env) + (movitz:movitz-constantp index env)) + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) ,value ,object) + (,prefixes :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)) + (,prefixes :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) + (,prefixes :movl :eax (:ebx :ecx))))))))) + (:code-vector + (let ((prefixes (if localp + nil + movitz:*compiler-nonlocal-lispval-write-segment-prefix*))) + (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 ,movitz:+code-vector-word-offset+ + (:ebx ,(+ (movitz:movitz-eval offset env) + (* 4 (movitz:movitz-eval index env))))) + (,prefixes + :addl :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 ,movitz:+code-vector-word-offset+ + (:ebx :ecx ,(movitz:movitz-eval offset env))) + (,prefixes + :addl :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 ,movitz:+code-vector-word-offset+ (:ebx :ecx)) + (,prefixes :addl :eax (:ebx :ecx))))))))) + (t ;; (warn "Can't handle inline MEMREF: ~S" form) + form))))))) (defun (setf memref) (value object offset &key (index 0) (type :lisp) localp (endian :host)) (ecase type @@ -1165,3 +1199,34 @@ (defun %copy-words (destination source count &optional (start1 0) (start2 0)) (%copy-words destination source count start1 start2)) + +;; (define-compiler-macro memrange (object )) + +(defun memrange (object offset index length type) + (ecase type + (:unsigned-byte8 + (let ((vector (make-array length :element-type '(unsigned-byte 8)))) + (loop for i upfrom index as j upfrom 0 repeat length + do (setf (aref vector j) (memref object offset :index i :type :unsigned-byte8))) + vector)))) + +(defun (setf memrange) (value object offset index length type) + (ecase type + (:unsigned-byte8 + (etypecase value + ((unsigned-byte 8) + (loop for i upfrom index repeat length + do (setf (memref object offset :index i :type :unsigned-byte8) value))) + (vector + (loop for i upfrom index as x across value repeat length + do (setf (memref object offset :index i :type :unsigned-byte8) x))))) + (:character + (etypecase value + (character + (loop for i upfrom index repeat length + do (setf (memref object offset :index i :type :character) value))) + (string + (loop for i upfrom index as x across value repeat length + do (setf (memref object offset :index i :type :character) x)))))) + value) +

1 0

[movitz-cvs] CVS update: movitz/losp/lib/net/ethernet.lisp
by ffjeld＠common-lisp.net 21 May '05

21 May '05

Update of /project/movitz/cvsroot/movitz/losp/lib/net In directory common-lisp.net:/tmp/cvs-serv4858 Modified Files: ethernet.lisp Log Message: *** empty log message *** Date: Sun May 22 00:37:22 2005 Author: ffjeld Index: movitz/losp/lib/net/ethernet.lisp diff -u movitz/losp/lib/net/ethernet.lisp:1.7 movitz/losp/lib/net/ethernet.lisp:1.8 --- movitz/losp/lib/net/ethernet.lisp:1.7 Thu Dec 9 15:18:37 2004 +++ movitz/losp/lib/net/ethernet.lisp Sun May 22 00:37:21 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001-2004, +;;;; Copyright (C) 2001-2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 17 15:25:31 2002 ;;;; -;;;; $Id: ethernet.lisp,v 1.7 2004/12/09 14:18:37 ffjeld Exp $ +;;;; $Id: ethernet.lisp,v 1.8 2005/05/21 22:37:21 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -60,6 +60,7 @@ #:+ether-type-mswin-heartbeat+ #:+ether-type-loopback+ + #:with-ether-header )) (in-package muerte.ethernet) @@ -78,6 +79,25 @@ ;;; Packet accessors +(defmacro with-ether-header ((ether packet &key (start 0)) &body body) + (let* ((packet-var (gensym "ether-packet-")) + (offset-var (gensym "ether-packet-offset-")) + (start-var (gensym "ether-packet-start-"))) + `(let* ((,start-var ,start) + (,packet-var (ensure-data-vector ,packet ,start-var 14)) + (,offset-var (+ ,start-var (movitz-type-slot-offset 'movitz-basic-vector 'data)))) + (macrolet ((,ether (slot) + (ecase slot + (:source + `(memrange ,',packet-var ,',offset-var 6 6 :unsigned-byte8)) + (:destination + `(memrange ,',packet-var ,',offset-var 0 6 :unsigned-byte8)) + (:type + `(memref ,',packet-var (+ ,',offset-var 12) :type :unsigned-byte16 :endian :big)) + (:end `(+ ,',start-var 14))))) + ,@body)))) + + (defmacro packet-ref (packet start offset type) `(memref ,packet (+ (muerte:movitz-type-slot-offset 'movitz-basic-vector 'data) ,start ,offset) @@ -141,6 +161,7 @@ (defconstant +ether-type-loopback+ #x9000) ;;; + (defun format-ethernet-packet (packet source destination type &key (start 0) (source-start 0) (destination-start 0))

1 0

[movitz-cvs] CVS update: movitz/losp/lib/net/dhcp.lisp
by ffjeld＠common-lisp.net 21 May '05

21 May '05

Update of /project/movitz/cvsroot/movitz/losp/lib/net In directory common-lisp.net:/tmp/cvs-serv4842 Added Files: dhcp.lisp Log Message: *** empty log message *** Date: Sun May 22 00:36:33 2005 Author: ffjeld

1 0

[movitz-cvs] CVS update: movitz/losp/lib/net/ip4.lisp
by ffjeld＠common-lisp.net 21 May '05

21 May '05

Update of /project/movitz/cvsroot/movitz/losp/lib/net In directory common-lisp.net:/tmp/cvs-serv4811 Modified Files: ip4.lisp Log Message: *** empty log message *** Date: Sun May 22 00:36:17 2005 Author: ffjeld Index: movitz/losp/lib/net/ip4.lisp diff -u movitz/losp/lib/net/ip4.lisp:1.17 movitz/losp/lib/net/ip4.lisp:1.18 --- movitz/losp/lib/net/ip4.lisp:1.17 Tue Apr 19 08:50:04 2005 +++ movitz/losp/lib/net/ip4.lisp Sun May 22 00:36:16 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Apr 30 13:52:57 2003 ;;;; -;;;; $Id: ip4.lisp,v 1.17 2005/04/19 06:50:04 ffjeld Exp $ +;;;; $Id: ip4.lisp,v 1.18 2005/05/21 22:36:16 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -30,7 +30,9 @@ #:format-udp-header #:*ip4-nic* #:*ip4-ip* - #:*ip4-router*)) + #:*ip4-router* + + #:with-ip4-header)) (in-package muerte.ip4) @@ -38,6 +40,123 @@ (defvar *ip4-ip* nil) (defvar *ip4-router* nil) +#| RFC 760: http://www.faqs.org/rfcs/rfc760.html + 0 1 2 3 + 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + |Version| IHL |Type of Service| Total Length | + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Identification |Flags| Fragment Offset | + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Time to Live | Protocol | Header Checksum | + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Source Address | + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Destination Address | + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Options | Padding | + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ +|# + +(defmacro with-ip4-header ((ip4 packet &key (start 0)) &body body) + (let ((packet-var (gensym "ip4-packet-")) + (start-var (gensym "ip4-packet-start")) + (offset-var (gensym "ip4-packet-offset-"))) + (macrolet ((mmem (offset type) + ```(memref ,packet-var (+ ,',offset ,offset-var) :type ,',type :endian :big))) + `(let* ((,start-var ,start) + (,packet-var (ensure-data-vector ,packet ,start-var 20)) + (,offset-var (+ ,start-var (movitz-type-slot-offset 'movitz-basic-vector 'data)))) + (macrolet ((,ip4 (slot) + (ecase slot + (:version + `(ldb (byte 4 4) ,,(mmem 0 :unsigned-byte8))) + (:ihl ; IP header-length in 32-bit units. + `(ldb (byte 4 0) ,,(mmem 0 :unsigned-byte8))) + (:tos ; type-of-service + ,(mmem 1 :unsigned-byte8)) + (:length + ,(mmem 2 :unsigned-byte16)) + (:identification + ,(mmem 4 :unsigned-byte16)) + (:ttl + ,(mmem 8 :unsigned-byte8)) + (:protocol + ,(mmem 9 :unsigned-byte8)) + (:checksum + ,(mmem 10 :unsigned-byte16)) + ((:compute-checksum) + `(logxor #xffff (mem-checksum ,',packet-var ,',offset-var 20) #+ignore + (checksum-octets ,',packet-var ,',start-var (+ 20 ,',start-var)))) + (:source + ,(mmem 12 :unsigned-byte32)) + (:destination + ,(mmem 16 :unsigned-byte32)) + (:address-length 4) + (:address-offset `(+ 12 ,',offset-var)) + (:end `(+ 20 ,',start-var))))) + ,@body))))) + +(defmacro with-udp-header ((udp packet &key (start '(ip :end))) &body body) + (let ((packet-var (gensym "udp-packet-")) + (start-var (gensym "udp-packet-start")) + (offset-var (gensym "udp-packet-offset-"))) + (macrolet ((mmem (offset type) + ```(memref ,packet-var (+ ,',offset ,offset-var) :type ,',type :endian :big))) + `(let* ((,start-var ,start) + (,packet-var (ensure-data-vector ,packet ,start-var 20)) + (,offset-var (+ ,start-var (movitz-type-slot-offset 'movitz-basic-vector 'data)))) + (macrolet ((,udp (slot &optional arg) + (ecase slot + (:source-port + ,(mmem 0 :unsigned-byte16)) + (:destination-port + ,(mmem 2 :unsigned-byte16)) + (:length + ,(mmem 4 :unsigned-byte16)) + (:checksum + ,(mmem 6 :unsigned-byte16)) + ((:compute-checksum) + `(logxor #xffff + (add-u16-ones-complement (mem-checksum ,',packet-var + (,arg :address-offset) + (* 2 (,arg :address-length))) + +ip-protocol-udp+ + (,',udp :length) + (mem-checksum ,',packet-var ,',offset-var + (,',udp :length))))) + (:end `(+ 8 ,',start-var))))) + ,@body))))) + + +(defun mem-checksum (packet offset length) + (with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :ebx) packet) + (:compile-form (:result-mode :ecx) offset) + (:compile-form (:result-mode :esi) length) + ;; (:movl :eax :ecx) ; ecx = start + ;; (:subl :eax :esi) ; esi = (- end start) + ;; (:movl 0 :eax) + (:xorl :eax :eax) + (:testl :esi :esi) + (:shrl #.movitz::+movitz-fixnum-shift+ :ecx) + (:xorl :edx :edx) + (:std) + checksum-loop + (:movw (:ebx 0 :ecx) :ax) + (:xchgb :al :ah) + (:addl 2 :ecx) + (:addl :eax :edx) + (:subl #.(cl:* 2 movitz:+movitz-fixnum-factor+) :esi) + (:jnbe 'checksum-loop) + (:movw :dx :ax) + (:shrl 16 :edx) + (:addw :dx :ax) + (:movl (:ebp -4) :esi) + end-checksum-loop + (:shll #.movitz:+movitz-fixnum-shift+ :eax) + (:cld))) + (defmacro ip4-ref (packet start offset type) `(memref ,packet (+ (muerte:movitz-type-slot-offset 'movitz-basic-vector 'data) ,start ,offset) @@ -457,6 +576,12 @@ (defun ip4-address (specifier &optional (start 0)) (or (ignore-errors (typecase specifier + ((unsigned-byte 32) + (assert (= 0 start)) + (loop with address = (make-array 4 :element-type '(unsigned-byte 8)) + for i from 0 to 3 + do (setf (aref address (- 3 i)) (ldb (byte 8 (* 8 i)) specifier)) + finally (return address))) ((simple-array (unsigned-byte 8) (*)) (if (= start 0) specifier @@ -487,14 +612,17 @@ muerte.x86-pc.ne2k:*ne2k-probe-addresses*))) (assert ethernet ethernet "No ethernet device.") (setf *ip4-nic* ethernet))) - (unless *ip4-ip* - (setf *ip4-ip* (ip4-address ip))) - (unless *ip4-router* - (setf *ip4-router* (ip4-address router))) - ;; This is to announce our presence on the LAN.. - (assert (polling-arp *ip4-router* (lambda () - (eql #\space (muerte.x86-pc.keyboard:poll-char)))) - () "Unable to resolve ~/ip4:pprint-ip4/ by ARP." *ip4-router*) + (when ip + (unless *ip4-ip* + (setf *ip4-ip* (ip4-address ip)))) + (when router + (unless *ip4-router* + (setf *ip4-router* (ip4-address router)))) + (when *ip4-router* + ;; This is to announce our presence on the LAN.. + (assert (polling-arp *ip4-router* (lambda () + (eql #\space (muerte.x86-pc.keyboard:poll-char)))) + () "Unable to resolve ~/ip4:pprint-ip4/ by ARP." *ip4-router*)) (values *ip4-nic* *ip4-ip*)) (defun ip4-test ()

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/sequences.lisp
by ffjeld＠common-lisp.net 21 May '05

21 May '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv4727 Modified Files: sequences.lisp Log Message: Added a piece of (map 'string ..) Date: Sun May 22 00:33:40 2005 Author: ffjeld Index: movitz/losp/muerte/sequences.lisp diff -u movitz/losp/muerte/sequences.lisp:1.19 movitz/losp/muerte/sequences.lisp:1.20 --- movitz/losp/muerte/sequences.lisp:1.19 Wed Dec 15 14:58:34 2004 +++ movitz/losp/muerte/sequences.lisp Sun May 22 00:33:40 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001-2004, +;;;; Copyright (C) 2001-2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 11 14:19:23 2001 ;;;; -;;;; $Id: sequences.lisp,v 1.19 2004/12/15 13:58:34 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.20 2005/05/21 22:33:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -670,7 +670,25 @@ (declare (dynamic-extent more-sequences) (ignore function first-sequence more-sequences)) (error "MAP not implemented.")))) - + +(defun map-for-string (function first-sequence &rest more-sequences) + (numargs-case + (2 (function first-sequence) + (with-funcallable (mapf function) + (let ((result (make-string (length first-sequence)))) + (sequence-dispatch first-sequence + (vector + (do ((i 0 (1+ i))) + ((>= i (length result)) result) + (setf (char result i) (mapf (aref first-sequence i))))) + (list + (do ((i 0 (1+ i))) + ((>= i (length result)) result) + (setf (char result i) (mapf (pop first-sequence))))))))) + (t (function first-sequence &rest more-sequences) + (declare (ignore function first-sequence more-sequences)) + (error "MAP not implemented.")))) + (defun map (result-type function first-sequence &rest more-sequences) "=> result" @@ -680,6 +698,8 @@ (apply 'map-for-nil function first-sequence more-sequences)) ((eq 'list result-type) (apply 'map-for-list function first-sequence more-sequences)) + ((eq 'string result-type) + (apply 'map-for-string function first-sequence more-sequences)) (t (error "MAP not implemented.")))) (defun fill (sequence item &key (start 0) end)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp
by ffjeld＠common-lisp.net 09 May '05

09 May '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv6419 Modified Files: interrupt.lisp Log Message: We _should_ do RET promotion of EIP, I think it was disabled for debugging purposes. Date: Mon May 9 08:20:55 2005 Author: ffjeld Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.44 movitz/losp/muerte/interrupt.lisp:1.45 --- movitz/losp/muerte/interrupt.lisp:1.44 Sun May 8 03:18:43 2005 +++ movitz/losp/muerte/interrupt.lisp Mon May 9 08:20:55 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.44 2005/05/08 01:18:43 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.45 2005/05/09 06:20:55 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -145,13 +145,13 @@ (:locally (:movl 0 (:edi (:edi-offset atomically-continuation)))) - ;; Do RET atomicification -;;; (:movl (:ebp ,(dit-frame-offset :eip)) :ecx) -;;; ((:cs-override) :cmpb ,(realpart (ia-x86:asm :ret)) (:ecx)) -;;; (:jne 'not-at-ret-instruction) -;;; (:globally (:movl (:edi (:edi-offset ret-trampoline)) :ecx)) -;;; (:movl :ecx (:ebp ,(dit-frame-offset :eip))) -;;; not-at-ret-instruction + ;; Do RET promotion of EIP. + (:movl (:ebp ,(dit-frame-offset :eip)) :ecx) + ((:cs-override) :cmpb ,(realpart (ia-x86:asm :ret)) (:ecx)) + (:jne 'not-at-ret-instruction) + (:globally (:movl (:edi (:edi-offset ret-trampoline)) :ecx)) + (:movl :ecx (:ebp ,(dit-frame-offset :eip))) + not-at-ret-instruction (:xorl :eax :eax) ; Ensure safe value (:xorl :edx :edx) ; Ensure safe value

1 0

[movitz-cvs] CVS update: movitz/losp/lib/threading.lisp
by ffjeld＠common-lisp.net 08 May '05

08 May '05

Update of /project/movitz/cvsroot/movitz/losp/lib In directory common-lisp.net:/tmp/cvs-serv30718 Modified Files: threading.lisp Log Message: I was a bit too quick about using the segment-selector accessor rather than the control-stack-fs operator, since the basic RTC object doesn't have a segment-selector slot. I'll have to come up with a better protocol for this stuff, in general. Date: Mon May 9 00:05:13 2005 Author: ffjeld Index: movitz/losp/lib/threading.lisp diff -u movitz/losp/lib/threading.lisp:1.6 movitz/losp/lib/threading.lisp:1.7 --- movitz/losp/lib/threading.lisp:1.6 Sun May 8 15:41:32 2005 +++ movitz/losp/lib/threading.lisp Mon May 9 00:05:13 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu Apr 28 08:30:01 2005 ;;;; -;;;; $Id: threading.lisp,v 1.6 2005/05/08 13:41:32 ffjeld Exp $ +;;;; $Id: threading.lisp,v 1.7 2005/05/08 22:05:13 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -66,6 +66,9 @@ (defmacro control-stack-esp (stack) `(stack-frame-ref ,stack 0 1)) +(defmacro control-stack-fs (stack) + `(stack-frame-ref ,stack 0 2)) + (defmethod initialize-instance :after ((thread thread) &key (stack-size 2048) segment-selector stack-cushion (function #'invoke-debugger) (args '(nil)) @@ -88,7 +91,8 @@ function args))) (multiple-value-bind (ebp esp) (control-stack-fixate stack) - (setf (control-stack-ebp stack) ebp + (setf (control-stack-fs stack) segment-selector + (control-stack-ebp stack) ebp (control-stack-esp stack) esp)) (setf (%run-time-context-slot thread 'muerte::dynamic-env) 0) (setf (%run-time-context-slot thread 'muerte::stack-vector) stack) @@ -163,7 +167,7 @@ (let ((my-stack (%run-time-context-slot nil 'muerte::stack-vector)) (target-stack (%run-time-context-slot target-rtc 'muerte::stack-vector))) (assert (not (eq my-stack target-stack))) - (let ((fs (segment-selector target-rtc)) + (let ((fs (control-stack-fs target-stack)) (esp (control-stack-esp target-stack)) (ebp (control-stack-ebp target-stack))) (assert (location-in-object-p target-stack esp)) @@ -177,7 +181,8 @@ (setf (%run-time-context-slot target-rtc 'muerte::scratch1) ebp (%run-time-context-slot target-rtc 'muerte::scratch2) esp) ;; Enable someone to yield back here.. - (setf (control-stack-ebp my-stack) (muerte::asm-register :ebp) + (setf (control-stack-fs my-stack) (segment-register :fs) + (control-stack-ebp my-stack) (muerte::asm-register :ebp) (control-stack-esp my-stack) (muerte::asm-register :esp)) (with-inline-assembly (:returns :eax) (:load-lexical (:lexical-binding fs) :untagged-fixnum-ecx) @@ -187,3 +192,4 @@ (:locally (:movl (:edi (:edi-offset scratch1)) :ebp)) (:locally (:movl (:edi (:edi-offset scratch2)) :esp)) (:popfl))))) +

1 0

[movitz-cvs] CVS update: movitz/image.lisp
by ffjeld＠common-lisp.net 08 May '05

08 May '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv30557 Modified Files: image.lisp Log Message: Have the values part be last, so that the RTC as a whole follows the <header part> <variable-length part> object layout pattern. Date: Mon May 9 00:02:46 2005 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.99 movitz/image.lisp:1.100 --- movitz/image.lisp:1.99 Thu May 5 20:01:13 2005 +++ movitz/image.lisp Mon May 9 00:02:46 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.99 2005/05/05 18:01:13 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.100 2005/05/08 22:02:46 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -310,12 +310,6 @@ (movitz-intern (movitz-env-named-function name)))) - (num-values - :binary-type word ; Fixnum - :initform 0) - (values - :binary-type #.(* 4 +movitz-multiple-values-limit+)) - (cons-pointer :binary-type code-vector-word :initform nil @@ -414,7 +408,12 @@ :accessor movitz-run-time-context-interrupt-descriptor-table :initform (make-array 256 :initial-element 'muerte::default-interrupt-trampoline) :map-binary-read-delayed 'movitz-word - :map-binary-write 'map-interrupt-trampolines-to-idt)) + :map-binary-write 'map-interrupt-trampolines-to-idt) + (num-values + :binary-type word ; Fixnum + :initform 0) + (values + :binary-type #.(* 4 +movitz-multiple-values-limit+))) (:slot-align null-symbol -5)) (defun atomically-continuation-simple-pf (pf-name)

1 0

[movitz-cvs] CVS update: movitz/losp/lib/threading.lisp
by ffjeld＠common-lisp.net 08 May '05

08 May '05

Update of /project/movitz/cvsroot/movitz/losp/lib In directory common-lisp.net:/tmp/cvs-serv20517 Modified Files: threading.lisp Log Message: Use the thread's segment-selector rather than storing FS on the stack. Date: Sun May 8 15:41:32 2005 Author: ffjeld Index: movitz/losp/lib/threading.lisp diff -u movitz/losp/lib/threading.lisp:1.5 movitz/losp/lib/threading.lisp:1.6 --- movitz/losp/lib/threading.lisp:1.5 Sun May 8 03:20:48 2005 +++ movitz/losp/lib/threading.lisp Sun May 8 15:41:32 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu Apr 28 08:30:01 2005 ;;;; -;;;; $Id: threading.lisp,v 1.5 2005/05/08 01:20:48 ffjeld Exp $ +;;;; $Id: threading.lisp,v 1.6 2005/05/08 13:41:32 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -56,6 +56,7 @@ (defclass thread (run-time-context) ((segment-selector + :reader segment-selector :initarg :segment-selector)) (:metaclass run-time-context-class)) @@ -65,9 +66,6 @@ (defmacro control-stack-esp (stack) `(stack-frame-ref ,stack 0 1)) -(defmacro control-stack-fs (stack) - `(stack-frame-ref ,stack 0 2)) - (defmethod initialize-instance :after ((thread thread) &key (stack-size 2048) segment-selector stack-cushion (function #'invoke-debugger) (args '(nil)) @@ -90,8 +88,7 @@ function args))) (multiple-value-bind (ebp esp) (control-stack-fixate stack) - (setf (control-stack-fs stack) segment-selector - (control-stack-ebp stack) ebp + (setf (control-stack-ebp stack) ebp (control-stack-esp stack) esp)) (setf (%run-time-context-slot thread 'muerte::dynamic-env) 0) (setf (%run-time-context-slot thread 'muerte::stack-vector) stack) @@ -166,7 +163,7 @@ (let ((my-stack (%run-time-context-slot nil 'muerte::stack-vector)) (target-stack (%run-time-context-slot target-rtc 'muerte::stack-vector))) (assert (not (eq my-stack target-stack))) - (let ((fs (control-stack-fs target-stack)) + (let ((fs (segment-selector target-rtc)) (esp (control-stack-esp target-stack)) (ebp (control-stack-ebp target-stack))) (assert (location-in-object-p target-stack esp)) @@ -180,8 +177,7 @@ (setf (%run-time-context-slot target-rtc 'muerte::scratch1) ebp (%run-time-context-slot target-rtc 'muerte::scratch2) esp) ;; Enable someone to yield back here.. - (setf (control-stack-fs my-stack) (segment-register :fs) - (control-stack-ebp my-stack) (muerte::asm-register :ebp) + (setf (control-stack-ebp my-stack) (muerte::asm-register :ebp) (control-stack-esp my-stack) (muerte::asm-register :esp)) (with-inline-assembly (:returns :eax) (:load-lexical (:lexical-binding fs) :untagged-fixnum-ecx)

1 0

[movitz-cvs] CVS update: movitz/losp/lib/threading.lisp
by ffjeld＠common-lisp.net 08 May '05

08 May '05

Update of /project/movitz/cvsroot/movitz/losp/lib In directory common-lisp.net:/tmp/cvs-serv25192 Modified Files: threading.lisp Log Message: (make-instance 'thread) and yield seem to work now.. :) Date: Sun May 8 03:20:48 2005 Author: ffjeld Index: movitz/losp/lib/threading.lisp diff -u movitz/losp/lib/threading.lisp:1.4 movitz/losp/lib/threading.lisp:1.5 --- movitz/losp/lib/threading.lisp:1.4 Fri May 6 08:59:03 2005 +++ movitz/losp/lib/threading.lisp Sun May 8 03:20:48 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu Apr 28 08:30:01 2005 ;;;; -;;;; $Id: threading.lisp,v 1.4 2005/05/06 06:59:03 ffjeld Exp $ +;;;; $Id: threading.lisp,v 1.5 2005/05/08 01:20:48 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -19,36 +19,44 @@ (defpackage threading (:use cl muerte) (:export thread - make-thread yield + *segment-descriptor-table-manager* + segment-descriptor-table-manager + allocate-segment-selector )) -(in-package muerte) +(in-package threading) -(defclass segment-descriptor-manager () +(defvar *segment-descriptor-table-manager*) + +(defclass segment-descriptor-table-manager () ((table - :accessor segment-descriptor-table + :reader segment-descriptor-table :initarg :table - :initform (dump-global-segment-table :entries 32)) + :initform (setf (muerte::global-segment-descriptor-table) + (muerte::dump-global-segment-table :entries 64))) + (clients + :initform (make-array 64)) (range-start :initarg :range-start :accessor range-start - :initform (1+ (ceiling (reduce #'max '(:cs :ds :es :ss :fs) - :key #'segment-register) - 8))))) + :initform (+ 8 (logand #xfff8 (reduce #'max '(:cs :ds :es :ss :fs) + :key #'segment-register)))))) -(defmethod allocate-segment-selector ((manager segment-descriptor-manager) &optional errorp) +(defmethod allocate-segment-selector ((manager segment-descriptor-table-manager) client + &optional (errorp t)) (loop with table = (segment-descriptor-table manager) - for s from (range-start manager) below (/ (length table) 2) - do (when (zerop (ldb (byte 1 0) (segment-descriptor-avl-x-db-g table s))) - (setf (ldb (byte 1 0) (segment-descriptor-avl-x-db-g table s)) 1) - (return (* 8 s))) + with clients = (slot-value manager 'clients) + for selector from (range-start manager) below (* (length table) 2) by 8 + do (when (not (aref clients (truncate selector 8))) + (setf (aref clients (truncate selector 8)) client) + (return selector)) finally (when errorp (error "Unable to allocate a segment selector.")))) (defclass thread (run-time-context) ((segment-selector - :initform :segment-selector)) + :initarg :segment-selector)) (:metaclass run-time-context-class)) (defmacro control-stack-ebp (stack) @@ -60,6 +68,45 @@ (defmacro control-stack-fs (stack) `(stack-frame-ref ,stack 0 2)) +(defmethod initialize-instance :after ((thread thread) + &key (stack-size 2048) segment-selector stack-cushion + (function #'invoke-debugger) (args '(nil)) + &allow-other-keys) + (let ((segment-selector + (or segment-selector + (let ((selector (setf (slot-value thread 'segment-selector) + (allocate-segment-selector *segment-descriptor-table-manager* thread)))) + (setf (segment-descriptor (segment-descriptor-table *segment-descriptor-table-manager*) + selector) + (segment-descriptor (segment-descriptor-table *segment-descriptor-table-manager*) + (segment-register :fs))) + selector)))) + (check-type segment-selector (unsigned-byte 16)) + (setf (segment-descriptor-base-location (segment-descriptor-table *segment-descriptor-table-manager*) + segment-selector) + (+ (object-location thread) (location-physical-offset))) + (let ((stack (control-stack-init-for-yield (make-array stack-size + :element-type '(unsigned-byte 32)) + function args))) + (multiple-value-bind (ebp esp) + (control-stack-fixate stack) + (setf (control-stack-fs stack) segment-selector + (control-stack-ebp stack) ebp + (control-stack-esp stack) esp)) + (setf (%run-time-context-slot thread 'muerte::dynamic-env) 0) + (setf (%run-time-context-slot thread 'muerte::stack-vector) stack) + (setf (%run-time-context-slot thread 'muerte::stack-top) + (+ 2 (object-location stack) + (length stack))) + (setf (%run-time-context-slot thread 'muerte::stack-bottom) + (+ (object-location stack) 2 + (or stack-cushion + (if (>= (length stack) 200) + 100 + 0)))) + (values thread)))) + + (defun control-stack-push (value stack &optional (type :lisp)) (let ((i (decf (control-stack-esp stack)))) (assert (< 1 i (length stack))) @@ -113,40 +160,11 @@ (control-stack-enter-frame stack #'yield) stack) -(defun make-thread (&key (name (gensym "thread-")) (function #'invoke-debugger) args) - "Make a thread and initialize its stack to apply function to args." - (let* ((fs-index 8) ; a vacant spot in the global segment descriptor table.. - (fs (* 8 fs-index)) - (thread (muerte::clone-run-time-context :name name)) - (segment-descriptor-table nil #+ignore (symbol-value 'muerte.init::*segment-descriptor-table*))) - (setf (segment-descriptor segment-descriptor-table fs-index) - (segment-descriptor segment-descriptor-table (truncate (segment-register :fs) 8))) - (setf (segment-descriptor-base-location segment-descriptor-table fs-index) - (+ (object-location thread) (muerte::location-physical-offset))) - (let ((cushion nil) - (stack (control-stack-init-for-yield (make-array 4094 :element-type '(unsigned-byte 32)) - function args))) - (multiple-value-bind (ebp esp) - (control-stack-fixate stack) - (setf (control-stack-fs stack) fs - (control-stack-ebp stack) ebp - (control-stack-esp stack) esp)) - (setf (%run-time-context-slot thread 'dynamic-env) 0 - (%run-time-context-slot thread 'stack-vector) stack - (%run-time-context-slot thread 'stack-top) (+ 2 (object-location stack) - (length stack)) - (%run-time-context-slot thread 'stack-bottom) (+ (object-location stack) 2 - (or cushion - (if (>= (length stack) 200) - 100 - 0)))) - (values thread)))) - (defun yield (target-rtc &optional value) (declare (dynamic-extent values)) (assert (not (eq target-rtc (current-run-time-context)))) - (let ((my-stack (%run-time-context-slot nil 'stack-vector)) - (target-stack (%run-time-context-slot target-rtc 'stack-vector))) + (let ((my-stack (%run-time-context-slot nil 'muerte::stack-vector)) + (target-stack (%run-time-context-slot target-rtc 'muerte::stack-vector))) (assert (not (eq my-stack target-stack))) (let ((fs (control-stack-fs target-stack)) (esp (control-stack-esp target-stack)) @@ -159,8 +177,8 @@ ;; Push eflags for later.. (setf (memref (decf esp) 0) (eflags)) ;; Store EBP and ESP so we can get to them after the switch - (setf (%run-time-context-slot target-rtc 'scratch1) ebp - (%run-time-context-slot target-rtc 'scratch2) esp) + (setf (%run-time-context-slot target-rtc 'muerte::scratch1) ebp + (%run-time-context-slot target-rtc 'muerte::scratch2) esp) ;; Enable someone to yield back here.. (setf (control-stack-fs my-stack) (segment-register :fs) (control-stack-ebp my-stack) (muerte::asm-register :ebp)

1 0