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

write embedding sexecutables without setting current output port

Browse Source 
svn: r12780
This commit is contained in:
Matthew Flatt 2008-12-11 20:14:53 +00:00
parent d80ef6a301
commit 3e7e63aecf
1 changed files with 30 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -740,7 +740,7 @@
;; 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 (do-write-module-bundle verbose? modules literal-files literal-expressions collects-dest (define (do-write-module-bundle outp verbose? modules literal-files literal-expressions collects-dest
on-extension program-name compiler expand-namespace on-extension program-name compiler expand-namespace
src-filter get-extra-imports) src-filter get-extra-imports)
(let* ([module-paths (map cadr modules)] (let* ([module-paths (map cadr modules)]
@ -778,11 +778,11 @@
;; Drop elements of `codes' that just record copied libs: ;; Drop elements of `codes' that just record copied libs:
(set-box! codes (filter mod-code (unbox codes))) (set-box! codes (filter mod-code (unbox codes)))
;; Bind `module' to get started: ;; Bind `module' to get started:
(write (compile-using-kernel '(namespace-require '(only '#%kernel module)))) (write (compile-using-kernel '(namespace-require '(only '#%kernel module))) outp)
;; 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))) outp)
(write (compile-using-kernel '(namespace-require ''#%resolver))) (write (compile-using-kernel '(namespace-require ''#%resolver)) outp)
;; Write the extension table and copy module code: ;; Write the extension table and copy module code:
(let* ([l (reverse (unbox codes))] (let* ([l (reverse (unbox codes))]
[extensions (filter (lambda (m) (extension? (mod-code m))) l)] [extensions (filter (lambda (m) (extension? (mod-code m))) l)]
@ -825,15 +825,17 @@
(path->complete-path p (current-directory)))) (path->complete-path p (current-directory))))
(current-directory d))) (current-directory d)))
p)))) p))))
eXtEnSiOn-modules)))) eXtEnSiOn-modules)))
(write (compile-using-kernel '(namespace-require ''#%extension-table)))) outp)
(write (compile-using-kernel '(namespace-require ''#%extension-table)) outp))
;; Runtime-path table: ;; Runtime-path table:
(unless (null? runtimes) (unless (null? runtimes)
(unless table-mod (unless table-mod
(error 'create-embedding-executable "cannot find module for runtime-path table")) (error 'create-embedding-executable "cannot find module for runtime-path table"))
(write (compile-using-kernel (write (compile-using-kernel
`(current-module-declare-name (make-resolved-module-path `(current-module-declare-name (make-resolved-module-path
',(mod-full-name table-mod))))) ',(mod-full-name table-mod))))
outp)
(write `(module runtime-path-table '#%kernel (write `(module runtime-path-table '#%kernel
(#%provide table) (#%provide table)
(define-values (table) (define-values (table)
@ -884,7 +886,8 @@
(bytes-append #"................." (path->bytes program-name)))) (bytes-append #"................." (path->bytes program-name))))
(mod-runtime-paths nc))) (mod-runtime-paths nc)))
runtimes))]) runtimes))])
rUnTiMe-paths)))))) rUnTiMe-paths))))
outp))
;; Copy module code: ;; Copy module code:
(for-each (for-each
(lambda (nc) (lambda (nc)
@ -895,26 +898,27 @@
(write (compile-using-kernel (write (compile-using-kernel
`(current-module-declare-name `(current-module-declare-name
(make-resolved-module-path (make-resolved-module-path
',(mod-full-name nc))))) ',(mod-full-name nc))))
outp)
(if (src-filter (mod-file nc)) (if (src-filter (mod-file nc))
(with-input-from-file (mod-file nc) (call-with-input-file* (mod-file nc)
(lambda () (lambda (inp)
(copy-port (current-input-port) (current-output-port)))) (copy-port inp outp)))
(write (mod-code nc))))) (write (mod-code nc) outp))))
l)) l))
(write (compile-using-kernel '(current-module-declare-name #f))) (write (compile-using-kernel '(current-module-declare-name #f)) outp)
;; Remove `module' binding before we start running user code: ;; Remove `module' binding before we start running user code:
(write (compile-using-kernel '(namespace-set-variable-value! 'module #f #t))) (write (compile-using-kernel '(namespace-set-variable-value! 'module #f #t)) outp)
(write (compile-using-kernel '(namespace-undefine-variable! 'module))) (write (compile-using-kernel '(namespace-undefine-variable! 'module)) outp)
(newline) (newline outp)
(for-each (lambda (f) (for-each (lambda (f)
(when verbose? (when verbose?
(fprintf (current-error-port) "Copying from ~s~n" f)) (fprintf (current-error-port) "Copying from ~s~n" f))
(call-with-input-file* f (call-with-input-file* f
(lambda (i) (lambda (i)
(copy-port i (current-output-port))))) (copy-port i outp))))
literal-files) literal-files)
(for-each write literal-expressions))) (for-each (lambda (v) (write v outp)) literal-expressions)))
(define (write-module-bundle #:verbose? [verbose? #f] (define (write-module-bundle #:verbose? [verbose? #f]
#:modules [modules null] #:modules [modules null]
@ -927,7 +931,7 @@
(compile expr)))] (compile expr)))]
#:src-filter [src-filter (lambda (filename) #f)] #:src-filter [src-filter (lambda (filename) #f)]
#:get-extra-imports [get-extra-imports (lambda (filename code) null)]) #:get-extra-imports [get-extra-imports (lambda (filename code) null)])
(do-write-module-bundle verbose? modules literal-files literal-expressions (do-write-module-bundle (current-output-port) verbose? modules literal-files literal-expressions
#f ; collects-dest #f ; collects-dest
on-extension on-extension
"?" ; program-name "?" ; program-name
@ -1072,8 +1076,9 @@
(path->complete-path orig-exe))]) (path->complete-path orig-exe))])
(update-dll-dir dest (build-path orig-dir dir)))))))) (update-dll-dir dest (build-path orig-dir dir))))))))
(let ([write-module (let ([write-module
(lambda () (lambda (s)
(do-write-module-bundle verbose? modules literal-files literal-expressions collects-dest (do-write-module-bundle s
verbose? modules literal-files literal-expressions collects-dest
on-extension on-extension
(file-name-from-path dest) (file-name-from-path dest)
compiler compiler
@ -1085,15 +1090,14 @@
(not unix-starter?)) (not unix-starter?))
;; For Mach-O, we know how to add a proper segment ;; For Mach-O, we know how to add a proper segment
(let ([s (open-output-bytes)]) (let ([s (open-output-bytes)])
(parameterize ([current-output-port s]) (write-module s)
(write-module))
(let ([s (get-output-bytes s)]) (let ([s (get-output-bytes s)])
(let ([start (add-plt-segment dest-exe s)]) (let ([start (add-plt-segment dest-exe s)])
(values start (values start
(+ start (bytes-length s)))))) (+ start (bytes-length s))))))
;; Other platforms: just add to the end of the file: ;; Other platforms: just add to the end of the file:
(let ([start (file-size dest-exe)]) (let ([start (file-size dest-exe)])
(with-output-to-file dest-exe write-module (call-with-output-file* dest-exe write-module
#:exists 'append) #:exists 'append)
(values start (file-size dest-exe))))]) (values start (file-size dest-exe))))])
(when verbose? (when verbose?