Re: Evolution & optimization of the module system

[ludo@chbouib.org (Ludovic Courtès)]

[-- Attachment #1: Type: text/plain, Size: 1660 bytes --]

Hi,

Kevin Ryde <user42@zip.com.au> 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.



[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Lazy duplicate binding checks --]
[-- Type: text/x-patch, Size: 36069 bytes --]

--- 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)))
 
 \f
 
@@ -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))
 
 \f
 
@@ -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)))
-
 \f
 
 ;;; {`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"))
 
+
 \f
 
 ;;; 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 @@
 \f
 
 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))))
+
+
+\f
+;;;
+;;; 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))))
+
+
+\f
+;;;
+;;; 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))))))
+
+
+\f
+;;;
+;;; 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?))))
+
+\f
+;;;
+;;; 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?))))
+
+
+\f
+;;;
+;;; 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 ()


[-- Attachment #3: Type: text/plain, Size: 143 bytes --]

_______________________________________________
Guile-devel mailing list
Guile-devel@gnu.org
http://lists.gnu.org/mailman/listinfo/guile-devel