[movitz-cvs] CVS update: movitz/compiler.lisp
Frode Vatvedt Fjeld
ffjeld at common-lisp.net
Thu Feb 12 21:57:05 UTC 2004
Update of /project/movitz/cvsroot/movitz
In directory common-lisp.net:/tmp/cvs-serv29059
Modified Files:
compiler.lisp
Log Message:
These changes adds type-inference for incf-like operations. Many
dynamic type-checks for integer type are removed from code, in dotimes
loops etc.
Date: Thu Feb 12 16:57:05 2004
Author: ffjeld
Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.22 movitz/compiler.lisp:1.23
--- movitz/compiler.lisp:1.22 Thu Feb 12 12:54:24 2004
+++ movitz/compiler.lisp Thu Feb 12 16:57:05 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.22 2004/02/12 17:54:24 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.23 2004/02/12 21:57:05 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -349,6 +349,9 @@
(setf (gethash binding binding-usage)
(make-type-analysis)))))
(cond
+ ((typep binding 'function-argument)
+ (setf (type-analysis-encoded-type analysis)
+ (multiple-value-list (type-specifier-encode t))))
((and (consp type) (eq 'binding-type (car type)))
(let ((target-binding (binding-target (cadr type))))
(cond
@@ -382,60 +385,58 @@
(loop for function-binding in (sub-function-binding-usage funobj) by #'cddr
do (analyze-funobj (function-binding-funobj function-binding)))
funobj))
-;;; ;; 1. Examine each store to lexical bindings.
-;;; (analyze-funobj toplevel-funobj)
-;;; ;; 2.
-;;; (loop repeat 10 while more-binding-references-p
-;;; doing
-;;; (setf more-binding-references-p nil)
-;;; (maphash (lambda (binding analysis)
-;;; (dolist (target-binding (type-analysis-binding-types analysis))
-;;; (let* ((target-analysis
-;;; (or (gethash target-binding binding-usage)
-;;; (and (typep target-binding 'function-argument)
-;;; (make-type-analysis
-;;; :encoded-type (multiple-value-list
-;;; (type-specifier-encode t))))
-;;; (error "Type-reference by ~S to unknown binding ~S"
-;;; binding target-binding)))
-;;; (new-type (setf (type-analysis-encoded-type analysis)
-;;; (multiple-value-list
-;;; (multiple-value-call
-;;; #'encoded-types-or
-;;; (values-list
-;;; (type-analysis-encoded-type analysis))
-;;; (values-list
-;;; (type-analysis-encoded-type target-analysis)))))))
-;;; (cond
-;;; ((apply #'encoded-allp new-type)
-;;; ;; If the type is already T, no need to look further.
-;;; (setf (type-analysis-binding-types analysis) nil))
-;;; ((setf (type-analysis-binding-types analysis)
-;;; (remove target-binding
-;;; (remove binding
-;;; (union (type-analysis-binding-types analysis)
-;;; (type-analysis-binding-types target-analysis)))))
-;;; (setf more-binding-references-p t))))))
-;;; binding-usage))
-;;; (when more-binding-references-p
-;;; (warn "Unable to remove all binding-references duding lexical type analysis."))
-;;; ;; 3.
-;;; (maphash (lambda (binding analysis)
-;;; (assert (null (type-analysis-binding-types analysis)) ()
-;;; "binding ~S type ~S still refers to ~S"
-;;; binding
-;;; (apply #'encoded-type-decode (type-analysis-encoded-type analysis))
-;;; (type-analysis-binding-types analysis))
-;;; (setf (binding-store-type binding)
-;;; (type-analysis-encoded-type analysis))
-;;; (unless (apply #'encoded-allp (type-analysis-encoded-type analysis))
-;;; (warn "Type: ~A => ~A"
-;;; (binding-name binding)
-;;; (apply #'encoded-type-decode (type-analysis-encoded-type analysis))))
-;;; #+ignore (warn "binding: ~S~% types: ~S"
-;;; binding
-;;; (apply #'encoded-type-decode (type-analysis-encoded-type analysis))))
-;;; binding-usage)
+ ;; 1. Examine each store to lexical bindings.
+ (analyze-funobj toplevel-funobj)
+ ;; 2.
+ (loop repeat 10 while more-binding-references-p
+ doing
+ (setf more-binding-references-p nil)
+ (maphash (lambda (binding analysis)
+ (dolist (target-binding (type-analysis-binding-types analysis))
+ (let* ((target-analysis
+ (or (gethash target-binding binding-usage)
+ (and (typep target-binding 'function-argument)
+ (make-type-analysis
+ :encoded-type (multiple-value-list
+ (type-specifier-encode t))))
+ (error "Type-reference by ~S to unknown binding ~S"
+ binding target-binding)))
+ (new-type (setf (type-analysis-encoded-type analysis)
+ (multiple-value-list
+ (multiple-value-call
+ #'encoded-types-or
+ (values-list
+ (type-analysis-encoded-type analysis))
+ (values-list
+ (type-analysis-encoded-type target-analysis)))))))
+ (cond
+ ((apply #'encoded-allp new-type)
+ ;; If the type is already T, no need to look further.
+ (setf (type-analysis-binding-types analysis) nil))
+ ((setf (type-analysis-binding-types analysis)
+ (remove target-binding
+ (remove binding
+ (union (type-analysis-binding-types analysis)
+ (type-analysis-binding-types target-analysis)))))
+ (setf more-binding-references-p t))))))
+ binding-usage))
+ (when more-binding-references-p
+ (warn "Unable to remove all binding-references duding lexical type analysis."))
+ ;; 3.
+ (maphash (lambda (binding analysis)
+ (assert (null (type-analysis-binding-types analysis)) ()
+ "binding ~S type ~S still refers to ~S"
+ binding
+ (apply #'encoded-type-decode (type-analysis-encoded-type analysis))
+ (type-analysis-binding-types analysis))
+ (setf (binding-store-type binding)
+ (type-analysis-encoded-type analysis))
+ #+ignore
+ (unless (apply #'encoded-allp (type-analysis-encoded-type analysis))
+ (warn "Type: ~A => ~A"
+ (binding-name binding)
+ (apply #'encoded-type-decode (type-analysis-encoded-type analysis)))))
+ binding-usage)
toplevel-funobj)))
(defun resolve-borrowed-bindings (toplevel-funobj)
@@ -5337,17 +5338,47 @@
(declare (ignore delta))
(values binding 'integer)))
+(define-find-read-bindings :incf-lexvar (binding delta)
+ (declare (ignore delta))
+ binding)
+
(define-extended-code-expander :incf-lexvar (instruction funobj frame-map)
- (declare (ignore funobj))
(destructuring-bind (binding delta)
(cdr instruction)
(check-type binding binding)
(check-type delta integer)
- (let ((location (new-binding-location binding frame-map)))
- (assert location)
- (warn "incf type: ~S location: ~S"
- (binding-store-type binding)
- location)
- `((:addl ,(* delta +movitz-fixnum-factor+)
- (:ebp ,(stack-frame-offset location)))
- (:into)))))
+ (let* ((binding (binding-target binding))
+ (location (new-binding-location binding frame-map :default nil)))
+ (assert (= 5 (length (binding-store-type binding))) ()
+ "Weird encoded-type: ~S" (binding-store-type binding))
+ (cond
+ ((and location
+ (multiple-value-call #'encoded-subtypep
+ (values-list (binding-store-type binding))
+ (type-specifier-encode 'integer)))
+ #+ignore
+ (warn "incf ~S type: ~S location: ~S"
+ binding
+ (apply #'encoded-type-decode (binding-store-type binding))
+ location)
+ (check-type location (integer 1 *))
+ `((:addl ,(* delta +movitz-fixnum-factor+)
+ (:ebp ,(stack-frame-offset location)))
+ (:into)))
+ ((multiple-value-call #'encoded-subtypep
+ (values-list (binding-store-type binding))
+ (type-specifier-encode 'integer))
+ `(,@(make-load-lexical (ensure-local-binding binding funobj) :eax funobj nil frame-map)
+ (:addl ,(* delta +movitz-fixnum-factor+) :eax)
+ (:into)
+ ,@(make-store-lexical (ensure-local-binding binding funobj)
+ :eax nil frame-map)))
+ (t `(,@(make-load-lexical (ensure-local-binding binding funobj) :eax funobj nil frame-map)
+ (:testb ,+movitz-fixnum-zmask+ :al)
+ (:jnz '(:sub-program (,(gensym "not-integer-"))
+ (:int 107)
+ (:jmp (:pc+ -4))))
+ (:addl ,(* delta +movitz-fixnum-factor+) :eax)
+ (:into)
+ ,@(make-store-lexical (ensure-local-binding binding funobj) :eax nil frame-map)))))))
+
More information about the Movitz-cvs
mailing list