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

[Git][cmucl/cmucl] Pushed new branch rtoy-issue-84-remove-unix-glibc2
by Raymond Toy 26 Aug '20

26 Aug '20

Raymond Toy pushed new branch rtoy-issue-84-remove-unix-glibc2 at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/rtoy-issue-84-remove-unix… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][rtoy-amd64-p1] SAP offsets should be 64 bits
by Raymond Toy 23 Aug '20

23 Aug '20

Raymond Toy pushed to branch rtoy-amd64-p1 at cmucl / cmucl Commits: ef49a0dc by Raymond Toy at 2020-08-23T08:51:57-07:00 SAP offsets should be 64 bits Just hard-code 64 like for alpha for now. We can fix this up later. - - - - - 1 changed file: - src/code/sap.lisp Changes: ===================================== src/code/sap.lisp ===================================== @@ -80,19 +80,19 @@ (defun int-sap (int) "Converts an integer into a System Area Pointer." - (declare (type (unsigned-byte #-alpha #.vm:word-bits #+alpha 64) int)) + (declare (type (unsigned-byte #-(or alpha amd64) #.vm:word-bits #+(or alpha amd64) 64) int)) (int-sap int)) (defun sap-ref-8 (sap offset) "Returns the 8-bit byte at OFFSET bytes from SAP." (declare (type system-area-pointer sap) - (type (signed-byte #-alpha #.vm:word-bits #+alpha 64) offset)) + (type (signed-byte #-(or alpha amd64) #.vm:word-bits #+(or alpha amd64) 64) offset)) (sap-ref-8 sap offset)) (defun sap-ref-16 (sap offset) "Returns the 16-bit word at OFFSET bytes from SAP." (declare (type system-area-pointer sap) - (type (signed-byte #-alpha #.(1- vm:word-bits) #+alpha 63) offset)) + (type (signed-byte #-(or alpha amd64) #.(1- vm:word-bits) #+(or alpha amd64) 63) offset)) (sap-ref-16 sap offset)) (defun sap-ref-32 (sap offset) @@ -110,7 +110,7 @@ (defun sap-ref-sap (sap offset) "Returns the 32-bit system-area-pointer at OFFSET bytes from SAP." (declare (type system-area-pointer sap) - (type (signed-byte #-alpha #.vm:word-bits #+alpha 64) offset)) + (type (signed-byte #-(or alpha amd64) #.vm:word-bits #+(or alpha amd64) 64) offset)) (sap-ref-sap sap offset)) (defun sap-ref-single (sap offset) @@ -135,13 +135,13 @@ (defun signed-sap-ref-8 (sap offset) "Returns the signed 8-bit byte at OFFSET bytes from SAP." (declare (type system-area-pointer sap) - (type (signed-byte #-alpha #.vm:word-bits #+alpha 64) offset)) + (type (signed-byte #-(or alpha amd64) #.vm:word-bits #+(or alpha amd64) 64) offset)) (signed-sap-ref-8 sap offset)) (defun signed-sap-ref-16 (sap offset) "Returns the signed 16-bit word at OFFSET bytes from SAP." (declare (type system-area-pointer sap) - (type (signed-byte #-alpha #.(1- vm:word-bits) #+alpha 63) offset)) + (type (signed-byte #-(or alpha amd64) #.(1- vm:word-bits) #+(or alpha amd64) 63) offset)) (signed-sap-ref-16 sap offset)) (defun signed-sap-ref-32 (sap offset) @@ -158,13 +158,13 @@ (defun %set-sap-ref-8 (sap offset new-value) (declare (type system-area-pointer sap) - (type (signed-byte #-alpha #.vm:word-bits #+alpha 64) offset) + (type (signed-byte #-(or alpha amd64) #.vm:word-bits #+(or alpha amd64) 64) offset) (type (unsigned-byte 8) new-value)) (setf (sap-ref-8 sap offset) new-value)) (defun %set-sap-ref-16 (sap offset new-value) (declare (type system-area-pointer sap) - (type (signed-byte #-alpha #.(1- vm:word-bits) #+alpha 63) offset) + (type (signed-byte #-(or alpha amd64) #.(1- vm:word-bits) #+(or alpha amd64) 63) offset) (type (unsigned-byte 16) new-value)) (setf (sap-ref-16 sap offset) new-value)) @@ -182,13 +182,13 @@ (defun %set-signed-sap-ref-8 (sap offset new-value) (declare (type system-area-pointer sap) - (type (signed-byte #-alpha #.vm:word-bits #+alpha 64) offset) + (type (signed-byte #-(or alpha amd64) #.vm:word-bits #+(or alpha amd64) 64) offset) (type (signed-byte 8) new-value)) (setf (signed-sap-ref-8 sap offset) new-value)) (defun %set-signed-sap-ref-16 (sap offset new-value) (declare (type system-area-pointer sap) - (type (signed-byte #-alpha #.(1- vm:word-bits) #+alpha 63) offset) + (type (signed-byte #-(or alpha amd64) #.(1- vm:word-bits) #+(or alpha amd64) 63) offset) (type (signed-byte 16) new-value)) (setf (signed-sap-ref-16 sap offset) new-value)) @@ -206,7 +206,7 @@ (defun %set-sap-ref-sap (sap offset new-value) (declare (type system-area-pointer sap new-value) - (type (signed-byte #-alpha #.vm:word-bits #+alpha 64) offset)) + (type (signed-byte #-(or alpha amd64) #.vm:word-bits #+(or alpha amd64) 64) offset)) (setf (sap-ref-sap sap offset) new-value)) (defun %set-sap-ref-single (sap offset new-value) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/ef49a0dceb16179ff332987… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/ef49a0dceb16179ff332987… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][rtoy-amd64-p1] Make cross-x86-amd64 look more like cross-x86-x86
by Raymond Toy 20 Aug '20

20 Aug '20

Raymond Toy pushed to branch rtoy-amd64-p1 at cmucl / cmucl Commits: aa7b0b27 by Raymond Toy at 2020-08-20T07:38:21-07:00 Make cross-x86-amd64 look more like cross-x86-x86 Make the cross compiler script look more like the x86-x86 one. * Don't load float-tran-dd since the x86 script doesn't. * Forgot to load vm:c-call. Fixes error about make-call-out-tns not existing. * Don't load compiler/codegen and compiler/array-tran since the x86 script doesn't. Not sure why these are here, but just comment them out for now. Still get this error: ; Compiling DEFUN INT-INIT-XORO-STATE: Structure for accessor C:TN-OFFSET is not a C:TN: #<RETURN #x6034AD55 LAMBDA= #<LAMBDA #x603494BD NAME= (FLET MAKE-DOUBLE INT-INIT-XORO-STATE) TYPE= #<FUNCTION-TYPE (FUNCTION ((UNSIGNED-BYTE 64)) DOUBLE-FLOAT)> WHERE-FROM= :DEFINED VARS= (X)> RESULT-TYPE= #<NUMERIC-TYPE DOUBLE-FLOAT>> Aborting... 0: (DEBUG:BACKTRACE 536870911 #<Stream for file "/home/toy/src/clnet/cmucl/dev/cmucl/xtarget-amd64/compile-lisp.log">) 1: ("DEFUN COMF" #<SIMPLE-TYPE-ERROR {60A80CBD}>) 2: (SIGNAL #<SIMPLE-TYPE-ERROR {60A80CBD}>) 3: (ERROR SIMPLE-TYPE-ERROR :DATUM #<RETURN #x6034AD55 LAMBDA= #<LAMBDA #x603494BD NAME= # TYPE= #<FUNCTION-TYPE #> WHERE-FROM= :DEFINED VARS= #> RESULT-TYPE= #<NUMERIC-TYPE DOUBLE-FLOAT>> :EXPECTED-TYPE ...) 4: ("DEFUN STRUCTURE-SLOT-ACCESSOR" #<unavailable-arg>) 5: (C::DO-CALL #<Code Object "DEFUN INLINE-ALLOCATION" {6171372F}> 11 12 143 ...) 6: ("DEFINE-VOP (MOVE-FROM-DOUBLE)" #<C::VOP #x603C3005 INFO= AMD64::MOVE-FROM-DOUBLE ARGS= #<C:TN-REF #x603C2FAD TN= #<TN t1[XMM1]> WRITE-P= NIL VOP= AMD64::MOVE-FROM-DOUBLE> RESULTS= #<C:TN-REF #x603C2FD5 TN= #<TN t2[RSI]> WRITE-P= T VOP= AMD64::MOVE-FROM-DOUBLE>>) 7: (C::GENERATE-CODE #<C:COMPONENT #x603517B5 NAME= "DEFUN INT-INIT-XORO-STATE">) And then finally in worldbuild, we get: /home/toy/src/clnet/cmucl/dev/cmucl/xtarget-amd64/code/type.amd64f End-of-File on #<Stream for file "/home/toy/src/clnet/cmucl/dev/cmucl/xtarget-amd64/code/type.amd64f"> [Condition of type END-OF-FILE] I'm guessing the fops are not getting written out correctly or the fasl loader isn't interpreting the lengths correctly. Not sure exactly what. It would be nice if we had a fasl dumper to print out the contents of a fasl file in a readable format. - - - - - 1 changed file: - src/tools/cross-scripts/cross-x86-amd64.lisp Changes: ===================================== src/tools/cross-scripts/cross-x86-amd64.lisp ===================================== @@ -300,7 +300,7 @@ (load "target:compiler/srctran") (load "vm:vm-typetran") (load "target:compiler/float-tran") -(load "target:compiler/float-tran-dd") +;;(load "target:compiler/float-tran-dd") (load "target:compiler/saptran") (load "vm:macros") @@ -322,12 +322,16 @@ (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") +;; These need to be loaded before array because array wants to use +;; some vops as templates. (load "vm:sse2-array") (load "vm:array") (load "vm:pred") @@ -343,8 +347,10 @@ (check-move-function-consistency) -(load "target:compiler/codegen") -(load "target:compiler/array-tran.lisp") +;; Aret these necessary? +;;(load "target:compiler/codegen") +;;(load "target:compiler/array-tran.lisp") + (load "vm:new-genesis") ;;; OK, the cross compiler backend is loaded. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/aa7b0b276fe865275bfbbad… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/aa7b0b276fe865275bfbbad… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][rtoy-amd64-p1] Restore ability to build on x86
by Raymond Toy 19 Aug '20

19 Aug '20

Raymond Toy pushed to branch rtoy-amd64-p1 at cmucl / cmucl Commits: 9cf8b82c by Raymond Toy at 2020-08-18T22:12:14-07:00 Restore ability to build on x86 Always compile compiler/float-tran-dd as we used to do. - - - - - 1 changed file: - src/tools/comcom.lisp Changes: ===================================== src/tools/comcom.lisp ===================================== @@ -121,7 +121,6 @@ (comf "target:compiler/typetran" :byte-compile *byte-compile*) (comf "target:compiler/generic/vm-typetran" :byte-compile *byte-compile*) (comf "target:compiler/float-tran" :byte-compile *byte-compile*) -#+#.(c:target-featurep :double-double) (comf "target:compiler/float-tran-dd" :byte-compile *byte-compile*) (comf "target:compiler/saptran" :byte-compile *byte-compile*) (comf "target:compiler/srctran") ;; try View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/9cf8b82c582aa74f3dd6549… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/9cf8b82c582aa74f3dd6549… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[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