mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

compilation enviroments are always modules; simplifications & refactorings

Browse source 
* module/ice-9/boot-9.scm (make-fresh-user-module): New public function,
  makes an anonymous beautified module.

* module/language/objcode/spec.scm: We used to have some things in here
  that allowed lexical variable names and values to be a part of the
  environment, but no more. Now an environment is just a module. If you
  want to "inject" free variables into code, just use lambda.

* module/language/scheme/compile-tree-il.scm (compile-tree-il): Same
  here. Also, rely on the fact that an environment *will* be a module --
  because (system base compile) guarantees that for us.

* module/language/scheme/spec.scm (scheme): In the reader, rely on the
  environment being a module. Define a #:make-default-environment
  handler, which returns a beautified module, augmented with a fresh
  definition for current-reader, so that side effects to current-reader
  are restricted to the compilation unit.

* module/language/tree-il/analyze.scm
  (report-possibly-unbound-variables):
* module/language/tree-il/compile-glil.scm (compile-glil):
* module/language/tree-il/optimize.scm (optimize!): The environment will
  be a module.

* module/system/base/language.scm (<language>): New field,
  `make-default-environment'. Defaults to `make-fresh-user-module'.
  (default-environment): New accessor, returns a default environment for
  a language.

* module/system/repl/common.scm (repl-compile): Always compile relative
  to the current module, because a module is always acceptable as an
  environment.

* module/system/base/compile.scm (compile-file, compile-and-load): Both
  of these have a new keyword argument, #:env. For `compile-file', it
  defaults to the default environment of the source language, and for
  `compile-and-load', to the current module.
  (read-and-compile): If there are no expressions read, pass the joiner
  its default environment (via `default-environment joint').
This commit is contained in:
Andy Wingo 2009-10-16 15:27:10 +02:00
parent 40867c9776
commit f95f82f8e1
10 changed files with 99 additions and 159 deletions
Download patch file Download diff file Expand all files Collapse all files

5
module/ice-9/boot-9.scm
View file

@ -2008,6 +2008,11 @@
;; Import the default set of bindings (from the SCM module) in MODULE. ;; Import the default set of bindings (from the SCM module) in MODULE.
(module-use! module the-scm-module))) (module-use! module the-scm-module)))
(define (make-fresh-user-module)
(let ((m (make-module)))
(beautify-user-module! m)
m))
;; NOTE: This binding is used in libguile/modules.c. ;; NOTE: This binding is used in libguile/modules.c.
;; ;;
(define resolve-module (define resolve-module

22
module/language/objcode/spec.scm
View file

@ -22,25 +22,17 @@
#:use-module (system base language) #:use-module (system base language)
#:use-module (system vm objcode) #:use-module (system vm objcode)
#:use-module (system vm program) #:use-module (system vm program)
#:export (objcode make-objcode-env)) #:export (objcode))
(define (make-objcode-env module externals)
(cons module externals))
(define (objcode-env-module env)
(if env (car env) (current-module)))
(define (objcode-env-externals env)
(and env (vector? (cdr env)) (cdr env)))
(define (objcode->value x e opts) (define (objcode->value x e opts)
(let ((thunk (make-program x #f (objcode-env-externals e)))) (let ((thunk (make-program x #f #f)))
(if e (if (eq? e (current-module))
;; save a cons in this case
(values (thunk) e e)
(save-module-excursion (save-module-excursion
(lambda () (lambda ()
(set-current-module (objcode-env-module e)) (set-current-module e)
(values (thunk) #f e))) (values (thunk) e e))))))
(values (thunk) #f e))))
;; since locals are allocated on the stack and can have limited scope, ;; since locals are allocated on the stack and can have limited scope,
;; in many cases we use one local for more than one lexical variable. so ;; in many cases we use one local for more than one lexical variable. so

35
module/language/scheme/compile-tree-il.scm
View file

@ -1,6 +1,6 @@
;;; Guile Scheme specification ;;; Guile Scheme specification
;; Copyright (C) 2001 Free Software Foundation, Inc. ;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -24,40 +24,11 @@
;;; environment := #f ;;; environment := #f
;;; | MODULE ;;; | MODULE
;;; | COMPILE-ENV
;;; compile-env := (MODULE LEXICALS . EXTERNALS)
(define (cenv-module env)
(cond ((not env) #f)
((module? env) env)
((and (pair? env) (module? (car env))) (car env))
(else (error "bad environment" env))))
(define (cenv-lexicals env)
(cond ((not env) '())
((module? env) '())
((pair? env) (cadr env))
(else (error "bad environment" env))))
(define (cenv-externals env)
(cond ((not env) '())
((module? env) '())
((pair? env) (cddr env))
(else (error "bad environment" env))))
(define (make-cenv module lexicals externals)
(cons module (cons lexicals externals)))
(define (location x)
(and (pair? x)
(let ((props (source-properties x)))
(and (not (null? props))
props))))
(define (compile-tree-il x e opts) (define (compile-tree-il x e opts)
(save-module-excursion (save-module-excursion
(lambda () (lambda ()
(and=> (cenv-module e) set-current-module) (set-current-module e)
(let* ((x (sc-expand x 'c '(compile load eval))) (let* ((x (sc-expand x 'c '(compile load eval)))
(cenv (make-cenv (current-module) (cenv (current-module)))
(cenv-lexicals e) (cenv-externals e))))
(values x cenv cenv))))) (values x cenv cenv)))))

17
module/language/scheme/spec.scm
View file

@ -41,11 +41,7 @@
#:reader (lambda (port env) #:reader (lambda (port env)
;; Use the binding of current-reader from the environment. ;; Use the binding of current-reader from the environment.
;; FIXME: Handle `read-options' as well? ;; FIXME: Handle `read-options' as well?
((or (and=> (and=> (module-variable ((or (and=> (and=> (module-variable env 'current-reader)
(cond ((pair? env) (car env))
(env)
(else (current-module)))
'current-reader)
variable-ref) variable-ref)
fluid-ref) fluid-ref)
read) read)
@ -55,4 +51,13 @@
#:decompilers `((tree-il . ,decompile-tree-il)) #:decompilers `((tree-il . ,decompile-tree-il))
#:evaluator (lambda (x module) (primitive-eval x)) #:evaluator (lambda (x module) (primitive-eval x))
#:printer write #:printer write
) #:make-default-environment
(lambda ()
;; Ideally we'd duplicate the whole module hierarchy so that `set!',
;; `fluid-set!', etc. don't have any effect in the current environment.
(let ((m (make-fresh-user-module)))
;; Provide a separate `current-reader' fluid so that
;; compile-time changes to `current-reader' are
;; limited to the current compilation unit.
(module-define! m 'current-reader (make-fluid))
m)))

109
module/language/tree-il/analyze.scm
View file

@ -633,76 +633,67 @@
(defs toplevel-info-defs) ;; (VARIABLE-NAME ...) (defs toplevel-info-defs) ;; (VARIABLE-NAME ...)
(locs toplevel-info-locs)) ;; (LOCATION ...) (locs toplevel-info-locs)) ;; (LOCATION ...)
(define (env-module e)
"Return the module corresponding to E."
;; XXX: This is a bit of a hack since since representation of compile-time
;; environments is hidden in `(language scheme compile-tree-il)'.
(cond ((pair? e) (car e))
((module? e) e)
(else (current-module))))
;; TODO: Combine with `report-unused-variables' so we don't traverse the tree ;; TODO: Combine with `report-unused-variables' so we don't traverse the tree
;; once for each warning type. ;; once for each warning type.
(define (report-possibly-unbound-variables tree env) (define (report-possibly-unbound-variables tree env)
"Return possibly unbound variables in TREE. Return TREE." "Return possibly unbound variables in TREE. Return TREE."
(define toplevel (define toplevel
(let ((env (env-module env))) (tree-il-fold (lambda (x info)
(tree-il-fold (lambda (x info) ;; X is a leaf: extend INFO's refs accordingly.
;; X is a leaf: extend INFO's refs accordingly. (let ((refs (toplevel-info-refs info))
(let ((refs (toplevel-info-refs info)) (defs (toplevel-info-defs info))
(defs (toplevel-info-defs info)) (locs (toplevel-info-locs info)))
(locs (toplevel-info-locs info))) (define (bound? name)
(define (bound? name) (or (and (module? env)
(or (and (module? env) (module-variable env name))
(module-variable env name)) (memq name defs)))
(memq name defs)))
(record-case x (record-case x
((<toplevel-ref> name src) ((<toplevel-ref> name src)
(if (bound? name) (if (bound? name)
info info
(let ((src (or src (find pair? locs)))) (let ((src (or src (find pair? locs))))
(make-toplevel-info (alist-cons name src refs) (make-toplevel-info (alist-cons name src refs)
defs defs
locs)))) locs))))
(else info)))) (else info))))
(lambda (x info) (lambda (x info)
;; Going down into X. ;; Going down into X.
(let* ((refs (toplevel-info-refs info)) (let* ((refs (toplevel-info-refs info))
(defs (toplevel-info-defs info)) (defs (toplevel-info-defs info))
(src (tree-il-src x)) (src (tree-il-src x))
(locs (cons src (toplevel-info-locs info)))) (locs (cons src (toplevel-info-locs info))))
(define (bound? name) (define (bound? name)
(or (and (module? env) (or (and (module? env)
(module-variable env name)) (module-variable env name))
(memq name defs))) (memq name defs)))
(record-case x (record-case x
((<toplevel-set> name src) ((<toplevel-set> name src)
(if (bound? name) (if (bound? name)
(make-toplevel-info refs defs locs) (make-toplevel-info refs defs locs)
(let ((src (find pair? locs))) (let ((src (find pair? locs)))
(make-toplevel-info (alist-cons name src refs) (make-toplevel-info (alist-cons name src refs)
defs defs
locs)))) locs))))
((<toplevel-define> name) ((<toplevel-define> name)
(make-toplevel-info (alist-delete name refs eq?) (make-toplevel-info (alist-delete name refs eq?)
(cons name defs) (cons name defs)
locs)) locs))
(else (else
(make-toplevel-info refs defs locs))))) (make-toplevel-info refs defs locs)))))
(lambda (x info) (lambda (x info)
;; Leaving X's scope. ;; Leaving X's scope.
(let ((refs (toplevel-info-refs info)) (let ((refs (toplevel-info-refs info))
(defs (toplevel-info-defs info)) (defs (toplevel-info-defs info))
(locs (toplevel-info-locs info))) (locs (toplevel-info-locs info)))
(make-toplevel-info refs defs (cdr locs)))) (make-toplevel-info refs defs (cdr locs))))
(make-toplevel-info '() '() '()) (make-toplevel-info '() '() '())
tree))) tree))
(for-each (lambda (name+loc) (for-each (lambda (name+loc)
(let ((name (car name+loc)) (let ((name (car name+loc))

4
module/language/tree-il/compile-glil.scm
View file

@ -65,10 +65,10 @@
(x (optimize! x e opts)) (x (optimize! x e opts))
(allocation (analyze-lexicals x))) (allocation (analyze-lexicals x)))
(with-fluid* *comp-module* (or (and e (car e)) (current-module)) (with-fluid* *comp-module* e
(lambda () (lambda ()
(values (flatten-lambda x #f allocation) (values (flatten-lambda x #f allocation)
(and e (cons (car e) (cddr e))) e
e))))) e)))))

5
module/language/tree-il/optimize.scm
View file

@ -25,11 +25,8 @@
#:use-module (language tree-il fix-letrec) #:use-module (language tree-il fix-letrec)
#:export (optimize!)) #:export (optimize!))
(define (env-module e)
(if e (car e) (current-module)))
(define (optimize! x env opts) (define (optimize! x env opts)
(inline! (inline!
(fix-letrec! (fix-letrec!
(expand-primitives! (expand-primitives!
(resolve-primitives! x (env-module env)))))) (resolve-primitives! x env)))))

41
module/system/base/compile.scm
View file

@ -141,9 +141,9 @@
(define* (compile-file file #:key (define* (compile-file file #:key
(output-file #f) (output-file #f)
(env #f)
(from (current-language)) (from (current-language))
(to 'objcode) (to 'objcode)
(env (default-environment from))
(opts '())) (opts '()))
(let* ((comp (or output-file (compiled-file-name file))) (let* ((comp (or output-file (compiled-file-name file)))
(in (open-input-file file)) (in (open-input-file file))
@ -159,10 +159,11 @@
file) file)
comp)) comp))
(define* (compile-and-load file #:key (from 'scheme) (to 'value) (opts '())) (define* (compile-and-load file #:key (from 'scheme) (to 'value)
(env (current-module)) (opts '()))
(read-and-compile (open-input-file file) (read-and-compile (open-input-file file)
#:from from #:to to #:opts opts #:from from #:to to #:opts opts
#:env (current-module))) #:env env))
;;; ;;;
@ -191,33 +192,10 @@
(else (else
(lp (cdr in) (caar in)))))) (lp (cdr in) (caar in))))))
(define (make-compilation-module)
"Return a fresh module to be used as the compilation environment."
;; Ideally we'd duplicate the whole module hierarchy so that `set!',
;; `fluid-set!', etc. don't have any effect in the current environment.
(let ((m (make-module)))
(beautify-user-module! m)
;; Provide a separate `current-reader' fluid so that the Scheme language
;; reader doesn't get to see the REPL's settings for `current-reader',
;; which would lead to an infinite loop.
(module-define! m 'current-reader (make-fluid))
m))
(define (language-default-environment lang)
"Return the default compilation environment for source language LANG."
(if (or (eq? lang 'scheme)
(eq? lang (lookup-language 'scheme)))
(make-compilation-module)
#f))
(define* (read-and-compile port #:key (define* (read-and-compile port #:key
(from (current-language)) (from (current-language))
(to 'objcode) (to 'objcode)
(env (language-default-environment from)) (env (default-environment from))
(opts '())) (opts '()))
(let ((from (ensure-language from)) (let ((from (ensure-language from))
(to (ensure-language to))) (to (ensure-language to)))
@ -227,10 +205,11 @@
(let ((x ((language-reader (current-language)) port cenv))) (let ((x ((language-reader (current-language)) port cenv)))
(cond (cond
((eof-object? x) ((eof-object? x)
;; FIXME: what if there are no expressions to be read?
;; then env is #f. Here default to cenv in that case.
(compile ((language-joiner joint) (reverse exps) env) (compile ((language-joiner joint) (reverse exps) env)
#:from joint #:to to #:env (or env cenv) #:opts opts)) #:from joint #:to to
;; env can be false if no expressions were read.
#:env (or env (default-environment joint))
#:opts opts))
(else (else
;; compile-fold instead of compile so we get the env too ;; compile-fold instead of compile so we get the env too
(receive (jexp jenv jcenv) (receive (jexp jenv jcenv)
@ -241,7 +220,7 @@
(define* (compile x #:key (define* (compile x #:key
(from (current-language)) (from (current-language))
(to 'value) (to 'value)
(env (language-default-environment from)) (env (default-environment from))
(opts '())) (opts '()))
(let ((warnings (memq #:warnings opts))) (let ((warnings (memq #:warnings opts)))

12
module/system/base/language.scm
View file

@ -25,10 +25,10 @@
language-name language-title language-version language-reader language-name language-title language-version language-reader
language-printer language-parser language-printer language-parser
language-compilers language-decompilers language-evaluator language-compilers language-decompilers language-evaluator
language-joiner language-joiner language-make-default-environment
lookup-compilation-order lookup-decompilation-order lookup-compilation-order lookup-decompilation-order
invalidate-compilation-cache!)) invalidate-compilation-cache! default-environment))
;;; ;;;
@ -45,7 +45,8 @@
(compilers '()) (compilers '())
(decompilers '()) (decompilers '())
(evaluator #f) (evaluator #f)
(joiner #f)) (joiner #f)
(make-default-environment make-fresh-user-module))
(define-macro (define-language name . spec) (define-macro (define-language name . spec)
`(begin `(begin
@ -97,3 +98,8 @@
reverse!))) reverse!)))
(set! *decompilation-cache* (acons key order *decompilation-cache*)) (set! *decompilation-cache* (acons key order *decompilation-cache*))
order)))) order))))
(define (default-environment lang)
"Return the default compilation environment for source language LANG."
((language-make-default-environment
(if (language? lang) lang (lookup-language lang)))))

8
module/system/repl/common.scm
View file

@ -70,13 +70,7 @@
((memq #:c opts) 'glil) ((memq #:c opts) 'glil)
(else 'objcode)))) (else 'objcode))))
(from (repl-language repl))) (from (repl-language repl)))
(compile form #:from from #:to to #:opts opts (compile form #:from from #:to to #:opts opts #:env (current-module))))
;; XXX: Languages other than Scheme may not support having
;; a module as the environment, so work around that. See
;; also `language-default-environment'.
#:env (if (eq? from (lookup-language 'scheme))
(current-module)
#f))))
(define (repl-parse repl form) (define (repl-parse repl form)
(let ((parser (language-parser (repl-language repl)))) (let ((parser (language-parser (repl-language repl))))