cmucl-cvs August 2020

cmucl-cvs@common-lisp.net

1 participants
26 discussions

[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

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

cmucl-cvs August 2020