From e84201ed60973fe665d6b0c0a8897da21f92001e Mon Sep 17 00:00:00 2001 From: felix Date: Mon, 8 Jan 2018 22:25:31 +0100 Subject: [PATCH] Allow "import" in evaluated code in static executables This patch - enables emission of module registration code in standalone executables, - retains module registration code in statically compiled extensions, - provides a new core unit ("eval-modules.scm") that is used by static standalone executables to allow importing core modules without loading external import libraries, - provides an internal hook for locating import library information to enable ther latter, - incorporates changes by Peter Bex to lazily initialize the initial evaluation environment to (see #1437), - adds the csc alias "-N" for "-no-module-registration", - provides a slightly more efficient variant of "merge-se" in modules.scm and - adds a test for using "import" in evaluated code in static binaries --- batch-driver.scm | 32 +++++----- core.scm | 8 +-- csc.mdoc | 2 +- csc.scm | 1 + distribution/manifest | 2 + egg-compile.scm | 2 +- eval-modules.scm | 105 +++++++++++++++++++++++++++++++++ eval.scm | 9 +++ manual/Using the compiler | 2 +- modules.scm | 51 ++++++++-------- rules.make | 39 ++++++------ tests/module-static-eval-compiled.scm | 10 ++++ tests/runtests.bat | 8 +++ tests/runtests.sh | 4 ++ tests/scrutiny.expected | 4 +- 15 files changed, 205 insertions(+), 74 deletions(-) create mode 100644 eval-modules.scm create mode 100644 tests/module-static-eval-compiled.scm diff --git a/batch-driver.scm b/batch-driver.scm index e9a10cd..f42aaa7 100644 --- a/batch-driver.scm +++ b/batch-driver.scm @@ -176,7 +176,14 @@ (initialize-compiler) (set! explicit-use-flag (memq 'explicit-use options)) (set! emit-debug-info (memq 'debug-info options)) - (let ((initforms `((import-for-syntax ,@default-syntax-imports) + (set! enable-module-registration + (not (memq 'no-module-registration options))) + (when (memq 'static options) + (set! static-extensions #t) + (register-feature! 'chicken-compile-static)) + (let* ((dynamic (memq 'dynamic options)) + (unit (memq 'unit options)) + (initforms `((import-for-syntax ,@default-syntax-imports) (##core#declare ,@(append default-declarations @@ -185,17 +192,16 @@ '()) (if explicit-use-flag '() - `((uses ,@default-units))))) - ,@(if explicit-use-flag - '() - `((import ,@default-imports))) - ;; Ensure the same default environment is - ;; available from eval, as well. See notes at - ;; the end of internal.scm and modules.scm. + `((uses ,@default-units))) + (if (and static-extensions + enable-module-registration + (not dynamic) + (not unit)) + '((uses eval-modules)) + '()))) ,@(if explicit-use-flag '() - `((scheme#eval '(import-for-syntax ,@default-syntax-imports)) - (scheme#eval '(import ,@default-imports)))))) + `((import ,@default-imports))))) (verbose (memq 'verbose options)) (outfile (cond ((memq 'output-file options) => (lambda (node) @@ -224,9 +230,7 @@ (hsize (memq 'heap-size options)) (kwstyle (memq 'keyword-style options)) (loop/dispatch (memq 'clustering options)) - (unit (memq 'unit options)) (a-only (memq 'analyze-only options)) - (dynamic (memq 'dynamic options)) (do-scrutinize #t) (do-lfa2 (memq 'lfa2 options)) (dumpnodes #f) @@ -329,7 +333,6 @@ (when (and (memq 'emit-all-import-libraries options) (not a-only)) (set! all-import-libraries #t)) - (set! enable-module-registration (not (memq 'no-module-registration options))) (when enable-specialization (set! do-scrutinize #t)) (when (memq 't debugging-chicken) (##sys#start-timer)) @@ -338,9 +341,6 @@ (set! explicit-use-flag #t) (set! cleanup-forms '()) (set! initforms '()) ) - (when (memq 'static options) - (set! static-extensions #t) - (register-feature! 'chicken-compile-static)) (when (memq 'no-lambda-info options) (set! emit-closure-info #f) ) (when (memq 'no-compiler-syntax options) diff --git a/core.scm b/core.scm index b22ff9f..d16815e 100644 --- a/core.scm +++ b/core.scm @@ -1011,12 +1011,8 @@ (else (values (reverse xs) - ;; XXX there's currently no way to enable - ;; module registration for executables! - (if standalone-executable - '() - (##sys#compiled-module-registration - (##sys#current-module))))))) + (##sys#compiled-module-registration + (##sys#current-module)))))) (else (loop (cdr body) diff --git a/csc.mdoc b/csc.mdoc index 16d2c89..f1e7158 100644 --- a/csc.mdoc +++ b/csc.mdoc @@ -107,7 +107,7 @@ Macros are made available at run-time. Write compile-time module information into separate file. .It Fl J , Fl emit-all-import-libraries Emit import-libraries for all defined modules. -.It Fl no-module-registration +.It Fl N , Fl no-module-registration Do not generate module registration code. .It Fl no-compiler-syntax Disable expansion of compiler-macros. diff --git a/csc.scm b/csc.scm index fb8cc54..78c64ae 100644 --- a/csc.scm +++ b/csc.scm @@ -173,6 +173,7 @@ (|-K| "-keyword-style") (|-X| "-extend") (|-J| "-emit-all-import-libraries") + (|-N| "-no-module-registration") (-x "-explicit-use") (-u "-unsafe") (-j "-emit-import-library") diff --git a/distribution/manifest b/distribution/manifest index 0fa78f9..abe628d 100644 --- a/distribution/manifest +++ b/distribution/manifest @@ -72,6 +72,7 @@ csi.mdoc csi.scm csibatch.bat eval.scm +eval-modules.scm extras.scm data-structures.scm debugger-client.scm @@ -157,6 +158,7 @@ tests/test-gc-hooks.scm tests/test-glob.scm tests/matchable.scm tests/module-tests.scm +tests/module-static-eval-compiled.scm tests/module-tests-2.scm tests/multiple-values.scm tests/test-finalizers.scm diff --git a/egg-compile.scm b/egg-compile.scm index 8b88bd8..3d2d40a 100644 --- a/egg-compile.scm +++ b/egg-compile.scm @@ -474,7 +474,7 @@ " -emit-link-file " (quotearg (conc sname +link-file-extension+)) (if (eq? mode 'host) " -host" "") - " -D compiling-extension -c -J -unit " name + " -D compiling-extension -c -unit " name " -D compiling-static-extension" " -C -I" srcdir (arglist opts) " " src " -o " out " : " diff --git a/eval-modules.scm b/eval-modules.scm new file mode 100644 index 0000000..b99da5c --- /dev/null +++ b/eval-modules.scm @@ -0,0 +1,105 @@ +;;;; module registrations for all core modules +; +; Copyright (c) 2017, The CHICKEN Team +; All rights reserved. +; +; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following +; conditions are met: +; +; Redistributions of source code must retain the above copyright notice, this list of conditions and the following +; disclaimer. +; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following +; disclaimer in the documentation and/or other materials provided with the distribution. +; Neither the name of the author nor the names of its contributors may be used to endorse or promote +; products derived from this software without specific prior written permission. +; +; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS +; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY +; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR +; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR +; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +; POSSIBILITY OF SUCH DAMAGE. + + +(declare + (unit eval-modules)) + +(include "common-declarations.scm") + + +(define-syntax put! + (syntax-rules () + ((_ sym prop val) + (##core#inline_allocate ("C_a_i_putprop" 8) sym prop val)))) + +(define-syntax get + (syntax-rules () + ((_ sym prop) + (##core#inline "C_i_getprop" sym prop #f)))) + +(define-syntax defmod + (er-macro-transformer + (lambda (x r c) + (let ((name (cadr x)) + (%lambda (r 'lambda)) + (%quote (r 'quote)) + (%include (r 'include)) + (%put! (r 'put!))) + `(,%put! (,%quote ,name) + (,%quote ##sys#import) + (,%lambda () + (,%include ,(string-append (symbol->string name) + ".import.scm")))))))) + +(defmod chicken) +(defmod chicken) +(defmod chicken.bitwise) +(defmod chicken.blob) +(defmod chicken.foreign) +(defmod chicken.fixnum) +(defmod chicken.keyword) +(defmod chicken.internal) +(defmod chicken.platform) +(defmod chicken.errno) +(defmod chicken.condition) +(defmod chicken.string) +(defmod chicken.irregex) +(defmod chicken.pathname) +(defmod chicken.io) +(defmod chicken.port) +(defmod chicken.time) +(defmod chicken.memory) +(defmod chicken.posix) +(defmod chicken.file.posix) +(defmod chicken.flonum) +(defmod chicken.format) +(defmod chicken.gc) +(defmod chicken.eval) +(defmod chicken.load) +(defmod chicken.locative) +(defmod chicken.memory.representation) +(defmod chicken.plist) +(defmod chicken.pretty-print) +(defmod chicken.process) +(defmod chicken.process.signal) +(defmod chicken.process-context) +(defmod chicken.process-context.posix) +(defmod chicken.random) +(defmod chicken.sort) +(defmod chicken.time.posix) +(defmod chicken.continuation) +(defmod chicken.file) +(defmod chicken.read-syntax) +(defmod chicken.repl) +(defmod chicken.tcp) +(defmod srfi-4) + +(set! ##sys#import-library-hook + (let ((hook ##sys#import-library-hook)) + (lambda (mname) + (let ((il (get mname '##sys#import))) + (or (il) + (hook mname)))))) diff --git a/eval.scm b/eval.scm index 0d577c0..2f5b2ca 100644 --- a/eval.scm +++ b/eval.scm @@ -739,6 +739,15 @@ (make-parameter (lambda (x #!optional env) (let ((se (##sys#current-environment))) + ;; When se is empty, it's the first time eval was called: + ;; ensure an active default environment. We do it here because + ;; eval does not work yet at the end of modules.scm, and we + ;; don't want to inject calls into every toplevel (see #1437) + (when (null? se) + ((compile-to-closure + `(##core#begin (import-for-syntax ,@default-syntax-imports) + (import ,@default-imports)) + '() se #f #f #f #t) '())) (cond (env (##sys#check-structure env 'environment 'eval) (let ((se2 (##sys#slot env 2))) diff --git a/manual/Using the compiler b/manual/Using the compiler index 6f952f5..0fa8e36 100644 --- a/manual/Using the compiler +++ b/manual/Using the compiler @@ -105,7 +105,7 @@ the source text should be read from standard input. ; -no-lambda-info : Don't emit additional information for each {{lambda}} expression (currently the argument-list, after alpha-conversion/renaming). -; -no-module-registration : Do not generate module-registration code in the compiled code. This is only needed if you want to use an import library that is generated by other means (manually, for example). +; -no-module-registration : Do not generate module-registration code in the compiled binary. Use this if you don't intend to expose modules from the currently compiled code to expressions executed via {{eval}}. ; -no-parentheses-synonyms : Disables list delimiter synonyms, [..] and {...} for (...). diff --git a/modules.scm b/modules.scm index 92e13df..a4539d2 100644 --- a/modules.scm +++ b/modules.scm @@ -299,16 +299,15 @@ (warn "indirect export of unknown binding" (car iexports)) (loop2 (cdr iexports))))))))))) -(define (merge-se . ses) ; later occurrences take precedence to earlier ones - (let ((se (apply append ses))) - (dm "merging " (length ses) " se's with total length of " (length se)) - (let ((se2 - (let loop ((se se)) - (cond ((null? se) '()) - ((assq (caar se) (cdr se)) (loop (cdr se))) - (else (cons (car se) (loop (cdr se)))))))) - (dm " merged has length " (length se2)) - se2))) +(define (merge-se . ses) ; later occurrences take precedence + (let bwd ((ses ses)) + (if (null? ses) + '() + (let fwd ((se (car ses)) + (rest (bwd (cdr ses)))) + (cond ((null? se) rest) + ((assq (caar se) rest) (fwd (cdr se) rest)) + (else (cons (car se) (fwd (cdr se) rest)))))))) (define (##sys#compiled-module-registration mod) (let ((dlist (module-defined-list mod)) @@ -377,7 +376,7 @@ sdefs)) (mod (make-module name lib '() vexports sexps iexps)) (senv (merge-se - (##sys#macro-environment) + (##sys#macro-environment) (##sys#current-environment) iexps vexports sexps nexps))) (mark-imported-symbols iexps) @@ -564,22 +563,25 @@ ;;; Import-expansion +(define (##sys#import-library-hook mname) + (and-let* ((il (chicken.load#find-dynamic-extension + (string-append (symbol->string mname) ".import") + #t))) + (parameterize ((##sys#current-module #f) + (##sys#current-environment '()) + (##sys#current-meta-environment + (##sys#current-meta-environment)) + (##sys#macro-environment + (##sys#meta-macro-environment))) + (fluid-let ((##sys#notices-enabled #f)) ; to avoid re-import warnings + (load il) + (##sys#find-module mname 'import))))) + (define (find-module/import-library lib loc) (let* ((mname (##sys#resolve-module-name lib loc)) (mod (##sys#find-module mname #f loc))) (unless mod - (and-let* ((il (chicken.load#find-dynamic-extension - (string-append (symbol->string mname) ".import") - #t))) - (parameterize ((##sys#current-module #f) - (##sys#current-environment '()) - (##sys#current-meta-environment - (##sys#current-meta-environment)) - (##sys#macro-environment - (##sys#meta-macro-environment))) - (fluid-let ((##sys#notices-enabled #f)) ; to avoid re-import warnings - (load il) - (set! mod (##sys#find-module mname 'import)))))) + (set! mod (##sys#import-library-hook mname))) mod)) (define (##sys#decompose-import x r c loc) @@ -1133,7 +1135,6 @@ ;; Ensure default modules are available in "eval", too ;; TODO: Figure out a better way to make this work for static programs. -;; The actual imports are handled by the prelude inserted by -;; batch-driver.scm +;; The actual imports are handled lazily by eval when first called. (include "chicken.base.import.scm") (include "chicken.syntax.import.scm") diff --git a/rules.make b/rules.make index ef162cf..d066abe 100644 --- a/rules.make +++ b/rules.make @@ -125,6 +125,8 @@ declare-static-libchicken-object = $(declare-static-library-object) $(foreach obj, $(LIBCHICKEN_OBJECTS_1),\ $(eval $(call declare-static-libchicken-object,$(obj)))) +$(eval $(call declare-static-libchicken-object,eval-modules)) + # import library objects define declare-import-lib-object @@ -205,7 +207,7 @@ cyg$(PROGRAM_PREFIX)chicken$(PROGRAM_SUFFIX)-0.dll: $(LIBCHICKEN_SHARED_OBJECTS) -Wl,--whole-archive $(LIBCHICKEN_SHARED_OBJECTS) \ -Wl,--no-whole-archive $(LIBCHICKEN_SO_LIBRARIES) -lib$(PROGRAM_PREFIX)chicken$(PROGRAM_SUFFIX)$(A): $(LIBCHICKEN_STATIC_OBJECTS) +lib$(PROGRAM_PREFIX)chicken$(PROGRAM_SUFFIX)$(A): $(LIBCHICKEN_STATIC_OBJECTS) eval-modules-static.o $(LIBRARIAN) $(LIBRARIAN_OPTIONS) $(LIBRARIAN_OUTPUT) $^ # import libraries and extensions @@ -535,7 +537,6 @@ c-backend.c: c-backend.scm mini-srfi-1.scm \ chicken.compiler.c-platform.import.scm \ chicken.compiler.support.import.scm \ chicken.compiler.core.import.scm \ - chicken.base.import.scm \ chicken.bitwise.import.scm \ chicken.flonum.import.scm \ chicken.foreign.import.scm \ @@ -547,25 +548,21 @@ c-backend.c: c-backend.scm mini-srfi-1.scm \ core.c: core.scm mini-srfi-1.scm \ chicken.compiler.scrutinizer.import.scm \ chicken.compiler.support.import.scm \ - chicken.base.import.scm \ chicken.eval.import.scm \ chicken.format.import.scm \ chicken.io.import.scm \ chicken.keyword.import.scm \ chicken.load.import.scm \ chicken.pretty-print.import.scm \ - chicken.string.import.scm \ - chicken.syntax.import.scm + chicken.string.import.scm optimizer.c: optimizer.scm mini-srfi-1.scm \ chicken.compiler.support.import.scm \ - chicken.base.import.scm \ chicken.internal.import.scm \ chicken.sort.import.scm \ chicken.string.import.scm scheduler.c: scheduler.scm \ chicken.format.import.scm scrutinizer.c: scrutinizer.scm mini-srfi-1.scm \ - chicken.base.import.scm \ chicken.compiler.support.import.scm \ chicken.format.import.scm \ chicken.internal.import.scm \ @@ -574,8 +571,7 @@ scrutinizer.c: scrutinizer.scm mini-srfi-1.scm \ chicken.platform.import.scm \ chicken.port.import.scm \ chicken.pretty-print.import.scm \ - chicken.string.import.scm \ - chicken.syntax.import.scm + chicken.string.import.scm lfa2.c: lfa2.scm mini-srfi-1.scm \ chicken.compiler.support.import.scm \ chicken.format.import.scm @@ -588,7 +584,6 @@ chicken-ffi-syntax.c: chicken-ffi-syntax.scm \ chicken.internal.import.scm \ chicken.string.import.scm support.c: support.scm mini-srfi-1.scm \ - chicken.base.import.scm \ chicken.bitwise.import.scm \ chicken.blob.import.scm \ chicken.condition.import.scm \ @@ -606,14 +601,14 @@ support.c: support.scm mini-srfi-1.scm \ chicken.random.import.scm \ chicken.sort.import.scm \ chicken.string.import.scm \ - chicken.syntax.import.scm \ chicken.time.import.scm modules.c: modules.scm \ chicken.internal.import.scm \ chicken.keyword.import.scm \ + chicken.base.import.scm \ + chicken.syntax.import.scm \ chicken.load.import.scm \ - chicken.platform.import.scm \ - chicken.syntax.import.scm + chicken.platform.import.scm csc.c: csc.scm \ chicken.file.import.scm \ chicken.foreign.import.scm \ @@ -625,7 +620,6 @@ csc.c: csc.scm \ chicken.process-context.import.scm \ chicken.string.import.scm csi.c: csi.scm \ - chicken.base.import.scm \ chicken.condition.import.scm \ chicken.foreign.import.scm \ chicken.format.import.scm \ @@ -640,8 +634,7 @@ csi.c: csi.scm \ chicken.process-context.import.scm \ chicken.repl.import.scm \ chicken.sort.import.scm \ - chicken.string.import.scm \ - chicken.syntax.import.scm + chicken.string.import.scm chicken-profile.c: chicken-profile.scm \ chicken.internal.import.scm \ chicken.posix.import.scm \ @@ -692,8 +685,7 @@ srfi-4.c: srfi-4.scm \ chicken.bitwise.import.scm \ chicken.foreign.import.scm \ chicken.gc.import.scm \ - chicken.platform.import.scm \ - chicken.syntax.import.scm + chicken.platform.import.scm posixunix.c: posixunix.scm \ chicken.bitwise.import.scm \ chicken.condition.import.scm \ @@ -733,10 +725,7 @@ eval.c: eval.scm \ chicken.foreign.import.scm \ chicken.internal.import.scm \ chicken.keyword.import.scm \ - chicken.platform.import.scm \ - chicken.syntax.import.scm -irregex.c: irregex.scm \ - chicken.syntax.import.scm + chicken.platform.import.scm repl.c: repl.scm \ chicken.eval.import.scm file.c: file.scm \ @@ -761,6 +750,10 @@ tcp.c: tcp.scm \ chicken.foreign.import.scm \ chicken.port.import.scm \ chicken.time.import.scm +eval-modules.c: eval-modules.scm $(DYNAMIC_IMPORT_LIBRARIES:=.import.scm) \ + $(foreach lib,$(DYNAMIC_CHICKEN_IMPORT_LIBRARIES),chicken.$(lib).import.scm) \ + $(foreach lib,$(DYNAMIC_CHICKEN_UNIT_IMPORT_LIBRARIES),$(lib).c) + define profile-flags $(if $(filter $(basename $(1)),$(PROFILE_OBJECTS)),-profile) @@ -857,6 +850,8 @@ debugger-client.c: $(SRCDIR)debugger-client.scm $(SRCDIR)common-declarations.scm $(bootstrap-lib) build-version.c: $(SRCDIR)build-version.scm $(SRCDIR)buildversion buildbranch buildid $(bootstrap-lib) +eval-modules.c: $(SRCDIR)eval-modules.scm $(SRCDIR)common-declarations.scm + $(bootstrap-lib) define declare-bootstrap-import-lib $(1).import.c: $$(SRCDIR)$(1).import.scm diff --git a/tests/module-static-eval-compiled.scm b/tests/module-static-eval-compiled.scm new file mode 100644 index 0000000..dc6ba9b --- /dev/null +++ b/tests/module-static-eval-compiled.scm @@ -0,0 +1,10 @@ +;;;; test eval in statically compiled code + + +(eval '(import (chicken memory representation))) +(assert (eval '(= 1 (block-ref #(1) 0)))) +(module static (foo) + (import scheme (chicken memory representation)) + (define (foo x) (block-ref x 0))) +(eval '(import static)) +(assert (eval '(= 99 (foo #(99))))) diff --git a/tests/runtests.bat b/tests/runtests.bat index 794faf2..bfc245e 100644 --- a/tests/runtests.bat +++ b/tests/runtests.bat @@ -374,6 +374,14 @@ echo ======================================== module tests (compiled) ... if errorlevel 1 exit /b 1 a.out if errorlevel 1 exit /b 1 +%compile% module-static-eval-compiled.scm +if errorlevel 1 exit /b 1 +a.out +if errorlevel 1 exit /b 1 +%compile% -static module-static-eval-compiled.scm +if errorlevel 1 exit /b 1 +a.out +if errorlevel 1 exit /b 1 echo ======================================== module tests (chained) ... del /f /q m*.import.* test-chained-modules.so diff --git a/tests/runtests.sh b/tests/runtests.sh index 8975370..7580768 100755 --- a/tests/runtests.sh +++ b/tests/runtests.sh @@ -304,6 +304,10 @@ rm -f "$module.import.scm" echo "======================================== module tests (compiled) ..." $compile module-tests-compiled.scm ./a.out +$compile module-static-eval-compiled.scm +./a.out +$compile -static module-static-eval-compiled.scm +./a.out echo "======================================== module tests (chained) ..." rm -f m*.import.* test-chained-modules.so diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected index 75910d1..f4ec793 100644 --- a/tests/scrutiny.expected +++ b/tests/scrutiny.expected @@ -43,10 +43,10 @@ Warning: at toplevel: assignment of value of type `fixnum' to toplevel variable `scheme#car' does not match declared type `(forall (a) (procedure scheme#car ((pair a *)) a))' Warning: at toplevel: - expected a single result in `let' binding of `g118', but received 2 results + expected a single result in `let' binding of `g127', but received 2 results Warning: at toplevel: - in procedure call to `g118', expected a value of type `(procedure () *)' but was given a value of type `fixnum' + in procedure call to `g127', expected a value of type `(procedure () *)' but was given a value of type `fixnum' Note: in toplevel procedure `foo': expected a value of type boolean in conditional, but was given a value of type `(procedure bar () *)' which is always true: -- 1.7.9.5