make extension-implemented modules work with mzc --exe and --exe-dir
svn: r5973
This commit is contained in:
Matthew Flatt
parent
a13692ed30
commit
85e838dab4
|
|
@ -13,11 +13,11 @@
|
|||
(provide assemble-distribution)
|
||||
|
||||
(define/kw (assemble-distribution dest-dir
|
||||
binaries
|
||||
orig-binaries
|
||||
#:key
|
||||
[collects-path #f] ; relative to dest-dir
|
||||
[copy-collects null])
|
||||
(let* ([types (map get-binary-type binaries)]
|
||||
(let* ([types (map get-binary-type orig-binaries)]
|
||||
[_ (unless (directory-exists? dest-dir)
|
||||
(make-directory dest-dir))]
|
||||
[sub-dirs (map (lambda (b type)
|
||||
|
|
@ -27,7 +27,7 @@
|
|||
[(macosx) (if (memq type '(mredcgc mred3m))
|
||||
#f
|
||||
"bin")]))
|
||||
binaries
|
||||
orig-binaries
|
||||
types)]
|
||||
;; Copy binaries into place:
|
||||
[binaries
|
||||
|
|
@ -47,14 +47,14 @@
|
|||
(begin
|
||||
(copy-file* b dest)
|
||||
dest))))))
|
||||
binaries
|
||||
orig-binaries
|
||||
sub-dirs
|
||||
types)]
|
||||
[single-mac-app? (and (eq? 'macosx (system-type))
|
||||
(= 1 (length types))
|
||||
(memq (car types) '(mredcgc mred3m)))])
|
||||
;; Create directories for libs and collects:
|
||||
(let-values ([(lib-dir collects-dir relative-collects-dir)
|
||||
;; Create directories for libs, collects, and extensions:
|
||||
(let-values ([(lib-dir collects-dir relative-collects-dir exts-dir relative-exts-dir)
|
||||
(if single-mac-app?
|
||||
;; Special case: single Mac OS X MrEd app:
|
||||
(let-values ([(base name dir?)
|
||||
|
|
@ -69,21 +69,28 @@
|
|||
"collects")))
|
||||
(if collects-path
|
||||
(build-path 'up 'up 'up collects-path)
|
||||
(build-path 'up "Resources" "collects"))))
|
||||
(build-path 'up "Resources" "collects"))
|
||||
(build-path base 'up "Resources" "exts")
|
||||
(build-path 'up "Resources" "exts")))
|
||||
;; General case:
|
||||
(let ([relative-collects-dir
|
||||
(or collects-path
|
||||
(let* ([specific-lib-dir
|
||||
(build-path "lib"
|
||||
"plt"
|
||||
(let-values ([(base name dir?)
|
||||
(split-path (car binaries))])
|
||||
(path-replace-suffix name #""))
|
||||
(path-replace-suffix name #"")))]
|
||||
[relative-collects-dir
|
||||
(or collects-path
|
||||
(build-path specific-lib-dir
|
||||
"collects"))])
|
||||
(values (build-path dest-dir "lib")
|
||||
(build-path dest-dir relative-collects-dir)
|
||||
relative-collects-dir)))])
|
||||
relative-collects-dir
|
||||
(build-path dest-dir specific-lib-dir "exts")
|
||||
(build-path specific-lib-dir "exts"))))])
|
||||
(make-directory* lib-dir)
|
||||
(make-directory* collects-dir)
|
||||
(make-directory* exts-dir)
|
||||
;; Copy libs into place
|
||||
(install-libs lib-dir types)
|
||||
;; Copy collections into place
|
||||
|
|
@ -96,23 +103,31 @@
|
|||
copy-collects)
|
||||
;; Patch binaries to find libs
|
||||
(patch-binaries binaries types)
|
||||
(let ([relative->binary-relative
|
||||
(lambda (sub-dir type relative-dir)
|
||||
(cond
|
||||
[sub-dir
|
||||
(build-path 'up relative-dir)]
|
||||
[(and (eq? 'macosx (system-type))
|
||||
(memq type '(mred mredx))
|
||||
(not single-mac-app?))
|
||||
(build-path 'up 'up 'up relative-dir)]
|
||||
[else
|
||||
relative-dir]))])
|
||||
;; Patch binaries to find collects
|
||||
(for-each (lambda (b type sub-dir)
|
||||
(set-collects-path
|
||||
b
|
||||
(collects-path->bytes
|
||||
(cond
|
||||
[sub-dir
|
||||
(build-path 'up relative-collects-dir)]
|
||||
[(and (eq? 'macosx (system-type))
|
||||
(memq type '(mred mredx))
|
||||
(not single-mac-app?))
|
||||
(build-path 'up 'up 'up relative-collects-dir)]
|
||||
[else
|
||||
relative-collects-dir]))))
|
||||
binaries types sub-dirs))
|
||||
(relative->binary-relative sub-dir type relative-collects-dir))))
|
||||
binaries types sub-dirs)
|
||||
;; Copy over extensions and adjust embedded paths:
|
||||
(copy-extensions-and-patch-binaries orig-binaries binaries types sub-dirs
|
||||
exts-dir
|
||||
relative-exts-dir
|
||||
relative->binary-relative)
|
||||
;; Done!
|
||||
(void)))
|
||||
(void)))))
|
||||
|
||||
(define (install-libs lib-dir types)
|
||||
(case (system-type)
|
||||
|
|
@ -340,6 +355,82 @@
|
|||
(flush-output o)))
|
||||
'update)))))
|
||||
|
||||
(define (copy-extensions-and-patch-binaries orig-binaries binaries types sub-dirs
|
||||
exts-dir relative-exts-dir
|
||||
relative->binary-relative)
|
||||
(let loop ([orig-binaries orig-binaries]
|
||||
[binaries binaries]
|
||||
[types types]
|
||||
[sub-dirs sub-dirs]
|
||||
[counter 0])
|
||||
(unless (null? binaries)
|
||||
(let-values ([(exts start-pos end-pos)
|
||||
(with-input-from-file (car binaries)
|
||||
(lambda ()
|
||||
(let* ([i (current-input-port)]
|
||||
[m (regexp-match-positions #rx#"eXtEnSiOn-modules" i)])
|
||||
(if m
|
||||
;; Read extension table:
|
||||
(begin
|
||||
(file-position i (cdar m))
|
||||
(let ([l (read i)])
|
||||
(values (cadr l) (cdar m) (file-position i))))
|
||||
;; No extension table:
|
||||
(values null #f #f)))))])
|
||||
(if (null? exts)
|
||||
(loop (cdr orig-binaries) (cdr binaries) (cdr types) (cdr sub-dirs) counter)
|
||||
(let-values ([(new-exts counter)
|
||||
;; Copy over the extensions for this binary, generating a separate path
|
||||
;; for each executable
|
||||
(let loop ([exts exts][counter counter])
|
||||
(if (null? exts)
|
||||
(values null counter)
|
||||
(let* ([src (path->complete-path
|
||||
(bytes->path (caar exts))
|
||||
(let-values ([(base name dir?)
|
||||
(split-path (path->complete-path (car orig-binaries)
|
||||
(current-directory)))])
|
||||
base))]
|
||||
[name (let-values ([(base name dir?) (split-path src)])
|
||||
name)]
|
||||
[sub (format "e~a" counter)])
|
||||
; Make dest dir and copy
|
||||
(make-directory* (build-path exts-dir sub))
|
||||
(let ([f (build-path exts-dir sub name)])
|
||||
(when (file-exists? f)
|
||||
(delete-file f))
|
||||
(copy-file src f))
|
||||
;; Generate the new extension entry for the table, and combine with
|
||||
;; recur result for the rest:
|
||||
(let-values ([(rest-exts counter)
|
||||
(loop (cdr exts) (add1 counter))])
|
||||
(values (cons (list (path->bytes
|
||||
(relative->binary-relative (car types)
|
||||
(car sub-dirs)
|
||||
(build-path relative-exts-dir sub name)))
|
||||
(cadr (car exts)))
|
||||
rest-exts)
|
||||
counter)))))])
|
||||
;; Update the binary with the new paths
|
||||
(let* ([str (string->bytes/utf-8 (format "~s" new-exts))]
|
||||
[extra-space 7] ; = "(quote" plus ")"
|
||||
[delta (- (- end-pos start-pos) (bytes-length str) extra-space)])
|
||||
(when (negative? delta)
|
||||
(error 'copy-extensions-and-patch-binaries
|
||||
"not enough room in executable for revised extension table"))
|
||||
(with-output-to-file (car binaries)
|
||||
(lambda ()
|
||||
(let ([o (current-output-port)])
|
||||
(file-position o start-pos)
|
||||
(write-bytes #"(quote" o)
|
||||
(write-bytes str o)
|
||||
;; Add space before final closing paren. This preserves space in case the
|
||||
;; genereated binary is input for a future distribution build.
|
||||
(write-bytes (make-bytes delta (char->integer #\space)) o)
|
||||
(write-bytes #")" o)))
|
||||
'update))
|
||||
(loop (cdr orig-binaries) (cdr binaries) (cdr types) (cdr sub-dirs) counter)))))))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Utilities
|
||||
|
||||
|
|
|
|||
|
|
@ -559,12 +559,14 @@ _embedr-sig.ss_ library provides the signature, _compiler:embed^_.
|
|||
|
||||
If the `on-extension' argument is a procedure, the procedure is
|
||||
called when the traversal of module dependencies arrives at an
|
||||
extension (i.e., a DLL or shared object). The default, #f, causes
|
||||
an exception to be raised when an extension is encountered, since
|
||||
extensions cannot be embedded in executables. The procedure is
|
||||
called with two arguments: a path for the extension, and a boolean
|
||||
that is #t if the extension is a _loader variant (instead of a
|
||||
single-module extension).
|
||||
extension (i.e., a DLL or shared object). The default, #f, causes a
|
||||
reference to a single-module extension (in its current location) to
|
||||
be embedded into the executable, since an extension itself cannot
|
||||
be embedded in executables, the default raises an erorr when only a
|
||||
_loader (instead of a single-module extension) variant is
|
||||
available. The procedure is called with two arguments: a path for
|
||||
the extension, and a boolean that is #t if the extension is a
|
||||
_loader variant.
|
||||
|
||||
If `launcher?' is #t, then no `modules' should be null,
|
||||
`literal-file-list' should be null, `literal-sexp' should be #f,
|
||||
|
|
|
|||
|
|
@ -328,6 +328,8 @@
|
|||
(make-directory* base)
|
||||
p))))
|
||||
|
||||
(define-struct extension (path))
|
||||
|
||||
;; Loads module code, using .zo if there, compiling from .scm if not
|
||||
(define (get-code filename module-path codes prefixes verbose? collects-dest on-extension)
|
||||
(when verbose?
|
||||
|
|
@ -354,14 +356,27 @@
|
|||
(lambda (f l?)
|
||||
(on-extension f l?)
|
||||
#f)
|
||||
#f))]
|
||||
(lambda (file _loader?)
|
||||
(if _loader?
|
||||
(error 'create-embedding-executable
|
||||
"cannot use a _loader extension: ~e"
|
||||
file)
|
||||
(make-extension file)))))]
|
||||
[name (let-values ([(base name dir?) (split-path filename)])
|
||||
(path->string (path-replace-suffix name #"")))]
|
||||
[prefix (let ([a (assoc filename prefixes)])
|
||||
(if a
|
||||
(cdr a)
|
||||
(generate-prefix)))])
|
||||
(if code
|
||||
(cond
|
||||
[(extension? code)
|
||||
(set-box! codes
|
||||
(cons (make-mod filename module-path code
|
||||
name prefix (string->symbol
|
||||
(format "~a~a" prefix name))
|
||||
null)
|
||||
(unbox codes)))]
|
||||
[code
|
||||
(let-values ([(imports fs-imports ft-imports) (module-compiled-imports code)])
|
||||
(let ([all-file-imports (filter (lambda (x) (not (symbol? x)))
|
||||
(append imports fs-imports ft-imports))])
|
||||
|
|
@ -413,16 +428,18 @@
|
|||
(filter (lambda (p)
|
||||
(and p (cdr p)))
|
||||
mappings))
|
||||
(unbox codes))))))))
|
||||
(unbox codes))))))))]
|
||||
[else
|
||||
(set-box! codes
|
||||
(cons (make-mod filename module-path code
|
||||
name #f #f
|
||||
null)
|
||||
(unbox codes))))))))
|
||||
(unbox codes)))])))))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (make-module-name-resolver code-l)
|
||||
(let ([extensions (filter (lambda (m) (extension? (mod-code m))) code-l)])
|
||||
`(let ([orig (current-module-name-resolver)]
|
||||
[ns (current-namespace)]
|
||||
[mapping-table (quote
|
||||
|
|
@ -497,12 +514,12 @@
|
|||
(cdr a3)
|
||||
;; Let default handler try:
|
||||
(orig name rel-to stx load?))))))])])
|
||||
(current-module-name-resolver embedded-resolver))))
|
||||
(current-module-name-resolver embedded-resolver)))))
|
||||
|
||||
;; Write a module bundle that can be loaded with 'load' (do not embed it
|
||||
;; into an executable). The bundle is written to the current output port.
|
||||
(define (write-module-bundle verbose? modules literal-files literal-expression collects-dest
|
||||
on-extension)
|
||||
on-extension program-name)
|
||||
(let* ([module-paths (map cadr modules)]
|
||||
[files (map
|
||||
(lambda (mp)
|
||||
|
|
@ -539,13 +556,39 @@
|
|||
;; Install a module name resolver that redirects
|
||||
;; to the embedded modules
|
||||
(write (make-module-name-resolver (filter mod-code (unbox codes))))
|
||||
(let ([l (unbox codes)])
|
||||
;; Write the extension table and copy module code:
|
||||
(let* ([l (unbox codes)]
|
||||
[extensions (filter (lambda (m) (extension? (mod-code m))) l)])
|
||||
(unless (null? extensions)
|
||||
(write
|
||||
`(let ([eXtEnSiOn-modules ;; this name is magic for the exe -> distribution process
|
||||
(quote ,(map (lambda (m)
|
||||
(let ([p (extension-path (mod-code m))])
|
||||
(when verbose?
|
||||
(fprintf (current-error-port) "Recording extension at ~s~n" p))
|
||||
(list (path->bytes p)
|
||||
(string->symbol (mod-prefix m))
|
||||
;; The program name isn't used. It just helps ensures that
|
||||
;; there's plenty of room in the executable for patching
|
||||
;; the path later when making a distribution.
|
||||
(path->bytes program-name))))
|
||||
extensions))])
|
||||
(for-each (lambda (pr)
|
||||
(current-module-name-prefix (cadr pr))
|
||||
(let ([p (bytes->path (car pr))])
|
||||
(load-extension (if (relative-path? p)
|
||||
(parameterize ([current-directory (find-system-path 'orig-dir)])
|
||||
(or (find-executable-path (find-system-path 'exec-file) p #t)
|
||||
(path->complete-path p (current-directory))))
|
||||
p))))
|
||||
eXtEnSiOn-modules))))
|
||||
(for-each
|
||||
(lambda (nc)
|
||||
(unless (extension? (mod-code nc))
|
||||
(when verbose?
|
||||
(fprintf (current-error-port) "Writing module from ~s~n" (mod-file nc)))
|
||||
(write `(current-module-name-prefix ',(string->symbol (mod-prefix nc))))
|
||||
(write (mod-code nc)))
|
||||
(write (mod-code nc))))
|
||||
l))
|
||||
(write '(current-module-name-prefix #f))
|
||||
(newline)
|
||||
|
|
@ -690,7 +733,8 @@
|
|||
(let ([write-module
|
||||
(lambda ()
|
||||
(write-module-bundle verbose? modules literal-files literal-expression collects-dest
|
||||
on-extension))])
|
||||
on-extension
|
||||
(file-name-from-path dest)))])
|
||||
(let-values ([(start end)
|
||||
(if (and (eq? (system-type) 'macosx)
|
||||
(not unix-starter?))
|
||||
|
|
|
|||
|
|
@ -574,9 +574,6 @@
|
|||
flags))
|
||||
#:collects-path (exe-embedded-collects-path)
|
||||
#:collects-dest (exe-embedded-collects-dest)
|
||||
#:on-extension (lambda (file _loader?)
|
||||
(fprintf (current-error-port)
|
||||
" Skipping extension: ~a\n" file))
|
||||
#:aux (exe-aux))
|
||||
(printf " [output to \"~a\"]~n" dest))]
|
||||
[(exe-dir)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user