[movitz-cvs] CVS update: movitz/compiler.lisp
Frode Vatvedt Fjeld
ffjeld at common-lisp.net
Sat Feb 14 15:44:32 UTC 2004
Update of /project/movitz/cvsroot/movitz
In directory common-lisp.net:/tmp/cvs-serv8428
Modified Files:
compiler.lisp
Log Message:
Minor edits, mostly related to type-inference.
Date: Sat Feb 14 10:44:32 2004
Author: ffjeld
Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.25 movitz/compiler.lisp:1.26
--- movitz/compiler.lisp:1.25 Fri Feb 13 17:05:04 2004
+++ movitz/compiler.lisp Sat Feb 14 10:44:32 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.25 2004/02/13 22:05:04 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.26 2004/02/14 15:44:32 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -357,7 +357,11 @@
(cond
((typep binding 'function-argument)
(setf (type-analysis-encoded-type analysis)
- (multiple-value-list (type-specifier-encode t))))
+ (multiple-value-list
+ (type-specifier-encode (etypecase binding
+ (rest-function-argument 'list)
+ (supplied-p-function-argument 'boolean)
+ (function-argument t))))))
((and (consp type) (eq 'binding-type (car type)))
(let ((target-binding (binding-target (cadr type))))
(cond
@@ -437,11 +441,17 @@
(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)))))
+ (when (or #+ignore (not (apply #'encoded-allp (type-analysis-encoded-type analysis)))
+ (multiple-value-call #'encoded-subtypep
+ (values-list (type-analysis-encoded-type analysis))
+ (type-specifier-encode 'list)))
+ #+ignore
+ (warn "Type: ~S => ~A (~A)"
+ binding
+ (apply #'encoded-type-decode (type-analysis-encoded-type analysis))
+ (multiple-value-call #'encoded-subtypep
+ (values-list (type-analysis-encoded-type analysis))
+ (type-specifier-encode 'list)))))
binding-usage))))
toplevel-funobj)
@@ -494,9 +504,8 @@
(let ((store-binding (find-written-binding-and-type instruction)))
(when store-binding
(process-binding funobj store-binding '(:read))))
- (let ((load-binding (find-read-bindings instruction)))
- (when load-binding
- (process-binding funobj load-binding '(:read))))
+ (dolist (load-binding (find-read-bindings instruction))
+ (process-binding funobj load-binding '(:read)))
(case (car instruction)
(:call-lexical
(process-binding funobj (second instruction) '(:call)))
@@ -1167,7 +1176,7 @@
(declare (special *default-load-priority*))
(with-simple-restart (continue "Skip Movitz compilation of ~S." path)
(with-retries-until-true (retry "Restart Movitz compilation of ~S." path)
- (warn "Compiling ~A.." path)
+ ;; (warn "Compiling ~A.." path)
(let* ((muerte.cl::*compile-file-pathname* path)
(*package* (find-package :muerte))
(funobj (make-instance 'movitz-funobj-pass1
@@ -2423,9 +2432,8 @@
(incf (getf p :lended-count 0))
(setf (getf p :dynamic-extent-p) (and (getf p :dynamic-extent-p t)
dynamic-extent-p))))))
- (let ((load-binding (find-read-bindings instruction)))
- (when load-binding
- (take-note-of-binding load-binding)))
+ (mapcar #'take-note-of-binding
+ (find-read-bindings instruction))
(let ((store-binding (find-written-binding-and-type instruction)))
(when store-binding
(take-note-of-binding store-binding t)))
@@ -2579,9 +2587,9 @@
(dolist (instruction code)
(when (consp instruction)
(let ((x (or (when load
- (let ((load-binding (find-read-bindings instruction)))
- (when load-binding
- (binding-eql binding load-binding))))
+ (some (lambda (read-binding)
+ (binding-eql read-binding binding))
+ (find-read-bindings instruction)))
(when store
(let ((store-binding (find-written-binding-and-type instruction)))
(when store-binding
@@ -5174,7 +5182,9 @@
(let* ((operator (car extended-instruction))
(finder (gethash operator *extended-code-find-read-binding*)))
(when finder
- (funcall finder extended-instruction)))))
+ (let ((result (funcall finder extended-instruction)))
+ (check-type result list "a list of read bindings")
+ result)))))
(defvar *extended-code-find-write-binding-and-type*
(make-hash-table :test #'eq))
@@ -5235,6 +5245,15 @@
(binding
`(binding-type ,binding))))
+(defun binding-store-subtypep (binding type-specifier)
+ "Is type-specifier a subtype 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
+ (multiple-value-call #'encoded-subtypep
+ (values-list (binding-store-type binding))
+ (type-specifier-encode type-specifier))))
+
;;;;;;;
;;;;;;; Extended-code handlers
;;;;;;;
@@ -5251,7 +5270,7 @@
(define-find-read-bindings :load-lexical (source destination &key &allow-other-keys)
(declare (ignore destination))
(check-type source binding)
- source)
+ (list source))
(define-extended-code-expander :load-lexical (instruction funobj frame-map)
(destructuring-bind (source destination &key shared-reference-p tmp-register protect-registers)
@@ -5272,7 +5291,7 @@
(define-find-read-bindings :lmove (source destination)
(declare (ignore destination))
- (values source))
+ (list source))
;;;;;;;;;;;;;;;;;; Store-lexical
@@ -5286,7 +5305,7 @@
(define-find-read-bindings :store-lexical (destination source &key &allow-other-keys)
(declare (ignore destination))
(when (typep source 'binding)
- source))
+ (list source)))
(define-extended-code-expander :store-lexical (instruction funobj frame-map)
(destructuring-bind (destination source &key shared-reference-p type)
@@ -5338,18 +5357,27 @@
;;;;;;;;;;;;;;;;;; car
+(define-find-read-bindings :car (x dst &key protect-registers)
+ (declare (ignore dst protect-registers))
+ (when (typep x 'binding)
+ (list x)))
(define-extended-code-expander :car (instruction funobj frame-map)
- (declare (ignore funobj frame-map))
+ (warn "CAR: ~S" instruction)
(destructuring-bind (x dst)
(cdr instruction)
(assert (member dst '(:eax :ebx :ecx :edx)))
(etypecase x
(binding
- `((:load-lexical ,x :eax)
- (:call (:edi ,(global-constant-offset 'fast-car)))
- ,@(when (not (eq dst :eax))
- `((:movl :eax ,dst)))))
+ (let* ((binding (ensure-local-binding (binding-target x) funobj)))
+ (cond
+ ((binding-store-subtypep binding 'list)
+ `(,@(make-load-lexical binding dst funobj nil frame-map)
+ (:movl (,dst -1) ,dst)))
+ (t `(,@(make-load-lexical binding dst funobj nil frame-map)
+ (:call (:edi ,(global-constant-offset 'fast-car)))
+ ,@(when (not (eq dst :eax))
+ `((:movl :eax ,dst))))))))
(symbol
(append (case x
(:eax
@@ -5370,8 +5398,8 @@
(values binding 'integer)))
(define-find-read-bindings :incf-lexvar (binding delta &key protect-registers)
- (declare (ignore delta protect-registers))
- nil #+ignore binding)
+ (declare (ignore delta protect-registers binding))
+ nil)
(define-extended-code-expander :incf-lexvar (instruction funobj frame-map)
(destructuring-bind (binding delta &key protect-registers)
@@ -5385,18 +5413,13 @@
((and binding-type
location
(not (binding-lended-p binding))
- (multiple-value-call #'encoded-subtypep
- (values-list (binding-store-type binding))
- (type-specifier-encode 'integer)))
+ (binding-store-subtypep binding 'integer))
;; This is an optimized incf that doesn't have to do type-checking.
(check-type location (integer 1 *))
`((:addl ,(* delta +movitz-fixnum-factor+)
(:ebp ,(stack-frame-offset location)))
(:into)))
- ((and binding-type
- (multiple-value-call #'encoded-subtypep
- (values-list (binding-store-type binding))
- (type-specifier-encode 'integer)))
+ ((binding-store-subtypep binding 'integer)
(let ((register (chose-free-register protect-registers)))
`(,@(make-load-lexical (ensure-local-binding binding funobj)
register funobj nil frame-map
More information about the Movitz-cvs
mailing list