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

raco exe and dist: repairs for cross-bundling runtime files

Browse Source
This commit is contained in:
Matthew Flatt 2021-05-13 09:13:08 -06:00
parent 40cd1ea083
commit 97e9a17dac
3 changed files with 38 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
racket/collects/compiler/distribute.rkt
View File

@ -446,10 +446,9 @@
(loop (cdr exts) (inc-counter counter))])
(values (if src
(cons (transform-entry
(path->bytes
(relative->binary-relative (car sub-dirs)
(car types)
(build-path relative-exts-dir sub dest)))
(relative->binary-relative (car sub-dirs)
(car types)
(build-path relative-exts-dir sub dest))
(car exts))
rest-exts)
(cons (car exts)
@ -495,7 +494,7 @@
name))
;; transform-entry
(lambda (new-path ext)
(list new-path (cadr ext)))
(list (path->cross-bytes new-path) (cadr ext)))
0 add1 ; <- counter
orig-binaries binaries types sub-dirs
exts-dir relative-exts-dir
@ -619,7 +618,7 @@
(set! exploded (cdr exploded)))))
;; transform-entry
(lambda (new-path ext)
(cons (car ext) (list new-path)))
(cons (car ext) (list (path->cross-bytes new-path))))
"rt" values ; <- counter
orig-binaries binaries types sub-dirs
exts-dir relative-exts-dir
@ -636,6 +635,28 @@
(string->path s)
s))
(define (path->cross-bytes p)
(define cross-convention
;; it would be nice to have `cross-system-path-convention`:
(case (cross-system-type)
[(windows) 'windows]
[else 'unix]))
(cond
[(eq? cross-convention (system-path-convention-type)) (path->bytes p)]
[else
(let loop ([p p] [accum '()])
(define-values (base name dir?) (split-path p))
(define new-accum (cons (if (path? name)
(bytes->path-element (path-element->bytes name)
cross-convention)
name)
accum))
(cond
[(eq? base 'relative) (path->bytes (apply build-path/convention-type
cross-convention
new-accum))]
[else (loop base new-accum)]))]))
(define (get-binary-type b)
;; Since this is called first, we also check that the executable
;; is a stub binary for Unix or doesn't depend on shared libraries.

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

@ -1321,7 +1321,9 @@
(let ([p (cond
[(bytes? p) (bytes->path p)]
[(so-spec? p)
(define path (so-find p))
(define path (so-find p
(cross-system-type 'so-suffix)
(get-cross-lib-search-dirs)))
(cond
[(and path embedded-dlls-box)
(set-box! embedded-dlls-box (cons path (unbox embedded-dlls-box)))

14
racket/collects/racket/private/so-search.rkt
View File

@ -25,13 +25,15 @@
(build-path base name)
name))))
(define (so-find p)
(define (so-find p
[so-suffix (system-type 'so-suffix)]
[lib-search-dirs (get-lib-search-dirs)])
(let ([verss (cons 'no-suffix
(if (= (length p) 3)
(let ([s (caddr p)])
(if (list? s) s (list s)))
'(#f)))]
[suffix-before-version? (not (equal? (system-type 'so-suffix)
[suffix-before-version? (not (equal? so-suffix
#".dylib"))])
(ormap (lambda (dir)
(ormap (lambda (vers)
@ -40,16 +42,16 @@
(path-extra-suffix (cadr p)
(if (string? vers)
(if suffix-before-version?
(bytes-append (system-type 'so-suffix)
(bytes-append so-suffix
#"."
(string->bytes/utf-8 vers))
(bytes-append #"."
(string->bytes/utf-8 vers)
(system-type 'so-suffix)))
(system-type 'so-suffix))))])
so-suffix))
so-suffix)))])
(let ([p (build-path dir f)])
(and (or (file-exists? p)
(directory-exists? p))
p))))
verss))
(get-lib-search-dirs))))
lib-search-dirs)))