Update of /project/movitz/cvsroot/movitz
In directory common-lisp.net:/tmp/cvs-serv7611
Modified Files:
compiler.lisp
Log Message:
Quite a bit of cruft regarding register allocation etc. Still more
work to do here, but I don't have time for it right now..
Date: Wed Jun 9 10:26:00 2004
Author: ffjeld
Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.63 movitz/compiler.lisp:1.64
--- movitz/compiler.lisp:1.63 Tue Jun 8 01:14:15 2004
+++ movitz/compiler.lisp Wed Jun 9 10:26:00 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.63 2004/06/08 08:14:15 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.64 2004/06/09 17:26:00 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -471,6 +471,9 @@
binding-usage))))
toplevel-funobj)
+(defmethod (setf borrowed-bindings) :before (x y)
+ (break "About to set borroweds for ~S to ~S." y x))
+
(defun resolve-borrowed-bindings (toplevel-funobj)
"For <funobj>'s code, for every non-local binding used we create
a borrowing-binding in the funobj-env. This process must be done
@@ -479,23 +482,7 @@
(check-type toplevel-funobj movitz-funobj)
(let ((function-binding-usage ()))
(labels ((process-binding (funobj binding usages)
- (typecase binding
- (forwarding-binding
- (setf (forwarding-binding-target binding)
- (process-binding funobj (forwarding-binding-target binding) usages)))
- (function-binding
- (dolist (usage usages)
- (pushnew usage
- (getf (sub-function-binding-usage (function-binding-parent binding))
- binding))
- (pushnew usage (getf function-binding-usage binding)))))
- (cond
- ((typep binding 'constant-object-binding)
- binding)
- ((eq funobj (binding-funobj binding))
- binding)
- (t #+ignore (warn "binding ~S is not local to ~S [~S])) .." binding funobj
- (mapcar #'borrowed-binding-target (borrowed-bindings funobj)))
+ (if (not (eq funobj (binding-funobj binding)))
(let ((borrowing-binding
(or (find binding (borrowed-bindings funobj)
:key #'borrowed-binding-target)
@@ -504,13 +491,39 @@
:name (binding-name binding)
:target-binding binding))
(borrowed-bindings funobj))))))
+ ;; We don't want to borrow a forwarding-binding..
+ (when (typep (borrowed-binding-target borrowing-binding)
+ '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))
(pushnew borrowing-binding
(getf (binding-lended-p binding) :lended-to))
(dolist (usage usages)
(pushnew usage (borrowed-binding-usage borrowing-binding)))
- borrowing-binding))))
+ borrowing-binding)
+ ;; Binding is local to this funobj
+ (typecase binding
+ (forwarding-binding
+ (setf (forwarding-binding-target binding)
+ (process-binding funobj (forwarding-binding-target binding) usages)))
+ (function-binding
+ (dolist (usage usages)
+ (pushnew usage
+ (getf (sub-function-binding-usage (function-binding-parent binding))
+ binding))
+ (pushnew usage (getf function-binding-usage binding))))
+ (t binding))))
(resolve-sub-funobj (funobj sub-funobj)
(dolist (binding-we-lend (borrowed-bindings (resolve-funobj-borrowing sub-funobj)))
+ #+ignore
+ (warn "Lending from ~S to ~S: ~S <= ~S"
+ funobj sub-funobj
+ (borrowed-binding-target binding-we-lend)
+ binding-we-lend)
(process-binding funobj
(borrowed-binding-target binding-we-lend)
(borrowed-binding-usage binding-we-lend))))
@@ -562,7 +575,8 @@
;;; (multiple-value-bind (toplevel-funobj function-binding-usage)
;;; (resolve-borrowed-bindings toplevel-funobj)
(assert (null (borrowed-bindings toplevel-funobj)) ()
- "Can't deal with toplevel closures yet.")
+ "Can't deal with toplevel closures yet. Borrowed: ~S"
+ (borrowed-bindings toplevel-funobj))
(setf (movitz-funobj-extent toplevel-funobj) :indefinite-extent)
(let ((sub-funobj-index 0))
(loop for (function-binding usage) on function-binding-usage by #'cddr
@@ -2371,7 +2385,7 @@
(list new-value)
`(let ((,(car stores) (progn
(assert (not (new-binding-located-p ,binding-var ,getter)))
- (check-type ,new-value (or keyword (integer 0 *)))
+ (check-type ,new-value (or keyword binding (integer 0 *)))
(acons ,binding-var ,new-value ,getter))))
,setter
,new-value)
@@ -2573,27 +2587,31 @@
free-so-far)))
((:load-constant :load-lexical :store-lexical :cons-get :endp :incf-lexvar :init-lexvar)
(assert (gethash (instruction-is i) *extended-code-expanders*))
- (unless (can-expand-extended-p i frame-map)
- (return (values nil t)))
- (let ((exp (expand-extended-code i funobj frame-map)))
- (when (tree-search exp '(:call :local-function-init))
- (setf free-so-far
- (remove-if (lambda (r)
- (not (eq r :push)))
- free-so-far)))
- (setf free-so-far
- (remove-if (lambda (r)
- (and (not (eq r :push))
- (or (tree-search exp r)
- (tree-search exp (register32-to-low8 r)))))
- free-so-far))))
+ (cond
+ ((and (instruction-is i :init-lexvar) ; special case..
+ (typep (second i) 'forwarding-binding)))
+ (t (unless (can-expand-extended-p i frame-map)
+ ;; (warn "can't expand ~A from ~A" i frame-map)
+ (return (values nil t)))
+ (let ((exp (expand-extended-code i funobj frame-map)))
+ (when (tree-search exp '(:call :local-function-init))
+ (setf free-so-far
+ (remove-if (lambda (r)
+ (not (eq r :push)))
+ free-so-far)))
+ (setf free-so-far
+ (remove-if (lambda (r)
+ (and (not (eq r :push))
+ (or (tree-search exp r)
+ (tree-search exp (register32-to-low8 r)))))
+ free-so-far))))))
((:local-function-init)
(destructuring-bind (binding)
(cdr i)
(unless (typep binding 'funobj-binding)
(return nil))))
- (t (warn "Dist ~D stopped by ~A"
- distance i)
+ (t #+ignore (warn "Dist ~D stopped by ~A"
+ distance i)
(return nil)))))
;; do (warn "after ~A: ~A" i free-so-far)
finally (return free-so-far)))
@@ -2605,13 +2623,13 @@
(let* ((count-init-pc (gethash binding var-counts))
(count (car count-init-pc))
(init-pc (cdr count-init-pc)))
- ;; (warn "b ~S: count: ~D, init-pc: ~{~&~A~}" binding count init-pc)
(cond
((binding-lended-p binding)
;; We can't lend a register.
(values nil :never))
((and (= 1 count)
init-pc)
+ ;; (warn "b ~S: count: ~D, init-pc: ~{~&~A~}" binding count init-pc)
(assert (instruction-is (first init-pc) :init-lexvar))
(destructuring-bind (init-binding &key init-with-register init-with-type
protect-registers protect-carry)
@@ -2620,8 +2638,9 @@
(assert (eq binding init-binding))
(let* ((load-instruction
(find-if (lambda (i)
- (member binding (find-read-bindings i)
- :test #'binding-eql))
+ (and (not (instruction-is i :init-lexvar))
+ (member binding (find-read-bindings i)
+ :test #'eq)))
(cdr init-pc)
:end 15))
(binding-destination (third load-instruction))
@@ -2674,7 +2693,7 @@
"Iterate over CODE, and take note in the hash-table VAR-COUNTER which ~
variables CODE references that are lexically bound in ENV."
(check-type function-env function-env)
- ;; (format t "~{~&~S~}" code)
+ ;; (print-code 'discover code)
(let ((var-counter (make-hash-table :test #'eq :size 40)))
(labels ((take-note-of-binding (binding &optional storep init-pc)
(let ((count-init-pc (or (gethash binding var-counter)
@@ -2685,17 +2704,17 @@
(setf (cdr count-init-pc) init-pc))
(unless storep
(incf (car count-init-pc))))
+ #+ignore
(when (typep binding 'forwarding-binding)
- (take-note-of-binding (forwarding-binding-target binding))))
+ (take-note-of-binding (forwarding-binding-target binding) storep)))
(do-discover-variables (code env)
(loop for pc on code as instruction in code
when (listp instruction)
do (flet ((lend-lexical (borrowing-binding dynamic-extent-p)
(let ((lended-binding
(borrowed-binding-target borrowing-binding)))
- (when (typep lended-binding 'forwarding-binding)
- (setf lended-binding
- (change-class lended-binding 'located-binding)))
+ (assert (not (typep lended-binding 'forwarding-binding)) ()
+ "Can't lend a forwarding-binding.")
(pushnew lended-binding
(potentially-lended-bindings function-env))
(take-note-of-binding lended-binding)
@@ -2724,7 +2743,10 @@
(cdr instruction)
(declare (ignore protect-registers protect-carry init-with-type))
(when init-with-register
- (take-note-of-binding binding t pc))))
+ (take-note-of-binding binding t pc)
+ (when (and (typep init-with-register 'binding)
+ #+ignore (not (typep binding 'forwarding-binding)))
+ (take-note-of-binding init-with-register)))))
(t (mapcar #'take-note-of-binding
(find-read-bindings instruction))
(let ((store-binding (find-written-binding-and-type instruction)))
@@ -2765,7 +2787,12 @@
((not (typep binding 'lexical-binding)))
((typep binding 'lambda-binding))
((typep binding 'constant-object-binding))
- ((typep binding 'forwarding-binding))
+ ((typep binding 'forwarding-binding)
+ ;; Immediately "assign" to target.
+ (when (plusp (or (car (gethash binding var-counts)) 0))
+ (setf (new-binding-location binding frame-map)
+ (forwarding-binding-target binding)))
+ t)
((typep binding 'borrowed-binding))
((typep binding 'funobj-binding))
((and (typep binding 'fixed-required-function-argument)
@@ -2778,7 +2805,7 @@
(unless (or (movitz-env-get variable 'ignore nil env nil)
(movitz-env-get variable 'ignorable nil env nil)
(typep binding 'hidden-rest-function-argument))
- (warn "Unused variable: ~S" variable)))))
+ (warn "Unused variable: ~S" binding)))))
collect binding))
(bindings-fun-arg-sorted
(when (eq env function-env)
@@ -2919,7 +2946,7 @@
;; do (warn "bind: ~S: ~S" binding (eq function-env (find-function-env env funobj)))
when (sub-env-p env function-env)
do (assign-env-bindings (binding-env binding)))
- ;; (warn "Frame-map:~{ ~A~}" frame-map)
+ ;; (warn "Frame-map:~{ ~A~}" frame-map)
frame-map)))
@@ -3418,6 +3445,7 @@
(defun finalize-code (code funobj frame-map)
;; (print-code 'to-be-finalized code)
+ ;; (warn "frame-map: ~A" frame-map)
(labels ((actual-binding (b)
(if (typep b 'borrowed-binding)
(borrowed-binding-target b)
@@ -3481,92 +3509,92 @@
funobj frame-map)))))
(t ;; (warn "finalizing ~S" instruction)
- (case (first instruction)
- ((:locally :globally)
- (destructuring-bind (sub-instr)
- (cdr instruction)
- (let ((pf (ecase (first instruction)
- (:locally *compiler-local-segment-prefix*)
- (:globally *compiler-global-segment-prefix*))))
- (list (fix-edi-offset
- (cond
- ((atom sub-instr)
- sub-instr)
- ((consp (car sub-instr))
- (list* (append pf (car sub-instr))
- (cdr sub-instr)))
- (t (list* pf sub-instr))))))))
- (:declare-label-set nil)
- (:local-function-init
- (destructuring-bind (function-binding)
- (operands instruction)
- #+ignore (warn "local-function-init: init ~S at ~S"
- function-binding
- (new-binding-location function-binding frame-map))
- (finalize-code
- (let* ((sub-funobj (function-binding-funobj function-binding))
- (lend-code (loop for bb in (borrowed-bindings sub-funobj)
- append (make-lend-lexical bb :edx nil))))
- (cond
- ((typep function-binding 'funobj-binding)
- nil)
- ((null lend-code)
- (warn "null lending")
- (append (make-load-constant sub-funobj :eax funobj frame-map)
- (make-store-lexical function-binding :eax nil frame-map)))
- (t (append (make-load-constant sub-funobj :eax funobj frame-map)
- `((:movl (:edi ,(global-constant-offset 'copy-funobj)) :esi)
- (:call (:esi ,(bt:slot-offset 'movitz-funobj 'code-vector%1op)))
- (:movl :eax :edx))
- (make-store-lexical function-binding :eax nil frame-map)
- lend-code))))
- funobj frame-map)))
- (:load-lambda
- (destructuring-bind (function-binding register)
- (operands instruction)
- ;; (warn "load-lambda not completed for ~S" function-binding)
- (finalize-code
- (let* ((sub-funobj (function-binding-funobj function-binding))
- (lend-code (loop for bb in (borrowed-bindings sub-funobj)
- appending
- (make-lend-lexical bb :edx nil))))
- (cond
- ((null lend-code)
- ;; (warn "null lambda lending")
- (append (make-load-constant sub-funobj register funobj frame-map)))
- (t (append (make-load-constant sub-funobj :eax funobj frame-map)
- `((:movl (:edi ,(global-constant-offset 'copy-funobj)) :esi)
- (:call (:esi ,(bt:slot-offset 'movitz-funobj 'code-vector%1op)))
- (:movl :eax :edx))
- lend-code
- `((:movl :edx ,register))))))
- funobj frame-map)))
- (:load-constant
- (destructuring-bind (object result-mode &key (op :movl))
- (cdr instruction)
- (make-load-constant object result-mode funobj frame-map :op op)))
- (:lexical-control-transfer
- (destructuring-bind (return-code return-mode from-env to-env &optional to-label)
- (cdr instruction)
- (declare (ignore return-code))
- (let ((x (apply #'make-compiled-lexical-control-transfer
- nil
- return-mode from-env to-env
- (when to-label (list to-label)))))
- (finalize-code x funobj frame-map))))
- (:call-lexical
- (destructuring-bind (binding num-args)
- (operands instruction)
- (append (etypecase binding
- (closure-binding
- (make-load-lexical (ensure-local-binding binding)
- :esi funobj nil frame-map
- :tmp-register :edx))
- (funobj-binding
- (make-load-constant (function-binding-funobj binding)
- :esi funobj frame-map)))
- (make-compiled-funcall-by-esi num-args))))
- (t (expand-extended-code instruction funobj frame-map)))))))))
+ (case (first instruction)
+ ((:locally :globally)
+ (destructuring-bind (sub-instr)
+ (cdr instruction)
+ (let ((pf (ecase (first instruction)
+ (:locally *compiler-local-segment-prefix*)
+ (:globally *compiler-global-segment-prefix*))))
+ (list (fix-edi-offset
+ (cond
+ ((atom sub-instr)
+ sub-instr)
+ ((consp (car sub-instr))
+ (list* (append pf (car sub-instr))
+ (cdr sub-instr)))
+ (t (list* pf sub-instr))))))))
+ (:declare-label-set nil)
+ (:local-function-init
+ (destructuring-bind (function-binding)
+ (operands instruction)
+ #+ignore (warn "local-function-init: init ~S at ~S"
+ function-binding
+ (new-binding-location function-binding frame-map))
+ (finalize-code
+ (let* ((sub-funobj (function-binding-funobj function-binding))
+ (lend-code (loop for bb in (borrowed-bindings sub-funobj)
+ append (make-lend-lexical bb :edx nil))))
+ (cond
+ ((typep function-binding 'funobj-binding)
+ nil)
+ ((null lend-code)
+ (warn "null lending")
+ (append (make-load-constant sub-funobj :eax funobj frame-map)
+ (make-store-lexical function-binding :eax nil frame-map)))
+ (t (append (make-load-constant sub-funobj :eax funobj frame-map)
+ `((:movl (:edi ,(global-constant-offset 'copy-funobj)) :esi)
+ (:call (:esi ,(bt:slot-offset 'movitz-funobj 'code-vector%1op)))
+ (:movl :eax :edx))
+ (make-store-lexical function-binding :eax nil frame-map)
+ lend-code))))
+ funobj frame-map)))
+ (:load-lambda
+ (destructuring-bind (function-binding register)
+ (operands instruction)
+ ;; (warn "load-lambda not completed for ~S" function-binding)
+ (finalize-code
+ (let* ((sub-funobj (function-binding-funobj function-binding))
+ (lend-code (loop for bb in (borrowed-bindings sub-funobj)
+ appending
+ (make-lend-lexical bb :edx nil))))
+ (cond
+ ((null lend-code)
+ ;; (warn "null lambda lending")
+ (append (make-load-constant sub-funobj register funobj frame-map)))
+ (t (append (make-load-constant sub-funobj :eax funobj frame-map)
+ `((:movl (:edi ,(global-constant-offset 'copy-funobj)) :esi)
+ (:call (:esi ,(bt:slot-offset 'movitz-funobj 'code-vector%1op)))
+ (:movl :eax :edx))
+ lend-code
+ `((:movl :edx ,register))))))
+ funobj frame-map)))
+ (:load-constant
+ (destructuring-bind (object result-mode &key (op :movl))
+ (cdr instruction)
+ (make-load-constant object result-mode funobj frame-map :op op)))
+ (:lexical-control-transfer
+ (destructuring-bind (return-code return-mode from-env to-env &optional to-label)
+ (cdr instruction)
+ (declare (ignore return-code))
+ (let ((x (apply #'make-compiled-lexical-control-transfer
+ nil
+ return-mode from-env to-env
+ (when to-label (list to-label)))))
+ (finalize-code x funobj frame-map))))
+ (:call-lexical
+ (destructuring-bind (binding num-args)
+ (operands instruction)
+ (append (etypecase binding
+ (closure-binding
+ (make-load-lexical (ensure-local-binding binding)
+ :esi funobj nil frame-map
+ :tmp-register :edx))
+ (funobj-binding
+ (make-load-constant (function-binding-funobj binding)
+ :esi funobj frame-map)))
+ (make-compiled-funcall-by-esi num-args))))
+ (t (expand-extended-code instruction funobj frame-map)))))))))
(defun image-t-symbol-p (x)
@@ -5801,17 +5829,32 @@
(assert init-with-type)
(values binding init-with-type))))
+(define-find-read-bindings :init-lexvar (binding &key init-with-register &allow-other-keys)
+ (declare (ignore binding))
+ (when (typep init-with-register 'binding)
+ (list init-with-register)))
+
(define-extended-code-expander :init-lexvar (instruction funobj frame-map)
(destructuring-bind (binding &key protect-registers protect-carry
init-with-register init-with-type)
(cdr instruction)
(declare (ignore protect-carry)) ; nothing modifies carry anyway.
- (assert (eq binding (ensure-local-binding binding funobj)))
+ ;; (assert (eq binding (ensure-local-binding binding funobj)))
+ (assert (eq funobj (binding-funobj binding)))
(cond
((not (new-binding-located-p binding frame-map))
(unless (or (movitz-env-get (binding-name binding) 'ignore nil (binding-env binding))
- (movitz-env-get (binding-name binding) 'ignorable nil (binding-env binding)))
- (warn "Unused variable: ~S." (binding-name binding))))
+ (movitz-env-get (binding-name binding) 'ignorable nil (binding-env binding))
+ #+ignore
+ (labels ((recursive-located-p (b)
+ (or (new-binding-located-p b frame-map)
+ (and (typep binding 'forwarding-binding)
+ (recursive-located-p (forwarding-binding-target b))))))
+ (recursive-located-p binding)))
+ (warn "Unused variable: ~S." binding)))
+ ((typep binding 'forwarding-binding)
+ ;; No need to do any initialization because the target will be initialized.
+ nil)
(t (when (movitz-env-get (binding-name binding) 'ignore nil (binding-env binding))
(warn "Variable ~S used while declared ignored." (binding-name binding)))
(append
@@ -5835,24 +5878,34 @@
(make-compiled-funcall-by-symbol 'muerte.cl:copy-list 1 funobj)))))
(cond
((binding-lended-p binding)
- (let ((cons-position (getf (binding-lended-p binding)
- :stack-cons-location))
- (tmp-register (find-if (lambda (r)
- (and (not (member r protect-registers))
- (not (eq r init-with-register))))
- '(:edx :ecx :ebx :eax)))
- (init-register (or init-with-register :edi)))
+ (let* ((cons-position (getf (binding-lended-p binding)
+ :stack-cons-location))
+ (init-register (etypecase init-with-register
+ (lexical-binding
+ (or (find-if (lambda (r)
+ (not (member r protect-registers)))
+ '(:edx :ebx :eax))
+ (error "Unable to get a register.")))
+ (keyword init-with-register)
+ (null :edi)))
+ (tmp-register (find-if (lambda (r)
+ (and (not (member r protect-registers))
+ (not (eq r init-register))))
+ '(:edx :ebx :eax))))
(when init-with-register
(assert (not (null init-with-type))))
(assert tmp-register () ; solve this with push eax .. pop eax if ever needed.
"Unable to find a tmp-register for ~S." instruction)
- `((:leal (:ebp ,(1+ (stack-frame-offset (1+ cons-position))))
- ,tmp-register)
- (:movl :edi (,tmp-register 3)) ; cdr
- (:movl ,init-register (,tmp-register -1)) ; car
- (:movl ,tmp-register
- (:ebp ,(stack-frame-offset
- (new-binding-location binding frame-map)))))))
+ (append (when (typep init-with-register 'binding)
+ (make-load-lexical init-with-register init-register funobj nil frame-map
+ :protect-registers protect-registers))
+ `((:leal (:ebp ,(1+ (stack-frame-offset (1+ cons-position))))
+ ,tmp-register)
+ (:movl :edi (,tmp-register 3)) ; cdr
+ (:movl ,init-register (,tmp-register -1)) ; car
+ (:movl ,tmp-register
+ (:ebp ,(stack-frame-offset
+ (new-binding-location binding frame-map))))))))
(init-with-register
(make-store-lexical binding init-with-register nil frame-map))))))))
