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