X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86-64%2Fcall.lisp;h=2b96e42299d1ac6af6467847dcea846934894299;hb=1540c1c1d517c58fa9a41629beb65cdce7dfafb6;hp=b1c53956e786f1db6e7ead9ea2c78d3ad9bbe079;hpb=a3c77b1a48ba90df15e66da44331342ca7657602;p=sbcl.git diff --git a/src/compiler/x86-64/call.lisp b/src/compiler/x86-64/call.lisp index b1c5395..2b96e42 100644 --- a/src/compiler/x86-64/call.lisp +++ b/src/compiler/x86-64/call.lisp @@ -15,7 +15,7 @@ ;;; Return a wired TN describing the N'th full call argument passing ;;; location. -(!def-vm-support-routine standard-arg-location (n) +(defun standard-arg-location (n) (declare (type unsigned-byte n)) (if (< n register-arg-count) (make-wired-tn *backend-t-primitive-type* descriptor-reg-sc-number @@ -26,7 +26,7 @@ ;;; ;;; Always wire the return PC location to the stack in its standard ;;; location. -(!def-vm-support-routine make-return-pc-passing-location (standard) +(defun make-return-pc-passing-location (standard) (declare (ignore standard)) (make-wired-tn (primitive-type-or-lose 'system-area-pointer) sap-stack-sc-number return-pc-save-offset)) @@ -38,7 +38,7 @@ ;;; because we want to be able to assume it's always there. Besides, ;;; the x86 doesn't have enough registers to really make it profitable ;;; to pass it in a register. -(!def-vm-support-routine make-old-fp-passing-location (standard) +(defun make-old-fp-passing-location (standard) (declare (ignore standard)) (make-wired-tn *fixnum-primitive-type* control-stack-sc-number ocfp-save-offset)) @@ -49,12 +49,12 @@ ;;; ;;; Without using a save-tn - which does not make much sense if it is ;;; wired to the stack? -(!def-vm-support-routine make-old-fp-save-location (physenv) +(defun make-old-fp-save-location (physenv) (physenv-debug-live-tn (make-wired-tn *fixnum-primitive-type* control-stack-sc-number ocfp-save-offset) physenv)) -(!def-vm-support-routine make-return-pc-save-location (physenv) +(defun make-return-pc-save-location (physenv) (physenv-debug-live-tn (make-wired-tn (primitive-type-or-lose 'system-area-pointer) sap-stack-sc-number return-pc-save-offset) @@ -63,23 +63,23 @@ ;;; Make a TN for the standard argument count passing location. We only ;;; need to make the standard location, since a count is never passed when we ;;; are using non-standard conventions. -(!def-vm-support-routine make-arg-count-location () +(defun make-arg-count-location () (make-wired-tn *fixnum-primitive-type* any-reg-sc-number rcx-offset)) ;;; Make a TN to hold the number-stack frame pointer. This is allocated ;;; once per component, and is component-live. -(!def-vm-support-routine make-nfp-tn () +(defun make-nfp-tn () (make-restricted-tn *fixnum-primitive-type* ignore-me-sc-number)) -(!def-vm-support-routine make-stack-pointer-tn () +(defun make-stack-pointer-tn () (make-normal-tn *fixnum-primitive-type*)) -(!def-vm-support-routine make-number-stack-pointer-tn () +(defun make-number-stack-pointer-tn () (make-restricted-tn *fixnum-primitive-type* ignore-me-sc-number)) ;;; Return a list of TNs that can be used to represent an unknown-values ;;; continuation within a function. -(!def-vm-support-routine make-unknown-values-locations () +(defun make-unknown-values-locations () (list (make-stack-pointer-tn) (make-normal-tn *fixnum-primitive-type*))) @@ -87,19 +87,9 @@ ;;; VM-dependent initialization of the IR2-COMPONENT structure. We ;;; push placeholder entries in the CONSTANTS to leave room for ;;; additional noise in the code object header. -(!def-vm-support-routine select-component-format (component) +(defun select-component-format (component) (declare (type component component)) - ;; The 1+ here is because for the x86 the first constant is a - ;; pointer to a list of fixups, or NIL if the code object has none. - ;; (If I understand correctly, the fixups are needed at GC copy - ;; time because the X86 code isn't relocatable.) - ;; - ;; KLUDGE: It'd be cleaner to have the fixups entry be a named - ;; element of the CODE (aka component) primitive object. However, - ;; it's currently a large, tricky, error-prone chore to change - ;; the layout of any primitive object, so for the foreseeable future - ;; we'll just live with this ugliness. -- WHN 2002-01-02 - (dotimes (i (1+ code-constants-offset)) + (dotimes (i code-constants-offset) (vector-push-extend nil (ir2-component-constants (component-info component)))) (values)) @@ -443,7 +433,7 @@ :disp (frame-byte-offset (+ sp->fp-offset register-arg-count)))) ;; Do the copy. - (inst shr rcx-tn word-shift) ; make word count + (inst shr rcx-tn n-fixnum-tag-bits) ; make word count (inst std) (inst rep) (inst movs :qword) @@ -455,7 +445,7 @@ ;; If none, then just blow out of here. (inst jmp :le restore-edi) (inst mov rcx-tn rax-tn) - (inst shr rcx-tn word-shift) ; word count + (inst shr rcx-tn n-fixnum-tag-bits) ; word count ;; Load RAX with NIL for fast storing. (inst mov rax-tn nil-value) ;; Do the store. @@ -510,7 +500,15 @@ register-arg-count) (inst cmp nargs (fixnumize register-arg-count)) (inst jmp :g stack-values) + #!+#.(cl:if (cl:= sb!vm:word-shift sb!vm:n-fixnum-tag-bits) '(and) '(or)) (inst sub rsp-tn nargs) + #!-#.(cl:if (cl:= sb!vm:word-shift sb!vm:n-fixnum-tag-bits) '(and) '(or)) + (progn + ;; FIXME: This can't be efficient, but LEA (my first choice) + ;; doesn't do subtraction. + (inst shl nargs (- word-shift n-fixnum-tag-bits)) + (inst sub rsp-tn nargs) + (inst shr nargs (- word-shift n-fixnum-tag-bits))) (emit-label stack-values)) ;; dtc: this writes the registers onto the stack even if they are ;; not needed, only the number specified in rcx are used and have @@ -567,7 +565,7 @@ (emit-label trampoline-label) (popw rbp-tn (frame-word-offset return-pc-save-offset))) (when alignp - (emit-alignment n-lowtag-bits #x90)) + (emit-alignment n-lowtag-bits :long-nop)) (emit-label start-label)) ;;; Non-TR local call for a fixed number of values passed according to @@ -810,6 +808,9 @@ ;; Compute the number of arguments. (noise '(inst mov rcx new-fp)) (noise '(inst sub rcx rsp-tn)) + #.(unless (= word-shift n-fixnum-tag-bits) + '(noise '(inst shr rcx + (- word-shift n-fixnum-tag-bits)))) ;; Move the necessary args to registers, ;; this moves them all even if they are ;; not all needed. @@ -874,11 +875,11 @@ ;; there are at least 3 slots. This hack ;; just adds 3 more. ,(if variable - '(inst sub rsp-tn (fixnumize 3))) + '(inst sub rsp-tn (* 3 n-word-bytes))) ;; Bias the new-fp for use as an fp ,(if variable - '(inst sub new-fp (fixnumize sp->fp-offset))) + '(inst sub new-fp (* sp->fp-offset n-word-bytes))) ;; Save the fp (storew rbp-tn new-fp @@ -1128,15 +1129,19 @@ (inst cmp rcx-tn (fixnumize fixed)) (inst jmp :be JUST-ALLOC-FRAME))) + ;; Create a negated copy of the number of arguments to allow us to + ;; use EA calculations in order to do scaled subtraction. + (inst mov temp rcx-tn) + (inst neg temp) + ;; Allocate the space on the stack. ;; stack = rbp + sp->fp-offset - (max 3 frame-size) - (nargs - fixed) - (inst lea rbx-tn + (inst lea rsp-tn (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) (max 3 (sb-allocated-size 'stack)))))) - (inst sub rbx-tn rcx-tn) ; Got the new stack in rbx - (inst mov rsp-tn rbx-tn) ;; Now: nargs>=1 && nargs>fixed @@ -1156,8 +1161,8 @@ ;; Initialize R8 to be the end of args. (inst lea source (make-ea :qword :base rbp-tn + :index temp :scale (ash 1 (- word-shift n-fixnum-tag-bits)) :disp (* sp->fp-offset n-word-bytes))) - (inst sub source rbx-tn) ;; We need to copy from downwards up to avoid overwriting some of ;; the yet uncopied args. So we need to use R9 as the copy index @@ -1170,7 +1175,7 @@ (inst mov temp (make-ea :qword :base source :index copy-index)) (inst mov (make-ea :qword :base rsp-tn :index copy-index) temp) (inst add copy-index n-word-bytes) - (inst sub rcx-tn n-word-bytes) + (inst sub rcx-tn (fixnumize 1)) (inst jmp :nz COPY-LOOP) DO-REGS @@ -1225,8 +1230,10 @@ (keyword :scs (descriptor-reg any-reg))) (:result-types * *) (:generator 4 - (inst mov value (make-ea :qword :base object :index index)) + (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)))) (define-vop (more-arg) @@ -1240,7 +1247,8 @@ (:generator 4 (move value index) (inst neg value) - (inst mov value (make-ea :qword :base object :index value)))) + (inst mov value (make-ea :qword :base object :index value + :scale (ash 1 (- word-shift n-fixnum-tag-bits)))))) ;;; Turn more arg (context, count) into a list. (define-vop (listify-rest-args) @@ -1265,7 +1273,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 :base rcx :index rcx)) + (inst lea dst (make-ea :qword :index rcx :scale (ash 2 (- word-shift n-fixnum-tag-bits)))) (maybe-pseudo-atomic stack-allocate-p (allocation dst dst node stack-allocate-p list-pointer-lowtag) ;; Set decrement mode (successive args at lower addresses) @@ -1286,7 +1294,7 @@ (inst sub src n-word-bytes) (storew rax dst 0 list-pointer-lowtag) ;; Go back for more. - (inst sub rcx n-word-bytes) + (inst sub rcx (fixnumize 1)) (inst jmp :nz loop) ;; NIL out the last cons. (storew nil-value dst 1 list-pointer-lowtag) @@ -1318,8 +1326,9 @@ ;; 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 1 - :disp (- (+ (fixnumize fixed) n-word-bytes)))) + :index count + :scale (ash 1 (- word-shift n-fixnum-tag-bits)) + :disp (- (* (1+ fixed) n-word-bytes)))) (unless (zerop fixed) (inst sub count (fixnumize fixed)))))