1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-01 12:20:26 +02:00

compilation passes return third value: the continuation environment

* module/system/base/compile.scm: Expect compile passes to produce three
  values, not two. The third is the "continuation environment", the
  environment that can be used to compile a subsequent expression from
  the same source language. For example, expansion-time side effects can
  set the current module, which would be reflected appropriately in the
  continuation environment.

* module/language/assembly/compile-bytecode.scm:
* module/language/bytecode/spec.scm:
* module/language/ecmascript/compile-ghil.scm:
* module/language/ghil/compile-glil.scm:
* module/language/glil/spec.scm:
* module/language/objcode/spec.scm:
* module/language/scheme/compile-ghil.scm:
* module/system/base/compile.scm: Update compile passes to return a
  continuation environment.
This commit is contained in:
Andy Wingo 2009-04-16 15:20:40 +02:00
parent 275baf0113
commit b41b92c9d1
8 changed files with 19 additions and 12 deletions

View file

@ -40,7 +40,7 @@
(get-addr (lambda () i))) (get-addr (lambda () i)))
(write-bytecode assembly write-byte get-addr '()) (write-bytecode assembly write-byte get-addr '())
(if (= i (u8vector-length v)) (if (= i (u8vector-length v))
(values v env) (values v env env)
(error "incorrect length in assembly" i (u8vector-length v))))) (error "incorrect length in assembly" i (u8vector-length v)))))
(else (error "bad assembly" assembly)))) (else (error "bad assembly" assembly))))

View file

@ -25,7 +25,7 @@
#:export (bytecode)) #:export (bytecode))
(define (compile-objcode x e opts) (define (compile-objcode x e opts)
(values (bytecode->objcode x) e)) (values (bytecode->objcode x) e e))
(define (decompile-objcode x e opts) (define (decompile-objcode x e opts)
(values (objcode->bytecode x) e)) (values (objcode->bytecode x) e))

View file

@ -41,6 +41,7 @@
(-> (lambda vars #f '() (-> (lambda vars #f '()
(-> (begin (list (@impl js-init '()) (-> (begin (list (@impl js-init '())
(comp exp e))))))))) (comp exp e)))))))))
env
env)) env))
(define (location x) (define (location x)

View file

@ -29,7 +29,8 @@
(define (compile-glil x e opts) (define (compile-glil x e opts)
(if (memq #:O opts) (set! x (optimize x))) (if (memq #:O opts) (set! x (optimize x)))
(values (codegen x) (values (codegen x)
(and e (cons (car e) (cddr e))))) (and e (cons (car e) (cddr e)))
e))
;;; ;;;

View file

@ -30,7 +30,7 @@
(apply write (unparse-glil exp) port)) (apply write (unparse-glil exp) port))
(define (compile-asm x e opts) (define (compile-asm x e opts)
(values (compile-assembly x) e)) (values (compile-assembly x) e e))
(define-language glil (define-language glil
#:title "Guile Lowlevel Intermediate Language (GLIL)" #:title "Guile Lowlevel Intermediate Language (GLIL)"

View file

@ -40,8 +40,8 @@
(save-module-excursion (save-module-excursion
(lambda () (lambda ()
(set-current-module (objcode-env-module e)) (set-current-module (objcode-env-module e))
(values (thunk) #f))) (values (thunk) #f e)))
(values (thunk) #f)))) (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

View file

@ -56,6 +56,8 @@
((pair? env) (cddr env)) ((pair? env) (cddr env))
(else (error "bad environment" env)))) (else (error "bad environment" env))))
(define (make-cenv module lexicals externals)
(cons module (cons lexicals externals)))
@ -65,11 +67,14 @@
(and=> (cenv-module e) set-current-module) (and=> (cenv-module e) set-current-module)
(call-with-ghil-environment (cenv-ghil-env e) '() (call-with-ghil-environment (cenv-ghil-env e) '()
(lambda (env vars) (lambda (env vars)
(values (make-ghil-lambda env #f vars #f '() (translate-1 env #f x)) (let ((x (make-ghil-lambda env #f vars #f '()
(translate-1 env #f x))))
(values x
(and e (and e
(cons* (cenv-module e) (cons* (cenv-module e)
(ghil-env-parent env) (ghil-env-parent env)
(cenv-externals e))))))))) (cenv-externals e)))
(make-cenv (current-module) '() '()))))))))
;;; ;;;

View file

@ -157,7 +157,7 @@
(define (compile-fold passes exp env opts) (define (compile-fold passes exp env opts)
(if (null? passes) (if (null? passes)
exp exp
(receive (exp env) ((car passes) exp env opts) (receive (exp env cenv) ((car passes) exp env opts)
(compile-fold (cdr passes) exp env opts)))) (compile-fold (cdr passes) exp env opts))))
(define (compile-time-environment) (define (compile-time-environment)