Changeset 15004

Timestamp:

Sep 29, 2011, 2:52:16 AM (13 years ago)

Author:

Gary Byers

Message:

Do some cases of CASE (and similar constructs) in constant time by
using a jump table in the x86 backends. This -seems- to do the right
things (wrt stack discipline, multiple values, etc.) in all cases that
I've tried (including a handful of things in CCL itself); it can
currently be disabled by setting CCL::*X862-GENERATE-CASEJUMP* to NIL
before compiling.

Get the x86 disassembler to recognize and display jump tables.
Persuade it to print the instruction address in a comment after the
instruction. (We're a ways from being able to re-assemble disassembled
code on x86 for several other reasons, but I think that this makes the
disassembly a little easier to read.)

Location:

trunk/source/compiler/X86

Files:

• X8632/x8632-vinsns.lisp (modified) (2 diffs)
• X8664/x8664-vinsns.lisp (modified) (3 diffs)
• x86-disassemble.lisp (modified) (6 diffs)
• x862.lisp (modified) (1 diff)

trunk/source/compiler/X86/X8632/x8632-vinsns.lisp

@@ -4217 +4217 @@
   (movl (:@ (:% x8632::ebp)) (:% x8632::ebp)))
 
-(define-x8632-vinsn (cjmp :branch) (((reg :lisp))
-                                    ((reg :lisp)
+(define-x8632-vinsn (cjmp :branch) (((reg :s32))
+                                    ((reg :s32)
                                      (minval :s32const)
                                      (maxval :u32const)
                                      (default :label))
-                                    ((temp :s32)
-                                    (rjmp :lisp)))
-  (testl (:$l x8664::fixnummask) (:%l reg))
+                                    ((rjmp :lisp)))
+  (testl (:$l x8632::fixnummask) (:%l reg))
   (jne default)
   ((:not (:pred zerop minval))
@@ -4230 +4229 @@
   (cmpl (:$l maxval) (:%l reg))
   (ja default)
-  (movl (:%l reg) (:%l temp))
-  (movl (:@ (:^ :jtab) (:%l x8632::fn) (:%l temp)) (:%l temp))
-  (leal (:@ (:%l x8632::fn) (:%l temp)) (:%l rjmp))
+  (movl (:@ (:^ :jtab) (:%l x8632::fn) (:%l reg)) (:%l reg))
+  (leal (:@ (:%l x8632::fn) (:%l reg)) (:%l rjmp))
   (jmp (:%l rjmp))
   (:uuo-section)

trunk/source/compiler/X86/X8664/x8664-vinsns.lisp

@@ -4632 +4632 @@
   (movq (:@ (:%q x8664::rbp)) (:%q x8664::rbp)))
 
-(define-x8664-vinsn (cjmp :branch) (((reg :lisp))
-                                    ((reg :lisp)
+(define-x8664-vinsn (cjmp :branch) (((reg :s64))
+                                    ((reg :s64)
                                      (minval :s32const)
                                      (maxval :u32const)
                                      (default :label))
-                                    ((temp :s32)
-                                    (rjmp :lisp)))
+                                    ((rjmp :lisp)))
   (testl (:$l x8664::fixnummask) (:%l reg))
   (jne default)
@@ -4645 +4644 @@
   (cmpq (:$l maxval) (:%q reg))
   (ja default)
-  (movl (:%l reg) (:%l temp))
-  (shrl (:%l temp))
-  (movl (:@ (:^ :jtab) (:%q x8664::fn) (:%q temp)) (:%l temp))
-  (leaq (:@ (:%q x8664::fn) (:%q temp)) (:%q rjmp))
+  (shrl (:%l reg))
+  (movl (:@ (:^ :jtab) (:%q x8664::fn) (:%q reg)) (:%l reg))
+  (leaq (:@ (:%q x8664::fn) (:%q reg)) (:%q rjmp))
   (jmp (:%q rjmp))
   (:uuo-section)
@@ -4654 +4652 @@
   (:long (:apply 1+ (:apply ash maxval (- x8664::fixnumshift))))
   :jtab)
-
-
+  
 
 (define-x8664-vinsn jtabentry (()

trunk/source/compiler/X86/x86-disassemble.lisp

@@ -2481 +2481 @@
            (let* ((jtab (is-jump-table-ref op0)))
              (if (and jtab (> jtab 0))
-               (let* ((count (x86-ds-u32-ref ds (- jtab 4))))
+               (let* ((count (x86-ds-u32-ref ds (- jtab 4)))
+                      (block (make-x86-dis-block :start-address jtab
+                                                 :end-address (+ jtab (* 4 count))))
+                      (instructions (x86-dis-block-instructions block))
+                      (labeled t))
+                 (setf (x86::x86-memory-operand-disp op0)
+                       (parse-x86-lap-expression `(:^ ,jtab)))
                  (dotimes (i count)
-                   (push (+ (x86-ds-u32-ref ds jtab)
-                            (x86-ds-entry-point ds))
-                         (x86-ds-pending-labels ds))
-                   (incf jtab 4)))
+                   (let* ((target (+ (x86-ds-u32-ref ds jtab)
+                                     (x86-ds-entry-point ds)))
+                          (start (+ jtab (x86-ds-entry-point ds)))
+                          (instruction (make-x86-disassembled-instruction
+                                        :address jtab
+                                        :labeled labeled
+                                        :mnemonic ":long"
+                                        :op0 (parse-x86-lap-expression `(:^ ,target))
+                                        :start start
+                                        :end (+ start 4))))
+                     (append-dll-node instruction instructions)
+                     (setq labeled nil)
+                     (push target (x86-ds-pending-labels ds))
+                     (incf jtab 4)))
+                 (insert-x86-block block (x86-ds-blocks ds)))
                (unless (x86-ds-mode-64 ds)
                  (when (and (is-fn op1)
@@ -2719 +2736 @@
     (format nil "L~d" (- addr entrypoint))))
 
+(defmethod unparse-x86-lap-operand ((op label-x86-lap-expression)
+                                    ds)
+  (unparse-x86-lap-expression op ds))
+
 
 (defmethod x86-lap-operand-constant-offset (op ds)
@@ -2812 +2833 @@
 (defvar *previous-source-note*)
 
-(defun x86-print-di-lap (ds instruction &optional tab-stop)
+(defun x86-print-di-lap (ds instruction tab-stop pc)
   (dolist (p (x86-di-prefixes instruction))
     (when tab-stop
@@ -2829 +2850 @@
         (when op2
           (write-x86-lap-operand t op2 ds)))))
-  (format t ")~%"))
+  (format t ")~vt;~8<[~D]~>" (+ 40 tab-stop) pc)  
+  (format t "~%"))
 
 (defun x86-print-disassembled-instruction (ds instruction seq function)
@@ -2847 +2869 @@
       (format t "~&L~d~%" pc)
       (setq seq 0))
-    (format t "~&~8<[~D]~>" pc)
+    (format t "~&")
     (let* ((istart (x86-di-start instruction))
            (iend (x86-di-end instruction))
@@ -2859 +2881 @@
           (incf byteidx))
         (decf nbytes 4))
-      (x86-print-di-lap ds instruction tab-stop)
+      (x86-print-di-lap ds instruction tab-stop pc)
       (when *disassemble-verbose*
         (while (plusp nbytes)

trunk/source/compiler/X86/x862.lisp

@@ -7308 +7308 @@
         (^)))))
 
-(defparameter *x862-generate-casejump* nil)
+(defparameter *x862-generate-casejump* t)
 
 (defun x862-generate-casejump (seg vreg xfer ranges trueforms var otherwise)
-  (declare (ignorable trueforms var otherwise))
   (when *x862-generate-casejump*
     (with-x86-local-vinsn-macros (seg vreg xfer)
-      (unless (x862-mvpass-p xfer)
-        (when ranges
-          (let* ((min (caar ranges))
-                 (max min)
-                 (count 0)
-                 (all ()))
-            (declare (fixnum min max count))
-            (when                       ; determine min,max, count; punt on duplicate keys
-                (dolist (range ranges t)
-                  (let* ((info (cons (backend-get-next-label) (pop trueforms))))
-                    (unless (dolist (val range t)
-                              (declare (fixnum val))
-                              (when (assoc val all)
-                                (return nil))
-                              (push (cons val info) all)
-                              (if (< val min)
-                                (setq min val)
-                                (if (> val max)
-                                  (setq max val)))
-                              (incf count))
-                      (return nil))))
-              (let* ((span (1+ (- max min))))
-                (declare (fixnum span))
-                (when (and (typep min '(signed-byte 32))
-                           (typep (- max min) 'unsigned-byte 32)
-                           (> count 4)
-                           (> count (the fixnum (- span (the fixnum (ash span -2))))))
-                  (let* ((defaultlabel (backend-get-next-label))
-                         (endlabel (backend-get-next-label))
-                         (reg ($ *x862-arg-z*)))
-                    (x862-use-operator (%nx1-operator lexical-reference)
-                                       seg reg nil var)
-                    (! cjmp reg (ash min *x862-target-fixnum-shift*) (ash (- max min) *x862-target-fixnum-shift*)  (aref *backend-labels* defaultlabel))
-                    (do* ((val min (1+ val)))
-                         ((> val max))
-                      (declare (fixnum val))
-                      (let* ((info (assoc val all)))
-                        (! jtabentry (aref *backend-labels* (if info (cadr info) defaultlabel)))))
-                    (let* ((target (x862-cd-merge xfer endlabel)))
-                      (dolist (case (nreverse all))
-                        (let* ((lab (cadr case))
-                               (form (cddr case)))
-                          (@= lab)
-                          (x862-form seg vreg target form)))
-                      (@= defaultlabel)
-                      (x862-form seg vreg target otherwise)
-                      (@ endlabel)
-                      (when (x862-mvpass-p xfer)
-                        (^))
-                      t)))))))))))
+      (when ranges
+        (let* ((min (caar ranges))
+               (max min)
+               (count 0)
+               (all ()))
+          (declare (fixnum min max count))
+          (when                         ; determine min,max, count; punt on duplicate keys
+              (dolist (range ranges t)
+                (let* ((info (cons (backend-get-next-label) (pop trueforms))))
+                  (unless (dolist (val range t)
+                            (declare (fixnum val))
+                            (when (assoc val all)
+                              (return nil))
+                            (push (cons val info) all)
+                            (if (< val min)
+                              (setq min val)
+                              (if (> val max)
+                                (setq max val)))
+                            (incf count))
+                    (return nil))))
+
+            (let* ((span (1+ (- max min))))
+              (declare (fixnum span))
+              (when (and (typep (ash min *x862-target-fixnum-shift*) '(signed-byte 32))
+                         (typep (ash (- max min) *x862-target-fixnum-shift*) 'unsigned-byte 32)
+                         (> count 4)
+                         (> count (the fixnum (- span (the fixnum (ash span -2))))))
+                (let* ((defaultlabel (backend-get-next-label))
+                       (endlabel (backend-get-next-label))
+                       (reg ($ *x862-imm0*)))
+                  (x862-use-operator (%nx1-operator lexical-reference)
+                                     seg reg nil var)
+                  (! cjmp reg (ash min *x862-target-fixnum-shift*) (ash (- max min) *x862-target-fixnum-shift*)  (aref *backend-labels* defaultlabel))
+                  (do* ((val min (1+ val)))
+                       ((> val max))
+                    (declare (fixnum val))
+                    (let* ((info (assoc val all)))
+                      (! jtabentry (aref *backend-labels* (if info (cadr info) defaultlabel)))))
+                  (let* ((target (if (x862-mvpass-p xfer)
+                                   (logior $backend-mvpass-mask endlabel)
+                                   (x862-cd-merge xfer endlabel)))
+                         (entry-stack (x862-encode-stack)))
+                    (dolist (case (nreverse all))
+                      (let* ((lab (cadr case))
+                             (form (cddr case)))
+                        (@= lab)
+                        (multiple-value-setq (*x862-undo-count*
+                                              *x862-cstack*
+                                              *x862-vstack*
+                                              *x862-top-vstack-lcell*)
+                          (x862-decode-stack entry-stack))
+                        (x862-undo-body seg vreg target form entry-stack)))
+                    (@= defaultlabel)
+                    (x862-form seg vreg target otherwise)
+                    (@ endlabel)
+                    (when (x862-mvpass-p xfer)
+                      (let* ((*x862-returning-values* :pass))
+                        (^)))
+                    t))))))))))
 
 (defx862 x862-if if (seg vreg xfer testform true false &aux test-val)