From 79a40cf717e62f45232979d1952f748ca42f8e8f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 16 Aug 2019 09:08:43 +0200 Subject: [PATCH] Add "mod" field to tree-il toplevel ref, set, define Add "mod" field to , , and , indicating the expander's idea of what the current module is when a toplevel variable is accessed or created. This will help in later optimizations. * libguile/expand.c (TOPLEVEL_REF, TOPLEVEL_SET, TOPLEVEL_DEFINE) (expand, expand_define, expand_set_x, convert_assignment): * libguile/expand.h (SCM_EXPANDED_TOPLEVEL_REF_FIELD_NAMES): (SCM_MAKE_EXPANDED_TOPLEVEL_REF, SCM_EXPANDED_TOPLEVEL_SET_FIELD_NAMES): (SCM_MAKE_EXPANDED_TOPLEVEL_SET, SCM_EXPANDED_TOPLEVEL_DEFINE_FIELD_NAMES): (SCM_MAKE_EXPANDED_TOPLEVEL_DEFINE): * module/ice-9/compile-psyntax.scm (translate-literal-syntax-objects): * module/ice-9/psyntax-pp.scm: * module/ice-9/psyntax.scm: * module/language/tree-il.scm: * module/language/tree-il.scm (parse-tree-il, make-tree-il-folder): (pre-post-order): * module/language/tree-il/analyze.scm (goops-toplevel-definition): (macro-use-before-definition-analysis, proc-ref?, format-analysis): * module/language/tree-il/compile-cps.scm (convert): * module/language/tree-il/debug.scm (verify-tree-il): * module/language/tree-il/effects.scm (make-effects-analyzer): * module/language/tree-il/fix-letrec.scm (free-variables): * module/language/tree-il/peval.scm (peval): * test-suite/tests/tree-il.test: Adapt uses. --- libguile/expand.c | 20 ++-- libguile/expand.h | 21 ++-- module/ice-9/compile-psyntax.scm | 3 +- module/ice-9/psyntax-pp.scm | 153 +++++++++++++----------- module/ice-9/psyntax.scm | 39 +++--- module/language/tree-il.scm | 38 +++--- module/language/tree-il/analyze.scm | 16 +-- module/language/tree-il/compile-cps.scm | 8 +- module/language/tree-il/debug.scm | 14 ++- module/language/tree-il/effects.scm | 4 +- module/language/tree-il/fix-letrec.scm | 4 +- module/language/tree-il/peval.scm | 12 +- test-suite/tests/tree-il.test | 6 +- 13 files changed, 182 insertions(+), 156 deletions(-) diff --git a/libguile/expand.c b/libguile/expand.c index dd6eab0fe..11e43c2b9 100644 --- a/libguile/expand.c +++ b/libguile/expand.c @@ -74,12 +74,12 @@ static const char** exp_field_names[SCM_NUM_EXPANDED_TYPES]; SCM_MAKE_EXPANDED_MODULE_REF(src, mod, name, public) #define MODULE_SET(src, mod, name, public, exp) \ SCM_MAKE_EXPANDED_MODULE_SET(src, mod, name, public, exp) -#define TOPLEVEL_REF(src, name) \ - SCM_MAKE_EXPANDED_TOPLEVEL_REF(src, name) -#define TOPLEVEL_SET(src, name, exp) \ - SCM_MAKE_EXPANDED_TOPLEVEL_SET(src, name, exp) -#define TOPLEVEL_DEFINE(src, name, exp) \ - SCM_MAKE_EXPANDED_TOPLEVEL_DEFINE(src, name, exp) +#define TOPLEVEL_REF(src, mod, name) \ + SCM_MAKE_EXPANDED_TOPLEVEL_REF(src, mod, name) +#define TOPLEVEL_SET(src, mod, name, exp) \ + SCM_MAKE_EXPANDED_TOPLEVEL_SET(src, mod, name, exp) +#define TOPLEVEL_DEFINE(src, mod, name, exp) \ + SCM_MAKE_EXPANDED_TOPLEVEL_DEFINE(src, mod, name, exp) #define CONDITIONAL(src, test, consequent, alternate) \ SCM_MAKE_EXPANDED_CONDITIONAL(src, test, consequent, alternate) #define PRIMCALL(src, name, exps) \ @@ -377,7 +377,7 @@ expand (SCM exp, SCM env) if (scm_is_true (gensym)) return LEXICAL_REF (SCM_BOOL_F, exp, gensym); else - return TOPLEVEL_REF (SCM_BOOL_F, exp); + return TOPLEVEL_REF (SCM_BOOL_F, SCM_BOOL_F, exp); } else return CONST_ (SCM_BOOL_F, exp); @@ -552,13 +552,14 @@ expand_define (SCM expr, SCM env) ASSERT_SYNTAX_2 (scm_is_symbol (CAR (variable)), s_bad_variable, variable, expr); return TOPLEVEL_DEFINE (scm_source_properties (expr), + SCM_BOOL_F, CAR (variable), expand_lambda (scm_cons (scm_sym_lambda, scm_cons (CDR (variable), body)), env)); } ASSERT_SYNTAX_2 (scm_is_symbol (variable), s_bad_variable, variable, expr); ASSERT_SYNTAX (scm_ilength (body) == 1, s_expression, expr); - return TOPLEVEL_DEFINE (scm_source_properties (expr), variable, + return TOPLEVEL_DEFINE (scm_source_properties (expr), SCM_BOOL_F, variable, expand (CAR (body), env)); } @@ -1143,6 +1144,7 @@ expand_set_x (SCM expr, SCM env) expand (CADDR (expr), env)); case SCM_EXPANDED_TOPLEVEL_REF: return TOPLEVEL_SET (scm_source_properties (expr), + SCM_EXPANDED_REF (vmem, TOPLEVEL_REF, MOD), SCM_EXPANDED_REF (vmem, TOPLEVEL_REF, NAME), expand (CADDR (expr), env)); case SCM_EXPANDED_MODULE_REF: @@ -1371,12 +1373,14 @@ convert_assignment (SCM exp, SCM assigned) case SCM_EXPANDED_TOPLEVEL_SET: return TOPLEVEL_SET (REF (exp, TOPLEVEL_SET, SRC), + REF (exp, TOPLEVEL_SET, MOD), REF (exp, TOPLEVEL_SET, NAME), convert_assignment (REF (exp, TOPLEVEL_SET, EXP), assigned)); case SCM_EXPANDED_TOPLEVEL_DEFINE: return TOPLEVEL_DEFINE (REF (exp, TOPLEVEL_DEFINE, SRC), + REF (exp, TOPLEVEL_DEFINE, MOD), REF (exp, TOPLEVEL_DEFINE, NAME), convert_assignment (REF (exp, TOPLEVEL_DEFINE, EXP), assigned)); diff --git a/libguile/expand.h b/libguile/expand.h index 86054a5f4..06abd9fbb 100644 --- a/libguile/expand.h +++ b/libguile/expand.h @@ -175,41 +175,44 @@ enum #define SCM_EXPANDED_TOPLEVEL_REF_TYPE_NAME "toplevel-ref" #define SCM_EXPANDED_TOPLEVEL_REF_FIELD_NAMES \ - { "src", "name", } + { "src", "mod", "name", } enum { SCM_EXPANDED_TOPLEVEL_REF_SRC, + SCM_EXPANDED_TOPLEVEL_REF_MOD, SCM_EXPANDED_TOPLEVEL_REF_NAME, SCM_NUM_EXPANDED_TOPLEVEL_REF_FIELDS, }; -#define SCM_MAKE_EXPANDED_TOPLEVEL_REF(src, name) \ - scm_c_make_struct (exp_vtables[SCM_EXPANDED_TOPLEVEL_REF], 0, SCM_NUM_EXPANDED_TOPLEVEL_REF_FIELDS, SCM_UNPACK (src), SCM_UNPACK (name)) +#define SCM_MAKE_EXPANDED_TOPLEVEL_REF(src, mod, name) \ + scm_c_make_struct (exp_vtables[SCM_EXPANDED_TOPLEVEL_REF], 0, SCM_NUM_EXPANDED_TOPLEVEL_REF_FIELDS, SCM_UNPACK (src), SCM_UNPACK (mod), SCM_UNPACK (name)) #define SCM_EXPANDED_TOPLEVEL_SET_TYPE_NAME "toplevel-set" #define SCM_EXPANDED_TOPLEVEL_SET_FIELD_NAMES \ - { "src", "name", "exp", } + { "src", "mod", "name", "exp", } enum { SCM_EXPANDED_TOPLEVEL_SET_SRC, + SCM_EXPANDED_TOPLEVEL_SET_MOD, SCM_EXPANDED_TOPLEVEL_SET_NAME, SCM_EXPANDED_TOPLEVEL_SET_EXP, SCM_NUM_EXPANDED_TOPLEVEL_SET_FIELDS, }; -#define SCM_MAKE_EXPANDED_TOPLEVEL_SET(src, name, exp) \ - scm_c_make_struct (exp_vtables[SCM_EXPANDED_TOPLEVEL_SET], 0, SCM_NUM_EXPANDED_TOPLEVEL_SET_FIELDS, SCM_UNPACK (src), SCM_UNPACK (name), SCM_UNPACK (exp)) +#define SCM_MAKE_EXPANDED_TOPLEVEL_SET(src, mod, name, exp) \ + scm_c_make_struct (exp_vtables[SCM_EXPANDED_TOPLEVEL_SET], 0, SCM_NUM_EXPANDED_TOPLEVEL_SET_FIELDS, SCM_UNPACK (src), SCM_UNPACK (mod), SCM_UNPACK (name), SCM_UNPACK (exp)) #define SCM_EXPANDED_TOPLEVEL_DEFINE_TYPE_NAME "toplevel-define" #define SCM_EXPANDED_TOPLEVEL_DEFINE_FIELD_NAMES \ - { "src", "name", "exp", } + { "src", "mod", "name", "exp", } enum { SCM_EXPANDED_TOPLEVEL_DEFINE_SRC, + SCM_EXPANDED_TOPLEVEL_DEFINE_MOD, SCM_EXPANDED_TOPLEVEL_DEFINE_NAME, SCM_EXPANDED_TOPLEVEL_DEFINE_EXP, SCM_NUM_EXPANDED_TOPLEVEL_DEFINE_FIELDS, }; -#define SCM_MAKE_EXPANDED_TOPLEVEL_DEFINE(src, name, exp) \ - scm_c_make_struct (exp_vtables[SCM_EXPANDED_TOPLEVEL_DEFINE], 0, SCM_NUM_EXPANDED_TOPLEVEL_DEFINE_FIELDS, SCM_UNPACK (src), SCM_UNPACK (name), SCM_UNPACK (exp)) +#define SCM_MAKE_EXPANDED_TOPLEVEL_DEFINE(src, mod, name, exp) \ + scm_c_make_struct (exp_vtables[SCM_EXPANDED_TOPLEVEL_DEFINE], 0, SCM_NUM_EXPANDED_TOPLEVEL_DEFINE_FIELDS, SCM_UNPACK (src), SCM_UNPACK (mod), SCM_UNPACK (name), SCM_UNPACK (exp)) #define SCM_EXPANDED_CONDITIONAL_TYPE_NAME "conditional" #define SCM_EXPANDED_CONDITIONAL_FIELD_NAMES \ diff --git a/module/ice-9/compile-psyntax.scm b/module/ice-9/compile-psyntax.scm index 44cdbbe9b..8a0b5cc0d 100644 --- a/module/ice-9/compile-psyntax.scm +++ b/module/ice-9/compile-psyntax.scm @@ -139,11 +139,12 @@ (translate-literal-syntax-objects (make-toplevel-define (toplevel-define-src x) + (toplevel-define-mod x) (toplevel-define-name x) (make-let (toplevel-define-src x) (list 'make-syntax) (list (module-gensym)) - (list (make-toplevel-ref #f 'make-syntax)) + (list (make-toplevel-ref #f #f 'make-syntax)) (toplevel-define-exp x)))))))) ;; Avoid gratuitous churn in psyntax-pp.scm due to the marks and labels diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 151bf8e5b..6cd767640 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -45,14 +45,24 @@ public? exp))) (make-toplevel-ref - (lambda (src name) - (make-struct/simple (vector-ref %expanded-vtables 7) src name))) + (lambda (src mod name) + (make-struct/simple (vector-ref %expanded-vtables 7) src mod name))) (make-toplevel-set - (lambda (src name exp) - (make-struct/simple (vector-ref %expanded-vtables 8) src name exp))) + (lambda (src mod name exp) + (make-struct/simple + (vector-ref %expanded-vtables 8) + src + mod + name + exp))) (make-toplevel-define - (lambda (src name exp) - (make-struct/simple (vector-ref %expanded-vtables 9) src name exp))) + (lambda (src mod name exp) + (make-struct/simple + (vector-ref %expanded-vtables 9) + src + mod + name + exp))) (make-conditional (lambda (src test consequent alternate) (make-struct/simple @@ -143,20 +153,20 @@ (analyze-variable (lambda (mod var modref-cont bare-cont) (if (not mod) - (bare-cont var) + (bare-cont #f var) (let ((kind (car mod)) (mod (cdr mod))) (let ((key kind)) (cond ((memv key '(public)) (modref-cont mod var #t)) ((memv key '(private)) - (if (not (equal? mod (module-name (current-module)))) - (modref-cont mod var #f) - (bare-cont var))) + (if (equal? mod (module-name (current-module))) + (bare-cont mod var) + (modref-cont mod var #f))) ((memv key '(bare)) (bare-cont var)) ((memv key '(hygiene)) (if (and (not (equal? mod (module-name (current-module)))) (module-variable (resolve-module mod) var)) (modref-cont mod var #f) - (bare-cont var))) + (bare-cont mod var))) ((memv key '(primitive)) (syntax-violation #f "primitive not in operator position" var)) (else (syntax-violation #f "bad module kind" var mod)))))))) @@ -166,7 +176,7 @@ mod var (lambda (mod var public?) (make-module-ref source mod var public?)) - (lambda (var) (make-toplevel-ref source var))))) + (lambda (mod var) (make-toplevel-ref source mod var))))) (build-global-assignment (lambda (source var exp mod) (maybe-name-value! var exp) @@ -175,11 +185,11 @@ var (lambda (mod var public?) (make-module-set source mod var public? exp)) - (lambda (var) (make-toplevel-set source var exp))))) + (lambda (mod var) (make-toplevel-set source mod var exp))))) (build-global-definition - (lambda (source var exp) + (lambda (source mod var exp) (maybe-name-value! var exp) - (make-toplevel-define source var exp))) + (make-toplevel-define source (and mod (cdr mod)) var exp))) (build-simple-lambda (lambda (src req rest vars meta exp) (make-lambda @@ -583,7 +593,7 @@ (syntax-expression id)))) (record-definition! id var) (list (if (eq? m 'c&e) - (let ((x (build-global-definition s var (expand e r w mod)))) + (let ((x (build-global-definition s mod var (expand e r w mod)))) (top-level-eval-hook x mod) (lambda () x)) (call-with-values @@ -591,9 +601,9 @@ (lambda (type* value* mod*) (if (eq? type* 'macro) (top-level-eval-hook - (build-global-definition s var (build-void s)) + (build-global-definition s mod var (build-void s)) mod)) - (lambda () (build-global-definition s var (expand e r w mod))))))))) + (lambda () (build-global-definition s mod var (expand e r w mod))))))))) ((memv key '(define-syntax-form define-syntax-parameter-form)) (let* ((id (wrap value w mod)) (label (gen-label)) @@ -604,21 +614,21 @@ (let ((key m)) (cond ((memv key '(c)) (cond ((memq 'compile esew) - (let ((e (expand-install-global var type (expand e r w mod)))) + (let ((e (expand-install-global mod var type (expand e r w mod)))) (top-level-eval-hook e mod) (if (memq 'load esew) (list (lambda () e)) '()))) ((memq 'load esew) (list (lambda () - (expand-install-global var type (expand e r w mod))))) + (expand-install-global mod var type (expand e r w mod))))) (else '()))) ((memv key '(c&e)) - (let ((e (expand-install-global var type (expand e r w mod)))) + (let ((e (expand-install-global mod var type (expand e r w mod)))) (top-level-eval-hook e mod) (list (lambda () e)))) (else (if (memq 'eval esew) (top-level-eval-hook - (expand-install-global var type (expand e r w mod)) + (expand-install-global mod var type (expand e r w mod)) mod)) '()))))) ((memv key '(begin-form)) @@ -683,9 +693,10 @@ (let ((exps (map (lambda (x) (x)) (reverse (parse body r w s m esew mod))))) (if (null? exps) (build-void s) (build-sequence s exps))))))) (expand-install-global - (lambda (name type e) + (lambda (mod name type e) (build-global-definition #f + mod name (build-primcall #f @@ -976,11 +987,11 @@ (source-wrap e w (cdr w) mod) x)) (else (decorate-source x s)))))) - (let* ((t-680b775fb37a463-7b8 transformer-environment) - (t-680b775fb37a463-7b9 (lambda (k) (k e r w s rib mod)))) + (let* ((t-680b775fb37a463-7c8 transformer-environment) + (t-680b775fb37a463-7c9 (lambda (k) (k e r w s rib mod)))) (with-fluid* - t-680b775fb37a463-7b8 - t-680b775fb37a463-7b9 + t-680b775fb37a463-7c8 + t-680b775fb37a463-7c9 (lambda () (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod)) @@ -1513,11 +1524,11 @@ s mod get-formals - (map (lambda (tmp-680b775fb37a463-aa9 - tmp-680b775fb37a463-aa8 - tmp-680b775fb37a463-aa7) - (cons tmp-680b775fb37a463-aa7 - (cons tmp-680b775fb37a463-aa8 tmp-680b775fb37a463-aa9))) + (map (lambda (tmp-680b775fb37a463-ab9 + tmp-680b775fb37a463-ab8 + tmp-680b775fb37a463-ab7) + (cons tmp-680b775fb37a463-ab7 + (cons tmp-680b775fb37a463-ab8 tmp-680b775fb37a463-ab9))) e2* e1* args*))) @@ -1815,11 +1826,11 @@ (apply (lambda (args e1 e2) (build-it '() - (map (lambda (tmp-680b775fb37a463-c76 - tmp-680b775fb37a463-c75 - tmp-680b775fb37a463-c74) - (cons tmp-680b775fb37a463-c74 - (cons tmp-680b775fb37a463-c75 tmp-680b775fb37a463-c76))) + (map (lambda (tmp-680b775fb37a463-c86 + tmp-680b775fb37a463-c85 + tmp-680b775fb37a463-c84) + (cons tmp-680b775fb37a463-c84 + (cons tmp-680b775fb37a463-c85 tmp-680b775fb37a463-c86))) e2 e1 args))) @@ -1831,11 +1842,11 @@ (apply (lambda (docstring args e1 e2) (build-it (list (cons 'documentation (syntax->datum docstring))) - (map (lambda (tmp-680b775fb37a463-c8c - tmp-680b775fb37a463-c8b - tmp-680b775fb37a463-c8a) - (cons tmp-680b775fb37a463-c8a - (cons tmp-680b775fb37a463-c8b tmp-680b775fb37a463-c8c))) + (map (lambda (tmp-680b775fb37a463-c9c + tmp-680b775fb37a463-c9b + tmp-680b775fb37a463-c9a) + (cons tmp-680b775fb37a463-c9a + (cons tmp-680b775fb37a463-c9b tmp-680b775fb37a463-c9c))) e2 e1 args))) @@ -1858,11 +1869,11 @@ (apply (lambda (args e1 e2) (build-it '() - (map (lambda (tmp-680b775fb37a463-cac - tmp-680b775fb37a463-cab - tmp-680b775fb37a463-caa) - (cons tmp-680b775fb37a463-caa - (cons tmp-680b775fb37a463-cab tmp-680b775fb37a463-cac))) + (map (lambda (tmp-680b775fb37a463-cbc + tmp-680b775fb37a463-cbb + tmp-680b775fb37a463-cba) + (cons tmp-680b775fb37a463-cba + (cons tmp-680b775fb37a463-cbb tmp-680b775fb37a463-cbc))) e2 e1 args))) @@ -1874,11 +1885,11 @@ (apply (lambda (docstring args e1 e2) (build-it (list (cons 'documentation (syntax->datum docstring))) - (map (lambda (tmp-680b775fb37a463-cc2 - tmp-680b775fb37a463-cc1 - tmp-680b775fb37a463-cc0) - (cons tmp-680b775fb37a463-cc0 - (cons tmp-680b775fb37a463-cc1 tmp-680b775fb37a463-cc2))) + (map (lambda (tmp-680b775fb37a463-cd2 + tmp-680b775fb37a463-cd1 + tmp-680b775fb37a463-cd0) + (cons tmp-680b775fb37a463-cd0 + (cons tmp-680b775fb37a463-cd1 tmp-680b775fb37a463-cd2))) e2 e1 args))) @@ -2803,9 +2814,9 @@ k (list docstring) (map (lambda (tmp-680b775fb37a463 - tmp-680b775fb37a463-112f - tmp-680b775fb37a463-112e) - (list (cons tmp-680b775fb37a463-112e tmp-680b775fb37a463-112f) + tmp-680b775fb37a463-113f + tmp-680b775fb37a463-113e) + (list (cons tmp-680b775fb37a463-113e tmp-680b775fb37a463-113f) tmp-680b775fb37a463)) template pattern @@ -2989,8 +3000,8 @@ (apply (lambda (p) (if (= lev 0) (quasilist* - (map (lambda (tmp-680b775fb37a463-11d3) - (list "value" tmp-680b775fb37a463-11d3)) + (map (lambda (tmp-680b775fb37a463-11e3) + (list "value" tmp-680b775fb37a463-11e3)) p) (quasi q lev)) (quasicons @@ -3013,8 +3024,8 @@ (apply (lambda (p) (if (= lev 0) (quasiappend - (map (lambda (tmp-680b775fb37a463-11d8) - (list "value" tmp-680b775fb37a463-11d8)) + (map (lambda (tmp-680b775fb37a463-11e8) + (list "value" tmp-680b775fb37a463-11e8)) p) (quasi q lev)) (quasicons @@ -3048,8 +3059,8 @@ (apply (lambda (p) (if (= lev 0) (quasilist* - (map (lambda (tmp-680b775fb37a463-11ee) - (list "value" tmp-680b775fb37a463-11ee)) + (map (lambda (tmp-680b775fb37a463-11fe) + (list "value" tmp-680b775fb37a463-11fe)) p) (vquasi q lev)) (quasicons @@ -3068,8 +3079,8 @@ (apply (lambda (p) (if (= lev 0) (quasiappend - (map (lambda (tmp-680b775fb37a463-11f3) - (list "value" tmp-680b775fb37a463-11f3)) + (map (lambda (tmp-680b775fb37a463) + (list "value" tmp-680b775fb37a463)) p) (vquasi q lev)) (quasicons @@ -3159,8 +3170,8 @@ (let ((tmp-1 ls)) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t-680b775fb37a463-123c) - (cons "vector" t-680b775fb37a463-123c)) + (apply (lambda (t-680b775fb37a463-124c) + (cons "vector" t-680b775fb37a463-124c)) tmp) (syntax-violation #f @@ -3213,9 +3224,9 @@ (let ((tmp-1 (list (emit (car x*)) (f (cdr x*))))) (let ((tmp ($sc-dispatch tmp-1 '(any any)))) (if tmp - (apply (lambda (t-680b775fb37a463-127a t-680b775fb37a463) + (apply (lambda (t-680b775fb37a463-128a t-680b775fb37a463) (list (make-syntax 'cons '((top)) '(hygiene guile)) - t-680b775fb37a463-127a + t-680b775fb37a463-128a t-680b775fb37a463)) tmp) (syntax-violation @@ -3244,9 +3255,9 @@ (let ((tmp-1 (map emit x))) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t-680b775fb37a463) + (apply (lambda (t-680b775fb37a463-12a2) (cons (make-syntax 'vector '((top)) '(hygiene guile)) - t-680b775fb37a463)) + t-680b775fb37a463-12a2)) tmp) (syntax-violation #f @@ -3257,9 +3268,9 @@ (if tmp-1 (apply (lambda (x) (let ((tmp (emit x))) - (let ((t-680b775fb37a463-129e tmp)) + (let ((t-680b775fb37a463-12ae tmp)) (list (make-syntax 'list->vector '((top)) '(hygiene guile)) - t-680b775fb37a463-129e)))) + t-680b775fb37a463-12ae)))) tmp-1) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any)))) (if tmp-1 diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 0cad97769..3cd87c8e3 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -329,19 +329,19 @@ (define (analyze-variable mod var modref-cont bare-cont) (if (not mod) - (bare-cont var) + (bare-cont #f var) (let ((kind (car mod)) (mod (cdr mod))) (case kind ((public) (modref-cont mod var #t)) - ((private) (if (not (equal? mod (module-name (current-module)))) - (modref-cont mod var #f) - (bare-cont var))) + ((private) (if (equal? mod (module-name (current-module))) + (bare-cont mod var) + (modref-cont mod var #f))) ((bare) (bare-cont var)) ((hygiene) (if (and (not (equal? mod (module-name (current-module)))) (module-variable (resolve-module mod) var)) (modref-cont mod var #f) - (bare-cont var))) + (bare-cont mod var))) ((primitive) (syntax-violation #f "primitive not in operator position" var)) (else (syntax-violation #f "bad module kind" var mod)))))) @@ -352,8 +352,8 @@ mod var (lambda (mod var public?) (make-module-ref source mod var public?)) - (lambda (var) - (make-toplevel-ref source var))))) + (lambda (mod var) + (make-toplevel-ref source mod var))))) (define build-global-assignment (lambda (source var exp mod) @@ -362,13 +362,13 @@ mod var (lambda (mod var public?) (make-module-set source mod var public? exp)) - (lambda (var) - (make-toplevel-set source var exp))))) + (lambda (mod var) + (make-toplevel-set source mod var exp))))) (define build-global-definition - (lambda (source var exp) + (lambda (source mod var exp) (maybe-name-value! var exp) - (make-toplevel-define source var exp))) + (make-toplevel-define source (and mod (cdr mod)) var exp))) (define build-simple-lambda (lambda (src req rest vars meta exp) @@ -1142,7 +1142,7 @@ (record-definition! id var) (list (if (eq? m 'c&e) - (let ((x (build-global-definition s var (expand e r w mod)))) + (let ((x (build-global-definition s mod var (expand e r w mod)))) (top-level-eval-hook x mod) (lambda () x)) (call-with-values @@ -1152,10 +1152,10 @@ ;; macro, then immediately discard that binding. (if (eq? type* 'macro) (top-level-eval-hook (build-global-definition - s var (build-void s)) + s mod var (build-void s)) mod)) (lambda () - (build-global-definition s var (expand e r w mod))))))))) + (build-global-definition s mod var (expand e r w mod))))))))) ((define-syntax-form define-syntax-parameter-form) (let* ((id (wrap value w mod)) (label (gen-label)) @@ -1167,23 +1167,23 @@ ((c) (cond ((memq 'compile esew) - (let ((e (expand-install-global var type (expand e r w mod)))) + (let ((e (expand-install-global mod var type (expand e r w mod)))) (top-level-eval-hook e mod) (if (memq 'load esew) (list (lambda () e)) '()))) ((memq 'load esew) (list (lambda () - (expand-install-global var type (expand e r w mod))))) + (expand-install-global mod var type (expand e r w mod))))) (else '()))) ((c&e) - (let ((e (expand-install-global var type (expand e r w mod)))) + (let ((e (expand-install-global mod var type (expand e r w mod)))) (top-level-eval-hook e mod) (list (lambda () e)))) (else (if (memq 'eval esew) (top-level-eval-hook - (expand-install-global var type (expand e r w mod)) + (expand-install-global mod var type (expand e r w mod)) mod)) '())))) ((begin-form) @@ -1244,9 +1244,10 @@ (build-sequence s exps)))))) (define expand-install-global - (lambda (name type e) + (lambda (mod name type e) (build-global-definition no-source + mod name (build-primcall no-source diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm index 5cb4710f2..77d6f2394 100644 --- a/module/language/tree-il.scm +++ b/module/language/tree-il.scm @@ -1,4 +1,4 @@ -;;;; Copyright (C) 2009-2014, 2017-2018 Free Software Foundation, Inc. +;;;; Copyright (C) 2009-2014, 2017-2019 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 @@ -30,9 +30,9 @@ lexical-set? make-lexical-set lexical-set-src lexical-set-name lexical-set-gensym lexical-set-exp module-ref? make-module-ref module-ref-src module-ref-mod module-ref-name module-ref-public? module-set? make-module-set module-set-src module-set-mod module-set-name module-set-public? module-set-exp - toplevel-ref? make-toplevel-ref toplevel-ref-src toplevel-ref-name - toplevel-set? make-toplevel-set toplevel-set-src toplevel-set-name toplevel-set-exp - toplevel-define? make-toplevel-define toplevel-define-src toplevel-define-name toplevel-define-exp + toplevel-ref? make-toplevel-ref toplevel-ref-src toplevel-ref-mod toplevel-ref-name + toplevel-set? make-toplevel-set toplevel-set-src toplevel-set-mod toplevel-set-name toplevel-set-exp + toplevel-define? make-toplevel-define toplevel-define-src toplevel-define-mod toplevel-define-name toplevel-define-exp conditional? make-conditional conditional-src conditional-test conditional-consequent conditional-alternate call? make-call call-src call-proc call-args primcall? make-primcall primcall-src primcall-name primcall-args @@ -117,9 +117,9 @@ ;; ( name gensym exp) ;; ( mod name public?) ;; ( mod name public? exp) - ;; ( name) - ;; ( name exp) - ;; ( name exp) + ;; ( mod name) + ;; ( mod name exp) + ;; ( mod name exp) ;; ( test consequent alternate) ;; ( proc args) ;; ( name args) @@ -197,13 +197,13 @@ (make-module-set loc mod name #f (retrans exp))) (('toplevel (and name (? symbol?))) - (make-toplevel-ref loc name)) + (make-toplevel-ref loc #f name)) (('set! ('toplevel (and name (? symbol?))) exp) - (make-toplevel-set loc name (retrans exp))) + (make-toplevel-set loc #f name (retrans exp))) (('define (and name (? symbol?)) exp) - (make-toplevel-define loc name (retrans exp))) + (make-toplevel-define loc #f name (retrans exp))) (('lambda meta body) (make-lambda loc meta (retrans body))) @@ -286,13 +286,13 @@ (($ src mod name public? exp) `(set! (,(if public? '@ '@@) ,mod ,name) ,(unparse-tree-il exp))) - (($ src name) + (($ src mod name) `(toplevel ,name)) - (($ src name exp) + (($ src mod name exp) `(set! (toplevel ,name) ,(unparse-tree-il exp))) - (($ src name exp) + (($ src mod name exp) `(define ,name ,(unparse-tree-il exp))) (($ src meta body) @@ -356,9 +356,9 @@ (foldts exp seed ...)) (($ src mod name public? exp) (foldts exp seed ...)) - (($ src name exp) + (($ src mod name exp) (foldts exp seed ...)) - (($ src name exp) + (($ src mod name exp) (foldts exp seed ...)) (($ src test consequent alternate) (let*-values (((seed ...) (foldts test seed ...)) @@ -449,17 +449,17 @@ This is an implementation of `foldts' as described by Andy Wingo in x (make-module-set src mod name public? exp*)))) - (($ src name exp) + (($ src mod name exp) (let ((exp* (lp exp))) (if (eq? exp exp*) x - (make-toplevel-set src name exp*)))) + (make-toplevel-set src mod name exp*)))) - (($ src name exp) + (($ src mod name exp) (let ((exp* (lp exp))) (if (eq? exp exp*) x - (make-toplevel-define src name exp*)))) + (make-toplevel-define src mod name exp*)))) (($ src test consequent alternate) (let ((test* (lp test)) diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index 62632fd3c..eb83a8ea5 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -873,7 +873,7 @@ given `tree-il' element." (match proc (($ _ '(oop goops) 'toplevel-define! #f) (toplevel-define-arg args)) - (($ _ 'toplevel-define!) + (($ _ _ 'toplevel-define!) ;; This may be the result of expanding one of the GOOPS macros within ;; `oop/goops.scm'. (and (eq? env (resolve-module '(oop goops))) @@ -972,11 +972,11 @@ given `tree-il' element." (($ _ 'make-syntax-transformer) #t) (_ #f))) (match x - (($ src name) + (($ src mod name) (add-use name (nearest-loc src))) - (($ src name) + (($ src mod name) (add-use name (nearest-loc src))) - (($ src name (? macro?)) + (($ src mod name (? macro?)) (add-def name (nearest-loc src))) (_ info))) @@ -1421,10 +1421,10 @@ resort, return #t when EXP refers to the global variable SPECIAL-NAME." (cut eq? <> special-name)) (match exp - (($ _ (? special?)) + (($ _ _ (? special?)) ;; Allow top-levels like: (define _ (cut gettext <> "my-domain")). #t) - (($ _ name) + (($ _ _ name) (let ((var (module-variable env name))) (and var (variable-bound? var) (eq? (variable-ref var) proc)))) @@ -1464,7 +1464,7 @@ resort, return #t when EXP refers to the global variable SPECIAL-NAME." (define format-analysis ;; Report arity mismatches in the given tree. (make-tree-analysis - (lambda (x _ env locs) + (lambda (x res env locs) ;; Down into X. (define (check-format-args args loc) (pmatch args @@ -1539,7 +1539,7 @@ resort, return #t when EXP refers to the global variable SPECIAL-NAME." (false-if-exception (module-ref env name)))) (match x - (($ src ($ _ name) args) + (($ src ($ _ _ name) args) (let ((proc (resolve-toplevel name))) (if (or (and (eq? proc (@ (guile) simple-format)) (check-simple-format-args args diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index 6c8884add..d97ead911 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/module/language/tree-il/compile-cps.scm @@ -1,6 +1,6 @@ ;;; Continuation-passing style (CPS) intermediate language (IL) -;; Copyright (C) 2013, 2014, 2015, 2017, 2018 Free Software Foundation, Inc. +;; Copyright (C) 2013-2015,2017-2019 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 @@ -1849,7 +1849,7 @@ ($continue k src ($primcall 'scm-set!/immediate '(box . 1) (box val)))))))))) - (($ src name) + (($ src mod name) (toplevel-box cps src name #t (lambda (cps box) @@ -1859,7 +1859,7 @@ ($continue k src ($primcall 'scm-ref/immediate '(box . 1) (box)))))))) - (($ src name exp) + (($ src mod name exp) (convert-arg cps exp (lambda (cps val) (toplevel-box @@ -1871,7 +1871,7 @@ ($continue k src ($primcall 'scm-set!/immediate '(box . 1) (box val)))))))))) - (($ src name exp) + (($ src modname name exp) (convert-arg cps exp (lambda (cps val) (with-cps cps diff --git a/module/language/tree-il/debug.scm b/module/language/tree-il/debug.scm index 613dc2ea6..3878fb526 100644 --- a/module/language/tree-il/debug.scm +++ b/module/language/tree-il/debug.scm @@ -1,6 +1,6 @@ ;;; Tree-IL verifier -;; Copyright (C) 2011, 2013 Free Software Foundation, Inc. +;; Copyright (C) 2011, 2013, 2019 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 @@ -170,8 +170,10 @@ (visit body env)))) (($ src val) #t) (($ src) #t) - (($ src name) + (($ src mod name) (cond + ((and mod (not (and (list? mod) (and-map symbol? mod)))) + (error "module name should be #f or list of symbols" mod)) ((not (symbol? name)) (error "name should be a symbol" name)))) (($ src mod name public?) @@ -184,14 +186,18 @@ (cond ((not (symbol? name)) (error "name should be symbol" exp)))) - (($ src name exp) + (($ src mod name exp) (cond + ((and mod (not (and (list? mod) (and-map symbol? mod)))) + (error "module name should be #f or list of symbols" mod)) ((not (symbol? name)) (error "name should be a symbol" name)) (else (visit exp env)))) - (($ src name exp) + (($ src mod name exp) (cond + ((and mod (not (and (list? mod) (and-map symbol? mod)))) + (error "module name should be #f or list of symbols" mod)) ((not (symbol? name)) (error "name should be a symbol" name)) (else diff --git a/module/language/tree-il/effects.scm b/module/language/tree-il/effects.scm index a133e3269..05016a3a1 100644 --- a/module/language/tree-il/effects.scm +++ b/module/language/tree-il/effects.scm @@ -294,10 +294,10 @@ of an expression." (logior (cause &toplevel) (cause &type-check) (compute-effects exp))) - (($ _ name exp) + (($ _ _ name exp) (logior (cause &toplevel) (compute-effects exp))) - (($ _ name exp) + (($ _ _ name exp) (logior (cause &toplevel) (compute-effects exp))) (($ ) diff --git a/module/language/tree-il/fix-letrec.scm b/module/language/tree-il/fix-letrec.scm index 227bbfb38..afc9b8e21 100644 --- a/module/language/tree-il/fix-letrec.scm +++ b/module/language/tree-il/fix-letrec.scm @@ -87,9 +87,9 @@ (adjoin gensym (recurse exp))) (($ src mod name public? exp) (recurse exp)) - (($ src name exp) + (($ src mod name exp) (recurse exp)) - (($ src name exp) + (($ src mod name exp) (recurse exp)) (($ src test consequent alternate) (union (recurse test) diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm index e1938e6bf..f11640fa5 100644 --- a/module/language/tree-il/peval.scm +++ b/module/language/tree-il/peval.scm @@ -387,7 +387,7 @@ top-level bindings from ENV and return the resulting expression." (let () (define (env-folder x env) (match x - (($ _ name) + (($ _ _ name) (vhash-consq name #t env)) (($ _ head tail) (env-folder tail (env-folder head env))) @@ -1020,7 +1020,7 @@ top-level bindings from ENV and return the resulting expression." (else #f)))) (_ #f)) (make-let-values lv-src producer (for-tail consumer))))) - (($ src (? effect-free-primitive? name)) + (($ src mod (? effect-free-primitive? name)) exp) (($ ) ;; todo: open private local bindings. @@ -1038,10 +1038,10 @@ top-level bindings from ENV and return the resulting expression." exp) (($ src mod name public? exp) (make-module-set src mod name public? (for-value exp))) - (($ src name exp) - (make-toplevel-define src name (for-value exp))) - (($ src name exp) - (make-toplevel-set src name (for-value exp))) + (($ src mod name exp) + (make-toplevel-define src mod name (for-value exp))) + (($ src mod name exp) + (make-toplevel-set src mod name (for-value exp))) (($ ) (case ctx ((effect) (make-void #f)) diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index bba2f6fe7..46729ef88 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -1,7 +1,7 @@ ;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*- ;;;; Andy Wingo --- May 2009 ;;;; -;;;; Copyright (C) 2009-2014, 2018 Free Software Foundation, Inc. +;;;; Copyright (C) 2009-2014,2018-2019 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 @@ -188,11 +188,11 @@ x)) (and (= result 12) (equal? (map strip-source (list-head (reverse ups) 3)) - (list (make-toplevel-ref #f '+) + (list (make-toplevel-ref #f #f '+) (make-lexical-ref #f 'x 'x1) (make-lexical-ref #f 'y 'y1))) (equal? (map strip-source (reverse (list-head downs 3))) - (list (make-toplevel-ref #f '+) + (list (make-toplevel-ref #f #f '+) (make-lexical-ref #f 'x 'x1) (make-lexical-ref #f 'y 'y1)))))))