~ chicken-core (chicken-5) 41a1decf5762c1178a9da2250df39a28badbb736
commit 41a1decf5762c1178a9da2250df39a28badbb736
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Sat May 9 20:15:46 2020 +1200
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Tue Nov 3 18:11:03 2020 +1300
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 until its code path is actually visited. This
resolves a difference in behaviour between dynamically compiled
libraries whose entrypoints are only called when their code path is
visited, and statically-compiled libraries whose entrypoints are
currently hoisted to the start of the program and always called,
regardless of whether or where they're actually used.
Drop the `file-requirements' hash table in favour of two global lists,
`required-libraries' and `linked-libraries', the first of which is a
superset of the second. The `linked-libraries' list includes everything
that should 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).
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).
This is necessary because all libraries now go through the compiler's
logic for `##core#require' nodes, whereas units were previously exempt.
Move all "forms" bindings together in the `let' that introduces them.
Introduce a new `used-libraries' 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, just like before this
change. The list of `used-units', which is used to generate prototypes
for external unit toplevels in the C backend, is constructed by simply
remembering all `##core#callunit' nodes as they're encounted during
canonicalisation.
Because each import form now has the potential to introduce a call to a
unit entrypoint, `##core#callunit' nodes are deduplicated during CPS.
This ensures that only one call to a given unit's entrypoint will be
generated along a given code path.
Simplify `##sys#process-require' so that it expects just a library,
module, and compilation flag as arguments, and returns just a single
value. Get rid of the global `provided' and `linked-static-extensions'
lists, which are no longer necessary.
For modules that export syntax in static libraries (where module
information is compiled into the libraries themselves), generate 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 disabled by static compilation. We communicate this
situation to `##sys#compiled-module-registration' with a compile mode
flag, for consistency with `##sys#process-require'.
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.
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'.
Drop the `stripu' alias from `process-declaration' and simply call
`strip-syntax' directly instead. `stripu' was only used in two places.
Signed-off-by: felix <felix@call-with-current-continuation.org>
diff --git a/batch-driver.scm b/batch-driver.scm
index 206d4089..9e91d916 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -194,8 +194,7 @@
(register-feature! 'chicken-compile-static))
(let* ((dynamic (memq 'dynamic options))
(unit (memq 'unit options))
- (initforms `((import-for-syntax ,@default-syntax-imports)
- (##core#declare
+ (init-forms `((##core#declare
,@(append
default-declarations
(if emit-debug-info
@@ -211,11 +210,12 @@
(or (not compile-module-registration)
(eq? compile-module-registration 'yes)))
'((uses eval-modules))
- '())))
- ,@(if explicit-use-flag
- '()
- `((import ,@default-imports)))))
- (verbose (memq 'verbose options))
+ '())))))
+ (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)))
@@ -227,14 +227,12 @@
(ipath (map chop-separator
(##sys#split-path
(or (get-environment-variable "CHICKEN_INCLUDE_PATH") ""))))
-
(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)))
@@ -352,8 +350,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)
@@ -363,7 +362,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)
@@ -428,7 +428,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))
@@ -486,13 +485,19 @@
(lambda (u) (map string->symbol (string-split u ", ")))
(collect-options 'uses))))
(unless (null? uses)
- (set! forms
- (cons `(##core#declare (uses . ,uses)) forms))))
+ (set! init-forms
+ (append init-forms `((##core#declare (uses . ,uses)))))))
- ;; Append required extensions to initforms:
- (set! initforms
+ ;; Mark linked libraries so they will be compiled as unit dependencies.
+ (let ((link (append-map
+ (lambda (l) (map string->symbol (string-split l ", ")))
+ (collect-options 'link))))
+ (set! linked-libraries (lset-union/eq? linked-libraries link)))
+
+ ;; Append required extensions to imports:
+ (set! import-forms
(append
- initforms
+ import-forms
(map (lambda (r) `(import ,(string->symbol r)))
(collect-options 'require-extension))))
@@ -524,9 +529,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))
@@ -599,18 +604,23 @@
(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) ()
,@forms))))))
+ (uses0 (map (lambda (u)
+ (canonicalize-expression `(##core#require ,u)))
+ (##sys#fast-reverse used-libraries)))
(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)
@@ -629,18 +639,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
@@ -679,10 +677,7 @@
(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 ((extensions (remove chicken.load#core-unit? required-libraries)))
(when enable-inline-files
(for-each
(lambda (id)
@@ -690,7 +685,7 @@
(symbol->string id) '(".inline") #t #f)))
(dribble "Loading inline file ~a ..." ifile)
(load-inline-file ifile)))
- mreq))
+ extensions))
(let ((ifs (collect-options 'consult-inline-file)))
(unless (null? ifs)
(set! inline-locally #t)
@@ -717,7 +712,7 @@
(load-type-database
(make-pathname #f (symbol->string id) "types")
enable-specialization))
- mreq)
+ extensions)
(begin-time)
(set! first-analysis #f)
(set! db (analyze 'scrutiny node0))
@@ -853,12 +848,11 @@
(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 ((exts (remove chicken.load#core-unit? required-libraries)))
+ (dribble "generating link file `~a' ..." emit-link-file)
+ (with-output-to-file emit-link-file (cut pp exts))))
+
;; 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 19a4c97f..ca209b39 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -109,7 +109,7 @@
module-registration 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 c1ade0ab..ef9b7aa6 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 ,name))))
(cdr x))))))
(##sys#extend-macro-environment
diff --git a/core.scm b/core.scm
index 584c3453..1e0c7ab7 100644
--- a/core.scm
+++ b/core.scm
@@ -139,8 +139,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> [<id>])
; (##core#app <exp> {<exp>})
; (##core#define-syntax <symbol> <expr>)
; (##core#define-compiler-syntax <symbol> <expr>)
@@ -291,10 +291,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 preserve-unchanged-import-libraries
bootstrap-mode compiler-syntax-enabled
@@ -309,15 +305,17 @@
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
unroll-limit
extended-bindings standard-bindings
+ ;; Non-booleans set and read by the (batch) driver
+ required-libraries linked-libraries used-libraries
+
;; 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
@@ -377,7 +375,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)
(define-constant default-unroll-limit 1)
@@ -449,9 +446,9 @@
(define callback-names '())
(define toplevel-scope #t)
(define toplevel-lambda-id #f)
-(define file-requirements #f)
-(define provided '())
-(define linked-static-extensions '())
+(define required-libraries '())
+(define linked-libraries '())
+(define used-libraries '())
(define unlikely-variables '(unquote unquote-splicing))
@@ -474,9 +471,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!) )
@@ -612,11 +606,11 @@
(get-real-name x)))))
(else x))))
- (define (emit-import-lib name il)
+ (define (emit-import-lib name mod 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))))
@@ -706,12 +700,12 @@
(hide-variable var)
var) ] ) ) )
- ((##core#callunit ##core#primitive ##core#undefined) x)
+ ((##core#provide ##core#primitive ##core#undefined) x)
- ((##core#provide)
- (let ((id (cadr x)))
- (set! provided (lset-adjoin/eq? provided id))
- `(##core#provide ,id)))
+ ((##core#callunit)
+ (let ((unit (cadr x)))
+ (set! used-units (lset-adjoin/eq? used-units unit))
+ `(##core#callunit ,unit)))
((##core#inline_ref)
`(##core#inline_ref
@@ -723,24 +717,19 @@
,(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) #f #f)
'(##core#undefined))
((##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 ((lib (cadr x))
+ (mod (and (pair? (cddr x)) (caddr x))))
+ (set! required-libraries (lset-adjoin/eq? required-libraries lib))
+ (walk (##sys#process-require
+ lib mod
+ (if (or (memq lib linked-libraries) static-extensions)
+ 'static
+ 'dynamic))
+ e dest ldest h ln #f)))
((##core#let)
(let* ((bindings (cadr x))
@@ -1010,49 +999,47 @@
((##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)
- (lambda (id)
- (cond
+ mod
+ (lambda (id)
+ (cond
((assq id foreign-variables)
"a foreign variable")
((hash-table-ref inline-table id)
@@ -1061,50 +1048,38 @@
"a constant")
((##sys#get id '##compiler#type-abbreviation)
"a type abbreviation")
- (else #f)))))
- (let ((il (or (assq name import-libraries) all-import-libraries)))
- (when 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)
- (if (or (eq? compile-module-registration 'yes)
- (and (not il) ; default behaviour
- (not compile-module-registration)))
- (##sys#compiled-module-registration (##sys#current-module))
- '()))))
- (else
+ (else #f))))
+ (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 name mod il)
+ (when (pair? il)
+ (set! import-libraries
+ (delete il import-libraries equal?))))
+ (canonicalize-begin-body
+ (append
+ (list (list '##core#provide (module-requirement name)))
+ (if (or (eq? compile-module-registration 'yes)
+ (and (not il) ; default behaviour
+ (not compile-module-registration)))
+ (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))
@@ -1560,7 +1535,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)
@@ -1578,17 +1552,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! used-libraries (lset-union/eq? used-libraries units))
+ (set! linked-libraries (lset-union/eq? linked-libraries 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)
@@ -1830,12 +1799,6 @@
'(##core#undefined) ) ) )
-;;; Register statically linked extension
-
-(define (register-static-extension id)
- (set! linked-static-extensions (cons id linked-static-extensions)))
-
-
;;; Create entry procedure:
(define (build-toplevel-procedure node)
@@ -1954,6 +1917,7 @@
;;; Convert canonicalized node-graph into continuation-passing-style:
(define (perform-cps-conversion node)
+ (let ((called-units '()))
(define (cps-lambda id llist subs k)
(let ([t1 (gensym 'k)])
@@ -2017,7 +1981,12 @@
##core#inline_loc_update ##core#debug-event)
(walk-inline-call class params subs k) )
((##core#call) (walk-call (car subs) (cdr subs) params k))
- ((##core#callunit) (walk-call-unit (first params) k))
+ ((##core#callunit)
+ (let ((unit (first params)))
+ (if (memq unit called-units)
+ (walk (make-node '##core#undefined '() '()) k)
+ (fluid-let ((called-units (cons unit called-units)))
+ (walk-call-unit unit k)))))
((##core#the ##core#the/result)
;; remove "the" nodes, as they are not used after scrutiny
(walk (car subs) k))
@@ -2080,7 +2049,7 @@
##core#inline_loc_ref ##core#inline_loc_update))
(every atomic? (node-subexpressions n)) ) ) ) )
- (walk node values) )
+ (walk node values)))
;;; Perform source-code analysis:
diff --git a/csc.scm b/csc.scm
index 01cfd04f..35129870 100644
--- a/csc.scm
+++ b/csc.scm
@@ -673,7 +673,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 344660dd..504985d1 100644
--- a/eval.scm
+++ b/eval.scm
@@ -591,14 +591,13 @@
(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 #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)))]
+ (let ((lib (cadr x))
+ (mod (and (pair? (cddr x)) (caddr x))))
+ (compile (##sys#process-require lib mod #f) e #f tf cntr #f))]
[(##core#elaborationtimeonly ##core#elaborationtimetoo) ; <- Note this!
(##sys#eval/meta (cadr x))
@@ -934,6 +933,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
@@ -1122,36 +1125,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)
@@ -1208,25 +1206,29 @@
(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))
- ((find-dynamic-extension id #f) =>
- (lambda (ext)
- (load/internal ext #f #f #f #f id)
- (##sys#provide id)))
- (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-inline (extension-loaded? lib mod)
+ (cond ((##sys#provided? lib))
+ ((eq? mod #t)
+ (##sys#provided? (module-requirement lib)))
+ ((symbol? mod)
+ (##sys#provided? (module-requirement mod)))
+ (else #f)))
+
+(define (load-extension lib mod loc)
+ (unless (extension-loaded? lib mod)
+ (cond ((memq lib core-units)
+ (load-unit lib #f loc))
+ ((find-dynamic-extension lib #f) =>
+ (lambda (ext)
+ (load/internal ext #f #f #f #f lib)
+ (##sys#provide lib)
+ (##core#undefined)))
+ (else
+ (##sys#error loc "cannot load extension" lib)))))
(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 <> #f 'require) ids))
(define (provide . ids)
(for-each (cut ##sys#check-symbol <> 'provide) ids)
@@ -1236,40 +1238,32 @@
(for-each (cut ##sys#check-symbol <> 'provided?) ids)
(every ##sys#provided? ids))
+;; 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-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)
- (let ((id (library-id lib)))
+;; Do the right thing with a `##core#require' form.
+(define (##sys#process-require lib mod compile-mode)
+ (let ((mod (or (eq? lib mod) mod)))
(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))
- ((memq id core-units)
- (if compiling?
- (values `(##core#declare (uses ,id)) #f)
- (values `(##sys#load-library (##core#quote ,id)) #f)))
- ((and compiling? static?)
- (mark-static id)
- (values `(##core#declare (uses ,id)) 'static))
+ ((assq lib core-unit-requirements) => cdr)
+ ((memq lib builtin-features) '(##core#undefined))
+ ((memq lib core-units)
+ (if compile-mode
+ `(##core#callunit ,lib)
+ `(chicken.load#load-unit (##core#quote ,lib)
+ (##core#quote #f)
+ (##core#quote #f))))
+ ((eq? compile-mode 'static)
+ `(##core#callunit ,lib))
(else
- (values `(chicken.load#load-extension
- (##core#quote ,id)
- (##core#quote ,alternates)
- (##core#quote require))
- 'dynamic)))))
+ `(chicken.load#load-extension (##core#quote ,lib)
+ (##core#quote ,mod)
+ (##core#quote #f))))))
;;; Find included file:
diff --git a/expand.scm b/expand.scm
index b228be8c..e96882c5 100644
--- a/expand.scm
+++ b/expand.scm
@@ -986,7 +986,7 @@
##sys#current-environment ##sys#macro-environment #f #f 'import))
(if (not lib)
'(##core#undefined)
- `(##core#require ,lib ,(module-requirement name)))))
+ `(##core#require ,lib ,name))))
(cdr x)))))))
(##sys#extend-macro-environment
diff --git a/modules.scm b/modules.scm
index beb52eaf..e70c56df 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
@@ -311,7 +311,14 @@
(else (hash-table-set! seen (caar se) #t)
(lp (cdr se) (cons (car se) se2))))))))))
-(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))
@@ -319,6 +326,9 @@
(mifs (module-meta-import-forms mod)))
`((##sys#with-environment
(lambda ()
+ ,@(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))))
'())
diff --git a/support.scm b/support.scm
index f610349d..a7637bb2 100644
--- a/support.scm
+++ b/support.scm
@@ -1915,7 +1915,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 9cda75ef..7bdfda99 100644
--- a/tests/compiler-tests.scm
+++ b/tests/compiler-tests.scm
@@ -469,3 +469,10 @@
(define fold- (lambda xs (reduce xs (car xs))))
(print (fold- 1 2 3))
+
+; 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/module-static-eval-compiled.scm b/tests/module-static-eval-compiled.scm
index dc6ba9ba..9a7f9a72 100644
--- a/tests/module-static-eval-compiled.scm
+++ b/tests/module-static-eval-compiled.scm
@@ -1,5 +1,6 @@
;;;; test eval in statically compiled code
+(declare (uses lolevel))
(eval '(import (chicken memory representation)))
(assert (eval '(= 1 (block-ref #(1) 0))))
Trap