~ chicken-core (chicken-5) f0aafa063b465b90b6414397ddd77860da6ab54e
commit f0aafa063b465b90b6414397ddd77860da6ab54e
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Thu Mar 31 22:06:12 2016 +1300
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Sun Apr 17 19:27:32 2016 +0200
Add "-link" flag for linking with objects from extensions
This is a basic helper option that just adds object files for the named
extensions to csc's link step (if any exist) and automatically "-uses"
them as units.
Signed-off-by: Peter Bex <peter@more-magic.net>
diff --git a/NEWS b/NEWS
index e065f789..8bb75522 100644
--- a/NEWS
+++ b/NEWS
@@ -12,6 +12,9 @@
- The "-scrutinize" compiler option has been removed.
- The "-module" compiler option (aliased as "-m") now expects a module name.
+- Tools
+ - The new "-link" option to csc allows linking with objects from extensions.
+
- Core libraries
- Removed support for memory-mapped files (posix), queues (data-structures),
binary-search (data-structures), scan-input-lines (utils), and
diff --git a/batch-driver.scm b/batch-driver.scm
index 0d319e89..740238ce 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -646,9 +646,8 @@
(when enable-inline-files
(for-each
(lambda (id)
- (and-let* ((ifile (##sys#resolve-include-filename
- (make-pathname #f (symbol->string id) "inline")
- #f #t))
+ (and-let* ((ifile (##sys#resolve-include-filename
+ (symbol->string id) '(".inline") #t))
((file-exists? ifile)))
(dribble "Loading inline file ~a ..." ifile)
(load-inline-file ifile)))
diff --git a/csc.scm b/csc.scm
index 94baf6bb..3db27261 100644
--- a/csc.scm
+++ b/csc.scm
@@ -169,7 +169,7 @@
-emit-type-file -consult-type-file
-feature -debug-level
-emit-import-library
- -module
+ -module -link
-no-feature))
(define-constant shortcuts
@@ -307,6 +307,26 @@
(define static-libs #f)
+;;; Locate object files for linking:
+
+(define (find-object-files name)
+
+ (define (locate-object-file filename repo)
+ (let ((f (##sys#resolve-include-filename filename '() repo)))
+ (and (file-exists? f) (list f))))
+
+ (define (static-extension-information name)
+ (and-let* ((info (extension-information name))
+ (files (alist-ref 'static info eq?)))
+ (map (lambda (f) (make-pathname (repository-path) f)) files)))
+
+ (let ((f (make-pathname #f name object-extension)))
+ (or (locate-object-file f #f)
+ (static-extension-information name)
+ (locate-object-file f #t)
+ (stop "couldn't find linked extension: ~a" name))))
+
+
;;; Display usage information:
(define (usage)
@@ -439,6 +459,8 @@ Usage: #{csc} FILENAME | OPTION ...
-e -embedded compile as embedded
(don't generate `main()')
-gui compile as GUI application
+ -link NAME link extension with compiled executable
+ (implies -uses)
-R -require-extension NAME require extension and import in compiled
code
-dll -library compile multiple units into a dynamic
@@ -539,6 +561,9 @@ EOF
(else "-shared")) link-options))
(set! shared #t) )
+ (define (collect-linked-files names)
+ (append-map find-object-files (string-split names ", ")))
+
(define (use-private-repository)
(set! compile-options (cons "-DC_PRIVATE_REPOSITORY" compile-options)))
@@ -651,6 +676,12 @@ EOF
[(-e -embedded)
(set! embedded #t)
(set! compile-options (cons "-DC_EMBEDDED" compile-options)) ]
+ [(-link)
+ (check s rest)
+ (t-options "-uses" (car rest))
+ (set! object-files
+ (append object-files (collect-linked-files (car rest))))
+ (set! rest (cdr rest))]
[(-require-extension -R)
(check s rest)
(t-options "-require-extension" (car rest))
diff --git a/distribution/manifest b/distribution/manifest
index eb93a5fc..1ba6f9d3 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -118,6 +118,7 @@ tests/arithmetic-test.scm
tests/arithmetic-test.32.expected
tests/arithmetic-test.64.expected
tests/library-tests.scm
+tests/linking-tests.scm
tests/compiler-tests.scm
tests/inlining-tests.scm
tests/locative-stress-test.scm
diff --git a/eval.scm b/eval.scm
index 635efc23..e796e192 100644
--- a/eval.scm
+++ b/eval.scm
@@ -1133,7 +1133,7 @@
(read read)
(reverse reverse))
(lambda (fname)
- (let ((path (##sys#resolve-include-filename fname #t)))
+ (let ((path (##sys#resolve-include-filename fname #t #f)))
(when (load-verbose) (print "; including " path " ..."))
(with-input-from-file path
(lambda ()
@@ -1398,20 +1398,24 @@
(let ((string-append string-append) )
(define (exists? fname)
(##sys#file-exists? fname #t #f #f))
- (lambda (fname prefer-source #!optional repo)
- (define (test2 fname lst)
+ (lambda (fname exts repo)
+ (define (test-extensions fname lst)
(if (null? lst)
(and (exists? fname) fname)
- (let ([fn (##sys#string-append fname (car lst))])
+ (let ((fn (##sys#string-append fname (car lst))))
(if (exists? fn)
fn
- (test2 fname (cdr lst)) ) ) ) )
+ (test-extensions fname (cdr lst))))))
(define (test fname)
- (test2
+ (test-extensions
fname
- (cond ((not (##sys#fudge 24)) (list source-file-extension)) ; no dload?
- (prefer-source (list source-file-extension ##sys#load-dynamic-extension))
- (else (list ##sys#load-dynamic-extension source-file-extension) ) ) ))
+ (cond ((pair? exts) exts) ; specific list of extensions
+ ((not (##sys#fudge 24)) ; no dload -> source only
+ (list source-file-extension))
+ ((not exts) ; prefer compiled
+ (list ##sys#load-dynamic-extension source-file-extension))
+ (else ; prefer source
+ (list source-file-extension ##sys#load-dynamic-extension)))))
(or (test fname)
(let loop ((paths (if repo
(##sys#append
diff --git a/manual/Using the compiler b/manual/Using the compiler
index c7c22a8f..33648792 100644
--- a/manual/Using the compiler
+++ b/manual/Using the compiler
@@ -86,6 +86,8 @@ the source text should be read from standard input.
; -keep-shadowed-macros : Do not remove macro definitions with the same name as assigned toplevel variables (the default is to remove the macro definition).
+; -link NAME : Links the extension {{NAME}} with the compiled program and uses it as a unit. Multiple names may be given and should be separated by commas.
+
; -local : Assume toplevel variables defined in the current compilation unit are not externally modified. This gives the compiler more opportunities for inlining. Note that this may result in counter-intuitive and non-standard behaviour: an asssignment to an exported toplevel variable executed in a different compilation unit or in evaluated code will possibly not be seen by code executing in the current compilation unit.
; -lfa2 : Does an additional lightweight flow-analysis pass on the fully optimized program to remove more type checks.
diff --git a/tests/linking-tests.scm b/tests/linking-tests.scm
new file mode 100644
index 00000000..feac0a05
--- /dev/null
+++ b/tests/linking-tests.scm
@@ -0,0 +1,7 @@
+;;; Tests linking with core units & extensions ("csc -link ...")
+
+(import (chicken irregex)
+ (reverser))
+
+(unless (irregex-match '(: #\1 (+ any) #\9) (rev "987654321"))
+ (error "weird"))
diff --git a/tests/runtests.bat b/tests/runtests.bat
index 3cc5f31b..6e507dac 100644
--- a/tests/runtests.bat
+++ b/tests/runtests.bat
@@ -8,6 +8,7 @@ set OS_NAME=WindowsNT
set CHICKEN=..\chicken
set CHICKEN_PROFILE=..\chicken-profile
+set CHICKEN_REPOSITORY=
set ASMFLAGS=-Wa,-w
set FAST_OPTIONS=-O5 -d0 -b -disable-interrupts
set PATH=%cd%\..;%PATH%
@@ -21,7 +22,8 @@ set compile2=..\csc -compiler %CHICKEN% -v -I%TEST_DIR%/.. -L%TEST_DIR%/.. -incl
set compile_s=..\csc -s -types %TYPESDB% -ignore-repository -compiler %CHICKEN% -v -I%TEST_DIR%/.. -L%TEST_DIR%/.. -include-path %TEST_DIR%/..
set interpret=..\csi -n -include-path %TEST_DIR%/..
-del /f /q *.exe *.so *.o *.import.* ..\foo.import.*
+del /f /q /s *.exe *.so *.o *.import.* ..\foo.import.* test-repository
+mkdir test-repository
echo ======================================== version tests ...
%interpret% -s version-tests.scm
@@ -531,6 +533,29 @@ if errorlevel 1 exit /b 1
a.out
if errorlevel 1 exit /b 1
+echo ======================================== linking tests ...
+%compile% -unit reverser reverser\tags\1.0\reverser.scm -J -c -o reverser.o
+%compile% -link reverser linking-tests.scm
+if errorlevel 1 exit /b 1
+a.out
+if errorlevel 1 exit /b 1
+%compile% -link reverser linking-tests.scm -static
+if errorlevel 1 exit /b 1
+a.out
+if errorlevel 1 exit /b 1
+set CHICKEN_REPOSITORY=test-repository
+mkdir %CHICKEN_REPOSITORY%
+move reverser.o %CHICKEN_REPOSITORY%
+move reverser.import.scm %CHICKEN_REPOSITORY%
+%compile% -link reverser linking-tests.scm
+if errorlevel 1 exit /b 1
+a.out
+if errorlevel 1 exit /b 1
+%compile% -link reverser linking-tests.scm -static
+if errorlevel 1 exit /b 1
+a.out
+if errorlevel 1 exit /b 1
+
echo ======================================== private repository test ...
del /f /s /q tmp
mkdir tmp
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 8d307067..fdf3da9d 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -444,6 +444,18 @@ echo "======================================== embedding (3) ..."
$compile -e embedded3.c embedded4.scm
./a.out
+echo "======================================== linking tests ..."
+$compile -unit reverser reverser/tags/1.0/reverser.scm -J -c -o reverser.o
+$compile -link reverser linking-tests.scm
+./a.out
+$compile -link reverser linking-tests.scm -static
+./a.out
+mv reverser.o reverser.import.scm "$CHICKEN_REPOSITORY"
+CHICKEN_REPOSITORY=$CHICKEN_REPOSITORY $compile -link reverser linking-tests.scm
+./a.out
+CHICKEN_REPOSITORY=$CHICKEN_REPOSITORY $compile -link reverser linking-tests.scm -static
+./a.out
+
echo "======================================== private repository test ..."
mkdir -p tmp
$compile private-repository-test.scm -private-repository -o tmp/xxx
Trap