From 39d5adc745ab078d639584bc301a2adc716e8a2f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 20 Nov 2020 14:12:58 -0700 Subject: [PATCH] system-type: add 'os* and 'arch modes The 'os* mode is like 'os, but it provides a more specific result for Unix variants, such as 'linux on Linux. The 'os* and 'arch modes together are the information that we've previously accessed indirectly via `(system-library-subpath #f)`. Closes #3510 --- .../scribblings/reference/runtime.scrbl | 22 ++- pkgs/racket-test-core/tests/racket/basic.rktl | 3 + racket/src/bc/mksystem.rkt | 8 +- racket/src/bc/sconfig.h | 103 ++++++----- racket/src/bc/src/string.c | 25 ++- racket/src/bc/src/systype.c | 2 + racket/src/cs/c/Makefile.in | 2 +- racket/src/cs/c/gen-system.rkt | 149 +++++++++++----- racket/src/cs/compile-file.ss | 2 +- racket/src/cs/rumble/system.ss | 164 ++++++++++++------ 10 files changed, 336 insertions(+), 144 deletions(-) diff --git a/pkgs/racket-doc/scribblings/reference/runtime.scrbl b/pkgs/racket-doc/scribblings/reference/runtime.scrbl index 9fa478baa6..5a4acc91e2 100644 --- a/pkgs/racket-doc/scribblings/reference/runtime.scrbl +++ b/pkgs/racket-doc/scribblings/reference/runtime.scrbl @@ -4,7 +4,7 @@ @title[#:tag "runtime"]{Environment and Runtime Information} -@defproc[(system-type [mode (or/c 'os 'word 'vm 'gc 'link 'machine 'target-machine +@defproc[(system-type [mode (or/c 'os 'os* 'arch 'word 'vm 'gc 'link 'machine 'target-machine 'so-suffix 'so-mode 'fs-change 'cross) 'os]) (or/c symbol? string? bytes? exact-positive-integer? vector? #f)]{ @@ -22,6 +22,19 @@ In @indexed-racket['os] mode, @item{@indexed-racket['macosx]} ] +@margin-note{Prior to the introduction of @racket['os*] and +@racket['arch] modes, @racket[(system-library-subpath #f)] could be +used to obtain this information somewhat indirectly.} + +In @indexed-racket['os*] mode, the result is similar to @racket['os] +mode, but refined to a specific operating system, such as +@racket['linux] or @racket['freebsd], instead of a generic +@racket['unix] classification. + +In @indexed-racket['arch] mode, the result is a symbol representing an +architecture. Possible results include @racket['x86_64], @racket['i386], +@racket['aarch64], @racket['arm] (32-bit), and @racket['ppc] (32-bit). + In @indexed-racket['word] mode, the result is either @racket[32] or @racket[64] to indicate whether Racket is running as a 32-bit program or 64-bit program. @@ -55,8 +68,8 @@ In @indexed-racket['link] mode, the possible symbol results are: @item{@indexed-racket['framework] (Mac OS)} ] -Future ports of Racket may expand the list of @racket['os], @racket['vm], -@racket['gc], and @racket['link] results. +Future ports of Racket may expand the list of @racket['os], @racket['os*], +@racket['arch], @racket['vm], @racket['gc], and @racket['link] results. In @indexed-racket['machine] mode, then the result is a string, which contains further details about the current machine in a @@ -118,7 +131,8 @@ The possible symbols are: @history[#:changed "6.8.0.2" @elem{Added @racket['vm] mode.} #:changed "6.9.0.1" @elem{Added @racket['cross] mode.} - #:changed "7.1.0.6" @elem{Added @racket['target-machine] mode.}]} + #:changed "7.1.0.6" @elem{Added @racket['target-machine] mode.} + #:changed "7.9.0.6" @elem{Added @racket['os*] and @racket['arch] modes.}]} @defproc[(system-language+country) string?]{ diff --git a/pkgs/racket-test-core/tests/racket/basic.rktl b/pkgs/racket-test-core/tests/racket/basic.rktl index 9f1719190f..b02ca1029f 100644 --- a/pkgs/racket-test-core/tests/racket/basic.rktl +++ b/pkgs/racket-test-core/tests/racket/basic.rktl @@ -3037,7 +3037,10 @@ (test (system-type) system-type 'os) (test #t string? (system-type 'machine)) (test #t symbol? (system-type 'link)) +(test #t symbol? (system-type 'os*)) +(test #t symbol? (system-type 'arch)) (test #t relative-path? (system-library-subpath)) +(test #t relative-path? (system-library-subpath #f)) (test #t pair? (memv (system-type 'word) '(32 64))) (test (fixnum? (expt 2 32)) = (system-type 'word) 64) diff --git a/racket/src/bc/mksystem.rkt b/racket/src/bc/mksystem.rkt index 1d8c13b760..64ef1b8d1f 100644 --- a/racket/src/bc/mksystem.rkt +++ b/racket/src/bc/mksystem.rkt @@ -15,6 +15,8 @@ (vector-ref args (- (vector-length args) 2)))) ;; Not cross-compiling (hash 'os (system-type 'os) + 'os* (system-type 'os*) + 'arch (system-type 'arch) 'word (system-type 'word) 'gc (if (= (vector-length args) 1) '3m ; GC mode for suffixless executables @@ -58,8 +60,12 @@ (lambda (var) (string->number (get-string var)))]) (let-values ([(library-subpath) (get-string "system_library_subpath")] - [(os) (get-symbol "system_type_os")]) + [(os) (get-symbol "system_type_os")] + [(os*) (get-symbol "system_type_os_star")] + [(arch) (get-symbol "system_type_arch")]) (hash 'os os + 'os* os* + 'arch arch 'word (* 8 (get-int "system_pointer_size")) 'gc (if (string=? "" (vector-ref args 2)) '3m diff --git a/racket/src/bc/sconfig.h b/racket/src/bc/sconfig.h index e8936e9d79..5443524650 100644 --- a/racket/src/bc/sconfig.h +++ b/racket/src/bc/sconfig.h @@ -30,18 +30,20 @@ # include # ifdef ECHRNG /* Solaris */ +# define SCHEME_OS "solaris" # if defined(__i386__) -# define SCHEME_PLATFORM_LIBRARY_SUBPATH "i386-solaris" +# define SCHEME_ARCH "i386" # elif defined(__x86_64) -# define SCHEME_PLATFORM_LIBRARY_SUBPATH "x86_64-solaris" +# define SCHEME_ARCH "x86_64" # else -# define SCHEME_PLATFORM_LIBRARY_SUBPATH "sparc-solaris" +# define SCHEME_ARCH "sparc" # endif # else /* SunOS4 */ -# define SCHEME_PLATFORM_LIBRARY_SUBPATH "sparc-sunos4" -# define NO_STRERROR_AVAILABLE -# define USE_ON_EXIT_FOR_ATEXIT +# define SCHEME_OS "sunos4" +# define SCHEME_ARCH "sparc" +# define NO_STRERROR_AVAILABLE +# define USE_ON_EXIT_FOR_ATEXIT # endif # define PREFER_MMAP_LARGE_BLOCKS @@ -66,7 +68,8 @@ # if defined(_IBMR2) -# define SCHEME_PLATFORM_LIBRARY_SUBPATH "rs6k-aix" +# define SCHEME_OS "rs6k" +# define SCHEME_ARCH "aix" # include "uconfig.h" @@ -81,58 +84,58 @@ #if defined(__linux__) # ifdef __ANDROID__ -# define SPLS_LINUX "android" +# define SCHEME_OS "android" # else -# define SPLS_LINUX "linux" +# define SCHEME_OS "linux" # endif # if defined(__i386__) -# define SCHEME_PLATFORM_LIBRARY_SUBPATH "i386-" SPLS_LINUX +# define SCHEME_ARCH "i386" # define REGISTER_POOR_MACHINE # define MZ_TRY_EXTFLONUMS # define ASM_DBLPREC_CONTROL_87 # endif # if defined(__powerpc__) && !defined(__powerpc64__) -# define SCHEME_PLATFORM_LIBRARY_SUBPATH "ppc-" SPLS_LINUX +# define SCHEME_ARCH "ppc" # endif # if defined(__powerpc64__) # if defined(__LITTLE_ENDIAN__) -# define SCHEME_PLATFORM_LIBRARY_SUBPATH "ppc64le-" SPLS_LINUX +# define SCHEME_ARCH "ppc64le" # else -# define SCHEME_PLATFORM_LIBRARY_SUBPATH "ppc64-" SPLS_LINUX +# define SCHEME_ARCH "ppc64" # endif # endif # if defined(__mc68000__) -# define SCHEME_PLATFORM_LIBRARY_SUBPATH "m68k-" SPLS_LINUX +# define SCHEME_ARCH "m68k" # endif # if defined(mips) -# define SCHEME_PLATFORM_LIBRARY_SUBPATH "mips-" SPLS_LINUX +# define SCHEME_ARCH "mips" # endif # if defined(__alpha__) -# define SCHEME_PLATFORM_LIBRARY_SUBPATH "alpha-" SPLS_LINUX +# define SCHEME_ARCH "alpha" # endif # if defined(__hppa__) -# define SCHEME_PLATFORM_LIBRARY_SUBPATH "hppa-" SPLS_LINUX +# define SCHEME_ARCH "hppa" # endif # if defined(__sparc__) -# define SCHEME_PLATFORM_LIBRARY_SUBPATH "sparc-" SPLS_LINUX +# define SCHEME_ARCH "sparc" # define FLUSH_SPARC_REGISTER_WINDOWS # endif # if defined(__arm__) || defined(__thumb__) -# define SCHEME_PLATFORM_LIBRARY_SUBPATH "arm-" SPLS_LINUX +# define SCHEME_ARCH "arm" # define FFI_CALLBACK_NEED_INT_CLEAR # endif # if defined(__aarch64__) -# define SCHEME_PLATFORM_LIBRARY_SUBPATH "aarch64-" SPLS_LINUX +# define SCHEME_ARCH "aarch64" # endif # if defined(__x86_64__) -# define SCHEME_PLATFORM_LIBRARY_SUBPATH "x86_64-" SPLS_LINUX +# define SCHEME_ARCH "x86_64" # define REGISTER_POOR_MACHINE # define ASM_DBLPREC_CONTROL_87 # define MZ_TRY_EXTFLONUMS # endif # ifndef SCHEME_PLATFORM_LIBRARY_SUBPATH -# define SCHEME_PLATFORM_LIBRARY_SUBPATH "unknown-" SPLS_LINUX +# define SCHEME_ARCH "unknown" # endif # include "uconfig.h" @@ -174,14 +177,16 @@ #if defined(__NetBSD__) +#define SCHEME_OS "netbsd" + #if defined(__i386__) -# define SCHEME_PLATFORM_LIBRARY_SUBPATH "i386-netbsd" +# define SCHEME_ARCH "i386" #elif defined(__powerpc__) -# define SCHEME_PLATFORM_LIBRARY_SUBPATH "ppc-netbsd" +# define SCHEME_ARCH "ppc" #elif defined(__x86_64__) -# define SCHEME_PLATFORM_LIBRARY_SUBPATH "x86_64-netbsd" +# define SCHEME_ARCH "x86_64" #else -# define SCHEME_PLATFORM_LIBRARY_SUBPATH "netbsd" +# define SCHEME_ARCH "unknown" #endif # include "uconfig.h" @@ -480,10 +485,13 @@ # ifdef _WIN64 # define SCHEME_PLATFORM_LIBRARY_SUBPATH "win32\\x86_64" +# define SCHEME_ARCH "x86_64" # else # define SCHEME_PLATFORM_LIBRARY_SUBPATH "win32\\i386" +# define SCHEME_ARCH "i386" # endif +# define SCHEME_OS "windows" # define SYSTEM_TYPE_NAME "windows" # define DOS_FILE_SYSTEM @@ -592,7 +600,8 @@ #if defined(__CYGWIN32__) -# define SCHEME_PLATFORM_LIBRARY_SUBPATH "i386-cygwin" +# define SCHEME_OS "cygwin" +# define SCHEME_ARCH "i386" # include "uconfig.h" @@ -621,23 +630,23 @@ # if defined(OS_X) || defined(XONX) # if defined(XONX) -# define SPLS_MAC "darwin" +# define SCHEME_OS "darwin" # elif TARGET_OS_IPHONE -# define SPLS_MAC "ios" +# define SCHEME_OS "ios" # else -# define SPLS_MAC "macosx" +# define SCHEME_OS "macosx" # endif # if defined(__POWERPC__) -# define SCHEME_PLATFORM_LIBRARY_SUBPATH "ppc-" SPLS_MAC +# define SCHEME_ARCH "ppc" # elif defined(__arm__) -# define SCHEME_PLATFORM_LIBRARY_SUBPATH "arm-" SPLS_MAC +# define SCHEME_ARCH "arm" # elif defined(__arm64__) -# define SCHEME_PLATFORM_LIBRARY_SUBPATH "arm64-" SPLS_MAC +# define SCHEME_ARCH "aarch64" # elif defined(__x86_64__) -# define SCHEME_PLATFORM_LIBRARY_SUBPATH "x86_64-" SPLS_MAC +# define SCHEME_ARCH "x86_64" # else -# define SCHEME_PLATFORM_LIBRARY_SUBPATH "i386-" SPLS_MAC +# define SCHEME_ARCH "i386" # endif # include "uconfig.h" @@ -696,7 +705,8 @@ # if defined(__APPLE__) && defined(__MACH__) && defined(__i386__) && !defined(OS_X) -# define SCHEME_PLATFORM_LIBRARY_SUBPATH "i386-darwin" +# define SCHEME_OS "darwin" +# define SCHEME_ARCH "i386" # include "uconfig.h" @@ -714,8 +724,12 @@ #if defined(__QNX__) +# define SCHEME_OS "qnx" + #if defined(__i386__) -# define SCHEME_PLATFORM_LIBRARY_SUBPATH "i386-qnx" +# define SCHEME_ARCH "i386" +#else +# define SCHEME_ARCH "unknown" #endif # define ASSUME_FIXED_STACK_SIZE @@ -741,14 +755,16 @@ #if defined(__DragonFly__) +# define SCHEME_OS "dragonfly" + # if defined(__i386__) -# define SCHEME_PLATFORM_LIBRARY_SUBPATH "i386-dragonfly" +# define SCHEME_ARCH "i386" # define REGISTER_POOR_MACHINE # define MZ_USE_JIT_I386 # define ASM_DBLPREC_CONTROL_87 # define MZ_TRY_EXTFLONUMS # elif defined(__amd64__) -# define SCHEME_PLATFORM_LIBRARY_SUBPATH "amd64-dragonfly" +# define SCHEME_ARCH "aarch64" # define REGISTER_POOR_MACHINE # define MZ_USE_JIT_X86_64 # define ASM_DBLPREC_CONTROL_87 @@ -779,6 +795,9 @@ /************** (END KNOWN ARCHITECTURE/SYSTEMS) ****************/ +#ifndef SCHEME_PLATFORM_LIBRARY_SUBPATH +# define SCHEME_PLATFORM_LIBRARY_SUBPATH SCHEME_ARCH "-" SCHEME_OS +#endif /***** (BEGIN CONFIGURATION FLAG DESCRPTIONS AND DEFAULTS) ******/ @@ -794,6 +813,12 @@ /* SYSTEM_TYPE_NAME must be a string; this will be converted into a symbol for the result of (system-type) */ + /* SCHEME_OS must be a string; this converted into a symbol for the + result of (system-type 'os*) */ + + /* SCHEME_ARCH must be a string; this converted into a symbol for the + result of (system-type 'arch) */ + /* SCHEME_PLATFORM_LIBRARY_SUBPATH must be a string; if it is undefined, it is automatically generated into a file named "schsys.h" into the same directory as .o files and #included diff --git a/racket/src/bc/src/string.c b/racket/src/bc/src/string.c index 7969e28a86..de007f66b7 100644 --- a/racket/src/bc/src/string.c +++ b/racket/src/bc/src/string.c @@ -171,10 +171,11 @@ static void cache_locale_or_close(int to_bytes, rktio_converter_t *cd, char *le) #define portable_isspace(x) (((x) < 128) && isspace(x)) -ROSYM static Scheme_Object *sys_symbol; +ROSYM static Scheme_Object *sys_symbol, *sys_os_symbol, *sys_arch_symbol; ROSYM static Scheme_Object *link_symbol, *machine_symbol, *vm_symbol, *gc_symbol; ROSYM static Scheme_Object *so_suffix_symbol, *so_mode_symbol, *word_symbol; -ROSYM static Scheme_Object *os_symbol, *fs_change_symbol, *target_machine_symbol, *cross_symbol; +ROSYM static Scheme_Object *os_symbol, *os_star_symbol, *arch_symbol; +ROSYM static Scheme_Object *fs_change_symbol, *target_machine_symbol, *cross_symbol; ROSYM static Scheme_Object *racket_symbol, *cgc_symbol, *_3m_symbol, *cs_symbol; ROSYM static Scheme_Object *force_symbol, *infer_symbol; ROSYM static Scheme_Object *platform_3m_path, *platform_cgc_path, *platform_cs_path; @@ -218,7 +219,11 @@ scheme_init_string (Scheme_Startup_Env *env) Scheme_Object *p; REGISTER_SO(sys_symbol); + REGISTER_SO(sys_os_symbol); + REGISTER_SO(sys_arch_symbol); sys_symbol = scheme_intern_symbol(SYSTEM_TYPE_NAME); + sys_os_symbol = scheme_intern_symbol(SCHEME_OS); + sys_arch_symbol = scheme_intern_symbol(SCHEME_ARCH); REGISTER_SO(link_symbol); REGISTER_SO(machine_symbol); @@ -228,6 +233,8 @@ scheme_init_string (Scheme_Startup_Env *env) REGISTER_SO(so_mode_symbol); REGISTER_SO(word_symbol); REGISTER_SO(os_symbol); + REGISTER_SO(os_star_symbol); + REGISTER_SO(arch_symbol); REGISTER_SO(fs_change_symbol); REGISTER_SO(target_machine_symbol); REGISTER_SO(cross_symbol); @@ -239,6 +246,8 @@ scheme_init_string (Scheme_Startup_Env *env) so_mode_symbol = scheme_intern_symbol("so-mode"); word_symbol = scheme_intern_symbol("word"); os_symbol = scheme_intern_symbol("os"); + os_star_symbol = scheme_intern_symbol("os*"); + arch_symbol = scheme_intern_symbol("arch"); fs_change_symbol = scheme_intern_symbol("fs-change"); target_machine_symbol = scheme_intern_symbol("target-machine"); cross_symbol = scheme_intern_symbol("cross"); @@ -2441,10 +2450,18 @@ static Scheme_Object *system_type(int argc, Scheme_Object *argv[]) return (cross_compile_mode ? force_symbol : infer_symbol); } + if (SAME_OBJ(argv[0], os_star_symbol)) { + return sys_os_symbol; + } + + if (SAME_OBJ(argv[0], arch_symbol)) { + return sys_arch_symbol; + } + if (!SAME_OBJ(argv[0], os_symbol)) { scheme_wrong_contract("system-type", - ("(or/c 'os 'word 'link 'machine 'target-machine\n" - " 'vm 'gc 'so-suffix 'so-mode 'word 'fs-change 'cross)"), + ("(or/c 'os 'os* 'arch 'word 'link 'machine 'target-machine\n" + " 'vm 'gc 'so-suffix 'so-mode 'word 'fs-change 'cross)"), 0, argc, argv); return NULL; } diff --git a/racket/src/bc/src/systype.c b/racket/src/bc/src/systype.c index fb75a14a5d..f61e0c686c 100644 --- a/racket/src/bc/src/systype.c +++ b/racket/src/bc/src/systype.c @@ -8,6 +8,8 @@ #endif string system_type_os = SYSTEM_TYPE_NAME; +string system_type_os_star = SCHEME_OS; +string system_type_arch = SCHEME_ARCH; string system_type_link = MZ_SYSTEM_TYPE_LINK; string system_type_so_suffix = MZ_SYSTEM_TYPE_SO_SUFFIX; string system_type_so_mode = MZ_SYSTEM_TYPE_SO_MODE; diff --git a/racket/src/cs/c/Makefile.in b/racket/src/cs/c/Makefile.in index 9d63ec3621..fdf7eb96a4 100644 --- a/racket/src/cs/c/Makefile.in +++ b/racket/src/cs/c/Makefile.in @@ -478,7 +478,7 @@ common-install: $(MAKE) common-@INSTALL_LIBS_ENABLE@-libs system-install: - $(RACKET) -cu "$(srcdir)/gen-system.rkt" $(DESTDIR)$(libpltdir)/system$(CS_INSTALLED).rktd $(TARGET_MACH) @CROSS_COMPILE_TARGET_KIND@ + $(RACKET) -cu "$(srcdir)/gen-system.rkt" $(DESTDIR)$(libpltdir)/system$(CS_INSTALLED).rktd $(TARGET_MACH) @CROSS_COMPILE_TARGET_KIND@ "$(srcdir)" include-install: $(ICP) $(srcdir)/api.h "$(DESTDIR)$(includepltdir)/racketcs.h" diff --git a/racket/src/cs/c/gen-system.rkt b/racket/src/cs/c/gen-system.rkt index dcfd24891d..d4a3d0af7b 100644 --- a/racket/src/cs/c/gen-system.rkt +++ b/racket/src/cs/c/gen-system.rkt @@ -1,59 +1,130 @@ (module gen-system '#%kernel - ;; Command-line argument: - - ;; This file includes various inferences for cross-compilation, so it has - ;; to be updated for new cross-compilation targets. + ;; Command-line argument: (define-values (machine) (string->symbol (vector-ref (current-command-line-arguments) 1))) + (define-values (srcdir) (vector-ref (current-command-line-arguments) 3)) - (define-values (machine-lookup) - (lambda (l default) + (define-values (definitions) + (call-with-input-file + (build-path srcdir 'up "rumble" "system.ss") + (lambda (i) + (letrec-values ([(loop) + (lambda () + (let-values ([(v) (read i)]) + (if (eof-object? v) + null + (cons v (loop)))))]) + (loop))))) + + (define-values (lookup) + (lambda (key) + (letrec-values ([(loop) + (lambda (l) + (if (null? l) + (error 'lookup "could not find ~e" key) + (let-values ([(a) (car l)]) + (if (eq? 'define (car a)) + (if (eq? key (cadr a)) + (parse-cond (caddr a)) + (loop (cdr l))) + (loop (cdr l))))))]) + (loop definitions)))) + + (define-values (parse-cond) + (lambda (e) + (if (matches? e '(case (machine-type) . _)) + (letrec-values ([(loop) + (lambda (l) + (if (null? l) + (error 'parse-cond "no match") + (let-values ([(a) (car l)]) + (if (matches? a '[else _]) + (parse-expr (cadr a)) + (if (matches? a '[_ _]) + (if (memq machine (car a)) + (parse-expr (cadr a)) + (loop (cdr l))) + (loop (cdr l)))))))]) + (loop (cddr e))) + (error 'parse-cond "could not parse ~e" e)))) + + (define-values (parse-expr) + (lambda (e) + (if (matches? e '(quote _)) + (cadr e) + (if (matches? e '(string->utf8 _)) + (string->bytes/utf-8 (cadr e)) + (if (matches? e '(if unix-style-macos? _ _)) + (if (eq? (system-type) 'macosx) + (parse-expr (cadddr e)) + (parse-expr (caddr e))) + (if (matches? e '(if unix-link-shared? _ _)) + ;; Currently assuming shared-library mode is not a cross compile: + (if (eq? (system-type 'link) 'shared) + (parse-expr (cadddr e)) + (parse-expr (caddr e))) + (error 'parse-expr "could not parse ~e" e))))))) + + (define-values (matches?) + (lambda (e pat) + (if (eq? pat '_) + #t + (if (pair? pat) + (if (pair? e) + (if (matches? (car e) (car pat)) + (matches? (cdr e) (cdr pat)) + #f) + #f) + (equal? e pat))))) + + (define-values (memq) + (lambda (a l) (if (null? l) - default - (if (eq? (caar l) machine) - (cdar l) - (machine-lookup (cdr l) default))))) + #f + (if (eq? a (car l)) + #t + (memq a (cdr l)))))) - ;; Check for cross-compile to Windows: - (define-values (windows?) (machine-lookup '((ta6nt . #t) - (a6nt . #t) - (ti3nt . #t) - (i3nt . #t)) - #f)) + (define-values (os) (lookup 'os-symbol)) + (define-values (os*) (lookup 'os*-symbol)) + (define-values (arch) (lookup 'arch-symbol)) + (define-values (link) (lookup 'link-symbol)) + (define-values (so-suffix) (lookup 'so-suffix-bytes)) (define-values (lib-subpath) - (machine-lookup '((ta6nt . "win32\\x86_64") - (a6nt . "win32\\x86_64") - (ti3nt . "win32\\i386") - (i3nt . "win32\\i386") - (tarm32le . "arm-linux") - (arm32le . "arm-linux") - (tarm64le . "aarch64-linux") - (arm64le . "aarch64-linux")) - (bytes->string/utf-8 (path->bytes (system-library-subpath #f))))) + (if (eq? machine 'ta6nt) + "win32\\x86_64" + (if (eq? machine 'a6nt) + "win32\\x86_64" + (if (eq? machine 'ti3nt) + "win32\\i386" + (if (eq? machine 'ti3nt) + "win32\\i386" + (format "~a-~a" arch os*)))))) (define-values (ht) - (hash 'os (if windows? 'windows (system-type 'os)) - 'word (machine-lookup '((ta6nt . 64) - (a6nt . 64) - (ti3nt . 32) - (i3nt . 32) - (tarm32le . 32) - (arm32le . 32) - (tarm64le . 64) - (arm64le . 64)) - (system-type 'word)) + (hash 'os os + 'os* os* + 'arch arch + 'word (if (eq? arch 'i386) + 32 + (if (eq? arch 'arm) + 32 + (if (eq? arch 'ppc) + 32 + 64))) 'gc 'cs 'vm 'chez-scheme - 'link (if windows? 'windows (system-type 'link)) + 'link link 'machine lib-subpath 'library-subpath (string->bytes/utf-8 lib-subpath) - 'library-subpath-convention (if windows? 'windows 'unix) - 'so-suffix (if windows? #".dll" (system-type 'so-suffix)) + 'library-subpath-convention (if (eq? os 'windows) 'windows 'unix) + 'so-suffix so-suffix 'so-mode 'local - 'fs-change (if windows? + 'fs-change (if (eq? os 'windows) '#(supported scalable low-latency #f) + ;; Warning: not necessarily right for cross compilation: (system-type 'fs-change)) 'target-machine (if (equal? "any" (vector-ref (current-command-line-arguments) 2)) #f diff --git a/racket/src/cs/compile-file.ss b/racket/src/cs/compile-file.ss index 6ddb7c409f..d669a84736 100644 --- a/racket/src/cs/compile-file.ss +++ b/racket/src/cs/compile-file.ss @@ -2,7 +2,7 @@ ;; Check to make we're using a build of Chez Scheme ;; that has all the features we need. (define-values (need-maj need-min need-sub need-dev) - (values 9 5 3 49)) + (values 9 5 3 50)) (unless (guard (x [else #f]) (eval 'scheme-fork-version-number)) (error 'compile-file diff --git a/racket/src/cs/rumble/system.ss b/racket/src/cs/rumble/system.ss index 08efcbb124..11e23778f1 100644 --- a/racket/src/cs/rumble/system.ss +++ b/racket/src/cs/rumble/system.ss @@ -1,11 +1,4 @@ -(define system-type - (case-lambda - [() (system-type* 'os)] - [(mode) (if (eq? mode 'vm) - 'chez-scheme - (system-type* mode))])) - (define unix-style-macos? (meta-cond [(getenv "PLT_CS_MAKE_UNIX_STYLE_MACOS") #t] @@ -22,37 +15,112 @@ (define fs-change-properties '#(#f #f #f #f)) (define (set-fs-change-properties! vec) (set! fs-change-properties vec)) -(define (system-type* mode) - (case mode - [(vm) 'chez-scheme] - [(os) (case (machine-type) - [(a6osx ta6osx i3osx ti3osx) - (if unix-style-macos? 'unix 'macosx)] - [(a6nt ta6nt i3nt ti3nt) 'windows] - [else 'unix])] - [(word) (if (> (fixnum-width) 32) 64 32)] - [(gc) 'cs] - [(link) (case (and (not unix-style-macos?) - (machine-type)) - [(a6osx ta6osx i3osx ti3osx) 'framework] - [(a6nt ta6nt i3nt ti3nt) 'windows] - [else (if unix-link-shared? - 'shared - 'static)])] - [(machine) (get-machine-info)] - [(so-suffix) (case (machine-type) - [(a6osx ta6osx i3osx ti3osx) (string->utf8 ".dylib")] - [(a6nt ta6nt i3nt ti3nt) (string->utf8 ".dll")] - [else (string->utf8 ".so")])] - [(so-mode) 'local] - [(fs-change) fs-change-properties] - [(target-machine) (machine-type)] - [(cross) cross-mode] - [else (raise-argument-error 'system-type - (string-append - "(or/c 'os 'word 'vm 'gc 'link 'machine 'target-machine\n" - " 'so-suffix 'so-mode 'fs-change 'cross)") - mode)])) +;; Definitons like `os-symbol` are also parsed by "../c/gen-system.rkt" + +(define os-symbol + (case (machine-type) + [(a6osx ta6osx i3osx ti3osx arm64osx tarm64osx) + (if unix-style-macos? 'unix 'macosx)] + [(a6nt ta6nt i3nt ti3nt) 'windows] + [else 'unix])) + +(define os*-symbol + (case (machine-type) + [(a6osx ta6osx i3osx ti3osx) (if unix-style-macos? + 'darwin + 'macosx)] + [(a6nt ta6nt i3nt ti3nt) 'windows] + [(a6le ta6le i3le ti3le + arm32le tarm32le arm64le tarm64le + ppc32le tppc32le) + 'linux] + [(a6ob ta6ob i3ob ti3ob) 'openbsd] + [(a6fb ta6fb i3fb ti3fb) 'freebsd] + [(a6nb ta6nb i3nb ti3nb) 'netbsd] + [(a6s2 ta6s2 i3s2 ti3s2) 'solaris] + [(i3qnx) 'qnx] + [else (error 'system-type "internal error: unknown operating system")])) + +(define arch-symbol + (case (machine-type) + [(a6osx ta6osx + a6nt ta6nt + a6le ta6le + a6ob ta6ob + a6fb ta6fb + a6s2 ta6s2) + 'x86_64] + [(i3osx ti3osx + i3nt ti3nt + i3le ti3le + i3ob ti3ob + i3fb ti3fb + i3s2 ti3s2 + i3qnx) + 'i386] + [(arm32le tarm32le) 'arm] + [(arm64le tarm64le arm64osx tarm64osx) 'aarch64] + [(ppc32le tppc32le) 'ppc] + [else (error 'system-type "internal error: unknown architecture")])) + +(define link-symbol + (case (machine-type) + [(a6osx ta6osx i3osx ti3osx arm64osx tarm64osx) + (if unix-style-macos? + 'static + 'framework)] + [(a6nt ta6nt i3nt ti3nt) 'windows] + [else (if unix-link-shared? + 'shared + 'static)])) + +(define so-suffix-bytes + (case (machine-type) + [(a6osx ta6osx i3osx ti3osx arm64osx tarm64osx) (string->utf8 ".dylib")] + [(a6nt ta6nt i3nt ti3nt) (string->utf8 ".dll")] + [else (string->utf8 ".so")])) + +;; Force inline of some common cases, so optimization can use +;; the resulting constant: +(define-syntax system-type + (lambda (stx) + (syntax-case stx (quote) + [(_ 'key) (case (#%syntax->datum #'key) + [(vm) #''chez-scheme] + [(os) #'os-symbol] + [(os*) #'os*-symbol] + [(arch) #'arch-symbol] + [(word) #'(if (> (fixnum-width) 32) 64 32)] + [(gc) #''cs] + [else #'(system-type* 'key)])] + [(_ arg ...) #'(system-type* arg ...)] + [_ #'system-type*]))) + +(define system-type* + (|#%name| + system-type + (case-lambda + [() (system-type* 'os)] + [(mode) + (case mode + [(vm) 'chez-scheme] + [(os) os-symbol] + [(os*) os*-symbol] + [(arch) arch-symbol] + [(word) (if (> (fixnum-width) 32) 64 32)] + [(gc) 'cs] + [(link) link-symbol] + [(machine) (get-machine-info)] + [(so-suffix) so-suffix-bytes] + [(so-mode) 'local] + [(fs-change) fs-change-properties] + [(target-machine) (machine-type)] + [(cross) cross-mode] + [else (raise-argument-error 'system-type + (string-append + "(or/c 'os 'os* 'arch 'word 'vm 'gc 'link 'machine 'target-machine\n" + " 'so-suffix 'so-mode 'fs-change 'cross)") + mode)])]))) (define (system-path-convention-type) (case (machine-type) @@ -64,23 +132,9 @@ (case (machine-type) [(a6nt ta6nt) "win32\\x86_64"] [(i3nt ti3nt) "win32\\i386"] - [(a6osx ta6osx) (if unix-style-macos? "x86_64-darwin" "x86_64-macosx")] - [(i3osx ti3osx) (if unix-style-macos? "i386-darwin" "i386-macosx")] - [(a6le ta6le) "x86_64-linux"] - [(i3le ti3le) "i386-linux"] - [(arm32le tarm32le) "arm-linux"] - [(arm64le tarm64le) "aarch64-linux"] - [(ppc32le tppc32le) "ppc-linux"] - [(i3ob ti3ob) "i386-openbsd"] - [(a6ob ta6ob) "x86_64-openbsd"] - [(i3ob ti3ob) "i386-openbsd"] - [(a6fb ta6fb) "x86_64-freebsd"] - [(i3fb ti3fb) "i386-freebsd"] - [(a6nb ta6nb) "x86_64-netbsd"] - [(i3nb ti3nb) "i386-netbsd"] - [(a6s2 ta6s2) "x86_64-solaris"] - [(i3s2 ti3s2) "i386-solaris"] - [else "unix"]) + [else (string-append (symbol->string arch-symbol) + "-" + (symbol->string os*-symbol))]) (let-syntax ([suffix (lambda (stx) (or (getenv "PLT_CS_SLSP_SUFFIX")