mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-17 17:20:29 +02:00
Code Activity

compile @ and @@

Browse source 
* libguile/vm-engine.c (vm_run): Add new error case for resolving @ or @@
  references, but there is no such module. Possible if
  module-public-interface returns #f.

* libguile/vm-i-loader.c (link-now): Allow the stack arg to be a sym, as
  before, or a list, indicating an absolute reference. Could be two
  separate instructions, but I'm lazy.

* libguile/vm-i-system.c (late-variable-ref, late-variable-set): As in
  link-now, allow the lazy reference to be a list, for @ and @@.

* module/language/scheme/translate.scm (custom-transformer-table):
  Compile @ and @@, and set! forms for both of them. This will ease the
  non-hygienic pain for exported macros.

* module/system/il/compile.scm (make-glil-var): Translate public and
  private module variable references into glil-module variables.

* module/system/il/ghil.scm (ghil-var-at-module!): New function, resolves
  a variable for @ or @@.

* module/system/il/glil.scm (<glil-module>): Revival of <glil-module>,
  this time with the semantics that it really links to a particular
  module.

* module/system/vm/assemble.scm (<vlink-now>, <vlink-later>): Redefine as
  taking a "key" as the argument, which may be a sym or a list; see the
  notes on link-now for more details.
  (codegen): Compile <glil-module> appropriately. Some duplication here,
  probably could use some cleanup later.
This commit is contained in:
Andy Wingo 2008-09-30 00:31:17 +02:00
parent a1122f8cba
commit fd3585753a
8 changed files with 164 additions and 31 deletions
Download patch file Download diff file Expand all files Collapse all files

4
libguile/vm-engine.c
View file

@ -182,6 +182,10 @@ vm_run (SCM vm, SCM program, SCM args)
err_args = SCM_EOL;
goto vm_error;
vm_error_no_such_module:
err_msg = scm_from_locale_string ("VM: No such module: ~A");
goto vm_error;
#if VM_CHECK_IP
vm_error_invalid_address:
err_msg = scm_from_locale_string ("VM: Invalid program address");

28
libguile/vm-i-loader.c
View file

@ -165,10 +165,32 @@ VM_DEFINE_LOADER (load_program, "load-program")
VM_DEFINE_INSTRUCTION (link_now, "link-now", 0, 1, 1)
{
SCM sym;
POP (sym);
SCM what;
POP (what);
SYNC_REGISTER ();
PUSH (scm_lookup (sym)); /* might longjmp */
if (SCM_LIKELY (SCM_SYMBOLP (what)))
{
PUSH (scm_lookup (what)); /* might longjmp */
}
else
{
SCM mod;
/* compilation of @ or @@
`what' is a three-element list: (MODNAME SYM INTERFACE?)
INTERFACE? is #t if we compiled @ or #f if we compiled @@
*/
mod = scm_resolve_module (SCM_CAR (what));
if (scm_is_true (SCM_CADDR (what)))
mod = scm_module_public_interface (mod);
if (SCM_FALSEP (mod))
{
err_args = SCM_LIST1 (SCM_CAR (what));
goto vm_error_no_such_module;
}
/* might longjmp */
PUSH (scm_module_lookup (mod, SCM_CADR (what)));
}
NEXT;
}

76
libguile/vm-i-system.c
View file

@ -285,33 +285,51 @@ VM_DEFINE_INSTRUCTION (variable_ref, "variable-ref", 0, 0, 1)
VM_DEFINE_INSTRUCTION (late_variable_ref, "late-variable-ref", 1, 0, 1)
{
unsigned objnum = FETCH ();
SCM sym_or_var;
SCM what;
CHECK_OBJECT (objnum);
sym_or_var = OBJECT_REF (objnum);
what = OBJECT_REF (objnum);
if (!SCM_VARIABLEP (sym_or_var))
if (!SCM_VARIABLEP (what))
{
SYNC_REGISTER ();
if (SCM_LIKELY (scm_module_system_booted_p && SCM_NFALSEP (bp->module)))
if (SCM_LIKELY (SCM_SYMBOLP (what)))
{
/* might longjmp */
sym_or_var = scm_module_lookup (bp->module, sym_or_var);
if (SCM_LIKELY (scm_module_system_booted_p
&& scm_is_true (bp->module)))
/* might longjmp */
what = scm_module_lookup (bp->module, what);
else
what = scm_sym2var (what, SCM_BOOL_F, SCM_BOOL_F);
}
else
{
sym_or_var = scm_sym2var (sym_or_var, SCM_BOOL_F, SCM_BOOL_F);
SCM mod;
/* compilation of @ or @@
`what' is a three-element list: (MODNAME SYM INTERFACE?)
INTERFACE? is #t if we compiled @ or #f if we compiled @@
*/
mod = scm_resolve_module (SCM_CAR (what));
if (scm_is_true (SCM_CADDR (what)))
mod = scm_module_public_interface (mod);
if (SCM_FALSEP (mod))
{
err_args = SCM_LIST1 (mod);
goto vm_error_no_such_module;
}
/* might longjmp */
what = scm_module_lookup (mod, SCM_CADR (what));
}
if (!VARIABLE_BOUNDP (sym_or_var))
if (!VARIABLE_BOUNDP (what))
{
err_args = SCM_LIST1 (sym_or_var);
err_args = SCM_LIST1 (what);
goto vm_error_unbound;
}
OBJECT_SET (objnum, sym_or_var);
OBJECT_SET (objnum, what);
}
PUSH (VARIABLE_REF (sym_or_var));
PUSH (VARIABLE_REF (what));
NEXT;
}
@ -349,27 +367,45 @@ VM_DEFINE_INSTRUCTION (variable_set, "variable-set", 0, 1, 0)
VM_DEFINE_INSTRUCTION (late_variable_set, "late-variable-set", 1, 1, 0)
{
unsigned objnum = FETCH ();
SCM sym_or_var;
SCM what;
CHECK_OBJECT (objnum);
sym_or_var = OBJECT_REF (objnum);
what = OBJECT_REF (objnum);
if (!SCM_VARIABLEP (sym_or_var))
if (!SCM_VARIABLEP (what))
{
SYNC_BEFORE_GC ();
if (SCM_LIKELY (scm_module_system_booted_p && SCM_NFALSEP (bp->module)))
if (SCM_LIKELY (SCM_SYMBOLP (what)))
{
/* might longjmp */
sym_or_var = scm_module_lookup (bp->module, sym_or_var);
if (SCM_LIKELY (scm_module_system_booted_p
&& scm_is_true (bp->module)))
/* might longjmp */
what = scm_module_lookup (bp->module, what);
else
what = scm_sym2var (what, SCM_BOOL_F, SCM_BOOL_F);
}
else
{
sym_or_var = scm_sym2var (sym_or_var, SCM_BOOL_F, SCM_BOOL_F);
SCM mod;
/* compilation of @ or @@
`what' is a three-element list: (MODNAME SYM INTERFACE?)
INTERFACE? is #t if we compiled @ or #f if we compiled @@
*/
mod = scm_resolve_module (SCM_CAR (what));
if (scm_is_true (SCM_CADDR (what)))
mod = scm_module_public_interface (mod);
if (SCM_FALSEP (mod))
{
err_args = SCM_LIST1 (what);
goto vm_error_no_such_module;
}
/* might longjmp */
what = scm_module_lookup (mod, SCM_CADR (what));
}
OBJECT_SET (objnum, sym_or_var);
OBJECT_SET (objnum, what);
}
VARIABLE_SET (sym_or_var, *sp);
VARIABLE_SET (what, *sp);
DROP ();
NEXT;
}

24
module/language/scheme/translate.scm
View file

@ -158,6 +158,22 @@
((,name ,val) (guard (symbol? name))
(make-ghil-set e l (ghil-var-for-set! e name) (retrans val)))
;; FIXME: Would be nice to verify the values of @ and @@ relative
;; to imported modules...
(((@ ,modname ,name) ,val) (guard (symbol? name)
(list? modname)
(and-map symbol? modname)
(not (ghil-var-is-bound? e '@)))
(make-ghil-set e l (ghil-var-at-module! e modname name #t)
(retrans val)))
(((@@ ,modname ,name) ,val) (guard (symbol? name)
(list? modname)
(and-map symbol? modname)
(not (ghil-var-is-bound? e '@@)))
(make-ghil-set e l (ghil-var-at-module! e modname name #f)
(retrans val)))
;; (set! (NAME ARGS...) VAL)
(((,name . ,args) ,val) (guard (symbol? name))
;; -> ((setter NAME) ARGS... VAL)
@ -272,6 +288,14 @@
((,expr)
(retrans `(make-promise (lambda () ,expr)))))
(@
((,modname ,sym)
(make-ghil-ref e l (ghil-var-at-module! e modname sym #t))))
(@@
((,modname ,sym)
(make-ghil-ref e l (ghil-var-at-module! e modname sym #f))))
(eval-case
(,clauses
(retrans

3
module/system/il/compile.scm
View file

@ -124,6 +124,9 @@
(make-glil-external op depth (ghil-var-index var)))))
((toplevel)
(make-glil-toplevel op (ghil-var-name var)))
((public private)
(make-glil-module op (ghil-var-env var) (ghil-var-name var)
(eq? (ghil-var-kind var) 'public)))
(else (error "Unknown kind of variable:" var))))
(define (constant? x)

14
module/system/il/ghil.scm
View file

@ -95,6 +95,7 @@
ghil-env-add!
ghil-var-is-bound? ghil-var-for-ref! ghil-var-for-set! ghil-var-define!
ghil-var-at-module!
call-with-ghil-environment call-with-ghil-bindings))
@ -236,6 +237,19 @@
(else
(loop parent)))))))
(define (ghil-var-at-module! env modname sym interface?)
(let loop ((e env))
(record-case e
((<ghil-toplevel-env> table)
(let ((key (list modname sym interface?)))
(or (assoc-ref table key)
(let ((var (make-ghil-var modname sym
(if interface? 'public 'private))))
(apush! key var (ghil-toplevel-env-table e))
var))))
((<ghil-env> parent table variables)
(loop parent)))))
(define (ghil-var-define! toplevel sym)
(let ((key (cons (module-name (current-module)) sym)))
(or (assoc-ref (ghil-toplevel-env-table toplevel) key)

6
module/system/il/glil.scm
View file

@ -57,6 +57,9 @@
<glil-toplevel> make-glil-toplevel glil-toplevel?
glil-toplevel-op glil-toplevel-name
<glil-module> make-glil-module glil-module?
glil-module-op glil-module-mod glil-module-name glil-module-public?
<glil-label> make-glil-label glil-label?
glil-label-label
@ -87,6 +90,7 @@
(<glil-local> op index)
(<glil-external> op depth index)
(<glil-toplevel> op name)
(<glil-module> op mod name public?)
;; Controls
(<glil-label> label)
(<glil-branch> inst label)
@ -190,6 +194,8 @@
`(,(symbol-append 'external- op) ,depth ,index))
((<glil-toplevel> op name)
`(,(symbol-append 'toplevel- op) ,name))
((<glil-module> op mod name public?)
`(,(symbol-append (if public? 'public 'private) '- op) ,mod ,name))
;; controls
((<glil-label> label) label)
((<glil-branch> inst label) `(,inst ,label))

40
module/system/vm/assemble.scm
View file

@ -42,8 +42,9 @@
(define-record (<vm-asm> venv glil body))
(define-record (<venv> parent nexts closure?))
(define-record (<vlink-now> name))
(define-record (<vlink-later> name))
;; key is either a symbol or the list (MODNAME SYM PUBLIC?)
(define-record (<vlink-now> key))
(define-record (<vlink-later> key))
(define-record (<vdefine> name))
(define-record (<bytespec> vars bytes meta objs closure?))
@ -188,12 +189,12 @@
((ref set)
(cond
(toplevel
(push-object! (make-vlink-now #:name name))
(push-object! (make-vlink-now #:key name))
(push-code! (case op
((ref) '(variable-ref))
((set) '(variable-set)))))
(else
(let* ((var (make-vlink-later #:name name))
(let* ((var (make-vlink-later #:key name))
(i (cond ((object-assoc var object-alist) => cdr)
(else
(let ((i (length object-alist)))
@ -208,6 +209,29 @@
(else
(error "unknown toplevel var kind" op name))))
((<glil-module> op mod name public?)
(let ((key (list mod name public?)))
(case op
((ref set)
(cond
(toplevel
(push-object! (make-vlink-now #:key key))
(push-code! (case op
((ref) '(variable-ref))
((set) '(variable-set)))))
(else
(let* ((var (make-vlink-later #:key key))
(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))))))))
(else
(error "unknown module var kind" op key)))))
((<glil-label> label)
(set! label-alist (assq-set! label-alist label (current-address))))
@ -319,10 +343,10 @@
(if meta (dump! meta))
;; dump bytecode
(push-code! `(load-program ,bytes)))
((<vlink-later> name)
(dump! name))
((<vlink-now> name)
(dump! name)
((<vlink-later> key)
(dump! key))
((<vlink-now> key)
(dump! key)
(push-code! '(link-now)))
((<vdefine> name)
(push-code! `(define ,(symbol->string name))))