Update of /project/movitz/cvsroot/movitz
In directory common-lisp.net:/tmp/cvs-serv10944
Modified Files:
compiler.lisp
Log Message:
Changed (and hopefully improved) the type-inference logic quite a bit.
Date: Thu Aug 12 10:25:07 2004
Author: ffjeld
Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.92 movitz/compiler.lisp:1.93
--- movitz/compiler.lisp:1.92 Tue Aug 10 05:56:12 2004
+++ movitz/compiler.lisp Thu Aug 12 10:25:06 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.92 2004/08/10 12:56:12 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.93 2004/08/12 17:25:06 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -74,6 +74,8 @@
(defvar *compiler-produce-defensive-code* t
"Try make code be extra cautious.")
+(defvar *compiler-trust-user-type-declarations-p* t)
+
(defvar *compiling-function-name*)
(defvar muerte.cl:*compile-file-pathname* nil)
@@ -360,25 +362,36 @@
(thunks)
(binding-types)
(encoded-type
- (multiple-value-list (type-specifier-encode nil))))
+ (multiple-value-list (type-specifier-encode nil)))
+ (declared-encoded-type
+ (multiple-value-list (type-specifier-encode t))))
+
+(defun make-type-analysis-with-declaration (binding)
+ (let ((declared-type
+ (if (not (and *compiler-trust-user-type-declarations-p*
+ (movitz-env-get (binding-name binding) :variable-type
+ nil (binding-env binding) nil)))
+ (multiple-value-list (type-specifier-encode t))
+ (multiple-value-list
+ (type-specifier-encode (movitz-env-get (binding-name binding) :variable-type
+ t (binding-env binding) nil))))))
+ ;; (warn "~S decl: ~A" binding (apply #'encoded-type-decode declared-type))
+ (make-type-analysis :declared-encoded-type declared-type)))
(defun analyze-bindings (toplevel-funobj)
"Figure out usage of bindings in a toplevel funobj.
Side-effects each binding's binding-store-type."
(when *compiler-do-type-inference*
- (let ((more-binding-references-p nil)
- (binding-usage (make-hash-table :test 'eq)))
+ (let ((binding-usage (make-hash-table :test 'eq)))
(labels ((binding-resolved-p (binding)
(let ((analysis (gethash binding binding-usage)))
(and analysis
- (null (type-analysis-binding-types analysis))
(null (type-analysis-thunks analysis)))))
(binding-resolve (binding)
(if (not (bindingp binding))
binding
(let ((analysis (gethash binding binding-usage)))
(assert (and (and analysis
- (null (type-analysis-binding-types analysis))
(null (type-analysis-thunks analysis))))
(binding)
"Can't resolve unresolved binding ~S." binding)
@@ -395,49 +408,63 @@
(assert (or (typep type 'binding)
(eql 1 (type-specifier-num-values type))) ()
"store-lexical with multiple-valued type: ~S for ~S" type binding)
+ ;; (warn "store ~S type ~S, thunk ~S" binding type thunk)
(let ((analysis (or (gethash binding binding-usage)
(setf (gethash binding binding-usage)
- (make-type-analysis)))))
+ (make-type-analysis-with-declaration binding)))))
(cond
(thunk
(assert (some #'bindingp thunk-args))
+;;; (assert (notany (lambda (arg)
+;;; (and (bindingp arg)
+;;; (binding-eql arg binding)))
+;;; thunk-args)
+;;; () "A thunk on itself for ~S?" binding)
(push (cons thunk thunk-args) (type-analysis-thunks analysis)))
- ((typep binding 'function-argument)
- (setf (type-analysis-encoded-type analysis)
- (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
- ((eq binding target-binding))
- ((typep binding 'constant-object-binding)
- (setf (type-analysis-encoded-type analysis)
- (multiple-value-list
- (multiple-value-call
- #'encoded-types-or
- (values-list (type-analysis-encoded-type analysis))
- (member-type-encode (constant-object target-binding))))))
- (t (pushnew target-binding (type-analysis-binding-types analysis))
- (setf more-binding-references-p t)))))
+;;; ((typep binding 'function-argument)
+;;; (setf (type-analysis-encoded-type analysis)
+;;; (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)))
+;;; (break "Got binding-type.")
+;;; (let ((target-binding (binding-target (cadr type))))
+;;; (cond
+;;; ((eq binding target-binding))
+;;; ((typep binding 'constant-object-binding)
+;;; (setf (type-analysis-encoded-type analysis)
+;;; (multiple-value-list
+;;; (multiple-value-call
+;;; #'encoded-types-or
+;;; (values-list (type-analysis-encoded-type analysis))
+;;; (member-type-encode (constant-object target-binding))))))
+;;; (t (pushnew target-binding (type-analysis-binding-types analysis))
+;;; ))))
((and (bindingp type)
(binding-eql type binding))
+ (break "got binding type")
nil)
(t (setf (type-analysis-encoded-type analysis)
(multiple-value-list
(multiple-value-call
#'encoded-types-or
(values-list (type-analysis-encoded-type analysis))
- (type-specifier-encode type))))))))
+ (type-specifier-encode type)))))))
+ #+ignore
+ (when (typep binding 'forwarding-binding)
+ (analyze-store (forwarding-binding-target binding) type thunk thunk-args)))
(analyze-code (code)
(dolist (instruction code)
(when (listp instruction)
(multiple-value-bind (store-binding store-type thunk thunk-args)
(find-written-binding-and-type instruction)
(when store-binding
- (analyze-store (binding-target store-binding) store-type thunk thunk-args)))
+ #+ignore
+ (warn "store: ~S binding ~S type ~S thunk ~S"
+ instruction store-binding store-type thunk)
+ (analyze-store store-binding store-type thunk thunk-args)))
(analyze-code (instruction-sub-program instruction)))))
(analyze-funobj (funobj)
(loop for (nil . function-env) in (function-envs funobj)
@@ -448,88 +475,78 @@
;; 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)
- (setf (type-analysis-thunks analysis)
- (remove-if (lambda (x)
- (destructuring-bind (thunk . thunk-args) x
- (when (every (lambda (arg)
- (or (not (bindingp arg))
- (binding-resolved-p arg)))
- thunk-args)
- (setf more-binding-references-p t)
- (setf (type-analysis-encoded-type analysis)
+ (flet ((resolve-thunks ()
+ (loop with more-thunks-p = t
+ repeat 20
+ finally (return t)
+ do (unless more-thunks-p
+ (return nil))
+ (setf more-thunks-p nil)
+ (maphash (lambda (binding analysis)
+ (declare (ignore binding))
+ (setf (type-analysis-thunks analysis)
+ (loop for (thunk . thunk-args) in (type-analysis-thunks analysis)
+ if (not (every #'binding-resolved-p thunk-args))
+ collect (cons thunk thunk-args)
+ else
+ do (setf (type-analysis-encoded-type analysis)
(multiple-value-list
(multiple-value-call
- #'encoded-types-or
+ #'encoded-types-and
(values-list
- (type-analysis-encoded-type analysis))
- (type-specifier-encode
- (apply thunk (mapcar #'binding-resolve
- thunk-args)))))))))
- (type-analysis-thunks 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 during lexical type analysis."))
+ (type-analysis-declared-encoded-type analysis))
+ (multiple-value-call
+ #'encoded-types-or
+ (values-list
+ (type-analysis-encoded-type analysis))
+ (type-specifier-encode
+ (apply thunk (mapcar #'binding-resolve
+ thunk-args)))))))
+ (setf more-thunks-p t))))
+ binding-usage))))
+ (when (and (resolve-thunks)
+ *compiler-trust-user-type-declarations-p*)
+ ;; For each unresolved binding, just use the declared type.
+ (maphash (lambda (binding analysis)
+ (declare (ignore binding))
+ (when (and (not (null (type-analysis-thunks analysis)))
+ (not (apply #'encoded-allp
+ (type-analysis-declared-encoded-type analysis))))
+ (setf (type-analysis-encoded-type analysis)
+ (type-analysis-declared-encoded-type analysis))
+ (setf (type-analysis-thunks analysis) nil))) ; Ignore remaining thunks.
+ binding-usage)
+ ;; Try one more time to resolve thunks.
+ (resolve-thunks)))
+ #+ignore
+ (maphash (lambda (binding analysis)
+ (when (type-analysis-thunks analysis)
+ (warn "Unable to infer type for ~S: ~S" binding
+ (type-analysis-thunks analysis))))
+ binding-usage)
;; 3.
(maphash (lambda (binding analysis)
-;;; (loop for (nil . thunk-args) in (type-analysis-thunks analysis)
-;;; do (warn "Unable to thunk ~S with args ~S." binding thunk-args))
- (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)
(cond
+ ((and (not (null (type-analysis-thunks analysis)))
+ *compiler-trust-user-type-declarations-p*
+ (movitz-env-get (binding-name binding) :variable-type nil
+ (binding-env binding) nil))
+ (multiple-value-list
+ (type-specifier-encode (movitz-env-get (binding-name binding) :variable-type
+ t (binding-env binding) nil))))
+ ((and *compiler-trust-user-type-declarations-p*
+ (movitz-env-get (binding-name binding) :variable-type nil
+ (binding-env binding) nil))
+ (multiple-value-list
+ (multiple-value-call #'encoded-types-and
+ (type-specifier-encode (movitz-env-get (binding-name binding) :variable-type
+ t (binding-env binding) nil))
+ (values-list (type-analysis-encoded-type analysis)))))
((not (null (type-analysis-thunks analysis)))
-;;; (when (not (rest (type-analysis-thunks analysis)))
-;;; (warn "One thunk: ~S for ~S" binding (first (type-analysis-thunks analysis))))
(multiple-value-list (type-specifier-encode t)))
(t (type-analysis-encoded-type analysis))))
- #+ignore
- (when (apply #'encoded-type-singleton (type-analysis-encoded-type analysis))
- (warn "Singleton: ~A" binding))
- #+ignore
- (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)))
- (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)))))
+ #+ignore (warn "Finally: ~S" binding))
binding-usage))))
toplevel-funobj)
@@ -555,10 +572,9 @@
'forwarding-binding)
(change-class (borrowed-binding-target borrowing-binding)
'located-binding))
- #+ignore
- (warn "binding ~S of ~S is not local to ~S, replacing with ~S of ~S."
- binding (binding-env binding) funobj
- borrowing-binding (binding-env borrowing-binding))
+;;; (warn "binding ~S of ~S is not local to ~S, replacing with ~S of ~S."
+;;; binding (binding-env binding) funobj
+;;; borrowing-binding (binding-env borrowing-binding))
(pushnew borrowing-binding
(getf (binding-lended-p binding) :lended-to))
(dolist (usage usages)
@@ -5821,24 +5837,28 @@
(list extended-instruction)
(let* ((operator (car extended-instruction))
(expander (gethash operator *extended-code-expanders*)))
- (if expander
- (funcall expander extended-instruction funobj frame-map)
- (list extended-instruction)))))
+ (if (not expander)
+ (list extended-instruction)
+ (let ((expansion (funcall expander extended-instruction funobj frame-map)))
+ (mapcan (lambda (e)
+ (expand-extended-code e funobj frame-map))
+ expansion))))))
(defun ensure-local-binding (binding funobj)
"When referencing binding in funobj, ensure we have the binding local to funobj."
(if (not (typep binding 'binding))
binding
- (let ((binding (binding-target binding)))
+ (let ((target-binding (binding-target binding)))
(cond
- ((eq funobj (binding-funobj binding))
+ ((eq funobj (binding-funobj target-binding))
binding)
- (t (or (find binding (borrowed-bindings funobj)
+ (t (or (find target-binding (borrowed-bindings funobj)
:key (lambda (binding)
(borrowed-binding-target binding)))
(error "Can't install non-local binding ~W." binding)))))))
(defun binding-type-specifier (binding)
+ (break "nix binding-type-specifier: ~S" binding)
(etypecase binding
(forwarding-binding
(binding-type-specifier (forwarding-binding-target binding)))
@@ -5867,7 +5887,10 @@
(destructuring-bind (source destination &key &allow-other-keys)
(cdr instruction)
(when (typep destination 'binding)
- (values destination (binding-type-specifier source)))))
+ (values destination t #+ignore (binding-type-specifier source)
+ (lambda (source-type)
+ source-type)
+ (list source)))))
(define-find-read-bindings :load-lexical (source destination &key &allow-other-keys)
(declare (ignore destination))
@@ -5927,8 +5950,13 @@
(declare (ignore protect-registers protect-carry))
(cond
(init-with-register
- (assert init-with-type)
- (values binding init-with-type))
+ (cond
+ ((not (typep init-with-register 'binding))
+ (assert init-with-type)
+ (values binding init-with-type) )
+ (t (values binding t
+ (lambda (x) x)
+ (list init-with-register)))))
((not (typep binding 'temporary-name))
(values binding t)))))
@@ -5942,8 +5970,6 @@
init-with-register init-with-type)
(cdr instruction)
(declare (ignore protect-carry)) ; nothing modifies carry anyway.
- (when (string= (binding-name binding) 'reader-function)
- (break "init: ~S" instruction))
;; (assert (eq binding (ensure-local-binding binding funobj)))
(assert (eq funobj (binding-funobj binding)))
(cond
@@ -6049,6 +6075,8 @@
(:movl ,tmp-register
(:ebp ,(stack-frame-offset
(new-binding-location binding frame-map))))))))
+ ((typep init-with-register 'lexical-binding)
+ (make-load-lexical init-with-register binding funobj nil frame-map))
(init-with-register
(make-store-lexical binding init-with-register nil frame-map))))))))
@@ -6239,41 +6267,59 @@
(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)))
+ (let* ((destination (ensure-local-binding destination funobj))
+ (term0 (ensure-local-binding term0 funobj))
+ (term1 (ensure-local-binding term1 funobj))
+ (destination-location (if (or (not (bindingp destination))
+ (typep destination 'borrowed-binding))
+ destination
+ (new-binding-location (binding-target 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)))
+;;; (warn "add: ~A" instruction)
+;;; (warn "add for: ~S is ~A, from ~A/~A and ~A/~A."
+;;; destination result-type
+;;; term0 loc0
+;;; term1 loc1)
(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)
+ ((and (movitz-subtypep type0 'fixnum)
(movitz-subtypep type1 'fixnum)
(movitz-subtypep result-type 'fixnum))
(cond
((and (type-specifier-singleton type0)
- (eq loc1 destination))
+ (eq loc1 destination-location))
(cond
- ((member destination '(:eax :ebx :ecx :edx))
+ ((member destination-location '(: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)))))))
+ ((and (type-specifier-singleton type0)
+ (eq term1 destination)
+ (integerp destination-location))
+ (break "untested")
+ `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0)))
+ (:ebp ,(stack-frame-offset destination-location)))))
+ ((and (type-specifier-singleton type0)
+ (symbolp loc1)
+ (integerp destination-location))
+ `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0)))
+ ,loc1)
+ (:movl ,loc1 (:ebp ,(stack-frame-offset destination-location)))))
(t
-;;; (warn "ADD: ~S = ~A/~S + ~A/~S,~%~A ~A"
+;;; (warn "ADD: ~A/~S = ~A/~S + ~A/~S,~%~A ~A"
+;;; destination-location
;;; destination
;;; loc0 term0
;;; loc1 term1
@@ -6281,24 +6327,24 @@
;;; (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)))))))
+ ((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)
