Merge pull request #494 from jltaylor-us/concatenate-object-files

Add concatenate-object-files procedure.
original commit: 28254f270ab55e8dde4a4318c9998b42a241f7a5

LOG

@@ -1858,3 +1858,7 @@
   'visiting' or 'revisiting' in a couple of places.
     syntax.ss,
     7.ms, 8.ms
+- added concatenate-object-files
+    compile.ss, primdata.ss
+    7.ms, root-experr*
+    system.stex, use.stex, release_notes.stex

csug/system.stex

@@ -1569,6 +1569,21 @@ first-element is the symbol \scheme{top-level-program},
 program requires at run time, as with \scheme{compile-program}.
 Otherwise, the return value is unspecified.
 
+%----------------------------------------------------------------------------
+\entryheader
+\formdef{concatenate-object-files}{\categoryprocedure}{(concatenate-object-files \var{out-file} \var{in-file_1} \var{in-file_2} \dots)}
+\returns unspecified
+\listlibraries
+\endentryheader
+
+\var{out-file} and each \var{in-file} must be strings.
+
+\scheme{concatenate-object-files} combines the header information
+contained in the object files named by each \var{in-file}.  It then
+writes the combined header information to the file named by
+\var{out-file}, followed by the remaining object code from each
+input file in turn.
+
 %----------------------------------------------------------------------------
 \entryheader
 \formdef{make-boot-file}{\categoryprocedure}{(make-boot-file \var{output-filename} \var{base-boot-list} \var{input-filename} \dots)}

csug/use.stex

@@ -1538,9 +1538,8 @@ libraries have been built and Scheme source files have been compiled
 to object code.
 
 Although not strictly necessary, we suggest that you concatenate your
-object files, if you have more than one, into a single object file.
+object files, if you have more than one, into a single object file
-This may be done on Unix systems simply via the \scheme{cat}
+via the \scheme{concatenate-object-files} procedure.
-program or on Windows via \scheme{copy}.
 Placing all of the object code into a single file
 simplifies both building and distribution of applications.
 

mats/7.ms

@@ -4876,6 +4876,160 @@ evaluating module init
     "invoking K0\ninvoking K1\nrunning K2, x1 = \"chocolate chip\"\n")
 )
 
+(mat concatenate-object-files
+  (begin
+    (define install
+      (lambda (dir . fn*)
+        (for-each
+          (lambda (fn)
+            (call-with-port (open-file-input-port fn)
+              (lambda (ip)
+                (call-with-port (open-file-output-port (format "~a/~a" dir (path-last fn)))
+                  (lambda (op)
+                    (put-bytevector op (get-bytevector-all ip)))))))
+          fn*)))
+    (define test-isolated-load
+      (lambda (fn lib val)
+        (rm-rf "testdir-isolated")
+        (mkdir "testdir-isolated")
+        (install "testdir-isolated" fn)
+        (separate-eval
+          `(cd "testdir-isolated")
+          `(load ,fn)
+          `(let ()
+             (import ,lib)
+             ,val))))
+    #t)
+  (begin
+    (mkfile "testfile-catlibA.ss"
+      '(library (testfile-catlibA)
+         (export a)
+         (import (chezscheme))
+         (define a 1)))
+    (mkfile "testfile-catlibB.ss"
+      '(library (testfile-catlibB)
+         (export a b)
+         (import (chezscheme) (testfile-catlibA))
+         (define b 2)))
+    (mkfile "testfile-catlibC.ss"
+      '(library (testfile-catlibC)
+         (export c)
+         (import (chezscheme) (testfile-catlibB))
+         (define c (+ a b))))
+    (separate-eval
+      '(compile-library "testfile-catlibA.ss" "testfile-catlibA.so"))
+    (separate-eval
+      '(compile-library "testfile-catlibB.ss" "testfile-catlibB.so"))
+    (separate-eval
+      '(compile-library "testfile-catlibC.ss" "testfile-catlibC.so"))
+    #t)
+  (eqv?
+    (separate-eval
+      '(begin
+         (concatenate-object-files "testfile-catlibAB.so" "testfile-catlibA.so" "testfile-catlibB.so")
+         (concatenate-object-files "testfile-catlibBC.so" "testfile-catlibB.so" "testfile-catlibC.so")
+         (concatenate-object-files "testfile-catlibABC.so" "testfile-catlibA.so" "testfile-catlibB.so" "testfile-catlibC.so")))
+    "")
+  (equal?
+    (test-isolated-load "testfile-catlibA.so" '(testfile-catlibA) 'a)
+    "1\n")
+  (error? ; can't find (testfile-catlibA)
+    (test-isolated-load "testfile-catlibB.so" '(testfile-catlibB) 'b))
+  (error? ; can't find (testfile-catlibA)
+    (test-isolated-load "testfile-catlibBC.so" '(testfile-catlibC) 'c))
+  (equal?
+    (test-isolated-load "testfile-catlibABC.so" '(testfile-catlibA) 'a)
+    "1\n")
+  (equal?
+    (test-isolated-load "testfile-catlibABC.so" '(testfile-catlibB) 'b)
+    "2\n")
+  (equal?
+    (test-isolated-load "testfile-catlibABC.so" '(testfile-catlibC) 'c)
+    "3\n")
+  (equal?
+    (test-isolated-load "testfile-catlibAB.so" '(testfile-catlibB) 'b)
+    "2\n")
+  (begin
+    (mkfile "testfile-cof1A.ss"
+      '(library (testfile-cof1A) (export a) (import (chezscheme))
+         (define-syntax a (identifier-syntax 45))))
+    (mkfile "testfile-cof1B.ss"
+      '(library (testfile-cof1B) (export b) (import (chezscheme) (testfile-cof1A))
+         (define b (lambda () (* a 2)))))
+    (mkfile "testfile-cof1P.ss"
+      '(import (chezscheme) (testfile-cof1A) (testfile-cof1B))
+      '(printf "a = ~s, (b) = ~s\n" a (b)))
+    (mkfile "testfile-cof1foo.ss"
+      '(printf "hello from foo!\n"))
+    (mkfile "testfile-cof1bar.ss"
+      '(printf "hello from bar!\n"))
+    (parameterize ([compile-imported-libraries #t]) (compile-program "testfile-cof1P"))
+    (compile-file "testfile-cof1foo")
+    (compile-file "testfile-cof1bar")
+    (let ()
+      (define fake-concatenate-object-files
+        (lambda (outfn infn . infn*)
+          (call-with-port (open-file-output-port outfn (file-options compressed replace))
+            (lambda (op)
+              (for-each
+                (lambda (infn)
+                  (put-bytevector op
+                    (call-with-port (open-file-input-port infn (file-options compressed)) get-bytevector-all)))
+                (cons infn infn*))))))
+      (fake-concatenate-object-files "testfile-cof1fooP.so" "testfile-cof1foo.so" "testfile-cof1P.so")
+      (fake-concatenate-object-files "testfile-cof1barB.so" "testfile-cof1bar.so" "testfile-cof1B.so"))
+    #t)
+  ; using separate-eval since A and B already loaded in the compiling process:
+  (equal?
+    (separate-eval '(load "testfile-cof1fooP.so"))
+    "hello from foo!\na = 45, (b) = 90\n")
+  (equal?
+    (separate-eval
+      '(load "testfile-cof1barB.so")
+      '(printf "~s\n" (and (member '(testfile-cof1B) (library-list)) 'yes)))
+    "hello from bar!\nyes\n")
+  (equal? (separate-eval '(verify-loadability 'visit "testfile-cof1barB.so")) "")
+  (equal? (separate-eval '(verify-loadability 'revisit "testfile-cof1barB.so")) "")
+  (delete-file "testfile-cof1A.so")
+  ; NB: this should be an error, but isn't because we're using the fake concatenate-object-files
+  (equal? (separate-eval '(verify-loadability 'visit "testfile-cof1barB.so")) "") ; requires testfile-cof1A.so
+  (equal? (separate-eval '(verify-loadability 'revisit "testfile-cof1barB.so")) "") ; doesn't require testfile-cof1A.so
+  
+  (equal? (separate-eval '(verify-loadability 'visit "testfile-cof1fooP.so")) "") ; doesn't require testfile-cof1A.so
+  (equal? (separate-eval '(verify-loadability 'revisit "testfile-cof1fooP.so")) "") ; doesn't require testfile-cof1A.so
+  (delete-file "testfile-cof1B.so")
+  (equal? (separate-eval '(verify-loadability 'visit "testfile-cof1fooP.so")) "") ; doesn't require testfile-cof1A.so or testfile-cof1B.so
+  ; NB: this should be an error, but isn't because we're using the fake concatenate-object-files
+  (equal? (separate-eval '(verify-loadability 'revisit "testfile-cof1fooP.so")) "") ; requires testfile-cof1B.so
+
+  ; now with the real concatenate-object-files
+  (begin
+    (separate-eval '(parameterize ([compile-imported-libraries #t]) (compile-program "testfile-cof1P")))
+    (concatenate-object-files "testfile-cof1fooP.so" "testfile-cof1foo.so" "testfile-cof1P.so")
+    (concatenate-object-files "testfile-cof1barB.so" "testfile-cof1bar.so" "testfile-cof1B.so")
+    #t)
+  ; using separate-eval since A and B already loaded in the compiling process:
+  (equal?
+    (separate-eval '(load "testfile-cof1fooP.so"))
+    "hello from foo!\na = 45, (b) = 90\n")
+  (equal?
+    (separate-eval
+      '(load "testfile-cof1barB.so")
+      '(printf "~s\n" (and (member '(testfile-cof1B) (library-list)) 'yes)))
+    "hello from bar!\nyes\n")
+  (equal? (separate-eval '(verify-loadability 'visit "testfile-cof1barB.so")) "")
+  (equal? (separate-eval '(verify-loadability 'revisit "testfile-cof1barB.so")) "")
+  (delete-file "testfile-cof1A.so")
+  (error? (separate-eval '(verify-loadability 'visit "testfile-cof1barB.so"))) ; requires testfile-cof1A.so
+  (equal? (separate-eval '(verify-loadability 'revisit "testfile-cof1barB.so")) "") ; doesn't require testfile-cof1A.so
+  
+  (equal? (separate-eval '(verify-loadability 'visit "testfile-cof1fooP.so")) "") ; doesn't require testfile-cof1A.so
+  (equal? (separate-eval '(verify-loadability 'revisit "testfile-cof1fooP.so")) "") ; doesn't require testfile-cof1A.so
+  (delete-file "testfile-cof1B.so")
+  (equal? (separate-eval '(verify-loadability 'visit "testfile-cof1fooP.so")) "") ; doesn't require testfile-cof1A.so or testfile-cof1B.so
+  (error? (separate-eval '(verify-loadability 'revisit "testfile-cof1fooP.so"))) ; requires testfile-cof1B.so
+)
+
 ;;; section 7.2:
 
 (mat top-level-value-functions

mats/root-experr-compile-0-f-f-f

@@ -7185,6 +7185,10 @@ format.mo:Expected error in mat format-dollar: "format: expected real number for
 7.mo:Expected error in mat verify-loadability: "verify-loadability: loading "testfile-clK0.so" did not define library (testfile-clK0)".
 7.mo:Expected error in mat verify-loadability: "verify-loadability: visiting "testfile-clK0.so" does not define compile-time information for (testfile-clK0)".
 7.mo:Expected error in mat verify-loadability: "separate-eval: Exception: loading testfile-clK0.so did not define library (testfile-clK0)
+7.mo:Expected error in mat concatenate-object-files: "separate-eval: Exception: library (testfile-catlibA) not found
+7.mo:Expected error in mat concatenate-object-files: "separate-eval: Exception: library (testfile-catlibA) not found
+7.mo:Expected error in mat concatenate-object-files: "separate-eval: Exception in verify-loadability: cannot find object file for library (testfile-cof1A)
+7.mo:Expected error in mat concatenate-object-files: "separate-eval: Exception in verify-loadability: cannot find object file for library (testfile-cof1B)
 7.mo:Expected error in mat top-level-value-functions: "top-level-bound?: "hello" is not a symbol".
 7.mo:Expected error in mat top-level-value-functions: "incorrect argument count in call (top-level-bound?)".
 7.mo:Expected error in mat top-level-value-functions: "top-level-bound?: 45 is not a symbol".

mats/root-experr-compile-2-f-f-f

@@ -7185,6 +7185,10 @@ format.mo:Expected error in mat format-dollar: "format: expected real number for
 7.mo:Expected error in mat verify-loadability: "verify-loadability: loading "testfile-clK0.so" did not define library (testfile-clK0)".
 7.mo:Expected error in mat verify-loadability: "verify-loadability: visiting "testfile-clK0.so" does not define compile-time information for (testfile-clK0)".
 7.mo:Expected error in mat verify-loadability: "separate-eval: Exception: loading testfile-clK0.so did not define library (testfile-clK0)
+7.mo:Expected error in mat concatenate-object-files: "separate-eval: Exception: library (testfile-catlibA) not found
+7.mo:Expected error in mat concatenate-object-files: "separate-eval: Exception: library (testfile-catlibA) not found
+7.mo:Expected error in mat concatenate-object-files: "separate-eval: Exception in verify-loadability: cannot find object file for library (testfile-cof1A)
+7.mo:Expected error in mat concatenate-object-files: "separate-eval: Exception in verify-loadability: cannot find object file for library (testfile-cof1B)
 7.mo:Expected error in mat top-level-value-functions: "top-level-bound?: "hello" is not a symbol".
 7.mo:Expected error in mat top-level-value-functions: "incorrect argument count in call (top-level-bound?)".
 7.mo:Expected error in mat top-level-value-functions: "top-level-bound?: 45 is not a symbol".

release_notes/release_notes.stex

@@ -58,6 +58,17 @@ Online versions of both books can be found at
 %-----------------------------------------------------------------------------
 \section{Functionality Changes}\label{section:functionality}
   
+\subsection{Combining object files (9.5.3)}
+
+In previous versions of Chez Scheme, multiple object files could
+be combined by concatinating them into a single file.  To support faster
+object file loading and loadability verification (described later in this
+document), recompile information and information about libraries and
+top-level programs within an object file is now placed at the top of the
+file.  The new \scheme{concatenate-object-files} procedure can be used to
+combine multiple object files while moving this information to the
+top of the combined file.
+
 \subsection{Verifying loadability of libraries and programs (9.5.3)}
 
 The new procedure \scheme{verify-loadability} can be used to
@@ -131,7 +142,9 @@ file where it can be read without the need to scan through the
 remainder of the file.
 Because the library manager expects to find recompile information
 at the front of an object file, it will not find all recompile
-information if object files are concatenated together.
+information if object files are concatenated together via some
+mechanism other than then new \scheme{concatenate-object-files}
+procedure.
 
 Also, the compiler has to hold in memory the object code for all
 expressions in a file so that it can emit the unified recompile

s/compile.ss

@@ -1757,6 +1757,71 @@
     (lambda (out machine . bootfiles)
       (do-make-boot-header who out machine bootfiles))))
 
+(let ()
+  (define (libreq-hash x) (symbol-hash (libreq-uid x)))
+  (define (libreq=? x y) (eq? (libreq-uid x) (libreq-uid y)))
+  (define do-concatenate-object-files
+    (lambda (who outfn infn*)
+      (unless (string? outfn) ($oops who "~s is not a string" outfn))
+      (for-each (lambda (infn) (unless (string? infn) ($oops who "~s is not a string" infn))) infn*)
+      (let ([import-ht (make-hashtable libreq-hash libreq=?)]
+            [include-ht (make-hashtable string-hash string=?)])
+        (let in-loop ([infn* infn*] [rip* '()])
+          (if (null? infn*)
+              (let ([ip* (reverse rip*)])
+                (with-object-file who outfn
+                  (lambda (op)
+                    (emit-header op (constant machine-type))
+                    (c-print-fasl `(object ,(make-recompile-info
+                                              (vector->list (hashtable-keys import-ht))
+                                              (vector->list (hashtable-keys include-ht))))
+                      op (constant fasl-type-visit-revisit))
+                    (for-each (lambda (ip)
+                                (let loop () ;; NB: This loop consumes one entry past the last library/program info record,
+                                             ;; which we presume is the #t end-of-header marker.
+                                  (let ([ty (lookahead-u8 ip)])
+                                    (unless (eof-object? ty)
+                                      ;; perhaps should verify ty here.
+                                      (let ([x (fasl-read ip)])
+                                        (when (or (library-info? x) (program-info? x))
+                                          (c-print-fasl `(object ,x) op ty)
+                                          (loop)))))))
+                      ip*)
+                    ;; inserting #t after lpinfo as an end-of-header marker
+                    (c-print-fasl `(object #t) op (constant fasl-type-visit-revisit))
+                    (let* ([bufsiz (file-buffer-size)] [buf (make-bytevector bufsiz)])
+                      (for-each (lambda (ip)
+                                  (let loop ()
+                                    (let ([n (get-bytevector-n! ip buf 0 bufsiz)])
+                                      (unless (eof-object? n)
+                                        (put-bytevector op buf 0 n)
+                                        (loop))))
+                                  (close-port ip))
+                        ip*)))))
+              (let* ([fn (car infn*)]
+                     [ip ($open-file-input-port who fn)])
+                (on-reset (close-port ip)
+                  ;; NB: Does not currently support files beginning with a #! line.  Add that here if desired.
+                  (port-file-compressed! ip)
+                  (unless ($compiled-file-header? ip) ($oops who "missing header for compiled file ~s" fn))
+                  (let ([rcinfo (fasl-read ip)])
+                    (unless (recompile-info? rcinfo) ($oops who "expected recompile info at start of ~s, found ~a" fn rcinfo))
+                    (for-each
+                      (lambda (x)
+                        ;; NB: this could be enhanced to perform additional checks for compatible versions
+                        (hashtable-set! import-ht x x))
+                      (recompile-info-import-req* rcinfo))
+                    (for-each
+                      (lambda (x) (hashtable-set! include-ht x #t))
+                      (recompile-info-include-req* rcinfo))
+                    (in-loop (cdr infn*) (cons ip rip*))
+                    ))))))))
+
+  (set-who! concatenate-object-files
+    (lambda (outfn infn0 . infn*)
+      (do-concatenate-object-files who outfn (cons infn0 infn*))))
+  )
+
 (set-who! compile-port
   (rec compile-port
     (case-lambda

s/primdata.ss

@@ -1221,6 +1221,7 @@
   (compile-whole-library [sig [(string string) -> (void)]] [flags])
   (compute-composition [sig [(ptr) -> (list)] [(ptr sub-ufixnum) -> (list)]] [flags alloc])
   (compute-size [sig [(ptr) -> (uint)] [(ptr sub-ufixnum) -> (uint)]] [flags alloc])
+  (concatenate-object-files [sig [(pathname pathname pathname ...) -> (void)]] [flags true])
   (condition-broadcast [feature pthreads] [sig [(condition-object) -> (void)]] [flags true])
   (condition-continuation [sig [(continuation-condition) -> (ptr)]] [flags pure mifoldable discard])
   (condition-name [feature pthreads] [sig [(condition-object) -> (maybe-symbol)]] [flags pure])