[Git][cmucl/cmucl][master] 2 commits: Fix #185: Use shorter instructions on x86

[Raymond Toy (@rtoy)]

Raymond Toy pushed to branch master at cmucl / cmucl


Commits:
677c3ccf by Raymond Toy at 2023-04-27T22:55:29+00:00
Fix #185: Use shorter instructions on x86

- - - - -
8826d962 by Raymond Toy at 2023-04-27T22:55:39+00:00
Merge branch 'issue-185-x86-shorter-insts' into 'master'

Fix #185: Use shorter instructions on x86

Closes #185

See merge request cmucl/cmucl!138
- - - - -


1 changed file:

- src/compiler/x86/insts.lisp


Changes:

=====================================
src/compiler/x86/insts.lisp
=====================================
@@ -1254,17 +1254,19 @@
 
 ;;;; Arithmetic
 
+(defun sign-extend (x n)
+  "Sign extend the N-bit number X"
+  (if (logbitp (1- n) x)
+      (logior (ash -1 (1- n)) x)
+      x))
+
 (defun emit-random-arith-inst (name segment dst src opcode
 				    &optional allow-constants)
   (let ((size (matching-operand-size dst src)))
     (maybe-emit-operand-size-prefix segment size)
     (cond
      ((integerp src)
-      (cond ((and (not (eq size :byte)) (<= -128 src 127))
-	     (emit-byte segment #b10000011)
-	     (emit-ea segment dst opcode allow-constants)
-	     (emit-byte segment src))
-	    ((accumulator-p dst)
+      (cond ((accumulator-p dst)
 	     (emit-byte segment
 			(dpb opcode
 			     (byte 3 3)
@@ -1272,6 +1274,10 @@
 				 #b00000100
 				 #b00000101)))
 	     (emit-sized-immediate segment size src))
+	    ((and (not (eq size :byte)) (<= -128 (sign-extend src 32) 127))
+	     (emit-byte segment #b10000011)
+	     (emit-ea segment dst opcode allow-constants)
+	     (emit-byte segment (ldb (byte 8 0) src)))
 	    (t
 	     (emit-byte segment (if (eq size :byte) #b10000000 #b10000001))
 	     (emit-ea segment dst opcode allow-constants)
@@ -1291,12 +1297,24 @@
      (t
       (error "Bogus operands to ~A" name)))))
 
+(defun arith-logical-constant-control (chunk inst stream dstate)
+    (declare (ignore inst stream))
+    (when (= (ldb (byte 8 0) chunk) #b10000011)
+      (let ((imm (sign-extend (ldb (byte 8 16) chunk) 8)))
+	(when (minusp imm)
+	  (disassem:note #'(lambda (stream)
+			     (princ (ldb (byte 32 0) imm) stream))
+			 dstate)))))
+
 (eval-when (compile eval)
-  (defun arith-inst-printer-list (subop)
-    `((accum-imm ((op ,(dpb subop (byte 3 2) #b0000010))))
-      (reg/mem-imm ((op (#b1000000 ,subop))))
+  (defun arith-inst-printer-list (subop &key control)
+    `((accum-imm ((op ,(dpb subop (byte 3 2) #b0000010)))
+		 ,@(when control `(:default :control #',control)))
+      (reg/mem-imm ((op (#b1000000 ,subop)))
+		   ,@(when control `(:default :control #',control)))
       (reg/mem-imm ((op (#b1000001 ,subop))
-		    (imm nil :type signed-imm-byte)))
+		    (imm nil :type signed-imm-byte))
+		   ,@(when control `(:default :control #',control)))
       (reg-reg/mem-dir ((op ,(dpb subop (byte 3 1) #b000000))))))
   )
 
@@ -1602,7 +1620,7 @@
 
 (define-instruction and (segment dst src)
   (:printer-list
-   (arith-inst-printer-list #b100))
+   (arith-inst-printer-list #b100 :control 'arith-logical-constant-control))
   (:emitter
    (emit-random-arith-inst "AND" segment dst src #b100)))
 
@@ -1639,13 +1657,13 @@
 
 (define-instruction or (segment dst src)
   (:printer-list
-   (arith-inst-printer-list #b001))
+   (arith-inst-printer-list #b001 :control 'arith-logical-constant-control))
   (:emitter
    (emit-random-arith-inst "OR" segment dst src #b001)))
 
 (define-instruction xor (segment dst src)
   (:printer-list
-   (arith-inst-printer-list #b110))
+   (arith-inst-printer-list #b110 :control 'arith-logical-constant-control))
   (:emitter
    (emit-random-arith-inst "XOR" segment dst src #b110)))
 



View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/acb29d8f6a3190744a042796038ea92f3e24e96f...8826d962b0a76b7b0d1cfd50d1849fddf97f096d

-- 
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/acb29d8f6a3190744a042796038ea92f3e24e96f...8826d962b0a76b7b0d1cfd50d1849fddf97f096d
You're receiving this email because of your account on gitlab.common-lisp.net.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/cmucl-cvs/attachments/20230427/11c66d61/attachment-0001.html>