mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
bind all module-level variables lazily
comments in ghil-lookup are pertinent. * module/system/il/compile.scm (make-glil-var): Require that ghil vars have environments. Remove the 'unresolved case -- we'll treat all module-level variables as late bound. * module/system/il/ghil.scm (ghil-lookup): Treat all module level vars as late bound. * module/system/vm/assemble.scm: Instead of vlink and vlate-bound, have vlink-now and vlink-later. (codegen): Add a bunch of crap to get the various cases right. (object-assoc, dump-object!): Handle the new cases, remove the old cases. * src/vm_loader.c (link-now, link-later): Change from link and lazy-bind. Include the module in which the link is to be done, so that callers from other modules get the right behavior. * src/vm_system.c (late-variable-ref, late-variable-set): Instead of a sym, the unbound representation is a module name / symbol pair. * testsuite/run-vm-tests.scm (run-vm-tests): Remove some debugging.
This commit is contained in:
Andy Wingo
parent
9cc649b880
commit
6297d22907
6 changed files with 72 additions and 86 deletions
|
|
@ -101,10 +101,8 @@
|
|||
(make-glil-external op depth (ghil-var-index var)))))
|
||||
((module)
|
||||
(let ((env (ghil-var-env var)))
|
||||
(make-glil-module op (and env (ghil-mod-module (ghil-env-mod env)))
|
||||
(make-glil-module op (ghil-mod-module (ghil-env-mod env))
|
||||
(ghil-var-name var))))
|
||||
((unresolved)
|
||||
(make-glil-late-bound op (ghil-var-name var)))
|
||||
(else (error "Unknown kind of variable:" var))))
|
||||
|
||||
(define (codegen ghil)
|
||||
|
|
|
|||
|
|
@ -185,11 +185,6 @@
|
|||
;;; Public interface
|
||||
;;;
|
||||
|
||||
(define (module-lookup module sym)
|
||||
(let ((iface (module-import-interface module sym)))
|
||||
(and iface
|
||||
(make-ghil-env (make-ghil-mod iface)))))
|
||||
|
||||
(define (fix-ghil-mod! mod for-sym)
|
||||
;;; So, these warnings happen for all instances of define-module.
|
||||
;;; Rather than fixing the problem, I'm going to suppress the common
|
||||
|
|
@ -219,13 +214,13 @@
|
|||
(fix-ghil-mod! e sym)
|
||||
(loop e))
|
||||
((assq-ref table sym)) ;; when does this hit?
|
||||
((module-lookup module sym)
|
||||
=> (lambda (found-env)
|
||||
(make-ghil-var found-env sym 'module)))
|
||||
(else
|
||||
;; a free variable that we have not resolved
|
||||
(warn "unresolved variable during compilation:" sym)
|
||||
(let ((var (make-ghil-var #f sym 'unresolved)))
|
||||
;; although we could bind the variable here, in
|
||||
;; practice further toplevel definitions in this
|
||||
;; compilation unit could change how we would resolve
|
||||
;; this binding, so punt and memoize the lookup at
|
||||
;; runtime always.
|
||||
(let ((var (make-ghil-var (make-ghil-env e) sym 'module)))
|
||||
(apush! sym var table)
|
||||
var))))
|
||||
((<ghil-env> mod parent table variables)
|
||||
|
|
|
|||
|
|
@ -43,8 +43,8 @@
|
|||
(define-record (<vm-asm> venv glil body))
|
||||
(define-record (<venv> parent nexts closure?))
|
||||
(define-record (<vmod> id))
|
||||
(define-record (<vlink> module name))
|
||||
(define-record (<vlate-bound> name))
|
||||
(define-record (<vlink-now> module name))
|
||||
(define-record (<vlink-later> module name))
|
||||
(define-record (<vdefine> module name))
|
||||
(define-record (<bytespec> vars bytes meta objs closure?))
|
||||
|
||||
|
|
@ -149,29 +149,28 @@
|
|||
|
||||
((<glil-module> op module name)
|
||||
(case op
|
||||
((ref)
|
||||
(push-object! (make-vlink :module module :name name))
|
||||
(push-code! '(variable-ref)))
|
||||
((set)
|
||||
(push-object! (make-vlink :module module :name name))
|
||||
(push-code! '(variable-set)))
|
||||
((ref set)
|
||||
(cond
|
||||
(toplevel
|
||||
(push-object! (make-vlink-now :module module :name name))
|
||||
(push-code! (case op
|
||||
((ref) '(variable-ref))
|
||||
((set) '(variable-set)))))
|
||||
(else
|
||||
(let* ((var (make-vlink-later :module module :name name))
|
||||
(i (cond ((object-assoc var object-alist) => cdr)
|
||||
(else
|
||||
(let ((i (length object-alist)))
|
||||
(set! object-alist (acons var i object-alist))
|
||||
i)))))
|
||||
(push-code! (case op
|
||||
((ref) `(late-variable-ref ,i))
|
||||
((set) `(late-variable-set ,i))))))))
|
||||
((define)
|
||||
(push-object! (make-vdefine :module module :name name))
|
||||
(push-code! '(variable-set)))))
|
||||
|
||||
((<glil-late-bound> op name)
|
||||
(let* ((var (make-vlate-bound :name name))
|
||||
(i (cond ((object-assoc var object-alist) => cdr)
|
||||
(else
|
||||
(let ((i (length object-alist)))
|
||||
(set! object-alist (acons var i object-alist))
|
||||
i)))))
|
||||
(case op
|
||||
((ref)
|
||||
(push-code! `(late-variable-ref ,i)))
|
||||
((set)
|
||||
(push-code! `(late-variable-set ,i)))
|
||||
(else (error "unknown late bound" op name)))))
|
||||
(push-code! '(variable-set)))
|
||||
(else
|
||||
(error "unknown toplevel var kind" op name))))
|
||||
|
||||
((<glil-label> label)
|
||||
(set! label-alist (assq-set! label-alist label (current-address))))
|
||||
|
|
@ -208,7 +207,8 @@
|
|||
|
||||
(define (object-assoc x alist)
|
||||
(record-case x
|
||||
((<vlink>) (assoc x alist))
|
||||
((<vlink-now>) (assoc x alist))
|
||||
((<vlink-later>) (assoc x alist))
|
||||
(else (assq x alist))))
|
||||
|
||||
(define (stack->bytes stack label-alist)
|
||||
|
|
@ -271,15 +271,17 @@
|
|||
(if meta (dump! meta))
|
||||
;; dump bytecode
|
||||
(push-code! `(load-program ,bytes)))
|
||||
((<vlink> module name)
|
||||
(dump! (and=> module module-name))
|
||||
((<vlink-later> module name)
|
||||
(dump! (module-name module))
|
||||
(dump! name)
|
||||
(push-code! '(link)))
|
||||
(push-code! '(link-later)))
|
||||
((<vlink-now> module name)
|
||||
(dump! (module-name module))
|
||||
(dump! name)
|
||||
(push-code! '(link-now)))
|
||||
((<vdefine> module name)
|
||||
;; FIXME: dump module
|
||||
(push-code! `(define ,(symbol->string name))))
|
||||
((<vlate-bound> name)
|
||||
(push-code! `(late-bind ,(symbol->string name))))
|
||||
((<vmod> id)
|
||||
(push-code! `(load-module ,id)))
|
||||
(else
|
||||
|
|
|
|||
|
|
@ -176,29 +176,21 @@ VM_DEFINE_LOADER (load_program, "load-program")
|
|||
NEXT;
|
||||
}
|
||||
|
||||
/* this seems to be a bit too much processing for one instruction.. */
|
||||
VM_DEFINE_INSTRUCTION (link, "link", 0, 2, 1)
|
||||
VM_DEFINE_INSTRUCTION (link_now, "link-now", 0, 2, 1)
|
||||
{
|
||||
SCM modname, mod, sym;
|
||||
SCM modname, sym;
|
||||
POP (sym);
|
||||
POP (modname);
|
||||
if (SCM_NFALSEP (modname))
|
||||
{
|
||||
mod = scm_resolve_module (modname);
|
||||
|
||||
if (mod != scm_current_module ())
|
||||
{
|
||||
mod = scm_c_module_lookup (mod, "%module-public-interface");
|
||||
if (SCM_FALSEP (mod))
|
||||
SCM_MISC_ERROR ("Could not load module", SCM_LIST1 (modname));
|
||||
mod = SCM_VARIABLE_REF (mod);
|
||||
}
|
||||
|
||||
PUSH (scm_module_lookup (mod, sym));
|
||||
}
|
||||
else
|
||||
PUSH (scm_lookup (sym));
|
||||
PUSH (scm_module_lookup (scm_resolve_module (modname), sym)); /* might longjmp */
|
||||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (link_later, "link-later", 0, 2, 1)
|
||||
{
|
||||
SCM modname, sym;
|
||||
POP (sym);
|
||||
POP (modname);
|
||||
PUSH (scm_cons (modname, sym));
|
||||
NEXT;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -259,23 +259,25 @@ VM_DEFINE_INSTRUCTION (variable_ref, "variable-ref", 0, 0, 1)
|
|||
|
||||
VM_DEFINE_INSTRUCTION (late_variable_ref, "late-variable-ref", 1, 0, 1)
|
||||
{
|
||||
register unsigned objnum = FETCH ();
|
||||
SCM x;
|
||||
unsigned objnum = FETCH ();
|
||||
SCM pair_or_var;
|
||||
CHECK_OBJECT (objnum);
|
||||
x = OBJECT_REF (objnum);
|
||||
pair_or_var = OBJECT_REF (objnum);
|
||||
|
||||
if (!SCM_VARIABLEP (x))
|
||||
if (!SCM_VARIABLEP (pair_or_var))
|
||||
{
|
||||
x = scm_lookup (x); /* might longjmp */
|
||||
OBJECT_SET (objnum, x);
|
||||
if (!VARIABLE_BOUNDP (x))
|
||||
SCM mod = scm_resolve_module (SCM_CAR (pair_or_var));
|
||||
/* module_lookup might longjmp */
|
||||
pair_or_var = scm_module_lookup (mod, SCM_CDR (pair_or_var));
|
||||
OBJECT_SET (objnum, pair_or_var);
|
||||
if (!VARIABLE_BOUNDP (pair_or_var))
|
||||
{
|
||||
err_args = SCM_LIST1 (x);
|
||||
err_args = SCM_LIST1 (pair_or_var);
|
||||
goto vm_error_unbound;
|
||||
}
|
||||
}
|
||||
|
||||
PUSH (VARIABLE_REF (x));
|
||||
PUSH (VARIABLE_REF (pair_or_var));
|
||||
NEXT;
|
||||
}
|
||||
|
||||
|
|
@ -313,23 +315,20 @@ VM_DEFINE_INSTRUCTION (variable_set, "variable-set", 0, 1, 0)
|
|||
|
||||
VM_DEFINE_INSTRUCTION (late_variable_set, "late-variable-set", 1, 1, 0)
|
||||
{
|
||||
register unsigned objnum = FETCH ();
|
||||
SCM x;
|
||||
unsigned objnum = FETCH ();
|
||||
SCM pair_or_var;
|
||||
CHECK_OBJECT (objnum);
|
||||
x = OBJECT_REF (objnum);
|
||||
pair_or_var = OBJECT_REF (objnum);
|
||||
|
||||
if (!SCM_VARIABLEP (x))
|
||||
if (!SCM_VARIABLEP (pair_or_var))
|
||||
{
|
||||
x = scm_lookup (x); /* might longjmp */
|
||||
OBJECT_SET (objnum, x);
|
||||
if (!VARIABLE_BOUNDP (x))
|
||||
{
|
||||
err_args = SCM_LIST1 (x);
|
||||
goto vm_error_unbound;
|
||||
}
|
||||
SCM mod = scm_resolve_module (SCM_CAR (pair_or_var));
|
||||
/* module_lookup might longjmp */
|
||||
pair_or_var = scm_module_lookup (mod, SCM_CDR (pair_or_var));
|
||||
OBJECT_SET (objnum, pair_or_var);
|
||||
}
|
||||
|
||||
VARIABLE_SET (x, *sp);
|
||||
VARIABLE_SET (pair_or_var, *sp);
|
||||
DROP ();
|
||||
NEXT;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -74,9 +74,9 @@ equal in the sense of @var{equal?}."
|
|||
(format #t "running `~a'... " file)
|
||||
(if (catch #t
|
||||
(lambda ()
|
||||
(equal? (pk (compile/run-test-from-file file))
|
||||
(pk (eval (fetch-sexp-from-file file)
|
||||
(interaction-environment)))))
|
||||
(equal? (compile/run-test-from-file file)
|
||||
(eval (fetch-sexp-from-file file)
|
||||
(interaction-environment))))
|
||||
(lambda (key . args)
|
||||
(format #t "[~a/~a] " key args)
|
||||
#f))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue