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)))