Hello fellow hackers,
Here is a big, gnarly patch that finishes the work I started in Bergen,
which was to change the way we handle library dependencies so that units
can be loaded conditionally. This was inspired by Peter's changes to
make import expressions lexically-scoped, so that you can write a
program like the following and have it work like you'd expect:
(if (some-condition)
(let () (import (foo)) ...)
(let () (import (bar)) ...))
With Peter's changes, those imports will only affect the syntactic
environments of their respective branches. However, when the libraries
"foo" and "bar" are compiled in (for example when "-static" is used),
they'll both be loaded unconditionally. This patch changes things so
that those libraries will only be loaded when program execution reaches
the corresponding import expression.
I'm sorry about the size of the diff, but I needed to rework quite a bit
of bookkeeping for this to work. I also took the opportunity to clean up
some related bits of code and rip out some provisional things that were
left over from my last round of library loading changes. The commit
message is exhaustive, and probably exhausting too.
Note that I've taken care to preserve the current behaviour of the
"-uses" flag and "(uses ...)" declaration, which "hoist" the named units
to the top level and call them at the start of the program. This makes
the code slightly more complex than it would otherwise be, but I wanted
to preserve the idea that declarations have unit-global effect. The
correct way to link a program with a unit that may *or may not* be
loaded during program execution is to use the "-link" flag.
Another complicating factor was static libraries containing modules that
export syntax, which contain those now-infamous "(eval '(import-syntax
...))" forms. Previously, such `eval' expressions would never cause an
[unsuccessful] attempt to load a dynamic library into a static program
because the imported module's implementing library would have already
been loaded (at the start of the program, thanks to the aforementioned
unit hoisting), indicating that the module is already provided. Now,
however, that library's top level is only entered when the "culpable"
import expression is reached, but the `eval' form will always precede
that point in the program. Luckily, the compiler knows exactly what
libraries need to be loaded before the `eval' expression to avoid this
situation, because it can consult the module's import forms. So, we now
inject the necessary library entrypoints into the program just before
the `eval' (this is the `compiled-module-dependencies' bit of the patch
that does this, in modules.scm). This is only done when necessary, i.e.
for statically compiled modules that export syntax.
I've tested this pretty extensively, but I also know that it's nasty in
terms of sheer size (15 files changed, 266 insertions, 309 deletions),
so please just let me know if you have any questions and I'll do my best
to help clarify what's going on.
Cheers,
Evan
>From 7a4622bfcf1c727c05b6a6bf5cbfb754914d289b Mon Sep 17 00:00:00 2001
From: Evan Hanson <ev...@foldling.org>
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 '<name> <qualifiers> '<type> '({<type>}) <exp>)
; (##core#define-external-variable <name> <type> <bool> [<symbol>])
; (##core#check <exp>)
-; (##core#require-for-syntax <id> ...)
-; (##core#require <id> <id> ...)
+; (##core#require-for-syntax <id>)
+; (##core#require <id>)
; (##core#app <exp> {<exp>})
; (##core#define-syntax <symbol> <expr>)
; (##core#define-compiler-syntax <symbol> <expr>)
@@ -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
_______________________________________________
Chicken-hackers mailing list
Chicken-hackers@nongnu.org
https://lists.nongnu.org/mailman/listinfo/chicken-hackers
