[movitz-cvs] CVS update: movitz/compiler.lisp
Frode Vatvedt Fjeld
ffjeld at common-lisp.net
Tue Feb 17 01:42:50 UTC 2004
Update of /project/movitz/cvsroot/movitz
In directory common-lisp.net:/tmp/cvs-serv484
Modified Files:
compiler.lisp
Log Message:
More work on register scheduling.
Date: Mon Feb 16 20:42:50 2004
Author: ffjeld
Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.28 movitz/compiler.lisp:1.29
--- movitz/compiler.lisp:1.28 Mon Feb 16 12:53:12 2004
+++ movitz/compiler.lisp Mon Feb 16 20:42:50 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.28 2004/02/16 17:53:12 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.29 2004/02/17 01:42:50 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -2024,6 +2024,14 @@
(setq p `((:call (:edi ,(global-constant-offset newf))))
next-pc (nthcdr 2 pc))
(explain nil "Changed [~S ~S] to ~S" i i2 newf)))
+ ((and (equal i '(:movl :eax :ebx))
+ (global-funcall-p i2 '(fast-car-ebx fast-cdr-ebx)))
+ (let ((newf (ecase (global-funcall-p i2 '(fast-car-ebx fast-cdr-ebx))
+ (fast-car-ebx 'fast-car)
+ (fast-cdr-ebx 'fast-cdr))))
+ (setq p `((:call (:edi ,(global-constant-offset newf))))
+ next-pc (nthcdr 2 pc))
+ (explain nil "Changed [~S ~S] to ~S" i i2 newf)))
((and (load-stack-frame-p i) (eq :eax (twop-dst i))
(global-funcall-p i2 '(fast-car fast-cdr))
(preserves-stack-location-p i3 (load-stack-frame-p i))
@@ -2406,43 +2414,55 @@
(defun compute-free-registers (pc distance funobj frame-map
&key (free-registers '(:eax :ebx :edx)))
+ "Return set of free register, and whether there may be more registers
+ free later, with a more specified frame-map."
(loop with free-so-far = free-registers
repeat distance for i in pc
doing
(cond
- ((instruction-is i :load-lexical)
- (destructuring-bind (source dest
- &key shared-reference-p
- tmp-register
- protect-registers)
+ ((and (instruction-is i :init-lexvar)
+ (typep (second i) 'required-function-argument)) ; XXX
+ (destructuring-bind (binding &key init-with-register init-with-type
+ protect-registers protect-carry)
(cdr i)
- (declare (ignore shared-reference-p
- tmp-register
- protect-registers))
- (unless (and (new-binding-located-p (binding-target source)
- frame-map)
- (or (not (typep dest 'binding))
- (new-binding-located-p (binding-target dest)
- frame-map)))
+ (declare (ignore binding protect-registers protect-carry init-with-type))
+ (when init-with-register
+ (setf free-so-far (remove init-with-register free-so-far)))))
+ ((member (instruction-is i)
+ '(:movl :testl :andl :addl))
+ (setf free-so-far
+ (remove-if (lambda (r)
+ (or (tree-search i r)
+ (tree-search i (register32-to-low8 r))))
+ free-so-far)))
+ ((member (instruction-is i)
+ '(:load-lexical :init-lexvar :car :incf-lexvar))
+ (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))
(return nil))
- (let ((exp (expand-extended-code i funobj frame-map)))
- (setf free-so-far
- (remove-if (lambda (r)
- (tree-search exp r))
- free-so-far)))))
- (t (setf free-so-far nil)))
+ (setf free-so-far
+ (remove-if (lambda (r)
+ (tree-search exp r))
+ free-so-far))))
+ (t #+ignore (warn "Dist ~D stopped by ~A"
+ distance i)
+ (return nil)))
finally (return free-so-far)))
(defun try-locate-in-register (binding var-counts funobj frame-map)
- "Try to locate binding in a register. Return a register, or NIL.
+ "Try to locate binding in a register. Return a register, or
+ nil and :not-now, or :never.
This function is factored out from assign-bindings."
(let* ((count-init-pc (gethash binding var-counts))
(count (car count-init-pc))
(init-pc (cdr count-init-pc)))
+ ;; (warn "count: ~D, init-pc: ~{~&~A~}" count init-pc)
(cond
((binding-lended-p binding)
;; We can't lend a register.
- nil)
+ (values nil :never))
((and (= 1 count)
init-pc)
(assert (instruction-is (first init-pc) :init-lexvar))
@@ -2453,28 +2473,25 @@
(assert (eq binding init-binding))
(let* ((load-instruction
(find-if (lambda (i)
- (member binding (find-read-bindings i)))
+ (member binding (find-read-bindings i)
+ :test #'binding-eql))
(cdr init-pc)
:end 7))
(binding-destination (third load-instruction))
- (distance (position load-instruction (cdr init-pc)))
- (free-registers
- (and distance
- (compute-free-registers (cdr init-pc) distance funobj frame-map))))
- (cond
- ((member binding-destination free-registers)
- binding-destination)
- ((member init-with-register free-registers)
- init-with-register)
- ((first free-registers))
- (t nil))))))))
-;;; (when (and (symbolp location) (< 2 distance))
-;;; (warn "Assigning ~A to ~A dist ~S."
-;;; (binding-name binding)
-;;; location
-;;; distance)
-;;; (print-code 'middle (subseq init-pc 0 (+ 2 distance))))
-;;; (setf (new-binding-location binding frame-map) location)))))
+ (distance (position load-instruction (cdr init-pc))))
+ (multiple-value-bind (free-registers more-later-p)
+ (and distance (compute-free-registers (cdr init-pc) distance funobj frame-map))
+ (cond
+ ((member binding-destination free-registers)
+ binding-destination)
+ ((member init-with-register free-registers)
+ init-with-register)
+ ((not (null free-registers))
+ (first free-registers))
+ (more-later-p
+ (values nil :not-now))
+ (t (values nil :never)))))))
+ (t (values nil :never)))))
(defun discover-variables (code function-env)
"Iterate over CODE, and take note in the hash-table VAR-COUNTER which ~
@@ -2564,64 +2581,131 @@
(t (assign-env-bindings (movitz-environment-extent-uplink env)))))
(assign-env-bindings (env)
(or (getf env-roof-map env nil)
- (let ((stack-frame-position (env-floor env))
- (bindings-to-locate
- (loop for (variable . binding) in (movitz-environment-bindings env)
- unless (cond
- ((not (typep binding 'lexical-binding)))
- ((typep binding 'lambda-binding))
- ((not (plusp (or (car (gethash binding var-counts)) 0)))
- (prog1 t
- (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)))))
- collect binding)))
- (when (eq env function-env)
- (setf bindings-to-locate
- (sort bindings-to-locate #'<
- :key (lambda (binding)
- (etypecase binding
- (edx-function-argument 3)
- (positional-function-argument
- (* 2 (function-argument-argnum binding)))
- (binding 100000)))))
- ;; (warn "btl: ~S" bindings-to-locate)
- (loop for binding in bindings-to-locate
- while (or (typep binding 'register-required-function-argument)
- (typep binding 'floating-required-function-argument)
- (and (typep binding 'positional-function-argument)
- (< (function-argument-argnum binding)
- 2)))
- do (unless (new-binding-located-p binding frame-map)
- (setf (new-binding-location binding frame-map)
- (post-incf stack-frame-position)))))
- (dolist (binding (sort (copy-list bindings-to-locate) #'>
- ;; Sort so as to make the most likely
- ;; candidates for locating to registers
- ;; be assigned last (i.e. maps to
- ;; a smaller value).
- :key (lambda (b)
- (etypecase b
- ((or constant-object-binding
- forwarding-binding
- borrowed-binding)
- 1000)
- (fixed-required-function-argument
- (+ 100 (function-argument-argnum b)))
- (located-binding
- (let* ((count-init (gethash b var-counts))
- (count (car count-init))
- (init-pc (cdr count-init)))
- (if (not (and count init-pc))
- 50
- (truncate
- (or (position-if (lambda (i)
- (member b (find-read-bindings i)))
- (cdr init-pc)
- :end 5)
- 10)
- count))))))))
+ (let* ((stack-frame-position (env-floor env))
+ (bindings-to-locate
+ (loop for (variable . binding) in (movitz-environment-bindings env)
+ unless (cond
+ ((not (typep binding 'lexical-binding)))
+ ((typep binding 'lambda-binding))
+ ((typep binding 'constant-object-binding))
+ ((typep binding 'forwarding-binding))
+ ((typep binding 'borrowed-binding))
+ ((typep binding 'fixed-required-function-argument)
+ (prog1 t
+ (setf (new-binding-location binding frame-map)
+ :argument-stack)))
+ ((not (plusp (or (car (gethash binding var-counts)) 0)))
+ (prog1 t
+ (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)))))
+ collect binding))
+ (bindings-fun-arg-sorted
+ (when (eq env function-env)
+ (sort (copy-list bindings-to-locate) #'<
+ :key (lambda (binding)
+ (etypecase binding
+ (edx-function-argument 3)
+ (positional-function-argument
+ (* 2 (function-argument-argnum binding)))
+ (binding 100000))))))
+ (bindings-register-goodness-sort
+ (sort (copy-list bindings-to-locate) #'<
+ ;; Sort so as to make the most likely
+ ;; candidates for locating to registers
+ ;; be assigned first (i.e. maps to
+ ;; a smaller value).
+ :key (lambda (b)
+ (etypecase b
+ ((or constant-object-binding
+ forwarding-binding
+ borrowed-binding)
+ 1000)
+ (fixed-required-function-argument
+ (+ 100 (function-argument-argnum b)))
+ (located-binding
+ (let* ((count-init (gethash b var-counts))
+ (count (car count-init))
+ (init-pc (cdr count-init)))
+ (if (not (and count init-pc))
+ 50
+ (truncate
+ (or (position-if (lambda (i)
+ (member b (find-read-bindings i)))
+ (cdr init-pc)
+ :end 5)
+ 10)
+ count)))))))))
+ ;; First, make several passes while trying to locate bindings
+ ;; into registers.
+ (loop repeat 100 with try-again = t and did-assign = t
+ do (unless (and try-again did-assign)
+ (return))
+ do (setf try-again nil did-assign nil)
+ (loop for binding in bindings-fun-arg-sorted
+ while (or (typep binding 'register-required-function-argument)
+ (typep binding 'floating-required-function-argument)
+ (and (typep binding 'positional-function-argument)
+ (< (function-argument-argnum binding)
+ 2)))
+ do (unless (new-binding-located-p binding frame-map)
+ (multiple-value-bind (register status)
+ (try-locate-in-register binding var-counts
+ (movitz-environment-funobj function-env)
+ frame-map)
+ (cond
+ (register
+ (setf (new-binding-location binding frame-map)
+ register)
+ (setf did-assign t))
+ ((eq status :not-now)
+ ;; (warn "Wait for ~S map ~A" binding frame-map)
+ (setf try-again t))
+ (t (assert (eq status :never)))))))
+ (dolist (binding bindings-register-goodness-sort)
+ (unless (and (binding-lended-p binding)
+ (not (typep binding 'borrowed-binding))
+ (not (getf (binding-lended-p binding) :stack-cons-location)))
+ (unless (new-binding-located-p binding frame-map)
+ (check-type binding located-binding)
+ (multiple-value-bind (register status)
+ (try-locate-in-register binding var-counts
+ (movitz-environment-funobj function-env)
+ frame-map)
+ (cond
+ (register
+ (setf (new-binding-location binding frame-map)
+ register)
+ (setf did-assign t))
+ ((eq status :not-now)
+ (setf try-again t))
+ (t (assert (eq status :never))))))))
+ do (when (and try-again (not did-assign))
+ (let ((binding (or (find-if (lambda (b)
+ (and (not (new-binding-located-p b frame-map))
+ (not (typep b 'function-argument))))
+ bindings-register-goodness-sort
+ :from-end t)
+ (find-if (lambda (b)
+ (not (new-binding-located-p b frame-map)))
+ bindings-fun-arg-sorted))))
+ (when binding
+ (setf (new-binding-location binding frame-map)
+ (post-incf stack-frame-position))
+ (setf did-assign t))))
+ finally (break "100 iterations didn't work"))
+ ;; Then, make one pass assigning bindings to stack-frame.
+ (loop for binding in bindings-fun-arg-sorted
+ while (or (typep binding 'register-required-function-argument)
+ (typep binding 'floating-required-function-argument)
+ (and (typep binding 'positional-function-argument)
+ (< (function-argument-argnum binding)
+ 2)))
+ do (unless (new-binding-located-p binding frame-map)
+ (setf (new-binding-location binding frame-map)
+ (post-incf stack-frame-position))))
+ (dolist (binding bindings-register-goodness-sort)
(when (and (binding-lended-p binding)
(not (typep binding 'borrowed-binding))
(not (getf (binding-lended-p binding) :stack-cons-location)))
@@ -2640,29 +2724,16 @@
(setf (new-binding-location binding frame-map)
:argument-stack))
(located-binding
- (let ((register (try-locate-in-register binding var-counts
- (movitz-environment-funobj function-env)
- frame-map)))
-;;; (when (and (binding-store-type binding)
-;;; (apply #'encoded-type-singleton
-;;; (binding-store-type binding)))
-;;; (warn "Locating constant binding: ~S" binding))
-;;; (warn "binding: ~S type ~S, count: ~S"
-;;; binding
-;;; (apply #'encoded-type-decode
-;;; (binding-store-type binding))
-;;; (gethash binding var-counts))
-;;; (print-code 'foo code)
- (setf (new-binding-location binding frame-map)
- (or register (post-incf stack-frame-position))))))))
+ (setf (new-binding-location binding frame-map)
+ (post-incf stack-frame-position))))))
(setf (getf env-roof-map env)
stack-frame-position)))))
- (loop ;; with funobj = (movitz-environment-funobj function-env)
- for binding being the hash-keys of var-counts
+ (loop for binding being the hash-keys of var-counts
as env = (binding-env binding)
;; 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)
frame-map)))
@@ -2773,6 +2844,7 @@
are load-lexicals of the first two function arguments, and if possible these
bindings are located in the appropriate register, so no stack location is needed."
(check-type env function-env)
+ #+ignore
(let ((funobj (movitz-environment-funobj env))
(scan-code code))
;; (warn "code: ~{~&~S~}" (subseq scan-code 0 5))
@@ -2830,7 +2902,20 @@
;; (setf (binding-location first-load-binding) location)
(setf (new-binding-location first-load-binding frame-map) location)
(setf scan-code (rest scan-code)))))))))
- (assign-bindings code env stack-frame-position frame-map))
+ #+ignore
+ (assign-bindings code env stack-frame-position frame-map)
+ (assign-bindings (append (when (first (required-vars env))
+ (let ((binding (movitz-binding (first (required-vars env))
+ env nil)))
+ (check-type binding required-function-argument)
+ `((:init-lexvar ,binding :init-with-register :eax :init-with-type t))))
+ (when (second (required-vars env))
+ (let ((binding (movitz-binding (second (required-vars env))
+ env nil)))
+ (check-type binding required-function-argument)
+ `((:init-lexvar ,binding :init-with-register :ebx :init-with-type t))))
+ code)
+ env stack-frame-position frame-map))
(defconstant +dynamic-frame-marker+ #xd193)
(defconstant +dynamic-catch-marker+ #xd293)
@@ -3607,13 +3692,16 @@
(t (ecase location-0
((nil :eax) nil)
(:ebx (assert (not location-1))
- '((:movl :eax :ebx))))))
+ '((:movl :eax :ebx)))
+ (:edx (assert (not edx-location))
+ '((:movl :eax :edx))))))
(cond
((eql 1 location-1)
(decf stack-setup-size)
'((:pushl :ebx)))
- (t (case location-1
+ (t (ecase location-1
((nil :ebx) nil)
+ (:edx '((:movl :ebx :edx)))
(:eax `((:movl :ebx :eax)))))))))
(cond
((or (and (or (eql 1 location-0)
@@ -5333,6 +5421,15 @@
(setf (gethash ',name *extended-code-expanders*) ',defun-name)
(defun ,defun-name ,lambda-list , at body))))
+(defun can-expand-extended-p (extended-instruction frame-map)
+ "Given frame-map, can we expand i at this point?"
+ (and (every (lambda (b)
+ (new-binding-located-p (binding-target b) frame-map))
+ (find-read-bindings extended-instruction))
+ (let ((written-binding (find-written-binding-and-type extended-instruction)))
+ (or (not written-binding)
+ (new-binding-located-p (binding-target written-binding) frame-map)))))
+
(defun expand-extended-code (extended-instruction funobj frame-map)
(if (not (listp extended-instruction))
(list extended-instruction)
@@ -5486,14 +5583,26 @@
(assert (member dst '(:eax :ebx :ecx :edx)))
(etypecase x
(binding
- (let* ((binding (ensure-local-binding (binding-target x) funobj)))
+ (let* ((binding (binding-target (ensure-local-binding (binding-target x) funobj)))
+ (location (new-binding-location (binding-target binding) frame-map))
+ (binding-is-list-p (binding-store-subtypep binding 'list)))
+;;; (warn "car of loc ~A bind ~A"
+;;; location binding)
(cond
- ((binding-store-subtypep binding 'list)
- ;; (warn "Inlined CAR for ~S" binding)
+ ((and binding-is-list-p
+ (member location '(:eax :ebx :ecx :edx)))
+ `((:movl (,location -1) ,dst)))
+ (binding-is-list-p
`(,@(make-load-lexical binding dst funobj nil frame-map)
(:movl (,dst -1) ,dst)))
+ ((eq location :ebx)
+ `((,*compiler-global-segment-prefix*
+ :call (:edi ,(global-constant-offset 'fast-car-ebx)))
+ ,@(when (not (eq dst :eax))
+ `((:movl :eax ,dst)))))
(t `(,@(make-load-lexical binding :eax funobj nil frame-map)
- (:call (:edi ,(global-constant-offset 'fast-car)))
+ (,*compiler-global-segment-prefix*
+ :call (:edi ,(global-constant-offset 'fast-car)))
,@(when (not (eq dst :eax))
`((:movl :eax ,dst))))))))
(symbol
More information about the Movitz-cvs
mailing list