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

[movitz-cvs] CVS update: movitz/losp/muerte/sequences.lisp
by Frode Vatvedt Fjeld 11 Jul '04

11 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv22849 Modified Files: sequences.lisp Log Message: Removed buggy implementation of replace between two u32 vectors. Date: Sun Jul 11 15:47:10 2004 Author: ffjeld Index: movitz/losp/muerte/sequences.lisp diff -u movitz/losp/muerte/sequences.lisp:1.14 movitz/losp/muerte/sequences.lisp:1.15 --- movitz/losp/muerte/sequences.lisp:1.14 Thu Jul 8 04:30:36 2004 +++ movitz/losp/muerte/sequences.lisp Sun Jul 11 15:47:10 2004 @@ -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.14 2004/07/08 11:30:36 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.15 2004/07/11 22:47:10 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -735,11 +735,6 @@ (memcopy sequence-1 sequence-2 2 start1 start2 (min (- end1 start1) (- end2 start2)) :unsigned-byte8)) - ((:u32 :u32) - (%copy-words (object-location sequence-1) - (object-location sequence-2) - (min (- end1 start1) (- end2 start2)) - start1 start2)) (t (with-subvector-accessor (sequence-1-ref sequence-1 start1 end1) (with-subvector-accessor (sequence-2-ref sequence-2 start2 end2) (cond

1 0

[movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp
by Frode Vatvedt Fjeld 11 Jul '04

11 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv4896 Modified Files: debugger.lisp Log Message: When filtering out conditions in safe-print-stack-frame-arglist, only catch serious-conditions. Date: Sun Jul 11 12:26:12 2004 Author: ffjeld Index: movitz/losp/x86-pc/debugger.lisp diff -u movitz/losp/x86-pc/debugger.lisp:1.13 movitz/losp/x86-pc/debugger.lisp:1.14 --- movitz/losp/x86-pc/debugger.lisp:1.13 Thu Jun 10 09:28:27 2004 +++ movitz/losp/x86-pc/debugger.lisp Sun Jul 11 12:26:11 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Nov 22 10:09:18 2002 ;;;; -;;;; $Id: debugger.lisp,v 1.13 2004/06/10 16:28:27 ffjeld Exp $ +;;;; $Id: debugger.lisp,v 1.14 2004/07/11 19:26:11 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -429,7 +429,7 @@ (defun safe-print-stack-frame-arglist (&rest args) (declare (dynamic-extent args)) (handler-case (apply #'print-stack-frame-arglist args) - (t (conditon) + (serious-condition (conditon) (write-string "#<error printing frame>")))) (defun backtrace (&key ((:frame initial-stack-frame)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp
by Frode Vatvedt Fjeld 10 Jul '04

10 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv6574 Modified Files: integers.lisp Log Message: Implemented addition of negative fixnums and positive bignums. Date: Sat Jul 10 07:39:28 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.41 movitz/losp/muerte/integers.lisp:1.42 --- movitz/losp/muerte/integers.lisp:1.41 Sat Jul 10 06:29:23 2004 +++ movitz/losp/muerte/integers.lisp Sat Jul 10 07:39:28 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.41 2004/07/10 13:29:23 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.42 2004/07/10 14:39:28 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -28,6 +28,9 @@ (deftype positive-bignum () `(integer ,(1+ movitz:+movitz-most-positive-fixnum+) *)) +(deftype negative-fixnum () + `(integer ,movitz:+movitz-most-negative-fixnum+ -1)) + (defmacro number-double-dispatch ((x y) &rest clauses) `(let ((x ,x) (y ,y)) (cond ,@(loop for ((x-type y-type) . then-body) in clauses @@ -123,7 +126,13 @@ ((positive-bignum positive-fixnum) (funcall '+ y x)) ((positive-fixnum positive-bignum) - (with-inline-assembly (:returns :eax) + (with-inline-assembly (:returns :eax :labels (retry-not-size1 + not-size1 + copy-bignum-loop + add-bignum-loop + add-bignum-done + no-expansion + pfix-pbig-done)) (:compile-two-forms (:eax :ebx) y x) (:testl :ebx :ebx) (:jz 'pfix-pbig-done) @@ -131,7 +140,7 @@ (:cmpl 1 :ecx) (:jne 'not-size1) (:compile-form (:result-mode :ecx) x) - (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) (:addl (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) :ecx) (:jc 'retry-not-size1) (:call-global-constant box-u32-ecx) @@ -160,7 +169,7 @@ (:jnz 'copy-bignum-loop) (:load-lexical (:lexical-binding x) :ecx) - (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) (:xorl :ebx :ebx) (:addl :ecx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) (:jnc 'add-bignum-done) @@ -177,6 +186,70 @@ (:je 'no-expansion) (:addl #x10000 (:eax ,movitz:+other-type-offset+)) (:addl ,movitz:+movitz-fixnum-factor+ :ecx) + no-expansion + (:call-global-constant cons-commit) + (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) + (:edi (:edi-offset atomically-status)))) + + pfix-pbig-done)) + ((negative-fixnum positive-bignum) + (with-inline-assembly (:returns :eax :labels (retry-not-size1 + not-size1 + copy-bignum-loop + add-bignum-loop + add-bignum-done + no-expansion + pfix-pbig-done)) + (:compile-two-forms (:eax :ebx) y x) + (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx) + (:cmpl 1 :ecx) + (:jne 'not-size1) + (:compile-form (:result-mode :ecx) x) + (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) + (:addl (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) :ecx) + (:call-global-constant box-u32-ecx) + (:jmp 'pfix-pbig-done) + retry-not-size1 + (:compile-form (:result-mode :eax) y) + (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx) + not-size1 + (:declare-label-set retry-jumper (retry-not-size1)) + (:locally (:movl :esp (:edi (:edi-offset atomically-esp)))) + (:locally (:movl '(:funcall ,(movitz::atomically-status-jumper-fn t :esp) + 'retry-jumper) + (:edi (:edi-offset atomically-status)))) + (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) ,(* 1 movitz:+movitz-fixnum-factor+)) + :eax) ; Number of words + (:call-global-constant get-cons-pointer) + (:load-lexical (:lexical-binding y) :ebx) ; bignum + (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx) + (:leal ((:ecx #.movitz:+movitz-fixnum-factor+) ,movitz:+movitz-fixnum-factor+) + :edx) + copy-bignum-loop + (:subl ,movitz:+movitz-fixnum-factor+ :edx) + (:movl (:ebx :edx ,movitz:+other-type-offset+) :ecx) + (:movl :ecx (:eax :edx ,movitz:+other-type-offset+)) + (:jnz 'copy-bignum-loop) + + (:load-lexical (:lexical-binding x) :ecx) + (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) + (:xorl :ebx :ebx) ; counter + (:negl :ecx) + (:subl :ecx (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) + (:jnc 'add-bignum-done) + add-bignum-loop + (:addl 4 :ebx) + (:subl 1 (:eax :ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) + (:jc 'add-bignum-loop) + add-bignum-done + (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) + :ecx) + (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) ,movitz:+movitz-fixnum-factor+) + :ecx) ; result bignum word-size + (:cmpl 0 (:eax :ecx ,(+ -8 (bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)))) + (:jne 'no-expansion) + (:subl #x10000 (:eax ,movitz:+other-type-offset+)) + (:subl ,movitz:+movitz-fixnum-factor+ :ecx) no-expansion (:call-global-constant cons-commit) (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp
by Frode Vatvedt Fjeld 10 Jul '04

10 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv13312 Modified Files: integers.lisp Log Message: Re-working the compilation of addition. Now use a proper extended-code instruction (which is like a "vop", I think). Date: Sat Jul 10 06:29:23 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.40 movitz/losp/muerte/integers.lisp:1.41 --- movitz/losp/muerte/integers.lisp:1.40 Thu Jul 8 14:51:08 2004 +++ movitz/losp/muerte/integers.lisp Sat Jul 10 06:29:23 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.40 2004/07/08 21:51:08 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.41 2004/07/10 13:29:23 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -71,7 +71,10 @@ (case (length operands) (0 0) (1 (first operands)) - (2 `(+%2op ,(first operands) ,(second operands))) + #+ignore (2 `(+%2op ,(first operands) ,(second operands))) + (2 `(let ((x ,(first operands)) + (y ,(second operands))) + (++%2op x y))) (t (let ((operands (loop for operand in operands if (movitz:movitz-constantp operand env) @@ -1975,8 +1978,9 @@ (movitz:movitz-eval integer env))) ; constant folding ((and (movitz:movitz-constantp size env) (movitz:movitz-constantp position env)) - (let ((size (movitz:movitz-eval size env)) - (position (movitz:movitz-eval position env))) + (let* ((size (movitz:movitz-eval size env)) + (position (movitz:movitz-eval position env)) + (result-type `(unsigned-byte ,size))) (cond ((or (minusp size) (minusp position)) (error "Negative byte-spec for ldb.")) @@ -1984,7 +1988,7 @@ `(progn ,integer 0)) ((<= (+ size position) (- 31 movitz:+movitz-fixnum-shift+)) `(with-inline-assembly (:returns :register - :type (integer 0 ,(mask-field (byte size 0) -1))) + :type ,result-type) (:compile-form (:result-mode :eax) ,integer) (:call-global-constant unbox-u32) (:andl ,(mask-field (byte size position) -1) :ecx) @@ -1992,7 +1996,7 @@ `((:shrl ,position :ecx))) (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) (:result-register)))) ((<= (+ size position) 32) - `(with-inline-assembly-case () + `(with-inline-assembly-case (:type ,result-type) (do-case (t :eax :labels (nix done)) (:compile-form (:result-mode :eax) ,integer) ,@(cond

1 0

[movitz-cvs] CVS update: movitz/special-operators.lisp
by Frode Vatvedt Fjeld 10 Jul '04

10 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv13088 Modified Files: special-operators.lisp Log Message: Re-working the compilation of addition. Now use a proper extended-code instruction (which is like a "vop", I think). Date: Sat Jul 10 06:29:18 2004 Author: ffjeld Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.24 movitz/special-operators.lisp:1.25 --- movitz/special-operators.lisp:1.24 Fri Jul 9 09:12:44 2004 +++ movitz/special-operators.lisp Sat Jul 10 06:29:18 2004 @@ -8,7 +8,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Nov 24 16:22:59 2000 ;;;; -;;;; $Id: special-operators.lisp,v 1.24 2004/07/09 16:12:44 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.25 2004/07/10 13:29:18 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1000,6 +1000,18 @@ :forward all :env local-env :form sub-form))) + +(define-special-operator muerte::++%2op (&all all &form form &env env &result-mode result-mode) + (destructuring-bind (term1 term2) + (cdr form) + (let ((returns (ecase (result-mode-type result-mode) + ((:function :multiple-values :eax :push) :eax) + ((:ebx :ecx :edx) result-mode) + ((:lexical-binding) result-mode)))) + (compiler-values () + :returns returns + :code `((:add ,(movitz-binding term1 env) ,(movitz-binding term2 env) ,returns)))))) + (define-special-operator muerte::+%2op (&all all &form form &env env &result-mode result-mode) (assert (not (eq :boolean result-mode)) ()

1 0

[movitz-cvs] CVS update: movitz/compiler.lisp
by Frode Vatvedt Fjeld 10 Jul '04

10 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv11680 Modified Files: compiler.lisp Log Message: Re-working the compilation of addition. Now use a proper extended-code instruction (which is like a "vop", I think). Date: Sat Jul 10 06:29:11 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.71 movitz/compiler.lisp:1.72 --- movitz/compiler.lisp:1.71 Fri Jul 9 09:11:20 2004 +++ movitz/compiler.lisp Sat Jul 10 06:29:11 2004 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.71 2004/07/09 16:11:20 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.72 2004/07/10 13:29:11 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -389,6 +389,9 @@ (member-type-encode (constant-object target-binding)))))) (t (pushnew target-binding (type-analysis-binding-types analysis)) (setf more-binding-references-p t))))) + ((and (bindingp type) + (binding-eql type binding)) + nil) (t (setf (type-analysis-encoded-type analysis) (multiple-value-list (multiple-value-call @@ -5425,7 +5428,6 @@ (compiler-values () :code (make-compiled-lexical-load binding returns) :final-form binding - :type (binding-type-specifier binding) :returns returns :functional-p t)))))) @@ -6098,47 +6100,88 @@ (define-find-read-bindings :add (term0 term1 destination) (declare (ignore destination)) - (remove-if-not #'bindingp (list term0 term1))) + (list term0 term1)) (define-extended-code-expander :add (instruction funobj frame-map) (destructuring-bind (term0 term1 destination) (cdr instruction) - (cond - ((and (bindingp term0) - (bindingp term1) - (member destination - '(:function :multple-values :eax :ebx :ecx :edx))) - #+ignore - (when (and (binding-store-subtypep term0 'fixnum) - (binding-store-subtypep term1 'fixnum) - (movitz-subtypep (multiple-value-call #'encoded-integer-types-add - (values-list (binding-store-type term0)) - (values-list (binding-store-type term1))) - 'fixnum)) - (warn "add: ~S~%~A => ~A~%~S, ~S" - instruction - (binding-type-specifier term0) - (binding-type-specifier term1) - (binding-store-subtypep term0 'fixnum) - (binding-store-subtypep term1 'fixnum))) + (assert (and (bindingp term0) + (bindingp term1) + (member (result-mode-type destination) + '(:lexical-binding :function :multple-values :eax :ebx :ecx :edx)))) + (let* ((term0 (binding-target term0)) + (term1 (binding-target term1)) + (destination (if (or (not (bindingp destination)) + (not (symbolp (new-binding-location destination frame-map :default 0)))) + destination + (new-binding-location destination frame-map))) + (type0 (apply #'encoded-type-decode (binding-store-type term0))) + (type1 (apply #'encoded-type-decode (binding-store-type term1))) + (result-type (multiple-value-call #'encoded-integer-types-add + (values-list (binding-store-type term0)) + (values-list (binding-store-type term1))))) + ;; (warn "add for: ~S is ~A." destination result-type) (let ((loc0 (new-binding-location term0 frame-map :default nil)) (loc1 (new-binding-location term1 frame-map :default nil))) - (append (cond - ((and (eq :eax loc0) (eq :ebx loc1)) - nil) - ((and (eq :ebx loc0) (eq :eax loc1)) - nil) ; terms order isn't important - ((eq :eax loc1) - (append - (make-load-lexical term0 :ebx funobj nil frame-map))) - (t (append - (make-load-lexical term0 :eax funobj nil frame-map) - (make-load-lexical term1 :ebx funobj nil frame-map)))) - `((:movl (:edi ,(global-constant-offset '+)) :esi)) - (make-compiled-funcall-by-esi 2) - (ecase destination - ((:function :multple-values :eax)) - ((:ebx :ecx :edx) - `((:movl :eax ,destination)))) - ))) - (t (error "Unknown add: ~S" instruction))))) + (cond + ((type-specifier-singleton result-type) + ;; (break "constant add: ~S" instruction) + (make-load-constant (car (type-specifier-singleton result-type)) + destination funobj frame-map)) + ((and (movitz-subtypep type1 'fixnum) + (movitz-subtypep type1 'fixnum) + (movitz-subtypep result-type 'fixnum)) + (cond + ((and (type-specifier-singleton type0) + (eq loc1 destination)) + (cond + ((member destination '(:eax :ebx :ecx :edx)) + `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0))) + ,destination))) + (t (assert (integerp loc1)) + (break "check that this is correct..") + `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0))) + (:ebp ,(stack-frame-offset loc1))))))) + (t (warn "ADD: ~S = ~A + ~A, ~A ~A, ~A ~A" + destination loc0 loc1 type0 type1 + (type-specifier-singleton type0) + (eq loc1 destination)) + (warn "ADDI: ~S" instruction) + (append (cond + ((and (eq :eax loc0) (eq :ebx loc1)) + nil) + ((and (eq :ebx loc0) (eq :eax loc1)) + nil) ; terms order isn't important + ((eq :eax loc1) + (append + (make-load-lexical term0 :ebx funobj nil frame-map))) + (t (append + (make-load-lexical term0 :eax funobj nil frame-map) + (make-load-lexical term1 :ebx funobj nil frame-map)))) + `((:movl (:edi ,(global-constant-offset '+)) :esi)) + (make-compiled-funcall-by-esi 2) + (etypecase destination + (symbol + (unless (eq destination :eax) + `((:movl :eax ,destination)))) + (binding + (make-store-lexical destination :eax nil frame-map))))))) + (t (append (cond + ((and (eq :eax loc0) (eq :ebx loc1)) + nil) + ((and (eq :ebx loc0) (eq :eax loc1)) + nil) ; terms order isn't important + ((eq :eax loc1) + (append + (make-load-lexical term0 :ebx funobj nil frame-map))) + (t (append + (make-load-lexical term0 :eax funobj nil frame-map) + (make-load-lexical term1 :ebx funobj nil frame-map)))) + `((:movl (:edi ,(global-constant-offset '+)) :esi)) + (make-compiled-funcall-by-esi 2) + (etypecase destination + (symbol + (unless (eq destination :eax) + `((:movl :eax ,destination)))) + (binding + (make-store-lexical destination :eax nil frame-map))))))))))

1 0

[movitz-cvs] CVS update: movitz/special-operators.lisp
by Frode Vatvedt Fjeld 09 Jul '04

09 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv12362 Modified Files: special-operators.lisp Log Message: Minor edit. Date: Fri Jul 9 09:12:44 2004 Author: ffjeld Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.23 movitz/special-operators.lisp:1.24 --- movitz/special-operators.lisp:1.23 Sun Jun 6 08:12:40 2004 +++ movitz/special-operators.lisp Fri Jul 9 09:12:44 2004 @@ -8,7 +8,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Nov 24 16:22:59 2000 ;;;; -;;;; $Id: special-operators.lisp,v 1.23 2004/06/06 15:12:40 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.24 2004/07/09 16:12:44 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1092,7 +1092,7 @@ :forward all :form (+ (eval-form term1 env) (eval-form term2 env)))) - ((and (movitz-constantp term1 env) ; first operand zero? + ((and (movitz-constantp term1 env) ; first operand zero? (zerop (eval-form term1 env))) (compiler-call #'compile-form-unprotected :forward all

1 0

[movitz-cvs] CVS update: movitz/image.lisp
by Frode Vatvedt Fjeld 09 Jul '04

09 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv10152 Modified Files: image.lisp Log Message: Added global-function + to constant-block. Date: Fri Jul 9 09:12:10 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.43 movitz/image.lisp:1.44 --- movitz/image.lisp:1.43 Fri Jul 9 04:16:24 2004 +++ movitz/image.lisp Fri Jul 9 09:12:10 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.43 2004/07/09 11:16:24 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.44 2004/07/09 16:12:10 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -284,6 +284,12 @@ :map-binary-write 'movitz-intern-code-vector :map-binary-read-delayed 'movitz-word-code-vector :binary-tag :primitive-function) + (+ + :initform 'muerte.cl:+ + :binary-type word + :binary-tag :global-function + :map-binary-write 'movitz-intern + :map-binary-read-delayed 'movitz-word) (complicated-class-of :binary-type word :binary-tag :global-function @@ -734,6 +740,13 @@ (check-type (cdr object) movitz-funobj) (+ (car object) (movitz-intern-code-vector (cdr object) type))))) +(defun movitz-intern-global-function (object &optional (type 'word)) + (assert (eq type 'word)) + (check-type object symbol) + (let ((x (movitz-env-named-function object))) + (check-type x movitz-funobj) + (movitz-intern x 'word))) + (defun movitz-word-code-vector (word &optional (type 'code-vector-word)) (assert (eq type 'code-vector-word)) (movitz-word (- word +code-vector-word-offset+))) @@ -853,7 +866,7 @@ ;; pull in functions in constant-block (dolist (gcf-name (binary-record-slot-names 'movitz-constant-block :match-tags :global-function)) (let* ((gcf-movitz-name (movitz-read (intern (symbol-name gcf-name) - ':muerte))) + ':muerte))) (gcf-funobj (movitz-symbol-function-value gcf-movitz-name))) (setf (slot-value constant-block gcf-name) 0) (cond

1 0

[movitz-cvs] CVS update: movitz/compiler.lisp
by Frode Vatvedt Fjeld 09 Jul '04

09 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv25538 Modified Files: compiler.lisp Log Message: Implementing :add extended-code. Date: Fri Jul 9 09:11:20 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.70 movitz/compiler.lisp:1.71 --- movitz/compiler.lisp:1.70 Wed Jul 7 10:34:09 2004 +++ movitz/compiler.lisp Fri Jul 9 09:11:20 2004 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.70 2004/07/07 17:34:09 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.71 2004/07/09 16:11:20 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -459,7 +459,7 @@ (when (apply #'encoded-type-singleton (type-analysis-encoded-type analysis)) (warn "Singleton: ~A" binding)) #+ignore - (when (or #+ignore (not (apply #'encoded-allp (type-analysis-encoded-type analysis))) + (when (or t #+ignore (not (apply #'encoded-allp (type-analysis-encoded-type analysis))) #+ignore (multiple-value-call #'encoded-subtypep (values-list (type-analysis-encoded-type analysis)) (type-specifier-encode 'list))) @@ -3024,6 +3024,9 @@ (when x (return t))))))) (code-search code binding load store call))) +(defun bindingp (x) + (typep x 'binding)) + (defun binding-target (binding) "Resolve a binding in terms of forwarding." (etypecase binding @@ -5759,7 +5762,7 @@ `(binding-type ,binding)))) (defun binding-store-subtypep (binding type-specifier) - "Is type-specifier a subtype of all values ever stored to binding? + "Is type-specifier a supertype of all values ever stored to binding? (Assuming analyze-bindings has put this information into binding-store-type.)" (if (not (binding-store-type binding)) nil @@ -6083,3 +6086,59 @@ (destructuring-bind (object result-mode &key (op :movl)) (cdr instruction) (make-load-constant object result-mode funobj frame-map :op op))) + +;;;;; Add + +(define-find-write-binding-and-type :add (instruction) + (destructuring-bind (term0 term1 destination) + (cdr instruction) + (declare (ignore term0 term1)) + (when (typep destination 'binding) + (values destination 'integer)))) + +(define-find-read-bindings :add (term0 term1 destination) + (declare (ignore destination)) + (remove-if-not #'bindingp (list term0 term1))) + +(define-extended-code-expander :add (instruction funobj frame-map) + (destructuring-bind (term0 term1 destination) + (cdr instruction) + (cond + ((and (bindingp term0) + (bindingp term1) + (member destination + '(:function :multple-values :eax :ebx :ecx :edx))) + #+ignore + (when (and (binding-store-subtypep term0 'fixnum) + (binding-store-subtypep term1 'fixnum) + (movitz-subtypep (multiple-value-call #'encoded-integer-types-add + (values-list (binding-store-type term0)) + (values-list (binding-store-type term1))) + 'fixnum)) + (warn "add: ~S~%~A => ~A~%~S, ~S" + instruction + (binding-type-specifier term0) + (binding-type-specifier term1) + (binding-store-subtypep term0 'fixnum) + (binding-store-subtypep term1 'fixnum))) + (let ((loc0 (new-binding-location term0 frame-map :default nil)) + (loc1 (new-binding-location term1 frame-map :default nil))) + (append (cond + ((and (eq :eax loc0) (eq :ebx loc1)) + nil) + ((and (eq :ebx loc0) (eq :eax loc1)) + nil) ; terms order isn't important + ((eq :eax loc1) + (append + (make-load-lexical term0 :ebx funobj nil frame-map))) + (t (append + (make-load-lexical term0 :eax funobj nil frame-map) + (make-load-lexical term1 :ebx funobj nil frame-map)))) + `((:movl (:edi ,(global-constant-offset '+)) :esi)) + (make-compiled-funcall-by-esi 2) + (ecase destination + ((:function :multple-values :eax)) + ((:ebx :ecx :edx) + `((:movl :eax ,destination)))) + ))) + (t (error "Unknown add: ~S" instruction)))))

1 0

[movitz-cvs] CVS update: movitz/compiler-types.lisp
by Frode Vatvedt Fjeld 09 Jul '04

09 Jul '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv21049 Modified Files: compiler-types.lisp Log Message: Changed handling of integers back again to having both an integer code and integer-range. Also, added encoded-integer-types-add. Date: Fri Jul 9 09:10:26 2004 Author: ffjeld Index: movitz/compiler-types.lisp diff -u movitz/compiler-types.lisp:1.17 movitz/compiler-types.lisp:1.18 --- movitz/compiler-types.lisp:1.17 Fri Jul 9 05:48:01 2004 +++ movitz/compiler-types.lisp Fri Jul 9 09:10:26 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Sep 10 00:40:07 2003 ;;;; -;;;; $Id: compiler-types.lisp,v 1.17 2004/07/09 12:48:01 ffjeld Exp $ +;;;; $Id: compiler-types.lisp,v 1.18 2004/07/09 16:10:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -211,11 +211,29 @@ (and x (not (car x)) (not (cdr x))))) +(defun numscope-combine (function range0 range1) + (let ((result ())) + (dolist (sub-range0 range0) + (dolist (sub-range1 range1) + (setf result + (numscope-union result + (funcall function + (car sub-range0) (cdr sub-range0) + (car sub-range1) (cdr sub-range1)))))) + result)) + +(defun numscope-plus (range0 range1) + "Return the numscope that covers the sum of any element of range0 +and any element of range1." + (numscope-combine (lambda (min0 max0 min1 max1) + (make-numscope (and min0 min1 (+ min0 min1)) + (and max0 max1 (+ max0 max1)))) + range0 range1)) ;;; (defparameter *tb-bitmap* - '(hash-table character function cons keyword symbol vector array :tail) + '(hash-table character function cons keyword symbol vector array integer :tail) "The union of these types must be t.") (defun basic-typep (x type) @@ -253,37 +271,11 @@ (case x (symbol (logior code (code 'keyword))) (array (logior code (code 'vector))) + ;; (number (logior code (code 'integer))) (t code))))))) (reduce #'logior (mapcar #'code types) :initial-value (code first-type))))) -(defun type-values (codes &key integer-range members include complement) - ;; Members: A list of objects explicitly included in type. - ;; Include: A list of (non-encodable) type-specs included in type. - (check-type include list) - (check-type members list) - (check-type integer-range list) - (let ((new-intscope integer-range) - (new-members ())) - (dolist (member members) ; move integer members into integer-range - (let ((member (movitz-read member))) - (etypecase member - (movitz-fixnum - (setf new-intscope - (numscope-union new-intscope - (make-numscope (movitz-fixnum-value member) - (movitz-fixnum-value member))))) - (movitz-object - (pushnew member new-members :test #'movitz-eql))))) - (let ((new-code (if (atom codes) - (type-code codes) - (apply #'type-code codes)))) - (values new-code - new-intscope - new-members - include - complement)))) - (defun encoded-type-decode (code integer-range members include complement) (if (let ((mask (1- (ash 1 (position :tail *tb-bitmap*))))) (= mask (logand mask code))) @@ -313,6 +305,38 @@ (t (if (not complement) (cons 'or sub-specs) (list 'not (cons 'or sub-specs)))))))) + +(defun type-values (codes &key integer-range members include complement) + ;; Members: A list of objects explicitly included in type. + ;; Include: A list of (non-encodable) type-specs included in type. + (check-type include list) + (check-type members list) + (check-type integer-range list) + (let ((new-intscope integer-range) + (new-members ())) + (dolist (member members) ; move integer members into integer-range + (let ((member (movitz-read member))) + (etypecase member + (movitz-fixnum + (setf new-intscope + (numscope-union new-intscope + (make-numscope (movitz-fixnum-value member) + (movitz-fixnum-value member))))) + (movitz-object + (pushnew member new-members :test #'movitz-eql))))) + (let ((new-code (logior (if (atom codes) + (type-code codes) + (apply #'type-code codes)) + (if (numscope-allp new-intscope) + (type-code 'integer) + 0)))) + (values new-code + (if (type-code-p 'integer new-code) + (make-numscope nil nil) + new-intscope) + new-members + include + complement)))) (defun star-is-t (x) (if (eq x '*) t x)) @@ -330,9 +354,13 @@ ((typep x 'movitz-nil) (type-code-p 'symbol code)) ((basic-typep x 'fixnum) - (numscope-memberp integer-range (movitz-fixnum-value x))) + (or (type-code-p 'integer code) + (and integer-range + (numscope-memberp integer-range (movitz-fixnum-value x))))) ((basic-typep x 'bignum) - (numscope-memberp integer-range (movitz-bignum-value x))) + (or (type-code-p 'integer code) + (and integer-range + (numscope-memberp integer-range (movitz-bignum-value x))))) (t (dolist (bt '(symbol character function cons hash-table vector) (error "Cant decide typep for ~S." x)) (when (basic-typep x bt) @@ -411,9 +439,13 @@ (values code0 integer-range0 members0 include0 complement0)) ((and (not complement0) (not complement1)) (let* ((new-inumscope (numscope-union integer-range0 integer-range1)) - (new-code (logior code0 code1))) + (new-code (logior code0 code1 (if (numscope-allp new-inumscope) + (type-code 'integer) + 0)))) (values new-code - new-inumscope + (if (type-code-p 'integer new-code) + nil + new-inumscope) (remove-if (lambda (x) (or (encoded-typep nil t x code0 integer-range0 nil include0 nil) (encoded-typep nil t x code1 integer-range1 nil include1 nil))) @@ -443,10 +475,8 @@ (bignum (type-specifier-encode `(or (integer * ,(1- +movitz-most-negative-fixnum+)) (integer ,(1+ +movitz-most-positive-fixnum+) *)))) - ((t nil cons symbol keyword function array vector hash-table character) + ((t nil cons symbol keyword function array vector integer hash-table character) (type-values type-specifier)) - ((integer) - (type-values () :integer-range (make-numscope))) (null (type-values () :members '(nil))) (list @@ -573,10 +603,10 @@ (values nil t)) (t (values nil nil)))) -(defun encoded-integerp (code integer-range members include complement) - "Is the encoded-type a subset/subtype of integer?" - (declare (ignore integer-range)) - (and (= 0 code) (null members) (null include) (not complement))) +(defun encoded-numscope (code integer-range) + (if (type-code-p 'integer code) + (make-numscope nil nil) + integer-range)) (defun encoded-subtypep (code0 integer-range0 members0 include0 complement0 code1 integer-range1 members1 include1 complement1) @@ -601,17 +631,13 @@ (and (not all1) confident))) ;; type0 is t, and type1 isn't. (result-is nil t)) - ((and (encoded-integerp code0 integer-range0 members0 include0 complement0) - (not complement1) - (numscope-subsetp integer-range0 integer-range1)) - ;; type0 is an integer type which is included in type1. - (result-is t t)) ((and (not complement0) (not complement1)) (dolist (st *tb-bitmap*) (when (type-code-p st code0) (unless (type-code-p st code1) (result-is nil t)))) - (unless (numscope-subsetp integer-range0 integer-range1) + (unless (numscope-subsetp (encoded-numscope code0 integer-range0) + (encoded-numscope code1 integer-range1)) (result-is nil t)) (dolist (m members0) (ecase (encoded-typep nil :unknown m code1 integer-range1 members1 include1 nil) @@ -643,8 +669,26 @@ ((and (null members) (null intscope)) (warn "Not singleton, nulloton.")))) -(defun movitz-subtypep (type1 type2) +(defun movitz-subtypep (type0 type1) "Compile-time subtypep." (multiple-value-call #'encoded-subtypep - (type-specifier-encode type1) - (type-specifier-encode type2))) + (type-specifier-encode type0) + (type-specifier-encode type1))) + +(defun encoded-integer-types-add (code0 integer-range0 members0 include0 complement0 + code1 integer-range1 members1 include1 complement1) + "Return the integer type that can result from adding a member of type0 to a member of type1." + (declare (ignore members0 members1)) + (cond + ((or include0 include1) + ;; We can't know.. + 'integer) + ((or complement0 complement1) + (break "adding complement types..?")) + (t (let ((integer-range (numscope-plus (encoded-numscope code0 integer-range0) + (encoded-numscope code1 integer-range1)))) + (encoded-type-decode (if (not (numscope-allp integer-range)) + 0 + (type-code 'integer)) + integer-range + nil nil nil)))))

1 0