>From 7a4622bfcf1c727c05b6a6bf5cbfb754914d289b Mon Sep 17 00:00:00 2001 From: Evan Hanson Date: Tue, 29 May 2018 18:33:00 +1200 Subject: [PATCH] Rework library loading to support conditional unit entry This makes a handful of changes to the way library dependencies are processed in order to support conditional unit loading, i.e. not calling a unit's entry procedure unless its code path is really visited: Drop the `file-requirements' hash table in favour of two "lset" globals, `library-requirements' and `unit-requirements', the first of which is a superset of the second. The `unit-requirements' list includes everything that needs to be linked with the program statically (i.e. as a unit), and everything else is a runtime dependency (i.e. loaded as a shared object or source file). Remove the "M" debug option. Introduce a new `uses-declarations' global to keep track of units that are specified with "-uses" or `(declare (uses))'. These are hoisted to the top level and called at the start of the program. Construct the list of `used-units', which is used to generate prototypes for external unit toplevels in the C backend, by simply remembering all `##core#callunit' nodes as they're encounted during canonicalisation. Split the batch driver's `initforms' list into two separate values, one for import forms (which must be included within the program's wrapper module's body, if one is used) and one for compiler-introduced initialisation forms (which must precede the profiling-related expressions that are inserted into the program when profiling is enabled, since they're responsible for loading the "profiler" unit). Move all "forms" bindings together in the `let' that introduces them. Simplify `##sys#process-require' so that it expects just a library name and compilation flag as arguments, and returns just a single value. Get rid of the `provided' list, which is no longer necessary. For modules that export syntax in static libraries (where module information is compiled into the libraries themselves), emit code that will load the module's library dependencies *before* the code for runtime evaluation of the module's import forms, that is, "(scheme#eval '(import-syntax ...))". This ensures that static programs do not attempt to dynamically load the named import libraries dynamically, since dlopen(3) et al. are specifically disabled by static compilation. We communicate this situation to `##sys#compiled-module-registration' with a compile mode flag, for consistency with `##sys#process-require'. Only include a library name in emitted import libraries when the program under compilation is actually a library. When it's an executable, it can't be loaded anyway, so including a library name in the import library isn't useful and only complicates the handling of later import forms. Do away with requirement identifiers for modules, which were always a hack. They muddy the runtime's require/provide mechanics, and they were only added to support the corner case where an import library is emitted for a dynamic library that is only accessible under a different name. We can do without this, given the above changes. A different approach to this problem may be developed under ticket #1463. Avoid inserting unnecessary `##core#callunit' forms into the program prelude by using `import-syntax' for all implicitly-available imports (rather than the standard `import' form, which will generate a corresponding `##core#require'). Remove "files" from the list of core units in eval.scm, since it no longer exists. Add "profiler", "scheduler", and "debugger-client", which do exist and should be considered core units. Change the meaning of the "-link" option so that it indicates libraries that should be linked iff they're required, rather than always generating a call to their entrypoints (thus requiring them to be linked unconditionally, as is the case with "-uses"). This option now also needs to be plumbed through to the "chicken" program, which handles the differentiation between static and (potentially) dynamic requirements. There is also some only-very-slightly-related refactoring in this patch: Simplify some of the internal procedures in eval.scm. The `load-library/internal' and `##sys#load-library' procedures can be combined, as can `load-extension/internal' and `load-extension'. Rename the internal version of the `load-library' procedure to `load-unit', since that's really what it does, and use it in the expansion of `##core#require'. Refactor the `##core#module' canonicalisation code for better readability. It was previously unclear what values really needed to be parameterised over what, which these changes hope to clarify. Reconstruct import forms using the literal import prefix symbols in `##sys#decompose-import', to make clear that they are indeed stored on their modules sans aliasing in `module-import-forms' et al. Fix a latent bug in `##sys#decompose-import' where "spec" (a list) was used to issue a warning rather than "name" (a symbol). This led to an invalid argument error arising from `symbol->string'. Reindent two cond arrows that were aligned too far to the right in `##sys#decompose-import'. Drop the `stripu' alias from `process-declaration' and simply call `strip-syntax' directly instead. `stripu' was only used in two places. Mark `##sys#register-profile-info` and `##sys#set-profile-info-vector!' as always `bound-to-procedure' in the declarations that are inserted into profiled programs. --- batch-driver.scm | 144 ++++++++++++++------------- c-platform.scm | 8 +- chicken-syntax.scm | 2 +- core.scm | 214 ++++++++++++++++------------------------- csc.scm | 2 +- eval.scm | 140 ++++++++++++--------------- expand.scm | 2 +- modules.scm | 40 +++++--- support.scm | 1 - tests/compiler-tests.scm | 7 ++ tests/import-library-test2.scm | 2 - tests/runtests.bat | 2 +- tests/runtests.sh | 4 +- tests/scrutiny.expected | 4 +- tests/test-chained-modules.scm | 3 +- 15 files changed, 266 insertions(+), 309 deletions(-) diff --git a/batch-driver.scm b/batch-driver.scm index fc7afb04..0b84a1b5 100644 --- a/batch-driver.scm +++ b/batch-driver.scm @@ -186,29 +186,31 @@ (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 - (if emit-debug-info - '((uses debugger-client)) - '()) - (if explicit-use-flag - '() - `((uses ,@default-units))) - (if (and static-extensions - enable-module-registration - (not dynamic) - (not unit) - (not explicit-use-flag)) - '((uses eval-modules)) - '()))) - ,@(if explicit-use-flag - '() - `((import ,@default-imports))))) - (verbose (memq 'verbose options)) + (let* ((unit (memq 'unit options)) + (dynamic (memq 'dynamic options)) + (forms '()) + (init-forms `((import-for-syntax ,@default-syntax-imports) + (##core#declare + ,@(append + default-declarations + (if emit-debug-info + '((uses debugger-client)) + '()) + (if explicit-use-flag + '() + `((uses ,@default-units))) + (if (and static-extensions + enable-module-registration + (not dynamic) + (not unit) + (not explicit-use-flag)) + '((uses eval-modules)) + '()))))) + (import-forms `((import-for-syntax ,@default-syntax-imports) + ,@(if explicit-use-flag + '() + `((import-syntax ,@default-imports))))) + (cleanup-forms '(((chicken.base#implicit-exit-handler)))) (outfile (cond ((memq 'output-file options) => (lambda (node) (let ((oname (option-arg node))) @@ -224,10 +226,8 @@ (opasses (default-optimization-passes)) (time0 #f) (time-breakdown #f) - (forms '()) (inline-output-file #f) (type-output-file #f) - (cleanup-forms '(((chicken.base#implicit-exit-handler)))) (profile (or (memq 'profile options) (memq 'accumulate-profile options) (memq 'profile-name options))) @@ -345,8 +345,9 @@ (when (memq 'b debugging-chicken) (set! time-breakdown #t)) (when (memq 'raw options) (set! explicit-use-flag #t) - (set! cleanup-forms '()) - (set! initforms '()) ) + (set! init-forms '()) + (set! import-forms '()) + (set! cleanup-forms '())) (when (memq 'no-lambda-info options) (set! emit-closure-info #f) ) (when (memq 'no-compiler-syntax options) @@ -356,7 +357,8 @@ (when (memq 'inline-global options) (set! enable-inline-files #t) (set! inline-locally #t)) - (when verbose + (when (memq 'verbose options) + (set! verbose-mode #t) (set! ##sys#notices-enabled #t)) (when (memq 'strict-types options) (set! strict-variable-types #t) @@ -413,7 +415,6 @@ (keyword-style #:none) (parentheses-synonyms #f) (symbol-escape #f) ) - (set! verbose-mode verbose) (set! ##sys#read-error-with-line-number #t) (set! ##sys#include-pathnames (append (map chop-separator (collect-options 'include-path)) @@ -466,18 +467,23 @@ (set! ##sys#features (cons '#:compiling ##sys#features)) (set! upap (user-post-analysis-pass)) + ;; Mark linked extensions as static requirements. + (let ((units (append-map + (lambda (l) (map string->symbol (string-split l ", "))) + (collect-options 'link)))) + (set! unit-requirements (lset-union/eq? unit-requirements units))) + ;; Handle units added with the "-uses" flag. - (let ((uses (append-map - (lambda (u) (map string->symbol (string-split u ", "))) - (collect-options 'uses)))) - (unless (null? uses) - (set! forms - (cons `(##core#declare (uses . ,uses)) forms)))) + (let ((units (append-map + (lambda (u) (map string->symbol (string-split u ", "))) + (collect-options 'uses)))) + (set! init-forms + (append init-forms `((##core#declare (uses . ,units)))))) ;; Append required extensions to initforms: - (set! initforms + (set! import-forms (append - initforms + import-forms (map (lambda (r) `(import ,(string->symbol r))) (collect-options 'require-extension)))) @@ -509,9 +515,9 @@ "you need to specify -profile-name if using accumulated profiling runs")) (set! emit-profile #t) (set! profiled-procedures 'all) - (set! initforms + (set! init-forms (append - initforms + init-forms default-profiling-declarations (if acc '((set! ##sys#profile-append-mode #t)) @@ -584,18 +590,22 @@ (print-expr "source" '|1| forms) (begin-time) ;; Canonicalize s-expressions - (let* ((exps0 (map (lambda (x) + (let* ((init0 (map canonicalize-expression init-forms)) + (exps0 (map (lambda (x) (fluid-let ((##sys#current-source-filename filename)) (canonicalize-expression x))) - (let ((forms (append initforms forms))) + (let ((forms (append import-forms forms))) (if (not module-name) forms - `((##core#module - ,(string->symbol module-name) () + `((##core#module ,(string->symbol module-name) () ,@forms)))))) + (uses0 (map (lambda (u) + (canonicalize-expression `(##core#require ,u))) + (##sys#fast-reverse uses-declarations))) (exps (append (map (lambda (ic) `(set! ,(cdr ic) ',(car ic))) immutable-constants) - (map (lambda (uu) `(##core#callunit ,uu)) used-units) + init0 + uses0 (if unit-name `((##core#provide ,unit-name)) '()) (if emit-profile (profiling-prelude-exps (and (not unit-name) @@ -614,18 +624,6 @@ (map (lambda (il) (->string (car il))) import-libraries) ", "))) - (and-let* ((reqs (hash-table-ref file-requirements 'dynamic)) - (missing (remove (cut chicken.load#find-dynamic-extension <> #f) reqs))) - (when (null? (lset-intersection/eq? '(eval repl) used-units)) - (notice ; XXX only issued when "-verbose" is used - (sprintf "~A has dynamic requirements but doesn't load (chicken eval): ~A" - (cond (unit-name "unit") (dynamic "library") (else "program")) - (string-intersperse (map ->string reqs) ", ")))) - (when (pair? missing) - (warning - (sprintf "the following extensions are not currently installed: ~A" - (string-intersperse (map ->string missing) ", "))))) - (when (pair? compiler-syntax-statistics) (with-debugging-output 'S @@ -664,10 +662,17 @@ (initialize-analysis-database) ;; collect requirements and load inline files - (let* ((req (concatenate (vector->list file-requirements))) - (mreq (concatenate (map cdr req)))) - (when (debugging 'M "; requirements:") - (pp req)) + (let* ((required-extensions + (remove chicken.load#core-unit? library-requirements)) + (missing-extensions + (remove (lambda (id) + (or (chicken.load#find-static-extension id) + (chicken.load#find-dynamic-extension id #f))) + required-extensions))) + (when (pair? missing-extensions) + (warning + (sprintf "the following extensions are not currently installed: ~A" + (string-intersperse (map ->string missing-extensions) ", ")))) (when enable-inline-files (for-each (lambda (id) @@ -675,7 +680,7 @@ (symbol->string id) '(".inline") #t #f))) (dribble "Loading inline file ~a ..." ifile) (load-inline-file ifile))) - mreq)) + required-extensions)) (let ((ifs (collect-options 'consult-inline-file))) (unless (null? ifs) (set! inline-locally #t) @@ -702,7 +707,7 @@ (load-type-database (make-pathname #f (symbol->string id) "types") enable-specialization)) - mreq) + required-extensions) (begin-time) (set! first-analysis #f) (set! db (analyze 'scrutiny node0)) @@ -831,12 +836,15 @@ (begin-time) ;; generate link file - (when emit-link-file - (dribble "generating link file `~a' ..." emit-link-file) - (with-output-to-file - emit-link-file - (cut pp linked-static-extensions))) - + (when emit-link-file + (let ((objs (filter-map + (lambda (id) + (and-let* ((o (chicken.load#find-static-extension id))) + (pathname-strip-directory o))) + (remove chicken.load#core-unit? library-requirements)))) + (dribble "generating link file `~a' ..." emit-link-file) + (with-output-to-file emit-link-file (cut pp objs)))) + ;; Code generation (let ((out (if outfile (open-output-file outfile) (current-output-port))) ) (dribble "generating `~A' ..." outfile) diff --git a/c-platform.scm b/c-platform.scm index 35a327cc..99cdae1e 100644 --- a/c-platform.scm +++ b/c-platform.scm @@ -72,8 +72,10 @@ (define default-profiling-declarations '((##core#declare (uses profiler) - (bound-to-procedure - ##sys#profile-entry ##sys#profile-exit) ) ) ) + (bound-to-procedure ##sys#profile-entry + ##sys#profile-exit + ##sys#register-profile-info + ##sys#set-profile-info-vector!)))) (define default-units '(library eval)) @@ -105,7 +107,7 @@ setup-mode no-module-registration) ) (define valid-compiler-options-with-argument - '(debug emit-link-file + '(debug link emit-link-file output-file include-path heap-size stack-size unit uses module keyword-style require-extension inline-limit profile-name prelude postlude prologue epilogue nursery extend feature no-feature diff --git a/chicken-syntax.scm b/chicken-syntax.scm index 2451075e..3801ba20 100644 --- a/chicken-syntax.scm +++ b/chicken-syntax.scm @@ -541,7 +541,7 @@ (let-values (((name lib _ _ _ _) (##sys#decompose-import x r c 'import))) (if (not lib) '(##core#undefined) - `(##core#require ,lib ,(module-requirement name))))) + `(##core#require ,lib)))) (cdr x)))))) (##sys#extend-macro-environment diff --git a/core.scm b/core.scm index f0c88f76..c29f3699 100644 --- a/core.scm +++ b/core.scm @@ -138,8 +138,8 @@ ; (##core#foreign-callback-wrapper ' ' '({}) ) ; (##core#define-external-variable []) ; (##core#check ) -; (##core#require-for-syntax ...) -; (##core#require ...) +; (##core#require-for-syntax ) +; (##core#require ) ; (##core#app {}) ; (##core#define-syntax ) ; (##core#define-compiler-syntax ) @@ -276,10 +276,6 @@ initialize-compiler perform-closure-conversion perform-cps-conversion prepare-for-code-generation build-toplevel-procedure - ;; These are both exported for use in eval.scm (which is a bit of - ;; a hack). file-requirements is also used by batch-driver - process-declaration file-requirements - ;; Various ugly global boolean flags that get set by the (batch) driver all-import-libraries bootstrap-mode compiler-syntax-enabled emit-closure-info emit-profile enable-inline-files explicit-use-flag @@ -293,14 +289,16 @@ disable-stack-overflow-checking emit-trace-info external-protos-first external-variables insert-timer-checks no-argc-checks no-global-procedure-checks no-procedure-checks emit-debug-info - linked-static-extensions ;; Other, non-boolean, flags set by (batch) driver profiled-procedures import-libraries inline-max-size extended-bindings standard-bindings + ;; Non-booleans set and read by the (batch) driver + library-requirements unit-requirements uses-declarations + ;; non-booleans set by the (batch) driver, and read by the (c) backend - target-heap-size target-stack-size unit-name used-units provided + target-heap-size target-stack-size unit-name used-units ;; bindings, set by the (c) platform default-extended-bindings default-standard-bindings internal-bindings @@ -360,7 +358,6 @@ (define-constant default-line-number-database-size 997) (define-constant inline-table-size 301) (define-constant constant-table-size 301) -(define-constant file-requirements-size 301) (define-constant default-inline-max-size 20) @@ -429,9 +426,9 @@ (define callback-names '()) (define toplevel-scope #t) (define toplevel-lambda-id #f) -(define file-requirements #f) -(define provided '()) -(define linked-static-extensions '()) +(define library-requirements '()) +(define unit-requirements '()) +(define uses-declarations '()) (define unlikely-variables '(unquote unquote-splicing)) @@ -454,9 +451,6 @@ (set! constant-table (make-vector constant-table-size '())) ) (reset-profile-info-vector-name!) (clear-real-name-table!) - (if file-requirements - (vector-fill! file-requirements '()) - (set! file-requirements (make-vector file-requirements-size '())) ) (clear-foreign-type-table!) ) @@ -584,11 +578,11 @@ ((not (memq x e)) (##sys#alias-global-hook x #f h)) ; only if global (else x)))) - (define (emit-import-lib name il) + (define (emit-import-lib mod name il) (let* ((fname (if all-import-libraries (string-append (symbol->string name) ".import.scm") (cdr il))) - (imps (##sys#compiled-module-registration (##sys#current-module))) + (imps (##sys#compiled-module-registration mod #f)) (oldimps (and (file-exists? fname) (call-with-input-file fname read-expressions)))) @@ -682,12 +676,7 @@ (hide-variable var) var) ] ) ) ) - ((##core#callunit ##core#primitive ##core#undefined) x) - - ((##core#provide) - (let ((id (cadr x))) - (set! provided (lset-adjoin/eq? provided id)) - `(##core#provide ,id))) + ((##core#provide ##core#primitive ##core#undefined) x) ((##core#inline_ref) `(##core#inline_ref @@ -699,24 +688,23 @@ ,(walk (caddr x) e dest ldest h ln #f))) ((##core#require-for-syntax) - (chicken.load#load-extension (cadr x) '() 'require) + (chicken.load#load-extension (cadr x) 'require) '(##core#undefined)) + ((##core#callunit) + (let ((id (cadr x))) + (set! used-units (lset-adjoin/eq? used-units id)) + `(##core#callunit ,id))) + ((##core#require) - (let ((id (cadr x)) - (alternates (cddr x))) - (let-values (((exp type) - (##sys#process-require - id #t - alternates provided - static-extensions - register-static-extension))) - (unless (not type) - (hash-table-update! - file-requirements type - (cut lset-adjoin/eq? <> id) - (cut list id))) - (walk exp e dest ldest h ln #f)))) + (let ((id (cadr x))) + (set! library-requirements (lset-adjoin/eq? library-requirements id)) + (walk (##sys#process-require + id + (if (or (memq id unit-requirements) static-extensions) + 'static + 'dynamic)) + e dest ldest h ln #f))) ((##core#let) (let* ((bindings (cadr x)) @@ -964,90 +952,72 @@ ((##core#module) (let* ((name (strip-syntax (cadr x))) - (lib (or unit-name name)) - (req (module-requirement name)) - (exports - (or (eq? #t (caddr x)) - (map (lambda (exp) - (cond ((symbol? exp) exp) - ((and (pair? exp) - (let loop ((exp exp)) - (or (null? exp) - (and (symbol? (car exp)) - (loop (cdr exp)))))) - exp) - (else - (##sys#syntax-error-hook - 'module - "invalid export syntax" exp name)))) - (strip-syntax (caddr x))))) + (il (or (assq name import-libraries) all-import-libraries)) + (lib (and (not standalone-executable) il (or unit-name name))) + (mod (##sys#register-module + name lib + (or (eq? #t (caddr x)) + (map (lambda (exp) + (cond ((symbol? exp) exp) + ((and (pair? exp) + (let loop ((exp exp)) + (or (null? exp) + (and (symbol? (car exp)) + (loop (cdr exp)))))) + exp) + (else + (##sys#syntax-error-hook + 'module + "invalid export syntax" exp name)))) + (strip-syntax (caddr x)))))) (csyntax compiler-syntax)) (when (##sys#current-module) (##sys#syntax-error-hook 'module "modules may not be nested" name)) - (let-values (((body module-registration) - (parameterize ((##sys#current-module - (##sys#register-module name lib exports)) - (##sys#current-environment '()) - (##sys#macro-environment - ##sys#initial-macro-environment) - (##sys#module-alias-environment - (##sys#module-alias-environment))) - (##sys#with-property-restore - (lambda () - (let loop ((body (cdddr x)) (xs '())) - (cond - ((null? body) + (let ((body (parameterize ((##sys#current-module mod) + (##sys#current-environment '()) + (##sys#macro-environment + ##sys#initial-macro-environment) + (##sys#module-alias-environment + (##sys#module-alias-environment))) + (##sys#with-property-restore + (lambda () + (let loop ((body (cdddr x)) (xs '())) + (if (null? body) (handle-exceptions ex (begin ;; avoid backtrace (print-error-message ex (current-error-port)) (exit 1)) - (##sys#finalize-module (##sys#current-module))) - (cond ((or (assq name import-libraries) all-import-libraries) - => (lambda (il) - (emit-import-lib name il) - ;; Remove from list to avoid error - (when (pair? il) - (set! import-libraries - (delete il import-libraries equal?))) - (values (reverse xs) '()))) - ((not enable-module-registration) - (values (reverse xs) '())) - (else - (values - (reverse xs) - (##sys#compiled-module-registration - (##sys#current-module)))))) - (else + (##sys#finalize-module mod) + (reverse xs)) (loop (cdr body) - (cons (walk - (car body) - e ;? - #f #f h ln #t) ; reset to toplevel! - xs)))))))))) - (let ((body - (canonicalize-begin-body - (append - (parameterize ((##sys#current-module #f) - (##sys#macro-environment - (##sys#meta-macro-environment)) - (##sys#current-environment ; ??? - (##sys#current-meta-environment))) - (map - (lambda (x) - (walk - x - e ;? - #f #f h ln tl?) ) - (cons `(##core#provide ,req) module-registration))) - body)))) - (do ((cs compiler-syntax (cdr cs))) - ((eq? cs csyntax)) - (##sys#put! (caar cs) '##compiler#compiler-syntax (cdar cs))) - (set! compiler-syntax csyntax) - body)))) + (cons (walk (car body) + e #f #f + h ln #t) ; reset to toplevel! + xs))))))))) + (do ((cs compiler-syntax (cdr cs))) + ((eq? cs csyntax) (set! compiler-syntax csyntax)) + (##sys#put! (caar cs) '##compiler#compiler-syntax (cdar cs))) + (when il + (emit-import-lib mod name il) + (when (pair? il) + (set! import-libraries + (delete il import-libraries equal?)))) + (canonicalize-begin-body + (append + (if (or (not enable-module-registration) il) + '() + (parameterize ((##sys#macro-environment + (##sys#meta-macro-environment)) + (##sys#current-environment ; ??? + (##sys#current-meta-environment))) + (map (lambda (x) (walk x e #f #f h ln tl?)) + (##sys#compiled-module-registration + mod + (if static-extensions 'static 'dynamic))))) + body))))) ((##core#loop-lambda) ;XXX is this really needed? (let* ((vars (cadr x)) @@ -1502,7 +1472,6 @@ (syntax-error "invalid declaration" spec) ) ) ) (define (stripa x) ; global aliasing (##sys#globalize x se)) - (define stripu strip-syntax) (define (globalize-all syms) (filter-map (lambda (var) @@ -1520,17 +1489,12 @@ (syntax-error "invalid declaration specification" spec) ) (case (strip-syntax (car spec)) ; no global aliasing ((uses) - (let ((us (lset-difference/eq? (stripu (cdr spec)) used-units))) - (when (pair? us) - (set! provided (append provided us)) - (set! used-units (append used-units us)) - (hash-table-update! - file-requirements 'static - (cut lset-union/eq? us <>) - (lambda () us))))) + (let ((units (strip-syntax (cdr spec)))) + (set! unit-requirements (lset-union/eq? unit-requirements units)) + (set! uses-declarations (lset-union/eq? uses-declarations units)))) ((unit) (check-decl spec 1 1) - (let ((u (stripu (cadr spec)))) + (let ((u (strip-syntax (cadr spec)))) (when (and unit-name (not (eq? unit-name u))) (warning "unit was already given a name (new name is ignored)")) (set! unit-name u) @@ -1764,14 +1728,6 @@ '(##core#undefined) ) ) ) -;;; Register statically linked extension - -(define (register-static-extension id path) - (set! linked-static-extensions - (cons (pathname-strip-directory path) - linked-static-extensions))) - - ;;; Create entry procedure: (define (build-toplevel-procedure node) diff --git a/csc.scm b/csc.scm index c9d7c969..be5fe6bc 100644 --- a/csc.scm +++ b/csc.scm @@ -643,7 +643,7 @@ EOF (set! compile-options (cons "-DC_EMBEDDED" compile-options)) ] [(-link) (check s rest) - (t-options "-uses" (car rest)) + (t-options "-link" (car rest)) (set! linked-extensions (append linked-extensions (string-split (car rest) ", "))) (set! rest (cdr rest))] diff --git a/eval.scm b/eval.scm index a615fa72..dc8043da 100644 --- a/eval.scm +++ b/eval.scm @@ -563,7 +563,6 @@ (if (null? body) (let ((xs (reverse xs))) (##sys#finalize-module (##sys#current-module)) - (##sys#provide (module-requirement name)) (lambda (v) (let loop2 ((xs xs)) (if (null? xs) @@ -589,14 +588,11 @@ (compile `(##sys#provide (##core#quote ,(cadr x))) e #f tf cntr #f)] [(##core#require-for-syntax) - (chicken.load#load-extension (cadr x) '() 'require) + (chicken.load#load-extension (cadr x) #f) (compile '(##core#undefined) e #f tf cntr #f)] [(##core#require) - (let ((id (cadr x)) - (alternates (cddr x))) - (let-values (((exp _) (##sys#process-require id #f alternates))) - (compile exp e #f tf cntr #f)))] + (compile (##sys#process-require (cadr x) #f) e #f tf cntr #f)] [(##core#elaborationtimeonly ##core#elaborationtimetoo) ; <- Note this! (##sys#eval/meta (cadr x)) @@ -910,9 +906,10 @@ (##core#require library))))) (define-constant core-units - '(chicken-syntax chicken-ffi-syntax continuation data-structures eval - expand extras file files internal irregex library lolevel pathname - port posix srfi-4 tcp repl read-syntax)) + '(chicken-syntax chicken-ffi-syntax continuation data-structures + debugger-client eval eval-modules expand extras file internal + irregex library lolevel pathname port posix profiler scheduler + srfi-4 tcp repl read-syntax)) (define-constant cygwin-default-dynamic-load-libraries '("cygchicken-0")) (define-constant macosx-load-library-extension ".dylib") @@ -937,6 +934,10 @@ (define ##sys#load-dynamic-extension default-load-library-extension) +(define (chicken.load#core-unit? id) ; used by batch-driver.scm + (or (memq id core-units) + (assq id core-unit-requirements))) + ; these are actually in unit extras, but that is used by default (define-constant builtin-features @@ -1125,36 +1126,31 @@ (##sys#check-list x) x) ) ) ) -(define load-library/internal - (let ((display display)) - (lambda (uname lib loc) - (let ((libs - (if lib - (##sys#list lib) - (cons (##sys#string-append (##sys#slot uname 1) load-library-extension) - (dynamic-load-libraries)))) - (top - (c-toplevel uname loc))) - (when (load-verbose) - (display "; loading library ") - (display uname) - (display " ...\n") ) - (let loop ((libs libs)) - (cond ((null? libs) - (##sys#error loc "unable to load library" uname _dlerror)) - ((##sys#dload (##sys#make-c-string (##sys#slot libs 0) 'load-library) top)) - (else - (loop (##sys#slot libs 1))))))))) - -(define (##sys#load-library uname #!optional lib loc) - (unless (##sys#provided? uname) - (load-library/internal uname lib loc) - (##core#undefined))) - -(define (load-library uname #!optional lib) - (##sys#check-symbol uname 'load-library) +(define (load-unit unit-name lib loc) + (unless (##sys#provided? unit-name) + (let ((libs + (if lib + (##sys#list lib) + (cons (##sys#string-append (##sys#slot unit-name 1) load-library-extension) + (dynamic-load-libraries)))) + (top + (c-toplevel unit-name loc))) + (when (load-verbose) + (display "; loading library ") + (display unit-name) + (display " ...\n")) + (let loop ((libs libs)) + (cond ((null? libs) + (##sys#error loc "unable to load library" unit-name (or _dlerror "library not found"))) + ((##sys#dload (##sys#make-c-string (##sys#slot libs 0) 'load-library) top) + (##core#undefined)) + (else + (loop (##sys#slot libs 1)))))))) + +(define (load-library unit-name #!optional lib) + (##sys#check-symbol unit-name 'load-library) (unless (not lib) (##sys#check-string lib 'load-library)) - (##sys#load-library uname lib 'load-library)) + (load-unit unit-name lib 'load-library)) (define ##sys#include-forms-from-file (let ((with-input-from-file with-input-from-file) @@ -1266,25 +1262,20 @@ (or (check pa) (loop (##sys#slot paths 1)) ) ) ) ) ) ) )) -(define (load-extension/internal id alternates loc) - (cond ((##sys#provided? id)) - ((any ##sys#provided? alternates)) - ((memq id core-units) - (load-library/internal id #f loc)) +(define (load-extension id loc) + (cond ((##sys#provided? id) (##core#undefined)) + ((memq id core-units) (load-unit id #f loc)) ((find-dynamic-extension id #f) => (lambda (ext) (load/internal ext #f #f #f #f id) - (##sys#provide id))) + (##sys#provide id) + (##core#undefined))) (else (##sys#error loc "cannot load extension" id)))) -(define (chicken.load#load-extension id alternates loc) - (load-extension/internal id alternates loc) - (##core#undefined)) - (define (require . ids) (for-each (cut ##sys#check-symbol <> 'require) ids) - (for-each (cut chicken.load#load-extension <> '() 'require) ids)) + (for-each (cut load-extension <> 'require) ids)) (define (provide . ids) (for-each (cut ##sys#check-symbol <> 'provide) ids) @@ -1299,42 +1290,29 @@ (find-file (##sys#string-append p object-file-extension) (repository-path)))) -;; Export for internal use in csc, modules and batch-driver: -(define chicken.load#find-file find-file) -(define chicken.load#find-static-extension find-static-extension) -(define chicken.load#find-dynamic-extension find-dynamic-extension) - -;; -;; Given a library specification, returns three values: -;; -;; - an expression for loading the library, if required -;; - a requirement type (e.g. 'dynamic) or #f if provided in core -;; -(define (##sys#process-require lib #!optional compiling? (alternates '()) (provided '()) static? mark-static) +;; Do the right thing with a `##core#require' form. +(define (##sys#process-require lib compile-mode) (let ((id (library-id lib))) (cond - ((assq id core-unit-requirements) => - (lambda (x) (values (cdr x) #f))) - ((memq id builtin-features) - (values '(##core#undefined) #f)) - ((memq id provided) - (values '(##core#undefined) #f)) - ((any (cut memq <> provided) alternates) - (values '(##core#undefined) #f)) + ((assq id core-unit-requirements) => cdr) + ((memq id builtin-features) '(##core#undefined)) ((memq id core-units) - (if compiling? - (values `(##core#declare (uses ,id)) #f) - (values `(##sys#load-library (##core#quote ,id)) #f))) - ((and compiling? static? (find-static-extension id)) => - (lambda (path) - (mark-static id path) - (values `(##core#declare (uses ,id)) 'static))) + (if compile-mode + `(##core#callunit ,id) + `(chicken.load#load-unit (##core#quote ,id) #f #f))) + ((eq? compile-mode 'static) + `(##core#callunit ,id)) (else - (values `(chicken.load#load-extension - (##core#quote ,id) - (##core#quote ,alternates) - (##core#quote require)) - 'dynamic))))) + `(chicken.load#load-extension (##core#quote ,id) #f))))) + +;; Export for internal use in the expansion of `##core#require': +(define chicken.load#load-unit load-unit) +(define chicken.load#load-extension load-extension) + +;; Export for internal use in csc, modules and batch-driver: +(define chicken.load#find-file find-file) +(define chicken.load#find-static-extension find-static-extension) +(define chicken.load#find-dynamic-extension find-dynamic-extension) ;;; Find included file: diff --git a/expand.scm b/expand.scm index b2f97d4b..6021efde 100644 --- a/expand.scm +++ b/expand.scm @@ -976,7 +976,7 @@ ##sys#current-environment ##sys#macro-environment #f #f 'import)) (if (not lib) '(##core#undefined) - `(##core#require ,lib ,(module-requirement name))))) + `(##core#require ,lib)))) (cdr x))))))) (##sys#extend-macro-environment diff --git a/modules.scm b/modules.scm index 73e89474..06c6e1dd 100644 --- a/modules.scm +++ b/modules.scm @@ -33,9 +33,9 @@ (disable-interrupts) (fixnum) (not inline ##sys#alias-global-hook) - (hide check-for-redef find-export find-module/import-library - match-functor-argument merge-se module-indirect-exports - module-rename register-undefined)) + (hide check-for-redef compiled-module-dependencies find-export + find-module/import-library match-functor-argument merge-se + module-indirect-exports module-rename register-undefined)) (import scheme chicken.base @@ -304,14 +304,24 @@ ((assq (caar se) rest) (fwd (cdr se) rest)) (else (cons (car se) (fwd (cdr se) rest))))))))) -(define (##sys#compiled-module-registration mod) +(define (compiled-module-dependencies mod) + (let ((libs (filter-map ; extract library names + (lambda (x) (nth-value 1 (##sys#decompose-import x o eq? 'module))) + (module-import-forms mod)))) + (map (lambda (lib) `(##core#require ,lib)) + (delete-duplicates libs eq?)))) + +(define (##sys#compiled-module-registration mod compile-mode) (let ((dlist (module-defined-list mod)) (mname (module-name mod)) (ifs (module-import-forms mod)) (sexports (module-sexports mod)) (mifs (module-meta-import-forms mod))) - `(,@(if (and (pair? ifs) (pair? sexports)) - `((scheme#eval '(import-syntax ,@(strip-syntax ifs)))) + `(,@(if (and (eq? compile-mode 'static) (pair? ifs) (pair? sexports)) + (compiled-module-dependencies mod) + '()) + ,@(if (and (pair? ifs) (pair? sexports)) + `((scheme#eval '(import-syntax ,@(strip-syntax ifs)))) '()) ,@(if (and (pair? mifs) (pair? sexports)) `((import-syntax ,@(strip-syntax mifs))) @@ -614,9 +624,9 @@ (cond ((null? ids) (for-each (lambda (id) - (warn "imported identifier doesn't exist" spec id)) + (warn "imported identifier doesn't exist" name id)) missing) - (values name lib `(,head ,spec ,@imports) v s impi)) + (values name lib `(only ,spec ,@imports) v s impi)) ((assq (car ids) impv) => (lambda (a) (loop (cdr ids) (cons a v) s missing))) @@ -637,15 +647,15 @@ (lambda (id) (warn "excluded identifier doesn't exist" name id)) ids) - (values name lib `(,head ,spec ,@imports) v s impi)) + (values name lib `(except ,spec ,@imports) v s impi)) ((memq (caar imps) ids) => - (lambda (id) - (loop (cdr imps) s (delete (car id) ids eq?)))) + (lambda (id) + (loop (cdr imps) s (delete (car id) ids eq?)))) (else (loop (cdr imps) (cons (car imps) s) ids))))) ((memq (caar impv) ids) => - (lambda (id) - (loop (cdr impv) v (delete (car id) ids eq?)))) + (lambda (id) + (loop (cdr impv) v (delete (car id) ids eq?)))) (else (loop (cdr impv) (cons (car impv) v) ids)))))) ((c %rename head) @@ -660,7 +670,7 @@ (lambda (id) (warn "renamed identifier doesn't exist" name id)) (map car ids)) - (values name lib `(,head ,spec ,@renames) v s impi)) + (values name lib `(rename ,spec ,@renames) v s impi)) ((assq (caar imps) ids) => (lambda (a) (loop (cdr imps) @@ -684,7 +694,7 @@ (##sys#string->symbol (##sys#string-append (tostr prefix) (##sys#symbol->string (car imp)))) (cdr imp))) - (values name lib `(,head ,spec ,prefix) (map rename impv) (map rename imps) impi))) + (values name lib `(prefix ,spec ,prefix) (map rename impv) (map rename imps) impi))) (else (module-imports (strip-syntax x)))))))))))) diff --git a/support.scm b/support.scm index 8d9baac2..fa5f1442 100644 --- a/support.scm +++ b/support.scm @@ -1834,7 +1834,6 @@ Available debugging options: x display information about experimental features D when printing nodes, use node-tree output I show inferred type information for unexported globals - M show syntax-/runtime-requirements N show the real-name mapping table P show expressions after specialization S show applications of compiler syntax diff --git a/tests/compiler-tests.scm b/tests/compiler-tests.scm index b3ab13ed..338ada24 100644 --- a/tests/compiler-tests.scm +++ b/tests/compiler-tests.scm @@ -436,3 +436,10 @@ (let ((v0 ((foreign-lambda* c-string () "C_return(\"str\");"))) (v1 ((foreign-lambda* (const c-string) () "C_return(\"str\");")))) (assert (equal? v0 v1))) + +; libraries are only loaded when entry point is called +(let () + (if #f (require-library (chicken repl))) + (assert (not (##sys#symbol-has-toplevel-binding? 'chicken.repl#repl))) + (if #t (require-library (chicken repl))) + (assert (##sys#symbol-has-toplevel-binding? 'chicken.repl#repl))) diff --git a/tests/import-library-test2.scm b/tests/import-library-test2.scm index fb61aee5..32bba424 100644 --- a/tests/import-library-test2.scm +++ b/tests/import-library-test2.scm @@ -1,5 +1,3 @@ -(require-library import-library-test1) - (module bar (xcase) (import scheme (chicken base) foo) (assert (equal? '(123) (foo))) diff --git a/tests/runtests.bat b/tests/runtests.bat index 100e2f48..5bf3026e 100644 --- a/tests/runtests.bat +++ b/tests/runtests.bat @@ -397,7 +397,7 @@ if errorlevel 1 exit /b 1 if errorlevel 1 exit /b 1 %interpret% -bn test-chained-modules.so if errorlevel 1 exit /b 1 -%interpret% -bn test-chained-modules.so -e "(import m3) (s3)" +%interpret% -bn test-chained-modules.so -e "(import-syntax m3) (s3)" if errorlevel 1 exit /b 1 echo ======================================== module tests (ec) ... diff --git a/tests/runtests.sh b/tests/runtests.sh index 35cd9920..e4a99f1d 100755 --- a/tests/runtests.sh +++ b/tests/runtests.sh @@ -309,7 +309,7 @@ $compile module-tests-compiled.scm ./a.out $compile module-static-eval-compiled.scm ./a.out -$compile -static module-static-eval-compiled.scm +$compile -static -uses lolevel module-static-eval-compiled.scm -debug 2M ./a.out echo "======================================== module tests (chained) ..." @@ -318,7 +318,7 @@ $interpret -bnq test-chained-modules.scm $compile_s test-chained-modules.scm -j m3 $compile_s m3.import.scm $interpret -bn test-chained-modules.so -$interpret -bn test-chained-modules.so -e '(import m3) (s3)' +$interpret -bn test-chained-modules.so -e '(import-syntax m3) (s3)' echo "======================================== module tests (ec) ..." rm -f ec.so ec.import.* diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected index 44afef85..07b6e21e 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 `g19', but received 2 results + expected a single result in `let' binding of `g24', but received 2 results Warning: at toplevel: - in procedure call to `g19', expected a value of type `(procedure () *)' but was given a value of type `fixnum' + in procedure call to `g24', 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: diff --git a/tests/test-chained-modules.scm b/tests/test-chained-modules.scm index c278f3bd..ce1f3be8 100644 --- a/tests/test-chained-modules.scm +++ b/tests/test-chained-modules.scm @@ -17,6 +17,5 @@ (syntax-rules () ((_) (s2))))) -(import m3) +(import-syntax m3) (s3) - -- 2.11.0