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

make extension-implemented modules work with mzc --exe and --exe-dir

Browse Source 
svn: r5973
This commit is contained in:
Matthew Flatt 2007-04-18 02:36:32 +00:00
parent a13692ed30
commit 85e838dab4
4 changed files with 317 additions and 183 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

135
collects/compiler/distribute.ss
View File

@ -13,11 +13,11 @@
(provide assemble-distribution) (provide assemble-distribution)
(define/kw (assemble-distribution dest-dir (define/kw (assemble-distribution dest-dir
binaries orig-binaries
#:key #:key
[collects-path #f] ; relative to dest-dir [collects-path #f] ; relative to dest-dir
[copy-collects null]) [copy-collects null])
(let* ([types (map get-binary-type binaries)] (let* ([types (map get-binary-type orig-binaries)]
[_ (unless (directory-exists? dest-dir) [_ (unless (directory-exists? dest-dir)
(make-directory dest-dir))] (make-directory dest-dir))]
[sub-dirs (map (lambda (b type) [sub-dirs (map (lambda (b type)
@ -27,7 +27,7 @@
[(macosx) (if (memq type '(mredcgc mred3m)) [(macosx) (if (memq type '(mredcgc mred3m))
#f #f
"bin")])) "bin")]))
binaries orig-binaries
types)] types)]
;; Copy binaries into place: ;; Copy binaries into place:
[binaries [binaries
@ -47,14 +47,14 @@
(begin (begin
(copy-file* b dest) (copy-file* b dest)
dest)))))) dest))))))
binaries orig-binaries
sub-dirs sub-dirs
types)] types)]
[single-mac-app? (and (eq? 'macosx (system-type)) [single-mac-app? (and (eq? 'macosx (system-type))
(= 1 (length types)) (= 1 (length types))
(memq (car types) '(mredcgc mred3m)))]) (memq (car types) '(mredcgc mred3m)))])
;; Create directories for libs and collects: ;; Create directories for libs, collects, and extensions:
(let-values ([(lib-dir collects-dir relative-collects-dir) (let-values ([(lib-dir collects-dir relative-collects-dir exts-dir relative-exts-dir)
(if single-mac-app? (if single-mac-app?
;; Special case: single Mac OS X MrEd app: ;; Special case: single Mac OS X MrEd app:
(let-values ([(base name dir?) (let-values ([(base name dir?)
@ -69,21 +69,28 @@
"collects"))) "collects")))
(if collects-path (if collects-path
(build-path 'up 'up 'up 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: ;; General case:
(let ([relative-collects-dir (let* ([specific-lib-dir
(or collects-path
(build-path "lib" (build-path "lib"
"plt" "plt"
(let-values ([(base name dir?) (let-values ([(base name dir?)
(split-path (car binaries))]) (split-path (car binaries))])
(path-replace-suffix name #"")) (path-replace-suffix name #"")))]
[relative-collects-dir
(or collects-path
(build-path specific-lib-dir
"collects"))]) "collects"))])
(values (build-path dest-dir "lib") (values (build-path dest-dir "lib")
(build-path dest-dir relative-collects-dir) (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* lib-dir)
(make-directory* collects-dir) (make-directory* collects-dir)
(make-directory* exts-dir)
;; Copy libs into place ;; Copy libs into place
(install-libs lib-dir types) (install-libs lib-dir types)
;; Copy collections into place ;; Copy collections into place
@ -96,23 +103,31 @@
copy-collects) copy-collects)
;; Patch binaries to find libs ;; Patch binaries to find libs
(patch-binaries binaries types) (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 ;; Patch binaries to find collects
(for-each (lambda (b type sub-dir) (for-each (lambda (b type sub-dir)
(set-collects-path (set-collects-path
b b
(collects-path->bytes (collects-path->bytes
(cond (relative->binary-relative sub-dir type relative-collects-dir))))
[sub-dir binaries types sub-dirs)
(build-path 'up relative-collects-dir)] ;; Copy over extensions and adjust embedded paths:
[(and (eq? 'macosx (system-type)) (copy-extensions-and-patch-binaries orig-binaries binaries types sub-dirs
(memq type '(mred mredx)) exts-dir
(not single-mac-app?)) relative-exts-dir
(build-path 'up 'up 'up relative-collects-dir)] relative->binary-relative)
[else
relative-collects-dir]))))
binaries types sub-dirs))
;; Done! ;; Done!
(void))) (void)))))
(define (install-libs lib-dir types) (define (install-libs lib-dir types)
(case (system-type) (case (system-type)
@ -340,6 +355,82 @@
(flush-output o))) (flush-output o)))
'update))))) '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 ;; Utilities

14
collects/compiler/doc.txt
View File

@ -559,12 +559,14 @@ _embedr-sig.ss_ library provides the signature, _compiler:embed^_.
If the `on-extension' argument is a procedure, the procedure is If the `on-extension' argument is a procedure, the procedure is
called when the traversal of module dependencies arrives at an called when the traversal of module dependencies arrives at an
extension (i.e., a DLL or shared object). The default, #f, causes extension (i.e., a DLL or shared object). The default, #f, causes a
an exception to be raised when an extension is encountered, since reference to a single-module extension (in its current location) to
extensions cannot be embedded in executables. The procedure is be embedded into the executable, since an extension itself cannot
called with two arguments: a path for the extension, and a boolean be embedded in executables, the default raises an erorr when only a
that is #t if the extension is a _loader variant (instead of a _loader (instead of a single-module extension) variant is
single-module extension). 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, If `launcher?' is #t, then no `modules' should be null,
`literal-file-list' should be null, `literal-sexp' should be #f, `literal-file-list' should be null, `literal-sexp' should be #f,

62
collects/compiler/embed-unit.ss
View File

@ -328,6 +328,8 @@
(make-directory* base) (make-directory* base)
p)))) p))))
(define-struct extension (path))
;; Loads module code, using .zo if there, compiling from .scm if not ;; 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) (define (get-code filename module-path codes prefixes verbose? collects-dest on-extension)
(when verbose? (when verbose?
@ -354,14 +356,27 @@
(lambda (f l?) (lambda (f l?)
(on-extension f l?) (on-extension f l?)
#f) #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)]) [name (let-values ([(base name dir?) (split-path filename)])
(path->string (path-replace-suffix name #"")))] (path->string (path-replace-suffix name #"")))]
[prefix (let ([a (assoc filename prefixes)]) [prefix (let ([a (assoc filename prefixes)])
(if a (if a
(cdr a) (cdr a)
(generate-prefix)))]) (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-values ([(imports fs-imports ft-imports) (module-compiled-imports code)])
(let ([all-file-imports (filter (lambda (x) (not (symbol? x))) (let ([all-file-imports (filter (lambda (x) (not (symbol? x)))
(append imports fs-imports ft-imports))]) (append imports fs-imports ft-imports))])
@ -413,16 +428,18 @@
(filter (lambda (p) (filter (lambda (p)
(and p (cdr p))) (and p (cdr p)))
mappings)) mappings))
(unbox codes)))))))) (unbox codes))))))))]
[else
(set-box! codes (set-box! codes
(cons (make-mod filename module-path code (cons (make-mod filename module-path code
name #f #f name #f #f
null) null)
(unbox codes)))))))) (unbox codes)))])))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (make-module-name-resolver code-l) (define (make-module-name-resolver code-l)
(let ([extensions (filter (lambda (m) (extension? (mod-code m))) code-l)])
`(let ([orig (current-module-name-resolver)] `(let ([orig (current-module-name-resolver)]
[ns (current-namespace)] [ns (current-namespace)]
[mapping-table (quote [mapping-table (quote
@ -497,12 +514,12 @@
(cdr a3) (cdr a3)
;; Let default handler try: ;; Let default handler try:
(orig name rel-to stx load?))))))])]) (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 ;; 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. ;; into an executable). The bundle is written to the current output port.
(define (write-module-bundle verbose? modules literal-files literal-expression collects-dest (define (write-module-bundle verbose? modules literal-files literal-expression collects-dest
on-extension) on-extension program-name)
(let* ([module-paths (map cadr modules)] (let* ([module-paths (map cadr modules)]
[files (map [files (map
(lambda (mp) (lambda (mp)
@ -539,13 +556,39 @@
;; Install a module name resolver that redirects ;; Install a module name resolver that redirects
;; to the embedded modules ;; to the embedded modules
(write (make-module-name-resolver (filter mod-code (unbox codes)))) (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 (for-each
(lambda (nc) (lambda (nc)
(unless (extension? (mod-code nc))
(when verbose? (when verbose?
(fprintf (current-error-port) "Writing module from ~s~n" (mod-file nc))) (fprintf (current-error-port) "Writing module from ~s~n" (mod-file nc)))
(write `(current-module-name-prefix ',(string->symbol (mod-prefix nc)))) (write `(current-module-name-prefix ',(string->symbol (mod-prefix nc))))
(write (mod-code nc))) (write (mod-code nc))))
l)) l))
(write '(current-module-name-prefix #f)) (write '(current-module-name-prefix #f))
(newline) (newline)
@ -690,7 +733,8 @@
(let ([write-module (let ([write-module
(lambda () (lambda ()
(write-module-bundle verbose? modules literal-files literal-expression collects-dest (write-module-bundle verbose? modules literal-files literal-expression collects-dest
on-extension))]) on-extension
(file-name-from-path dest)))])
(let-values ([(start end) (let-values ([(start end)
(if (and (eq? (system-type) 'macosx) (if (and (eq? (system-type) 'macosx)
(not unix-starter?)) (not unix-starter?))

3
collects/compiler/start.ss
View File

@ -574,9 +574,6 @@
flags)) flags))
#:collects-path (exe-embedded-collects-path) #:collects-path (exe-embedded-collects-path)
#:collects-dest (exe-embedded-collects-dest) #:collects-dest (exe-embedded-collects-dest)
#:on-extension (lambda (file _loader?)
(fprintf (current-error-port)
" Skipping extension: ~a\n" file))
#:aux (exe-aux)) #:aux (exe-aux))
(printf " [output to \"~a\"]~n" dest))] (printf " [output to \"~a\"]~n" dest))]
[(exe-dir) [(exe-dir)