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
-SUBDIRS=scheme
+SUBDIRS=scheme ghil glil objcode value
--- /dev/null
+SOURCES = spec.scm
+modpath = language/ghil
+include $(top_srcdir)/am/guilec
(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)))))
#:version "0.3"
#:reader read
#:printer write-ghil
- #:translator translate
+ #:parser parse
+ #:compilers `((,glil . ,compile-il))
)
--- /dev/null
+SOURCES = spec.scm
+modpath = language/glil
+include $(top_srcdir)/am/guilec
--- /dev/null
+;;; 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))
+ )
--- /dev/null
+SOURCES = spec.scm
+modpath = language/objcode
+include $(top_srcdir)/am/guilec
--- /dev/null
+;;; 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))
+ )
;;; 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))
;;;
#:version "0.5"
#:reader read
#:read-file read-file
- #:translator translate
+ #:compilers `((,ghil . ,translate))
#:evaluator (lambda (x module) (primitive-eval x))
#:printer write
)
#: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 '()
- (lambda (env vars)
- (make-ghil-lambda env #f vars #f '() (translate-1 env #f x)))))
+;;; 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))))
+
+
+\f
+
+(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)
+ (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)))))))))
\f
;;;
;; macro would do the trick; but it's good to test the mv-bind
;; code.
(receive (syms rest) (parse-formals formals)
- (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)))))))
+ (let ((producer (retrans `(lambda () ,producer-exp))))
+ (call-with-ghil-bindings e syms
+ (lambda (vars)
+ (make-ghil-mv-bind e l producer
+ vars rest (trans-body e l body))))))))
(define-scheme-translator values
((,x) (retrans x))
--- /dev/null
+SOURCES = spec.scm
+modpath = language/value
+include $(top_srcdir)/am/guilec
--- /dev/null
+;;; 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
+ )
(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))
,@(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)
;;; 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))
;;;
;;;
(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
- (lambda ()
- (with-output-to-port tmp
- (lambda () (proc (current-output-port))))
- (rename-file template filename))
+ (call-once
(lambda ()
- (delete-file template)))))
+ (with-throw-handler #t
+ (lambda ()
+ (with-output-to-port tmp
+ (lambda () (proc (current-output-port))))
+ (rename-file template filename))
+ (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)
(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))
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))))))
-
\f
;;;
-;;; Scheme compiler interface
+;;; 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))
+ (call-with-input-file file
+ (or (language-read-file lang)
+ (error "language has no #:read-file" lang))))
+
+(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 (or (null? keys)
- (and (car keys) (memq (car keys) opts)))
+ (if (null? (cdr langs))
(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))
- 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)))
+ (lp (cdr langs)
+ (cons (assq-ref (language-compilers (car langs)) (cadr langs))
+ out)))))
-(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 (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 (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)))
+(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)
-(fluid-set! *current-language* (lookup-language 'scheme))
+(define* (compile x #:key
+ (env #f)
+ (from (current-language))
+ (to value)
+ (opts '()))
+ (compile-fold (compile-passes from to opts)
+ x
+ env
+ opts))
;;; 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-name language-title language-version language-reader
+ language-printer language-parser language-read-file
+ language-compilers language-evaluator
+
+ lookup-compilation-order invalidate-compilation-cache!))
\f
;;;
;;; Language class
;;;
-(define-record (<language> name title version reader printer
- (read-file #f)
- (expander #f)
- (translator #f)
- (evaluator #f)
- (environment #f)
- ))
+(define-record <language>
+ name
+ title
+ version
+ reader
+ printer
+ (parser #f)
+ (read-file #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)))
(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)))))
(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)
#: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)))))
\f
;;;
;;; Variables
;;;
-(define-record (<ghil-var> env name kind (index #f)))
+(define-record <ghil-var> env name kind (index #f))
\f
;;;
;;; 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))
;;; 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?
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)
(<glil-mv-call> nargs ra))
\f
-;;;
-;;; Parser
-;;;
-
-;;; (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)))))
-
-\f
-;;;
-;;; Unparser
-;;;
-
-(define (unparse glil)
+(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 (unparse-glil glil)
(record-case glil
;; meta
((<glil-asm> vars meta body)
- `(@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))
+ `(asm (,(glil-vars-nargs vars) ,(glil-vars-nrest vars)
+ ,(glil-vars-nlocs vars) ,(glil-vars-nexts vars))
+ ,meta
+ ,@(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))))
-
-\f
-;;;
-;;; 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)))))
#: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)
(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)
-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
(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))))
Profile execution."
(apply vm-profile
(repl-vm repl)
- (repl-compile repl form)
+ (repl-compile repl (repl-parse repl form))
opts))
\f
-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
#:use-module (system base language)
#:use-module (system vm vm)
#: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!
- puts ->string user-error))
+ repl-tm-stats repl-gc-stats repl-vm-stats
+ repl-welcome repl-prompt repl-read repl-compile repl-eval
+ repl-parse repl-print repl-option-ref repl-option-set!
+ puts ->string user-error))
\f
;;;
;;; 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)
((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)))))
+ (eval form (current-module))
+ (vm-load (repl-vm repl) (repl-compile repl form '())))))
(define (repl-print repl val)
(if (not (eq? val *unspecified*))
(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)
;;; 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?)
\f
;;;
;;; Debugger
;;;
-(define-record (<debugger> vm chain index))
+(define-record <debugger> vm chain index)
(define (vm-debugger vm)
(let ((chain (vm-last-frame-chain vm)))
;; 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))
)
10))
(pass-if "compile environment is a module"
- (equal? ((compile '(lambda () 10) (current-module)))
+ (equal? ((compile '(lambda () 10) #:env (current-module)))
10))
)
\ No newline at end of file
(system vm disasm)
(system base compile)
(system base language)
-
+ (language scheme spec)
+ (language objcode spec)
(srfi srfi-1)
(ice-9 r5rs))
\f
-(define %scheme (lookup-language 'scheme))
-
(define (fetch-sexp-from-file file)
(with-input-from-file file
(lambda ()
(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}."
HCoop / bpt / guile.git / commitdiff