[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: Evolution & optimization of the module system
|
From: |
Ludovic Courtès |
|
Subject: |
Re: Evolution & optimization of the module system |
|
Date: |
Mon, 09 Apr 2007 01:24:15 +0200 |
|
User-agent: |
Gnus/5.110006 (No Gnus v0.6) Emacs/21.4 (gnu/linux) |
Hi,
Kevin Ryde <address@hidden> writes:
> One possibility for duplicates would be lazy checking, only check for
> a clash when actually using a symbol. That's sort of the prolog
> theory: don't worry now about what might never come up. I suspect the
> total work would end up greater though.
Attached is a patch that implements lazy duplicate checking.
`process-duplicates' is gone and `module-variable' plays its role when
an imported variable is looked up for the first time. Subsequent
lookups for the same variable result in a "cache hit", i.e., the result
is fetched directly from the "import obarray".
The code is simpler and obviously less memory-hungry than my previous
attempt. This lazy approach is not very R6RS-friendly, though (see my
earlier post on this topic).
I measured around 20% speedups in "pure startup time". The measurements
consist in running a dozen of times a program that just does a few
`use-module's and/or `autoload's and measuring the total user execution
time. Example programs are available there:
http://www.laas.fr/~lcourtes/software/guile/startup.scm
http://www.laas.fr/~lcourtes/software/guile/startup-autoload.scm
These measurements do not account for the overhead introduced in the
variable lookup process, so measurements with actual programs were
needed. The test suite, for instance, runs 30% faster. Other
applications have more moderate improvements.
It is worth noting that the calls to `literal_p ()' in `eval.c' incur
non-negligible overhead since they usually fail, which means that they
have the worst-case execution time for variable lookup.
This is it. Comments?
Thanks,
Ludovic.
--- orig/ice-9/boot-9.scm
+++ mod/ice-9/boot-9.scm
@@ -1100,8 +1100,6 @@
;;;
;;; - duplicates-handlers
;;;
-;;; - duplicates-interface
-;;;
;;; - observers
;;;
;;; - weak-observers
@@ -1173,8 +1171,10 @@
(define module-type
(make-record-type 'module
'(obarray uses binder eval-closure transformer name kind
- duplicates-handlers duplicates-interface
- observers weak-observers observer-id)
+ duplicates-handlers
+ duplicates-interface ;; FIXME: to be removed
+ observers weak-observers observer-id
+ import-obarray)
%print-module))
;; make-module &opt size uses binder
@@ -1190,6 +1190,10 @@
(list-ref args index)
default))
+ (define %default-import-size
+ ;; This should be the size of the pre-module obarray.
+ 500)
+
(if (> (length args) 3)
(error "Too many args to make-module." args))
@@ -1209,8 +1213,9 @@
(let ((module (module-constructor (make-hash-table size)
uses binder #f #f #f #f #f #f
'()
- (make-weak-value-hash-table 31)
- 0)))
+ (make-weak-key-hash-table 31)
+ 0
+ (make-hash-table
%default-import-size))))
;; We can't pass this as an argument to module-constructor,
;; because we need it to close over a pointer to the module
@@ -1240,10 +1245,6 @@
(record-accessor module-type 'duplicates-handlers))
(define set-module-duplicates-handlers!
(record-modifier module-type 'duplicates-handlers))
-(define module-duplicates-interface
- (record-accessor module-type 'duplicates-interface))
-(define set-module-duplicates-interface!
- (record-modifier module-type 'duplicates-interface))
(define module-observers (record-accessor module-type 'observers))
(define set-module-observers! (record-modifier module-type 'observers))
(define module-weak-observers (record-accessor module-type 'weak-observers))
@@ -1251,6 +1252,8 @@
(define set-module-observer-id! (record-modifier module-type 'observer-id))
(define module? (record-predicate module-type))
+(define module-import-obarray (record-accessor module-type 'import-obarray))
+
(define set-module-eval-closure!
(let ((setter (record-modifier module-type 'eval-closure)))
(lambda (module closure)
@@ -1269,11 +1272,10 @@
(set-module-observers! module (cons proc (module-observers module)))
(cons module proc))
-(define (module-observe-weak module proc)
- (let ((id (module-observer-id module)))
- (hash-set! (module-weak-observers module) id proc)
- (set-module-observer-id! module (+ 1 id))
- (cons module id)))
+(define (module-observe-weak module observer-id . proc)
+ (let ((id (if (null? proc) (gensym) observer-id))
+ (proc (if (null? proc) observer-id (car proc))))
+ (hashq-set! (module-weak-observers module) observer-id proc)))
(define (module-unobserve token)
(let ((module (car token))
@@ -1311,7 +1313,11 @@
(define (module-call-observers m)
(for-each (lambda (proc) (proc m)) (module-observers m))
- (hash-fold (lambda (id proc res) (proc m)) #f (module-weak-observers m)))
+
+ ;; We assume that weak observers don't (un)register themselves as they are
+ ;; called since this would preclude proper iteration over the hash table
+ ;; elements.
+ (hash-for-each (lambda (id proc) (proc m)) (module-weak-observers m)))
@@ -1435,26 +1441,8 @@
;;;
;;; If the symbol is not found at all, return #f.
;;;
-(define (module-local-variable m v)
-; (caddr
-; (list m v
- (let ((b (module-obarray-ref (module-obarray m) v)))
- (or (and (variable? b) b)
- (and (module-binder m)
- ((module-binder m) m v #f)))))
-;))
-
-;; module-variable module symbol
-;;
-;; like module-local-variable, except search the uses in the
-;; case V is not found in M.
-;;
-;; NOTE: This function is superseded with C code (see modules.c)
-;;; when using the standard eval closure.
-;;
-(define (module-variable m v)
- (module-search module-local-variable m v))
-
+;;; (This is now written in C, see `modules.c'.)
+;;;
;;; {Mapping modules x symbols --> bindings}
;;;
@@ -1515,19 +1503,10 @@
(module-modified m)
b)))
- ;; No local variable yet, so we need to create a new one. That
- ;; new variable is initialized with the old imported value of V,
- ;; if there is one.
- (let ((imported-var (module-variable m v))
- (local-var (or (and (module-binder m)
- ((module-binder m) m v #t))
- (begin
- (let ((answer (make-undefined-variable)))
- (module-add! m v answer)
- answer)))))
- (if (and imported-var (not (variable-bound? local-var)))
- (variable-set! local-var (variable-ref imported-var)))
- local-var)))
+ ;; Create a new local variable.
+ (let ((local-var (make-undefined-variable)))
+ (module-add! m v local-var)
+ local-var)))
;; module-ensure-local-variable! module symbol
;;
@@ -1696,46 +1675,29 @@
;; Add INTERFACE to the list of interfaces used by MODULE.
;;
(define (module-use! module interface)
- (set-module-uses! module
- (cons interface
- (filter (lambda (m)
- (not (equal? (module-name m)
- (module-name interface))))
- (module-uses module))))
- (module-modified module))
+ (if (not (eq? module interface))
+ (begin
+ ;; Newly used modules must be appended rather than consed, so that
+ ;; `module-variable' traverses the use list starting from the first
+ ;; used module.
+ (set-module-uses! module
+ (append (filter (lambda (m)
+ (not
+ (equal? (module-name m)
+ (module-name interface))))
+ (module-uses module))
+ (list interface)))
+
+ (module-modified module))))
;; MODULE-USE-INTERFACES! module interfaces
;;
;; Same as MODULE-USE! but add multiple interfaces and check for duplicates
;;
(define (module-use-interfaces! module interfaces)
- (let* ((duplicates-handlers? (or (module-duplicates-handlers module)
- (default-duplicate-binding-procedures)))
- (uses (module-uses module)))
- ;; remove duplicates-interface
- (set! uses (delq! (module-duplicates-interface module) uses))
- ;; remove interfaces to be added
- (for-each (lambda (interface)
- (set! uses
- (filter (lambda (m)
- (not (equal? (module-name m)
- (module-name interface))))
- uses)))
- interfaces)
- ;; add interfaces to use list
- (set-module-uses! module uses)
- (for-each (lambda (interface)
- (and duplicates-handlers?
- ;; perform duplicate checking
- (process-duplicates module interface))
- (set! uses (cons interface uses))
- (set-module-uses! module uses))
- interfaces)
- ;; add duplicates interface
- (if (module-duplicates-interface module)
- (set-module-uses! module
- (cons (module-duplicates-interface module) uses)))
- (module-modified module)))
+ (set-module-uses! module
+ (append (module-uses module) interfaces))
+ (module-modified module))
@@ -1861,8 +1823,8 @@
(set-module-public-interface! module interface))))
(if (and (not (memq the-scm-module (module-uses module)))
(not (eq? module the-root-module)))
- (set-module-uses! module
- (append (module-uses module) (list the-scm-module)))))
+ ;; Import the default set of bindings (from the SCM module) in MODULE.
+ (module-use! module the-scm-module)))
;; NOTE: This binding is used in libguile/modules.c.
;;
@@ -1893,6 +1855,7 @@
(define process-define-module #f)
(define process-use-modules #f)
(define module-export! #f)
+(define default-duplicate-binding-procedures #f)
;; This boots the module system. All bindings needed by modules.c
;; must have been defined by now.
@@ -2027,7 +1990,8 @@
(reversed-interfaces '())
(exports '())
(re-exports '())
- (replacements '()))
+ (replacements '())
+ (autoloads '()))
(if (null? kws)
(call-with-deferred-observers
@@ -2035,7 +1999,9 @@
(module-use-interfaces! module (reverse reversed-interfaces))
(module-export! module exports)
(module-replace! module replacements)
- (module-re-export! module re-exports)))
+ (module-re-export! module re-exports)
+ (if (not (null? autoloads))
+ (apply module-autoload! module autoloads))))
(case (car kws)
((#:use-module #:use-syntax)
(or (pair? (cdr kws))
@@ -2055,31 +2021,35 @@
(cons interface reversed-interfaces)
exports
re-exports
- replacements)))
+ replacements
+ autoloads)))
((#:autoload)
(or (and (pair? (cdr kws)) (pair? (cddr kws)))
(unrecognized kws))
(loop (cdddr kws)
- (cons (make-autoload-interface module
- (cadr kws)
- (caddr kws))
- reversed-interfaces)
+ reversed-interfaces
exports
re-exports
- replacements))
+ replacements
+ (let ((name (cadr kws))
+ (bindings (caddr kws)))
+ (cons* name bindings autoloads))))
((#:no-backtrace)
(set-system-module! module #t)
- (loop (cdr kws) reversed-interfaces exports re-exports
replacements))
+ (loop (cdr kws) reversed-interfaces exports re-exports
+ replacements autoloads))
((#:pure)
(purify-module! module)
- (loop (cdr kws) reversed-interfaces exports re-exports
replacements))
+ (loop (cdr kws) reversed-interfaces exports re-exports
+ replacements autoloads))
((#:duplicates)
(if (not (pair? (cdr kws)))
(unrecognized kws))
(set-module-duplicates-handlers!
module
(lookup-duplicates-handlers (cadr kws)))
- (loop (cddr kws) reversed-interfaces exports re-exports
replacements))
+ (loop (cddr kws) reversed-interfaces exports re-exports
+ replacements autoloads))
((#:export #:export-syntax)
(or (pair? (cdr kws))
(unrecognized kws))
@@ -2087,7 +2057,8 @@
reversed-interfaces
(append (cadr kws) exports)
re-exports
- replacements))
+ replacements
+ autoloads))
((#:re-export #:re-export-syntax)
(or (pair? (cdr kws))
(unrecognized kws))
@@ -2095,7 +2066,8 @@
reversed-interfaces
exports
(append (cadr kws) re-exports)
- replacements))
+ replacements
+ autoloads))
((#:replace #:replace-syntax)
(or (pair? (cdr kws))
(unrecognized kws))
@@ -2103,7 +2075,8 @@
reversed-interfaces
exports
re-exports
- (append (cadr kws) replacements)))
+ (append (cadr kws) replacements)
+ autoloads))
(else
(unrecognized kws)))))
(run-hook module-defined-hook module)
@@ -2132,7 +2105,23 @@
(set-car! autoload i)))
(module-local-variable i sym))))))
(module-constructor (make-hash-table 0) '() b #f #f name 'autoload #f #f
- '() (make-weak-value-hash-table 31) 0)))
+ '() (make-weak-value-hash-table 31) 0 (make-hash-table
0))))
+
+(define (module-autoload! module . args)
+ "Have @var{module} automatically load the module named @var{name} when one
+of the symbols listed in @var{bindings} is looked up."
+ (let loop ((args args))
+ (cond ((null? args)
+ #t)
+ ((null? (cdr args))
+ (error "invalid name+binding autoload list" args))
+ (else
+ (let ((name (car args))
+ (bindings (cadr args)))
+ (module-use! module (make-autoload-interface module
+ name bindings))
+ (loop (cddr args)))))))
+
;;; {Compiled module}
@@ -3133,57 +3122,6 @@
(lookup-duplicates-handlers handler-names))
handler-names)))
-(define (make-duplicates-interface)
- (let ((m (make-module)))
- (set-module-kind! m 'custom-interface)
- (set-module-name! m 'duplicates)
- m))
-
-(define (process-duplicates module interface)
- (let* ((duplicates-handlers (or (module-duplicates-handlers module)
- (default-duplicate-binding-procedures)))
- (duplicates-interface (module-duplicates-interface module)))
- (module-for-each
- (lambda (name var)
- (cond ((module-import-interface module name)
- =>
- (lambda (prev-interface)
- (let ((var1 (module-local-variable prev-interface name))
- (var2 (module-local-variable interface name)))
- (if (not (eq? var1 var2))
- (begin
- (if (not duplicates-interface)
- (begin
- (set! duplicates-interface
- (make-duplicates-interface))
- (set-module-duplicates-interface!
- module
- duplicates-interface)))
- (let* ((var (module-local-variable duplicates-interface
- name))
- (val (and var
- (variable-bound? var)
- (variable-ref var))))
- (let loop ((duplicates-handlers duplicates-handlers))
- (cond ((null? duplicates-handlers))
- (((car duplicates-handlers)
- module
- name
- prev-interface
- (and (variable-bound? var1)
- (variable-ref var1))
- interface
- (and (variable-bound? var2)
- (variable-ref var2))
- var
- val)
- =>
- (lambda (var)
- (module-add! duplicates-interface name
var)))
- (else
- (loop (cdr duplicates-handlers)))))))))))))
- interface)))
-
;;; {`cond-expand' for SRFI-0 support.}
@@ -3398,10 +3336,7 @@
'(((ice-9 threads)))
'())))
;; load debugger on demand
- (module-use! guile-user-module
- (make-autoload-interface guile-user-module
- '(ice-9 debugger) '(debug)))
-
+ (module-autoload! guile-user-module '(ice-9 debugger) '(debug))
;; Note: SIGFPE, SIGSEGV and SIGBUS are actually "query-only" (see
;; scmsigs.c scm_sigaction_for_thread), so the handlers setup here have
@@ -3475,6 +3410,7 @@
(begin-deprecated
(primitive-load-path "ice-9/deprecated.scm"))
+
;;; Place the user in the guile-user module.
--- orig/libguile/modules.c
+++ mod/libguile/modules.c
@@ -162,12 +162,8 @@
static SCM module_export_x_var;
-
-/*
- TODO: should export this function? --hwn.
- */
-static SCM
-scm_export (SCM module, SCM namelist)
+SCM
+scm_module_export (SCM module, SCM namelist)
{
return scm_call_2 (SCM_VARIABLE_REF (module_export_x_var),
module, namelist);
@@ -203,7 +199,7 @@
tail = SCM_CDRLOC (*tail);
}
va_end (ap);
- scm_export (scm_current_module(), names);
+ scm_module_export (scm_current_module (), names);
}
}
@@ -278,42 +274,220 @@
* release.
*/
-static SCM module_make_local_var_x_var;
+/* The `module-make-local-var!' variable. */
+static SCM module_make_local_var_x_var = SCM_UNSPECIFIED;
-static SCM
-module_variable (SCM module, SCM sym)
+/* The `default-duplicate-binding-procedures' variable. */
+static SCM default_duplicate_binding_procedures_var = SCM_UNSPECIFIED;
+
+/* Return the list of default duplicate binding handlers (procedures). */
+static inline SCM
+default_duplicate_binding_handlers (void)
+{
+ SCM get_handlers;
+
+ get_handlers = SCM_VARIABLE_REF (default_duplicate_binding_procedures_var);
+
+ return (scm_call_0 (get_handlers));
+}
+
+/* Resolve the import of SYM in MODULE, where SYM is currently provided by
+ both IFACE1 as VAR1 and IFACE2 as VAR2. Return the variable chosen by the
+ duplicate binding handlers or `#f'. */
+static inline SCM
+resolve_duplicate_binding (SCM module, SCM sym,
+ SCM iface1, SCM var1,
+ SCM iface2, SCM var2)
+{
+ SCM result = SCM_BOOL_F;
+
+ if (!scm_is_eq (var1, var2))
+ {
+ SCM val1, val2;
+ SCM handlers, h, handler_args;
+
+ val1 = SCM_VARIABLE_REF (var1);
+ val2 = SCM_VARIABLE_REF (var2);
+
+ val1 = (val1 == SCM_UNSPECIFIED) ? SCM_BOOL_F : val1;
+ val2 = (val2 == SCM_UNSPECIFIED) ? SCM_BOOL_F : val2;
+
+ handlers = SCM_MODULE_DUPLICATE_HANDLERS (module);
+ if (scm_is_false (handlers))
+ handlers = default_duplicate_binding_handlers ();
+
+ handler_args = scm_list_n (module, sym,
+ iface1, val1, iface2, val2,
+ var1, val1,
+ SCM_UNDEFINED);
+
+ for (h = handlers;
+ scm_is_pair (h) && scm_is_false (result);
+ h = SCM_CDR (h))
+ {
+ result = scm_apply (SCM_CAR (h), handler_args, SCM_EOL);
+ }
+ }
+ else
+ result = var1;
+
+ return result;
+}
+
+/* Lookup SYM as an imported variable of MODULE. */
+static inline SCM
+module_imported_variable (SCM module, SCM sym)
+{
+#define SCM_BOUND_THING_P scm_is_true
+ register SCM var, imports;
+
+ /* Search cached imported bindings. */
+ imports = SCM_MODULE_IMPORT_OBARRAY (module);
+ var = scm_hashq_ref (imports, sym, SCM_UNDEFINED);
+ if (SCM_BOUND_THING_P (var))
+ return var;
+
+ {
+ /* Search the use list for yet uncached imported bindings, possibly
+ resolving duplicates as needed and caching the result in the import
+ obarray. */
+ SCM uses;
+ SCM found_var = SCM_BOOL_F, found_iface = SCM_BOOL_F;
+
+ for (uses = SCM_MODULE_USES (module);
+ scm_is_pair (uses);
+ uses = SCM_CDR (uses))
+ {
+ SCM iface;
+
+ iface = SCM_CAR (uses);
+ var = scm_module_variable (iface, sym);
+
+ if (SCM_BOUND_THING_P (var))
+ {
+ if (SCM_BOUND_THING_P (found_var))
+ {
+ /* SYM is a duplicate binding (imported more than once) so we
+ need to resolve it. */
+ found_var = resolve_duplicate_binding (module, sym,
+ found_iface, found_var,
+ iface, var);
+ if (scm_is_eq (found_var, var))
+ found_iface = iface;
+ }
+ else
+ /* Keep track of the variable we found and check for other
+ occurences of SYM in the use list. */
+ found_var = var, found_iface = iface;
+ }
+ }
+
+ if (SCM_BOUND_THING_P (found_var))
+ {
+ /* Save the lookup result for future reference. */
+ (void) scm_hashq_set_x (imports, sym, found_var);
+ return found_var;
+ }
+ }
+
+ return SCM_BOOL_F;
+#undef SCM_BOUND_THING_P
+}
+
+SCM_DEFINE (scm_module_local_variable, "module-local-variable", 2, 0, 0,
+ (SCM module, SCM sym),
+ "Return the variable bound to @var{sym} in @var{module}. Return "
+ "@code{#f} is @var{sym} is not bound locally in @var{module}.")
+#define FUNC_NAME s_scm_module_local_variable
{
#define SCM_BOUND_THING_P(b) \
(scm_is_true (b))
+ register SCM b;
+
+ /* SCM_MODULE_TAG is not initialized yet when `boot-9.scm' is being
+ evaluated. */
+ if (scm_module_system_booted_p)
+ SCM_VALIDATE_MODULE (1, module);
+
+ SCM_VALIDATE_SYMBOL (2, sym);
+
+
/* 1. Check module obarray */
- SCM b = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym, SCM_UNDEFINED);
+ b = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym, SCM_UNDEFINED);
if (SCM_BOUND_THING_P (b))
return b;
+
+ /* 2. Search imported bindings. In order to be consistent with
+ `module-variable', the binder gets called only when no imported binding
+ matches SYM. */
+ b = module_imported_variable (module, sym);
+ if (SCM_BOUND_THING_P (b))
+ return SCM_BOOL_F;
+
{
+ /* 3. Query the custom binder. */
SCM binder = SCM_MODULE_BINDER (module);
+
if (scm_is_true (binder))
- /* 2. Custom binder */
{
b = scm_call_3 (binder, module, sym, SCM_BOOL_F);
if (SCM_BOUND_THING_P (b))
return b;
}
}
+
+ return SCM_BOOL_F;
+
+#undef SCM_BOUND_THING_P
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_module_variable, "module-variable", 2, 0, 0,
+ (SCM module, SCM sym),
+ "Return the variable bound to @var{sym} in @var{module}. This "
+ "may be both a local variable or an imported variable. Return "
+ "@code{#f} is @var{sym} is not bound in @var{module}.")
+#define FUNC_NAME s_scm_module_variable
+{
+#define SCM_BOUND_THING_P(b) \
+ (scm_is_true (b))
+
+ register SCM var;
+
+ if (scm_module_system_booted_p)
+ SCM_VALIDATE_MODULE (1, module);
+
+ SCM_VALIDATE_SYMBOL (2, sym);
+
+ /* 1. Check module obarray */
+ var = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym, SCM_UNDEFINED);
+ if (SCM_BOUND_THING_P (var))
+ return var;
+
+ /* 2. Search among the imported variables. */
+ var = module_imported_variable (module, sym);
+ if (SCM_BOUND_THING_P (var))
+ return var;
+
{
- /* 3. Search the use list */
- SCM uses = SCM_MODULE_USES (module);
- while (scm_is_pair (uses))
+ /* 3. Query the custom binder. */
+ SCM binder;
+
+ binder = SCM_MODULE_BINDER (module);
+ if (scm_is_true (binder))
{
- b = module_variable (SCM_CAR (uses), sym);
- if (SCM_BOUND_THING_P (b))
- return b;
- uses = SCM_CDR (uses);
+ var = scm_call_3 (binder, module, sym, SCM_BOOL_F);
+ if (SCM_BOUND_THING_P (var))
+ return var;
}
- return SCM_BOOL_F;
}
+
+ return SCM_BOOL_F;
+
#undef SCM_BOUND_THING_P
}
+#undef FUNC_NAME
scm_t_bits scm_tc16_eval_closure;
@@ -335,7 +509,7 @@
module, sym);
}
else
- return module_variable (module, sym);
+ return scm_module_variable (module, sym);
}
SCM_DEFINE (scm_standard_eval_closure, "standard-eval-closure", 1, 0, 0,
@@ -398,38 +572,44 @@
SCM_DEFINE (scm_module_import_interface, "module-import-interface", 2, 0, 0,
(SCM module, SCM sym),
- "")
+ "Return the module or interface from which @var{sym} is imported "
+ "in @var{module}. If @var{sym} is not imported (i.e., it is not "
+ "defined in @var{module} or it is a module-local binding instead "
+ "of an imported one), then @code{#f} is returned.")
#define FUNC_NAME s_scm_module_import_interface
{
-#define SCM_BOUND_THING_P(b) (scm_is_true (b))
- SCM uses;
- SCM_VALIDATE_MODULE (SCM_ARG1, module);
- /* Search the use list */
- uses = SCM_MODULE_USES (module);
- while (scm_is_pair (uses))
+ SCM var, result = SCM_BOOL_F;
+
+ SCM_VALIDATE_MODULE (1, module);
+ SCM_VALIDATE_SYMBOL (2, sym);
+
+ var = scm_module_variable (module, sym);
+ if (scm_is_true (var))
{
- SCM _interface = SCM_CAR (uses);
- /* 1. Check module obarray */
- SCM b = scm_hashq_ref (SCM_MODULE_OBARRAY (_interface), sym, SCM_BOOL_F);
- if (SCM_BOUND_THING_P (b))
- return _interface;
- {
- SCM binder = SCM_MODULE_BINDER (_interface);
- if (scm_is_true (binder))
- /* 2. Custom binder */
- {
- b = scm_call_3 (binder, _interface, sym, SCM_BOOL_F);
- if (SCM_BOUND_THING_P (b))
- return _interface;
- }
- }
- /* 3. Search use list recursively. */
- _interface = scm_module_import_interface (_interface, sym);
- if (scm_is_true (_interface))
- return _interface;
- uses = SCM_CDR (uses);
+ /* Look for the module that provides VAR. */
+ SCM local_var;
+
+ local_var = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym,
+ SCM_UNDEFINED);
+ if (scm_is_eq (local_var, var))
+ result = module;
+ else
+ {
+ /* Look for VAR among the used modules. */
+ SCM uses, imported_var;
+
+ for (uses = SCM_MODULE_USES (module);
+ scm_is_pair (uses) && scm_is_false (result);
+ uses = SCM_CDR (uses))
+ {
+ imported_var = scm_module_variable (SCM_CAR (uses), sym);
+ if (scm_is_eq (imported_var, var))
+ result = SCM_CAR (uses);
+ }
+ }
}
- return SCM_BOOL_F;
+
+ return result;
}
#undef FUNC_NAME
@@ -560,9 +740,13 @@
return var;
}
-SCM
-scm_module_reverse_lookup (SCM module, SCM variable)
-#define FUNC_NAME "module-reverse-lookup"
+SCM_DEFINE (scm_module_reverse_lookup, "module-reverse-lookup", 2, 0, 0,
+ (SCM module, SCM variable),
+ "Return the symbol under which @var{variable} is bound in "
+ "@var{module} or @var{#f} if @var{variable} is not visible "
+ "from @var{module}. If @var{module} is @code{#f}, then the "
+ "pre-module obarray is used.")
+#define FUNC_NAME s_scm_module_reverse_lookup
{
SCM obarray;
long i, n;
@@ -594,8 +778,7 @@
}
}
- /* Try the `uses' list.
- */
+ /* Try the `uses' list. */
{
SCM uses = SCM_MODULE_USES (module);
while (scm_is_pair (uses))
@@ -669,6 +852,8 @@
process_use_modules_var = PERM (scm_c_lookup ("process-use-modules"));
module_export_x_var = PERM (scm_c_lookup ("module-export!"));
the_root_module_var = PERM (scm_c_lookup ("the-root-module"));
+ default_duplicate_binding_procedures_var =
+ PERM (scm_c_lookup ("default-duplicate-binding-procedures"));
scm_module_system_booted_p = 1;
}
--- orig/libguile/modules.h
+++ mod/libguile/modules.h
@@ -45,6 +45,8 @@
#define scm_module_index_binder 2
#define scm_module_index_eval_closure 3
#define scm_module_index_transformer 4
+#define scm_module_index_duplicate_handlers 7
+#define scm_module_index_import_obarray 12
#define SCM_MODULE_OBARRAY(module) \
SCM_PACK (SCM_STRUCT_DATA (module) [scm_module_index_obarray])
@@ -56,6 +58,10 @@
SCM_PACK (SCM_STRUCT_DATA (module)[scm_module_index_eval_closure])
#define SCM_MODULE_TRANSFORMER(module) \
SCM_PACK (SCM_STRUCT_DATA (module)[scm_module_index_transformer])
+#define SCM_MODULE_DUPLICATE_HANDLERS(module) \
+ SCM_PACK (SCM_STRUCT_DATA (module)[scm_module_index_duplicate_handlers])
+#define SCM_MODULE_IMPORT_OBARRAY(module) \
+ SCM_PACK (SCM_STRUCT_DATA (module)[scm_module_index_import_obarray])
SCM_API scm_t_bits scm_tc16_eval_closure;
@@ -64,6 +70,8 @@
SCM_API SCM scm_current_module (void);
+SCM_API SCM scm_module_variable (SCM module, SCM sym);
+SCM_API SCM scm_module_local_variable (SCM module, SCM sym);
SCM_API SCM scm_interaction_environment (void);
SCM_API SCM scm_set_current_module (SCM module);
@@ -80,6 +88,7 @@
SCM_API SCM scm_c_module_define (SCM module, const char *name, SCM val);
SCM_API SCM scm_module_lookup (SCM module, SCM symbol);
SCM_API SCM scm_module_define (SCM module, SCM symbol, SCM val);
+SCM_API SCM scm_module_export (SCM module, SCM symbol_list);
SCM_API SCM scm_module_reverse_lookup (SCM module, SCM variable);
SCM_API SCM scm_c_resolve_module (const char *name);
--- orig/test-suite/tests/modules.test
+++ mod/test-suite/tests/modules.test
@@ -1,6 +1,6 @@
;;;; modules.test --- exercise some of guile's module stuff -*- scheme -*-
-;;;; Copyright (C) 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2006, 2007 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -16,10 +16,270 @@
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-(use-modules (test-suite lib))
+(define-module (test-suite test-modules)
+ :use-module (srfi srfi-1)
+ :use-module ((ice-9 streams) ;; for test purposes
+ #:renamer (symbol-prefix-proc 's:))
+ :use-module (test-suite lib))
+
+
+(define (every? . args)
+ (not (not (apply every args))))
+
+
+
+;;;
+;;; Foundations.
+;;;
+
+(with-test-prefix "foundations"
+
+ (pass-if "module-add!"
+ (let ((m (make-module))
+ (value (cons 'x 'y)))
+ (module-add! m 'something (make-variable value))
+ (eq? (module-ref m 'something) value)))
+
+ (pass-if "module-define!"
+ (let ((m (make-module))
+ (value (cons 'x 'y)))
+ (module-define! m 'something value)
+ (eq? (module-ref m 'something) value)))
+
+ (pass-if "module-use!"
+ (let ((m (make-module))
+ (import (make-module)))
+ (module-define! m 'something 'something)
+ (module-define! import 'imported 'imported)
+ (module-use! m import)
+ (and (eq? (module-ref m 'something) 'something)
+ (eq? (module-ref m 'imported) 'imported)
+ (module-local-variable m 'something)
+ (not (module-local-variable m 'imported))
+ #t)))
+
+ (pass-if "module-use! (duplicates local binding)"
+ ;; Imported bindings can't override locale bindings.
+ (let ((m (make-module))
+ (import (make-module)))
+ (module-define! m 'something 'something)
+ (module-define! import 'something 'imported)
+ (module-use! m import)
+ (eq? (module-ref m 'something) 'something)))
+
+ (pass-if "module-locally-bound?"
+ (let ((m (make-module))
+ (import (make-module)))
+ (module-define! m 'something #t)
+ (module-define! import 'imported #t)
+ (module-use! m import)
+ (and (module-locally-bound? m 'something)
+ (not (module-locally-bound? m 'imported)))))
+
+ (pass-if "module-{local-,}variable"
+ (let ((m (make-module))
+ (import (make-module)))
+ (module-define! m 'local #t)
+ (module-define! import 'imported #t)
+ (module-use! m import)
+ (and (module-local-variable m 'local)
+ (not (module-local-variable m 'imported))
+ (eq? (module-variable m 'local)
+ (module-local-variable m 'local))
+ (eq? (module-local-variable import 'imported)
+ (module-variable m 'imported)))))
+
+ (pass-if "module-import-interface"
+ (and (every? (lambda (sym iface)
+ (eq? (module-import-interface (current-module) sym)
+ iface))
+ '(current-module exception:bad-variable every)
+ (cons the-scm-module
+ (map resolve-interface
+ '((test-suite lib) (srfi srfi-1)))))
+
+ ;; For renamed bindings, a custom interface is used so we can't
+ ;; check for equality with `eq?'.
+ (every? (lambda (sym iface)
+ (let ((import
+ (module-import-interface (current-module) sym)))
+ (equal? (module-name import)
+ (module-name iface))))
+ '(s:make-stream s:stream-car s:stream-cdr)
+ (make-list 3 (resolve-interface '(ice-9 streams))))))
+
+ (pass-if "module-reverse-lookup"
+ (let ((mods '((srfi srfi-1) (test-suite lib) (ice-9 streams)))
+ (syms '(every exception:bad-variable make-stream))
+ (locals '(every exception:bad-variable s:make-stream)))
+ (every? (lambda (var sym)
+ (eq? (module-reverse-lookup (current-module) var)
+ sym))
+ (map module-variable
+ (map resolve-interface mods)
+ syms)
+ locals))))
+
+
+
+;;;
+;;; Observers.
+;;;
+
+(with-test-prefix "observers"
+
+ (pass-if "weak observer invoked"
+ (let* ((m (make-module))
+ (invoked 0))
+ (module-observe-weak m (lambda (mod)
+ (if (eq? mod m)
+ (set! invoked (+ invoked 1)))))
+ (module-define! m 'something 2)
+ (module-define! m 'something-else 1)
+ (= invoked 2)))
+
+ (pass-if "all weak observers invoked"
+ (let* ((m (make-module))
+ (observer-count 500)
+ (observer-ids (let loop ((i observer-count)
+ (ids '()))
+ (if (= i 0)
+ ids
+ (loop (- i 1) (cons (make-module) ids)))))
+ (observers-invoked (make-hash-table observer-count)))
+
+ ;; register weak observers
+ (for-each (lambda (id)
+ (module-observe-weak m id
+ (lambda (m)
+ (hashq-set! observers-invoked
+ id #t))))
+ observer-ids)
+
+ ;; invoke them
+ (module-call-observers m)
+
+ ;; make sure all of them were invoked
+ (->bool (every (lambda (id)
+ (hashq-ref observers-invoked id))
+ observer-ids))))
+
+ (pass-if "imported bindings updated"
+ (let ((m (make-module))
+ (imported (make-module)))
+ ;; Beautify them, notably adding them a public interface.
+ (beautify-user-module! m)
+ (beautify-user-module! imported)
+
+ (module-use! m (module-public-interface imported))
+ (module-define! imported 'imported-binding #t)
+
+ ;; At this point, `imported-binding' is local to IMPORTED.
+ (and (not (module-variable m 'imported-binding))
+ (begin
+ ;; Export `imported-binding' from IMPORTED.
+ (module-export! imported '(imported-binding))
+
+ ;; Make sure it is now visible from M.
+ (module-ref m 'imported-binding))))))
+
+
+
+;;;
+;;; Duplicate bindings handling.
+;;;
+
+(with-test-prefix "duplicate bindings"
+
+ (pass-if "simple duplicate handler"
+ ;; Import the same binding twice.
+ (let* ((m (make-module))
+ (import1 (make-module))
+ (import2 (make-module))
+ (handler-invoked? #f)
+ (handler (lambda (module name int1 val1 int2 val2 var val)
+ (set! handler-invoked? #t)
+ ;; Keep the first binding.
+ (or var (module-local-variable int1 name)))))
+
+ (set-module-duplicates-handlers! m (list handler))
+ (module-define! m 'something 'something)
+ (set-module-name! import1 'imported-module-1)
+ (set-module-name! import2 'imported-module-2)
+ (module-define! import1 'imported 'imported-1)
+ (module-define! import2 'imported 'imported-2)
+ (module-use! m import1)
+ (module-use! m import2)
+ (and (eq? (module-ref m 'imported) 'imported-1)
+ handler-invoked?))))
+
+
+;;;
+;;; Lazy binder.
+;;;
+
+(with-test-prefix "lazy binder"
+
+ (pass-if "not invoked"
+ (let ((m (make-module))
+ (invoked? #f))
+ (module-define! m 'something 2)
+ (set-module-binder! m (lambda args (set! invoked? #t) #f))
+ (and (module-ref m 'something)
+ (not invoked?))))
+
+ (pass-if "not invoked (module-add!)"
+ (let ((m (make-module))
+ (invoked? #f))
+ (set-module-binder! m (lambda args (set! invoked? #t) #f))
+ (module-add! m 'something (make-variable 2))
+ (and (module-ref m 'something)
+ (not invoked?))))
+
+ (pass-if "invoked (module-ref)"
+ (let ((m (make-module))
+ (invoked? #f))
+ (set-module-binder! m (lambda args (set! invoked? #t) #f))
+ (false-if-exception (module-ref m 'something))
+ invoked?))
+
+ (pass-if "invoked (module-define!)"
+ (let ((m (make-module))
+ (invoked? #f))
+ (set-module-binder! m (lambda args (set! invoked? #t) #f))
+ (module-define! m 'something 2)
+ (and invoked?
+ (eq? (module-ref m 'something) 2))))
+
+ (pass-if "honored (ref)"
+ (let ((m (make-module))
+ (invoked? #f)
+ (value (cons 'x 'y)))
+ (set-module-binder! m
+ (lambda (mod sym define?)
+ (set! invoked? #t)
+ (cond ((not (eq? m mod))
+ (error "invalid module" mod))
+ (define?
+ (error "DEFINE? shouldn't be set"))
+ (else
+ (make-variable value)))))
+ (and (eq? (module-ref m 'something) value)
+ invoked?))))
+
+
+
+;;;
+;;; Higher-level features.
+;;;
(with-test-prefix "autoload"
+ (pass-if "module-autoload!"
+ (let ((m (make-module)))
+ (module-autoload! m '(ice-9 q) '(make-q))
+ (not (not (module-ref m 'make-q)))))
+
(pass-if "autoloaded"
(catch #t
(lambda ()