Update of /project/movitz/cvsroot/movitz
In directory common-lisp.net:/tmp/cvs-serv3296
Modified Files:
compiler.lisp
Log Message:
Some more work on register scheduling. I'm starting to see how this
should have been designed in the first place.
Date: Tue Feb 17 15:23:51 2004
Author: ffjeld
Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.29 movitz/compiler.lisp:1.30
--- movitz/compiler.lisp:1.29 Mon Feb 16 20:42:50 2004
+++ movitz/compiler.lisp Tue Feb 17 15:23:51 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.29 2004/02/17 01:42:50 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.30 2004/02/17 20:23:51 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -432,7 +432,7 @@
(setf more-binding-references-p t))))))
binding-usage))
(when more-binding-references-p
- (warn "Unable to remove all binding-references duding lexical type analysis."))
+ (warn "Unable to remove all binding-references during lexical type analysis."))
;; 3.
(maphash (lambda (binding analysis)
(assert (null (type-analysis-binding-types analysis)) ()
@@ -442,6 +442,8 @@
(type-analysis-binding-types analysis))
(setf (binding-store-type binding)
(type-analysis-encoded-type analysis))
+ (when (apply #'encoded-type-singleton (type-analysis-encoded-type analysis))
+ (warn "Singleton: ~A" binding))
#+ignore
(when (or #+ignore (not (apply #'encoded-allp (type-analysis-encoded-type analysis)))
#+ignore (multiple-value-call #'encoded-subtypep
@@ -504,7 +506,7 @@
(when (listp instruction)
(let ((store-binding (find-written-binding-and-type instruction)))
(when store-binding
- (process-binding funobj store-binding '(:read))))
+ (process-binding funobj store-binding '(:write))))
(dolist (load-binding (find-read-bindings instruction))
(process-binding funobj load-binding '(:read)))
(case (car instruction)
@@ -1375,691 +1377,697 @@
(error "Peephole-optimizer recursive count reached ~D.
There is (propably) a bug in the peephole optimizer." recursive-count))
;; (warn "==================OPTIMIZE: ~{~&~A~}" unoptimized-code)
- (labels
- ((explain (always format &rest args)
- (when (or always *explain-peephole-optimizations*)
- (warn "Peephole: ~?~&----------------------------" format args)))
- (twop-p (c &optional op)
- (let ((c (ignore-instruction-prefixes c)))
- (and (listp c) (= 3 (length c))
- (or (not op) (eq op (first c)))
- (cdr c))))
- (twop-dst (c &optional op src)
- (let ((c (ignore-instruction-prefixes c)))
- (and (or (not src)
- (equal src (first (twop-p c op))))
- (second (twop-p c op)))))
- (twop-src (c &optional op dest)
- (let ((c (ignore-instruction-prefixes c)))
- (and (or (not dest)
- (equal dest (second (twop-p c op))))
- (first (twop-p c op)))))
- #+ignore
- (isrc (c)
- (let ((c (ignore-instruction-prefixes c)))
- (ecase (length (cdr c))
- (0 nil)
- (1 (cadr c))
- (2 (twop-src c)))))
- (idst (c)
- (let ((c (ignore-instruction-prefixes c)))
- (ecase (length (cdr c))
- (0 nil)
- (1 (cadr c))
- (2 (twop-dst c)))))
- (non-destructuve-p (c)
- (let ((c (ignore-instruction-prefixes c)))
- (and (consp c)
- (member (car c) '(:testl :testb :pushl :cmpl :cmpb :frame-map)))))
- (simple-instruction-p (c)
- (let ((c (ignore-instruction-prefixes c)))
- (and (listp c)
- (member (car c) '(:movl :xorl :popl :cmpl :leal :andl :addl :subl)))))
- (register-indirect-operand (op base)
- (multiple-value-bind (reg off)
- (when (listp op)
- (loop for x in op
- if (integerp x) sum x into off
- else collect x into reg
- finally (return (values reg off))))
- (and (eq base (car reg))
- (not (rest reg))
- off)))
- (stack-frame-operand (op)
- (register-indirect-operand op :ebp))
- (funobj-constant-operand (op)
- (register-indirect-operand op :esi))
- (global-constant-operand (op)
- (register-indirect-operand op :edi))
- (global-funcall-p (op &optional funs)
- (let ((op (ignore-instruction-prefixes op)))
- (when (instruction-is op :call)
- (let ((x (global-constant-operand (second op))))
- (flet ((try (name)
- (and (eql x (slot-offset 'movitz-constant-block name))
- name)))
- (cond
- ((not x) nil)
- ((null funs) t)
- ((atom funs) (try funs))
- (t (some #'try funs))))))))
- (preserves-stack-location-p (i stack-location)
- (let ((i (ignore-instruction-prefixes i)))
- (and (not (atom i))
- (or (global-funcall-p i)
- (instruction-is i :frame-map)
- (branch-instruction-label i)
- (non-destructuve-p i)
- (and (simple-instruction-p i)
- (not (eql stack-location (stack-frame-operand (idst i)))))))))
- (preserves-register-p (i register)
- (let ((i (ignore-instruction-prefixes i)))
- (and (not (atom i))
- (or (and (member register '(:edx))
- (member (global-funcall-p i)
- '(fast-car fast-cdr fast-car-ebx fast-cdr-ebx)))
- (instruction-is i :frame-map)
- (branch-instruction-label i)
- (non-destructuve-p i)
- (and (simple-instruction-p i)
- (not (eq register (idst i))))))))
- (register-operand (op)
- (and (member op '(:eax :ebx :ecx :edx :edi))
- op))
- (true-and-equal (x &rest more)
- (declare (dynamic-extent more))
- (and x (dolist (y more t)
- (unless (equal x y)
- (return nil)))))
- #+ignore
- (uses-stack-frame-p (c)
- (and (consp c)
- (some #'stack-frame-operand (cdr c))))
- (load-stack-frame-p (c &optional (op :movl))
- (stack-frame-operand (twop-src c op)))
- (store-stack-frame-p (c &optional (op :movl))
- (stack-frame-operand (twop-dst c op)))
- (read-stack-frame-p (c)
- (or (load-stack-frame-p c :movl)
- (load-stack-frame-p c :cmpl)
- (store-stack-frame-p c :cmpl)
+ (macrolet ((explain (always format &rest args)
+ `(when (or *explain-peephole-optimizations* ,always)
+ (warn "Peephole: ~@?~&----------------------------" ,format ,@args))))
+ (labels
+ (#+ignore
+ (explain (always format &rest args)
+ (when (or always *explain-peephole-optimizations*)
+ (warn "Peephole: ~?~&----------------------------" format args)))
+ (twop-p (c &optional op)
+ (let ((c (ignore-instruction-prefixes c)))
+ (and (listp c) (= 3 (length c))
+ (or (not op) (eq op (first c)))
+ (cdr c))))
+ (twop-dst (c &optional op src)
+ (let ((c (ignore-instruction-prefixes c)))
+ (and (or (not src)
+ (equal src (first (twop-p c op))))
+ (second (twop-p c op)))))
+ (twop-src (c &optional op dest)
+ (let ((c (ignore-instruction-prefixes c)))
+ (and (or (not dest)
+ (equal dest (second (twop-p c op))))
+ (first (twop-p c op)))))
+ #+ignore
+ (isrc (c)
+ (let ((c (ignore-instruction-prefixes c)))
+ (ecase (length (cdr c))
+ (0 nil)
+ (1 (cadr c))
+ (2 (twop-src c)))))
+ (idst (c)
+ (let ((c (ignore-instruction-prefixes c)))
+ (ecase (length (cdr c))
+ (0 nil)
+ (1 (cadr c))
+ (2 (twop-dst c)))))
+ (non-destructuve-p (c)
+ (let ((c (ignore-instruction-prefixes c)))
(and (consp c)
- (eq :pushl (car c))
- (stack-frame-operand (second c)))))
- (in-stack-frame-p (c reg)
- "Does c ensure that reg is in some particular stack-frame location?"
- (or (and (load-stack-frame-p c)
- (eq reg (twop-dst c))
- (stack-frame-operand (twop-src c)))
- (and (store-stack-frame-p c)
- (eq reg (twop-src c))
- (stack-frame-operand (twop-dst c)))))
- (load-funobj-constant-p (c)
- (funobj-constant-operand (twop-src c :movl)))
- #+ignore
- (sub-program-label-p (l)
- (and (consp l)
- (eq :sub-program (car l))))
- (local-load-p (c)
- (if (or (load-stack-frame-p c)
- (load-funobj-constant-p c))
- (twop-src c)
- nil))
- (label-here-p (label code)
- "Is <label> at this point in <code>?"
- (loop for i in code
- while (or (symbolp i)
- (instruction-is i :frame-map))
- thereis (eq label i)))
- (negate-branch (branch-type)
- (ecase branch-type
- (:jbe :ja) (:ja :jbe)
- (:jz :jnz) (:jnz :jz)
- (:je :jne) (:jne :je)
- (:jc :jnc) (:jnc :jc)
- (:jl :jge) (:jge :jl)
- (:jle :jg) (:jg :jle)))
- (branch-instruction-label (i &optional jmp (branch-types '(:je :jne :jb :jnb :jbe :jz :jl :jnz
- :jle :ja :jae :jg :jge :jnc :jc :js :jns)))
- "If i is a branch, return the label."
- (when jmp (push :jmp branch-types))
- (let ((i (ignore-instruction-prefixes i)))
- (or (and (listp i) (member (car i) branch-types)
- (listp (second i)) (member (car (second i)) '(quote muerte.cl::quote))
- (second (second i)))
- #+ignore
- (and (listp i)
- branch-types
- (symbolp (car i))
- (not (member (car i) '(:jmp :jecxz)))
- (char= #\J (char (symbol-name (car i)) 0))
- (warn "Not a branch: ~A / ~A [~A]" i (symbol-package (caadr i)) branch-types)))))
- (find-branches-to-label (start-pc label &optional (context-size 0))
- "Context-size is the number of instructions _before_ the branch you want returned."
- (dotimes (i context-size)
- (push nil start-pc))
- (loop for pc on start-pc
- as i = (nth context-size pc)
- as i-label = (branch-instruction-label i t)
- if (or (eq label i-label)
- (and (consp i-label)
- (eq :label-plus-one (car i-label))))
- nconc (list pc)
- else if (let ((sub-program i-label))
- (and (consp sub-program)
- (eq :sub-program (car sub-program))))
- nconc (find-branches-to-label (cddr (branch-instruction-label i t))
- label context-size)
- else if (and (not (atom i))
- (tree-search i label))
- nconc (list 'unknown-label-usage)))
- (optimize-trim-stack-frame (unoptimized-code)
- "Any unused local variables on the stack-frame?"
- unoptimized-code
- ;; BUILD A MAP OF USED STACK-VARS AND REMAP THEM!
- #+ignore (if (not (and stack-frame-size
- (find 'start-stack-frame-setup unoptimized-code)))
- unoptimized-code
- (let ((old-code unoptimized-code)
- (new-code ()))
- ;; copy everything upto start-stack-frame-setup
- (loop for i = (pop old-code)
- do (push i new-code)
- while old-code
- until (eq i 'start-stack-frame-setup))
- (assert (eq (car new-code) 'start-stack-frame-setup) ()
- "no start-stack-frame-setup label, but we already checked!")
- (loop for pos downfrom -8 by 4
- as i = (pop old-code)
- if (and (consp i) (eq :pushl (car i)) (symbolp (cadr i)))
- collect (cons pos (cadr i))
- and do (unless (find pos old-code :key #'read-stack-frame-p)
- (cond
- ((find pos old-code :key #'store-stack-frame-p)
- (warn "Unused local but stored var: ~S" pos))
- ((find pos old-code :key #'uses-stack-frame-p)
- (warn "Unused BUT USED local var: ~S" pos))
- (t (warn "Unused local var: ~S" pos))))
- else do
- (push i old-code)
- (loop-finish))))
- unoptimized-code)
- (frame-map-code (unoptimized-code)
- "After each label in unoptimized-code, insert a (:frame-map <full-map> <branch-map> <sticky>)
+ (member (car c) '(:testl :testb :pushl :cmpl :cmpb :frame-map)))))
+ (simple-instruction-p (c)
+ (let ((c (ignore-instruction-prefixes c)))
+ (and (listp c)
+ (member (car c) '(:movl :xorl :popl :cmpl :leal :andl :addl :subl)))))
+ (register-indirect-operand (op base)
+ (multiple-value-bind (reg off)
+ (when (listp op)
+ (loop for x in op
+ if (integerp x) sum x into off
+ else collect x into reg
+ finally (return (values reg off))))
+ (and (eq base (car reg))
+ (not (rest reg))
+ off)))
+ (stack-frame-operand (op)
+ (register-indirect-operand op :ebp))
+ (funobj-constant-operand (op)
+ (register-indirect-operand op :esi))
+ (global-constant-operand (op)
+ (register-indirect-operand op :edi))
+ (global-funcall-p (op &optional funs)
+ (let ((op (ignore-instruction-prefixes op)))
+ (when (instruction-is op :call)
+ (let ((x (global-constant-operand (second op))))
+ (flet ((try (name)
+ (and (eql x (slot-offset 'movitz-constant-block name))
+ name)))
+ (cond
+ ((not x) nil)
+ ((null funs) t)
+ ((atom funs) (try funs))
+ (t (some #'try funs))))))))
+ (preserves-stack-location-p (i stack-location)
+ (let ((i (ignore-instruction-prefixes i)))
+ (and (not (atom i))
+ (or (global-funcall-p i)
+ (instruction-is i :frame-map)
+ (branch-instruction-label i)
+ (non-destructuve-p i)
+ (and (simple-instruction-p i)
+ (not (eql stack-location (stack-frame-operand (idst i)))))))))
+ (preserves-register-p (i register)
+ (let ((i (ignore-instruction-prefixes i)))
+ (and (not (atom i))
+ (or (and (member register '(:edx))
+ (member (global-funcall-p i)
+ '(fast-car fast-cdr fast-car-ebx fast-cdr-ebx)))
+ (instruction-is i :frame-map)
+ (branch-instruction-label i)
+ (non-destructuve-p i)
+ (and (simple-instruction-p i)
+ (not (eq register (idst i))))))))
+ (register-operand (op)
+ (and (member op '(:eax :ebx :ecx :edx :edi))
+ op))
+ (true-and-equal (x &rest more)
+ (declare (dynamic-extent more))
+ (and x (dolist (y more t)
+ (unless (equal x y)
+ (return nil)))))
+ #+ignore
+ (uses-stack-frame-p (c)
+ (and (consp c)
+ (some #'stack-frame-operand (cdr c))))
+ (load-stack-frame-p (c &optional (op :movl))
+ (stack-frame-operand (twop-src c op)))
+ (store-stack-frame-p (c &optional (op :movl))
+ (stack-frame-operand (twop-dst c op)))
+ (read-stack-frame-p (c)
+ (or (load-stack-frame-p c :movl)
+ (load-stack-frame-p c :cmpl)
+ (store-stack-frame-p c :cmpl)
+ (and (consp c)
+ (eq :pushl (car c))
+ (stack-frame-operand (second c)))))
+ (in-stack-frame-p (c reg)
+ "Does c ensure that reg is in some particular stack-frame location?"
+ (or (and (load-stack-frame-p c)
+ (eq reg (twop-dst c))
+ (stack-frame-operand (twop-src c)))
+ (and (store-stack-frame-p c)
+ (eq reg (twop-src c))
+ (stack-frame-operand (twop-dst c)))))
+ (load-funobj-constant-p (c)
+ (funobj-constant-operand (twop-src c :movl)))
+ #+ignore
+ (sub-program-label-p (l)
+ (and (consp l)
+ (eq :sub-program (car l))))
+ (local-load-p (c)
+ (if (or (load-stack-frame-p c)
+ (load-funobj-constant-p c))
+ (twop-src c)
+ nil))
+ (label-here-p (label code)
+ "Is <label> at this point in <code>?"
+ (loop for i in code
+ while (or (symbolp i)
+ (instruction-is i :frame-map))
+ thereis (eq label i)))
+ (negate-branch (branch-type)
+ (ecase branch-type
+ (:jbe :ja) (:ja :jbe)
+ (:jz :jnz) (:jnz :jz)
+ (:je :jne) (:jne :je)
+ (:jc :jnc) (:jnc :jc)
+ (:jl :jge) (:jge :jl)
+ (:jle :jg) (:jg :jle)))
+ (branch-instruction-label (i &optional jmp (branch-types '(:je :jne :jb :jnb :jbe :jz :jl :jnz
+ :jle :ja :jae :jg :jge :jnc :jc :js :jns)))
+ "If i is a branch, return the label."
+ (when jmp (push :jmp branch-types))
+ (let ((i (ignore-instruction-prefixes i)))
+ (or (and (listp i) (member (car i) branch-types)
+ (listp (second i)) (member (car (second i)) '(quote muerte.cl::quote))
+ (second (second i)))
+ #+ignore
+ (and (listp i)
+ branch-types
+ (symbolp (car i))
+ (not (member (car i) '(:jmp :jecxz)))
+ (char= #\J (char (symbol-name (car i)) 0))
+ (warn "Not a branch: ~A / ~A [~A]" i (symbol-package (caadr i)) branch-types)))))
+ (find-branches-to-label (start-pc label &optional (context-size 0))
+ "Context-size is the number of instructions _before_ the branch you want returned."
+ (dotimes (i context-size)
+ (push nil start-pc))
+ (loop for pc on start-pc
+ as i = (nth context-size pc)
+ as i-label = (branch-instruction-label i t)
+ if (or (eq label i-label)
+ (and (consp i-label)
+ (eq :label-plus-one (car i-label))))
+ nconc (list pc)
+ else if (let ((sub-program i-label))
+ (and (consp sub-program)
+ (eq :sub-program (car sub-program))))
+ nconc (find-branches-to-label (cddr (branch-instruction-label i t))
+ label context-size)
+ else if (and (not (atom i))
+ (tree-search i label))
+ nconc (list 'unknown-label-usage)))
+ (optimize-trim-stack-frame (unoptimized-code)
+ "Any unused local variables on the stack-frame?"
+ unoptimized-code
+ ;; BUILD A MAP OF USED STACK-VARS AND REMAP THEM!
+ #+ignore (if (not (and stack-frame-size
+ (find 'start-stack-frame-setup unoptimized-code)))
+ unoptimized-code
+ (let ((old-code unoptimized-code)
+ (new-code ()))
+ ;; copy everything upto start-stack-frame-setup
+ (loop for i = (pop old-code)
+ do (push i new-code)
+ while old-code
+ until (eq i 'start-stack-frame-setup))
+ (assert (eq (car new-code) 'start-stack-frame-setup) ()
+ "no start-stack-frame-setup label, but we already checked!")
+ (loop for pos downfrom -8 by 4
+ as i = (pop old-code)
+ if (and (consp i) (eq :pushl (car i)) (symbolp (cadr i)))
+ collect (cons pos (cadr i))
+ and do (unless (find pos old-code :key #'read-stack-frame-p)
+ (cond
+ ((find pos old-code :key #'store-stack-frame-p)
+ (warn "Unused local but stored var: ~S" pos))
+ ((find pos old-code :key #'uses-stack-frame-p)
+ (warn "Unused BUT USED local var: ~S" pos))
+ (t (warn "Unused local var: ~S" pos))))
+ else do
+ (push i old-code)
+ (loop-finish))))
+ unoptimized-code)
+ (frame-map-code (unoptimized-code)
+ "After each label in unoptimized-code, insert a (:frame-map <full-map> <branch-map> <sticky>)
that says which registers are known to hold which stack-frame-locations.
A branch-map is the map that is guaranteed after every branch to the label, i.e. not including
falling below the label."
- #+ignore (warn "unmapped:~{~&~A~}" unoptimized-code)
- (flet ((rcode-map (code)
- #+ignore (when (instruction-is (car code) :testb)
- (warn "rcoding ~A" code))
- (loop with modifieds = nil
- with registers = (list :eax :ebx :ecx :edx)
- with local-map = nil
- for ii in code
- while registers
- do (flet ((add-map (stack reg)
- (when (and (not (member stack modifieds))
- (member reg registers))
- (push (cons stack reg)
- local-map))))
- (cond ((instruction-is ii :frame-map)
- (dolist (m (second ii))
- (add-map (car m) (cdr m))))
- ((load-stack-frame-p ii)
- (add-map (load-stack-frame-p ii)
- (twop-dst ii)))
- ((store-stack-frame-p ii)
- (add-map (store-stack-frame-p ii)
- (twop-src ii))
- (pushnew (store-stack-frame-p ii)
- modifieds))
- ((non-destructuve-p ii))
- ((branch-instruction-label ii))
- ((simple-instruction-p ii)
- (let ((op (idst ii)))
- (cond
- ((stack-frame-operand op)
- (pushnew (stack-frame-operand op) modifieds))
- ((symbolp op)
- (setf registers (delete op registers))))))
- (t #+ignore (when (instruction-is (car code) :testb)
- (warn "stopped at ~A" ii))
- (loop-finish))))
- (setf registers
- (delete-if (lambda (r)
- (not (preserves-register-p ii r)))
- registers))
- finally
- #+ignore (when (instruction-is (car code) :testb)
- (warn "..map ~A" local-map))
- (return local-map))))
- (loop with next-pc = 'auto-next
- ;; initially (warn "opt: ~{ ~A~%~}" unoptimized-code)
- for pc = unoptimized-code then (prog1 (if (eq 'auto-next next-pc) auto-next-pc next-pc)
- (setq next-pc 'auto-next))
- as auto-next-pc = (cdr unoptimized-code) then (cdr pc)
- as p = (list (car pc)) ; will be appended.
- as i1 = (first pc) ; current instruction, collected by default.
- and i2 = (second pc)
- while pc
- do (when (and (symbolp i1)
- (not (and (instruction-is i2 :frame-map)
- (fourth i2))))
- (let* ((label i1)
- (branch-map (reduce (lambda (&optional x y)
- (intersection x y :test #'equal))
- (mapcar (lambda (lpc)
- (if (eq 'unknown-label-usage lpc)
- nil
- (rcode-map (nreverse (subseq 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
- until (eq x pc)
- finally (return pos)))
- (back9 (max 0 (- pos 9))))
- (subseq unoptimized-code
- back9 pos)))))
- (if (instruction-uncontinues-p (car rcode))
- branch-map
- (intersection branch-map (rcode-map rcode) :test #'equal)))))
- (when (or full-map branch-map nil)
- #+ignore
- (explain nil "Inserting at ~A frame-map ~S branch-map ~S."
- label full-map branch-map))
- (setq p (list label `(:frame-map ,full-map ,branch-map))
- next-pc (if (instruction-is i2 :frame-map)
- (cddr pc)
- (cdr pc)))))
- nconc p)))
- (optimize-stack-frame-init (unoptimized-code)
- "Look at the function's stack-frame initialization code, and see
+ #+ignore (warn "unmapped:~{~&~A~}" unoptimized-code)
+ (flet ((rcode-map (code)
+ #+ignore (when (instruction-is (car code) :testb)
+ (warn "rcoding ~A" code))
+ (loop with modifieds = nil
+ with registers = (list :eax :ebx :ecx :edx)
+ with local-map = nil
+ for ii in code
+ while registers
+ do (flet ((add-map (stack reg)
+ (when (and (not (member stack modifieds))
+ (member reg registers))
+ (push (cons stack reg)
+ local-map))))
+ (cond ((instruction-is ii :frame-map)
+ (dolist (m (second ii))
+ (add-map (car m) (cdr m))))
+ ((load-stack-frame-p ii)
+ (add-map (load-stack-frame-p ii)
+ (twop-dst ii)))
+ ((store-stack-frame-p ii)
+ (add-map (store-stack-frame-p ii)
+ (twop-src ii))
+ (pushnew (store-stack-frame-p ii)
+ modifieds))
+ ((non-destructuve-p ii))
+ ((branch-instruction-label ii))
+ ((simple-instruction-p ii)
+ (let ((op (idst ii)))
+ (cond
+ ((stack-frame-operand op)
+ (pushnew (stack-frame-operand op) modifieds))
+ ((symbolp op)
+ (setf registers (delete op registers))))))
+ (t #+ignore (when (instruction-is (car code) :testb)
+ (warn "stopped at ~A" ii))
+ (loop-finish))))
+ (setf registers
+ (delete-if (lambda (r)
+ (not (preserves-register-p ii r)))
+ registers))
+ finally
+ #+ignore (when (instruction-is (car code) :testb)
+ (warn "..map ~A" local-map))
+ (return local-map))))
+ (loop with next-pc = 'auto-next
+ ;; initially (warn "opt: ~{ ~A~%~}" unoptimized-code)
+ for pc = unoptimized-code then (prog1 (if (eq 'auto-next next-pc) auto-next-pc next-pc)
+ (setq next-pc 'auto-next))
+ as auto-next-pc = (cdr unoptimized-code) then (cdr pc)
+ as p = (list (car pc)) ; will be appended.
+ as i1 = (first pc) ; current instruction, collected by default.
+ and i2 = (second pc)
+ while pc
+ do (when (and (symbolp i1)
+ (not (and (instruction-is i2 :frame-map)
+ (fourth i2))))
+ (let* ((label i1)
+ (branch-map (reduce (lambda (&optional x y)
+ (intersection x y :test #'equal))
+ (mapcar (lambda (lpc)
+ (if (eq 'unknown-label-usage lpc)
+ nil
+ (rcode-map (nreverse (subseq 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
+ until (eq x pc)
+ finally (return pos)))
+ (back9 (max 0 (- pos 9))))
+ (subseq unoptimized-code
+ back9 pos)))))
+ (if (instruction-uncontinues-p (car rcode))
+ branch-map
+ (intersection branch-map (rcode-map rcode) :test #'equal)))))
+ (when (or full-map branch-map nil)
+ #+ignore
+ (explain nil "Inserting at ~A frame-map ~S branch-map ~S."
+ label full-map branch-map))
+ (setq p (list label `(:frame-map ,full-map ,branch-map))
+ next-pc (if (instruction-is i2 :frame-map)
+ (cddr pc)
+ (cdr pc)))))
+ nconc p)))
+ (optimize-stack-frame-init (unoptimized-code)
+ "Look at the function's stack-frame initialization code, and see
if we can optimize that, and/or immediately subsequent loads/stores."
- (if (not (find 'start-stack-frame-setup unoptimized-code))
- unoptimized-code
- (let ((old-code unoptimized-code)
- (new-code ()))
- ;; copy everything upto start-stack-frame-setup
- (loop for i = (pop old-code)
- do (push i new-code)
- while old-code
- until (eq i 'start-stack-frame-setup))
- (assert (eq (car new-code) 'start-stack-frame-setup) ()
- "no start-stack-frame-setup label, but we already checked!")
- (let* ((frame-map (loop for pos downfrom -8 by 4
- as i = (pop old-code)
- if (and (consp i) (eq :pushl (car i)) (symbolp (cadr i)))
- collect (cons pos (cadr i))
- and do (push i new-code)
- else do
- (push i old-code)
- (loop-finish)))
- (mod-p (loop with mod-p = nil
- for i = `(:frame-map ,(copy-list frame-map) nil t)
- then (pop old-code)
- while i
- do (let ((new-i (cond
- ((let ((store-pos (store-stack-frame-p i)))
- (and store-pos
- (eq (cdr (assoc store-pos frame-map))
- (twop-src i))))
- (explain nil "removed stack-init store: ~S" i)
- nil)
- ((let ((load-pos (load-stack-frame-p i)))
- (and load-pos
- (eq (cdr (assoc load-pos frame-map))
- (twop-dst i))))
- (explain nil "removed stack-init load: ~S" i)
- nil)
- ((and (load-stack-frame-p i)
- (assoc (load-stack-frame-p i) frame-map))
- (let ((old-reg (cdr (assoc (load-stack-frame-p i)
- frame-map))))
- (explain nil "load ~S already in ~S."
- i old-reg)
- `(:movl ,old-reg ,(twop-dst i))))
- (t i))))
- (unless (eq new-i i)
- (setf mod-p t))
- (when (branch-instruction-label new-i t)
- (setf mod-p t)
- (push `(:frame-map ,(copy-list frame-map) nil t)
- new-code))
- (when new-i
- (push new-i new-code)
- ;; (warn "new-i: ~S, fm: ~S" new-i frame-map)
- (setf frame-map
- (delete-if (lambda (map)
- ;; (warn "considering: ~S" map)
- (not (and (preserves-register-p new-i (cdr map))
- (preserves-stack-location-p new-i
- (car map)))))
- frame-map))
- ;; (warn "Frame-map now: ~S" frame-map)
- (when (store-stack-frame-p new-i)
- (loop for map in frame-map
- do (when (= (store-stack-frame-p new-i)
- (car map))
- (setf (cdr map) (twop-src new-i)))))))
- while frame-map
- finally (return mod-p))))
- (if (not mod-p)
- unoptimized-code
- (append (nreverse new-code)
- old-code)))))))
- (let* ((unoptimized-code (frame-map-code (optimize-stack-frame-init unoptimized-code)))
- (code-modified-p nil)
- (stack-frame-used-map (loop with map = nil
- for i in unoptimized-code
- do (let ((x (read-stack-frame-p i)))
- (when x (pushnew x map)))
- (when (and (instruction-is i :leal)
- (stack-frame-operand (twop-src i)))
- (let ((x (stack-frame-operand (twop-src i))))
- (when (= (tag :cons) (ldb (byte 2 0) x))
- (pushnew (+ x -1) map)
- (pushnew (+ x 3) map))))
- finally (return map)))
- (optimized-code
- ;; This loop applies a set of (hard-coded) heuristics on unoptimized-code.
- (loop with next-pc = 'auto-next
- ;; initially (warn "opt: ~{ ~A~%~}" unoptimized-code)
- for pc = unoptimized-code then (prog1 (if (eq 'auto-next next-pc) auto-next-pc next-pc)
- (setq next-pc 'auto-next))
- as auto-next-pc = (cdr unoptimized-code) then (cdr pc)
- as p = (list (car pc)) ; will be appended.
- as original-p = p
- as i = (first pc) ; current instruction, collected by default.
- and i2 = (second pc) and i3 = (third pc) and i4 = (fourth pc) and i5 = (fifth pc)
- while pc
- do (cond
- ((and (instruction-is i :frame-map)
- (instruction-is i2 :frame-map)
- (not (fourth i))
- (not (fourth i2)))
- (let ((map (union (second i) (second i2) :test #'equal)))
- (explain nil "Merged maps:~%~A + ~A~% => ~A"
- (second i) (second i2) map)
- (setq p `((:frame-map ,map))
- next-pc (cddr pc))))
- ((let ((x (store-stack-frame-p i)))
- (and x (not (member x stack-frame-used-map))))
- (setq p nil)
- (explain nil "Removed store of unused local var: ~S" i))
- ((and (global-funcall-p i2 '(fast-car))
- (global-funcall-p i5 '(fast-cdr))
- (true-and-equal (in-stack-frame-p i :eax)
- (in-stack-frame-p i4 :eax)))
- (let ((call-prefix (if (consp (car i2)) (car i2) nil)))
- (cond
- ((equal i3 '(:pushl :eax))
- (explain nil "merge car,push,cdr to cdr-car,push")
- (setf p (list i
- `(,call-prefix :call
- (:edi ,(global-constant-offset 'fast-cdr-car)))
- `(:pushl :ebx))
- next-pc (nthcdr 5 pc)))
- ((and (store-stack-frame-p i3)
- (eq :eax (twop-src i3)))
- (explain nil "merge car,store,cdr to cdr-car,store")
- (setf p (list i
- `(,call-prefix :call
- (:edi ,(global-constant-offset 'fast-cdr-car)))
- `(:movl :ebx ,(twop-dst i3)))
- next-pc (nthcdr 5 pc)))
- (t (error "can't deal with cdr-car here: ~{~&~A~}" (subseq pc 0 8))))))
- ((flet ((try (place register &optional map reason)
- "See if we can remove a stack-frame load below current pc,
+ (if (not (find 'start-stack-frame-setup unoptimized-code))
+ unoptimized-code
+ (let ((old-code unoptimized-code)
+ (new-code ()))
+ ;; copy everything upto start-stack-frame-setup
+ (loop for i = (pop old-code)
+ do (push i new-code)
+ while old-code
+ until (eq i 'start-stack-frame-setup))
+ (assert (eq (car new-code) 'start-stack-frame-setup) ()
+ "no start-stack-frame-setup label, but we already checked!")
+ (let* ((frame-map (loop for pos downfrom -8 by 4
+ as i = (pop old-code)
+ if (and (consp i) (eq :pushl (car i)) (symbolp (cadr i)))
+ collect (cons pos (cadr i))
+ and do (push i new-code)
+ else do
+ (push i old-code)
+ (loop-finish)))
+ (mod-p (loop with mod-p = nil
+ for i = `(:frame-map ,(copy-list frame-map) nil t)
+ then (pop old-code)
+ while i
+ do (let ((new-i (cond
+ ((let ((store-pos (store-stack-frame-p i)))
+ (and store-pos
+ (eq (cdr (assoc store-pos frame-map))
+ (twop-src i))))
+ (explain nil "removed stack-init store: ~S" i)
+ nil)
+ ((let ((load-pos (load-stack-frame-p i)))
+ (and load-pos
+ (eq (cdr (assoc load-pos frame-map))
+ (twop-dst i))))
+ (explain nil "removed stack-init load: ~S" i)
+ nil)
+ ((and (load-stack-frame-p i)
+ (assoc (load-stack-frame-p i) frame-map))
+ (let ((old-reg (cdr (assoc (load-stack-frame-p i)
+ frame-map))))
+ (explain nil "load ~S already in ~S."
+ i old-reg)
+ `(:movl ,old-reg ,(twop-dst i))))
+ (t i))))
+ (unless (eq new-i i)
+ (setf mod-p t))
+ (when (branch-instruction-label new-i t)
+ (setf mod-p t)
+ (push `(:frame-map ,(copy-list frame-map) nil t)
+ new-code))
+ (when new-i
+ (push new-i new-code)
+ ;; (warn "new-i: ~S, fm: ~S" new-i frame-map)
+ (setf frame-map
+ (delete-if (lambda (map)
+ ;; (warn "considering: ~S" map)
+ (not (and (preserves-register-p new-i (cdr map))
+ (preserves-stack-location-p new-i
+ (car map)))))
+ frame-map))
+ ;; (warn "Frame-map now: ~S" frame-map)
+ (when (store-stack-frame-p new-i)
+ (loop for map in frame-map
+ do (when (= (store-stack-frame-p new-i)
+ (car map))
+ (setf (cdr map) (twop-src new-i)))))))
+ while frame-map
+ finally (return mod-p))))
+ (if (not mod-p)
+ unoptimized-code
+ (append (nreverse new-code)
+ old-code)))))))
+ (let* ((unoptimized-code (frame-map-code (optimize-stack-frame-init unoptimized-code)))
+ (code-modified-p nil)
+ (stack-frame-used-map (loop with map = nil
+ for i in unoptimized-code
+ do (let ((x (read-stack-frame-p i)))
+ (when x (pushnew x map)))
+ (when (and (instruction-is i :leal)
+ (stack-frame-operand (twop-src i)))
+ (let ((x (stack-frame-operand (twop-src i))))
+ (when (= (tag :cons) (ldb (byte 2 0) x))
+ (pushnew (+ x -1) map)
+ (pushnew (+ x 3) map))))
+ finally (return map)))
+ (optimized-code
+ ;; This loop applies a set of (hard-coded) heuristics on unoptimized-code.
+ (loop with next-pc = 'auto-next
+ ;; initially (warn "opt: ~{ ~A~%~}" unoptimized-code)
+ for pc = unoptimized-code then (prog1 (if (eq 'auto-next next-pc) auto-next-pc next-pc)
+ (setq next-pc 'auto-next))
+ as auto-next-pc = (cdr unoptimized-code) then (cdr pc)
+ as p = (list (car pc)) ; will be appended.
+ as original-p = p
+ as i = (first pc) ; current instruction, collected by default.
+ and i2 = (second pc) and i3 = (third pc) and i4 = (fourth pc) and i5 = (fifth pc)
+ while pc
+ do (cond
+ ((and (instruction-is i :frame-map)
+ (instruction-is i2 :frame-map)
+ (not (fourth i))
+ (not (fourth i2)))
+ (let ((map (union (second i) (second i2) :test #'equal)))
+ (explain nil "Merged maps:~%~A + ~A~% => ~A"
+ (second i) (second i2) map)
+ (setq p `((:frame-map ,map))
+ next-pc (cddr pc))))
+ ((let ((x (store-stack-frame-p i)))
+ (and x (not (member x stack-frame-used-map))))
+ (setq p nil)
+ (explain nil "Removed store of unused local var: ~S" i))
+ ((and (global-funcall-p i2 '(fast-car))
+ (global-funcall-p i5 '(fast-cdr))
+ (true-and-equal (in-stack-frame-p i :eax)
+ (in-stack-frame-p i4 :eax)))
+ (let ((call-prefix (if (consp (car i2)) (car i2) nil)))
+ (cond
+ ((equal i3 '(:pushl :eax))
+ (explain nil "merge car,push,cdr to cdr-car,push")
+ (setf p (list i
+ `(,call-prefix :call
+ (:edi ,(global-constant-offset 'fast-cdr-car)))
+ `(:pushl :ebx))
+ next-pc (nthcdr 5 pc)))
+ ((and (store-stack-frame-p i3)
+ (eq :eax (twop-src i3)))
+ (explain nil "merge car,store,cdr to cdr-car,store")
+ (setf p (list i
+ `(,call-prefix :call
+ (:edi ,(global-constant-offset 'fast-cdr-car)))
+ `(:movl :ebx ,(twop-dst i3)))
+ next-pc (nthcdr 5 pc)))
+ (t (error "can't deal with cdr-car here: ~{~&~A~}" (subseq pc 0 8))))))
+ ((flet ((try (place register &optional map reason)
+ "See if we can remove a stack-frame load below current pc,
given the knowledge that <register> is equal to <place>."
- (let ((next-load (and place
- (dolist (si (cdr pc))
- (when (and (twop-p si :cmpl)
- (equal place (twop-src si)))
- (warn "Reverse cmp not yet dealed with.."))
- (cond
- ((and (twop-p si :cmpl)
- (equal place (twop-dst si)))
- (return si))
- ((equal place (local-load-p si))
- (return si))
- ((or (not (consp si))
- (not (preserves-register-p si register))
- (equal place (twop-dst si)))
- (return nil)))
- (setf map
- (remove-if (lambda (m)
- (not (preserves-register-p si (cdr m))))
- map))))))
- (case (instruction-is next-load)
- (:movl
- (let ((pos (position next-load pc)))
- (setq p (nconc (subseq pc 0 pos)
- (if (or (eq register (twop-dst next-load))
- (find-if (lambda (m)
- (and (eq (twop-dst next-load) (cdr m))
- (= (car m) (stack-frame-operand place))))
- map))
- nil
- (list `(:movl ,register ,(twop-dst next-load)))))
- next-pc (nthcdr (1+ pos) pc))
- (explain nil "preserved load/store .. load ~S of place ~S because ~S."
- next-load place reason)))
- (:cmpl
- (let ((pos (position next-load pc)))
- (setq p (nconc (subseq pc 0 pos)
- (list `(:cmpl ,(twop-src next-load) ,register)))
- next-pc (nthcdr (1+ pos) pc))
- (explain nil "preserved load/store..cmp: ~S" p next-load))))
- (if next-load t nil))))
- (or (when (instruction-is i :frame-map)
- (loop for (place . register) in (second i)
+ (let ((next-load (and place
+ (dolist (si (cdr pc))
+ (when (and (twop-p si :cmpl)
+ (equal place (twop-src si)))
+ (warn "Reverse cmp not yet dealed with.."))
+ (cond
+ ((and (twop-p si :cmpl)
+ (equal place (twop-dst si)))
+ (return si))
+ ((equal place (local-load-p si))
+ (return si))
+ ((or (not (consp si))
+ (not (preserves-register-p si register))
+ (equal place (twop-dst si)))
+ (return nil)))
+ (setf map
+ (remove-if (lambda (m)
+ (not (preserves-register-p si (cdr m))))
+ map))))))
+ (case (instruction-is next-load)
+ (:movl
+ (let ((pos (position next-load pc)))
+ (setq p (nconc (subseq pc 0 pos)
+ (if (or (eq register (twop-dst next-load))
+ (find-if (lambda (m)
+ (and (eq (twop-dst next-load) (cdr m))
+ (= (car m) (stack-frame-operand place))))
+ map))
+ nil
+ (list `(:movl ,register ,(twop-dst next-load)))))
+ next-pc (nthcdr (1+ pos) pc))
+ (explain nil "preserved load/store .. load ~S of place ~S because ~S."
+ next-load place reason)))
+ (:cmpl
+ (let ((pos (position next-load pc)))
+ (setq p (nconc (subseq pc 0 pos)
+ (list `(:cmpl ,(twop-src next-load) ,register)))
+ next-pc (nthcdr (1+ pos) pc))
+ (explain nil "preserved load/store..cmp: ~S" p next-load))))
+ (if next-load t nil))))
+ (or (when (instruction-is i :frame-map)
+ (loop for (place . register) in (second i)
;;; do (warn "map try ~S ~S: ~S" place register
;;; (try place register))
- thereis (try `(:ebp ,place) register (second i) :frame-map)))
- (try (or (local-load-p i)
- (and (store-stack-frame-p i)
- (twop-dst i)))
- (if (store-stack-frame-p i)
- (twop-src i)
- (twop-dst i))
- nil i))))
- ((and (symbolp i)
- (instruction-is i2 :frame-map)
- (load-stack-frame-p i3)
- (eq (twop-dst i3)
- (cdr (assoc (load-stack-frame-p i3) (third i2))))
- (not (assoc (load-stack-frame-p i3) (second i2))))
- (let ((reg (cdr (assoc (load-stack-frame-p i3) (third i2)))))
- (explain nil "factor out load from loop: ~S" i3)
- (assert (eq reg (twop-dst i3)))
- (setq p (if (eq reg (twop-dst i3))
- (list i3 i i2)
- (append (list i3 i i2)
- `((:movl ,reg ,(twop-dst i3)))))
- next-pc (cdddr pc))))
- ;; ((:jmp x) ...(no labels).... x ..)
- ;; => (x ...)
- ((let ((x (branch-instruction-label i t nil)))
- (and (position x (cdr pc))
- (not (find-if #'symbolp (cdr pc) :end (position x (cdr pc))))))
- (explain nil "jmp x .. x: ~W"
- (subseq pc 0 (1+ (position (branch-instruction-label i t nil)
- pc))))
- (setq p nil
- next-pc (member (branch-instruction-label i t nil) pc)))
- ;; (:jcc 'x) .... x (:jmp 'y) ..
- ;; => (:jcc 'y) .... x (:jmp 'y) ..
- ((let* ((from (branch-instruction-label i t))
- (dest (member (branch-instruction-label i t)
- unoptimized-code))
- (to (branch-instruction-label (if (instruction-is (second dest) :frame-map)
- (third dest)
- (second dest))
- t nil)))
- (when (and from to (not (eq from to)))
- (setq p (list `(,(car i) ',to)))
- (explain nil "branch redirect from ~S to ~S" from to)
- t)))
- ;; remove branch no-ops.
- ((and (branch-instruction-label i t)
- (label-here-p (branch-instruction-label i t)
- (cdr pc)))
- (explain nil "branch no-op: ~A" i)
- (setq p nil))
- ((and (symbolp i)
- (null (symbol-package i))
- (null (find-branches-to-label unoptimized-code i))
- (not (member i keep-labels)))
- (setq p nil
- next-pc (cdr pc))
- (explain nil "unused label: ~S" i))
- ;; ((:jcc 'label) (:jmp 'y) label) => ((:jncc 'y) label)
- ((and (branch-instruction-label i)
- (branch-instruction-label i2 t nil)
- (symbolp i3)
- (eq (branch-instruction-label i) i3))
- (setq p (list `(,(negate-branch (first i))
- ',(branch-instruction-label i2 t nil)))
- next-pc (nthcdr 2 pc))
- (explain nil "collapsed double negative branch to ~S: ~A." i3 p))
- ((and (branch-instruction-label i)
- (instruction-is i2 :frame-map)
- (branch-instruction-label i3 t nil)
- (symbolp i4)
- (eq (branch-instruction-label i) i4))
- (setq p (list `(,(negate-branch (first i))
- ',(branch-instruction-label i3 t nil)))
- next-pc (nthcdr 3 pc))
- (explain nil "collapsed double negative branch to ~S: ~A." i4 p))
- ((and (twop-p i :movl)
- (register-operand (twop-src i))
- (register-operand (twop-dst i))
- (twop-p i2 :movl)
- (eq (twop-dst i) (twop-dst i2))
- (register-indirect-operand (twop-src i2) (twop-dst i)))
- (setq p (list `(:movl (,(twop-src i)
- ,(register-indirect-operand (twop-src i2)
- (twop-dst i)))
- ,(twop-dst i2)))
- next-pc (nthcdr 2 pc))
- (explain nil "(movl edx eax) (movl (eax <z>) eax) => (movl (edx <z>) eax: ~S"
- p))
- ((and (twop-p i :movl)
- (instruction-is i2 :pushl)
- (eq (twop-dst i) (second i2))
- (twop-p i3 :movl)
- (eq (twop-dst i) (twop-dst i3)))
- (setq p (list `(:pushl ,(twop-src i)))
- next-pc (nthcdr 2 pc))
- (explain nil "(movl <z> :eax) (pushl :eax) => (pushl <z>): ~S" p))
- ((and (instruction-uncontinues-p i)
- (not (or (symbolp i2)
- #+ignore (member (instruction-is i2) '(:foobar)))))
- (do ((x (cdr pc) (cdr x)))
- (nil)
- (cond
- ((not (or (symbolp (car x))
- #+ignore (member (instruction-is (car x)) '(:foobar))))
- (explain nil "Removing unreachable code ~A after ~A." (car x) i))
- (t (setf p (list i)
- next-pc x)
- (return)))))
- ((and (store-stack-frame-p i)
- (load-stack-frame-p i2)
- (load-stack-frame-p i3)
- (= (store-stack-frame-p i)
- (load-stack-frame-p i3))
- (not (eq (twop-dst i2) (twop-dst i3))))
- (setq p (list i `(:movl ,(twop-src i) ,(twop-dst i3)) i2)
- next-pc (nthcdr 3 pc))
- (explain nil "store, z, load => store, move, z: ~A" p))
- ((and (instruction-is i :movl)
- (member (twop-dst i) '(:eax :ebx :ecx :edx))
- (instruction-is i2 :pushl)
- (not (member (second i2) '(:eax :ebx :ecx :edx)))
- (equal (twop-src i) (second i2)))
- (setq p (list i `(:pushl ,(twop-dst i)))
- next-pc (nthcdr 2 pc))
- (explain t "load, push => load, push reg."))
- ((and (instruction-is i :movl)
- (member (twop-src i) '(:eax :ebx :ecx :edx))
- (instruction-is i2 :pushl)
- (not (member (second i2) '(:eax :ebx :ecx :edx)))
- (equal (twop-dst i) (second i2)))
- (setq p (list i `(:pushl ,(twop-src i)))
- next-pc (nthcdr 2 pc))
- (explain nil "store, push => store, push reg: ~S ~S" i i2))
- ((and (instruction-is i :cmpl)
- (true-and-equal (stack-frame-operand (twop-dst i))
- (load-stack-frame-p i3))
- (branch-instruction-label i2))
- (setf p (list i3
- `(:cmpl ,(twop-src i) ,(twop-dst i3))
- i2)
- next-pc (nthcdr 3 pc))
- (explain nil "~S ~S ~S => ~S" i i2 i3 p))
- ((and (instruction-is i :pushl)
- (instruction-is i3 :popl)
- (store-stack-frame-p i2)
- (store-stack-frame-p i4)
- (eq (idst i3) (twop-src i4)))
- (setf p (list i2
- `(:movl ,(idst i) ,(twop-dst i4))
- `(:movl ,(idst i) ,(idst i3)))
- next-pc (nthcdr 4 pc))
- (explain nil "~S => ~S" (subseq pc 0 4) p))
- #+ignore
- ((let ((i6 (nth 6 pc)))
- (and (global-funcall-p i2 '(fast-car))
- (global-funcall-p i6 '(fast-cdr))
- (load-stack-frame-p i)
- (eq :eax (twop-dst i))
- (equal i i4))))
- ((and (equal i '(:movl :ebx :eax))
- (global-funcall-p i2 '(fast-car fast-cdr)))
- (let ((newf (ecase (global-funcall-p i2 '(fast-car fast-cdr))
- (fast-car 'fast-car-ebx)
- (fast-cdr 'fast-cdr-ebx))))
- (setq p `((:call (:edi ,(global-constant-offset newf))))
+ thereis (try `(:ebp ,place) register (second i) :frame-map)))
+ (try (or (local-load-p i)
+ (and (store-stack-frame-p i)
+ (twop-dst i)))
+ (if (store-stack-frame-p i)
+ (twop-src i)
+ (twop-dst i))
+ nil i))))
+ ((and (symbolp i)
+ (instruction-is i2 :frame-map)
+ (load-stack-frame-p i3)
+ (eq (twop-dst i3)
+ (cdr (assoc (load-stack-frame-p i3) (third i2))))
+ (not (assoc (load-stack-frame-p i3) (second i2))))
+ (let ((reg (cdr (assoc (load-stack-frame-p i3) (third i2)))))
+ (explain nil "factor out load from loop: ~S" i3)
+ (assert (eq reg (twop-dst i3)))
+ (setq p (if (eq reg (twop-dst i3))
+ (list i3 i i2)
+ (append (list i3 i i2)
+ `((:movl ,reg ,(twop-dst i3)))))
+ next-pc (cdddr pc))))
+ ;; ((:jmp x) ...(no labels).... x ..)
+ ;; => (x ...)
+ ((let ((x (branch-instruction-label i t nil)))
+ (and (position x (cdr pc))
+ (not (find-if #'symbolp (cdr pc) :end (position x (cdr pc))))))
+ (explain nil "jmp x .. x: ~W"
+ (subseq pc 0 (1+ (position (branch-instruction-label i t nil)
+ pc))))
+ (setq p nil
+ next-pc (member (branch-instruction-label i t nil) pc)))
+ ;; (:jcc 'x) .... x (:jmp 'y) ..
+ ;; => (:jcc 'y) .... x (:jmp 'y) ..
+ ((let* ((from (branch-instruction-label i t))
+ (dest (member (branch-instruction-label i t)
+ unoptimized-code))
+ (to (branch-instruction-label (if (instruction-is (second dest) :frame-map)
+ (third dest)
+ (second dest))
+ t nil)))
+ (when (and from to (not (eq from to)))
+ (setq p (list `(,(car i) ',to)))
+ (explain nil "branch redirect from ~S to ~S" from to)
+ t)))
+ ;; remove branch no-ops.
+ ((and (branch-instruction-label i t)
+ (label-here-p (branch-instruction-label i t)
+ (cdr pc)))
+ (explain nil "branch no-op: ~A" i)
+ (setq p nil))
+ ((and (symbolp i)
+ (null (symbol-package i))
+ (null (find-branches-to-label unoptimized-code i))
+ (not (member i keep-labels)))
+ (setq p nil
+ next-pc (cdr pc))
+ (explain nil "unused label: ~S" i))
+ ;; ((:jcc 'label) (:jmp 'y) label) => ((:jncc 'y) label)
+ ((and (branch-instruction-label i)
+ (branch-instruction-label i2 t nil)
+ (symbolp i3)
+ (eq (branch-instruction-label i) i3))
+ (setq p (list `(,(negate-branch (first i))
+ ',(branch-instruction-label i2 t nil)))
+ next-pc (nthcdr 2 pc))
+ (explain nil "collapsed double negative branch to ~S: ~A." i3 p))
+ ((and (branch-instruction-label i)
+ (instruction-is i2 :frame-map)
+ (branch-instruction-label i3 t nil)
+ (symbolp i4)
+ (eq (branch-instruction-label i) i4))
+ (setq p (list `(,(negate-branch (first i))
+ ',(branch-instruction-label i3 t nil)))
+ next-pc (nthcdr 3 pc))
+ (explain nil "collapsed double negative branch to ~S: ~A." i4 p))
+ ((and (twop-p i :movl)
+ (register-operand (twop-src i))
+ (register-operand (twop-dst i))
+ (twop-p i2 :movl)
+ (eq (twop-dst i) (twop-dst i2))
+ (register-indirect-operand (twop-src i2) (twop-dst i)))
+ (setq p (list `(:movl (,(twop-src i)
+ ,(register-indirect-operand (twop-src i2)
+ (twop-dst i)))
+ ,(twop-dst i2)))
+ next-pc (nthcdr 2 pc))
+ (explain nil "(movl edx eax) (movl (eax <z>) eax) => (movl (edx <z>) eax: ~S"
+ p))
+ ((and (twop-p i :movl)
+ (instruction-is i2 :pushl)
+ (eq (twop-dst i) (second i2))
+ (twop-p i3 :movl)
+ (eq (twop-dst i) (twop-dst i3)))
+ (setq p (list `(:pushl ,(twop-src i)))
+ next-pc (nthcdr 2 pc))
+ (explain nil "(movl <z> :eax) (pushl :eax) => (pushl <z>): ~S" p))
+ ((and (instruction-uncontinues-p i)
+ (not (or (symbolp i2)
+ #+ignore (member (instruction-is i2) '(:foobar)))))
+ (do ((x (cdr pc) (cdr x)))
+ (nil)
+ (cond
+ ((not (or (symbolp (car x))
+ #+ignore (member (instruction-is (car x)) '(:foobar))))
+ (explain nil "Removing unreachable code ~A after ~A." (car x) i))
+ (t (setf p (list i)
+ next-pc x)
+ (return)))))
+ ((and (store-stack-frame-p i)
+ (load-stack-frame-p i2)
+ (load-stack-frame-p i3)
+ (= (store-stack-frame-p i)
+ (load-stack-frame-p i3))
+ (not (eq (twop-dst i2) (twop-dst i3))))
+ (setq p (list i `(:movl ,(twop-src i) ,(twop-dst i3)) i2)
+ next-pc (nthcdr 3 pc))
+ (explain nil "store, z, load => store, move, z: ~A" p))
+ ((and (instruction-is i :movl)
+ (member (twop-dst i) '(:eax :ebx :ecx :edx))
+ (instruction-is i2 :pushl)
+ (not (member (second i2) '(:eax :ebx :ecx :edx)))
+ (equal (twop-src i) (second i2)))
+ (setq p (list i `(:pushl ,(twop-dst i)))
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))))
+ (explain t "load, push => load, push reg."))
+ ((and (instruction-is i :movl)
+ (member (twop-src i) '(:eax :ebx :ecx :edx))
+ (instruction-is i2 :pushl)
+ (not (member (second i2) '(:eax :ebx :ecx :edx)))
+ (equal (twop-dst i) (second i2)))
+ (setq p (list i `(:pushl ,(twop-src i)))
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))
- (eql (load-stack-frame-p i)
- (load-stack-frame-p i4)))
- (let ((newf (ecase (global-funcall-p i2 '(fast-car fast-cdr))
- (fast-car 'fast-car-ebx)
- (fast-cdr 'fast-cdr-ebx))))
- (setq p `((:movl ,(twop-src i) :ebx)
- (:call (:edi ,(global-constant-offset newf)))
- ,i3
- ,@(unless (eq :ebx (twop-dst i4))
- `((:movl :ebx ,(twop-dst i4)))))
+ (explain nil "store, push => store, push reg: ~S ~S" i i2))
+ ((and (instruction-is i :cmpl)
+ (true-and-equal (stack-frame-operand (twop-dst i))
+ (load-stack-frame-p i3))
+ (branch-instruction-label i2))
+ (setf p (list i3
+ `(:cmpl ,(twop-src i) ,(twop-dst i3))
+ i2)
+ next-pc (nthcdr 3 pc))
+ (explain nil "~S ~S ~S => ~S" i i2 i3 p))
+ ((and (instruction-is i :pushl)
+ (instruction-is i3 :popl)
+ (store-stack-frame-p i2)
+ (store-stack-frame-p i4)
+ (eq (idst i3) (twop-src i4)))
+ (setf p (list i2
+ `(:movl ,(idst i) ,(twop-dst i4))
+ `(:movl ,(idst i) ,(idst i3)))
next-pc (nthcdr 4 pc))
- (explain nil "load around ~A" newf))))
- do (unless (eq p original-p) ; auto-detect whether any heuristic fired..
- #+ignore (warn "at ~A, ~A inserted ~A" i i2 p)
- #+ignore (warn "modified at ~S ~S ~S" i i2 i3)
- (setf code-modified-p t))
- nconc p)))
- (if code-modified-p
- (apply #'optimize-code-internal optimized-code (1+ recursive-count) key-args)
- (optimize-trim-stack-frame
- (remove :frame-map (progn #+ignore (warn "maps:~{~&~A~}" unoptimized-code)
- unoptimized-code)
- :key (lambda (x)
- (when (consp x)
- (car x)))))))))
+ (explain nil "~S => ~S" (subseq pc 0 4) p))
+ #+ignore
+ ((let ((i6 (nth 6 pc)))
+ (and (global-funcall-p i2 '(fast-car))
+ (global-funcall-p i6 '(fast-cdr))
+ (load-stack-frame-p i)
+ (eq :eax (twop-dst i))
+ (equal i i4))))
+ ((and (equal i '(:movl :ebx :eax))
+ (global-funcall-p i2 '(fast-car fast-cdr)))
+ (let ((newf (ecase (global-funcall-p i2 '(fast-car fast-cdr))
+ (fast-car 'fast-car-ebx)
+ (fast-cdr 'fast-cdr-ebx))))
+ (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))
+ (preserves-register-p i3 :ebx)
+ (eql (load-stack-frame-p i)
+ (load-stack-frame-p i4)))
+ (let ((newf (ecase (global-funcall-p i2 '(fast-car fast-cdr))
+ (fast-car 'fast-car-ebx)
+ (fast-cdr 'fast-cdr-ebx))))
+ (setq p `((:movl ,(twop-src i) :ebx)
+ (:call (:edi ,(global-constant-offset newf)))
+ ,i3
+ ,@(unless (eq :ebx (twop-dst i4))
+ `((:movl :ebx ,(twop-dst i4)))))
+ next-pc (nthcdr 4 pc))
+ (explain nil "load around ~A: ~{~&~A~}~%=>~% ~{~&~A~}"
+ newf (subseq pc 0 5) p))))
+ do (unless (eq p original-p) ; auto-detect whether any heuristic fired..
+ #+ignore (warn "at ~A, ~A inserted ~A" i i2 p)
+ #+ignore (warn "modified at ~S ~S ~S" i i2 i3)
+ (setf code-modified-p t))
+ nconc p)))
+ (if code-modified-p
+ (apply #'optimize-code-internal optimized-code (1+ recursive-count) key-args)
+ (optimize-trim-stack-frame
+ (remove :frame-map (progn #+ignore (warn "maps:~{~&~A~}" unoptimized-code)
+ unoptimized-code)
+ :key (lambda (x)
+ (when (consp x)
+ (car x))))))))))
;;;; Compiler internals
@@ -2076,11 +2084,12 @@
(defmethod print-object ((object binding) stream)
(print-unreadable-object (object stream :type t :identity t)
(when (slot-boundp object 'name)
- (format stream "name: ~S~@[->~S~]~@[ stype: ~A~]"
+ (format stream "name: ~S~@[->~S~]~@[ %~A~]"
(binding-name object)
(unless (eq object (binding-target object))
(binding-name (binding-target object)))
- (when (binding-store-type object)
+ (when (and (slot-boundp object 'store-type)
+ (binding-store-type object))
(apply #'encoded-type-decode
(binding-store-type object)))))))
@@ -2428,27 +2437,39 @@
(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))
- (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)))
+ (t (case (instruction-is i)
+ ((nil :call)
+ (return nil))
+ ((:into))
+ ((:jnz :je :jne :jz))
+ ((:outb)
+ (setf free-so-far
+ (set-difference free-so-far '(:eax :edx))))
+ ((:movb :testb :andb :cmpb)
+ (setf free-so-far
+ (remove-if (lambda (r)
+ (or (tree-search i r)
+ (tree-search i (register32-to-low8 r))))
+ free-so-far)))
+ ((:shrl :cmpl :pushl :popl :leal :movl :testl :andl :addl :subl :imull)
+ (setf free-so-far
+ (remove-if (lambda (r)
+ (tree-search i r))
+ free-so-far)))
+ ((:load-constant :load-lexical :store-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))
+ (setf free-so-far
+ (remove-if (lambda (r)
+ (or (tree-search exp r)
+ (tree-search exp (register32-to-low8 r))))
+ free-so-far))))
+ (t (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)
@@ -2987,14 +3008,14 @@
(:eax
(assert (not indirect-p))
(ecase result-mode
- ((:ebx :ecx :edx) `((:movl :eax ,result-mode)))
+ ((:ebx :ecx :edx :esi) `((: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))))))
+ ((:ebx :ecx :edx :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))
@@ -3047,7 +3068,7 @@
(cond
((and (binding-lended-p binding)
(not shared-reference-p))
- (case result-mode
+ (case (result-mode-type result-mode)
((:single-value :eax :ebx :ecx :edx :esi :esp)
(install-for-single-value binding binding-location
(single-value-register result-mode) t))
@@ -3066,7 +3087,7 @@
(t (make-result-and-returns-glue
result-mode :eax
(install-for-single-value binding binding-location :eax t)))))
- (t (case (operator result-mode)
+ (t (case (result-mode-type result-mode)
((:single-value :eax :ebx :ecx :edx :esi :esp)
(install-for-single-value binding binding-location
(single-value-register result-mode) nil))
@@ -3106,6 +3127,27 @@
(make-result-and-returns-glue
result-mode :ecx
(install-for-single-value binding binding-location :ecx nil)))
+ (:lexical-binding
+ (let* ((destination result-mode)
+ (dest-location (new-binding-location destination frame-map :default nil)))
+ (cond
+ ((not dest-location) ; unknown, e.g. a borrowed-binding.
+ (warn "unknown dest-loc for ~A" destination)
+ (append (install-for-single-value binding binding-location :ecx nil)
+ (make-store-lexical result-mode :ecx nil frame-map)))
+ ((eql binding-location dest-location)
+ nil)
+ ((member binding-location '(:eax :ebx :ecx :edx))
+ (make-store-lexical destination binding-location nil 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"
+ binding-location
+ dest-location
+ binding
+ destination)
+ (append (install-for-single-value binding binding-location :ecx nil)
+ (make-store-lexical result-mode :ecx nil frame-map))))))
(t (make-result-and-returns-glue
result-mode :eax
(install-for-single-value binding binding-location :eax nil)))
@@ -4266,7 +4308,7 @@
:type ,(type-specifier-primary type))))
desired-result
t))
- ((:ebx)
+ ((:ebx :ecx)
(values (append code
`((:store-lexical ,desired-result
,(result-mode-type returns-provided)
@@ -5108,7 +5150,13 @@
((:function :multiple-values :eax)
:eax)
(:lexical-binding
- :eax)
+ ;; We can use ECX as temporary storage,
+ ;; because this value will be reachable
+ ;; from at least one variable.
+ ;; XXXX But, probably we shouldn't decide
+ ;; on this here, rather use binding
+ ;; as result-mode in :load-lexical.
+ result-mode #+ignore :ecx)
((:ebx :ecx :edx :esi :push
:untagged-fixnum-eax
:untagged-fixnum-ecx
@@ -5441,15 +5489,16 @@
(defun ensure-local-binding (binding funobj)
"When referencing binding in funobj, ensure we have the binding local to funobj."
- (cond
- ((not (typep binding 'binding))
- binding)
- ((eq funobj (binding-funobj binding))
- binding)
- (t (or (find binding (borrowed-bindings funobj)
- :key (lambda (binding)
- (borrowed-binding-target binding)))
- (error "Can't install non-local binding ~W." binding)))))
+ (if (not (typep binding 'binding))
+ binding
+ (let ((binding (binding-target binding)))
+ (cond
+ ((eq funobj (binding-funobj binding))
+ binding)
+ (t (or (find binding (borrowed-bindings funobj)
+ :key (lambda (binding)
+ (borrowed-binding-target binding)))
+ (error "Can't install non-local binding ~W." binding)))))))
(defun binding-type-specifier (binding)
(etypecase binding
@@ -5636,6 +5685,7 @@
(let* ((binding (binding-target binding))
(location (new-binding-location binding frame-map :default nil))
(binding-type (binding-store-type binding)))
+;;; (warn "incf b ~A, loc: ~A, typ: ~A" binding location binding-type)
(cond
((and binding-type
location
@@ -5670,3 +5720,16 @@
register nil frame-map
:protect-registers protect-registers))))))))
+;;;;; Load-constant
+
+(define-find-write-binding-and-type :load-constant (instruction)
+ (destructuring-bind (object result-mode &key (op :movl))
+ (cdr instruction)
+ (when (and (eq op :movl) (typep result-mode 'binding))
+ (check-type result-mode 'lexical-binding)
+ (values result-mode `(eql ,object)))))
+
+(define-extended-code-expander :load-constant (instruction funobj frame-map)
+ (destructuring-bind (object result-mode &key (op :movl))
+ (cdr instruction)
+ (make-load-constant object result-mode funobj frame-map :op op)))
