Changeset 12861

Timestamp:

Sep 22, 2009, 3:05:49 AM (10 years ago)

Author:

gb

Message:

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.

Location:

trunk/source

Files:

• compiler/X86/x862.lisp (modified) (9 diffs)
• compiler/nx-basic.lisp (modified) (1 diff)
• compiler/nx0.lisp (modified) (4 diffs)
• compiler/nx1.lisp (modified) (4 diffs)
• compiler/nx2.lisp (modified) (1 diff)
• compiler/nxenv.lisp (modified) (3 diffs)
• compiler/optimizers.lisp (modified) (1 diff)
• library/lispequ.lisp (modified) (1 diff)

trunk/source/compiler/X86/x862.lisp

@@ -2111 +2111 @@
          (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
@@ -3548 +3548 @@
   (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*)))
@@ -3696 +3696 @@
 
 (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))
@@ -4368 +4368 @@
                    (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))
@@ -4374 +4374 @@
               (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
@@ -4481 +4482 @@
   (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)) *nx-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-operator bound-special-ref))
@@ -4998 +4999 @@
     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)))
@@ -6338 +6339 @@
     (x862-form seg vreg xfer form)))
 
+(defx862 x862-type-asserted-form type-asserted-form (seg vreg xfer typespec 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))
@@ -6734 +6739 @@
       (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))))

trunk/source/compiler/nx-basic.lisp

@@ -484 +484 @@
  
 (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))
 
 

trunk/source/compiler/nx0.lisp

@@ -436 +436 @@
 
 
-(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-decls)
-                        '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 trust-decls)
-                                    (acode-form-typep f2 'double-float trust-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-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 trust-decls)
+                                                  (acode-form-typep f2 'double-float trust-decls))
+                                            'double-float
+                                            'single-float)))
+                                      (cdr (assq op *nx-operator-result-types*)))))))))))))))))
+    (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)
@@ -1818 +1838 @@
                     (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)
@@ -2526 +2546 @@
        ((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))
@@ -2567 +2592 @@
                   (or (and op (cdr (assq op *nx-operator-result-types*)))
                       (and (not op)(cdr (assq (car form) *nx-operator-result-types-by-name*)))
-                      (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)

trunk/source/compiler/nx1.lisp

@@ -322 +322 @@
 (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)
@@ -1254 +1255 @@
               (%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
@@ -1470 +1471 @@
             (make-acode
              (%nx1-operator catch)
-             (make-acode (%nx1-operator lexical-reference) tagvar)
+             (nx-make-lexical-reference tagvar)
              body)
             0)))))))
@@ -1958 +1959 @@
                                     (%nx1-operator debind)
                                     nil
-                                    (make-acode 
-                                     (%nx1-operator lexical-reference) var)
+                                    (nx-make-lexical-reference var)
                                     nil 
                                     nil 

trunk/source/compiler/nx2.lisp

@@ -226 +226 @@
                 (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)))))))

trunk/source/compiler/nxenv.lisp

@@ -25 +25 @@
   (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")
@@ -124 +131 @@
      (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)
@@ -487 +494 @@
 ; 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)

trunk/source/compiler/optimizers.lisp

@@ -1226 +1226 @@
       `(%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, else not
-        `(*-2 ,n0 (* ,n1 ,@more))
-        w))
+    `(*-2 ,n0 (* ,n1 ,@more))
     (if n1p
       `(*-2 ,n0 ,n1)

trunk/source/library/lispequ.lisp

@@ -199 +199 @@
   (var-bits var-parent)                 ; fixnum or ptr to parent
   (var-ea  var-expansion)               ; p2 address (or symbol-macro expansion)
-  var-decls                             ; list of applicable decls [not used]
+  var-ref-forms                         ; in intermediate-code
   var-inittype
   var-binding-info
   var-refs
   var-nvr
+  var-declared-type
 )