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

157
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
"collects"))]) (or collects-path
(build-path specific-lib-dir
"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)
;; Patch binaries to find collects (let ([relative->binary-relative
(for-each (lambda (b type sub-dir) (lambda (sub-dir type relative-dir)
(set-collects-path (cond
b [sub-dir
(collects-path->bytes (build-path 'up relative-dir)]
(cond [(and (eq? 'macosx (system-type))
[sub-dir (memq type '(mred mredx))
(build-path 'up relative-collects-dir)] (not single-mac-app?))
[(and (eq? 'macosx (system-type)) (build-path 'up 'up 'up relative-dir)]
(memq type '(mred mredx)) [else
(not single-mac-app?)) relative-dir]))])
(build-path 'up 'up 'up relative-collects-dir)] ;; Patch binaries to find collects
[else (for-each (lambda (b type sub-dir)
relative-collects-dir])))) (set-collects-path
binaries types sub-dirs)) b
;; Done! (collects-path->bytes
(void))) (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)))))
(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,

326
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,155 +356,170 @@
(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
(let-values ([(imports fs-imports ft-imports) (module-compiled-imports code)]) [(extension? code)
(let ([all-file-imports (filter (lambda (x) (not (symbol? x))) (set-box! codes
(append imports fs-imports ft-imports))]) (cons (make-mod filename module-path code
(let ([sub-files (map (lambda (i) (normalize (resolve-module-path-index i filename))) name prefix (string->symbol
all-file-imports)] (format "~a~a" prefix name))
[sub-paths (map (lambda (i) (collapse-module-path-index i module-path)) null)
all-file-imports)]) (unbox codes)))]
;; Get code for imports: [code
(for-each (lambda (sub-filename sub-path) (let-values ([(imports fs-imports ft-imports) (module-compiled-imports code)])
(get-code sub-filename (let ([all-file-imports (filter (lambda (x) (not (symbol? x)))
sub-path (append imports fs-imports ft-imports))])
codes (let ([sub-files (map (lambda (i) (normalize (resolve-module-path-index i filename)))
prefixes all-file-imports)]
verbose? [sub-paths (map (lambda (i) (collapse-module-path-index i module-path))
collects-dest all-file-imports)])
on-extension)) ;; Get code for imports:
sub-files sub-paths) (for-each (lambda (sub-filename sub-path)
(if (and collects-dest (get-code sub-filename
(is-lib-path? module-path)) sub-path
;; Install code as .zo: codes
(begin prefixes
(with-output-to-file (lib-module-filename collects-dest module-path) verbose?
(lambda () collects-dest
(write code)) on-extension))
'truncate/replace) sub-files sub-paths)
;; Record module as copied (if (and collects-dest
(set-box! codes (is-lib-path? module-path))
(cons (make-mod filename module-path #f ;; Install code as .zo:
#f #f #f #f) (begin
(unbox codes)))) (with-output-to-file (lib-module-filename collects-dest module-path)
;; Build up relative module resolutions, relative to this one, (lambda ()
;; that will be requested at run-time. (write code))
(let ([mappings (map (lambda (sub-i sub-filename sub-path) 'truncate/replace)
(and (not (and collects-dest ;; Record module as copied
(is-lib-path? sub-path))) (set-box! codes
(let-values ([(path base) (module-path-index-split sub-i)]) (cons (make-mod filename module-path #f
;; Assert: base should refer to this module: #f #f #f #f)
(let-values ([(path2 base2) (module-path-index-split base)]) (unbox codes))))
(when (or path2 base2) ;; Build up relative module resolutions, relative to this one,
(error 'embed "unexpected nested module path index"))) ;; that will be requested at run-time.
(let ([m (assoc sub-filename (unbox codes))]) (let ([mappings (map (lambda (sub-i sub-filename sub-path)
(cons path (mod-full-name m)))))) (and (not (and collects-dest
all-file-imports sub-files sub-paths)]) (is-lib-path? sub-path)))
;; Record the module (let-values ([(path base) (module-path-index-split sub-i)])
(set-box! codes ;; Assert: base should refer to this module:
(cons (make-mod filename module-path code (let-values ([(path2 base2) (module-path-index-split base)])
name prefix (string->symbol (when (or path2 base2)
(format "~a~a" prefix name)) (error 'embed "unexpected nested module path index")))
(filter (lambda (p) (let ([m (assoc sub-filename (unbox codes))])
(and p (cdr p))) (cons path (mod-full-name m))))))
mappings)) all-file-imports sub-files sub-paths)])
(unbox codes)))))))) ;; Record the module
(set-box! codes (set-box! codes
(cons (make-mod filename module-path code (cons (make-mod filename module-path code
name #f #f name prefix (string->symbol
null) (format "~a~a" prefix name))
(unbox codes)))))))) (filter (lambda (p)
(and p (cdr p)))
mappings))
(unbox codes))))))))]
[else
(set-box! codes
(cons (make-mod filename module-path code
name #f #f
null)
(unbox codes)))])))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (make-module-name-resolver code-l) (define (make-module-name-resolver code-l)
`(let ([orig (current-module-name-resolver)] (let ([extensions (filter (lambda (m) (extension? (mod-code m))) code-l)])
[ns (current-namespace)] `(let ([orig (current-module-name-resolver)]
[mapping-table (quote [ns (current-namespace)]
,(map [mapping-table (quote
(lambda (m) ,(map
`(,(mod-full-name m) (lambda (m)
,(mod-mappings m))) `(,(mod-full-name m)
code-l))] ,(mod-mappings m)))
[library-table (quote code-l))]
,(filter values [library-table (quote
(map (lambda (m) ,(filter values
(let ([path (mod-mod-path m)]) (map (lambda (m)
(if (and (pair? path) (let ([path (mod-mod-path m)])
(eq? 'lib (car path))) (if (and (pair? path)
(cons path (mod-full-name m)) (eq? 'lib (car path)))
#f))) (cons path (mod-full-name m))
code-l)))]) #f)))
(letrec ([embedded-resolver code-l)))])
(case-lambda (letrec ([embedded-resolver
[(name) (case-lambda
;; a notification [(name)
(orig name)] ;; a notification
[(name rel-to stx) (orig name)]
(embedded-resolver name rel-to stx #t)] [(name rel-to stx)
[(name rel-to stx load?) (embedded-resolver name rel-to stx #t)]
(if (not (eq? (current-namespace) ns)) [(name rel-to stx load?)
;; Wrong namespace (if (not (eq? (current-namespace) ns))
(orig name rel-to stx load?) ;; Wrong namespace
;; Have a relative mapping? (orig name rel-to stx load?)
(let ([a (assoc rel-to mapping-table)]) ;; Have a relative mapping?
(if a (let ([a (assoc rel-to mapping-table)])
(let ([a2 (assoc name (cadr a))]) (if a
(if a2 (let ([a2 (assoc name (cadr a))])
(cdr a2) (if a2
;; No relative mapping found (presumably a lib) (cdr a2)
(orig name rel-to stx))) ;; No relative mapping found (presumably a lib)
;; A library mapping that we have? (orig name rel-to stx)))
(let ([a3 (and (pair? name) ;; A library mapping that we have?
(eq? (car name) 'lib) (let ([a3 (and (pair? name)
(ormap (lambda (lib-entry) (eq? (car name) 'lib)
(with-handlers ([exn:fail? (lambda (x) #f)]) (ormap (lambda (lib-entry)
;; To check equality of library references, (with-handlers ([exn:fail? (lambda (x) #f)])
;; we have to consider relative paths in the ;; To check equality of library references,
;; filename part of the name. ;; we have to consider relative paths in the
(let loop ([a (build-path ;; filename part of the name.
(apply build-path (let loop ([a (build-path
'same (apply build-path
(cddar lib-entry)) 'same
(cadar lib-entry))] (cddar lib-entry))
[b (build-path (cadar lib-entry))]
(apply build-path [b (build-path
'same (apply build-path
(let ([d (cddr name)]) 'same
(if (null? d) (let ([d (cddr name)])
'("mzlib") (if (null? d)
d))) '("mzlib")
(cadr name))]) d)))
(if (equal? a b) (cadr name))])
lib-entry (if (equal? a b)
(let-values ([(abase aname d?) (split-path a)]) lib-entry
(if (eq? aname 'same) (let-values ([(abase aname d?) (split-path a)])
(loop abase b) (if (eq? aname 'same)
(let-values ([(bbase bname a?) (split-path b)]) (loop abase b)
(if (eq? bname 'same) (let-values ([(bbase bname a?) (split-path b)])
(loop a bbase) (if (eq? bname 'same)
(if (equal? aname bname) (loop a bbase)
(loop abase bbase) (if (equal? aname bname)
#f))))))))) (loop abase bbase)
library-table))]) #f)))))))))
(if a3 library-table))])
;; Have it: (if a3
(cdr a3) ;; Have it:
;; Let default handler try: (cdr a3)
(orig name rel-to stx load?))))))])]) ;; Let default handler try:
(current-module-name-resolver embedded-resolver)))) (orig name rel-to stx load?))))))])])
(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)
(when verbose? (unless (extension? (mod-code nc))
(fprintf (current-error-port) "Writing module from ~s~n" (mod-file nc))) (when verbose?
(write `(current-module-name-prefix ',(string->symbol (mod-prefix nc)))) (fprintf (current-error-port) "Writing module from ~s~n" (mod-file nc)))
(write (mod-code nc))) (write `(current-module-name-prefix ',(string->symbol (mod-prefix 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)