diff --git a/BUILDING b/BUILDING index cb7bd9357..fc0c3d2da 100644 --- a/BUILDING +++ b/BUILDING @@ -435,6 +435,13 @@ after : Specifies that "scheme.exe" (and its DLL, if any) should statically link to the multi-threaded C runtime. + * `/x86-64-v` with as 1, 2, 3, or 4 + + Configures x64 output to for instructions that can be used + directly, instead of dynamically substituting them when available + or using other fallbacks. The corresponds to the level + in the x86-64 psABI. + * `/keepvs` Specifies that command-line tools like "cl.exe" are available and diff --git a/build.bat b/build.bat index b65b12605..afdda62e2 100644 --- a/build.bat +++ b/build.bat @@ -10,6 +10,7 @@ set MAKETARGET=all-dlls set SKIPVS=no set SKIPSUBMODULE=no set USEPB=yes +set XLEVEL=1 if "%WORKAREA%"=="" goto needargument @@ -21,6 +22,10 @@ if defined ARG ( if "%ARG%"=="/exe" set LINKAS=exe && goto argloop if "%ARG%"=="/MD" set RUNTIMEAS=dll && goto argloop if "%ARG%"=="/MT" set RUNTIMEAS=static && goto argloop + if "%ARG%"=="/x86-64-v1" set XLEVEL=1 && goto argloop + if "%ARG%"=="/x86-64-v2" set XLEVEL=2 && goto argloop + if "%ARG%"=="/x86-64-v3" set XLEVEL=3 && goto argloop + if "%ARG%"=="/x86-64-v4" set XLEVEL=4 && goto argloop if "%ARG%"=="/only" set MAKETARGET=build && goto argloop if "%ARG%"=="/kernel" set MAKETARGET=kernel && goto argloop if "%ARG%"=="/none" set MAKETARGET=none && goto argloop @@ -63,6 +68,7 @@ echo m=%M% >> %WORKAREA%\Mf-config echo linkAs=%LINKAS% >> %WORKAREA%\Mf-config echo runtimeAs=%RUNTIMEAS% >> %WORKAREA%\Mf-config echo enableFrompb=%USEPB% >> %WORKAREA%\Mf-config +echo x86_64_level=%XLEVEL% >> %WORKAREA%\Mf-config echo workarea=%WORKAREA% > Makefile echo !include %WORKAREA%\Mf-config >> Makefile diff --git a/build.zuo b/build.zuo index 1680ab8cc..cb7a293d5 100644 --- a/build.zuo +++ b/build.zuo @@ -85,6 +85,15 @@ (map (lambda (file) (build-path pb-dir file)) boot:boot-file-names)))) + (define x86-64-level + (hash-ref config 'x86_64_level "1")) + + (define (add-x86-64-level-target xm targets) + (if (equal? (m->arch xm) "a6") + (cons (input-data-target 'x86-64-level x86-64-level) + targets) + targets)) + (define all-src-files (map (lambda (n) (at-source "s" n)) all-src-names)) @@ -176,7 +185,8 @@ (hash))) (reboot m xm scheme (hash 'shell-options options 'out-dir (at-dir "..") - 'work-dir (at-dir ".."))) + 'work-dir (at-dir "..") + 'x86-64-level x86-64-level)) (record-build-success token xm m host-scheme host-workarea)))) (define (record-build-success token xm m host-scheme host-workarea) @@ -197,13 +207,15 @@ [else boot-files])) (build (target (at-boot (car boot-file-names)) (lambda (path token) - (rule (if record-from-pb? - ;; declare dependency on pb instead of host, - ;; so we don't rebuild via pb: - via-pb-files - ;; otherwise, bootquick again if host changes: - (append (host-boot-files) - all-src-files)) + (rule (add-x86-64-level-target + xm + (if record-from-pb? + ;; declare dependency on pb instead of host, + ;; so we don't rebuild via pb: + via-pb-files + ;; otherwise, bootquick again if host changes: + (append (host-boot-files) + all-src-files))) thunk)) (hash 'co-outputs (map at-boot (cdr boot-file-names)) 'precious? #t @@ -507,7 +519,7 @@ boot-files) ,@(if boot-from-pb? - `([:target (,@boot-src-files) (,@via-pb-files) + `([:target (,@boot-src-files) (,@(add-x86-64-level-target m via-pb-files)) ,(lambda (first-path token) (check-machine-type m) (alert (~a "checking boot files for " m " against pb")) @@ -521,6 +533,7 @@ (list* (build-raw-path (at-source ".") "configure") "--nomakefile" "--pb" + (~a "--x86-64-v" x86-64-level) (string->shell (~a "--sessionkey=" (hash-ref config 'sessionKey ""))) diff --git a/c/build.zuo b/c/build.zuo index 2d3988c16..341024d86 100644 --- a/c/build.zuo +++ b/c/build.zuo @@ -80,11 +80,11 @@ ;; sources for "kernel.o": (define kernel-src-files (add-windows - (list "statics.c" "segment.c" "alloc.c" "symbol.c" "intern.c" + (list "statics.c" "segment.c" "alloc.c" "symbol.c" "intern.c" "expeditor.c" "gcwrapper.c" "gc-011.c" "gc-par.c" "gc-ocd.c" "gc-oce.c" "number.c" "schsig.c" "io.c" "new-io.c" "print.c" "fasl.c" "vfasl.c" "stats.c" "foreign.c" "prim.c" "prim5.c" "flushcache.c" - "schlib.c" "thread.c" "expeditor.c" "scheme.c" "compress-io.c" + "schlib.c" "thread.c" "scheme.c" "compress-io.c" "random.c" "ffi.c" "self-exe.c" arch.c))) (define kernel-srcs diff --git a/configure b/configure index b4c747577..c1f6d1921 100755 --- a/configure +++ b/configure @@ -114,6 +114,7 @@ buildKernelOnly=no enableFrompb=yes pbendian=l emscripten=no +x86_64_level=1 empetite=no android=no crossCompile=no @@ -333,6 +334,17 @@ while [ $# != 0 ] ; do AR="emar" RANLIB="emranlib" ;; + --x86-64-v*) + x86_64_level=`echo $1 | sed -e 's/^--x86-64-v//'` + case "$x86_64_level" in + 1|2|3|4) + ;; + *) + echo "unrecoginzed x86-64 level: $x86_64_level" + exit 1 + ;; + esac + ;; --force) forceworkarea=yes enableFrompb=no @@ -708,6 +720,7 @@ if [ "$help" = "yes" ]; then echo " --pb specify pb (portable bytecode) version" echo " --pbarch specify pb with inferred word and endianness" echo " --emscripten build via emscripten (\"em\" tool prefix)" + echo " --x86-64-v configure a6 code generation; see below" echo " --cross build host to bootstrap target" echo " --disable-x11 disable X11 support" echo " --disable-curses disable [n]curses support" @@ -768,6 +781,13 @@ if [ "$help" = "yes" ]; then echo " STEXLIB= build docs with instead of own stex" echo " ZUO= build with instead of own Zuo" echo "" + echo "For --x86-64-v, the can be 1, 2, or 4 corresponding to a level" + echo "in the x86-64 psABI:" + echo " 1 is the baseline supported by all x86_64 processors" + echo " 2 includes POPCOUNT and SSE4.1 instructions" + echo " 3 includes FMA and AVX instructions" + echo " 4 includes AVX512 instructions" + echo "" echo "Available machine types: $machs" echo "" echo "Examples:" @@ -1222,6 +1242,7 @@ mboot=$mboot crossCompile=$crossCompile buildKernelOnly=$buildKernelOnly enableFrompb=$enableFrompb +x86_64_level=$x86_64_level mdinclude=$mdinclude mdcppflags=$mdcppflags mdcflags=$mdcflags diff --git a/makefiles/boot.zuo b/makefiles/boot.zuo index c92f6336e..6556ba1a3 100644 --- a/makefiles/boot.zuo +++ b/makefiles/boot.zuo @@ -34,6 +34,7 @@ (if (or host-scheme host-workarea) "cross=t\n" "") + (~a "x86_64_level=" (hash-ref config 'x86_64_level "1") "\n") (~a "sessionKey=" (hash-ref config 'sessionKey "") "\n") "\n") (build-path dir "Mf-config") diff --git a/release_notes/release_notes.stex b/release_notes/release_notes.stex index de02a9074..ad38374ca 100644 --- a/release_notes/release_notes.stex +++ b/release_notes/release_notes.stex @@ -165,6 +165,15 @@ The armv7le and tarmv7le machine types correspond to a 32-bit ARM compilation target using the armel ABI, which is consistent with (old) Android devices. +\subsection{Support for additional x86-64 instructions (10.5.0)} + +Supplying \scheme{--x86-64-v\var{level}} to \scheme{configure} enables +use of instructions at \var{level} as specified by the x86-64 psABI. +In particular, \var{level} as \scheme{2} enables direct use of +POPCOUNT and SSE4.1 instructions in code that is generated for x86\_64 +targets, instead of substituting those instructions (with a small +overhead) dynamically when they are available at run time. + \subsection{Exact zeros and \scheme{lcm} (10.5.0)} Supplying an exact \scheme{0} to \scheme{lcm} produces exact diff --git a/s/a6-options.def b/s/a6-options.def new file mode 100644 index 000000000..06ec48756 --- /dev/null +++ b/s/a6-options.def @@ -0,0 +1 @@ +(define-constant x86-64-level $(level)) diff --git a/s/a6.def b/s/a6.def index 9ba5df55f..f12d2d930 100644 --- a/s/a6.def +++ b/s/a6.def @@ -12,3 +12,5 @@ (define-constant integer-divide-instruction #t) (define-constant popcount-instruction #t) (define-constant fpround-instruction #t) + +(include "a6-options.def") diff --git a/s/build.zuo b/s/build.zuo index e21383940..d138a3fcf 100644 --- a/s/build.zuo +++ b/s/build.zuo @@ -134,6 +134,10 @@ '("../unicode/unicode-char-cases.ss" "../unicode/unicode-charinfo.ss")) +(define def-src-names + (sort (filter (glob->matcher "*.def") (ls (at-source "."))) + stringarch m)) - (define mach-src+dep+more-srcs (get-machine-files m arch)) + (define x86-64-level (if (string=? arch "a6") + (or (lookup 'x86_64_level) "1") + 0)) + + (define mach-src+dep+more-srcs (get-machine-files m arch x86-64-level)) (define machine-def-inputs (map at-source (cons (caar mach-src+dep+more-srcs) (cdr mach-src+dep+more-srcs)))) @@ -221,7 +230,8 @@ other-src-names))) (define all-srcs - (append base-srcs + (append (map at-source def-src-names) + base-srcs compiler-srcs included-srcs other-srcs)) @@ -345,9 +355,9 @@ loads))]) ;; Create a `:depend` line for a file that `include`s other files - (define (include-dep name src-names) + (define (include-dep name src-names [more-deps '()]) `[:depend (,(at-dir (~a name "." m)) ,(at-dir (~a name ".so")) ,(at-dir (~a name ".patch"))) - ,(map at-source src-names)]) + ,(append more-deps (map at-source src-names))]) (define (run-scheme-header-script dest make-script mk.so*) (define tmp (~a dest ".next")) @@ -532,7 +542,8 @@ ;; Internal targets ---------------------------------------- - [:target ,machine.def (,(input-data-target 'machine m) ,@machine-def-inputs) + [:target ,machine.def (,(input-data-target 'machine (list m x86-64-level)) + ,@machine-def-inputs) ,(lambda (dest token) ((cdar mach-src+dep+more-srcs) dest token))] @@ -593,8 +604,8 @@ ,(include-dep "strip" (list "strip-types.ss")) ,(include-dep "vfasl" (list "strip-types.ss")) ,(include-dep "pbchunk" (list "strip-types.ss")) - ,(include-dep "cpnanopass" cpnanopass-src-names) - ,(include-dep "cpprim" cpnanopass-src-names) + ,(include-dep "cpnanopass" cpnanopass-src-names (list machine.def)) + ,(include-dep "cpprim" cpnanopass-src-names (list machine.def)) [:target ,petite.boot ,(add-patchfile base-objs) ,(lambda (petite.boot token) diff --git a/s/cpprim.ss b/s/cpprim.ss index 46d179283..988f5c8f7 100644 --- a/s/cpprim.ss +++ b/s/cpprim.ss @@ -5055,7 +5055,7 @@ [(e) (constant-case fpround-instruction [(#t) (build-fp-op-1 %fpround e)] - [else (build-fl-call (lookup-c-entry flround) e)])]) ; fpround-instruction: SSE4.1 roundsd on x86_64, frint* on arm64 + [else (build-fl-call (lookup-c-entry flround) e)])]) (define-inline 3 flfloor [(e) (constant-case fpround-instruction diff --git a/s/machine.zuo b/s/machine.zuo index a76096a7b..365bc4ea1 100644 --- a/s/machine.zuo +++ b/s/machine.zuo @@ -16,7 +16,8 @@ ;; Get or synthesize a "machine.def" file and supporting files, ;; returns ;; (list (cons dep-name build) dep-input-name ...) -(define (get-machine-files m arch) +;; The `x86-64-level` argument is relevant only for the "a6" architecture +(define (get-machine-files m arch [x86-64-level 0]) (define threaded? (= (char "t") (string-ref m 0))) (define uni (if threaded? (substring m 1) m)) (cond @@ -50,22 +51,44 @@ (define arch.def (~a arch ".def")) (define os.def (~a os ".def")) (define src (at-source m.def)) - (cons (if (file-exists? src) - (cons m.def - (lambda (dest token) - (cp/ln src dest))) - (let ([src (if threaded? "tunix.def" "unix.def")]) - (cons src - (lambda (dest token) - (fill-template (at-source src) dest - (hash 'M m 'March arch)))))) + (define dep + (if (file-exists? src) + (cons m.def + (lambda (dest token) + (cp/ln src dest))) + (let ([src (if threaded? "tunix.def" "unix.def")]) + (cons src + (lambda (dest token) + (fill-template (at-source src) dest + (hash 'M m 'March arch))))))) + (define a6? (string=? arch "a6")) + (cons (if a6? + (add-a6-options dep x86-64-level) + dep) (append (list "default.def" arch.def) + (if a6? + (list "a6-options.def") + '()) (if (file-exists? (at-source os.def)) (list os.def) '())))])) +;; "a6.def" includes "a6-options.def" +(define (add-a6-options dep x86-64-level) + (cons (car dep) + (lambda (dest token) + ((cdr dep) dest token) + (define options.def (build-path (path-only dest) "a6-options.def")) + (rm* options.def) + (fill-template (at-source "a6-options.def") options.def + (hash 'level x86-64-level)) + ;; record level in `dest` so the file changes f the configuration changes + (define o (fd-open-output dest :append)) + (fd-write o (~a "\n;; level = " x86-64-level "\n")) + (fd-close o)))) + (define (fill-template src dest vars) (define s (file->string src)) (define new-s (let loop ([i 0] [start 0]) diff --git a/s/reboot.zuo b/s/reboot.zuo index 0730093db..5a0fc6b45 100644 --- a/s/reboot.zuo +++ b/s/reboot.zuo @@ -13,6 +13,8 @@ (hash-set flags 'target machine)] [flags ("--dest") dest "Write boot files to /boot/" (hash-set flags 'dest dest)] + [flags ("--x86-64-v") level "Enable x86-64 instructions for >" + (hash-set flags 'x86-64-level level)] :args () (lambda (flags) @@ -21,7 +23,8 @@ (define target (hash-ref flags 'target host)) (define dest (hash-ref flags 'dest ".")) - (reboot 'infer target command (hash 'out-dir dest))))) + (reboot 'infer target command (hash 'out-dir dest + 'x86-64-level (hash-ref flags 'x86-64-level "1")))))) (define (reboot given-host target command [options (hash)]) (define host (if (eq? given-host 'infer) @@ -41,7 +44,8 @@ (mkdir-p host-dir) (define host-config (get-machine-files host (m->arch host))) - (define target-config (get-machine-files target (m->arch target))) + (define target-config (get-machine-files target (m->arch target) + (hash-ref options 'x86-64-level "1"))) ((cdar host-config) (build-path host-dir "machine.def") #f) ((cdar target-config) (build-path s-dir "machine.def") #f) diff --git a/s/x86_64.ss b/s/x86_64.ss index a0327f2fd..dac1f45eb 100644 --- a/s/x86_64.ss +++ b/s/x86_64.ss @@ -499,17 +499,18 @@ (define-instruction value popcount [(op (z ur) (x ur mem)) - ;; Direct POPCNT instruction variant, works with corresponding `popcount-op`: - #; - `(set! ,(make-live-info) ,z (asm ,info ,(asm-popcount (info-inline? info)) ,x)) - - ;; Link-editable variant, for corresponding `popcount-op`: - (let ([urcx (make-precolored-unspillable 'urcx %rcx)] - [urax (make-precolored-unspillable 'urax %rax)]) - (seq - `(set! ,(make-live-info) ,urcx ,x) - `(set! ,(make-live-info) ,urax (asm ,info ,(asm-popcount (info-inline? info)) ,urcx)) - `(set! ,(make-live-info) ,z ,urax)))]) + (constant-case x86-64-level + [(2 3 4) + ;; Direct POPCNT instruction variant + `(set! ,(make-live-info) ,z (asm ,info ,(asm-popcount (info-inline? info)) ,x))] + [else + ;; Link-editable variant + (let ([urcx (make-precolored-unspillable 'urcx %rcx)] + [urax (make-precolored-unspillable 'urax %rax)]) + (seq + `(set! ,(make-live-info) ,urcx ,x) + `(set! ,(make-live-info) ,urax (asm ,info ,(asm-popcount (info-inline? info)) ,urcx)) + `(set! ,(make-live-info) ,z ,urax)))])]) (define-instruction value move [(op (z mem) (x ur imm32)) @@ -660,15 +661,16 @@ (define-instruction value (fpround fpfloor fpceiling fptruncate) [(op (x fpur) (y fpmem fpur)) - ;; Direct ROUNDSD instruction variant, works with corresponding `asm-fpround`: - #; - `(set! ,(make-live-info) ,x (asm ,info ,(asm-fpround op) ,y)) - - ;; Link-editable variant, for corresponding `asm-fpround`: - (let ([urax (make-precolored-unspillable 'urax %rax)]) ; rax is assumed by linker's x86_64_set_jump - (seq - `(set! ,(make-live-info) ,urax (asm ,null-info ,asm-kill)) - `(set! ,(make-live-info) ,x (asm ,info ,(asm-fpround op) ,y ,urax))))]) + (constant-case x86-64-level + [(2 3 4) + ;; Direct ROUNDSD instruction variant + `(set! ,(make-live-info) ,x (asm ,info ,(asm-fpround op) ,y))] + [else + ;; Link-editable variant + (let ([urax (make-precolored-unspillable 'urax %rax)]) ; rax is assumed by linker's x86_64_set_jump + (seq + `(set! ,(make-live-info) ,urax (asm ,null-info ,asm-kill)) + `(set! ,(make-live-info) ,x (asm ,info ,(asm-fpround op) ,y ,urax))))])]) (define-instruction value (fpsingle) [(op (x fpur) (y fpmem fpur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpsingle ,y))]) @@ -1556,68 +1558,68 @@ [3 op-code] [0 (fxlogand (ax-ea-reg-code reg) 7)])))))) - ;; Direct POPCNT instruction variant: - #; - (define popcount-op - (lambda (op size dest-reg src-ea inline? code*) - (let ([code* (emit-code (op src-ea dest-reg code*) - (build byte #xF3) - (ax-ea-rex (if (eq? size 'quad) 1 0) src-ea dest-reg size) - (build byte #x0F) - (build byte #xB8) - (ax-ea-modrm-reg src-ea dest-reg) - (ax-ea-sib src-ea) - (ax-ea-addr-disp src-ea))]) - (if (not (and (ax-register? src-ea) - (fx= (ax-ea-reg-code src-ea) - (ax-ea-reg-code dest-reg)))) - (emit xor dest-reg dest-reg code*) ; avoid false dependency - code*)))) - - ;; Link-editable variant: (define popcount-op - (let ([target `(x86_64-popcount ,(constant code-data-disp) (library ,(lookup-libspec popcount-slow)))]) - (lambda (op size dest-rax src-rcx inline? code*) - (safe-assert (and (ax-register? dest-rax) (ax-register? src-rcx))) - (record-case dest-rax - [(reg) dest-rax - (record-case src-rcx - [(reg) src-rcx - (safe-assert (and (eq? dest-rax %rax) (eq? src-rcx %rcx))) - (cond - [(not inline?) - ;; Set up a call to `popcount-slow`, which the linker - ;; can replace with a POPCNT instruction: - (asm-helper-call code* target dest-rax)] - [else - ;; Used for the body of `popcount-slow`. - ;; This is the sequence generated by LLVM's __builtin_popcountl(), - ;; but with pushes and pops to save used registers other than the - ;; result register %rax. - (emit-literal-code (op dest-rax src-rcx code*) - 51 ; pushq %rcx - 57 ; pushq %rdi - 48 89 c8 ; movq %rcx, %rax - 48 d1 e8 ; shrq %rax - 48 bf 55 55 55 55 55 55 55 55 ; movabsq $6148914691236517205, %rdi - 48 21 c7 ; andq %rax, %rdi - 48 29 f9 ; subq %rdi, %rcx - 48 b8 33 33 33 33 33 33 33 33 ; movabsq $3689348814741910323, %rax - 48 89 cf ; movq %rcx, %rdi - 48 21 c7 ; andq %rax, %rdi - 48 c1 e9 02 ; shrq $2, %rcx - 48 21 c1 ; andq %rax, %rcx - 48 01 f9 ; addq %rdi, %rcx - 48 89 c8 ; movq %rcx, %rax - 48 c1 e8 04 ; shrq $4, %rax - 48 8d 04 08 ; leaq (%rax,%rcx), %rax - 48 bf 0f 0f 0f 0f 0f 0f 0f 0f ; movabsq $1085102592571150095, %rdi - 48 21 c7 ; andq %rax, %rdi - 48 b8 01 01 01 01 01 01 01 01 ; movabsq $72340172838076673, %rax - 48 0f af c7 ; imulq %rdi, %rax - 48 c1 e8 38 ; shrq $56, %rax - 5f ; popq %rdi - 59)])])])))) ; popq %rcx + (constant-case x86-64-level + [(2 3 4) + ;; Direct POPCNT instruction variant: + (lambda (op size dest-reg src-ea inline? code*) + (let ([code* (emit-code (op src-ea dest-reg code*) + (build byte #xF3) + (ax-ea-rex (if (eq? size 'quad) 1 0) src-ea dest-reg size) + (build byte #x0F) + (build byte #xB8) + (ax-ea-modrm-reg src-ea dest-reg) + (ax-ea-sib src-ea) + (ax-ea-addr-disp src-ea))]) + (if (not (and (ax-register? src-ea) + (fx= (ax-ea-reg-code src-ea) + (ax-ea-reg-code dest-reg)))) + (emit xor dest-reg dest-reg code*) ; avoid false dependency + code*)))] + [else + ;; Link-editable variant: + (let ([target `(x86_64-popcount ,(constant code-data-disp) (library ,(lookup-libspec popcount-slow)))]) + (lambda (op size dest-rax src-rcx inline? code*) + (safe-assert (and (ax-register? dest-rax) (ax-register? src-rcx))) + (record-case dest-rax + [(reg) dest-rax + (record-case src-rcx + [(reg) src-rcx + (safe-assert (and (eq? dest-rax %rax) (eq? src-rcx %rcx))) + (cond + [(not inline?) + ;; Set up a call to `popcount-slow`, which the linker + ;; can replace with a POPCNT instruction: + (asm-helper-call code* target dest-rax)] + [else + ;; Used for the body of `popcount-slow`. + ;; This is the sequence generated by LLVM's __builtin_popcountl(), + ;; but with pushes and pops to save used registers other than the + ;; result register %rax. + (emit-literal-code (op dest-rax src-rcx code*) + 51 ; pushq %rcx + 57 ; pushq %rdi + 48 89 c8 ; movq %rcx, %rax + 48 d1 e8 ; shrq %rax + 48 bf 55 55 55 55 55 55 55 55 ; movabsq $6148914691236517205, %rdi + 48 21 c7 ; andq %rax, %rdi + 48 29 f9 ; subq %rdi, %rcx + 48 b8 33 33 33 33 33 33 33 33 ; movabsq $3689348814741910323, %rax + 48 89 cf ; movq %rcx, %rdi + 48 21 c7 ; andq %rax, %rdi + 48 c1 e9 02 ; shrq $2, %rcx + 48 21 c1 ; andq %rax, %rcx + 48 01 f9 ; addq %rdi, %rcx + 48 89 c8 ; movq %rcx, %rax + 48 c1 e8 04 ; shrq $4, %rax + 48 8d 04 08 ; leaq (%rax,%rcx), %rax + 48 bf 0f 0f 0f 0f 0f 0f 0f 0f ; movabsq $1085102592571150095, %rdi + 48 21 c7 ; andq %rax, %rdi + 48 b8 01 01 01 01 01 01 01 01 ; movabsq $72340172838076673, %rax + 48 0f af c7 ; imulq %rdi, %rax + 48 c1 e8 38 ; shrq $56, %rax + 5f ; popq %rdi + 59)])])])))])) ; popq %rcx (define-syntax emit-code (lambda (x) @@ -1993,46 +1995,46 @@ (maybe-clear-fp-dest src dest-reg (emit sse.sqrtsd src dest-reg code*))))) - ;; Direct ROUNDSD instruction variant: - #; - (define asm-fpround - (lambda (op) - (lambda (code* dest-reg src) - (define (emit-round code* src dest-reg) - (case op - [(fpround) (emit sse.roundsd src dest-reg code*)] - [(fpfloor) (emit sse.floorsd src dest-reg code*)] - [(fpceiling) (emit sse.ceilingsd src dest-reg code*)] - [(fptruncate) (emit sse.truncsd src dest-reg code*)])) - (Trivit (dest-reg src) - (maybe-clear-fp-dest src dest-reg - (emit-round code* src dest-reg)))))) - - ;; Link-editable variant: moves the argument to %Cfparg1 (xmm0), - ;; sets up a call to `fpround-slow` or similar, and moves the result - ;; from %Cfparg1. The linker replaces the call with - ;; `ROUNDSD xmm0, xmm0, mode` when SSE4.1 is available. The rounding - ;; mode is communicated to the linker as an addition to the - ;; relocation's usual `code-data-disp` item offset. Using %Cfparg1 - ;; as a scratch register makes the same assumption as `asm-fpop-2`. (define asm-fpround - (lambda (op) - (let* ([mode (case op - [(fpround) 0] - [(fpfloor) 1] - [(fpceiling) 2] - [(fptruncate) 3])] - [libspec (case op - [(fpround) (lookup-libspec fpround-slow)] - [(fpfloor) (lookup-libspec fpfloor-slow)] - [(fpceiling) (lookup-libspec fpceiling-slow)] - [(fptruncate) (lookup-libspec fptruncate-slow)])] - [target `(x86_64-fpround ,(fx+ (constant code-data-disp) mode) (library ,libspec))] - [xmm0 (cons 'reg %Cfparg1)]) - (lambda (code* dest-reg src jmp-reg) - (Trivit (dest-reg src) - (emit-fpmove src xmm0 - (asm-helper-call (emit-fpmove xmm0 dest-reg code*) target jmp-reg))))))) + (constant-case x86-64-level + [(2 3 4) + ;; Direct ROUNDSD instruction variant: + (lambda (op) + (lambda (code* dest-reg src) + (define (emit-round code* src dest-reg) + (case op + [(fpround) (emit sse.roundsd src dest-reg code*)] + [(fpfloor) (emit sse.floorsd src dest-reg code*)] + [(fpceiling) (emit sse.ceilingsd src dest-reg code*)] + [(fptruncate) (emit sse.truncsd src dest-reg code*)])) + (Trivit (dest-reg src) + (maybe-clear-fp-dest src dest-reg + (emit-round code* src dest-reg)))))] + [else + ;; Link-editable variant: moves the argument to %Cfparg1 (xmm0), + ;; sets up a call to `fpround-slow` or similar, and moves the result + ;; from %Cfparg1. The linker replaces the call with + ;; `ROUNDSD xmm0, xmm0, mode` when SSE4.1 is available. The rounding + ;; mode is communicated to the linker as an addition to the + ;; relocation's usual `code-data-disp` item offset. Using %Cfparg1 + ;; as a scratch register makes the same assumption as `asm-fpop-2`. + (lambda (op) + (let* ([mode (case op + [(fpround) 0] + [(fpfloor) 1] + [(fpceiling) 2] + [(fptruncate) 3])] + [libspec (case op + [(fpround) (lookup-libspec fpround-slow)] + [(fpfloor) (lookup-libspec fpfloor-slow)] + [(fpceiling) (lookup-libspec fpceiling-slow)] + [(fptruncate) (lookup-libspec fptruncate-slow)])] + [target `(x86_64-fpround ,(fx+ (constant code-data-disp) mode) (library ,libspec))] + [xmm0 (cons 'reg %Cfparg1)]) + (lambda (code* dest-reg src jmp-reg) + (Trivit (dest-reg src) + (emit-fpmove src xmm0 + (asm-helper-call (emit-fpmove xmm0 dest-reg code*) target jmp-reg))))))])) (define asm-fpmove (lambda (code* dest src)