diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp -x external-format-test.txt -x test-status.lisp-expr sbcl-1.0.13-pristine/src/assembly/arm/alloc.lisp sbcl-1.0.13-arm5-pass1/src/assembly/arm/alloc.lisp --- sbcl-1.0.13-pristine/src/assembly/arm/alloc.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-1.0.13-arm5-pass1/src/assembly/arm/alloc.lisp 2007-12-28 17:56:59.167646553 -0500 @@ -0,0 +1,87 @@ +;;;; allocating simple objects + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + +;;;; from signed/unsigned + +;;; KLUDGE: Why don't we want vops for this one and the next +;;; one? -- WHN 19990916 +#+sb-assembling ; We don't want a vop for this one. +(define-assembly-routine + (move-from-signed) + ((:temp eax unsigned-reg eax-offset) + (:temp ebx unsigned-reg ebx-offset)) + (inst mov ebx eax) + (inst shl ebx 1) + (inst jmp :o bignum) + (inst shl ebx 1) + (inst jmp :o bignum) + (inst ret) + BIGNUM + + (with-fixed-allocation (ebx bignum-widetag (+ bignum-digits-offset 1)) + (storew eax ebx bignum-digits-offset other-pointer-lowtag)) + + (inst ret)) + +#+sb-assembling ; We don't want a vop for this one either. +(define-assembly-routine + (move-from-unsigned) + ((:temp eax unsigned-reg eax-offset) + (:temp ebx unsigned-reg ebx-offset)) + + (inst test eax #xe0000000) + (inst jmp :nz bignum) + ;; Fixnum + (inst mov ebx eax) + (inst shl ebx 2) + (inst ret) + + BIGNUM + ;;; Note: On the mips port space for a two word bignum is always + ;;; allocated and the header size is set to either one or two words + ;;; as appropriate. On the mips port this is faster, and smaller + ;;; inline, but produces more garbage. The inline x86 version uses + ;;; the same approach, but here we save garbage and allocate the + ;;; smallest possible bignum. + (inst jmp :ns one-word-bignum) + (inst mov ebx eax) + + ;; Two word bignum + (with-fixed-allocation (ebx bignum-widetag (+ bignum-digits-offset 2)) + (storew eax ebx bignum-digits-offset other-pointer-lowtag)) + (inst ret) + + ONE-WORD-BIGNUM + (with-fixed-allocation (ebx bignum-widetag (+ bignum-digits-offset 1)) + (storew eax ebx bignum-digits-offset other-pointer-lowtag)) + (inst ret)) + +#+sb-assembling +(defun frob-allocation-assembly-routine (obj lowtag arg-tn) + `(define-assembly-routine (,(intern (format nil "ALLOCATE-~A-TO-~A" obj arg-tn))) + ((:temp ,arg-tn descriptor-reg ,(intern (format nil "~A-OFFSET" arg-tn)))) + (pseudo-atomic + (allocation ,arg-tn (pad-data-block ,(intern (format nil "~A-SIZE" obj)))) + (inst lea ,arg-tn (make-ea :byte :base ,arg-tn :disp ,lowtag))) + (inst ret))) + +#+sb-assembling +(macrolet ((frob-cons-routines () + (let ((routines nil)) + (dolist (tn-offset *dword-regs* + `(progn ,@routines)) + (push (frob-allocation-assembly-routine 'cons + list-pointer-lowtag + (intern (aref *dword-register-names* tn-offset))) + routines))))) + (frob-cons-routines)) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp -x external-format-test.txt -x test-status.lisp-expr sbcl-1.0.13-pristine/src/assembly/arm/arith.lisp sbcl-1.0.13-arm5-pass1/src/assembly/arm/arith.lisp --- sbcl-1.0.13-pristine/src/assembly/arm/arith.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-1.0.13-arm5-pass1/src/assembly/arm/arith.lisp 2007-12-28 17:56:59.169646248 -0500 @@ -0,0 +1,368 @@ +;;;; simple cases for generic arithmetic + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + +;;;; addition, subtraction, and multiplication + +(macrolet ((define-generic-arith-routine ((fun cost) &body body) + `(define-assembly-routine (,(symbolicate "GENERIC-" fun) + (:cost ,cost) + (:return-style :full-call) + (:translate ,fun) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) edx-offset) + (:arg y (descriptor-reg any-reg) + ;; this seems wrong esi-offset -- FIXME: What's it mean? + edi-offset) + + (:res res (descriptor-reg any-reg) edx-offset) + + (:temp eax unsigned-reg eax-offset) + (:temp ebx unsigned-reg ebx-offset) + (:temp ecx unsigned-reg ecx-offset)) + + (declare (ignorable ebx)) + + (inst test x 3) ; fixnum? + (inst jmp :nz DO-STATIC-FUN) ; no - do generic + (inst test y 3) ; fixnum? + (inst jmp :z DO-BODY) ; yes - doit here + + DO-STATIC-FUN + (inst pop eax) + (inst push ebp-tn) + (inst lea + ebp-tn + (make-ea :dword :base esp-tn :disp n-word-bytes)) + (inst sub esp-tn (fixnumize 2)) + (inst push eax) ; callers return addr + (inst mov ecx (fixnumize 2)) ; arg count + (inst jmp + (make-ea :dword + :disp (+ nil-value + (static-fun-offset + ',(symbolicate "TWO-ARG-" fun))))) + + DO-BODY + ,@body))) + + (define-generic-arith-routine (+ 10) + (move res x) + (inst add res y) + (inst jmp :no OKAY) + (inst rcr res 1) ; carry has correct sign + (inst sar res 1) ; remove type bits + + (move ecx res) + + (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset)) + (storew ecx res bignum-digits-offset other-pointer-lowtag)) + + OKAY) + + (define-generic-arith-routine (- 10) + (move res x) + (inst sub res y) + (inst jmp :no OKAY) + (inst cmc) ; carry has correct sign now + (inst rcr res 1) + (inst sar res 1) ; remove type bits + + (move ecx res) + + (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset)) + (storew ecx res bignum-digits-offset other-pointer-lowtag)) + OKAY) + + (define-generic-arith-routine (* 30) + (move eax x) ; must use eax for 64-bit result + (inst sar eax 2) ; remove *4 fixnum bias + (inst imul y) ; result in edx:eax + (inst jmp :no okay) ; still fixnum + + ;; zzz jrd changed edx to ebx in here, as edx isn't listed as a temp, above + ;; pfw says that loses big -- edx is target for arg x and result res + ;; note that 'edx' is not defined -- using x + (inst shrd eax x 2) ; high bits from edx + (inst sar x 2) ; now shift edx too + + (move ecx x) ; save high bits from cdq + (inst cdq) ; edx:eax <- sign-extend of eax + (inst cmp x ecx) + (inst jmp :e SINGLE-WORD-BIGNUM) + + (with-fixed-allocation (res bignum-widetag (+ bignum-digits-offset 2)) + (storew eax res bignum-digits-offset other-pointer-lowtag) + (storew ecx res (1+ bignum-digits-offset) other-pointer-lowtag)) + (inst jmp DONE) + + SINGLE-WORD-BIGNUM + + (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset)) + (storew eax res bignum-digits-offset other-pointer-lowtag)) + (inst jmp DONE) + + OKAY + (move res eax) + DONE)) + +;;;; negation + +(define-assembly-routine (generic-negate + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate %negate) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) edx-offset) + (:res res (descriptor-reg any-reg) edx-offset) + + (:temp eax unsigned-reg eax-offset) + (:temp ecx unsigned-reg ecx-offset)) + (inst test x 3) + (inst jmp :z FIXNUM) + + (inst pop eax) + (inst push ebp-tn) + (inst lea ebp-tn (make-ea :dword :base esp-tn :disp n-word-bytes)) + (inst sub esp-tn (fixnumize 2)) + (inst push eax) + (inst mov ecx (fixnumize 1)) ; arg count + (inst jmp (make-ea :dword + :disp (+ nil-value (static-fun-offset '%negate)))) + + FIXNUM + (move res x) + (inst neg res) ; (- most-negative-fixnum) is BIGNUM + (inst jmp :no OKAY) + (inst shr res 2) ; sign bit is data - remove type bits + (move ecx res) + + (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset)) + (storew ecx res bignum-digits-offset other-pointer-lowtag)) + + OKAY) + +;;;; comparison + +(macrolet ((define-cond-assem-rtn (name translate static-fn test) + `(define-assembly-routine (,name + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate ,translate) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) edx-offset) + (:arg y (descriptor-reg any-reg) edi-offset) + + (:res res descriptor-reg edx-offset) + + (:temp eax unsigned-reg eax-offset) + (:temp ecx unsigned-reg ecx-offset)) + + ;; KLUDGE: The "3" here is a mask for the bits which will be + ;; zero in a fixnum. It should have a symbolic name. (Actually, + ;; it might already have a symbolic name which the coder + ;; couldn't be bothered to use..) -- WHN 19990917 + (inst test x 3) + (inst jmp :nz TAIL-CALL-TO-STATIC-FN) + (inst test y 3) + (inst jmp :z INLINE-FIXNUM-COMPARE) + + TAIL-CALL-TO-STATIC-FN + (inst pop eax) + (inst push ebp-tn) + (inst lea ebp-tn (make-ea :dword + :base esp-tn + :disp n-word-bytes)) + (inst sub esp-tn (fixnumize 2)) ; FIXME: Push 2 words on stack, + ; weirdly? + (inst push eax) + (inst mov ecx (fixnumize 2)) ; FIXME: FIXNUMIZE and + ; SINGLE-FLOAT-BITS are parallel, + ; should be named parallelly. + (inst jmp (make-ea :dword + :disp (+ nil-value + (static-fun-offset ',static-fn)))) + + INLINE-FIXNUM-COMPARE + (inst cmp x y) + (inst mov res nil-value) + (inst jmp ,test RETURN-FALSE) + + (load-symbol res t) + + RETURN-FALSE + DONE))) + + (define-cond-assem-rtn generic-< < two-arg-< :ge) + (define-cond-assem-rtn generic-> > two-arg-> :le)) + +(define-assembly-routine (generic-eql + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate eql) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) edx-offset) + (:arg y (descriptor-reg any-reg) edi-offset) + + (:res res descriptor-reg edx-offset) + + (:temp eax unsigned-reg eax-offset) + (:temp ecx unsigned-reg ecx-offset)) + (inst cmp x y) + (inst jmp :e RETURN-T) + (inst test x 3) + (inst jmp :z RETURN-NIL) + (inst test y 3) + (inst jmp :nz DO-STATIC-FN) + + RETURN-NIL + (inst mov res nil-value) + (inst jmp DONE) + + DO-STATIC-FN + (inst pop eax) + (inst push ebp-tn) + (inst lea ebp-tn (make-ea :dword :base esp-tn :disp n-word-bytes)) + (inst sub esp-tn (fixnumize 2)) + (inst push eax) + (inst mov ecx (fixnumize 2)) + (inst jmp (make-ea :dword + :disp (+ nil-value (static-fun-offset 'eql)))) + + RETURN-T + (load-symbol res t) + + DONE) + +(define-assembly-routine (generic-= + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate =) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) edx-offset) + (:arg y (descriptor-reg any-reg) edi-offset) + + (:res res descriptor-reg edx-offset) + + (:temp eax unsigned-reg eax-offset) + (:temp ecx unsigned-reg ecx-offset) + ) + (inst test x 3) ; descriptor? + (inst jmp :nz DO-STATIC-FN) ; yes, do it here + (inst test y 3) ; descriptor? + (inst jmp :nz DO-STATIC-FN) + (inst cmp x y) + (inst jmp :e RETURN-T) ; ok + + (inst mov res nil-value) + (inst jmp DONE) + + DO-STATIC-FN + (inst pop eax) + (inst push ebp-tn) + (inst lea ebp-tn (make-ea :dword :base esp-tn :disp n-word-bytes)) + (inst sub esp-tn (fixnumize 2)) + (inst push eax) + (inst mov ecx (fixnumize 2)) + (inst jmp (make-ea :dword + :disp (+ nil-value (static-fun-offset 'two-arg-=)))) + + RETURN-T + (load-symbol res t) + + DONE) + + +;;; Support for the Mersenne Twister, MT19937, random number generator +;;; due to Matsumoto and Nishimura. +;;; +;;; Makoto Matsumoto and T. Nishimura, "Mersenne twister: A +;;; 623-dimensionally equidistributed uniform pseudorandom number +;;; generator.", ACM Transactions on Modeling and Computer Simulation, +;;; 1997, to appear. +;;; +;;; State: +;;; 0-1: Constant matrix A. [0, #x9908b0df] (not used here) +;;; 2: Index; init. to 1. +;;; 3-626: State. + +;;; This assembly routine is called from the inline VOP and updates +;;; the state vector with new random numbers. The state vector is +;;; passed in the EAX register. +#+sb-assembling ; We don't want a vop for this one. +(define-assembly-routine + (random-mt19937-update) + ((:temp state unsigned-reg eax-offset) + (:temp k unsigned-reg ebx-offset) + (:temp y unsigned-reg ecx-offset) + (:temp tmp unsigned-reg edx-offset)) + + ;; Save the temporary registers. + (inst push k) + (inst push y) + (inst push tmp) + + ;; Generate a new set of results. + (inst xor k k) + LOOP1 + (inst mov y (make-ea-for-vector-data state :index k :offset 3)) + (inst mov tmp (make-ea-for-vector-data state :index k :offset (+ 1 3))) + (inst and y #x80000000) + (inst and tmp #x7fffffff) + (inst or y tmp) + (inst shr y 1) + (inst jmp :nc skip1) + (inst xor y #x9908b0df) + SKIP1 + (inst xor y (make-ea-for-vector-data state :index k :offset (+ 397 3))) + (inst mov (make-ea-for-vector-data state :index k :offset 3) y) + (inst inc k) + (inst cmp k (- 624 397)) + (inst jmp :b loop1) + LOOP2 + (inst mov y (make-ea-for-vector-data state :index k :offset 3)) + (inst mov tmp (make-ea-for-vector-data state :index k :offset (+ 1 3))) + (inst and y #x80000000) + (inst and tmp #x7fffffff) + (inst or y tmp) + (inst shr y 1) + (inst jmp :nc skip2) + (inst xor y #x9908b0df) + SKIP2 + (inst xor y (make-ea-for-vector-data state :index k :offset (+ (- 397 624) 3))) + (inst mov (make-ea-for-vector-data state :index k :offset 3) y) + (inst inc k) + (inst cmp k (- 624 1)) + (inst jmp :b loop2) + + (inst mov y (make-ea-for-vector-data state :offset (+ (- 624 1) 3))) + (inst mov tmp (make-ea-for-vector-data state :offset (+ 0 3))) + (inst and y #x80000000) + (inst and tmp #x7fffffff) + (inst or y tmp) + (inst shr y 1) + (inst jmp :nc skip3) + (inst xor y #x9908b0df) + SKIP3 + (inst xor y (make-ea-for-vector-data state :offset (+ (- 397 1) 3))) + (inst mov (make-ea-for-vector-data state :offset (+ (- 624 1) 3)) y) + + ;; Restore the temporary registers and return. + (inst pop tmp) + (inst pop y) + (inst pop k) + (inst ret)) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp -x external-format-test.txt -x test-status.lisp-expr sbcl-1.0.13-pristine/src/assembly/arm/array.lisp sbcl-1.0.13-arm5-pass1/src/assembly/arm/array.lisp --- sbcl-1.0.13-pristine/src/assembly/arm/array.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-1.0.13-arm5-pass1/src/assembly/arm/array.lisp 2007-12-28 17:56:59.170646095 -0500 @@ -0,0 +1,19 @@ +;;;; various array operations that are too expensive (in space) to do +;;;; inline + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + +;;;; Note: On other platforms ALLOCATE-VECTOR is an assembly routine, +;;;; but on X86 it is a VOP. + +;;;; Note: CMU CL had assembly language primitives for hashing strings, +;;;; but SBCL doesn't. diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp -x external-format-test.txt -x test-status.lisp-expr sbcl-1.0.13-pristine/src/assembly/arm/assem-rtns.lisp sbcl-1.0.13-arm5-pass1/src/assembly/arm/assem-rtns.lisp --- sbcl-1.0.13-pristine/src/assembly/arm/assem-rtns.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-1.0.13-arm5-pass1/src/assembly/arm/assem-rtns.lisp 2007-12-28 17:56:59.171645943 -0500 @@ -0,0 +1,463 @@ +;;;; the machine specific support routines needed by the file assembler + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + +;;;; RETURN-MULTIPLE + +;;; For RETURN-MULTIPLE, we have to move the results from the end of +;;; the frame for the function that is returning to the end of the +;;; frame for the function being returned to. + +#+sb-assembling ;; We don't want a vop for this one. +(define-assembly-routine + (return-multiple (:return-style :none)) + (;; These four are really arguments. + (:temp eax unsigned-reg eax-offset) + (:temp ebx unsigned-reg ebx-offset) + (:temp ecx unsigned-reg ecx-offset) + (:temp esi unsigned-reg esi-offset) + + ;; These we need as temporaries. + (:temp edx unsigned-reg edx-offset) + (:temp edi unsigned-reg edi-offset)) + + ;; Pick off the cases where everything fits in register args. + (inst jecxz zero-values) + (inst cmp ecx (fixnumize 1)) + (inst jmp :e one-value) + (inst cmp ecx (fixnumize 2)) + (inst jmp :e two-values) + (inst cmp ecx (fixnumize 3)) + (inst jmp :e three-values) + + ;; Save the count, because the loop is going to destroy it. + (inst mov edx ecx) + + ;; 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 coping to a larger + ;; address. Therefore, we need to iterate from larger addresses to + ;; smaller addresses. pfw-this says copy ecx words from esi to edi + ;; counting down. + (inst shr ecx 2) ; fixnum to raw word count + (inst std) ; count down + (inst sub esi 4) ; ? + (inst lea edi (make-ea :dword :base ebx :disp (- n-word-bytes))) + (inst rep) + (inst movs :dword) + + ;; solaris requires DF being zero. + #!+sunos (inst cld) + + ;; Restore the count. + (inst mov ecx edx) + + ;; Set the stack top to the last result. + (inst lea esp-tn (make-ea :dword :base edi :disp n-word-bytes)) + + ;; Load the register args. + (loadw edx ebx -1) + (loadw edi ebx -2) + (loadw esi ebx -3) + + ;; And back we go. + (inst stc) + (inst jmp eax) + + ;; Handle the register arg cases. + ZERO-VALUES + (move esp-tn ebx) + (inst mov edx nil-value) + (inst mov edi edx) + (inst mov esi edx) + (inst stc) + (inst jmp eax) + + ONE-VALUE ; Note: we can get this, because the return-multiple vop + ; doesn't check for this case when size > speed. + (loadw edx esi -1) + (inst mov esp-tn ebx) + (inst clc) + (inst jmp eax) + + TWO-VALUES + (loadw edx esi -1) + (loadw edi esi -2) + (inst mov esi nil-value) + (inst lea esp-tn (make-ea :dword :base ebx :disp (* -2 n-word-bytes))) + (inst stc) + (inst jmp eax) + + THREE-VALUES + (loadw edx esi -1) + (loadw edi esi -2) + (loadw esi esi -3) + (inst lea esp-tn (make-ea :dword :base ebx :disp (* -3 n-word-bytes))) + (inst stc) + (inst jmp eax)) + +;;;; TAIL-CALL-VARIABLE + +;;; For tail-call-variable, we have to copy the arguments from the end +;;; of our stack frame (were args are produced) to the start of our +;;; stack frame (were args are expected). +;;; +;;; We take the function to call in EAX and a pointer to the arguments in +;;; ESI. EBP says the same over the jump, and the old frame pointer is +;;; still saved in the first stack slot. The return-pc is saved in +;;; the second stack slot, so we have to push it to make it look like +;;; we actually called. We also have to compute ECX from the difference +;;; between ESI and the stack top. +#+sb-assembling ;; No vop for this one either. +(define-assembly-routine + (tail-call-variable + (:return-style :none)) + + ((:temp eax unsigned-reg eax-offset) + (:temp ebx unsigned-reg ebx-offset) + (:temp ecx unsigned-reg ecx-offset) + (:temp edx unsigned-reg edx-offset) + (:temp edi unsigned-reg edi-offset) + (:temp esi unsigned-reg esi-offset)) + + ;; Calculate NARGS (as a fixnum) + (move ecx esi) + (inst sub ecx esp-tn) + + ;; Check for all the args fitting the registers. + (inst cmp ecx (fixnumize 3)) + (inst jmp :le REGISTER-ARGS) + + ;; Save the OLD-FP and RETURN-PC because the blit it going to trash + ;; those stack locations. Save the ECX, because the loop is going + ;; to trash it. + (pushw ebp-tn -1) + (loadw ebx ebp-tn -2) + (inst push ecx) + + ;; Do the blit. Because we are coping from smaller addresses to + ;; larger addresses, we have to start at the largest pair and work + ;; our way down. + (inst shr ecx 2) ; fixnum to raw words + (inst std) ; count down + (inst lea edi (make-ea :dword :base ebp-tn :disp (- n-word-bytes))) + (inst sub esi (fixnumize 1)) + (inst rep) + (inst movs :dword) + + ;; solaris requires DF being zero. + #!+sunos (inst cld) + + ;; Load the register arguments carefully. + (loadw edx ebp-tn -1) + + ;; Restore OLD-FP and ECX. + (inst pop ecx) + (popw ebp-tn -1) ; overwrites a0 + + ;; Blow off the stack above the arguments. + (inst lea esp-tn (make-ea :dword :base edi :disp n-word-bytes)) + + ;; remaining register args + (loadw edi ebp-tn -2) + (loadw esi ebp-tn -3) + + ;; Push the (saved) return-pc so it looks like we just called. + (inst push ebx) + + ;; And jump into the function. + (inst jmp (make-ea-for-object-slot eax closure-fun-slot fun-pointer-lowtag)) + + ;; All the arguments fit in registers, so load them. + REGISTER-ARGS + (loadw edx esi -1) + (loadw edi esi -2) + (loadw esi esi -3) + + ;; Clear most of the stack. + (inst lea esp-tn + (make-ea :dword :base ebp-tn :disp (* -3 n-word-bytes))) + + ;; Push the return-pc so it looks like we just called. + (pushw ebp-tn -2) + + ;; And away we go. + (inst jmp (make-ea-for-object-slot eax closure-fun-slot fun-pointer-lowtag))) + +(define-assembly-routine (throw + (:return-style :none)) + ((:arg target (descriptor-reg any-reg) edx-offset) + (:arg start any-reg ebx-offset) + (:arg count any-reg ecx-offset) + (:temp catch any-reg eax-offset)) + + (declare (ignore start count)) + + (load-tl-symbol-value catch *current-catch-block*) + + LOOP + + (let ((error (generate-error-code nil unseen-throw-tag-error target))) + (inst or catch catch) ; check for NULL pointer + (inst jmp :z error)) + + (inst cmp target (make-ea-for-object-slot catch catch-block-tag-slot 0)) + (inst jmp :e exit) + + (loadw catch catch catch-block-previous-catch-slot) + (inst jmp loop) + + EXIT + + ;; Here EAX points to catch block containing symbol pointed to by EDX. + (inst jmp (make-fixup 'unwind :assembly-routine))) + +;;;; non-local exit noise + +#!-win32 +(define-assembly-routine (unwind + (:return-style :none) + (:translate %continue-unwind) + (:policy :fast-safe)) + ((:arg block (any-reg descriptor-reg) eax-offset) + (:arg start (any-reg descriptor-reg) ebx-offset) + (:arg count (any-reg descriptor-reg) ecx-offset) + (:temp uwp unsigned-reg esi-offset)) + (declare (ignore start count)) + + (let ((error (generate-error-code nil invalid-unwind-error))) + (inst or block block) ; check for NULL pointer + (inst jmp :z error)) + + (load-tl-symbol-value uwp *current-unwind-protect-block*) + + ;; Does *CURRENT-UNWIND-PROTECT-BLOCK* match the value stored in + ;; argument's CURRENT-UWP-SLOT? + (inst cmp uwp + (make-ea-for-object-slot block unwind-block-current-uwp-slot 0)) + ;; If a match, return to context in arg block. + (inst jmp :e do-exit) + + ;; Not a match - return to *CURRENT-UNWIND-PROTECT-BLOCK* context. + ;; Important! Must save (and return) the arg 'block' for later use!! + (move edx-tn block) + (move block uwp) + ;; Set next unwind protect context. + (loadw uwp uwp unwind-block-current-uwp-slot) + ;; we're about to reload ebp anyway, so let's borrow it here as a + ;; temporary. Hope this works + (store-tl-symbol-value uwp *current-unwind-protect-block* ebp-tn) + + DO-EXIT + + (loadw ebp-tn block unwind-block-current-cont-slot) + + ;; Uwp-entry expects some things in known locations so that they can + ;; be saved on the stack: the block in edx-tn, start in ebx-tn, and + ;; count in ecx-tn. + + (inst jmp (make-ea-for-object-slot block unwind-block-entry-pc-slot 0))) + + +;;;; Win32 non-local exit noise + +#!+win32 +(define-assembly-routine (unwind + (:return-style :none) + (:policy :fast-safe)) + ((:arg block (any-reg descriptor-reg) eax-offset) + (:arg start (any-reg descriptor-reg) ebx-offset) + (:arg count (any-reg descriptor-reg) ecx-offset)) + (declare (ignore start count)) + + (let ((error (generate-error-code nil invalid-unwind-error))) + (inst or block block) ; check for NULL pointer + (inst jmp :z error)) + + ;; Save all our registers, as we're about to clobber them. + (inst pusha) + + ;; Find the SEH frame surrounding our target. + (loadw ecx-tn block unwind-block-next-seh-frame-slot) + + ;; This section copied from VOP CALL-OUT. + ;; Setup the NPX for C; all the FP registers need to be + ;; empty; pop them all. + (dotimes (i 8) + (inst fstp fr0-tn)) + + ;; I'm unlikely to ever forget this again. + (inst cld) + + ;; Set up a bogus stack frame for RtlUnwind to pick its return + ;; address from. (Yes, this is how RtlUnwind works.) + (inst push (make-fixup 'win32-unwind-tail :assembly-routine)) + (inst push ebp-tn) + (inst mov ebp-tn esp-tn) + + ;; Actually call out for the unwind. + (inst push 0) + (inst push 0) + (inst push 0) + (inst push ecx-tn) + (inst call (make-fixup "RtlUnwind@16" :foreign))) + +;; We want no VOP for this one and for it to only happen on Win32 +;; targets. Hence the following disaster. +#!+#.(cl:if (cl:member sb-assembling cl:*features*) win32 '(or)) +(define-assembly-routine + (win32-unwind-tail (:return-style :none)) + ((:temp block unsigned-reg eax-offset)) + + ;; The unwind returns here. Had to use a VOP for this because + ;; PUSH won't accept a label as an argument. + + ;; Clean up the bogus stack frame we pushed for the unwind. + (inst pop ebp-tn) + (inst pop esi-tn) ;; Random scratch register. + + ;; This section based on VOP CALL-OUT. + ;; Restore the NPX for lisp; ensure no regs are empty + (dotimes (i 8) + (inst fldz)) + + ;; Restore our regs. + (inst popa) + + ;; By now we've unwound all the UWP frames required, so we + ;; just jump to our target block. + (loadw ebp-tn block unwind-block-current-cont-slot) + + ;; Nlx-entry expects the arg start in ebx-tn and the arg count + ;; in ecx-tn. Fortunately, that's where they are already. + (inst jmp (make-ea-for-object-slot block unwind-block-entry-pc-slot 0))) + + +;;;; Win32 UWP block SEH interface. + +;; We want no VOP for this one and for it to only happen on Win32 +;; targets. Hence the following disaster. +#!+#.(cl:if (cl:member sb-assembling cl:*features*) win32 '(or)) +(define-assembly-routine + (uwp-seh-handler (:return-style :none)) + ((:temp block unsigned-reg eax-offset)) + + ;; We get called for any exception which happens within our + ;; dynamic contour that isn't handled below us, and for + ;; unwinding. + + ;; For the exceptions we just return ExceptionContinueSearch. + + ;; Find the exception record. + (inst mov eax-tn (make-ea :dword :base esp-tn :disp 4)) + + ;; Check unwind flags. + (inst test (make-ea :byte :base eax-tn :disp 4) 6) ; EH_UNWINDING | EH_EXIT_UNWIND + + ;; To see if we're unwinding or not. + (inst jmp :nz UNWINDING) + + ;; We're not unwinding, so we're not interested. + (inst mov eax-tn 1) ;; exception-continue-search + (inst ret) + + ;; For the unwinds we establish a basic environment as per + ;; call_into_lisp, but without the extra SEH frame (the theory + ;; being that we're already in a Lisp SEH context), and invoke + ;; our UWP block to unwind itself. + + ;; FIXME: Do we need to establish an SEH frame anyway? And do + ;; we need to do the same stack frame hackery for the debugger + ;; as we do for the main exception handler? + + ;; When the UWP block calls %continue-unwind, we come back to + ;; the next assembly routine, below, which reinitializes for C + ;; and returns to the Win32 unwind machinery. + + ;; If the UWP block sees fit to do a non-local exit, things + ;; Just Work, thanks to the Win32 API being sanely designed + ;; and our complying with it. + + ;; We also must update *current-unwind-protect-block* before + ;; calling the cleanup function. + + UNWINDING + + ;; Save all registers (overkill) + (inst pusha) + + ;; Establish our stack frame. + (inst mov ebp-tn esp-tn) + + ;; This section based on VOP CALL-OUT. + ;; Restore the NPX for lisp; ensure no regs are empty + (dotimes (i 8) + (inst fldz)) + + ;; Find our unwind-block by way of our SEH frame. + (inst mov block (make-ea :dword :base ebp-tn :disp #x28)) + (inst lea block (make-ea :dword :base block + :disp (- (* unwind-block-next-seh-frame-slot + n-word-bytes)))) + + ;; Update *CURRENT-UNWIND-PROTECT-BLOCK*. + (loadw ebx-tn block unwind-block-current-uwp-slot) + (store-tl-symbol-value ebx-tn *current-unwind-protect-block* ecx-tn) + + ;; Uwp-entry expects some things in known locations so that they can + ;; be saved on the stack: the block in edx-tn, start in ebx-tn, and + ;; count in ecx-tn. We don't actually have any of that here, but we + ;; do need to have access to our own stack frame, so we hijack the + ;; known locations to cover our own state. + + (inst xor ebx-tn ebx-tn) + (inst xor ecx-tn ecx-tn) + (inst mov ebx-tn ebp-tn) + (loadw ebp-tn block unwind-block-current-cont-slot) + (inst jmp (make-ea-for-object-slot block unwind-block-entry-pc-slot 0))) + +#!+win32 +(define-assembly-routine (continue-unwind + (:return-style :none) + (:translate %continue-unwind) + (:policy :fast-safe)) + ((:arg block (any-reg descriptor-reg) eax-offset) + (:arg start (any-reg descriptor-reg) ebx-offset) + (:arg count (any-reg descriptor-reg) ecx-offset)) + (declare (ignore block count)) + ;; The args here are mostly ignored because we're using the + ;; win32 unwind mechanism and keep all that elsewhere. The + ;; exception is START, which we use to pass the saved EBP for + ;; our exception handler. + + ;; "All" we have to do here is reload our EBP, reestablish a C + ;; environment, and return ExceptionContinueSearch. The OS + ;; handles the rest. + + ;; Restore our frame pointer. + (inst mov esp-tn start) + + ;; This section copied from VOP CALL-OUT. + ;; Setup the NPX for C; all the FP registers need to be + ;; empty; pop them all. + (dotimes (i 8) + (inst fstp fr0-tn)) + + ;; I'm unlikely to ever forget this again. + (inst cld) + + ;; Restore our saved registers + (inst popa) + + ;; And we're done. + (inst mov eax-tn 1) ;; exception-continue-search + (inst ret)) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp -x external-format-test.txt -x test-status.lisp-expr sbcl-1.0.13-pristine/src/assembly/arm/bit-bash.lisp sbcl-1.0.13-arm5-pass1/src/assembly/arm/bit-bash.lisp --- sbcl-1.0.13-pristine/src/assembly/arm/bit-bash.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-1.0.13-arm5-pass1/src/assembly/arm/bit-bash.lisp 2007-12-28 17:56:59.172645790 -0500 @@ -0,0 +1,12 @@ +;;;; just a dummy file to maintain parallelism with other VMs + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp -x external-format-test.txt -x test-status.lisp-expr sbcl-1.0.13-pristine/src/assembly/arm/support.lisp sbcl-1.0.13-arm5-pass1/src/assembly/arm/support.lisp --- sbcl-1.0.13-pristine/src/assembly/arm/support.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-1.0.13-arm5-pass1/src/assembly/arm/support.lisp 2007-12-28 17:56:59.173645638 -0500 @@ -0,0 +1,54 @@ +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + +;;; The :full-call assembly-routines must use the same full-call +;;; unknown-values return convention as a normal call, as some +;;; of the routines will tail-chain to a static-function. The +;;; routines themselves, however, take all of their arguments +;;; in registers (this will typically be one or two arguments, +;;; and is one of the lower bounds on the number of argument- +;;; passing registers), and thus don't need a call frame, which +;;; simplifies things for the normal call/return case. When it +;;; is neccessary for one of the assembly-functions to call a +;;; static-function it will construct the required call frame. +;;; Also, none of the assembly-routines return other than one +;;; value, which again simplifies the return path. +;;; -- AB, 2006/Feb/05. + +(!def-vm-support-routine generate-call-sequence (name style vop) + (ecase style + ((:raw :none) + (values + `((inst call (make-fixup ',name :assembly-routine))) + nil)) + (:full-call + (values + `((note-this-location ,vop :call-site) + (inst call (make-fixup ',name :assembly-routine)) + (note-this-location ,vop :single-value-return) + (cond + ((member :cmov *backend-subfeatures*) + (inst cmov :c esp-tn ebx-tn)) + (t + (let ((single-value (gen-label))) + (inst jmp :nc single-value) + (move esp-tn ebx-tn) + (emit-label single-value))))) + '((:save-p :compute-only)))))) + +(!def-vm-support-routine generate-return-sequence (style) + (ecase style + (:raw + `(inst ret)) + (:full-call + `((inst clc) + (inst ret))) + (:none))) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp -x external-format-test.txt -x test-status.lisp-expr sbcl-1.0.13-pristine/src/compiler/arm/alloc.lisp sbcl-1.0.13-arm5-pass1/src/compiler/arm/alloc.lisp --- sbcl-1.0.13-pristine/src/compiler/arm/alloc.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-1.0.13-arm5-pass1/src/compiler/arm/alloc.lisp 2007-12-28 17:57:08.111282145 -0500 @@ -0,0 +1,337 @@ +;;;; allocation VOPs for the x86 + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + +;;;; CONS, LIST and LIST* +(defoptimizer (cons stack-allocate-result) ((&rest args)) + t) +(defoptimizer (list stack-allocate-result) ((&rest args)) + (not (null args))) +(defoptimizer (list* stack-allocate-result) ((&rest args)) + (not (null (rest args)))) + +(define-vop (list-or-list*) + (:args (things :more t)) + (:temporary (:sc unsigned-reg) ptr temp) + (:temporary (:sc unsigned-reg :to (:result 0) :target result) res) + (:info num) + (:results (result :scs (descriptor-reg))) + (:variant-vars star) + (:policy :safe) + (:node-var node) + (:generator 0 + (cond ((zerop num) + ;; (move result nil-value) + (inst mov result nil-value)) + ((and star (= num 1)) + (move result (tn-ref-tn things))) + (t + (macrolet + ((store-car (tn list &optional (slot cons-car-slot)) + `(let ((reg + (sc-case ,tn + ((any-reg descriptor-reg) ,tn) + ((control-stack) + (move temp ,tn) + temp)))) + (storew reg ,list ,slot list-pointer-lowtag)))) + (let ((cons-cells (if star (1- num) num))) + (pseudo-atomic + (allocation res (* (pad-data-block cons-size) cons-cells) node + (awhen (sb!c::node-lvar node) (sb!c::lvar-dynamic-extent it))) + (inst lea res + (make-ea :byte :base res :disp list-pointer-lowtag)) + (move ptr res) + (dotimes (i (1- cons-cells)) + (store-car (tn-ref-tn things) ptr) + (setf things (tn-ref-across things)) + (inst add ptr (pad-data-block cons-size)) + (storew ptr ptr (- cons-cdr-slot cons-size) + list-pointer-lowtag)) + (store-car (tn-ref-tn things) ptr) + (cond (star + (setf things (tn-ref-across things)) + (store-car (tn-ref-tn things) ptr cons-cdr-slot)) + (t + (storew nil-value ptr cons-cdr-slot + list-pointer-lowtag))) + (aver (null (tn-ref-across things))))) + (move result res)))))) + +(define-vop (list list-or-list*) + (:variant nil)) + +(define-vop (list* list-or-list*) + (:variant t)) + +;;;; special-purpose inline allocators + +;;; ALLOCATE-VECTOR +(define-vop (allocate-vector-on-heap) + (:args (type :scs (unsigned-reg immediate)) + (length :scs (any-reg immediate)) + (words :scs (any-reg immediate))) + (:results (result :scs (descriptor-reg) :from :load)) + (:arg-types positive-fixnum + positive-fixnum + positive-fixnum) + (:policy :fast-safe) + (:generator 100 + (let ((size (sc-case words + (immediate + (logandc2 (+ (fixnumize (tn-value words)) + (+ (1- (ash 1 n-lowtag-bits)) + (* vector-data-offset n-word-bytes))) + lowtag-mask)) + (t + (inst lea result (make-ea :byte :base words :disp + (+ (1- (ash 1 n-lowtag-bits)) + (* vector-data-offset + n-word-bytes)))) + (inst and result (lognot lowtag-mask)) + result)))) + (pseudo-atomic + (allocation result size) + (inst lea result (make-ea :byte :base result :disp other-pointer-lowtag)) + (sc-case type + (immediate + (aver (typep (tn-value type) '(unsigned-byte 8))) + (storeb (tn-value type) result 0 other-pointer-lowtag)) + (t + (storew type result 0 other-pointer-lowtag))) + (sc-case length + (immediate + (let ((fixnum-length (fixnumize (tn-value length)))) + (typecase fixnum-length + ((unsigned-byte 8) + (storeb fixnum-length result + vector-length-slot other-pointer-lowtag)) + (t + (storew fixnum-length result + vector-length-slot other-pointer-lowtag))))) + (t + (storew length result vector-length-slot other-pointer-lowtag))))))) + +(define-vop (allocate-vector-on-stack) + (:args (type :scs (unsigned-reg immediate)) + (length :scs (any-reg)) + (words :scs (any-reg) :target ecx)) + (:temporary (:sc any-reg :offset ecx-offset :from (:argument 2)) ecx) + (:temporary (:sc any-reg :offset eax-offset :from (:argument 2)) zero) + (:temporary (:sc any-reg :offset edi-offset :from (:argument 0)) res) + (:results (result :scs (descriptor-reg) :from :load)) + (:arg-types positive-fixnum + positive-fixnum + positive-fixnum) + (:translate allocate-vector) + (:policy :fast-safe) + (:node-var node) + (:generator 100 + (inst lea result (make-ea :byte :base words :disp + (+ (1- (ash 1 n-lowtag-bits)) + (* vector-data-offset n-word-bytes)))) + (inst and result (lognot lowtag-mask)) + ;; FIXME: It would be good to check for stack overflow here. + (move ecx words) + (inst shr ecx n-fixnum-tag-bits) + (allocation result result node t) + (inst cld) + (inst lea res + (make-ea :byte :base result :disp (* vector-data-offset n-word-bytes))) + (inst lea result (make-ea :byte :base result :disp other-pointer-lowtag)) + (sc-case type + (immediate + (aver (typep (tn-value type) '(unsigned-byte 8))) + (storeb (tn-value type) result 0 other-pointer-lowtag)) + (t + (storew type result 0 other-pointer-lowtag))) + (storew length result vector-length-slot other-pointer-lowtag) + (inst xor zero zero) + (inst rep) + (inst stos zero))) + +(in-package "SB!C") + +(defoptimizer (allocate-vector stack-allocate-result) + ((type length words) node) + (ecase (policy node stack-allocate-vector) + (0 nil) + ((1 2) + ;; a vector object should fit in one page + (values-subtypep (lvar-derived-type words) + (load-time-value + (specifier-type `(integer 0 ,(- (/ sb!vm::*backend-page-size* + sb!vm:n-word-bytes) + sb!vm:vector-data-offset)))))) + (3 t))) + +(defoptimizer (allocate-vector ltn-annotate) ((type length words) call ltn-policy) + (let ((args (basic-combination-args call)) + (template (template-or-lose (if (awhen (node-lvar call) + (lvar-dynamic-extent it)) + 'sb!vm::allocate-vector-on-stack + 'sb!vm::allocate-vector-on-heap)))) + (dolist (arg args) + (setf (lvar-info arg) + (make-ir2-lvar (primitive-type (lvar-type arg))))) + (unless (is-ok-template-use template call (ltn-policy-safe-p ltn-policy)) + (ltn-default-call call) + (return-from allocate-vector-ltn-annotate-optimizer (values))) + (setf (basic-combination-info call) template) + (setf (node-tail-p call) nil) + + (dolist (arg args) + (annotate-1-value-lvar arg)))) + +(in-package "SB!VM") + +;;; +(define-vop (allocate-code-object) + (:args (boxed-arg :scs (any-reg) :target boxed) + (unboxed-arg :scs (any-reg) :target unboxed)) + (:results (result :scs (descriptor-reg) :from :eval)) + (:temporary (:sc unsigned-reg :from (:argument 0)) boxed) + (:temporary (:sc unsigned-reg :from (:argument 1)) unboxed) + (:node-var node) + (:generator 100 + (move boxed boxed-arg) + (inst add boxed (fixnumize (1+ code-trace-table-offset-slot))) + (inst and boxed (lognot lowtag-mask)) + (move unboxed unboxed-arg) + (inst shr unboxed word-shift) + (inst add unboxed lowtag-mask) + (inst and unboxed (lognot lowtag-mask)) + (inst mov result boxed) + (inst add result unboxed) + (pseudo-atomic + (allocation result result node) + (inst lea result (make-ea :byte :base result :disp other-pointer-lowtag)) + (inst shl boxed (- n-widetag-bits word-shift)) + (inst or boxed code-header-widetag) + (storew boxed result 0 other-pointer-lowtag) + (storew unboxed result code-code-size-slot other-pointer-lowtag) + (storew nil-value result code-entry-points-slot other-pointer-lowtag)) + (storew nil-value result code-debug-info-slot other-pointer-lowtag))) + +(define-vop (make-fdefn) + (:policy :fast-safe) + (:translate make-fdefn) + (:args (name :scs (descriptor-reg) :to :eval)) + (:results (result :scs (descriptor-reg) :from :argument)) + (:node-var node) + (:generator 37 + (with-fixed-allocation (result fdefn-widetag fdefn-size node) + (storew name result fdefn-name-slot other-pointer-lowtag) + (storew nil-value result fdefn-fun-slot other-pointer-lowtag) + (storew (make-fixup "undefined_tramp" :foreign) + result fdefn-raw-addr-slot other-pointer-lowtag)))) + +(define-vop (make-closure) + (:args (function :to :save :scs (descriptor-reg))) + (:info length stack-allocate-p) + (:temporary (:sc any-reg) temp) + (:results (result :scs (descriptor-reg))) + (:node-var node) + (:generator 10 + (maybe-pseudo-atomic stack-allocate-p + (let ((size (+ length closure-info-offset))) + (allocation result (pad-data-block size) node + stack-allocate-p) + (inst lea result + (make-ea :byte :base result :disp fun-pointer-lowtag)) + (storew (logior (ash (1- size) n-widetag-bits) closure-header-widetag) + result 0 fun-pointer-lowtag)) + (loadw temp function closure-fun-slot fun-pointer-lowtag) + (storew temp result closure-fun-slot fun-pointer-lowtag)))) + +;;; The compiler likes to be able to directly make value cells. +(define-vop (make-value-cell) + (:args (value :scs (descriptor-reg any-reg) :to :result)) + (:results (result :scs (descriptor-reg) :from :eval)) + (:info stack-allocate-p) + (:node-var node) + (:generator 10 + (with-fixed-allocation + (result value-cell-header-widetag value-cell-size node stack-allocate-p) + (storew value result value-cell-value-slot other-pointer-lowtag)))) + +;;;; automatic allocators for primitive objects + +(define-vop (make-unbound-marker) + (:args) + (:results (result :scs (any-reg))) + (:generator 1 + (inst mov result unbound-marker-widetag))) + +(define-vop (make-funcallable-instance-tramp) + (:args) + (:results (result :scs (any-reg))) + (:generator 1 + (inst lea result (make-fixup "funcallable_instance_tramp" :foreign)))) + +(define-vop (fixed-alloc) + (:args) + (:info name words type lowtag stack-allocate-p) + (:ignore name) + (:results (result :scs (descriptor-reg))) + (:node-var node) + (:generator 50 + ;; We special case the allocation of conses, because they're + ;; extremely common and because the pseudo-atomic sequence on x86 + ;; is relatively heavyweight. However, if the user asks for top + ;; speed, we accomodate him. The primary reason that we don't + ;; also check for (< SPEED SPACE) is because we want the space + ;; savings that these out-of-line allocation routines bring whilst + ;; compiling SBCL itself. --njf, 2006-07-08 + (if (and (not stack-allocate-p) + (= lowtag list-pointer-lowtag) (policy node (< speed 3))) + (let ((dst + ;; FIXME: out-of-line dx-allocation + #.(loop for offset in *dword-regs* + collect `(,offset + ',(intern (format nil "ALLOCATE-CONS-TO-~A" + (svref *dword-register-names* + offset)))) into cases + finally (return `(case (tn-offset result) + ,@cases))))) + (aver (null type)) + (inst call (make-fixup dst :assembly-routine))) + (pseudo-atomic + (allocation result (pad-data-block words) node stack-allocate-p) + (inst lea result (make-ea :byte :base result :disp lowtag)) + (when type + (storew (logior (ash (1- words) n-widetag-bits) type) + result + 0 + lowtag)))))) + +(define-vop (var-alloc) + (:args (extra :scs (any-reg))) + (:arg-types positive-fixnum) + (:info name words type lowtag) + (:ignore name) + (:results (result :scs (descriptor-reg) :from (:eval 1))) + (:temporary (:sc any-reg :from :eval :to (:eval 1)) bytes) + (:temporary (:sc any-reg :from :eval :to :result) header) + (:node-var node) + (:generator 50 + (inst lea bytes + (make-ea :dword :base extra :disp (* (1+ words) n-word-bytes))) + (inst mov header bytes) + (inst shl header (- n-widetag-bits 2)) ; w+1 to length field + (inst lea header ; (w-1 << 8) | type + (make-ea :dword :base header :disp (+ (ash -2 n-widetag-bits) type))) + (inst and bytes (lognot lowtag-mask)) + (pseudo-atomic + (allocation result bytes node) + (inst lea result (make-ea :byte :base result :disp lowtag)) + (storew header result 0 lowtag)))) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp -x external-format-test.txt -x test-status.lisp-expr sbcl-1.0.13-pristine/src/compiler/arm/arith.lisp sbcl-1.0.13-arm5-pass1/src/compiler/arm/arith.lisp --- sbcl-1.0.13-pristine/src/compiler/arm/arith.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-1.0.13-arm5-pass1/src/compiler/arm/arith.lisp 2007-12-28 17:57:08.121280620 -0500 @@ -0,0 +1,1899 @@ +;;;; the VM definition of arithmetic VOPs for the x86 + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + +;;;; unary operations + +(define-vop (fast-safe-arith-op) + (:policy :fast-safe) + (:effects) + (:affected)) + +(define-vop (fixnum-unop fast-safe-arith-op) + (:args (x :scs (any-reg) :target res)) + (:results (res :scs (any-reg))) + (:note "inline fixnum arithmetic") + (:arg-types tagged-num) + (:result-types tagged-num)) + +(define-vop (signed-unop fast-safe-arith-op) + (:args (x :scs (signed-reg) :target res)) + (:results (res :scs (signed-reg))) + (:note "inline (signed-byte 32) arithmetic") + (:arg-types signed-num) + (:result-types signed-num)) + +(define-vop (fast-negate/fixnum fixnum-unop) + (:translate %negate) + (:generator 1 + (move res x) + (inst neg res))) + +(define-vop (fast-negate/signed signed-unop) + (:translate %negate) + (:generator 2 + (move res x) + (inst neg res))) + +(define-vop (fast-lognot/fixnum fixnum-unop) + (:translate lognot) + (:generator 2 + (move res x) + (inst xor res (fixnumize -1)))) + +(define-vop (fast-lognot/signed signed-unop) + (:translate lognot) + (:generator 1 + (move res x) + (inst not res))) + +;;;; binary fixnum operations + +;;; Assume that any constant operand is the second arg... + +(define-vop (fast-fixnum-binop fast-safe-arith-op) + (:args (x :target r :scs (any-reg) + :load-if (not (and (sc-is x control-stack) + (sc-is y any-reg) + (sc-is r control-stack) + (location= x r)))) + (y :scs (any-reg control-stack))) + (:arg-types tagged-num tagged-num) + (:results (r :scs (any-reg) :from (:argument 0) + :load-if (not (and (sc-is x control-stack) + (sc-is y any-reg) + (sc-is r control-stack) + (location= x r))))) + (:result-types tagged-num) + (:note "inline fixnum arithmetic")) + +(define-vop (fast-unsigned-binop fast-safe-arith-op) + (:args (x :target r :scs (unsigned-reg) + :load-if (not (and (sc-is x unsigned-stack) + (sc-is y unsigned-reg) + (sc-is r unsigned-stack) + (location= x r)))) + (y :scs (unsigned-reg unsigned-stack))) + (:arg-types unsigned-num unsigned-num) + (:results (r :scs (unsigned-reg) :from (:argument 0) + :load-if (not (and (sc-is x unsigned-stack) + (sc-is y unsigned-reg) + (sc-is r unsigned-stack) + (location= x r))))) + (:result-types unsigned-num) + (:note "inline (unsigned-byte 32) arithmetic")) + +(define-vop (fast-signed-binop fast-safe-arith-op) + (:args (x :target r :scs (signed-reg) + :load-if (not (and (sc-is x signed-stack) + (sc-is y signed-reg) + (sc-is r signed-stack) + (location= x r)))) + (y :scs (signed-reg signed-stack))) + (:arg-types signed-num signed-num) + (:results (r :scs (signed-reg) :from (:argument 0) + :load-if (not (and (sc-is x signed-stack) + (sc-is y signed-reg) + (sc-is r signed-stack) + (location= x r))))) + (:result-types signed-num) + (:note "inline (signed-byte 32) arithmetic")) + +(define-vop (fast-fixnum-binop-c fast-safe-arith-op) + (:args (x :target r :scs (any-reg control-stack))) + (:info y) + (:arg-types tagged-num (:constant (signed-byte 30))) + (:results (r :scs (any-reg) + :load-if (not (location= x r)))) + (:result-types tagged-num) + (:note "inline fixnum arithmetic")) + +(define-vop (fast-unsigned-binop-c fast-safe-arith-op) + (:args (x :target r :scs (unsigned-reg unsigned-stack))) + (:info y) + (:arg-types unsigned-num (:constant (unsigned-byte 32))) + (:results (r :scs (unsigned-reg) + :load-if (not (location= x r)))) + (:result-types unsigned-num) + (:note "inline (unsigned-byte 32) arithmetic")) + +(define-vop (fast-signed-binop-c fast-safe-arith-op) + (:args (x :target r :scs (signed-reg signed-stack))) + (:info y) + (:arg-types signed-num (:constant (signed-byte 32))) + (:results (r :scs (signed-reg) + :load-if (not (location= x r)))) + (:result-types signed-num) + (:note "inline (signed-byte 32) arithmetic")) + +(macrolet ((define-binop (translate untagged-penalty op) + `(progn + (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM") + fast-fixnum-binop) + (:translate ,translate) + (:generator 2 + (move r x) + (inst ,op r y))) + (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum) + fast-fixnum-binop-c) + (:translate ,translate) + (:generator 1 + (move r x) + (inst ,op r (fixnumize y)))) + (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED") + fast-signed-binop) + (:translate ,translate) + (:generator ,(1+ untagged-penalty) + (move r x) + (inst ,op r y))) + (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed) + fast-signed-binop-c) + (:translate ,translate) + (:generator ,untagged-penalty + (move r x) + (inst ,op r y))) + (define-vop (,(symbolicate "FAST-" + translate + "/UNSIGNED=>UNSIGNED") + fast-unsigned-binop) + (:translate ,translate) + (:generator ,(1+ untagged-penalty) + (move r x) + (inst ,op r y))) + (define-vop (,(symbolicate 'fast- + translate + '-c/unsigned=>unsigned) + fast-unsigned-binop-c) + (:translate ,translate) + (:generator ,untagged-penalty + (move r x) + ,(if (eq translate 'logand) + ;; for the -C/UNSIGNED=>UNSIGNED VOP, this case + ;; is optimized away as an identity somewhere + ;; along the lines. However, this VOP is used in + ;; -C/SIGNED=>UNSIGNED, below, when the + ;; higher-level lisp code can't optimize away the + ;; non-trivial identity. + `(unless (= y #.(1- (ash 1 n-word-bits))) + (inst ,op r y)) + `(inst ,op r y))))))) + (define-binop - 4 sub) + (define-binop logand 2 and) + (define-binop logior 2 or) + (define-binop logxor 2 xor)) + +;;; Special handling of add on the x86; can use lea to avoid a +;;; register load, otherwise it uses add. +(define-vop (fast-+/fixnum=>fixnum fast-safe-arith-op) + (:translate +) + (:args (x :scs (any-reg) :target r + :load-if (not (and (sc-is x control-stack) + (sc-is y any-reg) + (sc-is r control-stack) + (location= x r)))) + (y :scs (any-reg control-stack))) + (:arg-types tagged-num tagged-num) + (:results (r :scs (any-reg) :from (:argument 0) + :load-if (not (and (sc-is x control-stack) + (sc-is y any-reg) + (sc-is r control-stack) + (location= x r))))) + (:result-types tagged-num) + (:note "inline fixnum arithmetic") + (: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 :dword :base x :index y :scale 1))) + (t + (move r x) + (inst add r y))))) + +(define-vop (fast-+-c/fixnum=>fixnum fast-safe-arith-op) + (:translate +) + (:args (x :target r :scs (any-reg control-stack))) + (:info y) + (:arg-types tagged-num (:constant (signed-byte 30))) + (:results (r :scs (any-reg) + :load-if (not (location= x r)))) + (:result-types tagged-num) + (:note "inline fixnum arithmetic") + (:generator 1 + (cond ((and (sc-is x any-reg) (sc-is r any-reg) (not (location= x r))) + (inst lea r (make-ea :dword :base x :disp (fixnumize y)))) + (t + (move r x) + (inst add r (fixnumize y)))))) + +(define-vop (fast-+/signed=>signed fast-safe-arith-op) + (:translate +) + (:args (x :scs (signed-reg) :target r + :load-if (not (and (sc-is x signed-stack) + (sc-is y signed-reg) + (sc-is r signed-stack) + (location= x r)))) + (y :scs (signed-reg signed-stack))) + (:arg-types signed-num signed-num) + (:results (r :scs (signed-reg) :from (:argument 0) + :load-if (not (and (sc-is x signed-stack) + (sc-is y signed-reg) + (location= x r))))) + (:result-types signed-num) + (:note "inline (signed-byte 32) arithmetic") + (: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 :dword :base x :index y :scale 1))) + (t + (move r x) + (inst add r y))))) + +;;;; Special logand cases: (logand signed unsigned) => unsigned + +(define-vop (fast-logand/signed-unsigned=>unsigned + fast-logand/unsigned=>unsigned) + (:args (x :target r :scs (signed-reg) + :load-if (not (and (sc-is x signed-stack) + (sc-is y unsigned-reg) + (sc-is r unsigned-stack) + (location= x r)))) + (y :scs (unsigned-reg unsigned-stack))) + (:arg-types signed-num unsigned-num)) + +(define-vop (fast-logand-c/signed-unsigned=>unsigned + fast-logand-c/unsigned=>unsigned) + (:args (x :target r :scs (signed-reg signed-stack))) + (:arg-types signed-num (:constant (unsigned-byte 32)))) + +(define-vop (fast-logand/unsigned-signed=>unsigned + fast-logand/unsigned=>unsigned) + (:args (x :target r :scs (unsigned-reg) + :load-if (not (and (sc-is x unsigned-stack) + (sc-is y signed-reg) + (sc-is r unsigned-stack) + (location= x r)))) + (y :scs (signed-reg signed-stack))) + (:arg-types unsigned-num signed-num)) + + +(define-vop (fast-+-c/signed=>signed fast-safe-arith-op) + (:translate +) + (:args (x :target r :scs (signed-reg signed-stack))) + (:info y) + (:arg-types signed-num (:constant (signed-byte 32))) + (:results (r :scs (signed-reg) + :load-if (not (location= x r)))) + (:result-types signed-num) + (:note "inline (signed-byte 32) arithmetic") + (:generator 4 + (cond ((and (sc-is x signed-reg) (sc-is r signed-reg) + (not (location= x r))) + (inst lea r (make-ea :dword :base x :disp y))) + (t + (move r x) + (if (= y 1) + (inst inc r) + (inst add r y)))))) + +(define-vop (fast-+/unsigned=>unsigned fast-safe-arith-op) + (:translate +) + (:args (x :scs (unsigned-reg) :target r + :load-if (not (and (sc-is x unsigned-stack) + (sc-is y unsigned-reg) + (sc-is r unsigned-stack) + (location= x r)))) + (y :scs (unsigned-reg unsigned-stack))) + (:arg-types unsigned-num unsigned-num) + (:results (r :scs (unsigned-reg) :from (:argument 0) + :load-if (not (and (sc-is x unsigned-stack) + (sc-is y unsigned-reg) + (sc-is r unsigned-stack) + (location= x r))))) + (:result-types unsigned-num) + (:note "inline (unsigned-byte 32) arithmetic") + (: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 :dword :base x :index y :scale 1))) + (t + (move r x) + (inst add r y))))) + +(define-vop (fast-+-c/unsigned=>unsigned fast-safe-arith-op) + (:translate +) + (:args (x :target r :scs (unsigned-reg unsigned-stack))) + (:info y) + (:arg-types unsigned-num (:constant (unsigned-byte 32))) + (:results (r :scs (unsigned-reg) + :load-if (not (location= x r)))) + (:result-types unsigned-num) + (:note "inline (unsigned-byte 32) arithmetic") + (:generator 4 + (cond ((and (sc-is x unsigned-reg) (sc-is r unsigned-reg) + (not (location= x r))) + (inst lea r (make-ea :dword :base x :disp y))) + (t + (move r x) + (if (= y 1) + (inst inc r) + (inst add r y)))))) + +;;;; multiplication and division + +(define-vop (fast-*/fixnum=>fixnum fast-safe-arith-op) + (:translate *) + ;; We need different loading characteristics. + (:args (x :scs (any-reg) :target r) + (y :scs (any-reg control-stack))) + (:arg-types tagged-num tagged-num) + (:results (r :scs (any-reg) :from (:argument 0))) + (:result-types tagged-num) + (:note "inline fixnum arithmetic") + (:generator 4 + (move r x) + (inst sar r 2) + (inst imul r y))) + +(define-vop (fast-*-c/fixnum=>fixnum fast-safe-arith-op) + (:translate *) + ;; We need different loading characteristics. + (:args (x :scs (any-reg control-stack))) + (:info y) + (:arg-types tagged-num (:constant (signed-byte 30))) + (:results (r :scs (any-reg))) + (:result-types tagged-num) + (:note "inline fixnum arithmetic") + (:generator 3 + (inst imul r x y))) + +(define-vop (fast-*/signed=>signed fast-safe-arith-op) + (:translate *) + ;; We need different loading characteristics. + (:args (x :scs (signed-reg) :target r) + (y :scs (signed-reg signed-stack))) + (:arg-types signed-num signed-num) + (:results (r :scs (signed-reg) :from (:argument 0))) + (:result-types signed-num) + (:note "inline (signed-byte 32) arithmetic") + (:generator 5 + (move r x) + (inst imul r y))) + +(define-vop (fast-*-c/signed=>signed fast-safe-arith-op) + (:translate *) + ;; We need different loading characteristics. + (:args (x :scs (signed-reg signed-stack))) + (:info y) + (:arg-types signed-num (:constant (signed-byte 32))) + (:results (r :scs (signed-reg))) + (:result-types signed-num) + (:note "inline (signed-byte 32) arithmetic") + (:generator 4 + (inst imul r x y))) + +(define-vop (fast-*/unsigned=>unsigned fast-safe-arith-op) + (:translate *) + (:args (x :scs (unsigned-reg) :target eax) + (y :scs (unsigned-reg unsigned-stack))) + (:arg-types unsigned-num unsigned-num) + (:temporary (:sc unsigned-reg :offset eax-offset :target r + :from (:argument 0) :to :result) eax) + (:temporary (:sc unsigned-reg :offset edx-offset + :from :eval :to :result) edx) + (:ignore edx) + (:results (r :scs (unsigned-reg))) + (:result-types unsigned-num) + (:note "inline (unsigned-byte 32) arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:generator 6 + (move eax x) + (inst mul eax y) + (move r eax))) + + +(define-vop (fast-truncate/fixnum=>fixnum fast-safe-arith-op) + (:translate truncate) + (:args (x :scs (any-reg) :target eax) + (y :scs (any-reg control-stack))) + (:arg-types tagged-num tagged-num) + (:temporary (:sc signed-reg :offset eax-offset :target quo + :from (:argument 0) :to (:result 0)) eax) + (:temporary (:sc unsigned-reg :offset edx-offset :target rem + :from (:argument 0) :to (:result 1)) edx) + (:results (quo :scs (any-reg)) + (rem :scs (any-reg))) + (:result-types tagged-num tagged-num) + (:note "inline fixnum arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:generator 31 + (let ((zero (generate-error-code vop division-by-zero-error x y))) + (if (sc-is y any-reg) + (inst test y y) ; smaller instruction + (inst cmp y 0)) + (inst jmp :eq zero)) + (move eax x) + (inst cdq) + (inst idiv eax y) + (if (location= quo eax) + (inst shl eax 2) + (inst lea quo (make-ea :dword :index eax :scale 4))) + (move rem edx))) + +(define-vop (fast-truncate-c/fixnum=>fixnum fast-safe-arith-op) + (:translate truncate) + (:args (x :scs (any-reg) :target eax)) + (:info y) + (:arg-types tagged-num (:constant (signed-byte 30))) + (:temporary (:sc signed-reg :offset eax-offset :target quo + :from :argument :to (:result 0)) eax) + (:temporary (:sc any-reg :offset edx-offset :target rem + :from :eval :to (:result 1)) edx) + (:temporary (:sc any-reg :from :eval :to :result) y-arg) + (:results (quo :scs (any-reg)) + (rem :scs (any-reg))) + (:result-types tagged-num tagged-num) + (:note "inline fixnum arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:generator 30 + (move eax x) + (inst cdq) + (inst mov y-arg (fixnumize y)) + (inst idiv eax y-arg) + (if (location= quo eax) + (inst shl eax 2) + (inst lea quo (make-ea :dword :index eax :scale 4))) + (move rem edx))) + +(define-vop (fast-truncate/unsigned=>unsigned fast-safe-arith-op) + (:translate truncate) + (:args (x :scs (unsigned-reg) :target eax) + (y :scs (unsigned-reg signed-stack))) + (:arg-types unsigned-num unsigned-num) + (:temporary (:sc unsigned-reg :offset eax-offset :target quo + :from (:argument 0) :to (:result 0)) eax) + (:temporary (:sc unsigned-reg :offset edx-offset :target rem + :from (:argument 0) :to (:result 1)) edx) + (:results (quo :scs (unsigned-reg)) + (rem :scs (unsigned-reg))) + (:result-types unsigned-num unsigned-num) + (:note "inline (unsigned-byte 32) arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:generator 33 + (let ((zero (generate-error-code vop division-by-zero-error x y))) + (if (sc-is y unsigned-reg) + (inst test y y) ; smaller instruction + (inst cmp y 0)) + (inst jmp :eq zero)) + (move eax x) + (inst xor edx edx) + (inst div eax y) + (move quo eax) + (move rem edx))) + +(define-vop (fast-truncate-c/unsigned=>unsigned fast-safe-arith-op) + (:translate truncate) + (:args (x :scs (unsigned-reg) :target eax)) + (:info y) + (:arg-types unsigned-num (:constant (unsigned-byte 32))) + (:temporary (:sc unsigned-reg :offset eax-offset :target quo + :from :argument :to (:result 0)) eax) + (:temporary (:sc unsigned-reg :offset edx-offset :target rem + :from :eval :to (:result 1)) edx) + (:temporary (:sc unsigned-reg :from :eval :to :result) y-arg) + (:results (quo :scs (unsigned-reg)) + (rem :scs (unsigned-reg))) + (:result-types unsigned-num unsigned-num) + (:note "inline (unsigned-byte 32) arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:generator 32 + (move eax x) + (inst xor edx edx) + (inst mov y-arg y) + (inst div eax y-arg) + (move quo eax) + (move rem edx))) + +(define-vop (fast-truncate/signed=>signed fast-safe-arith-op) + (:translate truncate) + (:args (x :scs (signed-reg) :target eax) + (y :scs (signed-reg signed-stack))) + (:arg-types signed-num signed-num) + (:temporary (:sc signed-reg :offset eax-offset :target quo + :from (:argument 0) :to (:result 0)) eax) + (:temporary (:sc signed-reg :offset edx-offset :target rem + :from (:argument 0) :to (:result 1)) edx) + (:results (quo :scs (signed-reg)) + (rem :scs (signed-reg))) + (:result-types signed-num signed-num) + (:note "inline (signed-byte 32) arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:generator 33 + (let ((zero (generate-error-code vop division-by-zero-error x y))) + (if (sc-is y signed-reg) + (inst test y y) ; smaller instruction + (inst cmp y 0)) + (inst jmp :eq zero)) + (move eax x) + (inst cdq) + (inst idiv eax y) + (move quo eax) + (move rem edx))) + +(define-vop (fast-truncate-c/signed=>signed fast-safe-arith-op) + (:translate truncate) + (:args (x :scs (signed-reg) :target eax)) + (:info y) + (:arg-types signed-num (:constant (signed-byte 32))) + (:temporary (:sc signed-reg :offset eax-offset :target quo + :from :argument :to (:result 0)) eax) + (:temporary (:sc signed-reg :offset edx-offset :target rem + :from :eval :to (:result 1)) edx) + (:temporary (:sc signed-reg :from :eval :to :result) y-arg) + (:results (quo :scs (signed-reg)) + (rem :scs (signed-reg))) + (:result-types signed-num signed-num) + (:note "inline (signed-byte 32) arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:generator 32 + (move eax x) + (inst cdq) + (inst mov y-arg y) + (inst idiv eax y-arg) + (move quo eax) + (move rem edx))) + + + +;;;; Shifting +(define-vop (fast-ash-c/fixnum=>fixnum) + (:translate ash) + (:policy :fast-safe) + (:args (number :scs (any-reg) :target result + :load-if (not (and (sc-is number any-reg control-stack) + (sc-is result any-reg control-stack) + (location= number result))))) + (:info amount) + (:arg-types tagged-num (:constant integer)) + (:results (result :scs (any-reg) + :load-if (not (and (sc-is number control-stack) + (sc-is result control-stack) + (location= number result))))) + (:result-types tagged-num) + (:note "inline ASH") + (:generator 2 + (cond ((and (= amount 1) (not (location= number result))) + (inst lea result (make-ea :dword :base number :index number))) + ((and (= amount 2) (not (location= number result))) + (inst lea result (make-ea :dword :index number :scale 4))) + ((and (= amount 3) (not (location= number result))) + (inst lea result (make-ea :dword :index number :scale 8))) + (t + (move result number) + (cond ((< -32 amount 32) + ;; this code is used both in ASH and ASH-SMOD30, so + ;; be careful + (if (plusp amount) + (inst shl result amount) + (progn + (inst sar result (- amount)) + (inst and result (lognot fixnum-tag-mask))))) + ((plusp amount) + (if (sc-is result any-reg) + (inst xor result result) + (inst mov result 0))) + (t (inst sar result 31) + (inst and result (lognot fixnum-tag-mask)))))))) + +(define-vop (fast-ash-left/fixnum=>fixnum) + (:translate ash) + (:args (number :scs (any-reg) :target result + :load-if (not (and (sc-is number control-stack) + (sc-is result control-stack) + (location= number result)))) + (amount :scs (unsigned-reg) :target ecx)) + (:arg-types tagged-num positive-fixnum) + (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx) + (:results (result :scs (any-reg) :from (:argument 0) + :load-if (not (and (sc-is number control-stack) + (sc-is result control-stack) + (location= number result))))) + (:result-types tagged-num) + (:policy :fast-safe) + (:note "inline ASH") + (:generator 3 + (move result number) + (move ecx amount) + ;; The result-type ensures us that this shift will not overflow. + (inst shl result :cl))) + +(define-vop (fast-ash-c/signed=>signed) + (:translate ash) + (:policy :fast-safe) + (:args (number :scs (signed-reg) :target result + :load-if (not (and (sc-is number signed-stack) + (sc-is result signed-stack) + (location= number result))))) + (:info amount) + (:arg-types signed-num (:constant integer)) + (:results (result :scs (signed-reg) + :load-if (not (and (sc-is number signed-stack) + (sc-is result signed-stack) + (location= number result))))) + (:result-types signed-num) + (:note "inline ASH") + (:generator 3 + (cond ((and (= amount 1) (not (location= number result))) + (inst lea result (make-ea :dword :base number :index number))) + ((and (= amount 2) (not (location= number result))) + (inst lea result (make-ea :dword :index number :scale 4))) + ((and (= amount 3) (not (location= number result))) + (inst lea result (make-ea :dword :index number :scale 8))) + (t + (move result number) + (cond ((plusp amount) (inst shl result amount)) + (t (inst sar result (min 31 (- amount))))))))) + +(define-vop (fast-ash-c/unsigned=>unsigned) + (:translate ash) + (:policy :fast-safe) + (:args (number :scs (unsigned-reg) :target result + :load-if (not (and (sc-is number unsigned-stack) + (sc-is result unsigned-stack) + (location= number result))))) + (:info amount) + (:arg-types unsigned-num (:constant integer)) + (:results (result :scs (unsigned-reg) + :load-if (not (and (sc-is number unsigned-stack) + (sc-is result unsigned-stack) + (location= number result))))) + (:result-types unsigned-num) + (:note "inline ASH") + (:generator 3 + (cond ((and (= amount 1) (not (location= number result))) + (inst lea result (make-ea :dword :base number :index number))) + ((and (= amount 2) (not (location= number result))) + (inst lea result (make-ea :dword :index number :scale 4))) + ((and (= amount 3) (not (location= number result))) + (inst lea result (make-ea :dword :index number :scale 8))) + (t + (move result number) + (cond ((< -32 amount 32) + ;; this code is used both in ASH and ASH-MOD32, so + ;; be careful + (if (plusp amount) + (inst shl result amount) + (inst shr result (- amount)))) + (t (if (sc-is result unsigned-reg) + (inst xor result result) + (inst mov result 0)))))))) + +(define-vop (fast-ash-left/signed=>signed) + (:translate ash) + (:args (number :scs (signed-reg) :target result + :load-if (not (and (sc-is number signed-stack) + (sc-is result signed-stack) + (location= number result)))) + (amount :scs (unsigned-reg) :target ecx)) + (:arg-types signed-num positive-fixnum) + (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx) + (:results (result :scs (signed-reg) :from (:argument 0) + :load-if (not (and (sc-is number signed-stack) + (sc-is result signed-stack) + (location= number result))))) + (:result-types signed-num) + (:policy :fast-safe) + (:note "inline ASH") + (:generator 4 + (move result number) + (move ecx amount) + (inst shl result :cl))) + +(define-vop (fast-ash-left/unsigned=>unsigned) + (:translate ash) + (:args (number :scs (unsigned-reg) :target result + :load-if (not (and (sc-is number unsigned-stack) + (sc-is result unsigned-stack) + (location= number result)))) + (amount :scs (unsigned-reg) :target ecx)) + (:arg-types unsigned-num positive-fixnum) + (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx) + (:results (result :scs (unsigned-reg) :from (:argument 0) + :load-if (not (and (sc-is number unsigned-stack) + (sc-is result unsigned-stack) + (location= number result))))) + (:result-types unsigned-num) + (:policy :fast-safe) + (:note "inline ASH") + (:generator 4 + (move result number) + (move ecx amount) + (inst shl result :cl))) + +(define-vop (fast-ash/signed=>signed) + (:translate ash) + (:policy :fast-safe) + (:args (number :scs (signed-reg) :target result) + (amount :scs (signed-reg) :target ecx)) + (:arg-types signed-num signed-num) + (:results (result :scs (signed-reg) :from (:argument 0))) + (:result-types signed-num) + (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx) + (:note "inline ASH") + (:generator 5 + (move result number) + (move ecx amount) + (inst or ecx ecx) + (inst jmp :ns positive) + (inst neg ecx) + (inst cmp ecx 31) + (inst jmp :be okay) + (inst mov ecx 31) + OKAY + (inst sar result :cl) + (inst jmp done) + + POSITIVE + ;; The result-type ensures us that this shift will not overflow. + (inst shl result :cl) + + DONE)) + +(define-vop (fast-ash/unsigned=>unsigned) + (:translate ash) + (:policy :fast-safe) + (:args (number :scs (unsigned-reg) :target result) + (amount :scs (signed-reg) :target ecx)) + (:arg-types unsigned-num signed-num) + (:results (result :scs (unsigned-reg) :from (:argument 0))) + (:result-types unsigned-num) + (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx) + (:note "inline ASH") + (:generator 5 + (move result number) + (move ecx amount) + (inst or ecx ecx) + (inst jmp :ns positive) + (inst neg ecx) + (inst cmp ecx 31) + (inst jmp :be okay) + (inst xor result result) + (inst jmp done) + OKAY + (inst shr result :cl) + (inst jmp done) + + POSITIVE + ;; The result-type ensures us that this shift will not overflow. + (inst shl result :cl) + + DONE)) + +(in-package "SB!C") + +(defknown %lea (integer integer (member 1 2 4 8) (signed-byte 32)) + integer + (foldable flushable movable)) + +(defoptimizer (%lea derive-type) ((base index scale disp)) + (when (and (constant-lvar-p scale) + (constant-lvar-p disp)) + (let ((scale (lvar-value scale)) + (disp (lvar-value disp)) + (base-type (lvar-type base)) + (index-type (lvar-type index))) + (when (and (numeric-type-p base-type) + (numeric-type-p index-type)) + (let ((base-lo (numeric-type-low base-type)) + (base-hi (numeric-type-high base-type)) + (index-lo (numeric-type-low index-type)) + (index-hi (numeric-type-high index-type))) + (make-numeric-type :class 'integer + :complexp :real + :low (when (and base-lo index-lo) + (+ base-lo (* index-lo scale) disp)) + :high (when (and base-hi index-hi) + (+ base-hi (* index-hi scale) disp)))))))) + +(defun %lea (base index scale disp) + (+ base (* index scale) disp)) + +(in-package "SB!VM") + +(define-vop (%lea/unsigned=>unsigned) + (:translate %lea) + (:policy :fast-safe) + (:args (base :scs (unsigned-reg)) + (index :scs (unsigned-reg))) + (:info scale disp) + (:arg-types unsigned-num unsigned-num + (:constant (member 1 2 4 8)) + (:constant (signed-byte 32))) + (:results (r :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 5 + (inst lea r (make-ea :dword :base base :index index + :scale scale :disp disp)))) + +(define-vop (%lea/signed=>signed) + (:translate %lea) + (:policy :fast-safe) + (:args (base :scs (signed-reg)) + (index :scs (signed-reg))) + (:info scale disp) + (:arg-types signed-num signed-num + (:constant (member 1 2 4 8)) + (:constant (signed-byte 32))) + (:results (r :scs (signed-reg))) + (:result-types signed-num) + (:generator 4 + (inst lea r (make-ea :dword :base base :index index + :scale scale :disp disp)))) + +(define-vop (%lea/fixnum=>fixnum) + (:translate %lea) + (:policy :fast-safe) + (:args (base :scs (any-reg)) + (index :scs (any-reg))) + (:info scale disp) + (:arg-types tagged-num tagged-num + (:constant (member 1 2 4 8)) + (:constant (signed-byte 32))) + (:results (r :scs (any-reg))) + (:result-types tagged-num) + (:generator 3 + (inst lea r (make-ea :dword :base base :index index + :scale scale :disp disp)))) + +;;; 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 +;;; least on my Celeron-XXX laptop, this version is marginally slower +;;; than the above version with branches. -- CSR, 2003-09-04 +(define-vop (fast-cmov-ash/unsigned=>unsigned) + (:translate ash) + (:policy :fast-safe) + (:args (number :scs (unsigned-reg) :target result) + (amount :scs (signed-reg) :target ecx)) + (:arg-types unsigned-num signed-num) + (:results (result :scs (unsigned-reg) :from (:argument 0))) + (:result-types unsigned-num) + (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx) + (:temporary (:sc any-reg :from (:eval 0) :to (:eval 1)) zero) + (:note "inline ASH") + (:guard (member :cmov *backend-subfeatures*)) + (:generator 4 + (move result number) + (move ecx amount) + (inst or ecx ecx) + (inst jmp :ns positive) + (inst neg ecx) + (inst xor zero zero) + (inst shr result :cl) + (inst cmp ecx 31) + (inst cmov :nbe result zero) + (inst jmp done) + + POSITIVE + ;; The result-type ensures us that this shift will not overflow. + (inst shl result :cl) + + DONE)) + +(define-vop (signed-byte-32-len) + (:translate integer-length) + (:note "inline (signed-byte 32) integer-length") + (:policy :fast-safe) + (:args (arg :scs (signed-reg) :target res)) + (:arg-types signed-num) + (:results (res :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 28 + (move res arg) + (inst cmp res 0) + (inst jmp :ge POS) + (inst not res) + POS + (inst bsr res res) + (inst jmp :z zero) + (inst inc res) + (inst jmp done) + ZERO + (inst xor res res) + DONE)) + +(define-vop (unsigned-byte-32-len) + (:translate integer-length) + (:note "inline (unsigned-byte 32) integer-length") + (:policy :fast-safe) + (:args (arg :scs (unsigned-reg))) + (:arg-types unsigned-num) + (:results (res :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 26 + (inst bsr res arg) + (inst jmp :z zero) + (inst inc res) + (inst jmp done) + ZERO + (inst xor res res) + DONE)) + +(define-vop (unsigned-byte-32-count) + (:translate logcount) + (:note "inline (unsigned-byte 32) logcount") + (:policy :fast-safe) + (:args (arg :scs (unsigned-reg) :target result)) + (:arg-types unsigned-num) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:temporary (:sc unsigned-reg) temp) + (:generator 14 + ;; See the comments below for how the algorithm works. The tricks + ;; used can be found for example in AMD's software optimization + ;; guide or at "http://www.hackersdelight.org/HDcode/pop.cc" in the + ;; function "pop1". + ;; Calculate 2-bit sums. Note that the value of a two-digit binary + ;; number is the sum of the right digit and twice the left digit. + ;; Thus we can calculate the sum of the two digits by shifting the + ;; left digit to the right position and doing a two-bit subtraction. + ;; This subtraction will never create a borrow and thus can be made + ;; on all 16 2-digit numbers at once. + (move result arg) + (move temp arg) + (inst shr result 1) + (inst and result #x55555555) + (inst sub temp result) + ;; Calculate 4-bit sums by straightforward shift, mask and add. + ;; Note that we shift the source operand of the MOV and not its + ;; destination so that the SHR and the MOV can execute in the same + ;; clock cycle. + (inst mov result temp) + (inst shr temp 2) + (inst and result #x33333333) + (inst and temp #x33333333) + (inst add result temp) + ;; Calculate 8-bit sums. Since each sum is at most 8, which fits + ;; into 4 bits, we can apply the mask after the addition, saving one + ;; instruction. + (inst mov temp result) + (inst shr result 4) + (inst add result temp) + (inst and result #x0f0f0f0f) + ;; Calculate the two 16-bit sums and the 32-bit sum. No masking is + ;; necessary inbetween since the final sum is at most 32 which fits + ;; into 6 bits. + (inst mov temp result) + (inst shr result 8) + (inst add result temp) + (inst mov temp result) + (inst shr result 16) + (inst add result temp) + (inst and result #xff))) + +;;;; binary conditional VOPs + +(define-vop (fast-conditional) + (:conditional) + (:info target not-p) + (:effects) + (:affected) + (:policy :fast-safe)) + +(define-vop (fast-conditional/fixnum fast-conditional) + (:args (x :scs (any-reg) + :load-if (not (and (sc-is x control-stack) + (sc-is y any-reg)))) + (y :scs (any-reg control-stack))) + (:arg-types tagged-num tagged-num) + (:note "inline fixnum comparison")) + +(define-vop (fast-conditional-c/fixnum fast-conditional/fixnum) + (:args (x :scs (any-reg control-stack))) + (:arg-types tagged-num (:constant (signed-byte 30))) + (:info target not-p y)) + +(define-vop (fast-conditional/signed fast-conditional) + (:args (x :scs (signed-reg) + :load-if (not (and (sc-is x signed-stack) + (sc-is y signed-reg)))) + (y :scs (signed-reg signed-stack))) + (:arg-types signed-num signed-num) + (:note "inline (signed-byte 32) comparison")) + +(define-vop (fast-conditional-c/signed fast-conditional/signed) + (:args (x :scs (signed-reg signed-stack))) + (:arg-types signed-num (:constant (signed-byte 32))) + (:info target not-p y)) + +(define-vop (fast-conditional/unsigned fast-conditional) + (:args (x :scs (unsigned-reg) + :load-if (not (and (sc-is x unsigned-stack) + (sc-is y unsigned-reg)))) + (y :scs (unsigned-reg unsigned-stack))) + (:arg-types unsigned-num unsigned-num) + (:note "inline (unsigned-byte 32) comparison")) + +(define-vop (fast-conditional-c/unsigned fast-conditional/unsigned) + (:args (x :scs (unsigned-reg unsigned-stack))) + (:arg-types unsigned-num (:constant (unsigned-byte 32))) + (:info target not-p y)) + +(macrolet ((define-logtest-vops () + `(progn + ,@(loop for suffix in '(/fixnum -c/fixnum + /signed -c/signed + /unsigned -c/unsigned) + for cost in '(4 3 6 5 6 5) + collect + `(define-vop (,(symbolicate "FAST-LOGTEST" suffix) + ,(symbolicate "FAST-CONDITIONAL" suffix)) + (:translate logtest) + (:generator ,cost + (emit-optimized-test-inst x + ,(if (eq suffix '-c/fixnum) + '(fixnumize y) + 'y)) + (inst jmp (if not-p :e :ne) target))))))) + (define-logtest-vops)) + +(defknown %logbitp (integer unsigned-byte) boolean + (movable foldable flushable always-translatable)) + +;;; only for constant folding within the compiler +(defun %logbitp (integer index) + (logbitp index integer)) + +;;; too much work to do the non-constant case (maybe?) +(define-vop (fast-logbitp-c/fixnum fast-conditional-c/fixnum) + (:translate %logbitp) + (:arg-types tagged-num (:constant (integer 0 29))) + (:generator 4 + (inst bt x (+ y n-fixnum-tag-bits)) + (inst jmp (if not-p :nc :c) target))) + +(define-vop (fast-logbitp/signed fast-conditional/signed) + (:args (x :scs (signed-reg signed-stack)) + (y :scs (signed-reg))) + (:translate %logbitp) + (:generator 6 + (inst bt x y) + (inst jmp (if not-p :nc :c) target))) + +(define-vop (fast-logbitp-c/signed fast-conditional-c/signed) + (:translate %logbitp) + (:arg-types signed-num (:constant (integer 0 31))) + (:generator 5 + (inst bt x y) + (inst jmp (if not-p :nc :c) target))) + +(define-vop (fast-logbitp/unsigned fast-conditional/unsigned) + (:args (x :scs (unsigned-reg unsigned-stack)) + (y :scs (unsigned-reg))) + (:translate %logbitp) + (:generator 6 + (inst bt x y) + (inst jmp (if not-p :nc :c) target))) + +(define-vop (fast-logbitp-c/unsigned fast-conditional-c/unsigned) + (:translate %logbitp) + (:arg-types unsigned-num (:constant (integer 0 31))) + (:generator 5 + (inst bt x y) + (inst jmp (if not-p :nc :c) target))) + +(macrolet ((define-conditional-vop (tran cond unsigned not-cond not-unsigned) + `(progn + ,@(mapcar + (lambda (suffix cost signed) + `(define-vop (;; FIXME: These could be done more + ;; cleanly with SYMBOLICATE. + ,(intern (format nil "~:@(FAST-IF-~A~A~)" + tran suffix)) + ,(intern + (format nil "~:@(FAST-CONDITIONAL~A~)" + suffix))) + (:translate ,tran) + (:generator ,cost + (inst cmp x + ,(if (eq suffix '-c/fixnum) + '(fixnumize y) + 'y)) + (inst jmp (if not-p + ,(if signed + not-cond + not-unsigned) + ,(if signed + cond + unsigned)) + target)))) + '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned) + '(4 3 6 5 6 5) + '(t t t t nil nil))))) + + (define-conditional-vop < :l :b :ge :ae) + (define-conditional-vop > :g :a :le :be)) + +(define-vop (fast-if-eql/signed fast-conditional/signed) + (:translate eql) + (:generator 6 + (inst cmp x y) + (inst jmp (if not-p :ne :e) target))) + +(define-vop (fast-if-eql-c/signed fast-conditional-c/signed) + (:translate eql) + (:generator 5 + (cond ((and (sc-is x signed-reg) (zerop y)) + (inst test x x)) ; smaller instruction + (t + (inst cmp x y))) + (inst jmp (if not-p :ne :e) target))) + +(define-vop (fast-if-eql/unsigned fast-conditional/unsigned) + (:translate eql) + (:generator 6 + (inst cmp x y) + (inst jmp (if not-p :ne :e) target))) + +(define-vop (fast-if-eql-c/unsigned fast-conditional-c/unsigned) + (:translate eql) + (:generator 5 + (cond ((and (sc-is x unsigned-reg) (zerop y)) + (inst test x x)) ; smaller instruction + (t + (inst cmp x y))) + (inst jmp (if not-p :ne :e) target))) + +;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a +;;; known fixnum. + +;;; These versions specify a fixnum restriction on their first arg. We have +;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on +;;; the first arg and a higher cost. The reason for doing this is to prevent +;;; fixnum specific operations from being used on word integers, spuriously +;;; consing the argument. + +(define-vop (fast-eql/fixnum fast-conditional) + (:args (x :scs (any-reg) + :load-if (not (and (sc-is x control-stack) + (sc-is y any-reg)))) + (y :scs (any-reg control-stack))) + (:arg-types tagged-num tagged-num) + (:note "inline fixnum comparison") + (:translate eql) + (:generator 4 + (inst cmp x y) + (inst jmp (if not-p :ne :e) target))) +(define-vop (generic-eql/fixnum fast-eql/fixnum) + (:args (x :scs (any-reg descriptor-reg) + :load-if (not (and (sc-is x control-stack) + (sc-is y any-reg)))) + (y :scs (any-reg control-stack))) + (:arg-types * tagged-num) + (:variant-cost 7)) + +(define-vop (fast-eql-c/fixnum fast-conditional/fixnum) + (:args (x :scs (any-reg control-stack))) + (:arg-types tagged-num (:constant (signed-byte 30))) + (:info target not-p y) + (:translate eql) + (:generator 2 + (cond ((and (sc-is x any-reg) (zerop y)) + (inst test x x)) ; smaller instruction + (t + (inst cmp x (fixnumize y)))) + (inst jmp (if not-p :ne :e) target))) +(define-vop (generic-eql-c/fixnum fast-eql-c/fixnum) + (:args (x :scs (any-reg descriptor-reg control-stack))) + (:arg-types * (:constant (signed-byte 30))) + (:variant-cost 6)) + +;;;; 32-bit logical operations + +(define-vop (merge-bits) + (:translate merge-bits) + (:args (shift :scs (signed-reg unsigned-reg) :target ecx) + (prev :scs (unsigned-reg) :target result) + (next :scs (unsigned-reg))) + (:arg-types tagged-num unsigned-num unsigned-num) + (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 0)) ecx) + (:results (result :scs (unsigned-reg) :from (:argument 1))) + (:result-types unsigned-num) + (:policy :fast-safe) + (:generator 4 + (move ecx shift) + (move result prev) + (inst shrd result next :cl))) + +;;; Only the lower 5 bits of the shift amount are significant. +(define-vop (shift-towards-someplace) + (:policy :fast-safe) + (:args (num :scs (unsigned-reg) :target r) + (amount :scs (signed-reg) :target ecx)) + (:arg-types unsigned-num tagged-num) + (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx) + (:results (r :scs (unsigned-reg) :from (:argument 0))) + (:result-types unsigned-num)) + +(define-vop (shift-towards-start shift-towards-someplace) + (:translate shift-towards-start) + (:note "SHIFT-TOWARDS-START") + (:generator 1 + (move r num) + (move ecx amount) + (inst shr r :cl))) + +(define-vop (shift-towards-end shift-towards-someplace) + (:translate shift-towards-end) + (:note "SHIFT-TOWARDS-END") + (:generator 1 + (move r num) + (move ecx amount) + (inst shl r :cl))) + +;;;; Modular functions +(defmacro define-mod-binop ((name prototype) function) + `(define-vop (,name ,prototype) + (:args (x :target r :scs (unsigned-reg signed-reg) + :load-if (not (and (or (sc-is x unsigned-stack) + (sc-is x signed-stack)) + (or (sc-is y unsigned-reg) + (sc-is y signed-reg)) + (or (sc-is r unsigned-stack) + (sc-is r signed-stack)) + (location= x r)))) + (y :scs (unsigned-reg signed-reg unsigned-stack signed-stack))) + (:arg-types untagged-num untagged-num) + (:results (r :scs (unsigned-reg signed-reg) :from (:argument 0) + :load-if (not (and (or (sc-is x unsigned-stack) + (sc-is x signed-stack)) + (or (sc-is y unsigned-reg) + (sc-is y unsigned-reg)) + (or (sc-is r unsigned-stack) + (sc-is r unsigned-stack)) + (location= x r))))) + (:result-types unsigned-num) + (:translate ,function))) +(defmacro define-mod-binop-c ((name prototype) function) + `(define-vop (,name ,prototype) + (:args (x :target r :scs (unsigned-reg signed-reg) + :load-if (not (and (or (sc-is x unsigned-stack) + (sc-is x signed-stack)) + (or (sc-is r unsigned-stack) + (sc-is r signed-stack)) + (location= x r))))) + (:info y) + (:arg-types untagged-num (:constant (or (unsigned-byte 32) (signed-byte 32)))) + (:results (r :scs (unsigned-reg signed-reg) :from (:argument 0) + :load-if (not (and (or (sc-is x unsigned-stack) + (sc-is x signed-stack)) + (or (sc-is r unsigned-stack) + (sc-is r unsigned-stack)) + (location= x r))))) + (:result-types unsigned-num) + (:translate ,function))) + +(macrolet ((def (name -c-p) + (let ((fun32 (intern (format nil "~S-MOD32" name))) + (vopu (intern (format nil "FAST-~S/UNSIGNED=>UNSIGNED" name))) + (vopcu (intern (format nil "FAST-~S-C/UNSIGNED=>UNSIGNED" name))) + (vopf (intern (format nil "FAST-~S/FIXNUM=>FIXNUM" name))) + (vopcf (intern (format nil "FAST-~S-C/FIXNUM=>FIXNUM" name))) + (vop32u (intern (format nil "FAST-~S-MOD32/WORD=>UNSIGNED" name))) + (vop32f (intern (format nil "FAST-~S-MOD32/FIXNUM=>FIXNUM" name))) + (vop32cu (intern (format nil "FAST-~S-MOD32-C/WORD=>UNSIGNED" name))) + (vop32cf (intern (format nil "FAST-~S-MOD32-C/FIXNUM=>FIXNUM" name))) + (sfun30 (intern (format nil "~S-SMOD30" name))) + (svop30f (intern (format nil "FAST-~S-SMOD30/FIXNUM=>FIXNUM" name))) + (svop30cf (intern (format nil "FAST-~S-SMOD30-C/FIXNUM=>FIXNUM" name)))) + `(progn + (define-modular-fun ,fun32 (x y) ,name :unsigned 32) + (define-modular-fun ,sfun30 (x y) ,name :signed 30) + (define-mod-binop (,vop32u ,vopu) ,fun32) + (define-vop (,vop32f ,vopf) (:translate ,fun32)) + (define-vop (,svop30f ,vopf) (:translate ,sfun30)) + ,@(when -c-p + `((define-mod-binop-c (,vop32cu ,vopcu) ,fun32) + (define-vop (,svop30cf ,vopcf) (:translate ,sfun30)))))))) + (def + t) + (def - t) + ;; (no -C variant as x86 MUL instruction doesn't take an immediate) + (def * nil)) + + +(define-vop (fast-ash-left-mod32-c/unsigned=>unsigned + fast-ash-c/unsigned=>unsigned) + (:translate ash-left-mod32)) + +(define-vop (fast-ash-left-mod32/unsigned=>unsigned + fast-ash-left/unsigned=>unsigned)) +(deftransform ash-left-mod32 ((integer count) + ((unsigned-byte 32) (unsigned-byte 5))) + (when (sb!c::constant-lvar-p count) + (sb!c::give-up-ir1-transform)) + '(%primitive fast-ash-left-mod32/unsigned=>unsigned integer count)) + +(define-vop (fast-ash-left-smod30-c/fixnum=>fixnum + fast-ash-c/fixnum=>fixnum) + (:translate ash-left-smod30)) + +(define-vop (fast-ash-left-smod30/fixnum=>fixnum + fast-ash-left/fixnum=>fixnum)) +(deftransform ash-left-smod30 ((integer count) + ((signed-byte 30) (unsigned-byte 5))) + (when (sb!c::constant-lvar-p count) + (sb!c::give-up-ir1-transform)) + '(%primitive fast-ash-left-smod30/fixnum=>fixnum integer count)) + +(in-package "SB!C") + +(defknown sb!vm::%lea-mod32 (integer integer (member 1 2 4 8) (signed-byte 32)) + (unsigned-byte 32) + (foldable flushable movable)) +(defknown sb!vm::%lea-smod30 (integer integer (member 1 2 4 8) (signed-byte 32)) + (signed-byte 30) + (foldable flushable movable)) + +(define-modular-fun-optimizer %lea ((base index scale disp) :unsigned :width width) + (when (and (<= width 32) + (constant-lvar-p scale) + (constant-lvar-p disp)) + (cut-to-width base :unsigned width) + (cut-to-width index :unsigned width) + 'sb!vm::%lea-mod32)) +(define-modular-fun-optimizer %lea ((base index scale disp) :signed :width width) + (when (and (<= width 30) + (constant-lvar-p scale) + (constant-lvar-p disp)) + (cut-to-width base :signed width) + (cut-to-width index :signed width) + 'sb!vm::%lea-smod30)) + +#+sb-xc-host +(progn + (defun sb!vm::%lea-mod32 (base index scale disp) + (ldb (byte 32 0) (%lea base index scale disp))) + (defun sb!vm::%lea-smod30 (base index scale disp) + (mask-signed-field 30 (%lea base index scale disp)))) +#-sb-xc-host +(progn + (defun sb!vm::%lea-mod32 (base index scale disp) + (let ((base (logand base #xffffffff)) + (index (logand index #xffffffff))) + ;; can't use modular version of %LEA, as we only have VOPs for + ;; constant SCALE and DISP. + (ldb (byte 32 0) (+ base (* index scale) disp)))) + (defun sb!vm::%lea-smod30 (base index scale disp) + (let ((base (mask-signed-field 30 base)) + (index (mask-signed-field 30 index))) + ;; can't use modular version of %LEA, as we only have VOPs for + ;; constant SCALE and DISP. + (mask-signed-field 30 (+ base (* index scale) disp))))) + +(in-package "SB!VM") + +(define-vop (%lea-mod32/unsigned=>unsigned + %lea/unsigned=>unsigned) + (:translate %lea-mod32)) +(define-vop (%lea-smod30/fixnum=>fixnum + %lea/fixnum=>fixnum) + (:translate %lea-smod30)) + +;;; logical operations +(define-modular-fun lognot-mod32 (x) lognot :unsigned 32) +(define-vop (lognot-mod32/word=>unsigned) + (:translate lognot-mod32) + (:args (x :scs (unsigned-reg signed-reg unsigned-stack signed-stack) :target r + :load-if (not (and (or (sc-is x unsigned-stack) + (sc-is x signed-stack)) + (or (sc-is r unsigned-stack) + (sc-is r signed-stack)) + (location= x r))))) + (:arg-types unsigned-num) + (:results (r :scs (unsigned-reg) + :load-if (not (and (or (sc-is x unsigned-stack) + (sc-is x signed-stack)) + (or (sc-is r unsigned-stack) + (sc-is r signed-stack)) + (sc-is r unsigned-stack) + (location= x r))))) + (:result-types unsigned-num) + (:policy :fast-safe) + (:generator 1 + (move r x) + (inst not r))) + +(define-modular-fun logxor-mod32 (x y) logxor :unsigned 32) +(define-mod-binop (fast-logxor-mod32/word=>unsigned + fast-logxor/unsigned=>unsigned) + logxor-mod32) +(define-mod-binop-c (fast-logxor-mod32-c/word=>unsigned + fast-logxor-c/unsigned=>unsigned) + logxor-mod32) +(define-vop (fast-logxor-mod32/fixnum=>fixnum + fast-logxor/fixnum=>fixnum) + (:translate logxor-mod32)) +(define-vop (fast-logxor-mod32-c/fixnum=>fixnum + fast-logxor-c/fixnum=>fixnum) + (:translate logxor-mod32)) + +(define-source-transform logeqv (&rest args) + (if (oddp (length args)) + `(logxor ,@args) + `(lognot (logxor ,@args)))) +(define-source-transform logandc1 (x y) + `(logand (lognot ,x) ,y)) +(define-source-transform logandc2 (x y) + `(logand ,x (lognot ,y))) +(define-source-transform logorc1 (x y) + `(logior (lognot ,x) ,y)) +(define-source-transform logorc2 (x y) + `(logior ,x (lognot ,y))) +(define-source-transform lognor (x y) + `(lognot (logior ,x ,y))) +(define-source-transform lognand (x y) + `(lognot (logand ,x ,y))) + +;;;; bignum stuff + +(define-vop (bignum-length get-header-data) + (:translate sb!bignum:%bignum-length) + (:policy :fast-safe)) + +(define-vop (bignum-set-length set-header-data) + (:translate sb!bignum:%bignum-set-length) + (:policy :fast-safe)) + +(define-full-reffer bignum-ref * bignum-digits-offset other-pointer-lowtag + (unsigned-reg) unsigned-num sb!bignum:%bignum-ref) +(define-full-reffer+offset bignum-ref-with-offset * + bignum-digits-offset other-pointer-lowtag + (unsigned-reg) unsigned-num sb!bignum:%bignum-ref-with-offset) +(define-full-setter bignum-set * bignum-digits-offset other-pointer-lowtag + (unsigned-reg) unsigned-num sb!bignum:%bignum-set) + +(define-vop (digit-0-or-plus) + (:translate sb!bignum:%digit-0-or-plusp) + (:policy :fast-safe) + (:args (digit :scs (unsigned-reg))) + (:arg-types unsigned-num) + (:conditional) + (:info target not-p) + (:generator 3 + (inst or digit digit) + (inst jmp (if not-p :s :ns) target))) + + +;;; For add and sub with carry the sc of carry argument is any-reg so +;;; that it may be passed as a fixnum or word and thus may be 0, 1, or +;;; 4. This is easy to deal with and may save a fixnum-word +;;; conversion. +(define-vop (add-w/carry) + (:translate sb!bignum:%add-with-carry) + (:policy :fast-safe) + (:args (a :scs (unsigned-reg) :target result) + (b :scs (unsigned-reg unsigned-stack) :to :eval) + (c :scs (any-reg) :target temp)) + (:arg-types unsigned-num unsigned-num positive-fixnum) + (:temporary (:sc any-reg :from (:argument 2) :to :eval) temp) + (:results (result :scs (unsigned-reg) :from (:argument 0)) + (carry :scs (unsigned-reg))) + (:result-types unsigned-num positive-fixnum) + (:generator 4 + (move result a) + (move temp c) + (inst neg temp) ; Set the carry flag to 0 if c=0 else to 1 + (inst adc result b) + (inst mov carry 0) + (inst adc carry carry))) + +;;; Note: the borrow is 1 for no borrow and 0 for a borrow, the opposite +;;; of the x86 convention. +(define-vop (sub-w/borrow) + (:translate sb!bignum:%subtract-with-borrow) + (:policy :fast-safe) + (:args (a :scs (unsigned-reg) :to :eval :target result) + (b :scs (unsigned-reg unsigned-stack) :to :result) + (c :scs (any-reg control-stack))) + (:arg-types unsigned-num unsigned-num positive-fixnum) + (:results (result :scs (unsigned-reg) :from :eval) + (borrow :scs (unsigned-reg))) + (:result-types unsigned-num positive-fixnum) + (:generator 5 + (inst cmp c 1) ; Set the carry flag to 1 if c=0 else to 0 + (move result a) + (inst sbb result b) + (inst mov borrow 1) + (inst sbb borrow 0))) + + +(define-vop (bignum-mult-and-add-3-arg) + (:translate sb!bignum:%multiply-and-add) + (:policy :fast-safe) + (:args (x :scs (unsigned-reg) :target eax) + (y :scs (unsigned-reg unsigned-stack)) + (carry-in :scs (unsigned-reg unsigned-stack))) + (:arg-types unsigned-num unsigned-num unsigned-num) + (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0) + :to (:result 1) :target lo) eax) + (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1) + :to (:result 0) :target hi) edx) + (:results (hi :scs (unsigned-reg)) + (lo :scs (unsigned-reg))) + (:result-types unsigned-num unsigned-num) + (:generator 20 + (move eax x) + (inst mul eax y) + (inst add eax carry-in) + (inst adc edx 0) + (move hi edx) + (move lo eax))) + +(define-vop (bignum-mult-and-add-4-arg) + (:translate sb!bignum:%multiply-and-add) + (:policy :fast-safe) + (:args (x :scs (unsigned-reg) :target eax) + (y :scs (unsigned-reg unsigned-stack)) + (prev :scs (unsigned-reg unsigned-stack)) + (carry-in :scs (unsigned-reg unsigned-stack))) + (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num) + (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0) + :to (:result 1) :target lo) eax) + (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1) + :to (:result 0) :target hi) edx) + (:results (hi :scs (unsigned-reg)) + (lo :scs (unsigned-reg))) + (:result-types unsigned-num unsigned-num) + (:generator 20 + (move eax x) + (inst mul eax y) + (inst add eax prev) + (inst adc edx 0) + (inst add eax carry-in) + (inst adc edx 0) + (move hi edx) + (move lo eax))) + + +(define-vop (bignum-mult) + (:translate sb!bignum:%multiply) + (:policy :fast-safe) + (:args (x :scs (unsigned-reg) :target eax) + (y :scs (unsigned-reg unsigned-stack))) + (:arg-types unsigned-num unsigned-num) + (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0) + :to (:result 1) :target lo) eax) + (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1) + :to (:result 0) :target hi) edx) + (:results (hi :scs (unsigned-reg)) + (lo :scs (unsigned-reg))) + (:result-types unsigned-num unsigned-num) + (:generator 20 + (move eax x) + (inst mul eax y) + (move hi edx) + (move lo eax))) + +(define-vop (bignum-lognot lognot-mod32/word=>unsigned) + (:translate sb!bignum:%lognot)) + +(define-vop (fixnum-to-digit) + (:translate sb!bignum:%fixnum-to-digit) + (:policy :fast-safe) + (:args (fixnum :scs (any-reg control-stack) :target digit)) + (:arg-types tagged-num) + (:results (digit :scs (unsigned-reg) + :load-if (not (and (sc-is fixnum control-stack) + (sc-is digit unsigned-stack) + (location= fixnum digit))))) + (:result-types unsigned-num) + (:generator 1 + (move digit fixnum) + (inst sar digit 2))) + +(define-vop (bignum-floor) + (:translate sb!bignum:%floor) + (:policy :fast-safe) + (:args (div-high :scs (unsigned-reg) :target edx) + (div-low :scs (unsigned-reg) :target eax) + (divisor :scs (unsigned-reg unsigned-stack))) + (:arg-types unsigned-num unsigned-num unsigned-num) + (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 1) + :to (:result 0) :target quo) eax) + (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 0) + :to (:result 1) :target rem) edx) + (:results (quo :scs (unsigned-reg)) + (rem :scs (unsigned-reg))) + (:result-types unsigned-num unsigned-num) + (:generator 300 + (move edx div-high) + (move eax div-low) + (inst div eax divisor) + (move quo eax) + (move rem edx))) + +(define-vop (signify-digit) + (:translate sb!bignum:%fixnum-digit-with-correct-sign) + (:policy :fast-safe) + (:args (digit :scs (unsigned-reg unsigned-stack) :target res)) + (:arg-types unsigned-num) + (:results (res :scs (any-reg signed-reg) + :load-if (not (and (sc-is digit unsigned-stack) + (sc-is res control-stack signed-stack) + (location= digit res))))) + (:result-types signed-num) + (:generator 1 + (move res digit) + (when (sc-is res any-reg control-stack) + (inst shl res 2)))) + +(define-vop (digit-ashr) + (:translate sb!bignum:%ashr) + (:policy :fast-safe) + (:args (digit :scs (unsigned-reg unsigned-stack) :target result) + (count :scs (unsigned-reg) :target ecx)) + (:arg-types unsigned-num positive-fixnum) + (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx) + (:results (result :scs (unsigned-reg) :from (:argument 0) + :load-if (not (and (sc-is result unsigned-stack) + (location= digit result))))) + (:result-types unsigned-num) + (:generator 2 + (move result digit) + (move ecx count) + (inst sar result :cl))) + +(define-vop (digit-ashr/c) + (:translate sb!bignum:%ashr) + (:policy :fast-safe) + (:args (digit :scs (unsigned-reg unsigned-stack) :target result)) + (:arg-types unsigned-num (:constant (integer 0 31))) + (:info count) + (:results (result :scs (unsigned-reg) :from (:argument 0) + :load-if (not (and (sc-is result unsigned-stack) + (location= digit result))))) + (:result-types unsigned-num) + (:generator 1 + (move result digit) + (inst sar result count))) + +(define-vop (digit-lshr digit-ashr) + (:translate sb!bignum:%digit-logical-shift-right) + (:generator 1 + (move result digit) + (move ecx count) + (inst shr result :cl))) + +(define-vop (digit-ashl digit-ashr) + (:translate sb!bignum:%ashl) + (:generator 1 + (move result digit) + (move ecx count) + (inst shl result :cl))) + +;;;; static functions + +(define-static-fun two-arg-/ (x y) :translate /) + +(define-static-fun two-arg-gcd (x y) :translate gcd) +(define-static-fun two-arg-lcm (x y) :translate lcm) + +(define-static-fun two-arg-and (x y) :translate logand) +(define-static-fun two-arg-ior (x y) :translate logior) +(define-static-fun two-arg-xor (x y) :translate logxor) + + +;;; Support for the Mersenne Twister, MT19937, random number generator +;;; due to Matsumoto and Nishimura. +;;; +;;; Makoto Matsumoto and T. Nishimura, "Mersenne twister: A +;;; 623-dimensionally equidistributed uniform pseudorandom number +;;; generator.", ACM Transactions on Modeling and Computer Simulation, +;;; 1997, to appear. +;;; +;;; State: +;;; 0-1: Constant matrix A. [0, #x9908b0df] (not used here) +;;; 2: Index; init. to 1. +;;; 3-626: State. +(defknown random-mt19937 ((simple-array (unsigned-byte 32) (*))) + (unsigned-byte 32) ()) +(define-vop (random-mt19937) + (:policy :fast-safe) + (:translate random-mt19937) + (:args (state :scs (descriptor-reg) :to :result)) + (:arg-types simple-array-unsigned-byte-32) + (:temporary (:sc unsigned-reg :from (:eval 0) :to :result) k) + (:temporary (:sc unsigned-reg :offset eax-offset + :from (:eval 0) :to :result) tmp) + (:results (y :scs (unsigned-reg) :from (:eval 0))) + (:result-types unsigned-num) + (:generator 50 + (loadw k state (+ 2 vector-data-offset) other-pointer-lowtag) + (inst cmp k 624) + (inst jmp :ne no-update) + (inst mov tmp state) ; The state is passed in EAX. + (inst call (make-fixup 'random-mt19937-update :assembly-routine)) + ;; Restore k, and set to 0. + (inst xor k k) + NO-UPDATE + ;; y = ptgfsr[k++]; + (inst mov y (make-ea-for-vector-data state :index k :offset 3)) + ;; y ^= (y >> 11); + (inst shr y 11) + (inst xor y (make-ea-for-vector-data state :index k :offset 3)) + ;; y ^= (y << 7) & #x9d2c5680 + (inst mov tmp y) + (inst inc k) + (inst shl tmp 7) + (storew k state (+ 2 vector-data-offset) other-pointer-lowtag) + (inst and tmp #x9d2c5680) + (inst xor y tmp) + ;; y ^= (y << 15) & #xefc60000 + (inst mov tmp y) + (inst shl tmp 15) + (inst and tmp #xefc60000) + (inst xor y tmp) + ;; y ^= (y >> 18); + (inst mov tmp y) + (inst shr tmp 18) + (inst xor y tmp))) + +(in-package "SB!C") + +(defun mask-result (class width result) + (ecase class + (:unsigned + `(logand ,result ,(1- (ash 1 width)))) + (:signed + `(mask-signed-field ,width ,result)))) + +;;; This is essentially a straight implementation of the algorithm in +;;; "Strength Reduction of Multiplications by Integer Constants", +;;; Youfeng Wu, ACM SIGPLAN Notices, Vol. 30, No.2, February 1995. +(defun basic-decompose-multiplication (class width arg num n-bits condensed) + (case (aref condensed 0) + (0 + (let ((tmp (min 3 (aref condensed 1)))) + (decf (aref condensed 1) tmp) + (mask-result class width + `(%lea ,arg + ,(decompose-multiplication class width + arg (ash (1- num) (- tmp)) (1- n-bits) (subseq condensed 1)) + ,(ash 1 tmp) 0)))) + ((1 2 3) + (let ((r0 (aref condensed 0))) + (incf (aref condensed 1) r0) + (mask-result class width + `(%lea ,(decompose-multiplication class width + arg (- num (ash 1 r0)) (1- n-bits) (subseq condensed 1)) + ,arg + ,(ash 1 r0) 0)))) + (t (let ((r0 (aref condensed 0))) + (setf (aref condensed 0) 0) + (mask-result class width + `(ash ,(decompose-multiplication class width + arg (ash num (- r0)) n-bits condensed) + ,r0)))))) + +(defun decompose-multiplication (class width arg num n-bits condensed) + (cond + ((= n-bits 0) 0) + ((= num 1) arg) + ((= n-bits 1) + (mask-result class width `(ash ,arg ,(1- (integer-length num))))) + ((let ((max 0) (end 0)) + (loop for i from 2 to (length condensed) + for j = (reduce #'+ (subseq condensed 0 i)) + when (and (> (- (* 2 i) 3 j) max) + (< (+ (ash 1 (1+ j)) + (ash (ldb (byte (- 32 (1+ j)) (1+ j)) num) + (1+ j))) + (ash 1 32))) + do (setq max (- (* 2 i) 3 j) + end i)) + (when (> max 0) + (let ((j (reduce #'+ (subseq condensed 0 end)))) + (let ((n2 (+ (ash 1 (1+ j)) + (ash (ldb (byte (- 32 (1+ j)) (1+ j)) num) (1+ j)))) + (n1 (1+ (ldb (byte (1+ j) 0) (lognot num))))) + (mask-result class width + `(- ,(optimize-multiply class width arg n2) + ,(optimize-multiply class width arg n1)))))))) + ((dolist (i '(9 5 3)) + (when (integerp (/ num i)) + (when (< (logcount (/ num i)) (logcount num)) + (let ((x (gensym))) + (return `(let ((,x ,(optimize-multiply class width arg (/ num i)))) + ,(mask-result class width + `(%lea ,x ,x (1- ,i) 0))))))))) + (t (basic-decompose-multiplication class width arg num n-bits condensed)))) + +(defun optimize-multiply (class width arg x) + (let* ((n-bits (logcount x)) + (condensed (make-array n-bits))) + (let ((count 0) (bit 0)) + (dotimes (i 32) + (cond ((logbitp i x) + (setf (aref condensed bit) count) + (setf count 1) + (incf bit)) + (t (incf count))))) + (decompose-multiplication class width arg x n-bits condensed))) + +(defun *-transformer (class width y) + (cond + ((= y (ash 1 (integer-length y))) + ;; there's a generic transform for y = 2^k + (give-up-ir1-transform)) + ((member y '(3 5 9)) + ;; we can do these multiplications directly using LEA + `(%lea x x ,(1- y) 0)) + ((member :pentium4 *backend-subfeatures*) + ;; the pentium4's multiply unit is reportedly very good + (give-up-ir1-transform)) + ;; FIXME: should make this more fine-grained. If nothing else, + ;; there should probably be a cutoff of about 9 instructions on + ;; pentium-class machines. + (t (optimize-multiply class width 'x y)))) + +(deftransform * ((x y) + ((unsigned-byte 32) (constant-arg (unsigned-byte 32))) + (unsigned-byte 32)) + "recode as leas, shifts and adds" + (let ((y (lvar-value y))) + (*-transformer :unsigned 32 y))) +(deftransform sb!vm::*-mod32 + ((x y) ((unsigned-byte 32) (constant-arg (unsigned-byte 32))) + (unsigned-byte 32)) + "recode as leas, shifts and adds" + (let ((y (lvar-value y))) + (*-transformer :unsigned 32 y))) + +(deftransform * ((x y) + ((signed-byte 30) (constant-arg (unsigned-byte 32))) + (signed-byte 30)) + "recode as leas, shifts and adds" + (let ((y (lvar-value y))) + (*-transformer :signed 30 y))) +(deftransform sb!vm::*-smod30 + ((x y) ((signed-byte 30) (constant-arg (unsigned-byte 32))) + (signed-byte 30)) + "recode as leas, shifts and adds" + (let ((y (lvar-value y))) + (*-transformer :signed 30 y))) + +;;; FIXME: we should also be able to write an optimizer or two to +;;; convert (+ (* x 2) 17), (- (* x 9) 5) to a %LEA. diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp -x external-format-test.txt -x test-status.lisp-expr sbcl-1.0.13-pristine/src/compiler/arm/array.lisp sbcl-1.0.13-arm5-pass1/src/compiler/arm/array.lisp --- sbcl-1.0.13-pristine/src/compiler/arm/array.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-1.0.13-arm5-pass1/src/compiler/arm/array.lisp 2007-12-28 17:57:08.123280315 -0500 @@ -0,0 +1,698 @@ +;;;; array operations for the x86 VM + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + +;;;; allocator for the array header + +(define-vop (make-array-header) + (:translate make-array-header) + (:policy :fast-safe) + (:args (type :scs (any-reg)) + (rank :scs (any-reg))) + (:arg-types positive-fixnum positive-fixnum) + (:temporary (:sc any-reg :to :eval) bytes) + (:temporary (:sc any-reg :to :result) header) + (:results (result :scs (descriptor-reg) :from :eval)) + (:node-var node) + (:generator 13 + (inst lea bytes + (make-ea :dword :base rank + :disp (+ (* (1+ array-dimensions-offset) n-word-bytes) + lowtag-mask))) + (inst and bytes (lognot lowtag-mask)) + (inst lea header (make-ea :dword :base rank + :disp (fixnumize (1- array-dimensions-offset)))) + (inst shl header n-widetag-bits) + (inst or header type) + (inst shr header 2) + (pseudo-atomic + (allocation result bytes node) + (inst lea result (make-ea :dword :base result :disp other-pointer-lowtag)) + (storew header result 0 other-pointer-lowtag)))) + +;;;; additional accessors and setters for the array header +(define-full-reffer %array-dimension * + array-dimensions-offset other-pointer-lowtag + (any-reg) positive-fixnum sb!kernel:%array-dimension) + +(define-full-setter %set-array-dimension * + array-dimensions-offset other-pointer-lowtag + (any-reg) positive-fixnum sb!kernel:%set-array-dimension) + +(define-vop (array-rank-vop) + (:translate sb!kernel:%array-rank) + (:policy :fast-safe) + (:args (x :scs (descriptor-reg))) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 6 + (loadw res x 0 other-pointer-lowtag) + (inst shr res n-widetag-bits) + (inst sub res (1- array-dimensions-offset)))) + +;;;; bounds checking routine + +;;; Note that the immediate SC for the index argument is disabled +;;; because it is not possible to generate a valid error code SC for +;;; an immediate value. +;;; +;;; FIXME: As per the KLUDGE note explaining the :IGNORE-FAILURE-P +;;; flag in build-order.lisp-expr, compiling this file causes warnings +;;; Argument FOO to VOP CHECK-BOUND has SC restriction +;;; DESCRIPTOR-REG which is not allowed by the operand type: +;;; (:OR POSITIVE-FIXNUM) +;;; CSR's message "format ~/ /" on sbcl-devel 2002-03-12 contained +;;; a possible patch, described as +;;; Another patch is included more for information than anything -- +;;; removing the descriptor-reg SCs from the CHECK-BOUND vop in +;;; x86/array.lisp seems to allow that file to compile without error[*], +;;; and build; I haven't tested rebuilding capability, but I'd be +;;; surprised if there were a problem. I'm not certain that this is the +;;; correct fix, though, as the restrictions on the arguments to the VOP +;;; aren't the same as in the sparc and alpha ports, where, incidentally, +;;; the corresponding file builds without error currently. +;;; Since neither of us (CSR or WHN) was quite sure that this is the +;;; right thing, I've just recorded the patch here in hopes it might +;;; help when someone attacks this problem again: +;;; diff -u -r1.7 array.lisp +;;; --- src/compiler/x86/array.lisp 11 Oct 2001 14:05:26 -0000 1.7 +;;; +++ src/compiler/x86/array.lisp 12 Mar 2002 12:23:37 -0000 +;;; @@ -76,10 +76,10 @@ +;;; (:translate %check-bound) +;;; (:policy :fast-safe) +;;; (:args (array :scs (descriptor-reg)) +;;; - (bound :scs (any-reg descriptor-reg)) +;;; - (index :scs (any-reg descriptor-reg #+nil immediate) :target result)) +;;; + (bound :scs (any-reg)) +;;; + (index :scs (any-reg #+nil immediate) :target result)) +;;; (:arg-types * positive-fixnum tagged-num) +;;; - (:results (result :scs (any-reg descriptor-reg))) +;;; + (:results (result :scs (any-reg))) +;;; (:result-types positive-fixnum) +;;; (:vop-var vop) +;;; (:save-p :compute-only) +(define-vop (check-bound) + (:translate %check-bound) + (:policy :fast-safe) + (:args (array :scs (descriptor-reg)) + (bound :scs (any-reg)) + (index :scs (any-reg #+nil immediate) :target result)) + (:arg-types * positive-fixnum tagged-num) + (:results (result :scs (any-reg))) + (:result-types positive-fixnum) + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (let ((error (generate-error-code vop invalid-array-index-error + array bound index)) + (index (if (sc-is index immediate) + (fixnumize (tn-value index)) + index))) + (inst cmp bound index) + ;; We use below-or-equal even though it's an unsigned test, + ;; because negative indexes appear as large unsigned numbers. + ;; Therefore, we get the <0 and >=bound test all rolled into one. + (inst jmp :be error) + (unless (and (tn-p index) (location= result index)) + (inst mov result index))))) + +;;;; accessors/setters + +;;; variants built on top of WORD-INDEX-REF, etc. I.e., those vectors +;;; whose elements are represented in integer registers and are built +;;; out of 8, 16, or 32 bit elements. +(macrolet ((def-full-data-vector-frobs (type element-type &rest scs) + `(progn + (define-full-reffer+offset ,(symbolicate "DATA-VECTOR-REF-WITH-OFFSET/" type) + ,type vector-data-offset other-pointer-lowtag ,scs + ,element-type data-vector-ref-with-offset) + (define-full-setter+offset ,(symbolicate "DATA-VECTOR-SET-WITH-OFFSET/" type) + ,type vector-data-offset other-pointer-lowtag ,scs + ,element-type data-vector-set-with-offset)))) + (def-full-data-vector-frobs simple-vector * descriptor-reg any-reg) + (def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num + unsigned-reg) + (def-full-data-vector-frobs simple-array-signed-byte-30 tagged-num any-reg) + (def-full-data-vector-frobs simple-array-unsigned-byte-29 positive-fixnum any-reg) + (def-full-data-vector-frobs simple-array-signed-byte-32 signed-num + signed-reg) + (def-full-data-vector-frobs simple-array-unsigned-byte-31 unsigned-num + unsigned-reg) + #!+sb-unicode + (def-full-data-vector-frobs simple-character-string character character-reg)) + +(define-full-compare-and-swap %compare-and-swap-svref simple-vector + vector-data-offset other-pointer-lowtag + (descriptor-reg any-reg) * + %compare-and-swap-svref) + +;;;; integer vectors whose elements are smaller than a byte, i.e., +;;;; bit, 2-bit, and 4-bit vectors + +(macrolet ((def-small-data-vector-frobs (type bits) + (let* ((elements-per-word (floor n-word-bits bits)) + (bit-shift (1- (integer-length elements-per-word)))) + `(progn + (define-vop (,(symbolicate 'data-vector-ref-with-offset/ type)) + (:note "inline array access") + (:translate data-vector-ref-with-offset) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (unsigned-reg))) + (:info offset) + (:arg-types ,type positive-fixnum (:constant (integer 0 0))) + (:results (result :scs (unsigned-reg) :from (:argument 0))) + (:result-types positive-fixnum) + (:temporary (:sc unsigned-reg :offset ecx-offset) ecx) + (:generator 20 + (aver (zerop offset)) + (move ecx index) + (inst shr ecx ,bit-shift) + (inst mov result (make-ea-for-vector-data object :index ecx)) + (move ecx index) + ;; We used to mask ECX for all values of ELEMENT-PER-WORD, + ;; but since Intel's documentation says that the chip will + ;; mask shift and rotate counts by 31 automatically, we can + ;; safely move the masking operation under the protection of + ;; this UNLESS in the bit-vector case. --njf, 2006-07-14 + ,@(unless (= elements-per-word n-word-bits) + `((inst and ecx ,(1- elements-per-word)) + (inst shl ecx ,(1- (integer-length bits))))) + (inst shr result :cl) + (inst and result ,(1- (ash 1 bits))))) + (define-vop (,(symbolicate 'data-vector-ref-c-with-offset/ type)) + (:translate data-vector-ref-with-offset) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:arg-types ,type (:constant index) (:constant (integer 0 0))) + (:info index offset) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 15 + (aver (zerop offset)) + (multiple-value-bind (word extra) (floor index ,elements-per-word) + (loadw result object (+ word vector-data-offset) + other-pointer-lowtag) + (unless (zerop extra) + (inst shr result (* extra ,bits))) + (unless (= extra ,(1- elements-per-word)) + (inst and result ,(1- (ash 1 bits))))))) + (define-vop (,(symbolicate 'data-vector-set-with-offset/ type)) + (:note "inline array store") + (:translate data-vector-set-with-offset) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to (:argument 2)) + (index :scs (unsigned-reg) :target ecx) + (value :scs (unsigned-reg immediate) :target result)) + (:info offset) + (:arg-types ,type positive-fixnum (:constant (integer 0 0)) + positive-fixnum) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:temporary (:sc unsigned-reg) word-index) + (:temporary (:sc unsigned-reg) old) + (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx) + (:generator 25 + (aver (zerop offset)) + (move word-index index) + (inst shr word-index ,bit-shift) + (inst mov old (make-ea-for-vector-data object :index word-index)) + (move ecx index) + ;; We used to mask ECX for all values of ELEMENT-PER-WORD, + ;; but since Intel's documentation says that the chip will + ;; mask shift and rotate counts by 31 automatically, we can + ;; safely move the masking operation under the protection of + ;; this UNLESS in the bit-vector case. --njf, 2006-07-14 + ,@(unless (= elements-per-word n-word-bits) + `((inst and ecx ,(1- elements-per-word)) + (inst shl ecx ,(1- (integer-length bits))))) + (inst ror old :cl) + (unless (and (sc-is value immediate) + (= (tn-value value) ,(1- (ash 1 bits)))) + (inst and old ,(lognot (1- (ash 1 bits))))) + (sc-case value + (immediate + (unless (zerop (tn-value value)) + (inst or old (logand (tn-value value) ,(1- (ash 1 bits)))))) + (unsigned-reg + (inst or old value))) + (inst rol old :cl) + (inst mov (make-ea-for-vector-data object :index word-index) + old) + (sc-case value + (immediate + (inst mov result (tn-value value))) + (unsigned-reg + (move result value))))) + (define-vop (,(symbolicate 'data-vector-set-c-with-offset/ type)) + (:translate data-vector-set-with-offset) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (value :scs (unsigned-reg immediate) :target result)) + (:arg-types ,type (:constant index) (:constant (integer 0 0)) + positive-fixnum) + (:info index offset) + (:results (result :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:temporary (:sc unsigned-reg :to (:result 0)) old) + (:generator 20 + (aver (zerop offset)) + (multiple-value-bind (word extra) (floor index ,elements-per-word) + (loadw old object (+ word vector-data-offset) other-pointer-lowtag) + (sc-case value + (immediate + (let* ((value (tn-value value)) + (mask ,(1- (ash 1 bits))) + (shift (* extra ,bits))) + (unless (= value mask) + (inst and old (ldb (byte n-word-bits 0) + (lognot (ash mask shift))))) + (unless (zerop value) + (inst or old (ash value shift))))) + (unsigned-reg + (let ((shift (* extra ,bits))) + (unless (zerop shift) + (inst ror old shift)) + (inst and old (lognot ,(1- (ash 1 bits)))) + (inst or old value) + (unless (zerop shift) + (inst rol old shift))))) + (storew old object (+ word vector-data-offset) other-pointer-lowtag) + (sc-case value + (immediate + (inst mov result (tn-value value))) + (unsigned-reg + (move result value)))))))))) + (def-small-data-vector-frobs simple-bit-vector 1) + (def-small-data-vector-frobs simple-array-unsigned-byte-2 2) + (def-small-data-vector-frobs simple-array-unsigned-byte-4 4)) + +;;; And the float variants. + +(defun make-ea-for-float-ref (object index offset element-size + &key (scale 1) (complex-offset 0)) + (sc-case index + (immediate + (make-ea :dword :base object + :disp (- (+ (* vector-data-offset n-word-bytes) + (* element-size (+ offset (tn-value index))) + complex-offset) + other-pointer-lowtag))) + (t + (make-ea :dword :base object :index index :scale scale + :disp (- (+ (* vector-data-offset n-word-bytes) + (* element-size offset) + complex-offset) + other-pointer-lowtag))))) + +(define-vop (data-vector-ref-with-offset/simple-array-single-float) + (:note "inline array access") + (:translate data-vector-ref-with-offset) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg immediate))) + (:info offset) + (:arg-types simple-array-single-float positive-fixnum + (:constant (constant-displacement other-pointer-lowtag + 4 vector-data-offset))) + (:results (value :scs (single-reg))) + (:result-types single-float) + (:generator 5 + (with-empty-tn@fp-top(value) + (inst fld (make-ea-for-float-ref object index offset 4))))) + +(define-vop (data-vector-set-with-offset/simple-array-single-float) + (:note "inline array store") + (:translate data-vector-set-with-offset) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg immediate)) + (value :scs (single-reg) :target result)) + (:info offset) + (:arg-types simple-array-single-float positive-fixnum + (:constant (constant-displacement other-pointer-lowtag + 4 vector-data-offset)) + single-float) + (:results (result :scs (single-reg))) + (:result-types single-float) + (:generator 5 + (cond ((zerop (tn-offset value)) + ;; Value is in ST0. + (inst fst (make-ea-for-float-ref object index offset 4)) + (unless (zerop (tn-offset result)) + ;; Value is in ST0 but not result. + (inst fst result))) + (t + ;; Value is not in ST0. + (inst fxch value) + (inst fst (make-ea-for-float-ref object index offset 4)) + (cond ((zerop (tn-offset result)) + ;; The result is in ST0. + (inst fst value)) + (t + ;; Neither value or result are in ST0 + (unless (location= value result) + (inst fst result)) + (inst fxch value))))))) + +(define-vop (data-vector-ref-with-offset/simple-array-double-float) + (:note "inline array access") + (:translate data-vector-ref-with-offset) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg immediate))) + (:info offset) + (:arg-types simple-array-double-float + positive-fixnum + (:constant (constant-displacement other-pointer-lowtag + 8 vector-data-offset))) + (:results (value :scs (double-reg))) + (:result-types double-float) + (:generator 7 + (with-empty-tn@fp-top(value) + (inst fldd (make-ea-for-float-ref object index offset 8 :scale 2))))) + +(define-vop (data-vector-set-with-offset/simple-array-double-float) + (:note "inline array store") + (:translate data-vector-set-with-offset) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg immediate)) + (value :scs (double-reg) :target result)) + (:info offset) + (:arg-types simple-array-double-float positive-fixnum + (:constant (constant-displacement other-pointer-lowtag + 8 vector-data-offset)) + double-float) + (:results (result :scs (double-reg))) + (:result-types double-float) + (:generator 20 + (cond ((zerop (tn-offset value)) + ;; Value is in ST0. + (inst fstd (make-ea-for-float-ref object index offset 8 :scale 2)) + (unless (zerop (tn-offset result)) + ;; Value is in ST0 but not result. + (inst fstd result))) + (t + ;; Value is not in ST0. + (inst fxch value) + (inst fstd (make-ea-for-float-ref object index offset 8 :scale 2)) + (cond ((zerop (tn-offset result)) + ;; The result is in ST0. + (inst fstd value)) + (t + ;; Neither value or result are in ST0 + (unless (location= value result) + (inst fstd result)) + (inst fxch value))))))) + +;;; complex float variants + +(define-vop (data-vector-ref-with-offset/simple-array-complex-single-float) + (:note "inline array access") + (:translate data-vector-ref-with-offset) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg immediate))) + (:info offset) + (:arg-types simple-array-complex-single-float positive-fixnum + (:constant (constant-displacement other-pointer-lowtag + 8 vector-data-offset))) + (:results (value :scs (complex-single-reg))) + (:result-types complex-single-float) + (:generator 5 + (let ((real-tn (complex-single-reg-real-tn value))) + (with-empty-tn@fp-top (real-tn) + (inst fld (make-ea-for-float-ref object index offset 8 :scale 2)))) + (let ((imag-tn (complex-single-reg-imag-tn value))) + (with-empty-tn@fp-top (imag-tn) + ;; FIXME + (inst fld (make-ea-for-float-ref object index offset 8 + :scale 2 :complex-offset 4)))))) + +(define-vop (data-vector-set-with-offset/simple-array-complex-single-float) + (:note "inline array store") + (:translate data-vector-set-with-offset) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg immediate)) + (value :scs (complex-single-reg) :target result)) + (:info offset) + (:arg-types simple-array-complex-single-float positive-fixnum + (:constant (constant-displacement other-pointer-lowtag + 8 vector-data-offset)) + complex-single-float) + (:results (result :scs (complex-single-reg))) + (:result-types complex-single-float) + (:generator 5 + (let ((value-real (complex-single-reg-real-tn value)) + (result-real (complex-single-reg-real-tn result))) + (cond ((zerop (tn-offset value-real)) + ;; Value is in ST0. + (inst fst (make-ea-for-float-ref object index offset 8 :scale 2)) + (unless (zerop (tn-offset result-real)) + ;; Value is in ST0 but not result. + (inst fst result-real))) + (t + ;; Value is not in ST0. + (inst fxch value-real) + (inst fst (make-ea-for-float-ref object index offset 8 :scale 2)) + (cond ((zerop (tn-offset result-real)) + ;; The result is in ST0. + (inst fst value-real)) + (t + ;; Neither value or result are in ST0 + (unless (location= value-real result-real) + (inst fst result-real)) + (inst fxch value-real)))))) + (let ((value-imag (complex-single-reg-imag-tn value)) + (result-imag (complex-single-reg-imag-tn result))) + (inst fxch value-imag) + (inst fst (make-ea-for-float-ref object index offset 8 + :scale 2 :complex-offset 4)) + (unless (location= value-imag result-imag) + (inst fst result-imag)) + (inst fxch value-imag)))) + +(define-vop (data-vector-ref-with-offset/simple-array-complex-double-float) + (:note "inline array access") + (:translate data-vector-ref-with-offset) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg immediate))) + (:info offset) + (:arg-types simple-array-complex-double-float positive-fixnum + (:constant (constant-displacement other-pointer-lowtag + 16 vector-data-offset))) + (:results (value :scs (complex-double-reg))) + (:result-types complex-double-float) + (:generator 7 + (let ((real-tn (complex-double-reg-real-tn value))) + (with-empty-tn@fp-top (real-tn) + (inst fldd (make-ea-for-float-ref object index offset 16 :scale 4))) + (let ((imag-tn (complex-double-reg-imag-tn value))) + (with-empty-tn@fp-top (imag-tn) + (inst fldd (make-ea-for-float-ref object index offset 16 + :scale 4 :complex-offset 8))))))) + +(define-vop (data-vector-set-with-offset/simple-array-complex-double-float) + (:note "inline array store") + (:translate data-vector-set-with-offset) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg immediate)) + (value :scs (complex-double-reg) :target result)) + (:info offset) + (:arg-types simple-array-complex-double-float positive-fixnum + (:constant (constant-displacement other-pointer-lowtag + 16 vector-data-offset)) + complex-double-float) + (:results (result :scs (complex-double-reg))) + (:result-types complex-double-float) + (:generator 20 + (let ((value-real (complex-double-reg-real-tn value)) + (result-real (complex-double-reg-real-tn result))) + (cond ((zerop (tn-offset value-real)) + ;; Value is in ST0. + (inst fstd (make-ea-for-float-ref object index offset 16 + :scale 4)) + (unless (zerop (tn-offset result-real)) + ;; Value is in ST0 but not result. + (inst fstd result-real))) + (t + ;; Value is not in ST0. + (inst fxch value-real) + (inst fstd (make-ea-for-float-ref object index offset 16 + :scale 4)) + (cond ((zerop (tn-offset result-real)) + ;; The result is in ST0. + (inst fstd value-real)) + (t + ;; Neither value or result are in ST0 + (unless (location= value-real result-real) + (inst fstd result-real)) + (inst fxch value-real)))))) + (let ((value-imag (complex-double-reg-imag-tn value)) + (result-imag (complex-double-reg-imag-tn result))) + (inst fxch value-imag) + (inst fstd (make-ea-for-float-ref object index offset 16 + :scale 4 :complex-offset 8)) + (unless (location= value-imag result-imag) + (inst fstd result-imag)) + (inst fxch value-imag)))) + + +;;; {un,}signed-byte-8, simple-base-string + +(macrolet ((define-data-vector-frobs (ptype element-type ref-inst + 8-bit-tns-p &rest scs) + `(progn + (define-vop (,(symbolicate "DATA-VECTOR-REF-WITH-OFFSET/" ptype)) + (:translate data-vector-ref-with-offset) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (unsigned-reg immediate))) + (:info offset) + (:arg-types ,ptype positive-fixnum + (:constant (constant-displacement other-pointer-lowtag + 1 vector-data-offset))) + (:results (value :scs ,scs)) + (:result-types ,element-type) + (:generator 5 + (sc-case index + (immediate + (inst ,ref-inst value (make-ea-for-vector-data + object :size :byte + :offset (+ (tn-value index) offset)))) + (t + (inst ,ref-inst value + (make-ea-for-vector-data object :size :byte + :index index :offset offset)))))) + (define-vop (,(symbolicate "DATA-VECTOR-SET-WITH-OFFSET/" ptype)) + (:translate data-vector-set-with-offset) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to (:eval 0)) + (index :scs (unsigned-reg immediate) :to (:eval 0)) + (value :scs ,scs ,@(unless 8-bit-tns-p + '(:target eax)))) + (:info offset) + (:arg-types ,ptype positive-fixnum + (:constant (constant-displacement other-pointer-lowtag + 1 vector-data-offset)) + ,element-type) + ,@(unless 8-bit-tns-p + '((:temporary (:sc unsigned-reg :offset eax-offset :target result + :from (:argument 2) :to (:result 0)) + eax))) + (:results (result :scs ,scs)) + (:result-types ,element-type) + (:generator 5 + ,@(unless 8-bit-tns-p + '((move eax value))) + (sc-case index + (immediate + (inst mov (make-ea-for-vector-data + object :size :byte :offset (+ (tn-value index) offset)) + ,(if 8-bit-tns-p + 'value + 'al-tn))) + (t + (inst mov (make-ea-for-vector-data object :size :byte + :index index :offset offset) + ,(if 8-bit-tns-p + 'value + 'al-tn)))) + (move result ,(if 8-bit-tns-p + 'value + 'eax))))))) + (define-data-vector-frobs simple-array-unsigned-byte-7 positive-fixnum + movzx nil unsigned-reg signed-reg) + (define-data-vector-frobs simple-array-unsigned-byte-8 positive-fixnum + movzx nil unsigned-reg signed-reg) + (define-data-vector-frobs simple-array-signed-byte-8 tagged-num + movsx nil signed-reg) + (define-data-vector-frobs simple-base-string character + #!+sb-unicode movzx #!-sb-unicode mov + #!+sb-unicode nil #!-sb-unicode t character-reg)) + +;;; {un,}signed-byte-16 +(macrolet ((define-data-vector-frobs (ptype element-type ref-inst &rest scs) + `(progn + (define-vop (,(symbolicate "DATA-VECTOR-REF-WITH-OFFSET/" ptype)) + (:translate data-vector-ref-with-offset) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (unsigned-reg immediate))) + (:info offset) + (:arg-types ,ptype positive-fixnum + (:constant (constant-displacement other-pointer-lowtag + 2 vector-data-offset))) + (:results (value :scs ,scs)) + (:result-types ,element-type) + (:generator 5 + (sc-case index + (immediate + (inst ,ref-inst value + (make-ea-for-vector-data object :size :word + :offset (+ (tn-value index) offset)))) + (t + (inst ,ref-inst value + (make-ea-for-vector-data object :size :word + :index index :offset offset)))))) + (define-vop (,(symbolicate "DATA-VECTOR-SET-WITH-OFFSET/" ptype)) + (:translate data-vector-set-with-offset) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to (:eval 0)) + (index :scs (unsigned-reg immediate) :to (:eval 0)) + (value :scs ,scs :target eax)) + (:info offset) + (:arg-types ,ptype positive-fixnum + (:constant (constant-displacement other-pointer-lowtag + 2 vector-data-offset)) + ,element-type) + (:temporary (:sc unsigned-reg :offset eax-offset :target result + :from (:argument 2) :to (:result 0)) + eax) + (:results (result :scs ,scs)) + (:result-types ,element-type) + (:generator 5 + (move eax value) + (sc-case index + (immediate + (inst mov (make-ea-for-vector-data + object :size :word :offset (+ (tn-value index) offset)) + ax-tn)) + (t + (inst mov (make-ea-for-vector-data object :size :word + :index index :offset offset) + ax-tn))) + (move result eax)))))) + (define-data-vector-frobs simple-array-unsigned-byte-15 positive-fixnum + movzx unsigned-reg signed-reg) + (define-data-vector-frobs simple-array-unsigned-byte-16 positive-fixnum + movzx unsigned-reg signed-reg) + (define-data-vector-frobs simple-array-signed-byte-16 tagged-num + movsx signed-reg)) + + +;;; These vops are useful for accessing the bits of a vector +;;; irrespective of what type of vector it is. +(define-full-reffer+offset raw-bits-with-offset * 0 other-pointer-lowtag (unsigned-reg) + unsigned-num %raw-bits-with-offset) +(define-full-setter+offset set-raw-bits-with-offset * 0 other-pointer-lowtag (unsigned-reg) + unsigned-num %set-raw-bits-with-offset) + + +;;;; miscellaneous array VOPs + +(define-vop (get-vector-subtype get-header-data)) +(define-vop (set-vector-subtype set-header-data)) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp -x external-format-test.txt -x test-status.lisp-expr sbcl-1.0.13-pristine/src/compiler/arm/backend-parms.lisp sbcl-1.0.13-arm5-pass1/src/compiler/arm/backend-parms.lisp --- sbcl-1.0.13-pristine/src/compiler/arm/backend-parms.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-1.0.13-arm5-pass1/src/compiler/arm/backend-parms.lisp 2007-12-28 17:57:08.124280162 -0500 @@ -0,0 +1,50 @@ +;;;; that part of the parms.lisp file from original CMU CL which is defined in +;;;; terms of the BACKEND structure +;;;; +;;;; FIXME: When we break up the BACKEND structure, this might be mergeable +;;;; back into the parms.lisp file. + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + +;;;; compiler constants + +(def!constant +backend-fasl-file-implementation+ :x86) + +(setf *backend-register-save-penalty* 3) + +(setf *backend-byte-order* :little-endian) + +;;; KLUDGE: It would seem natural to set this by asking our C runtime +;;; code for it, but mostly we need it for GENESIS, which doesn't in +;;; general have our C runtime code running to ask, so instead we set +;;; it by hand. -- WHN 2001-04-15 +;;; +;;; Actually any information that we can retrieve C-side would be +;;; useless in SBCL, since it's possible for otherwise binary +;;; compatible systems to return different values for getpagesize(). +;;; -- JES, 2007-01-06 +(eval-when (:compile-toplevel :load-toplevel :execute) + (setf *backend-page-size* 4096)) +;;; comment from CMU CL: +;;; +;;; in case we ever wanted to do this for Windows NT.. +;;; +;;; Windows NT uses a memory system granularity of 64K, which means +;;; everything that gets mapped must be a multiple of that. The real +;;; page size is 512, but that doesn't do us a whole lot of good. +;;; Effectively, the page size is 64K. +;;; +;;; would be: (setf *backend-page-size* 65536) + +;;; The size in bytes of the GENCGC pages. Should be a multiple of the +;;; architecture code size. +(def!constant gencgc-page-size *backend-page-size*) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp -x external-format-test.txt -x test-status.lisp-expr sbcl-1.0.13-pristine/src/compiler/arm/c-call.lisp sbcl-1.0.13-arm5-pass1/src/compiler/arm/c-call.lisp --- sbcl-1.0.13-pristine/src/compiler/arm/c-call.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-1.0.13-arm5-pass1/src/compiler/arm/c-call.lisp 2007-12-28 17:57:08.126279857 -0500 @@ -0,0 +1,404 @@ +;;;; the VOPs and other necessary machine specific support +;;;; routines for call-out to C + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + +;; The MOVE-ARG vop is going to store args on the stack for +;; call-out. These tn's will be used for that. move-arg is normally +;; used for things going down the stack but C wants to have args +;; indexed in the positive direction. + +(defun my-make-wired-tn (prim-type-name sc-name offset) + (make-wired-tn (primitive-type-or-lose prim-type-name) + (sc-number-or-lose sc-name) + offset)) + +(defstruct (arg-state (:copier nil)) + (stack-frame-size 0)) + +(define-alien-type-method (integer :arg-tn) (type state) + (let ((stack-frame-size (arg-state-stack-frame-size state))) + (setf (arg-state-stack-frame-size state) (1+ stack-frame-size)) + (multiple-value-bind (ptype stack-sc) + (if (alien-integer-type-signed type) + (values 'signed-byte-32 'signed-stack) + (values 'unsigned-byte-32 'unsigned-stack)) + (my-make-wired-tn ptype stack-sc stack-frame-size)))) + +(define-alien-type-method (system-area-pointer :arg-tn) (type state) + (declare (ignore type)) + (let ((stack-frame-size (arg-state-stack-frame-size state))) + (setf (arg-state-stack-frame-size state) (1+ stack-frame-size)) + (my-make-wired-tn 'system-area-pointer + 'sap-stack + stack-frame-size))) + +#!+long-float +(define-alien-type-method (long-float :arg-tn) (type state) + (declare (ignore type)) + (let ((stack-frame-size (arg-state-stack-frame-size state))) + (setf (arg-state-stack-frame-size state) (+ stack-frame-size 3)) + (my-make-wired-tn 'long-float 'long-stack stack-frame-size))) + +(define-alien-type-method (double-float :arg-tn) (type state) + (declare (ignore type)) + (let ((stack-frame-size (arg-state-stack-frame-size state))) + (setf (arg-state-stack-frame-size state) (+ stack-frame-size 2)) + (my-make-wired-tn 'double-float 'double-stack stack-frame-size))) + +(define-alien-type-method (single-float :arg-tn) (type state) + (declare (ignore type)) + (let ((stack-frame-size (arg-state-stack-frame-size state))) + (setf (arg-state-stack-frame-size state) (1+ stack-frame-size)) + (my-make-wired-tn 'single-float 'single-stack stack-frame-size))) + +(defstruct (result-state (:copier nil)) + (num-results 0)) + +(defun result-reg-offset (slot) + (ecase slot + (0 eax-offset) + (1 edx-offset))) + +(define-alien-type-method (integer :result-tn) (type state) + (let ((num-results (result-state-num-results state))) + (setf (result-state-num-results state) (1+ num-results)) + (multiple-value-bind (ptype reg-sc) + (if (alien-integer-type-signed type) + (values 'signed-byte-32 'signed-reg) + (values 'unsigned-byte-32 'unsigned-reg)) + (my-make-wired-tn ptype reg-sc (result-reg-offset num-results))))) + +(define-alien-type-method (system-area-pointer :result-tn) (type state) + (declare (ignore type)) + (let ((num-results (result-state-num-results state))) + (setf (result-state-num-results state) (1+ num-results)) + (my-make-wired-tn 'system-area-pointer 'sap-reg + (result-reg-offset num-results)))) + +#!+long-float +(define-alien-type-method (long-float :result-tn) (type state) + (declare (ignore type)) + (let ((num-results (result-state-num-results state))) + (setf (result-state-num-results state) (1+ num-results)) + (my-make-wired-tn 'long-float 'long-reg (* num-results 2)))) + +(define-alien-type-method (double-float :result-tn) (type state) + (declare (ignore type)) + (let ((num-results (result-state-num-results state))) + (setf (result-state-num-results state) (1+ num-results)) + (my-make-wired-tn 'double-float 'double-reg (* num-results 2)))) + +(define-alien-type-method (single-float :result-tn) (type state) + (declare (ignore type)) + (let ((num-results (result-state-num-results state))) + (setf (result-state-num-results state) (1+ num-results)) + (my-make-wired-tn 'single-float 'single-reg (* num-results 2)))) + +(define-alien-type-method (values :result-tn) (type state) + (let ((values (alien-values-type-values type))) + (when (> (length values) 2) + (error "Too many result values from c-call.")) + (mapcar (lambda (type) + (invoke-alien-type-method :result-tn type state)) + values))) + +(!def-vm-support-routine make-call-out-tns (type) + (let ((arg-state (make-arg-state))) + (collect ((arg-tns)) + (dolist (arg-type (alien-fun-type-arg-types type)) + (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state))) + (values (my-make-wired-tn 'positive-fixnum 'any-reg esp-offset) + (* (arg-state-stack-frame-size arg-state) n-word-bytes) + (arg-tns) + (invoke-alien-type-method :result-tn + (alien-fun-type-result-type type) + (make-result-state)))))) + + +(deftransform %alien-funcall ((function type &rest args) * * :node node) + (aver (sb!c::constant-lvar-p type)) + (let* ((type (sb!c::lvar-value type)) + (env (sb!c::node-lexenv node)) + (arg-types (alien-fun-type-arg-types type)) + (result-type (alien-fun-type-result-type type))) + (aver (= (length arg-types) (length args))) + (if (or (some #'(lambda (type) + (and (alien-integer-type-p type) + (> (sb!alien::alien-integer-type-bits type) 32))) + arg-types) + (and (alien-integer-type-p result-type) + (> (sb!alien::alien-integer-type-bits result-type) 32))) + (collect ((new-args) (lambda-vars) (new-arg-types)) + (dolist (type arg-types) + (let ((arg (gensym))) + (lambda-vars arg) + (cond ((and (alien-integer-type-p type) + (> (sb!alien::alien-integer-type-bits type) 32)) + (new-args `(logand ,arg #xffffffff)) + (new-args `(ash ,arg -32)) + (new-arg-types (parse-alien-type '(unsigned 32) env)) + (if (alien-integer-type-signed type) + (new-arg-types (parse-alien-type '(signed 32) env)) + (new-arg-types (parse-alien-type '(unsigned 32) env)))) + (t + (new-args arg) + (new-arg-types type))))) + (cond ((and (alien-integer-type-p result-type) + (> (sb!alien::alien-integer-type-bits result-type) 32)) + (let ((new-result-type + (let ((sb!alien::*values-type-okay* t)) + (parse-alien-type + (if (alien-integer-type-signed result-type) + '(values (unsigned 32) (signed 32)) + '(values (unsigned 32) (unsigned 32))) + env)))) + `(lambda (function type ,@(lambda-vars)) + (declare (ignore type)) + (multiple-value-bind (low high) + (%alien-funcall function + ',(make-alien-fun-type + :arg-types (new-arg-types) + :result-type new-result-type) + ,@(new-args)) + (logior low (ash high 32)))))) + (t + `(lambda (function type ,@(lambda-vars)) + (declare (ignore type)) + (%alien-funcall function + ',(make-alien-fun-type + :arg-types (new-arg-types) + :result-type result-type) + ,@(new-args)))))) + (sb!c::give-up-ir1-transform)))) + +(define-vop (foreign-symbol-sap) + (:translate foreign-symbol-sap) + (:policy :fast-safe) + (:args) + (:arg-types (:constant simple-string)) + (:info foreign-symbol) + (:results (res :scs (sap-reg))) + (:result-types system-area-pointer) + (:generator 2 + (inst lea res (make-fixup foreign-symbol :foreign)))) + +#!+linkage-table +(define-vop (foreign-symbol-dataref-sap) + (:translate foreign-symbol-dataref-sap) + (:policy :fast-safe) + (:args) + (:arg-types (:constant simple-string)) + (:info foreign-symbol) + (:results (res :scs (sap-reg))) + (:result-types system-area-pointer) + (:generator 2 + (inst mov res (make-fixup foreign-symbol :foreign-dataref)))) + +(define-vop (call-out) + (:args (function :scs (sap-reg)) + (args :more t)) + (:results (results :more t)) + (:temporary (:sc unsigned-reg :offset eax-offset + :from :eval :to :result) eax) + (:temporary (:sc unsigned-reg :offset ecx-offset + :from :eval :to :result) ecx) + (:temporary (:sc unsigned-reg :offset edx-offset + :from :eval :to :result) edx) + (:node-var node) + (:vop-var vop) + (:save-p t) + (:ignore args ecx edx) + (:generator 0 + ;; FIXME & OAOOM: This is brittle and error-prone to maintain two + ;; instances of the same logic, on in arch-assem.S, and one in + ;; c-call.lisp. If you modify this, modify that one too... + (cond ((policy node (> space speed)) + (move eax function) + (inst call (make-fixup "call_into_c" :foreign))) + (t + ;; Setup the NPX for C; all the FP registers need to be + ;; empty; pop them all. + (dotimes (i 8) + (inst fstp fr0-tn)) + + ;; Clear out DF: Darwin, Windows, and Solaris at least require + ;; this, and it should not hurt others either. + (inst cld) + + (inst call function) + ;; To give the debugger a clue. FIXME: not really internal-error? + (note-this-location vop :internal-error) + + ;; Restore the NPX for lisp; ensure no regs are empty + (dotimes (i 7) + (inst fldz)) + + (if (and results + (location= (tn-ref-tn results) fr0-tn)) + ;; The return result is in fr0. + (inst fxch fr7-tn) ; move the result back to fr0 + (inst fldz)) ; insure no regs are empty + )))) + +;;; While SBCL uses the FPU in 53-bit mode, most C libraries assume that +;;; the FPU is in 64-bit mode. So we change the FPU mode to 64-bit with +;;; the SET-FPU-WORD-FOR-C VOP before calling out to C and set it back +;;; to 53-bit mode after coming back using the SET-FPU-WORD-FOR-LISP VOP. +(define-vop (set-fpu-word-for-c) + (:node-var node) + (:generator 0 + (when (policy node (= sb!c::float-accuracy 3)) + (inst sub esp-tn 4) + (inst fnstcw (make-ea :word :base esp-tn)) + (inst wait) + (inst or (make-ea :word :base esp-tn) #x300) + (inst fldcw (make-ea :word :base esp-tn)) + (inst wait)))) + +(define-vop (set-fpu-word-for-lisp) + (:node-var node) + (:generator 0 + (when (policy node (= sb!c::float-accuracy 3)) + (inst fnstcw (make-ea :word :base esp-tn)) + (inst wait) + (inst and (make-ea :word :base esp-tn) #xfeff) + (inst fldcw (make-ea :word :base esp-tn)) + (inst wait) + (inst add esp-tn 4)))) + +(define-vop (alloc-number-stack-space) + (:info amount) + (:results (result :scs (sap-reg any-reg))) + (:generator 0 + (aver (location= result esp-tn)) + (unless (zerop amount) + (let ((delta (logandc2 (+ amount 3) 3))) + (inst sub esp-tn delta))) + (align-stack-pointer esp-tn) + (move result esp-tn))) + +(define-vop (alloc-alien-stack-space) + (:info amount) + #!+sb-thread (:temporary (:sc unsigned-reg) temp) + (:results (result :scs (sap-reg any-reg))) + #!+sb-thread + (:generator 0 + (aver (not (location= result esp-tn))) + (unless (zerop amount) + (let ((delta (logandc2 (+ amount 3) 3))) + (inst mov temp + (make-ea-for-symbol-tls-index *alien-stack*)) + (inst fs-segment-prefix) + (inst sub (make-ea :dword :base temp) delta))) + (load-tl-symbol-value result *alien-stack*)) + #!-sb-thread + (:generator 0 + (aver (not (location= result esp-tn))) + (unless (zerop amount) + (let ((delta (logandc2 (+ amount 3) 3))) + (inst sub (make-ea-for-symbol-value *alien-stack*) + delta))) + (load-symbol-value result *alien-stack*))) + +(define-vop (dealloc-alien-stack-space) + (:info amount) + #!+sb-thread (:temporary (:sc unsigned-reg) temp) + #!+sb-thread + (:generator 0 + (unless (zerop amount) + (let ((delta (logandc2 (+ amount 3) 3))) + (inst mov temp + (make-ea-for-symbol-tls-index *alien-stack*)) + (inst fs-segment-prefix) + (inst add (make-ea :dword :base temp) delta)))) + #!-sb-thread + (:generator 0 + (unless (zerop amount) + (let ((delta (logandc2 (+ amount 3) 3))) + (inst add (make-ea-for-symbol-value *alien-stack*) + delta))))) + +;;; not strictly part of the c-call convention, but needed for the +;;; WITH-PINNED-OBJECTS macro used for "locking down" lisp objects so +;;; that GC won't move them while foreign functions go to work. +(define-vop (touch-object) + (:translate touch-object) + (:args (object)) + (:ignore object) + (:policy :fast-safe) + (:arg-types t) + (:generator 0)) + +#-sb-xc-host +(defun alien-callback-accessor-form (type sp offset) + `(deref (sap-alien (sap+ ,sp ,offset) (* ,type)))) + +#-sb-xc-host +(defun alien-callback-assembler-wrapper (index return-type arg-types) + "Cons up a piece of code which calls call-callback with INDEX and a +pointer to the arguments." + (declare (ignore arg-types)) + (let* ((segment (make-segment)) + (eax eax-tn) + (edx edx-tn) + (ebp ebp-tn) + (esp esp-tn) + ([ebp-8] (make-ea :dword :base ebp :disp -8)) + ([ebp-4] (make-ea :dword :base ebp :disp -4))) + (assemble (segment) + (inst push ebp) ; save old frame pointer + (inst mov ebp esp) ; establish new frame + (inst mov eax esp) ; + (inst sub eax 8) ; place for result + (inst push eax) ; arg2 + (inst add eax 16) ; arguments + (inst push eax) ; arg1 + (inst push (ash index 2)) ; arg0 + + ;; Indirect the access to ENTER-ALIEN-CALLBACK through + ;; the symbol-value slot of SB-ALIEN::*ENTER-ALIEN-CALLBACK* + ;; to ensure it'll work even if the GC moves ENTER-ALIEN-CALLBACK. + ;; Skip any SB-THREAD TLS magic, since we don't expecte anyone + ;; to rebind the variable. -- JES, 2006-01-01 + (load-symbol-value eax sb!alien::*enter-alien-callback*) + (inst push eax) ; function + (inst mov eax (foreign-symbol-address "funcall3")) + (inst call eax) + ;; now put the result into the right register + (cond + ((and (alien-integer-type-p return-type) + (eql (alien-type-bits return-type) 64)) + (inst mov eax [ebp-8]) + (inst mov edx [ebp-4])) + ((or (alien-integer-type-p return-type) + (alien-pointer-type-p return-type) + (alien-type-= #.(parse-alien-type 'system-area-pointer nil) + return-type)) + (inst mov eax [ebp-8])) + ((alien-single-float-type-p return-type) + (inst fld [ebp-8])) + ((alien-double-float-type-p return-type) + (inst fldd [ebp-8])) + ((alien-void-type-p return-type)) + (t + (error "unrecognized alien type: ~A" return-type))) + (inst mov esp ebp) ; discard frame + (inst pop ebp) ; restore frame pointer + (inst ret)) + (finalize-segment segment) + ;; Now that the segment is done, convert it to a static + ;; vector we can point foreign code to. + (let ((buffer (sb!assem::segment-buffer segment))) + (make-static-vector (length buffer) + :element-type '(unsigned-byte 8) + :initial-contents buffer)))) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp -x external-format-test.txt -x test-status.lisp-expr sbcl-1.0.13-pristine/src/compiler/arm/call.lisp sbcl-1.0.13-arm5-pass1/src/compiler/arm/call.lisp --- sbcl-1.0.13-pristine/src/compiler/arm/call.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-1.0.13-arm5-pass1/src/compiler/arm/call.lisp 2007-12-28 17:57:08.130279247 -0500 @@ -0,0 +1,1482 @@ +;;;; function call for the x86 VM + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + +;;;; interfaces to IR2 conversion + +;;; Return a wired TN describing the N'th full call argument passing +;;; location. +(!def-vm-support-routine 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 + (nth n *register-arg-offsets*)) + (make-wired-tn *backend-t-primitive-type* control-stack-sc-number n))) + +;;; Make a passing location TN for a local call return PC. +;;; +;;; Always wire the return PC location to the stack in its standard +;;; location. +(!def-vm-support-routine 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)) + +;;; This is similar to MAKE-RETURN-PC-PASSING-LOCATION, but makes a +;;; location to pass OLD-FP in. +;;; +;;; This is wired in both the standard and the local-call conventions, +;;; 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) + (declare (ignore standard)) + (make-wired-tn *fixnum-primitive-type* control-stack-sc-number + ocfp-save-offset)) + +;;; Make the TNs used to hold OLD-FP and RETURN-PC within the current +;;; function. We treat these specially so that the debugger can find +;;; them at a known location. +;;; +;;; 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) + (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) + (physenv-debug-live-tn + (make-wired-tn (primitive-type-or-lose 'system-area-pointer) + sap-stack-sc-number return-pc-save-offset) + physenv)) + +;;; 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 () + (make-wired-tn *fixnum-primitive-type* any-reg-sc-number ecx-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 () + (make-restricted-tn *fixnum-primitive-type* ignore-me-sc-number)) + +(!def-vm-support-routine make-stack-pointer-tn () + (make-normal-tn *fixnum-primitive-type*)) + +(!def-vm-support-routine 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 () + (list (make-stack-pointer-tn) + (make-normal-tn *fixnum-primitive-type*))) + +;;; This function is called by the ENTRY-ANALYZE phase, allowing +;;; 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) + (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)) + (vector-push-extend nil + (ir2-component-constants (component-info component)))) + (values)) + +;;;; frame hackery + +;;; This is used for setting up the Old-FP in local call. +(define-vop (current-fp) + (:results (val :scs (any-reg control-stack))) + (:generator 1 + (move val ebp-tn))) + +;;; We don't have a separate NFP, so we don't need to do anything here. +(define-vop (compute-old-nfp) + (:results (val)) + (:ignore val) + (:generator 1 + nil)) + +(define-vop (xep-allocate-frame) + (:info start-lab copy-more-arg-follows) + (:vop-var vop) + (:generator 1 + (align n-lowtag-bits) + (trace-table-entry trace-table-fun-prologue) + (emit-label start-lab) + ;; Skip space for the function header. + (inst simple-fun-header-word) + (dotimes (i (1- simple-fun-code-offset)) + (inst dword 0)) + + ;; The start of the actual code. + ;; Save the return-pc. + (popw ebp-tn (frame-word-offset return-pc-save-offset)) + + ;; If copy-more-arg follows it will allocate the correct stack + ;; size. The stack is not allocated first here as this may expose + ;; args on the stack if they take up more space than the frame! + (unless copy-more-arg-follows + ;; The args fit within the frame so just allocate the frame. + (inst lea esp-tn + (make-ea :dword :base ebp-tn + :disp (- (* n-word-bytes + (max 3 (sb-allocated-size 'stack))))))) + + (trace-table-entry trace-table-normal))) + +;;; This is emitted directly before either a known-call-local, call-local, +;;; or a multiple-call-local. All it does is allocate stack space for the +;;; callee (who has the same size stack as us). +(define-vop (allocate-frame) + (:results (res :scs (any-reg control-stack)) + (nfp)) + (:info callee) + (:ignore nfp callee) + (:generator 2 + (move res esp-tn) + (inst sub esp-tn (* n-word-bytes (sb-allocated-size 'stack))))) + +;;; Allocate a partial frame for passing stack arguments in a full +;;; call. NARGS is the number of arguments passed. We allocate at +;;; least 3 slots, because the XEP noise is going to want to use them +;;; before it can extend the stack. +(define-vop (allocate-full-call-frame) + (:info nargs) + (:results (res :scs (any-reg control-stack))) + (:generator 2 + (move res esp-tn) + (inst sub esp-tn (* (max nargs 3) n-word-bytes)))) + +;;; Emit code needed at the return-point from an unknown-values call +;;; for a fixed number of values. Values is the head of the TN-REF +;;; list for the locations that the values are to be received into. +;;; Nvals is the number of values that are to be received (should +;;; equal the length of Values). +;;; +;;; MOVE-TEMP is a DESCRIPTOR-REG TN used as a temporary. +;;; +;;; This code exploits the fact that in the unknown-values convention, +;;; a single value return returns at the return PC + 2, whereas a +;;; return of other than one value returns directly at the return PC. +;;; +;;; If 0 or 1 values are expected, then we just emit an instruction to +;;; reset the SP (which will only be executed when other than 1 value +;;; is returned.) +;;; +;;; In the general case we have to do three things: +;;; -- Default unsupplied register values. This need only be done +;;; when a single value is returned, since register values are +;;; defaulted by the called in the non-single case. +;;; -- Default unsupplied stack values. This needs to be done whenever +;;; there are stack values. +;;; -- Reset SP. This must be done whenever other than 1 value is +;;; returned, regardless of the number of values desired. +(defun default-unknown-values (vop values nvals) + (declare (type (or tn-ref null) values) + (type unsigned-byte nvals)) + (cond + ((<= nvals 1) + (note-this-location vop :single-value-return) + (let ((single-value (gen-label))) + (cond + ((member :cmov *backend-subfeatures*) + (inst cmov :c esp-tn ebx-tn)) + (t + (inst jmp :nc single-value) + (inst mov esp-tn ebx-tn) + (emit-label single-value))))) + ((<= nvals register-arg-count) + (let ((regs-defaulted (gen-label))) + (note-this-location vop :unknown-return) + (inst jmp :c regs-defaulted) + ;; Default the unsuppled registers. + (let* ((2nd-tn-ref (tn-ref-across values)) + (2nd-tn (tn-ref-tn 2nd-tn-ref))) + (inst mov 2nd-tn nil-value) + (when (> nvals 2) + (loop + for tn-ref = (tn-ref-across 2nd-tn-ref) + then (tn-ref-across tn-ref) + for count from 2 below register-arg-count + do (inst mov (tn-ref-tn tn-ref) 2nd-tn)))) + (inst mov ebx-tn esp-tn) + (emit-label regs-defaulted) + (inst mov esp-tn ebx-tn))) + ((<= nvals 7) + ;; The number of bytes depends on the relative jump instructions. + ;; Best case is 31+(n-3)*14, worst case is 35+(n-3)*18. For + ;; NVALS=6 that is 73/89 bytes, and for NVALS=7 that is 87/107 + ;; bytes which is likely better than using the blt below. + (let ((regs-defaulted (gen-label)) + (defaulting-done (gen-label)) + (default-stack-slots (gen-label))) + (note-this-location vop :unknown-return) + ;; Branch off to the MV case. + (inst jmp :c regs-defaulted) + ;; Do the single value case. + ;; Default the register args + (inst mov eax-tn nil-value) + (do ((i 1 (1+ i)) + (val (tn-ref-across values) (tn-ref-across val))) + ((= i (min nvals register-arg-count))) + (inst mov (tn-ref-tn val) eax-tn)) + + ;; Fake other registers so it looks like we returned with all the + ;; registers filled in. + (move ebx-tn esp-tn) + (inst push edx-tn) + (inst jmp default-stack-slots) + + (emit-label regs-defaulted) + + (inst mov eax-tn nil-value) + (storew edx-tn ebx-tn -1) + (collect ((defaults)) + (do ((i register-arg-count (1+ i)) + (val (do ((i 0 (1+ i)) + (val values (tn-ref-across val))) + ((= i register-arg-count) val)) + (tn-ref-across val))) + ((null val)) + (let ((default-lab (gen-label)) + (tn (tn-ref-tn val))) + (defaults (cons default-lab tn)) + + (inst cmp ecx-tn (fixnumize i)) + (inst jmp :be default-lab) + (loadw edx-tn ebx-tn (frame-word-offset i)) + (inst mov tn edx-tn))) + + (emit-label defaulting-done) + (loadw edx-tn ebx-tn -1) + (move esp-tn ebx-tn) + + (let ((defaults (defaults))) + (when defaults + (assemble (*elsewhere*) + (trace-table-entry trace-table-fun-prologue) + (emit-label default-stack-slots) + (dolist (default defaults) + (emit-label (car default)) + (inst mov (cdr default) eax-tn)) + (inst jmp defaulting-done) + (trace-table-entry trace-table-normal))))))) + (t + ;; 91 bytes for this branch. + (let ((regs-defaulted (gen-label)) + (restore-edi (gen-label)) + (no-stack-args (gen-label)) + (default-stack-vals (gen-label)) + (count-okay (gen-label))) + (note-this-location vop :unknown-return) + ;; Branch off to the MV case. + (inst jmp :c regs-defaulted) + + ;; Default the register args, and set up the stack as if we + ;; entered the MV return point. + (inst mov ebx-tn esp-tn) + (inst push edx-tn) + (inst mov edi-tn nil-value) + (inst push edi-tn) + (inst mov esi-tn edi-tn) + ;; Compute a pointer to where to put the [defaulted] stack values. + (emit-label no-stack-args) + (inst lea edi-tn + (make-ea :dword :base ebp-tn + :disp (frame-byte-offset register-arg-count))) + ;; Load EAX with NIL so we can quickly store it, and set up + ;; stuff for the loop. + (inst mov eax-tn nil-value) + (inst std) + (inst mov ecx-tn (- nvals register-arg-count)) + ;; Jump into the default loop. + (inst jmp default-stack-vals) + + ;; The regs are defaulted. We need to copy any stack arguments, + ;; and then default the remaining stack arguments. + (emit-label regs-defaulted) + ;; Save EDI. + (storew edi-tn ebx-tn (frame-word-offset 1)) + ;; Compute the number of stack arguments, and if it's zero or + ;; less, don't copy any stack arguments. + (inst sub ecx-tn (fixnumize register-arg-count)) + (inst jmp :le no-stack-args) + + ;; Throw away any unwanted args. + (inst cmp ecx-tn (fixnumize (- nvals register-arg-count))) + (inst jmp :be count-okay) + (inst mov ecx-tn (fixnumize (- nvals register-arg-count))) + (emit-label count-okay) + ;; Save the number of stack values. + (inst mov eax-tn ecx-tn) + ;; Compute a pointer to where the stack args go. + (inst lea edi-tn + (make-ea :dword :base ebp-tn + :disp (frame-byte-offset register-arg-count))) + ;; Save ESI, and compute a pointer to where the args come from. + (storew esi-tn ebx-tn (frame-word-offset 2)) + (inst lea esi-tn + (make-ea :dword :base ebx-tn + :disp (frame-byte-offset register-arg-count))) + ;; Do the copy. + (inst shr ecx-tn word-shift) ; make word count + (inst std) + (inst rep) + (inst movs :dword) + ;; Restore ESI. + (loadw esi-tn ebx-tn (frame-word-offset 2)) + ;; Now we have to default the remaining args. Find out how many. + (inst sub eax-tn (fixnumize (- nvals register-arg-count))) + (inst neg eax-tn) + ;; If none, then just blow out of here. + (inst jmp :le restore-edi) + (inst mov ecx-tn eax-tn) + (inst shr ecx-tn word-shift) ; word count + ;; Load EAX with NIL for fast storing. + (inst mov eax-tn nil-value) + ;; Do the store. + (emit-label default-stack-vals) + (inst rep) + (inst stos eax-tn) + ;; Restore EDI, and reset the stack. + (emit-label restore-edi) + (loadw edi-tn ebx-tn (frame-word-offset 1)) + (inst mov esp-tn ebx-tn)))) + (values)) + +;;;; unknown values receiving + +;;; Emit code needed at the return point for an unknown-values call +;;; for an arbitrary number of values. +;;; +;;; We do the single and non-single cases with no shared code: there +;;; doesn't seem to be any potential overlap, and receiving a single +;;; value is more important efficiency-wise. +;;; +;;; When there is a single value, we just push it on the stack, +;;; returning the old SP and 1. +;;; +;;; When there is a variable number of values, we move all of the +;;; argument registers onto the stack, and return ARGS and NARGS. +;;; +;;; ARGS and NARGS are TNs wired to the named locations. We must +;;; explicitly allocate these TNs, since their lifetimes overlap with +;;; the results start and count. (Also, it's nice to be able to target +;;; them.) +(defun receive-unknown-values (args nargs start count) + (declare (type tn args nargs start count)) + (let ((variable-values (gen-label)) + (done (gen-label))) + (inst jmp :c variable-values) + + (cond ((location= start (first *register-arg-tns*)) + (inst push (first *register-arg-tns*)) + (inst lea start (make-ea :dword :base esp-tn :disp 4))) + (t (inst mov start esp-tn) + (inst push (first *register-arg-tns*)))) + (inst mov count (fixnumize 1)) + (inst jmp done) + + (emit-label variable-values) + ;; dtc: this writes the registers onto the stack even if they are + ;; not needed, only the number specified in ecx are used and have + ;; stack allocated to them. No harm is done. + (loop + for arg in *register-arg-tns* + for i downfrom -1 + do (storew arg args i)) + (move start args) + (move count nargs) + + (emit-label done)) + (values)) + +;;; VOP that can be inherited by unknown values receivers. The main thing this +;;; handles is allocation of the result temporaries. +(define-vop (unknown-values-receiver) + (:temporary (:sc descriptor-reg :offset ebx-offset + :from :eval :to (:result 0)) + values-start) + (:temporary (:sc any-reg :offset ecx-offset + :from :eval :to (:result 1)) + nvals) + (:results (start :scs (any-reg control-stack)) + (count :scs (any-reg control-stack)))) + +;;;; local call with unknown values convention return + +;;; Non-TR local call for a fixed number of values passed according to +;;; the unknown values convention. +;;; +;;; FP is the frame pointer in install before doing the call. +;;; +;;; NFP would be the number-stack frame pointer if we had a separate +;;; number stack. +;;; +;;; Args are the argument passing locations, which are specified only +;;; to terminate their lifetimes in the caller. +;;; +;;; VALUES are the return value locations (wired to the standard +;;; passing locations). NVALS is the number of values received. +;;; +;;; Save is the save info, which we can ignore since saving has been +;;; done. +;;; +;;; TARGET is a continuation pointing to the start of the called +;;; function. +(define-vop (call-local) + (:args (fp) + (nfp) + (args :more t)) + (:results (values :more t)) + (:save-p t) + (:move-args :local-call) + (:info arg-locs callee target nvals) + (:vop-var vop) + (:ignore nfp arg-locs args #+nil callee) + (:generator 5 + (trace-table-entry trace-table-call-site) + (move ebp-tn fp) + + (let ((ret-tn (callee-return-pc-tn callee))) + #+nil + (format t "*call-local ~S; tn-kind ~S; tn-save-tn ~S; its tn-kind ~S~%" + ret-tn (sb!c::tn-kind ret-tn) (sb!c::tn-save-tn ret-tn) + (sb!c::tn-kind (sb!c::tn-save-tn ret-tn))) + + ;; Is the return-pc on the stack or in a register? + (sc-case ret-tn + ((sap-stack) + #+nil (format t "*call-local: ret-tn on stack; offset=~S~%" + (tn-offset ret-tn)) + (storew (make-fixup nil :code-object return) + ebp-tn (frame-word-offset (tn-offset ret-tn)))) + ((sap-reg) + (inst lea ret-tn (make-fixup nil :code-object return))))) + + (note-this-location vop :call-site) + (inst jmp target) + RETURN + (default-unknown-values vop values nvals) + (trace-table-entry trace-table-normal))) + +;;; Non-TR local call for a variable number of return values passed according +;;; to the unknown values convention. The results are the start of the values +;;; glob and the number of values received. +(define-vop (multiple-call-local unknown-values-receiver) + (:args (fp) + (nfp) + (args :more t)) + (:save-p t) + (:move-args :local-call) + (:info save callee target) + (:ignore args save nfp #+nil callee) + (:vop-var vop) + (:generator 20 + (trace-table-entry trace-table-call-site) + (move ebp-tn fp) + + (let ((ret-tn (callee-return-pc-tn callee))) + #+nil + (format t "*multiple-call-local ~S; tn-kind ~S; tn-save-tn ~S; its tn-kind ~S~%" + ret-tn (sb!c::tn-kind ret-tn) (sb!c::tn-save-tn ret-tn) + (sb!c::tn-kind (sb!c::tn-save-tn ret-tn))) + + ;; Is the return-pc on the stack or in a register? + (sc-case ret-tn + ((sap-stack) + #+nil (format t "*multiple-call-local: ret-tn on stack; offset=~S~%" + (tn-offset ret-tn)) + ;; Stack + (storew (make-fixup nil :code-object return) + ebp-tn (frame-word-offset (tn-offset ret-tn)))) + ((sap-reg) + ;; Register + (inst lea ret-tn (make-fixup nil :code-object return))))) + + (note-this-location vop :call-site) + (inst jmp target) + RETURN + (note-this-location vop :unknown-return) + (receive-unknown-values values-start nvals start count) + (trace-table-entry trace-table-normal))) + +;;;; local call with known values return + +;;; Non-TR local call with known return locations. Known-value return +;;; works just like argument passing in local call. +;;; +;;; Note: we can't use normal load-tn allocation for the fixed args, +;;; since all registers may be tied up by the more operand. Instead, +;;; we use MAYBE-LOAD-STACK-TN. +(define-vop (known-call-local) + (:args (fp) + (nfp) + (args :more t)) + (:results (res :more t)) + (:move-args :local-call) + (:save-p t) + (:info save callee target) + (:ignore args res save nfp #+nil callee) + (:vop-var vop) + (:generator 5 + (trace-table-entry trace-table-call-site) + (move ebp-tn fp) + + (let ((ret-tn (callee-return-pc-tn callee))) + + #+nil + (format t "*known-call-local ~S; tn-kind ~S; tn-save-tn ~S; its tn-kind ~S~%" + ret-tn (sb!c::tn-kind ret-tn) (sb!c::tn-save-tn ret-tn) + (sb!c::tn-kind (sb!c::tn-save-tn ret-tn))) + + ;; Is the return-pc on the stack or in a register? + (sc-case ret-tn + ((sap-stack) + #+nil (format t "*known-call-local: ret-tn on stack; offset=~S~%" + (tn-offset ret-tn)) + ;; Stack + (storew (make-fixup nil :code-object return) + ebp-tn (frame-word-offset (tn-offset ret-tn)))) + ((sap-reg) + ;; Register + (inst lea ret-tn (make-fixup nil :code-object return))))) + + (note-this-location vop :call-site) + (inst jmp target) + RETURN + (note-this-location vop :known-return) + (trace-table-entry trace-table-normal))) + +;;; Return from known values call. We receive the return locations as +;;; arguments to terminate their lifetimes in the returning function. We +;;; restore FP and CSP and jump to the Return-PC. +;;; +;;; We can assume we know exactly where old-fp and return-pc are because +;;; make-old-fp-save-location and make-return-pc-save-location always +;;; return the same place. +#+nil +(define-vop (known-return) + (:args (old-fp) + (return-pc :scs (any-reg immediate-stack) :target rpc) + (vals :more t)) + (:move-args :known-return) + (:info val-locs) + (:temporary (:sc unsigned-reg :from (:argument 1)) rpc) + (:ignore val-locs vals) + (:vop-var vop) + (:generator 6 + (trace-table-entry trace-table-fun-epilogue) + ;; Save the return-pc in a register 'cause the frame-pointer is + ;; going away. Note this not in the usual stack location so we + ;; can't use RET + (move rpc return-pc) + ;; Restore the stack. + (move esp-tn ebp-tn) + ;; Restore the old fp. We know OLD-FP is going to be in its stack + ;; save slot, which is a different frame that than this one, + ;; so we don't have to worry about having just cleared + ;; most of the stack. + (move ebp-tn old-fp) + (inst jmp rpc) + (trace-table-entry trace-table-normal))) + +;;; From Douglas Crosher +;;; Return from known values call. We receive the return locations as +;;; arguments to terminate their lifetimes in the returning function. We +;;; restore FP and CSP and jump to the Return-PC. +;;; +;;; The old-fp may be either in a register or on the stack in its +;;; standard save locations - slot 0. +;;; +;;; The return-pc may be in a register or on the stack in any slot. +(define-vop (known-return) + (:args (old-fp) + (return-pc) + (vals :more t)) + (:move-args :known-return) + (:info val-locs) + (:ignore val-locs vals) + (:vop-var vop) + (:generator 6 + (trace-table-entry trace-table-fun-epilogue) + + #+nil (format t "*known-return: old-fp ~S, tn-kind ~S; ~S ~S~%" + old-fp (sb!c::tn-kind old-fp) (sb!c::tn-save-tn old-fp) + (sb!c::tn-kind (sb!c::tn-save-tn old-fp))) + + #+nil (format t "*known-return: return-pc ~S, tn-kind ~S; ~S ~S~%" + return-pc (sb!c::tn-kind return-pc) + (sb!c::tn-save-tn return-pc) + (sb!c::tn-kind (sb!c::tn-save-tn return-pc))) + + ;; return-pc may be either in a register or on the stack. + (sc-case return-pc + ((sap-reg) + (sc-case old-fp + ((control-stack) + + #+nil (format t "*known-return: old-fp ~S on stack; offset=~S~%" + old-fp (tn-offset old-fp)) + + (cond ((zerop (tn-offset old-fp)) + ;; Zot all of the stack except for the old-fp. + (inst lea esp-tn (make-ea :dword :base ebp-tn + :disp (frame-byte-offset ocfp-save-offset))) + ;; Restore the old fp from its save location on the stack, + ;; and zot the stack. + (inst pop ebp-tn)) + + (t + (cerror "Continue anyway" + "VOP return-local doesn't work if old-fp (in slot ~ + ~S) is not in slot 0" + (tn-offset old-fp))))) + + ((any-reg descriptor-reg) + ;; Zot all the stack. + (move esp-tn ebp-tn) + ;; Restore the old-fp. + (move ebp-tn old-fp))) + + ;; Return; return-pc is in a register. + (inst jmp return-pc)) + + ((sap-stack) + + #+nil (format t "*known-return: return-pc ~S on stack; offset=~S~%" + return-pc (tn-offset return-pc)) + + ;; Zot all of the stack except for the old-fp and return-pc. + (inst lea esp-tn + (make-ea :dword :base ebp-tn + :disp (frame-byte-offset (tn-offset return-pc)))) + ;; Restore the old fp. old-fp may be either on the stack in its + ;; save location or in a register, in either case this restores it. + (move ebp-tn old-fp) + ;; The return pops the return address (4 bytes), then we need + ;; to pop all the slots before the return-pc which includes the + ;; 4 bytes for the old-fp. + (inst ret (* (tn-offset return-pc) n-word-bytes)))) + + (trace-table-entry trace-table-normal))) + +;;;; full call +;;; +;;; There is something of a cross-product effect with full calls. +;;; Different versions are used depending on whether we know the +;;; number of arguments or the name of the called function, and +;;; whether we want fixed values, unknown values, or a tail call. +;;; +;;; In full call, the arguments are passed creating a partial frame on +;;; the stack top and storing stack arguments into that frame. On +;;; entry to the callee, this partial frame is pointed to by FP. + +;;; This macro helps in the definition of full call VOPs by avoiding +;;; code replication in defining the cross-product VOPs. +;;; +;;; NAME is the name of the VOP to define. +;;; +;;; NAMED is true if the first argument is an fdefinition object whose +;;; definition is to be called. +;;; +;;; RETURN is either :FIXED, :UNKNOWN or :TAIL: +;;; -- If :FIXED, then the call is for a fixed number of values, returned in +;;; the standard passing locations (passed as result operands). +;;; -- If :UNKNOWN, then the result values are pushed on the stack, and the +;;; result values are specified by the Start and Count as in the +;;; unknown-values continuation representation. +;;; -- If :TAIL, then do a tail-recursive call. No values are returned. +;;; The Old-Fp and Return-PC are passed as the second and third arguments. +;;; +;;; In non-tail calls, the pointer to the stack arguments is passed as +;;; the last fixed argument. If Variable is false, then the passing +;;; locations are passed as a more arg. Variable is true if there are +;;; a variable number of arguments passed on the stack. Variable +;;; cannot be specified with :TAIL return. TR variable argument call +;;; is implemented separately. +;;; +;;; In tail call with fixed arguments, the passing locations are +;;; passed as a more arg, but there is no new-FP, since the arguments +;;; have been set up in the current frame. +(macrolet ((define-full-call (name named return variable) + (aver (not (and variable (eq return :tail)))) + `(define-vop (,name + ,@(when (eq return :unknown) + '(unknown-values-receiver))) + (:args + ,@(unless (eq return :tail) + '((new-fp :scs (any-reg) :to (:argument 1)))) + + (fun :scs (descriptor-reg control-stack) + :target eax :to (:argument 0)) + + ,@(when (eq return :tail) + '((old-fp) + (return-pc))) + + ,@(unless variable '((args :more t :scs (descriptor-reg))))) + + ,@(when (eq return :fixed) + '((:results (values :more t)))) + + (:save-p ,(if (eq return :tail) :compute-only t)) + + ,@(unless (or (eq return :tail) variable) + '((:move-args :full-call))) + + (:vop-var vop) + (:info + ,@(unless (or variable (eq return :tail)) '(arg-locs)) + ,@(unless variable '(nargs)) + ,@(when (eq return :fixed) '(nvals)) + step-instrumenting) + + (:ignore + ,@(unless (or variable (eq return :tail)) '(arg-locs)) + ,@(unless variable '(args))) + + ;; We pass either the fdefn object (for named call) or + ;; the actual function object (for unnamed call) in + ;; EAX. With named call, closure-tramp will replace it + ;; with the real function and invoke the real function + ;; for closures. Non-closures do not need this value, + ;; so don't care what shows up in it. + (:temporary + (:sc descriptor-reg + :offset eax-offset + :from (:argument 0) + :to :eval) + eax) + + ;; We pass the number of arguments in ECX. + (:temporary (:sc unsigned-reg :offset ecx-offset :to :eval) ecx) + + ;; With variable call, we have to load the + ;; register-args out of the (new) stack frame before + ;; doing the call. Therefore, we have to tell the + ;; lifetime stuff that we need to use them. + ,@(when variable + (mapcar (lambda (name offset) + `(:temporary (:sc descriptor-reg + :offset ,offset + :from (:argument 0) + :to :eval) + ,name)) + *register-arg-names* *register-arg-offsets*)) + + ,@(when (eq return :tail) + '((:temporary (:sc unsigned-reg + :from (:argument 1) + :to (:argument 2)) + old-fp-tmp))) + + (:generator ,(+ (if named 5 0) + (if variable 19 1) + (if (eq return :tail) 0 10) + 15 + (if (eq return :unknown) 25 0)) + (trace-table-entry trace-table-call-site) + + ;; This has to be done before the frame pointer is + ;; changed! EAX stores the 'lexical environment' needed + ;; for closures. + (move eax fun) + + + ,@(if variable + ;; For variable call, compute the number of + ;; arguments and move some of the arguments to + ;; registers. + (collect ((noise)) + ;; Compute the number of arguments. + (noise '(inst mov ecx new-fp)) + (noise '(inst sub ecx esp-tn)) + ;; Move the necessary args to registers, + ;; this moves them all even if they are + ;; not all needed. + (loop + for name in *register-arg-names* + for index downfrom -1 + do (noise `(loadw ,name new-fp ,index))) + (noise)) + '((if (zerop nargs) + (inst xor ecx ecx) + (inst mov ecx (fixnumize nargs))))) + ,@(cond ((eq return :tail) + '(;; Python has figured out what frame we should + ;; return to so might as well use that clue. + ;; This seems really important to the + ;; implementation of things like + ;; (without-interrupts ...) + ;; + ;; dtc; Could be doing a tail call from a + ;; known-local-call etc in which the old-fp + ;; or ret-pc are in regs or in non-standard + ;; places. If the passing location were + ;; wired to the stack in standard locations + ;; then these moves will be un-necessary; + ;; this is probably best for the x86. + (sc-case old-fp + ((control-stack) + (unless (= ocfp-save-offset + (tn-offset old-fp)) + ;; FIXME: FORMAT T for stale + ;; diagnostic output (several of + ;; them around here), ick + (format t "** tail-call old-fp not S0~%") + (move old-fp-tmp old-fp) + (storew old-fp-tmp + ebp-tn + (frame-word-offset ocfp-save-offset)))) + ((any-reg descriptor-reg) + (format t "** tail-call old-fp in reg not S0~%") + (storew old-fp + ebp-tn + (frame-word-offset ocfp-save-offset)))) + + ;; For tail call, we have to push the + ;; return-pc so that it looks like we CALLed + ;; despite the fact that we are going to JMP. + (inst push return-pc) + )) + (t + ;; For non-tail call, we have to save our + ;; frame pointer and install the new frame + ;; pointer. We can't load stack tns after this + ;; point. + `(;; Python doesn't seem to allocate a frame + ;; here which doesn't leave room for the + ;; ofp/ret stuff. + + ;; The variable args are on the stack and + ;; become the frame, but there may be <3 + ;; args and 3 stack slots are assumed + ;; allocate on the call. So need to ensure + ;; there are at least 3 slots. This hack + ;; just adds 3 more. + ,(if variable + '(inst sub esp-tn (fixnumize 3))) + + ;; Save the fp + (storew ebp-tn new-fp (frame-word-offset ocfp-save-offset)) + + (move ebp-tn new-fp) ; NB - now on new stack frame. + ))) + + (when step-instrumenting + (emit-single-step-test) + (inst jmp :eq DONE) + (inst break single-step-around-trap)) + DONE + + (note-this-location vop :call-site) + + (inst ,(if (eq return :tail) 'jmp 'call) + ,(if named + '(make-ea-for-object-slot eax fdefn-raw-addr-slot + other-pointer-lowtag) + '(make-ea-for-object-slot eax closure-fun-slot + fun-pointer-lowtag))) + ,@(ecase return + (:fixed + '((default-unknown-values vop values nvals))) + (:unknown + '((note-this-location vop :unknown-return) + (receive-unknown-values values-start nvals start count))) + (:tail)) + (trace-table-entry trace-table-normal))))) + + (define-full-call call nil :fixed nil) + (define-full-call call-named t :fixed nil) + (define-full-call multiple-call nil :unknown nil) + (define-full-call multiple-call-named t :unknown nil) + (define-full-call tail-call nil :tail nil) + (define-full-call tail-call-named t :tail nil) + + (define-full-call call-variable nil :fixed t) + (define-full-call multiple-call-variable nil :unknown t)) + +;;; This is defined separately, since it needs special code that BLT's +;;; the arguments down. All the real work is done in the assembly +;;; routine. We just set things up so that it can find what it needs. +(define-vop (tail-call-variable) + (:args (args :scs (any-reg control-stack) :target esi) + (function :scs (descriptor-reg control-stack) :target eax) + (old-fp) + (ret-addr)) + (:temporary (:sc unsigned-reg :offset esi-offset :from (:argument 0)) esi) + (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 1)) eax) +; (:ignore ret-addr old-fp) + (:generator 75 + ;; Move these into the passing locations if they are not already there. + (move esi args) + (move eax function) + + ;; The following assumes that the return-pc and old-fp are on the + ;; stack in their standard save locations - Check this. + (unless (and (sc-is old-fp control-stack) + (= (tn-offset old-fp) ocfp-save-offset)) + (error "tail-call-variable: ocfp not on stack in standard save location?")) + (unless (and (sc-is ret-addr sap-stack) + (= (tn-offset ret-addr) return-pc-save-offset)) + (error "tail-call-variable: ret-addr not on stack in standard save location?")) + + + ;; And jump to the assembly routine. + (inst jmp (make-fixup 'tail-call-variable :assembly-routine)))) + +;;;; unknown values return + +;;; Return a single-value using the Unknown-Values convention. Specifically, +;;; we jump to clear the stack and jump to return-pc+2. +;;; +;;; We require old-fp to be in a register, because we want to reset ESP before +;;; restoring EBP. If old-fp were still on the stack, it could get clobbered +;;; by a signal. +;;; +;;; pfw--get wired-tn conflicts sometimes if register sc specd for args +;;; having problems targeting args to regs -- using temps instead. +;;; +;;; First off, modifying the return-pc defeats the branch-prediction +;;; optimizations on modern CPUs quite handily. Second, we can do all +;;; this without needing a temp register. Fixed the latter, at least. +;;; -- AB 2006/Feb/04 +(define-vop (return-single) + (:args (old-fp) + (return-pc) + (value)) + (:ignore value) + (:generator 6 + (trace-table-entry trace-table-fun-epilogue) + ;; Code structure lifted from known-return. + (sc-case return-pc + ((sap-reg) + ;; return PC in register for some reason (local call?) + ;; we jmp to the return pc after fixing the stack and frame. + (sc-case old-fp + ((control-stack) + ;; ofp on stack must be in slot 0 (the traditional storage place). + ;; Drop the stack above it and pop it off. + (cond ((zerop (tn-offset old-fp)) + (inst lea esp-tn (make-ea :dword :base ebp-tn + :disp (frame-byte-offset ocfp-save-offset))) + (inst pop ebp-tn)) + (t + ;; Should this ever happen, we do the same as above, but + ;; using (tn-offset old-fp) instead of ocfp-save-offset + ;; (which is 0 anyway, see src/compiler/x86/vm.lisp) and + ;; then lea esp again against itself with a displacement + ;; of (* (tn-offset old-fp) n-word-bytes) to clear the + ;; rest of the stack. + (cerror "Continue anyway" + "VOP return-single doesn't work if old-fp (in slot ~S) is not in slot 0" (tn-offset old-fp))))) + ((any-reg descriptor-reg) + ;; ofp in reg, drop the stack and load the real fp. + (move esp-tn ebp-tn) + (move ebp-tn old-fp))) + + ;; Set single-value-return flag + (inst clc) + ;; And return + (inst jmp return-pc)) + + ((sap-stack) + ;; Note that this will only work right if, when old-fp is on + ;; the stack, it has a lower tn-offset than return-pc. One of + ;; the comments in known-return indicate that this is the case + ;; (in that it will be in its save location), but we may wish + ;; to assert that (in either the weaker or stronger forms). + ;; Should this ever not be the case, we should load old-fp + ;; into a temp reg while we fix the stack. + ;; Drop stack above return-pc + (inst lea esp-tn (make-ea :dword :base ebp-tn + :disp (frame-byte-offset (tn-offset return-pc)))) + ;; Set single-value return flag + (inst clc) + ;; Restore the old frame pointer + (move ebp-tn old-fp) + ;; And return, dropping the rest of the stack as we go. + (inst ret (* (tn-offset return-pc) n-word-bytes)))))) + +;;; Do unknown-values return of a fixed (other than 1) number of +;;; values. The VALUES are required to be set up in the standard +;;; passing locations. NVALS is the number of values returned. +;;; +;;; Basically, we just load ECX with the number of values returned and +;;; EBX with a pointer to the values, set ESP to point to the end of +;;; the values, and jump directly to return-pc. +(define-vop (return) + (:args (old-fp) + (return-pc :to (:eval 1)) + (values :more t)) + (:ignore values) + (:info nvals) + + ;; In the case of other than one value, we need these registers to + ;; tell the caller where they are and how many there are. + (:temporary (:sc unsigned-reg :offset ebx-offset) ebx) + (:temporary (:sc unsigned-reg :offset ecx-offset) ecx) + + ;; We need to stretch the lifetime of return-pc past the argument + ;; registers so that we can default the argument registers without + ;; trashing return-pc. + (:temporary (:sc unsigned-reg :offset (first *register-arg-offsets*) + :from :eval) a0) + (:temporary (:sc unsigned-reg :offset (second *register-arg-offsets*) + :from :eval) a1) + (:temporary (:sc unsigned-reg :offset (third *register-arg-offsets*) + :from :eval) a2) + + (:generator 6 + (trace-table-entry trace-table-fun-epilogue) + ;; Establish the values pointer and values count. + (move ebx ebp-tn) + (if (zerop nvals) + (inst xor ecx ecx) ; smaller + (inst mov ecx (fixnumize nvals))) + ;; Restore the frame pointer. + (move ebp-tn old-fp) + ;; Clear as much of the stack as possible, but not past the return + ;; address. + (inst lea esp-tn (make-ea :dword :base ebx + :disp (- (* (max nvals 2) n-word-bytes)))) + ;; Pre-default any argument register that need it. + (when (< nvals register-arg-count) + (let* ((arg-tns (nthcdr nvals (list a0 a1 a2))) + (first (first arg-tns))) + (inst mov first nil-value) + (dolist (tn (cdr arg-tns)) + (inst mov tn first)))) + ;; Set multi-value return flag. + (inst stc) + ;; And away we go. Except that return-pc is still on the + ;; stack and we've changed the stack pointer. So we have to + ;; tell it to index off of EBX instead of EBP. + (cond ((zerop nvals) + ;; Return popping the return address and the OCFP. + (inst ret n-word-bytes)) + ((= nvals 1) + ;; Return popping the return, leaving 1 slot. Can this + ;; happen, or is a single value return handled elsewhere? + (inst ret)) + (t + (inst jmp (make-ea :dword :base ebx + :disp (frame-byte-offset (tn-offset return-pc)))))) + + (trace-table-entry trace-table-normal))) + +;;; Do unknown-values return of an arbitrary number of values (passed +;;; on the stack.) We check for the common case of a single return +;;; value, and do that inline using the normal single value return +;;; convention. Otherwise, we branch off to code that calls an +;;; assembly-routine. +;;; +;;; The assembly routine takes the following args: +;;; EAX -- the return-pc to finally jump to. +;;; EBX -- pointer to where to put the values. +;;; ECX -- number of values to find there. +;;; ESI -- pointer to where to find the values. +(define-vop (return-multiple) + (:args (old-fp :to (:eval 1) :target old-fp-temp) + (return-pc :target eax) + (vals :scs (any-reg) :target esi) + (nvals :scs (any-reg) :target ecx)) + + (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 1)) eax) + (:temporary (:sc unsigned-reg :offset esi-offset :from (:argument 2)) esi) + (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 3)) ecx) + (:temporary (:sc unsigned-reg :offset ebx-offset :from (:eval 0)) ebx) + (:temporary (:sc descriptor-reg :offset (first *register-arg-offsets*) + :from (:eval 0)) a0) + (:temporary (:sc unsigned-reg :from (:eval 1)) old-fp-temp) + (:node-var node) + + (:generator 13 + (trace-table-entry trace-table-fun-epilogue) + ;; Load the return-pc. + (move eax return-pc) + (unless (policy node (> space speed)) + ;; Check for the single case. + (let ((not-single (gen-label))) + (inst cmp nvals (fixnumize 1)) + (inst jmp :ne not-single) + + ;; Return with one value. + (loadw a0 vals -1) + ;; Clear the stack. We load old-fp into a register before clearing + ;; the stack. + (move old-fp-temp old-fp) + (move esp-tn ebp-tn) + (move ebp-tn old-fp-temp) + ;; Set the single-value return flag. + (inst clc) + ;; Out of here. + (inst jmp eax) + + ;; Nope, not the single case. Jump to the assembly routine. + (emit-label not-single))) + (move esi vals) + (move ecx nvals) + (move ebx ebp-tn) + (move ebp-tn old-fp) + (inst jmp (make-fixup 'return-multiple :assembly-routine)) + (trace-table-entry trace-table-normal))) + +;;;; XEP hackery + +;;; We don't need to do anything special for regular functions. +(define-vop (setup-environment) + (:info label) + (:ignore label) + (:generator 0 + ;; Don't bother doing anything. + nil)) + +;;; Get the lexical environment from its passing location. +(define-vop (setup-closure-environment) + (:results (closure :scs (descriptor-reg))) + (:info label) + (:ignore label) + (:generator 6 + ;; Get result. + (move closure eax-tn))) + +;;; Copy a &MORE arg from the argument area to the end of the current +;;; frame. FIXED is the number of non-&MORE arguments. +;;; +;;; The tricky part is doing this without trashing any of the calling +;;; convention registers that are still needed. This vop is emitted +;;; directly after the xep-allocate frame. That means the registers +;;; are in use as follows: +;;; +;;; EAX -- The lexenv. +;;; EBX -- Available. +;;; ECX -- The total number of arguments. +;;; EDX -- The first arg. +;;; EDI -- The second arg. +;;; ESI -- The third arg. +;;; +;;; So basically, we have one register available for our use: EBX. +;;; +;;; What we can do is push the other regs onto the stack, and then +;;; restore their values by looking directly below where we put the +;;; more-args. +(define-vop (copy-more-arg) + (:info fixed) + (:generator 20 + ;; Avoid the copy if there are no more args. + (cond ((zerop fixed) + (inst jecxz just-alloc-frame)) + (t + (inst cmp ecx-tn (fixnumize fixed)) + (inst jmp :be just-alloc-frame))) + + ;; Allocate the space on the stack. + ;; stack = ebp - (max 3 frame-size) - (nargs - fixed) + (inst lea ebx-tn + (make-ea :dword :base ebp-tn + :disp (- (fixnumize fixed) + (* n-word-bytes + (max 3 (sb-allocated-size 'stack)))))) + (inst sub ebx-tn ecx-tn) ; Got the new stack in ebx + (inst mov esp-tn ebx-tn) + + ;; Now: nargs>=1 && nargs>fixed + + ;; Save the original count of args. + (inst mov ebx-tn ecx-tn) + + (cond ((< fixed register-arg-count) + ;; We must stop when we run out of stack args, not when we + ;; run out of more args. + ;; Number to copy = nargs-3 + (inst sub ecx-tn (fixnumize register-arg-count)) + ;; Everything of interest in registers. + (inst jmp :be do-regs)) + (t + ;; Number to copy = nargs-fixed + (inst sub ecx-tn (fixnumize fixed)))) + + ;; Save edi and esi register args. + (inst push edi-tn) + (inst push esi-tn) + (inst push ebx-tn) + ;; Okay, we have pushed the register args. We can trash them + ;; now. + + ;; Initialize src to be end of args. + (inst mov esi-tn ebp-tn) + (inst sub esi-tn ebx-tn) + + ;; We need to copy from downwards up to avoid overwriting some of + ;; the yet uncopied args. So we need to use EBX as the copy index + ;; and ECX as the loop counter, rather than using ECX for both. + (inst xor ebx-tn ebx-tn) + + ;; We used to use REP MOVS here, but on modern x86 it performs + ;; much worse than an explicit loop for small blocks. + COPY-LOOP + (inst mov edi-tn (make-ea :dword :base esi-tn :index ebx-tn)) + ;; The :DISP is to account for the registers saved on the stack + (inst mov (make-ea :dword :base esp-tn :disp (* 3 n-word-bytes) + :index ebx-tn) + edi-tn) + (inst add ebx-tn n-word-bytes) + (inst sub ecx-tn n-word-bytes) + (inst jmp :nz COPY-LOOP) + + ;; So now we need to restore EDI and ESI. + (inst pop ebx-tn) + (inst pop esi-tn) + (inst pop edi-tn) + + DO-REGS + + ;; Restore ECX + (inst mov ecx-tn ebx-tn) + + ;; Here: nargs>=1 && nargs>fixed + (when (< fixed register-arg-count) + ;; Now we have to deposit any more args that showed up in + ;; registers. + (do ((i fixed)) + ( nil ) + ;; Store it relative to ebp + (inst mov (make-ea :dword :base ebp-tn + :disp (- (* 4 + (+ 1 (- i fixed) + (max 3 (sb-allocated-size 'stack)))))) + (nth i *register-arg-tns*)) + + (incf i) + (when (>= i register-arg-count) + (return)) + + ;; Don't deposit any more than there are. + (if (zerop i) + (inst test ecx-tn ecx-tn) + (inst cmp ecx-tn (fixnumize i))) + (inst jmp :eq done))) + + (inst jmp done) + + JUST-ALLOC-FRAME + (inst lea esp-tn + (make-ea :dword :base ebp-tn + :disp (- (* n-word-bytes + (max 3 (sb-allocated-size 'stack)))))) + + DONE)) + +(define-vop (more-kw-arg) + (:translate sb!c::%more-kw-arg) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to (:result 1)) + (index :scs (any-reg immediate) :to (:result 1) :target keyword)) + (:arg-types * tagged-num) + (:results (value :scs (descriptor-reg any-reg)) + (keyword :scs (descriptor-reg any-reg))) + (:result-types * *) + (:generator 4 + (sc-case index + (immediate + (inst mov value (make-ea :dword :base object :disp (tn-value index))) + (inst mov keyword (make-ea :dword :base object + :disp (+ (tn-value index) n-word-bytes)))) + (t + (inst mov value (make-ea :dword :base object :index index)) + (inst mov keyword (make-ea :dword :base object :index index + :disp n-word-bytes)))))) + +(define-vop (more-arg) + (:translate sb!c::%more-arg) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to (:result 1)) + (index :scs (any-reg) :to (:result 1) :target value)) + (:arg-types * tagged-num) + (:results (value :scs (descriptor-reg any-reg))) + (:result-types *) + (:generator 4 + (move value index) + (inst neg value) + (inst mov value (make-ea :dword :base object :index value)))) + +;;; Turn more arg (context, count) into a list. +(defoptimizer (%listify-rest-args stack-allocate-result) ((&rest args)) + t) + +(define-vop (listify-rest-args) + (:translate %listify-rest-args) + (:policy :safe) + (:args (context :scs (descriptor-reg) :target src) + (count :scs (any-reg) :target ecx)) + (:arg-types * tagged-num) + (:temporary (:sc unsigned-reg :offset esi-offset :from (:argument 0)) src) + (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx) + (:temporary (:sc unsigned-reg :offset eax-offset) eax) + (:temporary (:sc unsigned-reg) dst) + (:results (result :scs (descriptor-reg))) + (:node-var node) + (:generator 20 + (let ((enter (gen-label)) + (loop (gen-label)) + (done (gen-label)) + (stack-allocate-p (node-stack-allocate-p node))) + (move src context) + (move ecx count) + ;; Check to see whether there are no args, and just return NIL if so. + (inst mov result nil-value) + (inst jecxz done) + (inst lea dst (make-ea :dword :base ecx :index ecx)) + (maybe-pseudo-atomic stack-allocate-p + (allocation dst dst node stack-allocate-p) + (inst lea dst (make-ea :byte :base dst :disp list-pointer-lowtag)) + (inst shr ecx 2) + ;; Set decrement mode (successive args at lower addresses) + (inst std) + ;; Set up the result. + (move result dst) + ;; Jump into the middle of the loop, 'cause that's were we want + ;; to start. + (inst jmp enter) + (emit-label loop) + ;; Compute a pointer to the next cons. + (inst add dst (* cons-size n-word-bytes)) + ;; Store a pointer to this cons in the CDR of the previous cons. + (storew dst dst -1 list-pointer-lowtag) + (emit-label enter) + ;; Grab one value and stash it in the car of this cons. + (inst lods eax) + (storew eax dst 0 list-pointer-lowtag) + ;; Go back for more. + (inst sub ecx 1) + (inst jmp :nz loop) + ;; NIL out the last cons. + (storew nil-value dst 1 list-pointer-lowtag)) + (emit-label done)))) + +;;; Return the location and size of the &MORE arg glob created by +;;; COPY-MORE-ARG. SUPPLIED is the total number of arguments supplied +;;; (originally passed in ECX). FIXED is the number of non-rest +;;; arguments. +;;; +;;; We must duplicate some of the work done by COPY-MORE-ARG, since at +;;; that time the environment is in a pretty brain-damaged state, +;;; preventing this info from being returned as values. What we do is +;;; compute supplied - fixed, and return a pointer that many words +;;; below the current stack top. +(define-vop (more-arg-context) + (:policy :fast-safe) + (:translate sb!c::%more-arg-context) + (:args (supplied :scs (any-reg) :target count)) + (:arg-types positive-fixnum (:constant fixnum)) + (:info fixed) + (:results (context :scs (descriptor-reg)) + (count :scs (any-reg))) + (:result-types t tagged-num) + (:note "more-arg-context") + (:generator 5 + (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 :dword :base esp-tn + :index count :scale 1 + :disp (- (+ (fixnumize fixed) 4)))) + (unless (zerop fixed) + (inst sub count (fixnumize fixed))))) + +;;; Signal wrong argument count error if NARGS isn't equal to COUNT. +(define-vop (verify-arg-count) + (:policy :fast-safe) + (:translate sb!c::%verify-arg-count) + (:args (nargs :scs (any-reg))) + (:arg-types positive-fixnum (:constant t)) + (:info count) + (:vop-var vop) + (:save-p :compute-only) + (:generator 3 + (let ((err-lab + (generate-error-code vop invalid-arg-count-error nargs))) + (if (zerop count) + (inst test nargs nargs) ; smaller instruction + (inst cmp nargs (fixnumize count))) + (inst jmp :ne err-lab)))) + +;;; Various other error signallers. +(macrolet ((def (name error translate &rest args) + `(define-vop (,name) + ,@(when translate + `((:policy :fast-safe) + (:translate ,translate))) + (:args ,@(mapcar (lambda (arg) + `(,arg :scs (any-reg descriptor-reg))) + args)) + (:vop-var vop) + (:save-p :compute-only) + (:generator 1000 + (error-call vop ,error ,@args))))) + (def arg-count-error invalid-arg-count-error + sb!c::%arg-count-error nargs) + (def type-check-error object-not-type-error sb!c::%type-check-error + object type) + (def layout-invalid-error layout-invalid-error sb!c::%layout-invalid-error + object layout) + (def odd-key-args-error odd-key-args-error + sb!c::%odd-key-args-error) + (def unknown-key-arg-error unknown-key-arg-error + sb!c::%unknown-key-arg-error key) + (def nil-fun-returned-error nil-fun-returned-error nil fun)) + +;;; Single-stepping + +(defun emit-single-step-test () + ;; We use different ways of representing whether stepping is on on + ;; +SB-THREAD / -SB-THREAD: on +SB-THREAD, we use a slot in the + ;; thread structure. On -SB-THREAD we use the value of a static + ;; symbol. Things are done this way, since reading a thread-local + ;; slot from a symbol would require an extra register on +SB-THREAD, + ;; and reading a slot from a thread structure would require an extra + ;; register on -SB-THREAD. + #!+sb-thread + (progn + (inst fs-segment-prefix) + (inst cmp (make-ea :dword + :disp (* thread-stepping-slot n-word-bytes)) + nil-value)) + #!-sb-thread + (inst cmp (make-ea-for-symbol-value sb!impl::*stepping*) + nil-value)) + +(define-vop (step-instrument-before-vop) + (:policy :fast-safe) + (:vop-var vop) + (:generator 3 + (emit-single-step-test) + (inst jmp :eq DONE) + (inst break single-step-before-trap) + DONE + (note-this-location vop :step-before-vop))) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp -x external-format-test.txt -x test-status.lisp-expr sbcl-1.0.13-pristine/src/compiler/arm/cell.lisp sbcl-1.0.13-arm5-pass1/src/compiler/arm/cell.lisp --- sbcl-1.0.13-pristine/src/compiler/arm/cell.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-1.0.13-arm5-pass1/src/compiler/arm/cell.lisp 2007-12-28 17:57:08.132278942 -0500 @@ -0,0 +1,794 @@ +;;;; various primitive memory access VOPs for the x86 VM + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + +;;;; data object ref/set stuff + +(define-vop (slot) + (:args (object :scs (descriptor-reg))) + (:info name offset lowtag) + (:ignore name) + (:results (result :scs (descriptor-reg any-reg))) + (:generator 1 + (loadw result object offset lowtag))) + +(define-vop (set-slot) + (:args (object :scs (descriptor-reg)) + (value :scs (descriptor-reg any-reg immediate))) + (:info name offset lowtag) + (:ignore name) + (:results) + (:generator 1 + (storew (encode-value-if-immediate value) object offset lowtag))) + +(define-vop (compare-and-swap-slot) + (:args (object :scs (descriptor-reg) :to :eval) + (old :scs (descriptor-reg any-reg) :target eax) + (new :scs (descriptor-reg any-reg))) + (:temporary (:sc descriptor-reg :offset eax-offset + :from (:argument 1) :to :result :target result) + eax) + (:info name offset lowtag) + (:ignore name) + (:results (result :scs (descriptor-reg any-reg))) + (:generator 5 + (move eax old) + #!+sb-thread + (inst lock) + (inst cmpxchg (make-ea :dword :base object + :disp (- (* offset n-word-bytes) lowtag)) + new) + (move result eax))) + +;;;; symbol hacking VOPs + +(define-vop (%compare-and-swap-symbol-value) + (:translate %compare-and-swap-symbol-value) + (:args (symbol :scs (descriptor-reg) :to (:result 1)) + (old :scs (descriptor-reg any-reg) :target eax) + (new :scs (descriptor-reg any-reg))) + (:temporary (:sc descriptor-reg :offset eax-offset) eax) + #!+sb-thread + (:temporary (:sc descriptor-reg) tls) + (:results (result :scs (descriptor-reg any-reg))) + (:policy :fast-safe) + (:vop-var vop) + (:generator 15 + ;; This code has to pathological cases: NO-TLS-VALUE-MARKER + ;; or UNBOUND-MARKER as NEW: in either case we would end up + ;; doing possible damage with CMPXCHG -- so don't do that! + (let ((unbound (generate-error-code vop unbound-symbol-error symbol)) + (check (gen-label))) + (move eax old) + #!+sb-thread + (progn + (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag) + ;; Thread-local area, no LOCK needed. + (inst fs-segment-prefix) + (inst cmpxchg (make-ea :dword :base tls) new) + (inst cmp eax no-tls-value-marker-widetag) + (inst jmp :ne check) + (move eax old) + (inst lock)) + (inst cmpxchg (make-ea :dword :base symbol + :disp (- (* symbol-value-slot n-word-bytes) + other-pointer-lowtag)) + new) + (emit-label check) + (move result eax) + (inst cmp result unbound-marker-widetag) + (inst jmp :e unbound)))) + +;;; these next two cf the sparc version, by jrd. +;;; FIXME: Deref this ^ reference. + + +;;; The compiler likes to be able to directly SET symbols. +#!+sb-thread +(define-vop (set) + (:args (symbol :scs (descriptor-reg)) + (value :scs (descriptor-reg any-reg))) + (:temporary (:sc descriptor-reg) tls) + ;;(:policy :fast-safe) + (:generator 4 + (let ((global-val (gen-label)) + (done (gen-label))) + (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag) + (inst fs-segment-prefix) + (inst cmp (make-ea :dword :base tls) no-tls-value-marker-widetag) + (inst jmp :z global-val) + (inst fs-segment-prefix) + (inst mov (make-ea :dword :base tls) value) + (inst jmp done) + (emit-label global-val) + (storew value symbol symbol-value-slot other-pointer-lowtag) + (emit-label done)))) + +;; unithreaded it's a lot simpler ... +#!-sb-thread +(define-vop (set cell-set) + (:variant symbol-value-slot other-pointer-lowtag)) + +;;; With Symbol-Value, we check that the value isn't the trap object. So +;;; Symbol-Value of NIL is NIL. +#!+sb-thread +(define-vop (symbol-value) + (:translate symbol-value) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to (:result 1))) + (:results (value :scs (descriptor-reg any-reg))) + (:vop-var vop) + (:save-p :compute-only) + (:generator 9 + (let* ((check-unbound-label (gen-label)) + (err-lab (generate-error-code vop unbound-symbol-error object)) + (ret-lab (gen-label))) + (loadw value object symbol-tls-index-slot other-pointer-lowtag) + (inst fs-segment-prefix) + (inst mov value (make-ea :dword :base value)) + (inst cmp value no-tls-value-marker-widetag) + (inst jmp :ne check-unbound-label) + (loadw value object symbol-value-slot other-pointer-lowtag) + (emit-label check-unbound-label) + (inst cmp value unbound-marker-widetag) + (inst jmp :e err-lab) + (emit-label ret-lab)))) + +#!+sb-thread +(define-vop (fast-symbol-value symbol-value) + ;; KLUDGE: not really fast, in fact, because we're going to have to + ;; do a full lookup of the thread-local area anyway. But half of + ;; the meaning of FAST-SYMBOL-VALUE is "do not signal an error if + ;; unbound", which is used in the implementation of COPY-SYMBOL. -- + ;; CSR, 2003-04-22 + (:policy :fast) + (:translate symbol-value) + (:generator 8 + (let ((ret-lab (gen-label))) + (loadw value object symbol-tls-index-slot other-pointer-lowtag) + (inst fs-segment-prefix) + (inst mov value (make-ea :dword :base value)) + (inst cmp value no-tls-value-marker-widetag) + (inst jmp :ne ret-lab) + (loadw value object symbol-value-slot other-pointer-lowtag) + (emit-label ret-lab)))) + +#!-sb-thread +(define-vop (symbol-value) + (:translate symbol-value) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to (:result 1))) + (:results (value :scs (descriptor-reg any-reg))) + (:vop-var vop) + (:save-p :compute-only) + (:generator 9 + (let ((err-lab (generate-error-code vop unbound-symbol-error object))) + (loadw value object symbol-value-slot other-pointer-lowtag) + (inst cmp value unbound-marker-widetag) + (inst jmp :e err-lab)))) + +#!-sb-thread +(define-vop (fast-symbol-value cell-ref) + (:variant symbol-value-slot other-pointer-lowtag) + (:policy :fast) + (:translate symbol-value)) + +(defknown locked-symbol-global-value-add (symbol fixnum) fixnum ()) + +(define-vop (locked-symbol-global-value-add) + (:args (object :scs (descriptor-reg) :to :result) + (value :scs (any-reg) :target result)) + (:arg-types * tagged-num) + (:results (result :scs (any-reg) :from (:argument 1))) + (:policy :fast) + (:translate locked-symbol-global-value-add) + (:result-types tagged-num) + (:policy :fast-safe) + (:generator 4 + (move result value) + (inst lock) + (inst add (make-ea-for-object-slot object symbol-value-slot + other-pointer-lowtag) + value))) + +#!+sb-thread +(define-vop (boundp) + (:translate boundp) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:conditional) + (:info target not-p) + (:temporary (:sc descriptor-reg #+nil(:from (:argument 0))) value) + (:generator 9 + (let ((check-unbound-label (gen-label))) + (loadw value object symbol-tls-index-slot other-pointer-lowtag) + (inst fs-segment-prefix) + (inst mov value (make-ea :dword :base value)) + (inst cmp value no-tls-value-marker-widetag) + (inst jmp :ne check-unbound-label) + (loadw value object symbol-value-slot other-pointer-lowtag) + (emit-label check-unbound-label) + (inst cmp value unbound-marker-widetag) + (inst jmp (if not-p :e :ne) target)))) + +#!-sb-thread +(define-vop (boundp) + (:translate boundp) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:conditional) + (:info target not-p) + (:generator 9 + (inst cmp (make-ea-for-object-slot object symbol-value-slot + other-pointer-lowtag) + unbound-marker-widetag) + (inst jmp (if not-p :e :ne) target))) + + +(define-vop (symbol-hash) + (:policy :fast-safe) + (:translate symbol-hash) + (:args (symbol :scs (descriptor-reg))) + (:results (res :scs (any-reg))) + (:result-types positive-fixnum) + (:generator 2 + ;; The symbol-hash slot of NIL holds NIL because it is also the + ;; cdr slot, so we have to strip off the two low bits to make sure + ;; it is a fixnum. The lowtag selection magic that is required to + ;; ensure this is explained in the comment in objdef.lisp + (loadw res symbol symbol-hash-slot other-pointer-lowtag) + (inst and res (lognot #b11)))) + +;;;; fdefinition (FDEFN) objects + +(define-vop (fdefn-fun cell-ref) ; /pfw - alpha + (:variant fdefn-fun-slot other-pointer-lowtag)) + +(define-vop (safe-fdefn-fun) + (:args (object :scs (descriptor-reg) :to (:result 1))) + (:results (value :scs (descriptor-reg any-reg))) + (:vop-var vop) + (:save-p :compute-only) + (:generator 10 + (loadw value object fdefn-fun-slot other-pointer-lowtag) + (inst cmp value nil-value) + (let ((err-lab (generate-error-code vop undefined-fun-error object))) + (inst jmp :e err-lab)))) + +(define-vop (set-fdefn-fun) + (:policy :fast-safe) + (:translate (setf fdefn-fun)) + (:args (function :scs (descriptor-reg) :target result) + (fdefn :scs (descriptor-reg))) + (:temporary (:sc unsigned-reg) raw) + (:temporary (:sc byte-reg) type) + (:results (result :scs (descriptor-reg))) + (:generator 38 + (load-type type function (- fun-pointer-lowtag)) + (inst lea raw + (make-ea-for-object-slot function simple-fun-code-offset + fun-pointer-lowtag)) + (inst cmp type simple-fun-header-widetag) + (inst jmp :e normal-fn) + (inst lea raw (make-fixup "closure_tramp" :foreign)) + NORMAL-FN + (storew function fdefn fdefn-fun-slot other-pointer-lowtag) + (storew raw fdefn fdefn-raw-addr-slot other-pointer-lowtag) + (move result function))) + +(define-vop (fdefn-makunbound) + (:policy :fast-safe) + (:translate fdefn-makunbound) + (:args (fdefn :scs (descriptor-reg) :target result)) + (:results (result :scs (descriptor-reg))) + (:generator 38 + (storew nil-value fdefn fdefn-fun-slot other-pointer-lowtag) + (storew (make-fixup "undefined_tramp" :foreign) + fdefn fdefn-raw-addr-slot other-pointer-lowtag) + (move result fdefn))) + +;;;; binding and unbinding + +;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and +;;; the symbol on the binding stack and stuff the new value into the +;;; symbol. + +#!+sb-thread +(define-vop (bind) + (:args (val :scs (any-reg descriptor-reg)) + (symbol :scs (descriptor-reg))) + (:temporary (:sc descriptor-reg :offset eax-offset) eax) + (:temporary (:sc unsigned-reg) tls-index bsp) + (:generator 10 + (let ((tls-index-valid (gen-label)) + (get-tls-index-lock (gen-label)) + (release-tls-index-lock (gen-label))) + (load-binding-stack-pointer bsp) + (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag) + (inst add bsp (* binding-size n-word-bytes)) + (store-binding-stack-pointer bsp) + (inst or tls-index tls-index) + (inst jmp :ne tls-index-valid) + + ;; FIXME: + ;; * We should ensure the existence of TLS index for LET-bound specials + ;; at compile/load time, and use write a FAST-BIND for use with those. + ;; * PROGV will need to do this, but even there this should not be inline. + ;; This is probably best moved to C, since dynbind.c also needs to do this. + (pseudo-atomic + (emit-label get-tls-index-lock) + (inst mov tls-index 1) + (inst xor eax eax) + (inst lock) + (inst cmpxchg (make-ea-for-symbol-value *tls-index-lock*) tls-index) + (inst jmp :ne get-tls-index-lock) + ;; now with the lock held, see if the symbol's tls index has + ;; been set in the meantime + (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag) + (inst or tls-index tls-index) + (inst jmp :ne release-tls-index-lock) + ;; allocate a new tls-index + (load-symbol-value tls-index *free-tls-index*) + (inst add (make-ea-for-symbol-value *free-tls-index*) 4) ; fixnum + 1 + (storew tls-index symbol symbol-tls-index-slot other-pointer-lowtag) + (emit-label release-tls-index-lock) + (store-symbol-value 0 *tls-index-lock*)) + + (emit-label tls-index-valid) + (inst fs-segment-prefix) + (inst mov eax (make-ea :dword :base tls-index)) + (storew eax bsp (- binding-value-slot binding-size)) + (storew symbol bsp (- binding-symbol-slot binding-size)) + (inst fs-segment-prefix) + (inst mov (make-ea :dword :base tls-index) val)))) + +#!-sb-thread +(define-vop (bind) + (:args (val :scs (any-reg descriptor-reg)) + (symbol :scs (descriptor-reg))) + (:temporary (:sc unsigned-reg) temp bsp) + (:generator 5 + (load-symbol-value bsp *binding-stack-pointer*) + (loadw temp symbol symbol-value-slot other-pointer-lowtag) + (inst add bsp (* binding-size n-word-bytes)) + (store-symbol-value bsp *binding-stack-pointer*) + (storew temp bsp (- binding-value-slot binding-size)) + (storew symbol bsp (- binding-symbol-slot binding-size)) + (storew val symbol symbol-value-slot other-pointer-lowtag))) + + +#!+sb-thread +(define-vop (unbind) + ;; four temporaries? + (:temporary (:sc unsigned-reg) symbol value bsp tls-index) + (:generator 0 + (load-binding-stack-pointer bsp) + (loadw symbol bsp (- binding-symbol-slot binding-size)) + (loadw value bsp (- binding-value-slot binding-size)) + + (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag) + (inst fs-segment-prefix) + (inst mov (make-ea :dword :base tls-index) value) + + (storew 0 bsp (- binding-symbol-slot binding-size)) + (storew 0 bsp (- binding-value-slot binding-size)) + (inst sub bsp (* binding-size n-word-bytes)) + (store-binding-stack-pointer bsp))) + +#!-sb-thread +(define-vop (unbind) + (:temporary (:sc unsigned-reg) symbol value bsp) + (:generator 0 + (load-symbol-value bsp *binding-stack-pointer*) + (loadw symbol bsp (- binding-symbol-slot binding-size)) + (loadw value bsp (- binding-value-slot binding-size)) + (storew value symbol symbol-value-slot other-pointer-lowtag) + (storew 0 bsp (- binding-symbol-slot binding-size)) + (storew 0 bsp (- binding-value-slot binding-size)) + (inst sub bsp (* binding-size n-word-bytes)) + (store-symbol-value bsp *binding-stack-pointer*))) + + +(define-vop (unbind-to-here) + (:args (where :scs (descriptor-reg any-reg))) + (:temporary (:sc unsigned-reg) symbol value bsp #!+sb-thread tls-index) + (:generator 0 + (load-binding-stack-pointer bsp) + (inst cmp where bsp) + (inst jmp :e done) + + LOOP + (loadw symbol bsp (- binding-symbol-slot binding-size)) + (inst or symbol symbol) + (inst jmp :z skip) + ;; Bind stack debug sentinels have the unbound marker in the symbol slot + (inst cmp symbol unbound-marker-widetag) + (inst jmp :eq skip) + (loadw value bsp (- binding-value-slot binding-size)) + #!-sb-thread (storew value symbol symbol-value-slot other-pointer-lowtag) + + #!+sb-thread (loadw + tls-index symbol symbol-tls-index-slot other-pointer-lowtag) + #!+sb-thread (inst fs-segment-prefix) + #!+sb-thread (inst mov (make-ea :dword :base tls-index) value) + (storew 0 bsp (- binding-symbol-slot binding-size)) + + SKIP + (storew 0 bsp (- binding-value-slot binding-size)) + (inst sub bsp (* binding-size n-word-bytes)) + (inst cmp where bsp) + (inst jmp :ne loop) + (store-binding-stack-pointer bsp) + + DONE)) + +(define-vop (bind-sentinel) + (:temporary (:sc unsigned-reg) bsp) + (:generator 1 + (load-binding-stack-pointer bsp) + (inst add bsp (* binding-size n-word-bytes)) + (storew unbound-marker-widetag bsp (- binding-symbol-slot binding-size)) + (storew ebp-tn bsp (- binding-value-slot binding-size)) + (store-binding-stack-pointer bsp))) + +(define-vop (unbind-sentinel) + (:temporary (:sc unsigned-reg) bsp) + (:generator 1 + (load-binding-stack-pointer bsp) + (storew 0 bsp (- binding-value-slot binding-size)) + (storew 0 bsp (- binding-symbol-slot binding-size)) + (inst sub bsp (* binding-size n-word-bytes)) + (store-binding-stack-pointer bsp))) + + + +;;;; closure indexing + +(define-full-reffer closure-index-ref * + closure-info-offset fun-pointer-lowtag + (any-reg descriptor-reg) * %closure-index-ref) + +(define-full-setter set-funcallable-instance-info * + funcallable-instance-info-offset fun-pointer-lowtag + (any-reg descriptor-reg) * %set-funcallable-instance-info) + +(define-full-reffer funcallable-instance-info * + funcallable-instance-info-offset fun-pointer-lowtag + (descriptor-reg any-reg) * %funcallable-instance-info) + +(define-vop (closure-ref slot-ref) + (:variant closure-info-offset fun-pointer-lowtag)) + +(define-vop (closure-init slot-set) + (:variant closure-info-offset fun-pointer-lowtag)) + +;;;; value cell hackery + +(define-vop (value-cell-ref cell-ref) + (:variant value-cell-value-slot other-pointer-lowtag)) + +(define-vop (value-cell-set cell-set) + (:variant value-cell-value-slot other-pointer-lowtag)) + +;;;; structure hackery + +(define-vop (instance-length) + (:policy :fast-safe) + (:translate %instance-length) + (:args (struct :scs (descriptor-reg))) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 4 + (loadw res struct 0 instance-pointer-lowtag) + (inst shr res n-widetag-bits))) + +(define-full-reffer instance-index-ref * + instance-slots-offset instance-pointer-lowtag + (any-reg descriptor-reg) * + %instance-ref) + +(define-full-setter instance-index-set * + instance-slots-offset instance-pointer-lowtag + (any-reg descriptor-reg) * + %instance-set) + +(define-full-compare-and-swap %compare-and-swap-instance-ref instance + instance-slots-offset instance-pointer-lowtag + (any-reg descriptor-reg) * + %compare-and-swap-instance-ref) + +;;;; code object frobbing + +(define-full-reffer code-header-ref * 0 other-pointer-lowtag + (any-reg descriptor-reg) * code-header-ref) + +(define-full-setter code-header-set * 0 other-pointer-lowtag + (any-reg descriptor-reg) * code-header-set) + +;;;; raw instance slot accessors + +(defun make-ea-for-raw-slot (object index instance-length n-words) + (sc-case index + (any-reg (make-ea :dword + :base object + :index instance-length + :disp (- (* (- instance-slots-offset n-words) + n-word-bytes) + instance-pointer-lowtag))) + (immediate (make-ea :dword :base object + :index instance-length + :scale 4 + :disp (- (* (- instance-slots-offset n-words) + n-word-bytes) + instance-pointer-lowtag + (fixnumize (tn-value index))))))) + +(define-vop (raw-instance-ref/word) + (:translate %raw-instance-ref/word) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) (index :scs (any-reg immediate))) + (:arg-types * tagged-num) + (:temporary (:sc unsigned-reg) tmp) + (:results (value :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (when (sc-is index any-reg) + (inst shl tmp 2) + (inst sub tmp index)) + (inst mov value (make-ea-for-raw-slot object index tmp 1)))) + +(define-vop (raw-instance-set/word) + (:translate %raw-instance-set/word) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg immediate)) + (value :scs (unsigned-reg) :target result)) + (:arg-types * tagged-num unsigned-num) + (:temporary (:sc unsigned-reg) tmp) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (when (sc-is index any-reg) + (inst shl tmp 2) + (inst sub tmp index)) + (inst mov (make-ea-for-raw-slot object index tmp 1) value) + (move result value))) + +(define-vop (raw-instance-ref/single) + (:translate %raw-instance-ref/single) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) (index :scs (any-reg immediate))) + (:arg-types * tagged-num) + (:temporary (:sc unsigned-reg) tmp) + (:results (value :scs (single-reg))) + (:result-types single-float) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (when (sc-is index any-reg) + (inst shl tmp 2) + (inst sub tmp index)) + (with-empty-tn@fp-top(value) + (inst fld (make-ea-for-raw-slot object index tmp 1))))) + +(define-vop (raw-instance-set/single) + (:translate %raw-instance-set/single) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg immediate)) + (value :scs (single-reg) :target result)) + (:arg-types * tagged-num single-float) + (:temporary (:sc unsigned-reg) tmp) + (:results (result :scs (single-reg))) + (:result-types single-float) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (when (sc-is index any-reg) + (inst shl tmp 2) + (inst sub tmp index)) + (unless (zerop (tn-offset value)) + (inst fxch value)) + (inst fst (make-ea-for-raw-slot object index tmp 1)) + (cond + ((zerop (tn-offset value)) + (unless (zerop (tn-offset result)) + (inst fst result))) + ((zerop (tn-offset result)) + (inst fst value)) + (t + (unless (location= value result) + (inst fst result)) + (inst fxch value))))) + +(define-vop (raw-instance-ref/double) + (:translate %raw-instance-ref/double) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) (index :scs (any-reg immediate))) + (:arg-types * tagged-num) + (:temporary (:sc unsigned-reg) tmp) + (:results (value :scs (double-reg))) + (:result-types double-float) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (when (sc-is index any-reg) + (inst shl tmp 2) + (inst sub tmp index)) + (with-empty-tn@fp-top(value) + (inst fldd (make-ea-for-raw-slot object index tmp 2))))) + +(define-vop (raw-instance-set/double) + (:translate %raw-instance-set/double) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg immediate)) + (value :scs (double-reg) :target result)) + (:arg-types * tagged-num double-float) + (:temporary (:sc unsigned-reg) tmp) + (:results (result :scs (double-reg))) + (:result-types double-float) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (when (sc-is index any-reg) + (inst shl tmp 2) + (inst sub tmp index)) + (unless (zerop (tn-offset value)) + (inst fxch value)) + (inst fstd (make-ea-for-raw-slot object index tmp 2)) + (cond + ((zerop (tn-offset value)) + (unless (zerop (tn-offset result)) + (inst fstd result))) + ((zerop (tn-offset result)) + (inst fstd value)) + (t + (unless (location= value result) + (inst fstd result)) + (inst fxch value))))) + +(define-vop (raw-instance-ref/complex-single) + (:translate %raw-instance-ref/complex-single) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg immediate))) + (:arg-types * positive-fixnum) + (:temporary (:sc unsigned-reg) tmp) + (:results (value :scs (complex-single-reg))) + (:result-types complex-single-float) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (when (sc-is index any-reg) + (inst shl tmp 2) + (inst sub tmp index)) + (let ((real-tn (complex-single-reg-real-tn value))) + (with-empty-tn@fp-top (real-tn) + (inst fld (make-ea-for-raw-slot object index tmp 2)))) + (let ((imag-tn (complex-single-reg-imag-tn value))) + (with-empty-tn@fp-top (imag-tn) + (inst fld (make-ea-for-raw-slot object index tmp 1)))))) + +(define-vop (raw-instance-set/complex-single) + (:translate %raw-instance-set/complex-single) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg immediate)) + (value :scs (complex-single-reg) :target result)) + (:arg-types * positive-fixnum complex-single-float) + (:temporary (:sc unsigned-reg) tmp) + (:results (result :scs (complex-single-reg))) + (:result-types complex-single-float) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (when (sc-is index any-reg) + (inst shl tmp 2) + (inst sub tmp index)) + (let ((value-real (complex-single-reg-real-tn value)) + (result-real (complex-single-reg-real-tn result))) + (cond ((zerop (tn-offset value-real)) + ;; Value is in ST0. + (inst fst (make-ea-for-raw-slot object index tmp 2)) + (unless (zerop (tn-offset result-real)) + ;; Value is in ST0 but not result. + (inst fst result-real))) + (t + ;; Value is not in ST0. + (inst fxch value-real) + (inst fst (make-ea-for-raw-slot object index tmp 2)) + (cond ((zerop (tn-offset result-real)) + ;; The result is in ST0. + (inst fst value-real)) + (t + ;; Neither value or result are in ST0 + (unless (location= value-real result-real) + (inst fst result-real)) + (inst fxch value-real)))))) + (let ((value-imag (complex-single-reg-imag-tn value)) + (result-imag (complex-single-reg-imag-tn result))) + (inst fxch value-imag) + (inst fst (make-ea-for-raw-slot object index tmp 1)) + (unless (location= value-imag result-imag) + (inst fst result-imag)) + (inst fxch value-imag)))) + +(define-vop (raw-instance-ref/complex-double) + (:translate %raw-instance-ref/complex-double) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg immediate))) + (:arg-types * positive-fixnum) + (:temporary (:sc unsigned-reg) tmp) + (:results (value :scs (complex-double-reg))) + (:result-types complex-double-float) + (:generator 7 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (when (sc-is index any-reg) + (inst shl tmp 2) + (inst sub tmp index)) + (let ((real-tn (complex-double-reg-real-tn value))) + (with-empty-tn@fp-top (real-tn) + (inst fldd (make-ea-for-raw-slot object index tmp 4)))) + (let ((imag-tn (complex-double-reg-imag-tn value))) + (with-empty-tn@fp-top (imag-tn) + (inst fldd (make-ea-for-raw-slot object index tmp 2)))))) + +(define-vop (raw-instance-set/complex-double) + (:translate %raw-instance-set/complex-double) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg immediate)) + (value :scs (complex-double-reg) :target result)) + (:arg-types * positive-fixnum complex-double-float) + (:temporary (:sc unsigned-reg) tmp) + (:results (result :scs (complex-double-reg))) + (:result-types complex-double-float) + (:generator 20 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (when (sc-is index any-reg) + (inst shl tmp 2) + (inst sub tmp index)) + (let ((value-real (complex-double-reg-real-tn value)) + (result-real (complex-double-reg-real-tn result))) + (cond ((zerop (tn-offset value-real)) + ;; Value is in ST0. + (inst fstd (make-ea-for-raw-slot object index tmp 4)) + (unless (zerop (tn-offset result-real)) + ;; Value is in ST0 but not result. + (inst fstd result-real))) + (t + ;; Value is not in ST0. + (inst fxch value-real) + (inst fstd (make-ea-for-raw-slot object index tmp 4)) + (cond ((zerop (tn-offset result-real)) + ;; The result is in ST0. + (inst fstd value-real)) + (t + ;; Neither value or result are in ST0 + (unless (location= value-real result-real) + (inst fstd result-real)) + (inst fxch value-real)))))) + (let ((value-imag (complex-double-reg-imag-tn value)) + (result-imag (complex-double-reg-imag-tn result))) + (inst fxch value-imag) + (inst fstd (make-ea-for-raw-slot object index tmp 2)) + (unless (location= value-imag result-imag) + (inst fstd result-imag)) + (inst fxch value-imag)))) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp -x external-format-test.txt -x test-status.lisp-expr sbcl-1.0.13-pristine/src/compiler/arm/char.lisp sbcl-1.0.13-arm5-pass1/src/compiler/arm/char.lisp --- sbcl-1.0.13-pristine/src/compiler/arm/char.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-1.0.13-arm5-pass1/src/compiler/arm/char.lisp 2007-12-28 17:57:08.133278789 -0500 @@ -0,0 +1,209 @@ +;;;; x86 definition of character operations + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + +;;;; moves and coercions + +;;; Move a tagged char to an untagged representation. +#!+sb-unicode +(define-vop (move-to-character) + (:args (x :scs (any-reg descriptor-reg) :target y + :load-if (not (location= x y)))) + (:results (y :scs (character-reg) + :load-if (not (location= x y)))) + (:note "character untagging") + (:generator 1 + (move y x) + (inst shr y n-widetag-bits))) +#!-sb-unicode +(define-vop (move-to-character) + (:args (x :scs (any-reg control-stack) :target al)) + (:temporary (:sc byte-reg :offset al-offset + :from (:argument 0) :to (:eval 0)) al) + (:ignore al) + (:temporary (:sc byte-reg :offset ah-offset :target y + :from (:argument 0) :to (:result 0)) ah) + (:results (y :scs (character-reg character-stack))) + (:note "character untagging") + (:generator 1 + (move eax-tn x) + (move y ah))) +(define-move-vop move-to-character :move + (any-reg #!-sb-unicode control-stack) + (character-reg #!-sb-unicode character-stack)) + +;;; Move an untagged char to a tagged representation. +#!+sb-unicode +(define-vop (move-from-character) + (:args (x :scs (character-reg) :target y)) + (:results (y :scs (any-reg descriptor-reg))) + (:note "character tagging") + (:generator 1 + (move y x) + (inst shl y n-widetag-bits) + (inst or y character-widetag))) +#!-sb-unicode +(define-vop (move-from-character) + (:args (x :scs (character-reg character-stack) :target ah)) + (:temporary (:sc byte-reg :offset al-offset :target y + :from (:argument 0) :to (:result 0)) al) + (:temporary (:sc byte-reg :offset ah-offset + :from (:argument 0) :to (:result 0)) ah) + (:results (y :scs (any-reg descriptor-reg control-stack))) + (:note "character tagging") + (:generator 1 + (move ah x) ; Maybe move char byte. + (inst mov al character-widetag) ; x86 to type bits + (inst and eax-tn #xffff) ; Remove any junk bits. + (move y eax-tn))) +(define-move-vop move-from-character :move + (character-reg #!-sb-unicode character-stack) + (any-reg descriptor-reg #!-sb-unicode control-stack)) + +;;; Move untagged character values. +(define-vop (character-move) + (:args (x :target y + :scs (character-reg) + :load-if (not (location= x y)))) + (:results (y :scs (character-reg character-stack) + :load-if (not (location= x y)))) + (:note "character move") + (:effects) + (:affected) + (:generator 0 + (move y x))) +(define-move-vop character-move :move + (character-reg) (character-reg character-stack)) + +;;; Move untagged character arguments/return-values. +(define-vop (move-character-arg) + (:args (x :target y + :scs (character-reg)) + (fp :scs (any-reg) + :load-if (not (sc-is y character-reg)))) + (:results (y)) + (:note "character arg move") + (:generator 0 + (sc-case y + (character-reg + (move y x)) + (character-stack + #!-sb-unicode + (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))) + x) + #!+sb-unicode + (if (= (tn-offset fp) esp-offset) + (storew x fp (tn-offset y)) ; c-call + (storew x fp (frame-word-offset (tn-offset y)))))))) +(define-move-vop move-character-arg :move-arg + (any-reg character-reg) (character-reg)) + +;;; Use standard MOVE-ARG + coercion to move an untagged character +;;; to a descriptor passing location. +(define-move-vop move-arg :move-arg + (character-reg) (any-reg descriptor-reg)) + +;;;; other operations + +(define-vop (char-code) + (:translate char-code) + (:policy :fast-safe) + (:args #!-sb-unicode (ch :scs (character-reg character-stack)) + #!+sb-unicode (ch :scs (character-reg character-stack) :target res)) + (:arg-types character) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 1 + #!-sb-unicode + (inst movzx res ch) + #!+sb-unicode + (move res ch))) + +#!+sb-unicode +(define-vop (code-char) + (:translate code-char) + (:policy :fast-safe) + (:args (code :scs (unsigned-reg unsigned-stack) :target res)) + (:arg-types positive-fixnum) + (:results (res :scs (character-reg))) + (:result-types character) + (:generator 1 + (move res code))) +#!-sb-unicode +(define-vop (code-char) + (:translate code-char) + (:policy :fast-safe) + (:args (code :scs (unsigned-reg unsigned-stack) :target eax)) + (:arg-types positive-fixnum) + (:temporary (:sc unsigned-reg :offset eax-offset :target res + :from (:argument 0) :to (:result 0)) + eax) + (:results (res :scs (character-reg))) + (:result-types character) + (:generator 1 + (move eax code) + (move res al-tn))) + +;;; comparison of CHARACTERs +(define-vop (character-compare) + (:args (x :scs (character-reg character-stack)) + (y :scs (character-reg) + :load-if (not (and (sc-is x character-reg) + (sc-is y character-stack))))) + (:arg-types character character) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:note "inline comparison") + (:variant-vars condition not-condition) + (:generator 3 + (inst cmp x y) + (inst jmp (if not-p not-condition condition) target))) + +(define-vop (fast-char=/character character-compare) + (:translate char=) + (:variant :e :ne)) + +(define-vop (fast-char/character character-compare) + (:translate char>) + (:variant :a :na)) + +(define-vop (character-compare/c) + (:args (x :scs (character-reg character-stack))) + (:arg-types character (:constant character)) + (:conditional) + (:info target not-p y) + (:policy :fast-safe) + (:note "inline constant comparison") + (:variant-vars condition not-condition) + (:generator 2 + (inst cmp x (sb!xc:char-code y)) + (inst jmp (if not-p not-condition condition) target))) + +(define-vop (fast-char=/character/c character-compare/c) + (:translate char=) + (:variant :e :ne)) + +(define-vop (fast-char/character/c character-compare/c) + (:translate char>) + (:variant :a :na)) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp -x external-format-test.txt -x test-status.lisp-expr sbcl-1.0.13-pristine/src/compiler/arm/debug.lisp sbcl-1.0.13-arm5-pass1/src/compiler/arm/debug.lisp --- sbcl-1.0.13-pristine/src/compiler/arm/debug.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-1.0.13-arm5-pass1/src/compiler/arm/debug.lisp 2007-12-28 17:57:08.134278637 -0500 @@ -0,0 +1,154 @@ +;;;; x86 support for the debugger + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + +(define-vop (debug-cur-sp) + (:translate current-sp) + (:policy :fast-safe) + (:results (res :scs (sap-reg sap-stack))) + (:result-types system-area-pointer) + (:generator 1 + (move res esp-tn))) + +(define-vop (debug-cur-fp) + (:translate current-fp) + (:policy :fast-safe) + (:results (res :scs (sap-reg sap-stack))) + (:result-types system-area-pointer) + (:generator 1 + (move res ebp-tn))) + +;;; Stack-ref and %set-stack-ref can be used to read and store +;;; descriptor objects on the control stack. Use the sap-ref +;;; functions to access other data types. +(define-vop (read-control-stack) + (:translate stack-ref) + (:policy :fast-safe) + (:args (sap :scs (sap-reg) :to :eval) + (offset :scs (any-reg) :target temp)) + (:arg-types system-area-pointer positive-fixnum) + (:temporary (:sc unsigned-reg :from (:argument 1)) temp) + (:results (result :scs (descriptor-reg))) + (:result-types *) + (:generator 9 + (move temp offset) + (inst neg temp) + (inst mov result + (make-ea :dword :base sap :disp (frame-byte-offset 0) :index temp)))) + +(define-vop (read-control-stack-c) + (:translate stack-ref) + (:policy :fast-safe) + (:args (sap :scs (sap-reg))) + (:info index) + (:arg-types system-area-pointer (:constant (signed-byte 30))) + (:results (result :scs (descriptor-reg))) + (:result-types *) + (:generator 5 + (inst mov result (make-ea :dword :base sap + :disp (frame-byte-offset index))))) + +(define-vop (write-control-stack) + (:translate %set-stack-ref) + (:policy :fast-safe) + (:args (sap :scs (sap-reg) :to :eval) + (offset :scs (any-reg) :target temp) + (value :scs (descriptor-reg) :to :result :target result)) + (:arg-types system-area-pointer positive-fixnum *) + (:temporary (:sc unsigned-reg :from (:argument 1) :to :result) temp) + (:results (result :scs (descriptor-reg))) + (:result-types *) + (:generator 9 + (move temp offset) + (inst neg temp) + (inst mov + (make-ea :dword :base sap :disp (frame-byte-offset 0) :index temp) value) + (move result value))) + +(define-vop (write-control-stack-c) + (:translate %set-stack-ref) + (:policy :fast-safe) + (:args (sap :scs (sap-reg)) + (value :scs (descriptor-reg) :target result)) + (:info index) + (:arg-types system-area-pointer (:constant (signed-byte 30)) *) + (:results (result :scs (descriptor-reg))) + (:result-types *) + (:generator 5 + (inst mov (make-ea :dword :base sap + :disp (frame-byte-offset index)) + value) + (move result value))) + +(define-vop (code-from-mumble) + (:policy :fast-safe) + (:args (thing :scs (descriptor-reg))) + (:results (code :scs (descriptor-reg))) + (:temporary (:sc unsigned-reg) temp) + (:variant-vars lowtag) + (:generator 5 + (let ((bogus (gen-label)) + (done (gen-label))) + (loadw temp thing 0 lowtag) + (inst shr temp n-widetag-bits) + (inst jmp :z bogus) + (inst shl temp (1- (integer-length n-word-bytes))) + (unless (= lowtag other-pointer-lowtag) + (inst add temp (- lowtag other-pointer-lowtag))) + (move code thing) + (inst sub code temp) + (emit-label done) + (assemble (*elsewhere*) + (emit-label bogus) + (inst mov code nil-value) + (inst jmp done))))) + +(define-vop (code-from-lra code-from-mumble) + (:translate sb!di::lra-code-header) + (:variant other-pointer-lowtag)) + +(define-vop (code-from-function code-from-mumble) + (:translate sb!di::fun-code-header) + (:variant fun-pointer-lowtag)) + +(define-vop (%make-lisp-obj) + (:policy :fast-safe) + (:translate %make-lisp-obj) + (:args (value :scs (unsigned-reg unsigned-stack) :target result)) + (:arg-types unsigned-num) + (:results (result :scs (descriptor-reg) + :load-if (not (sc-is value unsigned-reg)) + )) + (:generator 1 + (move result value))) + +(define-vop (get-lisp-obj-address) + (:policy :fast-safe) + (:translate sb!di::get-lisp-obj-address) + (:args (thing :scs (descriptor-reg control-stack) :target result)) + (:results (result :scs (unsigned-reg) + :load-if (not (and (sc-is thing descriptor-reg) + (sc-is result unsigned-stack))))) + (:result-types unsigned-num) + (:generator 1 + (move result thing))) + + +(define-vop (fun-word-offset) + (:policy :fast-safe) + (:translate sb!di::fun-word-offset) + (:args (fun :scs (descriptor-reg))) + (:results (res :scs (unsigned-reg))) + (:result-types positive-fixnum) + (:generator 5 + (loadw res fun 0 fun-pointer-lowtag) + (inst shr res n-widetag-bits))) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp -x external-format-test.txt -x test-status.lisp-expr sbcl-1.0.13-pristine/src/compiler/arm/float.lisp sbcl-1.0.13-arm5-pass1/src/compiler/arm/float.lisp --- sbcl-1.0.13-pristine/src/compiler/arm/float.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-1.0.13-arm5-pass1/src/compiler/arm/float.lisp 2007-12-28 17:57:08.150276196 -0500 @@ -0,0 +1,4303 @@ +;;;; floating point support for the x86 + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + +(macrolet ((ea-for-xf-desc (tn slot) + `(make-ea-for-object-slot ,tn ,slot other-pointer-lowtag))) + (defun ea-for-sf-desc (tn) + (ea-for-xf-desc tn single-float-value-slot)) + (defun ea-for-df-desc (tn) + (ea-for-xf-desc tn double-float-value-slot)) + #!+long-float + (defun ea-for-lf-desc (tn) + (ea-for-xf-desc tn long-float-value-slot)) + ;; complex floats + (defun ea-for-csf-real-desc (tn) + (ea-for-xf-desc tn complex-single-float-real-slot)) + (defun ea-for-csf-imag-desc (tn) + (ea-for-xf-desc tn complex-single-float-imag-slot)) + (defun ea-for-cdf-real-desc (tn) + (ea-for-xf-desc tn complex-double-float-real-slot)) + (defun ea-for-cdf-imag-desc (tn) + (ea-for-xf-desc tn complex-double-float-imag-slot)) + #!+long-float + (defun ea-for-clf-real-desc (tn) + (ea-for-xf-desc tn complex-long-float-real-slot)) + #!+long-float + (defun ea-for-clf-imag-desc (tn) + (ea-for-xf-desc tn complex-long-float-imag-slot))) + +(macrolet ((ea-for-xf-stack (tn kind) + `(make-ea + :dword :base ebp-tn + :disp (frame-byte-offset + (+ (tn-offset ,tn) + (ecase ,kind (:single 0) (:double 1) (:long 2))))))) + (defun ea-for-sf-stack (tn) + (ea-for-xf-stack tn :single)) + (defun ea-for-df-stack (tn) + (ea-for-xf-stack tn :double)) + #!+long-float + (defun ea-for-lf-stack (tn) + (ea-for-xf-stack tn :long))) + +;;; Telling the FPU to wait is required in order to make signals occur +;;; at the expected place, but naturally slows things down. +;;; +;;; NODE is the node whose compilation policy controls the decision +;;; whether to just blast through carelessly or carefully emit wait +;;; instructions and whatnot. +;;; +;;; NOTE-NEXT-INSTRUCTION, if supplied, is to be passed to +;;; #'NOTE-NEXT-INSTRUCTION. +;;; +;;; Until 2004-03-15, the implementation of this was buggy; it +;;; unconditionally emitted the WAIT instruction. It turns out that +;;; this is the right thing to do anyway; omitting them can lead to +;;; system corruption on conforming code. -- CSR +(defun maybe-fp-wait (node &optional note-next-instruction) + (declare (ignore node)) + #+nil + (when (policy node (or (= debug 3) (> safety speed)))) + (when note-next-instruction + (note-next-instruction note-next-instruction :internal-error)) + (inst wait)) + +;;; complex float stack EAs +(macrolet ((ea-for-cxf-stack (tn kind slot &optional base) + `(make-ea + :dword :base ,base + :disp (frame-byte-offset + (+ (tn-offset ,tn) + -1 + (* (ecase ,kind + (:single 1) + (:double 2) + (:long 3)) + (ecase ,slot (:real 1) (:imag 2)))))))) + (defun ea-for-csf-real-stack (tn &optional (base ebp-tn)) + (ea-for-cxf-stack tn :single :real base)) + (defun ea-for-csf-imag-stack (tn &optional (base ebp-tn)) + (ea-for-cxf-stack tn :single :imag base)) + (defun ea-for-cdf-real-stack (tn &optional (base ebp-tn)) + (ea-for-cxf-stack tn :double :real base)) + (defun ea-for-cdf-imag-stack (tn &optional (base ebp-tn)) + (ea-for-cxf-stack tn :double :imag base)) + #!+long-float + (defun ea-for-clf-real-stack (tn &optional (base ebp-tn)) + (ea-for-cxf-stack tn :long :real base)) + #!+long-float + (defun ea-for-clf-imag-stack (tn &optional (base ebp-tn)) + (ea-for-cxf-stack tn :long :imag base))) + +;;; Abstract out the copying of a FP register to the FP stack top, and +;;; provide two alternatives for its implementation. Note: it's not +;;; necessary to distinguish between a single or double register move +;;; here. +;;; +;;; Using a Pop then load. +(defun copy-fp-reg-to-fr0 (reg) + (aver (not (zerop (tn-offset reg)))) + (inst fstp fr0-tn) + (inst fld (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset reg))))) +;;; Using Fxch then Fst to restore the original reg contents. +#+nil +(defun copy-fp-reg-to-fr0 (reg) + (aver (not (zerop (tn-offset reg)))) + (inst fxch reg) + (inst fst reg)) + +;;; The x86 can't store a long-float to memory without popping the +;;; stack and marking a register as empty, so it is necessary to +;;; restore the register from memory. +#!+long-float +(defun store-long-float (ea) + (inst fstpl ea) + (inst fldl ea)) + +;;;; move functions + +;;; X is source, Y is destination. +(define-move-fun (load-single 2) (vop x y) + ((single-stack) (single-reg)) + (with-empty-tn@fp-top(y) + (inst fld (ea-for-sf-stack x)))) + +(define-move-fun (store-single 2) (vop x y) + ((single-reg) (single-stack)) + (cond ((zerop (tn-offset x)) + (inst fst (ea-for-sf-stack y))) + (t + (inst fxch x) + (inst fst (ea-for-sf-stack y)) + ;; This may not be necessary as ST0 is likely invalid now. + (inst fxch x)))) + +(define-move-fun (load-double 2) (vop x y) + ((double-stack) (double-reg)) + (with-empty-tn@fp-top(y) + (inst fldd (ea-for-df-stack x)))) + +(define-move-fun (store-double 2) (vop x y) + ((double-reg) (double-stack)) + (cond ((zerop (tn-offset x)) + (inst fstd (ea-for-df-stack y))) + (t + (inst fxch x) + (inst fstd (ea-for-df-stack y)) + ;; This may not be necessary as ST0 is likely invalid now. + (inst fxch x)))) + +#!+long-float +(define-move-fun (load-long 2) (vop x y) + ((long-stack) (long-reg)) + (with-empty-tn@fp-top(y) + (inst fldl (ea-for-lf-stack x)))) + +#!+long-float +(define-move-fun (store-long 2) (vop x y) + ((long-reg) (long-stack)) + (cond ((zerop (tn-offset x)) + (store-long-float (ea-for-lf-stack y))) + (t + (inst fxch x) + (store-long-float (ea-for-lf-stack y)) + ;; This may not be necessary as ST0 is likely invalid now. + (inst fxch x)))) + +;;; The i387 has instructions to load some useful constants. This +;;; doesn't save much time but might cut down on memory access and +;;; reduce the size of the constant vector (CV). Intel claims they are +;;; stored in a more precise form on chip. Anyhow, might as well use +;;; the feature. It can be turned off by hacking the +;;; "immediate-constant-sc" in vm.lisp. +(eval-when (:compile-toplevel :execute) + (setf *read-default-float-format* + #!+long-float 'long-float #!-long-float 'double-float)) +(define-move-fun (load-fp-constant 2) (vop x y) + ((fp-constant) (single-reg double-reg #!+long-float long-reg)) + (let ((value (sb!c::constant-value (sb!c::tn-leaf x)))) + (with-empty-tn@fp-top(y) + (cond ((zerop value) + (inst fldz)) + ((= value 1e0) + (inst fld1)) + ((= value (coerce pi *read-default-float-format*)) + (inst fldpi)) + ((= value (log 10e0 2e0)) + (inst fldl2t)) + ((= value (log 2.718281828459045235360287471352662e0 2e0)) + (inst fldl2e)) + ((= value (log 2e0 10e0)) + (inst fldlg2)) + ((= value (log 2e0 2.718281828459045235360287471352662e0)) + (inst fldln2)) + (t (warn "ignoring bogus i387 constant ~A" value)))))) +(eval-when (:compile-toplevel :execute) + (setf *read-default-float-format* 'single-float)) + +;;;; complex float move functions + +(defun complex-single-reg-real-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg) + :offset (tn-offset x))) +(defun complex-single-reg-imag-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg) + :offset (1+ (tn-offset x)))) + +(defun complex-double-reg-real-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg) + :offset (tn-offset x))) +(defun complex-double-reg-imag-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg) + :offset (1+ (tn-offset x)))) + +#!+long-float +(defun complex-long-reg-real-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg) + :offset (tn-offset x))) +#!+long-float +(defun complex-long-reg-imag-tn (x) + (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg) + :offset (1+ (tn-offset x)))) + +;;; X is source, Y is destination. +(define-move-fun (load-complex-single 2) (vop x y) + ((complex-single-stack) (complex-single-reg)) + (let ((real-tn (complex-single-reg-real-tn y))) + (with-empty-tn@fp-top (real-tn) + (inst fld (ea-for-csf-real-stack x)))) + (let ((imag-tn (complex-single-reg-imag-tn y))) + (with-empty-tn@fp-top (imag-tn) + (inst fld (ea-for-csf-imag-stack x))))) + +(define-move-fun (store-complex-single 2) (vop x y) + ((complex-single-reg) (complex-single-stack)) + (let ((real-tn (complex-single-reg-real-tn x))) + (cond ((zerop (tn-offset real-tn)) + (inst fst (ea-for-csf-real-stack y))) + (t + (inst fxch real-tn) + (inst fst (ea-for-csf-real-stack y)) + (inst fxch real-tn)))) + (let ((imag-tn (complex-single-reg-imag-tn x))) + (inst fxch imag-tn) + (inst fst (ea-for-csf-imag-stack y)) + (inst fxch imag-tn))) + +(define-move-fun (load-complex-double 2) (vop x y) + ((complex-double-stack) (complex-double-reg)) + (let ((real-tn (complex-double-reg-real-tn y))) + (with-empty-tn@fp-top(real-tn) + (inst fldd (ea-for-cdf-real-stack x)))) + (let ((imag-tn (complex-double-reg-imag-tn y))) + (with-empty-tn@fp-top(imag-tn) + (inst fldd (ea-for-cdf-imag-stack x))))) + +(define-move-fun (store-complex-double 2) (vop x y) + ((complex-double-reg) (complex-double-stack)) + (let ((real-tn (complex-double-reg-real-tn x))) + (cond ((zerop (tn-offset real-tn)) + (inst fstd (ea-for-cdf-real-stack y))) + (t + (inst fxch real-tn) + (inst fstd (ea-for-cdf-real-stack y)) + (inst fxch real-tn)))) + (let ((imag-tn (complex-double-reg-imag-tn x))) + (inst fxch imag-tn) + (inst fstd (ea-for-cdf-imag-stack y)) + (inst fxch imag-tn))) + +#!+long-float +(define-move-fun (load-complex-long 2) (vop x y) + ((complex-long-stack) (complex-long-reg)) + (let ((real-tn (complex-long-reg-real-tn y))) + (with-empty-tn@fp-top(real-tn) + (inst fldl (ea-for-clf-real-stack x)))) + (let ((imag-tn (complex-long-reg-imag-tn y))) + (with-empty-tn@fp-top(imag-tn) + (inst fldl (ea-for-clf-imag-stack x))))) + +#!+long-float +(define-move-fun (store-complex-long 2) (vop x y) + ((complex-long-reg) (complex-long-stack)) + (let ((real-tn (complex-long-reg-real-tn x))) + (cond ((zerop (tn-offset real-tn)) + (store-long-float (ea-for-clf-real-stack y))) + (t + (inst fxch real-tn) + (store-long-float (ea-for-clf-real-stack y)) + (inst fxch real-tn)))) + (let ((imag-tn (complex-long-reg-imag-tn x))) + (inst fxch imag-tn) + (store-long-float (ea-for-clf-imag-stack y)) + (inst fxch imag-tn))) + + +;;;; move VOPs + +;;; float register to register moves +(define-vop (float-move) + (:args (x)) + (:results (y)) + (:note "float move") + (:generator 0 + (unless (location= x y) + (cond ((zerop (tn-offset y)) + (copy-fp-reg-to-fr0 x)) + ((zerop (tn-offset x)) + (inst fstd y)) + (t + (inst fxch x) + (inst fstd y) + (inst fxch x)))))) + +(define-vop (single-move float-move) + (:args (x :scs (single-reg) :target y :load-if (not (location= x y)))) + (:results (y :scs (single-reg) :load-if (not (location= x y))))) +(define-move-vop single-move :move (single-reg) (single-reg)) + +(define-vop (double-move float-move) + (:args (x :scs (double-reg) :target y :load-if (not (location= x y)))) + (:results (y :scs (double-reg) :load-if (not (location= x y))))) +(define-move-vop double-move :move (double-reg) (double-reg)) + +#!+long-float +(define-vop (long-move float-move) + (:args (x :scs (long-reg) :target y :load-if (not (location= x y)))) + (:results (y :scs (long-reg) :load-if (not (location= x y))))) +#!+long-float +(define-move-vop long-move :move (long-reg) (long-reg)) + +;;; complex float register to register moves +(define-vop (complex-float-move) + (:args (x :target y :load-if (not (location= x y)))) + (:results (y :load-if (not (location= x y)))) + (:note "complex float move") + (:generator 0 + (unless (location= x y) + ;; Note the complex-float-regs are aligned to every second + ;; float register so there is not need to worry about overlap. + (let ((x-real (complex-double-reg-real-tn x)) + (y-real (complex-double-reg-real-tn y))) + (cond ((zerop (tn-offset y-real)) + (copy-fp-reg-to-fr0 x-real)) + ((zerop (tn-offset x-real)) + (inst fstd y-real)) + (t + (inst fxch x-real) + (inst fstd y-real) + (inst fxch x-real)))) + (let ((x-imag (complex-double-reg-imag-tn x)) + (y-imag (complex-double-reg-imag-tn y))) + (inst fxch x-imag) + (inst fstd y-imag) + (inst fxch x-imag))))) + +(define-vop (complex-single-move complex-float-move) + (:args (x :scs (complex-single-reg) :target y + :load-if (not (location= x y)))) + (:results (y :scs (complex-single-reg) :load-if (not (location= x y))))) +(define-move-vop complex-single-move :move + (complex-single-reg) (complex-single-reg)) + +(define-vop (complex-double-move complex-float-move) + (:args (x :scs (complex-double-reg) + :target y :load-if (not (location= x y)))) + (:results (y :scs (complex-double-reg) :load-if (not (location= x y))))) +(define-move-vop complex-double-move :move + (complex-double-reg) (complex-double-reg)) + +#!+long-float +(define-vop (complex-long-move complex-float-move) + (:args (x :scs (complex-long-reg) + :target y :load-if (not (location= x y)))) + (:results (y :scs (complex-long-reg) :load-if (not (location= x y))))) +#!+long-float +(define-move-vop complex-long-move :move + (complex-long-reg) (complex-long-reg)) + +;;; Move from float to a descriptor reg. allocating a new float +;;; object in the process. +(define-vop (move-from-single) + (:args (x :scs (single-reg) :to :save)) + (:results (y :scs (descriptor-reg))) + (:node-var node) + (:note "float to pointer coercion") + (:generator 13 + (with-fixed-allocation (y + single-float-widetag + single-float-size node) + (with-tn@fp-top(x) + (inst fst (ea-for-sf-desc y)))))) +(define-move-vop move-from-single :move + (single-reg) (descriptor-reg)) + +(define-vop (move-from-double) + (:args (x :scs (double-reg) :to :save)) + (:results (y :scs (descriptor-reg))) + (:node-var node) + (:note "float to pointer coercion") + (:generator 13 + (with-fixed-allocation (y + double-float-widetag + double-float-size + node) + (with-tn@fp-top(x) + (inst fstd (ea-for-df-desc y)))))) +(define-move-vop move-from-double :move + (double-reg) (descriptor-reg)) + +#!+long-float +(define-vop (move-from-long) + (:args (x :scs (long-reg) :to :save)) + (:results (y :scs (descriptor-reg))) + (:node-var node) + (:note "float to pointer coercion") + (:generator 13 + (with-fixed-allocation (y + long-float-widetag + long-float-size + node) + (with-tn@fp-top(x) + (store-long-float (ea-for-lf-desc y)))))) +#!+long-float +(define-move-vop move-from-long :move + (long-reg) (descriptor-reg)) + +(define-vop (move-from-fp-constant) + (:args (x :scs (fp-constant))) + (:results (y :scs (descriptor-reg))) + (:generator 2 + (ecase (sb!c::constant-value (sb!c::tn-leaf x)) + (0f0 (load-symbol-value y *fp-constant-0f0*)) + (1f0 (load-symbol-value y *fp-constant-1f0*)) + (0d0 (load-symbol-value y *fp-constant-0d0*)) + (1d0 (load-symbol-value y *fp-constant-1d0*)) + #!+long-float + (0l0 (load-symbol-value y *fp-constant-0l0*)) + #!+long-float + (1l0 (load-symbol-value y *fp-constant-1l0*)) + #!+long-float + (#.pi (load-symbol-value y *fp-constant-pi*)) + #!+long-float + (#.(log 10l0 2l0) (load-symbol-value y *fp-constant-l2t*)) + #!+long-float + (#.(log 2.718281828459045235360287471352662L0 2l0) + (load-symbol-value y *fp-constant-l2e*)) + #!+long-float + (#.(log 2l0 10l0) (load-symbol-value y *fp-constant-lg2*)) + #!+long-float + (#.(log 2l0 2.718281828459045235360287471352662L0) + (load-symbol-value y *fp-constant-ln2*))))) +(define-move-vop move-from-fp-constant :move + (fp-constant) (descriptor-reg)) + +;;; Move from a descriptor to a float register. +(define-vop (move-to-single) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (single-reg))) + (:note "pointer to float coercion") + (:generator 2 + (with-empty-tn@fp-top(y) + (inst fld (ea-for-sf-desc x))))) +(define-move-vop move-to-single :move (descriptor-reg) (single-reg)) + +(define-vop (move-to-double) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (double-reg))) + (:note "pointer to float coercion") + (:generator 2 + (with-empty-tn@fp-top(y) + (inst fldd (ea-for-df-desc x))))) +(define-move-vop move-to-double :move (descriptor-reg) (double-reg)) + +#!+long-float +(define-vop (move-to-long) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (long-reg))) + (:note "pointer to float coercion") + (:generator 2 + (with-empty-tn@fp-top(y) + (inst fldl (ea-for-lf-desc x))))) +#!+long-float +(define-move-vop move-to-long :move (descriptor-reg) (long-reg)) + +;;; Move from complex float to a descriptor reg. allocating a new +;;; complex float object in the process. +(define-vop (move-from-complex-single) + (:args (x :scs (complex-single-reg) :to :save)) + (:results (y :scs (descriptor-reg))) + (:node-var node) + (:note "complex float to pointer coercion") + (:generator 13 + (with-fixed-allocation (y + complex-single-float-widetag + complex-single-float-size + node) + (let ((real-tn (complex-single-reg-real-tn x))) + (with-tn@fp-top(real-tn) + (inst fst (ea-for-csf-real-desc y)))) + (let ((imag-tn (complex-single-reg-imag-tn x))) + (with-tn@fp-top(imag-tn) + (inst fst (ea-for-csf-imag-desc y))))))) +(define-move-vop move-from-complex-single :move + (complex-single-reg) (descriptor-reg)) + +(define-vop (move-from-complex-double) + (:args (x :scs (complex-double-reg) :to :save)) + (:results (y :scs (descriptor-reg))) + (:node-var node) + (:note "complex float to pointer coercion") + (:generator 13 + (with-fixed-allocation (y + complex-double-float-widetag + complex-double-float-size + node) + (let ((real-tn (complex-double-reg-real-tn x))) + (with-tn@fp-top(real-tn) + (inst fstd (ea-for-cdf-real-desc y)))) + (let ((imag-tn (complex-double-reg-imag-tn x))) + (with-tn@fp-top(imag-tn) + (inst fstd (ea-for-cdf-imag-desc y))))))) +(define-move-vop move-from-complex-double :move + (complex-double-reg) (descriptor-reg)) + +#!+long-float +(define-vop (move-from-complex-long) + (:args (x :scs (complex-long-reg) :to :save)) + (:results (y :scs (descriptor-reg))) + (:node-var node) + (:note "complex float to pointer coercion") + (:generator 13 + (with-fixed-allocation (y + complex-long-float-widetag + complex-long-float-size + node) + (let ((real-tn (complex-long-reg-real-tn x))) + (with-tn@fp-top(real-tn) + (store-long-float (ea-for-clf-real-desc y)))) + (let ((imag-tn (complex-long-reg-imag-tn x))) + (with-tn@fp-top(imag-tn) + (store-long-float (ea-for-clf-imag-desc y))))))) +#!+long-float +(define-move-vop move-from-complex-long :move + (complex-long-reg) (descriptor-reg)) + +;;; Move from a descriptor to a complex float register. +(macrolet ((frob (name sc format) + `(progn + (define-vop (,name) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (,sc))) + (:note "pointer to complex float coercion") + (:generator 2 + (let ((real-tn (complex-double-reg-real-tn y))) + (with-empty-tn@fp-top(real-tn) + ,@(ecase format + (:single '((inst fld (ea-for-csf-real-desc x)))) + (:double '((inst fldd (ea-for-cdf-real-desc x)))) + #!+long-float + (:long '((inst fldl (ea-for-clf-real-desc x))))))) + (let ((imag-tn (complex-double-reg-imag-tn y))) + (with-empty-tn@fp-top(imag-tn) + ,@(ecase format + (:single '((inst fld (ea-for-csf-imag-desc x)))) + (:double '((inst fldd (ea-for-cdf-imag-desc x)))) + #!+long-float + (:long '((inst fldl (ea-for-clf-imag-desc x))))))))) + (define-move-vop ,name :move (descriptor-reg) (,sc))))) + (frob move-to-complex-single complex-single-reg :single) + (frob move-to-complex-double complex-double-reg :double) + #!+long-float + (frob move-to-complex-double complex-long-reg :long)) + +;;;; the move argument vops +;;;; +;;;; Note these are also used to stuff fp numbers onto the c-call +;;;; stack so the order is different than the lisp-stack. + +;;; the general MOVE-ARG VOP +(macrolet ((frob (name sc stack-sc format) + `(progn + (define-vop (,name) + (:args (x :scs (,sc) :target y) + (fp :scs (any-reg) + :load-if (not (sc-is y ,sc)))) + (:results (y)) + (:note "float argument move") + (:generator ,(case format (:single 2) (:double 3) (:long 4)) + (sc-case y + (,sc + (unless (location= x y) + (cond ((zerop (tn-offset y)) + (copy-fp-reg-to-fr0 x)) + ((zerop (tn-offset x)) + (inst fstd y)) + (t + (inst fxch x) + (inst fstd y) + (inst fxch x))))) + (,stack-sc + (if (= (tn-offset fp) esp-offset) + ;; C-call + (let* ((offset (* (tn-offset y) n-word-bytes)) + (ea (make-ea :dword :base fp :disp offset))) + (with-tn@fp-top(x) + ,@(ecase format + (:single '((inst fst ea))) + (:double '((inst fstd ea))) + #!+long-float + (:long '((store-long-float ea)))))) + ;; Lisp stack + (let ((ea (make-ea + :dword :base fp + :disp (frame-byte-offset + (+ (tn-offset y) + ,(case format + (:single 0) + (:double 1) + (:long 2))))))) + (with-tn@fp-top(x) + ,@(ecase format + (:single '((inst fst ea))) + (:double '((inst fstd ea))) + #!+long-float + (:long '((store-long-float ea))))))))))) + (define-move-vop ,name :move-arg + (,sc descriptor-reg) (,sc))))) + (frob move-single-float-arg single-reg single-stack :single) + (frob move-double-float-arg double-reg double-stack :double) + #!+long-float + (frob move-long-float-arg long-reg long-stack :long)) + +;;;; complex float MOVE-ARG VOP +(macrolet ((frob (name sc stack-sc format) + `(progn + (define-vop (,name) + (:args (x :scs (,sc) :target y) + (fp :scs (any-reg) + :load-if (not (sc-is y ,sc)))) + (:results (y)) + (:note "complex float argument move") + (:generator ,(ecase format (:single 2) (:double 3) (:long 4)) + (sc-case y + (,sc + (unless (location= x y) + (let ((x-real (complex-double-reg-real-tn x)) + (y-real (complex-double-reg-real-tn y))) + (cond ((zerop (tn-offset y-real)) + (copy-fp-reg-to-fr0 x-real)) + ((zerop (tn-offset x-real)) + (inst fstd y-real)) + (t + (inst fxch x-real) + (inst fstd y-real) + (inst fxch x-real)))) + (let ((x-imag (complex-double-reg-imag-tn x)) + (y-imag (complex-double-reg-imag-tn y))) + (inst fxch x-imag) + (inst fstd y-imag) + (inst fxch x-imag)))) + (,stack-sc + (let ((real-tn (complex-double-reg-real-tn x))) + (cond ((zerop (tn-offset real-tn)) + ,@(ecase format + (:single + '((inst fst + (ea-for-csf-real-stack y fp)))) + (:double + '((inst fstd + (ea-for-cdf-real-stack y fp)))) + #!+long-float + (:long + '((store-long-float + (ea-for-clf-real-stack y fp)))))) + (t + (inst fxch real-tn) + ,@(ecase format + (:single + '((inst fst + (ea-for-csf-real-stack y fp)))) + (:double + '((inst fstd + (ea-for-cdf-real-stack y fp)))) + #!+long-float + (:long + '((store-long-float + (ea-for-clf-real-stack y fp))))) + (inst fxch real-tn)))) + (let ((imag-tn (complex-double-reg-imag-tn x))) + (inst fxch imag-tn) + ,@(ecase format + (:single + '((inst fst (ea-for-csf-imag-stack y fp)))) + (:double + '((inst fstd (ea-for-cdf-imag-stack y fp)))) + #!+long-float + (:long + '((store-long-float + (ea-for-clf-imag-stack y fp))))) + (inst fxch imag-tn)))))) + (define-move-vop ,name :move-arg + (,sc descriptor-reg) (,sc))))) + (frob move-complex-single-float-arg + complex-single-reg complex-single-stack :single) + (frob move-complex-double-float-arg + complex-double-reg complex-double-stack :double) + #!+long-float + (frob move-complex-long-float-arg + complex-long-reg complex-long-stack :long)) + +(define-move-vop move-arg :move-arg + (single-reg double-reg #!+long-float long-reg + complex-single-reg complex-double-reg #!+long-float complex-long-reg) + (descriptor-reg)) + + +;;;; arithmetic VOPs + +;;; dtc: the floating point arithmetic vops +;;; +;;; Note: Although these can accept x and y on the stack or pointed to +;;; from a descriptor register, they will work with register loading +;;; without these. Same deal with the result - it need only be a +;;; register. When load-tns are needed they will probably be in ST0 +;;; and the code below should be able to correctly handle all cases. +;;; +;;; However it seems to produce better code if all arg. and result +;;; options are used; on the P86 there is no extra cost in using a +;;; memory operand to the FP instructions - not so on the PPro. +;;; +;;; It may also be useful to handle constant args? +;;; +;;; 22-Jul-97: descriptor args lose in some simple cases when +;;; a function result computed in a loop. Then Python insists +;;; on consing the intermediate values! For example +;;; +;;; (defun test(a n) +;;; (declare (type (simple-array double-float (*)) a) +;;; (fixnum n)) +;;; (let ((sum 0d0)) +;;; (declare (type double-float sum)) +;;; (dotimes (i n) +;;; (incf sum (* (aref a i)(aref a i)))) +;;; sum)) +;;; +;;; So, disabling descriptor args until this can be fixed elsewhere. +(macrolet + ((frob (op fop-sti fopr-sti + fop fopr sname scost + fopd foprd dname dcost + lname lcost) + #!-long-float (declare (ignore lcost lname)) + `(progn + (define-vop (,sname) + (:translate ,op) + (:args (x :scs (single-reg single-stack #+nil descriptor-reg) + :to :eval) + (y :scs (single-reg single-stack #+nil descriptor-reg) + :to :eval)) + (:temporary (:sc single-reg :offset fr0-offset + :from :eval :to :result) fr0) + (:results (r :scs (single-reg single-stack))) + (:arg-types single-float single-float) + (:result-types single-float) + (:policy :fast-safe) + (:note "inline float arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:node-var node) + (:generator ,scost + ;; Handle a few special cases + (cond + ;; x, y, and r are the same register. + ((and (sc-is x single-reg) (location= x r) (location= y r)) + (cond ((zerop (tn-offset r)) + (inst ,fop fr0)) + (t + (inst fxch r) + (inst ,fop fr0) + ;; XX the source register will not be valid. + (note-next-instruction vop :internal-error) + (inst fxch r)))) + + ;; x and r are the same register. + ((and (sc-is x single-reg) (location= x r)) + (cond ((zerop (tn-offset r)) + (sc-case y + (single-reg + ;; ST(0) = ST(0) op ST(y) + (inst ,fop y)) + (single-stack + ;; ST(0) = ST(0) op Mem + (inst ,fop (ea-for-sf-stack y))) + (descriptor-reg + (inst ,fop (ea-for-sf-desc y))))) + (t + ;; y to ST0 + (sc-case y + (single-reg + (unless (zerop (tn-offset y)) + (copy-fp-reg-to-fr0 y))) + ((single-stack descriptor-reg) + (inst fstp fr0) + (if (sc-is y single-stack) + (inst fld (ea-for-sf-stack y)) + (inst fld (ea-for-sf-desc y))))) + ;; ST(i) = ST(i) op ST0 + (inst ,fop-sti r))) + (maybe-fp-wait node vop)) + ;; y and r are the same register. + ((and (sc-is y single-reg) (location= y r)) + (cond ((zerop (tn-offset r)) + (sc-case x + (single-reg + ;; ST(0) = ST(x) op ST(0) + (inst ,fopr x)) + (single-stack + ;; ST(0) = Mem op ST(0) + (inst ,fopr (ea-for-sf-stack x))) + (descriptor-reg + (inst ,fopr (ea-for-sf-desc x))))) + (t + ;; x to ST0 + (sc-case x + (single-reg + (unless (zerop (tn-offset x)) + (copy-fp-reg-to-fr0 x))) + ((single-stack descriptor-reg) + (inst fstp fr0) + (if (sc-is x single-stack) + (inst fld (ea-for-sf-stack x)) + (inst fld (ea-for-sf-desc x))))) + ;; ST(i) = ST(0) op ST(i) + (inst ,fopr-sti r))) + (maybe-fp-wait node vop)) + ;; the default case + (t + ;; Get the result to ST0. + + ;; Special handling is needed if x or y are in ST0, and + ;; simpler code is generated. + (cond + ;; x is in ST0 + ((and (sc-is x single-reg) (zerop (tn-offset x))) + ;; ST0 = ST0 op y + (sc-case y + (single-reg + (inst ,fop y)) + (single-stack + (inst ,fop (ea-for-sf-stack y))) + (descriptor-reg + (inst ,fop (ea-for-sf-desc y))))) + ;; y is in ST0 + ((and (sc-is y single-reg) (zerop (tn-offset y))) + ;; ST0 = x op ST0 + (sc-case x + (single-reg + (inst ,fopr x)) + (single-stack + (inst ,fopr (ea-for-sf-stack x))) + (descriptor-reg + (inst ,fopr (ea-for-sf-desc x))))) + (t + ;; x to ST0 + (sc-case x + (single-reg + (copy-fp-reg-to-fr0 x)) + (single-stack + (inst fstp fr0) + (inst fld (ea-for-sf-stack x))) + (descriptor-reg + (inst fstp fr0) + (inst fld (ea-for-sf-desc x)))) + ;; ST0 = ST0 op y + (sc-case y + (single-reg + (inst ,fop y)) + (single-stack + (inst ,fop (ea-for-sf-stack y))) + (descriptor-reg + (inst ,fop (ea-for-sf-desc y)))))) + + (note-next-instruction vop :internal-error) + + ;; Finally save the result. + (sc-case r + (single-reg + (cond ((zerop (tn-offset r)) + (maybe-fp-wait node)) + (t + (inst fst r)))) + (single-stack + (inst fst (ea-for-sf-stack r)))))))) + + (define-vop (,dname) + (:translate ,op) + (:args (x :scs (double-reg double-stack #+nil descriptor-reg) + :to :eval) + (y :scs (double-reg double-stack #+nil descriptor-reg) + :to :eval)) + (:temporary (:sc double-reg :offset fr0-offset + :from :eval :to :result) fr0) + (:results (r :scs (double-reg double-stack))) + (:arg-types double-float double-float) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline float arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:node-var node) + (:generator ,dcost + ;; Handle a few special cases. + (cond + ;; x, y, and r are the same register. + ((and (sc-is x double-reg) (location= x r) (location= y r)) + (cond ((zerop (tn-offset r)) + (inst ,fop fr0)) + (t + (inst fxch x) + (inst ,fopd fr0) + ;; XX the source register will not be valid. + (note-next-instruction vop :internal-error) + (inst fxch r)))) + + ;; x and r are the same register. + ((and (sc-is x double-reg) (location= x r)) + (cond ((zerop (tn-offset r)) + (sc-case y + (double-reg + ;; ST(0) = ST(0) op ST(y) + (inst ,fopd y)) + (double-stack + ;; ST(0) = ST(0) op Mem + (inst ,fopd (ea-for-df-stack y))) + (descriptor-reg + (inst ,fopd (ea-for-df-desc y))))) + (t + ;; y to ST0 + (sc-case y + (double-reg + (unless (zerop (tn-offset y)) + (copy-fp-reg-to-fr0 y))) + ((double-stack descriptor-reg) + (inst fstp fr0) + (if (sc-is y double-stack) + (inst fldd (ea-for-df-stack y)) + (inst fldd (ea-for-df-desc y))))) + ;; ST(i) = ST(i) op ST0 + (inst ,fop-sti r))) + (maybe-fp-wait node vop)) + ;; y and r are the same register. + ((and (sc-is y double-reg) (location= y r)) + (cond ((zerop (tn-offset r)) + (sc-case x + (double-reg + ;; ST(0) = ST(x) op ST(0) + (inst ,foprd x)) + (double-stack + ;; ST(0) = Mem op ST(0) + (inst ,foprd (ea-for-df-stack x))) + (descriptor-reg + (inst ,foprd (ea-for-df-desc x))))) + (t + ;; x to ST0 + (sc-case x + (double-reg + (unless (zerop (tn-offset x)) + (copy-fp-reg-to-fr0 x))) + ((double-stack descriptor-reg) + (inst fstp fr0) + (if (sc-is x double-stack) + (inst fldd (ea-for-df-stack x)) + (inst fldd (ea-for-df-desc x))))) + ;; ST(i) = ST(0) op ST(i) + (inst ,fopr-sti r))) + (maybe-fp-wait node vop)) + ;; the default case + (t + ;; Get the result to ST0. + + ;; Special handling is needed if x or y are in ST0, and + ;; simpler code is generated. + (cond + ;; x is in ST0 + ((and (sc-is x double-reg) (zerop (tn-offset x))) + ;; ST0 = ST0 op y + (sc-case y + (double-reg + (inst ,fopd y)) + (double-stack + (inst ,fopd (ea-for-df-stack y))) + (descriptor-reg + (inst ,fopd (ea-for-df-desc y))))) + ;; y is in ST0 + ((and (sc-is y double-reg) (zerop (tn-offset y))) + ;; ST0 = x op ST0 + (sc-case x + (double-reg + (inst ,foprd x)) + (double-stack + (inst ,foprd (ea-for-df-stack x))) + (descriptor-reg + (inst ,foprd (ea-for-df-desc x))))) + (t + ;; x to ST0 + (sc-case x + (double-reg + (copy-fp-reg-to-fr0 x)) + (double-stack + (inst fstp fr0) + (inst fldd (ea-for-df-stack x))) + (descriptor-reg + (inst fstp fr0) + (inst fldd (ea-for-df-desc x)))) + ;; ST0 = ST0 op y + (sc-case y + (double-reg + (inst ,fopd y)) + (double-stack + (inst ,fopd (ea-for-df-stack y))) + (descriptor-reg + (inst ,fopd (ea-for-df-desc y)))))) + + (note-next-instruction vop :internal-error) + + ;; Finally save the result. + (sc-case r + (double-reg + (cond ((zerop (tn-offset r)) + (maybe-fp-wait node)) + (t + (inst fst r)))) + (double-stack + (inst fstd (ea-for-df-stack r)))))))) + + #!+long-float + (define-vop (,lname) + (:translate ,op) + (:args (x :scs (long-reg) :to :eval) + (y :scs (long-reg) :to :eval)) + (:temporary (:sc long-reg :offset fr0-offset + :from :eval :to :result) fr0) + (:results (r :scs (long-reg))) + (:arg-types long-float long-float) + (:result-types long-float) + (:policy :fast-safe) + (:note "inline float arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:node-var node) + (:generator ,lcost + ;; Handle a few special cases. + (cond + ;; x, y, and r are the same register. + ((and (location= x r) (location= y r)) + (cond ((zerop (tn-offset r)) + (inst ,fop fr0)) + (t + (inst fxch x) + (inst ,fopd fr0) + ;; XX the source register will not be valid. + (note-next-instruction vop :internal-error) + (inst fxch r)))) + + ;; x and r are the same register. + ((location= x r) + (cond ((zerop (tn-offset r)) + ;; ST(0) = ST(0) op ST(y) + (inst ,fopd y)) + (t + ;; y to ST0 + (unless (zerop (tn-offset y)) + (copy-fp-reg-to-fr0 y)) + ;; ST(i) = ST(i) op ST0 + (inst ,fop-sti r))) + (maybe-fp-wait node vop)) + ;; y and r are the same register. + ((location= y r) + (cond ((zerop (tn-offset r)) + ;; ST(0) = ST(x) op ST(0) + (inst ,foprd x)) + (t + ;; x to ST0 + (unless (zerop (tn-offset x)) + (copy-fp-reg-to-fr0 x)) + ;; ST(i) = ST(0) op ST(i) + (inst ,fopr-sti r))) + (maybe-fp-wait node vop)) + ;; the default case + (t + ;; Get the result to ST0. + + ;; Special handling is needed if x or y are in ST0, and + ;; simpler code is generated. + (cond + ;; x is in ST0. + ((zerop (tn-offset x)) + ;; ST0 = ST0 op y + (inst ,fopd y)) + ;; y is in ST0 + ((zerop (tn-offset y)) + ;; ST0 = x op ST0 + (inst ,foprd x)) + (t + ;; x to ST0 + (copy-fp-reg-to-fr0 x) + ;; ST0 = ST0 op y + (inst ,fopd y))) + + (note-next-instruction vop :internal-error) + + ;; Finally save the result. + (cond ((zerop (tn-offset r)) + (maybe-fp-wait node)) + (t + (inst fst r)))))))))) + + (frob + fadd-sti fadd-sti + fadd fadd +/single-float 2 + faddd faddd +/double-float 2 + +/long-float 2) + (frob - fsub-sti fsubr-sti + fsub fsubr -/single-float 2 + fsubd fsubrd -/double-float 2 + -/long-float 2) + (frob * fmul-sti fmul-sti + fmul fmul */single-float 3 + fmuld fmuld */double-float 3 + */long-float 3) + (frob / fdiv-sti fdivr-sti + fdiv fdivr //single-float 12 + fdivd fdivrd //double-float 12 + //long-float 12)) + +(macrolet ((frob (name inst translate sc type) + `(define-vop (,name) + (:args (x :scs (,sc) :target fr0)) + (:results (y :scs (,sc))) + (:translate ,translate) + (:policy :fast-safe) + (:arg-types ,type) + (:result-types ,type) + (:temporary (:sc double-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:ignore fr0) + (:note "inline float arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:generator 1 + (note-this-location vop :internal-error) + (unless (zerop (tn-offset x)) + (inst fxch x) ; x to top of stack + (unless (location= x y) + (inst fst x))) ; Maybe save it. + (inst ,inst) ; Clobber st0. + (unless (zerop (tn-offset y)) + (inst fst y)))))) + + (frob abs/single-float fabs abs single-reg single-float) + (frob abs/double-float fabs abs double-reg double-float) + #!+long-float + (frob abs/long-float fabs abs long-reg long-float) + (frob %negate/single-float fchs %negate single-reg single-float) + (frob %negate/double-float fchs %negate double-reg double-float) + #!+long-float + (frob %negate/long-float fchs %negate long-reg long-float)) + +;;;; comparison + +(define-vop (=/float) + (:args (x) (y)) + (:temporary (:sc word-reg :offset eax-offset :from :eval) temp) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:vop-var vop) + (:save-p :compute-only) + (:note "inline float comparison") + (:ignore temp) + (:generator 3 + (note-this-location vop :internal-error) + (cond + ;; x is in ST0; y is in any reg. + ((zerop (tn-offset x)) + (inst fucom y)) + ;; y is in ST0; x is in another reg. + ((zerop (tn-offset y)) + (inst fucom x)) + ;; x and y are the same register, not ST0 + ((location= x y) + (inst fxch x) + (inst fucom fr0-tn) + (inst fxch x)) + ;; x and y are different registers, neither ST0. + (t + (inst fxch x) + (inst fucom y) + (inst fxch x))) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x45) ; C3 C2 C0 + (inst cmp ah-tn #x40) + (inst jmp (if not-p :ne :e) target))) + +(define-vop (=/single-float =/float) + (:translate =) + (:args (x :scs (single-reg)) + (y :scs (single-reg))) + (:arg-types single-float single-float)) + +(define-vop (=/double-float =/float) + (:translate =) + (:args (x :scs (double-reg)) + (y :scs (double-reg))) + (:arg-types double-float double-float)) + +#!+long-float +(define-vop (=/long-float =/float) + (:translate =) + (:args (x :scs (long-reg)) + (y :scs (long-reg))) + (:arg-types long-float long-float)) + +(define-vop (single-float) + (:translate >) + (:args (x :scs (single-reg single-stack descriptor-reg)) + (y :scs (single-reg single-stack descriptor-reg))) + (:arg-types single-float single-float) + (:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0) + (:temporary (:sc word-reg :offset eax-offset :from :eval) temp) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:note "inline float comparison") + (:ignore temp) + (:generator 3 + ;; Handle a few special cases. + (cond + ;; y is ST0. + ((and (sc-is y single-reg) (zerop (tn-offset y))) + (sc-case x + (single-reg + (inst fcom x)) + ((single-stack descriptor-reg) + (if (sc-is x single-stack) + (inst fcom (ea-for-sf-stack x)) + (inst fcom (ea-for-sf-desc x))))) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x45) + (inst cmp ah-tn #x01)) + + ;; general case when y is not in ST0 + (t + ;; x to ST0 + (sc-case x + (single-reg + (unless (zerop (tn-offset x)) + (copy-fp-reg-to-fr0 x))) + ((single-stack descriptor-reg) + (inst fstp fr0) + (if (sc-is x single-stack) + (inst fld (ea-for-sf-stack x)) + (inst fld (ea-for-sf-desc x))))) + (sc-case y + (single-reg + (inst fcom y)) + ((single-stack descriptor-reg) + (if (sc-is y single-stack) + (inst fcom (ea-for-sf-stack y)) + (inst fcom (ea-for-sf-desc y))))) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x45))) + (inst jmp (if not-p :ne :e) target))) + +(define-vop (>double-float) + (:translate >) + (:args (x :scs (double-reg double-stack descriptor-reg)) + (y :scs (double-reg double-stack descriptor-reg))) + (:arg-types double-float double-float) + (:temporary (:sc double-reg :offset fr0-offset :from :eval) fr0) + (:temporary (:sc word-reg :offset eax-offset :from :eval) temp) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:note "inline float comparison") + (:ignore temp) + (:generator 3 + ;; Handle a few special cases. + (cond + ;; y is ST0. + ((and (sc-is y double-reg) (zerop (tn-offset y))) + (sc-case x + (double-reg + (inst fcomd x)) + ((double-stack descriptor-reg) + (if (sc-is x double-stack) + (inst fcomd (ea-for-df-stack x)) + (inst fcomd (ea-for-df-desc x))))) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x45) + (inst cmp ah-tn #x01)) + + ;; general case when y is not in ST0 + (t + ;; x to ST0 + (sc-case x + (double-reg + (unless (zerop (tn-offset x)) + (copy-fp-reg-to-fr0 x))) + ((double-stack descriptor-reg) + (inst fstp fr0) + (if (sc-is x double-stack) + (inst fldd (ea-for-df-stack x)) + (inst fldd (ea-for-df-desc x))))) + (sc-case y + (double-reg + (inst fcomd y)) + ((double-stack descriptor-reg) + (if (sc-is y double-stack) + (inst fcomd (ea-for-df-stack y)) + (inst fcomd (ea-for-df-desc y))))) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x45))) + (inst jmp (if not-p :ne :e) target))) + +#!+long-float +(define-vop (>long-float) + (:translate >) + (:args (x :scs (long-reg)) + (y :scs (long-reg))) + (:arg-types long-float long-float) + (:temporary (:sc word-reg :offset eax-offset :from :eval) temp) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:note "inline float comparison") + (:ignore temp) + (:generator 3 + (cond + ;; y is in ST0; x is in any reg. + ((zerop (tn-offset y)) + (inst fcomd x) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x45) + (inst cmp ah-tn #x01)) + ;; x is in ST0; y is in another reg. + ((zerop (tn-offset x)) + (inst fcomd y) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x45)) + ;; y and x are the same register, not ST0 + ;; y and x are different registers, neither ST0. + (t + (inst fxch x) + (inst fcomd y) + (inst fxch x) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x45))) + (inst jmp (if not-p :ne :e) target))) + +;;; Comparisons with 0 can use the FTST instruction. + +(define-vop (float-test) + (:args (x)) + (:temporary (:sc word-reg :offset eax-offset :from :eval) temp) + (:conditional) + (:info target not-p y) + (:variant-vars code) + (:policy :fast-safe) + (:vop-var vop) + (:save-p :compute-only) + (:note "inline float comparison") + (:ignore temp y) + (:generator 2 + (note-this-location vop :internal-error) + (cond + ;; x is in ST0 + ((zerop (tn-offset x)) + (inst ftst)) + ;; x not ST0 + (t + (inst fxch x) + (inst ftst) + (inst fxch x))) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x45) ; C3 C2 C0 + (unless (zerop code) + (inst cmp ah-tn code)) + (inst jmp (if not-p :ne :e) target))) + +(define-vop (=0/single-float float-test) + (:translate =) + (:args (x :scs (single-reg))) + (:arg-types single-float (:constant (single-float 0f0 0f0))) + (:variant #x40)) +(define-vop (=0/double-float float-test) + (:translate =) + (:args (x :scs (double-reg))) + (:arg-types double-float (:constant (double-float 0d0 0d0))) + (:variant #x40)) +#!+long-float +(define-vop (=0/long-float float-test) + (:translate =) + (:args (x :scs (long-reg))) + (:arg-types long-float (:constant (long-float 0l0 0l0))) + (:variant #x40)) + +(define-vop (<0/single-float float-test) + (:translate <) + (:args (x :scs (single-reg))) + (:arg-types single-float (:constant (single-float 0f0 0f0))) + (:variant #x01)) +(define-vop (<0/double-float float-test) + (:translate <) + (:args (x :scs (double-reg))) + (:arg-types double-float (:constant (double-float 0d0 0d0))) + (:variant #x01)) +#!+long-float +(define-vop (<0/long-float float-test) + (:translate <) + (:args (x :scs (long-reg))) + (:arg-types long-float (:constant (long-float 0l0 0l0))) + (:variant #x01)) + +(define-vop (>0/single-float float-test) + (:translate >) + (:args (x :scs (single-reg))) + (:arg-types single-float (:constant (single-float 0f0 0f0))) + (:variant #x00)) +(define-vop (>0/double-float float-test) + (:translate >) + (:args (x :scs (double-reg))) + (:arg-types double-float (:constant (double-float 0d0 0d0))) + (:variant #x00)) +#!+long-float +(define-vop (>0/long-float float-test) + (:translate >) + (:args (x :scs (long-reg))) + (:arg-types long-float (:constant (long-float 0l0 0l0))) + (:variant #x00)) + +#!+long-float +(deftransform eql ((x y) (long-float long-float)) + `(and (= (long-float-low-bits x) (long-float-low-bits y)) + (= (long-float-high-bits x) (long-float-high-bits y)) + (= (long-float-exp-bits x) (long-float-exp-bits y)))) + +;;;; conversion + +(macrolet ((frob (name translate to-sc to-type) + `(define-vop (,name) + (:args (x :scs (signed-stack signed-reg) :target temp)) + (:temporary (:sc signed-stack) temp) + (:results (y :scs (,to-sc))) + (:arg-types signed-num) + (:result-types ,to-type) + (:policy :fast-safe) + (:note "inline float coercion") + (:translate ,translate) + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (sc-case x + (signed-reg + (inst mov temp x) + (with-empty-tn@fp-top(y) + (note-this-location vop :internal-error) + (inst fild temp))) + (signed-stack + (with-empty-tn@fp-top(y) + (note-this-location vop :internal-error) + (inst fild x)))))))) + (frob %single-float/signed %single-float single-reg single-float) + (frob %double-float/signed %double-float double-reg double-float) + #!+long-float + (frob %long-float/signed %long-float long-reg long-float)) + +(macrolet ((frob (name translate to-sc to-type) + `(define-vop (,name) + (:args (x :scs (unsigned-reg))) + (:results (y :scs (,to-sc))) + (:arg-types unsigned-num) + (:result-types ,to-type) + (:policy :fast-safe) + (:note "inline float coercion") + (:translate ,translate) + (:vop-var vop) + (:save-p :compute-only) + (:generator 6 + (inst push 0) + (inst push x) + (with-empty-tn@fp-top(y) + (note-this-location vop :internal-error) + (inst fildl (make-ea :dword :base esp-tn))) + (inst add esp-tn 8))))) + (frob %single-float/unsigned %single-float single-reg single-float) + (frob %double-float/unsigned %double-float double-reg double-float) + #!+long-float + (frob %long-float/unsigned %long-float long-reg long-float)) + +;;; These should be no-ops but the compiler might want to move some +;;; things around. +(macrolet ((frob (name translate from-sc from-type to-sc to-type) + `(define-vop (,name) + (:args (x :scs (,from-sc) :target y)) + (:results (y :scs (,to-sc))) + (:arg-types ,from-type) + (:result-types ,to-type) + (:policy :fast-safe) + (:note "inline float coercion") + (:translate ,translate) + (:vop-var vop) + (:save-p :compute-only) + (:generator 2 + (note-this-location vop :internal-error) + (unless (location= x y) + (cond + ((zerop (tn-offset x)) + ;; x is in ST0, y is in another reg. not ST0 + (inst fst y)) + ((zerop (tn-offset y)) + ;; y is in ST0, x is in another reg. not ST0 + (copy-fp-reg-to-fr0 x)) + (t + ;; Neither x or y are in ST0, and they are not in + ;; the same reg. + (inst fxch x) + (inst fst y) + (inst fxch x)))))))) + + (frob %single-float/double-float %single-float double-reg + double-float single-reg single-float) + #!+long-float + (frob %single-float/long-float %single-float long-reg + long-float single-reg single-float) + (frob %double-float/single-float %double-float single-reg single-float + double-reg double-float) + #!+long-float + (frob %double-float/long-float %double-float long-reg long-float + double-reg double-float) + #!+long-float + (frob %long-float/single-float %long-float single-reg single-float + long-reg long-float) + #!+long-float + (frob %long-float/double-float %long-float double-reg double-float + long-reg long-float)) + +(macrolet ((frob (trans from-sc from-type round-p) + `(define-vop (,(symbolicate trans "/" from-type)) + (:args (x :scs (,from-sc))) + (:temporary (:sc signed-stack) stack-temp) + ,@(unless round-p + '((:temporary (:sc unsigned-stack) scw) + (:temporary (:sc any-reg) rcw))) + (:results (y :scs (signed-reg))) + (:arg-types ,from-type) + (:result-types signed-num) + (:translate ,trans) + (:policy :fast-safe) + (:note "inline float truncate") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + ,@(unless round-p + '((note-this-location vop :internal-error) + ;; Catch any pending FPE exceptions. + (inst wait))) + (,(if round-p 'progn 'pseudo-atomic) + ;; Normal mode (for now) is "round to best". + (with-tn@fp-top (x) + ,@(unless round-p + '((inst fnstcw scw) ; save current control word + (move rcw scw) ; into 16-bit register + (inst or rcw (ash #b11 10)) ; CHOP + (move stack-temp rcw) + (inst fldcw stack-temp))) + (sc-case y + (signed-stack + (inst fist y)) + (signed-reg + (inst fist stack-temp) + (inst mov y stack-temp))) + ,@(unless round-p + '((inst fldcw scw))))))))) + (frob %unary-truncate single-reg single-float nil) + (frob %unary-truncate double-reg double-float nil) + #!+long-float + (frob %unary-truncate long-reg long-float nil) + (frob %unary-round single-reg single-float t) + (frob %unary-round double-reg double-float t) + #!+long-float + (frob %unary-round long-reg long-float t)) + +(macrolet ((frob (trans from-sc from-type round-p) + `(define-vop (,(symbolicate trans "/" from-type "=>UNSIGNED")) + (:args (x :scs (,from-sc) :target fr0)) + (:temporary (:sc double-reg :offset fr0-offset + :from :argument :to :result) fr0) + ,@(unless round-p + '((:temporary (:sc unsigned-stack) stack-temp) + (:temporary (:sc unsigned-stack) scw) + (:temporary (:sc any-reg) rcw))) + (:results (y :scs (unsigned-reg))) + (:arg-types ,from-type) + (:result-types unsigned-num) + (:translate ,trans) + (:policy :fast-safe) + (:note "inline float truncate") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + ,@(unless round-p + '((note-this-location vop :internal-error) + ;; Catch any pending FPE exceptions. + (inst wait))) + ;; Normal mode (for now) is "round to best". + (unless (zerop (tn-offset x)) + (copy-fp-reg-to-fr0 x)) + ,@(unless round-p + '((inst fnstcw scw) ; save current control word + (move rcw scw) ; into 16-bit register + (inst or rcw (ash #b11 10)) ; CHOP + (move stack-temp rcw) + (inst fldcw stack-temp))) + (inst sub esp-tn 8) + (inst fistpl (make-ea :dword :base esp-tn)) + (inst pop y) + (inst fld fr0) ; copy fr0 to at least restore stack. + (inst add esp-tn 4) + ,@(unless round-p + '((inst fldcw scw))))))) + (frob %unary-truncate single-reg single-float nil) + (frob %unary-truncate double-reg double-float nil) + #!+long-float + (frob %unary-truncate long-reg long-float nil) + (frob %unary-round single-reg single-float t) + (frob %unary-round double-reg double-float t) + #!+long-float + (frob %unary-round long-reg long-float t)) + +(define-vop (make-single-float) + (:args (bits :scs (signed-reg) :target res + :load-if (not (or (and (sc-is bits signed-stack) + (sc-is res single-reg)) + (and (sc-is bits signed-stack) + (sc-is res single-stack) + (location= bits res)))))) + (:results (res :scs (single-reg single-stack))) + (:temporary (:sc signed-stack) stack-temp) + (:arg-types signed-num) + (:result-types single-float) + (:translate make-single-float) + (:policy :fast-safe) + (:vop-var vop) + (:generator 4 + (sc-case res + (single-stack + (sc-case bits + (signed-reg + (inst mov res bits)) + (signed-stack + (aver (location= bits res))))) + (single-reg + (sc-case bits + (signed-reg + ;; source must be in memory + (inst mov stack-temp bits) + (with-empty-tn@fp-top(res) + (inst fld stack-temp))) + (signed-stack + (with-empty-tn@fp-top(res) + (inst fld bits)))))))) + +(define-vop (make-double-float) + (:args (hi-bits :scs (signed-reg)) + (lo-bits :scs (unsigned-reg))) + (:results (res :scs (double-reg))) + (:temporary (:sc double-stack) temp) + (:arg-types signed-num unsigned-num) + (:result-types double-float) + (:translate make-double-float) + (:policy :fast-safe) + (:vop-var vop) + (:generator 2 + (let ((offset (tn-offset temp))) + (storew hi-bits ebp-tn (frame-word-offset offset)) + (storew lo-bits ebp-tn (frame-word-offset (1+ offset))) + (with-empty-tn@fp-top(res) + (inst fldd (make-ea :dword :base ebp-tn + :disp (frame-byte-offset (1+ offset)))))))) + +#!+long-float +(define-vop (make-long-float) + (:args (exp-bits :scs (signed-reg)) + (hi-bits :scs (unsigned-reg)) + (lo-bits :scs (unsigned-reg))) + (:results (res :scs (long-reg))) + (:temporary (:sc long-stack) temp) + (:arg-types signed-num unsigned-num unsigned-num) + (:result-types long-float) + (:translate make-long-float) + (:policy :fast-safe) + (:vop-var vop) + (:generator 3 + (let ((offset (tn-offset temp))) + (storew exp-bits ebp-tn (frame-word-offset offset)) + (storew hi-bits ebp-tn (frame-word-offset (1+ offset))) + (storew lo-bits ebp-tn (frame-word-offset (+ offset 2))) + (with-empty-tn@fp-top(res) + (inst fldl (make-ea :dword :base ebp-tn + :disp (frame-byte-offset (+ offset 2)))))))) + +(define-vop (single-float-bits) + (:args (float :scs (single-reg descriptor-reg) + :load-if (not (sc-is float single-stack)))) + (:results (bits :scs (signed-reg))) + (:temporary (:sc signed-stack :from :argument :to :result) stack-temp) + (:arg-types single-float) + (:result-types signed-num) + (:translate single-float-bits) + (:policy :fast-safe) + (:vop-var vop) + (:generator 4 + (sc-case bits + (signed-reg + (sc-case float + (single-reg + (with-tn@fp-top(float) + (inst fst stack-temp) + (inst mov bits stack-temp))) + (single-stack + (inst mov bits float)) + (descriptor-reg + (loadw + bits float single-float-value-slot + other-pointer-lowtag)))) + (signed-stack + (sc-case float + (single-reg + (with-tn@fp-top(float) + (inst fst bits)))))))) + +(define-vop (double-float-high-bits) + (:args (float :scs (double-reg descriptor-reg) + :load-if (not (sc-is float double-stack)))) + (:results (hi-bits :scs (signed-reg))) + (:temporary (:sc double-stack) temp) + (:arg-types double-float) + (:result-types signed-num) + (:translate double-float-high-bits) + (:policy :fast-safe) + (:vop-var vop) + (:generator 5 + (sc-case float + (double-reg + (with-tn@fp-top(float) + (let ((where (make-ea :dword :base ebp-tn + :disp (frame-byte-offset (1+ (tn-offset temp)))))) + (inst fstd where))) + (loadw hi-bits ebp-tn (frame-word-offset (tn-offset temp)))) + (double-stack + (loadw hi-bits ebp-tn (frame-word-offset (tn-offset float)))) + (descriptor-reg + (loadw hi-bits float (1+ double-float-value-slot) + other-pointer-lowtag))))) + +(define-vop (double-float-low-bits) + (:args (float :scs (double-reg descriptor-reg) + :load-if (not (sc-is float double-stack)))) + (:results (lo-bits :scs (unsigned-reg))) + (:temporary (:sc double-stack) temp) + (:arg-types double-float) + (:result-types unsigned-num) + (:translate double-float-low-bits) + (:policy :fast-safe) + (:vop-var vop) + (:generator 5 + (sc-case float + (double-reg + (with-tn@fp-top(float) + (let ((where (make-ea :dword :base ebp-tn + :disp (frame-byte-offset (1+ (tn-offset temp)))))) + (inst fstd where))) + (loadw lo-bits ebp-tn (frame-word-offset (1+ (tn-offset temp))))) + (double-stack + (loadw lo-bits ebp-tn (frame-word-offset (1+ (tn-offset float))))) + (descriptor-reg + (loadw lo-bits float double-float-value-slot + other-pointer-lowtag))))) + +#!+long-float +(define-vop (long-float-exp-bits) + (:args (float :scs (long-reg descriptor-reg) + :load-if (not (sc-is float long-stack)))) + (:results (exp-bits :scs (signed-reg))) + (:temporary (:sc long-stack) temp) + (:arg-types long-float) + (:result-types signed-num) + (:translate long-float-exp-bits) + (:policy :fast-safe) + (:vop-var vop) + (:generator 5 + (sc-case float + (long-reg + (with-tn@fp-top(float) + (let ((where (make-ea :dword :base ebp-tn + :disp (frame-byte-offset (+ 2 (tn-offset temp)))))) + (store-long-float where))) + (inst movsx exp-bits + (make-ea :word :base ebp-tn + :disp (frame-byte-offset (tn-offset temp))))) + (long-stack + (inst movsx exp-bits + (make-ea :word :base ebp-tn + :disp (frame-byte-offset (tn-offset temp))))) + (descriptor-reg + (inst movsx exp-bits + (make-ea-for-object-slot float (+ 2 long-float-value-slot) + other-pointer-lowtag :word)))))) + +#!+long-float +(define-vop (long-float-high-bits) + (:args (float :scs (long-reg descriptor-reg) + :load-if (not (sc-is float long-stack)))) + (:results (hi-bits :scs (unsigned-reg))) + (:temporary (:sc long-stack) temp) + (:arg-types long-float) + (:result-types unsigned-num) + (:translate long-float-high-bits) + (:policy :fast-safe) + (:vop-var vop) + (:generator 5 + (sc-case float + (long-reg + (with-tn@fp-top(float) + (let ((where (make-ea :dword :base ebp-tn + :disp (frame-byte-offset (+ 2 (tn-offset temp)))))) + (store-long-float where))) + (loadw hi-bits ebp-tn (frame-word-offset (1+ (tn-offset temp))))) + (long-stack + (loadw hi-bits ebp-tn (frame-word-offset (1+ (tn-offset temp))))) + (descriptor-reg + (loadw hi-bits float (1+ long-float-value-slot) + other-pointer-lowtag))))) + +#!+long-float +(define-vop (long-float-low-bits) + (:args (float :scs (long-reg descriptor-reg) + :load-if (not (sc-is float long-stack)))) + (:results (lo-bits :scs (unsigned-reg))) + (:temporary (:sc long-stack) temp) + (:arg-types long-float) + (:result-types unsigned-num) + (:translate long-float-low-bits) + (:policy :fast-safe) + (:vop-var vop) + (:generator 5 + (sc-case float + (long-reg + (with-tn@fp-top(float) + (let ((where (make-ea :dword :base ebp-tn + :disp (frame-byte-offset (+ 2 (tn-offset temp)))))) + (store-long-float where))) + (loadw lo-bits ebp-tn (frame-word-offset (+ (tn-offset temp) 2)))) + (long-stack + (loadw lo-bits ebp-tn (frame-word-offset (+ (tn-offset float) 2)))) + (descriptor-reg + (loadw lo-bits float long-float-value-slot + other-pointer-lowtag))))) + +;;;; float mode hackery + +(sb!xc:deftype float-modes () '(unsigned-byte 32)) ; really only 16 +(defknown floating-point-modes () float-modes (flushable)) +(defknown ((setf floating-point-modes)) (float-modes) + float-modes) + +(def!constant npx-env-size (* 7 n-word-bytes)) +(def!constant npx-cw-offset 0) +(def!constant npx-sw-offset 4) + +(define-vop (floating-point-modes) + (:results (res :scs (unsigned-reg))) + (:result-types unsigned-num) + (:translate floating-point-modes) + (:policy :fast-safe) + (:temporary (:sc unsigned-reg :offset eax-offset :target res + :to :result) eax) + (:generator 8 + (inst sub esp-tn npx-env-size) ; Make space on stack. + (inst wait) ; Catch any pending FPE exceptions + (inst fstenv (make-ea :dword :base esp-tn)) ; masks all exceptions + (inst fldenv (make-ea :dword :base esp-tn)) ; Restore previous state. + ;; Move current status to high word. + (inst mov eax (make-ea :dword :base esp-tn :disp (- npx-sw-offset 2))) + ;; Move exception mask to low word. + (inst mov ax-tn (make-ea :word :base esp-tn :disp npx-cw-offset)) + (inst add esp-tn npx-env-size) ; Pop stack. + (inst xor eax #x3f) ; Flip exception mask to trap enable bits. + (move res eax))) + +(define-vop (set-floating-point-modes) + (:args (new :scs (unsigned-reg) :to :result :target res)) + (:results (res :scs (unsigned-reg))) + (:arg-types unsigned-num) + (:result-types unsigned-num) + (:translate (setf floating-point-modes)) + (:policy :fast-safe) + (:temporary (:sc unsigned-reg :offset eax-offset + :from :eval :to :result) eax) + (:generator 3 + (inst sub esp-tn npx-env-size) ; Make space on stack. + (inst wait) ; Catch any pending FPE exceptions. + (inst fstenv (make-ea :dword :base esp-tn)) + (inst mov eax new) + (inst xor eax #x3f) ; Turn trap enable bits into exception mask. + (inst mov (make-ea :word :base esp-tn :disp npx-cw-offset) ax-tn) + (inst shr eax 16) ; position status word + (inst mov (make-ea :word :base esp-tn :disp npx-sw-offset) ax-tn) + (inst fldenv (make-ea :dword :base esp-tn)) + (inst add esp-tn npx-env-size) ; Pop stack. + (move res new))) + +#!-long-float +(progn + +;;; Let's use some of the 80387 special functions. +;;; +;;; These defs will not take effect unless code/irrat.lisp is modified +;;; to remove the inlined alien routine def. + +(macrolet ((frob (func trans op) + `(define-vop (,func) + (:args (x :scs (double-reg) :target fr0)) + (:temporary (:sc double-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:ignore fr0) + (:results (y :scs (double-reg))) + (:arg-types double-float) + (:result-types double-float) + (:translate ,trans) + (:policy :fast-safe) + (:note "inline NPX function") + (:vop-var vop) + (:save-p :compute-only) + (:node-var node) + (:generator 5 + (note-this-location vop :internal-error) + (unless (zerop (tn-offset x)) + (inst fxch x) ; x to top of stack + (unless (location= x y) + (inst fst x))) ; maybe save it + (inst ,op) ; clobber st0 + (cond ((zerop (tn-offset y)) + (maybe-fp-wait node)) + (t + (inst fst y))))))) + + ;; Quick versions of fsin and fcos that require the argument to be + ;; within range 2^63. + (frob fsin-quick %sin-quick fsin) + (frob fcos-quick %cos-quick fcos) + (frob fsqrt %sqrt fsqrt)) + +;;; Quick version of ftan that requires the argument to be within +;;; range 2^63. +(define-vop (ftan-quick) + (:translate %tan-quick) + (:args (x :scs (double-reg) :target fr0)) + (:temporary (:sc double-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc double-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:results (y :scs (double-reg))) + (:arg-types double-float) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline tan function") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + (case (tn-offset x) + (0 + (inst fstp fr1)) + (1 + (inst fstp fr0)) + (t + (inst fstp fr0) + (inst fstp fr0) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset x) 2))))) + (inst fptan) + ;; Result is in fr1 + (case (tn-offset y) + (0 + (inst fxch fr1)) + (1) + (t + (inst fxch fr1) + (inst fstd y))))) + +;;; KLUDGE: these versions of fsin, fcos, and ftan simply load a 0.0 +;;; result if the argument is out of range 2^63 and would thus be +;;; hopelessly inaccurate. +(macrolet ((frob (func trans op) + `(define-vop (,func) + (:translate ,trans) + (:args (x :scs (double-reg) :target fr0)) + (:temporary (:sc double-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc unsigned-reg :offset eax-offset + :from :argument :to :result) eax) + (:results (y :scs (double-reg))) + (:arg-types double-float) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline sin/cos function") + (:vop-var vop) + (:save-p :compute-only) + (:ignore eax) + (:generator 5 + (note-this-location vop :internal-error) + (unless (zerop (tn-offset x)) + (inst fxch x) ; x to top of stack + (unless (location= x y) + (inst fst x))) ; maybe save it + (inst ,op) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x04) ; C2 + (inst jmp :z DONE) + ;; Else x was out of range so reduce it; ST0 is unchanged. + (inst fstp fr0) ; Load 0.0 + (inst fldz) + DONE + (unless (zerop (tn-offset y)) + (inst fstd y)))))) + (frob fsin %sin fsin) + (frob fcos %cos fcos)) + +(define-vop (ftan) + (:translate %tan) + (:args (x :scs (double-reg) :target fr0)) + (:temporary (:sc double-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc double-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:temporary (:sc unsigned-reg :offset eax-offset + :from :argument :to :result) eax) + (:results (y :scs (double-reg))) + (:arg-types double-float) + (:result-types double-float) + (:ignore eax) + (:policy :fast-safe) + (:note "inline tan function") + (:vop-var vop) + (:save-p :compute-only) + (:ignore eax) + (:generator 5 + (note-this-location vop :internal-error) + (case (tn-offset x) + (0 + (inst fstp fr1)) + (1 + (inst fstp fr0)) + (t + (inst fstp fr0) + (inst fstp fr0) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset x) 2))))) + (inst fptan) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x04) ; C2 + (inst jmp :z DONE) + ;; Else x was out of range so load 0.0 + (inst fxch fr1) + DONE + ;; Result is in fr1 + (case (tn-offset y) + (0 + (inst fxch fr1)) + (1) + (t + (inst fxch fr1) + (inst fstd y))))) + +;;; %exp that handles the following special cases: exp(+Inf) is +Inf; +;;; exp(-Inf) is 0; exp(NaN) is NaN. +(define-vop (fexp) + (:translate %exp) + (:args (x :scs (double-reg) :target fr0)) + (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp) + (:temporary (:sc double-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc double-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:temporary (:sc double-reg :offset fr2-offset + :from :argument :to :result) fr2) + (:results (y :scs (double-reg))) + (:arg-types double-float) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline exp function") + (:vop-var vop) + (:save-p :compute-only) + (:ignore temp) + (:generator 5 + (note-this-location vop :internal-error) + (unless (zerop (tn-offset x)) + (inst fxch x) ; x to top of stack + (unless (location= x y) + (inst fst x))) ; maybe save it + ;; Check for Inf or NaN + (inst fxam) + (inst fnstsw) + (inst sahf) + (inst jmp :nc NOINFNAN) ; Neither Inf or NaN. + (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue. + (inst and ah-tn #x02) ; Test sign of Inf. + (inst jmp :z DONE) ; +Inf gives +Inf. + (inst fstp fr0) ; -Inf gives 0 + (inst fldz) + (inst jmp-short DONE) + NOINFNAN + (inst fstp fr1) + (inst fldl2e) + (inst fmul fr1) + ;; Now fr0=x log2(e) + (inst fst fr1) + (inst frndint) + (inst fst fr2) + (inst fsubp-sti fr1) + (inst f2xm1) + (inst fld1) + (inst faddp-sti fr1) + (inst fscale) + (inst fld fr0) + DONE + (unless (zerop (tn-offset y)) + (inst fstd y)))) + +;;; Expm1 = exp(x) - 1. +;;; Handles the following special cases: +;;; expm1(+Inf) is +Inf; expm1(-Inf) is -1.0; expm1(NaN) is NaN. +(define-vop (fexpm1) + (:translate %expm1) + (:args (x :scs (double-reg) :target fr0)) + (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp) + (:temporary (:sc double-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc double-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:temporary (:sc double-reg :offset fr2-offset + :from :argument :to :result) fr2) + (:results (y :scs (double-reg))) + (:arg-types double-float) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline expm1 function") + (:vop-var vop) + (:save-p :compute-only) + (:ignore temp) + (:generator 5 + (note-this-location vop :internal-error) + (unless (zerop (tn-offset x)) + (inst fxch x) ; x to top of stack + (unless (location= x y) + (inst fst x))) ; maybe save it + ;; Check for Inf or NaN + (inst fxam) + (inst fnstsw) + (inst sahf) + (inst jmp :nc NOINFNAN) ; Neither Inf or NaN. + (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue. + (inst and ah-tn #x02) ; Test sign of Inf. + (inst jmp :z DONE) ; +Inf gives +Inf. + (inst fstp fr0) ; -Inf gives -1.0 + (inst fld1) + (inst fchs) + (inst jmp-short DONE) + NOINFNAN + ;; Free two stack slots leaving the argument on top. + (inst fstp fr2) + (inst fstp fr0) + (inst fldl2e) + (inst fmul fr1) ; Now fr0 = x log2(e) + (inst fst fr1) + (inst frndint) + (inst fsub-sti fr1) + (inst fxch fr1) + (inst f2xm1) + (inst fscale) + (inst fxch fr1) + (inst fld1) + (inst fscale) + (inst fstp fr1) + (inst fld1) + (inst fsub fr1) + (inst fsubr fr2) + DONE + (unless (zerop (tn-offset y)) + (inst fstd y)))) + +(define-vop (flog) + (:translate %log) + (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)) + (:temporary (:sc double-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc double-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:results (y :scs (double-reg))) + (:arg-types double-float) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline log function") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + (sc-case x + (double-reg + (case (tn-offset x) + (0 + ;; x is in fr0 + (inst fstp fr1) + (inst fldln2) + (inst fxch fr1)) + (1 + ;; x is in fr1 + (inst fstp fr0) + (inst fldln2) + (inst fxch fr1)) + (t + ;; x is in a FP reg, not fr0 or fr1 + (inst fstp fr0) + (inst fstp fr0) + (inst fldln2) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset x)))))) + (inst fyl2x)) + ((double-stack descriptor-reg) + (inst fstp fr0) + (inst fstp fr0) + (inst fldln2) + (if (sc-is x double-stack) + (inst fldd (ea-for-df-stack x)) + (inst fldd (ea-for-df-desc x))) + (inst fyl2x))) + (inst fld fr0) + (case (tn-offset y) + ((0 1)) + (t (inst fstd y))))) + +(define-vop (flog10) + (:translate %log10) + (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)) + (:temporary (:sc double-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc double-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:results (y :scs (double-reg))) + (:arg-types double-float) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline log10 function") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + (sc-case x + (double-reg + (case (tn-offset x) + (0 + ;; x is in fr0 + (inst fstp fr1) + (inst fldlg2) + (inst fxch fr1)) + (1 + ;; x is in fr1 + (inst fstp fr0) + (inst fldlg2) + (inst fxch fr1)) + (t + ;; x is in a FP reg, not fr0 or fr1 + (inst fstp fr0) + (inst fstp fr0) + (inst fldlg2) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset x)))))) + (inst fyl2x)) + ((double-stack descriptor-reg) + (inst fstp fr0) + (inst fstp fr0) + (inst fldlg2) + (if (sc-is x double-stack) + (inst fldd (ea-for-df-stack x)) + (inst fldd (ea-for-df-desc x))) + (inst fyl2x))) + (inst fld fr0) + (case (tn-offset y) + ((0 1)) + (t (inst fstd y))))) + +(define-vop (fpow) + (:translate %pow) + (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0) + (y :scs (double-reg double-stack descriptor-reg) :target fr1)) + (:temporary (:sc double-reg :offset fr0-offset + :from (:argument 0) :to :result) fr0) + (:temporary (:sc double-reg :offset fr1-offset + :from (:argument 1) :to :result) fr1) + (:temporary (:sc double-reg :offset fr2-offset + :from :load :to :result) fr2) + (:results (r :scs (double-reg))) + (:arg-types double-float double-float) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline pow function") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + ;; Setup x in fr0 and y in fr1 + (cond + ;; x in fr0; y in fr1 + ((and (sc-is x double-reg) (zerop (tn-offset x)) + (sc-is y double-reg) (= 1 (tn-offset y)))) + ;; y in fr1; x not in fr0 + ((and (sc-is y double-reg) (= 1 (tn-offset y))) + ;; Load x to fr0 + (sc-case x + (double-reg + (copy-fp-reg-to-fr0 x)) + (double-stack + (inst fstp fr0) + (inst fldd (ea-for-df-stack x))) + (descriptor-reg + (inst fstp fr0) + (inst fldd (ea-for-df-desc x))))) + ;; x in fr0; y not in fr1 + ((and (sc-is x double-reg) (zerop (tn-offset x))) + (inst fxch fr1) + ;; Now load y to fr0 + (sc-case y + (double-reg + (copy-fp-reg-to-fr0 y)) + (double-stack + (inst fstp fr0) + (inst fldd (ea-for-df-stack y))) + (descriptor-reg + (inst fstp fr0) + (inst fldd (ea-for-df-desc y)))) + (inst fxch fr1)) + ;; x in fr1; y not in fr1 + ((and (sc-is x double-reg) (= 1 (tn-offset x))) + ;; Load y to fr0 + (sc-case y + (double-reg + (copy-fp-reg-to-fr0 y)) + (double-stack + (inst fstp fr0) + (inst fldd (ea-for-df-stack y))) + (descriptor-reg + (inst fstp fr0) + (inst fldd (ea-for-df-desc y)))) + (inst fxch fr1)) + ;; y in fr0; + ((and (sc-is y double-reg) (zerop (tn-offset y))) + (inst fxch fr1) + ;; Now load x to fr0 + (sc-case x + (double-reg + (copy-fp-reg-to-fr0 x)) + (double-stack + (inst fstp fr0) + (inst fldd (ea-for-df-stack x))) + (descriptor-reg + (inst fstp fr0) + (inst fldd (ea-for-df-desc x))))) + ;; Neither x or y are in either fr0 or fr1 + (t + ;; Load y then x + (inst fstp fr0) + (inst fstp fr0) + (sc-case y + (double-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset y) 2)))) + (double-stack + (inst fldd (ea-for-df-stack y))) + (descriptor-reg + (inst fldd (ea-for-df-desc y)))) + ;; Load x to fr0 + (sc-case x + (double-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset x))))) + (double-stack + (inst fldd (ea-for-df-stack x))) + (descriptor-reg + (inst fldd (ea-for-df-desc x)))))) + + ;; Now have x at fr0; and y at fr1 + (inst fyl2x) + ;; Now fr0=y log2(x) + (inst fld fr0) + (inst frndint) + (inst fst fr2) + (inst fsubp-sti fr1) + (inst f2xm1) + (inst fld1) + (inst faddp-sti fr1) + (inst fscale) + (inst fld fr0) + (case (tn-offset r) + ((0 1)) + (t (inst fstd r))))) + +(define-vop (fscalen) + (:translate %scalbn) + (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0) + (y :scs (signed-stack signed-reg) :target temp)) + (:temporary (:sc double-reg :offset fr0-offset + :from (:argument 0) :to :result) fr0) + (:temporary (:sc double-reg :offset fr1-offset :from :eval :to :result) fr1) + (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp) + (:results (r :scs (double-reg))) + (:arg-types double-float signed-num) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline scalbn function") + (:generator 5 + ;; Setup x in fr0 and y in fr1 + (sc-case x + (double-reg + (case (tn-offset x) + (0 + (inst fstp fr1) + (sc-case y + (signed-reg + (inst mov temp y) + (inst fild temp)) + (signed-stack + (inst fild y))) + (inst fxch fr1)) + (1 + (inst fstp fr0) + (sc-case y + (signed-reg + (inst mov temp y) + (inst fild temp)) + (signed-stack + (inst fild y))) + (inst fxch fr1)) + (t + (inst fstp fr0) + (inst fstp fr0) + (sc-case y + (signed-reg + (inst mov temp y) + (inst fild temp)) + (signed-stack + (inst fild y))) + (inst fld (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset x))))))) + ((double-stack descriptor-reg) + (inst fstp fr0) + (inst fstp fr0) + (sc-case y + (signed-reg + (inst mov temp y) + (inst fild temp)) + (signed-stack + (inst fild y))) + (if (sc-is x double-stack) + (inst fldd (ea-for-df-stack x)) + (inst fldd (ea-for-df-desc x))))) + (inst fscale) + (unless (zerop (tn-offset r)) + (inst fstd r)))) + +(define-vop (fscale) + (:translate %scalb) + (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0) + (y :scs (double-reg double-stack descriptor-reg) :target fr1)) + (:temporary (:sc double-reg :offset fr0-offset + :from (:argument 0) :to :result) fr0) + (:temporary (:sc double-reg :offset fr1-offset + :from (:argument 1) :to :result) fr1) + (:results (r :scs (double-reg))) + (:arg-types double-float double-float) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline scalb function") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + ;; Setup x in fr0 and y in fr1 + (cond + ;; x in fr0; y in fr1 + ((and (sc-is x double-reg) (zerop (tn-offset x)) + (sc-is y double-reg) (= 1 (tn-offset y)))) + ;; y in fr1; x not in fr0 + ((and (sc-is y double-reg) (= 1 (tn-offset y))) + ;; Load x to fr0 + (sc-case x + (double-reg + (copy-fp-reg-to-fr0 x)) + (double-stack + (inst fstp fr0) + (inst fldd (ea-for-df-stack x))) + (descriptor-reg + (inst fstp fr0) + (inst fldd (ea-for-df-desc x))))) + ;; x in fr0; y not in fr1 + ((and (sc-is x double-reg) (zerop (tn-offset x))) + (inst fxch fr1) + ;; Now load y to fr0 + (sc-case y + (double-reg + (copy-fp-reg-to-fr0 y)) + (double-stack + (inst fstp fr0) + (inst fldd (ea-for-df-stack y))) + (descriptor-reg + (inst fstp fr0) + (inst fldd (ea-for-df-desc y)))) + (inst fxch fr1)) + ;; x in fr1; y not in fr1 + ((and (sc-is x double-reg) (= 1 (tn-offset x))) + ;; Load y to fr0 + (sc-case y + (double-reg + (copy-fp-reg-to-fr0 y)) + (double-stack + (inst fstp fr0) + (inst fldd (ea-for-df-stack y))) + (descriptor-reg + (inst fstp fr0) + (inst fldd (ea-for-df-desc y)))) + (inst fxch fr1)) + ;; y in fr0; + ((and (sc-is y double-reg) (zerop (tn-offset y))) + (inst fxch fr1) + ;; Now load x to fr0 + (sc-case x + (double-reg + (copy-fp-reg-to-fr0 x)) + (double-stack + (inst fstp fr0) + (inst fldd (ea-for-df-stack x))) + (descriptor-reg + (inst fstp fr0) + (inst fldd (ea-for-df-desc x))))) + ;; Neither x or y are in either fr0 or fr1 + (t + ;; Load y then x + (inst fstp fr0) + (inst fstp fr0) + (sc-case y + (double-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset y) 2)))) + (double-stack + (inst fldd (ea-for-df-stack y))) + (descriptor-reg + (inst fldd (ea-for-df-desc y)))) + ;; Load x to fr0 + (sc-case x + (double-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset x))))) + (double-stack + (inst fldd (ea-for-df-stack x))) + (descriptor-reg + (inst fldd (ea-for-df-desc x)))))) + + ;; Now have x at fr0; and y at fr1 + (inst fscale) + (unless (zerop (tn-offset r)) + (inst fstd r)))) + +(define-vop (flog1p) + (:translate %log1p) + (:args (x :scs (double-reg) :to :result)) + (:temporary (:sc double-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc double-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:temporary (:sc word-reg :offset eax-offset :from :eval) temp) + (:results (y :scs (double-reg))) + (:arg-types double-float) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline log1p function") + (:ignore temp) + (:generator 5 + ;; x is in a FP reg, not fr0, fr1. + (inst fstp fr0) + (inst fstp fr0) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset x) 2))) + ;; Check the range + (inst push #x3e947ae1) ; Constant 0.29 + (inst fabs) + (inst fld (make-ea :dword :base esp-tn)) + (inst fcompp) + (inst add esp-tn 4) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x45) + (inst jmp :z WITHIN-RANGE) + ;; Out of range for fyl2xp1. + (inst fld1) + (inst faddd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset x) 1))) + (inst fldln2) + (inst fxch fr1) + (inst fyl2x) + (inst jmp DONE) + + WITHIN-RANGE + (inst fldln2) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset x) 1))) + (inst fyl2xp1) + DONE + (inst fld fr0) + (case (tn-offset y) + ((0 1)) + (t (inst fstd y))))) + +;;; The Pentium has a less restricted implementation of the fyl2xp1 +;;; instruction and a range check can be avoided. +(define-vop (flog1p-pentium) + (:translate %log1p) + (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)) + (:temporary (:sc double-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc double-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:results (y :scs (double-reg))) + (:arg-types double-float) + (:result-types double-float) + (:policy :fast-safe) + (:guard (member :pentium-style-fyl2xp1 *backend-subfeatures*)) + (:note "inline log1p with limited x range function") + (:vop-var vop) + (:save-p :compute-only) + (:generator 4 + (note-this-location vop :internal-error) + (sc-case x + (double-reg + (case (tn-offset x) + (0 + ;; x is in fr0 + (inst fstp fr1) + (inst fldln2) + (inst fxch fr1)) + (1 + ;; x is in fr1 + (inst fstp fr0) + (inst fldln2) + (inst fxch fr1)) + (t + ;; x is in a FP reg, not fr0 or fr1 + (inst fstp fr0) + (inst fstp fr0) + (inst fldln2) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset x))))))) + ((double-stack descriptor-reg) + (inst fstp fr0) + (inst fstp fr0) + (inst fldln2) + (if (sc-is x double-stack) + (inst fldd (ea-for-df-stack x)) + (inst fldd (ea-for-df-desc x))))) + (inst fyl2xp1) + (inst fld fr0) + (case (tn-offset y) + ((0 1)) + (t (inst fstd y))))) + +(define-vop (flogb) + (:translate %logb) + (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)) + (:temporary (:sc double-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc double-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:results (y :scs (double-reg))) + (:arg-types double-float) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline logb function") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + (sc-case x + (double-reg + (case (tn-offset x) + (0 + ;; x is in fr0 + (inst fstp fr1)) + (1 + ;; x is in fr1 + (inst fstp fr0)) + (t + ;; x is in a FP reg, not fr0 or fr1 + (inst fstp fr0) + (inst fstp fr0) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset x) 2)))))) + ((double-stack descriptor-reg) + (inst fstp fr0) + (inst fstp fr0) + (if (sc-is x double-stack) + (inst fldd (ea-for-df-stack x)) + (inst fldd (ea-for-df-desc x))))) + (inst fxtract) + (case (tn-offset y) + (0 + (inst fxch fr1)) + (1) + (t (inst fxch fr1) + (inst fstd y))))) + +(define-vop (fatan) + (:translate %atan) + (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)) + (:temporary (:sc double-reg :offset fr0-offset + :from (:argument 0) :to :result) fr0) + (:temporary (:sc double-reg :offset fr1-offset + :from (:argument 0) :to :result) fr1) + (:results (r :scs (double-reg))) + (:arg-types double-float) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline atan function") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + ;; Setup x in fr1 and 1.0 in fr0 + (cond + ;; x in fr0 + ((and (sc-is x double-reg) (zerop (tn-offset x))) + (inst fstp fr1)) + ;; x in fr1 + ((and (sc-is x double-reg) (= 1 (tn-offset x))) + (inst fstp fr0)) + ;; x not in fr0 or fr1 + (t + ;; Load x then 1.0 + (inst fstp fr0) + (inst fstp fr0) + (sc-case x + (double-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset x) 2)))) + (double-stack + (inst fldd (ea-for-df-stack x))) + (descriptor-reg + (inst fldd (ea-for-df-desc x)))))) + (inst fld1) + ;; Now have x at fr1; and 1.0 at fr0 + (inst fpatan) + (inst fld fr0) + (case (tn-offset r) + ((0 1)) + (t (inst fstd r))))) + +(define-vop (fatan2) + (:translate %atan2) + (:args (x :scs (double-reg double-stack descriptor-reg) :target fr1) + (y :scs (double-reg double-stack descriptor-reg) :target fr0)) + (:temporary (:sc double-reg :offset fr0-offset + :from (:argument 1) :to :result) fr0) + (:temporary (:sc double-reg :offset fr1-offset + :from (:argument 0) :to :result) fr1) + (:results (r :scs (double-reg))) + (:arg-types double-float double-float) + (:result-types double-float) + (:policy :fast-safe) + (:note "inline atan2 function") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + ;; Setup x in fr1 and y in fr0 + (cond + ;; y in fr0; x in fr1 + ((and (sc-is y double-reg) (zerop (tn-offset y)) + (sc-is x double-reg) (= 1 (tn-offset x)))) + ;; x in fr1; y not in fr0 + ((and (sc-is x double-reg) (= 1 (tn-offset x))) + ;; Load y to fr0 + (sc-case y + (double-reg + (copy-fp-reg-to-fr0 y)) + (double-stack + (inst fstp fr0) + (inst fldd (ea-for-df-stack y))) + (descriptor-reg + (inst fstp fr0) + (inst fldd (ea-for-df-desc y))))) + ((and (sc-is x double-reg) (zerop (tn-offset x)) + (sc-is y double-reg) (zerop (tn-offset x))) + ;; copy x to fr1 + (inst fst fr1)) + ;; y in fr0; x not in fr1 + ((and (sc-is y double-reg) (zerop (tn-offset y))) + (inst fxch fr1) + ;; Now load x to fr0 + (sc-case x + (double-reg + (copy-fp-reg-to-fr0 x)) + (double-stack + (inst fstp fr0) + (inst fldd (ea-for-df-stack x))) + (descriptor-reg + (inst fstp fr0) + (inst fldd (ea-for-df-desc x)))) + (inst fxch fr1)) + ;; y in fr1; x not in fr1 + ((and (sc-is y double-reg) (= 1 (tn-offset y))) + ;; Load x to fr0 + (sc-case x + (double-reg + (copy-fp-reg-to-fr0 x)) + (double-stack + (inst fstp fr0) + (inst fldd (ea-for-df-stack x))) + (descriptor-reg + (inst fstp fr0) + (inst fldd (ea-for-df-desc x)))) + (inst fxch fr1)) + ;; x in fr0; + ((and (sc-is x double-reg) (zerop (tn-offset x))) + (inst fxch fr1) + ;; Now load y to fr0 + (sc-case y + (double-reg + (copy-fp-reg-to-fr0 y)) + (double-stack + (inst fstp fr0) + (inst fldd (ea-for-df-stack y))) + (descriptor-reg + (inst fstp fr0) + (inst fldd (ea-for-df-desc y))))) + ;; Neither y or x are in either fr0 or fr1 + (t + ;; Load x then y + (inst fstp fr0) + (inst fstp fr0) + (sc-case x + (double-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset x) 2)))) + (double-stack + (inst fldd (ea-for-df-stack x))) + (descriptor-reg + (inst fldd (ea-for-df-desc x)))) + ;; Load y to fr0 + (sc-case y + (double-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset y))))) + (double-stack + (inst fldd (ea-for-df-stack y))) + (descriptor-reg + (inst fldd (ea-for-df-desc y)))))) + + ;; Now have y at fr0; and x at fr1 + (inst fpatan) + (inst fld fr0) + (case (tn-offset r) + ((0 1)) + (t (inst fstd r))))) +) ; PROGN #!-LONG-FLOAT + +#!+long-float +(progn + +;;; Lets use some of the 80387 special functions. +;;; +;;; These defs will not take effect unless code/irrat.lisp is modified +;;; to remove the inlined alien routine def. + +(macrolet ((frob (func trans op) + `(define-vop (,func) + (:args (x :scs (long-reg) :target fr0)) + (:temporary (:sc long-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:ignore fr0) + (:results (y :scs (long-reg))) + (:arg-types long-float) + (:result-types long-float) + (:translate ,trans) + (:policy :fast-safe) + (:note "inline NPX function") + (:vop-var vop) + (:save-p :compute-only) + (:node-var node) + (:generator 5 + (note-this-location vop :internal-error) + (unless (zerop (tn-offset x)) + (inst fxch x) ; x to top of stack + (unless (location= x y) + (inst fst x))) ; maybe save it + (inst ,op) ; clobber st0 + (cond ((zerop (tn-offset y)) + (maybe-fp-wait node)) + (t + (inst fst y))))))) + + ;; Quick versions of FSIN and FCOS that require the argument to be + ;; within range 2^63. + (frob fsin-quick %sin-quick fsin) + (frob fcos-quick %cos-quick fcos) + (frob fsqrt %sqrt fsqrt)) + +;;; Quick version of ftan that requires the argument to be within +;;; range 2^63. +(define-vop (ftan-quick) + (:translate %tan-quick) + (:args (x :scs (long-reg) :target fr0)) + (:temporary (:sc long-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc long-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:results (y :scs (long-reg))) + (:arg-types long-float) + (:result-types long-float) + (:policy :fast-safe) + (:note "inline tan function") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + (case (tn-offset x) + (0 + (inst fstp fr1)) + (1 + (inst fstp fr0)) + (t + (inst fstp fr0) + (inst fstp fr0) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset x) 2))))) + (inst fptan) + ;; Result is in fr1 + (case (tn-offset y) + (0 + (inst fxch fr1)) + (1) + (t + (inst fxch fr1) + (inst fstd y))))) + +;;; These versions of fsin, fcos, and ftan simply load a 0.0 result if +;;; the argument is out of range 2^63 and would thus be hopelessly +;;; inaccurate. +(macrolet ((frob (func trans op) + `(define-vop (,func) + (:translate ,trans) + (:args (x :scs (long-reg) :target fr0)) + (:temporary (:sc long-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc unsigned-reg :offset eax-offset + :from :argument :to :result) eax) + (:results (y :scs (long-reg))) + (:arg-types long-float) + (:result-types long-float) + (:policy :fast-safe) + (:note "inline sin/cos function") + (:vop-var vop) + (:save-p :compute-only) + (:ignore eax) + (:generator 5 + (note-this-location vop :internal-error) + (unless (zerop (tn-offset x)) + (inst fxch x) ; x to top of stack + (unless (location= x y) + (inst fst x))) ; maybe save it + (inst ,op) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x04) ; C2 + (inst jmp :z DONE) + ;; Else x was out of range so reduce it; ST0 is unchanged. + (inst fstp fr0) ; Load 0.0 + (inst fldz) + DONE + (unless (zerop (tn-offset y)) + (inst fstd y)))))) + (frob fsin %sin fsin) + (frob fcos %cos fcos)) + +(define-vop (ftan) + (:translate %tan) + (:args (x :scs (long-reg) :target fr0)) + (:temporary (:sc long-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc long-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:temporary (:sc unsigned-reg :offset eax-offset + :from :argument :to :result) eax) + (:results (y :scs (long-reg))) + (:arg-types long-float) + (:result-types long-float) + (:ignore eax) + (:policy :fast-safe) + (:note "inline tan function") + (:vop-var vop) + (:save-p :compute-only) + (:ignore eax) + (:generator 5 + (note-this-location vop :internal-error) + (case (tn-offset x) + (0 + (inst fstp fr1)) + (1 + (inst fstp fr0)) + (t + (inst fstp fr0) + (inst fstp fr0) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset x) 2))))) + (inst fptan) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x04) ; C2 + (inst jmp :z DONE) + ;; Else x was out of range so reduce it; ST0 is unchanged. + (inst fldz) ; Load 0.0 + (inst fxch fr1) + DONE + ;; Result is in fr1 + (case (tn-offset y) + (0 + (inst fxch fr1)) + (1) + (t + (inst fxch fr1) + (inst fstd y))))) + +;;; Modified exp that handles the following special cases: +;;; exp(+Inf) is +Inf; exp(-Inf) is 0; exp(NaN) is NaN. +(define-vop (fexp) + (:translate %exp) + (:args (x :scs (long-reg) :target fr0)) + (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp) + (:temporary (:sc long-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc long-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:temporary (:sc long-reg :offset fr2-offset + :from :argument :to :result) fr2) + (:results (y :scs (long-reg))) + (:arg-types long-float) + (:result-types long-float) + (:policy :fast-safe) + (:note "inline exp function") + (:vop-var vop) + (:save-p :compute-only) + (:ignore temp) + (:generator 5 + (note-this-location vop :internal-error) + (unless (zerop (tn-offset x)) + (inst fxch x) ; x to top of stack + (unless (location= x y) + (inst fst x))) ; maybe save it + ;; Check for Inf or NaN + (inst fxam) + (inst fnstsw) + (inst sahf) + (inst jmp :nc NOINFNAN) ; Neither Inf or NaN. + (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue. + (inst and ah-tn #x02) ; Test sign of Inf. + (inst jmp :z DONE) ; +Inf gives +Inf. + (inst fstp fr0) ; -Inf gives 0 + (inst fldz) + (inst jmp-short DONE) + NOINFNAN + (inst fstp fr1) + (inst fldl2e) + (inst fmul fr1) + ;; Now fr0=x log2(e) + (inst fst fr1) + (inst frndint) + (inst fst fr2) + (inst fsubp-sti fr1) + (inst f2xm1) + (inst fld1) + (inst faddp-sti fr1) + (inst fscale) + (inst fld fr0) + DONE + (unless (zerop (tn-offset y)) + (inst fstd y)))) + +;;; Expm1 = exp(x) - 1. +;;; Handles the following special cases: +;;; expm1(+Inf) is +Inf; expm1(-Inf) is -1.0; expm1(NaN) is NaN. +(define-vop (fexpm1) + (:translate %expm1) + (:args (x :scs (long-reg) :target fr0)) + (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp) + (:temporary (:sc long-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc long-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:temporary (:sc long-reg :offset fr2-offset + :from :argument :to :result) fr2) + (:results (y :scs (long-reg))) + (:arg-types long-float) + (:result-types long-float) + (:policy :fast-safe) + (:note "inline expm1 function") + (:vop-var vop) + (:save-p :compute-only) + (:ignore temp) + (:generator 5 + (note-this-location vop :internal-error) + (unless (zerop (tn-offset x)) + (inst fxch x) ; x to top of stack + (unless (location= x y) + (inst fst x))) ; maybe save it + ;; Check for Inf or NaN + (inst fxam) + (inst fnstsw) + (inst sahf) + (inst jmp :nc NOINFNAN) ; Neither Inf or NaN. + (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue. + (inst and ah-tn #x02) ; Test sign of Inf. + (inst jmp :z DONE) ; +Inf gives +Inf. + (inst fstp fr0) ; -Inf gives -1.0 + (inst fld1) + (inst fchs) + (inst jmp-short DONE) + NOINFNAN + ;; Free two stack slots leaving the argument on top. + (inst fstp fr2) + (inst fstp fr0) + (inst fldl2e) + (inst fmul fr1) ; Now fr0 = x log2(e) + (inst fst fr1) + (inst frndint) + (inst fsub-sti fr1) + (inst fxch fr1) + (inst f2xm1) + (inst fscale) + (inst fxch fr1) + (inst fld1) + (inst fscale) + (inst fstp fr1) + (inst fld1) + (inst fsub fr1) + (inst fsubr fr2) + DONE + (unless (zerop (tn-offset y)) + (inst fstd y)))) + +(define-vop (flog) + (:translate %log) + (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)) + (:temporary (:sc long-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc long-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:results (y :scs (long-reg))) + (:arg-types long-float) + (:result-types long-float) + (:policy :fast-safe) + (:note "inline log function") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + (sc-case x + (long-reg + (case (tn-offset x) + (0 + ;; x is in fr0 + (inst fstp fr1) + (inst fldln2) + (inst fxch fr1)) + (1 + ;; x is in fr1 + (inst fstp fr0) + (inst fldln2) + (inst fxch fr1)) + (t + ;; x is in a FP reg, not fr0 or fr1 + (inst fstp fr0) + (inst fstp fr0) + (inst fldln2) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset x)))))) + (inst fyl2x)) + ((long-stack descriptor-reg) + (inst fstp fr0) + (inst fstp fr0) + (inst fldln2) + (if (sc-is x long-stack) + (inst fldl (ea-for-lf-stack x)) + (inst fldl (ea-for-lf-desc x))) + (inst fyl2x))) + (inst fld fr0) + (case (tn-offset y) + ((0 1)) + (t (inst fstd y))))) + +(define-vop (flog10) + (:translate %log10) + (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)) + (:temporary (:sc long-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc long-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:results (y :scs (long-reg))) + (:arg-types long-float) + (:result-types long-float) + (:policy :fast-safe) + (:note "inline log10 function") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + (sc-case x + (long-reg + (case (tn-offset x) + (0 + ;; x is in fr0 + (inst fstp fr1) + (inst fldlg2) + (inst fxch fr1)) + (1 + ;; x is in fr1 + (inst fstp fr0) + (inst fldlg2) + (inst fxch fr1)) + (t + ;; x is in a FP reg, not fr0 or fr1 + (inst fstp fr0) + (inst fstp fr0) + (inst fldlg2) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset x)))))) + (inst fyl2x)) + ((long-stack descriptor-reg) + (inst fstp fr0) + (inst fstp fr0) + (inst fldlg2) + (if (sc-is x long-stack) + (inst fldl (ea-for-lf-stack x)) + (inst fldl (ea-for-lf-desc x))) + (inst fyl2x))) + (inst fld fr0) + (case (tn-offset y) + ((0 1)) + (t (inst fstd y))))) + +(define-vop (fpow) + (:translate %pow) + (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0) + (y :scs (long-reg long-stack descriptor-reg) :target fr1)) + (:temporary (:sc long-reg :offset fr0-offset + :from (:argument 0) :to :result) fr0) + (:temporary (:sc long-reg :offset fr1-offset + :from (:argument 1) :to :result) fr1) + (:temporary (:sc long-reg :offset fr2-offset + :from :load :to :result) fr2) + (:results (r :scs (long-reg))) + (:arg-types long-float long-float) + (:result-types long-float) + (:policy :fast-safe) + (:note "inline pow function") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + ;; Setup x in fr0 and y in fr1 + (cond + ;; x in fr0; y in fr1 + ((and (sc-is x long-reg) (zerop (tn-offset x)) + (sc-is y long-reg) (= 1 (tn-offset y)))) + ;; y in fr1; x not in fr0 + ((and (sc-is y long-reg) (= 1 (tn-offset y))) + ;; Load x to fr0 + (sc-case x + (long-reg + (copy-fp-reg-to-fr0 x)) + (long-stack + (inst fstp fr0) + (inst fldl (ea-for-lf-stack x))) + (descriptor-reg + (inst fstp fr0) + (inst fldl (ea-for-lf-desc x))))) + ;; x in fr0; y not in fr1 + ((and (sc-is x long-reg) (zerop (tn-offset x))) + (inst fxch fr1) + ;; Now load y to fr0 + (sc-case y + (long-reg + (copy-fp-reg-to-fr0 y)) + (long-stack + (inst fstp fr0) + (inst fldl (ea-for-lf-stack y))) + (descriptor-reg + (inst fstp fr0) + (inst fldl (ea-for-lf-desc y)))) + (inst fxch fr1)) + ;; x in fr1; y not in fr1 + ((and (sc-is x long-reg) (= 1 (tn-offset x))) + ;; Load y to fr0 + (sc-case y + (long-reg + (copy-fp-reg-to-fr0 y)) + (long-stack + (inst fstp fr0) + (inst fldl (ea-for-lf-stack y))) + (descriptor-reg + (inst fstp fr0) + (inst fldl (ea-for-lf-desc y)))) + (inst fxch fr1)) + ;; y in fr0; + ((and (sc-is y long-reg) (zerop (tn-offset y))) + (inst fxch fr1) + ;; Now load x to fr0 + (sc-case x + (long-reg + (copy-fp-reg-to-fr0 x)) + (long-stack + (inst fstp fr0) + (inst fldl (ea-for-lf-stack x))) + (descriptor-reg + (inst fstp fr0) + (inst fldl (ea-for-lf-desc x))))) + ;; Neither x or y are in either fr0 or fr1 + (t + ;; Load y then x + (inst fstp fr0) + (inst fstp fr0) + (sc-case y + (long-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset y) 2)))) + (long-stack + (inst fldl (ea-for-lf-stack y))) + (descriptor-reg + (inst fldl (ea-for-lf-desc y)))) + ;; Load x to fr0 + (sc-case x + (long-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset x))))) + (long-stack + (inst fldl (ea-for-lf-stack x))) + (descriptor-reg + (inst fldl (ea-for-lf-desc x)))))) + + ;; Now have x at fr0; and y at fr1 + (inst fyl2x) + ;; Now fr0=y log2(x) + (inst fld fr0) + (inst frndint) + (inst fst fr2) + (inst fsubp-sti fr1) + (inst f2xm1) + (inst fld1) + (inst faddp-sti fr1) + (inst fscale) + (inst fld fr0) + (case (tn-offset r) + ((0 1)) + (t (inst fstd r))))) + +(define-vop (fscalen) + (:translate %scalbn) + (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0) + (y :scs (signed-stack signed-reg) :target temp)) + (:temporary (:sc long-reg :offset fr0-offset + :from (:argument 0) :to :result) fr0) + (:temporary (:sc long-reg :offset fr1-offset :from :eval :to :result) fr1) + (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp) + (:results (r :scs (long-reg))) + (:arg-types long-float signed-num) + (:result-types long-float) + (:policy :fast-safe) + (:note "inline scalbn function") + (:generator 5 + ;; Setup x in fr0 and y in fr1 + (sc-case x + (long-reg + (case (tn-offset x) + (0 + (inst fstp fr1) + (sc-case y + (signed-reg + (inst mov temp y) + (inst fild temp)) + (signed-stack + (inst fild y))) + (inst fxch fr1)) + (1 + (inst fstp fr0) + (sc-case y + (signed-reg + (inst mov temp y) + (inst fild temp)) + (signed-stack + (inst fild y))) + (inst fxch fr1)) + (t + (inst fstp fr0) + (inst fstp fr0) + (sc-case y + (signed-reg + (inst mov temp y) + (inst fild temp)) + (signed-stack + (inst fild y))) + (inst fld (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset x))))))) + ((long-stack descriptor-reg) + (inst fstp fr0) + (inst fstp fr0) + (sc-case y + (signed-reg + (inst mov temp y) + (inst fild temp)) + (signed-stack + (inst fild y))) + (if (sc-is x long-stack) + (inst fldl (ea-for-lf-stack x)) + (inst fldl (ea-for-lf-desc x))))) + (inst fscale) + (unless (zerop (tn-offset r)) + (inst fstd r)))) + +(define-vop (fscale) + (:translate %scalb) + (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0) + (y :scs (long-reg long-stack descriptor-reg) :target fr1)) + (:temporary (:sc long-reg :offset fr0-offset + :from (:argument 0) :to :result) fr0) + (:temporary (:sc long-reg :offset fr1-offset + :from (:argument 1) :to :result) fr1) + (:results (r :scs (long-reg))) + (:arg-types long-float long-float) + (:result-types long-float) + (:policy :fast-safe) + (:note "inline scalb function") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + ;; Setup x in fr0 and y in fr1 + (cond + ;; x in fr0; y in fr1 + ((and (sc-is x long-reg) (zerop (tn-offset x)) + (sc-is y long-reg) (= 1 (tn-offset y)))) + ;; y in fr1; x not in fr0 + ((and (sc-is y long-reg) (= 1 (tn-offset y))) + ;; Load x to fr0 + (sc-case x + (long-reg + (copy-fp-reg-to-fr0 x)) + (long-stack + (inst fstp fr0) + (inst fldl (ea-for-lf-stack x))) + (descriptor-reg + (inst fstp fr0) + (inst fldl (ea-for-lf-desc x))))) + ;; x in fr0; y not in fr1 + ((and (sc-is x long-reg) (zerop (tn-offset x))) + (inst fxch fr1) + ;; Now load y to fr0 + (sc-case y + (long-reg + (copy-fp-reg-to-fr0 y)) + (long-stack + (inst fstp fr0) + (inst fldl (ea-for-lf-stack y))) + (descriptor-reg + (inst fstp fr0) + (inst fldl (ea-for-lf-desc y)))) + (inst fxch fr1)) + ;; x in fr1; y not in fr1 + ((and (sc-is x long-reg) (= 1 (tn-offset x))) + ;; Load y to fr0 + (sc-case y + (long-reg + (copy-fp-reg-to-fr0 y)) + (long-stack + (inst fstp fr0) + (inst fldl (ea-for-lf-stack y))) + (descriptor-reg + (inst fstp fr0) + (inst fldl (ea-for-lf-desc y)))) + (inst fxch fr1)) + ;; y in fr0; + ((and (sc-is y long-reg) (zerop (tn-offset y))) + (inst fxch fr1) + ;; Now load x to fr0 + (sc-case x + (long-reg + (copy-fp-reg-to-fr0 x)) + (long-stack + (inst fstp fr0) + (inst fldl (ea-for-lf-stack x))) + (descriptor-reg + (inst fstp fr0) + (inst fldl (ea-for-lf-desc x))))) + ;; Neither x or y are in either fr0 or fr1 + (t + ;; Load y then x + (inst fstp fr0) + (inst fstp fr0) + (sc-case y + (long-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset y) 2)))) + (long-stack + (inst fldl (ea-for-lf-stack y))) + (descriptor-reg + (inst fldl (ea-for-lf-desc y)))) + ;; Load x to fr0 + (sc-case x + (long-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset x))))) + (long-stack + (inst fldl (ea-for-lf-stack x))) + (descriptor-reg + (inst fldl (ea-for-lf-desc x)))))) + + ;; Now have x at fr0; and y at fr1 + (inst fscale) + (unless (zerop (tn-offset r)) + (inst fstd r)))) + +(define-vop (flog1p) + (:translate %log1p) + (:args (x :scs (long-reg) :to :result)) + (:temporary (:sc long-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc long-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:temporary (:sc word-reg :offset eax-offset :from :eval) temp) + (:results (y :scs (long-reg))) + (:arg-types long-float) + (:result-types long-float) + (:policy :fast-safe) + ;; FIXME 1: This appears to be the second DEFINE-VOP of FLOG1P. + ;; Perhaps this is OK because of the #!+LONG-FLOAT wrapped around + ;; an enormous PROGN above. Still, it would be probably be good to + ;; add some code to warn about redefining VOPs. + (:note "inline log1p function") + (:ignore temp) + (:generator 5 + ;; x is in a FP reg, not fr0, fr1. + (inst fstp fr0) + (inst fstp fr0) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset x) 2))) + ;; Check the range + (inst push #x3e947ae1) ; Constant 0.29 + (inst fabs) + (inst fld (make-ea :dword :base esp-tn)) + (inst fcompp) + (inst add esp-tn 4) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x45) + (inst jmp :z WITHIN-RANGE) + ;; Out of range for fyl2xp1. + (inst fld1) + (inst faddd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset x) 1))) + (inst fldln2) + (inst fxch fr1) + (inst fyl2x) + (inst jmp DONE) + + WITHIN-RANGE + (inst fldln2) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset x) 1))) + (inst fyl2xp1) + DONE + (inst fld fr0) + (case (tn-offset y) + ((0 1)) + (t (inst fstd y))))) + +;;; The Pentium has a less restricted implementation of the fyl2xp1 +;;; instruction and a range check can be avoided. +(define-vop (flog1p-pentium) + (:translate %log1p) + (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)) + (:temporary (:sc long-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc long-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:results (y :scs (long-reg))) + (:arg-types long-float) + (:result-types long-float) + (:policy :fast-safe) + (:guard (member :pentium-style-fyl2xp1 *backend-subfeatures*)) + (:note "inline log1p function") + (:generator 5 + (sc-case x + (long-reg + (case (tn-offset x) + (0 + ;; x is in fr0 + (inst fstp fr1) + (inst fldln2) + (inst fxch fr1)) + (1 + ;; x is in fr1 + (inst fstp fr0) + (inst fldln2) + (inst fxch fr1)) + (t + ;; x is in a FP reg, not fr0 or fr1 + (inst fstp fr0) + (inst fstp fr0) + (inst fldln2) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset x))))))) + ((long-stack descriptor-reg) + (inst fstp fr0) + (inst fstp fr0) + (inst fldln2) + (if (sc-is x long-stack) + (inst fldl (ea-for-lf-stack x)) + (inst fldl (ea-for-lf-desc x))))) + (inst fyl2xp1) + (inst fld fr0) + (case (tn-offset y) + ((0 1)) + (t (inst fstd y))))) + +(define-vop (flogb) + (:translate %logb) + (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)) + (:temporary (:sc long-reg :offset fr0-offset + :from :argument :to :result) fr0) + (:temporary (:sc long-reg :offset fr1-offset + :from :argument :to :result) fr1) + (:results (y :scs (long-reg))) + (:arg-types long-float) + (:result-types long-float) + (:policy :fast-safe) + (:note "inline logb function") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + (sc-case x + (long-reg + (case (tn-offset x) + (0 + ;; x is in fr0 + (inst fstp fr1)) + (1 + ;; x is in fr1 + (inst fstp fr0)) + (t + ;; x is in a FP reg, not fr0 or fr1 + (inst fstp fr0) + (inst fstp fr0) + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset x) 2)))))) + ((long-stack descriptor-reg) + (inst fstp fr0) + (inst fstp fr0) + (if (sc-is x long-stack) + (inst fldl (ea-for-lf-stack x)) + (inst fldl (ea-for-lf-desc x))))) + (inst fxtract) + (case (tn-offset y) + (0 + (inst fxch fr1)) + (1) + (t (inst fxch fr1) + (inst fstd y))))) + +(define-vop (fatan) + (:translate %atan) + (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)) + (:temporary (:sc long-reg :offset fr0-offset + :from (:argument 0) :to :result) fr0) + (:temporary (:sc long-reg :offset fr1-offset + :from (:argument 0) :to :result) fr1) + (:results (r :scs (long-reg))) + (:arg-types long-float) + (:result-types long-float) + (:policy :fast-safe) + (:note "inline atan function") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + ;; Setup x in fr1 and 1.0 in fr0 + (cond + ;; x in fr0 + ((and (sc-is x long-reg) (zerop (tn-offset x))) + (inst fstp fr1)) + ;; x in fr1 + ((and (sc-is x long-reg) (= 1 (tn-offset x))) + (inst fstp fr0)) + ;; x not in fr0 or fr1 + (t + ;; Load x then 1.0 + (inst fstp fr0) + (inst fstp fr0) + (sc-case x + (long-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset x) 2)))) + (long-stack + (inst fldl (ea-for-lf-stack x))) + (descriptor-reg + (inst fldl (ea-for-lf-desc x)))))) + (inst fld1) + ;; Now have x at fr1; and 1.0 at fr0 + (inst fpatan) + (inst fld fr0) + (case (tn-offset r) + ((0 1)) + (t (inst fstd r))))) + +(define-vop (fatan2) + (:translate %atan2) + (:args (x :scs (long-reg long-stack descriptor-reg) :target fr1) + (y :scs (long-reg long-stack descriptor-reg) :target fr0)) + (:temporary (:sc long-reg :offset fr0-offset + :from (:argument 1) :to :result) fr0) + (:temporary (:sc long-reg :offset fr1-offset + :from (:argument 0) :to :result) fr1) + (:results (r :scs (long-reg))) + (:arg-types long-float long-float) + (:result-types long-float) + (:policy :fast-safe) + (:note "inline atan2 function") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + ;; Setup x in fr1 and y in fr0 + (cond + ;; y in fr0; x in fr1 + ((and (sc-is y long-reg) (zerop (tn-offset y)) + (sc-is x long-reg) (= 1 (tn-offset x)))) + ;; x in fr1; y not in fr0 + ((and (sc-is x long-reg) (= 1 (tn-offset x))) + ;; Load y to fr0 + (sc-case y + (long-reg + (copy-fp-reg-to-fr0 y)) + (long-stack + (inst fstp fr0) + (inst fldl (ea-for-lf-stack y))) + (descriptor-reg + (inst fstp fr0) + (inst fldl (ea-for-lf-desc y))))) + ;; y in fr0; x not in fr1 + ((and (sc-is y long-reg) (zerop (tn-offset y))) + (inst fxch fr1) + ;; Now load x to fr0 + (sc-case x + (long-reg + (copy-fp-reg-to-fr0 x)) + (long-stack + (inst fstp fr0) + (inst fldl (ea-for-lf-stack x))) + (descriptor-reg + (inst fstp fr0) + (inst fldl (ea-for-lf-desc x)))) + (inst fxch fr1)) + ;; y in fr1; x not in fr1 + ((and (sc-is y long-reg) (= 1 (tn-offset y))) + ;; Load x to fr0 + (sc-case x + (long-reg + (copy-fp-reg-to-fr0 x)) + (long-stack + (inst fstp fr0) + (inst fldl (ea-for-lf-stack x))) + (descriptor-reg + (inst fstp fr0) + (inst fldl (ea-for-lf-desc x)))) + (inst fxch fr1)) + ;; x in fr0; + ((and (sc-is x long-reg) (zerop (tn-offset x))) + (inst fxch fr1) + ;; Now load y to fr0 + (sc-case y + (long-reg + (copy-fp-reg-to-fr0 y)) + (long-stack + (inst fstp fr0) + (inst fldl (ea-for-lf-stack y))) + (descriptor-reg + (inst fstp fr0) + (inst fldl (ea-for-lf-desc y))))) + ;; Neither y or x are in either fr0 or fr1 + (t + ;; Load x then y + (inst fstp fr0) + (inst fstp fr0) + (sc-case x + (long-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (- (tn-offset x) 2)))) + (long-stack + (inst fldl (ea-for-lf-stack x))) + (descriptor-reg + (inst fldl (ea-for-lf-desc x)))) + ;; Load y to fr0 + (sc-case y + (long-reg + (inst fldd (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (1- (tn-offset y))))) + (long-stack + (inst fldl (ea-for-lf-stack y))) + (descriptor-reg + (inst fldl (ea-for-lf-desc y)))))) + + ;; Now have y at fr0; and x at fr1 + (inst fpatan) + (inst fld fr0) + (case (tn-offset r) + ((0 1)) + (t (inst fstd r))))) + +) ; PROGN #!+LONG-FLOAT + +;;;; complex float VOPs + +(define-vop (make-complex-single-float) + (:translate complex) + (:args (real :scs (single-reg) :to :result :target r + :load-if (not (location= real r))) + (imag :scs (single-reg) :to :save)) + (:arg-types single-float single-float) + (:results (r :scs (complex-single-reg) :from (:argument 0) + :load-if (not (sc-is r complex-single-stack)))) + (:result-types complex-single-float) + (:note "inline complex single-float creation") + (:policy :fast-safe) + (:generator 5 + (sc-case r + (complex-single-reg + (let ((r-real (complex-double-reg-real-tn r))) + (unless (location= real r-real) + (cond ((zerop (tn-offset r-real)) + (copy-fp-reg-to-fr0 real)) + ((zerop (tn-offset real)) + (inst fstd r-real)) + (t + (inst fxch real) + (inst fstd r-real) + (inst fxch real))))) + (let ((r-imag (complex-double-reg-imag-tn r))) + (unless (location= imag r-imag) + (cond ((zerop (tn-offset imag)) + (inst fstd r-imag)) + (t + (inst fxch imag) + (inst fstd r-imag) + (inst fxch imag)))))) + (complex-single-stack + (unless (location= real r) + (cond ((zerop (tn-offset real)) + (inst fst (ea-for-csf-real-stack r))) + (t + (inst fxch real) + (inst fst (ea-for-csf-real-stack r)) + (inst fxch real)))) + (inst fxch imag) + (inst fst (ea-for-csf-imag-stack r)) + (inst fxch imag))))) + +(define-vop (make-complex-double-float) + (:translate complex) + (:args (real :scs (double-reg) :target r + :load-if (not (location= real r))) + (imag :scs (double-reg) :to :save)) + (:arg-types double-float double-float) + (:results (r :scs (complex-double-reg) :from (:argument 0) + :load-if (not (sc-is r complex-double-stack)))) + (:result-types complex-double-float) + (:note "inline complex double-float creation") + (:policy :fast-safe) + (:generator 5 + (sc-case r + (complex-double-reg + (let ((r-real (complex-double-reg-real-tn r))) + (unless (location= real r-real) + (cond ((zerop (tn-offset r-real)) + (copy-fp-reg-to-fr0 real)) + ((zerop (tn-offset real)) + (inst fstd r-real)) + (t + (inst fxch real) + (inst fstd r-real) + (inst fxch real))))) + (let ((r-imag (complex-double-reg-imag-tn r))) + (unless (location= imag r-imag) + (cond ((zerop (tn-offset imag)) + (inst fstd r-imag)) + (t + (inst fxch imag) + (inst fstd r-imag) + (inst fxch imag)))))) + (complex-double-stack + (unless (location= real r) + (cond ((zerop (tn-offset real)) + (inst fstd (ea-for-cdf-real-stack r))) + (t + (inst fxch real) + (inst fstd (ea-for-cdf-real-stack r)) + (inst fxch real)))) + (inst fxch imag) + (inst fstd (ea-for-cdf-imag-stack r)) + (inst fxch imag))))) + +#!+long-float +(define-vop (make-complex-long-float) + (:translate complex) + (:args (real :scs (long-reg) :target r + :load-if (not (location= real r))) + (imag :scs (long-reg) :to :save)) + (:arg-types long-float long-float) + (:results (r :scs (complex-long-reg) :from (:argument 0) + :load-if (not (sc-is r complex-long-stack)))) + (:result-types complex-long-float) + (:note "inline complex long-float creation") + (:policy :fast-safe) + (:generator 5 + (sc-case r + (complex-long-reg + (let ((r-real (complex-double-reg-real-tn r))) + (unless (location= real r-real) + (cond ((zerop (tn-offset r-real)) + (copy-fp-reg-to-fr0 real)) + ((zerop (tn-offset real)) + (inst fstd r-real)) + (t + (inst fxch real) + (inst fstd r-real) + (inst fxch real))))) + (let ((r-imag (complex-double-reg-imag-tn r))) + (unless (location= imag r-imag) + (cond ((zerop (tn-offset imag)) + (inst fstd r-imag)) + (t + (inst fxch imag) + (inst fstd r-imag) + (inst fxch imag)))))) + (complex-long-stack + (unless (location= real r) + (cond ((zerop (tn-offset real)) + (store-long-float (ea-for-clf-real-stack r))) + (t + (inst fxch real) + (store-long-float (ea-for-clf-real-stack r)) + (inst fxch real)))) + (inst fxch imag) + (store-long-float (ea-for-clf-imag-stack r)) + (inst fxch imag))))) + + +(define-vop (complex-float-value) + (:args (x :target r)) + (:results (r)) + (:variant-vars offset) + (:policy :fast-safe) + (:generator 3 + (cond ((sc-is x complex-single-reg complex-double-reg + #!+long-float complex-long-reg) + (let ((value-tn + (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset (+ offset (tn-offset x))))) + (unless (location= value-tn r) + (cond ((zerop (tn-offset r)) + (copy-fp-reg-to-fr0 value-tn)) + ((zerop (tn-offset value-tn)) + (inst fstd r)) + (t + (inst fxch value-tn) + (inst fstd r) + (inst fxch value-tn)))))) + ((sc-is r single-reg) + (let ((ea (sc-case x + (complex-single-stack + (ecase offset + (0 (ea-for-csf-real-stack x)) + (1 (ea-for-csf-imag-stack x)))) + (descriptor-reg + (ecase offset + (0 (ea-for-csf-real-desc x)) + (1 (ea-for-csf-imag-desc x))))))) + (with-empty-tn@fp-top(r) + (inst fld ea)))) + ((sc-is r double-reg) + (let ((ea (sc-case x + (complex-double-stack + (ecase offset + (0 (ea-for-cdf-real-stack x)) + (1 (ea-for-cdf-imag-stack x)))) + (descriptor-reg + (ecase offset + (0 (ea-for-cdf-real-desc x)) + (1 (ea-for-cdf-imag-desc x))))))) + (with-empty-tn@fp-top(r) + (inst fldd ea)))) + #!+long-float + ((sc-is r long-reg) + (let ((ea (sc-case x + (complex-long-stack + (ecase offset + (0 (ea-for-clf-real-stack x)) + (1 (ea-for-clf-imag-stack x)))) + (descriptor-reg + (ecase offset + (0 (ea-for-clf-real-desc x)) + (1 (ea-for-clf-imag-desc x))))))) + (with-empty-tn@fp-top(r) + (inst fldl ea)))) + (t (error "COMPLEX-FLOAT-VALUE VOP failure"))))) + +(define-vop (realpart/complex-single-float complex-float-value) + (:translate realpart) + (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg) + :target r)) + (:arg-types complex-single-float) + (:results (r :scs (single-reg))) + (:result-types single-float) + (:note "complex float realpart") + (:variant 0)) + +(define-vop (realpart/complex-double-float complex-float-value) + (:translate realpart) + (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg) + :target r)) + (:arg-types complex-double-float) + (:results (r :scs (double-reg))) + (:result-types double-float) + (:note "complex float realpart") + (:variant 0)) + +#!+long-float +(define-vop (realpart/complex-long-float complex-float-value) + (:translate realpart) + (:args (x :scs (complex-long-reg complex-long-stack descriptor-reg) + :target r)) + (:arg-types complex-long-float) + (:results (r :scs (long-reg))) + (:result-types long-float) + (:note "complex float realpart") + (:variant 0)) + +(define-vop (imagpart/complex-single-float complex-float-value) + (:translate imagpart) + (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg) + :target r)) + (:arg-types complex-single-float) + (:results (r :scs (single-reg))) + (:result-types single-float) + (:note "complex float imagpart") + (:variant 1)) + +(define-vop (imagpart/complex-double-float complex-float-value) + (:translate imagpart) + (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg) + :target r)) + (:arg-types complex-double-float) + (:results (r :scs (double-reg))) + (:result-types double-float) + (:note "complex float imagpart") + (:variant 1)) + +#!+long-float +(define-vop (imagpart/complex-long-float complex-float-value) + (:translate imagpart) + (:args (x :scs (complex-long-reg complex-long-stack descriptor-reg) + :target r)) + (:arg-types complex-long-float) + (:results (r :scs (long-reg))) + (:result-types long-float) + (:note "complex float imagpart") + (:variant 1)) + +;;; hack dummy VOPs to bias the representation selection of their +;;; arguments towards a FP register, which can help avoid consing at +;;; inappropriate locations +(defknown double-float-reg-bias (double-float) (values)) +(define-vop (double-float-reg-bias) + (:translate double-float-reg-bias) + (:args (x :scs (double-reg double-stack) :load-if nil)) + (:arg-types double-float) + (:policy :fast-safe) + (:note "inline dummy FP register bias") + (:ignore x) + (:generator 0)) +(defknown single-float-reg-bias (single-float) (values)) +(define-vop (single-float-reg-bias) + (:translate single-float-reg-bias) + (:args (x :scs (single-reg single-stack) :load-if nil)) + (:arg-types single-float) + (:policy :fast-safe) + (:note "inline dummy FP register bias") + (:ignore x) + (:generator 0)) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp -x external-format-test.txt -x test-status.lisp-expr sbcl-1.0.13-pristine/src/compiler/arm/insts.lisp sbcl-1.0.13-arm5-pass1/src/compiler/arm/insts.lisp --- sbcl-1.0.13-pristine/src/compiler/arm/insts.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-1.0.13-arm5-pass1/src/compiler/arm/insts.lisp 2008-11-13 11:04:12.698166200 -0500 @@ -0,0 +1,747 @@ +;;;; that part of the description of the ARM instruction set (for +;;;; ARMv5) which can live on the cross-compilation host + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") +;;; FIXME: SB!DISASSEM: prefixes are used so widely in this file that +;;; I wonder whether the separation of the disassembler from the +;;; virtual machine is valid or adds value. + +;;; Note: In CMU CL, this used to be a call to SET-DISASSEM-PARAMS. +(setf sb!disassem:*disassem-inst-alignment-bytes* 4) + + +(eval-when (:compile-toplevel :load-toplevel :execute) +(defparameter *conditions* + '((:eq . 0) + (:ne . 1) + (:cs . 2) (:hs . 2) + (:cc . 3) (:lo . 3) + (:mi . 4) + (:pl . 5) + (:vs . 6) + (:vc . 7) + (:hi . 8) + (:ls . 9) + (:ge . 10) + (:lt . 11) + (:gt . 12) + (:le . 13) + (:al . 14))) +(defparameter *condition-name-vec* + (let ((vec (make-array 16 :initial-element nil))) + (dolist (cond *conditions*) + (when (null (aref vec (cdr cond))) + (setf (aref vec (cdr cond)) (car cond)))) + vec)) +) ; EVAL-WHEN + +;;; Set assembler parameters. (In CMU CL, this was done with +;;; a call to a macro DEF-ASSEMBLER-PARAMS.) +(eval-when (:compile-toplevel :load-toplevel :execute) + (setf sb!assem:*assem-scheduler-p* nil)) + +(sb!disassem:define-arg-type condition-code + :printer *condition-name-vec*) + +(defun conditional-opcode (condition) + (cdr (assoc condition *conditions* :test #'eq))) + +;;;; primitive emitters + +;(define-bitfield-emitter emit-word 16 +; (byte 16 0)) + +(define-bitfield-emitter emit-word 32 + (byte 32 0)) + +;;;; fixup emitters +#| +(defun emit-absolute-fixup (segment fixup) + (note-fixup segment :absolute fixup) + (let ((offset (fixup-offset fixup))) + (if (label-p offset) + (emit-back-patch segment + 4 ; FIXME: n-word-bytes + (lambda (segment posn) + (declare (ignore posn)) + (emit-dword segment + (- (+ (component-header-length) + (or (label-position offset) + 0)) + other-pointer-lowtag)))) + (emit-dword segment (or offset 0))))) + +(defun emit-relative-fixup (segment fixup) + (note-fixup segment :relative fixup) + (emit-dword segment (or (fixup-offset fixup) 0))) +|# + +;;;; miscellaneous hackery + +(defun register-p (thing) + (and (tn-p thing) + (eq (sb-name (sc-sb (tn-sc thing))) 'registers))) + +(defmacro with-condition-defaulted ((argvar arglist) &body body) + (let ((internal-emitter (gensym))) + `(flet ((,internal-emitter ,arglist + ,@body)) + (if (keywordp (car ,argvar)) + (apply #',internal-emitter ,argvar) + (apply #',internal-emitter :al ,argvar))))) + +(define-instruction byte (segment byte) + (:emitter + (emit-byte segment byte))) + +;(define-instruction word (segment word) +; (:emitter +; (emit-word segment word))) + +(define-instruction word (segment word) + (:emitter + (emit-word segment word))) + +(defun emit-header-data (segment type) + (emit-back-patch segment + 4 + (lambda (segment posn) + (emit-word segment + (logior type + (ash (+ posn + (component-header-length)) + (- n-widetag-bits + word-shift))))))) + +(define-instruction simple-fun-header-word (segment) + (:emitter + (emit-header-data segment simple-fun-header-widetag))) + +(define-instruction lra-header-word (segment) + (:emitter + (emit-header-data segment return-pc-header-widetag))) + +;;;; Addressing mode 1 support + +;;; Addressing mode 1 has some 11 formats. These are immediate, +;;; register, and nine shift/rotate functions based on one or more +;;; registers. As the mnemonics used for these functions are not +;;; currently used, we simply define them as constructors for a +;;; shifter-operand structure, similar to the make-ea function in the +;;; x86 backend. + +(defstruct shifter-operand + register + function-code + operand) + +(defun lsl (register operand) + (aver (register-p register)) + (aver (or (register-p operand) + (typep operand '(integer 0 31)))) + + (make-shifter-operand :register register :function-code 0 :operand operand)) + +(defun lsr (register operand) + (aver (register-p register)) + (aver (or (register-p operand) + (typep operand '(integer 1 32)))) + + (make-shifter-operand :register register :function-code 1 :operand operand)) + +(defun asr (register operand) + (aver (register-p register)) + (aver (or (register-p operand) + (typep operand '(integer 1 32)))) + + (make-shifter-operand :register register :function-code 2 :operand operand)) + +(defun ror (register operand) + ;; ROR is a special case: the encoding for ROR with an immediate + ;; shift of 32 (0) is actually RRX. + (aver (register-p register)) + (aver (or (register-p operand) + (typep operand '(integer 1 31)))) + + (make-shifter-operand :register register :function-code 3 :operand operand)) + +(defun rrx (register) + ;; RRX is a special case: it is encoded as ROR with an immediate + ;; shift of 32 (0), and has no operand. + (aver (register-p register)) + + (make-shifter-operand :register register :function-code 3 :operand 0)) + +(defun encode-shifter-immediate (operand) + ;; 32-bit immediate data is encoded as an 8-bit immediate data value + ;; and a 4-bit immediate shift count. The actual value is the + ;; immediate data rotated right by a number of bits equal to twice + ;; the shift count. Note that this means that there are a limited + ;; number of valid immediate integers and that some integers have + ;; multiple possible encodings. In the case of multiple encodings, + ;; the correct one to use is the one with the lowest shift count. + ;; + ;; XXX: Is it possible to determine the correct encoding in constant + ;; time, rather than time proportional to the final shift count? Is + ;; it possible to determine if a given integer is valid without + ;; attempting to encode it? Are such solutions cheaper (either time + ;; or spacewise) than simply attempting to encode it? + (labels ((try-immediate-encoding (value shift) + (unless (<= 0 shift 15) + (error "Unable to encode #x~X as an immediate operand." operand)) + (if (typep value '(unsigned-byte 8)) + (dpb shift (byte 4 8) value) + (try-immediate-encoding (dpb value (byte 30 2) + (ldb (byte 2 30) value)) + (1+ shift))))) + (try-immediate-encoding operand 0))) + +(defun encode-shifter-operand (operand) + (etypecase operand + (integer + (dpb 1 (byte 1 25) (encode-shifter-immediate operand))) + + (tn + (ecase (sb-name (sc-sb (tn-sc operand))) + (registers + ;; For those wondering, this is LSL immediate for 0 bits. + (tn-offset operand)) + + ;; FIXME: Do we actually need constant TNs for shifter operands? + #+(or) + (constant ))) + + (shifter-operand + (let ((Rm (tn-offset (shifter-operand-register operand))) + (shift-code (shifter-operand-function-code operand)) + (shift-amount (shifter-operand-operand operand))) + (etypecase shift-amount + (integer + (dpb shift-amount (byte 5 7) + (dpb shift-code (byte 2 5) + Rm))) + (tn + (dpb (tn-offset shift-amount) (byte 4 8) + (dpb shift-code (byte 2 5) + (dpb 1 (byte 1 4) + Rm))))))))) + +;;;; Addressing mode 2 support + +;;; Addressing mode 2 ostensibly has 9 formats. These are formed from +;;; a cross product of three address calculations and three base +;;; register writeback modes. As one of the address calculations is a +;;; scaled register calculation identical to the mode 1 register shift +;;; by constant, we reuse the shifter-operand structure and its public +;;; constructors. + +(defstruct memory-operand + base + offset + direction + mode) + +;;; The @ macro is used to encode a memory addressing mode. The +;;; parameters for the base form are a base register, an optional +;;; offset (either an integer, a register tn or a shifter-operand +;;; structure with a constant shift amount, optionally within a unary +;;; - form), and a base register writeback mode (either :offset, +;;; :pre-index, or :post-index). The alternative form uses a label as +;;; the base register, and accepts only (optionally negated) integers +;;; as offsets, and requires a mode of :offset. +(defun %@ (base offset direction mode) + (when (label-p base) + (aver (eq mode :offset)) + (aver (integerp offset))) + + (when (shifter-operand-p offset) + (aver (integerp (shifter-operand-operand offset)))) + + ;; Fix up direction with negative offsets. + (when (and (not (label-p base)) + (integerp offset) + (< offset 0)) + (setf offset (- offset)) + (setf direction (if (eq direction :up) :down :up))) + + (make-memory-operand :base base :offset offset + :direction direction :mode mode)) + +(defmacro @ (base &optional (offset 0) (mode :offset)) + (let* ((direction (if (and (consp offset) (eq (car offset) '-)) + :down + :up)) + (offset (if (eq direction :down) (cadr offset) offset))) + `(%@ ,base ,offset ,direction ,mode))) + +;;;; Data-processing instructions + +;;; Data processing instructions have a 4-bit opcode field and a 1-bit +;;; "S" field for updating condition bits. They are adjacent, so we +;;; roll them into one 5-bit field for convenience. + +(define-bitfield-emitter emit-dp-instruction 32 + (byte 4 28) (byte 2 26) (byte 1 25) (byte 5 20) + (byte 4 16) (byte 4 12) (byte 12 0)) + +;;; There are 16 data processing instructions, with a breakdown as +;;; follows: +;;; +;;; 1.) Two "move" instructions, with no "source" operand (they have +;;; destination and shifter operands only). +;;; +;;; 2.) Four "test" instructions, with no "destination" operand. +;;; These instructions always have their "S" bit set, though it +;;; is not specified in their mnemonics. +;;; +;;; 3.) Ten "normal" instructions, with all three operands. +;;; +;;; Aside from this, the instructions all have a regular encoding, so +;;; we can use a single macro to define them. + +(defmacro define-data-processing-instruction (instruction opcode dest-p src-p) + `(define-instruction ,instruction (segment &rest args) + (:emitter + (with-condition-defaulted (args (condition ,@(if dest-p '(dest)) + ,@(if src-p '(src)) + shifter-operand)) + ,(if dest-p '(aver (register-p dest))) + ,(if src-p '(aver (register-p src))) + (let ((shifter-operand (encode-shifter-operand shifter-operand))) + (emit-dp-instruction segment + (conditional-opcode condition) + 0 + (ldb (byte 1 25) shifter-operand) + ,opcode + ,(if src-p '(tn-offset src) 0) + ,(if dest-p '(tn-offset dest) 0) + shifter-operand)))))) + +(define-data-processing-instruction and #x00 t t) +(define-data-processing-instruction ands #x01 t t) +(define-data-processing-instruction eor #x02 t t) +(define-data-processing-instruction eors #x03 t t) +(define-data-processing-instruction sub #x04 t t) +(define-data-processing-instruction subs #x05 t t) +(define-data-processing-instruction rsb #x06 t t) +(define-data-processing-instruction rsbs #x07 t t) +(define-data-processing-instruction add #x08 t t) +(define-data-processing-instruction adds #x09 t t) +(define-data-processing-instruction adc #x0a t t) +(define-data-processing-instruction adcs #x0b t t) +(define-data-processing-instruction sbc #x0c t t) +(define-data-processing-instruction sbcs #x0d t t) +(define-data-processing-instruction rsc #x0e t t) +(define-data-processing-instruction rscs #x0f t t) +(define-data-processing-instruction orr #x18 t t) +(define-data-processing-instruction orrs #x19 t t) +(define-data-processing-instruction bic #x1c t t) +(define-data-processing-instruction bics #x1d t t) + +(define-data-processing-instruction tst #x11 nil t) +(define-data-processing-instruction teq #x13 nil t) +(define-data-processing-instruction cmp #x15 nil t) +(define-data-processing-instruction cmn #x17 nil t) + +(define-data-processing-instruction mov #x1a t nil) +(define-data-processing-instruction movs #x1b t nil) +(define-data-processing-instruction mvn #x1e t nil) +(define-data-processing-instruction mvns #x1f t nil) + +;;;; Exception-generating instructions + +;;; There are two exception-generating instructions. One, BKPT, is +;;; ostensibly used as a breakpoint instruction, and to communicate +;;; with debugging hardware. The other, SWI, is intended for use as a +;;; system call interface. We need both because, at least on some +;;; platforms, the only breakpoint trap that works properly is a +;;; syscall. + +(define-bitfield-emitter emit-swi-instruction 32 + (byte 4 28) (byte 4 24) (byte 24 0)) + +(define-instruction swi (segment &rest args) + (:emitter + (with-condition-defaulted (args (condition code)) + (emit-swi-instruction segment + (conditional-opcode condition) + #b1111 code)))) + +(define-bitfield-emitter emit-bkpt-instruction 32 + (byte 4 28) (byte 8 20) (byte 12 8) (byte 4 4) (byte 4 0)) + +(define-instruction bkpt (segment code) + (:emitter + (emit-bkpt-instruction segment #b1110 #b00010010 + (ldb (byte 12 4) code) + #b0111 + (ldb (byte 4 0) code)))) + +;;;; Miscellaneous arithmetic instructions + +(define-bitfield-emitter emit-clz-instruction 32 + (byte 4 28) (byte 12 16) (byte 4 12) (byte 8 4) (byte 4 0)) + +(define-instruction clz (segment &rest args) + (:emitter + (with-condition-defaulted (args (condition dest src)) + (aver (register-p dest)) + (aver (register-p src)) + (emit-clz-instruction segment (conditional-opcode condition) + #b000101101111 + (tn-offset dest) + #b11110001 + (tn-offset src))))) + +;;;; Branch instructions + +(define-bitfield-emitter emit-branch-instruction 32 + (byte 4 28) (byte 4 24) (byte 24 0)) + +(defun emit-branch-back-patch (segment condition opcode dest) + (emit-back-patch segment 4 + (lambda (segment posn) + (emit-branch-instruction segment + (conditional-opcode condition) + opcode + (ldb (byte 24 2) + (- (label-position dest) + (+ posn 8))))))) + +(define-instruction b (segment &rest args) + (:emitter + (with-condition-defaulted (args (condition dest)) + (aver (label-p dest)) + (emit-branch-back-patch segment condition #b1010 dest)))) + +(define-instruction bl (segment &rest args) + (:emitter + (with-condition-defaulted (args (condition dest)) + (aver (label-p dest)) + (emit-branch-back-patch segment condition #b1011 dest)))) + +(define-bitfield-emitter emit-branch-exchange-instruction 32 + (byte 4 28) (byte 8 20) (byte 4 16) (byte 4 12) + (byte 4 8) (byte 4 4) (byte 4 0)) + +(define-instruction bx (segment &rest args) + (:emitter + (with-condition-defaulted (args (condition dest)) + (aver (register-p dest)) + (emit-branch-exchange-instruction segment + (conditional-opcode condition) + #b00010010 #b1111 #b1111 + #b1111 #b0001 (tn-offset dest))))) + +(define-instruction blx (segment &rest args) + (:emitter + (with-condition-defaulted (args (condition dest)) + (aver (register-p dest)) + (emit-branch-exchange-instruction segment + (conditional-opcode condition) + #b00010010 #b1111 #b1111 + #b1111 #b0011 (tn-offset dest))))) + +;;;; Semaphore instructions + +(defun emit-semaphore-instruction (segment opcode condition dest value address) + (aver (register-p dest)) + (aver (register-p value)) + (aver (memory-operand-p address)) + (aver (zerop (memory-operand-offset address))) + (aver (eq :offset (memory-operand-mode address))) + (emit-dp-instruction segment (conditional-opcode condition) + #b00 0 opcode (tn-offset (memory-operand-base address)) + (tn-offset dest) + (dpb #b1001 (byte 4 4) (tn-offset value)))) + +(define-instruction swp (segment &rest args) + (:emitter + (with-condition-defaulted (args (condition dest value address)) + (emit-semaphore-instruction segment #b10000 + condition dest value address)))) + +(define-instruction swpb (segment &rest args) + (:emitter + (with-condition-defaulted (args (condition dest value address)) + (emit-semaphore-instruction segment #b10100 + condition dest value address)))) + +;;;; Status-register instructions + +(define-instruction mrs (segment &rest args) + (:emitter + (with-condition-defaulted (args (condition dest reg)) + (aver (register-p dest)) + (aver (member reg '(:cpsr :spsr))) + (emit-dp-instruction segment (conditional-opcode condition) + #b00 0 (if (eq reg :cpsr) #b10000 #b10100) + #b1111 (tn-offset dest) 0)))) + +(defun encode-status-register-fields (fields) + (let ((fields (string fields))) + (labels ((frob (mask index) + (let* ((field (aref fields index)) + (field-mask (cdr (assoc field + '((#\c . #b0001) (#\x . #b0010) + (#\s . #b0100) (#\f . #b1000)) + :test #'char=)))) + (unless field-mask + (error "bad status register field desginator ~S" fields)) + (if (< (1+ index) (length fields)) + (frob (logior mask field-mask) (1+ index)) + (logior mask field-mask))))) + (frob 0 0)))) + +(defmacro cpsr (fields) + (encode-status-register-fields fields)) + +(defmacro spsr (fields) + (logior #b10000 (encode-status-register-fields fields))) + +(define-instruction msr (segment &rest args) + (:emitter + (with-condition-defaulted (args (condition field-mask src)) + (aver (or (register-p src) + (integerp src))) + (let ((encoded-src (encode-shifter-operand src))) + (emit-dp-instruction segment (conditional-opcode condition) + #b00 (ldb (byte 1 25) encoded-src) + (if (logbitp 4 field-mask) #b10110 #b10010) + field-mask #b1111 encoded-src))))) + +;;;; Multiply instructions + +(define-bitfield-emitter emit-multiply-instruction 32 + (byte 4 28) (byte 8 20) (byte 4 16) (byte 4 12) + (byte 4 8) (byte 4 4) (byte 4 0)) + +(macrolet + ((define-multiply-instruction (name field-mapping opcode1 opcode2) + (let ((arglist (ecase field-mapping + (:dzsm '(dest src multiplicand)) + (:dnsm '(dest src multiplicand num)) + (:ddsm '(dest-lo dest src multiplicand))))) + `(define-instruction ,name (segment &rest args) + (:emitter + (with-condition-defaulted (args (condition ,@arglist)) + ,@(loop + for arg in arglist + collect `(aver (register-p ,arg))) + (emit-multiply-instruction segment (conditional-opcode condition) + ,opcode1 + (tn-offset dest) + ,(ecase field-mapping + (:dzsm 0) + (:dnsm '(tn-offset num)) + (:ddsm '(tn-offset dest-lo))) + (tn-offset src) + ,opcode2 + (tn-offset multiplicand)))))))) + + (define-multiply-instruction mul :dzsm #b00000000 #b1001) + (define-multiply-instruction muls :dzsm #b00000001 #b1001) + (define-multiply-instruction mla :dnsm #b00000010 #b1001) + (define-multiply-instruction mlas :dnsm #b00000011 #b1001) + + (define-multiply-instruction umull :ddsm #b00001000 #b1001) + (define-multiply-instruction umulls :ddsm #b00001001 #b1001) + (define-multiply-instruction umlal :ddsm #b00001010 #b1001) + (define-multiply-instruction umlals :ddsm #b00001011 #b1001) + + (define-multiply-instruction smull :ddsm #b00001100 #b1001) + (define-multiply-instruction smulls :ddsm #b00001101 #b1001) + (define-multiply-instruction smlal :ddsm #b00001110 #b1001) + (define-multiply-instruction smlals :ddsm #b00001111 #b1001) + + (define-multiply-instruction smlabb :dnsm #b00010000 #b1000) + (define-multiply-instruction smlatb :dnsm #b00010000 #b1010) + (define-multiply-instruction smlabt :dnsm #b00010000 #b1100) + (define-multiply-instruction smlatt :dnsm #b00010000 #b1110) + + (define-multiply-instruction smlalbb :ddsm #b00010100 #b1000) + (define-multiply-instruction smlaltb :ddsm #b00010100 #b1010) + (define-multiply-instruction smlalbt :ddsm #b00010100 #b1100) + (define-multiply-instruction smlaltt :ddsm #b00010100 #b1110) + + (define-multiply-instruction smulbb :dzsm #b00010110 #b1000) + (define-multiply-instruction smultb :dzsm #b00010110 #b1010) + (define-multiply-instruction smulbt :dzsm #b00010110 #b1100) + (define-multiply-instruction smultt :dzsm #b00010110 #b1110) + + (define-multiply-instruction smlawb :dnsm #b00010010 #b1000) + (define-multiply-instruction smlawt :dnsm #b00010010 #b1100) + + (define-multiply-instruction smulwb :dzsm #b00010010 #b1010) + (define-multiply-instruction smulwt :dzsm #b00010010 #b1110)) + +;;;; Load/store instructions + +;;; Emit a load/store instruction. CONDITION is a condition code +;;; name, KIND is :load or :store, WIDTH is :word or :byte, DATA is a +;;; register TN and ADDRESS is either a memory-operand structure or a +;;; stack TN. +(defun emit-load/store-instruction (segment condition kind width data address) + (flet ((compute-opcode (direction mode) + (let ((opcode-bits '(:load #b00001 :store #b00000 + :word #b00000 :byte #b00100 + :up #b01000 :down #b00000 + :offset #b10000 + :pre-index #b10010 + :post-index #b00000))) + (reduce #'logior (list kind width direction mode) + :key (lambda (value) (getf opcode-bits value)))))) + (etypecase address + (memory-operand + (let* ((base (memory-operand-base address)) + (offset (memory-operand-offset address)) + (direction (memory-operand-direction address)) + (mode (memory-operand-mode address)) + (cond-bits (conditional-opcode condition))) + (cond + ((label-p base) + (emit-back-patch + segment 4 + (lambda (segment posn) + (let* ((label-delta (- (label-position base) + (+ posn 8))) + (offset-delta (if (eq direction :up) + offset + (- offset))) + (overall-delta (+ label-delta + offset-delta)) + (absolute-delta (abs overall-delta))) + (aver (typep absolute-delta '(unsigned-byte 12))) + (emit-dp-instruction segment cond-bits #b01 0 + (compute-opcode (if (< overall-delta 0) + :down + :up) + mode) + (tn-offset base) (tn-offset data) + absolute-delta))))) + ((integerp offset) + (aver (typep offset '(unsigned-byte 12))) + (emit-dp-instruction segment cond-bits #b01 0 + (compute-opcode direction mode) + (tn-offset base) (tn-offset data) + offset)) + (t + (emit-dp-instruction segment cond-bits #b01 1 + (compute-opcode direction mode) + (tn-offset base) (tn-offset data) + (encode-shifter-operand offset)))))) + + #+(or) + (tn + ;; FIXME: This is for stack TN references, and needs must be + ;; implemented. + )))) + +(macrolet + ((define-load/store-instruction (name kind width) + `(define-instruction ,name (segment &rest args) + (:emitter + (with-condition-defaulted (args (condition reg address)) + (aver (register-p reg)) + (emit-load/store-instruction segment condition + ,kind ,width reg address)))))) + (define-load/store-instruction ldr :load :word) + (define-load/store-instruction ldrb :load :byte) + (define-load/store-instruction str :store :word) + (define-load/store-instruction strb :store :byte)) + +;;; Emit a miscellaneous load/store instruction. CONDITION is a +;;; condition code name, OPCODE1 is the low bit of the first opcode +;;; field, OPCODE2 is the second opcode field, DATA is a register TN +;;; and ADDRESS is either a memory-operand structure or a stack TN. +(defun emit-misc-load/store-instruction (segment condition opcode1 + opcode2 data address) + (flet ((compute-opcode (kind direction mode) + (let ((opcode-bits '(:register #b00000 :immediate #b00100 + :up #b01000 :down #b00000 + :offset #b10000 + :pre-index #b10010 + :post-index #b00000))) + (reduce #'logior (list kind direction mode) + :key (lambda (value) (getf opcode-bits value)))))) + (etypecase address + (memory-operand + (let* ((base (memory-operand-base address)) + (offset (memory-operand-offset address)) + (direction (memory-operand-direction address)) + (mode (memory-operand-mode address)) + (cond-bits (conditional-opcode condition))) + (cond + ((label-p base) + (emit-back-patch + segment 4 + (lambda (segment posn) + (let* ((label-delta (- (label-position base) + (+ posn 8))) + (offset-delta (if (eq direction :up) + offset + (- offset))) + (overall-delta (+ label-delta + offset-delta)) + (absolute-delta (abs overall-delta))) + (aver (typep absolute-delta '(unsigned-byte 8))) + (emit-multiply-instruction segment cond-bits + (logior opcode1 + (compute-opcode :immedaite + (if (< overall-delta 0) + :down + :up) + mode)) + (tn-offset base) (tn-offset data) + (ldb (byte 4 4) absolute-delta) + opcode2 absolute-delta))))) + ((integerp offset) + (aver (typep offset '(unsigned-byte 8))) + (emit-multiply-instruction segment cond-bits + (logior opcode1 + (compute-opcode :immediate direction mode)) + (tn-offset base) (tn-offset data) + (ldb (byte 4 4) offset) + opcode2 offset)) + ((register-p offset) + (emit-multiply-instruction segment cond-bits + (logior opcode1 + (compute-opcode :register direction mode)) + (tn-offset base) (tn-offset data) + 0 opcode2 (tn-offset offset))) + (t + (error "bad thing for a miscellaneous load/store address ~S" + address))))) + + #+(or) + (tn + ;; FIXME: This is for stack TN references, and needs must be + ;; implemented. + )))) + +(macrolet + ((define-misc-load/store-instruction (name opcode1 opcode2 double-width) + `(define-instruction ,name (segment &rest args) + (:emitter + (with-condition-defaulted (args (condition reg address)) + (aver (register-p reg)) + ,(when double-width '(aver (evenp (tn-offset reg)))) + (emit-misc-load/store-instruction segment condition + ,opcode1 ,opcode2 + reg address)))))) + (define-misc-load/store-instruction strh 0 #b1011 nil) + (define-misc-load/store-instruction ldrd 0 #b1101 t) + (define-misc-load/store-instruction strd 0 #b1111 t) + + (define-misc-load/store-instruction ldrh 1 #b1011 nil) + (define-misc-load/store-instruction ldrsb 1 #b1101 nil) + (define-misc-load/store-instruction ldrsh 1 #b1111 nil)) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp -x external-format-test.txt -x test-status.lisp-expr sbcl-1.0.13-pristine/src/compiler/arm/macros.lisp sbcl-1.0.13-arm5-pass1/src/compiler/arm/macros.lisp --- sbcl-1.0.13-pristine/src/compiler/arm/macros.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-1.0.13-arm5-pass1/src/compiler/arm/macros.lisp 2007-12-28 17:57:08.156275281 -0500 @@ -0,0 +1,577 @@ +;;;; a bunch of handy macros for the x86 + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + +;;; We can load/store into fp registers through the top of stack +;;; %st(0) (fr0 here). Loads imply a push to an empty register which +;;; then changes all the reg numbers. These macros help manage that. + +;;; Use this when we don't have to load anything. It preserves old tos +;;; value, but probably destroys tn with operation. +(defmacro with-tn@fp-top((tn) &body body) + `(progn + (unless (zerop (tn-offset ,tn)) + (inst fxch ,tn)) + ,@body + (unless (zerop (tn-offset ,tn)) + (inst fxch ,tn)))) + +;;; Use this to prepare for load of new value from memory. This +;;; changes the register numbering so the next instruction had better +;;; be a FP load from memory; a register load from another register +;;; will probably be loading the wrong register! +(defmacro with-empty-tn@fp-top((tn) &body body) + `(progn + (inst fstp ,tn) + ,@body + (unless (zerop (tn-offset ,tn)) + (inst fxch ,tn)))) ; save into new dest and restore st(0) + +;;;; instruction-like macros + +(defmacro move (dst src) + #!+sb-doc + "Move SRC into DST unless they are location=." + (once-only ((n-dst dst) + (n-src src)) + `(unless (location= ,n-dst ,n-src) + (inst mov ,n-dst ,n-src)))) + +(defmacro align-stack-pointer (tn) + #!-darwin (declare (ignore tn)) + #!+darwin + ;; 16 byte alignment. + `(inst and ,tn #xfffffff0)) + +(defmacro make-ea-for-object-slot (ptr slot lowtag &optional (size :dword)) + `(make-ea ,size :base ,ptr :disp (- (* ,slot n-word-bytes) ,lowtag))) + +(defmacro loadw (value ptr &optional (slot 0) (lowtag 0)) + `(inst mov ,value (make-ea-for-object-slot ,ptr ,slot ,lowtag))) + +(defmacro storew (value ptr &optional (slot 0) (lowtag 0)) + (once-only ((value value)) + `(inst mov (make-ea-for-object-slot ,ptr ,slot ,lowtag) ,value))) + +;;; A handy macro for storing widetags. +(defmacro storeb (value ptr &optional (slot 0) (lowtag 0)) + (once-only ((value value)) + `(inst mov (make-ea-for-object-slot ,ptr ,slot ,lowtag :byte) ,value))) + +(defmacro pushw (ptr &optional (slot 0) (lowtag 0)) + `(inst push (make-ea-for-object-slot ,ptr ,slot ,lowtag))) + +(defmacro popw (ptr &optional (slot 0) (lowtag 0)) + `(inst pop (make-ea-for-object-slot ,ptr ,slot ,lowtag))) + +(defmacro make-ea-for-vector-data (object &key (size :dword) (offset 0) + index (scale (ash (width-bits size) -3))) + `(make-ea ,size :base ,object :index ,index :scale ,scale + :disp (- (+ (* vector-data-offset n-word-bytes) + (* ,offset ,scale)) + other-pointer-lowtag))) + +;;;; macros to generate useful values + +(defmacro load-symbol (reg symbol) + `(inst mov ,reg (+ nil-value (static-symbol-offset ,symbol)))) + +(defmacro make-ea-for-symbol-value (symbol &optional (width :dword)) + (declare (type symbol symbol)) + `(make-ea ,width + :disp (+ nil-value + (static-symbol-offset ',symbol) + (ash symbol-value-slot word-shift) + (- other-pointer-lowtag)))) + +(defmacro load-symbol-value (reg symbol) + `(inst mov ,reg (make-ea-for-symbol-value ,symbol))) + +(defmacro store-symbol-value (reg symbol) + `(inst mov (make-ea-for-symbol-value ,symbol) ,reg)) + +#!+sb-thread +(defmacro make-ea-for-symbol-tls-index (symbol) + (declare (type symbol symbol)) + `(make-ea :dword + :disp (+ nil-value + (static-symbol-offset ',symbol) + (ash symbol-tls-index-slot word-shift) + (- other-pointer-lowtag)))) + +#!+sb-thread +(defmacro load-tl-symbol-value (reg symbol) + `(progn + (inst mov ,reg (make-ea-for-symbol-tls-index ,symbol)) + (inst fs-segment-prefix) + (inst mov ,reg (make-ea :dword :base ,reg)))) +#!-sb-thread +(defmacro load-tl-symbol-value (reg symbol) `(load-symbol-value ,reg ,symbol)) + +#!+sb-thread +(defmacro store-tl-symbol-value (reg symbol temp) + `(progn + (inst mov ,temp (make-ea-for-symbol-tls-index ,symbol)) + (inst fs-segment-prefix) + (inst mov (make-ea :dword :base ,temp) ,reg))) +#!-sb-thread +(defmacro store-tl-symbol-value (reg symbol temp) + (declare (ignore temp)) + `(store-symbol-value ,reg ,symbol)) + +(defmacro load-binding-stack-pointer (reg) + #!+sb-thread + `(progn + (inst fs-segment-prefix) + (inst mov ,reg (make-ea :dword + :disp (* 4 thread-binding-stack-pointer-slot)))) + #!-sb-thread + `(load-symbol-value ,reg *binding-stack-pointer*)) + +(defmacro store-binding-stack-pointer (reg) + #!+sb-thread + `(progn + (inst fs-segment-prefix) + (inst mov (make-ea :dword + :disp (* 4 thread-binding-stack-pointer-slot)) + ,reg)) + #!-sb-thread + `(store-symbol-value ,reg *binding-stack-pointer*)) + +(defmacro load-type (target source &optional (offset 0)) + #!+sb-doc + "Loads the type bits of a pointer into target independent of + byte-ordering issues." + (once-only ((n-target target) + (n-source source) + (n-offset offset)) + (ecase *backend-byte-order* + (:little-endian + `(inst mov ,n-target + (make-ea :byte :base ,n-source :disp ,n-offset))) + (:big-endian + `(inst mov ,n-target + (make-ea :byte :base ,n-source + :disp (+ ,n-offset (1- n-word-bytes)))))))) + +;;;; allocation helpers + +;;; Allocation within alloc_region (which is thread local) can be done +;;; inline. If the alloc_region is overflown allocation is done by +;;; calling the C alloc() function. + +;;; C calls for allocation don't /seem/ to make an awful lot of +;;; difference to speed. On pure consing it's about a 25% +;;; gain. Guessing from historical context, it looks like inline +;;; allocation was introduced before pseudo-atomic, at which time all +;;; calls to alloc() would have needed a syscall to mask signals for +;;; the duration. Now we have pseudoatomic there's no need for that +;;; overhead. + +(defun allocation-dynamic-extent (alloc-tn size) + (inst sub esp-tn size) + ;; FIXME: SIZE _should_ be double-word aligned (suggested but + ;; unfortunately not enforced by PAD-DATA-BLOCK and + ;; WITH-FIXED-ALLOCATION), so that ESP is always divisible by 8 (for + ;; 32-bit lispobjs). In that case, this AND instruction is + ;; unneccessary and could be removed. If not, explain why. -- CSR, + ;; 2004-03-30 + (inst and esp-tn (lognot lowtag-mask)) + (aver (not (location= alloc-tn esp-tn))) + (inst mov alloc-tn esp-tn) + (values)) + +(defun allocation-notinline (alloc-tn size) + (let* ((alloc-tn-offset (tn-offset alloc-tn)) + ;; C call to allocate via dispatch routines. Each + ;; destination has a special entry point. The size may be a + ;; register or a constant. + (tn-text (ecase alloc-tn-offset + (#.eax-offset "eax") + (#.ecx-offset "ecx") + (#.edx-offset "edx") + (#.ebx-offset "ebx") + (#.esi-offset "esi") + (#.edi-offset "edi"))) + (size-text (case size (8 "8_") (16 "16_") (t "")))) + (unless (or (eql size 8) (eql size 16)) + (unless (and (tn-p size) (location= alloc-tn size)) + (inst mov alloc-tn size))) + (inst call (make-fixup (concatenate 'string + "alloc_" size-text + "to_" tn-text) + :foreign)))) + +(defun allocation-inline (alloc-tn size) + (let ((ok (gen-label)) + (done (gen-label)) + (free-pointer + (make-ea :dword :disp + #!+sb-thread (* n-word-bytes thread-alloc-region-slot) + #!-sb-thread (make-fixup "boxed_region" :foreign) + :scale 1)) ; thread->alloc_region.free_pointer + (end-addr + (make-ea :dword :disp + #!+sb-thread (* n-word-bytes (1+ thread-alloc-region-slot)) + #!-sb-thread (make-fixup "boxed_region" :foreign 4) + :scale 1))) ; thread->alloc_region.end_addr + (unless (and (tn-p size) (location= alloc-tn size)) + (inst mov alloc-tn size)) + #!+sb-thread (inst fs-segment-prefix) + (inst add alloc-tn free-pointer) + #!+sb-thread (inst fs-segment-prefix) + (inst cmp alloc-tn end-addr) + (inst jmp :be ok) + (let ((dst (ecase (tn-offset alloc-tn) + (#.eax-offset "alloc_overflow_eax") + (#.ecx-offset "alloc_overflow_ecx") + (#.edx-offset "alloc_overflow_edx") + (#.ebx-offset "alloc_overflow_ebx") + (#.esi-offset "alloc_overflow_esi") + (#.edi-offset "alloc_overflow_edi")))) + (inst call (make-fixup dst :foreign))) + (inst jmp-short done) + (emit-label ok) + ;; Swap ALLOC-TN and FREE-POINTER + (cond ((and (tn-p size) (location= alloc-tn size)) + ;; XCHG is extremely slow, use the xor swap trick + #!+sb-thread (inst fs-segment-prefix) + (inst xor alloc-tn free-pointer) + #!+sb-thread (inst fs-segment-prefix) + (inst xor free-pointer alloc-tn) + #!+sb-thread (inst fs-segment-prefix) + (inst xor alloc-tn free-pointer)) + (t + ;; It's easier if SIZE is still available. + #!+sb-thread (inst fs-segment-prefix) + (inst mov free-pointer alloc-tn) + (inst sub alloc-tn size))) + (emit-label done)) + (values)) + + +;;; Emit code to allocate an object with a size in bytes given by +;;; SIZE. The size may be an integer or a TN. If Inline is a VOP +;;; node-var then it is used to make an appropriate speed vs size +;;; decision. + +;;; Allocation should only be used inside a pseudo-atomic section, which +;;; should also cover subsequent initialization of the object. + +;;; (FIXME: so why aren't we asserting this?) + +(defun allocation (alloc-tn size &optional inline dynamic-extent) + (cond + (dynamic-extent (allocation-dynamic-extent alloc-tn size)) + ((or (null inline) (policy inline (>= speed space))) + (allocation-inline alloc-tn size)) + (t (allocation-notinline alloc-tn size))) + (values)) + +;;; Allocate an other-pointer object of fixed SIZE with a single word +;;; header having the specified WIDETAG value. The result is placed in +;;; RESULT-TN. +(defmacro with-fixed-allocation ((result-tn widetag size &optional inline stack-allocate-p) + &body forms) + (unless forms + (bug "empty &body in WITH-FIXED-ALLOCATION")) + (once-only ((result-tn result-tn) (size size) (stack-allocate-p stack-allocate-p)) + `(maybe-pseudo-atomic ,stack-allocate-p + (allocation ,result-tn (pad-data-block ,size) ,inline ,stack-allocate-p) + (storew (logior (ash (1- ,size) n-widetag-bits) ,widetag) + ,result-tn) + (inst lea ,result-tn + (make-ea :byte :base ,result-tn :disp other-pointer-lowtag)) + ,@forms))) + +;;;; error code +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) + (defun emit-error-break (vop kind code values) + (let ((vector (gensym))) + `((progn + #-darwin (inst int 3) ; i386 breakpoint instruction + ;; CLH 20060314 + ;; On Darwin, we need to use #x0b0f instead of int3 in order + ;; to generate a SIGILL instead of a SIGTRAP as darwin/x86 + ;; doesn't seem to be reliably firing SIGTRAP + ;; handlers. Hopefully this will be fixed by Apple at a + ;; later date. + #+darwin (inst word #x0b0f)) + ;; The return PC points here; note the location for the debugger. + (let ((vop ,vop)) + (when vop + (note-this-location vop :internal-error))) + (inst byte ,kind) ; eg trap_Xyyy + (with-adjustable-vector (,vector) ; interr arguments + (write-var-integer (error-number-or-lose ',code) ,vector) + ,@(mapcar (lambda (tn) + `(let ((tn ,tn)) + ;; classic CMU CL comment: + ;; zzzzz jrd here. tn-offset is zero for constant + ;; tns. + (write-var-integer (make-sc-offset (sc-number + (tn-sc tn)) + (or (tn-offset tn) + 0)) + ,vector))) + values) + (inst byte (length ,vector)) + (dotimes (i (length ,vector)) + (inst byte (aref ,vector i)))))))) + +(defmacro error-call (vop error-code &rest values) + #!+sb-doc + "Cause an error. ERROR-CODE is the error to cause." + (cons 'progn + (emit-error-break vop error-trap error-code values))) + +(defmacro generate-error-code (vop error-code &rest values) + #!+sb-doc + "Generate-Error-Code Error-code Value* + Emit code for an error with the specified Error-Code and context Values." + `(assemble (*elsewhere*) + (let ((start-lab (gen-label))) + (emit-label start-lab) + (error-call ,vop ,error-code ,@values) + start-lab))) + + +;;;; PSEUDO-ATOMIC + +;;; This is used to wrap operations which leave untagged memory lying +;;; around. It's an operation which the AOP weenies would describe as +;;; having "cross-cutting concerns", meaning it appears all over the +;;; place and there's no logical single place to attach documentation. +;;; grep (mostly in src/runtime) is your friend + +;;; KLUDGE: since the stack on the x86 is treated conservatively, it +;;; does not matter whether a signal occurs during construction of a +;;; dynamic-extent object, as the half-finished construction of the +;;; object will not cause any difficulty. We can therefore elide +(defmacro maybe-pseudo-atomic (really-p &body forms) + `(if ,really-p + (progn ,@forms) + (pseudo-atomic ,@forms))) + +#!+sb-thread +(defmacro pseudo-atomic (&rest forms) + (with-unique-names (label) + `(let ((,label (gen-label))) + (inst fs-segment-prefix) + (inst or (make-ea :byte :disp (* 4 thread-pseudo-atomic-bits-slot)) + (fixnumize 1)) + ,@forms + (inst fs-segment-prefix) + (inst xor (make-ea :byte :disp (* 4 thread-pseudo-atomic-bits-slot)) + (fixnumize 1)) + (inst jmp :z ,label) + ;; if PAI was set, interrupts were disabled at the same + ;; time using the process signal mask. + (inst break pending-interrupt-trap) + (emit-label ,label)))) + +#!-sb-thread +(defmacro pseudo-atomic (&rest forms) + (with-unique-names (label) + `(let ((,label (gen-label))) + (inst or (make-ea-for-symbol-value *pseudo-atomic-bits* :byte) + (fixnumize 1)) + ,@forms + (inst xor (make-ea-for-symbol-value *pseudo-atomic-bits* :byte) + (fixnumize 1)) + (inst jmp :z ,label) + ;; if PAI was set, interrupts were disabled at the same + ;; time using the process signal mask. + (inst break pending-interrupt-trap) + (emit-label ,label)))) + +;;;; indexed references + +(defmacro define-full-compare-and-swap + (name type offset lowtag scs el-type &optional translate) + `(progn + (define-vop (,name) + ,@(when translate `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :eval) + (index :scs (any-reg immediate unsigned-reg) :to :result) + (old-value :scs ,scs :target eax) + (new-value :scs ,scs)) + (:arg-types ,type tagged-num ,el-type ,el-type) + (:temporary (:sc descriptor-reg :offset eax-offset + :from (:argument 2) :to :result :target value) eax) + (:results (value :scs ,scs)) + (:result-types ,el-type) + (:generator 5 + (move eax old-value) + #!+sb-thread + (inst lock) + (let ((ea (sc-case index + (immediate + (make-ea :dword :base object + :disp (- (* (+ ,offset (tn-value index)) + n-word-bytes) + ,lowtag))) + (unsigned-reg + (make-ea :dword :base object :index index :scale 4 + :disp (- (* ,offset n-word-bytes) + ,lowtag))) + (t + (make-ea :dword :base object :index index + :disp (- (* ,offset n-word-bytes) + ,lowtag)))))) + (inst cmpxchg ea new-value)) + (move value eax))))) + +(defmacro define-full-reffer (name type offset lowtag scs el-type &optional translate) + `(progn + (define-vop (,name) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg immediate unsigned-reg))) + (:arg-types ,type tagged-num) + (:results (value :scs ,scs)) + (:result-types ,el-type) + (:generator 3 ; pw was 5 + (sc-case index + (immediate + (inst mov value (make-ea :dword :base object + :disp (- (* (+ ,offset (tn-value index)) + n-word-bytes) + ,lowtag)))) + (unsigned-reg + (inst mov value (make-ea :dword :base object :index index :scale 4 + :disp (- (* ,offset n-word-bytes) + ,lowtag)))) + (t + (inst mov value (make-ea :dword :base object :index index + :disp (- (* ,offset n-word-bytes) + ,lowtag))))))))) + +(defmacro define-full-reffer+offset (name type offset lowtag scs el-type &optional translate) + `(progn + (define-vop (,name) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg immediate unsigned-reg))) + (:arg-types ,type tagged-num + (:constant (constant-displacement ,lowtag sb!vm:n-word-bytes ,offset))) + (:info offset) + (:results (value :scs ,scs)) + (:result-types ,el-type) + (:generator 3 ; pw was 5 + (sc-case index + (immediate + (inst mov value (make-ea :dword :base object + :disp (- (* (+ ,offset + (tn-value index) + offset) + n-word-bytes) + ,lowtag)))) + (unsigned-reg + (inst mov value (make-ea :dword :base object :index index :scale 4 + :disp (- (* (+ ,offset offset) + n-word-bytes) + ,lowtag)))) + (t + (inst mov value (make-ea :dword :base object :index index + :disp (- (* (+ ,offset offset) + n-word-bytes) + ,lowtag))))))))) + +(defmacro define-full-setter (name type offset lowtag scs el-type &optional translate) + `(progn + (define-vop (,name) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg immediate)) + (value :scs ,scs :target result)) + (:arg-types ,type tagged-num ,el-type) + (:results (result :scs ,scs)) + (:result-types ,el-type) + (:generator 4 ; was 5 + (sc-case index + (immediate + (inst mov (make-ea :dword :base object + :disp (- (* (+ ,offset (tn-value index)) + n-word-bytes) + ,lowtag)) + value)) + (t + (inst mov (make-ea :dword :base object :index index + :disp (- (* ,offset n-word-bytes) ,lowtag)) + value))) + (move result value))))) + +(defmacro define-full-setter+offset (name type offset lowtag scs el-type &optional translate) + `(progn + (define-vop (,name) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg immediate)) + (value :scs ,scs :target result)) + (:info offset) + (:arg-types ,type tagged-num + (:constant (constant-displacement ,lowtag sb!vm:n-word-bytes ,offset)) ,el-type) + (:results (result :scs ,scs)) + (:result-types ,el-type) + (:generator 4 ; was 5 + (sc-case index + (immediate + (inst mov (make-ea :dword :base object + :disp (- (* (+ ,offset (tn-value index) offset) + n-word-bytes) + ,lowtag)) + value)) + (t + (inst mov (make-ea :dword :base object :index index + :disp (- (* (+ ,offset offset) + n-word-bytes) ,lowtag)) + value))) + (move result value))))) + +;;; helper for alien stuff. + +(def!macro with-pinned-objects ((&rest objects) &body body) + "Arrange with the garbage collector that the pages occupied by +OBJECTS will not be moved in memory for the duration of BODY. +Useful for e.g. foreign calls where another thread may trigger +collection." + (if objects + (let ((pins (make-gensym-list (length objects))) + (wpo (block-gensym "WPO"))) + ;; BODY is stuffed in a function to preserve the lexical + ;; environment. + `(flet ((,wpo () (progn ,@body))) + ;; PINS are dx-allocated in case the compiler for some + ;; unfathomable reason decides to allocate value-cells + ;; for them -- since we have DX value-cells on x86oid + ;; platforms this still forces them on the stack. + (dx-let ,(mapcar #'list pins objects) + (multiple-value-prog1 (,wpo) + ;; TOUCH-OBJECT has a VOP with an empty body: compiler + ;; thinks we're using the argument and doesn't flush + ;; the variable, but we don't have to pay any extra + ;; beyond that -- and MULTIPLE-VALUE-PROG1 keeps them + ;; live till the body has finished. *whew* + ,@(mapcar (lambda (pin) + `(touch-object ,pin)) + pins))))) + `(progn ,@body))) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp -x external-format-test.txt -x test-status.lisp-expr sbcl-1.0.13-pristine/src/compiler/arm/memory.lisp sbcl-1.0.13-arm5-pass1/src/compiler/arm/memory.lisp --- sbcl-1.0.13-pristine/src/compiler/arm/memory.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-1.0.13-arm5-pass1/src/compiler/arm/memory.lisp 2007-12-28 17:57:08.157275129 -0500 @@ -0,0 +1,130 @@ +;;;; the x86 definitions of some general purpose memory reference VOPs +;;;; inherited by basic memory reference operations + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + +;;; CELL-REF and CELL-SET are used to define VOPs like CAR, where the +;;; offset to be read or written is a property of the VOP used. +;;; CELL-SETF is similar to CELL-SET, but delivers the new value as +;;; the result. CELL-SETF-FUN takes its arguments as if it were a +;;; SETF function (new value first, as apposed to a SETF macro, which +;;; takes the new value last). +(define-vop (cell-ref) + (:args (object :scs (descriptor-reg))) + (:results (value :scs (descriptor-reg any-reg))) + (:variant-vars offset lowtag) + (:policy :fast-safe) + (:generator 4 + (loadw value object offset lowtag))) +(define-vop (cell-set) + (:args (object :scs (descriptor-reg)) + (value :scs (descriptor-reg any-reg))) + (:variant-vars offset lowtag) + (:policy :fast-safe) + (:generator 4 + (storew value object offset lowtag))) +(define-vop (cell-setf) + (:args (object :scs (descriptor-reg)) + (value :scs (descriptor-reg any-reg) :target result)) + (:results (result :scs (descriptor-reg any-reg))) + (:variant-vars offset lowtag) + (:policy :fast-safe) + (:generator 4 + (storew value object offset lowtag) + (move result value))) +(define-vop (cell-setf-fun) + (:args (value :scs (descriptor-reg any-reg) :target result) + (object :scs (descriptor-reg))) + (:results (result :scs (descriptor-reg any-reg))) + (:variant-vars offset lowtag) + (:policy :fast-safe) + (:generator 4 + (storew value object offset lowtag) + (move result value))) + +;;; Define accessor VOPs for some cells in an object. If the operation +;;; name is NIL, then that operation isn't defined. If the translate +;;; function is null, then we don't define a translation. +(defmacro define-cell-accessors (offset lowtag + ref-op ref-trans set-op set-trans) + `(progn + ,@(when ref-op + `((define-vop (,ref-op cell-ref) + (:variant ,offset ,lowtag) + ,@(when ref-trans + `((:translate ,ref-trans)))))) + ,@(when set-op + `((define-vop (,set-op cell-setf) + (:variant ,offset ,lowtag) + ,@(when set-trans + `((:translate ,set-trans)))))))) + +;;; X86 special +(define-vop (cell-xadd) + (:args (object :scs (descriptor-reg) :to :result) + (value :scs (any-reg) :target result)) + (:results (result :scs (any-reg) :from (:argument 1))) + (:result-types tagged-num) + (:variant-vars offset lowtag) + (:policy :fast-safe) + (:generator 4 + (move result value) + (inst xadd (make-ea-for-object-slot object offset lowtag) + value))) + +;;; SLOT-REF and SLOT-SET are used to define VOPs like CLOSURE-REF, +;;; where the offset is constant at compile time, but varies for +;;; different uses. +(define-vop (slot-ref) + (:args (object :scs (descriptor-reg))) + (:results (value :scs (descriptor-reg any-reg))) + (:variant-vars base lowtag) + (:info offset) + (:generator 4 + (loadw value object (+ base offset) lowtag))) +(define-vop (slot-set) + (:args (object :scs (descriptor-reg)) + (value :scs (descriptor-reg any-reg immediate))) + (:variant-vars base lowtag) + (:info offset) + (:generator 4 + (storew (encode-value-if-immediate value) object (+ base offset) lowtag))) + +(define-vop (slot-set-conditional) + (:args (object :scs (descriptor-reg) :to :eval) + (old-value :scs (descriptor-reg any-reg) :target eax) + (new-value :scs (descriptor-reg any-reg) :target temp)) + (:temporary (:sc descriptor-reg :offset eax-offset + :from (:argument 1) :to :result :target result) eax) + (:temporary (:sc descriptor-reg :from (:argument 2) :to :result) temp) + (:variant-vars base lowtag) + (:results (result :scs (descriptor-reg))) + (:info offset) + (:generator 4 + (move eax old-value) + (move temp new-value) + (inst cmpxchg (make-ea-for-object-slot object (+ base offset) lowtag) + temp) + (move result eax))) + +;;; X86 special +(define-vop (slot-xadd) + (:args (object :scs (descriptor-reg) :to :result) + (value :scs (any-reg) :target result)) + (:results (result :scs (any-reg) :from (:argument 1))) + (:result-types tagged-num) + (:variant-vars base lowtag) + (:info offset) + (:generator 4 + (move result value) + (inst xadd (make-ea-for-object-slot object (+ base offset) lowtag) + value))) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp -x external-format-test.txt -x test-status.lisp-expr sbcl-1.0.13-pristine/src/compiler/arm/move.lisp sbcl-1.0.13-arm5-pass1/src/compiler/arm/move.lisp --- sbcl-1.0.13-pristine/src/compiler/arm/move.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-1.0.13-arm5-pass1/src/compiler/arm/move.lisp 2007-12-28 17:57:08.158274976 -0500 @@ -0,0 +1,380 @@ +;;;; the x86 VM definition of operand loading/saving and the MOVE vop + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + +(define-move-fun (load-immediate 1) (vop x y) + ((immediate) + (any-reg descriptor-reg)) + (let ((val (encode-value-if-immediate x))) + (if (zerop val) + (inst xor y y) + (inst mov y val)))) + +(define-move-fun (load-number 1) (vop x y) + ((immediate) (signed-reg unsigned-reg)) + (let ((val (tn-value x))) + (if (zerop val) + (inst xor y y) + (inst mov y val)))) + +(define-move-fun (load-character 1) (vop x y) + ((immediate) (character-reg)) + (inst mov y (char-code (tn-value x)))) + +(define-move-fun (load-system-area-pointer 1) (vop x y) + ((immediate) (sap-reg)) + (inst mov y (sap-int (tn-value x)))) + +(define-move-fun (load-constant 5) (vop x y) + ((constant) (descriptor-reg any-reg)) + (inst mov y x)) + +(define-move-fun (load-stack 5) (vop x y) + ((control-stack) (any-reg descriptor-reg) + (character-stack) (character-reg) + (sap-stack) (sap-reg) + (signed-stack) (signed-reg) + (unsigned-stack) (unsigned-reg)) + (inst mov y x)) + +(define-move-fun (store-stack 5) (vop x y) + ((any-reg descriptor-reg) (control-stack) + (character-reg) (character-stack) + (sap-reg) (sap-stack) + (signed-reg) (signed-stack) + (unsigned-reg) (unsigned-stack)) + (inst mov y x)) + +;;;; the MOVE VOP +(define-vop (move) + (:args (x :scs (any-reg descriptor-reg immediate) :target y + :load-if (not (location= x y)))) + (:results (y :scs (any-reg descriptor-reg) + :load-if + (not (or (location= x y) + (and (sc-is x any-reg descriptor-reg immediate) + (sc-is y control-stack)))))) + (:effects) + (:affected) + (:generator 0 + (if (and (sc-is x immediate) + (sc-is y any-reg descriptor-reg control-stack)) + (let ((val (encode-value-if-immediate x))) + (if (and (zerop val) (sc-is y any-reg descriptor-reg)) + (inst xor y y) + (inst mov y val))) + (move y x)))) + +(define-move-vop move :move + (any-reg descriptor-reg immediate) + (any-reg descriptor-reg)) + +;;; Make MOVE the check VOP for T so that type check generation +;;; doesn't think it is a hairy type. This also allows checking of a +;;; few of the values in a continuation to fall out. +(primitive-type-vop move (:check) t) + +;;; The MOVE-ARG VOP is used for moving descriptor values into +;;; another frame for argument or known value passing. +;;; +;;; Note: It is not going to be possible to move a constant directly +;;; to another frame, except if the destination is a register and in +;;; this case the loading works out. +(define-vop (move-arg) + (:args (x :scs (any-reg descriptor-reg immediate) :target y + :load-if (not (and (sc-is y any-reg descriptor-reg) + (sc-is x control-stack)))) + (fp :scs (any-reg) + :load-if (not (sc-is y any-reg descriptor-reg)))) + (:results (y)) + (:generator 0 + (sc-case y + ((any-reg descriptor-reg) + (if (sc-is x immediate) + (let ((val (encode-value-if-immediate x))) + (if (zerop val) + (inst xor y y) + (inst mov y val))) + (move y x))) + ((control-stack) + (let ((frame-offset (if (= (tn-offset fp) esp-offset) + ;; C-call + (tn-offset y) + ;; Lisp stack + (frame-word-offset (tn-offset y))))) + (storew (encode-value-if-immediate x) fp frame-offset)))))) + +(define-move-vop move-arg :move-arg + (any-reg descriptor-reg) + (any-reg descriptor-reg)) + +;;;; ILLEGAL-MOVE + +;;; This VOP exists just to begin the lifetime of a TN that couldn't +;;; be written legally due to a type error. An error is signalled +;;; before this VOP is so we don't need to do anything (not that there +;;; would be anything sensible to do anyway.) +(define-vop (illegal-move) + (:args (x) (type)) + (:results (y)) + (:ignore y) + (:vop-var vop) + (:save-p :compute-only) + (:generator 666 + (error-call vop object-not-type-error x type))) + +;;;; moves and coercions + +;;; These MOVE-TO-WORD VOPs move a tagged integer to a raw full-word +;;; representation. Similarly, the MOVE-FROM-WORD VOPs converts a raw +;;; integer to a tagged bignum or fixnum. + +;;; Arg is a fixnum, so just shift it. We need a type restriction +;;; because some possible arg SCs (control-stack) overlap with +;;; possible bignum arg SCs. +(define-vop (move-to-word/fixnum) + (:args (x :scs (any-reg descriptor-reg) :target y + :load-if (not (location= x y)))) + (:results (y :scs (signed-reg unsigned-reg) + :load-if (not (location= x y)))) + (:arg-types tagged-num) + (:note "fixnum untagging") + (:generator 1 + (move y x) + (inst sar y 2))) +(define-move-vop move-to-word/fixnum :move + (any-reg descriptor-reg) (signed-reg unsigned-reg)) + +;;; Arg is a non-immediate constant, load it. +(define-vop (move-to-word-c) + (:args (x :scs (constant))) + (:results (y :scs (signed-reg unsigned-reg))) + (:note "constant load") + (:generator 1 + (inst mov y (tn-value x)))) +(define-move-vop move-to-word-c :move + (constant) (signed-reg unsigned-reg)) + + +;;; Arg is a fixnum or bignum, figure out which and load if necessary. +(define-vop (move-to-word/integer) + (:args (x :scs (descriptor-reg) :target eax)) + (:results (y :scs (signed-reg unsigned-reg))) + (:note "integer to untagged word coercion") + (:temporary (:sc unsigned-reg :offset eax-offset + :from (:argument 0) :to (:result 0) :target y) eax) + (:generator 4 + (move eax x) + (inst test al-tn 3) + (inst jmp :z fixnum) + (loadw y eax bignum-digits-offset other-pointer-lowtag) + (inst jmp done) + FIXNUM + (inst sar eax 2) + (move y eax) + DONE)) +(define-move-vop move-to-word/integer :move + (descriptor-reg) (signed-reg unsigned-reg)) + + +;;; Result is a fixnum, so we can just shift. We need the result type +;;; restriction because of the control-stack ambiguity noted above. +(define-vop (move-from-word/fixnum) + (:args (x :scs (signed-reg unsigned-reg) :target y + :load-if (not (location= x y)))) + (:results (y :scs (any-reg descriptor-reg) + :load-if (not (location= x y)))) + (:result-types tagged-num) + (:note "fixnum tagging") + (:generator 1 + (cond ((and (sc-is x signed-reg unsigned-reg) + (not (location= x y))) + ;; Uses 7 bytes, but faster on the Pentium + (inst lea y (make-ea :dword :index x :scale 4))) + (t + ;; Uses: If x is a reg 2 + 3; if x = y uses only 3 bytes + (move y x) + (inst shl y 2))))) +(define-move-vop move-from-word/fixnum :move + (signed-reg unsigned-reg) (any-reg descriptor-reg)) + +;;; Result may be a bignum, so we have to check. Use a worst-case cost +;;; to make sure people know they may be number consing. +;;; +;;; KLUDGE: I assume this is suppressed in favor of the "faster inline +;;; version" below. (See also mysterious comment "we don't want a VOP +;;; on this one" on DEFINE-ASSEMBLY-ROUTINE (MOVE-FROM-SIGNED) in +;;; "src/assembly/x86/alloc.lisp".) -- WHN 19990916 +#+nil +(define-vop (move-from-signed) + (:args (x :scs (signed-reg unsigned-reg) :target eax)) + (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)) eax) + (:temporary (:sc unsigned-reg :offset ebx-offset :to (:result 0) :target y) + ebx) + (:temporary (:sc unsigned-reg :offset ecx-offset + :from (:argument 0) :to (:result 0)) ecx) + (:ignore ecx) + (:results (y :scs (any-reg descriptor-reg))) + (:note "signed word to integer coercion") + (:generator 20 + (move eax x) + (inst call (make-fixup 'move-from-signed :assembly-routine)) + (move y ebx))) +;;; Faster inline version, +;;; KLUDGE: Do we really want the faster inline version? It's sorta big. +;;; It is nice that it doesn't use any temporaries, though. -- WHN 19990916 +(define-vop (move-from-signed) + (:args (x :scs (signed-reg unsigned-reg) :to :result)) + (:results (y :scs (any-reg descriptor-reg) :from :argument)) + (:note "signed word to integer coercion") + (:node-var node) + (:generator 20 + (aver (not (location= x y))) + (let ((bignum (gen-label)) + (done (gen-label))) + (inst mov y x) + (inst shl y 1) + (inst jmp :o bignum) + (inst shl y 1) + (inst jmp :o bignum) + (emit-label done) + ;; KLUDGE: The sequence above leaves a DESCRIPTOR-REG Y in a + ;; non-descriptor state for a while. Does that matter? Does it + ;; matter in GENGC but not in GENCGC? Is this written down + ;; anywhere? + ;; -- WHN 19990916 + ;; + ;; Also, the sequence above seems rather twisty. Why not something + ;; more obvious along the lines of + ;; inst move y x + ;; inst tst x #xc0000000 + ;; inst jmp :nz bignum + ;; inst shl y 2 + ;; emit-label done + + (assemble (*elsewhere*) + (emit-label bignum) + (with-fixed-allocation + (y bignum-widetag (+ bignum-digits-offset 1) node) + (storew x y bignum-digits-offset other-pointer-lowtag)) + (inst jmp done))))) +(define-move-vop move-from-signed :move + (signed-reg) (descriptor-reg)) + +;;; Check for fixnum, and possibly allocate one or two word bignum +;;; result. Use a worst-case cost to make sure people know they may be +;;; number consing. +#+nil +(define-vop (move-from-unsigned) + (:args (x :scs (signed-reg unsigned-reg) :target eax)) + (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)) eax) + (:temporary (:sc unsigned-reg :offset ebx-offset :to (:result 0) :target y) + ebx) + (:temporary (:sc unsigned-reg :offset ecx-offset + :from (:argument 0) :to (:result 0)) ecx) + (:ignore ecx) + (:results (y :scs (any-reg descriptor-reg))) + (:note "unsigned word to integer coercion") + (:generator 20 + (move eax x) + (inst call (make-fixup 'move-from-unsigned :assembly-routine)) + (move y ebx))) +;;; Faster inline version. +;;; KLUDGE: Do we really want the faster inline version? It seems awfully big.. +;;; If we really want speed, most likely it's only important in the non-consing +;;; case, so how about about making the *ELSEWHERE* stuff into a subroutine? -- +;;; WHN 19990916 +(define-vop (move-from-unsigned) + (:args (x :scs (signed-reg unsigned-reg) :to :save)) + (:temporary (:sc unsigned-reg) alloc) + (:results (y :scs (any-reg descriptor-reg))) + (:node-var node) + (:note "unsigned word to integer coercion") + (:generator 20 + (aver (not (location= x y))) + (aver (not (location= x alloc))) + (aver (not (location= y alloc))) + (let ((bignum (gen-label)) + (done (gen-label)) + (one-word-bignum (gen-label)) + (L1 (gen-label))) + (inst test x #xe0000000) + (inst jmp :nz bignum) + ;; Fixnum. + (inst lea y (make-ea :dword :index x :scale 4)) ; Faster but bigger. + ;(inst mov y x) + ;(inst shl y 2) + (emit-label done) + + (assemble (*elsewhere*) + (emit-label bignum) + ;; Note: As on the mips port, space for a two word bignum is + ;; always allocated and the header size is set to either one + ;; or two words as appropriate. + (inst jmp :ns one-word-bignum) + ;; two word bignum + (inst mov y (logior (ash (1- (+ bignum-digits-offset 2)) + n-widetag-bits) + bignum-widetag)) + (inst jmp L1) + (emit-label one-word-bignum) + (inst mov y (logior (ash (1- (+ bignum-digits-offset 1)) + n-widetag-bits) + bignum-widetag)) + (emit-label L1) + (pseudo-atomic + (allocation alloc (pad-data-block (+ bignum-digits-offset 2)) node) + (storew y alloc) + (inst lea y (make-ea :byte :base alloc :disp other-pointer-lowtag)) + (storew x y bignum-digits-offset other-pointer-lowtag)) + (inst jmp done))))) +(define-move-vop move-from-unsigned :move + (unsigned-reg) (descriptor-reg)) + +;;; Move untagged numbers. +(define-vop (word-move) + (:args (x :scs (signed-reg unsigned-reg) :target y + :load-if (not (location= x y)))) + (:results (y :scs (signed-reg unsigned-reg) + :load-if + (not (or (location= x y) + (and (sc-is x signed-reg unsigned-reg) + (sc-is y signed-stack unsigned-stack)))))) + (:effects) + (:affected) + (:note "word integer move") + (:generator 0 + (move y x))) +(define-move-vop word-move :move + (signed-reg unsigned-reg) (signed-reg unsigned-reg)) + +;;; Move untagged number arguments/return-values. +(define-vop (move-word-arg) + (:args (x :scs (signed-reg unsigned-reg) :target y) + (fp :scs (any-reg) :load-if (not (sc-is y sap-reg)))) + (:results (y)) + (:note "word integer argument move") + (:generator 0 + (sc-case y + ((signed-reg unsigned-reg) + (move y x)) + ((signed-stack unsigned-stack) + (if (= (tn-offset fp) esp-offset) + (storew x fp (tn-offset y)) ; c-call + (storew x fp (frame-word-offset (tn-offset y)))))))) +(define-move-vop move-word-arg :move-arg + (descriptor-reg any-reg signed-reg unsigned-reg) (signed-reg unsigned-reg)) + +;;; Use standard MOVE-ARG and coercion to move an untagged number +;;; to a descriptor passing location. +(define-move-vop move-arg :move-arg + (signed-reg unsigned-reg) (any-reg descriptor-reg)) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp -x external-format-test.txt -x test-status.lisp-expr sbcl-1.0.13-pristine/src/compiler/arm/nlx.lisp sbcl-1.0.13-arm5-pass1/src/compiler/arm/nlx.lisp --- sbcl-1.0.13-pristine/src/compiler/arm/nlx.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-1.0.13-arm5-pass1/src/compiler/arm/nlx.lisp 2007-12-28 17:57:08.159274824 -0500 @@ -0,0 +1,305 @@ +;;;; the definition of non-local exit for the x86 VM + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + +;;; Make an environment-live stack TN for saving the SP for NLX entry. +(!def-vm-support-routine make-nlx-sp-tn (env) + (physenv-live-tn + (make-representation-tn *fixnum-primitive-type* any-reg-sc-number) + env)) + +;;; Make a TN for the argument count passing location for a non-local entry. +(!def-vm-support-routine make-nlx-entry-arg-start-location () + (make-wired-tn *fixnum-primitive-type* any-reg-sc-number ebx-offset)) + +(defun catch-block-ea (tn) + (aver (sc-is tn catch-block)) + (make-ea :dword :base ebp-tn + :disp (frame-byte-offset (+ -1 (tn-offset tn) catch-block-size)))) + + +;;;; Save and restore dynamic environment. +;;;; +;;;; These VOPs are used in the reentered function to restore the +;;;; appropriate dynamic environment. Currently we only save the +;;;; Current-Catch and the alien stack pointer. (Before sbcl-0.7.0, +;;;; when there were IR1 and byte interpreters, we had to save +;;;; the interpreter "eval stack" too.) +;;;; +;;;; We don't need to save/restore the current UNWIND-PROTECT, since +;;;; UNWIND-PROTECTs are implicitly processed during unwinding. +;;;; +;;;; We don't need to save the BSP, because that is handled automatically. + +(define-vop (save-dynamic-state) + (:results (catch :scs (descriptor-reg)) + (alien-stack :scs (descriptor-reg))) + (:generator 13 + (load-tl-symbol-value catch *current-catch-block*) + (load-tl-symbol-value alien-stack *alien-stack*))) + +(define-vop (restore-dynamic-state) + (:args (catch :scs (descriptor-reg)) + (alien-stack :scs (descriptor-reg))) + #!+sb-thread (:temporary (:sc unsigned-reg) temp) + (:generator 10 + (store-tl-symbol-value catch *current-catch-block* temp) + (store-tl-symbol-value alien-stack *alien-stack* temp))) + +(define-vop (current-stack-pointer) + (:results (res :scs (any-reg control-stack))) + (:generator 1 + (move res esp-tn))) + +(define-vop (current-binding-pointer) + (:results (res :scs (any-reg descriptor-reg))) + (:generator 1 + (load-binding-stack-pointer res))) + +;;;; unwind block hackery + +;;; Compute the address of the catch block from its TN, then store into the +;;; block the current Fp, Env, Unwind-Protect, and the entry PC. +(define-vop (make-unwind-block) + (:args (tn)) + (:info entry-label) + (:temporary (:sc unsigned-reg) temp) + (:results (block :scs (any-reg))) + (:generator 22 + (inst lea block (catch-block-ea tn)) + (load-tl-symbol-value temp *current-unwind-protect-block*) + (storew temp block unwind-block-current-uwp-slot) + (storew ebp-tn block unwind-block-current-cont-slot) + (storew (make-fixup nil :code-object entry-label) +