>From 89411b1fd8348c2de7f6cc7dc08400d3601c5cc7 Mon Sep 17 00:00:00 2001 From: Evan Hanson Date: Thu, 31 Mar 2016 22:06:12 +1300 Subject: [PATCH 1/2] 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. --- NEWS | 3 +++ batch-driver.scm | 5 ++--- csc.scm | 33 ++++++++++++++++++++++++++++++++- eval.scm | 22 +++++++++++++--------- manual/Using the compiler | 2 ++ tests/linking-tests.scm | 7 +++++++ tests/runtests.bat | 27 ++++++++++++++++++++++++++- tests/runtests.sh | 12 ++++++++++++ 8 files changed, 97 insertions(+), 14 deletions(-) create mode 100644 tests/linking-tests.scm diff --git a/NEWS b/NEWS index 5097499..14430bd 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 c890678..9781ea7 100644 --- a/batch-driver.scm +++ b/batch-driver.scm @@ -654,9 +654,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 bed0073..6e9cd9e 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/eval.scm b/eval.scm index 635efc2..e796e19 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 e5aeb98..6fd0539 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 0000000..feac0a0 --- /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 3cc5f31..6e507da 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 e1238d3..2bc9aca 100755 --- a/tests/runtests.sh +++ b/tests/runtests.sh @@ -441,6 +441,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 -- 2.7.0