Changeset 14998

Timestamp:

Sep 24, 2011, 1:36:16 AM (13 years ago)

Author:

Gary Byers

Message:

Conditionally (using *x862-generate-casejump*, which defaults to false
for now) enable code to do constant-time CASE for certain types/ranges
of keys via a jump table.

Make the X86 disassembler recognize references to labels referenced from
the jump table (though it doesn't yet do anything to show the jump table
itself.)

This is about as far along as the ARM backend has been for the last few
months; the mechanics of dispatching through the jump table seem to be
correct, but the code generated at each case label is only correct in
certain circumstances.

Location:

trunk/source/compiler/X86

Files:

• X8632/x8632-vinsns.lisp (modified) (1 diff)
• x86-disassemble.lisp (modified) (4 diffs)
• x862.lisp (modified) (2 diffs)

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

@@ -4217 +4217 @@
   (movl (:@ (:% x8632::ebp)) (:% x8632::ebp)))
 
+(define-x8632-vinsn (cjmp :branch) (((reg :lisp))
+                                    ((reg :lisp)
+                                     (minval :s32const)
+                                     (maxval :u32const)
+                                     (default :label))
+                                    ((temp :s32)
+                                    (rjmp :lisp)))
+  (testl (:$l x8664::fixnummask) (:%l reg))
+  (jne default)
+  ((:not (:pred zerop minval))
+   (subl (:$l minval) (:%l reg)))
+  (cmpl (:$l maxval) (:%l reg))
+  (ja default)
+  (movl (:%l reg) (:%l temp))
+  (shrl (:%l temp))
+  (movl (:@ (:^ :jtab) (:%l x8632::fn) (:%l temp)) (:%l temp))
+  (leal (:@ (:%l x8632::fn) (:%l temp)) (:%l rjmp))
+  (jmp (:%l rjmp))
+  (:uuo-section)
+  (:align 2)
+  (:long (:apply 1+ (:apply ash maxval (- x8632::fixnumshift))))
+  :jtab)
+
+(define-x8632-vinsn jtabentry (()
+                               ((label :label)))
+  (:uuo-section)
+  (:long (:^ label)))
+
 (queue-fixup
  (fixup-x86-vinsn-templates

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

@@ -139 +139 @@
          (high (x86-ds-next-s32 ds)))
     (logior (ash high 32) low)))
+
+(defun x86-ds-u8-ref (ds idx)
+  (aref (x86-ds-code-vector ds) (+ idx (x86-ds-entry-point ds))))
+
+(defun x86-ds-u16-ref (ds idx)
+  (logior (x86-ds-u8-ref ds idx)
+          (ash (x86-ds-u8-ref ds (1+ idx)) 8)))
+
+(defun x86-ds-u32-ref (ds idx)
+  (logior (x86-ds-u16-ref ds idx)
+          (ash (x86-ds-u16-ref ds (+ idx 2)) 16)))
+
+
 
 (defun used-rex (ds value)
@@ -2411 +2424 @@
                     (let* ((disp (x86::x86-memory-operand-disp thing)))
                       (and disp (early-x86-lap-expression-value disp)))))
+             (is-jump-table-ref (thing)
+               (and (typep thing 'x86::x86-memory-operand)
+                    (is-fn (x86::x86-memory-operand-base thing))
+                    (x86::x86-memory-operand-index thing)
+                    (let* ((scale (x86::x86-memory-operand-scale thing)))
+                      (or (null scale) (eql 0 scale)))
+                    (let* ((disp (x86::x86-memory-operand-disp thing)))
+                      (and disp (early-x86-lap-expression-value disp)))))
              (is-ra0-ea (thing)
                (and (typep thing 'x86::x86-memory-operand)
@@ -2433 +2454 @@
            (let* ((disp ))
              (if (or (and (setq disp (is-fn-ea op0)) (> disp 0))
-                       (and (setq disp (is-ra0-ea op0)) (< disp 0) (is-fn op1)))
+                     (and (setq disp (is-ra0-ea op0)) (< disp 0) (is-fn op1)))
                (let* ((label-ea (+ entry-ea (abs disp))))
                  (when (< label-ea (x86-ds-code-limit ds))
@@ -2458 +2479 @@
                                   (subprimitive-info-name info)))))))
           (t
-           (unless (x86-ds-mode-64 ds)
-             (when (and (is-fn op1)
-                        (typep op0 'x86::x86-immediate-operand)
-                        ;; Not sure what else would have an
-                        ;; immediate source and %fn as destination,
-                        ;; but check for this.
-                        (equal (x86-di-mnemonic instruction) "movl"))
-               (setf (x86-di-mnemonic instruction) "recover-fn"
-                     (x86-di-op0 instruction) nil
-                     (x86-di-op0 instruction) nil))))
+           (let* ((jtab (is-jump-table-ref op0)))
+             (if (and jtab (> jtab 0))
+               (let* ((count (x86-ds-u32-ref ds (- jtab 4))))
+                 (dotimes (i count)
+                   (push (+ (x86-ds-u32-ref ds jtab)
+                            (x86-ds-entry-point ds))
+                         (x86-ds-pending-labels ds))
+                   (incf jtab 4)))
+               (unless (x86-ds-mode-64 ds)
+                 (when (and (is-fn op1)
+                            (typep op0 'x86::x86-immediate-operand)
+                            ;; Not sure what else would have an
+                            ;; immediate source and %fn as destination,
+                            ;; but check for this.
+                            (equal (x86-di-mnemonic instruction) "movl"))
+                   (setf (x86-di-mnemonic instruction) "recover-fn"
+                         (x86-di-op0 instruction) nil
+                         (x86-di-op0 instruction) nil))))))
 
           )))

trunk/source/compiler/X86/x862.lisp

@@ -6141 +6141 @@
                  (:anchored-uuo
                   (expand-form (cadr f))
-                  ;; add a trailing 0 byte after the uu0
+                  ;; add a trailing 0 byte after the uuo
                   (frag-list-push-byte frag-list 0))
                  ((:uuo :uuo-section)
@@ -7307 +7307 @@
         (<- *x862-arg-z*)
         (^)))))
-      
+
+(defparameter *x862-generate-casejump* nil)
+
+(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)))))))))))
 
 (defx862 x862-if if (seg vreg xfer testform true false &aux test-val)
   (if (setq test-val (nx2-constant-form-value (acode-unwrapped-form-value testform)))
     (x862-form seg vreg xfer (if (nx-null test-val) false true))
-    (let* ((cstack *x862-cstack*)
-           (vstack *x862-vstack*)
-           (top-lcell *x862-top-vstack-lcell*)
-           (entry-stack (x862-encode-stack))
-           (true-stack nil)
-           (false-stack nil)
-           (true-cleanup-label nil)
-           (same-stack-effects nil)
-           (true-is-goto (x862-go-label true))
-           (false-is-goto (and (not true-is-goto) (x862-go-label false)))
-           (endlabel (backend-get-next-label))
-           (falselabel (backend-get-next-label))
-           (need-else (unless false-is-goto (or (not (nx-null false)) (x862-for-value-p vreg))))
-           (both-single-valued (and (not *x862-open-code-inline*)
-                                    (eq xfer $backend-return)
-                                    (x862-for-value-p vreg)
-                                    need-else
-                                    (x862-single-valued-form-p true) 
-                                    (x862-single-valued-form-p false))))
-      (if (eq 0 xfer) 
-        (setq xfer nil))
-      (if both-single-valued            ; it's implied that we're returning
-        (let* ((result *x862-arg-z*))
-          (let ((merge-else-branch-label (if (nx-null false) (x862-find-nilret-label))))
-            (x862-conditional-form seg (x862-make-compound-cd 0 falselabel) testform)
-            (x862-form seg result endlabel true)
-            (if (and merge-else-branch-label (neq -1 (aref *backend-labels* merge-else-branch-label)))
-              (backend-copy-label merge-else-branch-label falselabel)
+    (multiple-value-bind (ranges trueforms var otherwise)
+        (nx2-reconstruct-case testform true false)
+      (or (x862-generate-casejump seg vreg xfer ranges trueforms var otherwise)
+          (let* ((cstack *x862-cstack*)
+                 (vstack *x862-vstack*)
+                 (top-lcell *x862-top-vstack-lcell*)
+                 (entry-stack (x862-encode-stack))
+                 (true-stack nil)
+                 (false-stack nil)
+                 (true-cleanup-label nil)
+                 (same-stack-effects nil)
+                 (true-is-goto (x862-go-label true))
+                 (false-is-goto (and (not true-is-goto) (x862-go-label false)))
+                 (endlabel (backend-get-next-label))
+                 (falselabel (backend-get-next-label))
+                 (need-else (unless false-is-goto (or (not (nx-null false)) (x862-for-value-p vreg))))
+                 (both-single-valued (and (not *x862-open-code-inline*)
+                                          (eq xfer $backend-return)
+                                          (x862-for-value-p vreg)
+                                          need-else
+                                          (x862-single-valued-form-p true) 
+                                          (x862-single-valued-form-p false))))
+            (if (eq 0 xfer) 
+              (setq xfer nil))
+            (if both-single-valued      ; it's implied that we're returning
+              (let* ((result *x862-arg-z*))
+                (let ((merge-else-branch-label (if (nx-null false) (x862-find-nilret-label))))
+                  (x862-conditional-form seg (x862-make-compound-cd 0 falselabel) testform)
+                  (x862-form seg result endlabel true)
+                  (if (and merge-else-branch-label (neq -1 (aref *backend-labels* merge-else-branch-label)))
+                    (backend-copy-label merge-else-branch-label falselabel)
+                    (progn
+                      (@ falselabel)
+                      (if (nx-null false) (@ (x862-record-nilret-label)))
+                      (x862-form seg result nil false)))
+                  (@ endlabel)
+                  (<- result)
+                  (^)))
               (progn
-                (@ falselabel)
-                (if (nx-null false) (@ (x862-record-nilret-label)))
-                (x862-form seg result nil false)))
-            (@ endlabel)
-            (<- result)
-            (^)))
-        (progn
-          (if (and need-else (x862-mvpass-p xfer))
-            (setq true-cleanup-label (backend-get-next-label)))         
-          (x862-conditional-form 
-           seg
-           (x862-make-compound-cd 
-            (or true-is-goto 0)
-            (or false-is-goto 
-                (if need-else 
-                  (if true-is-goto 0 falselabel) 
-                  (if true-is-goto xfer (x862-cd-merge xfer falselabel))))) 
-           testform)  
-          (if true-is-goto
-            (x862-unreachable-store)
-            (if true-cleanup-label
-              (progn
-                (x862-open-undo $undomvexpect)
-                (x862-form seg vreg (logior $backend-mvpass-mask true-cleanup-label) true))
-              (x862-form seg vreg (if need-else (x862-cd-merge xfer endlabel) xfer) true)))
-          (setq true-stack (x862-encode-stack))
-          (setq *x862-cstack* cstack)
-          (x862-set-vstack vstack)
-          (setq *x862-top-vstack-lcell* top-lcell)
-          (if false-is-goto (x862-unreachable-store))
-          (let ((merge-else-branch-label (if (and (nx-null false) (eq xfer $backend-return)) (x862-find-nilret-label))))
-            (if (and merge-else-branch-label (neq -1 (aref *backend-labels* merge-else-branch-label)))
-              (backend-copy-label merge-else-branch-label falselabel)
-              (progn
-                (@ falselabel)
-                (when need-else
+                (if (and need-else (x862-mvpass-p xfer))
+                  (setq true-cleanup-label (backend-get-next-label)))         
+                (x862-conditional-form 
+                 seg
+                 (x862-make-compound-cd 
+                  (or true-is-goto 0)
+                  (or false-is-goto 
+                      (if need-else 
+                        (if true-is-goto 0 falselabel) 
+                        (if true-is-goto xfer (x862-cd-merge xfer falselabel))))) 
+                 testform)  
+                (if true-is-goto
+                  (x862-unreachable-store)
                   (if true-cleanup-label
-                    (x862-mvpass seg false)
-                    (x862-form seg vreg xfer false))
-                  (setq false-stack (x862-encode-stack))))))
-          (when true-cleanup-label
-            (if (setq same-stack-effects (x862-equal-encodings-p true-stack false-stack)) ; can share cleanup code
-              (@ true-cleanup-label))
-            (let* ((*x862-returning-values* :pass))
-              (x862-nlexit seg xfer 1)
-              (x862-branch seg (if (and xfer (neq xfer $backend-mvpass-mask)) xfer (if (not same-stack-effects) endlabel))))
-            (unless same-stack-effects
-              (@ true-cleanup-label)
-              (multiple-value-setq (true *x862-cstack* *x862-vstack* *x862-top-vstack-lcell*)
-                (x862-decode-stack true-stack))
-              (let* ((*x862-returning-values* :pass))
-                (x862-nlexit seg xfer 1)
-                (^)))
-            (x862-close-undo)
-            (multiple-value-setq (*x862-undo-count* *x862-cstack* *x862-vstack* *x862-top-vstack-lcell*) 
-              (x862-decode-stack entry-stack)))
-          (@ endlabel))))))
+                    (progn
+                      (x862-open-undo $undomvexpect)
+                      (x862-form seg vreg (logior $backend-mvpass-mask true-cleanup-label) true))
+                    (x862-form seg vreg (if need-else (x862-cd-merge xfer endlabel) xfer) true)))
+                (setq true-stack (x862-encode-stack))
+                (setq *x862-cstack* cstack)
+                (x862-set-vstack vstack)
+                (setq *x862-top-vstack-lcell* top-lcell)
+                (if false-is-goto (x862-unreachable-store))
+                (let ((merge-else-branch-label (if (and (nx-null false) (eq xfer $backend-return)) (x862-find-nilret-label))))
+                  (if (and merge-else-branch-label (neq -1 (aref *backend-labels* merge-else-branch-label)))
+                    (backend-copy-label merge-else-branch-label falselabel)
+                    (progn
+                      (@ falselabel)
+                      (when need-else
+                        (if true-cleanup-label
+                          (x862-mvpass seg false)
+                          (x862-form seg vreg xfer false))
+                        (setq false-stack (x862-encode-stack))))))
+                (when true-cleanup-label
+                  (if (setq same-stack-effects (x862-equal-encodings-p true-stack false-stack)) ; can share cleanup code
+                    (@ true-cleanup-label))
+                  (let* ((*x862-returning-values* :pass))
+                    (x862-nlexit seg xfer 1)
+                    (x862-branch seg (if (and xfer (neq xfer $backend-mvpass-mask)) xfer (if (not same-stack-effects) endlabel))))
+                  (unless same-stack-effects
+                    (@ true-cleanup-label)
+                    (multiple-value-setq (true *x862-cstack* *x862-vstack* *x862-top-vstack-lcell*)
+                      (x862-decode-stack true-stack))
+                    (let* ((*x862-returning-values* :pass))
+                      (x862-nlexit seg xfer 1)
+                      (^)))
+                  (x862-close-undo)
+                  (multiple-value-setq (*x862-undo-count* *x862-cstack* *x862-vstack* *x862-top-vstack-lcell*) 
+                    (x862-decode-stack entry-stack)))
+                (@ endlabel))))))))
 
 (defx862 x862-or or (seg vreg xfer forms)