common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

x86-64: Create a BOA constructor named EA for instances of EA

Browse source 
And make SIZE an optional argument defaulting to :UNSPECIFIED.

This is step 1 of multiple changes needed to avoid messing up EQness
of register operand TNs, as well as operate on stack TNs in sizes other
than :QWORD.  The problem is that EAs and stack TNs have to be fungible;
and those, as well as registers, must allow operating on sub-words
without need for REG-IN-SIZE causing loss of identity of IR.

To begin with, EAs have to be sizeless, because creating a new EA to
process a byte of some stack TN is harmful to semantics. And sizes larger
than :QWORD were usually wrong anyway. In addition, 36% of our uses of EAs
were for LEA which ignores the source size. Not to mention, CMPXCHG16B
and maybe a few others that should care didn't care.

So most, but not all, EAs have the size removed in this change. The size
is implicit except for instructions that move an immediate value
to memory or perform an ALU op like ADD to memory with an immediate.
The next steps will be to:
* Add mandatory size qualifiers to MOVSX, MOVZX and some other
  instructions that have differently sized source/destination.
* Add optional size qualifiers to operations that could use them,
  such as (INST CMP :BYTE SOME-TN SOME-WIDETAG) etc.

This imparts no functional change despite the massive diff, because opcodes
taking two operands of the same size call MATCHING-OPERAND-SIZE which would
have already been failing had we passed in an EA whose size was unexpected.
Thus, changing any size to :UNSPECIFIED in the EA behaves as before: match
whatever the other operand is. Additionally the change was machine-verified
by the file in tools-for-build which can be used on the 32-bit code too.
This commit is contained in:
Douglas Katzman 2018-08-01 16:56:56 -04:00
parent b4bb8b81ff
commit 58d62c8eea
26 changed files with 638 additions and 639 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

39
src/assembly/x86-64/arith.lisp
View file

@ -31,14 +31,13 @@
(defun !static-fun-addr (name)
#!+immobile-code (make-fixup name :static-call)
#!-immobile-code
(make-ea :qword :disp (+ nil-value (static-fun-offset name))))
#!-immobile-code (ea (+ nil-value (static-fun-offset name))))
(defun !call-static-fun (fun arg-count)
(inst push rbp-tn)
(inst mov rbp-tn rsp-tn)
(inst sub rsp-tn (* n-word-bytes 2))
(inst mov (make-ea :qword :base rsp-tn) rbp-tn)
(inst mov (ea rsp-tn) rbp-tn)
(inst mov rbp-tn rsp-tn)
(inst mov rcx-tn (fixnumize arg-count))
(inst call (!static-fun-addr fun))
@ -48,8 +47,7 @@
(inst push rbp-tn)
(inst mov rbp-tn rsp-tn)
(inst sub rsp-tn n-word-bytes)
(inst push (make-ea :qword :base rbp-tn
:disp (frame-byte-offset return-pc-save-offset)))
(inst push (ea (frame-byte-offset return-pc-save-offset) rbp-tn))
(inst mov rcx-tn (fixnumize arg-count))
(inst jmp (!static-fun-addr fun))))
@ -332,13 +330,16 @@
;; POPCNT = ECX bit 23
(multiple-value-bind (bytes bits) (floor (+ 23 n-fixnum-tag-bits)
n-byte-bits)
;; FIXME: should be
;; (INST TEST :BYTE (STATIC-SYMBOL-VALUE-EA '*BLAH*) CONST)
;; but can't do that until sizes are removed from EAs
;; because STATIC-SYMBOL-VALUE-EA returns a :QWORD ea for now.
(inst test
(make-ea :byte
:disp (+ nil-value
(static-symbol-offset '*cpuid-fn1-ecx*)
(ash symbol-value-slot word-shift)
(- other-pointer-lowtag)
bytes))
(ea (+ nil-value
(static-symbol-offset '*cpuid-fn1-ecx*)
(ash symbol-value-slot word-shift)
(- other-pointer-lowtag)
bytes) nil nil nil :byte)
(ash 1 bits)))
(inst jmp :z slow)
;; Intel's implementation of POPCNT on some models treats it as
@ -389,26 +390,22 @@
(inst cmp x y)
(inst jmp :e done) ; Z condition flag contains the answer
;; check that both have other-pointer-lowtag
(inst lea (reg-in-size rax :dword)
(make-ea :dword :base x :disp (- other-pointer-lowtag)))
(inst lea (reg-in-size rcx :dword)
(make-ea :dword :base y :disp (- other-pointer-lowtag)))
(inst lea (reg-in-size rax :dword) (ea (- other-pointer-lowtag) x))
(inst lea (reg-in-size rcx :dword) (ea (- other-pointer-lowtag) y))
(inst or (reg-in-size rax :dword) (reg-in-size rcx :dword))
(inst test (reg-in-size rax :byte) lowtag-mask)
(inst jmp :ne done)
;; Compare the entire header word, ensuring that if at least one
;; argument is a bignum, then both are.
(inst mov rcx (make-ea :qword :base x :disp (- other-pointer-lowtag)))
(inst cmp rcx (make-ea :qword :base y :disp (- other-pointer-lowtag)))
(inst mov rcx (ea (- other-pointer-lowtag) x))
(inst cmp rcx (ea (- other-pointer-lowtag) y))
(inst jmp :ne done)
(inst shr rcx n-widetag-bits)
;; can you have 0 payload words? probably not, but let's be safe here.
(inst jrcxz done)
loop
(inst mov rax (make-ea :qword :base x :disp (- other-pointer-lowtag)
:index rcx :scale 8))
(inst cmp rax (make-ea :qword :base y :disp (- other-pointer-lowtag)
:index rcx :scale 8))
(inst mov rax (ea (- other-pointer-lowtag) x rcx 8))
(inst cmp rax (ea (- other-pointer-lowtag) y rcx 8))
;; These next 3 instructions are the equivalent of "LOOPNZ LOOP"
;; but had significantly better performance for me, consistent with claims
;; of most optimization guides saying that LOOP was deliberately pessimized

27
src/assembly/x86-64/array.lisp
View file

@ -33,11 +33,8 @@
;; but 'vector' is pinned because it's in a register, so this is ok.
;; If we had a precise GC we'd want to keep start and limit as offsets
;; because we couldn't tie them both to the vector.
(inst lea start (make-ea :qword
:base vector :index start
:scale (ash 1 (- word-shift n-fixnum-tag-bits))
:disp (- (ash vector-data-offset word-shift)
other-pointer-lowtag)))
(inst lea start (ea (- (ash vector-data-offset word-shift) other-pointer-lowtag)
vector start (ash 1 (- word-shift n-fixnum-tag-bits))))
;; REP STOS has a fixed cost that makes it suboptimal below
;; a certain fairly high threshold - about 350 objects in my testing.
(inst cmp count (fixnumize 350))
@ -60,7 +57,7 @@
;; if address ends in 8, we must write 1 word before using MOVDQA
(inst test (reg-in-size start :byte) #b1000)
(inst jmp :z SETUP)
(inst mov (make-ea :qword :base start) item)
(inst mov (ea start) item)
(inst add start n-word-bytes)
(inst sub count (fixnumize 1))
SETUP
@ -78,24 +75,22 @@
;; MOVNTDQ is supposedly faster, but would require a trailing SFENCE
;; which measurably harms performance on a small number of iterations.
UNROLL-LOOP ; Write 4 double-quads = 8 lisp objects
(inst movdqa (make-ea :qword :base start :disp 0) wordpair)
(inst movdqa (make-ea :qword :base start :disp 16) wordpair)
(inst movdqa (make-ea :qword :base start :disp 32) wordpair)
(inst movdqa (make-ea :qword :base start :disp 48) wordpair)
(inst movdqa (ea 0 start) wordpair)
(inst movdqa (ea 16 start) wordpair)
(inst movdqa (ea 32 start) wordpair)
(inst movdqa (ea 48 start) wordpair)
(inst add start (* 8 n-word-bytes))
(inst cmp start count)
(inst jmp :b UNROLL-LOOP)
FINISH
;; Now recompute 'count' as the ending address
(inst lea count (make-ea :qword
:base vector :index end
:scale (ash 1 (- word-shift n-fixnum-tag-bits))
:disp (- (ash vector-data-offset word-shift)
other-pointer-lowtag)))
(inst lea count (ea (- (ash vector-data-offset word-shift) other-pointer-lowtag)
vector
end (ash 1 (- word-shift n-fixnum-tag-bits))))
(inst cmp start count)
(inst jmp :ae DONE)
FINAL-LOOP
(inst mov (make-ea :qword :base start) item)
(inst mov (ea start) item)
(inst add start n-word-bytes)
(inst cmp start count)
(inst jmp :b FINAL-LOOP))

111
src/assembly/x86-64/assem-rtns.lisp
View file

@ -43,16 +43,13 @@
;; As per the calling convention EBX is expected to point at the SP
;; before the stack frame.
(inst lea ebx (make-ea :qword :base rbp-tn
:disp (* sp->fp-offset n-word-bytes)))
(inst lea ebx (ea (* sp->fp-offset n-word-bytes) rbp-tn))
;; Save the count, the return address and restore the frame pointer,
;; because the loop is going to destroy them.
(inst mov edx ecx)
(inst mov eax (make-ea :qword :base rbp-tn
:disp (frame-byte-offset return-pc-save-offset)))
(inst mov rbp-tn (make-ea :qword :base rbp-tn
:disp (frame-byte-offset ocfp-save-offset)))
(inst mov eax (ea (frame-byte-offset return-pc-save-offset) rbp-tn))
(inst mov rbp-tn (ea (frame-byte-offset ocfp-save-offset) rbp-tn))
;; Blit the values down the stack. Note: there might be overlap, so
;; we have to be careful not to clobber values before we've read
;; them. Because the stack builds down, we are copying to a larger
@ -61,19 +58,14 @@
(zeroize loop-index)
LOOP
(inst sub loop-index n-word-bytes)
(inst mov temp
(make-ea :qword :base esi
:index loop-index))
(inst mov
(make-ea :qword :base ebx
:index loop-index)
temp)
(inst mov temp (ea esi loop-index))
(inst mov (ea ebx loop-index) temp)
(inst sub edx (fixnumize 1))
(inst jmp :nz LOOP)
;; Set the stack top to the last result.
(inst lea rsp-tn (make-ea :qword :base ebx :index loop-index))
(inst lea rsp-tn (ea ebx loop-index))
;; Load the register args.
(loadw edx ebx -1)
@ -87,8 +79,7 @@
;; Handle the register arg cases.
ZERO-VALUES
(inst lea ebx (make-ea :qword :base rbp-tn
:disp (* sp->fp-offset n-word-bytes)))
(inst lea ebx (ea (* sp->fp-offset n-word-bytes) rbp-tn))
(inst mov edx nil-value)
(inst mov edi edx)
(inst mov esi edx)
@ -107,8 +98,7 @@
(inst ret)
TWO-VALUES
(inst lea ebx (make-ea :qword :base rbp-tn
:disp (* sp->fp-offset n-word-bytes)))
(inst lea ebx (ea (* sp->fp-offset n-word-bytes) rbp-tn))
(loadw edx esi -1)
(loadw edi esi -2)
(inst mov esi nil-value)
@ -118,8 +108,7 @@
(inst ret)
THREE-VALUES
(inst lea ebx (make-ea :qword :base rbp-tn
:disp (* sp->fp-offset n-word-bytes)))
(inst lea ebx (ea (* sp->fp-offset n-word-bytes) rbp-tn))
(loadw edx esi -1)
(loadw edi esi -2)
(loadw esi esi -3)
@ -166,7 +155,7 @@
;; our way down.
(inst shr ecx n-fixnum-tag-bits)
(inst std) ; count down
(inst lea edi (make-ea :qword :base rbp-tn :disp (frame-byte-offset 0)))
(inst lea edi (ea (frame-byte-offset 0) rbp-tn))
(inst sub esi n-word-bytes)
(inst rep)
(inst movs :qword)
@ -181,7 +170,7 @@
(popw rbp-tn (frame-word-offset ocfp-save-offset))
;; Blow off the stack above the arguments.
(inst lea rsp-tn (make-ea :qword :base edi :disp n-word-bytes))
(inst lea rsp-tn (ea n-word-bytes edi))
;; remaining register args
(inst mov edi edx)
@ -194,10 +183,7 @@
;; And jump into the function.
(if jump-to-the-end
(inst jmp end)
(inst jmp
(make-ea :byte :base eax
:disp (- (* closure-fun-slot n-word-bytes)
fun-pointer-lowtag))))
(inst jmp (ea (- (* closure-fun-slot n-word-bytes) fun-pointer-lowtag) eax)))
;; All the arguments fit in registers, so load them.
REGISTER-ARGS
@ -206,8 +192,7 @@
(loadw esi esi -3)
;; Clear most of the stack.
(inst lea rsp-tn
(make-ea :qword :base rbp-tn :disp (* (- sp->fp-offset 3) n-word-bytes)))
(inst lea rsp-tn (ea (* (- sp->fp-offset 3) n-word-bytes) rbp-tn))
;; Push the return-pc so it looks like we just called.
(pushw rbp-tn (frame-word-offset return-pc-save-offset))
@ -225,9 +210,7 @@
(:temp esi unsigned-reg rsi-offset))
(!prepare-for-tail-call-variable eax ebx ecx edx edi esi)
(inst jmp (make-ea :byte :base eax
:disp (- (* closure-fun-slot n-word-bytes)
fun-pointer-lowtag))))
(inst jmp (ea (- (* closure-fun-slot n-word-bytes) fun-pointer-lowtag) eax)))
#+sb-assembling
(define-assembly-routine
@ -246,9 +229,7 @@
(%lea-for-lowtag-test ebx-tn fun fun-pointer-lowtag)
(inst test bl-tn lowtag-mask)
(inst jmp :nz (make-fixup 'tail-call-symbol :assembly-routine))
(inst jmp (make-ea :byte :base eax
:disp (- (* closure-fun-slot n-word-bytes)
fun-pointer-lowtag))))
(inst jmp (ea (- (* closure-fun-slot n-word-bytes) fun-pointer-lowtag) eax)))
#+sb-assembling
(define-assembly-routine (call-symbol
@ -258,39 +239,31 @@
(:temp length (any-reg descriptor-reg) rax-offset)
(:temp vector (any-reg descriptor-reg) rbx-offset))
;; Jump over CALL QWORD PTR [RAX-3] in the caller
(inst add (make-ea :qword :base rsp-tn) 3)
(inst add (ea 0 rsp-tn nil nil :qword) 3)
(emit-alignment n-lowtag-bits :long-nop)
TAIL-CALL-SYMBOL
(%lea-for-lowtag-test vector fun other-pointer-lowtag)
(inst test (reg-in-size vector :byte) lowtag-mask)
(inst jmp :nz not-callable)
(inst cmp (make-ea :byte :base fun :disp (- other-pointer-lowtag))
symbol-widetag)
(inst cmp (ea (- other-pointer-lowtag) fun nil nil :byte) symbol-widetag)
(inst jmp :ne not-callable)
(load-symbol-info-vector vector fun r11-tn)
;; info-vector-fdefn
(inst cmp vector nil-value)
(inst jmp :e undefined)
(inst mov r10d-tn (make-ea :dword :base vector
:disp (- (* 2 n-word-bytes) other-pointer-lowtag)))
(inst mov r10d-tn (ea (- (* 2 n-word-bytes) other-pointer-lowtag) vector))
(inst and r10d-tn (fixnumize (1- (ash 1 (* info-number-bits 2)))))
(inst cmp r10d-tn (fixnumize (1+ (ash +fdefn-info-num+ info-number-bits))))
(inst jmp :b undefined)
(loadw length vector 1 other-pointer-lowtag)
(inst mov fun (make-ea :qword :base vector
:index length
:scale 4
:disp
(- 8 other-pointer-lowtag)))
(inst mov fun (ea (- 8 other-pointer-lowtag) vector length 4))
(let ((fdefn-raw-addr
(make-ea :qword :base fun
:disp (- (* fdefn-raw-addr-slot
n-word-bytes)
other-pointer-lowtag))))
(ea (- (* fdefn-raw-addr-slot n-word-bytes) other-pointer-lowtag)
fun)))
#!+immobile-code
(progn
(inst lea vector fdefn-raw-addr)
@ -303,7 +276,7 @@
(inst cmp fun nil-value) ;; NIL doesn't have SYMBOL-WIDETAG
(inst jmp :e undefined)
(inst pop (make-ea :qword :base rbp-tn :disp n-word-bytes))
(inst pop (ea n-word-bytes rbp-tn))
(emit-error-break nil error-trap (error-number-or-lose 'sb!kernel::object-not-callable-error)
(list fun)))
@ -389,8 +362,7 @@
;; be saved on the stack: the block in edx-tn, start in ebx-tn, and
;; count in ecx-tn.
(inst jmp (make-ea :byte :base block
:disp (* unwind-block-entry-pc-slot n-word-bytes))))
(inst jmp (ea (* unwind-block-entry-pc-slot n-word-bytes) block)))
;;; Perform a store to code, updating the GC page (card) protection bits.
;;; This is not a "good" implementation of soft card marking.
@ -420,14 +392,12 @@
;; because there's no way to get back into C code anyhow.
#!+sb-dynamic-core
(progn
(inst mov thread-base-tn
(make-ea :qword :disp (make-fixup "all_threads" :foreign-dataref)))
(inst mov thread-base-tn (make-ea :qword :base thread-base-tn)))
(inst mov thread-base-tn (ea (make-fixup "all_threads" :foreign-dataref)))
(inst mov thread-base-tn (ea thread-base-tn)))
#!-sb-dynamic-core
(inst mov thread-base-tn
(make-ea :qword :disp (make-fixup "all_threads" :foreign))))
(inst mov thread-base-tn (ea (make-fixup "all_threads" :foreign))))
(inst mov temp-reg-tn (make-ea :qword :base rsp-tn :disp 24))
(inst mov temp-reg-tn (ea 24 rsp-tn))
(inst sub temp-reg-tn (thread-slot-ea thread-varyobj-space-addr-slot))
(inst shr temp-reg-tn (1- (integer-length immobile-card-bytes)))
(pseudo-atomic
@ -435,11 +405,11 @@
(inst cmp temp-reg-tn (thread-slot-ea thread-varyobj-card-count-slot))
(inst jmp :ae try-dynamic-space)
(inst mov rdi-tn (thread-slot-ea thread-varyobj-card-marks-slot))
(inst bts (make-ea :qword :base rdi-tn) temp-reg-tn :lock)
(inst bts (ea rdi-tn) temp-reg-tn :lock)
(inst jmp store)
TRY-DYNAMIC-SPACE
(inst mov temp-reg-tn (make-ea :qword :base rsp-tn :disp 24)) ; reload
(inst mov temp-reg-tn (ea 24 rsp-tn)) ; reload
(inst sub temp-reg-tn (thread-slot-ea thread-dynspace-addr-slot))
(inst shr temp-reg-tn (1- (integer-length gencgc-card-bytes)))
(inst cmp temp-reg-tn (thread-slot-ea thread-dynspace-card-count-slot))
@ -453,28 +423,23 @@
(inst shl temp-reg-tn 3) ; multiply by 8
(inst add temp-reg-tn (thread-slot-ea thread-dynspace-pte-base-slot))
;; clear WP - bit index 5 of flags byte
(inst and (make-ea :byte :base temp-reg-tn :disp 6) (lognot (ash 1 5))
:lock))
(inst and (ea 6 temp-reg-tn nil nil :byte) (lognot (ash 1 5)) :lock))
(t
(inst lea temp-reg-tn ; multiply by 3
(make-ea :qword :base temp-reg-tn :index temp-reg-tn :scale 2))
(inst lea temp-reg-tn (ea temp-reg-tn temp-reg-tn 2)) ; multiply by 3
(inst shl temp-reg-tn 2) ; then by 4, = 12
(inst add temp-reg-tn (thread-slot-ea thread-dynspace-pte-base-slot))
;; clear WP
(inst and (make-ea :byte :base temp-reg-tn :disp 8) (lognot (ash 1 5))
:lock)))
(inst and (ea 8 temp-reg-tn nil nil :byte) (lognot (ash 1 5)) :lock)))
STORE
(inst mov rdi-tn (make-ea :qword :base rsp-tn :disp 24)) ; object
(inst mov temp-reg-tn (make-ea :qword :base rsp-tn :disp 32)) ; word index
(inst mov rax-tn (make-ea :qword :base rsp-tn :disp 40)) ; newval
(inst mov rdi-tn (ea 24 rsp-tn)) ; object
(inst mov temp-reg-tn (ea 32 rsp-tn)) ; word index
(inst mov rax-tn (ea 40 rsp-tn)) ; newval
;; set 'written' flag in the code header
(inst or (make-ea :byte :base rdi-tn :disp (- 3 other-pointer-lowtag))
#x40 :lock)
(inst or (ea (- 3 other-pointer-lowtag) rdi-tn nil nil :byte) #x40 :lock)
;; store newval into object
(inst mov (make-ea :qword :base rdi-tn
:index temp-reg-tn :scale (ash 1 word-shift)
:disp (- other-pointer-lowtag)) rax-tn)))
(inst mov (ea (- other-pointer-lowtag) rdi-tn temp-reg-tn n-word-bytes)
rax-tn)))
(inst pop rdi-tn) ; restore
(inst pop rax-tn)
(inst ret 24)) ; remove 3 stack args

2
src/assembly/x86-64/support.lisp
View file

@ -15,7 +15,7 @@
(cond ((sb!c::code-immobile-p vop)
(make-fixup routine :assembly-routine))
(t
(make-ea :qword :disp (make-fixup routine :assembly-routine*))))))
(ea (make-fixup routine :assembly-routine*))))))
(ecase inst
(jmp (inst jmp fixup))
(call (inst call fixup)))))

35
src/assembly/x86-64/tramps.lisp
View file

@ -36,8 +36,8 @@
float12-tn float13-tn float14-tn float15-tn)
collect
(if (eql op 'pop)
`(inst movaps ,float (make-ea :qword :base rsp-tn :disp ,i))
`(inst movaps (make-ea :qword :base rsp-tn :disp ,i) ,float))))))
`(inst movaps ,float (ea ,i rsp-tn))
`(inst movaps (ea ,i rsp-tn) ,float))))))
(inst cld)
(inst push rbp-tn)
(inst mov rbp-tn rsp-tn)
@ -56,23 +56,23 @@
(inst ret ,stack-delta)))))
(def (alloc-tramp "alloc" progn)
((inst mov rdi-tn (make-ea :qword :base rbp-tn :disp 16))) ; arg
((inst mov (make-ea :qword :base rbp-tn :disp 16) rax-tn))) ; result
((inst mov rdi-tn (ea 16 rbp-tn))) ; arg
((inst mov (ea 16 rbp-tn) rax-tn))) ; result
(def (alloc-tramp-r11 "alloc" progn
:do-not-preserve (r11-tn)
:stack-delta 8) ;; remove the size parameter
((inst mov rdi-tn (make-ea :qword :base rbp-tn :disp 16))) ; arg
((inst mov rdi-tn (ea 16 rbp-tn))) ; arg
((inst mov r11-tn rax-tn))) ; result
;; These routines are for the deterministic allocation profiler.
;; The C support routine's argument is the return PC
(def (enable-alloc-counter "allocation_tracker_counted" pseudo-atomic)
((inst lea rdi-tn (make-ea :qword :base rbp-tn :disp 8))) ; arg
((inst lea rdi-tn (ea 8 rbp-tn))) ; arg
()) ; result
(def (enable-sized-alloc-counter "allocation_tracker_sized" pseudo-atomic)
((inst lea rdi-tn (make-ea :qword :base rbp-tn :disp 8))) ; arg
((inst lea rdi-tn (ea 8 rbp-tn))) ; arg
())) ; result
(define-assembly-routine
@ -91,13 +91,10 @@
(+ 5 (ash fdefn-raw-addr-slot word-shift) (- other-pointer-lowtag))))
#!+immobile-code
UNDEFINED-TRAMP
(inst pop (make-ea :qword :base rbp-tn :disp n-word-bytes))
(inst pop (ea n-word-bytes rbp-tn))
(emit-error-break nil cerror-trap (error-number-or-lose 'undefined-fun-error) (list rax))
(inst push (make-ea :qword :base rbp-tn :disp n-word-bytes))
(inst jmp
(make-ea :qword :base rax
:disp (- (* closure-fun-slot n-word-bytes)
fun-pointer-lowtag))))
(inst push (ea n-word-bytes rbp-tn))
(inst jmp (ea (- (* closure-fun-slot n-word-bytes) fun-pointer-lowtag) rax)))
#!-sb-dynamic-core
(define-assembly-routine
@ -119,20 +116,20 @@
(inst push rax-tn) ; save registers in case we want to see the old values
(inst push rbx-tn)
;; load RAX with the PC after the call site
(inst mov rax-tn (make-ea :qword :base rsp-tn :disp 16))
(inst mov rax-tn (ea 16 rsp-tn))
;; load RBX with the signed 32-bit immediate from the call instruction
(inst movsx rbx-tn (make-ea :dword :base rax-tn :disp -4))
(inst movsx rbx-tn (ea -4 rax-tn nil nil :dword))
;; if at [PC-5] we see #x25 then it was a call with 32-bit mem addr
;; if ... #xE8 then ... 32-bit offset
(inst cmp (make-ea :byte :base rax-tn :disp -5) #x25)
(inst cmp (ea -5 rax-tn nil nil :byte) #x25)
(inst jmp :e ABSOLUTE)
(inst cmp (make-ea :byte :base rax-tn :disp -5) #xE8)
(inst cmp (ea -5 rax-tn nil nil :byte) #xE8)
(inst jmp :e RELATIVE)
;; failing those, assume RBX was valid. ("can't happen")
(inst mov rbx-tn (make-ea :qword :base rsp-tn)) ; restore pushed value of RBX
(inst mov rbx-tn (ea rsp-tn)) ; restore pushed value of RBX
(inst jmp trap)
ABSOLUTE
(inst lea rbx-tn (make-ea :qword :base rbx-tn :disp -8))
(inst lea rbx-tn (ea -8 rbx-tn))
(inst jmp TRAP)
RELATIVE
(inst add rbx-tn rax-tn)

81
src/compiler/x86-64/alloc.lisp
View file

@ -28,7 +28,7 @@
;; - The real issue is that it's not obvious that the stack is
;; 16-byte-aligned at *all* times. Maybe it is, maybe it isn't.
(inst and rsp-tn #.(lognot lowtag-mask))
(inst lea alloc-tn (make-ea :byte :base rsp-tn :disp lowtag))
(inst lea alloc-tn (ea lowtag rsp-tn))
(values))
(defun %alloc-tramp (node result-tn size lowtag)
@ -56,8 +56,7 @@
(when (policy node (> sb!c::instrument-consing 1))
(let ((skip-instrumentation (gen-label)))
(inst mov temp-reg-tn
(make-ea :qword :base thread-base-tn
:disp (* n-word-bytes thread-profile-data-slot)))
(ea (* n-word-bytes thread-profile-data-slot) thread-base-tn))
(inst test temp-reg-tn temp-reg-tn)
;; This instruction is modified to "JMP :z" when profiling is
;; partially enabled. After the buffer is assigned, it becomes
@ -75,9 +74,7 @@
(inst call (make-fixup helper :assembly-routine)) ; 5 bytes
(emit-alignment 3 :long-nop))
(t
(inst call ; 7 bytes
(make-ea :qword :disp
(make-fixup helper :assembly-routine*)))
(inst call (ea (make-fixup helper :assembly-routine*))) ; 7 bytes
(inst nop))) ; align
(unless (integerp size)
;; This TEST instruction is never executed- it informs the profiler
@ -113,13 +110,11 @@
;; thread->alloc_region.free_pointer
(free-pointer
#!+sb-thread (thread-slot-ea thread-alloc-region-slot)
#!-sb-thread
(make-ea :qword :disp (make-fixup "gc_alloc_region" :foreign)))
#!-sb-thread (ea (make-fixup "gc_alloc_region" :foreign)))
;; thread->alloc_region.end_addr
(end-addr
#!+sb-thread (thread-slot-ea (1+ thread-alloc-region-slot))
#!-sb-thread
(make-ea :qword :disp (make-fixup "gc_alloc_region" :foreign 8))))
#!-sb-thread (ea (make-fixup "gc_alloc_region" :foreign 8))))
(cond ((or in-elsewhere
;; large objects will never be made in a per-thread region
@ -129,17 +124,17 @@
(t
(inst mov temp-reg-tn free-pointer)
(cond ((integerp size)
(inst lea alloc-tn (make-ea :qword :base temp-reg-tn :disp size)))
(inst lea alloc-tn (ea size temp-reg-tn)))
((location= alloc-tn size)
(inst add alloc-tn temp-reg-tn))
(t
(inst lea alloc-tn (make-ea :qword :base temp-reg-tn :index size))))
(inst lea alloc-tn (ea temp-reg-tn size))))
(inst cmp alloc-tn end-addr)
(inst jmp :a NOT-INLINE)
(inst mov free-pointer alloc-tn)
(emit-label DONE)
(if lowtag
(inst lea alloc-tn (make-ea :byte :base temp-reg-tn :disp lowtag))
(inst lea alloc-tn (ea lowtag temp-reg-tn))
(inst mov alloc-tn temp-reg-tn))
(assemble (:elsewhere)
(emit-label NOT-INLINE)
@ -230,8 +225,8 @@
(defun storew* (word object slot lowtag zeroed)
(if (or (not zeroed) (not (typep word '(signed-byte 32))))
(storew word object slot lowtag) ; Possibly use temp-reg-tn
(inst mov
(make-ea (cond ((typep word '(unsigned-byte 8)) :byte)
(let ((size
(cond ((typep word '(unsigned-byte 8)) :byte)
((and (not (logtest word #xff))
(typep (ash word -8) '(unsigned-byte 8)))
;; Array lengths 128 to 16384 which are multiples of 128
@ -246,10 +241,8 @@
:byte)
((typep word '(unsigned-byte 16)) :word)
;; Definitely a (signed-byte 32) due to pre-test.
(t :dword))
:base object
:disp (- (* slot n-word-bytes) lowtag))
word)))
(t :dword))))
(inst mov (ea (- (* slot n-word-bytes) lowtag) object nil nil size) word))))
;;; ALLOCATE-VECTOR
(macrolet ((calc-size-in-bytes (n-words result-tn)
@ -257,10 +250,8 @@
(pad-data-block (+ (tn-value ,n-words) vector-data-offset)))
(t
(inst lea ,result-tn
(make-ea :byte :index ,n-words
:scale (ash 1 (- word-shift n-fixnum-tag-bits))
:disp (+ lowtag-mask
(* vector-data-offset n-word-bytes))))
(ea (+ lowtag-mask (* vector-data-offset n-word-bytes))
nil ,n-words (ash 1 (- word-shift n-fixnum-tag-bits))))
(inst and ,result-tn (lognot lowtag-mask))
,result-tn)))
(put-header (vector-tn type length zeroed)
@ -328,8 +319,7 @@
(inst mov rcx (+ (tn-value words) vector-data-offset)))
(t
(inst lea rcx
(make-ea :qword :base words
:disp (ash vector-data-offset n-fixnum-tag-bits)))
(ea (ash vector-data-offset n-fixnum-tag-bits) words))
(if (= n-fixnum-tag-bits 1)
(setq rax (reg-in-size rax :dword)) ; don't bother shifting rcx
(inst shr rcx n-fixnum-tag-bits))))
@ -341,12 +331,11 @@
(when words-savep
(inst mov words result) ; restore 'words'
(inst lea result ; recompute the tagged pointer
(make-ea :byte :base rsp-tn :disp other-pointer-lowtag)))))
(ea other-pointer-lowtag rsp-tn)))))
(unless (sb!c::vector-initialized-p node)
(let ((data-addr
(make-ea :qword :base result
:disp (- (* vector-data-offset n-word-bytes)
other-pointer-lowtag))))
(ea (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
result nil nil :qword)))
(block zero-fill
(cond ((sc-is words immediate)
(let ((n (tn-value words)))
@ -361,9 +350,9 @@
(dotimes (i double)
(inst movapd data-addr zero)
(setf data-addr
(make-ea :qword :base (ea-base data-addr)
:disp (+ (ea-disp data-addr)
(* n-word-bytes 2)))))
(ea (+ (ea-disp data-addr) (* n-word-bytes 2))
(ea-base data-addr)
nil nil :qword)))
(unless (zerop single)
(inst movaps data-addr zero))
(return-from zero-fill))))))
@ -385,9 +374,8 @@
(inst test ,length ,length)
(inst jmp :z done)
(inst lea ,answer
(make-ea :byte :base nil :index ,length
:scale (ash 1 (1+ (- word-shift
n-fixnum-tag-bits)))))
(ea nil ,length
(ash 1 (1+ (- word-shift n-fixnum-tag-bits)))))
,answer)))
(compute-end ()
`(let ((size (cond ((or (not (fixnump size))
@ -397,9 +385,8 @@
(inst mov limit size)
limit))))
(inst lea limit
(make-ea :qword :base result
:index (if (fixnump size) nil size)
:disp (if (fixnump size) size 0))))))
(ea (if (fixnump size) size 0) result
(if (fixnump size) nil size))))))
(define-vop (allocate-list-on-stack)
(:args (length :scs (any-reg immediate))
@ -528,7 +515,7 @@
(:generator 1
(let ((tramp (make-fixup 'funcallable-instance-tramp :assembly-routine)))
(if (sb!c::code-immobile-p vop)
(inst lea result (make-ea :qword :base rip-tn :disp tramp))
(inst lea result (ea tramp rip-tn))
(inst mov result tramp)))))
(define-vop (fixed-alloc)
@ -552,10 +539,10 @@
;; filled in when the layout is stored. Can't use STOREW* though,
;; because it tries to store as few bytes as possible,
;; where this instruction must write exactly 4 bytes.
(inst mov (make-ea :dword :base result :disp (- lowtag)) header)
(inst mov (ea (- lowtag) result nil nil :dword) header)
(storew* header result 0 lowtag (not stack-allocate-p)))
(unless (eq type widetag) ; TYPE is actually a LAYOUT
(inst mov (make-ea :dword :base result :disp (+ 4 (- lowtag)))
(inst mov (ea (+ 4 (- lowtag)) result nil nil :dword)
;; XXX: should layout fixups use a name, not a layout object?
(make-fixup type :layout)))))))))
@ -585,14 +572,12 @@
(values (reg-in-size bytes :dword)
(reg-in-size header :dword)))
(inst lea bytes
(make-ea :byte
:disp (* (1+ words) n-word-bytes) :index extra
:scale (ash 1 (- word-shift n-fixnum-tag-bits))))
(ea (* (1+ words) n-word-bytes) nil
extra (ash 1 (- word-shift n-fixnum-tag-bits))))
(inst mov header bytes)
(inst shl header (- n-widetag-bits word-shift)) ; w+1 to length field
(inst lea header ; (w-1 << 8) | type
(make-ea :byte :base header
:disp (+ (ash -2 n-widetag-bits) type)))
(ea (+ (ash -2 n-widetag-bits) type) header))
(inst and bytes (lognot lowtag-mask)))
(instrument-alloc bytes node)
(pseudo-atomic
@ -621,11 +606,11 @@
(inst and rsp-tn -16)
(pseudo-atomic
(c-call "alloc_fixedobj")
(inst lea result (make-ea :qword :base c-result :disp lowtag))
(inst lea result (ea lowtag c-result))
;; If code, the next word must be set within the P-A
;; otherwise the GC would compute the wrong object size.
(when word1
(inst mov (make-ea :qword :base result :disp (- n-word-bytes lowtag)) word1)))))
(inst mov (ea (- n-word-bytes lowtag) result nil nil :qword) word1)))))
(define-vop (alloc-immobile-layout)
(:args (slots :scs (descriptor-reg) :target c-arg1))
(:temporary (:sc unsigned-reg :from (:argument 0) :to :eval :offset rdi-offset)

65
src/compiler/x86-64/arith.lisp
View file

@ -174,7 +174,7 @@
,@(and (eq op 'sub)
`(((and (not (location= r x))
(typep (- (fixnumize y)) '(signed-byte 32)))
(inst lea r (make-ea :qword :base x :disp (- (fixnumize y)))))))
(inst lea r (ea (- (fixnumize y)) x)))))
(t
(move r x)
(inst ,op r (constantize (fixnumize y)))))))))
@ -192,7 +192,7 @@
,@(and (eq op 'sub)
`(((and (not (location= r x))
(typep (- y) '(signed-byte 32)))
(inst lea r (make-ea :qword :base x :disp (- y))))))
(inst lea r (ea (- y) x)))))
(t
(move r x)
(inst ,op r (constantize y))))))))
@ -214,7 +214,7 @@
,@(and (eq op 'sub)
`(((and (not (location= r x))
(typep (- y) '(signed-byte 32)))
(inst lea r (make-ea :qword :base x :disp (- y))))))
(inst lea r (ea (- y) x)))))
(t
(move r x)
(inst ,op r (constantize y)))))))))))
@ -298,7 +298,7 @@
(:generator 2
(cond ((and (sc-is x any-reg) (sc-is y any-reg) (sc-is r any-reg)
(not (location= x r)))
(inst lea r (make-ea :qword :base x :index y)))
(inst lea r (ea x y)))
(t
(move r x)
(inst add r y)))))
@ -315,7 +315,7 @@
(let ((y (fixnumize y)))
(cond ((and (not (location= x r))
(typep y '(signed-byte 32)))
(inst lea r (make-ea :qword :base x :disp y)))
(inst lea r (ea y x)))
(t
(move r x)
(inst add r (constantize y)))))))
@ -338,7 +338,7 @@
(:generator 5
(cond ((and (sc-is x signed-reg) (sc-is y signed-reg) (sc-is r signed-reg)
(not (location= x r)))
(inst lea r (make-ea :qword :base x :index y)))
(inst lea r (ea x y)))
(t
(move r x)
(inst add r y)))))
@ -390,7 +390,7 @@
(cond ((and (sc-is x signed-reg) (sc-is r signed-reg)
(not (location= x r))
(typep y '(signed-byte 32)))
(inst lea r (make-ea :qword :base x :disp y)))
(inst lea r (ea y x)))
(t
(move r x)
(cond ((= y 1)
@ -417,7 +417,7 @@
(:generator 5
(cond ((and (sc-is x unsigned-reg) (sc-is y unsigned-reg)
(sc-is r unsigned-reg) (not (location= x r)))
(inst lea r (make-ea :qword :base x :index y)))
(inst lea r (ea x y)))
(t
(move r x)
(inst add r y)))))
@ -438,7 +438,7 @@
(cond ((and (sc-is x unsigned-reg) (sc-is r unsigned-reg)
(not (location= x r))
(typep y '(unsigned-byte 31)))
(inst lea r (make-ea :qword :base x :disp y)))
(inst lea r (ea y x)))
(t
(move r x)
(cond ((= y 1)
@ -579,9 +579,8 @@
(if (location= quo eax)
(inst shl eax n-fixnum-tag-bits)
(if (= n-fixnum-tag-bits 1)
(inst lea quo (make-ea :qword :base eax :index eax))
(inst lea quo (make-ea :qword :index eax
:scale (ash 1 n-fixnum-tag-bits)))))
(inst lea quo (ea eax eax))
(inst lea quo (ea nil eax (ash 1 n-fixnum-tag-bits)))))
(move rem edx)))
(define-vop (fast-truncate-c/fixnum=>fixnum fast-safe-arith-op)
@ -608,9 +607,8 @@
(if (location= quo eax)
(inst shl eax n-fixnum-tag-bits)
(if (= n-fixnum-tag-bits 1)
(inst lea quo (make-ea :qword :base eax :index eax))
(inst lea quo (make-ea :qword :index eax
:scale (ash 1 n-fixnum-tag-bits)))))
(inst lea quo (ea eax eax))
(inst lea quo (ea nil eax (ash 1 n-fixnum-tag-bits)))))
(move rem edx)))
(define-vop (fast-truncate/unsigned=>unsigned fast-safe-arith-op)
@ -737,11 +735,11 @@
(:variant-vars modularp)
(:generator 2
(cond ((and (= amount 1) (not (location= number result)))
(inst lea result (make-ea :qword :base number :index number)))
(inst lea result (ea number number)))
((and (= amount 2) (not (location= number result)))
(inst lea result (make-ea :qword :index number :scale 4)))
(inst lea result (ea nil number 4)))
((and (= amount 3) (not (location= number result)))
(inst lea result (make-ea :qword :index number :scale 8)))
(inst lea result (ea nil number 8)))
(t
(move result number)
(cond ((< -64 amount 64)
@ -803,11 +801,11 @@ constant shift greater than word length")))
(:note "inline ASH")
(:generator 3
(cond ((and (= amount 1) (not (location= number result)))
(inst lea result (make-ea :qword :base number :index number)))
(inst lea result (ea number number)))
((and (= amount 2) (not (location= number result)))
(inst lea result (make-ea :qword :index number :scale 4)))
(inst lea result (ea nil number 4)))
((and (= amount 3) (not (location= number result)))
(inst lea result (make-ea :qword :index number :scale 8)))
(inst lea result (ea nil number 8)))
(t
(move result number)
(cond ((plusp amount) (inst shl result amount))
@ -830,11 +828,11 @@ constant shift greater than word length")))
(:note "inline ASH")
(:generator 3
(cond ((and (= amount 1) (not (location= number result)))
(inst lea result (make-ea :qword :base number :index number)))
(inst lea result (ea number number)))
((and (= amount 2) (not (location= number result)))
(inst lea result (make-ea :qword :index number :scale 4)))
(inst lea result (ea nil number 4)))
((and (= amount 3) (not (location= number result)))
(inst lea result (make-ea :qword :index number :scale 8)))
(inst lea result (ea nil number 8)))
(t
(move result number)
(cond ((< -64 amount 64) ;; XXXX
@ -997,6 +995,7 @@ constant shift greater than word length")))
integer
(foldable flushable movable))
;;; FIXME: arg order should be (DISP BASE INDEX SCALE) to match EA constructor
(defun %lea (base index scale disp)
(+ base (* index scale) disp))
@ -1014,8 +1013,7 @@ constant shift greater than word length")))
(:results (r :scs (unsigned-reg)))
(:result-types unsigned-num)
(:generator 5
(inst lea r (make-ea :qword :base base :index index
:scale scale :disp disp))))
(inst lea r (ea disp base index scale))))
(define-vop (%lea/signed=>signed)
(:translate %lea)
@ -1029,8 +1027,7 @@ constant shift greater than word length")))
(:results (r :scs (signed-reg)))
(:result-types signed-num)
(:generator 4
(inst lea r (make-ea :qword :base base :index index
:scale scale :disp disp))))
(inst lea r (ea disp base index scale))))
(define-vop (%lea/fixnum=>fixnum)
(:translate %lea)
@ -1044,8 +1041,7 @@ constant shift greater than word length")))
(:results (r :scs (any-reg)))
(:result-types tagged-num)
(:generator 3
(inst lea r (make-ea :qword :base base :index index
:scale scale :disp disp))))
(inst lea r (ea disp base index scale))))
;;; FIXME: before making knowledge of this too public, it needs to be
;;; fixed so that it's actually _faster_ than the non-CMOV version; at
@ -1297,7 +1293,7 @@ constant shift greater than word length")))
(let ((disp (frame-byte-offset (tn-offset x))))
(when reducible-to-byte-p
(setq size :byte disp (1+ disp) y (ash y -8)))
(setq x (make-ea size :base rbp-tn :disp disp))))
(setq x (ea disp rbp-tn nil nil size))))
(t
(aver (gpr-p x))
(if (and reducible-to-byte-p (<= (tn-offset x) 6)) ; 0, 2, 4, 6
@ -2055,10 +2051,9 @@ constant shift greater than word length")))
(ecase width
(64 (loadw r x bignum-digits-offset other-pointer-lowtag))
((32 16 8)
(inst movsx r (make-ea (bits->size width)
:base x
:disp (- (* bignum-digits-offset n-word-bytes)
other-pointer-lowtag))))))
(inst movsx r (ea (- (* bignum-digits-offset n-word-bytes)
other-pointer-lowtag)
x nil nil (bits->size width))))))
(t
(loadw r x bignum-digits-offset other-pointer-lowtag)
(let ((delta (- n-word-bits width)))

158
src/compiler/x86-64/array.lisp
View file

@ -29,14 +29,10 @@
(:results (result :scs (descriptor-reg) :from :eval))
(:node-var node)
(:generator 13
(inst lea bytes
(make-ea :qword
:index rank :scale (ash 1 (- word-shift n-fixnum-tag-bits))
:disp (+ (* array-dimensions-offset n-word-bytes)
lowtag-mask)))
(inst lea bytes (ea (+ (* array-dimensions-offset n-word-bytes) lowtag-mask)
nil rank (ash 1 (- word-shift n-fixnum-tag-bits))))
(inst and bytes (lognot lowtag-mask))
(inst lea header (make-ea :qword :base rank
:disp (fixnumize (1- array-dimensions-offset))))
(inst lea header (ea (fixnumize (1- array-dimensions-offset)) rank))
(inst shl header n-widetag-bits)
(inst or header type)
(inst shr header n-fixnum-tag-bits)
@ -83,8 +79,7 @@
(:generator 3
;; An unaligned dword read not spanning a 16-byte boundary is as fast as
;; and shorter by 5 bytes than a qword read and right-shift by 8.
(inst mov (reg-in-size res :dword)
(make-ea :dword :base x :disp (1+ (- other-pointer-lowtag))))
(inst mov (reg-in-size res :dword) (ea (1+ (- other-pointer-lowtag)) x))
(inst sub (reg-in-size res :dword) (1- array-dimensions-offset))))
(define-vop (array-rank-vop=>fixnum)
@ -94,16 +89,12 @@
(:results (res :scs (any-reg)))
(:result-types positive-fixnum)
(:generator 2
(inst mov (reg-in-size res :dword)
(make-ea :dword :base x :disp (1+ (- other-pointer-lowtag))))
(inst mov (reg-in-size res :dword) (ea (1+ (- other-pointer-lowtag)) x))
(inst lea (reg-in-size res :dword)
(let ((scale (ash 1 n-fixnum-tag-bits)))
;; Compute [res*N-disp]. for N=2 use [res+res-disp]
(make-ea :dword
:scale (if (= scale 2) 1 scale)
:index res
:base (if (= scale 2) res nil)
:disp (- (* scale (1- array-dimensions-offset))))))))
(ea (- (* scale (1- array-dimensions-offset)))
(if (= scale 2) res nil) res (if (= scale 2) 1 scale))))))
(define-vop (array-rank=)
(:translate %array-rank=)
@ -113,7 +104,7 @@
(:arg-types * (:constant t))
(:conditional :e)
(:generator 2
(inst cmp (make-ea :dword :base array :disp (1+ (- other-pointer-lowtag)))
(inst cmp (ea (1+ (- other-pointer-lowtag)) array nil nil :dword)
(+ rank
(1- array-dimensions-offset)))))
@ -215,10 +206,9 @@
;; using 32-bit operand size might elide the REX prefix on mov + shift
(multiple-value-bind (dword-index bit) (floor index 32)
(inst mov (reg-in-size result :dword)
(make-ea :dword :base object
:disp (+ (* dword-index 4)
(- (* vector-data-offset n-word-bytes)
other-pointer-lowtag))))
(ea (+ (* dword-index 4)
(- (* vector-data-offset n-word-bytes) other-pointer-lowtag))
object))
(let ((right-shift (- bit n-fixnum-tag-bits)))
(cond ((plusp right-shift)
(inst shr (reg-in-size result :dword) right-shift))
@ -237,10 +227,8 @@
(:results (result :scs (any-reg)))
(:result-types positive-fixnum)
(:generator 4
(inst bt (make-ea :qword :base object
:disp (- (* vector-data-offset n-word-bytes)
other-pointer-lowtag))
index)
(inst bt (ea (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
object) index)
(inst sbb (reg-in-size result :dword) (reg-in-size result :dword))
(inst and (reg-in-size result :dword) (fixnumize 1))))
@ -265,9 +253,8 @@
(move ecx index)
(inst shr ecx ,bit-shift)
(inst mov result
(make-ea :qword :base object :index ecx :scale n-word-bytes
:disp (- (* vector-data-offset n-word-bytes)
other-pointer-lowtag)))
(ea (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
object ecx n-word-bytes))
(move ecx index)
;; We used to mask ECX for all values of BITS, but since
;; Intel's documentation says that the chip will mask shift
@ -316,10 +303,8 @@
(move word-index index)
(inst shr word-index ,bit-shift)
(inst mov old
(make-ea :qword :base object :index word-index
:scale n-word-bytes
:disp (- (* vector-data-offset n-word-bytes)
other-pointer-lowtag)))
(ea (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
object word-index n-word-bytes))
(move ecx index)
;; We used to mask ECX for all values of BITS, but since
;; Intel's documentation says that the chip will mask shift
@ -340,10 +325,8 @@
(unsigned-reg
(inst or old value)))
(inst rol old :cl)
(inst mov (make-ea :qword :base object :index word-index
:scale n-word-bytes
:disp (- (* vector-data-offset n-word-bytes)
other-pointer-lowtag))
(inst mov (ea (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
object word-index n-word-bytes)
old)
(sc-case value
(immediate
@ -366,10 +349,9 @@
(aver (zerop offset))
(multiple-value-bind (word extra) (floor index ,elements-per-word)
(inst mov old
(make-ea :qword :base object
:disp (- (* (+ word vector-data-offset)
n-word-bytes)
other-pointer-lowtag)))
(ea (- (* (+ word vector-data-offset) n-word-bytes)
other-pointer-lowtag)
object))
(sc-case value
(immediate
(let* ((value (tn-value value))
@ -391,10 +373,9 @@
(inst or old value)
(unless (zerop shift)
(inst rol old shift)))))
(inst mov (make-ea :qword :base object
:disp (- (* (+ word vector-data-offset)
n-word-bytes)
other-pointer-lowtag))
(inst mov (ea (- (* (+ word vector-data-offset) n-word-bytes)
other-pointer-lowtag)
object)
old)
(sc-case value
(immediate
@ -411,17 +392,17 @@
(let ((ea-size (if (= element-size 4) :dword :qword)))
(etypecase index
(integer
(make-ea ea-size :base object
:disp (- (+ (* vector-data-offset n-word-bytes)
(* (+ index offset) element-size)
complex-offset)
other-pointer-lowtag)))
(ea (- (+ (* vector-data-offset n-word-bytes)
(* (+ index offset) element-size)
complex-offset)
other-pointer-lowtag)
object nil nil ea-size))
(tn
(make-ea ea-size :base object :index index :scale scale
:disp (- (+ (* vector-data-offset n-word-bytes)
(* offset element-size)
complex-offset)
other-pointer-lowtag))))))
(ea (- (+ (* vector-data-offset n-word-bytes)
(* offset element-size)
complex-offset)
other-pointer-lowtag)
object index scale ea-size)))))
#.
(let ((use-temp (<= word-shift n-fixnum-tag-bits)))
@ -733,11 +714,10 @@
(:results (value :scs ,scs))
(:result-types ,type)
(:generator 5
(inst ,mov-inst value
(make-ea ,operand-size :base object :index index :scale ,scale
:disp (- (+ (* vector-data-offset n-word-bytes)
(* offset ,n-bytes))
other-pointer-lowtag)))))
(inst ,mov-inst value
(ea (- (+ (* vector-data-offset n-word-bytes)
(* offset ,n-bytes)) other-pointer-lowtag)
object index ,scale ,operand-size))))
(define-vop (,(symbolicate "DATA-VECTOR-REF-WITH-OFFSET/" ptype "-C"))
(:translate data-vector-ref-with-offset)
(:policy :fast-safe)
@ -749,12 +729,12 @@
(:results (value :scs ,scs))
(:result-types ,type)
(:generator 4
(inst ,mov-inst value
(make-ea ,operand-size :base object
:disp (- (+ (* vector-data-offset n-word-bytes)
(* ,n-bytes index)
(* ,n-bytes offset))
other-pointer-lowtag)))))
(inst ,mov-inst value
(ea (- (+ (* vector-data-offset n-word-bytes)
(* ,n-bytes index)
(* ,n-bytes offset))
other-pointer-lowtag)
object nil nil ,operand-size))))
(define-vop (,(symbolicate "DATA-VECTOR-SET-WITH-OFFSET/" ptype))
(:translate data-vector-set-with-offset)
(:policy :fast-safe)
@ -769,13 +749,11 @@
(:results (result :scs ,scs))
(:result-types ,type)
(:generator 5
(inst mov (make-ea ,operand-size :base object :index index :scale ,scale
:disp (- (+ (* vector-data-offset n-word-bytes)
(* offset ,n-bytes))
other-pointer-lowtag))
(reg-in-size value ,operand-size))
(move result value)))
(inst mov (ea (- (+ (* vector-data-offset n-word-bytes)
(* offset ,n-bytes)) other-pointer-lowtag)
object index ,scale ,operand-size)
(reg-in-size value ,operand-size))
(move result value)))
(define-vop (,(symbolicate "DATA-VECTOR-SET-WITH-OFFSET/" ptype "-C"))
(:translate data-vector-set-with-offset)
(:policy :fast-safe)
@ -789,13 +767,13 @@
(:results (result :scs ,scs))
(:result-types ,type)
(:generator 4
(inst mov (make-ea ,operand-size :base object
:disp (- (+ (* vector-data-offset n-word-bytes)
(* ,n-bytes index)
(* ,n-bytes offset))
other-pointer-lowtag))
(reg-in-size value ,operand-size))
(move result value))))))))
(inst mov (ea (- (+ (* vector-data-offset n-word-bytes)
(* ,n-bytes index)
(* ,n-bytes offset))
other-pointer-lowtag)
object nil nil ,operand-size)
(reg-in-size value ,operand-size))
(move result value))))))))
(define-data-vector-frobs simple-array-unsigned-byte-7 movzx :byte
positive-fixnum unsigned-reg signed-reg)
(define-data-vector-frobs simple-array-unsigned-byte-8 movzx :byte
@ -841,11 +819,8 @@
(:results (result :scs (unsigned-reg)))
(:result-types unsigned-num)
(:generator 4
(inst xadd (make-ea :qword :base array
:scale (ash 1 (- word-shift n-fixnum-tag-bits))
:index index
:disp (- (* vector-data-offset n-word-bytes)
other-pointer-lowtag))
(inst xadd (ea (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
array index (ash 1 (- word-shift n-fixnum-tag-bits)))
diff :lock)
(move result diff)))
@ -860,14 +835,13 @@
(:generator 1
(inst cmp
(if (sc-is index immediate)
(make-ea :dword :base vector
:disp (+ (- other-pointer-lowtag)
(ash (+ vector-data-offset (tn-value index))
word-shift)))
(make-ea :dword :base vector
:disp (+ (- other-pointer-lowtag)
(ash vector-data-offset word-shift))
:index index :scale (ash 1 (- word-shift n-fixnum-tag-bits))))
(ea (+ (- other-pointer-lowtag)
(ash (+ vector-data-offset (tn-value index)) word-shift))
vector nil nil :dword)
(ea (+ (- other-pointer-lowtag)
(ash vector-data-offset word-shift))
vector index (ash 1 (- word-shift n-fixnum-tag-bits))
:dword))
(if (sc-is thing immediate)
(make-fixup (tn-value thing) :layout)
thing))))

19
src/compiler/x86-64/c-call.lisp
View file

@ -307,7 +307,7 @@
(arg args (tn-ref-across arg)))
((null arg))
;; KLUDGE: assume all parameters are 8 bytes or less
(inst mov (make-ea :qword :base rax :disp n) 0)))
(inst mov (ea n rax nil nil :qword) 0)))
#!-win32
;; ABI: AL contains amount of arguments passed in XMM registers
;; for vararg calls.
@ -329,7 +329,7 @@
(inst call (cond ((tn-p fun) fun)
((sb!c::code-immobile-p vop) (make-fixup fun :foreign))
(t (make-ea :qword :disp (make-fixup fun :foreign 8)))))
(t (ea (make-fixup fun :foreign 8)))))
;; For the undefined alien error
(note-this-location vop :internal-error)
#!+win32 (inst add rsp-tn #x20) ;MS_ABI: remove shadow space
@ -399,7 +399,7 @@
(rsp rsp-tn)
#!+(and win32 sb-thread) (r8 r8-tn)
(xmm0 float0-tn)
([rsp] (make-ea :qword :base rsp :disp 0))
([rsp] (ea rsp))
;; How many arguments have been copied
(arg-count 0)
;; How many arguments have been copied from the stack
@ -419,16 +419,11 @@
;; A TN pointing to the stack location where the
;; current argument should be stored for the purposes
;; of ENTER-ALIEN-CALLBACK.
(target-tn (make-ea :qword :base rsp
:disp (* arg-count
n-word-bytes)))
(target-tn (ea (* arg-count n-word-bytes) rsp))
;; A TN pointing to the stack location that contains
;; the next argument passed on the stack.
(stack-arg-tn (make-ea :qword :base rsp
:disp (* (+ 1
(length argument-types)
stack-argument-count)
n-word-bytes))))
(stack-arg-tn (ea (* (+ 1 (length argument-types) stack-argument-count)
n-word-bytes) rsp)))
(incf arg-count)
(cond (integerp
(let ((gpr (pop gprs)))
@ -462,7 +457,7 @@
#!-sb-thread
(progn
;; arg0 to FUNCALL3 (function)
(inst mov rdi (make-ea :qword :disp (static-fdefn-fun-addr 'enter-alien-callback)))
(inst mov rdi (ea (static-fdefn-fun-addr 'enter-alien-callback)))
;; arg0 to ENTER-ALIEN-CALLBACK (trampoline index)
(inst mov rsi (fixnumize index))
;; arg1 to ENTER-ALIEN-CALLBACK (pointer to argument vector)

119
src/compiler/x86-64/call.lisp
View file

@ -100,11 +100,8 @@
(macrolet ((define-frame-op
(suffix sc stack-sc instruction
&optional (ea
`(make-ea :qword
:base frame-pointer
:disp (frame-byte-offset
(tn-offset variable-home-tn)))))
&optional (ea `(ea (frame-byte-offset (tn-offset variable-home-tn))
frame-pointer)))
(let ((reffer (symbolicate 'ancestor-frame-ref '/ suffix))
(setter (symbolicate 'ancestor-frame-set '/ suffix)))
`(progn
@ -186,7 +183,7 @@
(defun emit-lea (target source disp)
(if (eql disp 0)
(inst mov target source)
(inst lea target (make-ea :qword :base source :disp disp))))
(inst lea target (ea disp source))))
(define-vop (xep-setup-sp)
(:generator 1
@ -203,8 +200,7 @@
(:info callee)
(:ignore nfp callee)
(:generator 2
(inst lea res (make-ea :qword :base rsp-tn
:disp (- (* sp->fp-offset n-word-bytes))))
(inst lea res (ea (- (* sp->fp-offset n-word-bytes)) rsp-tn))
(inst sub rsp-tn (* n-word-bytes (sb-allocated-size 'stack)))))
(defun make-stack-pointer-tn (&optional nargs)
@ -238,7 +234,7 @@
(inst sub rsp-tn stack-size)
(move res rsp-tn))
(t
(inst lea res (make-ea :qword :base rsp-tn :disp (- fp-offset)))
(inst lea res (ea (- fp-offset) rsp-tn))
(inst sub rsp-tn stack-size))))))
;;; Emit code needed at the return-point from an unknown-values call
@ -383,7 +379,7 @@
(inst jmp :c variable-values)
(cond ((location= start (first *register-arg-tns*))
(inst push (first *register-arg-tns*))
(inst lea start (make-ea :qword :base rsp-tn :disp n-word-bytes)))
(inst lea start (ea n-word-bytes rsp-tn)))
(t (inst mov start rsp-tn)
(inst push (first *register-arg-tns*))))
(unless (eq (tn-kind count) :unused)
@ -829,15 +825,12 @@
(inst ,(if (eq return :tail) 'jmp 'call) target))
#!-immobile-code
`(inst ,(if (eq return :tail) 'jmp 'call)
(make-ea :qword :disp
(+ nil-value (static-fun-offset fun)))))
(ea (+ nil-value (static-fun-offset fun)))))
#!-immobile-code
(named
`(inst ,(if (eq return :tail) 'jmp 'call)
(make-ea :qword :base rax
:disp (- (* fdefn-raw-addr-slot
n-word-bytes)
other-pointer-lowtag))))
(ea (- (* fdefn-raw-addr-slot n-word-bytes)
other-pointer-lowtag) rax)))
((eq return :tail)
`(tail-call-unnamed rax callable vop))
(t
@ -892,9 +885,8 @@
(defun tail-call-unnamed (fun designator-p vop)
(let ((relative-call (sb!c::code-immobile-p vop))
(fun-ea (make-ea :qword :base fun
:disp (- (* closure-fun-slot n-word-bytes)
fun-pointer-lowtag))))
(fun-ea (ea (- (* closure-fun-slot n-word-bytes) fun-pointer-lowtag)
fun)))
(if designator-p
(assemble ()
(%lea-for-lowtag-test ebx-tn fun fun-pointer-lowtag)
@ -916,9 +908,8 @@
(inst jmp :z call)
(invoke-asm-routine 'call 'call-symbol vop))
call
(inst call (make-ea :qword :base fun
:disp (- (* closure-fun-slot n-word-bytes)
fun-pointer-lowtag)))))
(inst call (ea (- (* closure-fun-slot n-word-bytes) fun-pointer-lowtag)
fun))))
;;; This is defined separately, since it needs special code that BLT's
;;; the arguments down. All the real work is done in the assembly
@ -1003,8 +994,7 @@
;; This is handled in RETURN-SINGLE.
(error "nvalues is 1"))
;; Establish the values pointer and values count.
(inst lea rbx (make-ea :qword :base rbp-tn
:disp (* sp->fp-offset n-word-bytes)))
(inst lea rbx (ea (* sp->fp-offset n-word-bytes) rbp-tn))
(if (zerop nvals)
(zeroize rcx) ; smaller
(inst mov rcx (fixnumize nvals)))
@ -1032,13 +1022,11 @@
;; Clear as much of the stack as possible, but not past the
;; old frame address.
(inst lea rsp-tn
(make-ea :qword :base rbp-tn
:disp (frame-byte-offset (1- nvals))))
(ea (frame-byte-offset (1- nvals)) rbp-tn))
(move rbp-tn old-fp)
(inst push (make-ea :qword :base rbx
:disp (frame-byte-offset
(+ sp->fp-offset
(tn-offset return-pc)))))
(inst push (ea (frame-byte-offset
(+ sp->fp-offset (tn-offset return-pc)))
rbx))
(inst ret)))))
;;; Do unknown-values return of an arbitrary number of values (passed
@ -1127,11 +1115,8 @@
(inst lea (if (<= fixed (sb-allocated-size 'stack))
rsp-tn
source)
(make-ea :qword :base rbp-tn
:index temp :scale (ash 1 (- word-shift n-fixnum-tag-bits))
:disp (* n-word-bytes
(- (+ sp->fp-offset fixed)
(sb-allocated-size 'stack)))))
(ea (* n-word-bytes (- (+ sp->fp-offset fixed) (sb-allocated-size 'stack)))
rbp-tn temp (ash 1 (- word-shift n-fixnum-tag-bits))))
;; Now: nargs>=1 && nargs>fixed
@ -1152,17 +1137,15 @@
(inst jmp :be DO-REGS))
(t
;; Number to copy = nargs-fixed
(inst lea rbx-tn (make-ea :qword :base rcx-tn
:disp (- (fixnumize fixed))))))
(inst lea rbx-tn (ea (- (fixnumize fixed)) rcx-tn))))
;; Initialize R8 to be the end of args.
;; Swap with SP if necessary to mirror the previous condition
(inst lea (if (<= fixed (sb-allocated-size 'stack))
source
rsp-tn)
(make-ea :qword :base rbp-tn
:index temp :scale (ash 1 (- word-shift n-fixnum-tag-bits))
:disp (* sp->fp-offset n-word-bytes)))
(ea (* sp->fp-offset n-word-bytes)
rbp-tn temp (ash 1 (- word-shift n-fixnum-tag-bits))))
;; src: rbp + temp + sp->fp
;; dst: rbp + temp + sp->fp + (fixed - [stack-size])
@ -1177,8 +1160,8 @@
;; much worse than an explicit loop for small blocks.
(emit-label loop)
(inst mov temp (make-ea :qword :base source :index copy-index))
(inst mov (make-ea :qword :base rsp-tn :index copy-index) temp)
(inst mov temp (ea source copy-index))
(inst mov (ea rsp-tn copy-index) temp)
(inst add copy-index n-word-bytes)
(inst sub rbx-tn (fixnumize 1))
(inst jmp :nz loop))
@ -1186,11 +1169,8 @@
;; dst is higher than src; copy backward
(emit-label loop)
(inst sub rbx-tn (fixnumize 1))
(inst mov temp (make-ea :qword :base rsp-tn
:index rbx-tn :scale fixnum->word))
(inst mov (make-ea :qword :base source
:index rbx-tn :scale fixnum->word)
temp)
(inst mov temp (ea rsp-tn rbx-tn fixnum->word))
(inst mov (ea source rbx-tn fixnum->word) temp)
(inst jmp :nz loop)
;; done with the stack--stack copy. Reset RSP to its final
;; value
@ -1204,12 +1184,10 @@
(do ((i fixed))
( nil )
;; Store it relative to rbp
(inst mov (make-ea :qword :base rbp-tn
:disp (* n-word-bytes
(- sp->fp-offset
(+ 1
(- i fixed)
(sb-allocated-size 'stack)))))
(inst mov (ea (* n-word-bytes
(- sp->fp-offset
(+ 1 (- i fixed) (sb-allocated-size 'stack))))
rbp-tn)
(nth i *register-arg-tns*))
(incf i)
@ -1242,11 +1220,9 @@
(keyword :scs (descriptor-reg any-reg)))
(:result-types * *)
(:generator 4
(inst mov value (make-ea :qword :base object :index index
:scale (ash 1 (- word-shift n-fixnum-tag-bits))))
(inst mov keyword (make-ea :qword :base object :index index
:scale (ash 1 (- word-shift n-fixnum-tag-bits))
:disp n-word-bytes))))
(inst mov value (ea object index (ash 1 (- word-shift n-fixnum-tag-bits))))
(inst mov keyword (ea n-word-bytes object index
(ash 1 (- word-shift n-fixnum-tag-bits))))))
(define-vop (more-arg/c)
(:translate sb!c::%more-arg)
@ -1257,8 +1233,7 @@
(:results (value :scs (descriptor-reg any-reg)))
(:result-types *)
(:generator 3
(inst mov value (make-ea :qword :base object
:disp (- (* index n-word-bytes))))))
(inst mov value (ea (- (* index n-word-bytes)) object))))
(define-vop (more-arg)
(:translate sb!c::%more-arg)
@ -1271,8 +1246,8 @@
(:generator 4
(move value index)
(inst neg value)
(inst mov value (make-ea :qword :base object :index value
:scale (ash 1 (- word-shift n-fixnum-tag-bits))))))
(inst mov value (ea object value
(ash 1 (- word-shift n-fixnum-tag-bits))))))
;;; Turn more arg (context, count) into a list.
(define-vop (listify-rest-args)
@ -1297,7 +1272,7 @@
;; Check to see whether there are no args, and just return NIL if so.
(inst mov result nil-value)
(inst jrcxz done)
(inst lea dst (make-ea :qword :index rcx :scale (ash 2 (- word-shift n-fixnum-tag-bits))))
(inst lea dst (ea nil rcx (ash 2 (- word-shift n-fixnum-tag-bits))))
(unless stack-allocate-p
(instrument-alloc dst node))
(maybe-pseudo-atomic stack-allocate-p
@ -1317,7 +1292,7 @@
(storew dst dst -1 list-pointer-lowtag)
(emit-label enter)
;; Grab one value and stash it in the car of this cons.
(inst mov rax (make-ea :qword :base src))
(inst mov rax (ea src))
(inst sub src n-word-bytes)
(storew rax dst 0 list-pointer-lowtag)
;; Go back for more.
@ -1351,10 +1326,9 @@
(move count supplied)
;; SP at this point points at the last arg pushed.
;; Point to the first more-arg, not above it.
(inst lea context (make-ea :qword :base rsp-tn
:index count
:scale (ash 1 (- word-shift n-fixnum-tag-bits))
:disp (- (* (1+ fixed) n-word-bytes))))
(inst lea context (ea (- (* (1+ fixed) n-word-bytes))
rsp-tn count
(ash 1 (- word-shift n-fixnum-tag-bits))))
(unless (zerop fixed)
(inst sub count (fixnumize fixed)))))
@ -1436,11 +1410,10 @@
#!+sb-thread
(inst cmp (thread-slot-ea thread-stepping-slot) 0)
#!-sb-thread
(inst cmp (make-ea :byte
:disp (+ nil-value (static-symbol-offset
'sb!impl::*stepping*)
(* symbol-value-slot n-word-bytes)
(- other-pointer-lowtag)))
(inst cmp (ea (+ nil-value (static-symbol-offset 'sb!impl::*stepping*)
(* symbol-value-slot n-word-bytes)
(- other-pointer-lowtag))
nil nil nil :byte)
0))
(define-vop (step-instrument-before-vop)

74
src/compiler/x86-64/cell.lisp
View file

@ -43,12 +43,12 @@
(inst shr (reg-in-size temp-reg-tn :dword) n-widetag-bits)
;; now temp-reg-tn holds the difference in words from code to fun.
(inst push temp-reg-tn)
(inst add (make-ea :qword :base rsp-tn) offset) ; for particular slot
(inst add (ea 0 rsp-tn nil nil :qword) offset) ; for particular slot
;; finish computing the code address
(inst neg temp-reg-tn)
(inst lea temp-reg-tn
(make-ea :qword :base object :index temp-reg-tn :scale n-word-bytes
:disp (- other-pointer-lowtag fun-pointer-lowtag)))
(ea (- other-pointer-lowtag fun-pointer-lowtag)
object temp-reg-tn n-word-bytes))
(inst push temp-reg-tn))
(t ; is code already
(inst push offset)
@ -66,15 +66,12 @@
(cond #!+compact-instance-header
((and (eq name '%make-structure-instance) (eql offset :layout))
;; The layout is in the upper half of the header word.
(inst mov
(make-ea :dword :base object :disp (- 4 instance-pointer-lowtag))
(if (sc-is value immediate)
(make-fixup (tn-value value) :layout)
(reg-in-size value :dword))))
(inst mov (ea (- 4 instance-pointer-lowtag) object nil nil :dword)
(if (sc-is value immediate)
(make-fixup (tn-value value) :layout)
(reg-in-size value :dword))))
((sc-is value immediate)
(move-immediate (make-ea :qword
:base object
:disp (- (* offset n-word-bytes) lowtag))
(move-immediate (ea (- (* offset n-word-bytes) lowtag) object nil nil :qword)
(encode-value-if-immediate value)
temp-reg-tn (not dx-p)))
(t
@ -92,8 +89,7 @@
(:results (result :scs (descriptor-reg any-reg)))
(:generator 5
(move rax old)
(inst cmpxchg (make-ea :qword :base object
:disp (- (* offset n-word-bytes) lowtag))
(inst cmpxchg (ea (- (* offset n-word-bytes) lowtag) object)
new :lock)
(move result rax)))
@ -157,9 +153,8 @@
`(progn
(inst mov (reg-in-size cell :dword) (tls-index-of symbol))
(inst lea cell
(make-ea :qword :base thread-base-tn :index cell
:disp (- other-pointer-lowtag
(ash symbol-value-slot word-shift))))
(ea (- other-pointer-lowtag (ash symbol-value-slot word-shift))
thread-base-tn cell))
(inst cmp (access-value-slot cell :dword) ; TLS reference
no-tls-value-marker-widetag)
(inst cmov :e cell symbol))) ; now possibly get the symbol
@ -410,11 +405,10 @@
(:results (result :scs (descriptor-reg)))
(:generator 38
(inst mov raw (make-fixup 'closure-tramp :assembly-routine))
(inst cmp (make-ea :byte :base function :disp (- fun-pointer-lowtag))
(inst cmp (ea (- fun-pointer-lowtag) function nil nil :byte)
simple-fun-widetag)
(inst cmov :e raw
(make-ea :qword :base function
:disp (- (* simple-fun-self-slot n-word-bytes) fun-pointer-lowtag)))
(ea (- (* simple-fun-self-slot n-word-bytes) fun-pointer-lowtag) function))
(storew function fdefn fdefn-fun-slot other-pointer-lowtag)
(storew raw fdefn fdefn-raw-addr-slot other-pointer-lowtag)
(move result function)))
@ -430,7 +424,7 @@
#!+immobile-code
(let ((tramp (make-fixup 'undefined-fdefn :assembly-routine)))
(if (sb!c::code-immobile-p vop)
(inst lea temp (make-ea :qword :base rip-tn :disp tramp))
(inst lea temp (ea tramp rip-tn))
(inst mov temp tramp))
;; Compute displacement from the call site
(inst sub (reg-in-size temp :dword) (reg-in-size fdefn :dword))
@ -498,8 +492,8 @@
(storew tmp bsp binding-value-slot)
;; Indices are small enough to be written as :DWORDs which avoids
;; a REX prefix if 'bsp' happens to be any of the low 8 registers.
(inst mov (make-ea :dword :base bsp
:disp (ash binding-symbol-slot word-shift)) tls-index)
(inst mov (ea (ash binding-symbol-slot word-shift) bsp nil nil :dword)
tls-index)
(inst mov tls-cell (encode-value-if-immediate val))))))
#!-sb-thread
@ -534,7 +528,7 @@
(loadw temp bsp binding-value-slot)
(inst mov tls-cell temp)
;; Zero out the stack.
(inst movapd (make-ea :qword :base bsp) zero))
(inst movapd (ea bsp) zero))
(store-binding-stack-pointer bsp)))
#!-sb-thread
@ -565,8 +559,7 @@
;; 32-bits.
#!+sb-thread
(let ((tls-index (reg-in-size symbol :dword)))
(inst mov tls-index
(make-ea :dword :base bsp :disp (* binding-symbol-slot n-word-bytes)))
(inst mov tls-index (ea (* binding-symbol-slot n-word-bytes) bsp))
(inst test tls-index tls-index))
#!-sb-thread
(progn
@ -580,7 +573,7 @@
(inst mov (thread-tls-ea symbol) value)
SKIP
(inst movapd (make-ea :qword :base bsp) zero)
(inst movapd (ea bsp) zero)
(inst cmp where bsp)
(inst jmp :ne LOOP)
@ -642,8 +635,7 @@
(:result-types positive-fixnum)
(:generator 4
(let ((res (reg-in-size res :dword)))
(inst movzx res (make-ea :word :base struct
:disp (1+ (- instance-pointer-lowtag))))
(inst movzx res (ea (1+ (- instance-pointer-lowtag)) struct nil nil :word))
(inst shl res n-fixnum-tag-bits))))
#!+compact-instance-header
@ -656,7 +648,7 @@
(:variant-vars lowtag)
(:variant instance-pointer-lowtag)
(:generator 1
(inst mov (reg-in-size res :dword) (make-ea :dword :base object :disp (- 4 lowtag)))))
(inst mov (reg-in-size res :dword) (ea (- 4 lowtag) object))))
(define-vop (%set-instance-layout)
(:translate %set-instance-layout)
(:policy :fast-safe)
@ -666,7 +658,7 @@
(:variant-vars lowtag)
(:variant instance-pointer-lowtag)
(:generator 2
(inst mov (make-ea :dword :base object :disp (- 4 lowtag)) (reg-in-size value :dword))
(inst mov (ea (- 4 lowtag) object) (reg-in-size value :dword))
(move res value)))
(define-vop (%funcallable-instance-layout %instance-layout)
(:translate %funcallable-instance-layout)
@ -706,17 +698,14 @@
(flet ((instance-slot-ea (object index)
(etypecase index
(integer
(make-ea :qword
:base object
:disp (+ (* (+ instance-slots-offset index) n-word-bytes)
(- instance-pointer-lowtag))))
(ea (+ (* (+ instance-slots-offset index) n-word-bytes)
(- instance-pointer-lowtag))
object nil nil :qword))
(tn
(make-ea :qword
:base object
:index index
:scale (ash 1 (- word-shift n-fixnum-tag-bits))
:disp (+ (* instance-slots-offset n-word-bytes)
(- instance-pointer-lowtag)))))))
(ea (+ (* instance-slots-offset n-word-bytes)
(- instance-pointer-lowtag))
object index (ash 1 (- word-shift n-fixnum-tag-bits))
:qword)))))
(macrolet
((def (suffix result-sc result-type inst &optional (inst/c inst))
`(progn
@ -865,11 +854,10 @@
expected-old-lo expected-old-hi new-lo new-hi
eax ebx ecx edx result-lo result-hi)))))
(define-cmpxchg-vop compare-and-exchange-pair
(make-ea :dword :base object :disp (- list-pointer-lowtag))
(ea (- list-pointer-lowtag) object)
((:translate %cons-cas-pair)))
(define-cmpxchg-vop compare-and-exchange-pair-indexed
(make-ea :dword :base object :disp offset :index index
:scale (ash n-word-bytes (- n-fixnum-tag-bits)))
(ea offset object index (ash n-word-bytes (- n-fixnum-tag-bits)))
((:variant-vars offset))
((index :scs (descriptor-reg any-reg) :to :eval))))

5
src/compiler/x86-64/char.lisp
View file

@ -110,7 +110,7 @@
(inst mov
;; XXX: If the sb-unicode case needs to handle c-call,
;; why does the non-unicode case not need to?
(make-ea :byte :base fp :disp (frame-byte-offset (tn-offset y)))
(ea (frame-byte-offset (tn-offset y)) fp nil nil :byte)
x)
#!+sb-unicode
(if (= (tn-offset fp) esp-offset)
@ -221,8 +221,7 @@
(:save-p :compute-only)
(:policy :fast-safe)
(:generator 4
(inst lea (reg-in-size temp :dword)
(make-ea :dword :base value :disp (- character-widetag)))
(inst lea (reg-in-size temp :dword) (ea (- character-widetag) value))
(inst test (reg-in-size temp :dword) (lognot #x7F00))))
#!+sb-unicode

13
src/compiler/x86-64/debug.lisp
View file

@ -43,8 +43,8 @@
(move temp offset)
(inst neg temp)
(inst mov result
(make-ea :qword :base sap :disp (frame-byte-offset 0) :index temp
:scale (ash 1 (- word-shift n-fixnum-tag-bits))))))
(ea (frame-byte-offset 0) sap
temp (ash 1 (- word-shift n-fixnum-tag-bits))))))
(define-vop (write-control-stack)
(:translate %set-stack-ref)
@ -60,8 +60,8 @@
(move temp offset)
(inst neg temp)
(inst mov
(make-ea :qword :base sap :disp (frame-byte-offset 0) :index temp
:scale (ash 1 (- word-shift n-fixnum-tag-bits)))
(ea (frame-byte-offset 0) sap
temp (ash 1 (- word-shift n-fixnum-tag-bits)))
value)
(move result value)))
@ -82,9 +82,8 @@
(inst shr (reg-in-size temp :dword) n-widetag-bits)
(inst jmp :z bogus)
(inst neg temp)
(inst lea code
(make-ea :qword :base thing :index temp :scale n-word-bytes
:disp (- other-pointer-lowtag fun-pointer-lowtag)))
(inst lea code (ea (- other-pointer-lowtag fun-pointer-lowtag)
thing temp n-word-bytes))
(emit-label done)
(assemble (:elsewhere)
(emit-label bogus)

38
src/compiler/x86-64/float.lisp
View file

@ -12,10 +12,7 @@
(in-package "SB!VM")
(macrolet ((ea-for-xf-desc (tn slot)
`(make-ea
:qword :base ,tn
:disp (- (* ,slot n-word-bytes)
other-pointer-lowtag))))
`(ea (- (* ,slot n-word-bytes) other-pointer-lowtag) ,tn)))
(defun ea-for-df-desc (tn)
(ea-for-xf-desc tn double-float-value-slot))
;; complex floats
@ -35,9 +32,7 @@
(macrolet ((ea-for-xf-stack (tn kind)
(declare (ignore kind))
`(make-ea
:qword :base rbp-tn
:disp (frame-byte-offset (tn-offset ,tn)))))
`(ea (frame-byte-offset (tn-offset ,tn)) rbp-tn)))
(defun ea-for-sf-stack (tn)
(ea-for-xf-stack tn :single))
(defun ea-for-df-stack (tn)
@ -202,9 +197,7 @@
(inst shufps y y #4r3331))
(control-stack
;; Directly load high 4 bytes of descriptor from its stack address
(inst movss y (make-ea :dword
:base rbp-tn
:disp (+ (frame-byte-offset (tn-offset x)) 4)))))))
(inst movss y (ea (+ (frame-byte-offset (tn-offset x)) 4) rbp-tn))))))
(define-move-vop move-to-single-reg :move (descriptor-reg) (single-reg))
;;; Move from a descriptor to a float stack.
@ -216,8 +209,7 @@
(:generator 2
(move tmp x)
(inst shr tmp 32)
(let ((slot (make-ea :dword :base rbp-tn
:disp (frame-byte-offset (tn-offset y)))))
(let ((slot (ea (frame-byte-offset (tn-offset y)) rbp-tn)))
(inst mov slot (reg-in-size tmp :dword)))))
(define-move-vop move-to-single-stack :move (descriptor-reg) (single-stack))
@ -296,13 +288,11 @@
(,stack-sc
(if (= (tn-offset fp) esp-offset)
(let* ((offset (* (tn-offset y) n-word-bytes))
(ea (make-ea :dword :base fp :disp offset)))
(ea (ea offset fp)))
,@(ecase format
(:single '((inst movss ea x)))
(:double '((inst movsd ea x)))))
(let ((ea (make-ea
:dword :base fp
:disp (frame-byte-offset (tn-offset y)))))
(let ((ea (ea (frame-byte-offset (tn-offset y)) fp)))
,@(ecase format
(:single '((inst movss ea x)))
(:double '((inst movsd ea x))))))))))
@ -1230,8 +1220,7 @@
(inst movd res (reg-in-size bits :dword)))
(signed-stack
(inst movss res
(make-ea :dword :base rbp-tn
:disp (frame-byte-offset (tn-offset bits))))))))))
(ea (frame-byte-offset (tn-offset bits)) rbp-tn))))))))
(define-vop (make-single-float-c)
(:results (res :scs (single-reg single-stack descriptor-reg)))
@ -1292,10 +1281,9 @@
(let ((dword-bits (reg-in-size bits :dword)))
(inst movd dword-bits float)
(inst movsxd bits dword-bits)))
(single-stack
(inst movsxd bits (make-ea :dword ; c.f. ea-for-sf-stack
:base rbp-tn
:disp (frame-byte-offset (tn-offset float)))))
(single-stack ; c.f. ea-for-sf-stack
(inst movsxd bits
(ea (frame-byte-offset (tn-offset float)) rbp-tn nil nil :dword)))
(descriptor-reg
(move bits float)
(inst sar bits 32)))))
@ -1338,12 +1326,10 @@
(double-reg
(inst movsd temp float)
(inst mov dword-lo-bits
(make-ea :dword :base rbp-tn
:disp (frame-byte-offset (tn-offset temp)))))
(ea (frame-byte-offset (tn-offset temp)) rbp-tn)))
(double-stack
(inst mov dword-lo-bits
(make-ea :dword :base rbp-tn
:disp (frame-byte-offset (tn-offset float)))))
(ea (frame-byte-offset (tn-offset float)) rbp-tn)))
(descriptor-reg
(inst mov dword-lo-bits
(make-ea-for-object-slot-half float double-float-value-slot

67
src/compiler/x86-64/insts.lisp
View file

@ -18,7 +18,7 @@
plausible-signed-imm32-operand-p
register-p gpr-p xmm-register-p
ea-p sized-ea ea-base ea-index
make-ea ea-disp rip-relative-ea) "SB!VM")
ea make-ea ea-disp rip-relative-ea) "SB!VM")
;; Imports from SB-VM into this package
(import '(sb!vm::frame-byte-offset sb!vm::rip-tn sb!vm::rbp-tn
sb!vm::registers sb!vm::float-registers sb!vm::stack))) ; SB names
@ -1023,11 +1023,13 @@
(addend 0 :type (signed-byte 32)))
(defstruct (ea (:constructor make-ea (size &key base index scale disp))
(:constructor %ea (disp base index scale size))
(:copier nil))
;; note that we can represent an EA with a QWORD size, but EMIT-EA
;; can't actually emit it on its own: caller also needs to emit REX
;; prefix
(size nil :type (member :byte :word :dword :qword) :read-only t)
(size :unspecific :type (member :byte :word :dword :qword :unspecific)
:read-only t)
(base nil :type (or tn null) :read-only t)
(index nil :type (or tn null) :read-only t)
(scale 1 :type (member 1 2 4 8) :read-only t)
@ -1063,16 +1065,51 @@
(format stream "+~A" (ea-disp ea))))
(write-char #\] stream))))
;;; BOA constructor for EA has these acceptable forms:
;;; (EA displacement &OPTIONAL base-register index-register scale size)
;;; (EA base-register &OPTIONAL index-register scale)
;;;
;;; mnemonic device: the syntax is like AT&T "disp(%rbase,%rindex,scale)"
;;; where the leading "disp" is optional.
;;;
;;; Most instructions can determine an EA size based on the size of a register
;;; operand. The few that can't are mem+immediate mode instructions, and
;;; instructions which need explicit differently sized register + EA.
;;; The assembler will be changed to parse a qualifier on the instruction
;;; similarly to other syntaxes:
;;;
;;; AT&T : testb $0x40(%rax)
;;; Intel : test byte ptr [%eax], 40
;;; SBCL : (TEST :BYTE (EA RAX-TN) #x40)
;;;
;;; Until that change is completed, EAs themselves will convey an optional size,
;;; specifiable only if you pass all constructor arguments.
;;;
(defun ea (displacement &optional base (index nil indexp) (scale 1 scalep)
(size :unspecific))
(when (or (null displacement) (gpr-p displacement))
;; Sans-displacement syntax requires that size be :unspecific.
;; Use the longer syntax meanwhile if you need an explicit size.
(aver (not scalep))
(setq scale (if indexp index 1)
index base
base displacement
displacement 0))
;; FIXME: until SIZE is removed, the caller might have to specify INDEX
;; and SCALE even if undesired. Allow NIL for the scale. but only when
;; INDEX is null, and set it to 1 if so (which is the default).
;; Scale could be NIL only if index was also specified, since they're
;; no longer keywords. This AVER prevents accidental use of
;; (EA 0 base index nil :dword) and similar. The OR below would have
;; passed valid arguments to %EA and not be detected otherwise.
(when index (aver scale))
(%ea displacement base index (or scale 1) size))
(defun rip-relative-ea (size label &optional addend)
(make-ea size :base rip-tn
:disp (if addend
(make-label+addend label addend)
label)))
(%ea (if addend (make-label+addend label addend) label) rip-tn nil 1 size))
(defun sized-ea (ea new-size)
(make-ea new-size
:base (ea-base ea) :index (ea-index ea) :scale (ea-scale ea)
:disp (ea-disp ea)))
(%ea (ea-disp ea) (ea-base ea) (ea-index ea) (ea-scale ea) new-size))
(defun emit-byte-displacement-backpatch (segment target)
(emit-back-patch segment 1
@ -1098,10 +1135,7 @@
(stack
;; Could this be refactored to fall into the EA case below instead
;; of consing a new EA? Probably. Does it matter? Probably not.
(emit-ea segment
(make-ea :qword :base rbp-tn
:disp (frame-byte-offset (tn-offset thing)))
reg))
(emit-ea segment (ea (frame-byte-offset (tn-offset thing)) rbp-tn) reg))
(constant
(unless allow-constants
;; Why?
@ -1316,7 +1350,8 @@
(or (sb!c:sc-operand-size (tn-sc thing))
(error "can't tell the size of ~S" thing)))
(ea
(ea-size thing))
(unless (eq (ea-size thing) :unspecific)
(ea-size thing)))
(fixup
;; GNA. Guess who spelt "flavor" correctly first time round?
;; There's a strong argument in my mind to change all uses of
@ -1560,7 +1595,7 @@
(inst mov (sb!vm::reg-in-size dst :dword) src))
(flet ((emit* (segment thing gpr-opcode mem-opcode subcode allowp)
(let ((size (operand-size thing)))
(let ((size (or (operand-size thing) :qword)))
(aver (or (eq size :qword) (eq size :word)))
(emit-prefixes segment thing nil (if (eq size :word) :word :do-not-set))
(cond ((gpr-p thing)
@ -2081,7 +2116,7 @@
(:emitter (emit* segment #xBD dst src))))
(flet ((emit* (segment src index opcode lock)
(let ((size (operand-size src)))
(let ((size (matching-operand-size src index)))
(when (eq size :byte)
(error "can't test byte: ~S" src))
(emit-prefixes segment src index size :lock lock)

91
src/compiler/x86-64/macros.lisp
View file

@ -39,20 +39,24 @@
(inst mov dst src)))))
(defmacro make-ea-for-object-slot (ptr slot lowtag)
`(make-ea :qword :base ,ptr :disp (- (* ,slot n-word-bytes) ,lowtag)))
;; Explicitly :qword sized because we use this in such instructions as
;; (inst mov (make-ea-for-object-slot ..) immediate)
`(ea (- (* ,slot n-word-bytes) ,lowtag) ,ptr nil nil :qword))
(defmacro make-ea-for-object-slot-half (ptr slot lowtag)
`(make-ea :dword :base ,ptr :disp (- (* ,slot n-word-bytes) ,lowtag)))
`(ea (- (* ,slot n-word-bytes) ,lowtag) ,ptr nil nil :dword))
(defmacro tls-index-of (sym)
`(make-ea :dword :base ,sym :disp (+ 4 (- other-pointer-lowtag))))
`(ea (+ 4 (- other-pointer-lowtag)) ,sym nil nil :dword))
(defmacro loadw (value ptr &optional (slot 0) (lowtag 0))
`(inst mov ,value (make-ea-for-object-slot ,ptr ,slot ,lowtag)))
(defun storew (value ptr &optional (slot 0) (lowtag 0))
;; FIXME: do we really use STOREW for other than :QWORD ?
;; Shouldn't sub-lispword stores use something more appropriately named?
(let* ((size (if (tn-p value)
(sc-operand-size (tn-sc value))
:qword))
(ea (make-ea size :base ptr :disp (- (* slot n-word-bytes) lowtag))))
(ea (ea (- (* slot n-word-bytes) lowtag) ptr nil nil size)))
(cond ((and (integerp value)
(not (typep value '(signed-byte 32))))
(inst mov temp-reg-tn value)
@ -74,11 +78,12 @@
;; Return the effective address of the value slot of static SYMBOL.
(defun static-symbol-value-ea (symbol)
(make-ea :qword
:disp (+ nil-value
(static-symbol-offset symbol)
(ash symbol-value-slot word-shift)
(- other-pointer-lowtag))))
(ea (+ nil-value
(static-symbol-offset symbol)
(ash symbol-value-slot word-shift)
(- other-pointer-lowtag))
;; Explicit :QWORD because of mem+imm mode for some instructions.
nil nil nil :qword))
(defun thread-tls-ea (index &optional (size :qword))
(if (tn-p index)
@ -87,11 +92,11 @@
;; RIP-relative addressing. (And attempting to encode an index is illegal)
;; So the 'mod' bits must be nonzero, which mandates encoding of an
;; explicit displacement of 0. Using INDEX as base avoids the extra byte.
(make-ea size :base index :index thread-base-tn)
(make-ea size :base thread-base-tn :disp index)))
(ea 0 index thread-base-tn 1 size)
(ea index thread-base-tn nil nil size)))
(defun thread-slot-ea (slot-index &optional (size :qword))
(make-ea size :base thread-base-tn :disp (ash slot-index word-shift)))
(ea (ash slot-index word-shift) thread-base-tn nil nil size))
#!+sb-thread
(progn
@ -125,7 +130,7 @@
(defmacro load-type (target source &optional (offset 0))
"Loads the type bits of a pointer into target independent of
byte-ordering issues."
`(inst movzx ,target (make-ea :byte :base ,source :disp ,offset)))
`(inst movzx ,target (ea ,offset ,source nil nil :byte)))
;;;; error code
(defun emit-error-break (vop kind code values)
@ -179,9 +184,8 @@
#!+sb-safepoint
(defun emit-safepoint ()
(inst test al-tn (make-ea :byte :disp
(- nil-value n-word-bytes other-pointer-lowtag
gc-safepoint-trap-offset))))
(inst test al-tn (ea (- nil-value n-word-bytes other-pointer-lowtag
gc-safepoint-trap-offset))))
(defmacro pseudo-atomic (&rest forms)
#!+sb-safepoint-strictly
@ -229,11 +233,12 @@
(:generator 5
(move rax old-value)
(inst cmpxchg
(make-ea :qword :base object
:index (unless (sc-is index immediate) index)
:scale (ash 1 (- word-shift n-fixnum-tag-bits))
:disp (- (* (+ (if (sc-is index immediate) (tn-value index) 0)
,offset) n-word-bytes) ,lowtag))
(ea (- (* (+ (if (sc-is index immediate) (tn-value index) 0) ,offset)
n-word-bytes)
,lowtag)
object
(unless (sc-is index immediate) index)
(ash 1 (- word-shift n-fixnum-tag-bits)))
new-value :lock)
(move value rax)))))
@ -249,10 +254,8 @@
(:results (value :scs ,scs))
(:result-types ,el-type)
(:generator 3 ; pw was 5
(inst mov value (make-ea :qword :base object :index index
:scale (ash 1 (- word-shift n-fixnum-tag-bits))
:disp (- (* ,offset n-word-bytes)
,lowtag)))))
(inst mov value (ea (- (* ,offset n-word-bytes) ,lowtag)
object index (ash 1 (- word-shift n-fixnum-tag-bits))))))
(define-vop (,(symbolicate name "-C"))
,@(when translate
`((:translate ,translate)))
@ -265,9 +268,8 @@
(:results (value :scs ,scs))
(:result-types ,el-type)
(:generator 2 ; pw was 5
(inst mov value (make-ea :qword :base object
:disp (- (* (+ ,offset index) n-word-bytes)
,lowtag)))))))
(inst mov value (ea (- (* (+ ,offset index) n-word-bytes) ,lowtag)
object))))))
(defmacro define-full-reffer+offset (name type offset lowtag scs el-type &optional translate)
`(progn
@ -284,10 +286,8 @@
(:results (value :scs ,scs))
(:result-types ,el-type)
(:generator 3 ; pw was 5
(inst mov value (make-ea :qword :base object :index index
:scale (ash 1 (- word-shift n-fixnum-tag-bits))
:disp (- (* (+ ,offset offset) n-word-bytes)
,lowtag)))))
(inst mov value (ea (- (* (+ ,offset offset) n-word-bytes) ,lowtag)
object index (ash 1 (- word-shift n-fixnum-tag-bits))))))
(define-vop (,(symbolicate name "-C"))
,@(when translate
`((:translate ,translate)))
@ -302,9 +302,8 @@
(:results (value :scs ,scs))
(:result-types ,el-type)
(:generator 2 ; pw was 5
(inst mov value (make-ea :qword :base object
:disp (- (* (+ ,offset index offset) n-word-bytes)
,lowtag)))))))
(inst mov value (ea (- (* (+ ,offset index offset) n-word-bytes) ,lowtag)
object))))))
(defmacro define-full-setter (name type offset lowtag scs el-type &optional translate)
(let ((want-both-variants
@ -332,14 +331,13 @@
;; but this macro declares the index arg as 'any-reg', so it has a tag bit,
;; so we'll push the arg and then shift right as the next instruction.
(inst push index)
(inst shr (make-ea :qword :base rsp-tn) n-fixnum-tag-bits)
(inst shr (ea 0 rsp-tn nil nil :qword) n-fixnum-tag-bits)
(inst push object)
(invoke-asm-routine 'call 'code-header-set vop)
(move result value))
`((gen-cell-set
(make-ea :qword :base object :index index
:scale (ash 1 (- word-shift n-fixnum-tag-bits))
:disp (- (* ,offset n-word-bytes) ,lowtag))
(ea (- (* ,offset n-word-bytes) ,lowtag)
object index (ash 1 (- word-shift n-fixnum-tag-bits)))
value result)))))
,@(when want-both-variants
`((define-vop (,(symbolicate name "-C"))
@ -357,9 +355,8 @@
(:result-types ,el-type)
(:generator 3 ; was 5
(gen-cell-set
(make-ea :qword :base object
:disp (- (* (+ ,offset index) n-word-bytes)
,lowtag))
(ea (- (* (+ ,offset index) n-word-bytes) ,lowtag)
object)
value result))))))))
(defmacro define-full-setter+offset (name type offset lowtag scs el-type &optional translate)
@ -381,9 +378,8 @@
(:result-types ,el-type)
(:generator 4 ; was 5
(gen-cell-set
(make-ea :qword :base object :index index
:scale (ash 1 (- word-shift n-fixnum-tag-bits))
:disp (- (* (+ ,offset offset) n-word-bytes) ,lowtag))
(ea (- (* (+ ,offset offset) n-word-bytes) ,lowtag)
object index (ash 1 (- word-shift n-fixnum-tag-bits)))
value result)))
(define-vop (,(symbolicate name "-C"))
,@(when translate
@ -403,8 +399,7 @@
(:result-types ,el-type)
(:generator 3 ; was 5
(gen-cell-set
(make-ea :qword :base object
:disp (- (* (+ ,offset index offset) n-word-bytes)
,lowtag))
(ea (- (* (+ ,offset index offset) n-word-bytes) ,lowtag)
object)
value result)))))

12
src/compiler/x86-64/memory.lisp
View file

@ -13,11 +13,11 @@
(in-package "SB!VM")
(defun symbol-slot-ea (symbol slot &optional (size :qword))
(make-ea size :disp
(let ((offset (- (* slot n-word-bytes) other-pointer-lowtag)))
(ea (let ((offset (- (* slot n-word-bytes) other-pointer-lowtag)))
(if (static-symbol-p symbol)
(+ nil-value (static-symbol-offset symbol) offset)
(make-fixup symbol :immobile-object offset)))))
(make-fixup symbol :immobile-object offset)))
nil nil nil size))
(defun gen-cell-set (ea value result)
(when (sc-is value immediate)
@ -153,16 +153,14 @@
(inst jmp :nz err)
(if const
(cond ((typep const '(signed-byte 32))
(inst lea newval
(make-ea :qword :base rax :disp const)))
(inst lea newval (ea const rax)))
(t
(inst mov newval const)
(inst add newval rax)))
,(if (eq inherit 'cell-xsub)
`(progn (move newval rax)
(inst sub newval delta))
`(inst lea newval
(make-ea :qword :base rax :index delta))))
`(inst lea newval (ea rax delta))))
(inst cmpxchg
(make-ea-for-object-slot cell ,slot list-pointer-lowtag)
newval :lock)

10
src/compiler/x86-64/move.lisp
View file

@ -237,9 +237,8 @@
(cond ((and (sc-is x signed-reg unsigned-reg)
(not (location= x y)))
(if (= n-fixnum-tag-bits 1)
(inst lea y (make-ea :qword :base x :index x))
(inst lea y (make-ea :qword :index x
:scale (ash 1 n-fixnum-tag-bits)))))
(inst lea y (ea x x))
(inst lea y (ea nil x (ash 1 n-fixnum-tag-bits)))))
(t
;; Uses: If x is a reg 2 + 3; if x = y uses only 3 bytes
(move y x)
@ -326,9 +325,8 @@
;; should be noise compared to bignum consing if that is needed
;; and saves one branch.
(if (= n-fixnum-tag-bits 1)
(inst lea y (make-ea :qword :base x :index x))
(inst lea y (make-ea :qword :index x
:scale (ash 1 n-fixnum-tag-bits))))
(inst lea y (ea x x))
(inst lea y (ea nil x (ash 1 n-fixnum-tag-bits))))
(inst jmp :z done)
(inst mov y x)
(invoke-asm-routine 'call #.(bignum-from-reg 'y "UNSIGNED") vop)

19
src/compiler/x86-64/nlx.lisp
View file

@ -17,13 +17,11 @@
(defun catch-block-ea (tn)
(aver (sc-is tn catch-block))
(make-ea :qword :base rbp-tn
:disp (frame-byte-offset (+ -1 (tn-offset tn) catch-block-size))))
(ea (frame-byte-offset (+ -1 (tn-offset tn) catch-block-size)) rbp-tn))
(defun unwind-block-ea (tn)
(aver (sc-is tn unwind-block))
(make-ea :qword :base rbp-tn
:disp (frame-byte-offset (+ -1 (tn-offset tn) unwind-block-size))))
(ea (frame-byte-offset (+ -1 (tn-offset tn) unwind-block-size)) rbp-tn))
;;;; Save and restore dynamic environment.
;;;;
@ -195,7 +193,7 @@
(emit-label label)
(note-this-location vop :non-local-entry)
(inst lea rsi (make-ea :qword :base source :disp (- n-word-bytes)))
(inst lea rsi (ea (- n-word-bytes) source))
;; The 'top' arg contains the %esp value saved at the time the
;; catch block was created and points to where the thrown values
;; should sit.
@ -216,7 +214,7 @@
(inst cld)
DONE
;; Reset the CSP at last moved arg.
(inst lea rsp-tn (make-ea :qword :base rdi :disp n-word-bytes))))
(inst lea rsp-tn (ea n-word-bytes rdi))))
;;; This VOP is just to force the TNs used in the cleanup onto the stack.
@ -269,14 +267,11 @@
(zeroize rcx-tn)
;; Clear the stack
(inst lea rsp-tn
(make-ea :qword :base rbp-tn
:disp (* (- sp->fp-offset 3) n-word-bytes)))
(inst lea rsp-tn (ea (* (- sp->fp-offset 3) n-word-bytes) rbp-tn))
;; Push the return-pc so it looks like we just called.
(pushw rbp-tn (frame-word-offset return-pc-save-offset))
;; Call it
(inst jmp (make-ea :qword :base block
:disp (- (* closure-fun-slot n-word-bytes)
fun-pointer-lowtag)))))
(inst jmp (ea (- (* closure-fun-slot n-word-bytes) fun-pointer-lowtag)
block))))

43
src/compiler/x86-64/sap.lisp
View file

@ -117,14 +117,14 @@
(not (location= ptr res)))
(sc-case offset
(signed-reg
(inst lea res (make-ea :qword :base ptr :index offset)))
(inst lea res (ea ptr offset)))
(immediate
(let ((value (tn-value offset)))
(cond ((typep value '(or (signed-byte 32) (unsigned-byte 31)))
(inst lea res (make-ea :qword :base ptr :disp value)))
(cond ((typep value '(signed-byte 32))
(inst lea res (ea value ptr)))
(t
(inst mov temp value)
(inst lea res (make-ea :qword :base ptr :index temp))))))))
(inst lea res (ea ptr temp))))))))
(t
(move res ptr)
(sc-case offset
@ -132,7 +132,7 @@
(inst add res offset))
(immediate
(let ((value (tn-value offset)))
(cond ((typep value '(or (signed-byte 32) (unsigned-byte 31)))
(cond ((typep value '(signed-byte 32))
(inst add res (tn-value offset)))
(t
(inst mov temp value)
@ -165,12 +165,10 @@
(inst add sap offset))
(inst mov temp-reg-tn msan-mem-to-shadow-xor-const)
(inst xor temp-reg-tn sap)
(inst mov (make-ea size :base temp-reg-tn) 0)
(inst mov (ea 0 temp-reg-tn nil nil size) 0)
(unless (eql offset 0) ; restore SAP as if nothing happened
(inst sub sap offset))))
(inst mov
(make-ea size :base sap :index ea-index :disp ea-disp)
(reg-in-size value size))
(inst mov (ea ea-disp sap ea-index) (reg-in-size value size))
(move result value))
(macrolet ((def-system-ref-and-set (ref-name
@ -191,8 +189,7 @@
(:results (result :scs (,sc)))
(:result-types ,type)
(:generator 5
(inst ,ref-insn result
(make-ea ,size :base sap :index offset))))
(inst ,ref-insn result (ea 0 sap offset 1 ,size))))
(define-vop (,ref-name-c)
(:translate ,ref-name)
(:policy :fast-safe)
@ -203,8 +200,7 @@
(:results (result :scs (,sc)))
(:result-types ,type)
(:generator 4
(inst ,ref-insn result
(make-ea ,size :base sap :disp offset))))
(inst ,ref-insn result (ea offset sap nil nil ,size))))
(define-vop (,set-name)
(:translate ,set-name)
(:policy :fast-safe)
@ -259,7 +255,7 @@
(:results (result :scs (double-reg)))
(:result-types double-float)
(:generator 5
(inst movsd result (make-ea :qword :base sap :index offset))))
(inst movsd result (ea sap offset))))
(define-vop (sap-ref-double-c)
(:translate sap-ref-double)
@ -270,7 +266,7 @@
(:results (result :scs (double-reg)))
(:result-types double-float)
(:generator 4
(inst movsd result (make-ea :qword :base sap :disp offset))))
(inst movsd result (ea offset sap))))
(define-vop (%set-sap-ref-double)
(:translate %set-sap-ref-double)
@ -282,7 +278,7 @@
(:results (result :scs (double-reg)))
(:result-types double-float)
(:generator 5
(inst movsd (make-ea :qword :base sap :index offset) value)
(inst movsd (ea sap offset) value)
(move result value)))
(define-vop (%set-sap-ref-double-c)
@ -295,7 +291,7 @@
(:results (result :scs (double-reg)))
(:result-types double-float)
(:generator 4
(inst movsd (make-ea :qword :base sap :disp offset) value)
(inst movsd (ea offset sap) value)
(move result value)))
;;;; SAP-REF-SINGLE
@ -309,7 +305,7 @@
(:results (result :scs (single-reg)))
(:result-types single-float)
(:generator 5
(inst movss result (make-ea :dword :base sap :index offset))))
(inst movss result (ea sap offset))))
(define-vop (sap-ref-single-c)
(:translate sap-ref-single)
@ -320,7 +316,7 @@
(:results (result :scs (single-reg)))
(:result-types single-float)
(:generator 4
(inst movss result (make-ea :dword :base sap :disp offset))))
(inst movss result (ea offset sap))))
(define-vop (%set-sap-ref-single)
(:translate %set-sap-ref-single)
@ -332,7 +328,7 @@
(:results (result :scs (single-reg)))
(:result-types single-float)
(:generator 5
(inst movss (make-ea :dword :base sap :index offset) value)
(inst movss (ea sap offset) value)
(move result value)))
(define-vop (%set-sap-ref-single-c)
@ -345,7 +341,7 @@
(:results (result :scs (single-reg)))
(:result-types single-float)
(:generator 4
(inst movss (make-ea :dword :base sap :disp offset) value)
(inst movss (ea offset sap) value)
(move result value)))
@ -361,7 +357,7 @@
(let ((disp (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)))
(if (location= sap vector)
(inst add sap disp)
(inst lea sap (make-ea :qword :base vector :disp disp))))))
(inst lea sap (ea disp vector))))))
;;; Compare and swap
(define-vop (signed-sap-cas-32)
@ -377,7 +373,6 @@
(:result-types signed-num)
(:generator 5
(inst mov eax (reg-in-size oldval :dword))
(inst cmpxchg (make-ea :dword :base sap :index offset)
(reg-in-size newval :dword) :lock)
(inst cmpxchg (ea sap offset) (reg-in-size newval :dword) :lock)
(inst mov (reg-in-size result :dword) eax)))

3
src/compiler/x86-64/simd-pack.lisp
View file

@ -12,8 +12,7 @@
(in-package "SB!VM")
(defun ea-for-sse-stack (tn &optional (base rbp-tn))
(make-ea :qword :base base
:disp (frame-byte-offset (1+ (tn-offset tn)))))
(ea (frame-byte-offset (1+ (tn-offset tn))) base))
(defun float-sse-p (tn)
(sc-is tn single-sse-reg single-sse-stack single-sse-immediate

58
src/compiler/x86-64/system.lisp
View file

@ -70,14 +70,14 @@
(inst jmp :ne try-other)
;; It's an instance or function. Both have the layout in the header.
(inst and (reg-in-size rax :byte) #b11110111)
(inst mov (reg-in-size result :dword) (make-ea :dword :base rax :disp 4))
(inst mov (reg-in-size result :dword) (ea 4 rax))
(inst jmp done)
TRY-OTHER
(inst xor (reg-in-size rax :byte) #b1100)
(inst test (reg-in-size rax :byte) #b1111)
(inst jmp :ne imm-or-list)
;; It's an other-pointer. Read the widetag.
(inst movzx (reg-in-size rax :dword) (make-ea :byte :base rax))
(inst movzx (reg-in-size rax :dword) (ea 0 rax nil nil :byte))
(inst jmp load-from-vector)
IMM-OR-LIST
(inst cmp object nil-value)
@ -86,10 +86,8 @@
LOAD-FROM-VECTOR
(inst mov result layouts)
(inst mov (reg-in-size result :dword)
(make-ea :dword :base result
:index rax :scale 8
:disp (+ (ash vector-data-offset word-shift)
(- other-pointer-lowtag))))
(ea (+ (ash vector-data-offset word-shift) (- other-pointer-lowtag))
result rax 8))
(inst jmp done)
NULL
(inst mov result (make-fixup (find-layout 'null) :layout))
@ -131,8 +129,7 @@
(:result-types positive-fixnum)
(:generator 6
(let ((res (reg-in-size res :dword)))
(inst movzx res
(make-ea :word :base x :disp (1+ (- fun-pointer-lowtag))))
(inst movzx res (ea (1+ (- fun-pointer-lowtag)) x nil nil :word))
(inst btr res 15) ; Clear the NAMEDP header bit
(inst shl res n-fixnum-tag-bits))))
@ -148,7 +145,7 @@
(:generator 6
(move eax data)
(inst shl eax (- n-widetag-bits n-fixnum-tag-bits))
(inst mov al-tn (make-ea :byte :base x :disp (- other-pointer-lowtag)))
(inst mov al-tn (ea (- other-pointer-lowtag) x))
(storew eax x 0 other-pointer-lowtag)
(move res x)))
@ -159,8 +156,7 @@
(:results (res :scs (any-reg)))
(:result-types positive-fixnum)
(:generator 6
(inst mov (reg-in-size res :dword)
(make-ea :dword :base x :disp (- 4 other-pointer-lowtag)))
(inst mov (reg-in-size res :dword) (ea (- 4 other-pointer-lowtag) x))
(inst shl res n-fixnum-tag-bits)))
;;; Swap the high half of the header word of an object
@ -178,12 +174,9 @@
(:result-types positive-fixnum)
(:generator 5
(move rax old)
(inst cmpxchg (make-ea :dword :base object
:disp (- 4 other-pointer-lowtag))
(inst cmpxchg (ea (- 4 other-pointer-lowtag) object)
(reg-in-size new :dword) :lock)
(inst lea result
(make-ea :qword :index rax
:scale (ash 1 n-fixnum-tag-bits)))))
(inst lea result (ea nil rax (ash 1 n-fixnum-tag-bits)))))
(define-vop (pointer-hash)
(:translate pointer-hash)
@ -222,11 +215,8 @@
(:results (sap :scs (sap-reg) :from (:argument 0)))
(:result-types system-area-pointer)
(:generator 10
(inst mov (reg-in-size sap :dword)
(make-ea :dword :base code :disp (- 4 other-pointer-lowtag)))
(inst lea sap (make-ea :byte :base code :index sap
:scale n-word-bytes
:disp (- other-pointer-lowtag)))))
(inst mov (reg-in-size sap :dword) (ea (- 4 other-pointer-lowtag) code))
(inst lea sap (ea (- other-pointer-lowtag) code sap n-word-bytes))))
(define-vop (compute-fun)
(:args (code :scs (descriptor-reg) :to (:result 0))
@ -234,12 +224,10 @@
(:arg-types * positive-fixnum)
(:results (func :scs (descriptor-reg) :from (:argument 0)))
(:generator 10
(inst mov (reg-in-size func :dword)
(make-ea :dword :base code :disp (- 4 other-pointer-lowtag)))
(inst mov (reg-in-size func :dword) (ea (- 4 other-pointer-lowtag) code))
(inst lea func
(make-ea :byte :base offset :index func
:scale n-word-bytes
:disp (- fun-pointer-lowtag other-pointer-lowtag)))
(ea (- fun-pointer-lowtag other-pointer-lowtag)
offset func n-word-bytes))
(inst add func code)))
;;; This vop is quite magical - because 'closure-fun' is a raw program counter,
@ -255,9 +243,8 @@
(:generator 3
(loadw result function closure-fun-slot fun-pointer-lowtag)
(inst lea result
(make-ea :byte :base result
:disp (- fun-pointer-lowtag
(* simple-fun-code-offset n-word-bytes))))))
(ea (- fun-pointer-lowtag (* simple-fun-code-offset n-word-bytes))
result))))
;;;; symbol frobbing
(defun load-symbol-info-vector (result symbol temp)
@ -267,8 +254,7 @@
;; there is an info-vector in the slot, it has at least one element.
;; This would compile to almost the same code without a VOP,
;; but using a jmp around a mov instead.
(inst lea (reg-in-size temp :dword)
(make-ea :dword :base result :disp (- list-pointer-lowtag)))
(inst lea (reg-in-size temp :dword) (ea (- list-pointer-lowtag) result))
(inst test (reg-in-size temp :byte) lowtag-mask)
(inst cmov :e result
(make-ea-for-object-slot result cons-cdr-slot list-pointer-lowtag)))
@ -326,8 +312,8 @@
(:policy :fast-safe)
(:generator 2
(inst mov sap
(make-ea :qword :base thread-base-tn :index n
:scale (ash 1 (- word-shift n-fixnum-tag-bits)))))))
(ea thread-base-tn
n (ash 1 (- word-shift n-fixnum-tag-bits)))))))
(define-vop (halt)
(:generator 1
@ -401,9 +387,9 @@ number of CPU cycles elapsed as secondary value. EXPERIMENTAL."
(:args (count-vector :scs (descriptor-reg)))
(:info index)
(:generator 0
(inst inc (make-ea :qword :base count-vector
:disp (- (* (+ vector-data-offset index) n-word-bytes)
other-pointer-lowtag)))))
(inst inc (ea (- (* (+ vector-data-offset index) n-word-bytes)
other-pointer-lowtag)
count-vector nil nil :qword))))
;;;; Memory barrier support

13
src/compiler/x86-64/type-vops.lisp
View file

@ -21,8 +21,7 @@
;; This is hooey. None of the type-vops presently allow
;; control-stack as a storage class.
((sc-is value control-stack)
(make-ea :byte :base rbp-tn
:disp (frame-byte-offset (tn-offset value))))
(ea (frame-byte-offset (tn-offset value)) rbp-tn nil nil :byte))
(t
value))
fixnum-tag-mask))
@ -33,7 +32,7 @@
(inst jmp (if not-p :nz :z) target))
(defun %lea-for-lowtag-test (temp value lowtag)
(inst lea (reg-in-size temp :dword) (make-ea :dword :base value :disp (- lowtag))))
(inst lea (reg-in-size temp :dword) (ea (- lowtag) value)))
;; Numerics including fixnum, excluding short-float. (INTEGER,RATIONAL)
(defun %test-fixnum-and-headers (value temp target not-p headers)
@ -139,11 +138,9 @@
(or (atom (car headers))
(= (caar headers) bignum-widetag)
(= (cdar headers) complex-array-widetag)))
(make-ea :byte :base value :disp (- lowtag))
(ea (- lowtag) value nil nil :byte)
(progn
(inst mov (reg-in-size temp :dword)
(make-ea :dword :base value
:disp (- lowtag)))
(inst mov (reg-in-size temp :dword) (ea (- lowtag) value))
(reg-in-size temp :byte)))))
((null remaining))
(dolist (widetag except) ; only after loading widetag-tn
@ -399,4 +396,4 @@
(:arg-types * (:constant t))
(:conditional :e)
(:generator 2
(inst cmp (make-ea :byte :base x :disp (- other-pointer-lowtag)) widetag)))
(inst cmp (ea (- other-pointer-lowtag) x nil nil :byte) widetag)))

16
src/compiler/x86-64/values.lisp
View file

@ -40,7 +40,7 @@
(inst jmp :be LOOP)
(inst cld)
DONE
(inst lea rsp-tn (make-ea :qword :base rdi :disp n-word-bytes))
(inst lea rsp-tn (ea n-word-bytes rdi))
(inst sub rdi rsi)
(loop for moved = moved-ptrs then (tn-ref-across moved)
while moved
@ -121,9 +121,7 @@
(immediate
(if (zerop (tn-value skip))
(move src context)
(inst lea src (make-ea :qword :base context
:disp (- (* (tn-value skip)
n-word-bytes))))))
(inst lea src (ea (- (* (tn-value skip) n-word-bytes)) context))))
(any-reg
(cond ((= word-shift n-fixnum-tag-bits)
(move src context)
@ -134,16 +132,14 @@
;; With a stack size of about 2MB, the limit is absurd anyway.
(inst neg skip)
(inst lea src
(make-ea :qword :base context :index skip
:scale (ash 1 (- word-shift n-fixnum-tag-bits))))
(ea context skip (ash 1 (- word-shift n-fixnum-tag-bits))))
(inst neg skip)))))
(unless (eq (tn-kind count) :unused)
(move count num))
(if (location= loop-index num)
(inst shl num (- word-shift n-fixnum-tag-bits))
(inst lea loop-index (make-ea :byte :index num
:scale (ash 1 (- word-shift n-fixnum-tag-bits)))))
(inst lea loop-index (ea nil num (ash 1 (- word-shift n-fixnum-tag-bits)))))
(inst mov start rsp-tn)
(inst jrcxz DONE) ; check for 0 count?
@ -151,9 +147,9 @@
(inst sub src loop-index)
LOOP
(inst mov temp (make-ea :qword :base src :index loop-index))
(inst mov temp (ea src loop-index))
(inst sub loop-index n-word-bytes)
(inst mov (make-ea :qword :base rsp-tn :index loop-index) temp)
(inst mov (ea rsp-tn loop-index) temp)
(inst jmp :nz LOOP)
DONE))

2
tests/assembler.pure.lisp
View file

@ -148,7 +148,7 @@
(try `(bt ,(memref :word) ,ax-tn) "660FA34500 BT WORD PTR [$fp], AX")
(try `(bt ,(memref :dword) ,eax-tn) "0FA34500 BT DWORD PTR [$fp], EAX")
#+x86-64
(try `(bt ,(memref :qword) ,eax-tn) "480FA34500 BT QWORD PTR [$fp], RAX")
(try `(bt ,(memref :qword) ,rax-tn) "480FA34500 BT QWORD PTR [$fp], RAX")
(try `(bt ,(memref :word) 3) "660FBA650003 BT WORD PTR [$fp], 3")
(try `(bt ,(memref :dword) 3) "0FBA650003 BT DWORD PTR [$fp], 3")
#+x86-64

157
tools-for-build/ea-refactor.lisp Normal file
View file

@ -0,0 +1,157 @@
(in-package sb-x86-64-asm)
(defparameter *files*
'("src/assembly/x86-64/arith"
"src/assembly/x86-64/array"
"src/assembly/x86-64/assem-rtns"
"src/assembly/x86-64/support"
"src/assembly/x86-64/tramps"
"src/compiler/x86-64/alloc"
"src/compiler/x86-64/arith"
"src/compiler/x86-64/array"
"src/compiler/x86-64/c-call"
"src/compiler/x86-64/call"
"src/compiler/x86-64/cell"
"src/compiler/x86-64/char"
"src/compiler/x86-64/debug"
"src/compiler/x86-64/float"
"src/compiler/x86-64/macros"
"src/compiler/x86-64/memory"
"src/compiler/x86-64/move"
"src/compiler/x86-64/nlx"
"src/compiler/x86-64/sap"
"src/compiler/x86-64/simd-pack"
"src/compiler/x86-64/system"
"src/compiler/x86-64/type-vops"
"src/compiler/x86-64/values"
))
(defvar sb-vm::+qword-register-names+
#("RAX" "RCX" "RDX" "RBX" "RSP" "RBP" "RSI" "RDI"
"R8" "R9" "R10" "R11" "R12" "R13" "R14" "R15"))
(defun forms-equal (x y)
(sb-int:named-let recurse ((x x) (y y))
(cond ((eql x y) t)
((consp x)
(and (consp y)
(recurse (car x) (car y))
(recurse (cdr x) (cdr y))))
((sb-int:comma-p x)
(and (sb-int:comma-p y)
(eql (sb-int:comma-kind x) (sb-int:comma-kind y))
(recurse (sb-int:comma-expr x) (sb-int:comma-expr y))))
((stringp x) (and (stringp y) (string= x y)))
((pathnamep x) (and (pathnamep y) (pathname= x y)))
((bit-vector-p x) (and (bit-vector-p y) (bit-vector-= x y)))
(t nil))))
(defun tree-find-if (pred tree)
(sb-int:named-let recurse ((subtree tree) (path nil))
(let ((i 0))
(dolist (x subtree)
(let ((path (cons i path)))
(when (funcall pred x)
(return-from tree-find-if (values x (reverse path))))
(when (consp x)
(recurse x path))
(incf i))))))
(defun extract-path (path tree)
(dolist (i path tree)
(setq tree (nth i tree))))
(defun equivalentp (old new)
(unless (and (consp new)
(symbolp (car new))
(string= (car new) "EA"))
(return-from equivalentp nil))
(let ((size (cadr old)))
(destructuring-bind (&key (base nil base-p) (index nil index-p)
(scale nil scale-p) (disp nil disp-p))
(cddr old)
(when (eql disp 0)
(setq disp nil disp-p nil))
(when (some
(lambda (expected)
(forms-equal (cdr new) expected))
(cond ((and base-p (not index-p) (not scale-p) (not disp-p))
(list `(0 ,base) `(,base))) ; two acceptable spellings
((and base-p index-p (not disp-p))
(list `(,base ,index ,@(if scale-p (list scale)))))
((not disp-p) ; omit the leading 'disp'
(list (nconc (if (or base-p index-p scale-p) (list base))
(if (or index-p scale-p) (list index))
(if (or scale-p) (list scale)))))
(t
;; other forms: base+index+disp, index only, displacement only
(list (nconc (list (or disp 0))
(if (or base-p index-p scale-p) (list base))
(if (or index-p scale-p) (list index))
(if (or scale-p) (list scale)))))))
(return-from equivalentp t))
;; the full form with all 5 args is valid, but to specify the last arg,
;; SCALE must be supplied, not defaulted.
(when (and index (not scale-p))
(setq scale 1))
(forms-equal (cdr new)
`(,(or disp 0) ,base ,index ,scale ,size)))))
(defun compare-trees (old-dir new-dir
&aux (total 0) (per-instruction)
(*package* *package*))
(dolist (file *files*)
(format t "processing ~s~%" file)
(with-open-file (f1 (format nil "~a~a.lisp" old-dir file))
(with-open-file (f2 (format nil "~a~a.lisp" new-dir file))
(loop
(let ((form1 (read f1 nil f1))
(form2)
(printed-tlf))
(when (eq form1 f1) (return))
(setq form2 (read f2))
(cond ((and (consp form1) (eq (car form1) 'in-package))
(assert (equal form2 form1))
(eval form1))
((and (consp form1) (eq (car form1) 'eval-when)
(member :compile-toplevel (second form1)))
(assert (forms-equal form2 form1))
(handler-bind ((warning #'muffle-warning))
(mapc 'eval (cddr form1)))))
(unless (forms-equal form2 form1)
(loop
(multiple-value-bind (subform path)
(tree-find-if (lambda (x)
(and (consp x)
(eq (car x) 'make-ea)))
form1)
(unless subform (return))
;; tally
(let ((containing-form (extract-path (butlast path) form1)))
(when (and (symbolp (car containing-form))
(string= (car containing-form) "INST")
(symbolp (cadr containing-form)))
(let* ((sym (cadr containing-form))
(found (assoc sym per-instruction)))
(if found
(incf (cdr found))
(push (cons sym 1) per-instruction)))))
(incf total)
;;
(let ((new-subform (extract-path path form2)))
(unless (equivalentp subform new-subform)
(let ((*print-pretty* nil)
(*print-length* 4)
(*print-level* 2)
(*package* (find-package :keyword)))
(unless printed-tlf
(format t "TLF=~s~%" form1)
(setq printed-tlf t)))
(format t "Possibly non-equivalent:~%~S~%~S~%"
subform new-subform))
(rplaca subform 'splat))))
(when printed-tlf
(format t "--~%"))))))))
(format t "Total: ~d, breakdown:~% ~s~%"
total (sort per-instruction #'> :key #'cdr)))