- cmucl-cvs - mailman3.common-lisp.net

[Git][cmucl/cmucl][rtoy-amd64-p1] Remove functions that are defined in sse2-c-call.lisp.
by Raymond Toy 17 Aug '20

17 Aug '20

Raymond Toy pushed to branch rtoy-amd64-p1 at cmucl / cmucl Commits: 547b415d by Raymond Toy at 2020-08-16T21:20:47-07:00 Remove functions that are defined in sse2-c-call.lisp. Make amd64/c-call.lisp match x86/c-call.lisp better. - - - - - 1 changed file: - src/compiler/amd64/c-call.lisp Changes: ===================================== src/compiler/amd64/c-call.lisp ===================================== @@ -226,6 +226,7 @@ :foreign-data)) (inst mov res (make-ea :qword :base res)))) +#|| (define-vop (call-out) (:args (function :scs (sap-reg)) (args :more t)) @@ -296,6 +297,7 @@ (let ((delta (logandc2 (+ amount 3) 3))) (inst add rsp-tn delta))))) +||# (define-vop (alloc-alien-stack-space) (:info amount) (:results (result :scs (sap-reg any-reg))) @@ -323,6 +325,7 @@ (- other-pointer-type))) (inst add (make-ea :qword :base temp-tn) delta))))) +#|| ;;; Support for callbacks to Lisp. (export '(make-callback-trampoline callback-accessor-form)) @@ -372,5 +375,4 @@ pointer to the arguments." (let* ((length (finalize-segment segment))) (prog1 (alien::segment-to-trampoline segment length) (release-segment segment))))) - - +||# View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/547b415d065e7bcbc5921ec… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/547b415d065e7bcbc5921ec… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][rtoy-amd64-p1] 2 commits: emit-ea needs to support float-registers
by Raymond Toy 17 Aug '20

17 Aug '20

Raymond Toy pushed to branch rtoy-amd64-p1 at cmucl / cmucl Commits: 4f8e35c9 by Raymond Toy at 2020-08-15T10:36:10-07:00 emit-ea needs to support float-registers emit-ea with a tn arg needs to recognize a float-register. The x86 port does this so we just copied it over. - - - - - b626b6ff by Raymond Toy at 2020-08-16T12:14:13-07:00 Allow using R12 in emit-ea Currently R12 is not allowed as an index register (a carry over from x86 because R12 is ESP when looking at the low 3 bits of the register). However, if we emit the appropriate REX prefix, then I think R12 is ok to use here. Just assume REX was emitted and allow use of R12 for now. - - - - - 1 changed file: - src/compiler/amd64/insts.lisp Changes: ===================================== src/compiler/amd64/insts.lisp ===================================== @@ -150,7 +150,7 @@ (etypecase thing (tn (ecase (sb-name (sc-sb (tn-sc thing))) - (registers + ((registers float-registers) (emit-mod-reg-r/m-byte segment #b11 reg (reg-lower-3-bits thing))) (stack ;; Convert stack tns into an index off of RBP. @@ -188,9 +188,15 @@ (let ((ss (1- (integer-length scale))) (index (if (null index) #b100 + ;; FIXME: We're going to assume this is ok + ;; for now because we emitted an appropriate + ;; REX prefix already to allow using R12 + ;; here. + #+nil (if (= (reg-tn-encoding index) #b100) (error "Can't index off of RSP") - (reg-lower-3-bits index)))) + (reg-lower-3-bits index)) + (reg-lower-3-bits index))) (base (if (null base) #b101 (reg-lower-3-bits base)))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/26a395fd35b99ec9c9e78e… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/26a395fd35b99ec9c9e78e… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][rtoy-amd64-p1] 3 commits: Update make-ea to be qword instead of dword
by Raymond Toy 15 Aug '20

15 Aug '20

Raymond Toy pushed to branch rtoy-amd64-p1 at cmucl / cmucl Commits: a7036919 by Raymond Toy at 2020-08-14T21:53:19-07:00 Update make-ea to be qword instead of dword The effective addresses should be qwords instead of dwords for the base tn. - - - - - de0474f9 by Raymond Toy at 2020-08-14T21:54:05-07:00 Update reg-tn-encoding to handle float regs Copied over from the x86 version. - - - - - 26a395fd by Raymond Toy at 2020-08-14T21:55:31-07:00 Add xmm regs to single-reg and update printer Update the printer to print out xmm registers using "XMM" instead of "FR", which was pretty confusing. But if you remember FR8 is XMM0, everything works out. But better to use XMM0. - - - - - 3 changed files: - src/compiler/amd64/float-sse2.lisp - src/compiler/amd64/insts.lisp - src/compiler/amd64/vm.lisp Changes: ===================================== src/compiler/amd64/float-sse2.lisp ===================================== @@ -30,7 +30,7 @@ (macrolet ((ea-for-xf-desc (tn slot) `(make-ea - :dword :base ,tn + :qword :base ,tn :disp (- (* ,slot vm:word-bytes) vm:other-pointer-type)))) (defun ea-for-sf-desc (tn) (ea-for-xf-desc tn vm:single-float-value-slot)) @@ -70,7 +70,7 @@ (macrolet ((ea-for-xf-stack (tn kind) `(make-ea - :dword :base rbp-tn + :qword :base rbp-tn :disp (- (* (+ (tn-offset ,tn) (ecase ,kind (:single 1) (:double 2) (:long 3))) vm:word-bytes))))) @@ -605,12 +605,12 @@ (,stack-sc (if (= (tn-offset fp) esp-offset) (let* ((offset (* (tn-offset y) word-bytes)) - (ea (make-ea :dword :base fp :disp offset))) + (ea (make-ea :qword :base fp :disp offset))) ,@(ecase format (:single '((inst movss ea x))) (:double '((inst movsd ea x))))) (let ((ea (make-ea - :dword :base fp + :qword :base fp :disp (- (* (+ (tn-offset y) ,(case format (:single 1) ===================================== src/compiler/amd64/insts.lisp ===================================== @@ -82,10 +82,16 @@ (defun reg-tn-encoding (tn) (declare (type tn tn)) - (assert (eq (sb-name (sc-sb (tn-sc tn))) 'registers)) - (let ((offset (tn-offset tn))) - (logior (ash (logand offset 1) 2) - (ash offset -1)))) + ;; ea only has space for three bits of register number: regs r8 + ;; and up are selected by a REX prefix byte which caller is responsible + ;; for having emitted where necessary already + (ecase (sb-name (sc-sb (tn-sc tn))) + (registers + (let ((offset (mod (tn-offset tn) 16))) + (logior (ash (logand offset 1) 2) + (ash offset -1)))) + (float-registers + (mod (tn-offset tn) 8)))) (defstruct (ea (:constructor make-ea (size &key base index scale disp)) ===================================== src/compiler/amd64/vm.lisp ===================================== @@ -427,7 +427,9 @@ (def-random-reg-tns byte-reg al ah bl bh cl ch dl dh) ;; added by jrd -(def-random-reg-tns single-reg fr0 fr1 fr2 fr3 fr4 fr5 fr6 fr7) +(def-random-reg-tns single-reg + fr0 fr1 fr2 fr3 fr4 fr5 fr6 fr7 + xmm0 xmm1 xmm2 xmm3 xmm4 xmm5 xmm6 xmm7) ;; Added by pw. @@ -526,7 +528,11 @@ (< -1 offset (length name-vec)) (svref name-vec offset)) (format nil "<Unknown Reg: off=~D, sc=~A>" offset sc-name)))) - (float-registers (format nil "FR~D" offset)) + (float-registers + (format nil (if (< offset 8) + "FR~D" + "XMM~D") + (mod offset 8))) (stack (format nil "S~D" offset)) (constant (format nil "Const~D" offset)) (immediate-constant "Immed") View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/9e953fef8e75ea6d302ce5… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/9e953fef8e75ea6d302ce5… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][rtoy-amd64-p1] Update cross script to compile more stuff
by Raymond Toy 14 Aug '20

14 Aug '20

Raymond Toy pushed to branch rtoy-amd64-p1 at cmucl / cmucl Commits: 9e953fef by Raymond Toy at 2020-08-14T16:16:36-07:00 Update cross script to compile more stuff The cross-x86-amd64 script was missing some sse2 stuff from, say, cross-x86-x86.lisp. We need to compile sse2-array, sse2-c-call, and sse2-sap. But these don't exist yet, so we just copy them from x86 as is, except a renaming the registers eax to rax, etc. And comcom.lisp needs to be updated to compile these new files. Previously they were only compiled with a feature of :x86. But they really require :sse2, so change the requirement to :sse2 so they get compiled for amd64 too. The cross script also needs to be updated to load these new files. More work needed. We now get an error compiling compiler/float-tran: Error in function LISP::ASSERT-ERROR: The assertion (EQ (SB-NAME (SC-SB (TN-SC TN))) 'AMD64::REGISTERS) failed. Aborting... 0: (DEBUG:BACKTRACE 536870911 #<Stream for file "/home/toy/src/clnet/cmucl/dev/cmucl/xtarget-amd64/compile-compiler.log">) 1: ("DEFUN COMF" #<SIMPLE-ERROR {60C753BD}>) 2: (SIGNAL #<SIMPLE-ERROR {60C753BD}>) 3: (ERROR #<SIMPLE-ERROR {60C753BD}>) 4: (LISP::ASSERT-ERROR (EQ (SB-NAME #) 'AMD64::REGISTERS) NIL NIL) 5: (AMD64::REG-TN-ENCODING #<TN t1[FR8]>) 6: (AMD64::EMIT-SSE-INST #<NEW-ASSEM:SEGMENT #x60C4F12D NAME= "Regular"> #<TN t1[FR8]> #<AMD64::EA :DWORD base=#<TN t2[RDX]> disp=1> 243 ...) 7: (AMD64::MOVSS-INST-EMITTER #<NEW-ASSEM:SEGMENT #x60C4F12D NAME= "Regular"> #<VOP #x60C55D2D INFO= AMD64::MOVE-TO-SINGLE ARGS= #<TN-REF #x60C55CDD TN= #<TN t2[RDX]> WRITE-P= NIL VOP= AMD64::MOVE-TO-SINGLE> RESULTS= #<TN-REF #x60C55D05 TN= #<TN t3[S3]> WRITE-P= T VOP= AMD64::MOVE-TO-SINGLE>> #<TN t1[FR8]> #<AMD64::EA :DWORD base=#<TN t2[RDX]> disp=1>) 8: ("DEFINE-VOP (MOVE-TO-SINGLE)" #<VOP #x60C55D2D INFO= AMD64::MOVE-TO-SINGLE ARGS= #<TN-REF #x60C55CDD TN= #<TN t2[RDX]> WRITE-P= NIL VOP= AMD64::MOVE-TO-SINGLE> RESULTS= #<TN-REF #x60C55D05 TN= #<TN t3[S3]> WRITE-P= T VOP= AMD64::MOVE-TO-SINGLE>>) - - - - - 5 changed files: - + src/compiler/amd64/sse2-array.lisp - + src/compiler/amd64/sse2-c-call.lisp - + src/compiler/amd64/sse2-sap.lisp - src/tools/comcom.lisp - src/tools/cross-scripts/cross-x86-amd64.lisp Changes: ===================================== src/compiler/amd64/sse2-array.lisp ===================================== @@ -0,0 +1,392 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group(a)cs.cmu.edu. +;;; +(ext:file-comment + "$Header: src/compiler/x86/sse2-array.lisp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the x86 definitions for array operations. +;;; + +(in-package :amd64) +(intl:textdomain "cmucl-sse2") + +(macrolet + ((frob (type move copy scale) + (let ((ref-name (symbolicate "DATA-VECTOR-REF/SIMPLE-ARRAY-" type "-FLOAT")) + (c-ref-name (symbolicate "DATA-VECTOR-REF-C/SIMPLE-ARRAY-" type "-FLOAT")) + (set-name (symbolicate "DATA-VECTOR-SET/SIMPLE-ARRAY-" type "-FLOAT")) + (c-set-name (symbolicate "DATA-VECTOR-SET-C/SIMPLE-ARRAY-" type "-FLOAT")) + (result-sc (symbolicate type "-REG")) + (result-type (symbolicate type "-FLOAT")) + (array-sc (symbolicate "SIMPLE-ARRAY-" type "-FLOAT"))) + `(progn + (define-vop (,ref-name) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types ,array-sc positive-fixnum) + (:results (value :scs (,result-sc))) + (:result-types ,result-type) + (:guard (backend-featurep :sse2)) + (:generator 5 + (inst ,move value + (make-ea :dword :base object :index index :scale ,scale + :disp (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type))))) + (define-vop (,c-ref-name) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:info index) + (:arg-types ,array-sc (:constant (signed-byte 30))) + (:results (value :scs (,result-sc))) + (:result-types ,result-type) + (:guard (backend-featurep :sse2)) + (:generator 4 + (inst ,move value + (make-ea :dword :base object + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + (* ,(* 4 scale) index)) + vm:other-pointer-type))))) + (define-vop (,set-name) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (,result-sc) :target result)) + (:arg-types ,array-sc positive-fixnum ,result-type) + (:results (result :scs (,result-sc))) + (:result-types ,result-type) + (:guard (backend-featurep :sse2)) + (:generator 5 + (inst ,move (make-ea :dword :base object :index index :scale ,scale + :disp (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)) + value) + (unless (location= result value) + (inst ,copy result value)))) + + (define-vop (,c-set-name) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (value :scs (,result-sc) :target result)) + (:info index) + (:arg-types ,array-sc (:constant (signed-byte 30)) + ,result-type) + (:results (result :scs (,result-sc))) + (:result-types ,result-type) + (:guard (backend-featurep :sse2)) + (:generator 4 + (inst ,move (make-ea :dword :base object + :disp (- (+ (* vm:vector-data-offset + vm:word-bytes) + (* ,(* 4 scale) index)) + vm:other-pointer-type)) + value) + (unless (location= result value) + (inst ,copy result value)))))))) + (frob single movss movss 1) + (frob double movsd movsd 2) + (frob complex-single movlps movaps 2) + (frob complex-double movupd movapd 4)) + + +#+double-double +(progn +(define-vop (data-vector-ref/simple-array-double-double-float) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (index :scs (any-reg))) + (:arg-types simple-array-double-double-float positive-fixnum) + (:results (value :scs (double-double-reg))) + (:result-types double-double-float) + (:guard (backend-featurep :sse2)) + (:generator 7 + (let ((hi-tn (double-double-reg-hi-tn value))) + (inst movsd hi-tn + (make-ea :dword :base object :index index :scale 4 + :disp (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)))) + (let ((lo-tn (double-double-reg-lo-tn value))) + (inst movsd lo-tn (make-ea :dword :base object :index index :scale 4 + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + 8) + vm:other-pointer-type)))))) + +(define-vop (data-vector-ref-c/simple-array-double-double-float) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result)) + (:arg-types simple-array-double-double-float (:constant index)) + (:info index) + (:results (value :scs (double-double-reg))) + (:result-types double-double-float) + (:guard (backend-featurep :sse2)) + (:generator 5 + (let ((hi-tn (double-double-reg-hi-tn value))) + (inst movsd hi-tn + (make-ea :dword :base object + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + (* 16 index)) + vm:other-pointer-type)))) + (let ((lo-tn (double-double-reg-lo-tn value))) + (inst movsd lo-tn + (make-ea :dword :base object + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + (* 16 index) + 8) + vm:other-pointer-type)))))) + +(define-vop (data-vector-set/simple-array-double-double-float) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (index :scs (any-reg)) + (value :scs (double-double-reg) :target result)) + (:arg-types simple-array-double-double-float positive-fixnum + double-double-float) + (:results (result :scs (double-double-reg))) + (:result-types double-double-float) + (:guard (backend-featurep :sse2)) + (:generator 20 + (let ((value-real (double-double-reg-hi-tn value)) + (result-real (double-double-reg-hi-tn result))) + (inst movsd (make-ea :dword :base object :index index :scale 4 + :disp (- (* vm:vector-data-offset + vm:word-bytes) + vm:other-pointer-type)) + value-real) + (inst movsd result-real value-real)) + (let ((value-imag (double-double-reg-lo-tn value)) + (result-imag (double-double-reg-lo-tn result))) + (inst movsd (make-ea :dword :base object :index index :scale 4 + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + 8) + vm:other-pointer-type)) + value-imag) + (inst movsd result-imag value-imag)))) + +(define-vop (data-vector-set-c/simple-array-double-double-float) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (value :scs (double-double-reg) :target result)) + (:arg-types simple-array-double-double-float + (:constant index) + double-double-float) + (:info index) + (:results (result :scs (double-double-reg))) + (:result-types double-double-float) + (:guard (backend-featurep :sse2)) + (:generator 20 + (let ((value-real (double-double-reg-hi-tn value)) + (result-real (double-double-reg-hi-tn result))) + (inst movsd (make-ea :dword :base object + :disp (- (+ (* vm:vector-data-offset + vm:word-bytes) + (* 16 index)) + vm:other-pointer-type)) + value-real) + (inst movsd result-real value-real)) + (let ((value-imag (double-double-reg-lo-tn value)) + (result-imag (double-double-reg-lo-tn result))) + (inst movsd (make-ea :dword :base object + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + (* 16 index) + 8) + vm:other-pointer-type)) + value-imag) + (inst movsd result-imag value-imag)))) + +(define-vop (data-vector-ref/simple-array-complex-double-double-float) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (index :scs (any-reg))) + (:arg-types simple-array-complex-double-double-float positive-fixnum) + (:results (value :scs (complex-double-double-reg))) + (:result-types complex-double-double-float) + (:guard (backend-featurep :sse2)) + (:generator 7 + (let ((real-tn (complex-double-double-reg-real-hi-tn value))) + (inst movsd real-tn + (make-ea :dword :base object :index index :scale 8 + :disp (- (* vm:vector-data-offset vm:word-bytes) + vm:other-pointer-type)))) + (let ((real-tn (complex-double-double-reg-real-lo-tn value))) + (inst movsd real-tn + (make-ea :dword :base object :index index :scale 8 + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + 8) + vm:other-pointer-type)))) + (let ((imag-tn (complex-double-double-reg-imag-hi-tn value))) + (inst movsd imag-tn + (make-ea :dword :base object :index index :scale 8 + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + 16) + vm:other-pointer-type)))) + (let ((imag-tn (complex-double-double-reg-imag-lo-tn value))) + (inst movsd imag-tn + (make-ea :dword :base object :index index :scale 8 + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + 24) + vm:other-pointer-type)))))) + +(define-vop (data-vector-ref-c/simple-array-complex-double-double-float) + (:note "inline array access") + (:translate data-vector-ref) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result)) + (:arg-types simple-array-complex-double-double-float (:constant index)) + (:info index) + (:results (value :scs (complex-double-double-reg))) + (:result-types complex-double-double-float) + (:guard (backend-featurep :sse2)) + (:generator 5 + (let ((real-tn (complex-double-double-reg-real-hi-tn value))) + (inst movsd real-tn + (make-ea :dword :base object + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + (* 32 index)) + vm:other-pointer-type)))) + (let ((real-tn (complex-double-double-reg-real-lo-tn value))) + (inst movsd real-tn + (make-ea :dword :base object + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + (* 32 index) + 8) + vm:other-pointer-type)))) + (let ((imag-tn (complex-double-double-reg-imag-hi-tn value))) + (inst movsd imag-tn + (make-ea :dword :base object + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + (* 32 index) + 16) + vm:other-pointer-type)))) + (let ((imag-tn (complex-double-double-reg-imag-lo-tn value))) + (inst movsd imag-tn + (make-ea :dword :base object + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + (* 32 index) + 24) + vm:other-pointer-type)))))) + +(define-vop (data-vector-set/simple-array-complex-double-double-float) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (index :scs (any-reg)) + (value :scs (complex-double-double-reg) :target result)) + (:arg-types simple-array-complex-double-double-float positive-fixnum + complex-double-double-float) + (:results (result :scs (complex-double-double-reg))) + (:result-types complex-double-double-float) + (:guard (backend-featurep :sse2)) + (:generator 20 + (let ((value-real (complex-double-double-reg-real-hi-tn value)) + (result-real (complex-double-double-reg-real-hi-tn result))) + (inst movsd (make-ea :dword :base object :index index :scale 8 + :disp (- (* vm:vector-data-offset + vm:word-bytes) + vm:other-pointer-type)) + value-real) + (inst movsd result-real value-real)) + (let ((value-real (complex-double-double-reg-real-lo-tn value)) + (result-real (complex-double-double-reg-real-lo-tn result))) + (inst movsd (make-ea :dword :base object :index index :scale 8 + :disp (- (+ (* vm:vector-data-offset + vm:word-bytes) + 8) + vm:other-pointer-type)) + value-real) + (inst movsd result-real value-real)) + (let ((value-imag (complex-double-double-reg-imag-hi-tn value)) + (result-imag (complex-double-double-reg-imag-hi-tn result))) + (inst movsd (make-ea :dword :base object :index index :scale 8 + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + 16) + vm:other-pointer-type)) + value-imag) + (inst movsd result-imag value-imag)) + (let ((value-imag (complex-double-double-reg-imag-lo-tn value)) + (result-imag (complex-double-double-reg-imag-lo-tn result))) + (inst movsd (make-ea :dword :base object :index index :scale 8 + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + 24) + vm:other-pointer-type)) + value-imag) + (inst movsd result-imag value-imag)))) + +(define-vop (data-vector-set-c/simple-array-complex-double-double-float) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :result) + (value :scs (complex-double-double-reg) :target result)) + (:arg-types simple-array-complex-double-double-float + (:constant index) + complex-double-double-float) + (:info index) + (:results (result :scs (complex-double-double-reg))) + (:result-types complex-double-double-float) + (:guard (backend-featurep :sse2)) + (:generator 20 + (let ((value-real (complex-double-double-reg-real-hi-tn value)) + (result-real (complex-double-double-reg-real-hi-tn result))) + (inst movsd (make-ea :dword :base object + :disp (- (+ (* vm:vector-data-offset + vm:word-bytes) + (* 32 index)) + vm:other-pointer-type)) + value-real) + (inst movsd result-real value-real)) + (let ((value-real (complex-double-double-reg-real-lo-tn value)) + (result-real (complex-double-double-reg-real-lo-tn result))) + (inst movsd (make-ea :dword :base object + :disp (- (+ (* vm:vector-data-offset + vm:word-bytes) + (* 32 index) + 8) + vm:other-pointer-type)) + value-real) + (inst movsd result-real value-real)) + (let ((value-imag (complex-double-double-reg-imag-hi-tn value)) + (result-imag (complex-double-double-reg-imag-hi-tn result))) + (inst movsd (make-ea :dword :base object + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + (* 32 index) + 16) + vm:other-pointer-type)) + value-imag) + (inst movsd result-imag value-imag)) + (let ((value-imag (complex-double-double-reg-imag-lo-tn value)) + (result-imag (complex-double-double-reg-imag-lo-tn result))) + (inst movsd (make-ea :dword :base object + :disp (- (+ (* vm:vector-data-offset vm:word-bytes) + (* 32 index) + 24) + vm:other-pointer-type)) + value-imag) + (inst movsd result-imag value-imag)))) + +) ===================================== src/compiler/amd64/sse2-c-call.lisp ===================================== @@ -0,0 +1,87 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group(a)cs.cmu.edu. +;;; +(ext:file-comment + "$Header: src/compiler/x86/sse2-c-call.lisp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the VOPs and other necessary machine specific support +;;; routines for call-out to C. +;;; + +(in-package :amd64) +(use-package :alien) +(use-package :alien-internals) +(intl:textdomain "cmucl-sse2") + +;; Note: other parts of the compiler depend on vops having exactly +;; these names. Don't change them, unless you also change the other +;; parts of the compiler. + +(define-vop (call-out) + (:args (function :scs (sap-reg)) + (args :more t)) + (:results (results :more t)) + (:temporary (:sc unsigned-reg :offset rax-offset + :from :eval :to :result) rax) + (:temporary (:sc unsigned-reg :offset rcx-offset + :from :eval :to :result) rcx) + (:temporary (:sc unsigned-reg :offset rdx-offset + :from :eval :to :result) 5dx) + (:temporary (:sc single-stack) temp-single) + (:temporary (:sc double-stack) temp-double) + (:node-var node) + (:vop-var vop) + (:save-p t) + (:ignore args rcx rdx) + (:guard (backend-featurep :sse2)) + (:generator 0 + (cond ((policy node (> space speed)) + (move rax function) + (inst call (make-fixup (extern-alien-name "call_into_c") :foreign))) + (t + (inst call function) + ;; To give the debugger a clue. XX not really internal-error? + (note-this-location vop :internal-error))) + ;; FIXME: check that a float result is returned when expected. If + ;; we don't, we'll either get a NaN when doing the fstp or we'll + ;; leave an entry on the FPU and we'll eventually overflow the FPU + ;; stack. + (when (and results + (location= (tn-ref-tn results) xmm0-tn)) + ;; If there's a float result, it would have been returned + ;; in ST(0) according to the ABI. We want it in xmm0. + (sc-case (tn-ref-tn results) + (single-reg + (inst fstp (ea-for-sf-stack temp-single)) + (inst movss xmm0-tn (ea-for-sf-stack temp-single))) + (double-reg + (inst fstpd (ea-for-df-stack temp-double)) + (inst movsd xmm0-tn (ea-for-df-stack temp-double))))))) + +(define-vop (alloc-number-stack-space) + (:info amount) + (:results (result :scs (sap-reg any-reg))) + (:generator 0 + (assert (location= result rsp-tn)) + + (unless (zerop amount) + (let ((delta (logandc2 (+ amount 3) 3))) + (inst sub rsp-tn delta))) + ;; Align the stack to a 16-byte boundary. This is required an + ;; Darwin and should be harmless everywhere else. + (inst and esp-tn #xfffffff0) + (move result rsp-tn))) + +(define-vop (dealloc-number-stack-space) + (:info amount) + (:generator 0 + (unless (zerop amount) + (let ((delta (logandc2 (+ amount 3) 3))) + (inst add rsp-tn delta))))) ===================================== src/compiler/amd64/sse2-sap.lisp ===================================== @@ -0,0 +1,75 @@ +1;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group(a)cs.cmu.edu. +;;; +(ext:file-comment + "$Header: src/compiler/x86/sse2-sap.lisp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the x86 VM definition of SAP operations. +;;; + +(in-package :amd64) +(intl:textdomain "cmucl-sse2") + +(macrolet + ((frob (name type inst) + (let ((sc-type (symbolicate type "-REG")) + (res-type (symbolicate type "-FLOAT"))) + `(progn + (define-vop (,(symbolicate "SAP-REF-" name)) + (:translate ,(symbolicate "SAP-REF-" name)) + (:policy :fast-safe) + (:args (sap :scs (sap-reg)) + (offset :scs (signed-reg))) + (:arg-types system-area-pointer signed-num) + (:results (result :scs (,sc-type))) + (:result-types ,res-type) + (:generator 5 + (inst ,inst result (make-ea :dword :base sap :index offset)))) + (define-vop (,(symbolicate "SAP-REF-" type "-C")) + (:translate ,(symbolicate "SAP-REF-" type)) + (:policy :fast-safe) + (:args (sap :scs (sap-reg))) + (:arg-types system-area-pointer (:constant (signed-byte 32))) + (:info offset) + (:results (result :scs (,sc-type))) + (:result-types ,res-type) + (:generator 4 + (inst ,inst result (make-ea :dword :base sap :disp offset)))) + (define-vop (,(symbolicate "%SET-SAP-REF-" type)) + (:translate ,(symbolicate "%SET-SAP-REF-" type)) + (:policy :fast-safe) + (:args (sap :scs (sap-reg) :to (:eval 0)) + (offset :scs (signed-reg) :to (:eval 0)) + (value :scs (,sc-type))) + (:arg-types system-area-pointer signed-num ,res-type) + (:results (result :scs (,sc-type))) + (:result-types ,res-type) + (:generator 5 + (inst ,inst (make-ea :dword :base sap :index offset) value) + (unless (location= result value) + (inst ,inst result value)))) + (define-vop (,(symbolicate "%SET-SAP-REF-" type "-C")) + (:translate ,(symbolicate "%SET-SAP-REF-" type)) + (:policy :fast-safe) + (:args (sap :scs (sap-reg) :to (:eval 0)) + (value :scs (,sc-type))) + (:arg-types system-area-pointer (:constant (signed-byte 32)) + ,res-type) + (:info offset) + (:results (result :scs (,sc-type))) + (:result-types ,res-type) + (:generator 4 + (inst ,inst (make-ea :dword :base sap :disp offset) value) + (unless (location= result value) + (inst ,inst result value)))))))) + (frob double double movsd) + (frob single single movss) + ;; Not really right since these aren't long floats + (frob long double movsd)) ===================================== src/tools/comcom.lisp ===================================== @@ -180,7 +180,7 @@ (vmdir "target:compiler/float")) :byte-compile *byte-compile*) (comf (vmdir "target:compiler/sap") :byte-compile *byte-compile*) -(when (c:target-featurep :x86) +(when (c:target-featurep :sse2) (comf (vmdir "target:compiler/sse2-sap") :byte-compile *byte-compile*)) (comf (vmdir "target:compiler/system") :byte-compile *byte-compile*) @@ -192,7 +192,7 @@ (comf (vmdir "target:compiler/debug") :byte-compile *byte-compile*) (comf (vmdir "target:compiler/c-call") :byte-compile *byte-compile*) -(when (c:target-featurep :x86) +(when (c:target-featurep :sse2) (comf (vmdir "target:compiler/sse2-c-call") :byte-compile *byte-compile*)) (when (c:target-featurep :alien-callback) @@ -206,7 +206,7 @@ ;; Must come before array.lisp because array.lisp wants to use some ;; vops as templates. -(when (c:target-featurep :x86) +(when (c:target-featurep :sse2) (comf (vmdir "target:compiler/sse2-array") :byte-compile *byte-compile*)) ===================================== src/tools/cross-scripts/cross-x86-amd64.lisp ===================================== @@ -273,6 +273,7 @@ (in-package :cl-user) +(print "***Comcom") (load "target:tools/comcom") ;;; Load the new backend. @@ -284,7 +285,7 @@ '("target:assembly/" "target:assembly/amd64/")) ;; Load the backend of the compiler. - +(print "***Load backend") (in-package "C") (load "vm:vm-fndb") @@ -299,6 +300,7 @@ (load "target:compiler/srctran") (load "vm:vm-typetran") (load "target:compiler/float-tran") +(load "target:compiler/float-tran-dd") (load "target:compiler/saptran") (load "vm:macros") @@ -309,9 +311,10 @@ (load "vm:primtype") (load "vm:move") (load "vm:sap") +(load "vm:sse2-sap") (load "vm:system") (load "vm:char") -(load "vm:float") +(load "vm:float-sse2") (load "vm:memory") (load "vm:static-fn") @@ -319,12 +322,13 @@ (load "vm:cell") (load "vm:subprim") (load "vm:debug") -(load "vm:c-call") +(load "vm:sse2-c-call") (load "vm:print") (load "vm:alloc") (load "vm:call") (load "vm:nlx") (load "vm:values") +(load "vm:sse2-array") (load "vm:array") (load "vm:pred") (load "vm:type-vops") View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/9e953fef8e75ea6d302ce55… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/9e953fef8e75ea6d302ce55… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][rtoy-amd64-p1] Define double-double-float-digits
by Raymond Toy 12 Aug '20

12 Aug '20

Raymond Toy pushed to branch rtoy-amd64-p1 at cmucl / cmucl Commits: b323ffa9 by Raymond Toy at 2020-08-11T20:06:28-07:00 Define double-double-float-digits Forgot to grab this from the x86 version. Fixes one compile error. - - - - - 1 changed file: - src/compiler/amd64/parms.lisp Changes: ===================================== src/compiler/amd64/parms.lisp ===================================== @@ -165,6 +165,10 @@ (defconstant long-float-digits (+ (byte-size long-float-significand-byte) 32 1)) +#+double-double +(defconstant double-double-float-digits + (* 2 double-float-digits)) + ;;; pfw -- from i486 microprocessor programmers reference manual (defconstant float-invalid-trap-bit (ash 1 0)) (defconstant float-denormal-trap-bit (ash 1 1)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/b323ffa95870f5e67a99f29… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/b323ffa95870f5e67a99f29… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][rtoy-issue-78-unneded-code-code-in-complex-acos] Revert changes to atanh
by Raymond Toy 01 Jun '20

01 Jun '20

Raymond Toy pushed to branch rtoy-issue-78-unneded-code-code-in-complex-acos at cmucl / cmucl Commits: 6ed52aa0 by Raymond Toy at 2020-05-31T21:01:13-07:00 Revert changes to atanh Still need the special case for real args to get the right branch cuts. Haven't yet figured out why the current code doesn't work when the arg is a pure real. Soemthing to do with computing y, but not sure how to get that to work out without doing just explicitly checking for real args. In that case, it's just much easier to change the arg to have the correct imaginary component to make it continuous with the desired quadrant. - - - - - 1 changed file: - src/code/irrat.lisp Changes: ===================================== src/code/irrat.lisp ===================================== @@ -1510,7 +1510,7 @@ Z may be any number, but the result is always a complex." ;; NOTE: this differs from what the CLHS says for the continuity. ;; Instead of the text in the CLHS, we choose to use the definition ;; to derive the correct values. - (if (and nil (realp z)) + (if (realp z) (complex-atanh (complex (float z) (- (* 0 (float z))))) (let* ( ;; Constants (theta (/ (sqrt most-positive-double-float) 4.0d0)) @@ -1518,9 +1518,10 @@ Z may be any number, but the result is always a complex." (half-pi (/ pi 2.0d0)) (rp (float (realpart z) 1.0d0)) (beta (float-sign rp 1.0d0)) - (z* (conjugate z)) - (x (* beta (realpart z*))) - (y (* beta (imagpart z*))) + ;; x+iy = beta*conjugate(z), but being careful to produce + ;; a signed-zero if z is rational. + (x (* beta (realpart z))) + (y (* beta (- (float (imagpart z) 1d0)))) (eta 0.0d0) (nu 0.0d0)) ;; Shouldn't need this declare. @@ -1562,8 +1563,7 @@ Z may be any number, but the result is always a complex." (atan (* 2.0d0 y) (- (* (- 1.0d0 x) (+ 1.0d0 x)) - (square t1))))) - (format t "eta = ~A nu ~A~%" eta nu)))) + (square t1)))))))) (coerce-to-complex-type (* beta eta) (- (* beta nu)) z))))) @@ -1715,16 +1715,13 @@ Z may be any number, but the result is always a complex." #+double-double (when (typep z '(or double-double-float (complex double-double-float))) (return-from complex-acos (dd-complex-acos z))) - (if (and nil (realp z) (> z 1)) - ;; acos is continuous in quadrant IV in this case. - (complex-acos (complex z -0f0)) - (let ((sqrt-1+z (complex-sqrt (1+z z))) - (sqrt-1-z (complex-sqrt (1-z z)))) - (with-float-traps-masked (:divide-by-zero) - (complex (* 2 (atan (/ (realpart sqrt-1-z) - (realpart sqrt-1+z)))) - (asinh (imagpart (* (conjugate sqrt-1+z) - sqrt-1-z)))))))) + (let ((sqrt-1+z (complex-sqrt (1+z z))) + (sqrt-1-z (complex-sqrt (1-z z)))) + (with-float-traps-masked (:divide-by-zero) + (complex (* 2 (atan (/ (realpart sqrt-1-z) + (realpart sqrt-1+z)))) + (asinh (imagpart (* (conjugate sqrt-1+z) + sqrt-1-z))))))) ;; acosh(z) = 2*log(sqrt((x+1)/2) + sqrt((x-1)/2)) ;; @@ -1823,16 +1820,13 @@ Z may be any number, but the result is always a complex." #+double-double (when (typep z '(or double-double-float (complex double-double-float))) (return-from complex-asin (dd-complex-asin z))) - (if (and nil (realp z) (> z 1)) - ;; asin is continuous in quadrant IV in this case. - (complex-asin (complex z -0f0)) - (let ((sqrt-1-z (complex-sqrt (1-z z))) - (sqrt-1+z (complex-sqrt (1+z z)))) - (with-float-traps-masked (:divide-by-zero) - (complex (atan (/ (realpart z) - (realpart (* sqrt-1-z sqrt-1+z)))) - (asinh (imagpart (* (conjugate sqrt-1-z) - sqrt-1+z)))))))) + (let ((sqrt-1-z (complex-sqrt (1-z z))) + (sqrt-1+z (complex-sqrt (1+z z)))) + (with-float-traps-masked (:divide-by-zero) + (complex (atan (/ (realpart z) + (realpart (* sqrt-1-z sqrt-1+z)))) + (asinh (imagpart (* (conjugate sqrt-1-z) + sqrt-1+z))))))) (defun complex-asinh (z) "Compute asinh z = log(z + sqrt(1 + z*z)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/6ed52aa06cd1b22f33b9417… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/6ed52aa06cd1b22f33b9417… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][rtoy-issue-78-unneded-code-code-in-complex-acos] Derive the values on the branch cuts for acosh
by Raymond Toy 24 May '20

24 May '20

Raymond Toy pushed to branch rtoy-issue-78-unneded-code-code-in-complex-acos at cmucl / cmucl Commits: 00d0cb6f by Raymond Toy at 2020-05-24T10:17:44-07:00 Derive the values on the branch cuts for acosh Conclusion: on the branch cuts, acosh is continuous with quadrant I for 9 <= x < 1 and with quadrant II for x < -1. This, of course, is consistent with Kahan's coutner-clowkwise continuity principla. - - - - - 1 changed file: - src/code/irrat.lisp Changes: ===================================== src/code/irrat.lisp ===================================== @@ -1726,6 +1726,46 @@ Z may be any number, but the result is always a complex." (asinh (imagpart (* (conjugate sqrt-1+z) sqrt-1-z)))))))) +;; acosh(z) = 2*log(sqrt((x+1)/2) + sqrt((x-1)/2)) +;; +;; For z = x, 0 <= x < 1 +;; acosh(z) = 2*log(sqrt((x+1)/2) + sqrt((x-1)/2)) +;; = 2*log(sqrt((x+1)/2) + i*sqrt((1-x)/2)) +;; = 2*(log(1) + i*arg(sqrt((x+1)/2) + i*sqrt((1-x)/2))) +;; = 2*i*atan(sqrt((1-x)/2), sqrt((x+1)/2)) +;; = 2*i*atan(sqrt((1-x)/(1+x))) +;; +;; For z = -x, x > 1 +;; acosh(z) = 2*log(sqrt((1-x)/2) + sqrt((-x-1)/2)) +;; = 2*log((i*sqrt((x-1)/2) + 0 + i*sqrt((1+x)/2)) + 0) +;; = 2*log(i*(sqrt((x-1)/2) + sqrt((1+x)/2)) + 0) +;; = 2*(log(sqrt((x-1)/2) + sqrt((1+x)/2)) + i*arg(sqrt((x-1)/2) + sqrt((1+x)/2)) + 0) +;; = 2*(log(sqrt((x-1)/2) + sqrt((1+x)/2)) + i*pi/2) +;; = 2*log(x+sqrt(x+1)*sqrt(x-1)) + i*pi +;; +;; For z = x + i0, 0 <= x < 1 +;; acosh(z) = 2*log(sqrt((1+x)/2+i0) + sqrt((x-1)/2+i0)) +;; = 2*log(sqrt((1+x)/2)+i0 + i*sqrt((1-x)/2) + 0) +;; = 2*log(sqrt((1+x)/2) + i*sqrt((1-x)/2)) +;; = 2*(log(1) + i*arg(sqrt((1+x)/2) + i*sqrt((1-x)/2)) +;; = 0 + 2*i*atan(sqrt((1-x)/2)/sqrt((1+x)/2)) + +;; = 0 + 2*i*atan(sqrt((1-x)/(1+x)) +;; +;; This is the same value we got for acosh(x), 0 <= x < 1. Hence, +;; acosh is continuous with quadrant I on the branch cut for 0 <= x < +;; 1. +;; +;; Finally, for z = -x + i0, x > 1 +;; acosh(z) = 2*log(sqrt((1-x)/2+i0) + sqrt((-x-1)/2+i0)) +;; = 2*log(i*sqrt((x-1)/2) + 0 + i*sqrt((1+x)/2 + i0)) +;; = 2*log(i*(sqrt((x-1)/2) + sqrt((1+x)/2)) + 0) +;; = 2*(log(sqrt((x-1)/2) + sqrt((1+x)/2)) + i*arg(0, (sqrt((x-1)/2) + sqrt((1+x)/2))) +;; = 2*(log(sqrt((x-1)/2) + sqrt((1+x)/2)) + i*pi/2) +;; = 2*log(sqrt((x-1)/2) + sqrt((1+x)/2)) + i*pi +;; +;; We see that this is the same expression for acosh(z), z < -1. +;; Hence, acosh(z) is continuous with quadrant II on the branch cut x +;; < -1. (defun complex-acosh (z) "Compute acosh z = 2 * log(sqrt((z+1)/2) + sqrt((z-1)/2)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/00d0cb6f5f931b01000bef1… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/00d0cb6f5f931b01000bef1… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][rtoy-issue-78-unneded-code-code-in-complex-acos] Derive the values on the branch cuts for atanh
by Raymond Toy 24 May '20

24 May '20

Raymond Toy pushed to branch rtoy-issue-78-unneded-code-code-in-complex-acos at cmucl / cmucl Commits: fe15b0a3 by Raymond Toy at 2020-05-24T08:10:39-07:00 Derive the values on the branch cuts for atanh Conclusion: atanh is continuous with quadrant Iv for x > 1 and quadrant II for x < -1. This, of course, is consistent with Kahan's coutner-clowkwise continuity principla. - - - - - 1 changed file: - src/code/irrat.lisp Changes: ===================================== src/code/irrat.lisp ===================================== @@ -1449,7 +1449,44 @@ Z may be any number, but the result is always a complex." ;; +infinity, but the following code returns approx 176 + i*pi/4. The ;; reason for the imaginary part is caused by the fact that arg i*y is ;; never 0 since we have positive and negative zeroes. - +;; +;; The branch cut for atanh is on the real axis for x < -1 and x > 1. +;; Let's derive the values on the branch cut. +;; +;; atanh(z) = 1/2*(log(1+z)-log(1-z)) +;; +;; For z = x, x > 1: +;; atanh(x) = 1/2*(log(1+x) - log(1-x)) +;; = 1/2*(log(1+x) - [log(x-1) + i*arg(1-x)) +;; = 1/2*(log(1+x) - (log(x-1) + i*pi)) +;; = 1/2*(log(1+x) - log(x-1) _ i*pi) +;; = 1/2*log((1+x)/(x-1)) - i*pi/2 +;; +;; For z = -x, x > 1 +;; atanh(x) = 1/2*(log(1-x) - log(1+x)) +;; = 1/2*((log(x-1) + i*arg(1-x)) - log(1+x)) +;; = 1/2*((log(x-1) + i*pi) - log(1+x)) +;; = 1/2*(log((x-1)/(x+1)) + i*pi) +;; = 1/2*log((x-1)/(x+1)) + i*pi/2 +;; +;; For z = x - i0, x > 1 +;; atanh(z) = 1/2*(log(1+x - i0) - log(1-x+i0)) +;; = 1/2*(log(1+x) + i*arg(1+x,-0) - (log(x-1) + i*arg(1-x, +0))) +;; = 1/2*(log(1+x) - i*0 - (log(x-1) + i*pi)) +;; = 1/2*(log(1+x) - log(x-1) - i*pi) +;; = 1/2*log((1+x)/(x-1)) - i*pi/2 +;; +;; This is the same answer we get for atanh(x), x > 1. Hence, atanh +;; is continuous with quadrant IV along the branch cut x > 1. +;; +;; Similary, for z = -x + i0, x > 1: +;; atanh(z) = 1/2*(log(1-x + i0) - log(1+x-i0)) +;; = 1/2*((log(x-1) + i*arg(1-x, +0)) - (log(1+x)+i*arg(1+x, -0))) +;; = 1/2*(log(x-1) + i*pi - (log(1+x) - i0)) +;; = 1/2*(log(x-1) - log(1+x) + i*pi) +;; = 1/2*log((x-1)/(x+1)) + i*pi/2 +;; This is same answer as atanh(x), x < -1. Thus, atanh is continuous +;; with quadrant II on the branch cut for x < -1 (defun complex-atanh (z) "Compute atanh z = (log(1+z) - log(1-z))/2" (declare (number z)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/fe15b0a31119288135a67ab… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/fe15b0a31119288135a67ab… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][rtoy-issue-78-unneded-code-code-in-complex-acos] Add derivation for the values on the branch cut for acos
by Raymond Toy 23 May '20

23 May '20

Raymond Toy pushed to branch rtoy-issue-78-unneded-code-code-in-complex-acos at cmucl / cmucl Commits: 53cf274f by Raymond Toy at 2020-05-23T13:46:52-07:00 Add derivation for the values on the branch cut for acos We derive formulas for the values of acos(x) for x > 1 and x < -1 and show that for x > 1, acos is continuous with quadrant IV and for x < -1, acos is continuous with quadrant II. This matches Kahan's counter-clockwise countinuity for values on the branch cuts. - - - - - 1 changed file: - src/code/irrat.lisp Changes: ===================================== src/code/irrat.lisp ===================================== @@ -1334,6 +1334,27 @@ and Y are coerced to single-float." (t (values rho 0))))))) +;; sqrt(z) = z^(1/2) +;; = exp(1/2*log(z)) +;; +;; Some special values, with x > 0 +;; sqrt(x + i*0) = exp(1/2*log(x+i*0)) +;; = exp(1/2*(log(x)+i*0)) +;; = exp(1/2*log(x)+i*0) +;; = exp(1/2*log(x))*exp(i*0) +;; = sqrt(x)*(cos 0 + i*sin(0)) +;; = sqrt(x) + i*0 +;; sqrt(x - i*0) = exp(1/2*log(x-i*0)) +;; = exp(1/2*(log(x) - i*0)) +;; = exp(1/2*log(x) - i*0) +;; = exp(1/2*log(x))*exp(-i*0) +;; = sqrt(x)*(cos(-0) + i*sin(-0)) +;; = sqrt(x) - i*0 +;; Kahan also gives the following for b > 0 +;; sqrt(-b+/-i*0) = +0 +/- i*sqrt(b) +;; sqrt(x +/- i*inf) = +inf +/- i*inf for all finite x. +;; sqrt(inf +/- i*b) = +inf +/- i*0 +;; sqrt(-inf +/- i*b) = +0 +/- i*inf (defun complex-sqrt (z) "Principle square root of Z @@ -1604,6 +1625,51 @@ Z may be any number, but the result is always a complex." (+ z 1) (complex (+ (realpart z) 1) (imagpart z)))) +;; acos(z) = 2*log(sqrt((1+z)/2) + i*sqrt((1-z)/2))/i +;; = pi/2 - asin(z) +;; +;; In particular for z = x > 1: +;; acos(x) = 2/i*log(sqrt((x+1)/2) + i*sqrt((1-x)/2)) +;; = 2/i*log(sqrt((x+1)/2) + i*i*sqrt((x-1)/2)) +;; = 2/i*log(sqrt((x+1)/2) - sqrt((x-1)/2)) +;; = -2*i*log(sqrt((x+1)/2) - sqrt((x-1)/2)) +;; = -i*log(x-sqrt(x-1)*sqrt(x+1)) +;; Thus, acos(2) = -i*log(2-sqrt(3) = -i*1.31695... +;; +;; Similarly for z = -x, x > 1: +;; acos(-x) = 2/i*log(sqrt((1-x)/2) + i*sart((1+x)/2)) +;; = 2/i*log(i*sqrt((x-1)/2) + i*sqrt((1+x)/2)) +;; = 2/i*log(i*(sqrt((x+1)/2)+sqrt((x-1)/2))) +;; = 2/i*(log(sqrt((x+1)/2)+sqrt((x-1)/2)) + i*pi/2) +;; = -i*2*log(sqrt((x+1)/2)+sqrt((x-1)/2)) - pi +;; = -pi - i*log(x+sqrt(x+1)*(sqrt(x-1))) +;; +;; Thus acos(-2) = -pi - i*log(2+sqrt(3)) = -pi -i*1.31695... +;; +;; Now see what aacos(x-i0) for x > 1 is: +;; acos(x-i*0) = 2/i*log(sqrt((x+1)/2-i*0) + i*sqrt((1-x)/2+i*0)) +;; = 2/i*log(sqrt((x+1)/2) -i*0+ i*(0+i*sqrt((x-1)/2))) +;; = 2/i*log(sqrt((x+1)/2) - sqrt((x-1)/2) - i*0) +;; = 2/i*[log(sqrt((x+1)/2) - sqrt((x-1)/2)) - i*0] +;; = -i*[2*log(sqrt((x+1)/2) - sqrt((x-1)/2)) - i*0] +;; = -i*log(x-sqrt(x-1)*sqrt(x+1)) + 0 +;; +;; Thus acos(2 - i*0) is the same as acos(2). That is, acos is +;; continuous with quadrant IV for x > 1. +;; +;; For acos(-x+i0), x > 1: +;; acos(-x+i0) = 2/i*log(sqrt((1-x+i0)/2) + i*sqrt((1+x-i0)/2)) +;; = 2/i*log(sqrt((1-x)/2+i0) + i*sqrt((1+x)/2-i0)) +;; = 2/i*log((i*sqrt((x-1)/2) + 0) + i*(sqrt((1+x)/2)-i0)) +;; = 2/i*log(i*sqrt((x-1)/2) + i*sqrt((1+x)/2) + 0) +;; = 2/i*log(i*(sqrt((x-1)/2 + sqrt(1+x)/2)) + 0) +;; = 2/i*(log(sqrt(x+sqrt(x-1)*sqrt(x+1))) + i*pi/2) +;; = -i*log(x+sqrt(x-1)*sqrt(x+1)) + pi +;; = pi - i*log(x+sqrt(x-1)*sqrt(x+1)) +;; +;; Thus acos(-2+i0) = pi - i*log(sqrt(3)+2) = pi -i*1.31695, and this +;; equal acos(-2). This means acos is continuous with quadrant II. +;; (defun complex-acos (z) "Compute acos z = pi/2 - asin z View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/53cf274f24589c7870593af… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/53cf274f24589c7870593af… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch rtoy-issue-78-unneded-code-code-in-complex-acos
by Raymond Toy 22 May '20

22 May '20

Raymond Toy pushed new branch rtoy-issue-78-unneded-code-code-in-complex-acos at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/rtoy-issue-78-unneded-cod… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0