From c1159fb02e46585ef6946245203855b977fd8ccc Mon Sep 17 00:00:00 2001 From: Bogdan Popa Date: Sun, 17 Jan 2021 17:16:02 +0200 Subject: [PATCH] cs: add support for cross-compiling to iOS Includes documentation notes about cross-compiling CS for iOS and makefile improvements. The changes also include improvements to `raco exe`. Racket CS cannot currently read fasl files for platforms other than the host, but `compiler/embed` has to be able to read compiled code in order to figure out what code needs to be embedded into an output image and which runtime paths need to be included. This change makes it so that host code is used to figure all of that information out, but that code is then replaced by target machine code before it is written to the output image. The new logic only applies when the right cross-compilation flags are set (per `cross-multi-compile?`). --- .../scribblings/inside/appendix.scrbl | 72 ++++- racket/collects/compiler/cross.rkt | 8 + racket/collects/compiler/embed.rkt | 273 ++++++++++-------- .../collects/compiler/private/cm-minimal.rkt | 8 +- racket/collects/setup/private/pkg-deps.rkt | 12 +- racket/collects/setup/setup-core.rkt | 5 +- racket/src/ChezScheme/IMPLEMENTATION.md | 2 +- racket/src/ChezScheme/c/Mf-arm64osx | 6 +- racket/src/ChezScheme/c/alloc.c | 19 +- racket/src/ChezScheme/c/arm32le.c | 8 + racket/src/ChezScheme/c/expeditor.c | 2 +- racket/src/ChezScheme/c/externs.h | 4 +- racket/src/ChezScheme/c/fasl.c | 10 +- racket/src/ChezScheme/c/gc.c | 8 +- racket/src/ChezScheme/c/prim.c | 11 +- racket/src/ChezScheme/c/prim5.c | 43 +-- racket/src/ChezScheme/c/scheme.c | 4 +- racket/src/ChezScheme/c/schsig.c | 11 +- racket/src/ChezScheme/c/segment.c | 167 ++++++++++- racket/src/ChezScheme/c/thread.c | 4 +- racket/src/ChezScheme/c/types.h | 5 +- racket/src/ChezScheme/c/version.h | 19 +- racket/src/Makefile.in | 7 + racket/src/README.txt | 22 +- racket/src/ac/sdk_ios.m4 | 22 ++ racket/src/ac/sdk_show.m4 | 2 +- racket/src/bc/configure | 12 +- racket/src/bc/configure.ac | 24 +- racket/src/cs/c/Makefile.in | 18 +- racket/src/cs/c/configure | 33 ++- racket/src/cs/c/configure.ac | 9 +- 31 files changed, 610 insertions(+), 240 deletions(-) create mode 100644 racket/collects/compiler/cross.rkt create mode 100644 racket/src/ac/sdk_ios.m4 diff --git a/pkgs/racket-doc/scribblings/inside/appendix.scrbl b/pkgs/racket-doc/scribblings/inside/appendix.scrbl index f69c9724ee..b10142ebac 100644 --- a/pkgs/racket-doc/scribblings/inside/appendix.scrbl +++ b/pkgs/racket-doc/scribblings/inside/appendix.scrbl @@ -28,6 +28,68 @@ build modes that are more suitable for developing Racket itself; see @; ---------------------------------------- +@section[#:tag "ios-cross-compilation"]{Cross-compiling Racket Sources for iOS} + +Everything in this section can be adapted to other cross-compilation +targets, but iOS is used to give concrete examples. + +After cross-compiling Racket CS for iOS according to the documentation +in the source distribution's @filepath{src/README.txt} file, you can +use that build of Racket in conjunction with the host build it was +compiled by to cross-compile Racket modules for iOS by passing the +following set of flags to the host executable: + +@verbatim[#:indent 2]{ +racket \ + --compile-any \ + --compiled 'compiled_host:tarm64osx' \ + --cross \ + --cross-compiler tarm64osx /path/to/ios/racket/lib \ + --config /path/to/ios/racket/etc \ + --collects /path/to/ios/racket/collects +} + +The above command runs the host Racket REPL with support for +outputting compiled code for both the host machine and for the +@tt{tarm64osx} target. The second path to @exec{--compiled} may be +any relative path, but @filepath{tarm64osx} is what the cross build +uses to set up its installation so it is convenient to re-use it. + +Furthermore, you can instruct the host Racket to run library code by +passing the @exec{-l} flag. For example, you can setup the target +Racket's installation with the following command: + +@verbatim[#:indent 2]{ +racket \ + --compile-any \ + --compiled 'compiled_host:tarm64osx' \ + --cross \ + --cross-compiler tarm64osx /path/to/ios/racket/lib \ + --config /path/to/ios/racket/etc \ + --collects /path/to/ios/racket/collects \ + -l- \ + raco setup +} + +Finally, you can package up a Racket module and its dependencies for +use with @cppi{racket_embedded_load_file} (after installing +@filepath{compiler-lib} and @filepath{cext-lib} for the target Racket) +with: + +@verbatim[#:indent 2]{ +racket \ + --compile-any \ + --compiled 'compiled_host:tarm64osx' \ + --cross \ + --cross-compiler tarm64osx /path/to/ios/racket/lib \ + --config /path/to/ios/racket/etc \ + --collects /path/to/ios/racket/collects \ + -l- \ + raco ctool --mods application.zo src/application.rkt +} + +@; ---------------------------------------- + @section[#:tag "segment-ideas"]{Embedding Files in Executable Sections} Locating external files on startup, such as the boot files needed for @@ -198,7 +260,7 @@ static char *get_self_path() char *s; uint32_t size = 0; int r; - + r = _NSGetExecutablePath(NULL, &size); s = malloc(size+1); r = _NSGetExecutablePath(s, &size); @@ -235,7 +297,7 @@ int main(int argc, char **argv) ba.boot1_offset = find_section("__DATA", "__rktboot1"); ba.boot2_offset = find_section("__DATA", "__rktboot2"); ba.boot3_offset = find_section("__DATA", "__rktboot3"); - + ba.exec_file = argv[0]; ba.run_file = argv[0]; @@ -304,7 +366,7 @@ static long find_resource_offset(wchar_t *path, int id, int type, int encoding) DWORD val, got, sec_pos, virtual_addr, rsrcs, pos; WORD num_sections, head_size; char name[8]; - + SetFilePointer(fd, 60, 0, FILE_BEGIN); ReadFile(fd, &val, 4, &got, NULL); SetFilePointer(fd, val+4+2, 0, FILE_BEGIN); /* Skip "PE\0\0" tag and machine */ @@ -327,7 +389,7 @@ static long find_resource_offset(wchar_t *path, int id, int type, int encoding) SetFilePointer(fd, 4, 0, FILE_CURRENT); /* skip file size */ ReadFile(fd, &rsrcs, 4, &got, NULL); SetFilePointer(fd, rsrcs, 0, FILE_BEGIN); - + /* We're at the resource table; step through 3 layers */ pos = find_by_id(fd, rsrcs, rsrcs, id); if (pos) { @@ -364,7 +426,7 @@ static DWORD find_by_id(HANDLE fd, DWORD rsrcs, DWORD pos, int id) { DWORD got, val; WORD name_count, id_count; - + SetFilePointer(fd, pos + 12, 0, FILE_BEGIN); ReadFile(fd, &name_count, 2, &got, NULL); ReadFile(fd, &id_count, 2, &got, NULL); diff --git a/racket/collects/compiler/cross.rkt b/racket/collects/compiler/cross.rkt new file mode 100644 index 0000000000..02ec17f07c --- /dev/null +++ b/racket/collects/compiler/cross.rkt @@ -0,0 +1,8 @@ +#lang racket/base + +(require "private/cm-minimal.rkt") + +(provide + ;; Publicly re-provide cross-multi-compile? for tools that need to be + ;; aware of cross-multi mode (like `raco setup'). + cross-multi-compile?) diff --git a/racket/collects/compiler/embed.rkt b/racket/collects/compiler/embed.rkt index 1fa31dd35a..34a9afa3e8 100644 --- a/racket/collects/compiler/embed.rkt +++ b/racket/collects/compiler/embed.rkt @@ -15,6 +15,7 @@ racket/private/so-search racket/private/share-search setup/cross-system + "private/cm-minimal.rkt" "private/winsubsys.rkt" "private/macfw.rkt" "private/mach-o.rkt" @@ -515,34 +516,38 @@ "" submod-path)))]) (hash-set! working filename full-name) - (let ([code (or ready-code - (get-module-code just-filename - #:submodule-path submod-path - (let ([l (use-compiled-file-paths)]) - (if (pair? l) - (car l) - "compiled")) - compiler - (if on-extension - (lambda (f l?) - (on-extension f l?) - #f) - (lambda (file _loader?) - (if _loader? - (error 'create-embedding-executable - "cannot use a _loader extension: ~e" - file) - (make-extension file)))) - #:choose - ;; Prefer extensions, if we're handling them: - (lambda (src zo so) - (set! actual-filename src) ; remember convert source name - (if on-extension - #f - (if (and (file-exists? so) - ((file-date so) . >= . (file-date zo))) - 'so - #f)))))]) + (let* ([get-module-code* + ;; Re-used when swapping code during cross-compilation. + (lambda (#:roots [roots (current-compiled-file-roots)]) + (get-module-code just-filename + #:roots roots + #:submodule-path submod-path + (let ([l (use-compiled-file-paths)]) + (if (pair? l) + (car l) + "compiled")) + compiler + (if on-extension + (lambda (f l?) + (on-extension f l?) + #f) + (lambda (file _loader?) + (if _loader? + (error 'create-embedding-executable + "cannot use a _loader extension: ~e" + file) + (make-extension file)))) + #:choose + ;; Prefer extensions, if we're handling them: + (lambda (src zo so) + (set! actual-filename src) ; remember convert source name + (if on-extension + #f + (if (and (file-exists? so) + ((file-date so) . >= . (file-date zo))) + 'so + #f)))))] + [code (or ready-code (get-module-code*))]) (cond [(extension? code) (when verbose? @@ -556,82 +561,83 @@ (unbox codes)))] [code (let ([importss (module-compiled-imports code)]) - (let ([all-file-imports (filter (keep-import-dependency? keep-full? actual-filename) - (apply append (map cdr importss)))] - [extra-paths - (map symbol-to-lib-form (append (if keep-full? - (extract-full-imports module-path actual-filename code) - null) - (if use-source? - (list 'compiler/private/read-bstr) - null) - (get-extra-imports actual-filename code)))]) - (let* ([runtime-paths - (if (module-compiled-cross-phase-persistent? code) - ;; avoid potentially trying to redeclare cross-phase persistent modules, - ;; since redeclaration isn't allowed: + (let* ([all-file-imports (filter (keep-import-dependency? keep-full? actual-filename) + (apply append (map cdr importss)))] + [extra-paths + (map symbol-to-lib-form (append (if keep-full? + (extract-full-imports module-path actual-filename code) + null) + (if use-source? + (list 'compiler/private/read-bstr) + null) + (get-extra-imports actual-filename code)))] + [extract-submods + (lambda (submods) + (if use-source? null - ;; check for run-time paths by visiting the module in an - ;; expand-time namespace: - (parameterize ([current-namespace expand-namespace]) - (let ([module-path - (if (path? module-path) - (path->complete-path module-path) - module-path)]) - (unless (module-declared? module-path) - (parameterize ([current-module-declare-name - (module-path-index-resolve (module-path-index-join - module-path - #f))]) - (eval code))) - (define e (expand `(,#'module m racket/kernel - (#%require (only ,module-path) - racket/runtime-path) - (runtime-paths ,module-path)))) - (syntax-case e (quote) - [(_ m mz (#%mb req (quote (spec ...)))) - (for/list ([p (in-list (syntax->datum #'(spec ...)))]) - ;; Strip variable reference from 'module specs, because - ;; we don't need them and they retain the namespace: - (if (and (pair? p) (eq? 'module (car p))) - (list 'module (cadr p)) - p))] - [_else (error 'create-empbedding-executable - "expansion mismatch when getting external paths: ~e" - (syntax->datum e))]))))] - - [extra-runtime-paths (filter - values - (map (lambda (p) - (and (pair? p) - (eq? (car p) 'module) - (cadr p))) - runtime-paths))] - [renamed-code (if (symbol? (module-compiled-name code)) - code - (module-compiled-name code (last (module-compiled-name code))))] - [extract-submods (lambda (l) - (if use-source? - null - (for/list ([m (in-list l)] - #:when (or (member (last (module-compiled-name m)) use-submods) - (declares-always-preserved? m))) - m)))] - [pre-submods (extract-submods (module-compiled-submodules renamed-code #t))] - [post-submods (extract-submods (module-compiled-submodules renamed-code #f))] - [code (if keep-full? - code - (module-compiled-submodules (module-compiled-submodules - renamed-code - #f - null) - #t - null))]) - (let ([sub-files (map (lambda (i) + (for/list ([m (in-list submods)] + #:when (or (member (last (module-compiled-name m)) use-submods) + (declares-always-preserved? m))) + m)))] + [prepare-code&submods + (lambda (code) + (define name (module-compiled-name code)) + (define renamed-code + (cond + [(symbol? name) code] + [else (module-compiled-name code (last name))])) + (define pre-submods (extract-submods (module-compiled-submodules renamed-code #t))) + (define post-submods (extract-submods (module-compiled-submodules renamed-code #f))) + (define new-code + (cond + [keep-full? code] + [else (module-compiled-submodules + (module-compiled-submodules renamed-code #f null) #t null)])) + (values new-code pre-submods post-submods))]) + (let*-values ([(runtime-paths) + (if (module-compiled-cross-phase-persistent? code) + ;; avoid potentially trying to redeclare cross-phase persistent modules, + ;; since redeclaration isn't allowed: + null + ;; check for run-time paths by visiting the module in an + ;; expand-time namespace: + (parameterize ([current-namespace expand-namespace]) + (let ([module-path + (if (path? module-path) + (path->complete-path module-path) + module-path)]) + (unless (module-declared? module-path) + (parameterize ([current-module-declare-name + (module-path-index-resolve (module-path-index-join + module-path + #f))]) + (eval code))) + (define e (expand `(,#'module m racket/kernel + (#%require (only ,module-path) + racket/runtime-path) + (runtime-paths ,module-path)))) + (syntax-case e (quote) + [(_ m mz (#%mb req (quote (spec ...)))) + (for/list ([p (in-list (syntax->datum #'(spec ...)))]) + ;; Strip variable reference from 'module specs, because + ;; we don't need them and they retain the namespace: + (if (and (pair? p) (eq? 'module (car p))) + (list 'module (cadr p)) + p))] + [_else (error 'create-empbedding-executable + "expansion mismatch when getting external paths: ~e" + (syntax->datum e))]))))] + [(extra-runtime-paths) (filter-map (lambda (p) + (and (pair? p) + (eq? (car p) 'module) + (cadr p))) + runtime-paths)] + [(code pre-submods post-submods) (prepare-code&submods code)]) + (let ([sub-files (map (lambda (i) ;; use `just-filename', because i has submod name embedded (normalize (resolve-module-path-index i just-filename))) all-file-imports)] - [sub-paths (map (lambda (i) + [sub-paths (map (lambda (i) ;; use `root-module-path', because i has submod name embedded (collapse-module-path-index i root-module-path)) all-file-imports)] @@ -738,25 +744,40 @@ (append sub-paths extra-runtime-paths))) (map get-submod-mapping pre-submods)))]) ;; Record the module - (set-box! codes - (cons (make-mod filename module-path code - name full-name - mappings-box - runtime-paths - ;; extract runtime-path module symbols: - (let loop ([runtime-paths runtime-paths] - [extra-files extra-files]) - (cond - [(null? runtime-paths) null] - [(let ([p (car runtime-paths)]) - (and (pair? p) (eq? (car p) 'module))) - (cons (lookup-full-name (car extra-files)) - (loop (cdr runtime-paths) (cdr extra-files)))] - [else - (cons #f (loop (cdr runtime-paths) extra-files))])) - actual-filename - use-source?) - (unbox codes))) + ;; For cross-compilation, we need to be able to execute code using the host Racket (to find + ;; dependencies and runtime paths), but then we have to swap in code for the target Racket + ;; here, before writing it to the output. + (let ([code (cond + [(cross-compiling?) + (when verbose? + (eprintf "Swapping host code of ~s for target platform~n" module-path)) + (define target-code + (get-module-code* #:roots (cdr (current-compiled-file-roots)))) + ;; Apply the same trasformations to the target code that were made to the host code. + (define-values (prepared-code _pre-submods _post-submods) + (prepare-code&submods target-code)) + prepared-code] + [else + code])]) + (set-box! codes + (cons (make-mod filename module-path code + name full-name + mappings-box + runtime-paths + ;; extract runtime-path module symbols: + (let loop ([runtime-paths runtime-paths] + [extra-files extra-files]) + (cond + [(null? runtime-paths) null] + [(let ([p (car runtime-paths)]) + (and (pair? p) (eq? (car p) 'module))) + (cons (lookup-full-name (car extra-files)) + (loop (cdr runtime-paths) (cdr extra-files)))] + [else + (cons #f (loop (cdr runtime-paths) extra-files))])) + actual-filename + use-source?) + (unbox codes)))) ;; Add code for post submodules: (for-each get-one-submodule-code post-submods) ;; Add post-submodule mappings: @@ -813,7 +834,8 @@ (define (compile-using-kernel e) (let ([ns (make-empty-namespace)]) (namespace-attach-module (current-namespace) ''#%kernel ns) - (parameterize ([current-namespace ns]) + (parameterize ([current-namespace ns] + [current-compile-target-machine (get-compile-target-machine)]) (namespace-require ''#%kernel) (compile e)))) @@ -1404,7 +1426,8 @@ #:on-extension [on-extension #f] #:expand-namespace [expand-namespace (current-namespace)] #:compiler [compiler (lambda (expr) - (parameterize ([current-namespace expand-namespace]) + (parameterize ([current-namespace expand-namespace] + [current-compile-target-machine (get-compile-target-machine)]) (compile expr)))] #:src-filter [src-filter (lambda (filename) #f)] #:get-extra-imports [get-extra-imports (lambda (filename code) null)]) @@ -1418,6 +1441,14 @@ void #f)) ; don't accumulate embedded DLLs +(define (cross-compiling?) + (cross-multi-compile? (current-compiled-file-roots))) + +(define (get-compile-target-machine) + (if (cross-compiling?) + (cross-system-type 'target-machine) + (system-type 'target-machine))) + ;; The old interface: (define make-embedding-executable diff --git a/racket/collects/compiler/private/cm-minimal.rkt b/racket/collects/compiler/private/cm-minimal.rkt index f88aa0e445..55ad165458 100644 --- a/racket/collects/compiler/private/cm-minimal.rkt +++ b/racket/collects/compiler/private/cm-minimal.rkt @@ -67,12 +67,14 @@ managed-compiled-context-key make-compilation-context-error-display-handler - + parallel-lock-client - + install-module-hashes! - current-path->mode) + current-path->mode + + cross-multi-compile?) (module+ cm-internal (provide try-file-time diff --git a/racket/collects/setup/private/pkg-deps.rkt b/racket/collects/setup/private/pkg-deps.rkt index 1d8de2cb13..c736d83b2a 100644 --- a/racket/collects/setup/private/pkg-deps.rkt +++ b/racket/collects/setup/private/pkg-deps.rkt @@ -13,6 +13,7 @@ setup/dirs setup/doc-db version/utils + compiler/cross compiler/private/dep "time.rkt") @@ -407,10 +408,17 @@ ;; ---------------------------------------- (define (find-compiled-directories path) - ;; Find all directories that can hold compiled bytecode for `path` + ;; Find all directories that can hold compiled bytecode for + ;; `path`. When cross-compiling, only list directories targeting + ;; the host machine. + (define roots + (let ([roots (current-compiled-file-roots)]) + (if (cross-multi-compile? roots) + (list (car roots)) + roots))) (filter values - (for*/list ([root (in-list (current-compiled-file-roots))] + (for*/list ([root (in-list roots)] [mode (in-list (use-compiled-file-paths))]) (define compiled-dir (cond diff --git a/racket/collects/setup/setup-core.rkt b/racket/collects/setup/setup-core.rkt index d3011eac33..7e849e1d1a 100755 --- a/racket/collects/setup/setup-core.rkt +++ b/racket/collects/setup/setup-core.rkt @@ -12,6 +12,7 @@ racket/string compiler/cm compiler/compilation-path + compiler/cross planet/planet-archives planet/private/planet-shared (only-in planet/resolver resolve-planet-path) @@ -2094,9 +2095,7 @@ (setup-printf "version" "~a" (version)) (setup-printf "platform" "~a [~a]" (cross-system-library-subpath #f) (cross-system-type 'gc)) (setup-printf "target machine" "~a" (or (current-compile-target-machine) - ;; Check for `cross-multi-compile?` mode like compiler/cm: - (and ((length (current-compiled-file-roots)) . > . 1) - (cross-installation?) + (and (cross-multi-compile? (current-compiled-file-roots)) (cross-system-type 'target-machine)) 'any)) (when (cross-installation?) diff --git a/racket/src/ChezScheme/IMPLEMENTATION.md b/racket/src/ChezScheme/IMPLEMENTATION.md index 623dd7ec2f..da8d976d5c 100644 --- a/racket/src/ChezScheme/IMPLEMENTATION.md +++ b/racket/src/ChezScheme/IMPLEMENTATION.md @@ -31,7 +31,7 @@ compiler to build a Chez Scheme compiler. The compiler and makefiles support cross-compilation, so you can work from an already supported host to cross-compile the boot files and produce the header files for a new platform. In particular, the `pb` (portable bytecode) machine -type can run on any supported hardward and operating system, so having +type can run on any supported hardware and operating system, so having `pb` boot files is one way to get started in a new environment. # Build System diff --git a/racket/src/ChezScheme/c/Mf-arm64osx b/racket/src/ChezScheme/c/Mf-arm64osx index d73163a0b3..24cdd423f2 100644 --- a/racket/src/ChezScheme/c/Mf-arm64osx +++ b/racket/src/ChezScheme/c/Mf-arm64osx @@ -16,7 +16,7 @@ m ?= arm64osx Cpu ?= AARCH64 -mdinclude = -I/opt/X11/include/ +mdinclude = -I/opt/X11/include/ o = o mdsrc ?= arm32le.c mdobj ?= arm32le.o @@ -39,7 +39,7 @@ ${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} $C -o ${Scheme} ${Main} ${Kernel} ${KernelLinkLibs} ${LDFLAGS} ${LIBS} ../zlib/configure.log: - (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS}" ./configure) + (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS}" LDFLAGS="${LDFLAGS}" ./configure) ../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS}" ${MAKE} liblz4.a) + (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS}" LDFLAGS="${LDFLAGS}" ${MAKE} liblz4.a) diff --git a/racket/src/ChezScheme/c/alloc.c b/racket/src/ChezScheme/c/alloc.c index cbeac73d54..2fa3f23212 100644 --- a/racket/src/ChezScheme/c/alloc.c +++ b/racket/src/ChezScheme/c/alloc.c @@ -33,8 +33,8 @@ void S_alloc_init() { for (g = 0; g <= static_generation; g++) { S_G.bytes_of_generation[g] = 0; for (s = 0; s <= max_real_space; s++) { - S_G.main_thread_gc.base_loc[g][s] = FIX(0); - S_G.main_thread_gc.next_loc[g][s] = FIX(0); + S_G.main_thread_gc.base_loc[g][s] = FIX(0); + S_G.main_thread_gc.next_loc[g][s] = FIX(0); S_G.main_thread_gc.bytes_left[g][s] = 0; S_G.bytes_of_space[g][s] = 0; } @@ -224,6 +224,9 @@ static void close_off_segment(thread_gc *tgc, ptr old, ptr base_loc, ptr sweep_l /* in case this is during a GC, add to sweep list */ si = SegInfo(addr_get_segment(base_loc)); si->sweep_start = sweep_loc; +#if defined(WRITE_XOR_EXECUTE_CODE) + si->sweep_bytes = bytes; +#endif si->sweep_next = tgc->sweep_next[g][s]; tgc->sweep_next[g][s] = si; } @@ -255,6 +258,15 @@ ptr S_find_more_gc_room(thread_gc *tgc, ISPC s, IGEN g, iptr n, ptr old) { tgc->bytes_left[g][s] = (new_bytes - n) - ptr_bytes; tgc->next_loc[g][s] = (ptr)((uptr)new + n); +#if defined(WRITE_XOR_EXECUTE_CODE) + if (s == space_code) { + /* Ensure allocated code segments are writable. The caller should + already have bracketed the writes with calls to start and stop + so there is no need for a stop here. */ + S_thread_start_code_write(tgc->tc, 0, 1, NULL); + } +#endif + if (tgc->during_alloc == 1) maybe_queue_fire_collector(tgc); tgc->during_alloc -= 1; @@ -272,6 +284,9 @@ void S_close_off_thread_local_segment(ptr tc, ISPC s, IGEN g) { close_off_segment(tgc, tgc->next_loc[g][s], tgc->base_loc[g][s], tgc->sweep_loc[g][s], s, g); tgc->base_loc[g][s] = (ptr)0; +#if defined(WRITE_XOR_EXECUTE_CODE) + tgc->base_loc[g][s] = 0; +#endif tgc->bytes_left[g][s] = 0; tgc->next_loc[g][s] = (ptr)0; tgc->sweep_loc[g][s] = (ptr)0; diff --git a/racket/src/ChezScheme/c/arm32le.c b/racket/src/ChezScheme/c/arm32le.c index 085ef0be5b..5acc1efd1c 100644 --- a/racket/src/ChezScheme/c/arm32le.c +++ b/racket/src/ChezScheme/c/arm32le.c @@ -19,6 +19,10 @@ #include #include +#ifdef TARGET_OS_IPHONE +# include +#endif + /* we don't count on having the right value for correctness, * but the right value will give maximum efficiency */ #define DEFAULT_L1_MAX_CACHE_LINE_SIZE 32 @@ -35,7 +39,11 @@ void S_doflush(uptr start, uptr end) { printf(" doflush(%x, %x)\n", start, end); fflush(stdout); #endif +#ifdef TARGET_OS_IPHONE + sys_icache_invalidate((void *)start, (char *)end-(char *)start); +#else __clear_cache((char *)start, (char *)end); +#endif } void S_machine_init() { diff --git a/racket/src/ChezScheme/c/expeditor.c b/racket/src/ChezScheme/c/expeditor.c index 6dd849ba34..c064696436 100644 --- a/racket/src/ChezScheme/c/expeditor.c +++ b/racket/src/ChezScheme/c/expeditor.c @@ -741,7 +741,7 @@ static ptr s_ee_get_screen_size(void) { static IBOOL tried_resize = 0; /* attempt to work around 10.6 tty driver / xterm bug */ if (ee_rows == 0 && ee_cols == 0 && !tried_resize) { - system("exec /usr/X11/bin/resize >& /dev/null"); + SYSTEM("exec /usr/X11/bin/resize >& /dev/null"); tried_resize = 1; return s_ee_get_screen_size(); } diff --git a/racket/src/ChezScheme/c/externs.h b/racket/src/ChezScheme/c/externs.h index 059ed85c4c..48e1c7ff86 100644 --- a/racket/src/ChezScheme/c/externs.h +++ b/racket/src/ChezScheme/c/externs.h @@ -393,8 +393,8 @@ extern uptr S_maxmembytes PROTO((void)); extern void S_resetmaxmembytes PROTO((void)); extern void S_adjustmembytes PROTO((iptr amt)); extern void S_move_to_chunk_list PROTO((chunkinfo *chunk, chunkinfo **pchunk_list)); -extern void S_thread_start_code_write(void); -extern void S_thread_end_code_write(void); +extern void S_thread_start_code_write PROTO((ptr tc, IGEN maxg, IBOOL current, void *hint)); +extern void S_thread_end_code_write PROTO((ptr tc, IGEN maxg, IBOOL current, void *hint)); /* stats.c */ extern void S_stats_init PROTO((void)); diff --git a/racket/src/ChezScheme/c/fasl.c b/racket/src/ChezScheme/c/fasl.c index 25bc6a3802..5d9230e2ea 100644 --- a/racket/src/ChezScheme/c/fasl.c +++ b/racket/src/ChezScheme/c/fasl.c @@ -508,7 +508,7 @@ static ptr fasl_entry(ptr tc, IFASLCODE situation, unbufFaslFile uf, ptr externa Scompact_heap(); } - S_thread_start_code_write(); + S_thread_start_code_write(tc, S_vfasl_boot_mode ? static_generation : 0, 1, NULL); switch (ty) { case fasl_type_gzip: @@ -557,7 +557,7 @@ static ptr fasl_entry(ptr tc, IFASLCODE situation, unbufFaslFile uf, ptr externa return (ptr)0; } S_flush_instruction_cache(tc); - S_thread_end_code_write(); + S_thread_end_code_write(tc, S_vfasl_boot_mode ? static_generation : 0, 1, NULL); return x; } else { uf_skipbytes(uf, size); @@ -569,7 +569,7 @@ static ptr bv_fasl_entry(ptr tc, ptr bv, int ty, uptr offset, uptr len, unbufFas ptr x; ptr strbuf = S_G.null_string; struct faslFileObj ffo; - S_thread_start_code_write(); + S_thread_start_code_write(tc, S_vfasl_boot_mode ? static_generation : 0, 1, NULL); if (ty == fasl_type_vfasl) { x = S_vfasl(bv, NULL, offset, len); @@ -585,8 +585,8 @@ static ptr bv_fasl_entry(ptr tc, ptr bv, int ty, uptr offset, uptr len, unbufFas } S_flush_instruction_cache(tc); - S_thread_end_code_write(); - + S_thread_end_code_write(tc, S_vfasl_boot_mode ? static_generation : 0, 1, NULL); + return x; } diff --git a/racket/src/ChezScheme/c/gc.c b/racket/src/ChezScheme/c/gc.c index 7739a8e4ce..78ba8c49c6 100644 --- a/racket/src/ChezScheme/c/gc.c +++ b/racket/src/ChezScheme/c/gc.c @@ -870,7 +870,7 @@ ptr GCENTRY(ptr tc, ptr count_roots_ls) { GET_REAL_TIME(astart); - S_thread_start_code_write(); + S_thread_start_code_write(tc, MAX_TG, 0, NULL); /* flush instruction cache: effectively clear_code_mod but safer */ for (ls = S_threads; ls != Snil; ls = Scdr(ls)) { @@ -1679,7 +1679,7 @@ ptr GCENTRY(ptr tc, ptr count_roots_ls) { if (MAX_CG >= S_G.min_free_gen) S_free_chunks(); S_flush_instruction_cache(tc); - S_thread_end_code_write(); + S_thread_end_code_write(tc, MAX_TG, 0, NULL); #ifndef NO_DIRTY_NEWSPACE_POINTERS /* mark dirty those newspace cards to which we've added wrong-way pointers */ @@ -2950,7 +2950,9 @@ static void setup_sweepers(thread_gc *tgc) { static s_thread_rv_t start_sweeper(void *_sweeper) { gc_sweeper *sweeper = _sweeper; - S_thread_start_code_write(); /* never ended */ +#if !defined(WRITE_XOR_EXECUTE_CODE) + S_thread_start_code_write((ptr)0, static_generation, 0, NULL); /* never ended */ +#endif (void)s_thread_mutex_lock(&sweep_mutex); while (1) { diff --git a/racket/src/ChezScheme/c/prim.c b/racket/src/ChezScheme/c/prim.c index c2194edc97..03c210df9d 100644 --- a/racket/src/ChezScheme/c/prim.c +++ b/racket/src/ChezScheme/c/prim.c @@ -228,7 +228,7 @@ static void s_instantiate_code_object() { cookie = S_get_scheme_arg(tc, 2); proc = S_get_scheme_arg(tc, 3); - S_thread_start_code_write(); + S_thread_start_code_write(tc, 0, 0, NULL); new = S_code(tc, CODETYPE(old), CODELEN(old)); @@ -280,15 +280,16 @@ static void s_instantiate_code_object() { } S_flush_instruction_cache(tc); - S_thread_end_code_write(); + S_thread_end_code_write(tc, 0, 0, NULL); AC0(tc) = new; } static void s_link_code_object(co, objs) ptr co, objs; { - ptr t; uptr a, m, n; + ptr t, tc = get_thread_context(); + uptr a, m, n; - S_thread_start_code_write(); + S_thread_start_code_write(tc, 0, 0, NULL); t = CODERELOC(co); m = RELOCSIZE(t); a = 0; @@ -307,7 +308,7 @@ static void s_link_code_object(co, objs) ptr co, objs; { S_set_code_obj("gc", RELOC_TYPE(entry), co, a, Scar(objs), item_off); objs = Scdr(objs); } - S_thread_end_code_write(); + S_thread_end_code_write(tc, 0, 0, NULL); } static INT s_check_heap_enabledp(void) { diff --git a/racket/src/ChezScheme/c/prim5.c b/racket/src/ChezScheme/c/prim5.c index 5d1566aef0..905d3859fc 100644 --- a/racket/src/ChezScheme/c/prim5.c +++ b/racket/src/ChezScheme/c/prim5.c @@ -877,64 +877,70 @@ static char *s_getwd() { static ptr s_set_code_byte(p, n, x) ptr p, n, x; { I8 *a; + ptr tc = get_thread_context(); - S_thread_start_code_write(); a = (I8 *)TO_VOIDP((uptr)p + UNFIX(n)); + S_thread_start_code_write(tc, 0, 0, TO_VOIDP(a)); *a = (I8)UNFIX(x); - S_thread_end_code_write(); + S_thread_end_code_write(tc, 0, 0, TO_VOIDP(a)); return Svoid; } static ptr s_set_code_word(p, n, x) ptr p, n, x; { I16 *a; + ptr tc = get_thread_context(); - S_thread_start_code_write(); a = (I16 *)TO_VOIDP((uptr)p + UNFIX(n)); + S_thread_start_code_write(tc, 0, 0, TO_VOIDP(a)); *a = (I16)UNFIX(x); - S_thread_end_code_write(); + S_thread_end_code_write(tc, 0, 0, TO_VOIDP(a)); return Svoid; } static ptr s_set_code_long(p, n, x) ptr p, n, x; { I32 *a; + ptr tc = get_thread_context(); - S_thread_start_code_write(); a = (I32 *)TO_VOIDP((uptr)p + UNFIX(n)); + S_thread_start_code_write(tc, 0, 0, TO_VOIDP(a)); *a = (I32)(Sfixnump(x) ? UNFIX(x) : Sinteger_value(x)); - S_thread_end_code_write(); + S_thread_end_code_write(tc, 0, 0, TO_VOIDP(a)); return Svoid; } static void s_set_code_long2(p, n, h, l) ptr p, n, h, l; { I32 *a; + ptr tc = get_thread_context(); - S_thread_start_code_write(); a = (I32 *)TO_VOIDP((uptr)p + UNFIX(n)); + S_thread_start_code_write(tc, 0, 0, TO_VOIDP(a)); *a = (I32)((UNFIX(h) << 16) + UNFIX(l)); - S_thread_end_code_write(); + S_thread_end_code_write(tc, 0, 0, TO_VOIDP(a)); } static ptr s_set_code_quad(p, n, x) ptr p, n, x; { I64 *a; + ptr tc = get_thread_context(); - S_thread_start_code_write(); a = (I64 *)TO_VOIDP((uptr)p + UNFIX(n)); + S_thread_start_code_write(tc, 0, 0, TO_VOIDP(a)); *a = Sfixnump(x) ? UNFIX(x) : S_int64_value("\\#set-code-quad!", x); - S_thread_end_code_write(); + S_thread_end_code_write(tc, 0, 0, TO_VOIDP(a)); return Svoid; } static ptr s_set_reloc(p, n, e) ptr p, n, e; { iptr *a; + ptr tc = get_thread_context(); - S_thread_start_code_write(); + S_thread_start_code_write(tc, 0, 0, TO_VOIDP(&CODERELOC(p))); a = (iptr *)(&RELOCIT(CODERELOC(p), UNFIX(n))); *a = Sfixnump(e) ? UNFIX(e) : Sinteger_value(e); - S_thread_end_code_write(); + S_thread_end_code_write(tc, 0, 0, TO_VOIDP(&CODERELOC(p))); return e; } @@ -947,10 +953,11 @@ static ptr s_flush_instruction_cache() { static ptr s_make_code(flags, free, name, arity_mark, n, info, pinfos) iptr flags, free, n; ptr name, arity_mark, info, pinfos; { ptr co; + ptr tc = get_thread_context(); - S_thread_start_code_write(); + S_thread_start_code_write(tc, 0, 0, NULL); - co = S_code(get_thread_context(), type_code | (flags << code_flags_offset), n); + co = S_code(tc, type_code | (flags << code_flags_offset), n); CODEFREE(co) = free; CODENAME(co) = name; CODEARITYMASK(co) = arity_mark; @@ -960,16 +967,18 @@ static ptr s_make_code(flags, free, name, arity_mark, n, info, pinfos) S_G.profile_counters = Scons(S_weak_cons(co, pinfos), S_G.profile_counters); } - S_thread_end_code_write(); + S_thread_end_code_write(tc, 0, 0, NULL); return co; } static ptr s_make_reloc_table(codeobj, n) ptr codeobj, n; { - S_thread_start_code_write(); + ptr tc = get_thread_context(); + + S_thread_start_code_write(tc, 0, 0, TO_VOIDP(&CODERELOC(codeobj))); CODERELOC(codeobj) = S_relocation_table(UNFIX(n)); RELOCCODE(CODERELOC(codeobj)) = codeobj; - S_thread_end_code_write(); + S_thread_end_code_write(tc, 0, 0, TO_VOIDP(&CODERELOC(codeobj))); return Svoid; } diff --git a/racket/src/ChezScheme/c/scheme.c b/racket/src/ChezScheme/c/scheme.c index 196916cdfc..b231ff0244 100644 --- a/racket/src/ChezScheme/c/scheme.c +++ b/racket/src/ChezScheme/c/scheme.c @@ -109,7 +109,7 @@ static void main_init() { VIRTREG(tc, i) = FIX(0); } - S_thread_start_code_write(); + S_thread_start_code_write(tc, 0, 0, NULL); p = S_code(tc, type_code, size_rp_header); CODERELOC(p) = S_relocation_table(0); CODENAME(p) = Sfalse; @@ -123,7 +123,7 @@ static void main_init() { (uptr)TO_PTR(&RPHEADERTOPLINK(TO_PTR(&CODEIT(p, 0)))) - (uptr)p; S_protect(&S_G.dummy_code_object); S_G.dummy_code_object = p; - S_thread_end_code_write(); + S_thread_end_code_write(tc, 0, 0, NULL); S_protect(&S_G.error_invoke_code_object); S_G.error_invoke_code_object = Snil; diff --git a/racket/src/ChezScheme/c/schsig.c b/racket/src/ChezScheme/c/schsig.c index 5715f3ada0..7baabb51f2 100644 --- a/racket/src/ChezScheme/c/schsig.c +++ b/racket/src/ChezScheme/c/schsig.c @@ -392,8 +392,8 @@ static void do_error(type, who, s, args) iptr type; const char *who, *s; ptr arg #endif /* PTHREADS */ /* in case error is during fasl read: */ - S_thread_end_code_write(); - + S_thread_end_code_write(tc, static_generation, 0, NULL); + TRAP(tc) = (ptr)1; AC0(tc) = (ptr)1; CP(tc) = S_symbol_value(S_G.error_id); @@ -775,6 +775,7 @@ static void init_signal_handlers() { void S_schsig_init() { if (S_boot_time) { ptr p; + ptr tc = get_thread_context(); S_protect(&S_G.nuate_id); S_G.nuate_id = S_intern((const unsigned char *)"$nuate"); @@ -786,15 +787,15 @@ void S_schsig_init() { S_protect(&S_G.collect_request_pending_id); S_G.collect_request_pending_id = S_intern((const unsigned char *)"$collect-request-pending"); - S_thread_start_code_write(); - p = S_code(get_thread_context(), type_code | (code_flag_continuation << code_flags_offset), 0); + S_thread_start_code_write(tc, 0, 0, NULL); + p = S_code(tc, type_code | (code_flag_continuation << code_flags_offset), 0); CODERELOC(p) = S_relocation_table(0); CODENAME(p) = Sfalse; CODEARITYMASK(p) = FIX(0); CODEFREE(p) = 0; CODEINFO(p) = Sfalse; CODEPINFOS(p) = Snil; - S_thread_end_code_write(); + S_thread_end_code_write(tc, 0, 0, NULL); S_set_symbol_value(S_G.null_continuation_id, S_mkcontinuation(space_new, diff --git a/racket/src/ChezScheme/c/segment.c b/racket/src/ChezScheme/c/segment.c index fbec515adc..1a13e03f53 100644 --- a/racket/src/ChezScheme/c/segment.c +++ b/racket/src/ChezScheme/c/segment.c @@ -45,6 +45,10 @@ static void add_to_chunk_list PROTO((chunkinfo *chunk, chunkinfo **pchunk_list)) static seginfo *sort_seginfo PROTO((seginfo *si, uptr n)); static seginfo *merge_seginfo PROTO((seginfo *si1, seginfo *si2)); +#if defined(WRITE_XOR_EXECUTE_CODE) +static void enable_code_write PROTO((ptr tc, IGEN maxg, IBOOL on, IBOOL current, ptr hint)); +#endif + void S_segment_init() { IGEN g; ISPC s; int i; @@ -88,14 +92,14 @@ void *S_getmem(iptr bytes, IBOOL zerofill, UNUSED IBOOL for_code) { if ((addr = malloc(bytes)) == (void *)0) out_of_memory(); - debug(printf("getmem(%p) -> %p\n", bytes, addr)) + debug(printf("getmem(%p) -> %p\n", TO_VOIDP(bytes), addr)) if ((membytes += bytes) > maxmembytes) maxmembytes = membytes; if (zerofill) memset(addr, 0, bytes); return addr; } void S_freemem(void *addr, iptr bytes) { - debug(printf("freemem(%p, %p)\n", addr, bytes)) + debug(printf("freemem(%p, %p)\n", addr, TO_VOIDP(bytes))) free(addr); membytes -= bytes; } @@ -108,7 +112,7 @@ void *S_getmem(iptr bytes, IBOOL zerofill, IBOOL for_code) { if ((uptr)bytes < S_pagesize) { if ((addr = malloc(bytes)) == (void *)0) out_of_memory(); - debug(printf("getmem malloc(%p) -> %p\n", bytes, addr)) + debug(printf("getmem malloc(%p) -> %p\n", TO_VOIDP(bytes), addr)) if ((membytes += bytes) > maxmembytes) maxmembytes = membytes; if (zerofill) memset(addr, 0, bytes); } else { @@ -116,7 +120,7 @@ void *S_getmem(iptr bytes, IBOOL zerofill, IBOOL for_code) { int perm = (for_code ? PAGE_EXECUTE_READWRITE : PAGE_READWRITE); if ((addr = VirtualAlloc((void *)0, (SIZE_T)p_bytes, MEM_COMMIT, perm)) == (void *)0) out_of_memory(); if ((membytes += p_bytes) > maxmembytes) maxmembytes = membytes; - debug(printf("getmem VirtualAlloc(%p => %p) -> %p\n", bytes, p_bytes, addr)) + debug(printf("getmem VirtualAlloc(%p => %p) -> %p\n", TO_VOIDP(bytes), TO_VOIDP(p_bytes), addr)) } return addr; @@ -146,7 +150,7 @@ void *S_getmem(iptr bytes, IBOOL zerofill, IBOOL for_code) { if ((uptr)bytes < S_pagesize) { if ((addr = malloc(bytes)) == (void *)0) out_of_memory(); - debug(printf("getmem malloc(%p) -> %p\n", bytes, addr)) + debug(printf("getmem malloc(%p) -> %p\n", TO_VOIDP(bytes), addr)) if ((membytes += bytes) > maxmembytes) maxmembytes = membytes; if (zerofill) memset(addr, 0, bytes); } else { @@ -160,13 +164,13 @@ void *S_getmem(iptr bytes, IBOOL zerofill, IBOOL for_code) { #endif if ((addr = mmap(NULL, p_bytes, perm, flags, -1, 0)) == (void *)-1) { out_of_memory(); - debug(printf("getmem mmap(%p) -> %p\n", bytes, addr)) + debug(printf("getmem mmap(%p) -> %p\n", TO_VOIDP(bytes), addr)) } #ifdef MAP_32BIT } #endif if ((membytes += p_bytes) > maxmembytes) maxmembytes = membytes; - debug(printf("getmem mmap(%p => %p) -> %p\n", bytes, p_bytes, addr)) + debug(printf("getmem mmap(%p => %p) -> %p\n", TO_VOIDP(bytes), TO_VOIDP(p_bytes), addr)) } return addr; @@ -174,12 +178,12 @@ void *S_getmem(iptr bytes, IBOOL zerofill, IBOOL for_code) { void S_freemem(void *addr, iptr bytes) { if ((uptr)bytes < S_pagesize) { - debug(printf("freemem free(%p, %p)\n", addr, bytes)) + debug(printf("freemem free(%p, %p)\n", addr, TO_VOIDP(bytes))) free(addr); membytes -= bytes; } else { uptr n = S_pagesize - 1; iptr p_bytes = (iptr)(((uptr)bytes + n) & ~n); - debug(printf("freemem munmap(%p, %p => %p)\n", addr, bytes, p_bytes)) + debug(printf("freemem munmap(%p, %p => %p)\n", addr, TO_VOIDP(bytes), TO_VOIDP(p_bytes))) munmap(addr, p_bytes); membytes -= p_bytes; } @@ -261,6 +265,9 @@ static void initialize_seginfo(seginfo *si, NO_THREADS_UNUSED thread_gc *creator si->counting_mask = NULL; si->measured_mask = NULL; si->sweep_next = NULL; +#if defined(WRITE_XOR_EXECUTE_CODE) + si->sweep_bytes = 0; +#endif } /* allocation mutex must be held */ @@ -273,7 +280,7 @@ iptr S_find_segments(creator, s, g, n) thread_gc *creator; ISPC s; IGEN g; iptr if (g != static_generation) S_G.number_of_nonstatic_segments += n; - debug(printf("attempting to find %d segments for space %d, generation %d\n", n, s, g)) + debug(printf("attempting to find %ld segments for space %d, generation %d\n", n, s, g)) chunks = (for_code ? S_code_chunks : S_chunks); @@ -568,18 +575,146 @@ static void contract_segment_table(uptr base, uptr end) { thread-specific, the bracketing functions disable execution of the code's memory while enabling writing. - Note that these function will not work for a W^X implementation - where each page's disposition is process-wide. Indeed, a - process-wide W^X disposition seems incompatible with the Chez + A process-wide W^X disposition seems incompatible with the Chez Scheme rule that a foreign thread is allowed to invoke a callback (as long as the callback is immobile/locked) at any time --- even, say, while Scheme is collecting garbage and needs to write to - executable pages. */ + executable pages. However, on platforms where such a disposition + is enforced (eg. iOS), we provide a best-effort implementation that + flips pages between W and X for the minimal set of segments + possible (depending on the context) in an effort to minimize the + chances of a page being flipped while a thread is executing code + off of it. +*/ -void S_thread_start_code_write(void) { +void S_thread_start_code_write(WX_UNUSED ptr tc, WX_UNUSED IGEN maxg, WX_UNUSED IBOOL current, WX_UNUSED void *hint) { +#if defined(WRITE_XOR_EXECUTE_CODE) + enable_code_write(tc, maxg, 1, current, hint); +#else S_ENABLE_CODE_WRITE(1); +#endif } -void S_thread_end_code_write(void) { +void S_thread_end_code_write(WX_UNUSED ptr tc, WX_UNUSED IGEN maxg, WX_UNUSED IBOOL current, WX_UNUSED void *hint) { +#if defined(WRITE_XOR_EXECUTE_CODE) + enable_code_write(tc, maxg, 0, current, hint); +#else S_ENABLE_CODE_WRITE(0); +#endif } + +#if defined(WRITE_XOR_EXECUTE_CODE) +# if defined(PTHREADS) +static IBOOL is_unused_seg(chunkinfo *chunk, seginfo *si) { + uptr number; + if (si->creator == NULL) { + /* If the seginfo doesn't have a creator, then it's unused so we + can skip the search. */ + return 1; + } + number = si->number; + si = chunk->unused_segs; + while (si != NULL) { + if (si->number == number) { + return 1; + } + si = si->next; + } + return 0; +} +# endif + +static void enable_code_write(ptr tc, IGEN maxg, IBOOL on, IBOOL current, void *hint) { + thread_gc *tgc; + chunkinfo *chunk; + seginfo si, *sip; + iptr i, j, bytes; + void *addr; + INT flags = (on ? PROT_WRITE : PROT_EXEC) | PROT_READ; + + /* Flip only the segment hinted at by the caller. */ + if (maxg == 0 && hint != NULL) { + addr = TO_VOIDP((char*)hint - ((uptr)hint % bytes_per_segment)); + if (mprotect(addr, bytes_per_segment, flags) != 0) { + S_error_abort("bad hint to enable_code_write"); + } + return; + } + + /* Flip only the current allocation segments. */ + tgc = THREAD_GC(tc); + if (maxg == 0 && current) { + addr = tgc->base_loc[0][space_code]; + if (addr == NULL) { + return; + } + bytes = (char*)tgc->next_loc[0][space_code] - (char*)tgc->base_loc[0][space_code] + tgc->bytes_left[0][space_code] + ptr_bytes; + if (mprotect(addr, bytes, flags) != 0) { + S_error_abort("failed to protect current allocation segments"); + } + /* If disabling writes, turn on exec for recently-allocated + segments in addition to the current segments. Clears the + current sweep_next chain so must not be used durring + collection. */ + if (!on) { + while ((sip = tgc->sweep_next[0][space_code]) != NULL) { + tgc->sweep_next[0][space_code] = sip->sweep_next; + addr = sip->sweep_start; + bytes = sip->sweep_bytes; + if (mprotect(addr, bytes, flags) != 0) { + S_error_abort("failed to protect recent allocation segments"); + } + } + } + return; + } + + for (i = 0; i <= PARTIAL_CHUNK_POOLS; i++) { + chunk = S_code_chunks[i]; + while (chunk != NULL) { + addr = chunk->addr; +# if defined(PTHREADS) + bytes = 0; + if (chunk->nused_segs == 0) { + /* None of the segments in the chunk are used so flip the bits + for all of them in one go. */ + bytes = chunk->bytes; + } else { + /* Flip bits for whole runs of segs that are either unused or + whose generation is within the range [0, maxg]. */ + for (j = 0; j < chunk->segs; j++) { + si = chunk->sis[j]; + /* When maxg is 0, limit the search to unused segments and + segments that belong to the current thread. */ + if ((maxg == 0 && si.generation == 0 && si.creator == tgc) || + (maxg != 0 && si.generation <= maxg) || + (is_unused_seg(chunk, &si))) { + bytes += bytes_per_segment; + } else { + if (bytes > 0) { + debug(printf("mprotect flags=%d from=%p to=%p maxg=%d (interrupted)\n", flags, addr, TO_VOIDP((char *)addr + bytes), maxg)) + if (mprotect(addr, bytes, flags) != 0) { + S_error_abort("mprotect failed"); + } + } + + addr = TO_VOIDP((char *)chunk->addr + (j + 1) * bytes_per_segment); + bytes = 0; + } + } + } +# else + bytes = chunk->bytes; +# endif + if (bytes > 0) { + debug(printf("mprotect flags=%d from=%p to=%p maxg=%d\n", flags, addr, TO_VOIDP((char *)addr + bytes), maxg)) + if (mprotect(addr, bytes, flags) != 0) { + S_error_abort("mprotect failed"); + } + } + + chunk = chunk->next; + } + } +} +#endif diff --git a/racket/src/ChezScheme/c/thread.c b/racket/src/ChezScheme/c/thread.c index eafad66dfd..ec31e3c9a0 100644 --- a/racket/src/ChezScheme/c/thread.c +++ b/racket/src/ChezScheme/c/thread.c @@ -256,7 +256,7 @@ static IBOOL destroy_thread(tc) ptr tc; { S_scan_dirty((ptr *)EAP(tc), (ptr *)REAL_EAP(tc)); /* close off thread-local allocation */ - S_thread_start_code_write(); + S_thread_start_code_write(tc, static_generation, 0, NULL); { ISPC s; IGEN g; thread_gc *tgc = THREAD_GC(tc); @@ -265,7 +265,7 @@ static IBOOL destroy_thread(tc) ptr tc; { if (tgc->next_loc[g][s]) S_close_off_thread_local_segment(tc, s, g); } - S_thread_end_code_write(); + S_thread_end_code_write(tc, static_generation, 0, NULL); alloc_mutex_release(); diff --git a/racket/src/ChezScheme/c/types.h b/racket/src/ChezScheme/c/types.h index fdb19f88d3..e33f91af57 100644 --- a/racket/src/ChezScheme/c/types.h +++ b/racket/src/ChezScheme/c/types.h @@ -158,6 +158,9 @@ typedef struct _seginfo { struct _seginfo *next; /* pointer to the next seginfo (used in occupied_segments and unused_segs) */ struct _seginfo *sweep_next; /* next in list of segments allocated during GC => need to sweep */ ptr sweep_start; /* address within segment to start sweep */ +#if defined(WRITE_XOR_EXECUTE_CODE) + iptr sweep_bytes; /* total number of bytes starting at sweep_start */ +#endif struct _seginfo **dirty_prev; /* pointer to the next pointer on the previous seginfo in the DirtySegments list */ struct _seginfo *dirty_next; /* pointer to the next seginfo on the DirtySegments list */ ptr trigger_ephemerons; /* ephemerons to re-check if object in segment is copied out */ @@ -186,7 +189,7 @@ typedef struct _chunkinfo { iptr base; /* first segment */ iptr bytes; /* size in bytes */ iptr segs; /* size in segments */ - iptr nused_segs; /* number of segments currently in used use */ + iptr nused_segs; /* number of segments currently in use */ struct _chunkinfo **prev; /* pointer to previous chunk's next */ struct _chunkinfo *next; /* next chunk */ struct _seginfo *unused_segs; /* list of unused segments */ diff --git a/racket/src/ChezScheme/c/version.h b/racket/src/ChezScheme/c/version.h index 4783f468a4..c50c942f66 100644 --- a/racket/src/ChezScheme/c/version.h +++ b/racket/src/ChezScheme/c/version.h @@ -324,9 +324,18 @@ typedef int tputsputcchar; #if !defined(__POWERPC__) # define LITTLE_ENDIAN_IEEE_DOUBLE #endif +/* for both iPhone and iPhoneSimulator */ +#if defined(TARGET_OS_IPHONE) +# define SYSTEM(s) ((void)s, -1) +# define S_PROT_CODE (PROT_WRITE | PROT_READ) +# define WRITE_XOR_EXECUTE_CODE +# define WX_UNUSED +#endif #if defined(__arm64__) -# define S_MAP_CODE MAP_JIT -# define S_ENABLE_CODE_WRITE(on) pthread_jit_write_protect_np(!(on)) +# if !defined(TARGET_OS_IPHONE) +# define S_MAP_CODE MAP_JIT +# define S_ENABLE_CODE_WRITE(on) pthread_jit_write_protect_np(!(on)) +# endif # define CANNOT_READ_DIRECTLY_INTO_CODE # include #elif defined(__x86_64__) @@ -506,6 +515,12 @@ typedef char tputsputcchar; # define S_ENABLE_CODE_WRITE(on) do { } while (0) #endif +/* Signals that an argument is unused when W&X memory pages are + supported. Relevant in relation to WRITE_XOR_EXECUTE_CODE. */ +#ifndef WX_UNUSED +# define WX_UNUSED UNUSED +#endif + #ifdef PTHREADS # define NO_THREADS_UNUSED /* empty */ #else diff --git a/racket/src/Makefile.in b/racket/src/Makefile.in index df77bd2231..608e17ba2b 100644 --- a/racket/src/Makefile.in +++ b/racket/src/Makefile.in @@ -265,6 +265,13 @@ install-pdf: # Clean ---------------------------------------- clean: + if [ -f cs/c/Makefile ]; then $(MAKE) clean-cs; fi + if [ -f bc/Makefile ]; then $(MAKE) clean-bc; fi + +clean-cs: + cd cs/c && $(MAKE) clean + +clean-bc: cd bc && $(MAKE) clean rm -rf compiled rm -f TAGS diff --git a/racket/src/README.txt b/racket/src/README.txt index facf71d110..d40607d961 100644 --- a/racket/src/README.txt +++ b/racket/src/README.txt @@ -397,11 +397,8 @@ the [comp] of your choice and the [platform] used to compile. Cross-compiling for iOS ======================================================================== -[Currently, cross-compilation works only for the Racket BC - implementation.] - To compile the Racket runtime system as a Framework for iOS, use (all -on one line) +on one line) for BC configure --host=[arch]-apple-darwin --enable-ios="[sdk]" @@ -420,6 +417,23 @@ becomes the path (all on one line) /Applications/Xcode.app/Contents/Developer/Platforms/ iPhoneOS.platform/Developer/SDKs/iPhoneOS.sdk +To cross-compile for CS, you must supply the Chez Scheme compiler that +Racket CS was built with. Assuming you have built Racket CS for your +machine at "/path/to/racket" using the default `make` target, you can +configure the cross build using that Racket binary and a path to the +Chez Scheme build folder as follows (all on one line) + + configure --host=[arch]-apple-darwin + --enable-ios="[sdk]" + --enable-racket=/path/to/racket/bin/racket + --enable-scheme=/path/to/racket/src/build/cs/c + +Currently, iOS enforces strict W^X protection on memory pages. See the +note about "writes to `space_code` memory" in "ChezScheme/c/segment.c" +for the implications this has on Racket CS. In principle, if you avoid +passing newly-allocated code between threads and avoid `#:blocking?` +foreign callbacks, you should not run into any issues. + ======================================================================== Test Suite diff --git a/racket/src/ac/sdk_ios.m4 b/racket/src/ac/sdk_ios.m4 new file mode 100644 index 0000000000..f2e3b7f317 --- /dev/null +++ b/racket/src/ac/sdk_ios.m4 @@ -0,0 +1,22 @@ +if test "${enable_ios}" != "" ; then + case "$host_cpu" in + aarch64) + IOS_ARCH=arm64 + ;; + *) + IOS_ARCH=$host_cpu + ;; + esac + case "${enable_ios}" in + iPhoneOS|iPhoneSimulator) + ios_sdk=/Applications/Xcode.app/Contents/Developer/Platforms/${enable_ios}.platform/Developer/SDKs/${enable_ios}.sdk + echo "=== Using inferred iOS SDK path ${ios_sdk}" + ;; + *) + ios_sdk="${enable_ios}" + ;; + esac + IOS_PHONE_VERS="6.0" + PREFLAGS="$PREFLAGS -DTARGET_OS_IPHONE=1 -arch ${IOS_ARCH} -isysroot ${ios_sdk} -miphoneos-version-min=${IOS_PHONE_VERS}" + LDFLAGS="$LDFLAGS -arch ${IOS_ARCH} -isysroot ${ios_sdk} -miphoneos-version-min=${IOS_PHONE_VERS} -liconv" +fi diff --git a/racket/src/ac/sdk_show.m4 b/racket/src/ac/sdk_show.m4 index 149f44578c..22575dcccc 100644 --- a/racket/src/ac/sdk_show.m4 +++ b/racket/src/ac/sdk_show.m4 @@ -32,7 +32,7 @@ if test "${enable_sdk6}" != "" ; then echo "=== Using Mac OS 10.6 SDK directory ${enable_sdk6}" fi if test "${enable_ios}" != "" ; then - echo "=== Using ios SDK directory ${enable_ios}" + echo "=== Using iOS SDK directory ${enable_ios}" fi if test "${enable_sysroot}" != "" ; then diff --git a/racket/src/bc/configure b/racket/src/bc/configure index 49fd45624c..f9d8567454 100755 --- a/racket/src/bc/configure +++ b/racket/src/bc/configure @@ -3388,7 +3388,7 @@ if test "${enable_sdk6}" != "" ; then echo "=== Using Mac OS 10.6 SDK directory ${enable_sdk6}" fi if test "${enable_ios}" != "" ; then - echo "=== Using ios SDK directory ${enable_ios}" + echo "=== Using iOS SDK directory ${enable_ios}" fi if test "${enable_sysroot}" != "" ; then @@ -3600,17 +3600,19 @@ if test "${enable_ios}" != "" ; then case "${enable_ios}" in iPhoneOS|iPhoneSimulator) ios_sdk=/Applications/Xcode.app/Contents/Developer/Platforms/${enable_ios}.platform/Developer/SDKs/${enable_ios}.sdk + echo "=== Using inferred iOS SDK path ${ios_sdk}" ;; *) ios_sdk="${enable_ios}" ;; esac IOS_PHONE_VERS="6.0" - PREFLAGS="$PREFLAGS -DTARGET_OS_IPHONE=1" - CPPFLAGS="$CPPFLAGS -DTARGET_OS_IPHONE=1" - PREFLAGS="$PREFLAGS -arch ${IOS_ARCH} -isysroot ${ios_sdk} -miphoneos-version-min=${IOS_PHONE_VERS}" - CPPFLAGS="$CPPFLAGS -arch ${IOS_ARCH} -isysroot ${ios_sdk} -miphoneos-version-min=${IOS_PHONE_VERS}" + PREFLAGS="$PREFLAGS -DTARGET_OS_IPHONE=1 -arch ${IOS_ARCH} -isysroot ${ios_sdk} -miphoneos-version-min=${IOS_PHONE_VERS}" LDFLAGS="$LDFLAGS -arch ${IOS_ARCH} -isysroot ${ios_sdk} -miphoneos-version-min=${IOS_PHONE_VERS} -liconv" +fi + +if test "${enable_ios}" != "" ; then + CPPFLAGS="$CPPFLAGS -DTARGET_OS_IPHONE=1 -arch ${IOS_ARCH} -isysroot ${ios_sdk} -miphoneos-version-min=${IOS_PHONE_VERS}" SUB_CONFIGURE_EXTRAS="${SUB_CONFIGURE_EXTRAS} CFLAGS="'"'"${CFLAGS}"'"' SUB_CONFIGURE_EXTRAS="${SUB_CONFIGURE_EXTRAS} CPPFLAGS="'"'"${PREFLAGS}"'"' SUB_CONFIGURE_EXTRAS="${SUB_CONFIGURE_EXTRAS} LDFLAGS="'"'"${LDFLAGS}"'"' diff --git a/racket/src/bc/configure.ac b/racket/src/bc/configure.ac index f8a6acbb0b..0879f3183d 100644 --- a/racket/src/bc/configure.ac +++ b/racket/src/bc/configure.ac @@ -379,29 +379,9 @@ if test "${enable_sysroot}" != "" ; then SUB_CONFIGURE_EXTRAS="${SUB_CONFIGURE_EXTRAS} LDFLAGS="'"'"${LDFLAGS}"'"' fi +m4_include(../ac/sdk_ios.m4) if test "${enable_ios}" != "" ; then - case "$host_cpu" in - aarch64) - IOS_ARCH=arm64 - ;; - *) - IOS_ARCH=$host_cpu - ;; - esac - case "${enable_ios}" in - iPhoneOS|iPhoneSimulator) - ios_sdk=/Applications/Xcode.app/Contents/Developer/Platforms/${enable_ios}.platform/Developer/SDKs/${enable_ios}.sdk - ;; - *) - ios_sdk="${enable_ios}" - ;; - esac - IOS_PHONE_VERS="6.0" - PREFLAGS="$PREFLAGS -DTARGET_OS_IPHONE=1" - CPPFLAGS="$CPPFLAGS -DTARGET_OS_IPHONE=1" - PREFLAGS="$PREFLAGS -arch ${IOS_ARCH} -isysroot ${ios_sdk} -miphoneos-version-min=${IOS_PHONE_VERS}" - CPPFLAGS="$CPPFLAGS -arch ${IOS_ARCH} -isysroot ${ios_sdk} -miphoneos-version-min=${IOS_PHONE_VERS}" - LDFLAGS="$LDFLAGS -arch ${IOS_ARCH} -isysroot ${ios_sdk} -miphoneos-version-min=${IOS_PHONE_VERS} -liconv" + CPPFLAGS="$CPPFLAGS -DTARGET_OS_IPHONE=1 -arch ${IOS_ARCH} -isysroot ${ios_sdk} -miphoneos-version-min=${IOS_PHONE_VERS}" SUB_CONFIGURE_EXTRAS="${SUB_CONFIGURE_EXTRAS} CFLAGS="'"'"${CFLAGS}"'"' SUB_CONFIGURE_EXTRAS="${SUB_CONFIGURE_EXTRAS} CPPFLAGS="'"'"${PREFLAGS}"'"' SUB_CONFIGURE_EXTRAS="${SUB_CONFIGURE_EXTRAS} LDFLAGS="'"'"${LDFLAGS}"'"' diff --git a/racket/src/cs/c/Makefile.in b/racket/src/cs/c/Makefile.in index 954a44b467..8707b31ab6 100644 --- a/racket/src/cs/c/Makefile.in +++ b/racket/src/cs/c/Makefile.in @@ -87,8 +87,12 @@ cs: $(MAKE) starter $(MAKE) repack-@INSTALL_LIBS_ENABLE@-libs +clean: + cd $(SCHEME_WORKAREA); $(MAKE) clean + cd rktio; $(MAKE) clean + SETUP_BOOT_MODE = @SETUP_BOOT_MODE@ -BOOT_COMPILED_SUBDIR = +BOOT_COMPILED_SUBDIR = SETUP_COMMON_BOOT = -l- setup $(SETUP_BOOT_MODE) $(srcdir)/../../setup-go.rkt $(builddir)/compiled$(BOOT_COMPILED_SUBDIR) ABS_SCHEME_WORKAREA = "`$(SCHEME) --script $(srcdir)/../absify.ss --no-trailing-sep $(SCHEME_WORKAREA)`" @@ -258,8 +262,8 @@ $(GRACKET_BIN): grmain.o $(RKTFW) $(GRAPPSKEL) $(CC) $(CFLAGS) -o $(GRACKET_BIN)_raw grmain.o $(MACLIBRKT_LINK_@MACLIBRKT_LINK_MODE@) $(MAKE) mac-embed-boot-@MACLIBRKT_LINK_MODE@ EMBED_SRC=$(GRACKET_BIN)_raw EMBED_DEST=$(GRACKET_BIN) /usr/bin/install_name_tool -change "Racket.framework/Versions/$(FWVERSION)_CS/Racket" "@executable_path/../../../Racket.framework/Versions/$(FWVERSION)_CS/Racket" $(GRACKET_BIN) - $(RESTORE_SIGNATURE) $(GRACKET_BIN) rm $(GRACKET_BIN)_raw + $(RESTORE_SIGNATURE) $(GRACKET_BIN) $(GRAPPSKEL): $(srcdir)/../../mac/osx_appl.rkt $(srcdir)/../../version/racket_version.h $(srcdir)/../../mac/icon/GRacket.icns $(BOOTSTRAP_RACKET) $(srcdir)/../../mac/osx_appl.rkt $(srcdir)/../.. "CS" @@ -384,6 +388,10 @@ plain-install-upcased: install-cross: $(MAKE) compile-xpatch.$(TARGET_MACH) $(MAKE) library-xpatch.$(TARGET_MACH) + rm -f "$(DESTDIR)$(libpltdir)/compile-xpatch.$(TARGET_MACH)" + rm -f "$(DESTDIR)$(libpltdir)/library-xpatch.$(TARGET_MACH)" + $(ICP) compile-xpatch.$(TARGET_MACH) "$(DESTDIR)$(libpltdir)/compile-xpatch.$(TARGET_MACH)" + $(ICP) library-xpatch.$(TARGET_MACH) "$(DESTDIR)$(libpltdir)/library-xpatch.$(TARGET_MACH)" SCHEME_XPATCH = $(SCHEME_WORKAREA)/$(TARGET_MACH)/s/xpatch @@ -464,8 +472,14 @@ install@NOT_MINGW@: $(MAKE) setup-install $(PROPAGATE_VARIABLES) setup-install: + $(MAKE) do-setup-install@T_CROSS_MODE@ + +do-setup-install: @RUN_RACKET@ $(SELF_ROOT_CONFIG) $(SETUP_ARGS) +do-setup-install-cross: + @RUN_RACKET@ $(SELF_ROOT_CONFIG) -C -M -R 'compiled_host:$(TARGET_MACH)' --cross-compiler $(TARGET_MACH) "$(DESTDIR)$(libpltdir)" $(SETUP_ARGS) + no-setup-install: echo done diff --git a/racket/src/cs/c/configure b/racket/src/cs/c/configure index 3bcba637a4..f69b03451b 100755 --- a/racket/src/cs/c/configure +++ b/racket/src/cs/c/configure @@ -2922,7 +2922,7 @@ if test "${enable_sdk6}" != "" ; then echo "=== Using Mac OS 10.6 SDK directory ${enable_sdk6}" fi if test "${enable_ios}" != "" ; then - echo "=== Using ios SDK directory ${enable_ios}" + echo "=== Using iOS SDK directory ${enable_ios}" fi if test "${enable_sysroot}" != "" ; then @@ -3215,6 +3215,30 @@ cs_auto_flags=--disable-auto-flags ###### Autoconfigure ####### +if test "${enable_ios}" != "" ; then + case "$host_cpu" in + aarch64) + IOS_ARCH=arm64 + ;; + *) + IOS_ARCH=$host_cpu + ;; + esac + case "${enable_ios}" in + iPhoneOS|iPhoneSimulator) + ios_sdk=/Applications/Xcode.app/Contents/Developer/Platforms/${enable_ios}.platform/Developer/SDKs/${enable_ios}.sdk + echo "=== Using inferred iOS SDK path ${ios_sdk}" + ;; + *) + ios_sdk="${enable_ios}" + ;; + esac + IOS_PHONE_VERS="6.0" + PREFLAGS="$PREFLAGS -DTARGET_OS_IPHONE=1 -arch ${IOS_ARCH} -isysroot ${ios_sdk} -miphoneos-version-min=${IOS_PHONE_VERS}" + LDFLAGS="$LDFLAGS -arch ${IOS_ARCH} -isysroot ${ios_sdk} -miphoneos-version-min=${IOS_PHONE_VERS} -liconv" +fi + + ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' @@ -4254,6 +4278,7 @@ if test "$ARFLAGS" = '' ; then ARFLAGS=rc fi + WINDRES=windres ############## platform tests ################ @@ -4456,8 +4481,10 @@ case "$host_os" in # -pthread is not needed and triggers a warning use_flag_pthread=no - # ncurses.h is always available - disable_curses_arg="" + # ncurses.h is always available, except on iOS + if test "${enable_ios}" == "" ; then + disable_curses_arg="" + fi ;; nto-qnx*) MACH_OS=qnx diff --git a/racket/src/cs/c/configure.ac b/racket/src/cs/c/configure.ac index 872c124ed3..c5305c425e 100644 --- a/racket/src/cs/c/configure.ac +++ b/racket/src/cs/c/configure.ac @@ -167,6 +167,8 @@ cs_auto_flags=--disable-auto-flags ###### Autoconfigure ####### +m4_include(../ac/sdk_ios.m4) + AC_PROG_CC m4_include(../ac/is_gcc.m4) @@ -192,6 +194,7 @@ if test "$ARFLAGS" = '' ; then ARFLAGS=rc fi + WINDRES=windres ############## platform tests ################ @@ -317,8 +320,10 @@ case "$host_os" in # -pthread is not needed and triggers a warning use_flag_pthread=no - # ncurses.h is always available - disable_curses_arg="" + # ncurses.h is always available, except on iOS + if test "${enable_ios}" == "" ; then + disable_curses_arg="" + fi ;; nto-qnx*) MACH_OS=qnx