[Openmcl-cvs-notifications] r12861 - in /trunk/source: compiler/X86/x862.lisp compiler/nx-basic.lisp compiler/nx0.lisp compiler/nx1.lisp compiler/nx2.lisp compiler/nxenv.lisp compiler/optimizers.lisp library/lispequ.lisp
gb at clozure.com
gb at clozure.com
Mon Sep 21 23:05:49 EDT 2009
Author: gb
Date: Mon Sep 21 23:05:49 2009
New Revision: 12861
Log:
compiler/optimizers.lisp: * (multiplication) compiler-macro: always
transform into a sequence of pairwise multiplications.
other files: compiler frontend changes, largely intended to address
ticket:186. These changes are a bit hard to bootstrap; new images
soon.
Modified:
trunk/source/compiler/X86/x862.lisp
trunk/source/compiler/nx-basic.lisp
trunk/source/compiler/nx0.lisp
trunk/source/compiler/nx1.lisp
trunk/source/compiler/nx2.lisp
trunk/source/compiler/nxenv.lisp
trunk/source/compiler/optimizers.lisp
trunk/source/library/lispequ.lisp
Modified: trunk/source/compiler/X86/x862.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/X86/x862.lisp (original)
+++ trunk/source/compiler/X86/x862.lisp Mon Sep 21 23:05:49 2009
@@ -2110,9 +2110,9 @@
(let* ((arch (backend-target-arch *target-backend*))
(is-node (member type-keyword (arch::target-gvector-types arch))=
))
(if is-node
- (cond ((eq form *nx-nil*)
+ (cond ((nx-null form)
(target-nil-value))
- ((eq form *nx-t*)
+ ((nx-t form)
(+ (target-nil-value) (arch::target-t-offset arch)))
(t
(let* ((fixval (acode-fixnum-form-p form)))
@@ -3547,8 +3547,8 @@
(defun x862-acode-operator-supports-push (form)
(let ((value (acode-unwrapped-form-value form)))
(when (acode-p value)
- (if (or (eq value *nx-t*)
- (eq value *nx-nil*)
+ (if (or (nx-t value)
+ (nx-null value)
(let* ((operator (acode-operator value)))
(member operator *x862-operator-supports-push*)))
value))))
@@ -3695,12 +3695,12 @@
(^))))
=
(defun x862-compare-register-to-constant (seg vreg xfer ireg cr-bit true-p=
constant)
- (cond ((eq constant *nx-nil*)
+ (cond ((nx-null constant)
(x862-compare-register-to-nil seg vreg xfer ireg cr-bit true-p))
(t
(with-x86-local-vinsn-macros (seg vreg xfer)
(when vreg
- (if (eq constant *nx-t*)
+ (if (nx-t constant)
(! compare-to-t ireg)
(let* ((imm (x862-immediate-operand constant))
(reg (x862-register-constant-p imm))) =
@@ -4367,12 +4367,13 @@
;; The value returned is acode.
(let* ((bits (nx-var-bits var)))
(if (%ilogbitp $vbitpuntable bits)
- (nx-untyped-form initform)))))
+ initform))))
(declare (inline x862-puntable-binding-p))
(if (and (not (x862-load-ea-p val))
(setq puntval (x862-puntable-binding-p var val)))
(progn
(nx-set-var-bits var (%ilogior (%ilsl $vbitpunted 1) bits))
+ (nx2-replace-var-refs var puntval)
(x862-set-var-ea seg var puntval))
(progn
(let* ((vloc *x862-vstack*)
@@ -4480,7 +4481,7 @@
(defun x862-dbind (seg value sym)
(with-x86-local-vinsn-macros (seg)
(let* ((ea-p (x862-load-ea-p value))
- (nil-p (unless ea-p (eq (setq value (nx-untyped-form value)) *n=
x-nil*)))
+ (nil-p (unless ea-p (nx-null (setq value (nx-untyped-form value=
)))))
(self-p (unless ea-p (and (or
(eq (acode-operator value) (%nx1-ope=
rator bound-special-ref))
(eq (acode-operator value) (%nx1-ope=
rator special-ref)))
@@ -4997,8 +4998,8 @@
(if (x862-form-typep valform 'fixnum)
nil
(let* ((val (acode-unwrapped-form-value valform)))
- (if (or (eq val *nx-t*)
- (eq val *nx-nil*)
+ (if (or (nx-t val)
+ (nx-null val)
(and (acode-p val)
(let* ((op (acode-operator val)))
(or (eq op (%nx1-operator fixnum)) #|(eq op (%nx1-ope=
rator immediate))|#))))
@@ -6337,6 +6338,10 @@
(x862-typechecked-form seg vreg xfer typespec form)
(x862-form seg vreg xfer form)))
=
+(defx862 x862-type-asserted-form type-asserted-form (seg vreg xfer typespe=
c form &optional check)
+ (declare (ignore typespec check))
+ (x862-form seg vreg xfer form))
+
(defx862 x862-%primitive %primitive (seg vreg xfer &rest ignore)
(declare (ignore seg vreg xfer ignore))
(compiler-bug "You're probably losing big: using %primitive ..."))
@@ -6733,13 +6738,13 @@
(multiple-value-bind (cr-bit true-p) (acode-condition-to-x86-cr-bit cc)
(let* ((f1 (acode-unwrapped-form form1))
(f2 (acode-unwrapped-form form2)))
- (cond ((or (eq f1 *nx-nil*)
- (eq f1 *nx-t*)
+ (cond ((or (nx-null f1 )
+ (nx-t f1)
(and (acode-p f1)
(eq (acode-operator f1) (%nx1-operator immediate))=
))
(x862-compare-register-to-constant seg vreg xfer (x862-one-=
untargeted-reg-form seg form2 ($ *x862-arg-z*)) cr-bit true-p f1))
- ((or (eq f2 *nx-nil*)
- (eq f2 *nx-t*)
+ ((or (nx-null f2)
+ (nx-t f2)
(and (acode-p f2)
(eq (acode-operator f2) (%nx1-operator immediate))=
))
(x862-compare-register-to-constant seg vreg xfer
Modified: trunk/source/compiler/nx-basic.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/nx-basic.lisp (original)
+++ trunk/source/compiler/nx-basic.lisp Mon Sep 21 23:05:49 2009
@@ -482,7 +482,7 @@
=
=
(defun cons-var (name &optional (bits 0))
- (%istruct 'var name bits nil nil nil nil nil))
+ (%istruct 'var name bits nil nil nil nil nil nil))
=
=
(defun augment-environment (env &key variable symbol-macro function macro =
declare)
Modified: trunk/source/compiler/nx0.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/nx0.lisp (original)
+++ trunk/source/compiler/nx0.lisp Mon Sep 21 23:05:49 2009
@@ -435,50 +435,70 @@
(%nx1-operator mul2)))
=
=
-(defun acode-form-type (form trust-decls)
- (nx-target-type =
- (if (acode-p form)
- (let* ((op (acode-operator form)))
- (if (eq op (%nx1-operator fixnum))
- 'fixnum
- (if (eq op (%nx1-operator immediate))
- (type-of (%cadr form))
- (and trust-decls
- (if (eq op (%nx1-operator typed-form))
- (if (eq (%cadr form) 'number)
- (or (acode-form-type (nx-untyped-form form) trust-decl=
s)
- 'number)
- (%cadr form))
- (if (eq op (%nx1-operator lexical-reference))
- (let* ((var (cadr form))
- (bits (nx-var-bits var))
- (punted (logbitp $vbitpunted bits)))
- (if (or punted
- (eql 0 (%ilogand $vsetqmask bits)))
- (var-inittype var)))
- (if (or (eq op (%nx1-operator %aref1))
- (eq op (%nx1-operator simple-typed-aref2))
- (eq op (%nx1-operator general-aref2))
- (eq op (%nx1-operator simple-typed-aref3))
- (eq op (%nx1-operator general-aref3)))
- (let* ((atype (acode-form-type (cadr form) t))
- (actype (if atype (specifier-type atype))))
- (if (typep actype 'array-ctype)
- (type-specifier (array-ctype-specialized-element=
-type
- actype))))
- (if (member op *numeric-acode-ops*)
- (multiple-value-bind (f1 f2)
- (nx-binop-numeric-contagion (cadr form)
- (caddr form)
- trust-decls)
- (if (and (acode-form-typep f1 'float trust-decls)
- (acode-form-typep f2 'float trust-decls=
))
-
- (if (or (acode-form-typep f1 'double-float tru=
st-decls)
- (acode-form-typep f2 'double-float tru=
st-decls))
- 'double-float
- 'single-float)))
- (cdr (assq op *nx-operator-result-types*))))))))))=
)))
+
+(defun acode-form-type (form trust-decls &optional (assert t))
+ (let* ((typespec
+ (if (nx-null form)
+ 'null
+ (if (eq form *nx-t*)
+ 'boolean
+ (nx-target-type =
+ (if (acode-p form)
+ (let* ((op (acode-operator form)))
+ (if (eq op (%nx1-operator fixnum))
+ 'fixnum
+ (if (eq op (%nx1-operator immediate))
+ (type-of (%cadr form))
+ (and trust-decls
+ (if (eq op (%nx1-operator type-asserted-form))
+ (progn
+ (setq assert nil)
+ (%cadr form))
+ (if (eq op (%nx1-operator typed-form))
+ (progn
+ (when (and assert (null (nth 3 form)))
+ (setf (%car form) (%nx1-operator type-=
asserted-form)
+ assert nil))
+ (if (eq (%cadr form) 'number)
+ (or (acode-form-type (nx-untyped-form =
form) trust-decls)
+ 'number)
+ (%cadr form)))
+ (if (eq op (%nx1-operator lexical-referenc=
e))
+ (let* ((var (cadr form))
+ (bits (nx-var-bits var))
+ (punted (logbitp $vbitpunted bits=
)))
+ (if (or punted
+ (eql 0 (%ilogand $vsetqmask bi=
ts)))
+ (var-inittype var)))
+ (if (or (eq op (%nx1-operator %aref1))
+ (eq op (%nx1-operator simple-typ=
ed-aref2))
+ (eq op (%nx1-operator general-ar=
ef2))
+ (eq op (%nx1-operator simple-typ=
ed-aref3))
+ (eq op (%nx1-operator general-ar=
ef3)))
+ (let* ((atype (acode-form-type (cadr f=
orm) t))
+ (actype (if atype (specifier-ty=
pe atype))))
+ (if (typep actype 'array-ctype)
+ (type-specifier (array-ctype-speci=
alized-element-type
+ actype))))
+ (if (member op *numeric-acode-ops*)
+ (multiple-value-bind (f1 f2)
+ (nx-binop-numeric-contagion (cad=
r form)
+ (cad=
dr form)
+ trus=
t-decls)
+ (if (and (acode-form-typep f1 'flo=
at trust-decls)
+ (acode-form-typep f2 'flo=
at trust-decls))
+
+ (if (or (acode-form-typep f1 'do=
uble-float trust-decls)
+ (acode-form-typep f2 'do=
uble-float trust-decls))
+ 'double-float
+ 'single-float)))
+ (cdr (assq op *nx-operator-result-ty=
pes*)))))))))))))))))
+ (when (and (acode-p form) (typep (acode-operator form) 'fixnum) assert)
+ (unless typespec (setq typespec t))
+ (let* ((new (cons typespec (cons (cons (%car form) (%cdr form)) nil)=
)))
+ (setf (%car form) (%nx1-operator type-asserted-form)
+ (%cdr form) new)))
+ typespec))
=
(defun nx-binop-numeric-contagion (form1 form2 trust-decls)
(cond ((acode-form-typep form1 'double-float trust-decls)
@@ -1817,7 +1837,7 @@
(when (not inherited-p)
(nx-set-var-bits info (%ilogior2 (%ilsl $vbitreffed 1)=
(nx-var-bits info))))
(nx-adjust-ref-count info)
- (make-acode (%nx1-operator lexical-reference) info)))
+ (nx-make-lexical-reference info)))
(make-acode
(if (nx1-check-special-ref form info)
(progn
@@ -2525,6 +2545,11 @@
(bits (var-bits var) (var-bits var)))
((fixnump bits) (setf (var-bits var) newbits))))
=
+(defun nx-make-lexical-reference (var)
+ (let* ((ref (make-acode (%nx1-operator lexical-reference) var)))
+ (push ref (var-ref-forms var))
+ ref))
+
(defun nx-adjust-ref-count (var)
(let* ((bits (nx-var-bits var))
(temp-p (%ilogbitp $vbittemporary bits))
@@ -2566,9 +2591,9 @@
(let* ((op (gethash (%car form) *nx1-operators*)))
(or (and op (cdr (assq op *nx-operator-result-types*)))
(and (not op)(cdr (assq (car form) *nx-operator-result-types-by-na=
me*)))
- (and (memq (car form) *numeric-ops*)
+ #+no (and (memq (car form) *numeric-ops*)
(grovel-numeric-form form env))
- (and (memq (car form) *logical-ops*)
+ #+no (and (memq (car form) *logical-ops*)
(grovel-logical-form form env))
(nx-declared-result-type (%car form) env)
;; Sort of the right idea, but this should be done
Modified: trunk/source/compiler/nx1.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/nx1.lisp (original)
+++ trunk/source/compiler/nx1.lisp Mon Sep 21 23:05:49 2009
@@ -321,8 +321,9 @@
;;; (assuming, of course, that anyone should ...)
(defun nx-untyped-form (form)
(while (and (consp form)
- (eq (%car form) (%nx1-operator typed-form))
- (null (nth 3 form)))
+ (or (and (eq (%car form) (%nx1-operator typed-form))
+ (null (nth 3 form)))
+ (eq (%car form) (%nx1-operator type-asserted-form))))
(setq form (%caddr form)))
form)
=
@@ -1253,7 +1254,7 @@
(let ((op (if (afunc-inherited-vars afunc)
(%nx1-operator closed-function)
(%nx1-operator simple-function)))
- (ref (afunc-ref-form afunc)))
+ (ref (acode-unwrapped-form (afunc-ref-form afunc))))
(if ref
(%rplaca ref op) ; returns ref
(setf (afunc-ref-form afunc)
@@ -1469,7 +1470,7 @@
(list (make-acode (%nx1-operator cons) (nx1-form nil) (nx1-for=
m nil)))
(make-acode
(%nx1-operator catch)
- (make-acode (%nx1-operator lexical-reference) tagvar)
+ (nx-make-lexical-reference tagvar)
body)
0)))))))
=
@@ -1957,8 +1958,7 @@
(setq body (make-acode
(%nx1-operator debind)
nil
- (make-acode =
- (%nx1-operator lexical-reference) var)
+ (nx-make-lexical-reference var)
nil =
nil =
rest =
Modified: trunk/source/compiler/nx2.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/nx2.lisp (original)
+++ trunk/source/compiler/nx2.lisp Mon Sep 21 23:05:49 2009
@@ -225,4 +225,13 @@
(push e new)))
(setq entries new)))))))
entries))
- =
+
+(defun nx2-replace-var-refs (var value)
+ (when (acode-p value)
+ (let* ((op (acode-operator value))
+ (operands (acode-operands value)))
+ (when (typep op 'fixnum)
+ (dolist (ref (var-ref-forms var) (setf (var-ref-forms var) nil))
+ (when (acode-p ref)
+ (setf (acode-operator ref) op
+ (acode-operands ref) operands)))))))
Modified: trunk/source/compiler/nxenv.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/nxenv.lisp (original)
+++ trunk/source/compiler/nxenv.lisp Mon Sep 21 23:05:49 2009
@@ -24,6 +24,13 @@
(require'backquote)
(require 'lispequ)
)
+
+#-bootstrapped
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (when (and (macro-function 'var-decls)
+ (not (macro-function 'var-ref-forms)))
+ (setf (macro-function 'var-ref-forms)
+ (macro-function 'var-decls))))
=
#+ppc-target (require "PPCENV")
#+x8632-target (require "X8632ENV")
@@ -123,7 +130,7 @@
(tag-label . 0)
(local-tagbody . #.operator-single-valued-mask)
(%fixnum-set-natural . #.operator-single-valued-mask)
- (spushl . #.operator-single-valued-mask)
+ (type-asserted-form . 0)
(spushp . #.operator-single-valued-mask)
(simple-function . #.operator-single-valued-mask)
(closed-function . #.operator-single-valued-mask)
@@ -486,12 +493,16 @@
=
; More Bootstrapping Shit.
(defmacro acode-operator (form)
- ; Gak.
+ ;; Gak.
`(%car ,form))
=
(defmacro acode-operand (n form)
- ; Gak. Gak.
+ ;; Gak. Gak.
`(nth ,n (the list ,form)))
+
+(defmacro acode-operands (form)
+ ;; Gak. Gak. Gak.
+ `(%cdr ,form))
=
(defmacro acode-p (x)
" A big help this is ..."
Modified: trunk/source/compiler/optimizers.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/optimizers.lisp (original)
+++ trunk/source/compiler/optimizers.lisp Mon Sep 21 23:05:49 2009
@@ -1225,12 +1225,9 @@
`(--2 ,n0 ,n1)
`(%negate ,n0))))
=
-(define-compiler-macro * (&whole w &environment env &optional (n0 nil n0p)=
(n1 nil n1p) &rest more)
+(define-compiler-macro * (&optional (n0 nil n0p) (n1 nil n1p) &rest more)
(if more
- (let ((type (nx-form-type w env)))
- (if (and type (numeric-type-p type)) ; go pairwise if type known, el=
se not
- `(*-2 ,n0 (* ,n1 , at more))
- w))
+ `(*-2 ,n0 (* ,n1 , at more))
(if n1p
`(*-2 ,n0 ,n1)
(if n0p
Modified: trunk/source/library/lispequ.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/library/lispequ.lisp (original)
+++ trunk/source/library/lispequ.lisp Mon Sep 21 23:05:49 2009
@@ -198,11 +198,12 @@
var-name ; symbol
(var-bits var-parent) ; fixnum or ptr to parent
(var-ea var-expansion) ; p2 address (or symbol-macro expa=
nsion)
- var-decls ; list of applicable decls [not us=
ed]
+ var-ref-forms ; in intermediate-code
var-inittype
var-binding-info
var-refs
var-nvr
+ var-declared-type
)
=
(def-accessors (package) %svref
More information about the Openmcl-cvs-notifications
mailing list