(define (make-modules-in module name)
(if (null? name)
module
- (cond
- ((module-ref module (car name) #f)
- => (lambda (m) (make-modules-in m (cdr name))))
- (else (let ((m (make-module 31)))
- (set-module-kind! m 'directory)
- (set-module-name! m (append (or (module-name module)
- '())
- (list (car name))))
- (module-define! module (car name) m)
- (make-modules-in m (cdr name)))))))
+ (make-modules-in
+ (let* ((var (module-local-variable module (car name)))
+ (val (and var (variable-bound? var) (variable-ref var))))
+ (if (module? val)
+ val
+ (let ((m (make-module 31)))
+ (set-module-kind! m 'directory)
+ (set-module-name! m (append (or (module-name module) '())
+ (list (car name))))
+ (module-define! module (car name) m)
+ m)))
+ (cdr name))))
(define (beautify-user-module! module)
(let ((interface (module-public-interface module)))
(if (equal? name '(guile))
the-root-module
(let ((full-name (append '(%app modules) name)))
- (let ((already (nested-ref the-root-module full-name)))
- (if already
- ;; The module already exists...
- (if (and (or (null? maybe-autoload) (car maybe-autoload))
- (not (module-public-interface already)))
- ;; ...but we are told to load and it doesn't contain source, so
- (begin
- (try-load-module name)
- already)
- ;; simply return it.
- already)
- (begin
- ;; Try to autoload it if we are told so
- (if (or (null? maybe-autoload) (car maybe-autoload))
- (try-load-module name))
- ;; Get/create it.
- (make-modules-in (current-module) full-name)))))))))
+ (let ((already (nested-ref the-root-module full-name))
+ (autoload (or (null? maybe-autoload) (car maybe-autoload))))
+ (cond
+ ((and already (module? already)
+ (or (not autoload) (module-public-interface already)))
+ ;; A hit, a palpable hit.
+ already)
+ (autoload
+ ;; Try to autoload the module, and recurse.
+ (try-load-module name)
+ (resolve-module name #f))
+ (else
+ ;; A module is not bound (but maybe something else is),
+ ;; we're not autoloading -- here's the weird semantics,
+ ;; we create an empty module.
+ (make-modules-in the-root-module full-name)))))))))
;; Cheat. These bindings are needed by modules.c, but we don't want
;; to move their real definition here because that would be unnatural.
args = SCM_CDR (args);
z = SCM_CDR (z);
}
- /* Fewer arguments than specifiers => CAR != ENV */
- if (scm_is_null (SCM_CAR (z)) || scm_is_pair (SCM_CAR (z)))
+ /* Fewer arguments than specifiers => CAR != CLASS */
+ if (!SCM_CLASSP (SCM_CAR (z)))
goto apply_cmethod;
next_method:
hash_value = (hash_value + 1) & mask;
apply_cmethod: /* inputs: z, arg1 */
{
- SCM formals = SCM_CMETHOD_FORMALS (z);
- env = SCM_EXTEND_ENV (formals, arg1, SCM_CMETHOD_ENV (z));
- x = SCM_CMETHOD_BODY (z);
- goto nontoplevel_begin;
+ if (scm_is_pair (z)) {
+ SCM formals = SCM_CMETHOD_FORMALS (z);
+ env = SCM_EXTEND_ENV (formals, arg1, SCM_CMETHOD_ENV (z));
+ x = SCM_CMETHOD_BODY (z);
+ goto nontoplevel_begin;
+ } else {
+ proc = z;
+ PREP_APPLY (proc, arg1);
+ goto apply_proc;
+ }
}
}
}
SCM_KEYWORD (k_setter, "setter");
SCM_KEYWORD (k_specializers, "specializers");
SCM_KEYWORD (k_procedure, "procedure");
+SCM_KEYWORD (k_formals, "formals");
+SCM_KEYWORD (k_body, "body");
+SCM_KEYWORD (k_compile_env, "compile-env");
SCM_KEYWORD (k_dsupers, "dsupers");
SCM_KEYWORD (k_slots, "slots");
SCM_KEYWORD (k_gf, "generic-function");
SCM_EOL,
FUNC_NAME));
SCM_SET_SLOT (z, scm_si_code_table, SCM_EOL);
+ SCM_SET_SLOT (z, scm_si_formals,
+ scm_i_get_keyword (k_formals,
+ args,
+ len - 1,
+ SCM_EOL,
+ FUNC_NAME));
+ SCM_SET_SLOT (z, scm_si_body,
+ scm_i_get_keyword (k_body,
+ args,
+ len - 1,
+ SCM_EOL,
+ FUNC_NAME));
+ SCM_SET_SLOT (z, scm_si_compile_env,
+ scm_i_get_keyword (k_compile_env,
+ args,
+ len - 1,
+ SCM_BOOL_F,
+ FUNC_NAME));
}
else
{
z = SCM_CDR (z);
}
while (j-- && !scm_is_null (ls));
- /* Fewer arguments than specifiers => CAR != ENV */
- if (scm_is_null (SCM_CAR (z)) || scm_is_pair (SCM_CAR (z)))
+ /* Fewer arguments than specifiers => CAR != CLASS */
+ if (!SCM_CLASSP (SCM_CAR (z)))
return z;
next_method:
i = (i + 1) & mask;
scm_apply_generic (SCM gf, SCM args)
{
SCM cmethod = scm_mcache_compute_cmethod (SCM_ENTITY_PROCEDURE (gf), args);
- return scm_eval_body (SCM_CDR (SCM_CMETHOD_CODE (cmethod)),
- SCM_EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (cmethod)),
- args,
- SCM_CMETHOD_ENV (cmethod)));
+ if (scm_is_pair (cmethod))
+ return scm_eval_body (SCM_CDR (SCM_CMETHOD_CODE (cmethod)),
+ SCM_EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (cmethod)),
+ args,
+ SCM_CMETHOD_ENV (cmethod)));
+ else
+ return scm_apply (cmethod, args, SCM_EOL);
}
SCM
:no-backtrace
)
-(define source-formals cadr)
-(define source-body cddr)
-
-(define cmethod-code cdr)
-(define cmethod-environment car)
-
-
;;;
;;; Method entries
;;;
(define (compute-entry-with-cmethod methods types)
(or (code-table-lookup (slot-ref (car methods) 'code-table) types)
(let* ((method (car methods))
- (place-holder (list #f))
- (entry (append types place-holder)))
- ;; In order to handle recursion nicely, put the entry
- ;; into the code-table before compiling the method
- (slot-set! (car methods) 'code-table
- (cons entry (slot-ref (car methods) 'code-table)))
- (let ((cmethod (compile-method methods types)))
- (set-car! place-holder (car cmethod))
- (set-cdr! place-holder (cdr cmethod)))
- (cons entry place-holder))))
+ (cmethod (compile-method methods types))
+ (entry (append types cmethod)))
+ (slot-set! method 'code-table
+ (cons entry (slot-ref method 'code-table)))
+ (cons entry cmethod))))
(define (compute-cmethod methods types)
(cdr (compute-entry-with-cmethod methods types)))
(lambda args
(no-next-method gf (if (null? args) default-args args)))))
-(define (make-make-next-method vcell gf methods types)
+;;;
+;;; Method compilation
+;;;
+
+;;; So, for the reader: there basic idea is that, given that the
+;;; semantics of `next-method' depend on the concrete types being
+;;; dispatched, why not compile a specific procedure to handle each type
+;;; combination that we see at runtime. There are two compilation
+;;; strategies implemented: one for the memoizer, and one for the VM
+;;; compiler.
+;;;
+;;; In theory we can do much better than a bytecode compilation, because
+;;; we know the *exact* types of the arguments. It's ideal for native
+;;; compilation. A task for the future.
+;;;
+;;; I think this whole generic application mess would benefit from a
+;;; strict MOP.
+
+(define (compile-method methods types)
+ (if (slot-ref (car methods) 'compile-env)
+ (compile-method/vm methods types)
+ (compile-method/memoizer methods types)))
+
+(define (make-next-method gf methods types)
+ (if (null? methods)
+ (lambda args (no-next-method gf args))
+ (let ((cmethod (compute-cmethod methods types)))
+ (if (pair? cmethod)
+ ;; if it's a pair, the next-method is interpreted
+ (local-eval (cons 'lambda (cmethod-code cmethod))
+ (cmethod-environment cmethod))
+ ;; otherwise a normal procedure
+ cmethod))))
+
+(define (compile-method/vm methods types)
+ (let* ((program-external (@ (system vm program) program-external))
+ (formals (slot-ref (car methods) 'formals))
+ (body (slot-ref (car methods) 'body)))
+ (cond
+ ((not (next-method? body))
+ ;; just one method to call -- in the future we could compile this
+ ;; based on the types that we see, but for now just return the
+ ;; method procedure (which is vm-compiled already)
+ (method-procedure (car methods)))
+
+ ;; (and-map (lambda (m) (null? (slot-ref m 'compile-env))) methods)
+ ;; many methods, but with no lexical bindings: can inline, in theory.
+ ;;
+ ;; modules complicate this though, the different method bodies only
+ ;; make sense in the contexts of their modules. so while we could
+ ;; expand this to a big letrec, there wouldn't be real inlining.
+
+ (else
+ (let* ((next-method-sym (gensym " next-method"))
+ (method (car methods))
+ (cmethod (compile
+ `(let ((,next-method-sym #f))
+ (lambda ,formals
+ (let ((next-method
+ (lambda args
+ (if (null? args)
+ ,(if (list? formals)
+ `(,next-method-sym ,@formals)
+ `(apply
+ ,next-method-sym
+ ,@(improper->proper formals)))
+ (apply ,next-method-sym args)))))
+ ,@body)))
+ (slot-ref method 'compile-env))))
+ (list-set! (program-external cmethod) 0
+ (make-next-method (method-generic-function method)
+ (cdr methods)
+ types))
+ cmethod)))))
+
+;;;
+;;; Compiling methods for the memoizer
+;;;
+
+(define source-formals cadr)
+(define source-body cddr)
+
+(define cmethod-code cdr)
+(define cmethod-environment car)
+
+(define %tag-body
+ (nested-ref the-root-module '(app modules oop goops %tag-body)))
+
+;;; An exegetical note: the strategy here seems to be to (a) only put in
+;;; next-method if it's referenced in the code; (b) memoize the lookup
+;;; lazily, when `next-method' is first called.
+
+(define (make-make-next-method/memoizer vcell gf methods types)
(lambda default-args
(lambda args
(if (null? methods)
(set-cdr! vcell (make-final-make-next-method method))
(@apply method (if (null? args) default-args args)))))))
-;;;
-;;; Method compilation
-;;;
-
-;;; NOTE: This section is far from finished. It will finally be
-;;; implemented on C level.
-
-(define %tag-body
- (nested-ref the-root-module '(app modules oop goops %tag-body)))
-
-(define (compile-method methods types)
+(define (compile-method/memoizer methods types)
(let* ((proc (method-procedure (car methods)))
;; XXX - procedure-source can not be guaranteed to be
;; reliable or efficient
(if (next-method? body)
(let ((vcell (cons 'goops:make-next-method #f)))
(set-cdr! vcell
- (make-make-next-method
+ (make-make-next-method/memoizer
vcell
(method-generic-function (car methods))
(cdr methods) types))
HCoop / bpt / guile.git / commitdiff