diff --git a/pkgs/racket-doc/scribblings/reference/eval.scrbl b/pkgs/racket-doc/scribblings/reference/eval.scrbl index 9561f7876c..eabfb31412 100644 --- a/pkgs/racket-doc/scribblings/reference/eval.scrbl +++ b/pkgs/racket-doc/scribblings/reference/eval.scrbl @@ -613,7 +613,8 @@ When @racket[(system-type 'vm)] reports @racket['racket], then the only target symbol is @racket['racket]. When @racket[(system-type 'vm)] reports @racket['chez-scheme], then a symbol corresponding to the current platform is a target, and other targets may also be -supported. +supported. The @racket['target-machine] mode of @racket[system-type] +reports the running Racket's native target machine. @history[#:added "7.1.0.6"]} diff --git a/pkgs/racket-doc/scribblings/reference/runtime.scrbl b/pkgs/racket-doc/scribblings/reference/runtime.scrbl index 899e192e90..362246d8b8 100644 --- a/pkgs/racket-doc/scribblings/reference/runtime.scrbl +++ b/pkgs/racket-doc/scribblings/reference/runtime.scrbl @@ -4,10 +4,10 @@ @title[#:tag "runtime"]{Environment and Runtime Information} -@defproc[(system-type [mode (or/c 'os 'word 'vm 'gc 'link 'machine +@defproc[(system-type [mode (or/c 'os 'word 'vm 'gc 'link 'machine 'target-machine 'so-suffix 'so-mode 'fs-change 'cross) 'os]) - (or/c symbol? string? bytes? exact-positive-integer? vector?)]{ + (or/c symbol? string? bytes? exact-positive-integer? vector? #f)]{ Returns information about the operating system, build mode, or machine for a running Racket. (Installation tools should use @racket[cross-system-type], @@ -59,6 +59,13 @@ In @indexed-racket['machine] mode, then the result is a string, which contains further details about the current machine in a platform-specific format. +In @indexed-racket['target-machine] mode, the result is a symbol for +the running Racket's native bytecode format, or it is @racket[#f] if +there is no native format other than the machine-independent format. +If the result is a symbol, then @racket[compile-target-machine?] returns +@racket[#t] when applied to the symbol; see also +@racket[current-compile-target-machine]. + In @indexed-racket['so-suffix] mode, then the result is a byte string that represents the file extension used for shared objects on the current platform. The byte string starts with a period, so it is @@ -107,7 +114,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 "6.9.0.1" @elem{Added @racket['cross] mode.} + #:changed "7.1.0.6" @elem{Added @racket['target-machine] mode.}]} @defproc[(system-language+country) string?]{ diff --git a/racket/collects/setup/cross-system.rkt b/racket/collects/setup/cross-system.rkt index ef590d9113..d2e6bcb2f0 100644 --- a/racket/collects/setup/cross-system.rkt +++ b/racket/collects/setup/cross-system.rkt @@ -7,13 +7,12 @@ (define cross-system-table #f) -(define system-type-symbols '(os word gc vm link machine so-suffix so-mode fs-change)) +(define system-type-symbols '(os word gc vm link machine so-suffix so-mode fs-change target-machine)) (define (compute-cross!) (unless cross-system-table (define lib-dir (find-lib-dir)) (define ht (and lib-dir - (eq? (system-type 'vm) 'racket) ; only the Racket VM supports cross-compilation, for now (let ([f (build-path lib-dir "system.rktd")]) (and (file-exists? f) (let ([ht (call-with-default-reading-parameterization @@ -22,6 +21,11 @@ f read)))]) (and (hash? ht) + ;; If 'vm doesn't match, then assuming that we're looking + ;; at a multi-vm overlay, instead of cross-compiling, + ;; because cross-compiling requires the same VM. + (eq? (system-type 'vm) + (hash-ref ht 'vm #f)) (for/and ([sym (in-list (list* 'library-subpath 'library-subpath-convention @@ -31,7 +35,7 @@ (and (for/and ([sym (in-list system-type-symbols)] #:unless (or (eq? sym 'machine) (eq? sym 'gc))) - (equal? (hash-ref ht sym) (system-type sym))) + (equal? (hash-ref ht sym #f) (system-type sym))) (equal? (bytes->path (hash-ref ht 'library-subpath) (hash-ref ht 'library-subpath-convention)) (system-library-subpath #f)))) @@ -50,7 +54,7 @@ (unless (memq mode system-type-symbols) (raise-argument-error 'cross-system-type - "(or/c 'os 'word 'gc 'vm 'link 'machine 'so-suffix 'so-mode 'fs-change)" + "(or/c 'os 'word 'gc 'vm 'link 'machine 'target-machine 'so-suffix 'so-mode 'fs-change)" mode)) (compute-cross!) (or (hash-ref cross-system-table mode #f) diff --git a/racket/src/cs/c/Makefile.in b/racket/src/cs/c/Makefile.in index e7908e4be8..c775902c47 100644 --- a/racket/src/cs/c/Makefile.in +++ b/racket/src/cs/c/Makefile.in @@ -237,6 +237,7 @@ common-install: $(STRIP_DEBUG) "$(DESTDIR)$(libpltdir)/starter" $(ICP) $(srcdir)/../../start/starter-sh "$(DESTDIR)$(libpltdir)/starter-sh" $(RACKET) -cu "$(srcdir)/../../racket/collects-path.rkt" "$(DESTDIR)$(libpltdir)/starter" $(DESTDIR)@COLLECTS_PATH@ $(DESTDIR)@CONFIG_PATH@ + $(RACKET) -cu "$(srcdir)/gen-system.rkt" $(DESTDIR)$(libpltdir)/system$(CS_INSTALLED).rktd $(MACH) unix-install: $(MAKE) common-install diff --git a/racket/src/cs/c/gen-system.rkt b/racket/src/cs/c/gen-system.rkt new file mode 100644 index 0000000000..b18e33165f --- /dev/null +++ b/racket/src/cs/c/gen-system.rkt @@ -0,0 +1,22 @@ +(module gen-system '#%kernel + + ;; Command-line argument: + + (define-values (ht) + (hash 'os (system-type 'os) + 'word (system-type 'word) + 'gc 'cs + 'vm 'chez-scheme + 'link 'static + 'machine (bytes->string/utf-8 (path->bytes (system-library-subpath #f))) + 'so-suffix (system-type 'so-suffix) + 'so-mode 'local + 'fs-change '#(#f #f #f #f) + 'target-machine (string->symbol (vector-ref (current-command-line-arguments) 1)))) + + (call-with-output-file + (vector-ref (current-command-line-arguments) 0) + (lambda (o) + (write ht o) + (newline o)) + 'truncate/replace)) diff --git a/racket/src/cs/rumble/system.ss b/racket/src/cs/rumble/system.ss index f3a6b8b93d..dbca41dce6 100644 --- a/racket/src/cs/rumble/system.ss +++ b/racket/src/cs/rumble/system.ss @@ -31,11 +31,12 @@ [(a6nt ta6nt i3nt ti3nt) (string->utf8 ".dll")] [else (string->utf8 ".so")])] [(so-mode) 'local] - [(fs-change) '#(#f #f #f #f)] + [(fs-change) '#(#f #f #f #f)] ; when this changes, change "gen-system.rkt", too + [(target-machine) (machine-type)] [(cross) cross-mode] [else (raise-argument-error 'system-type (string-append - "(or/c 'os 'word 'vm 'gc 'link 'machine\n" + "(or/c 'os 'word 'vm 'gc 'link 'machine 'target-machine\n" " 'so-suffix 'so-mode 'fs-change 'cross)") mode)])) diff --git a/racket/src/racket/mksystem.rkt b/racket/src/racket/mksystem.rkt index a493d77623..8dc2ddde66 100644 --- a/racket/src/racket/mksystem.rkt +++ b/racket/src/racket/mksystem.rkt @@ -1,4 +1,4 @@ -(module mkincludes '#%kernel +(module mksystem '#%kernel ;; Arguments are ;; [ <3m-exe-suffix> ] (define-values (args) (current-command-line-arguments)) @@ -22,6 +22,7 @@ 'so-suffix (system-type 'so-suffix) 'so-mode (system-type 'so-mode) 'fs-change (system-type 'fs-change) + 'target-machine 'racket 'library-subpath (path->bytes (system-library-subpath #f)) 'library-subpath-convention (system-path-convention-type)) ;; Cross-compiling; use `cpp` to get details @@ -64,6 +65,7 @@ 'so-suffix (string->bytes/utf-8 (get-string "system_type_so_suffix")) 'so-mode (get-symbol "system_type_so_mode") 'fs-change '#(#f #f #f #f) + 'target-machine 'racket 'library-subpath (string->bytes/utf-8 library-subpath) 'library-subpath-convention (if (eq? os 'windows) 'windows diff --git a/racket/src/racket/src/string.c b/racket/src/racket/src/string.c index 1e778bc9fb..86a384f89b 100644 --- a/racket/src/racket/src/string.c +++ b/racket/src/racket/src/string.c @@ -196,7 +196,7 @@ static char *string_to_from_locale(int to_bytes, ROSYM static Scheme_Object *sys_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, *cross_symbol; +ROSYM static Scheme_Object *os_symbol, *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; @@ -246,6 +246,7 @@ scheme_init_string (Scheme_Startup_Env *env) REGISTER_SO(word_symbol); REGISTER_SO(os_symbol); REGISTER_SO(fs_change_symbol); + REGISTER_SO(target_machine_symbol); REGISTER_SO(cross_symbol); link_symbol = scheme_intern_symbol("link"); machine_symbol = scheme_intern_symbol("machine"); @@ -256,6 +257,7 @@ scheme_init_string (Scheme_Startup_Env *env) word_symbol = scheme_intern_symbol("word"); os_symbol = scheme_intern_symbol("os"); fs_change_symbol = scheme_intern_symbol("fs-change"); + target_machine_symbol = scheme_intern_symbol("target-machine"); cross_symbol = scheme_intern_symbol("cross"); REGISTER_SO(racket_symbol); @@ -2412,12 +2414,19 @@ static Scheme_Object *system_type(int argc, Scheme_Object *argv[]) return fs_change_props; } + if (SAME_OBJ(argv[0], target_machine_symbol)) { + return racket_symbol; + } + if (SAME_OBJ(argv[0], cross_symbol)) { return (cross_compile_mode ? force_symbol : infer_symbol); } if (!SAME_OBJ(argv[0], os_symbol)) { - scheme_wrong_contract("system-type", "(or/c 'os 'word 'link 'machine 'vm 'gc 'so-suffix 'so-mode 'word 'fs-change 'cross)", 0, argc, argv); + scheme_wrong_contract("system-type", + ("(or/c 'os '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/worksp/csbuild.rkt b/racket/src/worksp/csbuild.rkt index e9a9fa75f3..667d3efc7e 100644 --- a/racket/src/worksp/csbuild.rkt +++ b/racket/src/worksp/csbuild.rkt @@ -256,3 +256,8 @@ (format "mrstart~a.sln" pltslnver) "/p:Configuration=Release" (format "/p:Platform=~a" buildmode))) + +(system*! (find-exe) + "../cs/c/gen-system.rkt" + (format "../../lib/system~a.rktd" cs-suffix) + machine)