From 3de80ed52f7482faee2ce883d3df21eb8a38ee7a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 30 Oct 2008 10:57:36 +0100 Subject: [PATCH] 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. --- ice-9/boot-9.scm | 21 +++--- libguile/objcodes.c | 9 ++- libguile/objcodes.h | 2 +- libguile/vm-i-system.c | 6 ++ libguile/vm.c | 2 +- module/language/scheme/translate.scm | 13 +++- module/system/base/compile.scm | 100 +++++++++++++++++++++------ module/system/base/syntax.scm | 5 +- module/system/il/ghil.scm | 12 +++- scripts/compile | 20 +----- test-suite/tests/compiler.test | 62 +++++++++++++++++ 11 files changed, 198 insertions(+), 54 deletions(-) create mode 100644 test-suite/tests/compiler.test diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 5843865fa..e32964ae4 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -123,13 +123,6 @@ (else (loop (cdr clauses)))))))) -(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) - ;; Before compiling, make sure any symbols are resolved in the (guile) @@ -2982,7 +2975,6 @@ module '(ice-9 q) '(make-q q-length))}." ;; Indeed, all references to global variables are memoized into such ;; variable objects. -;; FIXME: these don't work with the compiler (define-macro (@ mod-name var-name) (let ((var (module-variable (resolve-interface mod-name) var-name))) (if (not var) @@ -3000,6 +2992,19 @@ module '(ice-9 q) '(make-q q-length))}." +;;; {Compiler interface} +;;; +;;; The full compiler interface can be found in (system). Here we put a +;;; few useful procedures into the global namespace. + +(module-autoload! the-scm-module + '(system base compile) + '(compile + compile-time-environment)) + + + + ;;; {Parameters} ;;; diff --git a/libguile/objcodes.c b/libguile/objcodes.c index 6891e8a6a..bb2810ff5 100644 --- a/libguile/objcodes.c +++ b/libguile/objcodes.c @@ -254,8 +254,8 @@ SCM_DEFINE (scm_objcode_to_u8vector, "objcode->u8vector", 1, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_objcode_to_program, "objcode->program", 1, 0, 0, - (SCM objcode), +SCM_DEFINE (scm_objcode_to_program, "objcode->program", 1, 1, 0, + (SCM objcode, SCM external), "") #define FUNC_NAME s_scm_objcode_to_program { @@ -265,6 +265,10 @@ SCM_DEFINE (scm_objcode_to_program, "objcode->program", 1, 0, 0, struct scm_program *p; SCM_VALIDATE_OBJCODE (1, objcode); + if (SCM_UNBNDP (external)) + external = SCM_EOL; + else + SCM_VALIDATE_LIST (2, external); base = SCM_OBJCODE_BASE (objcode); size = SCM_OBJCODE_SIZE (objcode); @@ -272,6 +276,7 @@ SCM_DEFINE (scm_objcode_to_program, "objcode->program", 1, 0, 0, p = SCM_PROGRAM_DATA (prog); p->nlocs = base[8]; p->nexts = base[9]; + p->external = external; return prog; } #undef FUNC_NAME diff --git a/libguile/objcodes.h b/libguile/objcodes.h index 2cedefa98..5e4808b4c 100644 --- a/libguile/objcodes.h +++ b/libguile/objcodes.h @@ -61,7 +61,7 @@ extern scm_t_bits scm_tc16_objcode; #define SCM_OBJCODE_FD(x) (SCM_OBJCODE_DATA (x)->fd) extern SCM scm_load_objcode (SCM file); -extern SCM scm_objcode_to_program (SCM objcode); +extern SCM scm_objcode_to_program (SCM objcode, SCM external); extern SCM scm_objcode_p (SCM obj); extern SCM scm_bytecode_to_objcode (SCM bytecode, SCM nlocs, SCM nexts); extern SCM scm_objcode_to_u8vector (SCM objcode); diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index 2da2d4249..ca1dbcaf8 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -413,6 +413,12 @@ VM_DEFINE_INSTRUCTION (late_variable_set, "late-variable-set", 1, 1, 0) NEXT; } +VM_DEFINE_INSTRUCTION (externals, "externals", 0, 0, 1) +{ + PUSH (external); + NEXT; +} + /* * branch and jump diff --git a/libguile/vm.c b/libguile/vm.c index c0cf672d5..08629f0b7 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -743,7 +743,7 @@ SCM_DEFINE (scm_vm_fetch_stack, "vm-fetch-stack", 1, 0, 0, SCM scm_load_compiled_with_vm (SCM file) { - SCM program = scm_objcode_to_program (scm_load_objcode (file)); + SCM program = scm_objcode_to_program (scm_load_objcode (file), SCM_EOL); return vm_run (scm_the_vm (), program, SCM_EOL); } diff --git a/module/language/scheme/translate.scm b/module/language/scheme/translate.scm index 9719a4bbd..36dcc49a5 100644 --- a/module/language/scheme/translate.scm +++ b/module/language/scheme/translate.scm @@ -31,7 +31,7 @@ (define (translate x e) - (call-with-ghil-environment (make-ghil-toplevel-env) '() + (call-with-ghil-environment e '() (lambda (env vars) (make-ghil-lambda env #f vars #f '() (trans env (location x) x))))) @@ -383,8 +383,17 @@ ((,x) (retrans x)) (,args (make-ghil-values e l (map retrans args)))) + ;; (compile-time-environment) + ;; => (MODULE LEXICALS . EXTERNALS) (compile-time-environment - (() (make-ghil-reified-env e l))))) + (() (make-ghil-inline + e l 'cons + (list (retrans '(current-module)) + (make-ghil-inline + e l 'cons + (list (make-ghil-reified-env e l) + (make-ghil-inline e l 'externals '()))))))) + )) (define (lookup-apply-transformer proc) (cond ((eq? proc values) 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 diff --git a/scripts/compile b/scripts/compile index ebe810a20..0915c617d 100755 --- a/scripts/compile +++ b/scripts/compile @@ -71,20 +71,6 @@ Report bugs to .~%") (if expand-only? '(#:e) '()) (if translate-only? '(#:t) '()) (if compile-only? '(#:c) '())))) - - (catch #t - (lambda () - (for-each (lambda (file) - (apply compile-file file compile-opts)) - (option-ref options '() '()))) - (lambda (key . args) - (format (current-error-port) "exception `~a' caught~a~%" key - (if (null? args) "" - (if (string? (car args)) - (string-append " in subr `" (car args) "'") - ""))) - - (format (current-error-port) "removing compiled files due to errors~%") - (false-if-exception - (for-each unlink (map compiled-file-name files))) - (exit 1)))))) + (for-each (lambda (file) + (apply compile-file file compile-opts)) + (option-ref options '() '()))))) diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test new file mode 100644 index 000000000..dc27d6dc1 --- /dev/null +++ b/test-suite/tests/compiler.test @@ -0,0 +1,62 @@ +;;;; compiler.test --- tests for the compiler -*- scheme -*- +;;;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1999, 2001, 2006 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 2.1 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (test-suite tests compiler) + :use-module (test-suite lib) + :use-module (test-suite guile-test) + :use-module (system vm program)) + + +(with-test-prefix "environments" + + (pass-if "compile-time-environment in evaluator" + (eq? (primitive-eval '(compile-time-environment)) #f)) + + (pass-if "compile-time-environment in compiler" + (equal? (compile '(compile-time-environment)) + (cons (current-module) + (cons '() '())))) + + (let ((env (compile + '(let ((x 0)) (set! x 1) (compile-time-environment))))) + (pass-if "compile-time-environment in compiler, heap-allocated var" + (equal? env + (cons (current-module) + (cons '((x . 0)) '(1))))) + + ;; fixme: compiling with #t or module + (pass-if "recompiling with environment" + (equal? ((compile '(lambda () x) env)) + 1)) + + (pass-if "recompiling with environment/2" + (equal? ((compile '(lambda () (set! x (1+ x)) x) env)) + 2)) + + (pass-if "recompiling with environment/3" + (equal? ((compile '(lambda () x) env)) + 2)) + ) + + (pass-if "compile environment is #f" + (equal? ((compile '(lambda () 10))) + 10)) + + (pass-if "compile environment is a module" + (equal? ((compile '(lambda () 10) (current-module))) + 10)) + ) \ No newline at end of file -- 2.20.1