movitz-cvs
Threads by month
- ----- 2025 -----
- July
- June
- May
- April
- March
- February
- January
- ----- 2024 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2023 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2022 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2021 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2020 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2019 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2018 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2017 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2016 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2015 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2014 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2013 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2012 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2011 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2010 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2009 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2008 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2007 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2006 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2005 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2004 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- 2595 discussions
Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory common-lisp.net:/tmp/cvs-serv15265
Modified Files:
setf.lisp
Log Message:
Removed some dead code. Made setf a proper macro rather than
compiler-macro. For historical reasons there are many (nominally)
macros that are defined as compiler-macros in movitz, this shouldn't
be.
Date: Wed Feb 18 09:38:15 2004
Author: ffjeld
Index: movitz/losp/muerte/setf.lisp
diff -u movitz/losp/muerte/setf.lisp:1.2 movitz/losp/muerte/setf.lisp:1.3
--- movitz/losp/muerte/setf.lisp:1.2 Mon Jan 19 06:23:47 2004
+++ movitz/losp/muerte/setf.lisp Wed Feb 18 09:38:14 2004
@@ -10,7 +10,7 @@
;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org>
;;;; Created at: Thu Feb 8 20:43:20 2001
;;;;
-;;;; $Id: setf.lisp,v 1.2 2004/01/19 11:23:47 ffjeld Exp $
+;;;; $Id: setf.lisp,v 1.3 2004/02/18 14:38:14 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -151,7 +151,7 @@
,setter-form)))))))
-(define-compiler-macro setf (&environment env &rest pairs)
+(defmacro setf (&environment env &rest pairs)
(let ((num-pairs (length pairs)))
(cond
((= 2 num-pairs)
@@ -159,11 +159,6 @@
pairs
;; 5.1.2 Kinds of Places
(cond
- #+ignore
- ((nth-value 1 (movitz::movitz-macroexpand-1 place env))
- ;; 5.1.2.7 Macro forms as places
- ;; ..and 5.1.2.8 Symbol Macros as places.
- `(setf ,(movitz::movitz-macroexpand-1 place env) ,new-value-form))
((symbolp place) ; 5.1.2.1 Variable Names as Places
(multiple-value-bind (expansion expanded-p)
(movitz::movitz-macroexpand-1 place env)
@@ -172,9 +167,6 @@
`(setq ,place ,new-value-form))))
(t (multiple-value-bind (tmp-vars tmp-forms store-vars setter-form)
(get-setf-expansion place env)
- #+ignore
- (warn "tmp-vars: ~W, tmp-forms: ~W, store-vars: ~W, setter-form: ~W"
- tmp-vars tmp-forms store-vars setter-form)
(case (length store-vars)
(0 `(progn ,@tmp-forms ,new-value-form nil))
(1 `(let (,@(loop for tmp-var in tmp-vars
@@ -188,31 +180,7 @@
collect `(,tmp-var ,tmp-form))
(multiple-value-bind ,store-vars
,new-value-form
- ,setter-form))))))
- #+ignore
- ((listp place) ; 5.1.2.9 Other Compound Forms as Places
- (let ((place-operator (first place))
- (place-args (rest place)))
- (multiple-value-bind (newvalue-form newvalue-lets)
- (if (movitz:movitz-constantp new-value-form)
- (values new-value-form nil)
- (let ((newvalue-var (gensym "setf-newvalue")))
- (values newvalue-var
- (list (list newvalue-var new-value-form)))))
- (multiple-value-bind (place-forms place-lets)
- (loop for pa in place-args
- as var = (gensym "setf-var")
- if (movitz:movitz-constantp pa)
- collect pa into forms
- else
- collect var into forms
- and collect (list var pa) into lets
- finally (return (values forms lets)))
- `(let (,@place-lets ,@newvalue-lets)
- (,(movitz::movitz-env-setf-operator-name (movitz::translate-program place-operator
- :cl :muerte.cl))
- ,newvalue-form
- ,@place-forms)))))))))
+ ,setter-form)))))))))
((evenp num-pairs)
(cons 'progn
(loop for (place newvalue) on pairs by #'cddr
1
0
Update of /project/movitz/cvsroot/movitz/losp/lib
In directory common-lisp.net:/tmp/cvs-serv30205
Modified Files:
repl.lisp
Log Message:
Added a missing ignore declaration.
Date: Wed Feb 18 06:48:20 2004
Author: ffjeld
Index: movitz/losp/lib/repl.lisp
diff -u movitz/losp/lib/repl.lisp:1.3 movitz/losp/lib/repl.lisp:1.4
--- movitz/losp/lib/repl.lisp:1.3 Mon Jan 19 06:23:44 2004
+++ movitz/losp/lib/repl.lisp Wed Feb 18 06:48:20 2004
@@ -10,7 +10,7 @@
;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org>
;;;; Created at: Wed Mar 19 14:58:12 2003
;;;;
-;;;; $Id: repl.lisp,v 1.3 2004/01/19 11:23:44 ffjeld Exp $
+;;;; $Id: repl.lisp,v 1.4 2004/02/18 11:48:20 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -46,6 +46,7 @@
(handler-bind
((muerte::missing-delimiter
(lambda (c)
+ (declare (ignore c))
(format t "~&> ")
(invoke-restart 'muerte::next-line
(muerte.readline:contextual-readline *repl-readline-context*)))))
1
0
Update of /project/movitz/cvsroot/movitz/doc
In directory common-lisp.net:/tmp/cvs-serv8233
Modified Files:
ideas.txt
Log Message:
Some more loose idease that might be chased later.
Date: Wed Feb 18 06:18:31 2004
Author: ffjeld
Index: movitz/doc/ideas.txt
diff -u movitz/doc/ideas.txt:1.2 movitz/doc/ideas.txt:1.3
--- movitz/doc/ideas.txt:1.2 Thu Jan 15 05:47:57 2004
+++ movitz/doc/ideas.txt Wed Feb 18 06:18:31 2004
@@ -10,7 +10,7 @@
## Author: Frode Vatvedt Fjeld <frodef(a)acm.org>
## Created at: Fri Dec 12 19:19:39 2003
##
-## $Id: ideas.txt,v 1.2 2004/01/15 10:47:57 ffjeld Exp $
+## $Id: ideas.txt,v 1.3 2004/02/18 11:18:31 ffjeld Exp $
##
######################################################################
@@ -21,6 +21,9 @@
this would allow for a cache-size of 1 or 2, say. And it'd be
possible to determine these cases dynamically.
+ - It might be feasible to locate some specialization-tables directly
+ in the instance structure. For example eql-specialized methods.
+
** Function calls via symbols
@@ -44,3 +47,9 @@
install in the old FS a code-vector that updates the caller
function's references to the new FS, before trampolining to the
new FS. The performance gain could be substantial.
+
+
+** Caching strategies
+
+ - Might e.g. write-combining or other relaxed memory coherence
+ models be used, e.g. within one "thread" area?
1
0
Update of /project/movitz/cvsroot/movitz
In directory common-lisp.net:/tmp/cvs-serv19215
Modified Files:
special-operators.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:24:06 2004
Author: ffjeld
Index: movitz/special-operators.lisp
diff -u movitz/special-operators.lisp:1.13 movitz/special-operators.lisp:1.14
--- movitz/special-operators.lisp:1.13 Sat Feb 14 18:46:56 2004
+++ movitz/special-operators.lisp Tue Feb 17 15:24:06 2004
@@ -8,7 +8,7 @@
;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org>
;;;; Created at: Fri Nov 24 16:22:59 2000
;;;;
-;;;; $Id: special-operators.lisp,v 1.13 2004/02/14 23:46:56 ffjeld Exp $
+;;;; $Id: special-operators.lisp,v 1.14 2004/02/17 20:24:06 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -568,6 +568,7 @@
(check-type binding lexical-binding)
(list binding)))))
(let ((code (assembly-macroexpand inline-asm amenv)))
+ #+ignore
(assert (not (and (not side-effects)
(tree-search code '(:store-lexical))))
()
1
0
Update of /project/movitz/cvsroot/movitz
In directory common-lisp.net:/tmp/cvs-serv6051
Modified Files:
environment.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:24:00 2004
Author: ffjeld
Index: movitz/environment.lisp
diff -u movitz/environment.lisp:1.4 movitz/environment.lisp:1.5
--- movitz/environment.lisp:1.4 Mon Feb 9 19:24:38 2004
+++ movitz/environment.lisp Tue Feb 17 15:24:00 2004
@@ -9,7 +9,7 @@
;;;; Created at: Fri Nov 3 11:40:15 2000
;;;; Distribution: See the accompanying file COPYING.
;;;;
-;;;; $Id: environment.lisp,v 1.4 2004/02/10 00:24:38 ffjeld Exp $
+;;;; $Id: environment.lisp,v 1.5 2004/02/17 20:24:00 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -285,6 +285,7 @@
(image-global-environment *image*))
(defun movitz-env-add-binding (env binding &optional (variable (binding-name binding)))
+ "Returns the binding."
(check-type binding binding)
(check-type variable symbol "a variable name")
(let ((env (or env *movitz-global-environment*)))
1
0
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)))
1
0
Update of /project/movitz/cvsroot/movitz
In directory common-lisp.net:/tmp/cvs-serv484
Modified Files:
compiler.lisp
Log Message:
More work on register scheduling.
Date: Mon Feb 16 20:42:50 2004
Author: ffjeld
Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.28 movitz/compiler.lisp:1.29
--- movitz/compiler.lisp:1.28 Mon Feb 16 12:53:12 2004
+++ movitz/compiler.lisp Mon Feb 16 20:42:50 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.28 2004/02/16 17:53:12 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.29 2004/02/17 01:42:50 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -2024,6 +2024,14 @@
(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))
@@ -2406,43 +2414,55 @@
(defun compute-free-registers (pc distance funobj frame-map
&key (free-registers '(:eax :ebx :edx)))
+ "Return set of free register, and whether there may be more registers
+ free later, with a more specified frame-map."
(loop with free-so-far = free-registers
repeat distance for i in pc
doing
(cond
- ((instruction-is i :load-lexical)
- (destructuring-bind (source dest
- &key shared-reference-p
- tmp-register
- protect-registers)
+ ((and (instruction-is i :init-lexvar)
+ (typep (second i) 'required-function-argument)) ; XXX
+ (destructuring-bind (binding &key init-with-register init-with-type
+ protect-registers protect-carry)
(cdr i)
- (declare (ignore shared-reference-p
- tmp-register
- protect-registers))
- (unless (and (new-binding-located-p (binding-target source)
- frame-map)
- (or (not (typep dest 'binding))
- (new-binding-located-p (binding-target dest)
- frame-map)))
+ (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))
- (let ((exp (expand-extended-code i funobj frame-map)))
- (setf free-so-far
- (remove-if (lambda (r)
- (tree-search exp r))
- free-so-far)))))
- (t (setf free-so-far nil)))
+ (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)))
finally (return free-so-far)))
(defun try-locate-in-register (binding var-counts funobj frame-map)
- "Try to locate binding in a register. Return a register, or NIL.
+ "Try to locate binding in a register. Return a register, or
+ nil and :not-now, or :never.
This function is factored out from assign-bindings."
(let* ((count-init-pc (gethash binding var-counts))
(count (car count-init-pc))
(init-pc (cdr count-init-pc)))
+ ;; (warn "count: ~D, init-pc: ~{~&~A~}" count init-pc)
(cond
((binding-lended-p binding)
;; We can't lend a register.
- nil)
+ (values nil :never))
((and (= 1 count)
init-pc)
(assert (instruction-is (first init-pc) :init-lexvar))
@@ -2453,28 +2473,25 @@
(assert (eq binding init-binding))
(let* ((load-instruction
(find-if (lambda (i)
- (member binding (find-read-bindings i)))
+ (member binding (find-read-bindings i)
+ :test #'binding-eql))
(cdr init-pc)
:end 7))
(binding-destination (third load-instruction))
- (distance (position load-instruction (cdr init-pc)))
- (free-registers
- (and distance
- (compute-free-registers (cdr init-pc) distance funobj frame-map))))
- (cond
- ((member binding-destination free-registers)
- binding-destination)
- ((member init-with-register free-registers)
- init-with-register)
- ((first free-registers))
- (t nil))))))))
-;;; (when (and (symbolp location) (< 2 distance))
-;;; (warn "Assigning ~A to ~A dist ~S."
-;;; (binding-name binding)
-;;; location
-;;; distance)
-;;; (print-code 'middle (subseq init-pc 0 (+ 2 distance))))
-;;; (setf (new-binding-location binding frame-map) location)))))
+ (distance (position load-instruction (cdr init-pc))))
+ (multiple-value-bind (free-registers more-later-p)
+ (and distance (compute-free-registers (cdr init-pc) distance funobj frame-map))
+ (cond
+ ((member binding-destination free-registers)
+ binding-destination)
+ ((member init-with-register free-registers)
+ init-with-register)
+ ((not (null free-registers))
+ (first free-registers))
+ (more-later-p
+ (values nil :not-now))
+ (t (values nil :never)))))))
+ (t (values nil :never)))))
(defun discover-variables (code function-env)
"Iterate over CODE, and take note in the hash-table VAR-COUNTER which ~
@@ -2564,64 +2581,131 @@
(t (assign-env-bindings (movitz-environment-extent-uplink env)))))
(assign-env-bindings (env)
(or (getf env-roof-map env nil)
- (let ((stack-frame-position (env-floor env))
- (bindings-to-locate
- (loop for (variable . binding) in (movitz-environment-bindings env)
- unless (cond
- ((not (typep binding 'lexical-binding)))
- ((typep binding 'lambda-binding))
- ((not (plusp (or (car (gethash binding var-counts)) 0)))
- (prog1 t
- (unless (or (movitz-env-get variable 'ignore nil env nil)
- (movitz-env-get variable 'ignorable nil env nil)
- (typep binding 'hidden-rest-function-argument))
- (warn "Unused variable: ~S" variable)))))
- collect binding)))
- (when (eq env function-env)
- (setf bindings-to-locate
- (sort bindings-to-locate #'<
- :key (lambda (binding)
- (etypecase binding
- (edx-function-argument 3)
- (positional-function-argument
- (* 2 (function-argument-argnum binding)))
- (binding 100000)))))
- ;; (warn "btl: ~S" bindings-to-locate)
- (loop for binding in bindings-to-locate
- while (or (typep binding 'register-required-function-argument)
- (typep binding 'floating-required-function-argument)
- (and (typep binding 'positional-function-argument)
- (< (function-argument-argnum binding)
- 2)))
- do (unless (new-binding-located-p binding frame-map)
- (setf (new-binding-location binding frame-map)
- (post-incf stack-frame-position)))))
- (dolist (binding (sort (copy-list bindings-to-locate) #'>
- ;; Sort so as to make the most likely
- ;; candidates for locating to registers
- ;; be assigned last (i.e. maps to
- ;; a smaller value).
- :key (lambda (b)
- (etypecase b
- ((or constant-object-binding
- forwarding-binding
- borrowed-binding)
- 1000)
- (fixed-required-function-argument
- (+ 100 (function-argument-argnum b)))
- (located-binding
- (let* ((count-init (gethash b var-counts))
- (count (car count-init))
- (init-pc (cdr count-init)))
- (if (not (and count init-pc))
- 50
- (truncate
- (or (position-if (lambda (i)
- (member b (find-read-bindings i)))
- (cdr init-pc)
- :end 5)
- 10)
- count))))))))
+ (let* ((stack-frame-position (env-floor env))
+ (bindings-to-locate
+ (loop for (variable . binding) in (movitz-environment-bindings env)
+ unless (cond
+ ((not (typep binding 'lexical-binding)))
+ ((typep binding 'lambda-binding))
+ ((typep binding 'constant-object-binding))
+ ((typep binding 'forwarding-binding))
+ ((typep binding 'borrowed-binding))
+ ((typep binding 'fixed-required-function-argument)
+ (prog1 t
+ (setf (new-binding-location binding frame-map)
+ :argument-stack)))
+ ((not (plusp (or (car (gethash binding var-counts)) 0)))
+ (prog1 t
+ (unless (or (movitz-env-get variable 'ignore nil env nil)
+ (movitz-env-get variable 'ignorable nil env nil)
+ (typep binding 'hidden-rest-function-argument))
+ (warn "Unused variable: ~S" variable)))))
+ collect binding))
+ (bindings-fun-arg-sorted
+ (when (eq env function-env)
+ (sort (copy-list bindings-to-locate) #'<
+ :key (lambda (binding)
+ (etypecase binding
+ (edx-function-argument 3)
+ (positional-function-argument
+ (* 2 (function-argument-argnum binding)))
+ (binding 100000))))))
+ (bindings-register-goodness-sort
+ (sort (copy-list bindings-to-locate) #'<
+ ;; Sort so as to make the most likely
+ ;; candidates for locating to registers
+ ;; be assigned first (i.e. maps to
+ ;; a smaller value).
+ :key (lambda (b)
+ (etypecase b
+ ((or constant-object-binding
+ forwarding-binding
+ borrowed-binding)
+ 1000)
+ (fixed-required-function-argument
+ (+ 100 (function-argument-argnum b)))
+ (located-binding
+ (let* ((count-init (gethash b var-counts))
+ (count (car count-init))
+ (init-pc (cdr count-init)))
+ (if (not (and count init-pc))
+ 50
+ (truncate
+ (or (position-if (lambda (i)
+ (member b (find-read-bindings i)))
+ (cdr init-pc)
+ :end 5)
+ 10)
+ count)))))))))
+ ;; First, make several passes while trying to locate bindings
+ ;; into registers.
+ (loop repeat 100 with try-again = t and did-assign = t
+ do (unless (and try-again did-assign)
+ (return))
+ do (setf try-again nil did-assign nil)
+ (loop for binding in bindings-fun-arg-sorted
+ while (or (typep binding 'register-required-function-argument)
+ (typep binding 'floating-required-function-argument)
+ (and (typep binding 'positional-function-argument)
+ (< (function-argument-argnum binding)
+ 2)))
+ do (unless (new-binding-located-p binding frame-map)
+ (multiple-value-bind (register status)
+ (try-locate-in-register binding var-counts
+ (movitz-environment-funobj function-env)
+ frame-map)
+ (cond
+ (register
+ (setf (new-binding-location binding frame-map)
+ register)
+ (setf did-assign t))
+ ((eq status :not-now)
+ ;; (warn "Wait for ~S map ~A" binding frame-map)
+ (setf try-again t))
+ (t (assert (eq status :never)))))))
+ (dolist (binding bindings-register-goodness-sort)
+ (unless (and (binding-lended-p binding)
+ (not (typep binding 'borrowed-binding))
+ (not (getf (binding-lended-p binding) :stack-cons-location)))
+ (unless (new-binding-located-p binding frame-map)
+ (check-type binding located-binding)
+ (multiple-value-bind (register status)
+ (try-locate-in-register binding var-counts
+ (movitz-environment-funobj function-env)
+ frame-map)
+ (cond
+ (register
+ (setf (new-binding-location binding frame-map)
+ register)
+ (setf did-assign t))
+ ((eq status :not-now)
+ (setf try-again t))
+ (t (assert (eq status :never))))))))
+ do (when (and try-again (not did-assign))
+ (let ((binding (or (find-if (lambda (b)
+ (and (not (new-binding-located-p b frame-map))
+ (not (typep b 'function-argument))))
+ bindings-register-goodness-sort
+ :from-end t)
+ (find-if (lambda (b)
+ (not (new-binding-located-p b frame-map)))
+ bindings-fun-arg-sorted))))
+ (when binding
+ (setf (new-binding-location binding frame-map)
+ (post-incf stack-frame-position))
+ (setf did-assign t))))
+ finally (break "100 iterations didn't work"))
+ ;; Then, make one pass assigning bindings to stack-frame.
+ (loop for binding in bindings-fun-arg-sorted
+ while (or (typep binding 'register-required-function-argument)
+ (typep binding 'floating-required-function-argument)
+ (and (typep binding 'positional-function-argument)
+ (< (function-argument-argnum binding)
+ 2)))
+ do (unless (new-binding-located-p binding frame-map)
+ (setf (new-binding-location binding frame-map)
+ (post-incf stack-frame-position))))
+ (dolist (binding bindings-register-goodness-sort)
(when (and (binding-lended-p binding)
(not (typep binding 'borrowed-binding))
(not (getf (binding-lended-p binding) :stack-cons-location)))
@@ -2640,29 +2724,16 @@
(setf (new-binding-location binding frame-map)
:argument-stack))
(located-binding
- (let ((register (try-locate-in-register binding var-counts
- (movitz-environment-funobj function-env)
- frame-map)))
-;;; (when (and (binding-store-type binding)
-;;; (apply #'encoded-type-singleton
-;;; (binding-store-type binding)))
-;;; (warn "Locating constant binding: ~S" binding))
-;;; (warn "binding: ~S type ~S, count: ~S"
-;;; binding
-;;; (apply #'encoded-type-decode
-;;; (binding-store-type binding))
-;;; (gethash binding var-counts))
-;;; (print-code 'foo code)
- (setf (new-binding-location binding frame-map)
- (or register (post-incf stack-frame-position))))))))
+ (setf (new-binding-location binding frame-map)
+ (post-incf stack-frame-position))))))
(setf (getf env-roof-map env)
stack-frame-position)))))
- (loop ;; with funobj = (movitz-environment-funobj function-env)
- for binding being the hash-keys of var-counts
+ (loop for binding being the hash-keys of var-counts
as env = (binding-env binding)
;; do (warn "bind: ~S: ~S" binding (eq function-env (find-function-env env funobj)))
when (sub-env-p env function-env)
do (assign-env-bindings (binding-env binding)))
+ ;; (warn "Frame-map:~{ ~A~}" frame-map)
frame-map)))
@@ -2773,6 +2844,7 @@
are load-lexicals of the first two function arguments, and if possible these
bindings are located in the appropriate register, so no stack location is needed."
(check-type env function-env)
+ #+ignore
(let ((funobj (movitz-environment-funobj env))
(scan-code code))
;; (warn "code: ~{~&~S~}" (subseq scan-code 0 5))
@@ -2830,7 +2902,20 @@
;; (setf (binding-location first-load-binding) location)
(setf (new-binding-location first-load-binding frame-map) location)
(setf scan-code (rest scan-code)))))))))
- (assign-bindings code env stack-frame-position frame-map))
+ #+ignore
+ (assign-bindings code env stack-frame-position frame-map)
+ (assign-bindings (append (when (first (required-vars env))
+ (let ((binding (movitz-binding (first (required-vars env))
+ env nil)))
+ (check-type binding required-function-argument)
+ `((:init-lexvar ,binding :init-with-register :eax :init-with-type t))))
+ (when (second (required-vars env))
+ (let ((binding (movitz-binding (second (required-vars env))
+ env nil)))
+ (check-type binding required-function-argument)
+ `((:init-lexvar ,binding :init-with-register :ebx :init-with-type t))))
+ code)
+ env stack-frame-position frame-map))
(defconstant +dynamic-frame-marker+ #xd193)
(defconstant +dynamic-catch-marker+ #xd293)
@@ -3607,13 +3692,16 @@
(t (ecase location-0
((nil :eax) nil)
(:ebx (assert (not location-1))
- '((:movl :eax :ebx))))))
+ '((:movl :eax :ebx)))
+ (:edx (assert (not edx-location))
+ '((:movl :eax :edx))))))
(cond
((eql 1 location-1)
(decf stack-setup-size)
'((:pushl :ebx)))
- (t (case location-1
+ (t (ecase location-1
((nil :ebx) nil)
+ (:edx '((:movl :ebx :edx)))
(:eax `((:movl :ebx :eax)))))))))
(cond
((or (and (or (eql 1 location-0)
@@ -5333,6 +5421,15 @@
(setf (gethash ',name *extended-code-expanders*) ',defun-name)
(defun ,defun-name ,lambda-list ,@body))))
+(defun can-expand-extended-p (extended-instruction frame-map)
+ "Given frame-map, can we expand i at this point?"
+ (and (every (lambda (b)
+ (new-binding-located-p (binding-target b) frame-map))
+ (find-read-bindings extended-instruction))
+ (let ((written-binding (find-written-binding-and-type extended-instruction)))
+ (or (not written-binding)
+ (new-binding-located-p (binding-target written-binding) frame-map)))))
+
(defun expand-extended-code (extended-instruction funobj frame-map)
(if (not (listp extended-instruction))
(list extended-instruction)
@@ -5486,14 +5583,26 @@
(assert (member dst '(:eax :ebx :ecx :edx)))
(etypecase x
(binding
- (let* ((binding (ensure-local-binding (binding-target x) funobj)))
+ (let* ((binding (binding-target (ensure-local-binding (binding-target x) funobj)))
+ (location (new-binding-location (binding-target binding) frame-map))
+ (binding-is-list-p (binding-store-subtypep binding 'list)))
+;;; (warn "car of loc ~A bind ~A"
+;;; location binding)
(cond
- ((binding-store-subtypep binding 'list)
- ;; (warn "Inlined CAR for ~S" binding)
+ ((and binding-is-list-p
+ (member location '(:eax :ebx :ecx :edx)))
+ `((:movl (,location -1) ,dst)))
+ (binding-is-list-p
`(,@(make-load-lexical binding dst funobj nil frame-map)
(:movl (,dst -1) ,dst)))
+ ((eq location :ebx)
+ `((,*compiler-global-segment-prefix*
+ :call (:edi ,(global-constant-offset 'fast-car-ebx)))
+ ,@(when (not (eq dst :eax))
+ `((:movl :eax ,dst)))))
(t `(,@(make-load-lexical binding :eax funobj nil frame-map)
- (:call (:edi ,(global-constant-offset 'fast-car)))
+ (,*compiler-global-segment-prefix*
+ :call (:edi ,(global-constant-offset 'fast-car)))
,@(when (not (eq dst :eax))
`((:movl :eax ,dst))))))))
(symbol
1
0
Update of /project/movitz/cvsroot/movitz
In directory common-lisp.net:/tmp/cvs-serv20617
Modified Files:
compiler.lisp
Log Message:
Factored out function try-locate-in-register from assign-bindings.
Date: Mon Feb 16 12:53:12 2004
Author: ffjeld
Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.27 movitz/compiler.lisp:1.28
--- movitz/compiler.lisp:1.27 Mon Feb 16 12:22:47 2004
+++ movitz/compiler.lisp Mon Feb 16 12:53:12 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.27 2004/02/16 17:22:47 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.28 2004/02/16 17:53:12 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -2433,6 +2433,49 @@
(t (setf free-so-far nil)))
finally (return free-so-far)))
+(defun try-locate-in-register (binding var-counts funobj frame-map)
+ "Try to locate binding in a register. Return a register, or NIL.
+ This function is factored out from assign-bindings."
+ (let* ((count-init-pc (gethash binding var-counts))
+ (count (car count-init-pc))
+ (init-pc (cdr count-init-pc)))
+ (cond
+ ((binding-lended-p binding)
+ ;; We can't lend a register.
+ nil)
+ ((and (= 1 count)
+ init-pc)
+ (assert (instruction-is (first init-pc) :init-lexvar))
+ (destructuring-bind (init-binding &key init-with-register init-with-type
+ protect-registers protect-carry)
+ (cdr (first init-pc))
+ (declare (ignore protect-registers protect-carry init-with-type))
+ (assert (eq binding init-binding))
+ (let* ((load-instruction
+ (find-if (lambda (i)
+ (member binding (find-read-bindings i)))
+ (cdr init-pc)
+ :end 7))
+ (binding-destination (third load-instruction))
+ (distance (position load-instruction (cdr init-pc)))
+ (free-registers
+ (and distance
+ (compute-free-registers (cdr init-pc) distance funobj frame-map))))
+ (cond
+ ((member binding-destination free-registers)
+ binding-destination)
+ ((member init-with-register free-registers)
+ init-with-register)
+ ((first free-registers))
+ (t nil))))))))
+;;; (when (and (symbolp location) (< 2 distance))
+;;; (warn "Assigning ~A to ~A dist ~S."
+;;; (binding-name binding)
+;;; location
+;;; distance)
+;;; (print-code 'middle (subseq init-pc 0 (+ 2 distance))))
+;;; (setf (new-binding-location binding frame-map) location)))))
+
(defun discover-variables (code function-env)
"Iterate over CODE, and take note in the hash-table VAR-COUNTER which ~
variables CODE references that are lexically bound in ENV."
@@ -2554,9 +2597,10 @@
(setf (new-binding-location binding frame-map)
(post-incf stack-frame-position)))))
(dolist (binding (sort (copy-list bindings-to-locate) #'>
- ;; Sort so as to make the least likely
+ ;; Sort so as to make the most likely
;; candidates for locating to registers
- ;; be assigned last.
+ ;; be assigned last (i.e. maps to
+ ;; a smaller value).
:key (lambda (b)
(etypecase b
((or constant-object-binding
@@ -2596,59 +2640,21 @@
(setf (new-binding-location binding frame-map)
:argument-stack))
(located-binding
-;;; (when (and (binding-store-type binding)
-;;; (apply #'encoded-type-singleton
-;;; (binding-store-type binding)))
-;;; (warn "Locating constant binding: ~S" binding))
-;;; (warn "binding: ~S type ~S, count: ~S"
-;;; binding
-;;; (apply #'encoded-type-decode
-;;; (binding-store-type binding))
-;;; (gethash binding var-counts))
+ (let ((register (try-locate-in-register binding var-counts
+ (movitz-environment-funobj function-env)
+ frame-map)))
+;;; (when (and (binding-store-type binding)
+;;; (apply #'encoded-type-singleton
+;;; (binding-store-type binding)))
+;;; (warn "Locating constant binding: ~S" binding))
+;;; (warn "binding: ~S type ~S, count: ~S"
+;;; binding
+;;; (apply #'encoded-type-decode
+;;; (binding-store-type binding))
+;;; (gethash binding var-counts))
;;; (print-code 'foo code)
- (let* ((count-init-pc (gethash binding var-counts))
- (count (car count-init-pc))
- (init-pc (cdr count-init-pc)))
- (cond
- ((binding-lended-p binding)
- (setf (new-binding-location binding frame-map)
- (post-incf stack-frame-position)))
- ((and (= 1 count)
- init-pc)
- (assert (instruction-is (first init-pc) :init-lexvar))
- (destructuring-bind (init-binding &key init-with-register init-with-type
- protect-registers protect-carry)
- (cdr (first init-pc))
- (declare (ignore protect-registers protect-carry init-with-type))
- (assert (eq binding init-binding))
- (let* ((load-instruction
- (find-if (lambda (i)
- (member binding (find-read-bindings i)))
- (cdr init-pc)
- :end 7))
- (binding-destination (third load-instruction))
- (distance (position load-instruction (cdr init-pc)))
- (free-registers
- (and distance
- (compute-free-registers (cdr init-pc) distance
- (movitz-environment-funobj function-env)
- frame-map))))
- (let ((location (cond
- ((member binding-destination free-registers)
- binding-destination)
- ((member init-with-register free-registers)
- init-with-register)
- ((first free-registers))
- (t (post-incf stack-frame-position)))))
-;;; (when (and (symbolp location) (< 2 distance))
-;;; (warn "Assigning ~A to ~A dist ~S."
-;;; (binding-name binding)
-;;; location
-;;; distance)
-;;; (print-code 'middle (subseq init-pc 0 (+ 2 distance))))
- (setf (new-binding-location binding frame-map) location)))))
- (t (setf (new-binding-location binding frame-map)
- (post-incf stack-frame-position)))))))))
+ (setf (new-binding-location binding frame-map)
+ (or register (post-incf stack-frame-position))))))))
(setf (getf env-roof-map env)
stack-frame-position)))))
(loop ;; with funobj = (movitz-environment-funobj function-env)
1
0
Update of /project/movitz/cvsroot/movitz
In directory common-lisp.net:/tmp/cvs-serv32153
Modified Files:
compiler.lisp
Log Message:
This rather big check-in adds smartness in the compiler to locate
variables in registers, rather than mindlessly putting them on the
stack-frame. This should mean smaller, more efficient code, and
reduced stack usage.
Also, there are a few bug-fixes here and there, although these bugs
apparently haven't resulted in buggy output (yet).
Date: Mon Feb 16 12:22:47 2004
Author: ffjeld
Index: movitz/compiler.lisp
diff -u movitz/compiler.lisp:1.26 movitz/compiler.lisp:1.27
--- movitz/compiler.lisp:1.26 Sat Feb 14 10:44:32 2004
+++ movitz/compiler.lisp Mon Feb 16 12:22:47 2004
@@ -8,7 +8,7 @@
;;;; Created at: Wed Oct 25 12:30:49 2000
;;;; Distribution: See the accompanying file COPYING.
;;;;
-;;;; $Id: compiler.lisp,v 1.26 2004/02/14 15:44:32 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.27 2004/02/16 17:22:47 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -102,6 +102,7 @@
(let* ((name (movitz-print (movitz-funobj-name funobj)))
(hash-name name)
(new-size (length (movitz-vector-symbolic-data (movitz-funobj-code-vector funobj)))))
+ (assert name)
(let ((old-size (gethash hash-name (function-code-sizes *image*))))
(cond
((not old-size))
@@ -441,11 +442,11 @@
(type-analysis-binding-types analysis))
(setf (binding-store-type binding)
(type-analysis-encoded-type analysis))
+ #+ignore
(when (or #+ignore (not (apply #'encoded-allp (type-analysis-encoded-type analysis)))
- (multiple-value-call #'encoded-subtypep
- (values-list (type-analysis-encoded-type analysis))
- (type-specifier-encode 'list)))
- #+ignore
+ #+ignore (multiple-value-call #'encoded-subtypep
+ (values-list (type-analysis-encoded-type analysis))
+ (type-specifier-encode 'list)))
(warn "Type: ~S => ~A (~A)"
binding
(apply #'encoded-type-decode (type-analysis-encoded-type analysis))
@@ -2067,7 +2068,13 @@
(defmethod print-object ((object binding) stream)
(print-unreadable-object (object stream :type t :identity t)
(when (slot-boundp object 'name)
- (format stream "name: ~S" (binding-name object)))))
+ (format stream "name: ~S~@[->~S~]~@[ stype: ~A~]"
+ (binding-name object)
+ (unless (eq object (binding-target object))
+ (binding-name (binding-target object)))
+ (when (binding-store-type object)
+ (apply #'encoded-type-decode
+ (binding-store-type object)))))))
(defclass constant-object-binding (binding)
((object
@@ -2304,10 +2311,12 @@
(defun instruction-is (instruction &optional operator)
(and (listp instruction)
- (let ((instruction (ignore-instruction-prefixes instruction)))
- (if operator
- (eq operator (car instruction))
- (car instruction)))))
+ (if (member (car instruction) '(:globally :locally))
+ (instruction-is (second instruction) operator)
+ (let ((instruction (ignore-instruction-prefixes instruction)))
+ (if operator
+ (eq operator (car instruction))
+ (car instruction))))))
(defun instruction-uncontinues-p (instruction)
"Is it impossible for control to return after instruction?"
@@ -2395,33 +2404,58 @@
obj funobj (movitz-funobj-const-list funobj))
pos)))))
+(defun compute-free-registers (pc distance funobj frame-map
+ &key (free-registers '(:eax :ebx :edx)))
+ (loop with free-so-far = free-registers
+ repeat distance for i in pc
+ doing
+ (cond
+ ((instruction-is i :load-lexical)
+ (destructuring-bind (source dest
+ &key shared-reference-p
+ tmp-register
+ protect-registers)
+ (cdr i)
+ (declare (ignore shared-reference-p
+ tmp-register
+ protect-registers))
+ (unless (and (new-binding-located-p (binding-target source)
+ frame-map)
+ (or (not (typep dest 'binding))
+ (new-binding-located-p (binding-target dest)
+ frame-map)))
+ (return nil))
+ (let ((exp (expand-extended-code i funobj frame-map)))
+ (setf free-so-far
+ (remove-if (lambda (r)
+ (tree-search exp r))
+ free-so-far)))))
+ (t (setf free-so-far nil)))
+ finally (return free-so-far)))
+
(defun discover-variables (code function-env)
"Iterate over CODE, and take note in the hash-table VAR-COUNTER which ~
- variables CODE references that are lexically bound in ENV.
- Also return the set of borrowed-bindings discovered."
+ variables CODE references that are lexically bound in ENV."
(check-type function-env function-env)
;; (format t "~{~&~S~}" code)
- (let ((var-counter (make-hash-table :test #'eq :size 40))
- #+ignore (funobj (movitz-environment-funobj function-env)))
- (labels ((take-note-of-binding (binding &optional storep)
- ;; (check-type binding lexical-binding)
- (if storep
- (setf (gethash binding var-counter)
- (or (gethash binding var-counter) 0))
- (incf (gethash binding var-counter 0)))
+ (let ((var-counter (make-hash-table :test #'eq :size 40)))
+ (labels ((take-note-of-binding (binding &optional storep init-pc)
+ (let ((count-init-pc (or (gethash binding var-counter)
+ (setf (gethash binding var-counter)
+ (cons 0 nil)))))
+ (when init-pc
+ (assert (not (cdr count-init-pc)))
+ (setf (cdr count-init-pc) init-pc))
+ (unless storep
+ (incf (car count-init-pc))))
(when (typep binding 'forwarding-binding)
(take-note-of-binding (forwarding-binding-target binding))))
- (ensure-local-binding (binding)
- "If binding is borrowed from another funobj, we must replace it with a borrowing-binding."
- #+ignore (assert (eq funobj (binding-funobj binding)) ()
- "Not local: ~S" binding)
- binding)
(do-discover-variables (code env)
- (loop for instruction in code
+ (loop for pc on code as instruction in code
when (listp instruction)
do (flet ((lend-lexical (borrowing-binding dynamic-extent-p)
(let ((lended-binding
- (ensure-local-binding (borrowed-binding-target borrowing-binding))))
+ (borrowed-binding-target borrowing-binding)))
(when (typep lended-binding 'forwarding-binding)
(setf lended-binding
(change-class lended-binding 'located-binding)))
@@ -2432,11 +2466,6 @@
(incf (getf p :lended-count 0))
(setf (getf p :dynamic-extent-p) (and (getf p :dynamic-extent-p t)
dynamic-extent-p))))))
- (mapcar #'take-note-of-binding
- (find-read-bindings instruction))
- (let ((store-binding (find-written-binding-and-type instruction)))
- (when store-binding
- (take-note-of-binding store-binding t)))
(case (instruction-is instruction)
((:local-function-init :load-lambda)
(let ((function-binding (second instruction)))
@@ -2450,15 +2479,22 @@
(declare (ignore num-args))
(etypecase binding
(function-binding
- (take-note-of-binding (ensure-local-binding binding)))
+ (take-note-of-binding binding))
(funobj-binding))))
- (t (do-discover-variables (instruction-sub-program instruction) env)))))))
+ (:init-lexvar
+ (destructuring-bind (binding &key init-with-register init-with-type
+ protect-registers protect-carry)
+ (cdr instruction)
+ (declare (ignore protect-registers protect-carry init-with-type))
+ (when init-with-register
+ (take-note-of-binding binding t pc))))
+ (t (mapcar #'take-note-of-binding
+ (find-read-bindings instruction))
+ (let ((store-binding (find-written-binding-and-type instruction)))
+ (when store-binding
+ (take-note-of-binding store-binding t)))
+ (do-discover-variables (instruction-sub-program instruction) env)))))))
(do-discover-variables code function-env))
- ;; any hidden-rest is always used..
- (loop for (nil . binding) in (movitz-environment-bindings function-env)
- do (when (typep binding 'hidden-rest-function-argument)
- (incf (gethash binding var-counter 0))))
- ;; (setf (movitz-funobj-borrowed-bindings funobj) borrowed-bindings)
(values var-counter)))
(defun assign-bindings (code function-env &optional (initial-stack-frame-position 1)
@@ -2474,73 +2510,147 @@
(let* ((env-roof-map nil) ; memoize result of assign-env-bindings
(flat-program code)
(var-counts (discover-variables flat-program function-env)))
- (labels ((env-floor (env)
- (cond
- ((eq env function-env)
- initial-stack-frame-position)
- ((typep env 'function-env)
- (error "SEFEW: ~S" function-env))
- ;; The floor of this env is the roof of its extent-uplink.
- (t (assign-env-bindings (movitz-environment-extent-uplink env)))))
- (assign-env-bindings (env)
- (or (getf env-roof-map env nil)
- (let ((stack-frame-position (env-floor env))
- (bindings-to-locate
- (loop for (variable . binding) in (movitz-environment-bindings env)
- unless (cond
- ((not (typep binding 'lexical-binding)))
- ((typep binding 'lambda-binding))
- ((not (plusp (gethash binding var-counts 0)))
- (prog1 t
- (unless (or (movitz-env-get variable 'ignore nil env nil)
- (movitz-env-get variable 'ignorable nil env nil))
- (warn "Unused variable: ~S" variable)))))
- collect binding)))
- (when (eq env function-env)
- (setf bindings-to-locate
- (sort bindings-to-locate #'<
- :key (lambda (binding)
- (etypecase binding
- (edx-function-argument 3)
- (positional-function-argument
- (* 2 (function-argument-argnum binding)))
- (binding 100000)))))
- ;; (warn "btl: ~S" bindings-to-locate)
- (loop for binding in bindings-to-locate
- while (or (typep binding 'register-required-function-argument)
- (typep binding 'floating-required-function-argument)
- (and (typep binding 'positional-function-argument)
- (< (function-argument-argnum binding)
- 2)))
- do (unless (new-binding-located-p binding frame-map)
- (setf (new-binding-location binding frame-map)
- (post-incf stack-frame-position)))))
- (dolist (binding bindings-to-locate)
- (when (and (binding-lended-p binding)
- (not (typep binding 'borrowed-binding))
- (not (getf (binding-lended-p binding) :stack-cons-location)))
- ;; (warn "assigning lending-cons for ~W at ~D" binding stack-frame-position)
- (let ((cons-pos (post-incf stack-frame-position 2)))
- (setf (new-binding-location (cons :lended-cons binding) frame-map)
- (1+ cons-pos))
- (setf (getf (binding-lended-p binding) :stack-cons-location)
- cons-pos)))
- (unless (new-binding-located-p binding frame-map)
- (etypecase binding
- (constant-object-binding) ; no location needed.
- (forwarding-binding) ; will use the location of destination binding.
- (borrowed-binding) ; location is predetermined
- (fixed-required-function-argument
- (setf (new-binding-location binding frame-map) :argument-stack))
- (located-binding
- ;; don't think twice, it's alright..
- ;; (i.e. this is where we should be clever about assigning bindings
- ;; to registers and whatnot..)
- ;; (warn "assign ~W to ~D" binding stack-frame-position)
+ (labels
+ ((env-floor (env)
+ (cond
+ ((eq env function-env)
+ initial-stack-frame-position)
+ ((typep env 'function-env)
+ (error "SEFEW: ~S" function-env))
+ ;; The floor of this env is the roof of its extent-uplink.
+ (t (assign-env-bindings (movitz-environment-extent-uplink env)))))
+ (assign-env-bindings (env)
+ (or (getf env-roof-map env nil)
+ (let ((stack-frame-position (env-floor env))
+ (bindings-to-locate
+ (loop for (variable . binding) in (movitz-environment-bindings env)
+ unless (cond
+ ((not (typep binding 'lexical-binding)))
+ ((typep binding 'lambda-binding))
+ ((not (plusp (or (car (gethash binding var-counts)) 0)))
+ (prog1 t
+ (unless (or (movitz-env-get variable 'ignore nil env nil)
+ (movitz-env-get variable 'ignorable nil env nil)
+ (typep binding 'hidden-rest-function-argument))
+ (warn "Unused variable: ~S" variable)))))
+ collect binding)))
+ (when (eq env function-env)
+ (setf bindings-to-locate
+ (sort bindings-to-locate #'<
+ :key (lambda (binding)
+ (etypecase binding
+ (edx-function-argument 3)
+ (positional-function-argument
+ (* 2 (function-argument-argnum binding)))
+ (binding 100000)))))
+ ;; (warn "btl: ~S" bindings-to-locate)
+ (loop for binding in bindings-to-locate
+ while (or (typep binding 'register-required-function-argument)
+ (typep binding 'floating-required-function-argument)
+ (and (typep binding 'positional-function-argument)
+ (< (function-argument-argnum binding)
+ 2)))
+ do (unless (new-binding-located-p binding frame-map)
+ (setf (new-binding-location binding frame-map)
+ (post-incf stack-frame-position)))))
+ (dolist (binding (sort (copy-list bindings-to-locate) #'>
+ ;; Sort so as to make the least likely
+ ;; candidates for locating to registers
+ ;; be assigned last.
+ :key (lambda (b)
+ (etypecase b
+ ((or constant-object-binding
+ forwarding-binding
+ borrowed-binding)
+ 1000)
+ (fixed-required-function-argument
+ (+ 100 (function-argument-argnum b)))
+ (located-binding
+ (let* ((count-init (gethash b var-counts))
+ (count (car count-init))
+ (init-pc (cdr count-init)))
+ (if (not (and count init-pc))
+ 50
+ (truncate
+ (or (position-if (lambda (i)
+ (member b (find-read-bindings i)))
+ (cdr init-pc)
+ :end 5)
+ 10)
+ count))))))))
+ (when (and (binding-lended-p binding)
+ (not (typep binding 'borrowed-binding))
+ (not (getf (binding-lended-p binding) :stack-cons-location)))
+ ;; (warn "assigning lending-cons for ~W at ~D" binding stack-frame-position)
+ (let ((cons-pos (post-incf stack-frame-position 2)))
+ (setf (new-binding-location (cons :lended-cons binding) frame-map)
+ (1+ cons-pos))
+ (setf (getf (binding-lended-p binding) :stack-cons-location)
+ cons-pos)))
+ (unless (new-binding-located-p binding frame-map)
+ (etypecase binding
+ (constant-object-binding) ; no location needed.
+ (forwarding-binding) ; will use the location of target binding.
+ (borrowed-binding) ; location is predetermined
+ (fixed-required-function-argument
+ (setf (new-binding-location binding frame-map)
+ :argument-stack))
+ (located-binding
+;;; (when (and (binding-store-type binding)
+;;; (apply #'encoded-type-singleton
+;;; (binding-store-type binding)))
+;;; (warn "Locating constant binding: ~S" binding))
+;;; (warn "binding: ~S type ~S, count: ~S"
+;;; binding
+;;; (apply #'encoded-type-decode
+;;; (binding-store-type binding))
+;;; (gethash binding var-counts))
+;;; (print-code 'foo code)
+ (let* ((count-init-pc (gethash binding var-counts))
+ (count (car count-init-pc))
+ (init-pc (cdr count-init-pc)))
+ (cond
+ ((binding-lended-p binding)
(setf (new-binding-location binding frame-map)
- (post-incf stack-frame-position))))))
- (setf (getf env-roof-map env)
- stack-frame-position)))))
+ (post-incf stack-frame-position)))
+ ((and (= 1 count)
+ init-pc)
+ (assert (instruction-is (first init-pc) :init-lexvar))
+ (destructuring-bind (init-binding &key init-with-register init-with-type
+ protect-registers protect-carry)
+ (cdr (first init-pc))
+ (declare (ignore protect-registers protect-carry init-with-type))
+ (assert (eq binding init-binding))
+ (let* ((load-instruction
+ (find-if (lambda (i)
+ (member binding (find-read-bindings i)))
+ (cdr init-pc)
+ :end 7))
+ (binding-destination (third load-instruction))
+ (distance (position load-instruction (cdr init-pc)))
+ (free-registers
+ (and distance
+ (compute-free-registers (cdr init-pc) distance
+ (movitz-environment-funobj function-env)
+ frame-map))))
+ (let ((location (cond
+ ((member binding-destination free-registers)
+ binding-destination)
+ ((member init-with-register free-registers)
+ init-with-register)
+ ((first free-registers))
+ (t (post-incf stack-frame-position)))))
+;;; (when (and (symbolp location) (< 2 distance))
+;;; (warn "Assigning ~A to ~A dist ~S."
+;;; (binding-name binding)
+;;; location
+;;; distance)
+;;; (print-code 'middle (subseq init-pc 0 (+ 2 distance))))
+ (setf (new-binding-location binding frame-map) location)))))
+ (t (setf (new-binding-location binding frame-map)
+ (post-incf stack-frame-position)))))))))
+ (setf (getf env-roof-map env)
+ stack-frame-position)))))
(loop ;; with funobj = (movitz-environment-funobj function-env)
for binding being the hash-keys of var-counts
as env = (binding-env binding)
@@ -2767,147 +2877,148 @@
(when (movitz-env-get (binding-name binding) 'ignore nil (binding-env binding))
(warn "The variable ~S is used even if it was declared ignored."
(binding-name binding)))
- (flet ((chose-tmp-register (&optional preferred)
- (or tmp-register
- (unless (member preferred protect-registers)
- preferred)
- (first (set-difference '(:eax :ebx :ecx :edx)
- protect-registers))
- (error "Unable to chose a temporary register.")))
- (install-for-single-value (lexb lexb-location result-mode indirect-p)
- (if (integerp lexb-location)
- (append `((:movl ,(make-indirect-reference :ebp (stack-frame-offset lexb-location))
- ,(single-value-register result-mode)))
- (when indirect-p
- `((:movl (-1 ,(single-value-register result-mode))
- ,(single-value-register result-mode)))))
- (ecase lexb-location
- (:eax
- (assert (not indirect-p))
- (ecase result-mode
- ((:ecx :edx) `((:movl :eax ,result-mode)))
- ((:eax :single-value) nil)))
- ((:ebx :ecx :edx)
- (assert (not indirect-p))
- (unless (eq result-mode lexb-location)
+ (let ((protect-registers (cons :edx protect-registers)))
+ (flet ((chose-tmp-register (&optional preferred)
+ (or tmp-register
+ (unless (member preferred protect-registers)
+ preferred)
+ (first (set-difference '(:eax :ebx :ecx :edx)
+ protect-registers))
+ (error "Unable to chose a temporary register.")))
+ (install-for-single-value (lexb lexb-location result-mode indirect-p)
+ (if (integerp lexb-location)
+ (append `((:movl ,(make-indirect-reference :ebp (stack-frame-offset lexb-location))
+ ,(single-value-register result-mode)))
+ (when indirect-p
+ `((:movl (-1 ,(single-value-register result-mode))
+ ,(single-value-register result-mode)))))
+ (ecase lexb-location
+ (:eax
+ (assert (not indirect-p))
(ecase result-mode
- ((:eax :single-value) `((:movl :ebx :eax)))
- ((:ebx :ecx :ecx) `((:movl ,lexb-location ,result-mode))))))
- (:argument-stack
- (assert (<= 2 (function-argument-argnum lexb)) ()
- "lexical :argument-stack argnum can't be ~A." (function-argument-argnum lexb))
- (append `((:movl (:ebp ,(argument-stack-offset lexb))
- ,(single-value-register result-mode)))
- (when indirect-p
- `((:movl (-1 ,(single-value-register result-mode))
- ,(single-value-register result-mode))))))))))
- (etypecase binding
- (forwarding-binding
- (assert (not (binding-lended-p binding)) (binding)
- "Can't lend a forwarding-binding ~S." binding)
- (make-load-lexical (forwarding-binding-target binding)
- result-mode funobj shared-reference-p frame-map))
- (constant-object-binding
- (assert (not (binding-lended-p binding)) (binding)
- "Can't lend a constant-reference-binding ~S." binding)
- (make-load-constant (constant-object binding)
- result-mode
- funobj frame-map))
- (borrowed-binding
- (let ((slot (borrowed-binding-reference-slot binding)))
- (cond
- (shared-reference-p
- (ecase (result-mode-type result-mode)
- ((:eax :ebx :ecx :edx)
- `((:movl (:esi ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 slot)))
- ,(result-mode-type result-mode))))))
- ((not shared-reference-p)
- (case result-mode
- ((:single-value :eax :ebx :ecx :edx :esi)
- (let ((tmp-register (chose-tmp-register (single-value-register result-mode))))
- `((:movl (:esi ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 slot)))
- ,tmp-register)
- (:movl (,tmp-register -1)
- ,(single-value-register result-mode)))))
- (:push
- (let ((tmp-register (chose-tmp-register :eax)))
+ ((:ebx :ecx :edx) `((:movl :eax ,result-mode)))
+ ((:eax :single-value) nil)))
+ ((:ebx :ecx :edx)
+ (assert (not indirect-p))
+ (unless (eq result-mode lexb-location)
+ (ecase result-mode
+ ((:eax :single-value) `((:movl ,lexb-location :eax)))
+ ((:ebx :ecx :ecx :esi) `((:movl ,lexb-location ,result-mode))))))
+ (:argument-stack
+ (assert (<= 2 (function-argument-argnum lexb)) ()
+ "lexical :argument-stack argnum can't be ~A." (function-argument-argnum lexb))
+ (append `((:movl (:ebp ,(argument-stack-offset lexb))
+ ,(single-value-register result-mode)))
+ (when indirect-p
+ `((:movl (-1 ,(single-value-register result-mode))
+ ,(single-value-register result-mode))))))))))
+ (etypecase binding
+ (forwarding-binding
+ (assert (not (binding-lended-p binding)) (binding)
+ "Can't lend a forwarding-binding ~S." binding)
+ (make-load-lexical (forwarding-binding-target binding)
+ result-mode funobj shared-reference-p frame-map))
+ (constant-object-binding
+ (assert (not (binding-lended-p binding)) (binding)
+ "Can't lend a constant-reference-binding ~S." binding)
+ (make-load-constant (constant-object binding)
+ result-mode
+ funobj frame-map))
+ (borrowed-binding
+ (let ((slot (borrowed-binding-reference-slot binding)))
+ (cond
+ (shared-reference-p
+ (ecase (result-mode-type result-mode)
+ ((:eax :ebx :ecx :edx)
`((:movl (:esi ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 slot)))
- ,tmp-register)
- (:pushl (,tmp-register -1)))))
- (t (let ((tmp-register (chose-tmp-register :eax)))
- (make-result-and-returns-glue
- result-mode tmp-register
- `((:movl (:esi ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 slot)))
- ,tmp-register)
- (:movl (,tmp-register -1) ,tmp-register))))))))))
- (located-binding
- (let ((binding-location (new-binding-location binding frame-map)))
- (cond
- ((and (binding-lended-p binding)
- (not shared-reference-p))
- (case result-mode
- ((:single-value :eax :ebx :ecx :edx :esi :esp)
- (install-for-single-value binding binding-location
- (single-value-register result-mode) t))
- (:push
- (if (integerp binding-location)
- `((:movl (:ebp ,(stack-frame-offset binding-location)) :eax)
- (:pushl (:eax -1)))
- (ecase binding-location
-;;; (:eax '((:pushl :eax)))
-;;; (:ebx '((:pushl :ebx)))
- (:argument-stack
- (assert (<= 2 (function-argument-argnum binding)) ()
- ":load-lexical argnum can't be ~A." (function-argument-argnum binding))
- `((:movl (:ebp ,(argument-stack-offset binding)) :eax)
- (:pushl (:eax -1)))))))
- (t (make-result-and-returns-glue
- result-mode :eax
- (install-for-single-value binding binding-location :eax t)))))
- (t (case (operator result-mode)
+ ,(result-mode-type result-mode))))))
+ ((not shared-reference-p)
+ (case result-mode
+ ((:single-value :eax :ebx :ecx :edx :esi)
+ (let ((tmp-register (chose-tmp-register (single-value-register result-mode))))
+ `((:movl (:esi ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 slot)))
+ ,tmp-register)
+ (:movl (,tmp-register -1)
+ ,(single-value-register result-mode)))))
+ (:push
+ (let ((tmp-register (chose-tmp-register :eax)))
+ `((:movl (:esi ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 slot)))
+ ,tmp-register)
+ (:pushl (,tmp-register -1)))))
+ (t (let ((tmp-register (chose-tmp-register :eax)))
+ (make-result-and-returns-glue
+ result-mode tmp-register
+ `((:movl (:esi ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 slot)))
+ ,tmp-register)
+ (:movl (,tmp-register -1) ,tmp-register))))))))))
+ (located-binding
+ (let ((binding-location (new-binding-location binding frame-map)))
+ (cond
+ ((and (binding-lended-p binding)
+ (not shared-reference-p))
+ (case result-mode
((:single-value :eax :ebx :ecx :edx :esi :esp)
(install-for-single-value binding binding-location
- (single-value-register result-mode) nil))
+ (single-value-register result-mode) t))
(:push
(if (integerp binding-location)
- `((:pushl (:ebp ,(stack-frame-offset binding-location))))
+ `((:movl (:ebp ,(stack-frame-offset binding-location)) :eax)
+ (:pushl (:eax -1)))
(ecase binding-location
- (:eax '((:pushl :eax)))
- (:ebx '((:pushl :ebx)))
+;;; (:eax '((:pushl :eax)))
+;;; (:ebx '((:pushl :ebx)))
(:argument-stack
(assert (<= 2 (function-argument-argnum binding)) ()
":load-lexical argnum can't be ~A." (function-argument-argnum binding))
- `((:pushl (:ebp ,(argument-stack-offset binding))))))))
- (:boolean-branch-on-true
- (if (integerp binding-location)
- `((:cmpl :edi (:ebp ,(stack-frame-offset binding-location)))
- (:jne ',(operands result-mode)))
- (ecase binding-location
- ((:eax :ebx)
- `((:cmpl :edi ,binding-location)
- (:jne ',(operands result-mode))))
- (:argument-stack
- `((:cmpl :edi (:ebp ,(argument-stack-offset binding)))
- (:jne ',(operands result-mode)))))))
- (:boolean-branch-on-false
- (if (integerp binding-location)
- `((:cmpl :edi (:ebp ,(stack-frame-offset binding-location)))
- (:je ',(operands result-mode)))
- (ecase binding-location
- ((:eax :ebx)
- `((:cmpl :edi ,binding-location)
- (:je ',(operands result-mode))))
- (:argument-stack
- `((:cmpl :edi (:ebp ,(argument-stack-offset binding)))
- (:je ',(operands result-mode)))))))
- (:untagged-fixnum-ecx
- (make-result-and-returns-glue
- result-mode :ecx
- (install-for-single-value binding binding-location :ecx nil)))
+ `((:movl (:ebp ,(argument-stack-offset binding)) :eax)
+ (:pushl (:eax -1)))))))
(t (make-result-and-returns-glue
result-mode :eax
- (install-for-single-value binding binding-location :eax nil)))
- ))))))))
+ (install-for-single-value binding binding-location :eax t)))))
+ (t (case (operator result-mode)
+ ((:single-value :eax :ebx :ecx :edx :esi :esp)
+ (install-for-single-value binding binding-location
+ (single-value-register result-mode) nil))
+ (:push
+ (if (integerp binding-location)
+ `((:pushl (:ebp ,(stack-frame-offset binding-location))))
+ (ecase binding-location
+ (:eax '((:pushl :eax)))
+ (:ebx '((:pushl :ebx)))
+ (:argument-stack
+ (assert (<= 2 (function-argument-argnum binding)) ()
+ ":load-lexical argnum can't be ~A." (function-argument-argnum binding))
+ `((:pushl (:ebp ,(argument-stack-offset binding))))))))
+ (:boolean-branch-on-true
+ (if (integerp binding-location)
+ `((:cmpl :edi (:ebp ,(stack-frame-offset binding-location)))
+ (:jne ',(operands result-mode)))
+ (ecase binding-location
+ ((:eax :ebx)
+ `((:cmpl :edi ,binding-location)
+ (:jne ',(operands result-mode))))
+ (:argument-stack
+ `((:cmpl :edi (:ebp ,(argument-stack-offset binding)))
+ (:jne ',(operands result-mode)))))))
+ (:boolean-branch-on-false
+ (if (integerp binding-location)
+ `((:cmpl :edi (:ebp ,(stack-frame-offset binding-location)))
+ (:je ',(operands result-mode)))
+ (ecase binding-location
+ ((:eax :ebx)
+ `((:cmpl :edi ,binding-location)
+ (:je ',(operands result-mode))))
+ (:argument-stack
+ `((:cmpl :edi (:ebp ,(argument-stack-offset binding)))
+ (:je ',(operands result-mode)))))))
+ (:untagged-fixnum-ecx
+ (make-result-and-returns-glue
+ result-mode :ecx
+ (install-for-single-value binding binding-location :ecx nil)))
+ (t (make-result-and-returns-glue
+ result-mode :eax
+ (install-for-single-value binding binding-location :eax nil)))
+ )))))))))
(defun make-store-lexical (binding source shared-reference-p frame-map
&key protect-registers)
@@ -2960,6 +3071,7 @@
`((:movl ,source (:ebp ,(argument-stack-offset binding))))))))))))
(defun finalize-code (code funobj frame-map)
+ ;; (print-code 'to-be-finalized code)
(labels ((actual-binding (b)
(if (typep b 'borrowed-binding)
(borrowed-binding-target b)
@@ -5363,7 +5475,6 @@
(list x)))
(define-extended-code-expander :car (instruction funobj frame-map)
- (warn "CAR: ~S" instruction)
(destructuring-bind (x dst)
(cdr instruction)
(assert (member dst '(:eax :ebx :ecx :edx)))
@@ -5372,9 +5483,10 @@
(let* ((binding (ensure-local-binding (binding-target x) funobj)))
(cond
((binding-store-subtypep binding 'list)
+ ;; (warn "Inlined CAR for ~S" binding)
`(,@(make-load-lexical binding dst funobj nil frame-map)
(:movl (,dst -1) ,dst)))
- (t `(,@(make-load-lexical binding dst funobj nil frame-map)
+ (t `(,@(make-load-lexical binding :eax funobj nil frame-map)
(:call (:edi ,(global-constant-offset 'fast-car)))
,@(when (not (eq dst :eax))
`((:movl :eax ,dst))))))))
1
0

[movitz-cvs] CVS update: movitz/losp/muerte/los-closette-compiler.lisp
by Frode Vatvedt Fjeld 15 Feb '04
by Frode Vatvedt Fjeld 15 Feb '04
15 Feb '04
Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory common-lisp.net:/tmp/cvs-serv22465
Modified Files:
los-closette-compiler.lisp
Log Message:
Generate names for functions that are part of classes :default-initargs.
Date: Sun Feb 15 08:17:55 2004
Author: ffjeld
Index: movitz/losp/muerte/los-closette-compiler.lisp
diff -u movitz/losp/muerte/los-closette-compiler.lisp:1.10 movitz/losp/muerte/los-closette-compiler.lisp:1.11
--- movitz/losp/muerte/los-closette-compiler.lisp:1.10 Mon Feb 9 20:03:41 2004
+++ movitz/losp/muerte/los-closette-compiler.lisp Sun Feb 15 08:17:55 2004
@@ -10,7 +10,7 @@
;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org>
;;;; Created at: Thu Aug 29 13:15:11 2002
;;;;
-;;;; $Id: los-closette-compiler.lisp,v 1.10 2004/02/10 01:03:41 ffjeld Exp $
+;;;; $Id: los-closette-compiler.lisp,v 1.11 2004/02/15 13:17:55 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -281,7 +281,7 @@
,(canonicalize-direct-superclasses direct-superclasses)
:direct-slots
,(canonicalize-direct-slots direct-slots name nil)
- ,@(canonicalize-defclass-options options nil)))
+ ,@(canonicalize-defclass-options options nil name)))
(defun canonicalize-direct-slots (direct-slots class-name env)
`(list ,@(mapcar (lambda (ds) (canonicalize-direct-slot ds class-name env)) direct-slots)))
@@ -345,11 +345,10 @@
(setf (movitz-slot-value s 'object) object)
s))))
- (defun canonicalize-defclass-options (options env)
- (mapcan (lambda (o) (canonicalize-defclass-option o env)) options))
+ (defun canonicalize-defclass-options (options env class-name)
+ (mapcan (lambda (o) (canonicalize-defclass-option o env class-name)) options))
- (defun canonicalize-defclass-option (option env)
- (declare (ignore env))
+ (defun canonicalize-defclass-option (option env class-name)
(case (car option)
((:metaclass)
(list ':metaclass
@@ -357,11 +356,12 @@
((:default-initargs)
(list :default-initargs-function
(list 'quote
- (cons (compile-in-lexical-environment nil nil
- `(lambda (o)
- (case o
- ,@(loop for (arg val) on (cdr option) by #'cddr
- collect `(,arg ,val)))))
+ (cons (compile-in-lexical-environment
+ env (gensym (format nil "default-initargs-~A-" class-name))
+ `(lambda (o)
+ (case o
+ ,@(loop for (arg val) on (cdr option) by #'cddr
+ collect `(,arg ,val)))))
(loop for arg in (cdr option) by #'cddr collect arg)))))
(t (list `',(car option) `',(cadr option)))))
1
0