[movitz-cvs] CVS update: movitz/compiler.lisp
Frode Vatvedt Fjeld
ffjeld at common-lisp.net
Mon Feb 16 17:53:12 UTC 2004
Update of /project/movitz/cvsroot/movitz
In directory common-lisp.net:/tmp/cvs-serv20617
Modified Files:
compiler.lisp
Log Message:
Factored out function try-locate-in-register from assign-bindings.
Date: Mon Feb 16 12:53:12 2004
Author: ffjeld
Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.27 movitz/compiler.lisp:1.28
--- movitz/compiler.lisp:1.27 Mon Feb 16 12:22:47 2004
+++ movitz/compiler.lisp Mon Feb 16 12:53:12 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.27 2004/02/16 17:22:47 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.28 2004/02/16 17:53:12 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -2433,6 +2433,49 @@
(t (setf free-so-far 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.
+ 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)))
+ (cond
+ ((binding-lended-p binding)
+ ;; We can't lend a register.
+ nil)
+ ((and (= 1 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)
+ (cdr (first init-pc))
+ (declare (ignore protect-registers protect-carry init-with-type))
+ (assert (eq binding init-binding))
+ (let* ((load-instruction
+ (find-if (lambda (i)
+ (member binding (find-read-bindings i)))
+ (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)))))
+
(defun discover-variables (code function-env)
"Iterate over CODE, and take note in the hash-table VAR-COUNTER which ~
variables CODE references that are lexically bound in ENV."
@@ -2554,9 +2597,10 @@
(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 least likely
+ ;; Sort so as to make the most likely
;; candidates for locating to registers
- ;; be assigned last.
+ ;; be assigned last (i.e. maps to
+ ;; a smaller value).
:key (lambda (b)
(etypecase b
((or constant-object-binding
@@ -2596,59 +2640,21 @@
(setf (new-binding-location binding frame-map)
:argument-stack))
(located-binding
-;;; (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))
+ (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)
- (let* ((count-init-pc (gethash binding var-counts))
- (count (car count-init-pc))
- (init-pc (cdr count-init-pc)))
- (cond
- ((binding-lended-p binding)
- (setf (new-binding-location binding frame-map)
- (post-incf stack-frame-position)))
- ((and (= 1 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)
- (cdr (first init-pc))
- (declare (ignore protect-registers protect-carry init-with-type))
- (assert (eq binding init-binding))
- (let* ((load-instruction
- (find-if (lambda (i)
- (member binding (find-read-bindings i)))
- (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
- (movitz-environment-funobj function-env)
- frame-map))))
- (let ((location (cond
- ((member binding-destination free-registers)
- binding-destination)
- ((member init-with-register free-registers)
- init-with-register)
- ((first free-registers))
- (t (post-incf stack-frame-position)))))
-;;; (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)))))
- (t (setf (new-binding-location binding frame-map)
- (post-incf stack-frame-position)))))))))
+ (setf (new-binding-location binding frame-map)
+ (or register (post-incf stack-frame-position))))))))
(setf (getf env-roof-map env)
stack-frame-position)))))
(loop ;; with funobj = (movitz-environment-funobj function-env)
More information about the Movitz-cvs
mailing list