mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-17 03:00:21 +02:00
Code Activity

allow multiple modules in one compilation unit

Browse source 
* module/system/il/ghil.scm (<ghil-env>, <ghil-toplevel-env>): Refactor
  so that all environments point (eventually) at one toplevel
  environment. Instead of having potentially multiple toplevel
  environments, each noting the module against which its bindings are
  resolved, have each binding in the toplevel record what module it
  should be resolved in. Should fix compilation units that define
  multiple modules.
  (ghil-lookup, ghil-define): Reworked to not be destructive. Module
  variables now have the module name as their "env", and are keyed as
  `(MODNAME . SYM)' in the var table.
  (call-with-ghil-environment): Reindented.

* module/system/il/inline.scm (try-inline-with-env): Adapt to
  env/toplevel changes.

* module/system/vm/assemble.scm (dump-object!): A vlink-later now holds
  the module name, not the module itself.

* module/system/il/compile.scm (make-glil-var): The "env" of a "module"
  var is now the module name, not the module.

* module/language/scheme/translate.scm (primitive-syntax-table): Update
  the way we test for toplevel environments. Reindent the lambda
  translator.
  (lookup-transformer, trans): lookup-transformer now has 2 args, not 3.
  (translate): Update the way we make toplevel environments.
This commit is contained in:
Andy Wingo 2008-09-07 22:27:08 +02:00
parent b5c46470a5
commit 2e7e6969bd
5 changed files with 79 additions and 96 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -31,7 +31,7 @@
(define (translate x e)
(call-with-ghil-environment (make-ghil-mod e) '()
(call-with-ghil-environment (make-ghil-toplevel-env) '()
(lambda (env vars)
(make-ghil-lambda env #f vars #f '() (trans env (location x) x)))))
@ -47,8 +47,10 @@
;; compicated than that.
'(procedure->syntax procedure->macro procedure->memoizing-macro))
(define (lookup-transformer e head retrans)
(let* ((mod (ghil-mod-module (ghil-env-mod e)))
;; Looks up transformers relative to the current module at
;; compilation-time. See also the discussion of ghil-lookup in ghil.scm.
(define (lookup-transformer head retrans)
(let* ((mod (current-module))
(val (and (symbol? head)
(and=> (module-variable mod head)
(lambda (var)
@ -85,7 +87,7 @@
(cond ((pair? x)
(let ((head (car x)) (tail (cdr x)))
(cond
((lookup-transformer e head retrans)
((lookup-transformer head retrans)
=> (lambda (t) (t e l x)))
;; FIXME: lexical/module overrides of forbidden primitives
@ -142,7 +144,8 @@
(define
;; (define NAME VAL)
((,name ,val) (guard (symbol? name) (ghil-env-toplevel? e))
((,name ,val) (guard (symbol? name)
(ghil-toplevel-env? (ghil-env-parent e)))
(make-ghil-define e l (ghil-define (ghil-env-parent e) name)
(retrans val)))
;; (define (NAME FORMALS...) BODY...)
@ -259,16 +262,17 @@
((,formals . ,body)
(receive (syms rest) (parse-formals formals)
(call-with-ghil-environment e syms
(lambda (env vars)
(receive (meta body) (parse-lambda-meta body)
(make-ghil-lambda env l vars rest meta
(trans-body env l body))))))))
(lambda (env vars)
(receive (meta body) (parse-lambda-meta body)
(make-ghil-lambda env l vars rest meta
(trans-body env l body))))))))
(eval-case
(,clauses
(retrans
`(begin
,@(let ((toplevel? (ghil-env-toplevel? e)))
;; Compilation of toplevel units is always wrapped in a lambda
,@(let ((toplevel? (ghil-toplevel-env? (ghil-env-parent e))))
(let loop ((seen '()) (in clauses) (runtime '()))
(cond
((null? in) runtime)

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

@ -99,9 +99,7 @@
((eq? e (ghil-var-env var))
(make-glil-external op depth (ghil-var-index var)))))
((module)
(let ((env (ghil-var-env var)))
(make-glil-module op (ghil-mod-module (ghil-env-mod env))
(ghil-var-name var))))
(make-glil-module op (ghil-var-env var) (ghil-var-name var)))
(else (error "Unknown kind of variable:" var))))
(define (codegen ghil)

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

@ -76,14 +76,13 @@
ghil-var-env ghil-var-name ghil-var-kind ghil-var-type ghil-var-value
ghil-var-index
<ghil-mod> make-ghil-mod ghil-mod?
ghil-mod-module ghil-mod-table ghil-mod-imports
<ghil-toplevel-env> make-ghil-toplevel-env ghil-toplevel-env?
ghil-toplevel-env-table
<ghil-env> make-ghil-env ghil-env?
ghil-env-mod ghil-env-parent ghil-env-table ghil-env-variables
ghil-env-parent ghil-env-table ghil-env-variables
ghil-env-add! ghil-lookup ghil-define
ghil-env-toplevel?
call-with-ghil-environment call-with-ghil-bindings))
@ -125,23 +124,13 @@
;;; Modules
;;;
(define-record (<ghil-mod> module (table '()) (imports '())))
;;;
;;; Environments
;;;
(define-record (<ghil-env> mod parent (table '()) (variables '())))
(define %make-ghil-env make-ghil-env)
(define (make-ghil-env e)
(record-case e
((<ghil-mod>) (%make-ghil-env :mod e :parent e))
((<ghil-env> mod) (%make-ghil-env :mod mod :parent e))))
(define (ghil-env-toplevel? e)
(eq? (ghil-env-mod e) (ghil-env-parent e)))
(define-record (<ghil-env> parent (table '()) (variables '())))
(define-record (<ghil-toplevel-env> (table '())))
(define (ghil-env-ref env sym)
(assq-ref (ghil-env-table env) sym))
@ -165,64 +154,59 @@
;;; Public interface
;;;
(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
;;; warnings.
(if (not (eq? for-sym 'process-define-module))
(warn "during lookup of" for-sym ":"
(ghil-mod-module mod) "!= current" (current-module)))
(if (not (null? (ghil-mod-table mod)))
(warn "throwing away old variable table"
(ghil-mod-module) (ghil-mod-table mod)))
(set! (ghil-mod-module mod) (current-module))
(set! (ghil-mod-table mod) '())
(set! (ghil-mod-imports mod) '()))
;; looking up a var has side effects?
;; ghil-lookup: find out where a variable will be stored at runtime.
;;
;; First searches the lexical environments. If the variable is not in
;; the innermost environment, make sure the variable is marked as being
;; "external" so that it goes on the heap.
;;
;; If the variable is not found lexically, it is a toplevel variable,
;; which will be looked up at runtime with respect to the module that is
;; current at compile-time. The variable will be resolved when it is
;; first used.
;;
;; You might think that you want to look up all variables with respect
;; to the current runtime module, but you would have to associate the
;; current module with a closure, so that lazy lookup is done with
;; respect to the proper module. We could do that -- it would probably
;; cons less at runtime.
;;
;; This toplevel lookup strategy can exhibit weird effects in the case
;; of a call to set-current-module inside a closure -- specifically,
;; looking up any needed bindings for the rest of the closure in the
;; compilation module instead of the runtime module -- but such things
;; are both unspecified in the scheme standard.
(define (ghil-lookup env sym)
(or (ghil-env-ref env sym)
(let loop ((e (ghil-env-parent env)))
(record-case e
((<ghil-mod> module table imports)
(cond ((not (eq? module (current-module)))
;; FIXME: the primitive-eval in eval-case and/or macro
;; expansion can have side effects on the compilation
;; environment, for example changing the current
;; module. We probably need to add a special case in
;; compilation to handle define-module.
(fix-ghil-mod! e sym)
(loop e))
((assq-ref table sym)) ;; when does this hit?
(else
;; 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)
(let ((found (assq-ref table sym)))
(if found
(begin (set! (ghil-var-kind found) 'external) found)
(loop parent))))))))
(let loop ((e env))
(record-case e
((<ghil-toplevel-env> table)
(let ((key (cons (module-name (current-module)) sym)))
(or (assoc-ref table key)
(let ((var (make-ghil-var (car key) (cdr key) 'module)))
(apush! key var (ghil-toplevel-env-table e))
var))))
((<ghil-env> parent table variables)
(let ((found (assq-ref table sym)))
(if found
(begin
(if (not (eq? e env))
(set! (ghil-var-kind found) 'external))
found)
(loop parent)))))))
(define (ghil-define mod sym)
(if (not (eq? (ghil-mod-module mod) (current-module)))
(fix-ghil-mod! mod sym))
(or (assq-ref (ghil-mod-table mod) sym)
(let ((var (make-ghil-var (make-ghil-env mod) sym 'module)))
(apush! sym var (ghil-mod-table mod))
var)))
(define (ghil-define toplevel sym)
(let ((key (cons (module-name (current-module)) sym)))
(or (assoc-ref (ghil-toplevel-env-table toplevel) key)
(let ((var (make-ghil-var (car key) (cdr key) 'module)))
(apush! key var (ghil-toplevel-env-table toplevel))
var))))
(define (call-with-ghil-environment e syms func)
(let* ((e (make-ghil-env e))
(vars (map (lambda (s)
(let ((v (make-ghil-var e s 'argument)))
(ghil-env-add! e v) v))
syms)))
(vars (map (lambda (s)
(let ((v (make-ghil-var e s 'argument)))
(ghil-env-add! e v) v))
syms)))
(func e vars)))
(define (call-with-ghil-bindings e syms func)

23
module/system/il/inline.scm
View file

@ -69,22 +69,19 @@
(and=> (assq-ref *inline-table* head-value)
(lambda (proc) (apply proc args))))
(define (ghil-env-ref env sym)
(assq-ref (ghil-env-table env) sym))
(define (try-inline-with-env env loc exp)
(let ((sym (car exp)))
(and (not (ghil-env-ref env sym))
(let loop ((e (ghil-env-parent env)))
(record-case e
((<ghil-mod> module table imports)
(and (not (assq-ref table sym))
(module-bound? module sym)
(try-inline (module-ref module sym) (cdr exp))))
((<ghil-env> mod parent table variables)
(and (not (assq-ref table sym))
(loop parent))))))))
(let loop ((e env))
(record-case e
((<ghil-toplevel-env> table)
(let ((mod (current-module)))
(and (not (assoc-ref table (cons (module-name mod) sym)))
(module-bound? mod sym)
(try-inline (module-ref mod sym) (cdr exp)))))
((<ghil-env> parent table variables)
(and (not (assq-ref table sym))
(loop parent)))))))
(define-inline eq? (x y)
(eq? x y))

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

@ -269,7 +269,7 @@
;; dump bytecode
(push-code! `(load-program ,bytes)))
((<vlink-later> module name)
(dump! (module-name module))
(dump! module)
(dump! name)
(push-code! '(link-later)))
((<vlink-now> name)