diff options
author | Andy Wingo <wingo@pobox.com> | 2008-10-30 10:57:36 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2008-10-30 10:57:36 +0100 |
commit | 3de80ed52f7482faee2ce883d3df21eb8a38ee7a (patch) | |
tree | f33bf42499307ad99a5c78031e6497cddf47d89e /module/system | |
parent | 21497600d23534b2878f82401ffaf5551fdb6efd (diff) | |
download | guile-3de80ed52f7482faee2ce883d3df21eb8a38ee7a.tar.gz |
recompiling with compile environments, fluid languages, cleanups
* ice-9/boot-9.scm (compile-time-environment): Remove definition from
boot-9 -- instead, autoload it and `compile' from (system base
compile).
* libguile/objcodes.h:
* libguile/objcodes.c (scm_objcode_to_program): Add an optional argument,
`external', the external list to set on the returned program.
* libguile/vm-i-system.c (externals): New instruction, returns the
external list. Only used by (compile-time-environment).
* libguile/vm.c (scm_load_compiled_with_vm): Adapt to
scm_objcode_to_program change.
* module/language/scheme/translate.scm (translate): Actually pay
attention to the environment passed as an argument.
(custom-transformer-table): Expand out (compile-time-environment) to
something that can be passed to `compile'.
* module/system/base/compile.scm (*current-language*): Instead of
hard-coding `scheme' in various places, use a current language fluid,
initialized to `scheme'.
(compile-file, load-source-file): Adapt to *current-language*.
(load-source-file): Ada
(scheme-eval): Removed, no one used this.
(compiled-file-name): Don't hard-code "scm" and "go"; instead use the
%load-extensions and %load-compiled-extensions.
(cenv-module, cenv-ghil-env, cenv-externals): Some accessors for
compile-time environments.
(compile-time-environment): Here we define (compile-time-environment)
to something that will return #f; the compiler however produces
different code as noted above.
(compile): New function, compiles an expression into a thunk, then runs
the thunk to get the value. Useful for procedures. The optional second
argument can be either a module or a compile-time-environment; in the
latter case, we can recompile even with lexical bindings.
(compile-in): If the env specifies a module, set that module for the
duration of the compilation.
* module/system/base/syntax.scm (%compute-initargs): Fix a bug where the
default value for a field would always replace a user-supplied value.
Whoops.
* module/system/il/ghil.scm (ghil-env-dereify): New function, takes the
result of ghil-env-reify and turns it back into a GHIL environment.
* scripts/compile (compile): Remove some of the tricky error handling, as
the library procedures handle this for us.
* test-suite/tests/compiler.test: Add a test for the dynamic compilation
bits.
Diffstat (limited to 'module/system')
-rw-r--r-- | module/system/base/compile.scm | 100 | ||||
-rw-r--r-- | module/system/base/syntax.scm | 5 | ||||
-rw-r--r-- | module/system/il/ghil.scm | 12 |
3 files changed, 94 insertions, 23 deletions
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index f406eb84f..c852660dd 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -22,16 +22,21 @@ (define-module (system base compile) #:use-syntax (system base syntax) #:use-module (system base language) - #:use-module (system il compile) + #:use-module ((system il compile) #:select ((compile . compile-il))) + #:use-module (system il ghil) #:use-module (system il glil) #:use-module (system vm objcode) - #:use-module (system vm vm) ;; for compile-time evaluation #:use-module (system vm assemble) + #:use-module (system vm vm) ;; for compile-time evaluation #:use-module (ice-9 regex) + #:use-module (ice-9 optargs) #:export (syntax-error compile-file load-source-file load-file - compiled-file-name - scheme-eval read-file-in compile-in - load/compile)) + *current-language* + compiled-file-name + compile-time-environment + compile read-file-in compile-in + load/compile) + #:export-syntax (call-with-compile-error-catch)) ;;; ;;; Compiler environment @@ -50,15 +55,12 @@ (format (current-error-port) "unknown location: ~A: ~A~%" msg exp))))) -(export-syntax call-with-compile-error-catch) - - ;;; ;;; Compiler ;;; -(define (scheme) (lookup-language 'scheme)) +(define *current-language* (make-fluid)) (define (call-with-output-file/atomic filename proc) (let* ((template (string-append filename ".XXXXXX")) @@ -74,16 +76,16 @@ (define (compile-file file . opts) (let ((comp (compiled-file-name file)) - (scheme (scheme))) + (lang (fluid-ref *current-language*))) (catch 'nothing-at-all (lambda () (call-with-compile-error-catch (lambda () (call-with-output-file/atomic comp (lambda (port) - (let* ((source (read-file-in file scheme)) + (let* ((source (read-file-in file lang)) (objcode (apply compile-in source (current-module) - scheme opts))) + lang opts))) (if (memq #:c opts) (pprint-glil objcode port) (uniform-vector-write (objcode->u8vector objcode) port))))) @@ -106,8 +108,9 @@ ; result)))) (define (load-source-file file . opts) - (let ((source (read-file-in file (scheme)))) - (apply compile-in source (current-module) (scheme) opts))) + (let ((lang (fluid-ref *current-language*))) + (let ((source (read-file-in file lang))) + (apply compile-in source (current-module) lang opts)))) (define (load-file file . opts) (let ((comp (compiled-file-name file))) @@ -116,12 +119,63 @@ (apply load-source-file file opts)))) (define (compiled-file-name file) - (let ((base (basename file))) - (let ((m (string-match "\\.scm$" base))) - (string-append (if m (match:prefix m) base) ".go")))) - -(define (scheme-eval x e) - (vm-load (the-vm) (compile-in x e (scheme)))) + (let ((base (basename file)) + (cext (cond ((or (null? %load-compiled-extensions) + (string-null? (car %load-compiled-extensions))) + (warn "invalid %load-compiled-extensions" + %load-compiled-extensions) + ".go") + (else (car %load-compiled-extensions))))) + (let lp ((exts %load-extensions)) + (cond ((null? exts) (string-append base cext)) + ((string-null? (car exts)) (lp (cdr exts))) + ((string-suffix? (car exts) base) + (string-append + (substring base 0 + (- (string-length base) (string-length (car exts)))) + cext)) + (else (lp (cdr exts))))))) + +;;; environment := #f +;;; | 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-ghil-env env) + (cond ((not env) (make-ghil-toplevel-env)) + ((module? env) (make-ghil-toplevel-env)) + ((pair? env) + (ghil-env-dereify (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 (compile-time-environment) + "A special function known to the compiler that, when compiled, will +return a representation of the lexical environment in place at compile +time. Useful for supporting some forms of dynamic compilation. Returns +#f if called from the interpreter." + #f) + +(define* (compile x #:optional env) + (let ((thunk (objcode->program + (compile-in x env (fluid-ref *current-language*)) + (cenv-externals env)))) + (if (not env) + (thunk) + (save-module-excursion + (lambda () + (set-current-module (cenv-module env)) + (thunk)))))) ;;; @@ -136,6 +190,8 @@ (lambda () (catch 'result (lambda () + (and=> (cenv-module e) set-current-module) + (set! e (cenv-ghil-env e)) ;; expand (set! x ((language-expander lang) x e)) (if (memq #:e opts) (throw 'result x)) @@ -143,7 +199,7 @@ (set! x ((language-translator lang) x e)) (if (memq #:t opts) (throw 'result x)) ;; compile - (set! x (apply compile x e opts)) + (set! x (apply compile-il x e opts)) (if (memq #:c opts) (throw 'result x)) ;; assemble (apply assemble x e opts)) @@ -179,3 +235,5 @@ (not (string=? (dirname oldname) "."))) (string-append (dirname oldname) "/" filename) filename))) + +(fluid-set! *current-language* (lookup-language 'scheme)) diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm index 3172e3dee..8b0ba5969 100644 --- a/module/system/base/syntax.scm +++ b/module/system/base/syntax.scm @@ -87,7 +87,10 @@ (error "too many initargs" args slots)) (else (lp (cdr in) (cdr positional) - (acons (car positional) (car in) out)))))) + (let ((slot (car positional))) + (acons (if (pair? slot) (car slot) slot) + (car in) + out))))))) (define-macro (record-case record . clauses) (let ((r (gensym))) diff --git a/module/system/il/ghil.scm b/module/system/il/ghil.scm index 4b3043e14..5823ffb62 100644 --- a/module/system/il/ghil.scm +++ b/module/system/il/ghil.scm @@ -97,7 +97,7 @@ ghil-reified-env-env ghil-reified-env-loc ghil-env-add! - ghil-env-reify + ghil-env-reify ghil-env-dereify 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)) @@ -294,6 +294,16 @@ (filter (lambda (v) (eq? (ghil-var-kind v) 'external)) variables))))))) +(define (ghil-env-dereify name-index-alist) + (let* ((e (make-ghil-env (make-ghil-toplevel-env))) + (vars (map (lambda (pair) + (make-ghil-var e (car pair) 'external (cdr pair))) + name-index-alist))) + (set! (ghil-env-table e) + (map (lambda (v) (cons (ghil-var-name v) v)) vars)) + (set! (ghil-env-variables e) vars) + e)) + ;;; ;;; Parser |