[movitz-cvs] CVS update: movitz/compiler.lisp
Frode Vatvedt Fjeld
ffjeld at common-lisp.net
Mon Feb 16 17:22:48 UTC 2004
Update of /project/movitz/cvsroot/movitz
In directory common-lisp.net:/tmp/cvs-serv32153
Modified Files:
compiler.lisp
Log Message:
This rather big check-in adds smartness in the compiler to locate
variables in registers, rather than mindlessly putting them on the
stack-frame. This should mean smaller, more efficient code, and
reduced stack usage.
Also, there are a few bug-fixes here and there, although these bugs
apparently haven't resulted in buggy output (yet).
Date: Mon Feb 16 12:22:47 2004
Author: ffjeld
Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.26 movitz/compiler.lisp:1.27
--- movitz/compiler.lisp:1.26 Sat Feb 14 10:44:32 2004
+++ movitz/compiler.lisp Mon Feb 16 12:22:47 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.26 2004/02/14 15:44:32 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.27 2004/02/16 17:22:47 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -102,6 +102,7 @@
(let* ((name (movitz-print (movitz-funobj-name funobj)))
(hash-name name)
(new-size (length (movitz-vector-symbolic-data (movitz-funobj-code-vector funobj)))))
+ (assert name)
(let ((old-size (gethash hash-name (function-code-sizes *image*))))
(cond
((not old-size))
@@ -441,11 +442,11 @@
(type-analysis-binding-types analysis))
(setf (binding-store-type binding)
(type-analysis-encoded-type analysis))
+ #+ignore
(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
+ #+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))
@@ -2067,7 +2068,13 @@
(defmethod print-object ((object binding) stream)
(print-unreadable-object (object stream :type t :identity t)
(when (slot-boundp object 'name)
- (format stream "name: ~S" (binding-name object)))))
+ (format stream "name: ~S~@[->~S~]~@[ stype: ~A~]"
+ (binding-name object)
+ (unless (eq object (binding-target object))
+ (binding-name (binding-target object)))
+ (when (binding-store-type object)
+ (apply #'encoded-type-decode
+ (binding-store-type object)))))))
(defclass constant-object-binding (binding)
((object
@@ -2304,10 +2311,12 @@
(defun instruction-is (instruction &optional operator)
(and (listp instruction)
- (let ((instruction (ignore-instruction-prefixes instruction)))
- (if operator
- (eq operator (car instruction))
- (car instruction)))))
+ (if (member (car instruction) '(:globally :locally))
+ (instruction-is (second instruction) operator)
+ (let ((instruction (ignore-instruction-prefixes instruction)))
+ (if operator
+ (eq operator (car instruction))
+ (car instruction))))))
(defun instruction-uncontinues-p (instruction)
"Is it impossible for control to return after instruction?"
@@ -2395,33 +2404,58 @@
obj funobj (movitz-funobj-const-list funobj))
pos)))))
+(defun compute-free-registers (pc distance funobj frame-map
+ &key (free-registers '(:eax :ebx :edx)))
+ (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)
+ (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)))
+ (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)))
+ finally (return free-so-far)))
+
(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.
- Also return the set of borrowed-bindings discovered."
+ variables CODE references that are lexically bound in ENV."
(check-type function-env function-env)
;; (format t "~{~&~S~}" code)
- (let ((var-counter (make-hash-table :test #'eq :size 40))
- #+ignore (funobj (movitz-environment-funobj function-env)))
- (labels ((take-note-of-binding (binding &optional storep)
- ;; (check-type binding lexical-binding)
- (if storep
- (setf (gethash binding var-counter)
- (or (gethash binding var-counter) 0))
- (incf (gethash binding var-counter 0)))
+ (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)
+ (setf (gethash binding var-counter)
+ (cons 0 nil)))))
+ (when init-pc
+ (assert (not (cdr count-init-pc)))
+ (setf (cdr count-init-pc) init-pc))
+ (unless storep
+ (incf (car count-init-pc))))
(when (typep binding 'forwarding-binding)
(take-note-of-binding (forwarding-binding-target binding))))
- (ensure-local-binding (binding)
- "If binding is borrowed from another funobj, we must replace it with a borrowing-binding."
- #+ignore (assert (eq funobj (binding-funobj binding)) ()
- "Not local: ~S" binding)
- binding)
(do-discover-variables (code env)
- (loop for instruction in code
+ (loop for pc on code as instruction in code
when (listp instruction)
do (flet ((lend-lexical (borrowing-binding dynamic-extent-p)
(let ((lended-binding
- (ensure-local-binding (borrowed-binding-target borrowing-binding))))
+ (borrowed-binding-target borrowing-binding)))
(when (typep lended-binding 'forwarding-binding)
(setf lended-binding
(change-class lended-binding 'located-binding)))
@@ -2432,11 +2466,6 @@
(incf (getf p :lended-count 0))
(setf (getf p :dynamic-extent-p) (and (getf p :dynamic-extent-p t)
dynamic-extent-p))))))
- (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)))
(case (instruction-is instruction)
((:local-function-init :load-lambda)
(let ((function-binding (second instruction)))
@@ -2450,15 +2479,22 @@
(declare (ignore num-args))
(etypecase binding
(function-binding
- (take-note-of-binding (ensure-local-binding binding)))
+ (take-note-of-binding binding))
(funobj-binding))))
- (t (do-discover-variables (instruction-sub-program instruction) env)))))))
+ (:init-lexvar
+ (destructuring-bind (binding &key init-with-register init-with-type
+ protect-registers protect-carry)
+ (cdr instruction)
+ (declare (ignore protect-registers protect-carry init-with-type))
+ (when init-with-register
+ (take-note-of-binding binding t pc))))
+ (t (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)))
+ (do-discover-variables (instruction-sub-program instruction) env)))))))
(do-discover-variables code function-env))
- ;; any hidden-rest is always used..
- (loop for (nil . binding) in (movitz-environment-bindings function-env)
- do (when (typep binding 'hidden-rest-function-argument)
- (incf (gethash binding var-counter 0))))
- ;; (setf (movitz-funobj-borrowed-bindings funobj) borrowed-bindings)
(values var-counter)))
(defun assign-bindings (code function-env &optional (initial-stack-frame-position 1)
@@ -2474,73 +2510,147 @@
(let* ((env-roof-map nil) ; memoize result of assign-env-bindings
(flat-program code)
(var-counts (discover-variables flat-program function-env)))
- (labels ((env-floor (env)
- (cond
- ((eq env function-env)
- initial-stack-frame-position)
- ((typep env 'function-env)
- (error "SEFEW: ~S" function-env))
- ;; The floor of this env is the roof of its extent-uplink.
- (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 (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))
- (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 bindings-to-locate)
- (when (and (binding-lended-p binding)
- (not (typep binding 'borrowed-binding))
- (not (getf (binding-lended-p binding) :stack-cons-location)))
- ;; (warn "assigning lending-cons for ~W at ~D" binding stack-frame-position)
- (let ((cons-pos (post-incf stack-frame-position 2)))
- (setf (new-binding-location (cons :lended-cons binding) frame-map)
- (1+ cons-pos))
- (setf (getf (binding-lended-p binding) :stack-cons-location)
- cons-pos)))
- (unless (new-binding-located-p binding frame-map)
- (etypecase binding
- (constant-object-binding) ; no location needed.
- (forwarding-binding) ; will use the location of destination binding.
- (borrowed-binding) ; location is predetermined
- (fixed-required-function-argument
- (setf (new-binding-location binding frame-map) :argument-stack))
- (located-binding
- ;; don't think twice, it's alright..
- ;; (i.e. this is where we should be clever about assigning bindings
- ;; to registers and whatnot..)
- ;; (warn "assign ~W to ~D" binding stack-frame-position)
+ (labels
+ ((env-floor (env)
+ (cond
+ ((eq env function-env)
+ initial-stack-frame-position)
+ ((typep env 'function-env)
+ (error "SEFEW: ~S" function-env))
+ ;; The floor of this env is the roof of its extent-uplink.
+ (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 least likely
+ ;; candidates for locating to registers
+ ;; be assigned last.
+ :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))))))))
+ (when (and (binding-lended-p binding)
+ (not (typep binding 'borrowed-binding))
+ (not (getf (binding-lended-p binding) :stack-cons-location)))
+ ;; (warn "assigning lending-cons for ~W at ~D" binding stack-frame-position)
+ (let ((cons-pos (post-incf stack-frame-position 2)))
+ (setf (new-binding-location (cons :lended-cons binding) frame-map)
+ (1+ cons-pos))
+ (setf (getf (binding-lended-p binding) :stack-cons-location)
+ cons-pos)))
+ (unless (new-binding-located-p binding frame-map)
+ (etypecase binding
+ (constant-object-binding) ; no location needed.
+ (forwarding-binding) ; will use the location of target binding.
+ (borrowed-binding) ; location is predetermined
+ (fixed-required-function-argument
+ (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))
+;;; (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))))))
- (setf (getf env-roof-map env)
- stack-frame-position)))))
+ (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 (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
as env = (binding-env binding)
@@ -2767,147 +2877,148 @@
(when (movitz-env-get (binding-name binding) 'ignore nil (binding-env binding))
(warn "The variable ~S is used even if it was declared ignored."
(binding-name binding)))
- (flet ((chose-tmp-register (&optional preferred)
- (or tmp-register
- (unless (member preferred protect-registers)
- preferred)
- (first (set-difference '(:eax :ebx :ecx :edx)
- protect-registers))
- (error "Unable to chose a temporary register.")))
- (install-for-single-value (lexb lexb-location result-mode indirect-p)
- (if (integerp lexb-location)
- (append `((:movl ,(make-indirect-reference :ebp (stack-frame-offset lexb-location))
- ,(single-value-register result-mode)))
- (when indirect-p
- `((:movl (-1 ,(single-value-register result-mode))
- ,(single-value-register result-mode)))))
- (ecase lexb-location
- (:eax
- (assert (not indirect-p))
- (ecase result-mode
- ((:ecx :edx) `((:movl :eax ,result-mode)))
- ((:eax :single-value) nil)))
- ((:ebx :ecx :edx)
- (assert (not indirect-p))
- (unless (eq result-mode lexb-location)
+ (let ((protect-registers (cons :edx protect-registers)))
+ (flet ((chose-tmp-register (&optional preferred)
+ (or tmp-register
+ (unless (member preferred protect-registers)
+ preferred)
+ (first (set-difference '(:eax :ebx :ecx :edx)
+ protect-registers))
+ (error "Unable to chose a temporary register.")))
+ (install-for-single-value (lexb lexb-location result-mode indirect-p)
+ (if (integerp lexb-location)
+ (append `((:movl ,(make-indirect-reference :ebp (stack-frame-offset lexb-location))
+ ,(single-value-register result-mode)))
+ (when indirect-p
+ `((:movl (-1 ,(single-value-register result-mode))
+ ,(single-value-register result-mode)))))
+ (ecase lexb-location
+ (:eax
+ (assert (not indirect-p))
(ecase result-mode
- ((:eax :single-value) `((:movl :ebx :eax)))
- ((:ebx :ecx :ecx) `((:movl ,lexb-location ,result-mode))))))
- (:argument-stack
- (assert (<= 2 (function-argument-argnum lexb)) ()
- "lexical :argument-stack argnum can't be ~A." (function-argument-argnum lexb))
- (append `((:movl (:ebp ,(argument-stack-offset lexb))
- ,(single-value-register result-mode)))
- (when indirect-p
- `((:movl (-1 ,(single-value-register result-mode))
- ,(single-value-register result-mode))))))))))
- (etypecase binding
- (forwarding-binding
- (assert (not (binding-lended-p binding)) (binding)
- "Can't lend a forwarding-binding ~S." binding)
- (make-load-lexical (forwarding-binding-target binding)
- result-mode funobj shared-reference-p frame-map))
- (constant-object-binding
- (assert (not (binding-lended-p binding)) (binding)
- "Can't lend a constant-reference-binding ~S." binding)
- (make-load-constant (constant-object binding)
- result-mode
- funobj frame-map))
- (borrowed-binding
- (let ((slot (borrowed-binding-reference-slot binding)))
- (cond
- (shared-reference-p
- (ecase (result-mode-type result-mode)
- ((:eax :ebx :ecx :edx)
- `((:movl (:esi ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 slot)))
- ,(result-mode-type result-mode))))))
- ((not shared-reference-p)
- (case result-mode
- ((:single-value :eax :ebx :ecx :edx :esi)
- (let ((tmp-register (chose-tmp-register (single-value-register result-mode))))
- `((:movl (:esi ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 slot)))
- ,tmp-register)
- (:movl (,tmp-register -1)
- ,(single-value-register result-mode)))))
- (:push
- (let ((tmp-register (chose-tmp-register :eax)))
+ ((:ebx :ecx :edx) `((:movl :eax ,result-mode)))
+ ((:eax :single-value) nil)))
+ ((:ebx :ecx :edx)
+ (assert (not indirect-p))
+ (unless (eq result-mode lexb-location)
+ (ecase result-mode
+ ((:eax :single-value) `((:movl ,lexb-location :eax)))
+ ((:ebx :ecx :ecx :esi) `((:movl ,lexb-location ,result-mode))))))
+ (:argument-stack
+ (assert (<= 2 (function-argument-argnum lexb)) ()
+ "lexical :argument-stack argnum can't be ~A." (function-argument-argnum lexb))
+ (append `((:movl (:ebp ,(argument-stack-offset lexb))
+ ,(single-value-register result-mode)))
+ (when indirect-p
+ `((:movl (-1 ,(single-value-register result-mode))
+ ,(single-value-register result-mode))))))))))
+ (etypecase binding
+ (forwarding-binding
+ (assert (not (binding-lended-p binding)) (binding)
+ "Can't lend a forwarding-binding ~S." binding)
+ (make-load-lexical (forwarding-binding-target binding)
+ result-mode funobj shared-reference-p frame-map))
+ (constant-object-binding
+ (assert (not (binding-lended-p binding)) (binding)
+ "Can't lend a constant-reference-binding ~S." binding)
+ (make-load-constant (constant-object binding)
+ result-mode
+ funobj frame-map))
+ (borrowed-binding
+ (let ((slot (borrowed-binding-reference-slot binding)))
+ (cond
+ (shared-reference-p
+ (ecase (result-mode-type result-mode)
+ ((:eax :ebx :ecx :edx)
`((:movl (:esi ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 slot)))
- ,tmp-register)
- (:pushl (,tmp-register -1)))))
- (t (let ((tmp-register (chose-tmp-register :eax)))
- (make-result-and-returns-glue
- result-mode tmp-register
- `((:movl (:esi ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 slot)))
- ,tmp-register)
- (:movl (,tmp-register -1) ,tmp-register))))))))))
- (located-binding
- (let ((binding-location (new-binding-location binding frame-map)))
- (cond
- ((and (binding-lended-p binding)
- (not shared-reference-p))
- (case result-mode
- ((:single-value :eax :ebx :ecx :edx :esi :esp)
- (install-for-single-value binding binding-location
- (single-value-register result-mode) t))
- (:push
- (if (integerp binding-location)
- `((:movl (:ebp ,(stack-frame-offset binding-location)) :eax)
- (:pushl (:eax -1)))
- (ecase binding-location
-;;; (:eax '((:pushl :eax)))
-;;; (:ebx '((:pushl :ebx)))
- (:argument-stack
- (assert (<= 2 (function-argument-argnum binding)) ()
- ":load-lexical argnum can't be ~A." (function-argument-argnum binding))
- `((:movl (:ebp ,(argument-stack-offset binding)) :eax)
- (:pushl (:eax -1)))))))
- (t (make-result-and-returns-glue
- result-mode :eax
- (install-for-single-value binding binding-location :eax t)))))
- (t (case (operator result-mode)
+ ,(result-mode-type result-mode))))))
+ ((not shared-reference-p)
+ (case result-mode
+ ((:single-value :eax :ebx :ecx :edx :esi)
+ (let ((tmp-register (chose-tmp-register (single-value-register result-mode))))
+ `((:movl (:esi ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 slot)))
+ ,tmp-register)
+ (:movl (,tmp-register -1)
+ ,(single-value-register result-mode)))))
+ (:push
+ (let ((tmp-register (chose-tmp-register :eax)))
+ `((:movl (:esi ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 slot)))
+ ,tmp-register)
+ (:pushl (,tmp-register -1)))))
+ (t (let ((tmp-register (chose-tmp-register :eax)))
+ (make-result-and-returns-glue
+ result-mode tmp-register
+ `((:movl (:esi ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 slot)))
+ ,tmp-register)
+ (:movl (,tmp-register -1) ,tmp-register))))))))))
+ (located-binding
+ (let ((binding-location (new-binding-location binding frame-map)))
+ (cond
+ ((and (binding-lended-p binding)
+ (not shared-reference-p))
+ (case result-mode
((:single-value :eax :ebx :ecx :edx :esi :esp)
(install-for-single-value binding binding-location
- (single-value-register result-mode) nil))
+ (single-value-register result-mode) t))
(:push
(if (integerp binding-location)
- `((:pushl (:ebp ,(stack-frame-offset binding-location))))
+ `((:movl (:ebp ,(stack-frame-offset binding-location)) :eax)
+ (:pushl (:eax -1)))
(ecase binding-location
- (:eax '((:pushl :eax)))
- (:ebx '((:pushl :ebx)))
+;;; (:eax '((:pushl :eax)))
+;;; (:ebx '((:pushl :ebx)))
(:argument-stack
(assert (<= 2 (function-argument-argnum binding)) ()
":load-lexical argnum can't be ~A." (function-argument-argnum binding))
- `((:pushl (:ebp ,(argument-stack-offset binding))))))))
- (:boolean-branch-on-true
- (if (integerp binding-location)
- `((:cmpl :edi (:ebp ,(stack-frame-offset binding-location)))
- (:jne ',(operands result-mode)))
- (ecase binding-location
- ((:eax :ebx)
- `((:cmpl :edi ,binding-location)
- (:jne ',(operands result-mode))))
- (:argument-stack
- `((:cmpl :edi (:ebp ,(argument-stack-offset binding)))
- (:jne ',(operands result-mode)))))))
- (:boolean-branch-on-false
- (if (integerp binding-location)
- `((:cmpl :edi (:ebp ,(stack-frame-offset binding-location)))
- (:je ',(operands result-mode)))
- (ecase binding-location
- ((:eax :ebx)
- `((:cmpl :edi ,binding-location)
- (:je ',(operands result-mode))))
- (:argument-stack
- `((:cmpl :edi (:ebp ,(argument-stack-offset binding)))
- (:je ',(operands result-mode)))))))
- (:untagged-fixnum-ecx
- (make-result-and-returns-glue
- result-mode :ecx
- (install-for-single-value binding binding-location :ecx nil)))
+ `((:movl (:ebp ,(argument-stack-offset binding)) :eax)
+ (:pushl (:eax -1)))))))
(t (make-result-and-returns-glue
result-mode :eax
- (install-for-single-value binding binding-location :eax nil)))
- ))))))))
+ (install-for-single-value binding binding-location :eax t)))))
+ (t (case (operator result-mode)
+ ((:single-value :eax :ebx :ecx :edx :esi :esp)
+ (install-for-single-value binding binding-location
+ (single-value-register result-mode) nil))
+ (:push
+ (if (integerp binding-location)
+ `((:pushl (:ebp ,(stack-frame-offset binding-location))))
+ (ecase binding-location
+ (:eax '((:pushl :eax)))
+ (:ebx '((:pushl :ebx)))
+ (:argument-stack
+ (assert (<= 2 (function-argument-argnum binding)) ()
+ ":load-lexical argnum can't be ~A." (function-argument-argnum binding))
+ `((:pushl (:ebp ,(argument-stack-offset binding))))))))
+ (:boolean-branch-on-true
+ (if (integerp binding-location)
+ `((:cmpl :edi (:ebp ,(stack-frame-offset binding-location)))
+ (:jne ',(operands result-mode)))
+ (ecase binding-location
+ ((:eax :ebx)
+ `((:cmpl :edi ,binding-location)
+ (:jne ',(operands result-mode))))
+ (:argument-stack
+ `((:cmpl :edi (:ebp ,(argument-stack-offset binding)))
+ (:jne ',(operands result-mode)))))))
+ (:boolean-branch-on-false
+ (if (integerp binding-location)
+ `((:cmpl :edi (:ebp ,(stack-frame-offset binding-location)))
+ (:je ',(operands result-mode)))
+ (ecase binding-location
+ ((:eax :ebx)
+ `((:cmpl :edi ,binding-location)
+ (:je ',(operands result-mode))))
+ (:argument-stack
+ `((:cmpl :edi (:ebp ,(argument-stack-offset binding)))
+ (:je ',(operands result-mode)))))))
+ (:untagged-fixnum-ecx
+ (make-result-and-returns-glue
+ result-mode :ecx
+ (install-for-single-value binding binding-location :ecx nil)))
+ (t (make-result-and-returns-glue
+ result-mode :eax
+ (install-for-single-value binding binding-location :eax nil)))
+ )))))))))
(defun make-store-lexical (binding source shared-reference-p frame-map
&key protect-registers)
@@ -2960,6 +3071,7 @@
`((:movl ,source (:ebp ,(argument-stack-offset binding))))))))))))
(defun finalize-code (code funobj frame-map)
+ ;; (print-code 'to-be-finalized code)
(labels ((actual-binding (b)
(if (typep b 'borrowed-binding)
(borrowed-binding-target b)
@@ -5363,7 +5475,6 @@
(list x)))
(define-extended-code-expander :car (instruction funobj frame-map)
- (warn "CAR: ~S" instruction)
(destructuring-bind (x dst)
(cdr instruction)
(assert (member dst '(:eax :ebx :ecx :edx)))
@@ -5372,9 +5483,10 @@
(let* ((binding (ensure-local-binding (binding-target x) funobj)))
(cond
((binding-store-subtypep binding 'list)
+ ;; (warn "Inlined CAR for ~S" binding)
`(,@(make-load-lexical binding dst funobj nil frame-map)
(:movl (,dst -1) ,dst)))
- (t `(,@(make-load-lexical binding dst funobj nil frame-map)
+ (t `(,@(make-load-lexical binding :eax funobj nil frame-map)
(:call (:edi ,(global-constant-offset 'fast-car)))
,@(when (not (eq dst :eax))
`((:movl :eax ,dst))))))))
More information about the Movitz-cvs
mailing list