mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-18 10:10:23 +02:00
Code Activity

nifty generic compiler infrastructure -- no more hardcoded passes

Browse source 
* module/system/base/language.scm (<language>): Rework so that instead of
  hardcoding passes in the language, we define compilers that translate
  from one language to another. Add `parser' to the language fields, a
  bit of a hack but useful for languages with s-expression external
  representations but with record internal representations.
  (define-language, *compilation-cache*, invalidate-compilation-cache!)
  (compute-compilation-order, lookup-compilation-order): Add an algorithm
  that does a depth-first search for a translation path from a source
  language to a target language, caching the result in a lookup table.

* module/language/scheme/spec.scm:
* module/language/ghil/spec.scm: Update to the new language format.

* module/language/glil/spec.scm: Add a language specification for GLIL,
  with a compiler to objcode. Also there are parsers and printers, for
  repl usage, but for some reason this doesn't work yet.

* module/language/objcode/spec.scm: Define a language specification for
  object code. There is some sleight of hand here, in the "compiler" to
  values; but there is method behind the madness, because this way we
  higher levels can pass environments (a module + externals pair) to
  objcode->program.

* module/language/value/spec.scm: Define a language specification for
  values. There is something intellectually dishonest about this, but it
  does serve its purpose as a foundation for the language hierarchy.

* configure.in:
* module/language/Makefile.am
* module/language/ghil/Makefile.am
* module/language/glil/Makefile.am
* module/language/objcode/Makefile.am
* module/language/value/Makefile.am:
  Autotomfoolery for the ghil, glil, objcode, and value languages.

* module/language/scheme/translate.scm (translate): Import the bits that
  understand `compile-time-environment' here, and pass on the relevant
  portions of the environment to the next compiler pass.

* module/system/base/compile.scm (current-language): New procedure, refs
  the current language fluid, or lazily sets it to scheme.
  (call-once, call-with-output-file/atomic): Refactor these bits to use
  with-throw-handler. No functional change.
  (compile-file, compile-and-load, compile-passes, compile-fold)
  (compile): Refactor the public interface of the compiler to be generic
  and simple. Uses `lookup-compilation-order' to find a path from the
  source language to the target language.

* module/system/base/syntax.scm (define-type): Adapt to changes in
  define-record.
  (define-record): Instead of expecting all slots in the first form,
  expect them in the body, and let the first form hold the options.

* module/system/il/compile.scm (compile): Adapt to the compilation pass
  API (three in and two out).

* module/system/il/ghil.scm (<ghil-var>, <ghil-env>)
  (<ghil-toplevel-env>): Adapt to define-record changes.

* module/system/il/glil.scm (<glil-vars>): Adapt to define-record
  changes.
  (<glil>, print-glil): Add a GLIL record printer that uses unparse.
  (parse-glil, unparse-glil): Update unparse (formerly known as pprint),
  and write a parse function.

* module/system/repl/common.scm (<repl>): Adapt to define-record changes.
  (repl-parse): New function, parses the read form using the current
  language. Something of a hack.
  (repl-compile): Adapt to changes in `compile'.
  (repl-eval): Fix up the does-the-language-have-a-compiler check for
  changes in <language>.

* module/system/repl/repl.scm (start-repl): Parse the form before eval.

* module/system/repl/command.scm (describe): Parse.
  (compile): Be more generic.
  (compile-file): Adapt to changes in compile-file.
  (disassemble, time, profile, trace): Parse.

* module/system/vm/debug.scm:
* module/system/vm/assemble.scm: Adapt to define-record changes.

* module/language/scheme/translate.scm (receive): Fix an important bug
  that gave `receive' letrec semantics instead of let semantics. Whoops!
This commit is contained in:
Andy Wingo 2008-11-14 22:42:31 +01:00
parent 7493339cfc
commit b0b180d522
27 changed files with 421 additions and 345 deletions
Download patch file Download diff file Expand all files Collapse all files

4
configure.in
View file

@ -1557,6 +1557,10 @@ AC_CONFIG_FILES([
module/system/repl/Makefile
module/language/Makefile
module/language/scheme/Makefile
module/language/ghil/Makefile
module/language/glil/Makefile
module/language/objcode/Makefile
module/language/value/Makefile
module/ice-9/Makefile
module/ice-9/debugger/Makefile
module/ice-9/debugging/Makefile

2
module/language/Makefile.am
View file

@ -1 +1 @@
SUBDIRS=scheme
SUBDIRS=scheme ghil glil objcode value

3
module/language/ghil/Makefile.am Normal file
View file

@ -0,0 +1,3 @@
SOURCES = spec.scm
modpath = language/ghil
include $(top_srcdir)/am/guilec

9
module/language/ghil/spec.scm
View file

@ -21,14 +21,16 @@
(define-module (language ghil spec)
#:use-module (system base language)
#:use-module (language glil spec)
#:use-module (system il ghil)
#:use-module ((system il compile) #:select ((compile . compile-il)))
#:export (ghil))
(define (write-ghil exp . port)
(apply write (unparse-ghil exp) port))
(define (translate x e)
(call-with-ghil-environment e '()
(define (parse x)
(call-with-ghil-environment (make-ghil-toplevel-env e) '()
(lambda (env vars)
(make-ghil-lambda env #f vars #f '() (parse-ghil env x)))))
@ -37,5 +39,6 @@
#:version "0.3"
#:reader read
#:printer write-ghil
#:translator translate
#:parser parse
#:compilers `((,glil . ,compile-il))
)

3
module/language/glil/Makefile.am Normal file
View file

@ -0,0 +1,3 @@
SOURCES = spec.scm
modpath = language/glil
include $(top_srcdir)/am/guilec

48
module/language/glil/spec.scm Normal file
View file

@ -0,0 +1,48 @@
;;; Guile Lowlevel Intermediate Language
;; Copyright (C) 2001 Free Software Foundation, Inc.
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;;
;; This program 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 General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Code:
(define-module (language glil spec)
#:use-module (system base language)
#:use-module (language objcode spec)
#:use-module (system il glil)
#:use-module (system vm assemble)
#:export (glil))
(define (write-glil exp . port)
(apply write (unparse-glil exp) port))
(define (translate x)
;; Don't wrap in a thunk -- if you're down in these weeds you can
;; thunk it yourself. We don't know how many locs there will be,
;; anyway.
(parse-glil x))
(define (compile x e opts)
(values (assemble x e) e))
(define-language glil
#:title "Guile Lowlevel Intermediate Language (GLIL)"
#:version "0.3"
#:reader read
#:printer write-glil
#:parser translate
#:compilers `((,objcode . ,compile))
)

3
module/language/objcode/Makefile.am Normal file
View file

@ -0,0 +1,3 @@
SOURCES = spec.scm
modpath = language/objcode
include $(top_srcdir)/am/guilec

52
module/language/objcode/spec.scm Normal file
View file

@ -0,0 +1,52 @@
;;; Guile Lowlevel Intermediate Language
;; Copyright (C) 2001 Free Software Foundation, Inc.
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;;
;; This program 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 General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Code:
(define-module (language objcode spec)
#:use-module (system base language)
#:use-module (language value spec)
#:use-module (system vm objcode)
#:export (objcode make-objcode-env))
(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)
(if env (cdr env) '()))
(define (objcode->value x e opts)
(let ((thunk (objcode->program x (objcode-env-externals e))))
(if e
(save-module-excursion
(lambda ()
(set-current-module (objcode-env-module e))
(values (thunk) #f)))
(values (thunk) #f))))
(define-language objcode
#:title "Guile Object Code"
#:version "0.3"
#:reader #f
#:printer (lambda (x port) (uniform-vector-write (objcode->u8vector x) port))
#:compilers `((,value . ,objcode->value))
)

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

@ -20,8 +20,9 @@
;;; Code:
(define-module (language scheme spec)
#:use-module (language scheme translate)
#:use-module (system base language)
#:use-module (language scheme translate)
#:use-module (language ghil spec)
#:export (scheme))
;;;
@ -45,7 +46,7 @@
#:version "0.5"
#:reader read
#:read-file read-file
#:translator translate
#:compilers `((,ghil . ,translate))
#:evaluator (lambda (x module) (primitive-eval x))
#:printer write
)

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

@ -24,17 +24,52 @@
#:use-module (system base language)
#:use-module (system il ghil)
#:use-module (system il inline)
#:use-module (system vm objcode)
#:use-module (ice-9 receive)
#:use-module (ice-9 optargs)
#:use-module ((ice-9 syncase) #:select (sc-macro))
#:use-module ((system base compile) #:select (syntax-error))
#:export (translate translate-1
*translate-table* define-scheme-translator))
(define (translate x e)
(call-with-ghil-environment e '()
;;; 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 (translate x e opts)
(save-module-excursion
(lambda ()
(and=> (cenv-module e) set-current-module)
(call-with-ghil-environment (cenv-ghil-env e) '()
(lambda (env vars)
(make-ghil-lambda env #f vars #f '() (translate-1 env #f x)))))
(values (make-ghil-lambda env #f vars #f '() (translate-1 env #f x))
(and e
(cons* (cenv-module e)
(ghil-env-parent env)
(cenv-externals e)))))))))
;;;
@ -375,10 +410,11 @@
;; macro would do the trick; but it's good to test the mv-bind
;; code.
(receive (syms rest) (parse-formals formals)
(let ((producer (retrans `(lambda () ,producer-exp))))
(call-with-ghil-bindings e syms
(lambda (vars)
(make-ghil-mv-bind e l (retrans `(lambda () ,producer-exp))
vars rest (trans-body e l body)))))))
(make-ghil-mv-bind e l producer
vars rest (trans-body e l body))))))))
(define-scheme-translator values
((,x) (retrans x))

3
module/language/value/Makefile.am Normal file
View file

@ -0,0 +1,3 @@
SOURCES = spec.scm
modpath = language/value
include $(top_srcdir)/am/guilec

31
module/language/value/spec.scm Normal file
View file

@ -0,0 +1,31 @@
;;; Guile Lowlevel Intermediate Language
;; Copyright (C) 2001 Free Software Foundation, Inc.
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;;
;; This program 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 General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Code:
(define-module (language value spec)
#:use-module (system base language)
#:export (value))
(define-language value
#:title "Guile Values"
#:version "0.3"
#:reader #f
#:printer write
)

6
module/oop/goops.scm
View file

@ -1086,17 +1086,17 @@
(if (unbound? x)
(slot-unbound obj)
x)))
*goops-module*))
#:env *goops-module*))
(define (make-get index)
((@ (system base compile) compile)
`(lambda (o) (@slot-ref o ,index))
*goops-module*))
#:env *goops-module*))
(define (make-set index)
((@ (system base compile) compile)
`(lambda (o v) (@slot-set! o ,index v))
*goops-module*))
#:env *goops-module*))
(define bound-check-get
(standard-accessor-method make-bound-check-get bound-check-get-methods))

2
module/oop/goops/compile.scm
View file

@ -148,7 +148,7 @@
,@(improper->proper formals)))
(apply ,next-method-sym args)))))
,@body)))
(slot-ref method 'compile-env))))
#:env (slot-ref method 'compile-env))))
(list-set! (program-external cmethod) 0
(make-next-method (method-generic-function method)
(cdr methods)

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

@ -20,23 +20,18 @@
;;; Code:
(define-module (system base compile)
#:use-syntax (system base syntax)
#:use-module (system base syntax)
#:use-module (system base language)
#: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 assemble)
#:use-module (system vm vm) ;; for compile-time evaluation
#:use-module (language objcode spec)
#:use-module (language value spec)
#:use-module (system vm vm) ;; FIXME: there's a reason for this, can't remember why tho
#:use-module (ice-9 regex)
#:use-module (ice-9 optargs)
#:use-module ((srfi srfi-1) #:select (fold))
#:export (syntax-error compile-file load-source-file load-file
#:use-module (ice-9 receive)
#:export (syntax-error
*current-language*
compiled-file-name
compile-time-environment
compile read-file-in compile-in
load/compile)
compiled-file-name compile-file compile-and-load
compile compile-time-environment)
#:export-syntax (call-with-compile-error-catch))
;;;
@ -62,48 +57,47 @@
;;;
(define *current-language* (make-fluid))
(define (current-language)
(or (fluid-ref *current-language*)
(begin (fluid-set! *current-language* (lookup-language 'scheme))
(current-language))))
;; This is basically to avoid mucking with the backtrace.
(define (call-with-nonlocal-exit-protect thunk on-nonlocal-exit)
(let ((success #f) (entered #f))
(define (call-once thunk)
(let ((entered #f))
(dynamic-wind
(lambda ()
(if entered
(error "thunk may only be entered once: ~a" thunk))
(set! entered #t))
(lambda ()
(thunk)
(set! success #t))
(lambda ()
(if (not success)
(on-nonlocal-exit))))))
thunk
(lambda () #t))))
(define (call-with-output-file/atomic filename proc)
(let* ((template (string-append filename ".XXXXXX"))
(tmp (mkstemp! template)))
(call-with-nonlocal-exit-protect
(call-once
(lambda ()
(with-throw-handler #t
(lambda ()
(with-output-to-port tmp
(lambda () (proc (current-output-port))))
(rename-file template filename))
(lambda ()
(delete-file template)))))
(lambda args
(delete-file template)))))))
(define (compile-file file . opts)
(define* (compile-file file #:key (to objcode) (opts '()))
(let ((comp (compiled-file-name file))
(lang (fluid-ref *current-language*)))
(lang (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 lang))
(objcode (apply compile-in source (current-module)
lang opts)))
(if (memq #:c opts)
(pprint-glil objcode port)
(uniform-vector-write (objcode->u8vector objcode) port)))))
(let ((print (language-printer to)))
(print (compile (read-file-in file lang)
#:from lang #:to to #:opts opts)
port))))
(format #t "wrote `~A'\n" comp))))
(lambda (key . args)
(format #t "ERROR: during compilation of ~A:\n" file)
@ -113,25 +107,9 @@
(format #t "ERROR: ~A ~A ~A\n" key (car args) (cadddr args))
(delete-file comp)))))
; (let ((c-f compile-file))
; ;; XXX: Debugging output
; (set! compile-file
; (lambda (file . opts)
; (format #t "compile-file: ~a ~a~%" file opts)
; (let ((result (apply c-f (cons file opts))))
; (format #t "compile-file: returned ~a~%" result)
; result))))
(define (load-source-file file . 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)))
(if (file-exists? comp)
(load-objcode comp)
(apply load-source-file file opts))))
(define* (compile-and-load file #:key (to value) (opts '()))
(let ((lang (current-language)))
(compile (read-file-in file lang) #:to value #:opts opts)))
(define (compiled-file-name file)
(let ((base (basename file))
@ -151,28 +129,32 @@
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))))
;;;
;;; Compiler interface
;;;
(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 (read-file-in file lang)
(call-with-input-file file
(or (language-read-file lang)
(error "language has no #:read-file" lang))))
(define (cenv-externals env)
(cond ((not env) '())
((module? env) '())
((pair? env) (cddr env))
(else (error "bad environment" env))))
(define (compile-passes from to opts)
(let lp ((langs (or (lookup-compilation-order from to)
(error "no way to compile" (language-name from)
"to" (language-name to))))
(out '()))
(if (null? (cdr langs))
(reverse! out)
(lp (cdr langs)
(cons (assq-ref (language-compilers (car langs)) (cadr langs))
out)))))
(define (compile-fold passes exp env opts)
(if (null? passes)
exp
(receive (exp env) ((car passes) exp env opts)
(compile-fold (cdr passes) exp env opts))))
(define (compile-time-environment)
"A special function known to the compiler that, when compiled, will
@ -181,82 +163,12 @@ 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))))))
;;;
;;; Scheme compiler interface
;;;
(define (read-file-in file lang)
(call-with-input-file file (or (language-read-file lang)
(error "language has no #:read-file" lang))))
;;; FIXME: fold run-pass x (compile-passes lang opts)
(define (compile-passes lang opts)
(let lp ((passes (list
(language-expander lang)
(language-translator lang)
(lambda (x e) (apply compile-il x e opts))
(lambda (x e) (apply assemble x e opts))))
(keys '(#f #:e #:t #:c))
(out '()))
(if (or (null? keys)
(and (car keys) (memq (car keys) opts)))
(reverse! out)
(lp (cdr passes) (cdr keys)
(if (car passes)
(cons (car passes) out)
out)))))
(define (compile-in x e lang . opts)
(save-module-excursion
(lambda ()
(and=> (cenv-module e) set-current-module)
(let ((env (cenv-ghil-env e)))
(fold (lambda (pass exp)
(pass exp env))
(define* (compile x #:key
(env #f)
(from (current-language))
(to value)
(opts '()))
(compile-fold (compile-passes from to opts)
x
(compile-passes lang opts))))))
;;;
;;;
;;;
(define (compile-and-load file . opts)
(let ((comp (object-file-name file)))
(if (or (not (file-exists? comp))
(> (stat:mtime (stat file)) (stat:mtime (stat comp))))
(compile-file file))
(load-compiled-file comp)))
(define (load/compile file . opts)
(let* ((file (file-full-name file))
(compiled (object-file-name file)))
(if (or (not (file-exists? compiled))
(> (stat:mtime (stat file)) (stat:mtime (stat compiled))))
(apply compile-file file #f opts))
(if (memq #:b opts)
(apply vm-trace (the-vm) (load-objcode compiled) opts)
((the-vm) (load-objcode compiled)))))
(define (file-full-name filename)
(let* ((port (current-load-port))
(oldname (and port (port-filename port))))
(if (and oldname
(> (string-length filename) 0)
(not (char=? (string-ref filename 0) #\/))
(not (string=? (dirname oldname) ".")))
(string-append (dirname oldname) "/" filename)
filename)))
(fluid-set! *current-language* (lookup-language 'scheme))
env
opts))

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

@ -20,30 +20,56 @@
;;; Code:
(define-module (system base language)
#:use-syntax (system base syntax)
#:use-module (system base syntax)
#:export (define-language lookup-language make-language
language-name language-title language-version language-reader
language-printer language-read-file language-expander
language-translator language-evaluator language-environment))
language-printer language-parser language-read-file
language-compilers language-evaluator
lookup-compilation-order invalidate-compilation-cache!))
;;;
;;; Language class
;;;
(define-record (<language> name title version reader printer
(define-record <language>
name
title
version
reader
printer
(parser #f)
(read-file #f)
(expander #f)
(translator #f)
(evaluator #f)
(environment #f)
))
(compilers '())
(evaluator #f))
(define-macro (define-language name . spec)
`(define ,name (make-language #:name ',name ,@spec)))
`(begin
(invalidate-compilation-cache!)
(define ,name (make-language #:name ',name ,@spec))))
(define (lookup-language name)
(let ((m (resolve-module `(language ,name spec))))
(if (module-bound? m name)
(module-ref m name)
(error "no such language" name))))
(define *compilation-cache* '())
(define (invalidate-compilation-cache!)
(set! *compilation-cache* '()))
(define (compute-compilation-order from to)
(let lp ((from from) (seen '()))
(cond ((eq? from to) (reverse! (cons from seen)))
((memq from seen) #f)
(else (or-map (lambda (lang) (lp lang (cons from seen)))
(map car (language-compilers from)))))))
(define (lookup-compilation-order from to)
(or (assoc-ref *compilation-cache* (cons from to))
(let ((order (compute-compilation-order from to)))
(set! *compilation-cache*
(acons (cons from to) order *compilation-cache*))
order)))

14
module/system/base/syntax.scm
View file

@ -32,8 +32,11 @@
(let ((name (if (pair? name) (car name) name))
(opts (if (pair? name) (cdr name) '())))
(let ((printer (kw-arg-ref opts #:printer)))
`(begin ,@(map (lambda (def) `(define-record ,def
,@(if printer (list printer) '())))
`(begin ,@(map (lambda (def)
`(define-record ,(if printer
`(,(car def) ,printer)
(car def))
,@(cdr def)))
rest)))))
@ -44,14 +47,15 @@
(define (symbol-trim-both sym pred)
(string->symbol (string-trim-both (symbol->string sym) pred)))
(define-macro (define-record def . printer)
(let* ((name (car def)) (slots (cdr def))
(define-macro (define-record name-form . slots)
(let* ((name (if (pair? name-form) (car name-form) name-form))
(printer (and (pair? name-form) (cadr name-form)))
(slot-names (map (lambda (slot) (if (pair? slot) (car slot) slot))
slots))
(stem (symbol-trim-both name (list->char-set '(#\< #\>)))))
`(begin
(define ,name (make-record-type ,(symbol->string name) ',slot-names
,@printer))
,@(if printer (list printer) '())))
(define ,(symbol-append 'make- stem)
(let ((slots (list ,@(map (lambda (slot)
(if (pair? slot)

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

@ -26,9 +26,10 @@
#:use-module (ice-9 common-list)
#:export (compile))
(define (compile x e . opts)
(define (compile x e opts)
(if (memq #:O opts) (set! x (optimize x)))
(codegen x))
(values (codegen x)
(and e (cons (car e) (cddr e)))))
;;;

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

@ -145,7 +145,7 @@
;;; Variables
;;;
(define-record (<ghil-var> env name kind (index #f)))
(define-record <ghil-var> env name kind (index #f))
;;;
@ -157,8 +157,8 @@
;;; Environments
;;;
(define-record (<ghil-env> parent (table '()) (variables '())))
(define-record (<ghil-toplevel-env> (table '())))
(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))

161
module/system/il/glil.scm
View file

@ -20,10 +20,10 @@
;;; Code:
(define-module (system il glil)
#:use-syntax (system base syntax)
#:use-module (system base syntax)
#:use-module (system base pmatch)
#:export
(pprint-glil
<glil-vars> make-glil-vars
(<glil-vars> make-glil-vars
glil-vars-nargs glil-vars-nrest glil-vars-nlocs glil-vars-nexts
<glil-asm> make-glil-asm glil-asm?
@ -70,11 +70,16 @@
glil-call-inst glil-call-nargs
<glil-mv-call> make-glil-mv-call glil-mv-call?
glil-mv-call-nargs glil-mv-call-ra))
glil-mv-call-nargs glil-mv-call-ra
(define-record (<glil-vars> nargs nrest nlocs nexts))
parse-glil unparse-glil))
(define-type <glil>
(define-record <glil-vars> nargs nrest nlocs nexts)
(define (print-glil x port)
(format port "#<glil ~s>" (unparse-glil x)))
(define-type (<glil> #:printer print-glil)
;; Meta operations
(<glil-asm> vars meta body)
(<glil-bind> vars)
@ -97,125 +102,57 @@
(<glil-mv-call> nargs ra))
;;;
;;; Parser
;;;
(define (parse-glil x)
(pmatch x
((asm (,nargs ,nrest ,nlocs ,next) ,meta . ,body)
(make-glil-asm (make-glil-vars nargs nrest nlocs next)
meta (map parse-glil body)))
((bind . ,vars) (make-glil-bind vars))
((mv-bind ,vars . ,rest) (make-glil-mv-bind vars (map parse-glil rest)))
((unbind) (make-glil-unbind))
((source ,loc) (make-glil-source loc))
((void) (make-glil-void))
((const ,obj) (make-glil-const obj))
((argument ,op ,index) (make-glil-argument op index))
((local ,op ,index) (make-glil-local op index))
((external ,op ,depth ,index) (make-glil-external op depth index))
((toplevel ,op ,name) (make-glil-toplevel op name))
((module public ,op ,mod ,name) (make-glil-module op mod name #t))
((module private ,op ,mod ,name) (make-glil-module op mod name #f))
((label ,label) (make-label ,label))
((branch ,inst ,label) (make-glil-branch inst label))
((call ,inst ,nargs) (make-glil-call inst nargs))
((mv-call ,nargs ,ra) (make-glil-mv-call nargs ra))
(else (error "invalid glil" x))))
;;; (define (parse-glil x)
;;; (match x
;;; (('@asm args . body)
;;; (let* ((env (make-new-env e))
;;; (args (parse-args args env)))
;;; (make-asm env args (map-parse body env))))
;;; (else
;;; (error "Invalid assembly code:" x))))
;;;
;;; (define (parse-args x e)
;;; (let ((args (cond ((symbol? x) (make-args (list (make-local-var x)) #t))
;;; ((list? x) (make-args (map make-local-var x) #f))
;;; (else (let loop ((l x) (v '()))
;;; (if (pair? l)
;;; (loop (cdr l) (cons (car l) v))
;;; (make-args (map make-local-var
;;; (reverse! (cons l v)))
;;; #t)))))))
;;; (for-each (lambda (v) (env-add! e v)) (args-vars args))
;;; args))
;;;
;;; (define (map-parse x e)
;;; (map (lambda (x) (parse x e)) x))
;;;
;;; (define (parse x e)
;;; (match x
;;; ;; (@asm ARGS BODY...)
;;; (('@asm args . body)
;;; (parse-asm x e))
;;; ;; (@bind VARS BODY...)
;;; ;; (@block VARS BODY...)
;;; (((or '@bind '@block) vars . body)
;;; (let* ((offset (env-nvars e))
;;; (vars (args-vars (parse-args vars e)))
;;; (block (make-block (car x) offset vars (map-parse body e))))
;;; (for-each (lambda (v) (env-remove! e)) vars)
;;; block))
;;; ;; (void)
;;; (('void)
;;; (make-void))
;;; ;; (const OBJ)
;;; (('const obj)
;;; (make-const obj))
;;; ;; (ref NAME)
;;; ;; (set NAME)
;;; (((or 'ref 'set) name)
;;; (make-access (car x) (env-ref e name)))
;;; ;; (label LABEL)
;;; (('label label)
;;; (make-label label))
;;; ;; (br-if LABEL)
;;; ;; (jump LABEL)
;;; (((or 'br-if 'jump) label)
;;; (make-instl (car x) label))
;;; ;; (call NARGS)
;;; ;; (tail-call NARGS)
;;; (((or 'call 'goto/args) n)
;;; (make-instn (car x) n))
;;; ;; (INST)
;;; ((inst)
;;; (if (instruction? inst)
;;; (make-inst inst)
;;; (error "Unknown instruction:" inst)))))
;;;
;;; Unparser
;;;
(define (unparse glil)
(define (unparse-glil glil)
(record-case glil
;; meta
((<glil-asm> vars meta body)
`(@asm (,(glil-vars-nargs vars) ,(glil-vars-nrest vars)
`(asm (,(glil-vars-nargs vars) ,(glil-vars-nrest vars)
,(glil-vars-nlocs vars) ,(glil-vars-nexts vars))
,meta
,@(map unparse body)))
((<glil-bind> vars) `(@bind ,@vars))
((<glil-unbind>) `(@unbind))
((<glil-source> loc) `(@source ,loc))
,@(map unparse-glil body)))
((<glil-bind> vars) `(bind ,@vars))
((<glil-mv-bind> vars rest) `(mv-bind ,vars ,@rest))
((<glil-unbind>) `(unbind))
((<glil-source> loc) `(source ,loc))
;; constants
((<glil-void>) `(void))
((<glil-const> obj) `(const ,obj))
;; variables
((<glil-argument> op index)
`(,(symbol-append 'argument- op) ,index))
`(argument ,op ,index))
((<glil-local> op index)
`(,(symbol-append 'local- op) ,index))
`(local ,op ,index))
((<glil-external> op depth index)
`(,(symbol-append 'external- op) ,depth ,index))
`(external ,op ,depth ,index))
((<glil-toplevel> op name)
`(,(symbol-append 'toplevel- op) ,name))
`(toplevel ,op ,name))
((<glil-module> op mod name public?)
`(,(symbol-append (if public? 'public 'private) '- op) ,mod ,name))
`(module ,(if public? 'public 'private) ,op ,mod ,name))
;; controls
((<glil-label> label) label)
((<glil-branch> inst label) `(,inst ,label))
((<glil-call> inst nargs) `(,inst ,nargs))))
;;;
;;; Printer
;;;
(define (pprint-glil glil . port)
(let ((port (if (pair? port) (car port) (current-output-port))))
(let print ((code (unparse glil)) (column 0))
(display (make-string column #\space) port)
(cond ((and (pair? code) (eq? (car code) '@asm))
(format port "(@asm ~A\n" (cadr code))
(let ((col (+ column 2)))
(let loop ((l (cddr code)))
(print (car l) col)
(if (null? (cdr l))
(display ")" port)
(begin (newline port) (loop (cdr l)))))))
(else (write code port))))
(newline port)))
((<glil-label> label) (label ,label))
((<glil-branch> inst label) `(branch ,inst ,label))
((<glil-call> inst nargs) `(call ,inst ,nargs))
((<glil-mv-call> nargs ra) `(mv-call ,nargs ,(unparse-glil ra)))))

23
module/system/repl/command.scm
View file

@ -28,7 +28,6 @@
#:use-module (system vm program)
#:use-module (system vm vm)
#:autoload (system base language) (lookup-language)
#:autoload (system il glil) (pprint-glil)
#:autoload (system vm disasm) (disassemble-program disassemble-objcode)
#:autoload (system vm debug) (vm-debugger vm-backtrace)
#:autoload (system vm trace) (vm-trace vm-trace-on vm-trace-off)
@ -168,7 +167,8 @@ Find bindings/modules/packages."
(define (describe repl obj)
"describe OBJ
Show description/documentation."
(display (object-documentation (repl-eval repl obj)))
(display (object-documentation
(repl-eval repl (repl-parse repl obj))))
(newline))
(define (option repl . args)
@ -266,21 +266,20 @@ Generate compiled code.
-O Enable optimization
-D Add debug information"
(let ((x (apply repl-compile repl form opts)))
(cond ((or (memq #:e opts) (memq #:t opts)) (puts x))
((memq #:c opts) (pprint-glil x))
(else (disassemble-objcode x)))))
(let ((x (apply repl-compile repl (repl-parse repl form) opts)))
(cond ((objcode? x) (disassemble-objcode x))
(else (repl-print repl x)))))
(define guile:compile-file compile-file)
(define (compile-file repl file . opts)
"compile-file FILE
Compile a file."
(apply guile:compile-file (->string file) opts))
(guile:compile-file (->string file) #:opts opts))
(define (disassemble repl prog)
"disassemble PROGRAM
Disassemble a program."
(disassemble-program (repl-eval repl prog)))
(disassemble-program (repl-eval repl (repl-parse repl prog))))
(define (disassemble-file repl file)
"disassemble-file FILE
@ -298,7 +297,7 @@ Time execution."
(let* ((vms-start (vm-stats (repl-vm repl)))
(gc-start (gc-run-time))
(tms-start (times))
(result (repl-eval repl form))
(result (repl-eval repl (repl-parse repl form)))
(tms-end (times))
(gc-end (gc-run-time))
(vms-end (vm-stats (repl-vm repl))))
@ -320,7 +319,7 @@ Time execution."
Profile execution."
(apply vm-profile
(repl-vm repl)
(repl-compile repl form)
(repl-compile repl (repl-parse repl form))
opts))
@ -346,7 +345,9 @@ Trace execution.
-l Display local variables
-e Display external variables
-b Bytecode level trace"
(apply vm-trace (repl-vm repl) (repl-compile repl form) opts))
(apply vm-trace (repl-vm repl)
(repl-compile repl (repl-parse repl form))
opts))
(define (step repl)
"step FORM

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

@ -27,7 +27,7 @@
#:export (<repl> make-repl repl-vm repl-language repl-options
repl-tm-stats repl-gc-stats repl-vm-stats
repl-welcome repl-prompt repl-read repl-compile repl-eval
repl-print repl-option-ref repl-option-set!
repl-parse repl-print repl-option-ref repl-option-set!
puts ->string user-error))
@ -35,7 +35,7 @@
;;; Repl type
;;;
(define-record (<repl> vm language options tm-stats gc-stats vm-stats))
(define-record <repl> vm language options tm-stats gc-stats vm-stats)
(define repl-default-options
'((trace . #f)
@ -65,15 +65,23 @@
((language-reader (repl-language repl))))
(define (repl-compile repl form . opts)
(apply compile-in form (current-module) (repl-language repl) opts))
(let ((to (lookup-language (cond ((memq #:e opts) 'scheme)
((memq #:t opts) 'ghil)
((memq #:c opts) 'glil)
(else 'objcode)))))
(compile form #:from (repl-language repl) #:to to #:opts opts)))
(define (repl-parse repl form)
(let ((parser (language-parser (repl-language repl))))
(if parser (parser form) form)))
(define (repl-eval repl form)
(let ((eval (language-evaluator (repl-language repl))))
(if (and eval
(or (not (language-translator (repl-language repl)))
(or (null? (language-compilers (repl-language repl)))
(assq-ref (repl-options repl) 'interp)))
(eval form (current-module))
(vm-load (repl-vm repl) (repl-compile repl form)))))
(vm-load (repl-vm repl) (repl-compile repl form '())))))
(define (repl-print repl val)
(if (not (eq? val *unspecified*))

3
module/system/repl/repl.scm
View file

@ -121,7 +121,8 @@
(call-with-values (lambda ()
(run-hook before-eval-hook exp)
(start-stack repl-eval
(repl-eval repl exp)))
(repl-eval repl
(repl-parse repl exp))))
(lambda l
(for-each (lambda (v)
(run-hook before-print-hook v)

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

@ -40,13 +40,13 @@
;;; Types
;;;
(define-record (<vm-asm> venv glil body))
(define-record (<venv> parent nexts closure?))
(define-record <vm-asm> venv glil body)
(define-record <venv> parent nexts closure?)
;; key is either a symbol or the list (MODNAME SYM PUBLIC?)
(define-record (<vlink-now> key))
(define-record (<vlink-later> key))
(define-record (<vdefine> name))
(define-record (<bytespec> vars bytes meta objs closure?))
(define-record <vlink-now> key)
(define-record <vlink-later> key)
(define-record <vdefine> name)
(define-record <bytespec> vars bytes meta objs closure?)
;;;

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

@ -31,7 +31,7 @@
;;; Debugger
;;;
(define-record (<debugger> vm chain index))
(define-record <debugger> vm chain index)
(define (vm-debugger vm)
(let ((chain (vm-last-frame-chain vm)))

8
test-suite/tests/compiler.test
View file

@ -40,15 +40,15 @@
;; fixme: compiling with #t or module
(pass-if "recompiling with environment"
(equal? ((compile '(lambda () x) env))
(equal? ((compile '(lambda () x) #:env env))
1))
(pass-if "recompiling with environment/2"
(equal? ((compile '(lambda () (set! x (1+ x)) x) env))
(equal? ((compile '(lambda () (set! x (1+ x)) x) #:env env))
2))
(pass-if "recompiling with environment/3"
(equal? ((compile '(lambda () x) env))
(equal? ((compile '(lambda () x) #:env env))
2))
)
@ -57,6 +57,6 @@
10))
(pass-if "compile environment is a module"
(equal? ((compile '(lambda () 10) (current-module)))
(equal? ((compile '(lambda () 10) #:env (current-module)))
10))
)

7
testsuite/run-vm-tests.scm
View file

@ -22,13 +22,12 @@
(system vm disasm)
(system base compile)
(system base language)
(language scheme spec)
(language objcode spec)
(srfi srfi-1)
(ice-9 r5rs))
(define %scheme (lookup-language 'scheme))
(define (fetch-sexp-from-file file)
(with-input-from-file file
(lambda ()
@ -40,7 +39,7 @@
(define (compile-to-objcode sexp)
"Compile the expression @var{sexp} into a VM program and return it."
(compile-in sexp (current-module) %scheme))
(compile sexp #:from scheme #:to objcode))
(define (run-vm-program objcode)
"Run VM program contained into @var{objcode}."