suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

cs: add support for cross-compiling to iOS

Browse Source 
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?`).
This commit is contained in:
Bogdan Popa 2021-01-17 17:16:02 +02:00 committed by GitHub
parent b09e10d066
commit c1159fb02e
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
31 changed files with 610 additions and 240 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

72
pkgs/racket-doc/scribblings/inside/appendix.scrbl
View File

@ -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);

8
racket/collects/compiler/cross.rkt Normal file
View File

@ -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?)

273
racket/collects/compiler/embed.rkt
View File

@ -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

8
racket/collects/compiler/private/cm-minimal.rkt
View File

@ -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

12
racket/collects/setup/private/pkg-deps.rkt
View File

@ -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

5
racket/collects/setup/setup-core.rkt
View File

@ -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?)

2
racket/src/ChezScheme/IMPLEMENTATION.md
View File

@ -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

6
racket/src/ChezScheme/c/Mf-arm64osx
View File

@ -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)

19
racket/src/ChezScheme/c/alloc.c
View File

@ -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;

8
racket/src/ChezScheme/c/arm32le.c
View File

@ -19,6 +19,10 @@
#include <sys/types.h>
#include <sys/mman.h>
#ifdef TARGET_OS_IPHONE
# include <libkern/OSCacheControl.h>
#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() {

2
racket/src/ChezScheme/c/expeditor.c
View File

@ -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();
}

4
racket/src/ChezScheme/c/externs.h
View File

@ -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));

10
racket/src/ChezScheme/c/fasl.c
View File

@ -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;
}

8
racket/src/ChezScheme/c/gc.c
View File

@ -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) {

11
racket/src/ChezScheme/c/prim.c
View File

@ -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) {

43
racket/src/ChezScheme/c/prim5.c
View File

@ -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;
}

4
racket/src/ChezScheme/c/scheme.c
View File

@ -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;

11
racket/src/ChezScheme/c/schsig.c
View File

@ -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,

167
racket/src/ChezScheme/c/segment.c
View File

@ -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

4
racket/src/ChezScheme/c/thread.c
View File

@ -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();

5
racket/src/ChezScheme/c/types.h
View File

@ -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 */

19
racket/src/ChezScheme/c/version.h
View File

@ -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 <pthread.h>
#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

7
racket/src/Makefile.in
View File

@ -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

22
racket/src/README.txt
View File

@ -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

22
racket/src/ac/sdk_ios.m4 Normal file
View File

@ -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

2
racket/src/ac/sdk_show.m4
View File

@ -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

12
racket/src/bc/configure vendored
View File

@ -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}"'"'

24
racket/src/bc/configure.ac
View File

@ -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}"'"'

18
racket/src/cs/c/Makefile.in
View File

@ -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

33
racket/src/cs/c/configure vendored
View File

@ -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

9
racket/src/cs/c/configure.ac
View File

@ -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