From 2e944e3e2e6b1b42f487536435df5dc4b24ec3ab Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 9 May 2006 16:58:37 +0000 Subject: [PATCH] add --multi mode for -o/-g svn: r2888 --- collects/compiler/compiler-unit.ss | 13 ++++-- collects/compiler/ld-unit.ss | 67 +++++++++++++++++------------- collects/compiler/sig.ss | 4 +- collects/compiler/start.ss | 13 +++++- 4 files changed, 60 insertions(+), 37 deletions(-) diff --git a/collects/compiler/compiler-unit.ss b/collects/compiler/compiler-unit.ss index 5e1b138e52..75ff3fa8c2 100644 --- a/collects/compiler/compiler-unit.ss +++ b/collects/compiler/compiler-unit.ss @@ -117,13 +117,15 @@ (define compile-c-extension-parts (make-unprefixed-compiler 'compile-c-extension-part)) - (define (link/glue-extension-parts link? source-files destination-directory) + (define (link/glue-extension-parts link? compile? source-files destination-directory) (let ([u (c-dynamic-require '(lib "ld-unit.ss" "compiler") 'ld@)] [init (unit/sig () (import compiler:linker^) (if link? link-extension - glue-extension))]) + (if compile? + glue-extension + glue-extension-source)))]) (let ([f (invoke-unit/sig (compound-unit/sig (import (COMPILE : dynext:compile^) @@ -143,10 +145,13 @@ (f source-files destination-directory)))) (define (link-extension-parts source-files destination-directory) - (link/glue-extension-parts #t source-files destination-directory)) + (link/glue-extension-parts #t #t source-files destination-directory)) (define (glue-extension-parts source-files destination-directory) - (link/glue-extension-parts #f source-files destination-directory)) + (link/glue-extension-parts #f #t source-files destination-directory)) + + (define (glue-extension-parts-to-c source-files destination-directory) + (link/glue-extension-parts #f #f source-files destination-directory)) (define (compile-to-zo src dest namespace eval?) ((if eval? (lambda (t) (t)) with-module-reading-parameterization) diff --git a/collects/compiler/ld-unit.ss b/collects/compiler/ld-unit.ss index 8b718939fc..d9f97cfb79 100644 --- a/collects/compiler/ld-unit.ss +++ b/collects/compiler/ld-unit.ss @@ -34,15 +34,21 @@ (define (link-extension* files dest-dir) - (do-link-extension #t files dest-dir)) + (do-link-extension #t #t files dest-dir)) (define (glue-extension files dest-dir) - (do-link-extension #f files dest-dir)) + (do-link-extension #f #t files dest-dir)) + + (define (glue-extension-source + files + dest-dir) + (do-link-extension #f #f files dest-dir)) (define (do-link-extension link? + compile? files dest-dir) @@ -273,32 +279,33 @@ (printf "Scheme_Object * scheme_module_name() { return NULL; }~n")) 'truncate) - (let ([tmp-dir (let ([d (getenv "PLTLDTMPDIR")]) - (and d (directory-exists? d) d))]) - - (compile-extension (not (compiler:option:verbose)) - (build-path dest-dir _loader.c) - (build-path dest-dir _loader.o) - (list (collection-path "compiler"))) - - (when (compiler:option:clean-intermediate-files) - (delete-file (build-path dest-dir _loader.c))) + (when compile? + (let ([tmp-dir (let ([d (getenv "PLTLDTMPDIR")]) + (and d (directory-exists? d) d))]) + + (compile-extension (not (compiler:option:verbose)) + (build-path dest-dir _loader.c) + (build-path dest-dir _loader.o) + (list (collection-path "compiler"))) + + (when (compiler:option:clean-intermediate-files) + (delete-file (build-path dest-dir _loader.c))) - (if link? - (begin - (link-extension (not (compiler:option:verbose)) - (cons (build-path dest-dir _loader.o) o-files) - (build-path (if tmp-dir - tmp-dir - dest-dir) - _loader.so)) - (when tmp-dir - (copy-file (build-path tmp-dir _loader.so) - (build-path dest-dir _loader.so)) - (delete-file (build-path tmp-dir _loader.so))) - - (when (compiler:option:clean-intermediate-files) - (delete-file (build-path dest-dir _loader.o))) - - (printf " [output to \"~a\"]~n" (build-path dest-dir _loader.so))) - (printf " [output to \"~a\"]~n" (build-path dest-dir _loader.o)))))))) + (if link? + (begin + (link-extension (not (compiler:option:verbose)) + (cons (build-path dest-dir _loader.o) o-files) + (build-path (if tmp-dir + tmp-dir + dest-dir) + _loader.so)) + (when tmp-dir + (copy-file (build-path tmp-dir _loader.so) + (build-path dest-dir _loader.so)) + (delete-file (build-path tmp-dir _loader.so))) + + (when (compiler:option:clean-intermediate-files) + (delete-file (build-path dest-dir _loader.o))) + + (printf " [output to \"~a\"]~n" (build-path dest-dir _loader.so))) + (printf " [output to \"~a\"]~n" (build-path dest-dir _loader.o))))))))) diff --git a/collects/compiler/sig.ss b/collects/compiler/sig.ss index f21117d961..16729ae628 100644 --- a/collects/compiler/sig.ss +++ b/collects/compiler/sig.ss @@ -81,6 +81,7 @@ link-extension-parts glue-extension-parts + glue-extension-parts-to-c compile-zos @@ -106,4 +107,5 @@ ;; Low-level multi-file extension linker interface (define-signature compiler:linker^ (link-extension - glue-extension))) + glue-extension + glue-extension-source))) diff --git a/collects/compiler/start.ss b/collects/compiler/start.ss index 75f33d988b..9bb1ae3d23 100644 --- a/collects/compiler/start.ss +++ b/collects/compiler/start.ss @@ -57,6 +57,8 @@ (define plt-setup-collections (make-parameter null)) (define plt-include-compiled (make-parameter #f)) + (define stop-at-source (make-parameter #f)) + (define (extract-suffix appender) (bytes->string/latin-1 (subbytes @@ -148,6 +150,11 @@ [("--embedded") ,(lambda (f) (compiler:option:compile-for-embedded #t)) ("Compile for embedded run-time engine, with -c/-o/-g")] + [("--multi") + ,(lambda (f) (stop-at-source #t)) + (,(format "Stop at ~a instead of ~a for -o/-g" + (extract-suffix append-c-suffix) + (extract-suffix append-object-suffix)))] [("-p" "--prefix") ,(lambda (f v) v) ("Add elaboration-time prefix file for -e/-c/-o/-z" "file")] @@ -415,12 +422,14 @@ [(compile-c) ((compile-extensions-to-c prefix) source-files (dest-dir))] [(compile-o) - ((compile-extension-parts prefix) source-files (dest-dir))] + (((if (stop-at-source) compile-extension-parts-to-c compile-extension-parts) prefix) + source-files (dest-dir))] [(link) (never-embedded "link") (link-extension-parts source-files (or (dest-dir) (current-directory)))] [(link-glue) - (glue-extension-parts source-files (or (dest-dir) (current-directory)))] + ((if (stop-at-source) glue-extension-parts-to-c glue-extension-parts) + source-files (or (dest-dir) (current-directory)))] [(zo) ((compile-zos prefix) source-files (if (auto-dest-dir) 'auto