[movitz-cvs] CVS movitz
ffjeld
ffjeld at common-lisp.net
Sun Mar 11 22:40:58 UTC 2007
Update of /project/movitz/cvsroot/movitz
In directory clnet:/tmp/cvs-serv14273
Modified Files:
compiler.lisp
Log Message:
Tweak peephole optimizer.
--- /project/movitz/cvsroot/movitz/compiler.lisp 2007/03/01 21:27:39 1.181
+++ /project/movitz/cvsroot/movitz/compiler.lisp 2007/03/11 22:40:57 1.182
@@ -8,7 +8,7 @@
;;;; Created at: Wed Oct 25 12:30:49 2000
;;;; Distribution: See the accompanying file COPYING.
;;;;
-;;;; $Id: compiler.lisp,v 1.181 2007/03/01 21:27:39 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.182 2007/03/11 22:40:57 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -1288,22 +1288,25 @@
until (eq form '#0#)
appending
(with-simple-restart (skip-toplevel-form
- "Skip the compilation of top-level form~@[ ~A~]."
- (cond
- ((symbolp form) form)
- ((symbolp (car form)) (car form))))
+ "Skip the compilation of top-level form~{ ~A~}."
+ (cond
+ ((symbolp form)
+ (list form))
+ ((symbolp (car form))
+ (list (car form)
+ (cadr form)))))
(when *compiler-verbose-p*
- (format *query-io* "~&Movitz Compiling ~S..~%"
- (cond
- ((symbolp form) form)
- ((symbolp (car form))
- (xsubseq form 0 2)))))
- (compiler-call #'compile-form
- :form form
- :funobj funobj
- :env function-env
- :top-level-p t
- :result-mode :ignore))))))
+ (format *query-io* "~&Movitz Compiling ~S..~%"
+ (cond
+ ((symbolp form) form)
+ ((symbolp (car form))
+ (xsubseq form 0 2)))))
+ (compiler-call #'compile-form
+ :form form
+ :funobj funobj
+ :env function-env
+ :top-level-p t
+ :result-mode :ignore))))))
(cond
((null file-code)
(setf (image-load-time-funobjs *image*)
@@ -1819,49 +1822,55 @@
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
+ (let* ((frame-map (loop with pos = -8
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)
+ if (instruction-is i :frame-map)
+ do (progn :nothing)
+ else if
+ (and (consp i) (eq :pushl (car i)) (symbolp (cadr i)))
+ collect
+ (cons pos (cadr i))
+ and do
+ (decf pos 4)
+ (push i new-code)
else do
- (push i old-code)
- (loop-finish)))
+ (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))))
- ((and (instruction-is i :pushl)
- (stack-frame-operand (idst i))
- (assoc (stack-frame-operand (idst i))
- frame-map))
- (let ((old-reg
- (cdr (assoc (stack-frame-operand (idst i))
- frame-map))))
- (explain nil "push ~S already in ~S."
- i old-reg)
- `(:pushl ,old-reg)))
- (t 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))))
+ ((and (instruction-is i :pushl)
+ (stack-frame-operand (idst i))
+ (assoc (stack-frame-operand (idst i))
+ frame-map))
+ (let ((old-reg
+ (cdr (assoc (stack-frame-operand (idst i))
+ frame-map))))
+ (explain nil "push ~S already in ~S."
+ i old-reg)
+ `(:pushl ,old-reg)))
+ (t i))))
(unless (eq new-i i)
(setf mod-p t))
(when (branch-instruction-label new-i t)
@@ -1872,12 +1881,12 @@
(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))
+ (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
@@ -1889,7 +1898,11 @@
(if (not mod-p)
unoptimized-code
(append (nreverse new-code)
- old-code)))))))
+ old-code))))))
+ (remove-frame-maps (code)
+ (remove-if (lambda (x)
+ (typep x '(cons (eql :frame-map) *)))
+ 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
@@ -2282,13 +2295,7 @@
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))))))))))
-
+ (optimize-trim-stack-frame (remove-frame-maps unoptimized-code)))))))
;;;; Compiler internals
(defclass binding ()
More information about the Movitz-cvs
mailing list