Update of /project/movitz/cvsroot/movitz
In directory common-lisp.net:/tmp/cvs-serv16512
Modified Files:
compiler.lisp
Log Message:
More tuning of (forwarding-)binding/register allocation stuff. This
fix removes many superfluous stack-pushes/register-spills.
Date: Fri Nov 19 21:12:29 2004
Author: ffjeld
Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.109 movitz/compiler.lisp:1.110
--- movitz/compiler.lisp:1.109 Fri Nov 19 00:49:53 2004
+++ movitz/compiler.lisp Fri Nov 19 21:12:26 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.109 2004/11/18 23:49:53 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.110 2004/11/19 20:12:26 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -430,19 +430,24 @@
(analyze-funobj toplevel-funobj))
(let ((binding-usage (make-hash-table :test 'eq)))
(labels ((binding-resolved-p (binding)
- (let ((analysis (gethash binding binding-usage)))
- (and analysis
- (null (type-analysis-thunks analysis)))))
+ (or (typep binding 'constant-object-binding)
+ (let ((analysis (gethash binding binding-usage)))
+ (and 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-thunks analysis))))
- (binding)
- "Can't resolve unresolved binding ~S." binding)
- (apply #'encoded-type-decode
- (type-analysis-encoded-type analysis)))))
+ (cond
+ ((not (bindingp binding))
+ binding)
+ ((typep binding 'constant-object-binding)
+ (apply #'encoded-type-decode
+ (binding-store-type binding)))
+ (t (let ((analysis (gethash binding binding-usage)))
+ (assert (and (and analysis
+ (null (type-analysis-thunks analysis))))
+ (binding)
+ "Can't resolve unresolved binding ~S." binding)
+ (apply #'encoded-type-decode
+ (type-analysis-encoded-type analysis))))))
(type-is-t (type-specifier)
(or (eq type-specifier t)
(and (listp type-specifier)
@@ -1501,6 +1506,9 @@
(explain t "4: ~S for ~S [regx ~S, regy ~S]" p (subseq pc 0 5) regx regy)))
nconc p)))
+(defun xsubseq (sequence start end)
+ (subseq sequence start (min (length sequence) end)))
+
(defun optimize-code-internal (unoptimized-code recursive-count &rest key-args
&key keep-labels stack-frame-size)
"Peephole optimizer. Based on a lot of rather random techniques."
@@ -1808,7 +1816,7 @@
(mapcar (lambda (lpc)
(if (eq 'unknown-label-usage lpc)
nil
- (rcode-map (nreverse (subseq lpc 0 9)))))
+ (rcode-map (nreverse (xsubseq lpc 0 9)))))
(find-branches-to-label unoptimized-code label 9))))
(full-map (let ((rcode (nreverse (let* ((pos (loop for x on unoptimized-code
as pos upfrom 0
@@ -2773,7 +2781,7 @@
(find-if (lambda (i)
(and (not (instruction-is i :init-lexvar))
(member binding (find-read-bindings i)
- :test #'eq #+ignore #'binding-eql)))
+ :test #'binding-eql)))
(cdr init-pc)
#-sbcl :end #-sbcl 15))
(binding-destination (third load-instruction))
@@ -3501,11 +3509,11 @@
(cond
((not dest-location) ; unknown, e.g. a borrowed-binding.
(append (install-for-single-value binding binding-location :ecx nil)
- (make-store-lexical result-mode :ecx nil frame-map)))
+ (make-store-lexical result-mode :ecx nil funobj frame-map)))
((equal binding-location dest-location)
nil)
((member binding-location '(:eax :ebx :ecx :edx))
- (make-store-lexical destination binding-location nil frame-map))
+ (make-store-lexical destination binding-location nil funobj frame-map))
((member dest-location '(:eax :ebx :ecx :edx))
(install-for-single-value binding binding-location dest-location nil))
(t #+ignore (warn "binding => binding: ~A => ~A~% => ~A ~A"
@@ -3514,75 +3522,84 @@
binding
destination)
(append (install-for-single-value binding binding-location :eax nil)
- (make-store-lexical result-mode :eax nil frame-map))))))
+ (make-store-lexical result-mode :eax nil funobj frame-map))))))
(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
+(defun make-store-lexical (binding source shared-reference-p funobj frame-map
&key protect-registers)
(assert (not (and shared-reference-p
(not (binding-lended-p binding))))
(binding)
"funny binding: ~W" binding)
- (let ((protect-registers (cons source protect-registers)))
- (cond
- ((eq :untagged-fixnum-ecx source)
- (if (eq :untagged-fixnum-ecx
- (new-binding-location binding frame-map))
- nil
- (append (make-result-and-returns-glue :ecx :untagged-fixnum-ecx)
- (make-store-lexical binding :ecx shared-reference-p frame-map
- :protect-registers protect-registers))))
- ((typep binding 'borrowed-binding)
- (let ((slot (borrowed-binding-reference-slot binding)))
- (if (not shared-reference-p)
- (let ((tmp-reg (chose-free-register protect-registers)
- #+ignore(if (eq source :eax) :ebx :eax)))
- `((:movl (:esi ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 slot)))
- ,tmp-reg)
- (:movl ,source (-1 ,tmp-reg))))
- `((:movl ,source (:esi ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 slot))))))))
- ((typep binding 'forwarding-binding)
- (assert (not (binding-lended-p binding)) (binding))
- (make-store-lexical (forwarding-binding-target binding)
- source shared-reference-p frame-map))
- ((not (new-binding-located-p binding frame-map))
- ;; (warn "Can't store to unlocated binding ~S." binding)
- nil)
- ((and (binding-lended-p binding)
- (not shared-reference-p))
- (let ((tmp-reg (chose-free-register protect-registers)
- #+ignore (if (eq source :eax) :ebx :eax))
- (location (new-binding-location binding frame-map)))
- (if (integerp location)
- `((:movl (:ebp ,(stack-frame-offset location)) ,tmp-reg)
- (:movl ,source (,tmp-reg -1)))
- (ecase (operator location)
- (:argument-stack
- (assert (<= 2 (function-argument-argnum binding)) ()
- "store-lexical argnum can't be ~A." (function-argument-argnum binding))
- `((:movl (:ebp ,(argument-stack-offset binding)) ,tmp-reg)
- (:movl ,source (,tmp-reg -1))))))))
- (t (let ((location (new-binding-location binding frame-map)))
+ (if (typep source 'constant-object-binding)
+ (make-load-constant (constant-object source) binding funobj frame-map)
+ (let ((protect-registers (cons source protect-registers))
+ #+ignore (source (if (not (typep source 'constant-object-binding))
+ source
+ (etypecase (constant-object source)
+ (movitz-null
+ :edi)
+ (movitz-immediate-object
+ (movitz-immediate-value (constant-object source)))))))
+ (cond
+ ((eq :untagged-fixnum-ecx source)
+ (if (eq :untagged-fixnum-ecx
+ (new-binding-location binding frame-map))
+ nil
+ (append (make-result-and-returns-glue :ecx :untagged-fixnum-ecx)
+ (make-store-lexical binding :ecx shared-reference-p funobj frame-map
+ :protect-registers protect-registers))))
+ ((typep binding 'borrowed-binding)
+ (let ((slot (borrowed-binding-reference-slot binding)))
+ (if (not shared-reference-p)
+ (let ((tmp-reg (chose-free-register protect-registers)
+ #+ignore(if (eq source :eax) :ebx :eax)))
+ `((:movl (:esi ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 slot)))
+ ,tmp-reg)
+ (:movl ,source (-1 ,tmp-reg))))
+ `((:movl ,source (:esi ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 slot))))))))
+ ((typep binding 'forwarding-binding)
+ (assert (not (binding-lended-p binding)) (binding))
+ (make-store-lexical (forwarding-binding-target binding)
+ source shared-reference-p funobj frame-map))
+ ((not (new-binding-located-p binding frame-map))
+ ;; (warn "Can't store to unlocated binding ~S." binding)
+ nil)
+ ((and (binding-lended-p binding)
+ (not shared-reference-p))
+ (let ((tmp-reg (chose-free-register protect-registers)
+ #+ignore (if (eq source :eax) :ebx :eax))
+ (location (new-binding-location binding frame-map)))
(if (integerp location)
- `((:movl ,source (:ebp ,(stack-frame-offset location))))
+ `((:movl (:ebp ,(stack-frame-offset location)) ,tmp-reg)
+ (:movl ,source (,tmp-reg -1)))
(ecase (operator location)
- ((:push)
- `((:pushl ,source)))
- ((:eax :ebx :ecx :edx)
- (unless (eq source location)
- `((:movl ,source ,location))))
(:argument-stack
(assert (<= 2 (function-argument-argnum binding)) ()
"store-lexical argnum can't be ~A." (function-argument-argnum binding))
- `((:movl ,source (:ebp ,(argument-stack-offset binding)))))
- (:untagged-fixnum-ecx
- (append (unless (member source '(:ecx :untagged-fixnum-ecx))
- `((:movl ,source :ecx)))
- (unless (eq source :untagged-fixnum-ecx)
- `((:sarl ,+movitz-fixnum-shift+ :ecx))))))))))))
+ `((:movl (:ebp ,(argument-stack-offset binding)) ,tmp-reg)
+ (:movl ,source (,tmp-reg -1))))))))
+ (t (let ((location (new-binding-location binding frame-map)))
+ (if (integerp location)
+ `((:movl ,source (:ebp ,(stack-frame-offset location))))
+ (ecase (operator location)
+ ((:push)
+ `((:pushl ,source)))
+ ((:eax :ebx :ecx :edx)
+ (unless (eq source location)
+ `((:movl ,source ,location))))
+ (:argument-stack
+ (assert (<= 2 (function-argument-argnum binding)) ()
+ "store-lexical argnum can't be ~A." (function-argument-argnum binding))
+ `((:movl ,source (:ebp ,(argument-stack-offset binding)))))
+ (:untagged-fixnum-ecx
+ (append (unless (member source '(:ecx :untagged-fixnum-ecx))
+ `((:movl ,source :ecx)))
+ (unless (eq source :untagged-fixnum-ecx)
+ `((:sarl ,+movitz-fixnum-shift+ :ecx)))))))))))))
(defun finalize-code (code funobj frame-map)
;; (print-code 'to-be-finalized code)
@@ -3613,7 +3630,7 @@
(append `((:pushl :edx)
(:globally (:call (:edi (:edi-offset ensure-heap-cons-variable))))
(:popl :edx))
- (make-store-lexical lended-binding :eax t frame-map)))
+ (make-store-lexical lended-binding :eax t funobj frame-map)))
`((:movl :eax
(,funobj-register
,(+ (slot-offset 'movitz-funobj 'constant0)
@@ -3696,7 +3713,7 @@
`((: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)
+ (make-store-lexical function-binding :eax nil funobj frame-map)
(loop for bb in (borrowed-bindings sub-funobj)
append (make-lend-lexical bb :edx nil))))))
funobj frame-map)))
@@ -3762,7 +3779,7 @@
(movitz-null
(ecase (result-mode-type result-mode)
(:lexical-binding
- (make-store-lexical result-mode :edi nil frame-map))
+ (make-store-lexical result-mode :edi nil funobj frame-map))
(:push
'((:pushl :edi)))
((:eax :ebx :ecx :edx)
@@ -3800,7 +3817,7 @@
(:lexical-binding
(append `((:movl (:edi ,(global-constant-offset 't-symbol))
:eax))
- (make-store-lexical result-mode :eax nil frame-map)))
+ (make-store-lexical result-mode :eax nil funobj frame-map)))
#+ignore
(t (when (eq :boolean result-mode)
(warn "Compiling ~S for mode ~S." object result-mode))
@@ -3812,7 +3829,7 @@
(ecase (result-mode-type result-mode)
(:lexical-binding
(append (make-immediate-move x :eax)
- (make-store-lexical result-mode :eax nil frame-map)))
+ (make-store-lexical result-mode :eax nil funobj frame-map)))
(:untagged-fixnum-eax
(let ((value (movitz-fixnum-value object)))
(check-type value (unsigned-byte 16))
@@ -3833,7 +3850,7 @@
(:lexical-binding
(append `((:movl ,(new-make-compiled-constant-reference movitz-obj funobj)
:eax))
- (make-store-lexical result-mode :eax nil frame-map)))
+ (make-store-lexical result-mode :eax nil funobj frame-map)))
(:push
`((:pushl ,(new-make-compiled-constant-reference movitz-obj funobj))))
((:eax :ebx :ecx :edx :esi)
@@ -6049,7 +6066,7 @@
(declare (ignore type))
(make-store-lexical (ensure-local-binding destination funobj)
(ensure-local-binding source funobj)
- shared-reference-p frame-map
+ shared-reference-p funobj frame-map
:protect-registers protect-registers)))
;;;;;;;;;;;;;;;;;; Init-lexvar
@@ -6161,7 +6178,7 @@
(let* ((cons-position (getf (binding-lending binding)
:stack-cons-location))
(init-register (etypecase init-with-register
- (lexical-binding
+ ((or lexical-binding constant-object-binding)
(or (find-if (lambda (r)
(not (member r protect-registers)))
'(:edx :ebx :eax))
@@ -6189,7 +6206,7 @@
((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))))))))
+ (make-store-lexical binding init-with-register nil funobj frame-map))))))))
;;;;;;;;;;;;;;;;;; car
@@ -6308,6 +6325,7 @@
nil)
(define-extended-code-expander :incf-lexvar (instruction funobj frame-map)
+ (break "incf-lexvar??")
(destructuring-bind (binding delta &key protect-registers)
(cdr instruction)
(check-type binding binding)
@@ -6334,7 +6352,7 @@
(:addl ,(* delta +movitz-fixnum-factor+) :eax)
(:into)
,@(make-store-lexical (ensure-local-binding binding funobj)
- register nil frame-map
+ register nil funobj frame-map
:protect-registers protect-registers))))
(t (let ((register (chose-free-register protect-registers)))
`(,@(make-load-lexical (ensure-local-binding binding funobj)
@@ -6347,7 +6365,7 @@
(:addl ,(* delta +movitz-fixnum-factor+) ,register)
(:into)
,@(make-store-lexical (ensure-local-binding binding funobj)
- register nil frame-map
+ register nil funobj frame-map
:protect-registers protect-registers))))))))
;;;;; Load-constant
@@ -6384,7 +6402,16 @@
(define-find-read-bindings :add (term0 term1 destination)
(declare (ignore destination))
- (list term0 term1))
+ (let* ((type0 (and (binding-store-type term0)
+ (apply #'encoded-type-decode (binding-store-type term0))))
+ (type1 (and (binding-store-type term1)
+ (apply #'encoded-type-decode (binding-store-type term1))))
+ (singleton0 (and type0 (type-specifier-singleton type0)))
+ (singleton1 (and type1 (type-specifier-singleton type1))))
+ (append (unless (and singleton0 (typep (car singleton0) 'movitz-fixnum))
+ (list term0))
+ (unless (and singleton1 (typep (car singleton1) 'movitz-fixnum))
+ (list term1)))))
(define-extended-code-expander :add (instruction funobj frame-map)
(destructuring-bind (term0 term1 destination)
@@ -6415,18 +6442,47 @@
(let ((loc0 (new-binding-location (binding-target term0) frame-map :default nil))
(loc1 (new-binding-location (binding-target 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)
+ #+ignore
+ (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))
+ ((movitz-subtypep type0 '(integer 0 0))
+ (cond
+ ((eql destination loc1)
+ (break "NOP add: ~S" instruction))
+ ((and (member destination-location '(:eax :ebx :ecx :edx))
+ (member loc1 '(:eax :ebx :ecx :edx)))
+ `((:movl ,loc1 ,destination-location)))
+ ((integerp loc1)
+ (make-load-lexical term1 destination-location funobj nil frame-map))
+ #+ignore
+ ((integerp destination-location)
+ (make-store-lexical destination-location loc1 nil funobj frame-map))
+ (t (break "Unknown X zero-add: ~S" instruction))))
+ ((movitz-subtypep type1 '(integer 0 0))
+ ;; (warn "zero-add ~S => ~S [~S]" loc0 destination-location result-type)
+ (cond
+ ((eql destination loc0)
+ (break "NOP add: ~S" instruction))
+ ((and (member destination-location '(:eax :ebx :ecx :edx))
+ (member loc0 '(:eax :ebx :ecx :edx)))
+ `((:movl ,loc0 ,destination-location)))
+ ((integerp loc0)
+ (make-load-lexical term0 destination-location funobj nil frame-map))
+ #+ignore
+ ((integerp destination-location)
+ (make-store-lexical destination-location loc0 nil funobj frame-map))
+ (t (break "Unknown Y zero-add: ~S" instruction))))
((and (movitz-subtypep type0 'fixnum)
(movitz-subtypep type1 'fixnum)
(movitz-subtypep result-type 'fixnum))
+ ;; (warn "ADDX: ~S" instruction)
(cond
((and (type-specifier-singleton type0)
(eq loc1 destination-location))
@@ -6449,17 +6505,24 @@
(integerp destination-location))
(append `((:addl ,(movitz-immediate-value (car (type-specifier-singleton type0)))
,loc1))
- (make-store-lexical destination loc1 nil frame-map)))
- (t
-;;; (warn "ADD: ~A/~S = ~A/~S + ~A/~S,~%~A ~A"
-;;; destination-location
-;;; destination
-;;; loc0 term0
-;;; loc1 term1
-;;; (type-specifier-singleton type0)
-;;; (eq loc1 destination))
-;;; (warn "ADDI: ~S" instruction)
+ (make-store-lexical destination loc1 nil funobj frame-map)))
+ (t #+ignore (warn "ADD: ~A/~S = ~A/~S + ~A/~S,~%~A ~A"
+ destination-location
+ destination
+ loc0 term0
+ loc1 term1
+ (type-specifier-singleton type0)
+ (eq loc1 destination))
+;;; (warn "ADDI: ~S" instruction)
(append (cond
+ ((type-specifier-singleton type0)
+ (append (make-load-lexical term1 :eax funobj nil frame-map)
+ (make-load-constant (car (type-specifier-singleton type0))
+ :ebx funobj frame-map)))
+ ((type-specifier-singleton type1)
+ (append (make-load-lexical term0 :eax funobj nil frame-map)
+ (make-load-constant (car (type-specifier-singleton type1))
+ :ebx funobj frame-map)))
((and (eq :eax loc0) (eq :ebx loc1))
nil)
((and (eq :ebx loc0) (eq :eax loc1))
@@ -6477,8 +6540,16 @@
(unless (eq destination :eax)
`((:movl :eax ,destination))))
(binding
- (make-store-lexical destination :eax nil frame-map)))))))
+ (make-store-lexical destination :eax nil funobj frame-map)))))))
(t (append (cond
+ ((type-specifier-singleton type0)
+ (append (make-load-lexical term1 :eax funobj nil frame-map)
+ (make-load-constant (car (type-specifier-singleton type0))
+ :ebx funobj frame-map)))
+ ((type-specifier-singleton type1)
+ (append (make-load-lexical term0 :eax funobj nil frame-map)
+ (make-load-constant (car (type-specifier-singleton type1))
+ :ebx funobj frame-map)))
((and (eq :eax loc0) (eq :ebx loc1))
nil)
((and (eq :ebx loc0) (eq :eax loc1))
@@ -6496,7 +6567,7 @@
(unless (eq destination :eax)
`((:movl :eax ,destination))))
(binding
- (make-store-lexical destination :eax nil frame-map))))))))))
+ (make-store-lexical destination :eax nil funobj frame-map))))))))))
;;;;;;;
