[Openmcl-cvs-notifications] r16190 - in /trunk/source/compiler: X86/X8632/x8632-vinsns.lisp X86/x862.lisp acode-rewrite.lisp nx-basic.lisp nxenv.lisp

gb at clozure.com gb at clozure.com
Mon Sep 8 00:35:15 UTC 2014


Author: gb
Date: Mon Sep  8 00:35:15 2014
New Revision: 16190

Log:
on x8632: do logical and arithmetic operations on natural args using
an NFP slot and a register; don't try to walk acode with WITH-EXTRA-IMM-REG
reducing the number of available registers.  Fixes ticket:1226.

Don't use a temp register to access an unboxed word on the nfp. =

Fixes ticket:1232

ACODE.INFO is now a cons of visited flag and note.  ACODE-REWRITE
doesn't descend forms that have already been visited. Fixes ticket:1231,

Modified:
    trunk/source/compiler/X86/X8632/x8632-vinsns.lisp
    trunk/source/compiler/X86/x862.lisp
    trunk/source/compiler/acode-rewrite.lisp
    trunk/source/compiler/nx-basic.lisp
    trunk/source/compiler/nxenv.lisp

Modified: trunk/source/compiler/X86/X8632/x8632-vinsns.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/X8632/x8632-vinsns.lisp	(original)
+++ trunk/source/compiler/X86/X8632/x8632-vinsns.lisp	Mon Sep  8 00:35:15 2=
014
@@ -4237,15 +4237,17 @@
 =

 (define-x8632-vinsn (nfp-store-unboxed-word :nfp :set) (()
                                                         ((val :u32)
-                                                         (offset :u16const)
-                                                         (nfp :imm)))
-  (movl (:%l val) (:@ (:apply + 16 offset) (:% nfp))))
+                                                         (offset :u16const=
)))
+  (movd (:%l val) (:%mmx x8632::stack-temp))
+  (movl (:@ (:%seg :rcontext) x8632::tcr.nfp) (:%l val))
+  (movd (:%mmx x8632::stack-temp) (:@ (:apply + 16 offset) (:% val)))
+  (movd (:%mmx x8632::stack-temp) (:% val)))
 =

 =

 (define-x8632-vinsn (nfp-load-unboxed-word :nfp :ref) (((val :u32))
-                                                       ((offset :u16const)
-                                                        (nfp :imm)))
-  (movl (:@ (:apply + 16 offset) (:% nfp)) (:%l val)))
+                                                       ((offset :u16const)=
))
+  (movl (:@ (:%seg :rcontext) x8632::tcr.nfp) (:%l val))
+  (movl (:@ (:apply + 16 offset) (:% val)) (:%l val)))
 =

 (define-x8632-vinsn (nfp-store-single-float :nfp :set)
  (()
@@ -4301,6 +4303,45 @@
                                                   ((nfp :lisp))) ; sic
   (movl (:@ (:%seg :rcontext) x8632::tcr.nfp) (:%l nfp))
   (cmpl (:%l reg) (:@ (:apply + offset 16) (:%l nfp))))
+
+(define-x8632-vinsn nfp-logior-natural-register (()
+                                                  ((offset :u16const)
+                                                   (reg :u32))
+                                                  ((nfp :lisp))) ; sic
+  (movl (:@ (:%seg :rcontext) x8632::tcr.nfp) (:%l nfp))
+  (orl (:@ (:apply + offset 16) (:%l nfp)) (:%l reg)))
+
+(define-x8632-vinsn nfp-logand-natural-register (()
+                                                  ((offset :u16const)
+                                                   (reg :u32))
+                                                  ((nfp :lisp))) ; sic
+  (movl (:@ (:%seg :rcontext) x8632::tcr.nfp) (:%l nfp))
+  (andl (:@ (:apply + offset 16) (:%l nfp)) (:%l reg)))
+
+(define-x8632-vinsn nfp-logxor-natural-register (()
+                                                  ((offset :u16const)
+                                                   (reg :u32))
+                                                  ((nfp :lisp))) ; sic
+  (movl (:@ (:%seg :rcontext) x8632::tcr.nfp) (:%l nfp))
+  (xorl (:@ (:apply + offset 16) (:%l nfp)) (:%l reg)))
+
+(define-x8632-vinsn nfp-add-natural-register (()
+                                                  ((offset :u16const)
+                                                   (reg :u32))
+                                                  ((nfp :lisp))) ; sic
+  (movl (:@ (:%seg :rcontext) x8632::tcr.nfp) (:%l nfp))
+  (addl (:@ (:apply + offset 16) (:%l nfp)) (:%l reg)))
+
+(define-x8632-vinsn nfp-subtract-natural-register (()
+                                                  ((offset :u16const)
+                                                   (reg :u32))
+                                                  ((nfp :lisp))) ; sic
+  (movl (:@ (:%seg :rcontext) x8632::tcr.nfp) (:%l nfp))
+  (subl (:%l reg) (:@ (:apply + offset 16) (:%l nfp)))
+  (movl (:@ (:apply + offset 16) (:%l nfp)) (:%l reg)))
+
+
+
 =

 (define-x8632-vinsn (temp-push-unboxed-word :push :word :csp)
     (()

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  8 00:35:15 2014
@@ -296,7 +296,7 @@
                          (eql vreg-mode hard-reg-class-gpr-mode-u32))
               (setq reg (available-imm-temp
                          *available-backend-imm-temps*
-                         :u32)))
+                         :natural)))            =

             (setq vinsn
                   (! nfp-load-unboxed-word reg offset nfp)))
         (#. memspec-nfp-type-double-float
@@ -349,11 +349,13 @@
            (vreg-mode (if vreg (get-regspec-mode vreg))))
       (ecase type
         (#. memspec-nfp-type-natural
-            (if (and (eql vreg-class hard-reg-class-gpr)
-                     (eql vreg-mode hard-reg-class-gpr-mode-u32))
+            (if (and (eql vreg-class hard-reg-class-gpr)                  =
   =

+                     (eql vreg-mode (target-word-size-case
+                                     (64 hard-reg-class-gpr-mode-u64)
+                                     (32 hard-reg-class-gpr-mode-u32))))
               vreg
               (make-unwired-lreg
-               (available-imm-temp *available-backend-imm-temps* :u32))))
+               (available-imm-temp *available-backend-imm-temps* :natural)=
)))
         (#. memspec-nfp-type-double-float
             (if (and (eql vreg-class hard-reg-class-fpr)
                      (eql vreg-mode hard-reg-class-fpr-mode-double))
@@ -405,11 +407,11 @@
       (let* ((type (acode-var-type var *x862-trust-declarations*))
              (reg nil)
              (nfp-bits 0))
-        (cond ((and (subtypep type '(unsigned-byte 32))
+        (cond ((and (subtypep type *nx-target-natural-type*)
                     NIL
-                    (not (subtypep type '(signed-byte 30))))
+                    (not (subtypep type *nx-target-fixnum-type*)))
                (setq reg (available-imm-temp
-                          *available-backend-imm-temps* :u32)
+                          *available-backend-imm-temps* :natural)
                      nfp-bits memspec-nfp-type-natural))
               ((subtypep type 'single-float)
                (setq reg (available-fp-temp *available-backend-fp-temps*
@@ -3784,7 +3786,7 @@
         (setq vinsn (x862-vpush-register seg areg inhibit-note))
         (let* ((offset *x862-nfp-depth*)
                (size 16)
-               (nfp (x862-nfp-reg seg)))
+               (nfp (if (target-arch-case (:x8664 t) (:x8632 a-float))(x86=
2-nfp-reg seg))))
           (setq vinsn
                 (if a-float
                   (ecase (fpr-mode-value-name mode)
@@ -3792,7 +3794,9 @@
                     (:double-float (! nfp-store-double-float areg offset n=
fp))
                     (:complex-single-float (! nfp-store-complex-single-flo=
at areg offset nfp))
                     (:complex-double-float (! nfp-store-complex-double-flo=
at areg offset nfp)))
-                  (! nfp-store-unboxed-word areg offset nfp)))
+                  (target-arch-case
+                   (:x8664 (! nfp-store-unboxed-word areg offset nfp))
+                   (:x8632 (! nfp-store-unboxed-word areg offset)))))
           (incf offset size)
           (push vinsn *x862-all-nfp-pushes*)
           (setq *x862-nfp-depth* offset))))
@@ -3810,7 +3814,8 @@
       (if a-node
         (setq vinsn (x862-vpop-register seg areg))
         (let* ((offset (- *x862-nfp-depth* 16))
-               (nfp (x862-nfp-reg seg)))
+               (nfp (if (target-arch-case (:x8664 t) (:x8632 a-float))
+                      (x862-nfp-reg seg))))
           (setq vinsn
                 (if a-float
                   (ecase (fpr-mode-value-name mode)
@@ -3818,7 +3823,11 @@
                     (:double-float (! nfp-load-double-float areg offset nf=
p))
                     (:complex-single-float (! nfp-load-complex-single-floa=
t areg offset nfp))
                     (:complex-double-float (! nfp-load-complex--float areg=
 offset nfp)))
-                  (! nfp-load-unboxed-word areg offset nfp)))
+                  (target-arch-case
+                   (:x8664
+                    (! nfp-load-unboxed-word areg offset nfp))
+                   (:x8632
+                    (! nfp-load-unboxed-word areg offset)))))
           (setq *x862-nfp-depth* offset)))
       vinsn)))
 =

@@ -10763,10 +10772,18 @@
                (u31y (and (typep fix-y '(unsigned-byte 31)) fix-y)))
           (if (not (or u31x u31y))
             (with-imm-target () (xreg :natural)
-	      (with-additional-imm-reg ()
+              (target-arch-case
+               (:x8664
 		(with-imm-target (xreg) (yreg :natural)
 		  (x862-two-targeted-reg-forms seg x xreg y yreg)
 		  (! %natural+ xreg yreg)))
+               (:x8632
+                (let* ((*x862-nfp-depth* *x862-nfp-depth*)
+                       (offset *x862-nfp-depth*))
+                  (x862-one-targeted-reg-form seg x xreg)
+                  (x862-push-register seg xreg)
+                  (x862-one-targeted-reg-form seg y xreg)
+                  (! nfp-add-natural-register offset xreg))))
               (<- xreg))
             (let* ((other (if u31x y x)))
               (with-imm-target () (other-reg :natural)
@@ -10787,11 +10804,19 @@
         (let* ((u31y (and (typep fix-y '(unsigned-byte 31)) fix-y)))
           (if (not u31y)
 	    (with-imm-target () (xreg :natural)
-	      (with-additional-imm-reg ()
+	      (target-arch-case
+               (:x8664
 		(with-imm-target (xreg) (yreg :natural)
 		  (x862-two-targeted-reg-forms seg x xreg y yreg)
-		  (! %natural- xreg yreg))
-		(<- xreg)))
+		  (! %natural- xreg yreg)))
+               (:x8632
+                (let* ((*x862-nfp-depth* *x862-nfp-depth*)
+                       (offset *x862-nfp-depth*))
+                  (x862-one-targeted-reg-form seg x xreg)
+                  (x862-push-register seg xreg)
+                  (x862-one-targeted-reg-form seg y xreg)
+                  (! nfp-subtract-natural-register offset xreg))))
+		(<- xreg))
             (progn
               (with-imm-target () (xreg :natural)
                 (x862-one-targeted-reg-form seg x xreg)
@@ -10813,10 +10838,18 @@
                (constant (or u31x u31y)))
           (if (not constant)
             (with-imm-target () (xreg :natural)
-	      (with-additional-imm-reg ()
+	      (target-arch-case
+               (:x8664
 		(with-imm-target (xreg) (yreg :natural)
 		  (x862-two-targeted-reg-forms seg x xreg y yreg)
 		  (! %natural-logior xreg yreg)))
+               (:x8632
+                (let* ((*x862-nfp-depth* *x862-nfp-depth*)
+                       (offset *x862-nfp-depth*))
+                  (x862-one-targeted-reg-form seg x xreg)
+                  (x862-push-register seg xreg)
+                  (x862-one-targeted-reg-form seg y xreg)
+                  (! nfp-logior-natural-register offset xreg))))
               (<- xreg))
             (let* ((other (if u31x y x)))
               (with-imm-target () (other-reg :natural)
@@ -10839,10 +10872,18 @@
                (constant (or u32x u32y)))
           (if (not constant)
             (with-imm-target () (xreg :natural)
-	      (with-additional-imm-reg ()
+	      (target-arch-case
+               (:x8664
 		(with-imm-target (xreg) (yreg :natural)
 		  (x862-two-targeted-reg-forms seg x xreg y yreg)
 		  (! %natural-logxor xreg yreg)))
+               (:x8632
+                (let* ((*x862-nfp-depth* *x862-nfp-depth*)
+                       (offset *x862-nfp-depth*))
+                  (x862-one-targeted-reg-form seg x xreg)
+                  (x862-push-register seg xreg)
+                  (x862-one-targeted-reg-form seg y xreg)
+                  (! nfp-logxor-natural-register offset xreg))))
               (<- xreg))
             (let* ((other (if u32x y x)))
               (with-imm-target () (other-reg :natural)
@@ -10865,10 +10906,18 @@
                (constant (or u31x u31y)))
           (if (not constant)
             (with-imm-target () (xreg :natural)
-	      (with-additional-imm-reg ()
+	      (target-arch-case
+               (:x8664
 		(with-imm-target (xreg) (yreg :natural)
 		  (x862-two-targeted-reg-forms seg x xreg y yreg)
 		  (! %natural-logand xreg yreg)))
+               (:x8632
+                (let* ((*x862-nfp-depth* *x862-nfp-depth*)
+                       (offset *x862-nfp-depth*))
+                  (x862-one-targeted-reg-form seg x xreg)
+                  (x862-push-register seg xreg)
+                  (x862-one-targeted-reg-form seg y xreg)
+                  (! nfp-logand-natural-register offset xreg))))
               (<- xreg))
             (let* ((other (if u31x y x)))
               (with-imm-target () (other-reg :natural)

Modified: trunk/source/compiler/acode-rewrite.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/acode-rewrite.lisp	(original)
+++ trunk/source/compiler/acode-rewrite.lisp	Mon Sep  8 00:35:15 2014
@@ -70,14 +70,16 @@
 =

 (defun rewrite-acode-form (form &optional (type t))
   (when (acode-p form)
-    (let* ((op (acode-operator form))
-           (rewrite (svref *acode-rewrite-functions* (logand op operator-i=
d-mask))))
-      (if rewrite
-        (funcall rewrite form type)
-        (if (logbitp operator-acode-subforms-bit op)
-          (dolist (operand (acode-operands form))
-            (rewrite-acode-form operand))
-          (format t "~&can't rewrite ~s : ~s" (acode-operator-name op) for=
m))))))
+    (unless (acode-walked form)
+      (setf (acode-walked form) t)
+      (let* ((op (acode-operator form))
+             (rewrite (svref *acode-rewrite-functions* (logand op operator=
-id-mask))))
+        (if rewrite
+          (funcall rewrite form type)
+          (if (logbitp operator-acode-subforms-bit op)
+            (dolist (operand (acode-operands form))
+              (rewrite-acode-form operand))
+            (format t "~&can't rewrite ~s : ~s" (acode-operator-name op) f=
orm)))))))
 =

 (defun acode-wrap-in-unary-op (form op)
   (let* ((new (make-acode* (acode-operator form) (acode-operands form))))
@@ -170,6 +172,7 @@
            (let* ((c2 (acode-real-constant-p form2)))
              (if c2
                (setf (acode-operator form2) (%nx1-operator immediate)
+                     (acode.asserted-type form2) nil
                      (acode-operands form2) (cons (float c2 0.0d0) nil))
                (if (acode-form-typep form2 'fixnum trust-decls)
                  (acode-wrap-in-unary-op form2 (%nx1-operator %fixnum-to-d=
ouble)))))))
@@ -177,6 +180,7 @@
          (let* ((c1 (acode-real-constant-p form1)))
            (if c1
                (setf (acode-operator form1) (%nx1-operator immediate)
+                     (acode.asserted-type form1) nil
                      (acode-operands form1) (cons (float c1 0.0d0) nil))
              (if (acode-form-typep form1 'fixnum trust-decls)
                (acode-wrap-in-unary-op form1 (%nx1-operator %fixnum-to-dou=
ble))))))
@@ -185,6 +189,7 @@
            (let* ((c2 (acode-real-constant-p form2)))
              (if c2
                (setf (acode-operator form2) (%nx1-operator immediate)
+                     (acode.asserted-type form2) nil
                      (acode-operands form2) (cons (float c2 0.0f0) nil))
                (if (acode-form-typep form2 'fixnum trust-decls)
                  (acode-wrap-in-unary-op form2 (%nx1-operator %fixnum-to-s=
ingle)))))))
@@ -192,6 +197,7 @@
          (let* ((c1 (acode-real-constant-p form1)))
              (if c1
                (setf (acode-operator form1) (%nx1-operator immediate)
+                     (acode.asserted-type form1) nil
                      (acode-operands form1) (cons (float c1 0.0f0) nil))
                (if (acode-form-typep form1 'fixnum trust-decls)
                  (acode-wrap-in-unary-op form1 (%nx1-operator %fixnum-to-s=
ingle))))))))

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  8 00:35:15 2014
@@ -67,14 +67,21 @@
 ;;; the acode.info slot of an acode node might be used as
 ;;; a plist someday.
 (defun acode-note (acode)
-  (acode.info acode))
+  (when (acode-p acode)
+    (cdr (acode.info acode))))
 =

 (defun (setf acode-note) (note acode)
-  (when note
+  (when (and note (acode-p acode))
     ;; Only record if have a unique key
     (unless (or (nx-null acode)
                 (nx-t acode))
-      (setf (acode.info acode) note))))
+      (setf (cdr (acode.info acode)) note))))
+
+(defun acode-walked (acode)
+  (car (acode.info acode)))
+
+(defun (setf acode-walked) (val acode)
+  (setf (car (acode.info acode)) val))
 =

 =

 (defstruct (code-note (:constructor %make-code-note))

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  8 00:35:15 2014
@@ -31,7 +31,7 @@
   acode.operator                        ; fixnum
   acode.operands                        ; list, elements often acode
   acode.asserted-type                   ; NIL or type specifier.
-  acode.info                            ; plist: notes, etc
+  acode.info                            ; cons of "walked" marker, notr
   )
   =

 (def-accessors (var) %svref
@@ -484,7 +484,7 @@
 ; Stuff having to do with lisp:
 =

 (defmacro make-acode* (operator operands)
-  `(%istruct 'acode ,operator ,operands nil nil))
+  `(%istruct 'acode ,operator ,operands nil (cons nil nil)))
 =

 (defmacro make-acode (operator &rest args)
   `(make-acode* ,operator (list , at args)))



More information about the Openmcl-cvs-notifications mailing list