movitz-cvs

movitz-cvs@common-lisp.net

2595 discussions

[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

[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-serv12846 Modified Files: compiler-types.lisp Log Message: Fixed bug in numscope-add-range. Date: Fri Jul 9 05:48:02 2004 Author: ffjeld Index: movitz/compiler-types.lisp diff -u movitz/compiler-types.lisp:1.16 movitz/compiler-types.lisp:1.17 --- movitz/compiler-types.lisp:1.16 Thu Jul 8 04:27:19 2004 +++ movitz/compiler-types.lisp Fri Jul 9 05:48:01 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.16 2004/07/08 11:27:19 ffjeld Exp $ +;;;; $Id: compiler-types.lisp,v 1.17 2004/07/09 12:48:01 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -118,15 +118,17 @@ (push sub-range new-numscope) (setf new-min (and new-min (min new-min (car sub-range))) new-max nil))) - ((cond + ((cond ; is <new-min, new-max> overlapping sub-range? ((and (not new-min) (not new-max)) t) ((not new-min) (<= (car sub-range) (+ epsilon new-max))) ((not new-max) (<= new-min (+ epsilon (cdr sub-range)))) ((<= (- new-min epsilon) (car sub-range) (+ new-max epsilon)) t) - ((<= (- new-min epsilon) (cdr sub-range) (+ new-max epsilon)) t)) + ((<= (- new-min epsilon) (cdr sub-range) (+ new-max epsilon)) t) + ((<= (car sub-range) new-min (cdr sub-range)))) (setf new-min (and new-min (min new-min (car sub-range))) new-max (and new-max (max new-max (cdr sub-range))))) - (t (push sub-range new-numscope)))) + (t ;; (warn "Unaffected sub-range: ~A for ~D-~D" sub-range new-min new-max) + (push sub-range new-numscope)))) (sort (cons (cons new-min new-max) new-numscope) (lambda (x y) (and x y (< x y)))

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-serv14514 Modified Files: image.lisp Log Message: Removed dead code. Date: Fri Jul 9 04:16:24 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.42 movitz/image.lisp:1.43 --- movitz/image.lisp:1.42 Thu Jul 8 11:53:24 2004 +++ movitz/image.lisp Fri Jul 9 04:16:24 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.42 2004/07/08 18:53:24 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.43 2004/07/09 11:16:24 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -330,38 +330,6 @@ (movitz-read-and-intern (funcall 'muerte::movitz-find-class x) 'word)) :map-binary-read-delayed 'movitz-word) -;;; (the-class-fixnum -;;; :binary-type word -;;; :initform 'fixnum -;;; :map-binary-write (lambda (x type) -;;; (declare (ignore type)) -;;; (movitz-read-and-intern (funcall 'muerte::movitz-find-class x) -;;; 'word)) -;;; :map-binary-read-delayed 'movitz-word) -;;; (the-class-cons -;;; :binary-type word -;;; :initform 'cons -;;; :map-binary-write (lambda (x type) -;;; (declare (ignore type)) -;;; (movitz-read-and-intern (funcall 'muerte::movitz-find-class x) -;;; 'word)) -;;; :map-binary-read-delayed 'movitz-word) -;;; (the-class-null -;;; :binary-type word -;;; :initform 'null -;;; :map-binary-write (lambda (x type) -;;; (declare (ignore type)) -;;; (movitz-read-and-intern (funcall 'muerte::movitz-find-class x) -;;; 'word)) -;;; :map-binary-read-delayed 'movitz-word) -;;; (the-class-symbol -;;; :binary-type word -;;; :initform 'symbol -;;; :map-binary-write (lambda (x type) -;;; (declare (ignore type)) -;;; (movitz-read-and-intern (funcall 'muerte::movitz-find-class x) -;;; 'word)) -;;; :map-binary-read-delayed 'movitz-word) (interrupt-handlers :binary-type word :map-binary-write 'movitz-intern

1 0

[movitz-cvs] CVS update: movitz/losp/los0.lisp
by Frode Vatvedt Fjeld 08 Jul '04

08 Jul '04

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv24544 Modified Files: los0.lisp Log Message: Added top-level command :z that prints word values. Date: Thu Jul 8 14:52:29 2004 Author: ffjeld Index: movitz/losp/los0.lisp diff -u movitz/losp/los0.lisp:1.15 movitz/losp/los0.lisp:1.16 --- movitz/losp/los0.lisp:1.15 Thu Jul 8 11:59:55 2004 +++ movitz/losp/los0.lisp Thu Jul 8 14:52:29 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 1 18:08:32 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: los0.lisp,v 1.15 2004/07/08 18:59:55 ffjeld Exp $ +;;;; $Id: los0.lisp,v 1.16 2004/07/08 21:52:29 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -790,6 +790,15 @@ (format t "~&~Z = ~W" x x)) (t (fresh-line) (write x :radix nil :base (case *print-base* (10 16) (t 10))))) + x)) + (if x-list + (do-print (eval x-list)) + (dolist (x cl:/ (values-list cl:/)) + (do-print x))))) + +(define-toplevel-command :z (&optional x-list) + (flet ((do-print (x) + (format t "~&~Z => ~S" x x) x)) (if x-list (do-print (eval x-list))

1 0

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

08 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv18440 Modified Files: arrays.lisp Log Message: Removed dead code. Date: Thu Jul 8 14:51:48 2004 Author: ffjeld Index: movitz/losp/muerte/arrays.lisp diff -u movitz/losp/muerte/arrays.lisp:1.33 movitz/losp/muerte/arrays.lisp:1.34 --- movitz/losp/muerte/arrays.lisp:1.33 Thu Jul 8 11:53:42 2004 +++ movitz/losp/muerte/arrays.lisp Thu Jul 8 14:51:48 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sun Feb 11 23:14:04 2001 ;;;; -;;;; $Id: arrays.lisp,v 1.33 2004/07/08 18:53:42 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.34 2004/07/08 21:51:48 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -214,10 +214,6 @@ finally (return x))) (:compile-two-forms (:eax :ebx) array index) (:movl (:eax ,movitz:+other-type-offset+) :ecx) -;;; (:cmpb ,(movitz:tag :basic-vector) :cl) -;;; (:jne '(:sub-program (not-vector) -;;; (:compile-form (:result-mode :ignore) -;;; (error "Not an array: ~S." array)))) (:testb ,movitz:+movitz-fixnum-zmask+ :bl) (:jnz '(:sub-program (illegal-index) (:compile-form (:result-mode :ignore)

1 0

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

08 Jul '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv15680 Modified Files: integers.lisp Log Message: Corrected logxor for bignums. Date: Thu Jul 8 14:51:08 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.39 movitz/losp/muerte/integers.lisp:1.40 --- movitz/losp/muerte/integers.lisp:1.39 Thu Jul 8 04:30:20 2004 +++ movitz/losp/muerte/integers.lisp Thu Jul 8 14:51:08 2004 @@ -1,15 +1,15 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 20012000, 2002-2004, +;;;; Copyright (C) 2000-2004, ;;;; Department of Computer Science, University of Tromso, Norway ;;;; ;;;; Filename: integers.lisp -;;;; Description: +;;;; Description: Arithmetics. ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.39 2004/07/08 11:30:20 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.40 2004/07/08 21:51:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1552,12 +1552,14 @@ (with-inline-assembly (:returns :eax) (:compile-two-forms (:eax :ebx) x y) (:xorl :ebx :eax))) + (((eql 0) t) y) + ((t (eql 0)) x) ((positive-fixnum positive-bignum) (macrolet ((do-it () `(let ((r (copy-bignum y))) (with-inline-assembly (:returns :eax) - (:compile-two-forms (:eax :ecx) y x) + (:compile-two-forms (:eax :ecx) r x) (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) (:xorl (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)) :ecx))))) (do-it))) @@ -1572,34 +1574,29 @@ (do-it))) ((positive-bignum positive-bignum) (if (< (%bignum-bigits x) (%bignum-bigits y)) - (logior y x) + (logxor y x) (let ((r (copy-bignum x))) (macrolet ((do-it () - `(with-inline-assembly (:returns :eax) - (:compile-two-forms (:eax :ebx) r y) - (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) - :ecx) - (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) - ,(* -1 movitz:+movitz-fixnum-factor+)) - :edx) ; EDX is loop counter - or-loop - (:movl (:ebx :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)) - :ecx) - (:orl :ecx - (:eax :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) - (:subl 4 :edx) - (:jnc 'or-loop)))) - (do-it)))))) - (number-double-dispatch (x y) - (((eql 0) t) y) - ((t (eql 0)) x) - ((fixnum fixnum) - (with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) x) - (:compile-form (:result-mode :ecx) y) - ;; (:orl #.movitz:+movitz-fixnum-zmask+ :ecx) - (:xorl :ecx :eax))))) + `(%bignum-canonicalize + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) r y) + (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) + :ecx) + (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) + ,(* -1 movitz:+movitz-fixnum-factor+)) + :edx) ; EDX is loop counter + xor-loop + (:movl (:ebx :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)) + :ecx) + (:xorl :ecx + (:eax :edx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) + (:subl 4 :edx) + (:jnc 'xor-loop) + + (:movzxw (:ebx ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) + :ecx))))) + (do-it))))))) (t (&rest integers) (declare (dynamic-extent integers)) (if (null integers)

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

movitz-cvs