[Git][cmucl/cmucl][rtoy-amd64-p1] Update cross script to compile more stuff
Raymond Toy
gitlab at common-lisp.net
Fri Aug 14 23:16:58 UTC 2020
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 at 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 at 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 at 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/9e953fef8e75ea6d302ce5529c8369a571ebb817
--
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/9e953fef8e75ea6d302ce5529c8369a571ebb817
You're receiving this email because of your account on gitlab.common-lisp.net.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/cmucl-cvs/attachments/20200814/91488490/attachment-0001.htm>
More information about the cmucl-cvs
mailing list