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/acb29d8f6a3190744a04279... -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/acb29d8f6a3190744a04279... You're receiving this email because of your account on gitlab.common-lisp.net.